From 3ea1b3f47b2bcc4fd3a4192e4409e142893a8241 Mon Sep 17 00:00:00 2001
From: Whitney Armstrong <whit@temple.edu>
Date: Thu, 16 Aug 2012 10:19:34 -0400
Subject: [PATCH] Added all the files
---
BTRACKING/.cvsignore | 2 +
BTRACKING/CVS/Entries | 45 +
BTRACKING/CVS/Repository | 1 +
BTRACKING/CVS/Root | 1 +
BTRACKING/CVS/Tag | 1 +
BTRACKING/Makefile | 11 +
BTRACKING/Makefile.Unix | 60 +
BTRACKING/b_add_neighbors.f | 468 ++++
BTRACKING/b_analyze_pedestal.f | 107 +
BTRACKING/b_calc_cluster_time.f | 420 +++
BTRACKING/b_calc_pedestal.f | 295 +++
BTRACKING/b_calc_physics.f | 221 ++
BTRACKING/b_calc_shower_coord.f | 219 ++
BTRACKING/b_dump_peds.f | 160 ++
BTRACKING/b_fill_bigcal_arrays.f | 72 +
BTRACKING/b_fill_eff_hists.f | 61 +
BTRACKING/b_find_clusters.f | 530 ++++
BTRACKING/b_find_clusters_new.f | 585 +++++
BTRACKING/b_find_clusters_old.f | 1154 ++++++++
BTRACKING/b_generate_geometry.f | 102 +
BTRACKING/b_guess_ecell.f | 151 ++
BTRACKING/b_init_bad_list.f | 81 +
BTRACKING/b_init_gain.f | 97 +
BTRACKING/b_init_histid.f | 187 ++
BTRACKING/b_init_physics.f | 31 +
BTRACKING/b_init_shower.f | 83 +
BTRACKING/b_init_tof.f | 69 +
BTRACKING/b_matrix_accum.f | 162 ++
BTRACKING/b_print_cluster.f | 45 +
BTRACKING/b_print_raw_adc.f | 56 +
BTRACKING/b_print_raw_bad.f | 48 +
BTRACKING/b_print_raw_tdc.f | 45 +
BTRACKING/b_print_raw_trig.f | 62 +
BTRACKING/b_prune_clusters.f | 217 ++
BTRACKING/b_raw_dump_all.f | 28 +
BTRACKING/b_rebuild_cluster.f | 144 +
BTRACKING/b_reconstruction.f | 245 ++
BTRACKING/b_register_param.f | 32 +
BTRACKING/b_report_bad_data.f | 24 +
BTRACKING/b_sparsify_prot.f | 87 +
BTRACKING/b_sparsify_rcs.f | 95 +
BTRACKING/b_strip_tdc.f | 62 +
BTRACKING/b_strip_trig.f | 107 +
BTRACKING/b_trans_prot.f | 115 +
BTRACKING/b_trans_rcs.f | 124 +
BTRACKING/b_trans_tdc.f | 103 +
BTRACKING/b_trans_trig.f | 273 ++
BTRACKING/bigcal_calib.f | 646 +++++
CODA/.cvsignore | 1 +
CODA/CVS/Entries | 14 +
CODA/CVS/Repository | 1 +
CODA/CVS/Root | 1 +
CODA/CVS/Tag | 1 +
CODA/Makefile | 8 +
CODA/Makefile.Unix | 98 +
CODA/ceMsg.h | 53 +
CODA/ceMsgLib.c | 162 ++
CODA/ceMsgTbl.c | 26 +
CODA/evfile.msg | 40 +
CODA/evfile_msg.h | 18 +
CODA/evio.c | 1213 +++++++++
CODA/evtest.c | 134 +
CODA/facility | 33 +
CODA/misc.c | 7 +
CODA/swap_util.c | 463 ++++
CTP/.cvsignore | 5 +
CTP/CVS/Entries | 37 +
CTP/CVS/Repository | 1 +
CTP/CVS/Root | 1 +
CTP/CVS/Tag | 1 +
CTP/Makefile | 3 +
CTP/Makefile.Unix | 251 ++
CTP/cfortran.h | 2374 +++++++++++++++++
CTP/cfortran.h.debian | 2510 ++++++++++++++++++
CTP/daVar.h | 133 +
CTP/daVarHandlers.c | 497 ++++
CTP/daVarHandlers.h | 71 +
CTP/daVarHash.h | 57 +
CTP/daVarHashLib.c | 337 +++
CTP/daVarRegister.c | 723 +++++
CTP/daVarRpc.x | 114 +
CTP/daVarRpcProc.c | 452 ++++
CTP/daVarServ.c | 153 ++
CTP/fnmatch.h | 61 +
CTP/hbook.h | 417 +++
CTP/makereg.c | 689 +++++
CTP/th.h | 96 +
CTP/thClient.c | 607 +++++
CTP/thGethit.c | 517 ++++
CTP/thGroup.c | 336 +++
CTP/thGroup.h | 47 +
CTP/thHandlers.c | 213 ++
CTP/thHist.c | 882 +++++++
CTP/thInternal.h | 124 +
CTP/thLoad.c | 736 ++++++
CTP/thParm.c | 454 ++++
CTP/thReport.c | 411 +++
CTP/thRootStuff.cpp | 118 +
CTP/thTest.c | 538 ++++
CTP/thTestExecute.c | 724 +++++
CTP/thTestParse.c | 1159 ++++++++
CTP/thTestParse.h | 168 ++
CTP/thTree.c | 562 ++++
CTP/thUtils.c | 1040 ++++++++
CTP/thUtils.h | 68 +
CVS/Entries | 2 +
CVS/Entries.Log | 23 +
CVS/Repository | 1 +
CVS/Root | 1 +
CVS/Tag | 1 +
CVSROOT/CVS/Entries | 10 +
CVSROOT/CVS/Repository | 1 +
CVSROOT/CVS/Root | 1 +
CVSROOT/CVS/Tag | 1 +
CVSROOT/checkoutlist | 13 +
CVSROOT/commitinfo | 15 +
CVSROOT/cvswrappers | 22 +
CVSROOT/editinfo | 21 +
CVSROOT/loginfo | 21 +
CVSROOT/modules | 23 +
CVSROOT/notify | 12 +
CVSROOT/rcsinfo | 13 +
CVSROOT/taginfo | 20 +
ENGINE/.cvsignore | 2 +
ENGINE/CVS/Entries | 157 ++
ENGINE/CVS/Repository | 1 +
ENGINE/CVS/Root | 1 +
ENGINE/CVS/Tag | 1 +
ENGINE/Makefile | 8 +
ENGINE/Makefile.Unix | 371 +++
ENGINE/b_clear_event.f | 161 ++
ENGINE/b_cosmic_ntuple_init.f | 173 ++
ENGINE/b_initialize.f | 199 ++
ENGINE/b_keep_results.f | 45 +
ENGINE/b_ntuple_change.f | 72 +
ENGINE/b_ntuple_clear.f | 33 +
ENGINE/b_ntuple_close.f | 64 +
ENGINE/b_ntuple_init.f | 118 +
ENGINE/b_ntuple_keep.f | 579 ++++
ENGINE/b_ntuple_open.f | 236 ++
ENGINE/b_ntuple_register.f | 28 +
ENGINE/b_ntuple_shutdown.f | 44 +
ENGINE/b_proper_shutdown.f | 56 +
ENGINE/b_register_variables.f | 47 +
ENGINE/b_reset_event.f | 458 ++++
ENGINE/b_tree_init.f | 31 +
ENGINE/bigcal_mc_reconstruction.f | 226 ++
ENGINE/c_clear_event.f | 56 +
ENGINE/c_initialize.f | 81 +
ENGINE/c_keep_results.f | 66 +
ENGINE/c_ntuple_change.f | 87 +
ENGINE/c_ntuple_clear.f | 30 +
ENGINE/c_ntuple_close.f | 77 +
ENGINE/c_ntuple_init.f | 250 ++
ENGINE/c_ntuple_keep.f | 209 ++
ENGINE/c_ntuple_open.f | 115 +
ENGINE/c_ntuple_register.f | 47 +
ENGINE/c_ntuple_shutdown.f | 75 +
ENGINE/c_physics.f | 145 +
ENGINE/c_proper_shutdown.f | 88 +
ENGINE/c_reconstruction.f | 68 +
ENGINE/c_register_variables.f | 83 +
ENGINE/c_reset_event.f | 49 +
ENGINE/engine.f | 1282 +++++++++
ENGINE/g_analyze_beam_pedestal.f | 51 +
ENGINE/g_analyze_misc.f | 402 +++
ENGINE/g_analyze_pedestal.f | 64 +
ENGINE/g_analyze_scaler_bank.f | 387 +++
ENGINE/g_analyze_scalers.f | 269 ++
ENGINE/g_analyze_scalers_by_banks.f | 121 +
ENGINE/g_apply_offsets.f | 59 +
ENGINE/g_calc_beam_pedestal.f | 122 +
ENGINE/g_calc_bpm_pedestal.f | 33 +
ENGINE/g_calc_pedestal.f | 64 +
ENGINE/g_calc_raster_pedestal.f | 39 +
ENGINE/g_clear_event.f | 154 ++
ENGINE/g_ctp_database.f | 276 ++
ENGINE/g_decode_clear.f | 58 +
ENGINE/g_decode_config.f | 286 ++
ENGINE/g_decode_event_by_banks.f | 115 +
ENGINE/g_decode_fb_bank.f | 763 ++++++
ENGINE/g_decode_fb_detector.f | 501 ++++
ENGINE/g_decode_init.f | 56 +
ENGINE/g_decode_scalers.f | 66 +
ENGINE/g_dump_histograms.f | 69 +
ENGINE/g_dump_peds.f | 48 +
ENGINE/g_examine_control_event.f | 160 ++
ENGINE/g_examine_epics_event.f | 138 +
ENGINE/g_examine_go_info.f | 178 ++
ENGINE/g_examine_physics_event.f | 138 +
ENGINE/g_examine_picture_event.f | 90 +
ENGINE/g_extract_kinematics.f | 231 ++
ENGINE/g_get_next_event.f | 138 +
ENGINE/g_init_filenames.f | 268 ++
ENGINE/g_initialize.f | 511 ++++
ENGINE/g_keep_results.f | 158 ++
ENGINE/g_kludgeup_kinematics.f | 130 +
ENGINE/g_ntuple_init.f | 153 ++
ENGINE/g_ntuple_shutdown.f | 64 +
ENGINE/g_open_source.f | 133 +
ENGINE/g_output_thresholds.f | 169 ++
ENGINE/g_preproc_event.f | 89 +
ENGINE/g_preproc_open.f | 58 +
ENGINE/g_proper_shutdown.f | 199 ++
ENGINE/g_reconstruction.f | 324 +++
ENGINE/g_register_variables.f | 250 ++
ENGINE/g_reset_event.f | 175 ++
ENGINE/g_scaler_reset_event.f | 103 +
ENGINE/g_target_initialize.f | 49 +
ENGINE/g_trans_misc.f | 162 ++
ENGINE/g_tree_init.f | 40 +
ENGINE/g_write_event.f | 58 +
ENGINE/gep_check_bigcal.f | 323 +++
ENGINE/gep_clear_event.f | 69 +
ENGINE/gep_fill_hist.f | 80 +
ENGINE/gep_init_histid.f | 69 +
ENGINE/gep_initialize.f | 47 +
ENGINE/gep_keep_results.f | 33 +
ENGINE/gep_ntuple_change.f | 68 +
ENGINE/gep_ntuple_clear.f | 7 +
ENGINE/gep_ntuple_close.f | 64 +
ENGINE/gep_ntuple_init.f | 199 ++
ENGINE/gep_ntuple_keep.f | 199 ++
ENGINE/gep_ntuple_open.f | 120 +
ENGINE/gep_ntuple_register.f | 26 +
ENGINE/gep_ntuple_shutdown.f | 45 +
ENGINE/gep_physics.f | 613 +++++
ENGINE/gep_proper_shutdown.f | 46 +
ENGINE/gep_reconstruction.f | 42 +
ENGINE/gep_register_variables.f | 36 +
ENGINE/gep_reset_event.f | 74 +
ENGINE/gep_tree_init.f | 31 +
ENGINE/h_apply_offsets.f | 72 +
ENGINE/h_clear_event.f | 196 ++
ENGINE/h_field03.f | 162 ++
ENGINE/h_fieldcorr.f | 87 +
ENGINE/h_fpp_nt_change.f | 87 +
ENGINE/h_fpp_nt_close.f | 77 +
ENGINE/h_fpp_nt_init.f | 101 +
ENGINE/h_fpp_nt_keep.f | 199 ++
ENGINE/h_fpp_nt_open.f | 206 ++
ENGINE/h_fpp_nt_register.f | 38 +
ENGINE/h_fpp_nt_shutdown.f | 56 +
ENGINE/h_fpp_ntup.cwn | 112 +
ENGINE/h_initialize.f | 153 ++
ENGINE/h_keep_results.f | 109 +
ENGINE/h_ntuple_change.f | 87 +
ENGINE/h_ntuple_clear.f | 30 +
ENGINE/h_ntuple_close.f | 77 +
ENGINE/h_ntuple_init.f | 287 ++
ENGINE/h_ntuple_keep.f | 270 ++
ENGINE/h_ntuple_open.f | 117 +
ENGINE/h_ntuple_register.f | 47 +
ENGINE/h_ntuple_shutdown.f | 78 +
ENGINE/h_proper_shutdown.f | 106 +
ENGINE/h_register_variables.f | 126 +
ENGINE/h_reset_event.f | 312 +++
ENGINE/h_sv_nt_init.f | 214 ++
ENGINE/h_sv_nt_keep.f | 92 +
ENGINE/h_sv_nt_register.f | 43 +
ENGINE/h_sv_nt_shutdown.f | 117 +
ENGINE/h_tree_init.f | 30 +
ENGINE/params03.f | 110 +
ENGINE/s_apply_offsets.f | 77 +
ENGINE/s_clear_event.f | 137 +
ENGINE/s_fieldcorr.f | 76 +
ENGINE/s_initialize.f | 145 +
ENGINE/s_keep_results.f | 73 +
ENGINE/s_ntuple_change.f | 87 +
ENGINE/s_ntuple_clear.f | 30 +
ENGINE/s_ntuple_close.f | 77 +
ENGINE/s_ntuple_init.f | 243 ++
ENGINE/s_ntuple_keep.f | 208 ++
ENGINE/s_ntuple_open.f | 115 +
ENGINE/s_ntuple_register.f | 47 +
ENGINE/s_ntuple_shutdown.f | 77 +
ENGINE/s_proper_shutdown.f | 111 +
ENGINE/s_register_variables.f | 101 +
ENGINE/s_reset_event.f | 336 +++
ENGINE/s_sv_nt_init.f | 207 ++
ENGINE/s_sv_nt_keep.f | 87 +
ENGINE/s_sv_nt_register.f | 43 +
ENGINE/s_sv_nt_shutdown.f | 117 +
EXE/CVS/Entries | 2 +
EXE/CVS/Repository | 1 +
EXE/CVS/Root | 1 +
EXE/CVS/Tag | 1 +
EXE/Makefile | 154 ++
F1TRIGGER/.cvsignore | 2 +
F1TRIGGER/CVS/Entries | 10 +
F1TRIGGER/CVS/Repository | 1 +
F1TRIGGER/CVS/Root | 1 +
F1TRIGGER/CVS/Tag | 1 +
F1TRIGGER/Makefile | 17 +
F1TRIGGER/Makefile.Unix | 55 +
F1TRIGGER/f1t_register_variables.f | 34 +
F1TRIGGER/f1trigger_clear_event.f | 26 +
F1TRIGGER/f1trigger_decode.f | 33 +
F1TRIGGER/f1trigger_register_variables.f | 30 +
F1TRIGGER/f1trigger_reset_event.f | 26 +
F1TRIGGER/f1trigger_sort_by_counter.f | 23 +
HACK/.cvsignore | 2 +
HACK/CVS/Entries | 9 +
HACK/CVS/Repository | 1 +
HACK/CVS/Root | 1 +
HACK/CVS/Tag | 1 +
HACK/Makefile | 8 +
HACK/Makefile.Unix | 73 +
HACK/hack_anal.f | 80 +
HACK/hack_copyevt.f | 66 +
HACK/hack_initialize.f | 37 +
HACK/hack_register_variables.f | 32 +
HACK/hack_shutdown.f | 27 +
HTRACKING/.cvsignore | 2 +
HTRACKING/CVS/Entries | 110 +
HTRACKING/CVS/Repository | 1 +
HTRACKING/CVS/Root | 1 +
HTRACKING/CVS/Tag | 1 +
HTRACKING/Makefile | 8 +
HTRACKING/Makefile.Unix | 209 ++
HTRACKING/h_aero.f | 212 ++
HTRACKING/h_analyze_pedestal.f | 190 ++
HTRACKING/h_cal.f | 155 ++
HTRACKING/h_cal_calib.f | 628 +++++
HTRACKING/h_cal_eff.f | 131 +
HTRACKING/h_cal_eff_shutdown.f | 76 +
HTRACKING/h_calc_pedestal.f | 411 +++
HTRACKING/h_cer.f | 44 +
HTRACKING/h_cer_eff.f | 81 +
HTRACKING/h_cer_eff_shutdown.f | 63 +
HTRACKING/h_chamnum.f | 31 +
HTRACKING/h_choose_single_hit.f | 99 +
HTRACKING/h_clusters_cal.f | 215 ++
HTRACKING/h_correct_cal.f | 64 +
HTRACKING/h_correct_cal_neg.f | 69 +
HTRACKING/h_correct_cal_pos.f | 80 +
HTRACKING/h_dc_eff.f | 54 +
HTRACKING/h_dc_eff_shutdown.f | 68 +
HTRACKING/h_dc_trk_eff.f | 80 +
HTRACKING/h_dc_trk_eff_shutdown.f | 83 +
HTRACKING/h_dpsifun.f | 62 +
HTRACKING/h_drift_dist_calc.f | 73 +
HTRACKING/h_drift_time_calc.f | 45 +
HTRACKING/h_dump_cal.f | 73 +
HTRACKING/h_dump_peds.f | 181 ++
HTRACKING/h_dump_tof.f | 103 +
HTRACKING/h_fcnchisq.f | 44 +
HTRACKING/h_fill_aero_raw_hist.f | 70 +
HTRACKING/h_fill_cal_hist.f | 78 +
HTRACKING/h_fill_dc_dec_hist.f | 74 +
HTRACKING/h_fill_dc_fp_hist.f | 83 +
HTRACKING/h_fill_dc_target_hist.f | 55 +
HTRACKING/h_fill_fpp.f | 271 ++
HTRACKING/h_fill_scin_raw_hist.f | 140 +
HTRACKING/h_find_best_stub.f | 97 +
HTRACKING/h_find_easy_space_point.f | 85 +
HTRACKING/h_fpp.f | 62 +
HTRACKING/h_fpp_drift.f | 549 ++++
HTRACKING/h_fpp_fit.f | 458 ++++
HTRACKING/h_fpp_geometry.f | 508 ++++
HTRACKING/h_fpp_statistics.f | 211 ++
HTRACKING/h_fpp_tracking.f | 996 +++++++
HTRACKING/h_generate_geometry.f | 390 +++
HTRACKING/h_init_cal.f | 85 +
HTRACKING/h_init_cer.f | 35 +
HTRACKING/h_init_fpp.f | 215 ++
HTRACKING/h_init_histid.f | 385 +++
HTRACKING/h_init_physics.f | 69 +
HTRACKING/h_init_scin.f | 107 +
HTRACKING/h_left_right.f | 373 +++
HTRACKING/h_link_stubs.f | 271 ++
HTRACKING/h_pattern_recognition.f | 243 ++
HTRACKING/h_physics.f | 526 ++++
HTRACKING/h_physics_stat.f | 108 +
HTRACKING/h_print_decoded_dc.f | 60 +
HTRACKING/h_print_links.f | 27 +
HTRACKING/h_print_pr.f | 39 +
HTRACKING/h_print_raw_dc.f | 48 +
HTRACKING/h_print_stubs.f | 37 +
HTRACKING/h_print_tar_tracks.f | 69 +
HTRACKING/h_print_tracks.f | 61 +
HTRACKING/h_prt_cal_clusters.f | 75 +
HTRACKING/h_prt_cal_decoded.f | 52 +
HTRACKING/h_prt_cal_raw.f | 66 +
HTRACKING/h_prt_cal_sparsified.f | 47 +
HTRACKING/h_prt_cal_tests.f | 50 +
HTRACKING/h_prt_cal_tracks.f | 50 +
HTRACKING/h_prt_dec_scin.f | 89 +
HTRACKING/h_prt_raw_scin.f | 68 +
HTRACKING/h_prt_tof.f | 77 +
HTRACKING/h_prt_track_tests.f | 63 +
HTRACKING/h_psifun.f | 56 +
HTRACKING/h_raw_dump_all.f | 50 +
HTRACKING/h_reconstruction.f | 317 +++
HTRACKING/h_register_param.f | 108 +
HTRACKING/h_report_bad_data.f | 106 +
HTRACKING/h_satcorr.f | 80 +
HTRACKING/h_scin_eff.f | 251 ++
HTRACKING/h_scin_eff_shutdown.f | 149 ++
HTRACKING/h_select_best_track.f | 116 +
HTRACKING/h_select_best_track_prune.f | 309 +++
HTRACKING/h_select_best_track_using_scin.f | 214 ++
HTRACKING/h_solve_3by3.f | 64 +
HTRACKING/h_sp_destroy.f | 154 ++
HTRACKING/h_sp_multiwire.f | 237 ++
HTRACKING/h_sparsify_cal.f | 137 +
HTRACKING/h_strip_scin.f | 109 +
HTRACKING/h_targ_trans.f | 348 +++
HTRACKING/h_targ_trans_init.f | 182 ++
HTRACKING/h_tof.f | 1014 +++++++
HTRACKING/h_tof_fit.f | 110 +
HTRACKING/h_tof_init.f | 120 +
HTRACKING/h_track.f | 122 +
HTRACKING/h_track_fit.f | 243 ++
HTRACKING/h_track_tests.f | 399 +++
HTRACKING/h_tracks_cal.f | 158 ++
HTRACKING/h_trans_cal.f | 136 +
HTRACKING/h_trans_cer.f | 52 +
HTRACKING/h_trans_dc.f | 351 +++
HTRACKING/h_trans_fpp.f | 254 ++
HTRACKING/h_trans_fpp_hms.f | 344 +++
HTRACKING/h_trans_misc.f | 83 +
HTRACKING/h_trans_scin.f | 508 ++++
HTRACKING/h_wire_center_calc.f | 52 +
HTRACKING/hms_sane_track.f | 383 +++
HTRACKING/mt19937.f | 161 ++
INCLUDE/CVS/Entries | 102 +
INCLUDE/CVS/Repository | 1 +
INCLUDE/CVS/Root | 1 +
INCLUDE/CVS/Tag | 1 +
INCLUDE/Makefile | 121 +
INCLUDE/b_ntuple.cmn | 320 +++
INCLUDE/b_ntuple.dte | 10 +
INCLUDE/bigcal_bypass_switches.cmn | 59 +
INCLUDE/bigcal_data_structures.cmn | 731 ++++++
INCLUDE/bigcal_filenames.cmn | 33 +
INCLUDE/bigcal_gain_parms.cmn | 154 ++
INCLUDE/bigcal_geometry.cmn | 47 +
INCLUDE/bigcal_hist_id.cmn | 121 +
INCLUDE/bigcal_shower_parms.cmn | 83 +
INCLUDE/bigcal_tof_parms.cmn | 46 +
INCLUDE/c_ntuple.cmn | 51 +
INCLUDE/c_ntuple.dte | 21 +
INCLUDE/coin_bypass_switches.cmn | 17 +
INCLUDE/coin_data_structures.cmn | 82 +
INCLUDE/coin_filenames.cmn | 38 +
INCLUDE/f1trigger_data_structures.cmn | 48 +
INCLUDE/gen_constants.par | 80 +
INCLUDE/gen_craw.cmn | 25 +
INCLUDE/gen_data_structures.cmn | 545 ++++
INCLUDE/gen_decode_F1tdc.cmn | 27 +
INCLUDE/gen_decode_common.cmn | 101 +
INCLUDE/gen_detectorids.par | 107 +
INCLUDE/gen_epics.cmn | 22 +
INCLUDE/gen_event_info.cmn | 28 +
INCLUDE/gen_filenames.cmn | 156 ++
INCLUDE/gen_input_info.cmn | 19 +
INCLUDE/gen_one_ev_gckine.cmn | 33 +
INCLUDE/gen_one_ev_gctrak.cmn | 69 +
INCLUDE/gen_one_ev_gcvolu.cmn | 36 +
INCLUDE/gen_one_ev_info.cmn | 55 +
INCLUDE/gen_one_ev_info.dte | 21 +
INCLUDE/gen_output_info.cmn | 19 +
INCLUDE/gen_pawspace.cmn | 39 +
INCLUDE/gen_routines.dec | 123 +
INCLUDE/gen_run_info.cmn | 112 +
INCLUDE/gen_run_info.dte | 31 +
INCLUDE/gen_run_pref.cmn | 39 +
INCLUDE/gen_run_pref.dte | 20 +
INCLUDE/gen_scalers.cmn | 209 ++
INCLUDE/gen_units.par | 38 +
INCLUDE/gep_data_structures.cmn | 174 ++
INCLUDE/gep_filenames.cmn | 12 +
INCLUDE/gep_hist_id.cmn | 79 +
INCLUDE/gep_ntuple.cmn | 39 +
INCLUDE/gep_ntuple.dte | 13 +
INCLUDE/h_fpp_ntuple.cmn | 35 +
INCLUDE/h_fpp_ntuple.dte | 13 +
INCLUDE/h_ntuple.cmn | 53 +
INCLUDE/h_ntuple.dte | 21 +
INCLUDE/h_sieve_ntuple.cmn | 42 +
INCLUDE/h_sieve_ntuple.dte | 22 +
INCLUDE/hack_.cmn | 36 +
INCLUDE/hms_aero_parms.cmn | 82 +
INCLUDE/hms_bypass_switches.cmn | 80 +
INCLUDE/hms_calorimeter.cmn | 303 +++
INCLUDE/hms_cer_parms.cmn | 81 +
INCLUDE/hms_data_structures.cmn | 775 ++++++
INCLUDE/hms_filenames.cmn | 51 +
INCLUDE/hms_fpp_event.cmn | 164 ++
INCLUDE/hms_fpp_params.cmn | 128 +
INCLUDE/hms_fpp_params.dte | 218 ++
INCLUDE/hms_geometry.cmn | 240 ++
INCLUDE/hms_id_histid.cmn | 223 ++
INCLUDE/hms_one_ev.par | 47 +
INCLUDE/hms_pedestals.cmn | 298 +++
INCLUDE/hms_physics_sing.cmn | 230 ++
INCLUDE/hms_recon_elements.cmn | 48 +
INCLUDE/hms_scin_parms.cmn | 207 ++
INCLUDE/hms_scin_tof.cmn | 165 ++
INCLUDE/hms_statistics.cmn | 219 ++
INCLUDE/hms_track_histid.cmn | 104 +
INCLUDE/hms_tracking.cmn | 482 ++++
INCLUDE/insane_scalers.cmn | 4 +
INCLUDE/mc_structures.cmn | 117 +
INCLUDE/s_ntuple.cmn | 52 +
INCLUDE/s_ntuple.dte | 21 +
INCLUDE/s_sieve_ntuple.cmn | 37 +
INCLUDE/s_sieve_ntuple.dte | 21 +
INCLUDE/sane_data_structures.cmn | 386 +++
INCLUDE/sane_filenames.cmn | 24 +
INCLUDE/sane_ntuple.cmn | 277 ++
INCLUDE/sane_ntuple.dte | 10 +
INCLUDE/sem_data_structures.cmn | 112 +
INCLUDE/sos_aero_parms.cmn | 44 +
INCLUDE/sos_bypass_switches.cmn | 68 +
INCLUDE/sos_calorimeter.cmn | 302 +++
INCLUDE/sos_cer_parms.cmn | 61 +
INCLUDE/sos_data_structures.cmn | 711 +++++
INCLUDE/sos_filenames.cmn | 43 +
INCLUDE/sos_geometry.cmn | 150 ++
INCLUDE/sos_id_histid.cmn | 119 +
INCLUDE/sos_lucite_parms.cmn | 39 +
INCLUDE/sos_one_ev.par | 52 +
INCLUDE/sos_pedestals.cmn | 290 ++
INCLUDE/sos_physics_sing.cmn | 222 ++
INCLUDE/sos_recon_elements.cmn | 50 +
INCLUDE/sos_scin_parms.cmn | 194 ++
INCLUDE/sos_scin_tof.cmn | 147 ++
INCLUDE/sos_statistics.cmn | 193 ++
INCLUDE/sos_track_histid.cmn | 103 +
INCLUDE/sos_tracking.cmn | 429 +++
ONEEV/CVS/Entries | 36 +
ONEEV/CVS/Repository | 1 +
ONEEV/CVS/Root | 1 +
ONEEV/CVS/Tag | 1 +
ONEEV/Makefile | 8 +
ONEEV/Makefile.Unix | 183 ++
ONEEV/evdisplay.f | 275 ++
ONEEV/g_uglast.f | 18 +
ONEEV/g_ugsvolu.f | 34 +
ONEEV/glvolu.f | 538 ++++
ONEEV/h_one_ev_cal.f | 51 +
ONEEV/h_one_ev_det_reset.f | 132 +
ONEEV/h_one_ev_detectors.f | 21 +
ONEEV/h_one_ev_display.f | 38 +
ONEEV/h_one_ev_generate.f | 513 ++++
ONEEV/h_one_ev_geometry.f | 441 ++++
ONEEV/h_one_ev_head_view.f | 100 +
ONEEV/h_one_ev_hodo.f | 57 +
ONEEV/h_one_ev_persp_view.f | 66 +
ONEEV/h_one_ev_topside_view.f | 49 +
ONEEV/h_one_ev_track.f | 75 +
ONEEV/h_one_ev_wc.f | 79 +
ONEEV/h_uginit.f | 31 +
ONEEV/revdis_ask.f | 130 +
ONEEV/revdis_getev.f | 51 +
ONEEV/revdis_init.f | 161 ++
ONEEV/s_one_ev_cal.f | 53 +
ONEEV/s_one_ev_det_reset.f | 119 +
ONEEV/s_one_ev_detectors.f | 22 +
ONEEV/s_one_ev_display.f | 35 +
ONEEV/s_one_ev_generate.f | 486 ++++
ONEEV/s_one_ev_geometry.f | 455 ++++
ONEEV/s_one_ev_head_view.f | 97 +
ONEEV/s_one_ev_hodo.f | 57 +
ONEEV/s_one_ev_persp_view.f | 70 +
ONEEV/s_one_ev_topside_view.f | 49 +
ONEEV/s_one_ev_track.f | 77 +
ONEEV/s_one_ev_wc.f | 71 +
ONEEV/s_uginit.f | 37 +
ONLINE/CVS/Entries | 10 +
ONLINE/CVS/Repository | 1 +
ONLINE/CVS/Root | 1 +
ONLINE/CVS/Tag | 1 +
ONLINE/Makefile | 81 +
ONLINE/usrdownload.f | 63 +
ONLINE/usrdump.f | 25 +
ONLINE/usrend.f | 29 +
ONLINE/usrevent.f | 81 +
ONLINE/usrgo.f | 25 +
ONLINE/usrmain.f | 33 +
ONLINE/usrpause.f | 13 +
ONLINE/usrprestart.f | 52 +
PORT/.cvsignore | 1 +
PORT/CVS/Entries | 9 +
PORT/CVS/Repository | 1 +
PORT/CVS/Root | 1 +
PORT/CVS/Tag | 1 +
PORT/Makefile | 8 +
PORT/Makefile.Unix | 67 +
PORT/bit_wrappers.f | 57 +
PORT/cwrappers.c | 22 +
PORT/other_wrappers.f | 18 +
PORT/ran_wrappers.f | 26 +
PORT/trig_wrappers.f | 30 +
SANE/#sane_ntuple_keep.f# | 776 ++++++
SANE/.cvsignore | 3 +
SANE/CVS/Entries | 24 +
SANE/CVS/Repository | 1 +
SANE/CVS/Root | 1 +
SANE/CVS/Tag | 1 +
SANE/Makefile | 14 +
SANE/Makefile.Unix | 60 +
SANE/sane_analyze_pedestal.f | 131 +
SANE/sane_calc_pedestal.f | 107 +
SANE/sane_clear_event.f | 148 ++
SANE/sane_close_scalers.f | 80 +
SANE/sane_decode.f | 110 +
SANE/sane_dump_ntup_var.f | 114 +
SANE/sane_geometry_suplement.f | 162 ++
SANE/sane_keep_results.f | 56 +
SANE/sane_n100xye.f | 2767 ++++++++++++++++++++
SANE/sane_ntup_change.f | 80 +
SANE/sane_ntup_close.f | 159 ++
SANE/sane_ntup_init.f | 182 ++
SANE/sane_ntup_open.f | 615 +++++
SANE/sane_ntup_register.f | 29 +
SANE/sane_ntup_shutdown.f | 45 +
SANE/sane_ntuple_keep.f | 641 +++++
SANE/sane_physics.f | 1248 +++++++++
SANE/sane_register_variables.f | 41 +
SANE/sane_reset_event.f | 150 ++
SANE/sane_trgtrack.f | 903 +++++++
SEM/.cvsignore | 2 +
SEM/CVS/Entries | 12 +
SEM/CVS/Repository | 1 +
SEM/CVS/Root | 1 +
SEM/CVS/Tag | 1 +
SEM/Makefile | 17 +
SEM/Makefile.Unix | 55 +
SEM/sem_analyze_pedestal.f | 58 +
SEM/sem_calc_pedestal.f | 23 +
SEM/sem_calc_sr_beampos.f | 128 +
SEM/sem_clear_event.f | 24 +
SEM/sem_decode.f | 31 +
SEM/sem_fill_tbpm.f | 154 ++
SEM/sem_register_variables.f | 38 +
SEM/sem_reset_event.f | 24 +
STRACKING/.cvsignore | 2 +
STRACKING/CVS/Entries | 100 +
STRACKING/CVS/Repository | 1 +
STRACKING/CVS/Root | 1 +
STRACKING/CVS/Tag | 1 +
STRACKING/Makefile | 8 +
STRACKING/Makefile.Unix | 178 ++
STRACKING/s_aero.f | 131 +
STRACKING/s_analyze_pedestal.f | 182 ++
STRACKING/s_cal.f | 157 ++
STRACKING/s_cal_calib.f | 628 +++++
STRACKING/s_cal_eff.f | 129 +
STRACKING/s_cal_eff_shutdown.f | 78 +
STRACKING/s_calc_pedestal.f | 359 +++
STRACKING/s_cer.f | 44 +
STRACKING/s_cer_eff.f | 81 +
STRACKING/s_cer_eff_shutdown.f | 63 +
STRACKING/s_chamnum.f | 28 +
STRACKING/s_choose_single_hit.f | 96 +
STRACKING/s_clusters_cal.f | 211 ++
STRACKING/s_correct_cal.f | 62 +
STRACKING/s_correct_cal_neg.f | 59 +
STRACKING/s_correct_cal_pos.f | 61 +
STRACKING/s_correct_cal_two.f | 49 +
STRACKING/s_dc_eff.f | 54 +
STRACKING/s_dc_eff_shutdown.f | 68 +
STRACKING/s_dc_trk_eff.f | 81 +
STRACKING/s_dc_trk_eff_shutdown.f | 77 +
STRACKING/s_dpsifun.f | 62 +
STRACKING/s_drift_dist_calc.f | 67 +
STRACKING/s_drift_time_calc.f | 44 +
STRACKING/s_dump_cal.f | 69 +
STRACKING/s_dump_peds.f | 152 ++
STRACKING/s_dump_tof.f | 97 +
STRACKING/s_fcnchisq.f | 46 +
STRACKING/s_fill_cal_hist.f | 81 +
STRACKING/s_fill_dc_dec_hist.f | 72 +
STRACKING/s_fill_dc_fp_hist.f | 93 +
STRACKING/s_fill_dc_target_hist.f | 65 +
STRACKING/s_fill_scin_raw_hist.f | 119 +
STRACKING/s_find_best_stub.f | 90 +
STRACKING/s_find_easy_space_point.f | 84 +
STRACKING/s_generate_geometry.f | 273 ++
STRACKING/s_init_cal.f | 79 +
STRACKING/s_init_cer.f | 35 +
STRACKING/s_init_histid.f | 240 ++
STRACKING/s_init_physics.f | 69 +
STRACKING/s_init_scin.f | 103 +
STRACKING/s_initialize_fitting.f | 34 +
STRACKING/s_left_right.f | 262 ++
STRACKING/s_link_stubs.f | 264 ++
STRACKING/s_lucite.f | 96 +
STRACKING/s_pattern_recognition.f | 211 ++
STRACKING/s_physics.f | 486 ++++
STRACKING/s_physics_stat.f | 104 +
STRACKING/s_print_decoded_dc.f | 60 +
STRACKING/s_print_links.f | 27 +
STRACKING/s_print_pr.f | 39 +
STRACKING/s_print_raw_dc.f | 48 +
STRACKING/s_print_stubs.f | 44 +
STRACKING/s_print_tar_tracks.f | 71 +
STRACKING/s_print_tracks.f | 62 +
STRACKING/s_prt_cal_clusters.f | 75 +
STRACKING/s_prt_cal_decoded.f | 52 +
STRACKING/s_prt_cal_raw.f | 64 +
STRACKING/s_prt_cal_sparsified.f | 47 +
STRACKING/s_prt_cal_tests.f | 50 +
STRACKING/s_prt_cal_tracks.f | 47 +
STRACKING/s_prt_dec_scin.f | 89 +
STRACKING/s_prt_raw_scin.f | 82 +
STRACKING/s_prt_tof.f | 62 +
STRACKING/s_prt_track_tests.f | 63 +
STRACKING/s_psifun.f | 56 +
STRACKING/s_raw_dump_all.f | 50 +
STRACKING/s_reconstruction.f | 258 ++
STRACKING/s_register_param.f | 97 +
STRACKING/s_report_bad_data.f | 106 +
STRACKING/s_satcorr.f | 85 +
STRACKING/s_scin_eff.f | 222 ++
STRACKING/s_scin_eff_shutdown.f | 148 ++
STRACKING/s_select_best_track.f | 112 +
STRACKING/s_select_best_track_prune.f | 304 +++
STRACKING/s_select_best_track_using_scin.f | 220 ++
STRACKING/s_solve_3by3.f | 60 +
STRACKING/s_sparsify_cal.f | 136 +
STRACKING/s_strip_scin.f | 91 +
STRACKING/s_targ_trans.f | 225 ++
STRACKING/s_targ_trans_init.f | 175 ++
STRACKING/s_tdc_time_per_channel.f | 36 +
STRACKING/s_tdc_zero.f | 39 +
STRACKING/s_tof.f | 444 ++++
STRACKING/s_tof_fit.f | 98 +
STRACKING/s_tof_init.f | 104 +
STRACKING/s_track.f | 103 +
STRACKING/s_track_fit.f | 228 ++
STRACKING/s_track_tests.f | 421 +++
STRACKING/s_tracks_cal.f | 165 ++
STRACKING/s_trans_cal.f | 135 +
STRACKING/s_trans_cer.f | 52 +
STRACKING/s_trans_dc.f | 172 ++
STRACKING/s_trans_misc.f | 61 +
STRACKING/s_trans_scin.f | 353 +++
STRACKING/s_wire_center_calc.f | 48 +
SYNCFILTER/CVS/Entries | 3 +
SYNCFILTER/CVS/Repository | 1 +
SYNCFILTER/CVS/Root | 1 +
SYNCFILTER/CVS/Tag | 1 +
SYNCFILTER/Makefile | 14 +
SYNCFILTER/syncfilter.c | 369 +++
T20/CVS/Entries | 63 +
T20/CVS/Repository | 1 +
T20/CVS/Root | 1 +
T20/CVS/Tag | 1 +
T20/Makefile | 8 +
T20/Makefile.Unix | 182 ++
T20/g_analyze_misc.f | 100 +
T20/g_analyze_pedestal.f | 41 +
T20/g_analyze_scalers.f | 216 ++
T20/g_calc_pedestal.f | 41 +
T20/g_clear_event.f | 95 +
T20/g_decode_fb_bank.f | 361 +++
T20/g_decode_fb_detector.f | 335 +++
T20/g_examine_go_info.f | 136 +
T20/g_get_next_event.f | 76 +
T20/g_init_filenames.f | 191 ++
T20/g_initialize.f | 326 +++
T20/g_open_source.f | 71 +
T20/g_proper_shutdown.f | 160 ++
T20/g_reconstruction.f | 152 ++
T20/g_register_variables.f | 163 ++
T20/g_reset_event.f | 151 ++
T20/g_scaler.f | 81 +
T20/g_trans_misc.f | 62 +
T20/gen_data_structures.cmn | 333 +++
T20/gen_misc.cmn | 59 +
T20/gen_run_info.cmn | 93 +
T20/h_ntuple_init.f | 239 ++
T20/h_ntuple_keep.f | 136 +
T20/t20_bypass_switches.cmn | 19 +
T20/t20_data_structures.cmn | 177 ++
T20/t20_filenames.cmn | 25 +
T20/t20_geometry.cmn | 33 +
T20/t20_hms.cmn | 19 +
T20/t20_hodo.cmn | 73 +
T20/t20_hodo_parms.cmn | 22 +
T20/t20_misc.cmn | 82 +
T20/t20_pedestals.cmn | 16 +
T20/t20_reg_polder_structures.cmn | 406 +++
T20/t20_test_detectors.cmn | 359 +++
T20/t20_test_histid.cmn | 78 +
T20/t20_track_histid.cmn | 24 +
T20/t20_tracking.cmn | 73 +
T20/t_analyze_pedestal.f | 24 +
T20/t_calc_pedestal.f | 30 +
T20/t_clear_event.f | 53 +
T20/t_dump_peds.f | 44 +
T20/t_hms.f | 55 +
T20/t_hodos.f | 84 +
T20/t_init_histid.f | 200 ++
T20/t_init_physics.f | 69 +
T20/t_initialize.f | 94 +
T20/t_misc.f | 160 ++
T20/t_mwpc.f | 190 ++
T20/t_ntuple.cmn | 38 +
T20/t_ntuple_register.f | 43 +
T20/t_proper_shutdown.f | 81 +
T20/t_prt_raw_hodo.f | 45 +
T20/t_prt_raw_mwpc.f | 45 +
T20/t_raw_dump_all.f | 44 +
T20/t_reconstruction.f | 99 +
T20/t_register_param.f | 49 +
T20/t_register_variables.f | 72 +
T20/t_reset_event.f | 91 +
T20/t_test_straw_analyze.f | 1471 +++++++++++
T20/tengine.f | 711 +++++
TRACKING/.cvsignore | 1 +
TRACKING/CVS/Entries | 8 +
TRACKING/CVS/Repository | 1 +
TRACKING/CVS/Root | 1 +
TRACKING/CVS/Tag | 1 +
TRACKING/Makefile | 8 +
TRACKING/Makefile.Unix | 82 +
TRACKING/find_space_points.f | 222 ++
TRACKING/select_space_points.f | 55 +
TRACKING/solve_four_by_four.f | 67 +
TRACKING/total_eloss.f | 781 ++++++
UTILSUBS/.cvsignore | 1 +
UTILSUBS/CVS/Entries | 40 +
UTILSUBS/CVS/Repository | 1 +
UTILSUBS/CVS/Root | 1 +
UTILSUBS/CVS/Tag | 1 +
UTILSUBS/Makefile | 8 +
UTILSUBS/Makefile.Unix | 91 +
UTILSUBS/clear_after_null.f | 19 +
UTILSUBS/data_row.f | 58 +
UTILSUBS/g_add_path.f | 52 +
UTILSUBS/g_append.f | 38 +
UTILSUBS/g_build_note.f | 162 ++
UTILSUBS/g_important_length.f | 40 +
UTILSUBS/g_int_sort.f | 55 +
UTILSUBS/g_io_control.f | 151 ++
UTILSUBS/g_log_message.f | 32 +
UTILSUBS/g_normalize.f | 43 +
UTILSUBS/g_prepend.f | 47 +
UTILSUBS/g_reg_c.f | 50 +
UTILSUBS/g_rep_err.f | 88 +
UTILSUBS/g_rep_where.f | 62 +
UTILSUBS/g_shift_len.f | 33 +
UTILSUBS/g_sort.f | 69 +
UTILSUBS/g_sph_xyz.f | 31 +
UTILSUBS/g_sub_run_number.f | 73 +
UTILSUBS/g_utc_date.f | 157 ++
UTILSUBS/g_wrap_note.f | 84 +
UTILSUBS/g_xyz_sph.f | 48 +
UTILSUBS/get_values.f | 137 +
UTILSUBS/match.f | 47 +
UTILSUBS/no_blanks.f | 16 +
UTILSUBS/no_comments.f | 30 +
UTILSUBS/no_leading_blanks.f | 36 +
UTILSUBS/no_nulls.f | 22 +
UTILSUBS/no_tabs.f | 22 +
UTILSUBS/only_one_blank.f | 22 +
UTILSUBS/regparmstringarray.f | 12 +
UTILSUBS/shiftall.f | 16 +
UTILSUBS/squeeze.f | 34 +
UTILSUBS/string_length.f | 15 +
UTILSUBS/sub_string.f | 29 +
UTILSUBS/up_case.f | 26 +
UTILSUBS/up_shift.f | 18 +
etc/CVS/Entries | 6 +
etc/CVS/Repository | 1 +
etc/CVS/Root | 1 +
etc/CVS/Tag | 1 +
etc/Makefile | 207 ++
etc/Makefile.NEW | 82 +
etc/Makefile.flags | 15 +
etc/Makefile.variables | 86 +
etc/makefile.site.in | 129 +
modified.txt | 39 +
878 files changed, 123105 insertions(+)
create mode 100644 BTRACKING/.cvsignore
create mode 100644 BTRACKING/CVS/Entries
create mode 100644 BTRACKING/CVS/Repository
create mode 100644 BTRACKING/CVS/Root
create mode 100644 BTRACKING/CVS/Tag
create mode 100755 BTRACKING/Makefile
create mode 100644 BTRACKING/Makefile.Unix
create mode 100644 BTRACKING/b_add_neighbors.f
create mode 100755 BTRACKING/b_analyze_pedestal.f
create mode 100755 BTRACKING/b_calc_cluster_time.f
create mode 100755 BTRACKING/b_calc_pedestal.f
create mode 100755 BTRACKING/b_calc_physics.f
create mode 100755 BTRACKING/b_calc_shower_coord.f
create mode 100644 BTRACKING/b_dump_peds.f
create mode 100644 BTRACKING/b_fill_bigcal_arrays.f
create mode 100644 BTRACKING/b_fill_eff_hists.f
create mode 100755 BTRACKING/b_find_clusters.f
create mode 100755 BTRACKING/b_find_clusters_new.f
create mode 100755 BTRACKING/b_find_clusters_old.f
create mode 100755 BTRACKING/b_generate_geometry.f
create mode 100644 BTRACKING/b_guess_ecell.f
create mode 100644 BTRACKING/b_init_bad_list.f
create mode 100755 BTRACKING/b_init_gain.f
create mode 100755 BTRACKING/b_init_histid.f
create mode 100755 BTRACKING/b_init_physics.f
create mode 100755 BTRACKING/b_init_shower.f
create mode 100755 BTRACKING/b_init_tof.f
create mode 100644 BTRACKING/b_matrix_accum.f
create mode 100644 BTRACKING/b_print_cluster.f
create mode 100755 BTRACKING/b_print_raw_adc.f
create mode 100644 BTRACKING/b_print_raw_bad.f
create mode 100755 BTRACKING/b_print_raw_tdc.f
create mode 100755 BTRACKING/b_print_raw_trig.f
create mode 100644 BTRACKING/b_prune_clusters.f
create mode 100755 BTRACKING/b_raw_dump_all.f
create mode 100644 BTRACKING/b_rebuild_cluster.f
create mode 100755 BTRACKING/b_reconstruction.f
create mode 100755 BTRACKING/b_register_param.f
create mode 100755 BTRACKING/b_report_bad_data.f
create mode 100755 BTRACKING/b_sparsify_prot.f
create mode 100755 BTRACKING/b_sparsify_rcs.f
create mode 100755 BTRACKING/b_strip_tdc.f
create mode 100755 BTRACKING/b_strip_trig.f
create mode 100755 BTRACKING/b_trans_prot.f
create mode 100755 BTRACKING/b_trans_rcs.f
create mode 100755 BTRACKING/b_trans_tdc.f
create mode 100755 BTRACKING/b_trans_trig.f
create mode 100644 BTRACKING/bigcal_calib.f
create mode 100644 CODA/.cvsignore
create mode 100644 CODA/CVS/Entries
create mode 100644 CODA/CVS/Repository
create mode 100644 CODA/CVS/Root
create mode 100644 CODA/CVS/Tag
create mode 100644 CODA/Makefile
create mode 100644 CODA/Makefile.Unix
create mode 100644 CODA/ceMsg.h
create mode 100644 CODA/ceMsgLib.c
create mode 100644 CODA/ceMsgTbl.c
create mode 100644 CODA/evfile.msg
create mode 100644 CODA/evfile_msg.h
create mode 100644 CODA/evio.c
create mode 100644 CODA/evtest.c
create mode 100644 CODA/facility
create mode 100644 CODA/misc.c
create mode 100644 CODA/swap_util.c
create mode 100644 CTP/.cvsignore
create mode 100644 CTP/CVS/Entries
create mode 100644 CTP/CVS/Repository
create mode 100644 CTP/CVS/Root
create mode 100644 CTP/CVS/Tag
create mode 100644 CTP/Makefile
create mode 100644 CTP/Makefile.Unix
create mode 100644 CTP/cfortran.h
create mode 100644 CTP/cfortran.h.debian
create mode 100644 CTP/daVar.h
create mode 100644 CTP/daVarHandlers.c
create mode 100644 CTP/daVarHandlers.h
create mode 100644 CTP/daVarHash.h
create mode 100644 CTP/daVarHashLib.c
create mode 100644 CTP/daVarRegister.c
create mode 100644 CTP/daVarRpc.x
create mode 100644 CTP/daVarRpcProc.c
create mode 100644 CTP/daVarServ.c
create mode 100644 CTP/fnmatch.h
create mode 100644 CTP/hbook.h
create mode 100644 CTP/makereg.c
create mode 100644 CTP/th.h
create mode 100644 CTP/thClient.c
create mode 100644 CTP/thGethit.c
create mode 100644 CTP/thGroup.c
create mode 100644 CTP/thGroup.h
create mode 100644 CTP/thHandlers.c
create mode 100644 CTP/thHist.c
create mode 100644 CTP/thInternal.h
create mode 100644 CTP/thLoad.c
create mode 100644 CTP/thParm.c
create mode 100644 CTP/thReport.c
create mode 100644 CTP/thRootStuff.cpp
create mode 100644 CTP/thTest.c
create mode 100644 CTP/thTestExecute.c
create mode 100644 CTP/thTestParse.c
create mode 100644 CTP/thTestParse.h
create mode 100644 CTP/thTree.c
create mode 100644 CTP/thUtils.c
create mode 100644 CTP/thUtils.h
create mode 100644 CVS/Entries
create mode 100644 CVS/Entries.Log
create mode 100644 CVS/Repository
create mode 100644 CVS/Root
create mode 100644 CVS/Tag
create mode 100644 CVSROOT/CVS/Entries
create mode 100644 CVSROOT/CVS/Repository
create mode 100644 CVSROOT/CVS/Root
create mode 100644 CVSROOT/CVS/Tag
create mode 100644 CVSROOT/checkoutlist
create mode 100644 CVSROOT/commitinfo
create mode 100644 CVSROOT/cvswrappers
create mode 100644 CVSROOT/editinfo
create mode 100644 CVSROOT/loginfo
create mode 100644 CVSROOT/modules
create mode 100644 CVSROOT/notify
create mode 100644 CVSROOT/rcsinfo
create mode 100644 CVSROOT/taginfo
create mode 100644 ENGINE/.cvsignore
create mode 100644 ENGINE/CVS/Entries
create mode 100644 ENGINE/CVS/Repository
create mode 100644 ENGINE/CVS/Root
create mode 100644 ENGINE/CVS/Tag
create mode 100644 ENGINE/Makefile
create mode 100644 ENGINE/Makefile.Unix
create mode 100755 ENGINE/b_clear_event.f
create mode 100644 ENGINE/b_cosmic_ntuple_init.f
create mode 100755 ENGINE/b_initialize.f
create mode 100755 ENGINE/b_keep_results.f
create mode 100755 ENGINE/b_ntuple_change.f
create mode 100755 ENGINE/b_ntuple_clear.f
create mode 100755 ENGINE/b_ntuple_close.f
create mode 100755 ENGINE/b_ntuple_init.f
create mode 100755 ENGINE/b_ntuple_keep.f
create mode 100755 ENGINE/b_ntuple_open.f
create mode 100755 ENGINE/b_ntuple_register.f
create mode 100755 ENGINE/b_ntuple_shutdown.f
create mode 100755 ENGINE/b_proper_shutdown.f
create mode 100755 ENGINE/b_register_variables.f
create mode 100755 ENGINE/b_reset_event.f
create mode 100644 ENGINE/b_tree_init.f
create mode 100644 ENGINE/bigcal_mc_reconstruction.f
create mode 100644 ENGINE/c_clear_event.f
create mode 100644 ENGINE/c_initialize.f
create mode 100644 ENGINE/c_keep_results.f
create mode 100644 ENGINE/c_ntuple_change.f
create mode 100644 ENGINE/c_ntuple_clear.f
create mode 100644 ENGINE/c_ntuple_close.f
create mode 100644 ENGINE/c_ntuple_init.f
create mode 100644 ENGINE/c_ntuple_keep.f
create mode 100644 ENGINE/c_ntuple_open.f
create mode 100644 ENGINE/c_ntuple_register.f
create mode 100644 ENGINE/c_ntuple_shutdown.f
create mode 100644 ENGINE/c_physics.f
create mode 100644 ENGINE/c_proper_shutdown.f
create mode 100644 ENGINE/c_reconstruction.f
create mode 100644 ENGINE/c_register_variables.f
create mode 100644 ENGINE/c_reset_event.f
create mode 100644 ENGINE/engine.f
create mode 100644 ENGINE/g_analyze_beam_pedestal.f
create mode 100644 ENGINE/g_analyze_misc.f
create mode 100644 ENGINE/g_analyze_pedestal.f
create mode 100644 ENGINE/g_analyze_scaler_bank.f
create mode 100644 ENGINE/g_analyze_scalers.f
create mode 100644 ENGINE/g_analyze_scalers_by_banks.f
create mode 100644 ENGINE/g_apply_offsets.f
create mode 100644 ENGINE/g_calc_beam_pedestal.f
create mode 100644 ENGINE/g_calc_bpm_pedestal.f
create mode 100644 ENGINE/g_calc_pedestal.f
create mode 100644 ENGINE/g_calc_raster_pedestal.f
create mode 100644 ENGINE/g_clear_event.f
create mode 100644 ENGINE/g_ctp_database.f
create mode 100644 ENGINE/g_decode_clear.f
create mode 100644 ENGINE/g_decode_config.f
create mode 100644 ENGINE/g_decode_event_by_banks.f
create mode 100644 ENGINE/g_decode_fb_bank.f
create mode 100644 ENGINE/g_decode_fb_detector.f
create mode 100644 ENGINE/g_decode_init.f
create mode 100644 ENGINE/g_decode_scalers.f
create mode 100644 ENGINE/g_dump_histograms.f
create mode 100644 ENGINE/g_dump_peds.f
create mode 100644 ENGINE/g_examine_control_event.f
create mode 100644 ENGINE/g_examine_epics_event.f
create mode 100644 ENGINE/g_examine_go_info.f
create mode 100644 ENGINE/g_examine_physics_event.f
create mode 100644 ENGINE/g_examine_picture_event.f
create mode 100644 ENGINE/g_extract_kinematics.f
create mode 100644 ENGINE/g_get_next_event.f
create mode 100644 ENGINE/g_init_filenames.f
create mode 100644 ENGINE/g_initialize.f
create mode 100644 ENGINE/g_keep_results.f
create mode 100644 ENGINE/g_kludgeup_kinematics.f
create mode 100644 ENGINE/g_ntuple_init.f
create mode 100644 ENGINE/g_ntuple_shutdown.f
create mode 100644 ENGINE/g_open_source.f
create mode 100644 ENGINE/g_output_thresholds.f
create mode 100644 ENGINE/g_preproc_event.f
create mode 100644 ENGINE/g_preproc_open.f
create mode 100644 ENGINE/g_proper_shutdown.f
create mode 100644 ENGINE/g_reconstruction.f
create mode 100644 ENGINE/g_register_variables.f
create mode 100644 ENGINE/g_reset_event.f
create mode 100644 ENGINE/g_scaler_reset_event.f
create mode 100644 ENGINE/g_target_initialize.f
create mode 100644 ENGINE/g_trans_misc.f
create mode 100644 ENGINE/g_tree_init.f
create mode 100644 ENGINE/g_write_event.f
create mode 100644 ENGINE/gep_check_bigcal.f
create mode 100755 ENGINE/gep_clear_event.f
create mode 100644 ENGINE/gep_fill_hist.f
create mode 100644 ENGINE/gep_init_histid.f
create mode 100755 ENGINE/gep_initialize.f
create mode 100755 ENGINE/gep_keep_results.f
create mode 100644 ENGINE/gep_ntuple_change.f
create mode 100755 ENGINE/gep_ntuple_clear.f
create mode 100755 ENGINE/gep_ntuple_close.f
create mode 100755 ENGINE/gep_ntuple_init.f
create mode 100755 ENGINE/gep_ntuple_keep.f
create mode 100755 ENGINE/gep_ntuple_open.f
create mode 100644 ENGINE/gep_ntuple_register.f
create mode 100755 ENGINE/gep_ntuple_shutdown.f
create mode 100755 ENGINE/gep_physics.f
create mode 100755 ENGINE/gep_proper_shutdown.f
create mode 100755 ENGINE/gep_reconstruction.f
create mode 100755 ENGINE/gep_register_variables.f
create mode 100644 ENGINE/gep_reset_event.f
create mode 100644 ENGINE/gep_tree_init.f
create mode 100644 ENGINE/h_apply_offsets.f
create mode 100644 ENGINE/h_clear_event.f
create mode 100644 ENGINE/h_field03.f
create mode 100644 ENGINE/h_fieldcorr.f
create mode 100644 ENGINE/h_fpp_nt_change.f
create mode 100644 ENGINE/h_fpp_nt_close.f
create mode 100644 ENGINE/h_fpp_nt_init.f
create mode 100644 ENGINE/h_fpp_nt_keep.f
create mode 100644 ENGINE/h_fpp_nt_open.f
create mode 100644 ENGINE/h_fpp_nt_register.f
create mode 100644 ENGINE/h_fpp_nt_shutdown.f
create mode 100644 ENGINE/h_fpp_ntup.cwn
create mode 100644 ENGINE/h_initialize.f
create mode 100644 ENGINE/h_keep_results.f
create mode 100644 ENGINE/h_ntuple_change.f
create mode 100644 ENGINE/h_ntuple_clear.f
create mode 100644 ENGINE/h_ntuple_close.f
create mode 100644 ENGINE/h_ntuple_init.f
create mode 100644 ENGINE/h_ntuple_keep.f
create mode 100644 ENGINE/h_ntuple_open.f
create mode 100644 ENGINE/h_ntuple_register.f
create mode 100644 ENGINE/h_ntuple_shutdown.f
create mode 100644 ENGINE/h_proper_shutdown.f
create mode 100644 ENGINE/h_register_variables.f
create mode 100644 ENGINE/h_reset_event.f
create mode 100644 ENGINE/h_sv_nt_init.f
create mode 100644 ENGINE/h_sv_nt_keep.f
create mode 100644 ENGINE/h_sv_nt_register.f
create mode 100644 ENGINE/h_sv_nt_shutdown.f
create mode 100644 ENGINE/h_tree_init.f
create mode 100644 ENGINE/params03.f
create mode 100644 ENGINE/s_apply_offsets.f
create mode 100644 ENGINE/s_clear_event.f
create mode 100644 ENGINE/s_fieldcorr.f
create mode 100644 ENGINE/s_initialize.f
create mode 100644 ENGINE/s_keep_results.f
create mode 100644 ENGINE/s_ntuple_change.f
create mode 100644 ENGINE/s_ntuple_clear.f
create mode 100644 ENGINE/s_ntuple_close.f
create mode 100644 ENGINE/s_ntuple_init.f
create mode 100644 ENGINE/s_ntuple_keep.f
create mode 100644 ENGINE/s_ntuple_open.f
create mode 100644 ENGINE/s_ntuple_register.f
create mode 100644 ENGINE/s_ntuple_shutdown.f
create mode 100644 ENGINE/s_proper_shutdown.f
create mode 100644 ENGINE/s_register_variables.f
create mode 100644 ENGINE/s_reset_event.f
create mode 100644 ENGINE/s_sv_nt_init.f
create mode 100644 ENGINE/s_sv_nt_keep.f
create mode 100644 ENGINE/s_sv_nt_register.f
create mode 100644 ENGINE/s_sv_nt_shutdown.f
create mode 100644 EXE/CVS/Entries
create mode 100644 EXE/CVS/Repository
create mode 100644 EXE/CVS/Root
create mode 100644 EXE/CVS/Tag
create mode 100644 EXE/Makefile
create mode 100644 F1TRIGGER/.cvsignore
create mode 100644 F1TRIGGER/CVS/Entries
create mode 100644 F1TRIGGER/CVS/Repository
create mode 100644 F1TRIGGER/CVS/Root
create mode 100644 F1TRIGGER/CVS/Tag
create mode 100755 F1TRIGGER/Makefile
create mode 100644 F1TRIGGER/Makefile.Unix
create mode 100644 F1TRIGGER/f1t_register_variables.f
create mode 100644 F1TRIGGER/f1trigger_clear_event.f
create mode 100644 F1TRIGGER/f1trigger_decode.f
create mode 100644 F1TRIGGER/f1trigger_register_variables.f
create mode 100644 F1TRIGGER/f1trigger_reset_event.f
create mode 100644 F1TRIGGER/f1trigger_sort_by_counter.f
create mode 100644 HACK/.cvsignore
create mode 100644 HACK/CVS/Entries
create mode 100644 HACK/CVS/Repository
create mode 100644 HACK/CVS/Root
create mode 100644 HACK/CVS/Tag
create mode 100644 HACK/Makefile
create mode 100644 HACK/Makefile.Unix
create mode 100644 HACK/hack_anal.f
create mode 100644 HACK/hack_copyevt.f
create mode 100644 HACK/hack_initialize.f
create mode 100644 HACK/hack_register_variables.f
create mode 100644 HACK/hack_shutdown.f
create mode 100644 HTRACKING/.cvsignore
create mode 100644 HTRACKING/CVS/Entries
create mode 100644 HTRACKING/CVS/Repository
create mode 100644 HTRACKING/CVS/Root
create mode 100644 HTRACKING/CVS/Tag
create mode 100644 HTRACKING/Makefile
create mode 100644 HTRACKING/Makefile.Unix
create mode 100644 HTRACKING/h_aero.f
create mode 100644 HTRACKING/h_analyze_pedestal.f
create mode 100644 HTRACKING/h_cal.f
create mode 100644 HTRACKING/h_cal_calib.f
create mode 100644 HTRACKING/h_cal_eff.f
create mode 100644 HTRACKING/h_cal_eff_shutdown.f
create mode 100644 HTRACKING/h_calc_pedestal.f
create mode 100644 HTRACKING/h_cer.f
create mode 100644 HTRACKING/h_cer_eff.f
create mode 100644 HTRACKING/h_cer_eff_shutdown.f
create mode 100644 HTRACKING/h_chamnum.f
create mode 100644 HTRACKING/h_choose_single_hit.f
create mode 100644 HTRACKING/h_clusters_cal.f
create mode 100644 HTRACKING/h_correct_cal.f
create mode 100644 HTRACKING/h_correct_cal_neg.f
create mode 100644 HTRACKING/h_correct_cal_pos.f
create mode 100644 HTRACKING/h_dc_eff.f
create mode 100644 HTRACKING/h_dc_eff_shutdown.f
create mode 100644 HTRACKING/h_dc_trk_eff.f
create mode 100644 HTRACKING/h_dc_trk_eff_shutdown.f
create mode 100644 HTRACKING/h_dpsifun.f
create mode 100644 HTRACKING/h_drift_dist_calc.f
create mode 100644 HTRACKING/h_drift_time_calc.f
create mode 100644 HTRACKING/h_dump_cal.f
create mode 100644 HTRACKING/h_dump_peds.f
create mode 100644 HTRACKING/h_dump_tof.f
create mode 100644 HTRACKING/h_fcnchisq.f
create mode 100644 HTRACKING/h_fill_aero_raw_hist.f
create mode 100644 HTRACKING/h_fill_cal_hist.f
create mode 100644 HTRACKING/h_fill_dc_dec_hist.f
create mode 100644 HTRACKING/h_fill_dc_fp_hist.f
create mode 100644 HTRACKING/h_fill_dc_target_hist.f
create mode 100644 HTRACKING/h_fill_fpp.f
create mode 100644 HTRACKING/h_fill_scin_raw_hist.f
create mode 100644 HTRACKING/h_find_best_stub.f
create mode 100644 HTRACKING/h_find_easy_space_point.f
create mode 100644 HTRACKING/h_fpp.f
create mode 100644 HTRACKING/h_fpp_drift.f
create mode 100644 HTRACKING/h_fpp_fit.f
create mode 100644 HTRACKING/h_fpp_geometry.f
create mode 100644 HTRACKING/h_fpp_statistics.f
create mode 100644 HTRACKING/h_fpp_tracking.f
create mode 100644 HTRACKING/h_generate_geometry.f
create mode 100644 HTRACKING/h_init_cal.f
create mode 100644 HTRACKING/h_init_cer.f
create mode 100644 HTRACKING/h_init_fpp.f
create mode 100644 HTRACKING/h_init_histid.f
create mode 100644 HTRACKING/h_init_physics.f
create mode 100644 HTRACKING/h_init_scin.f
create mode 100644 HTRACKING/h_left_right.f
create mode 100644 HTRACKING/h_link_stubs.f
create mode 100644 HTRACKING/h_pattern_recognition.f
create mode 100644 HTRACKING/h_physics.f
create mode 100644 HTRACKING/h_physics_stat.f
create mode 100644 HTRACKING/h_print_decoded_dc.f
create mode 100644 HTRACKING/h_print_links.f
create mode 100644 HTRACKING/h_print_pr.f
create mode 100644 HTRACKING/h_print_raw_dc.f
create mode 100644 HTRACKING/h_print_stubs.f
create mode 100644 HTRACKING/h_print_tar_tracks.f
create mode 100644 HTRACKING/h_print_tracks.f
create mode 100644 HTRACKING/h_prt_cal_clusters.f
create mode 100644 HTRACKING/h_prt_cal_decoded.f
create mode 100644 HTRACKING/h_prt_cal_raw.f
create mode 100644 HTRACKING/h_prt_cal_sparsified.f
create mode 100644 HTRACKING/h_prt_cal_tests.f
create mode 100644 HTRACKING/h_prt_cal_tracks.f
create mode 100644 HTRACKING/h_prt_dec_scin.f
create mode 100644 HTRACKING/h_prt_raw_scin.f
create mode 100644 HTRACKING/h_prt_tof.f
create mode 100644 HTRACKING/h_prt_track_tests.f
create mode 100644 HTRACKING/h_psifun.f
create mode 100644 HTRACKING/h_raw_dump_all.f
create mode 100644 HTRACKING/h_reconstruction.f
create mode 100644 HTRACKING/h_register_param.f
create mode 100644 HTRACKING/h_report_bad_data.f
create mode 100644 HTRACKING/h_satcorr.f
create mode 100644 HTRACKING/h_scin_eff.f
create mode 100644 HTRACKING/h_scin_eff_shutdown.f
create mode 100644 HTRACKING/h_select_best_track.f
create mode 100644 HTRACKING/h_select_best_track_prune.f
create mode 100644 HTRACKING/h_select_best_track_using_scin.f
create mode 100644 HTRACKING/h_solve_3by3.f
create mode 100644 HTRACKING/h_sp_destroy.f
create mode 100644 HTRACKING/h_sp_multiwire.f
create mode 100644 HTRACKING/h_sparsify_cal.f
create mode 100644 HTRACKING/h_strip_scin.f
create mode 100644 HTRACKING/h_targ_trans.f
create mode 100644 HTRACKING/h_targ_trans_init.f
create mode 100644 HTRACKING/h_tof.f
create mode 100644 HTRACKING/h_tof_fit.f
create mode 100644 HTRACKING/h_tof_init.f
create mode 100644 HTRACKING/h_track.f
create mode 100644 HTRACKING/h_track_fit.f
create mode 100644 HTRACKING/h_track_tests.f
create mode 100644 HTRACKING/h_tracks_cal.f
create mode 100644 HTRACKING/h_trans_cal.f
create mode 100644 HTRACKING/h_trans_cer.f
create mode 100644 HTRACKING/h_trans_dc.f
create mode 100644 HTRACKING/h_trans_fpp.f
create mode 100644 HTRACKING/h_trans_fpp_hms.f
create mode 100644 HTRACKING/h_trans_misc.f
create mode 100644 HTRACKING/h_trans_scin.f
create mode 100644 HTRACKING/h_wire_center_calc.f
create mode 100755 HTRACKING/hms_sane_track.f
create mode 100644 HTRACKING/mt19937.f
create mode 100644 INCLUDE/CVS/Entries
create mode 100644 INCLUDE/CVS/Repository
create mode 100644 INCLUDE/CVS/Root
create mode 100644 INCLUDE/CVS/Tag
create mode 100644 INCLUDE/Makefile
create mode 100755 INCLUDE/b_ntuple.cmn
create mode 100644 INCLUDE/b_ntuple.dte
create mode 100755 INCLUDE/bigcal_bypass_switches.cmn
create mode 100755 INCLUDE/bigcal_data_structures.cmn
create mode 100755 INCLUDE/bigcal_filenames.cmn
create mode 100755 INCLUDE/bigcal_gain_parms.cmn
create mode 100755 INCLUDE/bigcal_geometry.cmn
create mode 100644 INCLUDE/bigcal_hist_id.cmn
create mode 100755 INCLUDE/bigcal_shower_parms.cmn
create mode 100755 INCLUDE/bigcal_tof_parms.cmn
create mode 100644 INCLUDE/c_ntuple.cmn
create mode 100644 INCLUDE/c_ntuple.dte
create mode 100644 INCLUDE/coin_bypass_switches.cmn
create mode 100644 INCLUDE/coin_data_structures.cmn
create mode 100644 INCLUDE/coin_filenames.cmn
create mode 100644 INCLUDE/f1trigger_data_structures.cmn
create mode 100644 INCLUDE/gen_constants.par
create mode 100644 INCLUDE/gen_craw.cmn
create mode 100644 INCLUDE/gen_data_structures.cmn
create mode 100644 INCLUDE/gen_decode_F1tdc.cmn
create mode 100644 INCLUDE/gen_decode_common.cmn
create mode 100644 INCLUDE/gen_detectorids.par
create mode 100644 INCLUDE/gen_epics.cmn
create mode 100644 INCLUDE/gen_event_info.cmn
create mode 100644 INCLUDE/gen_filenames.cmn
create mode 100644 INCLUDE/gen_input_info.cmn
create mode 100644 INCLUDE/gen_one_ev_gckine.cmn
create mode 100644 INCLUDE/gen_one_ev_gctrak.cmn
create mode 100644 INCLUDE/gen_one_ev_gcvolu.cmn
create mode 100644 INCLUDE/gen_one_ev_info.cmn
create mode 100644 INCLUDE/gen_one_ev_info.dte
create mode 100644 INCLUDE/gen_output_info.cmn
create mode 100644 INCLUDE/gen_pawspace.cmn
create mode 100644 INCLUDE/gen_routines.dec
create mode 100644 INCLUDE/gen_run_info.cmn
create mode 100644 INCLUDE/gen_run_info.dte
create mode 100644 INCLUDE/gen_run_pref.cmn
create mode 100644 INCLUDE/gen_run_pref.dte
create mode 100644 INCLUDE/gen_scalers.cmn
create mode 100644 INCLUDE/gen_units.par
create mode 100755 INCLUDE/gep_data_structures.cmn
create mode 100755 INCLUDE/gep_filenames.cmn
create mode 100644 INCLUDE/gep_hist_id.cmn
create mode 100755 INCLUDE/gep_ntuple.cmn
create mode 100644 INCLUDE/gep_ntuple.dte
create mode 100644 INCLUDE/h_fpp_ntuple.cmn
create mode 100644 INCLUDE/h_fpp_ntuple.dte
create mode 100644 INCLUDE/h_ntuple.cmn
create mode 100644 INCLUDE/h_ntuple.dte
create mode 100644 INCLUDE/h_sieve_ntuple.cmn
create mode 100644 INCLUDE/h_sieve_ntuple.dte
create mode 100644 INCLUDE/hack_.cmn
create mode 100644 INCLUDE/hms_aero_parms.cmn
create mode 100644 INCLUDE/hms_bypass_switches.cmn
create mode 100644 INCLUDE/hms_calorimeter.cmn
create mode 100644 INCLUDE/hms_cer_parms.cmn
create mode 100644 INCLUDE/hms_data_structures.cmn
create mode 100644 INCLUDE/hms_filenames.cmn
create mode 100644 INCLUDE/hms_fpp_event.cmn
create mode 100644 INCLUDE/hms_fpp_params.cmn
create mode 100644 INCLUDE/hms_fpp_params.dte
create mode 100644 INCLUDE/hms_geometry.cmn
create mode 100644 INCLUDE/hms_id_histid.cmn
create mode 100644 INCLUDE/hms_one_ev.par
create mode 100644 INCLUDE/hms_pedestals.cmn
create mode 100644 INCLUDE/hms_physics_sing.cmn
create mode 100644 INCLUDE/hms_recon_elements.cmn
create mode 100644 INCLUDE/hms_scin_parms.cmn
create mode 100644 INCLUDE/hms_scin_tof.cmn
create mode 100644 INCLUDE/hms_statistics.cmn
create mode 100644 INCLUDE/hms_track_histid.cmn
create mode 100644 INCLUDE/hms_tracking.cmn
create mode 100644 INCLUDE/insane_scalers.cmn
create mode 100644 INCLUDE/mc_structures.cmn
create mode 100644 INCLUDE/s_ntuple.cmn
create mode 100644 INCLUDE/s_ntuple.dte
create mode 100644 INCLUDE/s_sieve_ntuple.cmn
create mode 100644 INCLUDE/s_sieve_ntuple.dte
create mode 100644 INCLUDE/sane_data_structures.cmn
create mode 100644 INCLUDE/sane_filenames.cmn
create mode 100644 INCLUDE/sane_ntuple.cmn
create mode 100644 INCLUDE/sane_ntuple.dte
create mode 100644 INCLUDE/sem_data_structures.cmn
create mode 100644 INCLUDE/sos_aero_parms.cmn
create mode 100644 INCLUDE/sos_bypass_switches.cmn
create mode 100644 INCLUDE/sos_calorimeter.cmn
create mode 100644 INCLUDE/sos_cer_parms.cmn
create mode 100644 INCLUDE/sos_data_structures.cmn
create mode 100644 INCLUDE/sos_filenames.cmn
create mode 100644 INCLUDE/sos_geometry.cmn
create mode 100644 INCLUDE/sos_id_histid.cmn
create mode 100644 INCLUDE/sos_lucite_parms.cmn
create mode 100644 INCLUDE/sos_one_ev.par
create mode 100644 INCLUDE/sos_pedestals.cmn
create mode 100644 INCLUDE/sos_physics_sing.cmn
create mode 100644 INCLUDE/sos_recon_elements.cmn
create mode 100644 INCLUDE/sos_scin_parms.cmn
create mode 100644 INCLUDE/sos_scin_tof.cmn
create mode 100644 INCLUDE/sos_statistics.cmn
create mode 100644 INCLUDE/sos_track_histid.cmn
create mode 100644 INCLUDE/sos_tracking.cmn
create mode 100644 ONEEV/CVS/Entries
create mode 100644 ONEEV/CVS/Repository
create mode 100644 ONEEV/CVS/Root
create mode 100644 ONEEV/CVS/Tag
create mode 100644 ONEEV/Makefile
create mode 100644 ONEEV/Makefile.Unix
create mode 100644 ONEEV/evdisplay.f
create mode 100644 ONEEV/g_uglast.f
create mode 100644 ONEEV/g_ugsvolu.f
create mode 100644 ONEEV/glvolu.f
create mode 100644 ONEEV/h_one_ev_cal.f
create mode 100644 ONEEV/h_one_ev_det_reset.f
create mode 100644 ONEEV/h_one_ev_detectors.f
create mode 100644 ONEEV/h_one_ev_display.f
create mode 100644 ONEEV/h_one_ev_generate.f
create mode 100644 ONEEV/h_one_ev_geometry.f
create mode 100644 ONEEV/h_one_ev_head_view.f
create mode 100644 ONEEV/h_one_ev_hodo.f
create mode 100644 ONEEV/h_one_ev_persp_view.f
create mode 100644 ONEEV/h_one_ev_topside_view.f
create mode 100644 ONEEV/h_one_ev_track.f
create mode 100644 ONEEV/h_one_ev_wc.f
create mode 100644 ONEEV/h_uginit.f
create mode 100644 ONEEV/revdis_ask.f
create mode 100644 ONEEV/revdis_getev.f
create mode 100644 ONEEV/revdis_init.f
create mode 100644 ONEEV/s_one_ev_cal.f
create mode 100644 ONEEV/s_one_ev_det_reset.f
create mode 100644 ONEEV/s_one_ev_detectors.f
create mode 100644 ONEEV/s_one_ev_display.f
create mode 100644 ONEEV/s_one_ev_generate.f
create mode 100644 ONEEV/s_one_ev_geometry.f
create mode 100644 ONEEV/s_one_ev_head_view.f
create mode 100644 ONEEV/s_one_ev_hodo.f
create mode 100644 ONEEV/s_one_ev_persp_view.f
create mode 100644 ONEEV/s_one_ev_topside_view.f
create mode 100644 ONEEV/s_one_ev_track.f
create mode 100644 ONEEV/s_one_ev_wc.f
create mode 100644 ONEEV/s_uginit.f
create mode 100644 ONLINE/CVS/Entries
create mode 100644 ONLINE/CVS/Repository
create mode 100644 ONLINE/CVS/Root
create mode 100644 ONLINE/CVS/Tag
create mode 100644 ONLINE/Makefile
create mode 100644 ONLINE/usrdownload.f
create mode 100644 ONLINE/usrdump.f
create mode 100644 ONLINE/usrend.f
create mode 100644 ONLINE/usrevent.f
create mode 100644 ONLINE/usrgo.f
create mode 100644 ONLINE/usrmain.f
create mode 100644 ONLINE/usrpause.f
create mode 100644 ONLINE/usrprestart.f
create mode 100644 PORT/.cvsignore
create mode 100644 PORT/CVS/Entries
create mode 100644 PORT/CVS/Repository
create mode 100644 PORT/CVS/Root
create mode 100644 PORT/CVS/Tag
create mode 100644 PORT/Makefile
create mode 100644 PORT/Makefile.Unix
create mode 100644 PORT/bit_wrappers.f
create mode 100644 PORT/cwrappers.c
create mode 100644 PORT/other_wrappers.f
create mode 100644 PORT/ran_wrappers.f
create mode 100644 PORT/trig_wrappers.f
create mode 100644 SANE/#sane_ntuple_keep.f#
create mode 100644 SANE/.cvsignore
create mode 100644 SANE/CVS/Entries
create mode 100644 SANE/CVS/Repository
create mode 100644 SANE/CVS/Root
create mode 100644 SANE/CVS/Tag
create mode 100755 SANE/Makefile
create mode 100644 SANE/Makefile.Unix
create mode 100644 SANE/sane_analyze_pedestal.f
create mode 100644 SANE/sane_calc_pedestal.f
create mode 100644 SANE/sane_clear_event.f
create mode 100644 SANE/sane_close_scalers.f
create mode 100644 SANE/sane_decode.f
create mode 100644 SANE/sane_dump_ntup_var.f
create mode 100644 SANE/sane_geometry_suplement.f
create mode 100644 SANE/sane_keep_results.f
create mode 100644 SANE/sane_n100xye.f
create mode 100644 SANE/sane_ntup_change.f
create mode 100644 SANE/sane_ntup_close.f
create mode 100644 SANE/sane_ntup_init.f
create mode 100644 SANE/sane_ntup_open.f
create mode 100644 SANE/sane_ntup_register.f
create mode 100644 SANE/sane_ntup_shutdown.f
create mode 100644 SANE/sane_ntuple_keep.f
create mode 100644 SANE/sane_physics.f
create mode 100644 SANE/sane_register_variables.f
create mode 100644 SANE/sane_reset_event.f
create mode 100644 SANE/sane_trgtrack.f
create mode 100644 SEM/.cvsignore
create mode 100644 SEM/CVS/Entries
create mode 100644 SEM/CVS/Repository
create mode 100644 SEM/CVS/Root
create mode 100644 SEM/CVS/Tag
create mode 100755 SEM/Makefile
create mode 100644 SEM/Makefile.Unix
create mode 100644 SEM/sem_analyze_pedestal.f
create mode 100644 SEM/sem_calc_pedestal.f
create mode 100644 SEM/sem_calc_sr_beampos.f
create mode 100644 SEM/sem_clear_event.f
create mode 100644 SEM/sem_decode.f
create mode 100644 SEM/sem_fill_tbpm.f
create mode 100644 SEM/sem_register_variables.f
create mode 100644 SEM/sem_reset_event.f
create mode 100644 STRACKING/.cvsignore
create mode 100644 STRACKING/CVS/Entries
create mode 100644 STRACKING/CVS/Repository
create mode 100644 STRACKING/CVS/Root
create mode 100644 STRACKING/CVS/Tag
create mode 100644 STRACKING/Makefile
create mode 100644 STRACKING/Makefile.Unix
create mode 100644 STRACKING/s_aero.f
create mode 100644 STRACKING/s_analyze_pedestal.f
create mode 100644 STRACKING/s_cal.f
create mode 100644 STRACKING/s_cal_calib.f
create mode 100644 STRACKING/s_cal_eff.f
create mode 100644 STRACKING/s_cal_eff_shutdown.f
create mode 100644 STRACKING/s_calc_pedestal.f
create mode 100644 STRACKING/s_cer.f
create mode 100644 STRACKING/s_cer_eff.f
create mode 100644 STRACKING/s_cer_eff_shutdown.f
create mode 100644 STRACKING/s_chamnum.f
create mode 100644 STRACKING/s_choose_single_hit.f
create mode 100644 STRACKING/s_clusters_cal.f
create mode 100644 STRACKING/s_correct_cal.f
create mode 100644 STRACKING/s_correct_cal_neg.f
create mode 100644 STRACKING/s_correct_cal_pos.f
create mode 100644 STRACKING/s_correct_cal_two.f
create mode 100644 STRACKING/s_dc_eff.f
create mode 100644 STRACKING/s_dc_eff_shutdown.f
create mode 100644 STRACKING/s_dc_trk_eff.f
create mode 100644 STRACKING/s_dc_trk_eff_shutdown.f
create mode 100644 STRACKING/s_dpsifun.f
create mode 100644 STRACKING/s_drift_dist_calc.f
create mode 100644 STRACKING/s_drift_time_calc.f
create mode 100644 STRACKING/s_dump_cal.f
create mode 100644 STRACKING/s_dump_peds.f
create mode 100644 STRACKING/s_dump_tof.f
create mode 100644 STRACKING/s_fcnchisq.f
create mode 100644 STRACKING/s_fill_cal_hist.f
create mode 100644 STRACKING/s_fill_dc_dec_hist.f
create mode 100644 STRACKING/s_fill_dc_fp_hist.f
create mode 100644 STRACKING/s_fill_dc_target_hist.f
create mode 100644 STRACKING/s_fill_scin_raw_hist.f
create mode 100644 STRACKING/s_find_best_stub.f
create mode 100644 STRACKING/s_find_easy_space_point.f
create mode 100644 STRACKING/s_generate_geometry.f
create mode 100644 STRACKING/s_init_cal.f
create mode 100644 STRACKING/s_init_cer.f
create mode 100644 STRACKING/s_init_histid.f
create mode 100644 STRACKING/s_init_physics.f
create mode 100644 STRACKING/s_init_scin.f
create mode 100644 STRACKING/s_initialize_fitting.f
create mode 100644 STRACKING/s_left_right.f
create mode 100644 STRACKING/s_link_stubs.f
create mode 100644 STRACKING/s_lucite.f
create mode 100644 STRACKING/s_pattern_recognition.f
create mode 100644 STRACKING/s_physics.f
create mode 100644 STRACKING/s_physics_stat.f
create mode 100644 STRACKING/s_print_decoded_dc.f
create mode 100644 STRACKING/s_print_links.f
create mode 100644 STRACKING/s_print_pr.f
create mode 100644 STRACKING/s_print_raw_dc.f
create mode 100644 STRACKING/s_print_stubs.f
create mode 100644 STRACKING/s_print_tar_tracks.f
create mode 100644 STRACKING/s_print_tracks.f
create mode 100644 STRACKING/s_prt_cal_clusters.f
create mode 100644 STRACKING/s_prt_cal_decoded.f
create mode 100644 STRACKING/s_prt_cal_raw.f
create mode 100644 STRACKING/s_prt_cal_sparsified.f
create mode 100644 STRACKING/s_prt_cal_tests.f
create mode 100644 STRACKING/s_prt_cal_tracks.f
create mode 100644 STRACKING/s_prt_dec_scin.f
create mode 100644 STRACKING/s_prt_raw_scin.f
create mode 100644 STRACKING/s_prt_tof.f
create mode 100644 STRACKING/s_prt_track_tests.f
create mode 100644 STRACKING/s_psifun.f
create mode 100644 STRACKING/s_raw_dump_all.f
create mode 100644 STRACKING/s_reconstruction.f
create mode 100644 STRACKING/s_register_param.f
create mode 100644 STRACKING/s_report_bad_data.f
create mode 100644 STRACKING/s_satcorr.f
create mode 100644 STRACKING/s_scin_eff.f
create mode 100644 STRACKING/s_scin_eff_shutdown.f
create mode 100644 STRACKING/s_select_best_track.f
create mode 100644 STRACKING/s_select_best_track_prune.f
create mode 100644 STRACKING/s_select_best_track_using_scin.f
create mode 100644 STRACKING/s_solve_3by3.f
create mode 100644 STRACKING/s_sparsify_cal.f
create mode 100644 STRACKING/s_strip_scin.f
create mode 100644 STRACKING/s_targ_trans.f
create mode 100644 STRACKING/s_targ_trans_init.f
create mode 100644 STRACKING/s_tdc_time_per_channel.f
create mode 100644 STRACKING/s_tdc_zero.f
create mode 100644 STRACKING/s_tof.f
create mode 100644 STRACKING/s_tof_fit.f
create mode 100644 STRACKING/s_tof_init.f
create mode 100644 STRACKING/s_track.f
create mode 100644 STRACKING/s_track_fit.f
create mode 100644 STRACKING/s_track_tests.f
create mode 100644 STRACKING/s_tracks_cal.f
create mode 100644 STRACKING/s_trans_cal.f
create mode 100644 STRACKING/s_trans_cer.f
create mode 100644 STRACKING/s_trans_dc.f
create mode 100644 STRACKING/s_trans_misc.f
create mode 100644 STRACKING/s_trans_scin.f
create mode 100644 STRACKING/s_wire_center_calc.f
create mode 100644 SYNCFILTER/CVS/Entries
create mode 100644 SYNCFILTER/CVS/Repository
create mode 100644 SYNCFILTER/CVS/Root
create mode 100644 SYNCFILTER/CVS/Tag
create mode 100644 SYNCFILTER/Makefile
create mode 100644 SYNCFILTER/syncfilter.c
create mode 100644 T20/CVS/Entries
create mode 100644 T20/CVS/Repository
create mode 100644 T20/CVS/Root
create mode 100644 T20/CVS/Tag
create mode 100644 T20/Makefile
create mode 100644 T20/Makefile.Unix
create mode 100644 T20/g_analyze_misc.f
create mode 100644 T20/g_analyze_pedestal.f
create mode 100644 T20/g_analyze_scalers.f
create mode 100644 T20/g_calc_pedestal.f
create mode 100644 T20/g_clear_event.f
create mode 100644 T20/g_decode_fb_bank.f
create mode 100644 T20/g_decode_fb_detector.f
create mode 100644 T20/g_examine_go_info.f
create mode 100644 T20/g_get_next_event.f
create mode 100644 T20/g_init_filenames.f
create mode 100644 T20/g_initialize.f
create mode 100644 T20/g_open_source.f
create mode 100644 T20/g_proper_shutdown.f
create mode 100644 T20/g_reconstruction.f
create mode 100644 T20/g_register_variables.f
create mode 100644 T20/g_reset_event.f
create mode 100755 T20/g_scaler.f
create mode 100644 T20/g_trans_misc.f
create mode 100644 T20/gen_data_structures.cmn
create mode 100755 T20/gen_misc.cmn
create mode 100644 T20/gen_run_info.cmn
create mode 100644 T20/h_ntuple_init.f
create mode 100644 T20/h_ntuple_keep.f
create mode 100644 T20/t20_bypass_switches.cmn
create mode 100644 T20/t20_data_structures.cmn
create mode 100644 T20/t20_filenames.cmn
create mode 100644 T20/t20_geometry.cmn
create mode 100755 T20/t20_hms.cmn
create mode 100644 T20/t20_hodo.cmn
create mode 100644 T20/t20_hodo_parms.cmn
create mode 100755 T20/t20_misc.cmn
create mode 100644 T20/t20_pedestals.cmn
create mode 100644 T20/t20_reg_polder_structures.cmn
create mode 100644 T20/t20_test_detectors.cmn
create mode 100644 T20/t20_test_histid.cmn
create mode 100644 T20/t20_track_histid.cmn
create mode 100644 T20/t20_tracking.cmn
create mode 100644 T20/t_analyze_pedestal.f
create mode 100644 T20/t_calc_pedestal.f
create mode 100644 T20/t_clear_event.f
create mode 100644 T20/t_dump_peds.f
create mode 100644 T20/t_hms.f
create mode 100644 T20/t_hodos.f
create mode 100644 T20/t_init_histid.f
create mode 100644 T20/t_init_physics.f
create mode 100644 T20/t_initialize.f
create mode 100644 T20/t_misc.f
create mode 100644 T20/t_mwpc.f
create mode 100644 T20/t_ntuple.cmn
create mode 100644 T20/t_ntuple_register.f
create mode 100644 T20/t_proper_shutdown.f
create mode 100644 T20/t_prt_raw_hodo.f
create mode 100644 T20/t_prt_raw_mwpc.f
create mode 100644 T20/t_raw_dump_all.f
create mode 100644 T20/t_reconstruction.f
create mode 100644 T20/t_register_param.f
create mode 100644 T20/t_register_variables.f
create mode 100644 T20/t_reset_event.f
create mode 100644 T20/t_test_straw_analyze.f
create mode 100644 T20/tengine.f
create mode 100644 TRACKING/.cvsignore
create mode 100644 TRACKING/CVS/Entries
create mode 100644 TRACKING/CVS/Repository
create mode 100644 TRACKING/CVS/Root
create mode 100644 TRACKING/CVS/Tag
create mode 100644 TRACKING/Makefile
create mode 100644 TRACKING/Makefile.Unix
create mode 100644 TRACKING/find_space_points.f
create mode 100644 TRACKING/select_space_points.f
create mode 100644 TRACKING/solve_four_by_four.f
create mode 100644 TRACKING/total_eloss.f
create mode 100644 UTILSUBS/.cvsignore
create mode 100644 UTILSUBS/CVS/Entries
create mode 100644 UTILSUBS/CVS/Repository
create mode 100644 UTILSUBS/CVS/Root
create mode 100644 UTILSUBS/CVS/Tag
create mode 100644 UTILSUBS/Makefile
create mode 100644 UTILSUBS/Makefile.Unix
create mode 100644 UTILSUBS/clear_after_null.f
create mode 100644 UTILSUBS/data_row.f
create mode 100644 UTILSUBS/g_add_path.f
create mode 100644 UTILSUBS/g_append.f
create mode 100644 UTILSUBS/g_build_note.f
create mode 100644 UTILSUBS/g_important_length.f
create mode 100644 UTILSUBS/g_int_sort.f
create mode 100644 UTILSUBS/g_io_control.f
create mode 100644 UTILSUBS/g_log_message.f
create mode 100644 UTILSUBS/g_normalize.f
create mode 100644 UTILSUBS/g_prepend.f
create mode 100644 UTILSUBS/g_reg_c.f
create mode 100644 UTILSUBS/g_rep_err.f
create mode 100644 UTILSUBS/g_rep_where.f
create mode 100644 UTILSUBS/g_shift_len.f
create mode 100644 UTILSUBS/g_sort.f
create mode 100644 UTILSUBS/g_sph_xyz.f
create mode 100644 UTILSUBS/g_sub_run_number.f
create mode 100644 UTILSUBS/g_utc_date.f
create mode 100644 UTILSUBS/g_wrap_note.f
create mode 100644 UTILSUBS/g_xyz_sph.f
create mode 100644 UTILSUBS/get_values.f
create mode 100644 UTILSUBS/match.f
create mode 100644 UTILSUBS/no_blanks.f
create mode 100644 UTILSUBS/no_comments.f
create mode 100644 UTILSUBS/no_leading_blanks.f
create mode 100644 UTILSUBS/no_nulls.f
create mode 100644 UTILSUBS/no_tabs.f
create mode 100644 UTILSUBS/only_one_blank.f
create mode 100644 UTILSUBS/regparmstringarray.f
create mode 100644 UTILSUBS/shiftall.f
create mode 100644 UTILSUBS/squeeze.f
create mode 100644 UTILSUBS/string_length.f
create mode 100644 UTILSUBS/sub_string.f
create mode 100644 UTILSUBS/up_case.f
create mode 100644 UTILSUBS/up_shift.f
create mode 100644 etc/CVS/Entries
create mode 100644 etc/CVS/Repository
create mode 100644 etc/CVS/Root
create mode 100644 etc/CVS/Tag
create mode 100644 etc/Makefile
create mode 100644 etc/Makefile.NEW
create mode 100644 etc/Makefile.flags
create mode 100644 etc/Makefile.variables
create mode 100644 etc/makefile.site.in
create mode 100644 modified.txt
diff --git a/BTRACKING/.cvsignore b/BTRACKING/.cvsignore
new file mode 100644
index 0000000..0b6ddf9
--- /dev/null
+++ b/BTRACKING/.cvsignore
@@ -0,0 +1,2 @@
+O.*
+r_*.f
diff --git a/BTRACKING/CVS/Entries b/BTRACKING/CVS/Entries
new file mode 100644
index 0000000..884b2d9
--- /dev/null
+++ b/BTRACKING/CVS/Entries
@@ -0,0 +1,45 @@
+/.cvsignore/1.1.2.1/Wed Sep 12 17:02:28 2007//Tsane
+/Makefile/1.1.2.1/Tue May 15 01:19:10 2007//Tsane
+/Makefile.Unix/1.1.2.9.2.1/Tue Sep 1 19:57:58 2009//Tsane
+/b_add_neighbors.f/1.1.2.3/Sat Nov 3 07:32:03 2007//Tsane
+/b_analyze_pedestal.f/1.1.2.5/Fri Oct 19 16:29:14 2007//Tsane
+/b_calc_cluster_time.f/1.1.2.10.2.1/Thu Mar 3 20:12:05 2011//Tsane
+/b_calc_pedestal.f/1.1.2.8.2.1/Fri Jun 5 17:43:07 2009//Tsane
+/b_calc_physics.f/1.1.2.13/Wed Dec 12 16:00:00 2007//Tsane
+/b_calc_shower_coord.f/1.1.2.8.2.2/Tue Sep 1 19:59:30 2009//Tsane
+/b_dump_peds.f/1.1.2.4/Wed Oct 17 18:40:01 2007//Tsane
+/b_fill_bigcal_arrays.f/1.1.2.1/Tue Jul 17 22:33:50 2007//Tsane
+/b_fill_eff_hists.f/1.1.2.1/Wed Oct 31 22:49:05 2007//Tsane
+/b_find_clusters.f/1.1.2.14.2.2/Tue Sep 1 20:01:12 2009//Tsane
+/b_find_clusters_new.f/1.1.2.1/Tue May 15 01:19:31 2007//Tsane
+/b_find_clusters_old.f/1.1.2.2/Tue Jul 17 22:32:43 2007//Tsane
+/b_generate_geometry.f/1.1.2.4/Fri Jan 11 00:10:24 2008//Tsane
+/b_guess_ecell.f/1.1.2.1/Mon Oct 8 19:16:30 2007//Tsane
+/b_init_bad_list.f/1.1.2.2/Tue Oct 9 14:38:59 2007//Tsane
+/b_init_gain.f/1.1.2.8/Thu Nov 29 19:01:52 2007//Tsane
+/b_init_histid.f/1.1.2.11/Sun Nov 25 23:35:12 2007//Tsane
+/b_init_physics.f/1.1.2.2/Fri Jan 11 00:10:24 2008//Tsane
+/b_init_shower.f/1.1.2.3.2.1/Thu May 15 19:01:42 2008//Tsane
+/b_init_tof.f/1.1.2.2/Fri Dec 7 21:27:25 2007//Tsane
+/b_matrix_accum.f/1.1.2.7/Thu Jan 10 23:23:36 2008//Tsane
+/b_print_cluster.f/1.1.2.4/Fri Oct 26 16:42:44 2007//Tsane
+/b_print_raw_adc.f/1.1.2.2/Mon Sep 24 20:32:52 2007//Tsane
+/b_print_raw_bad.f/1.1.2.2/Wed Oct 10 13:09:58 2007//Tsane
+/b_print_raw_tdc.f/1.1.2.2/Mon Sep 24 20:32:52 2007//Tsane
+/b_print_raw_trig.f/1.1.2.3/Mon Sep 24 20:32:52 2007//Tsane
+/b_prune_clusters.f/1.1.4.2/Tue Sep 1 19:58:27 2009//Tsane
+/b_raw_dump_all.f/1.1.2.2/Mon Sep 24 20:32:52 2007//Tsane
+/b_rebuild_cluster.f/1.1.2.2/Sat Nov 3 07:31:02 2007//Tsane
+/b_reconstruction.f/1.1.2.15.2.3/Tue Sep 1 20:02:38 2009//Tsane
+/b_register_param.f/1.1.2.2/Tue Aug 7 18:46:59 2007//Tsane
+/b_report_bad_data.f/1.1.2.1/Tue May 15 01:19:31 2007//Tsane
+/b_sparsify_prot.f/1.1.2.6/Wed Oct 10 13:09:29 2007//Tsane
+/b_sparsify_rcs.f/1.1.2.9/Mon Oct 22 15:24:42 2007//Tsane
+/b_strip_tdc.f/1.1.2.2/Mon Jun 4 15:03:45 2007//Tsane
+/b_strip_trig.f/1.1.2.4/Wed Oct 10 13:09:29 2007//Tsane
+/b_trans_prot.f/1.1.2.8/Tue Jan 8 22:38:37 2008//Tsane
+/b_trans_rcs.f/1.1.2.8/Tue Jan 8 22:38:37 2008//Tsane
+/b_trans_tdc.f/1.1.2.13/Fri Dec 7 21:24:19 2007//Tsane
+/b_trans_trig.f/1.1.2.14/Fri Dec 7 21:23:37 2007//Tsane
+/bigcal_calib.f/1.1.2.7/Thu Jan 10 23:22:40 2008//Tsane
+D
diff --git a/BTRACKING/CVS/Repository b/BTRACKING/CVS/Repository
new file mode 100644
index 0000000..ca6ddc1
--- /dev/null
+++ b/BTRACKING/CVS/Repository
@@ -0,0 +1 @@
+Analyzer/BTRACKING
diff --git a/BTRACKING/CVS/Root b/BTRACKING/CVS/Root
new file mode 100644
index 0000000..6288c3f
--- /dev/null
+++ b/BTRACKING/CVS/Root
@@ -0,0 +1 @@
+whit@cvs.jlab.org:/group/hallc/cvsroot
diff --git a/BTRACKING/CVS/Tag b/BTRACKING/CVS/Tag
new file mode 100644
index 0000000..25d73f7
--- /dev/null
+++ b/BTRACKING/CVS/Tag
@@ -0,0 +1 @@
+Tsane
diff --git a/BTRACKING/Makefile b/BTRACKING/Makefile
new file mode 100755
index 0000000..5566601
--- /dev/null
+++ b/BTRACKING/Makefile
@@ -0,0 +1,11 @@
+#
+# $Log: Makefile,v $
+# Revision 1.1.2.1 2007/05/15 01:19:10 jones
+# Start to Bigcal code
+#
+# Revision 1.1 1998/12/08 14:33:24 saw
+# Initial Setup
+#
+ETC=../etc
+
+include $(ETC)/Makefile.NEW
diff --git a/BTRACKING/Makefile.Unix b/BTRACKING/Makefile.Unix
new file mode 100644
index 0000000..9bfbfd5
--- /dev/null
+++ b/BTRACKING/Makefile.Unix
@@ -0,0 +1,60 @@
+NEWSTYLE=1
+include ../../etc/Makefile
+include ../../etc/Makefile.flags
+
+
+osources = b_analyze_pedestal.f b_calc_cluster_time.f b_calc_pedestal.f b_calc_physics.f \
+ b_calc_shower_coord.f b_dump_peds.f b_find_clusters.f b_generate_geometry.f b_init_gain.f \
+ b_init_histid.f b_init_physics.f b_init_shower.f b_init_tof.f b_print_raw_adc.f \
+ b_print_raw_tdc.f b_print_raw_trig.f b_raw_dump_all.f b_reconstruction.f b_register_param.f \
+ b_report_bad_data.f b_sparsify_prot.f b_sparsify_rcs.f b_strip_tdc.f b_strip_trig.f \
+ b_trans_prot.f b_trans_rcs.f b_trans_tdc.f b_trans_trig.f b_print_cluster.f \
+ b_fill_bigcal_arrays.f b_add_neighbors.f b_matrix_accum.f bigcal_calib.f \
+ b_print_raw_bad.f b_init_bad_list.f b_guess_ecell.f b_rebuild_cluster.f \
+ b_fill_eff_hists.f b_prune_clusters.f
+makeregstuff = r_bigcal_geometry.f r_bigcal_gain_parms.f r_bigcal_tof_parms.f r_bigcal_shower_parms.f \
+ r_bigcal_bypass_switches.f r_bigcal_hist_id.f
+
+sources = $(osources) $(makeregstuff)
+
+libsources = $(sources)
+
+lib_targets := $(patsubst %.f, libbtracking.a(%.o), $(libsources))
+install-dirs := lib
+bin_targets =
+
+#default:
+# @echo "nothing to make"
+
+ifdef NFSDIRECTORY
+../%.f : $(NFSDIRECTORY)/BTRACKING/%.f
+ ln -s $< $@
+
+.PRECIOUS: ../%.f
+else
+#
+# Rule for making the register subroutines
+#
+../r_%.f : ../%.cmn $(MAKEREG)
+ (cd .. ; $(MAKEREG) $(<F) -o $(@F) -e /dev/null)
+
+.PRECIOUS: ../r_%.f
+endif
+
+#
+# Get include files from INCLUDE directory
+#
+
+%.cmn ../%.cmn:: ../../INCLUDE/%.cmn
+ $(CP) $< $@
+
+%.dec ../%.dec:: ../../INCLUDE/%.dec
+ $(CP) $< $@
+
+%.par ../%.par:: ../../INCLUDE/%.par
+ $(CP) $< $@
+
+%.dte ../%.dte:: ../../INCLUDE/%.dte
+ $(CP) $< $@
+
+include $(sources:.f=.d)
diff --git a/BTRACKING/b_add_neighbors.f b/BTRACKING/b_add_neighbors.f
new file mode 100644
index 0000000..87aae04
--- /dev/null
+++ b/BTRACKING/b_add_neighbors.f
@@ -0,0 +1,468 @@
+ subroutine b_add_neighbors(cell_index,ncell,nbad,ncellmax,ix,iy,x,y,E,A,bad,abort,err)
+
+ implicit none
+ save
+
+ logical abort
+ character*(*) err
+
+ character*15 here
+ parameter(here='b_add_neighbors')
+
+ integer cell_index,ncell,ncellmax,nbad
+ integer ix(ncellmax)
+ integer iy(ncellmax)
+ real x(ncellmax)
+ real y(ncellmax)
+ real E(ncellmax)
+ real A(ncellmax)
+ logical bad(ncellmax)
+
+ integer ix0,iy0
+ integer irow,icol,icell
+
+c logical found_any
+
+ include 'bigcal_data_structures.cmn'
+ include 'bigcal_bypass_switches.cmn'
+ include 'bigcal_geometry.cmn'
+
+ abort = .false.
+ err=' '
+
+ !found_any = .false.
+
+ ix0 = ix(cell_index)
+ iy0 = iy(cell_index)
+
+c$$$ write(*,*) 'searching for neighbors around cell (ix,iy,E) = ',
+c$$$ $ ix0,iy0,E(cell_index)
+
+c check that center cell coordinates are in range!!
+ if(ix0.lt.1 .or. iy0.lt.1 .or. iy0 .gt. 56 .or. ix0.gt.32 .or.
+ $ (iy0.gt.33.and.ix0.gt.30) ) goto 101
+
+ if(iy0 .le. 32) then
+c Check cell to the immediate left, if it exists
+ if(ncell.lt.ncellmax) then
+ irow = iy0
+ icol = ix0 - 1
+ icell = icol + 32*(irow-1)
+ if(icol .ge. 1) then
+ if(bigcal_all_good_det(icell).gt.b_cell_cut_prot) then
+ ncell = ncell + 1
+ ix(ncell) = icol
+ iy(ncell) = irow
+ x(ncell) = bigcal_all_xcenter(icell)
+ y(ncell) = bigcal_all_ycenter(icell)
+ E(ncell) = bigcal_all_good_det(icell)
+ bigcal_all_good_det(icell) = 0.
+ A(ncell) = bigcal_all_adc_det(icell)
+ bigcal_all_adc_det(icell) = 0.
+* the following condition should only be true if we are calling b_find_clusters a second time from
+* gep_check_bigcal:
+ if(bigcal_bad_chan_list(icell)) then
+ bad(ncell) = .true.
+ nbad = nbad + 1
+ bigcal_all_good_det(icell) = -1.
+ endif
+ !found_any = .true.
+ else if(b_use_bad_chan_list.ne.0.and.
+ $ bigcal_bad_chan_list(icell).and.
+ $ (.not.bad(cell_index)).and.
+ $ bigcal_all_good_det(icell).eq.0.) then
+c if one of the nearest neighbors is in the bad channel list, add it to the cluster so that we can
+c continue to build up the cluster around it. However, if the cell in question is itself bad, don't add
+c nearest neighbors if they are also in the bad channels list. That way, if e.g. a whole/half/quarter row
+c is bad, we don't add that whole section of bad channels, just the ones that have nearest neighbors with a hit.
+ ncell = ncell + 1
+ nbad = nbad + 1
+ ix(ncell) = icol
+ iy(ncell) = irow
+ x(ncell) = bigcal_all_xcenter(icell)
+ y(ncell) = bigcal_all_ycenter(icell)
+ E(ncell) = bigcal_all_good_det(icell)
+ bad(ncell) = .true.
+ bigcal_all_good_det(icell) = -1.
+ endif
+ endif
+ endif
+c Check cell to the immediate right, if it exists
+ if(ncell.lt.ncellmax) then
+ irow = iy0
+ icol = ix0 + 1
+ icell = icol + 32*(irow-1)
+
+ if(icol.le.32) then
+ if(bigcal_all_good_det(icell).gt.b_cell_cut_prot) then
+ ncell = ncell + 1
+ ix(ncell) = icol
+ iy(ncell) = irow
+ x(ncell) = bigcal_all_xcenter(icell)
+ y(ncell) = bigcal_all_ycenter(icell)
+ E(ncell) = bigcal_all_good_det(icell)
+ bigcal_all_good_det(icell) = 0.
+ A(ncell) = bigcal_all_adc_det(icell)
+ bigcal_all_adc_det(icell) = 0.
+* the following condition should only be true if we are calling b_find_clusters a second time from
+* gep_check_bigcal:
+ if(bigcal_bad_chan_list(icell)) then
+ bad(ncell) = .true.
+ nbad = nbad + 1
+ bigcal_all_good_det(icell) = -1.
+ endif
+
+ !found_any = .true.
+ else if(b_use_bad_chan_list.ne.0.and.
+ $ bigcal_bad_chan_list(icell).and.
+ $ (.not.bad(cell_index)).and.
+ $ bigcal_all_good_det(icell).eq.0.) then
+c if one of the nearest neighbors is in the bad channel list, add it to the cluster so that we can
+c continue to build up the cluster around it
+ ncell = ncell + 1
+ nbad = nbad + 1
+ ix(ncell) = icol
+ iy(ncell) = irow
+ x(ncell) = bigcal_all_xcenter(icell)
+ y(ncell) = bigcal_all_ycenter(icell)
+ E(ncell) = bigcal_all_good_det(icell)
+ bigcal_all_good_det(icell) = -1.
+ bad(ncell) = .true.
+ endif
+ endif
+ endif
+c Check one cell down, if it exists
+ if(ncell.lt.ncellmax) then
+ irow = iy0-1
+ icol = ix0
+ icell = icol + 32*(irow-1)
+ if(irow.ge.1) then
+ if(bigcal_all_good_det(icell).gt.b_cell_cut_prot) then
+ ncell = ncell + 1
+ ix(ncell) = icol
+ iy(ncell) = irow
+ x(ncell) = bigcal_all_xcenter(icell)
+ y(ncell) = bigcal_all_ycenter(icell)
+ E(ncell) = bigcal_all_good_det(icell)
+ bigcal_all_good_det(icell) = 0.
+ A(ncell) = bigcal_all_adc_det(icell)
+ bigcal_all_adc_det(icell) = 0.
+* the following condition should only be true if we are calling b_find_clusters a second time from
+* gep_check_bigcal:
+ if(bigcal_bad_chan_list(icell)) then
+ bad(ncell) = .true.
+ nbad = nbad + 1
+ bigcal_all_good_det(icell) = -1.
+ endif
+ !found_any = .true.
+ else if(b_use_bad_chan_list.ne.0.and.
+ $ bigcal_bad_chan_list(icell).and.
+ $ (.not.bad(cell_index)).and.
+ $ bigcal_all_good_det(icell).eq.0.) then
+c if one of the nearest neighbors is in the bad channel list, add it to the cluster so that we can
+c continue to build up the cluster around it
+ ncell = ncell + 1
+ nbad = nbad + 1
+ ix(ncell) = icol
+ iy(ncell) = irow
+ x(ncell) = bigcal_all_xcenter(icell)
+ y(ncell) = bigcal_all_ycenter(icell)
+ E(ncell) = bigcal_all_good_det(icell)
+ bad(ncell) = .true.
+ bigcal_all_good_det(icell) = -1.
+ endif
+ endif
+ endif
+c Check one cell up: if going up one row puts us in RCS section,
+c then check closest column according to ixclose_prot!!!!
+ if(ncell.lt.ncellmax) then
+ irow = iy0 + 1
+ icol = ix0
+ if(irow.le.32) then
+ icell = icol + 32*(irow-1)
+ if(bigcal_all_good_det(icell).gt.b_cell_cut_prot) then
+ ncell = ncell + 1
+ ix(ncell) = icol
+ iy(ncell) = irow
+ x(ncell) = bigcal_all_xcenter(icell)
+ y(ncell) = bigcal_all_ycenter(icell)
+ E(ncell) = bigcal_all_good_det(icell)
+ bigcal_all_good_det(icell) = 0.
+ A(ncell) = bigcal_all_adc_det(icell)
+ bigcal_all_adc_det(icell) = 0.
+* the following condition should only be true if we are calling b_find_clusters a second time from
+* gep_check_bigcal:
+ if(bigcal_bad_chan_list(icell)) then
+ bad(ncell) = .true.
+ nbad = nbad + 1
+ bigcal_all_good_det(icell) = -1.
+ endif
+ !found_any = .true.
+ else if(b_use_bad_chan_list.ne.0.and.
+ $ bigcal_bad_chan_list(icell).and.
+ $ (.not.bad(cell_index)).and.
+ $ bigcal_all_good_det(icell).eq.0.) then
+c if one of the nearest neighbors is in the bad channel list, add it to the cluster so that we can
+c continue to build up the cluster around it
+ nbad = nbad + 1
+ ncell = ncell + 1
+ ix(ncell) = icol
+ iy(ncell) = irow
+ x(ncell) = bigcal_all_xcenter(icell)
+ y(ncell) = bigcal_all_ycenter(icell)
+ E(ncell) = bigcal_all_good_det(icell)
+ bad(ncell) = .true.
+ bigcal_all_good_det(icell) = -1.
+ endif
+ else
+ icell = bigcal_prot_maxhits + bigcal_ixclose_prot(icol)
+ if(bigcal_all_good_det(icell).gt.b_cell_cut_rcs) then
+ ncell = ncell + 1
+ ix(ncell) = bigcal_ixclose_prot(icol)
+ iy(ncell) = irow
+ x(ncell) = bigcal_all_xcenter(icell)
+ y(ncell) = bigcal_all_ycenter(icell)
+ E(ncell) = bigcal_all_good_det(icell)
+ bigcal_all_good_det(icell) = 0.
+ A(ncell) = bigcal_all_adc_det(icell)
+ bigcal_all_adc_det(icell) = 0.
+* the following condition should only be true if we are calling b_find_clusters a second time from
+* gep_check_bigcal:
+ if(bigcal_bad_chan_list(icell)) then
+ bad(ncell) = .true.
+ nbad = nbad + 1
+ bigcal_all_good_det(icell) = -1.
+ endif
+ !found_any = .true.
+ else if(b_use_bad_chan_list.ne.0.and.
+ $ bigcal_bad_chan_list(icell).and.
+ $ (.not.bad(cell_index)).and.
+ $ bigcal_all_good_det(icell).eq.0.) then
+c if one of the nearest neighbors is in the bad channel list, add it to the cluster so that we can
+c continue to build up the cluster around it
+ nbad = nbad + 1
+ ncell = ncell + 1
+ ix(ncell) = icol
+ iy(ncell) = irow
+ x(ncell) = bigcal_all_xcenter(icell)
+ y(ncell) = bigcal_all_ycenter(icell)
+ E(ncell) = bigcal_all_good_det(icell)
+ bad(ncell) = .true.
+ bigcal_all_good_det(icell) = -1.
+ endif
+ endif
+ endif
+ else ! center cell is in RCS section
+c check one cell to the left, if it exists:
+ if(ncell.lt.ncellmax) then
+ irow = iy0
+ icol = ix0 - 1
+ icell = bigcal_prot_maxhits + icol + 30*(irow-33)
+ if(icol.ge.1) then
+ if(bigcal_all_good_det(icell).gt.b_cell_cut_rcs) then
+ ncell = ncell + 1
+ ix(ncell) = icol
+ iy(ncell) = irow
+ x(ncell) = bigcal_all_xcenter(icell)
+ y(ncell) = bigcal_all_ycenter(icell)
+ E(ncell) = bigcal_all_good_det(icell)
+ bigcal_all_good_det(icell) = 0.
+ A(ncell) = bigcal_all_adc_det(icell)
+ bigcal_all_adc_det(icell) = 0.
+* the following condition should only be true if we are calling b_find_clusters a second time from
+* gep_check_bigcal:
+ if(bigcal_bad_chan_list(icell)) then
+ bad(ncell) = .true.
+ nbad = nbad + 1
+ bigcal_all_good_det(icell) = -1.
+ endif
+! found_any = .true.
+ else if(b_use_bad_chan_list.ne.0.and.
+ $ bigcal_bad_chan_list(icell).and.
+ $ (.not.bad(cell_index)).and.
+ $ bigcal_all_good_det(icell).eq.0.) then
+c if one of the nearest neighbors is in the bad channel list, add it to the cluster so that we can
+c continue to build up the cluster around it
+ nbad = nbad + 1
+ ncell = ncell + 1
+ ix(ncell) = icol
+ iy(ncell) = irow
+ x(ncell) = bigcal_all_xcenter(icell)
+ y(ncell) = bigcal_all_ycenter(icell)
+ E(ncell) = bigcal_all_good_det(icell)
+ bad(ncell) = .true.
+ bigcal_all_good_det(icell) = -1.
+ endif
+ endif
+ endif
+c check one cell to the right, if it exists:
+ if(ncell.lt.ncellmax) then
+ irow = iy0
+ icol = ix0 + 1
+ icell = bigcal_prot_maxhits + icol + 30*(irow-33)
+ if(icol.le.30) then
+ if(bigcal_all_good_det(icell).gt.b_cell_cut_rcs) then
+ ncell = ncell + 1
+ ix(ncell) = icol
+ iy(ncell) = irow
+ x(ncell) = bigcal_all_xcenter(icell)
+ y(ncell) = bigcal_all_ycenter(icell)
+ E(ncell) = bigcal_all_good_det(icell)
+ bigcal_all_good_det(icell) = 0.
+ A(ncell) = bigcal_all_adc_det(icell)
+ bigcal_all_adc_det(icell) = 0.
+* the following condition should only be true if we are calling b_find_clusters a second time from
+* gep_check_bigcal:
+ if(bigcal_bad_chan_list(icell)) then
+ bad(ncell) = .true.
+ nbad = nbad + 1
+ bigcal_all_good_det(icell) = -1.
+ endif
+! found_any = .true.
+ else if(b_use_bad_chan_list.ne.0.and.
+ $ bigcal_bad_chan_list(icell).and.
+ $ (.not.bad(cell_index)).and.
+ $ bigcal_all_good_det(icell).eq.0.) then
+c if one of the nearest neighbors is in the bad channel list, add it to the cluster so that we can
+c continue to build up the cluster around it
+ nbad = nbad + 1
+ ncell = ncell + 1
+ ix(ncell) = icol
+ iy(ncell) = irow
+ x(ncell) = bigcal_all_xcenter(icell)
+ y(ncell) = bigcal_all_ycenter(icell)
+ E(ncell) = bigcal_all_good_det(icell)
+ bad(ncell) = .true.
+ bigcal_all_good_det(icell) = -1.
+ endif
+ endif
+ endif
+c check one cell up, if it exists:
+ if(ncell.lt.ncellmax) then
+ irow = iy0 + 1
+ icol = ix0
+ icell = bigcal_prot_maxhits + icol + 30*(irow-33)
+ if(irow.le.56) then
+ if(bigcal_all_good_det(icell).gt.b_cell_cut_rcs) then
+ ncell = ncell + 1
+ ix(ncell) = icol
+ iy(ncell) = irow
+ x(ncell) = bigcal_all_xcenter(icell)
+ y(ncell) = bigcal_all_ycenter(icell)
+ E(ncell) = bigcal_all_good_det(icell)
+ bigcal_all_good_det(icell) = 0.
+ A(ncell) = bigcal_all_adc_det(icell)
+ bigcal_all_adc_det(icell) = 0.
+* the following condition should only be true if we are calling b_find_clusters a second time from
+* gep_check_bigcal:
+ if(bigcal_bad_chan_list(icell)) then
+ bad(ncell) = .true.
+ nbad = nbad + 1
+ bigcal_all_good_det(icell) = -1.
+ endif
+! found_any = .true.
+ else if(b_use_bad_chan_list.ne.0.and.
+ $ bigcal_bad_chan_list(icell).and.
+ $ (.not.bad(cell_index)).and.
+ $ bigcal_all_good_det(icell).eq.0.) then
+c if one of the nearest neighbors is in the bad channel list, add it to the cluster so that we can
+c continue to build up the cluster around it
+ ncell = ncell + 1
+ nbad = nbad + 1
+ ix(ncell) = icol
+ iy(ncell) = irow
+ x(ncell) = bigcal_all_xcenter(icell)
+ y(ncell) = bigcal_all_ycenter(icell)
+ E(ncell) = bigcal_all_good_det(icell)
+ bad(ncell) = .true.
+ bigcal_all_good_det(icell) = -1.
+ endif
+ endif
+ endif
+c check one cell down, if it exists: if going one cell down puts us in protvino
+c section, then check closest column according to ixclose_rcs!!!!
+ if(ncell.lt.ncellmax) then
+ irow = iy0 - 1
+ icol = ix0
+ if(irow.ge.33) then
+ icell = bigcal_prot_maxhits + icol + 30*(irow-33)
+ if(bigcal_all_good_det(icell).gt.b_cell_cut_rcs) then
+ ncell = ncell + 1
+ ix(ncell) = icol
+ iy(ncell) = irow
+ x(ncell) = bigcal_all_xcenter(icell)
+ y(ncell) = bigcal_all_ycenter(icell)
+ E(ncell) = bigcal_all_good_det(icell)
+ bigcal_all_good_det(icell) = 0.
+ A(ncell) = bigcal_all_adc_det(icell)
+ bigcal_all_adc_det(icell) = 0.
+* the following condition should only be true if we are calling b_find_clusters a second time from
+* gep_check_bigcal:
+ if(bigcal_bad_chan_list(icell)) then
+ bad(ncell) = .true.
+ nbad = nbad + 1
+ bigcal_all_good_det(icell) = -1.
+ endif
+! found_any = .true.
+ else if(b_use_bad_chan_list.ne.0.and.
+ $ bigcal_bad_chan_list(icell).and.
+ $ (.not.bad(cell_index)).and.
+ $ bigcal_all_good_det(icell).eq.0.) then
+c if one of the nearest neighbors is in the bad channel list, add it to the cluster so that we can
+c continue to build up the cluster around it
+ ncell = ncell + 1
+ nbad = nbad + 1
+ ix(ncell) = icol
+ iy(ncell) = irow
+ x(ncell) = bigcal_all_xcenter(icell)
+ y(ncell) = bigcal_all_ycenter(icell)
+ E(ncell) = bigcal_all_good_det(icell)
+ bad(ncell) = .true.
+ bigcal_all_good_det(icell) = -1.
+ endif
+ else
+ icell = bigcal_ixclose_rcs(icol) + 32*(irow-1)
+ if(bigcal_all_good_det(icell).gt.b_cell_cut_prot) then
+ ncell = ncell + 1
+ ix(ncell) = bigcal_ixclose_rcs(icol)
+ iy(ncell) = irow
+ x(ncell) = bigcal_all_xcenter(icell)
+ y(ncell) = bigcal_all_ycenter(icell)
+ E(ncell) = bigcal_all_good_det(icell)
+ bigcal_all_good_det(icell) = 0.
+ A(ncell) = bigcal_all_adc_det(icell)
+ bigcal_all_adc_det(icell) = 0.
+* the following condition should only be true if we are calling b_find_clusters a second time from
+* gep_check_bigcal:
+ if(bigcal_bad_chan_list(icell)) then
+ bad(ncell) = .true.
+ nbad = nbad + 1
+ bigcal_all_good_det(icell) = -1.
+ endif
+! found_any = .true.
+ else if(b_use_bad_chan_list.ne.0.and.
+ $ bigcal_bad_chan_list(icell).and.
+ $ (.not.bad(cell_index)).and.
+ $ bigcal_all_good_det(icell).eq.0.) then
+c if one of the nearest neighbors is in the bad channel list, add it to the cluster so that we can
+c continue to build up the cluster around it
+ ncell = ncell + 1
+ nbad = nbad + 1
+ ix(ncell) = icol
+ iy(ncell) = irow
+ x(ncell) = bigcal_all_xcenter(icell)
+ y(ncell) = bigcal_all_ycenter(icell)
+ E(ncell) = bigcal_all_good_det(icell)
+ bad(ncell) = .true.
+ bigcal_all_good_det(icell) = -1.
+ endif
+ endif
+ endif
+ endif
+
+ 101 continue
+
+c add_neighbors = found_any
+
+ return
+ end
diff --git a/BTRACKING/b_analyze_pedestal.f b/BTRACKING/b_analyze_pedestal.f
new file mode 100755
index 0000000..9cde5b3
--- /dev/null
+++ b/BTRACKING/b_analyze_pedestal.f
@@ -0,0 +1,107 @@
+ subroutine b_analyze_pedestal(ABORT,err)
+
+ implicit none
+ save
+
+ character*18 here
+ parameter(here='b_analyze_pedestal')
+
+ logical ABORT
+ character*(*) err
+
+ include 'bigcal_data_structures.cmn'
+ include 'bigcal_gain_parms.cmn'
+ include 'bigcal_hist_id.cmn'
+ include 'bigcal_bypass_switches.cmn'
+
+ integer*4 ihit,jhit
+ integer*4 irow,icol,icell
+
+
+
+c pedestals we need to analyze include protvino, rcs, and trigger
+c procedure is to loop over all hits and accumulate ped sums:
+
+c write(*,*) 'bigcal_rcs_nhit=',bigcal_rcs_nhit
+
+ do ihit=1,BIGCAL_PROT_NHIT
+ irow = BIGCAL_PROT_IY(ihit)
+ icol = BIGCAL_PROT_IX(ihit)
+ icell = icol + BIGCAL_PROT_NX*(irow-1)
+
+ if(BIGCAL_PROT_ADC_RAW(ihit).le.bigcal_prot_ped_limit(icell))
+ $ then
+ bigcal_prot_ped_sum2(icell) = bigcal_prot_ped_sum2(icell) +
+ $ BIGCAL_PROT_ADC_RAW(ihit)*BIGCAL_PROT_ADC_RAW(ihit)
+ bigcal_prot_ped_sum(icell) = bigcal_prot_ped_sum(icell) +
+ $ BIGCAL_PROT_ADC_RAW(ihit)
+ bigcal_prot_ped_num(icell) = bigcal_prot_ped_num(icell) + 1
+ if(bigcal_prot_ped_num(icell).eq.nint(bigcal_prot_min_peds
+ $ /5.) ) then
+ bigcal_prot_ped_limit(icell) = 100 +
+ $ bigcal_prot_ped_sum(icell)/bigcal_prot_ped_num(icell)
+ endif
+
+ if(bid_badc(icell).gt.0.and.b_use_peds_in_hist.ne.0) then ! fill ADC hist for sanity check
+ call hf1(bid_badc(icell),float(bigcal_prot_adc_raw(ihit)),
+ $ 1.0)
+ endif
+ endif
+ enddo
+
+ do ihit=1,BIGCAL_RCS_NHIT
+ irow = BIGCAL_RCS_IY(ihit)-32
+ icol = BIGCAL_RCS_IX(ihit)
+ icell = icol + BIGCAL_RCS_NX*(irow-1)
+
+c write(*,*) 'icell,adc_raw,ped_limit=',icell,bigcal_rcs_adc_raw(icell),
+c $ bigcal_rcs_ped_limit(icell)
+
+ if(BIGCAL_RCS_ADC_RAW(ihit).le.bigcal_rcs_ped_limit(icell))
+ $ then
+ bigcal_rcs_ped_sum2(icell) = bigcal_rcs_ped_sum2(icell) +
+ $ BIGCAL_RCS_ADC_RAW(ihit)*BIGCAL_RCS_ADC_RAW(ihit)
+ bigcal_rcs_ped_sum(icell) = bigcal_rcs_ped_sum(icell) +
+ $ BIGCAL_RCS_ADC_RAW(ihit)
+ bigcal_rcs_ped_num(icell) = bigcal_rcs_ped_num(icell) + 1
+ if(bigcal_rcs_ped_num(icell).eq.nint(bigcal_rcs_min_peds
+ $ /5.) ) then
+ bigcal_rcs_ped_limit(icell) = 100 +
+ $ bigcal_rcs_ped_sum(icell)/bigcal_rcs_ped_num(icell)
+ endif
+ if(bid_badc(icell+bigcal_prot_maxhits).gt.0.and.
+ $ b_use_peds_in_hist.ne.0) then
+ call hf1(bid_badc(icell+bigcal_prot_maxhits),float(
+ $ bigcal_rcs_adc_raw(ihit)),1.0)
+ endif
+ endif
+ enddo
+
+ do ihit=1,BIGCAL_ATRIG_NHIT
+ irow = BIGCAL_ATRIG_IGROUP(ihit)
+ icol = BIGCAL_ATRIG_IHALF(ihit)
+ icell = icol + 2*(irow-1)
+
+ if(BIGCAL_ATRIG_ADC_RAW(ihit).le.bigcal_trig_ped_limit(icell))
+ $ then
+ bigcal_trig_ped_sum2(icell) = bigcal_trig_ped_sum2(icell) +
+ $ BIGCAL_ATRIG_ADC_RAW(ihit)*BIGCAL_ATRIG_ADC_RAW(ihit)
+ bigcal_trig_ped_sum(icell) = bigcal_trig_ped_sum(icell) +
+ $ BIGCAL_ATRIG_ADC_RAW(ihit)
+ bigcal_trig_ped_num(icell) = bigcal_trig_ped_num(icell) + 1
+ if(bigcal_trig_ped_num(icell).eq.nint(bigcal_trig_min_peds
+ $ /5.) ) then
+ bigcal_trig_ped_limit(icell) = 100 +
+ $ bigcal_trig_ped_sum(icell)/bigcal_trig_ped_num(icell)
+ endif
+
+ if(bid_btadc(icell).gt.0.and.b_use_peds_in_hist.ne.0) then
+ call hf1(bid_btadc(icell),float(bigcal_atrig_adc_raw(ihit)),
+ $ 1.0)
+ endif
+
+ endif
+ enddo
+
+ return
+ end
diff --git a/BTRACKING/b_calc_cluster_time.f b/BTRACKING/b_calc_cluster_time.f
new file mode 100755
index 0000000..0cfcfcc
--- /dev/null
+++ b/BTRACKING/b_calc_cluster_time.f
@@ -0,0 +1,420 @@
+ subroutine b_calc_cluster_time(ABORT,err)
+
+ implicit none
+ save
+
+ character*19 here
+ parameter(here='b_calc_cluster_time')
+
+ include 'bigcal_data_structures.cmn'
+ include 'bigcal_tof_parms.cmn'
+ include 'gep_data_structures.cmn'
+ include 'bigcal_bypass_switches.cmn'
+
+ logical abort
+ character*(*) err
+
+c the main purpose of this routine is to fill the timing related variables in the
+c cluster array. Maybe later we will use this routine to actually "trim" hits with bad timing
+c off of the clusters. For starters, we will calculate the mean time for a cluster based on
+c the values of all unique TDC channels, separately for sums of 8 and sums of 64. We will
+c also calculate the rms value. If a unique TDC channel has more than one hit, then we
+c choose the value closest to bigcal_window_center as the best value!!!!!!!!!!!!!!!!!
+
+ integer iclust,icell,i
+ integer i8,n8,i64,n64,n8cut,n64cut
+ integer irow,icol,irow8,icol8,irow64,icol64
+ integer icell8,icell64,ihit8,ihit64
+ integer jcell8,jcell64,jhit8,jhit64
+
+ real meant8,rmst8,mintdiff,meant64,rmst64,tdiff,thit
+ real meant8cut,rmst8cut,meant64cut,rmst64cut
+ real t8sum2,t64sum2,t8sum,t64sum
+ real t8sum2_cut,t8sum_cut,t64sum2_cut,t64sum_cut
+ real btrigt,breftime
+
+ real e8sum,e64sum,e8,e64
+
+ integer ihitmin
+
+ logical overlap_row
+
+ abort=.false.
+ err = ' '
+
+c first calculate a reference time:
+
+ mintdiff = 0.
+
+ if(ntrigb.gt.0) then
+ do i=1,ntrigb
+ if(i.eq.1.or.abs(gep_btime(i)-gep_btime_elastic).lt.mintdiff) then
+ btrigt = gep_btime(i)
+ mintdiff = abs(gep_btime(i)-gep_btime_elastic)
+ endif
+ enddo
+ else
+ btrigt = gep_btime_elastic
+ endif
+
+ breftime = bigcal_end_time - btrigt
+
+c corrections to hit times should have lined them up with the TRIGGER time, so
+c after calculating the correction to the hit times and finding the cluster time,
+c we should then simply add the walk correction of the trigger time to the cluster time:
+
+
+c write(*,*) 'breftime = ',breftime
+
+ do iclust=1,bigcal_all_nclstr
+ n8 = 0
+ n8cut = 0
+ n64cut = 0
+ n64 = 0
+
+ e8sum = 0.
+ e64sum = 0.
+
+ meant8 = 0.
+ rmst8 = 0.
+ meant8cut = 0.
+ rmst8cut = 0.
+ meant64 = 0.
+ rmst64 = 0.
+ meant64cut = 0.
+ rmst64cut = 0.
+ t8sum2 = 0.
+ t64sum2 = 0.
+ t8sum = 0.
+ t64sum = 0.
+
+ t8sum_cut = 0.
+ t8sum2_cut = 0.
+ t64sum_cut = 0.
+ t64sum2_cut = 0.
+
+ do icell=1,bigcal_all_clstr_ncell(iclust) ! we start with the maximum
+ irow = bigcal_all_clstr_iycell(iclust,icell)
+ icol = bigcal_all_clstr_ixcell(iclust,icell)
+
+ irow8 = irow
+ if(irow8.le.32) then
+ icol8 = (icol-1)/8 + 1
+ else
+ if(icol.lt.16) then
+ icol8 = (icol-1)/8 + 1
+ else
+ icol8 = icol/8 + 1
+ endif
+ endif
+
+ icell8 = icol8 + 4*(irow8-1)
+
+ if(bigcal_tdc_det_ngood(icell8).gt.0) then
+ if(n8 .eq. 0 ) then ! first channel with a tdc hit
+ n8 = n8 + 1
+ n8cut = n8cut + 1
+
+ bigcal_all_clstr_nhit8(iclust,n8) =
+ $ bigcal_tdc_det_ngood(icell8)
+ bigcal_all_clstr_irow8(iclust,n8) = irow8
+ bigcal_all_clstr_icol8(iclust,n8) = icol8
+ bigcal_all_clstr_s8(iclust,n8) = bigcal_tdc_sum8(icell8)
+
+ e8 = bigcal_tdc_sum8(icell8)
+
+ ihitmin = 0
+c for the first channel, take the hit which is closest to the trigger time:
+ do ihit8=1,bigcal_tdc_det_ngood(icell8)
+ thit = bigcal_tdc_good_det(icell8,ihit8)
+ bigcal_all_clstr_tcell8(iclust,n8,ihit8) = thit
+
+ tdiff = abs(thit - breftime)
+
+ if(ihit8.eq.1) then
+ mintdiff = tdiff
+ ihitmin = ihit8
+ else
+ if(tdiff.lt.mintdiff) then
+ mintdiff = tdiff
+ ihitmin = ihit8
+ endif
+ endif
+ enddo
+
+ thit = bigcal_tdc_good_det(icell8,ihitmin)
+
+ e8sum = e8sum + e8
+
+ t8sum = t8sum + thit
+ t8sum2 = t8sum2 + thit**2
+
+ t8sum_cut = t8sum_cut + thit*e8
+ t8sum2_cut = t8sum2_cut + (thit*e8)**2
+
+ else ! make sure this is a unique TDC channel!!!!
+ do jcell8=1,n8
+ if(irow8.eq.bigcal_all_clstr_irow8(iclust,jcell8)
+ $ .and.icol8.eq.bigcal_all_clstr_icol8(iclust,jcell8))
+ $ then ! not unique, exit the if-block
+ goto 101
+ endif
+ enddo
+ if (n8 .eq. 10) goto 101 ! mkj
+c if we make it to here without jumping out of this if-block, then
+c the tdc channel is unique!!!!
+ n8 = n8 + 1
+
+ if(n8.gt.10) then
+ write(*,*) 'problem, more than 10 unique TDC'//
+ $ ' channels found for cluster ',iclust,
+ $ '(irow,icol) = (',irow,icol,'), (nx,ny)=(',
+ $ bigcal_all_clstr_ncellx(iclust),
+ $ bigcal_all_clstr_ncelly(iclust),
+ $ '), unexpected!'
+ goto 101
+ endif
+
+ bigcal_all_clstr_nhit8(iclust,n8) =
+ $ bigcal_tdc_det_ngood(icell8)
+ bigcal_all_clstr_irow8(iclust,n8) = irow8
+ bigcal_all_clstr_icol8(iclust,n8) = icol8
+ bigcal_all_clstr_s8(iclust,n8) = bigcal_tdc_sum8(icell8)
+
+ e8 = bigcal_tdc_sum8(icell8)
+
+c take hit with min. time difference relative to moving average of cluster
+
+ do ihit8 = 1,bigcal_tdc_det_ngood(icell8)
+ thit = bigcal_tdc_good_det(icell8,ihit8)
+ bigcal_all_clstr_tcell8(iclust,n8,ihit8) = thit
+
+ tdiff = abs(thit - t8sum_cut/e8sum)
+
+ if(ihit8.eq.1) then
+ mintdiff = tdiff
+ ihitmin = ihit8
+ else
+ if(tdiff.lt.mintdiff) then
+ mintdiff = tdiff
+ ihitmin = ihit8
+ endif
+ endif
+ enddo
+
+ thit = bigcal_tdc_good_det(icell8,ihitmin)
+
+ t8sum = t8sum + thit
+ t8sum2 = t8sum2 + thit**2
+
+ if(abs(thit - t8sum_cut / e8sum ).le.b_timing_cut) then
+ n8cut = n8cut + 1
+ e8sum = e8sum + e8
+
+ t8sum_cut = t8sum_cut + thit*e8
+ t8sum2_cut = t8sum2_cut + (thit*e8)**2
+ endif
+
+ endif
+ endif
+ 101 continue
+
+ irow64 = (irow-1)/3 + 1
+
+ if(irow.le.32) then
+ icol64 = (icol-1)/16 + 1
+ else
+ icol64 = icol/16 + 1
+ endif
+
+ icell64 = icol64 + 2*(irow64-1)
+ if(mod(irow-1,3).eq.0 .and.irow-1.gt.0) then
+ overlap_row = .true.
+ else
+ overlap_row = .false.
+ endif
+
+ goto 104
+
+ 103 overlap_row = .false.
+
+ 104 continue
+
+ if(bigcal_ttrig_det_ngood(icell64).gt.0) then
+ if(n64.eq.0 ) then ! first trig. tdc channel with a hit
+ n64 = n64 + 1
+ n64cut = n64cut + 1
+
+ bigcal_all_clstr_nhit64(iclust,n64) =
+ $ bigcal_ttrig_det_ngood(icell64)
+ bigcal_all_clstr_irow64(iclust,n64) = irow64
+ bigcal_all_clstr_icol64(iclust,n64) = icol64
+ bigcal_all_clstr_A64(iclust,n64) =
+ $ bigcal_atrig_good_det(icell64)
+ bigcal_all_clstr_sum64(iclust,n64) =
+ $ bigcal_atrig_sum64(icell64)
+
+ e64 = bigcal_atrig_good_det(icell64)
+
+ if(e64.eq.0.) e64 = bigcal_atrig_sum64(icell64)
+
+ do ihit64=1,bigcal_ttrig_det_ngood(icell64)
+ thit = bigcal_ttrig_good_det(icell64,ihit64)
+ bigcal_all_clstr_tcell64(iclust,n64,ihit64) = thit
+
+ tdiff = abs(thit - breftime)
+
+ if(ihit64.eq.1) then
+ mintdiff = tdiff
+ ihitmin = ihit64
+ else
+ if(tdiff.lt.mintdiff) then
+ mintdiff = tdiff
+ ihitmin = ihit64
+ endif
+ endif
+ enddo
+
+ thit = bigcal_ttrig_good_det(icell64,ihitmin)
+
+ t64sum = t64sum + thit
+ t64sum2 = t64sum2 + thit**2
+
+ e64sum = e64sum + e64
+
+ t64sum_cut = t64sum_cut + thit*e64
+ t64sum2_cut = t64sum2_cut + (thit*e64)**2
+
+ else ! must check if unique trig. tdc channel
+ do jcell64=1,n64
+ if(irow64.eq.bigcal_all_clstr_irow64(iclust,jcell64)
+ $ .and.icol64.eq.bigcal_all_clstr_icol64(iclust,jcell64))
+ $ then
+ goto 102
+ endif
+ enddo
+ if (n64 .eq. 6) goto 102 ! mkj
+c if we make it to this point without jumping out of the if block, then
+c the trig. tdc channel is unique!!!!!!!!!!!!!!!!!!!!!!!!!!
+ n64 = n64 + 1
+
+ if(n64.gt.6) then
+ write(*,*) 'problem, more than 6 unique TTDC'//
+ $ ' channels found for cluster ',iclust,
+ $ '(irow,icol) = (',irow,icol,'), (nx,ny)=(',
+ $ bigcal_all_clstr_ncellx(iclust),
+ $ bigcal_all_clstr_ncelly(iclust),
+ $ '), unexpected!'
+ goto 102
+ endif
+
+ bigcal_all_clstr_nhit64(iclust,n64) =
+ $ bigcal_ttrig_det_ngood(icell64)
+ bigcal_all_clstr_irow64(iclust,n64) = irow64
+ bigcal_all_clstr_icol64(iclust,n64) = icol64
+ bigcal_all_clstr_A64(iclust,n64) =
+ $ bigcal_atrig_good_det(icell64)
+ bigcal_all_clstr_sum64(iclust,n64) =
+ $ bigcal_atrig_sum64(icell64)
+
+ e64 = bigcal_atrig_good_det(icell64)
+
+ if(e64.eq.0.) e64 = bigcal_atrig_sum64(icell64)
+
+ do ihit64=1,bigcal_ttrig_det_ngood(icell64)
+ thit = bigcal_ttrig_good_det(icell64,ihit64)
+ bigcal_all_clstr_tcell64(iclust,n64,ihit64) = thit
+
+ tdiff = abs(thit - t64sum_cut/e64sum)
+
+ if(ihit64.eq.1) then
+ mintdiff = tdiff
+ ihitmin = ihit64
+ else
+ if(tdiff.lt.mintdiff) then
+ mintdiff = tdiff
+ ihitmin = ihit64
+ endif
+ endif
+ enddo
+
+ thit = bigcal_ttrig_good_det(icell64,ihitmin)
+
+ t64sum = t64sum + thit
+ t64sum2 = t64sum2 + thit**2
+
+ if(abs(thit - t64sum_cut / e64sum).le.b_timing_cut) then
+ e64sum = e64sum + e64
+
+ n64cut = n64cut + 1
+ t64sum_cut = t64sum_cut + thit*e64
+ t64sum2_cut = t64sum2_cut + (thit*e64)**2
+ endif
+ endif
+ endif
+
+ 102 continue
+
+ if(overlap_row) then ! also check previous overlapping sum64 channel
+ icell64 = icell64 - 2
+ irow64 = irow64 - 1
+ goto 103
+ endif
+ enddo
+
+ bigcal_all_clstr_ncell8(iclust) = n8
+ bigcal_all_clstr_ncell64(iclust) = n64
+
+ meant8 = t8sum / n8
+ rmst8 = sqrt(max(0.,t8sum2 / n8 - meant8**2))
+
+ if(n8.eq.0) then
+ meant8 = 0.
+ rmst8 = 0.
+ endif
+
+c write(*,*) 't64sum,t64sum2,n64=',t64sum,t64sum2,n64
+
+ meant64 = t64sum / n64
+ rmst64 = sqrt(max(0.,t64sum2 / n64 - meant64**2))
+
+ if(n64.eq.0) then
+ meant64 = 0.
+ rmst64 = 0.
+ endif
+
+ meant8cut = t8sum_cut / e8sum
+ rmst8cut = sqrt(max(0.,t8sum2_cut / e8sum - meant8cut**2))
+
+ if(n8cut.eq.0) then
+ meant8cut = 0.
+ rmst8cut = 0.
+ endif
+
+c write(*,*) 't64sum,t64sum2,n64=',t64sum,t64sum2,n64
+
+ meant64cut = t64sum_cut / e64sum
+ rmst64cut = sqrt(max(0.,t64sum2_cut / e64sum - meant64cut**2))
+
+ if(n64cut.eq.0) then
+ meant64cut = 0.
+ rmst64cut = 0.
+ endif
+
+ bigcal_all_clstr_t8mean(iclust) = meant8
+ bigcal_all_clstr_t64mean(iclust) = meant64
+ bigcal_all_clstr_t8cut(iclust) = meant8cut
+
+ bigcal_all_clstr_t8cut_cor(iclust) = meant8cut +
+ $ gep_btime_corr - breftime
+
+ bigcal_all_clstr_t64cut(iclust) = meant64cut
+ bigcal_all_clstr_t8rms(iclust) = rmst8
+ bigcal_all_clstr_t64rms(iclust) = rmst64
+ bigcal_all_clstr_t64cut_cor(iclust) = meant64cut +
+ $ gep_btime_corr - breftime
+
+ enddo
+
+ return
+ end
diff --git a/BTRACKING/b_calc_pedestal.f b/BTRACKING/b_calc_pedestal.f
new file mode 100755
index 0000000..e1a60dd
--- /dev/null
+++ b/BTRACKING/b_calc_pedestal.f
@@ -0,0 +1,295 @@
+ subroutine b_calc_pedestal(ABORT,err)
+
+ implicit none
+ save
+
+ character*15 here
+ parameter(here='b_calc_pedestal')
+
+ logical ABORT
+ character*(*) err
+
+ include 'bigcal_data_structures.cmn'
+ include 'bigcal_hist_id.cmn'
+ include 'bigcal_gain_parms.cmn'
+ include 'bigcal_filenames.cmn'
+ include 'gen_run_info.cmn'
+
+ integer spareid
+ parameter(spareid=67)
+
+ integer irow,icol,icell
+ integer igroup,ihalf,igr64
+
+ integer nchange
+ integer roc,slot,signalcount
+
+ real numped,sigma2
+
+ character*132 file
+
+ nchange = 0
+
+ do irow=1,BIGCAL_PROT_NY
+ do icol=1,BIGCAL_PROT_NX
+ icell = icol + (irow-1)*BIGCAL_PROT_NX
+ numped = max(1.,float(bigcal_prot_ped_num(icell)))
+c write(*,*) 'prot numped=',numped
+
+ bigcal_prot_new_ped(icell)=bigcal_prot_ped_sum(icell)/numped
+ sigma2=float(bigcal_prot_ped_sum2(icell))/numped -
+ $ (bigcal_prot_new_ped(icell))**2
+
+ bigcal_prot_new_rms(icell) = sqrt(max(0.,sigma2))
+
+ bigcal_prot_new_threshold(icell)=bigcal_prot_new_ped(icell)
+ $ + bigcal_prot_nsparse
+ if(bigcal_prot_new_threshold(icell).lt.0) then
+ bigcal_prot_new_threshold(icell) = 0
+ endif
+ if(bigcal_prot_new_threshold(icell).gt.4000) then
+ bigcal_prot_new_threshold(icell) = 4000
+ endif
+
+ if(abs(bigcal_prot_ped_mean(icell) -
+ $ bigcal_prot_new_ped(icell)).gt. 2.0 *
+ $ bigcal_prot_new_rms(icell)) then
+ nchange = nchange + 1
+ bigcal_prot_change_irow(nchange) = irow
+ bigcal_prot_change_icol(nchange) = icol
+ bigcal_prot_ped_change(nchange) =
+ $ bigcal_prot_new_ped(icell) -
+ $ bigcal_prot_ped_mean(icell)
+ endif
+
+ if(numped.gt.bigcal_prot_min_peds.and.bigcal_prot_min_peds
+ $ .ne.0) then
+ bigcal_prot_ped_mean(icell)=bigcal_prot_new_ped(icell)
+ bigcal_prot_ped_rms(icell)=bigcal_prot_new_rms(icell)
+ bigcal_prot_adc_threshold(icell)=min(bigcal_prot_max_thresh,
+ $ max(bigcal_prot_min_thresh,2.5*bigcal_prot_new_rms(icell)))
+
+ if(bid_bcal_ped_mean_prot.gt.0) then
+ call hf1(bid_bcal_ped_mean_prot,float(icell),
+ $ bigcal_prot_ped_mean(icell))
+ endif
+
+ if(bid_bcal_ped_rms_prot.gt.0) then
+ call hf1(bid_bcal_ped_rms_prot,float(icell),
+ $ bigcal_prot_ped_rms(icell))
+ endif
+
+ if(bid_bcal_pedw_prot.gt.0) then
+ call hf1(bid_bcal_pedw_prot,bigcal_prot_ped_rms(icell),1.)
+ endif
+
+ endif
+ enddo
+ enddo
+
+ bigcal_prot_num_ped_changes = nchange
+
+ nchange = 0
+
+ do irow=1,BIGCAL_RCS_NY
+ do icol=1,BIGCAL_RCS_NX
+ icell = icol + (irow-1)*BIGCAL_RCS_NX
+ numped = max(1.,float(bigcal_rcs_ped_num(icell)))
+
+c write(*,*) 'rcs numped=',numped
+
+ bigcal_rcs_new_ped(icell)=bigcal_rcs_ped_sum(icell)/numped
+ sigma2=float(bigcal_rcs_ped_sum2(icell))/numped -
+ $ (bigcal_rcs_new_ped(icell))**2
+
+ bigcal_rcs_new_rms(icell) = sqrt(max(0.,sigma2))
+
+ bigcal_rcs_new_threshold(icell)=bigcal_rcs_new_ped(icell)
+ $ + bigcal_rcs_nsparse
+ if(bigcal_rcs_new_threshold(icell).lt.0) then
+ bigcal_rcs_new_threshold(icell) = 0
+ endif
+ if(bigcal_rcs_new_threshold(icell).gt.4000) then
+ bigcal_rcs_new_threshold(icell) = 4000
+ endif
+ if(abs(bigcal_rcs_ped_mean(icell) -
+ $ bigcal_rcs_new_ped(icell)).gt. 2.0 *
+ $ bigcal_rcs_new_rms(icell)) then
+ nchange = nchange + 1
+ bigcal_rcs_change_irow(nchange) = irow
+ bigcal_rcs_change_icol(nchange) = icol
+ bigcal_rcs_ped_change(nchange) =
+ $ bigcal_rcs_new_ped(icell) -
+ $ bigcal_rcs_ped_mean(icell)
+ endif
+
+ if(numped.gt.bigcal_rcs_min_peds.and.bigcal_rcs_min_peds
+ $ .ne.0) then
+ bigcal_rcs_ped_mean(icell)=bigcal_rcs_new_ped(icell)
+ bigcal_rcs_ped_rms(icell)=bigcal_rcs_new_rms(icell)
+ bigcal_rcs_adc_threshold(icell)=min(bigcal_rcs_max_thresh,
+ $ max(bigcal_rcs_min_thresh,2.5*bigcal_rcs_new_rms(icell)))
+ if(bid_bcal_ped_mean_rcs.gt.0) then
+ call hf1(bid_bcal_ped_mean_rcs,float(icell),
+ $ bigcal_rcs_ped_mean(icell))
+ endif
+
+ if(bid_bcal_ped_rms_rcs.gt.0) then
+ call hf1(bid_bcal_ped_rms_rcs,float(icell),
+ $ bigcal_rcs_ped_rms(icell))
+ endif
+
+ if(bid_bcal_pedw_rcs.gt.0) then
+ call hf1(bid_bcal_pedw_rcs,bigcal_rcs_ped_rms(icell),1.)
+ endif
+
+ endif
+ enddo
+ enddo
+
+ bigcal_rcs_num_ped_changes = nchange
+
+ nchange = 0
+
+ do igroup=1,BIGCAL_ATRIG_MAXHITS/2
+ do ihalf=1,2
+ igr64 = ihalf + 2*(igroup-1)
+ numped = max(1.,float(bigcal_trig_ped_num(igr64)))
+
+c write(*,*) 'trig numped=',numped
+
+ bigcal_trig_new_ped(igr64)=bigcal_trig_ped_sum(igr64)/numped
+ sigma2=float(bigcal_trig_ped_sum2(igr64))/numped -
+ $ (bigcal_trig_new_ped(igr64))**2
+
+ bigcal_trig_new_rms(igr64) = sqrt(max(0.,sigma2))
+
+ bigcal_trig_new_threshold(igr64)=bigcal_trig_new_ped(igr64)
+ $ + bigcal_trig_nsparse
+ if(bigcal_trig_new_threshold(igr64).lt.0) then
+ bigcal_trig_new_threshold(igr64) = 0
+ endif
+ if(bigcal_trig_new_threshold(igr64).gt.4000) then
+ bigcal_trig_new_threshold(igr64) = 4000
+ endif
+ if(abs(bigcal_trig_ped_mean(igr64) -
+ $ bigcal_trig_new_ped(igr64)).gt. 2.0 *
+ $ bigcal_trig_new_rms(igr64)) then
+ nchange = nchange + 1
+ bigcal_trig_change_irow(nchange) = irow
+ bigcal_trig_change_icol(nchange) = icol
+ bigcal_trig_ped_change(nchange) =
+ $ bigcal_trig_new_ped(igr64) -
+ $ bigcal_trig_ped_mean(igr64)
+ endif
+
+ if(numped.gt.bigcal_trig_min_peds.and.bigcal_trig_min_peds
+ $ .ne.0) then
+ bigcal_trig_ped_mean(igr64)=bigcal_trig_new_ped(igr64)
+ bigcal_trig_ped_rms(igr64)=bigcal_trig_new_rms(igr64)
+ bigcal_trig_adc_threshold(igr64)=min(bigcal_trig_max_thresh,
+ $ max(bigcal_trig_min_thresh,3.*bigcal_trig_new_rms(igr64)))
+ if(bid_bcal_ped_mean_trig.gt.0) then
+ call hf1(bid_bcal_ped_mean_trig,float(igr64),
+ $ bigcal_trig_ped_mean(igr64))
+ endif
+
+ if(bid_bcal_ped_rms_trig.gt.0) then
+ call hf1(bid_bcal_ped_rms_trig,float(igr64),
+ $ bigcal_trig_ped_rms(igr64))
+ endif
+
+ if(bid_bcal_pedw_trig.gt.0) then
+ call hf1(bid_bcal_pedw_trig,bigcal_trig_ped_rms(igr64),1.)
+ endif
+
+ endif
+ enddo
+ enddo
+
+ bigcal_trig_num_ped_changes = nchange
+
+c now we write thresholds to file for hardware sparsification:
+
+ if(b_roc11_threshold_output_filename.ne.' ') then
+ file = b_roc11_threshold_output_filename
+ call g_sub_run_number(file,gen_run_number)
+ open(unit=SPAREID,file=file,status='unknown')
+
+c$$$ write(SPAREID,*) '# This is the ADC threshold file generated '//
+c$$$ $ 'automatically'
+c$$$ write(SPAREID,666)'# from the pedestal data, run ',gen_run_number
+c$$$ write(SPAREID,*) '# ROC11 (BigCal Protvino and trigger ADCs):'
+c$$$ 666 format(A31,I8)
+ roc=11
+c protvino ADCs are NO LONGER in ROC11, slots 3-10 and 14-21
+c protvino ADCs are now in ROC11, slots 3-19
+
+ signalcount=1
+c change slot range to 3-20 since now we have several cables in slot 20
+ do slot=3,18
+ write(spareid,*) 'slot=',slot
+ call g_output_thresholds(spareid,roc,slot,signalcount,
+ $ BIGCAL_PROT_NX,bigcal_prot_new_threshold,0,
+ $ bigcal_prot_new_rms,0)
+ enddo
+
+ slot=19
+ write(spareid,*) 'slot=',slot
+ call g_output_thresholds(spareid,roc,slot,signalcount,
+ $ 2,bigcal_trig_new_threshold,0,
+ $ bigcal_trig_new_rms,0)
+
+
+ slot=20
+ write(spareid,*) 'slot=',slot
+ call g_output_thresholds(spareid,roc,slot,signalcount,
+ $ bigcal_prot_nx,bigcal_prot_new_threshold,0,
+ $ bigcal_prot_new_rms,0)
+
+
+ close(spareid)
+ endif
+
+c$$$ do slot=14,21
+c$$$ write(spareid,*) 'slot=',slot
+c$$$ call g_output_thresholds(spareid,roc,slot,signalcount,
+c$$$ $ BIGCAL_PROT_NX,bigcal_prot_new_threshold,0,
+c$$$ $ bigcal_prot_new_rms,0)
+c$$$ enddo
+c trigger ADCs are in roc 11, slot 22
+c$$$ slot=22
+c$$$ write(spareid,*) 'slot=',slot
+c$$$ call g_output_thresholds(spareid,roc,slot,signalcount,
+c$$$ $ 2,bigcal_trig_new_threshold,0,
+c$$$ $ bigcal_trig_new_rms,0)
+
+c rcs ADCs are in ROC12, slots 6-11 and 15-20
+
+c$$$ write(SPAREID,*) '# ROC12 (BigCal RCS ADCs):'
+
+ if(b_roc12_threshold_output_filename.ne.' ') then
+ file=b_roc12_threshold_output_filename
+ call g_sub_run_number(file,gen_run_number)
+ open(unit=SPAREID,file=file,status='unknown')
+ roc=12
+ do slot=6,11
+ write(spareid,*) 'slot=',slot
+ call g_output_thresholds(spareid,roc,slot,signalcount,
+ $ BIGCAL_RCS_NX,bigcal_rcs_new_threshold,0,
+ $ bigcal_rcs_new_rms,0)
+ enddo
+
+ do slot=15,20
+ write(spareid,*) 'slot=',slot
+ call g_output_thresholds(spareid,roc,slot,signalcount,
+ $ BIGCAL_RCS_NX,bigcal_rcs_new_threshold,0,
+ $ bigcal_rcs_new_rms,0)
+ enddo
+
+ close(spareid)
+
+ endif
+
+ return
+ end
diff --git a/BTRACKING/b_calc_physics.f b/BTRACKING/b_calc_physics.f
new file mode 100755
index 0000000..a1576ae
--- /dev/null
+++ b/BTRACKING/b_calc_physics.f
@@ -0,0 +1,221 @@
+ subroutine b_calc_physics(ABORT,err)
+
+ implicit none
+ save
+
+ character*14 here
+ parameter(here='b_calc_physics')
+
+ logical ABORT
+ character*(*) err
+
+ include 'bigcal_data_structures.cmn'
+ include 'bigcal_tof_parms.cmn'
+c include 'gen_units.par'
+ include 'gen_constants.par'
+ include 'gen_data_structures.cmn'
+ include 'gen_event_info.cmn'
+ include 'gep_data_structures.cmn'
+ include 'hms_data_structures.cmn'
+ include 'bigcal_hist_id.cmn'
+
+ integer i,j,k,ntrack,itrackmax,nprot,nrcs,nmid
+ integer irow,icol,icell
+ real E,x,y,z,t,R,L,tof,Rperp
+ real xrot,zrot
+ real thetadeg,thetarad,phideg,phirad
+ real Sinth,Costh
+ real m_e
+ real mom,beta,c,eloss,gamma,log10betagamma
+ real maxetot
+ real edx,edy,edz,vx,vy,vz
+
+c integer ilow,ihigh
+
+c logical last_time
+
+ ntrack = 0
+
+ ABORT=.false.
+ err=' '
+
+ Sinth = BIGCAL_SINTHETA
+ Costh = BIGCAL_COSTHETA
+ R = BIGCAL_R_TGT
+ m_e = mass_electron
+ c = speed_of_light
+
+c$$$ nprot = 0
+c$$$ nrcs = 0
+c$$$ nmid = 0
+c this routine also fills many standard histograms
+
+ if(BIGCAL_ALL_NCLSTR.gt.0) then
+ do i=1,bigcal_all_nclstr
+ ntrack = ntrack + 1
+c nprot = nprot + 1
+ x = BIGCAL_ALL_CLSTR_X(i)
+ y = BIGCAL_ALL_CLSTR_Y(i)
+ E = BIGCAL_ALL_CLSTR_ETOT(i)
+
+ if(bid_bcal_ixclust.gt.0) call hf1(bid_bcal_ixclust,
+ $ float(bigcal_all_clstr_ixmax(i)),1.0)
+ if(bid_bcal_iyclust.gt.0) call hf1(bid_bcal_iyclust,
+ $ float(bigcal_all_clstr_iymax(i)),1.0)
+ if(bid_bcal_rowcolclust.gt.0) call hf2(bid_bcal_rowcolclust,
+ $ float(bigcal_all_clstr_ixmax(i)),float(bigcal_all_clstr_iymax(i)),1.0)
+ if(bid_bcal_xclust.gt.0) call hf1(bid_bcal_xclust,x,1.0)
+ if(bid_bcal_yclust.gt.0) call hf1(bid_bcal_yclust,y,1.0)
+ if(bid_bcal_xmom.gt.0) call hf1(bid_bcal_xmom,bigcal_all_clstr_xmom(i),1.0)
+ if(bid_bcal_ymom.gt.0) call hf1(bid_bcal_ymom,bigcal_all_clstr_ymom(i),1.0)
+ if(bid_bcal_ncellclst.gt.0) call hf1(bid_bcal_ncellclst,float(bigcal_all_clstr_ncell(i)),1.0)
+ if(bid_bcal_nxclust.gt.0) call hf1(bid_bcal_nxclust,float(bigcal_all_clstr_ncellx(i)),1.0)
+ if(bid_bcal_nyclust.gt.0) call hf1(bid_bcal_nyclust,float(bigcal_all_clstr_ncelly(i)),1.0)
+ if(bid_bcal_nxny.gt.0) call hf2(bid_bcal_nxny,float(bigcal_all_clstr_ncellx(i)),
+ $ float(bigcal_all_clstr_ncelly(i)),1.0)
+ if(bid_bcal_xy.gt.0) call hf2(bid_bcal_xy,x,y,1.0)
+
+ t = BIGCAL_ALL_CLSTR_T8CUT(i)
+
+ if(bigcal_all_clstr_ncell8(i).gt.0) then
+ if(bid_bcal_tmean.gt.0) call hf1(bid_bcal_tmean,t,1.0)
+ if(bid_bcal_trms.gt.0) call hf1(bid_bcal_trms,bigcal_all_clstr_t8rms(i),1.0)
+ endif
+c correct every track for energy loss. BigCal is always electron arm
+c need to set up eloss params for BigCal absorber!
+ xrot = x * Costh + R * Sinth
+ zrot = -x * Sinth + R * Costh
+
+ if(gen_event_type.eq.6.and.hsnum_fptrack.gt.0) then ! correct angles for HMS vertex:
+ vx = gbeam_x
+ vy = gbeam_y
+ vz = hszbeam
+
+ edx = xrot - vx
+ edy = y - vy
+ edz = zrot - vz
+
+ L = sqrt(edx**2 + edy**2 + edz**2)
+
+ thetarad = acos(edz/L)
+ thetadeg = 180./tt * thetarad
+
+ phirad = atan2(edy,edx)
+ phideg = 180./tt * phirad
+ else
+ L = sqrt(xrot**2 + zrot**2 + y**2)
+c all length units are cm
+ thetarad = acos(zrot/L)
+ thetadeg = 180./tt * thetarad
+
+ phirad = atan2(y,xrot)
+ phideg = 180./tt * phirad
+ endif
+
+c if(last_time) then
+ if(bid_bcal_theta.gt.0) call hf1(bid_bcal_theta,thetadeg,1.0)
+c endif
+
+c if(last_time) then
+ if(bid_bcal_phi.gt.0) call hf1(bid_bcal_phi,phideg,1.0)
+c endif
+ gamma = E / m_e
+
+ beta = sqrt(max(0.,1. - 1./gamma**2))
+
+ if(gamma.lt.1.) beta = 1.
+
+ log10betagamma = log(beta*gamma) / log(10.)
+
+ if(gtarg_z(gtarg_num).gt.0) then
+ call total_eloss(3,.true.,thetarad,log10betagamma,eloss)
+ else
+ eloss = 0.
+ endif
+c for now, set eloss to zero for monte carlo analysis!
+c$$$ if(gen_bigcal_mc.ne.0) then
+c$$$ eloss = 0.
+c$$$ endif
+
+ E = E + eloss
+
+c if(last_time) then
+ if(bid_bcal_eclust.gt.0) call hf1(bid_bcal_eclust,E,1.0)
+c endif
+c increment energy sum
+ irow = bigcal_all_clstr_iymax(i)
+ icol = bigcal_all_clstr_ixmax(i)
+
+ if(irow.le.32) then
+ icell = icol + 32*(irow-1)
+ else
+ icell = icol + 30*(irow-33) + bigcal_prot_maxhits
+ endif
+
+ b_all_run_Esum(icell) = b_all_run_Esum(icell)+E
+ b_all_run_Enum(icell) = b_all_run_Enum(icell)+1
+
+ mom = sqrt(max(0.,E**2 - m_e**2))
+ beta = mom/E
+ if(mom.eq.0.) beta = 1.
+ tof = L/(beta*c)
+
+c Rperp = L*sin(thetarad)
+
+ BIGCAL_TRACK_THETARAD(ntrack) = thetarad
+ BIGCAL_TRACK_THETADEG(ntrack) = thetadeg
+ BIGCAL_TRACK_PHIRAD(ntrack) = phirad
+ BIGCAL_TRACK_PHIDEG(ntrack) = phideg
+ BIGCAL_TRACK_ENERGY(ntrack) = E
+ BIGCAL_TRACK_TIME(ntrack) = t
+ BIGCAL_TRACK_XFACE(ntrack) = xrot
+ BIGCAL_TRACK_YFACE(ntrack) = y
+ BIGCAL_TRACK_ZFACE(ntrack) = zrot
+ BIGCAL_TRACK_PX(ntrack) = mom * sin(thetarad) * cos(phirad)
+ BIGCAL_TRACK_PY(ntrack) = mom * sin(thetarad) * sin(phirad)
+ BIGCAL_TRACK_PZ(ntrack) = mom * cos(thetarad)
+ BIGCAL_TRACK_BETA(ntrack) = beta
+ BIGCAL_TRACK_TOF(ntrack) = tof
+ bigcal_track_tof_cor(ntrack) = tof - bigcal_tof_central
+
+c write(*,*) 'tof correction = ',tof - bigcal_tof_central
+
+ BIGCAL_TRACK_COIN_TIME(ntrack) = t - bigcal_track_tof_cor(ntrack)
+
+c increment some efficiency sums:
+ do irow=bigcal_all_clstr_iylo(i),
+ $ bigcal_all_clstr_iyhi(i)
+ if(irow.le.32) then
+ do icol=bigcal_all_clstr_ixlo(i,2),
+ $ bigcal_all_clstr_ixhi(i,2)
+ icell=icol+32*(irow-1)
+ if(bigcal_prot_good_det(icell).gt.b_cell_cut_prot)
+ $ then
+ b_all_run_clst_good(icell) =
+ $ b_all_run_clst_good(icell) + 1
+ else
+ b_all_run_clst_bad(icell) =
+ $ b_all_run_clst_bad(icell) + 1
+ endif
+ enddo
+ else
+ do icol=bigcal_all_clstr_ixlo(i,3),
+ $ bigcal_all_clstr_ixhi(i,3)
+ icell=icol + 30*(irow-33) + bigcal_prot_maxhits
+ if(bigcal_rcs_good_det(icell-bigcal_prot_maxhits)
+ $ .gt.b_cell_cut_rcs) then
+ b_all_run_clst_good(icell) =
+ $ b_all_run_clst_good(icell) + 1
+ else
+ b_all_run_clst_bad(icell) =
+ $ b_all_run_clst_bad(icell) + 1
+ endif
+ enddo
+ endif
+ enddo
+ enddo
+ bigcal_phys_ntrack = ntrack
+ endif
+
+ return
+ end
diff --git a/BTRACKING/b_calc_shower_coord.f b/BTRACKING/b_calc_shower_coord.f
new file mode 100755
index 0000000..cfd4c2a
--- /dev/null
+++ b/BTRACKING/b_calc_shower_coord.f
@@ -0,0 +1,219 @@
+ subroutine b_calc_shower_coord(ABORT,err)
+
+ implicit none
+ save
+
+ character*19 here
+ parameter(here='b_calc_shower_coord')
+
+ logical ABORT
+ character*(*) err
+
+ include 'bigcal_data_structures.cmn'
+ include 'bigcal_gain_parms.cmn'
+ include 'bigcal_geometry.cmn'
+ include 'bigcal_shower_parms.cmn'
+ include 'bigcal_bypass_switches.cmn'
+ include 'gen_data_structures.cmn'
+
+ integer i,j,irow,icol,icell,ibin,xsector,ysector,foundbin,section
+ real x,y
+ real xmom,ymom,xcenter,ycenter,xdiff,ydiff,xshift,yshift
+ real xpar(6),ypar(6)
+ real mlo,mhi,binwidth,frac,frachi,fraclo,sizex,sizey
+ real tmax
+ real Ecrit
+ parameter(Ecrit=.015) ! critical energy for TF1 lead glass in GeV
+ real X0
+ parameter(X0=2.74) ! rad length in cm for TF1 lead glass
+
+c all clusters are already sorted in order of decreasing amplitude, so cell 1 is the maximum
+
+ do i=1,bigcal_all_nclstr
+
+ if(b_recon_using_map.ne.0) then
+
+ xcenter = bigcal_all_clstr_xcell(i,1)
+ ycenter = bigcal_all_clstr_ycell(i,1)
+
+ xmom = bigcal_all_clstr_xmom(i)
+ ymom = bigcal_all_clstr_ymom(i)
+
+ irow = bigcal_all_clstr_iycell(i,1)
+ icol = bigcal_all_clstr_ixcell(i,1)
+
+ if(irow.le.32) then
+ xmom = xmom / bigcal_prot_size_x
+ ymom = ymom / bigcal_prot_size_y
+
+ sizex = bigcal_prot_size_x
+ sizey = bigcal_prot_size_y
+
+ else
+ xmom = xmom / bigcal_rcs_size_x
+ ymom = ymom / bigcal_rcs_size_y
+
+ sizex = bigcal_rcs_size_x
+ sizey = bigcal_rcs_size_y
+
+ endif
+
+c write(*,*) 'xmom,ymom=',xmom,ymom
+
+ xsector = (icol-1)/8 + 1
+ ysector = (irow-1)/8 + 1
+
+ section = xsector + 4*(ysector-1)
+
+c write(*,*) 'xsector,ysector=',xsector,ysector
+
+ !first do x
+ binwidth = (bigcal_xmap_mmax(section) - bigcal_xmap_mmin(section)) /
+ $ float(bigcal_xmap_nbin(section))
+ mlo = bigcal_xmap_mmin(section)
+
+c write(*,*) 'binwidth=',binwidth
+
+ if(xmom.lt.bigcal_xmap_mmin(section).or.xmom.gt.
+ $ bigcal_xmap_mmax(section)) then
+ xdiff = xmom * sizex
+ endif
+
+ do ibin=1,bigcal_xmap_nbin(section)
+ mhi = mlo + binwidth
+
+ if(mlo.le.xmom.and.xmom.le.mhi) then ! cluster is in this bin
+c write(*,*) 'mlo,mhi,xmom=',mlo,mhi,xmom
+ if(ibin.gt.1) then
+ fraclo = bigcal_xmap_xfrac(section,ibin-1)
+ else
+ fraclo = 0.
+ endif
+ frachi = bigcal_xmap_xfrac(section,ibin)
+c linearly interpolate frac within this bin
+ frac = fraclo + (frachi - fraclo)/(mhi - mlo) * (xmom - mlo)
+
+c write(*,*) 'fraclo,frachi,frac=',fraclo,frachi,frac
+ xdiff = (-.5 + frac)*sizex
+c write(*,*) 'xdiff=',xdiff
+
+c jump out of the loop once we find the right bin
+ goto 101
+ endif
+ mlo = mhi
+ enddo
+
+ 101 continue
+ !then do y
+ binwidth = (bigcal_ymap_mmax(section) - bigcal_ymap_mmin(section)) /
+ $ float(bigcal_ymap_nbin(section))
+ mlo = bigcal_ymap_mmin(section)
+
+ if(ymom.lt.bigcal_ymap_mmin(section).or.ymom.gt.
+ $ bigcal_ymap_mmax(section)) then
+ ydiff = ymom * sizey
+ endif
+
+ do ibin=1,bigcal_ymap_nbin(section)
+ mhi = mlo + binwidth
+
+ if(mlo.le.ymom.and.ymom.le.mhi) then ! cluster is in this bin
+ if(ibin.gt.1) then
+ fraclo = bigcal_ymap_yfrac(section,ibin-1)
+ else
+ fraclo = 0.
+ endif
+ frachi = bigcal_ymap_yfrac(section,ibin)
+c linearly interpolate frac within this bin
+ frac = fraclo + (frachi - fraclo)/(mhi - mlo) * (ymom - mlo)
+
+ ydiff = (-.5 + frac)*sizey
+c exit the do loop when we find the right bin.
+ goto 102
+
+ endif
+ mlo = mhi
+ enddo
+
+ 102 continue
+
+c$$$ xshift = bigcal_shower_map_shift(1) + (xcenter + xdiff)*
+c$$$ $ bigcal_shower_map_slope(1)
+c$$$ yshift = bigcal_shower_map_shift(2) + (ycenter + ydiff)*
+c$$$ $ bigcal_shower_map_slope(2)
+
+c for shower map-based reconstruction, use a very CRUDE model for the incident-angle distortion,
+c so we don't have to do lots of simulations and come up with parameters...
+c according to Particle Data Group's "Passage of Particles Through Matter", an approximate formula for tmax,
+c the depth in radiation lengths at which the energy deposition peaks in electromagnetic cascades, is given by:
+c tmax = 1.0 * (ln y + C) where y = E/Ec, E is electron energy, Ec is critical energy, and C = +.5 for photon
+c showers, and -.5 for electron showers. Assuming electrons, then, tmax for lead-glass can be found as follows:
+c X0 of TF1-0 lead glass (from Charles' note) X0 = 2.74 cm, Ecrit = 15 MeV, therefore, tmax for electrons =
+c tmax = ln(E'/15 MeV) - 0.5
+c BigCal measures the energy of the cluster. Large error, but smaller error on the logarithm:
+c This is a small correction of at MOST 2 cm
+
+ tmax = X0 / sqrt(2.0) * max(0.,log(bigcal_all_clstr_etot(i) / Ecrit) - 0.5 ) ! tmax in cm.
+
+ x = xcenter + xdiff
+ y = ycenter + ydiff
+
+ if(b_use_distcorr.ne.0) then
+
+ xshift = tmax * x / sqrt(x**2 + bigcal_r_tgt**2) ! sin(thetax) of incident electron
+ yshift = tmax * y / sqrt(y**2 + bigcal_r_tgt**2) ! sin(thetay) of incident electron
+
+ else
+
+ xshift = 0.0
+ yshift = 0.0
+
+ endif
+
+ bigcal_all_clstr_x(i) = xcenter + xdiff - xshift
+ bigcal_all_clstr_y(i) = ycenter + ydiff - yshift
+
+ else
+
+ xcenter = bigcal_all_clstr_xcell(i,1)
+ ycenter = bigcal_all_clstr_ycell(i,1)
+
+ xmom = bigcal_all_clstr_xmom(i)
+ ymom = bigcal_all_clstr_ymom(i)
+
+ irow = bigcal_all_clstr_iycell(i,1)
+ icol = bigcal_all_clstr_ixcell(i,1)
+
+ if(irow.eq.1) irow = 2
+ if(irow.eq.56) irow = 55
+
+ if(irow.le.32) then
+ if(icol.eq.1) icol = 2
+ if(icol.eq.32) icol = 31
+
+ do j=1,6
+ xpar(j) = bigcal_prot_xpar(icol,j)
+ ypar(j) = bigcal_prot_ypar(irow,j)
+ enddo
+ else
+ if(icol.eq.1) icol = 2
+ if(icol.eq.30) icol = 29
+
+ do j=1,6
+ xpar(j) = bigcal_rcs_xpar(icol,j)
+ ypar(j) = bigcal_rcs_ypar(irow-32,j)
+ enddo
+ endif
+
+ xdiff = xpar(1) * atan(xpar(2)*xmom**4 + xpar(3)*xmom**3 +
+ $ xpar(4)*xmom**2 + xpar(5)*xmom + xpar(6))
+ ydiff = ypar(1) * atan(ypar(2)*ymom**4 + ypar(3)*ymom**3 +
+ $ ypar(4)*ymom**2 + ypar(5)*ymom + ypar(6))
+
+ bigcal_all_clstr_x(i) = xcenter + xdiff
+ bigcal_all_clstr_y(i) = ycenter + ydiff
+ endif
+ enddo
+
+ return
+ end
diff --git a/BTRACKING/b_dump_peds.f b/BTRACKING/b_dump_peds.f
new file mode 100644
index 0000000..3b89005
--- /dev/null
+++ b/BTRACKING/b_dump_peds.f
@@ -0,0 +1,160 @@
+ subroutine b_dump_peds(ABORT,err)
+
+ implicit none
+ save
+
+ character*11 here
+ parameter(here='b_dump_peds')
+
+ logical abort
+ character*(*) err
+
+ integer spareid
+ parameter(spareid=67)
+
+ character*132 file
+ integer*4 irow,icol,igroup,ihalf
+
+ include 'bigcal_data_structures.cmn'
+ include 'bigcal_gain_parms.cmn'
+ include 'bigcal_filenames.cmn'
+ include 'gen_run_info.cmn'
+
+ if(b_pedestal_output_filename.ne.' ') then
+ file = b_pedestal_output_filename
+ call g_sub_run_number(file,gen_run_number)
+ open(unit=spareid,file=file,status='unknown')
+ else
+ return
+ endif
+
+ write(spareid,*) ';these are the values that were used '
+ write(spareid,*) ';for the analysis (from the param file'//
+ $ ' or ped. events)'
+ write(spareid,666) 'bigcal_prot_min_peds = ',bigcal_prot_min_peds
+ write(spareid,666) 'bigcal_rcs_min_peds = ',bigcal_rcs_min_peds
+ write(spareid,666) 'bigcal_trig_min_peds = ',bigcal_trig_min_peds
+ write(spareid,667) 'bigcal_prot_min_thresh = ',bigcal_prot_min_thresh
+ write(spareid,667) 'bigcal_prot_max_thresh = ',bigcal_prot_max_thresh
+ write(spareid,667) 'bigcal_rcs_min_thresh = ',bigcal_rcs_min_thresh
+ write(spareid,667) 'bigcal_rcs_max_thresh = ',bigcal_rcs_max_thresh
+ write(spareid,667) 'bigcal_trig_min_thresh = ',bigcal_trig_min_thresh
+ write(spareid,667) 'bigcal_trig_max_thresh = ',bigcal_trig_max_thresh
+ write(spareid,666) 'bigcal_prot_nsparse = ',bigcal_prot_nsparse
+ write(spareid,666) 'bigcal_rcs_nsparse = ',bigcal_rcs_nsparse
+ write(spareid,666) 'bigcal_trig_nsparse = ',bigcal_trig_nsparse
+ 666 format(A30,I6)
+ 667 format(A30,F8.5)
+ write(spareid,*) 'bigcal_prot_ped_mean = '
+ do irow=1,bigcal_prot_ny
+ write(spareid,100) (bigcal_prot_ped_mean(icol+bigcal_prot_nx*
+ $ (irow-1)),icol=1,16)
+ if(irow.lt.bigcal_prot_ny) then
+ write(spareid,100) (bigcal_prot_ped_mean(icol+bigcal_prot_nx*
+ $ (irow-1)),icol=17,32)
+ else
+ write(spareid,130) (bigcal_prot_ped_mean(icol+bigcal_prot_nx*
+ $ (irow-1)),icol=17,32)
+ endif
+ enddo
+ write(spareid,*) 'bigcal_prot_ped_rms = '
+ do irow=1,bigcal_prot_ny
+ write(spareid,100) (bigcal_prot_ped_rms(icol+bigcal_prot_nx*
+ $ (irow-1)),icol=1,16)
+ if(irow.lt.bigcal_prot_ny) then
+ write(spareid,100) (bigcal_prot_ped_rms(icol+bigcal_prot_nx*
+ $ (irow-1)),icol=17,32)
+ else
+ write(spareid,130) (bigcal_prot_ped_rms(icol+bigcal_prot_nx*
+ $ (irow-1)),icol=17,32)
+ endif
+ enddo
+ write(spareid,*) 'bigcal_prot_adc_threshold = '
+ do irow=1,bigcal_prot_ny
+ write(spareid,100) (bigcal_prot_adc_threshold(icol +
+ $ bigcal_prot_nx*(irow-1)),icol=1,16)
+ if(irow.lt.bigcal_prot_ny) then
+ write(spareid,100) (bigcal_prot_adc_threshold(icol +
+ $ bigcal_prot_nx*(irow-1)),icol=17,32)
+ else
+ write(spareid,130) (bigcal_prot_adc_threshold(icol +
+ $ bigcal_prot_nx*(irow-1)),icol=17,32)
+ endif
+ enddo
+ 100 format(16(f8.2,','))
+ 130 format(15(f8.2,','),f8.2)
+ write(spareid,*) 'bigcal_rcs_ped_mean = '
+ do irow=1,bigcal_rcs_ny
+ write(spareid,101) (bigcal_rcs_ped_mean(icol+bigcal_rcs_nx*
+ $ (irow-1)),icol=1,15)
+ if(irow.lt.bigcal_rcs_ny) then
+ write(spareid,101) (bigcal_rcs_ped_mean(icol+bigcal_rcs_nx*
+ $ (irow-1)),icol=16,30)
+ else
+ write(spareid,131) (bigcal_rcs_ped_mean(icol+bigcal_rcs_nx*
+ $ (irow-1)),icol=16,30)
+ endif
+ enddo
+ write(spareid,*) 'bigcal_rcs_ped_rms = '
+ do irow=1,bigcal_rcs_ny
+ write(spareid,101) (bigcal_rcs_ped_rms(icol+bigcal_rcs_nx*
+ $ (irow-1)),icol=1,15)
+ if(irow.lt.bigcal_rcs_ny) then
+ write(spareid,101) (bigcal_rcs_ped_rms(icol+bigcal_rcs_nx*
+ $ (irow-1)),icol=16,30)
+ else
+ write(spareid,131) (bigcal_rcs_ped_rms(icol+bigcal_rcs_nx*
+ $ (irow-1)),icol=16,30)
+ endif
+ enddo
+ write(spareid,*) 'bigcal_rcs_adc_threshold = '
+ do irow=1,bigcal_rcs_ny
+ write(spareid,101) (bigcal_rcs_adc_threshold(icol +
+ $ bigcal_rcs_nx*(irow-1)),icol=1,15)
+ if(irow.lt.bigcal_rcs_ny) then
+ write(spareid,101) (bigcal_rcs_adc_threshold(icol +
+ $ bigcal_rcs_nx*(irow-1)),icol=16,30)
+ else
+ write(spareid,131) (bigcal_rcs_adc_threshold(icol +
+ $ bigcal_rcs_nx*(irow-1)),icol=16,30)
+ endif
+ enddo
+
+ 101 format(15(f8.2,','))
+ 131 format(14(f8.2,','),f8.2)
+ write(spareid,*) 'bigcal_trig_ped_mean = '
+ do igroup=1,19
+ if(igroup.lt.19) then
+ write(spareid,102) (bigcal_trig_ped_mean(ihalf+(igroup-1)*2),
+ $ ihalf=1,2)
+ else
+ write(spareid,132) (bigcal_trig_ped_mean(ihalf+(igroup-1)*2),
+ $ ihalf=1,2)
+ endif
+ enddo
+ write(spareid,*) 'bigcal_trig_ped_rms = '
+ do igroup=1,19
+ if(igroup.lt.19) then
+ write(spareid,102) (bigcal_trig_ped_rms(ihalf+(igroup-1)*2),
+ $ ihalf=1,2)
+ else
+ write(spareid,132) (bigcal_trig_ped_rms(ihalf+(igroup-1)*2),
+ $ ihalf=1,2)
+ endif
+ enddo
+ write(spareid,*) 'bigcal_trig_adc_threshold = '
+ do igroup=1,19
+ if(igroup.lt.19) then
+ write(spareid,102) (bigcal_trig_adc_threshold(ihalf+(igroup-1)
+ $ * 2),ihalf=1,2)
+ else
+ write(spareid,132) (bigcal_trig_adc_threshold(ihalf+(igroup-1)
+ $ * 2),ihalf=1,2)
+ endif
+ enddo
+ 102 format(2(f8.2,','))
+ 132 format(f8.2,',',f8.2)
+ close(spareid)
+
+ return
+ end
diff --git a/BTRACKING/b_fill_bigcal_arrays.f b/BTRACKING/b_fill_bigcal_arrays.f
new file mode 100644
index 0000000..b47863d
--- /dev/null
+++ b/BTRACKING/b_fill_bigcal_arrays.f
@@ -0,0 +1,72 @@
+ subroutine b_fill_bigcal_arrays(abort,err)
+
+ implicit none
+ save
+
+ logical abort
+ character*(*) err
+
+ character*20 here
+ parameter(here='b_fill_bigcal_arrays')
+
+ integer ihit,irow,icol
+ integer icell,ngood
+
+ include 'bigcal_data_structures.cmn'
+ include 'bigcal_geometry.cmn'
+
+ abort = .false.
+ err = ' '
+
+c this routine fills the arrays that are used by the cluster finding algorithm
+
+ ngood = 0
+
+ if(bigcal_prot_ngood.gt.0) then
+ do ihit=1,bigcal_prot_ngood
+ irow = bigcal_prot_iygood(ihit)
+ icol = bigcal_prot_ixgood(ihit)
+ icell = icol + bigcal_prot_nx*(irow-1)
+
+ ngood = ngood + 1
+
+ bigcal_all_adc_good(ngood) = bigcal_prot_adc_good(ihit)
+ bigcal_all_ecell(ngood) = bigcal_prot_ecell(ihit)
+ bigcal_all_xgood(ngood) = bigcal_prot_xgood(ihit)
+ bigcal_all_ygood(ngood) = bigcal_prot_ygood(ihit)
+
+ bigcal_all_iygood(ngood) = irow
+ bigcal_all_ixgood(ngood) = icol
+
+ bigcal_all_good_det(icell) = bigcal_prot_ecell(ihit)
+
+ enddo
+ endif
+
+ if(bigcal_rcs_ngood.gt.0) then
+ do ihit=1,bigcal_rcs_ngood
+ irow = bigcal_rcs_iygood(ihit)
+ icol = bigcal_rcs_ixgood(ihit)
+ icell = icol + bigcal_rcs_nx*(irow-1) + bigcal_prot_maxhits
+
+ ngood = ngood + 1
+ bigcal_all_adc_good(ngood) = bigcal_rcs_adc_good(ihit)
+ bigcal_all_ecell(ngood) = bigcal_rcs_ecell(ihit)
+ bigcal_all_xgood(ngood) = bigcal_rcs_xgood(ihit)
+ bigcal_all_ygood(ngood) = bigcal_rcs_ygood(ihit)
+
+ bigcal_all_iygood(ngood) = irow + bigcal_prot_ny
+ bigcal_all_ixgood(ngood) = icol
+
+ bigcal_all_good_det(icell) = bigcal_rcs_ecell(ihit)
+ enddo
+ endif
+
+ bigcal_all_ngood = ngood
+
+ return
+ end
+
+
+
+
diff --git a/BTRACKING/b_fill_eff_hists.f b/BTRACKING/b_fill_eff_hists.f
new file mode 100644
index 0000000..8101551
--- /dev/null
+++ b/BTRACKING/b_fill_eff_hists.f
@@ -0,0 +1,61 @@
+ subroutine b_fill_eff_hists(ABORT,err)
+
+ implicit none
+ save
+
+ character*16 here
+ parameter(here='b_fill_eff_hists')
+
+ logical abort
+ character*(*) err
+
+ integer irow,icol,icell
+ real Eavg,eff
+
+ include 'bigcal_data_structures.cmn'
+ include 'gen_run_info.cmn'
+ include 'bigcal_hist_id.cmn'
+
+c calculate final "efficiencies" and fill histograms
+
+ do icell=1,bigcal_all_maxhits
+ if(icell.le.bigcal_prot_maxhits) then
+ irow=(icell-1)/32 + 1
+ icol=mod(icell-1,32) + 1
+ else
+ irow=(icell-1-bigcal_prot_maxhits)/30 + 33
+ icol=mod(icell-1-bigcal_prot_maxhits,30)+1
+ endif
+
+ if(b_all_run_Enum(icell).gt.0) then
+ Eavg = b_all_run_Esum(icell)/float(b_all_run_Enum(icell))
+ else
+ Eavg = 0.
+ endif
+ if(bid_bcal_exy.gt.0) call hf2(bid_bcal_exy,float(icol),float(irow),Eavg)
+
+ if(b_all_run_clst_good(icell)+b_all_run_clst_bad(icell)
+ $ .gt.0)then
+ eff = float(b_all_run_clst_good(icell)) /
+ $ float(b_all_run_clst_good(icell) +
+ $ b_all_run_clst_bad(icell))
+ else
+ eff = 0.
+ endif
+ if(icell.le.bigcal_prot_maxhits) then
+ if(bid_bcal_prot_eff.gt.0) call hf1(bid_bcal_prot_eff,float(icell),eff)
+ else
+ if(bid_bcal_rcs_eff.gt.0) call hf1(bid_bcal_rcs_eff,float(icell-bigcal_prot_maxhits),eff)
+ endif
+
+c b_all_run_Enum(icell) = 0
+c b_all_run_Esum(icell) = 0.
+
+
+ enddo
+
+ abort=.false.
+ err=' '
+
+ return
+ end
diff --git a/BTRACKING/b_find_clusters.f b/BTRACKING/b_find_clusters.f
new file mode 100755
index 0000000..3668d8d
--- /dev/null
+++ b/BTRACKING/b_find_clusters.f
@@ -0,0 +1,530 @@
+ subroutine b_find_clusters(ncluster,nmaximum,ABORT,err)
+
+ implicit none
+ save
+
+ character*16 here
+ parameter (here= 'b_find_clusters')
+
+ logical ABORT
+ character*(*) err
+
+ include 'bigcal_data_structures.cmn'
+ include 'bigcal_bypass_switches.cmn'
+ include 'bigcal_gain_parms.cmn'
+ include 'bigcal_tof_parms.cmn'
+ include 'bigcal_geometry.cmn'
+
+ integer i
+ integer ihit
+ integer irow
+ integer icol
+ integer icell,jcell
+ integer ixmax,iymax,ihitmax,nmaximum
+ integer ncluster,ncellclst,icellclst,nbadlist
+ integer ixlo(0:2),ixhi(0:2),iylo,iyhi,lengthx,lengthy
+ real emax,ecell,esum,asum,xmom_clst,ymom_clst
+ integer ix2max,iy2max,celldiffx,celldiffy
+
+ logical found_cluster
+
+ integer cluster_temp_irow(bigcal_clstr_ncell_max)
+ integer cluster_temp_icol(bigcal_clstr_ncell_max)
+ real cluster_temp_ecell(bigcal_clstr_ncell_max)
+ real cluster_temp_acell(bigcal_clstr_ncell_max)
+ real cluster_temp_xcell(bigcal_clstr_ncell_max)
+ real cluster_temp_ycell(bigcal_clstr_ncell_max)
+ logical cluster_temp_bad_chan(bigcal_clstr_ncell_max)
+
+ real xcenter,ycenter,xcell,ycell
+
+ real copyreal
+ integer copyint
+ logical copybool
+
+ abort=.false.
+ err=' '
+
+c Strategy: Find Maximum, then build cluster around it using "add_neighbors"
+
+c nmaximum = 0
+c ncluster = 0
+
+c initialize cluster trimming parameters if user hasn't defined something reasonable:
+
+ if(bigcal_clstr_nxmom_max.lt.1.or.bigcal_clstr_nxmom_max.gt.
+ $ max(bigcal_clstr_ncellx_max,7)) then
+ bigcal_clstr_nxmom_max = 2
+ endif
+
+ if(bigcal_clstr_nymom_max.lt.1.or.bigcal_clstr_nymom_max.gt.
+ $ max(bigcal_clstr_ncelly_max,7)) then
+ bigcal_clstr_nymom_max = 2
+ endif
+
+ if(bigcal_clstr_nxecl_max.lt.bigcal_clstr_nxmom_max
+ $ .or.bigcal_clstr_nxecl_max.gt.max(bigcal_clstr_ncellx_max,7))
+ $ then
+ bigcal_clstr_nxecl_max = max(2,bigcal_clstr_nxmom_max)
+ endif
+
+ if(bigcal_clstr_nyecl_max.lt.bigcal_clstr_nymom_max
+ $ .or.bigcal_clstr_nyecl_max.gt.max(bigcal_clstr_ncelly_max,7))
+ $ then
+ bigcal_clstr_nyecl_max = max(2,bigcal_clstr_nymom_max)
+ endif
+
+ 102 continue
+ found_cluster = .false.
+
+ emax = b_min_emax
+ ixmax = 0
+ iymax = 0
+ ihitmax = 0
+
+ icellclst = 0
+ ncellclst = 0
+ nbadlist = 0
+
+ do icell=1,bigcal_clstr_ncell_max
+ cluster_temp_irow(icell) = 0
+ cluster_temp_icol(icell) = 0
+ cluster_temp_ecell(icell) = 0.
+ cluster_temp_acell(icell) = 0.
+ cluster_temp_xcell(icell) = 0.
+ cluster_temp_ycell(icell) = 0.
+ cluster_temp_bad_chan(icell) = .false.
+ enddo
+c it should never happen that we find a max in a channel that is in the bad channels list
+c because the routine that initializes the bad channel list zeroes the calibration constant,
+c so regardless of the adc value, the "ecell" value should be zero!
+ do ihit=1,bigcal_all_ngood
+ irow = bigcal_all_iygood(ihit)
+ icol = bigcal_all_ixgood(ihit)
+ ecell = bigcal_all_ecell(ihit)
+ if(ecell.gt.emax) then
+ emax = ecell
+ ixmax = icol
+ iymax = irow
+ ihitmax = ihit
+ endif
+ enddo
+
+c check that max is at least one block away from the edge
+ if(ixmax.ge.1.and.iymax.ge.1.and.ixmax.le.32.and.iymax.le.56.and.
+ $ .not. (iymax.gt.32.and.ixmax.gt.30) ) then
+
+ nmaximum = nmaximum + 1
+ icellclst = icellclst + 1
+ ncellclst = ncellclst + 1
+c initialize all "bad cluster" flags to false
+ bigcal_edge_max(nmaximum) = .false.
+ bigcal_not_enough(nmaximum) = .false.
+ bigcal_too_long_x(nmaximum) = .false.
+ bigcal_too_long_y(nmaximum) = .false.
+ bigcal_below_cut(nmaximum) = .false.
+ bigcal_above_max(nmaximum) = .false.
+ bigcal_second_max(nmaximum) = .false.
+
+c check for maximum at edge condition:
+
+ if(iymax.eq.1.or.ixmax.eq.1.or.iymax.eq.56.or.(iymax.gt.32.and.
+ $ ixmax.eq.30).or.ixmax.eq.32) then
+ bigcal_edge_max(nmaximum) = .true.
+ endif
+
+ cluster_temp_irow(icellclst) = iymax
+ cluster_temp_icol(icellclst) = ixmax
+ cluster_temp_xcell(icellclst) = bigcal_all_xgood(ihitmax)
+ cluster_temp_ycell(icellclst) = bigcal_all_ygood(ihitmax)
+ cluster_temp_ecell(icellclst) = bigcal_all_ecell(ihitmax)
+ cluster_temp_acell(icellclst) = bigcal_all_adc_good(ihitmax)
+ bigcal_all_ecell(ihitmax) = 0.
+ bigcal_all_adc_good(ihitmax) = 0.
+ bigcal_all_iygood(ihitmax) = 0
+ bigcal_all_ixgood(ihitmax) = 0
+ bigcal_all_ygood(ihitmax) = 0.
+ bigcal_all_xgood(ihitmax) = 0.
+
+ if(iymax.le.32) then
+ icell = ixmax + 32*(iymax-1)
+ else
+ icell = ixmax + 30*(iymax-33) + bigcal_prot_maxhits
+ endif
+
+ bigcal_all_good_det(icell) = 0.
+
+ if(bigcal_bad_chan_list(icell)) then
+ bigcal_all_good_det(icell) = -1.
+ nbadlist = nbadlist + 1
+ cluster_temp_bad_chan(icellclst) = .true.
+ endif
+
+ !write(*,*) 'found max, adding nearest neighbors'
+
+c this is the nearest-neighbors adding loop!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ 103 call b_add_neighbors(icellclst,ncellclst,nbadlist,bigcal_clstr_ncell_max,
+ $ cluster_temp_icol,cluster_temp_irow,cluster_temp_xcell,
+ $ cluster_temp_ycell,cluster_temp_ecell,cluster_temp_acell,
+ $ cluster_temp_bad_chan,abort,err)
+ if(abort) then
+ call g_add_path(here,err)
+ return
+ endif
+ icellclst = icellclst + 1
+ if(icellclst.le.ncellclst) goto 103
+
+ !write(*,*) 'finished adding nearest neighbors'
+c end of the nearest-neighbors adding loop!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+c 105 continue
+c now subject clusters to a series of checks. If all are passed, add cluster
+c to the array!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ if(ncellclst.lt.bigcal_clstr_ncell_min) then
+ bigcal_not_enough(nmaximum) = .true.
+ goto 104
+ endif
+c if at least two cells, sort cluster array in order of decreasing energy:
+ do icell=1,ncellclst
+ do jcell=icell+1,ncellclst
+ if(cluster_temp_ecell(jcell).gt.cluster_temp_ecell(icell)
+ $ )then ! switch positions in the array
+ copyint = cluster_temp_icol(icell)
+ cluster_temp_icol(icell) = cluster_temp_icol(jcell)
+ cluster_temp_icol(jcell) = copyint
+
+ copyint = cluster_temp_irow(icell)
+ cluster_temp_irow(icell) = cluster_temp_irow(jcell)
+ cluster_temp_irow(jcell) = copyint
+
+ copyreal = cluster_temp_ecell(icell)
+ cluster_temp_ecell(icell) = cluster_temp_ecell(jcell)
+ cluster_temp_ecell(jcell) = copyreal
+
+ copyreal = cluster_temp_acell(icell)
+ cluster_temp_acell(icell) = cluster_temp_acell(jcell)
+ cluster_temp_acell(jcell) = copyreal
+
+ copyreal = cluster_temp_xcell(icell)
+ cluster_temp_xcell(icell) = cluster_temp_xcell(jcell)
+ cluster_temp_xcell(jcell) = copyreal
+
+ copyreal = cluster_temp_ycell(icell)
+ cluster_temp_ycell(icell) = cluster_temp_ycell(jcell)
+ cluster_temp_ycell(jcell) = copyreal
+
+ copybool = cluster_temp_bad_chan(icell)
+ cluster_temp_bad_chan(icell) = cluster_temp_bad_chan(jcell)
+ cluster_temp_bad_chan(jcell) = copybool
+ endif
+ enddo
+ enddo
+
+c$$$ write(*,252) 'ncell=',ncellclst
+c$$$ do icell=1,ncellclst
+c$$$ write(*,251) '(ix,iy,E)=(',cluster_temp_icol(icell),', ',
+c$$$ $ cluster_temp_irow(icell),', ',cluster_temp_ecell(icell),
+c$$$ $ ')'
+c$$$ enddo
+c$$$ 251 format(A11,I2,A2,I2,A2,F8.5,A1)
+c$$$ 252 format(A6,I2)
+
+c compute length in x and y. Start with y, and then treat x differently depending on whether
+c cluster has section overlap. Also accumulate esum
+
+ iylo = 57
+ iyhi = 0
+
+ ixlo(0) = 33
+ ixhi(0) = 0
+ ixlo(1) = 33
+ ixlo(2) = 31
+ ixhi(1) = 0
+ ixhi(2) = 0
+
+ esum = 0.
+
+ asum = 0.
+
+ do icell=1,ncellclst
+ irow = cluster_temp_irow(icell)
+ icol = cluster_temp_icol(icell)
+
+ if(irow.gt.iyhi) iyhi = irow
+ if(irow.lt.iylo) iylo = irow
+ if(icol.gt.ixhi(0)) ixhi(0) = icol
+ if(icol.lt.ixlo(0)) ixlo(0) = icol
+
+ if(irow.le.32) then
+ if(icol.gt.ixhi(1)) ixhi(1) = icol
+ if(icol.lt.ixlo(1)) ixlo(1) = icol
+ else
+ if(icol.gt.ixhi(2)) ixhi(2) = icol
+ if(icol.lt.ixlo(2)) ixlo(2) = icol
+ endif
+
+c intelligently calculate the cluster energy sum:
+c restrict how far away from the maximum we can be to include
+c a block in the sum:
+ if(abs(irow-cluster_temp_irow(1)).le.bigcal_clstr_nyecl_max)
+ $ then
+c 1. max in Prot and current block in RCS
+ if(cluster_temp_irow(1).le.32.and.irow.gt.32) then
+ if(abs(icol-bigcal_ixclose_prot(cluster_temp_icol(1)))
+ $ .le.bigcal_clstr_nxecl_max) then
+ esum = esum + cluster_temp_ecell(icell)
+ asum = asum + cluster_temp_acell(icell)
+ endif
+c 2. max in RCS and current block in Prot
+ else if(cluster_temp_irow(1).gt.32.and.irow.le.32) then
+ if(abs(icol-bigcal_ixclose_rcs(cluster_temp_icol(1)))
+ $ .le.bigcal_clstr_nxecl_max) then
+ esum = esum + cluster_temp_ecell(icell)
+ asum = asum + cluster_temp_acell(icell)
+ endif
+c 3. both blocks in same section
+ else
+ if(abs(icol-cluster_temp_icol(1)).le.bigcal_clstr_nxecl_max)
+ $ then
+ esum = esum + cluster_temp_ecell(icell)
+ asum = asum + cluster_temp_acell(icell)
+ endif
+ endif
+ endif
+ enddo
+
+ if(nbadlist.gt.0) then
+c$$$ write(*,*) 'WARNING: cluster contains at least one'//
+c$$$ $ 'channel from the bad channels list'
+c$$$ write(*,*) 'bypassing normal cluster checks'
+ goto 106 ! don't subject a cluster containing channels from the bad list to
+c the same checks as a cluster with no bad channels, just add it to the cluster array and move on.
+ endif
+ lengthy = iyhi - iylo + 1
+
+c$$$ write(*,253) 'length y = ',lengthy
+c$$$
+c$$$ 253 format(A11,I2)
+
+ if(iylo .le. 32 .and. iyhi .ge. 33) then ! cluster overlaps section boundary!
+ lengthx = max(ixhi(1)-ixlo(1)+1,ixhi(2)-ixlo(2)+1)
+ else ! cluster doesn't overlap!
+ lengthx = ixhi(0) - ixlo(0) + 1
+ endif
+
+c$$$ write(*,253) 'length x = ',lengthx
+
+ if(lengthx.lt.1.or.lengthy.lt.1) then
+ bigcal_not_enough(nmaximum) = .true.
+ goto 104
+ endif
+
+ if(lengthx.gt.bigcal_clstr_ncellx_max) then
+ bigcal_too_long_x(nmaximum) = .true.
+ endif
+ if(lengthy.gt.bigcal_clstr_ncelly_max) then
+ bigcal_too_long_y(nmaximum) = .true.
+ endif
+
+ if(bigcal_too_long_x(nmaximum).or.bigcal_too_long_y(nmaximum))
+ $ then
+c goto 104
+ endif
+ if(esum.lt.b_cluster_cut) then
+ bigcal_below_cut(nmaximum) = .true.
+ goto 104
+ endif
+
+ if(esum.gt.b_cluster_max) then
+ bigcal_above_max(nmaximum) = .true.
+ goto 104
+ endif
+
+ ix2max = cluster_temp_icol(2)
+ iy2max = cluster_temp_irow(2)
+
+ celldiffy = int(abs(float(iy2max - cluster_temp_irow(1))))
+
+ if(celldiffy.gt.1.and.ncellclst.gt.1) then
+ if(cluster_temp_ecell(2)/cluster_temp_ecell(1).gt.b_min_2max(1).and.
+ $ cluster_temp_ecell(2).gt.b_min_2max(2)) then
+ bigcal_second_max(nmaximum) = .true.
+c goto 104
+ endif
+ else if(ncellclst.gt.1) then
+ if(cluster_temp_irow(1).eq.32.and.iy2max.eq.33) then
+ celldiffx = int(abs(float(ix2max -
+ $ bigcal_ixclose_prot(cluster_temp_icol(1)))))
+ else if(cluster_temp_irow(1).eq.33.and.iy2max.eq.32) then
+ celldiffx = int(abs(float(ix2max -
+ $ bigcal_ixclose_rcs(cluster_temp_icol(1)))))
+ else
+ celldiffx=int(abs(float(ix2max - cluster_temp_icol(1))))
+ endif
+
+ if(celldiffx.gt.1) then
+ if(cluster_temp_ecell(2)/cluster_temp_ecell(1).gt.b_min_2max(1).and.
+ $ cluster_temp_ecell(2).gt.b_min_2max(2)) then
+ bigcal_second_max(nmaximum) = .true.
+c goto 104
+ endif
+ endif
+ endif
+
+c IF WE'VE MADE IT TO THIS POINT, IT SHOULD MEAN THAT ALL THE CLUSTER CHECKS WERE PASSED!!!
+c SO FILL THE CLUSTER ARRAY!!!
+c ALTERNATIVELY, IT MAY MEAN THAT THERE IS AT LEAST 1 BADLIST CHANNEL IN THE CLUSTER, AND WE
+c DON'T WANT TO STOP CLUSTER FINDING BECAUSE OF IT! IF A BADLIST CHANNEL IS ADJACENT TO THE MAXIMUM,
+c IT IS LIKELY THAT WE WILL FIND IT, BUT IF A BADLIST CHANNEL SHOULD HAVE BEEN THE MAXIMUM, THERE IS
+c ONLY A SMALL CHANCE OF FINDING A MAXIMUM NEXT TO IT, DEPENDING ON B_MIN_EMAX
+
+ 106 found_cluster = .true.
+ ncluster = ncluster + 1
+
+ bigcal_clstr_keep(ncluster) = .true.
+
+ bigcal_all_clstr_ncell(ncluster) = ncellclst
+ bigcal_all_clstr_ncellx(ncluster) = lengthx
+ bigcal_all_clstr_ncelly(ncluster) = lengthy
+ bigcal_all_clstr_nbadlist(ncluster) = nbadlist
+ bigcal_all_clstr_iymax(ncluster) = cluster_temp_irow(1)
+ bigcal_all_clstr_ixmax(ncluster) = cluster_temp_icol(1)
+
+ bigcal_all_clstr_iylo(ncluster) = iylo
+ bigcal_all_clstr_iyhi(ncluster) = iyhi
+ do i=0,2
+ bigcal_all_clstr_ixlo(ncluster,i+1) = ixlo(i)
+ bigcal_all_clstr_ixhi(ncluster,i+1) = ixhi(i)
+ enddo
+
+ xmom_clst = 0.
+ ymom_clst = 0.
+
+ xcenter = cluster_temp_xcell(1)
+ ycenter = cluster_temp_ycell(1)
+
+ do icell=1,ncellclst
+
+ bigcal_all_clstr_iycell(ncluster,icell) =
+ $ cluster_temp_irow(icell)
+ bigcal_all_clstr_ixcell(ncluster,icell) =
+ $ cluster_temp_icol(icell)
+ bigcal_all_clstr_ecell(ncluster,icell) =
+ $ cluster_temp_ecell(icell)
+ bigcal_all_clstr_acell(ncluster,icell) =
+ $ cluster_temp_acell(icell)
+ bigcal_all_clstr_xcell(ncluster,icell) =
+ $ cluster_temp_xcell(icell)
+ bigcal_all_clstr_ycell(ncluster,icell) =
+ $ cluster_temp_ycell(icell)
+ bigcal_clstr_bad_chan(ncluster,icell) =
+ $ cluster_temp_bad_chan(icell)
+
+ xcell = cluster_temp_xcell(icell)
+ ycell = cluster_temp_ycell(icell)
+ ecell = cluster_temp_ecell(icell)
+c acell = cluster_temp_acell(icell)
+
+c intelligent cluster moment calculation: restrict how far away from the maximum
+c we allow blocks to be in order to include them in the calculation
+c i.e., "trim" the clusters down to size
+
+ if(abs(cluster_temp_irow(icell)-cluster_temp_irow(1)).le.
+ $ bigcal_clstr_nymom_max) then
+
+ if(cluster_temp_irow(1).le.32.and.cluster_temp_irow(icell)
+ $ .gt.32) then
+ if(abs(cluster_temp_icol(icell)-
+ $ bigcal_ixclose_prot(cluster_temp_icol(1))).le.
+ $ bigcal_clstr_nxmom_max) then
+ xmom_clst = xmom_clst + ecell*(xcell-xcenter)/esum
+ ymom_clst = ymom_clst + ecell*(ycell-ycenter)/esum
+ endif
+ else if(cluster_temp_irow(1).gt.32.and.cluster_temp_irow(icell)
+ $ .le.32) then
+ if(abs(cluster_temp_icol(icell)-
+ $ bigcal_ixclose_rcs(cluster_temp_icol(1))).le.
+ $ bigcal_clstr_nxmom_max) then
+ xmom_clst = xmom_clst + ecell*(xcell-xcenter)/esum
+ ymom_clst = ymom_clst + ecell*(ycell-ycenter)/esum
+ endif
+ else
+ if(abs(cluster_temp_icol(icell)-cluster_temp_icol(1)).le.
+ $ bigcal_clstr_nxmom_max) then
+ xmom_clst = xmom_clst + ecell*(xcell-xcenter)/esum
+ ymom_clst = ymom_clst + ecell*(ycell-ycenter)/esum
+ endif
+ endif
+ endif
+
+ do ihit=1,bigcal_all_ngood
+ if(bigcal_all_iygood(ihit).eq.cluster_temp_irow(icell)
+ $ .and.bigcal_all_ixgood(ihit).eq.cluster_temp_icol(icell))
+ $ then ! zero this hit so it won't be used again
+ bigcal_all_ecell(ihit) = 0.
+ bigcal_all_adc_good(ihit) = 0.
+ bigcal_all_iygood(ihit) = 0
+ bigcal_all_ixgood(ihit) = 0
+ bigcal_all_ygood(ihit) = 0.
+ bigcal_all_xgood(ihit) = 0.
+ endif
+ enddo
+ enddo
+
+ bigcal_all_clstr_xmom(ncluster) = xmom_clst
+ bigcal_all_clstr_ymom(ncluster) = ymom_clst
+ bigcal_all_clstr_etot(ncluster) = esum
+ bigcal_all_clstr_atot(ncluster) = asum
+
+ if(bbypass_calc_shower_coord.ne.0) then ! use xcenter + xmom
+ bigcal_all_clstr_x(ncluster) = xcenter + xmom_clst
+ bigcal_all_clstr_y(ncluster) = ycenter + ymom_clst
+ endif
+
+c$$$ if(nbadlist.gt.0) then
+c$$$ call b_print_cluster(ncluster,abort,err)
+c$$$ if(abort) then
+c$$$ call g_add_path(here,err)
+c$$$ return
+c$$$ endif
+c$$$ endif
+
+ if(bdebug_print_clusters.ne.0) then
+ call b_print_cluster(ncluster,abort,err)
+ if(abort) then
+ call g_add_path(here,err)
+ return
+ endif
+ endif
+
+c$$$ else
+c$$$ if(ixmax.eq.1.or.iymax.eq.1.or.iymax.eq.56.or.ixmax.eq.32.or.
+c$$$ $ (iymax.gt.32.and.ixmax.eq.30)) then
+c$$$ nmaximum = nmaximum + 1
+c$$$ bigcal_edge_max(nmaximum) = .true.
+c$$$ bigcal_not_enough(nmaximum) = .false.
+c$$$ bigcal_too_long_x(nmaximum) = .false.
+c$$$ bigcal_too_long_y(nmaximum) = .false.
+c$$$ bigcal_below_cut(nmaximum) = .false.
+c$$$ bigcal_above_max(nmaximum) = .false.
+c$$$ bigcal_second_max(nmaximum) = .false.
+c$$$
+c$$$c zero ecell and adc good for hit array, but leave detector array untouched
+c$$$
+c$$$ bigcal_all_ecell(ihitmax) = 0.
+c$$$ bigcal_all_adc_good(ihitmax) = 0.
+c$$$
+c$$$ goto 102
+c$$$
+c$$$ endif
+ endif
+
+ 104 continue
+
+ if(found_cluster.and.ncluster.lt.bigcal_all_nclstr_max) goto 102
+
+ bigcal_all_nclstr = ncluster
+ bigcal_nmaxima = nmaximum
+
+ return
+ end
diff --git a/BTRACKING/b_find_clusters_new.f b/BTRACKING/b_find_clusters_new.f
new file mode 100755
index 0000000..fbff5de
--- /dev/null
+++ b/BTRACKING/b_find_clusters_new.f
@@ -0,0 +1,585 @@
+ subroutine b_find_clusters(ABORT,err)
+
+ implicit none
+ save
+
+ character*16 here
+ parameter (here= 'b_find_clusters')
+
+ logical ABORT
+ character*(*) err
+
+ include 'bigcal_data_structures.cmn'
+ include 'bigcal_bypass_switches.cmn'
+ include 'bigcal_gain_parms.cmn'
+ include 'bigcal_tof_parms.cmn'
+ include 'bigcal_geometry.cmn'
+
+ integer*4 ihit,jhit,khit
+ integer*4 icell,jcell,kcell
+ integer*4 itdc,jtdc,ktdc
+ integer*4 ilogic,jlogic,klogic
+ integer*4 irow,jrow,krow,icol,jcol,kcol
+ real*4 ecell,xcell,ycell
+ integer*4 irow8,icol8
+ integer*4 igroup64,ihalf64
+ integer*4 maxcelldiff,celldiffx,celldiffy
+ real*4 clstr_temp_ecell(BIGCAL_CLSTR_NCELL_MAX)
+ integer*4 clstr_temp_ixcell(BIGCAL_CLSTR_NCELL_MAX)
+ integer*4 clstr_temp_iycell(BIGCAL_CLSTR_NCELL_MAX)
+ real*4 clstr_temp_xcell(BIGCAL_CLSTR_NCELL_MAX)
+ real*4 clstr_temp_ycell(BIGCAL_CLSTR_NCELL_MAX)
+ real*4 clstr_temp_esum
+
+ real*4 max,xmax,ymax,minxdiff
+ integer*4 ixmax,iymax,ihitmax,ixmin,iymin
+ integer*4 ncellclust
+ integer*4 ncluster
+
+ integer*4 nrows
+
+ integer*4 itemp,jtemp,ktemp
+ real*4 irtemp,jrtemp,krtemp
+
+ real*4 trigtime
+ real*4 xmom,ymom,clstr_time
+ real*4 tavg
+
+ integer*4 ntdc
+
+ logical tdchit,trighit
+ logical second_max
+ logical found_cluster
+
+ trigtime = BIGCAL_REF_TIME
+
+ maxcelldiff = int(sqrt(float(BIGCAL_CLSTR_NCELL_MAX))) / 2
+
+ ncluster = 0
+
+ 101 continue
+ found_cluster = .false.
+
+ ! zero temporary cluster quantities:
+ do icell=1,BIGCAL_CLSTR_NCELL_MAX
+ clstr_temp_ecell(icell) = 0.
+ clstr_temp_xcell(icell) = 0.
+ clstr_temp_ycell(icell) = 0.
+ clstr_temp_ixcell(icell) = 0
+ clstr_temp_iycell(icell) = 0
+ enddo
+
+ max = 0.
+ ixmax = 0
+ iymax = 0
+
+ ! first step is to find first hit with good timing and with maximum amplitude
+ do ihit=1,BIGCAL_PROT_NGOOD
+ tdchit = .false.
+ trighit = .false.
+ ecell = BIGCAL_PROT_ECELL(ihit)
+ irow = BIGCAL_PROT_IYGOOD(ihit)
+ icol = BIGCAL_PROT_IXGOOD(ihit)
+ icell = icol + BIGCAL_PROT_NX * (irow - 1)
+ xcell = BIGCAL_PROT_XGOOD(ihit)
+ ycell = BIGCAL_PROT_YGOOD(ihit)
+ ! determine which tdc channel (group of 8) we are in
+ irow8 = irow
+ icol8 = (icol - 1) / 8 + 1
+ itdc = icol8 + (irow8 - 1)*BIGCAL_MAX_GROUPS
+ ! determine which trigger group (group of 64) we are in
+ ihalf64 = (icol - 1) / 16 + 1
+ igroup64 = (irow - 1) / 3 + 1
+ ilogic = igroup64 + (ihalf64 - 1) * BIGCAL_LOGIC_GROUPS / 2
+
+ if(abs(BIGCAL_TIME_DET(itdc) - trigtime).le.b_timing_cut) then
+ tdchit = .true.
+ endif
+
+ if(abs(BIGCAL_TRIG_TIME_DET(ilogic) - trigtime).le.b_timing_cut
+ $ ) then
+ trighit = .true.
+ endif
+
+ if((trighit .or. tdchit) .and. ecell .gt. max) then
+ max = ecell
+ ixmax = icol
+ iymax = irow
+ ihitmax = ihit
+ endif
+ enddo
+
+ ! if, upon looping through all hits, we have found a maximum that has a valid tdc or
+ ! trigger tdc value, then build a cluster from all the neighboring channels using the
+ ! detector arrays (regardless of whether there is a hit: some cells may have 0)
+ if(ixmax.ge.2.and.iymax.ge.2.and.ixmax.le.BIGCAL_PROT_NX-1.and.
+ $ iymax.le.BIGCAL_PROT_NY-1) then
+ ncellclust = 0
+ do irow = iymax - maxcelldiff,iymax + maxcelldiff
+ do icol = ixmax - maxcelldiff,ixmax + maxcelldiff
+ if(irow.ge.1.and.icol.ge.1.and.irow.le.BIGCAL_PROT_NY
+ $ .and.icol.le.BIGCAL_PROT_NX) then
+ icell = icol + BIGCAL_PROT_NX*(irow - 1)
+ ncellclust = ncellclust + 1
+ if(ncellclust.gt.BIGCAL_CLSTR_NCELL_MAX) goto 100
+ ecell = BIGCAL_PROT_GOOD_DET(icell)
+ xcell = BIGCAL_PROT_XCENTER(icell)
+ ycell = BIGCAL_PROT_YCENTER(icell)
+ clstr_temp_ecell(ncellclust) = ecell
+ clstr_temp_ixcell(ncellclust) = icol
+ clstr_temp_iycell(ncellclust) = irow
+ clstr_temp_xcell(ncellclust) = xcell
+ clstr_temp_ycell(ncellclust) = ycell
+ endif
+ enddo
+ enddo
+ 100 continue
+
+ ! in the special case of iymax = 31 add closest cells in the first rows of RCS part
+ if(iymax + maxcelldiff .gt. BIGCAL_PROT_NY) then
+ nrows = iymax + maxcelldiff - BIGCAL_PROT_NY
+ do irow=1,nrows
+ minxdiff = 1000.
+ xcell = BIGCAL_PROT_XGOOD(ihitmax)
+ do icol = 1,BIGCAL_RCS_NX
+ icell = icol + BIGCAL_RCS_NX * (irow - 1)
+ if(abs(xcell - BIGCAL_RCS_XCENTER(icell)).lt.minxdiff)
+ $ then
+ minxdiff = abs(xcell - BIGCAL_RCS_XCENTER(icell))
+ ixmin = icol
+ endif
+ enddo
+ if(minxdiff .lt. 1000.) then
+ do icol = ixmin - maxcelldiff,ixmin + maxcelldiff
+ icell = icol + BIGCAL_RCS_NX * (irow - 1)
+ if(icol.ge.1.and.icol.le.BIGCAL_RCS_NX) then
+ ncellclust = ncellclust + 1
+ if(ncellclust.gt.BIGCAL_CLSTR_NCELL_MAX)goto 102
+ ecell = BIGCAL_RCS_GOOD_DET(icell)
+ xcell = BIGCAL_RCS_XCENTER(icell)
+ ycell = BIGCAL_RCS_YCENTER(icell)
+ clstr_temp_ecell(ncellclust) = ecell
+ clstr_temp_ixcell(ncellclust) = icol
+ clstr_temp_iycell(ncellclust) =
+ $ irow + BIGCAL_PROT_NY
+ clstr_temp_xcell(ncellclust) = xcell
+ clstr_temp_ycell(ncellclust) = ycell
+ endif
+ enddo
+ endif
+ enddo
+ endif
+ ! end special case iymax = 31
+ ! check temporary cluster for absence of second max. and sum above
+ ! software threshold:
+ ! start by sorting cluster cells in descending order of amplitude:
+
+ 102 continue
+
+ clstr_temp_esum = 0.
+ do ihit=1,ncellclust
+ clstr_temp_esum = clstr_temp_esum + clstr_temp_ecell(ihit)
+ enddo
+
+ do ihit=1,ncellclust
+ do jhit=ihit+1,ncellclust
+ if(clstr_temp_ecell(jhit).gt.clstr_temp_ecell(ihit))then
+ ! switch hits i and j, remember to switch all five quantities
+ irtemp = clstr_temp_ecell(ihit)
+ clstr_temp_ecell(ihit) = clstr_temp_ecell(jhit)
+ clstr_temp_ecell(jhit) = irtemp
+
+ irtemp = clstr_temp_xcell(ihit)
+ clstr_temp_xcell(ihit) = clstr_temp_xcell(jhit)
+ clstr_temp_xcell(jhit) = irtemp
+
+ irtemp = clstr_temp_ycell(ihit)
+ clstr_temp_ycell(ihit) = clstr_temp_ycell(jhit)
+ clstr_temp_ycell(jhit) = irtemp
+
+ itemp = clstr_temp_ixcell(ihit)
+ clstr_temp_ixcell(ihit) = clstr_temp_ixcell(jhit)
+ clstr_temp_ixcell(jhit) = itemp
+
+ itemp = clstr_temp_iycell(ihit)
+ clstr_temp_iycell(ihit) = clstr_temp_iycell(jhit)
+ clstr_temp_iycell(jhit) = itemp
+ endif
+ enddo
+ enddo
+
+ celldiffx = clstr_temp_ixcell(2) - clstr_temp_ixcell(1)
+ celldiffy = clstr_temp_iycell(2) - clstr_temp_iycell(1)
+
+ celldiffx = int(abs(float(celldiffx)))
+ celldiffy = int(abs(float(celldiffy)))
+
+ if(celldiffx .gt. 1.or.celldiffy .gt. 1) then
+ second_max = .true.
+ endif
+
+ if(clstr_temp_esum.ge.b_cluster_cut.and. .not. second_max) then
+ ! add a cluster to the array for protvino:
+ found_cluster = .true.
+ ncluster = ncluster + 1
+ BIGCAL_PROT_CLSTR_IYMAX(ncluster) = clstr_temp_ixcell(1)
+ BIGCAL_PROT_CLSTR_IXMAX(ncluster) = clstr_temp_iycell(1)
+ BIGCAL_PROT_CLSTR_ETOT(ncluster) = clstr_temp_esum
+ BIGCAL_PROT_CLSTR_NCELL(ncluster) = ncellclust
+
+ xmom = 0.
+ ymom = 0.
+ ntdc = 0
+ tavg = 0.
+
+ do ihit=1,ncellclust
+ BIGCAL_PROT_CLSTR_IYCELL(ncluster,ihit) =
+ $ clstr_temp_iycell(ihit)
+ BIGCAL_PROT_CLSTR_IXCELL(ncluster,ihit) =
+ $ clstr_temp_ixcell(ihit)
+ BIGCAL_PROT_CLSTR_ECELL(ncluster,ihit) =
+ $ clstr_temp_ecell(ihit)
+ BIGCAL_PROT_CLSTR_XCELL(ncluster,ihit) =
+ $ clstr_temp_xcell(ihit)
+ BIGCAL_PROT_CLSTR_YCELL(ncluster,ihit) =
+ $ clstr_temp_ycell(ihit)
+
+ xmom = xmom + clstr_temp_ecell(ihit) / clstr_temp_esum *
+ $ (clstr_temp_xcell(ihit) - clstr_temp_xcell(1))
+ ymom = ymom + clstr_temp_ecell(ihit) / clstr_temp_esum *
+ $ (clstr_temp_ycell(ihit) - clstr_temp_ycell(1))
+
+ ! zero the hits belonging to this cluster so that they can't be
+ ! used more than once
+ do jhit=1,BIGCAL_PROT_NGOOD
+ if(BIGCAL_PROT_IYGOOD(jhit).eq.clstr_temp_iycell(ihit)
+ $ .and.BIGCAL_PROT_IXGOOD(jhit) .eq.
+ $ clstr_temp_ixcell(ihit)) then
+ BIGCAL_PROT_ECELL(jhit) = 0.
+ BIGCAL_PROT_IYGOOD(jhit) = 0
+ BIGCAL_PROT_IXGOOD(jhit) = 0
+ BIGCAL_PROT_XGOOD(jhit) = 0.
+ BIGCAL_PROT_YGOOD(jhit) = 0.
+ endif
+ enddo
+ ! do the same for the RCS part in the case of clusters overlapping
+ ! the Prot-RCS boundary:
+ do jhit=1,BIGCAL_RCS_NGOOD
+ if(BIGCAL_RCS_IYGOOD(jhit)+BIGCAL_PROT_NY.eq.
+ $ clstr_temp_iycell(ihit).and.
+ $ BIGCAL_RCS_IXGOOD(jhit) .eq.
+ $ clstr_temp_ixcell(ihit)) then
+ BIGCAL_RCS_ECELL(jhit) = 0.
+ BIGCAL_RCS_IYGOOD(jhit) = 0
+ BIGCAL_RCS_IXGOOD(jhit) = 0
+ BIGCAL_RCS_XGOOD(jhit) = 0.
+ BIGCAL_RCS_YGOOD(jhit) = 0.
+ endif
+ enddo
+ irow = clstr_temp_iycell(ihit)
+ icol = clstr_temp_ixcell(ihit)
+ if(irow.le.BIGCAL_PROT_NY)then
+ icell = icol + BIGCAL_PROT_NX * (irow - 1)
+ irow8 = irow
+ icol8 = (icol - 1) / 8 + 1
+ igroup64 = (irow - 1) / 3 + 1
+ ihalf64 = (icol - 1) / 16 + 1
+ else
+ icell = icol + BIGCAL_RCS_NX * (irow-1-BIGCAL_PROT_NY)
+ irow8 = irow
+ if(icol .lt. 16) icol8 = (icol - 1) / 8 + 1
+ if(icol .ge. 16) icol8 = icol / 8 + 1
+ igroup64 = (irow - 1) / 3 + 1
+ ihalf64 = icol / 16 + 1
+ endif
+ itdc = icol8 + (irow8 - 1) * BIGCAL_MAX_GROUPS
+ ilogic = igroup64 + (ihalf64 - 1)*BIGCAL_LOGIC_GROUPS / 2
+ if(abs(BIGCAL_TIME_DET(itdc) - trigtime).le.b_timing_cut)
+ $ then
+ ntdc = ntdc + 1
+ tavg = tavg + BIGCAL_TIME_DET(itdc)
+ endif
+ if(abs(BIGCAL_TRIG_TIME_DET(ilogic) - trigtime).le.
+ $ b_timing_cut) then
+ ntdc = ntdc + 1
+ tavg = tavg + BIGCAL_TRIG_TIME_DET(ilogic)
+ endif
+ enddo
+ clstr_time = tavg / ntdc
+ BIGCAL_PROT_CLSTR_XMOM(ncluster) = xmom
+ BIGCAL_PROT_CLSTR_YMOM(ncluster) = ymom
+ BIGCAL_PROT_CLSTR_TIME(ncluster) = clstr_time
+ endif
+ endif
+
+ if(found_cluster .and. ncluster .lt. BIGCAL_CLSTR_NCELL_MAX)
+ $ goto 101
+
+ BIGCAL_PROT_NCLSTR = ncluster
+
+ ncluster = 0
+
+ 201 continue
+ found_cluster = .false.
+
+ ! zero temporary cluster quantities:
+ do icell=1,BIGCAL_CLSTR_NCELL_MAX
+ clstr_temp_ecell(icell) = 0.
+ clstr_temp_xcell(icell) = 0.
+ clstr_temp_ycell(icell) = 0.
+ clstr_temp_ixcell(icell) = 0
+ clstr_temp_iycell(icell) = 0
+ enddo
+
+ max = 0.
+ ixmax = 0
+ iymax = 0
+
+ ! first step is to find first hit with good timing and with maximum amplitude
+ do ihit=1,BIGCAL_RCS_NGOOD
+ tdchit = .false.
+ trighit = .false.
+ ecell = BIGCAL_RCS_ECELL(ihit)
+ irow = BIGCAL_RCS_IYGOOD(ihit)
+ icol = BIGCAL_RCS_IXGOOD(ihit)
+ icell = icol + BIGCAL_RCS_NX * (irow - 1)
+ xcell = BIGCAL_RCS_XGOOD(ihit)
+ ycell = BIGCAL_RCS_YGOOD(ihit)
+ ! determine which tdc channel (group of 8) we are in
+ irow8 = irow + BIGCAL_PROT_NY
+ if(icol .lt. 16) icol8 = (icol - 1) / 8 + 1
+ if(icol .ge. 16) icol8 = icol / 8 + 1
+ itdc = icol8 + (irow8 - 1)*BIGCAL_MAX_GROUPS
+ ! determine which trigger group (group of 64) we are in
+ ihalf64 = icol / 16 + 1
+ igroup64 = (irow8 - 1) / 3 + 1
+ ilogic = igroup64 + (ihalf64 - 1) * BIGCAL_LOGIC_GROUPS / 2
+
+ if(abs(BIGCAL_TIME_DET(itdc) - trigtime).le.b_timing_cut) then
+ tdchit = .true.
+ endif
+
+ if(abs(BIGCAL_TRIG_TIME_DET(ilogic) - trigtime).le.b_timing_cut
+ $ ) then
+ trighit = .true.
+ endif
+
+ if((trighit .or. tdchit) .and. ecell .gt. max) then
+ max = ecell
+ ixmax = icol
+ iymax = irow
+ ihitmax = ihit
+ endif
+ enddo
+
+ ! if, upon looping through all hits, we have found a maximum that has a valid tdc or
+ ! trigger tdc value, then build a cluster from all the neighboring channels using the
+ ! detector arrays (regardless of whether there is a hit: some cells may have 0)
+ if(ixmax.ge.2.and.iymax.ge.2.and.ixmax.le.BIGCAL_RCS_NX-1.and.
+ $ iymax.le.BIGCAL_RCS_NY-1) then
+ ncellclust = 0
+ do irow = iymax - maxcelldiff,iymax + maxcelldiff
+ do icol = ixmax - maxcelldiff,ixmax + maxcelldiff
+ if(irow.ge.1.and.icol.ge.1.and.irow.le.BIGCAL_RCS_NY
+ $ .and.icol.le.BIGCAL_RCS_NX) then
+ icell = icol + BIGCAL_RCS_NX*(irow - 1)
+ ncellclust = ncellclust + 1
+ if(ncellclust.gt.BIGCAL_CLSTR_NCELL_MAX) goto 200
+ ecell = BIGCAL_RCS_GOOD_DET(icell)
+ xcell = BIGCAL_RCS_XCENTER(icell)
+ ycell = BIGCAL_RCS_YCENTER(icell)
+ clstr_temp_ecell(ncellclust) = ecell
+ clstr_temp_ixcell(ncellclust) = icol
+ clstr_temp_iycell(ncellclust) = irow + BIGCAL_PROT_NY
+ clstr_temp_xcell(ncellclust) = xcell
+ clstr_temp_ycell(ncellclust) = ycell
+ endif
+ enddo
+ enddo
+ 200 continue
+
+ ! in the special case of iymax = 2 add closest cells in the last rows of PROT part
+ if(iymax - maxcelldiff .lt. 1) then
+ nrows = maxcelldiff - iymax + 1
+ do irow=1,nrows
+ minxdiff = 1000.
+ xcell = BIGCAL_RCS_XGOOD(ihitmax)
+ do icol = 1,BIGCAL_PROT_NX
+ icell = icol + BIGCAL_PROT_NX*(BIGCAL_PROT_NY - irow)
+ if(abs(xcell-BIGCAL_PROT_XCENTER(icell)).lt.minxdiff)
+ $ then
+ minxdiff = abs(xcell - BIGCAL_PROT_XCENTER(icell))
+ ixmin = icol
+ endif
+ enddo
+ if(minxdiff .lt. 1000.) then
+ do icol = ixmin - maxcelldiff,ixmin + maxcelldiff
+ icell = icol+BIGCAL_PROT_NX*(BIGCAL_PROT_NY - irow)
+ if(icol.ge.1.and.icol.le.BIGCAL_PROT_NX) then
+ ncellclust = ncellclust + 1
+ if(ncellclust.gt.BIGCAL_CLSTR_NCELL_MAX)goto 202
+ ecell = BIGCAL_PROT_GOOD_DET(icell)
+ xcell = BIGCAL_PROT_XCENTER(icell)
+ ycell = BIGCAL_PROT_YCENTER(icell)
+ clstr_temp_ecell(ncellclust) = ecell
+ clstr_temp_ixcell(ncellclust) = icol
+ clstr_temp_iycell(ncellclust) =
+ $ BIGCAL_PROT_NY - irow + 1
+ clstr_temp_xcell(ncellclust) = xcell
+ clstr_temp_ycell(ncellclust) = ycell
+ endif
+ enddo
+ endif
+ enddo
+ endif
+ ! end special case iymax = 2
+ ! check temporary cluster for absence of second max. and sum above
+ ! software threshold:
+ ! start by sorting cluster cells in descending order of amplitude:
+
+ 202 continue
+
+ clstr_temp_esum = 0.
+ do ihit=1,ncellclust
+ clstr_temp_esum = clstr_temp_esum + clstr_temp_ecell(ihit)
+ enddo
+
+ do ihit=1,ncellclust
+ do jhit=ihit+1,ncellclust
+ if(clstr_temp_ecell(jhit).gt.clstr_temp_ecell(ihit))then
+ ! switch hits i and j, remember to switch all five quantities
+ irtemp = clstr_temp_ecell(ihit)
+ clstr_temp_ecell(ihit) = clstr_temp_ecell(jhit)
+ clstr_temp_ecell(jhit) = irtemp
+
+ irtemp = clstr_temp_xcell(ihit)
+ clstr_temp_xcell(ihit) = clstr_temp_xcell(jhit)
+ clstr_temp_xcell(jhit) = irtemp
+
+ irtemp = clstr_temp_ycell(ihit)
+ clstr_temp_ycell(ihit) = clstr_temp_ycell(jhit)
+ clstr_temp_ycell(jhit) = irtemp
+
+ itemp = clstr_temp_ixcell(ihit)
+ clstr_temp_ixcell(ihit) = clstr_temp_ixcell(jhit)
+ clstr_temp_ixcell(jhit) = itemp
+
+ itemp = clstr_temp_iycell(ihit)
+ clstr_temp_iycell(ihit) = clstr_temp_iycell(jhit)
+ clstr_temp_iycell(jhit) = itemp
+ endif
+ enddo
+ enddo
+
+ celldiffx = clstr_temp_ixcell(2) - clstr_temp_ixcell(1)
+ celldiffy = clstr_temp_iycell(2) - clstr_temp_iycell(1)
+
+ celldiffx = int(abs(float(celldiffx)))
+ celldiffy = int(abs(float(celldiffy)))
+
+ if(celldiffx .gt. 1.or.celldiffy .gt. 1) then
+ second_max = .true.
+ endif
+
+ if(clstr_temp_esum.ge.b_cluster_cut.and. .not. second_max) then
+ ! add a cluster to the array for rcs:
+ found_cluster = .true.
+ ncluster = ncluster + 1
+ BIGCAL_RCS_CLSTR_IYMAX(ncluster) = clstr_temp_iycell(1)
+ BIGCAL_RCS_CLSTR_IXMAX(ncluster) = clstr_temp_ixcell(1)
+ BIGCAL_RCS_CLSTR_ETOT(ncluster) = clstr_temp_esum
+ BIGCAL_RCS_CLSTR_NCELL(ncluster) = ncellclust
+
+ xmom = 0.
+ ymom = 0.
+ ntdc = 0
+ tavg = 0.
+
+ do ihit=1,ncellclust
+ BIGCAL_RCS_CLSTR_IYCELL(ncluster,ihit) =
+ $ clstr_temp_iycell(ihit)
+ BIGCAL_RCS_CLSTR_IXCELL(ncluster,ihit) =
+ $ clstr_temp_ixcell(ihit)
+ BIGCAL_RCS_CLSTR_ECELL(ncluster,ihit) =
+ $ clstr_temp_ecell(ihit)
+ BIGCAL_RCS_CLSTR_XCELL(ncluster,ihit) =
+ $ clstr_temp_xcell(ihit)
+ BIGCAL_RCS_CLSTR_YCELL(ncluster,ihit) =
+ $ clstr_temp_ycell(ihit)
+
+ xmom = xmom + clstr_temp_ecell(ihit) / clstr_temp_esum *
+ $ (clstr_temp_xcell(ihit) - clstr_temp_xcell(1))
+ ymom = ymom + clstr_temp_ecell(ihit) / clstr_temp_esum *
+ $ (clstr_temp_ycell(ihit) - clstr_temp_ycell(1))
+
+ ! zero the hits belonging to this cluster so that they can't be
+ ! used more than once
+ do jhit=1,BIGCAL_RCS_NGOOD
+ if(BIGCAL_RCS_IYGOOD(jhit).eq.clstr_temp_iycell(ihit)
+ $ - BIGCAL_PROT_NY.and.BIGCAL_RCS_IXGOOD(jhit).eq.
+ $ clstr_temp_ixcell(ihit)) then
+ BIGCAL_RCS_ECELL(jhit) = 0.
+ BIGCAL_RCS_IYGOOD(jhit) = 0
+ BIGCAL_RCS_IXGOOD(jhit) = 0
+ BIGCAL_RCS_XGOOD(jhit) = 0.
+ BIGCAL_RCS_YGOOD(jhit) = 0.
+ endif
+ enddo
+ ! do the same for the Protvino part in case of a cluster straddling the
+ ! two sections
+ do jhit=1,BIGCAL_PROT_NGOOD
+ if(BIGCAL_PROT_IYGOOD(jhit).eq.clstr_temp_iycell(ihit)
+ $ .and. BIGCAL_PROT_IXGOOD(jhit).eq.
+ $ clstr_temp_ixcell(ihit))then
+ BIGCAL_PROT_ECELL(jhit) = 0.
+ BIGCAL_PROT_IYGOOD(jhit) = 0
+ BIGCAL_PROT_IXGOOD(jhit) = 0
+ BIGCAL_PROT_XGOOD(jhit) = 0.
+ BIGCAL_PROT_YGOOD(jhit) = 0.
+ endif
+ enddo
+ irow = clstr_temp_iycell(ihit)
+ icol = clstr_temp_ixcell(ihit)
+ if(irow.le.BIGCAL_PROT_NY)then
+ icell = icol + BIGCAL_PROT_NX * (irow - 1)
+ irow8 = irow
+ icol8 = (icol - 1) / 8 + 1
+ igroup64 = (irow - 1) / 3 + 1
+ ihalf64 = (icol - 1) / 16 + 1
+ else
+ icell = icol + BIGCAL_RCS_NX * (irow-1-BIGCAL_PROT_NY)
+ irow8 = irow
+ if(icol .lt. 16) icol8 = (icol - 1) / 8 + 1
+ if(icol .ge. 16) icol8 = icol / 8 + 1
+ igroup64 = (irow - 1) / 3 + 1
+ ihalf64 = icol / 16 + 1
+ endif
+ itdc = icol8 + (irow8 - 1) * BIGCAL_MAX_GROUPS
+ ilogic = igroup64 + (ihalf64 - 1)*BIGCAL_LOGIC_GROUPS / 2
+ if(abs(BIGCAL_TIME_DET(itdc) - trigtime).le.b_timing_cut)
+ $ then
+ ntdc = ntdc + 1
+ tavg = tavg + BIGCAL_TIME_DET(itdc)
+ endif
+ if(abs(BIGCAL_TRIG_TIME_DET(ilogic) - trigtime).le.
+ $ b_timing_cut) then
+ ntdc = ntdc + 1
+ tavg = tavg + BIGCAL_TRIG_TIME_DET(ilogic)
+ endif
+ enddo
+ clstr_time = tavg / ntdc
+ BIGCAL_RCS_CLSTR_XMOM(ncluster) = xmom
+ BIGCAL_RCS_CLSTR_YMOM(ncluster) = ymom
+ BIGCAL_RCS_CLSTR_TIME(ncluster) = clstr_time
+ endif
+ endif
+
+ if(found_cluster .and. ncluster .lt. BIGCAL_CLSTR_NCELL_MAX)
+ $ goto 201
+
+ BIGCAL_RCS_NCLSTR = ncluster
+
+ !!!!!!!!!!! come back to middle section later !!!!!!!!!!!!!!!!!
+ !!!!! code still needs to be written !!!!!!!!!!!!!!!!!!!!!!!!!!
+ return
+ end
diff --git a/BTRACKING/b_find_clusters_old.f b/BTRACKING/b_find_clusters_old.f
new file mode 100755
index 0000000..000e539
--- /dev/null
+++ b/BTRACKING/b_find_clusters_old.f
@@ -0,0 +1,1154 @@
+ subroutine b_find_clusters(ABORT,err)
+
+ implicit none
+ save
+
+ character*16 here
+ parameter (here= 'b_find_clusters')
+
+ logical ABORT
+ character*(*) err
+
+ include 'bigcal_data_structures.cmn'
+ include 'bigcal_bypass_switches.cmn'
+ include 'bigcal_gain_parms.cmn'
+ include 'bigcal_tof_parms.cmn'
+ include 'bigcal_geometry.cmn'
+
+ integer*4 ihit,jhit,khit
+ integer*4 icell,jcell,kcell
+ integer*4 itdc,jtdc,ktdc
+ integer*4 ilogic,jlogic,klogic
+ integer*4 irow,jrow,krow,icol,jcol,kcol
+ real*4 ecell,xcell,ycell,xcenter,ycenter
+ integer*4 irow8,icol8
+ integer*4 igroup64,ihalf64
+ integer*4 maxcelldiff,celldiffx,celldiffy
+ real*4 clstr_temp_ecell(BIGCAL_CLSTR_NCELL_MAX)
+ integer*4 clstr_temp_ixcell(BIGCAL_CLSTR_NCELL_MAX)
+ integer*4 clstr_temp_iycell(BIGCAL_CLSTR_NCELL_MAX)
+ real*4 clstr_temp_xcell(BIGCAL_CLSTR_NCELL_MAX)
+ real*4 clstr_temp_ycell(BIGCAL_CLSTR_NCELL_MAX)
+ real*4 clstr_temp_esum
+
+ logical goodhit(BIGCAL_CLSTR_NCELL_MAX)
+
+ real*4 emax,xmax,ymax,minxdiff
+ integer*4 ixmax,iymax,ihitmax,ixmin,iymin
+ integer*4 ncellclust
+ integer*4 ncluster
+ integer*4 nbad
+
+ integer*4 nrows
+
+ integer*4 itemp,jtemp,ktemp
+ real*4 irtemp,jrtemp,krtemp
+
+ real*4 trigtime,hittime
+ real*4 xmom,ymom,clstr_time
+ real*4 tavg
+
+ integer*4 ntdc
+
+ logical tdchit,trighit
+ logical second_max
+ logical found_cluster
+
+ !trigtime = BIGCAL_REF_TIME
+
+ maxcelldiff = int(sqrt(float(BIGCAL_CLSTR_NCELL_MAX))) / 2
+
+ if(bbypass_prot.ne.0.or.bbypass_rcs.ne.0) return
+ ! at a minimum, the glass ADC information is required to look for clusters
+ ncluster = 0
+
+ 101 continue
+ found_cluster = .false.
+
+ ! zero temporary cluster quantities:
+ do icell=1,BIGCAL_CLSTR_NCELL_MAX
+ clstr_temp_ecell(icell) = 0.
+ clstr_temp_xcell(icell) = 0.
+ clstr_temp_ycell(icell) = 0.
+ clstr_temp_ixcell(icell) = 0
+ clstr_temp_iycell(icell) = 0
+ goodhit(icell) = .false.
+ enddo
+
+ emax = 0.
+ ixmax = 0
+ iymax = 0
+
+ ! find clusters. Only check timing if bypass switches are set for timing analysis
+ do ihit=1,BIGCAL_PROT_NGOOD
+ !tdchit = .false.
+ !trighit = .false.
+ ecell = BIGCAL_PROT_ECELL(ihit)
+ irow = BIGCAL_PROT_IYGOOD(ihit)
+ icol = BIGCAL_PROT_IXGOOD(ihit)
+ icell = icol + BIGCAL_PROT_NX * (irow - 1)
+ xcell = BIGCAL_PROT_XGOOD(ihit)
+ ycell = BIGCAL_PROT_YGOOD(ihit)
+ ! determine which tdc channel (group of 8) we are in
+ !irow8 = irow
+ !icol8 = (icol - 1) / 8 + 1
+ !itdc = icol8 + (irow8 - 1)*BIGCAL_MAX_GROUPS
+ ! determine which trigger group (group of 64) we are in
+ !ihalf64 = (icol - 1) / 16 + 1
+ !igroup64 = (irow - 1) / 3 + 1
+ !ilogic = igroup64 + (ihalf64 - 1) * BIGCAL_LOGIC_GROUPS / 2
+
+c$$$ if(bbypass_sum8.eq.0) then
+c$$$ if(abs(BIGCAL_TIME_DET(itdc)-trigtime).le.b_timing_cut) then
+c$$$ tdchit = .true.
+c$$$ endif
+c$$$ endif
+c$$$ if(bbypass_sum64.eq.0) then
+c$$$ if(abs(BIGCAL_TRIG_TIME_DET(ilogic)-trigtime).le.
+c$$$ $ b_timing_cut) then
+c$$$ trighit = .true.
+c$$$ endif
+c$$$ endif
+ !if(bbypass_sum64.eq.0.or.bbypass_sum8.eq.0) then
+ if(ecell .gt. emax) then
+ emax = ecell
+ ixmax = icol
+ iymax = irow
+ ihitmax = ihit
+ endif
+ enddo
+
+ ! if, upon looping through all hits, we have found a maximum that has a valid tdc or
+ ! trigger tdc value, then build a cluster from all the neighboring channels using the
+ ! detector arrays (regardless of whether there is a hit: some cells may have 0)
+ if(ixmax.ge.2.and.iymax.ge.2.and.ixmax.le.BIGCAL_PROT_NX-1.and.
+ $ iymax.le.BIGCAL_PROT_NY-1) then
+ ncellclust = 0
+ do irow = iymax - maxcelldiff,iymax + maxcelldiff
+ do icol = ixmax - maxcelldiff,ixmax + maxcelldiff
+ if(irow.ge.1.and.icol.ge.1.and.irow.le.BIGCAL_PROT_NY
+ $ .and.icol.le.BIGCAL_PROT_NX) then
+ icell = icol + BIGCAL_PROT_NX*(irow - 1)
+
+ ecell = BIGCAL_PROT_GOOD_DET(icell)
+ xcell = BIGCAL_PROT_XCENTER(icell)
+ ycell = BIGCAL_PROT_YCENTER(icell)
+
+ if(ecell.ge.b_cell_cut_prot) then
+ ncellclust = ncellclust + 1
+ if(ncellclust.gt.BIGCAL_CLSTR_NCELL_MAX) goto 100
+
+ clstr_temp_ecell(ncellclust) = ecell
+ clstr_temp_ixcell(ncellclust) = icol
+ clstr_temp_iycell(ncellclust) = irow
+ clstr_temp_xcell(ncellclust) = xcell
+ clstr_temp_ycell(ncellclust) = ycell
+ goodhit(ncellclust) = .true.
+ endif
+
+ endif
+ enddo
+ enddo
+ 100 continue
+
+c ! in the special case of iymax = 31 add closest cells in the first rows of RCS part
+ if(iymax + maxcelldiff .gt. BIGCAL_PROT_NY) then
+ nrows = iymax + maxcelldiff - BIGCAL_PROT_NY
+ do irow=1,nrows
+c$$$ minxdiff = 1000.
+c$$$ xcell = BIGCAL_PROT_XGOOD(ihitmax)
+c$$$ do icol = max(1,ixmax-5),min(ixmax+5,BIGCAL_RCS_NX)
+c$$$ icell = icol + BIGCAL_RCS_NX * (irow - 1)
+c$$$ if(abs(xcell - BIGCAL_RCS_XCENTER(icell)).lt.minxdiff)
+c$$$ $ then
+c$$$ minxdiff = abs(xcell - BIGCAL_RCS_XCENTER(icell))
+c$$$ ixmin = icol
+c$$$ endif
+c$$$ enddo
+
+ ixmin = bigcal_ixclose_prot(ixmax)
+
+c if(minxdiff .lt. 1000.) then
+ do icol = max(ixmin-maxcelldiff,1),min(ixmin+maxcelldiff,30)
+c$$$ do icol = ixmin - maxcelldiff,ixmin + maxcelldiff
+ icell = icol + BIGCAL_RCS_NX * (irow - 1)
+c if(icol.ge.1.and.icol.le.BIGCAL_RCS_NX) then
+
+ ecell = BIGCAL_RCS_GOOD_DET(icell)
+ xcell = BIGCAL_RCS_XCENTER(icell)
+ ycell = BIGCAL_RCS_YCENTER(icell)
+
+ if(ecell.ge.b_cell_cut_rcs) then
+ ncellclust = ncellclust + 1
+ if(ncellclust.gt.BIGCAL_CLSTR_NCELL_MAX)goto 102
+
+ clstr_temp_ecell(ncellclust) = ecell
+ clstr_temp_ixcell(ncellclust) = icol
+ clstr_temp_iycell(ncellclust) =
+ $ irow + BIGCAL_PROT_NY
+ clstr_temp_xcell(ncellclust) = xcell
+ clstr_temp_ycell(ncellclust) = ycell
+ goodhit(ncellclust)=.true.
+ endif
+
+c endif
+ enddo
+c endif
+ enddo
+ endif
+c ! end special case iymax = 31
+c ! check temporary cluster for absence of second max. and sum above
+c ! software threshold:
+c ! start by sorting cluster cells in descending order of amplitude:
+
+ 102 continue
+
+ if(ncellclust.gt.BIGCAL_CLSTR_NCELL_MAX) then
+ ncellclust = BIGCAL_CLSTR_NCELL_MAX
+ endif
+
+ if(ncellclust.lt.bigcal_clstr_ncell_min) then
+ bigcal_prot_bad_clstr_flag(ncluster) = 2
+c$$$ call b_trig_check(2,ncellclust,clstr_temp_iycell,
+c$$$ $ clstr_temp_ixcell,clstr_temp_ecell,abort,err)
+ goto 134
+ endif
+
+ clstr_temp_esum = 0.
+ do ihit=1,ncellclust
+ clstr_temp_esum = clstr_temp_esum + clstr_temp_ecell(ihit)
+ enddo
+
+ if(clstr_temp_esum .lt.b_cluster_cut) then
+ bigcal_prot_bad_clstr_flag(ncluster) = 3
+c$$$ call b_trig_check(3,ncellclust,clstr_temp_iycell,
+c$$$ $ clstr_temp_ixcell,clstr_temp_ecell,abort,err)
+ goto 134
+ endif
+
+ do ihit=1,ncellclust
+ do jhit=ihit+1,ncellclust
+ if(clstr_temp_ecell(jhit).gt.clstr_temp_ecell(ihit))then
+c ! switch hits i and j, remember to switch all five quantities
+c ! at this point all goodhit are true, so no need to switch
+ irtemp = clstr_temp_ecell(ihit)
+ clstr_temp_ecell(ihit) = clstr_temp_ecell(jhit)
+ clstr_temp_ecell(jhit) = irtemp
+
+ irtemp = clstr_temp_xcell(ihit)
+ clstr_temp_xcell(ihit) = clstr_temp_xcell(jhit)
+ clstr_temp_xcell(jhit) = irtemp
+
+ irtemp = clstr_temp_ycell(ihit)
+ clstr_temp_ycell(ihit) = clstr_temp_ycell(jhit)
+ clstr_temp_ycell(jhit) = irtemp
+
+ itemp = clstr_temp_ixcell(ihit)
+ clstr_temp_ixcell(ihit) = clstr_temp_ixcell(jhit)
+ clstr_temp_ixcell(jhit) = itemp
+
+ itemp = clstr_temp_iycell(ihit)
+ clstr_temp_iycell(ihit) = clstr_temp_iycell(jhit)
+ clstr_temp_iycell(jhit) = itemp
+ endif
+ enddo
+ enddo
+
+ celldiffx = clstr_temp_ixcell(2) - clstr_temp_ixcell(1)
+ celldiffy = clstr_temp_iycell(2) - clstr_temp_iycell(1)
+
+ celldiffx = int(abs(float(celldiffx)))
+ celldiffy = int(abs(float(celldiffy)))
+
+ if(celldiffx .gt. 1.or.celldiffy .gt. 1) then
+ second_max = .true.
+ else
+ second_max = .false.
+ endif
+
+ if(clstr_temp_iycell(1).ne.iymax.or.clstr_temp_ixcell(1).ne.ixmax) then
+ second_max = .true.
+ endif
+
+ if(second_max) then
+ bigcal_prot_bad_clstr_flag(ncluster) = 4
+c$$$ call b_trig_check(4,ncellclust,clstr_temp_iycell,
+c$$$ $ clstr_temp_ixcell,clstr_temp_ecell,abort,err)
+ goto 134
+ endif
+
+ if(clstr_temp_esum.ge.b_cluster_cut.and. .not. second_max) then
+c !add a cluster to the array for protvino:
+ if(ncellclust.ge.BIGCAL_CLSTR_NCELL_MIN) then
+ found_cluster = .true.
+ ncluster = ncluster + 1
+ BIGCAL_PROT_CLSTR_IYMAX(ncluster) = clstr_temp_iycell(1)
+ BIGCAL_PROT_CLSTR_IXMAX(ncluster) = clstr_temp_ixcell(1)
+ BIGCAL_PROT_CLSTR_ETOT(ncluster) = clstr_temp_esum
+ BIGCAL_PROT_CLSTR_NCELL(ncluster) = ncellclust
+
+ xmom = 0.
+ ymom = 0.
+
+ do ihit=1,ncellclust
+ BIGCAL_PROT_CLSTR_IYCELL(ncluster,ihit) =
+ $ clstr_temp_iycell(ihit)
+ BIGCAL_PROT_CLSTR_IXCELL(ncluster,ihit) =
+ $ clstr_temp_ixcell(ihit)
+ BIGCAL_PROT_CLSTR_ECELL(ncluster,ihit) =
+ $ clstr_temp_ecell(ihit)
+ BIGCAL_PROT_CLSTR_XCELL(ncluster,ihit) =
+ $ clstr_temp_xcell(ihit)
+ BIGCAL_PROT_CLSTR_YCELL(ncluster,ihit) =
+ $ clstr_temp_ycell(ihit)
+
+ xmom = xmom+clstr_temp_ecell(ihit)/clstr_temp_esum
+ $ *(clstr_temp_xcell(ihit)-clstr_temp_xcell(1))
+ ymom = ymom+clstr_temp_ecell(ihit)/clstr_temp_esum
+ $ *(clstr_temp_ycell(ihit)-clstr_temp_ycell(1))
+
+c ! zero the hits belonging to this cluster so that they can't be
+c ! used more than once
+
+ irow = clstr_temp_iycell(ihit)
+ icol = clstr_temp_ixcell(ihit)
+
+ if(irow.le.bigcal_prot_ny) then
+ icell = icol + bigcal_prot_nx*(irow-1)
+ bigcal_prot_good_det(icell) = 0.
+ else
+ icell = icol + bigcal_rcs_nx*(irow-33)
+ bigcal_rcs_good_det(icell) = 0.
+ endif
+
+ do jhit=1,BIGCAL_PROT_NGOOD
+ if(BIGCAL_PROT_IYGOOD(jhit).eq.
+ $ clstr_temp_iycell(ihit).and.
+ $ BIGCAL_PROT_IXGOOD(jhit).eq.
+ $ clstr_temp_ixcell(ihit)) then
+ BIGCAL_PROT_ECELL(jhit) = 0.
+ BIGCAL_PROT_IYGOOD(jhit) = 0
+ BIGCAL_PROT_IXGOOD(jhit) = 0
+ BIGCAL_PROT_XGOOD(jhit) = 0.
+ BIGCAL_PROT_YGOOD(jhit) = 0.
+ endif
+ enddo
+c ! do the same for the RCS part in the case of clusters overlapping
+c ! the Prot-RCS boundary:
+ do jhit=1,BIGCAL_RCS_NGOOD
+ if(BIGCAL_RCS_IYGOOD(jhit)+BIGCAL_PROT_NY.eq.
+ $ clstr_temp_iycell(ihit).and.
+ $ BIGCAL_RCS_IXGOOD(jhit) .eq.
+ $ clstr_temp_ixcell(ihit)) then
+ BIGCAL_RCS_ECELL(jhit) = 0.
+ BIGCAL_RCS_IYGOOD(jhit) = 0
+ BIGCAL_RCS_IXGOOD(jhit) = 0
+ BIGCAL_RCS_XGOOD(jhit) = 0.
+ BIGCAL_RCS_YGOOD(jhit) = 0.
+ endif
+ enddo
+ enddo
+ BIGCAL_PROT_CLSTR_XMOM(ncluster) = xmom
+ BIGCAL_PROT_CLSTR_YMOM(ncluster) = ymom
+
+ if(bdebug_print_clusters.ne.0) call b_print_cluster(1,ncluster,ABORT,err)
+
+ endif
+ endif
+
+ else if(ixmax.eq.1.or.ixmax.eq.bigcal_prot_nx.or.iymax.eq.1.or.
+ $ iymax.eq.bigcal_prot_ny) then ! max is at edge
+ bigcal_prot_bad_clstr_flag(ncluster) = 1
+c$$$ call b_trig_check(1,ncellclust,clstr_temp_iycell,
+c$$$ $ clstr_temp_ixcell,clstr_temp_ecell,abort,err)
+ !write(*,*) 'edge max! ncluster = ',ncluster
+ endif
+
+ 134 continue
+
+ if((.not.found_cluster).and.ncluster.eq.0) then
+ bigcal_prot_no_clstr_why = bigcal_prot_bad_clstr_flag(0)
+ endif
+
+ if(found_cluster .and. ncluster .lt. BIGCAL_PROT_NCLSTR_MAX) then
+ goto 101
+ endif
+
+ BIGCAL_PROT_NCLSTR = ncluster
+
+ ncluster = 0
+
+ 201 continue
+ found_cluster = .false.
+
+c ! zero temporary cluster quantities:
+ do icell=1,BIGCAL_CLSTR_NCELL_MAX
+ clstr_temp_ecell(icell) = 0.
+ clstr_temp_xcell(icell) = 0.
+ clstr_temp_ycell(icell) = 0.
+ clstr_temp_ixcell(icell) = 0
+ clstr_temp_iycell(icell) = 0
+ goodhit(icell) = .false.
+ enddo
+
+ emax = 0.
+ ixmax = 0
+ iymax = 0
+
+c ! find clusters. Only check timing if bypass switches are set for timing analysis
+ do ihit=1,BIGCAL_RCS_NGOOD
+c !tdchit = .false.
+c !trighit = .false.
+ ecell = BIGCAL_RCS_ECELL(ihit)
+ irow = BIGCAL_RCS_IYGOOD(ihit)
+ icol = BIGCAL_RCS_IXGOOD(ihit)
+ icell = icol + BIGCAL_RCS_NX * (irow - 1)
+ xcell = BIGCAL_RCS_XGOOD(ihit)
+ ycell = BIGCAL_RCS_YGOOD(ihit)
+c ! determine which tdc channel (group of 8) we are in
+c !irow8 = irow
+c !icol8 = (icol - 1) / 8 + 1
+c !itdc = icol8 + (irow8 - 1)*BIGCAL_MAX_GROUPS
+c ! determine which trigger group (group of 64) we are in
+c !ihalf64 = (icol - 1) / 16 + 1
+c !igroup64 = (irow - 1) / 3 + 1
+c !ilogic = igroup64 + (ihalf64 - 1) * BIGCAL_LOGIC_GROUPS / 2
+
+c$$$ if(bbypass_sum8.eq.0) then
+c$$$ if(abs(BIGCAL_TIME_DET(itdc)-trigtime).le.b_timing_cut) then
+c$$$ tdchit = .true.
+c$$$ endif
+c$$$ endif
+c$$$ if(bbypass_sum64.eq.0) then
+c$$$ if(abs(BIGCAL_TRIG_TIME_DET(ilogic)-trigtime).le.
+c$$$ $ b_timing_cut) then
+c$$$ trighit = .true.
+c$$$ endif
+c$$$ endif
+c !if(bbypass_sum64.eq.0.or.bbypass_sum8.eq.0) then
+ if(ecell .gt. emax) then
+ emax = ecell
+ ixmax = icol
+ iymax = irow
+ ihitmax = ihit
+ endif
+ enddo
+
+c ! if, upon looping through all hits, we have found a maximum that has a valid tdc or
+c ! trigger tdc value, then build a cluster from all the neighboring channels using the
+c ! detector arrays (regardless of whether there is a hit: some cells may have 0)
+ if(ixmax.ge.2.and.iymax.ge.2.and.ixmax.le.BIGCAL_RCS_NX-1.and.
+ $ iymax.le.BIGCAL_RCS_NY-1) then
+ ncellclust = 0
+ do irow = iymax - maxcelldiff,iymax + maxcelldiff
+ do icol = ixmax - maxcelldiff,ixmax + maxcelldiff
+ if(irow.ge.1.and.icol.ge.1.and.irow.le.BIGCAL_RCS_NY
+ $ .and.icol.le.BIGCAL_RCS_NX) then
+ icell = icol + BIGCAL_RCS_NX*(irow - 1)
+
+ ecell = BIGCAL_RCS_GOOD_DET(icell)
+ xcell = BIGCAL_RCS_XCENTER(icell)
+ ycell = BIGCAL_RCS_YCENTER(icell)
+
+ if(ecell.ge.b_cell_cut_rcs) then
+ ncellclust = ncellclust + 1
+ if(ncellclust.gt.BIGCAL_CLSTR_NCELL_MAX) goto 200
+
+ clstr_temp_ecell(ncellclust) = ecell
+ clstr_temp_ixcell(ncellclust) = icol
+ clstr_temp_iycell(ncellclust) = irow +
+ $ BIGCAL_PROT_NY
+ clstr_temp_xcell(ncellclust) = xcell
+ clstr_temp_ycell(ncellclust) = ycell
+ goodhit(ncellclust) = .true.
+ endif
+
+ endif
+ enddo
+ enddo
+ 200 continue
+
+c ! in the special case of iymax = 34 add closest cells in the first rows of RCS part
+ if(iymax - maxcelldiff .lt. 1) then
+ nrows = maxcelldiff - iymax + 1
+ do irow=1,nrows
+c$$$ minxdiff = 1000.
+c$$$ xcell = BIGCAL_RCS_XGOOD(ihitmax)
+c$$$ do icol = max(1,ixmax-5),min(ixmax+5,BIGCAL_PROT_NX)
+c$$$ icell = icol + BIGCAL_PROT_NX * (BIGCAL_PROT_NY-irow)
+c$$$ if(abs(xcell-BIGCAL_PROT_XCENTER(icell)).lt.minxdiff)
+c$$$ $ then
+c$$$ minxdiff = abs(xcell - BIGCAL_PROT_XCENTER(icell))
+c$$$ ixmin = icol
+c$$$ endif
+c$$$ enddo
+c if(minxdiff .lt. 1000.) then
+ ixmin = bigcal_ixclose_rcs(ixmax)
+
+ do icol = max(ixmin-maxcelldiff,1),min(ixmin+maxcelldiff,32)
+ icell = icol + BIGCAL_PROT_NX*(BIGCAL_PROT_NY-irow)
+c if(icol.ge.1.and.icol.le.BIGCAL_PROT_NX) then
+
+ ecell = BIGCAL_PROT_GOOD_DET(icell)
+ xcell = BIGCAL_PROT_XCENTER(icell)
+ ycell = BIGCAL_PROT_YCENTER(icell)
+
+ if(ecell.ge.b_cell_cut_prot) then
+ ncellclust = ncellclust + 1
+ if(ncellclust.gt.BIGCAL_CLSTR_NCELL_MAX)goto 202
+
+ clstr_temp_ecell(ncellclust) = ecell
+ clstr_temp_ixcell(ncellclust) = icol
+ clstr_temp_iycell(ncellclust) = BIGCAL_PROT_NY
+ $ - irow + 1
+ clstr_temp_xcell(ncellclust) = xcell
+ clstr_temp_ycell(ncellclust) = ycell
+ goodhit(ncellclust)=.true.
+ endif
+
+c endif
+ enddo
+c endif
+ enddo
+ endif
+c ! end special case iymax = 34
+c ! check temporary cluster for absence of second max. and sum above
+c ! software threshold:
+c ! start by sorting cluster cells in descending order of amplitude:
+
+ 202 continue
+
+ if(ncellclust.gt.BIGCAL_CLSTR_NCELL_MAX) then
+ ncellclust = BIGCAL_CLSTR_NCELL_MAX
+ endif
+
+ if(ncellclust.lt.bigcal_clstr_ncell_min) then
+ bigcal_rcs_bad_clstr_flag(ncluster) = 2
+ goto 234
+ endif
+
+ clstr_temp_esum = 0.
+ do ihit=1,ncellclust
+ clstr_temp_esum = clstr_temp_esum + clstr_temp_ecell(ihit)
+ enddo
+
+ if(clstr_temp_esum.lt.b_cluster_cut) then
+ bigcal_rcs_bad_clstr_flag(ncluster) = 3
+ goto 234
+ endif
+
+ do ihit=1,ncellclust
+ do jhit=ihit+1,ncellclust
+ if(clstr_temp_ecell(jhit).gt.clstr_temp_ecell(ihit))then
+c ! switch hits i and j, remember to switch all five quantities
+c ! at this point all goodhit are true, so no need to switch
+ irtemp = clstr_temp_ecell(ihit)
+ clstr_temp_ecell(ihit) = clstr_temp_ecell(jhit)
+ clstr_temp_ecell(jhit) = irtemp
+
+ irtemp = clstr_temp_xcell(ihit)
+ clstr_temp_xcell(ihit) = clstr_temp_xcell(jhit)
+ clstr_temp_xcell(jhit) = irtemp
+
+ irtemp = clstr_temp_ycell(ihit)
+ clstr_temp_ycell(ihit) = clstr_temp_ycell(jhit)
+ clstr_temp_ycell(jhit) = irtemp
+
+ itemp = clstr_temp_ixcell(ihit)
+ clstr_temp_ixcell(ihit) = clstr_temp_ixcell(jhit)
+ clstr_temp_ixcell(jhit) = itemp
+
+ itemp = clstr_temp_iycell(ihit)
+ clstr_temp_iycell(ihit) = clstr_temp_iycell(jhit)
+ clstr_temp_iycell(jhit) = itemp
+ endif
+ enddo
+ enddo
+
+ celldiffx = clstr_temp_ixcell(2) - clstr_temp_ixcell(1)
+ celldiffy = clstr_temp_iycell(2) - clstr_temp_iycell(1)
+
+ celldiffx = int(abs(float(celldiffx)))
+ celldiffy = int(abs(float(celldiffy)))
+
+ if(celldiffx .gt. 1.or.celldiffy .gt. 1) then
+ second_max = .true.
+ else
+ second_max = .false.
+ endif
+
+ if(clstr_temp_iycell(1)-bigcal_prot_ny.ne.iymax.or.
+ $ clstr_temp_ixcell(1).ne.ixmax) then
+ second_max = .true.
+ endif
+
+ if(second_max) then
+ bigcal_rcs_bad_clstr_flag(ncluster) = 4
+ goto 234
+ endif
+
+ if(clstr_temp_esum.ge.b_cluster_cut.and. .not. second_max) then
+c !add a cluster to the array for rcs:
+ if(ncellclust.ge.BIGCAL_CLSTR_NCELL_MIN) then
+ found_cluster = .true.
+ ncluster = ncluster + 1
+ BIGCAL_RCS_CLSTR_IYMAX(ncluster) = clstr_temp_iycell(1)
+ BIGCAL_RCS_CLSTR_IXMAX(ncluster) = clstr_temp_ixcell(1)
+ BIGCAL_RCS_CLSTR_ETOT(ncluster) = clstr_temp_esum
+ BIGCAL_RCS_CLSTR_NCELL(ncluster) = ncellclust
+
+ xmom = 0.
+ ymom = 0.
+
+ do ihit=1,ncellclust
+ BIGCAL_RCS_CLSTR_IYCELL(ncluster,ihit) =
+ $ clstr_temp_iycell(ihit)
+ BIGCAL_RCS_CLSTR_IXCELL(ncluster,ihit) =
+ $ clstr_temp_ixcell(ihit)
+ BIGCAL_RCS_CLSTR_ECELL(ncluster,ihit) =
+ $ clstr_temp_ecell(ihit)
+ BIGCAL_RCS_CLSTR_XCELL(ncluster,ihit) =
+ $ clstr_temp_xcell(ihit)
+ BIGCAL_RCS_CLSTR_YCELL(ncluster,ihit) =
+ $ clstr_temp_ycell(ihit)
+
+ xmom = xmom+clstr_temp_ecell(ihit)/clstr_temp_esum
+ $ *(clstr_temp_xcell(ihit)-clstr_temp_xcell(1))
+ ymom = ymom+clstr_temp_ecell(ihit)/clstr_temp_esum
+ $ *(clstr_temp_ycell(ihit)-clstr_temp_ycell(1))
+
+
+ icol = clstr_temp_ixcell(ihit)
+ irow = clstr_temp_iycell(ihit)
+
+ if(irow.le.bigcal_prot_ny) then
+ icell = icol + bigcal_prot_nx*(irow-1)
+ bigcal_prot_good_det(icell) = 0.
+ else
+ icell = icol + bigcal_rcs_nx*(irow-33)
+ bigcal_rcs_good_det(icell) = 0.
+ endif
+
+c ! zero the hits belonging to this cluster so that they can't be
+c ! used more than once
+ do jhit=1,BIGCAL_PROT_NGOOD
+ if(BIGCAL_PROT_IYGOOD(jhit).eq.
+ $ clstr_temp_iycell(ihit).and.
+ $ BIGCAL_PROT_IXGOOD(jhit).eq.
+ $ clstr_temp_ixcell(ihit)) then
+ BIGCAL_PROT_ECELL(jhit) = 0.
+ BIGCAL_PROT_IYGOOD(jhit) = 0
+ BIGCAL_PROT_IXGOOD(jhit) = 0
+ BIGCAL_PROT_XGOOD(jhit) = 0.
+ BIGCAL_PROT_YGOOD(jhit) = 0.
+ endif
+ enddo
+c ! do the same for the RCS part in the case of clusters overlapping
+c ! the Prot-RCS boundary:
+ do jhit=1,BIGCAL_RCS_NGOOD
+ if(BIGCAL_RCS_IYGOOD(jhit)+BIGCAL_PROT_NY.eq.
+ $ clstr_temp_iycell(ihit).and.
+ $ BIGCAL_RCS_IXGOOD(jhit) .eq.
+ $ clstr_temp_ixcell(ihit)) then
+ BIGCAL_RCS_ECELL(jhit) = 0.
+ BIGCAL_RCS_IYGOOD(jhit) = 0
+ BIGCAL_RCS_IXGOOD(jhit) = 0
+ BIGCAL_RCS_XGOOD(jhit) = 0.
+ BIGCAL_RCS_YGOOD(jhit) = 0.
+ endif
+ enddo
+ enddo
+
+ BIGCAL_RCS_CLSTR_XMOM(ncluster) = xmom
+ BIGCAL_RCS_CLSTR_YMOM(ncluster) = ymom
+
+ if(bdebug_print_clusters.ne.0) call b_print_cluster(2,ncluster,ABORT,err)
+
+ endif
+ endif
+ else if(ixmax.eq.1.or.ixmax.eq.bigcal_rcs_nx.or.iymax.eq.1.or.
+ $ iymax.eq.bigcal_rcs_ny) then ! max at edge
+ bigcal_rcs_bad_clstr_flag(ncluster) = 1
+ !write(*,*) 'edge max! ncluster = ',ncluster
+ endif
+
+ 234 continue
+
+ if((.not.found_cluster).and.ncluster.eq.0) then
+ bigcal_rcs_no_clstr_why = bigcal_rcs_bad_clstr_flag(0)
+ endif
+
+ if(found_cluster .and. ncluster .lt. BIGCAL_RCS_NCLSTR_MAX) then
+ goto 201
+ endif
+ BIGCAL_RCS_NCLSTR = ncluster
+
+c !!!!!!!!Come back to the middle section later!!!!!!!!!!!!!!1
+
+c first fill middle hit arrays:
+
+ do irow=30,32
+ do icol=1,32
+ icell = icol + 32*(irow-1)
+ bigcal_mid_ehit(irow,icol) = bigcal_prot_good_det(icell)
+ bigcal_mid_xhit(irow,icol) = bigcal_prot_xcenter(icell)
+ bigcal_mid_yhit(irow,icol) = bigcal_prot_ycenter(icell)
+ enddo
+ enddo
+
+ do irow=33,35
+ do icol=1,30
+ icell = icol + 30*(irow-33)
+ bigcal_mid_ehit(irow,icol) = bigcal_rcs_good_det(icell)
+ bigcal_mid_xhit(irow,icol) = bigcal_rcs_xcenter(icell)
+ bigcal_mid_yhit(irow,icol) = bigcal_rcs_ycenter(icell)
+ enddo
+ enddo
+
+c$$$ !write(*,*) 'mid_ehit = ',bigcal_mid_ehit
+c$$$ write(*,*) 'mid_xhit = ',bigcal_mid_xhit
+c$$$ write(*,*) 'mid_yhit = ',bigcal_mid_yhit
+
+c find maximum
+
+ ncluster = 0
+
+ 301 continue
+
+ found_cluster = .false.
+c zero temporary cluster quantities!!!!
+ do icell=1,BIGCAL_CLSTR_NCELL_MAX
+ clstr_temp_ecell(icell) = 0.
+ clstr_temp_xcell(icell) = 0.
+ clstr_temp_ycell(icell) = 0.
+ clstr_temp_ixcell(icell) = 0
+ clstr_temp_iycell(icell) = 0
+ goodhit(icell) = .false.
+ enddo
+
+ ixmax = 0
+ iymax = 0
+
+ emax = 0.
+
+ do irow = 30,35
+ do icol = 1,32
+ if(bigcal_mid_ehit(irow,icol).gt.emax) then
+ if( icol.le.30 .or. irow .le. 32) then
+ emax = bigcal_mid_ehit(irow,icol)
+ ixmax = icol
+ iymax = irow
+ endif
+ endif
+ enddo
+ enddo
+
+c$$$ if(iymax.ne.0) write(*,*) 'row = ',iymax,' col = ',ixmax
+
+ if(iymax.eq.32) then
+ if(ixmax.ge.2.and.ixmax.le.31) then
+
+c$$$ minxdiff = 10000.
+c$$$
+c$$$ do icol = max(ixmax-5,1),min(ixmax+5,30)
+c$$$ if(abs(bigcal_mid_xhit(33,icol)-bigcal_mid_xhit(32,ixmax))
+c$$$ $ .lt.minxdiff) then
+c$$$ ixmin = icol
+c$$$ minxdiff = abs(bigcal_mid_xhit(33,icol) -
+c$$$ $ bigcal_mid_xhit(32,ixmax))
+c$$$ endif
+c$$$ enddo
+
+c !write(*,*) 'colmindiff = ',ixmin
+
+ ixmin = bigcal_ixclose_prot(ixmax)
+
+ ncellclust = 0
+
+c if(minxdiff.lt.10000.) then
+ do irow = 30,32
+ do icol = max(ixmax-2,1),min(ixmax+2,32)
+
+ ecell = bigcal_mid_ehit(irow,icol)
+ xcell = bigcal_mid_xhit(irow,icol)
+ ycell = bigcal_mid_yhit(irow,icol)
+
+ if(ecell.ge.b_cell_cut_prot) then
+
+ ncellclust = ncellclust + 1
+ if(ncellclust.gt.bigcal_clstr_ncell_max)goto 300
+
+ clstr_temp_ecell(ncellclust) = ecell
+ clstr_temp_xcell(ncellclust) = xcell
+ clstr_temp_ycell(ncellclust) = ycell
+ clstr_temp_ixcell(ncellclust) = icol
+ clstr_temp_iycell(ncellclust) = irow
+ endif
+ enddo
+ enddo
+
+ do irow = 33,34
+ do icol = max(ixmin-2,1),min(ixmin+2,30)
+
+ ecell = bigcal_mid_ehit(irow,icol)
+ xcell = bigcal_mid_xhit(irow,icol)
+ ycell = bigcal_mid_yhit(irow,icol)
+
+ if(ecell.ge.b_cell_cut_rcs) then
+ ncellclust = ncellclust + 1
+ if(ncellclust.gt.bigcal_clstr_ncell_max)goto 300
+
+ clstr_temp_ecell(ncellclust) = ecell
+ clstr_temp_xcell(ncellclust) = xcell
+ clstr_temp_ycell(ncellclust) = ycell
+ clstr_temp_ixcell(ncellclust) = icol
+ clstr_temp_iycell(ncellclust) = irow
+ endif
+ enddo
+ enddo
+c endif ! otherwise something doesn't make sense
+ 300 continue
+
+ if(ncellclust.gt.bigcal_clstr_ncell_max) then
+ ncellclust = bigcal_clstr_ncell_max
+ endif
+
+ if(ncellclust.lt.bigcal_clstr_ncell_min) then
+ bigcal_mid_bad_clstr_flag(ncluster) = 2
+ goto 334
+ endif
+
+c sort in descending order of amplitude:
+
+ clstr_temp_esum = 0.
+ do ihit=1,ncellclust
+ clstr_temp_esum = clstr_temp_esum + clstr_temp_ecell(ihit)
+ enddo
+
+ if(clstr_temp_esum.lt.b_cluster_cut) then
+ bigcal_mid_bad_clstr_flag(ncluster) = 3
+ goto 334
+ endif
+
+ do ihit=1,ncellclust
+ do jhit=ihit+1,ncellclust
+ if(clstr_temp_ecell(jhit).gt.clstr_temp_ecell(ihit))then
+ irtemp = clstr_temp_ecell(ihit)
+ clstr_temp_ecell(ihit) = clstr_temp_ecell(jhit)
+ clstr_temp_ecell(jhit) = irtemp
+
+ irtemp = clstr_temp_xcell(ihit)
+ clstr_temp_xcell(ihit) = clstr_temp_xcell(jhit)
+ clstr_temp_xcell(jhit) = irtemp
+
+ irtemp = clstr_temp_ycell(ihit)
+ clstr_temp_ycell(ihit) = clstr_temp_ycell(jhit)
+ clstr_temp_ycell(jhit) = irtemp
+
+ itemp = clstr_temp_ixcell(ihit)
+ clstr_temp_ixcell(ihit) = clstr_temp_ixcell(jhit)
+ clstr_temp_ixcell(jhit) = itemp
+
+ itemp = clstr_temp_iycell(ihit)
+ clstr_temp_iycell(ihit) = clstr_temp_iycell(jhit)
+ clstr_temp_iycell(jhit) = itemp
+
+ endif
+ enddo
+ enddo
+
+c !write(*,*) 'ecell = ',clstr_temp_ecell
+c !write(*,*) 'iycell = ',clstr_temp_iycell
+c !write(*,*) 'ixcell = ',clstr_temp_ixcell
+
+ celldiffx = clstr_temp_ixcell(2) - clstr_temp_ixcell(1)
+ celldiffy = clstr_temp_iycell(2) - clstr_temp_iycell(1)
+
+ if( (clstr_temp_iycell(1).le.bigcal_prot_ny.and.
+ $ celldiffy.gt.0) .or. (clstr_temp_iycell(1).gt.
+ $ bigcal_prot_ny.and.celldiffy.lt.0) ) then
+ celldiffx = celldiffx + clstr_temp_ixcell(1) - ixmin
+ endif
+
+ celldiffx = int(abs(float(celldiffx)))
+ celldiffy = int(abs(float(celldiffy)))
+
+ if(celldiffx.gt.1.or.celldiffy.gt.1) then
+ second_max = .true.
+ else
+ second_max = .false.
+ endif
+
+ if(clstr_temp_iycell(1).ne.iymax.or.clstr_temp_ixcell(1)
+ $ .ne.ixmax) then
+ second_max = .true.
+ endif
+
+ if(second_max) then
+ bigcal_mid_bad_clstr_flag(ncluster) = 4
+ goto 334
+ endif
+
+ if(clstr_temp_esum.ge.b_cluster_cut.and. .not. second_max
+ $ .and.ncellclust.gt.bigcal_clstr_ncell_min)then
+c ADD A CLUSTER TO THE ARRAY FOR THE MIDDLE SECTION!
+ found_cluster = .true.
+
+c !write(*,*) 'found good cluster in mid section!!!!'
+
+ ncluster = ncluster + 1
+ bigcal_mid_clstr_ncell(ncluster) = ncellclust
+ bigcal_mid_clstr_iymax(ncluster) = clstr_temp_iycell(1)
+ bigcal_mid_clstr_ixmax(ncluster) = clstr_temp_ixcell(1)
+ bigcal_mid_clstr_etot(ncluster) = clstr_temp_esum
+
+ xmom = 0.
+ ymom = 0.
+
+ xcenter = clstr_temp_xcell(1)
+ ycenter = clstr_temp_ycell(1)
+
+ do icell=1,ncellclust
+ icol = clstr_temp_ixcell(icell)
+ irow = clstr_temp_iycell(icell)
+ xcell = clstr_temp_xcell(icell)
+ ycell = clstr_temp_ycell(icell)
+ ecell = clstr_temp_ecell(icell)
+c zero the hits from this array so that they can't be used again:
+ bigcal_mid_ehit(irow,icol) = 0.
+ bigcal_mid_xhit(irow,icol) = 0.
+ bigcal_mid_yhit(irow,icol) = 0.
+
+ xmom = xmom + (xcell - xcenter)* ecell / clstr_temp_esum
+ ymom = ymom + (ycell - ycenter)* ecell / clstr_temp_esum
+
+ bigcal_mid_clstr_ixcell(ncluster,icell) = icol
+ bigcal_mid_clstr_iycell(ncluster,icell) = irow
+ bigcal_mid_clstr_xcell(ncluster,icell) = xcell
+ bigcal_mid_clstr_ycell(ncluster,icell) = ycell
+ bigcal_mid_clstr_ecell(ncluster,icell) = ecell
+ enddo
+
+ bigcal_mid_clstr_xmom(ncluster) = xmom
+ bigcal_mid_clstr_ymom(ncluster) = ymom
+
+ endif
+ else if(ixmax.eq.1.or.ixmax.eq.bigcal_prot_nx) then
+ bigcal_mid_bad_clstr_flag(ncluster) = 1
+
+ !write(*,*) 'edge max! ncluster = ',ncluster
+ endif
+ else if(iymax.eq.33) then
+ if(ixmax.ge.2.and.ixmax.le.29) then
+c$$$ minxdiff = 10000.
+c$$$ do icol = max(ixmax-5,1),min(ixmax+5,32)
+c$$$ if(abs(bigcal_mid_xhit(32,icol)-bigcal_mid_xhit(33,ixmax))
+c$$$ $ .lt.minxdiff) then
+c$$$ ixmin = icol
+c$$$ minxdiff = abs(bigcal_mid_xhit(32,icol) -
+c$$$ $ bigcal_mid_xhit(33,ixmax))
+c$$$ endif
+c$$$ enddo
+
+c !write(*,*) 'colmindiff = ',ixmin
+
+ ixmin = bigcal_ixclose_rcs(ixmax)
+
+ ncellclust = 0
+c if(minxdiff.lt.10000.) then
+ do irow = 31,32
+ do icol = max(ixmin-2,1),min(ixmin+2,32)
+
+ ecell = bigcal_mid_ehit(irow,icol)
+ xcell = bigcal_mid_xhit(irow,icol)
+ ycell = bigcal_mid_yhit(irow,icol)
+
+ if(ecell.ge.b_cell_cut_prot) then
+ ncellclust = ncellclust + 1
+ if(ncellclust.gt.bigcal_clstr_ncell_max)goto 302
+
+ clstr_temp_ecell(ncellclust) = ecell
+ clstr_temp_xcell(ncellclust) = xcell
+ clstr_temp_ycell(ncellclust) = ycell
+ clstr_temp_ixcell(ncellclust) = icol
+ clstr_temp_iycell(ncellclust) = irow
+ endif
+ enddo
+ enddo
+
+ do irow = 33,35
+ do icol = max(ixmax-2,1),min(ixmax+2,30)
+ ecell = bigcal_mid_ehit(irow,icol)
+ xcell = bigcal_mid_xhit(irow,icol)
+ ycell = bigcal_mid_yhit(irow,icol)
+
+ if(ecell.ge.b_cell_cut_rcs) then
+ ncellclust = ncellclust + 1
+ if(ncellclust.gt.bigcal_clstr_ncell_max)goto 302
+
+ clstr_temp_ecell(ncellclust) = ecell
+ clstr_temp_xcell(ncellclust) = xcell
+ clstr_temp_ycell(ncellclust) = ycell
+ clstr_temp_ixcell(ncellclust) = icol
+ clstr_temp_iycell(ncellclust) = irow
+ endif
+ enddo
+ enddo
+c endif
+
+ 302 continue
+
+ if(ncellclust.gt.bigcal_clstr_ncell_max) then
+ ncellclust = bigcal_clstr_ncell_max
+ endif
+c sort in descending order of amplitude:
+
+ if(ncellclust.lt.bigcal_clstr_ncell_min) then
+ bigcal_mid_bad_clstr_flag(ncluster) = 2
+ goto 334
+ endif
+
+ clstr_temp_esum = 0.
+ do ihit=1,ncellclust
+ clstr_temp_esum = clstr_temp_esum + clstr_temp_ecell(ihit)
+ enddo
+
+ if(clstr_temp_esum.lt.b_cluster_cut) then
+ bigcal_mid_bad_clstr_flag(ncluster) = 3
+ goto 334
+ endif
+
+ do ihit=1,ncellclust
+ do jhit=ihit+1,ncellclust
+ if(clstr_temp_ecell(jhit).gt.clstr_temp_ecell(ihit))then
+ irtemp = clstr_temp_ecell(ihit)
+ clstr_temp_ecell(ihit) = clstr_temp_ecell(jhit)
+ clstr_temp_ecell(jhit) = irtemp
+
+ irtemp = clstr_temp_xcell(ihit)
+ clstr_temp_xcell(ihit) = clstr_temp_xcell(jhit)
+ clstr_temp_xcell(jhit) = irtemp
+
+ irtemp = clstr_temp_ycell(ihit)
+ clstr_temp_ycell(ihit) = clstr_temp_ycell(jhit)
+ clstr_temp_ycell(jhit) = irtemp
+
+ itemp = clstr_temp_ixcell(ihit)
+ clstr_temp_ixcell(ihit) = clstr_temp_ixcell(jhit)
+ clstr_temp_ixcell(jhit) = itemp
+
+ itemp = clstr_temp_iycell(ihit)
+ clstr_temp_iycell(ihit) = clstr_temp_iycell(jhit)
+ clstr_temp_iycell(jhit) = itemp
+
+ endif
+ enddo
+ enddo
+
+c !write(*,*) 'ecell = ',clstr_temp_ecell
+c !write(*,*) 'iycell = ',clstr_temp_iycell
+c !write(*,*) 'ixcell = ',clstr_temp_ixcell
+
+ celldiffx = clstr_temp_ixcell(2) - clstr_temp_ixcell(1)
+ celldiffy = clstr_temp_iycell(2) - clstr_temp_iycell(1)
+
+ if( (clstr_temp_iycell(1).le.bigcal_prot_ny.and.
+ $ celldiffy.gt.0) .or. (clstr_temp_iycell(1).gt.
+ $ bigcal_prot_ny.and.celldiffy.lt.0) ) then
+ celldiffx = celldiffx + clstr_temp_ixcell(1) - ixmin
+ endif
+
+ celldiffx = int(abs(float(celldiffx)))
+ celldiffy = int(abs(float(celldiffy)))
+
+ if(celldiffx.gt.1.or.celldiffy.gt.1) then
+ second_max = .true.
+ else
+ second_max = .false.
+ endif
+
+ if(clstr_temp_iycell(1).ne.iymax.or.clstr_temp_ixcell(1).ne.
+ $ ixmax) then
+ second_max = .true.
+ endif
+
+ if(second_max) then
+ bigcal_mid_bad_clstr_flag(ncluster) = 4
+ goto 334
+ endif
+
+ if(clstr_temp_esum.ge.b_cluster_cut.and. .not. second_max
+ $ .and.ncellclust.gt.bigcal_clstr_ncell_min)then
+c ADD A CLUSTER TO THE ARRAY FOR THE MIDDLE SECTION!
+
+c !write(*,*) 'found good cluster in mid section!!!!'
+
+ found_cluster = .true.
+ ncluster = ncluster + 1
+ bigcal_mid_clstr_ncell(ncluster) = ncellclust
+ bigcal_mid_clstr_iymax(ncluster) = clstr_temp_iycell(1)
+ bigcal_mid_clstr_ixmax(ncluster) = clstr_temp_ixcell(1)
+ bigcal_mid_clstr_etot(ncluster) = clstr_temp_esum
+
+ xmom = 0.
+ ymom = 0.
+
+ xcenter = clstr_temp_xcell(1)
+ ycenter = clstr_temp_ycell(1)
+
+ do icell=1,ncellclust
+ icol = clstr_temp_ixcell(icell)
+ irow = clstr_temp_iycell(icell)
+c zero the hits from this array so that they can't be used again:
+ bigcal_mid_ehit(irow,icol) = 0.
+ bigcal_mid_xhit(irow,icol) = 0.
+ bigcal_mid_yhit(irow,icol) = 0.
+
+ xcell = clstr_temp_xcell(icell)
+ ycell = clstr_temp_ycell(icell)
+ ecell = clstr_temp_ecell(icell)
+
+ xmom = xmom + (xcell-xcenter) * ecell / clstr_temp_esum
+ ymom = ymom + (ycell-ycenter) * ecell / clstr_temp_esum
+
+ bigcal_mid_clstr_ixcell(ncluster,icell) = icol
+ bigcal_mid_clstr_iycell(ncluster,icell) = irow
+ bigcal_mid_clstr_xcell(ncluster,icell) = xcell
+ bigcal_mid_clstr_ycell(ncluster,icell) = ycell
+ bigcal_mid_clstr_ecell(ncluster,icell) = ecell
+ enddo
+
+ bigcal_mid_clstr_xmom(ncluster) = xmom
+ bigcal_mid_clstr_ymom(ncluster) = ymom
+
+ if(bdebug_print_clusters.ne.0) call b_print_cluster(3,ncluster,ABORT,err)
+
+ endif
+ else if(ixmax.eq.1.or.ixmax.eq.bigcal_rcs_nx) then
+ bigcal_mid_bad_clstr_flag(ncluster) = 1
+ !write(*,*) 'edge max! ncluster = ',ncluster
+ endif
+ endif
+
+ 334 continue
+
+ if((.not.found_cluster).and.ncluster.eq.0) then
+ bigcal_mid_no_clstr_why = bigcal_mid_bad_clstr_flag(0)
+ endif
+
+ if(found_cluster .and. ncluster.lt.bigcal_mid_nclstr_max) then
+ goto 301
+ endif
+
+ bigcal_mid_nclstr = ncluster
+
+ if(bigcal_prot_nclstr.eq.0.and.bigcal_rcs_nclstr.eq.0.and.
+ $ bigcal_mid_nclstr.eq.0) then
+ bigcal_all_no_clstr_why = max(bigcal_prot_no_clstr_why,
+ $ bigcal_rcs_no_clstr_why,bigcal_mid_no_clstr_why)
+ else
+ bigcal_all_no_clstr_why = 0
+ endif
+
+ return
+ end
diff --git a/BTRACKING/b_generate_geometry.f b/BTRACKING/b_generate_geometry.f
new file mode 100755
index 0000000..7d4ca50
--- /dev/null
+++ b/BTRACKING/b_generate_geometry.f
@@ -0,0 +1,102 @@
+ subroutine b_generate_geometry
+
+ implicit none
+ save
+
+ include 'bigcal_data_structures.cmn'
+ include 'bigcal_geometry.cmn'
+
+ integer ix,iy,icell,ixmin
+
+ real xshift,yshift,xsize,ysize,xcenter,ycenter,xcell,diff
+ real mindiff
+
+ xshift = BIGCAL_PROT_SHIFT_X
+ yshift = BIGCAL_PROT_SHIFT_Y + bigcal_height
+
+ xsize = BIGCAL_PROT_SIZE_X
+ ysize = BIGCAL_PROT_SIZE_Y
+
+
+ do ix=1,BIGCAL_PROT_NX
+ do iy=1,BIGCAL_PROT_NY
+ icell = ix + (iy-1)*BIGCAL_PROT_NX
+ xcenter = xshift + (ix - .5)*xsize
+ ycenter = yshift + (iy - .5)*ysize
+
+ BIGCAL_PROT_XCENTER(icell) = xcenter
+ BIGCAL_PROT_YCENTER(icell) = ycenter
+ bigcal_all_xcenter(icell) = xcenter
+ bigcal_all_ycenter(icell) = ycenter
+ enddo
+ enddo
+
+ xshift = BIGCAL_RCS_SHIFT_X
+ yshift = BIGCAL_RCS_SHIFT_Y + bigcal_height
+
+ xsize = BIGCAL_RCS_SIZE_X
+ ysize = BIGCAL_RCS_SIZE_Y
+
+ do ix=1,BIGCAL_RCS_NX
+ do iy=1,BIGCAL_RCS_NY
+ icell = ix + (iy-1)*BIGCAL_RCS_NX
+ xcenter = xshift + (ix - .5)*xsize
+ ycenter = yshift + (iy - .5)*ysize
+
+ BIGCAL_RCS_XCENTER(icell) = xcenter
+ BIGCAL_RCS_YCENTER(icell) = ycenter
+
+ bigcal_all_xcenter(icell + bigcal_prot_maxhits) = xcenter
+ bigcal_all_ycenter(icell + bigcal_prot_maxhits) = ycenter
+ enddo
+ enddo
+
+ do ix=1,bigcal_prot_nx
+
+ mindiff = 1000000.
+ ixmin = 0
+
+ xcenter = bigcal_prot_xcenter(ix + 31*32)
+ do icell=1,30
+ xcell = bigcal_rcs_xcenter(icell)
+ diff = xcenter - xcell
+ if(abs(diff).lt.mindiff) then
+ mindiff = diff
+ ixmin = icell
+ endif
+ enddo
+
+ if(mindiff.lt.1000000..and.ixmin.ge.1.and.ixmin.le.30) then
+ bigcal_ixclose_prot(ix) = ixmin
+ else
+ write(*,*) 'warning: could not find ixclose_prot, ix = ',ix
+ write(*,*) 'something probably wrong with geometry database'
+ bigcal_ixclose_prot(ix) = min(max(ix,1),30)
+ endif
+ enddo
+
+ do ix=1,bigcal_rcs_nx
+
+ mindiff = 1000000.
+ ixmin = 0
+
+ xcenter = bigcal_rcs_xcenter(ix)
+ do icell=1,32
+ xcell = bigcal_prot_xcenter(icell + 31*32)
+ diff = xcenter - xcell
+ if(abs(diff).lt.mindiff) then
+ mindiff = diff
+ ixmin = icell
+ endif
+ enddo
+ if(mindiff.lt.1000000..and.ixmin.ge.1.and.ixmin.le.32) then
+ bigcal_ixclose_rcs(ix) = ixmin
+ else
+ write(*,*) 'warning: could not find ixclose_rcs, ix = ',ix
+ write(*,*) 'something probably wrong with geometry database'
+ bigcal_ixclose_rcs(ix) = min(max(ix,1),32)
+ endif
+ enddo
+
+ return
+ end
diff --git a/BTRACKING/b_guess_ecell.f b/BTRACKING/b_guess_ecell.f
new file mode 100644
index 0000000..bcc2eca
--- /dev/null
+++ b/BTRACKING/b_guess_ecell.f
@@ -0,0 +1,151 @@
+ subroutine b_guess_ecell(nbad,maxnbad,rowbad,colbad,cellbad,eguess,E,X,Y)
+
+ implicit none
+ save
+
+ include 'bigcal_data_structures.cmn'
+ include 'bigcal_shower_parms.cmn'
+ include 'bigcal_geometry.cmn'
+
+ integer nbad
+ integer maxnbad
+ integer rowbad(maxnbad)
+ integer colbad(maxnbad)
+ integer cellbad(maxnbad)
+
+ integer i
+
+ real eguess(maxnbad)
+
+ real cuteguess
+
+ real shower_fit_symm
+ real shower_fit_asymm
+
+ real E,X,Y
+
+ real xcell,ycell,xdiff,ydiff
+
+ do i=1,nbad
+
+ xcell = bigcal_all_xcenter(cellbad(i))
+ ycell = bigcal_all_ycenter(cellbad(i))
+
+ xdiff = xcell - X
+ ydiff = ycell - Y
+
+* normalize xdiff and ydiff to the cell size, because the shower shape fit
+* is based on the ratio of distance to cell size
+
+ if(rowbad(i).le.32) then
+ xdiff = xdiff / bigcal_prot_size_x
+ ydiff = ydiff / bigcal_prot_size_y
+ else
+ xdiff = xdiff / bigcal_rcs_size_x
+ ydiff = ydiff / bigcal_rcs_size_y
+ endif
+
+ if(bigcal_shape_opt.eq.1) then
+ eguess(i) = E*shower_fit_asymm(xdiff,ydiff)
+
+c$$$ write(*,*) 'guessed bad channel energy:',
+c$$$ $ '(row,col,Eguess)=(',rowbad(i),',',colbad(i),
+c$$$ $ ',',eguess(i),')'
+
+ if(cellbad(i).le.1024) then
+ cuteguess = b_cell_cut_prot
+ else
+ cuteguess = b_cell_cut_rcs
+ endif
+
+ if(eguess(i).lt.cuteguess) eguess(i) = 0.
+
+ bigcal_all_good_det(cellbad(i)) = eguess(i)
+ if(rowbad(i).le.32) then
+ bigcal_prot_good_det(cellbad(i)) = eguess(i)
+ else
+ bigcal_rcs_good_det(cellbad(i)-1024) = eguess(i)
+ endif
+ else
+ eguess(i) = E*shower_fit_symm(xdiff,ydiff)
+
+c$$$ write(*,*) 'guessed bad channel energy'//
+c$$$ $ '(row,col,Eguess)=(',rowbad(i),',',colbad(i),
+c$$$ $ ',',eguess(i),')'
+
+ if(cellbad(i).le.1024) then
+ cuteguess = b_cell_cut_prot
+ else
+ cuteguess = b_cell_cut_rcs
+ endif
+
+ if(eguess(i).lt.cuteguess) eguess(i) = 0.
+
+ bigcal_all_good_det(cellbad(i)) = eguess(i)
+ if(rowbad(i).le.32) then
+ bigcal_prot_good_det(cellbad(i)) = eguess(i)
+ else
+ bigcal_rcs_good_det(cellbad(i)-1024) = eguess(i)
+ endif
+ endif
+ enddo
+
+ return
+ end
+
+ real function gs(x,y,a,b)
+
+ real x,y,a,b
+
+ real PI
+ data PI/3.1415926536/
+
+ gs = a / sqrt(2.*PI) * (atan(x/b) + atan(y/b) +
+ $ atan(x*y/b/sqrt(b**2 + x**2 + y**2) ) )
+
+ end
+
+ real function ga(x,y,a,bx,by)
+
+ real x,y,a,bx,by
+ real PI
+ data PI/3.1415926536/
+
+ ga = a / sqrt(2.*PI) * (atan(x/bx) + atan(y/by) +
+ $ atan(x*y/bx/by/sqrt(1. + (x/bx)**2 + (y/by)**2) ) )
+
+ end
+
+ real function shower_fit_symm(x,y)
+
+ real x,y
+ real a,b,d,gs
+ include 'bigcal_data_structures.cmn'
+ include 'bigcal_shower_parms.cmn'
+
+ a = bigcal_sshape_a ! height parameter
+ b = bigcal_sshape_b ! width parameter
+c d = bigcal_sshape_d ! cell size parameter
+ d = 1.0
+ shower_fit_symm = gs(x+d/2.,y+d/2.,a,b) + gs(x-d/2.,y-d/2.,a,b)
+ $ - gs(x+d/2.,y-d/2.,a,b) - gs(x-d/2.,y+d/2.,a,b)
+
+ end
+
+ real function shower_fit_asymm(x,y)
+
+ real x,y
+ real a,bx,by,d,ga
+ include 'bigcal_data_structures.cmn'
+ include 'bigcal_shower_parms.cmn'
+
+ a = bigcal_ashape_a ! height parameter
+ bx = bigcal_ashape_bx ! width x parameter
+ by = bigcal_ashape_by ! width y parameter
+c d = bigcal_ashape_d ! cell size parameter
+ d = 1.0
+
+ shower_fit_asymm = ga(x+d/2.,y+d/2.,a,bx,by) + ga(x-d/2.,y-d/2.,a,bx,by)
+ $ - ga(x+d/2.,y-d/2.,a,bx,by) - ga(x-d/2.,y+d/2.,a,bx,by)
+
+ end
diff --git a/BTRACKING/b_init_bad_list.f b/BTRACKING/b_init_bad_list.f
new file mode 100644
index 0000000..c01714e
--- /dev/null
+++ b/BTRACKING/b_init_bad_list.f
@@ -0,0 +1,81 @@
+ subroutine b_init_bad_list(abort,err)
+
+ implicit none
+ save
+
+ character*15 here
+ parameter(here='b_init_bad_list')
+
+ logical abort
+ character*(*) err
+
+ character*80 filename
+
+ integer*4 iochan
+ integer*4 row,col,nbad,cell,i
+
+ include 'bigcal_data_structures.cmn'
+ include 'bigcal_gain_parms.cmn'
+ include 'bigcal_filenames.cmn'
+ include 'bigcal_bypass_switches.cmn'
+
+ abort=.false.
+ err=' '
+
+ nbad = 0
+
+ filename = b_bad_chan_list_filename
+
+c get any free io channel
+ call g_IO_control(iochan,'ANY',abort,err)
+
+ open(unit=iochan,file=filename,form='formatted',status='old',err=101)
+
+ 8 read(iochan,fmt=*,end=102,err=102) row,col
+
+ if((row.ge.1.and.row.le.32.and.col.ge.1.and.col.le.32).or.
+ $ (row.ge.33.and.row.le.56.and.col.ge.1.and.col.le.30)) then
+ nbad = nbad + 1
+ if(row.le.32) then
+ cell = col + 32*(row-1)
+ bigcal_prot_cfac(cell) = 0.
+c set a high threshold so that hits from the bad channel list will not make it into
+c the good hit array by accident
+ bigcal_prot_adc_threshold(cell) = 10000.
+ else
+ cell = col + 30*(row-33) + 1024
+ bigcal_rcs_cfac(cell-1024) = 0.
+c set a high threshold so that hits from the bad channel list will not make it into
+c the good hit array by accident
+ bigcal_rcs_adc_threshold(cell) = 10000.
+
+ endif
+
+ bigcal_bad_chan_list(cell) = .true.
+
+ goto 8
+ else
+ write(*,*) 'invalid row and/or column. Will not read any '//
+ $ 'more channels'
+ goto 102
+ endif
+
+ 101 write(*,*) 'could not open bad channel list file, list not '//
+ $ 'initialized!'
+ b_use_bad_chan_list = 0
+
+ call g_IO_control(iochan,'FREE',abort,err)
+ close(iochan)
+
+ return
+
+ 102 write(*,*) 'finished reading BigCal bad channel list'
+ write(*,*) 'nbad=',nbad
+
+ if(nbad.eq.0) b_use_bad_chan_list = 0
+
+ call g_IO_control(iochan,'FREE',abort,err)
+ close(iochan)
+
+ return
+ end
diff --git a/BTRACKING/b_init_gain.f b/BTRACKING/b_init_gain.f
new file mode 100755
index 0000000..7a971c6
--- /dev/null
+++ b/BTRACKING/b_init_gain.f
@@ -0,0 +1,97 @@
+ subroutine b_init_gain(ABORT,err)
+
+ implicit none
+ save
+
+ character*11 here
+ parameter(here='b_init_gain')
+
+ logical ABORT
+ character*(*) err
+
+ include 'bigcal_data_structures.cmn'
+ include 'bigcal_gain_parms.cmn'
+
+ integer ix,iy,icell,ig64,ih64,ilogic,i,j
+ real gainold,gainnew
+
+ abort=.false.
+ err=' '
+c check whether user has defined bigcal_prot_min_peds:
+ bigcal_prot_min_peds=500
+ bigcal_rcs_min_peds=500
+ bigcal_trig_min_peds=500
+
+c initialize threshold limits: define sensible values if the user hasn't
+
+c write(*,*) 'bigcal_prot_cfac=',bigcal_prot_cfac
+c write(*,*) 'bigcal_rcs_cfac=',bigcal_rcs_cfac
+
+c initialize ped_limit:
+ do i=1,bigcal_all_maxhits
+ if(i.le.1024) then
+ bigcal_prot_ped_limit(i) = 1000
+
+
+ else
+c write(*,*) 'rcs ped limit(',i-1024,')=',bigcal_rcs_ped_limit(i-1024)
+
+ bigcal_rcs_ped_limit(i-1024) = 1000
+
+c write(*,*) 'rcs ped limit(',i-1024,')=',bigcal_rcs_ped_limit(i-1024)
+ endif
+ enddo
+c trigger ADCs have WIDE pedestals (summing effect of all the noise)
+ do i=1,bigcal_atrig_maxhits
+ bigcal_trig_ped_limit(i) = 1200
+ bigcal_trig_cfac(i) = 1. ! don't use anything other than 1. for the trigger
+ bigcal_trig_gain_cor(i) = 1.
+ enddo
+
+c uncomment the following if you want to override the param file with some
+c values.
+
+c$$$ do i=1,bigcal_prot_maxhits
+c$$$ bigcal_prot_cfac(i) = 1./950.79
+c$$$ enddo
+c$$$ do i=1,bigcal_rcs_maxhits
+c$$$ bigcal_rcs_cfac(i) = 1./911.57
+c$$$ enddo
+
+c calculate gain correction factors. hopefully last and current gain factors
+c are correctly read in from CTP parm files
+
+c$$$ do ix=1,BIGCAL_PROT_NX
+c$$$ do iy=1,BIGCAL_PROT_NY
+c$$$ icell=ix + (iy-1)*BIGCAL_PROT_NX
+c$$$
+c$$$ gainold = bigcal_prot_gain_last(icell)
+c$$$ gainnew = bigcal_prot_gain_now(icell)
+c$$$
+c$$$ bigcal_prot_gain_cor(icell) = gainnew / gainold
+c$$$
+c$$$ enddo
+c$$$ enddo
+c$$$
+c$$$ do ix=1,BIGCAL_RCS_NX
+c$$$ do iy=1,BIGCAL_RCS_NY
+c$$$ icell = ix + (iy-1)*BIGCAL_RCS_NX
+c$$$
+c$$$ gainold = bigcal_rcs_gain_last(icell)
+c$$$ gainnew = bigcal_rcs_gain_now(icell)
+c$$$
+c$$$ bigcal_rcs_gain_cor(icell) = gainnew / gainold
+c$$$
+c$$$ enddo
+c$$$ enddo
+c$$$
+c$$$ do ilogic=1,BIGCAL_ATRIG_MAXHITS
+c$$$ gainold = bigcal_trig_gain_last(ilogic)
+c$$$ gainnew = bigcal_trig_gain_now(ilogic)
+c$$$ bigcal_trig_gain_cor(ilogic) = gainnew / gainold
+c$$$ enddo
+
+c Decided gain_last, gain_now are redundant. Just use cfac and gain_cor!!!!
+
+ return
+ end
diff --git a/BTRACKING/b_init_histid.f b/BTRACKING/b_init_histid.f
new file mode 100755
index 0000000..7e8548d
--- /dev/null
+++ b/BTRACKING/b_init_histid.f
@@ -0,0 +1,187 @@
+ subroutine b_init_histid(ABORT,err)
+
+ implicit none
+ save
+
+ character*13 here
+ parameter(here='b_init_histid')
+
+ logical ABORT
+ character*(*) err
+
+ external thgetid
+ integer*4 thgetid
+ integer i,j,irow,tens,ones,itens,iones,jtens,jones,icell
+
+ include 'bigcal_data_structures.cmn'
+ include 'bigcal_gain_parms.cmn'
+ include 'bigcal_shower_parms.cmn'
+ include 'bigcal_tof_parms.cmn'
+ include 'bigcal_geometry.cmn'
+ include 'bigcal_bypass_switches.cmn'
+ include 'bigcal_hist_id.cmn'
+
+ character*10 histname
+
+c For now, don't do anything here: I don't necessarily want to do
+c hard-coded histograms. I would like to use CTP. Will come back later
+c if this proves more convenient
+c It's later, I'm back. CTP histos on their own aren't terribly useful,
+c need to hardcode some:
+
+ bid_bcal_row = thgetid('bcal_row')
+ bid_bcal_col = thgetid('bcal_col')
+ bid_bcal_rowcol = thgetid('bcal_rowcol')
+ bid_bcal_tadcvsum64 = thgetid('bcal_tadc_v_sum64')
+ bid_bcal_trchvmax64 = thgetid('bcal_trch_v_max64')
+ bid_bcal_ttdcvtdc = thgetid('bcal_ttdc_v_tdc')
+ bid_bcal_prot_eff = thgetid('bcal_prot_eff')
+ bid_bcal_rcs_eff = thgetid('bcal_rcs_eff')
+
+ bid_bcal_ixclust = thgetid('bcal_ixclust')
+ bid_bcal_iyclust = thgetid('bcal_iyclust')
+ bid_bcal_rowcolclust = thgetid('bcal_rowcolclust')
+
+ bid_bcal_eclust = thgetid('bcal_eclust')
+
+ bid_bcal_ncellclst = thgetid('bcal_ncellclust')
+ bid_bcal_nxclust = thgetid('bcal_nxclust')
+ bid_bcal_nyclust = thgetid('bcal_nyclust')
+
+ bid_bcal_xmom = thgetid('bcal_xmoment')
+ bid_bcal_ymom = thgetid('bcal_ymoment')
+ bid_bcal_nxny = thgetid('bcal_nxny')
+
+ bid_bcal_tmean = thgetid('bcal_tmean')
+ bid_bcal_trms = thgetid('bcal_trms')
+
+ bid_bcal_xclust = thgetid('bcal_xclust')
+ bid_bcal_yclust = thgetid('bcal_yclust')
+ bid_bcal_xy = thgetid('bcal_xy')
+ bid_bcal_exy = thgetid('bcal_exy')
+ bid_bcal_theta = thgetid('bcal_thetaclst')
+ bid_bcal_phi = thgetid('bcal_phiclst')
+
+ bid_bcal_ped_mean_prot = thgetid('bcal_ped_mean_prot')
+ bid_bcal_ped_mean_rcs = thgetid('bcal_ped_mean_rcs')
+ bid_bcal_ped_mean_trig = thgetid('bcal_ped_mean_trig')
+ bid_bcal_ped_rms_prot = thgetid('bcal_ped_rms_prot')
+ bid_bcal_ped_rms_rcs = thgetid('bcal_ped_rms_rcs')
+ bid_bcal_ped_rms_trig = thgetid('bcal_ped_rms_trig')
+ bid_bcal_pedw_prot = thgetid('bcal_pedw_prot')
+ bid_bcal_pedw_rcs = thgetid('bcal_pedw_rcs')
+ bid_bcal_pedw_trig = thgetid('bcal_pedw_trig')
+ bid_bcal_raw_photodiode = thgetid('bcal_raw_photodiode')
+
+ do i=1,32
+ itens = i/10
+ iones = mod(i,10)
+ do j=1,32
+ jtens = j/10
+ jones = mod(j,10)
+
+ icell = j + 32*(i-1)
+
+ histname='ADC'//char(itens+ichar('0'))//
+ $ char(iones+ichar('0'))//char(jtens+ichar('0'))//
+ $ char(jones+ichar('0'))
+ bid_badc(icell) = thgetid(histname)
+ enddo
+ enddo
+
+ do i=33,56
+ itens = i/10
+ iones = mod(i,10)
+ do j=1,30
+ jtens = j/10
+ jones = mod(j,10)
+
+ icell = 1024 + j + 30*(i-33)
+
+ histname='ADC'//char(itens+ichar('0'))//
+ $ char(iones+ichar('0'))//char(jtens+ichar('0'))//
+ $ char(jones+ichar('0'))
+ bid_badc(icell) = thgetid(histname)
+ enddo
+ enddo
+
+ do i=1,56
+ tens = i/10
+ ones = mod(i,10)
+ histname = 'TDC'//char(tens + ichar('0'))//
+ $ char(ones + ichar('0'))//'A'
+ bid_btdc(1 + 4*(i-1) ) = thgetid(histname)
+ histname = 'TDC'//char(tens + ichar('0'))//
+ $ char(ones + ichar('0'))//'B'
+ bid_btdc(2 + 4*(i-1) ) = thgetid(histname)
+ histname = 'TDC'//char(tens + ichar('0'))//
+ $ char(ones + ichar('0'))//'C'
+ bid_btdc(3 + 4*(i-1) ) = thgetid(histname)
+ histname = 'TDC'//char(tens + ichar('0'))//
+ $ char(ones + ichar('0'))//'D'
+ bid_btdc(4 + 4*(i-1) ) = thgetid(histname)
+
+c$$$ histname = 'TWALK'//char(tens + ichar('0'))//
+c$$$ $ char(ones + ichar('0'))//'A'
+c$$$ bid_btimewalk(1 + 4*(i-1) ) = thgetid(histname)
+c$$$ histname = 'TWALK'//char(tens + ichar('0'))//
+c$$$ $ char(ones + ichar('0'))//'B'
+c$$$ bid_btimewalk(2 + 4*(i-1) ) = thgetid(histname)
+c$$$ histname = 'TWALK'//char(tens + ichar('0'))//
+c$$$ $ char(ones + ichar('0'))//'C'
+c$$$ bid_btimewalk(3 + 4*(i-1) ) = thgetid(histname)
+c$$$ histname = 'TWALK'//char(tens + ichar('0'))//
+c$$$ $ char(ones + ichar('0'))//'D'
+c$$$ bid_btimewalk(4 + 4*(i-1) ) = thgetid(histname)
+ enddo
+
+ do i=1,21
+ irow = 1 + 3*(i-1)
+ tens = irow/10
+ ones = mod(irow,10)
+
+ histname = 'TTDC'//char(tens + ichar('0'))//
+ $ char(ones + ichar('0'))//'AB'
+c write(*,*) 'histname=',histname
+ bid_bttdc(1 + 2*(i-1)) = thgetid(histname)
+
+ histname = 'TTDC'//char(tens + ichar('0'))//
+ $ char(ones + ichar('0'))//'CD'
+c write(*,*) 'histname=',histname
+ bid_bttdc(2 + 2*(i-1)) = thgetid(histname)
+
+ if(i.lt.20) then
+ histname = 'TADC'//char(tens+ichar('0'))//
+ $ char(ones+ichar('0'))//'AB'
+ bid_btadc(1 + 2*(i-1)) = thgetid(histname)
+ histname = 'TADC'//char(tens+ichar('0'))//
+ $ char(ones+ichar('0'))//'CD'
+ bid_btadc(2 + 2*(i-1)) = thgetid(histname)
+ endif
+
+ enddo
+
+ bid_bcal_empty = thgetid('bcal_empty')
+ bid_bcal_small = thgetid('bcal_small')
+ bid_bcal_cfac_old = thgetid('bcal_cfac_old')
+ bid_bcal_cfac_new = thgetid('bcal_cfac_new')
+ bid_bcal_cfac_dist = thgetid('bcal_cfac_dist')
+ bid_bcal_oldxnew = thgetid('bcal_oldxnew')
+
+ bid_bcal_row8 = thgetid('bcal_row8')
+ bid_bcal_col8 = thgetid('bcal_col8')
+ bid_bcal_row8vscol8 = thgetid('bcal_row8vscol8')
+ bid_bcal_trow64 = thgetid('bcal_trow64')
+ bid_bcal_tcol64 = thgetid('bcal_tcol64')
+ bid_bcal_trow64vstcol64 = thgetid('bcal_trow64vstcol64')
+ bid_bcal_arow64 = thgetid('bcal_arow64')
+ bid_bcal_acol64 = thgetid('bcal_acol64')
+ bid_bcal_arow64vsacol64 = thgetid('bcal_arow64vsacol64')
+ bid_bcal_ttchanvstachan = thgetid('bcal_ttchanvstachan')
+ bid_bcal_ttchanvstgroup = thgetid('bcal_ttchanvstgroup')
+
+ abort=.false.
+ err=' '
+
+ return
+ end
diff --git a/BTRACKING/b_init_physics.f b/BTRACKING/b_init_physics.f
new file mode 100755
index 0000000..da07556
--- /dev/null
+++ b/BTRACKING/b_init_physics.f
@@ -0,0 +1,31 @@
+ subroutine b_init_physics(ABORT,err)
+
+ implicit none
+ save
+
+ character*14 here
+ parameter(here='b_init_physics')
+
+ logical ABORT
+ character*(*) err
+
+ include 'gen_data_structures.cmn'
+ include 'bigcal_data_structures.cmn'
+ include 'gen_constants.par'
+ include 'gen_units.par'
+
+ abort=.false.
+ err=' '
+
+c BIGCAL_HEIGHT = 0.
+ BIGCAL_THETA_RAD = BIGCAL_THETA_DEG * tt / 180.
+
+ BIGCAL_SINTHETA = sin(BIGCAL_THETA_RAD)
+ BIGCAL_COSTHETA = cos(BIGCAL_THETA_RAD)
+
+c that's all for now
+
+ return
+ end
+
+
diff --git a/BTRACKING/b_init_shower.f b/BTRACKING/b_init_shower.f
new file mode 100755
index 0000000..d54cd55
--- /dev/null
+++ b/BTRACKING/b_init_shower.f
@@ -0,0 +1,83 @@
+ subroutine b_init_shower(ABORT,err)
+
+ implicit none
+ save
+
+ character*13 here
+ parameter(here='b_init_shower')
+
+ logical ABORT
+ character*(*) err
+
+ integer irow,icol,ipar,icell,j,i
+
+ include 'bigcal_data_structures.cmn'
+ include 'bigcal_shower_parms.cmn'
+ include 'bigcal_bypass_switches.cmn'
+
+ ABORT=.false.
+ err=' '
+
+c don't do anything for now...
+c boy do I hope I can get this CTP parm stuff working!!!!
+
+c$$$ write(*,*) 'pxdet_par = ',bigcal_pxdet_par
+c$$$ write(*,*) 'pydet_par = ',bigcal_pydet_par
+c$$$ write(*,*) 'rxdet_par = ',bigcal_rxdet_par
+c$$$ write(*,*) 'rydet_par = ',bigcal_rydet_par
+
+ do icol=1,bigcal_prot_nx
+ do ipar=1,bigcal_shower_npar
+ icell = ipar + (icol-1)*bigcal_shower_npar
+ bigcal_prot_xpar(icol,ipar) = bigcal_pxdet_par(icell)
+ enddo
+ enddo
+
+ do irow=1,bigcal_prot_ny
+ do ipar=1,bigcal_shower_npar
+ icell = ipar + (irow-1)*bigcal_shower_npar
+ bigcal_prot_ypar(irow,ipar) = bigcal_pydet_par(icell)
+ enddo
+ enddo
+
+ do icol=1,bigcal_rcs_nx
+ do ipar=1,bigcal_shower_npar
+ icell = ipar + (icol-1)*bigcal_shower_npar
+ bigcal_rcs_xpar(icol,ipar) = bigcal_rxdet_par(icell)
+ enddo
+ enddo
+
+ do irow=1,bigcal_rcs_ny
+ do ipar=1,bigcal_shower_npar
+ icell = ipar + (irow-1)*bigcal_shower_npar
+ bigcal_rcs_ypar(irow,ipar) = bigcal_rydet_par(icell)
+ enddo
+ enddo
+
+c$$$ do ipar=1,6
+c$$$ write(*,*) bigcal_prot_ypar(32,ipar)
+c$$$ enddo
+
+c$$$ write(*,*) 'prot_xpar = ',bigcal_prot_xpar
+c$$$ write(*,*) 'prot_ypar = ',bigcal_prot_ypar
+c$$$ write(*,*) 'rcs_xpar = ',bigcal_rcs_xpar
+c$$$ write(*,*) 'rcs_ypar = ',bigcal_rcs_ypar
+
+ if(b_recon_using_map.ne.0) then
+ do i=1,28
+ do j=1,bigcal_xmap_nbin(i)
+ bigcal_xmap_xfrac(i,j) = bigcal_xmap_frac(j+
+ $ bigcal_xmap_nbin(i)*(i-1))
+ enddo
+ enddo
+
+ do i=1,28
+ do j=1,bigcal_ymap_nbin(i)
+ bigcal_ymap_yfrac(i,j) = bigcal_ymap_frac(j+
+ $ bigcal_ymap_nbin(i)*(i-1))
+ enddo
+ enddo
+ endif
+
+ return
+ end
diff --git a/BTRACKING/b_init_tof.f b/BTRACKING/b_init_tof.f
new file mode 100755
index 0000000..5dbf264
--- /dev/null
+++ b/BTRACKING/b_init_tof.f
@@ -0,0 +1,69 @@
+ subroutine b_init_tof(ABORT,err)
+
+ implicit none
+ save
+
+ character*10 here
+ parameter(here='b_init_tof')
+
+ logical ABORT
+ character*(*) err
+
+ real Eprime_central,M,me,gamma,c,ebeam
+
+ double precision beta
+
+ integer*4 i
+
+ parameter(M=.938272)
+ parameter(me=.511e-3)
+ parameter(c=30.)
+
+ include 'bigcal_data_structures.cmn'
+ include 'bigcal_tof_parms.cmn'
+ include 'gen_data_structures.cmn'
+c include 'bigcal_geometry.cmn'
+
+c do nothing for now. Hopefully all variables are correctly read in from CTP parm
+c files
+c set sensible values for timing parameters if they have not been set yet:
+c just make sure that bigcal_end_time is bigger than bigcal_window_center!
+
+ if(bigcal_end_time.le.bigcal_window_center) then
+ bigcal_end_time = bigcal_window_center + 500.
+ endif
+
+ if(gebeam .eq. 0.) then
+ ebeam = gpbeam
+ else
+ ebeam = gebeam
+ endif
+
+ Eprime_central = gpbeam / (1. + gpbeam/M * (1. - bigcal_costheta) )
+
+ write(*,*) 'BigCal central Eprime =',Eprime_central
+
+ gamma = Eprime_central / me
+
+ beta = sqrt(max(0.,1. - 1./gamma**2))
+
+ bigcal_tof_central = bigcal_r_tgt / (beta*c) ! in ns
+
+ do i=1,bigcal_max_tdc
+ bigcal_g8_time_offset(i) = bigcal_g8_time_offset(i) +
+ $ b_trig_offset
+ enddo
+
+ do i=1,bigcal_ttrig_maxgroups
+ bigcal_g64_time_offset(i) = bigcal_g64_time_offset(i) +
+ $ b_trig_offset
+ enddo
+
+
+ write(*,*) 'bigcal central tof = ',bigcal_tof_central
+
+ ABORT=.false.
+ err = ' '
+
+ return
+ end
diff --git a/BTRACKING/b_matrix_accum.f b/BTRACKING/b_matrix_accum.f
new file mode 100644
index 0000000..ea5fbb4
--- /dev/null
+++ b/BTRACKING/b_matrix_accum.f
@@ -0,0 +1,162 @@
+ subroutine b_matrix_accum(abort,err)
+
+ implicit none
+ save
+
+ character*14 here
+ parameter(here='b_matrix_accum')
+
+ logical abort
+ character*(*) err
+
+ include 'bigcal_data_structures.cmn'
+ include 'bigcal_tof_parms.cmn'
+ include 'gen_run_info.cmn'
+ include 'gen_event_info.cmn'
+ include 'bigcal_bypass_switches.cmn'
+ include 'b_ntuple.cmn'
+ include 'gep_data_structures.cmn'
+ include 'gen_data_structures.cmn'
+ include 'hms_data_structures.cmn'
+
+ integer irow,icol,jrow,jcol,icell,jcell
+ integer best,ihit,jhit
+ real Ee,ei,ej
+
+ real PI
+ parameter(PI=3.14159265359)
+
+ real Mp
+ parameter(Mp=.938272)
+ abort=.false.
+ err=' '
+
+c
+c$$$ mintdiff = 0.
+c$$$
+c$$$ if(ntrigb.gt.0) then
+c$$$ do i=1,ntrigb
+c$$$ if(i.eq.1.or.abs(gep_btime(i)-gep_btime_elastic).lt.mintdiff) then
+c$$$ btrigt = gep_btime(i)
+c$$$ mintdiff = abs(gep_btime(i)-gep_btime_elastic)
+c$$$ endif
+c$$$ enddo
+c$$$ else
+c$$$ btrigt = gep_btime_elastic
+c$$$ endif
+c$$$
+c$$$ breftime = bigcal_end_time - btrigt
+
+
+ if(gen_bigcal_mc.ne.0.and.gen_bigcal_mc.ne.3) then
+c for monte carlo-based calibration we are happy with using only events where there is one cluster
+c corresponding to one electron
+ if(nvtrk_mc.eq.1.and.pid_mc(1).eq.3.and.bigcal_all_nclstr.eq.1)
+ $ then
+c check rough position agreement (cell positions only! reconstructed positions may be bad)
+ if(abs(bigcal_all_clstr_xcell(1,1)-xgeant(1)).le.10..and.
+ $ abs(bigcal_all_clstr_ycell(1,1)-ygeant(1)).le.10) then
+ Ee = egeant(1)
+
+ bigcal_nmatr_event = bigcal_nmatr_event + 1
+
+ do ihit=1,bigcal_all_clstr_ncell(1)
+ irow = bigcal_all_clstr_iycell(1,ihit)
+ icol = bigcal_all_clstr_ixcell(1,ihit)
+ if(irow.le.bigcal_prot_ny) then
+ icell = icol + bigcal_prot_nx*(irow-1)
+ else
+ icell = icol + bigcal_rcs_nx*(irow-1-bigcal_prot_ny)
+ $ + bigcal_prot_maxhits
+ endif
+
+ ei = bigcal_all_clstr_ecell(1,ihit)
+
+ bigcal_vector(icell) = bigcal_vector(icell) + ei / Ee
+
+ do jhit=1,bigcal_all_clstr_ncell(1)
+ jrow = bigcal_all_clstr_iycell(1,jhit)
+ jcol = bigcal_all_clstr_ixcell(1,jhit)
+ if(jrow.le.bigcal_prot_ny) then
+ jcell = jcol + bigcal_prot_nx*(jrow-1)
+ else
+ jcell = jcol + bigcal_rcs_nx*(jrow-1-bigcal_prot_ny)
+ $ + bigcal_prot_maxhits
+ endif
+
+ ej = bigcal_all_clstr_ecell(1,jhit)
+
+ bigcal_matrix(icell,jcell) = bigcal_matrix(icell,jcell)
+ $ + ei*ej / (Ee**2)
+ enddo
+ enddo
+ endif
+ endif
+ ! this was called from GEp reconstruction after selection of best track!!!
+c$$$ else if(bigcal_all_nclstr.ge.1.and.hsnum_fptrack.gt.0.and.
+c$$$ $ gen_event_trigtype(5).eq.1) then
+c Ee = gebeam - gep_Q2_H / (2.*.938272) ! E' = E - Q^2/2Mp, Q^2 as measured by HMS
+ else if(bigcal_all_nclstr.ge.1.and.hsnum_fptrack.gt.0) then
+ Ee = gep_E_electron
+ best = bigcal_itrack_best
+
+c check event selection cuts for calibration: dx, dy, and ctime:
+c also check elastic cut: This is crucial!!!
+c
+
+c write(*,*) 'track time =',bigcal_track_time(best)
+c$$$ write(*,*) 'dx,dy,dt,dpel,dth,dph=',bigcal_all_clstr_x(best)-gep_bx_expect_H,
+c$$$ $ bigcal_all_clstr_y(best)-gep_by_expect_H,bigcal_track_time(best)-bigcal_window_center,
+c$$$ $ (gep_p_proton-gep_pel_htheta)/hpcentral,bigcal_track_thetarad(best)-gep_etheta_expect_h,
+c$$$ $ bigcal_track_phirad(best)-gep_ephi_expect_h
+
+ if(abs(bigcal_all_clstr_x(best)-gep_bx_expect_H).lt.
+ $ gep_bcalib_cut_dx.and.abs(bigcal_all_clstr_y(best) -
+ $ gep_by_expect_H).lt.gep_bcalib_cut_dy.and.abs(
+ $ gep_ctime_hms-gep_ctime_cal).lt.gep_bcalib_cut_ctime.and.
+ $ abs(gep_pel_htheta-gep_p_proton)/hpcentral.lt.gep_bcalib_cut_elastic
+ $ .and.abs(bigcal_track_thetarad(best)-gep_etheta_expect_H).lt.
+ $ gep_bcalib_cut_theta.and.abs(bigcal_track_phirad(best)-
+ $ gep_ephi_expect_H+PI/2.).lt.gep_bcalib_cut_phi.and.
+ $ Ee.ge.gep_bcalib_cut_ehms(1).and.Ee.le.
+ $ gep_bcalib_cut_ehms(2)) then
+
+c write(*,*) 'writing event to calib. matrix'
+
+ bigcal_nmatr_event = bigcal_nmatr_event + 1
+
+ do ihit=1,bigcal_all_clstr_ncell(best)
+ irow = bigcal_all_clstr_iycell(best,ihit)
+ icol = bigcal_all_clstr_ixcell(best,ihit)
+ if(irow.le.bigcal_prot_ny) then
+ icell = icol + bigcal_prot_nx*(irow-1)
+ else
+ icell = icol + bigcal_rcs_nx*(irow-1-bigcal_prot_ny)
+ $ + bigcal_prot_maxhits
+ endif
+
+ ei = bigcal_all_clstr_ecell(best,ihit)
+
+ bigcal_vector(icell) = bigcal_vector(icell) + ei / Ee
+
+ do jhit=1,bigcal_all_clstr_ncell(best)
+ jrow = bigcal_all_clstr_iycell(best,jhit)
+ jcol = bigcal_all_clstr_ixcell(best,jhit)
+ if(jrow.le.bigcal_prot_ny) then
+ jcell = jcol + bigcal_prot_nx*(jrow-1)
+ else
+ jcell = jcol + bigcal_rcs_nx*(jrow-1-bigcal_prot_ny)
+ $ + bigcal_prot_maxhits
+ endif
+
+ ej = bigcal_all_clstr_ecell(best,jhit)
+
+ bigcal_matrix(icell,jcell) = bigcal_matrix(icell,jcell)
+ $ + ei*ej / (Ee**2)
+ enddo
+ enddo
+ endif
+ endif
+
+ return
+ end
diff --git a/BTRACKING/b_print_cluster.f b/BTRACKING/b_print_cluster.f
new file mode 100644
index 0000000..b818aab
--- /dev/null
+++ b/BTRACKING/b_print_cluster.f
@@ -0,0 +1,45 @@
+ subroutine b_print_cluster(iclust,ABORT,err)
+
+ implicit none
+ save
+
+ integer iclust,icell
+ logical ABORT
+ character*(*) err
+
+ include 'bigcal_data_structures.cmn'
+ include 'bigcal_bypass_switches.cmn'
+
+ character*15 here
+ parameter(here='b_print_cluster')
+
+ if(iclust.ge.1.and.iclust.le.bigcal_all_nclstr) then ! prot.
+ write(*,101) 'BigCal Cluster #',iclust
+ write(*,102) '(row,col) = (',bigcal_all_clstr_iymax(iclust),
+ $ ', ',bigcal_all_clstr_ixmax(iclust),')'
+ write(*,105) 'Etot = ',bigcal_all_clstr_etot(iclust)
+ write(*,103) 'xcellcenter = ',bigcal_all_clstr_xcell(iclust,1)
+ write(*,103) 'ycellcenter = ',bigcal_all_clstr_ycell(iclust,1)
+ write(*,104) 'xmoment = ',bigcal_all_clstr_xmom(iclust)
+ write(*,104) 'ymoment = ',bigcal_all_clstr_ymom(iclust)
+ write(*,106) 'ncell = ',bigcal_all_clstr_ncell(iclust)
+
+ do icell=1,bigcal_all_clstr_ncell(iclust)
+ write(*,107) 'Cell #',icell,', (row,col,E,bad?) = (',
+ $ bigcal_all_clstr_iycell(iclust,icell),', ',
+ $ bigcal_all_clstr_ixcell(iclust,icell),', ',
+ $ bigcal_all_clstr_ecell(iclust,icell),', ',
+ $ bigcal_clstr_bad_chan(iclust,icell),')'
+ enddo
+ endif
+
+ 101 format(A18,I10)
+ 102 format(A13,I2,A2,I2,A1)
+ 105 format(A7,F10.3)
+ 103 format(A14,F10.3)
+ 104 format(A10,F10.3)
+ 106 format(A8,I2)
+ 107 format(A6,I2,A25,I2,A2,I2,A2,F12.5,A2,L2,A1)
+
+ return
+ end
diff --git a/BTRACKING/b_print_raw_adc.f b/BTRACKING/b_print_raw_adc.f
new file mode 100755
index 0000000..f5f0c44
--- /dev/null
+++ b/BTRACKING/b_print_raw_adc.f
@@ -0,0 +1,56 @@
+ subroutine b_print_raw_adc(ABORT,err)
+
+ implicit none
+ save
+
+ character*16 here
+ parameter(here='b_print_raw_adc')
+
+ logical ABORT
+ character*(*) err
+
+ include 'bigcal_data_structures.cmn'
+ include 'bigcal_gain_parms.cmn'
+ include 'bigcal_bypass_switches.cmn'
+ include 'gen_event_info.cmn'
+
+ character*19 c1
+ parameter(c1='BIGCAL_PROT_NHIT = ')
+ character*7 c2
+ parameter(c2='IY = , ')
+ character*7 c3
+ parameter(c3='IX = , ')
+ character*10 c4
+ parameter(c4='raw adc = ')
+
+ character*18 c5
+ parameter(c5='BIGCAL_RCS_NHIT = ')
+
+ integer j
+
+ ABORT=.false.
+ err = ' '
+ if(BIGCAL_PROT_NHIT.gt.0) then
+ write(bluno,99) 'gen_event_id_number=',gen_event_id_number
+ write(bluno,100) c1,BIGCAL_PROT_NHIT
+ write(bluno,101) c2,c3,c4
+ write(bluno,102)
+ $ (BIGCAL_PROT_IY(j),BIGCAL_PROT_IX(j),
+ $ BIGCAL_PROT_ADC_RAW(j),j=1,BIGCAL_PROT_NHIT)
+ endif
+ if(BIGCAL_RCS_NHIT.gt.0) then
+ write(bluno,99) 'gen_event_id_number=',gen_Event_id_number
+ write(bluno,103) c5,BIGCAL_RCS_NHIT
+ write(bluno,101) c2,c3,c4
+ write(bluno,102)
+ $ (BIGCAL_RCS_IY(j),BIGCAL_RCS_IX(j),
+ $ BIGCAL_RCS_ADC_RAW(j),j=1,BIGCAL_RCS_NHIT)
+ endif
+ 99 format(A20,I7)
+ 100 FORMAT(A19,I5)
+ 101 FORMAT(2A7,A10)
+ 102 FORMAT(2I7,I10)
+ 103 FORMAT(A18,I5)
+
+ return
+ end
diff --git a/BTRACKING/b_print_raw_bad.f b/BTRACKING/b_print_raw_bad.f
new file mode 100644
index 0000000..9c3f8da
--- /dev/null
+++ b/BTRACKING/b_print_raw_bad.f
@@ -0,0 +1,48 @@
+ subroutine b_print_raw_bad(ABORT,err)
+
+ implicit none
+ save
+
+ character*16 here
+ parameter(here='b_print_raw_bad')
+
+ logical ABORT
+ character*(*) err
+
+ include 'bigcal_data_structures.cmn'
+ include 'bigcal_bypass_switches.cmn'
+ include 'gen_event_info.cmn'
+
+ integer j
+
+ abort=.false.
+ err=' '
+
+ if(bigcal_prot_nbad.gt.0) then
+ write(bluno,99) 'gen_event_id_number=',gen_event_id_number
+ write(bluno,99) 'bigcal_prot_nbad=',bigcal_prot_nbad
+ write(bluno,100) 'row,col,adc='
+ write(bluno,101) (bigcal_prot_iybad(j),bigcal_prot_ixbad(j),
+ $ bigcal_prot_adc_bad(j),j=1,bigcal_prot_badplusgood)
+ endif
+ if(bigcal_rcs_nbad.gt.0) then
+ write(bluno,99) 'gen_event_id_number=',gen_event_id_number
+ write(bluno,99) 'bigcal_rcs_nbad=',bigcal_rcs_nbad
+ write(bluno,100) 'row,col,adc='
+ write(bluno,101) (bigcal_rcs_iybad(j)+32,bigcal_rcs_ixbad(j),
+ $ bigcal_rcs_adc_bad(j),j=1,bigcal_rcs_badplusgood)
+ endif
+ if(bigcal_atrig_nbad.gt.0) then
+ write(bluno,99) 'gen_event_id_number=',gen_event_id_number
+ write(bluno,99) 'bigcal_atrig_nbad=',bigcal_atrig_nbad
+ write(bluno,100) 'group,half,adc='
+ write(bluno,101) (bigcal_atrig_igroup_bad(j),bigcal_atrig_ihalf_bad(j),
+ $ bigcal_atrig_adc_bad(j),j=1,bigcal_atrig_badplusgood)
+ endif
+
+ 99 format(A22,I7)
+ 100 format(A15)
+ 101 format(2I5,I7)
+
+ return
+ end
diff --git a/BTRACKING/b_print_raw_tdc.f b/BTRACKING/b_print_raw_tdc.f
new file mode 100755
index 0000000..3aa32a8
--- /dev/null
+++ b/BTRACKING/b_print_raw_tdc.f
@@ -0,0 +1,45 @@
+ subroutine b_print_raw_tdc(ABORT,err)
+
+ implicit none
+ save
+
+ character*16 here
+ parameter(here='b_print_raw_tdc')
+
+ logical ABORT
+ character*(*) err
+
+ include 'bigcal_data_structures.cmn'
+ include 'bigcal_tof_parms.cmn'
+ include 'bigcal_bypass_switches.cmn'
+ include 'gen_event_info.cmn'
+
+ character*18 c1
+ parameter(c1='BIGCAL_TDC_NHIT = ')
+ character*9 c2
+ parameter(c2='IROW = , ')
+ character*11 c3
+ parameter(c3='IGROUP = , ')
+ character*10 c4
+ parameter(c4='raw tdc = ')
+
+ integer j
+
+ ABORT=.false.
+ err=' '
+
+ if(BIGCAL_TDC_NHIT.gt.0) then
+ write(bluno,99) 'gen_event_id_number=',gen_event_id_number
+ write(bluno,100) c1,BIGCAL_TDC_NHIT
+ write(bluno,101) c2,c3,c4
+ write(bluno,102)
+ $ (BIGCAL_TDC_RAW_IROW(j),BIGCAL_TDC_RAW_IGROUP(j),
+ $ BIGCAL_TDC_RAW(j),j=1,BIGCAL_TDC_NHIT)
+ endif
+ 99 format(A20,I7)
+ 100 FORMAT(A18,I5)
+ 101 FORMAT(A9,A11,A10)
+ 102 FORMAT(I9,I11,I10)
+
+ return
+ end
diff --git a/BTRACKING/b_print_raw_trig.f b/BTRACKING/b_print_raw_trig.f
new file mode 100755
index 0000000..45b72c2
--- /dev/null
+++ b/BTRACKING/b_print_raw_trig.f
@@ -0,0 +1,62 @@
+ subroutine b_print_raw_trig(ABORT,err)
+
+ implicit none
+ save
+
+ character*17 here
+ parameter(here='b_print_raw_trig')
+
+ logical ABORT
+ character*(*) err
+
+ include 'bigcal_data_structures.cmn'
+ include 'bigcal_gain_parms.cmn'
+ include 'bigcal_tof_parms.cmn'
+ include 'bigcal_bypass_switches.cmn'
+ include 'gen_event_info.cmn'
+
+ character*20 c1
+ parameter(c1='BIGCAL_TTRIG_NHIT = ')
+ character*10 c2
+ parameter(c2='IHALF = , ')
+ character*11 c3
+ parameter(c3='IGROUP = , ')
+ character*12 c4
+ parameter(c4='raw adc = , ')
+ character*10 c5
+ parameter(c5='raw tdc = , ')
+ character*20 c6
+ parameter(c6='BIGCAL_ATRIG_NHIT = ')
+
+ integer j
+
+ ABORT=.false.
+ err = ' '
+
+ if(BIGCAL_TTRIG_NHIT.gt.0) then
+ write(bluno,99) 'gen_event_id_number=',gen_event_id_number
+ write(bluno,100) c1,BIGCAL_TTRIG_NHIT
+ write(bluno,101) c2,c3,c5
+ write(bluno,102)
+ $ (BIGCAL_TTRIG_IHALF(j),BIGCAL_TTRIG_IGROUP(j),
+ $ BIGCAL_TTRIG_TDC_RAW(j),
+ $ j=1,BIGCAL_TTRIG_NHIT)
+ endif
+
+ if(BIGCAL_ATRIG_NHIT.gt.0) then
+ write(bluno,99) 'gen_event_id_number=',gen_event_id_number
+ write(bluno,100) c6,BIGCAL_ATRIG_NHIT
+ write(bluno,101) c2,c3,c4
+ write(bluno,102)
+ $ (BIGCAL_ATRIG_IHALF(j),BIGCAL_ATRIG_IGROUP(j),
+ $ BIGCAL_ATRIG_ADC_RAW(j),j=1,BIGCAL_ATRIG_NHIT)
+ endif
+
+ 99 format(A20,I7)
+ 100 format(A20,I5)
+ 101 format(A10,A11,A12)
+ 102 format(I10,I11,I12)
+
+
+ return
+ end
diff --git a/BTRACKING/b_prune_clusters.f b/BTRACKING/b_prune_clusters.f
new file mode 100644
index 0000000..69e412d
--- /dev/null
+++ b/BTRACKING/b_prune_clusters.f
@@ -0,0 +1,217 @@
+ subroutine b_prune_clusters(abort,err)
+
+ implicit none
+ save
+
+ character*16 here
+ parameter(here='b_prune_clusters')
+
+ logical abort
+ character*(*) err
+
+ include 'bigcal_data_structures.cmn'
+ include 'bigcal_bypass_switches.cmn'
+ include 'bigcal_gain_parms.cmn'
+ include 'bigcal_geometry.cmn'
+ include 'bigcal_tof_parms.cmn'
+
+ logical keep(bigcal_all_nclstr_max)
+
+ integer ngood
+
+ integer iclust
+
+ abort=.false.
+ err=' '
+
+ ngood = 0
+
+c initialize all clusters to good:
+ do iclust=1,bigcal_all_nclstr
+ keep(iclust) = .true.
+ enddo
+
+c prune on second max:
+
+ if(b_prune_flags(1).ne.0) then
+
+ ngood = 0
+
+ do iclust=1,bigcal_all_nclstr
+ if((.not.bigcal_second_max(iclust)).and.keep(iclust)) then
+ ngood = ngood + 1
+ endif
+ enddo
+ if(ngood.gt.0) then
+ do iclust=1,bigcal_all_nclstr
+ if(bigcal_second_max(iclust)) then
+ keep(iclust) = .false.
+ endif
+ enddo
+ endif
+ endif
+
+c prune clusters that are too big:
+
+ if(b_prune_flags(2).ne.0) then
+
+ ngood = 0
+
+ do iclust=1,bigcal_all_nclstr
+ if(keep(iclust).and.(.not.bigcal_too_long_x(iclust)).and.
+ $ (.not.bigcal_too_long_y(iclust))) then
+ ngood = ngood + 1
+ endif
+ enddo
+ if(ngood.gt.0) then
+ do iclust=1,bigcal_all_nclstr
+ if(bigcal_too_long_x(iclust).or.bigcal_too_long_y(iclust)) then
+ keep(iclust) = .false.
+ endif
+ enddo
+ endif
+ endif
+
+c prune on cluster energy before pruning on edge max or cluster size:
+
+ if(b_prune_flags(3).ne.0) then
+
+ ngood = 0
+
+ do iclust=1,bigcal_all_nclstr
+ if(keep(iclust).and.bigcal_all_clstr_etot(iclust).ge.
+ $ b_prune_eclust(1).and.bigcal_all_clstr_etot(iclust).le.
+ $ b_prune_eclust(2)) then
+ ngood = ngood + 1
+ endif
+ enddo
+ if(ngood.gt.0) then
+ do iclust=1,bigcal_all_nclstr
+ if(bigcal_all_clstr_etot(iclust).lt.b_prune_eclust(1).or.
+ $ bigcal_all_clstr_etot(iclust).gt.b_prune_eclust(2))then
+ keep(iclust) = .false.
+ endif
+ enddo
+ endif
+ endif
+
+c prune on cluster size (want >1 in x and y for real showers)
+
+ if(b_prune_flags(4).ne.0) then
+
+ ngood = 0
+
+ do iclust=1,bigcal_all_nclstr
+ if(keep(iclust).and.bigcal_all_clstr_ncellx(iclust).gt.1.and.
+ $ bigcal_all_clstr_ncelly(iclust).gt.1) then
+ ngood = ngood + 1
+ endif
+ enddo
+ if(ngood.gt.0) then
+ do iclust=1,bigcal_all_nclstr
+ if(bigcal_all_clstr_ncellx(iclust).le.1.or.
+ $ bigcal_all_clstr_ncelly(iclust).le.1) then
+ keep(iclust) = .false.
+ endif
+ enddo
+ endif
+ endif
+
+c prune on edge max:
+
+ if(b_prune_flags(5).ne.0) then
+
+ ngood = 0
+ do iclust=1,bigcal_all_nclstr
+ if(keep(iclust).and.(.not.bigcal_edge_max(iclust))) then
+ ngood = ngood + 1
+ endif
+ enddo
+ if(ngood.gt.0) then
+ do iclust=1,bigcal_all_nclstr
+ if(bigcal_edge_max(iclust))then
+ keep(iclust) = .false.
+ endif
+ enddo
+ endif
+ endif
+
+c prune on group of 8 TDC hits:
+
+ if(b_prune_flags(6).ne.0) then
+
+ ngood = 0
+
+ do iclust=1,bigcal_all_nclstr
+ if(keep(iclust).and.bigcal_all_clstr_ncell8(iclust).gt.0) then
+ ngood = ngood + 1
+ endif
+ enddo
+ if(ngood.gt.0) then
+ do iclust=1,bigcal_all_nclstr
+ if(bigcal_all_clstr_ncell8(iclust).le.0) then
+ keep(iclust) = .false.
+ endif
+ enddo
+ endif
+ endif
+
+c prune on group of 64 TDC hits:
+
+ if(b_prune_flags(7).ne.0) then
+
+ ngood = 0
+
+ do iclust=1,bigcal_all_nclstr
+ if(keep(iclust).and.bigcal_all_clstr_ncell64(iclust).gt.0) then
+ ngood = ngood + 1
+ endif
+ enddo
+ if(ngood.gt.0) then
+ do iclust=1,bigcal_all_nclstr
+ if(bigcal_all_clstr_ncell64(iclust).le.0) then
+ keep(iclust) = .false.
+ endif
+ enddo
+ endif
+ endif
+
+c prune on trms:
+
+ if(b_prune_flags(8).ne.0) then
+
+ ngood = 0
+
+ do iclust=1,bigcal_all_nclstr
+ if(keep(iclust).and.bigcal_all_clstr_t8rms(iclust).le.b_timing_cut) then
+ ngood = ngood + 1
+ endif
+ enddo
+ if(ngood.gt.0) then
+ do iclust=1,bigcal_all_nclstr
+ if(bigcal_all_clstr_t8rms(iclust).gt.b_timing_cut)then
+ keep(iclust) = .false.
+ endif
+ enddo
+ endif
+ endif
+
+c now set the "keep" flag for each cluster
+c at this point, no longer keep clusters that don't satisfy, at a minimum, the following:
+c 1. no second max
+c 2. cluster size < maximum
+
+ bigcal_all_nclust_good = 0
+
+ do iclust=1,bigcal_all_nclstr
+ bigcal_clstr_keep(iclust)=.false.
+ if(keep(iclust).and..not.bigcal_second_max(iclust).and..not.
+ $ (bigcal_too_long_x(iclust).or.bigcal_too_long_y(iclust)))
+ $ then
+ bigcal_clstr_keep(iclust)=.true.
+ bigcal_all_nclust_good = bigcal_all_nclust_good + 1
+ endif
+ enddo
+
+ return
+ end
diff --git a/BTRACKING/b_raw_dump_all.f b/BTRACKING/b_raw_dump_all.f
new file mode 100755
index 0000000..3828e20
--- /dev/null
+++ b/BTRACKING/b_raw_dump_all.f
@@ -0,0 +1,28 @@
+ subroutine b_raw_dump_all(ABORT,err)
+
+ implicit none
+ save
+
+ character*50 here
+ parameter (here= 'b_raw_dump_all')
+*
+ logical ABORT
+ character*(*) err
+
+ include 'bigcal_data_structures.cmn'
+ include 'bigcal_bypass_switches.cmn'
+
+ ABORT = .FALSE.
+ err = ' '
+
+ if(bdebug_print_adc.ne.0) then
+ call b_print_raw_adc(ABORT,err)
+ endif
+ if(bdebug_print_tdc.ne.0) then
+ call b_print_raw_tdc(ABORT,err)
+ endif
+ if(bdebug_print_trig.ne.0) then
+ call b_print_raw_trig(ABORT,err)
+ endif
+ return
+ end
diff --git a/BTRACKING/b_rebuild_cluster.f b/BTRACKING/b_rebuild_cluster.f
new file mode 100644
index 0000000..cb3a196
--- /dev/null
+++ b/BTRACKING/b_rebuild_cluster.f
@@ -0,0 +1,144 @@
+ subroutine b_rebuild_cluster(clust)
+
+ implicit none
+ save
+
+ logical badi, badj
+ integer clust,icell,jcell,i,j
+ integer rowi,rowj,coli,colj,row,col
+ real ecell,xcell,ycell,xmom,ymom
+ real ei,ej,ai,aj,xi,xj,yi,yj
+ real xcenter,ycenter,xdiff,ydiff
+ real esum,asum
+ real xpar(6),ypar(6)
+
+ include 'bigcal_data_structures.cmn'
+ include 'bigcal_shower_parms.cmn'
+
+ logical abort
+ character*80 err
+
+c PURPOSE:
+c this routine assumes that the cell array for cluster iclust has
+c already been filled, but maybe one or more of the energies has changed
+c as a result of a guess using HMS info and elastic kinematics when a
+c channel is in the "bad channels" list.
+c So re-sort the cluster in order of decreasing energy, and re-calculate
+c cluster quantities related to the energies in the cells.
+c this routine gets called from the gep_check_bigcal routine which is a
+c subroutine of gep_physics. If the HMS predicts that electron should have
+c hit BigCal at a certain place, then gep_check_bigcal looks for
+c channels in the vicinity of the expected electron that are in the
+c bad channel list. If it finds any, then it will guess what the energy
+c should have been in those channels based on a fit to the shower shape
+c using the HMS-predicted energy and position of the expected electron.
+c If there are any clusters in the vicinity containing the same channels
+c from the bad channel list, then this routine reevaluates those clusters
+c based on the energy that was "guessed" for the channels in question.
+
+ if(bigcal_all_nclstr.lt.clust) return
+
+ esum = 0.
+ asum = 0.
+
+ do icell = 1,bigcal_all_clstr_ncell(clust)
+ ei = bigcal_all_clstr_ecell(clust,icell)
+ ai = bigcal_all_clstr_acell(clust,icell)
+ rowi = bigcal_all_clstr_iycell(clust,icell)
+ coli = bigcal_all_clstr_ixcell(clust,icell)
+ xi = bigcal_all_clstr_xcell(clust,icell)
+ yi = bigcal_all_clstr_ycell(clust,icell)
+
+ badi = bigcal_clstr_bad_chan(clust,icell)
+
+ do jcell = icell+1,bigcal_all_clstr_ncell(clust)
+ ej = bigcal_all_clstr_ecell(clust,jcell)
+ aj = bigcal_all_clstr_acell(clust,jcell)
+ xj = bigcal_all_clstr_xcell(clust,jcell)
+ yj = bigcal_all_clstr_ycell(clust,jcell)
+ rowj = bigcal_all_clstr_iycell(clust,jcell)
+ colj = bigcal_all_clstr_ixcell(clust,jcell)
+ badj = bigcal_clstr_bad_chan(clust,jcell)
+ if(ej.gt.ei) then ! switch everything:
+ bigcal_all_clstr_ecell(clust,icell) = ej
+ bigcal_all_clstr_acell(clust,icell) = aj
+ bigcal_all_clstr_xcell(clust,icell) = xj
+ bigcal_all_clstr_ycell(clust,icell) = yj
+ bigcal_all_clstr_ixcell(clust,icell) = colj
+ bigcal_all_clstr_iycell(clust,icell) = rowj
+
+ bigcal_clstr_bad_chan(clust,icell) = badj
+
+ bigcal_all_clstr_ecell(clust,jcell) = ei
+ bigcal_all_clstr_acell(clust,jcell) = ai
+ bigcal_all_clstr_xcell(clust,jcell) = xi
+ bigcal_all_clstr_ycell(clust,jcell) = yi
+ bigcal_all_clstr_ixcell(clust,jcell) = coli
+ bigcal_all_clstr_iycell(clust,jcell) = rowi
+
+ bigcal_clstr_bad_chan(clust,jcell) = badi
+ endif
+ enddo
+ enddo
+
+ do icell=1,bigcal_all_clstr_ncell(clust)
+ esum = esum + bigcal_all_clstr_ecell(clust,icell)
+ asum = asum + bigcal_all_clstr_acell(clust,icell)
+ enddo
+
+ bigcal_all_clstr_iymax(clust) = bigcal_all_clstr_iycell(clust,1)
+ bigcal_all_clstr_ixmax(clust) = bigcal_all_clstr_ixcell(clust,1)
+ bigcal_all_clstr_etot(clust) = esum
+ bigcal_all_clstr_atot(clust) = asum
+
+ xcenter = bigcal_all_clstr_xcell(clust,1)
+ ycenter = bigcal_all_clstr_ycell(clust,1)
+
+ xmom = 0.
+ ymom = 0.
+
+ do icell=1,bigcal_all_clstr_ncell(clust)
+ xdiff = bigcal_all_clstr_xcell(clust,icell) - xcenter
+ ydiff = bigcal_all_clstr_ycell(clust,icell) - ycenter
+
+ ecell = bigcal_all_clstr_ecell(clust,icell)
+
+ xmom = xmom + xdiff*ecell/esum
+ ymom = ymom + ydiff*ecell/esum
+
+ enddo
+
+ bigcal_all_clstr_xmom(clust) = xmom
+ bigcal_all_clstr_ymom(clust) = ymom
+
+c also re-calculate shower coordinates:
+
+ row = bigcal_all_clstr_iymax(clust)
+ col = bigcal_all_clstr_ixmax(clust)
+
+ if(row.le.32) then
+ do i=1,6
+ xpar(i) = bigcal_prot_xpar(col,i)
+ ypar(i) = bigcal_prot_ypar(row,i)
+ enddo
+ else
+ do i=1,6
+ xpar(i) = bigcal_rcs_xpar(col,i)
+ ypar(i) = bigcal_rcs_ypar(row,i)
+ enddo
+ endif
+
+ bigcal_all_clstr_x(clust) = xcenter + xpar(1)*atan(
+ $ xpar(2)*xmom**4 + xpar(3)*xmom**3 + xpar(4)*xmom**2 +
+ $ xpar(5)*xmom + xpar(6))
+ bigcal_all_clstr_y(clust) = ycenter + ypar(1)*atan(
+ $ ypar(2)*ymom**4 + ypar(3)*ymom**3 + ypar(4)*ymom**2 +
+ $ ypar(5)*ymom + ypar(6))
+
+c$$$ write(*,*) 'REBUILT CLUSTER#',clust,' after guessing energies '//
+c$$$ $ 'for channels in the bad list:'
+c$$$ call b_print_cluster(clust,abort,err)
+
+ return
+ end
+
diff --git a/BTRACKING/b_reconstruction.f b/BTRACKING/b_reconstruction.f
new file mode 100755
index 0000000..07d3fc4
--- /dev/null
+++ b/BTRACKING/b_reconstruction.f
@@ -0,0 +1,245 @@
+ subroutine B_reconstruction(ABORT,err)
+
+********************************************************
+ IMPLICIT NONE
+ SAVE
+********************************************************
+
+ character*16 here
+ parameter (here= 'B_reconstruction')
+
+c logical last_time
+ logical ABORT
+ logical mc_trig ! check if at least one trig. sum is above b_cluster_cut
+ integer isum64
+ integer ngood64
+ integer revert(5)
+ integer imax64,rowmax64,colmax64
+ character*(*) err
+
+ include 'bigcal_data_structures.cmn'
+ include 'bigcal_bypass_switches.cmn'
+ include 'bigcal_gain_parms.cmn'
+ include 'bigcal_geometry.cmn'
+ include 'bigcal_filenames.cmn'
+ include 'bigcal_tof_parms.cmn'
+ include 'hms_data_structures.cmn'
+ include 'gen_constants.par'
+ include 'gen_units.par'
+ include 'gen_scalers.cmn'
+ include 'gen_run_info.cmn'
+ include 'gen_event_info.cmn'
+
+ revert(1) = b_use_bad_chan_list
+ revert(2) = bbypass_find_clusters
+ revert(3) = bbypass_calc_cluster_time
+ revert(4) = bbypass_calc_shower_coord
+ revert(5) = bbypass_calc_physics
+
+c last_time = .false.
+
+c for certain event types, disable parts of the analysis:
+c don't add cells in the bad channel list to clusters for type 5
+c (bigcal singles) events. We only want to use the bad channel list
+c to improve the efficiency of coincidence events.
+ if(gen_event_type.eq.5) then
+ b_use_bad_chan_list = 0
+c last_time = .true.
+ endif
+ if(gen_event_type.gt.6) then
+ bbypass_find_clusters = 1
+ bbypass_calc_cluster_time = 1
+ bbypass_calc_shower_coord = 1
+ bbypass_calc_physics = 1
+ endif
+
+************ dump raw data ****************************
+ call b_raw_dump_all(ABORT,err)
+ if(ABORT) then
+ call g_add_path(here,err)
+ return
+ endif
+
+ !bigcal_max_adc = 0.
+ !bigcal_iymax_adc = 0
+ !bigcal_ixmax_adc = 0
+************ convert Protvino raw ADC to Protvino decoded ADC *******
+ if(bbypass_prot.eq.0) then
+ call b_trans_PROT(ABORT,err)
+ if(ABORT) then
+ call g_add_path(here,err)
+ return
+ endif
+ endif
+************ convert RCS raw ADC to RCS decoded ADC ****
+ if(bbypass_rcs.eq.0) then
+ call b_trans_RCS(ABORT,err)
+ if(ABORT) then
+ call g_add_path(here,err)
+ return
+ endif
+ endif
+
+ if(bigcal_iymax_adc.gt.0.and.bigcal_ixmax_adc.gt.0) then
+ rowmax64 = (bigcal_iymax_adc-1)/3 + 1
+ if(bigcal_iymax_adc.le.32) then
+ colmax64 = (bigcal_ixmax_adc-1)/16 + 1
+ else
+ colmax64 = bigcal_ixmax_adc/16 + 1
+ endif
+
+ imax64 = colmax64 + 2*(rowmax64-1)
+
+ if(mod(bigcal_iymax_adc-1,3).eq.0.and.bigcal_iymax_adc.gt.1)
+ $ then ! overlap row,
+c take group with bigger sum:
+ if(bigcal_atrig_sum64(imax64-2).gt.bigcal_atrig_sum64(imax64)) then
+ imax64 = imax64 - 2
+ endif
+ endif
+ bigcal_itrigmax_adc = imax64
+ endif
+ bigcal_all_ngood = bigcal_prot_ngood + bigcal_rcs_ngood
+
+*********** convert BigCal group-of-8 raw TDC to go8 decoded TDC *********
+ if(bbypass_sum8.eq.0) then
+ call b_trans_tdc(ABORT,err)
+ if(ABORT) then
+ call g_add_path(here,err)
+ return
+ endif
+ endif
+*********** convert BigCal raw trigger signals to decoded *****************
+ if(bbypass_sum64.eq.0) then
+ call b_trans_trig(ABORT,err)
+ if(ABORT) then
+ call g_add_path(here,err)
+ return
+ endif
+ endif
+
+ if(bdebug_print_bad.ne.0) then
+ call b_print_raw_bad(abort,err)
+ endif
+
+* special check for monte carlo event analysis: check trigger sums:
+ if(gen_bigcal_mc.ne.0) then
+ mc_trig = .false.
+
+ ngood64 = 0
+* fill hit array (special for monte carlo)
+ do isum64=1,bigcal_atrig_maxhits
+c$$$ write(*,*) 'igroup,ihalf,sum64 = ',(isum64+1)/2,mod(isum64,2)+1
+c$$$ $ ,bigcal_atrig_sum64(isum64)
+ if(bigcal_atrig_sum64(isum64).ge.b_trig_cut) then
+ mc_trig=.true.
+ ngood64 = ngood64 + 1
+ bigcal_atrig_esum(ngood64) = bigcal_atrig_sum64(isum64)
+ bigcal_atrig_good_igroup(ngood64) = (isum64-1)/2 + 1
+ bigcal_atrig_good_ihalf(ngood64) = mod(isum64-1,2) + 1
+ endif
+ enddo
+
+ bigcal_atrig_ngood = ngood64
+
+ if(.not.mc_trig) return
+ endif
+
+c$$$ do isum64=1,bigcal_atrig_maxhits
+c$$$c$$$ write(*,*) 'igroup,ihalf,sum64 = ',(isum64+1)/2,mod(isum64,2)+1
+c$$$c$$$ $ ,bigcal_atrig_sum64(isum64)
+c$$$ if(bigcal_atrig_sum64(isum64).ge.b_cluster_cut) then
+c$$$ mc_trig=.true.
+c$$$
+c$$$ endif
+c$$$ enddo
+
+c$$$ if(gen_bigcal_mc.ne.0.and. .not.mc_trig) return
+
+* find_clusters: fills the cluster arrays, calculates sums and moments
+ if(bbypass_find_clusters.eq.0.and.bbypass_prot.eq.0.and.
+ $ bbypass_rcs.eq.0) then
+
+ !write(*,*) 'entering b_fill_bigcal_arrays'
+
+c$$$ call b_fill_bigcal_arrays(abort,err)
+c$$$ if(ABORT) then
+c$$$ call g_add_path(here,err)
+c$$$ return
+c$$$ endif
+
+c write(*,*) 'entering b_find_clusters'
+
+ call b_find_clusters(bigcal_all_nclstr,bigcal_nmaxima,ABORT,err)
+ if(ABORT) then
+ call g_add_path(here,err)
+ return
+ endif
+ endif
+* check cluster timing: looks at all the hits in a cluster and calculates
+* the average time associated with sum8 tdcs and sum64 tdcs
+ if(bbypass_sum8.eq.0.and.bbypass_sum64.eq.0.and.
+ $ bbypass_calc_cluster_time.eq.0.and.bbypass_find_clusters
+ $ .eq.0) then
+ call b_calc_cluster_time(ABORT,err)
+ if(ABORT) then
+ call g_add_path(here,err)
+ return
+ endif
+ endif
+* calculate shower coordinates and energy from ADC information
+ if(bbypass_calc_shower_coord.eq.0.and.bbypass_prot.eq.0.and.
+ $ bbypass_rcs.eq.0.and.bbypass_find_clusters.eq.0) then
+ call b_calc_shower_coord(ABORT,err)
+ if(ABORT) then
+ call g_add_path(here,err)
+ return
+ endif
+ endif
+*
+ bigcal_all_nclust_good = bigcal_all_nclstr
+
+ if(bbypass_prune_clusters.eq.0.and.bbypass_find_clusters.eq.0)then
+ call b_prune_clusters(ABORT,err)
+ if(abort) then
+ call g_add_path(here,err)
+ return
+ endif
+ endif
+*
+ if(bbypass_calc_physics.eq.0.and.bbypass_find_clusters.eq.0) then
+
+ if(gen_event_type.ne.6.or.(gen_event_type.eq.6.and.
+ $ hsnum_fptrack.eq.0)) call b_calc_physics(ABORT,err)
+ if(ABORT) then
+ call g_add_path(here,err)
+ return
+ endif
+ endif
+
+c if dealing with real data and not monte carlo, then the appropriate
+c place to do the calibration matrix is in gep_reconstruction, because
+c we need to know the incident electron energy, hence we need the hms
+c info.
+ if(gen_bigcal_mc.ne.0.and.bigcal_do_calibration.ne.0.and.
+ $ gen_bigcal_mc.ne.3) then
+ call b_matrix_accum(abort,err)
+ if(abort) then
+ call g_add_path(here,err)
+ return
+ endif
+ endif
+
+ if(gen_event_type.eq.5) then
+ b_use_bad_chan_list = revert(1)
+ endif
+ if(gen_event_type.gt.6) then
+ bbypass_find_clusters = revert(2)
+ bbypass_calc_cluster_time = revert(3)
+ bbypass_calc_shower_coord = revert(4)
+ bbypass_calc_physics = revert(5)
+ endif
+ !write(*,*) 'done with reconstruction'
+*
+ return
+ end
diff --git a/BTRACKING/b_register_param.f b/BTRACKING/b_register_param.f
new file mode 100755
index 0000000..a2c4da4
--- /dev/null
+++ b/BTRACKING/b_register_param.f
@@ -0,0 +1,32 @@
+ subroutine b_register_param(ABORT,err)
+
+ IMPLICIT NONE
+ SAVE
+*
+ character*16 here
+ parameter (here= 'B_register_param')
+*
+ logical ABORT
+ character*(*) err
+*
+ logical FAIL
+ character*1000 why
+
+ err= ' '
+ ABORT = .false.
+
+ call r_bigcal_geometry
+ call r_bigcal_gain_parms
+ call r_bigcal_tof_parms
+ call r_bigcal_shower_parms
+
+ call r_bigcal_bypass_switches
+ call r_bigcal_hist_id
+
+c$$$ call r_bigcal_statistics
+c$$$ call r_bigcal_pedestals
+
+ IF(ABORT .or. err.NE.' ') call G_add_path(here,err)
+
+ return
+ end
diff --git a/BTRACKING/b_report_bad_data.f b/BTRACKING/b_report_bad_data.f
new file mode 100755
index 0000000..a5a1e55
--- /dev/null
+++ b/BTRACKING/b_report_bad_data.f
@@ -0,0 +1,24 @@
+ subroutine b_report_bad_data(lunout,ABORT,err)
+
+ implicit none
+ save
+
+ character*17 here
+ parameter(here='b_report_bad_data')
+
+ logical ABORT
+ character*(*) err
+
+ integer lunout
+
+ include 'bigcal_data_structures.cmn'
+
+c for now, don't do anything. for the HMS, the equivalent subroutine does
+c nothing because "we always use the pedestal events"
+c I will assume that is the case here.
+
+ abort=.false.
+ err=' '
+
+ return
+ end
diff --git a/BTRACKING/b_sparsify_prot.f b/BTRACKING/b_sparsify_prot.f
new file mode 100755
index 0000000..609f95d
--- /dev/null
+++ b/BTRACKING/b_sparsify_prot.f
@@ -0,0 +1,87 @@
+ subroutine b_sparsify_prot(ABORT,err)
+
+ implicit none
+ save
+
+ logical ABORT
+ character*(*) err
+ character*15 here
+ parameter (here='b_sparsify_prot')
+
+c loop over all hits, subtract peds, apply thresholds, and
+c fill decoded data arrays
+
+ integer*4 ihit,icell
+ integer*4 ngood,nbad,nbad2
+ integer*4 irow,icol
+ integer*4 adc_val
+* check number of hits:
+ include 'bigcal_data_structures.cmn'
+ include 'bigcal_gain_parms.cmn'
+
+ err=' '
+ if(BIGCAL_PROT_NHIT.lt.0.or.BIGCAL_PROT_NHIT.gt.
+ $ BIGCAL_PROT_MAXHITS) then
+ write(6,*) here,':bigcal_prot_nhit=',BIGCAL_PROT_NHIT
+ return
+ endif
+* "zero" decoded adcs:
+ do icell=1,BIGCAL_PROT_MAXHITS
+ BIGCAL_PROT_ADC_DECODED(icell)=-100.
+ enddo
+
+ ngood = 0
+ nbad = 0
+ nbad2 = 0
+
+* loop over raw hits:
+ if(bigcal_prot_nhit.gt.0) then
+ do ihit=1,BIGCAL_PROT_NHIT
+ irow = BIGCAL_PROT_IY(ihit)
+ icol = BIGCAL_PROT_IX(ihit)
+ icell = icol + BIGCAL_PROT_NX*(irow - 1)
+ adc_val = BIGCAL_PROT_ADC_RAW(ihit)
+
+ bigcal_prot_nhit_ch(icell) = bigcal_prot_nhit_ch(icell) + 1
+
+ if(bigcal_prot_nhit_ch(icell).eq.1) then
+ BIGCAL_PROT_RAW_DET(icell) = adc_val
+ endif
+ if(bigcal_prot_nhit_ch(icell).gt.1) then ! fill bad hits array
+ nbad = nbad + 1
+ nbad2 = nbad2 + 1
+ if(bigcal_prot_nhit_ch(icell).eq.2) then ! first bad hit
+ bigcal_prot_iybad(nbad) = irow
+ bigcal_prot_ixbad(nbad) = icol
+c bigcal_prot_raw_det(icell) should still contain the adc value of the first hit
+c in this channel
+ bigcal_prot_adc_bad(nbad) = bigcal_prot_raw_det(icell)
+ nbad = nbad + 1
+ endif
+ bigcal_prot_iybad(nbad) = irow
+ bigcal_prot_ixbad(nbad) = icol
+ bigcal_prot_adc_bad(nbad) = adc_val
+ endif
+
+c BIGCAL_ALL_RAW_DET(icell) = adc_val
+ if(adc_val.ge.0) then
+ BIGCAL_PROT_ADC_DECODED(icell) = float(adc_val) -
+ $ BIGCAL_PROT_PED_MEAN(icell)
+ endif
+c "sparsify" the data
+ if(BIGCAL_PROT_ADC_DECODED(icell).ge.
+ $ BIGCAL_PROT_ADC_THRESHOLD(icell)) then
+ ngood = ngood + 1
+ BIGCAL_PROT_ADC_GOOD(ngood) = BIGCAL_PROT_ADC_DECODED(icell)
+ BIGCAL_PROT_IYGOOD(ngood) = irow
+ BIGCAL_PROT_IXGOOD(ngood) = icol
+ endif
+ enddo
+ endif
+
+ BIGCAL_PROT_NGOOD = ngood
+ bigcal_prot_nbad = nbad2
+ bigcal_prot_badplusgood = nbad
+
+ return
+ end
diff --git a/BTRACKING/b_sparsify_rcs.f b/BTRACKING/b_sparsify_rcs.f
new file mode 100755
index 0000000..fc588e2
--- /dev/null
+++ b/BTRACKING/b_sparsify_rcs.f
@@ -0,0 +1,95 @@
+ subroutine b_sparsify_rcs(ABORT,err)
+
+ implicit none
+ save
+
+ logical ABORT
+ character*(*) err
+ character*15 here
+ parameter (here='b_sparsify_rcs')
+
+c loop over all hits, subtract peds, apply thresholds, and
+c fill decoded data arrays
+c RCS_IY from detector map will be 33-56. Subtract 32 in this routine and
+c then we can assume from here on out that RCS_IY starts at 1 and goes to 24
+
+ integer*4 ihit,icell
+ integer*4 ngood,nbad,nbad2
+ integer*4 irow,icol
+ integer*4 adc_val
+
+ include 'bigcal_data_structures.cmn'
+ include 'bigcal_gain_parms.cmn'
+
+* check number of hits:
+ err=' '
+ if(BIGCAL_RCS_NHIT.lt.0.or.BIGCAL_RCS_NHIT.gt.
+ $ BIGCAL_RCS_MAXHITS) then
+ write(6,*) here,':bigcal_rcs_nhit=',BIGCAL_RCS_NHIT
+ return
+ endif
+* "zero" decoded adcs:
+ do icell=1,BIGCAL_RCS_MAXHITS
+ BIGCAL_RCS_ADC_DECODED(icell)=-100.
+ enddo
+
+ ngood = 0
+ nbad = 0
+ nbad2 = 0
+
+* loop over raw hits:
+ if(bigcal_rcs_nhit.gt.0) then
+ do ihit=1,BIGCAL_RCS_NHIT
+ irow = BIGCAL_RCS_IY(ihit) - BIGCAL_PROT_NY
+ icol = BIGCAL_RCS_IX(ihit)
+ icell = icol + BIGCAL_RCS_NX*(irow - 1)
+ adc_val = BIGCAL_RCS_ADC_RAW(ihit)
+
+c$$$ if(bid_badc(icell+bigcal_prot_maxhits).gt.0)
+c$$$ $ call hf1(bid_badc(icell+bigcal_prot_maxhits),
+c$$$ $ float(adc_val),1.0)
+
+c BIGCAL_ALL_RAW_DET(icell+bigcal_prot_maxhits) = adc_val
+
+ bigcal_rcs_nhit_ch(icell) = bigcal_rcs_nhit_ch(icell) + 1
+
+ if(bigcal_rcs_nhit_ch(icell).eq.1) then
+ BIGCAL_RCS_RAW_DET(icell) = adc_val
+ endif
+ if(bigcal_rcs_nhit_ch(icell).gt.1) then
+ nbad = nbad + 1
+ nbad2 = nbad2 + 1
+ if(bigcal_rcs_nhit_ch(icell).eq.2) then ! first bad hit
+ bigcal_rcs_iybad(nbad) = irow
+ bigcal_rcs_ixbad(nbad) = icol
+c bigcal_prot_raw_det(icell) should still contain the adc value of the first hit
+c in this channel
+ bigcal_rcs_adc_bad(nbad) = bigcal_rcs_raw_det(icell)
+ nbad = nbad + 1
+ endif
+ bigcal_rcs_iybad(nbad) = irow
+ bigcal_rcs_ixbad(nbad) = icol
+ bigcal_rcs_adc_bad(nbad) = adc_val
+ endif
+
+ if(adc_val.ge.0) then
+ BIGCAL_RCS_ADC_DECODED(icell) = float(adc_val) -
+ $ BIGCAL_RCS_PED_MEAN(icell)
+ endif
+c "sparsify" the data
+ if(BIGCAL_RCS_ADC_DECODED(icell).ge.
+ $ BIGCAL_RCS_ADC_THRESHOLD(icell)) then
+ ngood = ngood + 1
+ BIGCAL_RCS_ADC_GOOD(ngood) = BIGCAL_RCS_ADC_DECODED(icell)
+ BIGCAL_RCS_IYGOOD(ngood) = irow
+ BIGCAL_RCS_IXGOOD(ngood) = icol
+ endif
+ enddo
+ endif
+ BIGCAL_RCS_NGOOD = ngood
+ bigcal_rcs_nbad = nbad2
+ bigcal_rcs_badplusgood = nbad
+
+ return
+ end
+
diff --git a/BTRACKING/b_strip_tdc.f b/BTRACKING/b_strip_tdc.f
new file mode 100755
index 0000000..3a5ee0d
--- /dev/null
+++ b/BTRACKING/b_strip_tdc.f
@@ -0,0 +1,62 @@
+ subroutine b_strip_tdc(ABORT,err)
+
+ implicit none
+ save
+
+ logical ABORT
+ character*(*) err
+
+ character*11 here
+ parameter (here='b_strip_tdc')
+
+ include 'bigcal_data_structures.cmn'
+ include 'bigcal_tof_parms.cmn'
+
+* want to calculate time relative to reference time (master trigger)
+
+ integer*4 ihit
+ integer*4 irow,igroup,itdc,tdc_raw,thitnum
+ integer*4 ngood,igood
+
+ do ihit=1,BIGCAL_TDC_MAXHITS
+ BIGCAL_TDC(ihit) = -1
+ BIGCAL_HIT_TIME(ihit) = -1000.
+ enddo
+
+c BIGCAL_GOOD_TRIG = .false.
+
+ if(BIGCAL_TDC_NHIT.lt.0.or.BIGCAL_TDC_NHIT.gt.BIGCAL_TDC_MAXHITS)
+ $ then
+ write(6,*) here,':bigcal_tdc_nhit=',BIGCAL_TDC_NHIT
+ return
+ endif
+
+ ngood = 0
+
+ if(bigcal_tdc_nhit.gt.0) then
+ do ihit=1,BIGCAL_TDC_NHIT
+ irow = BIGCAL_TDC_RAW_IROW(ihit)
+ igroup = BIGCAL_TDC_RAW_IGROUP(ihit)
+ itdc = igroup + (irow - 1) * BIGCAL_MAX_GROUPS
+ tdc_raw = bigcal_tdc_raw(ihit)
+
+ if(bigcal_tdc_det_nhit(itdc).lt.8) then
+ bigcal_tdc_det_nhit(itdc)=bigcal_tdc_det_nhit(itdc) + 1
+ thitnum = bigcal_tdc_det_nhit(itdc)
+ bigcal_tdc_raw_det(itdc,thitnum) = tdc_raw
+ endif
+
+ if(tdc_raw .ge. bigcal_tdc_min .and.
+ $ tdc_raw .le. bigcal_tdc_max ) then
+ ngood = ngood + 1
+ BIGCAL_TDC(ngood) = BIGCAL_TDC_RAW(ihit)
+ BIGCAL_TDC_IROW(ngood) = irow
+ BIGCAL_TDC_IGROUP(ngood) = igroup
+ endif
+ enddo
+ endif
+
+ BIGCAL_TDC_NDECODED = ngood
+
+ return
+ end
diff --git a/BTRACKING/b_strip_trig.f b/BTRACKING/b_strip_trig.f
new file mode 100755
index 0000000..0279dd5
--- /dev/null
+++ b/BTRACKING/b_strip_trig.f
@@ -0,0 +1,107 @@
+ subroutine b_strip_trig(ABORT,err)
+
+ implicit none
+ save
+
+ logical ABORT
+ character*(*) err
+
+ character*12 here
+ parameter (here='b_strip_trig')
+
+ include 'bigcal_data_structures.cmn'
+ include 'bigcal_tof_parms.cmn'
+ include 'bigcal_gain_parms.cmn'
+
+ integer*4 ihit,igroup64,ihalf64,icell64,ngood,adc_raw,tdc_raw
+ integer*4 thitnum
+ integer*4 nbad,nbad2
+
+ ngood = 0
+ nbad = 0
+ nbad2 = 0
+
+* do atrig first:
+ do icell64=1,bigcal_atrig_maxhits
+ bigcal_atrig_adc_dec(icell64) = -100.
+ enddo
+
+ if(bigcal_atrig_nhit.gt.0.and.bigcal_atrig_nhit.le.
+ $ bigcal_atrig_maxhits) then
+ do ihit=1,bigcal_atrig_nhit
+ igroup64 = bigcal_atrig_igroup(ihit)
+ ihalf64 = bigcal_atrig_ihalf(ihit)
+ icell64 = ihalf64 + 2*(igroup64 - 1)
+ adc_raw = bigcal_atrig_adc_raw(ihit)
+c bigcal_atrig_raw_det(icell64) = adc_raw
+
+ bigcal_atrig_nhit_ch(icell64) = bigcal_atrig_nhit_ch(icell64) + 1
+
+ if(bigcal_atrig_nhit_ch(icell64).eq.1) then
+ bigcal_atrig_raw_det(icell64) = adc_raw
+ endif
+ if(bigcal_atrig_nhit_ch(icell64).gt.1) then
+ nbad = nbad + 1
+ nbad2 = nbad2 + 1
+ if(bigcal_atrig_nhit_ch(icell64).eq.2) then ! first bad hit
+ bigcal_atrig_igroup_bad(nbad) = igroup64
+ bigcal_atrig_ihalf_bad(nbad) = ihalf64
+ bigcal_atrig_adc_bad(nbad) = bigcal_atrig_raw_det(icell64)
+ nbad = nbad + 1
+ endif
+ bigcal_atrig_igroup_bad(nbad) = igroup64
+ bigcal_atrig_ihalf_bad(nbad) = ihalf64
+ bigcal_atrig_adc_bad(nbad) = adc_raw
+ endif
+
+ if(adc_raw.ge.0) then
+ bigcal_atrig_adc_dec(icell64) = float(adc_raw) -
+ $ bigcal_trig_ped_mean(icell64)
+ endif
+
+ if(bigcal_atrig_adc_dec(icell64) .ge.
+ $ bigcal_trig_adc_threshold(icell64)) then
+ ngood = ngood + 1
+ bigcal_atrig_adc_good(ngood) = bigcal_atrig_adc_dec(icell64)
+ bigcal_atrig_good_igroup(ngood) = igroup64
+ bigcal_atrig_good_ihalf(ngood) = ihalf64
+ endif
+ enddo
+ endif
+
+ bigcal_atrig_ngood = ngood
+ bigcal_atrig_nbad = nbad2
+ bigcal_atrig_badplusgood = nbad
+
+ ngood = 0 ! now do tdcs:
+
+ if(bigcal_ttrig_nhit.gt.0.and.bigcal_ttrig_nhit.le.
+ $ bigcal_ttrig_maxhits) then
+ do ihit=1,bigcal_ttrig_nhit
+ igroup64 = bigcal_ttrig_igroup(ihit)
+ ihalf64 = bigcal_ttrig_ihalf(ihit)
+ icell64 = ihalf64 + 2*(igroup64-1)
+ tdc_raw = bigcal_ttrig_tdc_raw(ihit)
+
+ if(bigcal_ttrig_det_nhit(icell64).lt.8) then
+ bigcal_ttrig_det_nhit(icell64)=
+ $ bigcal_ttrig_det_nhit(icell64) + 1
+
+ thitnum = bigcal_ttrig_det_nhit(icell64)
+ bigcal_ttrig_raw_det(icell64,thitnum) = tdc_raw
+ endif
+ if(tdc_raw.ge.bigcal_tdc_min.and.tdc_raw.le.bigcal_tdc_max)
+ $ then
+ ngood = ngood + 1
+ bigcal_ttrig_tdc_dec(ngood) = tdc_raw
+ bigcal_ttrig_dec_igroup(ngood) = igroup64
+ bigcal_ttrig_dec_ihalf(ngood) = ihalf64
+ endif
+ enddo
+ endif
+
+ bigcal_ttrig_ndecoded = ngood
+
+ return
+ end
+
diff --git a/BTRACKING/b_trans_prot.f b/BTRACKING/b_trans_prot.f
new file mode 100755
index 0000000..3158a0d
--- /dev/null
+++ b/BTRACKING/b_trans_prot.f
@@ -0,0 +1,115 @@
+ subroutine b_trans_PROT(ABORT,err)
+
+ implicit none
+ save
+
+ logical ABORT
+ character*(*) err
+
+ character*12 here
+ parameter (here='b_trans_PROT')
+
+ integer ihit,irow,icol
+ integer icell,irow8,icol8,ig8
+ integer igroup64,ihalf64,ig64
+ real sum8
+
+ include 'bigcal_data_structures.cmn'
+ include 'bigcal_gain_parms.cmn'
+ include 'bigcal_geometry.cmn'
+ include 'bigcal_hist_id.cmn'
+ include 'bigcal_bypass_switches.cmn'
+*
+* start by sparsifying the raw data:
+*
+ call b_sparsify_prot(ABORT,err)
+ if(ABORT) then
+ call g_add_path(here,err)
+ return
+ endif
+
+*
+* for now, only additional step will be to convert the decoded
+* and ped-subtracted data to energies by multiplying with the
+* calibration constants. Actually, we should also have a database of
+* x and y positions of cell center relative to calorimeter center
+* and we can fill those arrays here too. What sums should we
+* accumulate?
+*
+* loop over sparsified "good" hits
+ if(bigcal_prot_ngood.gt.0) then
+ do ihit=1,BIGCAL_PROT_NGOOD
+ irow = BIGCAL_PROT_IYGOOD(ihit)
+ icol = BIGCAL_PROT_IXGOOD(ihit)
+ icell = icol + BIGCAL_PROT_NX*(irow - 1)
+ BIGCAL_PROT_ECELL(ihit) = BIGCAL_PROT_CFAC(icell) *
+ $ BIGCAL_PROT_ADC_GOOD(ihit) * BIGCAL_PROT_GAIN_COR(icell)
+
+ if(bigcal_prot_adc_good(ihit).gt.bigcal_max_adc) then
+ bigcal_max_adc = bigcal_prot_adc_good(ihit)
+ bigcal_iymax_adc = irow
+ bigcal_ixmax_adc = icol
+ endif
+
+ if(bid_bcal_row.gt.0) call hf1(bid_bcal_row,float(irow),1.0)
+ if(bid_bcal_col.gt.0) call hf1(bid_bcal_col,float(icol),1.0)
+ if(bid_bcal_rowcol.gt.0) call hf2(bid_bcal_rowcol,float(icol),float(irow),1.0)
+ if(bid_badc(icell).gt.0.and.b_use_peds_in_hist.le.0) then
+ if(b_use_peds_in_hist.eq.0) then
+ call hf1(bid_badc(icell),bigcal_prot_adc_good(ihit),1.0)
+ else
+ call hf1(bid_badc(icell),bigcal_prot_adc_good(ihit)+
+ $ bigcal_prot_ped_mean(icell),1.)
+ endif
+ endif
+* question of whether to group by hits or cells.
+* seems most logical and efficient to go by hits only and not
+* have to keep passing around the full array of cells with lots of
+* empties.
+*
+* Fill also xgood and ygood arrays
+ BIGCAL_PROT_XGOOD(ihit) = BIGCAL_PROT_XCENTER(icell)
+ BIGCAL_PROT_YGOOD(ihit) = BIGCAL_PROT_YCENTER(icell)
+
+* Fill detector arrays and increment sums of 8 and sums of 64:
+ BIGCAL_PROT_GOOD_DET(icell) = BIGCAL_PROT_ECELL(ihit)
+* Also fill "all detector" array:
+ bigcal_all_adc_good(ihit) = bigcal_prot_adc_good(ihit)
+ bigcal_all_ecell(ihit) = bigcal_prot_ecell(ihit)
+ bigcal_all_xgood(ihit) = bigcal_prot_xgood(ihit)
+ bigcal_all_ygood(ihit) = bigcal_prot_ygood(ihit)
+
+ bigcal_all_iygood(ihit) = irow
+ bigcal_all_ixgood(ihit) = icol
+
+ bigcal_all_adc_det(icell) = bigcal_prot_adc_good(ihit)
+ bigcal_all_good_det(icell) = bigcal_prot_ecell(ihit)
+
+c BIGCAL_PROT_GOOD_HIT(icell) = .true.
+ irow8 = irow
+ icol8 = (icol - 1)/8 + 1
+ ig8 = icol8 + BIGCAL_MAX_GROUPS * (irow8 - 1)
+c$$$ bigcal_tdc_sum8(ig8) = bigcal_tdc_sum8(ig8) +
+c$$$ $ BIGCAL_PROT_ECELL(ihit)
+ bigcal_tdc_sum8(ig8) = bigcal_tdc_sum8(ig8) +
+ $ BIGCAL_PROT_ADC_GOOD(ihit)
+ igroup64 = (irow - 1) / 3 + 1
+ ihalf64 = (icol - 1) / 16 + 1
+ ig64 = ihalf64 + 2*(igroup64 - 1)
+c$$$ bigcal_atrig_sum64(ig64) = bigcal_atrig_sum64(ig64) +
+c$$$ $ BIGCAL_PROT_ECELL(ihit)
+ bigcal_atrig_sum64(ig64) = bigcal_atrig_sum64(ig64) +
+ $ BIGCAL_PROT_ADC_GOOD(ihit)
+ if( mod(irow-1,3) .eq. 0 .and. irow.gt.1) then ! overlap row, also increment previous sum
+c$$$ bigcal_atrig_sum64(ig64-2) = bigcal_atrig_sum64(ig64-2) +
+c$$$ $ bigcal_prot_ecell(ihit)
+ bigcal_atrig_sum64(ig64-2) = bigcal_atrig_sum64(ig64-2) +
+ $ bigcal_prot_adc_good(ihit)
+ endif
+
+ enddo
+ endif
+
+ return
+ end
+
diff --git a/BTRACKING/b_trans_rcs.f b/BTRACKING/b_trans_rcs.f
new file mode 100755
index 0000000..c1a4c76
--- /dev/null
+++ b/BTRACKING/b_trans_rcs.f
@@ -0,0 +1,124 @@
+ subroutine b_trans_RCS(ABORT,err)
+
+ implicit none
+ save
+
+ logical ABORT
+ character*(*) err
+
+ character*12 here
+ parameter (here='b_trans_RCS')
+
+ integer ihit,irow,icol,irow8,icol8,ig8
+ integer icell,igroup64,ihalf64,ig64
+
+ include 'bigcal_data_structures.cmn'
+ include 'bigcal_gain_parms.cmn'
+ include 'bigcal_geometry.cmn'
+ include 'bigcal_hist_id.cmn'
+ include 'bigcal_bypass_switches.cmn'
+*
+* start by sparsifying the raw data:
+*
+ call b_sparsify_rcs(ABORT,err)
+ if(ABORT) then
+ call g_add_path(here,err)
+ return
+ endif
+
+*
+* for now, only additional step will be to convert the decoded
+* and ped-subtracted data to energies by multiplying with the
+* calibration constants. Actually, we should also have a database of
+* x and y positions of cell center relative to calorimeter center
+* and we can fill those arrays here too. What sums should we
+* accumulate?
+*
+* loop over sparsified "good" hits
+ if(bigcal_rcs_ngood.gt.0) then
+ do ihit=1,BIGCAL_RCS_NGOOD
+ irow = BIGCAL_RCS_IYGOOD(ihit)
+ icol = BIGCAL_RCS_IXGOOD(ihit)
+ icell = icol + BIGCAL_RCS_NX*(irow - 1)
+ BIGCAL_RCS_ECELL(ihit) = BIGCAL_RCS_CFAC(icell) *
+ $ BIGCAL_RCS_ADC_GOOD(ihit) * BIGCAL_RCS_GAIN_COR(icell)
+
+ if(bigcal_rcs_adc_good(ihit).gt.bigcal_max_adc) then
+ bigcal_max_adc = bigcal_rcs_adc_good(ihit)
+ bigcal_iymax_adc = irow + bigcal_prot_ny
+ bigcal_ixmax_adc = icol
+ endif
+
+ if(bid_bcal_row.gt.0) call hf1(bid_bcal_row,float(irow+bigcal_prot_ny),1.0)
+ if(bid_bcal_col.gt.0) call hf1(bid_bcal_col,float(icol),1.0)
+ if(bid_bcal_rowcol.gt.0) call hf2(bid_bcal_rowcol,float(icol),float(irow+
+ $ bigcal_prot_ny),1.0)
+ if(bid_badc(icell+bigcal_prot_maxhits).gt.0.and.b_use_peds_in_hist
+ $ .le.0) then
+ if(b_use_peds_in_hist.eq.0) then
+ call hf1(bid_badc(icell+bigcal_prot_maxhits),
+ $ bigcal_rcs_adc_good(ihit),1.0)
+ else
+ call hf1(bid_badc(icell+bigcal_prot_maxhits),
+ $ bigcal_rcs_adc_good(ihit)+bigcal_rcs_ped_mean(icell),1.)
+ endif
+ endif
+* question of whether to group by hits or cells.
+* seems most logical and efficient to go by hits only and not
+* have to keep passing around the full array of cells with lots of
+* empties.
+*
+* Fill also xgood and ygood arrays
+ BIGCAL_RCS_XGOOD(ihit) = BIGCAL_RCS_XCENTER(icell)
+ BIGCAL_RCS_YGOOD(ihit) = BIGCAL_RCS_YCENTER(icell)
+* Fill detector array and increment sums of 8 and sums of 64
+ BIGCAL_RCS_GOOD_DET(icell) = BIGCAL_RCS_ECELL(ihit)
+* Fill "all detector" array
+ bigcal_all_adc_good(ihit+bigcal_prot_ngood) = bigcal_rcs_adc_good(ihit)
+ bigcal_all_ecell(ihit+bigcal_prot_ngood) = bigcal_rcs_ecell(ihit)
+ bigcal_all_xgood(ihit+bigcal_prot_ngood) = bigcal_rcs_xgood(ihit)
+ bigcal_all_ygood(ihit+bigcal_prot_ngood) = bigcal_rcs_ygood(ihit)
+
+ bigcal_all_iygood(ihit+bigcal_prot_ngood) = irow+bigcal_prot_ny
+ bigcal_all_ixgood(ihit+bigcal_prot_ngood) = icol
+
+ bigcal_all_adc_det(icell+bigcal_prot_maxhits) = bigcal_rcs_adc_good(ihit)
+ bigcal_all_good_det(icell+bigcal_prot_maxhits) = bigcal_rcs_ecell(ihit)
+
+c BIGCAL_RCS_GOOD_HIT(icell) = .true.
+ irow8 = irow + BIGCAL_PROT_NY
+ if(icol.lt.16) then
+ icol8 = (icol - 1)/8 + 1
+ else
+ icol8 = icol / 8 + 1
+ endif
+ ig8 = icol8 + (irow8 - 1)*BIGCAL_MAX_GROUPS
+
+ igroup64 = (irow8 - 1) / 3 + 1
+ ihalf64 = icol / 16 + 1
+ ig64 = ihalf64 + 2*(igroup64-1)
+
+c$$$ bigcal_tdc_sum8(ig8) = bigcal_tdc_sum8(ig8) +
+c$$$ $ BIGCAL_RCS_ECELL(ihit)
+c$$$ bigcal_atrig_sum64(ig64) = bigcal_atrig_sum64(ig64) +
+c$$$ $ BIGCAL_RCS_ECELL(ihit)
+c$$$ if( mod(irow8-1,3) .eq.0)then ! overlap row, also increment previous group
+c$$$ bigcal_atrig_sum64(ig64-2) = bigcal_atrig_sum64(ig64-2) +
+c$$$ $ bigcal_rcs_ecell(ihit)
+c$$$ endif
+
+ bigcal_tdc_sum8(ig8) = bigcal_tdc_sum8(ig8) +
+ $ BIGCAL_RCS_ADC_GOOD(ihit)
+ bigcal_atrig_sum64(ig64) = bigcal_atrig_sum64(ig64) +
+ $ BIGCAL_RCS_ADC_GOOD(ihit)
+ if( mod(irow8-1,3) .eq.0)then ! overlap row, also increment previous group
+ bigcal_atrig_sum64(ig64-2) = bigcal_atrig_sum64(ig64-2) +
+ $ bigcal_rcs_adc_good(ihit)
+ endif
+
+ enddo
+ endif
+
+ return
+ end
+
diff --git a/BTRACKING/b_trans_tdc.f b/BTRACKING/b_trans_tdc.f
new file mode 100755
index 0000000..2fb1036
--- /dev/null
+++ b/BTRACKING/b_trans_tdc.f
@@ -0,0 +1,103 @@
+ subroutine b_trans_tdc(ABORT,err)
+
+ implicit none
+ save
+
+ logical ABORT
+ character*(*) err
+
+ character*11 here
+ parameter (here='b_trans_tdc')
+
+ include 'bigcal_data_structures.cmn'
+ include 'bigcal_bypass_switches.cmn'
+ include 'bigcal_tof_parms.cmn'
+ include 'bigcal_hist_id.cmn'
+ include 'gep_data_structures.cmn'
+
+ integer*4 ihit,igroup,irow,itdc,ngood,thitnum
+ real*4 thit,tphc,ttrig ! hit time
+ real*4 ph
+ real*4 p0,p1,p2,p3
+ logical firsthit(BIGCAL_MAX_TDC)
+
+ call b_strip_tdc(ABORT,err)
+ if(ABORT) then
+ call g_add_path(here,err)
+ return
+ endif
+
+ if(BIGCAL_TDC_NDECODED .le. 0) return
+
+ ngood = 0
+
+ ! at this point, use looser cut: "bigcal_window"
+ ! do pulse height correction only if we have decoded the ADCs:
+ do ihit=1,BIGCAL_TDC_NDECODED
+ irow = BIGCAL_TDC_IROW(ihit)
+ igroup = BIGCAL_TDC_IGROUP(ihit)
+ itdc = igroup + (irow - 1) * BIGCAL_MAX_GROUPS
+ if(bbypass_prot.ne.0.and.irow.le.BIGCAL_PROT_NY) then
+ ph = 0.
+ else if(bbypass_rcs.ne.0.and.irow.gt.BIGCAL_PROT_NY) then
+ ph = 0.
+ else
+ ph = BIGCAL_TDC_SUM8(itdc)
+ endif
+ thit = BIGCAL_TDC(ihit) * bigcal_tdc_to_time ! convert to ns
+ thit = bigcal_end_time - thit ! invert since we are in common-stop mode:
+ thit = thit - bigcal_g8_time_offset(itdc)
+
+c$$$ if(ntrigb.gt.0) then ! also subtract trigger time if there was a trigger
+c$$$ thit = thit - gep_btime(1)
+c$$$ else
+c$$$ thit = thit - gep_btime_elastic
+c$$$ endif
+
+ if(ph.ge.bigcal_g8_phc_minph(itdc).and.ph.le.bigcal_g8_phc_maxph(itdc)) then
+ p0 = bigcal_g8_phc_p0(itdc)
+ p1 = bigcal_g8_phc_p1(itdc)
+ p2 = bigcal_g8_phc_p2(itdc)
+ p3 = bigcal_g8_phc_p3(itdc)
+
+ tphc = p2 + (p0 + p1*ph)*exp(-p3*ph)
+ else
+ tphc = 0.
+ endif
+
+ thit = thit - tphc
+
+ if(ntrigb.gt.0) then
+ ttrig = bigcal_end_time - gep_btime(1)
+ else
+ ttrig = bigcal_end_time - gep_btime_elastic
+ endif
+
+ if(abs(thit - ttrig).le.bigcal_window_slop)then
+ ngood = ngood + 1
+ BIGCAL_TIME_IROW(ngood) = irow
+ BIGCAL_TIME_IGROUP(ngood) = igroup
+ BIGCAL_HIT_TIME(ngood) = thit
+ bigcal_tdc_good(ngood) = bigcal_tdc(ihit)
+c fill tdc histogram:
+ if(bid_btdc(itdc).gt.0) call hf1(bid_btdc(itdc),float(bigcal_tdc(ihit)),1.0)
+
+ if(bid_bcal_row8.gt.0) call hf1(bid_bcal_row8,float(irow),1.)
+ if(bid_bcal_col8.gt.0) call hf1(bid_bcal_col8,float(igroup),1.)
+ if(bid_bcal_row8vscol8.gt.0) call hf2(bid_bcal_row8vscol8,float(igroup),
+ $ float(irow),1.)
+
+c if(bid_btimewalk(itdc).gt.0) call hf2(bid_btimewalk(itdc),ph,thit,1.0)
+c ! also fill "detector" array (arrays over tdc# as opposed to hits)
+ if(bigcal_tdc_det_ngood(itdc).lt.8)then
+ bigcal_tdc_det_ngood(itdc)=bigcal_tdc_det_ngood(itdc) + 1
+ thitnum = bigcal_tdc_det_ngood(itdc)
+ bigcal_tdc_good_det(itdc,thitnum) = thit
+ endif
+ endif
+ enddo
+
+ BIGCAL_TIME_NGOOD = ngood
+
+ return
+ end
diff --git a/BTRACKING/b_trans_trig.f b/BTRACKING/b_trans_trig.f
new file mode 100755
index 0000000..c47ebb8
--- /dev/null
+++ b/BTRACKING/b_trans_trig.f
@@ -0,0 +1,273 @@
+ subroutine b_trans_trig(ABORT,err)
+
+ implicit none
+ save
+
+ logical ABORT
+ character*(*) err
+
+ character*12 here
+ parameter (here='b_trans_trig')
+
+ include 'bigcal_data_structures.cmn'
+ include 'bigcal_tof_parms.cmn'
+ include 'bigcal_gain_parms.cmn'
+ include 'bigcal_bypass_switches.cmn'
+ include 'bigcal_hist_id.cmn'
+ include 'gep_data_structures.cmn'
+
+ integer*4 ihit,jhit,ihitbest,icell64best
+ real*4 hit_time,ph,esum,tphc,ttrig,mintdiff
+ real*4 p0,p1,p2,p3
+ integer*4 irow64,icol64,icell64,ngood,thitnum
+ integer*4 jrow64,jcol64,jcell64
+ integer*4 irow8,icol8,icell8
+
+* find trigger logic groups with good ADC/TDC values
+ call b_strip_trig(ABORT,err)
+ if(ABORT) then
+ call g_add_path(here,err)
+ return
+ endif
+
+ if(bigcal_atrig_ngood.gt.0)then
+ do ihit=1,bigcal_atrig_ngood
+ irow64 = bigcal_atrig_good_igroup(ihit)
+ icol64 = bigcal_atrig_good_ihalf(ihit)
+ icell64 = icol64 + 2*(irow64 - 1)
+ bigcal_atrig_esum(ihit) = bigcal_trig_cfac(icell64) *
+ $ bigcal_atrig_adc_good(ihit)*bigcal_trig_gain_cor(icell64)
+
+c$$$ if(bid_btadc(icell64).gt.0.and.b_use_peds_in_hist.eq.0) then
+c$$$ call hf1(bid_btadc(icell64),
+c$$$ $ bigcal_atrig_adc_good(ihit),1.0)
+c$$$ endif
+ bigcal_atrig_good_det(icell64) = bigcal_atrig_esum(ihit)
+c$$$ if(bid_bcal_tadcvsum64.gt.0) then
+c$$$ call hf2(bid_bcal_tadcvsum64,bigcal_atrig_sum64(icell64),
+c$$$ $ bigcal_atrig_adc_good(ihit),1.0)
+c$$$ endif
+
+ if(bid_bcal_arow64.gt.0) call hf1(bid_bcal_arow64,float(irow64),1.)
+ if(bid_bcal_acol64.gt.0) call hf1(bid_bcal_acol64,float(icol64),1.)
+ if(bid_bcal_arow64vsacol64.gt.0) call hf2(bid_bcal_arow64vsacol64,
+ $ float(icol64),float(irow64),1.)
+
+ if(bigcal_iymax_adc.ne.0.and.bigcal_ixmax_adc.ne.0.and.
+ $ bid_bcal_trchvmax64.gt.0) then
+ jrow64 = (bigcal_iymax_adc-1)/3 + 1
+ if(bigcal_iymax_adc.le.bigcal_prot_ny) then
+ jcol64 = (bigcal_ixmax_adc-1)/16 + 1
+ else
+ jcol64 = bigcal_ixmax_adc/16 + 1
+ endif
+
+ jcell64 = jcol64 + 2*(jrow64-1)
+
+
+
+ if(mod(bigcal_iymax_adc-1,3).eq.0) then ! overlap row
+c pick closest group between jcell64 and jcell64-2, the other group to which
+c the maximum belongs
+
+ if(abs(jcell64-icell64).lt.abs(jcell64-2-icell64)) then
+ call hf2(bid_bcal_trchvmax64,float(jcell64),
+ $ float(icell64),1.0)
+ else
+ call hf2(bid_bcal_trchvmax64,float(jcell64-2),
+ $ float(icell64),1.0)
+ endif
+ else ! not overlap, group of max is unique
+ call hf2(bid_bcal_trchvmax64,float(jcell64),
+ $ float(icell64),1.0)
+ endif
+ endif
+ enddo
+ endif
+
+ ngood = 0
+
+ ihitbest = 0
+ icell64best = 0
+
+ mintdiff = 0.
+
+ if(ntrigb.gt.0) then
+ do ihit=1,ntrigb
+ if(ihit.eq.1.or.abs(gep_btime(ihit)-gep_btime_elastic).lt.mintdiff) then
+ ttrig = bigcal_end_time - gep_btime(ihit)
+ mintdiff = abs(gep_btime(ihit)-gep_btime_elastic)
+ endif
+ enddo
+ else
+ ttrig = bigcal_end_time - gep_btime_elastic
+ endif
+
+ gep_btime_raw = ttrig
+
+ mintdiff = 0.
+
+ if(bigcal_ttrig_ndecoded.gt.0) then
+ do ihit=1,bigcal_ttrig_ndecoded
+ irow64 = bigcal_ttrig_dec_igroup(ihit)
+ icol64 = bigcal_ttrig_dec_ihalf(ihit)
+ icell64 = icol64 + 2*(irow64-1)
+c$$$ if(bbypass_prot.ne.0.and.bbypass_rcs.ne.0.and.icell64
+c$$$ $ .le.bigcal_atrig_maxhits) then
+c$$$ ph = bigcal_atrig_sum64(icell64)
+c$$$ else
+c$$$ ph = 0.
+c$$$ endif
+
+ ph = bigcal_atrig_good_det(icell64)
+
+ hit_time = bigcal_ttrig_tdc_dec(ihit) * bigcal_tdc_to_time ! convert to ns
+ hit_time = bigcal_end_time - hit_time ! invert since we're in common stop mode.
+ hit_time = hit_time - bigcal_g64_time_offset(icell64)
+c$$$ if(ntrigb.gt.0) then ! also subtract trigger time if there was a trigger: otherwise,
+c$$$c subtract center of elastic timing window.
+c$$$ hit_time = hit_time - gep_btime(1)
+c$$$ else
+c$$$ hit_time = hit_time - gep_btime_elastic
+c$$$ endif
+c$$$ hit_time = hit_time - bigcal_g64_phc_coeff(icell64) *
+c$$$ $ sqrt(max(0.,(ph/bigcal_g64_minph(icell64)-1.)))
+
+ if(ph.ge.bigcal_g64_phc_minph(icell64).and.ph.le.bigcal_g64_phc_maxph(icell64)
+ $ ) then
+ p0 = bigcal_g64_phc_p0(icell64)
+ p1 = bigcal_g64_phc_p1(icell64)
+ p2 = bigcal_g64_phc_p2(icell64)
+ p3 = bigcal_g64_phc_p3(icell64)
+
+ tphc = p2 + (p0 + ph*p1)*exp(-p3*ph)
+ else
+ tphc = 0.
+ endif
+
+ hit_time = hit_time - tphc
+
+ if(abs(hit_time - ttrig).le.bigcal_window_slop)
+ $ then
+ ngood = ngood + 1
+
+ if(ngood.eq.1.or.abs(hit_time - ttrig)<mintdiff) then
+ mintdiff = abs(hit_time - ttrig)
+ ihitbest = ngood
+ icell64best = icell64
+ endif
+
+ bigcal_ttrig_good_igroup(ngood) = irow64
+ bigcal_ttrig_good_ihalf(ngood) = icol64
+ bigcal_ttrig_time_good(ngood) = hit_time
+ bigcal_ttrig_tdc_good(ngood) = bigcal_ttrig_tdc_dec(ihit)
+c fill trig tdc histogram
+
+ do jhit=1,bigcal_atrig_ngood
+ jrow64 = bigcal_atrig_good_igroup(jhit)
+ jcol64 = bigcal_atrig_good_ihalf(jhit)
+ jcell64 = jcol64 + 2*(jrow64-1)
+ if(bid_bcal_ttchanvstachan.gt.0) call hf2(bid_bcal_ttchanvstachan,
+ $ float(jcell64),float(icell64),1.)
+ enddo
+
+ if(bid_bcal_trow64.gt.0) call hf1(bid_bcal_trow64,float(irow64),1.)
+ if(bid_bcal_tcol64.gt.0) call hf1(bid_bcal_tcol64,float(icol64),1.)
+ if(bid_bcal_trow64vstcol64.gt.0) call hf2(bid_bcal_trow64vstcol64,
+ $ float(icol64),float(irow64),1.)
+
+ if(bid_bttdc(icell64).gt.0) call hf1(bid_bttdc(icell64),
+ $ float(bigcal_ttrig_tdc_good(ngood)),1.0)
+
+ if(bigcal_ttrig_det_ngood(icell64).lt.8) then
+ bigcal_ttrig_det_ngood(icell64) =
+ $ bigcal_ttrig_det_ngood(icell64) + 1
+ thitnum = bigcal_ttrig_det_ngood(icell64)
+ bigcal_ttrig_good_det(icell64,thitnum) = hit_time
+ endif
+
+ if(bbypass_sum8.eq.0.and.bigcal_time_ngood.gt.0.and.
+ $ bid_bcal_ttdcvtdc.gt.0) then
+ do jhit=1,bigcal_time_ngood
+ irow8 = bigcal_time_irow(jhit)
+ icol8 = bigcal_time_igroup(jhit)
+ icell8 = icol8 + 4*(irow8-1)
+
+ jcell64 = (icol8-1)/2 + 1 + 2*((irow8-1)/3)
+
+ if(bid_bcal_ttchanvstgroup.gt.0) then
+ if(mod(irow8-1,3).eq.0) then ! overlap row
+ if(abs(jcell64-icell64).lt.abs(jcell64-2-icell64)) then
+ call hf2(bid_bcal_ttchanvstgroup,float(jcell64),
+ $ float(icell64),1.)
+ else
+ call hf2(bid_bcal_ttchanvstgroup,float(jcell64-2),
+ $ float(icell64),1.)
+ endif
+ else ! not overlap row
+ call hf2(bid_bcal_ttchanvstgroup,float(jcell64),
+ $ float(icell64),1.)
+ endif
+ endif
+
+c check if the two hits match:
+ if( (icol8-1)/2 + 1 .eq. icol64 ) then
+ if( (irow8-1)/3 + 1 .eq. irow64 .or.(irow8-1)/3-1
+ $ .eq. irow64) then
+ call hf2(bid_bcal_ttdcvtdc,
+ $ bigcal_hit_time(jhit),hit_time,1.0)
+ endif
+ endif
+ enddo
+ endif
+ endif
+ enddo
+ endif
+
+c walk-correct the trigger time now:
+
+c write(*,*) 'icell64best=',icell64best
+
+ if(icell64best.gt.0) then
+c write(*,*) 'adc64=',bigcal_atrig_good_det(icell64best)
+c write(*,*) 'minph,maxph=',btrig_phc_minph,btrig_phc_maxph
+ if(bigcal_atrig_good_det(icell64best).ge.btrig_phc_minph.and.
+ $ bigcal_atrig_good_det(icell64best).le.btrig_phc_maxph) then
+ p0 = btrig_phc_p0
+ p1 = btrig_phc_p1
+ p2 = btrig_phc_p2
+ p3 = btrig_phc_p3
+
+ ph = bigcal_atrig_good_det(icell64best)
+
+ tphc = p2 + (p0 + p1*ph)*exp(-p3*ph)
+c write(*,*) 'adc,phc=',bigcal_atrig_good_det(icell64best),tphc
+
+ gep_btime_corr = ttrig - tphc
+c write(*,*) 'walk-corrected BigCal trigger time=',gep_btime_corr
+ else
+ gep_btime_corr = ttrig
+ endif
+ else
+ gep_btime_corr = ttrig
+ endif
+
+
+ do icell64=1,bigcal_atrig_maxhits
+ if(bigcal_ttrig_det_ngood(icell64).gt.0) then
+ if(bid_btadc(icell64).gt.0.and.b_use_peds_in_hist.eq.0) then
+ call hf1(bid_btadc(icell64),
+ $ bigcal_atrig_good_det(icell64),1.0)
+ endif
+
+ if(bid_bcal_tadcvsum64.gt.0) then
+ call hf2(bid_bcal_tadcvsum64,bigcal_atrig_sum64(icell64),
+ $ bigcal_atrig_good_det(icell64),1.0)
+ endif
+ endif
+ enddo
+
+ bigcal_ttrig_ngood = ngood
+
+ return
+ end
diff --git a/BTRACKING/bigcal_calib.f b/BTRACKING/bigcal_calib.f
new file mode 100644
index 0000000..7d6c91f
--- /dev/null
+++ b/BTRACKING/bigcal_calib.f
@@ -0,0 +1,646 @@
+ subroutine bigcal_calib(abort,err)
+
+ implicit none
+ save
+
+ character*12 here
+ parameter(here='bigcal_calib')
+
+ include 'bigcal_data_structures.cmn'
+ include 'bigcal_bypass_switches.cmn'
+ include 'gen_run_info.cmn'
+ include 'bigcal_filenames.cmn'
+ include 'bigcal_gain_parms.cmn'
+ include 'bigcal_hist_id.cmn'
+
+ integer nempty,nsmalldiag,N,irow,icol,jrow,jcol,icell,jcell,ismall,iempty
+ integer ihit,jhit,i,j,k
+ integer iochan,iflag_matr
+
+ real*4 c_old,g_old,c_new,g_new
+ real*4 newavg,redavg
+ integer*4 nnewavg,nredavg
+ integer*4 Nred,ired,jred
+ real*4 bigcal_reduced_matrix(bigcal_all_maxhits,bigcal_all_maxhits)
+ real*4 bigcal_reduced_vector(bigcal_all_maxhits)
+ integer*4 bigcal_ivect(bigcal_all_maxhits)
+ integer*4 bigcal_imatr(bigcal_all_maxhits,bigcal_all_maxhits)
+ integer*4 bigcal_jmatr(bigcal_all_maxhits,bigcal_all_maxhits)
+
+ logical fillhist
+
+ character*80 filename
+
+ logical abort
+ character*(*) err
+
+c build reduced matrix if parameters are set:
+
+c write(*,*) 'building reduced matrix Nred=',Nred
+
+c if(Nred.gt.0.and.Nred.le.bigcal_all_maxhits) then
+ Nred = 0
+ ired = 0
+ jred = 0
+ if(bigcal_calib_iylo.ge.1.and.bigcal_calib_iylo.le.56.and.
+ $ bigcal_calib_iyhi.ge.1.and.bigcal_calib_iyhi.le.56.and.
+ $ bigcal_calib_iyhi.gt.bigcal_calib_iylo) then
+ if(bigcal_calib_ixlo(1).ge.1.and.bigcal_calib_ixlo(1).le.32
+ $ .and.bigcal_calib_ixhi(1).ge.1.and.bigcal_calib_ixhi(1)
+ $ .le.32.and.bigcal_calib_ixhi(1).gt.bigcal_calib_ixlo(1)) then
+ if(bigcal_calib_ixlo(2).ge.1.and.bigcal_calib_ixlo(2).le.30
+ $ .and.bigcal_calib_ixhi(2).ge.1.and.bigcal_calib_ixhi(2)
+ $ .le.30.and.bigcal_calib_ixhi(2).gt.bigcal_calib_ixlo(2)) then
+c ired=0
+ do i=1,bigcal_all_maxhits
+ if(i.le.1024) then
+ irow = (i-1)/32 + 1
+ icol = mod(i-1,32) + 1
+ else
+ j=i-1024
+ irow = (j-1)/30 + 33
+ icol = mod(j-1,30) + 1
+ endif
+
+ if(irow.ge.bigcal_calib_iylo.and.irow.le.bigcal_calib_iyhi) then
+ if(irow.le.32) then
+ if(icol.ge.bigcal_calib_ixlo(1).and.icol.le.bigcal_calib_ixhi(1)) then
+ ired = ired + 1
+c write(*,*) 'i,irow,icol,ired=',i,irow,icol,ired
+ bigcal_reduced_vector(ired) = bigcal_vector(i)
+ bigcal_ivect(ired) = i
+
+ jred = 0
+ do j=1,bigcal_all_maxhits
+ if(j.le.1024) then
+ jrow = (j-1)/32 + 1
+ jcol = mod(j-1,32) + 1
+ else
+ k = j - 1024
+ jrow = (k-1)/30 + 33
+ jcol = mod(k-1,30) + 1
+ endif
+
+ if(jrow.ge.bigcal_calib_iylo.and.jrow.le.bigcal_calib_iyhi) then
+ if(jrow.le.32) then
+ if(jcol.ge.bigcal_calib_ixlo(1).and.jcol.le.
+ $ bigcal_calib_ixhi(1)) then
+ jred = jred + 1
+c write(*,*) 'j,jrow,jcol,jred=',j,jrow,jcol,jred
+ bigcal_reduced_matrix(ired,jred) = bigcal_matrix(i,j)
+ bigcal_imatr(ired,jred) = i
+ bigcal_jmatr(ired,jred) = j
+ endif
+ else
+ if(jcol.ge.bigcal_calib_ixlo(2).and.jcol.le.
+ $ bigcal_calib_ixhi(2)) then
+ jred = jred + 1
+c write(*,*) 'j,jrow,jcol,jred=',j,jrow,jcol,jred
+ bigcal_reduced_matrix(ired,jred) = bigcal_matrix(i,j)
+ bigcal_imatr(ired,jred) = i
+ bigcal_jmatr(ired,jred) = j
+ endif
+ endif
+ endif
+
+ enddo
+c write(*,*) 'ired,jredFINAL=',ired,jred
+ endif
+ else
+ if(icol.ge.bigcal_calib_ixlo(2).and.icol.le.bigcal_calib_ixhi(2)) then
+ ired = ired + 1
+c write(*,*) 'i,irow,icol,ired=',i,irow,icol,ired
+ bigcal_reduced_vector(ired) = bigcal_vector(i)
+ bigcal_ivect(ired) = i
+
+ jred = 0
+ do j=1,bigcal_all_maxhits
+ if(j.le.1024) then
+ jrow = (j-1)/32 + 1
+ jcol = mod(j-1,32) + 1
+ else
+ k = j - 1024
+ jrow = (k-1)/30 + 33
+ jcol = mod(k-1,30) + 1
+ endif
+
+ if(jrow.ge.bigcal_calib_iylo.and.jrow.le.bigcal_calib_iyhi) then
+ if(jrow.le.32) then
+ if(jcol.ge.bigcal_calib_ixlo(1).and.jcol.le.
+ $ bigcal_calib_ixhi(1)) then
+ jred = jred + 1
+c write(*,*) 'j,jrow,jcol,jred=',j,jrow,jcol,jred
+ bigcal_reduced_matrix(ired,jred) = bigcal_matrix(i,j)
+ bigcal_imatr(ired,jred) = i
+ bigcal_jmatr(ired,jred) = j
+ endif
+ else
+ if(jcol.ge.bigcal_calib_ixlo(2).and.jcol.le.
+ $ bigcal_calib_ixhi(2)) then
+ jred = jred + 1
+c write(*,*) 'j,jrow,jcol,jred=',j,jrow,jcol,jred
+ bigcal_reduced_matrix(ired,jred) = bigcal_matrix(i,j)
+ bigcal_imatr(ired,jred) = i
+ bigcal_jmatr(ired,jred) = j
+ endif
+ endif
+ endif
+ enddo
+c write(*,*) 'ired,jredFINAL=',ired,jred
+
+ endif
+ endif
+ endif
+ enddo
+c write(*,*) 'iredFINAL=',ired
+ Nred = ired
+ endif
+ endif
+ endif
+
+ write(*,*) 'built reduced matrix Nred=',Nred
+
+ abort = .false.
+ err = ' '
+
+c first check whether we have enough events to do a decent calibration:
+ if(bigcal_nmatr_event.lt.bigcal_min_calib_events) then ! save matrix to a file to start next run.
+ write(*,*) 'not enough events to calibrate, saving matrix'//
+ $ ' for next run'
+ write(*,*) 'number of events in calib. matrix = ',bigcal_nmatr_event
+ if(b_calib_matrix_filename.ne.' ') then
+ filename = b_calib_matrix_filename
+ call g_IO_control(iochan,'ANY',abort,err)
+ if(abort) then
+ call g_add_path(here,err)
+ return
+ endif
+
+ open(unit=iochan,file=filename,status='unknown',
+ $ form='unformatted',err=34)
+
+ write(iochan) bigcal_nmatr_event
+ write(iochan) bigcal_vector
+ write(iochan) bigcal_matrix
+
+ call g_IO_control(iochan,'FREE',abort,err)
+ if(abort) then
+ call g_add_path(here,err)
+ return
+ endif
+ close(iochan)
+ return
+
+ 34 write(*,*) 'problem opening '//filename
+ return
+ else
+ write(*,*) 'WARNING: insufficient events '//
+ $ 'to calibrate BigCal, but '
+ write(*,*) 'b_calib_matrix_filename undefined'
+ write(*,*) 'next run calibration analysis will '//
+ $ 'start over at zero events!'
+ endif
+ else ! have enough events, do calibration
+c before solving matrix, determine nempty, nsmall, and nsmalldiag per Kravtsov:
+
+ write(*,*) 'Ready to do calibration: nevent=',bigcal_nmatr_event
+
+ if(Nred.gt.0..and.Nred.le.bigcal_all_maxhits) then
+ write(*,*) 'using reduced calibration matrix:'
+ write(*,366) '(xlop,xhip,xlor,xhir,ylo,yhi)=(',bigcal_calib_ixlo(1),
+ $ ',',bigcal_calib_ixhi(1),',',bigcal_calib_ixlo(2),',',bigcal_calib_ixhi(2),
+ $ ',',bigcal_calib_iylo,',',bigcal_calib_iyhi
+
+ 366 format(A33,5(I3,A2),I3)
+
+ endif
+ do i=1,N
+ bigcal_matr_iempty(i) = 0
+ bigcal_matr_ismalld(i) = 0
+ enddo
+
+ nempty = 0
+ nsmalldiag = 0
+
+ N = bigcal_all_maxhits
+
+c newavg = 0.
+
+ ired = 1
+
+ do i=1,N
+c newavg = newavg + bigcal_vector(i)
+ if(bigcal_vector(i).eq.0.) then
+ nempty = nempty + 1
+ bigcal_matr_iempty(nempty) = i
+ bigcal_vector(i) = 1.
+ bigcal_matrix(i,i) = 1.
+
+ if(bigcal_ivect(ired).eq.i) then
+ bigcal_reduced_vector(ired) = 1.
+ bigcal_reduced_matrix(ired,ired) = 1.
+ endif
+ endif
+
+ if(bigcal_matrix(i,i).lt.0.1*bigcal_vector(i)) then
+ nsmalldiag = nsmalldiag + 1
+ bigcal_matr_ismalld(nsmalldiag) = i
+ bigcal_vector(i) = 1.
+ if(bigcal_ivect(ired).eq.i) then
+ bigcal_reduced_vector(ired) = 1.
+ do jred=1,Nred
+ bigcal_reduced_matrix(ired,jred) = 0.
+ bigcal_reduced_matrix(jred,ired) = 0.
+ enddo
+ bigcal_reduced_matrix(ired,ired) = 1.
+ endif
+ do j=1,N
+ bigcal_matrix(i,j) = 0.
+ bigcal_matrix(j,i) = 0.
+ enddo
+ bigcal_matrix(i,i) = 1.
+ endif
+
+ if(bigcal_ivect(ired).eq.i) ired = ired + 1
+ enddo
+
+c newavg = newavg / N
+
+ bigcal_matr_nempty = nempty
+ bigcal_matr_nsmalldiag = nsmalldiag
+
+ do i=1,nempty
+ if(bid_bcal_empty.gt.0) call hf1(bid_bcal_empty,
+ $ float(bigcal_matr_iempty(i)),1.)
+ enddo
+ do i=1,nsmalldiag
+ if(bid_bcal_small.gt.0) call hf1(bid_bcal_small,
+ $ float(bigcal_matr_ismalld(i)),1.)
+ enddo
+c call cernlib routine to solve the system of equations:
+c replaces "bigcal_vector" with the solution vector of coefficients
+
+ call rseqn(N,bigcal_matrix,N,iflag_matr,1,bigcal_vector)
+
+ if(Nred.gt.0.and.Nred.le.bigcal_all_maxhits) then
+ call rseqn(Nred,bigcal_reduced_matrix,N,iflag_matr,1,bigcal_reduced_vector)
+
+ if(iflag_matr.ne.-1) then
+ ired = 1
+ do i=1,N
+ if(i.eq.bigcal_ivect(ired)) then
+ bigcal_vector(i) = bigcal_reduced_vector(ired)
+ ired = ired + 1
+ else
+ bigcal_vector(i) = 1.
+ endif
+ enddo
+ endif
+ endif
+
+ bigcal_matr_iflag = iflag_matr
+ if(iflag_matr.eq.-1) then
+ write(*,*) '%BIGCAL CALIB: matrix not positive-definite'
+ return
+ else
+ write(*,*) '%BIGCAL CALIB: calibration successful'
+ endif
+
+c now write out a CTP parm file with the new calibration coefficients:
+
+ if(b_calib_parm_filename.ne.' ') then
+ filename = b_calib_parm_filename
+
+ write(*,*) filename
+
+ call g_sub_run_number(filename,gen_run_number)
+
+ write(*,*) 'writing new calib. coeffs. to '//filename
+
+ call g_IO_control(iochan,'ANY',abort,err)
+ if(abort) then
+ call g_add_path(here,err)
+ return
+ endif
+
+ open(unit=iochan,file=filename,status='unknown',
+ $ form='formatted',err=35)
+
+c amplitudes were already multiplied by cfac and gain_cor, therefore, to get the new calibration coefficients,
+c we have to separate out the effect of such:
+c Eguess = cfac_old*gain_cor_old * (ADC - PED)
+c set new gain_cor to 1
+c Eactual = Ccalculated * Eguess = cfac_new * (ADC - PED)
+c --> cfac_new = cfac_old*gain_cor_old * Ccalculated
+c --> gain_cor_new = 1
+
+ newavg = 0.
+ redavg = 0.
+
+ nnewavg = 0
+ nredavg = 0
+
+ ired = 1
+ ismall = 1
+ iempty = 1
+
+ do i=1,bigcal_prot_maxhits
+
+ fillhist = .true.
+
+ if(bigcal_matr_ismalld(ismall).eq.i) then
+ fillhist = .false.
+ ismall = ismall + 1
+ endif
+
+ if(bigcal_matr_iempty(iempty).eq.i) then
+ fillhist = .false.
+ iempty = iempty + 1
+ endif
+
+ irow = (i-1)/32 + 1
+ icol = mod(i-1,32) + 1
+
+ c_old = bigcal_prot_cfac(i)
+ g_old = bigcal_prot_gain_cor(i)
+
+ g_new = 1.
+ c_new = bigcal_vector(i) * c_old * g_old
+
+ bigcal_prot_gain_cor(i) = 1.
+ bigcal_prot_cfac(i) = bigcal_vector(i) * c_old * g_old
+
+ if(bid_bcal_cfac_old.gt.0) call hf1(bid_bcal_cfac_old,
+ $ float(i),c_old*g_old)
+
+c$$$ if(bid_bcal_oldxnew.gt.0) call hf1(bid_bcal_oldxnew,
+c$$$ $ float(i),bigcal_prot_cfac(i))
+
+c$$$ if(.not.(Nred.gt.0.and.Nred.le.bigcal_all_maxhits)) then ! using full matrix
+c$$$ if(bid_bcal_cfac_new.gt.0) call hf1(bid_bcal_cfac_new,
+c$$$ $ float(i),bigcal_vector(i))
+c$$$ if(bid_bcal_cfac_dist.gt.0) call hf1(bid_bcal_cfac_dist,
+c$$$ $ bigcal_vector(i),1.)
+c$$$ endif
+
+ newavg = newavg + c_new
+ nnewavg = nnewavg + 1
+ if(i.eq.bigcal_ivect(ired)) then
+ ired = ired + 1
+ if(irow.ne.bigcal_calib_iylo.and.irow.ne.bigcal_calib_iyhi.and.
+ $ icol.ne.bigcal_calib_ixlo(1).and.icol.ne.bigcal_calib_ixhi(1)) then
+ if(bid_bcal_cfac_new.gt.0.and.fillhist) call hf1(bid_bcal_cfac_new,
+ $ float(i),bigcal_vector(i))
+ if(bid_bcal_cfac_dist.gt.0.and.fillhist) call hf1(bid_bcal_cfac_dist,
+ $ bigcal_vector(i),1.)
+
+ redavg = redavg + c_new
+ nredavg = nredavg + 1
+ endif
+ endif
+ enddo
+
+ do i=1,bigcal_rcs_maxhits
+
+ irow = (i-1)/30 + 33
+ icol = mod(i-1,30) + 1
+
+ fillhist = .true.
+ if(bigcal_matr_ismalld(ismall).eq.i+1024) then
+ fillhist = .false.
+ ismall = ismall + 1
+ endif
+
+ if(bigcal_matr_iempty(iempty).eq.i+1024) then
+ fillhist = .false.
+ iempty = iempty + 1
+ endif
+
+ c_old = bigcal_rcs_cfac(i)
+ g_old = bigcal_rcs_gain_cor(i)
+
+ bigcal_rcs_gain_cor(i) = 1.
+ bigcal_rcs_cfac(i) = bigcal_vector(i+bigcal_prot_maxhits) *
+ $ c_old * g_old
+
+ g_new = 1.
+ c_new = bigcal_vector(i+bigcal_prot_maxhits) * c_old * g_old
+
+ if(bid_bcal_cfac_old.gt.0) call hf1(bid_bcal_cfac_old,
+ $ float(i+bigcal_prot_maxhits),c_old*g_old)
+
+c$$$ if(bid_bcal_oldxnew.gt.0) call hf1(bid_bcal_oldxnew,
+c$$$ $ float(i+bigcal_prot_maxhits),bigcal_rcs_cfac(i))
+
+c$$$ if(bid_bcal_cfac_new.gt.0) call hf1(bid_bcal_cfac_new,
+c$$$ $ float(i+bigcal_prot_maxhits),bigcal_vector(i+bigcal_prot_maxhits))
+c$$$
+c$$$ if(bid_bcal_cfac_dist.gt.0) call hf1(bid_bcal_cfac_dist,
+c$$$ $ bigcal_vector(i+bigcal_prot_maxhits),1.)
+
+ newavg = newavg + c_new
+ nnewavg = nnewavg + 1
+ if(i + bigcal_prot_maxhits.eq.bigcal_ivect(ired)) then
+
+ ired = ired + 1
+ if(irow.ne.bigcal_calib_iylo.and.irow.ne.bigcal_calib_iyhi.and.
+ $ icol.ne.bigcal_calib_ixlo(2).and.icol.ne.bigcal_calib_ixhi(2)) then
+ if(bid_bcal_cfac_new.gt.0.and.fillhist) call hf1(bid_bcal_cfac_new,
+ $ float(i+bigcal_prot_maxhits),bigcal_vector(i+bigcal_prot_maxhits))
+
+ if(bid_bcal_cfac_dist.gt.0.and.fillhist) call hf1(bid_bcal_cfac_dist,
+ $ bigcal_vector(i+bigcal_prot_maxhits),1.)
+ redavg = redavg + c_new
+ nredavg = nredavg + 1
+ endif
+ endif
+ enddo
+
+ newavg = newavg / nnewavg
+ redavg = redavg / nredavg
+
+c replace "empty" and "small diag." channels with the average new calibration constant:
+c also replace any channels that aren't in the reduced calib. matrix with the reduced avg.
+
+ do i=1,nsmalldiag
+ icell = bigcal_matr_ismalld(i)
+
+ if(icell.le.bigcal_prot_maxhits) then
+ bigcal_prot_cfac(icell) = newavg
+ if(Nred.gt.0.and.Nred.le.bigcal_all_maxhits) then
+ bigcal_prot_cfac(icell) = redavg
+ endif
+ else
+ bigcal_rcs_cfac(icell-bigcal_prot_maxhits) = newavg
+ if(Nred.gt.0.and.Nred.le.bigcal_all_maxhits) then
+ bigcal_rcs_cfac(icell-bigcal_prot_maxhits) = redavg
+ endif
+ endif
+ enddo
+
+ do i=1,nempty
+ icell = bigcal_matr_iempty(i)
+ if(icell.le.bigcal_prot_maxhits) then
+ bigcal_prot_cfac(icell) = newavg
+ if(Nred.gt.0.and.Nred.le.bigcal_all_maxhits) then
+ bigcal_prot_cfac(icell) = redavg
+ endif
+ else
+ bigcal_rcs_cfac(icell-bigcal_prot_maxhits) = newavg
+ if(Nred.gt.0.and.Nred.le.bigcal_all_maxhits) then
+ bigcal_rcs_cfac(icell-bigcal_prot_maxhits) = redavg
+ endif
+ endif
+ enddo
+
+c also replace any channels outside of the specified range with the average of channels calibrated
+c using the reduced matrix.
+
+ ired=1
+
+ do i=1,N
+ if(i.eq.bigcal_ivect(ired)) then
+ ired = ired + 1
+ if(i.le.1024) then
+ irow= (i-1)/32 + 1
+ icol= mod(i-1,32) + 1
+ if(irow.eq.bigcal_calib_iylo.or.irow.eq.bigcal_calib_iyhi.or.
+ $ icol.eq.bigcal_calib_ixlo(1).or.icol.eq.bigcal_calib_ixhi(1)) then
+ bigcal_prot_cfac(i) = redavg
+ endif
+
+ if(bigcal_prot_cfac(i).lt..05*redavg.or.bigcal_prot_cfac(i).gt.20.*redavg) then
+ bigcal_prot_cfac(i) = redavg
+ endif
+ else
+ irow=(i-1025)/30 + 33
+ icol=mod(i-1025,30) + 1
+ if(irow.eq.bigcal_calib_iylo.or.irow.eq.bigcal_calib_iyhi.or.
+ $ icol.eq.bigcal_calib_ixlo(2).or.icol.eq.bigcal_calib_ixhi(2)) then
+ bigcal_rcs_cfac(i-1024) = redavg
+ endif
+
+ if(bigcal_rcs_cfac(i-1024).lt..05*redavg.or.bigcal_rcs_cfac(i-1024).gt.20.*redavg) then
+ bigcal_rcs_cfac(i-1024) = redavg
+ endif
+
+ endif
+ else
+ if(i.le.1024) then
+ bigcal_prot_cfac(i) = redavg
+ else
+ bigcal_rcs_cfac(i-1024) = redavg
+ endif
+ endif
+ enddo
+
+c now that all the "empty" and "small diagonal" channels have been replaced with the appropriate averages,
+c fill the histograms with the new calibration constants:
+ if(bid_bcal_oldxnew.gt.0) then
+ do i=1,bigcal_all_maxhits
+ if(i.le.1024) then
+ call hf1(bid_bcal_oldxnew,float(i),bigcal_prot_cfac(i))
+ else
+ call hf1(bid_bcal_oldxnew,float(i),bigcal_rcs_cfac(i-1024))
+ endif
+ enddo
+ endif
+
+ write(iochan,*) 'bigcal_prot_cfac = '
+
+ do i=1,(bigcal_prot_maxhits/8)
+ if(i.lt.bigcal_prot_maxhits/8) then
+ write(iochan,101) (bigcal_prot_cfac(j+8*(i-1)),
+ $ ', ',j=1,8)
+ else
+ write(iochan,102) (bigcal_prot_cfac(j+8*(i-1)),
+ $ ', ',j=1,7),bigcal_prot_cfac(8+8*(i-1))
+ endif
+ enddo
+
+ write(iochan,*) 'bigcal_prot_gain_cor = '
+
+ do i=1,(bigcal_prot_maxhits/8)
+ if(i.lt.bigcal_prot_maxhits/8) then
+ write(iochan,101) (bigcal_prot_gain_cor(j+8*(i-1)),
+ $ ', ',j=1,8)
+ else
+ write(iochan,102) (bigcal_prot_gain_cor(j+8*(i-1)),
+ $ ', ',j=1,7),bigcal_prot_gain_cor(8+8*(i-1))
+ endif
+ enddo
+
+ write(iochan,*) 'bigcal_rcs_cfac = '
+
+ do i=1,(bigcal_rcs_maxhits/8)
+ if(i.lt.bigcal_rcs_maxhits/8) then
+ write(iochan,101) (bigcal_rcs_cfac(j+8*(i-1)),
+ $ ', ',j=1,8)
+ else
+ write(iochan,102) (bigcal_rcs_cfac(j+8*(i-1)),
+ $ ', ',j=1,7),bigcal_rcs_cfac(8+8*(i-1))
+ endif
+ enddo
+
+ write(iochan,*) 'bigcal_rcs_gain_cor = '
+
+ do i=1,(bigcal_rcs_maxhits/8)
+ if(i.lt.bigcal_rcs_maxhits/8) then
+ write(iochan,101) (bigcal_rcs_gain_cor(j+8*(i-1)),
+ $ ', ',j=1,8)
+ else
+ write(iochan,102) (bigcal_rcs_gain_cor(j+8*(i-1)),
+ $ ', ',j=1,7),bigcal_rcs_gain_cor(8+8*(i-1))
+ endif
+ enddo
+
+ 101 format(8(F12.5,A2))
+ 102 format(7(F12.5,A2),F12.5)
+c shut down the file:
+ call g_IO_control(iochan,'FREE',abort,err)
+ if(abort) then
+ call g_add_path(here,err)
+ return
+ endif
+ close(iochan)
+ endif
+c reset calibration matrix to zero and rewrite the original file without the
+c '_%d.param' extension. This way, if we are replaying runs using a script, the
+c next run will find the calibration coefficients reset:
+ bigcal_nmatr_event = 0
+ do i=1,bigcal_all_maxhits
+ bigcal_vector(i) = 0.
+ do j=1,bigcal_all_maxhits
+ bigcal_matrix(i,j) = 0.
+ enddo
+ enddo
+
+ filename = b_calib_matrix_filename
+ call g_IO_control(iochan,'ANY',abort,err)
+ if(abort) then
+ call g_add_path(here,err)
+ return
+ endif
+
+ open(unit=iochan,file=filename,status='unknown',
+ $ form='unformatted',err=35)
+
+ write(iochan) bigcal_nmatr_event
+ write(iochan) bigcal_vector
+ write(iochan) bigcal_matrix
+
+ call g_IO_control(iochan,'FREE',abort,err)
+ if(abort) then
+ call g_add_path(here,err)
+ return
+ endif
+ close(iochan)
+ return
+
+ 35 write(*,*) 'problem opening '//filename
+ return
+
+ endif
+
+ return
+ end
diff --git a/CODA/.cvsignore b/CODA/.cvsignore
new file mode 100644
index 0000000..92aeffc
--- /dev/null
+++ b/CODA/.cvsignore
@@ -0,0 +1 @@
+O.*
diff --git a/CODA/CVS/Entries b/CODA/CVS/Entries
new file mode 100644
index 0000000..24e1c6f
--- /dev/null
+++ b/CODA/CVS/Entries
@@ -0,0 +1,14 @@
+/.cvsignore/1.1/Thu Jul 8 18:40:13 2004//Tsane
+/Makefile/1.1/Mon Dec 7 22:11:04 1998//Tsane
+/Makefile.Unix/1.4.8.1/Mon Sep 10 20:08:01 2007//Tsane
+/ceMsg.h/1.1/Mon Dec 7 22:11:04 1998//Tsane
+/ceMsgLib.c/1.1/Mon Dec 7 22:11:04 1998//Tsane
+/ceMsgTbl.c/1.1/Mon Dec 7 22:11:05 1998//Tsane
+/evfile.msg/1.1/Mon Dec 7 22:11:05 1998//Tsane
+/evfile_msg.h/1.1/Mon Dec 7 22:11:05 1998//Tsane
+/evio.c/1.5.26.1/Thu Mar 3 20:10:23 2011//Tsane
+/evtest.c/1.1/Mon Dec 7 22:11:05 1998//Tsane
+/facility/1.1/Mon Dec 7 22:11:05 1998//Tsane
+/misc.c/1.1/Wed Feb 24 15:27:44 1999//Tsane
+/swap_util.c/1.1/Mon Dec 7 22:11:05 1998//Tsane
+D
diff --git a/CODA/CVS/Repository b/CODA/CVS/Repository
new file mode 100644
index 0000000..ea85d43
--- /dev/null
+++ b/CODA/CVS/Repository
@@ -0,0 +1 @@
+Analyzer/CODA
diff --git a/CODA/CVS/Root b/CODA/CVS/Root
new file mode 100644
index 0000000..6288c3f
--- /dev/null
+++ b/CODA/CVS/Root
@@ -0,0 +1 @@
+whit@cvs.jlab.org:/group/hallc/cvsroot
diff --git a/CODA/CVS/Tag b/CODA/CVS/Tag
new file mode 100644
index 0000000..25d73f7
--- /dev/null
+++ b/CODA/CVS/Tag
@@ -0,0 +1 @@
+Tsane
diff --git a/CODA/Makefile b/CODA/Makefile
new file mode 100644
index 0000000..a38ad3a
--- /dev/null
+++ b/CODA/Makefile
@@ -0,0 +1,8 @@
+#
+# $Log: Makefile,v $
+# Revision 1.1 1998/12/07 22:11:04 saw
+# Initial setup
+#
+ETC=../etc
+
+include $(ETC)/Makefile.NEW
diff --git a/CODA/Makefile.Unix b/CODA/Makefile.Unix
new file mode 100644
index 0000000..843608b
--- /dev/null
+++ b/CODA/Makefile.Unix
@@ -0,0 +1,98 @@
+#-----------------------------------------------------------------------------
+# Copyright (c) 1991,1992 Southeastern Universities Research Association,
+# Continuous Electron Beam Accelerator Facility
+#
+# This software was developed under a United States Government license
+# described in the NOTICE file included as part of this distribution.
+#
+# CEBAF Data Acquisition Group, 12000 Jefferson Ave., Newport News, VA 23606
+# Email: coda@cebaf.gov Tel: (804) 249-7101 Fax: (804) 249-7363
+# -----------------------------------------------------------------------------
+#
+# Description:
+# Makefile for event file I/O library, line mode dump utility
+#
+# Author: Chip Watson, CEBAF Data Acquisition Group
+#
+# Revision History:
+# $Log: Makefile.Unix,v $
+# Revision 1.4.8.1 2007/09/10 20:08:01 pcarter
+# Implemented changes to allow compilation on RHEL 3,4,5 and MacOSX
+#
+# Revision 1.4 2004/07/07 21:07:21 saw
+# Move CODA routine from libctp to libcoda
+#
+# Revision 1.3 1999/02/24 15:27:43 saw
+# Add to CVS tree
+#
+# Revision 1.2 1998/12/09 16:31:01 saw
+# Remove dependence on Csoft environment variable
+#
+# Revision 1.1 1998/12/07 22:11:04 saw
+# Initial setup
+#
+# Revision 1.4 93/07/22 11:23:47 11:23:47 heyes (Graham Heyes)
+# Convert to use master makefile format
+#
+# Revision 1.3 92/07/14 20:02:27 20:02:27 watson (Chip Watson)
+# fixed CODA targets
+#
+# Revision 1.2 1992/07/08 19:17:49 watson
+# Add dependence of evio on evfile_msg.h
+#
+# Revision 1.1 1992/07/08 18:28:03 watson
+# Initial revision
+#
+#
+
+NEWSTYLE = 1
+include ../../etc/Makefile
+include ../../etc/Makefile.flags
+
+ install-dirs := lib #include
+
+ lib_targets = libcoda.a(evio.o) libcoda.a(swap_util.o) \
+ libcoda.a(ceMsgLib.o) libcoda.a(ceMsgTbl.o)
+# include_targets = evfile_msg.h
+
+ sources = evio.c evtest.c swap_util.c ceMsgLib.c ceMsgTbl.c
+
+ifeq ($(MYOS),Linux)
+ lib_targets := $(lib_targets) libcoda.a(misc.o)
+ sources := $(sources) misc.c
+endif
+
+ifeq ($(MYOS),OSF1)
+ CC = cc
+else
+ CC = gcc
+endif
+#.KEEP_STATE:
+
+ifdef NFSDIRECTORY
+../%.c : $(NFSDIRECTORY)/CODA/%.c
+ ln -s $< $@
+
+../%.h : $(NFSDIRECTORY)/CODA/%.h
+ ln -s $< $@
+
+../%.msg : $(NFSDIRECTORY)/CODA/%.msg
+ ln -s $< $@
+
+.PRECIOUS: ../%.c ../%.h ../%.msg
+endif
+
+evio.o: ../evio.c ../evfile_msg.h
+
+evtest: evtest.o evio.o swap_util.o $(CODALIB)
+ $(CC) -o $@ evtest.o evio.o swap_util.o $(CODALIB)
+
+.PRECIOUS: evfile_msg.h
+
+evfile_msg.h: evfile.msg
+ makeMsgTbl
+
+#clean:
+# $(RM) *.o evfile_msg.h ceMsgTbl.c evtest *.dat
+
+include $(sources:.c=.d)
diff --git a/CODA/ceMsg.h b/CODA/ceMsg.h
new file mode 100644
index 0000000..0b298a7
--- /dev/null
+++ b/CODA/ceMsg.h
@@ -0,0 +1,53 @@
+/*-----------------------------------------------------------------------------
+ * Copyright (c) 1991,1992 Southeastern Universities Research Association,
+ * Continuous Electron Beam Accelerator Facility
+ *
+ * This software was developed under a United States Government license
+ * described in the NOTICE file included as part of this distribution.
+ *
+ * CEBAF Data Acquisition Group, 12000 Jefferson Ave., Newport News, VA 23606
+ * Email: coda@cebaf.gov Tel: (804) 249-7101 Fax: (804) 249-7363
+ *-----------------------------------------------------------------------------
+ *
+ * Description:
+ * Include file to define error message field values, structure
+ *
+ * Author: Chip Watson
+ *
+ * Revision History:
+ * $Log: ceMsg.h,v $
+ * Revision 1.1 1998/12/07 22:11:04 saw
+ * Initial setup
+ *
+* Revision 1.1 94/03/16 07:57:22 07:57:22 heyes (Graham Heyes)
+* Initial revision
+*
+* Revision 1.1 94/03/15 11:56:42 11:56:42 heyes (Graham Heyes)
+* Initial revision
+*
+ * Revision 1.1 92/07/14 18:27:34 18:27:34 watson (Chip Watson)
+ * Initial revision
+ *
+ */
+
+#define CEMSG_ALL 0
+#define CEMSG_NAME 1
+#define CEMSG_MSG 2
+#define CEMSG_SEV 3
+#define CEMSG_FAC 4
+#define CEMSG_CODE 5
+
+#define CEMSG_INFO 0
+#define CEMSG_WARN 1
+#define CEMSG_ERROR 2
+#define CEMSG_FATAL 3
+
+#define cemsg_severity(code) (((code)>>30)&3)
+
+typedef struct coda_error_table_entry {
+ char *name;
+ int num;
+ char *msg;
+} CE_TBL_ENTRY;
+
+
diff --git a/CODA/ceMsgLib.c b/CODA/ceMsgLib.c
new file mode 100644
index 0000000..c52def1
--- /dev/null
+++ b/CODA/ceMsgLib.c
@@ -0,0 +1,162 @@
+/*-----------------------------------------------------------------------------
+ * Copyright (c) 1991,1992 Southeastern Universities Research Association,
+ * Continuous Electron Beam Accelerator Facility
+ *
+ * This software was developed under a United States Government license
+ * described in the NOTICE file included as part of this distribution.
+ *
+ * CEBAF Data Acquisition Group, 12000 Jefferson Ave., Newport News, VA 23606
+ * Email: coda@cebaf.gov Tel: (804) 249-7101 Fax: (804) 249-7363
+ *-----------------------------------------------------------------------------
+ *
+ * Description:
+ * Routines to extract message text from message table
+ *
+ * Author: Chip Watson, CEBAF Data Acquisition Group
+ *
+ * Revision History:
+ * $Log: ceMsgLib.c,v $
+ * Revision 1.1 1998/12/07 22:11:04 saw
+ * Initial setup
+ *
+* Revision 1.1 94/03/16 07:57:20 07:57:20 heyes (Graham Heyes)
+* Initial revision
+*
+* Revision 1.1 94/03/15 11:56:40 11:56:40 heyes (Graham Heyes)
+* Initial revision
+*
+ * Revision 1.2 93/07/21 09:07:35 09:07:35 heyes (Graham Heyes)
+ * Get rid of anoying pointer without cast warning
+ *
+ * Revision 1.1 92/07/14 18:27:48 18:27:48 watson (Chip Watson)
+ * Initial revision
+ *
+ */
+
+#include <stdio.h>
+#include "ceMsg.h"
+
+char *ceMsg(int,int,char *,int);
+void cePmsg(char *,int);
+
+extern CE_TBL_ENTRY ceMsgTbl[];
+static char *lastmsg = (char *)0;
+
+#ifdef NOF77extname
+void cemsg
+#else
+void cemsg_
+#endif
+(int *num,int *flag,char *out,int maxout)
+{
+ /* fortran: call cemsg(error,flag,character_variable) */
+ (void) ceMsg(*num,*flag,out,maxout);
+}
+
+char *ceMsg(num,flag,out,maxout)
+ int num, flag, maxout;
+ char *out;
+{
+ int severity,len;
+ CE_TBL_ENTRY *entry;
+ char *msgptr,*cp;
+
+ if (lastmsg) free(lastmsg); /* free last constructed message */
+ for(entry = ceMsgTbl;entry->name!=NULL;entry++)
+ if (entry->num==num) break; /* assume null terminated table for now */
+ if (entry->num!=num) {
+ if (out) *out = '\0';
+ return(NULL);
+ }
+ msgptr = 0;
+ severity = cemsg_severity(num);
+ switch (flag) {
+ case (CEMSG_ALL):
+ len = strlen(entry->name) + strlen(entry->msg) + 16;
+ lastmsg = (char *)malloc(len);
+ if (lastmsg) {
+ msgptr = lastmsg;
+ switch (severity) {
+ case (CEMSG_INFO):
+ strcpy(msgptr,"Info: ");
+ break;
+ case (CEMSG_WARN):
+ strcpy(msgptr,"Warning: ");
+ break;
+ case (CEMSG_ERROR):
+ strcpy(msgptr,"Error: ");
+ break;
+ case (CEMSG_FATAL):
+ strcpy(msgptr,"Fatal error: ");
+ break;
+ }
+ strcat(msgptr,entry->name);
+ strcat(msgptr," ");
+ strcat(msgptr,entry->msg);
+ }
+ break;
+ case (CEMSG_NAME):
+ msgptr = entry->name;
+ break;
+ case (CEMSG_MSG):
+ msgptr = entry->msg;
+ break;
+ case (CEMSG_SEV):
+ switch (severity) {
+ case (CEMSG_INFO):
+ msgptr = "I";
+ break;
+ case (CEMSG_WARN):
+ msgptr = "W";
+ break;
+ case (CEMSG_ERROR):
+ msgptr = "E";
+ break;
+ case (CEMSG_FATAL):
+ msgptr = "F";
+ break;
+ }
+ break;
+ case (CEMSG_FAC):
+ lastmsg = (char *)malloc(strlen(entry->name)); /* bigger than needed */
+ msgptr = lastmsg;
+ strcpy((char *) msgptr,(char *) entry->name[2]); /* skip over S_ */
+ for (cp=msgptr;*cp;cp++)
+ if (*cp=='_') break;
+ *cp = '\0'; /* truncate at next _ */
+ break;
+ case (CEMSG_CODE):
+ lastmsg = (char *)malloc(strlen(entry->name)); /* bigger than needed */
+ msgptr = lastmsg;
+ for (cp= &(entry->name[2]);*cp;cp++)
+ if (*cp=='_') break;
+ strcpy(msgptr,cp+1); /* copy following S_XXX_ */
+ for (cp=msgptr;*cp;cp++)
+ if (*cp=='_') break;
+ *cp='\0'; /* terminate at next _ */
+ break;
+ default:
+ msgptr = (char *) 0;
+ }
+ if (out!=NULL) strncpy(out,msgptr,maxout);
+ return(msgptr);
+}
+
+void cepmsg_(char *string,int *num,int s_len)
+{
+ char *t;
+ t = (char *)malloc(s_len+1);
+ strncpy(t,string,s_len);
+ t[s_len]='\0';
+ (void) cePmsg(t,*num);
+ free(t);
+}
+
+void cePmsg(string,num)
+ char *string;
+ int num;
+{
+ fprintf(stderr,"%s ",string); /* append a space */
+ fprintf(stderr,"%s\n",ceMsg(num,CEMSG_ALL,NULL,0));
+}
+
diff --git a/CODA/ceMsgTbl.c b/CODA/ceMsgTbl.c
new file mode 100644
index 0000000..98229f0
--- /dev/null
+++ b/CODA/ceMsgTbl.c
@@ -0,0 +1,26 @@
+/* <@(#) ceMsgTbl.c created on Mon May 23 12:00 by makeMsgTbl> */
+
+typedef struct ce_tbl_entry {
+ char *name;
+ int num;
+ char *msg;
+} CE_TBL_ENTRY;
+
+CE_TBL_ENTRY ceMsgTbl[] = {
+
+ {"S_SUCCESS", 0, "Operation successful"},
+ {"S_FAILURE", -1, "Operation failed"},
+
+ /* <@(#) EVFILE 115 evfile.msg Event File I/O> */
+
+ {"S_EVFILE", 0x00730000, "evfile.msg Event File I/O"},
+ {"S_EVFILE_TRUNC", 0x40730001, "Event truncated on read"},
+ {"S_EVFILE_BADBLOCK", 0x40730002, "Bad block number encountered"},
+ {"S_EVFILE_BADHANDLE", 0x80730001, "Bad handle (file/stream not open)"},
+ {"S_EVFILE_ALLOCFAIL", 0x80730002, "Failed to allocate event I/O structure"},
+ {"S_EVFILE_BADFILE", 0x80730003, "File format error"},
+ {"S_EVFILE_UNKOPTION", 0x80730004, "Unknown option specified"},
+ {"S_EVFILE_UNXPTDEOF", 0x80730005, "Unexpected end of file while reading event"},
+ {"S_EVFILE_BADSIZEREQ", 0x80730006, "Invalid buffer size request to evIoct"},
+ {(char *)0,0,(char *)0}
+};
diff --git a/CODA/evfile.msg b/CODA/evfile.msg
new file mode 100644
index 0000000..2360b6c
--- /dev/null
+++ b/CODA/evfile.msg
@@ -0,0 +1,40 @@
+!-----------------------------------------------------------------------------
+! Copyright (c) 1991,1992 Southeastern Universities Research Association,
+! Continuous Electron Beam Accelerator Facility
+!
+! This software was developed under a United States Government license
+! described in the NOTICE file included as part of this distribution.
+!
+! CEBAF Data Acquisition Group, 12000 Jefferson Ave., Newport News, VA 23606
+! Email: coda@cebaf.gov Tel: (804) 249-7101 Fax: (804) 249-7363
+! -----------------------------------------------------------------------------
+!
+! Description:
+! Error message definitions for the Slow Controls package.
+!
+! Author: Chip Watson, CEBAF Data Acquisition Group
+!
+! Revision History:
+! $Log: evfile.msg,v $
+! Revision 1.1 1998/12/07 22:11:05 saw
+! Initial setup
+!
+! Revision 1.1 94/03/15 11:57:29 11:57:29 heyes (Graham Heyes)
+! Initial revision
+!
+! Revision 1.1 1992/07/08 18:28:20 watson
+! Initial revision
+!
+!
+
+.warn
+TRUNC 1 Event truncated on read
+BADBLOCK 2 Bad block number encountered
+
+.error
+BADHANDLE 1 Bad handle (file/stream not open)
+ALLOCFAIL 2 Failed to allocate event I/O structure
+BADFILE 3 File format error
+UNKOPTION 4 Unknown option specified
+UNXPTDEOF 5 Unexpected end of file while reading event
+BADSIZEREQ 6 Invalid buffer size request to evIoct
diff --git a/CODA/evfile_msg.h b/CODA/evfile_msg.h
new file mode 100644
index 0000000..c4d3f06
--- /dev/null
+++ b/CODA/evfile_msg.h
@@ -0,0 +1,18 @@
+/* <@(#) evfile_msg.h created on Mon May 23 12:00 by makeMsgTbl> */
+/* <@(#) Return Codes for EVFILE 115 evfile.msg Event File I/O> */
+#ifndef EVFILE_header
+#ifndef S_SUCCESS
+#define S_SUCCESS 0
+#define S_FAILURE -1
+#endif
+
+#define S_EVFILE 0x00730000 /* evfile.msg Event File I/O */
+#define S_EVFILE_TRUNC 0x40730001 /* Event truncated on read */
+#define S_EVFILE_BADBLOCK 0x40730002 /* Bad block number encountered */
+#define S_EVFILE_BADHANDLE 0x80730001 /* Bad handle (file/stream not open) */
+#define S_EVFILE_ALLOCFAIL 0x80730002 /* Failed to allocate event I/O structure */
+#define S_EVFILE_BADFILE 0x80730003 /* File format error */
+#define S_EVFILE_UNKOPTION 0x80730004 /* Unknown option specified */
+#define S_EVFILE_UNXPTDEOF 0x80730005 /* Unexpected end of file while reading event */
+#define S_EVFILE_BADSIZEREQ 0x80730006 /* Invalid buffer size request to evIoct */
+#endif
diff --git a/CODA/evio.c b/CODA/evio.c
new file mode 100644
index 0000000..7aa4d15
--- /dev/null
+++ b/CODA/evio.c
@@ -0,0 +1,1213 @@
+/*-----------------------------------------------------------------------------
+ * Copyright (c) 1991,1992 Southeastern Universities Research Association,
+ * Continuous Electron Beam Accelerator Facility
+ *
+ * This software was developed under a United States Government license
+ * described in the NOTICE file included as part of this distribution.
+ *
+ * CEBAF Data Acquisition Group, 12000 Jefferson Ave., Newport News, VA 23606
+ * Email: coda@cebaf.gov Tel: (804) 249-7101 Fax: (804) 249-7363
+ *-----------------------------------------------------------------------------
+ *
+ * Description:
+ * Event I/O routines
+ *
+ * Author: Chip Watson, CEBAF Data Acquisition Group
+ * Modified: Stephen A. Wood, TJNAF Hall C
+ * Works on ALPHA 64 bit machines if BIT64 is defined
+ * Will read input from standard input if filename is "-"
+ * If input filename is "|command" will take data from standard output
+ * of command.
+ * If input file is compressed and unconpressible with gunzip, it will
+ * decompress the data on the fly.
+ *
+ * Revision History:
+ * $Log: evio.c,v $
+ * Revision 1.5.26.1 2011/03/03 20:10:23 jones
+ * Check for 64bit by looking for LP64
+ *
+ * Revision 1.5 2002/10/02 15:59:25 saw
+ * Fix gcc3 compatibity
+ *
+ * Revision 1.4 2002/07/31 20:24:29 saw
+ * Make local copy of filename passed in evOpen
+ *
+ * Revision 1.3 1999/11/04 20:30:48 saw
+ * Add code to write coda output to stdout or pipes
+ *
+ * Revision 1.2 1998/12/01 13:54:12 saw
+ * (saw) Alpha 64 bit fixes, input from std input, pipes and compressed
+ * files
+ *
+ * Revision 1.1 1996/12/19 14:05:02 saw
+ * Initial revision
+ *
+ * Revision 1.5 1994/08/15 15:45:09 chen
+ * add evnum to EVFILE structure. Keep event number when call evWrite
+ *
+ * Revision 1.4 1994/08/12 17:14:55 chen
+ * check event type explicitly
+ *
+ * Revision 1.3 1994/06/17 16:11:12 chen
+ * fix a bug when there is a single special event in the last block
+ *
+ * Revision 1.2 1994/05/12 15:38:37 chen
+ * In case a wrong data format, close file and free memory
+ *
+ * Revision 1.1 1994/04/11 13:07:06 chen
+ * Initial revision
+ *
+* Revision 1.6 1993/11/16 20:57:27 chen
+* stronger type casting for swapped_memecpy
+*
+* Revision 1.5 1993/11/09 18:21:58 chen
+* fix a bug
+*
+* Revision 1.4 1993/11/09 18:16:49 chen
+* add binary search routines
+*
+* Revision 1.3 1993/11/03 16:40:55 chen
+* cosmatic change
+*
+* Revision 1.2 1993/11/03 16:39:39 chen
+* add bytpe_swapped flag to EVFILE struct
+*
+ *
+ *
+ *
+ * Routines
+ * --------
+ *
+ * evOpen(char *filename,char *flags,int *descriptor)
+ * evWrite(int descriptor,int *data,int datalen)
+ * evRead(int descriptor,int *data,int *datalen)
+ * evClose(int descriptor)
+ * evIoctl(int descriptor,char *request, void *argp)
+ *
+ * Modifications
+ * -------------
+ * 17-dec-91 cw started coding streams version with local buffers
+ */
+
+#include <stdio.h>
+#include <string.h>
+#include <errno.h>
+#define PMODE 0644
+#include "evfile_msg.h"
+
+typedef struct evfilestruct {
+ FILE *file;
+ int *buf;
+ int *next;
+ int left;
+ int blksiz;
+ int blknum;
+ int rw;
+ int magic;
+ int evnum; /* last events with evnum so far */
+ int byte_swapped;
+} EVFILE;
+
+typedef struct evBinarySearch{
+ int sbk;
+ int ebk;
+ int found_bk;
+ int found_evn;
+ int last_evn;
+} EVBSEARCH;
+
+#define EVBLOCKSIZE 8192
+#define EV_READ 0
+#define EV_WRITE 1
+#define EV_PIPE 2
+#define EV_PIPEWRITE 3
+#define EV_VERSION 1
+#define EV_MAGIC 0xc0da0100
+#define EV_HDSIZ 8
+
+
+#define EV_HD_BLKSIZ 0 /* size of block in longwords */
+#define EV_HD_BLKNUM 1 /* number, starting at 0 */
+#define EV_HD_HDSIZ 2 /* size of header in longwords (=8) */
+#define EV_HD_START 3 /* first start of event in this block */
+#define EV_HD_USED 4 /* number of words used in block (<= BLKSIZ) */
+#define EV_HD_VER 5 /* version of file format (=1) */
+#define EV_HD_RESVD 6 /* (reserved) */
+#define EV_HD_MAGIC 7 /* magic number for error detection */
+
+#define evGetStructure() (EVFILE *)malloc(sizeof(EVFILE))
+
+static int findLastEventWithinBlock(EVFILE *);
+static int copySingleEvent(EVFILE *, int *, int, int);
+static int evSearchWithinBlock(EVFILE *, EVBSEARCH *, int *, int, int *, int, int *);
+static void evFindEventBlockNum(EVFILE *, EVBSEARCH *, int *);
+static int evGetEventNumber(EVFILE *, int);
+static int evGetEventType(EVFILE *);
+static int isRealEventsInsideBlock(EVFILE *, int, int);
+static int physicsEventsInsideBlock(EVFILE *);
+
+extern int int_swap_byte();
+extern void onmemory_swap();
+extern int swapped_fread();
+extern void swapped_intcpy();
+extern void swapped_memcpy();
+
+#if (defined(__osf__) && defined(__alpha)) || defined(__LP64__)
+#define BIT64
+#endif
+
+#ifdef BIT64
+#define MAXHANDLES 10
+EVFILE *handle_list[10]={0,0,0,0,0,0,0,0,0,0};
+#endif
+
+#ifdef AbsoftUNIXFortran
+int evopen
+#else
+int evopen_
+#endif
+(char *filename,char *flags,int *handle,int fnlen,int flen)
+{
+ char *fn, *fl;
+ int status;
+ fn = (char *) malloc(fnlen+1);
+ strncpy(fn,filename,fnlen);
+ fn[fnlen] = 0; /* insure filename is null terminated */
+ fl = (char *) malloc(flen+1);
+ strncpy(fl,flags,flen);
+ fl[flen] = 0; /* insure flags is null terminated */
+ status = evOpen(fn,fl,handle);
+ free(fn);
+ free(fl);
+ return(status);
+}
+
+static char *kill_trailing(char *s, char t)
+{
+ char *e;
+ e = s + strlen(s);
+ if (e>s) { /* Need this to handle NULL string.*/
+ while (e>s && *--e==t); /* Don't follow t's past beginning. */
+ e[*e==t?0:1] = '\0'; /* Handle s[0]=t correctly. */
+ }
+ return s;
+}
+int evOpen(char *fname,char *flags,int *handle)
+{
+#ifdef BIT64
+ int ihandle;
+#endif
+ EVFILE *a;
+ char *cp;
+ int header[EV_HDSIZ];
+ int i;
+ int temp,blk_size;
+ char *filename;
+
+ filename = (char *) malloc(strlen(fname)+1);
+ strcpy(filename,fname);
+ a = evGetStructure(); /* allocate control structure or quit */
+ if (!a) {
+ free(filename);
+ return(S_EVFILE_ALLOCFAIL);
+ }
+ while (*filename==' ') filename++; /* remove leading spaces */
+ /* But don't frell with any other spaces except for the trailing ones */
+#if 0
+ for (cp=filename;*cp!=NULL;cp++) {
+ if ((*cp==' ') || !(isprint(*cp))) *cp='\0';
+ }
+#else
+ kill_trailing(filename,' ');
+#endif
+ switch (*flags) {
+ case '\0': case 'r': case 'R':
+ a->rw = EV_READ;
+ if(strcmp(filename,"-")==0) {
+ a->file = stdin;
+ } else if(filename[0] == '|') {
+ a->file = popen(filename+1,"r");
+ a->rw = EV_PIPE; /* Make sure we know to use pclose */
+ } else {
+ a->file = fopen(filename,"r");
+ if(a->file) {
+ int compressed;
+ char bytes[2];
+ fread(bytes,2,1,a->file); /* Check magic bytes for compressions */
+ if(bytes[0]=='\037' && (bytes[1]=='\213' || bytes[1]=='\235')) {
+ char *pipe_command;
+ fclose(a->file);
+ pipe_command = (char *)malloc(strlen(filename)+strlen("gunzip<")+1);
+ strcpy(pipe_command,"gunzip<");
+ strcat(pipe_command,filename);
+ a->file = popen(pipe_command,"r");
+ free(pipe_command);
+ a->rw = EV_PIPE;
+ } else {
+ fclose(a->file);
+ a->file = fopen(filename,"r");
+ }
+ }
+ }
+ if (a->file) {
+ fread(header,sizeof(header),1,a->file); /* update: check nbytes return */
+ if (header[EV_HD_MAGIC] != EV_MAGIC) {
+ temp = int_swap_byte(header[EV_HD_MAGIC]);
+ if(temp == EV_MAGIC)
+ a->byte_swapped = 1;
+ else{ /* close file and free memory */
+ fclose(a->file);
+ free (a);
+ free(filename);
+ return(S_EVFILE_BADFILE);
+ }
+ }
+ else
+ a->byte_swapped = 0;
+
+ if(a->byte_swapped){
+ blk_size = int_swap_byte(header[EV_HD_BLKSIZ]);
+ a->buf = (int *)malloc(blk_size*4);
+ }
+ else
+ a->buf = (int *) malloc(header[EV_HD_BLKSIZ]*4);
+ if (!(a->buf)) {
+ free(a); /* if can't allocate buffer, give up */
+ free(filename);
+ return(S_EVFILE_ALLOCFAIL);
+ }
+ if(a->byte_swapped){
+ swapped_intcpy((char *)a->buf,(char *)header,EV_HDSIZ*4);
+ fread(&(a->buf[EV_HDSIZ]),4,blk_size-EV_HDSIZ,a->file);
+ }
+ else{
+ memcpy(a->buf,header,EV_HDSIZ*4);
+ fread(a->buf+EV_HDSIZ,4,
+ header[EV_HD_BLKSIZ]-EV_HDSIZ,
+ a->file); /* read rest of block */
+ }
+ a->next = a->buf + (a->buf)[EV_HD_START];
+ a->left = (a->buf)[EV_HD_USED] - (a->buf)[EV_HD_START];
+ }
+ break;
+ case 'w': case 'W':
+ a->rw = EV_WRITE;
+ if(strcmp(filename,"-")==0) {
+ a->file = stdout;
+ } else if(filename[0] == '|') {
+ a->file = popen(filename+1,"r");
+ a->rw = EV_PIPEWRITE; /* Make sure we know to use pclose */
+ } else {
+ a->file = fopen(filename,"w");
+ }
+ if (a->file) {
+ a->buf = (int *) malloc(EVBLOCKSIZE*4);
+ if (!(a->buf)) {
+ free(a);
+ free(filename);
+ return(S_EVFILE_ALLOCFAIL);
+ }
+ a->buf[EV_HD_BLKSIZ] = EVBLOCKSIZE;
+ a->buf[EV_HD_BLKNUM] = 0;
+ a->buf[EV_HD_HDSIZ] = EV_HDSIZ;
+ a->buf[EV_HD_START] = 0;
+ a->buf[EV_HD_USED] = EV_HDSIZ;
+ a->buf[EV_HD_VER] = EV_VERSION;
+ a->buf[EV_HD_RESVD] = 0;
+ a->buf[EV_HD_MAGIC] = EV_MAGIC;
+ a->next = a->buf + EV_HDSIZ;
+ a->left = EVBLOCKSIZE - EV_HDSIZ;
+ a->evnum = 0;
+ }
+ break;
+ default:
+ free(a);
+ free(filename);
+ return(S_EVFILE_UNKOPTION);
+ }
+ if (a->file) {
+ a->magic = EV_MAGIC;
+ a->blksiz = a->buf[EV_HD_BLKSIZ];
+ a->blknum = a->buf[EV_HD_BLKNUM];
+#ifdef BIT64
+ for(ihandle=0;ihandle<MAXHANDLES;ihandle++){
+ if(handle_list[ihandle]==0) {
+ handle_list[ihandle] = a;
+ *handle = ihandle+1;
+ free(filename);
+ return(S_SUCCESS);
+ }
+ }
+ *handle = 0; /* No slots left */
+ free(a);
+ free(filename);
+ return(S_EVFILE_BADHANDLE); /* A better error code would help */
+#else
+ *handle = (int) a;
+ free(filename);
+ return(S_SUCCESS);
+#endif
+ } else {
+ free(a);
+#ifdef DEBUG
+ fprintf(stderr,"evOpen: Error opening file %s, flag %s\n",
+ filename,flags);
+ perror(NULL);
+#endif
+ *handle = 0;
+ free(filename);
+ return(errno);
+ }
+ free(filename);
+
+}
+
+#ifdef AbsoftUNIXFortran
+int evread
+#else
+int evread_
+#endif
+(int *handle,int *buffer,int *buflen)
+{
+ return(evRead(*handle,buffer,*buflen));
+}
+
+int evRead(int handle,int *buffer,int buflen)
+{
+ EVFILE *a;
+ int nleft,ncopy,error,status;
+ int *temp_buffer,*temp_ptr;
+
+#ifdef BIT64
+ a = handle_list[handle-1];
+#else
+ a = (EVFILE *)handle;
+#endif
+ if (a->byte_swapped){
+ temp_buffer = (int *)malloc(buflen*sizeof(int));
+ temp_ptr = temp_buffer;
+ }
+ if (a->magic != EV_MAGIC) return(S_EVFILE_BADHANDLE);
+ if (a->left<=0) {
+ error = evGetNewBuffer(a);
+ if (error) return(error);
+ }
+ if (a->byte_swapped)
+ nleft = int_swap_byte(*(a->next)) + 1;
+ else
+ nleft = *(a->next) + 1; /* inclusive size */
+ if (nleft < buflen) {
+ status = S_SUCCESS;
+ } else {
+ status = S_EVFILE_TRUNC;
+ nleft = buflen;
+ }
+ while (nleft>0) {
+ if (a->left<=0) {
+ error = evGetNewBuffer(a);
+ if (error) return(error);
+ }
+ ncopy = (nleft <= a->left) ? nleft : a->left;
+ if (a->byte_swapped){
+ memcpy(temp_buffer,a->next,ncopy*4);
+ temp_buffer += ncopy;
+ }
+ else{
+ memcpy(buffer,a->next,ncopy*4);
+ buffer += ncopy;
+ }
+ nleft -= ncopy;
+ a->next += ncopy;
+ a->left -= ncopy;
+ }
+ if (a->byte_swapped){
+ swapped_memcpy((char *)buffer,(char *)temp_ptr,buflen*sizeof(int));
+ free(temp_ptr);
+ }
+ return(status);
+}
+
+int evGetNewBuffer(a)
+ EVFILE *a;
+{
+ int i,nread,status;
+ status = S_SUCCESS;
+ if (feof(a->file)) return(EOF);
+ clearerr(a->file);
+ a->buf[EV_HD_MAGIC] = 0;
+ nread = fread(a->buf,4,a->blksiz,a->file);
+ if (a->byte_swapped){
+ for(i=0;i<EV_HDSIZ;i++)
+ onmemory_swap(&(a->buf[i]));
+ }
+ if (feof(a->file)) return(EOF);
+ if (ferror(a->file)) return(ferror(a->file));
+ if (nread != a->blksiz) return(errno);
+ if (a->buf[EV_HD_MAGIC] != EV_MAGIC) {
+ /* fprintf(stderr,"evRead: bad header\n"); */
+ return(S_EVFILE_BADFILE);
+ }
+ a->blknum++;
+ if (a->buf[EV_HD_BLKNUM] != a->blknum) {
+ /* fprintf(stderr,"evRead: bad block number %x should be %x\n",
+ a->buf[EV_HD_BLKNUM],a->blknum); */
+ status = S_EVFILE_BADBLOCK;
+ }
+ a->next = a->buf + (a->buf)[EV_HD_HDSIZ];
+ a->left = (a->buf)[EV_HD_USED] - (a->buf)[EV_HD_HDSIZ];
+ if (a->left<=0)
+ return(S_EVFILE_UNXPTDEOF);
+ else
+ return(status);
+}
+
+#ifdef AbsoftUNIXFortran
+int evwrite
+#else
+int evwrite_
+#endif
+(int *handle,int *buffer)
+{
+ return(evWrite(*handle,buffer));
+}
+
+int evWrite(int handle,int *buffer)
+{
+ EVFILE *a;
+ int nleft,ncopy,error;
+#ifdef BIT64
+ a = handle_list[handle-1];
+#else
+ a = (EVFILE *)handle;
+#endif
+ if (a->magic != EV_MAGIC) return(S_EVFILE_BADHANDLE);
+ if (a->buf[EV_HD_START]==0) a->buf[EV_HD_START] = a->next - a->buf;
+ a->evnum = a->evnum + 1; /* increase ev number every time you call evWrite */
+ nleft = buffer[0] + 1; /* inclusive length */
+ while (nleft>0) {
+ ncopy = (nleft <= a->left) ? nleft : a->left;
+ memcpy(a->next,buffer,ncopy*4);
+ buffer += ncopy;
+ nleft -= ncopy;
+ a->next += ncopy;
+ a->left -= ncopy;
+ if (a->left<=0) {
+ error = evFlush(a);
+ if (error) return(error);
+ }
+ }
+ return(S_SUCCESS);
+}
+
+int evFlush(a)
+ EVFILE *a;
+{
+ int nwrite;
+ clearerr(a->file);
+ a->buf[EV_HD_USED] = a->next - a->buf;
+ a->buf[EV_HD_RESVD] = a->evnum;
+ nwrite = fwrite(a->buf,4,a->blksiz,a->file);
+ if (ferror(a->file)) return(ferror(a->file));
+ if (nwrite != a->blksiz) return(errno);
+ a->blknum++;
+ a->buf[EV_HD_BLKSIZ] = a->blksiz;
+ a->buf[EV_HD_BLKNUM] = a->blknum;
+ a->buf[EV_HD_HDSIZ] = EV_HDSIZ;
+ a->buf[EV_HD_START] = 0;
+ a->buf[EV_HD_USED] = EV_HDSIZ;
+ a->buf[EV_HD_VER] = EV_VERSION;
+ a->buf[EV_HD_RESVD] = 0;
+ a->buf[EV_HD_MAGIC] = EV_MAGIC;
+ a->next = a->buf + EV_HDSIZ;
+ a->left = a->blksiz - EV_HDSIZ;
+ return(S_SUCCESS);
+}
+
+#ifdef AbsoftUNIXFortran
+int evioctl
+#else
+int evioctl_
+#endif
+(int *handle,char *request,void *argp,int reqlen)
+{
+ char *req;
+ int status;
+ req = (char *)malloc(reqlen+1);
+ strncpy(req,request,reqlen);
+ req[reqlen]=0; /* insure request is null terminated */
+ status = evIoctl(*handle,req,argp);
+ free(req);
+ return(status);
+}
+
+int evIoctl(int handle,char *request,void *argp)
+{
+ EVFILE *a;
+#ifdef BIT64
+ a = handle_list[handle-1];
+#else
+ a = (EVFILE *)handle;
+#endif
+ if (a->magic != EV_MAGIC) return(S_EVFILE_BADHANDLE);
+ switch (*request) {
+ case 'b': case 'B':
+ if (a->rw != EV_WRITE && a->rw != EV_PIPEWRITE) return(S_EVFILE_BADSIZEREQ);
+ if (a->blknum != 0) return(S_EVFILE_BADSIZEREQ);
+ if (a->buf[EV_HD_START] != 0) return(S_EVFILE_BADSIZEREQ);
+ free (a->buf);
+ a->blksiz = *(int *) argp;
+ a->left = a->blksiz - EV_HDSIZ;
+ a->buf = (int *) malloc(a->blksiz*4);
+ if (!(a->buf)) {
+ a->magic = 0;
+ free(a); /* if can't allocate buffer, give up */
+ return(S_EVFILE_ALLOCFAIL);
+ }
+ a->buf[EV_HD_BLKSIZ] = EVBLOCKSIZE;
+ a->buf[EV_HD_BLKNUM] = 0;
+ a->buf[EV_HD_HDSIZ] = EV_HDSIZ;
+ a->buf[EV_HD_START] = 0;
+ a->buf[EV_HD_USED] = EV_HDSIZ;
+ a->buf[EV_HD_VER] = EV_VERSION;
+ a->buf[EV_HD_RESVD] = 0;
+ a->buf[EV_HD_MAGIC] = EV_MAGIC;
+ break;
+ default:
+ return(S_EVFILE_UNKOPTION);
+ }
+ return(S_SUCCESS);
+}
+
+#ifdef AbsoftUNIXFortran
+int evclose
+#else
+int evclose_
+#endif
+(int *handle)
+{
+ return(evClose(*handle));
+}
+
+int evClose(int handle)
+{
+ EVFILE *a;
+ int status, status2;
+#ifdef BIT64
+ a = handle_list[handle-1];
+#else
+ a = (EVFILE *)handle;
+#endif
+ if (a->magic != EV_MAGIC) return(S_EVFILE_BADHANDLE);
+ if(a->rw == EV_WRITE || a->rw==EV_PIPEWRITE)
+ status = evFlush(a);
+ if(a->rw == EV_PIPE) {
+ status2 = pclose(a->file);
+ } else {
+ status2 = fclose(a->file);
+ }
+#ifdef BIT64
+ handle_list[handle-1] = 0;
+#endif
+ free((char *)(a->buf));
+ free((char *)a);
+ if (status==0) status = status2;
+ return(status);
+}
+
+
+/******************************************************************
+ * int evOpenSearch(int, int *) *
+ * Description: *
+ * Open for binary search on data blocks *
+ * return last physics event number *
+ *****************************************************************/
+int evOpenSearch(int handle, int *b_handle)
+{
+#ifdef BIT64
+ int ihandle;
+#endif
+ EVFILE *a;
+ EVBSEARCH *b;
+ int found = 0, temp, status, i = 1;
+ int last_evn, ev_type, bknum;
+ int header[EV_HDSIZ];
+
+#ifdef BIT64
+ a = handle_list[handle-1];
+#else
+ a = (EVFILE *)handle;
+#endif
+ b = (EVBSEARCH *)malloc(sizeof(EVBSEARCH));
+ if(b == NULL){
+ fprintf(stderr,"Cannot allocate memory for EVBSEARCH structure!\n");
+ exit(1);
+ }
+ fseek(a->file, 0L, SEEK_SET);
+ fread(header, sizeof(header), 1, a->file);
+ if(a->byte_swapped)
+ temp = int_swap_byte(header[EV_HD_BLKNUM]);
+ else
+ temp = header[EV_HD_BLKNUM];
+ b->sbk = temp;
+ /* jump to the end of file */
+ fseek(a->file, 0L, SEEK_END);
+ while(!found){
+ /* jump back to the beginning of the block */
+ fseek(a->file, (-1)*a->blksiz*4*i, SEEK_END);
+ if((bknum = physicsEventsInsideBlock(a)) >= 0){
+ b->ebk = bknum;
+ break;
+ }
+ else
+ i++;
+ }
+ /* the file pointer will point to the first physics event in the block */
+ last_evn = findLastEventWithinBlock(a);
+ b->found_bk = -1;
+ b->found_evn = -1;
+ b->last_evn = last_evn;
+#ifdef BIT64
+ for(ihandle=0;ihandle<MAXHANDLES;ihandle++){
+ if(handle_list[ihandle]==0) {
+ handle_list[ihandle] = (EVFILE *)b;
+ *b_handle = ihandle+1;
+ return last_evn;
+ }
+ }
+ *b_handle = 0; /* No slots left */
+ free(b);
+ return(-1); /* A better error code would help */
+#else
+ *b_handle = (int) b;
+ return last_evn;
+#endif
+}
+
+/*********************************************************************
+ * static int findLastEventWithinBlock(EVFILE *) *
+ * Description: *
+ * Doing sequential search on a block pointed by a *
+ * return last event number in the block *
+ * the pointer to the file has been moved to the beginning *
+ * of the fisrt event already by evOpenSearch() *
+ ********************************************************************/
+static int findLastEventWithinBlock(EVFILE *a)
+{
+ int header, t_header, found = 0;
+ int ev_size, temp, evn = 0, last_evn = 0;
+ int ev_type;
+ int first_time = 0;
+
+ while(!found){
+ fread(&header, sizeof(int), 1, a->file);
+ if(a->byte_swapped)
+ ev_size = int_swap_byte(header) + 1;
+ else
+ ev_size = header + 1;
+ /* read event type */
+ ev_type = evGetEventType(a);
+ a->left = a->left - ev_size; /* file pointer stays */
+ if(a->left <= 0){ /* no need to distinguish the special event */
+ if(ev_type < 16){ /* physics event */
+ first_time++;
+ fseek(a->file, 3*4, SEEK_CUR);
+ fread(&header, sizeof(int), 1, a->file);
+ if(a->byte_swapped)
+ evn = int_swap_byte(header);
+ else
+ evn = header;
+ found = 1;
+ }
+ else{
+ if (first_time == 0){
+ evn = -1;
+ found = 1;
+ }
+ else{
+ evn = last_evn;
+ found = 1;
+ }
+ }
+ }
+ else{
+ if(ev_type < 16){
+ first_time++;
+ fseek(a->file, 3*4, SEEK_CUR);
+ fread(&header, sizeof(int), 1, a->file);
+ if(a->byte_swapped)
+ evn = int_swap_byte(header);
+ else
+ evn = header;
+ last_evn = evn;
+ fseek(a->file,(ev_size - 5)*4, SEEK_CUR);
+ }
+ else{
+ fseek(a->file, (ev_size - 1)*4, SEEK_CUR);
+ }
+ }
+ }
+ return evn;
+}
+
+/********************************************************************
+ * int evSearch(int, int, int, int *, int, int *) *
+ * Description: *
+ * Doing binary search for event number evn, -1 failure *
+ * Copy event to buffer with buffer length buflen *
+ * This routine must be called after evOpenSearch() *
+ * return 0: found the event *
+ * return -1: the event number bigger than largest ev number *
+ * return 1: cannot find the event number *
+ *******************************************************************/
+int evSearch(int handle, int b_handle, int evn, int *buffer, int buflen, int *size)
+{
+ EVFILE *a;
+ EVBSEARCH *b;
+ int start,end, mid;
+ int found;
+
+#ifdef BIT64
+ a = handle_list[handle-1];
+ b = (EVBSEARCH *)handle_list[b_handle-1];
+#else
+ a = (EVFILE *)handle;
+ b = (EVBSEARCH *)b_handle;
+#endif
+
+ if(evn > b->last_evn)
+ return -1;
+
+ if(b->found_bk < 0){
+ start = b->sbk;
+ end = b->ebk;
+ mid = (start + end)/2.0;
+ }
+ else{
+ if(evn >= b->found_evn){
+ start = b->found_bk;
+ end = b->ebk;
+ mid = (start + end)/2.0;
+ }
+ else{
+ start = b->sbk;
+ end = b->found_bk;
+ mid = (start + end)/2.0;
+ }
+ }
+ while(start <= end){
+ found = evSearchWithinBlock(a, b, &mid, evn, buffer, buflen, size);
+ if(found < 0){ /* lower block */
+ end = mid - 1;
+ mid = (start + end)/2.0;
+ }
+ else if(found > 0){ /* upper block */
+ start = mid + 1;
+ mid = (start + end)/2.0;
+ }
+ else if(found == 0){ /*found block and evn */
+ break;
+ }
+ else
+ return found;
+ }
+ if(start <= end){
+ b->found_bk = mid;
+ b->found_evn = evn;
+ return 0;
+ }
+ else{
+ b->found_bk = -1;
+ return 1;
+ }
+}
+
+
+/****************************************************************************
+ * static int evSearchWithinBlock(EVFILE *, EVBSEARCH *, int *,int, int * *
+ * int, int * ) *
+ * Description: *
+ * Doing sequential search on a particular block to find out event *
+ * number evn *
+ * return 0: found *
+ * return -1: evn < all events in the block *
+ * return 1: evn > all events in the block *
+ ***************************************************************************/
+static int evSearchWithinBlock(EVFILE *a, EVBSEARCH *b, int *bknum,
+ int evn, int *buffer, int buflen, int *size)
+{
+ int header[EV_HDSIZ], temp, ev_size;
+ int buf[EV_HDSIZ], status;
+ int found = 0, t_evn, block_num;
+ int ev_type, t_temp;
+
+ evFindEventBlockNum(a, b, bknum);
+ block_num = *bknum;
+
+ /* check first event, if its event number is greater than
+ * requested event number, return -1
+ * the pointer pointing to file has been moved in the previous
+ * subroutines
+ */
+ fread(&temp,sizeof(int),1,a->file);
+ if(a->byte_swapped)
+ ev_size = int_swap_byte(temp) + 1;
+ else
+ ev_size = temp + 1;
+
+ a->left = a->left - ev_size;
+ t_evn = evGetEventNumber(a, ev_size); /* file pointer stays here */
+
+ if(t_evn == evn){
+ fseek(a->file, (-1)*4, SEEK_CUR); /* go to top of event */
+ *size = ev_size;
+ status = copySingleEvent(a, buffer, buflen, ev_size);
+ return status;
+ }
+ else if(t_evn > evn) /* no need to search any more */
+ return -1;
+ else{ /* need to search more */
+ if(a->left <=0) /* no more events left */
+ return 1;
+ else{
+ fseek(a->file, (ev_size-1)*4, SEEK_CUR);
+ while(!found && a->left > 0){
+ fread(&temp, sizeof(int), 1, a->file);
+ if(a->byte_swapped)
+ ev_size = int_swap_byte(temp) + 1;
+ else
+ ev_size = temp + 1;
+ /* read event type */
+ ev_type = evGetEventType(a); /* file pointer fixed here */
+
+ a->left = a->left - ev_size;
+ if(a->left <= 0){ /* this is the last event */
+ if(ev_type < 16){ /* physics event here */
+ t_evn = evGetEventNumber(a, ev_size); /* pinter stays */
+ /* check current event number */
+ if(t_evn == evn){
+ fseek(a->file, (-1)*4, SEEK_CUR);
+ found = 1;
+ *size = ev_size;
+ return (copySingleEvent(a, buffer, buflen, ev_size));
+ }
+ else
+ return 1;
+ }
+ else /* last event is not a physics event, no match */
+ return 1;
+ }
+ else{ /* not last event */
+ if(ev_type < 16){
+ t_evn = evGetEventNumber(a, ev_size);
+ /* check current event number */
+ if(t_evn == evn){
+ fseek(a->file, (-1)*4, SEEK_CUR);
+ *size = ev_size;
+ found = 1;
+ return (copySingleEvent(a, buffer, buflen, ev_size));
+ }
+ else{ /* go to next event */
+ fseek(a->file, (ev_size-1)*4, SEEK_CUR);
+ }
+ }
+ else /* special event go to next event */
+ fseek(a->file, (ev_size - 1)*4, SEEK_CUR);
+ } /* end of not last event case*/
+ } /* end of search event loop*/
+ }
+ }
+}
+
+
+/********************************************************************
+ * static void evFindEventBlockNum(EVFILE *, EVBSEARCH *, int *) *
+ * Description: *
+ * find out real block number in the case of this block *
+ * has one big event just crossing it *
+ *******************************************************************/
+static void evFindEventBlockNum(EVFILE *a, EVBSEARCH *b, int *bknum)
+{
+ int header[EV_HDSIZ], block_num;
+ int buf[EV_HDSIZ];
+ int found = 0, temp, nleft;
+
+ block_num = *bknum;
+ while(block_num <= b->ebk){
+ fseek(a->file, a->blksiz*block_num*4, SEEK_SET);
+ fread(header, sizeof(header), 1, a->file);
+ if(a->byte_swapped)
+ swapped_intcpy((char *)buf, (char *)header, EV_HDSIZ*4);
+ else
+ memcpy(buf, header, EV_HDSIZ*4);
+ if(buf[EV_HD_START] > 0){
+ fseek(a->file, 4*(buf[EV_HD_START]-EV_HDSIZ), SEEK_CUR);
+ nleft = buf[EV_HD_USED] - buf[EV_HD_START];
+ if(isRealEventsInsideBlock(a,block_num,nleft)){
+ *bknum = block_num;
+ return;
+ }
+ block_num++;
+ }
+ else
+ block_num++;
+ }
+ /* cannot find right block this way, try reverse direction */
+ block_num = *bknum;
+ while(block_num >= b->sbk){
+ fseek(a->file, a->blksiz*block_num*4, SEEK_SET);
+ fread(header, sizeof(header), 1, a->file);
+ if(a->byte_swapped)
+ swapped_intcpy((char *)buf,(char *)header, EV_HDSIZ*4);
+ else
+ memcpy((char *)buf, (char *)header, EV_HDSIZ*4);
+ if(buf[EV_HD_START] > 0){
+ fseek(a->file, 4*(buf[EV_HD_START]-EV_HDSIZ), SEEK_CUR);
+ nleft = buf[EV_HD_USED] - buf[EV_HD_START];
+ if(isRealEventsInsideBlock(a,block_num, nleft)){
+ *bknum = block_num;
+ return;
+ }
+ block_num--;
+ }
+ else
+ block_num--;
+ }
+ fprintf(stderr,"Cannot find out event offset in any of the blocks, Exit!\n");
+ exit(1);
+}
+
+/*************************************************************************
+ * static int isRealEventInsideBlock(EVFILE *, int, int) *
+ * Description: *
+ * Find out whether there is a real event inside this block *
+ * return 1: yes, return 0: no *
+ ************************************************************************/
+static int isRealEventsInsideBlock(EVFILE *a, int bknum, int old_left)
+{
+ int nleft = old_left;
+ int ev_size, temp, ev_type;
+
+ while(nleft > 0){
+ fread(&temp, sizeof(int), 1, a->file);
+ if(a->byte_swapped)
+ ev_size = int_swap_byte(temp) + 1;
+ else
+ ev_size = temp + 1;
+
+ ev_type = evGetEventType(a); /* file pointer stays */
+ if(ev_type < 16){
+ fseek(a->file, (-1)*sizeof(int), SEEK_CUR); /* rewind to head of this event */
+ break;
+ }
+ else{
+ nleft = nleft - ev_size;
+ fseek(a->file, 4*(ev_size - 1), SEEK_CUR);
+ }
+ }
+ if(nleft <= 0)
+ return 0;
+ else{
+ a->left = nleft;
+ return 1;
+ }
+}
+
+/*****************************************************************************
+ * static int copySingleEvent(EVFILE *, int *, int, int) *
+ * Description: *
+ * copy a single event to buffer by using fread. *
+ * starting point is given by EVFILE *a *
+ ****************************************************************************/
+static int copySingleEvent(EVFILE *a, int *buffer, int buflen, int ev_size)
+{
+ int *temp_buffer, *temp_ptr, *ptr;
+ int status, nleft, temp, block_left;
+ int ncopy;
+
+
+ if(a->byte_swapped){
+ temp_buffer = (int *)malloc(buflen*sizeof(int));
+ temp_ptr = temp_buffer;
+ }
+ else{
+ ptr = buffer;
+ }
+
+ if(buflen < ev_size){
+ status = S_EVFILE_TRUNC;
+ nleft = buflen;
+ }
+ else{
+ status = S_SUCCESS;
+ nleft = ev_size;
+ }
+ if(a->left < 0){
+ block_left = ev_size + a->left;
+ if(nleft <= block_left){
+ if(a->byte_swapped){
+ fread((char *)temp_ptr, nleft*4, 1, a->file);
+ }
+ else
+ fread((char *)ptr, nleft*4, 1, a->file);
+ }
+ else{
+ ncopy = block_left;
+ while(nleft > 0){
+ if(a->byte_swapped){
+ fread((char *)temp_ptr, ncopy*4, 1, a->file);
+ temp_ptr = temp_ptr + ncopy;
+ }
+ else{
+ fread((char *)ptr, ncopy*4, 1, a->file);
+ ptr = ptr + ncopy;
+ }
+ nleft = nleft - ncopy;
+ if(nleft > a->blksiz - EV_HDSIZ){
+ fseek(a->file, EV_HDSIZ*4, SEEK_CUR);
+ ncopy = a->blksiz - EV_HDSIZ;
+ }
+ else if(nleft > 0){
+ fseek(a->file, EV_HDSIZ*4,SEEK_CUR);
+ ncopy = nleft;
+ }
+ }
+ if(a->byte_swapped)
+ temp_ptr = temp_buffer;
+ else
+ ptr = buffer;
+ }
+ }
+ else{
+ if(a->byte_swapped){
+ fread(temp_ptr, ev_size*4, 1, a->file);
+ }
+ else{
+ fread(ptr, ev_size*4, 1, a->file);
+ }
+ }
+
+ if(a->byte_swapped){
+ swapped_memcpy((char *)buffer, (char *)temp_ptr, buflen*sizeof(int));
+ free(temp_ptr);
+ }
+ return (status);
+}
+
+/***********************************************************************
+ * int evCloseSearch(int ) *
+ * Description: *
+ * Close evSearch process, release memory *
+ **********************************************************************/
+int evCloseSearch(int b_handle)
+{
+ EVBSEARCH *b;
+#ifdef BIT64
+ b = (EVBSEARCH *)handle_list[b_handle-1];
+ handle_list[b_handle-1] = 0;
+#else
+ b = (EVBSEARCH *)b_handle;
+#endif
+ free((char *)b);
+}
+
+/**********************************************************************
+ * static int evGeteventNumber(EVFILE *, int) *
+ * Description: *
+ * get event number starting from event head. *
+ *********************************************************************/
+static int evGetEventNumber(EVFILE *a, int ev_size)
+{
+ int temp, evn, nleft;
+
+ nleft = a->left + ev_size;
+ if(nleft >= 5)
+ fseek(a->file, 3*4, SEEK_CUR);
+ else
+ fseek(a->file, (EV_HDSIZ+3)*4, SEEK_CUR);
+ fread(&temp, sizeof(int), 1, a->file);
+ if(a->byte_swapped)
+ evn = int_swap_byte(temp);
+ else
+ evn = temp;
+
+ if(nleft >= 5)
+ fseek(a->file, (-1)*4*4, SEEK_CUR);
+ else
+ fseek(a->file,(-1)*(EV_HDSIZ + 4)*4, SEEK_CUR);
+
+ return evn;
+}
+
+static int evGetEventType(EVFILE *a)
+{
+ int ev_type, temp, t_temp;
+
+ if(a->left == 1) /* event type long word is in the following block */
+ fseek(a->file, (EV_HDSIZ)*4,SEEK_CUR);
+ if(a->byte_swapped){
+ fread(&t_temp, sizeof(int), 1, a->file);
+ swapped_intcpy((char *)&temp, (char *)&t_temp, sizeof(int));
+ }
+ else
+ fread(&temp, sizeof(int), 1, a->file);
+ ev_type = (temp >> 16)&(0x0000ffff);
+
+ if(a->left == 1)
+ fseek(a->file, (-1)*(EV_HDSIZ + 1)*4, SEEK_CUR);
+ else
+ fseek(a->file, (-1)*4, SEEK_CUR);
+
+ return ev_type;
+}
+
+
+/*************************************************************************
+ * static int physicsEventsInsideBlock(a) *
+ * Description: *
+ * Check out whether this block pointed by a contains any physics *
+ * events *
+ * return -1: contains no physics *
+ * return >= 0 : yes, contains physics event, with block number *
+ * the file pointer will stays at the begining of the first physics *
+ * event inside the block *
+ ************************************************************************/
+static int physicsEventsInsideBlock(EVFILE *a)
+{
+ int header[EV_HDSIZ], buf[EV_HDSIZ];
+ int nleft, temp, ev_size, ev_type;
+
+ /* copy block header information */
+ if(a->byte_swapped){
+ fread(header, sizeof(header), 1, a->file);
+ swapped_intcpy((char *)buf, (char *)header, EV_HDSIZ*4);
+ }
+ else
+ fread(buf, sizeof(buf), 1, a->file);
+ /* search first event inside this block */
+ if (buf[EV_HD_START] < 0)
+ return 0;
+ else{
+ /* jump to the first event */
+ fseek(a->file, 4*(buf[EV_HD_START] - EV_HDSIZ), SEEK_CUR);
+ nleft = buf[EV_HD_USED] - buf[EV_HD_START];
+ while (nleft > 0){
+ fread(&temp, sizeof(int), 1, a->file);
+ if(a->byte_swapped)
+ ev_size = int_swap_byte(temp) + 1;
+ else
+ ev_size = temp + 1;
+ /* check event type and file pointer stays */
+ ev_type = evGetEventType(a);
+ if(ev_type < 16) { /*physics event */
+ fseek(a->file, (-1)*sizeof(int), SEEK_CUR);
+ a->left = nleft;
+ return buf[EV_HD_BLKNUM];
+ }
+ else{
+ nleft = nleft - ev_size;
+ fseek(a->file, 4*(ev_size - 1), SEEK_CUR);
+ }
+ }
+ }
+ return 0;
+}
diff --git a/CODA/evtest.c b/CODA/evtest.c
new file mode 100644
index 0000000..551a26f
--- /dev/null
+++ b/CODA/evtest.c
@@ -0,0 +1,134 @@
+/*-----------------------------------------------------------------------------
+ * Copyright (c) 1991,1992 Southeastern Universities Research Association,
+ * Continuous Electron Beam Accelerator Facility
+ *
+ * This software was developed under a United States Government license
+ * described in the NOTICE file included as part of this distribution.
+ *
+ * CEBAF Data Acquisition Group, 12000 Jefferson Ave., Newport News, VA 23606
+ * Email: coda@cebaf.gov Tel: (804) 249-7101 Fax: (804) 249-7363
+ *-----------------------------------------------------------------------------
+ *
+ * Description:
+ * Event I/O test program
+ *
+ * Author: Chip Watson, CEBAF Data Acquisition Group
+ *
+ * Revision History:
+ * $Log: evtest.c,v $
+ * Revision 1.1 1998/12/07 22:11:05 saw
+ * Initial setup
+ *
+* Revision 1.1 94/03/15 11:57:27 11:57:27 heyes (Graham Heyes)
+* Initial revision
+*
+ * Revision 1.2 1992/07/14 19:14:18 watson
+ * Make test event more complex
+ *
+ * Revision 1.1 1992/07/08 18:28:48 watson
+ * Initial revision
+ *
+ */
+
+int *makeEvent();
+#define MIN(a,b) (a<b)? a : b
+
+main()
+{
+ int handle,status,nevents,nlong,handle2;
+ int buffer[2048],i;
+ int *ip;
+
+ printf("Event I/O tests...\n");
+ status = evOpen("single.dat","w",&handle);
+ cePmsg("Opening single.dat",status);
+ ip = makeEvent();
+ status = evWrite(handle,ip);
+ cePmsg("Writing single.dat",status);
+ status = evClose(handle);
+ cePmsg("Closing single.dat",status);
+ status = evOpen("single.dat","r",&handle);
+ nevents=0;
+ while ((status=evRead(handle,buffer,16384))==0) {
+ nevents++;
+ printf(" nevent %d len %d\n",nevents,buffer[0]);
+ if (nevents<=4)
+ nlong = buffer[0]+1;
+ for(ip=buffer;nlong>0;nlong-=8) {
+ for (i=MIN(nlong,8);i>0;i--) printf(" %8x",*ip++);
+ printf("\n");
+ }
+ if (nevents==1) {
+ status = evOpen("multiple.dat","w",&handle2);
+ evWrite(handle2,buffer);
+ evWrite(handle2,buffer);
+ evWrite(handle2,buffer);
+ evClose(handle2);
+ }
+ }
+ printf("last read status %x\n",status);
+ evClose(handle);
+}
+
+
+int *makeEvent()
+{
+ int *bank;
+ int *segment, *longword;
+ short *word;
+ short *packet;
+ float data;
+
+ bank = (int *) malloc(80);
+ bank[0] = 22; /* event length = 18 */
+ bank[1] = 1<<16 | 0x20<<8; /* bank 1 contains segments */
+ {
+ segment = &(bank[2]);
+ segment[0] = 1<<24 | 0x20<<16 | 6; /* segment 1 has 2 segments of len 3 */
+ {
+ segment = &(segment[1]);
+ segment[0] = 2<<24 | 1<<16 | 2; /* segment 2 has 2 longwords */
+ segment[1] = 0x11111111;
+ segment[2] = 0x22222222;
+ segment += 3;
+ segment[0] = 3<<24 | 4<<16 | 2; /* segment 3 has 2 longwords of shorts */
+ {
+ word = (short *) &(segment[1]);
+ word[0] = 0x0000;
+ word[1] = 0x1111;
+ word[2] = 0x2222;
+ word[3] = 0x3333;
+ }
+ }
+ segment = &(bank[2]) + 7; /* point past segment 1 */
+ segment[0] = 4<<24 | 0x34<<16 | 3; /* seg 4 has I*2 packets */
+ {
+ packet = (short *) &(segment[1]);
+ packet[0] = 1<<8 | 2; /* packet 1 */
+ packet[1] = 0x1111;
+ packet[2] = 0x2222;
+ packet += 3;
+ packet[0] = 2<<8 | 2; /* packet 2 */
+ packet[1] = 0x1111;
+ packet[2] = 0x2222;
+ }
+ segment += 4;
+ segment[0] = 5<<24 | 0xF<<16 | 8; /* seg 5 contains repeating structures */
+ {
+ word = (short *) &(segment[1]);
+ word[0] = 2;
+ word[1] = 2<<8 | 2; /* 2(a,b) */
+ word[2] = 0x8000 | 2<<4 | 1; /* 2I */
+ word[3] = 0x8000 | 1<<4 | 2; /* 1F */
+ longword = &(segment[3]);
+ data = 123.456;
+ longword[0] = 0x1111;
+ longword[1] = 0x2222;
+ longword[2] = *(int *)&data;
+ longword[3] = 0x11111111;
+ longword[4] = 0x22222222;
+ longword[5] = *(int *)&data;
+ }
+ }
+ return(bank);
+}
diff --git a/CODA/facility b/CODA/facility
new file mode 100644
index 0000000..72c0d02
--- /dev/null
+++ b/CODA/facility
@@ -0,0 +1,33 @@
+!-----------------------------------------------------------------------------
+! Copyright (c) 1991,1992 Southeastern Universities Research Association,
+! Continuous Electron Beam Accelerator Facility
+!
+! This software was developed under a United States Government license
+! described in the NOTICE file included as part of this distribution.
+!
+! CEBAF Data Acquisition Group, 12000 Jefferson Ave., Newport News, VA 23606
+! Email: coda@cebaf.gov Tel: (804) 249-7101 Fax: (804) 249-7363
+! -----------------------------------------------------------------------------
+!
+! Description:
+! File to assign facility number for Event File I/O
+!
+! Author: Chip Watson, CEBAF Data Acquisition Group
+!
+! Revision History:
+! $Log: facility,v $
+! Revision 1.1 1998/12/07 22:11:05 saw
+! Initial setup
+!
+! Revision 1.1 1992/07/08 18:29:07 watson
+! Initial revision
+!
+!
+!
+! Name Number Filename [String]
+
+evfile 115 evfile.msg Event File I/O
+
+!
+! Note: Name is case sensitive in searching for the corresponding .msg file
+!
\ No newline at end of file
diff --git a/CODA/misc.c b/CODA/misc.c
new file mode 100644
index 0000000..01a5366
--- /dev/null
+++ b/CODA/misc.c
@@ -0,0 +1,7 @@
+#include <time.h>
+int time_(void)
+{
+ time_t now;
+ now = time((time_t *)0);
+ return((int) now);
+}
diff --git a/CODA/swap_util.c b/CODA/swap_util.c
new file mode 100644
index 0000000..efc5f52
--- /dev/null
+++ b/CODA/swap_util.c
@@ -0,0 +1,463 @@
+/*-----------------------------------------------------------------------------
+ * Copyright (c) 1991,1992 Southeastern Universities Research Association,
+ * Continuous Electron Beam Accelerator Facility
+ *
+ * This software was developed under a United States Government license
+ * described in the NOTICE file included as part of this distribution.
+ *
+ * CEBAF Data Acquisition Group, 12000 Jefferson Ave., Newport News, VA 23606
+ * Email: coda@cebaf.gov Tel: (804) 249-7101 Fax: (804) 249-7363
+ *-----------------------------------------------------------------------------
+ *
+ * Description:
+ * Byte swapping utilities
+ *
+ * Author: Jie Chen, CEBAF Data Acquisition Group
+ *
+ * Revision History:
+ * $Log: swap_util.c,v $
+ * Revision 1.1 1998/12/07 22:11:05 saw
+ * Initial setup
+ *
+ * Revision 1.4 1994/08/12 17:15:18 chen
+ * handle char string data type correctly
+ *
+ * Revision 1.3 1994/05/17 14:24:19 chen
+ * fix memory leaks
+ *
+ * Revision 1.2 1994/04/12 18:02:20 chen
+ * fix a bug when there is no event wrapper
+ *
+ * Revision 1.1 1994/04/11 13:09:18 chen
+ * Initial revision
+ *
+* Revision 1.2 1993/11/05 16:54:50 chen
+* change comment
+*
+* Revision 1.1 1993/10/27 09:39:44 heyes
+* Initial revision
+*
+ * Revision 1.1 93/08/30 19:13:49 19:13:49 chen (Jie chen)
+ * Initial revision
+ *
+ */
+
+#include <stdio.h>
+#include <memory.h>
+#include <errno.h>
+
+typedef struct _stack
+{
+ int length; /* inclusive size */
+ int posi; /* event start position */
+ int type; /* data type */
+ int tag; /* tag value */
+ int num; /* num field */
+ struct _stack *next;
+}evStack;
+
+typedef struct _lk
+{
+ int head_pos;
+ int type;
+}LK_AHEAD; /* find out header */
+
+static evStack *init_evStack(),*evStack_top();
+static void evStack_popoff();
+static void evStack_pushon();
+static void evStack_free();
+
+/*********************************************************
+ * int int_swap_byte(int input) *
+ * get integer 32 bit input and output swapped byte *
+ * integer *
+ ********************************************************/
+int int_swap_byte(int input)
+{
+ int temp,i,len;
+ char *buf,*temp_buf;
+
+ len = sizeof(int);
+ buf = (char *)malloc(sizeof(int));
+ temp_buf = (char *)malloc(sizeof(int));
+ memcpy(temp_buf,&input,sizeof(int));
+ for(i=0;i<sizeof(int);i++)
+ buf[i] = temp_buf[len-i-1];
+ temp = *(int *)(buf);
+ free(buf);free(temp_buf);
+ return temp;
+}
+
+/********************************************************
+ * void onmemory_swap(char *buffer) *
+ * swap byte order of buffer, buffer will be changed *
+ ********************************************************/
+void onmemory_swap(char *buffer)
+{
+ char temp[4],des_temp[4];
+ int i,int_len;
+
+ int_len = sizeof(int);
+ memcpy(temp,buffer,int_len);
+ for(i=0;i<int_len;i++)
+ des_temp[i] = temp[int_len-i-1];
+ memcpy(buffer,des_temp,int_len);
+}
+
+/********************************************************
+ * void swapped_intcpy(void *des,void *source, int size)*
+ * copy source with size size to des, but with byte *
+ * order swapped in the unit of byte *
+ *******************************************************/
+void swapped_intcpy(char *des,char *source,int size)
+{
+ char temp[4],des_temp[4];
+ int i,j,int_len;
+
+ int_len = sizeof(int);
+ i = 0;
+ while(i < size){
+ memcpy(temp,&source[i],sizeof(int));
+ for(j=0;j<int_len;j++)
+ des_temp[j] = temp[int_len - j - 1];
+ memcpy(&(des[i]),des_temp,sizeof(int));
+ i += 4;
+ }
+}
+
+/*******************************************************
+ * void swapped_shortcpy(char *des, char *source, size)*
+ * copy short integer or packet with swapped byte order*
+ * ****************************************************/
+void swapped_shortcpy(char *des,char *source,int size)
+{
+ char temp[2],des_temp[2];
+ int i, j, short_len;
+
+ short_len = sizeof(short);
+ i = 0;
+ while(i < size){
+ memcpy(temp,&source[i],short_len);
+ for(j=0; j<short_len;j++)
+ des_temp[j] = temp[short_len -j -1];
+ memcpy(&(des[i]),des_temp,short_len);
+ i += 2;
+ }
+}
+
+/*******************************************************
+ * void swapped_longcpy(char *des, char *source, size) *
+ * copy 64 bit with swapped byte order *
+ * ****************************************************/
+void swapped_longcpy(char *des,char *source,int size)
+{
+ char temp[8],des_temp[8];
+ int i, j, long_len;
+
+ long_len = 8;
+ i = 0;
+ while(i < size){
+ memcpy(temp,&source[i],long_len);
+ for(j=0; j< long_len;j++)
+ des_temp[j] = temp[long_len -j -1];
+ memcpy(&(des[i]),des_temp,long_len);
+ i += 8;
+ }
+}
+
+/*************************************************************
+ * int swapped_fread(void *ptr, int size, int n_itmes,file)*
+ * fread from a file stream, but return swapped result *
+ ************************************************************/
+int swapped_fread(void *ptr,int size,int n_items,FILE *stream)
+{
+ char *temp_ptr;
+ int nbytes;
+
+ temp_ptr = (char *)malloc(size*n_items);
+ nbytes = fread(temp_ptr,size,n_items,stream);
+ if(nbytes > 0){
+ swapped_intcpy(ptr,temp_ptr,n_items*size);
+ }
+ free(temp_ptr);
+ return(nbytes);
+}
+
+/***********************************************************
+ * void swapped_memcpy(char *buffer,char *source,size) *
+ * swapped memory copy from source to buffer accroding *
+ * to data type *
+ **********************************************************/
+void swapped_memcpy(char *buffer,char *source,int size)
+{
+ evStack *head, *p;
+ LK_AHEAD lk;
+ int int_len, short_len, long_len;
+ int i, j, depth, current_type;
+ int header1, header2;
+ int ev_size, ev_tag, ev_num, ev_type;
+ int bk_size, bk_tag, bk_num, bk_type;
+ int sg_size, sg_tag, sg_num, sg_type;
+ short pk_size, pk_tag, pack;
+ char temp[4],temp2[2];
+
+ int_len = sizeof(int);
+ short_len = sizeof(short);
+ long_len = 8;
+ head = init_evStack();
+ i = 0; /* index pointing to 16 bit word */
+ swapped_intcpy(temp,source,int_len);
+ ev_size = *(int *)(temp); /*ev_size in unit of 32 bit*/
+ memcpy(&(buffer[i*2]),temp,int_len);
+ i += 2;
+ swapped_intcpy(temp,&(source[i*2]),int_len);
+ header2 = *(int *)(temp);
+ ev_tag =(header2 >> 16) & (0x0000ffff);
+ ev_type=(header2 >> 8) & (0x000000ff);
+ ev_num = (header2) & (0x000000ff);
+ memcpy(&(buffer[i*2]),temp,int_len);
+ i += 2;
+
+ if(ev_type >= 0x10){/* data type must be 0x10 bank type */
+ evStack_pushon((ev_size+1)*2,i-4,ev_type,ev_tag,ev_num,head);
+ lk.head_pos = i;
+ lk.type = ev_type;
+ if(lk.type == 0x10)
+ ev_size = ev_size + 1;
+ }
+ else{ /* sometimes event has no wrapper */
+ lk.head_pos = i + 2*(ev_size - 1);
+ lk.type = ev_type;
+ current_type = ev_type;
+ }
+
+/* get into the loop */
+ while (i < ev_size*2){
+ if ((p = evStack_top(head)) != NULL){
+ while(((p = evStack_top(head)) != NULL) && i == (p->length + p->posi)){
+ evStack_popoff(head);
+ head->length -= 1;
+ }
+ }
+ if (i == lk.head_pos){ /* dealing with header */
+ if((p = evStack_top(head)) != NULL)
+ lk.type = (p->type);
+ switch(lk.type){
+ case 0x10:
+ swapped_intcpy(temp,&(source[i*2]),int_len);
+ header1 = *(int *)(temp);
+ bk_size = header1;
+ memcpy(&(buffer[i*2]),temp,int_len);
+ i = i + 2;
+ swapped_intcpy(temp,&(source[i*2]),int_len);
+ header2 = *(int *)(temp);
+ memcpy(&(buffer[i*2]),temp,int_len);
+ bk_tag = (header2 >> 16) & (0x0000ffff);
+ bk_type = (header2 >> 8) & (0x000000ff);
+ bk_num = (header2) & (0x000000ff);
+ depth = head->length; /* tree depth */
+ if (bk_type >= 0x10){ /* contains children */
+ evStack_pushon((bk_size+1)*2,i-2,bk_type,bk_tag,bk_num,head);
+ lk.head_pos = i + 2;
+ head->length += 1;
+ i = i + 2;
+ }
+ else{ /* real data */
+ current_type = bk_type;
+ lk.head_pos = i + bk_size*2;
+ i = i+ 2;
+ }
+ break;
+ case 0x20:
+ swapped_intcpy(temp,&(source[i*2]),int_len);
+ header2 = *(int *)(temp);
+ memcpy(&(buffer[i*2]),temp,int_len);
+ sg_size = (header2) & (0x0000ffff);
+ sg_size = sg_size + 1;
+ sg_tag = (header2 >> 24) & (0x000000ff);
+ sg_type = (header2 >> 16) & (0x000000ff);
+ if(sg_type >= 0x20){ /* contains children */
+ evStack_pushon((sg_size)*2,i,sg_type,sg_tag,NULL,head);
+ lk.head_pos = i + 2;
+ head->length += 1;
+ i = i+ 2;
+ }
+ else{ /* real data */
+ current_type = sg_type;
+ lk.head_pos = i + sg_size*2;
+ i = i + 2;
+ }
+ break;
+ default: /* packet type */
+ swapped_shortcpy(temp2,&(source[i*2]),short_len);
+ pack = *(short *)(temp2);
+ memcpy(&(buffer[i*2]),temp2,short_len);
+ if(pack == 0x0000){ /* empty packet increase by 1 */
+ lk.head_pos = i + 1;
+ i++;
+ }
+ else{
+ pk_tag = (pack >> 8) & (0x00ff);
+ pk_size = (pack) & (0x00ff);
+ current_type = lk.type;
+ lk.head_pos = i + pk_size + 1;
+ i = i + 1;
+ }
+ break;
+ }
+ }
+ else{ /* deal with real data */
+ switch(current_type){
+ case 0x0: /* unknown data type */
+ case 0x1: /* long integer */
+ case 0x2: /* IEEE floating point*/
+ case 0x9: /* VAX floating point */
+ for(j = i; j < lk.head_pos; j=j+2){
+ swapped_intcpy(temp,&(source[j*2]),int_len);
+ memcpy(&(buffer[j*2]),temp,int_len);
+ }
+ i = lk.head_pos;
+ break;
+ case 0x4: /* short integer */
+ case 0x5: /* unsigned integer */
+ case 0x30:
+ case 0x34:
+ case 0x35:
+ for(j = i; j < lk.head_pos; j=j+1){
+ swapped_shortcpy(temp2,&(source[j*2]),short_len);
+ memcpy(&(buffer[j*2]),temp2,short_len);
+ }
+ i = lk.head_pos;
+ break;
+ case 0x3: /* char string */
+ case 0x6:
+ case 0x7:
+ case 0x36:
+ case 0x37:
+ memcpy(&(buffer[i*2]),&(source[i*2]),(lk.head_pos - i)*2);
+ i = lk.head_pos;
+ break;
+ case 0x8: /* 64 bit */
+ case 0xA: /* 64 bit VAX floating point */
+ for(j = i; j < lk.head_pos; j=j+4){
+ swapped_shortcpy(temp,&(source[j*2]),long_len);
+ memcpy(&(buffer[j*2]),temp,long_len);
+ }
+ i = lk.head_pos;
+ break;
+ case 0xF: /* repeating structure, for now */
+ for(j = i; j < lk.head_pos; j=j+2){
+ swapped_intcpy(temp,&(source[j*2]),int_len);
+ memcpy(&(buffer[j*2]),temp,int_len);
+ }
+ i = lk.head_pos;
+ break;
+ default:
+ fprintf(stderr,"Wrong datatype 0x%x\n",current_type);
+ break;
+ }
+ }
+ }
+ evStack_free (head);
+}
+
+
+/**********************************************************
+ * evStack *init_evStack() *
+ * set up the head for event stack *
+ *********************************************************/
+static evStack *init_evStack()
+{
+ evStack *evhead;
+
+ evhead = (evStack *)malloc(1*sizeof(evStack));
+ if(evhead == NULL){
+ fprintf(stderr,"Cannot allocate memory for evStack\n");
+ exit (1);
+ }
+ evhead->length = 0;
+ evhead->posi = 0;
+ evhead->type = 0x0;
+ evhead->tag = 0x0;
+ evhead->num = 0x0;
+ evhead->next = NULL;
+ return evhead;
+}
+
+/*********************************************************
+ * evStack *evStack_top(evStack *head) *
+ * return the top of the evStack pointed by head *
+ ********************************************************/
+static evStack *evStack_top(evStack *head)
+{
+ evStack *p;
+
+ p = head;
+ if (p->next == NULL)
+ return (NULL);
+ else
+ return (p->next);
+}
+
+/********************************************************
+ * void evStack_popoff(evStack *head) *
+ * pop off the top of the stack item *
+ *******************************************************/
+static void evStack_popoff(evStack *head)
+{
+ evStack *p,*q;
+
+ q = head;
+ if(q->next == NULL){
+ fprintf(stderr,"Empty stack\n");
+ return;
+ }
+ p = q->next;
+ q->next = p->next;
+ free (p);
+}
+
+/*******************************************************
+ * void evStack_pushon() *
+ * push an item on to the stack *
+ ******************************************************/
+static void evStack_pushon(int size,
+ int posi,
+ int type,
+ int tag,
+ int num,
+ evStack *head)
+{
+ evStack *p, *q;
+
+ p = (evStack *)malloc(1*sizeof(evStack));
+ if (p == NULL){
+ fprintf(stderr,"Not enough memory for stack item\n");
+ exit(1);
+ }
+ q = head;
+ p->length = size;
+ p->posi = posi;
+ p->type = type;
+ p->tag = tag;
+ p->num = num;
+ p->next = q->next;
+ q->next = p;
+}
+
+/******************************************************
+ * void evStack_free() *
+ * Description: *
+ * Free all memory allocated for the stack *
+ *****************************************************/
+static void evStack_free(evStack *head)
+{
+ evStack *p, *q;
+
+ p = head;
+ while (p != NULL){
+ q = p->next;
+ free (p);
+ p = q;
+ }
+}
diff --git a/CTP/.cvsignore b/CTP/.cvsignore
new file mode 100644
index 0000000..f8c2622
--- /dev/null
+++ b/CTP/.cvsignore
@@ -0,0 +1,5 @@
+O.*
+daVarRpc.h
+daVarRpc_clnt.c
+daVarRpc_svc.c
+daVarRpc_xdr.c
diff --git a/CTP/CVS/Entries b/CTP/CVS/Entries
new file mode 100644
index 0000000..2b19f6a
--- /dev/null
+++ b/CTP/CVS/Entries
@@ -0,0 +1,37 @@
+/.cvsignore/1.1/Wed Jul 7 19:22:54 2004//Tsane
+/Makefile/1.1.24.1/Wed Sep 12 09:57:43 2007//Tsane
+/Makefile.Unix/1.21.8.2/Mon Sep 10 20:08:01 2007//Tsane
+/cfortran.h/1.1.24.1/Mon Sep 10 20:16:06 2007//Tsane
+/cfortran.h.debian/1.1.2.2/Wed Sep 12 09:57:50 2007//Tsane
+/daVar.h/1.3.24.1/Mon Sep 10 21:32:47 2007//Tsane
+/daVarHandlers.c/1.1/Mon Dec 7 22:11:09 1998//Tsane
+/daVarHandlers.h/1.2/Thu Nov 4 20:34:04 1999//Tsane
+/daVarHash.h/1.1/Mon Dec 7 22:11:09 1998//Tsane
+/daVarHashLib.c/1.2/Thu Nov 4 20:34:04 1999//Tsane
+/daVarRegister.c/1.3/Fri Feb 21 20:55:24 2003//Tsane
+/daVarRpc.x/1.2/Thu Nov 4 20:34:04 1999//Tsane
+/daVarRpcProc.c/1.2.24.1/Mon Sep 10 21:32:47 2007//Tsane
+/daVarServ.c/1.3/Fri Feb 21 20:55:24 2003//Tsane
+/fnmatch.h/1.1/Wed Jun 23 13:40:25 1999//Tsane
+/hbook.h/1.1/Mon Dec 7 22:11:10 1998//Tsane
+/makereg.c/1.1.24.1/Mon Sep 10 21:32:47 2007//Tsane
+/th.h/1.2/Thu Nov 4 20:34:05 1999//Tsane
+/thClient.c/1.5.26.1/Thu Mar 3 20:06:21 2011//Tsane
+/thGethit.c/1.2/Thu Nov 4 20:34:05 1999//Tsane
+/thGroup.c/1.5.8.1/Mon Sep 10 21:32:47 2007//Tsane
+/thGroup.h/1.2/Thu Nov 4 20:34:05 1999//Tsane
+/thHandlers.c/1.3.24.1/Mon Sep 10 21:32:47 2007//Tsane
+/thHist.c/1.3/Fri Feb 21 20:55:24 2003//Tsane
+/thInternal.h/1.3/Thu Jul 8 20:06:09 2004//Tsane
+/thLoad.c/1.5/Tue Jul 13 15:04:53 2004//Tsane
+/thParm.c/1.4.26.1/Thu Mar 3 20:08:14 2011//Tsane
+/thReport.c/1.3/Wed Jul 31 20:07:48 2002//Tsane
+/thRootStuff.cpp/1.3/Tue Feb 22 16:25:51 2005//Tsane
+/thTest.c/1.2/Thu Nov 4 20:34:07 1999//Tsane
+/thTestExecute.c/1.2.24.1.2.1/Thu Mar 3 20:09:01 2011//Tsane
+/thTestParse.c/1.4.24.1.2.1/Thu Mar 3 20:09:44 2011//Tsane
+/thTestParse.h/1.1/Mon Dec 7 22:11:13 1998//Tsane
+/thTree.c/1.6.6.1/Mon Sep 10 21:32:47 2007//Tsane
+/thUtils.c/1.3.24.1/Mon Sep 10 21:32:47 2007//Tsane
+/thUtils.h/1.1.24.1/Mon Sep 10 21:32:47 2007//Tsane
+D
diff --git a/CTP/CVS/Repository b/CTP/CVS/Repository
new file mode 100644
index 0000000..dca89bd
--- /dev/null
+++ b/CTP/CVS/Repository
@@ -0,0 +1 @@
+Analyzer/CTP
diff --git a/CTP/CVS/Root b/CTP/CVS/Root
new file mode 100644
index 0000000..6288c3f
--- /dev/null
+++ b/CTP/CVS/Root
@@ -0,0 +1 @@
+whit@cvs.jlab.org:/group/hallc/cvsroot
diff --git a/CTP/CVS/Tag b/CTP/CVS/Tag
new file mode 100644
index 0000000..25d73f7
--- /dev/null
+++ b/CTP/CVS/Tag
@@ -0,0 +1 @@
+Tsane
diff --git a/CTP/Makefile b/CTP/Makefile
new file mode 100644
index 0000000..bc6b01e
--- /dev/null
+++ b/CTP/Makefile
@@ -0,0 +1,3 @@
+ETC=../etc
+
+include $(ETC)/Makefile.NEW
diff --git a/CTP/Makefile.Unix b/CTP/Makefile.Unix
new file mode 100644
index 0000000..efca981
--- /dev/null
+++ b/CTP/Makefile.Unix
@@ -0,0 +1,251 @@
+#
+# $Log: Makefile.Unix,v $
+# Revision 1.21.8.2 2007/09/10 20:08:01 pcarter
+# Implemented changes to allow compilation on RHEL 3,4,5 and MacOSX
+#
+# Revision 1.21.8.1 2007/08/07 18:50:57 puckett
+# Don't want CTP Root trees anymore
+#
+# Revision 1.21 2004/07/08 20:04:33 saw
+# CTP ROOT trees will be compiled in if ROOTSYS is defined.
+# Build dummy CTP ROOT tree commands when ROOTSYS not defined.
+#
+# Revision 1.20 2004/07/02 18:50:00 saw
+# Add ability to compile CTP root code. To use, make sure the ROOTSYS
+# environment variable is set and comment out the line "ROOTSYS=".
+#
+# Revision 1.19 2004/02/26 14:58:29 jones
+# For now , comment out parts dealing with ROOT.
+#
+# Revision 1.18 2003/02/21 20:53:34 saw
+# Force rebuilding of files derived from daVarRpc.x more often.
+#
+# Revision 1.17 1999/11/04 20:34:03 saw
+# Alpha compatibility.
+# New RPC call needed for root event display.
+# Start of code to write ROOT trees (ntuples) from new "tree" block
+#
+# Revision 1.16 1998/12/08 15:40:45 saw
+# Force daVarRpc.h to be built.
+#
+# Revision 1.15 1998/12/07 22:11:08 saw
+# Initial setup
+#
+# Revision 1.14 1998/12/01 14:09:09 saw
+# (SAW) Misc fixes
+#
+# Revision 1.13 96/11/07 20:19:37 20:19:37 saw (Stephen A. Wood)
+# (SAW) Add SunOS and AIX compatibility
+#
+# Revision 1.12 1996/09/04 14:27:44 saw
+# (SAW) Add switches for OSF (Alpha) and some stuff for
+# Linux (NFSDIRECTORY fixes)
+#
+# Revision 1.11 1996/04/29 18:28:53 saw
+# (SAW) New makefile style
+#
+# Revision 1.10 1996/01/16 15:27:20 cdaq
+# (SAW) Add hash table name lookup
+#
+# Revision 1.9 1995/07/28 14:12:36 cdaq
+# (SAW) SGI/IRIX compatibility
+#
+# Revision 1.8 1995/04/06 20:08:28 cdaq
+# (SAW) Fix typo in a RPCGEN line
+#
+# Revision 1.7 1995/03/13 19:46:01 cdaq
+# (SAW) Add linux compile flags
+#
+# Revision 1.6 1994/11/23 15:35:29 cdaq
+# (SAW) Make a libctpclient.a, add NOFNMATCH for ultrix
+#
+# Revision 1.5 1994/10/11 18:31:42 cdaq
+# (SAW) Add thClient
+#
+# Revision 1.4 1994/08/18 04:21:48 cdaq
+# (SAW) Add makereg.c
+#
+# Revision 1.3 1994/08/04 03:49:08 cdaq
+# (SAW) Add gethit facility (thGethit.c)
+#
+# Revision 1.2 1994/06/14 17:54:01 cdaq
+# (SAW) Add report generator (thReport.c)
+#
+# Revision 1.1 1994/04/15 20:28:27 cdaq
+# Initial revision
+#
+
+# To disable compilation of CTP Root Trees, make sure that the environment
+# variable ROOTSYS is undefined, or uncomment "#ROOTSYS=" line below.
+# The same must be done in EXE/Makefile
+
+ROOTSYS=
+
+NEWSTYLE = 1
+
+#Only append to CFLAGS and CXXFLAGS the first time through
+ifeq ($(MAKELEVEL),2)
+ ifeq ($(MYOS),Linux)
+ ifeq ($(F77COMPILER),Absoft)
+ CFLAGS = -DNOF77extname -DAbsoftUNIXFortran # -DAbsoftUNIXFortran for cfortran.h
+ else
+ ifeq ($(OSEXT),TEST)
+ override CFLAGS += -Df2cFortran -b i486-linux -pg # -Df2cFortran for cfortran.h
+ else
+ # CFLAGS = -g -Df2cFortran -b i486-linux -O # -Df2cFortran for cfortran.h
+ override CFLAGS += -Df2cFortran # -Df2cFortran for cfortran.h
+ endif
+ endif
+ override CXXFLAGS += -fno-exceptions -fPIC
+ endif
+
+ ifdef ROOTSYS
+ override CFLAGS += -DROOTTREE
+ override CXXFLAGS += -I$(ROOTSYS)/include
+ endif
+endif
+ifeq ($(MYOS),Linux)
+# -k generates K&R C
+# RPCCOM=rpcgen -b -k
+ RPCCOM=rpcgen -b
+endif
+
+include ../../etc/Makefile
+
+ctp_sources = thTest.c thTestParse.c thTestExecute.c thHandlers.c thParm.c \
+ thUtils.c thLoad.c thGroup.c thHist.c thReport.c thGethit.c \
+ daVarRegister.c daVarRpcProc.c daVarHandlers.c daVarServ.c \
+ daVarRpc_svc.c daVarRpc_xdr.c daVarHashLib.c thTree.c
+ctpclient_sources = daVarRpc_xdr.c daVarRpc_clnt.c thClient.c
+
+lib_targets := $(patsubst %.c, libctp.a(%.o), $(ctp_sources)) \
+ $(patsubst %.c, libctpclient.a(%.o), $(ctpclient_sources))
+
+ifdef ROOTSYS
+cxxsources = thRootStuff.cpp
+lib_targets := $(patsubst %.c, libctp_root.a(%.o), $(ctp_sources)) \
+ $(patsubst %.c, libctpclient_root.a(%.o), $(ctpclient_sources)) \
+ $(patsubst %.cpp, libctp_root.a(%.o), $(cxxsources))
+endif
+
+sources = $(ctpclient_sources) $(ctp_sources) makereg.c
+
+bin_targets = makereg
+
+install-dirs := lib bin
+
+ifeq ($(MYOS),IRIX)
+ CC = gcc
+ CFLAGS = -DNOFNMATCH
+ RPCCOM=rpcgen
+endif
+
+ifeq ($(MYOS),OSF1)
+ CC = cc -verbose
+ CFLAGS = -DNOFNMATCH
+ RPCCOM=rpcgen
+endif
+
+ifeq ($(MYOS),HPUX)
+ CC = gcc
+ifeq ($(OSEXT),TEST)
+ CFLAGS = -Dhpux -D_HPUX_SOURCE -Dextname -g -pg # for gprof
+else
+ CFLAGS = -Dhpux -D_HPUX_SOURCE -Dextname -g
+endif
+ ARFLAGS = frv
+ RPCCOM=rpcgen
+endif
+
+ifeq ($(MYOS),ULTRIX)
+ CC = gcc
+ CFLAGS = -DNOFNMATCH
+ RPCCOM=/usr/site1/rpc/rpcgen
+endif
+
+ifeq ($(MYOS),SunOS)
+ CC = gcc
+ ifeq ($(OSVERSION),4)
+ CFLAGS = -O -DNOFNMATCH
+ else
+ CFLAGS = -O
+ endif
+ RPCCOM = /usr/bin/rpcgen
+endif
+
+ifeq ($(MYOS),AIX)
+ CC = gcc
+ CFLAGS = -O -Dextname
+ RPCCOM = rpcgen
+endif
+
+##library: libctp.a
+
+##$(LIBROOT)/libctp.a: $(libctp_members)
+
+ifdef NFSDIRECTORY
+
+../%.c : $(NFSDIRECTORY)/CTP/%.c
+ ln -s $< $@
+
+../%.h : $(NFSDIRECTORY)/CTP/%.h
+ ln -s $< $@
+
+../%.x : $(NFSDIRECTORY)/CTP/%.x
+ ln -s $< $@
+
+.PRECIOUS: ../%.c ../%.h ../%.x
+endif
+
+makereg: makereg.o
+
+ifdef ROOTSYS
+thRootStuff.o: ../thRootStuff.cpp
+ $(CXX) -o$@ -c $(CXXFLAGS) $<
+endif
+
+RPCDEPENDS_RULE = echo "$(subst .d,.o,$@): \
+ ../$(subst .d,.c,$@) ../daVarRpc.h" >$@
+
+# Include ../daVarRpc.h as a dependency to force it to be made before
+# dependencies on non-autogenerated sources are done
+
+daVarRpc_xdr.d: ../daVarRpc.h
+ echo remaking $@
+ $(RPCDEPENDS_RULE)
+
+daVarRpc_clnt.d: ../daVarRpc.h
+ echo remaking $@
+ $(RPCDEPENDS_RULE)
+
+daVarRpc_svc.d: ../daVarRpc.h
+ echo remaking $@
+ $(RPCDEPENDS_RULE)
+
+daVarRpc.d: ../daVarRpc.h
+ echo remaking $@
+ touch $@
+
+../daVarRpc_xdr.c: ../daVarRpc.x ../daVar.h daVarRpc_xdr.d
+ $(RM) $@
+ (cd .. ; $(RPCCOM) -o $(@F) -c daVarRpc.x)
+
+../daVarRpc_svc.c: ../daVarRpc.x ../daVar.h daVarRpc_svc.d
+ $(RM) $@
+# (cd .. ; $(RPCCOM) -o $(@F) -m daVarRpc.x)
+# work around a bug in rpcgen present in Mac OS X 10.4:
+ (cd .. ; $(RPCCOM) -o temp_svc.c -m daVarRpc.x; sed -e 's/extern/static/g' temp_svc.c > $(@F); $(RM) temp_svc.c)
+
+../daVarRpc_clnt.c: ../daVarRpc.x ../daVar.h daVarRpc_clnt.d
+ $(RM) $@
+ (cd .. ; $(RPCCOM) -o $(@F) -l daVarRpc.x)
+
+../daVarRpc.h: ../daVarRpc.x ../daVar.h
+ $(RM) $@
+ (cd .. ; $(RPCCOM) -o $(@F) -h daVarRpc.x)
+
+include $(sources:.c=.d)
+
+ifdef ROOTSYS
+include $(cxxsources:.cpp=.d)
+endif
diff --git a/CTP/cfortran.h b/CTP/cfortran.h
new file mode 100644
index 0000000..5ae0eda
--- /dev/null
+++ b/CTP/cfortran.h
@@ -0,0 +1,2374 @@
+/* cfortran.h 4.3 */
+/* http://www-zeus.desy.de/~burow/cfortran/ */
+/* Burkhard Burow burow@desy.de 1990 - 2001. */
+/* This version of cfortran.h is from NetCDF and has support for gfortran.
+ * http://www.unidata.ucar.edu/software/netcdf/
+ * Also see http://www.unidata.ucar.edu/software/netcdf/copyright.html
+ */
+
+#ifndef __CFORTRAN_LOADED
+#define __CFORTRAN_LOADED
+
+/*
+ THIS FILE IS PROPERTY OF BURKHARD BUROW. IF YOU ARE USING THIS FILE YOU
+ SHOULD ALSO HAVE ACCESS TO CFORTRAN.DOC WHICH PROVIDES TERMS FOR USING,
+ MODIFYING, COPYING AND DISTRIBUTING THE CFORTRAN.H PACKAGE.
+*/
+
+/*
+ Avoid symbols already used by compilers and system *.h:
+ __ - OSF1 zukal06 V3.0 347 alpha, cc -c -std1 cfortest.c
+
+ */
+
+
+/* First prepare for the C compiler. */
+
+#ifndef ANSI_C_preprocessor /* i.e. user can override. */
+#ifdef __CF__KnR
+#define ANSI_C_preprocessor 0
+#else
+#ifdef __STDC__
+#define ANSI_C_preprocessor 1
+#else
+#define _cfleft 1
+#define _cfright
+#define _cfleft_cfright 0
+#define ANSI_C_preprocessor _cfleft/**/_cfright
+#endif
+#endif
+#endif
+
+#if ANSI_C_preprocessor
+#define _0(A,B) A##B
+#define _(A,B) _0(A,B) /* see cat,xcat of K&R ANSI C p. 231 */
+#define _2(A,B) A##B /* K&R ANSI C p.230: .. identifier is not replaced */
+#define _3(A,B,C) _(A,_(B,C))
+#else /* if it turns up again during rescanning. */
+#define _(A,B) A/**/B
+#define _2(A,B) A/**/B
+#define _3(A,B,C) A/**/B/**/C
+#endif
+
+#if (defined(vax)&&defined(unix)) || (defined(__vax__)&&defined(__unix__))
+#define VAXUltrix
+#endif
+
+#include <stdio.h> /* NULL [in all machines stdio.h] */
+#include <string.h> /* strlen, memset, memcpy, memchr. */
+#if !( defined(VAXUltrix) || defined(sun) || (defined(apollo)&&!defined(__STDCPP__)) )
+#include <stdlib.h> /* malloc,free */
+#else
+#include <malloc.h> /* Had to be removed for DomainOS h105 10.4 sys5.3 425t*/
+#ifdef apollo
+#define __CF__APOLLO67 /* __STDCPP__ is in Apollo 6.8 (i.e. ANSI) and onwards */
+#endif
+#endif
+
+#if !defined(__GNUC__) && !defined(__sun) && (defined(sun)||defined(VAXUltrix)||defined(lynx))
+#define __CF__KnR /* Sun, LynxOS and VAX Ultrix cc only supports K&R. */
+ /* Manually define __CF__KnR for HP if desired/required.*/
+#endif /* i.e. We will generate Kernighan and Ritchie C. */
+/* Note that you may define __CF__KnR before #include cfortran.h, in order to
+generate K&R C instead of the default ANSI C. The differences are mainly in the
+function prototypes and declarations. All machines, except the Apollo, work
+with either style. The Apollo's argument promotion rules require ANSI or use of
+the obsolete std_$call which we have not implemented here. Hence on the Apollo,
+only C calling FORTRAN subroutines will work using K&R style.*/
+
+
+/* Remainder of cfortran.h depends on the Fortran compiler. */
+
+#if defined(CLIPPERFortran) || defined(pgiFortran) || defined(__CYGWIN32__)
+#ifndef f2cFortran
+#define f2cFortran
+#endif
+#endif
+
+/* VAX/VMS does not let us \-split long #if lines. */
+/* Split #if into 2 because some HP-UX can't handle long #if */
+#if !(defined(NAGf90Fortran)||defined(f2cFortran)||defined(hpuxFortran)||defined(apolloFortran)||defined(sunFortran)||defined(IBMR2Fortran)||defined(CRAYFortran)||defined(PATHSCALE_COMPILER)||defined(gFortran))
+#if !(defined(mipsFortran)||defined(DECFortran)||defined(vmsFortran)||defined(CONVEXFortran)||defined(PowerStationFortran)||defined(AbsoftUNIXFortran)||defined(AbsoftProFortran)||defined(SXFortran))
+/* If no Fortran compiler is given, we choose one for the machines we know. */
+#if defined(lynx) || defined(VAXUltrix)
+#define f2cFortran /* Lynx: Only support f2c at the moment.
+ VAXUltrix: f77 behaves like f2c.
+ Support f2c or f77 with gcc, vcc with f2c.
+ f77 with vcc works, missing link magic for f77 I/O.*/
+#endif
+#if defined(__hpux) /* 921107: Use __hpux instead of __hp9000s300 */
+#define hpuxFortran /* Should also allow hp9000s7/800 use.*/
+#endif
+#if defined(apollo)
+#define apolloFortran /* __CF__APOLLO67 also defines some behavior. */
+#endif
+#if defined(sun) || defined(__sun)
+#define sunFortran
+#endif
+#if defined(_IBMR2)
+#define IBMR2Fortran
+#endif
+#if defined(_CRAY)
+#define CRAYFortran /* _CRAYT3E also defines some behavior. */
+#endif
+#if defined(_SX)
+#define SXFortran
+#endif
+#if defined(mips) || defined(__mips)
+#define mipsFortran
+#endif
+#if defined(vms) || defined(__vms)
+#define vmsFortran
+#endif
+#if defined(__alpha) && defined(__unix__)
+#define DECFortran
+#endif
+#if defined(__convex__)
+#define CONVEXFortran
+#endif
+#if defined(VISUAL_CPLUSPLUS)
+#define PowerStationFortran
+#endif
+#if defined(__PATHCC__)
+#define PATHSCALE_COMPILER
+#endif
+#endif /* ...Fortran */
+#endif /* ...Fortran */
+
+/* Split #if into 2 because some HP-UX can't handle long #if */
+#if !(defined(NAGf90Fortran)||defined(f2cFortran)||defined(hpuxFortran)||defined(apolloFortran)||defined(sunFortran)||defined(IBMR2Fortran)||defined(CRAYFortran)||defined(PATHSCALE_COMPILER)||defined(gFortran))
+#if !(defined(mipsFortran)||defined(DECFortran)||defined(vmsFortran)||defined(CONVEXFortran)||defined(PowerStationFortran)||defined(AbsoftUNIXFortran)||defined(AbsoftProFortran)||defined(SXFortran))
+/* If your compiler barfs on ' #error', replace # with the trigraph for # */
+ #error "cfortran.h: Can't find your environment among:\
+ - MIPS cc and f77 2.0. (e.g. Silicon Graphics, DECstations, ...) \
+ - IBM AIX XL C and FORTRAN Compiler/6000 Version 01.01.0000.0000 \
+ - VAX VMS CC 3.1 and FORTRAN 5.4. \
+ - Alpha VMS DEC C 1.3 and DEC FORTRAN 6.0. \
+ - Alpha OSF DEC C and DEC Fortran for OSF/1 AXP Version 1.2 \
+ - Apollo DomainOS 10.2 (sys5.3) with f77 10.7 and cc 6.7. \
+ - CRAY \
+ - NEC SX-4 SUPER-UX \
+ - CONVEX \
+ - Sun \
+ - PowerStation Fortran with Visual C++ \
+ - HP9000s300/s700/s800 Latest test with: HP-UX A.08.07 A 9000/730 \
+ - LynxOS: cc or gcc with f2c. \
+ - VAXUltrix: vcc,cc or gcc with f2c. gcc or cc with f77. \
+ - f77 with vcc works; but missing link magic for f77 I/O. \
+ - NO fort. None of gcc, cc or vcc generate required names.\
+ - f2c : Use #define f2cFortran, or cc -Df2cFortran \
+ - NAG f90: Use #define NAGf90Fortran, or cc -DNAGf90Fortran \
+ - Absoft UNIX F77: Use #define AbsoftUNIXFortran or cc -DAbsoftUNIXFortran \
+ - Absoft Pro Fortran: Use #define AbsoftProFortran \
+ - Portland Group Fortran: Use #define pgiFortran \
+ - PathScale Fortran: Use #define PATHSCALE_COMPILER"
+/* Compiler must throw us out at this point! */
+#endif
+#endif
+
+
+#if defined(VAXC) && !defined(__VAXC)
+#define OLD_VAXC
+#pragma nostandard /* Prevent %CC-I-PARAMNOTUSED. */
+#endif
+
+/* Throughout cfortran.h we use: UN = Uppercase Name. LN = Lowercase Name. */
+
+#if defined(f2cFortran) || defined(NAGf90Fortran) || defined(DECFortran) || defined(mipsFortran) || defined(apolloFortran) || defined(sunFortran) || defined(CONVEXFortran) || defined(SXFortran) || defined(extname) || defined(PATHSCALE_COMPILER) || defined(gFortran)
+#define CFC_(UN,LN) _(LN,_) /* Lowercase FORTRAN symbols. */
+#define orig_fcallsc(UN,LN) CFC_(UN,LN)
+#else
+#if defined(CRAYFortran) || defined(PowerStationFortran) || defined(AbsoftProFortran)
+#ifdef _CRAY /* (UN), not UN, circumvents CRAY preprocessor bug. */
+#define CFC_(UN,LN) (UN) /* Uppercase FORTRAN symbols. */
+#else /* At least VISUAL_CPLUSPLUS barfs on (UN), so need UN. */
+#define CFC_(UN,LN) UN /* Uppercase FORTRAN symbols. */
+#endif
+#define orig_fcallsc(UN,LN) CFC_(UN,LN) /* CRAY insists on arg.'s here. */
+#else /* For following machines one may wish to change the fcallsc default. */
+#define CF_SAME_NAMESPACE
+#ifdef vmsFortran
+#define CFC_(UN,LN) LN /* Either case FORTRAN symbols. */
+ /* BUT we usually use UN for C macro to FORTRAN routines, so use LN here,*/
+ /* because VAX/VMS doesn't do recursive macros. */
+#define orig_fcallsc(UN,LN) UN
+#else /* HP-UX without +ppu or IBMR2 without -qextname. NOT reccomended. */
+#define CFC_(UN,LN) LN /* Lowercase FORTRAN symbols. */
+#define orig_fcallsc(UN,LN) CFC_(UN,LN)
+#endif /* vmsFortran */
+#endif /* CRAYFortran PowerStationFortran */
+#endif /* ....Fortran */
+
+#define fcallsc(UN,LN) orig_fcallsc(UN,LN)
+#define preface_fcallsc(P,p,UN,LN) CFC_(_(P,UN),_(p,LN))
+#define append_fcallsc(P,p,UN,LN) CFC_(_(UN,P),_(LN,p))
+
+#define C_FUNCTION(UN,LN) fcallsc(UN,LN)
+#define FORTRAN_FUNCTION(UN,LN) CFC_(UN,LN)
+
+#ifndef COMMON_BLOCK
+#ifndef CONVEXFortran
+#ifndef CLIPPERFortran
+#if !(defined(AbsoftUNIXFortran)||defined(AbsoftProFortran))
+#define COMMON_BLOCK(UN,LN) CFC_(UN,LN)
+#else
+#define COMMON_BLOCK(UN,LN) _(_C,LN)
+#endif /* AbsoftUNIXFortran or AbsoftProFortran */
+#else
+#define COMMON_BLOCK(UN,LN) _(LN,__)
+#endif /* CLIPPERFortran */
+#else
+#define COMMON_BLOCK(UN,LN) _3(_,LN,_)
+#endif /* CONVEXFortran */
+#endif /* COMMON_BLOCK */
+
+#ifndef DOUBLE_PRECISION
+#if defined(CRAYFortran) && !defined(_CRAYT3E)
+#define DOUBLE_PRECISION long double
+#else
+#define DOUBLE_PRECISION double
+#endif
+#endif
+
+#ifndef FORTRAN_REAL
+#if defined(CRAYFortran) && defined(_CRAYT3E)
+#define FORTRAN_REAL double
+#else
+#define FORTRAN_REAL float
+#endif
+#endif
+
+#ifdef CRAYFortran
+#ifdef _CRAY
+#include <fortran.h>
+#else
+#include "fortran.h" /* i.e. if crosscompiling assume user has file. */
+#endif
+#define FLOATVVVVVVV_cfPP (FORTRAN_REAL *) /* Used for C calls FORTRAN. */
+/* CRAY's double==float but CRAY says pointers to doubles and floats are diff.*/
+#define VOIDP (void *) /* When FORTRAN calls C, we don't know if C routine
+ arg.'s have been declared float *, or double *. */
+#else
+#define FLOATVVVVVVV_cfPP
+#define VOIDP
+#endif
+
+#ifdef vmsFortran
+#if defined(vms) || defined(__vms)
+#include <descrip.h>
+#else
+#include "descrip.h" /* i.e. if crosscompiling assume user has file. */
+#endif
+#endif
+
+#ifdef sunFortran
+#if defined(sun) || defined(__sun)
+#include <math.h> /* Sun's FLOATFUNCTIONTYPE, ASSIGNFLOAT, RETURNFLOAT. */
+#else
+#include "math.h" /* i.e. if crosscompiling assume user has file. */
+#endif
+/* At least starting with the default C compiler SC3.0.1 of SunOS 5.3,
+ * FLOATFUNCTIONTYPE, ASSIGNFLOAT, RETURNFLOAT are not required and not in
+ * <math.h>, since sun C no longer promotes C float return values to doubles.
+ * Therefore, only use them if defined.
+ * Even if gcc is being used, assume that it exhibits the Sun C compiler
+ * behavior in order to be able to use *.o from the Sun C compiler.
+ * i.e. If FLOATFUNCTIONTYPE, etc. are in math.h, they required by gcc.
+ */
+#endif
+
+#ifndef apolloFortran
+#define COMMON_BLOCK_DEF(DEFINITION, NAME) extern DEFINITION NAME
+#define CF_NULL_PROTO
+#else /* HP doesn't understand #elif. */
+/* Without ANSI prototyping, Apollo promotes float functions to double. */
+/* Note that VAX/VMS, IBM, Mips choke on 'type function(...);' prototypes. */
+#define CF_NULL_PROTO ...
+#ifndef __CF__APOLLO67
+#define COMMON_BLOCK_DEF(DEFINITION, NAME) \
+ DEFINITION NAME __attribute((__section(NAME)))
+#else
+#define COMMON_BLOCK_DEF(DEFINITION, NAME) \
+ DEFINITION NAME #attribute[section(NAME)]
+#endif
+#endif
+
+#ifdef __cplusplus
+#undef CF_NULL_PROTO
+#define CF_NULL_PROTO ...
+#endif
+
+
+#ifndef USE_NEW_DELETE
+#ifdef __cplusplus
+#define USE_NEW_DELETE 1
+#else
+#define USE_NEW_DELETE 0
+#endif
+#endif
+#if USE_NEW_DELETE
+#define _cf_malloc(N) new char[N]
+#define _cf_free(P) delete[] P
+#else
+#define _cf_malloc(N) (char *)malloc(N)
+#define _cf_free(P) free(P)
+#endif
+
+#ifdef mipsFortran
+#define CF_DECLARE_GETARG int f77argc; char **f77argv
+#define CF_SET_GETARG(ARGC,ARGV) f77argc = ARGC; f77argv = ARGV
+#else
+#define CF_DECLARE_GETARG
+#define CF_SET_GETARG(ARGC,ARGV)
+#endif
+
+#ifdef OLD_VAXC /* Allow %CC-I-PARAMNOTUSED. */
+#pragma standard
+#endif
+
+#define AcfCOMMA ,
+#define AcfCOLON ;
+
+/*-------------------------------------------------------------------------*/
+
+/* UTILITIES USED WITHIN CFORTRAN.H */
+
+#define _cfMIN(A,B) (A<B?A:B)
+
+/* 970211 - XIX.145:
+ firstindexlength - better name is all_but_last_index_lengths
+ secondindexlength - better name is last_index_length
+ */
+#define firstindexlength(A) (sizeof(A[0])==1 ? 1 : (sizeof(A) / sizeof(A[0])) )
+#define secondindexlength(A) (sizeof(A[0])==1 ? sizeof(A) : sizeof(A[0]) )
+
+/* Behavior of FORTRAN LOGICAL. All machines' LOGICAL is same size as C's int.
+Conversion is automatic except for arrays which require F2CLOGICALV/C2FLOGICALV.
+f2c, MIPS f77 [DECstation, SGI], VAX Ultrix f77,
+HP-UX f77 : as in C.
+VAX/VMS FORTRAN, VAX Ultrix fort,
+Absoft Unix Fortran, IBM RS/6000 xlf : LS Bit = 0/1 = TRUE/FALSE.
+Apollo : neg. = TRUE, else FALSE.
+[Apollo accepts -1 as TRUE for function values, but NOT all other neg. values.]
+[DECFortran for Ultrix RISC is also called f77 but is the same as VAX/VMS.]
+[MIPS f77 treats .eqv./.neqv. as .eq./.ne. and hence requires LOGICAL_STRICT.]*/
+
+#if defined(NAGf90Fortran) || defined(f2cFortran) || defined(mipsFortran) || defined(PowerStationFortran) || defined(hpuxFortran800) || defined(AbsoftUNIXFortran) || defined(AbsoftProFortran) || defined(SXFortran) || defined(PATHSCALE_COMPILER)
+/* SX/PowerStationFortran have 0 and 1 defined, others are neither T nor F. */
+/* hpuxFortran800 has 0 and 0x01000000 defined. Others are unknown. */
+#define LOGICAL_STRICT /* Other Fortran have .eqv./.neqv. == .eq./.ne. */
+#endif
+
+#define C2FLOGICALV(A,I) \
+ do {int __i; for(__i=0;__i<I;__i++) A[__i]=C2FLOGICAL(A[__i]); } while (0)
+#define F2CLOGICALV(A,I) \
+ do {int __i; for(__i=0;__i<I;__i++) A[__i]=F2CLOGICAL(A[__i]); } while (0)
+
+#if defined(apolloFortran)
+#define C2FLOGICAL(L) ((L)?-1:(L)&~((unsigned)1<<sizeof(int)*8-1))
+#define F2CLOGICAL(L) ((L)<0?(L):0)
+#else
+#if defined(CRAYFortran)
+#define C2FLOGICAL(L) _btol(L)
+#define F2CLOGICAL(L) _ltob(&(L)) /* Strangely _ltob() expects a pointer. */
+#else
+#if defined(IBMR2Fortran) || defined(vmsFortran) || defined(DECFortran) || defined(AbsoftUNIXFortran)
+/* How come no AbsoftProFortran ? */
+#define C2FLOGICAL(L) ((L)?(L)|1:(L)&~(int)1)
+#define F2CLOGICAL(L) ((L)&1?(L):0)
+#else
+#if defined(CONVEXFortran)
+#define C2FLOGICAL(L) ((L) ? ~0 : 0 )
+#define F2CLOGICAL(L) (L)
+#else /* others evaluate LOGICALs as for C. */
+#define C2FLOGICAL(L) (L)
+#define F2CLOGICAL(L) (L)
+#ifndef LOGICAL_STRICT
+#undef C2FLOGICALV
+#undef F2CLOGICALV
+#define C2FLOGICALV(A,I)
+#define F2CLOGICALV(A,I)
+#endif /* LOGICAL_STRICT */
+#endif /* CONVEXFortran || All Others */
+#endif /* IBMR2Fortran vmsFortran DECFortran AbsoftUNIXFortran */
+#endif /* CRAYFortran */
+#endif /* apolloFortran */
+
+/* 970514 - In addition to CRAY, there may be other machines
+ for which LOGICAL_STRICT makes no sense. */
+#if defined(LOGICAL_STRICT) && !defined(CRAYFortran)
+/* Force C2FLOGICAL to generate only the values for either .TRUE. or .FALSE.
+ SX/PowerStationFortran only have 0 and 1 defined.
+ Elsewhere, only needed if you want to do:
+ logical lvariable
+ if (lvariable .eq. .true.) then ! (1)
+ instead of
+ if (lvariable .eqv. .true.) then ! (2)
+ - (1) may not even be FORTRAN/77 and that Apollo's f77 and IBM's xlf
+ refuse to compile (1), so you are probably well advised to stay away from
+ (1) and from LOGICAL_STRICT.
+ - You pay a (slight) performance penalty for using LOGICAL_STRICT. */
+#undef C2FLOGICAL
+#ifdef hpuxFortran800
+#define C2FLOGICAL(L) ((L)?0x01000000:0)
+#else
+#if defined(apolloFortran) || defined(vmsFortran) || defined(DECFortran)
+#define C2FLOGICAL(L) ((L)?-1:0) /* These machines use -1/0 for .true./.false.*/
+#else
+#define C2FLOGICAL(L) ((L)? 1:0) /* All others use +1/0 for .true./.false.*/
+#endif
+#endif
+#endif /* LOGICAL_STRICT */
+
+/* Convert a vector of C strings into FORTRAN strings. */
+#ifndef __CF__KnR
+static char *c2fstrv(char* cstr, char *fstr, int elem_len, int sizeofcstr)
+#else
+static char *c2fstrv( cstr, fstr, elem_len, sizeofcstr)
+ char* cstr; char *fstr; int elem_len; int sizeofcstr;
+#endif
+{ int i,j;
+/* elem_len includes \0 for C strings. Fortran strings don't have term. \0.
+ Useful size of string must be the same in both languages. */
+for (i=0; i<sizeofcstr/elem_len; i++) {
+ for (j=1; j<elem_len && *cstr; j++) *fstr++ = *cstr++;
+ cstr += 1+elem_len-j;
+ for (; j<elem_len; j++) *fstr++ = ' ';
+} /* 95109 - Seems to be returning the original fstr. */
+return fstr-sizeofcstr+sizeofcstr/elem_len; }
+
+/* Convert a vector of FORTRAN strings into C strings. */
+#ifndef __CF__KnR
+static char *f2cstrv(char *fstr, char* cstr, int elem_len, int sizeofcstr)
+#else
+static char *f2cstrv( fstr, cstr, elem_len, sizeofcstr)
+ char *fstr; char* cstr; int elem_len; int sizeofcstr;
+#endif
+{ int i,j;
+/* elem_len includes \0 for C strings. Fortran strings don't have term. \0.
+ Useful size of string must be the same in both languages. */
+cstr += sizeofcstr;
+fstr += sizeofcstr - sizeofcstr/elem_len;
+for (i=0; i<sizeofcstr/elem_len; i++) {
+ *--cstr = '\0';
+ for (j=1; j<elem_len; j++) *--cstr = *--fstr;
+} return cstr; }
+
+/* kill the trailing char t's in string s. */
+#ifndef __CF__KnR
+static char *kill_trailing(char *s, char t)
+#else
+static char *kill_trailing( s, t) char *s; char t;
+#endif
+{char *e;
+e = s + strlen(s);
+if (e>s) { /* Need this to handle NULL string.*/
+ while (e>s && *--e==t); /* Don't follow t's past beginning. */
+ e[*e==t?0:1] = '\0'; /* Handle s[0]=t correctly. */
+} return s; }
+
+/* kill_trailingn(s,t,e) will kill the trailing t's in string s. e normally
+points to the terminating '\0' of s, but may actually point to anywhere in s.
+s's new '\0' will be placed at e or earlier in order to remove any trailing t's.
+If e<s string s is left unchanged. */
+#ifndef __CF__KnR
+static char *kill_trailingn(char *s, char t, char *e)
+#else
+static char *kill_trailingn( s, t, e) char *s; char t; char *e;
+#endif
+{
+if (e==s) *e = '\0'; /* Kill the string makes sense here.*/
+else if (e>s) { /* Watch out for neg. length string.*/
+ while (e>s && *--e==t); /* Don't follow t's past beginning. */
+ e[*e==t?0:1] = '\0'; /* Handle s[0]=t correctly. */
+} return s; }
+
+/* Note the following assumes that any element which has t's to be chopped off,
+does indeed fill the entire element. */
+#ifndef __CF__KnR
+static char *vkill_trailing(char* cstr, int elem_len, int sizeofcstr, char t)
+#else
+static char *vkill_trailing( cstr, elem_len, sizeofcstr, t)
+ char* cstr; int elem_len; int sizeofcstr; char t;
+#endif
+{ int i;
+for (i=0; i<sizeofcstr/elem_len; i++) /* elem_len includes \0 for C strings. */
+ kill_trailingn(cstr+elem_len*i,t,cstr+elem_len*(i+1)-1);
+return cstr; }
+
+#ifdef vmsFortran
+typedef struct dsc$descriptor_s fstring;
+#define DSC$DESCRIPTOR_A(DIMCT) \
+struct { \
+ unsigned short dsc$w_length; unsigned char dsc$b_dtype; \
+ unsigned char dsc$b_class; char *dsc$a_pointer; \
+ char dsc$b_scale; unsigned char dsc$b_digits; \
+ struct { \
+ unsigned : 3; unsigned dsc$v_fl_binscale : 1; \
+ unsigned dsc$v_fl_redim : 1; unsigned dsc$v_fl_column : 1; \
+ unsigned dsc$v_fl_coeff : 1; unsigned dsc$v_fl_bounds : 1; \
+ } dsc$b_aflags; \
+ unsigned char dsc$b_dimct; unsigned long dsc$l_arsize; \
+ char *dsc$a_a0; long dsc$l_m [DIMCT]; \
+ struct { \
+ long dsc$l_l; long dsc$l_u; \
+ } dsc$bounds [DIMCT]; \
+}
+typedef DSC$DESCRIPTOR_A(1) fstringvector;
+/*typedef DSC$DESCRIPTOR_A(2) fstringarrarr;
+ typedef DSC$DESCRIPTOR_A(3) fstringarrarrarr;*/
+#define initfstr(F,C,ELEMNO,ELEMLEN) \
+( (F).dsc$l_arsize= ( (F).dsc$w_length =(ELEMLEN) ) \
+ *( (F).dsc$l_m[0]=(F).dsc$bounds[0].dsc$l_u=(ELEMNO) ), \
+ (F).dsc$a_a0 = ( (F).dsc$a_pointer=(C) ) - (F).dsc$w_length ,(F))
+
+#else
+#define _NUM_ELEMS -1
+#define _NUM_ELEM_ARG -2
+#define NUM_ELEMS(A) A,_NUM_ELEMS
+#define NUM_ELEM_ARG(B) *_2(A,B),_NUM_ELEM_ARG
+#define TERM_CHARS(A,B) A,B
+#ifndef __CF__KnR
+static int num_elem(char *strv, unsigned elem_len, int term_char, int num_term)
+#else
+static int num_elem( strv, elem_len, term_char, num_term)
+ char *strv; unsigned elem_len; int term_char; int num_term;
+#endif
+/* elem_len is the number of characters in each element of strv, the FORTRAN
+vector of strings. The last element of the vector must begin with at least
+num_term term_char characters, so that this routine can determine how
+many elements are in the vector. */
+{
+unsigned num,i;
+if (num_term == _NUM_ELEMS || num_term == _NUM_ELEM_ARG)
+ return term_char;
+if (num_term <=0) num_term = (int)elem_len;
+for (num=0; ; num++) {
+ for (i=0; i<(unsigned)num_term && *strv==term_char; i++,strv++);
+ if (i==(unsigned)num_term) break;
+ else strv += elem_len-i;
+}
+return (int)num;
+}
+#endif
+/*-------------------------------------------------------------------------*/
+
+/* UTILITIES FOR C TO USE STRINGS IN FORTRAN COMMON BLOCKS */
+
+/* C string TO Fortran Common Block STRing. */
+/* DIM is the number of DIMensions of the array in terms of strings, not
+ characters. e.g. char a[12] has DIM = 0, char a[12][4] has DIM = 1, etc. */
+#define C2FCBSTR(CSTR,FSTR,DIM) \
+ c2fstrv((char *)CSTR, (char *)FSTR, sizeof(FSTR)/cfelementsof(FSTR,DIM)+1, \
+ sizeof(FSTR)+cfelementsof(FSTR,DIM))
+
+/* Fortran Common Block string TO C STRing. */
+#define FCB2CSTR(FSTR,CSTR,DIM) \
+ vkill_trailing(f2cstrv((char *)FSTR, (char *)CSTR, \
+ sizeof(FSTR)/cfelementsof(FSTR,DIM)+1, \
+ sizeof(FSTR)+cfelementsof(FSTR,DIM)), \
+ sizeof(FSTR)/cfelementsof(FSTR,DIM)+1, \
+ sizeof(FSTR)+cfelementsof(FSTR,DIM), ' ')
+
+#define cfDEREFERENCE0
+#define cfDEREFERENCE1 *
+#define cfDEREFERENCE2 **
+#define cfDEREFERENCE3 ***
+#define cfDEREFERENCE4 ****
+#define cfDEREFERENCE5 *****
+#define cfelementsof(A,D) (sizeof(A)/sizeof(_(cfDEREFERENCE,D)(A)))
+
+/*-------------------------------------------------------------------------*/
+
+/* UTILITIES FOR C TO CALL FORTRAN SUBROUTINES */
+
+/* Define lookup tables for how to handle the various types of variables. */
+
+#ifdef OLD_VAXC /* Prevent %CC-I-PARAMNOTUSED. */
+#pragma nostandard
+#endif
+
+#define ZTRINGV_NUM(I) I
+#define ZTRINGV_ARGFP(I) (*(_2(A,I))) /* Undocumented. For PINT, etc. */
+#define ZTRINGV_ARGF(I) _2(A,I)
+#ifdef CFSUBASFUN
+#define ZTRINGV_ARGS(I) ZTRINGV_ARGF(I)
+#else
+#define ZTRINGV_ARGS(I) _2(B,I)
+#endif
+
+#define PBYTE_cfVP(A,B) PINT_cfVP(A,B)
+#define PDOUBLE_cfVP(A,B)
+#define PFLOAT_cfVP(A,B)
+#ifdef ZTRINGV_ARGS_allows_Pvariables
+/* This allows Pvariables for ARGS. ARGF machinery is above ARGFP.
+ * B is not needed because the variable may be changed by the Fortran routine,
+ * but because B is the only way to access an arbitrary macro argument. */
+#define PINT_cfVP(A,B) int B = (int)A; /* For ZSTRINGV_ARGS */
+#else
+#define PINT_cfVP(A,B)
+#endif
+#define PLOGICAL_cfVP(A,B) int *B; /* Returning LOGICAL in FUNn and SUBn */
+#define PLONG_cfVP(A,B) PINT_cfVP(A,B)
+#define PSHORT_cfVP(A,B) PINT_cfVP(A,B)
+
+#define VCF_INT_S(T,A,B) _(T,VVVVVVV_cfTYPE) B = A;
+#define VCF_INT_F(T,A,B) _(T,_cfVCF)(A,B)
+/* _cfVCF table is directly mapped to _cfCCC table. */
+#define BYTE_cfVCF(A,B)
+#define DOUBLE_cfVCF(A,B)
+#if !defined(__CF__KnR)
+#define FLOAT_cfVCF(A,B)
+#else
+#define FLOAT_cfVCF(A,B) FORTRAN_REAL B = A;
+#endif
+#define INT_cfVCF(A,B)
+#define LOGICAL_cfVCF(A,B)
+#define LONG_cfVCF(A,B)
+#define SHORT_cfVCF(A,B)
+
+/* 980416
+ Cast (void (*)(CF_NULL_PROTO)) causes SunOS CC 4.2 occasionally to barf,
+ while the following equivalent typedef is fine.
+ For consistency use the typedef on all machines.
+ */
+typedef void (*cfCAST_FUNCTION)(CF_NULL_PROTO);
+
+#define VCF(TN,I) _Icf4(4,V,TN,_(A,I),_(B,I),F)
+#define VVCF(TN,AI,BI) _Icf4(4,V,TN,AI,BI,S)
+#define INT_cfV(T,A,B,F) _(VCF_INT_,F)(T,A,B)
+#define INTV_cfV(T,A,B,F)
+#define INTVV_cfV(T,A,B,F)
+#define INTVVV_cfV(T,A,B,F)
+#define INTVVVV_cfV(T,A,B,F)
+#define INTVVVVV_cfV(T,A,B,F)
+#define INTVVVVVV_cfV(T,A,B,F)
+#define INTVVVVVVV_cfV(T,A,B,F)
+#define PINT_cfV( T,A,B,F) _(T,_cfVP)(A,B)
+#define PVOID_cfV( T,A,B,F)
+#if defined(apolloFortran) || defined(hpuxFortran800) || defined(AbsoftUNIXFortran) || defined(AbsoftProFortran)
+#define ROUTINE_cfV(T,A,B,F) void (*B)(CF_NULL_PROTO) = (cfCAST_FUNCTION)A;
+#else
+#define ROUTINE_cfV(T,A,B,F)
+#endif
+#define SIMPLE_cfV(T,A,B,F)
+#ifdef vmsFortran
+#define STRING_cfV(T,A,B,F) static struct {fstring f; unsigned clen;} B = \
+ {{0,DSC$K_DTYPE_T,DSC$K_CLASS_S,NULL},0};
+#define PSTRING_cfV(T,A,B,F) static fstring B={0,DSC$K_DTYPE_T,DSC$K_CLASS_S,NULL};
+#define STRINGV_cfV(T,A,B,F) static fstringvector B = \
+ {sizeof(A),DSC$K_DTYPE_T,DSC$K_CLASS_A,NULL,0,0,{0,0,1,1,1},1,0,NULL,0,{1,0}};
+#define PSTRINGV_cfV(T,A,B,F) static fstringvector B = \
+ {0,DSC$K_DTYPE_T,DSC$K_CLASS_A,NULL,0,0,{0,0,1,1,1},1,0,NULL,0,{1,0}};
+#else
+#define STRING_cfV(T,A,B,F) struct {unsigned int clen, flen;} B;
+#define STRINGV_cfV(T,A,B,F) struct {char *s, *fs; unsigned flen;} B;
+#define PSTRING_cfV(T,A,B,F) int B;
+#define PSTRINGV_cfV(T,A,B,F) struct{char *fs; unsigned int sizeofA,flen;}B;
+#endif
+#define ZTRINGV_cfV(T,A,B,F) STRINGV_cfV(T,A,B,F)
+#define PZTRINGV_cfV(T,A,B,F) PSTRINGV_cfV(T,A,B,F)
+
+/* Note that the actions of the A table were performed inside the AA table.
+ VAX Ultrix vcc, and HP-UX cc, didn't evaluate arguments to functions left to
+ right, so we had to split the original table into the current robust two. */
+#define ACF(NAME,TN,AI,I) _(TN,_cfSTR)(4,A,NAME,I,AI,_(B,I),0)
+#define DEFAULT_cfA(M,I,A,B)
+#define LOGICAL_cfA(M,I,A,B) B=C2FLOGICAL(B);
+#define PLOGICAL_cfA(M,I,A,B) A=C2FLOGICAL(A);
+#define STRING_cfA(M,I,A,B) STRING_cfC(M,I,A,B,sizeof(A))
+#define PSTRING_cfA(M,I,A,B) PSTRING_cfC(M,I,A,B,sizeof(A))
+#ifdef vmsFortran
+#define AATRINGV_cfA( A,B, sA,filA,silA) \
+ initfstr(B,_cf_malloc((sA)-(filA)),(filA),(silA)-1), \
+ c2fstrv(A,B.dsc$a_pointer,(silA),(sA));
+#define APATRINGV_cfA( A,B, sA,filA,silA) \
+ initfstr(B,A,(filA),(silA)-1),c2fstrv(A,A,(silA),(sA));
+#else
+#define AATRINGV_cfA( A,B, sA,filA,silA) \
+ (B.s=_cf_malloc((sA)-(filA)),B.fs=c2fstrv(A,B.s,(B.flen=(silA)-1)+1,(sA)));
+#define APATRINGV_cfA( A,B, sA,filA,silA) \
+ B.fs=c2fstrv(A,A,(B.flen=(silA)-1)+1,B.sizeofA=(sA));
+#endif
+#define STRINGV_cfA(M,I,A,B) \
+ AATRINGV_cfA((char *)A,B,sizeof(A),firstindexlength(A),secondindexlength(A))
+#define PSTRINGV_cfA(M,I,A,B) \
+ APATRINGV_cfA((char *)A,B,sizeof(A),firstindexlength(A),secondindexlength(A))
+#define ZTRINGV_cfA(M,I,A,B) AATRINGV_cfA( (char *)A,B, \
+ (_3(M,_ELEMS_,I))*(( _3(M,_ELEMLEN_,I))+1), \
+ (_3(M,_ELEMS_,I)),(_3(M,_ELEMLEN_,I))+1)
+#define PZTRINGV_cfA(M,I,A,B) APATRINGV_cfA( (char *)A,B, \
+ (_3(M,_ELEMS_,I))*(( _3(M,_ELEMLEN_,I))+1), \
+ (_3(M,_ELEMS_,I)),(_3(M,_ELEMLEN_,I))+1)
+
+#define PBYTE_cfAAP(A,B) &A
+#define PDOUBLE_cfAAP(A,B) &A
+#define PFLOAT_cfAAP(A,B) FLOATVVVVVVV_cfPP &A
+#define PINT_cfAAP(A,B) &A
+#define PLOGICAL_cfAAP(A,B) B= &A /* B used to keep a common W table. */
+#define PLONG_cfAAP(A,B) &A
+#define PSHORT_cfAAP(A,B) &A
+
+#define AACF(TN,AI,I,C) _SEP_(TN,C,cfCOMMA) _Icf(3,AA,TN,AI,_(B,I))
+#define INT_cfAA(T,A,B) &B
+#define INTV_cfAA(T,A,B) _(T,VVVVVV_cfPP) A
+#define INTVV_cfAA(T,A,B) _(T,VVVVV_cfPP) A[0]
+#define INTVVV_cfAA(T,A,B) _(T,VVVV_cfPP) A[0][0]
+#define INTVVVV_cfAA(T,A,B) _(T,VVV_cfPP) A[0][0][0]
+#define INTVVVVV_cfAA(T,A,B) _(T,VV_cfPP) A[0][0][0][0]
+#define INTVVVVVV_cfAA(T,A,B) _(T,V_cfPP) A[0][0][0][0][0]
+#define INTVVVVVVV_cfAA(T,A,B) _(T,_cfPP) A[0][0][0][0][0][0]
+#define PINT_cfAA(T,A,B) _(T,_cfAAP)(A,B)
+#define PVOID_cfAA(T,A,B) (void *) A
+#if defined(apolloFortran) || defined(hpuxFortran800) || defined(AbsoftUNIXFortran)
+#define ROUTINE_cfAA(T,A,B) &B
+#else
+#define ROUTINE_cfAA(T,A,B) (cfCAST_FUNCTION)A
+#endif
+#define STRING_cfAA(T,A,B) STRING_cfCC(T,A,B)
+#define PSTRING_cfAA(T,A,B) PSTRING_cfCC(T,A,B)
+#ifdef vmsFortran
+#define STRINGV_cfAA(T,A,B) &B
+#else
+#ifdef CRAYFortran
+#define STRINGV_cfAA(T,A,B) _cptofcd(B.fs,B.flen)
+#else
+#define STRINGV_cfAA(T,A,B) B.fs
+#endif
+#endif
+#define PSTRINGV_cfAA(T,A,B) STRINGV_cfAA(T,A,B)
+#define ZTRINGV_cfAA(T,A,B) STRINGV_cfAA(T,A,B)
+#define PZTRINGV_cfAA(T,A,B) STRINGV_cfAA(T,A,B)
+
+#if defined(vmsFortran) || defined(CRAYFortran)
+#define JCF(TN,I)
+#define KCF(TN,I)
+#else
+#define JCF(TN,I) _(TN,_cfSTR)(1,J,_(B,I), 0,0,0,0)
+#if defined(AbsoftUNIXFortran)
+#define DEFAULT_cfJ(B) ,0
+#else
+#define DEFAULT_cfJ(B)
+#endif
+#define LOGICAL_cfJ(B) DEFAULT_cfJ(B)
+#define PLOGICAL_cfJ(B) DEFAULT_cfJ(B)
+#define STRING_cfJ(B) ,B.flen
+#define PSTRING_cfJ(B) ,B
+#define STRINGV_cfJ(B) STRING_cfJ(B)
+#define PSTRINGV_cfJ(B) STRING_cfJ(B)
+#define ZTRINGV_cfJ(B) STRING_cfJ(B)
+#define PZTRINGV_cfJ(B) STRING_cfJ(B)
+
+/* KCF is identical to DCF, except that KCF ZTRING is not empty. */
+#define KCF(TN,I) _(TN,_cfSTR)(1,KK,_(B,I), 0,0,0,0)
+#if defined(AbsoftUNIXFortran)
+#define DEFAULT_cfKK(B) , unsigned B
+#else
+#define DEFAULT_cfKK(B)
+#endif
+#define LOGICAL_cfKK(B) DEFAULT_cfKK(B)
+#define PLOGICAL_cfKK(B) DEFAULT_cfKK(B)
+#define STRING_cfKK(B) , unsigned B
+#define PSTRING_cfKK(B) STRING_cfKK(B)
+#define STRINGV_cfKK(B) STRING_cfKK(B)
+#define PSTRINGV_cfKK(B) STRING_cfKK(B)
+#define ZTRINGV_cfKK(B) STRING_cfKK(B)
+#define PZTRINGV_cfKK(B) STRING_cfKK(B)
+#endif
+
+#define WCF(TN,AN,I) _(TN,_cfSTR)(2,W,AN,_(B,I), 0,0,0)
+#define DEFAULT_cfW(A,B)
+#define LOGICAL_cfW(A,B)
+#define PLOGICAL_cfW(A,B) *B=F2CLOGICAL(*B);
+#define STRING_cfW(A,B) (A[B.clen]!='\0'?A[B.clen]='\0':0); /* A?="constnt"*/
+#define PSTRING_cfW(A,B) kill_trailing(A,' ');
+#ifdef vmsFortran
+#define STRINGV_cfW(A,B) _cf_free(B.dsc$a_pointer);
+#define PSTRINGV_cfW(A,B) \
+ vkill_trailing(f2cstrv((char*)A, (char*)A, \
+ B.dsc$w_length+1, B.dsc$l_arsize+B.dsc$l_m[0]), \
+ B.dsc$w_length+1, B.dsc$l_arsize+B.dsc$l_m[0], ' ');
+#else
+#define STRINGV_cfW(A,B) _cf_free(B.s);
+#define PSTRINGV_cfW(A,B) vkill_trailing( \
+ f2cstrv((char*)A,(char*)A,B.flen+1,B.sizeofA), B.flen+1,B.sizeofA,' ');
+#endif
+#define ZTRINGV_cfW(A,B) STRINGV_cfW(A,B)
+#define PZTRINGV_cfW(A,B) PSTRINGV_cfW(A,B)
+
+#define NCF(TN,I,C) _SEP_(TN,C,cfCOMMA) _Icf(2,N,TN,_(A,I),0)
+#define NNCF(TN,I,C) UUCF(TN,I,C)
+#define NNNCF(TN,I,C) _SEP_(TN,C,cfCOLON) _Icf(2,N,TN,_(A,I),0)
+#define INT_cfN(T,A) _(T,VVVVVVV_cfTYPE) * A
+#define INTV_cfN(T,A) _(T,VVVVVV_cfTYPE) * A
+#define INTVV_cfN(T,A) _(T,VVVVV_cfTYPE) * A
+#define INTVVV_cfN(T,A) _(T,VVVV_cfTYPE) * A
+#define INTVVVV_cfN(T,A) _(T,VVV_cfTYPE) * A
+#define INTVVVVV_cfN(T,A) _(T,VV_cfTYPE) * A
+#define INTVVVVVV_cfN(T,A) _(T,V_cfTYPE) * A
+#define INTVVVVVVV_cfN(T,A) _(T,_cfTYPE) * A
+#define PINT_cfN(T,A) _(T,_cfTYPE) * A
+#define PVOID_cfN(T,A) void * A
+#if defined(apolloFortran) || defined(hpuxFortran800) || defined(AbsoftUNIXFortran)
+#define ROUTINE_cfN(T,A) void (**A)(CF_NULL_PROTO)
+#else
+#define ROUTINE_cfN(T,A) void ( *A)(CF_NULL_PROTO)
+#endif
+#ifdef vmsFortran
+#define STRING_cfN(T,A) fstring * A
+#define STRINGV_cfN(T,A) fstringvector * A
+#else
+#ifdef CRAYFortran
+#define STRING_cfN(T,A) _fcd A
+#define STRINGV_cfN(T,A) _fcd A
+#else
+#define STRING_cfN(T,A) char * A
+#define STRINGV_cfN(T,A) char * A
+#endif
+#endif
+#define PSTRING_cfN(T,A) STRING_cfN(T,A) /* CRAY insists on arg.'s here. */
+#define PNSTRING_cfN(T,A) STRING_cfN(T,A) /* CRAY insists on arg.'s here. */
+#define PPSTRING_cfN(T,A) STRING_cfN(T,A) /* CRAY insists on arg.'s here. */
+#define PSTRINGV_cfN(T,A) STRINGV_cfN(T,A)
+#define ZTRINGV_cfN(T,A) STRINGV_cfN(T,A)
+#define PZTRINGV_cfN(T,A) PSTRINGV_cfN(T,A)
+
+
+/* Apollo 6.7, CRAY, old Sun, VAX/Ultrix vcc/cc and new ultrix
+ can't hack more than 31 arg's.
+ e.g. ultrix >= 4.3 gives message:
+ zow35> cc -c -DDECFortran cfortest.c
+ cfe: Fatal: Out of memory: cfortest.c
+ zow35>
+ Old __hpux had the problem, but new 'HP-UX A.09.03 A 9000/735' is fine
+ if using -Aa, otherwise we have a problem.
+ */
+#ifndef MAX_PREPRO_ARGS
+#if !defined(__GNUC__) && (defined(VAXUltrix) || defined(__CF__APOLLO67) || (defined(sun)&&!defined(__sun)) || defined(_CRAY) || defined(__ultrix__) || (defined(__hpux)&&defined(__CF__KnR)))
+#define MAX_PREPRO_ARGS 31
+#else
+#define MAX_PREPRO_ARGS 99
+#endif
+#endif
+
+#if defined(AbsoftUNIXFortran) || defined(AbsoftProFortran)
+/* In addition to explicit Absoft stuff, only Absoft requires:
+ - DEFAULT coming from _cfSTR.
+ DEFAULT could have been called e.g. INT, but keep it for clarity.
+ - M term in CFARGT14 and CFARGT14FS.
+ */
+#define ABSOFT_cf1(T0) _(T0,_cfSTR)(0,ABSOFT1,0,0,0,0,0)
+#define ABSOFT_cf2(T0) _(T0,_cfSTR)(0,ABSOFT2,0,0,0,0,0)
+#define ABSOFT_cf3(T0) _(T0,_cfSTR)(0,ABSOFT3,0,0,0,0,0)
+#define DEFAULT_cfABSOFT1
+#define LOGICAL_cfABSOFT1
+#define STRING_cfABSOFT1 ,MAX_LEN_FORTRAN_FUNCTION_STRING
+#define DEFAULT_cfABSOFT2
+#define LOGICAL_cfABSOFT2
+#define STRING_cfABSOFT2 ,unsigned D0
+#define DEFAULT_cfABSOFT3
+#define LOGICAL_cfABSOFT3
+#define STRING_cfABSOFT3 ,D0
+#else
+#define ABSOFT_cf1(T0)
+#define ABSOFT_cf2(T0)
+#define ABSOFT_cf3(T0)
+#endif
+
+/* _Z introduced to cicumvent IBM and HP silly preprocessor warning.
+ e.g. "Macro CFARGT14 invoked with a null argument."
+ */
+#define _Z
+
+#define CFARGT14S(S,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE) \
+ S(T1,1) S(T2,2) S(T3,3) S(T4,4) S(T5,5) S(T6,6) S(T7,7) \
+ S(T8,8) S(T9,9) S(TA,10) S(TB,11) S(TC,12) S(TD,13) S(TE,14)
+#define CFARGT27S(S,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,TP,TQ,TR) \
+ S(T1,1) S(T2,2) S(T3,3) S(T4,4) S(T5,5) S(T6,6) S(T7,7) \
+ S(T8,8) S(T9,9) S(TA,10) S(TB,11) S(TC,12) S(TD,13) S(TE,14) \
+ S(TF,15) S(TG,16) S(TH,17) S(TI,18) S(TJ,19) S(TK,20) S(TL,21) \
+ S(TM,22) S(TN,23) S(TO,24) S(TP,25) S(TQ,26) S(TR,27)
+
+#define CFARGT14FS(F,S,M,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE) \
+ F(T1,1,0) F(T2,2,1) F(T3,3,1) F(T4,4,1) F(T5,5,1) F(T6,6,1) F(T7,7,1) \
+ F(T8,8,1) F(T9,9,1) F(TA,10,1) F(TB,11,1) F(TC,12,1) F(TD,13,1) F(TE,14,1) \
+ M CFARGT14S(S,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE)
+#define CFARGT27FS(F,S,M,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,TP,TQ,TR) \
+ F(T1,1,0) F(T2,2,1) F(T3,3,1) F(T4,4,1) F(T5,5,1) F(T6,6,1) F(T7,7,1) \
+ F(T8,8,1) F(T9,9,1) F(TA,10,1) F(TB,11,1) F(TC,12,1) F(TD,13,1) F(TE,14,1) \
+ F(TF,15,1) F(TG,16,1) F(TH,17,1) F(TI,18,1) F(TJ,19,1) F(TK,20,1) F(TL,21,1) \
+ F(TM,22,1) F(TN,23,1) F(TO,24,1) F(TP,25,1) F(TQ,26,1) F(TR,27,1) \
+ M CFARGT27S(S,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,TP,TQ,TR)
+
+#if !(defined(PowerStationFortran)||defined(hpuxFortran800))
+/* Old CFARGT14 -> CFARGT14FS as seen below, for Absoft cross-compile yields:
+ SunOS> cc -c -Xa -DAbsoftUNIXFortran c.c
+ "c.c", line 406: warning: argument mismatch
+ Haven't checked if this is ANSI C or a SunOS bug. SunOS -Xs works ok.
+ Behavior is most clearly seen in example:
+ #define A 1 , 2
+ #define C(X,Y,Z) x=X. y=Y. z=Z.
+ #define D(X,Y,Z) C(X,Y,Z)
+ D(x,A,z)
+ Output from preprocessor is: x = x . y = 1 . z = 2 .
+ #define CFARGT14(F,S,M,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE) \
+ CFARGT14FS(F,S,M,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE)
+*/
+#define CFARGT14(F,S,M,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE) \
+ F(T1,1,0) F(T2,2,1) F(T3,3,1) F(T4,4,1) F(T5,5,1) F(T6,6,1) F(T7,7,1) \
+ F(T8,8,1) F(T9,9,1) F(TA,10,1) F(TB,11,1) F(TC,12,1) F(TD,13,1) F(TE,14,1) \
+ M CFARGT14S(S,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE)
+#define CFARGT27(F,S,M,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,TP,TQ,TR) \
+ F(T1,1,0) F(T2,2,1) F(T3,3,1) F(T4,4,1) F(T5,5,1) F(T6,6,1) F(T7,7,1) \
+ F(T8,8,1) F(T9,9,1) F(TA,10,1) F(TB,11,1) F(TC,12,1) F(TD,13,1) F(TE,14,1) \
+ F(TF,15,1) F(TG,16,1) F(TH,17,1) F(TI,18,1) F(TJ,19,1) F(TK,20,1) F(TL,21,1) \
+ F(TM,22,1) F(TN,23,1) F(TO,24,1) F(TP,25,1) F(TQ,26,1) F(TR,27,1) \
+ M CFARGT27S(S,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,TP,TQ,TR)
+
+#define CFARGT20(F,S,M,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK) \
+ F(T1,1,0) F(T2,2,1) F(T3,3,1) F(T4,4,1) F(T5,5,1) F(T6,6,1) F(T7,7,1) \
+ F(T8,8,1) F(T9,9,1) F(TA,10,1) F(TB,11,1) F(TC,12,1) F(TD,13,1) F(TE,14,1) \
+ F(TF,15,1) F(TG,16,1) F(TH,17,1) F(TI,18,1) F(TJ,19,1) F(TK,20,1) \
+ S(T1,1) S(T2,2) S(T3,3) S(T4,4) S(T5,5) S(T6,6) S(T7,7) \
+ S(T8,8) S(T9,9) S(TA,10) S(TB,11) S(TC,12) S(TD,13) S(TE,14) \
+ S(TF,15) S(TG,16) S(TH,17) S(TI,18) S(TJ,19) S(TK,20)
+#define CFARGTA14(F,S,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,AD,AE) \
+ F(T1,A1,1,0) F(T2,A2,2,1) F(T3,A3,3,1) F(T4,A4,4,1) F(T5,A5,5,1) F(T6,A6,6,1) \
+ F(T7,A7,7,1) F(T8,A8,8,1) F(T9,A9,9,1) F(TA,AA,10,1) F(TB,AB,11,1) F(TC,AC,12,1) \
+ F(TD,AD,13,1) F(TE,AE,14,1) S(T1,1) S(T2,2) S(T3,3) S(T4,4) \
+ S(T5,5) S(T6,6) S(T7,7) S(T8,8) S(T9,9) S(TA,10) \
+ S(TB,11) S(TC,12) S(TD,13) S(TE,14)
+#if MAX_PREPRO_ARGS>31
+#define CFARGTA20(F,S,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,AD,AE,AF,AG,AH,AI,AJ,AK) \
+ F(T1,A1,1,0) F(T2,A2,2,1) F(T3,A3,3,1) F(T4,A4,4,1) F(T5,A5,5,1) F(T6,A6,6,1) \
+ F(T7,A7,7,1) F(T8,A8,8,1) F(T9,A9,9,1) F(TA,AA,10,1) F(TB,AB,11,1) F(TC,AC,12,1) \
+ F(TD,AD,13,1) F(TE,AE,14,1) F(TF,AF,15,1) F(TG,AG,16,1) F(TH,AH,17,1) F(TI,AI,18,1) \
+ F(TJ,AJ,19,1) F(TK,AK,20,1) S(T1,1) S(T2,2) S(T3,3) S(T4,4) \
+ S(T5,5) S(T6,6) S(T7,7) S(T8,8) S(T9,9) S(TA,10) \
+ S(TB,11) S(TC,12) S(TD,13) S(TE,14) S(TF,15) S(TG,16) \
+ S(TH,17) S(TI,18) S(TJ,19) S(TK,20)
+#define CFARGTA27(F,S,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,TP,TQ,TR,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,AD,AE,AF,AG,AH,AI,AJ,AK,AL,AM,AN,AO,AP,AQ,AR) \
+ F(T1,A1,1,0) F(T2,A2,2,1) F(T3,A3,3,1) F(T4,A4,4,1) F(T5,A5,5,1) F(T6,A6,6,1) \
+ F(T7,A7,7,1) F(T8,A8,8,1) F(T9,A9,9,1) F(TA,AA,10,1) F(TB,AB,11,1) F(TC,AC,12,1) \
+ F(TD,AD,13,1) F(TE,AE,14,1) F(TF,AF,15,1) F(TG,AG,16,1) F(TH,AH,17,1) F(TI,AI,18,1) \
+ F(TJ,AJ,19,1) F(TK,AK,20,1) F(TL,AL,21,1) F(TM,AM,22,1) F(TN,AN,23,1) F(TO,AO,24,1) \
+ F(TP,AP,25,1) F(TQ,AQ,26,1) F(TR,AR,27,1) S(T1,1) S(T2,2) S(T3,3) \
+ S(T4,4) S(T5,5) S(T6,6) S(T7,7) S(T8,8) S(T9,9) \
+ S(TA,10) S(TB,11) S(TC,12) S(TD,13) S(TE,14) S(TF,15) \
+ S(TG,16) S(TH,17) S(TI,18) S(TJ,19) S(TK,20) S(TL,21) \
+ S(TM,22) S(TN,23) S(TO,24) S(TP,25) S(TQ,26) S(TR,27)
+#endif
+#else
+#define CFARGT14(F,S,M,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE) \
+ F(T1,1,0) S(T1,1) F(T2,2,1) S(T2,2) F(T3,3,1) S(T3,3) F(T4,4,1) S(T4,4) \
+ F(T5,5,1) S(T5,5) F(T6,6,1) S(T6,6) F(T7,7,1) S(T7,7) F(T8,8,1) S(T8,8) \
+ F(T9,9,1) S(T9,9) F(TA,10,1) S(TA,10) F(TB,11,1) S(TB,11) F(TC,12,1) S(TC,12) \
+ F(TD,13,1) S(TD,13) F(TE,14,1) S(TE,14)
+#define CFARGT27(F,S,M,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,TP,TQ,TR) \
+ F(T1,1,0) S(T1,1) F(T2,2,1) S(T2,2) F(T3,3,1) S(T3,3) F(T4,4,1) S(T4,4) \
+ F(T5,5,1) S(T5,5) F(T6,6,1) S(T6,6) F(T7,7,1) S(T7,7) F(T8,8,1) S(T8,8) \
+ F(T9,9,1) S(T9,9) F(TA,10,1) S(TA,10) F(TB,11,1) S(TB,11) F(TC,12,1) S(TC,12) \
+ F(TD,13,1) S(TD,13) F(TE,14,1) S(TE,14) F(TF,15,1) S(TF,15) F(TG,16,1) S(TG,16) \
+ F(TH,17,1) S(TH,17) F(TI,18,1) S(TI,18) F(TJ,19,1) S(TJ,19) F(TK,20,1) S(TK,20) \
+ F(TL,21,1) S(TL,21) F(TM,22,1) S(TM,22) F(TN,23,1) S(TN,23) F(TO,24,1) S(TO,24) \
+ F(TP,25,1) S(TP,25) F(TQ,26,1) S(TQ,26) F(TR,27,1) S(TR,27)
+
+#define CFARGT20(F,S,M,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK) \
+ F(T1,1,0) S(T1,1) F(T2,2,1) S(T2,2) F(T3,3,1) S(T3,3) F(T4,4,1) S(T4,4) \
+ F(T5,5,1) S(T5,5) F(T6,6,1) S(T6,6) F(T7,7,1) S(T7,7) F(T8,8,1) S(T8,8) \
+ F(T9,9,1) S(T9,9) F(TA,10,1) S(TA,10) F(TB,11,1) S(TB,11) F(TC,12,1) S(TC,12) \
+ F(TD,13,1) S(TD,13) F(TE,14,1) S(TE,14) F(TF,15,1) S(TF,15) F(TG,16,1) S(TG,16) \
+ F(TH,17,1) S(TH,17) F(TI,18,1) S(TI,18) F(TJ,19,1) S(TJ,19) F(TK,20,1) S(TK,20)
+#define CFARGTA14(F,S,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,AD,AE) \
+ F(T1,A1,1,0) S(T1,1) F(T2,A2,2,1) S(T2,2) F(T3,A3,3,1) S(T3,3) \
+ F(T4,A4,4,1) S(T4,4) F(T5,A5,5,1) S(T5,5) F(T6,A6,6,1) S(T6,6) \
+ F(T7,A7,7,1) S(T7,7) F(T8,A8,8,1) S(T8,8) F(T9,A9,9,1) S(T9,9) \
+ F(TA,AA,10,1) S(TA,10) F(TB,AB,11,1) S(TB,11) F(TC,AC,12,1) S(TC,12) \
+ F(TD,AD,13,1) S(TD,13) F(TE,AE,14,1) S(TE,14)
+#if MAX_PREPRO_ARGS>31
+#define CFARGTA20(F,S,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,AD,AE,AF,AG,AH,AI,AJ,AK) \
+ F(T1,A1,1,0) S(T1,1) F(T2,A2,2,1) S(T2,2) F(T3,A3,3,1) S(T3,3) \
+ F(T4,A4,4,1) S(T4,4) F(T5,A5,5,1) S(T5,5) F(T6,A6,6,1) S(T6,6) \
+ F(T7,A7,7,1) S(T7,7) F(T8,A8,8,1) S(T8,8) F(T9,A9,9,1) S(T9,9) \
+ F(TA,AA,10,1) S(TA,10) F(TB,AB,11,1) S(TB,11) F(TC,AC,12,1) S(TC,12) \
+ F(TD,AD,13,1) S(TD,13) F(TE,AE,14,1) S(TE,14) F(TF,AF,15,1) S(TF,15) \
+ F(TG,AG,16,1) S(TG,16) F(TH,AH,17,1) S(TH,17) F(TI,AI,18,1) S(TI,18) \
+ F(TJ,AJ,19,1) S(TJ,19) F(TK,AK,20,1) S(TK,20)
+#define CFARGTA27(F,S,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,TP,TQ,TR,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,AD,AE,AF,AG,AH,AI,AJ,AK,AL,AM,AN,AO,AP,AQ,AR) \
+ F(T1,A1,1,0) S(T1,1) F(T2,A2,2,1) S(T2,2) F(T3,A3,3,1) S(T3,3) \
+ F(T4,A4,4,1) S(T4,4) F(T5,A5,5,1) S(T5,5) F(T6,A6,6,1) S(T6,6) \
+ F(T7,A7,7,1) S(T7,7) F(T8,A8,8,1) S(T8,8) F(T9,A9,9,1) S(T9,9) \
+ F(TA,AA,10,1) S(TA,10) F(TB,AB,11,1) S(TB,11) F(TC,AC,12,1) S(TC,12) \
+ F(TD,AD,13,1) S(TD,13) F(TE,AE,14,1) S(TE,14) F(TF,AF,15,1) S(TF,15) \
+ F(TG,AG,16,1) S(TG,16) F(TH,AH,17,1) S(TH,17) F(TI,AI,18,1) S(TI,18) \
+ F(TJ,AJ,19,1) S(TJ,19) F(TK,AK,20,1) S(TK,20) F(TL,AL,21,1) S(TL,21) \
+ F(TM,AM,22,1) S(TM,22) F(TN,AN,23,1) S(TN,23) F(TO,AO,24,1) S(TO,24) \
+ F(TP,AP,25,1) S(TP,25) F(TQ,AQ,26,1) S(TQ,26) F(TR,AR,27,1) S(TR,27)
+#endif
+#endif
+
+
+#define PROTOCCALLSFSUB1( UN,LN,T1) \
+ PROTOCCALLSFSUB14(UN,LN,T1,CF_0,CF_0,CF_0,CF_0,CF_0,CF_0,CF_0,CF_0,CF_0,CF_0,CF_0,CF_0,CF_0)
+#define PROTOCCALLSFSUB2( UN,LN,T1,T2) \
+ PROTOCCALLSFSUB14(UN,LN,T1,T2,CF_0,CF_0,CF_0,CF_0,CF_0,CF_0,CF_0,CF_0,CF_0,CF_0,CF_0,CF_0)
+#define PROTOCCALLSFSUB3( UN,LN,T1,T2,T3) \
+ PROTOCCALLSFSUB14(UN,LN,T1,T2,T3,CF_0,CF_0,CF_0,CF_0,CF_0,CF_0,CF_0,CF_0,CF_0,CF_0,CF_0)
+#define PROTOCCALLSFSUB4( UN,LN,T1,T2,T3,T4) \
+ PROTOCCALLSFSUB14(UN,LN,T1,T2,T3,T4,CF_0,CF_0,CF_0,CF_0,CF_0,CF_0,CF_0,CF_0,CF_0,CF_0)
+#define PROTOCCALLSFSUB5( UN,LN,T1,T2,T3,T4,T5) \
+ PROTOCCALLSFSUB14(UN,LN,T1,T2,T3,T4,T5,CF_0,CF_0,CF_0,CF_0,CF_0,CF_0,CF_0,CF_0,CF_0)
+#define PROTOCCALLSFSUB6( UN,LN,T1,T2,T3,T4,T5,T6) \
+ PROTOCCALLSFSUB14(UN,LN,T1,T2,T3,T4,T5,T6,CF_0,CF_0,CF_0,CF_0,CF_0,CF_0,CF_0,CF_0)
+#define PROTOCCALLSFSUB7( UN,LN,T1,T2,T3,T4,T5,T6,T7) \
+ PROTOCCALLSFSUB14(UN,LN,T1,T2,T3,T4,T5,T6,T7,CF_0,CF_0,CF_0,CF_0,CF_0,CF_0,CF_0)
+#define PROTOCCALLSFSUB8( UN,LN,T1,T2,T3,T4,T5,T6,T7,T8) \
+ PROTOCCALLSFSUB14(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,CF_0,CF_0,CF_0,CF_0,CF_0,CF_0)
+#define PROTOCCALLSFSUB9( UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9) \
+ PROTOCCALLSFSUB14(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,CF_0,CF_0,CF_0,CF_0,CF_0)
+#define PROTOCCALLSFSUB10(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA) \
+ PROTOCCALLSFSUB14(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,CF_0,CF_0,CF_0,CF_0)
+#define PROTOCCALLSFSUB11(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB) \
+ PROTOCCALLSFSUB14(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,CF_0,CF_0,CF_0)
+#define PROTOCCALLSFSUB12(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC) \
+ PROTOCCALLSFSUB14(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,CF_0,CF_0)
+#define PROTOCCALLSFSUB13(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD) \
+ PROTOCCALLSFSUB14(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,CF_0)
+
+
+#define PROTOCCALLSFSUB15(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF) \
+ PROTOCCALLSFSUB20(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,CF_0,CF_0,CF_0,CF_0,CF_0)
+#define PROTOCCALLSFSUB16(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG) \
+ PROTOCCALLSFSUB20(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,CF_0,CF_0,CF_0,CF_0)
+#define PROTOCCALLSFSUB17(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH) \
+ PROTOCCALLSFSUB20(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,CF_0,CF_0,CF_0)
+#define PROTOCCALLSFSUB18(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI) \
+ PROTOCCALLSFSUB20(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,CF_0,CF_0)
+#define PROTOCCALLSFSUB19(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ) \
+ PROTOCCALLSFSUB20(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,CF_0)
+
+#define PROTOCCALLSFSUB21(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL) \
+ PROTOCCALLSFSUB27(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,CF_0,CF_0,CF_0,CF_0,CF_0,CF_0)
+#define PROTOCCALLSFSUB22(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM) \
+ PROTOCCALLSFSUB27(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,CF_0,CF_0,CF_0,CF_0,CF_0)
+#define PROTOCCALLSFSUB23(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN) \
+ PROTOCCALLSFSUB27(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,CF_0,CF_0,CF_0,CF_0)
+#define PROTOCCALLSFSUB24(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO) \
+ PROTOCCALLSFSUB27(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,CF_0,CF_0,CF_0)
+#define PROTOCCALLSFSUB25(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,TP) \
+ PROTOCCALLSFSUB27(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,TP,CF_0,CF_0)
+#define PROTOCCALLSFSUB26(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,TP,TQ) \
+ PROTOCCALLSFSUB27(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,TP,TQ,CF_0)
+
+
+#ifndef FCALLSC_QUALIFIER
+#ifdef VISUAL_CPLUSPLUS
+#define FCALLSC_QUALIFIER __stdcall
+#else
+#define FCALLSC_QUALIFIER
+#endif
+#endif
+
+#ifdef __cplusplus
+#define CFextern extern "C"
+#else
+#define CFextern extern
+#endif
+
+
+#ifdef CFSUBASFUN
+#define PROTOCCALLSFSUB0(UN,LN) \
+ PROTOCCALLSFFUN0( VOID,UN,LN)
+#define PROTOCCALLSFSUB14(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE) \
+ PROTOCCALLSFFUN14(VOID,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE)
+#define PROTOCCALLSFSUB20(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK)\
+ PROTOCCALLSFFUN20(VOID,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK)
+#define PROTOCCALLSFSUB27(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,TP,TQ,TR)\
+ PROTOCCALLSFFUN27(VOID,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,TP,TQ,TR)
+#else
+/* Note: Prevent compiler warnings, null #define PROTOCCALLSFSUB14/20 after
+ #include-ing cfortran.h if calling the FORTRAN wrapper within the same
+ source code where the wrapper is created. */
+#define PROTOCCALLSFSUB0(UN,LN) _(VOID,_cfPU)(CFC_(UN,LN))();
+#ifndef __CF__KnR
+#define PROTOCCALLSFSUB14(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE) \
+ _(VOID,_cfPU)(CFC_(UN,LN))( CFARGT14(NCF,KCF,_Z,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE) );
+#define PROTOCCALLSFSUB20(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK)\
+ _(VOID,_cfPU)(CFC_(UN,LN))( CFARGT20(NCF,KCF,_Z,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK) );
+#define PROTOCCALLSFSUB27(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,TP,TQ,TR)\
+ _(VOID,_cfPU)(CFC_(UN,LN))( CFARGT27(NCF,KCF,_Z,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,TP,TQ,TR) );
+#else
+#define PROTOCCALLSFSUB14(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE) \
+ PROTOCCALLSFSUB0(UN,LN)
+#define PROTOCCALLSFSUB20(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK) \
+ PROTOCCALLSFSUB0(UN,LN)
+#define PROTOCCALLSFSUB27(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,TP,TQ,TR) \
+ PROTOCCALLSFSUB0(UN,LN)
+#endif
+#endif
+
+
+#ifdef OLD_VAXC /* Allow %CC-I-PARAMNOTUSED. */
+#pragma standard
+#endif
+
+
+#define CCALLSFSUB1( UN,LN,T1, A1) \
+ CCALLSFSUB5 (UN,LN,T1,CF_0,CF_0,CF_0,CF_0,A1,0,0,0,0)
+#define CCALLSFSUB2( UN,LN,T1,T2, A1,A2) \
+ CCALLSFSUB5 (UN,LN,T1,T2,CF_0,CF_0,CF_0,A1,A2,0,0,0)
+#define CCALLSFSUB3( UN,LN,T1,T2,T3, A1,A2,A3) \
+ CCALLSFSUB5 (UN,LN,T1,T2,T3,CF_0,CF_0,A1,A2,A3,0,0)
+#define CCALLSFSUB4( UN,LN,T1,T2,T3,T4, A1,A2,A3,A4)\
+ CCALLSFSUB5 (UN,LN,T1,T2,T3,T4,CF_0,A1,A2,A3,A4,0)
+#define CCALLSFSUB5( UN,LN,T1,T2,T3,T4,T5, A1,A2,A3,A4,A5) \
+ CCALLSFSUB10(UN,LN,T1,T2,T3,T4,T5,CF_0,CF_0,CF_0,CF_0,CF_0,A1,A2,A3,A4,A5,0,0,0,0,0)
+#define CCALLSFSUB6( UN,LN,T1,T2,T3,T4,T5,T6, A1,A2,A3,A4,A5,A6) \
+ CCALLSFSUB10(UN,LN,T1,T2,T3,T4,T5,T6,CF_0,CF_0,CF_0,CF_0,A1,A2,A3,A4,A5,A6,0,0,0,0)
+#define CCALLSFSUB7( UN,LN,T1,T2,T3,T4,T5,T6,T7, A1,A2,A3,A4,A5,A6,A7) \
+ CCALLSFSUB10(UN,LN,T1,T2,T3,T4,T5,T6,T7,CF_0,CF_0,CF_0,A1,A2,A3,A4,A5,A6,A7,0,0,0)
+#define CCALLSFSUB8( UN,LN,T1,T2,T3,T4,T5,T6,T7,T8, A1,A2,A3,A4,A5,A6,A7,A8) \
+ CCALLSFSUB10(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,CF_0,CF_0,A1,A2,A3,A4,A5,A6,A7,A8,0,0)
+#define CCALLSFSUB9( UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,A1,A2,A3,A4,A5,A6,A7,A8,A9)\
+ CCALLSFSUB10(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,CF_0,A1,A2,A3,A4,A5,A6,A7,A8,A9,0)
+#define CCALLSFSUB10(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA)\
+ CCALLSFSUB14(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,CF_0,CF_0,CF_0,CF_0,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,0,0,0,0)
+#define CCALLSFSUB11(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB)\
+ CCALLSFSUB14(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,CF_0,CF_0,CF_0,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,0,0,0)
+#define CCALLSFSUB12(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC)\
+ CCALLSFSUB14(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,CF_0,CF_0,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,0,0)
+#define CCALLSFSUB13(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,AD)\
+ CCALLSFSUB14(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,CF_0,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,AD,0)
+
+#ifdef __cplusplus
+#define CPPPROTOCLSFSUB0( UN,LN)
+#define CPPPROTOCLSFSUB14(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE)
+#define CPPPROTOCLSFSUB20(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK)
+#define CPPPROTOCLSFSUB27(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,TP,TQ,TR)
+#else
+#define CPPPROTOCLSFSUB0(UN,LN) \
+ PROTOCCALLSFSUB0(UN,LN)
+#define CPPPROTOCLSFSUB14(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE) \
+ PROTOCCALLSFSUB14(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE)
+#define CPPPROTOCLSFSUB20(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK) \
+ PROTOCCALLSFSUB20(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK)
+#define CPPPROTOCLSFSUB27(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,TP,TQ,TR) \
+ PROTOCCALLSFSUB27(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,TP,TQ,TR)
+#endif
+
+#ifdef CFSUBASFUN
+#define CCALLSFSUB0(UN,LN) CCALLSFFUN0(UN,LN)
+#define CCALLSFSUB14(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,AD,AE)\
+ CCALLSFFUN14(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,AD,AE)
+#else
+/* do{...}while(0) allows if(a==b) FORT(); else BORT(); */
+#define CCALLSFSUB0( UN,LN) do{CPPPROTOCLSFSUB0(UN,LN) CFC_(UN,LN)();}while(0)
+#define CCALLSFSUB14(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,AD,AE)\
+do{VVCF(T1,A1,B1) VVCF(T2,A2,B2) VVCF(T3,A3,B3) VVCF(T4,A4,B4) VVCF(T5,A5,B5) \
+ VVCF(T6,A6,B6) VVCF(T7,A7,B7) VVCF(T8,A8,B8) VVCF(T9,A9,B9) VVCF(TA,AA,B10) \
+ VVCF(TB,AB,B11) VVCF(TC,AC,B12) VVCF(TD,AD,B13) VVCF(TE,AE,B14) \
+ CPPPROTOCLSFSUB14(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE) \
+ ACF(LN,T1,A1,1) ACF(LN,T2,A2,2) ACF(LN,T3,A3,3) \
+ ACF(LN,T4,A4,4) ACF(LN,T5,A5,5) ACF(LN,T6,A6,6) ACF(LN,T7,A7,7) \
+ ACF(LN,T8,A8,8) ACF(LN,T9,A9,9) ACF(LN,TA,AA,10) ACF(LN,TB,AB,11) \
+ ACF(LN,TC,AC,12) ACF(LN,TD,AD,13) ACF(LN,TE,AE,14) \
+ CFC_(UN,LN)( CFARGTA14(AACF,JCF,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,AD,AE) );\
+ WCF(T1,A1,1) WCF(T2,A2,2) WCF(T3,A3,3) WCF(T4,A4,4) WCF(T5,A5,5) \
+ WCF(T6,A6,6) WCF(T7,A7,7) WCF(T8,A8,8) WCF(T9,A9,9) WCF(TA,AA,10) \
+ WCF(TB,AB,11) WCF(TC,AC,12) WCF(TD,AD,13) WCF(TE,AE,14) }while(0)
+#endif
+
+
+#if MAX_PREPRO_ARGS>31
+#define CCALLSFSUB15(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,AD,AE,AF)\
+ CCALLSFSUB20(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,CF_0,CF_0,CF_0,CF_0,CF_0,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,AD,AE,AF,0,0,0,0,0)
+#define CCALLSFSUB16(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,AD,AE,AF,AG)\
+ CCALLSFSUB20(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,CF_0,CF_0,CF_0,CF_0,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,AD,AE,AF,AG,0,0,0,0)
+#define CCALLSFSUB17(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,AD,AE,AF,AG,AH)\
+ CCALLSFSUB20(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,CF_0,CF_0,CF_0,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,AD,AE,AF,AG,AH,0,0,0)
+#define CCALLSFSUB18(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,AD,AE,AF,AG,AH,AI)\
+ CCALLSFSUB20(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,CF_0,CF_0,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,AD,AE,AF,AG,AH,AI,0,0)
+#define CCALLSFSUB19(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,AD,AE,AF,AG,AH,AI,AJ)\
+ CCALLSFSUB20(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,CF_0,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,AD,AE,AF,AG,AH,AI,AJ,0)
+
+#ifdef CFSUBASFUN
+#define CCALLSFSUB20(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH, \
+ TI,TJ,TK, A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,AD,AE,AF,AG,AH,AI,AJ,AK) \
+ CCALLSFFUN20(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH, \
+ TI,TJ,TK, A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,AD,AE,AF,AG,AH,AI,AJ,AK)
+#else
+#define CCALLSFSUB20(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH, \
+ TI,TJ,TK, A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,AD,AE,AF,AG,AH,AI,AJ,AK) \
+do{VVCF(T1,A1,B1) VVCF(T2,A2,B2) VVCF(T3,A3,B3) VVCF(T4,A4,B4) VVCF(T5,A5,B5) \
+ VVCF(T6,A6,B6) VVCF(T7,A7,B7) VVCF(T8,A8,B8) VVCF(T9,A9,B9) VVCF(TA,AA,B10) \
+ VVCF(TB,AB,B11) VVCF(TC,AC,B12) VVCF(TD,AD,B13) VVCF(TE,AE,B14) VVCF(TF,AF,B15) \
+ VVCF(TG,AG,B16) VVCF(TH,AH,B17) VVCF(TI,AI,B18) VVCF(TJ,AJ,B19) VVCF(TK,AK,B20) \
+ CPPPROTOCLSFSUB20(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK) \
+ ACF(LN,T1,A1,1) ACF(LN,T2,A2,2) ACF(LN,T3,A3,3) ACF(LN,T4,A4,4) \
+ ACF(LN,T5,A5,5) ACF(LN,T6,A6,6) ACF(LN,T7,A7,7) ACF(LN,T8,A8,8) \
+ ACF(LN,T9,A9,9) ACF(LN,TA,AA,10) ACF(LN,TB,AB,11) ACF(LN,TC,AC,12) \
+ ACF(LN,TD,AD,13) ACF(LN,TE,AE,14) ACF(LN,TF,AF,15) ACF(LN,TG,AG,16) \
+ ACF(LN,TH,AH,17) ACF(LN,TI,AI,18) ACF(LN,TJ,AJ,19) ACF(LN,TK,AK,20) \
+ CFC_(UN,LN)( CFARGTA20(AACF,JCF,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,AD,AE,AF,AG,AH,AI,AJ,AK) ); \
+ WCF(T1,A1,1) WCF(T2,A2,2) WCF(T3,A3,3) WCF(T4,A4,4) WCF(T5,A5,5) WCF(T6,A6,6) \
+ WCF(T7,A7,7) WCF(T8,A8,8) WCF(T9,A9,9) WCF(TA,AA,10) WCF(TB,AB,11) WCF(TC,AC,12) \
+ WCF(TD,AD,13) WCF(TE,AE,14) WCF(TF,AF,15) WCF(TG,AG,16) WCF(TH,AH,17) WCF(TI,AI,18) \
+ WCF(TJ,AJ,19) WCF(TK,AK,20) }while(0)
+#endif
+#endif /* MAX_PREPRO_ARGS */
+
+#if MAX_PREPRO_ARGS>31
+#define CCALLSFSUB21(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,AD,AE,AF,AG,AH,AI,AJ,AK,AL)\
+ CCALLSFSUB27(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,CF_0,CF_0,CF_0,CF_0,CF_0,CF_0,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,AD,AE,AF,AG,AH,AI,AJ,AK,AL,0,0,0,0,0,0)
+#define CCALLSFSUB22(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,AD,AE,AF,AG,AH,AI,AJ,AK,AL,AM)\
+ CCALLSFSUB27(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,CF_0,CF_0,CF_0,CF_0,CF_0,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,AD,AE,AF,AG,AH,AI,AJ,AK,AL,AM,0,0,0,0,0)
+#define CCALLSFSUB23(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,AD,AE,AF,AG,AH,AI,AJ,AK,AL,AM,AN)\
+ CCALLSFSUB27(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,CF_0,CF_0,CF_0,CF_0,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,AD,AE,AF,AG,AH,AI,AJ,AK,AL,AM,AN,0,0,0,0)
+#define CCALLSFSUB24(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,AD,AE,AF,AG,AH,AI,AJ,AK,AL,AM,AN,AO)\
+ CCALLSFSUB27(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,CF_0,CF_0,CF_0,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,AD,AE,AF,AG,AH,AI,AJ,AK,AL,AM,AN,AO,0,0,0)
+#define CCALLSFSUB25(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,TP,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,AD,AE,AF,AG,AH,AI,AJ,AK,AL,AM,AN,AO,AP)\
+ CCALLSFSUB27(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,TP,CF_0,CF_0,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,AD,AE,AF,AG,AH,AI,AJ,AK,AL,AM,AN,AO,AP,0,0)
+#define CCALLSFSUB26(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,TP,TQ,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,AD,AE,AF,AG,AH,AI,AJ,AK,AL,AM,AN,AO,AP,AQ)\
+ CCALLSFSUB27(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,TP,TQ,CF_0,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,AD,AE,AF,AG,AH,AI,AJ,AK,AL,AM,AN,AO,AP,AQ,0)
+
+#ifdef CFSUBASFUN
+#define CCALLSFSUB27(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,TP,TQ,TR, \
+ A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,AD,AE,AF,AG,AH,AI,AJ,AK,AL,AM,AN,AO,AP,AQ,AR) \
+ CCALLSFFUN27(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,TP,TQ,TR, \
+ A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,AD,AE,AF,AG,AH,AI,AJ,AK,AL,AM,AN,AO,AP,AQ,AR)
+#else
+#define CCALLSFSUB27(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,TP,TQ,TR, \
+ A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,AD,AE,AF,AG,AH,AI,AJ,AK,AL,AM,AN,AO,AP,AQ,AR) \
+do{VVCF(T1,A1,B1) VVCF(T2,A2,B2) VVCF(T3,A3,B3) VVCF(T4,A4,B4) VVCF(T5,A5,B5) \
+ VVCF(T6,A6,B6) VVCF(T7,A7,B7) VVCF(T8,A8,B8) VVCF(T9,A9,B9) VVCF(TA,AA,B10) \
+ VVCF(TB,AB,B11) VVCF(TC,AC,B12) VVCF(TD,AD,B13) VVCF(TE,AE,B14) VVCF(TF,AF,B15) \
+ VVCF(TG,AG,B16) VVCF(TH,AH,B17) VVCF(TI,AI,B18) VVCF(TJ,AJ,B19) VVCF(TK,AK,B20) \
+ VVCF(TL,AL,B21) VVCF(TM,AM,B22) VVCF(TN,AN,B23) VVCF(TO,AO,B24) VVCF(TP,AP,B25) \
+ VVCF(TQ,AQ,B26) VVCF(TR,AR,B27) \
+ CPPPROTOCLSFSUB27(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,TP,TQ,TR) \
+ ACF(LN,T1,A1,1) ACF(LN,T2,A2,2) ACF(LN,T3,A3,3) ACF(LN,T4,A4,4) \
+ ACF(LN,T5,A5,5) ACF(LN,T6,A6,6) ACF(LN,T7,A7,7) ACF(LN,T8,A8,8) \
+ ACF(LN,T9,A9,9) ACF(LN,TA,AA,10) ACF(LN,TB,AB,11) ACF(LN,TC,AC,12) \
+ ACF(LN,TD,AD,13) ACF(LN,TE,AE,14) ACF(LN,TF,AF,15) ACF(LN,TG,AG,16) \
+ ACF(LN,TH,AH,17) ACF(LN,TI,AI,18) ACF(LN,TJ,AJ,19) ACF(LN,TK,AK,20) \
+ ACF(LN,TL,AL,21) ACF(LN,TM,AM,22) ACF(LN,TN,AN,23) ACF(LN,TO,AO,24) \
+ ACF(LN,TP,AP,25) ACF(LN,TQ,AQ,26) ACF(LN,TR,AR,27) \
+ CFC_(UN,LN)( CFARGTA27(AACF,JCF,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,TP,TQ,TR,\
+ A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,AD,AE,AF,AG,AH,AI,AJ,AK,AL,AM,AN,AO,AP,AQ,AR) ); \
+ WCF(T1,A1,1) WCF(T2,A2,2) WCF(T3,A3,3) WCF(T4,A4,4) WCF(T5,A5,5) WCF(T6,A6,6) \
+ WCF(T7,A7,7) WCF(T8,A8,8) WCF(T9,A9,9) WCF(TA,AA,10) WCF(TB,AB,11) WCF(TC,AC,12) \
+ WCF(TD,AD,13) WCF(TE,AE,14) WCF(TF,AF,15) WCF(TG,AG,16) WCF(TH,AH,17) WCF(TI,AI,18) \
+ WCF(TJ,AJ,19) WCF(TK,AK,20) WCF(TL,AL,21) WCF(TM,AM,22) WCF(TN,AN,23) WCF(TO,AO,24) \
+ WCF(TP,AP,25) WCF(TQ,AQ,26) WCF(TR,AR,27) }while(0)
+#endif
+#endif /* MAX_PREPRO_ARGS */
+
+/*-------------------------------------------------------------------------*/
+
+/* UTILITIES FOR C TO CALL FORTRAN FUNCTIONS */
+
+/*N.B. PROTOCCALLSFFUNn(..) generates code, whether or not the FORTRAN
+ function is called. Therefore, especially for creator's of C header files
+ for large FORTRAN libraries which include many functions, to reduce
+ compile time and object code size, it may be desirable to create
+ preprocessor directives to allow users to create code for only those
+ functions which they use. */
+
+/* The following defines the maximum length string that a function can return.
+ Of course it may be undefine-d and re-define-d before individual
+ PROTOCCALLSFFUNn(..) as required. It would also be nice to have this derived
+ from the individual machines' limits. */
+#define MAX_LEN_FORTRAN_FUNCTION_STRING 0x4FE
+
+/* The following defines a character used by CFORTRAN.H to flag the end of a
+ string coming out of a FORTRAN routine. */
+#define CFORTRAN_NON_CHAR 0x7F
+
+#ifdef OLD_VAXC /* Prevent %CC-I-PARAMNOTUSED. */
+#pragma nostandard
+#endif
+
+#define _SEP_(TN,C,cfCOMMA) _(__SEP_,C)(TN,cfCOMMA)
+#define __SEP_0(TN,cfCOMMA)
+#define __SEP_1(TN,cfCOMMA) _Icf(2,SEP,TN,cfCOMMA,0)
+#define INT_cfSEP(T,B) _(A,B)
+#define INTV_cfSEP(T,B) INT_cfSEP(T,B)
+#define INTVV_cfSEP(T,B) INT_cfSEP(T,B)
+#define INTVVV_cfSEP(T,B) INT_cfSEP(T,B)
+#define INTVVVV_cfSEP(T,B) INT_cfSEP(T,B)
+#define INTVVVVV_cfSEP(T,B) INT_cfSEP(T,B)
+#define INTVVVVVV_cfSEP(T,B) INT_cfSEP(T,B)
+#define INTVVVVVVV_cfSEP(T,B) INT_cfSEP(T,B)
+#define PINT_cfSEP(T,B) INT_cfSEP(T,B)
+#define PVOID_cfSEP(T,B) INT_cfSEP(T,B)
+#define ROUTINE_cfSEP(T,B) INT_cfSEP(T,B)
+#define SIMPLE_cfSEP(T,B) INT_cfSEP(T,B)
+#define VOID_cfSEP(T,B) INT_cfSEP(T,B) /* For FORTRAN calls C subr.s.*/
+#define STRING_cfSEP(T,B) INT_cfSEP(T,B)
+#define STRINGV_cfSEP(T,B) INT_cfSEP(T,B)
+#define PSTRING_cfSEP(T,B) INT_cfSEP(T,B)
+#define PSTRINGV_cfSEP(T,B) INT_cfSEP(T,B)
+#define PNSTRING_cfSEP(T,B) INT_cfSEP(T,B)
+#define PPSTRING_cfSEP(T,B) INT_cfSEP(T,B)
+#define ZTRINGV_cfSEP(T,B) INT_cfSEP(T,B)
+#define PZTRINGV_cfSEP(T,B) INT_cfSEP(T,B)
+
+#if defined(SIGNED_BYTE) || !defined(UNSIGNED_BYTE)
+#ifdef OLD_VAXC
+#define INTEGER_BYTE char /* Old VAXC barfs on 'signed char' */
+#else
+#define INTEGER_BYTE signed char /* default */
+#endif
+#else
+#define INTEGER_BYTE unsigned char
+#endif
+#define BYTEVVVVVVV_cfTYPE INTEGER_BYTE
+#define DOUBLEVVVVVVV_cfTYPE DOUBLE_PRECISION
+#define FLOATVVVVVVV_cfTYPE FORTRAN_REAL
+#define INTVVVVVVV_cfTYPE int
+#define LOGICALVVVVVVV_cfTYPE int
+#define LONGVVVVVVV_cfTYPE long
+#define SHORTVVVVVVV_cfTYPE short
+#define PBYTE_cfTYPE INTEGER_BYTE
+#define PDOUBLE_cfTYPE DOUBLE_PRECISION
+#define PFLOAT_cfTYPE FORTRAN_REAL
+#define PINT_cfTYPE int
+#define PLOGICAL_cfTYPE int
+#define PLONG_cfTYPE long
+#define PSHORT_cfTYPE short
+
+#define CFARGS0(A,T,V,W,X,Y,Z) _3(T,_cf,A)
+#define CFARGS1(A,T,V,W,X,Y,Z) _3(T,_cf,A)(V)
+#define CFARGS2(A,T,V,W,X,Y,Z) _3(T,_cf,A)(V,W)
+#define CFARGS3(A,T,V,W,X,Y,Z) _3(T,_cf,A)(V,W,X)
+#define CFARGS4(A,T,V,W,X,Y,Z) _3(T,_cf,A)(V,W,X,Y)
+#define CFARGS5(A,T,V,W,X,Y,Z) _3(T,_cf,A)(V,W,X,Y,Z)
+
+#define _Icf(N,T,I,X,Y) _(I,_cfINT)(N,T,I,X,Y,0)
+#define _Icf4(N,T,I,X,Y,Z) _(I,_cfINT)(N,T,I,X,Y,Z)
+#define BYTE_cfINT(N,A,B,X,Y,Z) DOUBLE_cfINT(N,A,B,X,Y,Z)
+#define DOUBLE_cfINT(N,A,B,X,Y,Z) _(CFARGS,N)(A,INT,B,X,Y,Z,0)
+#define FLOAT_cfINT(N,A,B,X,Y,Z) DOUBLE_cfINT(N,A,B,X,Y,Z)
+#define INT_cfINT(N,A,B,X,Y,Z) DOUBLE_cfINT(N,A,B,X,Y,Z)
+#define LOGICAL_cfINT(N,A,B,X,Y,Z) DOUBLE_cfINT(N,A,B,X,Y,Z)
+#define LONG_cfINT(N,A,B,X,Y,Z) DOUBLE_cfINT(N,A,B,X,Y,Z)
+#define SHORT_cfINT(N,A,B,X,Y,Z) DOUBLE_cfINT(N,A,B,X,Y,Z)
+#define PBYTE_cfINT(N,A,B,X,Y,Z) PDOUBLE_cfINT(N,A,B,X,Y,Z)
+#define PDOUBLE_cfINT(N,A,B,X,Y,Z) _(CFARGS,N)(A,PINT,B,X,Y,Z,0)
+#define PFLOAT_cfINT(N,A,B,X,Y,Z) PDOUBLE_cfINT(N,A,B,X,Y,Z)
+#define PINT_cfINT(N,A,B,X,Y,Z) PDOUBLE_cfINT(N,A,B,X,Y,Z)
+#define PLOGICAL_cfINT(N,A,B,X,Y,Z) PDOUBLE_cfINT(N,A,B,X,Y,Z)
+#define PLONG_cfINT(N,A,B,X,Y,Z) PDOUBLE_cfINT(N,A,B,X,Y,Z)
+#define PSHORT_cfINT(N,A,B,X,Y,Z) PDOUBLE_cfINT(N,A,B,X,Y,Z)
+#define BYTEV_cfINT(N,A,B,X,Y,Z) DOUBLEV_cfINT(N,A,B,X,Y,Z)
+#define BYTEVV_cfINT(N,A,B,X,Y,Z) DOUBLEVV_cfINT(N,A,B,X,Y,Z)
+#define BYTEVVV_cfINT(N,A,B,X,Y,Z) DOUBLEVVV_cfINT(N,A,B,X,Y,Z)
+#define BYTEVVVV_cfINT(N,A,B,X,Y,Z) DOUBLEVVVV_cfINT(N,A,B,X,Y,Z)
+#define BYTEVVVVV_cfINT(N,A,B,X,Y,Z) DOUBLEVVVVV_cfINT(N,A,B,X,Y,Z)
+#define BYTEVVVVVV_cfINT(N,A,B,X,Y,Z) DOUBLEVVVVVV_cfINT(N,A,B,X,Y,Z)
+#define BYTEVVVVVVV_cfINT(N,A,B,X,Y,Z) DOUBLEVVVVVVV_cfINT(N,A,B,X,Y,Z)
+#define DOUBLEV_cfINT(N,A,B,X,Y,Z) _(CFARGS,N)(A,INTV,B,X,Y,Z,0)
+#define DOUBLEVV_cfINT(N,A,B,X,Y,Z) _(CFARGS,N)(A,INTVV,B,X,Y,Z,0)
+#define DOUBLEVVV_cfINT(N,A,B,X,Y,Z) _(CFARGS,N)(A,INTVVV,B,X,Y,Z,0)
+#define DOUBLEVVVV_cfINT(N,A,B,X,Y,Z) _(CFARGS,N)(A,INTVVVV,B,X,Y,Z,0)
+#define DOUBLEVVVVV_cfINT(N,A,B,X,Y,Z) _(CFARGS,N)(A,INTVVVVV,B,X,Y,Z,0)
+#define DOUBLEVVVVVV_cfINT(N,A,B,X,Y,Z) _(CFARGS,N)(A,INTVVVVVV,B,X,Y,Z,0)
+#define DOUBLEVVVVVVV_cfINT(N,A,B,X,Y,Z) _(CFARGS,N)(A,INTVVVVVVV,B,X,Y,Z,0)
+#define FLOATV_cfINT(N,A,B,X,Y,Z) DOUBLEV_cfINT(N,A,B,X,Y,Z)
+#define FLOATVV_cfINT(N,A,B,X,Y,Z) DOUBLEVV_cfINT(N,A,B,X,Y,Z)
+#define FLOATVVV_cfINT(N,A,B,X,Y,Z) DOUBLEVVV_cfINT(N,A,B,X,Y,Z)
+#define FLOATVVVV_cfINT(N,A,B,X,Y,Z) DOUBLEVVVV_cfINT(N,A,B,X,Y,Z)
+#define FLOATVVVVV_cfINT(N,A,B,X,Y,Z) DOUBLEVVVVV_cfINT(N,A,B,X,Y,Z)
+#define FLOATVVVVVV_cfINT(N,A,B,X,Y,Z) DOUBLEVVVVVV_cfINT(N,A,B,X,Y,Z)
+#define FLOATVVVVVVV_cfINT(N,A,B,X,Y,Z) DOUBLEVVVVVVV_cfINT(N,A,B,X,Y,Z)
+#define INTV_cfINT(N,A,B,X,Y,Z) DOUBLEV_cfINT(N,A,B,X,Y,Z)
+#define INTVV_cfINT(N,A,B,X,Y,Z) DOUBLEVV_cfINT(N,A,B,X,Y,Z)
+#define INTVVV_cfINT(N,A,B,X,Y,Z) DOUBLEVVV_cfINT(N,A,B,X,Y,Z)
+#define INTVVVV_cfINT(N,A,B,X,Y,Z) DOUBLEVVVV_cfINT(N,A,B,X,Y,Z)
+#define INTVVVVV_cfINT(N,A,B,X,Y,Z) DOUBLEVVVVV_cfINT(N,A,B,X,Y,Z)
+#define INTVVVVVV_cfINT(N,A,B,X,Y,Z) DOUBLEVVVVVV_cfINT(N,A,B,X,Y,Z)
+#define INTVVVVVVV_cfINT(N,A,B,X,Y,Z) DOUBLEVVVVVVV_cfINT(N,A,B,X,Y,Z)
+#define LOGICALV_cfINT(N,A,B,X,Y,Z) DOUBLEV_cfINT(N,A,B,X,Y,Z)
+#define LOGICALVV_cfINT(N,A,B,X,Y,Z) DOUBLEVV_cfINT(N,A,B,X,Y,Z)
+#define LOGICALVVV_cfINT(N,A,B,X,Y,Z) DOUBLEVVV_cfINT(N,A,B,X,Y,Z)
+#define LOGICALVVVV_cfINT(N,A,B,X,Y,Z) DOUBLEVVVV_cfINT(N,A,B,X,Y,Z)
+#define LOGICALVVVVV_cfINT(N,A,B,X,Y,Z) DOUBLEVVVVV_cfINT(N,A,B,X,Y,Z)
+#define LOGICALVVVVVV_cfINT(N,A,B,X,Y,Z) DOUBLEVVVVVV_cfINT(N,A,B,X,Y,Z)
+#define LOGICALVVVVVVV_cfINT(N,A,B,X,Y,Z) DOUBLEVVVVVVV_cfINT(N,A,B,X,Y,Z)
+#define LONGV_cfINT(N,A,B,X,Y,Z) DOUBLEV_cfINT(N,A,B,X,Y,Z)
+#define LONGVV_cfINT(N,A,B,X,Y,Z) DOUBLEVV_cfINT(N,A,B,X,Y,Z)
+#define LONGVVV_cfINT(N,A,B,X,Y,Z) DOUBLEVVV_cfINT(N,A,B,X,Y,Z)
+#define LONGVVVV_cfINT(N,A,B,X,Y,Z) DOUBLEVVVV_cfINT(N,A,B,X,Y,Z)
+#define LONGVVVVV_cfINT(N,A,B,X,Y,Z) DOUBLEVVVVV_cfINT(N,A,B,X,Y,Z)
+#define LONGVVVVVV_cfINT(N,A,B,X,Y,Z) DOUBLEVVVVVV_cfINT(N,A,B,X,Y,Z)
+#define LONGVVVVVVV_cfINT(N,A,B,X,Y,Z) DOUBLEVVVVVVV_cfINT(N,A,B,X,Y,Z)
+#define SHORTV_cfINT(N,A,B,X,Y,Z) DOUBLEV_cfINT(N,A,B,X,Y,Z)
+#define SHORTVV_cfINT(N,A,B,X,Y,Z) DOUBLEVV_cfINT(N,A,B,X,Y,Z)
+#define SHORTVVV_cfINT(N,A,B,X,Y,Z) DOUBLEVVV_cfINT(N,A,B,X,Y,Z)
+#define SHORTVVVV_cfINT(N,A,B,X,Y,Z) DOUBLEVVVV_cfINT(N,A,B,X,Y,Z)
+#define SHORTVVVVV_cfINT(N,A,B,X,Y,Z) DOUBLEVVVVV_cfINT(N,A,B,X,Y,Z)
+#define SHORTVVVVVV_cfINT(N,A,B,X,Y,Z) DOUBLEVVVVVV_cfINT(N,A,B,X,Y,Z)
+#define SHORTVVVVVVV_cfINT(N,A,B,X,Y,Z) DOUBLEVVVVVVV_cfINT(N,A,B,X,Y,Z)
+#define PVOID_cfINT(N,A,B,X,Y,Z) _(CFARGS,N)(A,B,B,X,Y,Z,0)
+#define ROUTINE_cfINT(N,A,B,X,Y,Z) PVOID_cfINT(N,A,B,X,Y,Z)
+/*CRAY coughs on the first,
+ i.e. the usual trouble of not being able to
+ define macros to macros with arguments.
+ New ultrix is worse, it coughs on all such uses.
+ */
+/*#define SIMPLE_cfINT PVOID_cfINT*/
+#define SIMPLE_cfINT(N,A,B,X,Y,Z) PVOID_cfINT(N,A,B,X,Y,Z)
+#define VOID_cfINT(N,A,B,X,Y,Z) PVOID_cfINT(N,A,B,X,Y,Z)
+#define STRING_cfINT(N,A,B,X,Y,Z) PVOID_cfINT(N,A,B,X,Y,Z)
+#define STRINGV_cfINT(N,A,B,X,Y,Z) PVOID_cfINT(N,A,B,X,Y,Z)
+#define PSTRING_cfINT(N,A,B,X,Y,Z) PVOID_cfINT(N,A,B,X,Y,Z)
+#define PSTRINGV_cfINT(N,A,B,X,Y,Z) PVOID_cfINT(N,A,B,X,Y,Z)
+#define PNSTRING_cfINT(N,A,B,X,Y,Z) PVOID_cfINT(N,A,B,X,Y,Z)
+#define PPSTRING_cfINT(N,A,B,X,Y,Z) PVOID_cfINT(N,A,B,X,Y,Z)
+#define ZTRINGV_cfINT(N,A,B,X,Y,Z) PVOID_cfINT(N,A,B,X,Y,Z)
+#define PZTRINGV_cfINT(N,A,B,X,Y,Z) PVOID_cfINT(N,A,B,X,Y,Z)
+#define CF_0_cfINT(N,A,B,X,Y,Z)
+
+
+#define UCF(TN,I,C) _SEP_(TN,C,cfCOMMA) _Icf(2,U,TN,_(A,I),0)
+#define UUCF(TN,I,C) _SEP_(TN,C,cfCOMMA) _SEP_(TN,1,I)
+#define UUUCF(TN,I,C) _SEP_(TN,C,cfCOLON) _Icf(2,U,TN,_(A,I),0)
+#define INT_cfU(T,A) _(T,VVVVVVV_cfTYPE) A
+#define INTV_cfU(T,A) _(T,VVVVVV_cfTYPE) * A
+#define INTVV_cfU(T,A) _(T,VVVVV_cfTYPE) * A
+#define INTVVV_cfU(T,A) _(T,VVVV_cfTYPE) * A
+#define INTVVVV_cfU(T,A) _(T,VVV_cfTYPE) * A
+#define INTVVVVV_cfU(T,A) _(T,VV_cfTYPE) * A
+#define INTVVVVVV_cfU(T,A) _(T,V_cfTYPE) * A
+#define INTVVVVVVV_cfU(T,A) _(T,_cfTYPE) * A
+#define PINT_cfU(T,A) _(T,_cfTYPE) * A
+#define PVOID_cfU(T,A) void *A
+#define ROUTINE_cfU(T,A) void (*A)(CF_NULL_PROTO)
+#define VOID_cfU(T,A) void A /* Needed for C calls FORTRAN sub.s. */
+#define STRING_cfU(T,A) char *A /* via VOID and wrapper. */
+#define STRINGV_cfU(T,A) char *A
+#define PSTRING_cfU(T,A) char *A
+#define PSTRINGV_cfU(T,A) char *A
+#define ZTRINGV_cfU(T,A) char *A
+#define PZTRINGV_cfU(T,A) char *A
+
+/* VOID breaks U into U and UU. */
+#define INT_cfUU(T,A) _(T,VVVVVVV_cfTYPE) A
+#define VOID_cfUU(T,A) /* Needed for FORTRAN calls C sub.s. */
+#define STRING_cfUU(T,A) char *A
+
+
+#define BYTE_cfPU(A) CFextern INTEGER_BYTE FCALLSC_QUALIFIER A
+#define DOUBLE_cfPU(A) CFextern DOUBLE_PRECISION FCALLSC_QUALIFIER A
+#if ! (defined(FLOATFUNCTIONTYPE)&&defined(ASSIGNFLOAT)&&defined(RETURNFLOAT))
+#define FLOAT_cfPU(A) CFextern FORTRAN_REAL FCALLSC_QUALIFIER A
+#else
+#define FLOAT_cfPU(A) CFextern FLOATFUNCTIONTYPE FCALLSC_QUALIFIER A
+#endif
+#define INT_cfPU(A) CFextern int FCALLSC_QUALIFIER A
+#define LOGICAL_cfPU(A) CFextern int FCALLSC_QUALIFIER A
+#define LONG_cfPU(A) CFextern long FCALLSC_QUALIFIER A
+#define SHORT_cfPU(A) CFextern short FCALLSC_QUALIFIER A
+#define STRING_cfPU(A) CFextern void FCALLSC_QUALIFIER A
+#define VOID_cfPU(A) CFextern void FCALLSC_QUALIFIER A
+
+#define BYTE_cfE INTEGER_BYTE A0;
+#define DOUBLE_cfE DOUBLE_PRECISION A0;
+#if ! (defined(FLOATFUNCTIONTYPE)&&defined(ASSIGNFLOAT)&&defined(RETURNFLOAT))
+#define FLOAT_cfE FORTRAN_REAL A0;
+#else
+#define FLOAT_cfE FORTRAN_REAL AA0; FLOATFUNCTIONTYPE A0;
+#endif
+#define INT_cfE int A0;
+#define LOGICAL_cfE int A0;
+#define LONG_cfE long A0;
+#define SHORT_cfE short A0;
+#define VOID_cfE
+#ifdef vmsFortran
+#define STRING_cfE static char AA0[1+MAX_LEN_FORTRAN_FUNCTION_STRING]; \
+ static fstring A0 = \
+ {MAX_LEN_FORTRAN_FUNCTION_STRING,DSC$K_DTYPE_T,DSC$K_CLASS_S,AA0};\
+ memset(AA0, CFORTRAN_NON_CHAR, MAX_LEN_FORTRAN_FUNCTION_STRING);\
+ *(AA0+MAX_LEN_FORTRAN_FUNCTION_STRING)='\0';
+#else
+#ifdef CRAYFortran
+#define STRING_cfE static char AA0[1+MAX_LEN_FORTRAN_FUNCTION_STRING]; \
+ static _fcd A0; *(AA0+MAX_LEN_FORTRAN_FUNCTION_STRING)='\0';\
+ memset(AA0,CFORTRAN_NON_CHAR, MAX_LEN_FORTRAN_FUNCTION_STRING);\
+ A0 = _cptofcd(AA0,MAX_LEN_FORTRAN_FUNCTION_STRING);
+#else
+/* 'cc: SC3.0.1 13 Jul 1994' barfs on char A0[0x4FE+1];
+ * char A0[0x4FE +1]; char A0[1+0x4FE]; are both OK. */
+#define STRING_cfE static char A0[1+MAX_LEN_FORTRAN_FUNCTION_STRING]; \
+ memset(A0, CFORTRAN_NON_CHAR, \
+ MAX_LEN_FORTRAN_FUNCTION_STRING); \
+ *(A0+MAX_LEN_FORTRAN_FUNCTION_STRING)='\0';
+#endif
+#endif
+/* ESTRING must use static char. array which is guaranteed to exist after
+ function returns. */
+
+/* N.B.i) The diff. for 0 (Zero) and >=1 arguments.
+ ii)That the following create an unmatched bracket, i.e. '(', which
+ must of course be matched in the call.
+ iii)Commas must be handled very carefully */
+#define INT_cfGZ(T,UN,LN) A0=CFC_(UN,LN)(
+#define VOID_cfGZ(T,UN,LN) CFC_(UN,LN)(
+#ifdef vmsFortran
+#define STRING_cfGZ(T,UN,LN) CFC_(UN,LN)(&A0
+#else
+#if defined(CRAYFortran) || defined(AbsoftUNIXFortran) || defined(AbsoftProFortran)
+#define STRING_cfGZ(T,UN,LN) CFC_(UN,LN)( A0
+#else
+#define STRING_cfGZ(T,UN,LN) CFC_(UN,LN)( A0,MAX_LEN_FORTRAN_FUNCTION_STRING
+#endif
+#endif
+
+#define INT_cfG(T,UN,LN) INT_cfGZ(T,UN,LN)
+#define VOID_cfG(T,UN,LN) VOID_cfGZ(T,UN,LN)
+#define STRING_cfG(T,UN,LN) STRING_cfGZ(T,UN,LN), /*, is only diff. from _cfG*/
+
+#define BYTEVVVVVVV_cfPP
+#define INTVVVVVVV_cfPP /* These complement FLOATVVVVVVV_cfPP. */
+#define DOUBLEVVVVVVV_cfPP
+#define LOGICALVVVVVVV_cfPP
+#define LONGVVVVVVV_cfPP
+#define SHORTVVVVVVV_cfPP
+#define PBYTE_cfPP
+#define PINT_cfPP
+#define PDOUBLE_cfPP
+#define PLOGICAL_cfPP
+#define PLONG_cfPP
+#define PSHORT_cfPP
+#define PFLOAT_cfPP FLOATVVVVVVV_cfPP
+
+#define BCF(TN,AN,C) _SEP_(TN,C,cfCOMMA) _Icf(2,B,TN,AN,0)
+#define INT_cfB(T,A) (_(T,VVVVVVV_cfTYPE)) A
+#define INTV_cfB(T,A) A
+#define INTVV_cfB(T,A) (A)[0]
+#define INTVVV_cfB(T,A) (A)[0][0]
+#define INTVVVV_cfB(T,A) (A)[0][0][0]
+#define INTVVVVV_cfB(T,A) (A)[0][0][0][0]
+#define INTVVVVVV_cfB(T,A) (A)[0][0][0][0][0]
+#define INTVVVVVVV_cfB(T,A) (A)[0][0][0][0][0][0]
+#define PINT_cfB(T,A) _(T,_cfPP)&A
+#define STRING_cfB(T,A) (char *) A
+#define STRINGV_cfB(T,A) (char *) A
+#define PSTRING_cfB(T,A) (char *) A
+#define PSTRINGV_cfB(T,A) (char *) A
+#define PVOID_cfB(T,A) (void *) A
+#define ROUTINE_cfB(T,A) (cfCAST_FUNCTION)A
+#define ZTRINGV_cfB(T,A) (char *) A
+#define PZTRINGV_cfB(T,A) (char *) A
+
+#define SCF(TN,NAME,I,A) _(TN,_cfSTR)(3,S,NAME,I,A,0,0)
+#define DEFAULT_cfS(M,I,A)
+#define LOGICAL_cfS(M,I,A)
+#define PLOGICAL_cfS(M,I,A)
+#define STRING_cfS(M,I,A) ,sizeof(A)
+#define STRINGV_cfS(M,I,A) ,( (unsigned)0xFFFF*firstindexlength(A) \
+ +secondindexlength(A))
+#define PSTRING_cfS(M,I,A) ,sizeof(A)
+#define PSTRINGV_cfS(M,I,A) STRINGV_cfS(M,I,A)
+#define ZTRINGV_cfS(M,I,A)
+#define PZTRINGV_cfS(M,I,A)
+
+#define HCF(TN,I) _(TN,_cfSTR)(3,H,cfCOMMA, H,_(C,I),0,0)
+#define HHCF(TN,I) _(TN,_cfSTR)(3,H,cfCOMMA,HH,_(C,I),0,0)
+#define HHHCF(TN,I) _(TN,_cfSTR)(3,H,cfCOLON, H,_(C,I),0,0)
+#define H_CF_SPECIAL unsigned
+#define HH_CF_SPECIAL
+#define DEFAULT_cfH(M,I,A)
+#define LOGICAL_cfH(S,U,B)
+#define PLOGICAL_cfH(S,U,B)
+#define STRING_cfH(S,U,B) _(A,S) _(U,_CF_SPECIAL) B
+#define STRINGV_cfH(S,U,B) STRING_cfH(S,U,B)
+#define PSTRING_cfH(S,U,B) STRING_cfH(S,U,B)
+#define PSTRINGV_cfH(S,U,B) STRING_cfH(S,U,B)
+#define PNSTRING_cfH(S,U,B) STRING_cfH(S,U,B)
+#define PPSTRING_cfH(S,U,B) STRING_cfH(S,U,B)
+#define ZTRINGV_cfH(S,U,B)
+#define PZTRINGV_cfH(S,U,B)
+
+/* Need VOID_cfSTR because Absoft forced function types go through _cfSTR. */
+/* No spaces inside expansion. They screws up macro catenation kludge. */
+#define VOID_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E)
+#define BYTE_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E)
+#define DOUBLE_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E)
+#define FLOAT_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E)
+#define INT_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E)
+#define LOGICAL_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,LOGICAL,A,B,C,D,E)
+#define LONG_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E)
+#define SHORT_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E)
+#define BYTEV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E)
+#define BYTEVV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E)
+#define BYTEVVV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E)
+#define BYTEVVVV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E)
+#define BYTEVVVVV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E)
+#define BYTEVVVVVV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E)
+#define BYTEVVVVVVV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E)
+#define DOUBLEV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E)
+#define DOUBLEVV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E)
+#define DOUBLEVVV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E)
+#define DOUBLEVVVV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E)
+#define DOUBLEVVVVV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E)
+#define DOUBLEVVVVVV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E)
+#define DOUBLEVVVVVVV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E)
+#define FLOATV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E)
+#define FLOATVV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E)
+#define FLOATVVV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E)
+#define FLOATVVVV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E)
+#define FLOATVVVVV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E)
+#define FLOATVVVVVV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E)
+#define FLOATVVVVVVV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E)
+#define INTV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E)
+#define INTVV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E)
+#define INTVVV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E)
+#define INTVVVV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E)
+#define INTVVVVV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E)
+#define INTVVVVVV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E)
+#define INTVVVVVVV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E)
+#define LOGICALV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E)
+#define LOGICALVV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E)
+#define LOGICALVVV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E)
+#define LOGICALVVVV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E)
+#define LOGICALVVVVV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E)
+#define LOGICALVVVVVV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E)
+#define LOGICALVVVVVVV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E)
+#define LONGV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E)
+#define LONGVV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E)
+#define LONGVVV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E)
+#define LONGVVVV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E)
+#define LONGVVVVV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E)
+#define LONGVVVVVV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E)
+#define LONGVVVVVVV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E)
+#define SHORTV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E)
+#define SHORTVV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E)
+#define SHORTVVV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E)
+#define SHORTVVVV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E)
+#define SHORTVVVVV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E)
+#define SHORTVVVVVV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E)
+#define SHORTVVVVVVV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E)
+#define PBYTE_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E)
+#define PDOUBLE_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E)
+#define PFLOAT_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E)
+#define PINT_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E)
+#define PLOGICAL_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,PLOGICAL,A,B,C,D,E)
+#define PLONG_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E)
+#define PSHORT_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E)
+#define STRING_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,STRING,A,B,C,D,E)
+#define PSTRING_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,PSTRING,A,B,C,D,E)
+#define STRINGV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,STRINGV,A,B,C,D,E)
+#define PSTRINGV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,PSTRINGV,A,B,C,D,E)
+#define PNSTRING_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,PNSTRING,A,B,C,D,E)
+#define PPSTRING_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,PPSTRING,A,B,C,D,E)
+#define PVOID_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E)
+#define ROUTINE_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E)
+#define SIMPLE_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E)
+#define ZTRINGV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,ZTRINGV,A,B,C,D,E)
+#define PZTRINGV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,PZTRINGV,A,B,C,D,E)
+#define CF_0_cfSTR(N,T,A,B,C,D,E)
+
+/* See ACF table comments, which explain why CCF was split into two. */
+#define CCF(NAME,TN,I) _(TN,_cfSTR)(5,C,NAME,I,_(A,I),_(B,I),_(C,I))
+#define DEFAULT_cfC(M,I,A,B,C)
+#define LOGICAL_cfC(M,I,A,B,C) A=C2FLOGICAL( A);
+#define PLOGICAL_cfC(M,I,A,B,C) *A=C2FLOGICAL(*A);
+#ifdef vmsFortran
+#define STRING_cfC(M,I,A,B,C) (B.clen=strlen(A),B.f.dsc$a_pointer=A, \
+ C==sizeof(char*)||C==(unsigned)(B.clen+1)?B.f.dsc$w_length=B.clen: \
+ (memset((A)+B.clen,' ',C-B.clen-1),A[B.f.dsc$w_length=C-1]='\0'));
+ /* PSTRING_cfC to beware of array A which does not contain any \0. */
+#define PSTRING_cfC(M,I,A,B,C) (B.dsc$a_pointer=A, C==sizeof(char*) ? \
+ B.dsc$w_length=strlen(A): (A[C-1]='\0',B.dsc$w_length=strlen(A), \
+ memset((A)+B.dsc$w_length,' ',C-B.dsc$w_length-1), B.dsc$w_length=C-1));
+#else
+#define STRING_cfC(M,I,A,B,C) (B.clen=strlen(A), \
+ C==sizeof(char*)||C==(unsigned)(B.clen+1)?B.flen=B.clen: \
+ (memset((A)+B.clen,' ',C-B.clen-1),A[B.flen=C-1]='\0'));
+#define PSTRING_cfC(M,I,A,B,C) (C==sizeof(char*)? B=strlen(A): \
+ (A[C-1]='\0',B=strlen(A),memset((A)+B,' ',C-B-1),B=C-1));
+#endif
+ /* For CRAYFortran for (P)STRINGV_cfC, B.fs is set, but irrelevant. */
+#define STRINGV_cfC(M,I,A,B,C) \
+ AATRINGV_cfA( A,B,(C/0xFFFF)*(C%0xFFFF),C/0xFFFF,C%0xFFFF)
+#define PSTRINGV_cfC(M,I,A,B,C) \
+ APATRINGV_cfA( A,B,(C/0xFFFF)*(C%0xFFFF),C/0xFFFF,C%0xFFFF)
+#define ZTRINGV_cfC(M,I,A,B,C) \
+ AATRINGV_cfA( A,B, (_3(M,_ELEMS_,I))*((_3(M,_ELEMLEN_,I))+1), \
+ (_3(M,_ELEMS_,I)), (_3(M,_ELEMLEN_,I))+1 )
+#define PZTRINGV_cfC(M,I,A,B,C) \
+ APATRINGV_cfA( A,B, (_3(M,_ELEMS_,I))*((_3(M,_ELEMLEN_,I))+1), \
+ (_3(M,_ELEMS_,I)), (_3(M,_ELEMLEN_,I))+1 )
+
+#define BYTE_cfCCC(A,B) &A
+#define DOUBLE_cfCCC(A,B) &A
+#if !defined(__CF__KnR)
+#define FLOAT_cfCCC(A,B) &A
+ /* Although the VAX doesn't, at least the */
+#else /* HP and K&R mips promote float arg.'s of */
+#define FLOAT_cfCCC(A,B) &B /* unprototyped functions to double. Cannot */
+#endif /* use A here to pass the argument to FORTRAN. */
+#define INT_cfCCC(A,B) &A
+#define LOGICAL_cfCCC(A,B) &A
+#define LONG_cfCCC(A,B) &A
+#define SHORT_cfCCC(A,B) &A
+#define PBYTE_cfCCC(A,B) A
+#define PDOUBLE_cfCCC(A,B) A
+#define PFLOAT_cfCCC(A,B) A
+#define PINT_cfCCC(A,B) A
+#define PLOGICAL_cfCCC(A,B) B=A /* B used to keep a common W table. */
+#define PLONG_cfCCC(A,B) A
+#define PSHORT_cfCCC(A,B) A
+
+#define CCCF(TN,I,M) _SEP_(TN,M,cfCOMMA) _Icf(3,CC,TN,_(A,I),_(B,I))
+#define INT_cfCC(T,A,B) _(T,_cfCCC)(A,B)
+#define INTV_cfCC(T,A,B) A
+#define INTVV_cfCC(T,A,B) A
+#define INTVVV_cfCC(T,A,B) A
+#define INTVVVV_cfCC(T,A,B) A
+#define INTVVVVV_cfCC(T,A,B) A
+#define INTVVVVVV_cfCC(T,A,B) A
+#define INTVVVVVVV_cfCC(T,A,B) A
+#define PINT_cfCC(T,A,B) _(T,_cfCCC)(A,B)
+#define PVOID_cfCC(T,A,B) A
+#if defined(apolloFortran) || defined(hpuxFortran800) || defined(AbsoftUNIXFortran)
+#define ROUTINE_cfCC(T,A,B) &A
+#else
+#define ROUTINE_cfCC(T,A,B) A
+#endif
+#define SIMPLE_cfCC(T,A,B) A
+#ifdef vmsFortran
+#define STRING_cfCC(T,A,B) &B.f
+#define STRINGV_cfCC(T,A,B) &B
+#define PSTRING_cfCC(T,A,B) &B
+#define PSTRINGV_cfCC(T,A,B) &B
+#else
+#ifdef CRAYFortran
+#define STRING_cfCC(T,A,B) _cptofcd(A,B.flen)
+#define STRINGV_cfCC(T,A,B) _cptofcd(B.s,B.flen)
+#define PSTRING_cfCC(T,A,B) _cptofcd(A,B)
+#define PSTRINGV_cfCC(T,A,B) _cptofcd(A,B.flen)
+#else
+#define STRING_cfCC(T,A,B) A
+#define STRINGV_cfCC(T,A,B) B.fs
+#define PSTRING_cfCC(T,A,B) A
+#define PSTRINGV_cfCC(T,A,B) B.fs
+#endif
+#endif
+#define ZTRINGV_cfCC(T,A,B) STRINGV_cfCC(T,A,B)
+#define PZTRINGV_cfCC(T,A,B) PSTRINGV_cfCC(T,A,B)
+
+#define BYTE_cfX return A0;
+#define DOUBLE_cfX return A0;
+#if ! (defined(FLOATFUNCTIONTYPE)&&defined(ASSIGNFLOAT)&&defined(RETURNFLOAT))
+#define FLOAT_cfX return A0;
+#else
+#define FLOAT_cfX ASSIGNFLOAT(AA0,A0); return AA0;
+#endif
+#define INT_cfX return A0;
+#define LOGICAL_cfX return F2CLOGICAL(A0);
+#define LONG_cfX return A0;
+#define SHORT_cfX return A0;
+#define VOID_cfX return ;
+#if defined(vmsFortran) || defined(CRAYFortran)
+#define STRING_cfX return kill_trailing( \
+ kill_trailing(AA0,CFORTRAN_NON_CHAR),' ');
+#else
+#define STRING_cfX return kill_trailing( \
+ kill_trailing( A0,CFORTRAN_NON_CHAR),' ');
+#endif
+
+#define CFFUN(NAME) _(__cf__,NAME)
+
+/* Note that we don't use LN here, but we keep it for consistency. */
+#define CCALLSFFUN0(UN,LN) CFFUN(UN)()
+
+#ifdef OLD_VAXC /* Allow %CC-I-PARAMNOTUSED. */
+#pragma standard
+#endif
+
+#define CCALLSFFUN1( UN,LN,T1, A1) \
+ CCALLSFFUN5 (UN,LN,T1,CF_0,CF_0,CF_0,CF_0,A1,0,0,0,0)
+#define CCALLSFFUN2( UN,LN,T1,T2, A1,A2) \
+ CCALLSFFUN5 (UN,LN,T1,T2,CF_0,CF_0,CF_0,A1,A2,0,0,0)
+#define CCALLSFFUN3( UN,LN,T1,T2,T3, A1,A2,A3) \
+ CCALLSFFUN5 (UN,LN,T1,T2,T3,CF_0,CF_0,A1,A2,A3,0,0)
+#define CCALLSFFUN4( UN,LN,T1,T2,T3,T4, A1,A2,A3,A4)\
+ CCALLSFFUN5 (UN,LN,T1,T2,T3,T4,CF_0,A1,A2,A3,A4,0)
+#define CCALLSFFUN5( UN,LN,T1,T2,T3,T4,T5, A1,A2,A3,A4,A5) \
+ CCALLSFFUN10(UN,LN,T1,T2,T3,T4,T5,CF_0,CF_0,CF_0,CF_0,CF_0,A1,A2,A3,A4,A5,0,0,0,0,0)
+#define CCALLSFFUN6( UN,LN,T1,T2,T3,T4,T5,T6, A1,A2,A3,A4,A5,A6) \
+ CCALLSFFUN10(UN,LN,T1,T2,T3,T4,T5,T6,CF_0,CF_0,CF_0,CF_0,A1,A2,A3,A4,A5,A6,0,0,0,0)
+#define CCALLSFFUN7( UN,LN,T1,T2,T3,T4,T5,T6,T7, A1,A2,A3,A4,A5,A6,A7) \
+ CCALLSFFUN10(UN,LN,T1,T2,T3,T4,T5,T6,T7,CF_0,CF_0,CF_0,A1,A2,A3,A4,A5,A6,A7,0,0,0)
+#define CCALLSFFUN8( UN,LN,T1,T2,T3,T4,T5,T6,T7,T8, A1,A2,A3,A4,A5,A6,A7,A8) \
+ CCALLSFFUN10(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,CF_0,CF_0,A1,A2,A3,A4,A5,A6,A7,A8,0,0)
+#define CCALLSFFUN9( UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,A1,A2,A3,A4,A5,A6,A7,A8,A9)\
+ CCALLSFFUN10(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,CF_0,A1,A2,A3,A4,A5,A6,A7,A8,A9,0)
+#define CCALLSFFUN10(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA)\
+ CCALLSFFUN14(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,CF_0,CF_0,CF_0,CF_0,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,0,0,0,0)
+#define CCALLSFFUN11(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB)\
+ CCALLSFFUN14(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,CF_0,CF_0,CF_0,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,0,0,0)
+#define CCALLSFFUN12(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC)\
+ CCALLSFFUN14(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,CF_0,CF_0,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,0,0)
+#define CCALLSFFUN13(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,AD)\
+ CCALLSFFUN14(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,CF_0,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,AD,0)
+
+#define CCALLSFFUN14(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,AD,AE)\
+((CFFUN(UN)( BCF(T1,A1,0) BCF(T2,A2,1) BCF(T3,A3,1) BCF(T4,A4,1) BCF(T5,A5,1) \
+ BCF(T6,A6,1) BCF(T7,A7,1) BCF(T8,A8,1) BCF(T9,A9,1) BCF(TA,AA,1) \
+ BCF(TB,AB,1) BCF(TC,AC,1) BCF(TD,AD,1) BCF(TE,AE,1) \
+ SCF(T1,LN,1,A1) SCF(T2,LN,2,A2) SCF(T3,LN,3,A3) SCF(T4,LN,4,A4) \
+ SCF(T5,LN,5,A5) SCF(T6,LN,6,A6) SCF(T7,LN,7,A7) SCF(T8,LN,8,A8) \
+ SCF(T9,LN,9,A9) SCF(TA,LN,10,AA) SCF(TB,LN,11,AB) SCF(TC,LN,12,AC) \
+ SCF(TD,LN,13,AD) SCF(TE,LN,14,AE))))
+
+/* N.B. Create a separate function instead of using (call function, function
+value here) because in order to create the variables needed for the input
+arg.'s which may be const.'s one has to do the creation within {}, but these
+can never be placed within ()'s. Therefore one must create wrapper functions.
+gcc, on the other hand may be able to avoid the wrapper functions. */
+
+/* Prototypes are needed to correctly handle the value returned correctly. N.B.
+Can only have prototype arg.'s with difficulty, a la G... table since FORTRAN
+functions returning strings have extra arg.'s. Don't bother, since this only
+causes a compiler warning to come up when one uses FCALLSCFUNn and CCALLSFFUNn
+for the same function in the same source code. Something done by the experts in
+debugging only.*/
+
+#define PROTOCCALLSFFUN0(F,UN,LN) \
+_(F,_cfPU)( CFC_(UN,LN))(CF_NULL_PROTO); \
+static _Icf(2,U,F,CFFUN(UN),0)() {_(F,_cfE) _Icf(3,GZ,F,UN,LN) ABSOFT_cf1(F));_(F,_cfX)}
+
+#define PROTOCCALLSFFUN1( T0,UN,LN,T1) \
+ PROTOCCALLSFFUN5 (T0,UN,LN,T1,CF_0,CF_0,CF_0,CF_0)
+#define PROTOCCALLSFFUN2( T0,UN,LN,T1,T2) \
+ PROTOCCALLSFFUN5 (T0,UN,LN,T1,T2,CF_0,CF_0,CF_0)
+#define PROTOCCALLSFFUN3( T0,UN,LN,T1,T2,T3) \
+ PROTOCCALLSFFUN5 (T0,UN,LN,T1,T2,T3,CF_0,CF_0)
+#define PROTOCCALLSFFUN4( T0,UN,LN,T1,T2,T3,T4) \
+ PROTOCCALLSFFUN5 (T0,UN,LN,T1,T2,T3,T4,CF_0)
+#define PROTOCCALLSFFUN5( T0,UN,LN,T1,T2,T3,T4,T5) \
+ PROTOCCALLSFFUN10(T0,UN,LN,T1,T2,T3,T4,T5,CF_0,CF_0,CF_0,CF_0,CF_0)
+#define PROTOCCALLSFFUN6( T0,UN,LN,T1,T2,T3,T4,T5,T6) \
+ PROTOCCALLSFFUN10(T0,UN,LN,T1,T2,T3,T4,T5,T6,CF_0,CF_0,CF_0,CF_0)
+#define PROTOCCALLSFFUN7( T0,UN,LN,T1,T2,T3,T4,T5,T6,T7) \
+ PROTOCCALLSFFUN10(T0,UN,LN,T1,T2,T3,T4,T5,T6,T7,CF_0,CF_0,CF_0)
+#define PROTOCCALLSFFUN8( T0,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8) \
+ PROTOCCALLSFFUN10(T0,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,CF_0,CF_0)
+#define PROTOCCALLSFFUN9( T0,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9) \
+ PROTOCCALLSFFUN10(T0,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,CF_0)
+#define PROTOCCALLSFFUN10(T0,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA) \
+ PROTOCCALLSFFUN14(T0,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,CF_0,CF_0,CF_0,CF_0)
+#define PROTOCCALLSFFUN11(T0,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB) \
+ PROTOCCALLSFFUN14(T0,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,CF_0,CF_0,CF_0)
+#define PROTOCCALLSFFUN12(T0,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC) \
+ PROTOCCALLSFFUN14(T0,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,CF_0,CF_0)
+#define PROTOCCALLSFFUN13(T0,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD) \
+ PROTOCCALLSFFUN14(T0,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,CF_0)
+
+/* HP/UX 9.01 cc requires the blank between '_Icf(3,G,T0,UN,LN) CCCF(T1,1,0)' */
+
+#ifndef __CF__KnR
+#define PROTOCCALLSFFUN14(T0,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE) \
+ _(T0,_cfPU)(CFC_(UN,LN))(CF_NULL_PROTO); static _Icf(2,U,T0,CFFUN(UN),0)( \
+ CFARGT14FS(UCF,HCF,_Z,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE) ) \
+{ CFARGT14S(VCF,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE) _(T0,_cfE) \
+ CCF(LN,T1,1) CCF(LN,T2,2) CCF(LN,T3,3) CCF(LN,T4,4) CCF(LN,T5,5) \
+ CCF(LN,T6,6) CCF(LN,T7,7) CCF(LN,T8,8) CCF(LN,T9,9) CCF(LN,TA,10) \
+ CCF(LN,TB,11) CCF(LN,TC,12) CCF(LN,TD,13) CCF(LN,TE,14) _Icf(3,G,T0,UN,LN) \
+ CFARGT14(CCCF,JCF,ABSOFT_cf1(T0),T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE)); \
+ WCF(T1,A1,1) WCF(T2,A2,2) WCF(T3,A3,3) WCF(T4,A4,4) WCF(T5,A5,5) \
+ WCF(T6,A6,6) WCF(T7,A7,7) WCF(T8,A8,8) WCF(T9,A9,9) WCF(TA,A10,10) \
+ WCF(TB,A11,11) WCF(TC,A12,12) WCF(TD,A13,13) WCF(TE,A14,14) _(T0,_cfX)}
+#else
+#define PROTOCCALLSFFUN14(T0,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE) \
+ _(T0,_cfPU)(CFC_(UN,LN))(CF_NULL_PROTO); static _Icf(2,U,T0,CFFUN(UN),0)( \
+ CFARGT14FS(UUCF,HHCF,_Z,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE) ) \
+ CFARGT14FS(UUUCF,HHHCF,_Z,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE) ; \
+{ CFARGT14S(VCF,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE) _(T0,_cfE) \
+ CCF(LN,T1,1) CCF(LN,T2,2) CCF(LN,T3,3) CCF(LN,T4,4) CCF(LN,T5,5) \
+ CCF(LN,T6,6) CCF(LN,T7,7) CCF(LN,T8,8) CCF(LN,T9,9) CCF(LN,TA,10) \
+ CCF(LN,TB,11) CCF(LN,TC,12) CCF(LN,TD,13) CCF(LN,TE,14) _Icf(3,G,T0,UN,LN) \
+ CFARGT14(CCCF,JCF,ABSOFT_cf1(T0),T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE)); \
+ WCF(T1,A1,1) WCF(T2,A2,2) WCF(T3,A3,3) WCF(T4,A4,4) WCF(T5,A5,5) \
+ WCF(T6,A6,6) WCF(T7,A7,7) WCF(T8,A8,8) WCF(T9,A9,9) WCF(TA,A10,10) \
+ WCF(TB,A11,11) WCF(TC,A12,12) WCF(TD,A13,13) WCF(TE,A14,14) _(T0,_cfX)}
+#endif
+
+/*-------------------------------------------------------------------------*/
+
+/* UTILITIES FOR FORTRAN TO CALL C ROUTINES */
+
+#ifdef OLD_VAXC /* Prevent %CC-I-PARAMNOTUSED. */
+#pragma nostandard
+#endif
+
+#if defined(vmsFortran) || defined(CRAYFortran)
+#define DCF(TN,I)
+#define DDCF(TN,I)
+#define DDDCF(TN,I)
+#else
+#define DCF(TN,I) HCF(TN,I)
+#define DDCF(TN,I) HHCF(TN,I)
+#define DDDCF(TN,I) HHHCF(TN,I)
+#endif
+
+#define QCF(TN,I) _(TN,_cfSTR)(1,Q,_(B,I), 0,0,0,0)
+#define DEFAULT_cfQ(B)
+#define LOGICAL_cfQ(B)
+#define PLOGICAL_cfQ(B)
+#define STRINGV_cfQ(B) char *B; unsigned int _(B,N);
+#define STRING_cfQ(B) char *B=NULL;
+#define PSTRING_cfQ(B) char *B=NULL;
+#define PSTRINGV_cfQ(B) STRINGV_cfQ(B)
+#define PNSTRING_cfQ(B) char *B=NULL;
+#define PPSTRING_cfQ(B)
+
+#ifdef __sgi /* Else SGI gives warning 182 contrary to its C LRM A.17.7 */
+#define ROUTINE_orig *(void**)&
+#else
+#define ROUTINE_orig (void *)
+#endif
+
+#define ROUTINE_1 ROUTINE_orig
+#define ROUTINE_2 ROUTINE_orig
+#define ROUTINE_3 ROUTINE_orig
+#define ROUTINE_4 ROUTINE_orig
+#define ROUTINE_5 ROUTINE_orig
+#define ROUTINE_6 ROUTINE_orig
+#define ROUTINE_7 ROUTINE_orig
+#define ROUTINE_8 ROUTINE_orig
+#define ROUTINE_9 ROUTINE_orig
+#define ROUTINE_10 ROUTINE_orig
+#define ROUTINE_11 ROUTINE_orig
+#define ROUTINE_12 ROUTINE_orig
+#define ROUTINE_13 ROUTINE_orig
+#define ROUTINE_14 ROUTINE_orig
+#define ROUTINE_15 ROUTINE_orig
+#define ROUTINE_16 ROUTINE_orig
+#define ROUTINE_17 ROUTINE_orig
+#define ROUTINE_18 ROUTINE_orig
+#define ROUTINE_19 ROUTINE_orig
+#define ROUTINE_20 ROUTINE_orig
+#define ROUTINE_21 ROUTINE_orig
+#define ROUTINE_22 ROUTINE_orig
+#define ROUTINE_23 ROUTINE_orig
+#define ROUTINE_24 ROUTINE_orig
+#define ROUTINE_25 ROUTINE_orig
+#define ROUTINE_26 ROUTINE_orig
+#define ROUTINE_27 ROUTINE_orig
+
+#define TCF(NAME,TN,I,M) _SEP_(TN,M,cfCOMMA) _(TN,_cfT)(NAME,I,_(A,I),_(B,I),_(C,I))
+#define BYTE_cfT(M,I,A,B,D) *A
+#define DOUBLE_cfT(M,I,A,B,D) *A
+#define FLOAT_cfT(M,I,A,B,D) *A
+#define INT_cfT(M,I,A,B,D) *A
+#define LOGICAL_cfT(M,I,A,B,D) F2CLOGICAL(*A)
+#define LONG_cfT(M,I,A,B,D) *A
+#define SHORT_cfT(M,I,A,B,D) *A
+#define BYTEV_cfT(M,I,A,B,D) A
+#define DOUBLEV_cfT(M,I,A,B,D) A
+#define FLOATV_cfT(M,I,A,B,D) VOIDP A
+#define INTV_cfT(M,I,A,B,D) A
+#define LOGICALV_cfT(M,I,A,B,D) A
+#define LONGV_cfT(M,I,A,B,D) A
+#define SHORTV_cfT(M,I,A,B,D) A
+#define BYTEVV_cfT(M,I,A,B,D) (void *)A /* We have to cast to void *,*/
+#define BYTEVVV_cfT(M,I,A,B,D) (void *)A /* since we don't know the */
+#define BYTEVVVV_cfT(M,I,A,B,D) (void *)A /* dimensions of the array. */
+#define BYTEVVVVV_cfT(M,I,A,B,D) (void *)A /* i.e. Unfortunately, can't */
+#define BYTEVVVVVV_cfT(M,I,A,B,D) (void *)A /* check that the type */
+#define BYTEVVVVVVV_cfT(M,I,A,B,D) (void *)A /* matches the prototype. */
+#define DOUBLEVV_cfT(M,I,A,B,D) (void *)A
+#define DOUBLEVVV_cfT(M,I,A,B,D) (void *)A
+#define DOUBLEVVVV_cfT(M,I,A,B,D) (void *)A
+#define DOUBLEVVVVV_cfT(M,I,A,B,D) (void *)A
+#define DOUBLEVVVVVV_cfT(M,I,A,B,D) (void *)A
+#define DOUBLEVVVVVVV_cfT(M,I,A,B,D) (void *)A
+#define FLOATVV_cfT(M,I,A,B,D) (void *)A
+#define FLOATVVV_cfT(M,I,A,B,D) (void *)A
+#define FLOATVVVV_cfT(M,I,A,B,D) (void *)A
+#define FLOATVVVVV_cfT(M,I,A,B,D) (void *)A
+#define FLOATVVVVVV_cfT(M,I,A,B,D) (void *)A
+#define FLOATVVVVVVV_cfT(M,I,A,B,D) (void *)A
+#define INTVV_cfT(M,I,A,B,D) (void *)A
+#define INTVVV_cfT(M,I,A,B,D) (void *)A
+#define INTVVVV_cfT(M,I,A,B,D) (void *)A
+#define INTVVVVV_cfT(M,I,A,B,D) (void *)A
+#define INTVVVVVV_cfT(M,I,A,B,D) (void *)A
+#define INTVVVVVVV_cfT(M,I,A,B,D) (void *)A
+#define LOGICALVV_cfT(M,I,A,B,D) (void *)A
+#define LOGICALVVV_cfT(M,I,A,B,D) (void *)A
+#define LOGICALVVVV_cfT(M,I,A,B,D) (void *)A
+#define LOGICALVVVVV_cfT(M,I,A,B,D) (void *)A
+#define LOGICALVVVVVV_cfT(M,I,A,B,D) (void *)A
+#define LOGICALVVVVVVV_cfT(M,I,A,B,D) (void *)A
+#define LONGVV_cfT(M,I,A,B,D) (void *)A
+#define LONGVVV_cfT(M,I,A,B,D) (void *)A
+#define LONGVVVV_cfT(M,I,A,B,D) (void *)A
+#define LONGVVVVV_cfT(M,I,A,B,D) (void *)A
+#define LONGVVVVVV_cfT(M,I,A,B,D) (void *)A
+#define LONGVVVVVVV_cfT(M,I,A,B,D) (void *)A
+#define SHORTVV_cfT(M,I,A,B,D) (void *)A
+#define SHORTVVV_cfT(M,I,A,B,D) (void *)A
+#define SHORTVVVV_cfT(M,I,A,B,D) (void *)A
+#define SHORTVVVVV_cfT(M,I,A,B,D) (void *)A
+#define SHORTVVVVVV_cfT(M,I,A,B,D) (void *)A
+#define SHORTVVVVVVV_cfT(M,I,A,B,D) (void *)A
+#define PBYTE_cfT(M,I,A,B,D) A
+#define PDOUBLE_cfT(M,I,A,B,D) A
+#define PFLOAT_cfT(M,I,A,B,D) VOIDP A
+#define PINT_cfT(M,I,A,B,D) A
+#define PLOGICAL_cfT(M,I,A,B,D) ((*A=F2CLOGICAL(*A)),A)
+#define PLONG_cfT(M,I,A,B,D) A
+#define PSHORT_cfT(M,I,A,B,D) A
+#define PVOID_cfT(M,I,A,B,D) A
+#if defined(apolloFortran) || defined(hpuxFortran800) || defined(AbsoftUNIXFortran)
+#define ROUTINE_cfT(M,I,A,B,D) _(ROUTINE_,I) (*A)
+#else
+#define ROUTINE_cfT(M,I,A,B,D) _(ROUTINE_,I) A
+#endif
+/* A == pointer to the characters
+ D == length of the string, or of an element in an array of strings
+ E == number of elements in an array of strings */
+#define TTSTR( A,B,D) \
+ ((B=_cf_malloc(D+1))[D]='\0', memcpy(B,A,D), kill_trailing(B,' '))
+#define TTTTSTR( A,B,D) (!(D<4||A[0]||A[1]||A[2]||A[3]))?NULL: \
+ memchr(A,'\0',D) ?A : TTSTR(A,B,D)
+#define TTTTSTRV( A,B,D,E) (_(B,N)=E,B=_cf_malloc(_(B,N)*(D+1)), (void *) \
+ vkill_trailing(f2cstrv(A,B,D+1, _(B,N)*(D+1)), D+1,_(B,N)*(D+1),' '))
+#ifdef vmsFortran
+#define STRING_cfT(M,I,A,B,D) TTTTSTR( A->dsc$a_pointer,B,A->dsc$w_length)
+#define STRINGV_cfT(M,I,A,B,D) TTTTSTRV(A->dsc$a_pointer, B, \
+ A->dsc$w_length , A->dsc$l_m[0])
+#define PSTRING_cfT(M,I,A,B,D) TTSTR( A->dsc$a_pointer,B,A->dsc$w_length)
+#define PPSTRING_cfT(M,I,A,B,D) A->dsc$a_pointer
+#else
+#ifdef CRAYFortran
+#define STRING_cfT(M,I,A,B,D) TTTTSTR( _fcdtocp(A),B,_fcdlen(A))
+#define STRINGV_cfT(M,I,A,B,D) TTTTSTRV(_fcdtocp(A),B,_fcdlen(A), \
+ num_elem(_fcdtocp(A),_fcdlen(A),_3(M,_STRV_A,I)))
+#define PSTRING_cfT(M,I,A,B,D) TTSTR( _fcdtocp(A),B,_fcdlen(A))
+#define PPSTRING_cfT(M,I,A,B,D) _fcdtocp(A)
+#else
+#define STRING_cfT(M,I,A,B,D) TTTTSTR( A,B,D)
+#define STRINGV_cfT(M,I,A,B,D) TTTTSTRV(A,B,D, num_elem(A,D,_3(M,_STRV_A,I)))
+#define PSTRING_cfT(M,I,A,B,D) TTSTR( A,B,D)
+#define PPSTRING_cfT(M,I,A,B,D) A
+#endif
+#endif
+#define PNSTRING_cfT(M,I,A,B,D) STRING_cfT(M,I,A,B,D)
+#define PSTRINGV_cfT(M,I,A,B,D) STRINGV_cfT(M,I,A,B,D)
+#define CF_0_cfT(M,I,A,B,D)
+
+#define RCF(TN,I) _(TN,_cfSTR)(3,R,_(A,I),_(B,I),_(C,I),0,0)
+#define DEFAULT_cfR(A,B,D)
+#define LOGICAL_cfR(A,B,D)
+#define PLOGICAL_cfR(A,B,D) *A=C2FLOGICAL(*A);
+#define STRING_cfR(A,B,D) if (B) _cf_free(B);
+#define STRINGV_cfR(A,B,D) _cf_free(B);
+/* A and D as defined above for TSTRING(V) */
+#define RRRRPSTR( A,B,D) if (B) memcpy(A,B, _cfMIN(strlen(B),D)), \
+ (D>strlen(B)?memset(A+strlen(B),' ', D-strlen(B)):0), _cf_free(B);
+#define RRRRPSTRV(A,B,D) c2fstrv(B,A,D+1,(D+1)*_(B,N)), _cf_free(B);
+#ifdef vmsFortran
+#define PSTRING_cfR(A,B,D) RRRRPSTR( A->dsc$a_pointer,B,A->dsc$w_length)
+#define PSTRINGV_cfR(A,B,D) RRRRPSTRV(A->dsc$a_pointer,B,A->dsc$w_length)
+#else
+#ifdef CRAYFortran
+#define PSTRING_cfR(A,B,D) RRRRPSTR( _fcdtocp(A),B,_fcdlen(A))
+#define PSTRINGV_cfR(A,B,D) RRRRPSTRV(_fcdtocp(A),B,_fcdlen(A))
+#else
+#define PSTRING_cfR(A,B,D) RRRRPSTR( A,B,D)
+#define PSTRINGV_cfR(A,B,D) RRRRPSTRV(A,B,D)
+#endif
+#endif
+#define PNSTRING_cfR(A,B,D) PSTRING_cfR(A,B,D)
+#define PPSTRING_cfR(A,B,D)
+
+#define BYTE_cfFZ(UN,LN) INTEGER_BYTE FCALLSC_QUALIFIER fcallsc(UN,LN)(
+#define DOUBLE_cfFZ(UN,LN) DOUBLE_PRECISION FCALLSC_QUALIFIER fcallsc(UN,LN)(
+#define INT_cfFZ(UN,LN) int FCALLSC_QUALIFIER fcallsc(UN,LN)(
+#define LOGICAL_cfFZ(UN,LN) int FCALLSC_QUALIFIER fcallsc(UN,LN)(
+#define LONG_cfFZ(UN,LN) long FCALLSC_QUALIFIER fcallsc(UN,LN)(
+#define SHORT_cfFZ(UN,LN) short FCALLSC_QUALIFIER fcallsc(UN,LN)(
+#define VOID_cfFZ(UN,LN) void FCALLSC_QUALIFIER fcallsc(UN,LN)(
+#ifndef __CF__KnR
+/* The void is req'd by the Apollo, to make this an ANSI function declaration.
+ The Apollo promotes K&R float functions to double. */
+#define FLOAT_cfFZ(UN,LN) FORTRAN_REAL FCALLSC_QUALIFIER fcallsc(UN,LN)(void
+#ifdef vmsFortran
+#define STRING_cfFZ(UN,LN) void FCALLSC_QUALIFIER fcallsc(UN,LN)(fstring *AS
+#else
+#ifdef CRAYFortran
+#define STRING_cfFZ(UN,LN) void FCALLSC_QUALIFIER fcallsc(UN,LN)(_fcd AS
+#else
+#if defined(AbsoftUNIXFortran) || defined(AbsoftProFortran)
+#define STRING_cfFZ(UN,LN) void FCALLSC_QUALIFIER fcallsc(UN,LN)(char *AS
+#else
+#define STRING_cfFZ(UN,LN) void FCALLSC_QUALIFIER fcallsc(UN,LN)(char *AS, unsigned D0
+#endif
+#endif
+#endif
+#else
+#if ! (defined(FLOATFUNCTIONTYPE)&&defined(ASSIGNFLOAT)&&defined(RETURNFLOAT))
+#define FLOAT_cfFZ(UN,LN) FORTRAN_REAL FCALLSC_QUALIFIER fcallsc(UN,LN)(
+#else
+#define FLOAT_cfFZ(UN,LN) FLOATFUNCTIONTYPE FCALLSC_QUALIFIER fcallsc(UN,LN)(
+#endif
+#if defined(vmsFortran) || defined(CRAYFortran) || defined(AbsoftUNIXFortran)
+#define STRING_cfFZ(UN,LN) void FCALLSC_QUALIFIER fcallsc(UN,LN)(AS
+#else
+#define STRING_cfFZ(UN,LN) void FCALLSC_QUALIFIER fcallsc(UN,LN)(AS, D0
+#endif
+#endif
+
+#define BYTE_cfF(UN,LN) BYTE_cfFZ(UN,LN)
+#define DOUBLE_cfF(UN,LN) DOUBLE_cfFZ(UN,LN)
+#ifndef __CF_KnR
+#define FLOAT_cfF(UN,LN) FORTRAN_REAL FCALLSC_QUALIFIER fcallsc(UN,LN)(
+#else
+#define FLOAT_cfF(UN,LN) FLOAT_cfFZ(UN,LN)
+#endif
+#define INT_cfF(UN,LN) INT_cfFZ(UN,LN)
+#define LOGICAL_cfF(UN,LN) LOGICAL_cfFZ(UN,LN)
+#define LONG_cfF(UN,LN) LONG_cfFZ(UN,LN)
+#define SHORT_cfF(UN,LN) SHORT_cfFZ(UN,LN)
+#define VOID_cfF(UN,LN) VOID_cfFZ(UN,LN)
+#define STRING_cfF(UN,LN) STRING_cfFZ(UN,LN),
+
+#define INT_cfFF
+#define VOID_cfFF
+#ifdef vmsFortran
+#define STRING_cfFF fstring *AS;
+#else
+#ifdef CRAYFortran
+#define STRING_cfFF _fcd AS;
+#else
+#define STRING_cfFF char *AS; unsigned D0;
+#endif
+#endif
+
+#define INT_cfL A0=
+#define STRING_cfL A0=
+#define VOID_cfL
+
+#define INT_cfK
+#define VOID_cfK
+/* KSTRING copies the string into the position provided by the caller. */
+#ifdef vmsFortran
+#define STRING_cfK \
+ memcpy(AS->dsc$a_pointer,A0,_cfMIN(AS->dsc$w_length,(A0==NULL?0:strlen(A0))));\
+ AS->dsc$w_length>(A0==NULL?0:strlen(A0))? \
+ memset(AS->dsc$a_pointer+(A0==NULL?0:strlen(A0)),' ', \
+ AS->dsc$w_length-(A0==NULL?0:strlen(A0))):0;
+#else
+#ifdef CRAYFortran
+#define STRING_cfK \
+ memcpy(_fcdtocp(AS),A0, _cfMIN(_fcdlen(AS),(A0==NULL?0:strlen(A0))) ); \
+ _fcdlen(AS)>(A0==NULL?0:strlen(A0))? \
+ memset(_fcdtocp(AS)+(A0==NULL?0:strlen(A0)),' ', \
+ _fcdlen(AS)-(A0==NULL?0:strlen(A0))):0;
+#else
+#define STRING_cfK memcpy(AS,A0, _cfMIN(D0,(A0==NULL?0:strlen(A0))) ); \
+ D0>(A0==NULL?0:strlen(A0))?memset(AS+(A0==NULL?0:strlen(A0)), \
+ ' ', D0-(A0==NULL?0:strlen(A0))):0;
+#endif
+#endif
+
+/* Note that K.. and I.. can't be combined since K.. has to access data before
+R.., in order for functions returning strings which are also passed in as
+arguments to work correctly. Note that R.. frees and hence may corrupt the
+string. */
+#define BYTE_cfI return A0;
+#define DOUBLE_cfI return A0;
+#if ! (defined(FLOATFUNCTIONTYPE)&&defined(ASSIGNFLOAT)&&defined(RETURNFLOAT))
+#define FLOAT_cfI return A0;
+#else
+#define FLOAT_cfI RETURNFLOAT(A0);
+#endif
+#define INT_cfI return A0;
+#ifdef hpuxFortran800
+/* Incredibly, functions must return true as 1, elsewhere .true.==0x01000000. */
+#define LOGICAL_cfI return ((A0)?1:0);
+#else
+#define LOGICAL_cfI return C2FLOGICAL(A0);
+#endif
+#define LONG_cfI return A0;
+#define SHORT_cfI return A0;
+#define STRING_cfI return ;
+#define VOID_cfI return ;
+
+#ifdef OLD_VAXC /* Allow %CC-I-PARAMNOTUSED. */
+#pragma standard
+#endif
+
+#define FCALLSCSUB0( CN,UN,LN) FCALLSCFUN0(VOID,CN,UN,LN)
+#define FCALLSCSUB1( CN,UN,LN,T1) FCALLSCFUN1(VOID,CN,UN,LN,T1)
+#define FCALLSCSUB2( CN,UN,LN,T1,T2) FCALLSCFUN2(VOID,CN,UN,LN,T1,T2)
+#define FCALLSCSUB3( CN,UN,LN,T1,T2,T3) FCALLSCFUN3(VOID,CN,UN,LN,T1,T2,T3)
+#define FCALLSCSUB4( CN,UN,LN,T1,T2,T3,T4) \
+ FCALLSCFUN4(VOID,CN,UN,LN,T1,T2,T3,T4)
+#define FCALLSCSUB5( CN,UN,LN,T1,T2,T3,T4,T5) \
+ FCALLSCFUN5(VOID,CN,UN,LN,T1,T2,T3,T4,T5)
+#define FCALLSCSUB6( CN,UN,LN,T1,T2,T3,T4,T5,T6) \
+ FCALLSCFUN6(VOID,CN,UN,LN,T1,T2,T3,T4,T5,T6)
+#define FCALLSCSUB7( CN,UN,LN,T1,T2,T3,T4,T5,T6,T7) \
+ FCALLSCFUN7(VOID,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7)
+#define FCALLSCSUB8( CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8) \
+ FCALLSCFUN8(VOID,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8)
+#define FCALLSCSUB9( CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9) \
+ FCALLSCFUN9(VOID,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9)
+#define FCALLSCSUB10(CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA) \
+ FCALLSCFUN10(VOID,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA)
+#define FCALLSCSUB11(CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB) \
+ FCALLSCFUN11(VOID,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB)
+#define FCALLSCSUB12(CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC) \
+ FCALLSCFUN12(VOID,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC)
+#define FCALLSCSUB13(CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD) \
+ FCALLSCFUN13(VOID,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD)
+#define FCALLSCSUB14(CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE) \
+ FCALLSCFUN14(VOID,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE)
+#define FCALLSCSUB15(CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF) \
+ FCALLSCFUN15(VOID,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF)
+#define FCALLSCSUB16(CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG) \
+ FCALLSCFUN16(VOID,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG)
+#define FCALLSCSUB17(CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH) \
+ FCALLSCFUN17(VOID,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH)
+#define FCALLSCSUB18(CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI) \
+ FCALLSCFUN18(VOID,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI)
+#define FCALLSCSUB19(CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ) \
+ FCALLSCFUN19(VOID,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ)
+#define FCALLSCSUB20(CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK) \
+ FCALLSCFUN20(VOID,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK)
+#define FCALLSCSUB21(CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL) \
+ FCALLSCFUN21(VOID,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL)
+#define FCALLSCSUB22(CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM) \
+ FCALLSCFUN22(VOID,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM)
+#define FCALLSCSUB23(CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN) \
+ FCALLSCFUN23(VOID,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN)
+#define FCALLSCSUB24(CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO) \
+ FCALLSCFUN24(VOID,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO)
+#define FCALLSCSUB25(CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,TP) \
+ FCALLSCFUN25(VOID,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,TP)
+#define FCALLSCSUB26(CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,TP,TQ) \
+ FCALLSCFUN26(VOID,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,TP,TQ)
+#define FCALLSCSUB27(CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,TP,TQ,TR) \
+ FCALLSCFUN27(VOID,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,TP,TQ,TR)
+
+
+#define FCALLSCFUN1( T0,CN,UN,LN,T1) \
+ FCALLSCFUN5 (T0,CN,UN,LN,T1,CF_0,CF_0,CF_0,CF_0)
+#define FCALLSCFUN2( T0,CN,UN,LN,T1,T2) \
+ FCALLSCFUN5 (T0,CN,UN,LN,T1,T2,CF_0,CF_0,CF_0)
+#define FCALLSCFUN3( T0,CN,UN,LN,T1,T2,T3) \
+ FCALLSCFUN5 (T0,CN,UN,LN,T1,T2,T3,CF_0,CF_0)
+#define FCALLSCFUN4( T0,CN,UN,LN,T1,T2,T3,T4) \
+ FCALLSCFUN5 (T0,CN,UN,LN,T1,T2,T3,T4,CF_0)
+#define FCALLSCFUN5( T0,CN,UN,LN,T1,T2,T3,T4,T5) \
+ FCALLSCFUN10(T0,CN,UN,LN,T1,T2,T3,T4,T5,CF_0,CF_0,CF_0,CF_0,CF_0)
+#define FCALLSCFUN6( T0,CN,UN,LN,T1,T2,T3,T4,T5,T6) \
+ FCALLSCFUN10(T0,CN,UN,LN,T1,T2,T3,T4,T5,T6,CF_0,CF_0,CF_0,CF_0)
+#define FCALLSCFUN7( T0,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7) \
+ FCALLSCFUN10(T0,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,CF_0,CF_0,CF_0)
+#define FCALLSCFUN8( T0,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8) \
+ FCALLSCFUN10(T0,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,CF_0,CF_0)
+#define FCALLSCFUN9( T0,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9) \
+ FCALLSCFUN10(T0,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,CF_0)
+#define FCALLSCFUN10(T0,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA) \
+ FCALLSCFUN14(T0,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,CF_0,CF_0,CF_0,CF_0)
+#define FCALLSCFUN11(T0,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB) \
+ FCALLSCFUN14(T0,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,CF_0,CF_0,CF_0)
+#define FCALLSCFUN12(T0,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC) \
+ FCALLSCFUN14(T0,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,CF_0,CF_0)
+#define FCALLSCFUN13(T0,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD) \
+ FCALLSCFUN14(T0,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,CF_0)
+
+
+#define FCALLSCFUN15(T0,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF) \
+ FCALLSCFUN20(T0,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,CF_0,CF_0,CF_0,CF_0,CF_0)
+#define FCALLSCFUN16(T0,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG) \
+ FCALLSCFUN20(T0,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,CF_0,CF_0,CF_0,CF_0)
+#define FCALLSCFUN17(T0,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH) \
+ FCALLSCFUN20(T0,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,CF_0,CF_0,CF_0)
+#define FCALLSCFUN18(T0,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI) \
+ FCALLSCFUN20(T0,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,CF_0,CF_0)
+#define FCALLSCFUN19(T0,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ) \
+ FCALLSCFUN20(T0,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,CF_0)
+#define FCALLSCFUN20(T0,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK) \
+ FCALLSCFUN27(T0,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,CF_0,CF_0,CF_0,CF_0,CF_0,CF_0,CF_0)
+#define FCALLSCFUN21(T0,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL) \
+ FCALLSCFUN27(T0,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,CF_0,CF_0,CF_0,CF_0,CF_0,CF_0)
+#define FCALLSCFUN22(T0,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM) \
+ FCALLSCFUN27(T0,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,CF_0,CF_0,CF_0,CF_0,CF_0)
+#define FCALLSCFUN23(T0,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN) \
+ FCALLSCFUN27(T0,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,CF_0,CF_0,CF_0,CF_0)
+#define FCALLSCFUN24(T0,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO) \
+ FCALLSCFUN27(T0,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,CF_0,CF_0,CF_0)
+#define FCALLSCFUN25(T0,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,TP) \
+ FCALLSCFUN27(T0,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,TP,CF_0,CF_0)
+#define FCALLSCFUN26(T0,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,TP,TQ) \
+ FCALLSCFUN27(T0,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,TP,TQ,CF_0)
+
+
+#ifndef __CF__KnR
+#define FCALLSCFUN0(T0,CN,UN,LN) CFextern _(T0,_cfFZ)(UN,LN) ABSOFT_cf2(T0)) \
+ {_Icf(2,UU,T0,A0,0); _Icf(0,L,T0,0,0) CN(); _Icf(0,K,T0,0,0) _(T0,_cfI)}
+
+#define FCALLSCFUN14(T0,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE) \
+ CFextern _(T0,_cfF)(UN,LN) \
+ CFARGT14(NCF,DCF,ABSOFT_cf2(T0),T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE) ) \
+ { CFARGT14S(QCF,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE) \
+ _Icf(2,UU,T0,A0,0); _Icf(0,L,T0,0,0) CN( TCF(LN,T1,1,0) TCF(LN,T2,2,1) \
+ TCF(LN,T3,3,1) TCF(LN,T4,4,1) TCF(LN,T5,5,1) TCF(LN,T6,6,1) TCF(LN,T7,7,1) \
+ TCF(LN,T8,8,1) TCF(LN,T9,9,1) TCF(LN,TA,10,1) TCF(LN,TB,11,1) TCF(LN,TC,12,1) \
+ TCF(LN,TD,13,1) TCF(LN,TE,14,1) ); _Icf(0,K,T0,0,0) \
+ CFARGT14S(RCF,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE) _(T0,_cfI) }
+
+#define FCALLSCFUN27(T0,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,TP,TQ,TR) \
+ CFextern _(T0,_cfF)(UN,LN) \
+ CFARGT27(NCF,DCF,ABSOFT_cf2(T0),T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,TP,TQ,TR) ) \
+ { CFARGT27S(QCF,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,TP,TQ,TR) \
+ _Icf(2,UU,T0,A0,0); _Icf(0,L,T0,0,0) CN( TCF(LN,T1,1,0) TCF(LN,T2,2,1) \
+ TCF(LN,T3,3,1) TCF(LN,T4,4,1) TCF(LN,T5,5,1) TCF(LN,T6,6,1) TCF(LN,T7,7,1) \
+ TCF(LN,T8,8,1) TCF(LN,T9,9,1) TCF(LN,TA,10,1) TCF(LN,TB,11,1) TCF(LN,TC,12,1) \
+ TCF(LN,TD,13,1) TCF(LN,TE,14,1) TCF(LN,TF,15,1) TCF(LN,TG,16,1) TCF(LN,TH,17,1) \
+ TCF(LN,TI,18,1) TCF(LN,TJ,19,1) TCF(LN,TK,20,1) TCF(LN,TL,21,1) TCF(LN,TM,22,1) \
+ TCF(LN,TN,23,1) TCF(LN,TO,24,1) TCF(LN,TP,25,1) TCF(LN,TQ,26,1) TCF(LN,TR,27,1) ); _Icf(0,K,T0,0,0) \
+ CFARGT27S(RCF,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,TP,TQ,TR) _(T0,_cfI) }
+
+#else
+#define FCALLSCFUN0(T0,CN,UN,LN) CFextern _(T0,_cfFZ)(UN,LN) ABSOFT_cf3(T0)) _Icf(0,FF,T0,0,0)\
+ {_Icf(2,UU,T0,A0,0); _Icf(0,L,T0,0,0) CN(); _Icf(0,K,T0,0,0) _(T0,_cfI)}
+
+#define FCALLSCFUN14(T0,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE) \
+ CFextern _(T0,_cfF)(UN,LN) \
+ CFARGT14(NNCF,DDCF,ABSOFT_cf3(T0),T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE)) _Icf(0,FF,T0,0,0) \
+ CFARGT14FS(NNNCF,DDDCF,_Z,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE); \
+ { CFARGT14S(QCF,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE) \
+ _Icf(2,UU,T0,A0,0); _Icf(0,L,T0,0,0) CN( TCF(LN,T1,1,0) TCF(LN,T2,2,1) \
+ TCF(LN,T3,3,1) TCF(LN,T4,4,1) TCF(LN,T5,5,1) TCF(LN,T6,6,1) TCF(LN,T7,7,1) \
+ TCF(LN,T8,8,1) TCF(LN,T9,9,1) TCF(LN,TA,10,1) TCF(LN,TB,11,1) TCF(LN,TC,12,1) \
+ TCF(LN,TD,13,1) TCF(LN,TE,14,1) ); _Icf(0,K,T0,0,0) \
+ CFARGT14S(RCF,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE) _(T0,_cfI)}
+
+#define FCALLSCFUN27(T0,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,TP,TQ,TR) \
+ CFextern _(T0,_cfF)(UN,LN) \
+ CFARGT27(NNCF,DDCF,ABSOFT_cf3(T0),T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,TP,TQ,TR)) _Icf(0,FF,T0,0,0) \
+ CFARGT27FS(NNNCF,DDDCF,_Z,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,TP,TQ,TR); \
+ { CFARGT27S(QCF,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,TP,TQ,TR) \
+ _Icf(2,UU,T0,A0,0); _Icf(0,L,T0,0,0) CN( TCF(LN,T1,1,0) TCF(LN,T2,2,1) \
+ TCF(LN,T3,3,1) TCF(LN,T4,4,1) TCF(LN,T5,5,1) TCF(LN,T6,6,1) TCF(LN,T7,7,1) \
+ TCF(LN,T8,8,1) TCF(LN,T9,9,1) TCF(LN,TA,10,1) TCF(LN,TB,11,1) TCF(LN,TC,12,1) \
+ TCF(LN,TD,13,1) TCF(LN,TE,14,1) TCF(LN,TF,15,1) TCF(LN,TG,16,1) TCF(LN,TH,17,1) \
+ TCF(LN,TI,18,1) TCF(LN,TJ,19,1) TCF(LN,TK,20,1) TCF(LN,TL,21,1) TCF(LN,TM,22,1) \
+ TCF(LN,TN,23,1) TCF(LN,TO,24,1) TCF(LN,TP,25,1) TCF(LN,TQ,26,1) TCF(LN,TR,27,1) ); _Icf(0,K,T0,0,0) \
+ CFARGT27S(RCF,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,TP,TQ,TR) _(T0,_cfI)}
+
+#endif
+
+
+#endif /* __CFORTRAN_LOADED */
+
diff --git a/CTP/cfortran.h.debian b/CTP/cfortran.h.debian
new file mode 100644
index 0000000..77db992
--- /dev/null
+++ b/CTP/cfortran.h.debian
@@ -0,0 +1,2510 @@
+/* cfortran.h 4.4 */
+/* http://www-zeus.desy.de/~burow/cfortran/ */
+/* Burkhard Burow burow@desy.de 1990 - 2002. */
+/* This vresion of cfortran.h is from Debian and has support for gfortran. */
+
+#ifndef __CFORTRAN_LOADED
+#define __CFORTRAN_LOADED
+
+/*
+ THIS FILE IS PROPERTY OF BURKHARD BUROW. IF YOU ARE USING THIS FILE YOU
+ SHOULD ALSO HAVE ACCESS TO CFORTRAN.DOC WHICH PROVIDES TERMS FOR USING,
+ MODIFYING, COPYING AND DISTRIBUTING THE CFORTRAN.H PACKAGE.
+*/
+
+/* The following modifications were made by the authors of CFITSIO or by me.
+ * They are flagged below with CFITSIO, the author's initials, or KMCCARTY.
+ * PDW = Peter Wilson
+ * DM = Doug Mink
+ * LEB = Lee E Brotzman
+ * MR = Martin Reinecke
+ * WDP = William D Pence
+ * -- Kevin McCarty, for Debian (19 Dec. 2005) */
+
+/*******
+ Modifications:
+ Oct 1997: Changed symbol name extname to appendus (PDW/HSTX)
+ (Conflicted with a common variable name in FTOOLS)
+ Nov 1997: If g77Fortran defined, also define f2cFortran (PDW/HSTX)
+ Feb 1998: Let VMS see the NUM_ELEMS code. Lets programs treat
+ single strings as vectors with single elements
+ Nov 1999: If macintoxh defined, also define f2cfortran (for Mac OS-X)
+ Apr 2000: If WIN32 defined, also define PowerStationFortran and
+ VISUAL_CPLUSPLUS (Visual C++)
+ Jun 2000: If __GNUC__ and linux defined, also define f2cFortran
+ (linux/gcc environment detection)
+ Apr 2002: If __CYGWIN__ is defined, also define f2cFortran
+ Nov 2002: If __APPLE__ defined, also define f2cfortran (for Mac OS-X)
+
+ Nov 2003: If __INTEL_COMPILER or INTEL_COMPILER defined, also define
+ f2cFortran (KMCCARTY)
+ Dec 2005: If f2cFortran is defined, enforce REAL functions in FORTRAN
+ returning "double" in C. This was one of the items on
+ Burkhard's TODO list. (KMCCARTY)
+ Dec 2005: Modifications to support 8-byte integers. (MR)
+ USE AT YOUR OWN RISK!
+ Feb 2006 Added logic to typedef the symbol 'LONGLONG' to an appropriate
+ intrinsic 8-byte integer datatype (WDP)
+ Apr 2006: Modifications to support gfortran (and g77 with -fno-f2c flag)
+ since by default it returns "float" for FORTRAN REAL function.
+ (KMCCARTY)
+ *******/
+
+/*
+ Avoid symbols already used by compilers and system *.h:
+ __ - OSF1 zukal06 V3.0 347 alpha, cc -c -std1 cfortest.c
+
+*/
+
+/*
+ Determine what 8-byte integer data type is available.
+ 'long long' is now supported by most compilers, but older
+ MS Visual C++ compilers before V7.0 use '__int64' instead. (WDP)
+*/
+
+#ifndef LONGLONG_TYPE /* this may have been previously defined */
+#if defined(_MSC_VER) /* Microsoft Visual C++ */
+
+#if (_MSC_VER < 1300) /* versions earlier than V7.0 do not have 'long long' */
+ typedef __int64 LONGLONG;
+#else /* newer versions do support 'long long' */
+ typedef long long LONGLONG;
+#endif
+
+#else
+ typedef long long LONGLONG;
+#endif
+
+#define LONGLONG_TYPE
+#endif
+
+
+/* First prepare for the C compiler. */
+
+#ifndef ANSI_C_preprocessor /* i.e. user can override. */
+#ifdef __CF__KnR
+#define ANSI_C_preprocessor 0
+#else
+#ifdef __STDC__
+#define ANSI_C_preprocessor 1
+#else
+#define _cfleft 1
+#define _cfright
+#define _cfleft_cfright 0
+#define ANSI_C_preprocessor _cfleft/**/_cfright
+#endif
+#endif
+#endif
+
+#if ANSI_C_preprocessor
+#define _0(A,B) A##B
+#define _(A,B) _0(A,B) /* see cat,xcat of K&R ANSI C p. 231 */
+#define _2(A,B) A##B /* K&R ANSI C p.230: .. identifier is not replaced */
+#define _3(A,B,C) _(A,_(B,C))
+#else /* if it turns up again during rescanning. */
+#define _(A,B) A/**/B
+#define _2(A,B) A/**/B
+#define _3(A,B,C) A/**/B/**/C
+#endif
+
+#if (defined(vax)&&defined(unix)) || (defined(__vax__)&&defined(__unix__))
+#define VAXUltrix
+#endif
+
+#include <stdio.h> /* NULL [in all machines stdio.h] */
+#include <string.h> /* strlen, memset, memcpy, memchr. */
+#if !( defined(VAXUltrix) || defined(sun) || (defined(apollo)&&!defined(__STDCPP__)) )
+#include <stdlib.h> /* malloc,free */
+#else
+#include <malloc.h> /* Had to be removed for DomainOS h105 10.4 sys5.3 425t*/
+#ifdef apollo
+#define __CF__APOLLO67 /* __STDCPP__ is in Apollo 6.8 (i.e. ANSI) and onwards */
+#endif
+#endif
+
+#if !defined(__GNUC__) && !defined(__sun) && (defined(sun)||defined(VAXUltrix)||defined(lynx))
+#define __CF__KnR /* Sun, LynxOS and VAX Ultrix cc only supports K&R. */
+ /* Manually define __CF__KnR for HP if desired/required.*/
+#endif /* i.e. We will generate Kernighan and Ritchie C. */
+/* Note that you may define __CF__KnR before #include cfortran.h, in order to
+generate K&R C instead of the default ANSI C. The differences are mainly in the
+function prototypes and declarations. All machines, except the Apollo, work
+with either style. The Apollo's argument promotion rules require ANSI or use of
+the obsolete std_$call which we have not implemented here. Hence on the Apollo,
+only C calling FORTRAN subroutines will work using K&R style.*/
+
+
+/* Remainder of cfortran.h depends on the Fortran compiler. */
+
+/* 11/29/2003 (KMCCARTY): add *INTEL_COMPILER symbols here */
+/* 04/05/2006 (KMCCARTY): add gFortran symbol here */
+#if defined(CLIPPERFortran) || defined(pgiFortran) || defined(__INTEL_COMPILER) || defined(INTEL_COMPILER) || defined(gFortran)
+#define f2cFortran
+#endif
+
+/* VAX/VMS does not let us \-split long #if lines. */
+/* Split #if into 2 because some HP-UX can't handle long #if */
+#if !(defined(NAGf90Fortran)||defined(f2cFortran)||defined(hpuxFortran)||defined(apolloFortran)||defined(sunFortran)||defined(IBMR2Fortran)||defined(CRAYFortran))
+#if !(defined(mipsFortran)||defined(DECFortran)||defined(vmsFortran)||defined(CONVEXFortran)||defined(PowerStationFortran)||defined(AbsoftUNIXFortran)||defined(AbsoftProFortran)||defined(SXFortran))
+/* If no Fortran compiler is given, we choose one for the machines we know. */
+#if defined(lynx) || defined(VAXUltrix)
+#define f2cFortran /* Lynx: Only support f2c at the moment.
+ VAXUltrix: f77 behaves like f2c.
+ Support f2c or f77 with gcc, vcc with f2c.
+ f77 with vcc works, missing link magic for f77 I/O.*/
+#endif
+/* 04/13/00 DM (CFITSIO): Add these lines for NT */
+/* with PowerStationFortran and and Visual C++ */
+#if defined(WIN32) && !defined(__CYGWIN__)
+#define PowerStationFortran
+#define VISUAL_CPLUSPLUS
+#endif
+#if defined(g77Fortran) /* 11/03/97 PDW (CFITSIO) */
+#define f2cFortran
+#endif
+#if defined(__CYGWIN__) /* 04/11/02 LEB (CFITSIO) */
+#define f2cFortran
+#endif
+#if defined(__GNUC__) && defined(linux) /* 06/21/00 PDW (CFITSIO) */
+#define f2cFortran
+#endif
+#if defined(macintosh) /* 11/1999 (CFITSIO) */
+#define f2cFortran
+#endif
+#if defined(__APPLE__) /* 11/2002 (CFITSIO) */
+#define f2cFortran
+#endif
+#if defined(__hpux) /* 921107: Use __hpux instead of __hp9000s300 */
+#define hpuxFortran /* Should also allow hp9000s7/800 use.*/
+#endif
+#if defined(apollo)
+#define apolloFortran /* __CF__APOLLO67 also defines some behavior. */
+#endif
+#if defined(sun) || defined(__sun)
+#define sunFortran
+#endif
+#if defined(_IBMR2)
+#define IBMR2Fortran
+#endif
+#if defined(_CRAY)
+#define CRAYFortran /* _CRAYT3E also defines some behavior. */
+#endif
+#if defined(_SX)
+#define SXFortran
+#endif
+#if defined(mips) || defined(__mips)
+#define mipsFortran
+#endif
+#if defined(vms) || defined(__vms)
+#define vmsFortran
+#endif
+#if defined(__alpha) && defined(__unix__)
+#define DECFortran
+#endif
+#if defined(__convex__)
+#define CONVEXFortran
+#endif
+#if defined(VISUAL_CPLUSPLUS)
+#define PowerStationFortran
+#endif
+#endif /* ...Fortran */
+#endif /* ...Fortran */
+
+/* Split #if into 2 because some HP-UX can't handle long #if */
+#if !(defined(NAGf90Fortran)||defined(f2cFortran)||defined(hpuxFortran)||defined(apolloFortran)||defined(sunFortran)||defined(IBMR2Fortran)||defined(CRAYFortran))
+#if !(defined(mipsFortran)||defined(DECFortran)||defined(vmsFortran)||defined(CONVEXFortran)||defined(PowerStationFortran)||defined(AbsoftUNIXFortran)||defined(AbsoftProFortran)||defined(SXFortran))
+/* If your compiler barfs on ' #error', replace # with the trigraph for # */
+ #error "cfortran.h: Can't find your environment among:\
+ - GNU gcc (g77) on Linux. \
+ - MIPS cc and f77 2.0. (e.g. Silicon Graphics, DECstations, ...) \
+ - IBM AIX XL C and FORTRAN Compiler/6000 Version 01.01.0000.0000 \
+ - VAX VMS CC 3.1 and FORTRAN 5.4. \
+ - Alpha VMS DEC C 1.3 and DEC FORTRAN 6.0. \
+ - Alpha OSF DEC C and DEC Fortran for OSF/1 AXP Version 1.2 \
+ - Apollo DomainOS 10.2 (sys5.3) with f77 10.7 and cc 6.7. \
+ - CRAY \
+ - NEC SX-4 SUPER-UX \
+ - CONVEX \
+ - Sun \
+ - PowerStation Fortran with Visual C++ \
+ - HP9000s300/s700/s800 Latest test with: HP-UX A.08.07 A 9000/730 \
+ - LynxOS: cc or gcc with f2c. \
+ - VAXUltrix: vcc,cc or gcc with f2c. gcc or cc with f77. \
+ - f77 with vcc works; but missing link magic for f77 I/O. \
+ - NO fort. None of gcc, cc or vcc generate required names.\
+ - f2c/g77: Use #define f2cFortran, or cc -Df2cFortran \
+ - gfortran: Use #define gFortran, or cc -DgFortran \
+ (also necessary for g77 with -fno-f2c option) \
+ - NAG f90: Use #define NAGf90Fortran, or cc -DNAGf90Fortran \
+ - Absoft UNIX F77: Use #define AbsoftUNIXFortran or cc -DAbsoftUNIXFortran \
+ - Absoft Pro Fortran: Use #define AbsoftProFortran \
+ - Portland Group Fortran: Use #define pgiFortran \
+ - Intel Fortran: Use #define INTEL_COMPILER"
+/* Compiler must throw us out at this point! */
+#endif
+#endif
+
+
+#if defined(VAXC) && !defined(__VAXC)
+#define OLD_VAXC
+#pragma nostandard /* Prevent %CC-I-PARAMNOTUSED. */
+#endif
+
+/* Throughout cfortran.h we use: UN = Uppercase Name. LN = Lowercase Name. */
+
+/* "extname" changed to "appendus" below (CFITSIO) */
+#if defined(f2cFortran) || defined(NAGf90Fortran) || defined(DECFortran) || defined(mipsFortran) || defined(apolloFortran) || defined(sunFortran) || defined(CONVEXFortran) || defined(SXFortran) || defined(appendus)
+#define CFC_(UN,LN) _(LN,_) /* Lowercase FORTRAN symbols. */
+#define orig_fcallsc(UN,LN) CFC_(UN,LN)
+#else
+#if defined(CRAYFortran) || defined(PowerStationFortran) || defined(AbsoftProFortran)
+#ifdef _CRAY /* (UN), not UN, circumvents CRAY preprocessor bug. */
+#define CFC_(UN,LN) (UN) /* Uppercase FORTRAN symbols. */
+#else /* At least VISUAL_CPLUSPLUS barfs on (UN), so need UN. */
+#define CFC_(UN,LN) UN /* Uppercase FORTRAN symbols. */
+#endif
+#define orig_fcallsc(UN,LN) CFC_(UN,LN) /* CRAY insists on arg.'s here. */
+#else /* For following machines one may wish to change the fcallsc default. */
+#define CF_SAME_NAMESPACE
+#ifdef vmsFortran
+#define CFC_(UN,LN) LN /* Either case FORTRAN symbols. */
+ /* BUT we usually use UN for C macro to FORTRAN routines, so use LN here,*/
+ /* because VAX/VMS doesn't do recursive macros. */
+#define orig_fcallsc(UN,LN) UN
+#else /* HP-UX without +ppu or IBMR2 without -qextname. NOT reccomended. */
+#define CFC_(UN,LN) LN /* Lowercase FORTRAN symbols. */
+#define orig_fcallsc(UN,LN) CFC_(UN,LN)
+#endif /* vmsFortran */
+#endif /* CRAYFortran PowerStationFortran */
+#endif /* ....Fortran */
+
+#define fcallsc(UN,LN) orig_fcallsc(UN,LN)
+#define preface_fcallsc(P,p,UN,LN) CFC_(_(P,UN),_(p,LN))
+#define append_fcallsc(P,p,UN,LN) CFC_(_(UN,P),_(LN,p))
+
+#define C_FUNCTION(UN,LN) fcallsc(UN,LN)
+#define FORTRAN_FUNCTION(UN,LN) CFC_(UN,LN)
+
+#ifndef COMMON_BLOCK
+#ifndef CONVEXFortran
+#ifndef CLIPPERFortran
+#if !(defined(AbsoftUNIXFortran)||defined(AbsoftProFortran))
+#define COMMON_BLOCK(UN,LN) CFC_(UN,LN)
+#else
+#define COMMON_BLOCK(UN,LN) _(_C,LN)
+#endif /* AbsoftUNIXFortran or AbsoftProFortran */
+#else
+#define COMMON_BLOCK(UN,LN) _(LN,__)
+#endif /* CLIPPERFortran */
+#else
+#define COMMON_BLOCK(UN,LN) _3(_,LN,_)
+#endif /* CONVEXFortran */
+#endif /* COMMON_BLOCK */
+
+#ifndef DOUBLE_PRECISION
+#if defined(CRAYFortran) && !defined(_CRAYT3E)
+#define DOUBLE_PRECISION long double
+#else
+#define DOUBLE_PRECISION double
+#endif
+#endif
+
+#ifndef FORTRAN_REAL
+#if defined(CRAYFortran) && defined(_CRAYT3E)
+#define FORTRAN_REAL double
+#else
+#define FORTRAN_REAL float
+#endif
+#endif
+
+#ifdef CRAYFortran
+#ifdef _CRAY
+#include <fortran.h>
+#else
+#include "fortran.h" /* i.e. if crosscompiling assume user has file. */
+#endif
+#define FLOATVVVVVVV_cfPP (FORTRAN_REAL *) /* Used for C calls FORTRAN. */
+/* CRAY's double==float but CRAY says pointers to doubles and floats are diff.*/
+#define VOIDP (void *) /* When FORTRAN calls C, we don't know if C routine
+ arg.'s have been declared float *, or double *. */
+#else
+#define FLOATVVVVVVV_cfPP
+#define VOIDP
+#endif
+
+#ifdef vmsFortran
+#if defined(vms) || defined(__vms)
+#include <descrip.h>
+#else
+#include "descrip.h" /* i.e. if crosscompiling assume user has file. */
+#endif
+#endif
+
+#ifdef sunFortran
+#if defined(sun) || defined(__sun)
+#include <math.h> /* Sun's FLOATFUNCTIONTYPE, ASSIGNFLOAT, RETURNFLOAT. */
+#else
+#include "math.h" /* i.e. if crosscompiling assume user has file. */
+#endif
+/* At least starting with the default C compiler SC3.0.1 of SunOS 5.3,
+ * FLOATFUNCTIONTYPE, ASSIGNFLOAT, RETURNFLOAT are not required and not in
+ * <math.h>, since sun C no longer promotes C float return values to doubles.
+ * Therefore, only use them if defined.
+ * Even if gcc is being used, assume that it exhibits the Sun C compiler
+ * behavior in order to be able to use *.o from the Sun C compiler.
+ * i.e. If FLOATFUNCTIONTYPE, etc. are in math.h, they required by gcc.
+ */
+#endif
+
+#ifndef apolloFortran
+/* "extern" removed (CFITSIO) */
+#define COMMON_BLOCK_DEF(DEFINITION, NAME) /* extern */ DEFINITION NAME
+#define CF_NULL_PROTO
+#else /* HP doesn't understand #elif. */
+/* Without ANSI prototyping, Apollo promotes float functions to double. */
+/* Note that VAX/VMS, IBM, Mips choke on 'type function(...);' prototypes. */
+#define CF_NULL_PROTO ...
+#ifndef __CF__APOLLO67
+#define COMMON_BLOCK_DEF(DEFINITION, NAME) \
+ DEFINITION NAME __attribute((__section(NAME)))
+#else
+#define COMMON_BLOCK_DEF(DEFINITION, NAME) \
+ DEFINITION NAME #attribute[section(NAME)]
+#endif
+#endif
+
+#ifdef __cplusplus
+#undef CF_NULL_PROTO
+#define CF_NULL_PROTO ...
+#endif
+
+
+#ifndef USE_NEW_DELETE
+#ifdef __cplusplus
+#define USE_NEW_DELETE 1
+#else
+#define USE_NEW_DELETE 0
+#endif
+#endif
+#if USE_NEW_DELETE
+#define _cf_malloc(N) new char[N]
+#define _cf_free(P) delete[] P
+#else
+#define _cf_malloc(N) (char *)malloc(N)
+#define _cf_free(P) free(P)
+#endif
+
+#ifdef mipsFortran
+#define CF_DECLARE_GETARG int f77argc; char **f77argv
+#define CF_SET_GETARG(ARGC,ARGV) f77argc = ARGC; f77argv = ARGV
+#else
+#define CF_DECLARE_GETARG
+#define CF_SET_GETARG(ARGC,ARGV)
+#endif
+
+#ifdef OLD_VAXC /* Allow %CC-I-PARAMNOTUSED. */
+#pragma standard
+#endif
+
+#define AcfCOMMA ,
+#define AcfCOLON ;
+
+/*-------------------------------------------------------------------------*/
+
+/* UTILITIES USED WITHIN CFORTRAN.H */
+
+#define _cfMIN(A,B) (A<B?A:B)
+
+/* 970211 - XIX.145:
+ firstindexlength - better name is all_but_last_index_lengths
+ secondindexlength - better name is last_index_length
+ */
+#define firstindexlength(A) (sizeof(A[0])==1 ? 1 : (sizeof(A) / sizeof(A[0])) )
+#define secondindexlength(A) (sizeof(A[0])==1 ? sizeof(A) : sizeof(A[0]) )
+
+/* Behavior of FORTRAN LOGICAL. All machines' LOGICAL is same size as C's int.
+Conversion is automatic except for arrays which require F2CLOGICALV/C2FLOGICALV.
+f2c, MIPS f77 [DECstation, SGI], VAX Ultrix f77,
+HP-UX f77 : as in C.
+VAX/VMS FORTRAN, VAX Ultrix fort,
+Absoft Unix Fortran, IBM RS/6000 xlf : LS Bit = 0/1 = TRUE/FALSE.
+Apollo : neg. = TRUE, else FALSE.
+[Apollo accepts -1 as TRUE for function values, but NOT all other neg. values.]
+[DECFortran for Ultrix RISC is also called f77 but is the same as VAX/VMS.]
+[MIPS f77 treats .eqv./.neqv. as .eq./.ne. and hence requires LOGICAL_STRICT.]*/
+
+#if defined(NAGf90Fortran) || defined(f2cFortran) || defined(mipsFortran) || defined(PowerStationFortran) || defined(hpuxFortran800) || defined(AbsoftUNIXFortran) || defined(AbsoftProFortran) || defined(SXFortran)
+/* SX/PowerStationFortran have 0 and 1 defined, others are neither T nor F. */
+/* hpuxFortran800 has 0 and 0x01000000 defined. Others are unknown. */
+#define LOGICAL_STRICT /* Other Fortran have .eqv./.neqv. == .eq./.ne. */
+#endif
+
+#define C2FLOGICALV(A,I) \
+ do {int __i; for(__i=0;__i<I;__i++) A[__i]=C2FLOGICAL(A[__i]); } while (0)
+#define F2CLOGICALV(A,I) \
+ do {int __i; for(__i=0;__i<I;__i++) A[__i]=F2CLOGICAL(A[__i]); } while (0)
+
+#if defined(apolloFortran)
+#define C2FLOGICAL(L) ((L)?-1:(L)&~((unsigned)1<<sizeof(int)*8-1))
+#define F2CLOGICAL(L) ((L)<0?(L):0)
+#else
+#if defined(CRAYFortran)
+#define C2FLOGICAL(L) _btol(L)
+#define F2CLOGICAL(L) _ltob(&(L)) /* Strangely _ltob() expects a pointer. */
+#else
+#if defined(IBMR2Fortran) || defined(vmsFortran) || defined(DECFortran) || defined(AbsoftUNIXFortran)
+/* How come no AbsoftProFortran ? */
+#define C2FLOGICAL(L) ((L)?(L)|1:(L)&~(int)1)
+#define F2CLOGICAL(L) ((L)&1?(L):0)
+#else
+#if defined(CONVEXFortran)
+#define C2FLOGICAL(L) ((L) ? ~0 : 0 )
+#define F2CLOGICAL(L) (L)
+#else /* others evaluate LOGICALs as for C. */
+#define C2FLOGICAL(L) (L)
+#define F2CLOGICAL(L) (L)
+#ifndef LOGICAL_STRICT
+#undef C2FLOGICALV
+#undef F2CLOGICALV
+#define C2FLOGICALV(A,I)
+#define F2CLOGICALV(A,I)
+#endif /* LOGICAL_STRICT */
+#endif /* CONVEXFortran || All Others */
+#endif /* IBMR2Fortran vmsFortran DECFortran AbsoftUNIXFortran */
+#endif /* CRAYFortran */
+#endif /* apolloFortran */
+
+/* 970514 - In addition to CRAY, there may be other machines
+ for which LOGICAL_STRICT makes no sense. */
+#if defined(LOGICAL_STRICT) && !defined(CRAYFortran)
+/* Force C2FLOGICAL to generate only the values for either .TRUE. or .FALSE.
+ SX/PowerStationFortran only have 0 and 1 defined.
+ Elsewhere, only needed if you want to do:
+ logical lvariable
+ if (lvariable .eq. .true.) then ! (1)
+ instead of
+ if (lvariable .eqv. .true.) then ! (2)
+ - (1) may not even be FORTRAN/77 and that Apollo's f77 and IBM's xlf
+ refuse to compile (1), so you are probably well advised to stay away from
+ (1) and from LOGICAL_STRICT.
+ - You pay a (slight) performance penalty for using LOGICAL_STRICT. */
+#undef C2FLOGICAL
+#ifdef hpuxFortran800
+#define C2FLOGICAL(L) ((L)?0x01000000:0)
+#else
+#if defined(apolloFortran) || defined(vmsFortran) || defined(DECFortran)
+#define C2FLOGICAL(L) ((L)?-1:0) /* These machines use -1/0 for .true./.false.*/
+#else
+#define C2FLOGICAL(L) ((L)? 1:0) /* All others use +1/0 for .true./.false.*/
+#endif
+#endif
+#endif /* LOGICAL_STRICT */
+
+/* Convert a vector of C strings into FORTRAN strings. */
+#ifndef __CF__KnR
+static char *c2fstrv(char* cstr, char *fstr, int elem_len, int sizeofcstr)
+#else
+static char *c2fstrv( cstr, fstr, elem_len, sizeofcstr)
+ char* cstr; char *fstr; int elem_len; int sizeofcstr;
+#endif
+{ int i,j;
+/* elem_len includes \0 for C strings. Fortran strings don't have term. \0.
+ Useful size of string must be the same in both languages. */
+for (i=0; i<sizeofcstr/elem_len; i++) {
+ for (j=1; j<elem_len && *cstr; j++) *fstr++ = *cstr++;
+ cstr += 1+elem_len-j;
+ for (; j<elem_len; j++) *fstr++ = ' ';
+} /* 95109 - Seems to be returning the original fstr. */
+return fstr-sizeofcstr+sizeofcstr/elem_len; }
+
+/* Convert a vector of FORTRAN strings into C strings. */
+#ifndef __CF__KnR
+static char *f2cstrv(char *fstr, char* cstr, int elem_len, int sizeofcstr)
+#else
+static char *f2cstrv( fstr, cstr, elem_len, sizeofcstr)
+ char *fstr; char* cstr; int elem_len; int sizeofcstr;
+#endif
+{ int i,j;
+/* elem_len includes \0 for C strings. Fortran strings don't have term. \0.
+ Useful size of string must be the same in both languages. */
+cstr += sizeofcstr;
+fstr += sizeofcstr - sizeofcstr/elem_len;
+for (i=0; i<sizeofcstr/elem_len; i++) {
+ *--cstr = '\0';
+ for (j=1; j<elem_len; j++) *--cstr = *--fstr;
+} return cstr; }
+
+/* kill the trailing char t's in string s. */
+#ifndef __CF__KnR
+static char *kill_trailing(char *s, char t)
+#else
+static char *kill_trailing( s, t) char *s; char t;
+#endif
+{char *e;
+e = s + strlen(s);
+if (e>s) { /* Need this to handle NULL string.*/
+ while (e>s && *--e==t); /* Don't follow t's past beginning. */
+ e[*e==t?0:1] = '\0'; /* Handle s[0]=t correctly. */
+} return s; }
+
+/* kill_trailingn(s,t,e) will kill the trailing t's in string s. e normally
+points to the terminating '\0' of s, but may actually point to anywhere in s.
+s's new '\0' will be placed at e or earlier in order to remove any trailing t's.
+If e<s string s is left unchanged. */
+#ifndef __CF__KnR
+static char *kill_trailingn(char *s, char t, char *e)
+#else
+static char *kill_trailingn( s, t, e) char *s; char t; char *e;
+#endif
+{
+if (e==s) *e = '\0'; /* Kill the string makes sense here.*/
+else if (e>s) { /* Watch out for neg. length string.*/
+ while (e>s && *--e==t); /* Don't follow t's past beginning. */
+ e[*e==t?0:1] = '\0'; /* Handle s[0]=t correctly. */
+} return s; }
+
+/* Note the following assumes that any element which has t's to be chopped off,
+does indeed fill the entire element. */
+#ifndef __CF__KnR
+static char *vkill_trailing(char* cstr, int elem_len, int sizeofcstr, char t)
+#else
+static char *vkill_trailing( cstr, elem_len, sizeofcstr, t)
+ char* cstr; int elem_len; int sizeofcstr; char t;
+#endif
+{ int i;
+for (i=0; i<sizeofcstr/elem_len; i++) /* elem_len includes \0 for C strings. */
+ kill_trailingn(cstr+elem_len*i,t,cstr+elem_len*(i+1)-1);
+return cstr; }
+
+#ifdef vmsFortran
+typedef struct dsc$descriptor_s fstring;
+#define DSC$DESCRIPTOR_A(DIMCT) \
+struct { \
+ unsigned short dsc$w_length; unsigned char dsc$b_dtype; \
+ unsigned char dsc$b_class; char *dsc$a_pointer; \
+ char dsc$b_scale; unsigned char dsc$b_digits; \
+ struct { \
+ unsigned : 3; unsigned dsc$v_fl_binscale : 1; \
+ unsigned dsc$v_fl_redim : 1; unsigned dsc$v_fl_column : 1; \
+ unsigned dsc$v_fl_coeff : 1; unsigned dsc$v_fl_bounds : 1; \
+ } dsc$b_aflags; \
+ unsigned char dsc$b_dimct; unsigned long dsc$l_arsize; \
+ char *dsc$a_a0; long dsc$l_m [DIMCT]; \
+ struct { \
+ long dsc$l_l; long dsc$l_u; \
+ } dsc$bounds [DIMCT]; \
+}
+typedef DSC$DESCRIPTOR_A(1) fstringvector;
+/*typedef DSC$DESCRIPTOR_A(2) fstringarrarr;
+ typedef DSC$DESCRIPTOR_A(3) fstringarrarrarr;*/
+#define initfstr(F,C,ELEMNO,ELEMLEN) \
+( (F).dsc$l_arsize= ( (F).dsc$w_length =(ELEMLEN) ) \
+ *( (F).dsc$l_m[0]=(F).dsc$bounds[0].dsc$l_u=(ELEMNO) ), \
+ (F).dsc$a_a0 = ( (F).dsc$a_pointer=(C) ) - (F).dsc$w_length ,(F))
+
+#endif /* PDW: 2/10/98 (CFITSIO) -- Let VMS see NUM_ELEMS definitions */
+#define _NUM_ELEMS -1
+#define _NUM_ELEM_ARG -2
+#define NUM_ELEMS(A) A,_NUM_ELEMS
+#define NUM_ELEM_ARG(B) *_2(A,B),_NUM_ELEM_ARG
+#define TERM_CHARS(A,B) A,B
+#ifndef __CF__KnR
+static int num_elem(char *strv, unsigned elem_len, int term_char, int num_term)
+#else
+static int num_elem( strv, elem_len, term_char, num_term)
+ char *strv; unsigned elem_len; int term_char; int num_term;
+#endif
+/* elem_len is the number of characters in each element of strv, the FORTRAN
+vector of strings. The last element of the vector must begin with at least
+num_term term_char characters, so that this routine can determine how
+many elements are in the vector. */
+{
+unsigned num,i;
+if (num_term == _NUM_ELEMS || num_term == _NUM_ELEM_ARG)
+ return term_char;
+if (num_term <=0) num_term = (int)elem_len;
+for (num=0; ; num++) {
+ for (i=0; i<(unsigned)num_term && *strv==term_char; i++,strv++);
+ if (i==(unsigned)num_term) break;
+ else strv += elem_len-i;
+}
+if (0) { /* to prevent not used warnings in gcc (added by ROOT) */
+ c2fstrv(0, 0, 0, 0); f2cstrv(0, 0, 0, 0); kill_trailing(0, 0);
+ vkill_trailing(0, 0, 0, 0); num_elem(0, 0, 0, 0);
+}
+return (int)num;
+}
+/* #endif removed 2/10/98 (CFITSIO) */
+
+/*-------------------------------------------------------------------------*/
+
+/* UTILITIES FOR C TO USE STRINGS IN FORTRAN COMMON BLOCKS */
+
+/* C string TO Fortran Common Block STRing. */
+/* DIM is the number of DIMensions of the array in terms of strings, not
+ characters. e.g. char a[12] has DIM = 0, char a[12][4] has DIM = 1, etc. */
+#define C2FCBSTR(CSTR,FSTR,DIM) \
+ c2fstrv((char *)CSTR, (char *)FSTR, sizeof(FSTR)/cfelementsof(FSTR,DIM)+1, \
+ sizeof(FSTR)+cfelementsof(FSTR,DIM))
+
+/* Fortran Common Block string TO C STRing. */
+#define FCB2CSTR(FSTR,CSTR,DIM) \
+ vkill_trailing(f2cstrv((char *)FSTR, (char *)CSTR, \
+ sizeof(FSTR)/cfelementsof(FSTR,DIM)+1, \
+ sizeof(FSTR)+cfelementsof(FSTR,DIM)), \
+ sizeof(FSTR)/cfelementsof(FSTR,DIM)+1, \
+ sizeof(FSTR)+cfelementsof(FSTR,DIM), ' ')
+
+#define cfDEREFERENCE0
+#define cfDEREFERENCE1 *
+#define cfDEREFERENCE2 **
+#define cfDEREFERENCE3 ***
+#define cfDEREFERENCE4 ****
+#define cfDEREFERENCE5 *****
+#define cfelementsof(A,D) (sizeof(A)/sizeof(_(cfDEREFERENCE,D)(A)))
+
+/*-------------------------------------------------------------------------*/
+
+/* UTILITIES FOR C TO CALL FORTRAN SUBROUTINES */
+
+/* Define lookup tables for how to handle the various types of variables. */
+
+#ifdef OLD_VAXC /* Prevent %CC-I-PARAMNOTUSED. */
+#pragma nostandard
+#endif
+
+#define ZTRINGV_NUM(I) I
+#define ZTRINGV_ARGFP(I) (*(_2(A,I))) /* Undocumented. For PINT, etc. */
+#define ZTRINGV_ARGF(I) _2(A,I)
+#ifdef CFSUBASFUN
+#define ZTRINGV_ARGS(I) ZTRINGV_ARGF(I)
+#else
+#define ZTRINGV_ARGS(I) _2(B,I)
+#endif
+
+#define PBYTE_cfVP(A,B) PINT_cfVP(A,B)
+#define PDOUBLE_cfVP(A,B)
+#define PFLOAT_cfVP(A,B)
+#ifdef ZTRINGV_ARGS_allows_Pvariables
+/* This allows Pvariables for ARGS. ARGF machinery is above ARGFP.
+ * B is not needed because the variable may be changed by the Fortran routine,
+ * but because B is the only way to access an arbitrary macro argument. */
+#define PINT_cfVP(A,B) int B = (int)A; /* For ZSTRINGV_ARGS */
+#else
+#define PINT_cfVP(A,B)
+#endif
+#define PLOGICAL_cfVP(A,B) int *B; /* Returning LOGICAL in FUNn and SUBn */
+#define PLONG_cfVP(A,B) PINT_cfVP(A,B)
+#define PSHORT_cfVP(A,B) PINT_cfVP(A,B)
+
+#define VCF_INT_S(T,A,B) _(T,VVVVVVV_cfTYPE) B = A;
+#define VCF_INT_F(T,A,B) _(T,_cfVCF)(A,B)
+/* _cfVCF table is directly mapped to _cfCCC table. */
+#define BYTE_cfVCF(A,B)
+#define DOUBLE_cfVCF(A,B)
+#if !defined(__CF__KnR)
+#define FLOAT_cfVCF(A,B)
+#else
+#define FLOAT_cfVCF(A,B) FORTRAN_REAL B = A;
+#endif
+#define INT_cfVCF(A,B)
+#define LOGICAL_cfVCF(A,B)
+#define LONG_cfVCF(A,B)
+#define SHORT_cfVCF(A,B)
+
+/* 980416
+ Cast (void (*)(CF_NULL_PROTO)) causes SunOS CC 4.2 occasionally to barf,
+ while the following equivalent typedef is fine.
+ For consistency use the typedef on all machines.
+ */
+typedef void (*cfCAST_FUNCTION)(CF_NULL_PROTO);
+
+#define VCF(TN,I) _Icf4(4,V,TN,_(A,I),_(B,I),F)
+#define VVCF(TN,AI,BI) _Icf4(4,V,TN,AI,BI,S)
+#define INT_cfV(T,A,B,F) _(VCF_INT_,F)(T,A,B)
+#define INTV_cfV(T,A,B,F)
+#define INTVV_cfV(T,A,B,F)
+#define INTVVV_cfV(T,A,B,F)
+#define INTVVVV_cfV(T,A,B,F)
+#define INTVVVVV_cfV(T,A,B,F)
+#define INTVVVVVV_cfV(T,A,B,F)
+#define INTVVVVVVV_cfV(T,A,B,F)
+#define PINT_cfV( T,A,B,F) _(T,_cfVP)(A,B)
+#define PVOID_cfV( T,A,B,F)
+#if defined(apolloFortran) || defined(hpuxFortran800) || defined(AbsoftUNIXFortran) || defined(AbsoftProFortran)
+#define ROUTINE_cfV(T,A,B,F) void (*B)(CF_NULL_PROTO) = (cfCAST_FUNCTION)A;
+#else
+#define ROUTINE_cfV(T,A,B,F)
+#endif
+#define SIMPLE_cfV(T,A,B,F)
+#ifdef vmsFortran
+#define STRING_cfV(T,A,B,F) static struct {fstring f; unsigned clen;} B = \
+ {{0,DSC$K_DTYPE_T,DSC$K_CLASS_S,NULL},0};
+#define PSTRING_cfV(T,A,B,F) static fstring B={0,DSC$K_DTYPE_T,DSC$K_CLASS_S,NULL};
+#define STRINGV_cfV(T,A,B,F) static fstringvector B = \
+ {sizeof(A),DSC$K_DTYPE_T,DSC$K_CLASS_A,NULL,0,0,{0,0,1,1,1},1,0,NULL,0,{1,0}};
+#define PSTRINGV_cfV(T,A,B,F) static fstringvector B = \
+ {0,DSC$K_DTYPE_T,DSC$K_CLASS_A,NULL,0,0,{0,0,1,1,1},1,0,NULL,0,{1,0}};
+#else
+#define STRING_cfV(T,A,B,F) struct {unsigned int clen, flen; char *nombre;} B;
+#define STRINGV_cfV(T,A,B,F) struct {char *s, *fs; unsigned flen; char *nombre;} B;
+#define PSTRING_cfV(T,A,B,F) int B;
+#define PSTRINGV_cfV(T,A,B,F) struct{char *fs; unsigned int sizeofA,flen;}B;
+#endif
+#define ZTRINGV_cfV(T,A,B,F) STRINGV_cfV(T,A,B,F)
+#define PZTRINGV_cfV(T,A,B,F) PSTRINGV_cfV(T,A,B,F)
+
+/* Note that the actions of the A table were performed inside the AA table.
+ VAX Ultrix vcc, and HP-UX cc, didn't evaluate arguments to functions left to
+ right, so we had to split the original table into the current robust two. */
+#define ACF(NAME,TN,AI,I) _(TN,_cfSTR)(4,A,NAME,I,AI,_(B,I),0)
+#define DEFAULT_cfA(M,I,A,B)
+#define LOGICAL_cfA(M,I,A,B) B=C2FLOGICAL(B);
+#define PLOGICAL_cfA(M,I,A,B) A=C2FLOGICAL(A);
+#define STRING_cfA(M,I,A,B) STRING_cfC(M,I,A,B,sizeof(A))
+#define PSTRING_cfA(M,I,A,B) PSTRING_cfC(M,I,A,B,sizeof(A))
+#ifdef vmsFortran
+#define AATRINGV_cfA( A,B, sA,filA,silA) \
+ initfstr(B,_cf_malloc((sA)-(filA)),(filA),(silA)-1), \
+ c2fstrv(A,B.dsc$a_pointer,(silA),(sA));
+#define APATRINGV_cfA( A,B, sA,filA,silA) \
+ initfstr(B,A,(filA),(silA)-1),c2fstrv(A,A,(silA),(sA));
+#else
+#define AATRINGV_cfA( A,B, sA,filA,silA) \
+ (B.s=_cf_malloc((sA)-(filA)),B.fs=c2fstrv(A,B.s,(B.flen=(silA)-1)+1,(sA)));
+#define APATRINGV_cfA( A,B, sA,filA,silA) \
+ B.fs=c2fstrv(A,A,(B.flen=(silA)-1)+1,B.sizeofA=(sA));
+#endif
+#define STRINGV_cfA(M,I,A,B) \
+ AATRINGV_cfA((char *)A,B,sizeof(A),firstindexlength(A),secondindexlength(A))
+#define PSTRINGV_cfA(M,I,A,B) \
+ APATRINGV_cfA((char *)A,B,sizeof(A),firstindexlength(A),secondindexlength(A))
+#define ZTRINGV_cfA(M,I,A,B) AATRINGV_cfA( (char *)A,B, \
+ (_3(M,_ELEMS_,I))*(( _3(M,_ELEMLEN_,I))+1), \
+ (_3(M,_ELEMS_,I)),(_3(M,_ELEMLEN_,I))+1)
+#define PZTRINGV_cfA(M,I,A,B) APATRINGV_cfA( (char *)A,B, \
+ (_3(M,_ELEMS_,I))*(( _3(M,_ELEMLEN_,I))+1), \
+ (_3(M,_ELEMS_,I)),(_3(M,_ELEMLEN_,I))+1)
+
+#define PBYTE_cfAAP(A,B) &A
+#define PDOUBLE_cfAAP(A,B) &A
+#define PFLOAT_cfAAP(A,B) FLOATVVVVVVV_cfPP &A
+#define PINT_cfAAP(A,B) &A
+#define PLOGICAL_cfAAP(A,B) B= &A /* B used to keep a common W table. */
+#define PLONG_cfAAP(A,B) &A
+#define PSHORT_cfAAP(A,B) &A
+
+#define AACF(TN,AI,I,C) _SEP_(TN,C,cfCOMMA) _Icf(3,AA,TN,AI,_(B,I))
+#define INT_cfAA(T,A,B) &B
+#define INTV_cfAA(T,A,B) _(T,VVVVVV_cfPP) A
+#define INTVV_cfAA(T,A,B) _(T,VVVVV_cfPP) A[0]
+#define INTVVV_cfAA(T,A,B) _(T,VVVV_cfPP) A[0][0]
+#define INTVVVV_cfAA(T,A,B) _(T,VVV_cfPP) A[0][0][0]
+#define INTVVVVV_cfAA(T,A,B) _(T,VV_cfPP) A[0][0][0][0]
+#define INTVVVVVV_cfAA(T,A,B) _(T,V_cfPP) A[0][0][0][0][0]
+#define INTVVVVVVV_cfAA(T,A,B) _(T,_cfPP) A[0][0][0][0][0][0]
+#define PINT_cfAA(T,A,B) _(T,_cfAAP)(A,B)
+#define PVOID_cfAA(T,A,B) (void *) A
+#if defined(apolloFortran) || defined(hpuxFortran800) || defined(AbsoftUNIXFortran)
+#define ROUTINE_cfAA(T,A,B) &B
+#else
+#define ROUTINE_cfAA(T,A,B) (cfCAST_FUNCTION)A
+#endif
+#define STRING_cfAA(T,A,B) STRING_cfCC(T,A,B)
+#define PSTRING_cfAA(T,A,B) PSTRING_cfCC(T,A,B)
+#ifdef vmsFortran
+#define STRINGV_cfAA(T,A,B) &B
+#else
+#ifdef CRAYFortran
+#define STRINGV_cfAA(T,A,B) _cptofcd(B.fs,B.flen)
+#else
+#define STRINGV_cfAA(T,A,B) B.fs
+#endif
+#endif
+#define PSTRINGV_cfAA(T,A,B) STRINGV_cfAA(T,A,B)
+#define ZTRINGV_cfAA(T,A,B) STRINGV_cfAA(T,A,B)
+#define PZTRINGV_cfAA(T,A,B) STRINGV_cfAA(T,A,B)
+
+#if defined(vmsFortran) || defined(CRAYFortran)
+#define JCF(TN,I)
+#define KCF(TN,I)
+#else
+#define JCF(TN,I) _(TN,_cfSTR)(1,J,_(B,I), 0,0,0,0)
+#if defined(AbsoftUNIXFortran)
+#define DEFAULT_cfJ(B) ,0
+#else
+#define DEFAULT_cfJ(B)
+#endif
+#define LOGICAL_cfJ(B) DEFAULT_cfJ(B)
+#define PLOGICAL_cfJ(B) DEFAULT_cfJ(B)
+#define STRING_cfJ(B) ,B.flen
+#define PSTRING_cfJ(B) ,B
+#define STRINGV_cfJ(B) STRING_cfJ(B)
+#define PSTRINGV_cfJ(B) STRING_cfJ(B)
+#define ZTRINGV_cfJ(B) STRING_cfJ(B)
+#define PZTRINGV_cfJ(B) STRING_cfJ(B)
+
+/* KCF is identical to DCF, except that KCF ZTRING is not empty. */
+#define KCF(TN,I) _(TN,_cfSTR)(1,KK,_(B,I), 0,0,0,0)
+#if defined(AbsoftUNIXFortran)
+#define DEFAULT_cfKK(B) , unsigned B
+#else
+#define DEFAULT_cfKK(B)
+#endif
+#define LOGICAL_cfKK(B) DEFAULT_cfKK(B)
+#define PLOGICAL_cfKK(B) DEFAULT_cfKK(B)
+#define STRING_cfKK(B) , unsigned B
+#define PSTRING_cfKK(B) STRING_cfKK(B)
+#define STRINGV_cfKK(B) STRING_cfKK(B)
+#define PSTRINGV_cfKK(B) STRING_cfKK(B)
+#define ZTRINGV_cfKK(B) STRING_cfKK(B)
+#define PZTRINGV_cfKK(B) STRING_cfKK(B)
+#endif
+
+#define WCF(TN,AN,I) _(TN,_cfSTR)(2,W,AN,_(B,I), 0,0,0)
+#define DEFAULT_cfW(A,B)
+#define LOGICAL_cfW(A,B)
+#define PLOGICAL_cfW(A,B) *B=F2CLOGICAL(*B);
+#define STRING_cfW(A,B) (B.nombre=A,B.nombre[B.clen]!='\0'?B.nombre[B.clen]='\0':0); /* A?="constnt"*/
+#define PSTRING_cfW(A,B) kill_trailing(A,' ');
+#ifdef vmsFortran
+#define STRINGV_cfW(A,B) _cf_free(B.dsc$a_pointer);
+#define PSTRINGV_cfW(A,B) \
+ vkill_trailing(f2cstrv((char*)A, (char*)A, \
+ B.dsc$w_length+1, B.dsc$l_arsize+B.dsc$l_m[0]), \
+ B.dsc$w_length+1, B.dsc$l_arsize+B.dsc$l_m[0], ' ');
+#else
+#define STRINGV_cfW(A,B) _cf_free(B.s);
+#define PSTRINGV_cfW(A,B) vkill_trailing( \
+ f2cstrv((char*)A,(char*)A,B.flen+1,B.sizeofA), B.flen+1,B.sizeofA,' ');
+#endif
+#define ZTRINGV_cfW(A,B) STRINGV_cfW(A,B)
+#define PZTRINGV_cfW(A,B) PSTRINGV_cfW(A,B)
+
+#define NCF(TN,I,C) _SEP_(TN,C,cfCOMMA) _Icf(2,N,TN,_(A,I),0)
+#define NNCF(TN,I,C) UUCF(TN,I,C)
+#define NNNCF(TN,I,C) _SEP_(TN,C,cfCOLON) _Icf(2,N,TN,_(A,I),0)
+#define INT_cfN(T,A) _(T,VVVVVVV_cfTYPE) * A
+#define INTV_cfN(T,A) _(T,VVVVVV_cfTYPE) * A
+#define INTVV_cfN(T,A) _(T,VVVVV_cfTYPE) * A
+#define INTVVV_cfN(T,A) _(T,VVVV_cfTYPE) * A
+#define INTVVVV_cfN(T,A) _(T,VVV_cfTYPE) * A
+#define INTVVVVV_cfN(T,A) _(T,VV_cfTYPE) * A
+#define INTVVVVVV_cfN(T,A) _(T,V_cfTYPE) * A
+#define INTVVVVVVV_cfN(T,A) _(T,_cfTYPE) * A
+#define PINT_cfN(T,A) _(T,_cfTYPE) * A
+#define PVOID_cfN(T,A) void * A
+#if defined(apolloFortran) || defined(hpuxFortran800) || defined(AbsoftUNIXFortran)
+#define ROUTINE_cfN(T,A) void (**A)(CF_NULL_PROTO)
+#else
+#define ROUTINE_cfN(T,A) void ( *A)(CF_NULL_PROTO)
+#endif
+#ifdef vmsFortran
+#define STRING_cfN(T,A) fstring * A
+#define STRINGV_cfN(T,A) fstringvector * A
+#else
+#ifdef CRAYFortran
+#define STRING_cfN(T,A) _fcd A
+#define STRINGV_cfN(T,A) _fcd A
+#else
+#define STRING_cfN(T,A) char * A
+#define STRINGV_cfN(T,A) char * A
+#endif
+#endif
+#define PSTRING_cfN(T,A) STRING_cfN(T,A) /* CRAY insists on arg.'s here. */
+#define PNSTRING_cfN(T,A) STRING_cfN(T,A) /* CRAY insists on arg.'s here. */
+#define PPSTRING_cfN(T,A) STRING_cfN(T,A) /* CRAY insists on arg.'s here. */
+#define PSTRINGV_cfN(T,A) STRINGV_cfN(T,A)
+#define ZTRINGV_cfN(T,A) STRINGV_cfN(T,A)
+#define PZTRINGV_cfN(T,A) PSTRINGV_cfN(T,A)
+
+
+/* Apollo 6.7, CRAY, old Sun, VAX/Ultrix vcc/cc and new ultrix
+ can't hack more than 31 arg's.
+ e.g. ultrix >= 4.3 gives message:
+ zow35> cc -c -DDECFortran cfortest.c
+ cfe: Fatal: Out of memory: cfortest.c
+ zow35>
+ Old __hpux had the problem, but new 'HP-UX A.09.03 A 9000/735' is fine
+ if using -Aa, otherwise we have a problem.
+ */
+#ifndef MAX_PREPRO_ARGS
+#if !defined(__GNUC__) && (defined(VAXUltrix) || defined(__CF__APOLLO67) || (defined(sun)&&!defined(__sun)) || defined(_CRAY) || defined(__ultrix__) || (defined(__hpux)&&defined(__CF__KnR)))
+#define MAX_PREPRO_ARGS 31
+#else
+#define MAX_PREPRO_ARGS 99
+#endif
+#endif
+
+#if defined(AbsoftUNIXFortran) || defined(AbsoftProFortran)
+/* In addition to explicit Absoft stuff, only Absoft requires:
+ - DEFAULT coming from _cfSTR.
+ DEFAULT could have been called e.g. INT, but keep it for clarity.
+ - M term in CFARGT14 and CFARGT14FS.
+ */
+#define ABSOFT_cf1(T0) _(T0,_cfSTR)(0,ABSOFT1,0,0,0,0,0)
+#define ABSOFT_cf2(T0) _(T0,_cfSTR)(0,ABSOFT2,0,0,0,0,0)
+#define ABSOFT_cf3(T0) _(T0,_cfSTR)(0,ABSOFT3,0,0,0,0,0)
+#define DEFAULT_cfABSOFT1
+#define LOGICAL_cfABSOFT1
+#define STRING_cfABSOFT1 ,MAX_LEN_FORTRAN_FUNCTION_STRING
+#define DEFAULT_cfABSOFT2
+#define LOGICAL_cfABSOFT2
+#define STRING_cfABSOFT2 ,unsigned D0
+#define DEFAULT_cfABSOFT3
+#define LOGICAL_cfABSOFT3
+#define STRING_cfABSOFT3 ,D0
+#else
+#define ABSOFT_cf1(T0)
+#define ABSOFT_cf2(T0)
+#define ABSOFT_cf3(T0)
+#endif
+
+/* _Z introduced to cicumvent IBM and HP silly preprocessor warning.
+ e.g. "Macro CFARGT14 invoked with a null argument."
+ */
+#define _Z
+
+#define CFARGT14S(S,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE) \
+ S(T1,1) S(T2,2) S(T3,3) S(T4,4) S(T5,5) S(T6,6) S(T7,7) \
+ S(T8,8) S(T9,9) S(TA,10) S(TB,11) S(TC,12) S(TD,13) S(TE,14)
+#define CFARGT27S(S,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,TP,TQ,TR) \
+ S(T1,1) S(T2,2) S(T3,3) S(T4,4) S(T5,5) S(T6,6) S(T7,7) \
+ S(T8,8) S(T9,9) S(TA,10) S(TB,11) S(TC,12) S(TD,13) S(TE,14) \
+ S(TF,15) S(TG,16) S(TH,17) S(TI,18) S(TJ,19) S(TK,20) S(TL,21) \
+ S(TM,22) S(TN,23) S(TO,24) S(TP,25) S(TQ,26) S(TR,27)
+
+#define CFARGT14FS(F,S,M,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE) \
+ F(T1,1,0) F(T2,2,1) F(T3,3,1) F(T4,4,1) F(T5,5,1) F(T6,6,1) F(T7,7,1) \
+ F(T8,8,1) F(T9,9,1) F(TA,10,1) F(TB,11,1) F(TC,12,1) F(TD,13,1) F(TE,14,1) \
+ M CFARGT14S(S,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE)
+#define CFARGT27FS(F,S,M,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,TP,TQ,TR) \
+ F(T1,1,0) F(T2,2,1) F(T3,3,1) F(T4,4,1) F(T5,5,1) F(T6,6,1) F(T7,7,1) \
+ F(T8,8,1) F(T9,9,1) F(TA,10,1) F(TB,11,1) F(TC,12,1) F(TD,13,1) F(TE,14,1) \
+ F(TF,15,1) F(TG,16,1) F(TH,17,1) F(TI,18,1) F(TJ,19,1) F(TK,20,1) F(TL,21,1) \
+ F(TM,22,1) F(TN,23,1) F(TO,24,1) F(TP,25,1) F(TQ,26,1) F(TR,27,1) \
+ M CFARGT27S(S,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,TP,TQ,TR)
+
+#if !(defined(PowerStationFortran)||defined(hpuxFortran800))
+/* Old CFARGT14 -> CFARGT14FS as seen below, for Absoft cross-compile yields:
+ SunOS> cc -c -Xa -DAbsoftUNIXFortran c.c
+ "c.c", line 406: warning: argument mismatch
+ Haven't checked if this is ANSI C or a SunOS bug. SunOS -Xs works ok.
+ Behavior is most clearly seen in example:
+ #define A 1 , 2
+ #define C(X,Y,Z) x=X. y=Y. z=Z.
+ #define D(X,Y,Z) C(X,Y,Z)
+ D(x,A,z)
+ Output from preprocessor is: x = x . y = 1 . z = 2 .
+ #define CFARGT14(F,S,M,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE) \
+ CFARGT14FS(F,S,M,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE)
+*/
+#define CFARGT14(F,S,M,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE) \
+ F(T1,1,0) F(T2,2,1) F(T3,3,1) F(T4,4,1) F(T5,5,1) F(T6,6,1) F(T7,7,1) \
+ F(T8,8,1) F(T9,9,1) F(TA,10,1) F(TB,11,1) F(TC,12,1) F(TD,13,1) F(TE,14,1) \
+ M CFARGT14S(S,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE)
+#define CFARGT27(F,S,M,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,TP,TQ,TR) \
+ F(T1,1,0) F(T2,2,1) F(T3,3,1) F(T4,4,1) F(T5,5,1) F(T6,6,1) F(T7,7,1) \
+ F(T8,8,1) F(T9,9,1) F(TA,10,1) F(TB,11,1) F(TC,12,1) F(TD,13,1) F(TE,14,1) \
+ F(TF,15,1) F(TG,16,1) F(TH,17,1) F(TI,18,1) F(TJ,19,1) F(TK,20,1) F(TL,21,1) \
+ F(TM,22,1) F(TN,23,1) F(TO,24,1) F(TP,25,1) F(TQ,26,1) F(TR,27,1) \
+ M CFARGT27S(S,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,TP,TQ,TR)
+
+#define CFARGT20(F,S,M,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK) \
+ F(T1,1,0) F(T2,2,1) F(T3,3,1) F(T4,4,1) F(T5,5,1) F(T6,6,1) F(T7,7,1) \
+ F(T8,8,1) F(T9,9,1) F(TA,10,1) F(TB,11,1) F(TC,12,1) F(TD,13,1) F(TE,14,1) \
+ F(TF,15,1) F(TG,16,1) F(TH,17,1) F(TI,18,1) F(TJ,19,1) F(TK,20,1) \
+ S(T1,1) S(T2,2) S(T3,3) S(T4,4) S(T5,5) S(T6,6) S(T7,7) \
+ S(T8,8) S(T9,9) S(TA,10) S(TB,11) S(TC,12) S(TD,13) S(TE,14) \
+ S(TF,15) S(TG,16) S(TH,17) S(TI,18) S(TJ,19) S(TK,20)
+#define CFARGTA14(F,S,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,AD,AE) \
+ F(T1,A1,1,0) F(T2,A2,2,1) F(T3,A3,3,1) F(T4,A4,4,1) F(T5,A5,5,1) F(T6,A6,6,1) \
+ F(T7,A7,7,1) F(T8,A8,8,1) F(T9,A9,9,1) F(TA,AA,10,1) F(TB,AB,11,1) F(TC,AC,12,1) \
+ F(TD,AD,13,1) F(TE,AE,14,1) S(T1,1) S(T2,2) S(T3,3) S(T4,4) \
+ S(T5,5) S(T6,6) S(T7,7) S(T8,8) S(T9,9) S(TA,10) \
+ S(TB,11) S(TC,12) S(TD,13) S(TE,14)
+#if MAX_PREPRO_ARGS>31
+#define CFARGTA20(F,S,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,AD,AE,AF,AG,AH,AI,AJ,AK) \
+ F(T1,A1,1,0) F(T2,A2,2,1) F(T3,A3,3,1) F(T4,A4,4,1) F(T5,A5,5,1) F(T6,A6,6,1) \
+ F(T7,A7,7,1) F(T8,A8,8,1) F(T9,A9,9,1) F(TA,AA,10,1) F(TB,AB,11,1) F(TC,AC,12,1) \
+ F(TD,AD,13,1) F(TE,AE,14,1) F(TF,AF,15,1) F(TG,AG,16,1) F(TH,AH,17,1) F(TI,AI,18,1) \
+ F(TJ,AJ,19,1) F(TK,AK,20,1) S(T1,1) S(T2,2) S(T3,3) S(T4,4) \
+ S(T5,5) S(T6,6) S(T7,7) S(T8,8) S(T9,9) S(TA,10) \
+ S(TB,11) S(TC,12) S(TD,13) S(TE,14) S(TF,15) S(TG,16) \
+ S(TH,17) S(TI,18) S(TJ,19) S(TK,20)
+#define CFARGTA27(F,S,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,TP,TQ,TR,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,AD,AE,AF,AG,AH,AI,AJ,AK,AL,AM,AN,AO,AP,AQ,AR) \
+ F(T1,A1,1,0) F(T2,A2,2,1) F(T3,A3,3,1) F(T4,A4,4,1) F(T5,A5,5,1) F(T6,A6,6,1) \
+ F(T7,A7,7,1) F(T8,A8,8,1) F(T9,A9,9,1) F(TA,AA,10,1) F(TB,AB,11,1) F(TC,AC,12,1) \
+ F(TD,AD,13,1) F(TE,AE,14,1) F(TF,AF,15,1) F(TG,AG,16,1) F(TH,AH,17,1) F(TI,AI,18,1) \
+ F(TJ,AJ,19,1) F(TK,AK,20,1) F(TL,AL,21,1) F(TM,AM,22,1) F(TN,AN,23,1) F(TO,AO,24,1) \
+ F(TP,AP,25,1) F(TQ,AQ,26,1) F(TR,AR,27,1) S(T1,1) S(T2,2) S(T3,3) \
+ S(T4,4) S(T5,5) S(T6,6) S(T7,7) S(T8,8) S(T9,9) \
+ S(TA,10) S(TB,11) S(TC,12) S(TD,13) S(TE,14) S(TF,15) \
+ S(TG,16) S(TH,17) S(TI,18) S(TJ,19) S(TK,20) S(TL,21) \
+ S(TM,22) S(TN,23) S(TO,24) S(TP,25) S(TQ,26) S(TR,27)
+#endif
+#else
+#define CFARGT14(F,S,M,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE) \
+ F(T1,1,0) S(T1,1) F(T2,2,1) S(T2,2) F(T3,3,1) S(T3,3) F(T4,4,1) S(T4,4) \
+ F(T5,5,1) S(T5,5) F(T6,6,1) S(T6,6) F(T7,7,1) S(T7,7) F(T8,8,1) S(T8,8) \
+ F(T9,9,1) S(T9,9) F(TA,10,1) S(TA,10) F(TB,11,1) S(TB,11) F(TC,12,1) S(TC,12) \
+ F(TD,13,1) S(TD,13) F(TE,14,1) S(TE,14)
+#define CFARGT27(F,S,M,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,TP,TQ,TR) \
+ F(T1,1,0) S(T1,1) F(T2,2,1) S(T2,2) F(T3,3,1) S(T3,3) F(T4,4,1) S(T4,4) \
+ F(T5,5,1) S(T5,5) F(T6,6,1) S(T6,6) F(T7,7,1) S(T7,7) F(T8,8,1) S(T8,8) \
+ F(T9,9,1) S(T9,9) F(TA,10,1) S(TA,10) F(TB,11,1) S(TB,11) F(TC,12,1) S(TC,12) \
+ F(TD,13,1) S(TD,13) F(TE,14,1) S(TE,14) F(TF,15,1) S(TF,15) F(TG,16,1) S(TG,16) \
+ F(TH,17,1) S(TH,17) F(TI,18,1) S(TI,18) F(TJ,19,1) S(TJ,19) F(TK,20,1) S(TK,20) \
+ F(TL,21,1) S(TL,21) F(TM,22,1) S(TM,22) F(TN,23,1) S(TN,23) F(TO,24,1) S(TO,24) \
+ F(TP,25,1) S(TP,25) F(TQ,26,1) S(TQ,26) F(TR,27,1) S(TR,27)
+
+#define CFARGT20(F,S,M,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK) \
+ F(T1,1,0) S(T1,1) F(T2,2,1) S(T2,2) F(T3,3,1) S(T3,3) F(T4,4,1) S(T4,4) \
+ F(T5,5,1) S(T5,5) F(T6,6,1) S(T6,6) F(T7,7,1) S(T7,7) F(T8,8,1) S(T8,8) \
+ F(T9,9,1) S(T9,9) F(TA,10,1) S(TA,10) F(TB,11,1) S(TB,11) F(TC,12,1) S(TC,12) \
+ F(TD,13,1) S(TD,13) F(TE,14,1) S(TE,14) F(TF,15,1) S(TF,15) F(TG,16,1) S(TG,16) \
+ F(TH,17,1) S(TH,17) F(TI,18,1) S(TI,18) F(TJ,19,1) S(TJ,19) F(TK,20,1) S(TK,20)
+#define CFARGTA14(F,S,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,AD,AE) \
+ F(T1,A1,1,0) S(T1,1) F(T2,A2,2,1) S(T2,2) F(T3,A3,3,1) S(T3,3) \
+ F(T4,A4,4,1) S(T4,4) F(T5,A5,5,1) S(T5,5) F(T6,A6,6,1) S(T6,6) \
+ F(T7,A7,7,1) S(T7,7) F(T8,A8,8,1) S(T8,8) F(T9,A9,9,1) S(T9,9) \
+ F(TA,AA,10,1) S(TA,10) F(TB,AB,11,1) S(TB,11) F(TC,AC,12,1) S(TC,12) \
+ F(TD,AD,13,1) S(TD,13) F(TE,AE,14,1) S(TE,14)
+#if MAX_PREPRO_ARGS>31
+#define CFARGTA20(F,S,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,AD,AE,AF,AG,AH,AI,AJ,AK) \
+ F(T1,A1,1,0) S(T1,1) F(T2,A2,2,1) S(T2,2) F(T3,A3,3,1) S(T3,3) \
+ F(T4,A4,4,1) S(T4,4) F(T5,A5,5,1) S(T5,5) F(T6,A6,6,1) S(T6,6) \
+ F(T7,A7,7,1) S(T7,7) F(T8,A8,8,1) S(T8,8) F(T9,A9,9,1) S(T9,9) \
+ F(TA,AA,10,1) S(TA,10) F(TB,AB,11,1) S(TB,11) F(TC,AC,12,1) S(TC,12) \
+ F(TD,AD,13,1) S(TD,13) F(TE,AE,14,1) S(TE,14) F(TF,AF,15,1) S(TF,15) \
+ F(TG,AG,16,1) S(TG,16) F(TH,AH,17,1) S(TH,17) F(TI,AI,18,1) S(TI,18) \
+ F(TJ,AJ,19,1) S(TJ,19) F(TK,AK,20,1) S(TK,20)
+#define CFARGTA27(F,S,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,TP,TQ,TR,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,AD,AE,AF,AG,AH,AI,AJ,AK,AL,AM,AN,AO,AP,AQ,AR) \
+ F(T1,A1,1,0) S(T1,1) F(T2,A2,2,1) S(T2,2) F(T3,A3,3,1) S(T3,3) \
+ F(T4,A4,4,1) S(T4,4) F(T5,A5,5,1) S(T5,5) F(T6,A6,6,1) S(T6,6) \
+ F(T7,A7,7,1) S(T7,7) F(T8,A8,8,1) S(T8,8) F(T9,A9,9,1) S(T9,9) \
+ F(TA,AA,10,1) S(TA,10) F(TB,AB,11,1) S(TB,11) F(TC,AC,12,1) S(TC,12) \
+ F(TD,AD,13,1) S(TD,13) F(TE,AE,14,1) S(TE,14) F(TF,AF,15,1) S(TF,15) \
+ F(TG,AG,16,1) S(TG,16) F(TH,AH,17,1) S(TH,17) F(TI,AI,18,1) S(TI,18) \
+ F(TJ,AJ,19,1) S(TJ,19) F(TK,AK,20,1) S(TK,20) F(TL,AL,21,1) S(TL,21) \
+ F(TM,AM,22,1) S(TM,22) F(TN,AN,23,1) S(TN,23) F(TO,AO,24,1) S(TO,24) \
+ F(TP,AP,25,1) S(TP,25) F(TQ,AQ,26,1) S(TQ,26) F(TR,AR,27,1) S(TR,27)
+#endif
+#endif
+
+
+#define PROTOCCALLSFSUB1( UN,LN,T1) \
+ PROTOCCALLSFSUB14(UN,LN,T1,CF_0,CF_0,CF_0,CF_0,CF_0,CF_0,CF_0,CF_0,CF_0,CF_0,CF_0,CF_0,CF_0)
+#define PROTOCCALLSFSUB2( UN,LN,T1,T2) \
+ PROTOCCALLSFSUB14(UN,LN,T1,T2,CF_0,CF_0,CF_0,CF_0,CF_0,CF_0,CF_0,CF_0,CF_0,CF_0,CF_0,CF_0)
+#define PROTOCCALLSFSUB3( UN,LN,T1,T2,T3) \
+ PROTOCCALLSFSUB14(UN,LN,T1,T2,T3,CF_0,CF_0,CF_0,CF_0,CF_0,CF_0,CF_0,CF_0,CF_0,CF_0,CF_0)
+#define PROTOCCALLSFSUB4( UN,LN,T1,T2,T3,T4) \
+ PROTOCCALLSFSUB14(UN,LN,T1,T2,T3,T4,CF_0,CF_0,CF_0,CF_0,CF_0,CF_0,CF_0,CF_0,CF_0,CF_0)
+#define PROTOCCALLSFSUB5( UN,LN,T1,T2,T3,T4,T5) \
+ PROTOCCALLSFSUB14(UN,LN,T1,T2,T3,T4,T5,CF_0,CF_0,CF_0,CF_0,CF_0,CF_0,CF_0,CF_0,CF_0)
+#define PROTOCCALLSFSUB6( UN,LN,T1,T2,T3,T4,T5,T6) \
+ PROTOCCALLSFSUB14(UN,LN,T1,T2,T3,T4,T5,T6,CF_0,CF_0,CF_0,CF_0,CF_0,CF_0,CF_0,CF_0)
+#define PROTOCCALLSFSUB7( UN,LN,T1,T2,T3,T4,T5,T6,T7) \
+ PROTOCCALLSFSUB14(UN,LN,T1,T2,T3,T4,T5,T6,T7,CF_0,CF_0,CF_0,CF_0,CF_0,CF_0,CF_0)
+#define PROTOCCALLSFSUB8( UN,LN,T1,T2,T3,T4,T5,T6,T7,T8) \
+ PROTOCCALLSFSUB14(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,CF_0,CF_0,CF_0,CF_0,CF_0,CF_0)
+#define PROTOCCALLSFSUB9( UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9) \
+ PROTOCCALLSFSUB14(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,CF_0,CF_0,CF_0,CF_0,CF_0)
+#define PROTOCCALLSFSUB10(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA) \
+ PROTOCCALLSFSUB14(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,CF_0,CF_0,CF_0,CF_0)
+#define PROTOCCALLSFSUB11(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB) \
+ PROTOCCALLSFSUB14(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,CF_0,CF_0,CF_0)
+#define PROTOCCALLSFSUB12(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC) \
+ PROTOCCALLSFSUB14(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,CF_0,CF_0)
+#define PROTOCCALLSFSUB13(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD) \
+ PROTOCCALLSFSUB14(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,CF_0)
+
+
+#define PROTOCCALLSFSUB15(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF) \
+ PROTOCCALLSFSUB20(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,CF_0,CF_0,CF_0,CF_0,CF_0)
+#define PROTOCCALLSFSUB16(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG) \
+ PROTOCCALLSFSUB20(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,CF_0,CF_0,CF_0,CF_0)
+#define PROTOCCALLSFSUB17(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH) \
+ PROTOCCALLSFSUB20(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,CF_0,CF_0,CF_0)
+#define PROTOCCALLSFSUB18(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI) \
+ PROTOCCALLSFSUB20(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,CF_0,CF_0)
+#define PROTOCCALLSFSUB19(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ) \
+ PROTOCCALLSFSUB20(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,CF_0)
+
+#define PROTOCCALLSFSUB21(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL) \
+ PROTOCCALLSFSUB27(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,CF_0,CF_0,CF_0,CF_0,CF_0,CF_0)
+#define PROTOCCALLSFSUB22(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM) \
+ PROTOCCALLSFSUB27(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,CF_0,CF_0,CF_0,CF_0,CF_0)
+#define PROTOCCALLSFSUB23(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN) \
+ PROTOCCALLSFSUB27(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,CF_0,CF_0,CF_0,CF_0)
+#define PROTOCCALLSFSUB24(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO) \
+ PROTOCCALLSFSUB27(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,CF_0,CF_0,CF_0)
+#define PROTOCCALLSFSUB25(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,TP) \
+ PROTOCCALLSFSUB27(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,TP,CF_0,CF_0)
+#define PROTOCCALLSFSUB26(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,TP,TQ) \
+ PROTOCCALLSFSUB27(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,TP,TQ,CF_0)
+
+
+#ifndef FCALLSC_QUALIFIER
+#ifdef VISUAL_CPLUSPLUS
+#define FCALLSC_QUALIFIER __stdcall
+#else
+#define FCALLSC_QUALIFIER
+#endif
+#endif
+
+#ifdef __cplusplus
+#define CFextern extern "C"
+#else
+#define CFextern extern
+#endif
+
+
+#ifdef CFSUBASFUN
+#define PROTOCCALLSFSUB0(UN,LN) \
+ PROTOCCALLSFFUN0( VOID,UN,LN)
+#define PROTOCCALLSFSUB14(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE) \
+ PROTOCCALLSFFUN14(VOID,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE)
+#define PROTOCCALLSFSUB20(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK)\
+ PROTOCCALLSFFUN20(VOID,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK)
+#define PROTOCCALLSFSUB27(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,TP,TQ,TR)\
+ PROTOCCALLSFFUN27(VOID,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,TP,TQ,TR)
+#else
+/* Note: Prevent compiler warnings, null #define PROTOCCALLSFSUB14/20 after
+ #include-ing cfortran.h if calling the FORTRAN wrapper within the same
+ source code where the wrapper is created. */
+#define PROTOCCALLSFSUB0(UN,LN) _(VOID,_cfPU)(CFC_(UN,LN))();
+#ifndef __CF__KnR
+#define PROTOCCALLSFSUB14(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE) \
+ _(VOID,_cfPU)(CFC_(UN,LN))( CFARGT14(NCF,KCF,_Z,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE) );
+#define PROTOCCALLSFSUB20(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK)\
+ _(VOID,_cfPU)(CFC_(UN,LN))( CFARGT20(NCF,KCF,_Z,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK) );
+#define PROTOCCALLSFSUB27(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,TP,TQ,TR)\
+ _(VOID,_cfPU)(CFC_(UN,LN))( CFARGT27(NCF,KCF,_Z,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,TP,TQ,TR) );
+#else
+#define PROTOCCALLSFSUB14(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE) \
+ PROTOCCALLSFSUB0(UN,LN)
+#define PROTOCCALLSFSUB20(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK) \
+ PROTOCCALLSFSUB0(UN,LN)
+#define PROTOCCALLSFSUB27(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,TP,TQ,TR) \
+ PROTOCCALLSFSUB0(UN,LN)
+#endif
+#endif
+
+
+#ifdef OLD_VAXC /* Allow %CC-I-PARAMNOTUSED. */
+#pragma standard
+#endif
+
+
+#define CCALLSFSUB1( UN,LN,T1, A1) \
+ CCALLSFSUB5 (UN,LN,T1,CF_0,CF_0,CF_0,CF_0,A1,0,0,0,0)
+#define CCALLSFSUB2( UN,LN,T1,T2, A1,A2) \
+ CCALLSFSUB5 (UN,LN,T1,T2,CF_0,CF_0,CF_0,A1,A2,0,0,0)
+#define CCALLSFSUB3( UN,LN,T1,T2,T3, A1,A2,A3) \
+ CCALLSFSUB5 (UN,LN,T1,T2,T3,CF_0,CF_0,A1,A2,A3,0,0)
+#define CCALLSFSUB4( UN,LN,T1,T2,T3,T4, A1,A2,A3,A4)\
+ CCALLSFSUB5 (UN,LN,T1,T2,T3,T4,CF_0,A1,A2,A3,A4,0)
+#define CCALLSFSUB5( UN,LN,T1,T2,T3,T4,T5, A1,A2,A3,A4,A5) \
+ CCALLSFSUB10(UN,LN,T1,T2,T3,T4,T5,CF_0,CF_0,CF_0,CF_0,CF_0,A1,A2,A3,A4,A5,0,0,0,0,0)
+#define CCALLSFSUB6( UN,LN,T1,T2,T3,T4,T5,T6, A1,A2,A3,A4,A5,A6) \
+ CCALLSFSUB10(UN,LN,T1,T2,T3,T4,T5,T6,CF_0,CF_0,CF_0,CF_0,A1,A2,A3,A4,A5,A6,0,0,0,0)
+#define CCALLSFSUB7( UN,LN,T1,T2,T3,T4,T5,T6,T7, A1,A2,A3,A4,A5,A6,A7) \
+ CCALLSFSUB10(UN,LN,T1,T2,T3,T4,T5,T6,T7,CF_0,CF_0,CF_0,A1,A2,A3,A4,A5,A6,A7,0,0,0)
+#define CCALLSFSUB8( UN,LN,T1,T2,T3,T4,T5,T6,T7,T8, A1,A2,A3,A4,A5,A6,A7,A8) \
+ CCALLSFSUB10(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,CF_0,CF_0,A1,A2,A3,A4,A5,A6,A7,A8,0,0)
+#define CCALLSFSUB9( UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,A1,A2,A3,A4,A5,A6,A7,A8,A9)\
+ CCALLSFSUB10(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,CF_0,A1,A2,A3,A4,A5,A6,A7,A8,A9,0)
+#define CCALLSFSUB10(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA)\
+ CCALLSFSUB14(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,CF_0,CF_0,CF_0,CF_0,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,0,0,0,0)
+#define CCALLSFSUB11(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB)\
+ CCALLSFSUB14(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,CF_0,CF_0,CF_0,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,0,0,0)
+#define CCALLSFSUB12(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC)\
+ CCALLSFSUB14(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,CF_0,CF_0,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,0,0)
+#define CCALLSFSUB13(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,AD)\
+ CCALLSFSUB14(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,CF_0,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,AD,0)
+
+#ifdef __cplusplus
+#define CPPPROTOCLSFSUB0( UN,LN)
+#define CPPPROTOCLSFSUB14(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE)
+#define CPPPROTOCLSFSUB20(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK)
+#define CPPPROTOCLSFSUB27(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,TP,TQ,TR)
+#else
+#define CPPPROTOCLSFSUB0(UN,LN) \
+ PROTOCCALLSFSUB0(UN,LN)
+#define CPPPROTOCLSFSUB14(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE) \
+ PROTOCCALLSFSUB14(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE)
+#define CPPPROTOCLSFSUB20(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK) \
+ PROTOCCALLSFSUB20(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK)
+#define CPPPROTOCLSFSUB27(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,TP,TQ,TR) \
+ PROTOCCALLSFSUB27(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,TP,TQ,TR)
+#endif
+
+#ifdef CFSUBASFUN
+#define CCALLSFSUB0(UN,LN) CCALLSFFUN0(UN,LN)
+#define CCALLSFSUB14(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,AD,AE)\
+ CCALLSFFUN14(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,AD,AE)
+#else
+/* do{...}while(0) allows if(a==b) FORT(); else BORT(); */
+#define CCALLSFSUB0( UN,LN) do{CPPPROTOCLSFSUB0(UN,LN) CFC_(UN,LN)();}while(0)
+#define CCALLSFSUB14(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,AD,AE)\
+do{VVCF(T1,A1,B1) VVCF(T2,A2,B2) VVCF(T3,A3,B3) VVCF(T4,A4,B4) VVCF(T5,A5,B5) \
+ VVCF(T6,A6,B6) VVCF(T7,A7,B7) VVCF(T8,A8,B8) VVCF(T9,A9,B9) VVCF(TA,AA,B10) \
+ VVCF(TB,AB,B11) VVCF(TC,AC,B12) VVCF(TD,AD,B13) VVCF(TE,AE,B14) \
+ CPPPROTOCLSFSUB14(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE) \
+ ACF(LN,T1,A1,1) ACF(LN,T2,A2,2) ACF(LN,T3,A3,3) \
+ ACF(LN,T4,A4,4) ACF(LN,T5,A5,5) ACF(LN,T6,A6,6) ACF(LN,T7,A7,7) \
+ ACF(LN,T8,A8,8) ACF(LN,T9,A9,9) ACF(LN,TA,AA,10) ACF(LN,TB,AB,11) \
+ ACF(LN,TC,AC,12) ACF(LN,TD,AD,13) ACF(LN,TE,AE,14) \
+ CFC_(UN,LN)( CFARGTA14(AACF,JCF,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,AD,AE) );\
+ WCF(T1,A1,1) WCF(T2,A2,2) WCF(T3,A3,3) WCF(T4,A4,4) WCF(T5,A5,5) \
+ WCF(T6,A6,6) WCF(T7,A7,7) WCF(T8,A8,8) WCF(T9,A9,9) WCF(TA,AA,10) \
+ WCF(TB,AB,11) WCF(TC,AC,12) WCF(TD,AD,13) WCF(TE,AE,14) }while(0)
+#endif
+
+
+#if MAX_PREPRO_ARGS>31
+#define CCALLSFSUB15(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,AD,AE,AF)\
+ CCALLSFSUB20(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,CF_0,CF_0,CF_0,CF_0,CF_0,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,AD,AE,AF,0,0,0,0,0)
+#define CCALLSFSUB16(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,AD,AE,AF,AG)\
+ CCALLSFSUB20(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,CF_0,CF_0,CF_0,CF_0,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,AD,AE,AF,AG,0,0,0,0)
+#define CCALLSFSUB17(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,AD,AE,AF,AG,AH)\
+ CCALLSFSUB20(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,CF_0,CF_0,CF_0,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,AD,AE,AF,AG,AH,0,0,0)
+#define CCALLSFSUB18(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,AD,AE,AF,AG,AH,AI)\
+ CCALLSFSUB20(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,CF_0,CF_0,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,AD,AE,AF,AG,AH,AI,0,0)
+#define CCALLSFSUB19(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,AD,AE,AF,AG,AH,AI,AJ)\
+ CCALLSFSUB20(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,CF_0,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,AD,AE,AF,AG,AH,AI,AJ,0)
+
+#ifdef CFSUBASFUN
+#define CCALLSFSUB20(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH, \
+ TI,TJ,TK, A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,AD,AE,AF,AG,AH,AI,AJ,AK) \
+ CCALLSFFUN20(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH, \
+ TI,TJ,TK, A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,AD,AE,AF,AG,AH,AI,AJ,AK)
+#else
+#define CCALLSFSUB20(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH, \
+ TI,TJ,TK, A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,AD,AE,AF,AG,AH,AI,AJ,AK) \
+do{VVCF(T1,A1,B1) VVCF(T2,A2,B2) VVCF(T3,A3,B3) VVCF(T4,A4,B4) VVCF(T5,A5,B5) \
+ VVCF(T6,A6,B6) VVCF(T7,A7,B7) VVCF(T8,A8,B8) VVCF(T9,A9,B9) VVCF(TA,AA,B10) \
+ VVCF(TB,AB,B11) VVCF(TC,AC,B12) VVCF(TD,AD,B13) VVCF(TE,AE,B14) VVCF(TF,AF,B15) \
+ VVCF(TG,AG,B16) VVCF(TH,AH,B17) VVCF(TI,AI,B18) VVCF(TJ,AJ,B19) VVCF(TK,AK,B20) \
+ CPPPROTOCLSFSUB20(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK) \
+ ACF(LN,T1,A1,1) ACF(LN,T2,A2,2) ACF(LN,T3,A3,3) ACF(LN,T4,A4,4) \
+ ACF(LN,T5,A5,5) ACF(LN,T6,A6,6) ACF(LN,T7,A7,7) ACF(LN,T8,A8,8) \
+ ACF(LN,T9,A9,9) ACF(LN,TA,AA,10) ACF(LN,TB,AB,11) ACF(LN,TC,AC,12) \
+ ACF(LN,TD,AD,13) ACF(LN,TE,AE,14) ACF(LN,TF,AF,15) ACF(LN,TG,AG,16) \
+ ACF(LN,TH,AH,17) ACF(LN,TI,AI,18) ACF(LN,TJ,AJ,19) ACF(LN,TK,AK,20) \
+ CFC_(UN,LN)( CFARGTA20(AACF,JCF,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,AD,AE,AF,AG,AH,AI,AJ,AK) ); \
+ WCF(T1,A1,1) WCF(T2,A2,2) WCF(T3,A3,3) WCF(T4,A4,4) WCF(T5,A5,5) WCF(T6,A6,6) \
+ WCF(T7,A7,7) WCF(T8,A8,8) WCF(T9,A9,9) WCF(TA,AA,10) WCF(TB,AB,11) WCF(TC,AC,12) \
+ WCF(TD,AD,13) WCF(TE,AE,14) WCF(TF,AF,15) WCF(TG,AG,16) WCF(TH,AH,17) WCF(TI,AI,18) \
+ WCF(TJ,AJ,19) WCF(TK,AK,20) }while(0)
+#endif
+#endif /* MAX_PREPRO_ARGS */
+
+#if MAX_PREPRO_ARGS>31
+#define CCALLSFSUB21(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,AD,AE,AF,AG,AH,AI,AJ,AK,AL)\
+ CCALLSFSUB27(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,CF_0,CF_0,CF_0,CF_0,CF_0,CF_0,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,AD,AE,AF,AG,AH,AI,AJ,AK,AL,0,0,0,0,0,0)
+#define CCALLSFSUB22(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,AD,AE,AF,AG,AH,AI,AJ,AK,AL,AM)\
+ CCALLSFSUB27(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,CF_0,CF_0,CF_0,CF_0,CF_0,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,AD,AE,AF,AG,AH,AI,AJ,AK,AL,AM,0,0,0,0,0)
+#define CCALLSFSUB23(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,AD,AE,AF,AG,AH,AI,AJ,AK,AL,AM,AN)\
+ CCALLSFSUB27(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,CF_0,CF_0,CF_0,CF_0,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,AD,AE,AF,AG,AH,AI,AJ,AK,AL,AM,AN,0,0,0,0)
+#define CCALLSFSUB24(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,AD,AE,AF,AG,AH,AI,AJ,AK,AL,AM,AN,AO)\
+ CCALLSFSUB27(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,CF_0,CF_0,CF_0,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,AD,AE,AF,AG,AH,AI,AJ,AK,AL,AM,AN,AO,0,0,0)
+#define CCALLSFSUB25(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,TP,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,AD,AE,AF,AG,AH,AI,AJ,AK,AL,AM,AN,AO,AP)\
+ CCALLSFSUB27(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,TP,CF_0,CF_0,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,AD,AE,AF,AG,AH,AI,AJ,AK,AL,AM,AN,AO,AP,0,0)
+#define CCALLSFSUB26(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,TP,TQ,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,AD,AE,AF,AG,AH,AI,AJ,AK,AL,AM,AN,AO,AP,AQ)\
+ CCALLSFSUB27(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,TP,TQ,CF_0,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,AD,AE,AF,AG,AH,AI,AJ,AK,AL,AM,AN,AO,AP,AQ,0)
+
+#ifdef CFSUBASFUN
+#define CCALLSFSUB27(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,TP,TQ,TR, \
+ A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,AD,AE,AF,AG,AH,AI,AJ,AK,AL,AM,AN,AO,AP,AQ,AR) \
+ CCALLSFFUN27(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,TP,TQ,TR, \
+ A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,AD,AE,AF,AG,AH,AI,AJ,AK,AL,AM,AN,AO,AP,AQ,AR)
+#else
+#define CCALLSFSUB27(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,TP,TQ,TR, \
+ A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,AD,AE,AF,AG,AH,AI,AJ,AK,AL,AM,AN,AO,AP,AQ,AR) \
+do{VVCF(T1,A1,B1) VVCF(T2,A2,B2) VVCF(T3,A3,B3) VVCF(T4,A4,B4) VVCF(T5,A5,B5) \
+ VVCF(T6,A6,B6) VVCF(T7,A7,B7) VVCF(T8,A8,B8) VVCF(T9,A9,B9) VVCF(TA,AA,B10) \
+ VVCF(TB,AB,B11) VVCF(TC,AC,B12) VVCF(TD,AD,B13) VVCF(TE,AE,B14) VVCF(TF,AF,B15) \
+ VVCF(TG,AG,B16) VVCF(TH,AH,B17) VVCF(TI,AI,B18) VVCF(TJ,AJ,B19) VVCF(TK,AK,B20) \
+ VVCF(TL,AL,B21) VVCF(TM,AM,B22) VVCF(TN,AN,B23) VVCF(TO,AO,B24) VVCF(TP,AP,B25) \
+ VVCF(TQ,AQ,B26) VVCF(TR,AR,B27) \
+ CPPPROTOCLSFSUB27(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,TP,TQ,TR) \
+ ACF(LN,T1,A1,1) ACF(LN,T2,A2,2) ACF(LN,T3,A3,3) ACF(LN,T4,A4,4) \
+ ACF(LN,T5,A5,5) ACF(LN,T6,A6,6) ACF(LN,T7,A7,7) ACF(LN,T8,A8,8) \
+ ACF(LN,T9,A9,9) ACF(LN,TA,AA,10) ACF(LN,TB,AB,11) ACF(LN,TC,AC,12) \
+ ACF(LN,TD,AD,13) ACF(LN,TE,AE,14) ACF(LN,TF,AF,15) ACF(LN,TG,AG,16) \
+ ACF(LN,TH,AH,17) ACF(LN,TI,AI,18) ACF(LN,TJ,AJ,19) ACF(LN,TK,AK,20) \
+ ACF(LN,TL,AL,21) ACF(LN,TM,AM,22) ACF(LN,TN,AN,23) ACF(LN,TO,AO,24) \
+ ACF(LN,TP,AP,25) ACF(LN,TQ,AQ,26) ACF(LN,TR,AR,27) \
+ CFC_(UN,LN)( CFARGTA27(AACF,JCF,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,TP,TQ,TR,\
+ A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,AD,AE,AF,AG,AH,AI,AJ,AK,AL,AM,AN,AO,AP,AQ,AR) ); \
+ WCF(T1,A1,1) WCF(T2,A2,2) WCF(T3,A3,3) WCF(T4,A4,4) WCF(T5,A5,5) WCF(T6,A6,6) \
+ WCF(T7,A7,7) WCF(T8,A8,8) WCF(T9,A9,9) WCF(TA,AA,10) WCF(TB,AB,11) WCF(TC,AC,12) \
+ WCF(TD,AD,13) WCF(TE,AE,14) WCF(TF,AF,15) WCF(TG,AG,16) WCF(TH,AH,17) WCF(TI,AI,18) \
+ WCF(TJ,AJ,19) WCF(TK,AK,20) WCF(TL,AL,21) WCF(TM,AM,22) WCF(TN,AN,23) WCF(TO,AO,24) \
+ WCF(TP,AP,25) WCF(TQ,AQ,26) WCF(TR,AR,27) }while(0)
+#endif
+#endif /* MAX_PREPRO_ARGS */
+
+/*-------------------------------------------------------------------------*/
+
+/* UTILITIES FOR C TO CALL FORTRAN FUNCTIONS */
+
+/*N.B. PROTOCCALLSFFUNn(..) generates code, whether or not the FORTRAN
+ function is called. Therefore, especially for creator's of C header files
+ for large FORTRAN libraries which include many functions, to reduce
+ compile time and object code size, it may be desirable to create
+ preprocessor directives to allow users to create code for only those
+ functions which they use. */
+
+/* The following defines the maximum length string that a function can return.
+ Of course it may be undefine-d and re-define-d before individual
+ PROTOCCALLSFFUNn(..) as required. It would also be nice to have this derived
+ from the individual machines' limits. */
+#define MAX_LEN_FORTRAN_FUNCTION_STRING 0x4FE
+
+/* The following defines a character used by CFORTRAN.H to flag the end of a
+ string coming out of a FORTRAN routine. */
+#define CFORTRAN_NON_CHAR 0x7F
+
+#ifdef OLD_VAXC /* Prevent %CC-I-PARAMNOTUSED. */
+#pragma nostandard
+#endif
+
+#define _SEP_(TN,C,cfCOMMA) _(__SEP_,C)(TN,cfCOMMA)
+#define __SEP_0(TN,cfCOMMA)
+#define __SEP_1(TN,cfCOMMA) _Icf(2,SEP,TN,cfCOMMA,0)
+#define INT_cfSEP(T,B) _(A,B)
+#define INTV_cfSEP(T,B) INT_cfSEP(T,B)
+#define INTVV_cfSEP(T,B) INT_cfSEP(T,B)
+#define INTVVV_cfSEP(T,B) INT_cfSEP(T,B)
+#define INTVVVV_cfSEP(T,B) INT_cfSEP(T,B)
+#define INTVVVVV_cfSEP(T,B) INT_cfSEP(T,B)
+#define INTVVVVVV_cfSEP(T,B) INT_cfSEP(T,B)
+#define INTVVVVVVV_cfSEP(T,B) INT_cfSEP(T,B)
+#define PINT_cfSEP(T,B) INT_cfSEP(T,B)
+#define PVOID_cfSEP(T,B) INT_cfSEP(T,B)
+#define ROUTINE_cfSEP(T,B) INT_cfSEP(T,B)
+#define SIMPLE_cfSEP(T,B) INT_cfSEP(T,B)
+#define VOID_cfSEP(T,B) INT_cfSEP(T,B) /* For FORTRAN calls C subr.s.*/
+#define STRING_cfSEP(T,B) INT_cfSEP(T,B)
+#define STRINGV_cfSEP(T,B) INT_cfSEP(T,B)
+#define PSTRING_cfSEP(T,B) INT_cfSEP(T,B)
+#define PSTRINGV_cfSEP(T,B) INT_cfSEP(T,B)
+#define PNSTRING_cfSEP(T,B) INT_cfSEP(T,B)
+#define PPSTRING_cfSEP(T,B) INT_cfSEP(T,B)
+#define ZTRINGV_cfSEP(T,B) INT_cfSEP(T,B)
+#define PZTRINGV_cfSEP(T,B) INT_cfSEP(T,B)
+
+#if defined(SIGNED_BYTE) || !defined(UNSIGNED_BYTE)
+#ifdef OLD_VAXC
+#define INTEGER_BYTE char /* Old VAXC barfs on 'signed char' */
+#else
+#define INTEGER_BYTE signed char /* default */
+#endif
+#else
+#define INTEGER_BYTE unsigned char
+#endif
+#define BYTEVVVVVVV_cfTYPE INTEGER_BYTE
+#define DOUBLEVVVVVVV_cfTYPE DOUBLE_PRECISION
+#define FLOATVVVVVVV_cfTYPE FORTRAN_REAL
+#define INTVVVVVVV_cfTYPE int
+#define LOGICALVVVVVVV_cfTYPE int
+#define LONGVVVVVVV_cfTYPE long
+#define LONGLONGVVVVVVV_cfTYPE LONGLONG /* added by MR December 2005 */
+#define SHORTVVVVVVV_cfTYPE short
+#define PBYTE_cfTYPE INTEGER_BYTE
+#define PDOUBLE_cfTYPE DOUBLE_PRECISION
+#define PFLOAT_cfTYPE FORTRAN_REAL
+#define PINT_cfTYPE int
+#define PLOGICAL_cfTYPE int
+#define PLONG_cfTYPE long
+#define PLONGLONG_cfTYPE LONGLONG /* added by MR December 2005 */
+#define PSHORT_cfTYPE short
+
+#define CFARGS0(A,T,V,W,X,Y,Z) _3(T,_cf,A)
+#define CFARGS1(A,T,V,W,X,Y,Z) _3(T,_cf,A)(V)
+#define CFARGS2(A,T,V,W,X,Y,Z) _3(T,_cf,A)(V,W)
+#define CFARGS3(A,T,V,W,X,Y,Z) _3(T,_cf,A)(V,W,X)
+#define CFARGS4(A,T,V,W,X,Y,Z) _3(T,_cf,A)(V,W,X,Y)
+#define CFARGS5(A,T,V,W,X,Y,Z) _3(T,_cf,A)(V,W,X,Y,Z)
+
+#define _Icf(N,T,I,X,Y) _(I,_cfINT)(N,T,I,X,Y,0)
+#define _Icf4(N,T,I,X,Y,Z) _(I,_cfINT)(N,T,I,X,Y,Z)
+#define BYTE_cfINT(N,A,B,X,Y,Z) DOUBLE_cfINT(N,A,B,X,Y,Z)
+#define DOUBLE_cfINT(N,A,B,X,Y,Z) _(CFARGS,N)(A,INT,B,X,Y,Z,0)
+#define FLOAT_cfINT(N,A,B,X,Y,Z) DOUBLE_cfINT(N,A,B,X,Y,Z)
+#define INT_cfINT(N,A,B,X,Y,Z) DOUBLE_cfINT(N,A,B,X,Y,Z)
+#define LOGICAL_cfINT(N,A,B,X,Y,Z) DOUBLE_cfINT(N,A,B,X,Y,Z)
+#define LONG_cfINT(N,A,B,X,Y,Z) DOUBLE_cfINT(N,A,B,X,Y,Z)
+#define LONGLONG_cfINT(N,A,B,X,Y,Z) DOUBLE_cfINT(N,A,B,X,Y,Z) /* added by MR December 2005 */
+#define SHORT_cfINT(N,A,B,X,Y,Z) DOUBLE_cfINT(N,A,B,X,Y,Z)
+#define PBYTE_cfINT(N,A,B,X,Y,Z) PDOUBLE_cfINT(N,A,B,X,Y,Z)
+#define PDOUBLE_cfINT(N,A,B,X,Y,Z) _(CFARGS,N)(A,PINT,B,X,Y,Z,0)
+#define PFLOAT_cfINT(N,A,B,X,Y,Z) PDOUBLE_cfINT(N,A,B,X,Y,Z)
+#define PINT_cfINT(N,A,B,X,Y,Z) PDOUBLE_cfINT(N,A,B,X,Y,Z)
+#define PLOGICAL_cfINT(N,A,B,X,Y,Z) PDOUBLE_cfINT(N,A,B,X,Y,Z)
+#define PLONG_cfINT(N,A,B,X,Y,Z) PDOUBLE_cfINT(N,A,B,X,Y,Z)
+#define PLONGLONG_cfINT(N,A,B,X,Y,Z) PDOUBLE_cfINT(N,A,B,X,Y,Z) /* added by MR December 2005 */
+#define PSHORT_cfINT(N,A,B,X,Y,Z) PDOUBLE_cfINT(N,A,B,X,Y,Z)
+#define BYTEV_cfINT(N,A,B,X,Y,Z) DOUBLEV_cfINT(N,A,B,X,Y,Z)
+#define BYTEVV_cfINT(N,A,B,X,Y,Z) DOUBLEVV_cfINT(N,A,B,X,Y,Z)
+#define BYTEVVV_cfINT(N,A,B,X,Y,Z) DOUBLEVVV_cfINT(N,A,B,X,Y,Z)
+#define BYTEVVVV_cfINT(N,A,B,X,Y,Z) DOUBLEVVVV_cfINT(N,A,B,X,Y,Z)
+#define BYTEVVVVV_cfINT(N,A,B,X,Y,Z) DOUBLEVVVVV_cfINT(N,A,B,X,Y,Z)
+#define BYTEVVVVVV_cfINT(N,A,B,X,Y,Z) DOUBLEVVVVVV_cfINT(N,A,B,X,Y,Z)
+#define BYTEVVVVVVV_cfINT(N,A,B,X,Y,Z) DOUBLEVVVVVVV_cfINT(N,A,B,X,Y,Z)
+#define DOUBLEV_cfINT(N,A,B,X,Y,Z) _(CFARGS,N)(A,INTV,B,X,Y,Z,0)
+#define DOUBLEVV_cfINT(N,A,B,X,Y,Z) _(CFARGS,N)(A,INTVV,B,X,Y,Z,0)
+#define DOUBLEVVV_cfINT(N,A,B,X,Y,Z) _(CFARGS,N)(A,INTVVV,B,X,Y,Z,0)
+#define DOUBLEVVVV_cfINT(N,A,B,X,Y,Z) _(CFARGS,N)(A,INTVVVV,B,X,Y,Z,0)
+#define DOUBLEVVVVV_cfINT(N,A,B,X,Y,Z) _(CFARGS,N)(A,INTVVVVV,B,X,Y,Z,0)
+#define DOUBLEVVVVVV_cfINT(N,A,B,X,Y,Z) _(CFARGS,N)(A,INTVVVVVV,B,X,Y,Z,0)
+#define DOUBLEVVVVVVV_cfINT(N,A,B,X,Y,Z) _(CFARGS,N)(A,INTVVVVVVV,B,X,Y,Z,0)
+#define FLOATV_cfINT(N,A,B,X,Y,Z) DOUBLEV_cfINT(N,A,B,X,Y,Z)
+#define FLOATVV_cfINT(N,A,B,X,Y,Z) DOUBLEVV_cfINT(N,A,B,X,Y,Z)
+#define FLOATVVV_cfINT(N,A,B,X,Y,Z) DOUBLEVVV_cfINT(N,A,B,X,Y,Z)
+#define FLOATVVVV_cfINT(N,A,B,X,Y,Z) DOUBLEVVVV_cfINT(N,A,B,X,Y,Z)
+#define FLOATVVVVV_cfINT(N,A,B,X,Y,Z) DOUBLEVVVVV_cfINT(N,A,B,X,Y,Z)
+#define FLOATVVVVVV_cfINT(N,A,B,X,Y,Z) DOUBLEVVVVVV_cfINT(N,A,B,X,Y,Z)
+#define FLOATVVVVVVV_cfINT(N,A,B,X,Y,Z) DOUBLEVVVVVVV_cfINT(N,A,B,X,Y,Z)
+#define INTV_cfINT(N,A,B,X,Y,Z) DOUBLEV_cfINT(N,A,B,X,Y,Z)
+#define INTVV_cfINT(N,A,B,X,Y,Z) DOUBLEVV_cfINT(N,A,B,X,Y,Z)
+#define INTVVV_cfINT(N,A,B,X,Y,Z) DOUBLEVVV_cfINT(N,A,B,X,Y,Z)
+#define INTVVVV_cfINT(N,A,B,X,Y,Z) DOUBLEVVVV_cfINT(N,A,B,X,Y,Z)
+#define INTVVVVV_cfINT(N,A,B,X,Y,Z) DOUBLEVVVVV_cfINT(N,A,B,X,Y,Z)
+#define INTVVVVVV_cfINT(N,A,B,X,Y,Z) DOUBLEVVVVVV_cfINT(N,A,B,X,Y,Z)
+#define INTVVVVVVV_cfINT(N,A,B,X,Y,Z) DOUBLEVVVVVVV_cfINT(N,A,B,X,Y,Z)
+#define LOGICALV_cfINT(N,A,B,X,Y,Z) DOUBLEV_cfINT(N,A,B,X,Y,Z)
+#define LOGICALVV_cfINT(N,A,B,X,Y,Z) DOUBLEVV_cfINT(N,A,B,X,Y,Z)
+#define LOGICALVVV_cfINT(N,A,B,X,Y,Z) DOUBLEVVV_cfINT(N,A,B,X,Y,Z)
+#define LOGICALVVVV_cfINT(N,A,B,X,Y,Z) DOUBLEVVVV_cfINT(N,A,B,X,Y,Z)
+#define LOGICALVVVVV_cfINT(N,A,B,X,Y,Z) DOUBLEVVVVV_cfINT(N,A,B,X,Y,Z)
+#define LOGICALVVVVVV_cfINT(N,A,B,X,Y,Z) DOUBLEVVVVVV_cfINT(N,A,B,X,Y,Z)
+#define LOGICALVVVVVVV_cfINT(N,A,B,X,Y,Z) DOUBLEVVVVVVV_cfINT(N,A,B,X,Y,Z)
+#define LONGV_cfINT(N,A,B,X,Y,Z) DOUBLEV_cfINT(N,A,B,X,Y,Z)
+#define LONGVV_cfINT(N,A,B,X,Y,Z) DOUBLEVV_cfINT(N,A,B,X,Y,Z)
+#define LONGVVV_cfINT(N,A,B,X,Y,Z) DOUBLEVVV_cfINT(N,A,B,X,Y,Z)
+#define LONGVVVV_cfINT(N,A,B,X,Y,Z) DOUBLEVVVV_cfINT(N,A,B,X,Y,Z)
+#define LONGVVVVV_cfINT(N,A,B,X,Y,Z) DOUBLEVVVVV_cfINT(N,A,B,X,Y,Z)
+#define LONGVVVVVV_cfINT(N,A,B,X,Y,Z) DOUBLEVVVVVV_cfINT(N,A,B,X,Y,Z)
+#define LONGVVVVVVV_cfINT(N,A,B,X,Y,Z) DOUBLEVVVVVVV_cfINT(N,A,B,X,Y,Z)
+#define LONGLONGV_cfINT(N,A,B,X,Y,Z) DOUBLEV_cfINT(N,A,B,X,Y,Z) /* added by MR December 2005 */
+#define LONGLONGVV_cfINT(N,A,B,X,Y,Z) DOUBLEVV_cfINT(N,A,B,X,Y,Z) /* added by MR December 2005 */
+#define LONGLONGVVV_cfINT(N,A,B,X,Y,Z) DOUBLEVVV_cfINT(N,A,B,X,Y,Z) /* added by MR December 2005 */
+#define LONGLONGVVVV_cfINT(N,A,B,X,Y,Z) DOUBLEVVVV_cfINT(N,A,B,X,Y,Z) /* added by MR December 2005 */
+#define LONGLONGVVVVV_cfINT(N,A,B,X,Y,Z) DOUBLEVVVVV_cfINT(N,A,B,X,Y,Z) /* added by MR December 2005 */
+#define LONGLONGVVVVVV_cfINT(N,A,B,X,Y,Z) DOUBLEVVVVVV_cfINT(N,A,B,X,Y,Z) /* added by MR December 2005 */
+#define LONGLONGVVVVVVV_cfINT(N,A,B,X,Y,Z) DOUBLEVVVVVVV_cfINT(N,A,B,X,Y,Z) /* added by MR December 2005 */
+#define SHORTV_cfINT(N,A,B,X,Y,Z) DOUBLEV_cfINT(N,A,B,X,Y,Z)
+#define SHORTVV_cfINT(N,A,B,X,Y,Z) DOUBLEVV_cfINT(N,A,B,X,Y,Z)
+#define SHORTVVV_cfINT(N,A,B,X,Y,Z) DOUBLEVVV_cfINT(N,A,B,X,Y,Z)
+#define SHORTVVVV_cfINT(N,A,B,X,Y,Z) DOUBLEVVVV_cfINT(N,A,B,X,Y,Z)
+#define SHORTVVVVV_cfINT(N,A,B,X,Y,Z) DOUBLEVVVVV_cfINT(N,A,B,X,Y,Z)
+#define SHORTVVVVVV_cfINT(N,A,B,X,Y,Z) DOUBLEVVVVVV_cfINT(N,A,B,X,Y,Z)
+#define SHORTVVVVVVV_cfINT(N,A,B,X,Y,Z) DOUBLEVVVVVVV_cfINT(N,A,B,X,Y,Z)
+#define PVOID_cfINT(N,A,B,X,Y,Z) _(CFARGS,N)(A,B,B,X,Y,Z,0)
+#define ROUTINE_cfINT(N,A,B,X,Y,Z) PVOID_cfINT(N,A,B,X,Y,Z)
+/*CRAY coughs on the first,
+ i.e. the usual trouble of not being able to
+ define macros to macros with arguments.
+ New ultrix is worse, it coughs on all such uses.
+ */
+/*#define SIMPLE_cfINT PVOID_cfINT*/
+#define SIMPLE_cfINT(N,A,B,X,Y,Z) PVOID_cfINT(N,A,B,X,Y,Z)
+#define VOID_cfINT(N,A,B,X,Y,Z) PVOID_cfINT(N,A,B,X,Y,Z)
+#define STRING_cfINT(N,A,B,X,Y,Z) PVOID_cfINT(N,A,B,X,Y,Z)
+#define STRINGV_cfINT(N,A,B,X,Y,Z) PVOID_cfINT(N,A,B,X,Y,Z)
+#define PSTRING_cfINT(N,A,B,X,Y,Z) PVOID_cfINT(N,A,B,X,Y,Z)
+#define PSTRINGV_cfINT(N,A,B,X,Y,Z) PVOID_cfINT(N,A,B,X,Y,Z)
+#define PNSTRING_cfINT(N,A,B,X,Y,Z) PVOID_cfINT(N,A,B,X,Y,Z)
+#define PPSTRING_cfINT(N,A,B,X,Y,Z) PVOID_cfINT(N,A,B,X,Y,Z)
+#define ZTRINGV_cfINT(N,A,B,X,Y,Z) PVOID_cfINT(N,A,B,X,Y,Z)
+#define PZTRINGV_cfINT(N,A,B,X,Y,Z) PVOID_cfINT(N,A,B,X,Y,Z)
+#define CF_0_cfINT(N,A,B,X,Y,Z)
+
+
+#define UCF(TN,I,C) _SEP_(TN,C,cfCOMMA) _Icf(2,U,TN,_(A,I),0)
+#define UUCF(TN,I,C) _SEP_(TN,C,cfCOMMA) _SEP_(TN,1,I)
+#define UUUCF(TN,I,C) _SEP_(TN,C,cfCOLON) _Icf(2,U,TN,_(A,I),0)
+#define INT_cfU(T,A) _(T,VVVVVVV_cfTYPE) A
+#define INTV_cfU(T,A) _(T,VVVVVV_cfTYPE) * A
+#define INTVV_cfU(T,A) _(T,VVVVV_cfTYPE) * A
+#define INTVVV_cfU(T,A) _(T,VVVV_cfTYPE) * A
+#define INTVVVV_cfU(T,A) _(T,VVV_cfTYPE) * A
+#define INTVVVVV_cfU(T,A) _(T,VV_cfTYPE) * A
+#define INTVVVVVV_cfU(T,A) _(T,V_cfTYPE) * A
+#define INTVVVVVVV_cfU(T,A) _(T,_cfTYPE) * A
+#define PINT_cfU(T,A) _(T,_cfTYPE) * A
+#define PVOID_cfU(T,A) void *A
+#define ROUTINE_cfU(T,A) void (*A)(CF_NULL_PROTO)
+#define VOID_cfU(T,A) void A /* Needed for C calls FORTRAN sub.s. */
+#define STRING_cfU(T,A) char *A /* via VOID and wrapper. */
+#define STRINGV_cfU(T,A) char *A
+#define PSTRING_cfU(T,A) char *A
+#define PSTRINGV_cfU(T,A) char *A
+#define ZTRINGV_cfU(T,A) char *A
+#define PZTRINGV_cfU(T,A) char *A
+
+/* VOID breaks U into U and UU. */
+#define INT_cfUU(T,A) _(T,VVVVVVV_cfTYPE) A
+#define VOID_cfUU(T,A) /* Needed for FORTRAN calls C sub.s. */
+#define STRING_cfUU(T,A) char *A
+
+
+#define BYTE_cfPU(A) CFextern INTEGER_BYTE FCALLSC_QUALIFIER A
+#define DOUBLE_cfPU(A) CFextern DOUBLE_PRECISION FCALLSC_QUALIFIER A
+#if ! (defined(FLOATFUNCTIONTYPE)&&defined(ASSIGNFLOAT)&&defined(RETURNFLOAT))
+#if defined (f2cFortran) && ! defined (gFortran)
+/* f2c/g77 return double from FORTRAN REAL functions. (KMCCARTY, 2005/12/09) */
+#define FLOAT_cfPU(A) CFextern DOUBLE_PRECISION FCALLSC_QUALIFIER A
+#else
+#define FLOAT_cfPU(A) CFextern FORTRAN_REAL FCALLSC_QUALIFIER A
+#endif
+#else
+#define FLOAT_cfPU(A) CFextern FLOATFUNCTIONTYPE FCALLSC_QUALIFIER A
+#endif
+#define INT_cfPU(A) CFextern int FCALLSC_QUALIFIER A
+#define LOGICAL_cfPU(A) CFextern int FCALLSC_QUALIFIER A
+#define LONG_cfPU(A) CFextern long FCALLSC_QUALIFIER A
+#define SHORT_cfPU(A) CFextern short FCALLSC_QUALIFIER A
+#define STRING_cfPU(A) CFextern void FCALLSC_QUALIFIER A
+#define VOID_cfPU(A) CFextern void FCALLSC_QUALIFIER A
+
+#define BYTE_cfE INTEGER_BYTE A0;
+#define DOUBLE_cfE DOUBLE_PRECISION A0;
+#if ! (defined(FLOATFUNCTIONTYPE)&&defined(ASSIGNFLOAT)&&defined(RETURNFLOAT))
+#define FLOAT_cfE FORTRAN_REAL A0;
+#else
+#define FLOAT_cfE FORTRAN_REAL AA0; FLOATFUNCTIONTYPE A0;
+#endif
+#define INT_cfE int A0;
+#define LOGICAL_cfE int A0;
+#define LONG_cfE long A0;
+#define SHORT_cfE short A0;
+#define VOID_cfE
+#ifdef vmsFortran
+#define STRING_cfE static char AA0[1+MAX_LEN_FORTRAN_FUNCTION_STRING]; \
+ static fstring A0 = \
+ {MAX_LEN_FORTRAN_FUNCTION_STRING,DSC$K_DTYPE_T,DSC$K_CLASS_S,AA0};\
+ memset(AA0, CFORTRAN_NON_CHAR, MAX_LEN_FORTRAN_FUNCTION_STRING);\
+ *(AA0+MAX_LEN_FORTRAN_FUNCTION_STRING)='\0';
+#else
+#ifdef CRAYFortran
+#define STRING_cfE static char AA0[1+MAX_LEN_FORTRAN_FUNCTION_STRING]; \
+ static _fcd A0; *(AA0+MAX_LEN_FORTRAN_FUNCTION_STRING)='\0';\
+ memset(AA0,CFORTRAN_NON_CHAR, MAX_LEN_FORTRAN_FUNCTION_STRING);\
+ A0 = _cptofcd(AA0,MAX_LEN_FORTRAN_FUNCTION_STRING);
+#else
+/* 'cc: SC3.0.1 13 Jul 1994' barfs on char A0[0x4FE+1];
+ * char A0[0x4FE +1]; char A0[1+0x4FE]; are both OK. */
+#define STRING_cfE static char A0[1+MAX_LEN_FORTRAN_FUNCTION_STRING]; \
+ memset(A0, CFORTRAN_NON_CHAR, \
+ MAX_LEN_FORTRAN_FUNCTION_STRING); \
+ *(A0+MAX_LEN_FORTRAN_FUNCTION_STRING)='\0';
+#endif
+#endif
+/* ESTRING must use static char. array which is guaranteed to exist after
+ function returns. */
+
+/* N.B.i) The diff. for 0 (Zero) and >=1 arguments.
+ ii)That the following create an unmatched bracket, i.e. '(', which
+ must of course be matched in the call.
+ iii)Commas must be handled very carefully */
+#define INT_cfGZ(T,UN,LN) A0=CFC_(UN,LN)(
+#define VOID_cfGZ(T,UN,LN) CFC_(UN,LN)(
+#ifdef vmsFortran
+#define STRING_cfGZ(T,UN,LN) CFC_(UN,LN)(&A0
+#else
+#if defined(CRAYFortran) || defined(AbsoftUNIXFortran) || defined(AbsoftProFortran)
+#define STRING_cfGZ(T,UN,LN) CFC_(UN,LN)( A0
+#else
+#define STRING_cfGZ(T,UN,LN) CFC_(UN,LN)( A0,MAX_LEN_FORTRAN_FUNCTION_STRING
+#endif
+#endif
+
+#define INT_cfG(T,UN,LN) INT_cfGZ(T,UN,LN)
+#define VOID_cfG(T,UN,LN) VOID_cfGZ(T,UN,LN)
+#define STRING_cfG(T,UN,LN) STRING_cfGZ(T,UN,LN), /*, is only diff. from _cfG*/
+
+#define BYTEVVVVVVV_cfPP
+#define INTVVVVVVV_cfPP /* These complement FLOATVVVVVVV_cfPP. */
+#define DOUBLEVVVVVVV_cfPP
+#define LOGICALVVVVVVV_cfPP
+#define LONGVVVVVVV_cfPP
+#define SHORTVVVVVVV_cfPP
+#define PBYTE_cfPP
+#define PINT_cfPP
+#define PDOUBLE_cfPP
+#define PLOGICAL_cfPP
+#define PLONG_cfPP
+#define PSHORT_cfPP
+#define PFLOAT_cfPP FLOATVVVVVVV_cfPP
+
+#define BCF(TN,AN,C) _SEP_(TN,C,cfCOMMA) _Icf(2,B,TN,AN,0)
+#define INT_cfB(T,A) (_(T,VVVVVVV_cfTYPE)) A
+#define INTV_cfB(T,A) A
+#define INTVV_cfB(T,A) (A)[0]
+#define INTVVV_cfB(T,A) (A)[0][0]
+#define INTVVVV_cfB(T,A) (A)[0][0][0]
+#define INTVVVVV_cfB(T,A) (A)[0][0][0][0]
+#define INTVVVVVV_cfB(T,A) (A)[0][0][0][0][0]
+#define INTVVVVVVV_cfB(T,A) (A)[0][0][0][0][0][0]
+#define PINT_cfB(T,A) _(T,_cfPP)&A
+#define STRING_cfB(T,A) (char *) A
+#define STRINGV_cfB(T,A) (char *) A
+#define PSTRING_cfB(T,A) (char *) A
+#define PSTRINGV_cfB(T,A) (char *) A
+#define PVOID_cfB(T,A) (void *) A
+#define ROUTINE_cfB(T,A) (cfCAST_FUNCTION)A
+#define ZTRINGV_cfB(T,A) (char *) A
+#define PZTRINGV_cfB(T,A) (char *) A
+
+#define SCF(TN,NAME,I,A) _(TN,_cfSTR)(3,S,NAME,I,A,0,0)
+#define DEFAULT_cfS(M,I,A)
+#define LOGICAL_cfS(M,I,A)
+#define PLOGICAL_cfS(M,I,A)
+#define STRING_cfS(M,I,A) ,sizeof(A)
+#define STRINGV_cfS(M,I,A) ,( (unsigned)0xFFFF*firstindexlength(A) \
+ +secondindexlength(A))
+#define PSTRING_cfS(M,I,A) ,sizeof(A)
+#define PSTRINGV_cfS(M,I,A) STRINGV_cfS(M,I,A)
+#define ZTRINGV_cfS(M,I,A)
+#define PZTRINGV_cfS(M,I,A)
+
+#define HCF(TN,I) _(TN,_cfSTR)(3,H,cfCOMMA, H,_(C,I),0,0)
+#define HHCF(TN,I) _(TN,_cfSTR)(3,H,cfCOMMA,HH,_(C,I),0,0)
+#define HHHCF(TN,I) _(TN,_cfSTR)(3,H,cfCOLON, H,_(C,I),0,0)
+#define H_CF_SPECIAL unsigned
+#define HH_CF_SPECIAL
+#define DEFAULT_cfH(M,I,A)
+#define LOGICAL_cfH(S,U,B)
+#define PLOGICAL_cfH(S,U,B)
+#define STRING_cfH(S,U,B) _(A,S) _(U,_CF_SPECIAL) B
+#define STRINGV_cfH(S,U,B) STRING_cfH(S,U,B)
+#define PSTRING_cfH(S,U,B) STRING_cfH(S,U,B)
+#define PSTRINGV_cfH(S,U,B) STRING_cfH(S,U,B)
+#define PNSTRING_cfH(S,U,B) STRING_cfH(S,U,B)
+#define PPSTRING_cfH(S,U,B) STRING_cfH(S,U,B)
+#define ZTRINGV_cfH(S,U,B)
+#define PZTRINGV_cfH(S,U,B)
+
+/* Need VOID_cfSTR because Absoft forced function types go through _cfSTR. */
+/* No spaces inside expansion. They screws up macro catenation kludge. */
+#define VOID_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E)
+#define BYTE_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E)
+#define DOUBLE_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E)
+#define FLOAT_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E)
+#define INT_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E)
+#define LOGICAL_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,LOGICAL,A,B,C,D,E)
+#define LONG_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E)
+#define LONGLONG_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E) /* added by MR December 2005 */
+#define SHORT_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E)
+#define BYTEV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E)
+#define BYTEVV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E)
+#define BYTEVVV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E)
+#define BYTEVVVV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E)
+#define BYTEVVVVV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E)
+#define BYTEVVVVVV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E)
+#define BYTEVVVVVVV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E)
+#define DOUBLEV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E)
+#define DOUBLEVV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E)
+#define DOUBLEVVV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E)
+#define DOUBLEVVVV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E)
+#define DOUBLEVVVVV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E)
+#define DOUBLEVVVVVV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E)
+#define DOUBLEVVVVVVV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E)
+#define FLOATV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E)
+#define FLOATVV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E)
+#define FLOATVVV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E)
+#define FLOATVVVV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E)
+#define FLOATVVVVV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E)
+#define FLOATVVVVVV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E)
+#define FLOATVVVVVVV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E)
+#define INTV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E)
+#define INTVV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E)
+#define INTVVV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E)
+#define INTVVVV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E)
+#define INTVVVVV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E)
+#define INTVVVVVV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E)
+#define INTVVVVVVV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E)
+#define LOGICALV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E)
+#define LOGICALVV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E)
+#define LOGICALVVV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E)
+#define LOGICALVVVV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E)
+#define LOGICALVVVVV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E)
+#define LOGICALVVVVVV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E)
+#define LOGICALVVVVVVV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E)
+#define LONGV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E)
+#define LONGVV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E)
+#define LONGVVV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E)
+#define LONGVVVV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E)
+#define LONGVVVVV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E)
+#define LONGVVVVVV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E)
+#define LONGVVVVVVV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E)
+#define LONGLONGV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E) /* added by MR December 2005 */
+#define LONGLONGVV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E) /* added by MR December 2005 */
+#define LONGLONGVVV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E) /* added by MR December 2005 */
+#define LONGLONGVVVV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E) /* added by MR December 2005 */
+#define LONGLONGVVVVV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E) /* added by MR December 2005 */
+#define LONGLONGVVVVVV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E) /* added by MR December 2005 */
+#define LONGLONGVVVVVVV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E) /* added by MR December 2005 */
+#define SHORTV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E)
+#define SHORTVV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E)
+#define SHORTVVV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E)
+#define SHORTVVVV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E)
+#define SHORTVVVVV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E)
+#define SHORTVVVVVV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E)
+#define SHORTVVVVVVV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E)
+#define PBYTE_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E)
+#define PDOUBLE_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E)
+#define PFLOAT_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E)
+#define PINT_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E)
+#define PLOGICAL_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,PLOGICAL,A,B,C,D,E)
+#define PLONG_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E)
+#define PLONGLONG_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E) /* added by MR December 2005 */
+#define PSHORT_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E)
+#define STRING_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,STRING,A,B,C,D,E)
+#define PSTRING_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,PSTRING,A,B,C,D,E)
+#define STRINGV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,STRINGV,A,B,C,D,E)
+#define PSTRINGV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,PSTRINGV,A,B,C,D,E)
+#define PNSTRING_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,PNSTRING,A,B,C,D,E)
+#define PPSTRING_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,PPSTRING,A,B,C,D,E)
+#define PVOID_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E)
+#define ROUTINE_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E)
+#define SIMPLE_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E)
+#define ZTRINGV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,ZTRINGV,A,B,C,D,E)
+#define PZTRINGV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,PZTRINGV,A,B,C,D,E)
+#define CF_0_cfSTR(N,T,A,B,C,D,E)
+
+/* See ACF table comments, which explain why CCF was split into two. */
+#define CCF(NAME,TN,I) _(TN,_cfSTR)(5,C,NAME,I,_(A,I),_(B,I),_(C,I))
+#define DEFAULT_cfC(M,I,A,B,C)
+#define LOGICAL_cfC(M,I,A,B,C) A=C2FLOGICAL( A);
+#define PLOGICAL_cfC(M,I,A,B,C) *A=C2FLOGICAL(*A);
+#ifdef vmsFortran
+#define STRING_cfC(M,I,A,B,C) (B.clen=strlen(A),B.f.dsc$a_pointer=A, \
+ C==sizeof(char*)||C==(unsigned)(B.clen+1)?B.f.dsc$w_length=B.clen: \
+ (memset((A)+B.clen,' ',C-B.clen-1),A[B.f.dsc$w_length=C-1]='\0'));
+ /* PSTRING_cfC to beware of array A which does not contain any \0. */
+#define PSTRING_cfC(M,I,A,B,C) (B.dsc$a_pointer=A, C==sizeof(char*) ? \
+ B.dsc$w_length=strlen(A): (A[C-1]='\0',B.dsc$w_length=strlen(A), \
+ memset((A)+B.dsc$w_length,' ',C-B.dsc$w_length-1), B.dsc$w_length=C-1));
+#else
+#define STRING_cfC(M,I,A,B,C) (B.nombre=A,B.clen=strlen(A), \
+ C==sizeof(char*)||C==(unsigned)(B.clen+1)?B.flen=B.clen: \
+ (memset(B.nombre+B.clen,' ',C-B.clen-1),B.nombre[B.flen=C-1]='\0'));
+#define PSTRING_cfC(M,I,A,B,C) (C==sizeof(char*)? B=strlen(A): \
+ (A[C-1]='\0',B=strlen(A),memset((A)+B,' ',C-B-1),B=C-1));
+#endif
+ /* For CRAYFortran for (P)STRINGV_cfC, B.fs is set, but irrelevant. */
+#define STRINGV_cfC(M,I,A,B,C) \
+ AATRINGV_cfA( A,B,(C/0xFFFF)*(C%0xFFFF),C/0xFFFF,C%0xFFFF)
+#define PSTRINGV_cfC(M,I,A,B,C) \
+ APATRINGV_cfA( A,B,(C/0xFFFF)*(C%0xFFFF),C/0xFFFF,C%0xFFFF)
+#define ZTRINGV_cfC(M,I,A,B,C) \
+ AATRINGV_cfA( A,B, (_3(M,_ELEMS_,I))*((_3(M,_ELEMLEN_,I))+1), \
+ (_3(M,_ELEMS_,I)), (_3(M,_ELEMLEN_,I))+1 )
+#define PZTRINGV_cfC(M,I,A,B,C) \
+ APATRINGV_cfA( A,B, (_3(M,_ELEMS_,I))*((_3(M,_ELEMLEN_,I))+1), \
+ (_3(M,_ELEMS_,I)), (_3(M,_ELEMLEN_,I))+1 )
+
+#define BYTE_cfCCC(A,B) &A
+#define DOUBLE_cfCCC(A,B) &A
+#if !defined(__CF__KnR)
+#define FLOAT_cfCCC(A,B) &A
+ /* Although the VAX doesn't, at least the */
+#else /* HP and K&R mips promote float arg.'s of */
+#define FLOAT_cfCCC(A,B) &B /* unprototyped functions to double. Cannot */
+#endif /* use A here to pass the argument to FORTRAN. */
+#define INT_cfCCC(A,B) &A
+#define LOGICAL_cfCCC(A,B) &A
+#define LONG_cfCCC(A,B) &A
+#define SHORT_cfCCC(A,B) &A
+#define PBYTE_cfCCC(A,B) A
+#define PDOUBLE_cfCCC(A,B) A
+#define PFLOAT_cfCCC(A,B) A
+#define PINT_cfCCC(A,B) A
+#define PLOGICAL_cfCCC(A,B) B=A /* B used to keep a common W table. */
+#define PLONG_cfCCC(A,B) A
+#define PSHORT_cfCCC(A,B) A
+
+#define CCCF(TN,I,M) _SEP_(TN,M,cfCOMMA) _Icf(3,CC,TN,_(A,I),_(B,I))
+#define INT_cfCC(T,A,B) _(T,_cfCCC)(A,B)
+#define INTV_cfCC(T,A,B) A
+#define INTVV_cfCC(T,A,B) A
+#define INTVVV_cfCC(T,A,B) A
+#define INTVVVV_cfCC(T,A,B) A
+#define INTVVVVV_cfCC(T,A,B) A
+#define INTVVVVVV_cfCC(T,A,B) A
+#define INTVVVVVVV_cfCC(T,A,B) A
+#define PINT_cfCC(T,A,B) _(T,_cfCCC)(A,B)
+#define PVOID_cfCC(T,A,B) A
+#if defined(apolloFortran) || defined(hpuxFortran800) || defined(AbsoftUNIXFortran)
+#define ROUTINE_cfCC(T,A,B) &A
+#else
+#define ROUTINE_cfCC(T,A,B) A
+#endif
+#define SIMPLE_cfCC(T,A,B) A
+#ifdef vmsFortran
+#define STRING_cfCC(T,A,B) &B.f
+#define STRINGV_cfCC(T,A,B) &B
+#define PSTRING_cfCC(T,A,B) &B
+#define PSTRINGV_cfCC(T,A,B) &B
+#else
+#ifdef CRAYFortran
+#define STRING_cfCC(T,A,B) _cptofcd(A,B.flen)
+#define STRINGV_cfCC(T,A,B) _cptofcd(B.s,B.flen)
+#define PSTRING_cfCC(T,A,B) _cptofcd(A,B)
+#define PSTRINGV_cfCC(T,A,B) _cptofcd(A,B.flen)
+#else
+#define STRING_cfCC(T,A,B) A
+#define STRINGV_cfCC(T,A,B) B.fs
+#define PSTRING_cfCC(T,A,B) A
+#define PSTRINGV_cfCC(T,A,B) B.fs
+#endif
+#endif
+#define ZTRINGV_cfCC(T,A,B) STRINGV_cfCC(T,A,B)
+#define PZTRINGV_cfCC(T,A,B) PSTRINGV_cfCC(T,A,B)
+
+#define BYTE_cfX return A0;
+#define DOUBLE_cfX return A0;
+#if ! (defined(FLOATFUNCTIONTYPE)&&defined(ASSIGNFLOAT)&&defined(RETURNFLOAT))
+#define FLOAT_cfX return A0;
+#else
+#define FLOAT_cfX ASSIGNFLOAT(AA0,A0); return AA0;
+#endif
+#define INT_cfX return A0;
+#define LOGICAL_cfX return F2CLOGICAL(A0);
+#define LONG_cfX return A0;
+#define SHORT_cfX return A0;
+#define VOID_cfX return ;
+#if defined(vmsFortran) || defined(CRAYFortran)
+#define STRING_cfX return kill_trailing( \
+ kill_trailing(AA0,CFORTRAN_NON_CHAR),' ');
+#else
+#define STRING_cfX return kill_trailing( \
+ kill_trailing( A0,CFORTRAN_NON_CHAR),' ');
+#endif
+
+#define CFFUN(NAME) _(__cf__,NAME)
+
+/* Note that we don't use LN here, but we keep it for consistency. */
+#define CCALLSFFUN0(UN,LN) CFFUN(UN)()
+
+#ifdef OLD_VAXC /* Allow %CC-I-PARAMNOTUSED. */
+#pragma standard
+#endif
+
+#define CCALLSFFUN1( UN,LN,T1, A1) \
+ CCALLSFFUN5 (UN,LN,T1,CF_0,CF_0,CF_0,CF_0,A1,0,0,0,0)
+#define CCALLSFFUN2( UN,LN,T1,T2, A1,A2) \
+ CCALLSFFUN5 (UN,LN,T1,T2,CF_0,CF_0,CF_0,A1,A2,0,0,0)
+#define CCALLSFFUN3( UN,LN,T1,T2,T3, A1,A2,A3) \
+ CCALLSFFUN5 (UN,LN,T1,T2,T3,CF_0,CF_0,A1,A2,A3,0,0)
+#define CCALLSFFUN4( UN,LN,T1,T2,T3,T4, A1,A2,A3,A4)\
+ CCALLSFFUN5 (UN,LN,T1,T2,T3,T4,CF_0,A1,A2,A3,A4,0)
+#define CCALLSFFUN5( UN,LN,T1,T2,T3,T4,T5, A1,A2,A3,A4,A5) \
+ CCALLSFFUN10(UN,LN,T1,T2,T3,T4,T5,CF_0,CF_0,CF_0,CF_0,CF_0,A1,A2,A3,A4,A5,0,0,0,0,0)
+#define CCALLSFFUN6( UN,LN,T1,T2,T3,T4,T5,T6, A1,A2,A3,A4,A5,A6) \
+ CCALLSFFUN10(UN,LN,T1,T2,T3,T4,T5,T6,CF_0,CF_0,CF_0,CF_0,A1,A2,A3,A4,A5,A6,0,0,0,0)
+#define CCALLSFFUN7( UN,LN,T1,T2,T3,T4,T5,T6,T7, A1,A2,A3,A4,A5,A6,A7) \
+ CCALLSFFUN10(UN,LN,T1,T2,T3,T4,T5,T6,T7,CF_0,CF_0,CF_0,A1,A2,A3,A4,A5,A6,A7,0,0,0)
+#define CCALLSFFUN8( UN,LN,T1,T2,T3,T4,T5,T6,T7,T8, A1,A2,A3,A4,A5,A6,A7,A8) \
+ CCALLSFFUN10(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,CF_0,CF_0,A1,A2,A3,A4,A5,A6,A7,A8,0,0)
+#define CCALLSFFUN9( UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,A1,A2,A3,A4,A5,A6,A7,A8,A9)\
+ CCALLSFFUN10(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,CF_0,A1,A2,A3,A4,A5,A6,A7,A8,A9,0)
+#define CCALLSFFUN10(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA)\
+ CCALLSFFUN14(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,CF_0,CF_0,CF_0,CF_0,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,0,0,0,0)
+#define CCALLSFFUN11(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB)\
+ CCALLSFFUN14(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,CF_0,CF_0,CF_0,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,0,0,0)
+#define CCALLSFFUN12(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC)\
+ CCALLSFFUN14(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,CF_0,CF_0,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,0,0)
+#define CCALLSFFUN13(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,AD)\
+ CCALLSFFUN14(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,CF_0,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,AD,0)
+
+#define CCALLSFFUN14(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,AD,AE)\
+((CFFUN(UN)( BCF(T1,A1,0) BCF(T2,A2,1) BCF(T3,A3,1) BCF(T4,A4,1) BCF(T5,A5,1) \
+ BCF(T6,A6,1) BCF(T7,A7,1) BCF(T8,A8,1) BCF(T9,A9,1) BCF(TA,AA,1) \
+ BCF(TB,AB,1) BCF(TC,AC,1) BCF(TD,AD,1) BCF(TE,AE,1) \
+ SCF(T1,LN,1,A1) SCF(T2,LN,2,A2) SCF(T3,LN,3,A3) SCF(T4,LN,4,A4) \
+ SCF(T5,LN,5,A5) SCF(T6,LN,6,A6) SCF(T7,LN,7,A7) SCF(T8,LN,8,A8) \
+ SCF(T9,LN,9,A9) SCF(TA,LN,10,AA) SCF(TB,LN,11,AB) SCF(TC,LN,12,AC) \
+ SCF(TD,LN,13,AD) SCF(TE,LN,14,AE))))
+
+/* N.B. Create a separate function instead of using (call function, function
+value here) because in order to create the variables needed for the input
+arg.'s which may be const.'s one has to do the creation within {}, but these
+can never be placed within ()'s. Therefore one must create wrapper functions.
+gcc, on the other hand may be able to avoid the wrapper functions. */
+
+/* Prototypes are needed to correctly handle the value returned correctly. N.B.
+Can only have prototype arg.'s with difficulty, a la G... table since FORTRAN
+functions returning strings have extra arg.'s. Don't bother, since this only
+causes a compiler warning to come up when one uses FCALLSCFUNn and CCALLSFFUNn
+for the same function in the same source code. Something done by the experts in
+debugging only.*/
+
+#define PROTOCCALLSFFUN0(F,UN,LN) \
+_(F,_cfPU)( CFC_(UN,LN))(CF_NULL_PROTO); \
+static _Icf(2,U,F,CFFUN(UN),0)() {_(F,_cfE) _Icf(3,GZ,F,UN,LN) ABSOFT_cf1(F));_(F,_cfX)}
+
+#define PROTOCCALLSFFUN1( T0,UN,LN,T1) \
+ PROTOCCALLSFFUN5 (T0,UN,LN,T1,CF_0,CF_0,CF_0,CF_0)
+#define PROTOCCALLSFFUN2( T0,UN,LN,T1,T2) \
+ PROTOCCALLSFFUN5 (T0,UN,LN,T1,T2,CF_0,CF_0,CF_0)
+#define PROTOCCALLSFFUN3( T0,UN,LN,T1,T2,T3) \
+ PROTOCCALLSFFUN5 (T0,UN,LN,T1,T2,T3,CF_0,CF_0)
+#define PROTOCCALLSFFUN4( T0,UN,LN,T1,T2,T3,T4) \
+ PROTOCCALLSFFUN5 (T0,UN,LN,T1,T2,T3,T4,CF_0)
+#define PROTOCCALLSFFUN5( T0,UN,LN,T1,T2,T3,T4,T5) \
+ PROTOCCALLSFFUN10(T0,UN,LN,T1,T2,T3,T4,T5,CF_0,CF_0,CF_0,CF_0,CF_0)
+#define PROTOCCALLSFFUN6( T0,UN,LN,T1,T2,T3,T4,T5,T6) \
+ PROTOCCALLSFFUN10(T0,UN,LN,T1,T2,T3,T4,T5,T6,CF_0,CF_0,CF_0,CF_0)
+#define PROTOCCALLSFFUN7( T0,UN,LN,T1,T2,T3,T4,T5,T6,T7) \
+ PROTOCCALLSFFUN10(T0,UN,LN,T1,T2,T3,T4,T5,T6,T7,CF_0,CF_0,CF_0)
+#define PROTOCCALLSFFUN8( T0,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8) \
+ PROTOCCALLSFFUN10(T0,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,CF_0,CF_0)
+#define PROTOCCALLSFFUN9( T0,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9) \
+ PROTOCCALLSFFUN10(T0,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,CF_0)
+#define PROTOCCALLSFFUN10(T0,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA) \
+ PROTOCCALLSFFUN14(T0,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,CF_0,CF_0,CF_0,CF_0)
+#define PROTOCCALLSFFUN11(T0,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB) \
+ PROTOCCALLSFFUN14(T0,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,CF_0,CF_0,CF_0)
+#define PROTOCCALLSFFUN12(T0,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC) \
+ PROTOCCALLSFFUN14(T0,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,CF_0,CF_0)
+#define PROTOCCALLSFFUN13(T0,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD) \
+ PROTOCCALLSFFUN14(T0,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,CF_0)
+
+/* HP/UX 9.01 cc requires the blank between '_Icf(3,G,T0,UN,LN) CCCF(T1,1,0)' */
+
+#ifndef __CF__KnR
+#define PROTOCCALLSFFUN14(T0,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE) \
+ _(T0,_cfPU)(CFC_(UN,LN))(CF_NULL_PROTO); static _Icf(2,U,T0,CFFUN(UN),0)( \
+ CFARGT14FS(UCF,HCF,_Z,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE) ) \
+{ CFARGT14S(VCF,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE) _(T0,_cfE) \
+ CCF(LN,T1,1) CCF(LN,T2,2) CCF(LN,T3,3) CCF(LN,T4,4) CCF(LN,T5,5) \
+ CCF(LN,T6,6) CCF(LN,T7,7) CCF(LN,T8,8) CCF(LN,T9,9) CCF(LN,TA,10) \
+ CCF(LN,TB,11) CCF(LN,TC,12) CCF(LN,TD,13) CCF(LN,TE,14) _Icf(3,G,T0,UN,LN) \
+ CFARGT14(CCCF,JCF,ABSOFT_cf1(T0),T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE)); \
+ WCF(T1,A1,1) WCF(T2,A2,2) WCF(T3,A3,3) WCF(T4,A4,4) WCF(T5,A5,5) \
+ WCF(T6,A6,6) WCF(T7,A7,7) WCF(T8,A8,8) WCF(T9,A9,9) WCF(TA,A10,10) \
+ WCF(TB,A11,11) WCF(TC,A12,12) WCF(TD,A13,13) WCF(TE,A14,14) _(T0,_cfX)}
+#else
+#define PROTOCCALLSFFUN14(T0,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE) \
+ _(T0,_cfPU)(CFC_(UN,LN))(CF_NULL_PROTO); static _Icf(2,U,T0,CFFUN(UN),0)( \
+ CFARGT14FS(UUCF,HHCF,_Z,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE) ) \
+ CFARGT14FS(UUUCF,HHHCF,_Z,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE) ; \
+{ CFARGT14S(VCF,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE) _(T0,_cfE) \
+ CCF(LN,T1,1) CCF(LN,T2,2) CCF(LN,T3,3) CCF(LN,T4,4) CCF(LN,T5,5) \
+ CCF(LN,T6,6) CCF(LN,T7,7) CCF(LN,T8,8) CCF(LN,T9,9) CCF(LN,TA,10) \
+ CCF(LN,TB,11) CCF(LN,TC,12) CCF(LN,TD,13) CCF(LN,TE,14) _Icf(3,G,T0,UN,LN) \
+ CFARGT14(CCCF,JCF,ABSOFT_cf1(T0),T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE)); \
+ WCF(T1,A1,1) WCF(T2,A2,2) WCF(T3,A3,3) WCF(T4,A4,4) WCF(T5,A5,5) \
+ WCF(T6,A6,6) WCF(T7,A7,7) WCF(T8,A8,8) WCF(T9,A9,9) WCF(TA,A10,10) \
+ WCF(TB,A11,11) WCF(TC,A12,12) WCF(TD,A13,13) WCF(TE,A14,14) _(T0,_cfX)}
+#endif
+
+/*-------------------------------------------------------------------------*/
+
+/* UTILITIES FOR FORTRAN TO CALL C ROUTINES */
+
+#ifdef OLD_VAXC /* Prevent %CC-I-PARAMNOTUSED. */
+#pragma nostandard
+#endif
+
+#if defined(vmsFortran) || defined(CRAYFortran)
+#define DCF(TN,I)
+#define DDCF(TN,I)
+#define DDDCF(TN,I)
+#else
+#define DCF(TN,I) HCF(TN,I)
+#define DDCF(TN,I) HHCF(TN,I)
+#define DDDCF(TN,I) HHHCF(TN,I)
+#endif
+
+#define QCF(TN,I) _(TN,_cfSTR)(1,Q,_(B,I), 0,0,0,0)
+#define DEFAULT_cfQ(B)
+#define LOGICAL_cfQ(B)
+#define PLOGICAL_cfQ(B)
+#define STRINGV_cfQ(B) char *B; unsigned int _(B,N);
+#define STRING_cfQ(B) char *B=NULL;
+#define PSTRING_cfQ(B) char *B=NULL;
+#define PSTRINGV_cfQ(B) STRINGV_cfQ(B)
+#define PNSTRING_cfQ(B) char *B=NULL;
+#define PPSTRING_cfQ(B)
+
+#ifdef __sgi /* Else SGI gives warning 182 contrary to its C LRM A.17.7 */
+#define ROUTINE_orig *(void**)&
+#else
+#define ROUTINE_orig (void *)
+#endif
+
+#define ROUTINE_1 ROUTINE_orig
+#define ROUTINE_2 ROUTINE_orig
+#define ROUTINE_3 ROUTINE_orig
+#define ROUTINE_4 ROUTINE_orig
+#define ROUTINE_5 ROUTINE_orig
+#define ROUTINE_6 ROUTINE_orig
+#define ROUTINE_7 ROUTINE_orig
+#define ROUTINE_8 ROUTINE_orig
+#define ROUTINE_9 ROUTINE_orig
+#define ROUTINE_10 ROUTINE_orig
+#define ROUTINE_11 ROUTINE_orig
+#define ROUTINE_12 ROUTINE_orig
+#define ROUTINE_13 ROUTINE_orig
+#define ROUTINE_14 ROUTINE_orig
+#define ROUTINE_15 ROUTINE_orig
+#define ROUTINE_16 ROUTINE_orig
+#define ROUTINE_17 ROUTINE_orig
+#define ROUTINE_18 ROUTINE_orig
+#define ROUTINE_19 ROUTINE_orig
+#define ROUTINE_20 ROUTINE_orig
+#define ROUTINE_21 ROUTINE_orig
+#define ROUTINE_22 ROUTINE_orig
+#define ROUTINE_23 ROUTINE_orig
+#define ROUTINE_24 ROUTINE_orig
+#define ROUTINE_25 ROUTINE_orig
+#define ROUTINE_26 ROUTINE_orig
+#define ROUTINE_27 ROUTINE_orig
+
+#define TCF(NAME,TN,I,M) _SEP_(TN,M,cfCOMMA) _(TN,_cfT)(NAME,I,_(A,I),_(B,I),_(C,I))
+#define BYTE_cfT(M,I,A,B,D) *A
+#define DOUBLE_cfT(M,I,A,B,D) *A
+#define FLOAT_cfT(M,I,A,B,D) *A
+#define INT_cfT(M,I,A,B,D) *A
+#define LOGICAL_cfT(M,I,A,B,D) F2CLOGICAL(*A)
+#define LONG_cfT(M,I,A,B,D) *A
+#define LONGLONG_cfT(M,I,A,B,D) *A /* added by MR December 2005 */
+#define SHORT_cfT(M,I,A,B,D) *A
+#define BYTEV_cfT(M,I,A,B,D) A
+#define DOUBLEV_cfT(M,I,A,B,D) A
+#define FLOATV_cfT(M,I,A,B,D) VOIDP A
+#define INTV_cfT(M,I,A,B,D) A
+#define LOGICALV_cfT(M,I,A,B,D) A
+#define LONGV_cfT(M,I,A,B,D) A
+#define LONGLONGV_cfT(M,I,A,B,D) A /* added by MR December 2005 */
+#define SHORTV_cfT(M,I,A,B,D) A
+#define BYTEVV_cfT(M,I,A,B,D) (void *)A /* We have to cast to void *,*/
+#define BYTEVVV_cfT(M,I,A,B,D) (void *)A /* since we don't know the */
+#define BYTEVVVV_cfT(M,I,A,B,D) (void *)A /* dimensions of the array. */
+#define BYTEVVVVV_cfT(M,I,A,B,D) (void *)A /* i.e. Unfortunately, can't */
+#define BYTEVVVVVV_cfT(M,I,A,B,D) (void *)A /* check that the type */
+#define BYTEVVVVVVV_cfT(M,I,A,B,D) (void *)A /* matches the prototype. */
+#define DOUBLEVV_cfT(M,I,A,B,D) (void *)A
+#define DOUBLEVVV_cfT(M,I,A,B,D) (void *)A
+#define DOUBLEVVVV_cfT(M,I,A,B,D) (void *)A
+#define DOUBLEVVVVV_cfT(M,I,A,B,D) (void *)A
+#define DOUBLEVVVVVV_cfT(M,I,A,B,D) (void *)A
+#define DOUBLEVVVVVVV_cfT(M,I,A,B,D) (void *)A
+#define FLOATVV_cfT(M,I,A,B,D) (void *)A
+#define FLOATVVV_cfT(M,I,A,B,D) (void *)A
+#define FLOATVVVV_cfT(M,I,A,B,D) (void *)A
+#define FLOATVVVVV_cfT(M,I,A,B,D) (void *)A
+#define FLOATVVVVVV_cfT(M,I,A,B,D) (void *)A
+#define FLOATVVVVVVV_cfT(M,I,A,B,D) (void *)A
+#define INTVV_cfT(M,I,A,B,D) (void *)A
+#define INTVVV_cfT(M,I,A,B,D) (void *)A
+#define INTVVVV_cfT(M,I,A,B,D) (void *)A
+#define INTVVVVV_cfT(M,I,A,B,D) (void *)A
+#define INTVVVVVV_cfT(M,I,A,B,D) (void *)A
+#define INTVVVVVVV_cfT(M,I,A,B,D) (void *)A
+#define LOGICALVV_cfT(M,I,A,B,D) (void *)A
+#define LOGICALVVV_cfT(M,I,A,B,D) (void *)A
+#define LOGICALVVVV_cfT(M,I,A,B,D) (void *)A
+#define LOGICALVVVVV_cfT(M,I,A,B,D) (void *)A
+#define LOGICALVVVVVV_cfT(M,I,A,B,D) (void *)A
+#define LOGICALVVVVVVV_cfT(M,I,A,B,D) (void *)A
+#define LONGVV_cfT(M,I,A,B,D) (void *)A
+#define LONGVVV_cfT(M,I,A,B,D) (void *)A
+#define LONGVVVV_cfT(M,I,A,B,D) (void *)A
+#define LONGVVVVV_cfT(M,I,A,B,D) (void *)A
+#define LONGVVVVVV_cfT(M,I,A,B,D) (void *)A
+#define LONGVVVVVVV_cfT(M,I,A,B,D) (void *)A
+#define LONGLONGVV_cfT(M,I,A,B,D) (void *)A /* added by MR December 2005 */
+#define LONGLONGVVV_cfT(M,I,A,B,D) (void *)A /* added by MR December 2005 */
+#define LONGLONGVVVV_cfT(M,I,A,B,D) (void *)A /* added by MR December 2005 */
+#define LONGLONGVVVVV_cfT(M,I,A,B,D) (void *)A /* added by MR December 2005 */
+#define LONGLONGVVVVVV_cfT(M,I,A,B,D) (void *)A /* added by MR December 2005 */
+#define LONGLONGVVVVVVV_cfT(M,I,A,B,D) (void *)A /* added by MR December 2005 */
+#define SHORTVV_cfT(M,I,A,B,D) (void *)A
+#define SHORTVVV_cfT(M,I,A,B,D) (void *)A
+#define SHORTVVVV_cfT(M,I,A,B,D) (void *)A
+#define SHORTVVVVV_cfT(M,I,A,B,D) (void *)A
+#define SHORTVVVVVV_cfT(M,I,A,B,D) (void *)A
+#define SHORTVVVVVVV_cfT(M,I,A,B,D) (void *)A
+#define PBYTE_cfT(M,I,A,B,D) A
+#define PDOUBLE_cfT(M,I,A,B,D) A
+#define PFLOAT_cfT(M,I,A,B,D) VOIDP A
+#define PINT_cfT(M,I,A,B,D) A
+#define PLOGICAL_cfT(M,I,A,B,D) ((*A=F2CLOGICAL(*A)),A)
+#define PLONG_cfT(M,I,A,B,D) A
+#define PLONGLONG_cfT(M,I,A,B,D) A /* added by MR December 2005 */
+#define PSHORT_cfT(M,I,A,B,D) A
+#define PVOID_cfT(M,I,A,B,D) A
+#if defined(apolloFortran) || defined(hpuxFortran800) || defined(AbsoftUNIXFortran)
+#define ROUTINE_cfT(M,I,A,B,D) _(ROUTINE_,I) (*A)
+#else
+#define ROUTINE_cfT(M,I,A,B,D) _(ROUTINE_,I) A
+#endif
+/* A == pointer to the characters
+ D == length of the string, or of an element in an array of strings
+ E == number of elements in an array of strings */
+#define TTSTR( A,B,D) \
+ ((B=_cf_malloc(D+1))[D]='\0', memcpy(B,A,D), kill_trailing(B,' '))
+#define TTTTSTR( A,B,D) (!(D<4||A[0]||A[1]||A[2]||A[3]))?NULL: \
+ memchr(A,'\0',D) ?A : TTSTR(A,B,D)
+#define TTTTSTRV( A,B,D,E) (_(B,N)=E,B=_cf_malloc(_(B,N)*(D+1)), (void *) \
+ vkill_trailing(f2cstrv(A,B,D+1, _(B,N)*(D+1)), D+1,_(B,N)*(D+1),' '))
+#ifdef vmsFortran
+#define STRING_cfT(M,I,A,B,D) TTTTSTR( A->dsc$a_pointer,B,A->dsc$w_length)
+#define STRINGV_cfT(M,I,A,B,D) TTTTSTRV(A->dsc$a_pointer, B, \
+ A->dsc$w_length , A->dsc$l_m[0])
+#define PSTRING_cfT(M,I,A,B,D) TTSTR( A->dsc$a_pointer,B,A->dsc$w_length)
+#define PPSTRING_cfT(M,I,A,B,D) A->dsc$a_pointer
+#else
+#ifdef CRAYFortran
+#define STRING_cfT(M,I,A,B,D) TTTTSTR( _fcdtocp(A),B,_fcdlen(A))
+#define STRINGV_cfT(M,I,A,B,D) TTTTSTRV(_fcdtocp(A),B,_fcdlen(A), \
+ num_elem(_fcdtocp(A),_fcdlen(A),_3(M,_STRV_A,I)))
+#define PSTRING_cfT(M,I,A,B,D) TTSTR( _fcdtocp(A),B,_fcdlen(A))
+#define PPSTRING_cfT(M,I,A,B,D) _fcdtocp(A)
+#else
+#define STRING_cfT(M,I,A,B,D) TTTTSTR( A,B,D)
+#define STRINGV_cfT(M,I,A,B,D) TTTTSTRV(A,B,D, num_elem(A,D,_3(M,_STRV_A,I)))
+#define PSTRING_cfT(M,I,A,B,D) TTSTR( A,B,D)
+#define PPSTRING_cfT(M,I,A,B,D) A
+#endif
+#endif
+#define PNSTRING_cfT(M,I,A,B,D) STRING_cfT(M,I,A,B,D)
+#define PSTRINGV_cfT(M,I,A,B,D) STRINGV_cfT(M,I,A,B,D)
+#define CF_0_cfT(M,I,A,B,D)
+
+#define RCF(TN,I) _(TN,_cfSTR)(3,R,_(A,I),_(B,I),_(C,I),0,0)
+#define DEFAULT_cfR(A,B,D)
+#define LOGICAL_cfR(A,B,D)
+#define PLOGICAL_cfR(A,B,D) *A=C2FLOGICAL(*A);
+#define STRING_cfR(A,B,D) if (B) _cf_free(B);
+#define STRINGV_cfR(A,B,D) _cf_free(B);
+/* A and D as defined above for TSTRING(V) */
+#define RRRRPSTR( A,B,D) if (B) memcpy(A,B, _cfMIN(strlen(B),D)), \
+ (D>strlen(B)?memset(A+strlen(B),' ', D-strlen(B)):0), _cf_free(B);
+#define RRRRPSTRV(A,B,D) c2fstrv(B,A,D+1,(D+1)*_(B,N)), _cf_free(B);
+#ifdef vmsFortran
+#define PSTRING_cfR(A,B,D) RRRRPSTR( A->dsc$a_pointer,B,A->dsc$w_length)
+#define PSTRINGV_cfR(A,B,D) RRRRPSTRV(A->dsc$a_pointer,B,A->dsc$w_length)
+#else
+#ifdef CRAYFortran
+#define PSTRING_cfR(A,B,D) RRRRPSTR( _fcdtocp(A),B,_fcdlen(A))
+#define PSTRINGV_cfR(A,B,D) RRRRPSTRV(_fcdtocp(A),B,_fcdlen(A))
+#else
+#define PSTRING_cfR(A,B,D) RRRRPSTR( A,B,D)
+#define PSTRINGV_cfR(A,B,D) RRRRPSTRV(A,B,D)
+#endif
+#endif
+#define PNSTRING_cfR(A,B,D) PSTRING_cfR(A,B,D)
+#define PPSTRING_cfR(A,B,D)
+
+#define BYTE_cfFZ(UN,LN) INTEGER_BYTE FCALLSC_QUALIFIER fcallsc(UN,LN)(
+#define DOUBLE_cfFZ(UN,LN) DOUBLE_PRECISION FCALLSC_QUALIFIER fcallsc(UN,LN)(
+#define INT_cfFZ(UN,LN) int FCALLSC_QUALIFIER fcallsc(UN,LN)(
+#define LOGICAL_cfFZ(UN,LN) int FCALLSC_QUALIFIER fcallsc(UN,LN)(
+#define LONG_cfFZ(UN,LN) long FCALLSC_QUALIFIER fcallsc(UN,LN)(
+#define LONGLONG_cfFZ(UN,LN) LONGLONG FCALLSC_QUALIFIER fcallsc(UN,LN)( /* added by MR December 2005 */
+#define SHORT_cfFZ(UN,LN) short FCALLSC_QUALIFIER fcallsc(UN,LN)(
+#define VOID_cfFZ(UN,LN) void FCALLSC_QUALIFIER fcallsc(UN,LN)(
+#ifndef __CF__KnR
+/* The void is req'd by the Apollo, to make this an ANSI function declaration.
+ The Apollo promotes K&R float functions to double. */
+#if defined (f2cFortran) && ! defined (gFortran)
+/* f2c/g77 return double from FORTRAN REAL functions. (KMCCARTY, 2005/12/09) */
+#define FLOAT_cfFZ(UN,LN) DOUBLE_PRECISION FCALLSC_QUALIFIER fcallsc(UN,LN)(void
+#else
+#define FLOAT_cfFZ(UN,LN) FORTRAN_REAL FCALLSC_QUALIFIER fcallsc(UN,LN)(void
+#endif
+#ifdef vmsFortran
+#define STRING_cfFZ(UN,LN) void FCALLSC_QUALIFIER fcallsc(UN,LN)(fstring *AS
+#else
+#ifdef CRAYFortran
+#define STRING_cfFZ(UN,LN) void FCALLSC_QUALIFIER fcallsc(UN,LN)(_fcd AS
+#else
+#if defined(AbsoftUNIXFortran) || defined(AbsoftProFortran)
+#define STRING_cfFZ(UN,LN) void FCALLSC_QUALIFIER fcallsc(UN,LN)(char *AS
+#else
+#define STRING_cfFZ(UN,LN) void FCALLSC_QUALIFIER fcallsc(UN,LN)(char *AS, unsigned D0
+#endif
+#endif
+#endif
+#else
+#if ! (defined(FLOATFUNCTIONTYPE)&&defined(ASSIGNFLOAT)&&defined(RETURNFLOAT))
+#if defined (f2cFortran) && ! defined (gFortran)
+/* f2c/g77 return double from FORTRAN REAL functions. (KMCCARTY, 2005/12/09) */
+#define FLOAT_cfFZ(UN,LN) DOUBLE_PRECISION FCALLSC_QUALIFIER fcallsc(UN,LN)(
+#else
+#define FLOAT_cfFZ(UN,LN) FORTRAN_REAL FCALLSC_QUALIFIER fcallsc(UN,LN)(
+#endif
+#else
+#define FLOAT_cfFZ(UN,LN) FLOATFUNCTIONTYPE FCALLSC_QUALIFIER fcallsc(UN,LN)(
+#endif
+#if defined(vmsFortran) || defined(CRAYFortran) || defined(AbsoftUNIXFortran)
+#define STRING_cfFZ(UN,LN) void FCALLSC_QUALIFIER fcallsc(UN,LN)(AS
+#else
+#define STRING_cfFZ(UN,LN) void FCALLSC_QUALIFIER fcallsc(UN,LN)(AS, D0
+#endif
+#endif
+
+#define BYTE_cfF(UN,LN) BYTE_cfFZ(UN,LN)
+#define DOUBLE_cfF(UN,LN) DOUBLE_cfFZ(UN,LN)
+#ifndef __CF_KnR
+#if defined (f2cFortran) && ! defined (gFortran)
+/* f2c/g77 return double from FORTRAN REAL functions. (KMCCARTY, 2005/12/09) */
+#define FLOAT_cfF(UN,LN) DOUBLE_PRECISION FCALLSC_QUALIFIER fcallsc(UN,LN)(
+#else
+#define FLOAT_cfF(UN,LN) FORTRAN_REAL FCALLSC_QUALIFIER fcallsc(UN,LN)(
+#endif
+#else
+#define FLOAT_cfF(UN,LN) FLOAT_cfFZ(UN,LN)
+#endif
+#define INT_cfF(UN,LN) INT_cfFZ(UN,LN)
+#define LOGICAL_cfF(UN,LN) LOGICAL_cfFZ(UN,LN)
+#define LONG_cfF(UN,LN) LONG_cfFZ(UN,LN)
+#define LONGLONG_cfF(UN,LN) LONGLONG_cfFZ(UN,LN) /* added by MR December 2005 */
+#define SHORT_cfF(UN,LN) SHORT_cfFZ(UN,LN)
+#define VOID_cfF(UN,LN) VOID_cfFZ(UN,LN)
+#define STRING_cfF(UN,LN) STRING_cfFZ(UN,LN),
+
+#define INT_cfFF
+#define VOID_cfFF
+#ifdef vmsFortran
+#define STRING_cfFF fstring *AS;
+#else
+#ifdef CRAYFortran
+#define STRING_cfFF _fcd AS;
+#else
+#define STRING_cfFF char *AS; unsigned D0;
+#endif
+#endif
+
+#define INT_cfL A0=
+#define STRING_cfL A0=
+#define VOID_cfL
+
+#define INT_cfK
+#define VOID_cfK
+/* KSTRING copies the string into the position provided by the caller. */
+#ifdef vmsFortran
+#define STRING_cfK \
+ memcpy(AS->dsc$a_pointer,A0,_cfMIN(AS->dsc$w_length,(A0==NULL?0:strlen(A0))));\
+ AS->dsc$w_length>(A0==NULL?0:strlen(A0))? \
+ memset(AS->dsc$a_pointer+(A0==NULL?0:strlen(A0)),' ', \
+ AS->dsc$w_length-(A0==NULL?0:strlen(A0))):0;
+#else
+#ifdef CRAYFortran
+#define STRING_cfK \
+ memcpy(_fcdtocp(AS),A0, _cfMIN(_fcdlen(AS),(A0==NULL?0:strlen(A0))) ); \
+ _fcdlen(AS)>(A0==NULL?0:strlen(A0))? \
+ memset(_fcdtocp(AS)+(A0==NULL?0:strlen(A0)),' ', \
+ _fcdlen(AS)-(A0==NULL?0:strlen(A0))):0;
+#else
+#define STRING_cfK memcpy(AS,A0, _cfMIN(D0,(A0==NULL?0:strlen(A0))) ); \
+ D0>(A0==NULL?0:strlen(A0))?memset(AS+(A0==NULL?0:strlen(A0)), \
+ ' ', D0-(A0==NULL?0:strlen(A0))):0;
+#endif
+#endif
+
+/* Note that K.. and I.. can't be combined since K.. has to access data before
+R.., in order for functions returning strings which are also passed in as
+arguments to work correctly. Note that R.. frees and hence may corrupt the
+string. */
+#define BYTE_cfI return A0;
+#define DOUBLE_cfI return A0;
+#if ! (defined(FLOATFUNCTIONTYPE)&&defined(ASSIGNFLOAT)&&defined(RETURNFLOAT))
+#define FLOAT_cfI return A0;
+#else
+#define FLOAT_cfI RETURNFLOAT(A0);
+#endif
+#define INT_cfI return A0;
+#ifdef hpuxFortran800
+/* Incredibly, functions must return true as 1, elsewhere .true.==0x01000000. */
+#define LOGICAL_cfI return ((A0)?1:0);
+#else
+#define LOGICAL_cfI return C2FLOGICAL(A0);
+#endif
+#define LONG_cfI return A0;
+#define LONGLONG_cfI return A0; /* added by MR December 2005 */
+#define SHORT_cfI return A0;
+#define STRING_cfI return ;
+#define VOID_cfI return ;
+
+#ifdef OLD_VAXC /* Allow %CC-I-PARAMNOTUSED. */
+#pragma standard
+#endif
+
+#define FCALLSCSUB0( CN,UN,LN) FCALLSCFUN0(VOID,CN,UN,LN)
+#define FCALLSCSUB1( CN,UN,LN,T1) FCALLSCFUN1(VOID,CN,UN,LN,T1)
+#define FCALLSCSUB2( CN,UN,LN,T1,T2) FCALLSCFUN2(VOID,CN,UN,LN,T1,T2)
+#define FCALLSCSUB3( CN,UN,LN,T1,T2,T3) FCALLSCFUN3(VOID,CN,UN,LN,T1,T2,T3)
+#define FCALLSCSUB4( CN,UN,LN,T1,T2,T3,T4) \
+ FCALLSCFUN4(VOID,CN,UN,LN,T1,T2,T3,T4)
+#define FCALLSCSUB5( CN,UN,LN,T1,T2,T3,T4,T5) \
+ FCALLSCFUN5(VOID,CN,UN,LN,T1,T2,T3,T4,T5)
+#define FCALLSCSUB6( CN,UN,LN,T1,T2,T3,T4,T5,T6) \
+ FCALLSCFUN6(VOID,CN,UN,LN,T1,T2,T3,T4,T5,T6)
+#define FCALLSCSUB7( CN,UN,LN,T1,T2,T3,T4,T5,T6,T7) \
+ FCALLSCFUN7(VOID,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7)
+#define FCALLSCSUB8( CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8) \
+ FCALLSCFUN8(VOID,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8)
+#define FCALLSCSUB9( CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9) \
+ FCALLSCFUN9(VOID,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9)
+#define FCALLSCSUB10(CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA) \
+ FCALLSCFUN10(VOID,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA)
+#define FCALLSCSUB11(CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB) \
+ FCALLSCFUN11(VOID,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB)
+#define FCALLSCSUB12(CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC) \
+ FCALLSCFUN12(VOID,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC)
+#define FCALLSCSUB13(CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD) \
+ FCALLSCFUN13(VOID,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD)
+#define FCALLSCSUB14(CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE) \
+ FCALLSCFUN14(VOID,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE)
+#define FCALLSCSUB15(CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF) \
+ FCALLSCFUN15(VOID,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF)
+#define FCALLSCSUB16(CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG) \
+ FCALLSCFUN16(VOID,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG)
+#define FCALLSCSUB17(CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH) \
+ FCALLSCFUN17(VOID,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH)
+#define FCALLSCSUB18(CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI) \
+ FCALLSCFUN18(VOID,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI)
+#define FCALLSCSUB19(CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ) \
+ FCALLSCFUN19(VOID,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ)
+#define FCALLSCSUB20(CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK) \
+ FCALLSCFUN20(VOID,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK)
+#define FCALLSCSUB21(CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL) \
+ FCALLSCFUN21(VOID,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL)
+#define FCALLSCSUB22(CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM) \
+ FCALLSCFUN22(VOID,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM)
+#define FCALLSCSUB23(CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN) \
+ FCALLSCFUN23(VOID,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN)
+#define FCALLSCSUB24(CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO) \
+ FCALLSCFUN24(VOID,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO)
+#define FCALLSCSUB25(CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,TP) \
+ FCALLSCFUN25(VOID,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,TP)
+#define FCALLSCSUB26(CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,TP,TQ) \
+ FCALLSCFUN26(VOID,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,TP,TQ)
+#define FCALLSCSUB27(CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,TP,TQ,TR) \
+ FCALLSCFUN27(VOID,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,TP,TQ,TR)
+
+
+#define FCALLSCFUN1( T0,CN,UN,LN,T1) \
+ FCALLSCFUN5 (T0,CN,UN,LN,T1,CF_0,CF_0,CF_0,CF_0)
+#define FCALLSCFUN2( T0,CN,UN,LN,T1,T2) \
+ FCALLSCFUN5 (T0,CN,UN,LN,T1,T2,CF_0,CF_0,CF_0)
+#define FCALLSCFUN3( T0,CN,UN,LN,T1,T2,T3) \
+ FCALLSCFUN5 (T0,CN,UN,LN,T1,T2,T3,CF_0,CF_0)
+#define FCALLSCFUN4( T0,CN,UN,LN,T1,T2,T3,T4) \
+ FCALLSCFUN5 (T0,CN,UN,LN,T1,T2,T3,T4,CF_0)
+#define FCALLSCFUN5( T0,CN,UN,LN,T1,T2,T3,T4,T5) \
+ FCALLSCFUN10(T0,CN,UN,LN,T1,T2,T3,T4,T5,CF_0,CF_0,CF_0,CF_0,CF_0)
+#define FCALLSCFUN6( T0,CN,UN,LN,T1,T2,T3,T4,T5,T6) \
+ FCALLSCFUN10(T0,CN,UN,LN,T1,T2,T3,T4,T5,T6,CF_0,CF_0,CF_0,CF_0)
+#define FCALLSCFUN7( T0,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7) \
+ FCALLSCFUN10(T0,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,CF_0,CF_0,CF_0)
+#define FCALLSCFUN8( T0,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8) \
+ FCALLSCFUN10(T0,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,CF_0,CF_0)
+#define FCALLSCFUN9( T0,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9) \
+ FCALLSCFUN10(T0,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,CF_0)
+#define FCALLSCFUN10(T0,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA) \
+ FCALLSCFUN14(T0,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,CF_0,CF_0,CF_0,CF_0)
+#define FCALLSCFUN11(T0,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB) \
+ FCALLSCFUN14(T0,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,CF_0,CF_0,CF_0)
+#define FCALLSCFUN12(T0,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC) \
+ FCALLSCFUN14(T0,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,CF_0,CF_0)
+#define FCALLSCFUN13(T0,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD) \
+ FCALLSCFUN14(T0,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,CF_0)
+
+
+#define FCALLSCFUN15(T0,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF) \
+ FCALLSCFUN20(T0,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,CF_0,CF_0,CF_0,CF_0,CF_0)
+#define FCALLSCFUN16(T0,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG) \
+ FCALLSCFUN20(T0,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,CF_0,CF_0,CF_0,CF_0)
+#define FCALLSCFUN17(T0,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH) \
+ FCALLSCFUN20(T0,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,CF_0,CF_0,CF_0)
+#define FCALLSCFUN18(T0,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI) \
+ FCALLSCFUN20(T0,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,CF_0,CF_0)
+#define FCALLSCFUN19(T0,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ) \
+ FCALLSCFUN20(T0,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,CF_0)
+#define FCALLSCFUN20(T0,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK) \
+ FCALLSCFUN27(T0,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,CF_0,CF_0,CF_0,CF_0,CF_0,CF_0,CF_0)
+#define FCALLSCFUN21(T0,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL) \
+ FCALLSCFUN27(T0,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,CF_0,CF_0,CF_0,CF_0,CF_0,CF_0)
+#define FCALLSCFUN22(T0,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM) \
+ FCALLSCFUN27(T0,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,CF_0,CF_0,CF_0,CF_0,CF_0)
+#define FCALLSCFUN23(T0,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN) \
+ FCALLSCFUN27(T0,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,CF_0,CF_0,CF_0,CF_0)
+#define FCALLSCFUN24(T0,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO) \
+ FCALLSCFUN27(T0,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,CF_0,CF_0,CF_0)
+#define FCALLSCFUN25(T0,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,TP) \
+ FCALLSCFUN27(T0,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,TP,CF_0,CF_0)
+#define FCALLSCFUN26(T0,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,TP,TQ) \
+ FCALLSCFUN27(T0,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,TP,TQ,CF_0)
+
+
+#ifndef __CF__KnR
+#define FCALLSCFUN0(T0,CN,UN,LN) CFextern _(T0,_cfFZ)(UN,LN) ABSOFT_cf2(T0)) \
+ {_Icf(2,UU,T0,A0,0); _Icf(0,L,T0,0,0) CN(); _Icf(0,K,T0,0,0) _(T0,_cfI)}
+
+#define FCALLSCFUN14(T0,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE) \
+ CFextern _(T0,_cfF)(UN,LN) \
+ CFARGT14(NCF,DCF,ABSOFT_cf2(T0),T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE) ) \
+ { CFARGT14S(QCF,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE) \
+ _Icf(2,UU,T0,A0,0); _Icf(0,L,T0,0,0) CN( TCF(LN,T1,1,0) TCF(LN,T2,2,1) \
+ TCF(LN,T3,3,1) TCF(LN,T4,4,1) TCF(LN,T5,5,1) TCF(LN,T6,6,1) TCF(LN,T7,7,1) \
+ TCF(LN,T8,8,1) TCF(LN,T9,9,1) TCF(LN,TA,10,1) TCF(LN,TB,11,1) TCF(LN,TC,12,1) \
+ TCF(LN,TD,13,1) TCF(LN,TE,14,1) ); _Icf(0,K,T0,0,0) \
+ CFARGT14S(RCF,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE) _(T0,_cfI) }
+
+#define FCALLSCFUN27(T0,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,TP,TQ,TR) \
+ CFextern _(T0,_cfF)(UN,LN) \
+ CFARGT27(NCF,DCF,ABSOFT_cf2(T0),T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,TP,TQ,TR) ) \
+ { CFARGT27S(QCF,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,TP,TQ,TR) \
+ _Icf(2,UU,T0,A0,0); _Icf(0,L,T0,0,0) CN( TCF(LN,T1,1,0) TCF(LN,T2,2,1) \
+ TCF(LN,T3,3,1) TCF(LN,T4,4,1) TCF(LN,T5,5,1) TCF(LN,T6,6,1) TCF(LN,T7,7,1) \
+ TCF(LN,T8,8,1) TCF(LN,T9,9,1) TCF(LN,TA,10,1) TCF(LN,TB,11,1) TCF(LN,TC,12,1) \
+ TCF(LN,TD,13,1) TCF(LN,TE,14,1) TCF(LN,TF,15,1) TCF(LN,TG,16,1) TCF(LN,TH,17,1) \
+ TCF(LN,TI,18,1) TCF(LN,TJ,19,1) TCF(LN,TK,20,1) TCF(LN,TL,21,1) TCF(LN,TM,22,1) \
+ TCF(LN,TN,23,1) TCF(LN,TO,24,1) TCF(LN,TP,25,1) TCF(LN,TQ,26,1) TCF(LN,TR,27,1) ); _Icf(0,K,T0,0,0) \
+ CFARGT27S(RCF,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,TP,TQ,TR) _(T0,_cfI) }
+
+#else
+#define FCALLSCFUN0(T0,CN,UN,LN) CFextern _(T0,_cfFZ)(UN,LN) ABSOFT_cf3(T0)) _Icf(0,FF,T0,0,0)\
+ {_Icf(2,UU,T0,A0,0); _Icf(0,L,T0,0,0) CN(); _Icf(0,K,T0,0,0) _(T0,_cfI)}
+
+#define FCALLSCFUN14(T0,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE) \
+ CFextern _(T0,_cfF)(UN,LN) \
+ CFARGT14(NNCF,DDCF,ABSOFT_cf3(T0),T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE)) _Icf(0,FF,T0,0,0) \
+ CFARGT14FS(NNNCF,DDDCF,_Z,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE); \
+ { CFARGT14S(QCF,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE) \
+ _Icf(2,UU,T0,A0,0); _Icf(0,L,T0,0,0) CN( TCF(LN,T1,1,0) TCF(LN,T2,2,1) \
+ TCF(LN,T3,3,1) TCF(LN,T4,4,1) TCF(LN,T5,5,1) TCF(LN,T6,6,1) TCF(LN,T7,7,1) \
+ TCF(LN,T8,8,1) TCF(LN,T9,9,1) TCF(LN,TA,10,1) TCF(LN,TB,11,1) TCF(LN,TC,12,1) \
+ TCF(LN,TD,13,1) TCF(LN,TE,14,1) ); _Icf(0,K,T0,0,0) \
+ CFARGT14S(RCF,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE) _(T0,_cfI)}
+
+#define FCALLSCFUN27(T0,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,TP,TQ,TR) \
+ CFextern _(T0,_cfF)(UN,LN) \
+ CFARGT27(NNCF,DDCF,ABSOFT_cf3(T0),T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,TP,TQ,TR)) _Icf(0,FF,T0,0,0) \
+ CFARGT27FS(NNNCF,DDDCF,_Z,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,TP,TQ,TR); \
+ { CFARGT27S(QCF,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,TP,TQ,TR) \
+ _Icf(2,UU,T0,A0,0); _Icf(0,L,T0,0,0) CN( TCF(LN,T1,1,0) TCF(LN,T2,2,1) \
+ TCF(LN,T3,3,1) TCF(LN,T4,4,1) TCF(LN,T5,5,1) TCF(LN,T6,6,1) TCF(LN,T7,7,1) \
+ TCF(LN,T8,8,1) TCF(LN,T9,9,1) TCF(LN,TA,10,1) TCF(LN,TB,11,1) TCF(LN,TC,12,1) \
+ TCF(LN,TD,13,1) TCF(LN,TE,14,1) TCF(LN,TF,15,1) TCF(LN,TG,16,1) TCF(LN,TH,17,1) \
+ TCF(LN,TI,18,1) TCF(LN,TJ,19,1) TCF(LN,TK,20,1) TCF(LN,TL,21,1) TCF(LN,TM,22,1) \
+ TCF(LN,TN,23,1) TCF(LN,TO,24,1) TCF(LN,TP,25,1) TCF(LN,TQ,26,1) TCF(LN,TR,27,1) ); _Icf(0,K,T0,0,0) \
+ CFARGT27S(RCF,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,TP,TQ,TR) _(T0,_cfI)}
+
+#endif
+
+
+#endif /* __CFORTRAN_LOADED */
diff --git a/CTP/daVar.h b/CTP/daVar.h
new file mode 100644
index 0000000..d2d6f8c
--- /dev/null
+++ b/CTP/daVar.h
@@ -0,0 +1,133 @@
+/*-----------------------------------------------------------------------------
+ * Copyright (c) 1993 Southeastern Universities Research Association,
+ * Continuous Electron Beam Accelerator Facility
+ *
+ * This software was developed under a United States Government license
+ * described in the NOTICE file included as part of this distribution.
+ *
+ * Stephen A. Wood, 12000 Jefferson Ave., Newport News, VA 23606
+ * Email: saw@cebaf.gov Tel: (804) 249-7367 Fax: (804) 249-5800
+ *-----------------------------------------------------------------------------
+ *
+ * Description:
+ * Include file for daVarRegister.c and anything that uses the routines in it.
+ *
+ * Author: Stephen Wood, CEBAF Hall C
+ *
+ * Revision History:
+ * $Log: daVar.h,v $
+ * Revision 1.3.24.1 2007/09/10 21:32:47 pcarter
+ * Implemented changes to allow compilation on RHEL 3,4,5 and MacOSX
+ *
+ * Revision 1.3 2003/02/21 20:55:24 saw
+ * Clean up some types and casts to reduce compiler warnings.
+ *
+ * Revision 1.2 1999/11/04 20:34:03 saw
+ * Alpha compatibility.
+ * New RPC call needed for root event display.
+ * Start of code to write ROOT trees (ntuples) from new "tree" block
+ *
+ * Revision 1.7 1999/08/25 13:16:04 saw
+ * *** empty log message ***
+ *
+ * Revision 1.6 1994/07/21 20:49:34 saw
+ * Add NOEOL error code and TRUE/FALSE definitions
+ *
+ * Revision 1.5 1994/06/13 13:39:41 saw
+ * Change values of some constants
+ *
+ * Revision 1.4 1993/11/29 16:02:02 saw
+ * Add DADOUBLE definition.
+ *
+ * Revision 1.3 1993/11/23 22:32:43 saw
+ * Add Double type definition
+ *
+ * Revision 1.2 1993/11/22 16:19:48 saw
+ * Add Fortran string type.
+ *
+ * Revision 1.1 1993/05/10 20:49:21 saw
+ * Initial revision
+ *
+ */
+
+#ifndef _DAVAR_H
+#define _DAVAR_H
+
+/* Variable types */
+
+#define DAVARINT 1
+#define DAVARFLOAT 2
+#define DAVARDOUBLE 3
+#define DAVARSTRING 4
+#define DAVARFSTRING 5
+/* For future use */
+#define DAVARINTP 17
+#define DAVARFLOATP 18
+#define DAVARDOUBLEP 19
+#define DAVARSTRINGP 20
+#define DAVARFSTRINGP 21
+/* Flags */
+
+#define DAVAR_READONLY 1
+#define DAVAR_READWRITE 0
+#define DAVAR_OBEYMF 2
+/* If set, varptr may be changed (it doesn't point to fixed "user" data) */
+#define DAVAR_REPOINTOK 4
+/* If set, this variable is a dynamically created "parm." type variable.
+ Its type and size will be adjusted */
+#define DAVAR_DYNAMIC_PAR 8
+
+#ifndef RPCGEN
+/* Make sure this stuff is not seen by rpcgen */
+typedef int daVarStatus;
+
+typedef struct {
+ char *name; /* Name of the object */
+ int type; /* Object type */
+ void *varptr; /* Pointer to the object */
+ char *title; /* Title string */
+ int size; /* Size or length of object */
+ int flag; /* Read Only and other flags */
+ void *opaque; /* Pointer to arbitrary structure */
+ daVarStatus (*rhook)();
+ daVarStatus (*whook)();
+} daVarStruct;
+/* Size is number of array elements for int for float. For strings it
+ is the maximum number of characters that space has been allocated for.
+ (The actual length can be smaller since the strings are null terminated.)
+*/
+
+int daVarRegister(int flag, daVarStruct *args);
+int daVarLookup(char *name, daVarStruct *result);
+int daVarList(char *pattern, char ***listp, int *count);
+
+typedef int DAINT;
+typedef float DAFLOAT;
+typedef double DADOUBLE;
+
+
+#ifndef S_SUCCESS
+#define S_SUCCESS 0
+#define S_FAILURE -1
+#endif
+
+#define S_DAVAR_REPLACED -2
+#define S_DAVAR_UNKNOWN -3
+#define S_DAVAR_UNKATTR -4 /* Unknown attribute */
+#define S_DAVAR_TOOMANY -5 /* Attempted to write too many values to array */
+#define S_DAVAR_ILLCONV -6 /* Illegal type conversion of write */
+#define S_DAVAR_NOEOL -10 /* Line in a block doesn't have a newline */
+#define S_DAVAR_NOINDEX -101 /* Status return from thGetIndex */
+
+#define floatToLong(x) (int) ((x)>0.0 ? (x)+0.5 : (x)-0.5)
+#endif
+
+#define STDERR stdout
+
+#ifndef FALSE
+#define FALSE (1==0)
+#endif
+#ifndef TRUE
+#define TRUE (1==1)
+#endif
+#endif
diff --git a/CTP/daVarHandlers.c b/CTP/daVarHandlers.c
new file mode 100644
index 0000000..34dd02e
--- /dev/null
+++ b/CTP/daVarHandlers.c
@@ -0,0 +1,497 @@
+/*-----------------------------------------------------------------------------
+ * Copyright (c) 1993 Southeastern Universities Research Association,
+ * Continuous Electron Beam Accelerator Facility
+ *
+ * This software was developed under a United States Government license
+ * described in the NOTICE file included as part of this distribution.
+ *
+ * Stephen A. Wood, 12000 Jefferson Ave., Newport News, VA 23606
+ * Email: saw@cebaf.gov Tel: (804) 249-7367 Fax: (804) 249-5800
+ *-----------------------------------------------------------------------------
+ *
+ * Description:
+ * Handlers for RPC services.
+ *
+ * Author: Stephen Wood, CEBAF Hall C
+ *
+ * Revision History:
+ * $Log: daVarHandlers.c,v $
+ * Revision 1.1 1998/12/07 22:11:09 saw
+ * Initial setup
+ *
+ * Revision 1.7 1995/01/09 15:59:53 saw
+ * Move location of kill_trailing function in the file
+ *
+ * Revision 1.6 1994/11/07 14:13:49 saw
+ * Finish name change by include daVarHandlers.h instead of daVarServ.h
+ *
+ * Revision 1.5 1994/10/16 21:37:57 saw
+ * Add RPC support for Fortran strings
+ * Change name from daVarServ to daVarHandlers
+ *
+ * Revision 1.4 1994/06/03 21:04:45 saw
+ * Add RPC support for doubles
+ *
+ * Revision 1.3 1993/08/12 15:03:49 saw
+ * Add #include <rpc/rpc.h>
+ *
+ * Revision 1.2 1993/05/10 21:05:05 saw
+ * Fix description
+ *
+ * Revision 1.1 1993/05/10 21:02:55 saw
+ * Initial revision
+ *
+*/
+
+/*
+If an index is put on a variable for a read, just that array element is read.
+If an index is put on a variable for a write, that array element is used as
+the starting point for however long a list of values is contained in the
+write call. If the write would go past the end of the array, nothing is
+written and an error is returned.
+
+A write of a string to a value (of the type string) will be allowed if the
+string to be written has a length <= to the allocated size specified in
+the ->size.
+
+If a string is written to a title, the existing string will be free'd and
+the new string written. The new string may be any size.
+
+*/
+
+#include <string.h>
+#include <rpc/rpc.h>
+
+#include "daVar.h"
+#include "daVarRpc.h"
+#include "daVarHandlers.h"
+
+char *daVarRAtrList[]={"value","title","size","flag","type","watr","ratr",0};
+char *daVarWAtrList[]={"value","title",0};
+
+
+daVarStatus daVarClassFind(char *name, daVarStruct **varp);
+daVarStatus daVarAttributeFind(char *name, daVarStruct *varclass,
+ daVarStruct **varp, char **attribute,
+ int *index);
+void daVarRhandler(char *name, daVarStruct *varclass, any *retval);
+daVarStatus daVarWhandler(char *name,daVarStruct *varclass,any *setval);
+char *daVarMakeRAtrList();
+char *daVarMakeWAtrList();
+void daVarCopyAlist(char *nllist,char **list);
+
+static char *kill_trailing(char *s, char t)
+{
+ char *e;
+ e = s + strlen(s);
+ if (e>s) { /* Need this to handle NULL string.*/
+ while (e>s && *--e==t); /* Don't follow t's past beginning. */
+ e[*e==t?0:1] = '\0'; /* Handle s[0]=t correctly. */
+ }
+ return s;
+}
+
+daVarStatus daVarWriteVar(char *name, any *setval)
+{
+ daVarStruct *varclass;
+
+ if(daVarClassFind(name,&varclass)!=S_SUCCESS){
+ return(S_FAILURE);
+
+ }
+ if(varclass->whook){
+ return((varclass->whook)(name,varclass,setval));
+ } else {
+ return(daVarWhandler(name,varclass,setval));
+ }
+}
+
+
+void daVarReadVar(char *name, any *retval)
+{
+ daVarStruct *varclass;
+
+ if(daVarClassFind(name,&varclass)!=S_SUCCESS){
+ retval->valtype = DAVARERROR_RPC;
+ retval->any_u.error = S_FAILURE;
+ return;
+ }
+ if(varclass->rhook){
+ (varclass->rhook)(name,varclass,retval);
+ } else {
+ daVarRhandler(name,varclass,retval);
+ }
+}
+
+daVarStatus daVarWhandler(char *name,daVarStruct *varclass,any *setval)
+/* The default Write handler */
+{
+ daVarStruct *varp;
+ char *attribute;
+ daVarStatus status;
+ int index;
+
+ status = daVarAttributeFind(name, varclass, &varp, &attribute, &index);
+ if(status == S_SUCCESS)
+ status = daVarRegWatr(varp, attribute, index, setval);
+ /* A special handler would check more attributes if status != SUCCESS */
+ return(status);
+}
+
+void daVarRhandler(char *name, daVarStruct *varclass, any *retval)
+/* The default Read handler */
+{
+ daVarStruct *varp;
+ char *attribute;
+ daVarStatus status;
+ int index;
+
+ status = daVarAttributeFind(name, varclass, &varp, &attribute, &index);
+ status = daVarRegRatr(varp, attribute, index, retval);
+ /* A special handler would check more attributes if status != SUCCESS */
+ return;
+}
+
+daVarStatus daVarRegRatr(daVarStruct *varp, char *attribute
+ ,int index, any *retval)
+/* Regular Read Attribute routine. Returns failure if attribute is not
+ of the standard set. */
+{
+ int i;
+
+ if(*attribute == '\0' || strcasecmp(attribute,DAVAR_VALUE) == 0){
+ if(varp->type == DAVARINT){
+ retval->valtype = DAVARINT_RPC;
+ if(index == DAVAR_NOINDEX) {
+ retval->any_u.i.i_len = varp->size;
+ retval->any_u.i.i_val = (int *) malloc(varp->size*sizeof(int));
+ for(i=0;i<varp->size;i++) {
+ retval->any_u.i.i_val[i] = ((DAINT *)varp->varptr)[i];
+ /* printf("%d %d\n",i,retval->any_u.i.i_val[i]);*/
+ }
+ } else {
+ retval->any_u.i.i_len = 1;
+ retval->any_u.i.i_val = (int *) malloc(sizeof(int));
+ retval->any_u.i.i_val[0] = ((DAINT *)varp->varptr)[index];
+ }
+ } else if(varp->type == DAVARFLOAT){
+ retval->valtype = DAVARFLOAT_RPC;
+ if(index == DAVAR_NOINDEX) {
+ retval->any_u.r.r_len = varp->size;
+ retval->any_u.r.r_val = (float *) malloc(varp->size*sizeof(float));
+ for(i=0;i<varp->size;i++) {
+ retval->any_u.r.r_val[i] = ((DAFLOAT *)varp->varptr)[i];
+ /* printf("%d %f\n",i,retval->any_u.r.r_val[i]);*/
+ }
+ } else {
+ retval->any_u.r.r_len = 1;
+ retval->any_u.r.r_val = (float *) malloc(sizeof(float));
+ retval->any_u.r.r_val[0] = ((DAFLOAT *)varp->varptr)[index];
+ }
+ } else if(varp->type == DAVARDOUBLE){
+ /* Return a float type for now since doubles don't work with our RPC */
+ retval->valtype = DAVARFLOAT_RPC;
+ if(index == DAVAR_NOINDEX) {
+ retval->any_u.r.r_len = varp->size;
+ retval->any_u.r.r_val = (float *) malloc(varp->size*sizeof(float));
+ for(i=0;i<varp->size;i++) {
+ retval->any_u.r.r_val[i] = ((DADOUBLE *)varp->varptr)[i];
+/* printf("%d %f\n",i,retval->any_u.r.r_val[i]);*/
+ }
+ } else {
+ retval->any_u.r.r_len = 1;
+ retval->any_u.r.r_val = (float *) malloc(sizeof(float));
+ retval->any_u.r.r_val[0] = ((DADOUBLE *)varp->varptr)[index];
+ }
+ } else if(varp->type == DAVARSTRING && index == DAVAR_NOINDEX){
+ /* indices to strings not supported */
+ retval->valtype = DAVARSTRING_RPC;
+ retval->any_u.s = (char *) malloc(strlen((char *)varp->varptr) + 1);
+ strcpy(retval->any_u.s,(char *)varp->varptr);
+ /* printf("%s\n",retval->any_u.s);*/
+ } else if(varp->type == DAVARFSTRING && index == DAVAR_NOINDEX){
+ retval->valtype = DAVARSTRING_RPC;
+ retval->any_u.s = (char *) malloc(varp->size+1);
+ strncpy(retval->any_u.s,(char *)varp->varptr,varp->size);
+ retval->any_u.s[varp->size] = '\0';
+ kill_trailing(retval->any_u.s,' ');
+ } else {
+ retval->valtype = DAVARERROR_RPC;
+ retval->any_u.error = S_SUCCESS;
+ }
+ return(S_SUCCESS);
+ } else if(strcasecmp(attribute,DAVAR_TITLE) == 0){
+ retval->valtype = DAVARSTRING_RPC;
+ retval->any_u.s = (char *) malloc(strlen(varp->title) + 1);
+ strcpy(retval->any_u.s,varp->title);
+ /* printf("%s\n",retval->any_u.s);*/
+ return(S_SUCCESS);
+ } else if(strcasecmp(attribute,DAVAR_SIZE) == 0){
+ retval->valtype = DAVARINT_RPC;
+ retval->any_u.i.i_len = 1;
+ retval->any_u.i.i_val = (int *) malloc(sizeof(int));
+ retval->any_u.i.i_val[0] = varp->size;
+ return(S_SUCCESS);
+ } else if(strcasecmp(attribute,DAVAR_TYPE) == 0){
+ retval->valtype = DAVARINT_RPC;
+ retval->any_u.i.i_len = 1;
+ retval->any_u.i.i_val = (int *) malloc(sizeof(int));
+ retval->any_u.i.i_val[0] = varp->type;
+ return(S_SUCCESS);
+ } else if(strcasecmp(attribute,DAVAR_FLAG) == 0){
+ retval->valtype = DAVARINT_RPC;
+ retval->any_u.i.i_len = 1;
+ retval->any_u.i.i_val = (int *) malloc(sizeof(int));
+ retval->any_u.i.i_val[0] = varp->flag;
+ return(S_SUCCESS);
+ } else if(strcasecmp(attribute,DAVAR_WATR) == 0){
+ retval->valtype = DAVARSTRING_RPC;
+ retval->any_u.s = daVarMakeWAtrList();
+ return(S_SUCCESS);
+ } else if(strcasecmp(attribute,DAVAR_RATR) == 0){
+ retval->valtype = DAVARSTRING_RPC;
+ retval->any_u.s = daVarMakeRAtrList();
+ return(S_SUCCESS);
+ } else {
+ retval->valtype = DAVARERROR_RPC;
+ retval->any_u.error = S_DAVAR_UNKATTR; /* Why success??? */
+ return(S_DAVAR_UNKATTR);
+ }
+}
+
+char *daVarMakeRAtrList()
+ /* Caller must free up the allocated memory */
+{
+ static int listsize=0;
+ char *nllist;
+
+ if(listsize==0) listsize=daVarGetAListSize(daVarRAtrList);
+ nllist = (char *) malloc(listsize+1);
+ daVarCopyAlist(nllist,daVarRAtrList); /* Copy to \n delineated list */
+ return(nllist);
+}
+char *daVarMakeWAtrList()
+ /* Caller must free up the allocated memory */
+{
+ static int listsize=0;
+ char *nllist;
+
+ if(listsize==0) listsize=daVarGetAListSize(daVarWAtrList);
+ nllist = (char *) malloc(listsize+1);
+ daVarCopyAlist(nllist,daVarWAtrList);
+ return(nllist);
+}
+int daVarGetAListSize(char **list)
+{
+ int len;
+ len = 0;
+ while(*list) len += strlen(*list++)+1;
+ return(len);
+}
+void daVarCopyAlist(char *nllist,char **list)
+{
+ char *nlp;
+ char *lp;
+
+ nlp = nllist;
+ while(lp=*list++){
+ while(*nlp = *lp++) nlp++;
+ *nlp++ = '\n';
+ }
+ *nlp = '\0';
+}
+
+daVarStatus daVarRegWatr(daVarStruct *varp, char *attribute
+ , int index, any *setval)
+/* Regular Write Attribute routine. Returns failure if attribute is not
+ of the standard set. */
+{
+ int i;
+
+
+ if(*attribute == '\0' || strcasecmp(attribute,DAVAR_VALUE) == 0){
+ if(index == DAVAR_NOINDEX) index = 0;
+ if(setval->valtype == DAVARINT_RPC) {
+ if(varp->size >= setval->any_u.i.i_len+index){
+ if(varp->type == DAVARINT){
+ for(i=0;i<setval->any_u.i.i_len;i++){
+ ((DAINT *)varp->varptr)[i+index] = setval->any_u.i.i_val[i];
+ }
+ } else if(varp->type == DAVARFLOAT){
+ for(i=0;i<setval->any_u.i.i_len;i++){
+ ((DAFLOAT *)varp->varptr)[i+index] = setval->any_u.i.i_val[i];
+ }
+ } else if(varp->type == DAVARDOUBLE){
+ for(i=0;i<setval->any_u.i.i_len;i++){
+ ((DADOUBLE *)varp->varptr)[i+index] = setval->any_u.i.i_val[i];
+ }
+ } else
+ return(S_DAVAR_ILLCONV);
+ } else
+ return(S_DAVAR_TOOMANY);
+ } else if(setval->valtype == DAVARFLOAT_RPC) {
+ if(varp->size >= setval->any_u.r.r_len+index){
+ if(varp->type == DAVARINT){
+ for(i=0;i<setval->any_u.r.r_len;i++){
+ ((DAINT *)varp->varptr)[i+index] = floatToLong(setval->any_u.r.r_val[i]);
+ }
+ } else if(varp->type == DAVARFLOAT){
+ for(i=0;i<setval->any_u.r.r_len;i++){
+ ((DAFLOAT *)varp->varptr)[i+index] = setval->any_u.r.r_val[i];
+ }
+ } else if(varp->type == DAVARDOUBLE){
+ for(i=0;i<setval->any_u.r.r_len;i++){
+ ((DADOUBLE *)varp->varptr)[i+index] = setval->any_u.r.r_val[i];
+ }
+ } else
+ return(S_DAVAR_TOOMANY);
+
+ } else
+ return(S_DAVAR_ILLCONV);
+ }
+#ifdef DOUBLERPC
+ else if(setval->valtype == DAVARDOUBLE_RPC) {
+ if(varp->size >= setval->any_u.d.d_len+index){
+ if(varp->type == DAVARINT){
+ for(i=0;i<setval->any_u.d.d_len;i++){
+ ((DAINT *)varp->varptr)[i+index] = floatToLong(setval->any_u.d.d_val[i]);
+ }
+ } else if(varp->type == DAVARFLOAT){
+ for(i=0;i<setval->any_u.d.d_len;i++){
+ ((DAFLOAT *)varp->varptr)[i+index] = setval->any_u.d.d_val[i];
+ }
+ } else if(varp->type == DAVARDOUBLE){
+ for(i=0;i<setval->any_u.d.d_len;i++){
+ ((DADOUBLE *)varp->varptr)[i+index] = setval->any_u.d.d_val[i];
+ }
+ } else
+ return(S_DAVAR_TOOMANY);
+ } else
+ return(S_DAVAR_ILLCONV);
+ }
+#endif
+ else if(setval->valtype == DAVARSTRING_RPC) {
+ if(varp->type == DAVARSTRING) {
+ if(varp->size < strlen(setval->any_u.s)+index) {
+ return(S_DAVAR_TOOMANY); /* Maybe we should truncate strings??? */
+ }
+ strcpy(((char *) varp->varptr)+index, setval->any_u.s);
+ } else if(varp->type == DAVARFSTRING) {
+ int in_len;
+ int blanks;
+ char *p;
+ in_len = strlen(setval->any_u.s);
+/* printf("|%s|\n",setval->any_u.s);*/
+ if(varp->size < in_len+index) {
+ return(S_DAVAR_TOOMANY);
+ }
+ strncpy(((char *) varp->varptr)+index,
+ setval->any_u.s,in_len);
+ blanks = varp->size - index - in_len;
+ p = ((char *) varp->varptr) + index + in_len;
+ while(blanks-- > 0) *p++ = ' '; /* Blank pad */
+ } else
+ return(S_DAVAR_ILLCONV);
+ } else
+ return(S_FAILURE);
+ } else if(strcasecmp(attribute,DAVAR_TITLE) == 0){
+ /* Index ignored for title attribute */
+/* printf("setval->valtype = %d\n",setval->valtype);*/
+ if(setval->valtype == DAVARSTRING_RPC) {
+ varp->title = (char *) realloc(varp->title,strlen(setval->any_u.s) + 1);
+/* printf("Writing string %s\n",setval->any_u.s);*/
+ strcpy(varp->title,setval->any_u.s);
+ } else
+ return(S_DAVAR_ILLCONV);
+ } else {
+ return(S_DAVAR_UNKATTR);
+ }
+ return(S_SUCCESS);
+}
+
+daVarStatus daVarClassFind(char *name, daVarStruct **varp)
+/* Pass ptr to name of full variable.
+ Name is of form a.b.c.d.e..., searches for variable "a", then "a.b"
+ and so on until a registered variable is found.
+ varp is the pointer to the structure of the registered variable.
+
+ Must have write access to the string name (even though it will be left
+ unchanged.)
+
+*/
+{
+ char c, *s, *t, *end;
+
+ s = name;
+
+ end = s + strlen(s);
+ if((t=strchr(s,'('))) if(t<end) end = t; /* ) (to keep c-mode happy) */
+ if((t=strchr(s,'['))) if(t<end) end = t; /* ] (to keep c-mode happy) */
+ c = *end;
+ *end = '\0';
+
+ while((t=strchr(s,'.'))){
+ *t = 0;
+ if(daVarLookupP(name, varp) == S_SUCCESS) {
+ *t = '.';
+ *end = c;
+ return(S_SUCCESS);
+ }
+ *t = '.';
+ s = t + 1;
+ }
+ if(daVarLookupP(name, varp) == S_SUCCESS) {
+ *end = c;
+ return(S_SUCCESS);
+ }
+ *end = c;
+ return(S_FAILURE);
+}
+daVarStatus daVarAttributeFind(char *name, daVarStruct *varclass,
+ daVarStruct **varp, char **attribute, int *index)
+ /* Return DAVAR_NOINDEX for index if none specified. */
+{
+ char *atptr; /* Pointer to attribute string */
+ daVarStatus status;
+ char *end, *pptr, parenchar;
+
+ end = name + strlen(name);
+ if((status=thGetIndex(name, index, &pptr)) == S_SUCCESS) {
+ parenchar = *pptr;
+ } else if(status == S_DAVAR_NOINDEX) {
+ parenchar = *pptr;
+ *index = DAVAR_NOINDEX;
+ } else /* Failed */
+ return(S_FAILURE);
+
+ *pptr = '\0';
+ atptr = pptr;
+
+
+ if(strcasecmp(name,varclass->name) == 0){ /* Lookup alread done */
+ *varp = varclass;
+ *attribute = end; /* Point to null */
+ } else if(daVarLookupP(name, varp) == S_SUCCESS){ /* Fullly qualified name?*/
+ *attribute = end; /* Point to null */
+ } else { /* Start striping attributes off pptr */
+ int clnamlen;
+ clnamlen = strlen(varclass->name);
+ atptr--;
+ *varp = varclass;
+ while((atptr - name) > clnamlen) { /* Stop before "class" name */
+ if(*atptr == '.'){
+ *atptr = '\0';
+ if(daVarLookupP(name, varp) == S_SUCCESS){
+ *atptr = '.';
+ break;
+ *attribute = atptr + 1;
+ } else
+ *atptr-- = '.';
+ } else
+ atptr--;
+ }
+ *attribute = atptr + 1;
+ }
+/* *pptr = parenchar; Leave name null terminated at the left paren */
+ return(S_SUCCESS);
+}
diff --git a/CTP/daVarHandlers.h b/CTP/daVarHandlers.h
new file mode 100644
index 0000000..b3c0a68
--- /dev/null
+++ b/CTP/daVarHandlers.h
@@ -0,0 +1,71 @@
+/*-----------------------------------------------------------------------------
+ * Copyright (c) 1993,1994 Southeastern Universities Research Association,
+ * Continuous Electron Beam Accelerator Facility
+ *
+ * This software was developed under a United States Government license
+ * described in the NOTICE file included as part of this distribution.
+ *
+ * Stephen A. Wood, 12000 Jefferson Ave., Newport News, VA 23606
+ * Email: saw@cebaf.gov Tel: (804) 249-7367 Fax: (804) 249-5800
+ *-----------------------------------------------------------------------------
+ *
+ * Description:
+ * Header for RPC handlers
+ *
+ * Author: Stephen A. Wood, CEBAF Hall C
+ *
+ * Revision History:
+ * $Log: daVarHandlers.h,v $
+ * Revision 1.2 1999/11/04 20:34:04 saw
+ * Alpha compatibility.
+ * New RPC call needed for root event display.
+ * Start of code to write ROOT trees (ntuples) from new "tree" block
+ *
+ * Revision 1.4 1999/08/25 13:16:05 saw
+ * *** empty log message ***
+ *
+ * Revision 1.3 1994/11/07 14:31:34 saw
+ * Add pending callback requests structure definition
+ *
+ * Revision 1.2 1993/05/11 17:34:58 saw
+ * Fix $Log: daVarHandlers.h,v $
+ * Fix Revision 1.2 1999/11/04 20:34:04 saw
+ * Fix Alpha compatibility.
+ * Fix New RPC call needed for root event display.
+ * Fix Start of code to write ROOT trees (ntuples) from new "tree" block
+ * Fix
+ * Fix Revision 1.4 1999/08/25 13:16:05 saw
+ * Fix *** empty log message ***
+ * Fix
+ * Fix Revision 1.3 1994/11/07 14:31:34 saw
+ * Fix Add pending callback requests structure definition
+ * Fix
+ *
+ */
+
+void daVarReadVar(char *name, any *retval);
+daVarStatus daVarWriteVar(char *name, any *retval);
+daVarStatus daVarRegRatr(daVarStruct *varp, char *attribute
+ ,int index, any *retval);
+daVarStatus daVarRegWatr(daVarStruct *varp, char *attribute
+ ,int index, any *setval);
+
+#define DAVAR_VALUE "value"
+#define DAVAR_TITLE "title"
+#define DAVAR_SIZE "size"
+#define DAVAR_FLAG "flag"
+#define DAVAR_TYPE "type"
+#define DAVAR_WATR "watr"
+#define DAVAR_RATR "ratr"
+
+#define DAVAR_NOINDEX -12345678
+
+/* Structures for holding information about call back requests */
+
+struct daVarCallBackList {
+ struct sockaddr_in *sock_in; /* Caller socket info */
+ struct daVarCallBackList *next;
+ struct TESTNAMELIST *list;
+ time_t start_time;
+};
+typedef struct daVarCallBackList daVarCallBackList;
diff --git a/CTP/daVarHash.h b/CTP/daVarHash.h
new file mode 100644
index 0000000..d886d4e
--- /dev/null
+++ b/CTP/daVarHash.h
@@ -0,0 +1,57 @@
+/*-----------------------------------------------------------------------------
+ * Copyright (c) 1991,1992 Southeastern Universities Research Association,
+ * Continuous Electron Beam Accelerator Facility
+ *
+ * This software was developed under a United States Government license
+ * described in the NOTICE file included as part of this distribution.
+ *
+ * CEBAF Data Acquisition Group, 12000 Jefferson Ave., Newport News, VA 23606
+ * Email: coda@cebaf.gov Tel: (804) 249-7101 Fax: (804) 249-7363
+ *-----------------------------------------------------------------------------
+ *
+ * Description:
+ * header file for CODA readout language symbol hash table
+ *
+ * Author: Jie Chen, CEBAF Data Acquisition Group
+ *
+ * Revision History:
+ * $Log: daVarHash.h,v $
+ * Revision 1.1 1998/12/07 22:11:09 saw
+ * Initial setup
+ *
+* Revision 1.1 94/03/15 12:53:09 12:53:09 heyes (Graham Heyes)
+* Initial revision
+*
+ *
+ */
+#ifndef _crl_hash_h
+#define _crl_hash_h
+
+#define CTPHASH
+#ifndef CTPHASH
+typedef struct _symbol{
+ char *var_name;
+ int var_type; /*0: integer, 1: unsigned long */
+}CrlSymbol;
+#else
+typedef void *CrlSymbol;
+#endif
+typedef struct _SLOT_ENTRY
+{
+ CrlSymbol crlSymbol;
+ struct _SLOT_ENTRY *next;
+}symbolEntry;
+
+extern void crlHashCreate(symbolEntry **hash_table_head);
+extern int crlHashAdd(CrlSymbol symbol,symbolEntry **hash_table_head);
+extern int crlHashDelete(CrlSymbol symbol,symbolEntry **hash_table_head);
+CrlSymbol *crlHashFind(CrlSymbol symbol,symbolEntry **hash_table_head);
+extern void crlHashWalk(symbolEntry **hash_table_head,void (*action)());
+/*extern int crlHashDestroy();*/
+/*extern void crlAddSymbols();*/
+/*extern void isSymbolFound();*/
+
+#define TABLE_SIZE 2053
+
+
+#endif
diff --git a/CTP/daVarHashLib.c b/CTP/daVarHashLib.c
new file mode 100644
index 0000000..8f25701
--- /dev/null
+++ b/CTP/daVarHashLib.c
@@ -0,0 +1,337 @@
+/*-----------------------------------------------------------------------------
+ * Copyright (c) 1991,1992 Southeastern Universities Research Association,
+ * Continuous Electron Beam Accelerator Facility
+ *
+ * This software was developed under a United States Government license
+ * described in the NOTICE file included as part of this distribution.
+ *
+ * CEBAF Data Acquisition Group, 12000 Jefferson Ave., Newport News, VA 23606
+ * Email: coda@cebaf.gov Tel: (804) 249-7101 Fax: (804) 249-7363
+ *-----------------------------------------------------------------------------
+ *
+ * Description:
+ * CODA readout language symbol hashtable related routines
+ *
+ * Author: Jie Chen, CEBAF Data Acquisition Group
+ *
+ * Revision History:
+ * $Log: daVarHashLib.c,v $
+ * Revision 1.2 1999/11/04 20:34:04 saw
+ * Alpha compatibility.
+ * New RPC call needed for root event display.
+ * Start of code to write ROOT trees (ntuples) from new "tree" block
+ *
+ * Revision 1.1 1996/07/31 20:33:15 saw
+ * Initial revision
+ *
+ * $Log: daVarHashLib.c,v $
+ * Revision 1.2 1999/11/04 20:34:04 saw
+ * Alpha compatibility.
+ * New RPC call needed for root event display.
+ * Start of code to write ROOT trees (ntuples) from new "tree" block
+ *
+ * Revision 1.1 1996/07/31 20:33:15 saw
+ * Initial revision
+ *
+* Revision 1.1 94/03/15 12:53:11 12:53:11 heyes (Graham Heyes)
+* Initial revision
+*
+ *
+ */
+#define CASE_INSENSITIVE
+
+#include <stdio.h>
+#include <stdlib.h>
+#include "daVarHash.h"
+#include "daVar.h"
+
+/* hash table size, change to a different prime number if necessary */
+/* Some primes: 97 257 1031 2053 4099 */
+
+/*static symbolEntry *hash_table_head[TABLE_SIZE];*/
+static void crlSymbol_copy();
+static void crlSymbol_delete();
+static int hashFunction();
+
+#ifdef CASE_INSENSITIVE
+#define STRCMP daVarComp
+#define TOLOWER tolower
+#else
+#define STRCMP strcmp
+#define TOLOWER
+#endif
+
+#ifdef _NO_STRDUP
+char *strdup (s)
+char *s;
+{
+ char *p = (char *)malloc ((strlen(s) + 1)*sizeof(char));
+ if (p == 0) {
+ fprintf (stderr, "Cannot allocate memory for strdup\n");
+ exit (1);
+ }
+ strcpy (p, s);
+ return p;
+}
+#endif
+
+/****************************************************************
+ * void crlHashCreate() *
+ * Hash table creation routine. Hash table is organized in *
+ * such a way to eliminate the collision *
+ ***************************************************************/
+void crlHashCreate(symbolEntry **hash_table_head)
+{
+ register int i;
+
+ for (i = 0; i < TABLE_SIZE; i++){
+ hash_table_head[i]=(symbolEntry *)malloc(sizeof(symbolEntry));
+ if(hash_table_head[i] == NULL){
+ fprintf(stderr,"Cannot allocate memory for crl hash table\n");
+ exit(1);
+ }
+ else{
+ hash_table_head[i]->crlSymbol = 0;
+ hash_table_head[i]->next=(symbolEntry *)0;
+ }
+ }
+}
+
+/*************************************************************
+ * int crlHashAdd() *
+ * Add an item to the hashTable, return 1 on success *
+ * return 0 on failure *
+ ************************************************************/
+int crlHashAdd (CrlSymbol symbol,symbolEntry **hash_table_head)
+{
+ int hashvalue,i;
+ symbolEntry *ptr,*txt;
+
+ hashvalue = hashFunction(symbol, TABLE_SIZE);
+/* printf ("Hash value for is %d\n",hashvalue);*/
+ for(ptr = hash_table_head[hashvalue]->next; ptr != NULL; ptr = ptr->next){
+ if((STRCMP(ptr->crlSymbol,symbol)) == 0)
+ break;
+ else
+ ;
+ }
+ if(ptr !=NULL)
+ return 0;
+ else{
+ txt=(symbolEntry *)malloc(sizeof(symbolEntry));
+ if(txt == NULL){
+ fprintf(stderr,"Cannot allocate memory for this cns entry.\n");
+ exit(1);
+ }
+/* crlSymbol_copy(&txt->crlSymbol,symbol);*/
+ txt->crlSymbol = symbol;
+ txt->next = hash_table_head[hashvalue]->next;
+ hash_table_head[hashvalue]->next=txt;
+ return 1;
+ }
+}
+
+/************************************************************
+ * int crlHashDelete() *
+ * delete a single item from the Hash Table *
+ * return 0 on success, return 1 on failure *
+ ***********************************************************/
+int crlHashDelete(CrlSymbol symbol,symbolEntry **hash_table_head)
+{
+ int hashvalue;
+ symbolEntry *ptr,*qtr;
+
+ hashvalue=hashFunction (symbol, TABLE_SIZE);
+ qtr = hash_table_head [hashvalue];
+ for(ptr = hash_table_head[hashvalue]->next; ptr!=NULL; ptr=ptr->next){
+ if((STRCMP(ptr->crlSymbol, symbol)) == 0)
+ break;
+ else
+ qtr=qtr->next;
+ }
+
+ if(ptr !=NULL){
+ qtr->next=ptr->next;
+ ptr->next=NULL;
+ /* free memory */
+/* crlSymbol_delete (&(ptr->crlSymbol));*/
+ free (ptr);
+ return 0;
+ }
+ else
+ return 1;
+}
+
+/**************************************************************
+ * int crlHashFind() *
+ * Find out whether a particular item which has key 'key' *
+ * existed in the hash Tabel, return item *
+ * return 0 for failure *
+ *************************************************************/
+CrlSymbol *crlHashFind(CrlSymbol symbol,symbolEntry **hash_table_head)
+{
+ int hashvalue;
+ symbolEntry *ptr;
+
+ hashvalue = hashFunction (symbol, TABLE_SIZE);
+/* printf ("Hash value inside find for is %d\n", hashvalue);*/
+ for(ptr = hash_table_head[hashvalue]->next; ptr != NULL; ptr = ptr->next){
+ if((STRCMP(ptr->crlSymbol, symbol)) == 0)
+ break;
+ else
+ ;
+ }
+ if(ptr != NULL){
+ return(&(ptr->crlSymbol));
+ }
+ else
+ return 0;
+}
+
+/**********************************************************
+ * int crlHashDestroy() *
+ * Destroy hashTable and free memory *
+ * return 0 on success, return 1 on failure *
+ *********************************************************/
+#if 0
+int crlHashDestroy()
+{
+ int i;
+ symbolEntry *ptr,*qtr;
+
+ for(i=0;i < TABLE_SIZE; i++){
+ ptr = hash_table_head[i];
+ while(ptr != NULL){
+ qtr = ptr->next;
+ /* free all memory */
+ crlSymbol_delete (&(ptr->crlSymbol));
+ free(ptr);
+ /* update pointer information */
+ ptr = qtr;
+ }
+ }
+ return 0;
+}
+#endif
+
+
+/**********************************************************
+ * int hashFunction() *
+ * return hash value according to the char key *
+ * case sensitive *
+ *********************************************************/
+static int hashFunction(s,slot_num)
+daVarStruct *s;
+int slot_num;
+{
+ char *p;
+ unsigned h=0,g;
+
+/* printf("H(%s)=",s->name);*/
+ for(p = s->name; *p !='\0'; p++) {
+ h= (h<<4) + (TOLOWER(*p));
+ if(g = h & 0xf0000000) {
+ h=h^(g>>24);
+ h=h^g;
+ }
+ }
+/* printf("%d\n",h%slot_num);*/
+ return h%slot_num;
+}
+extern void crlHashWalk(symbolEntry **hash_table_head,void (*action)())
+{
+ int i;
+ symbolEntry *ptr;
+
+ for(i=0;i < TABLE_SIZE; i++){
+ ptr = hash_table_head[i]->next;
+ while(ptr != NULL){
+ (*action) (ptr->crlSymbol);
+ ptr = ptr->next;
+ }
+ }
+}
+
+/**********************************************************
+ * void crlSymbol_copy() *
+ * locally used structure copy routine *
+ * copy expid struct from id1 to id2 *
+ * id2 memory must be allocated before use this routine *
+ **********************************************************/
+/*static void crlSymbol_copy(id2,id1)
+CrlSymbol *id2,*id1;
+{
+ id2->var_name = strdup(id1->var_name);
+ id2->var_type = id1->var_type;
+}*/
+
+/**********************************************************
+ * void crlSymbol_delete() *
+ * locally used structure delete routine *
+ * free memory pointed by id *
+ **********************************************************/
+#if 0
+static void crlSymbol_delete(id)
+CrlSymbol *id;
+{
+ free (id->var_name);
+}
+#endif
+/*********************************************************
+ * void crlAddSymbols() *
+ * Description: *
+ * add list of var names to symbol hashtable *
+ ********************************************************/
+#if 0
+void crlAddSymbols(var_list,type)
+char *var_list;
+int type;
+{
+ char *p, *q,temp[80];
+ int status;
+ CrlSymbol crlSymbol;
+
+ if(strchr(var_list,',') == NULL){ /* single var name */
+ crlSymbol.var_name = strdup(var_list);
+ crlSymbol.var_type = type;
+ status = crlHashAdd(crlSymbol.var_name, &crlSymbol);
+ }
+ else{
+ p = var_list;
+ q = temp;
+ while(*p != '\n' && *p != '\0'){
+ if(*p == ','){
+ *q = '\0';
+ p++;
+ crlSymbol.var_name = strdup(temp);
+ crlSymbol.var_type = type;
+ status = crlHashAdd(crlSymbol.var_name,&crlSymbol);
+ q = temp;
+ }
+ else{
+ *q = *p;
+ q++; p++;
+ }
+ }
+ }
+}
+#endif
+/*****************************************************************
+ * void isSymbolFound() *
+ * Description: *
+ * Check to see whether a var name existed in the hashTable *
+ ****************************************************************/
+#if 0
+void isSymbolFound(symbol)
+char *symbol;
+{
+ int status = 0;
+
+ status = crlHashFind(symbol);
+ if(status != 0){
+ fprintf(stderr,"Error: Undefined symbol \"%s\"\n", symbol);
+ fprintf(stderr,"Cannot continue, Quit.\n");
+ exit(1);
+ }
+}
+#endif
diff --git a/CTP/daVarRegister.c b/CTP/daVarRegister.c
new file mode 100644
index 0000000..330788f
--- /dev/null
+++ b/CTP/daVarRegister.c
@@ -0,0 +1,723 @@
+/*-----------------------------------------------------------------------------
+ * Copyright (c) 1992 Southeastern Universities Research Association,
+ * Continuous Electron Beam Accelerator Facility
+ *
+ * This software was developed under a United States Government license
+ * described in the NOTICE file included as part of this distribution.
+ *
+ * Stephen A. Wood, 12000 Jefferson Ave., Newport News, VA 23606
+ * Email: saw@cebaf.gov Tel: (804) 249-7367 Fax: (804) 249-5800
+ *-----------------------------------------------------------------------------
+ *
+ * Description:
+ * C and Fortran routines for registering variables to be used by
+ * the test, histogram and parameter packages.
+ *
+ * Author: Stephen Wood, CEBAF HALL C
+ *
+ * Revision History:
+ * $Log: daVarRegister.c,v $
+ * Revision 1.3 2003/02/21 20:55:24 saw
+ * Clean up some types and casts to reduce compiler warnings.
+ *
+ * Revision 1.2 1999/11/04 20:34:04 saw
+ * Alpha compatibility.
+ * New RPC call needed for root event display.
+ * Start of code to write ROOT trees (ntuples) from new "tree" block
+ *
+ * Revision 1.13 1999/08/25 13:16:05 saw
+ * *** empty log message ***
+ *
+ * Revision 1.12 1999/03/01 19:51:32 saw
+ * Add Absoft Fortran stuff
+ *
+ * Revision 1.11 1997/05/29 18:56:25 saw
+ * Lock changes before adding Absoft(Linux) compatibility
+ *
+ * Revision 1.10 1996/07/31 20:37:53 saw
+ * Use hash table for name storage.
+ *
+ * Revision 1.9 1994/09/27 20:20:53 saw
+ * Remove linux dependencies, allow wild cards in daVarList
+ *
+ * Revision 1.8 1994/08/24 14:27:00 saw
+ * Have daVarLookupPWithClass return S_DAVAR_UNKNOWN if var not found
+ *
+ * Revision 1.7 1994/06/03 20:59:26 saw
+ * Replace stderr with STDERR
+ *
+ * Revision 1.6 1994/02/10 21:58:33 saw
+ * Change node variable name to nd to not conflict with node type.
+ *
+ * Revision 1.5 1994/02/10 18:34:05 saw
+ * Small fixes for SGI compatibility
+ *
+ * Revision 1.4 1993/11/24 21:37:39 saw
+ * Add fortran calls for registering double (REAL *8) variable type.
+ *
+ * Revision 1.3 1993/11/22 20:09:42 saw
+ * Add REGPARMSTRING fortran call for new Fortran string type DAVARFSTRING
+ *
+ * Revision 1.2 1993/08/12 19:58:10 saw
+ * On HPUX don't use native tsearch.
+ *
+ * Revision 1.1 1993/05/10 20:05:09 saw
+ * Initial revision
+ *
+ *
+ * 18-dec-92 saw Original version
+ *
+ *
+ * Routines available to general users:
+ * --------
+ * daVarRegister(int flag, daVarStruct *args)
+ * daVarLookup(char *name, daVarStruct *results)
+ *
+ * Routines available to "friendly" packages (e.g.) RPC service routines
+ * --------
+ * daVarLookupP(char *name, daVarStruct **results)
+ * daVarList(char ***listp)
+ * daVarFreeList(char **list)
+ *
+ *
+ */
+#include "cfortran.h"
+#include "daVar.h"
+
+#define USEHASH
+#ifdef USEHASH
+#include "daVarHash.h"
+#else
+#if !defined(ultrix)
+#define NO_TSEARCH
+#endif
+
+#include <stdio.h>
+#ifdef NOFNMATCH
+#include "fnmatch.h" /* For non POSIX systems */
+#else
+#include <fnmatch.h>
+#endif
+
+/* Stuff for Tsearch routines*/
+typedef struct node_t
+{
+ daVarStruct *key;
+ struct node_t *left, *right;
+} node;
+
+#ifdef NO_TSEARCH
+typedef enum { preorder, postorder, endorder, leaf } VISIT;
+node *mytsearch(void *key, node **rootp, int (* compar)());
+node *mytfind(void *key, node **rootp, int (* compar)());
+void mytwalk();
+#else
+#include <search.h>
+#define mytsearch tsearch
+#define mytfind tfind
+#define mytwalk twalk
+#endif
+#endif
+
+#ifdef USEHASH
+symbolEntry *hash_table[TABLE_SIZE];
+int hashNotInited=1;
+#else
+node *daVarRoot=0;
+#endif
+int daVarCount=0; /* Used by daVarList */
+char **daVarListGlob;
+char *daVarListPattern;
+int (*daVarListCompFunction)();
+int daVarListPattern_length;
+
+/* Local prototypes */
+int daVarComp(daVarStruct *item1, daVarStruct *item2);
+
+/* Code */
+int daVarRegister(int flag, daVarStruct *args)
+/* Should accept a title arg of zero and create a null string in that
+ case.
+*/
+{
+ daVarStruct search, *new, **searchresult;
+ int fullnamelen;
+
+ if(flag != 0) {
+ fprintf(STDERR,
+ "(daVarRegister) Only zero allowed for flag argument now.\n");
+ return(S_FAILURE);
+ }
+
+ search.name = args->name;
+/* printf("Searching for %s\n",args->name);*/
+#ifdef USEHASH
+ if(hashNotInited) {crlHashCreate(hash_table); hashNotInited = 0;}
+ if(searchresult = (daVarStruct **) crlHashFind((CrlSymbol) &search,hash_table)) {
+#else
+ if(searchresult = (daVarStruct **) mytfind(&search,&daVarRoot,daVarComp)){
+#endif
+ fprintf(STDERR,
+ "(daVar) Replacing definition of variable \"%s\" in table\n",
+ args->name);
+ free((*searchresult)->title);
+ if(args->title) {
+ if(((*searchresult)->title = (char *) malloc(strlen(args->title)+1))
+ == NULL)
+ return(S_FAILURE);
+ strcpy((*searchresult)->title,args->title);
+ } else {
+ if(((*searchresult)->title = (char *) malloc(1))
+ == NULL)
+ return(S_FAILURE);
+ (*searchresult)->title[0] = '\0';
+ }
+ (*searchresult)->varptr = args->varptr;
+ (*searchresult)->size = (args->size<=0) ? 1 : args->size;
+ (*searchresult)->type = args->type;
+ (*searchresult)->flag = args->flag;
+ (*searchresult)->rhook = args->rhook;
+ (*searchresult)->whook = args->whook;
+ (*searchresult)->opaque = args->opaque;
+ return(S_DAVAR_REPLACED);
+ } else {
+ if((new = (daVarStruct *) malloc(sizeof(daVarStruct))) == NULL)
+ return(S_FAILURE);
+ if((new->name = (char *) malloc(strlen(args->name)+1)) == NULL)
+ return(S_FAILURE);
+ strcpy(new->name,args->name);
+
+
+ if(args->title) {
+ if((new->title = (char *) malloc(strlen(args->title)+1)) == NULL)
+ return(S_FAILURE);
+ strcpy(new->title,args->title);
+ } else {
+ if((new->title = (char *) malloc(1)) == NULL)
+ return(S_FAILURE);
+ new->title[0] = '\0';
+ }
+ new->type = args->type;
+ new->varptr = args->varptr;
+ new->size = (args->size<=0) ? 1 : args->size;
+ new->flag = args->flag;
+ new->rhook = args->rhook;
+ new->whook = args->whook;
+ new->opaque = args->opaque;
+
+#ifdef USEHASH
+ if(crlHashAdd((CrlSymbol) new, hash_table))
+#else
+ if(mytsearch((void *) new,&daVarRoot,daVarComp))
+#endif
+ return(S_SUCCESS);
+ else
+ return(S_FAILURE);
+ }
+}
+
+
+int daVarLookup(char *name, daVarStruct *result)
+{
+ daVarStruct search, **searchresult;
+ static char *namel=0; /* Pointers to static space for copies of */
+ static int namelsize=0;
+ static char *titlel=0; /* the name and title pointers */
+ static int titlelsize=0;
+ int len;
+
+ search.name = name;
+#ifdef USEHASH
+ if(searchresult = (daVarStruct **) crlHashFind((CrlSymbol) &search,hash_table)) {
+#else
+ if(searchresult = (daVarStruct **) mytfind(&search,&daVarRoot,daVarComp)){
+#endif
+
+ len=strlen((*searchresult)->name);
+ if(len >= namelsize) {
+ if(namel) free(namel);
+ namel = (char *) malloc(len+1);
+ namelsize = len+1;
+ }
+ strcpy(namel,(*searchresult)->name);
+ result->name = namel;
+
+ len=strlen((*searchresult)->title);
+ if(len >= titlelsize) {
+ if(titlel) free(titlel);
+ titlel = (char *) malloc(len + 1);
+ titlelsize = len+1;
+ }
+ strcpy(titlel,(*searchresult)->title);
+ result->title = titlel;
+
+ result->type = (*searchresult)->type;
+ result->varptr = (*searchresult)->varptr;
+ result->size = (*searchresult)->size;
+ result->opaque = (*searchresult)->opaque;
+ result->rhook = (*searchresult)->rhook;
+ result->whook = (*searchresult)->whook;
+ return(S_SUCCESS);
+ } else
+ return(S_DAVAR_UNKNOWN);
+}
+int daVarStrcmp(register char *s1, register char *s2)
+{
+ while(toupper(*s1) == toupper(*s2++))
+ if(*s1++ == '\0')
+ return(0);
+ return(toupper(*s1) - toupper(*--s2));
+}
+int daVarFnmatch(register char *pattern, register char *s, register int n)
+{
+ return(fnmatch(pattern,s,0));
+}
+int daVarStrncmp(register char *s1, register char *s2, register int n)
+{
+ while(toupper(*s1) == toupper(*s2++))
+ if(*s1++ == '\0' || (--n) <= 0)
+ return(0);
+ return(toupper(*s1) - toupper(*--s2));
+}
+
+int daVarComp(daVarStruct *item1, daVarStruct *item2)
+/* Do case insensitive comparisons of keys */
+{
+ return(daVarStrcmp(item1->name,item2->name));
+}
+
+int daVarLookupP(char *name, daVarStruct **varstructptr)
+{
+ daVarStruct search, **searchresult;
+
+ search.name = name;
+#ifdef USEHASH
+ if(searchresult = (daVarStruct **) crlHashFind((CrlSymbol) &search,hash_table)) {
+#else
+ if(searchresult = (daVarStruct **) mytfind(&search,&daVarRoot,daVarComp)){
+#endif
+ *varstructptr = *searchresult;
+ return(S_SUCCESS);
+ } else
+ return(S_DAVAR_UNKNOWN);
+}
+
+daVarLookupPWithClass(char *name, char **prefixlist, daVarStruct **varp)
+{
+ int namlen,namtrylen;
+ char *namtry;
+
+ namlen = strlen(name);
+ if(daVarLookupP(name,varp)==S_SUCCESS) return(S_SUCCESS);
+ namtrylen = namlen + 10;
+ namtry = (char *) malloc(namtrylen+1);
+ while(*prefixlist){
+ int thislen;
+ thislen = strlen(*prefixlist) + namlen + 1;
+ if(thislen > namtrylen) {
+ namtrylen = thislen;
+ namtry = (char *) realloc(namtry,namtrylen);
+ }
+ strcpy(namtry,*prefixlist);
+ strcat(namtry,".");
+ strcat(namtry,name);
+ if(daVarLookupP(namtry,varp)==S_SUCCESS) {
+ free(namtry);
+ return(S_SUCCESS);
+ }
+ prefixlist++;
+ }
+ free(namtry);
+ return(S_DAVAR_UNKNOWN); /* Variable not registered */
+}
+
+void daVarCount_node
+#ifdef USEHASH
+(void *entry)
+{
+#else
+(node *nd,VISIT order, int level)
+{
+ if(order==postorder || order == leaf)
+#endif
+ daVarCount++;
+}
+
+void daVarList_node
+#ifdef USEHASH
+(void *entry)
+{
+#else
+(node *nd,VISIT order, int level)
+{
+ if(order==postorder || order == leaf)
+#endif
+ {
+ char *name;
+
+ name = ((daVarStruct *) entry)->name;
+ if(daVarListPattern_length == 0 ||
+ (daVarListCompFunction)(daVarListPattern,name,daVarListPattern_length) == 0)
+ daVarListGlob[daVarCount++] = name;
+ }
+}
+
+
+int daVarList(char *pattern, char ***listp, int *count)
+/* User is not allowed to muck with the strings pointed to in the list
+ because they are the actual strings in the tables. */
+{
+
+ if(strchr(pattern,'*') || strchr(pattern,'?')) {
+ daVarListCompFunction = daVarFnmatch;
+ } else {
+ daVarListCompFunction = daVarStrncmp;
+ }
+ if(pattern) {
+ daVarListPattern = pattern;
+ daVarListPattern_length = strlen(daVarListPattern);
+ } else
+ daVarListPattern_length = 0;
+ daVarCount = 0;
+#ifdef USEHASH
+ crlHashWalk(hash_table,daVarCount_node);
+#else
+ mytwalk(daVarRoot,daVarCount_node);/* Should make list only big enough
+ for what matches */
+#endif
+
+ if((*listp = daVarListGlob =
+ (char **) malloc((daVarCount)*sizeof(char *))) == NULL)
+ return(S_FAILURE);
+ daVarCount = 0;
+#ifdef USEHASH
+ crlHashWalk(hash_table,daVarList_node);
+#else
+ mytwalk(daVarRoot,daVarList_node);
+#endif
+ *count = daVarCount;
+ return(S_SUCCESS);
+}
+#ifndef USEHASH
+daVarPrint_node(node *nd,VISIT order, int level)
+{
+ char *name,*title;
+
+ if(order==postorder || order == leaf) {
+ name = ((daVarStruct *) nd->key)->name;
+ title = ((daVarStruct *) nd->key)->title;
+ printf("XX: %s %s %x %x\n",name,title,nd,nd->key);
+ }
+}
+
+int daVarPrint()
+{
+ mytwalk(daVarRoot,daVarPrint_node);
+ return(S_SUCCESS);
+}
+#endif
+int daVarFreeList(char **list)
+/* Free's up the list of variables in listp */
+{
+ int i;
+
+ free(list);
+ return(S_SUCCESS);
+}
+
+/* Fortran entry points */
+
+#define LENDEFARRAY int *size,
+#define LENDEFSCALER
+#define LENARGARRAY *size
+#define LENARGSCALER 1
+
+#define MAKEFSUB(SUBNAME,CLASS,TYPENAME,DATYPE,ARRAY) \
+int SUBNAME(char *name, TYPENAME *vptr, LENDEF##ARRAY char *title\
+ ,unsigned l_name, unsigned l_title)\
+{\
+ int A0;\
+ daVarStruct args;\
+ char *BN=0;\
+ char *BT=0;\
+ char *BF = 0;\
+\
+ BF = malloc(strlen(CLASS)+l_name+1);\
+ strcpy(BF,CLASS);\
+ args.name = strcat(BF,((!*(int *)name)?0:memchr(name,'\0',l_name)?name:\
+ (memcpy(BN=(char *) malloc(l_name+1),name,l_name)\
+ ,BN[l_name]='\0',kill_trailing(BN,' '))));\
+ args.title = ((!*(int *)title)?0:memchr(title,'\0',l_title)?title:\
+ (memcpy(BT=(char *) malloc(l_title+1),title,l_title)\
+ ,BT[l_title]='\0',kill_trailing(BT,' ')));\
+ args.size = LENARG##ARRAY;\
+ args.varptr = (void *) vptr;\
+ args.flag = DAVAR_READWRITE;\
+ args.type = DATYPE;\
+ args.opaque = 0;\
+ args.rhook = 0;\
+ args.whook = 0;\
+ A0 = daVarRegister((int) 0, &args);\
+ if(BF) free(BF);\
+ if(BN) free(BN);\
+ if(BT) free(BT);\
+ return(A0);\
+}
+
+/* Can't figure out a more clever way */
+#ifdef AbsoftUNIXFortran
+MAKEFSUB(regreal,"",float,DAVARFLOAT,SCALER)
+MAKEFSUB(regdouble,"",double,DAVARDOUBLE,SCALER)
+MAKEFSUB(regint,"",int,DAVARINT,SCALER)
+MAKEFSUB(regrealarray,"",float,DAVARFLOAT,ARRAY)
+MAKEFSUB(regdoublearray,"",double,DAVARDOUBLE,ARRAY)
+MAKEFSUB(regintarray,"",int,DAVARINT,ARRAY)
+
+MAKEFSUB(regparmreal,"parm.",float,DAVARFLOAT,SCALER)
+MAKEFSUB(regparmdouble,"parm.",double,DAVARDOUBLE,SCALER)
+MAKEFSUB(regeventreal,"event.",float,DAVARFLOAT,SCALER)
+MAKEFSUB(regeventdouble,"event.",double,DAVARDOUBLE,SCALER)
+MAKEFSUB(regparmint,"parm.",int,DAVARINT,SCALER)
+MAKEFSUB(regeventint,"event.",int,DAVARINT,SCALER)
+MAKEFSUB(regparmrealarray,"parm.",float,DAVARFLOAT,ARRAY)
+MAKEFSUB(regparmdoublearray,"parm.",double,DAVARDOUBLE,ARRAY)
+MAKEFSUB(regeventrealarray,"event.",float,DAVARFLOAT,ARRAY)
+MAKEFSUB(regeventdoublearray,"event.",double,DAVARDOUBLE,ARRAY)
+MAKEFSUB(regparmintarray,"parm.",int,DAVARINT,ARRAY)
+MAKEFSUB(regeventintarray,"event.",int,DAVARINT,ARRAY)
+
+MAKEFSUB(regtestint,"test.",int,DAVARINT,SCALER)
+MAKEFSUB(regtestintarray,"test.",int,DAVARINT,ARRAY)
+#else
+MAKEFSUB(regreal_,"",float,DAVARFLOAT,SCALER)
+MAKEFSUB(regdouble_,"",double,DAVARDOUBLE,SCALER)
+MAKEFSUB(regint_,"",int,DAVARINT,SCALER)
+MAKEFSUB(regrealarray_,"",float,DAVARFLOAT,ARRAY)
+MAKEFSUB(regdoublearray_,"",double,DAVARDOUBLE,ARRAY)
+MAKEFSUB(regintarray_,"",int,DAVARINT,ARRAY)
+
+MAKEFSUB(regparmreal_,"parm.",float,DAVARFLOAT,SCALER)
+MAKEFSUB(regparmdouble_,"parm.",double,DAVARDOUBLE,SCALER)
+MAKEFSUB(regeventreal_,"event.",float,DAVARFLOAT,SCALER)
+MAKEFSUB(regeventdouble_,"event.",double,DAVARDOUBLE,SCALER)
+MAKEFSUB(regparmint_,"parm.",int,DAVARINT,SCALER)
+MAKEFSUB(regeventint_,"event.",int,DAVARINT,SCALER)
+MAKEFSUB(regparmrealarray_,"parm.",float,DAVARFLOAT,ARRAY)
+MAKEFSUB(regparmdoublearray_,"parm.",double,DAVARDOUBLE,ARRAY)
+MAKEFSUB(regeventrealarray_,"event.",float,DAVARFLOAT,ARRAY)
+MAKEFSUB(regeventdoublearray_,"event.",double,DAVARDOUBLE,ARRAY)
+MAKEFSUB(regparmintarray_,"parm.",int,DAVARINT,ARRAY)
+MAKEFSUB(regeventintarray_,"event.",int,DAVARINT,ARRAY)
+
+MAKEFSUB(regtestint_,"test.",int,DAVARINT,SCALER)
+MAKEFSUB(regtestintarray_,"test.",int,DAVARINT,ARRAY)
+#endif
+
+/* Entry points for String registration. Do entry points for anything other
+than parmameters make sense? */
+#ifdef AbsoftUNIXFortran
+int regparmstring
+#else
+int regparmstring_
+#endif
+(char *name, char *sptr, char *title
+ ,unsigned l_name, unsigned l_sptr, unsigned l_title)
+{
+ int A0;
+ daVarStruct args;
+ char *BN=0;
+
+ char *BT=0;
+ char *BF = 0;
+
+ BF = malloc(5+l_name+1);
+ strcpy(BF,"parm.");
+ args.name = strcat(BF,((!*(int *)name)?0:memchr(name,'\0',l_name)?name:
+ (memcpy(BN=(char *) malloc(l_name+1),name,l_name)
+ ,BN[l_name]='\0',kill_trailing(BN,' '))));
+ args.title = ((!*(int *)title)?0:memchr(title,'\0',l_title)?title:
+ (memcpy(BT=(char *) malloc(l_title+1),title,l_title)
+ ,BT[l_title]='\0',kill_trailing(BT,' ')));
+ args.size = l_sptr;
+ args.varptr = (void *) sptr;
+ args.flag = DAVAR_READWRITE;
+ args.type = DAVARFSTRING;
+ args.opaque = 0;
+ args.rhook = 0;
+ args.whook = 0;
+ A0 = daVarRegister((int) 0, &args);
+ if(BF) free(BF);
+ if(BN) free(BN);
+ return(A0);
+}
+
+#ifdef NO_TSEARCH
+/*
+ * Tree search generalized from Knuth (6.2.2) Algorithm T just like
+ * the AT&T man page says.
+ *
+ * The node_t structure is for internal use only, lint doesn't grok it.
+ *
+ * Written by reading the System V Interface Definition, not the code.
+ *
+ * Totally public domain.
+ */
+/*LINTLIBRARY*/
+
+/*
+#include <search.h>
+
+typedef struct node_t
+{
+ char *key;
+ struct node_t *left, *right;
+}
+node;
+*/
+
+node *mytsearch(key, rootp, compar)
+/* find or insert datum into search tree */
+void *key; /* key to be located */
+register node **rootp; /* address of tree root */
+int (*compar)(); /* ordering function */
+{
+ register node *q;
+
+ if (rootp == (struct node_t **)0)
+ return ((struct node_t *)0);
+ while (*rootp != (struct node_t *)0) /* Knuth's T1: */
+ {
+ int r;
+
+ if ((r = (*compar)(key, (*rootp)->key)) == 0) /* T2: */
+ return (*rootp); /* we found it! */
+ rootp = (r < 0) ?
+ &(*rootp)->left : /* T3: follow left branch */
+ &(*rootp)->right; /* T4: follow right branch */
+ }
+ q = (node *) malloc(sizeof(node)); /* T5: key not found */
+ if (q != (struct node_t *)0) /* make new node */
+ {
+ *rootp = q; /* link new node to old */
+ q->key = key; /* initialize new node */
+ q->left = q->right = (struct node_t *)0;
+ }
+ return (q);
+}
+
+node *mytdelete(key, rootp, compar)
+/* delete node with given key */
+char *key; /* key to be deleted */
+register node **rootp; /* address of the root of tree */
+int (*compar)(); /* comparison function */
+{
+ node *p;
+ register node *q;
+ register node *r;
+ int cmp;
+
+ if (rootp == (struct node_t **)0 || (p = *rootp) == (struct node_t *)0)
+ return ((struct node_t *)0);
+ while ((cmp = (*compar)(key, (*rootp)->key)) != 0)
+ {
+ p = *rootp;
+ rootp = (cmp < 0) ?
+ &(*rootp)->left : /* follow left branch */
+ &(*rootp)->right; /* follow right branch */
+ if (*rootp == (struct node_t *)0)
+ return ((struct node_t *)0); /* key not found */
+ }
+ r = (*rootp)->right; /* D1: */
+ if ((q = (*rootp)->left) == (struct node_t *)0) /* Left (struct node_t *)0? */
+ q = r;
+ else if (r != (struct node_t *)0) /* Right link is null? */
+ {
+ if (r->left == (struct node_t *)0) /* D2: Find successor */
+ {
+ r->left = q;
+ q = r;
+ }
+ else
+ { /* D3: Find (struct node_t *)0 link */
+ for (q = r->left; q->left != (struct node_t *)0; q = r->left)
+ r = q;
+ r->left = q->right;
+ q->left = (*rootp)->left;
+ q->right = (*rootp)->right;
+ }
+ }
+ free((struct node_t *) *rootp); /* D4: Free node */
+ *rootp = q; /* link parent to new node */
+ return(p);
+}
+
+static void trecurse(root, action, level)
+/* Walk the nodes of a tree */
+register node *root; /* Root of the tree to be walked */
+register void (*action)(); /* Function to be called at each node */
+register int level;
+{
+ if (root->left == (struct node_t *)0 && root->right == (struct node_t *)0)
+ (*action)(root, leaf, level);
+ else
+ {
+ (*action)(root, preorder, level);
+ if (root->left != (struct node_t *)0)
+ trecurse(root->left, action, level + 1);
+ (*action)(root, postorder, level);
+ if (root->right != (struct node_t *)0)
+ trecurse(root->right, action, level + 1);
+ (*action)(root, endorder, level);
+ }
+}
+
+void mytwalk(root, action) /* Walk the nodes of a tree */
+node *root; /* Root of the tree to be walked */
+void (*action)(); /* Function to be called at each node */
+{
+ if (root != (node *)0 && action != (void(*)())0)
+ trecurse(root, action, 0);
+}
+
+/* mytsearch.c ends here */
+/*
+ * Tree search generalized from Knuth (6.2.2) Algorithm T just like
+ * the AT&T man page says.
+ *
+ * The node_t structure is for internal use only, lint doesn't grok it.
+ *
+ * Written by reading the System V Interface Definition, not the code.
+ *
+ * Totally public domain.
+ */
+/*LINTLIBRARY*/
+/*
+#include <search.h>
+
+typedef struct node_t
+{
+ char *key;
+ struct node_t *left, *right;
+} node;
+*/
+
+node *mytfind(key, rootp, compar)
+/* find a node, or return 0 */
+void *key; /* key to be found */
+register node **rootp; /* address of the tree root */
+int (*compar)(); /* ordering function */
+{
+ if (rootp == (struct node_t **)0)
+ return ((struct node_t *)0);
+ while (*rootp != (struct node_t *)0) /* T1: */
+ {
+ int r;
+ if ((r = (*compar)(key, (*rootp)->key)) == 0) /* T2: */
+ return (*rootp); /* key found */
+ rootp = (r < 0) ?
+ &(*rootp)->left : /* T3: follow left branch */
+ &(*rootp)->right; /* T4: follow right branch */
+ }
+ return (node *)0;
+}
+#endif
diff --git a/CTP/daVarRpc.x b/CTP/daVarRpc.x
new file mode 100644
index 0000000..d8fd131
--- /dev/null
+++ b/CTP/daVarRpc.x
@@ -0,0 +1,114 @@
+/*-----------------------------------------------------------------------------
+ * Copyright (c) 1993 Southeastern Universities Research Association,
+ * Continuous Electron Beam Accelerator Facility
+ *
+ * This software was developed under a United States Government license
+ * described in the NOTICE file included as part of this distribution.
+ *
+ * Stephen A. Wood, 12000 Jefferson Ave., Newport News, VA 23606
+ * Email: saw@cebaf.gov Tel: (804) 249-7367 Fax: (804) 249-5800
+ *-----------------------------------------------------------------------------
+ *
+ * Description:
+ * daVar RPCGEN input file
+ *
+ * Author: Stephen Wood, CEBAF Hall C
+ *
+ * Revision History:
+ * $Log: daVarRpc.x,v $
+ * Revision 1.2 1999/11/04 20:34:04 saw
+ * Alpha compatibility.
+ * New RPC call needed for root event display.
+ * Start of code to write ROOT trees (ntuples) from new "tree" block
+ *
+ * Revision 1.4 1999/08/25 13:16:05 saw
+ * *** empty log message ***
+ *
+ * Revision 1.3 1994/11/07 14:33:12 saw
+ * Add testnamelist structure and readmultiple_test and family rpc's
+ *
+ * Revision 1.2 1993/11/24 22:01:35 saw
+ * Add double variable type
+ *
+ * Revision 1.1 1993/05/10 21:10:37 saw
+ * Initial revision
+ *
+ */
+
+%#include <time.h>
+%#define _xdr_result xdr_result
+%#define _xdr_argument xdr_argument
+
+#if defined(RPC_HDR) || defined(RPC_XDR) || defined(RPC_SVC) || \
+ defined(RPC_CLNT) || defined(RPC_TBL)
+#define RPCGEN
+#else
+#undef RPCGEN
+#endif
+
+#include "daVar.h"
+const DAVARINT_RPC = DAVARINT;
+const DAVARFLOAT_RPC = DAVARFLOAT;
+const DAVARDOUBLE_RPC = DAVARDOUBLE;
+const DAVARSTRING_RPC = DAVARSTRING;
+const DAVARERROR_RPC = 999;
+
+typedef string PNAME<>;
+typedef PNAME NAMELIST<>;
+
+union any switch (int valtype) {
+ case DAVARINT_RPC:
+ int i<>;
+ case DAVARFLOAT_RPC:
+ float r<>;
+ case DAVARDOUBLE_RPC:
+ double d<>;
+ case DAVARSTRING_RPC:
+ string s<>;
+ case DAVARERROR_RPC:
+ int error;
+ default:
+ void;
+};
+
+struct wany {
+ PNAME name;
+ any *val;
+};
+
+typedef any RVALLIST<>;
+
+typedef wany WVALLIST<>;
+
+typedef int ERRLIST<>;
+
+struct TESTNAMELIST {
+ /* Can we have a more generic structure fore this? */
+ string test_condition<>;
+ int max_time_wait; /* Seconds before failing */
+ int max_event_wait; /* # of events before failing */
+ int prog;
+ int vers;
+ NAMELIST *NAMELISTP;
+};
+
+program DAVARSVR {
+ version DAVARVERS {
+ int DAVAR_ACKMESSAGE(string) = 101;
+ NAMELIST DAVAR_GETLIST(string) = 102;
+ RVALLIST DAVAR_READMULTIPLE(NAMELIST) = 103;
+ ERRLIST DAVAR_WRITEMULTIPLE(WVALLIST) = 104;
+ int DAVAR_READMULTIPLE_TEST(TESTNAMELIST) = 105;
+#if defined(RPC_HDR) || defined(RPC_XDR) || defined(RPC_SVC)
+ int DAVAR_READMULTIPLE_TEST_CB(RVALLIST) = 106; /* Call Back */
+#endif
+ WVALLIST DAVAR_READPATTERNMATCH(string) = 107;
+/* double HACK(int) = 201;*/
+ } = 1;
+} = 0x2c0daFF8;
+
+/*
+Local Variables:
+mode: c
+End:
+*/
diff --git a/CTP/daVarRpcProc.c b/CTP/daVarRpcProc.c
new file mode 100644
index 0000000..0bd5674
--- /dev/null
+++ b/CTP/daVarRpcProc.c
@@ -0,0 +1,452 @@
+/*-----------------------------------------------------------------------------
+ * Copyright (c) 1993 Southeastern Universities Research Association,
+ * Continuous Electron Beam Accelerator Facility
+ *
+ * This software was developed under a United States Government license
+ * described in the NOTICE file included as part of this distribution.
+ *
+ * Stephen A. Wood, 12000 Jefferson Ave., Newport News, VA 23606
+ * Email: saw@cebaf.gov Tel: (804) 249-7367 Fax: (804) 249-5800
+ *-----------------------------------------------------------------------------
+ *
+ * Description:
+ * RPC server interface routines.
+ * Actual rpc routines on the server side. These routines repackage
+ * the rpc argument and call the real server routines.
+ *
+ * Author: Stephen Wood, CEBAF Hall C
+ *
+ * Revision History:
+ * $Log: daVarRpcProc.c,v $
+ * Revision 1.2.24.1 2007/09/10 21:32:47 pcarter
+ * Implemented changes to allow compilation on RHEL 3,4,5 and MacOSX
+ *
+ * Revision 1.2 1999/11/04 20:34:04 saw
+ * Alpha compatibility.
+ * New RPC call needed for root event display.
+ * Start of code to write ROOT trees (ntuples) from new "tree" block
+ *
+ * Revision 1.5 1999/08/25 13:16:05 saw
+ * *** empty log message ***
+ *
+ * Revision 1.4 1999/03/01 19:52:30 saw
+ * Need svc_soc.h on sun
+ *
+ * Revision 1.3 1994/11/07 14:15:46 saw
+ * Add davar_readmultiple_test_1
+ * Add Callback routine
+ * On HP, replace broken xdr_free's with my own freeing
+ *
+ * Revision 1.2 1993/12/03 19:30:58 saw
+ * Remove some miscelaneous print statements
+ *
+ * Revision 1.1 1993/05/10 21:14:59 saw
+ * Initial revision
+ *
+ */
+
+#include <stdio.h>
+#include <rpc/rpc.h> /* always need this here */
+#ifdef __sun
+#include <rpc/svc_soc.h>
+#endif
+#include <limits.h>
+#include "daVarRpc.h" /* need this too: generated by rpcgen */
+#include <sys/socket.h>
+#include <netdb.h>
+#include <netinet/in.h>
+#include <time.h>
+
+#include "cfortran.h"
+#include "daVar.h"
+#include "daVarHandlers.h"
+
+#ifdef hpux
+#define xdr_on_hp_is_broken
+#endif
+
+int daVarCallBack();
+FCALLSCFUN0(INT,daVarCallBack,THCALLBACK,thcallback);
+
+
+static struct timeval TIMEOUT = { 5, 0}; /* Allow 5 seconds for timeout */
+/*
+ * Remote verson of "ackmessage"
+ */
+int *nullproc_1(int *argp, CLIENT *clnt)
+{
+ static int result;
+
+ result = 0;
+
+ return(&result);
+}
+/*
+ * Remote verson of "ackmessage"
+ */
+int *
+davar_ackmessage_1(char **argp, CLIENT *clnt)
+{
+
+ static int result;
+
+/* printf("Ack: %s\n",*argp);*/
+ result = strlen(*argp);
+
+ return(&result);
+}
+
+int *
+davar_ackmessage_1_svc(char **argp, struct svc_req *svc)
+{
+ CLIENT *clnt;
+ return(davar_ackmessage_1(argp,clnt));
+}
+
+NAMELIST *
+davar_getlist_1(char **argp, CLIENT *clnt)
+{
+
+ static NAMELIST result={0,0};
+ char **list;
+ int i, count;
+
+ if(result.NAMELIST_val){
+/* printf("Freeing previous list\n");*/
+ daVarFreeList(result.NAMELIST_val);
+ }
+ daVarList(*argp,&list,&count); /* Check error code */
+ result.NAMELIST_len = count;
+ result.NAMELIST_val = list;
+
+ return(&result);
+}
+
+NAMELIST *
+davar_getlist_1_svc(char **argp, struct svc_req *svc)
+{
+ CLIENT *clnt;
+ return(davar_getlist_1(argp,clnt));
+}
+
+
+RVALLIST *davar_readmultiple_1(NAMELIST *argp, CLIENT *clnt)
+{
+ static RVALLIST result;
+ int i;
+ static int need_to_free=0;
+
+/* minfo = mallinfo();
+ printf("AA:%d %d\n",minfo.arena,minfo.ordblks);*/
+ if(need_to_free) {
+#ifdef xdr_on_hp_is_broken
+ for(i=0; i<result.RVALLIST_len; i++){
+ free(result.RVALLIST_val[i].any_u.i.i_val);
+ }
+ free(result.RVALLIST_val);
+#else
+ xdr_free(xdr_RVALLIST, (void *) &result);
+#endif
+ } else need_to_free = 1;
+/* minfo = mallinfo();
+ printf("BB:%d %d\n",minfo.arena,minfo.ordblks);*/
+
+ result.RVALLIST_len = argp->NAMELIST_len;
+ result.RVALLIST_val = (any *) malloc(result.RVALLIST_len*sizeof(any));
+
+ for(i=0; i<argp->NAMELIST_len; i++){
+ daVarReadVar(argp->NAMELIST_val[i],&(result.RVALLIST_val[i]));
+ }
+ return(&result);
+}
+
+RVALLIST *davar_readmultiple_1_svc(NAMELIST *argp, struct svc_req *svc)
+{
+ CLIENT *clnt;
+ return(davar_readmultiple_1(argp,clnt));
+}
+
+ERRLIST *davar_writemultiple_1(WVALLIST *argp, CLIENT *clnt)
+{
+ static ERRLIST result;
+ int i;
+
+ xdr_free(xdr_ERRLIST, (void *) &result);
+
+ result.ERRLIST_len = argp->WVALLIST_len;
+ result.ERRLIST_val = (int *) malloc(result.ERRLIST_len*sizeof(any));
+
+ for(i=0; i<argp->WVALLIST_len; i++){
+ result.ERRLIST_val[i] =
+ daVarWriteVar(argp->WVALLIST_val[i].name,argp->WVALLIST_val[i].val);
+ }
+ return(&result);
+}
+
+ERRLIST *davar_writemultiple_1_svc(WVALLIST *argp, struct svc_req *svc)
+{
+ CLIENT *clnt;
+ return(davar_writemultiple_1(argp,clnt));
+}
+
+daVarCallBackList *thCallBackListP=0;
+
+int *davar_readmultiple_test_1(TESTNAMELIST *argp, CLIENT *clnt)
+{ /* Code fragment to get client info */
+ static int result;
+ int i;
+ daVarCallBackList *next,*this;
+
+ TESTNAMELIST *argcopy;
+
+ SVCXPRT *transp;
+ struct sockaddr_in *sock,*sockcopy;
+
+/* printf("IN davar_readmultiple_test_1\n");*/
+ sock = (struct sockaddr_in *)
+ svc_getcaller(((struct svc_req *) clnt)->rq_xprt);
+
+ /* Copy the arguments */
+ argcopy = (TESTNAMELIST *) malloc(sizeof(TESTNAMELIST));
+ argcopy->test_condition = (char *) malloc(strlen(argp->test_condition)+1);
+ strcpy(argcopy->test_condition, argp->test_condition);
+ argcopy->max_time_wait = argp->max_time_wait;
+ argcopy->max_event_wait = argp->max_event_wait;
+ argcopy->prog = argp->prog;
+ argcopy->vers = argp->vers;
+ argcopy->NAMELISTP = (NAMELIST *) malloc(sizeof(NAMELIST));
+ argcopy->NAMELISTP->NAMELIST_len = argp->NAMELISTP->NAMELIST_len;
+ argcopy->NAMELISTP->NAMELIST_val =
+ (char **) malloc(argp->NAMELISTP->NAMELIST_len*sizeof(char *));
+ for(i=0; i<argp->NAMELISTP->NAMELIST_len; i++){
+ argcopy->NAMELISTP->NAMELIST_val[i] = (char *)
+ malloc(strlen(argp->NAMELISTP->NAMELIST_val[i])+1);
+ strcpy(argcopy->NAMELISTP->NAMELIST_val[i]
+ ,argp->NAMELISTP->NAMELIST_val[i]);
+ }
+ /* Copy the socket */
+ sockcopy = (struct sockaddr_in *) malloc(sizeof(struct sockaddr_in));
+ bzero(sockcopy,sizeof(struct sockaddr_in));
+ bcopy(sock,sockcopy,sizeof(struct sockaddr_in));
+
+/* printf("Socket copied\n");*/
+ next = thCallBackListP;
+ this = thCallBackListP = (daVarCallBackList *)
+ malloc(sizeof(daVarCallBackList));
+ this->sock_in = sockcopy; /* Actually need to copy structure */
+ this->list = argcopy;
+ this->start_time = time(0); /* Record when request came in */
+ this->next = next;
+
+
+#if 0
+ hp = (struct hostent *)
+ gethostbyaddr((char *)&sockcopy->sin_addr, sizeof(sockcopy->sin_addr),AF_INET);
+ printf("%s %s\n", inet_ntoa(sockcopy->sin_addr), hp->h_name);
+#endif
+
+ result = S_SUCCESS;
+ return(&result);
+}
+
+int *davar_readmultiple_test_1_svc(TESTNAMELIST *argp, struct svc_req *svc)
+{
+ CLIENT *clnt;
+ return(davar_readmultiple_test_1(argp,clnt));
+}
+
+int *
+davar_readmultiple_test_cb_1(argp, clnt)
+ RVALLIST *argp;
+ CLIENT *clnt;
+{
+ static int clnt_res;
+ enum clnt_stat clnt_stat;
+
+#if 0
+ {
+ struct sockaddr_in sock;
+ struct hostent *hp;
+
+ clnt_control(clnt, CLGET_SERVER_ADDR, (char *) &sock);
+ hp = (struct hostent *)
+ gethostbyaddr((char *)&sock.sin_addr, sizeof(sock.sin_addr),AF_INET);
+ printf("cb_1: %s %s\n", inet_ntoa(sock.sin_addr), hp->h_name);
+ }
+#endif
+
+ memset((char *)&clnt_res, 0, sizeof(clnt_res));
+ if ((clnt_stat = clnt_call(clnt, DAVAR_READMULTIPLE_TEST_CB, xdr_RVALLIST, argp, xdr_int, &clnt_res, TIMEOUT)) != RPC_SUCCESS) {
+ printf("clnt call failed, clnt_stat = %d\n",clnt_stat);
+ clnt_perrno(clnt_stat);
+ return (NULL);
+ }
+ return (&clnt_res);
+}
+
+int *davar_readmultiple_test_cb_1_svc(RVALLIST *argp, struct svc_req *svc)
+{
+ CLIENT *clnt;
+ return(davar_readmultiple_test_cb_1(argp,clnt));
+}
+
+WVALLIST *davar_readpatternmatch_1(char **argp, CLIENT *clnt)
+{
+ static WVALLIST result;
+ int i;
+ static int need_to_free=0;
+ char *pattern;
+ char **vlist;
+ int count;
+
+/* minfo = mallinfo();
+ printf("AA:%d %d\n",minfo.arena,minfo.ordblks);*/
+ /* printf("In davar_readpatternmatch_1 doing pattern '%s'\n",*argp);*/
+ if(need_to_free) {
+#ifdef xdr_on_hp_is_broken
+ for(i=0; i<result.WVALLIST_len; i++){
+ free(result.WVALLIST_val[i].val->any_u.i.i_val);
+ free(result.WVALLIST_val[i].name);
+ }
+ free(result.WVALLIST_val);
+#else
+ xdr_free(xdr_WVALLIST, (void *) &result);
+#endif
+ } else need_to_free = 1;
+/* minfo = mallinfo();
+ printf("BB:%d %d\n",minfo.arena,minfo.ordblks);*/
+
+ daVarList(*argp,&vlist,&count);
+
+ result.WVALLIST_len = count;
+ result.WVALLIST_val = (wany *) malloc(count*sizeof(wany));
+
+ for(i=0; i<count; i++){
+ /* printf("%d: %s\n",i,vlist[i]);*/
+ result.WVALLIST_val[i].name = (char *) malloc(strlen(vlist[i])+1);
+ strcpy(result.WVALLIST_val[i].name,vlist[i]);
+ /* daVarReadVar(vlist[i],&(result.WVALLIST_val[i].val));*/
+ result.WVALLIST_val[i].val = malloc(sizeof(any));
+ daVarReadVar(vlist[i],result.WVALLIST_val[i].val);
+ }
+ /* daVarFreeList(vlist);*/
+ return(&result);
+}
+
+WVALLIST *davar_readpatternmatch_1_svc(char **argp, struct svc_req *svc)
+{
+ CLIENT *clnt;
+ return(davar_readpatternmatch_1(argp,clnt));
+}
+
+int daVarCallBack()
+/* Scan the list of pending readmultiple requests. Make a call back for
+ each request for which the test is true or blank. Ignore the time
+ out stuff for now. */
+{
+ daVarCallBackList *this,*next,**last;
+ TESTNAMELIST *argp;
+ struct sockaddr_in *sock_in;
+ struct hostent *hp;
+ DAINT itest;
+ static RVALLIST rpc;
+ CLIENT *clnt;
+ int i;
+ int *status;
+ int pending,processed;
+ int testresult,timeout;
+
+ this = thCallBackListP;
+ last = &thCallBackListP;
+ pending = 0;
+ processed = 0;
+
+ while(this) {
+ argp = this->list;
+ argp->max_event_wait--;
+ testresult = (argp->test_condition == 0 ||
+ argp->test_condition[0] == '\0' ||
+ (thEvalImed(argp->test_condition,0,&itest),itest));
+ timeout = (argp->max_event_wait < 0
+ || (time(0)-this->start_time) > argp->max_time_wait);
+ if(testresult || timeout) {
+ sock_in = this->sock_in;
+/* printf("PORT=%d,%x\n",sock_in->sin_port,htonl(sock_in->sin_addr.s_addr));*/
+ hp = (struct hostent *)
+ gethostbyaddr((char *)&sock_in->sin_addr, sizeof(sock_in->sin_addr)
+ ,AF_INET);
+/* printf("Creating client for %s(%x %x)\n",hp->h_name
+ ,argp->prog,argp->vers);*/
+ if(testresult) {
+ /* Build the structure with the return data */
+ rpc.RVALLIST_len = argp->NAMELISTP->NAMELIST_len;
+ rpc.RVALLIST_val = (any *) malloc(rpc.RVALLIST_len*sizeof(any));
+
+ for(i=0; i<argp->NAMELISTP->NAMELIST_len; i++){
+ daVarReadVar(argp->NAMELISTP->NAMELIST_val[i],
+ &(rpc.RVALLIST_val[i]));
+ }
+ } else {
+ rpc.RVALLIST_len = 0;
+ rpc.RVALLIST_val = 0;
+ }
+ {
+ /* This is really weird. clnt_create only works if we copy the hostname*/
+ char *host;
+ host = malloc(strlen(hp->h_name)+1);
+ strcpy(host,hp->h_name);
+ clnt = clnt_create(host, argp->prog, argp->vers, "tcp");
+ free(host);
+ }
+ {
+ /* This is really weird. On the alpha it seems we need to copy the
+ host name to a separate variable. Maybe clnt_create calls some
+ function that mucks with the hp structure. */
+ char *host;
+ host = malloc(strlen(hp->h_name)+1);
+ strcpy(host,hp->h_name);
+ clnt = clnt_create(host, argp->prog, argp->vers, "tcp");
+ if(clnt) {
+ status = davar_readmultiple_test_cb_1(&rpc, clnt);
+ clnt_destroy(clnt);
+ /* We don't care what the status was. */
+ } else {
+ fprintf(stderr,"Callback to %s failed\n",host);
+ }
+ free(host);
+ }
+#ifdef xdr_on_hp_is_broken
+ if(testresult) {
+ for(i=0; i<argp->NAMELISTP->NAMELIST_len; i++){
+ free(rpc.RVALLIST_val[i].any_u.i.i_val);
+ }
+ free(rpc.RVALLIST_val);
+ }
+ for(i=0; i<argp->NAMELISTP->NAMELIST_len;i++){
+ free(argp->NAMELISTP->NAMELIST_val[i]);
+ }
+ free(argp->NAMELISTP->NAMELIST_val);
+ free(argp->NAMELISTP);
+ free(argp->test_condition);
+#else
+ if(testresult) {
+ xdr_free(xdr_RVALLIST, (void *) &rpc);
+ }
+ xdr_free(xdr_TESTNAMELIST, (void *) argp);
+#endif
+ free(argp);
+ free(this->sock_in);
+ next = this->next;
+ *last = next;
+ free(this);
+ this = next;
+ processed++;
+ } else {
+ last = &(this->next);
+ this = this->next;
+ pending++;
+ }
+ }
+ if(processed&&pending==0) return(-1);
+ else return(pending);
+}
diff --git a/CTP/daVarServ.c b/CTP/daVarServ.c
new file mode 100644
index 0000000..8c27aa5
--- /dev/null
+++ b/CTP/daVarServ.c
@@ -0,0 +1,153 @@
+/*-----------------------------------------------------------------------------
+ * Copyright (c) 1994 Southeastern Universities Research Association,
+ * Continuous Electron Beam Accelerator Facility
+ *
+ * This software was developed under a United States Government license
+ * described in the NOTICE file included as part of this distribution.
+ *
+ * Stephen A. Wood, 12000 Jefferson Ave., Newport News, VA 23606
+ * Email: saw@cebaf.gov Tel: (804) 249-7367 Fax: (804) 249-5800
+ *-----------------------------------------------------------------------------
+ *
+ * Description:
+ * This file also contains some routines to help set up servers.
+ *
+ * Author: Stephen Wood, CEBAF Hall C
+ *
+ * Revision History:
+ * $Log: daVarServ.c,v $
+ * Revision 1.3 2003/02/21 20:55:24 saw
+ * Clean up some types and casts to reduce compiler warnings.
+ *
+ * Revision 1.2 1999/11/04 20:34:05 saw
+ * Alpha compatibility.
+ * New RPC call needed for root event display.
+ * Start of code to write ROOT trees (ntuples) from new "tree" block
+ *
+ * Revision 1.2 1995/01/09 16:03:50 saw
+ * include errno.h
+ *
+ * Revision 1.1 1994/11/07 14:19:57 saw
+ * Initial revision
+ *
+ */
+
+#include <stdio.h>
+#include <rpc/rpc.h> /* always need this here */
+#include "daVarRpc.h" /* need this too: generated by rpcgen */
+#include <errno.h>
+#if 0
+#include <stdlib.h>
+#include <rpc/pmap_clnt.h>
+#include <memory.h>
+#include <sys/socket.h>
+#include <netinet/in.h>
+#include <time.h>
+#endif
+
+#include "cfortran.h"
+
+void davarsvr_1(struct svc_req *rqstp, register SVCXPRT *transp);
+
+int daVarServSet(int prog, int version);
+int daVarServUnSet(int prog, int version);
+int daVarServOnce(int wait);
+FCALLSCFUN2(INT,daVarServSet,THSERVSET,thservset,INT,INT);
+FCALLSCFUN2(INT,daVarServUnSet,THSERVUNSET,thservunset,INT,INT);
+FCALLSCFUN1(INT,daVarServOnce,THSERVONE,thservone,INT);
+
+int last_program,last_version; /* Save these for daVarServUnSet */
+SVCXPRT *udp_transp,*tcp_transp; /* Descriptors that go with above */
+
+int daVarGetProgVers(int *prog, int *version)
+{
+ *prog = last_program;
+ *version = last_version;
+}
+int daVarServSet(int prog, int version)
+{
+
+ if(prog==0) prog = DAVARSVR;
+ if(version==0) version = DAVARVERS;
+ (void) pmap_unset(prog,version);
+ last_program = prog;
+ last_version = version;
+
+ udp_transp = (SVCXPRT *) svcudp_create(RPC_ANYSOCK);
+ if (udp_transp == NULL) {
+ fprintf(stderr, "cannot create udp service.");
+ exit(1);
+ }
+ if (!svc_register(udp_transp, prog, version, davarsvr_1, IPPROTO_UDP)) {
+ fprintf(stderr, "unable to register (%d, %d), udp).\n",prog,version);
+ exit(1);
+ }
+
+ tcp_transp = (SVCXPRT *) svctcp_create(RPC_ANYSOCK, 0, 0);
+ if (tcp_transp == NULL) {
+ fprintf(stderr, "cannot create tcp service.\n");
+ exit(1);
+ }
+ if (!svc_register(tcp_transp, prog, version, davarsvr_1, IPPROTO_TCP)) {
+ fprintf(stderr, "unable to register (%d, %d), tcp).\n",prog,version);
+ exit(1);
+ }
+
+}
+
+int daVarServUnSet(int prog, int version)
+{
+ register SVCXPRT *transp;
+
+ if(prog==0) prog = last_program;
+ if(version==0) version = last_version;
+ (void) pmap_unset(prog,version);
+ if(prog==last_program && version == last_version){
+ if(udp_transp) svc_destroy(udp_transp);
+ if(tcp_transp) svc_destroy(tcp_transp);
+ }
+ return(0);
+}
+
+int daVarServOnce(int wait)
+{
+ fd_set readfdset;
+ extern int errno;
+ int status;
+ struct timeval timeout;
+ struct timeval *timeoutp;
+ static int tsize=0;
+
+ if(wait>=0) {
+ timeout.tv_sec = wait;
+ timeout.tv_usec = 1;
+ timeoutp = &timeout;
+ } else {
+ timeoutp = 0;
+ }
+
+#ifdef hpux
+ if(!tsize) tsize = NFDBITS;
+#else
+ if(!tsize) tsize = getdtablesize(); /* how many descriptors can we have */
+#endif
+
+ readfdset = svc_fdset;
+ switch((status=select(tsize, &readfdset, (fd_set *) NULL, (fd_set *) NULL,
+ timeoutp))) {
+ case -1:
+ if (errno == EBADF) break;
+ perror("select failed");
+ break;
+ case 0:
+ /* perform other functions here if select() timed-out */
+ break;
+ default:
+ svc_getreqset(&readfdset);
+ status = 1;
+ }
+ return(status);
+}
+
+
+
diff --git a/CTP/fnmatch.h b/CTP/fnmatch.h
new file mode 100644
index 0000000..f727b14
--- /dev/null
+++ b/CTP/fnmatch.h
@@ -0,0 +1,61 @@
+/* $Log: fnmatch.h,v $
+/* Revision 1.1 1999/06/23 13:40:25 saw
+/* Need for Linux
+/*
+ * Revision 1.1 1994/11/21 03:52:23 saw
+ * Initial revision
+ * */
+/*-
+ * Copyright (c) 1992, 1993
+ * The Regents of the University of California. All rights reserved.
+ *
+ * Redistribution and use in source and binary forms, with or without
+ * modification, are permitted provided that the following conditions
+ * are met:
+ * 1. Redistributions of source code must retain the above copyright
+ * notice, this list of conditions and the following disclaimer.
+ * 2. Redistributions in binary form must reproduce the above copyright
+ * notice, this list of conditions and the following disclaimer in the
+ * documentation and/or other materials provided with the distribution.
+ * 3. All advertising materials mentioning features or use of this software
+ * must display the following acknowledgement:
+ * This product includes software developed by the University of
+ * California, Berkeley and its contributors.
+ * 4. Neither the name of the University nor the names of its contributors
+ * may be used to endorse or promote products derived from this software
+ * without specific prior written permission.
+ *
+ * THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND
+ * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+ * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+ * ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE
+ * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+ * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
+ * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
+ * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
+ * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
+ * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
+ * SUCH DAMAGE.
+ *
+ * @(#)fnmatch.h 8.1 (Berkeley) 6/2/93
+ */
+
+#ifndef _FNMATCH_H_
+#define _FNMATCH_H_
+
+#define FNM_NOMATCH 1 /* Match failed. */
+
+#define FNM_NOESCAPE 0x01 /* Disable backslash escaping. */
+#define FNM_PATHNAME 0x02 /* Slash must be matched by slash. */
+#define FNM_PERIOD 0x04 /* Period must be matched by period. */
+
+/*#include <sys/cdefs.h>*/
+
+/*__BEGIN_DECLS*/
+#ifndef _POSIX_SOURCE
+/*int fnmatch __P((const char *, const char *, int));*/
+int fnmatch(const char *, const char *, int);
+#endif
+/*__END_DECLS*/
+
+#endif /* !_FNMATCH_H_ */
diff --git a/CTP/hbook.h b/CTP/hbook.h
new file mode 100644
index 0000000..9763790
--- /dev/null
+++ b/CTP/hbook.h
@@ -0,0 +1,417 @@
+/* hbook.h */
+/* Burkhard Burow, University of Toronto, 1991. */
+
+#ifndef __HBOOK_LOADED
+#define __HBOOK_LOADED 1
+
+#include "cfortran.h"
+
+/* HBOOK Version 4. User Guide of October 28, 1987. */
+/* Some internal routines, not in the guide, are given at the end. */
+
+/* The variables of the following routines are DOUBLEV on all machines, except
+ on the CRAY where they are FLOATV. Note that this implies C programmers
+7.3.1.1 a) HFITL : P do not need to change their routines
+7.3.1.1 b) HFITS : P when moving code to/from the CRAY.
+7.3.1.2 HFITN : P [As long as these variables are
+7.3.1.2 HFIT1 : P declared double[] in C, since
+7.3.1.3 HDERI1: PAR, DER float==double on the CRAY.]
+7.3.1.3 HDERI2: PAR, DER
+7.3.1.3 HDERIN: PAR, DER
+7.4.1 HPARAM: COEFF
+7.4.2 HPARMN: COEFF
+*/
+
+/* Chapter 2 FUNDAMENTALS */
+
+/* 2.1 Booking */
+#define HBOOK1(ID,CHTITLE,NX,XMI,XMA,VMX) \
+ CCALLSFSUB6(HBOOK1,hbook1,INT,STRING,INT,FLOAT,FLOAT,FLOAT, \
+ ID,CHTITLE,NX,XMI,XMA,VMX)
+#define HBOOK2(ID,CHTITLE,NX,XMI,XMA,NY,YMI,YMA,VMX) \
+ CCALLSFSUB9(HBOOK2,hbook2,INT,STRING,INT,FLOAT,FLOAT,INT,FLOAT,FLOAT,FLOAT, \
+ ID,CHTITLE,NX,XMI,XMA,NY,YMI,YMA,VMX)
+#define HBOOKN(ID,CHTITLE,NVAR,CHRZPA,NPRIME,TAGS) \
+ CCALLSFSUB6(HBOOKN,hbookn,INT,STRING,INT,STRING,INT,STRINGV, \
+ ID,CHTITLE,NVAR,CHRZPA,NPRIME,TAGS)
+
+/* 2.2 Filling */
+#define HFILL(ID,X,Y,WEIGHT) \
+ CCALLSFSUB4(HFILL,hfill,INT,FLOAT,FLOAT,FLOAT, ID,X,Y,WEIGHT)
+#define HFN(ID,X) CCALLSFSUB2(HFN,hfn,INT,FLOATV, ID,X)
+
+/* 2.3 Editing */
+#define HISTDO() CCALLSFSUB0(HISTDO,histdo)
+#define HPRINT(ID) CCALLSFSUB1(HPRINT,hprint,INT, ID)
+
+/* 2.? Tables. Don't know where the doc. is other than the code. */
+#define HTABLE(ID2,CHTITLE,NNX,XX0,XX1,NNY,YY0,YY1,VALMAX) \
+ CCALLSFSUB9(HTABLE,htable,INT,STRING,INT,FLOAT,FLOAT,INT,FLOAT,FLOAT,FLOAT, \
+ ID2,CHTITLE,NNX,XX0,XX1,NNY,YY0,YY1,VALMAX)
+
+
+/* Chapter 3 MORE ON BOOKING */
+
+/* 3.1 Histograms with non-equidistant bins */
+#define HBOOKB(ID,CHTITL,NCX,XBINS,VMX) \
+ CCALLSFSUB5(HBOOKB,hbookb,INT,STRING,INT,FLOATV,FLOAT, ID,CHTITL,NCX,XBINS,VMX)
+
+/* 3.2 Profile histograms */
+
+#define HBPROF(ID,CHTITLE,NCX,XLO,XUP,YMIN,YMAX,CHOPT) \
+ CCALLSFSUB8(HBPROF,hbprof,INT,STRING,INT,FLOAT,FLOAT,FLOAT,FLOAT,STRING, \
+ ID,CHTITLE,NCX,XLO,XUP,YMIN,YMAX,CHOPT)
+
+/* 3.3 Rounding */
+#define HBINSZ(YES_OR_NO) CCALLSFSUB1(HBINSZ,hbinsz,STRING, YES_OR_NO)
+
+/* 3.4 Projections, Slices, Bands */
+#define HBPRO(ID,VMX) CCALLSFSUB2(HBPRO,hbpro,INT,FLOAT, ID,VMX)
+#define HBPROX(ID,VMX) CCALLSFSUB2(HBPROX,hbprox,INT,FLOAT, ID,VMX)
+#define HBPROY(ID,VMX) CCALLSFSUB2(HBPROY,hbproy,INT,FLOAT, ID,VMX)
+#define HBANDX(ID,YMI,YMA,VMX) \
+ CCALLSFSUB4(HBANDX,hbandx,INT,FLOAT,FLOAT,FLOAT, ID,YMI,YMA,VMX)
+#define HBANDY(ID,XMI,XMA,VMX) \
+ CCALLSFSUB4(HBANDY,hbandy,INT,FLOAT,FLOAT,FLOAT, ID,XMI,XMA,VMX)
+#define HBSLIX(ID,NSLI,VMX) CCALLSFSUB3(HBSLIX,hbslix,INT,INT,FLOAT, ID,NSLI,VMX)
+#define HBSLIY(ID,NSLI,VMX) CCALLSFSUB3(HBSLIY,hbsliy,INT,INT,FLOAT, ID,NSLI,VMX)
+
+/* 3.5 Statistics */
+#define HBARX(ID) CCALLSFSUB1(HBARX,hbarx,INT, ID)
+#define HBARY(ID) CCALLSFSUB1(HBARY,hbary,INT, ID)
+
+/* 3.6 Copy, Reset and Delete */
+#define HCOPY(ID1,ID2,CHTITL) CCALLSFSUB3(HCOPY,hcopy,INT,INT,STRING, ID1,ID2,CHTITL)
+#define HRESET(ID,CHTITL) CCALLSFSUB2(HRESET,hreset,INT,STRING, ID,CHTITL)
+#define HDELET(ID) CCALLSFSUB1(HDELET,hdelet,INT, ID)
+
+/* 3.7 Function Representation */
+#define HBFUN1(ID,CHTITLE,NX,XMI,XMA,FUN) \
+ CCALLSFSUB6(HBFUN1,hbfun1,INT,STRING,INT,FLOAT,FLOAT,PVOID, \
+ ID,CHTITLE,NX,XMI,XMA,FUN)
+#define HBFUN2(ID,CHTITLE,NX,XMI,XMA,NY,YMI,YMA,FUN) \
+ CCALLSFSUB9(HBFUN2,hbfun2,INT,STRING,INT,FLOAT,FLOAT,INT,FLOAT,FLOAT,PVOID, \
+ ID,CHTITLE,NX,XMI,XMA,NY,YMI,YMA,FUN)
+#define HFUNC(ID,FUN) CCALLSFSUB2(HFUNC,hfunc,INT,PVOID, ID,FUN)
+#define HARRAY(ID,NWORDS,LOC) CCALLSFSUB3(HARRAY,harray,INT,INT,PINT, ID,NWORDS,LOC)
+
+
+/* Chapter 4 FILLING OPTIONS */
+
+/* 4.1 Fast Filling Entries */
+#define HF1(ID,X,WEIGHT) CCALLSFSUB3(HF1,hf1,INT,FLOAT,FLOAT, ID,X,WEIGHT)
+#define HF2(ID,X,Y,WEIGHT) \
+ CCALLSFSUB4(HF2,hf2,INT,FLOAT,FLOAT,FLOAT, ID,X,Y,WEIGHT)
+#define HFF1(ID,NID,X,W) CCALLSFSUB4(HFF1,hff1,INT,PINT,FLOAT,FLOAT, ID,NID,X,W)
+#define HFF2(ID,NID,X,Y,W) \
+ CCALLSFSUB5(HFF2,hff2,INT,PINT,FLOAT,FLOAT,FLOAT, ID,NID,X,Y,W)
+#define HFPAK1(ID,NID,V,N) CCALLSFSUB4(HFPAK1,hfpak1,INT,PINT,FLOATV,INT, ID,NID,V,N)
+#define HIPAK1(ID,NID,IV,N) CCALLSFSUB4(HIPAK1,hipak1,INT,PINT,INTV,INT, ID,NID,IV,N)
+
+/* 4.2 Global Filling */
+#define HPAK(ID,CONTEN) CCALLSFSUB2(HPAK,hpak,INT,FLOATV, ID,CONTEN)
+#define HPAKE(ID,ERRORS) CCALLSFSUB2(HPAKE,hpake,INT,FLOATV, ID,ERRORS)
+
+
+/* Chapter % EDITING */
+
+/* 5.1 Index and General Title */
+#define HINDEX() CCALLSFSUB0(HINDEX,hindex)
+#define HTITLE(CHGTIT) CCALLSFSUB1(HTITLE,htitle,STRING, CHGTIT)
+
+/* 5.3 Graphic Choices (1-dimensional histogram) */
+#define HPCHAR(IOPT,ICHA) CCALLSFSUB2(HPCHAR,hpchar,STRING,STRING, IOPT,ICHA)
+#define HBIGBI(ID,NCOL) CCALLSFSUB2(HBIGBI,hbigbi,INT,INT, ID,NCOL)
+
+/* 5.4 Scale Definition and Normalization */
+#define HMAXIM(ID,CMAX) CCALLSFSUB2(HMAXIM,hmaxim,INT,FLOAT, ID,CMAX)
+#define HMINIM(ID,CMIN) CCALLSFSUB2(HMINIM,hminim,INT,FLOAT, ID,CMIN)
+#define HCOMPA(IDVECT,N) CCALLSFSUB2(HCOMPA,hcompa,INTV,INT, IDVECT,N)
+#define HNORMA(ID,XNORM) CCALLSFSUB2(HNORMA,hnorma,INT,FLOAT, ID,XNORM)
+#define HSCALE(ID,FACTOR) CCALLSFSUB2(HSCALE,hscale,INT,FLOAT, ID,FACTOR)
+
+/* 5.5 Page Control */
+#define HSQUEZ(YES_OR_NO) CCALLSFSUB1(HSQUEZ,hsquez,STRING, YES_OR_NO)
+#define HPAGSZ(NLINES) CCALLSFSUB1(HPAGSZ,hpagsz,INT, NLINES)
+
+/* 5.6 Selective Editing */
+#define HPHIST(ID,CHOICE,NUM) CCALLSFSUB3(HPHIST,hphist,INT,STRING,INT, ID,CHOICE,NUM)
+#define HPROT(ID,CHOICE,NUM) CCALLSFSUB3(HPROT,hprot,INT,STRING,INT, ID,CHOICE,NUM)
+#define HPSCAT(ID) CCALLSFSUB1(HPSCAT,hpscat,INT, ID)
+#define HPTAB(ID) CCALLSFSUB1(HPTAB,hptab,INT, ID)
+#define HPHS(ID) CCALLSFSUB1(HPHS,hphs,INT, ID)
+#define HPHST(ID) CCALLSFSUB1(HPHST,hphst,INT, ID)
+
+/* 5.7 Printing after System Error Recovery */
+#define HPONCE() CCALLSFSUB0(HPONCE,hponce)
+
+
+
+/* Chapter 6 ACCESS TO INFORMATION */
+
+/* 6.1 Testing if a histogram exists in memory */
+PROTOCCALLSFFUN1(INT,HEXIST,hexist,INT)
+#define HEXIST(ID) CCALLSFFUN1(HEXIST,hexist,INT,ID)
+
+/* 6.2 List of histograms */
+#define HID1(IDVECT,N) CCALLSFSUB2(HID1,hid1,INTV,PINT, IDVECT,N)
+#define HID2(IDVECT,N) CCALLSFSUB2(HID2,hid2,INTV,PINT, IDVECT,N)
+#define HIDALL(IDVECT,N) CCALLSFSUB2(HIDALL,hidall,INTV,PINT, IDVECT,N)
+
+/* 6.3 Number of Entries */
+#define HNOENT(ID,NOENT) CCALLSFSUB2(HNOENT,hnoent,INT,PINT, ID,NOENT)
+
+
+/* 6.4 Contents */
+#define HUNPAK(ID,CONTEN,CHOICE,NUM) \
+ CCALLSFSUB4(HUNPAK,hunpak,INT,FLOATV,STRING,INT, ID,CONTEN,CHOICE,NUM)
+PROTOCCALLSFFUN2(FLOAT,HI,hi,INT,INT)
+#define HI(ID,I) CCALLSFFUN2(HI,hi,INT,INT, ID,I)
+PROTOCCALLSFFUN3(FLOAT,HIJ,hij,INT,INT,INT)
+#define HIJ(ID,I,J) CCALLSFFUN3(HIJ,hij,INT,INT,INT, ID,I,J)
+PROTOCCALLSFFUN2(FLOAT,HX,hx,INT,FLOAT)
+#define HX(ID,X) CCALLSFFUN2(HX,hx,INT,FLOAT, ID,X)
+PROTOCCALLSFFUN3(FLOAT,HXY,hxy,INT,FLOAT,FLOAT)
+#define HXY(ID,X,Y) CCALLSFFUN3(HXY,hxy,INT,FLOAT,FLOAT, ID,X,Y)
+
+/* 6.5 Errors */
+PROTOCCALLSFFUN2(FLOAT,HIE,hie,INT,INT)
+#define HIE(ID,I) CCALLSFFUN2(HIE,hie,INT,INT, ID,I)
+PROTOCCALLSFFUN2(FLOAT,HXE,hxe,INT,FLOAT)
+#define HXE(ID,X) CCALLSFFUN2(HXE,hxe,INT,FLOAT, ID,X)
+
+/* 6.6 Associated function */
+PROTOCCALLSFFUN2(FLOAT,HIF,hif,INT,INT)
+#define HIF(ID,I) CCALLSFFUN2(HIF,hif,INT,INT, ID,I)
+
+/* 6.7 Abscissa to channel number */
+#define HXI(ID,X,I) CCALLSFSUB3(HXI,hxi,INT,FLOAT,PINT, ID,X,I)
+#define HXYIJ(ID,X,Y,I,J) \
+ CCALLSFSUB5(HXYIJ,hxyij,INT,FLOAT,FLOAT,PINT,PINT, ID,X,Y,I,J)
+#define HIX(ID,I,X) CCALLSFSUB3(HIX,hix,INT,INT,PFLOAT, ID,I,X)
+#define HIJXY(ID,I,J,X,Y) \
+ CCALLSFSUB5(HIJXY,hijxy,INT,INT,INT,PFLOAT,PFLOAT, ID,I,J,X,Y)
+
+/* 6.8 Maximum and Minimum */
+PROTOCCALLSFFUN1(FLOAT,HMAX,hmax,INT)
+#define HMAX(ID) CCALLSFFUN1(HMAX,hmax,INT, ID)
+PROTOCCALLSFFUN1(FLOAT,HMIN,hmin,INT)
+#define HMIN(ID) CCALLSFFUN1(HMIN,hmin,INT, ID)
+
+/* 6.9 Integrated contents */
+PROTOCCALLSFFUN1(FLOAT,HSUM,hsum,INT)
+#define HSUM(ID) CCALLSFFUN1(HSUM,hsum,INT, ID)
+
+/* 6.10 Rebinning */
+#define HREBIN(ID,X,Y,EX,EY,N,IFIRST,ILAST) \
+ CCALLSFSUB8(HREBIN,hrebin,INT,FLOATV,FLOATV,FLOATV,FLOATV,INT,INT,INT, \
+ ID,X,Y,EX,EY,N,IFIRST,ILAST)
+
+/* 6.11 Histogram address and definnition */
+#define HLOCAT(ID,LOC) CCALLSFSUB2(HLOCAT,hlocat,INT,PINT, ID,LOC)
+#define HGIVE(ID,CHTITL,NX,XMI,XMA,NY,YMI,YMA,NWT,LOC) \
+ CCALLSFSUB10(HGIVE,hgive,INT,PSTRING,PINT,PFLOAT,PFLOAT,PINT,PFLOAT,PFLOAT,PINT,PINT,\
+ ID,CHTITL,NX,XMI,XMA,NY,YMI,YMA,NWT,LOC)
+#define HDUMP(ID) CCALLSFSUB1(HDUMP,hdump,INT, ID)
+
+/* 6.12 Statistics */
+PROTOCCALLSFFUN4(FLOAT,HSTATI,hstati,INT,INT,STRING,INT)
+#define HSTATI(ID,ICASE,CHOICE,NUM) \
+ CCALLSFFUN4(HSTATI,hstati,INT,INT,STRING,INT, ID,ICASE,CHOICE,NUM)
+
+
+/* Chapter 7 OPERATIONS ON HISTOGRAMS, FITTINGS */
+
+/* 7.1 Arithmetic */
+#define HOPERA(ID1, CHOPERA, ID2, ID3, C1, C2) \
+ CCALLSFSUB6(HOPERA,hopera,INT,STRING,INT,INT,FLOAT,FLOAT, \
+ ID1, CHOPERA, ID2, ID3, C1, C2)
+
+/* 7.2 Statistical differences between histograms */
+#define HDIFF(ID1,ID2,PROB,CHOPT) \
+ CCALLSFSUB4(HDIFF,hdiff,INT,INT,PFLOAT,STRING, ID1,ID2,PROB,CHOPT)
+
+/* 7.3 Fitting */
+/* 7.3.1 Fitting with HBOOK */
+/* 7.3.1.1 Histograms */
+/* a) Long version */
+#ifndef CRAY
+#define HFITL(ID,FUN,NP,P,CHI2,IC,SIG,COV,ST,PMI,PMA) \
+ CCALLSFSUB11(HFITL,hfitl,INT,PVOID,INT,DOUBLEV,PFLOAT,INT,FLOATV,FLOATV,FLOATV,FLOATV,FLOATV,\
+ ID,FUN,NP,P,CHI2,IC,SIG,COV,ST,PMI,PMA)
+#else
+#define HFITL(ID,FUN,NP,P,CHI2,IC,SIG,COV,ST,PMI,PMA) \
+ CCALLSFSUB11(HFITL,hfitl,INT,PVOID,INT,FLOATV,PFLOAT,INT,FLOATV,FLOATV,FLOATV,FLOATV,FLOATV,\
+ ID,FUN,NP,P,CHI2,IC,SIG,COV,ST,PMI,PMA)
+#endif
+/* b) Short version */
+#ifndef CRAY
+#define HFITS(ID,FUN,NP,P,CHI2,IC,SIG) \
+ CCALLSFSUB7(HFITS,hfits,INT,PVOID,INT,DOUBLEV,PFLOAT,INT,FLOATV,\
+ ID,FUN,NP,P,CHI2,IC,SIG)
+#else
+#define HFITS(ID,FUN,NP,P,CHI2,IC,SIG) \
+ CCALLSFSUB7(HFITS,hfits,INT,PVOID,INT,FLOATV,PFLOAT,INT,FLOATV,\
+ ID,FUN,NP,P,CHI2,IC,SIG)
+#endif
+
+/* 7.3.1.2 Non-equidistant points in a multi-dimensional space */
+#ifndef CRAY
+#define HFITN(X,Y,EY,NPTS,N1,NVAR,FUN,NP,P,CHI2,IC,SIG,COV,ST,PMI,PMA) \
+ CCALLSFSUB16(HFITN,hfitn,FLOATVV,FLOATV,FLOATV,INT,INT,INT,PVOID,INT,DOUBLEV,PFLOAT,INT,FLOATV,FLOATV,FLOATV,FLOATV,FLOATV,\
+ X,Y,EY,NPTS,N1,NVAR,FUN,NP,P,CHI2,IC,SIG,COV,ST,PMI,PMA)
+#define HFIT1(X,Y,EY,N,FUN,NP,P,CHI2,IC,SIG) \
+ CCALLSFSUB10(HFIT1,hfit1,FLOATV,FLOATV,FLOATV,INT,PVOID,INT,DOUBLEV,PFLOAT,INT,FLOATV,\
+ X,Y,EY,N,FUN,NP,P,CHI2,IC,SIG)
+#else
+#include "hfitn_cray.h"
+/* We have to generate this >15 arg. routine elsewhere for the CRAY.
+ Note the change of DOUBLEV to FLOATV.
+#define HFITN(X,Y,EY,NPTS,N1,NVAR,FUN,NP,P,CHI2,IC,SIG,COV,ST,PMI,PMA) \
+ CCALLSFSUB16(HFITN,hfitn,FLOATVV,FLOATV,FLOATV,INT,INT,INT,PVOID,INT,FLOATV,PFLOAT,INT,FLOATV,FLOATV,FLOATV,FLOATV,FLOATV,\
+ X,Y,EY,NPTS,N1,NVAR,FUN,NP,P,CHI2,IC,SIG,COV,ST,PMI,PMA)
+*/
+#define HFIT1(X,Y,EY,N,FUN,NP,P,CHI2,IC,SIG) \
+ CCALLSFSUB10(HFIT1,hfit1,FLOATV,FLOATV,FLOATV,INT,PVOID,INT,FLOATV,PFLOAT,INT,FLOATV,\
+ X,Y,EY,N,FUN,NP,P,CHI2,IC,SIG)
+#endif
+
+/* 7.3.1.3 User Supplied Derivatives */
+#ifndef CRAY
+#define HDERI1(ID,X,PAR,DER) \
+ CCALLSFSUB4(HDERI1,hderi1,INT,FLOATV,DOUBLEV,DOUBLEV, ID,X,PAR,DER)
+#define HDERI2(ID,X,Y,PAR,DER) \
+ CCALLSFSUB5(HDERI2,hderi2,INT,FLOATV,FLOATV,DOUBLEV,DOUBLEV, ID,X,Y,PAR,DER)
+#define HDERIN(X,PAR,DER) CCALLSFSUB3(HDERIN,hderin,FLOATV,DOUBLEV,DOUBLEV, X,PAR,DER)
+#else
+#define HDERI1(ID,X,PAR,DER) \
+ CCALLSFSUB4(HDERI1,hderi1,INT,FLOATV,FLOATV,FLOATV, ID,X,PAR,DER)
+#define HDERI2(ID,X,Y,PAR,DER) \
+ CCALLSFSUB5(HDERI2,hderi2,INT,FLOATV,FLOATV,FLOATV,FLOATV, ID,X,Y,PAR,DER)
+#define HDERIN(X,PAR,DER) CCALLSFSUB3(HDERIN,hderin,FLOATV,FLOATV,FLOATV, X,PAR,DER)
+#endif
+/* 7.3.1.4 Histogram Fitting with Special Functions */
+#define HFITEX(ID,AA,BB,CHI2,IC,SIG) \
+ CCALLSFSUB6(HFITEX,hfitex,INT,PFLOAT,PFLOAT,PFLOAT,INT,FLOATV,\
+ ID,AA,BB,CHI2,IC,SIG)
+#define HFITGA(ID,C,AV,SD,CHI2,IC,SIG) \
+ CCALLSFSUB7(HFITGA,hfitga,INT,PFLOAT,PFLOAT,PFLOAT,PFLOAT,INT,FLOATV,\
+ ID,C,AV,SD,CHI2,IC,SIG)
+#define HFITPO(ID,NP,A,CHI2,IC,SIG) \
+ CCALLSFSUB6(HFITPO,hfitpo,INT,INT,FLOATV,PFLOAT,INT,FLOATV, ID,NP,A,CHI2,IC,SIG)
+
+/* 7.3.2 Equality-constrained fitting with HBOOK */
+#define HLINEQ(ID,A,B,NC) \
+ CCALLSFSUB4(HLINEQ,hlineq,INT,FLOATVV,FLOATV,PFLOAT, ID,A,B,NC)
+
+/* 7.4 Parametrization */
+/* 7.4.1 Histograms and plots */
+#ifndef CRAY
+#define HPARAM(ID,IC,R2MIN,MAXPOW,COEFF,ITERM,NCO) \
+ CCALLSFSUB7(HPARAM,hparam,INT,INT,FLOAT,INT,DOUBLEV,INTV,PINT,\
+ ID,IC,R2MIN,MAXPOW,COEFF,ITERM,NCO)
+#else
+#define HPARAM(ID,IC,R2MIN,MAXPOW,COEFF,ITERM,NCO) \
+ CCALLSFSUB7(HPARAM,hparam,INT,INT,FLOAT,INT,FLOATV,INTV,PINT,\
+ ID,IC,R2MIN,MAXPOW,COEFF,ITERM,NCO)
+#endif
+#define HSETPR(CHNAME,VALUE) CCALLSFSUB2(HSETPR,hsetpr,STRING,FLOAT, CHNAME,VALUE)
+
+/* 7.4.2 Distributions */
+#ifndef CRAY
+#define HPARMN(X,Y,EY,NP,NVAR,IC,R2MIN,MAXPOW,COEFF,ITERM,NCO) \
+ CCALLSFSUB11(HPARMN,hparmn,FLOATVV,FLOATV,FLOATV,INT,INT,INT,FLOAT,INT,DOUBLEV,INTV,PINT,\
+ X,Y,EY,NP,NVAR,IC,R2MIN,MAXPOW,COEFF,ITERM,NCO)
+#else
+#define HPARMN(X,Y,EY,NP,NVAR,IC,R2MIN,MAXPOW,COEFF,ITERM,NCO) \
+ CCALLSFSUB11(HPARMN,hparmn,FLOATVV,FLOATV,FLOATV,INT,INT,INT,FLOAT,INT,FLOATV,INTV,PINT,\
+ X,Y,EY,NP,NVAR,IC,R2MIN,MAXPOW,COEFF,ITERM,NCO)
+#endif
+
+/* 7.5 Smoothing */
+#define HSMOOF(ID,ICASE,CHI2) CCALLSFSUB3(HSMOOF,hsmoof,INT,INT,PFLOAT, ID,ICASE,CHI2)
+#define HSPLI1(ID,IC,N,K,CHI2) \
+ CCALLSFSUB5(HSPLI1,hspli1,INT,INT,INT,INT,PFLOAT, ID,IC,N,K,CHI2)
+#define HSPLI2(ID,NX,NY,KX,KY) \
+ CCALLSFSUB5(HSPLI2,hspli2,INT,INT,INT,INT,INT, ID,NX,NY,KX,KY)
+PROTOCCALLSFFUN4(FLOAT,HSPFUN,hspfun,INT,FLOAT,INT,INT)
+#define HSPFUN(ID,X,N,K) CCALLSFFUN4(HSPFUN,hspfun,INT,FLOAT,INT,INT, ID,X,N,K)
+
+/* 7.6 Random Number Generation */
+PROTOCCALLSFFUN1(FLOAT,HRNDM1,hrndm1,INT)
+#define HRNDM1(ID) CCALLSFFUN1(HRNDM1,hrndm1,INT, ID)
+PROTOCCALLSFFUN3(FLOAT,HRNDM2,hrndm2,INT,PFLOAT,PFLOAT)
+#define HRNDM2(ID,RX,RY) CCALLSFFUN3(HRNDM2,hrndm2,INT,PFLOAT,PFLOAT, ID,RX,RY)
+
+
+/* Chapter 8 MEMORY MANAGEMENT */
+
+/* 8.1 Memory size control */
+#define HLIMIT(NWPAW) CCALLSFSUB1(HLIMIT,hlimit,INT,NWPAW)
+
+/* 8.2 Directories */
+#define HMDIR(CHDIR,CHOPT) CCALLSFSUB2(HMDIR,hmdir,STRING,STRING, CHDIR,CHOPT)
+#define HCDIR(CHDIR,CHOPT) CCALLSFSUB2(HCDIR,hcdir,PSTRING,STRING, CHDIR,CHOPT)
+#define HLDIR(CHDIR,CHOPT) CCALLSFSUB2(HLDIR,hldir,STRING,STRING, CHDIR,CHOPT)
+#define HPDIR(CHDIR,CHOPT) CCALLSFSUB2(HPDIR,hpdir,STRING,STRING, CHDIR,CHOPT)
+
+
+/* Chapter 9 INPUT/OUTPUT */
+
+/* 9.1 Direct Access I/O */
+/* 9.1.1 Open a RZ direct access file or map a Global Section */
+#define HRFILE(LUN,CHDIR,CHOPT) \
+ CCALLSFSUB3(HRFILE,hrfile,INT,STRING,STRING, LUN,CHDIR,CHOPT)
+
+/* 9.1.2 Writing to a file */
+#define HROUT(ID,ICYCLE,CHOPT) \
+ CCALLSFSUB3(HROUT,hrout,INT,PINT,STRING, ID,ICYCLE,CHOPT)
+
+/* 9.1.3 Reading from a direct-access file or Global Section */
+#define HRIN(ID,ICYCLE,IOFSET) CCALLSFSUB3(HRIN,hrin,INT,INT,INT, ID,ICYCLE,IOFSET)
+
+/* 9.1.4 Scratching histogram in a file */
+#define HSCR(ID,ICYCLE,CHOPT) CCALLSFSUB3(HSCR,hscr,INT,INT,STRING, ID,ICYCLE,CHOPT)
+
+/* 9.1.5 Close a file */
+#define HREND(CHTOP) CCALLSFSUB1(HREND,hrend,STRING, CHTOP)
+
+/* 9.2 Reading files generated by HBBOK version 3 */
+#define HFETCH(ID,LUN) CCALLSFSUB2(HFETCH,hfetch,INT,INT, ID,LUN)
+#define HREAD(ID,LUIN,IADDR,NWORDS,IOPT,NOMORE) \
+ CCALLSFSUB6(HREAD,hread,INT,INT,INT,INT,INT,INT, ID,LUIN,IADDR,NWORDS,IOPT,NOMORE)
+
+/* 9.3 Changing Logical unit numbers for output and message files */
+#define HOUTPU(LOUT) CCALLSFSUB1(HOUTPU,houtpu,INT, LOUT)
+#define HERMES(LERR) CCALLSFSUB1(HERMES,hermes,INT, LERR)
+
+/* 9.? Late additions. See cern_root:[000000.doc]hbook.mem for info. */
+#define HRPUT(ID,FILE_NAME,CHOPT) \
+ CCALLSFSUB3(HRPUT,hrput,INT,STRING,STRING, ID,FILE_NAME,CHOPT)
+#define HRGET(ID,FILE_NAME,CHOPT) \
+ CCALLSFSUB3(HRGET,hrget,INT,STRING,STRING, ID,FILE_NAME,CHOPT)
+#define HROPEN(LUN,TOPDIR,FILE_NAME,CHOPT,LREC,ISTAT) \
+ CCALLSFSUB6(HROPEN,hropen,INT,STRING,STRING,STRING,INT,PINT, LUN,TOPDIR,FILE_NAME,CHOPT,LREC,ISTAT)
+
+
+/* Chapter 10 N-TUPLES */
+
+/* 10.3 Making projections */
+#define HPROJ1(ID,IDN,ISEL,FUN,IFROM,ITO,IVARX) \
+ CCALLSFSUB7(HPROJ1,hproj1,INT,INT,INT,PVOID,INT,INT,INT, ID,IDN,ISEL,FUN,IFROM,ITO,IVARX)
+#define HPROJ2(ID,IDN,ISEL,FUN,IFROM,ITO,IVARX,IVARY) \
+ CCALLSFSUB8(HPROJ2,hproj2,INT,INT,INT,PVOID,INT,INT,INT,INT, ID,IDN,ISEL,FUN,IFROM,ITO,IVARX,IVARY)
+
+
+/* Chapter 11 SETTING OPTIONS */
+
+#define HIDOPT(ID,OPTION) CCALLSFSUB2(HIDOPT,hidopt,INT,STRING, ID,OPTION)
+
+
+/* Some internal routines, not in the guide, but in HBOOK4.CAR. */
+
+#define HGNPAR(IDN,CHROUT) CCALLSFSUB2(HGNPAR,hgnpar,INT,STRING, IDN,CHROUT)
+#define HGNF(IDN,IDNEVT,X,IERROR) \
+ CCALLSFSUB4(HGNF,hgnf,INT,INT,FLOATV,PINT, IDN,IDNEVT,X,IERROR)
+
+#endif /* __HBOOK_LOADED */
diff --git a/CTP/makereg.c b/CTP/makereg.c
new file mode 100644
index 0000000..cd9316e
--- /dev/null
+++ b/CTP/makereg.c
@@ -0,0 +1,689 @@
+/* makereg.c version 1.0. August 1994, Allen Boozer
+ Report bugs to adb2y@virginia.edu
+ $Log: makereg.c,v $
+ Revision 1.1.24.1 2007/09/10 21:32:47 pcarter
+ Implemented changes to allow compilation on RHEL 3,4,5 and MacOSX
+
+ Revision 1.1 1998/12/07 22:11:11 saw
+ Initial setup
+
+ Revision 1.2 1995/01/09 15:10:44 saw
+ Put titles in reg calls on a continuation line
+
+ * Revision 1.1 1994/08/26 17:47:07 saw
+ * Initial revision
+ *
+*/
+
+#include <stdio.h>
+#include <string.h>
+#include <ctype.h>
+#include <stdlib.h>
+#include <time.h>
+
+/*
+ c%% - Put the current line in the fortran code
+ c CTPTYPE = test - Use "test" call statements
+ c CTPTYPE = parm - Use "parm" call statements
+ c CTPTYPE = event - Use "event" call statements
+ c CTPTYPE = off - Ignore all lines until CTYPE is set to test, parm, or event
+*/
+
+
+#define VERSION "v1.01"
+#define BUFFER_LEN 256
+#define NUM_TYPES 8
+
+#define CTPTEST 0
+#define CTPPARM 1
+#define CTPEVENT 2
+#define CTPOFF 3
+
+#define COMMON -1
+#define PARAMETER -2
+#define EQUIV -3
+#define NOP -4
+#define COMMON_CONTINUE -5
+#define REGISTER_CONTINUE -6
+#define MARK -7
+#define IGNORE -8
+#define SKIP -9
+
+/*
+ Two linked lists (the register list and the common list) are used to store
+ information about variables that have been declared. The register list
+ stores variables which have been registered, and the common list stores
+ variables which have been defined in common blocks. The elements of the
+ linked lists are of type "node", as defined below:
+*/
+
+struct node {
+ int vartype; /* A number which represents the type of the variable */
+ int action; /* A number which tells what to do with the variable */
+ int calltype; /* Use test, parm, or event calls */
+ int line_number; /* The line number on which the variable occurs */
+ char *name; /* The name of the variable */
+ char *size; /* The size of the array, or NULL if not an array */
+ char *title; /* The title string, or NULL if no title string */
+ struct node *next; /* Ptr to the next node, or NULL if last node */
+};
+
+struct node *register_start; /* Ptr to the first node of the register list */
+struct node *common_start; /* Ptr to the first node of the common list */
+
+/* Variable types (as they appear when variables are declared) */
+char types[NUM_TYPES][20] = {
+ "logical", "logical*4",
+ "integer", "integer*4",
+ "real", "real*4",
+ "double precision", "real*8" };
+
+/* Variable types (as the appear in fortran call statements) */
+char type_names[5][10] = {"int", "int", "real", "double", "string"};
+
+char keywords[3][15] = {"common", "parameter", "equivalence"};
+char call_names[4][10] = {"test", "parm", "event", "off"};
+
+int variable_flags[3][5] = {{0, 0, 0, 0, 0}, {0, 0, 0, 0, 0}, {0, 0, 0, 0, 0}};
+int array_flags[3][5] = {{0, 0, 0, 0, 0}, {0, 0, 0, 0, 0}, {0, 0, 0, 0, 0}};
+
+FILE *input, *output, *error;
+char input_filename[BUFFER_LEN];
+char output_filename[BUFFER_LEN];
+char error_filename[BUFFER_LEN] = {""};
+char subroutine_name[BUFFER_LEN] = {""};
+char command_line[BUFFER_LEN];
+int current_calltype, current_line;
+
+void eprint (char string[]);
+void eprintn (char string[], int length);
+void eprint_newline ();
+void eprint_line (int line_num);
+void memory_error ();
+char *parse_array_size (char string[]);
+void create (struct node *ptr, int vartype, char string[], char title[]);
+int max (int a, int b);
+int min (int a, int b);
+void free_node (struct node *ptr);
+void clear_list (struct node *ptr);
+void copy (char dest[], char source[], int length);
+int strncmp_i (char str1[], char str2[], int length);
+struct node *find_node (struct node *start, char string[]);
+void mark_node (struct node *start, char string[], int new_action);
+int determine_type (char string[]);
+char *skip_blanks (char string[]);
+char *skip_nonblanks (char string[]);
+char *find_char (char string[], char character);
+int extract_text (char string[]);
+void shift_left (char string[]);
+void parse (char string[]);
+void compare_lists ();
+void write_fortran_header ();
+void write_fortran_code ();
+void set_call_type (char string[]);
+
+/***************************************************************************
+* Linked list functions
+***************************************************************************/
+
+/* Print a character string to "error" */
+void eprint (char string[]) {
+ fprintf (error, "%s", string);
+ fprintf (output, "%s", string);
+}
+
+/* Print "length" characters of a character string to "error" */
+void eprintn (char string[], int length) {
+ char output_buffer[BUFFER_LEN];
+
+ copy (output_buffer, string, length);
+ fprintf (error, "%s", output_buffer);
+ fprintf (output, "%s", output_buffer);
+}
+
+/* Print a newline character to "error" */
+void eprint_newline () {
+ fprintf (error, "\n");
+ fprintf (output, "\n* ");
+}
+
+/* Print a line number to "error" */
+void eprint_line (int line_num) {
+ fprintf (error, "Line %d: ", line_num);
+ fprintf (output, "Line %d: ", line_num);
+}
+
+/* memory_error is called if malloc returns a NULL pointer */
+void memory_error () {
+ printf ("Memory allocation error\n");
+ fclose (input);
+ fclose (output);
+ fclose (error);
+ exit (0);
+}
+
+/* Return a pointer to a string containing the array size */
+char *parse_array_size (char string[]) {
+ char output_buffer[BUFFER_LEN];
+ int length;
+ char *size_string, *ptr = string;
+
+ memset (output_buffer, '\0', BUFFER_LEN);
+ ptr = find_char (ptr, '(');
+ while (ptr < find_char(string,')')) {
+ if (strlen(output_buffer) != 0) strcat (output_buffer, "*");
+ length = min (find_char(ptr,',')-ptr, find_char(ptr,')')-ptr) - 1;
+ strcat (output_buffer, "(");
+ if (find_char(ptr,':')-ptr < length) {
+ strcat (output_buffer, "1-");
+ strncat (output_buffer, ptr, find_char(ptr,':')-ptr-1);
+ strcat (output_buffer, "+");
+ ptr = find_char (ptr, ':');
+ length = min (find_char(ptr,',')-ptr, find_char(ptr,')')-ptr) - 1;
+ }
+ strncat (output_buffer, ptr, length);
+ strcat (output_buffer, ")");
+ ptr = skip_blanks (find_char (ptr, ','));
+ }
+ size_string = malloc (strlen(output_buffer)+1);
+ if (size_string == NULL) memory_error ();
+ strcpy (size_string, output_buffer);
+ return (size_string);
+}
+
+/* Add a variable to a linked list */
+void create (struct node *start, int vartype, char string[], char comment[]) {
+ struct node *end = start, *temp;
+
+ if (find_node (start, string) == NULL) {
+ /* Create a new node and add it to the end of the linked list */
+ while (end->next != NULL) end = end->next;
+ end->next = malloc (sizeof(struct node));
+ if (end->next == NULL) memory_error ();
+ end = end->next;
+ end->vartype = vartype;
+ end->action = NOP;
+ end->calltype = current_calltype;
+ end->line_number = current_line;
+ end->name = calloc (extract_text(string)+1, sizeof(char));
+ if (end->name == NULL) memory_error ();
+ copy (end->name, string, extract_text(string));
+ if ((find_char (string, '(') < find_char (string, ',')) &&
+ (find_char (string, '(') < find_char (string, '!'))) {
+ /* Variable is an array */
+ if (start == common_start) {
+ /* Array is defined in a common block, so print a warning */
+ eprint_newline ();
+ eprint ("Warning - Array size defined in common block:");
+ eprint_newline ();
+ eprint_line (current_line);
+ eprintn (string, find_char(string, ')') - string);
+ eprint_newline ();
+ temp = find_node (register_start, string);
+ if (temp != NULL) {
+ if (temp->vartype > 0) array_flags[temp->calltype][temp->vartype]=1;
+ free (temp->size);
+ temp->size = parse_array_size (string);
+ end->size = NULL;
+ }
+ }
+ else end->size = parse_array_size (string);
+ }
+ else (end->size = NULL);
+ if (comment != NULL) {
+ end->title = calloc (strlen(comment), sizeof(char));
+ if (end->title == NULL) memory_error ();
+ copy (end->title, comment, strlen(comment)-1);
+ }
+ else end->title = NULL;
+ end->next = NULL;
+ }
+}
+
+/* Return the maximum of a and b */
+int max (int a, int b) {
+ return ((a < b) ? b : a);
+}
+
+/* Return the minimum of a and b */
+int min (int a, int b) {
+ return ((a < b) ? a : b);
+}
+
+/* Release the memory used by a node */
+void free_node (struct node *ptr) {
+ free (ptr->name);
+ if (ptr->size != NULL) free (ptr->size);
+ if (ptr->title != NULL) free (ptr->title);
+ free (ptr);
+}
+
+/* Release the memory used by each node in a linked list */
+void clear_list (struct node* start) {
+ struct node *ptr = start->next, *old_ptr;
+
+ while (ptr != NULL) {
+ old_ptr = ptr;
+ ptr = ptr->next;
+ free_node (old_ptr);
+ }
+ start->next = NULL;
+}
+
+/* Copy length chars from "dest" to "source", terminate "dest" with a \0 */
+void copy (char dest[], char source[], int length) {
+ memcpy (dest, source, length);
+ dest[length] = '\0';
+}
+
+/* Case insensitive string compare */
+int strncmp_i (char str1[], char str2[], int length) {
+ int i;
+
+ for (i=0; i<length;i++) if (toupper(str1[i]) != toupper(str2[i])) return (1);
+ return (0);
+}
+
+/* Return a pointer to the node which has "string" as it's name field */
+struct node *find_node (struct node *start, char string[]) {
+ int length, flag=1;
+ struct node *ptr = start;
+
+ do {
+ ptr = ptr->next;
+ if (ptr != NULL) {
+ length = max (extract_text(string), strlen(ptr->name));
+ flag = strncmp_i (ptr->name, string, length);
+ }
+ } while ((flag != 0) && (ptr != NULL));
+ return (ptr);
+}
+
+/* Set the action of the node which has "string" as it's name field */
+void mark_node (struct node *start, char string[], int new_action) {
+ struct node *node_ptr;
+
+ node_ptr = find_node (start, string);
+ if (node_ptr != NULL) node_ptr->action = new_action;
+}
+
+/***************************************************************************
+* Parse functions
+***************************************************************************/
+
+int determine_type (char string[]) {
+ int i, length;
+
+ for (i=0; i<NUM_TYPES; i++) {
+ length = max (strlen(types[i]), skip_nonblanks(string)-string);
+ if (strncmp_i(string, types[i], length) == 0) return (i/2);
+ }
+ if (strncmp_i(string, "character", 9) == 0) return (4);
+ if (strncmp_i(string, "integer*2", 9) == 0) {
+ eprint_newline ();
+ eprint ("Warning - Type integer*2:");
+ eprint_newline ();
+ eprint_line (current_line);
+ eprintn (string, strlen(string) - 1);
+ eprint_newline ();
+ return (NOP);
+ }
+ for (i=0; i<3; i++) {
+ length = max (strlen(keywords[i]), extract_text(string));
+ if (strncmp_i(string, keywords[i], length) == 0) return (-i-1);
+ }
+ return (NOP);
+}
+
+/* Return a ptr to the first nonblank character in the string */
+char *skip_blanks (char string[]) {
+ while (isspace (*string)) string++;
+ return (string);
+}
+
+/* Return a ptr to the first blank character in the string */
+char *skip_nonblanks (char string[]) {
+ while ((! isspace (*string)) && (*string != '\0')) string++;
+ return (string);
+}
+
+/* Return a ptr to the character after the first occurrence of "character" */
+char *find_char (char string[], char character) {
+ while ((*string != character) && (*string != '\0')) string++;
+ if (*string == character) string++;
+ return (string);
+}
+
+/* Return the number of contiguous text characters in a string */
+int extract_text (char string[]) {
+ int i=0;
+
+ while ((isalnum (string[i])) || (string[i] == '_')) i++;
+ return (i);
+}
+
+/* Shift a character string one character to the right */
+void shift_left (char string[]) {
+ char *ptr = string;
+
+ while (*ptr != '\0') ptr++;
+ *(ptr+1) = '\0';
+ while (ptr != string) *ptr = *(--ptr);
+}
+
+/* Parse one line of text */
+void parse (char string[]) {
+ struct node *list_ptr /*, *node_ptr */;
+ static int vartype = NOP, state = NOP;
+ char *ptr = string, *title_ptr, *temp;
+
+ if (((string[0] == ' ') && (strlen(string) > 6)) ||
+ ((string[0] == '\t') && (strlen(string) > 2))) {
+ /* The current line is not a comment */
+ if (string[0] == '\t') ptr++;
+ else ptr += 5;
+ if ((isspace (*ptr)) || ((state != COMMON_CONTINUE) && (state != REGISTER_CONTINUE))) {
+ ptr = skip_blanks (ptr);
+ vartype = determine_type (ptr);
+ state = vartype;
+ if (strncmp_i("double precision", ptr, 16) == 0)
+ ptr = skip_blanks (skip_nonblanks (ptr));
+ }
+ if ((vartype != NOP) && (vartype != PARAMETER) && (vartype != EQUIV)) {
+ /* The current line is a list of variables */
+ if (state == COMMON_CONTINUE) {
+ /* The current line is the continuation of a common block */
+ list_ptr = common_start;
+ ptr++;
+ }
+ else if (state == COMMON) {
+ /* The current line is a common block */
+ list_ptr = common_start;
+ ptr = find_char (find_char (ptr, '/'), '/');
+ state = COMMON_CONTINUE;
+ }
+ else if (state == REGISTER_CONTINUE) {
+ /* The current line is the continuation of a register statement */
+ list_ptr = register_start;
+ ptr++;
+ }
+ else {
+ /* The current line contains variables to be registered */
+ list_ptr = register_start;
+ ptr = skip_nonblanks (ptr);
+ state = REGISTER_CONTINUE;
+ }
+ ptr = skip_blanks (ptr);
+
+ /* Obtain the title string */
+ title_ptr = string;
+ if (find_char (ptr, ',') > find_char (ptr, '!')) {
+ while (*title_ptr != '!') title_ptr++;
+ title_ptr = skip_blanks (title_ptr+1);
+ if (*title_ptr == '\0') title_ptr = NULL;
+ }
+ else title_ptr = NULL;
+ /* Convert ' to '' in title string */
+ if (title_ptr != NULL) {
+ temp = title_ptr;
+ while (*temp != '\0') {
+ if (*temp == '\'') shift_left (temp++);
+ temp++;
+ }
+ }
+
+ /* Add each variable to the linked list */
+ while ((ptr < find_char (string, '!')) && (*ptr != '!')) {
+ if ((find_char (ptr, '(') < find_char (ptr, ',')) &&
+ (find_char (ptr, '(') < find_char (ptr, '!'))) {
+ /* The variable is an array */
+ create (list_ptr, vartype, ptr, title_ptr);
+ if (vartype >= 0) array_flags[current_calltype][vartype] = 1;
+ ptr = skip_blanks (find_char (find_char (ptr, ')'), ','));
+ }
+ else {
+ /* The variable is not an array */
+ create (list_ptr, vartype, ptr, title_ptr);
+ if (vartype >=0) variable_flags[current_calltype][vartype] = 1;
+ ptr = skip_blanks (find_char (ptr, ','));
+ }
+ }
+ }
+ if (vartype == PARAMETER)
+ /* If the line is a parameter statement, then ignore the variable */
+ mark_node (register_start, skip_blanks(find_char (ptr, '(')), IGNORE);
+ if (vartype == EQUIV) {
+ /* If the line is an equivalence statement, then skip the variables */
+ ptr = skip_blanks (find_char (ptr, '('));
+ mark_node (register_start, ptr, SKIP);
+ if (find_char(ptr,'(') < find_char(ptr,',')) ptr = find_char(ptr,')');
+ ptr = skip_blanks (find_char (ptr, ','));
+ mark_node (register_start, ptr, SKIP);
+ }
+ }
+}
+
+/* Compare the common list with the register list */
+void compare_lists () {
+ struct node *ptr, *common_node;
+
+ eprint_newline ();
+ eprint ("Registered, but did not occur in a common block:");
+ eprint_newline ();
+ ptr = register_start->next;
+ while (ptr != NULL) {
+ common_node = find_node (common_start, ptr->name);
+ if (common_node != NULL) {
+ common_node->action = MARK;
+ if ((common_node->title != NULL) && (ptr->title == NULL)) {
+ ptr->title = malloc (strlen(common_node->title)+1);
+ if (ptr->title == NULL) memory_error ();
+ strcpy (ptr->title, common_node->title);
+ }
+ }
+ else if ((ptr->action != IGNORE) && (ptr->action != SKIP)) {
+ eprint_line (ptr->line_number);
+ eprint (ptr->name);
+ eprint_newline ();
+ }
+ ptr = ptr->next;
+ }
+
+ eprint_newline ();
+ eprint ("Occurred in a common block, but were not registered:");
+ ptr = common_start->next;
+ while (ptr != NULL) {
+ if (ptr->action != MARK) {
+ eprint_newline ();
+ eprint_line (ptr->line_number);
+ eprint (ptr->name);
+ }
+ ptr = ptr->next;
+ }
+ eprint ("\n\n");
+}
+
+/* Write a header to the output file */
+void write_fortran_header () {
+ time_t current_time = time (NULL);
+
+ fprintf (output, "******************************************************");
+ fprintf (output, "*************************\n");
+ fprintf (output, "* This file (%s) was generated ", output_filename);
+ fprintf (output, "from %s by makereg %s\n", input_filename, VERSION);
+ fprintf (output, "* This file was created on ");
+ fprintf (output, "%s", asctime (localtime (¤t_time)));
+ fprintf (output, "*\n");
+ fprintf (output, "* The command used to create this file was:\n");
+ fprintf (output, "* %s\n", command_line);
+ fprintf (output, "*\n");
+ fprintf (output, "* Do not edit this file.\n");
+ fprintf (output, "******************************************************");
+ fprintf (output, "*************************\n\n");
+ fprintf (output, " subroutine %s\n\n", subroutine_name);
+ fprintf (output, " implicit none\n\n");
+}
+
+/* Write the fortran code to an output file */
+void write_fortran_code () {
+ struct node *ptr = register_start->next;
+ int i, j;
+
+ for (j=0; j<3; j++) {
+ if (variable_flags[j][0] == 1) variable_flags[j][1] = 1;
+ if (array_flags[j][0] == 1) array_flags[j][1] = 1;
+ }
+
+ fprintf (output, " include '%s'\n\n", input_filename);
+ for (j=0; j<3; j++) {
+ for (i=1; i<5; i++) {
+ if (variable_flags[j][i] == 1) {
+ fprintf (output, "c integer ");
+ fprintf (output, "reg%s%s\n", call_names[j], type_names[i]);
+ fprintf (output, "c external ");
+ fprintf (output, "reg%s%s\n", call_names[j], type_names[i]);
+ }
+ if (array_flags[j][i] == 1) {
+ fprintf (output, "c integer ");
+ fprintf (output, "reg%s%sarray\n", call_names[j], type_names[i]);
+ fprintf (output, "c external ");
+ fprintf (output, "reg%s%sarray\n", call_names[j], type_names[i]);
+ }
+ }
+ }
+ fprintf (output, "\n");
+
+ /* Loop to output the reg calls */
+ while (ptr != NULL) {
+ if (ptr->action != IGNORE) {
+ fprintf (output, " call reg%s", call_names[ptr->calltype]);
+ fprintf (output, "%s", type_names[ptr->vartype]);
+ if (ptr->size == NULL)
+ fprintf (output, "('%s',%s,", ptr->name, ptr->name);
+ else
+ fprintf (output, "array('%s',%s,%s,", ptr->name, ptr->name, ptr->size);
+ if (ptr->title == NULL) fprintf (output, "0)\n");
+ else {
+ fprintf (output, "\n & ");
+ fprintf (output, "'%s')\n", ptr->title);
+ }
+ }
+ ptr = ptr->next;
+ }
+
+ fprintf (output, "\n");
+ fprintf (output, " return\n");
+ fprintf (output, " end\n");
+}
+
+/* Set the call type to "test", "parm", or "event" */
+void set_call_type (char string[]) {
+ int i;
+ char *ptr;
+
+ if (strlen (string) != 0) {
+ ptr = skip_blanks (string+1);
+ if (strncmp_i(ptr, "CTPTYPE", 7) == 0) {
+ while (isalpha(*ptr) && (*ptr != '\0')) ptr++;
+ while ((! isalpha(*ptr)) && (*ptr != '\0')) ptr++;
+ if (*ptr != '\0')
+ for (i=0; i<4; i++)
+ if (strncmp_i(ptr, call_names[i], 3) == 0) current_calltype = i;
+ }
+ }
+}
+
+void print_usage () {
+ printf ("Usage: makereg infile [-o outfile] [-e errorfile] ");
+ printf ("[-s subroutine name]\n");
+ printf (" [-c test | parm | event]\n");
+ exit (0);
+}
+
+int main (int argc, char *argv[]) {
+ char buffer[BUFFER_LEN];
+ struct node first_register_node, first_common_node;
+ int i, j;
+
+ first_register_node.next = NULL;
+ first_common_node.next = NULL;
+ register_start = &first_register_node;
+ common_start = &first_common_node;
+
+ for (i=0; i<argc; i++) {
+ strcat (command_line, argv[i]);
+ strcat (command_line, " ");
+ }
+
+ current_calltype = CTPTEST;
+ error = stderr;
+ if (argc < 2) print_usage ();
+ strcpy (input_filename, argv[1]);
+ strcpy (output_filename, input_filename);
+ if ((strcmp (strrchr(output_filename, '.'), ".cmn")) == 0)
+ strcpy (strrchr(output_filename, '.'), ".f");
+ else strcat (output_filename, ".f");
+ i = 2;
+ while (i < argc) {
+ if (strcmp(argv[i], "-o") == 0) {
+ if (argc > i+1) strcpy (output_filename, argv[i+1]);
+ else print_usage ();
+ }
+ else if (strcmp(argv[i], "-e") == 0) {
+ if (argc > i+1) strcpy (error_filename, argv[i+1]);
+ else print_usage ();
+ }
+ else if (strcmp(argv[i], "-c") == 0) {
+ if (argc > i+1) {
+ for (j=0; j<3; j++)
+ if (strcmp(argv[i+1], call_names[j]) == 0) current_calltype = j;
+ }
+ else print_usage ();
+ }
+ else if (strcmp(argv[i], "-s") == 0) {
+ if (argc > i+1) strcpy (subroutine_name, argv[i+1]);
+ else print_usage ();
+ }
+ i += 2;
+ }
+ input = fopen (input_filename, "r");
+ if (input == NULL) {
+ printf ("Invalid filename: %s\n", input_filename);
+ print_usage ();
+ }
+ output = fopen (output_filename, "w");
+ if (output == NULL) {
+ printf ("Invalid filename: %s\n", output_filename);
+ print_usage ();
+ }
+ if (strlen(error_filename) != 0) {
+ error = fopen (error_filename, "w");
+ if (error == NULL) {
+ printf ("Invalid filename: %s\n", error_filename);
+ print_usage ();
+ }
+ }
+ if (strlen(subroutine_name) == 0) {
+ strcpy (subroutine_name, output_filename);
+ if (strrchr(subroutine_name, '.') != NULL)
+ *strrchr(subroutine_name, '.') = '\0';
+ }
+
+ write_fortran_header ();
+ current_line = 1;
+ while (fgets (buffer, BUFFER_LEN, input) != NULL) {
+ set_call_type (buffer);
+ if (strncmp(buffer, "*%%", 3) == 0)
+ fprintf (output, " %s", skip_blanks(skip_nonblanks(buffer)));
+ else if (current_calltype != CTPOFF) parse (buffer);
+ current_line++;
+ }
+ compare_lists ();
+ write_fortran_code ();
+ clear_list (register_start);
+ clear_list (common_start);
+ fclose (input);
+ fclose (output);
+ fclose (error);
+ return 0;
+}
diff --git a/CTP/th.h b/CTP/th.h
new file mode 100644
index 0000000..0d0e68a
--- /dev/null
+++ b/CTP/th.h
@@ -0,0 +1,96 @@
+/*-----------------------------------------------------------------------------
+ * Copyright (c) 1993 Southeastern Universities Research Association,
+ * Continuous Electron Beam Accelerator Facility
+ *
+ * This software was developed under a United States Government license
+ * described in the NOTICE file included as part of this distribution.
+ *
+ * Stephen A. Wood, 12000 Jefferson Ave., Newport News, VA 23606
+ * Email: saw@cebaf.gov Tel: (804) 249-7367 Fax: (804) 249-5800
+ *-----------------------------------------------------------------------------
+ *
+ * Description:
+ * Include file with prototypes for CTP routines.
+ *
+ * Author: Stephen Wood, CEBAF Hall C
+ *
+ * Revision History:
+ * $Log: th.h,v $
+ * Revision 1.2 1999/11/04 20:34:05 saw
+ * Alpha compatibility.
+ * New RPC call needed for root event display.
+ * Start of code to write ROOT trees (ntuples) from new "tree" block
+ *
+ * Revision 1.6 1999/08/25 13:16:05 saw
+ * *** empty log message ***
+ *
+ * Revision 1.5 1996/01/30 15:39:45 saw
+ * Add new prototypes: group calls, class calls used by groups
+ *
+ * Revision 1.4 1995/08/03 13:47:48 saw
+ * Add Error code for integer overflow
+ *
+ * Revision 1.3 1994/11/07 14:40:22 saw
+ * Add error code S_TH_UNREG
+ *
+ * Revision 1.2 1994/09/27 20:34:46 saw
+ * Define STDERR to be stdout
+ *
+ * Revision 1.1 1993/05/11 15:10:08 saw
+ * Initial revision
+ *
+ */
+
+#ifndef _TH_H
+#define _TH_H
+/* Variable registration */
+
+typedef int thStatus; /* Return status type */
+
+/* General booking routines */
+thStatus thLoad(char *fname);
+thStatus thOBook();
+thStatus thBook();
+
+
+/* Test package routines */
+typedef enum {
+ WALK_DISPLAY, WALK_CLEAR_FLAGS, WALK_CLEAR_SCALERS, WALK_EXECUTE,
+ WALK_REMOVE, WALK_INCREMENT_SCALERS} WALKOP;
+
+thStatus thWalkTree(char *block_name, WALKOP walkop);
+thStatus thExecuteTests(char *block_name);
+thStatus thClearTestFlags(char *block_name);
+thStatus thClearTestScalers(char *block_name);
+thStatus thIncTestScalers(char *block_name);
+/*#define thExecuteTests(block_name) thWalkTree(block_name,WALK_EXECUTE)*/
+/*#define thIncTestScalers(block_name) \
+ thWalkTree(block_name,WALK_INCREMENT_SCALERS)*/
+#define thDisplayTests(block_name) thWalkTree(block_name,WALK_DISPLAY)
+#define thRemoveTests(block_name) thWalkTree(block_name,WALK_REMOVE)
+/*#define thClearTestFlags(block_name) \
+ thWalkTree(block_name,WALK_CLEAR_FLAGS)*/
+/*#define thClearTestScalers(block_name) \
+ thWalkTree(block_name,WALK_CLEAR_SCALERS)*/
+thStatus thExecuteGroup(char *group_name);
+thStatus thClearGroup(char *group_name);
+thStatus thClearScalersGroup(char *group_name);
+thStatus thIncrementScalersGroup(char *group_name);
+thStatus thWriteGroup(char *group_name);
+thStatus thCloseGroup(char *group_name);
+
+/* Histogram package routines */
+thStatus thExecuteHists(char *block_name);
+thStatus thClearHists(char *block_name);
+int thGetHistID(char *name);
+thStatus thHistAliasWrite(char *fname);
+
+#ifndef S_SUCCESS
+#define S_SUCCESS 0
+#define S_FAILURE -1
+#endif
+#define S_TH_UNREG 1 /* Unregistered variable in test expression */
+#define S_INTOVF 2
+
+#endif
+#define STDERR stdout
diff --git a/CTP/thClient.c b/CTP/thClient.c
new file mode 100644
index 0000000..9d6d789
--- /dev/null
+++ b/CTP/thClient.c
@@ -0,0 +1,607 @@
+#if defined(__osf__) || defined(__LP64__)
+#define BIT64
+#endif
+/*-----------------------------------------------------------------------------
+ * Copyright (c) 1994 Southeastern Universities Research Association,
+ * Continuous Electron Beam Accelerator Facility
+ *
+ * This software was developed under a United States Government license
+ * described in the NOTICE file included as part of this distribution.
+ *
+ * Stephen A. Wood, 12000 Jefferson Ave., Newport News, VA 23606
+ * Email: saw@cebaf.gov Tel: (804) 249-7367 Fax: (804) 249-5800
+ *-----------------------------------------------------------------------------
+ *
+ * Description:
+ * Routines used by a client to retrieve CTP variables
+ *
+ * Author: Stephen Wood, CEBAF Hall C
+ *
+ * Revision History:
+ * $Log: thClient.c,v $
+ * Revision 1.5.26.1 2011/03/03 20:06:21 jones
+ * Add check for 64bit by looking for LP64
+ *
+ * Revision 1.5 2003/02/21 20:55:24 saw
+ * Clean up some types and casts to reduce compiler warnings.
+ *
+ * Revision 1.4 1999/11/04 20:34:05 saw
+ * Alpha compatibility.
+ * New RPC call needed for root event display.
+ * Start of code to write ROOT trees (ntuples) from new "tree" block
+ *
+ * Revision 1.6 1999/08/25 13:16:06 saw
+ * *** empty log message ***
+ *
+ * Revision 1.5 1999/03/01 19:53:05 saw
+ * Add OSF stuff
+ *
+ * Revision 1.4 1995/08/03 13:50:52 saw
+ * Add SGI compatibility
+ *
+ * Revision 1.3 1994/11/07 14:09:42 saw
+ * Bug fixes in thGetList_test and callback server code.
+ *
+ * Revision 1.2 1994/10/17 17:07:28 saw
+ * Add thGetList_test and the callback service davar_readmultiple_test_cb_1
+ *
+ * Revision 1.1 1994/09/27 19:19:09 saw
+ * Initial revision
+ *
+ */
+#include <stdio.h>
+#include <string.h>
+#include <rpc/rpc.h>
+#include "daVar.h"
+#include "daVarRpc.h"
+#include "cfortran.h"
+
+int thCreateList(); /* Move to some include file */
+int thAddToList(int handle, char *pattern);
+int thRemoveFromList(int handle, char *pattern);
+#ifdef BIT64
+int thGetList(int handle, int client);
+int thGetList_test(int handle, int client, char *test_condition,
+ int max_time_wait, int max_event_wait);
+int thImportVars(char *pattern, int client);
+#else
+int thGetList(int handle, CLIENT *clnt);
+int thGetList_test(int handle, CLIENT *clnt, char *test_condition,
+ int max_time_wait, int max_event_wait);
+int thImportVars(char *pattern, CLIENT *clnt);
+#endif
+int thPrintList(int handle);
+#ifdef BIT64
+int myClntCreate(char *host, int prog, int vers, char *proto);
+#endif
+
+FCALLSCFUN0(INT,thCreateList,THCRLIST,thcrlist);
+FCALLSCFUN2(INT,thAddToList,THADDLIST,thaddlist,INT,STRING);
+FCALLSCFUN2(INT,thRemoveFromList,THREMLIST,thremlist,INT,STRING);
+FCALLSCFUN2(INT,thGetList,THGETLIST,thgetlist,INT,INT);
+FCALLSCFUN5(INT,thGetList_test,THCGETLIST,thcgetlist,INT,INT,STRING,INT,INT);
+FCALLSCFUN1(INT,thPrintList,THPRTLIST,thprtlist,INT);
+/* Don't really understand the following. What about ultrix?
+ This is probably because of the _ in clnt_create */
+#ifndef __osf__
+FCALLSCFUN4(INT,clnt_create,CLNT_CREATE,clnt_create,STRING,INT,INT,STRING);
+#else
+#ifdef BIT64
+FCALLSCFUN4(INT,myClntCreate,CLNT_CREATE,clnt_create,STRING,INT,INT,STRING);
+#else
+FCALLSCFUN4(INT,clnt_create,CLNT_CREATE_,clnt_create_,STRING,INT,INT,STRING);
+#endif
+#endif
+
+struct thNameNode {
+ char *name;
+ struct thNameNode *next;
+};
+typedef struct thNameNode thNameNode;
+
+struct thNameList {
+ thNameNode *namehead;
+ int nnames; /* Number of names in list */
+ int rpc_made;
+ NAMELIST rpc; /* List in form for RPC argument */
+};
+typedef struct thNameList thNameList;
+
+TESTNAMELIST *pending_arg=0;
+int pending_flag=0;
+int callback_result;
+
+#ifdef BIT64
+#define MAXHANDLES 10
+static thNameList *handle_list[MAXHANDLES]={0,0,0,0,0,0,0,0,0,0};
+static CLIENT *clnt_list[MAXHANDLES]={0,0,0,0,0,0,0,0,0,0};
+#endif
+
+#ifdef BIT64
+/* Keep client pointers in an array so that we can return a 32 bit "handle"
+ instead of 64 bit. We probably won't need more than one, but we have an
+ array to hold 10 client pointers just for the heck of it.
+*/
+int myClntCreate(char *host, int prog, int vers, char *proto)
+{
+ CLIENT *clnt;
+ int client;
+
+ clnt = clnt_create(host, prog, vers, proto);
+ for(client=0;client<MAXHANDLES;client++){
+ if(clnt_list[client]==0) {
+ clnt_list[client] = clnt;
+ return(client+1);
+ }
+ }
+ return(0);
+}
+#endif
+int thCreateList(){
+ /* Create a handle for a list of variables */
+ thNameList *list;
+#ifdef BIT64
+ int ihandle;
+#endif
+
+ list = (thNameList *) malloc(sizeof(thNameList));;
+ list->namehead = 0;
+ list->nnames = 0;
+ list->rpc_made = 0;
+ list->rpc.NAMELIST_len = 0;
+ list->rpc.NAMELIST_val = 0;
+#ifdef BIT64
+ for(ihandle=0;ihandle<MAXHANDLES;ihandle++){
+ if(handle_list[ihandle]==0) {
+ handle_list[ihandle] = list;
+ printf("cr: handle_list[%d]=%x\n",ihandle,handle_list[ihandle]);
+ return(ihandle+1);
+ }
+ }
+ free(list);
+ return(0);
+#else
+ return((int) list);
+#endif
+}
+int thAddToList(int handle, char *pattern)
+/* Add registered variables to a list of variables to get from a server
+ Return the number of variables added
+ Should we check for duplicates? Not now. No harm in duplicates.
+ thRemoveFromList will remove all duplicates though. */
+{
+ thNameList *list;
+ thNameNode *next,*this;
+ char **vlist; /* List of characters matching pattern */
+ int count; /* Number of variables being added */
+ int i;
+
+#ifdef BIT64
+ list = (thNameList *) handle_list[handle-1];
+#else
+ list = (thNameList *) handle;
+#endif
+ daVarList(pattern,&vlist,&count);
+ for(i=0;i<count;i++) {
+ next = list->namehead; /* The current list */
+ this = list->namehead = (thNameNode *) malloc(sizeof(thNameNode)); /* New name */
+ this->name = (char *) malloc(strlen(vlist[i])+1);
+ strcpy(this->name,vlist[i]);
+ this->next = next; /* Attach rest of list */
+ }
+ list->nnames += count; /* Perhaps I should just count when needed ? */
+ list->rpc_made = 0; /* RPC format list now out of date. */
+ return(list->nnames);
+}
+int thRemoveFromList(int handle, char *pattern)
+{
+ thNameList *list;
+ thNameNode *this,**thisp;
+ char **vlist; /* List of characters matching pattern */
+ int count; /* Number of variables being removed */
+ int nremove;
+ int i;
+
+#ifdef BIT64
+ list = (thNameList *) handle_list[handle-1];
+#else
+ list = (thNameList *) handle;
+#endif
+ daVarList(pattern,&vlist,&count);
+ nremove = 0;
+ for(i=0;i<count;i++) {
+ this = list->namehead; /* Start of list */
+ thisp = &list->namehead; /* Pointer to next field of previous name */
+ while(this) {
+ if(strcasecmp(this->name,vlist[i])==0) { /* Remove matching string */
+ *thisp = this->next;
+ free(this->name);
+ free(this);
+ this = *thisp;
+ nremove++;
+ } else {
+ thisp = &(this->next);
+ this = this->next;
+ }
+ }
+ }
+ list->nnames -= nremove; /* Perhaps I should just count when needed ? */
+ return(list->nnames);
+}
+int thPrintList(int handle)
+ /* For debugging */
+{
+ thNameList *list;
+ thNameNode *next,*this;
+ int count;
+
+#ifdef BIT64
+ list = (thNameList *) handle_list[handle-1];
+#else
+ list = (thNameList *) handle;
+#endif
+ this = list->namehead;
+ printf("Variables attached to handle %d\n",handle);
+ count++;
+ while(this) {
+ printf("%s\n",this->name);
+ count++;
+ this = this->next;
+ }
+ return(count);
+}
+#ifdef BIT64
+int thGetList(int handle, int client)
+#else
+int thGetList(int handle, CLIENT *clnt)
+#endif
+ /* Returns 0 for total success, -1 for total failure, a positive number
+ for the number of variables that didn't work */
+{
+ thNameList *list;
+ thNameNode *next,*this;
+ int i;
+ RVALLIST *vals;
+ int nerrors;
+#ifdef BIT64
+ CLIENT *clnt;
+
+ clnt = clnt_list[client-1];
+#endif
+
+/*
+ printf("sizeof(handle)=%d\n",sizeof(handle));
+ printf("thGetLIst: handle=%d\n",handle);
+ printf("thGhandle_list[0]=%x\n",handle_list[0]);
+ printf("handle_list[%d-1]=%x\n",handle,handle_list[handle-1]);
+*/
+#ifdef BIT64
+ list = (thNameList *) handle_list[handle-1];
+#else
+ list = (thNameList *) handle;
+#endif
+/* printf("list->nnames=%d\n",list->nnames);*/
+ if(!list->rpc_made) {
+ if(list->rpc.NAMELIST_len == 0) {
+ list->rpc.NAMELIST_len = list->nnames;
+ list->rpc.NAMELIST_val = (char **) malloc(list->rpc.NAMELIST_len
+ *sizeof(char *));
+ } else if (list->rpc.NAMELIST_len != list->nnames) {
+ list->rpc.NAMELIST_len = list->nnames;
+ list->rpc.NAMELIST_val = (char **)
+ realloc(list->rpc.NAMELIST_val,list->rpc.NAMELIST_len*sizeof(char *));
+ }
+ this = list->namehead;
+ for(i=0;(i<list->nnames && this);i++){
+ list->rpc.NAMELIST_val[i] = this->name;
+ this = this->next;
+ }
+ }
+ nerrors = 0;
+ if(vals = davar_readmultiple_1(&(list->rpc),clnt)) {
+ this = list->namehead;
+/* printf("list->rpc.NAMELIST_len=%d\n",list->rpc.NAMELIST_len);*/
+ for(i=0;(i<list->rpc.NAMELIST_len && this);i++){
+/* printf("%s\n",this->name);*/
+ if(vals->RVALLIST_val[i].valtype != DAVARERROR_RPC){
+ if(daVarWriteVar(this->name,&(vals->RVALLIST_val[i])) != S_SUCCESS)
+ nerrors++;
+ } else {
+ nerrors++;
+ }
+ this = this->next;
+ }
+ } else {
+ nerrors = -1;
+ }
+ return(nerrors);
+}
+#if 0
+#ifdef BIT64
+int thPutList(int handle, int client)
+#else
+int thPutList(int handle, CLIENT *clnt)
+#endif
+ /* Returns 0 for total success, -1 for total failure, a positive number
+ for the number of variables that didn't work */
+{
+ thNameList *list;
+ thNameNode *next,*this;
+ int i;
+ WVALLIST vals;
+ int nerrors;
+#ifdef BIT64
+ CLIENT *clnt;
+
+ clnt = clnt_list[client-1];
+#endif
+
+ /* Create the write structure */
+#ifdef BIT64
+ list = (thNameList *) handle_list[handle-1];
+#else
+ list = (thNameList *) handle;
+#endif
+/* printf("list->nnames=%d\n",list->nnames);*/
+ if(!list->rpc_made) {
+ if(list->rpc.NAMELIST_len == 0) {
+ list->rpc.NAMELIST_len = list->nnames;
+ list->rpc.NAMELIST_val = (char **) malloc(list->rpc.NAMELIST_len
+ *sizeof(char *));
+ } else if (list->rpc.NAMELIST_len != list->nnames) {
+ list->rpc.NAMELIST_len = list->nnames;
+ list->rpc.NAMELIST_val = (char **)
+ realloc(list->rpc.NAMELIST_val,list->rpc.NAMELIST_len*sizeof(char *));
+ }
+ this = list->namehead;
+ for(i=0;(i<list->nnames && this);i++){
+ list->rpc.NAMELIST_val[i] = this->name;
+ this = this->next;
+ }
+ }
+ nerrors = 0;
+ if(vals = davar_readmultiple_1(&(list->rpc),clnt)) {
+ this = list->namehead;
+/* printf("list->rpc.NAMELIST_len=%d\n",list->rpc.NAMELIST_len);*/
+ for(i=0;(i<list->rpc.NAMELIST_len && this);i++){
+/* printf("%s\n",this->name);*/
+ if(vals->RVALLIST_val[i].valtype != DAVARERROR_RPC){
+ if(daVarWriteVar(this->name,&(vals->RVALLIST_val[i])) != S_SUCCESS)
+ nerrors++;
+ } else {
+ nerrors++;
+ }
+ this = this->next;
+ }
+ } else {
+ nerrors = -1;
+ }
+ return(nerrors);
+}
+#endif
+#if 0
+int tsize=0;
+struct timeval timeout;
+int servone(int wait)
+/* Need to move something that does this into CTP proper */
+{
+ fd_set readfdset;
+ extern int errno;
+
+ timeout.tv_sec = wait;
+ timeout.tv_usec = 1;
+
+#ifdef hpux
+ if(!tsize) tsize = NFDBITS;
+#else
+ if(!tsize) tsize = getdtablesize(); /* how many descriptors can we have */
+#endif
+
+ readfdset = svc_fdset;
+ switch(select(tsize, &readfdset, (fd_set *) NULL, (fd_set *) NULL,
+ &timeout)) {
+ case -1:
+ if (errno == EBADF) break;
+ perror("select failed");
+ break;
+ case 0:
+ /* perform other functions here if select() timed-out */
+ break;
+ default:
+ svc_getreqset(&readfdset);
+ }
+}
+#endif
+#ifdef BIT64
+int thGetList_test(int handle, int client, char *test_condition,
+ int max_time_wait, int max_event_wait)
+#else
+int thGetList_test(int handle, CLIENT *clnt, char *test_condition,
+ int max_time_wait, int max_event_wait)
+#endif
+ /* Returns 0 for total success, -1 for total failure, a positive number
+ for the number of variables that didn't work */
+{
+ thNameList *list;
+ thNameNode *next,*this;
+ int i;
+ int *status;
+ TESTNAMELIST *arg;
+ int servret;
+#ifdef BIT64
+ CLIENT *clnt;
+
+ clnt = clnt_list[client-1];
+#endif
+
+ /* Can return some kind of error if pending_arg is not zero */
+#ifdef BIT64
+ list = (thNameList *) handle_list[handle-1];
+#else
+ list = (thNameList *) handle;
+#endif
+/* printf("list->nnames=%d\n",list->nnames);*/
+ if(!list->rpc_made) {
+ if(list->rpc.NAMELIST_len == 0) {
+ list->rpc.NAMELIST_len = list->nnames;
+ list->rpc.NAMELIST_val = (char **) malloc(list->rpc.NAMELIST_len
+ *sizeof(char *));
+ } else if (list->rpc.NAMELIST_len != list->nnames) {
+ list->rpc.NAMELIST_len = list->nnames;
+ list->rpc.NAMELIST_val = (char **)
+ realloc(list->rpc.NAMELIST_val,list->rpc.NAMELIST_len*sizeof(char *));
+ }
+ this = list->namehead;
+ for(i=0;(i<list->nnames && this);i++){
+ list->rpc.NAMELIST_val[i] = this->name;
+ this = this->next;
+ }
+ }
+ arg = (TESTNAMELIST *) malloc(sizeof(TESTNAMELIST));
+ arg->test_condition = (char *) malloc(strlen(test_condition)+1);
+ strcpy(arg->test_condition,test_condition);
+ arg->max_time_wait = max_time_wait;
+ arg->max_event_wait = max_event_wait;
+ arg->prog = DAVARSVR;
+ arg->vers = DAVARVERS+1;
+ arg->NAMELISTP = &list->rpc;
+ pending_arg = arg;
+ pending_flag = 1;
+
+ if(!(status = davar_readmultiple_test_1(arg,clnt)))
+ return(-1);
+
+ /* Now wait for the incoming network call */
+
+ servret = 1;
+ while(pending_flag && servret > 0) /* Wait for timeout, completion or failur*/
+ servret = daVarServOnce(arg->max_time_wait+10); /* Will wait double?? */
+ if(servret == 0) callback_result = -2; /* Timeout */
+ else if(servret == -1) callback_result = -3;
+
+ free(arg->test_condition);
+ free(arg);
+ pending_arg = 0;
+
+ return(callback_result);
+}
+#ifdef BIT64
+int thImportVars(char *pattern, int client)
+#else
+int thImportVars(char *pattern, CLIENT *clnt)
+#endif
+ /* Returns 0 for total success, -1 for total failure, a positive number
+ for the number of variables that didn't work */
+{
+ WVALLIST *vals;
+ int count;
+
+ thNameList *list;
+ thNameNode *next,*this;
+ int i;
+ int nerrors;
+#ifdef BIT64
+ CLIENT *clnt;
+
+ clnt = clnt_list[client-1];
+#endif
+
+ /* need to initialize the hash tables */
+
+ if(!(vals = davar_readpatternmatch_1(&pattern,clnt))) {
+ return(-1); /* Failed */
+ }
+
+ count = vals->WVALLIST_len;
+ /*printf("daVarImportVars got %d variables matching %s\n",count,pattern);*/
+ nerrors = 0;
+ for(i=0;i<count;i++) {
+ char *name;
+ int valtype;
+ daVarStruct var;
+
+ name = vals->WVALLIST_val[i].name;
+ /*printf("%d: %s\n",i,name);*/
+ /* Don't do anything if it already exists */
+ if(daVarWriteVar(name,vals->WVALLIST_val[i].val) == S_SUCCESS) continue;
+ var.type = vals->WVALLIST_val[i].val->valtype;
+ if(var.type == DAVARERROR_RPC){
+ printf("Error getting %s\n",name);
+ nerrors++;
+ continue;
+ }
+ var.name = name;
+ /*printf("Vartype = %d\n",var.type);*/
+ switch(var.type)
+ {
+ case DAVARINT_RPC:
+ var.size = vals->WVALLIST_val[i].val->any_u.i.i_len;
+ /*printf("size=%d\n",var.size);*/
+ var.varptr = (void *) malloc(var.size*sizeof(DAINT));
+ break;
+ case DAVARFLOAT_RPC:
+ var.size = vals->WVALLIST_val[i].val->any_u.r.r_len;
+ /*printf("size=%d\n",var.size);*/
+ var.varptr = (void *) malloc(var.size*sizeof(DAFLOAT));
+ break;
+ case DAVARDOUBLE_RPC:
+ var.size = vals->WVALLIST_val[i].val->any_u.d.d_len;
+ /*printf("size=%d\n",var.size);*/
+ var.varptr = (void *) malloc(var.size*sizeof(DADOUBLE));
+ break;
+ case DAVARSTRING_RPC:
+ var.size = strlen(vals->WVALLIST_val[i].val->any_u.s) + 1;
+ /*printf("size=%d\n",var.size);*/
+ var.varptr = malloc(var.size);
+ break;
+ }
+ var.opaque = 0;
+ var.rhook = 0;
+ var.whook = 0;
+ var.flag = DAVAR_REPOINTOK | DAVAR_DYNAMIC_PAR;
+ var.flag = DAVAR_REPOINTOK | DAVAR_DYNAMIC_PAR;
+ var.title = 0;
+ daVarRegister((int) 0, &var);
+ /* free(var.name);*/
+ if(daVarWriteVar(name,vals->WVALLIST_val[i].val) != S_SUCCESS) {
+ printf("daVarWriteVar of %s should have worked\n",name);
+ nerrors++;
+ }
+ }
+ return(nerrors);
+}
+int *davar_readmultiple_test_cb_1(RVALLIST *vals, CLIENT *clnt)
+{
+ static int result;
+
+ TESTNAMELIST *argp;
+ thNameNode *next,*this;
+ int i;
+
+ if(pending_arg) argp = pending_arg;
+ else {
+ pending_flag = 0;
+ return(&result); /* What error code ?? */
+ }
+
+ callback_result = 0;
+ if(argp->NAMELISTP->NAMELIST_len == vals->RVALLIST_len) {
+ for(i=0;(i<argp->NAMELISTP->NAMELIST_len);i++){
+/* printf("%s\n",this->name);*/
+ if(vals->RVALLIST_val[i].valtype != DAVARERROR_RPC){
+ if(daVarWriteVar(argp->NAMELISTP->NAMELIST_val[i]
+ ,&(vals->RVALLIST_val[i])) != S_SUCCESS)
+ callback_result++;
+ } else {
+ callback_result++;
+ }
+ }
+ } else if (vals->RVALLIST_len>0) {
+ printf("Lengths: %d %d",argp->NAMELISTP->NAMELIST_len,vals->RVALLIST_len);
+ callback_result = -1;
+ } else {
+ callback_result = -2; /* Server send timeout signal */
+ }
+ pending_flag = 0;
+ return(&result);
+}
diff --git a/CTP/thGethit.c b/CTP/thGethit.c
new file mode 100644
index 0000000..0f626d0
--- /dev/null
+++ b/CTP/thGethit.c
@@ -0,0 +1,517 @@
+/*-----------------------------------------------------------------------------
+ * Copyright (c) 1993 Southeastern Universities Research Association,
+ * Continuous Electron Beam Accelerator Facility
+ *
+ * This software was developed under a United States Government license
+ * described in the NOTICE file included as part of this distribution.
+ *
+ * Stephen A. Wood, 12000 Jefferson Ave., Newport News, VA 23606
+ * Email: saw@cebaf.gov Tel: (804) 249-7367 Fax: (804) 249-5800
+ *-----------------------------------------------------------------------------
+ *
+ * Description:
+ * Retrieve data from Hall C Engine hit lists (gen_datastructures.cmn).
+ *
+ * Author: Stephen A. Wood, CEBAF, Hall C
+ *
+ * Revision History:
+ * $Log: thGethit.c,v $
+ * Revision 1.2 1999/11/04 20:34:05 saw
+ * Alpha compatibility.
+ * New RPC call needed for root event display.
+ * Start of code to write ROOT trees (ntuples) from new "tree" block
+ *
+ * Revision 1.6 1996/08/01 01:31:14 saw
+ * Change argument of thExecuteaGethitBlock from block pointer to a var
+ *
+ * Revision 1.5 1995/04/10 15:52:52 saw
+ * No defined gethit blocks is not an error in thExecuteGethits
+ *
+ * Revision 1.4 1995/01/13 16:26:01 saw
+ * Add missing return(S_SUCCESS) calls to various routines
+ *
+ * Revision 1.3 1994/09/27 19:26:21 saw
+ * Remove linux dependencies
+ *
+ * Revision 1.2 1994/08/26 12:30:23 saw
+ * Register result and test variables as needed
+ *
+ * Revision 1.1 1994/07/21 18:48:12 saw
+ * Initial revision
+ *
+ */
+/*
+Any gethit block can only operate on one "data structure".
+
+begin gethit wc
+missing_value=-1 ! Value to give when hit not found
+hitcount=numhits ! Pointer to word holding hit count
+matchlist=plane ! First array to match with
+matchlist=counter! Second array to match with
+valuelist=data ! Default list containing data values
+
+xsin1,txsin1:,1,4 ! Use default array !Makes hit.xscin1, and test.txsin1
+xsin2,txsin2:data2,1,5
+end gethist wc
+*/
+#include <stdio.h>
+#include <string.h>
+#include "daVar.h"
+#include "th.h"
+#include "thInternal.h"
+#include "thUtils.h"
+#include "cfortran.h"
+
+struct thGethitList {
+ struct thGethitList *next;
+ daVarStruct *src; /* Array to get data from when hit is found */
+ DAINT *coord; /* Coordinate values to match*/
+ daVarStruct *dest,*test; /* Variable to put value of hit detector
+ and a flag for hit found/not found */
+ int destindex, testindex;
+};
+typedef struct thGethitList thGethitList;
+
+struct thGethitOpaque {
+ DAINT *vnhits; /* CTP variable with number of hits */
+ int ncoord; /* Number of coordinates that must match */
+ DAINT **coord_array; /* Point to list of arrays containing hit
+ coordinates */
+ thGethitList *hlisthead; /* List of gethit definitions */
+ daVarStruct *srcdefault; /* Default data array */
+ DADOUBLE default_real; /* Default value to give when hit not found */
+ DAINT default_int; /* Int of default_real */
+};
+
+typedef struct thGethitOpaque thGethitOpaque;
+
+struct thGBlockList {
+ struct thGBlockList *next;
+ char *blockname; /* Block name without the block.gethit */
+ daVarStruct *var; /* Pointer to variable that describes block */
+};
+typedef struct thGBlockList thGBlockList;
+
+thGBlockList *thGBlockListP = NULL;
+char *hitsourceclasslist[]={EVENTSTR,0};
+
+/* Function prototypes */
+thStatus thGethitPreamble(char *line, thGethitOpaque *opqptr,int *icoord);
+char *thGetline(char *lines,char **lcopy);
+thStatus thBookaGethit(char *line, thGethitOpaque *opqptr
+ ,thGethitList **thGethitNext);
+thStatus thExecuteaGethitBlock(daVarStruct *var);
+thStatus thExecuteaGethit(thGBlockList *block);
+
+thStatus thBookGethits(daVarStruct *var)
+{
+ char *lines,*eol,*lcopy;
+ thGethitOpaque *opqptr;
+ thGethitList **thGethitNext;
+ int ncoord,icoord;
+ int line_count,mode;
+ char *blockname;
+
+ blockname = var->name; /* If name doesn't fit pattern, use whole */
+/* printf("Booking gethit block %s\n",blockname);*/
+ if(strcasestr(var->name,BLOCKSTR)==var->name){
+ int i;
+ i = strlen(BLOCKSTR) + 1;
+ if(strcasestr((var->name + i),GETHITSTR)==(var->name + i)){
+ i += strlen(GETHITSTR);
+ if(*(var->name + i) == '.'){
+ blockname += i + 1;
+ }
+ }
+ }
+
+ if(var->opaque == 0) {
+ opqptr = (thGethitOpaque *) malloc(sizeof(thGethitOpaque));
+ var->opaque = (void *) opqptr;
+ } else {
+ daVarStructList *next,*this;
+
+ opqptr = (thGethitOpaque *) var->opaque;
+ free(opqptr->coord_array);
+ /* Walk down optptr->hlisthead freeing the individual gethit structures */
+ }
+ /* Initialize/Clear the Gethit structure */
+ opqptr->vnhits = (DAINT *) 0;
+ opqptr->ncoord = 0;
+ opqptr->coord_array = (DAINT **) 0;
+ opqptr->srcdefault = (daVarStruct *) 0;
+ opqptr->hlisthead = (thGethitList *) 0;
+ opqptr->default_real = opqptr->default_int = 0;
+
+ lines = var->title;
+ line_count = 0;
+ ncoord=0;
+
+ while(*lines) { /* First Pass */
+ /* Count the number of arrays to match */
+
+ line_count++;
+ lines = thGetline(lines,&lcopy);
+ if(!thCleanLine(lcopy)){
+ if(strcasestr(lcopy,"matchlist") && strchr(lcopy,'=')) {
+ ncoord++;
+ }
+ if(strchr(lcopy,':')) { /* First gethit definition */
+ break;
+ }
+ }
+ }
+ opqptr->ncoord = ncoord;
+ opqptr->coord_array = (DAINT **) malloc(ncoord*sizeof(DAINT *));
+
+ mode = 0; /* setup mode */
+ thGethitNext = (thGethitList **) &opqptr->hlisthead;
+ line_count = 0;
+ icoord = 0;
+
+ lines = var->title;
+ while(*lines) { /* Second Pass */
+ line_count++;
+ lines = thGetline(lines,&lcopy);
+ if(!thCleanLine(lcopy)){
+ if(strchr(lcopy,':'))
+ mode = 1;
+ if(mode) { /* Defining the individual gethits */
+ if(thBookaGethit(lcopy,opqptr,thGethitNext)==S_SUCCESS){
+ thGethitNext = &((*thGethitNext)->next);
+ } else {
+ fprintf(STDERR,"Gethit booking error in line %d\n",line_count);
+ }
+ } else { /* Preamble */
+ if(thGethitPreamble(lcopy,opqptr,&icoord)!=S_SUCCESS){
+ fprintf(STDERR,"Gethit booking error in line %d\n",line_count);
+ }
+ }
+ }
+ }
+ /* Update internal table of gethit blocks */
+ {
+ thGBlockList *thisblock,*nextblock,**lastblockp;
+ nextblock = thGBlockListP;
+ lastblockp = &thGBlockListP;
+ thisblock = thGBlockListP;
+ while(thisblock){
+ if((strcasecmp(thisblock->var->name,var->name)) == 0){
+ /* Replacing a block with a new definition */
+ fprintf(stderr,"Replacing %s with new definition\n",var->name);
+ if(thisblock->var != var){
+ fprintf(stderr,"ERR: Same name, different var pointer\n");
+ }
+ break;
+ }
+ lastblockp = &thisblock->next;
+ thisblock = thisblock->next;
+ }
+ if(!thisblock){ /* Create entry for New block */
+ *lastblockp = thisblock = (thGBlockList *) malloc(sizeof(thGBlockList));
+ thisblock->var = var;
+ thisblock->next = (thGBlockList *) NULL;
+ thisblock->blockname = (char *) malloc(strlen(blockname) + 1);
+ strcpy(thisblock->blockname,blockname);
+ }
+ }
+/* printf("Returning from booking Gethit's\n");*/
+ return(S_SUCCESS);
+}
+char *thGetline(char *lines,char **lcopy)
+/* Pull out the characters from lines up to a newline and copy them into
+ a new array. Return the pointer to that array. If a line is missing
+ a newline, return an error. */
+{
+ static char *line_copy=0;
+ static line_copy_size=0;
+ char *next;
+ int len;
+ char *eol;
+
+ eol = strchr(lines,'\n');
+ if(!eol) {
+ len = strlen(lines);
+ next = lines + len;
+ } else {
+ len = (eol-lines);
+ next = eol+1;
+ }
+ if(!line_copy) {
+ line_copy = (char *) malloc(len+1);
+ line_copy_size = len+1;
+ } else {
+ if(len >= line_copy_size) {
+ line_copy = (char *) realloc(line_copy,len+1);
+ line_copy_size = len+1;
+ }
+ }
+ strncpy(line_copy,lines,len);
+ line_copy[len] = '\0';
+ *lcopy = line_copy;
+ return(next);
+}
+thStatus thGethitPreamble(char *line, thGethitOpaque *opqptr,int *icoord){
+ char *equal;
+ char *arg;
+
+/* printf("Processing preamble line %x %s\n",line,line);*/
+ if(!(equal=strchr(line,'=')))
+ return(S_SUCCESS);
+ arg = equal + 1;
+ *equal = 0;
+ arg = thSpaceStrip(arg);
+/* printf("line=%s,arg=%s\n",line,arg); */
+ if(strcasestr(line,"missing_value")) {
+ opqptr->default_real = atof(arg);
+ opqptr->default_int = floatToLong(opqptr->default_real);
+ } else {
+ daVarStruct *varp;
+/* printf("line=%s,arg=%x %s\n",line,arg,arg);*/
+ if(daVarLookupPWithClass(arg,hitsourceclasslist,&varp)!=S_SUCCESS){
+ fprintf(STDERR,"(thGethitPreamble )Variable %s not found\n",arg);
+ return(S_FAILURE); /* Variable not found */
+ }
+/* printf("line=%s,arg=%x %s\n",line,arg,arg);*/
+/* printf("Searching for keyword in %s\n",line);*/
+ if(strcasestr(line,"valuelist")) {
+ opqptr->srcdefault = varp;
+ } else {
+ if(varp->type != DAVARINT) {
+ return(S_FAILURE); /* Not an integer array */
+ }
+ if(strcasestr(line,"hitcount")) {
+ opqptr->vnhits = (DAINT *) varp->varptr;
+/* printf("Setting vnhits to %s\n",varp->name);*/
+ } else if(strcasestr(line,"matchlist")) {
+/* printf("Coordinate %d=%s\n",*icoord,varp->name);*/
+ opqptr->coord_array[(*icoord)++] = (DAINT *) varp->varptr;
+ } else {
+ return(S_FAILURE);
+ }
+ }
+ }
+ return(S_SUCCESS);
+}
+thStatus thBookaGethit(char *line, thGethitOpaque *opqptr, thGethitList **thGethitNext)
+{
+ char *colon;
+ int ndestarg; /* Number of destination args */
+ char *destargs[20];
+ int nsrcarg; /* Number of destination args */
+ char *srcargs[20];
+ daVarStruct *destp, *testp;
+ int destind,testind; /* Indexes into destination and test arrays */
+ daVarStruct *source;
+ DAINT *coord;
+ int icoord;
+ thGethitList *Gethit;
+ thStatus status;
+
+ if(!(colon=strchr(line,':'))) {
+ return(S_SUCCESS);
+ }
+
+ *colon = '\0';
+ colon++;
+
+ ndestarg = thCommas(line,destargs);
+ nsrcarg = thCommas(colon,srcargs);
+
+ /* Parse the source side first so that we know the data type of the
+ source in case we need to register the destination */
+
+ /* printf("%s found as %s at %x\n",destargs[0],destp->name,destp->varptr);*/
+ if(nsrcarg < opqptr->ncoord+1) {
+ fprintf(STDERR,"Insufficient arguments after :\n");
+ return(S_FAILURE);
+ }
+ srcargs[0] = thSpaceStrip(srcargs[0]);
+ if(strlen(srcargs[0]) == 0) {
+ source = opqptr->srcdefault;
+ } else {
+ if(daVarLookupPWithClass(srcargs[0],hitsourceclasslist,*source)
+ != S_SUCCESS) {
+ fprintf(STDERR,"%s not registered\n",srcargs[0]);
+ return(S_FAILURE); /* Destination not registered */
+ }
+ }
+
+ destargs[0] = thSpaceStrip(destargs[0]);
+ if((status=thVarResolve(destargs[0],&destp,&destind,2,source->type)) != S_SUCCESS){
+ return(S_FAILURE);
+ /* ASAP we must change this to register variables as they are needed */
+ /* If the variable exists, then we also must check to make sure that
+ the requested index does not exceed the size of the array.
+ a new thVarResolve should also increase the size of the array if
+ it was created by CTP */
+ }
+ if(ndestarg > 1){
+ destargs[1] = thSpaceStrip(destargs[1]);
+ if(thVarResolve(destargs[1],&testp,&testind,3,DAVARINT) != S_SUCCESS){
+ return(S_FAILURE); /* Test flag not registered */
+ /* ASAP we must change this to register variables as they are needed */
+ /* If the variable exists, then we also must check to make sure that
+ the requested index does not exceed the size of the array.
+ a new thVarResolve should also increase the size of the array if
+ it was created by CTP */
+
+ }
+ } else {
+ testp = 0;
+ testind = 0;
+ }
+
+ coord = (DAINT *) malloc(opqptr->ncoord*sizeof(DAINT));
+ for(icoord=0;icoord<opqptr->ncoord;icoord++) {
+ srcargs[icoord+1] = thSpaceStrip(srcargs[icoord+1]);
+ if(thEvalImed(srcargs[icoord+1],0,&coord[icoord]) != S_SUCCESS) {
+ fprintf(STDERR,"Error evaluating %s\n",srcargs[icoord+1]);
+ free(coord);
+ return(S_FAILURE);
+ }
+ }
+/* Everything obtained from line now */
+ Gethit = *thGethitNext = (thGethitList *) malloc(sizeof(thGethitList));
+ Gethit->next = (thGethitList *) NULL;
+ Gethit->src = source;
+ Gethit->coord = coord;
+ Gethit->dest = destp;
+ Gethit->destindex = destind;
+ Gethit->test = testp;
+ Gethit->testindex = testind;
+
+ return(S_SUCCESS);
+}
+thStatus thExecuteGethits(char *block_name){
+ thGBlockList *thisblock;
+
+
+ if(block_name) if(*block_name=='\0') block_name = 0;
+
+ if(thGBlockListP == 0){
+ return(S_SUCCESS); /* No gethits defined */
+ } else {
+ thisblock = thGBlockListP;
+ while(thisblock){
+ if(block_name)
+ if(strcasecmp(block_name,thisblock->blockname)!=0){
+ thisblock = thisblock->next;
+ continue;
+ }
+ thExecuteaGethitBlock(thisblock->var);
+ (*((DAINT *)thisblock->var->varptr))++; /* Increment block counter */
+ if(block_name)
+ if(strcasecmp(block_name,thisblock->blockname)==0) return(S_SUCCESS);
+ thisblock = thisblock->next;
+ }
+ }
+ return(S_SUCCESS);
+}
+
+thStatus thExecuteaGethitBlock(daVarStruct *var)
+ /* Execute a gethit block */
+{
+ thGethitOpaque *opqptr;
+ thGethitList *thisgethit;
+ int nhits;
+ int ihit;
+ int icoord,ncoord;
+ DAINT **coord_array;
+ double dval;
+ int ival;
+
+/* opqptr = block->var->opaque;*/ /* Structure that describes the gethits */
+ opqptr = var->opaque;
+/* printf("opqptr=%x\n",opqptr);*/
+ nhits = *(opqptr->vnhits);
+ ncoord = opqptr->ncoord;
+ coord_array = opqptr->coord_array;
+
+ thisgethit = opqptr->hlisthead;
+/* printf("%d hits this event\n",nhits);*/
+ while(thisgethit){ /* Inefficient algorithm */
+/* printf("Getting %s\n",thisgethit->dest->name);*/
+ if(thisgethit->test) {
+ /* Assume that test is integer */
+ *((DAINT *) thisgethit->test->varptr + thisgethit->testindex) = FALSE;
+ }
+ for(ihit=0;ihit<nhits;ihit++){
+ for(icoord=0;icoord<ncoord;icoord++){
+/* printf("Hit=%d, Coord=%d %d %d\n",ihit,icoord
+ ,coord_array[icoord][ihit],thisgethit->coord[icoord]);*/
+ if((coord_array[icoord])[ihit] != thisgethit->coord[icoord]) break;
+ }
+ if(icoord >= ncoord){ /* All coordinates matched */
+ int srctype;
+/* printf("Matched at hit %d, %d %d\n",ihit,icoord,ncoord);*/
+ if(thisgethit->test)
+ *((DAINT *) thisgethit->test->varptr + thisgethit->testindex) = TRUE;
+ /* Need to grab the data value, stuff it into variable */
+ srctype = thisgethit->src->type;
+ switch(srctype)
+ {
+ case DAVARINT:
+ ival = ((DAINT *)thisgethit->src->varptr)[ihit];
+ switch(thisgethit->dest->type)
+ {
+ case DAVARINT:
+ ((DAINT *)thisgethit->dest->varptr)[thisgethit->destindex] =
+ ival;
+ break;
+ case DAVARFLOAT:
+ ((DAFLOAT *)thisgethit->dest->varptr)[thisgethit->destindex] =
+ ival;
+ break;
+ case DAVARDOUBLE:
+ ((DADOUBLE *)thisgethit->dest->varptr)[thisgethit->destindex]
+ = ival;
+ break;
+ }
+ break;
+ case DAVARFLOAT:
+ case DAVARDOUBLE:
+ if(srctype == DAVARFLOAT)
+ dval = ((DAFLOAT *)thisgethit->src->varptr)[ihit];
+ else
+ dval = ((DADOUBLE *)thisgethit->src->varptr)[ihit];
+ switch(thisgethit->dest->type)
+ {
+ case DAVARINT:
+ ((DAINT *)thisgethit->dest->varptr)[thisgethit->destindex] =
+ floatToLong(dval);
+ break;
+ case DAVARFLOAT:
+ ((DAFLOAT *)thisgethit->dest->varptr)[thisgethit->destindex] =
+ dval;
+ break;
+ case DAVARDOUBLE:
+ ((DADOUBLE *)thisgethit->dest->varptr)[thisgethit->destindex]
+ = dval;
+ break;
+ }
+ break;
+ }
+ break; /* Only match one hit for now */
+ }
+ }
+ thisgethit = thisgethit->next;
+ }
+ return(S_SUCCESS);
+}
+int thgethit_()
+{
+ int A0;
+ A0 = thExecuteGethits(0);
+ return A0;
+}
+int thgethitb_(char *A1,unsigned C1)
+{
+ int A0;
+ char *B1;
+ A0 = thExecuteGethits((!*(int *)A1)?0:memchr(A1,'\0',C1)?A1:
+ (memcpy(B1=malloc(C1+1),A1,C1),B1[C1]='\0'
+ ,kill_trailing(B1,' ')));
+ if(B1) free(B1);
+ return A0;
+}
diff --git a/CTP/thGroup.c b/CTP/thGroup.c
new file mode 100644
index 0000000..4fabf59
--- /dev/null
+++ b/CTP/thGroup.c
@@ -0,0 +1,336 @@
+/*-----------------------------------------------------------------------------
+ * Copyright (c) 1995,1996 Southeastern Universities Research Association,
+ * Continuous Electron Beam Accelerator Facility
+ *
+ * This software was developed under a United States Government license
+ * described in the NOTICE file included as part of this distribution.
+ *
+ * Stephen A. Wood, 12000 Jefferson Ave., Newport News, VA 23606
+ * Email: saw@cebaf.gov Tel: (804) 249-7367 Fax: (804) 249-5800
+ *-----------------------------------------------------------------------------
+ *
+ * Description:
+ * Code for dealing with blocks in groups.
+ *
+ * Author: Stephen Wood, CEBAF Hall C
+ *
+ * Revision History:
+ * $Log: thGroup.c,v $
+ * Revision 1.5.8.1 2007/09/10 21:32:47 pcarter
+ * Implemented changes to allow compilation on RHEL 3,4,5 and MacOSX
+ *
+ * Revision 1.5 2004/07/08 20:05:37 saw
+ * Use dummy fortran ctp tree routines when ROOTSYS not defined.
+ *
+ * Revision 1.4 2004/07/07 18:15:27 saw
+ * Consistenly use thtreeexeg
+ *
+ * Revision 1.3 2004/07/02 20:11:07 saw
+ * Make fortran tree group function names sane
+ *
+ * Revision 1.2 1999/11/04 20:34:05 saw
+ * Alpha compatibility.
+ * New RPC call needed for root event display.
+ * Start of code to write ROOT trees (ntuples) from new "tree" block
+ *
+ * Revision 1.1 1998/12/07 22:11:12 saw
+ * Initial setup
+ *
+ * Revision 1.2 1996/07/31 20:31:52 saw
+ * Book blocks in the order they appear in the input files.
+ *
+ * Revision 1.1 1996/01/30 15:35:16 saw
+ * Initial revision
+ *
+ */
+#include <stdio.h>
+#include "daVar.h"
+#include "th.h"
+#include "thInternal.h"
+#include "thUtils.h"
+#include "cfortran.h"
+#include "thGroup.h"
+
+thStatus thBookGroup(char *name);
+/* Fortran Interface */
+FCALLSCFUN0(INT,thBook,THBOOK,thbook)
+FCALLSCFUN1(INT,thBookGroup,THGBOOK,thgbook,STRING)
+FCALLSCFUN1(INT,thExecuteGroup,THGEXE,thgexe,STRING)
+FCALLSCFUN1(INT,thClearGroup,THGCLR,thgclr,STRING)
+FCALLSCFUN1(INT,thClearScalersGroup,THGCLS,thgcls,STRING)
+FCALLSCFUN1(INT,thIncrementScalersGroup,THGINS,thgins,STRING)
+
+struct thHook {
+ char *type;
+ thStatus (*book)(); /* Hooks to the appropriate routines */
+ thStatus (*execute)();
+ thStatus (*clear)();
+ thStatus (*clearScalers)();
+ thStatus (*incrementScalers)();
+ thStatus (*ctpwrite)();
+ thStatus (*ctpclose)();
+};
+typedef struct thHook thHook;
+/* V indicates these calls take a variable pointer, not a name */
+/* Eventually calls without V may go away, and these will all be renamed */
+/* How many of these c routines are "advertised */
+thHook thHooks[] = {
+ {PARMSTR ,thLoadParameters,0,0,0,0,0,0},
+ {GETHITSTR ,thBookGethits,thExecuteaGethitBlock,0,0,0,0,0},
+ {TESTSTR ,thBookTests,thExecuteTestsV,thClearTestFlagsV,thClearTestScalersV
+ ,thIncTestScalersV,0,0},
+ {HISTSTR,thBookHists,thExecuteHistsV,thClearHistsV,0,0,0,0},
+ {UHISTSTR,thBookHists,0,0,0,0,0,0},
+ {TREESTR,thBookTree,thFillTreeV,thClearTreeV,0,0,thWriteTreeV,thCloseTreeV},
+ {REPORTSTR,thBookReports,0,0,0,0,0,0},
+ {0,0,0,0,0,0,0,0}};
+
+int thGroupClassesSet=0;
+
+thStatus thSetGroupClasses();
+
+void thInitGroupOpaque(char *name, thGroupOpaque *opqptr)
+{
+ daVarStatus status;
+ daVarStruct *varclass;
+ thGroupOpaque *classopqptr;
+
+ if(!thGroupClassesSet) {
+ status = thSetGroupClasses();
+ thGroupClassesSet = 1;
+ }
+ status = daVarClassFind(name,&varclass);
+ classopqptr = varclass->opaque;
+ opqptr->blocklist = 0;
+ opqptr->type = classopqptr->type;
+ opqptr->book = classopqptr->book;
+ opqptr->execute = classopqptr->execute;
+ opqptr->clear = classopqptr->clear;
+ opqptr->clearScalers = classopqptr->clearScalers;
+ opqptr->incrementScalers = classopqptr->incrementScalers;
+ opqptr->ctpwrite = classopqptr->ctpwrite;
+ opqptr->ctpclose = classopqptr->ctpclose;
+ /* Find out what group type we are copy the information out of it's
+ opaque block */
+}
+thStatus thSetGroupClasses()
+{
+/* thBookList *booklist;
+ thBookList **booknext;*/
+ thGroupOpaque *opqptr;
+ char *classname;
+ daVarStruct var;
+ int i;
+
+ for(i=0;thHooks[i].type;i++){
+ /* Need to decide later to do automatic booking by groups
+ What do I mean by that ^^^ ?*/
+ classname = (char *) malloc(strlen(GROUPSTR)+strlen(thHooks[i].type)+2);
+ strcpy(classname,GROUPSTR);
+ strcat(classname,".");
+ strcat(classname,thHooks[i].type);
+
+ var.name = classname;
+ var.title = 0;/*""*/
+ var.type = DAVARINT;
+ var.varptr = (DAINT *) malloc(sizeof(DAINT));
+ *((DAINT *) var.varptr) = i; /* Booking order */
+ var.size = 1;
+ var.whook = 0; /* Need handlers? */
+ var.rhook = 0;
+ var.flag = DAVAR_READWRITE | DAVAR_REPOINTOK;
+// var.opaque = (void *)opqptr = (thGroupOpaque *) malloc(sizeof(thGroupOpaque));/*phil*/
+ var.opaque = (void *) (opqptr = (thGroupOpaque *) (void *)
+ ((thGroupOpaque *) malloc(sizeof(thGroupOpaque))));
+ opqptr->blocklist = 0;
+ opqptr->type = (char *) malloc(strlen(thHooks[i].type) + 1);
+ strcpy(opqptr->type,thHooks[i].type);
+ opqptr->book = thHooks[i].book;
+ opqptr->execute = thHooks[i].execute;
+ opqptr->clear = thHooks[i].clear;
+ opqptr->clearScalers = thHooks[i].clearScalers;
+ opqptr->incrementScalers = thHooks[i].incrementScalers;
+ opqptr->ctpwrite = thHooks[i].ctpwrite;
+ opqptr->ctpclose = thHooks[i].ctpclose;
+ if(daVarRegister((int) 0, &var) == S_FAILURE){
+ fprintf(STDERR,"Failed to register %s\n",var.name);
+ return(S_FAILURE);
+ }
+/* printf("Registered %s\n",var.name);*/
+ }
+ return(S_SUCCESS);
+}
+thStatus thBookGroup(char *group)
+{
+ daVarStruct *varp, *bvar;
+ daVarStructList *blocklist;
+ thStatus stat;
+ thStatus (*hook)();
+
+ if(daVarLookupP(group, &varp) != S_SUCCESS){
+/* fprintf(STDERR,"Failed to find %s\n",group);*/
+ return(S_FAILURE);
+ }
+ hook = ((thGroupOpaque *)varp->opaque)->book;
+ blocklist = ((thGroupOpaque *)varp->opaque)->blocklist;
+ while(blocklist) {
+ bvar = blocklist->varp;
+ if(!bvar->varptr) { /* Only book those not already booked */
+ bvar->varptr = (DAINT *) malloc(sizeof(DAINT));
+ *((DAINT *) bvar->varptr) = 0; /* Initializec execution counter */
+ if(hook) {
+/* printf("Booking %s\n",bvar->name);*/
+ stat = (hook)(bvar);
+ } else {
+/* printf("No booking required for %s\n",bvar->name);*/
+ }
+ }
+ blocklist = blocklist->next;
+ }
+ return(S_SUCCESS);
+}
+
+#define MAKEGSUB(SUBNAME,QSUBNAME,ELEMENT) \
+thStatus SUBNAME(char *group)\
+{\
+ daVarStruct *varp, *bvar;\
+ daVarStructList *blocklist;\
+ thStatus stat;\
+ thStatus (*hook)();\
+\
+ if(daVarLookupP(group, &varp) != S_SUCCESS){\
+/* fprintf(STDERR,"(%s) Failed to find %s\n",QSUBNAME,group);*/\
+ return(S_SUCCESS);\
+ }\
+ hook = ((thGroupOpaque *)varp->opaque)->ELEMENT;\
+ blocklist = ((thGroupOpaque *)varp->opaque)->blocklist;\
+ if(hook) {\
+ while(blocklist) {\
+ bvar = blocklist->varp;\
+ stat = (hook)(bvar);\
+ blocklist = blocklist->next;\
+ }\
+ }\
+ return(S_SUCCESS);\
+}
+MAKEGSUB(thExecuteGroup,"thExecuteGroup",execute)
+MAKEGSUB(thClearGroup,"thClearGroup",clear)
+MAKEGSUB(thClearScalersGroup,"thClearScalersGroup",clearScalers)
+MAKEGSUB(thIncrementScalersGroup,"thIncrementScalersGroup",incrementScalers)
+MAKEGSUB(thWriteGroup,"thWriteGroup",ctpwrite)
+MAKEGSUB(thCloseGroup,"thCloseGroup",ctpclose)
+
+thStatus thBook()
+/* Book all the parameter, tests and histograms and anything else that is
+ in the booking order list. Books groups in alphabetical order. Within
+ groups booking is done in the order that the blocks appear in the CTP
+ files.
+
+1/30/96 New behaviour. Just book the "all" group for each class. That way
+booking order will be precisely as appears in the CTP files.
+*/
+{
+ int i;
+ thStatus status;
+
+ status = S_FAILURE; /* Return failure if everything fails to book */
+
+ for(i=0;thHooks[i].type;i++){
+ char *prefix; char **glist0; char **glist; int count;
+
+#if 0
+ prefix = (char *) malloc(strlen(GROUPSTR) + strlen(thHooks[i].type) + 3);
+#else
+ prefix = (char *) malloc(strlen(GROUPSTR) + strlen(thHooks[i].type)
+ + strlen(ALLGRPSTR) + 3);
+#endif
+ strcpy(prefix,GROUPSTR);
+ strcat(prefix,".");
+ strcat(prefix,thHooks[i].type);
+ strcat(prefix,".");
+
+#if 0
+/* Make a list of all groups in this class */
+
+ daVarList(prefix,&glist0,&count);
+ glist = glist0;
+ while(count-- > 0){
+/* printf("Booking group %s\n",*glist);*/
+ if(thBookGroup(*glist) == S_SUCCESS){
+ status = S_SUCCESS;
+ } else {
+ fprintf(STDERR,"Failed to book %s\n",*glist);
+ }
+ glist++;
+ }
+#else
+ strcat(prefix,ALLGRPSTR);
+/* printf("Booking %s\n",prefix);*/
+ if(thBookGroup(prefix) == S_SUCCESS){
+ status = S_SUCCESS;
+ } else {
+/* fprintf(STDERR,"Failed to book %s\n",prefix);*/
+ }
+#endif
+ free(prefix);
+ }
+ return(status);
+}
+
+#define MAKEFSUB(SUBNAME,TYPESTR,CSUBNAME) \
+int SUBNAME(char *A1,unsigned C1)\
+{\
+ int A0;\
+ char *B1=0;\
+ int newsize;\
+ static char *full_name=0;\
+ static int full_name_size;\
+\
+ newsize = strlen(GROUPSTR) + strlen(TYPESTR) + C1 + 3;\
+ if(!full_name) {\
+ full_name_size = newsize;\
+ full_name = (char *) malloc(full_name_size);\
+ } else {\
+ if(newsize > full_name_size) {\
+ full_name = realloc(full_name,newsize);\
+ }\
+ }\
+ strcpy(full_name,GROUPSTR);\
+ strcat(full_name,".");\
+ strcat(full_name,TYPESTR);\
+ strcat(full_name,".");\
+ strcat(full_name,(!*(int *)A1)?0:memchr(A1,'\0',C1)?A1:\
+ (memcpy(B1=malloc(C1+1),A1,C1),B1[C1]='\0'\
+ ,kill_trailing(B1,' ')));\
+ A0 = CSUBNAME(full_name);\
+ if(B1) free(B1);\
+ return(A0);\
+}
+
+#ifdef AbsoftUNIXFortran
+MAKEFSUB(thtstexeg,TESTSTR,thExecuteGroup)
+MAKEFSUB(thtstclrg,TESTSTR,thClearGroup)
+MAKEFSUB(thtstclsg,TESTSTR,thClearScalersGroup)
+MAKEFSUB(thtstinsg,TESTSTR,thIncrementScalersGroup)
+MAKEFSUB(thhstexeg,HISTSTR,thExecuteGroup)
+MAKEFSUB(thgethitg,GETHITSTR,thExecuteGroup)
+MAKEFSUB(thtreeexeg,TREESTR,thExecuteGroup)
+MAKEFSUB(thtreecloseg,TREESTR,thCloseGroup)
+MAKEFSUB(thtreewriteg,TREESTR,thWriteGroup)
+#else
+MAKEFSUB(thtstexeg_,TESTSTR,thExecuteGroup)
+MAKEFSUB(thtstclrg_,TESTSTR,thClearGroup)
+MAKEFSUB(thtstclsg_,TESTSTR,thClearScalersGroup)
+MAKEFSUB(thtstinsg_,TESTSTR,thIncrementScalersGroup)
+MAKEFSUB(thhstexeg_,HISTSTR,thExecuteGroup)
+MAKEFSUB(thgethitg_,GETHITSTR,thExecuteGroup)
+MAKEFSUB(thtreeexeg_,TREESTR,thExecuteGroup)
+MAKEFSUB(thtreecloseg_,TREESTR,thCloseGroup)
+MAKEFSUB(thtreewriteg_,TREESTR,thWriteGroup)
+#endif
+
+/*
+#define MAKEFCALL(SUBNAME,CLASS) \
+
+MAKEFCALL(thhstexeg,hist)
+*/
diff --git a/CTP/thGroup.h b/CTP/thGroup.h
new file mode 100644
index 0000000..e9f3815
--- /dev/null
+++ b/CTP/thGroup.h
@@ -0,0 +1,47 @@
+/*-----------------------------------------------------------------------------
+ * Copyright (c) 1996 Southeastern Universities Research Association,
+ * Continuous Electron Beam Accelerator Facility
+ *
+ * This software was developed under a United States Government license
+ * described in the NOTICE file included as part of this distribution.
+ *
+ * Stephen A. Wood, 12000 Jefferson Ave., Newport News, VA 23606
+ * Email: saw@cebaf.gov Tel: (804) 249-7367 Fax: (804) 249-5800
+ *-----------------------------------------------------------------------------
+ *
+ * Description:
+ * Include file with group opaque structure and internal group calls
+ *
+ * Author: Stephen Wood, CEBAF Hall C
+ *
+ * Revision History:
+ * $Log: thGroup.h,v $
+ * Revision 1.2 1999/11/04 20:34:05 saw
+ * Alpha compatibility.
+ * New RPC call needed for root event display.
+ * Start of code to write ROOT trees (ntuples) from new "tree" block
+ *
+ * Revision 1.2 1999/08/25 13:16:06 saw
+ * *** empty log message ***
+ *
+ * Revision 1.1 1996/01/30 15:42:43 saw
+ * Initial revision
+ *
+ */
+struct thGroupOpaque { /* Opaque structure for group definitions */
+ daVarStructList *blocklist;
+ char *type; /* i.e. hist, test, gethit, ... */
+ thStatus (*book)(); /* Hooks to the appropriate routines */
+ thStatus (*execute)();
+ thStatus (*clear)();
+ thStatus (*clearScalers)();
+ thStatus (*incrementScalers)();
+ thStatus (*ctpwrite)();
+ thStatus (*ctpclose)();
+};
+typedef struct thGroupOpaque thGroupOpaque;
+
+void thInitGroupOpaque(char *name, thGroupOpaque *opqptr);
+/*void thInitGroupOpaque(char *name, (thGroupOpaque *) opqptr);*/
+
+
diff --git a/CTP/thHandlers.c b/CTP/thHandlers.c
new file mode 100644
index 0000000..d923d63
--- /dev/null
+++ b/CTP/thHandlers.c
@@ -0,0 +1,213 @@
+/*-----------------------------------------------------------------------------
+ * Copyright (c) 1993 Southeastern Universities Research Association,
+ * Continuous Electron Beam Accelerator Facility
+ *
+ * This software was developed under a United States Government license
+ * described in the NOTICE file included as part of this distribution.
+ *
+ * Stephen A. Wood, 12000 Jefferson Ave., Newport News, VA 23606
+ * Email: saw@cebaf.gov Tel: (804) 249-7367 Fax: (804) 249-5800
+ *-----------------------------------------------------------------------------
+ *
+ * Description:
+ * Special test and histogram handlers for RPC services.
+ *
+ * Author: Stephen Wood, CEBAF Hall C
+ *
+ * Revision History:
+ * $Log: thHandlers.c,v $
+ * Revision 1.3.24.1 2007/09/10 21:32:47 pcarter
+ * Implemented changes to allow compilation on RHEL 3,4,5 and MacOSX
+ *
+ * Revision 1.3 2003/02/21 20:55:24 saw
+ * Clean up some types and casts to reduce compiler warnings.
+ *
+ * Revision 1.2 1999/11/04 20:34:06 saw
+ * Alpha compatibility.
+ * New RPC call needed for root event display.
+ * Start of code to write ROOT trees (ntuples) from new "tree" block
+ *
+ * Revision 1.7 1999/08/25 13:16:06 saw
+ * *** empty log message ***
+ *
+ * Revision 1.6 1999/07/07 13:43:58 saw
+ * Move thTestRHandler() into thTestParse.c
+ *
+ * Revision 1.5 1996/08/01 01:31:56 saw
+ * Have thRHandler return a status
+ *
+ * Revision 1.4 1995/01/09 15:41:11 saw
+ * Change "linux" ifdef's to NOHBOOK.
+ *
+ * Revision 1.3 1994/10/16 21:42:21 saw
+ * Change an include file name from daVarServ.h daVarHandlers.h
+ *
+ * Revision 1.2 1993/08/12 14:57:39 saw
+ * Add #include <rpc/rpc.h>
+ *
+ * Revision 1.1 1993/05/10 21:06:46 saw
+ * Initial revision
+ *
+ */
+#include <string.h>
+#include <rpc/rpc.h>
+
+#include "daVar.h"
+#include "daVarRpc.h"
+#include "daVarHandlers.h"
+#include "th.h"
+#include "thInternal.h"
+
+#ifndef NOHBOOK
+#include "hbook.h"
+#endif
+
+int thLastIdRhandled;
+
+daVarStatus thWHandler(char *name,daVarStruct *varclass,any *setval)
+/* The write handler used by block.test, block.hist and block.parm */
+{
+ daVarStruct *varp;
+ char *attribute;
+ daVarStatus status;
+ int index;
+
+ status = daVarAttributeFind(name, varclass, &varp, &attribute, &index);
+ if(status == S_SUCCESS) {
+ status = daVarRegWatr(varp, attribute, index, setval);
+ if(strcasecmp(attribute,DAVAR_TITLE) == 0 && status == S_SUCCESS){
+ status = ((daVarStatus (*)()) varclass->opaque)(varp);
+ }
+ }
+ return(status);
+}
+daVarStatus thRHandler(char *name, daVarStruct *varclass, any *retval)
+/* The default Read handler */
+{
+ daVarStruct *varp;
+ char *attribute;
+ daVarStatus status;
+ int index;
+
+ status = daVarAttributeFind(name, varclass, &varp, &attribute, &index);
+ status = daVarRegRatr(varp, attribute, index, retval);
+ /* scaler attribute a synonym for the value which holds the block counter */
+ if(status == S_SUCCESS) {
+ if(strcasecmp(attribute,DAVAR_RATR) == 0){
+ retval->any_u.s = realloc(retval->any_u.s,strlen(retval->any_u.s)
+ +strlen(TH_SCALER) + 2);
+ strcat(retval->any_u.s,TH_SCALER);
+ strcat(retval->any_u.s,"\n");
+ }
+ } else {
+ if(strcasecmp(attribute,TH_SCALER) == 0){
+ retval->valtype = DAVARINT_RPC;
+ retval->any_u.i.i_len = 1;
+ retval->any_u.i.i_val = (int *) malloc(sizeof(int));
+ retval->any_u.i.i_val[0] = ((DAINT *)varp->varptr)[0];
+ }
+ }
+ return(status);
+}
+
+#ifndef NOHBOOK
+void thHistZeroLastId()
+{
+ thLastIdRhandled = 9999999;
+ return;
+}
+daVarStatus thHistRHandler(char *name, daVarStruct *varclass, any *retval)
+ /* Read Handler for Histograms */
+{
+ daVarStruct *varp;
+ char *attribute;
+ daVarStatus status;
+ int index;
+ static int NX,NY,NWT,LOC ; static float XMI,XMA,YMI,YMA;
+/* thHistOpaque *hopq;*/
+
+ status = daVarAttributeFind(name, varclass, &varp, &attribute, &index);
+ status = daVarRegRatr(varp, attribute, index, retval);
+ if(status == S_SUCCESS) {
+ if(strcasecmp(attribute,DAVAR_RATR) == 0){
+ retval->any_u.s = realloc(retval->any_u.s,strlen(retval->any_u.s)
+ + strlen(TH_ND) + strlen(TH_NX)
+ + strlen(TH_NY) + strlen(TH_XMI)
+ + strlen(TH_XMA) + strlen(TH_YMI)
+ + strlen(TH_YMA) + strlen(TH_CONTEN) + 9);
+ strcat(retval->any_u.s,TH_ND); strcat(retval->any_u.s,"\n");
+ strcat(retval->any_u.s,TH_NX); strcat(retval->any_u.s,"\n");
+ strcat(retval->any_u.s,TH_NY); strcat(retval->any_u.s,"\n");
+ strcat(retval->any_u.s,TH_XMI); strcat(retval->any_u.s,"\n");
+ strcat(retval->any_u.s,TH_XMA); strcat(retval->any_u.s,"\n");
+ strcat(retval->any_u.s,TH_YMI); strcat(retval->any_u.s,"\n");
+ strcat(retval->any_u.s,TH_YMA); strcat(retval->any_u.s,"\n");
+ strcat(retval->any_u.s,TH_CONTEN); strcat(retval->any_u.s,"\n");
+ }
+ } else {
+ char chtitle[80];
+
+ retval->valtype = DAVARERROR_RPC;
+ retval->any_u.error = S_DAVAR_UNKATTR;
+ if(thLastIdRhandled != *((DAINT *) varp->varptr)) {
+ thLastIdRhandled = *((DAINT *) varp->varptr);
+ HGIVE(*((DAINT *) varp->varptr),chtitle,NX,XMI,XMA,NY,YMI,YMA
+ ,NWT,LOC);
+ }
+ if(strcasecmp(attribute,TH_ND) == 0){
+ retval->valtype = DAVARINT_RPC;
+ retval->any_u.i.i_len = 1;
+ retval->any_u.i.i_val = (int *) malloc(varp->size*sizeof(int));
+ retval->any_u.i.i_val[0] = (NY == 0 ? 1 : 2);
+ } else if(strcasecmp(attribute,TH_NX) == 0){
+ retval->valtype = DAVARINT_RPC;
+ retval->any_u.i.i_len = 1;
+ retval->any_u.i.i_val = (int *) malloc(varp->size*sizeof(int));
+ retval->any_u.i.i_val[0] = NX;
+ } else if(strcasecmp(attribute,TH_NY) == 0){
+ retval->valtype = DAVARINT_RPC;
+ retval->any_u.i.i_len = 1;
+ retval->any_u.i.i_val = (int *) malloc(varp->size*sizeof(int));
+ retval->any_u.i.i_val[0] = NY;
+ } else if(strcasecmp(attribute,TH_XMI) == 0){
+ retval->valtype = DAVARFLOAT_RPC;
+ retval->any_u.r.r_len = 1;
+ retval->any_u.r.r_val = (float *) malloc(varp->size*sizeof(float));
+ retval->any_u.r.r_val[0] = XMI;
+ } else if(strcasecmp(attribute,TH_XMA) == 0){
+ retval->valtype = DAVARFLOAT_RPC;
+ retval->any_u.r.r_len = 1;
+ retval->any_u.r.r_val = (float *) malloc(varp->size*sizeof(float));
+ retval->any_u.r.r_val[0] = XMA;
+ } else if(strcasecmp(attribute,TH_YMI) == 0){
+ retval->valtype = DAVARFLOAT_RPC;
+ retval->any_u.r.r_len = 1;
+ retval->any_u.r.r_val = (float *) malloc(varp->size*sizeof(float));
+ retval->any_u.r.r_val[0] = YMI;
+ } else if(strcasecmp(attribute,TH_YMA) == 0){
+ retval->valtype = DAVARFLOAT_RPC;
+ retval->any_u.r.r_len = 1;
+ retval->any_u.r.r_val = (float *) malloc(varp->size*sizeof(float));
+ retval->any_u.r.r_val[0] = YMA;
+ } else if(strcasecmp(attribute,TH_CONTEN) == 0){
+ int size;
+ retval->valtype = DAVARFLOAT_RPC;
+ size = NX;
+ if(NY != 0) size *= NY;
+ retval->any_u.r.r_len = size;
+ retval->any_u.r.r_val = (float *)malloc(size*sizeof(float));
+ /* Next line gives warning "assignment of read-only location */
+ char tmpstring[] = "HIST";
+ HUNPAK(thLastIdRhandled,retval->any_u.r.r_val,tmpstring,(int) 1);
+ }
+ }
+ return(status);
+}
+#endif
+#ifdef ROOTTREE
+daVarStatus thTreeRHandler(char *name, daVarStruct *varclass, any *retval)
+/* The default Read handler */
+{
+ return(thRHandler(name, varclass, retval));
+}
+#endif
diff --git a/CTP/thHist.c b/CTP/thHist.c
new file mode 100644
index 0000000..aa7a32e
--- /dev/null
+++ b/CTP/thHist.c
@@ -0,0 +1,882 @@
+/*-----------------------------------------------------------------------------
+ * Copyright (c) 1993,1994 Southeastern Universities Research Association,
+ * Continuous Electron Beam Accelerator Facility
+ *
+ * This software was developed under a United States Government license
+ * described in the NOTICE file included as part of this distribution.
+ *
+ * Stephen A. Wood, 12000 Jefferson Ave., Newport News, VA 23606
+ * Email: saw@cebaf.gov Tel: (804) 249-7367 Fax: (804) 249-5800
+ *-----------------------------------------------------------------------------
+ *
+ * Description:
+ * Books histograms. Constants or array indices in configuration line may
+ * be expressions. The expressions get evaluated at run time.
+ *
+ * Author: Stephen Wood, CEBAF Hall C
+ *
+ * Revision History:
+ * $Log: thHist.c,v $
+ * Revision 1.3 2003/02/21 20:55:24 saw
+ * Clean up some types and casts to reduce compiler warnings.
+ *
+ * Revision 1.2 1999/11/04 20:34:06 saw
+ * Alpha compatibility.
+ * New RPC call needed for root event display.
+ * Start of code to write ROOT trees (ntuples) from new "tree" block
+ *
+ * Revision 1.1 1998/12/07 22:11:12 saw
+ * Initial setup
+ *
+ * Revision 1.16 1996/07/31 20:33:53 saw
+ * Show line number for booking errors.
+ *
+ * Revision 1.15 1996/01/30 15:37:37 saw
+ * Add thExecuteHistsV to execute the block contained by a var. Add thClearHists.
+ *
+ * Revision 1.14 1995/04/10 15:54:18 saw
+ * No defined hist blocks is not an error in thExecuteHists
+ *
+ * Revision 1.13 1995/01/13 16:25:49 saw
+ * Add missing return(S_SUCCESS) calls to various routines
+ *
+ * Revision 1.12 1995/01/09 15:53:45 saw
+ * On fprintf, indicate block type and well as name. Fix some memory leaks
+ * and shorted mallocs.
+ *
+ * Revision 1.11 1994/09/27 20:14:17 saw
+ * Remove some linux dependencies. Define dummy hbook routines.
+ *
+ * Revision 1.10 1994/08/26 13:17:44 saw
+ * Add option to thVarResolve to register unknown variables when requested
+ *
+ * Revision 1.9 1994/07/11 18:40:07 saw
+ * (SAW) Move thHistOpaque structure here from thInternals.h
+ *
+ * Revision 1.8 1994/06/28 19:40:04 saw
+ * Fix infinite loops when uhist blocks were encountered in thhstexe calls
+ *
+ * Revision 1.7 1994/06/13 13:05:01 saw
+ * Update ifdef's so this can compile under linux (no f77)
+ *
+ * Revision 1.6 1994/04/05 19:08:18 saw
+ * Use HEXIST to make sure we don't book existing histograms.
+ *
+ * Revision 1.5 1993/12/02 21:26:12 saw
+ * Allow histogram filling from doubles (REAL*8)
+ *
+ * Revision 1.4 1993/11/24 21:32:31 saw
+ * Floating argument of thEvalImed is now double.
+ *
+ * Revision 1.3 1993/07/09 18:45:45 saw
+ * Fix detection of 2d user histograms
+ *
+ * Revision 1.2 1993/05/10 20:46:54 saw
+ * Fix header
+ *
+ */
+
+#include <stdio.h>
+#include <string.h>
+#include <math.h>
+#include "daVar.h"
+#include "th.h"
+#include "thInternal.h"
+#include "thUtils.h"
+#include "hbook.h"
+#ifdef NOHBOOK
+int hexist_(){return(0);};
+float hi_(){};
+float hij_(){};
+float hx_(){};
+float hxy_(){};
+float hie_(){};
+float hxe_(){};
+float hif_(){};
+float hmax_(){};
+float hmin_(){};
+float hsum_(){};
+float hstati_(){};
+float hspfun_(){};
+float hrndm1_(){};
+float hrndm2_(){};
+void hbook1_(int *id, char *chtitle, int *nx, float *xmi, float *xma,
+ float *vmx,...){};
+void hbook2_(int *id, char *chtitle, int *nx, float *xmi, float *xma,
+ int *ny, float *ymi, float *yma, float *vmx,...){};
+void hf1_(int *id, float *x, float *weight,...){};
+void hf2_(int *id, float *x, float *y, float *weight,...){};
+void hdelet_(int *id,...){};
+void hlimit_(){};
+void hrfile_(){};
+void hrout_(){};
+void hrend_(){};
+/*
+void HF1(){};
+void HF2(){};
+void HDELET(){};
+void HBOOK1(){};
+void HBOOK2(){};
+int HEXIST(){};
+void HRFILE(){};
+void HREND(){};
+*/
+#endif
+
+extern daVarStatus thHistRHandler();
+
+struct thHistSpecList { /* Opaque structure for blocks */
+ daVarStruct *varname; /* name is "hist.xxx", varptr points to ID
+ title is optional title
+ opaque points nd, and x,y,test vars */
+ struct thHistSpecList *next;
+};
+typedef struct thHistSpecList thHistSpecList;
+
+typedef enum {HISTCLASS, UHISTCLASS} hclasstype;
+
+struct thHistOpaque { /* Opaque structure for histogram definition */
+ int nd; /* Number of dimensions */
+ daVarStruct *x; int xindex;
+ daVarStruct *y; int yindex;
+ daVarStruct *test; int testindex;
+ daVarStruct *weight; int weightindex;
+ /* Include here the limits? */
+ /* Include the pointer to the variable of how much to fill by. */
+};
+typedef struct thHistOpaque thHistOpaque;
+
+struct thHBlockList {
+ struct thHBlockList *next;
+ char *blockname; /* Block name without the "block.hist" */
+ hclasstype classtype;
+ daVarStruct *var; /* Varptr points to # times called
+ Title is code from file.
+ opaque is pointer to hist speclist */
+};
+typedef struct thHBlockList thHBlockList;
+
+thHBlockList *thHBlockListP; /* Pointer to list of hist blocks */
+
+thStatus thBookaHist(char *line, thHistSpecList **thHistNext);
+thStatus thExecuteaHist(thHistSpecList *Hist);
+thStatus thRemoveHists(char *block_name);
+thStatus thVarResolve(char *s, daVarStruct **var,int *index,int datatest,int newvartype);
+
+FCALLSCFUN1(INT,thGetHistID,THGETID,thgetid,STRING)
+FCALLSCFUN1(INT,thHistAliasWrite,THWHALIAS,thwhalias,STRING)
+
+/*
+enum attribute_value {HNAME, XSOURCE, YSOURCE, NBINS, NBINX, NBINY, XLOW,XHIGH
+, YLOW, YHIGH, TEST, TITLE, WEIGHT};
+char *attribute_string[] = {"name","xsource","ysource","nbins","nbinx","nbiny"
+,"xlow","xhigh","ylow","yhigh","title","test","weight"};
+*/
+int thMaxID=0; /* Maximum Hbook ID used so far */
+char *datasourcelist[]={EVENTSTR,TESTSTR,0}; /* Immediate expressions */
+char *testflaglist[]={TESTSTR,EVENTSTR,PARMSTR,0}; /* Logical operand */
+char *histclasslist[]={UHISTSTR,HISTSTR,0}; /* Hist name classes */
+
+thStatus thBookHists(daVarStruct *var)
+{
+ char *lines,*eol;
+ int line_count;
+ thHistSpecList **thHistNext;
+ char *blockname;
+ hclasstype classtype;
+
+#ifndef NOHBOOK
+ thHistZeroLastId();
+#endif
+
+ {
+ int i;
+/* printf("In bookhists\n");*/
+ /* Get the name without the block.hist on it */
+ blockname = var->name; /* If name doesn't fit pattern, use whole */
+ if(strcasestr(var->name,BLOCKSTR)==var->name){
+ i = strlen(BLOCKSTR) + 1;
+ if(strcasestr((var->name + i),HISTSTR)==(var->name + i)){
+ classtype = HISTCLASS;
+ i += strlen(HISTSTR);
+ if(*(var->name + i) == '.'){
+ blockname += i + 1;
+ }
+ } else if(strcasestr((var->name + i),UHISTSTR)==(var->name + i)){
+ classtype = UHISTCLASS;
+ i += strlen(UHISTSTR);
+ if(*(var->name + i) == '.'){
+ blockname += i + 1;
+ }
+ }
+ }
+ }
+/* printf("Booking histogram block %s\n",blockname);*/
+
+ if(var->opaque) thRemoveHists(blockname);
+
+ thHistNext = (thHistSpecList **) &var->opaque;
+ lines = var->title;
+ line_count = 0;
+ while(*lines){
+ char *lcopy;
+
+ line_count++;
+ eol = strchr(lines,'\n');
+ if(!eol) {
+ fprintf(stderr,"L %d: Last line of hist block %s has no newline\n"
+ ,line_count,var->name);
+ break;
+ }
+ if(*(eol+1)=='\0'){ /* This is the last line */
+ if(strcasestr(lines,ENDSTR) == 0)
+ fprintf(stderr,"L %d: Last line of hist block %s is not an END\n"
+ ,line_count,var->name);
+ break;
+ }
+ if(line_count == 1)
+ if(strcasestr(lines,BEGINSTR) != 0){
+/* printf("Is a begin\n");*/
+ lines = eol + 1;
+ continue;
+ } else
+ fprintf(stderr,"First line of hist block %s is not a BEGIN\n",var->name);
+ /* Ready to book the line, Add continuation lines later */
+ lcopy = (char *) malloc(eol-lines+1);
+ strncpy(lcopy,lines,(eol-lines));
+ *(lcopy + (eol-lines)) = '\0';
+/* printf("Passing|%s|\n",lcopy);*/
+ if(!thCleanLine(lcopy)){
+ if(thBookaHist(lcopy,thHistNext)==S_SUCCESS){
+ thHistNext = &((*thHistNext)->next);
+ } else {
+ fprintf(stderr,"(%s): Hist booking error in line %d\n",var->name,line_count);
+ }
+ }
+ free(lcopy);
+ lines = eol+1;
+ }
+ /* Update internal table of hist blocks. */
+ {
+ thHBlockList *thisblock,*nextblock,**lastblockp;
+ nextblock = thHBlockListP;
+ lastblockp = &thHBlockListP;
+ thisblock = thHBlockListP;
+ while(thisblock){
+ if((strcasecmp(thisblock->var->name,var->name)) == 0){
+ /* Replacing a block with a new definition */
+ fprintf(stderr,"Replacing %s with new definition\n",var->name);
+ if(thisblock->var != var){
+ fprintf(stderr,"ERR: Same name, different var pointer\n");
+ }
+ break;
+ }
+ lastblockp = &thisblock->next;
+ thisblock = thisblock->next;
+ }
+ if(!thisblock){ /* Create entry for New block */
+ *lastblockp = thisblock = (thHBlockList *) malloc(sizeof(thHBlockList));
+ thisblock->var = var;
+ thisblock->next = (thHBlockList *) NULL;
+ thisblock->blockname = (char *) malloc(strlen(blockname) + 1);
+ thisblock->classtype = classtype;
+ strcpy(thisblock->blockname,blockname);
+ }
+ }
+/* printf("Returning from booking hists\n");*/
+ return(S_SUCCESS);
+}
+
+thStatus thBookaHist(char *line, thHistSpecList **thHistNext)
+{
+ int nargs, nd, n, id;
+ char *long_title;
+ daVarStruct *(varp[2]),*testp,*weightp;
+ int vind[2],tind,wind;
+ thHistOpaque *histpars;
+ char *args[20];
+ /* int type;
+ thTokenType toktyp;
+ int nd,n;
+ */
+ int userflag; /* 0 for normal hist, 1 for user hist */
+
+ {
+ char *s;
+ s = line;
+ long_title = 0;
+ while(*s != 0) {
+ if(*s == HTITLECHAR){
+ *s++ = 0;
+ long_title = (char *) malloc(strlen(s)+1);
+ strcpy(long_title,s); /* Make sure to free this */
+ break;
+ } else s++;
+ }
+ }
+ if(!long_title) {
+ long_title = (char *) malloc(strlen(line)+1);
+ strcpy(long_title,line);
+ }
+ /* All between # and title char, comment char, or EOL is the weight */
+ {
+ char *s;
+ if((s=strchr(line,WEIGHTCHAR))) {
+ *s++=0;
+ s = thSpaceStrip(s);
+ if(thVarResolve(s,&weightp,&wind,0,0) != S_SUCCESS) {
+ free(long_title);
+ return(S_FAILURE);
+ }
+ } else {
+ weightp = 0;
+ wind = 0;
+ }
+ }
+
+ nargs = thCommas(line,args);
+ args[0] = thSpaceStrip(args[0]);
+
+ userflag = 0;
+ if(nargs >= 4 && nargs <=6) {
+ nd = 1;
+ if(nargs == 4) userflag = 1;
+ } else if(nargs == 7) {
+ nd = 2;
+ userflag = 1;
+ } else if(nargs >= 9 && nargs <= 10){
+ nd = 2;
+ } else {
+ fprintf(stderr,"Incorrect number of arguments\n");
+ free(long_title);
+ return(S_FAILURE);
+ }
+
+ varp[1] = 0; vind[1] = 0;
+ testp = 0; tind = 0;
+ if(userflag) {
+ varp[0] = 0; vind[0] = 0;
+ } else {
+ for(n=0;n<nd;n++){ /* Interpret the data sources */
+ args[n+1] = thSpaceStrip(args[n+1]);
+ if(thVarResolve(args[n+1],&varp[n],&vind[n],0,0) != S_SUCCESS) {
+ free(long_title);
+ return(S_FAILURE);
+ }
+ } /* Data sources now defined */
+ if((nd==1&&nargs==6)||(nd==2&&nargs==10)){
+ args[nargs-1] = thSpaceStrip(args[nargs-1]);
+ if(thVarResolve(args[nargs-1],&testp,&tind,1,0) != S_SUCCESS) {
+ free(long_title);
+ return(S_FAILURE);
+ }
+ if(testp->type != DAVARINT){
+ fprintf(stderr,"Test flag %s must be an integer\n",args[nargs-1]);
+ free(long_title);
+ return(S_FAILURE);
+ }
+ } else {
+/* printf("Test is NULL\n");*/
+ testp = NULL;
+ }
+ }
+ /* Find/Create the variable to hold hist def stuff */
+ {
+ char *name;
+ daVarStruct var;
+ thHistSpecList *Hist;
+
+ name = (char *) malloc(strlen(HISTSTR)+strlen(args[0])+2);
+ strcpy(name,HISTSTR);
+ strcat(name,".");
+ strcat(name,args[0]);
+ if(daVarLookup(name,&var)!=S_SUCCESS){
+ var.name = name;
+ var.size = 1;
+ var.varptr = (void *) malloc(sizeof(DAINT));
+ *((DAINT *) var.varptr) = ++thMaxID;
+ var.type = DAVARINT;
+ var.flag = DAVAR_READONLY | DAVAR_REPOINTOK;
+ if(userflag)
+ var.opaque = 0;
+ else
+ var.opaque = (void *) malloc(sizeof(thHistOpaque));
+ var.whook = 0;
+#ifndef NOHBOOK
+ var.rhook = thHistRHandler;
+#endif
+ var.title = long_title;
+/* printf("Registering %s\n",var.name);*/
+ daVarRegister((int) 0,&var); /* Create variable for histogram */
+ }
+ /* Make sure that we don't use an existing histogram id */
+ while(HEXIST((id= *((DAINT *) var.varptr))) != 0) {
+ *((DAINT *) var.varptr) = ++thMaxID;
+ }
+ id = *((DAINT *) var.varptr);
+ if(!userflag) {
+ histpars = var.opaque;
+ }
+ /* Perhaps we don't want to put the user hists in this list?? */
+ Hist = *thHistNext = (thHistSpecList *) malloc(sizeof(thHistSpecList));
+ Hist->next = (thHistSpecList *) NULL;
+ if(daVarLookupP(name,&Hist->varname)!=S_SUCCESS){
+ fprintf(stderr,"This can't happen\n");
+ free(long_title);
+ return(S_FAILURE);
+ }
+ free(name);
+ }
+ if(!userflag) {
+ histpars->nd = nd;
+ histpars->x = varp[0];
+ histpars->xindex = vind[0];
+ histpars->y = varp[1];
+ histpars->yindex = vind[1];
+ histpars->test = testp;
+ histpars->testindex = tind;
+ histpars->weight = weightp;
+ histpars->weightindex = wind;
+ }
+
+ /* Data sources and test result now interpreted */
+ {
+ int nbinx,nbiny;
+ double xlow,xhigh,ylow,yhigh;
+ int ixargoffset, iyargoffset;
+
+ if(userflag) {
+ ixargoffset = 1;
+ } else {
+ ixargoffset = 1 + nd;
+ }
+ iyargoffset = ixargoffset + 3;
+ if((thEvalImed(args[ixargoffset],0,&nbinx) != S_SUCCESS) ||
+ (thEvalImed(args[ixargoffset+1],&xlow,0) != S_SUCCESS) ||
+ (thEvalImed(args[ixargoffset+2],&xhigh,0) != S_SUCCESS))
+ fprintf(stderr,"Error intrepreting histogram arguments\n");
+ if(nd == 2){
+ thEvalImed(args[iyargoffset],0,&nbiny);
+ thEvalImed(args[iyargoffset+1],&ylow,0);
+ thEvalImed(args[iyargoffset+2],&yhigh,0);
+ }
+
+ if(nd==1){
+ HBOOK1(id,long_title,nbinx,(float) xlow,(float) xhigh,0.0);;
+ } else {
+ HBOOK2(id,long_title,nbinx,(float) xlow,(float) xhigh,nbiny,
+ (float) ylow,(float) yhigh,0.0);;
+ }
+ }
+ /* Need to add to alias file */
+ free(long_title);
+ return(S_SUCCESS);
+}
+thStatus thVarResolve(char *s, daVarStruct **varpp, int *index,
+ int datatest, int newvartype)
+/* Interpret the string as a variable name with a possible index.
+ Pass the index off the thEvalImed to evaluate it.
+
+Interpret the string s as an array element. Looks for an index inside
+of []'s, returning that in index. If there is an index inside of ()'s, then
+one is subtracted from the index before it is returnd. []'s are for
+c style indexing, ()'s for fortran style indexing. A pointer to the [ or (
+is returned, so that the variable name may be null terminated by the caller.
+If there is an error in the balancing of the []'s or ()'s, a null is returned
+to signify an error.
+datatest values
+ 0 - data source
+ 1 - test flag
+ 2 - data destination (create float if doesn't exist)
+ 3 - test flag (create if it doens't exist)
+*/
+{
+ int cstyle;
+ char cleft,cright;
+ char *leftp,*rightp;
+ char **classlist;
+ daVarStruct var;
+
+ *varpp = 0;
+ *index = 0;
+
+ leftp = strchr(s,'(');
+ {
+ char *lb;
+ lb = strchr(s,'[');
+ if(leftp) {
+ if(lb && lb<leftp) leftp = lb;
+ } else
+ leftp = lb;
+ }
+
+ if(leftp) {
+ cleft = *leftp;
+ *leftp = '\0';
+ }
+
+ if(datatest & 1)
+ classlist = testflaglist;
+ else
+ classlist = datasourcelist;
+ if(daVarLookupPWithClass(s,classlist,varpp) != S_SUCCESS){
+ if(datatest & 2) { /* Create the variable (as an int) */
+ if(strchr(s,'.')) { /* Don't prepend a class */
+ var.name = (char *) malloc(strlen(s)+1);
+ strcpy(var.name,s);
+ } else {
+ var.name = (char *) malloc(strlen(classlist[0])
+ +strlen(s)+2);
+ strcpy(var.name,classlist[0]);
+ strcat(var.name,".");
+ strcat(var.name,s);
+ }
+ var.size = 1;
+ var.type = newvartype;
+ switch(newvartype)
+ {
+ case DAVARINT:
+ var.varptr = (void *) malloc(sizeof(DAINT));
+ *((DAINT *)var.varptr) = 0;
+ break;
+ case DAVARFLOAT:
+ var.varptr = (void *) malloc(sizeof(DAFLOAT));
+ *((DAFLOAT *)var.varptr) = 0.0;
+ break;
+ case DAVARDOUBLE:
+ var.varptr = (void *) malloc(sizeof(DADOUBLE));
+ *((DADOUBLE *)var.varptr) = 0.0;
+ break;
+ }
+ var.opaque = 0;
+ var.rhook = 0;
+ var.whook = 0;
+ var.flag = DAVAR_REPOINTOK | DAVAR_READONLY | DAVAR_DYNAMIC_PAR;
+ var.title = 0;
+ printf("Registering %s at %d\n",var.name,var.varptr);
+ daVarRegister((int) 0,&var); /* Create the parameter */
+ daVarLookupP(var.name,varpp);
+ free(var.name);
+ } else {
+ fprintf(stderr,"Variable %s must be registered\n",s);
+ if(leftp) *leftp = cleft;
+ return(S_FAILURE);
+ }
+ }
+
+ if(leftp){
+ int cstyle;
+ char *sindex;
+ int indtemp;
+
+ *leftp = cleft;
+ sindex = leftp + 1;
+
+ if(cleft=='('){
+ cstyle = -1;
+ cright = ')';
+ } else {
+ cstyle = 0;
+ cright = ']';
+ }
+ if((rightp=strrchr(sindex,cright)) == 0){
+ fprintf(stderr,"Syntax error in %s\n",s);
+ return(S_FAILURE);
+ }
+ *rightp = 0;
+ if(thEvalImed(sindex,0,&indtemp)!= S_SUCCESS){
+ fprintf(stderr,"Error evaluating index %s\n",sindex);
+ *rightp = cright;
+ return(S_FAILURE);
+ }
+ *rightp = cright;
+ *index = indtemp + cstyle;
+ }
+ if(datatest & 2) { /* See if array needs to be larger */
+ if(*index >= (*varpp)->size) {
+ (*varpp)->size = *index+1;
+ switch((*varpp)->type)
+ {
+ case DAVARINT:
+ (*varpp)->varptr = (void *) realloc((*varpp)->varptr,(*index+1) * sizeof(DAINT));
+ break;
+ case DAVARFLOAT:
+ (*varpp)->varptr = (void *) realloc((*varpp)->varptr,(*index+1) * sizeof(DAFLOAT));
+ break;
+ case DAVARDOUBLE:
+ (*varpp)->varptr = (void *) realloc((*varpp)->varptr,(*index+1) * sizeof(DADOUBLE));
+ break;
+ }
+ }
+ }
+ return(S_SUCCESS);
+}
+
+thStatus thExecuteHistsV(daVarStruct *var){
+ thHistSpecList *thishist;
+
+ thishist = var->opaque;
+ while(thishist){
+ thExecuteaHist(thishist);
+ thishist = thishist->next;
+ }
+ (*((DAINT *)var->varptr))++; /* Increment block counter */
+ return(S_SUCCESS);
+}
+thStatus thClearHistsV(daVarStruct *var){
+ thHistSpecList *thishist;
+
+ thishist = var->opaque;
+ while(thishist){
+ HRESET(*(DAINT *) thishist->varname->varptr, thishist->varname->title);
+ thishist = thishist->next;
+ }
+ (*((DAINT *)var->varptr)) = 0; /* Increment block counter */
+ return(S_SUCCESS);
+}
+
+thStatus thExecuteHists(char *block_name){
+ thHistSpecList *thishist;
+ thHBlockList *thisblock;
+
+ if(block_name) if(*block_name=='\0') block_name = 0;
+
+ if(thHBlockListP == 0){
+ return(S_SUCCESS); /* No hists defined */
+ } else {
+ thisblock = thHBlockListP;
+ while(thisblock){
+ if(block_name)
+ if(strcasecmp(block_name,thisblock->blockname)!=0){
+ thisblock = thisblock->next;
+ continue;
+ }
+ if(thisblock->classtype == UHISTCLASS){
+ thisblock = thisblock->next;
+ continue;
+ }
+ thishist = thisblock->var->opaque;
+ while(thishist){
+ thExecuteaHist(thishist);
+ thishist = thishist->next;
+ }
+ (*((DAINT *)thisblock->var->varptr))++; /* Increment block counter */
+ if(block_name)
+ if(strcasecmp(block_name,thisblock->blockname)==0) return(S_SUCCESS);
+ thisblock = thisblock->next;
+ }
+ if(block_name) {
+ fprintf(STDERR,"Hist block %s not found\n",block_name);
+ return(S_FAILURE);
+ }
+ }
+ return(S_SUCCESS);
+}
+thStatus thExecuteaHist(thHistSpecList *Hist)
+{
+ float vals[2];
+
+ int id,nd;
+ daVarStruct *(varp[2]);
+ int indxy[2];
+ thHistOpaque *opqptr;
+ double weight;
+
+/* nd = Hist->nd;*/
+ opqptr = Hist->varname->opaque;
+ if(!opqptr) return(S_SUCCESS); /* Assume it is a user filled histogram */
+ nd = opqptr->nd;
+
+ varp[0] = opqptr->x; indxy[0] = opqptr->xindex;
+ varp[1] = opqptr->y; indxy[1] = opqptr->yindex;
+
+ for(id=0;id<nd;id++){
+ switch(varp[id]->type)
+ {
+ case DAVARINT:
+ vals[id] = *((DAINT *) varp[id]->varptr + indxy[id]);
+ break;
+ case DAVARFLOAT:
+ vals[id] = *((DAFLOAT *) varp[id]->varptr + indxy[id]);
+ break;
+ case DAVARDOUBLE:
+ vals[id] = *((DADOUBLE *) varp[id]->varptr + indxy[id]);
+ break;
+ }
+ }
+ if(opqptr->weight) {
+ switch(opqptr->weight->type)
+ {
+ case DAVARINT:
+ weight = *((DAINT *) opqptr->weight->varptr + opqptr->weightindex);
+ break;
+ case DAVARFLOAT:
+ weight = *((DAFLOAT *) opqptr->weight->varptr + opqptr->weightindex);
+ break;
+ case DAVARDOUBLE:
+ weight = *((DADOUBLE *) opqptr->weight->varptr + opqptr->weightindex);
+ break;
+ }
+ } else {
+ weight = 1.0;
+ }
+ if((opqptr->test ? *((DAINT *) opqptr->test->varptr + opqptr->testindex) : 1)) {
+ if(nd==1){
+ HF1(*(DAINT *) Hist->varname->varptr,vals[0],weight);
+/* printf("Filling %s at %f\n",Hist->varname->name,vals[0]);*/
+ }
+ else
+ HF2(*(int *) Hist->varname->varptr,vals[0],vals[1],weight);
+ }
+ return(S_SUCCESS);
+}
+thStatus thClearHists(char *block_name){
+ thHistSpecList *thishist;
+ thHBlockList *thisblock;
+
+ if(block_name) if(*block_name=='\0') block_name = 0;
+
+ if(thHBlockListP == 0){
+ return(S_SUCCESS); /* No tests defined */
+ } else {
+ thisblock = thHBlockListP;
+ while(thisblock){
+ if(block_name)
+ if(strcasecmp(block_name,thisblock->blockname)!=0){
+ thisblock = thisblock->next;
+ continue;
+ }
+/* if(thisblock->classtype == UHISTCLASS){
+ thisblock = thisblock->next;
+ continue;
+ }*/
+ thishist = thisblock->var->opaque;
+ while(thishist){
+ HRESET(*(DAINT *) thishist->varname->varptr, thishist->varname->title);
+ thishist = thishist->next;
+ }
+ (*((DAINT *)thisblock->var->varptr))=0; /* Increment block counter */
+ if(block_name)
+ if(strcasecmp(block_name,thisblock->blockname)==0) return(S_SUCCESS);
+ thisblock = thisblock->next;
+ }
+ }
+ return(S_SUCCESS);
+}
+thStatus thRemoveHists(char *block_name){
+ thHistSpecList *thishist,*nexthist;
+ thHBlockList *thisblock,*nextblock,**lastblockp;
+
+ if(block_name)
+ if(*block_name=='\0')
+ block_name = 0;
+ else
+ lastblockp = &thHBlockListP;
+
+ if(thHBlockListP == 0){
+ return(S_FAILURE); /* No histograms defined */
+ } else {
+ thisblock = thHBlockListP;
+ if(!block_name)
+ HDELET(0); /* Free all space */
+ while(thisblock) {
+ if(block_name)
+ if(strcasecmp(block_name,thisblock->blockname)!=0){
+ lastblockp = &thisblock->next;
+ thisblock = thisblock->next;
+ continue;
+ }
+ thishist = thisblock->var->opaque;
+ while(thishist){
+ nexthist = thishist->next;
+ if(block_name) {
+ HDELET(*(DAINT *) thishist->varname->varptr);
+ }
+ free(thishist);
+ thishist = nexthist;
+ }
+ nextblock = thisblock->next;
+ if(block_name){
+ if(strcasecmp(block_name,thisblock->blockname)==0) {
+ *lastblockp = nextblock;
+ free(thisblock);
+ }
+ return(S_SUCCESS);
+ } else {
+ free(thisblock);
+ }
+ thisblock = nextblock;
+ }
+ if(block_name) {
+ fprintf(stderr,"Hist block %s not found\n",block_name);
+ return(S_FAILURE);
+ }
+ thHBlockListP = (thHBlockList *) NULL;
+ }
+ return(S_SUCCESS);
+}
+int thGetHistID(char *name)
+{
+ daVarStruct *varp;
+
+ if(daVarLookupPWithClass(name,histclasslist,&varp) == S_SUCCESS){
+ if(varp->type = DAVARINT){
+ return((int) *((DAINT *) varp->varptr));
+ }
+ }
+ return(0); /* No hist ID found */
+}
+thStatus thHistAliasWrite(char *fname)
+{
+ FILE *OFILE;
+ thHBlockList *thisblock;
+ thHistSpecList *thishist;
+
+ if(thHBlockListP == 0) {
+ return(S_FAILURE); /* No tests defined */
+ }
+
+ if((OFILE = fopen(fname,"w")) == NULL) {
+ fprintf(stderr,"(thHistAliasWrite) Failed to open %s for write\n",fname);
+ return(S_FAILURE);
+ }
+ thisblock = thHBlockListP;
+ while(thisblock){
+ thishist = thisblock->var->opaque;
+ while(thishist){
+ char *name;
+ name = strchr(thishist->varname->name,'.');
+ if(name) {
+ name++;
+ fprintf(OFILE,"alias/create %s %d\n",name
+ ,*((DAINT *) thishist->varname->varptr));
+ } else {
+ fprintf(stderr,"No . in histogram name %s\n",thishist->varname->name);
+ }
+ thishist = thishist->next;
+ }
+ thisblock = thisblock->next;
+ }
+ fclose(OFILE);
+ return(S_SUCCESS);
+}
+
+int thhstexe_()
+{
+ int A0;
+ A0 = thExecuteHists(0);
+ return A0;
+}
+/* This routine needs to append block.hist in front. Ultimately it
+should probably only put this in front if there isn't a block. in the
+name already?? */
+int thhstexeb_(char *A1,unsigned C1)
+{
+ int A0;
+ char *B1;
+ A0 = thExecuteHists((!*(int *)A1)?0:memchr(A1,'\0',C1)?A1:
+ (memcpy(B1=malloc(C1+1),A1,C1),B1[C1]='\0'
+ ,kill_trailing(B1,' ')));
+ if(B1) free(B1);
+ return A0;
+}
diff --git a/CTP/thInternal.h b/CTP/thInternal.h
new file mode 100644
index 0000000..4dbfc68
--- /dev/null
+++ b/CTP/thInternal.h
@@ -0,0 +1,124 @@
+/*-----------------------------------------------------------------------------
+ * Copyright (c) 1993-1996 Southeastern Universities Research Association,
+ * Continuous Electron Beam Accelerator Facility
+ *
+ * This software was developed under a United States Government license
+ * described in the NOTICE file included as part of this distribution.
+ *
+ * Stephen A. Wood, 12000 Jefferson Ave., Newport News, VA 23606
+ * Email: saw@cebaf.gov Tel: (804) 249-7367 Fax: (804) 249-5800
+ *-----------------------------------------------------------------------------
+ *
+ * Description:
+ * Structures, defs, and prototypes for internal use by CTP.
+ *
+ * Author: Stephen Wood, CEBAF Hall C
+ *
+ * Revision History:
+ * $Log: thInternal.h,v $
+ * Revision 1.3 2004/07/08 20:06:09 saw
+ * Always have CTP Tree routines (perhaps dummy) available
+ *
+ * Revision 1.2 1999/11/04 20:34:06 saw
+ * Alpha compatibility.
+ * New RPC call needed for root event display.
+ * Start of code to write ROOT trees (ntuples) from new "tree" block
+ *
+ * Revision 1.8 1999/08/25 13:16:06 saw
+ * *** empty log message ***
+ *
+ * Revision 1.7 1999/03/01 19:54:48 saw
+ * Add weighted histograms
+ *
+ * Revision 1.6 1996/01/30 15:44:49 saw
+ * Add prototypes of calls needed by groups, add DEFAULTGRPSTR and ALLGRPSTR
+ *
+ * Revision 1.5 1995/08/03 13:53:43 saw
+ * Add parameters for #, real, integer, double
+ *
+ * Revision 1.4 1994/09/27 20:07:54 saw
+ * Add SCALERSTR definition
+ *
+ * Revision 1.3 1994/07/21 20:48:27 saw
+ * Add "gethit" and "report" string definitions
+ *
+ * Revision 1.2 1993/11/22 21:21:07 saw
+ * Add QUOTECHARS definitions.
+ *
+ * Revision 1.1 1993/05/11 17:37:30 saw
+ * Initial revision
+ *
+ */
+
+#ifndef _TH_INTERNAL_H
+#define _TH_INTERNAL_H
+
+#ifndef _DAVAR_H
+#include "daVar.h"
+#endif
+
+thStatus thLoadParameters(daVarStruct *var);
+thStatus thBookGethits(daVarStruct *var);
+thStatus thBookTests(daVarStruct *var);
+thStatus thBookHists(daVarStruct *var);
+thStatus thBookReports(daVarStruct *var);
+thStatus thExecuteTestsV(daVarStruct *var);
+thStatus thClearTestFlagsV(daVarStruct *var);
+thStatus thClearTestScalersV(daVarStruct *var);
+thStatus thIncTestScalersV(daVarStruct *var);
+thStatus thExecuteHistsV(daVarStruct *var);
+thStatus thClearHistsV(daVarStruct *var);
+thStatus thExecuteaGethitBlock(daVarStruct *var);
+thStatus thBookTree(daVarStruct *var);
+thStatus thFillTreeV(daVarStruct *var);
+thStatus thClearTreeV(daVarStruct *var);
+thStatus thWriteTreeV(daVarStruct *var);
+thStatus thCloseTreeV(daVarStruct *var);
+
+extern daVarStatus thWHandler();
+extern daVarStatus thRHandler();
+
+#define BEGINSTR "begin"
+#define ENDSTR "end"
+#define BLOCKSTR "block"
+#define GROUPSTR "group"
+#define DEFAULTGRPSTR "default"
+#define ALLGRPSTR "all"
+#define COMCHAR ';'
+#define SPECIALCHAR '#'
+
+/* Double and single quote chars */
+#define QUOTECHAR1 0x22
+#define QUOTECHAR2 0x27
+#define PARMSTR "parm"
+#define TESTSTR "test"
+#define HISTSTR "hist"
+#define UHISTSTR "uhist"
+#define NTUPLESTR "ntup"
+#define EVENTSTR "event"
+#define GETHITSTR "gethit"
+#define REPORTSTR "report"
+#define TREESTR "tree"
+#define SCALERSTR "scaler"
+#define REAL "real"
+#define INTEGER "integer"
+#define DOUBLE "double"
+
+#define HTITLECHAR '$'
+#define WEIGHTCHAR '#'
+
+#define TH_SCALER "scaler"
+#define TH_ND "nd"
+#define TH_NX "nx"
+#define TH_NY "ny"
+#define TH_XMI "xmi"
+#define TH_XMA "xma"
+#define TH_YMI "ymi"
+#define TH_YMA "yma"
+#define TH_CONTEN "conten"
+#define TH_X "x"
+#define TH_Y "y"
+#define TH_TEST "test"
+
+#endif
+
diff --git a/CTP/thLoad.c b/CTP/thLoad.c
new file mode 100644
index 0000000..ef2b767
--- /dev/null
+++ b/CTP/thLoad.c
@@ -0,0 +1,736 @@
+/*-----------------------------------------------------------------------------
+ * Copyright (c) 1993 Southeastern Universities Research Association,
+ * Continuous Electron Beam Accelerator Facility
+ *
+ * This software was developed under a United States Government license
+ * described in the NOTICE file included as part of this distribution.
+ *
+ * Stephen A. Wood, 12000 Jefferson Ave., Newport News, VA 23606
+ * Email: saw@cebaf.gov Tel: (804) 249-7367 Fax: (804) 249-5800
+ *-----------------------------------------------------------------------------
+ *
+ * Description:
+ * Read CTP configuration files saving them as the titles of registered
+ * block variables. thBook books all unbooked blocks.
+ *
+ * Author: Stephen Wood, CEBAF Hall C
+ *
+ * Revision History:
+ * $Log: thLoad.c,v $
+ * Revision 1.5 2004/07/13 15:04:53 saw
+ * Get count of groups on begin line correct when there are other attributes
+ *
+ * Revision 1.4 2004/07/08 20:06:45 saw
+ * CTP Root Trees can exist in input files even if root trees not compiled in.
+ *
+ * Revision 1.3 2003/02/21 20:55:24 saw
+ * Clean up some types and casts to reduce compiler warnings.
+ *
+ * Revision 1.2 1999/11/04 20:34:06 saw
+ * Alpha compatibility.
+ * New RPC call needed for root event display.
+ * Start of code to write ROOT trees (ntuples) from new "tree" block
+ *
+ * Revision 1.17 1999/08/25 13:16:06 saw
+ * *** empty log message ***
+ *
+ * Revision 1.16 1999/03/01 19:56:12 saw
+ * Work on INPUT_FILE open/close problem
+ *
+ * Revision 1.15 1996/07/31 20:35:19 saw
+ * Book all groups instead of default groups. (Forces booking order to
+ * be same as input files)
+ *
+ * Revision 1.14 1996/01/30 15:38:32 saw
+ * Add groups
+ *
+ * Revision 1.13 1995/08/03 13:52:42 saw
+ * Add a missing return statement
+ *
+ * Revision 1.12 1995/02/04 19:08:29 saw
+ * Fix problem in finding quotes around include filenames.
+ *
+ * Revision 1.11 1995/01/09 15:22:51 saw
+ * Add include files, fix assorted paren placement problems that were only
+ * apparent on ultrix and linux
+ *
+ * Revision 1.10 1994/09/27 19:41:03 saw
+ * Remove linux dependencies
+ *
+ * Revision 1.9 1994/08/26 13:20:24 saw
+ * Add DAVAR_REPOINTOK to some flags
+ *
+ * Revision 1.8 1994/07/21 18:43:58 saw
+ * Add gethit and report to list of valid block classes
+ *
+ * Revision 1.7 1994/06/13 13:08:27 saw
+ * getblock: fix bug in reading of non standard block types
+ *
+ * Revision 1.6 1994/06/03 18:48:41 saw
+ * Replace stderr with STDERR
+ *
+ * Revision 1.5 1993/10/18 18:28:28 saw
+ * Fix blank lines causing failure on HP.
+ *
+ * Revision 1.4 1993/09/10 17:37:07 saw
+ * *** empty log message ***
+ *
+ * Revision 1.3 1993/09/10 17:32:59 saw
+ * Fix up improper use of blockname in getblock after freeing blockname.
+ *
+ * Revision 1.2 1993/05/10 21:18:56 saw
+ * Fix header
+ *
+ */
+/*
+ Read in lines of text and save them in a long string. Test, histogram
+ booking and parameter lines will be saved in a long carriage return
+ separated string.
+*/
+
+/* Scheme. Call a routine with an open file. It reads the file, ignoreing
+ input until a "begin" is found. It then reads until an end line is found.
+ It then returns a string that contains the whole contents of the file
+ between the begin and the end.
+
+This is loading phase. When loading is done, user must call a book all
+routine.
+
+*/
+
+#include <stdio.h>
+#include "daVar.h"
+#include "th.h"
+#include "thInternal.h"
+#include "thUtils.h"
+#include "cfortran.h"
+#include "thGroup.h"
+
+#define MAXLINELENGTH 512
+#define MAXTOKS 20
+#define max(a,b) (a<b ? b : a)
+#define INCLUDESTR "#include"
+
+/*extern thStatus thBookGethits(daVarStruct *var);
+extern thStatus thBookTests(daVarStruct *var);
+extern thStatus thBookHists(daVarStruct *var);
+extern thStatus thBookReports(daVarStruct *var);
+extern thStatus thBookGroup(daVarStruct *var);
+extern daVarStatus thWHandler();
+extern daVarStatus thRHandler();*/
+
+char *types[]={PARMSTR, GETHITSTR, TESTSTR, HISTSTR, UHISTSTR,
+ TREESTR,
+ REPORTSTR, 0};
+thStatus (*hooks[])()={thLoadParameters, thBookGethits, thBookTests,
+ thBookHists, thBookHists,
+ thBookTree,
+ thBookReports, 0};
+
+char *qualifiers[]={"obey", "read", "write", 0};
+int qualflags[]={DAVAR_OBEYMF, DAVAR_READONLY, DAVAR_READWRITE, DAVAR_OBEYMF};
+
+struct thBookList {
+ char *classname; /* Variable name containing the whook */
+ struct thBookList *next;
+};
+typedef struct thBookList thBookList;
+
+thBookList *thBookListP=NULL;
+
+thStatus thSetBlockClasses();
+
+/* Fortran Interface */
+FCALLSCFUN0(INT,thOBook,THOBOOK,thobook)
+FCALLSCFUN1(INT,thLoad,THLOAD,thload,STRING)
+
+struct thFdList {
+ FILE *fd;
+ struct thFdList *next;
+};
+typedef struct thFdList thFdList;
+thFdList *thFdListP=NULL;
+
+FILE *myopen(char *fname);
+FILE *myclose(FILE *fd);
+void mycloseall();
+FILE *do_include(char *fname);
+
+thStatus thOBook()
+/* Book all the parameter, tests, and histograms and anything else that is
+ in the booking order list.
+ This is the pre-group booking routine. Within each class it booked blocks
+ in alphabetical order.
+*/
+{
+ thBookList *booklist;
+
+ /* Need to find a way to make sure these are called by anything else
+ that might do booking. Perhaps need a thInit routine. */
+/* printf("In thBook\n");*/
+ if (!thBookListP) { /* Booking order not defined */
+ if(thSetBlockClasses() != S_SUCCESS){
+ fprintf(STDERR,"Failed to set the th Block Class handlers\n");
+ return(S_FAILURE);
+ }
+ }
+
+ booklist = thBookListP;
+ while(booklist){
+ char *prefix; char **blist0; char **blist; int count;
+ daVarStruct var, *bvar;
+
+ if(daVarLookup(booklist->classname,&var) != S_SUCCESS){
+ fprintf(STDERR,"Failed to find class variable %s\n",booklist->classname);
+ return(S_FAILURE);
+ }
+
+ prefix = (char *) malloc(strlen(booklist->classname) + 2);
+ strcpy(prefix,booklist->classname);
+ strcat(prefix,".");
+
+ daVarList(prefix,&blist0,&count);
+ blist = blist0;
+ while(count-- > 0){
+ thStatus stat;
+
+ /* printf("Booking %s\n",*blist); */
+ if(daVarLookupP(*blist,&bvar) != S_SUCCESS){
+ fprintf(STDERR,"Failed to find %s\n",*blist);
+ return(S_FAILURE);
+ }
+ if(!bvar->varptr) { /* Only book those not already booked */
+ bvar->varptr = (DAINT *) malloc(sizeof(DAINT));
+ *((DAINT *) bvar->varptr) = 0; /* Initializec execution counter */
+ stat = ((thStatus (*)()) var.opaque)(bvar);
+ }
+ blist++;
+ }
+
+ daVarFreeList(blist0);
+
+ booklist = booklist->next;
+ }
+ return(S_SUCCESS);
+}
+thStatus thSetBlockClasses()
+{
+ thBookList *booklist;
+ thBookList **booknext;
+ daVarStruct var;
+ int i;
+
+ booknext = &thBookListP;
+ for(i=0;types[i];i++){
+ booklist = *booknext = (thBookList *) malloc(sizeof(thBookList));
+ booklist->classname = (char *)
+ malloc(strlen(BLOCKSTR) + strlen(types[i]) + 2);
+ strcpy(booklist->classname,BLOCKSTR);
+ strcat(booklist->classname,".");
+ strcat(booklist->classname,types[i]);
+ booklist->next = (thBookList *) NULL;
+ booknext = &booklist->next;
+
+ var.name = booklist->classname;
+ var.title = 0;/*""*/
+ var.type = DAVARINT;
+ var.varptr = (DAINT *) malloc(sizeof(DAINT));
+ *((DAINT *) var.varptr) = i; /* Booking order */
+ var.size = 1;
+ var.whook = thWHandler;
+ var.rhook = thRHandler;
+ var.flag = DAVAR_READWRITE | DAVAR_REPOINTOK;
+ var.opaque = (void *) hooks[i];
+ if(daVarRegister((int) 0, &var) == S_FAILURE){
+ fprintf(STDERR,"Failed to register %s\n",var.name);
+ return(S_FAILURE);
+ }
+ }
+ return(S_SUCCESS);
+}
+
+thStatus thLoad(char *fname)
+/* Open the file and read in all the blocks of test, histogram, or parameter
+ code. Put the contents of each block into the title field of variables
+ with the names block.TYPE.NAME.
+ May want to change this later to take a file descriptor, not a file
+ name (so that pipes can be used.)
+ */
+{
+ FILE *INPUT_FILE; /* Descriptor file */
+ char *varname, *vartitle, **grouplist;
+ int qualid,ig;
+
+ if((INPUT_FILE = myopen(fname))==NULL) {
+ fprintf(STDERR,"(thLoad) Failed to open %s\n",fname);
+ return(S_FAILURE);
+ }
+ while(getblock(&INPUT_FILE,&varname,&vartitle,&qualid
+ ,&grouplist)==S_SUCCESS){
+ daVarStruct var,*varp;
+
+ if(daVarLookup(varname,&var) == S_SUCCESS){ /* Variable exists */
+ if(var.type != DAVARINT){
+ fprintf(STDERR,"Type for variable %s must be integer\n",varname);
+ return(S_FAILURE);
+ }
+ /* Free and zero the varptr to indicate that this block has not been
+ booked. */
+ if(var.varptr) {
+ free(var.varptr);
+ var.varptr = 0;
+ }
+ /* printf("XX: Found %s\n",varname);*/
+ } else {
+ var.name = varname;
+ var.type = DAVARINT;
+ var.varptr = 0; /* Null pointer means not yet booked */
+ var.size = 1;
+ var.opaque = 0; /* Booking routine may add opaque data */
+ var.rhook = 0;
+ var.whook = 0;
+ var.flag = DAVAR_READONLY | DAVAR_REPOINTOK;
+ }
+ var.title = vartitle; /* The lines to book test, hists, pars etc. */
+ var.flag = qualflags[qualid] | DAVAR_REPOINTOK;
+/* printf("XX: Registering %s\n",varname);*/
+ if(daVarRegister((int) 0, &var) == S_FAILURE){ /* Create block desciptor */
+ fprintf(STDERR,"Failure to register %s\n",varname);
+ fclose(INPUT_FILE);
+ return(S_FAILURE);
+ }
+ daVarLookupP(var.name,&varp);
+ /* Go attach this block to each group, create var for group
+ if it doesn't exist, check that block is not in group before
+ adding it at the end. Do we do the group stuff before or after
+ the block is fully read in? */
+ for(ig=0;grouplist[ig];ig++) {
+ daVarStruct varg;
+ daVarStructList *blist; /* Block list */
+ thGroupOpaque *opqptr;
+
+ if(daVarLookup(grouplist[ig],&varg) != S_SUCCESS){ /* Variable exists */
+ varg.name = grouplist[ig];
+ varg.type = DAVARINT;
+ varg.varptr = (void *) malloc(sizeof(DAINT));
+ *(DAINT *)varg.varptr = 0;
+ varg.size = 1;
+ varg.opaque = (void *) malloc(sizeof(thGroupOpaque));
+ opqptr = (thGroupOpaque *) varg.opaque;
+ thInitGroupOpaque(varg.name,opqptr); /* Fill the elelments of the structure */
+ varg.rhook = 0;
+ varg.whook = 0; /* Can put something neat here */
+ varg.flag = DAVAR_READONLY | DAVAR_REPOINTOK;
+ varg.title = 0; /* Would be nice to put group descriptions here */
+ } else
+ opqptr = (thGroupOpaque *) varg.opaque;
+ blist = opqptr->blocklist;
+ thAddVarToList(&blist, varp);
+ if(!opqptr->blocklist) { /* Create group list var if it doesn't exist */
+ opqptr->blocklist = blist;
+ if(daVarRegister((int) 0, &varg) == S_FAILURE){
+ fprintf(STDERR,"Failure to register %s\n",varg.name);
+ fclose(INPUT_FILE);
+ return(S_FAILURE);
+ }
+ }
+/* printf("X %s\n",grouplist[ig]);*/
+ }
+ }
+ /* Are we covering up something. Should we be able to get to here with
+ a null value for INPUT_FILE? Does it mean we have left a file open? */
+ if(INPUT_FILE) fclose(INPUT_FILE);
+
+#if 0
+ {
+ daVarStruct varg;
+ daVarStructList *blist;
+
+ if(daVarLookup("group.test.all",&varg)==S_SUCCESS) {
+ printf("All Test group blocks:\n");
+ blist = ((thGroupOpaque *)varg.opaque)->blocklist;
+ while(blist) {
+ printf(" %s\n",blist->varp->name);
+ blist = blist->next;
+ }
+ }
+ if(daVarLookup("group.hist.all",&varg)==S_SUCCESS) {
+ printf("All Histogram group blocks:\n");
+ blist = ((thGroupOpaque *)varg.opaque)->blocklist;
+ while(blist) {
+ printf(" %s\n",blist->varp->name);
+ blist = blist->next;
+ }
+ }
+ if(daVarLookup("group.parm.all",&varg)==S_SUCCESS) {
+ printf("All Parameter group blocks:\n");
+ blist = ((thGroupOpaque *)varg.opaque)->blocklist;
+ while(blist) {
+ printf(" %s\n",blist->varp->name);
+ blist = blist->next;
+ }
+ }
+ }
+#endif
+ return(S_SUCCESS);
+}
+int getblock(FILE **TEST_FILE, char **varname, char **vartitle, int *qualid
+ ,char ***grouplist)
+/*
+ Scan the file until a begin line is found. When "begin xxx" is found, read
+ all the lines up until end xxx is found, stuffing them into a line pointed
+ to by vartitle.
+
+ This code is really ugly. Can't I make it better?
+*/
+{
+
+ static char *start=0;
+ static char *last=0;
+ static char *next=0;
+ char oline[MAXLINELENGTH];
+ char line[MAXLINELENGTH];
+ static char *blockname=0;
+ static char **groups=0;
+ char *toks[MAXTOKS];
+ int toklens[3], ntoks, itok, qualifier;
+ char *stat;
+ char *s;
+ static char *thistype=0;
+ int endflag, len;
+ static int maxgroups=0;
+
+
+ int i;
+
+ static int EOF_PENDING=0; /* For cases where EOF happened in a file */
+
+ /* Scan for a begin line */
+
+ if(EOF_PENDING){
+ EOF_PENDING = 0;
+ if(start) free(start);
+ start = last = 0;
+ return(S_FAILURE); /* Should be another code for EOF */
+ }
+ toks[0] = line; /* Protect against blank lines */
+ /* Scan for "begin" statement or #include */
+ keep_looking_for_begin:
+ while((stat=fgets(oline,MAXLINELENGTH,*TEST_FILE))){
+ strcpy(line,oline);
+ s = line;
+ while(*s && *s != '\n' && *s != COMCHAR) s++;
+ *s = 0;
+ { /* Break into tokens */
+ s = line;
+ while(*s && isspace(*s)) s++; /* Skip white space to first character */
+ ntoks = 0;
+ while(*s){
+/* printf("|%s|\n",s);*/
+ toks[ntoks++] = s;
+ while(*s && !isspace(*s)) s++; /* Skip over token */
+ if(*s){
+ *s++ = 0;
+ while(*s && isspace(*s)) s++; /* Skip white space to next */
+ }
+ }
+ }
+ itok = 0;
+ if(strcasecmp(toks[itok++],BEGINSTR) == 0) break;
+ if(strcasecmp(toks[0],INCLUDESTR) == 0) *TEST_FILE = do_include(toks[1]);
+ }
+
+ if(stat == NULL) {
+ *TEST_FILE = myclose(*TEST_FILE);
+ if(*TEST_FILE) { /* Not the true end of file */
+ goto keep_looking_for_begin;
+ } else {
+ if(start) free(start);
+ start = last = 0;
+ return(S_FAILURE); /* Should be another code for EOF */
+ }
+ }
+
+ /* Begin found at this point */
+
+
+ for(i=0;qualifiers[i];i++){
+ if(strncasecmp(toks[itok],
+ qualifiers[i],
+ strlen(qualifiers[i])) == 0){
+ itok++;
+ break;
+ }
+ }
+ *qualid = i;
+
+ if(thistype)
+ thistype = (char *) realloc(thistype,strlen(toks[itok])+1);
+ else
+ thistype = (char *) malloc(strlen(toks[itok])+1);
+
+
+ for(i=0;types[i];i++){
+ if(strncasecmp(toks[itok],types[i],strlen(types[i])) == 0){
+ break;
+ }
+ }
+ if(types[i] == 0) {
+ fprintf(STDERR,"Unknown block type %s\n",toks[itok]);
+ strcpy(thistype,toks[itok]);
+ /* Need provision for user defined block types? */
+ } else {
+ strcpy(thistype,types[i]);
+ }
+ itok++;
+ {
+ int len;
+ len = strlen(BLOCKSTR) + strlen(thistype) + strlen(toks[itok]) + 3;
+ if(blockname)
+ blockname = (char *) realloc(blockname,len);
+ else
+ blockname = (char *) malloc(len);
+ }
+ strcpy(blockname,BLOCKSTR);
+ strcat(blockname,".");
+ strcat(blockname,thistype);
+ strcat(blockname,".");
+ strcat(blockname,toks[itok]);
+
+/* printf("|%s|\n",blockname);*/
+ /* Look for the group id */
+ itok++;
+ if(!groups) { /* Initialize groups array */
+ groups = (char **) malloc(3*(sizeof(char *)));
+ groups[0] = 0;
+ groups[1] = 0;
+ groups[2] = 0;
+ maxgroups = 2;
+ }
+ /* Put it in the all group */
+ if(groups[0]) free(groups[0]);
+ groups[0] = (char *) malloc(strlen(GROUPSTR)+strlen(thistype)
+ +strlen(ALLGRPSTR)+3);
+ strcpy(groups[0],GROUPSTR);
+ strcat(groups[0],".");
+ strcat(groups[0],thistype);
+ strcat(groups[0],".");
+ strcat(groups[0],ALLGRPSTR);
+
+ if(ntoks-itok+1 > maxgroups) {
+ int ig;
+ groups = (char **) realloc(groups,(ntoks-itok+2)*(sizeof(char *)));
+ for(ig=maxgroups+1;ig<ntoks-itok+2;ig++) {
+ groups[ig] = 0; /* Zero new elements, */
+ } /* Makeing sure realloc will work */
+ maxgroups = ntoks-itok+1;
+ }
+ if(ntoks > itok) {
+ int ig=1; /* Skip over all group */
+ for(;itok < ntoks;itok++) { /* Scan for the group keyword */
+ if(strncasecmp(toks[itok],GROUPSTR,strlen(GROUPSTR))==0) {
+ char *grpnam;
+ if(grpnam = strchr(toks[itok],'=')) {
+ grpnam++;
+ if(groups[ig]) free(groups[ig]);
+#if 0
+ /* For now, groups can only contain a single block type */
+ if(strchr(grpnam,'.')) { /* Class assigned already */
+ groups[ig] = (char *) malloc(strlen(GROUPSTR)+
+ strlen(toks[itok])+2);
+ strcpy(groups[ig],GROUPSTR);
+ strcat(groups[ig],".");
+ strcat(groups[ig],grpnam);
+ } else { /* Prepend block type */
+#endif
+
+ groups[ig] = (char *) malloc(strlen(GROUPSTR)+
+ strlen(grpnam)+strlen(thistype)+3);
+ strcpy(groups[ig],GROUPSTR);
+ strcat(groups[ig],".");
+ strcat(groups[ig],thistype);
+ strcat(groups[ig],".");
+ strcat(groups[ig],grpnam);
+#if 0
+ }
+#endif
+ } /* else { ignore if = is missing } */
+ ig++;
+ }
+ }
+ if(groups[ig]) { /* Null terminate list */
+ free(groups[ig]);
+ groups[ig] = 0;
+ }
+ } else { /* No groups specified, use default group */
+ if(groups[1]) free(groups[1]);
+ groups[1] = (char *) malloc(strlen(GROUPSTR)+strlen(thistype)
+ +strlen(DEFAULTGRPSTR)+3);
+ strcpy(groups[1],GROUPSTR);
+ strcat(groups[1],".");
+ strcat(groups[1],thistype);
+ strcat(groups[1],".");
+ strcat(groups[1],DEFAULTGRPSTR);
+ if(groups[2]) { /* Null terminate list */
+ free(groups[2]);
+ groups[2] = 0;
+ }
+ }
+
+ strcpy(line,oline); /* Save the line */
+ endflag = 0;
+
+ next = start; /* Initialize */
+ while(1){
+ len = strlen(line);
+ if(next+len >= last){
+ int newsize;
+/* char *src,*dst,*newstart;*/
+
+/* src = start;*/
+ newsize = max((last-start) + MAXLINELENGTH,(next-start) + len + 1);
+/* newstart = dst = (char *) malloc(newsize);
+ while(src < next) *dst++ = *src++;
+ if(start) free(start);
+ last = newstart + newsize;
+ start = newstart;*/
+ if(start) {
+ char *newstart;
+ newstart = (char *) realloc(start,newsize);
+ next = next + (newstart-start);
+ start = newstart;
+ } else {
+ start = (char *) malloc(newsize);
+ next = start;
+ }
+/* next = next + (dst-src);*/
+ }
+ strcpy(next,line);
+ next += len;
+
+ if(endflag) break;
+ reread:
+ if((stat=fgets(line,MAXLINELENGTH,*TEST_FILE))){
+ s = line;
+ while(*s && isspace(*s)) s++;
+ if(strncasecmp(s,INCLUDESTR,strlen(INCLUDESTR)) == 0) {
+ *TEST_FILE = do_include(s + strlen(INCLUDESTR));
+ goto reread; /* Get another line */
+ }
+ if(strncasecmp(s,ENDSTR,strlen(ENDSTR))!=0) continue;
+ s += strlen(ENDSTR)+1;
+ while(*s && isspace(*s)) s++;
+ if(strncasecmp(s,thistype,strlen(thistype))!=0) continue;
+/* Don't require block name to be restated
+ s += strlen(thistype)+1;
+ while(*s && isspace(*s)) s++;
+ if(strncasecmp(s,BLOCKSTR,strlen(BLOCKSTR))!=0) continue;
+*/
+ endflag = 1;
+ } else { /* EOF */
+ *TEST_FILE = myclose(*TEST_FILE);
+ if(!*TEST_FILE) { /* Test for true end of file */
+ strcpy(line,"end ");
+ strcat(line,s);
+ strcat(line," block\n");
+ endflag = 1; /* Terminate after writing end block */
+ } else {
+ goto reread; /* Get another line */
+ }
+ }
+ }
+
+ *varname = blockname;
+ *vartitle = start;
+ *grouplist = groups;
+
+ return(S_SUCCESS);
+}
+
+FILE *myopen(char *fname)
+{
+ /* Opens a new file, saving the last file descriptor on a stack. */
+ FILE *fd;
+ thFdList *next;
+
+ fd = fopen(fname,"r");
+ if(fd) {
+ next = thFdListP;
+ thFdListP = (thFdList *) malloc(sizeof(thFdList));
+ thFdListP->fd = fd;
+ thFdListP->next = next;
+ }
+ return(fd);
+}
+
+FILE *myclose(FILE *fd)
+{
+ /* Close a file. If that fd is at top of stack, remove it from stack */
+ thFdList *next;
+
+ if(thFdListP->fd == fd) {
+ next = thFdListP->next;
+ free(thFdListP);
+ thFdListP = next;
+ fclose(fd);
+ if(thFdListP) return(thFdListP->fd);
+ else return(0);
+ } else {
+ fclose(fd);
+ return(0);
+ /* Should probably return some kind of error because fd was not what
+ was expected. */
+ }
+}
+void mycloseall()
+{
+ /* Close all files on stack */
+ thFdList *next;
+
+ while(thFdListP) {
+ fclose(thFdListP->fd);
+ next = thFdListP->next;
+ free(thFdListP);
+ thFdListP = next;
+ }
+}
+
+FILE *do_include(char *include_string)
+{
+ /* Skip over whitespace:
+ Is first character a quote or double quote, if so, interpret string a
+ filename. Else interpret string as a variable and evaluate it. If it
+ is not of string type, assume it is a filename. */
+ char *fstring,*fname;
+ char *s;
+ char quotechar;
+ int len;
+ FILE *fd;
+
+ s = include_string;
+ while(*s && isspace(*s)) s++; /* Skip whitespace */
+ quotechar = 0;
+ if(*s == QUOTECHAR1 || *s == QUOTECHAR2) {
+ quotechar = *s++;
+ }
+ fstring = s;
+ while(*s && *s != quotechar && !isspace(*s) && (quotechar || *s != COMCHAR)){
+ s++;
+ }
+ len = s-fstring;
+ fname = (char *) malloc(len+1);
+ strncpy(fname,fstring,len);
+ fname[len] = '\0';
+ if(quotechar) {
+ fd = myopen(fname);
+ } else { /* TODO: Interpret as CTP variable */
+ fd = myopen(fname);
+ }
+ if(!fd) {
+ fprintf(STDERR,"(thLoad) Failed to open '%s'\n",fname);
+ if(thFdListP) fd = thFdListP->fd;
+ fd = 0;
+ }
+ free(fname);
+ return(fd);
+}
diff --git a/CTP/thParm.c b/CTP/thParm.c
new file mode 100644
index 0000000..01a1adb
--- /dev/null
+++ b/CTP/thParm.c
@@ -0,0 +1,454 @@
+/*-----------------------------------------------------------------------------
+ * Copyright (c) 1993 Southeastern Universities Research Association,
+ * Continuous Electron Beam Accelerator Facility
+ *
+ * This software was developed under a United States Government license
+ * described in the NOTICE file included as part of this distribution.
+ *
+ * Stephen A. Wood, 12000 Jefferson Ave., Newport News, VA 23606
+ * Email: saw@cebaf.gov Tel: (804) 249-7367 Fax: (804) 249-5800
+ *-----------------------------------------------------------------------------
+ *
+ * Description:
+ * Book parameters
+ *
+ * Author: Stephen Wood, CEBAF Hall C
+ *
+ * Revision History:
+ * $Log: thParm.c,v $
+ * Revision 1.4.26.1 2011/03/03 20:08:14 jones
+ * Used to be %li and %ld, but that makes 8 byte result stuffed into 4 byte lval .
+ *
+ * Revision 1.4 2003/02/21 20:55:24 saw
+ * Clean up some types and casts to reduce compiler warnings.
+ *
+ * Revision 1.3 1999/11/04 20:34:06 saw
+ * Alpha compatibility.
+ * New RPC call needed for root event display.
+ * Start of code to write ROOT trees (ntuples) from new "tree" block
+ *
+ * Revision 1.16 1999/08/16 16:31:10 saw
+ * Treat numbers that start with "0x" as hex.
+ *
+ * Revision 1.15 1998/09/29 18:28:47 saw
+ * We shouldn't use thIDToken to identify whether the RHS of a parameter
+ * setting line is a simple constant or an expression. So for now all RHS's
+ * will be evaluated. Need some thought about setting the type of new
+ * variables that get created. This eliminates the 1998 CTP bug.
+ *
+ * Revision 1.14 1995/08/03 13:54:22 saw
+ * Add thpset function to single parameter setting lines from code
+ *
+ * Revision 1.13 1995/04/10 15:41:21 saw
+ * Handle ctp file registration (#int, #real, ...)
+ *
+ * Revision 1.12 1995/01/09 15:26:09 saw
+ * On fprintf, indicate block type and well as name
+ *
+ * Revision 1.11 1994/08/26 13:29:37 saw
+ * Add DAVAR_REPOINTOK to created parameter.
+ *
+ * Revision 1.10 1994/07/21 20:35:44 saw
+ * Don't prepend parm. when creating variables that have . in them.
+ *
+ * Revision 1.9 1994/06/13 13:21:04 saw
+ * Fix up handling of string type CTP variables.
+ *
+ * Revision 1.8 1994/06/03 18:49:54 saw
+ * Replace stderr with STDERR
+ *
+ * Revision 1.7 1994/02/14 20:23:29 saw
+ * Comment out debugging printf's
+ *
+ * Revision 1.6 1994/02/08 21:34:01 saw
+ * Remove debugging statement
+ *
+ * Revision 1.5 1993/12/02 21:34:47 saw
+ * Fully allow doubles on parm left or right hand sides
+ *
+ * Revision 1.4 1993/09/22 17:27:39 saw
+ * Convert integer values with sscanf to allow for octal and hex.
+ *
+ * Revision 1.3 1993/09/13 20:52:34 saw
+ * Dynamically allocated arrays allowed. Dynamic params will automatically
+ * float if needed.
+ *
+ * Revision 1.2 1993/05/11 17:53:56 saw
+ * Fix header
+ *
+ */
+
+/* What to do about unregistered variables?
+ Register them as Int's now. Later allow declaring of reals and arrays.
+
+*/
+#include <stdio.h>
+#include <string.h>
+#include <math.h>
+#include "daVar.h"
+#include "th.h"
+#include "thInternal.h"
+#include "thUtils.h"
+#include "cfortran.h"
+
+#define MAXLINELENGTH 512
+/*#define NULL 0*/
+
+/* Global variables */
+int thParmVarIndex;
+int thParmVarType;
+int thParmVarALen;
+int *thParmVarLP;
+float *thParmVarFP;
+double *thParmVarDP;
+char *thParmVarSP;
+char *thParmVarName;
+daVarStruct *thParmVarVarp;
+int thParmVarDynamic;
+/**/
+
+char *classlist[]={PARMSTR,0}; /* Class list for parameter names */
+
+thStatus thParmLineSet(char *line);
+/*FCALLSCFUN1(INT,thLoadParameters,LOADPARM,loadparm,STRING)*/
+
+thStatus thLoadParameters(daVarStruct *var)
+/* Set the parameters as specified on the title line.
+ When done, replace title line with the parameters without the values??
+ For now, we won't modify the lines. */
+{
+ char *lines,*eol;
+ int line_count;
+
+ if(*((DAINT *)var->varptr) != 0) /* This block already booked */
+ return(S_SUCCESS);
+ *((DAINT *) var->varptr) = 1;
+ lines = var->title;
+ line_count = 0;
+ while(*lines){
+ char *lcopy;
+
+ line_count++;
+ eol = strchr(lines,'\n');
+ if(!eol) {
+ fprintf(STDERR,"L %d: Last line of parm block %s has no newline\n"
+ ,line_count,var->name);
+ break;
+ }
+ if(*(eol+1)=='\0'){ /* This is the last line */
+ if(strcasestr(lines,ENDSTR) == 0) {
+ fprintf(STDERR,"L %d: Last line of parm block %s is not an END\n"
+ ,line_count,var->name);
+ }
+ break;
+ }
+ if(line_count == 1)
+ if(strcasestr(lines,BEGINSTR) != 0){
+ /* printf("Is a begin\n");*/
+ lines = eol + 1;
+ continue;
+ } else
+ fprintf(STDERR,"First line of parm block %s is not a BEGIN\n",var->name);
+ /* Ready to book the line, Add continuation lines later */
+ lcopy = (char *) malloc(eol-lines+1);
+ strncpy(lcopy,lines,(eol-lines));
+ *(lcopy + (eol-lines)) = '\0';
+/* printf("Passing|%s|\n",lcopy);*/
+ if(!thSpecial(lcopy,PARMSTR)) {
+ if(thParmLineSet(lcopy)!=S_SUCCESS)
+ fprintf(STDERR,"Error saving parameters on line %d\n",line_count);
+ }
+ free(lcopy);
+ lines = eol + 1;
+ }
+ return(S_SUCCESS);
+}
+thStatus thParmLineSet(char *line)
+ /* Process a line of a parameter CTP block */
+{
+ thTokenType toktyp;
+ int vartyp;
+ int vardimen;
+ daVarStruct *varp;
+ int i;
+ char *varnam;
+ int nargs;
+ char *args[50];
+ char *orgargs; /* Unadulterated arguments line */
+
+ { /* Needs to be fixed to handle strings */
+ char *s;
+ int blank;
+ char quotechar;
+ int instring;
+
+ s = line;
+ blank = 1;
+ instring = 0;
+ while(*s != 0){
+ if(instring && *s == quotechar) {
+ if(*(s+1) == quotechar) s++;
+ else instring = 0;
+ } else {
+ if(*s == QUOTECHAR1 || *s== QUOTECHAR2) {
+ instring = 1;
+ quotechar = *s;
+ blank = 0;
+ } else if(isspace(*s)) {
+ *s = ' '; /* Remove tabs, ... */
+ } else if(*s == COMCHAR) {
+ *s = 0;
+ break;
+ } else
+ blank = 0;
+ }
+ s++;
+ }
+ if(blank) return(S_SUCCESS);
+ /* Now look for = and figure out what kind of variable is on left.
+ If more than one number is given, left must be array. */
+
+ s = line;
+ orgargs = 0;
+ if((s = strchr(s,'='))){
+ *s++ = '\0';
+ orgargs = (char *) malloc(strlen(s)+1);
+ strcpy(orgargs,s);
+ varnam = thSpaceStrip(line);
+ } else {
+ s = line;
+ varnam = 0;
+ }
+ nargs = thCommas(s,args);
+ for(i=0;i<nargs;i++){
+ args[i] = thSpaceStrip(args[i]);/* Remove all space from the argument */
+ /* printf("%s ",args[i]);*/
+ }
+ if(nargs > 0) /* If only white space after last comma, */
+ if(args[nargs-1][0] == '\0') /* then don't count it as an argument */
+ nargs--;
+ }
+
+ if(varnam){
+ toktyp = thIDToken(varnam);
+ if(toktyp != TOKVAR && toktyp != TOKARRAY){
+ fprintf(STDERR,"Variable name %s can't be a number\n",varnam);
+ if(orgargs) free(orgargs);
+ return(S_FAILURE);
+ }
+ if(toktyp == TOKARRAY){
+ char *p;
+ p = thTokenArray(varnam,&thParmVarIndex);
+ *p = 0;
+ } else
+ thParmVarIndex = 0;
+ if(daVarLookupPWithClass(varnam,classlist,&varp) != S_SUCCESS) {
+ /* Variable is not preregistered, we will automatically allocate it.
+ Later, a flag for the block will be added which will disallow
+ auto allocation. We will allocate here an integer array of length
+ thParmVarIndex plus the number of arguments on the line. If there
+ are subsequent lines, the array will automatically be extended below
+ since the code will see the DAVAR_DYNAMIC_PAR flag. If floating
+ point values are found on the lines below, the array will
+ automatically be changed to floating. (Perhaps we should just always
+ make the variables floating point.)
+ The noauto flag will eventually be implimented to disable automatic
+ variable createion. */
+ daVarStruct var;
+ if(strchr(varnam,'.')) { /* Don't prepend parm., if varname has '.'s */
+ var.name = (char *) malloc(strlen(varnam)+1);
+ strcpy(var.name,varnam);
+ } else {
+ var.name = (char *) malloc(strlen(classlist[0])
+ +strlen(varnam)+2);
+ strcpy(var.name,classlist[0]);
+ strcat(var.name,".");
+ strcat(var.name,varnam);
+ }
+ var.size = thParmVarIndex + nargs;
+ var.varptr = (void *) malloc(var.size*sizeof(DAINT));
+ var.opaque = 0;
+ var.rhook = 0;
+ var.whook = 0;
+ var.type = DAVARINT;
+ var.flag = DAVAR_REPOINTOK | DAVAR_READONLY | DAVAR_DYNAMIC_PAR;
+ var.title = 0;
+ daVarRegister((int) 0,&var); /* parameter */
+ daVarLookupP(var.name,&varp);
+ free(var.name);
+ fprintf(STDERR,"%s not registered, registering as int\n",varnam);
+ }
+ /* vardimen = varp->dimension;
+ if(vardimen==0 && toktyp == TOKARRAY) {
+ fprintf(STDERR,"Variable %s not registered as an array\n",varnam);
+ return(S_FAILURE);
+ }
+ */
+ vartyp = varp->type;
+ thParmVarType = vartyp;
+ thParmVarName = varp->name;
+ thParmVarVarp = varp;
+ thParmVarDynamic = (varp->flag & DAVAR_DYNAMIC_PAR);
+ thParmVarALen = varp->size;
+ switch(vartyp)
+ {
+ case DAVARINT:
+ thParmVarLP = (int *) varp->varptr;
+ break;
+ case DAVARFLOAT:
+ thParmVarFP = (float *) varp->varptr;
+ break;
+ case DAVARDOUBLE:
+ thParmVarDP = (double *) varp->varptr;
+ break;
+ case DAVARSTRING:
+ case DAVARFSTRING:
+ thParmVarSP = (char *) varp->varptr;
+ break;
+ }
+ }
+ if(thParmVarType == DAVARINT || thParmVarType == DAVARFLOAT
+ || thParmVarType == DAVARDOUBLE) {
+ for(i=0;i<nargs;i++){
+ int lval;
+ double dval;
+ toktyp = thIDToken(args[i]);
+ if(thParmVarIndex>=thParmVarALen){
+ if(thParmVarDynamic) { /* Automatically up size for dynamic pars */
+/* printf("i=%d, thParmVarIndex=%d, thParmVarALen=%d\n",i,thParmVarIndex
+ ,thParmVarALen);
+ printf("thParmVarType=%d\n",thParmVarType);*/
+ if(thParmVarType == DAVARINT){
+ int j;
+ int *TMPP;
+
+ thParmVarVarp->size = (thParmVarIndex + (nargs-i));
+ TMPP = (int *) malloc(thParmVarVarp->size*sizeof(DAINT));
+ for(j=0;j<thParmVarALen;j++)
+ TMPP[j] = thParmVarLP[j];
+ free(thParmVarLP);
+ thParmVarLP = TMPP;
+ thParmVarVarp->varptr = thParmVarLP;
+ } else { /*if(thParmVarType == DAVARFLOAT)*/
+ int j;
+ float *TMPP;
+
+ thParmVarVarp->size = (thParmVarIndex + (nargs-i));
+ TMPP = (float *) malloc(thParmVarVarp->size*sizeof(DAFLOAT));
+ for(j=0;j<thParmVarALen;j++)
+ TMPP[j] = thParmVarFP[j];
+ free(thParmVarFP);
+ thParmVarFP = TMPP;
+ thParmVarVarp->varptr = thParmVarFP;
+ }
+ thParmVarALen = thParmVarVarp->size;
+ } else {
+ fprintf(STDERR,"Tried to fill past end of array %s\n",thParmVarName);
+ if(orgargs) free(orgargs);
+ return(S_FAILURE);
+ }
+ }
+#define ALWAYSEVAL
+#ifndef ALWAYSEVAL
+ switch(toktyp)
+ {
+ case TOKINT:
+ /* Used to be %li and %ld, but that makes 8 byte result
+ stuffed into 4 byte lval */
+ if(args[i][0] == '0' && (args[i][1] == 'x' || args[i][1] == 'X')) {
+ sscanf(args[i],"%i",&lval); /* Treat as Hex */
+ } else {
+ sscanf(args[i],"%d",&lval); /* Treat as decimal */
+ }
+ dval = lval;
+ break;
+ case TOKFLOAT:
+ dval = atof(args[i]);
+ lval = floatToLong(dval);
+ break;
+ default:
+#endif
+ if(thEvalImed(args[i],&dval,&lval) != S_SUCCESS)
+ fprintf(STDERR,"Parm: Error interpreting %s\n");
+#ifndef ALWAYSEVAL
+ break;
+ }
+#endif
+ switch(thParmVarType)
+ {
+ case DAVARINT:
+ if(thParmVarDynamic) {
+ /* User must be careful, if an expression evaluated with thEvalImed ends up
+ as integer, then the type of the variable will stay as integer. */
+ if(toktyp == TOKFLOAT || (toktyp != TOKINT && dval != lval)) {
+ /* Floating point arg found */
+ int j; /* Copy integer arry to float array */
+ thParmVarFP = (float *) malloc(thParmVarALen*sizeof(DAFLOAT));
+ for(j=0;j<thParmVarALen;j++)
+ thParmVarFP[j] = thParmVarLP[j];
+ free(thParmVarLP);
+ thParmVarVarp->varptr = thParmVarFP;
+ thParmVarVarp->type = DAVARFLOAT;
+ thParmVarFP[thParmVarIndex++] = dval;
+ thParmVarType = DAVARFLOAT;
+ break;
+ }
+ }
+ thParmVarLP[thParmVarIndex++] = lval;
+ break;
+ case DAVARFLOAT:
+ thParmVarFP[thParmVarIndex++] = dval;
+ break;
+ case DAVARDOUBLE:
+ thParmVarDP[thParmVarIndex++] = dval;
+ break;
+ }
+ /* printf("Saved args[%d] %s %d %f\n",i,args[i],lval,dval);*/
+ }
+ } else if(thParmVarType == DAVARSTRING || thParmVarType == DAVARFSTRING) {
+ int maxlen, arglen;
+ char *argptr; char *s;
+
+ maxlen = thParmVarALen - ((thParmVarType == DAVARSTRING) ? 1 : 0);
+ /* Find first non blank character after the = */
+ argptr = orgargs;
+
+ while(isspace(*argptr)) argptr++;
+ if(argptr[0] == QUOTECHAR1 || argptr[0] == QUOTECHAR2){
+ s = argptr+1;
+ while(*s && *s != argptr[0]) s++; /* Search for nul or matching qu
+e */
+ *s = 0;
+ argptr++; /* Move to char after quote */
+ }
+ arglen = strlen(argptr);
+ if(arglen > maxlen) arglen = maxlen;
+ strncpy(thParmVarSP, argptr, arglen);
+ if(thParmVarType == DAVARFSTRING) {
+ while(arglen < maxlen)
+ thParmVarSP[arglen++] = ' '; /* Blank pad fortran strings */
+ } else {
+ thParmVarSP[arglen] = 0;
+ }
+ }
+ if(orgargs) free(orgargs);
+ return(S_SUCCESS);
+}
+/* Fortran routine to evaluate a line of the form parm = value */
+#ifdef NOF77extname
+int thpset
+#else
+int thpset_
+#endif
+(char *A1,unsigned C1)
+{
+ int A0;
+ char *B1;
+ thStatus status;
+
+ status = thParmLineSet((!*(int *)A1)?0:memchr(A1,'\0',C1)?A1:
+ (memcpy(B1=malloc(C1+1),A1,C1),B1[C1]='\0'
+ ,kill_trailing(B1,' ')));
+ if(B1) free(B1);
+ return status;
+}
diff --git a/CTP/thReport.c b/CTP/thReport.c
new file mode 100644
index 0000000..7520b1a
--- /dev/null
+++ b/CTP/thReport.c
@@ -0,0 +1,411 @@
+/*-----------------------------------------------------------------------------
+ * Copyright (c) 1994 Southeastern Universities Research Association,
+ * Continuous Electron Beam Accelerator Facility
+ *
+ * This software was developed under a United States Government license
+ * described in the NOTICE file included as part of this distribution.
+ *
+ * Stephen A. Wood, 12000 Jefferson Ave., Newport News, VA 23606
+ * Email: saw@cebaf.gov Tel: (804) 249-7367 Fax: (804) 249-5800
+ *-----------------------------------------------------------------------------
+ *
+ * Description:
+ * Report generator
+ *
+ * Author: Stephen Wood, CEBAF Hall C
+ *
+ * Revision History:
+ * $Log: thReport.c,v $
+ * Revision 1.3 2002/07/31 20:07:48 saw
+ * Add files for ROOT Trees
+ *
+ * Revision 1.2 1999/11/04 20:34:06 saw
+ * Alpha compatibility.
+ * New RPC call needed for root event display.
+ * Start of code to write ROOT trees (ntuples) from new "tree" block
+ *
+ * Revision 1.11 1999/03/01 19:56:52 saw
+ * Add Absoft Fortran stuff
+ *
+ * Revision 1.10 1997/05/30 14:06:17 saw
+ * Fix some memory leaks
+ *
+ * Revision 1.9 1995/05/09 17:03:13 saw
+ * Have threp and threpa return S_FAILURE when files can't be opened.
+ *
+ * Revision 1.8 1995/04/10 15:40:22 saw
+ * Force to floating point format on integer overflow from thEvalImed.
+ * Add a missing error return to thReportFromVar.
+ *
+ * Revision 1.7 1994/11/07 14:27:09 saw
+ * Bug fixes
+ *
+ * Revision 1.2 1994/06/14 21:13:28 saw
+ * Add fortran calls. Strip trailing spaces off of fortran strings.
+ *
+ * Revision 1.1 1994/06/13 13:27:25 saw
+ * Initial revision
+ *
+*/
+
+#define REPORTSTR "report"
+#define VLISTSTR "vlist."
+#define SPECIALTYPE 9999
+#include <stdio.h>
+#include "daVar.h"
+#include "th.h"
+#include "thInternal.h"
+#include "cfortran.h"
+
+char *reportclasslist[]={TESTSTR,PARMSTR,EVENTSTR,0};
+
+extern thStatus thReportFd(char *varname, FILE *output);
+thStatus thReportFromVar(daVarStruct *bvar,FILE *output);
+
+#ifdef AbsoftUNIXFortran
+int threp
+#else
+int threp_
+#endif
+(char *repname, char *filename
+ ,unsigned l_repname, unsigned l_filename){
+ int A0;
+ char *BR=0;
+ char *BF=0;
+ FILE *fd;
+
+ fd = fopen(((!*(int *)filename)?0:memchr(filename,'\0',l_filename)?filename:
+ (memcpy(BF=(char *) malloc(l_filename+1),filename,l_filename)
+ ,BF[l_filename]='\0',kill_trailing(BF,' '))),"w");
+/* Need to add an error message if fopen fails */
+ if(fd)
+ A0 = thReportFd(((!*(int *)repname)?0:memchr(repname,'\0',l_repname)
+ ?repname:(memcpy(BR=(char *) malloc(l_repname+1)
+ ,repname,l_repname)
+ ,BR[l_repname]='\0',kill_trailing(BR,' '))),fd);
+ else {
+ A0 = S_FAILURE;
+ fprintf(stderr,"Failed to open file %s\n",BF);
+ }
+ if(fd) fclose(fd);
+ if(BF) free(BF);
+ if(BR) free(BR);
+ return(A0);
+}
+#ifdef AbsoftUNIXFortran
+int threpa
+#else
+int threpa_
+#endif
+(char *repname, char *filename
+ ,unsigned l_repname, unsigned l_filename){
+ int A0;
+ char *BR=0;
+ char *BF=0;
+ FILE *fd;
+
+ fd = fopen(((!*(int *)filename)?0:memchr(filename,'\0',l_filename)?filename:
+ (memcpy(BF=(char *) malloc(l_filename+1),filename,l_filename)
+ ,BF[l_filename]='\0',kill_trailing(BF,' '))),"a");
+/* Need to add an error message if fopen fails */
+ if(fd)
+ A0 = thReportFd(((!*(int *)repname)?0:memchr(repname,'\0',l_repname)
+ ?repname:(memcpy(BR=(char *) malloc(l_repname+1)
+ ,repname,l_repname)
+ ,BR[l_repname]='\0',kill_trailing(BR,' '))),fd);
+ else
+ A0 = S_FAILURE;
+ if(fd) fclose(fd);
+ if(BF) free(BF);
+ if(BR) free(BR);
+ return(A0);
+}
+
+thStatus thBookReports(daVarStruct *var)
+{
+ /* Dummy routine. No booking action needed for reports */
+ return(S_SUCCESS);
+}
+thStatus thReportFd(char *block_name, FILE *output)
+{
+ static daVarStruct *bvar;
+ static char *fullvarname;
+
+ fullvarname = malloc(strlen(BLOCKSTR)+strlen(REPORTSTR)
+ +strlen(block_name)+3);
+ strcpy(fullvarname,BLOCKSTR);
+ strcat(fullvarname,".");
+ strcat(fullvarname,REPORTSTR);
+ strcat(fullvarname,".");
+ strcat(fullvarname,block_name);
+
+ if(daVarLookupP(fullvarname,&bvar) != S_SUCCESS){
+ fprintf(stderr,"Failed to find %s\n",fullvarname);
+ free(fullvarname);
+ return(S_FAILURE);
+ }
+ free(fullvarname);
+ return(thReportFromVar(bvar,output));
+}
+
+thStatus thReportFromVar(daVarStruct *bvar,FILE *output)
+{
+ char *lines,*eol,*s;
+ int line_count;
+ double dval; char *dfmt="%f";
+ int lval; char *lfmt="%d";
+ char *sval; char *sfmt="%s";
+ daVarStruct *varp;
+ int dtype;
+ int expression;
+
+ lines = bvar->title;
+/* printf("%s",lines);*/
+ (*((DAINT *) bvar->varptr))++; /* Number of times report has been printed */
+
+ line_count = 0;
+ while(*lines){
+ line_count++;
+ eol = strchr(lines,'\n');
+ if(!eol) {
+ fprintf(STDERR,"L %d: Last line of %s has no newline\n"
+ ,line_count,bvar->name);
+ }
+ if(*(eol+1)=='\0'){ /* This is the last line */
+ if(strcasestr(lines,ENDSTR) == 0)
+ fprintf(STDERR,"L %d: Last line of %s is not an END\n"
+ ,line_count,bvar->name);
+ else
+ break;
+ }
+ if(line_count == 1)
+ if(strcasestr(lines,BEGINSTR) != 0){
+ lines = eol + 1;
+ continue;
+ } else
+ fprintf(STDERR,"First line of %s is not a BEGIN\n",bvar->name);
+ /* Ready to process the line, Add continuation lines later */
+ s = lines;
+ while(s <= eol){
+ if(*s != '{') {
+ if(*s == '\\') {
+ if(*++s != '\n') fputc(*s++,output);/* Escape chars and newlines */
+ else s++;
+ } else fputc(*s++,output);
+ } else {
+ char *eptr; /* Expression pointer */
+ char *fptr; /* Format pointer */
+ char *eend; /* Pointer to end of expression */
+ char *fend; /* Pointer to end of format pointer */
+ char ceend, cfend;
+
+ eptr = ++s;
+ fptr = 0; eend = 0; fend = 0;
+ while(s < eol){
+ if(*s == ':') {
+ eend = s; ceend = *s;
+ *s++ = 0; /* Replace : with null to terminate expr */
+ fptr = s;
+ while(s < eol) {
+ if(*s == '}') {
+ fend = s; cfend = *s;
+ *s++ = 0; /* s points to next character to print */
+ break;
+ }
+ s++;
+ }
+ if(!fend) {fend = eol; cfend = *eol;}
+ break;
+ } else if (*s == '}') {
+ eend = s; ceend = *s;
+ *s++ = 0; /* s points to next character to print */
+ break;
+ } else s++;
+ }
+ if(!eend) {eend = eol; ceend = *eol;}
+
+ /* Look first for atomic values or variable names (could be a string) */
+ dtype = 0; /* Data type of variable or expression */
+ expression = 0;
+ if(strncasecmp(eptr,VLISTSTR,strlen(VLISTSTR)) == 0) {
+ dtype = SPECIALTYPE;
+ } else {
+ char *p;
+ p = eptr;
+ if(strchr(".0123456789",*p)) expression = 1;
+ while(*p && !expression){
+ if(strchr("*/-+%=!&~,<>[]()",*p++)) expression=1;
+ }
+ if(!expression) if(daVarLookupPWithClass(eptr,reportclasslist,&varp)==S_SUCCESS) {
+ switch(varp->type)
+ {
+ case DAVARSTRING:
+ sval = varp->varptr;
+ dtype = DAVARSTRING;
+ break;
+ case DAVARFSTRING: /* Fortran string */
+ sval = (char *) malloc(varp->size+1);
+ strncpy(sval,varp->varptr,varp->size); /* Copy and */
+ sval[varp->size] = '\0'; /* Null terminate */
+ {
+ char *strip;
+
+ strip = sval+varp->size-1;
+ while(*strip==' ' && strip>sval) strip--;
+ *(strip+1) = '\0';
+ }
+ printf("%s:",sval);
+ dtype = DAVARFSTRING;
+ break;
+ default:
+ break; /* Let thEvalImed handle other types */
+ }
+ }
+ }
+ if(dtype == 0){
+ int stat;
+ stat = thEvalImed(eptr,&dval, &lval);
+ if(stat==S_SUCCESS || stat==S_INTOVF){
+ /* printf("%f %d\n",dval,lval);*/
+ if(stat==S_INTOVF) {
+ dtype = DAVARDOUBLE;
+ } else if(dval == (double) lval) {
+ dtype = DAVARINT;
+ } else {
+ dtype = DAVARDOUBLE;
+ }
+ } /* else dtype stays zero and everything between {}'s is printed */
+ }
+ if(fptr&&(dtype==DAVARINT || dtype==DAVARDOUBLE)) {
+ char *sf;
+ sf = fptr;
+ while(*sf) {
+ if(*sf == '\\'){
+ if(*(sf+1)) sf++;
+ } else if(*sf=='%') {
+ if(*++sf) {
+ if(*sf != '%') break;
+ }
+ }
+ sf++;
+ }
+ while(*sf){
+ if(strchr("eEfgG",*sf)) {
+ dtype = DAVARDOUBLE;
+ break;
+ } else if(strchr("diouxXDOUcp",*sf)) {
+ dtype = DAVARINT;
+ break;
+ } else if(*sf=='s') {
+ fprintf(STDERR,"(thReport): %s not allowed with numbers\n");
+ break;
+ }
+ sf++;
+ }
+ }
+ switch(dtype) {
+ case DAVARINT:
+ if(!fptr) fptr = lfmt;
+ fprintf(output,fptr,lval);
+ break;
+ case DAVARDOUBLE:
+ if(!fptr) fptr = dfmt;
+ fprintf(output,fptr,dval);
+ break;
+ case DAVARSTRING:
+ case DAVARFSTRING:
+ if(!fptr) fptr = sfmt;
+ fprintf(output,fptr,sval);
+ if(dtype==DAVARFSTRING) free(sval);
+ break;
+ case SPECIALTYPE:
+ thReportSpecial(output,eptr);
+ break;
+ default:
+ fprintf(output,"{%s",eptr);
+ if(fptr) {
+ fprintf(output,":%s}",fptr);
+ } else {
+ fprintf(output,"}",fptr);
+ }
+ }
+ if(eend) {*eend = ceend;} /*s = eend+1;*/
+ if(fend) {*fend = cfend;} /*s = fend+1;}*/
+ }
+ }
+ lines = eol + 1;
+ }
+ return(S_SUCCESS);
+}
+thReportSpecial(FILE *output, char *eptr)
+{
+ char *vptr; /* Pointer to pattern to match */
+ char **vlist;
+ daVarStruct *varp;
+ int count;
+ int i;
+ char ftemp[20];
+ int len;
+
+ vptr = eptr + strlen(VLISTSTR);
+ daVarList(vptr,&vlist,&count);
+ for(i=0;i<count;i++) {
+ if(daVarLookupP(vlist[i],&varp)==S_SUCCESS) {
+ if(varp->flag & DAVAR_REPOINTOK)
+ fputc('*',output); /* CTP created */
+ else
+ fputc(' ',output); /* Explicitely registered */
+ if(strchr(vptr,'*') || strchr(vptr,'?')) {
+ fprintf(output,"%-30.30s",vlist[i]);
+ } else {
+ fprintf(output,"%-30.30s",vlist[i]+strlen(vptr));
+ }
+ if(varp->size == 1){
+ switch(varp->type)
+ {
+ case DAVARINT:
+ fprintf(output,"%-12i",*((DAINT *)(varp->varptr)));
+ break;
+ case DAVARFLOAT:
+ fprintf(output,"%-12f",*((DAFLOAT *)(varp->varptr)));
+ break;
+ case DAVARDOUBLE:
+ fprintf(output,"%-12lf",*((DADOUBLE *)(varp->varptr)));
+ break;
+ case DAVARSTRING:
+ case DAVARFSTRING:
+ fprintf(output,"%1.1s ",((char *)(varp->varptr)));
+ break;
+ }
+ fprintf(output," %-36.36s",varp->title);
+ } else {
+ switch(varp->type)
+ {
+ case DAVARINT:
+ case DAVARFLOAT:
+ case DAVARDOUBLE:
+ if(varp->type==DAVARINT) fputs("I*4",output);
+ else if(varp->type==DAVARFLOAT) fputs("R*4",output);
+ else if(varp->type==DAVARDOUBLE) fputs("R*8",output);
+ sprintf(ftemp,"(%d)",varp->size);
+ fputs(ftemp,output);
+ len = strlen(ftemp)+3;
+ while(len++<12) fputc(' ',output);
+ fprintf(output," %-36.36s",varp->title);
+ break;
+ case DAVARSTRING:
+ fprintf(output,"%-48.48s",((char *)(varp->varptr)));
+ break;
+ case DAVARFSTRING:
+ len = varp->size;
+ if(len>49) len=48;
+ sprintf(ftemp,"%%-%d.%ds",len,len);
+ fprintf(output,ftemp,((char *)(varp->varptr)));
+ break;
+ }
+ }
+ }
+ fprintf(output,"\n");
+ }
+ daVarFreeList(vlist);
+}
diff --git a/CTP/thRootStuff.cpp b/CTP/thRootStuff.cpp
new file mode 100644
index 0000000..014e756
--- /dev/null
+++ b/CTP/thRootStuff.cpp
@@ -0,0 +1,118 @@
+//
+// thRootStuff.cpp
+// C++ wrapper routines to interface between CTP and Root libraries
+//
+// $Log: thRootStuff.cpp,v $
+// Revision 1.3 2005/02/22 16:25:51 saw
+// Make sure next pointer is zeroed in rootfilelist
+//
+// Revision 1.2 2004/07/07 18:16:55 saw
+// use extern "C" to export names needed in thTree.c
+//
+// Revision 1.1 2002/07/31 20:07:48 saw
+// Add files for ROOT Trees
+//
+// Revision 1.1 1999/08/25 13:16:07 saw
+// *** empty log message ***
+//
+#include <stdio.h>
+#include <stdlib.h>
+
+#include <TROOT.h>
+#include <TFile.h>
+#include <TH1.h>
+#include <TH2.h>
+#include <TProfile.h>
+#include <TRandom.h>
+#include <TTree.h>
+
+TROOT CTP("CTP","CTP Histograms and trees");
+
+TTree *tree;
+TFile *hfile;
+
+struct thRootFileList {
+ char *filename;
+ TFile *tfile;
+ int count;
+ struct thRootFileList *next;
+};
+typedef struct thRootFileList thRootFileList;
+
+thRootFileList *rootfilelistp=0;
+
+extern "C" void *thRoot_TFile(char *filename);
+
+extern "C" void *thRoot_TTree(char *treename);
+
+extern "C" void thRoot_Branch(TTree *tree, char *branchname, void *structp, char *brancharg);
+
+extern "C" void thRoot_Fill(TTree *tree);
+
+extern "C" void thRoot_Write(thRootFileList *file);
+
+extern "C" void thRoot_Close(thRootFileList *file);
+
+void *thRoot_TFile(char *filename)
+{
+ thRootFileList *thisfile,**lastp;
+ thisfile = rootfilelistp;
+ lastp = &rootfilelistp;
+ while(thisfile) {
+ if(strcmp(thisfile->filename,filename)==0) {
+ thisfile->count++;
+ return((void *) thisfile);
+ }
+ lastp = &(thisfile->next);
+ thisfile = thisfile->next;
+ }
+ /* Need to check if file has been opened */
+ printf("Tfile(\"%s\",\"RECREATE\",\"CTP ROOT file with trees\")\n",filename);
+ *lastp = (thRootFileList *) malloc(sizeof(thRootFileList));
+ thisfile = *lastp;
+ thisfile->tfile = new TFile(filename,"RECREATE","CTP ROOT file with trees");
+ thisfile->count = 1;
+ thisfile->filename = (char *)malloc(strlen(filename)+1);
+ thisfile->next = (thRootFileList *) 0;
+ strcpy(thisfile->filename,filename);
+ return((void *) thisfile);
+}
+
+void *thRoot_TTree(char *treename)
+{
+ TTree *tree;
+
+ /* Perhaps Check if a tree exists by this name?? */
+ printf("new TTree(\"%s\",\"CTP ROOT tree\")\n",treename);
+ tree = new TTree(treename,"CTP ROOT tree");
+ return((void *)tree);
+}
+
+void thRoot_Branch(TTree *tree, char *branchname, void *structp, char *brancharg)
+{
+ tree->Branch(branchname,structp,brancharg);
+}
+
+void thRoot_Fill(TTree *tree)
+{
+ tree->Fill();
+}
+
+void thRoot_Write(thRootFileList *file)
+{
+ (file->tfile)->Flush();
+}
+
+void thRoot_Close(thRootFileList *file)
+{
+ TFile *hfile;
+ if(--file->count <= 0){
+ printf("Closing\n");
+ hfile = file->tfile;
+ hfile->Write();
+ hfile->Close();
+ } else {
+ printf("Not Closing\n");
+ }
+}
+
diff --git a/CTP/thTest.c b/CTP/thTest.c
new file mode 100644
index 0000000..dcf6462
--- /dev/null
+++ b/CTP/thTest.c
@@ -0,0 +1,538 @@
+/*-----------------------------------------------------------------------------
+ * Copyright (c) 1993 Southeastern Universities Research Association,
+ * Continuous Electron Beam Accelerator Facility
+ *
+ * This software was developed under a United States Government license
+ * described in the NOTICE file included as part of this distribution.
+ *
+ * Stephen A. Wood, 12000 Jefferson Ave., Newport News, VA 23606
+ * Email: saw@cebaf.gov Tel: (804) 249-7367 Fax: (804) 249-5800
+ *-----------------------------------------------------------------------------
+ *
+ * Description:
+ * Book tests, execute or operate on tests.
+ *
+ * Author: Stephen Wood, CEBAF Hall C
+ *
+ * Revision History:
+ * $Log: thTest.c,v $
+ * Revision 1.2 1999/11/04 20:34:07 saw
+ * Alpha compatibility.
+ * New RPC call needed for root event display.
+ * Start of code to write ROOT trees (ntuples) from new "tree" block
+ *
+ * Revision 1.1 1998/12/07 22:11:13 saw
+ * Initial setup
+ *
+ * Revision 1.7 1996/07/31 20:30:17 saw
+ * (SAW) List line number of booking errors. Add code in support of groups.
+ *
+ * Revision 1.6 1995/04/10 15:42:35 saw
+ * Handle ctp file registration (#int, #real, ...)
+ * No defined test blocks is not an error in thTestExecute
+ *
+ * Revision 1.5 1995/01/09 15:55:25 saw
+ * On fprintf, indicate block type and well as name.
+ *
+ * Revision 1.4 1994/08/31 13:05:02 saw
+ * Add code for WALK_CLEAR_FLAGS to thWalkTree
+ *
+ * Revision 1.3 1994/06/03 18:51:22 saw
+ * Replace stderr with STDERR
+ *
+ * Revision 1.2 1993/05/11 17:56:37 saw
+ * Fix header
+ *
+ */
+
+/*
+ Need to add means of accessing scalers. Two ways. 1 Register the
+ scaler array, 2 make a call with the name and a pointer to an array.
+*/
+
+/*An argument is a variable name, an array, or a number. Numbers are not
+allowed for test result. Arrays start at 0 if []'s are used and start
+at 1 if ()'s are used. Arrays may only be used for test results if they
+are already registered by the analyzer. (May add option to declare them
+in the test package.)*/
+
+#include <stdio.h>
+#include <string.h>
+#include <math.h>
+#include "daVar.h"
+#include "th.h"
+#include "thInternal.h"
+#include "thUtils.h"
+#include "thTestParse.h"
+#include "cfortran.h"
+#define max(a,b) (a<b ? b : a)
+#define min(a,b) (a>b ? b : a)
+
+#define MAXLINELENGTH 512
+
+struct thTBOpaque {
+ CODEPTR code;
+ CODEPTR end;
+ daVarStructList *vlisthead;
+};
+typedef struct thTBOpaque thTBOpaque;
+
+struct thTBlockList {
+ struct thTBlockList *next;
+ char *blockname; /* Block name with out the "block.test" */
+ daVarStruct *var; /* Pointer to variable that describes block */
+/* Block execution counter, pointer to list of test names and results */
+};
+typedef struct thTBlockList thTBlockList;
+
+thTBlockList *thTBlockListP = NULL;
+
+/* End of newstuff */
+
+thStatus thBookTests(daVarStruct *var)
+{
+ char *lines,*eol;
+ int line_count;
+ thTBOpaque *opqptr;
+ CODEPTR codehead, codenext, codelimit;
+
+ /* Need to zero out the count. Make sure variable for count is
+ created */
+
+/* printf("Booking tests %s\n",var->name);*/
+
+ if(var->opaque == 0) {
+ opqptr = (thTBOpaque *) malloc(sizeof(thTBOpaque));
+ var->opaque = (void *) opqptr;
+ codehead = codenext = (CODEPTR) malloc(sizeof(CODE)*CODESTARTSIZE);
+ codelimit = codehead + CODESTARTSIZE;
+ opqptr->vlisthead = 0;
+ } else {
+ daVarStructList *next,*this;
+
+ opqptr = (thTBOpaque *) var->opaque;
+ codehead = codenext = opqptr->code;
+ codelimit = opqptr->end;
+ this = opqptr->vlisthead;
+ while(this) {
+ next = this->next;
+ free(this);
+ this = next;
+ }
+ opqptr->vlisthead = 0;
+ }
+
+ lines = var->title;
+ line_count = 0;
+ while(*lines){
+ char *lcopy;
+
+ line_count++;
+ eol = strchr(lines,'\n');
+ if(!eol) {
+ fprintf(STDERR,"L %d: Last line of test block %s has no newline\n"
+ ,line_count,var->name);
+ break;
+ }
+/* {
+ *eol = 0;
+ printf("L %d:%s\n",line_count,lines);
+ *eol = '\n';
+ }*/
+
+/* printf("Next char = %d\n",*(eol+1));*/
+ if(*(eol+1)=='\0'){ /* This is the last line */
+ if(strcasestr(lines,ENDSTR) == 0) {
+ fprintf(STDERR,"L %d: Last line of test block %s is not an END\n"
+ ,line_count,var->name);
+/* fprintf(STDERR,"%s",var->title);*/
+ }
+ break;
+ }
+ if(line_count == 1)
+ if(strcasestr(lines,BEGINSTR) != 0){
+/* printf("Is a begin\n");*/
+ lines = eol + 1;
+ continue;
+ } else
+ fprintf(STDERR,"First line of test block %s is not a BEGIN\n",var->name);
+ /* Ready to book the line, Add continuation lines later */
+ lcopy = (char *) malloc(eol-lines+1);
+ strncpy(lcopy,lines,(eol-lines));
+ *(lcopy + (eol-lines)) = '\0';
+/* printf("Passing|%s|\n",lcopy);*/
+ if(!thSpecial(lcopy,TESTSTR)) {
+ if(!thCleanLine(lcopy)){
+ if(thBookaTest(lcopy,&codehead,&codenext,&codelimit,0,
+ &(opqptr->vlisthead))==S_SUCCESS) {
+ /* {
+ daVarStructList *walk;
+ walk = opqptr->vlisthead;
+ while(walk){
+ walk = walk->next;
+ }*/
+ /* {
+ CODEPTR code;
+ for(code=codehead;code < codenext; code++)
+ printf(" %x\n",*code);
+ }*/
+ } else {
+ fprintf(STDERR,"(%s): Test booking error in line %d\n",var->name,line_count);
+ }
+ }
+ }
+ free(lcopy);
+ lines = eol+1;
+ }
+
+ { /* */
+ CODEPTR src,dst;
+ dst = opqptr->code = (CODEPTR) malloc(sizeof(CODE)*(codenext-codehead));
+ src = codehead;
+ while(src < codenext) *dst++ = *src++;
+ opqptr->end = dst;
+ free(codehead);
+/* printf("%x %x\n",opqptr->code,opqptr->end);*/
+ }
+ /* Update internal table of test blocks. */
+ {
+ thTBlockList *thisblock,*nextblock,**lastblockp;
+ nextblock = thTBlockListP;
+ lastblockp = &thTBlockListP;
+ thisblock = thTBlockListP;
+ while(thisblock){
+ if((strcmp(thisblock->var->name,var->name)) == 0){
+ /* Replacing a block with a new definition */
+ fprintf(STDERR,"Replacing %s with new definition\n",var->name);
+ if(thisblock->var != var){
+ fprintf(STDERR,"ERR: Same name, different var pointer\n");
+ }
+ break;
+ }
+ lastblockp = &thisblock->next;
+ thisblock = thisblock->next;
+ }
+ if(!thisblock){ /* Create entry for New block */
+ char *s;
+ int i;
+ *lastblockp = thisblock = (thTBlockList *) malloc(sizeof(thTBlockList));
+ thisblock->var = var;
+ thisblock->next = (thTBlockList *) NULL;
+ /* Get the name without the block.test on it */
+ s = var->name; /* If name doesn't fit pattern, use whole */
+ if(strcasestr(var->name,BLOCKSTR)==var->name){
+ i = strlen(BLOCKSTR) + 1;
+ if(strcasestr((var->name + i),TESTSTR)==(var->name + i)){
+ i += strlen(TESTSTR);
+ if(*(var->name + i) == '.'){
+ s += i + 1;
+ }
+ }
+ }
+ thisblock->blockname = (char *) malloc(strlen(s) + 1);
+ strcpy(thisblock->blockname,s);
+ }
+ }
+ return(S_SUCCESS);
+}
+
+thStatus thClearTestFlagsV(daVarStruct *var)
+{
+ thTBOpaque *opqptr;
+ thStatus status;
+ daVarStructList *vlist;
+
+ opqptr = (thTBOpaque *) var->opaque;
+ vlist = opqptr->vlisthead;
+ while(vlist){
+ daVarStruct *varp;
+ varp = vlist->varp;
+ if(varp->type == DAVARINT) { /* Only clear when flag is integer */
+ int i;
+ for(i=0;i<varp->size;i++)
+ ((DAINT *) varp->varptr)[i] = 0;
+ }
+ vlist = vlist->next;
+ }
+}
+thStatus thClearTestScalersV(daVarStruct *var)
+{
+ thTBOpaque *opqptr;
+ thStatus status;
+ daVarStructList *vlist;
+
+ opqptr = (thTBOpaque *) var->opaque;
+ vlist = opqptr->vlisthead;
+ while(vlist){
+ daVarStruct *varp;
+ varp = vlist->varp;
+ if(varp->type == DAVARINT) { /* Only clear when flag is integer */
+ int i;
+ for(i=0;i<varp->size;i++)
+ ((DAINT *) varp->opaque)[i] = 0;
+ }
+ vlist = vlist->next;
+ }
+}
+thStatus thIncTestScalersV(daVarStruct *var)
+{
+ thTBOpaque *opqptr;
+ thStatus status;
+ daVarStructList *vlist;
+
+ opqptr = (thTBOpaque *) var->opaque;
+ vlist = opqptr->vlisthead;
+ while(vlist){
+ daVarStruct *varp;
+ varp = vlist->varp;
+ if(varp->type == DAVARINT) { /* Only clear when flag is integer */
+ int i;
+ for(i=0;i<varp->size;i++)
+ ((DAINT *) varp->opaque)[i] += (((DAINT *) varp->varptr)[i] != 0);
+
+ }
+ vlist = vlist->next;
+ }
+}
+thStatus thExecuteTestsV(daVarStruct *var)
+{
+ thTBOpaque *opqptr;
+ thStatus status;
+
+ CODEPTR codehead, codenext, codelimit;
+
+ opqptr = (thTBOpaque *) var->opaque;
+ status = thExecuteCode(var->name,opqptr->code,opqptr->end);
+ if(status == S_SUCCESS)
+ (*((DAINT *)var->varptr))++; /* Increment block counter */
+ return(status);
+}
+
+thStatus thWalkTree(char *block_name, WALKOP walkop)
+{
+ thTBlockList *thisblock,*nextblock,**lastblockp;
+ int *result;
+ thTBOpaque *opqptr;
+
+ if(block_name)
+ if(*block_name=='\0')
+ block_name = 0;
+ else
+ lastblockp = &thTBlockListP; /* If no block specified, do default group */
+
+ if(thTBlockListP == 0){
+ return(S_SUCCESS); /* No tests defined */
+ } else {
+ thisblock = thTBlockListP;
+ while(thisblock){
+ if(block_name)
+ if(strcasecmp(block_name,thisblock->blockname)!=0) {
+ lastblockp = &thisblock->next;
+ thisblock = thisblock->next;
+ continue;
+ }
+ if(walkop == WALK_DISPLAY)
+ fprintf(STDERR," /%s\n",thisblock->blockname);
+ else {
+ opqptr = thisblock->var->opaque;
+ if(walkop == WALK_EXECUTE) {
+ thExecuteCode(thisblock->var->name,opqptr->code,opqptr->end);
+ (*((DAINT *)thisblock->var->varptr))++; /* Increment block counter */
+ } else if(walkop == WALK_CLEAR_SCALERS
+ || walkop == WALK_INCREMENT_SCALERS
+ || walkop == WALK_CLEAR_FLAGS) {
+ daVarStructList *vlist;
+ vlist = opqptr->vlisthead;
+ while(vlist) {
+ daVarStruct *varp;
+ varp = vlist->varp;
+ if(varp->type == DAVARINT) {
+ int i;
+ if(walkop == WALK_CLEAR_SCALERS) {
+ if(varp->opaque)
+ for(i=0;i<varp->size;i++)
+ ((DAINT *) varp->opaque)[i] = 0;
+ } else if(walkop == WALK_INCREMENT_SCALERS) {
+ if(varp->opaque)
+ for(i=0;i<varp->size;i++)
+ ((DAINT *) varp->opaque)[i]
+ += (((DAINT *) varp->varptr)[i] != 0);
+ } else { /* WALK_CLEAR_FLAGS */
+ if(varp->type == DAVARINT) {
+ for(i=0;i<varp->size;i++)
+ ((DAINT *) varp->varptr)[i] = 0;
+ }
+ }
+ }
+ vlist = vlist->next;
+ }
+ } else
+ fprintf(STDERR,"Unimplimented WALK code\n");
+ }
+ nextblock = thisblock->next;
+ if(block_name) {
+ if(strcasecmp(block_name,thisblock->blockname)==0) {
+ if(walkop == WALK_REMOVE){
+ *lastblockp = nextblock;
+ free(thisblock);
+ }
+ return(S_SUCCESS);
+ }
+ } else if (walkop == WALK_REMOVE){
+ free(thisblock);
+ }
+ thisblock = nextblock;
+ }
+ if(block_name) {
+ fprintf(STDERR,"Test block %s not found\n",block_name);
+ return(S_FAILURE);
+ }
+ if(walkop == WALK_REMOVE)
+ thTBlockListP = (thTBlockList *) NULL;
+ }
+ return(S_SUCCESS);
+}
+
+/* Fortran callable versions of the various test walk routines */
+
+#ifdef NOF77extname
+int thtstexe()
+#else
+int thtstexe_()
+#endif
+{
+ int A0;
+ A0 = thWalkTree(0,WALK_EXECUTE);
+ return A0;
+}
+#ifdef NOF77extname
+int thtstexeb
+#else
+int thtstexeb_
+#endif
+(char *A1,unsigned C1)
+{
+ int A0;
+ char *B1;
+ A0 = thWalkTree((!*(int *)A1)?0:memchr(A1,'\0',C1)?A1:
+ (memcpy(B1=malloc(C1+1),A1,C1),B1[C1]='\0'
+ ,kill_trailing(B1,' ')),WALK_EXECUTE);
+ if(B1) free(B1);
+ return A0;
+}
+#ifdef NOF77extname
+int thtstdis()
+#else
+int thtstdis_()
+#endif
+{
+ int A0;
+ A0 = thWalkTree(0,WALK_DISPLAY);
+ return A0;
+}
+#ifdef NOF77extname
+int thtstdisb
+#else
+int thtstdisb_
+#endif
+(char *A1,unsigned C1)
+{
+ int A0;
+ char *B1;
+ A0 = thWalkTree((!*(int *)A1)?0:memchr(A1,'\0',C1)?A1:
+ (memcpy(B1=malloc(C1+1),A1,C1),B1[C1]='\0'
+ ,kill_trailing(B1,' ')),WALK_DISPLAY);
+ if(B1) free(B1);
+ return A0;
+}
+#ifdef NOF77extname
+int thtstclr()
+#else
+int thtstclr_()
+#endif
+{
+ int A0;
+ A0 = thWalkTree(0,WALK_CLEAR_FLAGS);
+ return A0;
+}
+#ifdef NOF77extname
+int thtstclrb
+#else
+int thtstclrb_
+#endif
+(char *A1,unsigned C1)
+{
+ int A0;
+ char *B1;
+ A0 = thWalkTree((!*(int *)A1)?0:memchr(A1,'\0',C1)?A1:
+ (memcpy(B1=malloc(C1+1),A1,C1),B1[C1]='\0'
+ ,kill_trailing(B1,' ')),WALK_CLEAR_FLAGS);
+ if(B1) free(B1);
+ return A0;
+}
+#ifdef NOF77extname
+int thtstins()
+#else
+int thtstins_()
+#endif
+{
+ int A0;
+ A0 = thWalkTree(0,WALK_INCREMENT_SCALERS);
+ return A0;
+}
+#ifdef NOF77extname
+int thtstinsb
+#else
+int thtstinsb_
+#endif
+(char *A1,unsigned C1)
+{
+ int A0;
+ char *B1;
+ A0 = thWalkTree((!*(int *)A1)?0:memchr(A1,'\0',C1)?A1:
+ (memcpy(B1=malloc(C1+1),A1,C1),B1[C1]='\0'
+ ,kill_trailing(B1,' ')),WALK_INCREMENT_SCALERS);
+ if(B1) free(B1);
+ return A0;
+}
+#ifdef NOF77extname
+int thtstcls()
+#else
+int thtstcls_()
+#endif
+{
+ int A0;
+ A0 = thWalkTree(0,WALK_CLEAR_SCALERS);
+ return A0;
+}
+#ifdef NOF77extname
+int thtstclsb
+#else
+int thtstclsb_
+#endif
+(char *A1,unsigned C1)
+{
+ int A0;
+ char *B1;
+ A0 = thWalkTree((!*(int *)A1)?0:memchr(A1,'\0',C1)?A1:
+ (memcpy(B1=malloc(C1+1),A1,C1),B1[C1]='\0'
+ ,kill_trailing(B1,' ')),WALK_CLEAR_SCALERS);
+ if(B1) free(B1);
+ return A0;
+}
+thStatus thExecuteTests(char *block_name)
+{
+ return(thWalkTree(block_name,WALK_EXECUTE));
+}
+thStatus thClearTestFlags(char *block_name)
+{
+ return(thWalkTree(block_name,WALK_CLEAR_FLAGS));
+}
+thStatus thClearTestScalers(char *block_name)
+{
+ return(thWalkTree(block_name,WALK_CLEAR_SCALERS));
+}
+thStatus thIncTestScalers(char *block_name)
+{
+ return(thWalkTree(block_name,WALK_INCREMENT_SCALERS));
+}
diff --git a/CTP/thTestExecute.c b/CTP/thTestExecute.c
new file mode 100644
index 0000000..6924601
--- /dev/null
+++ b/CTP/thTestExecute.c
@@ -0,0 +1,724 @@
+/*-----------------------------------------------------------------------------
+ * Copyright (c) 1993-1995 Southeastern Universities Research Association,
+ * Continuous Electron Beam Accelerator Facility
+ *
+ * This software was developed under a United States Government license
+ * described in the NOTICE file included as part of this distribution.
+ *
+ * Stephen A. Wood, 12000 Jefferson Ave., Newport News, VA 23606
+ * Email: saw@cebaf.gov Tel: (804) 249-7367 Fax: (804) 249-5800
+ *-----------------------------------------------------------------------------
+ *
+ * Description:
+ * Test code executor
+ *
+ * Author: Stephen Wood, CEBAF Hall C
+ *
+ * Revision History:
+ * $Log: thTestExecute.c,v $
+ * Revision 1.2.24.1.2.1 2011/03/03 20:09:01 jones
+ * Add check for 64bit by looking for LP64
+ *
+ * Revision 1.2.24.1 2007/09/10 21:32:47 pcarter
+ * Implemented changes to allow compilation on RHEL 3,4,5 and MacOSX
+ *
+ * Revision 1.2 2003/02/21 20:55:25 saw
+ * Clean up some types and casts to reduce compiler warnings.
+ *
+ * Revision 1.1 1998/12/07 22:11:13 saw
+ * Initial setup
+ *
+ * Revision 1.13 1996/08/01 01:33:31 saw
+ * Add trig functions. Print block name on errors. Allow floating arguments
+ * for mod (%).
+ *
+ * Revision 1.12 1995/08/03 13:56:00 saw
+ * Add single argument functions
+ *
+ * Revision 1.11 1995/02/14 16:53:12 saw
+ * Make compatible with OSF/Alpha (64 bit pointers)
+ *
+ * Revision 1.10 1994/10/03 12:39:45 saw
+ * All "/" (division) has real result. New op "//" has integerized result.
+ *
+ * Revision 1.9 1994/07/21 20:46:50 saw
+ * Make some POP and PUSH stuff more portable
+ *
+ * Revision 1.8 1994/06/13 13:26:55 saw
+ * Add some divide by zero checking
+ *
+ * Revision 1.7 1994/06/03 21:12:19 saw
+ * Use memcpy for stack manipulation
+ *
+ * Revision 1.5 1994/02/10 18:40:25 saw
+ * Typecasting of sp and pc pointer while incrementing or decrementing
+ * doesn't work for ANSI C (Silicon Graphics). Rewrote some POP and PUSH
+ * macros and other codes for this (presumably) non-posix case.
+ *
+ * Revision 1.4 1993/12/02 21:33:17 saw
+ * Fully allow the use of doubles in test expressions
+ *
+ * Revision 1.3 1993/11/22 20:42:12 saw
+ * Add return of status codes on thExecuteCode
+ *
+ * Revision 1.2 1993/05/11 17:58:13 saw
+ * Add copyright and header
+ *
+ */
+
+#include <stdio.h>
+#include <string.h>
+#include <math.h>
+#include "daVar.h"
+#include "th.h"
+#include "thUtils.h"
+#include "thTestParse.h"
+#include "thInternal.h"
+#include "cfortran.h"
+
+
+static DAINT stack[1000]; /* The stack */
+
+/* Execute Test Package Pseudo Code
+ code is first instruction, codelimit is pointer to location
+ after last instruction.
+ */
+
+#ifdef __sgi
+#define NOTPOSIX
+#endif
+
+#if defined(hpux) || defined(__sun)
+#define USEMEMCPY
+#endif
+
+#ifdef __DECC
+#define USEMEMCPY
+#endif
+
+#if (defined(__osf__) && defined(__alpha)) || defined(__LP64__)
+#undef USEMEMCPY
+#define NOTPOSIX
+#define POINTER64
+#endif
+
+#ifdef USEMEMCPY
+#define PUSHPOINTER(x) memcpy(((void **)sp)++, (void *)&x, sizeof(void *))
+#else
+//#define PUSHPOINTER(x) *((DAINT **)sp)++ = x
+//#define PUSHPOINTER(x) *(DAINT **)sp = x; (DAINT **)(sp = (DAINT *)(DAINT **)((DAINT **)sp + 1))
+#define PUSHPOINTER(x) *(DAINT **)sp = x; sp = (DAINT *) (DAINT **) ((DAINT **)sp + 1)
+//#define PUSHPOINTER(x) *(DAINT **)sp = x; sp = (DAINT *) ((DAINT **)sp + 1)
+#endif
+
+#ifdef NOTPOSIX
+
+/* Can't use --() constructs, must decrement stack pointer manually */
+
+# ifdef POINTER64
+
+# define SAVEINT(x) **((DAINT **)(sp-2)) = x; sp--; sp--
+# define SAVEFLOAT(x) **((DAFLOAT **)(sp-2)) = x; sp--; sp--
+# define SAVEDOUBLE(x) **((DADOUBLE **)(sp-2)) = x; sp--; sp--
+# define FETCHIARRAY(x) x = *(*(((DAINT **)sp)-1) + index); sp--; sp--
+# define FETCHFARRAY(x) x = *(*(((DAFLOAT **)sp)-1) + index); sp--; sp--
+# define FETCHDARRAY(x) x = *(*(((DADOUBLE **)sp)-1) + index); sp--; sp--
+
+# else /* 32 bit pointers */
+
+# define SAVEINT(x) **((DAINT **)(sp-1)) = x; sp--
+# define SAVEFLOAT(x) **((DAFLOAT **)(sp-1)) = x; sp--
+# define SAVEDOUBLE(x) **((DADOUBLE **)(sp-1)) = x; sp--
+# define FETCHIARRAY(x) x = *((DAINT *) *(sp-1) + index); sp--
+# define FETCHFARRAY(x) x = *((DAFLOAT *) *(sp-1) + index); sp--
+# define FETCHDARRAY(x) x = *((DADOUBLE *) *(sp-1) + index); sp--
+
+# endif
+
+#define POPDOUBLE(x) x = *((DADOUBLE *)(sp-2)); sp--; sp--
+#define POPFLOAT(x) x = *((DAFLOAT *)(sp-1)); sp--
+#define POPINT(x) x = *((DAINT *)(sp-1)); sp--
+#define PUSHDOUBLE(x) *((DADOUBLE *)sp) = x; sp++; sp++
+#define PUSHFLOAT(x) *((DAFLOAT *)sp++) = x;
+#define PUSHINT(x) *((DAINT *)sp++) = x;
+
+#else
+
+//# define SAVEINT(x) **(--(DAINT **)sp) = x
+//# define SAVEFLOAT(x) **(--(DAFLOAT **)sp) = x
+//# define SAVEDOUBLE(x) **(--(DADOUBLE **)sp) = x
+# define SAVEINT(x) sp = (DAINT *) (DAINT **) ((DAINT **)sp - 1); **(DAINT **)sp = x
+# define SAVEFLOAT(x) sp = (DAINT *) (DAFLOAT **) ((DAFLOAT **)sp - 1); **(DAFLOAT **)sp = x
+# define SAVEDOUBLE(x) sp = (DAINT *) (DADOUBLE **) ((DADOUBLE **)sp - 1); **(DADOUBLE **)sp = x
+//# define FETCHIARRAY(x) x = (*(*(--(DAINT**)sp) + index));
+//# define FETCHFARRAY(x) x = (*(*(--(DAFLOAT**)sp) + index));
+//# define FETCHDARRAY(x) x = (*(*(--(DADOUBLE**)sp) + index));
+# define FETCHIARRAY(x) sp = (DAINT *) (DAINT **) ((DAINT **)sp - 1); x = *(*(DAINT**)sp + index);
+# define FETCHFARRAY(x) sp = (DAINT *) (DAFLOAT **) ((DAFLOAT **)sp - 1); x = *(*(DAFLOAT**)sp + index);
+# define FETCHDARRAY(x) sp = (DAINT *) (DADOUBLE **) ((DADOUBLE **)sp - 1); x = *(*(DADOUBLE**)sp + index);
+
+#ifdef USEMEMCPY
+
+#define POPDOUBLE(x) ((DADOUBLE *)sp)--; memcpy((void *)&x,(void *)sp,sizeof(DADOUBLE))
+#define POPFLOAT(x) x = *(--(DAFLOAT *)sp)
+#define POPINT(x) x = *(--(DAINT *)sp)
+#define PUSHDOUBLE(x) memcpy(((DADOUBLE *)sp)++,(void *)&x,sizeof(DADOUBLE));
+#define PUSHFLOAT(x) *((DAFLOAT *)sp)++ = x;
+#define PUSHINT(x) *((DAINT *)sp)++ = x;
+
+#else
+
+//#define POPDOUBLE(x) x = *(--(DADOUBLE *)sp)
+#define POPDOUBLE(x) sp = (DAINT *) (DADOUBLE *) ((DADOUBLE *)sp - 1); x = *(DADOUBLE *)sp
+//#define POPFLOAT(x) x = *(--(DAFLOAT *)sp)
+#define POPFLOAT(x) sp = (DAINT *) (DAFLOAT *) ((DAFLOAT *)sp - 1); x = *(DAFLOAT *)sp
+#define POPINT(x) x = *(--(DAINT *)sp)
+//#define PUSHDOUBLE(x) *((DADOUBLE *)sp)++ = x;
+#define PUSHDOUBLE(x) *(DADOUBLE *)sp = x; sp = (DAINT *) (DADOUBLE *) ((DADOUBLE *)sp + 1)
+//#define PUSHFLOAT(x) *((DAFLOAT *)sp)++ = x
+#define PUSHFLOAT(x) *(DAFLOAT *)sp = x; sp = (DAINT *) (DAFLOAT *) ((DAFLOAT *)sp + 1)
+#define PUSHINT(x) *((DAINT *)sp)++ = x
+#endif
+#endif
+
+#define GETNEXTINTP (((DAINT *)pc)++)
+#define GETNEXTFLOATP (((DAFLOAT *)pc)++)
+#define GETNEXTDOUBLEP (((DADOUBLE *)pc)++)
+#define GETNEXTPOINTERP (((DAINT **)pc)++)
+
+thStatus thExecuteCode(char *blockname,CODEPTR code, CODEPTR codelimit)
+{
+#ifdef PHILDEBUG
+#ifdef NOTPOSIX
+#warning Phil says NOTPOSIX!
+#else
+#warning Phil says not NOTPOSIX! i.e. POSIX!!
+#endif
+#ifdef POINTER64
+#warning Phil says POINTER64!
+#else
+#warning Phil says not POINTER64!
+#endif
+#ifdef USEMEMCPY
+#warning Phil says USEMEMCPY!
+#else
+#warning Phil says not USEMEMCPY!
+#endif
+#endif
+ register CODEPTR pc;
+ CODE rawopcode,opcode,ltype,rtype,lrtypes;
+ DAINT nargs,result;
+ register DAINT *sp;
+ DAINT i,il,ir,*pi;
+ DAFLOAT f,fl,fr,*pf;
+ DADOUBLE d,dl,dr,*pd;
+ DAINT index;
+
+ sp = stack;
+ pc = code;
+
+ while(pc < codelimit){
+/* printf("PC=%x, Op code %x, Stack=%x, SP=%x\n",pc,*pc,stack,sp);*/
+ rawopcode = *pc++;
+ if(rawopcode >= OPLP){ /* New style */
+ ltype = (rawopcode & OPLEFTTYPEMASK) >> 8;
+ rtype = (rawopcode & OPRIGHTTYPEMASK) >> 4;
+/* lrtypes = opcode & OPLRTYPEMASK;*/
+ opcode = rawopcode & OPCODEMASK;
+ switch(opcode & OPGROUPMASK)
+ {
+ case OPPUSHGROUP: /* Pushes */
+ switch(opcode)
+ {
+#ifdef USEMEMCPY
+ void *tmpptr;
+#endif
+ case OPPUSHINT: /* Float included in pushes */
+ if((rawopcode & OPRESTYPEMASK) == OPRDOUBLE){
+/* printf("sp=%x, pc=%x\n",sp,pc);*/
+#ifdef USEMEMCPY
+ memcpy((void *)&d,((DADOUBLE *)pc)++,sizeof(DADOUBLE));
+ PUSHDOUBLE(d);
+#else
+#ifdef __sgi
+ PUSHDOUBLE(*((DADOUBLE *)pc)); pc++; pc++;
+#else
+ PUSHDOUBLE(*(DADOUBLE *)pc);/*phil*/
+ pc = (CODEPTR) (DADOUBLE *) ((DADOUBLE *)pc + 1);
+#endif
+#endif
+/* printf("sp=%x, pc=%x\n",sp,pc);*/
+ } else {
+ PUSHINT(*pc++);
+ }
+ break;
+ case OPPUSHPINT: /*Push a pointer*/
+#ifdef USEMEMCPY
+ PUSHPOINTER((memcpy(&tmpptr,(((DAINT **)pc)++),sizeof(void *))
+ ,tmpptr));
+#else
+ PUSHPOINTER(*(DAINT **)pc); /*phil*/
+ pc = (CODEPTR)(DAINT **) ((DAINT **)pc + 1);
+#endif
+ break;
+ case OPPUSHINTP: /*Push what a pointer points to */
+ if((rawopcode & OPRESTYPEMASK) == OPRDOUBLE){
+#ifdef USEMEMCPY
+ memcpy(&tmpptr,(((DAINT **)pc)++),sizeof(void *));
+ d = *(DADOUBLE *) tmpptr;
+#else
+ d = **(DADOUBLE **)pc;/*phil*/
+ pc = (CODEPTR) (DADOUBLE **) ((DADOUBLE **)pc + 1);
+#endif
+ PUSHDOUBLE(d);/*phil*/
+ } else {
+#ifdef USEMEMCPY
+ memcpy(&tmpptr,(((DAINT **)pc)++),sizeof(void *));
+ PUSHINT(*(DAINT *) tmpptr);
+#else
+ PUSHINT(**(DAINT **)pc);/*phil*/
+ pc = (CODEPTR) (DAINT **) ((DAINT **)pc + 1);
+#endif
+ }
+ break;
+ case OPPUSHFUNCTION: /*Push a intrinsic function code */
+ PUSHINT(*pc++);
+ break;
+ }
+ break;
+ case OPEOLGROUP:
+ sp--; /* Should empty the stack */
+ if(rtype == OPRDOUBLE) sp--; /* Double is two entries on stack */
+ break;
+ case OPLINDEXGROUP:
+ if(opcode==OPLFARG) {
+ if(rtype==OPRINT) {POPINT(i);}
+ else if(rtype==OPRFLOAT) {POPFLOAT(f);}/*phil*/
+ else {POPDOUBLE(d);}/*phil*/
+ POPINT(index); /* Pop the function code */
+ switch(index)
+ {
+ case 0: /* abs */
+ if(rtype==OPRINT) {
+ if(i<0) i = -i;
+ PUSHINT(i);
+ } else if(rtype==OPRFLOAT) {
+ if(f<0.0) f = -f;
+ PUSHFLOAT(f);/*phil*/
+ } else {
+ if(d<0.0) d = -d;
+ PUSHDOUBLE(d);/*phil*/
+ }
+ break;
+ case 1: /* sqrt */
+ if(rtype==OPRINT) d = i;
+ else if(rtype==OPRFLOAT) d = f;
+ if(d>=0) d = sqrt(d);
+ else {
+ fprintf(STDERR,"Test block %s: sqrt(%f)\n",blockname,d);
+ d = 0;
+ }
+ PUSHDOUBLE(d);/*phil*/
+ break;
+ case 2: /* exp */
+ if(rtype==OPRINT) d = i;
+ else if(rtype==OPRFLOAT) d = f;
+ d = exp(d);
+ PUSHDOUBLE(d);/*phil*/
+ break;
+ case 3: /* sin */
+ if(rtype==OPRINT) d = i;
+ else if(rtype==OPRFLOAT) d = f;
+ d = sin(d);
+ PUSHDOUBLE(d);/*phil*/
+ break;
+ case 4: /* cos */
+ if(rtype==OPRINT) d = i;
+ else if(rtype==OPRFLOAT) d = f;
+ d = cos(d);
+ PUSHDOUBLE(d);/*phil*/
+ break;
+ case 5: /* tan */
+ if(rtype==OPRINT) d = i;
+ else if(rtype==OPRFLOAT) d = f;
+ d = tan(d);
+ PUSHDOUBLE(d);/*phil*/
+ break;
+ }
+ break;
+ }
+ if(rtype==OPRFLOAT) { /* Floating point index */
+ POPFLOAT(f);/*phil*/
+ index = floatToLong(f);
+ } else if(rtype==OPRDOUBLE) { /* Double */
+ POPDOUBLE(d);/*phil*/
+ index = floatToLong(d);
+ } else {
+ POPINT(index);
+ }
+ index -= ((opcode & 0xF000) == 0x1000 ? 0 : 1);
+ /* ltype should always be == restype */
+ if(opcode == OPLINDEX || opcode == OPLINDEXB){
+ if(ltype == OPRDOUBLE) {
+ FETCHDARRAY(d);/*phil*/
+ PUSHDOUBLE(d);/*phil*/
+ } else if (ltype == OPRFLOAT) {
+ FETCHFARRAY(f);/*phil*/
+ PUSHFLOAT(f);/*phil*/
+ } else {
+ FETCHIARRAY(i);/*phil*/
+ PUSHINT(i);
+ }
+ } else { /*pointer on stack*/
+ sp--;
+#ifdef POINTER64
+ sp--;
+#endif
+ if(ltype == OPRDOUBLE) {
+ /* *((DADOUBLE **)sp)++ = (*((DADOUBLE **)sp)+index);*/
+ /* The following works better on the alpha */
+ pd = *((DADOUBLE **)sp);
+ pd += index;
+ PUSHPOINTER(pd);/*phil*/
+ } else { /* Assume INT and FLOAT the same size */
+ /**((DAINT **)sp)++ = (*((DAINT **)sp)+index);*/
+ /* The following works better on the alpha */
+ pi = *((DAINT **)sp);
+ pi += index;
+ PUSHPOINTER(pi);/*phil*/
+ }
+ }
+ break;
+ case OPEQUAL: /* Big ugly matrix of type conversions */
+ if(rtype==OPRINT) {
+ POPINT(i);
+ if(ltype==OPRINT) {
+ SAVEINT(i); /* Save result in result variable *//*phil*/
+ PUSHINT(i); /* Put result back on stack */
+ } else if(ltype==OPRFLOAT) {
+ f = i; /* Convert to floating */
+ SAVEFLOAT(f); /* Save variable *//*phil*/
+ PUSHFLOAT(f); /* Put back on stack *//*phil*/
+ } else { /* if(ltype==OPRDOUBLE) */
+ d = i;
+ SAVEDOUBLE(d);/*phil*/
+ PUSHDOUBLE(d);/*phil*/
+ }
+ } else if(rtype==OPRFLOAT) {
+ POPFLOAT(f);/*phil*/
+ if(ltype==OPRINT) {
+ i = floatToLong(f);
+ SAVEINT(i); /* Save result in result variable *//*phil*/
+ *sp++ = i;
+ } else if(ltype==OPRFLOAT) {
+ SAVEFLOAT(f); /* Save variable *//*phil*/
+ *sp++ = *(DAINT *)&f;
+ } else { /* if(ltype==OPRDOUBLE) */
+ d = f;
+ SAVEDOUBLE(d);/*phil*/
+ PUSHDOUBLE(d);/*phil*/
+ }
+ } else { /* if(rtype==OPRDOUBLE) */
+ POPDOUBLE(d);/*phil*/
+ if(ltype==OPRINT) {
+ i = floatToLong(d);
+ SAVEINT(i); /* Save result in result variable *//*phil*/
+ *sp++ = i;
+ } else if(ltype==OPRFLOAT) {
+ f = d;
+ SAVEFLOAT(f); /* Save variable *//*phil*/
+ *sp++ = *(DAINT *)&f;
+ } else { /* if(ltype==OPRDOUBLE) */
+ SAVEDOUBLE(d);/*phil*/
+ PUSHDOUBLE(d);/*phil*/
+ }
+ }
+ break;
+ case OPLOGGROUP: /* Logic and Bit operations */
+ case OPSHIFTGROUP: /* Logic and Bit operations */
+ if(rtype==OPRINT) {
+ POPINT(ir);
+ } else if(rtype==OPRFLOAT) {
+ POPFLOAT(f);/*phil*/
+ ir = floatToLong(f);
+ } else {
+ POPDOUBLE(d);/*phil*/
+ ir = floatToLong(d);
+ }
+ if(ltype==OPRINT) {
+ POPINT(il);
+ } else if(ltype==OPRFLOAT) {
+ POPFLOAT(f);/*phil*/
+ il = floatToLong(f);
+ } else {
+ POPDOUBLE(d);/*phil*/
+ il = floatToLong(d);
+ }
+ switch(opcode)
+ {
+ case OPLOGOR:
+ *sp++ = il || ir;
+ break;
+ case OPLOGXOR:
+ *sp++ = (il != 0) ^ (ir != 0);
+ break;
+ case OPLOGAND:
+ *sp++ = il && ir;
+ break;
+ case OPBITOR:
+ *sp++ = il | ir;
+ break;
+ case OPBITXOR:
+ *sp++ = il ^ ir;
+ break;
+ case OPBITAND:
+ *sp++ = il & ir;
+ break;
+ case OPSHL:
+ *sp++ = il << ir;
+ break;
+ case OPSHR:
+ *sp++ = il >> ir;
+ break;
+ }
+ break;
+ case OPCOMPGROUP: /* Logic comparisons */
+/* Result of Add amd MUL groups should now always be double */
+ case OPADDGROUP: /* Add and Subtract */
+ case OPMULGROUP: /* * / and % */
+ if(rtype==OPRINT) {
+ POPINT(ir);
+ dr = ir;
+ } else if (rtype==OPRFLOAT) {
+ POPFLOAT(fr);/*phil*/
+ dr = fr;
+ } else {
+ POPDOUBLE(dr);/*phil*/
+ }
+ if(ltype==OPRINT) {
+ POPINT(il);
+ dl = il;
+ } else if (ltype==OPRFLOAT) {
+ POPFLOAT(fl);/*phil*/
+ dl = fl;
+ } else {
+ POPDOUBLE(dl);/*phil*/
+ }
+ if(rtype!=OPRINT || ltype!=OPRINT){
+ switch(opcode)
+ {
+ case OPISEQUAL:
+ *sp++ = dl == dr;
+ break;
+ case OPISNOTEQUAL:
+ *sp++ = dl != dr;
+ break;
+ case OPISLT:
+ *sp++ = dl < dr;
+ break;
+ case OPISGT:
+ *sp++ = dl > dr;
+ break;
+ case OPISLE:
+ *sp++ = dl <= dr;
+ break;
+ case OPISGE:
+ *sp++ = dl >= dr;
+ break;
+ case OPADD:
+ d = dl + dr;
+ PUSHDOUBLE(d);/*phil*/
+ break;
+ case OPSUB:
+ d = dl - dr;
+ PUSHDOUBLE(d);/*phil*/
+ break;
+ case OPTIMES:
+ d = dl * dr; /* Need to deal with overflow */
+ PUSHDOUBLE(d);/*phil*/
+ break;
+ case OPIDIV:
+/* printf("OP=%x\n",rawopcode);*/
+ if(dr == 0.0) {
+ fprintf(STDERR,"Test block %s: %f/0.0\n",blockname,dl);
+ d = 0.0;
+ } else {
+ d = dl / dr; /* Need to deal with overflow and div 0 */
+ }
+ *sp++ = floatToLong(d);
+ break;
+ case OPDIV:
+ if(dr == 0.0) {
+ fprintf(STDERR,"Test block %s: %f/0.0\n",blockname,dl);
+ d = 0.0;
+ } else {
+ d = dl / dr; /* Need to deal with overflow and div 0 */
+ }
+ PUSHDOUBLE(d);/*phil*/
+ break;
+ case OPMOD:
+ d = fmod(dl,dr);
+ PUSHDOUBLE(d);/*phil*/
+ break;
+ }
+ } else { /* Both left and right are int */
+ switch(opcode)
+ {
+ case OPISEQUAL:
+ *sp++ = il == ir;
+ break;
+ case OPISNOTEQUAL:
+ *sp++ = il != ir;
+ break;
+ case OPISLT:
+ *sp++ = il < ir;
+ break;
+ case OPISGT:
+ *sp++ = il > ir;
+ break;
+ case OPISLE:
+ *sp++ = il <= ir;
+ break;
+ case OPISGE:
+ *sp++ = il >= ir;
+ break;
+ case OPADD:
+ *sp++ = il + ir;
+ break;
+ case OPSUB:
+ *sp++ = il - ir;
+ break;
+ case OPTIMES:
+ *sp++ = il * ir; /* Need to deal with overflow */
+ break;
+ case OPIDIV:
+/* printf("At OPIDIV all int branch\n");*/
+ if(ir == 0) {
+ fprintf(STDERR,"Test block %s: %d/0.0\n",blockname,il);
+ *sp++ = 0;
+ } else {
+ *sp++ = il / ir;
+ }
+ break;
+ case OPDIV:
+ if(ir == 0) {
+ fprintf(STDERR,"Test block %s: %d/0.0\n",blockname,il);
+ d = 0.0;
+ } else
+ d = dl / dr; /* Need to deal with overflow and div 0 */
+ PUSHDOUBLE(d);/*phil*/
+ break;
+ case OPMOD:
+ *sp++ = il % ir; /* Need to deal with overflow and div 0 */
+ break;
+ }
+ }
+ break;
+ case OPUNARY: /* Unary Operators */
+ switch(opcode)
+ {
+ case OPNEG:
+ if(rtype==OPRINT) {
+ i = -(*--sp);
+ *sp++ = i;
+ } else if (rtype==OPRFLOAT) {
+ f = *(DAFLOAT *)(--sp);
+ f = -f;
+ *sp++ = *(DAINT *)&f;
+ } else {
+ POPDOUBLE(d);/*phil*/
+ d = -d;
+ PUSHDOUBLE(d);/*phil*/
+ }
+ break;
+ case OPNOT:
+ case OPCOMP:
+ if(rtype==OPRINT) {
+ POPINT(i);
+ } else if(rtype==OPRFLOAT) {
+ POPFLOAT(f);/*phil*/
+ i = floatToLong(f);
+ } else {
+ POPDOUBLE(d);/*phil*/
+ i = floatToLong(d);
+ }
+ i = (opcode == OPNOT ? !i : ~i);
+ *sp++ = i;
+ break;
+ }
+ break;
+ default:
+ fprintf(STDERR,"Test block %s: Operator %x not yet implimented\n",
+ blockname,opcode);
+ break;
+ } /* Terminates switch */
+ } else { /* terminates if(rawopcode >=OPLP) *//* Old Style, May not work anymore */
+ switch(*pc++)
+ {
+ case PUSHI:
+ *sp++ = *pc++;
+ break;
+ case PUSHS:
+ *sp++ = *((DAINT *) *pc++);
+ pc++; /* Skip variable name */
+ break;
+ case PUSHFTOIS:
+ *sp++ = floatToLong(*((DAFLOAT *) *pc++));
+ pc++; /* Skip variable name */
+ break;
+ case PUSHITOFS:
+ *sp++ = *(DAINT *)&f;
+ pc++; /* Skip variable name */
+ break;
+ case POPS:
+ *((int *) *pc++) = *--sp;
+/* printf("Putting result %d into %s\n",*sp,(char *) *pc);*/
+ pc++; /* Skip variable name */
+ break;
+ case tGATE:
+ nargs = *pc++;
+/* printf("GATE: nargs=%d\n",nargs);*/
+ result = ((*((DAFLOAT *) sp-3) >= *((DAFLOAT *) sp-2))
+ && (*((DAFLOAT *) sp-1) > *((DAFLOAT *) sp-3)));
+ sp -= nargs;
+ *sp++ = result;
+ break;
+ case tEQ:
+ nargs = *pc++;
+ result = (*(sp-1) == *(sp-2));
+ sp -= nargs;
+ *sp++ = result;
+ break;
+ case tAND:
+ result = 1;
+ for(nargs = *pc++;(nargs > 0) && result; nargs--){
+ result = (*(--sp)) != 0;
+ }
+ sp -= nargs;
+ *sp++ = result;
+ break;
+ case tIOR:
+ result = 0;
+ for(nargs = *pc++;(nargs > 0) && !result; nargs--){
+ result = (*(--sp)) != 0;
+ }
+ sp -= nargs;
+ *sp++ = result;
+ break;
+ default:
+ fprintf(STDERR,"Test block %s: Opcode %d not defined\n",
+ blockname,*(pc-1));
+ }
+/* printf("Stack depth %d\n",sp-stack);*/
+ }
+ }
+ if(sp != stack){
+ fprintf(STDERR,"\n");
+ fprintf(STDERR,"Original SP %x\n",stack);
+ fprintf(STDERR,"\n\n\n\n");
+ fprintf(STDERR,"Final SP %x\n",sp);
+ fprintf(STDERR,"Items left on stack = %d\n",sp-stack);
+ return(S_FAILURE);
+ }
+ return(S_SUCCESS);
+}
diff --git a/CTP/thTestParse.c b/CTP/thTestParse.c
new file mode 100644
index 0000000..4a627c8
--- /dev/null
+++ b/CTP/thTestParse.c
@@ -0,0 +1,1159 @@
+/*-----------------------------------------------------------------------------
+ * Copyright (c) 1993 Southeastern Universities Research Association,
+ * Continuous Electron Beam Accelerator Facility
+ *
+ * This software was developed under a United States Government license
+ * described in the NOTICE file included as part of this distribution.
+ *
+ * Stephen A. Wood, 12000 Jefferson Ave., Newport News, VA 23606
+ * Email: saw@cebaf.gov Tel: (804) 249-7367 Fax: (804) 249-5800
+ *-----------------------------------------------------------------------------
+ *
+ * Description:
+ * The expression parser and stack executor for the Test Package
+ *
+ * Author: Stephen Wood, CEBAF Hall C
+ *
+ * Revision History:
+ * $Log: thTestParse.c,v $
+ * Revision 1.4.24.1.2.1 2011/03/03 20:09:44 jones
+ * Used to be %li and %ld, but that makes 8 byte result stuffed into 4 byte *tokval
+ *
+ * Revision 1.4.24.1 2007/09/10 21:32:47 pcarter
+ * Implemented changes to allow compilation on RHEL 3,4,5 and MacOSX
+ *
+ * Revision 1.4 2003/02/21 20:55:25 saw
+ * Clean up some types and casts to reduce compiler warnings.
+ *
+ * Revision 1.3 1999/11/04 20:34:07 saw
+ * Alpha compatibility.
+ * New RPC call needed for root event display.
+ * Start of code to write ROOT trees (ntuples) from new "tree" block
+ *
+ * Revision 1.19 1999/08/25 13:16:07 saw
+ * *** empty log message ***
+ *
+ * Revision 1.18 1999/07/07 13:43:51 saw
+ * Don't make numbers starting with "0" be octal. Accept 0x as hex.
+ *
+ * Move thTestRHandler() into thTestParse.c
+ *
+ * Revision 1.17 1999/03/01 20:00:50 saw
+ * Fix bug where a series of numbers added or subtracted in a parameter line
+ * got evaluated to be just the first number. Improve the scientific
+ * number detection to do this.
+ *
+ * Revision 1.16 1996/07/31 20:36:56 saw
+ * Support floating point for mod command. Add trig functions.
+ *
+ * Revision 1.15 1995/08/03 13:56:36 saw
+ * Add single argument functions
+ *
+ * Revision 1.14 1995/04/10 15:51:21 saw
+ * thEvalImed returns INTOVF if double result is to large to convert to int.
+ *
+ * Revision 1.13 1995/02/14 16:53:52 saw
+ * Make compatible with OSF/Alpha (64 bit pointers)
+ *
+ * Revision 1.12 1995/01/09 16:06:11 saw
+ * Fix a short malloc for a string
+ *
+ * Revision 1.11 1994/11/17 18:14:21 saw
+ * Strip out unary + operators when parsing expressions
+ *
+ * Revision 1.10 1994/11/07 14:28:34 saw
+ * Add thevalchk fortran call to check for expressions.
+ * Try to avoid bomb outs for bad expressions
+ *
+ * Revision 1.9 1994/10/03 12:41:22 saw
+ * All "/" (division) has real result. New op "//" has integerized
+ * result. thEvalImed actually gets a double from thTestExecute.
+ * Added fortran interfaces to thEvalImed (itheval, ftheval, dtheval).
+ *
+ * Revision 1.8 1994/09/12 15:12:31 saw
+ * thGetTok was missing reset of lastop on EOL
+ *
+ * Revision 1.7 1994/08/29 20:08:10 saw
+ * Fix calculation of testscalervarname length
+ *
+ * Revision 1.6 1994/08/26 17:46:18 saw
+ * Register test scaler results
+ *
+ * Revision 1.5 1994/08/26 13:36:46 saw
+ * Add DAVAR_REPOINTOK to some flags
+ *
+ * Revision 1.4 1994/06/03 18:54:29 saw
+ * Replace stderr with STDERR
+ *
+ * Revision 1.3 1993/12/02 21:33:36 saw
+ * Fully allow use of doubles in test expressions
+ *
+ * Revision 1.2 1993/11/24 21:24:54 saw
+ * thEvalImed now returns double instead of floating result.
+ *
+ * Revision 1.3 1993/09/22 17:51:06 saw
+ * Allow integer constants to be octal or hex.
+ *
+ * Revision 1.2 1993/05/11 18:00:10 saw
+ * Update header
+ *
+ */
+
+/* thTestParse.c
+
+ Make test result variable that are created take the type of the rhs???
+ Add variable names to stack so that expressions can be recreated.
+ Allow constants to be hex or octal.
+ Agree on a new comment character or syntax since ! is not part
+ of expressions.
+ Add unary operators to executor. Allow + to be a unary operator too.
+
+ Need to build up a linked list of test results used in a block. Don't
+ duplicate any variables. Print warning when a scaler test result is
+ reused.
+
+*/
+/*An argument is a variable name, an array, or a number. Numbers are not
+allowed for test result. Arrays start at 0 if []'s are used and start
+at 1 if ()'s are used. Arrays may only be used for test results if they
+are already registered by the analyzer. (May add option to declare them
+in the test package.)*/
+
+#include <stdio.h>
+#include <string.h>
+#include <math.h>
+
+#define INT_MAX 2147483647
+/* limits.h is used only to get #define INT_MAX 2147483647
+ * If you don't have limits.h, try #include <values.h> instead and then
+ * #define INT_MAX MAXINT */
+//#include <limits.h>
+
+#include <rpc/rpc.h>
+#include "daVar.h"
+#include "daVarRpc.h"
+#include "daVarHandlers.h"
+#include "th.h"
+#include "thUtils.h"
+#include "thTestParse.h"
+#include "thInternal.h"
+#include "cfortran.h"
+
+daVarStatus thTestRHandler(char *name, daVarStruct *varclass, any *retval);
+
+CODE opstack[100]; /* Operator stack */
+CODE typstack[100]; /* Result type stack */
+
+typedef struct
+{
+ char *ops;
+ int toks[3];
+} OPTABLE;
+
+OPTABLE optable[] =
+{
+ {"(",{OPLP}},
+ {")",{OPRP}},
+ {"[",{OPLINDEXB}},
+ {"]",{OPRP}},
+ {"-",{OPSUB}},
+ {"+",{OPADD}},
+ {"<<=",{OPISLT,OPSHL,OPISLE}},
+ {">>=",{OPISGT,OPSHR,OPISGE}},
+ {"==",{OPEQUAL,OPISEQUAL}},
+ {"!=",{OPNOT,OPISNOTEQUAL}},
+ {"&&",{OPBITAND,OPLOGAND}},
+ {"||",{OPBITOR,OPLOGOR}},
+ {"^^",{OPBITXOR,OPLOGXOR}},
+ {"*",{OPTIMES}},
+ {"//",{OPDIV,OPIDIV}},
+ {"%",{OPMOD}},
+ {"~",{OPCOMP}},
+ {",",{OPCOMMA}},
+ {0,{0,0,0}}};
+static char *opchars=0;
+
+/* For Q like test package format, must be in same order as type
+ types listed in typedef for thTestType. */
+char *testCodes[tBAD]
+ = {"GA","PA","EQ","BI","AN","IO","EO","MA","US"};
+
+typedef struct
+{
+ CODE op;
+ CODE result[9];
+} TYPETABLE;
+
+TYPETABLE typetable[] =
+{
+ {OPLINDEX,{0,0,0,1,1,1,2,2,2}}, /* Result is same as variable */
+ {OPLINDEXB,{0,0,0,1,1,1,2,2,2}}, /* being indexed */
+ {OPLINDEXP,{0,0,0,1,1,1,2,2,2}}, /* Result is same as variable */
+ {OPLINDEXPB,{0,0,0,1,1,1,2,2,2}}, /* being indexed */
+ {OPEQUAL,{0,0,0,1,1,1,2,2,2}}, /* Set result type to LHS type */
+ {OPLOGOR,{0,0,0,0,0,0,0,0,0}}, /* Result is always integer */
+ {OPLOGXOR,{0,0,0,0,0,0,0,0,0}},
+ {OPLOGAND,{0,0,0,0,0,0,0,0,0}},
+ {OPBITOR,{0,0,0,0,0,0,0,0,0}},
+ {OPBITXOR,{0,0,0,0,0,0,0,0,0}},
+ {OPBITAND,{0,0,0,0,0,0,0,0,0}},
+ {OPISEQUAL,{0,0,0,0,0,0,0,0,0}},
+ {OPISNOTEQUAL,{0,0,0,0,0,0,0,0,0}},
+ {OPISLT,{0,0,0,0,0,0,0,0,0}},
+ {OPISLE,{0,0,0,0,0,0,0,0,0}},
+ {OPISGT,{0,0,0,0,0,0,0,0,0}},
+ {OPISGE,{0,0,0,0,0,0,0,0,0}},
+ {OPSHL,{0,0,0,0,0,0,0,0,0}},
+ {OPSHR,{0,0,0,0,0,0,0,0,0}},
+ {OPADD,{0,2,2,2,2,2,2,2,2}}, /* Result is double unless both ops int */
+ {OPSUB,{0,2,2,2,2,2,2,2,2}},
+ {OPTIMES,{0,2,2,2,2,2,2,2,2}},
+ {OPDIV,{2,2,2,2,2,2,2,2,2}}, /* Result always double */
+ {OPIDIV,{0,0,0,0,0,0,0,0,0}}, /* Result always integer */
+ {OPMOD,{0,2,2,2,2,2,2,2,2}},
+ {OPNEG,{0,1,2,0,1,2,0,1,2}}, /* No lh operand, type = rh type */
+ {OPNOT,{0,0,0,0,0,0,0,0,0}}, /* No lh operand, type always int */
+ {OPCOMP,{0,0,0,0,0,0,0,0,0}}, /* No lh operand, type always int */
+ {0,{0,0,0,0,0,0,0,0,0}}};
+
+INTRINSIC_FUNCTIONS intrinsic_functions[] =
+{
+ {"abs",{0,1,2}},
+ {"sqrt",{2,2,2}},
+ {"exp",{2,2,2}},
+ {"sin",{2,2,2}},
+ {"cos",{2,2,2}},
+ {"tan",{2,2,2}},
+ {0,{0,0,0}}
+};
+char *thGetTok(char *linep, int *tokenid, char **tokstr,
+ CODE *tokval, void **tokptr, int expflag, daVarStructList **vlisthead)
+/* Pass a pointer to the unscanned portion of the line.
+ Returns An ID code for operators, and an operand type for operands in
+ tokenid.
+ Returns the string for the operand in tokstr. (Null otherwise)
+ Returns the operand value in tokval, or in tokptr if the operand is
+ a pointer.
+ If the operand is a function, then tokenid will be pushfunction, and
+ tokval will be a the fuction id.
+
+ Function returns pointer to remainder of the line.
+
+
+ */
+{
+ static char string[100];
+ static int lasttoktype=0; /* Last tok was an operator */
+ static CODE lastop=0;
+
+ char *savelinep;
+ char *stringp;
+ char *ptr,c;
+ int tindex,sindex;
+ daVarStruct *varp;
+ DAFLOAT f;
+
+ /* Build up a list of characters that can start operators */
+ if(opchars == 0){
+ int count=0;
+ int i;
+
+ while(optable[count++].ops != 0) ;
+ opchars = (char *) malloc(count);
+ for(i=0;i<(count-1); i++)
+ opchars[i] = optable[i].ops[0];
+ opchars[count-1] = 0;
+ }
+
+ *tokstr = 0;
+ *tokval = 0;
+ *tokptr = 0;
+ *tokenid = 0; /* Will signify an undeclared operand */
+
+ if(!(*linep)) {
+ *tokenid = OPEOL;
+ lasttoktype = 0;
+ lastop = 0;
+ return(0);
+ }
+ savelinep = linep;
+ while(*linep == ' ' || *linep == '\t') linep++;
+ if((ptr = strchr(opchars,*linep))) { /* Operator */
+ tindex = ptr - opchars;
+ if(lasttoktype == 0 && *linep == '-') { /* Last thing was an operator */
+ *tokenid = OPNEG; /* So the '-' must be a negative sign */
+ linep++;
+ } else if(lasttoktype == 0 && *linep == '+') { /* Unary plus */
+ linep++;
+ goto operand;
+ } else if(lasttoktype == 1 && *linep == '(') {
+ *tokenid = OPLINDEX;
+ linep++;
+ } else if(lasttoktype == 3 && *linep == '(') {
+ /* How will we know when the right hand operator is the closing
+ paren of the function? We don't need to know. The RHP only
+ acts to determine precedence. */
+ *tokenid = OPLFARG;
+ linep++;
+ } else {
+ linep++;
+ *tokenid = optable[tindex].toks[0];
+ sindex = 1;
+ if(*linep) { /* Don't search past end of line */
+ while((c = optable[tindex].ops[sindex])) {
+ if(*linep == c) {
+ *tokenid = optable[tindex].toks[sindex];
+ linep++;
+ break;
+ }
+ sindex++;
+ }
+ }
+ }
+ /* Following two lines were before last }. */
+ if(*tokenid == OPRP) lasttoktype = 2; /* Minus is minus after ) or ] */
+ else lasttoktype = 0;
+ /* For OPLINDEX and OPLINDEXB, need to search ahead for matching ) or ]
+ and check if the next operator is an = not ==). If so, then we
+ need to return OPLINDEXP or OPLINDEXPB. */
+ if(*tokenid == OPLINDEX || *tokenid == OPLINDEXB){
+ char *p; char rc; int ccount=0; int bcount=0;
+ if(*tokenid == OPLINDEXB) rc = ']';
+ else rc = ')';
+ p = linep;
+ while(*p && (*p != rc || bcount || ccount)) {
+ switch(*p++)
+ {
+ case '(': ccount++; break;
+ case ')': ccount--; break;
+ case '[': bcount++; break;
+ case ']': bcount--; break;
+ default: break;
+ }
+ } /* Only NULL or balanced rc terminates */
+ if(*p++){ /* Search for = */
+ while(*p == ' ' || *p=='\t') p++;
+ if(*p == '=' && *(p+1) != '=') {
+ *tokenid += (OPLINDEXP - OPLINDEX);
+ /* Assumes OPLINDEXBP-OPLINDEXB is the same*/
+ }
+ } else
+ fprintf(STDERR,"thTest: Parenthesis balance problem\n");
+ }
+ lastop = *tokenid;
+ } else { /* Operand */
+ // int optype;
+ int isnum;
+ int efound;
+
+ operand:
+ lasttoktype = 1;
+ stringp = string;
+ /* Scan until operator or whitespace is reached */
+ isnum = 1; efound = 0;
+/* What a hack to check for scientific notation */
+ while(*linep && *linep!=' ' && *linep!='\t' && !strchr(opchars,*linep)){
+ if(*linep == 'e' || *linep == 'E') {
+ if(efound) {
+ isnum = 0;
+ } else {
+ if(stringp > string) {
+ efound=1;
+ } else {
+ isnum = 0;
+ }
+ }
+ } else if(!isdigit(*linep) && *linep != '.') isnum = 0;
+ *stringp++ = *linep++;
+ }
+ if(isnum && efound) { /* Exponential, scan past last digit */
+ if(*linep == '-' || *linep == '+') *stringp++ = *linep++;
+ while(isdigit(*linep)) {
+ *stringp++ = *linep++;
+ }
+ }
+ while(*linep == ' ' || *linep == '\t') linep++; /* Skip past whitespace */
+ *stringp = 0;
+ *tokstr = string;
+/* printf("token=%s\n",string);*/
+ switch(thIDToken(string))
+ {
+ case TOKINT:
+ /* Used to be %li and %ld, but that makes 8 byte result stuffed into
+ 4 byte *tokval */
+ if(string[0] == '0' && (string[1] == 'x' || string[1] == 'X')) {
+ sscanf(string,"%i",tokval); /* Treat as Hex */
+ } else {
+ sscanf(string,"%d",tokval); /* Treat as decimal */
+ }
+ *tokenid = OPPUSHINT;
+ break;
+ case TOKFLOAT:
+ f = atof(string);
+ *tokval = *(DAINT *)&f; /* Copy floating value */
+ *tokenid = OPPUSHFLOAT;
+ break;
+ case TOKVAR:
+ {
+ char **classlist;
+ thOperandType optype;
+
+ optype = thGetOperandType(string,linep,lastop,0);
+ classlist = thGetClassList(optype);
+ /* Probably should consistently use the same class list of
+ TEST,EVENT,PARM here */
+/* If token is a result variable (and we are in non-immediate mode), and the
+ variable is an integer type, then we need to add this variable to a list
+ of variables for the current block. (Probably add real variable to
+ the list anyway. ) This will allow us to acumulate scalers. The opaque
+ pointer of each variable in the list will point to the scaler array. */
+
+ /* First check if variable is really an intrinsic function */
+ {
+ int ifunc;
+ ifunc = 0;
+ while(intrinsic_functions[ifunc].name) {
+ if(strcasecmp(string,intrinsic_functions[ifunc].name)==0) {
+ *tokenid = OPPUSHFUNCTION;
+ *tokval = ifunc;
+ lasttoktype = 3;
+ break;
+ }
+ ifunc++;
+ }
+ if(*tokenid) break; /* Hopefully this breaks out of case */
+ }
+ if(daVarLookupPWithClass(string,classlist,&varp) == S_SUCCESS) {
+/* printf("Found variable %s[%s]\n",string,varp->name);*/
+ if(varp->type == DAVARFLOAT) {/* If next operator is a ( or [ */
+/* printf("FLOAT ");*/
+ /* then push pointer instead of */
+#define ISARRAYORLHS(x) (*x=='(' || *x=='[' || (*x=='=' && *(x+1)!='='))
+ *tokenid = ISARRAYORLHS(linep) ? OPPUSHPFLOAT : OPPUSHFLOATP;
+ } else if(varp->type == DAVARDOUBLE){ /* value onto rpn stack */
+/* printf("DOUBL ");*/
+ *tokenid = ISARRAYORLHS(linep) ? OPPUSHPDOUBLE : OPPUSHDOUBLEP;
+ } else if(varp->type == DAVARINT){ /* value onto rpn stack */
+/* printf("INT ");*/
+ *tokenid = ISARRAYORLHS(linep) ? OPPUSHPINT : OPPUSHINTP;
+ }
+ else {
+ fprintf(STDERR
+ ,"thTest: Variable %s[%s] must be integer, float or double\n"
+ ,string,varp->name);
+ }
+/* *tokval = *(DAINT *)&varp->varptr;*/ /* Get the pointer */
+ *tokptr = varp->varptr;
+ } else if(*linep=='=' && (*(linep+1)!='=')){
+ /* Undefined variable is an unindexed result */
+ /* For now, create an integer variable. Later figure out how
+ to make the variable the same type as the rhs */
+ daVarStruct var;
+ var.name = (char *) malloc(strlen(classlist[0])
+ +strlen(string)+2);
+ strcpy(var.name,classlist[0]);
+ strcat(var.name,".");
+ strcat(var.name,string);
+ var.varptr = (void *) malloc(sizeof(DAINT));
+ var.size = 1;
+ var.opaque = 0;
+ var.rhook = 0;
+ var.whook = 0;
+ var.type = DAVARINT;
+ var.flag = DAVAR_READONLY | DAVAR_REPOINTOK;
+ var.title = savelinep;
+ daVarRegister((int) 0,&var); /* Create test result */
+ daVarLookupP(var.name,&varp);
+ free(var.name);
+printf("Created test result %s\n",varp->name);
+ *tokenid = OPPUSHPINT;
+/* *tokval = *(DAINT *)&varp->varptr;*/
+ *tokptr = varp->varptr;
+ } /* else
+ printf("%s not found\n",string);
+ }*/
+ /* If variable does not exist, caller will note that toktype and
+ tokval have not been set. */
+ if(optype == otRESULT && vlisthead){ /* Don't make scalers for */
+ thAddVarToList(vlisthead,varp); /* Variables created in */
+ if(varp->type == DAVARINT) { /* thEvalImed */
+ DAINT *sarray; int i;
+ if(varp->opaque == 0) { /* No scaler array yet */
+ char *testscalervarname;
+ daVarStruct *svarp; /* Pointer to scaler var struct */
+ testscalervarname = /* Add the "scaler" attribute */
+ (char *) malloc(strlen(varp->name)+strlen(SCALERSTR)+2);
+ strcpy(testscalervarname,varp->name);
+ strcat(testscalervarname,".");
+ strcat(testscalervarname,SCALERSTR);
+ if(daVarLookupP(testscalervarname,&svarp) != S_SUCCESS) {
+ daVarStruct svar;
+ svar.name = testscalervarname;
+ svar.opaque = 0;
+ svar.rhook = 0;
+ svar.whook = 0;
+ svar.type = DAVARINT;
+ svar.flag = DAVAR_READONLY | DAVAR_REPOINTOK;
+ svar.varptr = (void *) malloc(varp->size*sizeof(DAINT));
+ svar.size = varp->size;
+ /* Actually not OK to repoint, but this says CTP made it */
+ svar.title = varp->name;
+ daVarRegister((int) 0, &svar);
+ daVarLookupP(svar.name,&svarp);
+ }
+ varp->opaque = (DAINT *) svarp->varptr;
+ varp->rhook = thTestRHandler;
+ free(testscalervarname);
+ }
+ sarray = varp->opaque;
+ for(i=0;i<varp->size;i++)
+ sarray[i] = 0;
+ }
+ }
+ }
+ break;
+ default:
+ fprintf(STDERR,"thTest: Error understanding %s\n",string);
+ break;
+ }
+/* printf("token = %x\n",*tokenid);*/
+ lastop = 0;
+ }
+ while(*linep == ' ' || *linep == '\t') linep++; /* Skip whitespace */
+ return(linep);
+}
+
+
+char **thGetClassList(thOperandType optype)
+{
+ static char *explist[]={PARMSTR,EVENTSTR,TESTSTR,0}; /* Immediate expressions */
+ static char *loglist[]={TESTSTR,PARMSTR,EVENTSTR,0}; /* Logical operand */
+ static char *numlist[]={EVENTSTR,PARMSTR,TESTSTR,0}; /* Operand is a value */
+ static char *resultlistp[]={TESTSTR,EVENTSTR,PARMSTR,0}; /* Operand is a result */
+
+#define ALWAYSTESTFIRST
+#ifdef ALWAYSTESTFIRST
+ return(resultlistp);
+#else
+ switch(optype)
+ {
+ case otIMMED:
+ return(explist);
+ case otLOGIC:
+ return(loglist);
+ case otVALUE:
+ return(numlist);
+ case otRESULT:
+ return(resultlistp);
+ }
+#endif
+}
+
+thOperandType thGetOperandType(char *soperand, char *rest, CODE lastop,
+ int expflag)
+{
+ if(expflag)
+ return(otIMMED);
+ else if(lastop == OPNOT)
+ return(otLOGIC);
+ else if(lastop != 0 && (lastop != OPLOGOR)
+ && (lastop != OPLOGAND) && (lastop != OPLOGXOR)
+ && (lastop != OPEQUAL) && (lastop != OPCOMMA)
+ && (lastop != OPLP))
+ return(otVALUE);
+ else {
+ /* This is really ugly code to determine if the operand
+ is a result, logical operand, or numerical operand from the
+ surrounding operators. The last operator is known, but it must
+ search ahead for the next operator. This code should be burried
+ in a subroutine. */
+
+ char *p;
+ p = rest;
+ if(*p == '(' || *p == '[') {
+ int ccount=0; int bcount=0;
+ if(*p++ == '(') ccount++; else bcount++;
+ while(*p && (bcount || ccount)){
+ /* printf("%c(%d,%d)\n",*p,ccount,bcount);*/
+ switch(*p++) {
+ case '(': ccount++; break; case ')': ccount--; break;
+ case '[': bcount++; break; case ']': bcount--; break;
+ default: break;
+ }
+ }
+ /* printf("pos=%c, %d %d ",*p,ccount,bcount);*/
+ }
+ while(*p == ' ' || *p =='\t') p++;
+#define ISLOG(x,y) (*x==y && *(x+1)==y)
+ /* printf(", Nextchar=%c: ",*p);*/
+ if(*p=='=' && *(p+1)!='=') {
+ return(otRESULT);
+ } else if((ISLOG(p,'|') || ISLOG(p,'&') || ISLOG(p,'^')
+ || *p=='\0' || *p==',' || *p == ')'))
+ return(otLOGIC);
+ }
+ return(otVALUE);
+}
+
+CODE thGetResultType(CODE operator, CODE leftoptype, CODE rightoptype)
+{
+ /* For a given operator, determine the data type of the result a given
+ combination of the types of the lh and rh operands.
+ Assumes that only types 0, 1, or 2 are allowed. */
+
+ int lrindex;
+ int i;
+
+ if(leftoptype < 0 || leftoptype > 2 || rightoptype < 0 || rightoptype > 2) {
+ fprintf(STDERR,"thTest: Illegal operand type %x %x\n",leftoptype,rightoptype);
+ return(0);
+ }
+ lrindex = (leftoptype * 3) + rightoptype;
+ for(i=0; typetable[i].op; i++) { /* Do Linear search for the operator */
+ if(operator == typetable[i].op) {
+ return(typetable[i].result[lrindex]);
+ }
+ }
+ fprintf(STDERR,"Operator %x not found in result type table\n",operator);
+ return(0);
+}
+
+thStatus thEvalImed(char *line, DADOUBLE *d, DAINT *i)
+/* ImmedOBiately evaluate the expression in line. Will internally evaluate to
+ a float, and then pass back both the float and interized values. */
+{
+ CODEPTR codehead, codenext, codelimit, codelastop;
+ int codesize;
+#define RDOUBLE
+#ifdef RDOUBLE
+ double result;
+#else
+ float result; /* Should change to double */
+#endif
+ thStatus retcode;
+
+/* printf("%s=",line);*/
+ codesize = 10+2*strlen(line);
+ codehead = codenext = (CODEPTR) malloc(sizeof(CODE)*codesize);
+ codelimit = codehead + codesize;
+#ifdef RDOUBLE
+ *codenext++ = OPPUSHPDOUBLE;
+#ifdef USEMEMCPY
+ {
+ void *resultp;
+ resultp = &result;
+ memcpy(((void **)codenext)++, (void *) &resultp, sizeof(void *));
+ }
+#else
+ *((void **) codenext) = (void *) &result; /*phil*/
+ codenext = (CODEPTR) (void **) ((void **)codenext +1);
+#endif
+/* printf("%x\n",codenext);*/
+#else
+ *codenext++ = OPPUSHPFLOAT; /* Should change to double */
+ *((void **) codenext)++ = (void *) &result;
+#endif
+ retcode = S_SUCCESS;
+ if(thBookaTest(line,&codehead,&codenext,&codelimit,&codelastop,0)!=S_SUCCESS) {
+ fprintf(STDERR,"Failure interpreting expression |%s|\n",line);
+ result = 0.0;
+ retcode = S_FAILURE;
+ } else {
+ int exptype;
+ CODE lastop;
+#if 0
+ printf("%x-%x=%d\n",codenext,codehead,codenext-codehead);
+ {
+ CODEPTR code;
+ for(code=codehead;code < codenext; code++)
+ if(code==codelastop) printf("* %x\n",*code);
+ else printf(" %x\n",*code);
+ }
+#endif
+ codenext = codelastop;
+ exptype = *codenext++ & OPRESTYPEMASK;
+ lastop = *codelastop & OPCODEMASK;
+ if(lastop == OPPUSHPINT || lastop == OPPUSHINTP) {
+ codenext = (CODEPTR) (DAINT **) ((DAINT **)codenext + 1);/*phil*/
+ } else if(lastop == OPPUSHINT) {
+ if(exptype == OPRDOUBLE) {
+ codenext = (CODEPTR) (DADOUBLE **) ((DADOUBLE **)codenext + 1);/*phil*/
+ } else { /* Assume ints, floats have size */
+ codenext = (CODEPTR) (DAINT *) ((DAINT *)codenext + 1);/*phil*/
+ }
+ }
+#ifdef RDOUBLE
+ *codenext++ = OPEQUAL | 0x202 | (exptype<<4);
+#else
+ *codenext++ = OPEQUAL | 0x101 | (exptype<<4);
+#endif
+#ifdef RDOUBLE
+ *codenext++ = OPEOL | (OPRDOUBLE<<4);
+#else
+ *codenext++ = OPEOL;
+#endif
+ if(thExecuteCode("IMMED",codehead,codenext)!=S_SUCCESS){
+ fprintf(STDERR,"Failure evaluating expression |%s|\n",line);
+ result = 0.0;
+ retcode = S_FAILURE;
+ }
+ }
+/* printf("%f\n",result);*/
+ free(codehead);
+ if(d) *d = result;
+ if(i) {
+ if(result>=INT_MAX || result <=-INT_MAX) {
+ if(retcode==S_SUCCESS)
+ retcode=S_INTOVF;
+ } else {
+ *i = floatToLong(result);
+ }
+ }
+ return(retcode);
+}
+
+thStatus thBookaTest(char *line, CODEPTR *codeheadp, CODEPTR *codenextp,
+ CODEPTR *codelimitp, CODEPTR *codelastop, daVarStructList **vlisthead)
+/* if expflag != 0, still treat as an expression even if there is no
+ equal sign in the line.
+ Return codes:
+ S_SUCCESS = Line OK
+ S_FAILURE = Line not executable
+*/
+{
+ /* int type;*/
+ char *args[20];
+ int nargs;
+ thTokenType toktyp;
+ daVarStruct var, *varp;
+ thTestType test_type;
+ int forcefloat;
+ int iarg;
+ char *token;
+ CODEPTR codenext;
+ int index; /* Used for index into arrays */
+ thStatus status;
+ int expflag;
+
+ if(codelastop) expflag = 1; else expflag = 0;
+ status = S_SUCCESS;
+ if(*codenextp + 2*strlen(line) > *codelimitp) {
+ CODEPTR src,dst,newhead;
+ int newsize;
+/* printf("Increasing the size of the code stack from %d ",
+ *codelimitp-*codeheadp);*/
+ src = *codeheadp;
+ newsize = max((*codelimitp-*codeheadp)+CODEGROWSIZE
+ ,(*codenextp-*codeheadp)+2*strlen(line));
+ newhead = dst = (CODEPTR) malloc(sizeof(CODE)*newsize);
+ while(src < *codenextp) *dst++ = *src++;
+ if(*codeheadp) free(*codeheadp);
+ *codelimitp = newhead + newsize;
+ *codeheadp = newhead;
+ *codenextp = *codenextp + (dst - src);
+
+ /*printf("to %d, using %d\n",*codelimitp-*codeheadp,*codenextp - *codeheadp);*/
+ }
+ codenext = *codenextp;
+
+/* printf("Booking \"%s\"\n",line);*/
+ if(strchr(line,'=')||expflag) {
+ char *linep;
+ int TOKEN,TOKCOMP;
+ char *tokstr; CODE tokval;
+ void *tokptr;
+ CODE *osp, *tsp, opcode;
+ CODE rightoptype,leftoptype,resultoptype;
+
+ osp = opstack; /* Stack of pending operators */
+ *osp = '\0';
+
+ tsp = typstack; /* Stack of Current result type */
+ /* Like the stack in the executor but only */
+ /* contains the data types */
+ linep = line;
+ do {
+ /* Get tokens until there are no more (last token will be OPEOL) */
+ linep = thGetTok(linep,&TOKEN, &tokstr, &tokval, &tokptr, expflag, vlisthead);
+ if(tokstr) { /* Operand */
+/* printf("Operand %s |",tokstr);*/
+ if(codelastop) *codelastop = codenext; /* HACK for thImmed: Save ptr to last operator */
+ if(TOKEN) {
+ if(tokptr == 0) { /* Value operand - 4 bytes */
+ *codenext++ = TOKEN; /* String not put on stack at moment */
+ *codenext++ = tokval;
+ } else { /* Pointer operand - maybe 8 bytes */
+ *codenext++ = TOKEN;
+#ifdef USEMEMCPY
+ memcpy(((void **)codenext)++,&tokptr,sizeof(void *));
+#else
+ *(void **)codenext = tokptr;/*phil*/
+ codenext = (CODEPTR) (void **) ((void **)codenext +1);
+#endif
+ }
+ /* If TOKEN is push function, then tokval is an index into a list of
+ functions. We put this index on tsp instead of the result type. */
+ if(TOKEN==OPPUSHFUNCTION) {
+ *tsp++ = tokval;
+ } else {
+ *tsp++ = TOKEN & OPRESTYPEMASK;
+ }
+ } else {
+ fprintf(STDERR,"thTest: Unregistered variable %s\n",tokstr);
+ status = S_TH_UNREG;
+ *codenext++ = OPPUSHINT;
+ *codenext++ = 0;
+ *tsp++ = OPPUSHINT & OPRESTYPEMASK;
+ }
+ } else { /* Operator */
+ switch(TOKEN)
+ {
+ case 0:
+ fprintf(STDERR,"thTest: Bad token\n");
+ return(S_FAILURE);
+ break;
+ case OPLP:
+ *++osp = TOKEN;
+ break;
+ default:
+/* printf("OSP:");
+ {CODE *sp; for(sp=opstack;sp<=osp;sp++)
+ printf("%x:",*sp);}
+ printf("\n");
+*/
+ /* Generate code for all operators of equal or higher precedence
+ that are pending on the operator stack. */
+ if((TOKEN & OPGROUPMASK) == OPLINDEXGROUP)
+ TOKCOMP = 0xFFFFFFF; /* Nothing higher in precedence */
+ else
+ TOKCOMP = TOKEN & OPPRECMASK;
+ while((*osp & OPPRECMASK) >= TOKCOMP){
+/* if((*osp & OPPRECMASK) == OPLINDEX){*/
+ if((*osp & OPGROUPMASK) == OPLINDEXGROUP){
+ if(TOKEN == OPRP) {
+ if(*osp == OPLFARG) TOKEN = OPRFARG;
+ else TOKEN = OPRINDEX; /* Break from case */
+ }
+ TOKCOMP = 0xFFFFFFF; /* Terminate osp rundown */
+ }
+ rightoptype = *--tsp;
+ leftoptype = ((*osp & OPPRECMASK) == OPUNARY) ? 0 : (*--tsp);
+ /* If the Operator is "evaluate function", we need to find out
+ what the function is so that we can get the correct
+ result type. leftoptype should be an index into
+ "intrinsic_functions". We can use that and rightoptype
+ to look up the resulttype. */
+ if(*osp==OPLFARG) {
+ resultoptype =
+ intrinsic_functions[leftoptype].result[rightoptype];
+ } else {
+ resultoptype = thGetResultType(*osp,leftoptype,rightoptype);
+ }
+ opcode = *osp--;
+ opcode |= (leftoptype << 8) | (rightoptype << 4)
+ | resultoptype;
+ if(codelastop) if((opcode&&OPCODEMASK) !=OPEOL) *codelastop = codenext; /* HACK for thImmed: Save ptr to last operator */
+ *codenext++ = opcode;
+ *tsp++ = resultoptype; /* Keep a rpn stack of the data type */
+ }
+ if(TOKEN == OPRINDEX || TOKEN == OPRFARG) break; /* No clean up needed */
+
+ if(TOKEN == OPRP) {
+ if(*osp == OPLP) osp--; /* ) removes matching ( */
+ else {
+ fprintf(STDERR,"Right paren not matched by left\n");
+ return(S_FAILURE);
+ }
+ } else if(TOKEN == OPEOL || TOKEN == OPCOMMA) {
+ if(codelastop) if(TOKEN==OPCOMMA) *codelastop = codenext; /* HACK for thImmed: Save ptr to last operator */
+ *codenext++ = TOKEN | (*--tsp) << 4; /* Leave type in Right type field */
+ } else {
+ *++osp = TOKEN;
+ }
+ break;
+ }
+ }
+ /* Token processed */
+ } while (linep);
+/* Check that stacks are OK. Need to add some clean up of allocated memory. */
+ if(tsp != typstack) {
+ fprintf(STDERR,"%d items left on type stack\n",tsp-typstack);
+ return(S_FAILURE);
+ }
+ if(osp != opstack) {
+ fprintf(STDERR,"%d items left on operand stack\n",osp-opstack);
+ return(S_FAILURE);
+ }
+ } else { /* Old style test lines */
+ int i;
+ nargs = thCommas(line,args);
+ for(i=0;i<nargs;i++){
+ args[i] = thSpaceStrip(args[i]); /* Remove all space from the argument */
+ }
+
+ if(nargs <= 1) return(S_FAILURE);
+
+ { /* Interpret the test type. */
+
+ for(test_type=0;test_type<tBAD;test_type++){
+ if(testCodes[test_type][0] == toupper(args[1][0]) &&
+ testCodes[test_type][1] == toupper(args[1][1])) break;
+ }
+ if(test_type == tBAD) return(S_FAILURE);
+ /* printf("%s\n",testCodes[test_type]);*/
+ }
+ if(test_type == tGATE || test_type == tEQ) {
+ forcefloat = 1;
+ } else forcefloat = 0;
+ for(iarg=2;iarg<nargs;iarg++){
+ DAFLOAT f; /* Should do double here */
+ token = args[iarg];
+ toktyp = thIDToken(token);
+ switch((toktyp = thIDToken(token)))
+ {
+ case TOKINT:
+ *codenext++ = PUSHI;
+ if(forcefloat) {
+ f = atof(token);
+ *codenext++ = *(DAINT *)&f;
+ } else {
+ DAINT i;
+ /* Used to be %li and %ld, but that makes 8 byte result
+ stuffed into 4 byte i */
+ if(token[0] == '0' && (token[1] == 'x' || token[1] == 'X')) {
+ sscanf(token,"%i",&i); /* Treat as Hex */
+ } else {
+ sscanf(token,"%d",&i); /* Treat as decimal */
+ }
+ *codenext++ = i;
+ }
+ break;
+ case TOKFLOAT: /* Should Do all floats as doubles */
+ *codenext++ = PUSHI;
+ if(forcefloat) {
+ f = atof(token);
+ *codenext++ = *(DAINT *)&f;
+ } else {
+ *codenext++ = (DAINT) floatToLong(atof(token));
+ }
+ break;
+ case TOKARRAY:
+ case TOKVAR:
+ {
+ char *p; int index; char leftp;
+ if(toktyp == TOKARRAY) {
+ p = thTokenArray(token,&index);
+ leftp = *p; *p = 0; /* Save ( or [ then null terminate */
+ } else
+ index = 0;
+ if(daVarLookup(token,&var)!=S_SUCCESS) {
+ fprintf(STDERR,"(thTest) %s not registered\n",token);
+ *codenext++ = PUSHI;
+ if(forcefloat) {
+ f = 0.0;
+ *codenext++ = *(DAINT *)&f;
+ } else
+ *codenext++ = 0;
+ } else {
+ if(forcefloat)
+ if(var.type == DAVARINT)
+ *codenext++ = PUSHITOFS; /* Push converting to float and skip */
+ else if(var.type == DAVARFLOAT)
+ *codenext++ = PUSHS;
+ else
+ *codenext++ = PUSHI; /* Push immediate */
+ else
+ if(var.type == DAVARINT)
+ *codenext++ = PUSHS; /* Push and skip */
+ else if(var.type == DAVARFLOAT)
+ *codenext++ = PUSHFTOIS;
+ else
+ *codenext++ = PUSHI; /* Push immediate */
+ if(toktyp == TOKARRAY)
+ *p = leftp;
+ if(var.type == DAVARINT || var.type == DAVARFLOAT) {
+ *(void **)codenext = ((DAINT *) var.varptr+index);/*phil*/
+ codenext = (CODEPTR) (void **) ((void **)codenext + 1);
+ *((void **)codenext) = (void *) malloc(sizeof(token)+1);
+ strcpy((char *) *(void **)codenext,token);
+ codenext = (CODEPTR) (void **) ((void **)codenext + 1);
+ } else {
+ if(forcefloat) {
+ f = 0.0;
+ *codenext++ = *(DAINT *)&f;
+ } else
+ *codenext++ = 0;
+ }
+ }
+ }
+ break;
+ }
+ }
+ *codenext++ = test_type; /* Operation to do on pushed args */
+ *codenext++ = nargs-2; /* # of args pushed on stack for this op */
+
+ /* Now push test result on stack */
+ *codenext++ = POPS;
+
+ token = args[0];
+ toktyp = thIDToken(token);
+ index = 0;
+ switch((toktyp = thIDToken(token)))
+ {
+ case TOKINT:
+ case TOKFLOAT:
+ fprintf(STDERR,"(thTest) Test result must be a variable name\n");
+ return(S_FAILURE); /* No test is added to program */
+ case TOKARRAY:
+ /* First check if variable with index has been already registered
+ perhaps from a previous booking of histograms */
+ if(daVarLookup(token,&var) != S_SUCCESS){
+ char *p; char leftp;
+ p = thTokenArray(token,&index);
+ leftp = *p; *p = 0; /* Save ( or [ then null terminate */
+ if(daVarLookup(token,&var) != S_SUCCESS){
+ fprintf(STDERR,
+ "(thTest) Arrays %s must be registered\n",token);
+ return(S_FAILURE);
+ }
+ *p = leftp; /* Restore the left ( or [ */
+ if(index >= var.size) {
+ fprintf(STDERR,
+ "(thTest) Array size for %s exceeded\n",token);
+ return(S_FAILURE);
+ }
+ if(var.type != DAVARINT) {
+ fprintf(STDERR,
+ "(thTest) Array %s must be of integer*4\n",token);
+ return(S_FAILURE);
+ }
+ var.varptr = (DAINT *) var.varptr + index;
+ var.name = token;
+ var.opaque = 0;
+ }
+ var.title = token; /* Eventually be the input line */
+ break;
+ case TOKVAR:
+ if(daVarLookup(token,&var)!=S_SUCCESS) {
+ var.name = token;
+ var.varptr = (void *) malloc(sizeof(DAINT));
+ var.opaque = 0;
+ var.rhook = 0;
+ var.whook = 0;
+ var.type = DAVARINT;
+ var.flag = DAVAR_READONLY | DAVAR_REPOINTOK;
+/* Do I need to set the size to 1 here??? */
+ }
+ var.title = token;
+ break;
+ }
+ daVarRegister((int) 0, &var); /* Create or replace variable */
+ *(void **)codenext = ((DAINT *) var.varptr);/*phil*/
+ codenext = (CODEPTR) (void **) ((void **)codenext + 1);
+ /* Save the token string for future reference */
+ *((void **)codenext) = ((void *) malloc(strlen(token)+1));
+ strcpy((char *) *(void **)codenext,token);
+ codenext = (CODEPTR) (void **) ((void **)codenext + 1);
+ }
+ *codenextp = codenext;
+ return(status);
+
+}
+int thevalchk_(char *A1,unsigned C1)
+/* Check if an expression is valid. Return's zero if valid */
+{
+ int A0;
+ char *B1;
+ thStatus status;
+
+ status = thEvalImed((!*(int *)A1)?0:memchr(A1,'\0',C1)?A1:
+ (memcpy(B1=malloc(C1+1),A1,C1),B1[C1]='\0'
+ ,kill_trailing(B1,' ')),0,0);
+ if(B1) free(B1);
+ return(status);
+}
+
+int itheval_(char *A1,unsigned C1)
+{
+ int A0;
+ char *B1;
+ DAINT i;
+ double d;
+ thStatus status;
+
+ status = thEvalImed((!*(int *)A1)?0:memchr(A1,'\0',C1)?A1:
+ (memcpy(B1=malloc(C1+1),A1,C1),B1[C1]='\0'
+ ,kill_trailing(B1,' ')),0,&i);
+ if(B1) free(B1);
+ return i;
+}
+double dtheval_(char *A1,unsigned C1)
+{
+ char *B1;
+ double d;
+ thStatus status;
+
+ status = thEvalImed((!*(int *)A1)?0:memchr(A1,'\0',C1)?A1:
+ (memcpy(B1=malloc(C1+1),A1,C1),B1[C1]='\0'
+ ,kill_trailing(B1,' ')),&d,0);
+ if(B1) free(B1);
+ return d;
+}
+float ftheval_(char *A1,unsigned C1)
+{
+ char *B1;
+ DAINT i;
+ double d;
+ float f;
+ thStatus status;
+
+ status = thEvalImed((!*(int *)A1)?0:memchr(A1,'\0',C1)?A1:
+ (memcpy(B1=malloc(C1+1),A1,C1),B1[C1]='\0'
+ ,kill_trailing(B1,' ')),&d,0);
+ if(B1) free(B1);
+ f = d;
+ return f;
+}
+
+daVarStatus thTestRHandler(char *name, daVarStruct *varclass, any *retval)
+/* The default Read handler */
+{
+ daVarStruct *varp;
+ char *attribute;
+ daVarStatus status;
+ int index;
+
+ status = daVarAttributeFind(name, varclass, &varp, &attribute, &index);
+ status = daVarRegRatr(varp, attribute, index, retval);
+ if(status == S_SUCCESS) {
+ if(strcasecmp(attribute,DAVAR_RATR) == 0){
+ retval->any_u.s = realloc(retval->any_u.s,strlen(retval->any_u.s)
+ +strlen(TH_SCALER) + 2);
+ strcat(retval->any_u.s,TH_SCALER);
+ strcat(retval->any_u.s,"\n");
+ }
+ } else {
+ if(strcasecmp(attribute,TH_SCALER) == 0){
+ int i;
+ if(varp->opaque){
+ retval->valtype = DAVARINT_RPC;
+ if(index == DAVAR_NOINDEX) {
+ retval->any_u.i.i_len = varp->size;
+ retval->any_u.i.i_val = (int *) malloc(varp->size*sizeof(int));
+ for(i=0;i<varp->size;i++) {
+ retval->any_u.i.i_val[i] = ((DAINT *)varp->opaque)[i];
+ }
+ } else {
+ retval->any_u.i.i_len = 1;
+ retval->any_u.i.i_val = (int *) malloc(sizeof(int));
+ retval->any_u.i.i_val[0] = ((DAINT *)varp->opaque)[index];
+ }
+ } else {
+ retval->valtype = DAVARERROR_RPC;
+ retval->any_u.error = S_SUCCESS;
+ }
+ }
+ }
+ /* A special handler would check more attributes if status != SUCCESS */
+ return(status);
+}
diff --git a/CTP/thTestParse.h b/CTP/thTestParse.h
new file mode 100644
index 0000000..ed73479
--- /dev/null
+++ b/CTP/thTestParse.h
@@ -0,0 +1,168 @@
+/*
+ * Revision History:
+ * $Log: thTestParse.h,v $
+ * Revision 1.1 1998/12/07 22:11:13 saw
+ * Initial setup
+ *
+ * Revision 1.6 1995/08/03 14:37:13 saw
+ * Add single argument functions
+ *
+ * Revision 1.5 1995/04/25 17:46:52 saw
+ * Make compatible with OSF/Alpha (64 bit pointers)
+ *
+ * Revision 1.4 1994/11/07 14:38:43 saw
+ * Add integer divide operator
+ *
+ * Revision 1.3 1994/07/21 20:52:33 saw
+ * Add Revision history
+ *
+ */
+#ifndef _TH_TESTPARSE_H
+#define _TH_TESTPARSE_H
+
+#ifndef _TH_UTILS_H
+#include "thUtils.h"
+#endif
+
+/* thTestParse.h
+ Header file for thTestParse.c and thTestExecute.c
+ */
+
+#define max(a,b) (a<b ? b : a)
+#define min(a,b) (a>b ? b : a)
+
+#ifndef NULL
+#define NULL ((void *)0)
+#endif
+
+#define CODEGROWSIZE 250
+#define CODESTARTSIZE 2500
+typedef DAINT CODE;
+typedef CODE * CODEPTR;
+
+
+
+/* Operand types */
+
+/* Hex charcter meanings
+ H7 H6 H5 H4 H3 H2 H1 H0
+ H7 Groups instructions together for execution convenience
+ H7 H6 H5 Operator precidence ordering
+ H4 H3 Operator code within precidence group
+ H2 Type of Left operand
+ H1 Type of Right operand
+ H0 Type of the result
+
+*/
+/* Operand types */
+#define OPRINT 0
+#define OPRFLOAT 1
+#define OPRDOUBLE 2
+/* Operators */
+#define OPPUSHGROUP 0x0000000
+#define OPPUSHINT 0x0800000
+#define OPPUSHFLOAT 0x0800001
+#define OPPUSHDOUBLE 0x0800002
+/* Next word is a pointer, push the value pointed to onto rpn stack */
+#define OPPUSHINTP 0x0810000
+#define OPPUSHFLOATP 0x0810001
+#define OPPUSHDOUBLEP 0x0810002
+/* Next word is a pointer, push the pointer onto the rpn stack */
+#define OPPUSHPINT 0x0820000
+#define OPPUSHPFLOAT 0x0820001
+#define OPPUSHPDOUBLE 0x0820002
+/* Next word is a index into a function table */
+#define OPPUSHFUNCTION 0x0830000
+/* Parenthesis operators */
+#define OPLP 0x0100000
+#define OPRP 0x0900000
+#define OPRINDEX 0x0901000
+#define OPRFARG 0x0B01000
+#define OPLINDEXGROUP 0x1000000
+#define OPLINDEX 0x1A00000
+/* Fortran mode index */
+#define OPLINDEXB 0x1A01000
+/* These operators leave the pointer instead of the value on the stack */
+/* They are used for the first indexing ( or [ before the = */
+#define OPLINDEXP 0x1A10000
+/* Fortran mode index */
+#define OPLINDEXPB 0x1A11000
+/* Function operator. Is this the right place in precidence scheme? */
+#define OPLFARG 0x1B00000
+#define OPEOLGROUP 0x2000000
+#define OPEOL 0x2E00000
+#define OPCOMMA 0x2F00000
+
+#define OPEQUAL 0x4000000
+
+#define OPLOGGROUP 0x8000000
+#define OPLOGOR 0x8300000
+#define OPLOGXOR 0x8400000
+#define OPLOGAND 0x8500000
+#define OPBITOR 0x8600000
+#define OPBITXOR 0x8700000
+#define OPBITAND 0x8800000
+
+#define OPCOMPGROUP 0xA000000
+#define OPISEQUAL 0xA900000
+#define OPISNOTEQUAL 0xA901000
+#define OPISLT 0xAA00000
+#define OPISLE 0xAA01000
+#define OPISGT 0xAA02000
+#define OPISGE 0xAA03000
+
+#define OPSHIFTGROUP 0xB000000
+#define OPSHL 0xBB00000
+#define OPSHR 0xBB01000
+
+#define OPADDGROUP 0xC000000
+#define OPADD 0xC000000
+#define OPSUB 0xC001000
+
+#define OPMULGROUP 0xD000000
+#define OPTIMES 0xD000000
+#define OPDIV 0xD001000
+#define OPIDIV 0xD002000
+#define OPMOD 0xD003000
+
+#define OPUNARY 0xE000000
+#define OPNEG 0xE000000
+#define OPNOT 0xE001000
+#define OPCOMP 0xE002000
+
+#define OPGROUPMASK 0xF000000
+#define OPPRECMASK 0xFF00000
+#define OPCODEMASK 0xFFFF000
+
+#define OPLEFTTYPEMASK 0x0000F00
+#define OPRIGHTTYPEMASK 0x00000F0
+#define OPLRTYPEMASK 0x0000FF0
+#define OPRESTYPEMASK 0x000000F
+
+/* For Q like test package format */
+typedef enum {
+ tGATE, tPAT, tEQ, tBIT, tAND, tIOR, tXOR, tMAJ, tUSER, tBAD,
+ PUSHI, PUSHITOFS, PUSHS, PUSHFTOIS, POPS
+ } thTestType;
+
+/* Operand types deduced from context */
+typedef enum {
+ otIMMED, otLOGIC, otVALUE, otRESULT} thOperandType;
+
+typedef struct
+{
+ char *name;
+ CODE result[3];
+} INTRINSIC_FUNCTIONS;
+
+char *thGetTok(char *linep,int *tokenid, char **tokstr, CODE *tokval,
+ void **tokptr, int expflag, daVarStructList **vlisthead);
+thStatus thBookaTest(char *line, CODEPTR *codeheadp, CODEPTR *codenextp,
+ CODEPTR *codelimitp, CODEPTR *codelastop,
+ daVarStructList **vlisthead);
+thStatus thExecuteCode(char *blockname, CODEPTR code, CODEPTR codelimit);
+thOperandType thGetOperandType(char *soperand, char *rest, CODE lastop,
+ int expflag);
+char **thGetClassList(thOperandType optype);
+
+#endif
diff --git a/CTP/thTree.c b/CTP/thTree.c
new file mode 100644
index 0000000..bde9ee9
--- /dev/null
+++ b/CTP/thTree.c
@@ -0,0 +1,562 @@
+/*-----------------------------------------------------------------------------
+ * Copyright (c) 1999 Thomas Jefferson National Accelerator Facility
+ *
+ * This software was developed under a United States Government license
+ * described in the NOTICE file included as part of this distribution.
+ *
+ * Stephen A. Wood, 12000 Jefferson Ave., Newport News, VA 23606
+ * Email: saw@jlab.org Tel: (758) 269-7367 Fax: (757) 269-5235
+ *-----------------------------------------------------------------------------
+ *
+ * Description:
+ * Book ROOT trees.
+ *
+ * Author: Stephen Wood, CEBAF Hall C
+ *
+ * Revision History:
+ * $Log: thTree.c,v $
+ * Revision 1.6.6.1 2007/09/10 21:32:47 pcarter
+ * Implemented changes to allow compilation on RHEL 3,4,5 and MacOSX
+ *
+ * Revision 1.6 2005/02/22 16:54:46 saw
+ * Clean up some diagnostic printfs
+ *
+ * Revision 1.5 2004/07/09 20:44:11 saw
+ * Can now put a test on a tree block
+ *
+ *
+ * Revision 1.1.16.2 2004/07/09 20:41:50 saw
+ * Can now put a test on a tree block
+ *
+ * Revision 1.1.16.1 2004/07/09 14:12:11 saw
+ * Add ability for CTP to make ROOT Trees
+ *
+ * Revision 1.4 2004/07/08 20:07:00 saw
+ * Supply dummy routines when ROOTSYS not defined
+ *
+ * Revision 1.3 2004/07/07 18:16:30 saw
+ * Use properly exported names from thRootStuff.cpp
+ *
+ * Revision 1.2 2004/07/02 18:46:29 saw
+ * Update ugly cpp routine for gcc 3.2.3. Need to find a better way to
+ * reference C++ routines.
+ *
+ * Revision 1.1 2002/07/31 20:07:48 saw
+ * Add files for ROOT Trees
+ *
+ * Revision 1.1 1999/08/25 13:16:07 saw
+ * *** empty log message ***
+ *
+ */
+
+#include <stdio.h>
+#include <stdlib.h>
+#include <string.h>
+#include <math.h>
+#include "daVar.h"
+#include "th.h"
+#include "thInternal.h"
+#include "thUtils.h"
+
+#ifdef ROOTTREE
+extern daVarStatus thTreeRHandler();
+
+struct thLeafList { /* Variable and index list */
+ struct thLeafList *next;
+ char *name;
+ int leafsize; /* Number of bytes in leaf */
+ char leaftype; /* Single letter with leaf type */
+ daVarStruct *varp; int index;
+};
+typedef struct thLeafList thLeafList;
+
+struct thTreeBranchList {
+ struct thTreeBranchList *next;
+ char *branchname; /* Block name without the "block.hist" */
+ void *evstruct; /* Event structure to fill with data */
+ struct thLeafList *leaflistp;
+};
+typedef struct thTreeBranchList thTreeBranchList;
+
+struct thTreeOpaque { /* Opaque structure for histogram definition */
+ void *file;
+ /* void *file Need to point to structure that has file info. File structures will also
+ be on a linked list so that we a new file is opened, you can see if it exists. Wait, we
+should just use davars. Make a new class for files? ?
+ */
+ void *treeptr; /* Pointer to tree object */
+ daVarStruct *test; int testindex;
+ thTreeBranchList *branchlistP;
+};
+typedef struct thTreeOpaque thTreeOpaque;
+
+struct thRBlockList {
+ struct thRBlockList *next;
+ char *blockname; /* Block name without the "block.tree" */
+ daVarStruct *var; /* Varptr points to # times called
+ Title is code from file.
+ opaque is pointer to hist speclist */
+};
+typedef struct thRBlockList thRBlockList;
+
+thRBlockList *thRBlockListP; /* Pointer to list of tree blocks */
+
+thStatus thBookaBranch(thTreeOpaque *tree, char *line, thTreeBranchList **thBranchNext);
+ /*thStatus thExecuteaHist(thHistSpecList *Hist);*/
+thStatus thRemoveTree(char *block_name);
+
+thStatus thBookTree(daVarStruct *var)
+{
+ char *lines,*eol;
+ int line_count;
+ thTreeBranchList **thBranchNext;
+ char *blockname;
+ thTreeOpaque *treedef;
+ int i;
+ int isopen;
+ char *lbuf=0;
+
+ /* thHistZeroLastId(); */
+
+ /* printf("In booktrees\n");*/
+ /* Get the name without the block.test on it */
+ blockname = var->name; /* If name doesn't fit pattern, use whole */
+ if(strcasestr(var->name,BLOCKSTR)==var->name){
+ i = strlen(BLOCKSTR) + 1;
+ if(strcasestr((var->name + i),TREESTR)==(var->name + i)){
+ i += strlen(TREESTR);
+ if(*(var->name + i) == '.'){
+ blockname += i + 1;
+ }
+ }
+ }
+
+ /*printf("Booking tree %s\n",blockname);*/
+
+ if(var->opaque) thRemoveTree(blockname);
+
+ /* We assume for now that thRemoveTree completely removed the opaque definition)
+ */
+ treedef = var->opaque = (thTreeOpaque *) malloc(sizeof(thTreeOpaque));
+ thBranchNext = (thTreeBranchList **) &treedef->branchlistP;
+
+ lines = var->title;
+ line_count = 0;
+ isopen = 0;
+ while(*lines){
+ char *lcopy;
+
+ line_count++;
+ eol = strchr(lines,'\n');
+ if(!eol) {
+ fprintf(stderr,"L %d: Last line of hist block %s has no newline\n"
+ ,line_count,var->name);
+ break;
+ }
+ if(*(eol+1)=='\0'){ /* This is the last line */
+ if(strcasestr(lines,ENDSTR) == 0)
+ fprintf(stderr,"L %d: Last line of tree block %s is not an END\n"
+ ,line_count,var->name);
+ break;
+ }
+ if(line_count == 1) {
+ char *fname=0;
+ if(strcasestr(lines,BEGINSTR) !=0) {
+ char *p;
+ if(p = strcasestr(lines,"file=")) {
+ p += 5;
+ /* If " or ', grab to next matching char */
+ /* other interpret as variable. But interpret as file if variable not found */
+ if(*p == QUOTECHAR1 || *p == QUOTECHAR2) {
+ char *s; int len;
+ s = p+1;
+ while(*s && *s != *p && *s !='\n') s++;
+ len = (s - p) - 1;
+ fname = malloc(len+1);
+ strncpy(fname,p+1,len);
+ fname[len] = '\0';
+ } else { /* Probably a variable */
+ char *varname=0; char *s; int len; int index;
+ daVarStruct *varp;
+ s = p;
+ while(*s && !isspace(*s) && *s !='\n') s++;
+ len = (s-p);
+ varname = malloc(len+1);
+ strncpy(varname,p,len);
+ varname[len] = '\0';
+ if(thVarResolve(varname,&varp,&index,1,0)==S_SUCCESS) {
+ /*printf("%s,type=%d, size=%d\n",varp->name,varp->type,varp->size);*/
+ if(varp->type == DAVARSTRING) {
+ fname = malloc(strlen((char *)varp->varptr)+1);
+ strcpy(fname,(char *)varp->varptr);
+ } else if(varp->type == DAVARFSTRING) {
+ fname = malloc(varp->size+1);
+ strncpy(fname,(char *)varp->varptr,varp->size);
+ fname[varp->size] = '\0';
+ p = fname;
+ while(*p && !isspace(*p)) p++;
+ *p = '\0'; /* Null terminate at first blank */
+ }
+ /*printf("|%s|\n", fname);*/
+ }
+ if(!fname) {
+ fname = malloc(len+1);
+ strncpy(fname,p,len);
+ fname[len] = '\0';
+ }
+ }
+ }
+ if(p = strcasestr(lines,"test=")) {
+ /* RHS must be a variable */
+ char *varname=0; char *s; int len, testindex;
+ daVarStruct *testp;
+ p += 5;
+ s = p;
+ while(*s && !isspace(*s) && *s !='\n') s++;
+ len = (s-p);
+ varname = (char *) malloc(len+1);
+ strncpy(varname,p,len);
+ varname[len] = '\0';
+ if(thVarResolve(varname,&testp,&testindex,1,0) != S_SUCCESS) {
+ return(S_FAILURE); /* Test flag not registered */
+ /* ASAP we must change this to register variables as they are needed */
+ /* If the variable exists, then we also must check to make sure that
+ the requested index does not exceed the size of the array.
+ a new thVarResolve should also increase the size of the array if
+ it was created by CTP */
+ }
+ treedef->test = testp;
+ treedef->testindex = testindex;
+ } else {
+ treedef->test = 0; /* No test, always true */
+ }
+ }
+
+ if(fname) {
+ printf("Opening Root file %s\n",fname);
+ treedef->file = (void *) thRoot_TFile(fname);
+ free(fname);
+ } else {
+ /*printf("Opening Root file %s\n","ctp.tree");*/
+ treedef->file = (void *) thRoot_TFile("ctp.root");
+ }
+
+ /*printf("Call to TTree(\"%s\",\"title\") goes here\n",blockname);*/
+ treedef->treeptr = (void *) thRoot_TTree(blockname);
+
+ if(strcasestr(lines,BEGINSTR) != 0){
+ /* printf("Is a begin\n");*/
+ lines = eol + 1;
+ continue;
+ } else
+ fprintf(stderr,"First line of tree block %s is not a BEGIN\n",var->name);
+ }
+ /* Ready to book the line, Add continuation lines later */
+ lcopy = (char *) malloc(eol-lines+1);
+ strncpy(lcopy,lines,(eol-lines));
+ *(lcopy + (eol-lines)) = '\0';
+ if(!thCleanLine(lcopy)){
+ if(strchr(lcopy,'=')) { /* Start of a new branch */
+ if(lbuf) { /* Do we have a pending branch */
+ /*printf("Passing 1 |%s|\n",lbuf);*/
+ if(thBookaBranch(treedef,lbuf,thBranchNext)==S_SUCCESS){
+ thBranchNext = &((*thBranchNext)->next);
+ } else {
+ fprintf(stderr,"(%s): Tree booking error in line %d\n",var->name,line_count);
+ }
+ free(lbuf);
+ lbuf = 0;
+ }
+ }
+ if(lbuf) { /* Append */
+ char *lastcomma;
+ char *firstcomma;
+ int addcomma=0;
+ lastcomma = lbuf + strlen(lbuf) - 1;
+ while(*lastcomma == ' ') lastcomma--;
+ if(*lastcomma != ',' && *lastcomma != '=') lastcomma = 0;
+ firstcomma = lcopy;
+ while(*firstcomma == ' ') firstcomma++;
+ if(*firstcomma != ',') firstcomma = 0;
+ if(firstcomma && lastcomma) {
+ *firstcomma = ' ';
+ } else if (!firstcomma && !lastcomma) {
+ addcomma = 1;
+ }
+ lbuf = realloc(lbuf,strlen(lbuf) + strlen(lcopy) + 2);
+ if(addcomma) strcat(lbuf,",");
+ strcat(lbuf,lcopy);
+ } else { /* Make new lbuf */
+ lbuf = malloc(strlen(lcopy)+1);
+ strcpy(lbuf,lcopy);
+ }
+ }
+ free(lcopy);
+ lines = eol+1;
+ }
+ if(lbuf) { /* Do the last branch we were building */
+ /*printf("Passing 2 |%s|\n",lbuf);*/
+ if(thBookaBranch(treedef,lbuf,thBranchNext)==S_SUCCESS){
+ thBranchNext = &((*thBranchNext)->next);
+ } else {
+ fprintf(stderr,"(%s): Tree booking error in line %d\n",var->name,line_count);
+ }
+ free(lbuf);
+ }
+ /* Update internal table of trees. */
+ {
+ thRBlockList *thisblock,*nextblock,**lastblockp;
+ nextblock = thRBlockListP;
+ lastblockp = &thRBlockListP;
+ thisblock = thRBlockListP;
+ while(thisblock){
+ if((strcasecmp(thisblock->var->name,var->name)) == 0){
+ /* Replacing a block with a new definition */
+ fprintf(stderr,"Replacing %s with new definition\n",var->name);
+ if(thisblock->var != var){
+ fprintf(stderr,"ERR: Same name, different var pointer\n");
+ }
+ break;
+ }
+ lastblockp = &thisblock->next;
+ thisblock = thisblock->next;
+ }
+ if(!thisblock){ /* Create entry for New block */
+ *lastblockp = thisblock = (thRBlockList *) malloc(sizeof(thRBlockList));
+ thisblock->var = var;
+ thisblock->next = (thRBlockList *) NULL;
+ thisblock->blockname = (char *) malloc(strlen(blockname) + 1);
+ strcpy(thisblock->blockname,blockname);
+ }
+ }
+ /*printf("Returning from booking a tree\n");*/
+ return(S_SUCCESS);
+}
+
+thStatus thBookaBranch(thTreeOpaque *treedef, char *line, thTreeBranchList **thBranchNext)
+ /* Interpret a branch def of the form branch=leaf1,leaf2,leaf3,... */
+ /* For now require the "branch=" part */
+{
+
+ /* char *long_title;*/
+ int n,nleafs;
+ int lenbrancharg;
+ char *brancharg;
+ char *sleafs,*branchname;
+ thTreeBranchList *Branch;
+ thLeafList **LeafNext;
+ thLeafList *thisleaf;
+ daVarStruct *varp;
+ int vind;
+ char *args[100];
+
+ /*printf("In thBookaBranch\n");*/
+ if(!(sleafs = strchr(line,'='))) {
+ return(S_FAILURE);
+ }
+ *sleafs=0;
+ sleafs++; /* Pointer to list of leaves */
+ nleafs = thCommas(sleafs,args);
+ if(nleafs <=0) {
+ return(S_FAILURE);
+ }
+ Branch = *thBranchNext = (thTreeBranchList *) malloc(sizeof(thTreeBranchList));
+ Branch->next = (thTreeBranchList *) NULL;
+ branchname = thSpaceStrip(line);
+ Branch->branchname = malloc(strlen(branchname)+1);
+ LeafNext = (thLeafList **) &Branch->leaflistp;
+ strcpy(Branch->branchname,branchname);
+ lenbrancharg = 0;
+ for(n=0;n<nleafs;n++) {
+ char *nameptr;
+ /* Need to look for $name here. name will be the name given to root */
+ args[n] = thSpaceStrip(args[n]);
+ /*printf("Leaf %s\n",args[n]);*/
+ if(nameptr=strchr(args[n],'$')) *nameptr++=0;
+ if(thVarResolve(args[n],&varp,&vind,0,0) == S_SUCCESS) {
+ char *p, snum[25];
+ /*printf("Index=%d\n",vind);*/
+ thisleaf = *LeafNext = (thLeafList *) malloc(sizeof(thLeafList));
+ /*printf("thisleaf = %x\n",thisleaf);*/
+ thisleaf->next = (thLeafList *) NULL;
+ thisleaf->varp = varp;
+ thisleaf->index = vind;
+ /* Pick a good name */
+ if(nameptr) {
+ thisleaf->name = (char *) malloc(strlen(nameptr)+1);
+ strcpy(thisleaf->name,nameptr);
+ } else {
+ if(p=strpbrk(args[n],"()[]")) {
+ sprintf(snum,"%d",vind+1);
+ thisleaf->name = (char *) malloc(strlen(args[n])+strlen(snum)+2);
+ strncpy(thisleaf->name,args[n],p-args[n]);
+ thisleaf->name[p-args[n]] = '\0';
+ strcat(thisleaf->name,"_");
+ strcat(thisleaf->name,snum);
+ } else {
+ thisleaf->name = (char *) malloc(strlen(args[n])+1);
+ strcpy(thisleaf->name,args[n]);
+ }
+ }
+ LeafNext = &((*LeafNext)->next);
+ lenbrancharg += strlen(args[n]) + 3;
+ } else {
+ fprintf(stderr,"Bad variable %s\n",args[n]);
+ }
+ }
+ /* Walk down the leaf list and build the Branch call argument */
+ /* What do I do about leaf names with subscripts? */
+ thisleaf = Branch->leaflistp;
+ brancharg = malloc(lenbrancharg+10);
+ brancharg[0] = '\0';
+ while(thisleaf) {
+ /*printf("thisleaf = %x\n",thisleaf);
+ printf("Adding %s to branchlist\n",thisleaf->name);*/
+ strcat(brancharg,thisleaf->name);
+ if(thisleaf->varp->type == DAVARINT) {
+ strcat(brancharg,"/I");
+ thisleaf->leafsize=4;
+ } else if(thisleaf->varp->type == DAVARFLOAT) {
+ strcat(brancharg,"/F");
+ thisleaf->leafsize=4;
+ } else if(thisleaf->varp->type == DAVARDOUBLE) {
+ strcat(brancharg,"/D");
+ thisleaf->leafsize=8;
+ } else {
+ fprintf(stderr,"Variable %s has unknown type\n");
+ }
+
+ if(thisleaf->next) {
+ strcat(brancharg,":");
+ }
+ thisleaf = thisleaf->next;
+ }
+
+ /* Reserve enough space as if they were all double */
+ Branch->evstruct = (void *) malloc(lenbrancharg*sizeof(double));
+
+ /*
+ * leaflist is the concatenation of all the variable names and types
+ separated by a colon character :
+ The variable name and the variable type are separated by a slash (/).
+ The variable type may be 0,1 or 2 characters. If no type is given,
+ the type of the variable is assumed to be the same as the previous
+ variable. If the first variable does not have a type, it is assumed
+ of type F by default. The list of currently supported types is given below:
+ - C : a character string terminated by the 0 character
+ - B : an 8 bit signed integer (Char_t)
+ - b : an 8 bit unsigned integer (UChar_t)
+ - S : a 16 bit signed integer (Short_t)
+ - s : a 16 bit unsigned integer (UShort_t)
+ - I : a 32 bit signed integer (Int_t)
+ - i : a 32 bit unsigned integer (UInt_t)
+ - F : a 32 bit floating point (Float_t)
+ - D : a 64 bit floating point (Double_t)
+ */
+
+ printf("Branch=%s Leafs=%s\n",Branch->branchname,brancharg);
+ thRoot_Branch(treedef->treeptr,Branch->branchname,(Branch->evstruct),brancharg);
+
+ free(brancharg);
+ printf("Exiting book a branch\n");
+ return(S_SUCCESS);
+}
+
+thStatus thFillTreeV(daVarStruct *var){
+ thTreeOpaque *treedef;
+ thTreeBranchList *thisbranch;
+ thLeafList *thisleaf;
+ void *structp;
+ /* printf("Executing Tree %s\n",var->name);*/
+ treedef = ((thTreeOpaque *)(var->opaque));
+ thisbranch = treedef->branchlistP;
+ if(! (treedef->test ? *((DAINT *) treedef->test->varptr
+ + treedef->testindex) : 1)) {
+ return(S_SUCCESS); /* Test was false */
+ }
+ while(thisbranch) {
+ structp = thisbranch->evstruct;
+ /* printf("Filling branch %s at %x\n",thisbranch->branchname,structp);*/
+ thisleaf = thisbranch->leaflistp;
+ while(thisleaf) {
+ if(thisleaf->varp->type == DAVARINT) {
+ *(DAINT *)(structp) = *((DAINT *)thisleaf->varp->varptr + thisleaf->index);/*phil*/
+ structp = (void *) (DAINT *) ((DAINT *)structp + 1);
+ /* printf(" %s=%d\n",thisleaf->name,*((DAINT *)thisleaf->varp->varptr
+ + thisleaf->index));*/
+ } else if(thisleaf->varp->type == DAVARFLOAT) {
+ *(DAFLOAT *)(structp) = *((DAFLOAT *)thisleaf->varp->varptr + thisleaf->index);/*phil*/
+ structp = (void *) (DAFLOAT *) ((DAFLOAT *)structp + 1);
+ /* printf(" %s=%f\n",thisleaf->name,*((DAFLOAT *)thisleaf->varp->varptr
+ + thisleaf->index));*/
+ } else if(thisleaf->varp->type == DAVARDOUBLE) {
+ *(DADOUBLE *)(structp) = *((DADOUBLE *)thisleaf->varp->varptr + thisleaf->index);/*phil*/
+ structp = (void *) (DADOUBLE *) ((DADOUBLE *)structp + 1);
+ /* printf(" %s=%lf\n",thisleaf->name,*((DADOUBLE *)thisleaf->varp->varptr
+ + thisleaf->index));*/
+ }
+ thisleaf = thisleaf->next;
+ }
+ thisbranch = thisbranch->next;
+ }
+ thRoot_Fill(treedef->treeptr);
+
+ (*((DAINT *)var->varptr))++; /* Increment block counter */
+ return(S_SUCCESS);
+}
+thStatus thClearTreeV(daVarStruct *var){
+
+ /* printf("Clearing Tree %s\n",var->name); */
+
+ (*((DAINT *)var->varptr)) = 0; /* Increment block counter */
+ return(S_SUCCESS);
+}
+thStatus thWriteTreeV(daVarStruct *var){
+
+ /* printf("Writing Tree %s\n",var->name); */
+ thRoot_Write(((thTreeOpaque *)(var->opaque))->file);
+
+ (*((DAINT *)var->varptr)) = 0; /* Increment block counter */
+ return(S_SUCCESS);
+}
+thStatus thCloseTreeV(daVarStruct *var){
+
+ /*printf("Closing Tree %s\n",var->name);*/
+ thRoot_Close(((thTreeOpaque *)(var->opaque))->file);
+
+ (*((DAINT *)var->varptr)) = 0; /* Increment block counter */
+ return(S_SUCCESS);
+}
+
+thStatus thRemoveTree(char *treename) {
+ printf("Dummy routine to remove tree %s\n",treename);
+ return(S_SUCCESS);
+}
+
+/*
+int thtreewrite_()
+{
+ thRoot_Write();
+}
+*/
+
+#else
+
+thStatus thBookTree(daVarStruct *var) {
+ return(S_SUCCESS);
+}
+
+thStatus thFillTreeV(daVarStruct *var) {
+ return(S_SUCCESS);
+}
+thStatus thClearTreeV(daVarStruct *var) {
+ return(S_SUCCESS);
+}
+thStatus thWriteTreeV(daVarStruct *var) {
+ return(S_SUCCESS);
+}
+thStatus thCloseTreeV(daVarStruct *var) {
+ return(S_SUCCESS);
+}
+
+#endif
diff --git a/CTP/thUtils.c b/CTP/thUtils.c
new file mode 100644
index 0000000..3c1a763
--- /dev/null
+++ b/CTP/thUtils.c
@@ -0,0 +1,1040 @@
+/*-----------------------------------------------------------------------------
+ * Copyright (c) 1993 Southeastern Universities Research Association,
+ * Continuous Electron Beam Accelerator Facility
+ *
+ * This software was developed under a United States Government license
+ * described in the NOTICE file included as part of this distribution.
+ *
+ * Stephen A. Wood, 12000 Jefferson Ave., Newport News, VA 23606
+ * Email: saw@cebaf.gov Tel: (804) 249-7367 Fax: (804) 249-5800
+ *-----------------------------------------------------------------------------
+ *
+ * Description:
+ * Utilities used by CTP
+ *
+ * Author: Stephen Wood, CEBAF Hall C
+ *
+ * Revision History:
+ * $Log: thUtils.c,v $
+ * Revision 1.3.24.1 2007/09/10 21:32:47 pcarter
+ * Implemented changes to allow compilation on RHEL 3,4,5 and MacOSX
+ *
+ * Revision 1.3 2003/02/21 20:55:25 saw
+ * Clean up some types and casts to reduce compiler warnings.
+ *
+ * Revision 1.2 1999/11/04 20:34:07 saw
+ * Alpha compatibility.
+ * New RPC call needed for root event display.
+ * Start of code to write ROOT trees (ntuples) from new "tree" block
+ *
+ * Revision 1.1 1998/12/07 22:11:14 saw
+ * Initial setup
+ *
+ * Revision 1.6 1995/04/10 15:50:27 saw
+ * Add thSpecial to interpret directives such as #real, #int, ...
+ *
+ * Revision 1.5 1995/01/09 15:38:18 saw
+ * Fix up potential ref to unallocated memory in thIDToken.
+ *
+ * Revision 1.4 1994/09/27 19:44:50 saw
+ * Add fnmatch routine from BSD. Only use when OS doesn't have it (ultrix)
+ *
+ * Revision 1.3 1994/07/21 20:40:22 saw
+ * In thCommas, ignore commas in quotes. Replace stderr with STDERR.
+ *
+ * Revision 1.2 1993/09/22 15:24:50 saw
+ * Allow thIDToken to accept hex
+ *
+ * Revision 1.1 1993/05/11 18:02:05 saw
+ * Initial revision
+ *
+ */
+
+/* thUtils.c
+ Routines used by thTest, thHist and thParm
+
+*/
+#include <stdio.h>
+#include <string.h>
+#include <stdlib.h>
+#include "daVar.h"
+#include "th.h"
+#include "thInternal.h"
+#include "thUtils.h"
+
+daVarStatus thGetIndex(char *name, int *index, char **pptr)
+/* If the name has an array index, evaluate the index and return it to
+*index. Also return a pointer to ( or [ that starts the index.
+If there is no index, return a zero index, but also return the status
+code S_DAVAR_NOINDEX.
+
+I have a whole bunch of ways of dealing with these indices. Must be
+cleaned up.
+*/
+{
+ char *nend, *pbegin; /* Name end */
+ char *t;
+ char cright;
+ int istyle;
+
+ pbegin = nend = name + strlen(name);
+ if((t=strchr(name,'('))) if(t<pbegin) {
+ pbegin = t;
+ cright = ')';
+ istyle = -1;
+ }
+ if((t=strchr(name,'['))) if(t<pbegin) {
+ pbegin = t;
+ cright = ']';
+ istyle = 0;
+ }
+ *pptr = pbegin;
+ if(pbegin < nend) {
+ char *s,*rp;
+ int i;
+
+ s = pbegin + 1;
+ if((rp = strrchr(s,cright)) == 0) {
+ *index = 0;
+ return(S_FAILURE);
+ }
+ *rp = 0;
+ if(thEvalImed(s,0,&i) != S_SUCCESS) {
+ *index = 0;
+ return(S_FAILURE);
+ }
+ *rp = cright;
+ *index = i + istyle;
+ return(S_SUCCESS);
+ }
+ *index = 0;
+ return(S_DAVAR_NOINDEX);
+}
+
+int thComSpace(char *s,char **args)
+/* Treat spaces, tabs and commas as delimiters. */
+{
+ char *p;
+ int i;
+ int comma;
+
+ i = 0;
+ p = s;
+ comma = 1;
+ while(*p != '\0'){
+ while(isspace(*p) || (!comma && *p == ',')) {
+ if(!comma) comma = (*p == ',');
+ p++;
+ }
+ if(*p == '\0') break;
+ args[i++] = p;
+ while(!isspace(*p) && *p != ',' && *p != '\0') p++;
+ if(*p != '\0'){
+ comma = (*p == ',');
+ *p++ = '\0';
+ }
+ }
+ return(i);
+}
+int thCommas(char *s,char **args){
+ /* commas inside of quotes are now protected */
+ char *p;
+ int i;
+ char quotechar;
+ int instring;
+
+ args[0] = s;
+ i = 1;
+ p = s;
+ instring = 0;
+ while(*p != 0) {
+ if(instring && *p == quotechar) {
+ if(*(p+1) == quotechar) p++;
+ else instring = 0;
+ } else {
+ if(*p == ','){
+ *p = '\0';
+ args[i++] = p+1;
+ } else if (*p == QUOTECHAR1 || *p == QUOTECHAR2) {
+ instring = 1;
+ quotechar = *p;
+ }
+ }
+ p++;
+ }
+
+/* while((p=strchr(p,',')) != NULL){
+ *p++ = '\0';
+ args[i++] = p;
+ }*/
+ args[i] = 0;
+ return(i);
+}
+char *thTokenArray(char *s,int *index)
+/* Interpret the string s as an array element. Looks for an index inside
+of []'s, returning that in index. If there is an index inside of ()'s, then
+one is subtracted from the index before it is returnd. []'s are for
+c style indexing, ()'s for fortran style indexing. A pointer to the [ or (
+is returned, so that the variable name may be null terminated by the caller.
+If there is an error in the balancing of the []'s or ()'s, a null is returned
+to signify an error.
+*/
+{
+ int cstyle;
+ char *leftp,*rightp;
+ char sindex[25];
+ char cright;
+ char wleft,wright; /* Character for "other" style */
+ int len;
+
+ if((leftp=strchr(s,'('))){
+ cright = ')';
+ wleft = '['; wright = ']';
+ cstyle = 1;
+ } else if((leftp=strchr(s,'['))){
+ cright = ']';
+ wleft = '('; wright = ')';
+ cstyle = 0;
+ } else return(NULL);
+ rightp = strchr(s,cright);
+ if((leftp>=rightp) || strchr(s,wleft) || strchr(s,wright)) return (NULL);
+ len = min(24,(rightp-leftp)-1);
+ strncpy(sindex,leftp+1,len);
+ sindex[len] = 0;
+ *index = atol(sindex);
+ if(cstyle) (*index)--;
+ return(leftp);
+}
+
+thTokenType thIDToken(char *s)
+/* Examines a string to determine if it is an integer, real number,
+variable name, or array element. Only works if is not an expression.
+Allows hex constants as INT's */
+{
+ char *p;
+ thTokenType typ;
+ int nume; /* Number of E characters */
+
+ /* printf("TYPE(%s)=",s);*/
+ nume = 0;
+ p = s;
+ typ = TOKINT;
+ while(*p != '\0'){
+ if(strchr("()[]",*p)) {/* printf("%d\n",TOKARRAY); */ return(TOKARRAY);}
+ if(typ != TOKVAR){
+ switch(*p)
+ {
+ case 'e':
+ case 'E':
+ if(nume > 0 || p==s){
+ typ = TOKVAR;
+ break;
+ }
+ nume = 1;
+ case '.':
+ typ = TOKFLOAT;
+ break;
+ case '+':
+ case '-':
+ break;
+ case 'x': case 'X':
+ if(p==s || *(p-1) != '0' || nume > 0)
+ typ = TOKVAR;
+ else
+ nume = 1;
+ default:
+ if(!isdigit(*p)) typ = TOKVAR;
+ break;
+ }
+ }
+ p++;
+ }
+ /*printf("%d\n",typ);*/
+ return(typ);
+}
+
+char *thSpaceStrip(char *s)
+/* Strip leading, trailing and embedded spaces from a string.
+ Modifies argument.*/
+{
+ char *p,*t;
+
+ p = t = s;
+ while(*s != '\0'){
+ if(*s != ' ') *t++ = *s++;
+ else *s++;
+ }
+ *t = '\0';
+ return(p);
+
+}
+
+int thSpecial(char *line, char *default_class)
+{ /* Process special commands */
+ char *s,*p;
+ char *command;
+ char *arg;
+ char *arglist[20];
+ int nargs;
+ char *class;
+ daVarStruct *varp;
+ int vartype;
+ char *classlist[]={0,0};
+ int i;
+
+ s = line;
+ while(isspace(*s) && *s) s++;
+ if(*s != SPECIALCHAR) return(0); /* Not a special command */
+
+ /* Split line into command and argument */
+ s++;
+ while(isspace(*s) && *s) s++; /* Skip to command */
+ if(!*s) return(1); /* Empty line */
+ /* s now points to the command */
+ p = s+1;
+ while(!isspace(*p) && *p) p++; /* Skip to end of command */
+ if(!*p) return(1); /* No argument */
+ command = malloc(p-s+1);
+ strncpy(command,s,p-s); command[p-s] = '\0';
+ s = p;
+ while(isspace(*s) && *s) s++; /* Skip to argument */
+ if(!*s) { /* No argument */
+ free(command);
+ return(1);
+ }
+ arg = malloc(strlen(s)+1);
+ strcpy(arg,s);
+ nargs = thCommas(arg,arglist);
+
+/* Now need to look for a . in command to see if there is a class specified */
+ s = strchr(command,'.');
+ if(s) {
+ *s = 0;
+ class = s+1;
+ s = class;
+ while(*s) {tolower(*s); s++;}
+ } else {
+ class = default_class;
+ } /* Should probably use a table here */
+ if(strncasecmp(command,"integer",strlen(command))==0) {
+ vartype = DAVARINT;
+ } else if(strncasecmp(command,"real",strlen(command))==0) {
+ vartype = DAVARFLOAT;
+ } else if(strncasecmp(command,"double",strlen(command))==0) {
+ vartype = DAVARDOUBLE;
+ } else if(strncasecmp(command,"string",strlen(command))==0) {
+ vartype = DAVARSTRING;
+ }
+ classlist[0] = class;
+ for(i=0;i<nargs;i++) {
+ arglist[i] = thSpaceStrip(arglist[i]);
+ thVarCreate(arglist[i],vartype,classlist,&varp);
+ }
+/* command and arg now contain what to do */
+ free(command);
+ free(arg);
+ return(1);
+}
+thVarCreate(char *s, int vartype, char **classlist, daVarStruct **varpp)
+/* Should eventually merge this with thVarResolve */
+{
+ int cstyle;
+ char cleft,cright;
+ char *leftp,*rightp;
+ daVarStruct var;
+ int arindex,arsize;
+
+ *varpp = 0;
+ arindex = 0;
+
+ leftp = strchr(s,'(');
+ {
+ char *lb;
+ lb = strchr(s,'[');
+ if(leftp) {
+ if(lb && lb<leftp) leftp = lb;
+ } else
+ leftp = lb;
+ }
+
+ if(leftp) {
+ cleft = *leftp;
+ *leftp = '\0';
+ }
+ if(leftp){
+ int cstyle;
+ char *sindex;
+ int indtemp;
+
+ sindex = leftp + 1;
+
+ if(cleft=='('){
+ cstyle = -1;
+ cright = ')';
+ } else {
+ cstyle = 0;
+ cright = ']';
+ }
+ if((rightp=strrchr(sindex,cright)) == 0){
+ fprintf(stderr,"Syntax error in %s\n",s);
+ return(S_FAILURE);
+ }
+ *rightp = 0;
+ if(thEvalImed(sindex,0,&indtemp)!= S_SUCCESS){
+ fprintf(stderr,"Error evaluating index %s\n",sindex);
+ *rightp = cright;
+ return(S_FAILURE);
+ }
+ *rightp = cright;
+ arindex = indtemp + cstyle;
+ arsize = indtemp;
+ } else {
+ arsize = 1;
+ }
+ if(daVarLookupPWithClass(s,classlist,varpp) != S_SUCCESS){
+ /* Doesn't exist, we can create it as we want it */
+ if(strchr(s,'.')) { /* Don't prepend a class */
+ var.name = malloc(strlen(s)+1);
+ strcpy(var.name,s);
+ } else {
+ var.name = malloc(strlen(classlist[0])
+ +strlen(s)+2);
+ strcpy(var.name,classlist[0]);
+ strcat(var.name,".");
+ strcat(var.name,s);
+ }
+ if(leftp) *leftp = cleft; /* Restore left paren */
+ var.size = arsize;
+ var.type = vartype;
+ switch(vartype)
+ {
+ case DAVARINT: /* How should we initialize the variables */
+ var.varptr = malloc(var.size*sizeof(DAINT));
+ break;
+ case DAVARFLOAT:
+ var.varptr = malloc(var.size*sizeof(DAFLOAT));
+ break;
+ case DAVARDOUBLE:
+ var.varptr = malloc(var.size*sizeof(DADOUBLE));
+ break;
+ case DAVARSTRING:
+ var.varptr = malloc(var.size*sizeof(char *));
+ *((char *)var.varptr) = '\0';
+ break;
+ }
+ var.opaque = 0;
+ var.rhook = 0;
+ var.whook = 0;
+ var.flag = DAVAR_REPOINTOK | DAVAR_READONLY | DAVAR_DYNAMIC_PAR;
+ var.flag = DAVAR_REPOINTOK | DAVAR_READONLY | DAVAR_DYNAMIC_PAR;
+ var.title = 0;
+/* printf("Registering %s(%d) at %x\n",var.name,var.size,var.varptr);*/
+ daVarRegister((int) 0,&var); /* Create the parameter */
+ daVarLookupP(var.name,varpp);
+ free(var.name);
+ } else {
+ if(leftp) *leftp = cleft; /* Restore left paren */
+ /* Already exists */
+ if((*varpp)->type == vartype && (*varpp)->size == arsize) {
+ /* We are OK, return */
+ return(S_SUCCESS);
+ } else {
+ /* See if we can fix */
+ if((*varpp)->flag&DAVAR_DYNAMIC_PAR) {
+ if((*varpp)->size != arsize || (*varpp)->type != vartype) {
+ (*varpp)->type = vartype;
+ (*varpp)->size = arsize;
+ switch((*varpp)->type)
+ {
+ case DAVARINT:
+ (*varpp)->varptr = (void *) realloc((*varpp)->varptr,arsize * sizeof(DAINT));
+ break;
+ case DAVARFLOAT:
+ (*varpp)->varptr = (void *) realloc((*varpp)->varptr,arsize * sizeof(DAFLOAT));
+ break;
+ case DAVARDOUBLE:
+ (*varpp)->varptr = (void *) realloc((*varpp)->varptr,arsize * sizeof(DADOUBLE));
+ case DAVARSTRING:
+ (*varpp)->varptr = (void *) realloc((*varpp)->varptr,arsize * sizeof(char *));
+ *((char *)var.varptr) = '\0';
+ break;
+ }
+ }
+ }
+ }
+ }
+ return(S_SUCCESS);
+}
+
+
+
+#ifdef OLD
+int thGetMode(char *s, enum MODES mode, enum MODES *nmode, char **blocknamep)
+{
+ char *args[20];
+ int nargs;
+ enum MODES omod e;
+ static char *nulstr="";
+ char *command,*last;
+
+ omode = mode;
+ *nmode = mode;
+ *blocknamep = 0;
+
+ command = s;
+ while(isspace(*command)) command++;
+ last = command;
+ while(!isspace(*last) && *last) last++;
+ if(strncasecmp(command,"begin",last-command) == 0
+ || strncasecmp(command,"end",last-command) == 0){
+ nargs = thComSpace(s,args);
+ if(nargs < 2) {
+ *nmode = M_BAD;
+ return(1);
+ }
+ if(strcasecmp("test",args[1]) == 0)
+ *nmode = M_TES;
+ else if(strcasecmp("hist",args[1]) == 0
+ || strcasecmp("histogram",args[1]) == 0)
+ *nmode = M_HIS;
+ else if(strcasecmp("parameter",args[1]) == 0)
+ *nmode = M_PAR;
+ else
+ *nmode = M_BAD;
+ if(strcasecmp(args[0],"end") == 0){
+ if(*nmode == omode)
+ *nmode = M_COM;
+ else
+ *nmode = M_BAD;
+ } else {
+ if(nargs > 2)
+ *blocknamep = args[2];
+ else
+ *blocknamep = nulstr;
+ }
+ return(1);
+ } else
+ return(0);
+}
+
+int thTokToPtr(char *token, int create, int intonly, daVarStruct *varp)
+/* Find registered variable pointer for token. If the token is an array,
+ create a new entry if the array is already registered. If the variable
+ or array is not registered, register it only if create is true. If
+ intonly is true, fail if an existing variable is not integer.
+
+ If intonly is true when the token is an element of an array that is
+ not short or long, then the routine returns an error.
+
+ If the token is a constant, then create it if it doesn't exist */
+{
+ thTokenType toktyp;
+ daVarStruct var;
+ int lookstat;
+
+ toktyp = thIDToken(token);
+ if(intonly&&create)
+ if(toktyp != TOKVAR && toktyp != TOKARRAY){
+ fprintf(STDERR,"Variable %s must not be a number\n",token);
+ return(S_FAILURE);
+ }
+
+ lookstat = daVarLookup(token, &var);
+ if(lookstat != S_SUCCESS)
+ lookstat = thVarLookup(token, &var);
+ if(lookstat != S_SUCCESS){
+ if(create || toktyp != TOKVAR){
+ var.name = token;
+ var.title = 0;
+ var.flag = DAVAR_READONLY;
+ var.rhook = 0;
+ var.whook = 0;
+ var.opaque = 0;
+ switch(toktyp)
+ {
+ case TOKINT:
+ {
+ register DAINT *longp;
+ longp = malloc(sizeof(DAINT));
+ *longp = atol(token);
+ var.varptr = longp;
+ var.type = DAVARINT;
+ var.size = 1;
+/* daVarRegister(token,longp,DAVARINT,1,DAVAR_READONLY);*/
+ thVarRegister((int) 0, &var);
+ }
+ break;
+ case TOKFLOAT:
+ {
+ register DAFLOAT *floatp;
+ floatp = malloc(sizeof(DAFLOAT));
+ *floatp = atof(token);
+ var.varptr = floatp;
+ var.type = DAVARFLOAT;
+ var.size = 1;
+/* daVarRegister(token,floatp,DAVARFLOAT,1,DAVAR_READONLY);*/
+ thVarRegister((int) 0, &var);
+ }
+ break;
+ case TOKVAR:
+ {
+ register DAINT *longp;
+ longp = malloc(sizeof(DAINT));
+ var.varptr = longp;
+ var.type = DAVARINT;
+ var.size = 1;
+/* daVarRegister(token,intp,DAVARINT,1,DAVAR_READWRITE);*/
+ thVarRegister((int) 0, &var);
+ }
+ break;
+ case TOKARRAY:
+ {
+ /* Only create if underlying variable exists. */
+ char *p; int index; char leftp;
+ p = thTokenArray(token,&index);
+ leftp = *p; /* Save ( or [ character */
+ *p = 0;
+ lookstat = daVarLookup(token, &var);
+ if(lookstat != S_SUCCESS)
+ lookstat = thVarLookup(token, &var);
+ if(lookstat == S_SUCCESS && intonly && (var.type != DAVARINT)) {
+ fprintf(STDERR,
+ "Array %s must be a preregistered LONGINT array.\n",token);
+ return(S_FAILURE);
+ } else {
+ if(index >= var.size){
+ fprintf(STDERR,
+ "Index %d exceeds %s array length of %d\n",index,
+ token,var.size);
+ return(S_FAILURE);
+ }
+ }
+ *p = leftp;
+ switch(var.type)
+ {
+ case DAVARINT:
+ var.varptr = (int *)(var.varptr) + index;
+ var.type = DAVARINT;
+ thVarRegister((int) 0, &var);
+ break;
+ case DAVARFLOAT:
+ var.varptr = (float *)(var.varptr) + index;
+ var.type = DAVARFLOAT;
+ thVarRegister((int) 0, &var);
+ break;
+ default:
+ *p = 0;
+ fprintf(STDERR,"Illegal type %d for variable %s\n"
+ ,var.type,token);
+ return(S_FAILURE);
+ }
+ break;
+ }
+ }
+ lookstat = daVarLookup(token, &var);
+ if(lookstat != S_SUCCESS)
+ if((lookstat = thVarLookup(token, &var)) != S_SUCCESS){
+ fprintf(STDERR,"(thToktoPtr) Bad error\n");
+ return(S_FAILURE);
+ }
+ } else {
+ fprintf(STDERR,"Variable %s must be preregistered\n",token);
+ return(S_FAILURE);
+ }
+ }
+ daVarStructCopy(varp,&var);
+ return(S_SUCCESS);
+}
+#endif
+int thCleanLine(char *s)
+{
+ int blank;
+ blank = 1;
+ while(*s != 0){
+ if(isspace(*s)) *s = ' '; /* Remove tabs, ... */
+ else if(*s == COMCHAR) {
+ *s = 0;
+ break;
+ } else
+ blank = 0;
+ s++;
+ }
+ return(blank);
+}
+/*float argtoFloat(daVarStruct *x)
+{
+ float d;
+
+ switch(x->type)
+ {
+ case DAVARINT:
+ d = *(DAINT *) x->varptr;
+ break;
+ case DAVARFLOAT:
+ d = *(DAFLOAT *) x->varptr;
+ break;
+ case DAVARINTP:
+ d = **(DAINT **) x->varptr;
+ break;
+ case DAVARFLOATP:
+ d = **(DAFLOAT **) x->varptr;
+ break;
+ }
+ return(d);
+}*/
+int argtoInt(daVarStruct *x)
+{
+ DAINT l;
+ DAFLOAT d;
+
+ switch(x->type)
+ {
+ case DAVARINT:
+ l = *(DAINT *) x->varptr;
+ break;
+ case DAVARFLOAT:
+ d = *(DAFLOAT *) x->varptr;
+ l = floatToLong(d);
+ break;
+ case DAVARINTP:
+ l = **(DAINT **) x->varptr;
+ break;
+ case DAVARFLOATP:
+ d = **(DAFLOAT **) x->varptr;
+ l = floatToLong(d);
+ break;
+ }
+ return(l);
+}
+
+
+/*
+ strstr - public-domain implementation of standard C library function
+
+ last edit: 02-Sep-1990 D A Gwyn
+
+ This is an original implementation based on an idea by D M Sunday,
+ essentially the "quick search" algorithm described in CACM V33 N8.
+ Unlike Sunday's implementation, this one does not wander past the
+ ends of the strings (which can cause malfunctions under certain
+ circumstances), nor does it require the length of the searched
+ text to be determined in advance. There are numerous other subtle
+ improvements too. The code is intended to be fully portable, but in
+ environments that do not conform to the C standard, you should check
+ the sections below marked "configure as required". There are also
+ a few compilation options, as follows:
+
+ #define ROBUST to obtain sane behavior when invoked with a null
+ pointer argument, at a miniscule cost in speed
+ #define ZAP to use memset() to zero the shift[] array; this may
+ be faster in some implementations, but could fail on
+ unusual architectures
+ #define DEBUG to enable assertions (bug detection)
+ #define TEST to enable the test program attached at the end
+*/
+#define ROBUST
+#if !defined(__osf__) || !defined(__alpha)
+#define ZAP
+#endif
+
+#include <stddef.h> /* defines size_t and NULL */
+#include <limits.h> /* defines UCHAR_MAX */
+
+#ifdef ZAP
+typedef void *pointer;
+/* Not clear why we need to do this at all */
+#ifndef linux
+extern pointer memset( pointer, int, size_t );
+#endif
+#endif
+
+#if defined(ultrix)
+#define const /* nothing */
+#endif
+
+#ifndef DEBUG
+#define NDEBUG
+#endif
+#include <assert.h>
+
+typedef const unsigned char cuc; /* char variety used in algorithm */
+
+#define EOS '\0' /* C string terminator */
+
+char * /* returns -> leftmost occurrence,
+ or null pointer if not present */
+strcasestr(const char *s1, const char *s2 )
+ /* const char *s1; */ /* -> string to be searched */
+ /* const char *s2; */ /* -> search-pattern string */
+{
+ register cuc *t; /* -> text character being tested */
+ register cuc *p; /* -> pattern char being tested */
+ register cuc *tx; /* -> possible start of match */
+ register size_t m; /* length of pattern */
+ register cuc *top; /* -> high water mark in text */
+#if UCHAR_MAX > 255 /* too large for auto allocation */
+ static /* not malloc()ed; that can fail! */
+#endif /* else allocate shift[] on stack */
+ size_t shift[UCHAR_MAX + 1]; /* pattern shift table */
+
+#ifdef ROBUST /* not required by C standard */
+ if ( s1 == NULL || s2 == NULL )
+ return NULL; /* certainly, no match is found! */
+#endif
+
+ /* Precompute shift intervals based on the pattern;
+ the length of the pattern is determined as a side effect: */
+
+#ifdef ZAP
+ (void)memset( (pointer)&shift[1], 0, UCHAR_MAX * sizeof(size_t) );
+#else
+ {
+ register unsigned char c;
+
+ c = UCHAR_MAX;
+ do
+ shift[c] = 0;
+ while ( --c > 0 );
+ }
+#endif
+ /* Note: shift[0] is undefined at this point (fixed later). */
+
+ for ( m = 1, p = (cuc *)s2; *p != EOS; ++m, ++p )
+ shift[tolower((cuc)*p)] = m;
+
+ assert(s2[m - 1] == EOS);
+
+ {
+ register unsigned char c;
+
+ c = UCHAR_MAX;
+ do
+ if(!isupper(c)) shift[c] = m - shift[c];
+ while ( --c > 0 );
+
+ /* Note: shift[0] is still undefined at this point. */
+ }
+
+ shift[0] = --m; /* shift[EOS]; important details! */
+
+ assert(s2[m] == EOS);
+
+ /* Try to find the pattern in the text string: */
+
+ for ( top = tx = (cuc *)s1; ; tx += shift[tolower(*(top = t))] )
+ {
+ for ( t = tx, p = (cuc *)s2; ; ++t, ++p )
+ {
+ if ( *p == EOS ) /* entire pattern matched */
+ return (char *)tx;
+
+ if ( tolower(*p) != tolower(*t) )
+ break;
+ }
+ if ( t < top) /* idea due to ado@elsie.nci.nih.gov */
+ t = top; /* already scanned this far for EOS */
+
+ do {
+ assert(m > 0);
+ assert(t - tx < m);
+
+ if ( *t == EOS )
+ return NULL; /* no match */
+ }
+ while ( ++t - tx != m ); /* < */
+ }
+}
+
+void thAddVarToList(daVarStructList **head, daVarStruct *varp)
+{
+ daVarStructList *nextptr;
+
+ if(head==0) {
+ fprintf(STDERR,"thAddVarToList shouldn't have been called\n");
+ return;
+ }
+ nextptr = *head;
+ while(nextptr){
+ if(nextptr->varp == varp) /* Don't add duplicates */
+ return;
+ head = &(nextptr->next);
+ nextptr = nextptr->next;
+ }
+ *head = malloc(sizeof(daVarStructList));
+ (*head)->next = 0;
+ (*head)->varp = varp;
+ return;
+}
+#ifdef NOFNMATCH
+/*
+ * Copyright (c) 1989, 1993, 1994
+ * The Regents of the University of California. All rights reserved.
+ *
+ * This code is derived from software contributed to Berkeley by
+ * Guido van Rossum.
+ *
+ * Redistribution and use in source and binary forms, with or without
+ * modification, are permitted provided that the following conditions
+ * are met:
+ * 1. Redistributions of source code must retain the above copyright
+ * notice, this list of conditions and the following disclaimer.
+ * 2. Redistributions in binary form must reproduce the above copyright
+ * notice, this list of conditions and the following disclaimer in the
+ * documentation and/or other materials provided with the distribution.
+ * 3. All advertising materials mentioning features or use of this software
+ * must display the following acknowledgement:
+ * This product includes software developed by the University of
+ * California, Berkeley and its contributors.
+ * 4. Neither the name of the University nor the names of its contributors
+ * may be used to endorse or promote products derived from this software
+ * without specific prior written permission.
+ *
+ * THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND
+ * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+ * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+ * ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE
+ * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+ * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
+ * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
+ * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
+ * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
+ * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
+ * SUCH DAMAGE.
+ */
+
+#if defined(LIBC_SCCS) && !defined(lint)
+static char sccsid[] = "@(#)fnmatch.c 8.2 (Berkeley) 4/16/94";
+#endif /* LIBC_SCCS and not lint */
+
+/*
+ * Function fnmatch() as specified in POSIX 1003.2-1992, section B.6.
+ * Compares a filename or pathname to a pattern.
+ */
+
+#include "fnmatch.h"
+
+#define EOS '\0'
+
+/*static const char *rangematch __P((const char *, int, int));*/
+static const char *rangematch(const char *, int, int);
+
+int
+fnmatch(pattern, string, flags)
+ const char *pattern, *string;
+ int flags;
+{
+ const char *stringstart;
+ char c, test;
+
+ for (stringstart = string;;)
+ switch (c = *pattern++) {
+ case EOS:
+ return (*string == EOS ? 0 : FNM_NOMATCH);
+ case '?':
+ if (*string == EOS)
+ return (FNM_NOMATCH);
+ if (*string == '/' && (flags & FNM_PATHNAME))
+ return (FNM_NOMATCH);
+ if (*string == '.' && (flags & FNM_PERIOD) &&
+ (string == stringstart ||
+ ((flags & FNM_PATHNAME) && *(string - 1) == '/')))
+ return (FNM_NOMATCH);
+ ++string;
+ break;
+ case '*':
+ c = *pattern;
+ /* Collapse multiple stars. */
+ while (c == '*')
+ c = *++pattern;
+
+ if (*string == '.' && (flags & FNM_PERIOD) &&
+ (string == stringstart ||
+ ((flags & FNM_PATHNAME) && *(string - 1) == '/')))
+ return (FNM_NOMATCH);
+
+ /* Optimize for pattern with * at end or before /. */
+ if (c == EOS)
+ if (flags & FNM_PATHNAME)
+ return (strchr(string, '/') == NULL ?
+ 0 : FNM_NOMATCH);
+ else
+ return (0);
+ else if (c == '/' && flags & FNM_PATHNAME) {
+ if ((string = strchr(string, '/')) == NULL)
+ return (FNM_NOMATCH);
+ break;
+ }
+
+ /* General case, use recursion. */
+ while ((test = *string) != EOS) {
+ if (!fnmatch(pattern, string, flags & ~FNM_PERIOD))
+ return (0);
+ if (test == '/' && flags & FNM_PATHNAME)
+ break;
+ ++string;
+ }
+ return (FNM_NOMATCH);
+ case '[':
+ if (*string == EOS)
+ return (FNM_NOMATCH);
+ if (*string == '/' && flags & FNM_PATHNAME)
+ return (FNM_NOMATCH);
+ if ((pattern =
+ rangematch(pattern, *string, flags)) == NULL)
+ return (FNM_NOMATCH);
+ ++string;
+ break;
+ case '\\':
+ if (!(flags & FNM_NOESCAPE)) {
+ if ((c = *pattern++) == EOS) {
+ c = '\\';
+ --pattern;
+ }
+ }
+ /* FALLTHROUGH */
+ default:
+ if (c != *string++)
+ return (FNM_NOMATCH);
+ break;
+ }
+ /* NOTREACHED */
+}
+
+static const char *
+rangematch(pattern, test, flags)
+ const char *pattern;
+ int test, flags;
+{
+ int negate, ok;
+ char c, c2;
+
+ /*
+ * A bracket expression starting with an unquoted circumflex
+ * character produces unspecified results (IEEE 1003.2-1992,
+ * 3.13.2). This implementation treats it like '!', for
+ * consistency with the regular expression syntax.
+ * J.T. Conklin (conklin@ngai.kaleida.com)
+ */
+ if (negate = (*pattern == '!' || *pattern == '^'))
+ ++pattern;
+
+ for (ok = 0; (c = *pattern++) != ']';) {
+ if (c == '\\' && !(flags & FNM_NOESCAPE))
+ c = *pattern++;
+ if (c == EOS)
+ return (NULL);
+ if (*pattern == '-'
+ && (c2 = *(pattern+1)) != EOS && c2 != ']') {
+ pattern += 2;
+ if (c2 == '\\' && !(flags & FNM_NOESCAPE))
+ c2 = *pattern++;
+ if (c2 == EOS)
+ return (NULL);
+ if (c <= test && test <= c2)
+ ok = 1;
+ } else if (c == test)
+ ok = 1;
+ }
+ return (ok == negate ? NULL : pattern);
+}
+#endif
diff --git a/CTP/thUtils.h b/CTP/thUtils.h
new file mode 100644
index 0000000..d6336ad
--- /dev/null
+++ b/CTP/thUtils.h
@@ -0,0 +1,68 @@
+/*-----------------------------------------------------------------------------
+ * Copyright (c) 1993 Southeastern Universities Research Association,
+ * Continuous Electron Beam Accelerator Facility
+ *
+ * This software was developed under a United States Government license
+ * described in the NOTICE file included as part of this distribution.
+ *
+ * Stephen A. Wood, 12000 Jefferson Ave., Newport News, VA 23606
+ * Email: saw@cebaf.gov Tel: (804) 249-7367 Fax: (804) 249-5800
+ *-----------------------------------------------------------------------------
+ *
+ * Description:
+ * prototypes and defs for when thUtils.c routines are used.
+ *
+ * Author: Stephen Wood, CEBAF Hall C
+ *
+ * Revision History:
+ * $Log: thUtils.h,v $
+ * Revision 1.1.24.1 2007/09/10 21:32:47 pcarter
+ * Implemented changes to allow compilation on RHEL 3,4,5 and MacOSX
+ *
+ * Revision 1.1 1998/12/07 22:11:14 saw
+ * Initial setup
+ *
+ * Revision 1.2 1995/08/03 15:02:59 saw
+ * Declare thSpecial for #real, #int, ... directives
+ *
+ * Revision 1.1 1993/05/11 17:40:51 saw
+ * Initial revision
+ *
+ */
+
+#ifndef _TH_UTILS_H
+#define _TH_UTILS_H
+
+#ifndef _DAVAR_H
+#include "daVar.h"
+#endif
+
+#define min(a,b) (a>b ? b : a)
+
+typedef enum {TOKINT, TOKFLOAT, TOKVAR, TOKARRAY} thTokenType;
+
+daVarStatus thGetIndex(char *name, int *index, char **pptr);
+int thComSpace(char *s,char **args);
+int thCommas(char *s,char **args);
+char *thTokenArray(char *s,int *index);
+thTokenType thIDToken(char *s);
+char *thSpaceStrip(char *s);
+int thSpecial(char *line, char *default_class);
+#ifdef OLD
+*int thGetMode(char *s, enum MODES mode, enum MODES *nmode, char **blocknamep);
+int thTokToPtr(char *token, int create, int intonly, daVarStruct *varp);
+#endif
+int thCleanLine(char *s);
+/*float argtoFloat(daVarStruct *x);*/
+int argtoInt(daVarStruct *x);
+char *strcasestr(const char *s1, const char *s2);
+
+struct daVarStructList {
+ struct daVarStructList *next;
+ daVarStruct *varp;
+};
+
+typedef struct daVarStructList daVarStructList;
+
+void thAddVarToList(daVarStructList **head,daVarStruct *varp);
+#endif
diff --git a/CVS/Entries b/CVS/Entries
new file mode 100644
index 0000000..1c48b59
--- /dev/null
+++ b/CVS/Entries
@@ -0,0 +1,2 @@
+/Makefile/1.8.14.6.2.3/Sat Oct 25 12:49:29 2008//Tsane
+D
diff --git a/CVS/Entries.Log b/CVS/Entries.Log
new file mode 100644
index 0000000..ab52239
--- /dev/null
+++ b/CVS/Entries.Log
@@ -0,0 +1,23 @@
+A D/BTRACKING////
+A D/CODA////
+A D/CTP////
+A D/CVSROOT////
+A D/ENGINE////
+A D/ESCAN////
+A D/EXE////
+A D/F1TRIGGER////
+A D/HACK////
+A D/HTRACKING////
+A D/INCLUDE////
+A D/ONEEV////
+A D/ONLINE////
+A D/PORT////
+A D/SANE////
+A D/SEM////
+A D/STRACKING////
+A D/SYNCFILTER////
+A D/T20////
+A D/TRACKING////
+A D/UTILSUBS////
+A D/etc////
+R D/ESCAN////
diff --git a/CVS/Repository b/CVS/Repository
new file mode 100644
index 0000000..8b98839
--- /dev/null
+++ b/CVS/Repository
@@ -0,0 +1 @@
+Analyzer
diff --git a/CVS/Root b/CVS/Root
new file mode 100644
index 0000000..6288c3f
--- /dev/null
+++ b/CVS/Root
@@ -0,0 +1 @@
+whit@cvs.jlab.org:/group/hallc/cvsroot
diff --git a/CVS/Tag b/CVS/Tag
new file mode 100644
index 0000000..25d73f7
--- /dev/null
+++ b/CVS/Tag
@@ -0,0 +1 @@
+Tsane
diff --git a/CVSROOT/CVS/Entries b/CVSROOT/CVS/Entries
new file mode 100644
index 0000000..910355a
--- /dev/null
+++ b/CVSROOT/CVS/Entries
@@ -0,0 +1,10 @@
+/checkoutlist/1.1/Thu Dec 3 16:54:23 1998//Tsane
+/commitinfo/1.1/Thu Dec 3 16:54:23 1998//Tsane
+/cvswrappers/1.1/Thu Dec 3 16:54:23 1998//Tsane
+/editinfo/1.1/Thu Dec 3 16:54:23 1998//Tsane
+/loginfo/1.2/Wed Feb 12 20:18:34 2003//Tsane
+/modules/1.1/Thu Dec 3 16:54:23 1998//Tsane
+/notify/1.1/Thu Dec 3 16:54:23 1998//Tsane
+/rcsinfo/1.1/Thu Dec 3 16:54:23 1998//Tsane
+/taginfo/1.1/Thu Dec 3 16:54:23 1998//Tsane
+D
diff --git a/CVSROOT/CVS/Repository b/CVSROOT/CVS/Repository
new file mode 100644
index 0000000..5ba3545
--- /dev/null
+++ b/CVSROOT/CVS/Repository
@@ -0,0 +1 @@
+Analyzer/CVSROOT
diff --git a/CVSROOT/CVS/Root b/CVSROOT/CVS/Root
new file mode 100644
index 0000000..6288c3f
--- /dev/null
+++ b/CVSROOT/CVS/Root
@@ -0,0 +1 @@
+whit@cvs.jlab.org:/group/hallc/cvsroot
diff --git a/CVSROOT/CVS/Tag b/CVSROOT/CVS/Tag
new file mode 100644
index 0000000..25d73f7
--- /dev/null
+++ b/CVSROOT/CVS/Tag
@@ -0,0 +1 @@
+Tsane
diff --git a/CVSROOT/checkoutlist b/CVSROOT/checkoutlist
new file mode 100644
index 0000000..b04b350
--- /dev/null
+++ b/CVSROOT/checkoutlist
@@ -0,0 +1,13 @@
+# The "checkoutlist" file is used to support additional version controlled
+# administrative files in $CVSROOT/CVSROOT, such as template files.
+#
+# The first entry on a line is a filename which will be checked out from
+# the corresponding RCS file in the $CVSROOT/CVSROOT directory.
+# The remainder of the line is an error message to use if the file cannot
+# be checked out.
+#
+# File format:
+#
+# [<whitespace>]<filename><whitespace><error message><end-of-line>
+#
+# comment lines begin with '#'
diff --git a/CVSROOT/commitinfo b/CVSROOT/commitinfo
new file mode 100644
index 0000000..b19e7b7
--- /dev/null
+++ b/CVSROOT/commitinfo
@@ -0,0 +1,15 @@
+# The "commitinfo" file is used to control pre-commit checks.
+# The filter on the right is invoked with the repository and a list
+# of files to check. A non-zero exit of the filter program will
+# cause the commit to be aborted.
+#
+# The first entry on a line is a regular expression which is tested
+# against the directory that the change is being committed to, relative
+# to the $CVSROOT. For the first match that is found, then the remainder
+# of the line is the name of the filter to run.
+#
+# If the repository name does not match any of the regular expressions in this
+# file, the "DEFAULT" line is used, if it is specified.
+#
+# If the name "ALL" appears as a regular expression it is always used
+# in addition to the first matching regex or "DEFAULT".
diff --git a/CVSROOT/cvswrappers b/CVSROOT/cvswrappers
new file mode 100644
index 0000000..5047bf1
--- /dev/null
+++ b/CVSROOT/cvswrappers
@@ -0,0 +1,22 @@
+# This file describes wrappers and other binary files to CVS.
+#
+# Wrappers are the concept where directories of files are to be
+# treated as a single file. The intended use is to wrap up a wrapper
+# into a single tar such that the tar archive can be treated as a
+# single binary file in CVS.
+#
+# To solve the problem effectively, it was also necessary to be able to
+# prevent rcsmerge from merging these files.
+#
+# Format of wrapper file ($CVSROOT/CVSROOT/cvswrappers or .cvswrappers)
+#
+# wildcard [option value][option value]...
+#
+# where option is one of
+# -f from cvs filter value: path to filter
+# -t to cvs filter value: path to filter
+# -m update methodology value: MERGE or COPY
+#
+# and value is a single-quote delimited value.
+#
+# For example:
diff --git a/CVSROOT/editinfo b/CVSROOT/editinfo
new file mode 100644
index 0000000..0d006c7
--- /dev/null
+++ b/CVSROOT/editinfo
@@ -0,0 +1,21 @@
+# The "editinfo" file is used to allow verification of logging
+# information. It works best when a template (as specified in the
+# rcsinfo file) is provided for the logging procedure. Given a
+# template with locations for, a bug-id number, a list of people who
+# reviewed the code before it can be checked in, and an external
+# process to catalog the differences that were code reviewed, the
+# following test can be applied to the code:
+#
+# Making sure that the entered bug-id number is correct.
+# Validating that the code that was reviewed is indeed the code being
+# checked in (using the bug-id number or a seperate review
+# number to identify this particular code set.).
+#
+# If any of the above test failed, then the commit would be aborted.
+#
+# Actions such as mailing a copy of the report to each reviewer are
+# better handled by an entry in the loginfo file.
+#
+# One thing that should be noted is the the ALL keyword is not
+# supported. There can be only one entry that matches a given
+# repository.
diff --git a/CVSROOT/loginfo b/CVSROOT/loginfo
new file mode 100644
index 0000000..c20b8d6
--- /dev/null
+++ b/CVSROOT/loginfo
@@ -0,0 +1,21 @@
+# The "loginfo" file is used to control where "cvs commit" log information
+# is sent. The first entry on a line is a regular expression which is tested
+# against the directory that the change is being made to, relative to the
+# $CVSROOT. For the first match that is found, then the remainder of the
+# line is a filter program that should expect log information on its standard
+# input.
+#
+# If the repository name does not match any of the regular expressions in the
+# first field of this file, the "DEFAULT" line is used, if it is specified.
+#
+# If the name "ALL" appears as a regular expression it is always used
+# in addition to the first matching regex or "DEFAULT".
+#
+# The filter program may use one and only one "%s" modifier (ala printf). If
+# such a "%s" is specified in the filter program, a brief title is included
+# (as one argument, enclosed in single quotes) showing the relative directory
+# name and listing the modified file names.
+#
+# For example:
+#DEFAULT (echo ""; who am i; date; cat) >> $CVSROOT/CVSROOT/commitlog
+^Analyzer Mail -s %s jones
diff --git a/CVSROOT/modules b/CVSROOT/modules
new file mode 100644
index 0000000..d0febb0
--- /dev/null
+++ b/CVSROOT/modules
@@ -0,0 +1,23 @@
+# Three different line formats are valid:
+# key -a aliases...
+# key [options] directory
+# key [options] directory files...
+#
+# Where "options" are composed of:
+# -i prog Run "prog" on "cvs commit" from top-level of module.
+# -o prog Run "prog" on "cvs checkout" of module.
+# -e prog Run "prog" on "cvs export" of module.
+# -t prog Run "prog" on "cvs rtag" of module.
+# -u prog Run "prog" on "cvs update" of module.
+# -d dir Place module in directory "dir" instead of module name.
+# -l Top-level directory only -- do not recurse.
+#
+# And "directory" is a path to a directory relative to $CVSROOT.
+#
+# The "-a" option specifies an alias. An alias is interpreted as if
+# everything on the right of the "-a" had been typed on the command line.
+#
+# You can encode a module within a module by using the special '&'
+# character to interpose another module into the current module. This
+# can be useful for creating a module that consists of many directories
+# spread out over the entire source repository.
diff --git a/CVSROOT/notify b/CVSROOT/notify
new file mode 100644
index 0000000..34f0bc2
--- /dev/null
+++ b/CVSROOT/notify
@@ -0,0 +1,12 @@
+# The "notify" file controls where notifications from watches set by
+# "cvs watch add" or "cvs edit" are sent. The first entry on a line is
+# a regular expression which is tested against the directory that the
+# change is being made to, relative to the $CVSROOT. If it matches,
+# then the remainder of the line is a filter program that should contain
+# one occurrence of %s for the user to notify, and information on its
+# standard input.
+#
+# "ALL" or "DEFAULT" can be used in place of the regular expression.
+#
+# For example:
+#ALL mail %s -s "CVS notification"
diff --git a/CVSROOT/rcsinfo b/CVSROOT/rcsinfo
new file mode 100644
index 0000000..49e59f4
--- /dev/null
+++ b/CVSROOT/rcsinfo
@@ -0,0 +1,13 @@
+# The "rcsinfo" file is used to control templates with which the editor
+# is invoked on commit and import.
+#
+# The first entry on a line is a regular expression which is tested
+# against the directory that the change is being made to, relative to the
+# $CVSROOT. For the first match that is found, then the remainder of the
+# line is the name of the file that contains the template.
+#
+# If the repository name does not match any of the regular expressions in this
+# file, the "DEFAULT" line is used, if it is specified.
+#
+# If the name "ALL" appears as a regular expression it is always used
+# in addition to the first matching regex or "DEFAULT".
diff --git a/CVSROOT/taginfo b/CVSROOT/taginfo
new file mode 100644
index 0000000..274a46d
--- /dev/null
+++ b/CVSROOT/taginfo
@@ -0,0 +1,20 @@
+# The "taginfo" file is used to control pre-tag checks.
+# The filter on the right is invoked with the following arguments:
+#
+# $1 -- tagname
+# $2 -- operation "add" for tag, "mov" for tag -F, and "del" for tag -d
+# $3 -- repository
+# $4-> file revision [file revision ...]
+#
+# A non-zero exit of the filter program will cause the tag to be aborted.
+#
+# The first entry on a line is a regular expression which is tested
+# against the directory that the change is being committed to, relative
+# to the $CVSROOT. For the first match that is found, then the remainder
+# of the line is the name of the filter to run.
+#
+# If the repository name does not match any of the regular expressions in this
+# file, the "DEFAULT" line is used, if it is specified.
+#
+# If the name "ALL" appears as a regular expression it is always used
+# in addition to the first matching regex or "DEFAULT".
diff --git a/ENGINE/.cvsignore b/ENGINE/.cvsignore
new file mode 100644
index 0000000..0b6ddf9
--- /dev/null
+++ b/ENGINE/.cvsignore
@@ -0,0 +1,2 @@
+O.*
+r_*.f
diff --git a/ENGINE/CVS/Entries b/ENGINE/CVS/Entries
new file mode 100644
index 0000000..5379c27
--- /dev/null
+++ b/ENGINE/CVS/Entries
@@ -0,0 +1,157 @@
+/.cvsignore/1.1/Thu Jul 8 18:09:52 2004//Tsane
+/Makefile/1.1/Mon Dec 7 22:11:16 1998//Tsane
+/Makefile.Unix/1.28.16.10.2.1/Thu May 15 18:59:21 2008//Tsane
+/b_clear_event.f/1.1.2.11/Tue Jan 8 22:45:30 2008//Tsane
+/b_cosmic_ntuple_init.f/1.1.2.1/Tue May 15 02:54:45 2007//Tsane
+/b_initialize.f/1.1.2.8/Tue Jan 8 22:50:52 2008//Tsane
+/b_keep_results.f/1.1.2.4.2.3/Fri Apr 3 15:33:19 2009//Tsane
+/b_ntuple_change.f/1.1.2.2/Mon Jun 4 14:56:05 2007//Tsane
+/b_ntuple_clear.f/1.1.2.1/Tue May 15 02:54:45 2007//Tsane
+/b_ntuple_close.f/1.1.2.1.2.1/Fri Jan 16 18:47:12 2009//Tsane
+/b_ntuple_init.f/1.1.2.5.2.1/Fri Jan 16 18:47:12 2009//Tsane
+/b_ntuple_keep.f/1.1.2.19.2.9/Tue Sep 8 16:11:26 2009//Tsane
+/b_ntuple_open.f/1.1.2.21.2.2/Fri Jan 16 18:47:12 2009//Tsane
+/b_ntuple_register.f/1.1.2.1/Tue May 15 02:54:45 2007//Tsane
+/b_ntuple_shutdown.f/1.1.2.2/Mon Jun 4 14:56:05 2007//Tsane
+/b_proper_shutdown.f/1.1.2.7/Sat Nov 3 09:21:42 2007//Tsane
+/b_register_variables.f/1.1.2.1/Tue May 15 02:54:45 2007//Tsane
+/b_reset_event.f/1.1.2.14/Tue Jan 8 22:45:30 2008//Tsane
+/b_tree_init.f/1.1.2.1/Tue Aug 7 19:07:03 2007//Tsane
+/bigcal_mc_reconstruction.f/1.1.2.6/Mon Oct 8 19:22:02 2007//Tsane
+/c_clear_event.f/1.5/Tue Feb 23 16:39:34 1999//Tsane
+/c_initialize.f/1.9/Fri Dec 27 21:49:43 2002//Tsane
+/c_keep_results.f/1.5/Wed Sep 4 15:29:30 1996//Tsane
+/c_ntuple_change.f/1.1/Tue Feb 17 17:26:33 2004//Tsane
+/c_ntuple_clear.f/1.1/Wed Feb 24 14:52:36 1999//Tsane
+/c_ntuple_close.f/1.1/Tue Feb 17 17:26:33 2004//Tsane
+/c_ntuple_init.f/1.10.18.1/Tue Oct 16 20:20:31 2007//Tsane
+/c_ntuple_keep.f/1.10/Tue Feb 17 17:26:34 2004//Tsane
+/c_ntuple_open.f/1.1/Tue Feb 17 17:26:34 2004//Tsane
+/c_ntuple_register.f/1.2/Fri Jun 17 02:47:58 1994//Tsane
+/c_ntuple_shutdown.f/1.5/Tue Feb 17 17:26:34 2004//Tsane
+/c_physics.f/1.10/Fri Dec 19 19:21:04 2003//Tsane
+/c_proper_shutdown.f/1.8/Tue Jan 16 21:07:45 1996//Tsane
+/c_reconstruction.f/1.6/Tue Jan 16 21:08:42 1996//Tsane
+/c_register_variables.f/1.9/Tue Jan 16 21:09:28 1996//Tsane
+/c_reset_event.f/1.3/Tue Jan 16 21:10:22 1996//Tsane
+/engine.f/1.42.8.21.2.13/Thu Sep 17 20:24:14 2009//Tsane
+/g_analyze_beam_pedestal.f/1.3/Tue Feb 23 16:49:21 1999//Tsane
+/g_analyze_misc.f/1.9.20.4.2.8/Tue Feb 23 14:51:30 2010//Tsane
+/g_analyze_pedestal.f/1.2.24.1.2.2/Sun Oct 26 19:12:33 2008//Tsane
+/g_analyze_scaler_bank.f/1.4.14.2.2.6/Fri Feb 25 20:24:28 2011//Tsane
+/g_analyze_scalers.f/1.15.20.1.2.1/Wed Sep 2 13:36:59 2009//Tsane
+/g_analyze_scalers_by_banks.f/1.2.24.2/Fri Nov 9 17:17:15 2007//Tsane
+/g_apply_offsets.f/1.1.24.1/Mon Jun 4 14:56:05 2007//Tsane
+/g_calc_beam_pedestal.f/1.4.20.2/Wed Oct 24 16:59:55 2007//Tsane
+/g_calc_bpm_pedestal.f/1.2/Mon Apr 29 19:43:42 1996//Tsane
+/g_calc_pedestal.f/1.2.24.1.2.2/Sun Oct 26 19:12:33 2008//Tsane
+/g_calc_raster_pedestal.f/1.3.26.1/Sat Oct 11 15:03:35 2008//Tsane
+/g_clear_event.f/1.10.24.2.2.4/Thu Nov 6 21:38:50 2008//Tsane
+/g_ctp_database.f/1.7/Thu Nov 4 20:35:15 1999//Tsane
+/g_decode_clear.f/1.3.24.1/Tue Sep 11 19:14:17 2007//Tsane
+/g_decode_config.f/1.7.24.3.2.1/Fri Jan 16 18:47:12 2009//Tsane
+/g_decode_event_by_banks.f/1.6.24.2.2.1/Wed Sep 2 13:37:42 2009//Tsane
+/g_decode_fb_bank.f/1.32.20.15.2.7/Tue Sep 29 13:58:51 2009//Tsane
+/g_decode_fb_detector.f/1.23.20.13.2.5/Fri Jan 30 20:33:29 2009//Tsane
+/g_decode_init.f/1.3/Tue Jan 16 20:54:59 1996//Tsane
+/g_decode_scalers.f/1.1/Wed Jun 22 20:59:25 1994//Tsane
+/g_dump_histograms.f/1.3/Wed Sep 25 14:42:06 2002//Tsane
+/g_dump_peds.f/1.1/Mon Apr 29 19:46:35 1996//Tsane
+/g_examine_control_event.f/1.7.24.1/Mon Sep 10 20:33:37 2007//Tsane
+/g_examine_epics_event.f/1.5.20.1.2.4/Mon Dec 6 18:31:13 2010//Tsane
+/g_examine_go_info.f/1.4.20.3/Fri Nov 2 22:36:16 2007//Tsane
+/g_examine_physics_event.f/1.4.24.2.2.1/Mon Feb 16 00:18:13 2009//Tsane
+/g_examine_picture_event.f/1.1.6.3/Wed Sep 12 14:40:03 2007//Tsane
+/g_extract_kinematics.f/1.6/Fri Sep 5 15:41:05 2003//Tsane
+/g_get_next_event.f/1.5.24.1/Thu Sep 13 04:02:17 2007//Tsane
+/g_init_filenames.f/1.19.6.9.2.1/Tue Oct 27 15:11:46 2009//Tsane
+/g_initialize.f/1.24.6.12/Thu Nov 29 19:05:29 2007//Tsane
+/g_keep_results.f/1.10.8.1.2.1/Thu May 15 18:59:21 2008//Tsane
+/g_kludgeup_kinematics.f/1.3.24.1/Mon Sep 10 20:33:37 2007//Tsane
+/g_ntuple_init.f/1.1.24.4.2.1/Thu May 15 18:59:21 2008//Tsane
+/g_ntuple_shutdown.f/1.2.24.2.2.1/Thu May 15 18:59:22 2008//Tsane
+/g_open_source.f/1.5.24.3/Fri Sep 7 16:06:07 2007//Tsane
+/g_output_thresholds.f/1.7.20.4/Thu Nov 29 18:37:17 2007//Tsane
+/g_preproc_event.f/1.1/Mon Jun 10 17:47:43 1996//Tsane
+/g_preproc_open.f/1.1/Mon Jun 10 17:48:15 1996//Tsane
+/g_proper_shutdown.f/1.14.8.2/Mon Jun 4 14:56:05 2007//Tsane
+/g_reconstruction.f/1.13.24.9.2.7/Tue May 31 15:34:47 2011//Tsane
+/g_register_variables.f/1.11.24.2.2.3/Sun Oct 26 19:12:33 2008//Tsane
+/g_reset_event.f/1.11.24.3.2.3/Sun Oct 26 19:12:33 2008//Tsane
+/g_scaler_reset_event.f/1.5.22.2/Tue Sep 29 14:00:32 2009//Tsane
+/g_target_initialize.f/1.1/Mon Jan 22 15:11:55 1996//Tsane
+/g_trans_misc.f/1.2.24.5.2.1/Tue Oct 28 20:53:12 2008//Tsane
+/g_tree_init.f/1.1.2.1/Tue Aug 7 19:07:17 2007//Tsane
+/g_write_event.f/1.1/Mon Jun 10 17:47:32 1996//Tsane
+/gep_check_bigcal.f/1.1.2.1/Mon Oct 8 19:23:17 2007//Tsane
+/gep_clear_event.f/1.1.2.4/Fri Dec 7 21:35:29 2007//Tsane
+/gep_fill_hist.f/1.1.2.2/Wed Nov 7 21:18:13 2007//Tsane
+/gep_init_histid.f/1.1.2.8.2.2/Sun Oct 26 19:12:58 2008//Tsane
+/gep_initialize.f/1.1.2.2.2.1/Fri Jun 5 17:50:27 2009//Tsane
+/gep_keep_results.f/1.1.2.3/Sat Nov 3 08:39:35 2007//Tsane
+/gep_ntuple_change.f/1.1.2.1/Tue May 15 02:54:45 2007//Tsane
+/gep_ntuple_clear.f/1.1.2.1/Tue May 15 02:54:45 2007//Tsane
+/gep_ntuple_close.f/1.1.2.1/Tue May 15 02:54:45 2007//Tsane
+/gep_ntuple_init.f/1.1.2.10/Wed Dec 12 15:56:42 2007//Tsane
+/gep_ntuple_keep.f/1.1.2.10/Wed Dec 12 15:56:42 2007//Tsane
+/gep_ntuple_open.f/1.1.2.2/Fri Sep 7 16:13:02 2007//Tsane
+/gep_ntuple_register.f/1.1.2.1/Tue May 15 02:54:45 2007//Tsane
+/gep_ntuple_shutdown.f/1.1.2.1/Tue May 15 02:54:45 2007//Tsane
+/gep_physics.f/1.1.2.15.2.4/Wed Sep 16 18:52:38 2009//Tsane
+/gep_proper_shutdown.f/1.1.2.1/Tue May 15 02:54:45 2007//Tsane
+/gep_reconstruction.f/1.1.2.3/Fri Sep 7 16:15:26 2007//Tsane
+/gep_register_variables.f/1.1.2.2/Fri Sep 7 16:16:13 2007//Tsane
+/gep_reset_event.f/1.1.2.4.2.1/Sun Oct 26 19:12:33 2008//Tsane
+/gep_tree_init.f/1.1.2.1/Tue Aug 7 19:06:55 2007//Tsane
+/h_apply_offsets.f/1.3/Fri Sep 5 16:36:58 2003//Tsane
+/h_clear_event.f/1.15.24.2/Tue Sep 11 19:14:17 2007//Tsane
+/h_field03.f/1.1.4.1/Tue May 15 02:54:45 2007//Tsane
+/h_fieldcorr.f/1.2/Fri Feb 21 14:55:26 2003//Tsane
+/h_fpp_nt_change.f/1.1.2.1/Wed Aug 22 19:09:16 2007//Tsane
+/h_fpp_nt_close.f/1.1.2.1/Wed Aug 22 19:09:16 2007//Tsane
+/h_fpp_nt_init.f/1.1.2.2/Tue Oct 16 20:20:31 2007//Tsane
+/h_fpp_nt_keep.f/1.1.2.12/Sun Nov 11 08:03:44 2007//Tsane
+/h_fpp_nt_open.f/1.1.2.12/Sun Nov 11 08:03:44 2007//Tsane
+/h_fpp_nt_register.f/1.1.2.1/Wed Aug 22 19:09:16 2007//Tsane
+/h_fpp_nt_shutdown.f/1.1.2.1/Wed Aug 22 19:09:17 2007//Tsane
+/h_fpp_ntup.cwn/1.1.2.10/Sun Nov 11 08:03:44 2007//Tsane
+/h_initialize.f/1.15.24.2/Mon Oct 22 15:16:52 2007//Tsane
+/h_keep_results.f/1.6.24.3.2.2/Fri Jun 5 17:53:25 2009//Tsane
+/h_ntuple_change.f/1.1/Tue Feb 17 17:26:34 2004//Tsane
+/h_ntuple_clear.f/1.1/Wed Feb 24 14:52:36 1999//Tsane
+/h_ntuple_close.f/1.1/Tue Feb 17 17:26:34 2004//Tsane
+/h_ntuple_init.f/1.11.18.5.2.5/Tue Oct 27 15:48:29 2009//Tsane
+/h_ntuple_keep.f/1.10.18.5.2.6/Tue Oct 27 15:48:41 2009//Tsane
+/h_ntuple_open.f/1.1.18.1/Wed Aug 22 19:09:17 2007//Tsane
+/h_ntuple_register.f/1.2/Fri Jun 17 02:54:45 1994//Tsane
+/h_ntuple_shutdown.f/1.6/Tue Feb 17 17:26:34 2004//Tsane
+/h_proper_shutdown.f/1.10/Mon Oct 9 18:55:48 1995//Tsane
+/h_register_variables.f/1.12.24.1/Wed Aug 22 19:09:17 2007//Tsane
+/h_reset_event.f/1.17/Fri Dec 20 21:55:23 2002//Tsane
+/h_sv_nt_init.f/1.6/Tue Nov 5 21:42:08 1996//Tsane
+/h_sv_nt_keep.f/1.5/Tue Nov 5 21:42:28 1996//Tsane
+/h_sv_nt_register.f/1.1/Fri Jan 27 20:05:51 1995//Tsane
+/h_sv_nt_shutdown.f/1.2/Thu Feb 13 15:08:20 2003//Tsane
+/h_tree_init.f/1.1.2.1/Tue Aug 7 19:06:55 2007//Tsane
+/params03.f/1.1.4.1/Tue May 15 02:54:45 2007//Tsane
+/s_apply_offsets.f/1.3/Fri Sep 5 16:41:06 2003//Tsane
+/s_clear_event.f/1.12/Tue Feb 23 18:27:50 1999//Tsane
+/s_fieldcorr.f/1.4/Thu Dec 18 14:38:00 2003//Tsane
+/s_initialize.f/1.16/Wed Sep 4 15:17:01 1996//Tsane
+/s_keep_results.f/1.6/Wed Sep 4 15:17:33 1996//Tsane
+/s_ntuple_change.f/1.1/Tue Feb 17 17:26:34 2004//Tsane
+/s_ntuple_clear.f/1.1/Wed Feb 24 14:50:24 1999//Tsane
+/s_ntuple_close.f/1.1/Tue Feb 17 17:26:33 2004//Tsane
+/s_ntuple_init.f/1.8.18.1/Tue Oct 16 20:20:31 2007//Tsane
+/s_ntuple_keep.f/1.8/Tue Feb 17 17:26:34 2004//Tsane
+/s_ntuple_open.f/1.1/Tue Feb 17 17:26:33 2004//Tsane
+/s_ntuple_register.f/1.2/Fri Jun 17 02:56:26 1994//Tsane
+/s_ntuple_shutdown.f/1.6/Tue Feb 17 17:26:34 2004//Tsane
+/s_proper_shutdown.f/1.11/Mon Oct 9 18:56:25 1995//Tsane
+/s_register_variables.f/1.11/Tue Jan 16 16:27:28 1996//Tsane
+/s_reset_event.f/1.15/Fri Aug 20 14:52:18 1999//Tsane
+/s_sv_nt_init.f/1.4/Tue Dec 1 15:58:54 1998//Tsane
+/s_sv_nt_keep.f/1.3/Tue Nov 5 21:44:04 1996//Tsane
+/s_sv_nt_register.f/1.1/Fri Aug 11 16:23:06 1995//Tsane
+/s_sv_nt_shutdown.f/1.2/Wed Feb 12 16:03:21 2003//Tsane
+D
diff --git a/ENGINE/CVS/Repository b/ENGINE/CVS/Repository
new file mode 100644
index 0000000..ac407ab
--- /dev/null
+++ b/ENGINE/CVS/Repository
@@ -0,0 +1 @@
+Analyzer/ENGINE
diff --git a/ENGINE/CVS/Root b/ENGINE/CVS/Root
new file mode 100644
index 0000000..6288c3f
--- /dev/null
+++ b/ENGINE/CVS/Root
@@ -0,0 +1 @@
+whit@cvs.jlab.org:/group/hallc/cvsroot
diff --git a/ENGINE/CVS/Tag b/ENGINE/CVS/Tag
new file mode 100644
index 0000000..25d73f7
--- /dev/null
+++ b/ENGINE/CVS/Tag
@@ -0,0 +1 @@
+Tsane
diff --git a/ENGINE/Makefile b/ENGINE/Makefile
new file mode 100644
index 0000000..75ec04d
--- /dev/null
+++ b/ENGINE/Makefile
@@ -0,0 +1,8 @@
+#
+# $Log: Makefile,v $
+# Revision 1.1 1998/12/07 22:11:16 saw
+# Initial setup
+#
+ETC=../etc
+
+include $(ETC)/Makefile.NEW
diff --git a/ENGINE/Makefile.Unix b/ENGINE/Makefile.Unix
new file mode 100644
index 0000000..1a959f9
--- /dev/null
+++ b/ENGINE/Makefile.Unix
@@ -0,0 +1,371 @@
+#
+# $Log: Makefile.Unix,v $
+# Revision 1.28.16.10.2.1 2008/05/15 18:59:21 bhovik
+# 1'st version
+#
+# Revision 1.28.16.10 2007/11/03 08:40:02 cdaq
+# added gep_hist_fill.f
+#
+# Revision 1.28.16.9 2007/10/16 19:44:00 cdaq
+# fixed F1TDC_WINDOW_SIZE declaration
+#
+# Revision 1.28.16.8 2007/10/08 19:19:05 puckett
+# Added bad channel list handling for BigCal
+#
+# Revision 1.28.16.7 2007/09/13 04:02:17 brash
+# Implement some minor changes to fix Mac OS X runtime errors ... ejb
+#
+# Revision 1.28.16.6 2007/09/10 20:08:01 pcarter
+# Implemented changes to allow compilation on RHEL 3,4,5 and MacOSX
+#
+# Revision 1.28.16.5 2007/08/22 19:09:16 frw
+# added FPP
+#
+# Revision 1.29 2006/06/23 frw
+# added HMS FPP
+#
+# Revision 1.28.16.4 2007/08/15 21:40:59 puckett
+# Added call to skeleton routine "gep_init_histid" for coincidence histograms for later
+#
+# Revision 1.28.16.3 2007/08/07 18:55:30 puckett
+# added compiler directives for tree init routines
+#
+# Revision 1.28.16.2 2007/06/20 18:26:32 puckett
+# Added BigCal Monte Carlo analysis capability
+#
+# Revision 1.28.16.1 2007/05/15 02:55:01 jones
+# Start to Bigcal code
+#
+# Revision 1.28.8.2 2004/09/07 18:02:56 cdaq
+# updated to check magnets and beam positions
+#
+# Revision 1.28.8.1 2004/06/30 19:34:55 cdaq
+# Add g_examine_picture_event.f (DJG)
+#
+# Revision 1.28 2004/02/18 14:06:53 jones
+# Updated compile subroutines needed to allow the possibility of segmenting rzdat files.
+#
+# Revision 1.27.2.1 2003/06/26 12:39:53 cdaq
+# changes for e01-001 (mkj)
+#
+# Revision 1.27 2003/02/21 14:47:46 jones
+# Add s_fieldcorr.f to list of SOS files to compile
+#
+# Revision 1.26 2002/09/24 20:21:18 jones
+# add g_apply_offsets.f,h_apply_offsets.f,s_apply_offsets.f,h_fieldcorr.f
+#
+# Revision 1.25 1999/11/04 20:35:14 saw
+# Linux/G77 compatibility fixes
+#
+# Revision 1.24 1999/08/20 14:52:17 saw
+# Put in warning if Xscin_tdc_max is bigger than 4094
+#
+# Revision 1.23 1999/02/23 16:27:42 csa
+# Add new routines
+#
+# Revision 1.22 1999/01/21 21:39:01 saw
+# Clean up Include file rules
+#
+# Revision 1.21 1998/12/09 16:31:16 saw
+# Remove dependence on Csoft environment variable
+#
+# Revision 1.20 1998/12/07 22:11:16 saw
+# Initial setup
+#
+# Revision 1.19 1996/11/05 21:45:30 saw
+# (SAW) Add AIX and SunOS support and fixes for Linux
+#
+# Revision 1.18 1996/09/04 14:29:35 saw
+# (SAW) Add new routines, OSD switches, and Linux compatibility fixes
+#
+# Revision 1.17 1996/04/29 18:30:05 saw
+# (SAW) New makefile style
+#
+# Revision 1.16 1996/01/22 15:56:58 saw
+# (JRA) Add g_analyze_beam_pedestal, g_analyze_misc,
+# g_calc_beam_pedestal, g_calc_bpm_pedestal,
+# g_calc_raster_pedestal, g_target_initialize, g_trans_misc
+#
+# Revision 1.15 1996/01/16 16:03:10 cdaq
+# (SAW) Add g_scaler_reset_event, g_extract_kinematics, g_output_thresholds,
+# g_examine_go_info, g_kludgeup_kinematics, s_sv_nt_init, s_sv_nt_keep,
+# s_sv_nt_register, s_sv_nt_shutdown
+#
+# Revision 1.14 1995/07/28 14:13:32 cdaq
+# (SAW) Add new routines, SGI/IRIX compatibility
+#
+# Revision 1.13 1995/05/24 13:20:54 cdaq
+# Cosmetic changes
+#
+# Revision 1.12 1995/05/11 19:03:10 cdaq
+# (SAW) Compile c_physics.f and some ntuple variable registration routines
+#
+# Revision 1.11 1995/04/06 20:05:30 cdaq
+# (SAW) Add pedestal routines
+#
+# Revision 1.10 1995/03/08 20:32:52 cdaq
+# (SAW) Add -f switch on include file copy commands
+#
+# Revision 1.9 1995/01/27 20:48:08 cdaq
+# (SAW) Add sieve slit routines
+#
+# Revision 1.8 1994/11/23 15:37:39 cdaq
+# (SAW) Update link flags for ULTRIX
+#
+# Revision 1.7 1994/08/18 04:22:46 cdaq
+# (SAW) Call makereg generated routines to register variables
+#
+# Revision 1.6 1994/08/04 03:49:53 cdaq
+# (SAW) Add libhack.a to library list
+#
+# Revision 1.5 1994/07/07 15:18:22 cdaq
+# (SAW) Fix a bug so that all sources not get compiled
+#
+# Revision 1.4 1994/06/22 21:04:29 cdaq
+# (SAW) Add g_analyze_scalers.f
+#
+# Revision 1.3 1994/06/14 19:30:33 cdaq
+# (SAW) Add g_dump_histograms, remove g_open_hbook_file
+#
+# Revision 1.2 1994/06/07 18:47:48 cdaq
+# Add examine_event routines
+#
+# Revision 1.1 1994/04/15 20:27:32 cdaq
+# Initial revision
+#
+NEWSTYLE = 1
+include ../../etc/Makefile
+include ../../etc/Makefile.flags
+
+decode_source = g_decode_clear.f g_decode_config.f g_decode_event_by_banks.f \
+ g_decode_fb_bank.f g_decode_fb_detector.f \
+ g_decode_init.f g_analyze_scalers.f
+general_source = $(decode_source) g_clear_event.f \
+ g_init_filenames.f g_initialize.f g_keep_results.f \
+ g_open_source.f g_proper_shutdown.f g_reconstruction.f \
+ g_reset_event.f g_register_variables.f \
+ g_examine_control_event.f \
+ g_examine_physics_event.f g_dump_histograms.f g_analyze_pedestal.f \
+ g_calc_pedestal.f g_ctp_database.f g_scaler_reset_event.f \
+ g_extract_kinematics.f g_output_thresholds.f \
+ g_examine_go_info.f g_kludgeup_kinematics.f \
+ g_analyze_beam_pedestal.f g_analyze_misc.f \
+ g_calc_beam_pedestal.f g_calc_bpm_pedestal.f g_calc_raster_pedestal.f \
+ g_target_initialize.f g_trans_misc.f g_dump_peds.f g_get_next_event.f \
+ g_preproc_event.f g_preproc_open.f g_write_event.f \
+ g_examine_epics_event.f g_examine_picture_event.f\
+ g_analyze_scaler_bank.f g_analyze_scalers_by_banks.f g_apply_offsets.f \
+ h_field03.f params03.f g_tree_init.f
+hms_source = h_clear_event.f h_initialize.f h_keep_results.f \
+ h_proper_shutdown.f h_reset_event.f \
+ h_register_variables.f h_apply_offsets.f h_fieldcorr.f \
+ h_ntuple_close.f h_ntuple_open.f h_ntuple_change.f \
+ h_tree_init.f
+sos_source = s_clear_event.f s_initialize.f s_keep_results.f \
+ s_proper_shutdown.f s_reset_event.f \
+ s_register_variables.f s_apply_offsets.f s_fieldcorr.f \
+ s_ntuple_close.f s_ntuple_open.f s_ntuple_change.f
+coin_source = c_register_variables.f c_clear_event.f c_initialize.f \
+ c_keep_results.f c_proper_shutdown.f c_reconstruction.f \
+ c_reset_event.f c_physics.f \
+ c_ntuple_close.f c_ntuple_open.f c_ntuple_change.f
+bigcal_source = b_clear_event.f b_initialize.f b_keep_results.f b_ntuple_change.f \
+ b_ntuple_close.f b_ntuple_open.f b_proper_shutdown.f b_register_variables.f \
+ b_reset_event.f bigcal_mc_reconstruction.f b_tree_init.f
+gep_source = gep_clear_event.f gep_initialize.f gep_keep_results.f gep_ntuple_change.f \
+ gep_ntuple_close.f gep_ntuple_open.f gep_physics.f gep_proper_shutdown.f \
+ gep_reconstruction.f gep_register_variables.f gep_reset_event.f \
+ gep_tree_init.f gep_init_histid.f gep_check_bigcal.f gep_fill_hist.f
+ntuple_source = g_ntuple_init.f g_ntuple_shutdown.f \
+ c_ntuple_clear.f c_ntuple_init.f c_ntuple_keep.f \
+ c_ntuple_register.f c_ntuple_shutdown.f \
+ h_ntuple_clear.f h_ntuple_init.f h_ntuple_keep.f \
+ h_ntuple_register.f h_ntuple_shutdown.f \
+ s_ntuple_clear.f s_ntuple_init.f s_ntuple_keep.f \
+ s_ntuple_register.f s_ntuple_shutdown.f \
+ h_sv_nt_init.f h_sv_nt_keep.f \
+ h_sv_nt_register.f h_sv_nt_shutdown.f \
+ s_sv_nt_init.f s_sv_nt_keep.f \
+ s_sv_nt_register.f s_sv_nt_shutdown.f \
+ h_fpp_nt_change.f h_fpp_nt_close.f \
+ h_fpp_nt_init.f h_fpp_nt_keep.f \
+ h_fpp_nt_open.f h_fpp_nt_register.f \
+ h_fpp_nt_shutdown.f \
+ b_ntuple_clear.f b_ntuple_init.f b_ntuple_keep.f \
+ b_ntuple_register.f b_ntuple_shutdown.f \
+ gep_ntuple_clear.f gep_ntuple_init.f gep_ntuple_keep.f \
+ gep_ntuple_register.f gep_ntuple_shutdown.f
+gmakeregstuff = r_gen_filenames.f r_gen_run_info.f r_gen_event_info.f \
+ r_gen_scalers.f r_gen_run_pref.f r_gen_data_structures.f \
+ r_gen_decode_F1tdc.f
+cmakeregstuff = r_coin_filenames.f r_c_ntuple.f r_coin_data_structures.f
+hmakeregstuff = r_h_ntuple.f r_h_sieve_ntuple.f r_hms_data_structures.f \
+ r_hms_fpp_event.f r_h_fpp_ntuple.f
+smakeregstuff = r_s_ntuple.f r_sos_data_structures.f
+bmakeregstuff = r_b_ntuple.f r_bigcal_data_structures.f r_bigcal_filenames.f
+gepmakeregstuff = r_gep_ntuple.f r_gep_filenames.f r_gep_data_structures.f
+replay_source = engine.f
+
+libsources = $(coin_source) $(sos_source) $(hms_source) $(general_source) \
+ $(bigcal_source) $(gep_source) $(ntuple_source) $(gmakeregstuff) \
+ $(cmakeregstuff) $(hmakeregstuff) $(smakeregstuff) $(bmakeregstuff) \
+ $(gepmakeregstuff)
+
+ifeq ($(MYOS),AIX)
+xlibsources := $(filter-out g_decode_config.f,$(libsources))
+libsources = g_decode_config_aix.f $(xlibsources)
+../g_%_aix.f : ../g_%.f
+ sed -e "s/READONLY/action='read'/"< $< > $@
+endif
+
+ifeq ($(MYOS),Linux)
+xlibsources := $(filter-out g_decode_config.f,$(libsources))
+libsources = g_decode_config_linux.f $(xlibsources)
+# F2C doesn't know about READONLY
+../g_%_linux.f : ../g_%.f
+ sed -e "s/,READONLY//" $< > $@
+endif
+
+#short_names = g_xyz_sph.f g_shift_len.f g_sort.f g_rep_err.f g_prepend.f \
+# g_normalize.f g_add_path.f g_decode_clear.f
+sources = $(libsources) $(replay_source)
+#engine_members:= $(patsubst %.f, libengine.a(%.o), $(libsources))
+lib_targets := $(patsubst %.f, libengine.a(%.o), $(sources))
+bin_targets = engine
+
+#install-dirs := lib bin
+install-dirs := lib
+
+DEPLIBS = $(LIBROOT)/libengine.a \
+ $(LIBROOT)/libhtracking.a $(LIBROOT)/libstracking.a \
+ $(LIBROOT)/libengine.a \
+ $(LIBROOT)/libtracking.a $(LIBROOT)/libhack.a \
+ $(LIBROOT)/libbtracking.a $(LIBROOT)/libsanetracking.a \
+ $(LIBROOT)/libutils.a #$(LIBROOT)/libctp.a
+#$(LIBROOT)/libgmc.a
+
+ifeq ($(MYOS),HPUX)
+# OTHERLIBS = -Wl,-L$(CODA)/HP_UX/lib \
+# -lcoda -Wl,-L$(CERN_ROOT)/lib -lpacklib
+ OTHERLIBS = -Wl,-L$(CERN_ROOT)/lib -lpacklib -lU77 -lm
+endif
+
+ifeq ($(MYOS),ULTRIX)
+ RPCLIBDIR = /usr/site1/rpc/usr/lib
+ OTHERLIBS = -L$(CODA)/ULTRIX/lib -lcoda -L$(CERN_ROOT)/lib -lpacklib \
+ -L$(RPCLIBDIR) -lrpclib
+endif
+
+ifeq ($(MYOS),OSF1)
+ OTHERLIBS = -L$(CERN_ROOT)/lib -lpacklib
+ FLDFLAGS= -g -Wl,-taso
+endif
+
+ifeq ($(MYOS),IRIX)
+ RPCLIBDIR = /usr/lib
+ OTHERLIBS = -L$(CERN_ROOT)/lib -lpacklib -L$(RPCLIBDIR) -lrpcsvc
+endif
+
+ifeq ($(MYOS),Linux)
+ ifeq ($(MYREALOS),Darwin)
+ OTHERLIBS = -L$(CERN_ROOT)/lib -lpacklib -lc -lm
+ else
+ OTHERLIBS = -L$(CERN_ROOT)/lib -lpacklib -lc -lm -lnsl
+ endif
+ DEPLIBS := $(DEPLIBS) $(LIBROOT)/libport.a
+
+$(LIBROOT)/libport.a:
+ $(MAKE) -C ../../PORT
+endif
+
+ifeq ($(MYOS),SunOS)
+ OTHERLIBS = -L$(LIBROOT) -lctpclient -lctp -L$(CERN_ROOT)/lib \
+ -lgeant$(GEANTVER) -lpawlib -lgraflib -lgrafX11 -lpacklib -lmathlib \
+ -lnsl -lsocket -lX11
+endif
+
+ifeq ($(MYOS),AIX)
+ OTHERLIBS = -L$(CERN_ROOT)/lib -lpacklib
+ DEPLIBS := $(DEPLIBS) $(LIBROOT)/libport.a
+endif
+
+#ifeq ($(MYOS),Linux)
+## F2C doesn't know about READONLY
+#../g_decode_config.f : $(NFSDIRECTORY)/ENGINE/g_decode_config.f
+# sed -e "s/,READONLY//" $< > $@
+#endif
+
+#default:
+# @echo "nothing to make"
+
+##library: libengine.a
+
+##libengine.a: $(engine_members)
+
+$(LIBROOT)/libutils.a:
+ $(MAKE) -C ../../UTILSUBS
+
+$(LIBROOT)/libtracking.a:
+ $(MAKE) -C ../../TRACKING
+
+$(LIBROOT)/libhtracking.a:
+ $(MAKE) -C ../../HTRACKING
+
+$(LIBROOT)/libstracking.a:
+ $(MAKE) -C ../../STRACKING
+
+$(LIBROOT)/libbtracking.a:
+ $(MAKE) -C ../../BTRACKING
+
+$(LIBROOT)/libsanetracking.a:
+ $(MAKE) -C ../../SANE
+
+$(LIBROOT)/libctp.a:
+ $(MAKE) -C ../../CTP
+
+$(LIBROOT)/libhack.a:
+ $(MAKE) -C ../../HACK
+
+ifeq ($(MYOS),OSF1)
+engine: $(DEPLIBS)
+ $(AR) x $(LIBROOT)/libengine.a engine.o
+ $(FC) $(FLDFLAGS) -o engine engine.o $(DEPLIBS) $(OTHERLIBS)
+ $(RM) engine.o
+else
+engine: $(DEPLIBS)
+ $(AR) x $(LIBROOT)/libengine.a engine.o
+ $(FC) $(FFLAGS) -o engine engine.o $(DEPLIBS) $(OTHERLIBS)
+ $(RM) engine.o
+endif
+
+ifdef NFSDIRECTORY
+../%.f : $(NFSDIRECTORY)/ENGINE/%.f
+ ln -s $< $@
+
+.PRECIOUS: ../%.f
+else
+#
+# Rule for making the register subroutines
+#
+../r_%.f : ../%.cmn $(MAKEREG)
+ (cd .. ; $(MAKEREG) $(<F) -o $(@F) -e /dev/null)
+
+.PRECIOUS: ../r_%.f
+endif
+
+%.cwn:: ../%.cwn
+ $(CP) $< $@
+
+%.cmn ../%.cmn:: ../../INCLUDE/%.cmn
+ $(CP) $< $@
+
+%.dec ../%.dec:: ../../INCLUDE/%.dec
+ $(CP) $< $@
+
+%.par ../%.par:: ../../INCLUDE/%.par
+ $(CP) $< $@
+
+%.dte ../%.dte:: ../../INCLUDE/%.dte
+ $(CP) $< $@
+
+include $(sources:.f=.d)
diff --git a/ENGINE/b_clear_event.f b/ENGINE/b_clear_event.f
new file mode 100755
index 0000000..fbacb1f
--- /dev/null
+++ b/ENGINE/b_clear_event.f
@@ -0,0 +1,161 @@
+ subroutine B_clear_event(ABORT,err)
+
+ IMPLICIT NONE
+ SAVE
+*
+ character*13 here
+ parameter (here= 'B_clear_event')
+*
+ logical ABORT
+ character*(*) err
+
+ include 'bigcal_data_structures.cmn'
+ include 'b_ntuple.cmn'
+ include 'bigcal_gain_parms.cmn'
+ include 'bigcal_filenames.cmn'
+ include 'bigcal_bypass_switches.cmn'
+c include 'bigcal_statistics.cmn'
+ include 'bigcal_shower_parms.cmn'
+
+ integer i,j,k
+
+ bigcal_annoying_pulser_event = .false.
+ BIGCAL_TDC_NHIT = 0
+ BIGCAL_TDC_NDECODED = 0
+ BIGCAL_TIME_NGOOD = 0
+ BIGCAL_ATRIG_NHIT = 0
+ BIGCAL_ATRIG_NGOOD = 0
+ BIGCAL_TTRIG_NHIT = 0
+ BIGCAL_TTRIG_NDECODED = 0
+ BIGCAL_TTRIG_NGOOD = 0
+ BIGCAL_PROT_NHIT = 0
+ BIGCAL_RCS_NHIT = 0
+ BIGCAL_PROT_NGOOD = 0
+ BIGCAL_RCS_NGOOD = 0
+ bigcal_all_ngood = 0
+c$$$ bigcal_all_nclstr = 0
+c$$$ bigcal_phys_ntrack = 0
+
+ bigcal_prot_nbad = 0
+ bigcal_rcs_nbad = 0
+ bigcal_atrig_nbad = 0
+
+ bigcal_max_adc = 0.
+ bigcal_iymax_adc = 0
+ bigcal_ixmax_adc = 0
+
+* zero "detector" arrays:
+
+ do i=1,BIGCAL_PROT_MAXHITS
+ BIGCAL_PROT_RAW_DET(i) = 0
+ BIGCAL_PROT_GOOD_DET(i) = 0.
+c BIGCAL_PROT_GOOD_HIT(i) = .false.
+ bigcal_all_adc_det(i) = 0.
+ bigcal_all_good_det(i) = 0.
+
+ bigcal_prot_nhit_ch(i) = 0
+ enddo
+
+ do i=1,BIGCAL_RCS_MAXHITS
+ BIGCAL_RCS_RAW_DET(i) = 0
+ BIGCAL_RCS_GOOD_DET(i) = 0.
+c BIGCAL_RCS_GOOD_HIT(i) = .false.
+ bigcal_all_adc_det(i+bigcal_prot_maxhits)=0.
+ bigcal_all_good_det(i+bigcal_prot_maxhits) = 0.
+
+ bigcal_rcs_nhit_ch(i) = 0
+ enddo
+
+ do i=1,BIGCAL_MAX_TDC
+ bigcal_tdc_det_nhit(i) = 0
+ bigcal_tdc_det_ngood(i) = 0
+ bigcal_tdc_sum8(i) = 0.
+ do j=1,8
+ BIGCAL_TDC_RAW_DET(i,j) = 0
+ bigcal_tdc_good_det(i,j) = -9999.
+ enddo
+ enddo
+
+ do i=1,bigcal_atrig_maxhits
+ bigcal_atrig_raw_det(i) = 0
+ bigcal_atrig_good_det(i) = 0.
+ bigcal_atrig_sum64(i) = 0.
+
+ bigcal_atrig_nhit_ch(i) = 0
+ enddo
+
+ do i=1,bigcal_ttrig_maxgroups
+ bigcal_ttrig_det_nhit(i) = 0
+ bigcal_ttrig_det_ngood(i) = 0
+ do j=1,8
+ bigcal_ttrig_raw_det(i,j) = 0
+ bigcal_ttrig_good_det(i,j) = -9999.
+ enddo
+ enddo
+
+c$$$ do i=30,35
+c$$$ do j=1,32
+c$$$ bigcal_mid_ehit(i,j) = 0.
+c$$$ bigcal_mid_xhit(i,j) = 0.
+c$$$ bigcal_mid_yhit(i,j) = 0.
+c$$$ enddo
+c$$$ enddo
+
+c we probably need to clear out the cluster arrays too!!!!
+
+ bigcal_all_nclstr = 0
+ bigcal_phys_ntrack = 0
+ bigcal_nmaxima = 0
+
+c$$$ bigcal_best_thetarad = 0.
+c$$$ bigcal_best_thetadeg = 0.
+c$$$ bigcal_best_phirad = 0.
+c$$$ bigcal_best_phideg = 0.
+c$$$ bigcal_best_energy = 0.
+c$$$ bigcal_best_time = 0.
+c$$$ bigcal_best_xface = 0.
+c$$$ bigcal_best_yface = 0.
+c$$$ bigcal_best_zface = 0.
+c$$$ bigcal_best_px = 0.
+c$$$ bigcal_best_py = 0.
+c$$$ bigcal_best_pz = 0.
+c$$$ bigcal_best_beta = 0.
+c$$$ bigcal_best_tof = 0.
+c$$$ bigcal_best_coin_time = 0.
+c$$$
+c$$$ do i=1,bigcal_max_ntrack
+c$$$ bigcal_track_thetarad(i) = 0.
+c$$$ bigcal_track_thetadeg(i) = 0.
+c$$$ bigcal_track_phirad(i) = 0.
+c$$$ bigcal_track_phideg(i) = 0.
+c$$$ bigcal_track_energy(i) = 0.
+c$$$ bigcal_track_time(i) = 0.
+c$$$ bigcal_track_xface(i) = 0.
+c$$$ bigcal_track_yface(i) = 0.
+c$$$ bigcal_track_zface(i) = 0.
+c$$$ bigcal_track_px(i) = 0.
+c$$$ bigcal_track_py(i) = 0.
+c$$$ bigcal_track_pz(i) = 0.
+c$$$ bigcal_track_beta(i) = 0.
+c$$$ bigcal_track_tof(i) = 0.
+c$$$ bigcal_track_coin_time(i) = 0.
+c$$$ enddo
+
+ nclust = 0
+ nclust8 = 0
+ nclust64=0
+ ntrack = 0
+ ibest=0
+ nmax = 0
+ ntrk_g = 0
+
+ bigcal_itrack_best = 0
+
+* don't need to do anything with hit arrays, since they are filled dynamically
+* (other than zeroing the numbers of hits)
+ call b_ntuple_clear
+
+ ABORT=.false.
+ err = ' '
+ return
+ end
diff --git a/ENGINE/b_cosmic_ntuple_init.f b/ENGINE/b_cosmic_ntuple_init.f
new file mode 100644
index 0000000..8ea2178
--- /dev/null
+++ b/ENGINE/b_cosmic_ntuple_init.f
@@ -0,0 +1,173 @@
+ subroutine b_cosmic_ntuple_init(ABORT,err)
+*----------------------------------------------------------------------
+*
+* Creates an Bigcal cosmic Ntuple
+*
+* Purpose :
+*
+* Output: ABORT - success or failure
+* : err - reason for failure, if any
+*
+*----------------------------------------------------------------------
+ implicit none
+ save
+*
+ character*13 here
+ parameter (here='_init')
+*
+ logical ABORT
+ character*(*) err
+*
+ INCLUDE 'gen_routines.dec'
+ INCLUDE 'gen_run_info.cmn'
+ INCLUDE 'sos_minerva.cmn'
+
+
+*
+ character*80 default_name
+ parameter (default_name= 'ssieventuple')
+ character*80 default_title
+ parameter (default_title= 'sSieveSlits')
+ integer default_bank,default_recL
+ parameter (default_bank= 8000) !4 bytes/word
+ parameter (default_recL= 1024) !record length
+ character*80 title,file
+ character*80 directory,name
+ character*1000 pat,msg
+ integer status,size,io,id,bank,recL,iv(10),m
+* parameter (id = 1)
+ real rv(10)
+*
+ logical HEXIST !CERNLIB function
+ INCLUDE 's_sieve_ntuple.cmn'
+ INCLUDE 's_sieve_ntuple.dte'
+*
+*--------------------------------------------------------
+ err= ' '
+ ABORT = .FALSE.
+*
+ IF(s_sieve_Ntuple_exists) THEN
+ call s_sv_Nt_shutdown(ABORT,err)
+ If(ABORT) Then
+ call G_add_path(here,err)
+ RETURN
+ EndIf
+ ENDIF
+*
+
+ s_sieve_Ntuple_ID= default_s_sieve_Ntuple_ID
+ s_sieve_Ntuple_name= default_name
+ s_sieve_Ntuple_title= default_title
+
+ call NO_nulls(s_sieve_Ntuple_file) !replace null characters with blanks
+*
+*-if name blank, just forget it
+ IF(s_sieve_Ntuple_file.EQ.' ') RETURN !do nothing
+*
+*- get any free IO channel
+*
+ call g_IO_control(io,'ANY',ABORT,err)
+ s_sieve_Ntuple_exists= .NOT.ABORT
+ IF(ABORT) THEN
+ call G_add_path(here,err)
+ RETURN
+ ENDIF
+ s_sieve_Ntuple_IOchannel= io
+*
+ id= s_sieve_Ntuple_ID
+*
+
+ ABORT= HEXIST(id)
+ IF(ABORT) THEN
+ call g_IO_control(s_sieve_Ntuple_IOchannel,'FREE',ABORT,err)
+ call G_build_note(':HBOOK id#$ already in use',
+ & '$',id,' ',rv,' ',err)
+ call G_add_path(here,err)
+ RETURN
+ ENDIF
+*
+
+ CALL HCDIR(directory,'R') !CERNLIB read current directory
+
+*
+*
+ id= s_sieve_Ntuple_ID
+ name= s_sieve_Ntuple_name
+
+ file= s_sieve_Ntuple_file
+ call g_sub_run_number(file,gen_run_number)
+
+ recL= default_recL
+ io= s_sieve_Ntuple_IOchannel
+*
+*-open New *.rzdat file-
+ call HROPEN(io,name,file,'N',recL,status) !CERNLIB
+* !directory set to "//TUPLE"
+ io= s_sieve_Ntuple_IOchannel
+ ABORT= status.NE.0
+ IF(ABORT) THEN
+ call g_IO_control(s_sieve_Ntuple_IOchannel,'FREE',ABORT,err)
+ iv(1)= status
+ iv(2)= io
+ pat= ':HROPEN error#$ opening IO#$ "'//file//'"'
+ call G_build_note(pat,'$',iv,' ',rv,' ',err)
+ call G_add_path(here,err)
+ RETURN
+ ENDIF
+ s_sieve_Ntuple_file= file
+*
+ title= s_sieve_Ntuple_title
+ IF(title.EQ.' ') THEN
+ msg= name//' '//s_sieve_Ntuple_file
+ call only_one_blank(msg)
+ title= msg
+ s_sieve_Ntuple_title= title
+ ENDIF
+*
+
+ id= s_sieve_Ntuple_ID
+ io= s_sieve_Ntuple_IOchannel
+ name= s_sieve_Ntuple_name
+ title= s_sieve_Ntuple_title
+ size= s_sieve_Ntuple_size
+ file= s_sieve_Ntuple_file
+ bank= default_bank
+
+ Call Hbnt(id,name,' ') ! create CWN Ntuple
+*
+* define Ntuple structure
+*
+ call HBNAME(id,'SOS fp',s_xfp,'s_xfp:R*4,s_xpfp:R*4,s_yfp:R*4,
+ & s_ypfp:R*4,s_delta:R*4')
+ call HBNAME(id,'SOS_MINE',n_minerva_hits,'n_minerva_hits[0,40]:I,
+ & plane(n_minerva_hits):I,fiber(n_minerva_hits):I,
+ & ADC(n_minerva_hits):I')
+
+***** call HBOOKN(id,title,size,name,bank,s_sieve_Ntuple_tag) !create Ntuple
+*
+ call HCDIR(s_sieve_Ntuple_directory,'R') !record Ntuple directory
+*
+ CALL HCDIR(directory,' ') !reset CERNLIB directory
+
+*
+ s_sieve_Ntuple_exists= HEXIST(s_sieve_Ntuple_ID)
+ ABORT= .NOT.s_sieve_Ntuple_exists
+*
+ iv(1)= id
+ iv(2)= io
+ pat= 'Ntuple id#$ [' // s_sieve_Ntuple_directory // '/]' //
+ & name // ' IO#$ "' // file // '"'
+ call G_build_note(pat,'$',iv,' ',rv,' ',msg)
+ call sub_string(msg,' /]','/]')
+*
+ IF(ABORT) THEN
+ err= ':unable to create '//msg
+ call G_add_path(here,err)
+ ELSE
+ pat= ':created '//msg
+ call G_add_path(here,pat)
+ call G_log_message('INFO: '//pat)
+ ENDIF
+*
+ RETURN
+ END
diff --git a/ENGINE/b_initialize.f b/ENGINE/b_initialize.f
new file mode 100755
index 0000000..e84311c
--- /dev/null
+++ b/ENGINE/b_initialize.f
@@ -0,0 +1,199 @@
+ subroutine b_initialize(ABORT,err)
+
+ implicit none
+ save
+
+ character*12 here
+ parameter(here='b_initialize')
+
+ logical ABORT
+ character*(*) err
+ character*20 mss
+ integer*4 istat
+
+ logical fail
+ character*1000 why
+ character*80 filename
+ integer*4 iochan
+ integer*4 i,j,Nred
+ integer*4 irow,icol
+
+ include 'gen_run_info.cmn'
+ include 'bigcal_data_structures.cmn'
+ include 'bigcal_filenames.cmn'
+ include 'bigcal_bypass_switches.cmn'
+
+ err = ' '
+ abort = .false.
+
+c "calculate physics singles constants"
+ call b_init_physics(FAIL,why)
+ if(err.ne.' '.and.why.ne.' ') then
+ call G_append(err,' & '//why)
+ else if(why.ne.' ') then
+ err = why
+ endif
+ abort = abort .or. fail
+
+ call b_generate_geometry ! initialize geometry constants
+
+ call b_init_tof(FAIL,why) ! initialize timing constants
+ if(why.ne.' '.and.err.ne.' ') then
+ call G_append(err,' & '//why)
+ else if(why.ne.' ') then
+ err = why
+ endif
+ abort=abort.or.fail
+
+ call b_init_gain(FAIL,why) ! initialize calibration constants
+ if(why.ne.' '.and.err.ne.' ') then
+ call G_append(err,' & '//why)
+ else if(why.ne.' ') then
+ err = why
+ endif
+ abort=abort.or.fail
+
+ call b_init_shower(FAIL,why) ! initialize shower reconstruction parms
+ if(why.ne.' '.and.err.ne.' ') then
+ call G_append(err,' & '//why)
+ else if(why.ne.' ') then
+ err = why
+ endif
+ abort=abort.or.fail
+
+c initialize calibration stuff. Always try to read an old matrix. If
+c b_calib_matrix_filename is given, use that file. Otherwise, use a
+c default filename of 'outfiles/bigcal_calib'
+
+ if(bigcal_do_calibration.ne.0.and. .not. abort) then
+c count up the number of channels to calibrate for the reduced matrix:
+c$$$ Nred=0
+c$$$ if(bigcal_calib_iylo.ge.1.and.bigcal_calib_iylo.le.56.and.
+c$$$ $ bigcal_calib_iyhi.ge.1.and.bigcal_calib_iyhi.le.56.and.
+c$$$ $ bigcal_calib_iyhi.gt.bigcal_calib_iylo) then
+c$$$ if(bigcal_calib_ixlo(1).ge.1.and.bigcal_calib_ixlo(1).le.32
+c$$$ $ .and.bigcal_calib_ixhi(1).ge.1.and.bigcal_calib_ixhi(1)
+c$$$ $ .le.32.and.bigcal_calib_ixhi(1).gt.bigcal_calib_ixlo(1)) then
+c$$$ if(bigcal_calib_ixlo(2).ge.1.and.bigcal_calib_ixlo(2).le.30
+c$$$ $ .and.bigcal_calib_ixhi(2).ge.1.and.bigcal_calib_ixhi(2)
+c$$$ $ .le.30.and.bigcal_calib_ixhi(2).gt.bigcal_calib_ixlo(2)) then
+c$$$ Nred=0
+c$$$
+c$$$ do i=1,bigcal_all_maxhits
+c$$$ if(i.le.1024) then
+c$$$ irow = i/32 + 1
+c$$$ icol = mod(i,32) + 1
+c$$$ else
+c$$$ j=i-1024
+c$$$ irow = j/30 + 33
+c$$$ icol = mod(j,30) + 1
+c$$$ endif
+c$$$
+c$$$ if(irow.ge.bigcal_calib_iylo.and.irow.le.bigcal_calib_iyhi) then
+c$$$ if(irow.le.32) then
+c$$$ if(icol.ge.bigcal_calib_ixlo(1).and.icol.le.bigcal_calib_ixhi(1)) then
+c$$$ Nred = Nred + 1
+c$$$ endif
+c$$$ else
+c$$$ if(icol.ge.bigcal_calib_ixlo(2).and.icol.le.bigcal_calib_ixhi(2)) then
+c$$$ Nred = Nred + 1
+c$$$ endif
+c$$$ endif
+c$$$
+c$$$ endif
+c$$$ enddo
+c$$$ endif
+c$$$ endif
+c$$$ endif
+c$$$
+c$$$ bigcal_Ncalib = Nred
+c$$$
+c$$$ write(*,*) 'Number of channels in reduced calibration matrix=',Nred
+
+ if(b_calib_matrix_filename.ne.' ') then
+ filename = b_calib_matrix_filename
+
+ call g_IO_control(iochan,'ANY',ABORT,err)
+ if(abort) then
+ call g_add_path(here,err)
+ return
+ endif
+
+ bigcal_matr_iochan = iochan
+
+ open(unit=iochan,file=filename,status='old',
+ $ form='unformatted',err=34)
+
+c successful open: read BigCal matrix and number of events:
+ read(iochan,end=35,err=35) bigcal_nmatr_event
+ read(iochan,end=35,err=35) bigcal_vector
+ read(iochan,end=35,err=35) bigcal_matrix
+
+ write(*,*) 'read old BigCal calibration matrix from '//filename
+ write(*,*) 'Number of events in matrix = ',bigcal_nmatr_event
+
+c any read problems will trigger a reset of the calibration
+c quantities to zero.
+c a successful read means the calib. matrix quantities are
+c successfully initialized to their "old" values.
+
+ goto 36
+
+ 34 write(*,*) filename//' does not exist'//
+ $ ', initializing BigCal calib. matrix to zero'
+
+c if there is any trouble reading in the values, scrap and
+c start over:
+
+ 35 bigcal_nmatr_event = 0
+ do i=1,bigcal_all_maxhits
+ bigcal_vector(i) = 0.
+ do j=1,bigcal_all_maxhits
+ bigcal_matrix(i,j) = 0.
+ enddo
+ enddo
+c shut down the file:
+ 36 call g_IO_control(iochan,'FREE',abort,err)
+ if(abort) then
+ call g_add_path(here,err)
+ return
+ endif
+ close(iochan)
+ else
+ bigcal_nmatr_event = 0
+ do i=1,bigcal_all_maxhits
+ bigcal_vector(i) = 0.
+ do j=1,bigcal_all_maxhits
+ bigcal_matrix(i,j) = 0.
+ enddo
+ enddo
+ endif
+ endif
+c initialize debugging output file:
+ if(bdebug_print_adc.ne.0 .or. bdebug_print_tdc.ne.0.or.bdebug_print_trig
+ $ .ne.0.or.bdebug_print_bad.ne.0) then
+ if(b_debug_output_filename.ne.' ') then
+ filename = b_debug_output_filename
+ else
+ filename = 'scalers/rawbigcal_%d.txt'
+ endif
+
+ call g_sub_run_number(filename,gen_run_number)
+
+ open(unit=bluno,file=filename,form='formatted',status='unknown')
+
+ endif
+c initialize list of bad channels:
+ if(b_use_bad_chan_list.ne.0 .and. b_bad_chan_list_filename
+ $ .ne. ' ') then
+ call b_init_bad_list(abort,err)
+ if(abort) then
+ call g_add_path(here,err)
+ return
+ endif
+ endif
+
+ if(abort .or. err.ne.' ') call g_add_path(here,err)
+
+ return
+ end
diff --git a/ENGINE/b_keep_results.f b/ENGINE/b_keep_results.f
new file mode 100755
index 0000000..0b84acf
--- /dev/null
+++ b/ENGINE/b_keep_results.f
@@ -0,0 +1,45 @@
+ subroutine b_keep_results(ABORT,err)
+
+ implicit none
+ save
+
+ include 'bigcal_data_structures.cmn'
+ include 'b_ntuple.cmn'
+ include 'gen_event_info.cmn'
+ include 'sane_ntuple.cmn'
+ character*14 here
+ parameter(here='b_keep_results')
+
+ logical abort
+ character*(*) err
+
+ abort=.false.
+ err=' '
+
+c check whether there is a cluster.
+c if there is a cluster, then keep the ntuple
+
+c$$$ if(BIGCAL_PROT_NCLSTR.gt.0.or.BIGCAL_RCS_NCLSTR.gt.0.or.
+c$$$ $ BIGCAL_MID_NCLSTR.gt.0) then
+c$$$ call b_ntuple_keep(ABORT,err,.true.)
+c$$$ endif
+
+c if (gen_event_type .le. 2) return
+
+ if(bigcal_ntuple_type.eq.1)then
+ if(bigcal_all_nclstr.gt.0!.or.bigcal_nmaxima.gt.0
+ & ) then
+ call b_ntuple_keep(ABORT,err,.true.)
+ endif
+ else if(bigcal_ntuple_type.eq.2)then
+ call b_ntuple_keep(ABORT,err,.true.)
+ endif
+
+ if(abort) then
+ call G_add_path(here,err)
+ else
+ err=' '
+ endif
+
+ return
+ end
diff --git a/ENGINE/b_ntuple_change.f b/ENGINE/b_ntuple_change.f
new file mode 100755
index 0000000..0d0311c
--- /dev/null
+++ b/ENGINE/b_ntuple_change.f
@@ -0,0 +1,72 @@
+ subroutine b_ntuple_change(ABORT,err)
+
+ implicit none
+ save
+
+ character*15 here
+ parameter(here='b_ntuple_change')
+
+ logical ABORT
+ character*(*) err
+
+ include 'b_ntuple.cmn'
+ include 'gen_run_info.cmn'
+
+ character*1 ifile
+ character*80 file
+ character*1000 pat
+
+ integer*4 ilo,fn_len
+
+ integer g_important_length
+
+ call b_ntuple_close(ABORT,err)
+
+ if(b_ntuple_exists) then
+ ABORT=.true.
+ endif
+
+ call NO_nulls(b_ntuple_file)
+
+ file = b_ntuple_file
+
+ call NO_nulls(file)
+ call g_sub_run_number(file,gen_run_number)
+
+ b_ntuple_filesegments = b_ntuple_filesegments + 1
+ !write(*,*) 'computing ifile'
+ if(b_ntuple_filesegments.lt.10) then
+ ifile = char(ichar('0')+b_ntuple_filesegments)
+ else
+ ifile = char(ichar('a')+b_ntuple_filesegments-10)
+ endif
+ !write(*,*), 'ifile = ',ifile
+
+ fn_len = g_important_length(file)
+ ilo = index(file,'.hbook')
+ if((ilo.le.1).or.(ilo.gt.fn_len-5)) then
+ ilo=index(file,'.rzdat')
+ endif
+
+ if((ilo.gt.1).and.(ilo.lt.fn_len)) then
+ file = file(1:ilo-1)//'.'//ifile//file(ilo:fn_len)
+ else
+ abort=.true.
+ endif
+
+ !write(*,*) 'new file name = ',file
+
+ if(.not.abort) call b_ntuple_open(file,ABORT,err)
+
+ if(abort) then
+ err=':unable to change BigCal ntuple file segment'
+ call G_add_path(here,err)
+ else
+ pat=':changed BigCal ntuple file segment'
+ call G_add_path(here,pat)
+ call G_log_message('INFO: '//pat)
+ endif
+
+ return
+ end
+
diff --git a/ENGINE/b_ntuple_clear.f b/ENGINE/b_ntuple_clear.f
new file mode 100755
index 0000000..185c531
--- /dev/null
+++ b/ENGINE/b_ntuple_clear.f
@@ -0,0 +1,33 @@
+ subroutine B_ntuple_clear
+*----------------------------------------------------------------------
+*
+* Purpose : Clear vars that go to the BigCal Ntuple
+*
+* csa 4/15/97
+*
+* $Log: b_ntuple_clear.f,v $
+* Revision 1.1.2.1 2007/05/15 02:54:45 jones
+* Start to Bigcal code
+*
+* Revision 1.1 1999/02/24 14:52:36 saw
+* Dummy routine
+*
+*
+*----------------------------------------------------------------------
+ implicit none
+ save
+*
+* character*13 here
+* parameter (here='h_Ntuple_clear')
+*
+* logical ABORT
+* character*(*) err
+*
+
+* csa 2/2/99 -- This is a dummy routine in the CVS tree. The
+* real thing gets created in the user's Oscar directory based
+* on which variables are in the ntuple.lst file.
+
+*
+ RETURN
+ END
diff --git a/ENGINE/b_ntuple_close.f b/ENGINE/b_ntuple_close.f
new file mode 100755
index 0000000..1e8215f
--- /dev/null
+++ b/ENGINE/b_ntuple_close.f
@@ -0,0 +1,64 @@
+ subroutine b_ntuple_close(ABORT,err)
+
+ implicit none
+ save
+
+ character*14 here
+ parameter(here='b_ntuple_close')
+
+ logical ABORT
+ character*(*) err
+
+ include 'b_ntuple.cmn'
+ include 'gen_routines.dec'
+
+ logical HEXIST ! CERNLIB function
+
+ logical FAIL
+ character*80 why,directory,name
+ character*1000 msg
+ integer io,id,cycle,m
+
+ err=' '
+ abort=.false.
+
+ if(.not.b_ntuple_exists) return
+
+ call HCDIR(directory,'R') ! keep current directory
+
+ id=b_ntuple_ID
+ io=b_ntuple_IOchannel
+ name=b_ntuple_name
+
+ abort=.not.HEXIST(id)
+
+ if(abort) then
+ call G_add_path(here,err)
+ if(io.gt.0) then
+ call G_IO_control(io,'FREE',FAIL,why) ! free up
+ if(.not.fail) close(io)
+ endif
+ endif
+
+ call HCDIR(b_ntuple_directory,' ') ! go to ntuple directory
+
+ call G_add_path(here,msg)
+ call G_log_message('INFO: '//msg)
+
+ cycle= 0
+ call HROUT(id,cycle,' ')
+ call HREND(name)
+ call G_IO_control(io,'FREE',ABORT,err)
+ close(io)
+ write(*,*)'B NTUPLE IO',io
+ call HCDIR(directory,' ') ! return to "current" directory
+
+ b_ntuple_directory=' '
+ b_ntuple_exists=.false.
+ b_ntuple_IOchannel= 0
+
+ if(abort) call G_add_path(here,err)
+
+ return
+ end
+
diff --git a/ENGINE/b_ntuple_init.f b/ENGINE/b_ntuple_init.f
new file mode 100755
index 0000000..8fbd6eb
--- /dev/null
+++ b/ENGINE/b_ntuple_init.f
@@ -0,0 +1,118 @@
+ subroutine b_ntuple_init(ABORT,err)
+
+ implicit none
+ save
+
+ character*13 here
+ parameter(here='b_ntuple_init')
+
+c integer itype
+
+ include 'b_ntuple.cmn'
+ include 'gen_routines.dec'
+ include 'bigcal_data_structures.cmn'
+ include 'gen_run_info.cmn'
+ include 'b_ntuple.dte'
+
+ character*80 default_name
+ parameter(default_name='BIGCAL_ntuple')
+
+ logical ABORT
+ character*(*) err
+
+ character*80 file
+ character*80 name
+ character*1000 pat,msg
+ integer ilo,fn_len,m,i,j,k
+ character*1 ifile
+
+ character*5 Ecelltag
+ character*2 ixtag,iytag
+
+c$$$ data b_ntuple_exists/.false./
+c$$$ data b_ntuple_ID/0/
+c$$$ data b_ntuple_file/' '/
+c$$$ data b_ntuple_name/' '/
+c$$$ data b_ntuple_title/' '/
+c$$$ data b_ntuple_directory/' '/
+c$$$ data b_ntuple_IOchannel/0/
+c$$$ data b_ntuple_size/0/
+c$$$ data b_ntuple_tag/bmax_ntuple_size*' '/
+c$$$ data b_ntuple_contents/bmax_ntuple_size*0/
+
+ err=' '
+ abort=.false.
+
+ if(b_ntuple_exists) then
+ !write(*,*) 'calling b_ntuple_shutdown'
+ call b_ntuple_shutdown(ABORT,err)
+ if(abort) then
+ call G_add_path(here,err)
+ return
+ endif
+ endif
+
+ call no_nulls(b_ntuple_file) ! replace null characters with blanks
+
+ if(b_ntuple_file.eq.' ') return
+ b_ntuple_id = default_b_ntuple_ID
+ b_ntuple_name = default_name
+ if(b_ntuple_title.eq.' ') then
+ msg = b_ntuple_name//' '//b_ntuple_file
+ !write(*,*) 'bigcal ntuple title = ',msg
+ call only_one_blank(msg)
+ b_ntuple_title= msg
+
+ endif
+
+ file = b_ntuple_file
+ call g_sub_run_number(file,gen_run_number)
+
+c write(*,*) 'b_ntuple_max_segmentevents=',b_ntuple_max_segmentevents
+
+ if(b_ntuple_max_segmentevents.gt.0) then
+ b_ntuple_filesegments = 1
+ ifile = char(ichar('0')+b_ntuple_filesegments)
+ fn_len = g_important_length(file)
+ ilo=index(file,'.hbook')
+ if((ilo.le.1).or.(ilo.gt.fn_len-5))then
+ ilo=index(file,'.rzdat')
+ endif
+
+ if((ilo.gt.1).and.(ilo.lt.fn_len)) then
+ file = file(1:ilo-1)//'.'//ifile//file(ilo:fn_len)
+ else
+ abort=.true.
+ return
+ endif
+
+ write(*,*) ' using segmented bigcal rzdat files
+ $ first filename: ',file
+ else
+ write(*,*) ' Not using segmented bigcal rzdat files
+ $ first filename: ',file
+ endif
+
+c choose ntuple type based on input argument
+
+ if(bigcal_ntuple_type.eq.2) then ! cosmics ntuple
+ b_ntuple_id = 9501
+ endif
+
+
+ !write(*,*) 'calling b_ntuple_open'
+c b_ntuple_exists=.TRUE.
+ call b_ntuple_open(file,ABORT,err)
+ !write(*,*) 'b_ntuple_open successful, itype=',bigcal_ntuple_type
+
+ if(abort) then
+ err= ':unable to create BigCal ntuple'
+ call G_add_path(here,err)
+ else
+ pat= ':created BigCal ntuple'
+ call G_add_path(here,pat)
+ call G_log_message('INFO: '//pat)
+ endif
+
+ return
+ end
diff --git a/ENGINE/b_ntuple_keep.f b/ENGINE/b_ntuple_keep.f
new file mode 100755
index 0000000..20ab32d
--- /dev/null
+++ b/ENGINE/b_ntuple_keep.f
@@ -0,0 +1,579 @@
+ subroutine b_ntuple_keep(ABORT,err,hflag)
+
+ implicit none
+ save
+
+ character*13 here
+ parameter(here='b_ntuple_keep')
+
+ logical abort
+ character*(*) err
+
+ include 'b_ntuple.cmn'
+ include 'bigcal_data_structures.cmn'
+ include 'bigcal_tof_parms.cmn'
+ include 'hms_data_structures.cmn'
+ include 'bigcal_gain_parms.cmn'
+ include 'gen_event_info.cmn'
+ include 'gen_data_structures.cmn'
+ include 'gep_data_structures.cmn'
+c include 'gen_scalers.cmn'
+ real PI
+ parameter(PI=3.14159265359)
+
+ logical HEXIST ! CERNLIB function
+
+c logical middlebest
+
+ integer m,np,nr,nm,irow,icol,ihit,jhit,itdc,itrig,ngood
+c real ep,er,em
+c integer iybest,ixbest,xclst,yclst,Eclst,xmom,ymom,t8avg,t64avg
+ integer L8sum,L64sum,iydiff,ixdiff,icell,jcell,iarray
+c real ecell(BIGCAL_CLSTR_NCELL_MAX)
+
+c integer itype
+ integer jclust,iclust,imax,idiff
+ integer nhit_tdc(224)
+ integer nhit_ttdc(42)
+ integer nhit_tadc(38)
+ logical hflag
+ real Mp
+ parameter(Mp=.938272)
+
+ do ihit=1,224
+ nhit_tdc(ihit) = 0
+ if(ihit.le.42) nhit_ttdc(ihit) = 0
+ if(ihit.le.38) nhit_tadc(ihit) = 0
+ enddo
+
+ err=' '
+ ABORT=.false.
+
+ if (hflag) then
+ if(.not.b_ntuple_exists) return
+
+ if(b_ntuple_max_segmentevents.gt.0) then
+ if(b_ntuple_segmentevents.gt.b_ntuple_max_segmentevents) then
+ call b_ntuple_change(ABORT,err)
+ b_ntuple_segmentevents=0
+ else
+ b_ntuple_segmentevents = b_ntuple_segmentevents + 1
+ endif
+ endif
+ endif
+ if ( .not. hflag) bigcal_ntuple_type = 1
+ if(bigcal_ntuple_type.eq.1) then
+ bgid = gen_event_ID_number
+ bgtype = gen_event_type
+ btrigtype = 0
+
+ do itrig=3,7
+ btrigtype = btrigtype + itrig*gen_event_trigtype(itrig)
+ enddo
+
+c$$$ write(*,*) 'filling BigCal ntuple'
+c$$$ write(*,*) 'event,type,trigtype=',bgid,bgtype,btrigtype
+
+ nclust = bigcal_all_nclust_good
+ nclust8 = nclust
+ nclust64 = nclust
+ ntrack = nclust
+ ibest = bigcal_itrack_best
+
+ if(ntrigB.gt.0) then
+ btrigtime = bigcal_end_time - gep_btime(1)
+ else
+ btrigtime = 0.
+ endif
+
+c$$$ write(*,*) 'nclust,ncl8,ncl64,ntrk,best=',nclust,nclust8,
+c$$$ $ nclust64,ntrack,ibest
+
+ ngood = 0
+
+ do iclust = 1,bigcal_all_nclstr
+ if(bigcal_clstr_keep(iclust)) then
+ ngood = ngood + 1
+
+ if(iclust.eq.ibest) ibest = ngood
+
+ ncellclust(ngood) = bigcal_all_clstr_ncell(iclust)
+ ncellbad(ngood) = bigcal_all_clstr_nbadlist(iclust)
+ ncellx(ngood) = bigcal_all_clstr_ncellx(iclust)
+ ncelly(ngood) = bigcal_all_clstr_ncelly(iclust)
+ ncell8clust(ngood) = bigcal_all_clstr_ncell8(iclust)
+ ncell64clust(ngood) = bigcal_all_clstr_ncell64(iclust)
+
+c$$$ write(*,*) 'iclust,ncell,nbad,nx,ny,n8,n64=',iclust,ncellclust(iclust),
+c$$$ $ ncellbad(iclust),ncellx(iclust),ncelly(iclust),ncell8clust(iclust),
+c$$$ $ ncell64clust(iclust)
+
+ do icell=1,ncellclust(ngood)
+ iycell(icell,ngood) = bigcal_all_clstr_iycell(iclust,icell)
+ ixcell(icell,ngood) = bigcal_all_clstr_ixcell(iclust,icell)
+ xcell(icell,ngood) = bigcal_all_clstr_xcell(iclust,icell)
+ ycell(icell,ngood) = bigcal_all_clstr_ycell(iclust,icell)
+ eblock(icell,ngood) = bigcal_all_clstr_ecell(iclust,icell)
+ ablock(icell,ngood) = bigcal_all_clstr_acell(iclust,icell)
+ cellbad(icell,ngood) = bigcal_clstr_bad_chan(iclust,icell)
+c$$$ write(*,*) 'cell,row,col,x,y,e,bad?=',icell,iycell(icell,iclust),
+c$$$ $ ixcell(icell,iclust),xcell(icell,iclust),ycell(icell,iclust),
+c$$$ $ eblock(icell,iclust),cellbad(icell,iclust)
+ enddo
+c zero all cells above ncellclust
+ do icell=ncellclust(ngood)+1,bigcal_clstr_ncell_max
+ iycell(icell,ngood) = 0
+ ixcell(icell,ngood) = 0
+ xcell(icell,ngood) = 0.
+ ycell(icell,ngood) = 0.
+ eblock(icell,ngood) = 0.
+ ablock(icell,ngood) = 0.
+ cellbad(icell,ngood) = .false.
+ enddo
+
+ do icell=1,ncell8clust(ngood)
+ irow8hit(icell,ngood) = bigcal_all_clstr_irow8(iclust,icell)
+ icol8hit(icell,ngood) = bigcal_all_clstr_icol8(iclust,icell)
+ nhit8clust(icell,ngood) = bigcal_all_clstr_nhit8(iclust,icell)
+
+ s8(icell,ngood) = bigcal_all_clstr_s8(iclust,icell)
+
+c$$$ write(*,*) 'cell8,row8,col8,nh=',icell,irow8hit(icell,iclust),
+c$$$ $ icol8hit(icell,iclust),nhit8clust(icell,iclust)
+
+ do ihit=1,nhit8clust(icell,ngood)
+c$$$ write(*,*) 'hit,time=',ihit,tcell8(icell,ihit,iclust)
+ tcell8(icell,ihit,ngood) = bigcal_all_clstr_tcell8(iclust,icell,ihit)
+ enddo
+c zero all hits above nhit8clust(icell,iclust)
+ do ihit=nhit8clust(icell,ngood)+1,8
+ tcell8(icell,ihit,ngood) = 0.
+ enddo
+ enddo
+c zero all cells and all hits of all cells above ncell8clust
+ do icell=ncell8clust(ngood)+1,10
+ irow8hit(icell,ngood) = 0
+ icol8hit(icell,ngood) = 0
+ nhit8clust(icell,ngood) = 0
+ s8(icell,ngood) = 0.
+ do ihit=1,8
+ tcell8(icell,ihit,ngood) = 0.
+ enddo
+ enddo
+
+ do icell=1,ncell64clust(ngood)
+ irow64hit(icell,ngood) = bigcal_all_clstr_irow64(iclust,icell)
+ icol64hit(icell,ngood) = bigcal_all_clstr_icol64(iclust,icell)
+ nhit64clust(icell,ngood) = bigcal_all_clstr_nhit64(iclust,icell)
+ a64(icell,ngood) = bigcal_all_clstr_a64(iclust,icell)
+ s64(icell,ngood) = bigcal_all_clstr_sum64(iclust,icell)
+c$$$ write(*,*) 'cell64,row64,col64,nh,a64,s64=',icell,irow64hit(icell,iclust),
+c$$$ $ icol64hit(icell,iclust),nhit64clust(icell,iclust),a64(icell,iclust),
+c$$$ $ s64(icell,iclust)
+ do ihit=1,nhit64clust(icell,ngood)
+ !write(*,*) 'hit,time=',ihit,tcell64(icell,ihit,iclust)
+ tcell64(icell,ihit,ngood) = bigcal_all_clstr_tcell64(iclust,icell,ihit)
+ enddo
+c zero all hits above nhit64clust(icell,iclust)
+ do ihit=nhit64clust(icell,ngood)+1,8
+ tcell64(icell,ihit,ngood) = 0.
+ enddo
+ enddo
+c zero all cells and all hits of all cells above ncell64clust
+ do icell=ncell64clust(ngood)+1,6
+ irow64hit(icell,ngood) = 0
+ icol64hit(icell,ngood) = 0
+ nhit64clust(icell,ngood) = 0
+ do ihit=1,8
+ tcell64(icell,ihit,ngood) = 0.
+ enddo
+ enddo
+
+ xmoment(ngood) = bigcal_all_clstr_xmom(iclust)
+ ymoment(ngood) = bigcal_all_clstr_ymom(iclust)
+ tclust8(ngood) = bigcal_all_clstr_t8mean(iclust)
+ tclust64(ngood) = bigcal_all_clstr_t64mean(iclust)
+ tcut8(ngood) = bigcal_all_clstr_t8cut(iclust)
+c tofcor8(ngood) = bigcal_all_clstr_t8cut_cor(iclust)
+ tcut64(ngood) = bigcal_all_clstr_t64cut(iclust)
+c tofcor64(ngood) = bigcal_all_clstr_t64cut_cor(iclust)
+ trms8(ngood) = bigcal_all_clstr_t8rms(iclust)
+ trms64(ngood) = bigcal_all_clstr_t64rms(iclust)
+
+c write(*,*) 'tcut8 = ',tcut8(iclust)
+c write(*,*) 'tcut64=',tcut64(iclust)
+
+c$$$ write(*,*) 'xmom,ymom,t8,t64,trms8,trms64=',xmoment(iclust),
+c$$$ $ ymoment(iclust),tclust8(iclust),tclust64(iclust),trms8(iclust),
+c$$$ $ trms64(iclust)
+
+ xclust(ngood) = bigcal_all_clstr_x(iclust)
+ yclust(ngood) = bigcal_all_clstr_y(iclust)
+ eclust(ngood) = bigcal_all_clstr_etot(iclust)
+ aclust(ngood) = bigcal_all_clstr_atot(iclust)
+
+c keepclst(ngood) = bigcal_clstr_keep(iclust)
+
+cwrite(*,*) 'xclust,yclust,eclust=',xclust(iclust),yclust(iclust),
+c $ eclust(iclust)
+
+ thetarad(ngood) = bigcal_track_thetarad(iclust)
+ phirad(ngood) = bigcal_track_phirad(iclust)
+ energy(ngood) = bigcal_track_energy(iclust)
+ xface(ngood) = bigcal_track_xface(iclust)
+ yface(ngood) = bigcal_track_yface(iclust)
+ zface(ngood) = bigcal_track_zface(iclust)
+ px(ngood) = bigcal_track_px(iclust)
+ py(ngood) = bigcal_track_py(iclust)
+ pz(ngood) = bigcal_track_pz(iclust)
+ ctime_clust(ngood) = bigcal_track_coin_time(iclust) -
+ $ (bigcal_end_time - bigcal_window_center)
+
+ if(bgtype.eq.6.and.ibest>0) then
+c write(*,*) 'chi2=',bigcal_all_clstr_chi2(iclust)
+ chi2clust(ngood) = bigcal_all_clstr_chi2(iclust)
+ do idiff=1,6
+c write(*,*) 'chi2_',idiff,'=',bigcal_all_clstr_chi2contr(iclust,idiff)
+ chi2contr(idiff,ngood) = bigcal_all_clstr_chi2contr(iclust,idiff)
+ enddo
+ else
+ chi2clust(ngood) = -9999.
+ do idiff=1,6
+ chi2contr(idiff,ngood) = -9999.
+ enddo
+ endif
+c$$$ write(*,*) 'theta,phi,E,xf,yf,zf,px,py,pz,t=',thetarad(iclust),phirad(iclust),
+c$$$ $ energy(iclust),xface(iclust),yface(iclust),zface(iclust),px(iclust),py(iclust),
+c$$$ $ pz(iclust),ctime_clust(iclust)
+ endif
+ enddo
+
+ if(ngood.ne.nclust) then
+ nclust = ngood
+ ntrack = ngood
+ nclust8 = ngood
+ nclust64 = ngood
+ endif
+
+ nmax = bigcal_nmaxima
+c write(*,*) 'nmax=',nmax
+ do imax=1,nmax
+ edge_max(imax) = bigcal_edge_max(imax)
+ not_enough(imax) = bigcal_not_enough(imax)
+ too_long_x(imax) = bigcal_too_long_x(imax)
+ too_long_y(imax) = bigcal_too_long_y(imax)
+ below_thresh(imax) = bigcal_below_cut(imax)
+ above_max(imax) = bigcal_above_max(imax)
+ second_max(imax) = bigcal_second_max(imax)
+c write(*,*) 'max,edge,small,bigx,bigy,cutlo,cuthi,twomax=',
+c $ edge_max(imax),not_enough(imax),too_long_x(imax),too_long_y(imax),
+c $ below_thresh(imax),above_max(imax),second_max(imax)
+ enddo
+ ngooda = bigcal_all_ngood
+ ngoodt = bigcal_time_ngood
+ ngoodta = bigcal_atrig_ngood
+ ngoodtt = bigcal_ttrig_ngood
+c$$$ write(*,*) '(rowmax,colmax,adcmax)=',bigcal_iymax_adc,
+c$$$ $ bigcal_ixmax_adc,bigcal_max_adc
+ irowmax = bigcal_iymax_adc
+ icolmax = bigcal_ixmax_adc
+ max_adc = bigcal_max_adc
+
+c$$$ write(*,*) 'na,nt,nta,ntt,rowmax,colmax,maxadc=',ngooda,ngoodt,ngoodta,
+c$$$ $ ngoodtt,irowmax,icolmax,max_adc
+
+ if(bgtype.eq.6.and.ibest>0) then ! this always assumes elastic kinematics--won't always make sense!
+c E_HMS = gebeam - gep_Q2_H/(2.*Mp)
+c T_HMS = gep_ctime_hms
+ TH_HMS = gep_etheta_expect_h
+ PH_HMS = gep_ephi_expect_h - PI/2.
+
+c write(*,*) 'thetaH,phiH,dpel=',th_hms,ph_hms
+ E_HMS = gep_E_electron
+ X_HMS = gep_bx_expect_H
+ Y_HMS = gep_by_expect_H
+ dPel_HMS = (gep_p_proton - gep_pel_htheta) / hpcentral ! useful to isolate elastics
+c write(*,*) 'e_hms,x_hms,y_hms,dpel=',e_hms,x_hms,y_hms,dpel_hms
+ else
+c T_HMS = -9999.
+ TH_HMS = -9999.
+ PH_HMS = -9999.
+ E_HMS = -9999.
+ X_HMS = -9999.
+ Y_HMS = -9999.
+ dpel_hms = -9999.
+ endif
+ else if(bigcal_ntuple_type.eq.2) then
+ nahit = 0
+ if(bigcal_prot_ngood.gt.0) then
+ do ihit=1,bigcal_prot_ngood
+ icol = bigcal_prot_ixgood(ihit)
+ irow = bigcal_prot_iygood(ihit)
+ icell = icol + 32*(irow-1)
+ if(icell.ge.1.and.icell.le.1024.and.
+ $ bigcal_prot_adc_good(ihit).ge.bigcal_prot_adc_threshold(icell)
+ $ .and. bigcal_prot_adc_good(ihit).le.8192.) then
+ nahit = nahit + 1
+ xa(nahit) = bigcal_prot_ixgood(ihit)
+ ya(nahit) = bigcal_prot_iygood(ihit)
+ aa(nahit) = bigcal_prot_adc_good(ihit)
+ endif
+ enddo
+ endif
+
+ if(bigcal_rcs_ngood.gt.0) then
+ do ihit=1,bigcal_rcs_ngood
+ icol = bigcal_rcs_ixgood(ihit)
+ irow = bigcal_rcs_iygood(ihit)
+ icell = icol + 30*(irow - 1)
+ if(icell.ge.1.and.icell.le.720.and.
+ $ bigcal_rcs_adc_good(ihit).ge.bigcal_rcs_adc_threshold(icell)
+ $ .and. bigcal_rcs_adc_good(ihit).le.8192.) then
+ nahit = nahit + 1
+ xa(nahit) = bigcal_rcs_ixgood(ihit) + icol/16
+ ya(nahit) = bigcal_rcs_iygood(ihit) + 32
+ aa(nahit) = bigcal_rcs_adc_good(ihit)
+ endif
+ enddo
+ endif
+
+ nthit=0
+
+ if(bigcal_tdc_nhit.gt.0) then
+ do ihit=1,bigcal_tdc_nhit
+ if(bigcal_tdc(ihit).gt.10)then
+ nthit = nthit + 1
+ xt(nthit) = bigcal_tdc_igroup(ihit)
+ yt(nthit) = bigcal_tdc_irow(ihit)
+ itdc = xt(nthit) + 4*(yt(nthit)-1)
+ nhit_tdc(itdc) = nhit_tdc(itdc) + 1
+ hn(nthit) = nhit_tdc(itdc)
+ tt(nthit) = bigcal_tdc_raw(ihit)
+c$$$ write(*,*) 'nthit,xt,yt,hn,tt = ',nthit,xt(nthit),
+c$$$ $ yt(nthit),hn(nthit),tt(nthit)
+ endif
+ enddo
+ endif
+
+ ntahit=0
+ ntthit=0
+
+ if(bigcal_atrig_ngood.gt.0) then
+ do ihit=1,bigcal_atrig_ngood
+ icol = bigcal_atrig_good_ihalf(ihit)
+ irow = bigcal_atrig_good_igroup(ihit)
+ icell = icol + 2*(irow-1)
+ if(icell.ge.1.and.icell.le.38.and.
+ $ bigcal_atrig_adc_good(ihit).ge.bigcal_trig_adc_threshold(icell)
+ $ .and.bigcal_atrig_adc_good(ihit).le.8192.)then
+ ntahit = ntahit + 1
+ xta(ntahit) = icol
+ yta(ntahit) = irow
+ taa(ntahit) = bigcal_atrig_adc_good(ihit)
+ endif
+ enddo
+ endif
+
+ if(bigcal_ttrig_nhit.gt.0) then
+ do ihit=1,bigcal_ttrig_nhit
+ icol = bigcal_ttrig_ihalf(ihit)
+ irow = bigcal_ttrig_igroup(ihit)
+ icell = icol + 2*(irow-1)
+ if(bigcal_ttrig_tdc_raw(ihit).gt.10) then
+ ntthit = ntthit + 1
+ nhit_ttdc(icell) = nhit_ttdc(icell) + 1
+ xtt(ntthit) = icol
+ ytt(ntthit) = irow
+ hnt(ntthit) = nhit_ttdc(icell)
+ ttt(ntthit) = bigcal_ttrig_tdc_raw(ihit)
+ endif
+ enddo
+ endif
+ else if(bigcal_ntuple_type.eq.3) then
+ m=0
+ m=m+1
+ b_ntuple_contents(m) = float(gen_event_id_number)
+ m=m+1
+ b_ntuple_contents(m) = float(gen_event_type)
+ m=m+1
+ if(ntrigB.gt.0) then
+ b_ntuple_contents(m) = bigcal_end_time - gep_btime(1)
+ else
+ b_ntuple_contents(m) = bigcal_end_time - bigcal_window_center
+ endif
+ m=m+1
+ b_ntuple_contents(m) = float(bigcal_all_ngood)
+ m=m+1
+ b_ntuple_contents(m) = float(bigcal_time_ngood)
+ m=m+1
+ b_ntuple_contents(m) = float(bigcal_atrig_ngood)
+ m=m+1
+ b_ntuple_contents(m) = float(bigcal_ttrig_ngood)
+ m=m+1
+ b_ntuple_contents(m) = float(bigcal_iymax_adc)
+ m=m+1
+ b_ntuple_contents(m) = float(bigcal_ixmax_adc)
+ m=m+1
+ b_ntuple_contents(m) = bigcal_max_adc
+ m=m+1
+ b_ntuple_contents(m) = float(bigcal_all_nclstr)
+ m=m+1
+ b_ntuple_contents(m) = float(bigcal_nmaxima)
+ m=m+1
+ if(bigcal_itrack_best.gt.0) then
+ ibest = bigcal_itrack_best
+ else
+ ibest = 1
+ endif
+ b_ntuple_contents(m) = float(bigcal_all_clstr_ncell(ibest))
+ m=m+1
+ b_ntuple_contents(m) = float(bigcal_all_clstr_ncellx(ibest))
+ m=m+1
+ b_ntuple_contents(m) = float(bigcal_all_clstr_ncelly(ibest))
+ m=m+1
+ b_ntuple_contents(m) = float(bigcal_all_clstr_ncell8(ibest))
+ m=m+1
+ b_ntuple_contents(m) = float(bigcal_all_clstr_ncell64(ibest))
+ m=m+1
+ b_ntuple_contents(m) = float(bigcal_all_clstr_iycell(ibest,1))
+ m=m+1
+ b_ntuple_contents(m) = float(bigcal_all_clstr_ixcell(ibest,1))
+ m=m+1
+ b_ntuple_contents(m) = bigcal_all_clstr_xcell(ibest,1)
+ m=m+1
+ b_ntuple_contents(m) = bigcal_all_clstr_ycell(ibest,1)
+ m=m+1
+ b_ntuple_contents(m) = bigcal_all_clstr_xmom(ibest)
+ m=m+1
+ b_ntuple_contents(m) = bigcal_all_clstr_ymom(ibest)
+ m=m+1
+ b_ntuple_contents(m) = bigcal_all_clstr_x(ibest)
+ m=m+1
+ b_ntuple_contents(m) = bigcal_all_clstr_y(ibest)
+ m=m+1
+ b_ntuple_contents(m) = bigcal_all_clstr_atot(ibest)
+ m=m+1
+ b_ntuple_contents(m) = bigcal_all_clstr_etot(ibest)
+ m=m+1
+ b_ntuple_contents(m) = bigcal_all_clstr_t8cut(ibest)
+ m=m+1
+ b_ntuple_contents(m) = bigcal_all_clstr_t8rms(ibest)
+ m=m+1
+ b_ntuple_contents(m) = bigcal_all_clstr_t64cut(ibest)
+ m=m+1
+ b_ntuple_contents(m) = bigcal_all_clstr_t64rms(ibest)
+ m=m+1
+ b_ntuple_contents(m) = bigcal_track_thetarad(ibest)
+ m=m+1
+ b_ntuple_contents(m) = bigcal_track_phirad(ibest)
+ m=m+1
+ b_ntuple_contents(m) = bigcal_track_energy(ibest)
+ m=m+1
+ b_ntuple_contents(m) = bigcal_track_coin_time(ibest) -
+ $ (bigcal_end_time - bigcal_window_center)
+ m=m+1
+ b_ntuple_contents(m) = bigcal_track_tof_cor(ibest)
+ m=m+1
+ b_ntuple_contents(m) = float(hsnum_fptrack)
+ m=m+1
+ if(bigcal_itrack_best.gt.0) then
+
+ b_ntuple_contents(m) = bigcal_all_clstr_chi2(ibest)
+ m=m+1
+ b_ntuple_contents(m) = bigcal_all_clstr_chi2contr(ibest,4)
+ m=m+1
+ b_ntuple_contents(m) = bigcal_all_clstr_chi2contr(ibest,5)
+ m=m+1
+ b_ntuple_contents(m) = bigcal_all_clstr_chi2contr(ibest,2)
+ m=m+1
+ b_ntuple_contents(m) = bigcal_all_clstr_chi2contr(ibest,3)
+ m=m+1
+ b_ntuple_contents(m) = bigcal_all_clstr_chi2contr(ibest,1)
+ m=m+1
+ b_ntuple_contents(m) = bigcal_all_clstr_chi2contr(ibest,6)
+ m=m+1
+ b_ntuple_contents(m) = gep_E_electron
+ m=m+1
+ b_ntuple_contents(m) = gep_etheta_expect_h
+ m=m+1
+ b_ntuple_contents(m) = gep_ephi_expect_h - PI/2.
+ m=m+1
+ b_ntuple_contents(m) = gep_bx_expect_h
+ m=m+1
+ b_ntuple_contents(m) = gep_by_expect_h
+ m=m+1
+ b_ntuple_contents(m) = gep_ctime_hms
+ m=m+1
+ b_ntuple_contents(m) = (gep_p_proton - gep_pel_htheta) / hpcentral
+ m=m+1
+ b_ntuple_contents(m) = (gep_p_proton - gep_pel_btheta) / hpcentral
+ m=m+1
+ b_ntuple_contents(m) = gbeam_x
+ m=m+1
+ b_ntuple_contents(m) = gbeam_y
+ m=m+1
+ b_ntuple_contents(m) = hszbeam
+ m=m+1
+ b_ntuple_contents(m) = hsxp_tar
+ m=m+1
+ b_ntuple_contents(m) = hsyp_tar
+ else
+ b_ntuple_contents(m) = -1.
+ m=m+1
+ b_ntuple_contents(m) = -1.
+ m=m+1
+ b_ntuple_contents(m) = -1.
+ m=m+1
+ b_ntuple_contents(m) = -1.
+ m=m+1
+ b_ntuple_contents(m) = -1.
+ m=m+1
+ b_ntuple_contents(m) = -1.
+ m=m+1
+ b_ntuple_contents(m) = -1.
+ m=m+1
+ b_ntuple_contents(m) = -999.
+ m=m+1
+ b_ntuple_contents(m) = -999.
+ m=m+1
+ b_ntuple_contents(m) = -999.
+ m=m+1
+ b_ntuple_contents(m) = -999.
+ m=m+1
+ b_ntuple_contents(m) = -999.
+ m=m+1
+ b_ntuple_contents(m) = -999.
+ m=m+1
+ b_ntuple_contents(m) = -999.
+ m=m+1
+ b_ntuple_contents(m) = -999.
+ m=m+1
+ b_ntuple_contents(m) = gbeam_x
+ m=m+1
+ b_ntuple_contents(m) = gbeam_y
+ m=m+1
+ b_ntuple_contents(m) = 0.
+ m=m+1
+ b_ntuple_contents(m) = -999.
+ m=m+1
+ b_ntuple_contents(m) = -999.
+ endif
+ endif
+
+
+ if ( hflag) then
+ abort=.not.HEXIST(b_ntuple_ID)
+ if(abort) then
+ call G_build_note(':Ntuple ID#$ does not exist',
+ $ '$',b_ntuple_ID,' ',0.,' ',err)
+ call G_add_path(here,err)
+ else if(bigcal_ntuple_type.lt.3) then
+
+ call HFNT(b_ntuple_ID)
+ else if(bigcal_ntuple_type.eq.3) then
+ call HFN(b_ntuple_ID,b_ntuple_contents)
+
+ endif
+ endif
+ return
+ end
diff --git a/ENGINE/b_ntuple_open.f b/ENGINE/b_ntuple_open.f
new file mode 100755
index 0000000..34e73d2
--- /dev/null
+++ b/ENGINE/b_ntuple_open.f
@@ -0,0 +1,236 @@
+ subroutine b_ntuple_open(file,ABORT,err)
+
+ implicit none
+ save
+
+ character*13 here
+ parameter(here='b_ntuple_open')
+
+ logical ABORT
+ character*(*) err
+ integer iquest
+ Common /QUEST/ Iquest(100)
+
+ include 'b_ntuple.cmn'
+ include 'bigcal_bypass_switches.cmn'
+ include 'gen_run_info.cmn'
+
+c integer itype
+
+ integer default_bank,default_recl
+ parameter(default_bank=8000) !4 bytes/word
+ parameter(default_recl=1024) !record length
+ character*80 title,file
+ character*80 directory,name
+ character*1000 pat,msg,chform
+ integer status,size,io,id,bank,recL,iv(10),m
+ real rv(10)
+
+ logical HEXIST !CERNLIB function
+
+ err=' '
+ ABORT=.false.
+ if(b_ntuple_exists) then
+ call b_ntuple_shutdown(ABORT,err)
+ if(abort) then
+ call G_add_path(here,err)
+ return
+ endif
+ endif
+
+c get any free IO channel
+
+ call g_IO_control(io,'ANY',ABORT,err)
+ b_ntuple_exists = .not.ABORT
+ if(ABORT) then
+ call G_add_path(here,err)
+ return
+ endif
+
+ b_ntuple_iochannel = io
+
+ id = b_ntuple_id
+ name = b_ntuple_name
+ title = b_ntuple_title
+ ABORT = HEXIST(id)
+ if(ABORT) then
+ call g_IO_control(b_ntuple_iochannel,'FREE',ABORT,err)
+ call g_build_note(':HBOOK id#$ already in use',
+ $ '$',id,' ',rv,' ',err)
+ call G_add_path(here,err)
+ return
+ endif
+
+ call HCDIR(directory,'R') !CERNLIB read current directory
+
+c$$$ if(bigcal_ntuple_type.eq.1) then
+c$$$ recL = default_recl
+c$$$ call HROPEN(io,name,file,'N',recL,status)
+c$$$ else
+c$$$ recL = 8191
+c$$$ iquest(10) = 65000
+c$$$ call HROPEN(io,name,file,'NQ',recL,status)
+c$$$ endif
+
+ recL = 8191
+ iquest(10) = 65000
+ call HROPEN(io,name,file,'NQ',recL,status)
+
+
+ ABORT= status.ne.0
+ if(ABORT) then
+ call g_IO_control(b_ntuple_iochannel,'FREE',ABORT,err)
+ iv(1) = status
+ iv(2) = io
+ pat= ':HROPEN error#$ opening IO#$ "'//file//'"'
+ call G_build_note(pat,'$',iv,' ',rv,' ',err)
+ call G_add_path(here,err)
+ return
+ endif
+
+ size = b_ntuple_size
+ bank = default_bank
+ title = b_ntuple_title
+
+ if(bigcal_ntuple_type.eq.1) then ! col-wise ntuple for cluster analysis
+ call hbset('BSIZE',8176,status)
+ call HBNT(id,title,' ')
+ if(b_ntuple_switch.ne.0)then
+
+ call HBNAME(id,'bevinfo',bgid,'bgid:I*4,bgtype:I*4,'//
+ $ 'btrigtype:I*4,btrigtime')
+ call HBNAME(id,'bhits',ngooda,'ngooda:I*4,ngoodt:I*4,'//
+ $ 'ngoodta:I*4,ngoodtt:I*4,irowmax:I*4,icolmax:I*4,'//
+ $ 'max_adc:R*4')
+
+ if(bbypass_find_clusters.eq.0) then
+ call HBNAME(id,'clustblock',nclust,
+ $ 'nclust[0,50]:I*4,ncellclust(nclust)[0,50]:I*4,'//
+ $ 'ncellbad(nclust)[0,50]:I*4,'//
+ $ 'ncellx(nclust),ncelly(nclust),iycell(50,nclust),'//
+ $ 'ixcell(50,nclust),cellbad(50,nclust):L,'//
+ $ 'xcell(50,nclust),ycell(50,nclust),'//
+ $ 'eblock(50,nclust),ablock(50,nclust),'//
+ $ 'xmoment(nclust),ymoment(nclust),'//
+ $ 'eclust(nclust),aclust(nclust),'//
+ $ 'xclust(nclust),yclust(nclust)')
+ if(bbypass_calc_cluster_time.eq.0) then
+ if(bbypass_sum8.eq.0) then
+ call HBNAME(id,'clusttdc',nclust8,
+ $ 'nclust8[0,50]:I*4,'//
+ $ 'ncell8clust(nclust8)[0,10]:I*4,'//
+ $ 'irow8hit(10,nclust8)[0,56]:I*4,'//
+ $ 'icol8hit(10,nclust8)[0,4]:I*4,'//
+ $ 'nhit8clust(10,nclust8)[0,8]:I*4,'//
+ $ 's8(10,nclust8),'//
+ $ 'tcell8(10,8,nclust8),tclust8(nclust8),'//
+ $ 'tcut8(nclust8),tcut8cor(nclust8),'//
+ $ 'trms8(nclust8)')
+ endif
+
+ if(bbypass_sum64.eq.0) then
+ call HBNAME(id,'clusttrig',nclust64,
+ $ 'nclust64[0,50]:I*4,'//
+ $ 'ncell64clust(nclust64)[0,6]:I*4,'//
+ $ 'irow64hit(6,nclust64)[0,19]:I*4,'//
+ $ 'icol64hit(6,nclust64)[0,2]:I*4,'//
+ $ 'nhit64clust(6,nclust64)[0,8]:I*4,'//
+ $ 'tcell64(6,8,nclust64),a64(6,nclust64),'//
+ $ 's64(6,nclust64),tclust64(nclust64),'//
+ $ 'tcut64(nclust64),tcut64cor(nclust64),'//
+ $ 'trms64(nclust64)')
+ endif
+ endif
+
+ if(bbypass_calc_physics.eq.0) then
+ call HBNAME(id,'clustphys',ntrack,'ntrack[0,50]:I*4,'//
+ $ 'ibest[0,50]:I*4,thetarad(ntrack),'//
+ $ 'phirad(ntrack),energy(ntrack),'//
+ $ 'xface(ntrack),yface(ntrack),'//
+ $ 'zface(ntrack),px(ntrack),py(ntrack),pz(ntrack),'//
+ $ 'ctime_clust(ntrack),chi2clust(ntrack),'//
+ $ 'chi2contr(6,ntrack)')
+ endif
+
+ call HBNAME(id,'bad_clust',nmax,'nmax[0,50]:I*4,'//
+ $ 'edge_max(nmax):L,not_enough(nmax):L,'//
+ $ 'too_long_x(nmax):L,too_long_y(nmax):L,'//
+ $ 'below_thresh(nmax):L,above_max(nmax):L,'//
+ $ 'second_max(nmax):L')
+ endif
+
+ if(gen_bigcal_mc.ne.0) then
+ call HBNAME(id,'MC_Clust',evid_g,'evid_g:I*4,'//
+ $ 'ntrk_g[0,50]:I*4,'//
+ $ 'pid_g(ntrk_g)[0,50]:I*4,xvertex_g,yvertex_g,'//
+ $ 'zvertex_g,pxgeant(ntrk_g),pygeant(ntrk_g),'//
+ $ 'pzgeant(ntrk_g),xgeant(ntrk_g),ygeant(ntrk_g),'//
+ $ 'egeant(ntrk_g),pgeant(ntrk_g),gthetarad(ntrk_g),'//
+ $ 'gphirad(ntrk_g)')
+ endif
+c write(*,*) 'before adding hmsblk, gen_run_enable=',gen_run_enable
+c write(*,*) 'before adding hmsblk, gen_bigcal_mc=',gen_bigcal_mc
+ if(gen_run_enable(5).ne.0.and.(gen_bigcal_mc.eq.3.or.
+ $ gen_bigcal_mc.eq.0)) then
+c write(*,*) 'adding block hmsblk to bigcal ntuple'
+ call HBNAME(id,'hmsblk',TH_HMS,'TH_HMS,PH_HMS,E_HMS,'//
+ $ 'X_HMS,Y_HMS,dPel_HMS')
+ endif
+ endif
+ else if(bigcal_ntuple_type.eq.2) then ! col-wise ntuple for cosmics analysis
+
+ !write(*,*) 'booking cosmic hits ntuple:'
+
+ !write(*,*) 'calling hbnt title=',title,' ID=',id
+ call hbset('BSIZE',8176,status)
+ call hbnt(id,title,' ')
+
+ !write(*,*) 'hbnt successful, calling hbname(clear)'
+
+ call hbname(id,' ',0,'$clear')
+
+ !write(*,*) 'clear successful, creating chform'
+ chform='nahit[0,1856]:I*4,xa(nahit)[1,32]:I*4,'//
+ * 'ya(nahit)[1,56]:I*4,aa(nahit)[-100,8192]:I*4,'//
+ * 'nthit[0,3072]:I*4,xt(nthit)[1,4]:I*4,'//
+ * 'yt(nthit)[1,56]:I*4,hn(nthit)[1,8]:I*4,'//
+ * 'tt(nthit)[-100,8192]:I*4,'//
+ * 'ntahit[0,38]:I*4,xta(ntahit)[1,2]:I*4,'//
+ * 'yta(ntahit)[1,19]:I*4,taa(ntahit)[-100,8192]:I*4,'//
+ * 'ntthit[0,336]:I*4,xtt(ntthit)[1,2]:I*4,'//
+ * 'ytt(ntthit)[1,21]:I*4,hnt(ntthit)[1,8]:I*4,'//
+ * 'ttt(ntthit)[-100,8192]:I*4'
+ !write(*,*) 'chform successful, calling hbname(chform)'
+ call hbname(id,'hits',nahit,chform)
+
+ !write(*,*) 'booking of cosmic hits ntuple successful'
+
+ endif
+
+ call HCDIR(b_ntuple_directory,'R') ! record ntuple directory
+
+ call HCDIR(directory,' ') !reset CERNLIB directory
+
+ b_ntuple_exists = HEXIST(b_ntuple_id)
+
+ abort = .not.b_ntuple_exists
+
+ iv(1) = id
+ iv(2) = io
+ pat = 'Ntuple id#$ [' // b_ntuple_directory // '/]' //
+ $ name // ' IO#$ "' // file // '"'
+ call G_build_note(pat,'$',iv,' ',rv,' ',msg)
+
+ call sub_string(msg,'/]','/]')
+
+ if(abort) then
+ err = 'unable to create '//msg
+ call G_add_path(here,err)
+ else
+ pat=':created '//msg
+ call G_add_path(here,pat)
+ call G_log_message('INFO: '//pat)
+ endif
+
+ return
+ end
diff --git a/ENGINE/b_ntuple_register.f b/ENGINE/b_ntuple_register.f
new file mode 100755
index 0000000..2ae83c7
--- /dev/null
+++ b/ENGINE/b_ntuple_register.f
@@ -0,0 +1,28 @@
+ subroutine b_ntuple_register(ABORT,err)
+
+ implicit none
+ save
+
+ character*17 here
+ parameter(here='b_ntuple_register')
+
+ logical ABORT
+ character*(*) err
+
+ include 'b_ntuple.cmn'
+ include 'gen_routines.dec'
+
+ integer ierr
+
+ err=' '
+ abort=.false.
+
+ call G_reg_C('BigCal_Ntuple',b_ntuple_file,ABORT,err)
+
+ if(abort) then
+ call G_prepend(':unable to register-',err)
+ call G_add_path(here,err)
+ endif
+
+ return
+ end
diff --git a/ENGINE/b_ntuple_shutdown.f b/ENGINE/b_ntuple_shutdown.f
new file mode 100755
index 0000000..3d5b11c
--- /dev/null
+++ b/ENGINE/b_ntuple_shutdown.f
@@ -0,0 +1,44 @@
+ subroutine b_ntuple_shutdown(ABORT,err)
+c final shutdown of BigCal ntuple
+ implicit none
+ save
+
+ character*17 here
+ parameter(here='b_ntuple_shutdown')
+
+ logical abort
+ character*(*) err
+
+ include 'b_ntuple.cmn'
+ include 'gen_routines.dec'
+
+ logical fail
+ character*80 why,directory,name
+ character*1000 msg
+ integer io,id,cycle,m
+
+ err=' '
+ abort=.false.
+
+ if(.not.b_ntuple_exists) return ! nothing to do
+
+ call b_ntuple_close(ABORT,err)
+
+ if(b_ntuple_exists) then
+ abort=.true.
+ endif
+
+ b_ntuple_ID=0
+ b_ntuple_name=' '
+ b_ntuple_file=' '
+ b_ntuple_title=' '
+ b_ntuple_size=0
+ do m=1,bmax_ntuple_size
+ b_ntuple_tag(m)= ' '
+ b_ntuple_contents(m) = 0.
+ enddo
+
+ if(abort) call G_add_path(here,err)
+
+ return
+ end
diff --git a/ENGINE/b_proper_shutdown.f b/ENGINE/b_proper_shutdown.f
new file mode 100755
index 0000000..d56688d
--- /dev/null
+++ b/ENGINE/b_proper_shutdown.f
@@ -0,0 +1,56 @@
+ subroutine b_proper_shutdown(lunout,ABORT,err)
+
+ implicit none
+ save
+
+ character*17 here
+ parameter(here='b_proper_shutdown')
+
+ include 'gen_routines.dec'
+ include 'gen_filenames.cmn'
+ include 'gen_run_info.cmn'
+ include 'bigcal_data_structures.cmn'
+ include 'bigcal_filenames.cmn'
+ include 'bigcal_bypass_switches.cmn'
+ include 'bigcal_hist_id.cmn'
+
+ logical abort, report_abort
+ character*(*) err
+
+ integer lunout
+ integer ierr
+ character*132 file
+
+ integer irow,icol,icell
+ real Eavg,eff
+
+ abort=.false.
+ err=' '
+
+ call b_report_bad_data(lunout,ABORT,err)
+
+ if(b_report_blockname.ne.' '.and.
+ $ b_report_output_filename.ne.' ') then
+ file = b_report_output_filename
+ call g_sub_run_number(file,gen_run_number)
+ ierr = threp(b_report_blockname,file)
+ if(ierr.ne.0) then
+ call g_append(err,'& threp failed to create report in file'
+ $ //file)
+ report_abort=.true.
+ endif
+ endif
+
+ if(bdebug_print_adc.ne.0 .or. bdebug_print_tdc.ne.0.or.bdebug_print_trig
+ $ .ne.0.or.bdebug_print_bad.ne.0) then
+ close(bluno)
+ endif
+
+ if(ABORT.or.report_abort) then
+ call G_add_path(here,err)
+ else
+ err=' '
+ endif
+
+ return
+ end
diff --git a/ENGINE/b_register_variables.f b/ENGINE/b_register_variables.f
new file mode 100755
index 0000000..1fad311
--- /dev/null
+++ b/ENGINE/b_register_variables.f
@@ -0,0 +1,47 @@
+ subroutine b_register_variables(ABORT,err)
+
+ implicit none
+ save
+
+ character*20 here
+ parameter (here='b_register_variables')
+
+ logical ABORT
+ character*(*) err
+*
+ logical FAIL
+ character*1000 why
+
+ err= ' '
+ ABORT= .false.
+
+ call r_bigcal_data_structures
+
+ call r_bigcal_filenames
+
+ call r_b_ntuple
+
+ call b_register_param(FAIL,why) ! reconstruction variables
+
+ IF(err.NE.' ' .and. why.NE.' ') THEN !keep warnings
+ call G_append(err,' & '//why)
+ ELSEIF(why.NE.' ') THEN
+ err= why
+ ENDIF
+
+ ABORT= ABORT .or. FAIL
+
+ IF(ABORT .or. err.NE.' ') call G_add_path(here,err)
+
+ call b_ntuple_register(FAIL,why) ! remove this when ctp files fixed
+ if(err.ne.' '.and.why.ne.' ') then
+ call G_append(err,' & '//why)
+ else if(why.ne.' ') then
+ err=why
+ endif
+ abort = abort.or.fail
+
+ if(abort.or.err.ne.' ') call G_add_path(here,err)
+
+ return
+ end
diff --git a/ENGINE/b_reset_event.f b/ENGINE/b_reset_event.f
new file mode 100755
index 0000000..4542329
--- /dev/null
+++ b/ENGINE/b_reset_event.f
@@ -0,0 +1,458 @@
+ subroutine b_reset_event(ABORT,err)
+
+ implicit none
+ save
+
+ character*13 here
+ parameter(here='b_reset_event')
+
+ logical ABORT
+ character*(*) err
+
+ include 'bigcal_data_structures.cmn'
+ include 'bigcal_gain_parms.cmn'
+ include 'bigcal_geometry.cmn'
+ include 'bigcal_shower_parms.cmn'
+ include 'bigcal_tof_parms.cmn'
+ include 'b_ntuple.cmn'
+c include 'gen_units.par'
+c include 'gen_constants.par'
+ include 'gen_run_info.cmn'
+
+ integer i,j,k
+ integer irow,icol,icell,jrow,jcol,jcell
+ integer irow8,icol8,igroup8
+ integer igroup64,ihalf64,ilogic
+
+
+ bigcal_annoying_pulser_event = .false.
+ bigcal_tdc_nhit = 0
+ bigcal_tdc_ndecoded = 0
+ bigcal_time_ngood = 0
+ do i=1,bigcal_tdc_maxhits
+ bigcal_tdc_raw_irow(i) = 0
+ bigcal_tdc_raw_igroup(i) = 0
+ bigcal_tdc_raw(i) = 0
+ bigcal_tdc_irow(i) = 0
+ bigcal_tdc_igroup(i) = 0
+ bigcal_tdc(i) = 0
+ bigcal_time_irow(i) = 0
+ bigcal_time_igroup(i) = 0
+ bigcal_tdc_good(i) = 0
+ bigcal_hit_time(i) = 0.
+ enddo
+
+ bigcal_atrig_nhit = 0
+ bigcal_atrig_ngood = 0
+ bigcal_atrig_nbad = 0
+ do i=1,bigcal_atrig_maxhits
+ bigcal_atrig_igroup(i) = 0
+ bigcal_atrig_ihalf(i) = 0
+ bigcal_atrig_adc_raw(i) = 0
+ bigcal_atrig_good_igroup(i) = 0
+ bigcal_atrig_good_ihalf(i) = 0
+ bigcal_atrig_adc_dec(i) = 0.
+ bigcal_atrig_adc_good(i) = 0.
+ bigcal_atrig_esum(i) = 0.
+
+ bigcal_atrig_igroup_bad(i) = 0
+ bigcal_atrig_ihalf_bad(i) = 0
+ bigcal_atrig_adc_bad(i) = 0
+
+ bigcal_atrig_nhit_ch(i) = 0
+ enddo
+
+ bigcal_ttrig_nhit = 0
+ bigcal_ttrig_ndecoded = 0
+ bigcal_ttrig_ngood = 0
+ do i=1,bigcal_ttrig_maxhits
+ bigcal_ttrig_igroup(i) = 0
+ bigcal_ttrig_ihalf(i) = 0
+ bigcal_ttrig_tdc_raw(i) = 0
+ bigcal_ttrig_dec_igroup(i) = 0
+ bigcal_ttrig_dec_ihalf(i) = 0
+ bigcal_ttrig_tdc_dec(i) = 0
+ bigcal_ttrig_good_igroup(i) = 0
+ bigcal_ttrig_good_ihalf(i) = 0
+ bigcal_ttrig_tdc_good(i) = 0
+ bigcal_ttrig_time_good(i) = 0.
+ enddo
+
+ bigcal_all_ngood = 0
+
+ bigcal_prot_nhit = 0
+ bigcal_prot_ngood = 0
+ bigcal_prot_nbad = 0
+ do i=1,bigcal_prot_maxhits
+ bigcal_prot_iy(i) = 0
+ bigcal_prot_ix(i) = 0
+ bigcal_prot_adc_raw(i) = 0
+ bigcal_prot_iygood(i) = 0
+ bigcal_prot_ixgood(i) = 0
+ bigcal_prot_adc_decoded(i) = 0.
+ bigcal_prot_adc_good(i) = 0.
+ bigcal_prot_ecell(i) = 0.
+ bigcal_prot_xgood(i) = 0.
+ bigcal_prot_ygood(i) = 0.
+
+ bigcal_prot_iybad(i) = 0
+ bigcal_prot_ixbad(i) = 0
+ bigcal_prot_adc_bad(i) = 0
+
+ bigcal_prot_nhit_ch(i) = 0
+
+ bigcal_all_iygood(i) = 0
+ bigcal_all_ixgood(i) = 0
+ bigcal_all_adc_good(i) = 0.
+ bigcal_all_ecell(i) = 0.
+ bigcal_all_xgood(i) = 0.
+ bigcal_all_ygood(i) = 0.
+ b_all_run_clst_good(i) = 0
+ b_all_run_clst_bad(i) = 0
+ b_all_run_clst_eff(i) = 0.
+ b_all_run_Esum(i) = 0.
+ b_all_run_Enum(i) = 0
+ enddo
+
+ bigcal_rcs_nhit = 0
+ bigcal_rcs_ngood = 0
+ bigcal_rcs_nbad = 0
+ do i=1,bigcal_rcs_maxhits
+ bigcal_rcs_iy(i) = 0
+ bigcal_rcs_ix(i) = 0
+ bigcal_rcs_adc_raw(i) = 0
+ bigcal_rcs_iygood(i) = 0
+ bigcal_rcs_ixgood(i) = 0
+ bigcal_rcs_adc_decoded(i) = 0.
+ bigcal_rcs_adc_good(i) = 0.
+ bigcal_rcs_ecell(i) = 0.
+ bigcal_rcs_xgood(i) = 0.
+ bigcal_rcs_ygood(i) = 0.
+
+ bigcal_rcs_iybad(i) = 0
+ bigcal_rcs_ixbad(i) = 0
+ bigcal_rcs_adc_bad(i) = 0
+
+ bigcal_rcs_nhit_ch(i) = 0
+
+ bigcal_all_iygood(i+bigcal_prot_maxhits) = 0
+ bigcal_all_ixgood(i+bigcal_prot_maxhits) = 0
+ bigcal_all_adc_good(i+bigcal_prot_maxhits) = 0.
+ bigcal_all_ecell(i+bigcal_prot_maxhits) = 0.
+ bigcal_all_xgood(i+bigcal_prot_maxhits) = 0.
+ bigcal_all_ygood(i+bigcal_prot_maxhits) = 0.
+ b_all_run_clst_good(i+bigcal_prot_maxhits) = 0
+ b_all_run_clst_bad(i+bigcal_prot_maxhits) = 0
+ b_all_run_clst_eff(i+bigcal_prot_maxhits) = 0.
+ b_all_run_Esum(i+bigcal_prot_maxhits) = 0.
+ b_all_run_Enum(i+bigcal_prot_maxhits) = 0
+ enddo
+
+ bigcal_iymax_adc = 0
+ bigcal_ixmax_adc = 0
+ bigcal_max_adc = 0.
+
+c$$$ bigcal_iymax_final = 0
+c$$$ bigcal_ixmax_final = 0
+c$$$ bigcal_max_adc_final = 0.
+
+* zero "detector" arrays:
+
+ do i=1,BIGCAL_PROT_MAXHITS
+ BIGCAL_PROT_RAW_DET(i) = 0
+ BIGCAL_PROT_GOOD_DET(i) = 0.
+c BIGCAL_PROT_GOOD_HIT(i) = .false.
+ BIGCAL_ALL_ADC_DET(i) = 0.
+ BIGCAL_ALL_GOOD_DET(i) = 0.
+ enddo
+
+ do i=1,BIGCAL_RCS_MAXHITS
+ BIGCAL_RCS_RAW_DET(i) = 0
+ BIGCAL_RCS_GOOD_DET(i) = 0.
+c BIGCAL_RCS_GOOD_HIT(i) = .false.
+ BIGCAL_ALL_ADC_DET(i+bigcal_prot_maxhits) = 0.
+ BIGCAL_ALL_GOOD_DET(i+bigcal_prot_maxhits) = 0.
+ enddo
+
+ do i=1,BIGCAL_MAX_TDC
+ bigcal_tdc_det_nhit(i) = 0
+ bigcal_tdc_det_ngood(i) = 0
+ bigcal_tdc_sum8(i) = 0.
+ do j=1,8
+ BIGCAL_TDC_RAW_DET(i,j) = 0
+ bigcal_tdc_good_det(i,j) = -9999.
+ enddo
+ enddo
+
+ do i=1,bigcal_atrig_maxhits
+ bigcal_atrig_raw_det(i) = 0
+ bigcal_atrig_good_det(i) = 0.
+ bigcal_atrig_sum64(i) = 0.
+ enddo
+
+ do i=1,bigcal_ttrig_maxgroups
+ bigcal_ttrig_det_nhit(i) = 0
+ bigcal_ttrig_det_ngood(i) = 0
+ do j=1,8
+ bigcal_ttrig_raw_det(i,j) = 0
+ bigcal_ttrig_good_det(i,j) = -9999.
+ enddo
+ enddo
+
+c$$$ do i=30,35
+c$$$ do j=1,32
+c$$$ bigcal_mid_ehit(i,j) = 0.
+c$$$ bigcal_mid_xhit(i,j) = 0.
+c$$$ bigcal_mid_yhit(i,j) = 0.
+c$$$ enddo
+c$$$ enddo
+
+c bigcal_prot_bad_clstr_flag(0) = 0
+
+ bigcal_all_nclstr = 0
+ bigcal_nmaxima = 0
+ do i=1,bigcal_all_nclstr_max
+ bigcal_all_clstr_ncell(i) = 0
+ bigcal_all_clstr_ncellx(i) = 0
+ bigcal_all_clstr_ncelly(i)= 0
+ bigcal_all_clstr_nbadlist(i) = 0
+ bigcal_all_clstr_iymax(i) = 0
+ bigcal_all_clstr_ixmax(i) = 0
+ bigcal_all_clstr_iylo(i)=0
+ bigcal_all_clstr_iyhi(i) = 0
+ do j=1,3
+ bigcal_all_clstr_ixlo(i,j) = 0
+ bigcal_all_clstr_ixhi(i,j) = 0
+ enddo
+ bigcal_all_clstr_ncell8(i) = 0
+ bigcal_all_clstr_ncell64(i) = 0
+ bigcal_all_clstr_xmom(i) = 0.
+ bigcal_all_clstr_ymom(i) = 0.
+ bigcal_all_clstr_x(i) = 0.
+ bigcal_all_clstr_y(i) = 0.
+ bigcal_all_clstr_etot(i) = 0.
+ bigcal_all_clstr_atot(i) = 0.
+ bigcal_all_clstr_t8mean(i) = 0.
+ bigcal_all_clstr_t8rms(i) = 0.
+ bigcal_all_clstr_t8cut(i) = 0.
+ bigcal_all_clstr_t8cut_cor(i) = 0.
+ bigcal_all_clstr_t64mean(i) = 0.
+ bigcal_all_clstr_t64rms(i) = 0.
+ bigcal_all_clstr_t64cut(i) = 0.
+ bigcal_all_clstr_t64cut_cor(i) = 0.
+ bigcal_all_clstr_chi2(i) = 0.
+ do j=1,6
+ bigcal_all_clstr_chi2contr(i,j) = 0.
+ enddo
+ do j=1,bigcal_clstr_ncell_max
+ bigcal_all_clstr_iycell(i,j) = 0
+ bigcal_all_clstr_ixcell(i,j) = 0
+ bigcal_all_clstr_ycell(i,j) = 0.
+ bigcal_all_clstr_xcell(i,j) = 0.
+ bigcal_all_clstr_ecell(i,j) = 0.
+ bigcal_all_clstr_acell(i,j) = 0.
+ bigcal_clstr_bad_chan(i,j) = .false.
+ enddo
+
+ do j=1,10
+ bigcal_all_clstr_nhit8(i,j) = 0
+ bigcal_all_clstr_irow8(i,j) = 0
+ bigcal_all_clstr_icol8(i,j) = 0
+ bigcal_all_clstr_s8(i,j) = 0.
+ do k=1,8
+ bigcal_all_clstr_tcell8(i,j,k) = 0.
+ enddo
+ enddo
+
+ do j=1,6
+ bigcal_all_clstr_nhit64(i,j) = 0
+ bigcal_all_clstr_irow64(i,j) = 0
+ bigcal_all_clstr_icol64(i,j) = 0
+ bigcal_all_clstr_sum64(i,j) = 0.
+ do k=1,8
+ bigcal_all_clstr_tcell64(i,j,k) = 0.
+ enddo
+ enddo
+
+ bigcal_edge_max(i) = .false.
+ bigcal_not_enough(i) = .false.
+ bigcal_too_long_x(i) = .false.
+ bigcal_too_long_y(i) = .false.
+ bigcal_below_cut(i) = .false.
+ bigcal_above_max(i) = .false.
+ bigcal_second_max(i) = .false.
+
+ enddo
+
+ bigcal_phys_ntrack = 0
+ bigcal_itrack_best = 0
+
+ bigcal_thetarad = 0.
+c bigcal_thetadeg = 0.
+ bigcal_phirad = 0.
+c bigcal_phideg = 0.
+ bigcal_energy = 0.
+ bigcal_time = 0.
+ bigcal_xface = 0.
+ bigcal_yface = 0.
+ bigcal_zface = 0.
+ bigcal_px = 0.
+ bigcal_py = 0.
+ bigcal_pz = 0.
+ bigcal_beta = 0.
+ bigcal_eloss = 0.
+ bigcal_tof_cor = 0.
+ bigcal_tof = 0.
+ bigcal_ctime = 0.
+
+ do i=1,bigcal_max_ntrack
+ bigcal_track_thetarad(i) = 0.
+ bigcal_track_thetadeg(i) = 0.
+ bigcal_track_phirad(i) = 0.
+ bigcal_track_phideg(i) = 0.
+ bigcal_track_energy(i) = 0.
+ bigcal_track_eloss(i) = 0.
+ bigcal_track_time(i) = 0.
+ bigcal_track_xface(i) = 0.
+ bigcal_track_yface(i) = 0.
+ bigcal_track_zface(i) = 0.
+ bigcal_track_px(i) = 0.
+ bigcal_track_py(i) = 0.
+ bigcal_track_pz(i) = 0.
+ bigcal_track_beta(i) = 0.
+ bigcal_track_tof(i) = 0.
+ bigcal_track_tof_cor(i) = 0.
+ bigcal_track_coin_time(i) = 0.
+ enddo
+
+c$$$ if(gen_bigcal_mc.ne.0) then
+c$$$ !override pedestals info from param file: set all to zero for monte carlo events:
+c$$$ !also override calibration constants:
+c$$$ do i=1,bigcal_prot_maxhits
+c$$$ bigcal_prot_ped_mean(i) = 0.0
+c$$$ bigcal_prot_ped_rms(i) = 0.0
+c$$$ bigcal_prot_adc_threshold(i) = 0.0
+c$$$ bigcal_prot_cfac(i) = 1./950.79
+c$$$ enddo
+c$$$ do i=1,bigcal_rcs_maxhits
+c$$$ bigcal_rcs_ped_mean(i) = 0.0
+c$$$ bigcal_rcs_ped_rms(i) = 0.0
+c$$$ bigcal_rcs_adc_threshold(i) = 0.0
+c$$$ bigcal_rcs_cfac(i) = 1./911.57
+c$$$ enddo
+c$$$ endif
+
+c clear out cluster ntuple variables:
+
+ nclust = 0
+ nclust8 = 0
+ nclust64 = 0
+ ntrack = 0
+ ibest = 0
+ nmax = 0
+ do i=1,maxnclust
+ ncellclust(i) = 0
+ ncellbad(i) = 0
+ ncellx(i) = 0
+ ncelly(i) = 0
+ ncell8clust(i) = 0
+ ncell64clust(i) = 0
+ xmoment(i) = 0.
+ ymoment(i) = 0.
+ tclust8(i) = 0.
+ tcut8(i) = 0.
+ tcut8cor(i) = 0.
+ trms8(i) = 0.
+ tclust64(i) = 0.
+ tcut64(i) = 0.
+ tcut64cor(i) = 0.
+ trms64(i) = 0.
+ xclust(i) = 0.
+ yclust(i) = 0.
+ eclust(i) = 0.
+ aclust(i) = 0.
+ do j=1,maxncellclust
+ iycell(j,i) = 0
+ ixcell(j,i) = 0
+ xcell(j,i) = 0.
+ ycell(j,i) = 0.
+ eblock(j,i) = 0.
+ cellbad(j,i) = .false.
+ enddo
+ do j=1,10
+ irow8hit(j,i) = 0
+ icol8hit(j,i) = 0
+ nhit8clust(j,i) = 0
+ s8(j,i) = 0.
+ do k=1,8
+ tcell8(j,k,i) = 0.
+ enddo
+ enddo
+ do j=1,6
+ irow64hit(j,i) = 0
+ icol64hit(j,i) = 0
+ nhit64clust(j,i) = 0.
+ a64(j,i) = 0.
+ s64(j,i) = 0.
+ do k=1,8
+ tcell64(j,k,i) = 0.
+ enddo
+ enddo
+ thetarad(i) = 0.
+ phirad(i) = 0.
+ xface(i) = 0.
+ yface(i) = 0.
+ zface(i) = 0.
+ px(i) = 0.
+ py(i) = 0.
+ pz(i) = 0.
+ ctime_clust(i) = 0.
+ chi2clust(i) = 0.
+ do j=1,6
+ chi2contr(j,i) = 0.
+ enddo
+ edge_max(i) = .false.
+ not_enough(i) = .false.
+ too_long_x(i) = .false.
+ too_long_y(i) = .false.
+ below_thresh(i) = .false.
+ above_max(i) = .false.
+ second_max(i) = .false.
+ enddo
+
+ ngooda = 0
+ ngoodt = 0
+ ngoodta = 0
+ ngoodtt = 0
+ irowmax = 0
+ icolmax = 0
+ max_adc = 0.
+
+c clear out monte carlo event info variables:
+
+ ntrk_g = 0
+ xvertex_g = 0.
+ yvertex_g = 0.
+ zvertex_g = 0.
+ do i=1,maxnclust
+ pid_g(i) = 0
+ pxgeant(i) = 0.
+ pygeant(i) = 0.
+ pzgeant(i) = 0.
+ xgeant(i) = 0.
+ ygeant(i) = 0.
+ egeant(i) = 0.
+ pgeant(i) = 0.
+ gthetarad(i) = 0.
+ gphirad(i) = 0.
+ enddo
+
+ E_HMS = 0.
+ X_HMS = 0.
+ Y_HMS = 0.
+ TH_HMS = 0.
+ PH_HMS = 0.
+ dPel_HMS = 0.
+
+ return
+ end
diff --git a/ENGINE/b_tree_init.f b/ENGINE/b_tree_init.f
new file mode 100644
index 0000000..e9603ff
--- /dev/null
+++ b/ENGINE/b_tree_init.f
@@ -0,0 +1,31 @@
+ subroutine b_tree_init(abort,err)
+
+ implicit none
+ save
+
+ character*11 here
+ parameter(here='b_tree_init')
+
+ include 'bigcal_filenames.cmn'
+ include 'gen_routines.dec'
+ include 'bigcal_data_structures.cmn'
+ include 'gen_run_info.cmn'
+c include 'b_ntuple.dte'
+
+ logical abort
+ character*(*) err
+
+c only purpose of this routine is to substitute run number in
+c tree filename! CTP will take care of the rest!!!!!!!!!!!
+
+ call no_nulls(b_tree_filename)
+
+ if(b_tree_filename.eq.' ') return
+
+ call g_sub_run_number(b_tree_filename,gen_run_number)
+
+ abort=.false.
+ err=' '
+
+ return
+ end
diff --git a/ENGINE/bigcal_mc_reconstruction.f b/ENGINE/bigcal_mc_reconstruction.f
new file mode 100644
index 0000000..1036cdd
--- /dev/null
+++ b/ENGINE/bigcal_mc_reconstruction.f
@@ -0,0 +1,226 @@
+ subroutine bigcal_mc_reconstruction(iflag,ABORT,err)
+
+ implicit none
+ save
+
+ integer iflag,jflag,io_unit,i,j,k
+ logical ABORT
+ character*(*) err
+
+ character*24 here
+ parameter(here='bigcal_mc_reconstruction')
+
+ real xhat,yhat,zhat,pxh,pyh,pzh,xvh,yvh,zvh
+ real xvh_temp,yvh_temp,zvh_temp
+ real tintercept,xintercept,yintercept,zintercept
+ real gbthetarad
+ parameter(gbthetarad=1.1868239)
+ real gbrcm
+ parameter(gbrcm=448.0)
+
+ include 'bigcal_data_structures.cmn'
+ include 'gen_run_info.cmn'
+ include 'gen_filenames.cmn'
+ include 'bigcal_bypass_switches.cmn'
+ include 'b_ntuple.cmn'
+c include 'gen_constants.par'
+
+ abort=.false.
+ err=' '
+
+ if(iflag.eq.1.or.iflag.eq.3) then !bigcal mc .dat file
+ io_unit = g_data_source_in_hndl
+
+ jflag = 0
+
+ read(io_unit,end=101,err=101) iev_mc
+
+ evid_g = iev_mc
+
+ read(io_unit,end=101,err=101) xv_mc,yv_mc,zv_mc
+ read(io_unit,end=101,err=101) nvtrk_mc
+
+c$$$ xvertex_g = xv_mc
+c$$$ yvertex_g = yv_mc
+c$$$ zvertex_g = zv_mc
+ if(nvtrk_mc.le.25) then
+ ntrk_g = nvtrk_mc
+ else
+ ntrk_g = 25
+ endif
+
+ jflag = 1
+
+ do i=1,nvtrk_mc
+ read(io_unit,end=101,err=101) pid_mc(i),px_mc(i),py_mc(i),
+ $ pz_mc(i)
+ if(i.le.25) then
+ pid_g(i) = pid_mc(i)
+c$$$ pxgeant(i) = px_mc(i)
+c$$$ pygeant(i) = py_mc(i)
+c$$$ pzgeant(i) = pz_mc(i)
+ pgeant(i) = sqrt((px_mc(i))**2 + (py_mc(i))**2 +
+ $ (pz_mc(i))**2 )
+ if(pid_g(i).eq.2.or.pid_g(i).eq.3) then !electron-positron
+ egeant(i) = sqrt((.510999e-3)**2 + (pgeant(i))**2)
+ else if(pid_g(i).eq.1) then ! photon
+ egeant(i) = pgeant(i)
+ else if(pid_g(i).eq.13.or.pid_g(i).eq.14) then ! nucleon
+ egeant(i) = sqrt(.938272**2 + (pgeant(i))**2)
+ else if(pid_g(i).eq.5.or.pid_g(i).eq.6) then ! muon
+ egeant(i) = sqrt(.105658**2 + (pgeant(i))**2)
+ else if(pid_g(i).eq.8.or.pid_g(i).eq.9) then ! pion
+ egeant(i) = sqrt(.13957**2 + (pgeant(i))**2)
+ else ! assume electron:
+ egeant(i) = sqrt((.510999e-3)**2 + (pgeant(i))**2)
+ endif
+
+ ! now calculate trajectory and intersection point:
+c$$$ xhat = pxgeant(i) / pgeant(i)
+c$$$ yhat = pygeant(i) / pgeant(i)
+c$$$ zhat = pzgeant(i) / pgeant(i)
+
+ ! in the GEANT coordinate system, the calo is always at 440 cm and 68 degrees
+ ! need to rotate and translate coordinates appropriately into hall system:
+
+ pxh = px_mc(i)*cos(bigcal_theta_rad-gbthetarad)
+ $ + pz_mc(i)*sin(bigcal_theta_rad-gbthetarad)
+ pyh = py_mc(i)
+ pzh = -px_mc(i)*sin(bigcal_theta_rad-gbthetarad)
+ $ + pz_mc(i)*cos(bigcal_theta_rad-gbthetarad)
+
+ pxgeant(i) = pxh
+ pygeant(i) = pyh
+ pzgeant(i) = pzh
+
+ xhat = pxgeant(i)/pgeant(i)
+ yhat = pygeant(i)/pgeant(i)
+ zhat = pzgeant(i)/pgeant(i)
+
+ gthetarad(i) = acos(zhat)
+ gphirad(i) = atan2(yhat,xhat)
+c translate
+ xvh_temp = xv_mc + (bigcal_r_tgt - gbrcm)*sin(gbthetarad)
+ zvh_temp = zv_mc + (bigcal_r_tgt - gbrcm)*cos(gbthetarad)
+c rotate
+ xvh = xvh_temp*cos(bigcal_theta_rad-gbthetarad) +
+ $ zvh_temp*sin(bigcal_theta_rad-gbthetarad)
+ yvh = yv_mc
+ zvh = -xvh_temp*sin(bigcal_theta_rad-gbthetarad) +
+ $ zvh_temp*cos(bigcal_theta_rad-gbthetarad)
+
+ xvertex_g = xvh
+ yvertex_g = yvh
+ zvertex_g = zvh
+
+ ! calculate intersection point of trajectory with calo:
+
+ tintercept = (bigcal_r_tgt - xvertex_g*bigcal_sintheta -
+ $ zvertex_g*bigcal_costheta)/(xhat*bigcal_sintheta +
+ $ zhat*bigcal_costheta)
+
+ xintercept = xvertex_g + tintercept*xhat
+ yintercept = yvertex_g + tintercept*yhat
+ zintercept = zvertex_g + tintercept*zhat
+
+ ! rotate into calo-centered coordinate system:
+
+ xgeant(i) = xintercept*bigcal_costheta -
+ $ zintercept*bigcal_sintheta
+ ygeant(i) = yintercept
+
+ ! and that's it!!!!!
+
+ endif
+ enddo
+
+ jflag = 2
+
+ read(io_unit,end=101,err=101) isum_mc
+ read(io_unit,end=101,err=101) esum_mc
+
+ jflag = 3
+
+ bigcal_prot_nhit = isum_mc(1)
+ bigcal_rcs_nhit = isum_mc(2)
+c here's the key part: fill the raw hit arrays!!!
+ do i=1,isum_mc(1)
+ read(io_unit,end=101,err=101) ix_mc,iy_mc,npe_mc
+ bigcal_prot_ix(i) = ix_mc
+ bigcal_prot_iy(i) = iy_mc
+ bigcal_prot_adc_raw(i) = nint(npe_mc)
+ enddo
+
+ jflag = 4
+
+ do i=1,isum_mc(2)
+ read(io_unit,end=101,err=101) ix_mc,iy_mc,npe_mc
+ bigcal_rcs_ix(i) = ix_mc
+ bigcal_rcs_iy(i) = iy_mc + 32
+ bigcal_rcs_adc_raw(i) = nint(npe_mc)
+ enddo
+
+ jflag = 5
+
+ read(io_unit,end=101,err=101) idesum_mc
+ read(io_unit,end=101,err=101) allde_mc
+
+ jflag = 6
+
+ do i=1,2
+ do j=1,idesum_mc(i)
+ read(io_unit,end=101,err=101) ix_mc,iy_mc,dedx_mc
+ enddo
+ enddo
+
+ jflag = 7
+
+c read proton data if it's there:
+
+ if(gen_bigcal_mc.eq.3) then
+ read(io_unit,end=101,err=101) iev_p_mc
+ read(io_unit,end=101,err=101) pp_mc,ptheta_mc,pphi_mc,
+ $ xv_p_mc,yv_p_mc,zv_p_mc
+ endif
+
+ jflag = 8
+
+c override bypass flags from parameter files:
+c$$$ bbypass_prot = 0
+c$$$ bbypass_rcs = 0
+c$$$ bbypass_sum8 = 1
+c$$$ bbypass_sum64 = 1
+c$$$ bbypass_find_clusters = 0
+c$$$ bbypass_calc_cluster_time = 1
+c$$$ bbypass_calc_shower_coord = 0
+c$$$ bbypass_calc_physics = 0
+c BAD PUCKETT! DON'T hardwire things into the code, mmm'kay?
+
+ !write(*,*) 'entering b_reconstruction'
+
+ call b_reconstruction(abort,err)
+
+ if(gen_bigcal_mc.eq.3) then
+ call gep_reconstruction(abort,err)
+ endif
+
+ !write(*,*) 'finished b_reconstruction'
+
+ if(abort) then
+ call g_add_path(here,err)
+ return
+ endif
+
+ return
+
+ 101 write(*,*) 'end of file',g_data_source_filename,'reached'
+ EOF_MC_DAT = .true.
+ return
+
+ else if(iflag.eq.2) then !wei's bigcal mc ntuple
+
+
+ endif
+
+ return
+ end
diff --git a/ENGINE/c_clear_event.f b/ENGINE/c_clear_event.f
new file mode 100644
index 0000000..5eb98ca
--- /dev/null
+++ b/ENGINE/c_clear_event.f
@@ -0,0 +1,56 @@
+ SUBROUTINE C_clear_event(ABORT,err)
+*--------------------------------------------------------
+*- Prototype C analysis routine
+*-
+*-
+*- Purpose and Methods : clears all COIN quantities before an event
+*- is processed.
+*-
+*-
+*- Output: ABORT - success or failure
+*- : err - reason for failure, if any
+*-
+*- Created 29-Oct-1993 Kevin B. Beard
+*- Modified 6-Dec-1993 K.B.Beard: adopt new errors
+* $Log: c_clear_event.f,v $
+* Revision 1.5 1999/02/23 16:39:34 csa
+* Fixed thinko on last rev
+*
+* Revision 1.4 1999/02/10 17:44:35 csa
+* Added call to c_ntuple_clear
+*
+* Revision 1.3 1996/01/16 20:59:10 cdaq
+* no change
+*
+* Revision 1.2 1995/05/22 20:50:42 cdaq
+* (SAW) Split gen_data_data_structures into gen, hms, sos, and coin parts"
+*
+* Revision 1.1 1994/02/04 21:05:40 cdaq
+* Initial revision
+*
+*-
+*- All standards are from "Proposal for Hall C Analysis Software
+*- Vade Mecum, Draft 1.0" by D.F.Geesamn and S.Wood, 7 May 1993
+*-
+*-
+*--------------------------------------------------------
+ IMPLICIT NONE
+ SAVE
+*
+ character*13 here
+ parameter (here= 'C_clear_event')
+*
+ logical ABORT
+ character*(*) err
+*
+ INCLUDE 'coin_data_structures.cmn'
+*
+*--------------------------------------------------------
+*
+ call c_ntuple_clear
+
+ ABORT= .FALSE.
+ err= ' '
+
+ RETURN
+ END
diff --git a/ENGINE/c_initialize.f b/ENGINE/c_initialize.f
new file mode 100644
index 0000000..d03b1ba
--- /dev/null
+++ b/ENGINE/c_initialize.f
@@ -0,0 +1,81 @@
+ SUBROUTINE C_initialize(ABORT,err)
+*--------------------------------------------------------
+*- Prototype C analysis routine
+*-
+*-
+*- Purpose and Methods : Initializes COIN quantities
+*-
+*- Output: ABORAT - success or failure
+*- : err - reason for failure, if any
+*-
+*- Created 8-Nov-1993 Kevin B. Beard
+* $Log: c_initialize.f,v $
+* Revision 1.9 2002/12/27 21:49:43 jones
+* Ioana Niculescu modified total_eloss call
+*
+* Revision 1.8 1999/02/10 17:39:36 csa
+* Changed celoss to geloss
+*
+* Revision 1.7 1996/01/22 15:04:19 saw
+* (JRA) Change cebeam and cpbeam to gebeam and gpbeam
+*
+* Revision 1.6 1996/01/16 20:59:39 cdaq
+* no change
+*
+* Revision 1.5 1995/05/22 20:50:43 cdaq
+* (SAW) Split gen_data_data_structures into gen, hms, sos, and coin parts"
+*
+* Revision 1.4 1995/05/11 13:44:50 cdaq
+* (SAW) Add calculation of s from beam and target info
+*
+* Revision 1.3 1994/06/14 03:16:09 cdaq
+* (DFG) Add CEBEAM calculation
+*
+* Revision 1.2 1994/04/12 17:08:54 cdaq
+* (KBB) Add ntuple call
+*
+* Revision 1.1 1994/02/04 21:06:11 cdaq
+* Initial revision
+*
+*-
+*-
+*- All standards are from "Proposal for Hall C Analysis Software
+*- Vade Mecum, Draft 1.0" by D.F.Geesamn and S.Wood, 7 May 1993
+*-
+*-
+*--------------------------------------------------------
+ IMPLICIT NONE
+ SAVE
+*
+ character*12 here
+ parameter (here= 'C_initialize')
+*
+ logical ABORT
+ character*(*) err
+*
+ INCLUDE 'gen_data_structures.cmn'
+** INCLUDE 'coin_data_structures.cmn'
+ INCLUDE 'gen_constants.par'
+*
+*--------------------------------------------------------
+*
+ ABORT= .FALSE.
+*
+ gebeam=sqrt(gpbeam**2 + mass_electron**2)
+ if(gtarg_z(gtarg_num).gt.0.)then
+ call total_eloss(0,.true.,0.0,1.0,geloss)
+ else
+ geloss=0.
+ endif
+ gebeam = gebeam - geloss
+ gpbeam = sqrt(gebeam**2 - mass_electron**2)
+ g_beam_target_s = (gtarg_mass(gtarg_num) + gebeam)**2 - gpbeam**2
+*
+ IF(ABORT) THEN
+ call G_add_path(here,err)
+ ELSE
+ err= ' '
+ ENDIF
+*
+ RETURN
+ END
diff --git a/ENGINE/c_keep_results.f b/ENGINE/c_keep_results.f
new file mode 100644
index 0000000..0c541ae
--- /dev/null
+++ b/ENGINE/c_keep_results.f
@@ -0,0 +1,66 @@
+ SUBROUTINE C_keep_results(ABORT,err)
+*--------------------------------------------------------
+*- Prototype C analysis routine
+*-
+*-
+*- Purpose and Methods : Keeps statistics, etc.
+*-
+*- Output: ABORT - success or failure
+*- : err - reason for failure, if any
+*-
+*- Created 20-Nov-1993 Kevin B. Beard for new error standards
+* $Log: c_keep_results.f,v $
+* Revision 1.5 1996/09/04 15:29:30 saw
+* * (JRA) Make HSNUM_FPTRACK.gt.0 and SSNUM_FPTRACK.gt.0 instead of
+* HNTRACKS_FP .gt. 0 and HNTRACKS_FP .gt. 0 as criteria for
+* adding to ntuples
+*
+* Revision 1.4 1996/01/22 15:05:20 saw
+* (JRA) Only fill coin ntuple if HMS and SOS both have tracks
+*
+* Revision 1.3 1996/01/16 21:00:40 cdaq
+* no change
+*
+* Revision 1.2 1994/04/12 17:10:33 cdaq
+* (KBB) Add ntuple call
+*
+* Revision 1.1 1994/02/04 21:07:07 cdaq
+* Initial revision
+*
+*-
+*- All standards are from "Proposal for Hall C Analysis Software
+*- Vade Mecum, Draft 1.0" by D.F.Geesamn and S.Wood, 7 May 1993
+*-
+*-
+*--------------------------------------------------------
+ IMPLICIT NONE
+ SAVE
+*
+ include 'hms_data_structures.cmn'
+ include 'sos_data_structures.cmn'
+*
+ character*14 here
+ parameter (here= 'C_keep_results')
+*
+ logical ABORT
+ character*(*) err
+*
+*--------------------------------------------------------
+*-chance to flush any statistics, etc.
+*
+*
+ ABORT= .FALSE.
+ err = ' '
+*
+ if(HSNUM_FPTRACK .gt. 0 .AND. SSNUM_FPTRACK .gt. 0) ! check for tracks
+ > call c_ntuple_keep(ABORT,err)
+*
+ IF(ABORT) THEN
+ call G_add_path(here,err)
+ RETURN
+ ELSE
+ err= ' '
+ ENDIF
+*
+ RETURN
+ END
diff --git a/ENGINE/c_ntuple_change.f b/ENGINE/c_ntuple_change.f
new file mode 100644
index 0000000..41b2ad2
--- /dev/null
+++ b/ENGINE/c_ntuple_change.f
@@ -0,0 +1,87 @@
+ subroutine c_ntuple_change(ABORT,err)
+*----------------------------------------------------------------------
+*
+* closes one HMS Ntuple file and opens another
+*
+* Purpose : switching from one file to the next
+*
+* Output: ABORT - success or failure
+* : err - reason for failure, if any
+*
+*----------------------------------------------------------------------
+
+ implicit none
+ save
+
+ character*15 here
+ parameter (here='c_ntuple_change')
+
+ logical ABORT
+ character*(*) err
+
+ INCLUDE 'c_ntuple.cmn'
+ include 'gen_run_info.cmn'
+
+ character*1 ifile
+ character*80 file
+ character*1000 pat
+
+ integer*4 ilo,fn_len
+
+* functions
+ integer g_important_length
+
+*--------------------------------------------------------
+
+
+ call c_ntuple_close(ABORT,err)
+
+
+
+ if (c_ntuple_exists) then
+ ABORT = .true.
+ endif
+
+ call NO_nulls(c_ntuple_file) !replace null characters with blanks
+
+ file= c_ntuple_file
+ call NO_nulls(file) !replace null characters with blanks
+ call g_sub_run_number(file,gen_run_number)
+
+ c_ntuple_filesegments = c_ntuple_filesegments + 1
+
+ if (c_ntuple_filesegments .le. 9) then
+ ifile = char(ichar('0')+c_ntuple_filesegments)
+ else
+ ifile = char(ichar('a')+c_ntuple_filesegments-10)
+ endif
+
+ fn_len = g_important_length(file)
+ ilo=index(file,'.hbook')
+ if ((ilo.le.1).or.(ilo.gt.fn_len-5)) then
+ ilo=index(file,'.rzdat')
+ endif
+
+ if ((ilo.gt.1).and.(ilo.lt.fn_len)) then
+ file = file(1:ilo-1) // '.' // ifile // file(ilo:fn_len)
+ else
+ ABORT = .true.
+ endif
+
+
+
+ IF (.not.ABORT) call c_ntuple_open(file,ABORT,err)
+
+
+ IF(ABORT) THEN
+ err= ':unable to change Coin Ntuple file segment'
+ call G_add_path(here,err)
+ ELSE
+ pat= ':changed Coin Ntuple file segment'
+ call G_add_path(here,pat)
+ call G_log_message('INFO: '//pat)
+ ENDIF
+
+
+ RETURN
+ END
diff --git a/ENGINE/c_ntuple_clear.f b/ENGINE/c_ntuple_clear.f
new file mode 100644
index 0000000..83a069b
--- /dev/null
+++ b/ENGINE/c_ntuple_clear.f
@@ -0,0 +1,30 @@
+ subroutine c_Ntuple_clear
+*----------------------------------------------------------------------
+*
+* Purpose : Clear vars that go to the COIN Ntuple
+*
+* csa 4/15/97
+*
+* $Log: c_ntuple_clear.f,v $
+* Revision 1.1 1999/02/24 14:52:36 saw
+* Dummy routine
+*
+*
+*----------------------------------------------------------------------
+ implicit none
+ save
+*
+* character*13 here
+* parameter (here='c_Ntuple_clear')
+*
+* logical ABORT
+* character*(*) err
+*
+
+* csa 2/2/99 -- This is a dummy routine in the CVS tree. The
+* real thing gets created in the user's Oscar directory based
+* on which variables are in the ntuple.lst file.
+
+*
+ RETURN
+ END
diff --git a/ENGINE/c_ntuple_close.f b/ENGINE/c_ntuple_close.f
new file mode 100644
index 0000000..3a7157b
--- /dev/null
+++ b/ENGINE/c_ntuple_close.f
@@ -0,0 +1,77 @@
+ subroutine c_Ntuple_close(ABORT,err)
+*----------------------------------------------------------------------
+*
+* closes the HMS Ntuple file
+*
+* Purpose : Flushes and closes the HMS Ntuple
+*
+* Output: ABORT - success or failure
+* : err - reason for failure, if any
+*
+*----------------------------------------------------------------------
+
+ implicit none
+ save
+
+ character*14 here
+ parameter (here='c_Ntuple_close')
+
+ logical ABORT
+ character*(*) err
+*
+ INCLUDE 'c_ntuple.cmn'
+ INCLUDE 'gen_routines.dec'
+*
+ logical HEXIST !CERNLIB function
+*
+ logical FAIL
+ character*80 why,directory,name
+ character*1000 msg
+ integer io,id,cycle,m
+*
+*--------------------------------------------------------
+
+ err= ' '
+ ABORT = .FALSE.
+
+ IF(.NOT.c_Ntuple_exists) RETURN !nothing to do
+
+ call HCDIR(directory,'R') !keep current directory
+
+ id= c_Ntuple_ID
+ io= c_Ntuple_IOchannel
+ name= c_Ntuple_name
+
+ ABORT= .NOT.HEXIST(id)
+ IF(ABORT) THEN
+ call G_add_path(here,err)
+ If(io.GT.0) Then
+ call G_IO_control(io,'FREE',FAIL,why) !free up
+ if(.NOT.FAIL) CLOSE(io)
+ EndIf
+ c_Ntuple_exists= .FALSE.
+ c_Ntuple_IOchannel= 0
+ RETURN
+ ENDIF
+
+ call HCDIR(c_Ntuple_directory,' ') !goto Ntuple directory
+
+ call G_add_path(here,msg)
+ call G_log_message('INFO: '//msg)
+
+ cycle= 0 !dummy for HROUT
+ call HROUT(id,cycle,' ') !flush CERNLIB buffers
+ call HREND(name) !CERNLIB close file
+ call G_IO_control(io,'FREE',ABORT,err) !free up IO channel
+ CLOSE(io) !close IO channel
+
+ call HCDIR(directory,' ') !return to current directory
+
+ c_Ntuple_directory= ' '
+ c_Ntuple_exists= .FALSE.
+ c_Ntuple_IOchannel= 0
+
+ IF(ABORT) call G_add_path(here,err)
+
+ RETURN
+ END
diff --git a/ENGINE/c_ntuple_init.f b/ENGINE/c_ntuple_init.f
new file mode 100644
index 0000000..288da11
--- /dev/null
+++ b/ENGINE/c_ntuple_init.f
@@ -0,0 +1,250 @@
+ subroutine c_Ntuple_init(ABORT,err)
+*----------------------------------------------------------------------
+*
+* Creates an COIN Ntuple
+*
+* Purpose : Books an COIN Ntuple; defines structure of it
+*
+* Output: ABORT - success or failure
+* : err - reason for failure, if any
+*
+* Created: 8-Apr-1994 K.B.Beard, Hampton Univ.
+* $Log: c_ntuple_init.f,v $
+* Revision 1.10.18.1 2007/10/16 20:20:31 cdaq
+* *** empty log message ***
+*
+* Revision 1.10 2004/02/17 17:26:34 jones
+* Changes to enable possiblity of segmenting rzdat files
+*
+* Revision 1.9 1999/02/23 16:40:37 csa
+* Variable changes
+*
+* Revision 1.8 1996/09/04 15:29:57 saw
+* (JRA) Modify ntuple contents
+*
+* Revision 1.7 1996/01/22 15:06:25 saw
+* (JRA) Change ntuple contents
+*
+* Revision 1.6 1996/01/16 21:01:12 cdaq
+* (JRA) Add HSDELTA and SSDELTA
+*
+* Revision 1.5 1995/08/08 16:09:40 cdaq
+* (DD) Change ntuple list
+*
+* Revision 1.4 1995/07/27 18:59:48 cdaq
+* (SAW) Relocate data statements for f2c compatibility
+*
+* Revision 1.3 1995/05/11 13:55:27 cdaq
+* (SAW) Allow %d for run number in filenames
+*
+* Revision 1.2 1994/06/17 02:32:24 cdaq
+* (KBB) Upgrade
+*
+* Revision 1.1 1994/04/12 16:11:34 cdaq
+* Initial revision
+*
+*
+*----------------------------------------------------------------------
+ implicit none
+ save
+*
+ character*13 here
+ parameter (here='c_Ntuple_init')
+*
+ logical ABORT
+ character*(*) err
+*
+ INCLUDE 'c_ntuple.cmn'
+ INCLUDE 'gen_routines.dec'
+ include 'gen_run_info.cmn'
+*
+ character*80 default_name
+ parameter (default_name= 'COINntuple')
+
+ character*80 file
+ character*80 name
+ character*1000 pat,msg
+ integer ilo,fn_len,m
+ character*1 ifile
+*
+ logical HEXIST !CERNLIB function
+*
+ INCLUDE 'c_ntuple.dte'
+*
+*--------------------------------------------------------
+*--------------------------------------------------------
+ err= ' '
+ ABORT = .FALSE.
+*
+ IF(c_Ntuple_exists) THEN
+ call c_Ntuple_shutdown(ABORT,err)
+ If(ABORT) Then
+ call G_add_path(here,err)
+ RETURN
+ EndIf
+ ENDIF
+*
+ call NO_nulls(c_Ntuple_file) !replace null characters with blanks
+*
+*-if name blank, just forget it
+ IF(c_Ntuple_file.EQ.' ') RETURN !do nothing
+ c_Ntuple_ID= default_c_Ntuple_ID
+ c_Ntuple_name= default_name
+ IF(c_Ntuple_title.EQ.' ') THEN
+ msg= name//' '//c_Ntuple_file
+ call only_one_blank(msg)
+ c_Ntuple_title= msg
+ ENDIF
+
+ file= c_Ntuple_file
+ call g_sub_run_number(file,gen_run_number)
+
+
+* * only needed if using more than one file
+ if (c_Ntuple_max_segmentevents .gt. 0) then
+ c_Ntuple_filesegments = 1
+
+ ifile = char(ichar('0')+c_Ntuple_filesegments)
+
+ fn_len = g_important_length(file)
+ ilo=index(file,'.hbook')
+ if ((ilo.le.1).or.(ilo.gt.fn_len-5)) then
+ ilo=index(file,'.rzdat')
+ endif
+
+ if ((ilo.gt.1).and.(ilo.lt.fn_len)) then
+ file = file(1:ilo-1) // '.' // ifile // file(ilo:fn_len)
+ else
+ ABORT = .true.
+ RETURN
+ endif
+ write(*,*) ' Using segmented COIN rzdat files first filename: ',file
+ else
+ write(*,*) ' Not using segmented COIN rzdat files.'
+ endif
+*
+**********begin insert description of contents of COIN tuple ******
+ m= 0
+ m=m+1
+ c_Ntuple_tag(m)= 'cointime' ! Corrected Coincidence Time
+ m= m+1
+ c_Ntuple_tag(m)= 'bpmxmean' ! Mean Beam X Position
+ m= m+1
+ c_Ntuple_tag(m)= 'bpmymean' ! Mean Beam Y Position
+ m= m+1
+ c_Ntuple_tag(m)= 'bpmx' ! Beam X Position
+ m= m+1
+ c_Ntuple_tag(m)= 'bpmy' ! Beam Y Position
+ m= m+1
+ c_Ntuple_tag(m)= 'frx' ! Fast Raster X
+ m= m+1
+ c_Ntuple_tag(m)= 'fry' ! Fast Raster Y
+ m= m+1
+ c_Ntuple_tag(m)= 'gbeam_x' ! Fast Raster X
+ m= m+1
+ c_Ntuple_tag(m)= 'gbeam_y' ! Fast Raster Y
+ m= m+1
+ c_Ntuple_tag(m)= 'hsxfp' ! HMS Focal Plane
+ m= m+1
+ c_Ntuple_tag(m)= 'hsyfp' !
+ m= m+1
+ c_Ntuple_tag(m)= 'hsxpfp' !
+ m= m+1
+ c_Ntuple_tag(m)= 'hsypfp' !
+ m= m+1
+ c_Ntuple_tag(m)= 'ssxfp' ! SOS Focal Plane
+ m= m+1
+ c_Ntuple_tag(m)= 'ssyfp' !
+ m= m+1
+ c_Ntuple_tag(m)= 'ssxpfp' !
+ m= m+1
+ c_Ntuple_tag(m)= 'ssypfp' !
+ m= m+1
+ c_Ntuple_tag(m)= 'hsytar' ! HMS Target
+ m= m+1
+ c_Ntuple_tag(m)= 'hsxptar' !
+ m= m+1
+ c_Ntuple_tag(m)= 'hsyptar' !
+ m= m+1
+ c_Ntuple_tag(m)= 'hsdelta' !
+ m= m+1
+ c_Ntuple_tag(m)= 'ssytar' ! SOS Target
+ m= m+1
+ c_Ntuple_tag(m)= 'ssxptar' !
+ m= m+1
+ c_Ntuple_tag(m)= 'ssyptar' !
+ m= m+1
+ c_Ntuple_tag(m)= 'ssdelta' !
+ m= m+1
+ c_Ntuple_tag(m)= 'hcer_npe' ! HMS Particle Id.
+ m= m+1
+ c_Ntuple_tag(m)= 'hsshsum' !
+ m= m+1
+ c_Ntuple_tag(m)= 'hsshtrk' !
+ m= m+1
+ c_Ntuple_tag(m)= 'hsprtrk' !
+ m= m+1
+ c_Ntuple_tag(m)= 'hsbeta_notrk' !
+ m= m+1
+ c_Ntuple_tag(m)= 'hsbeta' !
+ m= m+1
+ c_Ntuple_tag(m)= 'hsdedx1' !
+ m= m+1
+ c_Ntuple_tag(m)= 'scer_npe' ! SOS Particle Id.
+ m= m+1
+c c_Ntuple_tag(m)= 'saer_npe' !
+c m= m+1
+ c_Ntuple_tag(m)= 'ssshsum' !
+ m= m+1
+ c_Ntuple_tag(m)= 'ssshtrk' !
+ m= m+1
+ c_Ntuple_tag(m)= 'ssprtrk' !
+ m= m+1
+ c_Ntuple_tag(m)= 'ssbeta_notrk' !
+ m= m+1
+ c_Ntuple_tag(m)= 'ssbeta' !
+ m= m+1
+ c_Ntuple_tag(m)= 'ssdedx1' !
+ m= m+1
+ c_Ntuple_tag(m)= 'charge' ! Charge of last Scaler Event
+ m=m+1
+ c_Ntuple_tag(m)= 'eventID' ! CODA event ID#
+ m=m+1
+ c_Ntuple_tag(m)= 'Em'
+ m=m+1
+ c_Ntuple_tag(m)= 'missmass'
+ m=m+1
+ c_Ntuple_tag(m)= 'Pm'
+ m=m+1
+ c_Ntuple_tag(m)= 'PmPar'
+ m=m+1
+ c_Ntuple_tag(m)= 'PmPer'
+ m=m+1
+ c_Ntuple_tag(m)= 'PmOop'
+ m=m+1
+ c_Ntuple_tag(m)= 'th_pq'
+ m=m+1
+ c_ntuple_tag(m)= 'phi_pq'
+
+* m=m+1
+* c_Ntuple_tag(m)= 'HmsCorsi'
+* m=m+1
+* c_Ntuple_tag(m)= 'SosCorsi'
+ c_Ntuple_size= m
+***********end insert description of contents of COIN tuple********
+*
+* Open ntuple
+
+ call c_Ntuple_open(file,ABORT,err)
+
+ IF(ABORT) THEN
+ err= ':unable to create Coin Ntuple'
+ call G_add_path(here,err)
+ ELSE
+ pat= ':created Coin Ntuple'
+ call G_add_path(here,pat)
+ call G_log_message('INFO: '//pat)
+ ENDIF
+*
+ RETURN
+ END
diff --git a/ENGINE/c_ntuple_keep.f b/ENGINE/c_ntuple_keep.f
new file mode 100644
index 0000000..e174db9
--- /dev/null
+++ b/ENGINE/c_ntuple_keep.f
@@ -0,0 +1,209 @@
+ subroutine c_Ntuple_keep(ABORT,err)
+*----------------------------------------------------------------------
+*
+* Purpose : Add entry to the COIN Ntuple
+*
+* Output: ABORT - success or failure
+* : err - reason for failure, if any
+*
+* Created: 11-Apr-1994 K.B.Beard, Hampton U.
+* $Log: c_ntuple_keep.f,v $
+* Revision 1.10 2004/02/17 17:26:34 jones
+* Changes to enable possiblity of segmenting rzdat files
+*
+* Revision 1.9 1999/02/23 16:41:08 csa
+* Variable changes
+*
+* Revision 1.8 1996/09/04 15:30:17 saw
+* (JRA) Modify ntuple contents
+*
+* Revision 1.7 1996/04/29 18:44:04 saw
+* (JRA) Add aerogel photon count
+*
+* Revision 1.6 1996/01/22 15:06:41 saw
+* (JRA) Change ntuple contents
+*
+* Revision 1.5 1996/01/16 21:01:33 cdaq
+* (JRA) Add HSDELTA and SSDELTA
+*
+* Revision 1.4 1995/09/01 15:45:21 cdaq
+* (JRA) Add spectrometer kinematic vars to ntuple
+*
+* Revision 1.3 1995/05/22 20:50:43 cdaq
+* (SAW) Split gen_data_data_structures into gen, hms, sos, and coin parts"
+*
+* Revision 1.2 1994/06/17 02:41:25 cdaq
+* (KBB) Upgrade
+*
+* Revision 1.1 1994/04/12 16:12:33 cdaq
+* Initial revision
+*
+*
+*----------------------------------------------------------------------
+ implicit none
+ save
+*
+ character*13 here
+ parameter (here='c_Ntuple_keep')
+*
+ logical ABORT
+ character*(*) err
+*
+ INCLUDE 'c_ntuple.cmn'
+ INCLUDE 'gen_data_structures.cmn'
+ INCLUDE 'gen_run_info.cmn'
+ INCLUDE 'coin_data_structures.cmn'
+ INCLUDE 'hms_data_structures.cmn'
+ INCLUDE 'hms_physics_sing.cmn'
+ INCLUDE 'sos_data_structures.cmn'
+ INCLUDE 'hms_scin_parms.cmn'
+ INCLUDE 'sos_scin_parms.cmn'
+ INCLUDE 'sos_track_histid.cmn'
+ INCLUDE 'sos_aero_parms.cmn'
+ INCLUDE 's_ntuple.cmn'
+ INCLUDE 'sos_tracking.cmn'
+ INCLUDE 'gen_event_info.cmn'
+ INCLUDE 'gen_scalers.cmn'
+ INCLUDE 'hms_calorimeter.cmn'
+ INCLUDE 'sos_calorimeter.cmn'
+ INCLUDE 'hms_scin_tof.cmn'
+ INCLUDE 'sos_scin_tof.cmn'
+*
+ logical HEXIST !CERNLIB function
+*
+ integer m
+*
+*--------------------------------------------------------
+ err= ' '
+ ABORT = .FALSE.
+*
+ IF(.NOT.c_Ntuple_exists) RETURN !nothing to do
+c
+ if (c_Ntuple_max_segmentevents .gt. 0) then
+ if (c_Ntuple_segmentevents .gt. c_Ntuple_max_segmentevents) then
+ call c_ntuple_change(ABORT,err)
+ c_Ntuple_segmentevents = 0
+ else
+ c_Ntuple_segmentevents = c_Ntuple_segmentevents +1
+ endif
+ endif
+*
+**********begin insert description of contents of COIN tuple ******
+
+ m= 0
+ m= m+1
+ c_Ntuple_contents(m)= ccointime_hms ! Corrected Coincidence time
+ m= m+1
+ c_Ntuple_contents(m)= gbpm_beam_x ! Mean Beam X Position
+ m= m+1
+ c_Ntuple_contents(m)= gbpm_beam_y ! Mean Beam Y Position
+ m= m+1
+ c_Ntuple_contents(m)= gbpm_x(2) ! Beam X Position bei BPM 2 (gut=1.8)
+ m= m+1
+ c_Ntuple_contents(m)= gbpm_y(2) ! Beam Y Position bei BPM 2 (gut=0.0)
+ m= m+1
+ c_Ntuple_contents(m)= gfrx_raw_adc ! Fast Raster X
+ m= m+1
+ c_Ntuple_contents(m)= gfry_raw_adc ! Fast Raster Y
+ m= m+1
+ c_Ntuple_contents(m)= gbeam_x ! Berechnete StrahlpositionX
+ m= m+1
+ c_Ntuple_contents(m)= gbeam_y ! Berechnete StrahlpositionY
+ m= m+1
+ c_Ntuple_contents(m)= HSX_FP ! HMS Focal Plane
+ m= m+1
+ c_Ntuple_contents(m)= HSY_FP !
+ m= m+1
+ c_Ntuple_contents(m)= HSXP_FP !
+ m= m+1
+ c_Ntuple_contents(m)= HSYP_FP !
+ m= m+1
+ c_Ntuple_contents(m)= SSX_FP ! SOS Focal Plane
+ m= m+1
+ c_Ntuple_contents(m)= SSY_FP !
+ m= m+1
+ c_Ntuple_contents(m)= SSXP_FP !
+ m= m+1
+ c_Ntuple_contents(m)= SSYP_FP !
+ m= m+1
+ c_Ntuple_contents(m)= HSY_TAR ! HMS Target
+ m= m+1
+ c_Ntuple_contents(m)= HSXP_TAR !
+ m= m+1
+ c_Ntuple_contents(m)= HSYP_TAR !
+ m= m+1
+ c_Ntuple_contents(m)= HSDELTA !
+ m= m+1
+ c_Ntuple_contents(m)= SSY_TAR ! SOS Target
+ m= m+1
+ c_Ntuple_contents(m)= SSXP_TAR !
+ m= m+1
+ c_Ntuple_contents(m)= SSYP_TAR !
+ m= m+1
+ c_Ntuple_contents(m)= SSDELTA !
+ m= m+1
+ c_Ntuple_contents(m)= HCER_NPE_SUM ! HMS Particle Id.
+ m= m+1
+ c_Ntuple_contents(m)= HSSHSUM !
+ m= m+1
+ c_Ntuple_contents(m)= HSSHTRK !
+ m= m+1
+ c_Ntuple_contents(m)= HSPRTRK !
+ m= m+1
+ c_Ntuple_contents(m)= HBETA_NOTRK !
+ m= m+1
+ c_Ntuple_contents(m)= HSBETA !
+ m= m+1
+ c_Ntuple_contents(m)= HSDEDX(1) !
+ m= m+1
+ c_Ntuple_contents(m)= SCER_NPE_SUM ! SOS Particle Id.
+ m= m+1
+ c_Ntuple_contents(m)= SSSHSUM !
+ m= m+1
+ c_Ntuple_contents(m)= SSSHTRK !
+ m= m+1
+ c_Ntuple_contents(m)= SSPRTRK !
+ m= m+1
+ c_Ntuple_contents(m)= SBETA_NOTRK !
+ m= m+1
+ c_Ntuple_contents(m)= SSBETA !
+ m= m+1
+ c_Ntuple_contents(m)= SSDEDX(1) !
+ m= m+1
+ c_Ntuple_contents(m)= gbcm1_charge ! Charge of last scaler event
+ m= m+1
+ c_Ntuple_contents(m)= FLOAT(gen_event_ID_number)
+ m= m+1
+ c_Ntuple_contents(m)= cmissing_e ! missing energy
+ m= m+1
+ c_Ntuple_contents(m)= cmissing_mass ! missing mass
+ m= m+1
+ c_Ntuple_contents(m)= cmissing_mom ! Missing Momentum
+ m= m+1
+ c_Ntuple_contents(m)= cmissing_mom_par ! pm parallel to q
+ m= m+1
+ c_Ntuple_contents(m)= cmissing_mom_perp ! pm perp tp q
+ m= m+1
+ c_Ntuple_contents(m)= cmissing_mom_oop ! pm out of plane
+ m= m+1
+ c_Ntuple_contents(m)= cthetapq
+ m= m+1
+ c_Ntuple_contents(m)= cphipq
+
+* m= m+1
+* c_Ntuple_contents(m)= P_HMS_CORR ! Corrected hms singles
+* m= m+1
+* c_Ntuple_contents(m)= P_SOS_CORR ! Corrected sos singles
+***********end insert description of contents of COIN tuple********
+*
+ ABORT= .NOT.HEXIST(c_Ntuple_ID)
+ IF(ABORT) THEN
+ call G_build_note(':Ntuple ID#$ does not exist',
+ & '$',c_Ntuple_ID,' ',0.,' ',err)
+ call G_add_path(here,err)
+ ELSE
+ call HFN(c_Ntuple_ID,c_Ntuple_contents)
+ ENDIF
+*
+ RETURN
+ END
diff --git a/ENGINE/c_ntuple_open.f b/ENGINE/c_ntuple_open.f
new file mode 100644
index 0000000..d3a8177
--- /dev/null
+++ b/ENGINE/c_ntuple_open.f
@@ -0,0 +1,115 @@
+ subroutine c_Ntuple_open(file,ABORT,err)
+*----------------------------------------------------------------------
+*
+* Opens an HMS Ntuple file
+*
+* Purpose : Books an HMS Ntuple
+*
+* Output: ABORT - success or failure
+* : err - reason for failure, if any
+*
+*----------------------------------------------------------------------
+
+ implicit none
+ save
+
+ character*13 here
+ parameter (here='c_Ntuple_open')
+
+ logical ABORT
+ character*(*) err
+
+ INCLUDE 'c_ntuple.cmn'
+
+ integer default_bank,default_recL
+ parameter (default_bank= 8000) !4 bytes/word
+ parameter (default_recL= 1024) !record length
+ character*80 title,file
+ character*80 directory,name
+ character*1000 pat,msg
+ integer status,size,io,id,bank,recL,iv(10),m
+ real rv(10)
+
+ logical HEXIST !CERNLIB function
+
+*--------------------------------------------------------
+
+ err= ' '
+ ABORT = .FALSE.
+ IF(c_Ntuple_exists) THEN
+ call c_Ntuple_shutdown(ABORT,err)
+ If(ABORT) Then
+ call G_add_path(here,err)
+ RETURN
+ EndIf
+ ENDIF
+
+*- get any free IO channel
+
+ call g_IO_control(io,'ANY',ABORT,err)
+ c_Ntuple_exists= .NOT.ABORT
+ IF(ABORT) THEN
+ call G_add_path(here,err)
+ RETURN
+ ENDIF
+ c_Ntuple_IOchannel= io
+
+ id= c_Ntuple_ID
+ name= c_Ntuple_name
+ title= c_Ntuple_title
+ ABORT= HEXIST(id)
+ IF(ABORT) THEN
+ call g_IO_control(c_Ntuple_IOchannel,'FREE',ABORT,err)
+ call G_build_note(':HBOOK id#$ already in use',
+ & '$',id,' ',rv,' ',err)
+ call G_add_path(here,err)
+ RETURN
+ ENDIF
+
+ CALL HCDIR(directory,'R') !CERNLIB read current directory
+
+*-open New *.rzdat file-
+ recL= default_recL
+ call HROPEN(io,name,file,'N',recL,status) !CERNLIB
+
+ ABORT= status.NE.0
+ IF(ABORT) THEN
+ call g_IO_control(c_Ntuple_IOchannel,'FREE',ABORT,err)
+ iv(1)= status
+ iv(2)= io
+ pat= ':HROPEN error#$ opening IO#$ "'//file//'"'
+ call G_build_note(pat,'$',iv,' ',rv,' ',err)
+ call G_add_path(here,err)
+ RETURN
+ ENDIF
+
+ size= c_Ntuple_size
+ bank= default_bank
+ title= c_Ntuple_title
+ call HBOOKN(id,title,size,name,bank,c_Ntuple_tag) !create Ntuple
+
+ call HCDIR(c_Ntuple_directory,'R') !record Ntuple directory
+
+ CALL HCDIR(directory,' ') !reset CERNLIB directory
+
+ c_Ntuple_exists= HEXIST(c_Ntuple_ID)
+ ABORT= .NOT.c_Ntuple_exists
+
+ iv(1)= id
+ iv(2)= io
+ pat= 'Ntuple id#$ [' // c_Ntuple_directory // '/]' //
+ & name // ' IO#$ "' // file // '"'
+ call G_build_note(pat,'$',iv,' ',rv,' ',msg)
+ call sub_string(msg,' /]','/]')
+
+ IF(ABORT) THEN
+ err= ':unable to create '//msg
+ call G_add_path(here,err)
+ ELSE
+ pat= ':created '//msg
+ call G_add_path(here,pat)
+ call G_log_message('INFO: '//pat)
+ ENDIF
+
+ RETURN
+ END
diff --git a/ENGINE/c_ntuple_register.f b/ENGINE/c_ntuple_register.f
new file mode 100644
index 0000000..9f45bf5
--- /dev/null
+++ b/ENGINE/c_ntuple_register.f
@@ -0,0 +1,47 @@
+ subroutine c_Ntuple_register(ABORT,err)
+*----------------------------------------------------------------------
+*
+* CTP variable registration routine for the COIN Ntuples
+*
+* Purpose : Register output filename for COIN Ntuple; temporary
+* implementation to be superceeded by CTP Ntuples
+*
+* Output: ABORT - success or failure
+* : err - reason for failure, if any
+*
+* Created: 8-Apr-1994 K.B.Beard, HU: added Ntuples
+* $Log: c_ntuple_register.f,v $
+* Revision 1.2 1994/06/17 02:47:58 cdaq
+* (KBB) Upgrade
+*
+* Revision 1.1 1994/04/12 16:12:59 cdaq
+* Initial revision
+*
+*
+*----------------------------------------------------------------------
+ implicit none
+ save
+*
+ character*17 here
+ parameter (here='c_Ntuple_register')
+*
+ logical ABORT
+ character*(*) err
+*
+ INCLUDE 'c_ntuple.cmn'
+ INCLUDE 'gen_routines.dec'
+*
+ integer ierr
+*--------------------------------------------------------
+ err= ' '
+ ABORT = .FALSE.
+*
+ call G_reg_C('COIN_Ntuple',c_Ntuple_file,ABORT,err)
+*
+ IF(ABORT) THEN
+ call G_prepend(':unable to register-',err)
+ call G_add_path(here,err)
+ ENDIF
+*
+ return
+ end
diff --git a/ENGINE/c_ntuple_shutdown.f b/ENGINE/c_ntuple_shutdown.f
new file mode 100644
index 0000000..27767bf
--- /dev/null
+++ b/ENGINE/c_ntuple_shutdown.f
@@ -0,0 +1,75 @@
+ subroutine c_Ntuple_shutdown(ABORT,err)
+*----------------------------------------------------------------------
+*
+* Final shutdown of the COIN Ntuple
+*
+* Purpose : Flushes and closes the COIN Ntuple
+*
+* Output: ABORT - success or failure
+* : err - reason for failure, if any
+*
+* Created: 8-Apr-1994 K.B.Beard, HU: added Ntuples
+* $Log: c_ntuple_shutdown.f,v $
+* Revision 1.5 2004/02/17 17:26:34 jones
+* Changes to enable possiblity of segmenting rzdat files
+*
+* Revision 1.4 1998/12/01 15:33:33 saw
+* (SAW) Clean out archaic g_build_note stuff
+*
+* Revision 1.3 1994/06/29 03:24:56 cdaq
+* (KBB) Remove HDELET call
+*
+* Revision 1.2 1994/06/17 03:00:30 cdaq
+* (KBB) Upgrade
+*
+* Revision 1.1 1994/04/12 16:14:33 cdaq
+* Initial revision
+*
+*
+*----------------------------------------------------------------------
+ implicit none
+ save
+*
+ character*17 here
+ parameter (here='c_Ntuple_shutdown')
+*
+ logical ABORT
+ character*(*) err
+*
+ INCLUDE 'c_ntuple.cmn'
+ INCLUDE 'gen_routines.dec'
+*
+ logical FAIL
+ character*80 why,directory,name
+ character*1000 msg
+ integer io,id,cycle,m
+*
+*
+*--------------------------------------------------------
+ err= ' '
+ ABORT = .FALSE.
+*
+
+ IF(.NOT.c_Ntuple_exists) RETURN !nothing to do
+c
+
+ call c_ntuple_close(ABORT,err)
+
+*
+ IF(c_Ntuple_exists) then
+ ABORT = .true.
+ endif
+ c_Ntuple_ID= 0
+ c_Ntuple_name= ' '
+ c_Ntuple_file= ' '
+ c_Ntuple_title= ' '
+ c_Ntuple_size= 0
+ do m=1,CMAX_Ntuple_size
+ c_Ntuple_tag(m)= ' '
+ c_Ntuple_contents(m)= 0.
+ enddo
+*
+ IF(ABORT) call G_add_path(here,err)
+*
+ RETURN
+ END
diff --git a/ENGINE/c_physics.f b/ENGINE/c_physics.f
new file mode 100644
index 0000000..c176fd7
--- /dev/null
+++ b/ENGINE/c_physics.f
@@ -0,0 +1,145 @@
+ SUBROUTINE C_PHYSICS(ABORT,err)
+*--------------------------------------------------------
+*-
+*- Purpose and Methods : Compute coincident quantities
+*-
+*- Output: ABORT - success or failure
+*- : err - reason for failure, if any
+*-
+* $Log: c_physics.f,v $
+* Revision 1.10 2003/12/19 19:21:04 jones
+* Use ssinplane and hsinplane in calculating cqx,cqz and cmissing_momx,cmissing_momz
+*
+* Revision 1.9 2003/11/28 15:49:41 jones
+* Go back to adding h_oopcentral_offset and s_oopcentral_offset to hsxp_tar and
+* ssxp_tar since this in no longer done in h_physics.f and s_physics.f (MKJ)
+*
+* Revision 1.8 2003/09/05 21:54:44 jones
+* Remove phi_offset addition to xptar. It is done in h_physics.f and s_physics.f (mkj)
+*
+* Revision 1.7 1996/09/04 15:31:12 saw
+* (JRA) Add phi_offset to calculation of q 3 vector
+*
+* Revision 1.6 1996/04/29 19:13:00 saw
+* (JRA) Corrections
+*
+* Revision 1.5 1996/01/22 15:08:02 saw
+* (JRA) Adjust variable names. Get particle properties from lookup
+* tables
+*
+* Revision 1.4 1996/01/16 21:06:55 cdaq
+* (RE?) Change some definitions
+*
+* Revision 1.3 1995/05/22 20:50:44 cdaq
+* (SAW) Split gen_data_data_structures into gen, hms, sos, and coin parts"
+*
+* Revision 1.2 1995/05/13 02:44:07 cdaq
+* (SAW) Remove some debugging
+*
+* Revision 1.1 1995/05/11 15:17:36 cdaq
+* Initial revision
+*
+*--------------------------------------------------------
+ IMPLICIT NONE
+ SAVE
+*
+ character*9 here
+ parameter (here= 'C_PHYSICS')
+*
+ logical ABORT
+ character*(*) err
+*
+ include 'gen_data_structures.cmn'
+ include 'hms_data_structures.cmn'
+ include 'sos_data_structures.cmn'
+ include 'coin_data_structures.cmn'
+ include 'gen_constants.par'
+ include 'hms_scin_tof.cmn'
+ include 'sos_scin_tof.cmn'
+ include 'hms_physics_sing.cmn'
+ include 'sos_physics_sing.cmn'
+ include 'hms_scin_parms.cmn'
+ include 'sos_scin_parms.cmn'
+*
+* local variables
+*
+ real*4 cqx,cqy,cqz,cqabs
+ real*4 ekinrec,m_rec
+ real*4 tar_amin1
+ real*4 offset_ctime
+
+ ABORT = .FALSE.
+ err = ' '
+
+ if(HSNUM_FPTRACK.le.0.or.SSNUM_FPTRACK.le.0) then
+ return
+ endif
+
+* Need to select which arm is the hadron
+ tar_amin1= gtarg_a(gtarg_num)-1.0
+ m_rec = tar_amin1*m_amu
+ if(hpartmass .lt. 2*mass_electron) then ! Less than 1 MeV, HMS is elec
+ cqx = -hsp*cos(hsxp_tar+h_oopcentral_offset)*sin(hsinplane)
+ cqy = -hsp*sin(hsxp_tar+h_oopcentral_offset)
+ cqz = gpbeam - hsp*cos(hsxp_tar+h_oopcentral_offset)*cos(hsinplane)
+ cqabs= sqrt(cqx**2+cqy**2+cqz**2)
+ cmissing_momx = cqx + ssp*cos(ssxp_tar+s_oopcentral_offset)*sin(ssinplane)
+ cmissing_momy = cqy - ssp*sin(ssxp_tar+s_oopcentral_offset)
+ cmissing_momz = cqz - ssp*cos(ssxp_tar+s_oopcentral_offset)*cos(ssinplane)
+ cmissing_mom = sqrt(cmissing_momx**2 + cmissing_momy**2
+ > + cmissing_momz**2)
+ cmissing_mom_par = (cmissing_momx*cqx+cmissing_momz*cqz)/cqabs
+ cmissing_mom_perp = (-cmissing_momz*cqx+cmissing_momx*cqz)/cqabs
+ cmissing_mom_oop = cmissing_momy
+ if(cmissing_mom_perp.lt.0)then
+ cmissing_mom = -cmissing_mom
+ endif
+ omega = gebeam-hsenergy
+ if(tar_amin1.ge.999. .or.tar_amin1.lt.0.001)then
+ ekinrec = 0
+ else
+ ekinrec = sqrt(cmissing_mom**2 + m_rec**2)-m_rec
+ endif
+ cmissing_e= omega -(ssenergy - mass_nucleon) - ekinrec
+ p_hms_corr = hsenergy - gebeam/(1+gebeam/0.938272*(1-cos(hstheta)))
+ p_sos_corr = ssp -2.*mass_nucleon*gebeam*cos(sstheta)/
+ > (gebeam+mass_nucleon)/(1-(gebeam*cos(sstheta)/
+ > (gebeam+mass_nucleon))**2)
+ else ! SOS is the electron
+ cqx = -ssp*cos(ssxp_tar+s_oopcentral_offset)*sin(ssinplane)
+ cqy = -ssp*sin(ssxp_tar+s_oopcentral_offset)
+ cqz = gpbeam - ssp*cos(ssxp_tar+s_oopcentral_offset)*cos(ssinplane)
+ cqabs= sqrt(cqx**2+cqy**2+cqz**2)
+ cmissing_momx = cqx + hsp*cos(hsxp_tar+h_oopcentral_offset)*sin(hsinplane)
+ cmissing_momy = cqy - hsp*sin(hsxp_tar+h_oopcentral_offset)
+ cmissing_momz = cqz - hsp*cos(hsxp_tar+h_oopcentral_offset)*cos(hsinplane)
+ cmissing_mom = sqrt(cmissing_momx**2 + cmissing_momy**2
+ > + cmissing_momz**2)
+ cmissing_mom_par = (cmissing_momx*cqx+cmissing_momz*cqz)/cqabs
+ cmissing_mom_perp = (-cmissing_momz*cqx+cmissing_momx*cqz)/cqabs
+ cmissing_mom_oop = cmissing_momy
+ if(cmissing_mom_perp.lt.0)then
+ cmissing_mom = -cmissing_mom
+ endif
+ omega = gebeam-ssenergy
+ if(tar_amin1.ge.999. .or.tar_amin1.lt.0.001)then
+ ekinrec = 0
+ else
+ ekinrec = sqrt(cmissing_mom**2 + m_rec**2)-m_rec
+ endif
+ cmissing_e= omega -(hsenergy - mass_nucleon) - ekinrec
+ p_sos_corr = ssenergy - gebeam/(1+gebeam/0.938272*(1-cos(sstheta)))
+ p_hms_corr = hsp -2.*mass_nucleon*gebeam*cos(hstheta)/
+ > (gebeam+mass_nucleon)/(1-(gebeam*cos(hstheta)/
+ > (gebeam+mass_nucleon))**2)
+ endif
+
+* Coincidence timing.
+ offset_ctime = - (hstime_at_fp-hstart_time_center)
+ & + (sstime_at_fp-sstart_time_center)
+ & - hspath_cor + sspath_cor + 10
+ ccointime_hms = (hmisc_dec_data(10,1)-2450)/9.46 + offset_ctime
+ ccointime_sos = (smisc_dec_data(9,1)-1570)/9.68 - offset_ctime
+*
+ return
+ end
diff --git a/ENGINE/c_proper_shutdown.f b/ENGINE/c_proper_shutdown.f
new file mode 100644
index 0000000..f0ed6d5
--- /dev/null
+++ b/ENGINE/c_proper_shutdown.f
@@ -0,0 +1,88 @@
+ SUBROUTINE C_proper_shutdown(lunout,ABORT,err)
+*--------------------------------------------------------
+*- Prototype C analysis routine
+*-
+*-
+*- Purpose and Methods : Closes files properly, flushes, etc.
+*-
+*- Output: ABORT - success or failure
+*- : err - reason for failure, if any
+*-
+*- Created 20-Nov-1993 Kevin B. Beard for new error standards
+* $Log: c_proper_shutdown.f,v $
+* Revision 1.8 1996/01/16 21:07:45 cdaq
+* no change
+*
+* Revision 1.7 1995/07/27 19:02:19 cdaq
+* (SAW) Move ntuple shutdown to g_ntuple_shutdown
+*
+* Revision 1.6 1995/05/22 13:30:11 cdaq
+* (JRA) Make a listing of potential detector problems
+*
+* Revision 1.5 1995/04/01 19:43:57 cdaq
+* (SAW) One report file for each of g, h, s, c instead of a single report file
+* Allow %d for run number in filenames
+*
+* Revision 1.4 1994/10/11 18:39:02 cdaq
+* (SAW) Protect agains blank blocknames
+*
+* Revision 1.3 1994/08/30 14:45:44 cdaq
+* (SAW) Add call to report generator
+*
+* Revision 1.2 1994/04/12 17:12:20 cdaq
+* (KBB) Add ntuple call
+*
+* Revision 1.1 1994/02/04 21:07:58 cdaq
+* Initial revision
+*
+*- All standards are from "Proposal for Hall C Analysis Software
+*- Vade Mecum, Draft 1.0" by D.F.Geesamn and S.Wood, 7 May 1993
+*-
+*--------------------------------------------------------
+ IMPLICIT NONE
+ SAVE
+*
+ include 'gen_routines.dec'
+ include 'gen_filenames.cmn'
+ include 'gen_run_info.cmn'
+ include 'coin_filenames.cmn'
+*
+ character*17 here
+ parameter (here= 'C_proper_shutdown')
+*
+ logical ABORT, report_abort
+ character*(*) err
+*
+ integer ierr
+ character*132 file
+ integer lunout
+*--------------------------------------------------------
+*-chance to flush any statistics, etc.
+*
+*
+ ABORT= .FALSE.
+ err = ' '
+*
+* call c_ntuple_shutdown(ABORT,err)
+*
+ if(c_report_blockname.ne.' '.and.
+ $ c_report_output_filename.ne.' ') then
+
+ file = c_report_output_filename
+ call g_sub_run_number(file, gen_run_number)
+
+ ierr = threp(c_report_blockname, file)
+ if(ierr.ne.0) then
+ call g_append(err,'& threp failed to create report in file'//file)
+ report_abort = .true.
+ endif
+ endif
+*
+ IF(ABORT.or.report_abort) THEN
+ call G_add_path(here,err)
+ ELSE
+ err= ' '
+ ENDIF
+*
+ RETURN
+ END
diff --git a/ENGINE/c_reconstruction.f b/ENGINE/c_reconstruction.f
new file mode 100644
index 0000000..85ec2ef
--- /dev/null
+++ b/ENGINE/c_reconstruction.f
@@ -0,0 +1,68 @@
+ SUBROUTINE C_reconstruction(ABORT,err)
+*--------------------------------------------------------
+*- Prototype C analysis routine
+*-
+*-
+*- Purpose and Methods : reconstruction of HMS quantities
+*-
+*- Output: ABORT - success or failure
+*- : err - reason for failure, if any
+*-
+*- Created 8-Nov-1993 Kevin B. Beard, HU
+*- Modified 20-Nov-1993 KBB for new errors
+* $Log: c_reconstruction.f,v $
+* Revision 1.6 1996/01/16 21:08:42 cdaq
+* no change
+*
+* Revision 1.5 1995/05/22 20:50:44 cdaq
+* (SAW) Split gen_data_data_structures into gen, hms, sos, and coin parts"
+*
+* Revision 1.4 1995/05/11 15:48:15 cdaq
+* (SAW) Add call to c_physics for coincidence variables
+*
+* Revision 1.3 1994/06/17 03:16:29 cdaq
+* (KBB) Remove not yet written warning
+*
+* Revision 1.2 1994/02/04 21:09:43 cdaq
+* Fix indentation
+*
+* Revision 1.1 1994/02/04 21:08:21 cdaq
+* Initial revision
+*
+*-
+*- All standards are from "Proposal for Hall C Analysis Software
+*- Vade Mecum, Draft 1.0" by D.F.Geesamn and S.Wood, 7 May 1993
+*-
+*--------------------------------------------------------
+ IMPLICIT NONE
+ SAVE
+*
+ character*16 here
+ parameter (here= 'C_reconstruction')
+*
+ logical ABORT
+ character*(*) err
+*
+ INCLUDE 'coin_data_structures.cmn'
+ INCLUDE 'gen_constants.par'
+ INCLUDE 'gen_units.par'
+ INCLUDE 'coin_bypass_switches.cmn'
+*
+*--------------------------------------------------------
+*
+ ABORT= .FALSE.
+ err = ' '
+*
+ if(cbypass_physics.eq.0) then
+ call c_physics(abort,err)
+ IF(ABORT) call G_add_path(here,err)
+ return
+ endif
+*
+* Successful return
+*
+ abort = .false.
+*
+ RETURN
+ END
+
diff --git a/ENGINE/c_register_variables.f b/ENGINE/c_register_variables.f
new file mode 100644
index 0000000..b79cfc7
--- /dev/null
+++ b/ENGINE/c_register_variables.f
@@ -0,0 +1,83 @@
+ subroutine c_register_variables(ABORT,err)
+*----------------------------------------------------------------------
+*
+* CTP variable registration routine for coincidences
+*
+* Purpose : Register all variables that are to be used by CTP, that are
+* connected with the coincidence calculations. This includes
+* externally configured parameters/contants, event data that can be a
+* histogram source, and possible test results and scalers.
+*
+* Output: ABORT - success or failure
+* : err - reason for failure, if any
+*
+* Created: 9-Feb-1994 Stephen A. Wood
+* $Log: c_register_variables.f,v $
+* Revision 1.9 1996/01/16 21:09:28 cdaq
+* no change
+*
+* Revision 1.8 1995/05/22 13:32:49 cdaq
+* (SAW) Add call to register coin_data_structures.cmn variables
+*
+* Revision 1.7 1995/05/11 14:50:17 cdaq
+* (SAW) Add call to register variables from c_ntuple.cmn
+*
+* Revision 1.6 1994/08/18 04:11:57 cdaq
+* (SAW) Call makereg generated routines to register variables
+*
+* Revision 1.5 1994/06/17 03:19:44 cdaq
+* (KBB) Execute all code despite registration errors
+*
+* Revision 1.4 1994/06/16 03:41:41 cdaq
+* (SAW) Register filenames for reports
+*
+* Revision 1.3 1994/06/14 03:19:03 cdaq
+* (DFG) register target and beam variables
+*
+* Revision 1.2 1994/04/12 17:13:37 cdaq
+* (KBB) Add ntuple call
+*
+* Revision 1.1 1994/02/11 18:32:18 cdaq
+* Initial revision
+*
+*----------------------------------------------------------------------
+ implicit none
+
+ save
+*
+ character*20 here
+ parameter (here='c_register_variables')
+*
+ logical ABORT
+ character*(*) err
+*
+ integer*4 ierr
+ logical FAIL
+ character*1000 why
+*..................................................................
+*
+ ABORT = .false.
+ err= ' '
+
+ call r_coin_data_structures
+
+ call r_coin_filenames
+
+ call r_c_ntuple
+
+ IF(ABORT) THEN
+ call G_prepend(':unable to register',err)
+ ENDIF
+*
+ call c_ntuple_register(FAIL,why) ! Remove this when ctp files fixed
+ IF(err.NE.' ' .and. why.NE.' ') THEN
+ call G_append(err,' & '//why)
+ ELSEIF(why.NE.' ') THEN
+ err= why
+ ENDIF
+ ABORT= ABORT .or. FAIL
+*
+ if(ABORT .or. err.NE.' ') call g_add_path(here,err)
+*
+ return
+ end
diff --git a/ENGINE/c_reset_event.f b/ENGINE/c_reset_event.f
new file mode 100644
index 0000000..3057b65
--- /dev/null
+++ b/ENGINE/c_reset_event.f
@@ -0,0 +1,49 @@
+ SUBROUTINE C_reset_event(ABORT,err)
+*--------------------------------------------------------
+*- Prototype C analysis routine
+*-
+*-
+*- Purpose and Methods : resets all COIN quantities before an event
+*- is processed.
+*-
+*-
+*- Output: ABORT - success or failure
+*- : err - reason for failure, if any
+*-
+*- Created 29-Oct-1993 Kevin B. Beard
+*- Modified 6-Dec-1993 K.B.Beard: adopt new errors
+* $Log: c_reset_event.f,v $
+* Revision 1.3 1996/01/16 21:10:22 cdaq
+* no change
+*
+* Revision 1.2 1995/05/22 20:50:44 cdaq
+* (SAW) Split gen_data_data_structures into gen, hms, sos, and coin parts"
+*
+* Revision 1.1 1994/02/04 21:18:37 cdaq
+* Initial revision
+*
+*-
+*- All standards are from "Proposal for Hall C Analysis Software
+*- Vade Mecum, Draft 1.0" by D.F.Geesamn and S.Wood, 7 May 1993
+*-
+*-
+*--------------------------------------------------------
+ IMPLICIT NONE
+ SAVE
+*
+ character*50 here
+ parameter (here= 'C_reset_event')
+*
+ logical ABORT
+ character*(*) err
+*
+ INCLUDE 'coin_data_structures.cmn'
+*--------------------------------------------------------
+*
+ ABORT= .FALSE.
+ err= ' '
+*
+ RETURN
+ END
+
+
diff --git a/ENGINE/engine.f b/ENGINE/engine.f
new file mode 100644
index 0000000..e9af403
--- /dev/null
+++ b/ENGINE/engine.f
@@ -0,0 +1,1282 @@
+* PROGRAM Engine
+*--------------------------------------------------------
+*- Prototype C analysis routine
+*-
+*- This is the analysis shell for CEBAF hall C.
+* It gets all of its instructions via the CTP package
+*- Loops through data until it encounters an error.
+*-
+*- Created 18-Nov-1993 Kevin B. Beard, Hampton Univ.
+* $Log: engine.f,v $
+* Revision 1.42.8.21.2.13 2009/09/17 20:24:14 jones
+* call sane_close_scalers()
+*
+* Revision 1.42.8.21.2.12 2009/09/16 21:47:37 jones
+* Define SANE_FIELD_ANGLE_PHI , ANE_BETA_ANGLE_PHI , SANE_HMS_ANGLE_PHI
+* Set SANE_BETA_ANGLE_THETA = bigcal_theta_deg
+* Set ANE_HMS_ANGLE_THETA = htheta_lab
+* Create new varaibles SANE_HMS_FIELD_THETA,SANE_HMS_FIELD_PHI
+* Create new variables SANE_BETA_FIELD_THETA,SANE_BETA_FIELD_PHI
+*
+* Revision 1.42.8.21.2.11 2009/09/02 13:30:57 jones
+* eliminate definition of variables that are not used
+*
+* Revision 1.42.8.21.2.10 2009/05/04 20:54:24 jones
+* Modified so that syncfilter will work
+*
+* Revision 1.42.8.21.2.9 2009/04/23 19:24:11 jones
+* For runs 72532-72583 set event type 1 equal to event type 6.
+*
+* Revision 1.42.8.21.2.8 2009/03/31 19:33:00 cdaq
+* *** empty log message ***
+*
+* Revision 1.42.8.21.2.7 2009/02/16 00:16:10 cdaq
+* *** empty log message ***
+*
+* Revision 1.42.8.21.2.6 2009/02/11 22:58:44 cdaq
+* *** empty log message ***
+*
+* Revision 1.42.8.21.2.5 2008/11/17 20:52:33 cdaq
+* Added call to h_tofcal_endrun
+*
+* Revision 1.42.8.21.2.4 2008/10/26 18:59:13 cdaq
+* fixed trginit call
+*
+* Revision 1.42.8.21.2.3 2008/10/26 18:53:06 cdaq
+* *** empty log message ***
+*
+* Revision 1.42.8.21.2.2 2008/10/26 18:49:04 cdaq
+* trginit moved
+*
+* Revision 1.42.8.21.2.1 2008/09/26 21:03:18 cdaq
+* *** empty log message ***
+*
+* Revision 1.42.8.21 2008/01/08 22:50:36 cdaq
+* *** empty log message ***
+*
+* Revision 1.42.8.20 2007/11/10 20:17:56 brash
+* Added FPP information to the gep coincidence ntuple
+*
+* Revision 1.42.8.19 2007/10/31 22:49:56 cdaq
+* added end-of-run call to b_fill_eff_hists
+*
+* Revision 1.42.8.18 2007/10/23 13:25:35 cdaq
+* commented out diagnostic message
+*
+* Revision 1.42.8.17 2007/10/22 18:38:59 cdaq
+* adjusted HMS FPP histos
+*
+* Revision 1.42.8.16 2007/10/22 14:50:37 brash
+* Fixed typo in loop surrounding gepid_gep_evtype
+*
+* Revision 1.42.8.15 2007/10/20 19:56:08 cdaq
+* Added filling of event type histogram
+*
+* Revision 1.42.8.14 2007/10/19 14:57:08 cdaq
+* *** empty log message ***
+*
+* Revision 1.42.8.13 2007/10/19 00:15:20 cdaq
+* *** empty log message ***
+*
+* Revision 1.42.8.12 2007/10/10 13:13:24 puckett
+* *** empty log message ***
+*
+* Revision 1.42.8.11 2007/09/13 04:02:17 brash
+* Implement some minor changes to fix Mac OS X runtime errors ... ejb
+*
+* Revision 1.42.8.10 2007/09/12 19:18:46 puckett
+* fixed incorrect usages of array index of gen_run_enable
+*
+* Revision 1.42.8.9 2007/09/10 20:33:37 pcarter
+* Implemented changes to allow compilation on RHEL 3,4,5 and MacOSX
+*
+* Revision 1.42.8.8 2007/09/07 16:04:35 puckett
+* updated bigcal monte carlo reconstruction to include protons.
+*
+* Revision 1.42.8.7 2007/08/27 19:01:38 puckett
+* Added call to BigCal calibration in engine.f
+*
+* Revision 1.42.8.6 2007/08/07 19:02:22 puckett
+* added run number substitution for tree filenames
+*
+* Revision 1.42.8.4 2007/06/26 16:36:45 puckett
+* latest changes for monte carlo analysis, latest fixes for cluster finding routine
+*
+* Revision 1.42.8.3 2007/06/20 18:26:32 puckett
+* Added BigCal Monte Carlo analysis capability
+*
+* Revision 1.42.8.2 2007/06/04 14:56:05 puckett
+* changed hit array structure for trigger related signals
+*
+* Revision 1.42.8.1 2007/05/15 02:55:01 jones
+* Start to Bigcal code
+*
+* Revision 1.41.6.3 2004/07/09 14:12:46 saw
+* Add function calls to fill CTP ROOT Trees
+*
+* Revision 1.41.6.2 2004/06/30 19:31:49 cdaq
+* Add call to g_examine_picture_event (DJG)
+*
+* Revision 1.41.6.1 2004/06/18 11:24:11 cdaq
+* Fixed so that runstats works under Linux
+*
+* Revision 1.41 2004/05/27 23:51:28 jones
+* Initialize EoF = .false.
+*
+* Revision 1.40 2004/05/27 22:01:55 jones
+* Comment call to g_analyze_scalers when there is an event 129
+* ( a CODA 1.4 scaler event).
+*
+* Revision 1.39 2004/05/19 21:33:52 jones
+* Initialize physics_events=0
+*
+* Revision 1.38 2004/05/11 18:29:27 jones
+* Add ability when using syncfilter to skip events if "skip_event"
+* is set to true in g_analyze_scaler_bank.f
+*
+* Revision 1.37 2003/12/19 17:45:31 jones
+* a) Fill gscaler_skipped and gscaler_saved only when using syncfilter
+* b) Fixed bug with skipping events for low beam current. Make sure it
+* only works when using syncfilter
+* c) Clean up output about syncfilter effects
+*
+* Revision 1.36 2003/12/17 15:10:56 jones
+* fix problem in sync filter part
+*
+* Revision 1.35 2003/09/05 21:49:12 jones
+* Merge in online03 changes (mkj)
+*
+* Revision 1.34 2003/04/03 00:30:28 jones
+* Add call to s_cal_calib ( V. Tadevosyan)
+*
+* Revision 1.33 2003/03/24 22:49:41 jones
+* Changes for HMS calo calibration. Include hms_calorimeter.cmn and add call
+* to h_cal_calib at end of run if hdbg_tracks_cal .lt. 0
+*
+* Revision 1.32.2.8 2003/09/04 20:30:48 jones
+* Changes for running with syncfilter (mkj)
+*
+* Revision 1.32.2.7 2003/08/14 00:42:23 cdaq
+* Modify to be able to write scaler rates for each read to a file (mkj)
+*
+* Revision 1.32.2.6 2003/06/26 12:38:11 cdaq
+* add write statement when genable_sos_satcorr .ne. 0 (mkj)
+*
+* Revision 1.32.2.5 2003/04/21 23:45:58 cdaq
+* Modified so only one message about scaler kludge is printed. (MKJ)
+*
+* Revision 1.32.2.4 2003/04/14 18:02:06 jones
+* Modified so that engine will not analyze events until after first scaler read.
+*
+* Revision 1.32.2.3 2003/04/09 02:47:00 cdaq
+* Update readout code to ignore HV and EPICS events when searching for run_info event
+*
+* Revision 1.32.2.2 2003/04/03 01:02:44 cdaq
+* match main branch apr-02-2003
+*
+* Revision 1.32.2.1 2003/03/25 03:03:40 cdaq
+* match main brach mar-24-2003
+*
+* Revision 1.32 2003/02/21 14:51:13 jones
+* Added line to call s_fieldcorr subroutine
+*
+* Revision 1.31 2003/02/15 17:11:45 jones
+* Eliminated STOP command when run info event found after starting the analyze physics events. Just wrote out comments to let the user decide what to do.
+*
+* Revision 1.30 2003/02/12 20:30:59 jones
+* Initialize variable 'problems' to false ( E. Brash)
+*
+* Revision 1.29 2002/12/20 21:55:23 jones
+* Modified by Hamlet for new HMS aerogel
+*
+* Revision 1.28 2002/09/24 20:10:34 jones
+* Added calls to subroutines h_fieldcorr.f and g_apply_offsets.f
+*
+* Revision 1.27 1999/11/04 20:35:14 saw
+* Linux/G77 compatibility fixes
+*
+* Revision 1.26 1999/06/10 14:30:35 csa
+* (JRA) Cleanup, handling of go_info event
+*
+* Revision 1.25 1999/02/23 16:47:30 csa
+* (JRA) Changes to scaler event handling and cleanup
+*
+* Revision 1.24 1998/12/01 16:01:48 saw
+* (SAW) Close preproc output file at end of run
+*
+* Revision 1.23 1996/11/08 15:40:09 saw
+* (JRA) Add analysis of epics events.
+*
+* Revision 1.22 1996/09/04 15:33:43 saw
+* (JRA) Assorted changes and diagnostics
+*
+* Revision 1.21 1996/04/29 19:19:04 saw
+* (JRA) Corrections
+*
+* Revision 1.20 1996/01/24 16:11:10 saw
+* (JRA) Change evtype to registered gen_event_type. Refresh statistics
+* file at a time interval rather than event interval
+*
+* Revision 1.19 1996/01/16 21:12:41 cdaq
+* (JRA) Add tcl run statistics display
+*
+* Revision 1.18 1995/10/09 19:59:00 cdaq
+* (JRA) Improve event counting for periodic dumping. Dump pedestal data
+* at end of run.
+*
+* Revision 1.17 1995/09/22 19:39:13 cdaq
+* (SAW) Move g_ctp_database from g_init_filenames to here. Process all
+* CTP command line vars after every ctp file read so that command line
+* overrides everything.
+*
+* Revision 1.16 1995/07/27 19:45:40 cdaq
+* (SAW) f2c compatibility changes. Only shutdown ntuples at very end.
+* ctp command line variables override at every oportunity
+*-
+* Revision 1.15 1995/05/11 19:02:23 cdaq
+* (SAW) Add ability to set CTP variables from the command line
+*
+* Revision 1.14 1995/04/01 20:12:58 cdaq
+* (SAW) Call g_proper_shutdown instead of dump_hists for periodic hist dumps
+*
+* Revision 1.13 1995/03/13 18:11:05 cdaq
+* (JRA) Write scaler report when histograms are dumped at intervals
+*
+* Revision 1.12 1995/01/31 21:12:17 cdaq
+* (SAW) Add gen_run_hist_dump_interval for in run hist dumping. Add commented
+* out code to query user for # of event and hist dump interval.
+*
+* Revision 1.11 1994/11/22 20:12:01 cdaq
+* (SAW) Change "" to " " so this would compile under ultrix.
+*
+* Revision 1.10 1994/10/19 20:40:29 cdaq
+* (SAW) Add handling of RPC requests
+*
+* Revision 1.9 1994/07/07 15:28:29 cdaq
+* (SAW) Move check for scaler event to proper place
+*
+* Revision 1.8 1994/06/26 02:07:03 cdaq
+* (KBB) Add ability to analyze selected subset of events. Add evcount stats.
+* (SAW) Add call to scaler analysis
+*
+* Revision 1.7 1994/06/17 03:35:00 cdaq
+* (KBB) Upgrade error reporting
+*
+* Revision 1.6 1994/06/15 14:27:30 cdaq
+* (SAW) Actually add call to g_examine_physics_event
+*
+* Revision 1.5 1994/06/07 18:22:58 cdaq
+* (SAW) Add calls to g_examine_physics_event and g_examine_control_event
+*
+* Revision 1.4 1994/04/15 20:31:25 cdaq
+* (SAW) Changes for ONLINE use
+*
+* Revision 1.3 1994/03/24 22:02:12 cdaq
+* Reorganize for online compatibility
+*
+* Revision 1.2 1994/02/11 18:32:06 cdaq
+* Split off CTP variables registration from initialize routines
+*
+* Revision 1.1 1994/02/04 21:04:59 cdaq
+* Initial revision
+*
+*-
+*--------------------------------------------------------
+c program engine
+c
+ IMPLICIT NONE
+ SAVE
+ external jishft, jiand, jieor
+
+ character*6 here
+ parameter (here= 'Engine')
+
+ logical ABORT,EoF
+ character*800 err,mss
+
+ include 'gen_filenames.cmn'
+ include 'gen_craw.cmn'
+ include 'gen_run_info.cmn'
+ include 'gen_event_info.cmn'
+ include 'gen_run_pref.cmn'
+ include 'gen_routines.dec'
+ include 'gen_scalers.cmn'
+ include 'gen_data_structures.cmn'
+ include 'hms_data_structures.cmn'
+ include 'sos_data_structures.cmn'
+ include 'sane_data_structures.cmn'
+ include 'bigcal_data_structures.cmn'
+ include 'bigcal_bypass_switches.cmn'
+ include 'bigcal_filenames.cmn'
+ include 'gep_hist_id.cmn'
+ include 'hms_calorimeter.cmn' !for HMS calorimeter calibration
+ include 'sos_calorimeter.cmn' !for SOS calorimeter calibration
+
+ logical problems, finished_extracting
+ integer total_event_count
+ integer physics_events
+ integer analyzed_events(0:gen_max_trigger_types)
+ integer sum_analyzed,sum_analyzed_skipped
+ integer recorded_events(0:gen_max_trigger_types)
+ integer skipped_badsync_events(0:gen_max_trigger_types)
+ integer skipped_lowbcm_events(0:gen_max_trigger_types)
+ integer sum_recorded
+ integer num_events_skipped
+ integer i,since_cnt,lastdump
+ integer mkj,ii
+ integer rpc_pend ! # Pending asynchronous RPC requests
+c
+ common /aevents/ analyzed_events
+c
+ character*80 g_config_environmental_var
+ parameter (g_config_environmental_var= 'ENGINE_CONFIG_FILE')
+
+ integer*4 jishft,jiand,jieor
+
+ integer ierr
+ integer*4 status
+ integer*4 evclose
+ character*132 file
+ character*20 groupname
+c character*132 system_string
+
+ real*4 ebeam,phms,thms,psos,tsos,ntarg
+c real*4 calangledeg,rcal,ycal
+ real*4 instrate,avrate
+
+ integer start_time,lasttime
+ integer lasttime2,tdiff,report_incr
+ integer time
+ integer*4 preprocessor_keep_event
+ external time
+c
+ integer*4 skipped_events_scal,tindex
+ real*8 delta_time
+c real*8 omega
+*
+*
+*--------------------------------------------------------
+*
+ print *
+ print *,' Hall C Proudly Presents: PHYSICS Analysis Engine'
+
+ print *
+
+c ncalls_calc_ped = 0
+
+ total_event_count= 0 ! Need to register this
+ lastdump=0
+ physics_events=0
+ skipped_events_scal = 0
+ do i=0,gen_max_trigger_types
+ analyzed_events(i)=0
+ recorded_events(i)=0
+ skipped_badsync_events(i)=0
+ skipped_lowbcm_events(i)=0
+ enddo
+ sum_analyzed=0
+ sum_analyzed_skipped=0
+ sum_recorded=0
+ num_events_skipped=0
+
+ rpc_on=0 ! RPC servicing off by default
+ rpc_control=-1 ! If RPC on, don't block by default
+
+ call g_register_variables(ABORT,err)
+ if(ABORT.or.err.ne.' ') then
+ call G_add_path(here,err)
+ call G_rep_err(ABORT,err)
+ If(ABORT) STOP
+ err= ' '
+ ENDIF
+
+ g_config_filename = ' '
+
+ call engine_command_line(.false.) ! Set CTP vars from command line
+*
+ call G_init_filenames(ABORT,err,g_config_environmental_var)
+ if(ABORT.or.err.ne.' ') then
+ call G_add_path(here,err)
+ call G_rep_err(ABORT,err)
+ If(ABORT) STOP
+ err= ' '
+ ENDIF
+
+ !write(*,*) 'after processing engine config file, gen_run_enable=',
+c $ gen_run_enable
+ !write(*,*) 'after processing engine config file, gen_bigcal_mc=',
+c $ gen_bigcal_mc
+
+ call engine_command_line(.false.) ! Set CTP vars from command line
+*
+* If there is a g_ctp_database_filename set, pass the run number
+* to it to set CTP variables
+*
+
+ !write(*,*) 'processing CTP database'
+
+ if(.not.ABORT.and.g_ctp_database_filename.ne.' ') then
+ call g_ctp_database(ABORT, err ,gen_run_number, g_ctp_database_filename)
+ IF(ABORT) THEN
+ call G_add_path(here,err)
+ endif
+ ENDIF
+
+c write(*,*) 'b_ntuple_max_segmentevents=',b_ntuple_max_segmentevents
+
+ !write(*,*) 'after processing ctp database file, gen_run_enable=',
+c $ gen_run_enable
+ !write(*,*) 'after processing ctp database file, gen_bigcal_mc=',
+c $ gen_bigcal_mc
+
+c initialize CTP ROOT trees: substitute run number into filename!!!!
+ if(.not.abort) then
+ call g_tree_init(abort,err)
+ if(abort) then
+ call g_add_path(here,err)
+ endif
+ endif
+
+ !write(*,*) 'CTP database file processed'
+
+ call engine_command_line(.false.) ! Set CTP vars from command line
+
+ call G_decode_init(ABORT,err)
+ if(ABORT.or.err.ne.' ') then
+ call G_add_path(here,err)
+ call G_rep_err(ABORT,err)
+ If(ABORT) STOP
+ err= ' '
+ endif
+
+ g_data_source_opened = .false. !not opened yet
+ g_data_source_in_hndl= 0 !none
+ call G_open_source(ABORT,err)
+ if(ABORT.or.err.ne.' ') then
+ call G_add_path(here,err)
+ call G_rep_err(ABORT,err)
+ If(ABORT) STOP
+ err= ' '
+ endif
+c
+*
+* if preprocessor on, open event file
+*
+ if(g_preproc_on.ne.0)then
+ g_preproc_opened=.false. !not opened yet
+ g_preproc_in_hndl=0 !none IO opened
+ call g_preproc_open(ABORT,err)
+ if (ABORT.or.err.ne.' ')then
+ call G_add_path(here,err)
+ call G_rep_err(ABORT,err)
+ if (ABORT) STOP
+ err=' '
+ endif
+ write(6,*)'Opened CODA event file for preprocessor output'
+ endif
+
+ finished_extracting = .false.
+ problems = .false.
+ syncfilter_on = .false.
+ insync = 0
+ EoF=.false.
+
+ if(gen_bigcal_mc.ne.0) goto 666 ! skip run info event loop
+
+ DO WHILE(.NOT.problems .and. .NOT.ABORT .and. .NOT.EoF .and.
+ & .NOT.finished_extracting)
+ mss= ' '
+ g_replay_time=time()-start_time
+
+ call G_clear_event(ABORT,err) !clear out old data
+ problems= problems .OR. ABORT
+
+ if(mss.NE.' ' .and. err.NE.' ') then
+ call G_append(mss,' & '//err)
+ elseif(err.NE.' ') then
+ mss= err
+ endif
+
+ If(.NOT.problems) Then
+ call G_get_next_event(ABORT,err) !get and store 1 event
+ problems= problems .OR. ABORT
+ if(.NOT.ABORT) total_event_count= total_event_count+1
+
+ EndIf
+
+ if(mss.NE.' ' .and. err.NE.' ') then
+ call G_append(mss,' & '//err)
+ elseif(err.NE.' ') then
+ mss= err
+ endif
+*
+* Check if this is a physics event or a CODA control event.
+*
+ if(.not.problems) then
+ gen_event_type = jishft(craw(2),-16)
+ !write(*,*)'gen_event_type = ',gen_event_type
+ !write(*,*)'gen_MAX_trigger_types = ',gen_MAX_trigger_types
+
+ if(gen_event_type.le.gen_MAX_trigger_types) then
+ recorded_events(gen_event_type)=recorded_events(gen_event_type)+1
+ if (gen_event_type.ne.0) sum_recorded=sum_recorded+1
+ write(6,*) "AAAAAAAAAAHHHHHHHHHHHHHHHHHHHHHHHHHHH!!!!!!!!!!"
+ write(6,*) "Whew, I feel much bettter now"
+ write(6,*) "However, you might want to know that I've hit a physics event"
+ write(6,*) "In my run info event loop and THAT SHOULD NEVER HAPPEN!!!"
+ write(6,*) "KILL ME!!! KILL ME NOW!!!!!"
+ endif
+*
+* if preprocessor is on write all events of trig type > 16
+* (i.e. all non-physics events)
+*
+ if(gen_event_type.ge.(gen_max_trigger_types-1) .and.
+ $ g_preproc_on.ne.0) then
+ call g_write_event(ABORT,err)
+ endif
+*
+* if preprocessor is on write trig type 0 (scaler events)
+*
+ if(gen_event_type.eq.0 .and. g_preproc_on.ne.0) then
+ call g_write_event(ABORT,err)
+ else if (gen_event_type.eq.130) then !run info event (get e,p,theta)
+ finished_extracting=.true.
+ write(6,'(a)') 'COMMENTS FROM RUN INFO EVENT'
+ call g_extract_kinematics(ebeam,phms,thms,psos,tsos,ntarg)
+ write(6,'(a)') 'KINEMATICS FROM RUN INFO EVENT'
+ if (ebeam.gt.10.) ebeam=ebeam/1000. !usually in MeV
+ write(6,*) ' gpbeam =',abs(ebeam),' GeV'
+ gpbeam=abs(ebeam)
+ write(6,*) ' hpcentral =',abs(phms),' GeV/c'
+ hpcentral=abs(phms)
+ write(6,*) ' htheta_lab =',abs(thms),' deg.'
+ htheta_lab=abs(thms)
+ write(6,*) ' spcentral =',abs(psos),' GeV/c'
+ spcentral=abs(psos)
+ write(6,*) ' stheta_lab =',abs(tsos),' deg.'
+ stheta_lab=abs(tsos)
+ write(6,*) ' gtarg_num =',abs(ntarg)
+ gtarg_num=ntarg
+ else if (gen_event_type.eq.131 .or. gen_event_type.eq.132) then! EPICS event
+ call g_examine_epics_event
+
+ else if (gen_event_type.eq.133) then !SAW's new go_info events
+ call g_examine_go_info(CRAW,ABORT,err)
+ else if (gen_event_type.eq.141 .or. gen_event_type.eq.142 .or.
+ & gen_event_type.eq.144) then
+* write(6,*) 'HV information event, event type=',gen_event_type
+ else if (gen_event_type.eq.146..or.gen_event_type.eq.147) then
+c write(6,*) 'Cheesy poofs! - picture event'
+ call g_examine_picture_event
+ else if (gen_event_type.eq.251) then
+ syncfilter_on = .true.
+ else
+ call g_examine_control_event(CRAW,ABORT,err)
+ endif
+
+! Go event is last 'nice tag' for point where we should have already seen
+! run-info event.
+
+ if (gen_event_type.eq.18) then
+ write(6,*) "no run information event found"
+ finished_extracting=.true.
+ endif
+
+ endif !if .not.problems
+ enddo !do while .not.finished_extracting
+
+ 666 continue
+
+ !write(*,*) 'skipped run info event loop for mc analysis'
+
+ call G_initialize(ABORT,err) !includes a total reset
+ IF(ABORT.or.err.NE.' ') THEN
+ call G_add_path(here,err)
+ call G_rep_err(ABORT,err)
+ If(ABORT) STOP
+ err= ' '
+ ENDIF
+
+c write(*,*) 'G_initialize completed successfully'
+*
+*-attempt to open FASTBUS-CODA file
+*
+c g_data_source_opened = .false. !not opened yet
+c g_data_source_in_hndl= 0 !none
+c call G_open_source(ABORT,err)
+c if(ABORT.or.err.ne.' ') then
+c call G_add_path(here,err)
+c call G_rep_err(ABORT,err)
+c If(ABORT) STOP
+c err= ' '
+c endif
+
+ call engine_command_line(.false.) ! Set CTP vars from command line
+c
+ !write(*,*) 'about to call h_fieldcorr'
+ if(gen_run_enable(0).ne.0) then
+ call h_fieldcorr(ABORT,err)
+ endif
+c
+c call h_fieldcorr subroutine
+c to fix problem with setting hpcentral in field programs
+c applies to experiments using fieldxx.f programs before field02.f
+c parameter genable_hms_fieldcorr is switch to determine
+c whether fix is applied.
+c
+ if(gen_run_enable(1).ne.0) then
+ call s_fieldcorr(ABORT,err)
+ endif
+c
+ if (genable_sos_satcorr.ne.0) then
+ write(*,*) '*************'
+ write(*,*) ' SOS saturation correction enabled'
+ write(*,*) ' Delta modified for each event'
+ write(*,*) '*************'
+ endif
+c
+
+ call G_apply_offsets(ABORT,err)
+c
+c initial polarized target field
+ if (SANE_TGTFIELD_B .gt. 0) then
+c BETA and HMS angle relative to beam direction, need SANE_FIELD_ANGLE_THETA
+ SANE_FIELD_ANGLE_PHI = 180.0d00
+ SANE_BETA_ANGLE_THETA = bigcal_theta_deg
+ SANE_BETA_ANGLE_PHI = 0.0d00 ! pointing beam left is phi =0
+ SANE_HMS_ANGLE_THETA = htheta_lab
+ SANE_HMS_ANGLE_PHI = 180.0d00 ! pointing beam left is phi =180
+ SANE_BETA_OMEGA = abs(SANE_BETA_ANGLE_THETA - SANE_FIELD_ANGLE_THETA) ! used in sane_physics.f
+c detemine angle of HMS and BETA relative to FIELD direction
+ SANE_HMS_FIELD_THETA = SANE_FIELD_ANGLE_THETA + SANE_HMS_ANGLE_THETA ! used h_targ_trans.f
+ SANE_HMS_FIELD_PHI = 180.d00 ! used h_targ_trans.f
+ if (SANE_HMS_FIELD_THETA .gt. 180.0d00) then
+ SANE_HMS_FIELD_THETA = 360.0d00 - SANE_HMS_FIELD_THETA
+ SANE_HMS_FIELD_PHI = 0.0d00
+ endif
+ SANE_BETA_FIELD_THETA = abs(SANE_FIELD_ANGLE_THETA - SANE_BETA_ANGLE_THETA) ! used gep_physics.f
+ SANE_BETA_FIELD_PHI = 180.d00 ! used gep_physics.f
+ if (SANE_FIELD_ANGLE_THETA .le. SANE_BETA_ANGLE_THETA) SANE_BETA_FIELD_PHI = 0.d00
+ call trgInit('trg_field_map_extended.dat')
+ endif
+c
+c
+c call G_apply_offsets which calls s_apply_offsets, h_apply_offsets
+c which apply offsets to spect. momenta, angles
+c
+* Print out the statistics report once...
+ if(g_stats_blockname.ne.' '.and.
+ $ g_stats_output_filename.ne.' ') then
+ file = g_stats_output_filename
+ call g_sub_run_number(file, gen_run_number)
+ ierr = threp(g_stats_blockname,file)
+ endif
+*
+* Comment out the following three lines if they cause trouble or
+* if wish is unavailable.
+*
+c$$$ write(system_string,*) './runstats ',file(1:index(file,' ')-1), ' ',
+c$$$ $ gen_run_number, ' > /dev/null &'
+c$$$ call system(system_string)
+*
+*-zero entire event buffer
+*
+ DO i=1,LENGTH_CRAW
+ CRAW(i)= 0
+ ENDDO
+
+ since_cnt= 0
+ report_incr = 10
+ problems= .false.
+ EoF = .false.
+
+ if(rpc_on.ne.0) then
+ print *,"*****************************************************"
+ print *," "
+ print *,"ENGINE is enabled to receive RPC requests"
+ if(rpc_control.eq.0) then
+ print *," "
+ print *,"ENGINE will HANG waiting for RPC requests"
+ else if(rpc_control.gt.0) then
+ print *,"ENGINE will HANG to waitfor RPC requests after "
+ $ ,rpc_control," events"
+ endif
+ if(rpc_control.ge.0) then
+ print *,"If you don't want this to happen, put one of the"
+ print *,"following in your CTP setup file"
+ print *," rpc_on = 0 ; Turns off RPC handling"
+ print *," rpc_control = -1 ; No Hanging, but RPC handled"
+ endif
+ print *," "
+ print *,"*****************************************************"
+
+ call thservset(0,0) !prepare for RPC requests
+
+ endif
+ rpc_pend = 0
+
+ start_time=time()
+ lasttime=0
+ lasttime2 = 0
+c
+c Start data analysis
+ if ( syncfilter_on) then
+ write(6,*) ' ******'
+ write(6,*) ' Analyzing using Syncfilter'
+ write(6,*) ' ******'
+ endif
+c
+ !write(*,*) 'Entering event loop'
+
+ DO WHILE(.NOT.problems .and. .NOT.ABORT .and. .NOT.EoF)
+ mss= ' '
+ g_replay_time=time()-start_time
+
+ call G_clear_event(ABORT,err) !clear out old data
+ problems= problems .OR. ABORT
+c !!!!!!!!!!!!!!!!!!!!!!!!!!!IF BIGCAL MONTE CARLO DATA, DO ALL EVENT REPLAY HERE!!!!!!!!
+ if(gen_bigcal_mc.ne.0) then
+c call get_bigcal_mc_event(gen_bigcal_mc,ABORT,err)
+ gen_event_type = 5
+ if(gen_bigcal_mc.eq.3) then ! fake proton data included
+ gen_event_type = 6
+ endif
+
+ !write(*,*) 'Entering monte carlo reconstruction'
+
+ call bigcal_mc_reconstruction(gen_bigcal_mc,ABORT,err)
+
+c$$$ write(*,*) '(rowmax,colmax,adcmax)=',bigcal_iymax_adc,
+c$$$ $ bigcal_ixmax_adc,bigcal_max_adc
+
+ EoF = EOF_MC_DAT
+
+ if(abort) then
+ call g_add_path(here,err)
+ return
+ endif
+
+c$$$ recorded_events(gen_event_type)=recorded_events(gen_event_type)+1
+c$$$ sum_recorded=sum_recorded+1
+c$$$ total_event_count= total_event_count+1
+
+ groupname='bigcal'
+ if(gen_bigcal_mc.eq.3) groupname='gep'
+ call g_keep_results(groupname,ABORT,err)
+
+ if(abort) then
+ call g_add_path(here,err)
+ return
+ endif
+
+ sum_analyzed = sum_analyzed + 1
+ gen_event_ID_number = gen_event_ID_number + 1
+c write(*,*) gen_event_ID_number
+
+ goto 667 ! skip the rest of event loop
+ endif
+c !!!!!!!!!!!!!!!!!!!!!!!!!!!END BIGCAL MONTE CARLO EVENT REPLAY!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ if(mss.NE.' ' .and. err.NE.' ') then
+ call G_append(mss,' & '//err)
+ elseif(err.NE.' ') then
+ mss= err
+ endif
+ If(.NOT.problems) Then
+ call G_get_next_event(ABORT,err) !get and store 1 event
+ problems= problems .OR. ABORT
+ if(.NOT.ABORT) total_event_count= total_event_count+1
+ EndIf
+
+ if(mss.NE.' ' .and. err.NE.' ') then
+ call G_append(mss,' & '//err)
+ elseif(err.NE.' ') then
+ mss= err
+ endif
+*
+* Check if this is a physics event or a CODA control event.
+*
+ if (.not.problems) then
+ gen_event_type = jishft(craw(2),-16)
+ if (gen_event_type .eq. 13) then
+ gen_event_type = 6
+ endif
+ if(grun .ge. 72532 .and.
+ > grun .le. 72583) then
+ if (gen_event_type .eq. 1) gen_event_type = 6
+ endif
+
+c write(*,*) 'gen_event_type=',gen_event_type
+c write(*,*) 'gepid_gep_ev_type=',gepid_gep_evtype
+
+ if(gepid_gep_evtype.gt.0) then
+c write(*,*) 'filling gep event type hist, gen_event_type=',
+c $ gen_event_type
+ call hf1(gepid_gep_evtype,float(gen_event_type),1.)
+ endif
+
+ if(gen_event_type.le.gen_MAX_trigger_types) then
+ recorded_events(gen_event_type)=recorded_events(gen_event_type)+1
+ if (gen_event_type.ne.0) sum_recorded=sum_recorded+1
+ endif
+*
+*if preprocessor is on write all events of trig type > 16
+* (i.e. all non-physics events)
+*
+ if(gen_event_type.ge.(gen_max_trigger_types-1) .and.
+ & g_preproc_on.ne.0) call g_write_event(ABORT,err)
+*
+* if preprocessor is on write trig type 0 (scaler events)
+*
+ if(gen_event_type.eq.0 .and. g_preproc_on.ne.0)
+ & call g_write_event(ABORT,err)
+c
+ if (gen_event_type .eq. 251) then
+ write(6,*) ' Syncfilter event, SYNC type = ',craw(5)
+ insync = craw(5)
+ endif
+c
+ if (gen_event_type.eq.130) then !run info event (get e,p,theta)
+ write(6,*) " ***********"
+ write(6,*) " A run info event after starting to analyze physics events"
+ write(6,*) " If you are using the kinematics file "
+ write(6,*) " to set HMS and SOS central momentum and angles then no problem"
+ write(6,*) " number of events for event types HMS,SOS,COIN",analyzed_events(1)
+ >,analyzed_events(2),analyzed_events(3)
+ write(6,*) " If no events analyzed yet for HMS,SOS, or COIN then no problem"
+ write(6,*) " ***********"
+ write(6,*) " If you are relying on the run info event "
+ write(6,*) " to set HMS and SOS central momentum and angles then for this run"
+ write(6,*) " it is best to do it using the kinematics file"
+ write(6,*) " ***********"
+ endif
+
+ if(jieor(jiand(CRAW(2),'FFFF'x),'10CC'x).eq.0) then ! Physics event
+ if (gen_event_type.eq.0) then !scaler event.
+ analyzed_events(gen_event_type)=analyzed_events(gen_event_type)+1
+ call g_analyze_scalers_by_banks(CRAW,ABORT,err)
+ if (g_writeout_scaler_filename.ne.' ' .and. analyzed_events(0) .gt. 1) then
+ delta_time = max(gscaler_change(gclock_index)/gclock_rate,.000D00)
+ write(G_LUN_WRITEOUT_SCALER,'(i10,10g12.5)') gen_event_ID_number,delta_time,
+ > (gscaler_change(INDEX_WRITEOUT_SCALERS(tindex))/delta_time
+ > ,tindex=1,NUM_WRITEOUT_SCALERS)
+ endif
+c
+ if (syncfilter_on) then
+ if ( insync .eq. 1 .or. skip_events )
+ , write(*,*) ' Skipping out-of-sync events'
+ if ( ave_current_bcm(bcm_for_threshold_cut) .le. g_beam_on_thresh_cur(bcm_for_threshold_cut)
+ > .or. insync .eq. 1 .or. skip_events ) then
+ do ii=1,MAX_NUM_SCALERS
+ gscaler_skipped(ii) = gscaler_skipped(ii) + gscaler_change(ii)
+ enddo
+ else
+ do ii=1,MAX_NUM_SCALERS
+ gscaler_saved(ii) = gscaler_saved(ii) + gscaler_change(ii)
+ enddo
+ endif
+ endif
+c
+ if (analyzed_events(0) .le. 1 ) then
+ write(*,*) '************'
+c write(*,*)' Will not analyze events until after first scaler read'
+ write(*,*) '************'
+ endif
+*
+* if preprocessor is on write trig type 0 (scaler events)
+*
+ if(gen_event_type.eq.0 .and. g_preproc_on.ne.0)
+ & call g_write_event(ABORT,err)
+*
+* dump report at first scaler event AFTER hist_dump_interval to keep hardware
+* and software scalers roughly in sync.
+*
+ if((physics_events-lastdump).ge.gen_run_hist_dump_interval
+ & .and.gen_run_hist_dump_interval.gt.0) then
+ lastdump=physics_events ! Wait for next interval of dump_int.
+ !write(*,*) 'about to call g_proper_shutdown. Is this where the seg. fault occurs?'
+ call g_proper_shutdown(ABORT,err)
+ print 112,
+ & "Finished dumping histograms/scalers for first",
+ & physics_events," events"
+ 112 format (a,i8,a)
+ endif
+ else !REAL physics event.
+c may need to change some of this stuff to look at the testlab data.
+ if (analyzed_events(0) .le. 1 .and. gen_event_type .le. 3) then
+ if (skipped_events_scal .eq. 0 ) then
+ write(*,*) '************'
+c write(*,*) ' Will not analyze SOS,HMS or coin events until after first scaler read'
+ write(*,*) ' Analyzed events :',(analyzed_events(mkj),mkj=1,4)
+ write(*,*) '************'
+ endif
+ skipped_events_scal = skipped_events_scal + 1
+ goto 868 ! kludge mkj
+ endif
+c
+c
+ if(gen_event_type.le.gen_MAX_trigger_types) then
+ if(gen_run_enable(gen_event_type-1).ne.0) then
+c
+ if ( insync .eq. 1 .and. gen_event_type .ne. 4 .and. syncfilter_on ) then
+ skipped_badsync_events(gen_event_type)=skipped_badsync_events(gen_event_type) + 1
+ sum_analyzed_skipped = sum_analyzed_skipped + 1
+ goto 868
+ endif
+ if ( skip_events .and. gen_event_type .ne. 4 .and. syncfilter_on ) then
+ skipped_badsync_events(gen_event_type)=skipped_badsync_events(gen_event_type) + 1
+ sum_analyzed_skipped = sum_analyzed_skipped + 1
+ goto 868
+ endif
+ if ( ave_current_bcm(bcm_for_threshold_cut) .lt. g_beam_on_thresh_cur(bcm_for_threshold_cut)
+ > .and. gen_event_type .ne. 4 .and. syncfilter_on) then
+ skipped_lowbcm_events(gen_event_type)=skipped_lowbcm_events(gen_event_type) + 1
+ sum_analyzed_skipped = sum_analyzed_skipped + 1
+ goto 868
+ endif
+c
+
+ call g_examine_physics_event(CRAW,ABORT,err)
+
+ problems = problems .or.ABORT
+
+ if(mss.NE.' ' .and. err.NE.' ') then
+ call G_append(mss,' & '//err)
+ elseif(err.NE.' ') then
+ mss= err
+ endif
+
+ if (num_events_skipped.lt.gen_run_starting_event .and.
+ & gen_event_type.ne.4) then ! always analyze peds.
+ num_events_skipped = num_events_skipped + 1
+ else
+ if(gen_run_starting_event.eq.gen_event_id_number)
+ & start_time=time() !reset start time for analysis rate
+ if(.NOT.problems) then
+ if (gen_event_type.ne.0) then !physics events (not scalers)
+ !write(*,*) 'about to call g_reconstruction, trying to locate segfault'
+c write(*,*) 'calling g_reconstruction, gen_event_type=',
+c $ gen_event_type
+
+
+ call G_reconstruction(CRAW,ABORT,err) !COMMONs
+ physics_events = physics_events + 1
+ if (gen_event_type .le. gen_max_trigger_types) then
+ analyzed_events(gen_event_type)=analyzed_events(gen_event_type)+1
+ endif
+ if (gen_event_type.ne.0) sum_analyzed=sum_analyzed+1
+ problems= problems .OR. ABORT
+
+ else !gen_event_type=0, scaler event
+ endif
+ endif
+
+ if(mss.NE.' ' .and. err.NE.' ') then
+ call G_append(mss,' & '//err)
+ elseif(err.NE.' ') then
+ mss= err
+ endif
+
+ groupname=' '
+ if (gen_event_type.eq.1) then
+ groupname='hms'
+ else if (gen_event_type.eq.2) then
+ groupname='sos'
+ else if (gen_event_type.eq.3) then
+ groupname='both'
+ else if (gen_event_type.eq.4) then
+ start_time=time() !reset start time for analysis rate
+ groupname='ped'
+ else if (gen_event_type.eq.5.or.gen_event_type.eq.7.or.
+ $ gen_event_type.eq.8) then
+ groupname = 'bigcal'
+ else if (gen_event_type.eq.6) then
+ groupname = 'gep'
+ else
+ write(6,*) 'gen_event_type= ',gen_event_type,
+ , ' for call to g_keep_results'
+ endif
+
+ If(.NOT.problems .and. groupname.ne.' ') Then
+ !write(*,*) 'about to call g_keep_results'
+ call G_keep_results(groupname,ABORT,err) !file away results as
+ problems= problems .OR. ABORT !specified by interface
+ EndIf
+
+ if(mss.NE.' ' .and. err.NE.' ') then
+ call G_append(mss,' & '//err)
+ elseif(err.NE.' ') then
+ mss= err
+ endif
+*
+* if preprocessor is on check event for write criteria
+*
+ if(g_preproc_on.ne.0)then
+ if(.NOT.problems)then
+ call g_preproc_event(preprocessor_keep_event)
+ if(preprocessor_keep_event.eq.1)then
+ call g_write_event(ABORT,err)
+ endif
+ endif
+ endif
+
+*
+*- Here is where we insert a check for an Remote Proceedure Call (RPC)
+*- from another process for CTP to interpret
+*
+ if(rpc_on.ne.0) then
+ if(rpc_pend.eq.0.and.rpc_control.eq.0) then
+ do while(rpc_pend.eq.0.and.rpc_control.eq.0)
+ ierr = thservone(-1) !block until one RPC request serviced
+ rpc_pend = thcallback()
+ enddo
+ else
+ ierr = thservone(0) !service one RPC requests
+ rpc_pend = thcallback()
+ endif
+ if(rpc_pend.lt.0) rpc_pend = 0 ! Last thcallback took care of all
+ ! outstanding requests
+ if(rpc_control.gt.0) rpc_control = rpc_control - 1
+ endif
+
+ endif
+ endif
+ else if (gen_event_type.eq.131 .or. gen_event_type.eq.132) then ! EPICS event
+ call g_examine_epics_event
+
+ endif
+
+ endif !if REAL physics event as opposed to scaler (evtype=0)
+
+ Else
+ if(gen_event_type.eq.129) then
+ write(6,*) 'CODA 1.4 SCALER EVENT - event type 129!!!!!'
+ write(6,*) ' Will not Analyze this event'
+! call g_analyze_scalers(CRAW,ABORT,err)
+!* Dump report at first scaler event AFTER hist_dump_interval to keep hardware
+!* and software scalers in sync.
+! if((physics_events-lastdump).ge.gen_run_hist_dump_interval.and.
+! & gen_run_hist_dump_interval.gt.0) then
+! lastdump=physics_events ! Wait for next interval of dump_int.
+! call g_proper_shutdown(ABORT,err)
+! print 112,"Finished dumping histograms/scalers for first"
+! & ,physics_events," events"
+! 112 format (a,i8,a)
+! endif
+ else if (gen_event_type.eq.133) then !SAW's new go_info events
+ call g_examine_go_info(CRAW,ABORT,err)
+ else
+ call g_examine_control_event(CRAW,ABORT,err)
+ endif
+ mss = err
+ EndIf
+ endif
+c
+c skip analyzing data until after first scaler read
+c also can skip if using syncfilter and beam current is low
+ 868 continue
+c
+c
+*
+*Now write the statistics report every 2 sec...
+*
+ if (g_replay_time-lasttime.ge.2) then !dump every 2 seconds
+ lasttime=g_replay_time
+ if(g_stats_blockname.ne.' '.and.
+ $ g_stats_output_filename.ne.' ') then
+ file = g_stats_output_filename
+ call g_sub_run_number(file, gen_run_number)
+ ierr = threp(g_stats_blockname,file)
+ endif
+ endif
+
+ 667 continue
+
+ since_cnt= since_cnt+1
+
+* * echo progress at least once every 3 minutes but no more than every 15 sec
+ if (mod(since_cnt,report_incr) .eq. 0) then
+ avrate = float(since_cnt)/max(float(g_replay_time),0.001)
+ tdiff=g_replay_time-lasttime2
+ instrate = report_incr/max(float(tdiff),0.001)
+ if (total_event_count.gt.99999.or.physics_events.gt.99999.or.
+ > g_replay_time.gt.9999) then
+ write(6,'(''[47;34;1m Event = '',i9,3x,''trigger#'',i9,4x,''(time = '',
+ >i6,''s, rate int= '',i5,''/s, diff= '',i5,''/s) [49;0m'')')
+ > total_event_count,physics_events,g_replay_time,int(avrate),int(instrate)
+ else
+ write(6,'(''[47;34;1m Event = '',i5,3x,''trigger#'',i5,4x,''(time = '',
+ >i4,''s, rate int= '',i5,''/s, diff= '',i5,''/s) [49;0m'')')
+ > total_event_count,physics_events,g_replay_time,int(avrate),int(instrate)
+ endif
+ lasttime2 = g_replay_time
+ if (tdiff.lt.15) then
+ report_incr = report_incr*10
+ elseif(tdiff.gt.180) then
+ report_incr = report_incr/10
+ endif
+ endif
+
+
+
+ If(ABORT .or. mss.NE.' ') Then
+ call G_add_path(here,mss) !only if problems
+ call G_rep_err(ABORT,mss)
+ EndIf
+
+ EoF= gen_event_type.EQ.20 .or. EOF_MC_DAT
+
+ if(gen_run_stopping_event.gt.0 .and. gen_event_ID_number.gt.0) then
+ EoF=EoF .or. gen_run_stopping_event.le.sum_analyzed+sum_analyzed_skipped-analyzed_events(4)
+ $ .or. EOF_MC_DAT
+ EndIf
+*
+*- Here is where we insert a check for an Remote Proceedure Call (RPC)
+*- from another process for CTP to interpret
+
+
+*
+ ENDDO !found a problem or end of run
+
+c write(*,*) 'ncalls_calc_ped=',ncalls_calc_ped
+
+c... Calibrate HMS and SOS calorimeters.
+
+ if(hdbg_tracks_cal.lt.0) call h_cal_calib(1)
+
+ if(sdbg_tracks_cal.lt.0) call s_cal_calib(1)
+
+c calibrate HMS scintilattor tof
+ call h_tofcal_endrun(gen_run_number)
+
+c... call to calibration routine for BigCal.
+ if(bigcal_do_calibration.ne.0) then
+ write(*,*) '*****CALLING BIGCAL CALIBRATION*****'
+c write(*,*) 'Nred=',bigcal_Ncalib
+c call bigcal_calib(bigcal_Ncalib,abort,err)
+ call bigcal_calib(abort,err)
+ endif
+
+c also call bigcal end-of-run hist filling here, so that it is close
+c to other BigCal stuff and easy to find
+ call b_fill_eff_hists(abort,err)
+c...
+
+ print *,' -------------------------------------'
+
+ IF(ABORT .or. mss.NE.' ') THEN
+ call G_rep_err(ABORT,mss) !report any errors or warnings
+ err= ' '
+ ENDIF
+
+ if(rpc_on.ne.0) call thservunset(0,0)
+
+ print *,' -------------------------------------'
+*
+* Print out the statistics report one last time...
+ if(g_stats_blockname.ne.' '.and.
+ $ g_stats_output_filename.ne.' ') then
+ file = g_stats_output_filename
+ call g_sub_run_number(file, gen_run_number)
+ ierr = threp(g_stats_blockname,file)
+ endif
+
+ call G_proper_shutdown(ABORT,err) !save files, etc.
+ If(ABORT .or. err.NE.' ') Then
+ call G_add_path(here,err) !report any errors or warnings
+ call G_rep_err(ABORT,err)
+ err= ' '
+ EndIf
+
+ call g_ntuple_shutdown(ABORT,err)
+ If(ABORT .or. err.NE.' ') Then
+ call G_add_path(here,err) !report any errors or warnings
+ call G_rep_err(ABORT,err)
+ err= ' '
+ EndIf
+*
+* close charge scalers output file.
+ if (g_charge_scaler_filename.ne.' ') close(unit=G_LUN_CHARGE_SCALER)
+*
+* close epics output file.
+ if (g_epics_output_filename.ne.' ') close(unit=G_LUN_EPICS_OUTPUT)
+
+ if (g_preproc_opened) then
+ status= evclose(g_preproc_in_hndl)
+ if (status.ne.0) write(6,*) 'status for evclose=',status
+ endif
+
+ call sane_close_scalers()
+ call g_dump_peds
+ call h_dump_peds
+ call s_dump_peds
+ call b_dump_peds ! add bigcal
+ print *
+ print *,'Processed:'
+ DO i=0,gen_MAX_trigger_types
+ If(recorded_events(i).GT.0) Then
+ write(mss,'(4x,i12," / ",i8," events of type",i3)')
+ & analyzed_events(i),recorded_events(i),i
+ call G_log_message(mss)
+ EndIf
+ ENDDO
+ write(mss,'(i12," / ",i8," total (neglecting scalers)")') sum_analyzed,sum_recorded
+ call G_log_message(mss)
+ print *,' for run#',gen_run_number
+ if ( syncfilter_on) then
+ write(mss,'(i12," number of analyzed skipped ")') sum_analyzed_skipped
+ call G_log_message(mss)
+ DO i=1,gen_MAX_trigger_types
+ If(recorded_events(i).GT.0) Then
+ write(mss,'(" events of type:",i3,
+ , " # skipped for bad sync:",i12)')
+ & i,skipped_badsync_events(i)
+ call G_log_message(mss)
+ ENDIF
+ ENDDO
+ DO i=1,gen_MAX_trigger_types
+ If(recorded_events(i).GT.0) Then
+ write(mss,'(" events of type:",i3,
+ & " # skipped for low current:",i12)')
+ & i,skipped_lowbcm_events(i)
+ call G_log_message(mss)
+ ENDIF
+ ENDDO
+ endif
+
+ avrate = float(since_cnt)/max(float(g_replay_time),0.001)
+ tdiff=g_replay_time-lasttime2
+ write(6,'(''[47;34;1m Event #'',i9,'', trigger #'',i9,'', time = '',i6,
+ >''s, rate '',i5,''/s [49;0m'')')
+ >total_event_count,physics_events,g_replay_time,int(avrate)
+
+ ierr=thtreecloseg('all')
+
+* Comment out the following two lines if they cause trouble
+ call system
+ & ("kill `ps | grep runstats | awk '{ print $1}'` > /dev/null")
+
+
+ END
+
+ subroutine engine_command_line(outputflag)
+
+ implicit none
+ integer iarg
+ character*132 arg
+c iargc is a GNU extension (intrinsic)
+c integer iargc
+c external iargc
+ logical outputflag
+*
+* Process command line args that set CTP variables
+*
+ do iarg=1,iargc()
+ call getarg(iarg,arg)
+ if(index(arg,'=').gt.0) then
+ call thpset(arg)
+ if (outputflag) write(6,'(4x,a70)') arg(1:70)
+ endif
+ enddo
+
+ return
+ end
diff --git a/ENGINE/g_analyze_beam_pedestal.f b/ENGINE/g_analyze_beam_pedestal.f
new file mode 100644
index 0000000..4fe60fa
--- /dev/null
+++ b/ENGINE/g_analyze_beam_pedestal.f
@@ -0,0 +1,51 @@
+ subroutine g_analyze_beam_pedestal(ABORT,err)
+*
+* $Log: g_analyze_beam_pedestal.f,v $
+* Revision 1.3 1999/02/23 16:49:21 csa
+* (JRA) Add gmisc_dec_data
+*
+* Revision 1.2 1999/02/10 17:38:09 csa
+* Added call to g_analyze_misc
+*
+* Revision 1.1 1996/01/22 15:08:20 saw
+* Initial revision
+*
+ implicit none
+ save
+*
+ character*23 here
+ parameter (here='g_analyze_beam_pedestal')
+*
+ logical ABORT
+ character*(*) err
+*
+ integer*4 ihit
+ integer*4 ind
+*
+ INCLUDE 'gen_data_structures.cmn'
+ save
+*
+*
+* MISC PEDESTALS
+*
+ do ihit = 1 , gmax_misc_hits
+ gmisc_dec_data(ihit,2)=-1
+ enddo
+
+ do ihit = 1 , gmisc_tot_hits
+ if (gmisc_raw_addr1(ihit).eq.2) then !ADCs
+ ind=gmisc_raw_addr2(ihit) ! no sparsification yet - NEED TO FIX!!!!
+ gmisc_dec_data(ind,2) = gmisc_raw_data(ihit)
+ gmisc_ped_sum2(ind,2) = gmisc_ped_sum2(ind,2) +
+ $ gmisc_raw_data(ihit)*gmisc_raw_data(ihit) !2 is for ADCs
+ gmisc_ped_sum(ind,2) = gmisc_ped_sum(ind,2) + gmisc_raw_data(ihit)
+ gmisc_ped_num(ind,2) = gmisc_ped_num(ind,2) + 1
+ endif
+ enddo
+
+* we have to call this also for pedestal events, to get the mean
+* beam position before we get the first physics event
+ call g_analyze_misc(ABORT,err)
+
+ return
+ end
diff --git a/ENGINE/g_analyze_misc.f b/ENGINE/g_analyze_misc.f
new file mode 100644
index 0000000..51b96d2
--- /dev/null
+++ b/ENGINE/g_analyze_misc.f
@@ -0,0 +1,402 @@
+ subroutine g_analyze_misc(abort,errmsg)
+*-------------------------------------------------------------------
+* author: John Arrington
+* created: 1/17/96
+*
+* g_analyze_misc takes the gen_decoded_misc common block and
+* generates decoded bpm/raster information.
+*
+* $Log: g_analyze_misc.f,v $
+* Revision 1.9.20.4.2.8 2010/02/23 14:51:30 jones
+* Remove "dbg slow raster=" write statements
+*
+* Revision 1.9.20.4.2.7 2009/06/05 17:47:35 jones
+* Changed gsrx_raw_adc = gmisc_dec_data(3,2) to gmisc_dec_data(4,2)
+* gsry_raw_adc = gmisc_dec_data(4,2) to gmisc_dec_data(3,2)
+*
+* Revision 1.9.20.4.2.6 2009/01/16 18:47:12 cdaq
+* *** empty log message ***
+*
+* Revision 1.9.20.4.2.5 2008/11/05 15:41:54 cdaq
+* Set variables gsrx_adc and gsry_adc
+*
+* Revision 1.9.20.4.2.4 2008/10/28 20:55:21 cdaq
+* Changed raster channels
+*
+* Revision 1.9.20.4.2.3 2008/10/19 21:49:24 cdaq
+* slow raster
+*
+* Revision 1.9.20.4.2.2 2008/10/11 15:03:34 cdaq
+* slow raster
+*
+* Revision 1.9.20.4.2.1 2008/09/26 21:03:49 cdaq
+* *** empty log message ***
+*
+* Revision 1.9.20.4 2007/10/20 19:55:06 cdaq
+* Added more helicity analysis
+*
+* Revision 1.9.20.3 2007/10/17 19:30:14 cdaq
+* changed cutoffs for h+ and h- signals: >8000 for ON, <2000 for OFF
+*
+* Revision 1.9.20.2 2007/10/17 16:12:38 cdaq
+* Added handling of helicity ADC
+*
+* Revision 1.9.20.1 2007/10/17 15:52:54 cdaq
+* Added helicity stuff
+*
+* Revision 1.9 2003/09/05 15:17:37 jones
+* Merge in online03 changes (mkj)
+*
+* Revision 1.8.2.1 2003/08/14 00:23:36 cdaq
+* Get bpm3 x and y position data from correct part of gmisc_dec_data array (mkj)
+*
+* Revision 1.8 2002/12/27 21:57:50 jones
+* a. delete variable n_use_bpm and only use variable n_use_bpms
+* b. Comment out forced setting of guse_bpm_in_recon,gusefr,guse_frdefault
+* c. only set xp(3),yp(3),xm(3),ym(3) when n_use_bpms .eq. 3
+* d. gbpm_kappa is an array
+* e. JRA added check of fasraster pedestals
+*
+* Revision 1.7 1999/11/04 20:35:14 saw
+* Linux/G77 compatibility fixes
+*
+* Revision 1.6 1999/06/10 14:38:25 csa
+* (CSA) Commented out debugging output
+*
+* Revision 1.5 1999/02/23 16:55:43 csa
+* Correct gbeam calc, add a bunch of comments
+*
+* Revision 1.4 1999/02/10 17:43:38 csa
+* Updated code for SEE bpms (P. Gueye?), added raster calculations
+* (J. Reinhold), and added code for third target bpm
+*
+* Revision 1.3 1996/09/04 14:30:41 saw
+* (JRA) Add beam position calculations
+*
+* Revision 1.2 1996/04/29 19:41:09 saw
+* (JRA) Update BPM code
+*
+* Revision 1.1 1996/01/22 15:08:37 saw
+* Initial revision
+*
+*--------------------------------------------------------
+
+ implicit none
+
+ include 'gen_data_structures.cmn'
+ include 'gen_constants.par'
+ include 'gep_hist_id.cmn'
+
+ logical abort
+ character*(*) errmsg
+ character*20 here
+ parameter (here = 'g_analyze_misc')
+
+ integer*4 ibpm,ibpm_sample,n_use_bpms
+ real*8 normfrx,frxphase,frxdphase
+ real*8 normfry,fryphase,frydphase
+
+ real*4 xp(gmax_num_bpms),xm(gmax_num_bpms)
+ real*4 yp(gmax_num_bpms),ym(gmax_num_bpms)
+ real*4 bpm_x(gmax_num_bpms,gbpm_sample_max)
+ real*4 bpm_y(gmax_num_bpms,gbpm_sample_max)
+ real*4 bpm_meanx(gmax_num_bpms),bpm_meany(gmax_num_bpms)
+ real*4 sum_x,sum_y,sum_z,sum_zx,sum_zy,sum_zz,denom
+
+ integer*4 numfr
+ real*4 sumfry,sumfrx,avefry,avefrx
+
+ real*4 small
+ parameter (small = 1.e-6)
+
+ save
+
+ abort = .false.
+ errmsg = ' '
+
+* csa 2/99 -- Note that the SEE BPMs have a large delay in their
+* electronics. For a 20 kHz raster, it amounts to about 90 degrees.
+* There is a phase ambiguity which arises from this delay, and as a
+* result, the target position derived directly from the BPM *cannot*
+* be used on an event-by-event basis to correct for position. The
+* fast raster signal should be used for this (alternatively, the
+* phase ambiguity can be resolved using both the fast raster and
+* fast raster synch signals). We *can* use the BPM signals to
+* calculate a running centroid average (phase ambiguity is not
+* harmful here).
+
+* In principle, the following needs to be done only once per run...
+
+ n_use_bpms = 3
+ if (guse_bpmc .ne. 1) n_use_bpms = 2
+
+* csa 2/2/99 -- Until we understand the bpms we will not use the
+* info in the analyzer. Once someone has done a reasonable analysis
+* that convinces us we understand what we are getting, these defeats
+* can be removed.
+
+* mkj 11/21/2001 Let the user have some intelligence to set these.
+*mkj if(guse_bpm_in_recon .ne. 0) then
+*mkj write(6,*)' g_analyze_misc: forcing guse_bpm_in_recon to 0'
+*mkj guse_bpm_in_recon = 0
+*mkj endif
+
+*mkj if(gusefr .ne. 0) then
+*mkj write(6,*)' g_analyze_misc: forcing gusefr to 0 (NO Fast Raster corrections)'
+*mkj gusefr = 0
+*mkj endif
+
+*mkj if(guse_frdefault .ne. 1) then
+*mkj write(6,*)' g_analyze_misc: forcing guse_frdefault to 1'
+*mkj guse_frdefault = 1
+*mkj endif
+
+* initialize beam coordinates
+
+ gbeam_x = 0.
+ gbeam_xp = 0.
+ gbeam_y = 0.
+ gbeam_yp = 0.
+
+* BPM Signals:
+* ============
+
+* pedestals are set in replay/PARAM/gbeam.param.*
+
+ xp(1) = gmisc_dec_data(5,2) - gbpm_xp_ped(1)
+ xm(1) = gmisc_dec_data(6,2) - gbpm_xm_ped(1)
+ yp(1) = gmisc_dec_data(7,2) - gbpm_yp_ped(1)
+ ym(1) = gmisc_dec_data(8,2) - gbpm_ym_ped(1)
+
+ xp(2) = gmisc_dec_data(9,2) - gbpm_xp_ped(2)
+ xm(2) = gmisc_dec_data(10,2) - gbpm_xm_ped(2)
+ yp(2) = gmisc_dec_data(11,2) - gbpm_yp_ped(2)
+ ym(2) = gmisc_dec_data(12,2) - gbpm_ym_ped(2)
+
+ if (n_use_bpms .eq. 3) then
+ xp(3) = gmisc_dec_data(17,2) - gbpm_xp_ped(3)
+ xm(3) = gmisc_dec_data(18,2) - gbpm_xm_ped(3)
+ yp(3) = gmisc_dec_data(19,2) - gbpm_yp_ped(3)
+ ym(3) = gmisc_dec_data(20,2) - gbpm_ym_ped(3)
+ endif
+
+* calibration constants are set in replay/PARAM/gbeam.param.*
+
+ do ibpm = 1,n_use_bpms
+ gbpm_yprime(ibpm) = gbpm_kappa(ibpm)*
+ & (xp(ibpm)-gbpm_alpha_x(ibpm)*xm(ibpm))/
+ & (xp(ibpm)+gbpm_alpha_x(ibpm)*xm(ibpm)+small)
+ gbpm_xprime(ibpm) = -gbpm_kappa(ibpm)*
+ & (yp(ibpm)-gbpm_alpha_y(ibpm)*ym(ibpm))/
+ & (yp(ibpm)+gbpm_alpha_y(ibpm)*ym(ibpm)+small)
+ gbpm_x(ibpm) = ( gbpm_xprime(ibpm)+gbpm_yprime(ibpm))/sqrt(2.)+
+ & gbpm_x_off(ibpm)
+ gbpm_y(ibpm) = (-gbpm_xprime(ibpm)+gbpm_yprime(ibpm))/sqrt(2.)+
+ & gbpm_y_off(ibpm)
+ enddo
+
+* calculate the mean over the last 'gbpm_sample' events
+
+ ibpm_sample = ibpm_sample+1
+ if(ibpm_sample.eq.gbpm_sample+1) ibpm_sample=1
+ do ibpm=1,n_use_bpms
+ bpm_meanx(ibpm) = bpm_meanx(ibpm) -
+ > bpm_x(ibpm,ibpm_sample) + gbpm_x(ibpm)
+ gbpm_meanx(ibpm) = bpm_meanx(ibpm)/gbpm_sample
+ bpm_x(ibpm,ibpm_sample) = gbpm_x(ibpm)
+ bpm_meany(ibpm) = bpm_meany(ibpm) -
+ > bpm_y(ibpm,ibpm_sample) + gbpm_y(ibpm)
+ gbpm_meany(ibpm) = bpm_meany(ibpm)/gbpm_sample
+ bpm_y(ibpm,ibpm_sample) = gbpm_y(ibpm)
+ enddo
+
+* csa 2/2/99 -- For the time being I am assuming that all three BPMs
+* are operational (with the exception that you can ignore H003 by
+* setting guse_bpmc to zero). Eventually it would be nice to make
+* the code automatically handle the case that one of the devices is
+* broken. I'm not sure how to robustly identify a failed bpm,
+* though.
+
+* We'll assume that the sigmas for the three BPMs are the
+* same (i.e., we give them equal weight), which simplifies
+* the math of the linear fit quite a bit.
+
+* Note that only mean bpm information is used here (not event-
+* to-event).
+
+ sum_x = 0.
+ sum_y = 0.
+ sum_z = 0.
+ sum_zx = 0.
+ sum_zy = 0.
+ sum_zz = 0.
+ do ibpm=1,n_use_bpms
+ sum_x = sum_x + gbpm_meanx(ibpm)
+ sum_y = sum_y + gbpm_meany(ibpm)
+ sum_z = sum_z + gbpm_zpos(ibpm)
+ sum_zx = sum_zx + gbpm_zpos(ibpm)*gbpm_meanx(ibpm)
+ sum_zy = sum_zx + gbpm_zpos(ibpm)*gbpm_meany(ibpm)
+ sum_zz = sum_zz + gbpm_zpos(ibpm)*gbpm_zpos(ibpm)
+ enddo
+
+ denom = sum_zz - sum_z*sum_z
+ if (abs(denom) .lt. small) denom = small
+ gbpm_beam_xp = (sum_zx - sum_x*sum_z)/denom
+ gbpm_beam_x = (sum_zz*sum_x - sum_zx*sum_z)/denom
+
+ gbpm_beam_yp = (sum_zy - sum_y*sum_z)/denom
+ gbpm_beam_y = (sum_zz*sum_y - sum_zy*sum_z)/denom
+
+* write(6,*)' g_anal_misc: sum_x/y/z =',sum_x,sum_y,sum_z
+* write(6,*)' g_anal_misc: sum_zx/zy/zz =',sum_zx,sum_zy,sum_zz
+* write(6,*)' g_anal_misc: gbpm_beam_x/y =',gbpm_beam_x,gbpm_beam_y
+
+ if(guse_bpm_in_recon.ne.0)then
+ gbeam_x = gbpm_beam_x
+ gbeam_xp = gbpm_beam_xp
+ gbeam_y = gbpm_beam_y
+ gbeam_yp = gbpm_beam_yp
+ else
+ gbeam_x = gbeam_xoff
+ gbeam_xp = gbeam_xpoff
+ gbeam_y = gbeam_yoff
+ gbeam_yp = gbeam_ypoff
+ endif
+ gbeam_x = gbeam_x - gspec_xoff
+ gbeam_xp = gbeam_xp - gspec_xpoff
+ gbeam_y = gbeam_y - gspec_yoff
+ gbeam_yp = gbeam_yp - gspec_ypoff
+
+* Fast Raster Signals:
+* ===================
+
+ gfrx_raw_adc = gmisc_dec_data(14,2)
+ gfry_raw_adc = gmisc_dec_data(16,2)
+
+* JRA: Code to check FR pedestals. Since the raster is a fixed frequency
+* and the pedestals come at a fixed rate, it is possible to keep getting
+* the same value for each pedestal event, and get the wrong zero value.
+* (see HCLOG #28325). So calculate pedestal from first 1000 REAL
+* events and compare to value from pedestal events. Error on each
+* measurement is RMS/sqrt(1000), error on diff is *sqrt(2), so 3 sigma
+* check is 3*sqrt(2)*RMS/sqrt(1000) = .13*RMS
+!
+! Can't use RMS, since taking sum of pedestal**2 for these signals
+! gives rollover for integer*4. Just assume signal is +/-2000
+! channels, gives sigma of 100 channels, so check for diff>130.
+!
+* Note: this is (for some reason) called for pedestal events as well,
+* so we need to start counting only after gfrx_adc_ped is set.
+
+ if (numfr.lt.1000 .and. gfrx_adc_ped.gt.1.0) then
+ numfr = numfr + 1
+ sumfrx = sumfrx + gfrx_raw_adc
+ sumfry = sumfry + gfry_raw_adc
+
+ if (numfr.eq.1000) then
+ avefrx = sumfrx / float(numfr)
+ avefry = sumfry / float(numfr)
+ if (abs(avefrx-gfrx_adc_ped).gt.130.) then
+ write(6,*) 'FRPED: peds give <frx>=',gfrx_adc_ped,
+ $ ' realevents give <frx>=',avefrx
+ endif
+ if (abs(avefry-gfry_adc_ped).gt.130.) then
+ write(6,*) 'FRPED: peds give <fry>=',gfry_adc_ped,
+ $ ' realevents give <fry>=',avefry
+ endif
+ endif
+
+ endif
+
+* calculate raster position from ADC value.
+
+ gfrx_adc = gfrx_raw_adc - gfrx_adc_ped
+ gfry_adc = gfry_raw_adc - gfry_adc_ped
+ gfrx_sync = gmisc_dec_data(13,2) - gfrx_sync_mean !sign gives sync phase
+ gfry_sync = gmisc_dec_data(15,2) - gfry_sync_mean
+
+* fast raster deflection on target is calculated in cm
+
+ if (guse_frdefault .ne. 0) then ! no phase correction
+ gfrx = (gfrx_adc/gfrx_adcpercm)*(gfr_cal_mom/gpbeam)
+ gfry = (gfry_adc/gfry_adcpercm)*(gfr_cal_mom/gpbeam)
+ else ! apply phase correction
+ normfrx = max(-1.0,min(1.0,(gfrx_adc/gfrx_adcmax)))
+ frxphase = asin(normfrx)
+ frxdphase = sign(1.,gfrx_sync-gfrx_synccut)*gfrx_dphase*degree
+ frxphase = frxphase + frxdphase
+ gfrx = sin(frxphase)*gfrx_maxsize
+
+ normfry = max(-1.0,min(1.0,(gfry_adc/gfry_adcmax)))
+ fryphase = asin(normfry)
+ frydphase = sign(1.,gfry_sync-gfry_synccut)*gfry_dphase*degree
+ fryphase = fryphase + frydphase
+ gfry = sin(fryphase)*gfry_maxsize
+ endif
+
+ gfrxp = gfrx/gfrx_dist
+ gfryp = gfry/gfry_dist
+
+ if (gusefr .ne. 0) then ! correct for raster
+ gbeam_x = gbeam_x + gfrx
+ gbeam_xp = gbeam_xp + gfrxp
+ gbeam_y = gbeam_y + gfry
+ gbeam_yp = gbeam_yp + gfryp
+ endif
+
+c figure out helicity from ADC signals:
+ if(gmisc_dec_data(1,2).gt.8000.and.gmisc_dec_data(2,2).lt.2000) then
+ gbeam_helicity_ADC = 1
+ else if(gmisc_dec_data(2,2).ge.8000.and.gmisc_dec_data(1,2).lt.2000) then
+ gbeam_helicity_ADC = -1
+ else
+ gbeam_helicity_ADC = 0
+ endif
+c write(*,*)gmisc_dec_data(1,2),gmisc_dec_data(2,2),
+c , gmisc_dec_data(2,2),gmisc_dec_data(1,2),gbeam_helicity_ADC
+
+
+c for now just trust the trigger supervisor more than the ADC which can be noisy
+
+ gbeam_helicity = gbeam_helicity_TS
+
+c write(*,*) 'h+ signal = ',gmisc_dec_data(1,2)
+c write(*,*) 'h- signal = ',gmisc_dec_data(2,2)
+
+
+* Slow Raster Signals: !!!!!! SLOTS NEED TO BE DETERMINED
+* ===================
+ gsrx_raw_adc = gmisc_dec_data(4,2) ! raw info matching MAP (reversed order)!
+ gsry_raw_adc = gmisc_dec_data(3,2)
+
+! 2nd copy of slow raster read out in Hall C (for use
+! when HMS and BETA re running stand-alone)
+ gsrx_raw_adc2 = gmisc_dec_data(24,2) ! raw info matching MAP (reversed order)!
+ gsry_raw_adc2 = gmisc_dec_data(26,2)
+
+c histrogram
+ if(gepid_slowrastx.gt.0)
+ > call hf1(gepid_slowrastx,gsrx_raw_adc,1.)
+ if(gepid_slowrasty.gt.0)
+ > call hf1(gepid_slowrasty,gsry_raw_adc,1.)
+ if(gepid_slowrastxy.gt.0)
+ > call hf2(gepid_slowrastxy,
+ > gsrx_raw_adc,gsry_raw_adc,1.)
+ if(gepid_slowrastxy2.gt.0)
+ > call hf2(gepid_slowrastxy2,
+ > gsrx_raw_adc2,gsry_raw_adc2,1.)
+
+ gsrx_adc = gsrx_raw_adc ! we do not want peds subtracted
+ gsry_adc = gsry_raw_adc
+
+c gsrx_adc = gsrx_raw_adc - gsrx_adc_ped
+c gsry_adc = gsry_raw_adc - gsry_adc_ped
+
+c commented this out, becuse (3,2) is used for slow raster, and
+c (5,2) is
+c gsrx_sync = gmisc_dec_data(3,2)! - gsrx_sync_mean
+c gsry_sync = gmisc_dec_data(5,2)! - gsry_sync_mean
+
+
+ return
+ end
diff --git a/ENGINE/g_analyze_pedestal.f b/ENGINE/g_analyze_pedestal.f
new file mode 100644
index 0000000..fd3c5ba
--- /dev/null
+++ b/ENGINE/g_analyze_pedestal.f
@@ -0,0 +1,64 @@
+ subroutine g_analyze_pedestal(ABORT,err)
+*
+* $Log: g_analyze_pedestal.f,v $
+* Revision 1.2.24.1.2.2 2008/10/26 19:12:33 cdaq
+* SEM
+*
+* Revision 1.2.24.1.2.1 2008/05/15 18:59:21 bhovik
+* 1'st version
+*
+* Revision 1.2.24.1 2007/05/15 02:55:01 jones
+* Start to Bigcal code
+*
+* Revision 1.2 1996/01/22 15:09:24 saw
+* (JRA) Add call to g_analyze_beam_pedestal
+*
+* Revision 1.1 1995/04/01 19:36:55 cdaq
+* Initial revision
+*
+*
+ implicit none
+*
+ character*18 here
+ parameter (here='g_analyze_pedestal')
+*
+ logical ABORT
+ character*(*) err
+*
+ call g_analyze_beam_pedestal(ABORT,err)
+ if(ABORT) then
+ call G_add_path(here,err)
+ return
+ endif
+*
+ call h_analyze_pedestal(ABORT,err)
+ if(ABORT) then
+ call G_add_path(here,err)
+ return
+ endif
+*
+ call b_analyze_pedestal(ABORT,err) ! bigcal
+ if(ABORT) then
+ call G_add_path(here,err)
+ return
+ endif
+*
+ call sane_analyze_pedestal(ABORT,err) ! bigcal
+ if(ABORT) then
+ call G_add_path(here,err)
+ return
+ endif
+ call sem_analyze_pedestal(ABORT,err) ! bigcal
+ if(ABORT) then
+ call G_add_path(here,err)
+ return
+ endif
+*
+ call s_analyze_pedestal(ABORT,err)
+ if(ABORT) then
+ call G_add_path(here,err)
+ return
+ endif
+*
+ return
+ end
diff --git a/ENGINE/g_analyze_scaler_bank.f b/ENGINE/g_analyze_scaler_bank.f
new file mode 100644
index 0000000..9f1b2cf
--- /dev/null
+++ b/ENGINE/g_analyze_scaler_bank.f
@@ -0,0 +1,387 @@
+ subroutine g_analyze_scaler_bank(event,roc,ABORT,err)
+*
+* $Log: g_analyze_scaler_bank.f,v $
+* Revision 1.4.14.2.2.6 2011/02/25 20:24:28 jones
+* Fix problem with scaler(503) . It should be 1MHz but before
+* run 72476 it was 0.998MHz. This 0.998 Mhz clock was also
+* going into the helicity plus and minus scalers ( 516 and 515).
+* To get the charge for plus and minus need the fraction of time
+* for each. Use the scaler(174) which is another 1MHz clock
+* for the absolute time. Then scale the time by ratio of
+* 516/503 or 515/503 to get the time for the plus and minus
+* helicity.
+*
+* Revision 1.4.14.2.2.5 2009/11/11 16:22:00 jones
+* Switch to
+* delta_time_help = max(gscaler_change(516)/gclock_rate,.0001D00)
+* delta_time_helm = max(gscaler_change(515)/gclock_rate,.0001D00)
+*
+* Revision 1.4.14.2.2.4 2009/11/04 15:34:05 jones
+* Call scalers 514 and 518 helicity plus and 513 and 517 helicity minus
+*
+* Revision 1.4.14.2.2.3 2009/11/04 15:10:38 jones
+* Fill new variable g_run_time_beam_on
+*
+* Revision 1.4.14.2.2.2 2009/09/29 13:57:19 jones
+* 1) Add variables for calculating charge asymmetry
+* 2) For runs between 72476 to 72588 calculate the time for each helicity using 0.4926*(total time) instead of direct scaler measurement since there was a problem with the clock signal going to downstairs scalers.
+*
+* Revision 1.4.14.2.2.1 2009/09/02 13:34:35 jones
+* add variable charge_ch
+*
+* Revision 1.4.14.2 2007/11/09 17:17:09 cdaq
+* added ability to read roc21 scalers
+*
+* Revision 1.4.14.1 2007/09/10 20:33:37 pcarter
+* Implemented changes to allow compilation on RHEL 3,4,5 and MacOSX
+*
+* Revision 1.4 2004/05/11 18:31:22 jones
+* If using syncfilter and time between scaler reads is larger than 2.5 seconds
+* then set "skip_event" to true so that g_beam_on_run_time and g_beam_on_bcm_charge are not updated and events are skipped
+* in engine.
+*
+* Revision 1.3 2003/09/05 20:54:28 jones
+* Merge in online03 changes (mkj)
+*
+* Revision 1.2.2.3 2003/09/04 20:42:17 jones
+* Changes to run with syncfilter (mkj)
+*
+* Revision 1.2.2.2 2003/08/14 00:40:09 cdaq
+* Modify so "beam on" scalers for both bcm1 and bcm2 (mkj)
+*
+* Revision 1.2.2.1 2003/04/14 18:05:37 jones
+* Modified to skip first scaler event. gscaler is sum from first scaler event.
+*
+* Revision 1.2 1999/11/04 20:35:14 saw
+* Linux/G77 compatibility fixes
+*
+* Revision 1.1 1999/02/24 15:19:14 saw
+* Bring into CVS tree
+*
+
+ implicit none
+ save
+ external jishft, jiand, jieor
+ integer*4 event(*)
+ integer*4 roc
+*
+ character*17 here
+ parameter (here='g_analyze_scaler_bank')
+*
+ logical ABORT
+ character*(*) err
+*
+ INCLUDE 'gen_scalers.cmn'
+ INCLUDE 'gen_run_info.cmn'
+ INCLUDE 'gen_filenames.cmn'
+ INCLUDE 'sane_ntuple.cmn'
+*
+ integer ind
+ integer*4 cratenum ! 1=hms,2=sos
+ real*8 realscal
+ logical update_bcms
+ logical update_helicity_bcms
+ integer analyzed_events(0:15)
+ common /aevents/ analyzed_events
+*
+ integer*4 jiand, jishft, jieor ! Declare to help f2c
+*
+* Scaler events have a header in from of each scaler. High 16 bits
+* will contain the address (the switch settings). Address for hall C
+* will be of the form DANN, where NN is the scaler number. The low 16
+* bits will contain the number of scaler values to follow (this should
+* be no larger than 16, but we will allow more.)
+*
+*
+* NOTE that the variables gscaler(i) is REAL!!!!!
+* this is so that we can record the correct value when the
+* hardware scalers (32 bit <> I*4) overflow.
+*
+
+ integer evtype, evnum, evlen, pointer
+ integer scalid, countinmod, address, counter,ii
+*
+* Temporary variables for beam current and charge calculations
+*
+ real*8 ave_current_unser
+ real*8 delta_time,delta_time_help,delta_time_helm
+
+*
+* Find if hms or sos scaler event (assumes first HMS scaler is DA01).
+* write(6,'("Scaler event: event(3)=",9z)') event(3)
+ if (jieor(jiand(jishft(event(3),-16),'FFFF'X),'DA01'X).eq.0) then !first scaler
+ cratenum=1 !hms
+ else
+ cratenum=2 !sos
+ endif
+*
+ evtype = jishft(event(2),-16)
+ evnum = jiand(event(2),'FF'x) ! last 2 bytes give event number (mod 256)
+*
+* evnum is mod(256), so must reset lastevnum for rollover
+c Disable out of order detection since it should no longer happen.
+c if (evnum.eq.0 .and. gscal_lastevnum(cratenum).gt.200) then
+c gscal_lastevnum(cratenum)=0
+c else if (evnum.le.gscal_lastevnum(cratenum)) then
+c write(6,*) 'STATUS: skipping outoforder scaler event:',
+c & ' crate,oldevnum,newevnum=',cratenum,
+c & gscal_lastevnum(cratenum),evnum
+c return
+c endif
+*
+ gscal_lastevnum(cratenum)=evnum
+*
+* Should check against list of known scaler events
+*
+ evlen = event(1) + 1
+ update_bcms = .false.
+ update_helicity_bcms = .false.
+ if(evlen.gt.3) then ! We have a scaler bank
+ pointer = 3
+*
+ do while(pointer.lt.evlen)
+*
+ scalid = jiand(jishft(event(pointer),-16),'FF'x)
+ countinmod = jiand(event(pointer),'FFFF'x)
+ if(jieor(jiand(event(pointer),'FF000000'x),'DA000000'x).eq.0) then
+c Old style header with scaler ID @ 00FF0000
+ scalid = jiand(jishft(event(pointer),-16),'FF'x)
+ address = scalid*16
+*
+* Might want to check that count is not to big.
+*
+* if(countinmod.gt.16) then
+ if(countinmod.gt.32) then
+ err = 'Scaler module header word has count<>16'
+ ABORT = .true.
+ call g_add_path(here,err)
+ return ! Safest action
+ endif
+ else
+c
+c New style header with scaler ID @ FFF?0000
+c (If ? is non zero, it means we are starting in the middle of a scaler)
+c Allows for non multiple of 16 address starts
+c
+ address = jishft(event(pointer),-16)
+ if (roc .eq. 21) address = address + 230
+*
+* Might want to check that count is not to big.
+*
+* if(countinmod.gt.16) then
+ if(countinmod.gt.32) then
+ err = 'Scaler module header word has count >16'
+ ABORT = .true.
+ call g_add_path(here,err)
+ return ! Safest action
+ endif
+ endif
+*
+ccccc address = scalid*16
+ do counter = 1,countinmod
+ ind=address+counter
+ realscal=dfloat(event(pointer+counter))
+ if (ind.eq.gbcm1_index) update_bcms=.true. !assume bcms in same crate
+c
+c For Gen (7/1998) it is noticed that some scaler channels are randomly
+c clearing themselves. The following is a lame hack to detect and correct
+c this random clearing.
+c
+ if(gscalweirdcorrect_flag.eq.1) then ! Look for random clears
+ if(event(pointer+counter).gt.0) then ! Really saying < 2**31
+ if(gscalweird_lastval(ind).gt.event(pointer+counter)) then
+ gscalweird_nclears(ind) = gscalweird_nclears(ind) + 1
+ gscalweird_lostcounts(ind) = gscalweird_lostcounts(ind)
+ $ + gscalweird_lastval(ind)
+c
+c If the longint scaler value is negative, but close to 0 (which means that
+c it is really >> 2**31), then we will get to a point where we can't tell the
+c difference between an overflow and a random clear. But if a channel is
+c getting random clears too much, then the channel will never get to 2**31
+c anyway. For now, let's assume that nothing counts faster than 5Mhz and that
+c scalers are read out every 5 seconds, and then round that up to
+c 2^25=33554432. So if a scaler apparantly overflows, but jumps by more than
+c 2^25, we assume it was a false clear. We could be cleverer and use some
+c intellegence to characterize the typical rate of each channel, but let's
+c not get carried away.
+c
+ else if (gscalweird_lastval(ind).lt.0 .and.
+ $ (event(pointer+counter)-gscalweird_lastval(ind))
+ $ .gt.33554432) then
+ gscalweird_nclears(ind) = gscalweird_nclears(ind) + 1
+ gscalweird_lostcounts(ind) = gscalweird_lostcounts(ind)
+ $ + gscalweird_lastval(ind)
+ endif
+ endif
+ gscalweird_lastval(ind) = event(pointer+counter)
+ endif
+* Save scaler value from previous scaler event:
+
+* write(101,*) 'scaler index=',ind
+c gscaler_old(ind) = gscaler(ind)
+c
+ if ( analyzed_events(0) .eq. 1) then
+ gscaler_old(ind) = 0
+ gscaler(ind) = 0
+ endif
+c
+ if (realscal.lt.-0.5) then
+ realscal=realscal+4294967296.
+ endif
+ if ( (realscal+dfloat(gscaler_nroll(ind))*4294967296.
+ $ +gscalweird_lostcounts(ind)) .lt. gscaler(ind) ) then
+ ! 2**32 = 4.295e+9
+ !32 bit scaler rolled over.
+ gscaler_nroll(ind)=gscaler_nroll(ind)+1
+ endif
+c gscaler(ind) = realscal + gscaler_nroll(ind)*4294967296.
+c $ + gscalweird_lostcounts(ind)
+* Calculate difference between current scaler value and previous value:
+c gscaler_change(ind) = gscaler(ind) - gscaler_old(ind)
+ if ( analyzed_events(0) .gt. 1) then
+ gscaler_change(ind) = realscal + gscaler_nroll(ind)*4294967296.
+ $ + gscalweird_lostcounts(ind) - gscaler_old(ind)
+ gscaler(ind) = gscaler_change(ind) + gscaler(ind)
+ endif
+ gscaler_old(ind) = realscal + gscaler_nroll(ind)*4294967296.
+ $ + gscalweird_lostcounts(ind)
+ enddo
+ pointer = pointer + countinmod + 1 ! Add 17 to pointer
+ enddo
+ else
+c err = 'Event not big enough to contain scalers'
+c ABORT = .true.
+c call g_add_path(here,err)
+c
+c Not all banks will have scaler data every event. Don't generate the
+c error any more. (saw 20.6.1998)
+c
+ return
+ endif
+*
+* Calculate beam current and charge between scaler events
+
+ if (update_bcms .and. analyzed_events(0) .gt. 1) then
+c
+ g_run_time = g_run_time + max(0.001D00,gscaler_change(gclock_index)/gclock_rate)
+ delta_time = max(gscaler_change(gclock_index)/gclock_rate,.0001D00)
+ delta_time_help = max(gscaler_change(516)/gclock_rate,.0001D00)
+ delta_time_helm = max(gscaler_change(515)/gclock_rate,.0001D00)
+ if (gen_run_number .lt. 72476) then
+ delta_time_help =delta_time*gscaler_change(516)/gscaler_change(503)
+ delta_time_helm =delta_time*gscaler_change(515)/gscaler_change(503)
+ endif
+ if ( gen_run_number .ge. 72476 .and. gen_run_number .le. 72588) then ! period when problem with clock signal
+ delta_time_help = 0.4926*delta_time
+ delta_time_helm = 0.4926*delta_time
+ endif
+c
+ skip_events = .false.
+ if (syncfilter_on .and. delta_time .gt. 2.5 ) then
+ write(*,*) ' Skip events for
+ > this scaler read since delta_time = ',delta_time
+ skip_events = .true.
+ endif
+c
+ ave_current_bcm(1) = gbcm1_gain*((gscaler_change(gbcm1_index)
+ & /delta_time) - gbcm1_offset)
+ ave_current_bcm(2) = gbcm2_gain*((gscaler_change(gbcm2_index)
+ & /delta_time) - gbcm2_offset)
+ ave_current_bcm_help(1) = gbcm1_gain*((gscaler_change(514)
+ & /delta_time_help) - gbcm1_offset)
+ ave_current_bcm_help(2) = gbcm2_gain*((gscaler_change(518)
+ & /delta_time_help) - gbcm2_offset)
+ ave_current_bcm_helm(1) = gbcm1_gain*((gscaler_change(513)
+ & /delta_time_helm) - gbcm1_offset)
+ ave_current_bcm_helm(2) = gbcm2_gain*((gscaler_change(517)
+ & /delta_time_helm) - gbcm2_offset)
+ ave_current_bcm(3) = gbcm3_gain*((gscaler_change(gbcm3_index)
+ & /delta_time) - gbcm3_offset)
+ ave_current_unser = gunser_gain*((gscaler_change(gunser_index)
+ & /delta_time) - gunser_offset)
+
+
+ charge_ch=.FALSE.
+ if (delta_time.gt.0.0001) then
+ charge_ch=.TRUE.
+
+ gbcm1_charge = gbcm1_charge + ave_current_bcm(1)*delta_time
+ gbcm2_charge = gbcm2_charge + ave_current_bcm(2)*delta_time
+ gbcm1_charge_help = gbcm1_charge_help + ave_current_bcm_help(1)*delta_time_help
+ gbcm2_charge_help = gbcm2_charge_help + ave_current_bcm_help(2)*delta_time_help
+ gbcm1_charge_helm = gbcm1_charge_helm + ave_current_bcm_helm(1)*delta_time_helm
+ gbcm2_charge_helm = gbcm2_charge_helm + ave_current_bcm_helm(2)*delta_time_helm
+ gbcm3_charge = gbcm3_charge + ave_current_bcm(3)*delta_time
+ gunser_charge = gunser_charge + ave_current_unser*delta_time
+
+*
+* Check for the beam on condition, and update beam on variables if needed.
+*
+* We will use bcm1 for now as it is zero seems more stable. This could change.
+*
+* write(6,*) "Checking threshold..."
+ if (ave_current_bcm(1) .ge. g_beam_on_thresh_cur(1) .and. insync .eq. 0 .and. .not. skip_events) then
+ g_beam_on_run_time(1) = g_beam_on_run_time(1) + delta_time
+ g_beam_on_bcm_charge(1) = g_beam_on_bcm_charge(1)
+ $ + ave_current_bcm(1)*delta_time
+ g_beam_on_run_time_help(1) = g_beam_on_run_time_help(1) + delta_time_help
+ g_beam_on_bcm_charge_help(1) = g_beam_on_bcm_charge_help(1)
+ $ + ave_current_bcm_help(1)*delta_time_help
+ g_beam_on_run_time_helm(1) = g_beam_on_run_time_helm(1) + delta_time_helm
+ g_beam_on_bcm_charge_helm(1) = g_beam_on_bcm_charge_helm(1)
+ $ + ave_current_bcm_helm(1)*delta_time_helm
+* write(6,*) "above threshold (",ave_current_bcm1,")"
+ endif
+ if (ave_current_bcm(2) .ge. g_beam_on_thresh_cur(2) .and. insync .eq. 0 .and. .not. skip_events) then
+ g_beam_on_run_time(2) = g_beam_on_run_time(2) + delta_time
+ g_beam_on_bcm_charge(2) = g_beam_on_bcm_charge(2)
+ $ + ave_current_bcm(2)*delta_time
+ g_beam_on_run_time_help(2) = g_beam_on_run_time_help(2) + delta_time_help
+ g_beam_on_bcm_charge_help(2) = g_beam_on_bcm_charge_help(2)
+ $ + ave_current_bcm_help(2)*delta_time_help
+ g_beam_on_run_time_helm(2) = g_beam_on_run_time_helm(2) + delta_time_helm
+ g_beam_on_bcm_charge_helm(2) = g_beam_on_bcm_charge_helm(2)
+ $ + ave_current_bcm_helm(2)*delta_time_helm
+ endif
+ g_run_time_beam_on = g_beam_on_run_time(bcm_for_threshold_cut)
+*
+ gscaler_event_num = gscaler_event_num + 1
+
+* Write out pertinent charge scaler rates for each scaler event.
+
+ if (g_charge_scaler_filename.ne.' ' .and. ave_current_bcm(1) .ge. g_beam_on_thresh_cur(1)) then
+c write(G_LUN_CHARGE_SCALER,1001) gscaler_event_num, !scaler event num
+c & gscaler_change(gunser_index)/delta_time, !scaler rate(Hz)
+c & gscaler_change(gbcm1_index)/delta_time, !scaler rate(Hz)
+c & gscaler_change(gbcm2_index)/delta_time, !scaler rate(Hz)
+c & gscaler_change(gbcm3_index)/delta_time, !scaler rate(Hz)
+c & delta_time !time since last scaler event (sec)
+ write(G_LUN_CHARGE_SCALER,1001) gscaler_event_num, !scaler event num
+ > g_beam_on_bcm_charge(1),g_beam_on_bcm_charge_help(1),g_beam_on_bcm_charge_helm(1),
+ > (g_beam_on_bcm_charge_help(1)
+ > +g_beam_on_bcm_charge_helm(1))/g_beam_on_bcm_charge(1),
+ > g_beam_on_bcm_charge_help(1)/g_beam_on_bcm_charge(1),
+ > g_beam_on_bcm_charge_helm(1)/g_beam_on_bcm_charge(1),
+ > ave_current_bcm(1)*delta_time, ave_current_bcm_help(1)*delta_time_help,
+ > ave_current_bcm_helm(1)*delta_time_helm,
+ > (ave_current_bcm_help(1)*delta_time_help
+ >+ave_current_bcm_helm(1)*delta_time_helm)/(ave_current_bcm(1)*delta_time),
+ > delta_time,delta_time_help,delta_time_helm,
+ > (delta_time_help+delta_time_helm)/delta_time,
+ > g_beam_on_run_time_help(1)/g_beam_on_run_time(1),g_beam_on_run_time_helm(1)/g_beam_on_run_time(1),
+ > (g_beam_on_run_time_help(1)+g_beam_on_run_time_helm(1))/g_beam_on_run_time(1)
+ endif
+ endif
+
+ endif
+
+
+
+*
+* 1001 format(i6,4f13.2,f12.6)
+ 1001 format(i6,17(1x,f8.5))
+
+ return
+ end
+
+
diff --git a/ENGINE/g_analyze_scalers.f b/ENGINE/g_analyze_scalers.f
new file mode 100644
index 0000000..a9b4477
--- /dev/null
+++ b/ENGINE/g_analyze_scalers.f
@@ -0,0 +1,269 @@
+ subroutine g_analyze_scalers(event,ABORT,err)
+*
+* $Log: g_analyze_scalers.f,v $
+* Revision 1.15.20.1.2.1 2009/09/02 13:36:59 jones
+* add variable charge_ch
+*
+* Revision 1.15.20.1 2007/09/10 20:33:37 pcarter
+* Implemented changes to allow compilation on RHEL 3,4,5 and MacOSX
+*
+* Revision 1.15 2003/09/05 20:54:41 jones
+* Merge in online03 changes (mkj)
+*
+* Revision 1.14.2.2 2003/08/14 00:40:09 cdaq
+* Modify so "beam on" scalers for both bcm1 and bcm2 (mkj)
+*
+* Revision 1.14.2.1 2003/04/11 13:25:11 cdaq
+* Remove old hardwire check on run number
+*
+* Revision 1.14 1999/11/04 20:35:14 saw
+* Linux/G77 compatibility fixes
+*
+* Revision 1.13 1999/02/10 18:17:21 csa
+* Added beam-on calculations (D. McKee)
+*
+* Revision 1.12 1996/11/05 20:45:02 saw
+* (SAW) Use parameter for G_LUN_CHARGE_SCALER instead of hard coded #
+*
+* Revision 1.11 1996/09/04 14:31:53 saw
+* (JRA) Update BCM calculations
+*
+* Revision 1.10 1996/04/29 19:41:57 saw
+* (JRA) Deal with out of order scaler events
+*
+* Revision 1.9 1996/01/22 15:10:03 saw
+* (JRA) Extract event number from scaler events
+*
+* Revision 1.8 1996/01/16 18:39:17 cdaq
+* (CB,SAW) Add current monitor calculations. Make compatible with SAW's new
+* scaler header format.
+*
+* Revision 1.7 1995/10/09 17:55:32 cdaq
+* (JRA) Add arrays for previous scalers and differences from previous scalers
+*
+* Revision 1.6 1995/09/01 13:41:25 cdaq
+* (JRA) Calculate time of run
+*
+* Revision 1.5 1995/07/27 19:04:54 cdaq
+* (SAW) Use specific bit manipulation routines for f2c compatibility
+*
+* Revision 1.4 1995/04/06 20:04:33 cdaq
+* (JRA) Handle overflows and save them in real variables
+*
+* Revision 1.3 1994/07/07 15:24:24 cdaq
+* (SAW) Fix bugs
+*
+c Revision 1.2 1994/07/07 15:23:16 cdaq
+c (SAW) Correct pointers for actual bank structure
+c
+c Revision 1.1 1994/06/22 21:02:17 cdaq
+c Initial revision
+c
+*
+ implicit none
+ save
+ external jishft, jiand, jieor
+ integer*4 event(*)
+*
+ character*17 here
+ parameter (here='g_analyze_scalers')
+*
+ logical ABORT
+ character*(*) err
+*
+ INCLUDE 'gen_scalers.cmn'
+ INCLUDE 'gen_run_info.cmn'
+ INCLUDE 'gen_filenames.cmn'
+ INCLUDE 'sane_ntuple.cmn'
+*
+ integer ind
+ integer*4 cratenum ! 1=hms,2=sos
+ real*8 realscal
+ logical update_bcms
+*
+ integer*4 jiand, jishft, jieor ! Declare to help f2c
+*
+* Scaler events have a header in from of each scaler. High 16 bits
+* will contain the address (the switch settings). Address for hall C
+* will be of the form DANN, where NN is the scaler number. The low 16
+* bits will contain the number of scaler values to follow (this should
+* be no larger than 16, but we will allow more.)
+*
+*
+* NOTE that the variables gscaler(i) is REAL!!!!!
+* this is so that we can record the correct value when the
+* hardware scalers (32 bit <> I*4) overflow.
+*
+
+ integer evtype, evnum, evlen, pointer
+ integer scalid, countinmod, address, counter
+*
+* Temporary variables for beam current and charge calculations
+*
+ real*8 ave_current_bcm1, ave_current_bcm2, ave_current_bcm3
+ real*8 ave_current_unser
+ real*8 delta_time
+*
+* Find if hms or sos scaler event (assumes first HMS scaler is DA01).
+ if (jieor(jiand(jishft(event(3),-16),'FFFF'X),'DA01'X).eq.0) then !first scaler
+ cratenum=1 !hms
+ else
+ cratenum=2 !sos
+ endif
+*
+ evtype = jishft(event(2),-16)
+ evnum = jiand(event(2),'FF'x) ! last 2 bytes give event number (mod 256)
+*
+* evnum is mod(256), so must reset lastevnum for rollover
+ if (evnum.eq.0 .and. gscal_lastevnum(cratenum).gt.200) then
+ gscal_lastevnum(cratenum)=0
+ else if (evnum.le.gscal_lastevnum(cratenum)) then
+ write(6,*) 'STATUS: skipping outoforder scaler event:',
+ & ' crate,oldevnum,newevnum=',cratenum,
+ & gscal_lastevnum(cratenum),evnum
+ return
+ endif
+*
+ gscal_lastevnum(cratenum)=evnum
+*
+* Should check against list of known scaler events
+*
+ evlen = event(1) + 1
+ update_bcms = .false.
+ if(evlen.gt.3) then ! We have a scaler bank
+ pointer = 3
+*
+ do while(pointer.lt.evlen)
+*
+ scalid = jiand(jishft(event(pointer),-16),'FF'x)
+ countinmod = jiand(event(pointer),'FFFF'x)
+ if(jieor(jiand(event(pointer),'FF000000'x),'DA000000'x).eq.0) then
+c Old style header with scaler ID @ 00FF0000
+ scalid = jiand(jishft(event(pointer),-16),'FF'x)
+ address = scalid*16
+*
+* Might want to check that count is not to big.
+*
+ if(countinmod.ne.16) then
+ err = 'Scaler module header word has count<>16'
+ ABORT = .true.
+ call g_add_path(here,err)
+ return ! Safest action
+ endif
+ else
+c
+c New style header with scaler ID @ FFF?0000
+c (If ? is non zero, it means we are starting in the middle of a scaler)
+c Allows for non multiple of 16 address starts
+c
+ address = jishft(event(pointer),-16)
+*
+* Might want to check that count is not to big.
+*
+ if(countinmod.gt.16) then
+ err = 'Scaler module header word has count >16'
+ ABORT = .true.
+ call g_add_path(here,err)
+ return ! Safest action
+ endif
+ endif
+*
+ address = scalid*16
+ do counter = 1,countinmod
+ ind=address+counter
+ realscal=dfloat(event(pointer+counter))
+ if (ind.eq.gbcm1_index) update_bcms=.true. !assume bcms in same crate
+
+* Save scaler value from previous scaler event:
+ gscaler_old(ind) = gscaler(ind)
+
+ if (realscal.lt.-0.5) then
+ realscal=realscal+4294967296.
+ endif
+ if ( (realscal+dfloat(gscaler_nroll(ind))*4294967296.) .ge.
+ & gscaler(ind) ) then ! 2**32 = 4.295e+9
+ gscaler(ind) = realscal + gscaler_nroll(ind)*4294967296.
+ else !32 bit scaler rolled over.
+ gscaler_nroll(ind)=gscaler_nroll(ind)+1
+ gscaler(ind) = realscal + gscaler_nroll(ind)*4294967296.
+ endif
+* Calculate difference between current scaler value and previous value:
+ gscaler_change(ind) = gscaler(ind) - gscaler_old(ind)
+ enddo
+ pointer = pointer + countinmod + 1 ! Add 17 to pointer
+ enddo
+ else
+ err = 'Event not big enough to contain scalers'
+ ABORT = .true.
+ call g_add_path(here,err)
+ return
+ endif
+
+* calculate time of run (must not be zero to avoid div. by zero).
+ g_run_time = max(0.001D00,gscaler(gclock_index)/gclock_rate)
+
+* Calculate beam current and charge between scaler events
+
+ if (update_bcms) then ! can't assume in hms crate, moved for some runs
+
+ delta_time = max(gscaler_change(gclock_index)/gclock_rate,.0001D00)
+
+ ave_current_bcm1 = gbcm1_gain*((gscaler_change(gbcm1_index)
+ & /delta_time) - gbcm1_offset)
+ ave_current_bcm3 = gbcm3_gain*((gscaler_change(gbcm3_index)
+ & /delta_time) - gbcm3_offset)
+ ave_current_unser = gunser_gain*((gscaler_change(gunser_index)
+ & /delta_time) - gunser_offset)
+
+ ave_current_bcm2 = gbcm2_gain*((gscaler_change(gbcm2_index)
+ & /delta_time) - gbcm2_offset)
+*
+* Remove old, hardwired check on run number.
+*
+* if (gen_run_number.le.6268) then
+* ave_current_bcm2 = gbcm2_gain*sqrt(max(0.0D00,
+* & (gscaler_change(gbcm2_index)/delta_time)-gbcm2_offset))
+* else
+* ave_current_bcm2 = gbcm2_gain*((gscaler_change(gbcm2_index)
+* & /delta_time) - gbcm2_offset)
+* endif
+ charge_ch=.FALSE.
+ if (delta_time.gt.0.0001) then
+ charge_ch = .TRUE.
+ gbcm1_charge = gbcm1_charge + ave_current_bcm1*delta_time
+ gbcm2_charge = gbcm2_charge + ave_current_bcm2*delta_time
+ gbcm3_charge = gbcm3_charge + ave_current_bcm3*delta_time
+ gunser_charge = gunser_charge + ave_current_unser*delta_time
+
+* Check for the "beam on" condition, and update "beam on" variables
+* if needed. I'm only using bcm2 (the current "best" bcm) right
+* now. This could be changed or added to.
+
+ if (ave_current_bcm2 .ge. g_beam_on_thresh_cur(2)) then
+ g_beam_on_run_time(2) = g_beam_on_run_time(2) + delta_time
+ g_beam_on_bcm_charge(2) = g_beam_on_bcm_charge(2) + ave_current_bcm2*delta_time
+ endif
+ if (ave_current_bcm1 .ge. g_beam_on_thresh_cur(1)) then
+ g_beam_on_run_time(1) = g_beam_on_run_time(1) + delta_time
+ g_beam_on_bcm_charge(1) = g_beam_on_bcm_charge(1) + ave_current_bcm1*delta_time
+ endif
+
+ gscaler_event_num = gscaler_event_num + 1
+
+* Write out pertinent charge scaler rates for each scaler event.
+
+ if (g_charge_scaler_filename.ne.' ') then
+ write(G_LUN_CHARGE_SCALER,1001) gscaler_event_num, !scaler event num
+ & gscaler_change(gunser_index)/delta_time, !scaler rate(Hz)
+ & gscaler_change(gbcm1_index)/delta_time, !scaler rate(Hz)
+ & gscaler_change(gbcm2_index)/delta_time, !scaler rate(Hz)
+ & gscaler_change(gbcm3_index)/delta_time, !scaler rate(Hz)
+ & delta_time !time since last scaler event (sec)
+ endif
+ endif
+ endif
+
+ 1001 format(i6,4f13.2,f12.6)
+
+ return
+ end
diff --git a/ENGINE/g_analyze_scalers_by_banks.f b/ENGINE/g_analyze_scalers_by_banks.f
new file mode 100644
index 0000000..3ae8b29
--- /dev/null
+++ b/ENGINE/g_analyze_scalers_by_banks.f
@@ -0,0 +1,121 @@
+ subroutine g_analyze_scalers_by_banks(event,ABORT, err)
+*-----------------------------------------------------------------------
+*- Purpose and Methods: Pull out individual scaler banks from event
+*- for subsequent analysis
+*-
+*- Find the beginning of each ROC bank and send it off to
+*- "g_analyze_scaler_bank".
+*-
+*- Inputs:
+*- event Pointer to the first word (length) of an event data bank.
+*-
+*- Outputs:
+*- ABORT success or failure
+*- err explanation for failure
+*-
+*- Created 20-Jun-1998 Stephen Wood
+*- $Log: g_analyze_scalers_by_banks.f,v $
+*- Revision 1.2.24.2 2007/11/09 17:17:15 cdaq
+*- added ability to read roc21 scalers
+*-
+*- Revision 1.2.24.1 2007/09/10 20:33:37 pcarter
+*- Implemented changes to allow compilation on RHEL 3,4,5 and MacOSX
+*-
+*- Revision 1.2 1999/11/04 20:35:15 saw
+*- Linux/G77 compatibility fixes
+*-
+*- Revision 1.1 1999/02/24 15:04:41 saw
+*- Bring into CVS tree
+*-
+*-----------------------------------------------------------------------
+ IMPLICIT NONE
+ SAVE
+ external jishft, jiand, jieor
+*
+ integer*4 event(*)
+*
+ character*30 here
+ parameter (here= 'g_analyze_scalers_by_banks')
+*
+ logical ABORT
+ character*(*) err
+ integer*4 evlength ! Total length of the event
+ integer*4 bankpointer ! Pointer to next bank
+ integer*4 jiand,jishft,jieor ! Declare to help f2c
+ integer*4 roc
+*
+ include 'gen_data_structures.cmn'
+ INCLUDE 'gen_scalers.cmn'
+ INCLUDE 'gen_run_info.cmn'
+ include 'insane_scalers.cmn' ! WHIT's InSANE HACK
+ include 'gen_event_info.cmn'
+*
+ integer analyzed_events(0:15)
+ common /aevents/ analyzed_events
+ integer*4 i_insane
+*
+ logical WARN
+*
+*-----------------------------------------------------------------------
+*
+*
+* Assume that the event is bank containing banks, the first of which is
+* an event ID bank.
+*
+* Various hex constants that are used in decode routines should
+* probably be put in an include file.
+*
+
+ ABORT = jieor(jiand(event(2),'FFFF'x),'10CC'x).ne.0
+ if(ABORT) then
+ err = here//'Event header not standard physics event'
+ return
+ endif
+
+ evlength = event(1)
+ bankpointer = 3
+
+ ABORT = jieor(event(bankpointer+1),'C0000100'x).ne.0
+ if(ABORT) then
+ err = here//'First bank is not an Event ID bank'
+ return
+ endif
+
+ bankpointer = bankpointer + event(bankpointer) + 1
+
+ WARN = (bankpointer.gt.evlength) ! No ROC's in event
+ IF(WARN) THEN
+ err= ':event contained no ROC banks'
+ call G_add_path(here,err)
+ ENDIF
+
+ do while(bankpointer.lt.evlength)
+ roc = jiand(jishft(event(bankpointer+1),-16),'1F'X)
+ if(roc.eq.5.or.roc.eq.8.or.roc.eq.20.or.roc.eq.21) then
+ call g_analyze_scaler_bank(event(bankpointer),roc, ABORT, err)
+ endif
+ bankpointer = bankpointer + event(bankpointer) + 1
+
+ enddo
+
+ WARN = bankpointer.eq.(evlength + 1)
+ if(WARN) THEN
+ err = ':inconsistent bank and event lengths'
+ call G_add_path(here,err)
+ endif
+*
+
+ if(analyzed_events(0) .gt. 0 ) then
+! insane_last_event_id=gen_event_ID_number
+ write(215,'(I10,$)') INT(gen_event_ID_number)
+ write(215,'(I10,$)') INT(g_run_time)
+ write(215,*) (INT(gscaler_change(i_insane)), i_insane=1, 582)
+! write(215,*) (INT(gscaler_change(i_insane)), i_insane=231,582)
+! write(215,*) (INT(gscaler_change(i_insane)), i_insane=170,230)
+ endif
+
+ RETURN
+ END
+
+
+
diff --git a/ENGINE/g_apply_offsets.f b/ENGINE/g_apply_offsets.f
new file mode 100644
index 0000000..39f2120
--- /dev/null
+++ b/ENGINE/g_apply_offsets.f
@@ -0,0 +1,59 @@
+ SUBROUTINE G_apply_offsets(ABORT,err)
+*--------------------------------------------------------
+*- Prototype C analysis routine
+*-
+*-
+*- Purpose and Methods : applies offsets to spectrometer
+*- momenta and angles
+*-
+*-
+*- Output: ABORT - success or failure
+*- : err - reason for failure, if any
+*-
+*- Created 31-Aug-1999 Chris Armstrong
+*-
+*-
+*- All standards are from "Proposal for Hall C Analysis Software
+*- Vade Mecum, Draft 1.0" by D.F.Geesamn and S.Wood, 7 May 1993
+*-
+*-
+*--------------------------------------------------------
+ IMPLICIT NONE
+ SAVE
+*
+ character*13 here
+ parameter (here= 'G_apply_offsets')
+*
+ logical ABORT
+ character*(*) err
+ logical HMS_ABORT,SOS_ABORT
+ character*132 HMS_err,SOS_err
+
+ include 'gen_run_info.cmn'
+*
+*--------------------------------------------------------
+*
+ err= ' '
+ HMS_err= ' '
+ SOS_err= ' '
+*
+
+ call H_apply_offsets(HMS_ABORT,HMS_err)
+
+*
+
+ call S_apply_offsets(SOS_ABORT,SOS_err)
+
+*
+ ABORT= HMS_ABORT .or. SOS_ABORT
+*
+ IF(ABORT) THEN
+ err= HMS_err
+ call G_prepend(SOS_err,err)
+ call G_add_path(here,err)
+ ELSE
+ err= ' '
+ ENDIF
+*
+ RETURN
+ END
diff --git a/ENGINE/g_calc_beam_pedestal.f b/ENGINE/g_calc_beam_pedestal.f
new file mode 100644
index 0000000..2d81c45
--- /dev/null
+++ b/ENGINE/g_calc_beam_pedestal.f
@@ -0,0 +1,122 @@
+ subroutine g_calc_beam_pedestal(ABORT,err)
+*
+* $Log: g_calc_beam_pedestal.f,v $
+* Revision 1.4.20.2 2007/10/24 16:59:55 cdaq
+* added special handling for BigCal light source photodiode
+*
+* Revision 1.4.20.1 2007/09/11 19:14:17 frw
+* fixed FPP related arrays and limits
+*
+* Revision 1.4 2003/09/05 15:33:55 jones
+* Merge in online03 changes (mkj)
+*
+* Revision 1.3.2.1 2003/04/09 16:53:40 cdaq
+* Modified so that it does not write out slot = 15 to threshold file (MKJ)
+*
+* Revision 1.3 1996/12/12 22:10:20 saw
+* (SAW) Remove disabling of inputs 3 and 4 in slot 15 (Adds the slow
+* raster)
+*
+c Revision 1.2 96/09/04 14:32:27 14:32:27 saw (Stephen A. Wood)
+c (JRA) ??
+c
+* Revision 1.1 1996/01/22 15:10:14 saw
+* Initial revision
+*
+ implicit none
+ save
+*
+ character*22 here
+ parameter (here='g_calc_beam_pedestal')
+*
+ logical ABORT
+ character*(*) err
+*
+ integer*4 imisc
+ integer*4 ind,ihit
+ integer*4 roc,slot
+ integer*4 signalcount,istart
+ real*4 sig2
+ real*4 num
+ character*132 file
+*
+ INCLUDE 'gen_data_structures.cmn'
+ include 'gen_detectorids.par'
+ INCLUDE 'gen_decode_common.cmn'
+ INCLUDE 'gen_run_info.cmn'
+ INCLUDE 'hms_filenames.cmn'
+ include 'bigcal_gain_parms.cmn'
+*
+ integer SPAREID
+ parameter (SPAREID=67)
+*
+*
+* MISC. PEDESTALS
+*
+ ind = 0
+ do ihit = 1 , gmax_misc_hits
+ if (gmisc_raw_addr1(ihit).eq.2) then ! ADC data.
+ imisc = gmisc_raw_addr2(ihit)
+ num=max(1.,float(gmisc_ped_num(imisc,2)))
+ gmisc_new_ped(imisc,2) = float(gmisc_ped_sum(imisc,2)) / num
+ sig2 = float(gmisc_ped_sum2(imisc,2))/ num - gmisc_new_ped(imisc,2)**2
+ gmisc_new_rms(imisc,2) = sqrt(max(0.,sig2))
+ gmisc_new_adc_threshold(imisc,2)=gmisc_new_ped(imisc,2)+10.
+ gmisc_dum_adc_threshold(imisc,2)=0 !don't sparsify USED channels.
+
+ if(imisc.eq.37) then !BigCal light source photodiode
+ bigcal_trig_new_ped(39) = gmisc_new_ped(imisc,2)
+ bigcal_trig_new_rms(39) = gmisc_new_rms(imisc,2)
+ bigcal_trig_new_threshold(39) = gmisc_new_ped(imisc,2) +
+ $ bigcal_trig_nsparse
+ endif
+
+ if (abs(gmisc_ped(imisc,2)-gmisc_new_ped(imisc,2))
+ & .ge.(2.*gmisc_new_rms(imisc,2))) then
+ ind = ind + 1
+ gmisc_changed_tube(ind)=imisc
+ gmisc_ped_change(ind)=gmisc_new_ped(imisc,2)-gmisc_ped(imisc,2)
+ endif
+ if (num.gt.gmisc_min_peds .and. gmisc_min_peds.ne.0) then
+ gmisc_ped(imisc,2)=gmisc_new_ped(imisc,2)
+ gmisc_ped_rms(imisc,2)=gmisc_new_rms(imisc,2)
+ endif
+ endif !chose ADC hits.
+ enddo
+ gmisc_num_ped_changes = ind
+*
+ call g_calc_bpm_pedestal
+ call g_calc_raster_pedestal
+*
+* WRITE THRESHOLDS TO FILE FOR HARDWARE SPARCIFICATION
+*
+ if (h_threshold_output_filename.ne.' ') then !the ADC is in the HMS ROC.
+ file=h_threshold_output_filename
+ call g_sub_run_number(file, gen_run_number)
+
+ open(unit=SPAREID,file=file,status='unknown')
+
+ write(SPAREID,*) '# This is the ADC threshold file generated automatically'
+ write(SPAREID,*) '# from the pedestal data from run number ',gen_run_number
+
+ roc=1
+
+ slot=15
+ signalcount=1
+ istart=g_decode_slotpointer(roc,slot)
+ if (istart.ne.-1) then !uninstrumented slot.
+ write(SPAREID,*) 'slot=',slot
+ endif
+
+
+ccc gmisc_dum_adc_threshold(3,2)=4000 !empty slots after blm.
+ccc gmisc_dum_adc_threshold(4,2)=4000
+
+ call g_output_thresholds(SPAREID,roc,slot,signalcount,gmax_misc_hits,
+ & gmisc_dum_adc_threshold,0,gmisc_new_rms,0)
+
+* close(unit=SPAREID) !don't close. needed by h_calc_pedestal.f
+ endif
+
+ return
+ end
diff --git a/ENGINE/g_calc_bpm_pedestal.f b/ENGINE/g_calc_bpm_pedestal.f
new file mode 100644
index 0000000..350b8bf
--- /dev/null
+++ b/ENGINE/g_calc_bpm_pedestal.f
@@ -0,0 +1,33 @@
+ subroutine g_calc_bpm_pedestal(ABORT,err)
+*
+* $Log: g_calc_bpm_pedestal.f,v $
+* Revision 1.2 1996/04/29 19:43:42 saw
+* (JRA) Update bpm calculations
+*
+* Revision 1.1 1996/01/22 15:12:05 saw
+* Initial revision
+*
+ implicit none
+ save
+*
+ character*18 here
+ parameter (here='g_calc_bpm_pedestal')
+*
+ logical ABORT
+ character*(*) err
+*
+ integer*4 ibpm,isig
+*
+ INCLUDE 'gen_data_structures.cmn'
+*
+*
+* extract bpm pedestal information from gmisc variables.
+*
+ do ibpm=1,gmax_num_bpms !need some kind of 'map' for this.
+ do isig=1,gnum_bpm_signals
+ gbpm_adc_ped(isig,ibpm) = gmisc_ped(4*(ibpm-1)+isig,2) !2 is for ADC
+ enddo
+ enddo
+
+ return
+ end
diff --git a/ENGINE/g_calc_pedestal.f b/ENGINE/g_calc_pedestal.f
new file mode 100644
index 0000000..ec9c681
--- /dev/null
+++ b/ENGINE/g_calc_pedestal.f
@@ -0,0 +1,64 @@
+ subroutine g_calc_pedestal(ABORT,err)
+*
+* $Log: g_calc_pedestal.f,v $
+* Revision 1.2.24.1.2.2 2008/10/26 19:12:33 cdaq
+* SEM
+*
+* Revision 1.2.24.1.2.1 2008/05/15 18:59:21 bhovik
+* 1'st version
+*
+* Revision 1.2.24.1 2007/05/15 02:55:01 jones
+* Start to Bigcal code
+*
+* Revision 1.2 1996/01/22 15:12:35 saw
+* (JRA) Add call to g_calc_beam_pedestal
+*
+* Revision 1.1 1995/04/01 19:37:06 cdaq
+* Initial revision
+*
+*
+ implicit none
+*
+ character*18 here
+ parameter (here='g_calc_pedestal')
+*
+ logical ABORT
+ character*(*) err
+*
+ call g_calc_beam_pedestal(ABORT,err)
+ if(ABORT) then
+ call G_add_path(here,err)
+ return
+ endif
+*
+ call h_calc_pedestal(ABORT,err)
+ if(ABORT) then
+ call G_add_path(here,err)
+ return
+ endif
+*
+ call s_calc_pedestal(ABORT,err)
+ if(ABORT) then
+ call G_add_path(here,err)
+ return
+ endif
+
+ call b_calc_pedestal(ABORT,err)
+ if(ABORT) then
+ call G_add_path(here,err)
+ return
+ endif
+
+ call sane_calc_pedestal(ABORT,err)
+ if(ABORT) then
+ call G_add_path(here,err)
+ return
+ endif
+ call sem_calc_pedestal(ABORT,err)
+ if(ABORT) then
+ call G_add_path(here,err)
+ return
+ endif
+*
+ return
+ end
diff --git a/ENGINE/g_calc_raster_pedestal.f b/ENGINE/g_calc_raster_pedestal.f
new file mode 100644
index 0000000..f666e70
--- /dev/null
+++ b/ENGINE/g_calc_raster_pedestal.f
@@ -0,0 +1,39 @@
+ subroutine g_calc_raster_pedestal(ABORT,err)
+*
+* $Log: g_calc_raster_pedestal.f,v $
+* Revision 1.3.26.1 2008/10/11 15:03:35 cdaq
+* slow raster
+*
+* Revision 1.3 1999/02/23 16:56:46 csa
+* (JRA) Remove slow raster stuff
+*
+* Revision 1.2 1999/02/10 17:38:43 csa
+* Cleanup
+*
+* Revision 1.1 1996/01/22 15:10:20 saw
+* Initial revision
+*
+ implicit none
+ save
+*
+ character*23 here
+ parameter (here='g_calc_raster_pedestal')
+*
+ logical ABORT
+ character*(*) err
+*
+ INCLUDE 'gen_data_structures.cmn'
+*
+* extract raster pedestal information from gmisc variables.
+*
+ gfrx_adc_ped=gmisc_ped(14,2) !2 is for ADCs
+ gfry_adc_ped=gmisc_ped(16,2)
+ gfrx_sync_mean=gmisc_ped(13,2)
+ gfry_sync_mean=gmisc_ped(15,2)
+ GSRX_ADC_PED = gmisc_ped(4,2)
+ GSRY_ADC_PED = gmisc_ped(6,2)
+ GSRX_ADC_PED2 = gmisc_ped(24,2)
+ GSRY_ADC_PED2 = gmisc_ped(26,2)
+
+ return
+ end
diff --git a/ENGINE/g_clear_event.f b/ENGINE/g_clear_event.f
new file mode 100644
index 0000000..14a08c0
--- /dev/null
+++ b/ENGINE/g_clear_event.f
@@ -0,0 +1,154 @@
+ SUBROUTINE G_clear_event(ABORT,err)
+*--------------------------------------------------------
+*- Prototype C analysis routine
+*-
+*-
+*- Purpose and Methods : clears all quantities AT THE START OF EACH EVENT
+*-
+*-
+*- Output: ABORT - success or failure
+*- : err - reason for failure, if any
+*-
+*- Created 29-Oct-1993 Kevin B. Beard, Hampton U.
+*- Modified 19-Nov-1993 Kevin B. Beard for new error standards
+*- $Log: g_clear_event.f,v $
+*- Revision 1.10.24.2.2.4 2008/11/06 21:38:50 cdaq
+*- Fix typo which had
+*- call f1trigger_clear_event(F1trigger_ABORT,f1trigger_err) ! F1 trigger
+*- call f1trigger_clear_event(Sem_ABORT,Sem_err) ! sem
+*-
+*- instead of
+*-
+*- call f1trigger_clear_event(F1trigger_ABORT,f1trigger_err) ! F1 trigger
+*- call sem_clear_event(Sem_ABORT,Sem_err) ! sem
+*-
+*- Revision 1.10.24.2.2.3 2008/10/26 19:12:33 cdaq
+*- SEM
+*-
+*- Revision 1.10.24.2.2.2 2008/10/02 17:57:23 cdaq
+*- *** empty log message ***
+*-
+*- Revision 1.10.24.2.2.1 2008/05/15 18:59:21 bhovik
+*- 1'st version
+*-
+*- Revision 1.10.24.2 2007/06/04 14:56:05 puckett
+*- changed hit array structure for trigger related signals
+*-
+*- Revision 1.10.24.1 2007/05/15 02:55:01 jones
+*- Start to Bigcal code
+*-
+*- Revision 1.10 1996/09/04 14:33:10 saw
+*- (SAW) Don't use gmc_abort since gmc stuff not called
+*-
+*- Revision 1.9 1996/01/22 15:14:48 saw
+*- (JRA) Put BPM/Raster data into MISC data structures
+*-
+*- Revision 1.8 1996/01/16 18:41:36 cdaq
+*- (JRA) Explain that routine runs at start of each event
+*-
+*- Revision 1.7 1995/07/27 19:06:40 cdaq
+*- (SAW) Disable monte carlo (GMC)
+*-
+* Revision 1.6 1995/04/01 19:44:31 cdaq
+* (SAW) Add clear of BPM hit counter
+*
+* Revision 1.5 1994/06/22 20:23:47 cdaq
+* (SAW) Clear the uninstrumented channel hit counter
+*
+* Revision 1.4 1994/04/15 20:33:43 cdaq
+* (SAW) Changes for ONLINE use
+*
+* Revision 1.3 1994/02/22 19:47:07 cdaq
+* Change gmc_clear_event to gmc_mc_clear
+*
+* Revision 1.2 1994/02/17 21:46:03 cdaq
+* Add call to gmc_clear_event
+*
+* Revision 1.1 1994/02/04 21:48:38 cdaq
+* Initial revision
+*
+*-
+*- All standards are from "Proposal for Hall C Analysis Software
+*- Vade Mecum, Draft 1.0" by D.F.Geesamn and S.Wood, 7 May 1993
+*-
+*-
+*--------------------------------------------------------
+ IMPLICIT NONE
+ SAVE
+*
+ character*13 here
+ parameter (here= 'G_clear_event')
+*
+ logical ABORT
+ character*(*) err
+*
+ INCLUDE 'gen_data_structures.cmn'
+ include 'gen_run_info.cmn'
+*
+ logical HMS_ABORT,SOS_ABORT,COIN_ABORT,gmc_abort,BIGCAL_ABORT
+ logical GEP_ABORT,SANE_ABORT,F1Trigger_abort,sem_abort
+ character*132 HMS_err,SOS_err,COIN_err,gmc_err,BIGCAL_err
+ character*132 GEP_err,SANE_err,F1trigger_err,SEM_err
+
+*
+*--------------------------------------------------------
+*
+ err= ' '
+ HMS_err= ' '
+ SOS_err= ' '
+ BIGCAL_err=' '
+ GEP_err=' '
+ gmc_err= ' '
+ sane_err= ' '
+ F1trigger_err= ' '
+ sem_err= ' '
+*
+ GUNINST_TOT_HITS = 0 ! Unistrumented hit counter
+ GMISC_TOT_HITS = 0
+*
+
+ call H_clear_event(HMS_ABORT,HMS_err)
+
+*
+
+ call S_clear_event(SOS_ABORT,SOS_err)
+
+*
+
+ call C_clear_event(COIN_ABORT,COIN_err)
+
+*
+ call B_clear_event(BIGCAL_ABORT,BIGCAL_err) ! BigCal
+
+*
+ call sane_clear_event(SANE_ABORT,SANE_err) ! SANE
+
+ call f1trigger_clear_event(F1trigger_ABORT,f1trigger_err) ! F1 trigger
+ call sem_clear_event(Sem_ABORT,Sem_err) ! sem
+
+*
+
+ call GEp_clear_event(GEP_ABORT,GEP_err) ! GEp-coin
+
+*
+
+** call gmc_mc_clear(gmc_abort,gmc_err)
+*
+ ABORT= HMS_ABORT .or. SOS_ABORT .or. COIN_ABORT .or. BIGCAL_ABORT
+ $ .or. GEP_ABORT
+*.or. gmc_abort
+*
+ IF(ABORT) THEN
+ err= COIN_err
+ call G_prepend(SOS_err,err)
+ call G_prepend(HMS_err,err)
+ call g_prepend(gmc_err,err)
+ call g_prepend(BIGCAL_err,err)
+ call g_prepend(GEP_err,err)
+ call G_add_path(here,err)
+ ELSE
+ err= ' '
+ ENDIF
+*
+ RETURN
+ END
diff --git a/ENGINE/g_ctp_database.f b/ENGINE/g_ctp_database.f
new file mode 100644
index 0000000..0d917e7
--- /dev/null
+++ b/ENGINE/g_ctp_database.f
@@ -0,0 +1,276 @@
+ subroutine g_ctp_database(ABORT, error, run, filename)
+*
+* USES LUN G_LUN_TEMP as a temporary LUN
+*
+************************************************************************
+* g_ctp_database(run, filename, ABORT)
+*
+* Find and execute in the given file, all the CTP parameter lines
+* associated with the given run number.
+* Thiis is done by parsing the individual lines within <filename>,
+* where each line will be one of the following:
+*
+* 1. A comment. These lines will start with the character ";", and
+* will be ignored.
+* 2. A run list. These lines will have the following syntax:
+* <run_list> :: "<number>[-<number>] [,<run_list>]"
+* Note that for the time being, spaces are not allowed.
+* 3. Text. This is anything after the run list, and before the next
+* run list (or to <EOF>).
+*
+* Currently, there is *no* error handling. I don't make mistakes.
+*
+* Creation date: 25 May 1995 (JWP)
+*
+* Modification History:
+*
+* 30 May 1995 (JWP): Two new features --
+* (1) if run number is not found, set ABORT to .true.
+* (2) Don't print lines starting with ";";
+* furthermore, ignore embedded comments (i.e.,
+* don't print out stuff following the ';').
+*
+* $Log: g_ctp_database.f,v $
+* Revision 1.7 1999/11/04 20:35:15 saw
+* Linux/G77 compatibility fixes
+*
+* Revision 1.6 1996/11/05 20:47:06 saw
+* (SAW) Change in open statement for porting compatibility
+*
+* Revision 1.5 1996/09/04 14:33:40 saw
+* (SAW) Use G_LUN_TEMP instead of 133 for linux compatibility
+*
+* Revision 1.4 1996/01/16 18:42:07 cdaq
+* (JRA) Minor bug fixes
+*
+* Revision 1.3 1995/10/11 12:14:49 cdaq
+* (JWP) Fix single run number at end of line bug.
+* Don't pass blank lines to thpset.
+*
+* Revision 1.2 1995/09/01 13:42:04 cdaq
+* (JRA) Some corrections
+*
+* Revision 1.1 1995/07/27 19:08:06 cdaq
+* Initial revision
+*
+************************************************************************
+ implicit none
+ SAVE
+*
+ include 'gen_filenames.cmn'
+*
+ character*14 here
+ parameter (here='g_ctp_database')
+*
+ logical ABORT
+ character*(*) error
+ integer*4 run
+ character*(*) filename
+
+ logical debug
+ logical parsing_run_list, spaces_stripped
+
+ integer i
+ integer index, number
+ logical looking_for_run, found_run, printed_header
+ character*132 line, newline
+ integer*4 chan
+* integer*4 err
+ integer*4 lo_limit, hi_limit
+
+c write (6,*) 'Debug?'
+c read (5, 1002) i
+c if (i .eq. 1) then
+c debug = .true.
+c else
+ debug = .false.
+c endif
+
+ if(debug) write(6,*) 'looking for run ',run
+ found_run = .FALSE.
+ looking_for_run = .TRUE.
+ printed_header = .FALSE.
+
+* Again, I don't make mistakes.
+ ABORT = .FALSE.
+
+ chan = G_LUN_TEMP
+
+ open (unit=chan, status='old', file=filename)
+
+ read (chan, 1001, end=9999) line
+ index = 1
+ if (debug) write (6,*) line
+ 111 do while (looking_for_run)
+
+ do while (line(1:1) .eq. ';')
+ read (chan, 1001, end=9999) line
+ index = 1
+ if (debug) write (6,*) line
+ end do
+
+ parsing_run_list = .true.
+ do while (parsing_run_list)
+
+* At this point, we should be looking at a run list. The first thing in
+* the list will be a number, or it may be white space. Skip the white
+* space and build the number. After that, skip any white space at the
+* end.
+ number = 0
+
+ do while ((index .lt. 132) .and.
+ $ (line(index:index) .eq. ' '))
+ if (debug) write (6,*) 'Found white space!'
+ index = index + 1
+ end do
+
+ do while ((ichar(line(index:index)) .ge. ichar('0')) .and.
+ $ (ichar(line(index:index)) .le. ichar('9')))
+ number = 10*number +
+ $ ichar(line(index:index)) - ichar('0')
+ index = index + 1
+ end do
+ if (debug) write (6,*) 'Found number:',number
+
+ do while ((index .lt. 132) .and.
+ $ (line(index:index) .eq. ' '))
+ if (debug) write (6,*) 'Found white space!'
+ index = index + 1
+ end do
+
+************************************************************************
+* Now, we are pointing at one of the following:
+*
+* 1. The end of the line. This is flagged by (index .eq. 132). In
+* this case, check the number we found against <run>.
+* 2. A comma. This indicates that the number we just built is not
+* the end of the current line, but *is* the end of the current
+* run list. Check it against <run>.
+* 3. A dash ("-"). This indicates that the number we just built is
+* the lower limit of the current run list. Build the upper
+* limit, and check to see if <run> is within the limits.
+
+
+ if (index .eq. 132) then
+ if (debug) write (6,*) 'End of the line!'
+ parsing_run_list = .false.
+ if (number .eq. run) then
+ found_run = .true.
+ looking_for_run = .false.
+ end if
+
+ else if (line(index:index) .eq. ',') then
+ if (debug) write (6,*) 'NOT last number in list!'
+ if (number .eq. run) then
+ found_run = .true.
+ looking_for_run = .false.
+ parsing_run_list = .false.
+ end if
+ index = index + 1
+ else if (line(index:index) .eq. '-') then
+ if (debug) write (6,*) 'Range:'
+ lo_limit = number
+ number = 0
+ index = index + 1
+ do while ((ichar(line(index:index)) .ge. ichar('0'))
+ $ .and. (ichar(line(index:index)) .le. ichar('9')))
+ number = 10*number +
+ $ ichar(line(index:index)) - ichar('0')
+ index = index + 1
+ end do
+ hi_limit = number
+ if (debug) write (6,*) lo_limit,'-',hi_limit
+ if (line(index:index) .eq. ',') then
+ index = index+1
+ else if (line(index:index) .eq. ' ') then
+ parsing_run_list = .false.
+ end if
+ if ((lo_limit .le. run) .and. (hi_limit .ge. run)) then
+ found_run = .true.
+ looking_for_run = .false.
+ parsing_run_list = .false.
+ end if
+ else
+ write(6,*) 'encountered unexpected character(s)' ! JRA
+ stop
+ end if
+
+ end do
+ if (looking_for_run) then
+ if (debug) write (6,*)
+ $ 'Didn''t find run -- skipping to next run list!'
+ read (chan, 1001, end=9999) line
+ index = 1
+ if (debug) write (6,*) line
+ do while ((ichar(line(1:1)) .lt. ichar('0')) .or.
+ $ (ichar(line(1:1)) .gt. ichar('9')))
+ read (chan, 1001, end=9999) line
+ index = 1
+ if (debug) write (6,*) line
+ end do
+ end if
+ end do
+
+************************************************************************
+* At this point, we've found the run number. Print out the lines
+* following the run number, stripping the leading spaces, until we get
+* to another run list.
+ read (chan, 1001, end=9999) line
+ index = 1
+ if (debug) write (6,*) line
+ do while ((ichar(line(1:1)) .lt. ichar('0')) .or.
+ $ (ichar(line(1:1)) .gt. ichar('9')))
+ do i=1,132
+ newline(i:i) = ' '
+ end do
+ spaces_stripped = .false.
+ do while(.not. spaces_stripped)
+ if (line(index:index) .eq. ' ') then
+ index = index + 1
+ if (index .gt. 132) then
+ spaces_stripped = .true.
+ end if
+ else
+ spaces_stripped = .true.
+ end if
+ end do
+ if (index .le. 132) then
+ if (line(index:index) .ne. ';') then
+ i = 1
+ do while ((index .lt. 132) .and.
+ $ (line(index:index) .ne. ';'))
+ newline(i:i) = line(index:index)
+ index = index + 1
+ i = i+1
+ end do
+ if(.not.printed_header) then
+c write(6,*)'g_ctp_database is setting the following CTP parameters'
+ printed_header = .true.
+ endif
+ write(6,'(4x,a)') newline(1:70) ! Truncate to keep 1/line
+ call thpset(newline)
+ end if
+ end if
+ read (chan, 1001, end=9999) line
+ index = 1
+ if (debug) write (6,*) line
+ end do
+
+ looking_for_run = .true.
+ parsing_run_list = .true.
+ goto 111
+* Done with open file.
+
+ 9999 close (unit=chan)
+ if (.not. found_run) then
+ write(6,*) 'cant find run ',run,' in "',filename,'"'
+ end if
+
+ return
+
+*============================ Format Statements ===============================
+
+ 1001 format(a)
+ 1002 format(i10)
+
+ end
diff --git a/ENGINE/g_decode_clear.f b/ENGINE/g_decode_clear.f
new file mode 100644
index 0000000..f2e663e
--- /dev/null
+++ b/ENGINE/g_decode_clear.f
@@ -0,0 +1,58 @@
+ subroutine g_decode_clear(ABORT, error)
+*
+* Purpose and Methods: clear decoding arrays AT THE START OF EACH EVENT
+*
+* Inputs:
+*
+* None
+*
+* Outputs:
+*
+* ABORT
+* error
+*
+*-
+*- by Steve Wood
+*- modified by Kevin Beard Dec.3,1993
+* $Log: g_decode_clear.f,v $
+* Revision 1.3.24.1 2007/09/11 19:14:17 frw
+* fixed FPP related arrays and limits
+*
+* Revision 1.3 1996/01/16 20:31:54 cdaq
+* (SAW) Start "roc" index at zero instead of one.
+*
+* Revision 1.2 1994/06/18 02:46:58 cdaq
+* (SAW) Add code for miscleaneous data and uninstrumented channels
+*
+* Revision 1.1 1994/02/04 21:49:17 cdaq
+* Initial revision
+*
+*-
+ implicit none
+ SAVE
+ logical ABORT
+ character*(*) error
+ integer roc,slot,i
+*
+ include 'gen_detectorids.par'
+ include 'gen_decode_common.cmn'
+*
+* Clear out slotpointer and subaddcount and mask arrays.
+*
+ do roc=0, G_DECODE_MAXROCS
+ do slot=1, G_DECODE_MAXSLOTS
+ g_decode_slotpointer(roc,slot) = -1 ! Uninstrumented SLOT
+ g_decode_subaddcnt(roc,slot) = 16 ! Dflt for "uninstrmntd" slots
+ g_decode_slotmask(roc,slot) = 'FFF'x ! Default mask
+ enddo
+ enddo
+*
+ do i=1,G_DECODE_MAXWORDS ! Clear out the Detector ID map
+ g_decode_didmap(i) = UNINST_ID ! with the uninstrumented ID
+ enddo
+*
+ g_decode_nextpointer = 1
+ ABORT= .FALSE.
+ error= ' '
+ return
+ end
diff --git a/ENGINE/g_decode_config.f b/ENGINE/g_decode_config.f
new file mode 100644
index 0000000..eaa66df
--- /dev/null
+++ b/ENGINE/g_decode_config.f
@@ -0,0 +1,286 @@
+ subroutine g_decode_config(ABORT, error, fname)
+*------------------------------------------------------------------------------
+*
+* Purpose and Methods:
+*
+* Build a table that maps (ROC, Slot, Subadd) to (Detector ID, Plane,
+* Counter, Signal type). Also saves a mask for each slot that is used
+* to extract value from fastbus word.
+*
+* Inputs:
+*
+* fname Name of file
+* - Allowed keywords. roc, slot, detector, nsubadd, mask, module
+* - Numerical lines: Subadd, Plane, Counter, Signal
+*
+* Outputs:
+*
+* ABORT
+* error
+*
+* Created 16-NOV-1993 Stephen Wood, CEBAF
+* Modified 3-Dec-1993 Kevin Beard, Hampton Univ.; rewrote parsing
+* $Log: g_decode_config.f,v $
+* Revision 1.7.24.3.2.1 2009/01/16 18:47:12 cdaq
+* *** empty log message ***
+*
+* Revision 1.7.24.3 2007/09/12 14:40:02 brash
+* *** empty log message ***
+*
+* Revision 1.7.24.2 2007/09/10 21:18:13 frw
+* fixed FPP related arrays and limits
+*
+* Revision 1.7.24.1 2007/08/22 19:09:16 frw
+* added FPP
+*
+* Revision 1.8 4/2007 frw
+* add new declaration statement to mapping file to indicate module
+* type -- NOT used by fastbus and thus defaults to 0 if undeclared
+*
+* Revision 1.7 2002/09/25 14:40:33 jones
+* Add call to G_IO_control to get spareID for unit number to open file
+* and call at end to G_IO_control free the unit number.
+*
+* Revision 1.6 1996/01/16 20:48:35 cdaq
+* (SAW) Start "roc" index at zero instead of one.
+*
+* Revision 1.5 1995/07/27 19:07:53 cdaq
+* (SAW) Remove unused variables, change type to status in open statement (f2c)
+*
+* Revision 1.4 1994/06/21 20:42:37 cdaq
+* (SAW) Fix a bug interpreting comment lines
+*
+* Revision 1.3 1994/06/18 02:47:38 cdaq
+* (SAW) Add code for miscleaneous data and uninstrumented channels
+*
+* Revision 1.2 1994/04/06 18:22:02 cdaq
+* (SAW) Revert to pre-initial version that doesn't use UTILSUBS string
+* manipulation routines. Added BSUB keyword for # of bits to shift to get
+* the channel number from a lecroy FB word. Some validity checking should
+* be added back in.
+*
+* Revision 1.1 1994/02/01 20:38:10 cdaq
+* Initial revision
+*
+*------------------------------------------------------------------------------
+
+ implicit none
+ SAVE
+
+ character*30 here
+ parameter (here= 'g_decode_config')
+
+ character*(*) error
+ logical ABORT
+ character*(*) fname
+
+ include 'gen_detectorids.par'
+ include 'gen_decode_common.cmn'
+ integer SPAREID ! Need a LUN handler?
+ integer MAXLINE
+ parameter (MAXLINE=300)
+
+ character*(MAXLINE) line
+ logical OK,text
+
+ integer llen,lp,lpcom, lpeq, m ! Line pointers
+ character*1 tab
+ integer*4 roc, slot, subadd, mask
+ integer*4 did, plane, counter, signal, nsubadd, bsubadd, modtyp
+ integer*4 lastroc, lastslot
+ integer N_lines_read
+
+ logical echo,debug,override
+ character*26 lo,HI
+ data echo/.FALSE./
+ data debug,override/2*.FALSE./
+ data lo/'abcdefghijklmnopqrstuvwxyz'/
+ data HI/'ABCDEFGHIJKLMNOPQRSTUVWXYZ'/
+
+*********************************************************************************
+* Valid data lines are
+*
+* roc=
+* slot=
+* detector=
+* nsubadd=
+* moduletype=
+* A line with 4 comma separated numbers, Subadd, plane, "wire #", sigtyp
+* sigtyp may be left blank (e.g. for wire chambers) in which case zero
+* is assumed.
+*********************************************************************************
+
+ ABORT= .FALSE.
+
+ call g_IO_control(spareID,'ANY',ABORT,error) !get IO channel
+ IF(ABORT) THEN
+ call G_add_path(here,error)
+ RETURN
+ ENDIF
+ open(unit=SPAREID,status='OLD',READONLY,file=fname,err=999)
+* * file name passed as an argument
+
+ tab = char(9)
+ roc = -1
+ slot = -1
+ lastroc = -1
+ lastslot = -1
+ N_lines_read= 0
+ mask = 'FFF'x ! Default data mask
+ bsubadd = 17 ! Default LSB of channel field
+ modtyp = 0
+
+ OK= .TRUE.
+ DO WHILE (OK)
+
+ OK= .FALSE.
+ error= ':error reading'
+ read(SPAREID, '(a)',err=555,end=666) line
+ OK= .TRUE.
+ error= ' '
+555 N_lines_read= N_lines_read+1
+
+ If(OK) Then
+
+ if(echo) call g_log_message(line)
+
+ llen = len(line) ! Remove comments (; or !)
+ lpcom = index(line(1:llen),';')
+ if(lpcom.gt.0) llen = lpcom - 1
+ if(llen.gt.0) then
+ lpcom = index(line(1:llen),'!')
+ if(lpcom.gt.0) llen = lpcom - 1
+ endif
+
+ if(llen.gt.0) then
+ do while((line(llen:llen).eq.' '.or.line(llen:llen).eq.tab)
+ $ .and.llen.ge.1)
+ llen = llen - 1 ! Strip whitespace off end of string
+ if(llen.le.0) goto 127 ! Prevent line(0:0)
+ enddo
+ 127 continue
+ endif
+
+ if(llen.gt.0) then
+ text = .false.
+ do lp=1,llen ! Shift to upper case
+ m = index(lo,line(lp:lp))
+ if(m.gt.0) then
+ line(lp:lp) = HI(m:m)
+ text = .true.
+ else if(index(HI,line(lp:lp)).gt.0) then
+ text = .true.
+ endif
+ enddo
+
+ if(text) then
+ lpeq = index(line(1:llen),'=')
+
+ if(lpeq.gt.0) then
+ if(index(line(1:lpeq-1),'ROC').gt.0) then
+ read(line(lpeq+1:llen),'(i10)') roc
+ modtyp = 0 !init to fastbus for compatibility
+ else if(index(line(1:lpeq-1),'SLOT').gt.0) then
+ read(line(lpeq+1:llen),'(i10)') slot
+ else if(index(line(1:lpeq-1),'DET').gt.0) then
+ read(line(lpeq+1:llen),'(i10)') did
+ else if(index(line(1:lpeq-1),'NSUB').gt.0) then
+ read(line(lpeq+1:llen),'(i10)') nsubadd
+ else if(index(line(1:lpeq-1),'BSUB').gt.0) then
+ read(line(lpeq+1:llen),'(i10)') bsubadd
+ else if(index(line(1:lpeq-1),'MODU').gt.0) then
+ read(line(lpeq+1:llen),'(i10)') modtyp
+ else if(index(line(1:lpeq-1),'MASK').gt.0) then
+ lp = index(line(lpeq+1:llen),'X')
+ if(lp.gt.0) llen = lpeq+lp-1
+ read(line(lpeq+1:llen),'(z10)') mask
+ endif
+ else
+ if(index(line(1:llen),'NOECHO').gt.0) then
+ echo = .false.
+ else if(index(line(1:llen),'ECHO').gt.0) then
+ echo = .true.
+ endif
+ endif
+ else
+ read(line(1:llen),'(4i15)') subadd, plane, counter,
+ $ signal
+ If(OK .and. (roc.ne.lastroc.or.slot.ne.lastslot)) Then
+ if(g_decode_slotpointer(roc,slot).le.0) then
+ g_decode_slotpointer(roc,slot) =
+ & g_decode_nextpointer
+ g_decode_subaddcnt(roc,slot) = nsubadd
+ g_decode_subaddbit(roc,slot) = bsubadd
+ g_decode_slotmask(roc,slot) = mask
+ g_decode_modtyp(roc,slot) = modtyp
+ g_decode_nextpointer = g_decode_nextpointer +
+ & nsubadd
+ lastroc = roc
+ lastslot = slot
+
+ endif
+ EndIf
+
+ If(OK) Then
+ g_decode_didmap( g_decode_slotpointer(roc,slot)
+ & +subadd ) = did
+ g_decode_planemap( g_decode_slotpointer(roc,slot)
+ & +subadd ) = plane
+ g_decode_countermap( g_decode_slotpointer(roc,slot)
+ & +subadd ) = counter
+ g_decode_sigtypmap( g_decode_slotpointer(roc,slot)
+ & +subadd ) = signal
+c write(*,*)G_DECODE_MAXDIDS,G_DECODE_MAXPLANES,
+c & G_DECODE_MAXSIGNALS,G_DECODE_MAXCOUNTERS
+c write(*,*)did,counter,plane,signal
+ if ( did.le.MAXID
+ & .and.plane.le.G_DECODE_MAXPLANES
+ & .and.counter.le.G_DECODE_MAXCOUNTERS
+ & .and.signal.le.G_DECODE_MAXSIGNALS) then
+ g_decode_roc(did,plane,counter,signal) = roc
+ else
+ print *,'\n Array limits insufficient!!'
+ print *,' max did =',MAXID ,' got ',did
+ print *,' max plane =',G_DECODE_MAXPLANES ,' got ',plane
+ print *,' max counter =',G_DECODE_MAXCOUNTERS ,' got ',counter
+ print *,' max signal =',G_DECODE_MAXSIGNALS ,' got ',signal
+ print *,'\n Update gen_decode_common.cmn and recompile!/n'
+ STOP
+ endif
+ EndIf
+
+ endif
+ endif
+ endif
+ enddo
+
+
+888 ABORT= .NOT.OK
+ IF(ABORT) THEN
+ call G_add_path(here,error)
+ ELSE
+ error= ' '
+ ENDIF
+
+ close(unit=SPAREID)
+ call G_IO_control(spareID,'FREE',ABORT,error) !free up IO channel
+ IF(ABORT) THEN
+ call G_add_path(here,error)
+ RETURN
+ ENDIF
+
+ return
+
+
+666 OK= N_lines_read.GT.0
+ error= ':no lines read before End-of-File'
+ GOTO 888 !normal end-of-file?
+
+
+999 continue
+ error = ':Unable to open file "'//fname//'"'
+ call G_add_path(here,error)
+ return
+
+
+ end
diff --git a/ENGINE/g_decode_event_by_banks.f b/ENGINE/g_decode_event_by_banks.f
new file mode 100644
index 0000000..034f496
--- /dev/null
+++ b/ENGINE/g_decode_event_by_banks.f
@@ -0,0 +1,115 @@
+ subroutine g_decode_event_by_banks(event,ABORT, err)
+*-----------------------------------------------------------------------
+*- Purpose and Methods: Pull out individual Fastbus banks from event
+*- for subsequent decoding
+*-
+*- Find the beginning of each ROC bank and send it off to
+*- "g_decode_fb_bank".
+*-
+*- Inputs:
+*- event Pointer to the first word (length) of an event data bank.
+*-
+*- Outputs:
+*- ABORT success or failure
+*- err explanation for failure
+*-
+*- Created 3-Dec-1993 Kevin Beard, Hampton U.
+*- $Log: g_decode_event_by_banks.f,v $
+*- Revision 1.6.24.2.2.1 2009/09/02 13:37:42 jones
+*- eliminate commented write statements
+*-
+*- Revision 1.6.24.2 2007/09/10 20:33:37 pcarter
+*- Implemented changes to allow compilation on RHEL 3,4,5 and MacOSX
+*-
+*- Revision 1.6.24.1 2007/05/15 02:55:01 jones
+*- Start to Bigcal code
+*-
+*- Revision 1.6 1999/11/04 20:35:15 saw
+*- Linux/G77 compatibility fixes
+*-
+*- Revision 1.5 1995/07/27 19:09:10 cdaq
+*- (SAW) Use specific bit manipulation routines for f2c compatibility
+*-
+* Revision 1.4 1994/04/15 20:34:42 cdaq
+* ???
+*
+* Revision 1.3 1994/02/17 21:30:37 cdaq
+* Move ABORT, err args to end of g_decode_fb_bank call
+*
+* Revision 1.2 1994/02/02 19:59:16 cdaq
+* Rewrite without using fbgen routines
+*
+* Revision 1.1 1994/02/01 20:38:58 cdaq
+* Initial revision
+*
+*-----------------------------------------------------------------------
+ IMPLICIT NONE
+ SAVE
+*
+ external jiand, jieor
+ integer*4 event(*)
+*
+ character*30 here
+ parameter (here= 'g_decode_event_by_banks')
+*
+ logical ABORT
+ character*(*) err
+ integer*4 evlength ! Total length of the event
+ integer*4 bankpointer ! Pointer to next bank
+ integer*4 jiand, jieor
+*
+ include 'gen_data_structures.cmn'
+*
+ logical WARN
+*
+*-----------------------------------------------------------------------
+*
+*
+* Assume that the event is bank containing banks, the first of which is
+* an event ID bank.
+*
+* Various hex constants that are used in decode routines should
+* probably be put in an include file.
+*
+
+ ABORT = jieor(jiand(event(2),'FFFF'x),'10CC'x).ne.0
+ if(ABORT) then
+ err = here//'Event header not standard physics event'
+ return
+ endif
+
+ evlength = event(1)
+ bankpointer = 3
+
+ ABORT = jieor(event(bankpointer+1),'C0000100'x).ne.0
+ if(ABORT) then
+ err = here//'First bank is not an Event ID bank'
+ return
+ endif
+
+ bankpointer = bankpointer + event(bankpointer) + 1
+
+ WARN = (bankpointer.gt.evlength) ! No ROC's in event
+ IF(WARN) THEN
+ err= ':event contained no ROC banks'
+ call G_add_path(here,err)
+ ENDIF
+
+ do while(bankpointer.lt.evlength)
+ call g_decode_fb_bank(event(bankpointer), ABORT, err)
+
+ bankpointer = bankpointer + event(bankpointer) + 1
+
+ enddo
+
+ WARN = bankpointer.eq.(evlength + 1)
+ if(WARN) THEN
+ err = ':inconsistent bank and event lengths'
+ call G_add_path(here,err)
+ endif
+*
+ RETURN
+ END
+
+
+
diff --git a/ENGINE/g_decode_fb_bank.f b/ENGINE/g_decode_fb_bank.f
new file mode 100644
index 0000000..b4089f0
--- /dev/null
+++ b/ENGINE/g_decode_fb_bank.f
@@ -0,0 +1,763 @@
+ subroutine g_decode_fb_bank(bank, ABORT, error)
+*
+* Purpose and Methods: Decode a Fastbus bank.
+*
+* Looks at detector ID for a word in a data bank and passes the
+* appopriate data structure pointers to the g_decode_fb_detector routine.
+* That routine will return when it gets to another detector in which
+* case the the present routine will dispatch g_decode_fb_detector with a
+* new set of pointers.
+*
+* This routine must be modified when new detectors are added. It may
+* also may need to modified if fastbus modules other than from LeCroy
+* are used.
+*
+* It is the responsibility of the calling routine to call
+* g_decode_fb_bank only for banks of fastbus data.
+*
+* Inputs:
+*
+* bank Pointer to the first word (length) of a data bank.
+*
+* Outputs:
+*
+* ABORT
+* error
+*
+* Created 16-NOV-1993 Stephen Wood, CEBAF
+* Modified 3-Dec-1993 Kevin Beard, Hampton U.
+* $Log: g_decode_fb_bank.f,v $
+* Revision 1.32.20.15.2.7 2009/09/29 13:58:51 jones
+* Remove lines:
+* if(gen_event_trigtype(4).eq.1)then
+* if(gbeam_helicity_TS.eq.1)g_hel_pos = g_hel_pos+1
+* if(gbeam_helicity_TS.eq.-1)g_hel_neg = g_hel_neg+1
+* endif
+* this was overcount the number of T4 helicity plus and minus triggers
+* since the routine is called multiple times per event.
+* Moved to g_reconstruction.f
+*
+* Revision 1.32.20.15.2.6 2009/09/02 13:38:01 jones
+* eliminate commented write statements
+*
+* Revision 1.32.20.15.2.5 2009/03/31 19:33:00 cdaq
+* *** empty log message ***
+*
+* Revision 1.32.20.15.2.4 2009/01/30 20:33:29 cdaq
+* *** empty log message ***
+*
+* Revision 1.32.20.15.2.3 2008/10/26 19:12:33 cdaq
+* SEM
+*
+* Revision 1.32.20.15.2.2 2008/10/02 17:57:58 cdaq
+* *** empty log message ***
+*
+* Revision 1.32.20.15.2.1 2008/05/15 18:59:21 bhovik
+* 1'st version
+*
+* Revision 1.32.20.15 2008/01/08 22:44:08 cdaq
+* *** empty log message ***
+*
+* Revision 1.32.20.14 2007/10/22 15:47:44 cdaq
+* *** empty log message ***
+*
+* Revision 1.32.20.13 2007/10/20 19:54:19 cdaq
+* Added decoding of ROC21 (TS) bank to get the trigger input bits
+*
+* Revision 1.32.20.12 2007/10/17 16:10:23 cdaq
+* Added analysis of roc21 (trigger supervisor) to decode the trig. type bits
+*
+* Revision 1.32.20.11 2007/10/16 23:26:10 cdaq
+* *** empty log message ***
+*
+* Revision 1.32.20.10 2007/10/16 23:23:34 cdaq
+* fixed F1 data decoding
+*
+* Revision 1.32.20.9 2007/10/10 13:13:24 puckett
+* *** empty log message ***
+*
+* Revision 1.32.20.8 2007/09/12 19:25:48 puckett
+* commented out diagnostic message, don't want this printing out for every event
+*
+* Revision 1.32.20.7 2007/09/12 14:40:03 brash
+* *** empty log message ***
+*
+* Revision 1.32.20.6 2007/09/10 20:33:37 pcarter
+* Implemented changes to allow compilation on RHEL 3,4,5 and MacOSX
+*
+* Revision 1.32.20.5 2007/08/22 19:09:16 frw
+* added FPP
+*
+* Revision 1.4 4/2007 frw
+* added handling of VME data
+*
+* Revision 1.33 2006/06/22 frw
+* added FPP
+*
+* Revision 1.32.20.4 2007/06/20 18:34:43 puckett
+* Added BigCal Monte Carlo analysis capability
+*
+* Revision 1.32.20.3 2007/06/05 21:26:36 weiluo
+* Fix typo
+*
+* Revision 1.32.20.2 2007/06/04 15:01:48 puckett
+* *** empty log message ***
+*
+* Revision 1.32.20.1 2007/05/15 18:55:22 jones
+* Start Bigcal version
+*
+* Revision 1.32 2003/09/05 15:22:56 jones
+* Merge in online03 changes (mkj)
+*
+* Revision 1.31.2.1 2003/07/24 13:08:11 cdaq
+* Changes made for adding scaler ROC 5 during Baryon exp. (MKJ for SAW)
+*
+* Revision 1.31 2002/12/20 21:55:22 jones
+* Modified by Hamlet for new HMS aerogel
+*
+* Revision 1.30 1999/11/04 20:35:15 saw
+* Linux/G77 compatibility fixes
+*
+* Revision 1.29 1999/02/23 16:58:58 csa
+* (JRA) Add roc 20 handling
+*
+* Revision 1.28 1999/01/29 17:47:44 saw
+* Fix Typo
+*
+* Revision 1.27 1999/01/29 17:23:03 saw
+* Add second tubes to SOS shower counter
+*
+* Revision 1.26 1998/12/17 21:50:31 saw
+* Support extra set of tubes on HMS shower counter
+*
+* Revision 1.25 1998/12/01 15:54:26 saw
+* (SAW) Slight change in debugging output
+*
+* Revision 1.24 1996/11/08 15:48:01 saw
+* (WH) Add decoding for lucite counter
+*
+* Revision 1.23 1996/04/29 19:45:37 saw
+* (JRA) Update Aerogel variable names
+*
+* Revision 1.22 1996/01/22 15:13:56 saw
+* (JRA) Put BPM/Raster data into MISC data structures
+*
+* Revision 1.21 1996/01/16 20:49:40 cdaq
+* (SAW) Handle banks containing two parallel link ROC banks
+*
+* Revision 1.20 1995/12/06 19:04:24 cdaq
+* (SAW) What is this version? Two bank banks processing lost.
+*
+* Revision 1.19 1995/11/28 18:50:03 cdaq
+* (SAW) Quick hack to accept banks with 2 rocs (from parallel link)
+*
+* Revision 1.18 1995/10/09 18:20:51 cdaq
+* (JRA) Change HCER_ADC to HCER_RAW_ADC
+* Replace g_decode_getdid call with explicit calculation (for speed)
+*
+* Revision 1.17 1995/07/27 19:06:02 cdaq
+* (SAW) Use specific bit manipulation routines for f2c compatibility
+* Get FB roc from header on parallel link banks
+*
+* Revision 1.16 1995/05/22 20:50:45 cdaq
+* (SAW) Split gen_data_data_structures into gen, hms, sos, and coin parts"
+*
+* Revision 1.15 1995/05/22 13:35:40 cdaq
+* (SAW) Fix up some problems with decoding of parallel link wrappers around
+* fastbus events. Still doesn't hadle two fb rocs wrapped into one bank.
+*
+* Revision 1.14 1995/05/11 17:17:00 cdaq
+* (SAW) Extend || link hack for SOS. Add Aerogel detector.
+*
+* Revision 1.13 1995/04/01 19:44:50 cdaq
+* (SAW) Add BPM hitlist
+*
+* Revision 1.12 1995/01/27 20:12:48 cdaq
+* (SAW) Add hacks to deal with parallel link data. Pass lastslot variable to
+* g_decode_fb_detector so it can find 1881M/1877 headers.
+*
+* Revision 1.11 1994/11/22 20:13:02 cdaq
+* (SPB) Update array names for raw SOS Scintillator bank
+*
+* Revision 1.10 1994/06/28 20:01:23 cdaq
+* (SAW) Change arrays that HMS scintillators go into
+*
+* Revision 1.9 1994/06/18 02:45:49 cdaq
+* (SAW) Add code for miscleaneous data and uninstrumented channels
+*
+* Revision 1.8 1994/06/09 04:48:28 cdaq
+* (SAW) Fix length argument on gmc_mc_decode call again
+*
+* Revision 1.7 1994/04/13 18:49:10 cdaq
+* (KBB Fix length argument on gmc_mc_deocde call
+*
+*
+ implicit none
+ SAVE
+ external jishft, jiand, jieor
+*
+ character*16 here
+ parameter (here='g_decode_fb_bank')
+*
+ logical ABORT
+ character*(*) error
+ integer*4 bank(*)
+ logical SANE_TRUE
+ logical F1TRIGGER_TRUE
+ logical SEM_TRUE
+* This routine unpacks a ROC bank. It looks a fastbus word to
+* determine which detector it belongs to. It then passes the
+* appropriate arrays for that detector to detector independent unpacker
+* G_DECODE_FB_DETECTOR which will unpack words from the bank into the
+* hit arrays until the detector changes or it runs out of data.
+* G_DECODE_FB_DETECTOR returns a pointer to the next data word to be
+* processed.
+*
+ include 'gen_detectorids.par'
+ include 'gen_data_structures.cmn'
+ include 'hms_data_structures.cmn'
+ include 'sos_data_structures.cmn'
+ include 'gen_decode_common.cmn'
+ include 'mc_structures.cmn'
+ include 'gen_event_info.cmn'
+ include 'gen_scalers.cmn'
+cajp
+ include 'bigcal_data_structures.cmn'
+cajp
+ include 'gep_hist_id.cmn'
+
+ integer*4 iannoyingpulser
+ integer*4 pointer ! Pointer FB data word
+ integer*4 banklength,maxwords
+ integer*4 roc,subadd,slot,lastslot
+ integer*4 stat_roc
+ integer*4 slotp ! temp variable
+ integer*4 did ! Detector ID
+ integer*4 g_decode_fb_detector ! Detector unpacking routine
+ integer*4 last_first,i ! Last word of first bank in || bank
+*
+ integer*4 jiand, jishft, jieor ! Declare to help f2c
+ integer*4 hplus_ts,hmin_ts,quartet_ts,ntest,ts_input(9)
+
+ integer*4 ntrig
+
+c write(*,*)'Start'
+
+ banklength = bank(1) + 1 ! Bank length including count
+ last_first = banklength
+
+ stat_roc = jishft(bank(2),-16)
+ roc = jiand(stat_roc,'1F'X) ! Get ROC from header
+
+ if(roc.eq.20.or.roc.eq.5) then
+c write(*,*)'END'
+ return ! scaler ROC
+ endif
+
+ ntrig = 0
+ if(roc.eq.21) then
+ do i=1,9
+ ntest = 2**(i-1)
+ ts_input(i) = 0
+ if ( jiand(bank(3),ntest)/ntest .eq. 1 ) then
+ ts_input(i) = 1
+ if(i.le.8) ntrig = ntrig + 1
+ endif
+ gen_event_trigtype(i) = ts_input(i)
+ if(gepid_gep_trigtype.gt.0) then
+ call hf1(gepid_gep_trigtype,float(i),float(ts_input(i)))
+ endif
+
+ if(gepid_gep_trigtype_vs_evtype.gt.0) then
+ call hf2(gepid_gep_trigtype_vs_evtype,float(gen_event_type),
+ $ float(i),float(ts_input(i)))
+ endif
+ enddo
+ hplus_ts = 0
+ hmin_ts=0
+ quartet_ts=0
+ if ( jiand(bank(3),512)/512 .eq. 1 ) quartet_ts = 1
+ if ( jiand(bank(3),1024)/1024 .eq. 1 ) hplus_ts = 1
+ if ( jiand(bank(3),2048)/2048 .eq. 1) hmin_ts = 1
+
+ gen_event_trigtype(10) = quartet_ts
+ gen_event_trigtype(11) = hplus_ts
+ gen_event_trigtype(12) = hmin_ts
+
+ if(gepid_gep_ntrigs.gt.0) then
+ call hf1(gepid_gep_ntrigs,float(ntrig),1.)
+ endif
+
+ if(gepid_gep_trigtype.gt.0) then
+ call hf1(gepid_gep_trigtype,10.,float(quartet_ts))
+ call hf1(gepid_gep_trigtype,11.,float(hplus_ts))
+ call hf1(gepid_gep_trigtype,12.,float(hmin_ts))
+ endif
+
+ if(gepid_gep_trigtype_vs_evtype.gt.0) then
+ call hf2(gepid_gep_trigtype_vs_evtype,float(gen_event_type),
+ $ 10.,float(quartet_ts))
+ call hf2(gepid_gep_trigtype_vs_evtype,float(gen_event_type),
+ $ 11.,float(hplus_ts))
+ call hf2(gepid_gep_trigtype_vs_evtype,float(gen_event_type),
+ $ 12.,float(hmin_ts))
+ endif
+
+ if(hplus_ts.gt.0 .and. hmin_ts.eq.0) then
+ gbeam_helicity_TS = 1
+ else if(hplus_ts.eq.0 .and. hmin_ts .gt.0) then
+ gbeam_helicity_TS = -1
+ else
+ gbeam_helicity_TS = 0
+ endif
+
+c write(*,*) ' hel min = ',hmin_ts,' hel plus = ',hplus_ts
+c > ,ts_input
+c write(*,*)'END'
+ return ! scaler ROC
+ endif
+*
+* First look for special Monte Carlo Banks
+*
+ if(stat_roc.eq.mc_status_and_ROC) then
+* call gmc_mc_decode(banklength-2,bank(3),ABORT,error)
+ ABORT = .TRUE.
+ error = 'Monte Carlo Event analysis disabled'
+ if(ABORT) then
+ call g_add_path(here,error)
+ endif
+c write(*,*)'END'
+ return
+ endif
+*
+ if(roc.gt.G_DECODE_MAXROCS) then
+ ABORT = .false. ! Just warn
+ write(error,*) ':ROC out of range, ROC#=',roc
+ call g_add_path(here,error)
+c write(*,*)'END'
+ return
+ endif
+*
+ pointer = 3 ! First word of bank
+*
+ if (roc.eq.7 .or. roc.eq.8 .or. roc.eq.9) then
+*
+* These 3 rocs are VME front ends for fastbus crates. At present
+* we assume that each VME front end is only taking data from one
+* FB roc and that this FB roc # is in 4 word of the bank. This
+* hack will not work when we have roc 8 taking data from both
+* fbch1 and fbch2. But it should work for runs up through
+* at least 5/31/95.
+*
+ last_first = pointer + bank(pointer) ! Last word in sub bank
+ stat_roc = jishft(bank(pointer+1),-16)!2 words are fb roc header.
+ roc = jiand(stat_roc,'1F'X)
+ pointer=pointer+2 !using parallel link, so next
+ endif
+
+ lastslot = -1
+ do while (pointer .le. banklength)
+ if(pointer.eq.(last_first+1)) then ! Second bank in a two bank bank
+ last_first = banklength ! Reset to end of second bank
+ stat_roc = jishft(bank(pointer+1),-16) !2 words are fb roc header
+ roc = jiand(stat_roc,'1F'X) ! New roc
+ endif
+*
+* Look for and report empty ROCs.
+*
+ if (jieor(bank(pointer),'DCFF0000'X).eq.0) then
+ if (roc.eq.1 .or. roc.eq.2) then !missing hms data
+ if (gen_event_type.ne.2) then !event type 2 is sos only event.
+ write(6,'(a,i3,a,i8,a,z8,a,i2)') 'roc',roc,' has no data for event'
+ & ,gen_event_id_number,' scanmask=',bank(pointer+1)
+ $ ,', evtype=',gen_event_type
+ endif
+ else !missing sos data
+ if (gen_event_type.ne.1) then !event type 1 is hms only data.
+ write(6,'(a,i3,a,i8,a,z8,a,i2)') 'roc',roc,' has no data for event'
+ & ,gen_event_id_number,' scanmask=',bank(pointer+1)
+ $ ,', evtype=',gen_event_type
+ endif
+ endif
+ endif
+*
+ slot = jiand(jishft(bank(pointer),-27),'1F'X)
+
+ if(slot.gt.0.and.slot.le.G_DECODE_MAXSLOTS .and.
+ $ roc.gt.0 .and. roc.le.g_decode_maxrocs) then
+
+* * for F1 TDCs, the traditional subadd cut will not work!
+* * we need the header word which contains the trigger time to
+* * handle roll-over, but the header has the subadd at the very LSB
+* *
+* * so we branch depending on externally supplied VME ROC flag to
+* * properly handle these headers and all data words
+* * note that we really WANT to see the header words for trigger timing!
+* *
+* * for F1 TDC, there are two types of data:
+* * header/trailer words and data words
+* *
+* * ,overflow Xor
+* * header/trailer: xxxx xxxx 0 ? ?? ???? ???? ???? ? ? ?? ? ???
+* * | T_trigger | channel
+* * event no chip
+* *
+* * data: xxxx xxxx 1 0 ?? ? ??? ???? ???? ???? ????
+* * chip chan ------ data -------
+* *
+* * in both cases, the first 8 bits (xxxx xxxx) are as follows:
+* *
+* * ???? ? ???
+* * slot error flags
+* *
+* * data have 16 bits for TDC count, i.e. 0-65535
+* * but header's T_trigger only has 9 bits, i.e. 0-511
+*
+ if (g_decode_modtyp(roc,slot).eq.0) then ! FastBus
+ subadd = jiand(jishft(bank(pointer),
+ $ -g_decode_subaddbit(roc,slot)),'7F'X)
+
+ elseif (g_decode_modtyp(roc,slot).eq.1) then !VME F1 TDC
+* * F1 uses 1 as the first channel, not 0!!!
+ if (jiand(ishft(bank(pointer),-23),'1'X).eq.0) then !header
+ subadd = jiand(bank(pointer),'3F'X) + 1
+ else !data
+ subadd = jiand(jishft( bank(pointer),
+ $ -g_decode_subaddbit(roc,slot) ),'3F'X) + 1
+ subadd = (subadd - 1) / 2 + 1
+
+ endif
+ endif
+
+c if (subadd .lt. '7F'X) then ! Only valid subaddress
+ if (subadd .lt. 255) then ! Only valid subaddress
+ ! This skips module headers
+
+ slotp = g_decode_slotpointer(roc,slot)
+ if (slotp.gt.0) then
+ did = g_decode_didmap(slotp+subadd)
+ else
+ did = UNINST_ID
+ endif
+c if(roc.eq.12.and.slot.eq.5) write(6,
+c > '(''found did with roc,slot'',3i6)')
+c > did,roc,slot
+
+
+ maxwords = last_first - pointer + 1
+
+ SANE_TRUE = did.eq.LUCITE_SANE_ID.or.did.eq.LUCITE_SANE_ID2.or.
+ & did.eq.LUCITE_SANE_ID3.or.
+ & did.eq.CERENKOV_SANE_ID.or.
+ & did.eq.CERENKOV_SANE_ID2.or.
+ & did.eq.TRACKER_SANE_X_ID.or.
+ & did.eq.TRACKER_SANE_Y_ID
+ F1TRIGGER_TRUE = did.eq.F1TRIGGER_ID
+ SEM_TRUE = did.eq.SEM_ID
+c write(*,*)did,roc,slot,slotp,subadd
+c if(did.gt.0)write(*,*)did,roc,slot,slotp,subadd
+
+*
+* 1 2 3 4 5 6 7
+*23456789012345678901234567890123456789012345678901234567890123456789012
+*
+
+ if(did.eq.HDC_ID) then
+ pointer = pointer +
+ $ g_decode_fb_detector(lastslot, roc, bank(pointer),
+ & maxwords, did,
+ $ HMAX_DC_HITS, HDC_RAW_TOT_HITS, HDC_RAW_PLANE_NUM,
+ $ HDC_RAW_WIRE_NUM,1 ,HDC_RAW_TDC,0, 0, 0)
+
+ else if (did.eq.HSCIN_ID) then
+ pointer = pointer +
+ $ g_decode_fb_detector(lastslot, roc, bank(pointer),
+ & maxwords, did,
+ $ HMAX_ALL_SCIN_HITS, HSCIN_ALL_TOT_HITS,
+ $ HSCIN_ALL_PLANE_NUM, HSCIN_ALL_COUNTER_NUM, 4,
+ $ HSCIN_ALL_ADC_POS, HSCIN_ALL_ADC_NEG,
+ $ HSCIN_ALL_TDC_POS, HSCIN_ALL_TDC_NEG)
+c if(gen_event_type.eq.1) then
+c write(6,'(''dbg'',i4,i14,3i8)')
+c > roc,bank(pointer),
+c $ HMAX_ALL_SCIN_HITS, HSCIN_ALL_TOT_HITS
+c > ,pointer
+c do i=1,HSCIN_ALL_TOT_HITS
+c write(6,'(i4,6i8)') i,
+c > HSCIN_ALL_PLANE_NUM(i),
+c > HSCIN_ALL_COUNTER_NUM(i),
+c > HSCIN_ALL_TDC_POS(i),
+c > HSCIN_ALL_TDC_NEG(i),
+c > HSCIN_ALL_ADC_POS(i),
+c > HSCIN_ALL_ADC_NEG(i)
+c enddo
+c endif
+ else if (did.eq.HCAL_ID) then
+ pointer = pointer +
+ $ g_decode_fb_detector(lastslot, roc, bank(pointer),
+ & maxwords, did,
+ $ HMAX_CAL_BLOCKS, HCAL_TOT_HITS, HCAL_COLUMN,
+ $ HCAL_ROW, 2, HCAL_ADC_POS, HCAL_ADC_NEG, 0, 0)
+
+ else if (did.eq.HCER_ID) then
+*
+* Cerenkov has no plane array. Pass it HCER_COR_ADC. Unpacker will
+* fill it with zeros or ones. (Or whatever we tell the unpacker the
+* plane number is.)
+*
+ pointer = pointer +
+ $ g_decode_fb_detector(lastslot, roc, bank(pointer),
+ & maxwords, did,
+ $ HMAX_CER_HITS, HCER_TOT_HITS, HCER_PLANE,
+ $ HCER_TUBE_NUM, 1, HCER_RAW_ADC, 0, 0, 0)
+
+*
+*====================== HMS AEROGEL ==================================
+*
+
+ else if (did.eq.HAERO_ID) then
+*
+* Aerogel has two tubes for each "counter". Since we may use all
+* TDC's, we will tell the decoder that we have 4 signals, array
+* 3rd and 4th will use for TDC signals.
+*
+* HAERO_PLANE is a dummy array.
+*
+ pointer = pointer +
+ $ g_decode_fb_detector(lastslot, roc, bank(pointer),
+ & maxwords, did,
+ $ HMAX_AERO_HITS, HAERO_TOT_HITS, HAERO_PLANE,
+ $ HAERO_PAIR_NUM, 4, HAERO_ADC_POS, HAERO_ADC_NEG,
+ $ HAERO_TDC_POS, HAERO_TDC_NEG)
+
+* print *,'HAERO_TDC_POS',HAERO_TDC_POS
+* print *,'HAERO_TDC_NEG',HAERO_TDC_NEG
+
+*
+*====================== HMS Focal Plane Polarimeter ==================
+*
+ else if (did.eq.HFPP_ID) then
+*
+* planes are DC layers of all chambers in order of increasing z-coord
+*
+c write(*,*) 'did = fpp, decoding fpp data'
+ pointer = pointer +
+ $ g_decode_fb_detector(lastslot, roc, bank(pointer),
+ & maxwords, did,
+ $ H_FPP_MAX_RAWHITS, HFPP_raw_tot_hits,
+ $ HFPP_raw_plane, HFPP_raw_wire, 1, HFPP_raw_TDC, 0, 0, 0)
+
+*
+*
+************************************************************************
+c
+c SANE DECODER
+c
+
+ else if(SANE_TRUE)then
+ call sane_decode(pointer,lastslot, roc, bank,
+ & maxwords, did)
+***************************************
+c
+c F1 Trigger Decode
+c
+ else if(F1TRIGGER_TRUE)then
+ call F1TRIGGER_decode(pointer,lastslot, roc, bank,
+ & maxwords, did)
+ else if(SEM_TRUE)then
+***********************************
+c
+c SEM Decode
+c
+ call sem_decode(pointer,lastslot, roc, bank,
+ & maxwords, did)
+
+*===================== BIGCAL ==========================================
+ else if (did.eq.BIGCAL_PROT_ID) then
+ !write(*,*) 'did = protvino, decoding protvino data'
+ pointer = pointer +
+ $ g_decode_fb_detector(lastslot, roc, bank(pointer),
+ $ maxwords, did, BIGCAL_PROT_MAXHITS, BIGCAL_PROT_NHIT,
+ $ BIGCAL_PROT_IY, BIGCAL_PROT_IX, 1, BIGCAL_PROT_ADC_RAW,
+ $ 0, 0, 0)
+ !write(*,*) 'protvino data decoded successfully'
+ else if (did.eq.BIGCAL_RCS_ID) then
+ !write(*,*) 'did = rcs, decoding rcs data'
+ pointer = pointer +
+ $ g_decode_fb_detector(lastslot, roc, bank(pointer),
+ $ maxwords, did, BIGCAL_RCS_MAXHITS, BIGCAL_RCS_NHIT,
+ $ BIGCAL_RCS_IY, BIGCAL_RCS_IX, 1, BIGCAL_RCS_ADC_RAW,
+ $ 0, 0, 0)
+ !write(*,*) 'rcs data decoded successfully'
+ else if (did.eq.BIGCAL_TDC_ID) then
+ !write(*,*) 'did = tdc, decoding tdc data'
+ pointer = pointer +
+ $ g_decode_fb_detector(lastslot, roc, bank(pointer),
+ $ maxwords, did, BIGCAL_TDC_MAXHITS, BIGCAL_TDC_NHIT,
+ $ BIGCAL_TDC_RAW_IROW, BIGCAL_TDC_RAW_IGROUP, 1,
+ $ BIGCAL_TDC_RAW, 0, 0, 0)
+ !write(*,*) 'tdc data decoded successfully'
+ else if (did.eq.BIGCAL_ATRIG_ID) then
+ !write(*,*) 'did = trig, decoding trig data'
+ pointer = pointer +
+ $ g_decode_fb_detector(lastslot, roc, bank(pointer),
+ $ maxwords, did, BIGCAL_ATRIG_MAXHITS, BIGCAL_ATRIG_NHIT,
+ $ BIGCAL_ATRIG_IGROUP, BIGCAL_ATRIG_IHALF, 1,
+ $ BIGCAL_ATRIG_ADC_RAW, 0,0,0)
+ !write(*,*) 'trig data decoded successfully'
+ else if (did.eq.BIGCAL_TTRIG_ID) then
+ pointer = pointer +
+ $ g_decode_fb_detector(lastslot,roc, bank(pointer),
+ $ maxwords, did, BIGCAL_TTRIG_MAXHITS, BIGCAL_TTRIG_NHIT,
+ $ BIGCAL_TTRIG_IGROUP, BIGCAL_TTRIG_IHALF, 1,
+ $ BIGCAL_TTRIG_TDC_RAW, 0,0,0)
+* figure out if this is an annoying pulser event:
+ do iannoyingpulser=1,bigcal_ttrig_nhit
+ if(bigcal_ttrig_igroup(iannoyingpulser).eq.20.and.
+ $ bigcal_ttrig_ihalf(iannoyingpulser).eq.1) then
+ bigcal_annoying_pulser_event = .true.
+ endif
+ enddo
+
+*======================= HMISC ================================================
+
+ else if (did.eq.HMISC_ID) then
+*
+* This array is for data words that don't belong to a specific
+* detector counter. Things like energy sums, and TDC's from various
+* points in the logic will go here. Most likely we will set ADDR1
+* always to 1, and ADDR2 will start at 1.
+*
+ pointer = pointer +
+ $ g_decode_fb_detector(lastslot, roc, bank(pointer),
+ & maxwords, did,
+ $ HMAX_MISC_HITS, HMISC_TOT_HITS, HMISC_RAW_ADDR1,
+ $ HMISC_RAW_ADDR2, 1, HMISC_RAW_DATA, 0, 0, 0)
+
+*
+* 1 2 3 4 5 6 7
+*23456789012345678901234567890123456789012345678901234567890123456789012
+*
+ else if(did.eq.SDC_ID) then
+ pointer = pointer +
+ $ g_decode_fb_detector(lastslot, roc, bank(pointer),
+ & maxwords, did,
+ $ SMAX_DC_HITS, SDC_RAW_TOT_HITS, SDC_RAW_PLANE_NUM,
+ $ SDC_RAW_WIRE_NUM,1 ,SDC_RAW_TDC,0, 0, 0)
+
+ else if (did.eq.SSCIN_ID) then
+ pointer = pointer +
+ $ g_decode_fb_detector(lastslot, roc, bank(pointer),
+ & maxwords, did,
+ $ SMAX_ALL_SCIN_HITS, SSCIN_ALL_TOT_HITS,
+ $ SSCIN_ALL_PLANE_NUM, SSCIN_ALL_COUNTER_NUM, 4,
+ $ SSCIN_ALL_ADC_POS, SSCIN_ALL_ADC_NEG,
+ $ SSCIN_ALL_TDC_POS, SSCIN_ALL_TDC_NEG)
+
+ else if (did.eq.SCAL_ID) then
+ pointer = pointer +
+ $ g_decode_fb_detector(lastslot, roc, bank(pointer),
+ & maxwords, did,
+ $ SMAX_CAL_BLOCKS, SCAL_TOT_HITS, SCAL_COLUMN,
+ $ SCAL_ROW, 2, SCAL_ADC_POS, SCAL_ADC_NEG, 0, 0)
+
+ else if (did.eq.SCER_ID) then
+*
+ pointer = pointer +
+ $ g_decode_fb_detector(lastslot, roc, bank(pointer),
+ & maxwords, did,
+ $ SMAX_CER_HITS, SCER_TOT_HITS, SCER_PLANE,
+ $ SCER_TUBE_NUM, 1, SCER_RAW_ADC, 0, 0, 0)
+
+ else if (did.eq.SAER_ID) then
+*
+* Aerogel has two tubes for each "counter". Since there are no
+* TDC's, we will tell the decoder that we have 4 signals, but pass
+* a dummy array for the 3rd and 4th signal.
+*
+* SAER_PLANE is a dummy array.
+*
+ pointer = pointer +
+ $ g_decode_fb_detector(lastslot, roc, bank(pointer),
+ & maxwords, did,
+ $ SMAX_AER_HITS, SAER_TOT_HITS, SAER_PLANE,
+ $ SAER_PAIR_NUM, 4, SAER_ADC_POS, SAER_ADC_NEG,
+ $ SAER_DUMMY, SAER_DUMMY)
+
+ else if (did.eq.SLUC_ID) then
+*
+* Lucite has two tubes for each "counter". The detector
+* has both ADC's and TDC's signals.
+*
+*
+* SLUC_PLANE is a dummy array.
+*
+ pointer = pointer +
+ $ g_decode_fb_detector(lastslot, roc, bank(pointer),
+ & maxwords, did,
+ $ SMAX_LUC_HITS, SLUC_TOT_HITS, SLUC_PLANE,
+ $ SLUC_PAIR_NUM, 4, SLUC_ADC_POS, SLUC_ADC_NEG,
+ $ SLUC_TDC_POS, SLUC_TDC_NEG)
+
+ else if (did.eq.SMISC_ID) then
+*
+* This array is for data words that don't belong to a specific
+* detector counter. Things like energy sums, and TDC's from various
+* points in the logic will go here. Most likely we will set ADDR1
+* always to 1, and ADDR2 will start at 1.
+*
+ pointer = pointer +
+ $ g_decode_fb_detector(lastslot, roc, bank(pointer),
+ & maxwords, did,
+ $ SMAX_MISC_HITS, SMISC_TOT_HITS, SMISC_RAW_ADDR1,
+ $ SMISC_RAW_ADDR2, 1, SMISC_RAW_DATA, 0, 0, 0)
+
+*
+* BPM/Raster ADC values.
+*
+ else if (did.eq.GMISC_ID) then
+ pointer = pointer +
+ $ g_decode_fb_detector(lastslot, roc, bank(pointer),
+ & maxwords, did,
+ $ GMAX_MISC_HITS, GMISC_TOT_HITS, GMISC_RAW_ADDR1,
+ $ GMISC_RAW_ADDR2, 1, GMISC_RAW_DATA, 0, 0, 0)
+
+
+*
+* Data from Uninstrumented channels and slots go into a special array
+*
+ else if (did.eq.UNINST_ID) then
+ pointer = pointer +
+ $ g_decode_fb_detector(lastslot, roc, bank(pointer),
+ & maxwords, did,
+ $ GMAX_UNINST_HITS, GUNINST_TOT_HITS, GUNINST_RAW_ROCSLOT,
+ $ GUNINST_RAW_SUBADD, 1, GUNINST_RAW_DATAWORD, 0, 0, 0)
+
+ else
+* Should never get here. Unknown detector ID's or did=-1 for bad ROC#
+* or SLOT# will come here.
+*
+ print *,"BAD DID, unknown ROC,SLOT",roc,slot,did
+ pointer = pointer + 1 ! Skip unknown detector id's
+ endif
+ else
+ lastslot = slot
+ pointer = pointer + 1 ! Skip Bad subaddresses (module header)
+ endif
+*
+ else
+ pointer = pointer + 1 ! Skip bad slots
+ endif
+*
+ enddo
+ ABORT= .FALSE.
+ error= ' '
+c write(*,*)'END'
+ return
+ end
+**************
+* Local Variables:
+* mode: fortran
+* fortran-if-indent: 2
+* fortran-do-indent: 2
+* End:
diff --git a/ENGINE/g_decode_fb_detector.f b/ENGINE/g_decode_fb_detector.f
new file mode 100644
index 0000000..be3bf98
--- /dev/null
+++ b/ENGINE/g_decode_fb_detector.f
@@ -0,0 +1,501 @@
+ INTEGER*4 FUNCTION g_decode_fb_detector(oslot,roc,evfrag,length,did,
+ $ maxhits,hitcount,planelist,counterlist,signalcount,signal0,
+ $ signal1,signal2,signal3)
+*----------------------------------------------------------------------
+*- Created ? Steve Wood, CEBAF
+*- Corrected 3-Dec-1993 Kevin Beard, Hampton U.
+* $Log: g_decode_fb_detector.f,v $
+* Revision 1.23.20.13.2.5 2009/01/30 20:33:29 cdaq
+* *** empty log message ***
+*
+* Revision 1.23.20.13.2.4 2008/10/31 07:54:39 cdaq
+* comment out some warnings on detector limits
+*
+* Revision 1.23.20.13.2.3 2008/10/02 17:58:28 cdaq
+* *** empty log message ***
+*
+* Revision 1.23.20.13.2.2 2008/09/25 18:43:14 cdaq
+* Updated for F1 hi res
+*
+* Revision 1.23.20.13.2.1 2008/05/15 18:59:21 bhovik
+* 1'st version
+*
+* Revision 1.23.20.13 2007/10/22 18:39:00 cdaq
+* adjusted HMS FPP histos
+*
+* Revision 1.23.20.11 2007/10/19 00:15:20 cdaq
+* *** empty log message ***
+*
+* Revision 1.23.20.10 2007/10/18 16:25:26 cdaq
+* fixed F1 handling bug
+*
+* Revision 1.23.20.9 2007/10/17 22:02:15 cdaq
+* fix FPP bugs
+*
+* Revision 1.23.20.8 2007/10/16 23:26:10 cdaq
+* *** empty log message ***
+*
+* Revision 1.23.20.7 2007/10/16 23:23:34 cdaq
+* fixed F1 data decoding
+*
+* Revision 1.23.20.6 2007/10/16 22:17:20 cdaq
+* fixed F1 decoding bug
+*
+* Revision 1.23.20.5 2007/09/24 20:37:20 puckett
+* *** empty log message ***
+*
+* Revision 1.23.20.4 2007/09/11 19:14:17 frw
+* fixed FPP related arrays and limits
+*
+* Revision 1.23.20.3 2007/09/10 20:33:37 pcarter
+* Implemented changes to allow compilation on RHEL 3,4,5 and MacOSX
+*
+* Revision 1.23.20.2 2007/08/22 19:09:16 frw
+* added FPP
+*
+* Revision 1.24 frw
+* added processing of F1 TDCs
+*
+* Revision 1.23.20.1 2007/05/15 02:55:01 jones
+* Start to Bigcal code
+*
+* Revision 1.23 2003/09/05 15:31:23 jones
+* Merge in online03 changes (mkj)
+*
+* Revision 1.22.2.1 2003/07/24 13:08:11 cdaq
+* Changes made for adding scaler ROC 5 during Baryon exp. (MKJ for SAW)
+*
+* Revision 1.22 2002/09/25 14:40:03 jones
+* Eliminate commented out diagnostic messages and the variables
+* buffer,iscaler,nscalers associated with them.
+*
+* Revision 1.21 1999/11/04 20:35:16 saw
+* Linux/G77 compatibility fixes
+*
+* Revision 1.20 1998/12/17 21:50:31 saw
+* Support extra set of tubes on HMS shower counter
+*
+* Revision 1.19 1998/12/01 15:54:57 saw
+* (SAW) Slight change in debugging output
+*
+* Revision 1.18 1997/04/03 10:56:05 saw
+* (SAW) Better report of DCFE code words. Prints out roc, slot, event
+* number and how many extra events are in the module.
+*
+* Revision 1.17 96/09/04 14:34:19 14:34:19 saw (Stephen A. Wood)
+* (JRA) More error reporting of error codes in FB data stream
+*
+* Revision 1.16 1996/04/29 19:46:19 saw
+* (JRA) Tweak diagnostic messages
+*
+* Revision 1.15 1996/01/16 20:51:55 cdaq
+* (SAW) Fixes: Forgot why
+*
+* Revision 1.14 1995/11/28 18:59:24 cdaq
+* (SAW) Change arrays that use roc as index to start with zero.
+*
+* Revision 1.13 1995/10/09 18:23:29 cdaq
+* (JRA) Comment out some debugging statements
+*
+* Revision 1.12 1995/07/27 19:10:02 cdaq
+* (SAW) Use specific bit manipulation routines for f2c compatibility
+*
+* Revision 1.11 1995/01/31 15:55:52 cdaq
+* (SAW) Make sure mappointer and subaddbit are set on program entry.
+*
+* Revision 1.10 1995/01/27 20:14:04 cdaq
+* (SAW) Add assorted diagnostic printouts. Add hack to look for the headers
+* on new 1881M/1877 modules while maintaining backward compatibility.
+*
+* Revision 1.9 1994/10/20 12:34:55 cdaq
+* (SAW) Only print out "Max exceeded did=" meesage once
+*
+* Revision 1.8 1994/06/27 02:14:18 cdaq
+* (SAW) Ignore all words that start with DC
+*
+* Revision 1.7 1994/06/22 20:21:24 cdaq
+* (SAW) Put -1 in hodoscope signals that don't get any data
+*
+* Revision 1.6 1994/06/22 20:07:37 cdaq
+* (SAW) Fix problems with filling of hodoscope type hit lists (multiple signal)
+*
+* Revision 1.5 1994/06/21 16:02:54 cdaq
+* (SAW) Ignore DCFF0000 headers from Arrington's CRL's
+*
+* Revision 1.4 1994/06/18 02:48:04 cdaq
+* (SAW) Add code for miscleaneous data and uninstrumented channels
+*
+* Revision 1.3 1994/04/06 18:03:38 cdaq
+* (SAW) # of bits to get channel number is now configurable (g_decode_subaddbit).
+* Changed range of signal types from 1:4 to 0:3 to agree with documentation.
+*
+* Revision 1.2 1994/03/24 22:00:15 cdaq
+* Temporarily change shift to get subaddress from 17 to 16
+*
+* Revision 1.1 1994/02/04 21:50:03 cdaq
+* Initial revision
+*
+*----------------------------------------------------------------------
+ implicit none
+ SAVE
+ external jishft, jiand, jieor
+*
+* The following arguments don't get modified.
+ integer*4 roc,evfrag(*),length,did,maxhits,signalcount
+
+* The following arguments get modified.
+ integer*4 oslot
+ integer*4 hitcount,planelist(*),counterlist(*)
+ integer*4 signal0(*),signal1(*),signal2(*),signal3(*)
+ integer pointer,newdid,subadd,slot,mappointer,plane
+ integer counter,signal,sigtyp
+*
+ include 'gen_detectorids.par'
+ include 'gen_decode_common.cmn'
+ include 'gen_decode_F1tdc.cmn'
+ include 'gen_scalers.cmn'
+ include 'gen_event_info.cmn'
+
+ include 'hms_data_structures.cmn'
+ include 'hms_id_histid.cmn'
+*
+ integer h,hshift,i
+ integer*4 trigger_time
+ integer subaddbit
+ logical printerr !flag to turn off printing of error after 1 time.
+ logical firsttime
+*
+ integer*4 jishft, jiand, jieor, nprt
+*
+ printerr = .true.
+ pointer = 1
+ newdid = did
+
+ firsttime = .true.
+ do while(pointer.le.length .and. did.eq.newdid)
+*
+ if(jieor(jiand(evfrag(pointer),'FFFFFFFF'x),'DCAA0000'x).eq.0) then ! VME/FB event length mismatch
+ write(6,'(a,i10)') 'ERROR: VME/Fastbus event
+ & length mismatch for event #',gen_event_id_number
+ write(6,'(a,z9,a,z9,a)') ' Fastbus event length:',evfrag(pointer+1),
+ & ' VME event length:',evfrag(pointer+2),' (or vice-versa).'
+ pointer = pointer + 3
+ goto 987
+! Check for extra events in FB modules on sync events
+ else if(jieor(jiand(evfrag(pointer),'FFFF0000'x),'DCFE0000'x).eq.0) then
+ write(6,'(a,i2,a,i3,a,i3,a,i10)') 'ROC',roc,': Slot'
+ $ ,jiand(jishft(evfrag(pointer),-11),'1F'x),': '
+ $ ,jiand(evfrag(pointer),'7FF'x),' extra events, event=',
+ & gen_event_id_number
+ pointer = pointer + 1
+ goto 987
+ else if(jieor(jiand(evfrag(pointer),'FF000000'x),'DC000000'x).eq.0) then ! Catch arrington's headers
+ write(6,'(a,i2,a,i10,a,z10)') 'ROC',roc,': no gate
+ & or too much data, event=',
+ & gen_event_id_number,' error dataword=',evfrag(pointer)
+ pointer = pointer + 1
+ goto 987
+ endif
+
+
+ if(evfrag(pointer).le.1.and.evfrag(pointer).ge.0) then
+
+! on sync events, get zeros at end of event.
+ if (gen_event_id_number .eq. 1000*int(gen_event_id_number/1000)) then
+ if (evfrag(pointer).ne.0) then
+
+ write(6,'(" ERROR: BAD FB value evfrag(",i4,")=",z10,
+ & " ROC=",i2,"event=",i7)')
+ $ pointer,evfrag(pointer),roc,gen_event_id_number
+ endif
+ endif
+ pointer = pointer + 1
+ goto 987
+ endif
+ slot = jiand(JISHFT(evfrag(pointer),-27),'1F'X)
+ if(slot.ne.oslot.or.firsttime) then
+ if (slot.le.0 .or. slot.ge.26 .or. roc.le.0 .or. roc.ge.G_DECODE_MAXSLOTS) then
+c write (6,'(a,i3,i3,i3,z10,a,i5,a,i8)') 'roc,slot,oslot,evfrag=',roc,
+c & slot,oslot,evfrag(pointer),
+c $ '(p=',pointer,') for event #',gen_event_id_number
+c write (6,'(a,i3)') ' Probably after slot',jiand(JISHFT(evfrag(pointer-1),-27),'1F'X)
+ pointer = pointer + 1
+ goto 987
+ else
+ mappointer = g_decode_slotpointer(roc,slot)
+ subaddbit = g_decode_subaddbit(roc,slot) ! Usually 16 or 17
+ endif
+ endif
+
+ if(slot.ne.oslot) then
+ oslot = slot
+ trigger_time = -1 !flag absence of header data via default of error
+
+
+c
+c On 1881M's and 1877, a subaddress of zero could be a header word, so
+c we need to put in some hackery to catch these. We need to make sure
+c that 1881's and 1876's will still work.
+c
+c A real ugly hack that looks to see if the first word of an 1881M or
+c 1877 has a subaddress of zero, in which case it is the header word and must
+c be discarded. If it is an 1881 or 1876, then the the first word of a
+c new slot will have a subaddress of '7F' and later be discarded.
+c
+ if(subaddbit.eq.17.and.g_decode_modtyp(roc,slot).eq.0) then ! Is not an 1872A (which has not headers)
+ if(jiand(evfrag(pointer),'00FE0000'X).eq.0) then ! probably a header
+ if(jiand(evfrag(pointer),'07FF0000'X).ne.0) then
+ print *,"SHIT:misidentified real data word as a header"
+ print *,"DID=",did,", SLOT=",slot,", POINTER=",pointer
+ else
+c if(roc.eq.12.and.slot.eq.4.and.subadd.lt.32)
+c , write(*,*)"Jump 1 ROC12 SLOT4 CHAN=",subadd
+ pointer = pointer + 1
+ goto 987
+ endif
+ endif
+ endif
+
+ endif !oslot
+*
+* * for F1 TDCs, the TDC counts are ABSOLUTE with a random zero value
+* * to get the time relative to a triggering event, the trigger must be
+* * recorded as well in a TDC channel
+* * a low-resolution measure of the trigger is provided in the data header
+* * but this is insufficient for time measurements
+* * it *is* however good for detecting roll-over of the free running
+* * absolute time, as it overflows at the same time as the measured values
+* *
+* * so we branch depending on externally supplied VME ROC flag
+* *
+* * for F1 TDC, there are two types of data:
+* * header/trailer words and data words
+* *
+* * ,overflow Xor
+* * header/trailer: xxxx xxxx 0 ? ?? ???? ???? ???? ? ? ?? ? ???
+* * | T_trigger | channel
+* * event no chip
+* *
+* * data: xxxx xxxx 1 0 ?? ? ??? ???? ???? ???? ????
+* * chip chan ------ data -------
+* *
+* * in both cases, the first 8 bits (xxxx xxxx) are as follows:
+* *
+* * ???? ? ???
+* * slot error flags
+* *
+* * data have 16 bits for TDC count, i.e. 0-65535
+* * but header's T_trigger only has 9 bits, i.e. 0-511
+*
+ if (g_decode_modtyp(roc,slot).eq.0) then ! fastbus
+ subadd = jiand(JISHFT(evfrag(pointer),-subaddbit),'7F'X)
+
+ elseif (g_decode_modtyp(roc,slot).eq.1) then ! VME F1 TDC
+* * F1 uses 1 as the first channel, not 0!!!
+ if (jiand(ishft(evfrag(pointer),-23),'1'X).eq.1) then !data
+ subadd = jiand(jishft(evfrag(pointer),-subaddbit),'3F'X) + 1
+cc For hi res mode, have to take in pairs
+ if(subadd.lt.1.or.subadd.gt.64)
+ > write(6,'(''ERROR'',i6)') subadd
+ subadd = (subadd - 1) / 2 + 1
+ signal =jiand(evfrag(pointer),g_decode_slotmask(roc,slot))
+c if(roc.eq.13.and.slot.eq.18)
+c > write(6,'(''subadd,signal='',5i10)') roc,slot,did,
+c > subadd,signal,gen_event_id_number,counter
+
+ if (signal.eq.65535) then ! skip overflow entries
+ pointer = pointer + 1
+
+ goto 987
+ endif
+
+* * histogram F1 raw hits
+c write(6,'(''hf2'',4i10)') roc,
+c > hid_rawROC(roc),slot,subadd
+c call hf2(hid_rawROC(roc),float(slot),float(subadd),1.)
+c write(6,'(''hf2'',4i10)') roc,
+c > hid_rawROC(roc),slot,subadd
+
+ else !header
+ subadd = jiand(evfrag(pointer),'3F'X) + 1
+ trigger_time = jiand(ishft(evfrag(pointer),-7),'1FF'X)
+ trigger_time = trigger_time*128 + 127 ! trigger time has 7 bits less resolution!!
+ pointer = pointer + 1
+ goto 987
+ endif
+ endif
+*
+* If a module that uses a shift of 17 for the subaddress is in a slot
+* that we havn't told the map file about, it's data will end up in the
+* unstrimented channel "detector" hit list. However, the decoder will
+* think that the subaddress starts in channel 16 (since some Lecroy
+* modules do so), The next statement will mean that only the first 64
+* channels will end up in the uninstrumented hit list. The rest will
+* be lost. If you don't want to put this module in the map file, put
+* in a single entry for it with a detector id of UNINST_ID (zero) and
+* the proper BSUB value.
+*
+c if (subadd .lt. '7F'X) then ! Only valid subaddresses
+ if (subadd .lt. 255) then ! Only valid subaddresses
+c if(roc.eq.12.and.slot.eq.21.and.subadd.lt.17)
+c , write(*,*)"ROC12 SLOT 21 CHAN=",subadd,signal
+c if(roc.eq.12.and.slot.eq.4.and.subadd.eq.40)
+c , write(*,*)"ROC12 SLOT4 CHAN=",subadd
+c if(roc.eq.12.and.slot.eq.4.and.subadd.eq.43)
+c , write(*,*)"ROC12 SLOT4 CHAN=",subadd
+c if(roc.eq.12.and.slot.eq.4.and.subadd.eq.44)
+c , write(*,*)"ROC12 SLOT4 CHAN=",subadd
+ ! Skips headers for 1881 and 1876
+c write(6,'(''did'',2i10)') did
+ if(mappointer.gt.0) then
+ newdid = g_decode_didmap(mappointer+subadd)
+ else
+ newdid = UNINST_ID
+ endif
+c write(6,'(''old,newdid'',2i10)') newdid,did
+ if(newdid.eq.did) then
+ if(did.ne.UNINST_ID) then
+c write(6,'(''plane'',i8)') mappointer+subadd
+ plane = g_decode_planemap(mappointer+subadd)
+c write(6,'(''plane'',i8)') plane
+ counter = g_decode_countermap(mappointer+subadd)
+c write(6,'(''counter'',i8)') counter
+ signal =jiand(evfrag(pointer),g_decode_slotmask(roc,slot))
+c write(6,'(''signal'',i8)') signal
+* fix roll-over if module is F1 TDC
+c if (g_decode_modtyp(roc,slot).eq.1) then
+c if (signal.lt.trigger_time) then ! roll-over!!
+c signal = signal + F1TDC_WINDOW_SIZE(roc)
+c write(6,'(''signalcorr'',i8)') signal
+c endif
+c endif
+ else
+ plane = jishft(roc,16) + slot
+ counter = subadd
+ signal = evfrag(pointer)
+c write(6,'(''p,c,s'',3i8)') plane,counter,signal
+ endif
+ if(hitcount .lt. maxhits .or.
+ $ (hitcount.eq.maxhits .and. signalcount .gt. 1)) then ! Don't overwrite arrays
+ if(signalcount .le. 1) then ! single signal counter
+*
+* Starting at end of hit list, search back until a hit earlier in
+* the sort order is found.
+*
+ h = hitcount
+ do while(h .gt. 0 .and. (plane .lt. planelist(h)
+ $ .or.(plane .eq. planelist(h).and. counter .lt.
+ $ counterlist(h))))
+*
+* Shift hit to next place in list
+*
+ planelist(h+1) = planelist(h)
+ counterlist(h+1) = counterlist(h)
+ signal0(h+1) = signal0(h)
+ h = h - 1
+ enddo
+ h = h + 1 ! Put hit pointer to blank
+ if(did.eq.6 .and. nprt .lt.10) then
+c write(6,'(''dbg gmisc'',6i8)') roc,slot,
+c > plane,counter,signal
+ nprt = nprt + 1
+ endif
+ planelist(h) = plane
+ counterlist(h) = counter
+ signal0(h) = signal
+ hitcount = hitcount + 1
+c if(did.eq.25) write(6,'(''dbg did 25'',
+c > 8i8)') h,plane,counter,signal,hitcount,
+c > roc,slot
+ else ! Multiple signal counter sigcount= 2 or 4 allowed
+*
+* Starting at the end of the hist list, search back until a hit on
+* the same counter or earlier in the sort order is found.
+*
+ h = hitcount
+ do while(h .gt. 0 .and. (plane .lt. planelist(h)
+ $ .or.(plane .eq. planelist(h).and. counter .lt.
+ $ counterlist(h))))
+ h = h - 1
+ enddo
+*
+* If plane/counter match is not found, then need to shift up the array
+* to make room for the new hit.
+*
+ if(h.le.0.or.plane.ne.planelist(h) ! Plane and counter
+ $ .or.counter.ne.counterlist(h)) then ! not found
+ if(hitcount.lt.maxhits) then
+ h = h + 1
+ do hshift=hitcount,h,-1 ! Shift up to make room
+ planelist(hshift+1) = planelist(hshift)
+ counterlist(hshift+1) = counterlist(hshift)
+ signal0(hshift+1) = signal0(hshift)
+ signal1(hshift+1) = signal1(hshift)
+ if(signalcount.eq.4) then
+ signal2(hshift+1) = signal2(hshift)
+ signal3(hshift+1) = signal3(hshift)
+ endif
+ enddo
+ planelist(h) = plane
+ counterlist(h) = counter
+ signal0(h) = -1
+ signal1(h) = -1
+ if(signalcount.eq.4) then
+ signal2(h) = -1
+ signal3(h) = -1
+ endif
+ hitcount = hitcount + 1
+ else ! Too many hits
+ if(printerr) then
+c print *,'g_decode_fb_detector: Max exceeded, did=',
+c $ did,', max=',maxhits,': event',gen_event_id_number
+c print *,' roc,slot,cntr,sig,subadd=',roc,slot,counter,sigtyp,subadd
+ printerr = .false.
+ endif
+ endif
+ endif
+*
+ sigtyp = g_decode_sigtypmap(mappointer+subadd)
+*
+ if(sigtyp.eq.0) then
+ signal0(h) = signal
+ else if (sigtyp.eq.1) then
+ signal1(h) = signal
+ else if (sigtyp.eq.2) then
+ signal2(h) = signal
+ else if (sigtyp.eq.3) then
+ signal3(h) = signal
+ endif
+ endif !multi-signal
+
+ else if(hitcount.eq.maxhits .and. printerr) then ! Only print this message once
+c print *,'g_decode_fb_detector: Max exceeded, did=',
+c $ did,', max=',maxhits,': event',gen_event_id_number
+c print *,' roc,slot,cntr=',roc,slot,counter
+ printerr = .false.
+*
+* Print/generate some kind of error that the hit array has been
+* exceeded.
+*
+ endif
+ pointer = pointer + 1
+* else
+* exit and get called back with the correct arrays for the new did
+ endif
+ else
+ pointer = pointer + 1
+ endif
+ 987 continue
+
+ enddo
+
+ g_decode_fb_detector = pointer - 1 ! Number of words processed
+
+ return
+ end
+**************
+* Local Variables:
+* mode: fortran
+* fortran-if-indent: 2
+* fortran-do-indent: 2
+* End:
diff --git a/ENGINE/g_decode_init.f b/ENGINE/g_decode_init.f
new file mode 100644
index 0000000..e4ecc7d
--- /dev/null
+++ b/ENGINE/g_decode_init.f
@@ -0,0 +1,56 @@
+ SUBROUTINE G_decode_init(ABORT,err)
+*----------------------------------------------------------------------
+*- Prototype hall C initialize routine
+*-
+*- Purpose and Methods : Initialization decoding algorithm
+*-
+*- Output: ABORT - success or failure
+*- : err - reason for failure, if any
+*-
+*- Created 3-Dec-1993 Kevin B. Beard
+*
+* $Log: g_decode_init.f,v $
+* Revision 1.3 1996/01/16 20:54:59 cdaq
+* no change
+*
+* Revision 1.2 1994/03/24 18:15:59 cdaq
+* (SAW) Move g_decode_clear into this routine.
+*
+* Revision 1.1 1994/02/04 21:51:53 cdaq
+* Initial revision
+*
+*-
+*- All standards are from "Proposal for Hall C Analysis Software
+*- Vade Mecum, Draft 1.0" by D.F.Geesamn and S.Wood, 7 May 1993
+*-
+*--------------------------------------------------------
+ IMPLICIT NONE
+ SAVE
+*
+ character*40 here
+ parameter (here= 'G_decode_init')
+*
+ logical ABORT
+ character*(*) err
+*
+ INCLUDE 'gen_filenames.cmn' !names of config. files
+*
+*--------------------------------------------------------
+*
+*-all crucial setup information here; failure is fatal
+*
+ call g_decode_clear(ABORT,err)
+ if(ABORT) then
+ call G_add_path(here,err)
+ return
+ endif
+*
+ call G_decode_config(ABORT,err,g_decode_map_filename)
+ IF(ABORT) THEN
+ call G_add_path(here,err)
+ ELSE
+ err= ' '
+ ENDIF
+*
+ RETURN
+ END
diff --git a/ENGINE/g_decode_scalers.f b/ENGINE/g_decode_scalers.f
new file mode 100644
index 0000000..44c3f83
--- /dev/null
+++ b/ENGINE/g_decode_scalers.f
@@ -0,0 +1,66 @@
+ subroutine g_analyze_scalers(event,ABORT,err)
+*
+* $Log: g_decode_scalers.f,v $
+* Revision 1.1 1994/06/22 20:59:25 cdaq
+* Initial revision
+*
+*
+ implicit none
+ integer*4 event(*)
+*
+ character*17 here
+ parameter (here='g_analyze_scalers')
+*
+ logical ABORT
+ character*(*) err
+*
+ INCLUDE 'gen_scalers.cmn'
+*
+* Scaler events have a header in from of each scaler. High 16 bits
+* will contain the address (the switch settings). Address for hall C
+* will be of the form DANN, where NN is the scaler number. The low 16
+* bits will contain the number of scaler values to follow (this should
+* be no larger than 16, but we will allow more.)
+*
+ integer evtype, evlen, pointer
+ integer scalid, countinmod, address, counter
+
+*
+ evtype = ishft(event(2),-16)
+*
+* Should check against list of known scaler events
+*
+ evlen = event(1) + 1
+ if(evlen.gt.3) then ! We have a scaler bank
+ pointer = 5
+*
+ do while(pointer.lt.evlen)
+*
+ scalid = iand(ishft(event(pointer),-16),'FF'x)
+ countinmod = iand(event(pointer),'FFFF'x)
+*
+* Might want to check that count is not to big.
+*
+ if(countinmod.ne.16) then
+ err = 'Scaler module header word has count<>16'
+ ABORT = .true.
+ call g_add_path(here,err)
+ return ! Safest action
+ endif
+*
+ address = scalid*16
+ do counter = 1,countinmod
+ scalers(address+counter) = event(pointer) + counter
+ enddo
+ pointer = pointer + countinmod
+ enddo
+ else
+ err = 'Event not big enough to contain scalers'
+ ABORT = .true.
+ call g_add_path(here,err)
+ return
+ endif
+
+ return
+ end
+
diff --git a/ENGINE/g_dump_histograms.f b/ENGINE/g_dump_histograms.f
new file mode 100644
index 0000000..0494075
--- /dev/null
+++ b/ENGINE/g_dump_histograms.f
@@ -0,0 +1,69 @@
+ SUBROUTINE G_dump_histograms(ABORT,err)
+*--------------------------------------------------------
+*- Routine to dump the histograms
+*-
+*-
+*- Output: ABORT - success or failure
+*- : err - reason for failure, if any
+*-
+*- Created 14-Jun-1994 S.A. Wood
+* $Log: g_dump_histograms.f,v $
+* Revision 1.3 2002/09/25 14:42:06 jones
+* Replace call HREND(nametag) with call HRENDC(nametag) and close(IO)
+*
+* Revision 1.2 1995/04/01 19:45:37 cdaq
+* (SAW) Allow %d for run number in filenames
+*
+* Revision 1.1 1994/06/14 19:13:42 cdaq
+* Initial revision
+*
+
+ IMPLICIT NONE
+ SAVE
+*
+ character*17 here
+ parameter (here= 'G_dump_histograms')
+*
+ logical ABORT
+ character*(*) err
+*
+ INCLUDE 'gen_filenames.cmn'
+ INCLUDE 'gen_run_info.cmn'
+*
+ character*132 file
+ character*80 default_histfile
+ parameter (default_histfile='engine_output.hbk')
+ integer istat
+ character*4 nametag
+ parameter (nametag='RAWH')
+ integer cycle,IO
+
+ err = ' '
+ IO= G_LUN_TEMP ! temporary IO channel
+ file= g_histout_filename ! File to write histograms into
+ if(file.EQ.' ') file= default_histfile
+ call g_sub_run_number(file,gen_run_number)
+*
+* call G_open_HBOOK_file(IO,file,'NEW',ABORT,err) !FORTRAN file open
+*
+ call hropen(IO,nametag,file,'N',1024,ISTAT)
+*
+ ABORT = .false. ! Need to check ISTAT
+*
+ IF(.NOT.ABORT) THEN
+* call HRFILE(IO,nametag,'N') !tell HBOOK to use channel IO (New)
+ cycle= 0 !dummy for internal counting
+ call HROUT(0,cycle,' ') !CERNLIB flush buffers, all histograms
+* call HREND(nametag) !done with this channel
+ call HRENDC(nametag) !done with this channel
+ close (IO)
+ ENDIF
+*
+ return
+ end
+
+
+
+
+
+
diff --git a/ENGINE/g_dump_peds.f b/ENGINE/g_dump_peds.f
new file mode 100644
index 0000000..0f1348e
--- /dev/null
+++ b/ENGINE/g_dump_peds.f
@@ -0,0 +1,48 @@
+ subroutine g_dump_peds(ABORT,err)
+*
+* $Log: g_dump_peds.f,v $
+* Revision 1.1 1996/04/29 19:46:35 saw
+* Initial revision
+*
+ implicit none
+ save
+*
+ character*12 here
+ parameter (here='g_dump_peds')
+*
+ logical ABORT
+ character*(*) err
+*
+ integer*4 ind
+ character*132 file
+
+ integer SPAREID
+ parameter (SPAREID=67)
+*
+ INCLUDE 'gen_data_structures.cmn'
+ INCLUDE 'gen_filenames.cmn'
+ INCLUDE 'gen_run_info.cmn'
+
+
+ if (g_pedestal_output_filename.ne.' ') then
+ file=g_pedestal_output_filename
+ call g_sub_run_number(file, gen_run_number)
+ open(unit=SPAREID,file=file,status='unknown')
+ else
+ return
+ endif
+
+ write(SPAREID,*) 'These are the values that were used for the analysis'
+ write(SPAREID,*) ' (from the param file or pedestal events)'
+ write(SPAREID,*)
+*
+* MISC PEDESTALS
+*
+ write(SPAREID,*) 'gmisc_ped = '
+ write(SPAREID,113) (gmisc_ped(ind,2),ind=1,16)
+113 format (7(f6.1,','),f6.1)
+
+ close(SPAREID)
+
+ return
+ end
diff --git a/ENGINE/g_examine_control_event.f b/ENGINE/g_examine_control_event.f
new file mode 100644
index 0000000..c57f877
--- /dev/null
+++ b/ENGINE/g_examine_control_event.f
@@ -0,0 +1,160 @@
+ SUBROUTINE G_examine_control_event(buffer,ABORT,err)
+*--------------------------------------------------------
+*-
+*- Purpose and Methods : examine a control event and gather various
+*- information from it.
+*-
+*- Input: buffer - raw data buffer
+*- : ABORT - success or failure
+*- : err - reason for failure, if any
+*-
+*- Created 17-May-1994 Kevin B. Beard, Hampton U.
+* $Log: g_examine_control_event.f,v $
+* Revision 1.7.24.1 2007/09/10 20:33:37 pcarter
+* Implemented changes to allow compilation on RHEL 3,4,5 and MacOSX
+*
+* Revision 1.7 1999/11/04 20:35:16 saw
+* Linux/G77 compatibility fixes
+*
+* Revision 1.6 1995/07/27 19:37:29 cdaq
+* (SAW) Use specific bit manipulation routines for f2c compatibility
+*
+* Revision 1.5 1994/06/28 20:04:49 cdaq
+* *** empty log message ***
+*
+* Revision 1.4 1994/06/24 19:11:26 cdaq
+* (KBB) Fill in gen_event_type with the event type
+*
+* Revision 1.3 1994/06/09 04:29:44 cdaq
+* (SAW) Replace g_build_note calls with write(var, ... calls
+*
+* Revision 1.2 1994/06/07 18:18:45 cdaq
+* (SAW) Split g_examine_event into g_examine_control_event
+* and g_examine_physics_event.
+*
+*-
+*- All standards are from "Proposal for Hall C Analysis Software
+*- Vade Mecum, Draft 1.3" by D.F.Geesamn and S.Wood, Csoft-NOTE-94-001
+*-
+*--------------------------------------------------------
+ IMPLICIT NONE
+ SAVE
+ external jishft, jiand, jieor, bjtest
+*
+ character*23 here
+ parameter (here= 'G_examine_control_event')
+*
+ INTEGER buffer(*)
+ LOGICAL ABORT
+ CHARACTER*(*) err
+*
+ INCLUDE 'gen_run_info.cmn'
+ INCLUDE 'gen_event_info.cmn'
+*
+ integer dy,mth,yr,hr,minute,sec,m,EvType,status,nth
+ logical control,bad_sync
+ character*160 msg,note
+ integer*4 jiand,jishft,jieor
+ logical*4 bjtest
+*
+ integer SYNC_EvType,PRESTART_EvType,GO_EvType,END_EvType
+ integer PAUSE_EvType
+ parameter (SYNC_EvType = 16) !from CODA manual
+ parameter (PRESTART_EvType = 17) !from CODA manual
+ parameter (GO_EvType = 18) !from CODA manual
+ parameter (PAUSE_EvType = 19) !from CODA manual
+ parameter (END_EvType = 20) !from CODA manual
+*
+*----------------------------------------------------------------------
+ err= ' '
+*
+ gen_event_sequence_N= gen_event_sequence_N+1 !from beginning
+*
+ if(jieor(jiand(buffer(2),'FFFF'x),'01CC'x).ne.0) then
+ err = 'Event is not a control event'
+ ABORT = .true.
+ call g_add_path(here,err)
+ return
+ endif
+ EvType = jISHFT(buffer(2),-16)
+
+ gen_event_ID_number= 0
+ gen_event_type= EvType
+ gen_event_class= 0
+*
+ If(EvType.EQ.SYNC_EvType) Then
+*
+ gen_run_UTC_last= buffer(3)
+ gen_run_total_events= buffer(5)
+ call g_UTC_date(gen_run_UTC_last,gen_run_date_last,
+ & dy,mth,yr,hr,minute,sec)
+*
+ status= buffer(6)
+ bad_sync= status.NE.0
+ ABORT= bad_sync
+ if(bad_sync) then
+ err= ' '
+ DO nth=0,31
+ If(BjTEST(status,nth)) Then
+ write(msg,'(", ROC #",i3)') nth
+ call G_append(err,msg)
+ EndIf
+ ENDDO
+ write(msg,'("event #",i10)') gen_run_total_events
+ call G_prepend(':CODA synchronization failure '//note,err)
+ call G_append(err,':'//gen_run_date_last)
+ call G_add_path(here,err)
+ IF(ABORT) RETURN
+ endif
+*
+ ElseIf(EvType.EQ.PRESTART_EvType) Then
+*
+ gen_run_UTC_start= buffer(3)
+ gen_run_number= buffer(4)
+ gen_run_type= buffer(5)
+ call g_UTC_date(gen_run_UTC_start,gen_run_date_start,
+ & dy,mth,yr,hr,minute,sec)
+*
+ gen_event_sequence_N= 1 !start counting over
+ gen_run_total_events= 1
+*
+ do m=0,gen_MAX_trigger_types !clear triggered table
+ gen_run_triggered(m)= 0
+ enddo
+*
+ write(msg,'("INFO:PRESTART Run #",i5," type #",i4,1x,a)')
+ $ gen_run_number,gen_run_type,gen_run_date_start
+ call G_log_message(msg)
+*
+ ElseIf(EvType.EQ.GO_EvType) Then
+*
+ gen_run_UTC_start= buffer(3)
+ call g_UTC_date(gen_run_UTC_start,gen_run_date_start,
+ & dy,mth,yr,hr,minute,sec)
+*
+ msg= 'INFO:GO '//gen_run_date_start
+ call G_log_message(msg)
+*
+ ElseIf(EvType.EQ.PAUSE_EvType) Then
+*
+ gen_run_UTC_last= buffer(3)
+ gen_run_total_events= buffer(5)
+ call g_UTC_date(gen_run_UTC_last,gen_run_date_last,
+ & dy,mth,yr,hr,minute,sec)
+ msg= 'INFO:PAUSE '//gen_run_date_last
+ call G_log_message(msg)
+*
+ ElseIf(EvType.EQ.END_EvType) Then
+*
+ gen_run_UTC_stop= buffer(3)
+ gen_run_total_events= buffer(5)
+ call g_UTC_date(gen_run_UTC_stop,gen_run_date_stop,
+ & dy,mth,yr,hr,minute,sec)
+*
+ msg= 'INFO:END '//gen_run_date_stop
+ call G_log_message(msg)
+*
+ EndIf
+*
+ RETURN
+ END
diff --git a/ENGINE/g_examine_epics_event.f b/ENGINE/g_examine_epics_event.f
new file mode 100644
index 0000000..f22aa05
--- /dev/null
+++ b/ENGINE/g_examine_epics_event.f
@@ -0,0 +1,138 @@
+ subroutine g_examine_epics_event
+* $Log: g_examine_epics_event.f,v $
+* Revision 1.5.20.1.2.4 2010/12/06 18:31:13 jones
+* Add IF statements to set half wave plate status during analysis
+* according run number
+* Exception for run 72608 and 72612
+*
+* Revision 1.5.20.1.2.3 2009/09/02 13:38:35 jones
+* add readout of halfwave plate status
+*
+* Revision 1.5.20.1.2.1 2009/03/31 19:33:00 cdaq
+* *** empty log message ***
+*
+* Revision 1.5.20.1 2007/09/10 20:33:37 pcarter
+* Implemented changes to allow compilation on RHEL 3,4,5 and MacOSX
+*
+* Revision 1.5 2003/09/05 15:28:05 jones
+* Merge in online03 changes (mkj)
+*
+* Revision 1.4.2.1 2003/08/14 00:17:55 cdaq
+* Modifly so that gdebugdumpepics=1,2,3 means dump 30 sec epics varaibles,
+* 2 sec epics variables, or both. (mkj)
+*
+* Revision 1.4 1999/06/10 14:41:03 csa
+* (JRA) Added dump for numevent up to 10
+*
+* Revision 1.3 1998/12/01 15:55:40 saw
+* (SAW) Print out error when event has no data
+*
+* Revision 1.2 1996/11/05 21:40:32 saw
+* (JRA) Print out just first epics event
+*
+* Revision 1.1 1996/08/12 18:30:13 saw
+* Initial revision
+*
+*--------------------------------------------------------
+ implicit none
+ save
+ external jieor
+
+ character buffer*12000
+ equivalence (craw(5), buffer)
+ integer i,j,evlen
+ integer g_important_length,find_char
+ integer evtype
+ integer numevent
+ logical dump_event
+ integer*4 jishft
+ integer HALFWAVE
+ include 'gen_craw.cmn'
+ include 'gen_run_info.cmn'
+ include 'gen_filenames.cmn'
+ include 'sane_ntuple.cmn'
+*
+* event type =131 30 second epics read
+* event type =132 2 second epics read
+* when gdebugdumpepics=1,2,3 dump 131,132, both
+*--------------------------------------------------------
+
+ numevent = numevent + 1
+
+ if (g_epics_output_filename.ne.' ' .and.
+ & (gdebugdumpepics.ge.1 )) then !write out event
+ dump_event = .true.
+ else
+ dump_event = .false.
+ return
+ endif
+c
+ evtype = jishft(craw(2),-16)
+ if (evtype-gdebugdumpepics .gt. 130) dump_event = .false.
+
+c
+ if (dump_event) write (G_LUN_EPICS_OUTPUT,*) 'epics event #',numevent
+
+ if (craw(3)-1.le.0) then
+ write (6,*)
+ 1 '**g_examine_epics_event: bad record length; numevent=',
+ 1 numevent,', craw3=',craw(3)
+ return
+ endif
+c
+ half_plate=+1 ! before run 72412
+ if (gen_run_number .ge. 72412) half_plate= -1
+ if (gen_run_number .ge. 72609) half_plate= +1
+ if (gen_run_number .ge. 72613) half_plate= -1
+ if (gen_run_number .ge. 72618) half_plate= +1
+ if (gen_run_number .ge. 72733) half_plate= -1
+ if (gen_run_number .ge. 72832) half_plate= +1
+ if (gen_run_number .ge. 72896) half_plate= -1
+ if (gen_run_number .ge. 72926) half_plate= +1
+ if (gen_run_number .ge. 72953) half_plate= -1
+ if (gen_run_number .ge. 73012) half_plate= +1
+c
+cccc write (6,*) 'epics,evlen',evlen,numevent,craw(3)
+
+ evlen=g_important_length(buffer(1:4*(craw(3)-1)))
+ i = 1
+cccc write (6,*) 'epics,evlen',evlen,numevent,craw(3)
+c polarea=-1000.
+ polarization_ch = .FALSE.
+ do while (i.le.evlen)
+ j = find_char (buffer, i, 10) ! 10 = NewLine character
+ if (i.eq.j) goto 20
+ if(i.lt.j-1 .and. dump_event) write(G_LUN_EPICS_OUTPUT,'(4x,a)') buffer(i:j-1)
+ if (i+11.le.j-1) then !text line.
+c ********** read out the BPMs (POS values first...) **********
+ if (buffer(i:i+11).eq.'hcptNMR_Area') then
+ read(buffer(i+13:j-1),*,err=20) polarea
+c write(*,*)"HERE IS POLARIZATION",polarea
+ polarization_ch = .TRUE.
+ ENDIF ! hcptNMR_Area
+ if (buffer(i:i+15).eq.'hcptPolarization')then
+ read(buffer(i+16:j-1),*,err=20)polarization
+
+ endif
+ if (buffer(i:i+14).eq.'IGL1I00DI24_24M') then
+ read(buffer(i+16:j-1),*,err=20)HALFWAVE
+c write(*,*)'WAVE PLATE ',HALFWAVE
+ if ( gen_run_number .eq. 72608 .or. gen_run_number .eq. 72612) then
+ half_plate=0.
+ if(HALFWAVE.eq.0)half_plate=-1.
+ if(HALFWAVE.eq.1)half_plate=1.
+ endif
+ endif
+ ENDIF
+ 20 i = j + 1
+ enddo
+c call system("rm fort.21")
+c call system
+c & ("tail -n 361 scalers/epics72252.txt |
+c & grep NMR_A | awk '{ print $2}'>fort.21")
+c read(21,*)polarea
+c write(*,*)'HERE IS EPIC EVENT',polarea
+c close(21)
+c write(*,*) gen_run_number," halfwave = ", half_plate,halfwave
+ return
+ end
diff --git a/ENGINE/g_examine_go_info.f b/ENGINE/g_examine_go_info.f
new file mode 100644
index 0000000..f825101
--- /dev/null
+++ b/ENGINE/g_examine_go_info.f
@@ -0,0 +1,178 @@
+ SUBROUTINE G_examine_go_info(buffer,ABORT,err)
+*-----------------------------------------------------
+*-
+*- Purpose and Methods : examine the go information and gather various
+*- quantities
+*-
+*- Input: buffer - raw data buffer
+*- : ABORT - success or failure
+*- : err - reason for failure, if any
+*-
+*- Created 30-Nov-1995 John Arrington, Caltech.
+*-
+* $Log: g_examine_go_info.f,v $
+* Revision 1.4.20.3 2007/11/02 22:36:16 cdaq
+* Added code to extract additional prescale factors
+*
+* Revision 1.4.20.2 2007/09/11 19:14:17 frw
+* fixed FPP related arrays and limits
+*
+* Revision 1.4.20.1 2007/09/10 20:33:37 pcarter
+* Implemented changes to allow compilation on RHEL 3,4,5 and MacOSX
+*
+* Revision 1.4 2003/09/05 15:37:28 jones
+* Merge in online03 changes (mkj)
+*
+* Revision 1.3.2.1 2003/04/09 02:49:42 cdaq
+* Update code to look for prescale factors in go_info event from ANY crate, also have it skip the nped=1000 line when extracting prescale factors
+*
+* Revision 1.3 1999/11/04 20:35:16 saw
+* Linux/G77 compatibility fixes
+*
+* Revision 1.2 1996/09/04 14:35:16 saw
+* (JRA) Extract prescale factors
+*
+* Revision 1.1 1995/12/08 20:07:54 cdaq
+* Initial revision
+*
+*--------------------------------------------------------
+ IMPLICIT NONE
+ SAVE
+ external jishft, jiand, jieor
+*
+ character*18 here
+ parameter (here= 'G_examine_go_info')
+*
+ INTEGER buffer(*)
+ LOGICAL ABORT
+ CHARACTER*(*) err
+*
+ include 'gen_detectorids.par'
+ include 'gen_decode_common.cmn'
+ include 'gen_run_info.cmn'
+*
+ integer EvType
+ integer*4 pointer,subpntr,ind
+ integer*4 evlen,sublen,subheader,slotheader,numvals
+ integer*4 roc,slot
+ integer*4 jiand,jishft,jieor
+ logical*4 found_thresholds,found_prescale
+ character*80 prescale_string
+ character*4 tmpstring
+ integer*4 ilo,prescale_len,ilo2
+ integer*4 nped
+* functions
+ integer g_important_length
+*
+*----------------------------------------------------------------------
+ err= ' '
+*
+ EvType = jISHFT(buffer(2),-16)
+ if (evtype.ne.133) then
+ err = 'Event is not a control event'
+ ABORT = .true.
+ call g_add_path(here,err)
+ return
+ endif
+*
+ found_thresholds = .false.
+ found_prescale = .false.
+ prescale_string = ' '
+ evlen = buffer(1)
+
+
+c write(6,*) 'evlen=',buffer(1)
+ pointer = 3 !1=#/words, 2=event type
+ roc= (jiand(buffer(2),'FF'x))
+c write(6,*) 'roc=',roc,'evtype=',evtype
+
+ do while (.not.found_thresholds .and. pointer.le.evlen)
+ sublen=buffer(pointer)
+c write(6,*) ' sublen=',sublen
+ subheader=buffer(pointer+1)
+c write(6,'(a,z10)') ' subheader=',subheader
+
+ if (jieor(jishft(jiand(subheader,'FF0000'x),-16),'10'x).eq.0) then !thresholds
+ found_thresholds = .true.
+c write(6,*) ' THRESHOLDS!'
+ subpntr=2 !skip past main subheader.
+c write(6,*) ' subpntr=',subpntr
+ do while (subpntr .lt. sublen)
+ slotheader=buffer(pointer+subpntr)
+ slot=jishft(jiand(slotheader,'FF000000'x),-24)
+c write(6,'(a,z10)') ' slotheader=',slotheader
+ numvals=jiand(slotheader,'FF'x)
+c write(6,*) ' slot#',slot,' has ',numvals,' thresholds'
+ do ind=1,numvals
+ subpntr=subpntr+1
+ g_threshold_readback(ind,roc,slot)=buffer(pointer+subpntr)
+c write(6,*) 'g_threshold_readback(',ind,roc,slot,')=',g_threshold_readback(ind,roc,slot)
+ enddo
+ subpntr=subpntr+1 !skip to next slotheader
+c write(6,*) 'subpntr=',subpntr
+ enddo !NEED CHECK FOR NEXT HEADER.
+ pointer=pointer+subpntr
+*
+* Used to look at TS0 (roc=0) for prescales, but for daq03, there is
+* no go_info event for TS0, so just take any crate with prescales.
+*
+* else if (roc.eq.0 .and.
+* & jieor(jishft(jiand(subheader,'FF0000'x),-16),'02'x).eq.0) then
+*
+ else if (jieor(jishft(jiand(subheader,'FF0000'x),-16),'02'x).eq.0) then
+c write(6,*) 'PRESCALE FACTORS'
+ found_prescale=.true.
+ do ind=2,sublen
+c write(6,'(3x,a,i4,2x,a4) ') 'ind=',ind,buffer(pointer+ind)
+ write(tmpstring,'(a4)') buffer(pointer+ind)
+ prescale_string(4*(ind-2)+1:4*(ind-1)) = tmpstring
+ enddo
+ prescale_len=4*(sublen-1)
+ pointer=pointer+sublen+1
+ else
+c write(6,*) ' NOT THRESHOLDS,NOT PS FACTORS. WHO CARES.'
+ pointer=pointer+sublen+1
+ endif
+ enddo
+*
+ if (found_prescale .and. prescale_len.ne.0) then
+ prescale_len = g_important_length(prescale_string(1:prescale_len))
+ ilo=index(prescale_string(1:prescale_len),'nped=')+5
+ ilo2=ilo+index(prescale_string(ilo:prescale_len),',')-1
+ if (ilo2 .lt. ilo) ilo2 = prescale_len
+ read(prescale_string(ilo:ilo2),*,err=998) nped
+ ilo=index(prescale_string(1:prescale_len),'ps1=')+4
+ ilo2=ilo+index(prescale_string(ilo:prescale_len),',')-1
+ if (ilo2 .lt. ilo) ilo2 = prescale_len
+ read(prescale_string(ilo:ilo2),*,err=998) gps1
+ ilo=index(prescale_string(1:prescale_len),'ps2=')+4
+ ilo2=ilo+index(prescale_string(ilo:prescale_len),',')-1
+ if (ilo2 .lt. ilo) ilo2 = prescale_len
+ read(prescale_string(ilo:ilo2),*,err=998) gps2
+ ilo=index(prescale_string(1:prescale_len),'ps3=')+4
+ ilo2=ilo+index(prescale_string(ilo:prescale_len),',')-1
+ if (ilo2 .lt. ilo) ilo2 = prescale_len
+ read(prescale_string(ilo:ilo2),*,err=998) gps3
+ ilo=index(prescale_string(1:prescale_len),'ps4=')+4
+ ilo2=ilo+index(prescale_string(ilo:prescale_len),',')-1
+ if (ilo2 .lt. ilo) ilo2 = prescale_len
+ read(prescale_string(ilo:ilo2),*,err=998) gps4
+ ilo=index(prescale_string(1:prescale_len),'ps5=')+4
+ ilo2=ilo+index(prescale_string(ilo:prescale_len),',')-1
+ if (ilo2 .lt. ilo) ilo2 = prescale_len
+ read(prescale_string(ilo:ilo2),*,err=998) gps5
+ ilo=index(prescale_string(1:prescale_len),'ps6=')+4
+ ilo2=ilo+index(prescale_string(ilo:prescale_len),',')-1
+ if (ilo2 .lt. ilo) ilo2 = prescale_len
+ read(prescale_string(ilo:ilo2),*,err=998) gps6
+ ilo=index(prescale_string(1:prescale_len),'ps7=')+4
+ ilo2=ilo+index(prescale_string(ilo:prescale_len),',')-1
+ if (ilo2 .lt. ilo) ilo2 = prescale_len
+ read(prescale_string(ilo:ilo2),*,err=998) gps7
+ endif
+*
+ goto 999
+998 write(6,*) 'WARNING: g_examine_go_info.f >>> error extracting prescale factors, giving up'
+999 continue
+ RETURN
+ END
diff --git a/ENGINE/g_examine_physics_event.f b/ENGINE/g_examine_physics_event.f
new file mode 100644
index 0000000..d8bf725
--- /dev/null
+++ b/ENGINE/g_examine_physics_event.f
@@ -0,0 +1,138 @@
+ SUBROUTINE G_examine_physics_event(buffer,ABORT,err)
+*--------------------------------------------------------
+*-
+*- Purpose and Methods : examine event and decide whether to process
+*- further
+*-
+*- Input: buffer - raw data buffer
+*- Output: process - worth processing
+*- : ABORT - success or failure
+*- : err - reason for failure, if any
+*-
+*- Created 17-May-1994 Kevin B. Beard, Hampton U.
+* $Log: g_examine_physics_event.f,v $
+* Revision 1.4.24.2.2.1 2009/02/16 00:18:13 cdaq
+* *** empty log message ***
+*
+* Revision 1.4.24.2 2007/09/13 04:02:17 brash
+* Implement some minor changes to fix Mac OS X runtime errors ... ejb
+*
+* Revision 1.4.24.1 2007/09/10 20:33:37 pcarter
+* Implemented changes to allow compilation on RHEL 3,4,5 and MacOSX
+*
+* Revision 1.4 1999/11/04 20:35:16 saw
+* Linux/G77 compatibility fixes
+*
+* Revision 1.3 1996/01/16 20:57:18 cdaq
+* no change
+*
+* Revision 1.2 1995/07/27 19:11:15 cdaq
+* (SAW) Use specific bit manipulation routines for f2c compatibility
+* Remove event number limit checking
+*
+* Revision 1.1 1994/06/07 18:19:03 cdaq
+* Initial revision
+*
+*-
+*- All standards are from "Proposal for Hall C Analysis Software
+*- Vade Mecum, Draft 1.3" by D.F.Geesamn and S.Wood, Csoft-NOTE-94-001
+*-
+*--------------------------------------------------------
+ IMPLICIT NONE
+ SAVE
+ external jishft, jiand, jieor
+*
+ character*23 here
+ parameter (here= 'G_examine_physics_event')
+
+ INTEGER buffer(*)
+ccc LOGICAL process
+ LOGICAL ABORT
+ CHARACTER*(*) err
+*
+ INCLUDE 'gen_run_info.cmn'
+ INCLUDE 'gen_event_info.cmn'
+*
+ integer evtype
+ logical eventidbank, nontrivial
+ integer*8 EventIDbank_size,EventIDbank_desc_hex,EventIDbank_desc
+*
+ integer*4 jiand,jishft,jieor
+*
+ parameter (EventIDbank_size= 4)
+ parameter (EventIDbank_desc_hex= '40000100'x) !from CODA manual
+*
+ EventIDbank_desc=-1*EventIDbank_desc_hex+512
+ gen_event_sequence_N= gen_event_sequence_N+1 !from beginning
+*
+ if(jieor(jiand(buffer(2),'FFFF'x),'10CC'x).ne.0) then
+ err = 'Event is not a physics event'
+ ABORT = .true.
+ call g_add_path(here,err)
+ return
+ endif
+ EvType = jISHFT(buffer(2),-16)
+*
+ gen_run_total_events= gen_run_total_events+1
+* gen_event_type= EvType
+*
+ ABORT= EvType.LT.0 .or. EvType.GT.gen_MAX_trigger_types
+ If(ABORT) Then
+ write(err,'(":illegal physics type #",i3," sequential #",i10)')
+ $ EvType, gen_event_sequence_N
+ call G_add_path(here,err)
+ RETURN
+ EndIf
+*
+ccc process= gen_run_enable(EvType)
+*
+ gen_run_triggered(EvType)= gen_run_triggered(EvType)+1
+*
+*- likely that next bank is an "Event ID bank"; if so try to
+*- recover event info, if not just skip
+*
+ nontrivial= buffer(1).GE.6 !non-null CODA physics event
+*
+ If(nontrivial) Then
+ EventIDbank= buffer(1).GE.6 .and.
+ & buffer(3).EQ.EventIDbank_size
+ & .and. buffer(4).EQ.EventIDbank_desc
+*
+c write(*,*)'Event info: ',buffer(1),buffer(3),buffer(4)
+c write(*,*)'Event into 2:',
+c & EventIDbank_size,EventIDbank_desc,EventIDbank
+ if(EventIDbank) then
+*
+ gen_event_ID_number= buffer(5)
+ gen_event_class= buffer(6)
+ gen_event_ROC_summary= buffer(7)
+*
+*-see if event_ID within limits of interest
+ccc IF(gen_run_starting_event.GT.0) THEN
+ccc process= gen_event_ID_number.GE.gen_run_starting_event
+ccc ENDIF
+*
+ccc IF(gen_run_stopping_event.GE.gen_run_starting_event
+ccc & .and. gen_run_stopping_event.GT.0) THEN
+ccc process= gen_event_ID_number.LE.gen_run_stopping_event
+ccc ENDIF
+*
+ else !1st bank NOT eventID bank-must look later
+*
+ gen_event_ID_number= 0
+ gen_event_class= 0
+ gen_event_ROC_summary= 0
+*
+ endif
+*
+ Else !trivial event- nothing inside
+*
+ write(err,'(":sequential event #",i10," type #",i3
+ $ ," too small [",i2,"]")')
+ $ gen_event_sequence_n,evtype,buffer(1)+1
+ call G_add_path(here,err) !warning only
+*
+ EndIf
+
+ return
+ end
diff --git a/ENGINE/g_examine_picture_event.f b/ENGINE/g_examine_picture_event.f
new file mode 100644
index 0000000..afc3fcd
--- /dev/null
+++ b/ENGINE/g_examine_picture_event.f
@@ -0,0 +1,90 @@
+ subroutine g_examine_picture_event
+* $Log: g_examine_picture_event.f,v $
+* Revision 1.1.6.3 2007/09/12 14:40:03 brash
+* *** empty log message ***
+*
+* Revision 1.1.6.2 2007/09/10 20:33:37 pcarter
+* Implemented changes to allow compilation on RHEL 3,4,5 and MacOSX
+*
+* Revision 1.1.6.1 2007/05/15 02:54:45 jones
+* Start to Bigcal code
+*
+* Revision 1.1.2.1 2004/06/30 19:31:08 cdaq
+* Subroutine to dump HMS/SOS angle pictures (DJG)
+*
+
+* Revision 1.1 2004/06/28 18:30:13 saw
+* Initial revision
+*
+*--------------------------------------------------------
+ implicit none
+ save
+ external jishft
+
+ character buffer*100000
+ character*80 file
+ equivalence (craw(5), buffer)
+ integer i,j,evlen
+ integer g_important_length,find_char
+ integer evtype
+ integer numevent
+ logical dump_event
+ integer*4 jishft
+
+ include 'gen_craw.cmn'
+ include 'gen_run_info.cmn'
+ include 'sos_filenames.cmn'
+ include 'hms_filenames.cmn'
+*
+* event type =131 30 second epics read
+* event type =132 2 second epics read
+* when gdebugdumpepics=1,2,3 dump 131,132, both
+*--------------------------------------------------------
+
+ numevent = numevent + 1
+
+c if (g_epics_output_filename.ne.' ' .and.
+c & (gdebugdumpepics.ge.1 )) then !write out event
+c dump_event = .true.
+c else
+c dump_event = .false.
+c return
+c endif
+c
+
+ dump_event = .true.
+ evtype = jishft(craw(2),-16)
+c
+c if (dump_event) write (G_LUN_EPICS_OUTPUT,*) 'epics event #',numevent
+
+ if (craw(3)-1.le.0) then
+ write (6,*)
+ 1 '**g_examine_picture_event: bad record length; numevent=',
+ 1 numevent,', craw3=',craw(3)
+ return
+ endif
+
+c write (6,*) 'picture,evlen',evlen,numevent,craw(3)
+
+ evlen=g_important_length(buffer(1:4*(craw(3)-1)))
+ i = 1
+
+
+ if(evtype.eq.146.and.h_angle_output_filename.ne.' ') then
+ file = h_angle_output_filename
+ call g_sub_run_number(file,gen_run_number)
+ open(8,file=file,status='unknown',form='unformatted',access='direct',recl=evlen)
+ write(8,rec=1) buffer(i:evlen)
+ close(8)
+ elseif(evtype.eq.147.and.s_angle_output_filename.ne.' ') then
+ file = s_angle_output_filename
+ call g_sub_run_number(file,gen_run_number)
+ open(8,file=file,status='unknown',form='unformatted',access='direct',recl=evlen)
+ write(8,rec=1) buffer(i:evlen)
+ close(8)
+ endif
+
+
+
+ return
+ end
diff --git a/ENGINE/g_extract_kinematics.f b/ENGINE/g_extract_kinematics.f
new file mode 100644
index 0000000..eabf9a4
--- /dev/null
+++ b/ENGINE/g_extract_kinematics.f
@@ -0,0 +1,231 @@
+ subroutine g_extract_kinematics(ebeam,phms,thms,psos,tsos,ntarg)
+* $Log: g_extract_kinematics.f,v $
+* Revision 1.6 2003/09/05 15:41:05 jones
+* Merge in online03 changes (mkj)
+*
+* Revision 1.5.2.2 2003/04/10 00:41:51 cdaq
+* Have the engine take the spectrometer angles from the typed field of the run_info event rather than the epics field
+*
+* Revision 1.5.2.1 2003/04/09 02:47:57 cdaq
+* Update code to look for Target Material instead of Target NUMBER in run info event
+*
+* Revision 1.5 2002/09/25 14:38:47 jones
+* a. IN subroutine parse_line
+* i. character*132 line changed to character*(*) line
+* ii. character*20 name changed to character*(*) name
+* b. in function skip_blanks character*132 string changed to character*(*) string
+*
+* Revision 1.4 1998/12/01 15:59:47 saw
+* (SAW) Make "string" argument of skip_item variable length
+*
+* Revision 1.3 1996/09/04 14:36:19 saw
+* (JRA) Fixes
+*
+* Revision 1.2 1996/01/16 18:35:02 cdaq
+* (JRA) Minor bug fix
+*
+* Revision 1.1 1995/11/28 19:10:48 cdaq
+* Initial revision
+*
+*--------------------------------------------------------
+ implicit none
+ save
+
+ character buffer*2000
+ equivalence (craw(5), buffer)
+ integer find_char
+ integer i
+ integer j,evlen
+ integer mode
+ character*20 name
+ real*4 epics_value,typed_value
+ real*4 ebeam,phms,thms,psos,tsos,ntarg
+ integer g_important_length
+
+ include 'gen_craw.cmn'
+*--------------------------------------------------------
+
+c
+c Break up the text stored in the event array into individual lines. If
+c the line is a comment, print it out, otherwise parse it.
+c
+
+ evlen=g_important_length(buffer(1:4*(craw(3)-1)))
+ i = 1
+ mode = 0 ! Mode 0 => Parse each line
+ do while (i.le.evlen)
+ j = find_char (buffer, i, 10) ! 10 = NewLine character
+ if (i.eq.j) goto 20
+ if (buffer(i:i+7).eq.'comment') then
+ mode = 1 ! Mode 1 => Print out each line
+ i = i + 24 ! comment has 24 character of 'header'
+ endif
+ if (mode.eq.0) then
+ call parse_line (buffer(i:j), j-i, name, epics_value, typed_value)
+ if (name(1:11).eq.'Beam Energy') then
+ ebeam=typed_value
+ else if (name(1:12).eq.'HMS Momentum') then
+ phms=typed_value
+ else if (name(1:9).eq.'HMS Angle') then
+ thms=typed_value
+ else if (name(1:12).eq.'SOS Momentum') then
+ psos=typed_value
+ else if (name(1:9).eq.'SOS Angle') then
+ tsos=typed_value
+ else if (name(1:15).eq.'Target Material') then
+ ntarg=typed_value
+ endif
+ else
+ if(i.lt.j-1) write(6,'(4x,a)') buffer(i:j-1)
+ endif
+ 20 i = j + 1
+ enddo
+ 10 continue
+ return
+ end
+
+c
+c Parse a character string
+c
+ subroutine parse_line (line, line_len, name, value1, value2)
+ implicit none
+ character*(*) line
+ character*132 tmpline
+ integer line_len,new_len
+ integer name_start,name_stop
+ integer value1_start,value1_stop
+ integer value2_start,value2_stop
+ character*(*) name
+ character*20 value_string
+ real*4 value1,value2
+
+! sample line: sangle {SOS Angle} sangle {29.4} {29.4}
+
+ name_start = index(line,'{')+1
+ name_stop = index(line,'}')-1
+ if (name_start.le.name_stop) name = line(name_start:name_stop)
+ if (name_stop+2.gt.line_len) goto 999
+ tmpline = line(name_stop+2:line_len)
+ new_len = line_len - name_stop - 1
+ value1_start = index(tmpline,'{')+1
+ value1_stop = index(tmpline,'}')-1
+ if (value1_start.le.value1_stop) value_string = tmpline(value1_start:value1_stop)
+ read (value_string,*,err=999) value1
+ if (value1_stop+2.gt.new_len) goto 999
+ tmpline = tmpline(value1_stop+2:new_len)
+ value2_start = index(tmpline,'{')+1
+ value2_stop = index(tmpline,'}')-1
+ if (value2_start.le.value2_stop) value_string = tmpline(value2_start:value2_stop)
+ read (value_string,*,err=999) value2
+
+999 continue !if non-numerical vaule, skip reading
+ return
+ end
+
+c
+c Return the offset of the next item
+c
+ integer function skip_item (string, i)
+ character*132 string
+ integer i, j, find_char, skip_blanks, skip_nonblanks
+ j = skip_blanks (string, i)
+ if (string(j:j).eq.'{') then
+ j = find_char (string, j, ichar('}')) + 1
+ else
+ j = skip_nonblanks (string, j)
+ endif
+ j = skip_blanks (string, j)
+ skip_item = j
+ return
+ end
+
+c
+c Find the offset of character "char_num" in text string "string"
+c
+ integer function find_char (string, i, char_num)
+ character*(*) string
+ integer i, j, char_num
+ j = i
+ do while ((ichar(string(j:j)).ne.char_num).and.(ichar(string(j:j)).ne.0))
+ j = j + 1
+ enddo
+ find_char = j
+ return
+ end
+
+c
+c Return the offset of the first nonblank character in "string"
+c
+ integer function skip_blanks (string, i)
+ character*(*) string
+ integer i, j
+ j = i
+ do while ((string(j:j).eq.' ').and.(ichar(string(j:j)).ne.0))
+ j = j + 1
+ enddo
+ skip_blanks = j
+ return
+ end
+
+c
+c Return the offset of the first blank character in "string"
+c
+ integer function skip_nonblanks (string, i)
+ character*(*) string
+ integer i, j
+ j = i
+ do while ((string(j:j).ne.' ').and.(ichar(string(j:j)).ne.0))
+ j = j + 1
+ enddo
+ skip_nonblanks = j
+ return
+ end
+
+c
+c Convert a text character to a digit
+c If the character is not a digit and is not a ".", return -1
+c If the character is a ".", return -2
+c
+ real function char_to_digit (letter)
+ character letter
+ char_to_digit = ichar(letter) - 48
+ if ((char_to_digit.lt.0).or.(char_to_digit.gt.9)) char_to_digit = -1
+ if (letter.eq.'.') char_to_digit = -2
+ return
+ end
+
+c
+c Convert a text string to a real number
+c
+ real function string_to_number (string)
+ character*(*) string
+ real offset, digit, sign, number
+ integer starting_offset
+ starting_offset = 1
+ sign = 1
+ if (string(1:1).eq.'+') starting_offset = 2
+ if (string(1:1).eq.'-') then
+ starting_offset = 2
+ sign = -1
+ endif
+ number = 0
+ offset = 0.1
+ do i = starting_offset, 79
+ digit = char_to_digit (string(i:i))
+ if (digit.lt.0) goto 10
+ number = number*10 + digit
+ enddo
+ 10 continue
+ if (digit.eq.-2) then
+ do j = i+1, 79
+ digit = char_to_digit (string(j:j))
+ if (digit.lt.0) goto 20
+ number = number + offset*digit
+ offset = offset/10
+ enddo
+ 20 continue
+ endif
+ number = number*sign
+ string_to_number = number
+ return
+ end
diff --git a/ENGINE/g_get_next_event.f b/ENGINE/g_get_next_event.f
new file mode 100644
index 0000000..d8b0120
--- /dev/null
+++ b/ENGINE/g_get_next_event.f
@@ -0,0 +1,138 @@
+ SUBROUTINE G_get_next_event(ABORT,err)
+*--------------------------------------------------------
+*- Prototype C analysis routine
+*-
+*-
+*- Purpose and Methods : gets the CRAW (C raw data) buffer
+*- from a FASTBUS CODA file
+*-
+*- Output: ABORT - success or failure
+*- : err - reason for failure, if any
+*-
+*- Created 29-Oct-1993 Kevin B. Beard
+*- Modified 1-Dec-1993 KBB: borrowed L.Dennis's hall B routines
+* $Log: g_get_next_event.f,v $
+* Revision 1.5.24.1 2007/09/13 04:02:17 brash
+* Implement some minor changes to fix Mac OS X runtime errors ... ejb
+*
+* Revision 1.5 2002/09/25 13:50:49 jones
+* a. include file gen_run_info.cmn
+* b. add code for segmented runs
+*
+* Revision 1.4 1996/01/16 18:32:21 cdaq
+* no change
+*
+* Revision 1.3 1994/04/12 18:45:53 cdaq
+* (SAW) Add include for the CRAW event buffer common
+*
+* Revision 1.2 1994/02/11 15:43:08 cdaq
+* Replace fbgen library call with plain evread call
+*
+* Revision 1.1 1994/02/01 20:40:55 cdaq
+* Initial revision
+*
+*-
+*- All standards are from "Proposal for Hall C Analysis Software
+*- Vade Mecum, Draft 1.0" by D.F.Geesamn and S.Wood, 7 May 1993
+*-
+*-
+*--------------------------------------------------------
+ IMPLICIT NONE
+ SAVE
+*
+ character*16 here
+ parameter (here= 'G_get_next_event')
+*
+ logical ABORT
+ character*(*) err
+*
+ INCLUDE 'gen_data_structures.cmn'
+ include 'gen_craw.cmn'
+ INCLUDE 'gen_filenames.cmn'
+ INCLUDE 'gen_run_info.cmn'
+*
+ integer g_important_length
+*
+ integer maxsize,i
+ integer*4 status
+ integer*4 evread, evclose, evopen ! Coda event read routine
+ character*132 file
+ integer*4 fname_len
+*
+*--------------------------------------------------------
+*
+ err= ' '
+*
+ ABORT= .NOT.g_data_source_opened
+*
+ IF(ABORT) THEN
+*
+ err= ':no data source open'
+*
+ ELSE !try to get next event
+*
+ maxsize= LENGTH_CRAW
+
+ status = evread(g_data_source_in_hndl,CRAW,maxsize)
+
+c write(*,*)'Event data -------'
+c do i=1,10
+c write(*,*)'event data: ',i,CRAW(i)
+c enddo
+
+
+ if(status.ne.0) then
+ if(g_segment.ge.0) then ! This is a segmented run, look for more
+
+ print *,"Closing segment ",g_segment
+ status = evclose(g_data_source_in_hndl) ! Should check result
+ g_data_source_opened = .false.
+ g_segment = g_segment+1
+
+ file = g_data_source_filename
+ call g_sub_run_number(file, gen_run_number)
+ fname_len = g_important_length(file)
+ if(g_segment.lt.10) then
+ fname_len = fname_len + 1
+ file(fname_len:fname_len) = '.'
+ fname_len = fname_len + 1
+ file(fname_len:fname_len) = char(ichar('0')+g_segment)
+ else if(g_segment.lt.100) then
+ fname_len = fname_len + 1
+ file(fname_len:fname_len) = '.'
+ fname_len = fname_len + 1
+ file(fname_len:fname_len) = char(ichar('0')+g_segment/10)
+ fname_len = fname_len + 1
+ file(fname_len:fname_len) = char(ichar('0')
+ $ +g_segment-10*(g_segment/10))
+
+ else ! Only support up to 100 segments
+ ABORT = .true.
+ endif
+ if(.NOT.ABORT) then
+ print *,"Opening segment ",g_segment
+ status = evopen(file,'r',g_data_source_in_hndl)
+ if(status.eq.0) then
+ g_data_source_opened = .true.
+ status = evread(g_data_source_in_hndl,CRAW,maxsize)
+ if(status.ne.0) then
+ 1 ABORT = .true.
+ call G_append(err,' & cannot read from file')
+ endif
+ else
+ call G_append(err,' & cannot open file')
+ ABORT = .true.
+ endif
+ endif
+ else
+ call cemsg(status,0,err) ! Get error string from CODA
+ ABORT = .true.
+ endif
+ endif
+ ENDIF
+*
+ IF(ABORT) call G_add_path(here,err)
+*
+ RETURN
+ END
+
diff --git a/ENGINE/g_init_filenames.f b/ENGINE/g_init_filenames.f
new file mode 100644
index 0000000..8618dc8
--- /dev/null
+++ b/ENGINE/g_init_filenames.f
@@ -0,0 +1,268 @@
+ subroutine g_init_filenames(ABORT, err, env_var)
+*----------------------------------------------------------------------
+*- Purpose and Methods:
+*-
+*- Read a configuration file with set of filenames and options.
+*- Much of this will be handled by CTP when a string capability is added
+*- to CTP parameter files. Allowed keywords in config file are
+*- 'hist', 'test', 'parm', 'alias', 'data', 'hbook', 'map', 'nevents', 'data'
+*-
+*- This routine does the booking of hist, test, and parm files. This
+*- booking should be moved to another file.
+*-
+*- Inputs:
+*-
+*- env_var Environment variable pointing to the config file.
+*-
+*- Outputs:
+*-
+*- ABORT
+*- err
+*-
+*- Created Steve Wood, CEBAF
+*- Modified 3-Dec-1993 Kevin Beard, Hampton U.
+*- Modified 8-Dec-1993 Kevin Beard; rewrote parsing,added 'data' type
+* $Log: g_init_filenames.f,v $
+* Revision 1.19.6.9.2.1 2009/10/27 15:11:46 jones
+* Initialize pol_table and charge_table filenames
+*
+* Revision 1.19.6.9 2007/11/29 19:06:13 puckett
+* *** empty log message ***
+*
+* Revision 1.19.6.8 2007/10/24 16:37:07 cdaq
+* *** empty log message ***
+*
+* Revision 1.19.6.7 2007/10/08 19:22:33 puckett
+* Added bad channel list handling for BigCal
+*
+* Revision 1.19.6.6 2007/09/24 20:37:50 puckett
+* added BigCal debugging output file
+*
+* Revision 1.19.6.5 2007/09/07 16:05:29 puckett
+* removed initialization of filenames for bigcal calibration reports, no longer used, this info will go in regular bigcal report
+*
+* Revision 1.19.6.4 2007/08/27 19:05:39 puckett
+* Added filenames relating to BigCal calibration
+*
+* Revision 1.19.6.3 2007/08/15 21:44:21 puckett
+* Added gep (coincidence) report names to filename initialization
+*
+* Revision 1.19.6.2 2007/08/07 19:03:38 puckett
+* added initialization for tree filenames
+*
+* Revision 1.19.6.1 2007/05/15 02:55:01 jones
+* Start to Bigcal code
+*
+* Revision 1.18.12.1 2004/06/30 19:32:32 cdaq
+* Add initialition of angle picture filenames (DJG)
+*
+* Revision 1.18 2003/09/05 15:44:44 jones
+* Merge in online03 changes (mkj)
+*
+* Revision 1.17.2.1 2003/08/14 00:42:22 cdaq
+* Modify to be able to write scaler rates for each read to a file (mkj)
+*
+* Revision 1.17 1996/11/05 21:40:59 saw
+* (JRA) Add g_epics_output_filename
+*
+* Revision 1.16 1996/09/04 14:36:59 saw
+* (JRA) Add read of command line parameters
+*
+* Revision 1.15 1996/04/29 19:47:11 saw
+* (JRA) Add g_pedestal_output_filename
+*
+* Revision 1.14 1996/01/16 18:31:26 cdaq
+* (JRA) Add file for tcl stats display, add files for thresholds and pedestals
+*
+* Revision 1.13 1995/10/09 18:37:52 cdaq
+* (SAW) Move g_ctp_database call to engine.f
+*
+* Revision 1.12 1995/09/01 14:31:03 cdaq
+* (JRA) Blank out g_ctp_kinematics_filename
+*
+* Revision 1.11 1995/07/27 19:35:15 cdaq
+* (SAW) Add call to g_ctp_database to set ctp vars by run number
+*
+* Revision 1.10 1995/05/11 19:01:29 cdaq
+* (SAW) Check 0 in g_config_filename in case user doesn't update engine.f
+*
+* Revision 1.9 1995/05/11 16:16:11 cdaq
+* (SAW) Don't get g_config_filename from environment if it is already set
+* from the command line and allow %d run number substitution in it.
+*
+* Revision 1.8 1995/04/01 19:46:13 cdaq
+* (SAW) One report file for each of g, h, s, c instead of a single report file
+*
+* Revision 1.7 1994/10/19 19:51:55 cdaq
+* (SAW) Add g_label variable for labels on reports
+*
+* Revision 1.6 1994/06/22 20:57:14 cdaq
+* (SAW) Add more variables for reports
+*
+* Revision 1.5 1994/06/16 03:47:57 cdaq
+* (SAW) Blank out filenames for reports
+*
+* Revision 1.4 1994/03/24 22:02:21 cdaq
+* Reorganize for online compatibility
+*
+* Revision 1.3 1994/02/11 18:34:34 cdaq
+* Split off CTP variables registration from initialize routines
+*
+* Revision 1.2 1994/02/03 18:12:17 cdaq
+* Use CTP parameter block to get the filenames
+*
+* Revision 1.1 1994/02/02 20:08:15 cdaq
+* Initial revision
+*
+*----------------------------------------------------------------------
+ implicit none
+ SAVE
+*
+ character*16 here
+ parameter (here= 'g_init_filenames')
+*
+ logical ABORT
+ character*(*) err
+ character*(*) env_var
+*
+ include 'gen_filenames.cmn'
+ include 'hms_filenames.cmn'
+ include 'sos_filenames.cmn'
+ include 'coin_filenames.cmn'
+ include 'bigcal_filenames.cmn'
+ include 'gep_filenames.cmn'
+ include 'gen_routines.dec'
+ include 'gen_run_info.cmn'
+ include 'sane_ntuple.cmn'
+*
+ integer ierr
+ character*132 file
+*
+*-all crucial setup information here; failure is fatal
+*
+ g_hist_rebook = .true.
+ g_test_rebook = .true.
+ g_parm_rebook = .true.
+ g_report_rebook = .true.
+ b_calib_rebook = .true.
+ h_driftmap_rebook = .true.
+ g_ctp_parm_filename = ' '
+ g_ctp_test_filename = ' '
+ g_ctp_hist_filename = ' '
+ g_data_source_filename= ' '
+ g_alias_filename = ' '
+ g_histout_filename = ' '
+ g_decode_map_filename = ' '
+ g_ctp_database_filename = ' '
+ g_ctp_kinematics_filename = ' '
+ g_charge_scaler_filename = ' '
+ g_writeout_scaler_filename = ' '
+ b_calib_input_filename = ' '
+ h_driftmap_input_filename = ' '
+*
+ s_recon_coeff_filename = ' '
+ h_recon_coeff_filename = ' '
+*
+ h_report_template_filename = ' '
+ s_report_template_filename = ' '
+ g_report_template_filename = ' '
+ c_report_template_filename = ' '
+ b_report_template_filename = ' ' ! add BigCal
+c b_calib_report_template = ' ' ! not used, make part of bigcal report
+ gep_report_template_filename = ' ' ! add GEp
+ g_stats_template_filename = ' '
+*
+ h_report_output_filename = ' '
+ s_report_output_filename = ' '
+ g_report_output_filename = ' '
+ c_report_output_filename = ' '
+ b_report_output_filename = ' ' ! add BigCal
+ gep_report_output_filename = ' ' ! add GEp
+ g_stats_output_filename = ' '
+ g_bad_output_filename = ' '
+ g_epics_output_filename = ' '
+*
+ h_report_blockname = ' '
+ s_report_blockname = ' '
+ g_report_blockname = ' '
+ c_report_blockname = ' '
+ b_report_blockname = ' ' ! add BigCal
+c b_calib_report_blockname = ' ' ! not used, make part of bigcal report
+ gep_report_blockname = ' '
+ g_stats_blockname = ' '
+*
+ h_threshold_output_filename = ' '
+ s_threshold_output_filename = ' '
+ b_roc11_threshold_output_filename = ' ' ! add BigCal
+ b_roc12_threshold_output_filename = ' '
+ g_pedestal_output_filename = ' '
+ h_pedestal_output_filename = ' '
+ s_pedestal_output_filename = ' '
+ b_pedestal_output_filename = ' ' ! add BigCal
+*
+ h_angle_output_filename = ' '
+ s_angle_output_filename = ' '
+c b_angle_output_filename = ' ' ! add BigCal
+ h_tree_filename = ' '
+ b_tree_filename = ' '
+ gep_tree_filename = ' '
+c
+
+c the following is the name of the binary data file containing
+c the augmented matrix and vector of constants for the system of
+c linear equations to be solved for the BigCal calibration coefficients,
+c accumulated over one or several runs until the desired number of events
+c is reached (bigcal_min_calib_events)
+
+ b_calib_matrix_filename = ' '
+ b_calib_parm_filename = ' '
+ b_debug_output_filename = ' '
+ b_bad_chan_list_filename = ' '
+c b_calib_report_filename = ' ' ! not used
+ polarization_data_table = ' '
+ charge_data_table = ' '
+*
+ g_label = ' ' ! Label for reports etc.
+*
+ if(g_config_filename.eq.' '.or.
+ $ ichar(g_config_filename(1:1)).eq.0) ! Only if not already set
+ $ call getenv(env_var,g_config_filename)
+*
+ call engine_command_line(.false.)
+*
+ ABORT= g_config_filename.EQ.' '
+ IF(ABORT) THEN
+ err= here//':blank environmental variable '//env_var
+ RETURN
+ ENDIF
+*
+ file = g_config_filename
+ call g_sub_run_number(file,gen_run_number)
+ ierr = thload(file) ! Config file is now a CTP parm file
+ if(ierr.ne.0) goto 999
+ ierr = thbook()
+ if(ierr.eq.0) then
+ g_config_loaded = .true.
+ else
+ g_config_loaded = .false.
+ endif
+
+ ABORT= .NOT.g_config_loaded
+ IF(ABORT) THEN
+ err= ':opened OK, but thbook command failed from "'//file//'"'
+ call G_add_path(here,err)
+ ELSE
+ err= ' '
+ ENDIF
+*
+ return
+*
+999 g_config_loaded= .FALSE.
+ ABORT= .NOT.g_config_loaded
+ err= ':unable to open file "'//file//'"'
+ call G_add_path(here,err)
+ return
+*
+ end
+
+
diff --git a/ENGINE/g_initialize.f b/ENGINE/g_initialize.f
new file mode 100644
index 0000000..2fbb2f5
--- /dev/null
+++ b/ENGINE/g_initialize.f
@@ -0,0 +1,511 @@
+ SUBROUTINE G_initialize(ABORT,err)
+*----------------------------------------------------------------------
+*- Prototype hall C initialize routine
+*-
+*- Purpose and Methods : Initialization is performed and status returned
+*-
+*- Output: ABORT - success or failure
+*- : err - reason for failure, if any
+*-
+*- Created 9-Nov-1993 Kevin B. Beard
+*- Modified 20-Nov-1993 Kevin B. Beard
+* $Log: g_initialize.f,v $
+* Revision 1.24.6.12 2007/11/29 19:05:29 puckett
+* added special parm filenames b_calib_input_filename and h_driftmap_input_filename which can be used in MAIN.db
+*
+* Revision 1.24.6.11 2007/11/29 18:37:53 cdaq
+* commented out call to c_initialize, duplicated in gep_initialize
+*
+* Revision 1.24.6.10 2007/10/24 16:58:28 cdaq
+* Always call h_initialize
+*
+* Revision 1.24.6.9 2007/10/22 15:18:09 cdaq
+* fixed array index problem with gen_run_enable
+*
+* Revision 1.24.6.8 2007/09/12 19:26:31 puckett
+* *** empty log message ***
+*
+* Revision 1.24.6.7 2007/09/10 20:33:37 pcarter
+* Implemented changes to allow compilation on RHEL 3,4,5 and MacOSX
+*
+* Revision 1.24.6.6 2007/08/15 21:44:21 puckett
+* Added gep (coincidence) report names to filename initialization
+*
+* Revision 1.24.6.5 2007/08/07 19:06:06 puckett
+* *** empty log message ***
+*
+* Revision 1.24.6.3 2007/06/20 18:26:32 puckett
+* Added BigCal Monte Carlo analysis capability
+*
+* Revision 1.24.6.2 2007/06/04 14:56:05 puckett
+* changed hit array structure for trigger related signals
+*
+* Revision 1.24.6.1 2007/05/15 02:55:01 jones
+* Start to Bigcal code
+*
+* Revision 1.23 2004/05/11 18:24:12 jones
+* Initialize skip_events to false
+*
+* Revision 1.22 2003/09/05 15:48:36 jones
+* Merge in online03 changes (mkj)
+*
+* Revision 1.21.2.3 2003/08/14 00:42:22 cdaq
+* Modify to be able to write scaler rates for each read to a file (mkj)
+*
+* Revision 1.21.2.2 2003/04/10 00:41:27 cdaq
+* Added gen_data_structures and included status messages when kinematics overridden
+*
+* Revision 1.21.2.1 2003/04/09 23:56:27 cdaq
+* Check for gpbeam=0
+*
+* Revision 1.21 1996/11/05 21:41:36 saw
+* (SAW) Use CTP routines as functions rather than subroutines for
+* porting.
+*
+* Revision 1.20 1996/09/04 14:37:56 saw
+* (JRA) Open output file for charge scalers
+*
+* Revision 1.19 1996/04/29 19:47:42 saw
+* (JRA) Add call to engine_command_line
+*
+* Revision 1.18 1996/01/22 15:18:12 saw
+* (JRA) Add call to g_target_initialize. Remove call to
+* g_kludge_up_kinematics
+*
+* Revision 1.17 1996/01/16 18:24:47 cdaq
+* (JRA) Get kinematics for runinfo event, create a tcl stats screen. Groupify
+* CTP calls
+*
+* Revision 1.16 1995/10/09 18:42:57 cdaq
+* (SAW) Move loading of ctp_kinematics database to before CTP loading. Take
+* ntuple inialization out of spec specific init routines into a all ntuple
+* init routine.
+*
+* Revision 1.15 1995/09/01 14:29:41 cdaq
+* (JRA) Zero run time variable, read kinematics database after last book
+*
+* Revision 1.14 1995/07/27 19:36:41 cdaq
+* (SAW) Relocate data statements for f2c compatibility, check error returns
+* on thload calls and quit if important files are missing.
+*
+* Revision 1.13 1995/05/22 20:41:40 cdaq
+* (SAW) Split g_init_histid into h_init_histid and s_init_histid
+*
+* Revision 1.12 1995/04/01 19:47:22 cdaq
+* (SAW) One report file for each of g, h, s, c instead of a single report file
+* Allow %d for run number in filenames
+*
+* Revision 1.11 1994/10/11 18:39:40 cdaq
+* (SAW) Add some hacks for event display
+*
+* Revision 1.10 1994/09/21 19:52:57 cdaq
+* (SAW) Cosmetic change
+*
+* Revision 1.9 1994/08/30 14:47:41 cdaq
+* (SAW) Add calls to clear the test flags and scalers
+*
+* Revision 1.8 1994/08/18 03:45:01 cdaq
+* (SAW) Correct typo in adding hack stuff
+*
+* Revision 1.7 1994/08/04 03:08:11 cdaq
+* (SAW) Add call to Breuer's hack_initialize
+*
+* Revision 1.6 1994/06/22 20:55:14 cdaq
+* (SAW) Load report templates
+*
+* Revision 1.5 1994/06/04 02:35:59 cdaq
+* (KBB) Make sure CTP files are non-blank before trying to thload them
+*
+* Revision 1.4 1994/04/12 20:59:21 cdaq
+* (SAW) Add call to calculation of histid's for hfilled histograms
+*
+* Revision 1.3 1994/03/24 22:02:31 cdaq
+* Reorganize for online compatibility
+*
+* Revision 1.2 1994/02/11 18:34:49 cdaq
+* Split off CTP variables registration from initialize routines
+*
+* Revision 1.1 1994/02/04 22:00:26 cdaq
+* Initial revision
+*
+*-
+*- All standards are from "Proposal for Hall C Analysis Software
+*- Vade Mecum, Draft 1.0" by D.F.Geesamn and S.Wood, 7 May 1993
+*-
+*--------------------------------------------------------
+ IMPLICIT NONE
+ SAVE
+*
+ character*12 here
+ parameter (here= 'G_initialize')
+*
+ logical ABORT
+ character*(*) err
+*
+ INCLUDE 'gen_filenames.cmn' !all setup files
+ INCLUDE 'hms_filenames.cmn'
+ INCLUDE 'sos_filenames.cmn'
+ include 'bigcal_filenames.cmn' ! add BigCal
+ INCLUDE 'coin_filenames.cmn'
+ include 'gep_filenames.cmn' ! add GEp
+ INCLUDE 'gen_routines.dec'
+ INCLUDE 'gen_pawspace.cmn' !includes sizes of special CERNLIB space
+ INCLUDE 'gen_run_info.cmn'
+ include 'gen_scalers.cmn'
+ include 'hms_data_structures.cmn'
+ include 'sos_data_structures.cmn'
+ include 'gen_data_structures.cmn'
+ include 'bigcal_data_structures.cmn' ! add BigCal
+*
+ integer ierr,i
+ logical HMS_ABORT,SOS_ABORT, HACK_ABORT, BIGCAL_ABORT ! add flag for BigCal
+ character*132 HMS_err,SOS_err, HACK_err, BIGCAL_err ! add err. message for BigCal
+*
+ character*132 file
+ logical*4 first_time ! Allows routine to be called
+ data first_time /.true./ ! by online code
+*
+*--------------------------------------------------------
+*
+ ABORT= .FALSE. !clear any old flags
+ err= ' ' !erase any old errors
+ HMS_err= ' '
+ SOS_err= ' '
+ BIGCAL_err = ' '
+*
+* set the runtime variable to avoid divide by zero during report
+*
+* g_run_time = 0.0001
+*
+* Book the histograms, tests and parameters
+*
+ if(first_time) then
+ call HLIMIT(G_sizeHBOOK) !set in "gen_pawspace.cmn"
+ endif
+* Load and book all the CTP files
+*
+*
+
+ if((first_time.or.g_parm_rebook).and.g_ctp_parm_filename.ne.' ') then
+ file = g_ctp_parm_filename
+ call g_sub_run_number(file,gen_run_number)
+ if(thload(file).ne.0) then
+ ABORT = .true.
+ err = file
+ endif
+ ierr = thbook() ! Assert parm values
+ endif ! so that ctp_database can override
+*
+*
+* Now if there is a g_ctp_kinematics_filename set, pass the run number
+* to it to set CTP variables. Parameters placed in this file will
+* override values defined in the CTP input files.
+*
+
+ if(.not.ABORT.and.g_ctp_kinematics_filename.ne.' ') then
+ write(6,'(a,a60)') 'KINEMATICS FROM ',g_ctp_kinematics_filename(1:60)
+ call g_ctp_database(ABORT, err
+ $ ,gen_run_number, g_ctp_kinematics_filename)
+ IF(ABORT) THEN
+ call G_add_path(here,err)
+ endif
+ ENDIF
+*
+
+ if((first_time.or.g_test_rebook).and.g_ctp_test_filename.ne.' ') then
+ file = g_ctp_test_filename
+ call g_sub_run_number(file,gen_run_number)
+ if(thload(file).ne.0) then
+ ABORT = .true.
+ if(err.ne.' ') then
+ call g_append(err,' & '//file)
+ else
+ err = file
+ endif
+ endif
+ endif
+
+ if((first_time.or.h_driftmap_rebook).and.h_driftmap_input_filename.ne.' ') then
+ file = h_driftmap_input_filename
+ if(thload(file).ne.0) then
+ abort = .true.
+ if(err.ne.' ') then
+ call g_append(err,' & '//file)
+ else
+ err = file
+ endif
+ endif
+ endif
+
+ if((first_time.or.b_calib_rebook).and.b_calib_input_filename.ne.' ') then
+ file = b_calib_input_filename
+ if(thload(file).ne.0) then
+ abort = .true.
+ if(err.ne.' ') then
+ call g_append(err,' & '//file)
+ else
+ err = file
+ endif
+ endif
+ endif
+
+ write(6,'(a)') 'COMMAND LINE FLAGS'
+ call engine_command_line(.true.) ! Reset CTP vars from command line
+
+* that was the last call to engine_command_line, the last time to input
+* ctp variables. Set some here to avoid divide by zero errors if they
+* were not read in.
+ if (hpcentral.le.0.001) then
+ hpcentral = 1.
+ write(6,*) 'hpcentral value not given: setting to 1 GeV'
+ endif
+ if (spcentral.le.0.001) then
+ spcentral = 1.
+ write(6,*) 'spcentral value not given: setting to 1 GeV'
+ endif
+ if (htheta_lab.le.0.001) then
+ htheta_lab = 90.
+ write(6,*) 'htheta_lab value not given: setting to 90 degrees'
+ endif
+ if (stheta_lab.le.0.001) then
+ stheta_lab = 90.
+ write(6,*) 'stheta_lab value not given: setting to 90 degrees'
+ endif
+ if (gpbeam.le.0.001) then
+ gpbeam = 2.
+ write(6,*) 'gpbeam value not given: setting to 2 GeV'
+ endif
+c avoid divide-by-zero errors for BigCal:
+ if(BIGCAL_THETA_DEG.le.0.001) then
+ BIGCAL_THETA_DEG = 90.
+ write(6,*) 'bigcal_theta_deg value not given: set to 90 deg.'
+ endif
+ if(BIGCAL_R_TGT.le.0.001) then
+ BIGCAL_R_TGT = 1000.
+ write(6,*) 'bigcal_r_tgt value not given: setting to 10.0 m'
+ endif
+
+ if((first_time.or.g_hist_rebook).and.g_ctp_hist_filename.ne.' ') then
+ file = g_ctp_hist_filename
+ call g_sub_run_number(file,gen_run_number)
+ if(thload(file).ne.0) then
+ ABORT = .true.
+ if(err.ne.' ') then
+ call g_append(err,' & '//file)
+ else
+ err = file
+ endif
+ endif
+ endif
+*
+ if(ABORT) then
+ call g_add_path(here,err)
+ return ! Don't try to proceed
+ endif
+
+*
+* Load the report definitions
+*
+
+ if((first_time.or.g_report_rebook)
+ $ .and.g_report_template_filename.ne.' ') then
+ file = g_report_template_filename
+ call g_sub_run_number(file,gen_run_number)
+ ierr = thload(file)
+ endif
+*
+
+ if((first_time.or.g_report_rebook)
+ $ .and.g_stats_template_filename.ne.' ') then
+ file = g_stats_template_filename
+ call g_sub_run_number(file,gen_run_number)
+ ierr = thload(file)
+ endif
+*
+ if((first_time.or.g_report_rebook)
+ $ .and.s_report_template_filename.ne.' ') then
+ file = s_report_template_filename
+ call g_sub_run_number(file,gen_run_number)
+ ierr = thload(file)
+ endif
+*
+ if((first_time.or.g_report_rebook)
+ $ .and.h_report_template_filename.ne.' ') then
+ file = h_report_template_filename
+ call g_sub_run_number(file,gen_run_number)
+ ierr = thload(file)
+ endif
+*
+ if((first_time.or.g_report_rebook)
+ $ .and.c_report_template_filename.ne.' ') then
+ file = c_report_template_filename
+ call g_sub_run_number(file,gen_run_number)
+ ierr = thload(file)
+ endif
+
+ if((first_time.or.g_report_rebook).and. ! add BigCal
+ $ b_report_template_filename.ne.' ') then
+ file = b_report_template_filename
+ call g_sub_run_number(file,gen_run_number)
+ ierr = thload(file)
+ endif
+
+ if((first_time.or.g_report_rebook).and. ! add GEp-coin.
+ $ gep_report_template_filename.ne.' ') then
+ file = gep_report_template_filename
+ call g_sub_run_number(file,gen_run_number)
+ ierr = thload(file)
+ endif
+*
+* Call thbook if any new files have been loaded
+*
+ if(first_time.or.g_parm_rebook.or.g_test_rebook
+ $ .or.g_hist_rebook.or.g_report_rebook) then
+ ierr = thbook()
+*
+* Recalculate all histogram id's of user (hard wired) histograms
+*
+ call h_init_histid(ABORT,err)
+ call s_init_histid(ABORT,err)
+ call b_init_histid(ABORT,err) ! add bigcal
+ call gep_init_histid(ABORT,err) ! add GEp-coin
+*
+ if(g_alias_filename.ne.' ') then
+ file = g_alias_filename
+ call g_sub_run_number(file,gen_run_number)
+ ierr = thwhalias(file)
+ if (ierr.ne.0) print *,'called haliaswrite',ierr
+ endif
+ endif
+*
+ call thtstclrg("default") ! Clear test flags
+ call thtstclsg("default") ! Clear test scalers
+*
+ call g_target_initialize(ABORT,err)
+
+* Open output file for charge scalers.
+ if (g_charge_scaler_filename.ne.' ') then
+ file=g_charge_scaler_filename
+ call g_sub_run_number(file,gen_run_number)
+ open(unit=G_LUN_CHARGE_SCALER,file=file,status='unknown')
+ write(G_LUN_CHARGE_SCALER,*) '!Charge scalers - Run #',gen_run_number
+ write(G_LUN_CHARGE_SCALER,*) '!event Unser(Hz) BCM1(Hz) BCM2(Hz)',
+ & ' BCM3(Hz) Time(s)'
+ endif
+c WHIT's InSANE HACK
+ file='InSANEOUT/scalers%d.txt'
+ call g_sub_run_number(file,gen_run_number)
+c 215=philadelphia area code
+ open(unit=215,file=file,status='REPLACE')
+ write(215,*) '#InSANE scalers - Run #',gen_run_number
+c END WHIT's InSANE HACK
+c
+ skip_events = .false.
+* Open output file to writeout scalers.
+ if (g_writeout_scaler_filename.ne.' ') then
+ if ( NUM_WRITEOUT_SCALERS .le. MAX_WRITEOUT_SCALERS) then
+ file=g_writeout_scaler_filename
+ call g_sub_run_number(file,gen_run_number)
+ open(unit=G_LUN_WRITEOUT_SCALER,file=file,status='unknown')
+ else
+ write(*,*) ' Asking to write out ',NUM_WRITEOUT_SCALERS,' scalers'
+ write(*,*) ' Maximum is ' ,MAX_WRITEOUT_SCALERS
+ WRITE(*,*) ' Modify MAX_WRITEOUT_SCALERS in INCLUDE/gen_scalers and recompile code'
+ g_writeout_scaler_filename = ' '
+ endif
+ endif
+
+* Open output file for epics events.
+ if (g_epics_output_filename.ne.' ') then
+ file=g_epics_output_filename
+ call g_sub_run_number(file,gen_run_number)
+ open(unit=G_LUN_EPICS_OUTPUT,file=file,status='unknown')
+ endif
+
+c write(*,*) 'about to call h_initialize'
+
+*-HMS initialize
+c$$$ write(*,*) 'gen_run_enable flags ->'
+c$$$ do i=0,15
+c$$$ write(*,*) 'gen_run_able(',i,') = ',gen_run_enable(i)
+c$$$ enddo
+
+c if(gen_run_enable(0).ne.0) then
+ call H_initialize(HMS_ABORT,HMS_err)
+c endif
+*
+*-SOS initialize
+c if(gen_run_enable(1).ne.0) then
+c call S_initialize(SOS_ABORT,SOS_err)
+c endif
+
+c !write(*,*) 'about to call b_initialize'
+*
+*-BigCal initialize
+
+ !write(*,*) 'before call to b_initialize, gen_run_enable=',gen_run_enable
+ !write(*,*) 'before call to b_initialize, gen_bigcal_mc=',gen_bigcal_mc
+
+ call B_initialize(BIGCAL_ABORT,BIGCAL_err)
+
+*
+ ABORT= HMS_ABORT .or. SOS_ABORT .or. BIGCAL_ABORT
+ If(HMS_ABORT .and. .NOT.(SOS_ABORT.or.BIGCAL_ABORT)) Then
+ err= HMS_err
+ ElseIf(SOS_ABORT .and. .NOT.(HMS_ABORT.or.BIGCAL_ABORT)) Then
+ err= SOS_err
+ ElseIf(BIGCAL_ABORT.and. .not.(HMS_ABORT.or.SOS_ABORT)) then
+ err = BIGCAL_err
+ ElseIf(HMS_ABORT.and.SOS_ABORT.and.(.not.BIGCAL_ABORT)) Then
+ err= '&'//SOS_err
+ call G_prepend(HMS_err,err)
+ ElseIf(HMS_ABORT.and.BIGCAL_ABORT.and.(.not.SOS_ABORT)) Then
+ err= '&'//BIGCAL_err
+ call G_prepend(HMS_err,err)
+ ElseIf(BIGCAL_ABORT.and.SOS_ABORT.and.(.not.HMS_ABORT)) Then
+ err= '&'//BIGCAL_err
+ call G_prepend(SOS_err,err)
+ ElseIf(BIGCAL_ABORT.and.SOS_ABORT.and.HMS_ABORT) Then
+ err= '&'//SOS_err//'&'//BIGCAL_err
+ call G_prepend(HMS_err,err)
+ EndIf
+*
+c write(*,*) 'about to call C_initialize'
+ IF(.NOT.ABORT) THEN
+*
+*-COIN initialize
+*
+
+* call C_initialize(ABORT,err)
+
+*
+ ENDIF
+*
+c write(*,*) 'about to call GEP_initialize'
+ if(.not.ABORT) then
+ call GEP_initialize(ABORT,err) ! clone of C_initialize for now
+ endif
+
+ !write(*,*) 'before call to g_ntuple_init, gen_run_enable=',gen_run_enable
+ !write(*,*) 'before call to g_ntuple_init, gen_bigcal_mc=',gen_bigcal_mc
+
+c write(*,*) 'about to call g_ntuple_init'
+ call g_ntuple_init(HACK_ABORT,HACK_err) ! Ingore error return for now
+*
+c write(*,*) 'about to call hack_initialize'
+ call hack_initialize(HACK_ABORT,HACK_err) ! Ignore error return for now
+*
+*-force reset of all space of all working arrays
+*-(clear just zeros the index of each array)
+c write(*,*) 'about to call g_reset_event'
+ IF(.NOT.ABORT) THEN
+ call G_reset_event(ABORT,err)
+*
+ ENDIF
+*
+ IF(ABORT .or. err.NE.' ') call G_add_path(here,err)
+*
+ first_time = .false.
+*
+ RETURN
+ END
diff --git a/ENGINE/g_keep_results.f b/ENGINE/g_keep_results.f
new file mode 100644
index 0000000..f5071bc
--- /dev/null
+++ b/ENGINE/g_keep_results.f
@@ -0,0 +1,158 @@
+ SUBROUTINE G_keep_results(groupname,ABORT,err)
+*----------------------------------------------------------------------
+*- Prototype hall C keep_results routine
+*-
+*- Purpose and Methods : Given previously filled data structures,
+*- keep_results stores the reconstructed info.
+*-
+*- Output: ABORT - success or failure
+*- : err - reason for failure, if any
+*-
+*- Created 20-Nov-1993 Kevin B. Beard, HU
+*
+* $Log: g_keep_results.f,v $
+* Revision 1.10.8.1.2.1 2008/05/15 18:59:21 bhovik
+* 1'st version
+*
+* Revision 1.10.8.1 2007/05/15 02:55:01 jones
+* Start to Bigcal code
+*
+* Revision 1.9.16.1 2004/07/09 14:12:47 saw
+* Add function calls to fill CTP ROOT Trees
+*
+* Revision 1.9 2002/09/25 14:38:21 jones
+* a. character*20 groupname changed to character*(*) groupname
+* b. remove declaration character*80 msg
+*
+* Revision 1.8 1996/01/16 18:18:33 cdaq
+* (JRA) Add group name to CTP calls
+*
+* Revision 1.7 1995/04/01 19:49:49 cdaq
+* (SAW) Fix mistake in error reporting
+*
+* Revision 1.6 1995/01/13 18:15:39 cdaq
+* (SAW) Put in a missing else that conspired with a broken thgethit (CTP) so that
+* things actually worked on HPUX. (But not Ultrix)
+*
+* Revision 1.5 1994/08/30 14:48:50 cdaq
+* (SAW) Add call to increment scalers
+*
+* Revision 1.4 1994/07/21 19:51:14 cdaq
+* (SAW) Add call to thgethit
+*
+* Revision 1.3 1994/06/17 03:50:36 cdaq
+* (KBB) Upgrade error reporting
+*
+* Revision 1.2 1994/04/15 20:35:29 cdaq
+* (KBB) Add calls to thtstexe and thhstexe
+*
+* Revision 1.1 1994/02/04 22:10:48 cdaq
+* Initial revision
+*
+*-
+*- All standards are from "Proposal for Hall C Analysis Software
+*- Vade Mecum, Draft 1.0" by D.F.Geesamn and S.Wood, 7 May 1993
+*-
+*--------------------------------------------------------
+ IMPLICIT NONE
+ SAVE
+*
+ character*40 here
+ parameter (here= 'G_keep_results')
+*
+ logical ABORT
+ character*(*) err
+*
+ INCLUDE 'gen_data_structures.cmn'
+ include 'gen_routines.dec'
+*
+ logical FAIL
+ character*1024 why
+ character*(*) groupname
+ integer ierr
+*
+*--------------------------------------------------------
+*
+ err= ' ' !erase any old errors
+*
+ ierr= thgethitg(groupname)
+ ABORT= ierr.NE.0
+ IF(ABORT) THEN
+ call G_build_note(':failure#$ in thgethitg',
+ & '$',ierr,' ',0.,' ',err)
+ else
+ ierr= thtstexeg(groupname)
+ call thtstinsg(groupname) ! Increment scalers
+*
+ ABORT= ierr.NE.0
+ IF(ABORT) THEN
+ call G_build_note(':failure#$ in thtstexeg',
+ & '$',ierr,' ',0.,' ',err)
+ ELSE
+ ierr= thhstexeg(groupname)
+ ABORT= ierr.NE.0
+ If(ABORT) call G_build_note(':failure#$ in thhstexeg',
+ & '$',ierr,' ',0.,' ',err)
+
+ ierr = thtreeexeg(groupname)
+
+ ENDIF
+ ENDIF
+*
+*-HMS
+ call H_keep_results(FAIL,why)
+ IF(err.NE.' ' .and. why.NE.' ') THEN
+ call G_append(err,' & '//why)
+ ELSEIF(why.NE.' ') THEN
+ err= why
+ ENDIF
+ ABORT= ABORT .or. FAIL
+*
+*-SOS
+ call S_keep_results(FAIL,why)
+ IF(err.NE.' ' .and. why.NE.' ') THEN
+ call G_append(err,' & '//why)
+ ELSEIF(why.NE.' ') THEN
+ err= why
+ ENDIF
+ ABORT= ABORT .or. FAIL
+*
+*-COIN
+ call C_keep_results(FAIL,why)
+ IF(err.NE.' ' .and. why.NE.' ') THEN
+ call G_append(err,' & '//why)
+ ELSEIF(why.NE.' ') THEN
+ err= why
+ ENDIF
+ ABORT= ABORT .or. FAIL
+*-BIGCAL
+ call B_keep_results(FAIL,why)
+ if(err.ne.' '.and. why.ne.' ') then
+ call G_append(err,' & '//why)
+ else if(why.ne.' ') then
+ err = why
+ endif
+ abort = abort .or. fail
+*-SANE
+ call SANE_keep_results(FAIL,why)
+ if(err.ne.' '.and. why.ne.' ') then
+ call G_append(err,' & '//why)
+ else if(why.ne.' ') then
+ err = why
+ endif
+ abort = abort .or. fail
+*-GEp
+ call GEp_keep_results(FAIL,why)
+ if(err.ne.' '.and.why.ne.' ') then
+ call G_append(err,' & '//why)
+ else if(why.ne.' ') then
+ err = why
+ endif
+ abort = abort .or. fail
+
+
+*
+ IF(ABORT .or. err.NE.' ') call G_add_path(here,err)
+*
+ RETURN
+ END
diff --git a/ENGINE/g_kludgeup_kinematics.f b/ENGINE/g_kludgeup_kinematics.f
new file mode 100644
index 0000000..bc188be
--- /dev/null
+++ b/ENGINE/g_kludgeup_kinematics.f
@@ -0,0 +1,130 @@
+ SUBROUTINE G_klugeup_kinematics(ABORT,err)
+*--------------------------------------------------------
+* $Log: g_kludgeup_kinematics.f,v $
+* Revision 1.3.24.1 2007/09/10 20:33:37 pcarter
+* Implemented changes to allow compilation on RHEL 3,4,5 and MacOSX
+*
+* Revision 1.3 1996/09/04 14:38:32 saw
+* (JRA) Initialize problems logical
+*
+* Revision 1.2 1996/01/22 15:11:46 saw
+* (JRA) Change cpbeam to gpbeam
+*
+* Revision 1.1 1995/12/08 20:12:00 cdaq
+* Initial revision
+*
+*--------------------------------------------------------
+ IMPLICIT NONE
+ SAVE
+ external jishft, jiand
+*
+ character*21 here
+ parameter (here= 'g_klugeup_kinematics')
+*
+ logical ABORT
+ character*800 err,mss
+*
+ include 'gen_filenames.cmn'
+ include 'gen_craw.cmn'
+ include 'gen_run_info.cmn'
+ include 'gen_data_structures.cmn'
+ include 'hms_data_structures.cmn'
+ include 'sos_data_structures.cmn'
+*
+ logical problems
+ integer ind
+ integer evtype
+* integer SPAREID
+* parameter (SPAREID=67)
+*
+ character*80 g_config_environmental_var
+ parameter (g_config_environmental_var= 'ENGINE_CONFIG_FILE')
+*
+ integer*4 jishft,jiand
+ integer*4 status
+ integer*4 evclose
+*
+ real*4 ebeam,phms,thms,psos,tsos
+*
+*
+*--------------------------------------------------------
+*
+*-attempt to open FASTBUS-CODA file
+*
+ problems = .false.
+ g_data_source_in_hndl= 0
+ g_data_source_opened = .false.
+ call g_open_source(ABORT,err)
+ if(ABORT.or.err.ne.' ') then
+ call G_add_path(here,err)
+ call G_rep_err(ABORT,err)
+ If(ABORT) STOP
+ err= ' '
+ endif
+
+ DO ind=1,3
+ mss= ' '
+*
+c write(6,*) 'get event ',ind
+ call G_get_next_event(ABORT,err) !get and store 1 event
+c write(6,*) 'got event ',ind
+*
+* Check if this is a physics event or a CODA control event.
+*
+ if(.not.problems) then
+ evtype = jishft(craw(2),-16)
+c write(6,'(a,z10)') 'craw(2)=',craw(2)
+c write(6,*) 'evtype=',evtype
+
+ if (evtype.eq.130) then !run info event (get e,p,theta)
+ call g_extract_kinematics(ebeam,phms,thms,psos,tsos)
+ if (gpbeam .ge. 7. .and. ebeam.le.7.) then !sometimes ebeam in MeV
+ gpbeam=abs(ebeam)
+ write(6,*) 'gpbeam=',abs(ebeam),' GeV'
+ endif
+ if (hpcentral .ge. 7.) then
+ write(6,*) 'hpcentral=',abs(phms),' GeV/c'
+ hpcentral=abs(phms)
+ endif
+ if (htheta_lab .le. 0.) then
+ write(6,*) 'htheta_lab=',abs(thms),' deg.'
+ htheta_lab=abs(thms)*3.14159265/180.
+ endif
+ if (spcentral .ge. 7.) then
+ write(6,*) 'spcentral=',abs(psos),' GeV/c'
+ spcentral=abs(psos)
+ endif
+ if (stheta_lab .le. 0.) then
+ write(6,*) 'stheta_lab=',abs(tsos),' deg.'
+ stheta_lab=abs(tsos)*3.14159265/180.
+ endif
+c write(6,*) 'GOT KINEMATICS!!!'
+ endif
+
+c if(jiand(CRAW(2),'FFFF'x).eq.'10CC'x) then ! Physics event
+c write(6,*) 'AAAARRGGHHHHHH! Physics EVENT!!!!!'
+c Else
+c if(evtype.eq.129) then
+c write(6,*) 'AAAARRGGHHHHHH! Scalar EVENT!!!!!'
+c else if (evtype.eq.133) then !SAW's new go_info events
+c write(6,*) 'AAAARRGGHHHHHH! SAWs new go_info EVENT!!!!!'
+c else
+c write(6,*) 'AAAARRGGHHHHHH! well, maybe not so bad. control event'
+c call g_examine_control_event(CRAW,ABORT,err)
+c endif
+c EndIf
+ endif
+ ENDDO !found a problem or end of run
+*
+*
+ status = evclose(g_data_source_in_hndl)
+ g_data_source_opened = .false.
+ if(ABORT.or.err.ne.' ') then
+ call G_add_path(here,err)
+ call G_rep_err(ABORT,err)
+ If(ABORT) STOP
+ err= ' '
+ endif
+
+ return
+ end
diff --git a/ENGINE/g_ntuple_init.f b/ENGINE/g_ntuple_init.f
new file mode 100644
index 0000000..4067a50
--- /dev/null
+++ b/ENGINE/g_ntuple_init.f
@@ -0,0 +1,153 @@
+ SUBROUTINE g_ntuple_init(ABORT,err)
+*--------------------------------------------------------
+*- Close all ntuples
+*-
+*-
+*- Purpose and Methods : Close ntuples.
+*- Taken from ?_initialize so that s_initialize, h_initialize,
+*- and c_initialize can be called from event display without mucking
+*- with ntuples.
+*-
+*- Output: ABORT - success or failure
+*- : err - reason for failure, if any
+*-
+*-Created 6-September-1995 SAW
+* $Log: g_ntuple_init.f,v $
+* Revision 1.1.24.4.2.1 2008/05/15 18:59:21 bhovik
+* 1'st version
+*
+* Revision 1.1.24.4 2007/09/12 19:26:31 puckett
+* *** empty log message ***
+*
+* Revision 1.1.24.3 2007/08/22 19:09:16 frw
+* added FPP
+*
+* Revision 1.1.25 frw
+* added call for FPP
+*
+* Revision 1.1.24.2 2007/06/04 14:56:05 puckett
+* changed hit array structure for trigger related signals
+*
+* Revision 1.1.24.1 2007/05/15 02:55:01 jones
+* Start to Bigcal code
+*
+* Revision 1.1 1995/10/09 18:43:07 cdaq
+* Initial revision
+*
+*--------------------------------------------------------
+ IMPLICIT NONE
+ SAVE
+*
+ character*13 here
+ parameter (here= 'g_ntuple_init')
+*
+ logical ABORT
+ character*(*) err
+*
+ character*500 why
+ logical FAIL
+
+ include 'gen_run_info.cmn'
+
+*--------------------------------------------------------
+ ABORT = .false.
+ err = ' '
+*
+c write(*,*) 'about to call h_ntuple_init'
+
+ call h_ntuple_init(FAIL,why)
+
+ if(err.NE.' ' .and. why.NE.' ') then
+ call G_append(err,' & '//why)
+ elseif(why.NE.' ') then
+ err= why
+ endif
+ ABORT= ABORT .or. FAIL
+*
+ call h_fpp_nt_init(FAIL,why)
+ if(err.NE.' ' .and. why.NE.' ') then
+ call G_append(err,' & '//why)
+ elseif(why.NE.' ') then
+ err= why
+ endif
+ ABORT= ABORT .or. FAIL
+*
+c write(*,*) 'about to call h_sv_ntuple_init'
+ call h_sv_nt_init(FAIL,why)
+ if(err.NE.' ' .and. why.NE.' ') then
+ call G_append(err,' & '//why)
+ elseif(why.NE.' ') then
+ err= why
+ endif
+ ABORT= ABORT .or. FAIL
+*
+
+c write(*,*) 'about to call s_ntuple_init'
+ call s_ntuple_init(FAIL,why)
+ if(err.NE.' ' .and. why.NE.' ') then
+ call G_append(err,' & '//why)
+ elseif(why.NE.' ') then
+ err= why
+ endif
+ ABORT= ABORT .or. FAIL
+*
+c !write(*,*) 'about to call s_sv_nt_init'
+ call s_sv_nt_init(FAIL,why)
+ if(err.NE.' ' .and. why.NE.' ') then
+ call G_append(err,' & '//why)
+ elseif(why.NE.' ') then
+ err= why
+ endif
+ ABORT= ABORT .or. FAIL
+*
+ !write(*,*) 'before call to b_ntuple_init, gen_run_enable=',gen_run_enable
+ !write(*,*) 'before call to b_ntuple_init, gen_bigcal_mc=',gen_bigcal_mc
+
+ !write(*,*) 'about to call b_ntuple_init'
+ call b_ntuple_init(FAIL,why)
+ !write(*,*) 'b_ntuple_init successful'
+ if(err.ne.' '.and.why.ne.' ')then
+ call G_append(err,' & '//why)
+ elseif(why.ne.' ') then
+ err = why
+ endif
+ ABORT = ABORT .or. FAIL
+cc
+
+ call sane_ntup_init(FAIL,why)
+c write(*,*) 'sane_ntup_init successful'
+ if(err.ne.' '.and.why.ne.' ')then
+ call G_append(err,' & '//why)
+ elseif(why.ne.' ') then
+ err = why
+ endif
+ ABORT = ABORT .or. FAIL
+
+*
+
+c !write(*,*) 'about to call c_ntuple_init'
+ call c_ntuple_init(FAIL,why)
+ if(err.NE.' ' .and. why.NE.' ') then
+ call G_append(err,' & '//why)
+ elseif(why.NE.' ') then
+ err= why
+ endif
+ ABORT= ABORT .or. FAIL
+
+*
+
+C !write(*,*) 'about to call gep_ntuple_init'
+ call gep_ntuple_init(FAIL,why)
+ if(err.ne.' '.and.why.ne.' ') then
+ call G_append(err,' & '//why)
+ else if(why.ne.' ') then
+ err=why
+ endif
+
+*
+ if(ABORT .or. err.NE.' ') call g_add_path(here,err)
+*
+ return
+ end
+
+
diff --git a/ENGINE/g_ntuple_shutdown.f b/ENGINE/g_ntuple_shutdown.f
new file mode 100644
index 0000000..8e748d4
--- /dev/null
+++ b/ENGINE/g_ntuple_shutdown.f
@@ -0,0 +1,64 @@
+ SUBROUTINE g_ntuple_shutdown(ABORT,err)
+*--------------------------------------------------------
+*- Close all ntuples
+*-
+*-
+*- Purpose and Methods : Close ntuples.
+*- Taken from ?_keep_results routines so that g_keep_results can
+*- be called without closing out ntuples.
+*-
+*- Output: ABORT - success or failure
+*- : err - reason for failure, if any
+*-
+*- Created 30-June-1995 SAW
+* $Log: g_ntuple_shutdown.f,v $
+* Revision 1.2.24.2.2.1 2008/05/15 18:59:22 bhovik
+* 1'st version
+*
+* Revision 1.2.24.2 2007/08/22 19:09:16 frw
+* added FPP
+*
+* Revision 1.2.25 frw
+* added HMS FPP call
+*
+* Revision 1.2.24.1 2007/05/15 02:55:01 jones
+* Start to Bigcal code
+*
+* Revision 1.2 1995/09/01 15:46:13 cdaq
+* (JRA) Add call to sos sieve slit ntuple
+*
+* Revision 1.1 1995/07/27 19:00:55 cdaq
+* Initial revision
+*
+*--------------------------------------------------------
+ IMPLICIT NONE
+ SAVE
+*
+ character*17 here
+ parameter (here= 'g_ntuple_shutdown')
+*
+ logical ABORT
+ character*(*) err
+*--------------------------------------------------------
+ call h_ntuple_shutdown(ABORT,err)
+*
+ call h_fpp_nt_shutdown(ABORT,err)
+*
+ call h_sv_nt_shutdown(ABORT,err)
+*
+ call s_ntuple_shutdown(ABORT,err)
+*
+ call s_sv_nt_shutdown(ABORT,err)
+*
+ call c_ntuple_shutdown(ABORT,err)
+*
+ call b_ntuple_shutdown(ABORT,err)
+*
+ call sane_ntup_shutdown(ABORT,err)
+*
+ call gep_ntuple_shutdown(ABORT,err)
+*
+ return
+ end
+
+
diff --git a/ENGINE/g_open_source.f b/ENGINE/g_open_source.f
new file mode 100644
index 0000000..66ec6b2
--- /dev/null
+++ b/ENGINE/g_open_source.f
@@ -0,0 +1,133 @@
+ SUBROUTINE G_open_source(ABORT,err)
+*----------------------------------------------------------------------
+*- Prototype hall C open (FASTBUS) CODA file routine
+*-
+*- Purpose and Methods : Initialization is performed and status returned
+*-
+*- Output: ABORT - success or failure
+*- : err - reason for failure, if any
+*-
+*- Created 30-Nov-1993 Kevin B. Beard
+*
+* $Log: g_open_source.f,v $
+* Revision 1.5.24.3 2007/09/07 16:06:07 puckett
+* added 'gen_bigcal_mc.eq.3' flag to g_open_source
+*
+* Revision 1.5.24.2 2007/06/26 16:36:45 puckett
+* latest changes for monte carlo analysis, latest fixes for cluster finding routine
+*
+* Revision 1.5.24.1 2007/06/20 18:26:32 puckett
+* Added BigCal Monte Carlo analysis capability
+*
+* Revision 1.5 2002/09/25 13:51:30 jones
+* add code for analyzing segmented data files.
+*
+* Revision 1.4 1996/01/16 18:16:01 cdaq
+* no change
+*
+* Revision 1.3 1995/05/11 16:18:51 cdaq
+* (SAW) Allow %d run number substitution in data source filename
+*
+* Revision 1.2 1995/01/27 20:11:48 cdaq
+* (SAW) Add setting of ABORT
+*
+* Revision 1.1 1994/02/04 22:11:29 cdaq
+* Initial revision
+*
+*-
+*- All standards are from "Proposal for Hall C Analysis Software
+*- Vade Mecum, Draft 1.0" by D.F.Geesamn and S.Wood, 7 May 1993
+*-
+*--------------------------------------------------------
+ IMPLICIT NONE
+ SAVE
+*
+ character*13 here
+ parameter (here= 'G_open_source')
+*
+ logical ABORT
+ character*(*) err
+*
+ INCLUDE 'gen_filenames.cmn'
+ INCLUDE 'gen_run_info.cmn'
+c include 'bigcal_bypass_switches.cmn'
+ include 'bigcal_data_structures.cmn'
+*
+ integer g_important_length
+*
+ integer*4 status
+ integer*4 evopen ! CODA routine
+ character*132 file
+ integer fname_len
+ integer*4 io_dat
+*
+*--------------------------------------------------------
+ err= ' '
+ ABORT = .FALSE.
+ g_data_source_in_hndl= 0
+*
+ file = g_data_source_filename
+ if(gen_bigcal_mc.ne.0) then ! Monte Carlo!!!
+ if(gen_bigcal_mc.eq.1.or.gen_bigcal_mc.eq.3) then
+ call g_IO_control(io_dat,'ANY',ABORT,err)
+ if(abort) then
+ call g_add_path(here,err)
+ return
+ endif
+ call g_sub_run_number(file,gen_run_number)
+ g_data_source_in_hndl = io_dat
+ open(unit=g_data_source_in_hndl,file=file,status='old',
+ $ form='unformatted',err=34)
+
+ goto 35
+
+ 34 g_data_source_opened = .false.
+ abort = .true.
+ err='error opening bigcal mc .dat file '//file
+ call g_add_path(here,err)
+ return
+
+ 35 write(*,*) 'Opened bigcal mc .dat file '//file//
+ $ ' successfully'
+ g_data_source_opened = .true.
+ EOF_MC_DAT = .false.
+ else if(gen_bigcal_mc.eq.2) then
+ ! open wei's ntuple file
+ g_data_source_opened = .false. !for now
+ endif
+ else
+ call g_sub_run_number(file,gen_run_number)
+ status = evopen(file,'r',g_data_source_in_hndl)
+ if(status.ne.0) then
+* call cemsg(status,0,err)
+* If filename doesn't end in a digit, try adding ".0" to the end and
+* opening that.
+ fname_len = g_important_length(file)
+ if(ichar(file(fname_len:fname_len)).le.ichar('0')
+ $ .or.ichar(file(fname_len:fname_len)).ge.ichar('9'))then
+ g_segment = 0 ! First segment
+ file(fname_len+1:fname_len+2) = '.0'
+ status = evopen(file,'r',g_data_source_in_hndl)
+ if(status.ne.0) then
+ g_data_source_opened = .false.
+ else
+ g_data_source_opened = .true.
+ endif
+ else
+ g_data_source_opened = .false.
+ endif
+ else
+ g_data_source_opened = .true.
+ g_segment = -1 ! Not segmented
+ endif
+*
+ IF(.not.g_data_source_opened) THEN
+ err= ':could not open "'//file//'"'
+ call G_add_path(here,err)
+ ABORT = .TRUE.
+ ENDIF
+*
+ endif
+ RETURN
+ END
+
diff --git a/ENGINE/g_output_thresholds.f b/ENGINE/g_output_thresholds.f
new file mode 100644
index 0000000..3646ede
--- /dev/null
+++ b/ENGINE/g_output_thresholds.f
@@ -0,0 +1,169 @@
+ subroutine g_output_thresholds(lunout,roc,slot,signalcount,
+ & elements_per_plane,signal0,signal1,sigma0,sigma1)
+* $Log: g_output_thresholds.f,v $
+* Revision 1.7.20.4 2007/11/29 18:37:17 cdaq
+* added special handling of ROC11, slot 19 (bigcal trig. ADCs)
+*
+* Revision 1.7.20.3 2007/10/19 14:50:45 cdaq
+* *** empty log message ***
+*
+* Revision 1.7.20.2 2007/10/12 02:03:44 puckett
+* *** empty log message ***
+*
+* Revision 1.7.20.1 2007/09/11 19:14:17 frw
+* fixed FPP related arrays and limits
+*
+* Revision 1.7 2003/09/05 15:53:04 jones
+* Merge in online03 changes (mkj)
+*
+* Revision 1.6.2.1 2003/04/09 16:51:38 cdaq
+* Added # to comment written out to threshold file. (MKJ)
+*
+* Revision 1.6 1999/02/23 18:23:01 csa
+* (JRA) Move temps to signalcount 2 and make SunOS fixes
+*
+* Revision 1.5 1996/09/04 14:39:01 saw
+* (JRA) Modify write statements
+*
+* Revision 1.4 1996/01/22 15:22:57 saw
+* (JRA) Add/Modify some commented out diagnostics
+*
+* Revision 1.3 1996/01/17 20:25:27 saw
+* (SAW) Add back missing sigma0 and sigma1 arguments that got lost
+*
+* Revision 1.2 1996/01/16 18:13:50 cdaq
+* (JRA) Warn if thresholds change by too much
+*
+* Revision 1.1 1995/11/28 19:12:22 cdaq
+* Initial revision
+*
+ implicit none
+ save
+*
+ character*21 here
+ parameter (here='g_output_thresholds')
+*
+ integer*4 lunout
+ integer*4 roc,slot
+ integer*4 signalcount,elements_per_plane
+ real*4 signal0(*),signal1(*)
+ real*4 sigma0(*),sigma1(*)
+ real*4 delta_ped
+*
+ integer*4 pln,cnt,element,sigtyp
+ integer*4 ich,ind,istart
+ logical annoying_message
+*
+ INCLUDE 'gen_detectorids.par'
+ INCLUDE 'gen_decode_common.cmn'
+
+ annoying_message=.true.
+
+
+ istart=g_decode_slotpointer(roc,slot)
+ if (istart.eq.-1) then !uninstrumented slot.
+ write(lunout,*) '# roc#',roc,', slot#',slot,' is not in the map'
+ return
+ endif
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!
+ if (signalcount.eq.1) then !cerenkov.
+ do ich=1,g_decode_subaddcnt(roc,slot)
+ ind=istart+ich-1
+ pln=g_decode_planemap(ind)
+
+ if(roc.eq.12) then ! BigCal RCS part
+ pln = pln - 32
+ endif
+
+ cnt=g_decode_countermap(ind)
+ if (g_decode_didmap(ind).eq.UNINST_ID) then
+ write(lunout,'(a6)') ' 4000' ! set threshold very high if there is no signal
+ else
+ element=(pln-1)*elements_per_plane+cnt
+ write(lunout,'(i6)') nint(signal0(element))
+ delta_ped=signal0(element)-float(g_threshold_readback(ich,roc,slot))
+ if ( (abs(delta_ped) .gt. min(20.,2.*sigma0(element))) .and.
+ & g_threshold_readback(ich,roc,slot).ne.0) then
+ if (annoying_message.and..not.(roc.eq.11.and.slot.eq.19)) then
+ write(6,*) 'Warning! Danger Will Robinson! Inconsistant Thresholds approaching!'
+ write(6,'(a)') 'May require updating hms(sos)_thresholds.dat in ~cdaq/coda to avoid losing data'
+ write(6,*) ' roc slot channel threshold calc.thresh. delta #sigma(pos. is OK).'
+ annoying_message=.false.
+ endif
+ if(.not.(roc.eq.11.and.slot.eq.19)) then
+ write(6,'(2x,i3,i5,i6,i11,2f11.1,f9.1)') roc,slot,ich,
+ & g_threshold_readback(ich,roc,slot),signal0(element),delta_ped,delta_ped/(sigma0(element)+.001)
+ else
+ if(abs(delta_ped).gt.2.*sigma0(element)) then
+ write(6,'(2x,i3,i5,i6,i11,2f11.1,f9.1)') roc,slot,ich,
+ & g_threshold_readback(ich,roc,slot),signal0(element),delta_ped,delta_ped/(sigma0(element)+.001)
+ endif
+ endif
+ endif
+ endif
+ enddo
+!!!!!!!!!!!!!!!!!!!!!!!!!!
+ else if (signalcount.eq.2) then !hodoscopes, calorimeter (w/2nd PMT).
+ do ich=1,g_decode_subaddcnt(roc,slot)
+ ind=istart+ich-1
+ pln=g_decode_planemap(ind)
+ cnt=g_decode_countermap(ind)
+ sigtyp=g_decode_sigtypmap(ind)
+
+ if ( (roc.eq.1.and.slot.eq.1) .or. (roc.eq.1.and.slot.eq.5) .or.
+ & (roc.eq.3.and.slot.eq.1) .or. (roc.eq.3.and.slot.eq.5) ) then
+ element=cnt+(pln-1)*elements_per_plane !calorimeter
+ else !hodoscope. convert 2d pln,cnt to 1d array
+ element=pln+(cnt-1)*elements_per_plane
+ endif
+
+ if (roc.eq.1 .and. slot.eq.1 .and. (ich.eq.63 .or. ich.eq.64)) then
+ write(lunout,'(a6)') ' 0' ! no threshold for muon hodoscope
+ goto 999
+* not hooked up: 2/18/99
+* else if (roc.eq.3 .and. slot.eq.1 .and. ich.eq.64) then
+* write(lunout,'(a6)') ' 0' ! no threshold for laser gain photodiode
+* goto 999
+ endif
+ if (g_decode_didmap(ind).eq.UNINST_ID) then
+ write(lunout,'(a6)') ' 4000' ! set threshold very high if there is no signal
+ else
+ if (sigtyp.eq.0) then
+ write(lunout,'(i6)') nint(signal0(element))
+ delta_ped=signal0(element)-float(g_threshold_readback(ich,roc,slot))
+ if ( (abs(delta_ped) .gt. min(20.,2.*sigma0(element))) .and.
+ & g_threshold_readback(ich,roc,slot).ne.0) then
+ if (annoying_message) then
+ write(6,*) 'Warning! Danger Will Robinson! Inconsistant Thresholds approaching!'
+ write(6,*) ' roc slot channel threshold calc.thresh. delta #sigma(pos. is OK).'
+ annoying_message=.false.
+ endif
+ write(6,'(2x,i3,i5,i6,i11,2f11.1,f9.1)') roc,slot,ich,
+ & g_threshold_readback(ich,roc,slot),signal0(element),delta_ped,delta_ped/(sigma0(element)+.001)
+ endif
+ else if (sigtyp.eq.1) then
+ write(lunout,'(i6)') nint(signal1(element))
+ delta_ped=signal1(element)-float(g_threshold_readback(ich,roc,slot))
+ if ( (abs(delta_ped) .gt. min(20.,2.*sigma1(element))) .and.
+ & g_threshold_readback(ich,roc,slot).ne.0) then
+ if (annoying_message) then
+ write(6,*) 'Warning! Danger Will Robinson! Inconsistant Thresholds approaching!'
+ write(6,*) ' roc slot channel threshold calc.thresh. delta #sigma(pos. is OK).'
+ annoying_message=.false.
+ endif
+ write(6,'(2x,i3,i5,i6,i11,2f11.1,f9.1)') roc,slot,ich,
+ & g_threshold_readback(ich,roc,slot),signal1(element),delta_ped,delta_ped/(sigma1(element)+.001)
+ endif
+ else
+ write(6,*) 'sigtyp=',sigtyp,' in g_output_thresholds (should be 0 or 1)'
+ endif
+ endif
+ 999 continue
+ enddo
+ else
+ write(6,*) 'signalcount=',signalcount,' in g_output_thresholds (1=cal/cer, 2=hodoscopes)'
+ endif
+
+ return
+ end
diff --git a/ENGINE/g_preproc_event.f b/ENGINE/g_preproc_event.f
new file mode 100644
index 0000000..036ff43
--- /dev/null
+++ b/ENGINE/g_preproc_event.f
@@ -0,0 +1,89 @@
+ SUBROUTINE g_preproc_event(preprocessor_keep_event)
+*---------------------------------------------------------------------
+* prototype C analysis routine
+*
+* purpose and mothods : check the event for defined criteria and
+* set flag to 1 if it meets these criteria.
+*
+*
+*
+* created apr-29-1996 Dave Meekins
+* $Log: g_preproc_event.f,v $
+* Revision 1.1 1996/06/10 17:47:43 saw
+* Initial revision
+*
+*---------------------------------------------------------------------
+
+
+ IMPLICIT NONE
+ SAVE
+
+ character*20 here
+ parameter (here='g_preproc_event')
+
+ integer*4 preprocessor_keep_event
+
+* make sure to include all the necessary include files
+* so that the tests below can be carried out
+
+ INCLUDE 'hms_data_structures.cmn'
+ INCLUDE 'sos_data_structures.cmn'
+ INCLUDE 'hms_scin_tof.cmn'
+ INCLUDE 'sos_scin_tof.cmn'
+ INCLUDE 'gen_event_info.cmn'
+
+
+ preprocessor_keep_event=0
+
+* test for good event
+
+* ALL COINCIDENCE EVENTS, coin only (should disable tracking
+* and decoding when analyzing, since no analysis is needed).
+ if (gen_event_type.eq.3 .or. gen_event_type.eq.4) then
+ preprocessor_keep_event=1
+ endif
+
+* ALL HMS (AND COINCIDENCE) EVENTS, (should disable tracking
+* and decoding when analyzing, since no analysis is needed).
+! if (gen_event_type.eq.1 .or. gen_event_type.eq.3 .or.
+! & gen_event_type.eq.4) then
+! preprocessor_keep_event=1
+! endif
+
+* ALL SOS (AND COINCIDENCE) EVENTS, (should disable tracking
+* and decoding when analyzing, since no analysis is needed).
+! if (gen_event_type.eq.2 .or. gen_event_type.eq.3 .or.
+! & gen_event_type.eq.4) then
+! preprocessor_keep_event=1
+! endif
+
+* MEEK'S TESTS.
+* Keep pedestals, SOS and COIN with good beta_notrk, reject HMS
+! if (gen_event_type.eq.1) then !HMS singles trigger
+! if ((hbeta_notrk.gt.0).and.(hbeta_notrk.lt.0.01))then
+! preprocessor_keep_event=1
+! endif
+!
+! else if (gen_event_type.eq.2) then !SOS singles trigger
+! if((sbeta_notrk.gt.0).and.(sbeta_notrk.lt.1.5))then
+! preprocessor_keep_event=1
+! endif
+!
+! else if (gen_event_type.eq.3) then !COIN trigger
+! if( ((sbeta_notrk.gt.0).and.(sbeta_notrk.lt.1.5)) .or.
+! & ((hbeta_notrk.gt.0).and.(hbeta_notrk.lt.0.01)) ) then
+! preprocessor_keep_event=1
+! endif
+!
+! else if (gen_event_type.eq.4) then !PED trigger
+! preprocessor_keep_event=1
+!
+! else
+! write(6,*) 'g_preproc_event was called for event type',
+! & gen_event_type
+! write(6,*) ' should only be called for event types 1-4 (I think-JRA)'
+!
+! endif
+
+ RETURN
+ END
diff --git a/ENGINE/g_preproc_open.f b/ENGINE/g_preproc_open.f
new file mode 100644
index 0000000..35b4ebc
--- /dev/null
+++ b/ENGINE/g_preproc_open.f
@@ -0,0 +1,58 @@
+ SUBROUTINE g_preproc_open(ABORT,err)
+*---------------------------------------------------------------------
+* opens file for output of preprocessed events in CODA format
+*
+* Purpose and Methods: Initialization is done status is returned.
+*
+* output: ABORT success or failure
+* err reason for fault if any
+*
+* created: apr-29-1996 Dave Meekins
+*
+*
+* I don't know what other crap I need to fill in here
+* $Log: g_preproc_open.f,v $
+* Revision 1.1 1996/06/10 17:48:15 saw
+* Initial revision
+*
+*---------------------------------------------------------------------
+ IMPLICIT NONE
+ SAVE
+*
+* variables
+*
+ character*40 here
+ parameter(here='g_preproc_open')
+ logical ABORT
+ character*(*) err
+ integer*4 status !status
+ integer*4 evopen !CODA ouput file opening routine
+ character*132 file
+*
+* common files
+*
+ include 'gen_filenames.cmn'
+ include 'gen_run_info.cmn'
+*
+* inits
+*
+ err=' '
+ g_preproc_in_hndl=0
+*
+ file = g_preproc_filename
+ write(6,*) file
+ call g_sub_run_number(file,gen_run_number)
+
+ status=evopen(file,'w',g_preproc_in_hndl)
+ if(status.eq.0)then
+ g_preproc_opened = .true.
+ else
+ call cemsg(status,0,err)
+ g_preproc_opened = .false.
+ write(6,*) 'could not open preprocessor output file '
+ err=':error opening"'//file//'"'
+ call G_add_path(here,err)
+ endif
+*
+ RETURN
+ END
diff --git a/ENGINE/g_proper_shutdown.f b/ENGINE/g_proper_shutdown.f
new file mode 100644
index 0000000..09e9022
--- /dev/null
+++ b/ENGINE/g_proper_shutdown.f
@@ -0,0 +1,199 @@
+ SUBROUTINE G_proper_shutdown(ABORT,err)
+*--------------------------------------------------------
+*- Prototype C analysis routine
+*-
+*-
+*- Purpose and Methods : Closes files properly, flushes, etc.
+*-
+*- Output: ABORT - success or failure
+*- : err - reason for failure, if any
+*-
+*- Created 20-Nov-1993 Kevin B. Beard for new error standards
+* $Log: g_proper_shutdown.f,v $
+* Revision 1.14.8.2 2007/06/04 14:56:05 puckett
+* changed hit array structure for trigger related signals
+*
+* Revision 1.14.8.1 2007/05/15 02:55:01 jones
+* Start to Bigcal code
+*
+* Revision 1.13.10.1 2004/07/09 14:12:47 saw
+* Add function calls to fill CTP ROOT Trees
+*
+* Revision 1.13 2004/02/17 17:27:10 jones
+* Only dump histograms when g_histout_filename is set.
+*
+* Revision 1.12 1999/02/23 18:24:23 csa
+* (JRA) Remove debugcalcpeds stuff, cleanup
+*
+* Revision 1.11 1996/09/04 14:40:05 saw
+* (JRA) Get filename for "bad" report from a ctp variable
+*
+* Revision 1.10 1995/10/09 18:44:27 cdaq
+* (JRA) Only write pedestal file if appropriate control flag(s) set.
+*
+* Revision 1.9 1995/09/01 15:46:41 cdaq
+* (JRA) Open temp file for pedestal outputs
+*
+* Revision 1.8 1995/07/27 19:03:36 cdaq
+* (SAW) Error return fix up
+*
+* Revision 1.7 1995/05/22 13:29:24 cdaq
+* (JRA) Make a listing of potential detector problems
+*
+* Revision 1.6 1995/04/01 19:42:36 cdaq
+* (SAW) One report file for each of g, h, s, c instead of a single report file
+*
+* Revision 1.5 1994/08/04 03:45:46 cdaq
+* (SAW) Add call to Breuer's hack_shutdown
+*
+* Revision 1.4 1994/06/22 19:49:31 cdaq
+* (SAW) Create report file and append g_report_template to it
+*
+* Revision 1.3 1994/06/14 19:13:20 cdaq
+* (SAW) Move histogram saving to new routine g_dump_histograms
+*
+* Revision 1.2 1994/04/15 20:36:49 cdaq
+* (KBB) Add ntuple handling
+*
+* Revision 1.1 1994/02/04 22:12:15 cdaq
+* Initial revision
+*
+*-
+*- All standards are from "Proposal for Hall C Analysis Software
+*- Vade Mecum, Draft 1.0" by D.F.Geesamn and S.Wood, 7 May 1993
+*-
+*-
+*--------------------------------------------------------
+ IMPLICIT NONE
+ SAVE
+
+ character*17 here
+ parameter (here= 'G_proper_shutdown')
+
+ logical ABORT
+ character*(*) err
+
+ logical bad_report,bad_HMS,bad_SOS,bad_COIN,bad_HBK,bad_hack
+ logical bad_BIGCAL
+ logical bad_GEP
+ character*132 err_report,err_HMS,err_SOS,err_COIN,err_HBK,err_hack
+ character*132 err_BIGCAL,err_GEP
+ integer SPAREID
+ parameter (SPAREID=67)
+
+ include 'gen_filenames.cmn'
+ include 'gen_routines.dec'
+ include 'gen_run_info.cmn'
+ include 'hms_data_structures.cmn'
+ include 'hms_tracking.cmn'
+ include 'sos_data_structures.cmn'
+ include 'sos_tracking.cmn'
+ include 'bigcal_data_structures.cmn'
+
+ integer ierr
+ character*132 file
+*--------------------------------------------------------
+ bad_report = .TRUE.
+ err_report = 'Failed to open report file'
+
+ ierr=thtreewriteg('all') ! Flush
+
+ if (g_bad_output_filename.ne.' ') then
+ file = g_bad_output_filename
+ call g_sub_run_number(file, gen_run_number)
+
+ open(unit=SPAREID,file=file,status='unknown')
+ else
+ open(unit=SPAREID,file='bad.tmp',status='unknown')
+ endif
+
+*-chance to flush any statistics, etc.
+
+ call H_proper_shutdown(SPAREID,bad_HMS,err_HMS)
+
+
+
+ call S_proper_shutdown(SPAREID,bad_SOS,err_SOS)
+
+
+
+ call B_proper_shutdown(SPAREID,bad_BIGCAL,err_BIGCAL)
+
+
+
+ call C_proper_shutdown(SPAREID,bad_COIN,err_COIN)
+
+
+
+ call GEP_proper_shutdown(SPAREID,bad_GEP,err_GEP)
+
+
+ close(unit=SPAREID)
+
+ call hack_shutdown(bad_hack,err_hack)
+
+ if (g_histout_filename .ne. ' ') then
+ call g_dump_histograms(bad_HBK,err_HBK)
+ endif
+
+ bad_report = .false.
+ err_report = ' '
+
+ if(g_report_blockname.ne.' '.and.
+ $ g_report_output_filename.ne.' ') then
+
+ file = g_report_output_filename
+ call g_sub_run_number(file, gen_run_number)
+
+ ierr = threp(g_report_blockname,file)
+ if(ierr.ne.0) then
+ bad_report = .true.
+ err_report = 'threp failed to create report in file '//file
+ endif
+ endif
+
+ ABORT= bad_HMS .or. bad_SOS .or. bad_COIN .or. bad_HBK
+ $ .or. bad_report .or. bad_BIGCAL.or.bad_GEP
+ err= ' '
+ IF(ABORT) THEN !assemble error message
+ if(bad_report) err = err_report
+ If(bad_HBK) Then
+ call G_prepend(err_HBK//' &',err)
+ elseif (bad_HBK) then
+ err= err_HBK
+ EndIf
+ If(bad_COIN .and. err.NE.' ') Then
+ call G_prepend(err_COIN//' &',err)
+ ElseIf(bad_COIN) Then
+ err= err_COIN
+ EndIf
+ If(bad_SOS .and. err.NE.' ') Then
+ call G_prepend(err_SOS//' &',err)
+ ElseIf(bad_SOS) Then
+ err= err_SOS
+ EndIf
+ If(bad_HMS .and. err.NE.' ') Then
+ call G_prepend(err_HMS//' &',err)
+ ElseIf(bad_HMS) Then
+ err= err_HMS
+ EndIf
+ If(bad_BIGCAL .and. err .ne. ' ') then
+ call G_prepend(err_BIGCAL//' &',err)
+ else if(bad_BIGCAL) then
+ err = err_BIGCAL
+ endif
+
+ if(bad_GEP .and. err .ne.' ') then
+ call G_prepend(err_GEP//' &',err)
+ else if(bad_GEP) then
+ err = err_GEP
+ end if
+
+ call G_add_path(here,err)
+ ENDIF
+
+ bad_HBK = .false.
+ err_HBK = ' '
+
+ RETURN
+ END
diff --git a/ENGINE/g_reconstruction.f b/ENGINE/g_reconstruction.f
new file mode 100644
index 0000000..cd95d10
--- /dev/null
+++ b/ENGINE/g_reconstruction.f
@@ -0,0 +1,324 @@
+ SUBROUTINE G_reconstruction(event,ABORT,err)
+*----------------------------------------------------------------------
+*- Prototype hall C reconstruction routine
+*-
+*- Purpose and Methods : Given previously filled data structures,
+*- reconstruction is performed and status returned
+*-
+*- Inputs:
+*- event Pointer to the first word (length) of an event data bank.
+*-
+*- Output: ABORT - success or failure
+*- : err - reason for failure, if any
+*-
+*- Created 20-Oct-1993 Kevin B. Beard
+*- Modified 20-Nov-1993 KBB for new error routines
+* $Log: g_reconstruction.f,v $
+* Revision 1.13.24.9.2.7 2011/05/31 15:34:47 jones
+* increment g_hel_pos and g_hel_neg for trigtype=1,2,3 or 4 .
+* Before incremented just for trigtype=4
+*
+* Revision 1.13.24.9.2.6 2009/09/29 13:59:53 jones
+* Add lines:
+* if(gen_event_trigtype(4).eq.1)then
+* if(gbeam_helicity_TS.eq.1)g_hel_pos = g_hel_pos+1
+* if(gbeam_helicity_TS.eq.-1)g_hel_neg = g_hel_neg+1
+* endif
+* This is the number of T4 helicity plus and minus triggers
+* Used to calculate the computer lifetime
+*
+* Revision 1.13.24.9.2.5 2009/09/15 20:39:59 jones
+* Call gep_hysics for event_type = 1 and 6 instead of just 6
+*
+* Revision 1.13.24.9.2.4 2009/09/02 13:39:35 jones
+* eliminate commented write statements
+*
+* Revision 1.13.24.9.2.3 2009/02/17 21:18:32 cdaq
+* Changed so b_reconstruction always called
+*
+* Revision 1.13.24.9.2.2 2008/10/26 19:12:33 cdaq
+* SEM
+*
+* Revision 1.13.24.9.2.1 2008/10/02 17:58:46 cdaq
+* *** empty log message ***
+*
+* Revision 1.13.24.9 2008/01/08 22:43:13 cdaq
+* *** empty log message ***
+*
+* Revision 1.13.24.8 2007/10/19 14:54:58 cdaq
+* *** empty log message ***
+*
+* Revision 1.13.24.7 2007/10/19 14:49:41 cdaq
+* *** empty log message ***
+*
+* Revision 1.13.24.6 2007/10/17 16:08:08 cdaq
+* Changed if-block for beamline analysis. Now call for any event type 1-8 if flag is set
+*
+* Revision 1.13.24.5 2007/10/10 16:24:31 puckett
+* *** empty log message ***
+*
+* Revision 1.13.24.4 2007/10/08 19:22:59 puckett
+* Added bad channel list handling for BigCal
+*
+* Revision 1.13.24.3 2007/09/07 16:08:05 puckett
+* put event type 3 option back in for call to h_reconstruction, just in case somebody wants to use it. Also added event type 7 and 8 for calls to b_reconstruction, for the case of the cosmic/light box trigger for bigcal
+*
+* Revision 1.13.24.2 2007/06/04 14:56:06 puckett
+* changed hit array structure for trigger related signals
+*
+* Revision 1.13.24.1 2007/05/15 02:55:01 jones
+* Start to Bigcal code
+*
+* Revision 1.13 1996/01/22 15:23:34 saw
+* (SAW) Add calls to analyze beam position
+*
+* Revision 1.12 1995/10/09 18:28:41 cdaq
+* (JRA) Only call spec analysis routines that correspond to trigger type
+*
+* Revision 1.11 1995/05/22 20:50:45 cdaq
+* (SAW) Split gen_data_data_structures into gen, hms, sos, and coin parts"
+*
+* Revision 1.10 1995/04/01 19:50:22 cdaq
+* (JRA) Add pedestal event handling
+*
+* Revision 1.9 1994/11/22 20:13:39 cdaq
+* (SPB) Uncomment call to SOS code
+*
+* Revision 1.8 1994/10/11 20:03:27 cdaq
+* (JRA) Comment out call to SOS
+*
+* Revision 1.7 1994/08/04 03:46:31 cdaq
+* (SAW) Add call to Breuer's hack_anal
+*
+* Revision 1.6 1994/06/17 03:36:57 cdaq
+* (KBB) Upgrade error reporting
+*
+* Revision 1.5 1994/04/15 20:37:41 cdaq
+* (SAW) for ONLINE compatibility get event from argument instead of commmon.
+*
+* Revision 1.4 1994/02/02 19:58:47 cdaq
+* Remove some damn nulls at the end of the file
+*
+* Revision 1.3 1994/02/02 18:53:43 cdaq
+* Actually add call to g_decode_event_by_banks
+*
+* Revision 1.2 1994/02/01 21:28:48 cdaq
+* Add call to G_decode_event_by_banks
+*
+*-
+*- All standards are from "Proposal for Hall C Analysis Software
+*- Vade Mecum, Draft 1.0" by D.F.Geesamn and S.Wood, 7 May 1993
+*-
+*--------------------------------------------------------
+ IMPLICIT NONE
+ SAVE
+*
+ integer*4 event(*)
+*
+ character*16 here
+ parameter (here= 'G_reconstruction')
+*
+ logical ABORT
+ character*(*) err
+*
+ INCLUDE 'gen_data_structures.cmn'
+ INCLUDE 'gen_event_info.cmn'
+ include 'gen_run_info.cmn'
+ INCLUDE 'hack_.cmn'
+ include 'bigcal_data_structures.cmn'
+ include 'bigcal_bypass_switches.cmn'
+ include 'gen_scalers.cmn'
+*
+ logical FAIL
+ character*1024 why
+*
+ logical update_peds ! TRUE = There is new pedestal data
+*--------------------------------------------------------
+*
+ ABORT= .FALSE.
+ err= ' ' !erase any old errors
+*
+
+ call G_decode_event_by_banks(event,ABORT,err)
+
+ IF(ABORT) THEN
+ call G_add_path(here,err)
+ RETURN
+ ENDIF
+C
+C SORTING F1 TRIGGERS BY COUNTERS
+C
+ CALL f1trigger_sort_by_counter()
+
+c if(gen_event_trigtype(4).eq.1)then
+c if(gbeam_helicity_TS.eq.1)g_hel_pos = g_hel_pos+1
+c if(gbeam_helicity_TS.eq.-1)g_hel_neg = g_hel_neg+1
+c endif
+
+ if(gen_event_trigtype(4).eq.1.or.
+ , gen_event_trigtype(1).eq.1.or.
+ , gen_event_trigtype(3).eq.1.or.
+ , gen_event_trigtype(2).eq.1.)then
+c if(gen_event_trigtype(4).eq.1.and.nclust.eq.0)write(*,*)0
+ if(gbeam_helicity_TS.eq.1)g_hel_pos= g_hel_pos+1
+ if(gbeam_helicity_TS.eq.-1)g_hel_neg = g_hel_neg+1
+ endif
+c write(*,*)g_hel_pos_tot,g_hel_pos,g_hel_neg_tot,g_hel_neg,
+c , gscaler_change(535),gscaler_change(536),gscaler_change(537),gscaler_change(538)
+
+*
+*
+* INTERRUPT ANALYSIS FOR PEDESTAL EVENTS.
+*
+*
+!!!! Commenting out next 6 lines so peds go to data. - wra
+c IF(gen_event_type .eq. 4) then !pedestal event
+c call g_analyze_pedestal(ABORT,err)
+c
+c update_peds = .true. !need to recalculate pedestals
+c RETURN
+c ENDIF
+!! added the following line - wra
+* update_peds = .true.
+
+*
+* check to see if pedestals need to be recalculated. Note that this is only
+* done if the event was NOT a scaler event, because of the 'return' at the
+* end of the pedestal handling call.
+*
+ IF(update_peds) then
+ !write(*,*) 'calling g_calc_pedestal,evtype=',gen_event_type
+ call g_calc_pedestal(ABORT,err)
+ !write(*,*) 'g_calc_pedestal successful'
+ update_peds = .false.
+c ncalls_calc_ped = ncalls_calc_ped + 1
+ ENDIF
+
+
+
+*
+*-Beamline reconstruction
+*-for GEp, avoid event types 2 and 3!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! (No SOS!)
+c IF(gen_event_type.ge.1 .and. gen_event_type.le.3) then !HMS/SOS/COIN trig
+c$$$ if((gen_event_type.eq.1 .or. gen_event_type.eq.5 .or.
+c$$$ $ gen_event_type.eq.6).and.gen_analyze_beamline.ne.0) then ! 1 = HMS singles, 5 = BigCal singles, 6 = HMS-BigCal coin.
+
+ if(b_suppress_annoying_pulser.ne.0.and.bigcal_annoying_pulser_event) then
+c write(*,*) 'found annoying pulser event, skipping'
+ return
+ endif
+
+ if(gen_event_type.ge.1.and.gen_event_type.le.8.and.gen_analyze_beamline
+ $ .ne.0) then
+ !write(*,*) 'calling g_trans_misc'
+ call g_trans_misc(FAIL,why)
+ !write(*,*) 'g_trans_misc successful'
+ IF(err.NE.' ' .and. why.NE.' ') THEN
+ call G_append(err,' & '//why)
+ ELSEIF(why.NE.' ') THEN
+ err= why
+ ENDIF
+ ABORT= ABORT .or. FAIL
+
+ !write(*,*) 'calling g_analyze_misc'
+ call g_analyze_misc(FAIL,why) !UNCOMMENT WHEN WE GET IN HALL AND BEAM ON!
+ !write(*,*) 'g_analyze_misc successful'
+ IF(err.NE.' ' .and. why.NE.' ') THEN
+ call G_append(err,' & '//why)
+ ELSEIF(why.NE.' ') THEN
+ err= why
+ ENDIF
+ ABORT= ABORT .or. FAIL
+ ENDIF
+c
+c
+c SEM FILL
+c
+c
+ call sem_fill_tbpm()
+ call sem_calc_sr_beampos()
+
+*
+*-HMS reconstruction
+c IF(gen_event_type.eq.1 .or. gen_event_type.eq.3) then !HMS/COIN trig
+
+ if(gen_event_type.eq.1 .or. gen_event_type .eq. 6 .or.
+ $ gen_event_type .eq. 3) then !HMS/COIN trig
+
+c write(*,*) 'calling HMS reconstruction, gen_event_type=',gen_event_type
+
+ call H_reconstruction(FAIL,why)
+ IF(err.NE.' ' .and. why.NE.' ') THEN
+ call G_append(err,' & '//why)
+ ELSEIF(why.NE.' ') THEN
+ err= why
+ ENDIF
+ ABORT= ABORT .or. FAIL
+ ENDIF
+*
+*-SOS reconstruction
+ IF(gen_event_type.eq.2 .or. gen_event_type.eq.3) then !SOS/COIN trig
+ call S_reconstruction(FAIL,why)
+ IF(err.NE.' ' .and. why.NE.' ') THEN
+ call G_append(err,' & '//why)
+ ELSEIF(why.NE.' ') THEN
+ err= why
+ ENDIF
+ ABORT= ABORT .or. FAIL
+ ENDIF
+*-BIGCAL reconstruction
+c changed to always do pyb Feb. 17 2009
+c if((gen_event_type.ge.5 .and.
+c > gen_event_type.le.8).or.
+c > gen_event_type.eq.13) then !5.BIGCAL/6.HMS-BIGCAL COIN/7.COSMIC/8.LIGHT BOX
+ if(gen_event_type.ne.99999) then
+ !write(*,*) 'calling b_reconstruction'
+
+ call B_reconstruction(FAIL,why)
+
+ !write(*,*) 'b_reconstruction successful'
+ IF(err.NE.' ' .and. why.NE.' ') THEN
+ call G_append(err,' & '//why)
+ ELSEIF(why.NE.' ') THEN
+ err= why
+ ENDIF
+ ABORT= ABORT .or. FAIL
+ endif
+*-GEP-COIN reconstruction
+ if(gen_event_type.eq.6 .or. gen_event_type.eq.1) then !GEp-coin. trig
+* write(*,*) 'calling gep_reconstruction'
+ call GEp_reconstruction(FAIL,why)
+* write(*,*) 'gep_reconstruction successful'
+ if(err.ne.' '.and.why.ne.' ') then
+ call G_append(err,' & '//why)
+ else if(why.ne.' ') then
+ err = why
+ endif
+ ABORT = ABORT.or.FAIL
+ endif
+*
+*-COIN reconstruction
+ IF(gen_event_type.eq.3) then !COIN trig
+ call C_reconstruction(FAIL,why)
+ IF(err.NE.' ' .and. why.NE.' ') THEN
+ call G_append(err,' & '//why)
+ ELSEIF(why.NE.' ') THEN
+ err= why
+ ENDIF
+ ABORT= ABORT .or. FAIL
+ ENDIF
+*
+ IF(ABORT .or. err.NE.' ') call G_add_path(here,err)
+*
+ IF(hack_enable.ne.0) then
+ call hack_anal(FAIL,why)
+ IF(err.NE.' ' .and. why.NE.' ') THEN
+ call G_append(err,' & '//why)
+ ELSEIF(why.NE.' ') THEN
+ err= why
+ ENDIF
+ ABORT= ABORT .or. FAIL
+ ENDIF
+*
+ RETURN
+ END
diff --git a/ENGINE/g_register_variables.f b/ENGINE/g_register_variables.f
new file mode 100644
index 0000000..b6dfdc4
--- /dev/null
+++ b/ENGINE/g_register_variables.f
@@ -0,0 +1,250 @@
+ subroutine g_register_variables(ABORT,err)
+*----------------------------------------------------------------------
+*
+* CTP variable registration routine
+*
+* Purpose : Register all variables that are to be used by CTP. This
+* includes externally configured parameters/contants, event data that
+* can be a histogram source, and possible test results and scalers.
+*
+* Method: 1. Register variables needed to use CTP to get various
+* filenames. And register other common variables.
+* 2. Call Register routines for HMS, SOS and coincidence.
+*
+* Output: ABORT - success or failure
+* : err - reason for failure, if any
+*
+* Created: 9-Feb-1994 Stephen A. Wood
+* Modified: 17-May-1994 Kevin B. Beard, Hampton U.
+* Modified: 24-May-1994 K.B.Beard
+*
+* $Log: g_register_variables.f,v $
+* Revision 1.11.24.2.2.3 2008/10/26 19:12:33 cdaq
+* SEM
+*
+* Revision 1.11.24.2.2.2 2008/10/02 17:59:13 cdaq
+* *** empty log message ***
+*
+* Revision 1.11.24.2.2.1 2008/05/15 18:59:22 bhovik
+* 1'st version
+*
+* Revision 1.11.24.2 2007/10/16 19:51:19 cdaq
+* fixed F1TDC_WINDOW_SIZE declaration
+*
+* Revision 1.11.24.1 2007/05/15 02:55:01 jones
+* Start to Bigcal code
+*
+* Revision 1.11 1996/01/16 17:08:55 cdaq
+* no change
+*
+* Revision 1.10 1995/07/27 19:38:27 cdaq
+* (SAW) Relocate data statements for f2c compatibility
+*
+* Revision 1.9 1994/10/11 18:39:59 cdaq
+* (SAW) Add some hacks for event dislpay
+*
+* Revision 1.8 1994/08/18 04:11:47 cdaq
+* (SAW) Call makereg generated routines to register variables
+*
+* Revision 1.7 1994/08/04 03:47:05 cdaq
+* (SAW) Add call to Breuer's hack_register_variables
+*
+* Revision 1.6 1994/06/21 16:40:20 cdaq
+* (SAW) Register g_report_rebook and scalers
+*
+* Revision 1.5 1994/06/17 03:30:35 cdaq
+* (KBB) Execute all code despite registration errors
+*
+* Revision 1.4 1994/06/16 03:24:28 cdaq
+* (SAW) Register reconstruction filenames and report generator filenames etc.
+*
+* Revision 1.3 1994/06/07 18:14:57 cdaq
+* (KBB) Add regististration for enable_EvtypeN and triggered_EvTypeN
+*
+* Revision 1.2 1994/03/24 15:29:53 cdaq
+* (SAW) Add registration of rebook flags for parm,test,hist
+*
+* Revision 1.1 1994/02/11 18:35:11 cdaq
+* Initial revision
+*
+*----------------------------------------------------------------------
+ implicit none
+ save
+*
+ character*20 here
+ parameter (here='g_register_variables')
+*
+ logical ABORT
+ character*(*) err
+*
+ include 'gen_routines.dec'
+*
+ include 'gen_run_info.cmn'
+ include 'gen_run_pref.cmn'
+
+ integer ierr,m,i
+ logical FAIL
+ character*1000 why
+ character*30 msg
+*
+ include 'gen_run_info.dte'
+ include 'gen_run_pref.dte'
+*
+*----------------------------------------------------------------------
+*
+* Register the variables that contain the filenames and other
+* configuration variables.
+*
+ ABORT= .FALSE.
+ err = ' '
+*
+ call r_gen_filenames
+
+ call r_gen_run_info
+
+ call r_gen_event_info
+
+ call r_gen_scalers
+
+ call r_gen_run_pref
+
+ call r_gen_data_structures ! Contains both HMS and SOS stuff
+
+ call r_gen_decode_F1tdc
+
+*HDISPLAY call r_one_ev_io
+*
+* Need to change in parm files
+* hist_filename -> g_ctp_hist_filename
+* g_hist_rebook -> hist_rebook
+* parm_filename -> g_ctp_parm_filename
+* parm_rebook -> g_parm_rebook
+* test_filename -> g_ctp_test_filename
+* test_rebook -> g_test_rebook
+* report_rebook -> g_report_rebook
+* data_source_filename -> g_data_source_filename
+* alias_filename -> g_alias_filename
+* histout_filename -> g_histout_filename
+* decode_map_filename -> g_decode_map_filename
+* g_report_template_filename -> g_report_template_filename
+* g_report_output_filename -> g_report_output_filename
+* g_report_blockname -> g_report_blockname
+* max_events -> g_max_events
+* RUN_number -> gen_run_number
+* RUN_type -> gen_run_type
+* RUN_total_events -> gen_run_total_events
+* RUN_comment -> gen_run_comment
+* RUN_start_date -> gen_run_date_start
+* RUN_stop_date -> gen_run_date_stop
+* RUN_last_date -> gen_run_date_last
+* RUN_start_event -> gen_run_starting_event
+* RUN_stop_event -> gen_run_stopping_event
+* EVENT_id -> gen_event_ID_number
+* EVENT_type -> gen_event_type
+* EVENT_class -> gen_event_class
+* EVENT_sequenceN -> gen_event_sequence_N
+* SHOW_progress -> gen_show_progress
+* SHOW_interval -> gen_show_interval
+* PREF_muddleON -> gen_pref_muddleON
+
+*
+* Leave in these aliases
+*
+ Do m=0,gen_MAX_trigger_types
+ write(msg,'("enable_EvType",i4)') m
+ call squeeze(msg,i)
+ ierr= regparmint(msg(1:i),gen_run_enable(m),0)
+ if(ierr.ne.0) call G_append(err,',"'//msg(1:i)//'"')
+ ABORT= ierr.ne.0 .or. ABORT
+ EndDo
+*
+ Do m=0,gen_MAX_trigger_types
+ write(msg,'("triggered_EvType",i4)') m
+ call squeeze(msg,i)
+ ierr= regparmint(msg(1:i),gen_run_triggered(m),0)
+ if(ierr.ne.0) call G_append(err,',"'//msg(1:i)//'"')
+ ABORT= ierr.ne.0 .or. ABORT
+ EndDo
+*
+*
+ call h_register_variables(FAIL,why) ! HMS
+ IF(err.NE.' ' .and. why.NE.' ') THEN
+ call G_append(err,' & '//why)
+ ELSEIF(why.NE.' ') THEN
+ err= why
+ ENDIF
+ ABORT= ABORT .or. FAIL
+*
+ call s_register_variables(FAIL,why) ! SOS
+ IF(err.NE.' ' .and. why.NE.' ') THEN
+ call G_append(err,' & '//why)
+ ELSEIF(why.NE.' ') THEN
+ err= why
+ ENDIF
+ ABORT= ABORT .or. FAIL
+*
+ call c_register_variables(FAIL,why) ! COIN
+ IF(err.NE.' ' .and. why.NE.' ') THEN
+ call G_append(err,' & '//why)
+ ELSEIF(why.NE.' ') THEN
+ err= why
+ ENDIF
+ ABORT= ABORT .or. FAIL
+*
+ call b_register_variables(FAIL,why) ! BIGCAL
+ IF(err.NE.' ' .and. why.NE.' ') THEN
+ call G_append(err,' & '//why)
+ ELSEIF(why.NE.' ') THEN
+ err= why
+ ENDIF
+ ABORT= ABORT .or. FAIL
+*
+ call sane_register_variables(FAIL,why) ! BIGCAL
+ IF(err.NE.' ' .and. why.NE.' ') THEN
+ call G_append(err,' & '//why)
+ ELSEIF(why.NE.' ') THEN
+ err= why
+ ENDIF
+ ABORT= ABORT .or. FAIL
+*
+*
+* SEM register variables
+*
+ call sem_register_variables(FAIL,why) ! BIGCAL
+ IF(err.NE.' ' .and. why.NE.' ') THEN
+ call G_append(err,' & '//why)
+ ELSEIF(why.NE.' ') THEN
+ err= why
+ ENDIF
+ ABORT= ABORT .or. FAIL
+*
+*
+* Register F1 Trigger Variables
+*
+ call f1trigger_register_variables(FAIL,why) ! F1TDC
+ IF(err.NE.' ' .and. why.NE.' ') THEN
+ call G_append(err,' & '//why)
+ ELSEIF(why.NE.' ') THEN
+ err= why
+ ENDIF
+ ABORT= ABORT .or. FAIL
+*
+ call gep_register_variables(FAIL,why) ! GEp-coin.
+ if(err.ne.' '.and.why.ne.' ') then
+ call G_append(err,' & '//why)
+ else if(why.ne.' ') then
+ err = why
+ endif
+*
+ call hack_register_variables(FAIL,why)
+ IF(err.NE.' ' .and. why.NE.' ') THEN
+ call G_append(err,' & '//why)
+ ELSEIF(why.NE.' ') THEN
+ err= why
+ ENDIF
+ ABORT= ABORT .or. FAIL
+
+ if(ABORT .or. err.NE.' ') call g_add_path(here,err)
+*
+ return
+ end
diff --git a/ENGINE/g_reset_event.f b/ENGINE/g_reset_event.f
new file mode 100644
index 0000000..b89a975
--- /dev/null
+++ b/ENGINE/g_reset_event.f
@@ -0,0 +1,175 @@
+ SUBROUTINE G_reset_event(ABORT,err)
+*--------------------------------------------------------
+*- Prototype C analysis routine
+*-
+*-
+*- Purpose and Methods : Resets all quantities AT THE BEGINNING OF THE RUN
+*-
+*-
+*- Output: ABORT - success or failure
+*- : err - reason for failure, if any
+*-
+*- Created 29-Oct-1993 Kevin B. Beard
+*- Modified 3-Dec-1993 Kevin B. Beard, Hampton U.
+* $Log: g_reset_event.f,v $
+* Revision 1.11.24.3.2.3 2008/10/26 19:12:33 cdaq
+* SEM
+*
+* Revision 1.11.24.3.2.2 2008/10/02 17:59:26 cdaq
+* *** empty log message ***
+*
+* Revision 1.11.24.3.2.1 2008/05/15 18:59:22 bhovik
+* 1'st version
+*
+* Revision 1.11.24.3 2007/09/11 19:14:17 frw
+* fixed FPP related arrays and limits
+*
+* Revision 1.11.24.2 2007/06/04 14:56:06 puckett
+* changed hit array structure for trigger related signals
+*
+* Revision 1.11.24.1 2007/05/15 02:55:01 jones
+* Start to Bigcal code
+*
+* Revision 1.11 1996/01/22 15:15:01 saw
+* (JRA) Put BPM/Raster data into MISC data structures
+*
+* Revision 1.10 1996/01/16 17:07:55 cdaq
+* (JRA) Zero out ADC threshold readback array
+*
+* Revision 1.9 1995/10/09 18:45:20 cdaq
+* (JRA) Add scaler event reset call. Remove monte carlo stuff.
+*
+* Revision 1.8 1995/07/27 19:39:25 cdaq
+* (SAW) Disable monte carlo (GMC)
+*
+* Revision 1.7 1995/04/01 19:50:55 cdaq
+* (SAW) Add BPM hitlist
+*
+* Revision 1.6 1994/06/22 20:24:23 cdaq
+* (SAW) Zero out uninstrumented channel hit data structure
+*
+* Revision 1.5 1994/04/12 18:42:05 cdaq
+* (SAW) Remove clearing of CRAW event buffer to online compatibility
+*
+* Revision 1.4 1994/02/22 19:47:36 cdaq
+* Change gmc_reset_event to gmc_mc_reset
+*
+* Revision 1.3 1994/02/17 21:49:57 cdaq
+* Simplify error handling to be like g_clear_event
+*
+* Revision 1.2 1994/02/17 21:43:39 cdaq
+* Add call to gmc_reset_event
+*
+* Revision 1.1 1994/02/04 22:13:26 cdaq
+* Initial revision
+*
+*-
+*-
+*- All standards are from "Proposal for Hall C Analysis Software
+*- Vade Mecum, Draft 1.0" by D.F.Geesamn and S.Wood, 7 May 1993
+*-
+*-
+*--------------------------------------------------------
+ IMPLICIT NONE
+ SAVE
+*
+ character*13 here
+ parameter (here= 'G_reset_event')
+*
+ logical ABORT
+ character*(*) err
+*
+ logical HMS_ABORT,SOS_ABORT,COIN_ABORT,SCAL_ABORT
+ logical BIGCAL_ABORT,GEP_ABORT,SANE_ABORT,F1trigger_abort,sem_abort
+ character*132 HMS_err,SOS_err,COIN_err,SCAL_err,BIGCAL_err
+ character*132 GEP_err,SANE_err,F1trigger_err,sem_err
+*
+ integer hit,chan,roc,slot
+*
+ INCLUDE 'gen_data_structures.cmn'
+ include 'gen_detectorids.par'
+ INCLUDE 'gen_decode_common.cmn'
+ include 'gen_run_info.cmn'
+*
+*--------------------------------------------------------
+*
+ err = ' '
+ hms_err = ' '
+ sos_err = ' '
+ coin_err = ' '
+ bigcal_err = ' '
+ sane_err = ' '
+ f1trigger_err = ' '
+ sem_err = ' '
+ gep_err = ' '
+*
+* Uninstrumented hits
+*
+ do hit=1,GMAX_UNINST_HITS
+ GUNINST_RAW_ROCSLOT(hit) = 0
+ GUNINST_RAW_SUBADD(hit) = 0
+ GUNINST_RAW_DATAWORD(hit) = 0
+ enddo
+ GUNINST_TOT_HITS = 0
+*
+ do hit=1,GMAX_MISC_HITS
+ GMISC_RAW_ADDR1(hit) = 0
+ GMISC_RAW_ADDR2(hit) = 0
+ GMISC_RAW_DATA(hit) = 0
+ enddo
+ GMISC_TOT_HITS = 0
+*
+ do slot=1,gmax_slot_with_adc
+ do roc=1,gmax_roc_with_adc
+ do chan=1,gnum_adc_channels
+ g_threshold_readback(chan,roc,slot)=0
+ enddo
+ enddo
+ enddo
+*
+ call g_scaler_reset_event(SCAL_ABORT,SCAL_err)
+*
+
+ call H_reset_event(HMS_ABORT,HMS_err)
+
+*
+
+ call S_reset_event(SOS_ABORT,SOS_err)
+
+*
+
+ call C_reset_event(COIN_ABORT,COIN_err)
+
+*
+
+ call B_reset_event(BIGCAL_ABORT,BIGCAL_err)
+ call SANE_reset_event(SANE_ABORT,SANE_err)
+ call f1trigger_reset_event(F1Trigger_ABORT,F1Trigger_err)
+ call sem_reset_event(SEM_ABORT,SEM_err)
+
+
+
+ call GEp_reset_event(GEP_ABORT,GEP_err)
+
+
+ abort = hms_abort.or.sos_abort.or.coin_abort.or.scal_abort
+ $ .or. BIGCAL_ABORT .or. GEP_ABORT
+*
+ IF(ABORT) then
+ err= COIN_err
+ call G_prepend(SOS_err,err)
+ call G_prepend(HMS_err,err)
+ call G_prepend(SCAL_err,err)
+ call G_prepend(BIGCAL_err,err)
+ call G_prepend(BIGCAL_err,err)
+ call G_prepend(SANE_err,err)
+ call G_prepend(F1TRIGGER_err,err)
+ call G_prepend(SEM_err,err)
+ call G_prepend(GEP_err,err)
+ call G_add_path(here,err)
+ else
+ err = ' '
+ endif
+*
+ RETURN
+ END
diff --git a/ENGINE/g_scaler_reset_event.f b/ENGINE/g_scaler_reset_event.f
new file mode 100644
index 0000000..d506f53
--- /dev/null
+++ b/ENGINE/g_scaler_reset_event.f
@@ -0,0 +1,103 @@
+ SUBROUTINE g_scaler_reset_event(ABORT,err)
+*--------------------------------------------------------
+*- Prototype C analysis routine
+*-
+*-
+*- Purpose and Methods : Resets all scalers at beginning of run.
+*-
+*-
+*- Output: ABORT - success or failure
+*- : err - reason for failure, if any
+*-
+*- Created 12-Sep-1995 John Arrington
+*-
+*- All standards are from "Proposal for Hall C Analysis Software
+*- Vade Mecum, Draft 1.0" by D.F.Geesamn and S.Wood, 7 May 1993
+*
+* $Log: g_scaler_reset_event.f,v $
+* Revision 1.5.22.2 2009/09/29 14:00:32 jones
+* Set variables used for charge asymmetry to zero
+*
+* Revision 1.5.22.1 2009/03/30 20:50:25 cdaq
+* *** empty log message ***
+*
+* Revision 1.5 2003/09/05 16:34:34 jones
+* Merge in online03 changes (mkj)
+*
+* Revision 1.4.2.2 2003/09/04 21:02:03 jones
+* changes to run with syncfilter (mkj)
+*
+* Revision 1.4.2.1 2003/08/14 00:40:09 cdaq
+* Modify so "beam on" scalers for both bcm1 and bcm2 (mkj)
+*
+* Revision 1.4 1999/02/10 18:17:57 csa
+* Added beam-on variable initialization (D. McKee)
+*
+* Revision 1.3 1996/04/29 19:48:45 saw
+* (JRA) Add gscaler, gscaler_old, gscaler_nroll, gscaler_change initialization
+*
+* Revision 1.2 1996/01/16 17:06:35 cdaq
+* (CB) Clear out current monitor variables
+*
+* Revision 1.1 1995/09/19 14:58:35 cdaq
+* Initial revision
+*
+*--------------------------------------------------------
+ IMPLICIT NONE
+ SAVE
+*
+ character*20 here
+ parameter (here= 'g_scaler_reset_event')
+*
+ logical ABORT
+ character*(*) err
+*
+ INCLUDE 'gen_scalers.cmn'
+*
+ INTEGER ind
+*
+*--------------------------------------------------------
+*
+ do ind = 1 , max_num_evscalers
+ evscalers(ind) = 0.
+ enddo
+*
+ do ind = 1 , max_num_scalers
+ gscaler(ind) = 0.
+ gscaler_skipped(ind) = 0.
+ gscaler_saved(ind) = 0.
+ gscaler_old(ind) = 0.
+ gscaler_nroll(ind) = 0
+ gscaler_change(ind) = 0.
+ enddo
+*
+ gscal_lastevnum(1)=0
+ gscal_lastevnum(2)=0
+*
+ gbcm1_charge = 0.
+ gbcm2_charge = 0.
+ gbcm1_charge_help = 0.
+ gbcm2_charge_helm = 0.
+ gbcm3_charge = 0.
+ gunser_charge = 0.
+ g_hel_pos = 0
+ g_hel_neg = 0
+*
+ g_run_time = 0.
+ g_beam_on_run_time(1) = 0. ! Have to do this, because I have to accumlate
+ g_beam_on_bcm_charge(1) = 0.
+ g_beam_on_run_time(2) = 0. ! Have to do this, because I have to accumlate
+ g_beam_on_bcm_charge(2) = 0.
+ g_beam_on_run_time_help(1) = 0. ! Have to do this, because I have to accumlate
+ g_beam_on_bcm_charge_help(1) = 0.
+ g_beam_on_run_time_help(2) = 0. ! Have to do this, because I have to accumlate
+ g_beam_on_bcm_charge_help(2) = 0.
+ g_beam_on_run_time_helm(1) = 0. ! Have to do this, because I have to accumlate
+ g_beam_on_bcm_charge_helm(1) = 0.
+ g_beam_on_run_time_helm(2) = 0. ! Have to do this, because I have to accumlate
+ g_beam_on_bcm_charge_helm(2) = 0.
+*
+ ABORT= .FALSE.
+ err= ' '
+ RETURN
+ END
diff --git a/ENGINE/g_target_initialize.f b/ENGINE/g_target_initialize.f
new file mode 100644
index 0000000..256f1ed
--- /dev/null
+++ b/ENGINE/g_target_initialize.f
@@ -0,0 +1,49 @@
+ SUBROUTINE g_target_initialize(ABORT,err)
+*--------------------------------------------------------
+*- Prototype target analysis routine
+*-
+*-
+*- Purpose and Methods : Initializes target quantities
+*-
+*- Output: ABORAT - success or failure
+*- : err - reason for failure, if any
+*-
+*-
+*- All standards are from "Proposal for Hall C Analysis Software
+*- Vade Mecum, Draft 1.0" by D.F.Geesamn and S.Wood, 7 May 1993
+*-
+* $Log: g_target_initialize.f,v $
+* Revision 1.1 1996/01/22 15:11:55 saw
+* Initial revision
+*
+*--------------------------------------------------------
+ IMPLICIT NONE
+ SAVE
+*
+ character*18 here
+ parameter (here= 'g_target_initialize')
+*
+ logical ABORT
+ character*(*) err
+*
+ INCLUDE 'gen_data_structures.cmn'
+ INCLUDE 'gen_constants.par'
+*
+*--------------------------------------------------------
+*
+ ABORT= .FALSE.
+
+ if ((gtarg_num.lt.1).OR.(gtarg_num.gt.gmax_targets)) then
+ print*, 'No target or invalid target number given'
+ ABORT=.true.
+ endif
+*
+ IF(ABORT) THEN
+ err = 'No target or invalid target number given'
+ call G_add_path(here,err)
+ ELSE
+ err= ' '
+ ENDIF
+*
+ RETURN
+ END
diff --git a/ENGINE/g_trans_misc.f b/ENGINE/g_trans_misc.f
new file mode 100644
index 0000000..3e78ca7
--- /dev/null
+++ b/ENGINE/g_trans_misc.f
@@ -0,0 +1,162 @@
+ subroutine g_trans_misc(abort,errmsg)
+*-------------------------------------------------------------------
+* author: John Arrington
+* created: 1/16/96
+*
+* g_trans_misc fills the gen_decoded_misc common block
+*
+* $Log: g_trans_misc.f,v $
+* Revision 1.2.24.5.2.1 2008/10/28 20:53:12 cdaq
+* Added trigger F1 TDC code
+*
+* Revision 1.2.24.5 2007/11/29 18:33:05 cdaq
+* commented out diagnostic message
+*
+* Revision 1.2.24.4 2007/11/12 03:16:22 cdaq
+* added timing window for triggers
+*
+* Revision 1.2.24.3 2007/10/29 19:44:07 cdaq
+* Added handling of multi-hits for HMS and BigCal trigger TDCs
+*
+* Revision 1.2.24.2 2007/10/23 13:23:32 cdaq
+* Added filling of raw trigger TDC histograms, signals are in the gmisc hit array
+*
+* Revision 1.2.24.1 2007/10/17 15:52:29 cdaq
+* *** empty log message ***
+*
+* Revision 1.2 2002/09/25 14:37:32 jones
+* character*1024 errmsg changed to character*(*) errmsgCVS: ----------------------------------------------------------------------
+*
+* Revision 1.1 1996/01/22 15:14:10 saw
+* Initial revision
+*
+*--------------------------------------------------------
+
+ implicit none
+
+ include 'gen_data_structures.cmn'
+ include 'gen_event_info.cmn'
+ include 'gep_data_structures.cmn'
+ include 'gep_hist_id.cmn'
+
+ logical abort
+ character*(*) errmsg
+ character*20 here
+ parameter (here = 'g_trans_misc')
+
+ integer*4 ihit,rawtime,corrtime
+ integer*4 nH1,nH2,nB,nprt,itrig,j,ncall
+ real hittime
+
+ save
+
+ abort = .false.
+ errmsg = ' '
+
+ do ihit = 1 , gmax_misc_hits
+ gmisc_dec_data(ihit,1) = 0 ! Clear TDC's
+ gmisc_dec_data(ihit,2) = -1 ! Clear ADC's
+ enddo
+ ncall = ncall + 1
+
+ nH1 = 0
+ nH2 = 0
+ nB = 0
+
+c write(*,*) 'gmisc_tot_hits=',gmisc_tot_hits
+
+ do ihit = 1 , gmisc_tot_hits
+c$$$ if((gmisc_raw_addr2(ihit).eq.1.or.gmisc_raw_addr2(ihit).eq.2)
+c$$$ $ .and. gmisc_raw_addr1(ihit).eq.2) then
+c$$$ if(gmisc_raw_addr2(ihit).eq.1) then ! h+
+c$$$ write(*,*) 'h+ hit, raw ADC=',gmisc_raw_data(ihit)
+c$$$ endif
+c$$$ if(gmisc_raw_addr2(ihit).eq.2) then ! h-
+c$$$ write(*,*) 'h- hit, raw ADC=',gmisc_raw_data(ihit)
+c$$$ endif
+c$$$ endif
+
+ if(gmisc_raw_addr1(ihit).eq.1) then
+c write(*,*) 'gmisc TDC hit ctr,TDCraw=',gmisc_raw_addr2(ihit),
+c $ gmisc_raw_data(ihit)
+ if(gmisc_raw_addr2(ihit).eq.1) then !HMS1 trigger: fill hist
+
+ hittime = .5*gmisc_raw_data(ihit)
+
+ if(abs(hittime-gep_h1time_center).le.gep_h1time_slop)then
+ nH1 = nH1 + 1
+ if(nH1.le.8) then
+ GEP_H1time(nH1) = hittime
+ endif
+ if(gepid_gep_HMS1_rawtdc.gt.0) then
+ call hf1(gepid_gep_HMS1_rawtdc,float(gmisc_raw_data(ihit)),
+ $ 1.)
+ endif
+ endif
+ endif
+ if(gmisc_raw_addr2(ihit).eq.2) then !HMS2 trigger: fill hist
+ hittime = .5*gmisc_raw_data(ihit)
+
+ if(abs(hittime-gep_h2time_center).le.gep_h2time_slop)then
+ nH2 = nH2 + 1
+ if(nH2.le.8) then
+ GEP_H2time(nH2) = hittime
+ endif
+ if(gepid_gep_HMS2_rawtdc.gt.0) then
+ call hf1(gepid_gep_HMS2_rawtdc,float(gmisc_raw_data(ihit)),
+ $ 1.)
+ endif
+ endif
+ endif
+ if(gmisc_raw_addr2(ihit).eq.3) then !BigCal trigger: fill hist
+ hittime = .5*gmisc_raw_data(ihit)
+ if(abs(hittime-gep_btime_center).le.gep_btime_slop) then
+ nB = nB + 1
+ if(nB.le.8) then
+ GEP_Btime(nB) = hittime
+ endif
+ if(gepid_gep_bigcal_rawtdc.gt.0) then
+ call hf1(gepid_gep_bigcal_rawtdc,float(gmisc_raw_data(ihit)),
+ $ 1.)
+ endif
+ endif
+ endif
+ endif
+
+c trigger times in F1 TDCs. These arrays allow for multiple TDC hits,
+c whereas gmisc_dec_data will just have the last hit, if more than one.
+c Also, correct raw data for trigger time and rollovers
+ if(gmisc_raw_addr2(ihit).ge.11 .and.
+ > gmisc_raw_addr2(ihit).le.16 .and.
+ > gmisc_raw_addr1(ihit).eq.1) then
+c correct for trigger time and rollovers assuming this is ROC 13
+ rawtime = gmisc_raw_data(ihit)
+ call CORRECT_RAW_TIME_SANE(rawtime,corrtime)
+ if(nprt .lt.0.and.gen_event_type.ne.4) then
+ nprt = nprt + 1
+ write(6,'(''dbg trigs'',6i8)') ncall, gen_event_ID_number,
+ > gmisc_raw_addr1(ihit),gmisc_raw_addr2(ihit),
+ > rawtime,corrtime
+ endif
+c Add an offset to make all values positive, and convert to nsec
+ corrtime = (corrtime + 3000) * 0.0566
+ gmisc_dec_data(gmisc_raw_addr2(ihit),gmisc_raw_addr1(ihit)) =
+ $ corrtime
+c Increment the multiple hit versions of the arrays
+ itrig = gmisc_raw_addr2(ihit) - 10
+ gep_ntrigs(itrig) = gep_ntrigs(itrig) +1
+ j = max(1, min(10,gep_ntrigs(itrig)))
+ gep_trigtimes(itrig,j) = corrtime
+ else
+
+ gmisc_dec_data(gmisc_raw_addr2(ihit),gmisc_raw_addr1(ihit)) =
+ $ gmisc_raw_data(ihit)
+ endif
+ enddo
+
+ ntrigH1 = nH1
+ ntrigH2 = nH2
+ ntrigB = nB
+
+ return
+ end
diff --git a/ENGINE/g_tree_init.f b/ENGINE/g_tree_init.f
new file mode 100644
index 0000000..13fcd3a
--- /dev/null
+++ b/ENGINE/g_tree_init.f
@@ -0,0 +1,40 @@
+ subroutine g_tree_init(abort,err)
+
+ implicit none
+ save
+
+ character*11 here
+ parameter(here='g_tree_init')
+
+ include 'gen_filenames.cmn'
+ include 'hms_filenames.cmn'
+ include 'gep_filenames.cmn'
+ include 'bigcal_filenames.cmn'
+ include 'gen_run_info.cmn'
+
+ logical abort
+ character*(*) err
+
+ abort=.false.
+ err=' '
+
+ call h_tree_init(abort,err)
+ if(abort) then
+ call g_add_path(here,err)
+ return
+ endif
+
+ call b_tree_init(abort,err)
+ if(abort) then
+ call g_add_path(here,err)
+ return
+ endif
+
+ call gep_tree_init(abort,err)
+ if(abort) then
+ call g_add_path(here,err)
+ return
+ endif
+
+ return
+ end
diff --git a/ENGINE/g_write_event.f b/ENGINE/g_write_event.f
new file mode 100644
index 0000000..edab2ff
--- /dev/null
+++ b/ENGINE/g_write_event.f
@@ -0,0 +1,58 @@
+ SUBROUTINE g_write_event(ABORT,err)
+*------------------------------------------------------------
+* prototype C analysis routine
+*
+* purpose and methods : write the event in buffer to a file
+*
+* output : abort: sucess or fail
+* err: reason for failure
+*
+* created apr-30-1996 Dave Meekins
+*
+* $Log: g_write_event.f,v $
+* Revision 1.1 1996/06/10 17:47:32 saw
+* Initial revision
+*
+*------------------------------------------------------------
+
+* DECLARATIONS
+
+ IMPLICIT NONE
+ SAVE
+
+ character*20 here
+ parameter (here='g_write_event')
+
+ logical ABORT
+ character*(*) err
+
+ INCLUDE 'gen_data_structures.cmn'
+ INCLUDE 'gen_craw.cmn'
+ INCLUDE 'gen_filenames.cmn'
+
+ integer*4 status
+ integer*4 evwrite ! coda routine to write event
+
+*------------------------------------------------------------
+
+* START OF CODE
+
+ err=' '
+ ABORT=.NOT.g_preproc_opened
+
+ if(g_preproc_in_hndl.ne.0)then
+ status=evwrite(g_preproc_in_hndl,craw)
+ if(status.ne.0)then
+ ABORT=.true.
+ call cemsg(status,0,err)
+ endif
+ else
+ err='no preprocessor output file opened'
+ endif
+
+ if(ABORT)then
+ call G_add_path(here)
+ endif
+
+ RETURN
+ END
diff --git a/ENGINE/gep_check_bigcal.f b/ENGINE/gep_check_bigcal.f
new file mode 100644
index 0000000..546ccfb
--- /dev/null
+++ b/ENGINE/gep_check_bigcal.f
@@ -0,0 +1,323 @@
+ subroutine gep_check_bigcal(X_H,Y_H,E_H)
+
+ implicit none
+ save
+
+ character*16 here
+ parameter(here='gep_check_bigcal')
+
+ real X_H,Y_H,E_H
+
+ include 'gep_data_structures.cmn'
+ include 'bigcal_data_structures.cmn'
+ include 'bigcal_bypass_switches.cmn'
+ include 'bigcal_geometry.cmn'
+ include 'bigcal_shower_parms.cmn'
+
+ integer rowexpect,colexpect,row,col,colcenter,maxcol,cell
+ integer nsearch_y,nsearch_x
+ integer i,j,k
+ integer nbad_near
+
+c integer nguessclust,nrealclust
+ integer nclustbefore,nclustafter
+
+ integer rowbad(10),colbad(10),cellbad(10),imax_bad
+ real eguess_bad(10)
+ real maxebad
+
+ real xdiff_expect,ydiff_expect
+c real xmom_expect,ymom_expect
+c real xroot_predict,yroot_predict
+c integer bestroot
+
+ real yedge,xedge ! distance from edge of section
+
+ real csxp,csyp,csxr,csyr
+
+ real diffsq,mindiffsq
+
+ integer bestclstr,cellexpect
+
+c$$$ integer ncellclust
+c$$$ integer cluster_temp_irow(bigcal_clstr_ncell_max)
+c$$$ integer cluster_temp_icol(bigcal_clstr_ncell_max)
+c$$$ real cluster_temp_ecell(bigcal_clstr_ncell_max)
+c$$$ real cluster_temp_xcell(bigcal_clstr_ncell_max)
+c$$$ real cluster_temp_ycell(bigcal_clstr_ncell_max)
+
+c logical fixed_any
+
+ logical abort
+ character*80 err
+
+ csxp = bigcal_prot_size_x
+ csyp = bigcal_prot_size_y
+ csxr = bigcal_rcs_size_x
+ csyr = bigcal_rcs_size_y
+
+c fixed_any = .false.
+
+c write(*,*) 'checking for bad BigCal channels'//
+c $ 'near the expected electron'
+
+ yedge = Y_H - bigcal_prot_shift_y
+
+ if(yedge.le.32.*csyp) then
+ rowexpect = int(yedge/csyp) + 1
+ else
+ yedge = yedge - 32.*csyp
+ rowexpect = int(yedge/csyr) + 33
+ endif
+
+ if(rowexpect.lt.1) rowexpect = 1
+ if(rowexpect.gt.56) rowexpect = 56
+
+ if(rowexpect.le.32) then
+ xedge = X_H - bigcal_prot_shift_x
+ colexpect = int(xedge/csxp) + 1
+ if(colexpect.lt.1) colexpect = 1
+ if(colexpect.gt.32) colexpect = 32
+
+ cellexpect = colexpect + 32*(rowexpect-1)
+
+ nsearch_y = nint(3.*gep_sigma_ydiff/csyp) + 2
+ nsearch_x = nint(3.*gep_sigma_xdiff/csxp) + 2
+
+ else
+ xedge = X_H - bigcal_rcs_shift_x
+ colexpect = int(xedge/csxr) + 1
+ if(colexpect.lt.1) colexpect = 1
+ if(colexpect.gt.30) colexpect = 30
+
+ cellexpect = colexpect + 30*(rowexpect-33) + 1024
+
+ nsearch_y = nint(3.*gep_sigma_ydiff/csyr) + 2
+ nsearch_x = nint(3.*gep_sigma_xdiff/csxr) + 2
+
+ endif
+
+ xdiff_expect = bigcal_all_xcenter(cellexpect) - X_H
+ ydiff_expect = bigcal_all_ycenter(cellexpect) - Y_H
+
+ nbad_near = 0
+
+ do row=max(rowexpect-nsearch_y,1),min(rowexpect+nsearch_y,56)
+ if(rowexpect.le.32) then
+ if(row.le.32) then
+ colcenter = colexpect
+ maxcol = 32
+ else
+ colcenter = bigcal_ixclose_prot(colexpect)
+ maxcol = 30
+ endif
+ else
+ if(row.gt.32) then
+ colcenter = colexpect
+ maxcol = 30
+ else
+ colcenter = bigcal_ixclose_rcs(colexpect)
+ maxcol = 32
+ endif
+ endif
+
+ do col=max(colcenter-nsearch_x,1),min(colcenter+nsearch_x,maxcol)
+ if(row.le.32) then
+ cell = col + 32*(row-1)
+ else
+ cell = col + 30*(row-33) + 1024
+ endif
+
+ if(bigcal_bad_chan_list(cell)) then
+ nbad_near = nbad_near + 1
+
+ if(nbad_near.gt.10) goto 100 ! probably time to give up well before this ever happens
+
+ rowbad(nbad_near) = row
+ colbad(nbad_near) = col
+ cellbad(nbad_near) = cell
+
+ endif
+ enddo
+ enddo
+
+c if yes, then check if there are any clusters already in the vicinity:
+
+ if(nbad_near.gt.0) then
+
+* !write(*,*) '(X_H,Y_H)=(',X_H,', ',Y_H,')'
+* !write(*,*) '(rowexpect,colexpect)=(',rowexpect,', ',
+* $ colexpect,')'
+
+c guess the energy in each bad channel:
+
+* !write(*,*) '(xdiffexpect,ydiffexpect)=(',xdiff_expect,', ',
+* $ ydiff_expect,')'
+* !write(*,*) '(nsearch_x,nsearch_y)=(',nsearch_x,', ',nsearch_y,
+* $ ')'
+
+ call b_guess_ecell(nbad_near, 10, rowbad, colbad, cellbad,eguess_bad,E_H,X_H,Y_H)
+
+ bestclstr = 0
+
+ do i=1,bigcal_all_nclstr
+ if(rowexpect-nsearch_y .le. bigcal_all_clstr_iymax(i) .and.
+ $ bigcal_all_clstr_iymax(i).le.rowexpect+nsearch_y ) then
+ if(rowexpect .le. 32) then
+ if(bigcal_all_clstr_iymax(i).le.32) then
+ if(colexpect-nsearch_x.le.bigcal_all_clstr_ixmax(i).and.
+ $ bigcal_all_clstr_ixmax(i).le.colexpect + nsearch_x) then
+ diffsq = float(bigcal_all_clstr_ixmax(i)-colexpect)**2 +
+ $ float(bigcal_all_clstr_iymax(i)-rowexpect)**2
+ if(i.eq.1.or.diffsq.lt.mindiffsq) then
+ mindiffsq = diffsq
+ bestclstr = i
+ endif
+ endif
+ else
+ if(bigcal_ixclose_prot(colexpect)-nsearch_x.le.bigcal_all_clstr_ixmax(i)
+ $ .and. bigcal_all_clstr_ixmax(i).le.bigcal_ixclose_prot(colexpect)
+ $ + nsearch_x) then
+ diffsq = float(bigcal_all_clstr_ixmax(i)-bigcal_ixclose_prot(colexpect))**2
+ $ + float(bigcal_all_clstr_iymax(i)-rowexpect)**2
+ if(i.eq.1.or.diffsq.lt.mindiffsq) then
+ mindiffsq = diffsq
+ bestclstr = i
+ endif
+ endif
+ endif
+ else
+ if(bigcal_all_clstr_iymax(i).le.32) then
+ if(bigcal_ixclose_rcs(colexpect)-nsearch_x.le.bigcal_all_clstr_ixmax(i)
+ $ .and. bigcal_all_clstr_ixmax(i).le.bigcal_ixclose_rcs(colexpect) +
+ $ nsearch_x) then
+ diffsq = float(bigcal_all_clstr_ixmax(i)-bigcal_ixclose_rcs(colexpect))**2
+ $ + float(bigcal_all_clstr_iymax(i)-rowexpect)**2
+ if(i.eq.1.or.diffsq.lt.mindiffsq) then
+ mindiffsq = diffsq
+ bestclstr = i
+ endif
+ endif
+ else
+ if(colexpect - nsearch_x.le.bigcal_all_clstr_ixmax(i).and.
+ $ bigcal_all_clstr_ixmax(i).le.colexpect + nsearch_x) then
+ diffsq = float(bigcal_all_clstr_ixmax(i)-colexpect)**2
+ $ + float(bigcal_all_clstr_iymax(i)-rowexpect)**2
+ if(i.eq.1.or.diffsq.lt.mindiffsq) then
+ mindiffsq = diffsq
+ bestclstr = i
+ endif
+ endif
+ endif
+ endif
+ endif
+ enddo
+c if there is a cluster near the expected position, try and "fill in the blanks" of any bad
+c cells in the cluster. If we found a cluster despite a bad channel, then chances are it
+c already contains a significant fraction of the energy of the cluster. If there is no cluster,
+c then chances are the maximum should have been in one of the bad channels.
+
+ if(bestclstr.gt.0) then
+ if(bigcal_all_clstr_nbadlist(bestclstr).gt.0) then ! try to fill in the blanks:
+ do i=1,bigcal_all_clstr_ncell(bestclstr)
+ if(bigcal_clstr_bad_chan(bestclstr,i)) then
+ do j=1,nbad_near
+ if(rowbad(j).eq.bigcal_all_clstr_iycell(bestclstr,i)
+ $ .and. colbad(j).eq.bigcal_all_clstr_ixcell(bestclstr,i)
+ $ ) then
+ bigcal_all_clstr_ecell(bestclstr,i) = eguess_bad(j)
+c bigcal_clstr_bad_chan(bestclstr,i) = .false.
+ endif
+ enddo
+ endif
+ enddo
+c now re-sort the cluster and recalculate important quantities:
+ call b_rebuild_cluster(bestclstr)
+c fixed_any = .true.
+ endif
+ else
+* no cluster was found: try to build a cluster around the bad cell with biggest "guessed" amplitude
+* and see if we find any nearby hits. It OUGHT to be the case that the "good hit" array still contains
+* the surrounding hits, because the good hit array only gets zeroed if we find a cluster, HOWEVER, it is
+* also quite possible that the good "detector" array hits around our maximum have been zeroed, so it is
+* useful here to re-initialize them from the "protvino" and "rcs" detector arrays which don't get zeroed
+* during the cluster finding. In retrospect it was good to keep those arrays around because they serve to
+* remember the values of each channel that might get zeroed in the cluster finding which uses the
+* "all detector" array.
+ do i=1,nbad_near
+ if(eguess_bad(i).gt.maxebad .or. i.eq.1) then
+ maxebad = eguess_bad(i)
+ imax_bad = i
+ endif
+ enddo
+
+ if(maxebad.gt.b_min_emax) then
+* initialize the signals in the max. cell and surrounding cells:
+ do row=max(rowbad(imax_bad)-nsearch_y,1),min(rowbad(imax_bad)+nsearch_y,56)
+ if(rowexpect.le.32) then
+ if(row.le.32) then
+ colcenter = colbad(imax_bad)
+ maxcol = 32
+ else
+ colcenter = bigcal_ixclose_prot(colbad(imax_bad))
+ maxcol = 30
+ endif
+ else
+ if(row.gt.32) then
+ colcenter = colbad(imax_bad)
+ maxcol = 30
+ else
+ colcenter = bigcal_ixclose_rcs(colbad(imax_bad))
+ maxcol = 32
+ endif
+ endif
+
+ do col=max(colcenter-nsearch_x,1),min(colcenter+nsearch_x,maxcol)
+ if(row.le.32) then
+ cell = col + 32*(row-1)
+ bigcal_all_good_det(cell) = bigcal_prot_good_det(cell)
+ else
+ cell = col + 30*(row-33) + 1024
+ bigcal_all_good_det(cell) = bigcal_rcs_good_det(cell-1024)
+ endif
+ enddo
+ enddo
+
+ bigcal_all_ngood = 1
+ bigcal_all_iygood(1) = rowbad(imax_bad)
+ bigcal_all_ixgood(1) = colbad(imax_bad)
+ bigcal_all_ecell(1) = maxebad
+
+ nclustbefore = bigcal_all_nclstr
+
+* !write(*,*) 'No cluster near expected electron: '//
+* $ 'building new cluster around expected max!'
+
+ call b_find_clusters(bigcal_all_nclstr,bigcal_nmaxima,abort,err)
+
+ nclustafter = bigcal_all_nclstr
+ call b_calc_shower_coord(abort,err)
+c for a new cluster we also need to calculate the time if possible.
+ if(bbypass_calc_cluster_time.eq.0) then
+ call b_calc_cluster_time(abort,err)
+ endif
+c require at least half of the blocks in any new cluster to be real hits
+ if(nclustafter.eq.nclustbefore + 1) then
+ if(bigcal_all_clstr_ncell(nclustafter) -
+ $ bigcal_all_clstr_nbadlist(nclustafter).lt.
+ $ bigcal_all_clstr_ncell(nclustafter)/2) then ! don't include this cluster
+ bigcal_all_nclstr = bigcal_all_nclstr - 1
+ else
+c !write(*,*)'built new cluster around expected maximum!'
+ endif
+ endif
+ endif
+ endif
+ endif
+
+ 100 continue
+
+ return
+ end
+
+
diff --git a/ENGINE/gep_clear_event.f b/ENGINE/gep_clear_event.f
new file mode 100755
index 0000000..aebe8a2
--- /dev/null
+++ b/ENGINE/gep_clear_event.f
@@ -0,0 +1,69 @@
+ subroutine gep_clear_event(ABORT,err)
+
+ implicit none
+ save
+
+ character*15 here
+ parameter(here='gep_clear_event')
+
+ logical ABORT
+ character*(*) err
+
+ integer i
+
+ include 'gep_data_structures.cmn'
+
+ ntrigh1 = 0
+ ntrigh2 = 0
+ ntrigb = 0
+
+ do i=1,8
+ gep_h1time(i) = 0.
+ gep_h2time(i) = 0.
+ gep_btime(i) = 0.
+ enddo
+
+ gep_btime_raw = 0.
+ gep_btime_corr = 0.
+
+ gep_ctime_hms = 0.
+ gep_ctime_cal = 0.
+ gep_Q2 = 0.
+ gep_Q2_H = 0.
+ gep_Q2_B = 0.
+ gep_E_electron = 0.
+ gep_P_proton = 0.
+ gep_delta_P = 0.
+ gep_epsilon = 0.
+ gep_xfp_p = 0.
+ gep_yfp_p = 0.
+ gep_xpfp_p = 0.
+ gep_ypfp_p = 0.
+ gep_xptar_p = 0.
+ gep_yptar_p = 0.
+ gep_ytar_p = 0.
+
+ gep_etheta_deg = 0.
+ gep_ephi_deg = 0.
+ gep_ptheta_deg = 0.
+ gep_pphi_deg = 0.
+ gep_emiss = 0.
+ gep_pmissx = 0.
+ gep_pmissy = 0.
+ gep_pmissz = 0.
+ gep_pmiss = 0.
+ gep_w2 = 0.
+ gep_mmiss = 0.
+
+ gep_bx_expect_H = 0.
+ gep_by_expect_H = 0.
+ gep_etheta_expect_H = 0.
+ gep_ephi_expect_h = 0.
+
+ call gep_ntuple_clear
+
+ abort=.false.
+ err=' '
+
+ return
+ end
diff --git a/ENGINE/gep_fill_hist.f b/ENGINE/gep_fill_hist.f
new file mode 100644
index 0000000..3a7dce8
--- /dev/null
+++ b/ENGINE/gep_fill_hist.f
@@ -0,0 +1,80 @@
+ subroutine gep_fill_hist(abort,err)
+
+ implicit none
+ save
+
+ character*13 here
+ parameter(here='gep_fill_hist')
+
+ logical abort
+ character*(*) err
+
+ include 'gen_event_info.cmn'
+ include 'gep_data_structures.cmn'
+ include 'gep_hist_id.cmn'
+ include 'hms_data_structures.cmn'
+ include 'bigcal_data_structures.cmn'
+
+ real xdiff,ydiff,ediff
+ integer i
+
+ abort = .false.
+ err= ' '
+
+ if(gepid_gep_coin1_times.gt.0.and.ntrigH1.gt.0.and.gen_event_trigtype(4)
+ $ .eq.1.and.ntrigB.gt.0) then
+ call hf2(gepid_gep_coin1_times,GEP_Btime(1),GEP_H1time(1),1.)
+ endif
+
+ if(gepid_gep_coin2_times.gt.0.and.ntrigH2.gt.0.and.gen_event_trigtype(5)
+ $ .eq.1.and.ntrigB.gt.0) then
+ call hf2(gepid_gep_coin2_times,GEP_Btime(1),GEP_H2time(1),1.)
+ endif
+
+ if(gepid_gep_ntrig_h1.gt.0) call hf1(gepid_gep_ntrig_h1,float(ntrigH1),1.)
+ if(gepid_gep_ntrig_h2.gt.0) call hf1(gepid_gep_ntrig_h2,float(ntrigH2),1.)
+ if(gepid_gep_ntrig_bigcal.gt.0) call hf1(gepid_gep_ntrig_bigcal,float(ntrigB),1.)
+
+ if(abs(hsdelta).lt.10..and.abs(hsp-gep_pel_htheta)/hpcentral .lt..1.and.
+ $ bigcal_itrack_best.gt.0) then
+
+ xdiff = bigcal_all_clstr_x(bigcal_itrack_best) - gep_bx_expect_h
+ ydiff = bigcal_all_clstr_y(bigcal_itrack_best) - gep_by_expect_h
+ ediff = gep_e_electron - bigcal_energy
+
+ do i=1,2
+
+ if(gen_event_trigtype(i+3).eq.1.and.gen_event_trigtype(6-i).eq.0) then
+
+ if(gepid_hgep_delta(i).gt.0) call hf1(gepid_hgep_delta(i),hsdelta,1.)
+ if(gepid_hgep_q2_hms(i).gt.0) call hf1(gepid_hgep_q2_hms(i),gep_q2_h,1.)
+ if(gepid_hgep_q2_cal(i).gt.0) call hf1(gepid_hgep_q2_cal(i),gep_q2_b,1.)
+ if(gepid_hgep_q2(i).gt.0) call hf1(gepid_hgep_q2(i),gep_q2,1.)
+ if(gepid_hgep_ecal(i).gt.0) call hf1(gepid_hgep_ecal(i),bigcal_energy,1.)
+ if(gepid_hgep_pp(i).gt.0) call hf1(gepid_hgep_pp(i),hsp,1.)
+ if(gepid_hgep_epsilon(i).gt.0) call hf1(gepid_hgep_epsilon(i),gep_epsilon,1.)
+ if(gepid_hgep_etheta(i).gt.0) call hf1(gepid_hgep_etheta(i),gep_etheta_deg,1.)
+ if(gepid_hgep_ephi(i).gt.0) call hf1(gepid_hgep_ephi(i),gep_ephi_deg,1.)
+ if(gepid_hgep_ptheta(i).gt.0) call hf1(gepid_hgep_ptheta(i),gep_ptheta_deg,1.)
+ if(gepid_hgep_pphi(i).gt.0) call hf1(gepid_hgep_pphi(i),gep_pphi_deg,1.)
+ if(gepid_hgep_emiss(i).gt.0) call hf1(gepid_hgep_emiss(i),gep_emiss,1.)
+ if(gepid_hgep_pmissx(i).gt.0) call hf1(gepid_hgep_pmissx(i),gep_pmissx,1.)
+ if(gepid_hgep_pmissy(i).gt.0) call hf1(gepid_hgep_pmissy(i),gep_pmissy,1.)
+ if(gepid_hgep_pmissz(i).gt.0) call hf1(gepid_hgep_pmissz(i),gep_pmissz,1.)
+
+ if(gepid_hgep_xdiff(i).gt.0) call hf1(gepid_hgep_xdiff(i),xdiff,1.)
+ if(gepid_hgep_ydiff(i).gt.0) call hf1(gepid_hgep_ydiff(i),ydiff,1.)
+ if(gepid_hgep_xydiff(i).gt.0) call hf2(gepid_hgep_xydiff(i),xdiff,ydiff,1.)
+ if(gepid_hgep_ediff(i).gt.0) call hf1(gepid_hgep_ediff(i),ediff,1.)
+ if(gepid_hgep_dpel(i).gt.0) call hf1(gepid_hgep_dpel(i),
+ $ (hsp-gep_pel_htheta)/hpcentral*100.,1.)
+
+ endif
+ enddo
+ endif
+
+
+ return
+ end
+
+
diff --git a/ENGINE/gep_init_histid.f b/ENGINE/gep_init_histid.f
new file mode 100644
index 0000000..62769a6
--- /dev/null
+++ b/ENGINE/gep_init_histid.f
@@ -0,0 +1,69 @@
+ subroutine gep_init_histid(abort,err)
+
+ implicit none
+ save
+
+ character*15 here
+ parameter(here='gep_init_histid')
+
+ logical abort
+ character*(*) err
+ external thgetid
+ integer*4 thgetid
+
+ integer i
+
+ include 'gep_data_structures.cmn'
+ include 'gep_hist_id.cmn'
+
+c do nothing until we set up some histograms...
+c miscellaneous hard-coded histograms for checkout
+
+ abort=.false.
+ err=' '
+
+ gepid_gep_trigtype = thgetid('gep_trigtype')
+ gepid_gep_evtype = thgetid('gep_evtype')
+ gepid_gep_trigtype_vs_evtype = thgetid('gep_trigtype_vs_evtype')
+ gepid_gep_ntrigs = thgetid('gep_ntrigs')
+ gepid_gep_HMS1_rawtdc = thgetid('gep_HMS1_rawtdc')
+ gepid_gep_HMS2_rawtdc = thgetid('gep_HMS2_rawtdc')
+ gepid_slowrastx = thgetid('gep_slowrastx')
+ gepid_slowrasty = thgetid('gep_slowrasty')
+ gepid_slowrastxy = thgetid('gep_slowrastxy')
+ gepid_slowrastxy2 = thgetid('gep_slowrastxy2')
+ gepid_gep_bigcal_rawtdc = thgetid('gep_bigcal_rawtdc')
+ gepid_gep_coin1_times = thgetid('gep_coin1_times')
+ gepid_gep_coin2_times = thgetid('gep_coin2_times')
+ gepid_gep_ntrig_h1 = thgetid('gep_ntrig_h1')
+ gepid_gep_ntrig_h2 = thgetid('gep_ntrig_h2')
+ gepid_gep_ntrig_bigcal = thgetid('gep_ntrig_bigcal')
+
+ do i=1,2
+
+ gepid_hgep_delta(i) = thgetid('hgep_delta'//char(i+ichar('0')))
+ gepid_hgep_q2_hms(i) = thgetid('hgep_q2_hms'//char(i+ichar('0')))
+ gepid_hgep_q2_cal(i) = thgetid('hgep_q2_cal'//char(i+ichar('0')))
+ gepid_hgep_q2(i) = thgetid('hgep_q2_'//char(i+ichar('0')))
+ gepid_hgep_ecal(i) = thgetid('hgep_ecal'//char(i+ichar('0')))
+ gepid_hgep_pp(i) = thgetid('hgep_pp'//char(i+ichar('0')))
+ gepid_hgep_epsilon(i) =
+ $ thgetid('hgep_epsilon'//char(i+ichar('0')))
+ gepid_hgep_etheta(i) = thgetid('hgep_etheta'//char(i+ichar('0')))
+ gepid_hgep_ephi(i) = thgetid('hgep_ephi'//char(i+ichar('0')))
+ gepid_hgep_ptheta(i) = thgetid('hgep_ptheta'//char(i+ichar('0')))
+ gepid_hgep_pphi(i) = thgetid('hgep_pphi'//char(i+ichar('0')))
+ gepid_hgep_emiss(i) = thgetid('hgep_emiss'//char(i+ichar('0')))
+ gepid_hgep_pmissx(i) = thgetid('hgep_pmissx'//char(i+ichar('0')))
+ gepid_hgep_pmissy(i) = thgetid('hgep_pmissy'//char(i+ichar('0')))
+ gepid_hgep_pmissz(i) = thgetid('hgep_pmissz'//char(i+ichar('0')))
+ gepid_hgep_xdiff(i) = thgetid('hgep_xdiff'//char(i+ichar('0')))
+ gepid_hgep_ydiff(i) = thgetid('hgep_ydiff'//char(i+ichar('0')))
+ gepid_hgep_xydiff(i) = thgetid('hgep_xydiff'//char(i+ichar('0')))
+ gepid_hgep_ediff(i) = thgetid('hgep_ediff'//char(i+ichar('0')))
+ gepid_hgep_dpel(i) = thgetid('hgep_dpel'//char(i+ichar('0')))
+
+ enddo
+
+ return
+ end
diff --git a/ENGINE/gep_initialize.f b/ENGINE/gep_initialize.f
new file mode 100755
index 0000000..50e9318
--- /dev/null
+++ b/ENGINE/gep_initialize.f
@@ -0,0 +1,47 @@
+ subroutine gep_initialize(ABORT,err)
+
+ implicit none
+ save
+
+ character*14 here
+ parameter(here='gep_initialize')
+
+ logical ABORT
+ character*(*) err
+
+ include 'gen_data_structures.cmn'
+ include 'gen_constants.par'
+ include 'gep_data_structures.cmn'
+
+ abort=.false.
+
+ gebeam = sqrt(gpbeam**2 + mass_electron**2)
+ if(gtarg_z(gtarg_num).gt.0.)then
+ call total_eloss(0,.true.,0.0,1.0,geloss)
+ else
+ geloss=0.
+ endif
+c gebeam = gebeam - geloss ! for SANE no energy loss correction
+ gpbeam = sqrt(gebeam**2 - mass_electron**2)
+ g_beam_target_s = (gtarg_mass(gtarg_num) + gebeam)**2 - gpbeam**2
+
+c initialize coincidence timing window parameters if the user hasn't defined something reasonable:
+ if(gep_h1time_slop.lt.10.or.gep_h1time_slop.gt.1000.) then
+ gep_h1time_slop=30.
+ endif
+ if(gep_h2time_slop.lt.10..or.gep_h2time_slop.gt.1000.) then
+ gep_h2time_slop=30.
+ endif
+
+ if(gep_btime_slop.lt.10.or.gep_btime_slop.gt.1000.) then
+ gep_btime_slop=30.
+ endif
+
+ IF(ABORT) THEN
+ call G_add_path(here,err)
+ ELSE
+ err= ' '
+ ENDIF
+
+ return
+ end
diff --git a/ENGINE/gep_keep_results.f b/ENGINE/gep_keep_results.f
new file mode 100755
index 0000000..5b0ca03
--- /dev/null
+++ b/ENGINE/gep_keep_results.f
@@ -0,0 +1,33 @@
+ subroutine gep_keep_results(ABORT,err)
+
+ implicit none
+ save
+
+c include 'gen_event_info.cmn'
+ include 'gep_data_structures.cmn'
+ include 'hms_data_structures.cmn'
+ include 'bigcal_data_structures.cmn'
+
+ character*14 here
+ parameter(here='b_keep_results')
+
+ logical abort
+ character*(*) err
+
+ abort=.false.
+ err=' '
+
+ if(HSNUM_FPTRACK.gt.0 .and. BIGCAL_PHYS_NTRACK .gt. 0) then
+c gep_evid = gen_event_id_number
+ call gep_ntuple_keep(abort,err)
+ call gep_fill_hist(abort,err)
+ endif
+ if(abort) then
+ call G_add_path(here,err)
+ return
+ else
+ err=' '
+ endif
+
+ return
+ end
diff --git a/ENGINE/gep_ntuple_change.f b/ENGINE/gep_ntuple_change.f
new file mode 100644
index 0000000..07c265f
--- /dev/null
+++ b/ENGINE/gep_ntuple_change.f
@@ -0,0 +1,68 @@
+ subroutine gep_ntuple_change(ABORT,err)
+
+ implicit none
+ save
+
+ character*17 here
+ parameter(here='gep_ntuple_change')
+
+ logical abort
+ character*(*) err
+
+ include 'gep_ntuple.cmn'
+ include 'gen_run_info.cmn'
+
+ character*1 ifile
+ character*80 file
+ character*1000 pat
+
+ integer*4 ilo,fn_len
+
+* functions
+ integer g_important_length
+
+ call gep_ntuple_close(abort,err)
+
+ if(gep_ntuple_exists) then
+ abort=.true.
+ endif
+
+ call NO_nulls(gep_ntuple_file)
+ file = gep_ntuple_file
+
+ call NO_nulls(file)
+ call g_sub_run_number(file,gen_run_number)
+
+ gep_ntuple_filesegments = gep_ntuple_filesegments + 1
+ if(gep_ntuple_filesegments.le.9) then
+ ifile = char(ichar('0')+gep_ntuple_filesegments)
+ else
+ ifile = char(ichar('a') + gep_ntuple_filesegments-10)
+ endif
+
+ fn_len = g_important_length(file)
+
+ ilo=index(file,'.hbook')
+ if((ilo.le.1).or.(ilo.gt.fn_len-5)) then
+ ilo=index(file,'.rzdat')
+ endif
+
+ if((ilo.gt.1).and.(ilo.lt.fn_len)) then
+ file = file(1:ilo-1)//'.'//ifile//file(ilo:fn_len)
+ else
+ abort=.true.
+ endif
+
+ if(.not.abort) call gep_ntuple_open(file,ABORT,err)
+
+ if(abort) then
+ err='unable to change GEp ntuple file segment'
+ call G_add_path(here,err)
+ else
+ pat=':changed GEp Ntuple file segment'
+ call G_add_path(here,pat)
+ call G_log_message('INFO: '//pat)
+ endif
+
+ return
+ end
diff --git a/ENGINE/gep_ntuple_clear.f b/ENGINE/gep_ntuple_clear.f
new file mode 100755
index 0000000..a615c4c
--- /dev/null
+++ b/ENGINE/gep_ntuple_clear.f
@@ -0,0 +1,7 @@
+ subroutine gep_ntuple_clear
+
+ implicit none
+ save
+c dummy routine
+ return
+ end
diff --git a/ENGINE/gep_ntuple_close.f b/ENGINE/gep_ntuple_close.f
new file mode 100755
index 0000000..c5a7e86
--- /dev/null
+++ b/ENGINE/gep_ntuple_close.f
@@ -0,0 +1,64 @@
+ subroutine gep_ntuple_close(abort,err)
+
+ implicit none
+ save
+
+ character*16 here
+ parameter(here='gep_ntuple_close')
+
+ logical abort
+ character*(*) err
+
+ include 'gep_ntuple.cmn'
+ include 'gen_routines.dec'
+
+ logical HEXIST ! cernlib function
+
+ logical fail
+ character*80 why,directory,name
+ character*1000 msg
+ integer io,id,cycle,m
+
+ err=' '
+ abort=.false.
+
+ if(.not.gep_ntuple_exists) return
+
+ call HCDIR(directory,'R') ! keep current directory
+
+ id = gep_ntuple_ID
+ io = gep_ntuple_IO_channel
+ name = gep_ntuple_name
+
+ abort = .not. HEXIST(id)
+
+ if(abort) then
+ call G_add_path(here,err)
+
+ if(io.gt.0) then
+ call G_IO_control(io,'FREE',FAIL,why)
+ if(.not.fail) close(io)
+ endif
+ endif
+
+ call HCDIR(gep_ntuple_directory,' ') ! go to ntuple directory
+
+ call G_add_path(here,msg)
+ call G_log_message('INFO: '//msg)
+
+ cycle = 0
+ call HROUT(id,cycle,' ')
+ call HREND(name)
+ call G_IO_control(io,'FREE',ABORT,err)
+ close(io)
+
+ call HCDIR(directory,' ') ! return to current directory
+
+ gep_ntuple_directory=' '
+ gep_ntuple_exists=.false.
+ gep_ntuple_IO_channel = 0
+
+ if(abort) call G_add_path(here,err)
+
+ return
+ end
diff --git a/ENGINE/gep_ntuple_init.f b/ENGINE/gep_ntuple_init.f
new file mode 100755
index 0000000..57b8362
--- /dev/null
+++ b/ENGINE/gep_ntuple_init.f
@@ -0,0 +1,199 @@
+ subroutine gep_ntuple_init(ABORT,err)
+
+ implicit none
+ save
+
+ character*15 here
+ parameter(here='gep_ntuple_init')
+
+ character*80 default_name
+ parameter(default_name='GEPntuple')
+
+ include 'gep_ntuple.cmn'
+ include 'gen_routines.dec'
+ include 'bigcal_data_structures.cmn'
+ include 'gen_run_info.cmn'
+ include 'gep_ntuple.dte'
+
+ logical ABORT
+ character*(*) err
+
+
+
+ character*80 file
+ character*80 name
+ character*1000 pat,msg
+ integer ilo,fn_len,m,i,j,k
+ character*1 ifile
+
+ err=' '
+ abort=.false.
+
+ if(gep_ntuple_exists) then
+ call gep_ntuple_shutdown(ABORT,err)
+ if(abort) then
+ call G_add_path(here,err)
+ return
+ endif
+ endif
+
+ call no_nulls(gep_ntuple_file) ! replace null characters with blanks
+
+ if(gep_ntuple_file.eq.' ') return
+ gep_ntuple_id = default_gep_ntuple_ID
+ gep_ntuple_name = default_name
+ if(gep_ntuple_title.eq.' ') then
+ msg = name//' '//gep_ntuple_file
+ call only_one_blank(msg)
+ gep_ntuple_title = msg
+ endif
+
+ file = gep_ntuple_file
+ call g_sub_run_number(file,gen_run_number)
+
+ if(gep_ntuple_max_segmentevents.gt.0) then
+ gep_ntuple_filesegments = 1
+ ifile = char(ichar('0') + gep_ntuple_filesegments)
+ fn_len = g_important_length(file)
+ ilo=index(file,'.hbook')
+ if((ilo.le.1).or.(ilo.gt.fn_len-5))then
+ ilo=index(file,'.rzdat')
+ endif
+
+ if((ilo.gt.1).and.(ilo.lt.fn_len))then
+ file = file(1:ilo-1)//'.'//ifile//file(ilo:fn_len)
+ else
+ abort=.true.
+ return
+ endif
+
+ write(*,*) ' using segmented gep rzdat files
+ $ first filename: ',file
+ else
+ write(*,*) ' not using segmented gep rzdat files
+ $ first filename: ',file
+ endif
+
+ m=0
+ m=m+1
+ gep_ntuple_tag(m) = 'evid' ! gen_event_id_number
+ m=m+1
+ gep_ntuple_tag(m) = 'trigtype' ! trigger type
+ m=m+1
+ gep_ntuple_tag(m) = 'ctimeh' ! hms coin. time
+ m=m+1
+ gep_ntuple_tag(m) = 'ctimeb' ! bigcal coin. time
+ m=m+1
+ gep_ntuple_tag(m) = 'nh1' ! number of TDC hits h1
+ m=m+1
+ gep_ntuple_tag(m) = 'nh2' ! number of TDC hits h2
+ m=m+1
+ gep_ntuple_tag(m) = 'nb' ! number of TDC hits BigCal
+ m=m+1
+ gep_ntuple_tag(m) = 'h1time' ! hms1 trigger time
+ m=m+1
+ gep_ntuple_tag(m) = 'h2time' ! hms2 trigger time
+ m=m+1
+ gep_ntuple_tag(m) = 'btime' ! bigcal trigger time
+ m=m+1
+ gep_ntuple_tag(m) = 'Q2' ! q-squared in GeV^2
+ m=m+1
+ gep_ntuple_tag(m) = 'Q2_H' ! q-squared in GeV^2, HMS
+ m=m+1
+ gep_ntuple_tag(m) = 'Q2_B' ! q-squared in GeV^2, Calo
+ m=m+1
+ gep_ntuple_tag(m) = 'E_e' ! electron energy in GeV
+ m=m+1
+ gep_ntuple_tag(m) = 'P_p' ! proton momentum in GeV/c
+ m=m+1
+ gep_ntuple_tag(m) = 'Pel_htheta' ! elastic proton momentum for hstheta
+ m=m+1
+ gep_ntuple_tag(m) = 'Pel_btheta' ! elastic proton momentum for btheta
+ m=m+1
+ gep_ntuple_tag(m) = 'delta' ! (p-p0)/p0 in %
+ m=m+1
+ gep_ntuple_tag(m) = 'xfp'! x at the focal plane for proton.
+ m=m+1
+ gep_ntuple_tag(m) = 'yfp' ! y at the focal plane for the proton.
+ m=m+1
+ gep_ntuple_tag(m) = 'xpfp'! dx/dz at the focal plane for proton.
+ m=m+1
+ gep_ntuple_tag(m) = 'ypfp' ! dy/dz at the focal plane for the proton.
+ m=m+1
+ gep_ntuple_tag(m) = 'xptar'! dx/dz at the target for proton.
+ m=m+1
+ gep_ntuple_tag(m) = 'yptar' ! dy/dz at the target for the proton.
+ m=m+1
+ gep_ntuple_tag(m) = 'ytar' ! y at the target for the proton.
+ m=m+1
+ gep_ntuple_tag(m) = 'epsilon' ! virtual photon long. polarization
+ m=m+1
+ gep_ntuple_tag(m) = 'etheta' ! electron polar scattering angle in degrees
+ m=m+1
+ gep_ntuple_tag(m) = 'ephi' ! electron azimuthal scattering angle in degrees
+ m=m+1
+ gep_ntuple_tag(m) = 'ptheta' ! proton polar scattering angle in degrees
+ m=m+1
+ gep_ntuple_tag(m) = 'pphi' ! proton azimuthal scattering angle in degrees
+ m=m+1
+ gep_ntuple_tag(m) = 'Emiss' ! missing energy in GeV
+ m=m+1
+ gep_ntuple_tag(m) = 'Pmiss' ! magnitude of missing momentum in GeV/c
+ m=m+1
+ gep_ntuple_tag(m) = 'Pmissx' ! x cpt. of missing mom.
+ m=m+1
+ gep_ntuple_tag(m) = 'Pmissy' ! y cpt. of missing mom.
+ m=m+1
+ gep_ntuple_tag(m) = 'Pmissz' ! z cpt. of missing mom.
+ m=m+1
+ gep_ntuple_tag(m) = 'W2' ! invariant mass of detected particles W^2 = (p+q)^2 = M_p^2 + 2M*nu - Q^2 = M_p^2 for ep elastic
+ m=m+1
+ gep_ntuple_tag(m) = 'Mmiss' ! missing mass of detected particles, should be zero for ep elastic
+ m=m+1
+ gep_ntuple_tag(m) = 'helicite' ! electron beam helicity
+ m=m+1
+ gep_ntuple_tag(m) = 'ntrack1' ! number of tracks in FPP1
+ m=m+1
+ gep_ntuple_tag(m) = 'ntrack2' ! number of tracks in FPP2
+ m=m+1
+ gep_ntuple_tag(m) = 'trk1' ! track number of the chosen track in FPP1
+ m=m+1
+ gep_ntuple_tag(m) = 'zclos1' ! reconstructed zclose in FPP1
+ m=m+1
+ gep_ntuple_tag(m) = 'sclos1' ! reconstructed sclose in FPP1
+ m=m+1
+ gep_ntuple_tag(m) = 'conet1' ! conetest FPP1
+ m=m+1
+ gep_ntuple_tag(m) = 'theta1' ! polar theta FPP1
+ m=m+1
+ gep_ntuple_tag(m) = 'phi1' ! azimuthal phi FPP1
+ m=m+1
+ gep_ntuple_tag(m) = 'trk2' ! track number of the chosen track in FPP2
+ m=m+1
+ gep_ntuple_tag(m) = 'zclos2' ! reconstructed zclose in FPP2
+ m=m+1
+ gep_ntuple_tag(m) = 'sclos2' ! reconstructed sclose in FPP2
+ m=m+1
+ gep_ntuple_tag(m) = 'conet2' ! conetest FPP2
+ m=m+1
+ gep_ntuple_tag(m) = 'theta2' ! polar theta FPP2
+ m=m+1
+ gep_ntuple_tag(m) = 'phi2' ! azimuthal phi FPP2
+
+c now all tags are set, initialize the ntuple:
+
+ gep_ntuple_size = m
+
+ call gep_ntuple_open(file,ABORT,err)
+
+ if(abort) then
+ err=':unable to create GEp ntuple'
+ call G_add_path(here,err)
+ else
+ pat= ':created GEp ntuple'
+ call G_add_path(here,pat)
+ call G_log_message('INFO: '//pat)
+ endif
+
+ return
+ end
diff --git a/ENGINE/gep_ntuple_keep.f b/ENGINE/gep_ntuple_keep.f
new file mode 100755
index 0000000..d8e73ed
--- /dev/null
+++ b/ENGINE/gep_ntuple_keep.f
@@ -0,0 +1,199 @@
+ subroutine gep_ntuple_keep(abort,err)
+
+ implicit none
+ save
+
+ character*15 here
+ parameter(here='gep_ntuple_keep')
+
+ logical abort
+ character*(*) err
+
+ include 'gep_ntuple.cmn'
+ include 'gep_data_structures.cmn'
+ include 'gen_data_structures.cmn'
+ include 'gen_event_info.cmn'
+ include 'gen_detectorids.par'
+ include 'gen_decode_common.cmn'
+ include 'hms_data_structures.cmn'
+ include 'hms_fpp_event.cmn'
+ include 'hms_geometry.cmn'
+
+ integer m,iTrk,iSet
+ real zclose_store,sclose_store
+ real theta_store,phi_store
+ real conetest_store,track_store
+ real zanalyzer(2)
+
+ logical HEXIST ! cernlib function
+
+ err=' '
+ abort=.false.
+
+ if(.not.gep_ntuple_exists) return
+
+ if(gep_ntuple_max_segmentevents.gt.0) then
+ if(gep_ntuple_segmentevents.gt.gep_ntuple_max_segmentevents)
+ $ then
+ call gep_ntuple_change(abort,err)
+ gep_ntuple_segmentevents=0
+ else
+ gep_ntuple_segmentevents = gep_ntuple_segmentevents + 1
+ endif
+ endif
+
+ m=0
+
+ m=m+1
+ gep_ntuple_contents(m) = float(gen_event_id_number)
+ m=m+1
+ if(gen_event_trigtype(4).eq.1.and.gen_event_trigtype(5).eq.0) then
+ gep_ntuple_contents(m) = 1.
+ else if(gen_event_trigtype(5).eq.1.and.gen_event_trigtype(4).eq.0) then
+ gep_ntuple_contents(m) = 2.
+ else
+ gep_ntuple_contents(m) = 3.
+ endif
+ m=m+1
+ gep_ntuple_contents(m) = GEP_ctime_hms
+ m=m+1
+ gep_ntuple_contents(m) = GEP_ctime_cal
+ m=m+1
+ gep_ntuple_contents(m) = float(ntrigH1)
+ m=m+1
+ gep_ntuple_contents(m) = float(ntrigH2)
+ m=m+1
+ gep_ntuple_contents(m) = float(ntrigB)
+ m=m+1
+ if(ntrigH1.gt.0.and.gep_ntuple_contents(2).ne.2.) then
+ gep_ntuple_contents(m) = GEP_H1time(1) !H1 trig time in ns (first hit only)
+ else
+ gep_ntuple_contents(m) = 0.
+ endif
+ m=m+1
+ if(ntrigH2.gt.0.and.gep_ntuple_contents(2).ne.1.) then
+ gep_ntuple_contents(m) = GEP_H2time(1) !H2 trig time in ns (first hit only)
+ else
+ gep_ntuple_contents(m) = 0.
+ endif
+ m=m+1
+ if(ntrigB.gt.0) then
+ gep_ntuple_contents(m) = GEP_Btime(1) !Bigcal trig time in ns (first hit )
+ else
+ gep_ntuple_contents(m) = 0.
+ endif
+ m=m+1
+ gep_ntuple_contents(m) = GEP_Q2
+ m=m+1
+ gep_ntuple_contents(m) = GEP_Q2_H
+ m=m+1
+ gep_ntuple_contents(m) = GEP_Q2_B
+ m=m+1
+ gep_ntuple_contents(m) = GEP_E_electron
+ m=m+1
+ gep_ntuple_contents(m) = GEP_P_proton
+ m=m+1
+ gep_ntuple_contents(m) = GEP_Pel_htheta
+ m=m+1
+ gep_ntuple_contents(m) = GEP_Pel_btheta
+ m=m+1
+ gep_ntuple_contents(m) = GEP_delta_p
+ m=m+1
+ gep_ntuple_contents(m) = GEP_xfp_p
+ m=m+1
+ gep_ntuple_contents(m) = GEP_yfp_p
+ m=m+1
+ gep_ntuple_contents(m) = GEP_xpfp_p
+ m=m+1
+ gep_ntuple_contents(m) = GEP_ypfp_p
+ m=m+1
+ gep_ntuple_contents(m) = GEP_xptar_p
+ m=m+1
+ gep_ntuple_contents(m) = GEP_yptar_p
+ m=m+1
+ gep_ntuple_contents(m) = GEP_ytar_p
+ m=m+1
+ gep_ntuple_contents(m) = GEP_epsilon
+ m=m+1
+ gep_ntuple_contents(m) = GEP_etheta_deg
+ m=m+1
+ gep_ntuple_contents(m) = GEP_ephi_deg
+ m=m+1
+ gep_ntuple_contents(m) = GEP_ptheta_deg
+ m=m+1
+ gep_ntuple_contents(m) = GEP_pphi_deg
+ m=m+1
+ gep_ntuple_contents(m) = GEP_Emiss
+ m=m+1
+ gep_ntuple_contents(m) = GEP_Pmiss
+ m=m+1
+ gep_ntuple_contents(m) = GEP_Pmissx
+ m=m+1
+ gep_ntuple_contents(m) = GEP_Pmissy
+ m=m+1
+ gep_ntuple_contents(m) = GEP_Pmissz
+ m=m+1
+ gep_ntuple_contents(m) = GEP_W2
+ m=m+1
+ gep_ntuple_contents(m) = GEP_Mmiss
+ m=m+1
+ gep_ntuple_contents(m) = gbeam_helicity
+ m=m+1
+ gep_ntuple_contents(m) = HFPP_N_tracks(1)
+ m=m+1
+ gep_ntuple_contents(m) = HFPP_N_tracks(2)
+c
+c Algorithm to select "best" track for final analysis
+c
+ do iSet=1,2
+ theta_store=1.0e15
+ phi_store=1.0e15
+ conetest_store=1.0e15
+ zclose_store=1.0e15
+ sclose_store=1.0e15
+ zanalyzer(1)=140.3
+ zanalyzer(2)=237.8
+c
+ do iTrk=1,HFPP_N_tracks(iSet)
+ if(abs(HFPP_track_zclose(iSet,iTrk)-zanalyzer(iSet)).le.27.0) then
+ if(HFPP_track_sclose(iSet,iTrk).lt.8.0) then
+ if(HFPP_track_conetest(iSet,iTrk).eq.1) then
+ if(HFPP_track_theta(iSet,iTrk).gt.2.5/180.0*3.14159265.and.
+ > HFPP_track_theta(iSet,iTrk).lt.theta_store) then
+ track_store=iTrk
+ theta_store=HFPP_track_theta(iSet,iTrk)
+ phi_store=HFPP_track_phi(iSet,iTrk)
+ conetest_store=HFPP_track_conetest(iSet,iTrk)
+ zclose_store=HFPP_track_zclose(iSet,iTrk)
+ sclose_store=HFPP_track_sclose(iSet,iTrk)
+ endif
+ endif
+ endif
+ endif
+ enddo
+ m=m+1
+ gep_ntuple_contents(m) = track_store
+ m=m+1
+ gep_ntuple_contents(m) = zclose_store
+ m=m+1
+ gep_ntuple_contents(m) = sclose_store
+ m=m+1
+ gep_ntuple_contents(m) = conetest_store
+ m=m+1
+ gep_ntuple_contents(m) = theta_store
+ m=m+1
+ gep_ntuple_contents(m) = phi_store
+ enddo
+
+ abort = .not. HEXIST(gep_ntuple_ID)
+ if(abort) then
+ call G_build_note(':Ntuple ID#$ does not exist',
+ $ '$',gep_ntuple_ID,' ',0.,' ',err)
+ call G_add_path(here,err)
+ else
+c call HFNT(gep_ntuple_ID)
+ call HFN(gep_ntuple_id,gep_ntuple_contents)
+ endif
+
+ return
+ end
diff --git a/ENGINE/gep_ntuple_open.f b/ENGINE/gep_ntuple_open.f
new file mode 100755
index 0000000..c8a7d4d
--- /dev/null
+++ b/ENGINE/gep_ntuple_open.f
@@ -0,0 +1,120 @@
+ subroutine gep_ntuple_open(file,ABORT,err)
+
+ implicit none
+ save
+
+ character*15 here
+ parameter(here='gep_ntuple_open')
+
+ logical ABORT
+ character*(*) err
+
+ include 'gep_ntuple.cmn'
+c include 'gep_data_structures.cmn'
+
+ integer default_bank,default_recl
+
+ parameter(default_bank=8000) !4 bytes/word
+ parameter(default_recl=1024) !record length
+
+ character*80 title,file
+ character*80 directory,name
+ character*1000 pat,msg
+ integer status,size,io,id,bank,recL,iv(10),m
+ real rv(10)
+
+ logical HEXIST !CERNLIB function
+
+ err=' '
+ abort=.false.
+
+ if(gep_ntuple_exists) then
+ call gep_ntuple_shutdown(ABORT,err)
+ if(abort)then
+ call G_add_path(here,err)
+ return
+ endif
+ endif
+
+c get any free IO channel
+
+ call g_IO_control(io,'ANY',ABORT,err)
+ if(abort) then
+ call G_add_path(here,err)
+ return
+ endif
+
+ gep_ntuple_io_channel = io
+
+ id = gep_ntuple_id
+ name = gep_ntuple_name
+ title = gep_ntuple_title
+ abort = HEXIST(id)
+ if(abort) then
+ call g_IO_control(gep_ntuple_io_channel,'FREE',abort,err)
+ call g_build_note(':HBOOK id#$ already in use',
+ $ '$',id,' ',rv,' ',err)
+ call G_add_path(here,err)
+ return
+ endif
+
+ call HCDIR(directory,'R') !CERNLIB read current directory
+
+ recL = default_recl
+
+ call HROPEN(io,name,file,'N',recL,status)
+
+ abort= status.ne.0
+
+ if(abort) then
+
+ call g_IO_control(gep_ntuple_io_channel,'FREE',abort,err)
+ iv(1) = status
+ iv(2) = io
+ pat= ':HROPEN error#$ opening IO#$ "'//file//'"'
+ call G_build_note(pat,'$',iv,' ',rv,' ',err)
+ call G_add_path(here,err)
+ return
+ endif
+
+ size = gep_ntuple_size
+ bank = default_bank
+ title = gep_ntuple_title
+
+ call HBOOKN(id,title,size,name,bank,gep_ntuple_tag) ! create ntuple
+c call HBNT(id,title,' ')
+c$$$ call HBNAME(id,'GEPBLOCK',gep_evid,'gep_evid:I*4,'//
+c$$$ $ 'gep_ctime_hms,gep_ctime_cal,gep_Q2,gep_Q2_H,'//
+c$$$ $ 'gep_Q2_B,GEP_E_electron,GEP_P_proton,GEP_delta_p,'//
+c$$$ $ 'gep_epsilon,gep_etheta_deg,gep_ptheta_deg,gep_ephi_deg,'//
+c$$$ $ 'gep_pphi_deg,gep_Emiss,gep_Pmissx,gep_Pmissy,gep_Pmissz,'//
+c$$$ $ 'gep_Pmiss,gep_W2,gep_Mmiss')
+
+ call HCDIR(gep_ntuple_directory,'R') ! record ntuple directory
+ call HCDIR(directory,' ') ! reset CERNLIB directory
+
+ gep_ntuple_exists = HEXIST(gep_ntuple_id)
+
+ abort = .not.gep_ntuple_exists
+
+ iv(1) = id
+ iv(2) = io
+
+ pat = 'Ntuple id#$ [' // gep_ntuple_directory // '/]' //
+ $ name // ' IO#$ "' // file // '"'
+
+ call G_build_note(pat,'$',iv,' ',rv,' ',msg)
+
+ call sub_string(msg,'/]','/]')
+
+ if(abort) then
+ err = 'unable to create '//msg
+ call G_add_path(here,err)
+ else
+ pat=':created '//msg
+ call G_add_path(here,pat)
+ call G_log_message('INFO: '//pat)
+ endif
+
+ return
+ end
diff --git a/ENGINE/gep_ntuple_register.f b/ENGINE/gep_ntuple_register.f
new file mode 100644
index 0000000..50250dd
--- /dev/null
+++ b/ENGINE/gep_ntuple_register.f
@@ -0,0 +1,26 @@
+ subroutine gep_ntuple_register(ABORT,err)
+
+ implicit none
+ save
+
+ character*19 here
+ parameter(here='gep_ntuple_register')
+
+ logical abort
+ character*(*) err
+
+ include 'gep_ntuple.cmn'
+ include 'gen_routines.dec'
+
+ err=' '
+ abort=.false.
+
+ call G_reg_C('GEp_Ntuple',gep_ntuple_file,abort,err)
+
+ if(abort) then
+ call G_prepend(':unable to register-',err)
+ call G_add_path(here,err)
+ endif
+
+ return
+ end
diff --git a/ENGINE/gep_ntuple_shutdown.f b/ENGINE/gep_ntuple_shutdown.f
new file mode 100755
index 0000000..2c303d0
--- /dev/null
+++ b/ENGINE/gep_ntuple_shutdown.f
@@ -0,0 +1,45 @@
+ subroutine gep_ntuple_shutdown(ABORT,err)
+c final shutdown of GEp ntuple
+
+ implicit none
+ save
+
+ character*19 here
+ parameter(here='gep_ntuple_shutdown')
+
+ logical abort
+ character*(*) err
+
+ include 'gep_ntuple.cmn'
+ include 'gen_routines.dec'
+
+ logical fail
+ character*80 why,directory,name
+ character*1000 msg
+ integer io,id,cycle,m
+
+ err=' '
+ abort=.false.
+
+ if(.not.gep_ntuple_exists) return
+
+ call gep_ntuple_close(abort,err)
+
+ if(gep_ntuple_exists) then
+ abort=.true.
+ endif
+
+ gep_ntuple_ID=0
+ gep_ntuple_name=' '
+ gep_ntuple_file=' '
+ gep_ntuple_title=' '
+ gep_ntuple_size=0
+ do m=1,gep_ntuple_size
+ gep_ntuple_tag(m)=' '
+ gep_ntuple_contents(m)=0.
+ enddo
+
+ if(abort) call G_add_path(here,err)
+
+ return
+ end
diff --git a/ENGINE/gep_physics.f b/ENGINE/gep_physics.f
new file mode 100755
index 0000000..d2dfce7
--- /dev/null
+++ b/ENGINE/gep_physics.f
@@ -0,0 +1,613 @@
+ subroutine gep_physics(abort,err)
+
+ implicit none
+ save
+
+ character*11 here
+ parameter(here='gep_physics')
+
+ logical abort
+ character*(*) err
+
+ include 'gen_run_info.cmn'
+ include 'gen_event_info.cmn'
+ include 'gen_data_structures.cmn'
+ include 'hms_data_structures.cmn'
+ include 'hms_scin_parms.cmn'
+ include 'bigcal_data_structures.cmn'
+ include 'gep_data_structures.cmn'
+ include 'gen_constants.par'
+ include 'hms_scin_tof.cmn'
+ include 'hms_physics_sing.cmn'
+ include 'bigcal_tof_parms.cmn'
+ include 'bigcal_gain_parms.cmn'
+ include 'bigcal_shower_parms.cmn'
+ include 'bigcal_geometry.cmn'
+ include 'bigcal_bypass_switches.cmn'
+ include 'sane_data_structures.cmn'
+
+ include 'sane_ntuple.cmn'
+c
+c local variables:
+c
+
+c FIRST PART OF THIS CODE IS TO USE HMS INFO TO SELECT BEST TRACK IN BIGCAL!!!
+c HMS phi is centered at -PI/2, therefore, we need to rotate bigcal phi so
+c that it is centered at +PI/2
+c here we want to use the HMS singles physics info to choose the best track
+c from BigCal assuming elastic kinematics!!!
+ integer pick_best_cal_track
+
+c logical fixed_bigcal
+
+ real etheta_expect,ephi_expect
+ real exhat,eyhat,ezhat,exhat_tar,eyhat_tar,ezhat_tar
+ real xint_hexpect,yint_hexpect,zint_hexpect
+ real xcal_hexpect
+ real ycal_hexpect
+ real Ecal_hexpect
+ real tcal_hexpect
+ real Eprime,ethetarad,ephirad,Q2_gep,nu
+ real pthetarad,pphirad
+ real vx,vy,vz
+ real etint
+ real edx,edy,edz,ethetacorr,ephicorr,epathlength,mom_corr
+ real gamma_corr,beta_corr,tof
+ real Q2_cal,Q2_hms,Q2_htheta,nu_htheta,pp_htheta,pp_btheta
+ real nu_btheta
+ real Ee_btheta
+ real hoffset_ctime,boffset_ctime,htrigt,btrigt,mindiff
+
+ real dx_ang,dy_ang,func1_mom,func2_mom,func4_x,func3_y,func5_mom
+ real func1_dx,func2_dx,func3_dx,func4_dx,func5_x,func5_y
+ real*8 theta_angle_diff,phi_angle_diff
+
+cc
+c
+c Implementetion of the magnetic field for electron tracking to BIGCAL
+c
+cc
+ REAL*8 TARGET_COORD(6),Eprot,Pprot
+ COMMON/TARGET_GENRECON/TARGET_COORD,Eprot,Pprot
+ real*8 u(6),dl,temp,zfinal
+ real*8 Eb,theta_big, phi_big!,ccx,ccy,ccz
+ common/FAKEBIG/Eb,theta_big, phi_big
+c real*8 P1_bigcal(3),P2_bigcal(3),P3_bigcal(3)
+c real*8 P1_bigcal_r(3),P2_bigcal_r(3),P3_bigcal_r(3)
+ logical ok
+ccccccccccccccccccccccccccccccc
+ real Mp
+ parameter(Mp=.938272)
+
+ real Me
+
+ integer i,ibest_cal
+
+ real PI
+ parameter(PI=3.14159265359)
+
+c if the user has not defined something reasonable, then set by hand here:
+
+ if(GEP_sigma_Ediff.lt..001.or.GEP_sigma_Ediff.gt.10.0) then
+ GEP_sigma_Ediff = .06
+ endif
+ if(GEP_sigma_Xdiff.lt..001.or.GEP_sigma_Xdiff.gt.100.0) then
+ GEP_sigma_Xdiff = 1.0
+ endif
+ if(GEP_sigma_Ydiff.lt..001.or.GEP_sigma_Ydiff.gt.100.0) then
+ GEP_sigma_Ydiff =1.0
+ endif
+ if(GEP_sigma_Tdiff.lt..001.or.GEP_sigma_Tdiff.gt.1000.0) then
+ GEP_sigma_Tdiff = 10.0
+ endif
+
+ if(gen_bigcal_mc.eq.3) then ! fill HMS info from Monte Carlo:
+ hsnum_fptrack = 1
+ hsp = pp_mc
+ hsdelta = (hsp - hpcentral)/hpcentral
+ hsenergy = sqrt(hsp**2 + Mp**2)
+ hstheta = ptheta_mc*PI/180.
+ hsphi = (- pphi_mc - 90.)*PI/180.
+ hszbeam = zv_p_mc
+ gbeam_x = xv_p_mc
+ gbeam_y = yv_p_mc
+ endif
+
+ if(hsnum_fptrack.le.0) then
+ return
+ endif
+
+c here we compute the expected cluster time in BigCal (using the focal-plane time for the
+c good track):
+
+ hoffset_ctime = hstime_at_fp - hstart_time_center + hspath_cor ! should be around zero for most
+
+ mindiff = 0.
+
+ if(ntrigb.gt.0) then
+ do i=1,ntrigb
+ if(i.eq.1.or.abs(gep_btime(i)-gep_btime_elastic).lt.mindiff) then
+ btrigt = gep_btime(i)
+ mindiff = abs(gep_btime(i)-gep_btime_elastic)
+ endif
+ enddo
+ else
+ btrigt = gep_btime_elastic
+ endif
+
+c invert (common-stop) hms trigger times using the same user parameter as for BigCal:
+
+ if(ntrigh2.gt.0.and.ntrigh1.eq.0) then
+ htrigt = bigcal_end_time - gep_h2time(1)
+ else if(ntrigh1.gt.0.and.ntrigh2.eq.0) then
+ htrigt = bigcal_end_time - gep_h1time(1)
+ else if(ntrigh1.gt.0.and.ntrigh2.gt.0) then ! use trig. time 2
+ htrigt = bigcal_end_time - gep_h2time(1)
+ else ! shouldn't hardcode coin. trigger delay, but most data is taken with
+c 16 ns delay of HMS trigger relative to BigCal trigger. Eventually set up a user param.
+ htrigt = bigcal_end_time - gep_btime_elastic + gep_htrig_delay
+ endif
+
+c here are the possible scenarios for the coincidence trigger:
+c 1. BigCal comes in first by about 16 ns (or gep_htrig_delay). This is most likely for good
+c elastics, but
+c the timing resolution of BigCal is comparatively poor (several ns as opposed to sub-ns
+c in the case of the hms scintillators), and the tail of the BigCal trigger time peak has some
+c overlap with the HMS self-timing peak.
+c 2. the BigCal trigger comes in later than the HMS trigger, and the ADC gate/TDC stop comes
+c from the BigCal self-timing peak.
+c Now, suppose we have a good elastic event for which the hms trigger self-times and picks out
+c a track with focal-plane time near hstart_time_center (normal case). Then, we should look for
+c BigCal clusters coming in 16 ns (gep_htrig_delay) earlier than htrig + hoffset_ctime!
+c Now, suppose we have a good elastic event for which the bigcal trigger self-times and the HMS
+c trigger comes in earlier. IF BigCal self-times, then we also expect the good cluster time to be
+c in the self-timing peak for BigCal, and an earlier HMS time. But essentially, we should always
+c look for the BigCal cluster 16 ns before the HMS focal-plane time, because that is where our
+c elastics are:
+
+ tcal_hexpect = htrigt + hoffset_ctime - gep_htrig_delay
+c tcal_hexpect = hoffset_ctime
+
+c$$$ write(*,*) 'tcal_hexpect=',tcal_hexpect
+c$$$ write(*,*) 'hoffset_ctime=',hoffset_ctime
+c$$$ write(*,*) 'htrigt=',htrigt
+
+ Me = mass_electron ! convenient shorthand
+
+c calculate nu for elastic-ep:
+
+ nu = sqrt(Mp**2 + hsp**2) - Mp
+
+c expected electron energy:
+ Eprime = gebeam - nu
+
+ Ecal_hexpect = Eprime
+
+ pthetarad = hstheta
+c pthetarad = 2*SANE_HMS_ANGLE_THETA*3.1415/180.-hstheta
+ pphirad = hsphi - 3.*PI/2.
+
+c calculate proton momentum (assuming elastic) from hstheta:
+
+ Q2_htheta = 4.*Mp**2*gebeam**2*(cos(hstheta))**2 /
+ $ (Mp**2 + 2.*Mp*gebeam + gebeam**2*(sin(hstheta))**2)
+ nu_htheta = Q2_htheta / (2.*Mp)
+
+ pp_htheta = sqrt(nu_htheta**2 + 2.*Mp*nu_htheta)
+
+c calculate electron angle from gebeam and hsp only, since the resolution of these quantities is better than
+c you can get using hstheta, the reason being the large Jacobian of the reaction. The error on etheta is
+c magnified roughly by a factor hsp/Eprime compared to the error on hstheta, and this in turn gives a
+c large error on xcal,ycal
+
+ if(nu.ge.gebeam) then ! this is certainly not an elastic proton!!!!
+ Eprime = 0.
+ etheta_expect = 0.
+ xcal_hexpect = -999.
+ ycal_hexpect = -999.
+ goto 173
+c set Eprime and theta to zero and skip calculation of expected electron position:
+ else if(nu/Eprime.gt.2.*gebeam/Mp) then ! ep elastic is still kinematically forbidden!
+ Eprime = 0.
+ etheta_expect = 0.
+ xcal_hexpect = -999.
+ ycal_hexpect = -999.
+ goto 173
+ else ! if ep-elastic is not explicitly kinematically forbidden, then
+c use elastic kinematics to predict the electron position and energy:
+c since we have yet to put a cut on the correlation between hsp and pel(hstheta),
+c we won't always get a sensible value. Just want to prevent annoying divide-by-zero messages for now.
+ etheta_expect = acos(1. - Mp/gebeam * nu / Eprime)
+ endif
+
+ ! in BigCal coordinates, phi is centered at 0 for BigCal. In target coordinates, BigCal is
+ ! centered at +PI/2, while HMS is centered at -PI/2. However, since BigCal y means -target x
+ ! we have to be careful.
+
+ if(pphirad.gt.0) then
+ pphirad = pphirad - PI
+ endif
+
+ ephi_expect = pphirad + PI
+
+ ethetarad = etheta_expect
+
+ gep_etheta_expect_H = ethetarad
+ gep_ephi_expect_H = ephi_expect
+
+c first calculate exhat,eyhat,ezhat in target coordinates so there is no ambiguity:
+
+ exhat_tar = sin(ethetarad)*cos(ephi_expect)
+ eyhat_tar = sin(ethetarad)*sin(ephi_expect)
+ ezhat_tar = cos(ethetarad)
+
+c now rotate to BigCal coordinates:
+
+ exhat = eyhat_tar
+ eyhat = -exhat_tar
+ ezhat = ezhat_tar
+
+ !write(*,*) 'exhat,eyhat,ezhat=',exhat,eyhat,ezhat
+
+c vertex coordinates expressed in BigCal coordinate system
+c turns out that beam x and y coordinates are the same as BigCal coordinates
+
+ vz = hszbeam ! along beamline
+ vx = gbeam_x ! horizontal toward BigCal
+ vy = gbeam_y ! vertical up (target x is vertical down.)
+
+ !write(*,*) 'vertex xyz=',vx,vy,vz
+
+c etint is the trajectory parameter, calculated at the intersection point with the face of BigCal,
+c in other words, if e- position = vertex + et*ehat, where ehat is the unit trajectory vector and et is
+c the parameter determining where we are on the line, then etint is the value of the parameter when the
+c electron hits the calorimeter.
+c so we are calculating the intersection point of the e- trajectory expected from the HMS with BigCal:
+
+ etint = (bigcal_r_tgt-vx*bigcal_sintheta-vz*bigcal_costheta) /
+ $ (exhat * bigcal_sintheta + ezhat*bigcal_costheta)
+
+ xint_hexpect = vx + etint * exhat
+ yint_hexpect = vy + etint * eyhat
+ zint_hexpect = vz + etint * ezhat
+
+ !write(*,*) 'xint,yint,zint=',xint_hexpect,yint_hexpect,zint_hexpect
+
+c now rotate into calo-centered coordinate system:
+
+cc xcal_hexpect=xint_hexpect*bigcal_costheta-zint_hexpect*bigcal_sintheta
+cc ycal_hexpect=yint_hexpect
+c tcal_hexpect= hstime_at_fp - hstart_time_center + hspath_cor
+
+********** use parameter correlated functions insted of tgd field correction subtoutines *************************
+ xcal_hexpect_B0=xint_hexpect*bigcal_costheta-zint_hexpect*bigcal_sintheta
+ ycal_hexpect_B0=yint_hexpect
+
+ dy_ang=ycal_hexpect_B0/bigcal_r_tgt
+ dx_ang=xcal_hexpect_B0/bigcal_r_tgt
+
+ EprimeMeV = Eprime*1000
+ func1_mom =-15.358+(0.0122386*(Eprime*1000))+(-3.57333e-6*(Eprime*1000)**2)+(3.63059e-10*(Eprime*1000)*(Eprime*1000)**2)
+ func2_mom =-78.556+(0.0340849*(Eprime*1000))+(-5.45359e-6*(Eprime*1000)**2)+(1.87087e-10*(Eprime*1000)*(Eprime*1000)**2)
+ func3_y = -0.03322 + (1.19167*vy)
+ func4_x = 0.00001 + (0.09876*vx)
+cc func5_mom = -6.5252+(0.0015859*(Eprime*1000))+(0.53662e-6*(Eprime*1000)**2)+(-0.14983e-9*(Eprime*1000)*(Eprime*1000)**2)
+cc xdiff_shift=func1_mom + (func2_mom*dy_ang) + func3_y + func4_x
+ xdiff_shift=func1_mom + (func2_mom*dy_ang) + func3_y + func4_x
+
+ func1_dx = -108.84+(163.98*dx_ang)+(-135.00*dx_ang**2)
+ func2_dx = 0.079489+(-0.12047*dx_ang)+(0.13244*dx_ang**2)
+ func3_dx = -0.24567e-4+(0.37428e-4*dx_ang)+(-0.51771e-4*dx_ang**2)
+ func4_dx = 2.7249e-9+(-0.41655e-8*dx_ang)+(0.68318e-8*dx_ang**2)
+cc func5_x = 0.01204+(-0.39499*vx)
+cc func5_y = 0.00906+(0.00070*vy)
+cc ydiff_shift = (func1_dx+(func2_dx*(Eprime*1000))+(func3_dx*(Eprime*1000)*(Eprime*1000))+(func4_dx*(Eprime*1000)
+cc & *(Eprime*1000)*(Eprime*1000))+func5_x - func5_y)
+ ydiff_shift = (func1_dx+(func2_dx*(Eprime*1000))+(func3_dx*(Eprime*1000)*(Eprime*1000))+(func4_dx*(Eprime*1000)
+ & *(Eprime*1000)*(Eprime*1000)))
+
+c xcal_hexpect =xcal_hexpect_B0- xdiff_shift
+c ycal_hexpect =ycal_hexpect_B0+ ydiff_shift
+
+***********************************************************************************************************************
+
+c for now, just take time difference relative to bigcal_window center
+c tcal_hexpect = bigcal_window_center
+
+ if(gen_bigcal_mc.eq.3) then
+ tcal_hexpect = 0.0
+ endif
+
+ 173 continue
+
+cc
+c
+c Implementetion of the magnetic field for electron tracking to BIGCAL
+c
+cc
+ if(SANE_TGTFIELD_B.gt.0)then
+c if(a_bigcal.eq.0.and.b_bigcal.eq.0.and.c_bigcal.eq.0)then
+c
+c Define Bigcal plane
+c
+c P1_bigcal(1) = 0
+c P1_bigcal(2) = 0
+c P1_bigcal(3) = Bigcal_SHIFT(3)
+c P2_bigcal(1) = 0
+c P2_bigcal(2) = 1
+c P2_bigcal(3) = Bigcal_SHIFT(3)
+c P3_bigcal(1) = 1
+c P3_bigcal(2) = 0
+c P3_bigcal(3) = Bigcal_SHIFT(3)
+
+
+c call ROTATE(P1_bigcal, 0., -Bigcal_SHIFT(4)*3.141/180., 0. ,P1_bigcal_r)
+c call ROTATE(P2_bigcal, 0., -Bigcal_SHIFT(4)*3.141/180., 0. ,P2_bigcal_r)
+c call ROTATE(P3_bigcal, 0., -Bigcal_SHIFT(4)*3.141/180., 0. ,P3_bigcal_r)
+c temp = P1_bigcal_r(2)
+c P1_bigcal_r(2) = P1_bigcal_r(1)
+c P1_bigcal_r(1) = temp
+c temp = P2_bigcal_r(2)
+c P2_bigcal_r(2) = P2_bigcal_r(1)
+c P2_bigcal_r(1) = temp
+c temp = P3_bigcal_r(2)
+c P3_bigcal_r(2) = P3_bigcal_r(1)
+c P3_bigcal_r(1) = temp
+c call Plane(P1_bigcal_r,P2_bigcal_r,P3_bigcal_r,
+c , a_bigcal,b_bigcal,c_bigcal,d_bigcal)
+c write(*,*)P1_bigcal_r,P2_bigcal_r,P3_bigcal_r
+c endif
+ theta_angle_diff=abs(SANE_BETA_ANGLE_THETA-SANE_FIELD_ANGLE_THETA)
+ SANE_BETA_ANGLE_PHI = 0
+ SANE_FIELD_ANGLE_PHI = 0
+ if (SANE_BETA_ANGLE_PHI .eq. SANE_FIELD_ANGLE_PHI) then
+ if (SANE_BETA_ANGLE_THETA .ge. SANE_FIELD_ANGLE_THETA) phi_angle_diff=0.
+ if (SANE_BETA_ANGLE_THETA .lt. SANE_FIELD_ANGLE_THETA) phi_angle_diff=180.
+ endif
+ if (SANE_FIELD_ANGLE_THETA .eq. 0 ) then
+ if (SANE_BETA_ANGLE_PHI .eq. 0 ) phi_angle_diff=0.
+ if (SANE_BETA_ANGLE_PHI .eq. 180. ) phi_angle_diff=180.
+ endif
+ if (SANE_FIELD_ANGLE_THETA .eq. 180 ) then
+ if (SANE_BETA_ANGLE_PHI .eq. 0 ) phi_angle_diff=180.
+ if (SANE_BETA_ANGLE_PHI .eq. 180. ) phi_angle_diff=0.
+ endif
+ theta_angle_diff=40.0d00
+ phi_angle_diff=180.0d00
+c use +x vertical down, +y large angle, +z towards beta for tracking thru field
+c SANE_FIELD_THETA =theta_angle_diff
+c SANE_FIELD_PHI =phi_angle_diff
+ CALL trgInitFieldANGLES(SANE_BETA_FIELD_THETA ,SANE_BETA_FIELD_PHI)
+
+ Eb = -Eprime*1000.
+ U(1) = 0 ! vertical position (-y_beta) cm
+ U(2) = 0 ! horizontal position (+x_beta) cm in Beta coodinates
+ U(3) = 0 ! z position (z_beta) cm in Beta coodinates
+ theta_big = etheta_expect
+ phi_big = (ephi_expect)
+ dy_ang=-ycal_hexpect_B0/bigcal_r_tgt
+ dx_ang=xcal_hexpect_B0/bigcal_r_tgt
+ U(6) = 29.979/sqrt(1+dy_ang**2+dx_ang**2)
+ U(4) = dy_ang*u(6) ! dy_beta/dz_beta*(speed of light) cm/ns
+ U(5) = dx_ang*u(6) ! dx_beta/dz_beta*(speed of light) cm/ns
+ dl = 1.0
+ ok = .TRUE.
+c give trgTrackToPlane the starting positions and angles in U vector and it
+c returns the positions and angles at the plane
+c write(*,*) ' call trackto plane'
+ zfinal=-bigcal_r_tgt
+ call trgTrackToPlane(U,Eb,dl,
+ , 0.d00,0.d00,1.d00,zfinal,ok)
+c write(*,*) 'retrun call trackto plane'
+ gep_bx_expect_H = u(2)
+ gep_by_expect_H = -u(1)
+c if ( eprime .gt. 1.0 .and. abs((gep_p_proton - gep_pel_htheta) / hpcentral +0.01) .le. .02) then
+c write(*,*) ' positions = ',xcal_hexpect_B0,ycal_hexpect_B0,gep_bx_expect_H,gep_by_expect_H,dx_ang,dy_ang
+c write(*,*) eb,zfinal,' U = ',u
+c endif
+ else
+ gep_bx_expect_H = xcal_hexpect
+ gep_by_expect_H = ycal_hexpect
+ endif
+
+ !write(*,*) 'bigcal e_hms,x_hms,y_hms=',Eprime,xcal_hexpect,ycal_hexpect
+
+c how to choose? pick the track for which the quadrature sum of
+c sum( ((Eclust-Eexpect)/sigma)**2 + ((xclust-xexpect)/sigma)**2 + ((yclust-yexpect)/sigma)**2 ) is minimum
+c the resolution parameters sigma should be CTP parms
+
+c if(b_use_bad_chan_list.ne.0) then
+c check bigcal clusters, and, if necessary, fix clusters near the
+c expected electron position containing channels in the "bad" list
+
+c fixed_bigcal = .false.
+* fixed_bigcal will be true if any channels from the bad channel list are
+* filled with a guess and if any cluster is rebuilt or a new cluster is found
+c call gep_check_bigcal(gep_bx_expect_H,gep_by_expect_H,Eprime)
+c endif
+
+ call b_calc_physics(abort,err) ! reconstruct physics quantities for BigCal.
+c this routine should only get called once per event!!!!!!!!!!!!!!!!
+
+* now pick up where we left off:
+
+
+c ibest_cal = pick_best_cal_track(tcal_hexpect,gep_etheta_expect_h,
+c $ gep_ephi_expect_h,gep_bx_expect_h,gep_by_expect_h,Ecal_hexpect)
+
+ ibest_cal = 1
+
+
+c now compute "missing" quantities using the track we have selected.
+c first correct best calo track for vertex information which we now know from HMS reconstruction:
+
+ if(ibest_cal.eq.0) return
+
+ bigcal_itrack_best = ibest_cal
+
+c correct angles since we know vertex:
+
+ edx = bigcal_track_xface(ibest_cal) - vx
+ edy = bigcal_track_yface(ibest_cal) - vy
+ edz = bigcal_track_zface(ibest_cal) - vz
+
+ epathlength = sqrt(edx**2 + edy**2 + edz**2)
+
+ bigcal_thetarad = acos(edz/epathlength)
+ bigcal_phirad = atan2(edy,edx)
+
+ bigcal_track_thetarad(ibest_cal) = bigcal_thetarad
+ bigcal_track_phirad(ibest_cal) = bigcal_phirad
+
+ bigcal_energy = bigcal_track_energy(ibest_cal)
+
+c correct tof:
+
+ gamma_corr = bigcal_energy / Me
+
+c could get a "NaN" error here: check:
+ if(gamma_corr.lt.1.) gamma_corr = 1.
+
+ beta_corr = sqrt(max(0.,1.-1./gamma_corr**2))
+
+ if(beta_corr.eq.0.) beta_corr = 1.
+ bigcal_beta = beta_corr
+ bigcal_tof = epathlength / (beta_corr*speed_of_light)
+
+ mom_corr = beta_corr * bigcal_energy
+
+ bigcal_px = mom_corr * sin(bigcal_thetarad) * cos(bigcal_phirad)
+ bigcal_py = mom_corr * sin(bigcal_thetarad) * sin(bigcal_phirad)
+ bigcal_pz = mom_corr * cos(bigcal_thetarad)
+
+ bigcal_eloss = bigcal_track_eloss(ibest_cal)
+ bigcal_time = bigcal_track_time(ibest_cal)
+ bigcal_tof_cor = bigcal_tof - bigcal_tof_central
+ bigcal_ctime = bigcal_track_time(ibest_cal) - bigcal_tof_cor -
+ $ (bigcal_end_time - gep_btime_elastic)
+
+ gep_ctime_hms = hstime_at_fp - hstart_time_center + hspath_cor
+ gep_ctime_cal = bigcal_ctime
+
+ if(gen_bigcal_mc.eq.3) then
+ gep_ctime_hms = 0.
+ gep_ctime_cal = 0.
+ endif
+
+ Ee_btheta = gebeam / (1. + gebeam/Mp * (1. - cos(bigcal_thetarad)))
+
+ nu_btheta = gebeam - Ee_btheta
+ pp_btheta = sqrt(nu_btheta**2 + 2.*Mp*nu_btheta)
+c compute Q2 three different ways:
+c Q2_Cal uses only BigCal information except for hms vertex info
+c Q2_hms uses only HMS information, period.
+ Q2_cal = 2.*gebeam*Ee_btheta*(1.-cos(bigcal_thetarad))
+ Q2_hms = 2.*Mp*nu
+c what is the average Q2? Both measurements are very good, except for bigcal_energy
+c best is probably to use Eprime calculated from hsp, but use BigCal angle measurement
+c corrected for HMS vertex info. Q2 from Ebeam, hsp alone (Q2_hms) may be even better than this.
+ GEP_Q2 = 2.*gebeam*Eprime*(1.-cos(bigcal_thetarad))
+c GEP_Q2 = .5*(Q2_cal + Q2_hms)
+ GEP_Q2_H = Q2_hms
+ GEP_Q2_B = Q2_cal
+ GEP_E_electron = Eprime ! electron energy from HMS
+ GEP_P_proton = hsp
+ GEP_Pel_htheta = pp_htheta
+ GEP_Pel_btheta = pp_btheta
+ GEP_delta_p = hsdelta
+ GEP_xfp_p = HSX_FP
+ GEP_yfp_p = HSY_FP
+ GEP_xpfp_p = HSXP_FP
+ GEP_ypfp_p = HSYP_FP
+ GEP_xptar_p = HSXP_TAR
+ GEP_yptar_p = HSYP_TAR
+ GEP_ytar_p = HSY_TAR
+ GEP_epsilon = 1./(1.+2.*(1.+GEP_Q2/(4.*Mp**2))*(tan(bigcal_thetarad/2.))**2)
+ GEP_etheta_deg = bigcal_thetarad * 180./PI
+ GEP_ptheta_deg = hstheta * 180./PI
+ GEP_ephi_deg = bigcal_phirad * 180./PI + 90.
+ GEP_pphi_deg = pphirad * 180./PI
+
+ GEP_Emiss = gebeam + Mp - hsenergy - bigcal_energy
+ GEP_Pmissx = -bigcal_py + hsp*sin(hstheta)*cos(pphirad)
+ GEP_Pmissy = bigcal_px + hsp*sin(hstheta)*sin(pphirad)
+ GEP_Pmissz = gpbeam - bigcal_pz - hsp*cos(hstheta)
+ GEP_Pmiss = sqrt(GEP_Pmissx**2 + GEP_Pmissy**2 + GEP_Pmissz**2)
+ GEP_W2 = Mp**2 + Q2_hms - Q2_cal ! 2Mnu - Q2_cal
+ GEP_Mmiss = sqrt(abs(GEP_W2 - Mp**2))
+
+ return
+ end
+
+
+ integer function pick_best_cal_track(T_H,TH_H,PH_H,X_H,Y_H,E_H)
+
+ include 'gep_data_structures.cmn'
+ include 'bigcal_data_structures.cmn'
+ include 'bigcal_tof_parms.cmn'
+
+ logical restore_E
+ integer itrack,ibest
+ real diffsum,mindiffsum
+
+ real E_cal,TH_cal,PH_cal,T_cal,X_cal,Y_cal
+ real T_H,TH_H,PH_H,E_H,X_H,Y_H
+
+ real PI
+ parameter(PI=3.14159265359)
+
+ restore_E = .false.
+
+ if(bigcal_phys_ntrack.gt.0) then
+ do itrack = 1,bigcal_phys_ntrack
+ E_cal = bigcal_track_energy(itrack)
+
+ if(E_cal .gt. 10.0) then ! divide by 1000
+ E_cal = E_cal / 1000.
+ restore_E = .true.
+ endif
+
+ TH_cal = bigcal_track_thetarad(itrack)
+ PH_cal = bigcal_track_phirad(itrack) + PI/2.
+
+
+ T_cal = bigcal_track_time(itrack) - bigcal_track_tof_cor(itrack) -
+ $ (bigcal_end_time - gep_btime_elastic)
+ X_cal = bigcal_all_clstr_x(itrack)
+ Y_cal = bigcal_all_clstr_y(itrack)
+
+ diffsum = 0.
+ diffsum = diffsum + ( (E_cal - E_H)/GEP_sigma_Ediff )**2
+ diffsum = diffsum + ( (TH_cal - TH_H)/GEP_sigma_thdiff )**2
+ diffsum = diffsum + ( (PH_cal - PH_H)/GEP_sigma_phdiff )**2
+ diffsum = diffsum + ( (T_cal - T_H)/GEP_sigma_Tdiff )**2
+ diffsum = diffsum + ( (X_cal - X_H)/GEP_sigma_Xdiff )**2
+ diffsum = diffsum + ( (Y_cal - Y_H)/GEP_sigma_Ydiff )**2
+
+ if(itrack.eq.1) then
+ mindiffsum = diffsum
+ ibest = itrack
+ else
+ if(diffsum.lt.mindiffsum) then
+ mindiffsum = diffsum
+ ibest = itrack
+ endif
+ endif
+
+ bigcal_all_clstr_chi2(itrack) = diffsum/6.
+ bigcal_all_clstr_chi2contr(itrack,1) = ( (E_cal - E_H)/GEP_sigma_Ediff )**2
+c bigcal_all_clstr_chi2contr(itrack,2) = ( (TH_cal - TH_H)/GEP_sigma_thdiff )**2
+c bigcal_all_clstr_chi2contr(itrack,3) = ( (PH_cal - PH_H)/GEP_sigma_phdiff )**2
+c bigcal_all_clstr_chi2contr(itrack,4) = ( (X_cal - X_H)/GEP_sigma_xdiff )**2
+c bigcal_all_clstr_chi2contr(itrack,5) = ( (Y_cal - Y_H)/GEP_sigma_ydiff )**2
+c bigcal_all_clstr_chi2contr(itrack,6) = ( (T_cal - T_H)/GEP_sigma_Tdiff )**2
+
+ if(restore_E) E_cal = E_cal * 1000.
+
+ enddo
+ pick_best_cal_track = ibest
+ else
+ pick_best_cal_track = 0
+ endif
+
+ end
diff --git a/ENGINE/gep_proper_shutdown.f b/ENGINE/gep_proper_shutdown.f
new file mode 100755
index 0000000..98712c5
--- /dev/null
+++ b/ENGINE/gep_proper_shutdown.f
@@ -0,0 +1,46 @@
+ subroutine gep_proper_shutdown(lunout,ABORT,err)
+
+ implicit none
+ save
+
+ character*19 here
+ parameter(here='gep_proper_shutdown')
+
+ include 'gen_routines.dec'
+ include 'gen_filenames.cmn'
+ include 'gen_run_info.cmn'
+ include 'gep_data_structures.cmn'
+ include 'gep_filenames.cmn'
+
+ logical abort, report_abort
+ character*(*) err
+
+ integer lunout
+ integer ierr
+ character*132 file
+
+ abort=.false.
+ err=' '
+
+c call gep_report_bad_data(lunout,ABORT,err)
+
+ if(gep_report_blockname.ne.' '.and.
+ $ gep_report_output_filename.ne.' ') then
+ file = gep_report_output_filename
+ call g_sub_run_number(file,gen_run_number)
+ ierr = threp(gep_report_blockname,file)
+ if(ierr.ne.0) then
+ call g_append(err,'& threp failed to create report in file'
+ $ //file)
+ report_abort = .true.
+ endif
+ endif
+
+ if(abort.or.report_abort) then
+ call G_add_path(here,err)
+ else
+ err=' '
+ endif
+
+ return
+ end
diff --git a/ENGINE/gep_reconstruction.f b/ENGINE/gep_reconstruction.f
new file mode 100755
index 0000000..b3f9a29
--- /dev/null
+++ b/ENGINE/gep_reconstruction.f
@@ -0,0 +1,42 @@
+ subroutine gep_reconstruction(ABORT,err)
+
+ implicit none
+ save
+
+ character*18 here
+ parameter(here='gep_reconstruction')
+
+ logical abort
+ character*(*) err
+
+ include 'gep_data_structures.cmn'
+ include 'gen_constants.par'
+ include 'gen_units.par'
+ include 'bigcal_bypass_switches.cmn'
+c include 'gep_bypass_switches.cmn'
+
+ abort=.false.
+ err=' '
+
+c if(gepbypass_physics.eq.0) then
+
+ call gep_physics(abort,err)
+ if(abort) then
+ call G_add_path(here,err)
+ return
+ endif
+
+ if(bigcal_do_calibration.ne.0) then
+ call b_matrix_accum(abort,err)
+ if(abort) then
+ call g_add_path(here,err)
+ return
+ endif
+ endif
+
+c successful return
+
+ abort = .false.
+
+ return
+ end
diff --git a/ENGINE/gep_register_variables.f b/ENGINE/gep_register_variables.f
new file mode 100755
index 0000000..a57a36c
--- /dev/null
+++ b/ENGINE/gep_register_variables.f
@@ -0,0 +1,36 @@
+ subroutine gep_register_variables(ABORT,err)
+
+ implicit none
+ save
+
+ character*22 here
+ parameter (here='gep_register_variables')
+
+ logical ABORT
+ character*(*) err
+ logical FAIL
+ character*100 why
+
+ err = ' '
+ ABORT = .false.
+
+ call r_gep_data_structures
+ call r_gep_filenames
+ call r_gep_ntuple
+
+ if(abort)then
+ call G_prepend(':unable to register',err)
+ endif
+
+ if(abort .or. err.ne.' ') call g_add_path(here,err)
+
+ call gep_ntuple_register(FAIL,why) ! remove this when ctp files fixed
+ if(err.ne.' '.and.why.ne.' ') then
+ call G_append(err,' & '//why)
+ else if(why.ne.' ') then
+ err=why
+ endif
+ abort = abort.or.fail
+
+ return
+ end
diff --git a/ENGINE/gep_reset_event.f b/ENGINE/gep_reset_event.f
new file mode 100644
index 0000000..d1b6721
--- /dev/null
+++ b/ENGINE/gep_reset_event.f
@@ -0,0 +1,74 @@
+ subroutine gep_reset_event(ABORT,err)
+
+ implicit none
+ save
+
+ character*15 here
+ parameter(here='gep_reset_event')
+
+ logical abort
+ character*(*) err
+
+ include 'gep_data_structures.cmn'
+
+ integer i,j
+
+ abort=.false.
+ err=' '
+
+ ntrigh1 = 0
+ ntrigh2 = 0
+ ntrigb = 0
+
+ do i=1,8
+ gep_h1time(i) = 0.
+ gep_h2time(i) = 0.
+ gep_btime(i) = 0.
+ enddo
+
+ gep_btime_raw = 0.
+ gep_btime_corr = 0.
+
+ gep_ctime_hms = 0.
+ gep_ctime_cal = 0.
+ gep_Q2 = 0.
+ gep_Q2_H = 0.
+ gep_Q2_B = 0.
+ gep_E_electron = 0.
+ gep_P_proton = 0.
+ gep_delta_P = 0.
+ gep_epsilon = 0.
+ gep_xfp_p = 0.
+ gep_yfp_p = 0.
+ gep_xpfp_p = 0.
+ gep_ypfp_p = 0.
+ gep_xptar_p = 0.
+ gep_yptar_p = 0.
+ gep_ytar_p = 0.
+
+ gep_etheta_deg = 0.
+ gep_ephi_deg = 0.
+ gep_ptheta_deg = 0.
+ gep_pphi_deg = 0.
+ gep_emiss = 0.
+ gep_pmissx = 0.
+ gep_pmissy = 0.
+ gep_pmissz = 0.
+ gep_pmiss = 0.
+ gep_w2 = 0.
+ gep_mmiss = 0.
+
+ gep_bx_expect_H = 0.
+ gep_by_expect_H = 0.
+ gep_etheta_expect_H = 0.
+ gep_ephi_expect_h = 0.
+
+ do i=1,8
+ gep_ntrigs(i)=0
+ do j=1,10
+ gep_trigtimes(i,j)=0.
+ enddo
+ enddo
+
+ return
+ end
diff --git a/ENGINE/gep_tree_init.f b/ENGINE/gep_tree_init.f
new file mode 100644
index 0000000..e783fc1
--- /dev/null
+++ b/ENGINE/gep_tree_init.f
@@ -0,0 +1,31 @@
+ subroutine gep_tree_init(abort,err)
+
+ implicit none
+ save
+
+ character*13 here
+ parameter(here='gep_tree_init')
+
+ include 'gep_filenames.cmn'
+ include 'gen_routines.dec'
+ include 'gep_data_structures.cmn'
+ include 'gen_run_info.cmn'
+c include 'b_ntuple.dte'
+
+ logical abort
+ character*(*) err
+
+c only purpose of this routine is to substitute run number in
+c tree filename! CTP will take care of the rest!!!!!!!!!!!
+
+ call no_nulls(gep_tree_filename)
+
+ if(gep_tree_filename.eq.' ') return
+
+ call g_sub_run_number(gep_tree_filename,gen_run_number)
+
+ abort=.false.
+ err=' '
+
+ return
+ end
diff --git a/ENGINE/h_apply_offsets.f b/ENGINE/h_apply_offsets.f
new file mode 100644
index 0000000..b39b8c8
--- /dev/null
+++ b/ENGINE/h_apply_offsets.f
@@ -0,0 +1,72 @@
+ SUBROUTINE H_apply_offsets(ABORT,err)
+*--------------------------------------------------------
+*- Prototype C analysis routine
+*-
+*-
+*- Purpose and Methods : applies offsets to HMS
+*- central momentum and central angle.
+*-
+*-
+*- Output: ABORT - success or failure
+*- : err - reason for failure, if any
+*-
+*- Created 31-Aug-1999 Chris Armstrong
+*-
+*-
+*- All standards are from "Proposal for Hall C Analysis Software
+*- Vade Mecum, Draft 1.0" by D.F.Geesamn and S.Wood, 7 May 1993
+*-
+*-
+*--------------------------------------------------------
+ IMPLICIT NONE
+ SAVE
+*
+ character*15 here
+ parameter (here= 'H_apply_offsets')
+
+ logical ABORT
+ character*(*) err
+*
+ INCLUDE 'hms_data_structures.cmn'
+ INCLUDE 'hms_physics_sing.cmn'
+ INCLUDE 'gen_constants.par'
+*
+*--------------------------------------------------------
+*
+
+ if (h_oopcentral_offset .ne. 0 ) then
+ write(*,*) ' ******'
+ write(6,*)' h_apply_offs: h_oopcentral_offset =',h_oopcentral_offset,' rad'
+ write(6,*)' Used to offset hsxp_tar in h_physics.f '
+ endif
+c
+ if (hpcentral_offset .ne. 0 ) then
+ write(*,*) ' ******'
+ write(6,*)' h_apply_offs: apply hpcentral_offset(%) =',hpcentral_offset
+ write(6,*)' h_apply_offs: before: hpcentral =',hpcentral
+ hpcentral = hpcentral * ( 1. + hpcentral_offset / 100. )
+ write(6,*)' h_apply_offs: after: hpcentral =',hpcentral
+ endif
+c
+ if ( hmomentum_factor .gt. 0.1 ) then
+ write(*,*) ' ******'
+ write(6,*)' h_apply_offs: apply hmomentum_factor =',hmomentum_factor
+ write(6,*)' h_apply_offs: before : hpcentral =',hpcentral
+ hpcentral = hpcentral * hmomentum_factor
+ write(6,*)' h_apply_offs: after : hpcentral =',hpcentral
+ endif
+c
+ if (hthetacentral_offset .ne. 0 ) then
+ write(*,*) ' ******'
+ write(6,*)' h_apply_offs: before: htheta_lab =',htheta_lab
+ htheta_lab=htheta_lab + hthetacentral_offset/degree
+ write(6,*)' h_apply_offs: after: htheta_lab =',htheta_lab
+ coshthetas = cos(htheta_lab*degree)
+ sinhthetas = sin(htheta_lab*degree)
+ endif
+c
+
+ ABORT= .FALSE.
+ err= ' '
+ RETURN
+ END
diff --git a/ENGINE/h_clear_event.f b/ENGINE/h_clear_event.f
new file mode 100644
index 0000000..52fb7ea
--- /dev/null
+++ b/ENGINE/h_clear_event.f
@@ -0,0 +1,196 @@
+ SUBROUTINE H_clear_event(ABORT,err)
+*--------------------------------------------------------
+*- Prototype C analysis routine
+*-
+*-
+*- Purpose and Methods : clears all HMS quantities before event is processed.
+*-
+*-
+*- Output: ABORT - success or failure
+*- : err - reason for failure, if any
+*-
+*- Created 29-Oct-1993 Kevin B. Beard
+*
+* $Log: h_clear_event.f,v $
+* Revision 1.15.24.2 2007/09/11 19:14:17 frw
+* fixed FPP related arrays and limits
+*
+* Revision 1.15.24.1 2007/08/22 19:09:16 frw
+* added FPP
+*
+* Revision 1.20 2004/04/26 19:53:33 frw
+* inserted FPP items
+*
+* Revision 1.15 2002/12/20 21:55:23 jones
+* Modified by Hamlet for new HMS aerogel
+*
+* Revision 1.15 2002/09/26
+* (Hamlet) Add clear of HMS Aerogel
+*
+* Revision 1.14 1999/02/23 18:25:15 csa
+* Add call to h_ntuple_clear
+*
+* Revision 1.13 1996/01/16 17:05:05 cdaq
+* no change
+*
+* Revision 1.12 1995/10/09 18:07:59 cdaq
+* (JRA) Add clear of HCER_RAW_ADC
+*
+* Revision 1.11 1995/09/01 13:36:45 cdaq
+* (JRA) Clear some cerenkov variables
+*
+* Revision 1.10 1995/05/22 20:50:46 cdaq
+* (SAW) Split gen_data_data_structures into gen, hms, sos, and coin parts"
+*
+* Revision 1.9 1995/03/13 18:12:46 cdaq
+* (SAW) Include file ordering
+*
+* Revision 1.8 1994/10/11 20:27:35 cdaq
+* (JRA) Include additional common blocks
+*
+* Revision 1.7 1994/09/20 17:29:41 cdaq
+* (SAW) Add include of hms_tracking.cmn
+*
+* Revision 1.6 1994/07/07 21:16:57 cdaq
+* (JRA) Clear additional variables
+*
+* Revision 1.5 1994/06/28 20:05:20 cdaq
+* (SAW) Add clear of hscin_all_tot_hits
+*
+* Revision 1.4 1994/06/22 20:53:21 cdaq
+* (SAW) zero the miscleaneous hits counter
+*
+* Revision 1.3 1994/03/01 20:14:24 cdaq
+* (SAW) Add zeroing of the raw total hits counter for the drift chambers
+*
+* Revision 1.2 1994/02/22 19:04:58 cdaq
+* (SAW) HNUM_DC_PLANES -> HMAX_NUM_DC_PLANES
+*
+* Revision 1.1 1994/02/04 22:14:24 cdaq
+* Initial revision
+*
+*-
+*-
+*- All standards are from "Proposal for Hall C Analysis Software
+*- Vade Mecum, Draft 1.0" by D.F.Geesamn and S.Wood, 7 May 1993
+*-
+*-
+*--------------------------------------------------------
+ IMPLICIT NONE
+ SAVE
+*
+ character*13 here
+ parameter (here= 'H_clear_event')
+*
+ logical ABORT
+ character*(*) err
+*
+ INCLUDE 'hms_data_structures.cmn'
+ INCLUDE 'hms_tracking.cmn'
+ INCLUDE 'hms_statistics.cmn'
+ INCLUDE 'hms_scin_parms.cmn'
+ INCLUDE 'hms_scin_tof.cmn'
+ INCLUDE 'hms_cer_parms.cmn'
+ INCLUDE 'hms_calorimeter.cmn'
+ include 'gen_detectorids.par'
+ include 'gen_decode_common.cmn'
+ INCLUDE 'hms_fpp_event.cmn'
+
+*
+ INTEGER plane,tube
+ integer*4 iSet, iChamber, iLayer, iPlane, iHit, i
+*
+*--------------------------------------------------------
+*
+ HDC_RAW_TOT_HITS = 0
+*
+ HDC_TOT_HITS= 0
+*
+ DO plane= 1,HMAX_NUM_DC_PLANES
+ HDC_HITS_PER_PLANE(plane)= 0
+ ENDDO
+*
+ HSCIN_ALL_TOT_HITS = 0
+ HSCIN_TOT_HITS = 0
+*
+ DO plane=1,HNUM_SCIN_PLANES
+ HSCIN_HITS_PER_PLANE(plane) = 0
+ ENDDO
+*
+* HMS CALORIMETER HITS
+*
+ HCAL_TOT_HITS= 0
+*
+ HCAL_NUM_HITS= 0
+*
+* HMS CERENKOV HITS
+*
+ HCER_TOT_HITS= 0
+ do tube = 1, HMAX_CER_HITS
+ HCER_RAW_ADC(tube) = 0
+ HCER_ADC(tube) = 0
+ HCER_NPE(tube) = 0.
+ enddo
+
+*
+* HMS AEROGEL HITS
+*
+ HAERO_TOT_HITS = 0
+
+*
+* HMS Miscleaneous hits
+*
+ HMISC_TOT_HITS = 0
+*
+* HMS DETECTOR TRACK QUANTITIES
+*
+ HNTRACKS_FP= 0
+*
+* HMS TARGET QUANTITIES
+*
+ HNTRACKS_TAR= 0
+*
+ HSNUM_FPTRACK = 0
+ HSNUM_TARTRACK = 0
+*
+
+* FPP items
+*
+* * total number of raw TDC hits in the FPP DCs
+ hfpp_raw_tot_hits = 0
+
+* * overall event descriptor for HMS FPP
+ HFPP_eventclass = H_FPP_ET_NOHITS
+
+cfrw -- should not be needed!!
+cfrw * * drift times for all hits
+cfrw do iHit=1, H_FPP_MAX_RAWHITS
+cfrw HFPP_HitTime(iHit) = 0.0
+cfrw enddo
+
+* * number of raw hits in each plane
+ do iPlane=1, H_FPP_N_PLANES
+ HFPP_N_planehitsraw(iPlane) = 0
+ HFPP_N_planehits(iPlane) = 0
+ enddo !iplane
+
+* * number of hit clusters in each plane
+* * HFPP_nClusters(iSet,iChamber,iLayer) is positively inited in h_trans_fpp
+
+* * number of tracks in each set of DCs
+ do iSet=1, H_FPP_N_DCSETS
+ hfpp_N_tracks(iSet) = 0
+ enddo !iSet
+
+* * FPP F1 trigger time references
+ do i=0,G_DECODE_MAXROCS
+ HFPP_trigger_TDC(i) = -1
+ enddo
+
+
+ call h_ntuple_clear
+
+ ABORT= .FALSE.
+ err= ' '
+ RETURN
+ END
diff --git a/ENGINE/h_field03.f b/ENGINE/h_field03.f
new file mode 100644
index 0000000..ffb8fdc
--- /dev/null
+++ b/ENGINE/h_field03.f
@@ -0,0 +1,162 @@
+c++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+c Field
+c Calculate the magnet settings for the HMS at a given momentum.
+c Field knows about the quadrupole tune, and the saturation effects
+c in all the magnets.
+c++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+ subroutine h_field03(P_HMS,I_Q1,I_Q2,I_Q3,I_D,B_D)
+
+c--------------------------------------------------------------------------
+c History:
+c
+c S A Wood 5-Jun-2003
+c The momentum can now be passed on the command line for use by
+c programs that want to call this. The output will be a single
+c line with the currents for the quads and the field for the
+c separated by ,'s.
+c
+c M K Jones 27-Mar-2003
+c Eric Christy's found that the central momentum of the
+c spectrometer was being set to low by 0.003 . Introduce new
+c norm factor : bnorm_03 = -0.003
+c Now
+c I_Q1 = I_Q1 * renorm_D / renorm_mom/(1+bnorm_03)
+c I_Q2 = I_Q2 * renorm_D / renorm_mom/(1+bnorm_03)
+c I_Q3 = I_Q3 * renorm_D / renorm_mom/(1+bnorm_03)
+c B_D = B_D / renorm_mom/(1+bnorm_03)
+c
+c
+c
+c Antje Bruell 12-Jul-2000
+c Modify Q3 set currents to obtain the correct readback currents
+c (fitting Iset(readback)/P from D. Pottervelds note 16768 and
+c renormalising at p=0.93)
+c I_Q3 = I_Q3 / (1.0107*(1.004-0.0136*p_HMS)))
+c
+c David Potterveld 26-Feb-1999 Old version had incorrect conversion to
+c gauss from tesla for the dipole. We want tesla anyways, so I removed
+c the units conversion.
+c
+c David McKee 8Feb1999
+c Add the golden tune parameters from Jochen's file.
+c
+c David McKee 22Jan1999
+c Added the dipole parameterization in function Bneedd. Made the quadrupole
+c paraeterization function Ineedq. I'll keep both ``need'' functions in
+c the same file.
+c
+c David McKee 20Jan1999
+c Changed the form of the fit to reflect the hysterisis effects and
+c the golden tune as per Jochen's version.
+c Why did Rolf give me the one without it?
+c
+c Also move the calculation of I(bl_q[1-3]) into a function.
+c
+c David McKee 3Sept1998
+c Hacked from Jochen's version to work like the printout that Rolf gave me
+c Comented and cleaned up.
+c---------------------------------------------------------------------------
+ implicit none
+
+ real*8 befl_q1, befl_q2, befl_q3 ! See note below
+ real*8 golden1, golden2, golden3
+ real*8 futch_q3
+ real*8 renorm_D, renorm_mom
+ real*8 P_HMS,sign_HMS
+ real*8 bl_q1, bl_q2, bl_q3 ! Int{B dot dL} for each quad.
+ real*8 I_Q1, I_Q2, I_Q3 ! Currents in the quads.
+ real*8 B_D ! Field in the dipole.
+ real*8 I_D ! Current in the dipole.
+
+ real*8 Bneedd, Ineedq
+ real*8 bnorm_03
+
+ integer iargc
+ integer iargcount
+ character*30 arg
+
+c These three numbers reflect the quadrupole tune.
+c They are the desired B.dl for each magnet at a nominal momentum
+c setting of 6.0 GeV. Mess with them at your peril.
+
+c HMS100 tune (from Jochen's version)
+ data befl_q1/2.6571/
+ data befl_q2/3.3233/
+ data befl_q3/1.6324/
+ data golden1/1.010/
+ data golden2/1.005/
+ data golden3/1.010/
+
+
+c HMS-1? tune
+c data befl_q1/2.8858/
+c data befl_q2/3.4212/
+c data befl_q3/1.7298/
+c data golden1/1.0/
+c data golden2/1.0/
+c data golden3/1.0/
+
+
+c The rest of these constants are historical. I don't necessarily know where
+c the came from, and I'm not going to mess with them. DWM
+c Some find of (Dutch(?)) fudge factor. 1.0 is nominal.
+c Imperical value based on Dec '94 run
+c data futch_q3/0.983/
+ data futch_q3/1.000/
+
+c Renormalization of currents since we set the Dipole by the NMR now.
+ data renorm_D/0.985/
+c data renorm_D/1.000/
+
+c Empirical renormalization of central momentum
+ data renorm_mom/1.009/
+c mkj determination by Eric Christy of new normalization 2003.
+c this is a correction to the nromalizations above.
+ data bnorm_03 /-0.003/
+
+c---------------------------------------------------------------------------
+c Finally, the code...
+
+ iargcount = 1!iargc()
+
+c Prompt the user for the momentum,
+c then seperate the sign from the magnitude...
+
+ sign_HMS = P_HMS/abs(P_HMS)
+ P_HMS = abs(P_HMS)
+
+c The B.dl we desire is liearly related to the momentum, the befl_q[1-3]s
+c are normalized to 6 GeV
+ bl_q1=befl_q1*P_HMS/6.*golden1
+ bl_q2=befl_q2*P_HMS/6.*golden2
+ bl_q3=befl_q3*P_HMS/6.*golden3
+
+c Calculate the needed current.
+ I_Q1 = Ineedq(bl_q1,1)
+ I_Q2 = Ineedq(bl_q2,2)
+ I_Q3 = Ineedq(bl_q3,3)
+ B_D = Bneedd(P_HMS,iargcount)
+c Apply the dipole and central momentum normalizations...
+ I_Q1 = I_Q1 * renorm_D / renorm_mom/(1+bnorm_03)
+ I_Q2 = I_Q2 * renorm_D / renorm_mom/(1+bnorm_03)
+ I_Q3 = I_Q3 * renorm_D / renorm_mom/(1+bnorm_03)
+ B_D = B_D / renorm_mom/(1+bnorm_03)
+
+c For Q3 use readback current instead of setcurrent
+c i.e. renormalise by ratio of readback/set current
+ I_Q3 = I_Q3 / (1.0107*(1.004-0.0136/P_HMS))
+
+c Added 19 April 2003 by Joerg Reinhold
+c For the Dipole calculate s start value for the set current
+ I_D = 1105.7*B_D+13.192*B_D*B_D
+
+ end
+
+
+
+
+
+
+
+
+
diff --git a/ENGINE/h_fieldcorr.f b/ENGINE/h_fieldcorr.f
new file mode 100644
index 0000000..d490f3c
--- /dev/null
+++ b/ENGINE/h_fieldcorr.f
@@ -0,0 +1,87 @@
+ SUBROUTINE H_FIELDCORR(ABORT,err)
+*--------------------------------------------------------
+*-
+*- Purpose and Methods : Correct hpcentral from wrong saturation
+*- calculation in fieldXX.f
+*-
+*-
+*- Required Input BANKS HMS_FOCAL_PLANE
+*- HMS_TARGET
+*-
+*- Output BANKS HMS_PHYSICS_R4
+*- HMS_PHYSICS_I4
+*-
+*- Output: ABORT - success or failure
+*- : err - reason for failure, if any
+*-
+*-
+*- crated: Fri Aug 18 11:48:29 EDT 2000 B. Zihlmann
+*- from h_satcorr.f but do correction to hpcentral
+*- and the call needs to be done at begining of
+*- run only (not event-by-event).
+*-
+*-
+* $Log: h_fieldcorr.f,v $
+* Revision 1.2 2003/02/21 14:55:26 jones
+* Added write statements
+*
+* Revision 1.1 2002/09/24 20:11:24 jones
+* h_fieldcorr.f corrects hpcentral when genable_hms_fieldcorr.eq.0
+* and hpcentral > 3.5573 GeV/c . Correction needs to be applied
+* for experiments which used fieldxx.f before field02.f
+*
+*
+*-
+*-
+*--------------------------------------------------------
+ IMPLICIT NONE
+ SAVE
+*
+ character*9 here
+ parameter (here= 'h_fieldcorr')
+*
+ logical ABORT
+ character*(*) err
+ integer ierr
+*
+ include 'gen_data_structures.cmn'
+ INCLUDE 'hms_data_structures.cmn'
+ INCLUDE 'gen_constants.par'
+ INCLUDE 'gen_units.par'
+*
+* local variables
+*
+ REAL*4 p0corr
+
+*--------------------------------------------------------
+*
+
+ ierr=0
+ ABORT=.FALSE.
+
+ p0corr=0.
+
+ if(genable_hms_fieldcorr.eq.0) then
+ write(*,*) ' ******'
+ write(*,*) ' HMS field correction applied when hpcentral > 3.5573 '
+ write(*,*) ' Should be enabled for data taken before Jan 1 2002'
+ if (hpcentral.gt.3.5573) then
+ p0corr= 1.0 + 1.0755e-3*
+ > ((hpcentral-3.5573)**2)
+
+ hpcentral = hpcentral*p0corr
+
+ endif
+ else
+ write(*,*) ' ******'
+ write(*,*) ' HMS field correction not applied '
+ write(*,*) ' Should be enabled for data taken before Jan 1 2002'
+ endif
+
+ ABORT= ierr.ne.0 .or. ABORT
+
+ return
+ end
+
+
+
diff --git a/ENGINE/h_fpp_nt_change.f b/ENGINE/h_fpp_nt_change.f
new file mode 100644
index 0000000..7ab5e47
--- /dev/null
+++ b/ENGINE/h_fpp_nt_change.f
@@ -0,0 +1,87 @@
+ subroutine h_fpp_nt_change(ABORT,err)
+*----------------------------------------------------------------------
+*
+* closes one HMS FPP Ntuple file and opens another
+*
+* Purpose : switching from one file to the next
+*
+* Output: ABORT - success or failure
+* : err - reason for failure, if any
+*
+*----------------------------------------------------------------------
+
+ implicit none
+ save
+
+ character*15 here
+ parameter (here='h_fpp_nt_change')
+
+ logical ABORT
+ character*(*) err
+
+ INCLUDE 'h_fpp_ntuple.cmn'
+ include 'gen_run_info.cmn'
+
+ character*1 ifile
+ character*80 file
+ character*1000 pat
+
+ integer*4 ilo,fn_len
+
+* functions
+ integer g_important_length
+
+*--------------------------------------------------------
+
+
+ call h_fpp_nt_close(ABORT,err)
+
+
+
+ if (h_fpp_nt_exists) then
+ ABORT = .true.
+ endif
+
+ call NO_nulls(h_fpp_nt_file) !replace null characters with blanks
+
+ file= h_fpp_nt_file
+ call NO_nulls(file) !replace null characters with blanks
+ call g_sub_run_number(file,gen_run_number)
+
+ h_fpp_nt_filesegments = h_fpp_nt_filesegments + 1
+
+ if (h_fpp_nt_filesegments .le. 9) then
+ ifile = char(ichar('0')+h_fpp_nt_filesegments)
+ else
+ ifile = char(ichar('a')+h_fpp_nt_filesegments-10)
+ endif
+
+ fn_len = g_important_length(file)
+ ilo=index(file,'.hbook')
+ if ((ilo.le.1).or.(ilo.gt.fn_len-5)) then
+ ilo=index(file,'.rzdat')
+ endif
+
+ if ((ilo.gt.1).and.(ilo.lt.fn_len)) then
+ file = file(1:ilo-1) // '.' // ifile // file(ilo:fn_len)
+ else
+ ABORT = .true.
+ endif
+
+
+
+ IF (.not.ABORT) call h_fpp_nt_open(file,ABORT,err)
+
+
+ IF(ABORT) THEN
+ err= ':unable to change HMS FPP Ntuple file segment'
+ call G_add_path(here,err)
+ ELSE
+ pat= ':changed HMS FPP Ntuple file segment'
+ call G_add_path(here,pat)
+ call G_log_message('INFO: '//pat)
+ ENDIF
+
+
+ RETURN
+ END
diff --git a/ENGINE/h_fpp_nt_close.f b/ENGINE/h_fpp_nt_close.f
new file mode 100644
index 0000000..a8d7456
--- /dev/null
+++ b/ENGINE/h_fpp_nt_close.f
@@ -0,0 +1,77 @@
+ subroutine h_fpp_nt_close(ABORT,err)
+*----------------------------------------------------------------------
+*
+* closes the HMS FPP Ntuple file
+*
+* Purpose : Flushes and closes the HMS FPP Ntuple
+*
+* Output: ABORT - success or failure
+* : err - reason for failure, if any
+*
+*----------------------------------------------------------------------
+
+ implicit none
+ save
+
+ character*14 here
+ parameter (here='h_fpp_nt_close')
+
+ logical ABORT
+ character*(*) err
+*
+ INCLUDE 'h_fpp_ntuple.cmn'
+ INCLUDE 'gen_routines.dec'
+*
+ logical HEXIST !CERNLIB function
+*
+ logical FAIL
+ character*80 why,directory,name
+ character*1000 msg
+ integer io,id,cycle,m
+*
+*--------------------------------------------------------
+
+ err= ' '
+ ABORT = .FALSE.
+
+ IF(.NOT.h_fpp_nt_exists) RETURN !nothing to do
+
+ call HCDIR(directory,'R') !keep current directory
+
+ id= h_fpp_nt_ID
+ io= h_fpp_nt_IOchannel
+ name= h_fpp_nt_name
+
+ ABORT= .NOT.HEXIST(id)
+ IF(ABORT) THEN
+ call G_add_path(here,err)
+ If(io.GT.0) Then
+ call G_IO_control(io,'FREE',FAIL,why) !free up
+ if(.NOT.FAIL) CLOSE(io)
+ EndIf
+ h_fpp_nt_exists= .FALSE.
+ h_fpp_nt_IOchannel= 0
+ RETURN
+ ENDIF
+
+ call HCDIR(h_fpp_nt_directory,' ') !goto Ntuple directory
+
+ call G_add_path(here,msg)
+ call G_log_message('INFO: '//msg)
+
+ cycle= 0 !dummy for HROUT
+ call HROUT(id,cycle,' ') !flush CERNLIB buffers
+ call HREND(name) !CERNLIB close file
+ call G_IO_control(io,'FREE',ABORT,err) !free up IO channel
+ CLOSE(io) !close IO channel
+
+ call HCDIR(directory,' ') !return to current directory
+
+ h_fpp_nt_directory= ' '
+ h_fpp_nt_exists= .FALSE.
+ h_fpp_nt_IOchannel= 0
+
+ IF(ABORT) call G_add_path(here,err)
+
+ RETURN
+ END
diff --git a/ENGINE/h_fpp_nt_init.f b/ENGINE/h_fpp_nt_init.f
new file mode 100644
index 0000000..7283c8d
--- /dev/null
+++ b/ENGINE/h_fpp_nt_init.f
@@ -0,0 +1,101 @@
+ subroutine h_fpp_nt_init(ABORT,err)
+*----------------------------------------------------------------------
+*
+* Creates an HMS FPP Ntuple
+*
+* Purpose : Books an HMS FPP Ntuple; defines structure of it
+*
+* Output: ABORT - success or failure
+* : err - reason for failure, if any
+*
+*----------------------------------------------------------------------
+ implicit none
+ save
+*
+ character*13 here
+ parameter (here='h_fpp_nt_init')
+*
+ logical ABORT
+ character*(*) err
+*
+ INCLUDE 'h_fpp_ntuple.cmn'
+ INCLUDE 'gen_routines.dec'
+ include 'hms_data_structures.cmn'
+ include 'gen_run_info.cmn'
+*
+ character*80 default_name
+ parameter (default_name= 'hFPPntuple')
+c
+ character*80 file
+ character*80 name
+ character*1000 pat,msg
+ integerilo,fn_len,m
+ character*1 ifile
+
+ INCLUDE 'h_fpp_ntuple.dte'
+*
+*--------------------------------------------------------
+ err= ' '
+ ABORT = .FALSE.
+*
+ IF(h_fpp_nt_exists) THEN
+ call h_fpp_nt_shutdown(ABORT,err)
+ If(ABORT) Then
+ call G_add_path(here,err)
+ RETURN
+ EndIf
+ ENDIF
+*
+ call NO_nulls(h_fpp_nt_file) !replace null characters with blanks
+*
+*-if name blank, just forget it
+ IF(h_fpp_nt_file.EQ.' ') RETURN !do nothing
+
+ h_fpp_nt_ID= default_h_fpp_nt_ID
+ h_fpp_nt_name= default_name
+
+ IF(h_fpp_nt_title.EQ.' ') THEN
+ msg= name//' '//h_fpp_nt_file
+ call only_one_blank(msg)
+ h_fpp_nt_title= msg
+ ENDIF
+
+ file= h_fpp_nt_file
+ call g_sub_run_number(file,gen_run_number)
+
+* * only needed if using more than one file
+ if (HFPP_nt_max_segmentevents .gt. 0) then
+ h_fpp_nt_filesegments = 1
+
+ ifile = char(ichar('0')+h_fpp_nt_filesegments)
+
+ fn_len = g_important_length(file)
+ ilo=index(file,'.hbook')
+ if ((ilo.le.1).or.(ilo.gt.fn_len-5)) then
+ ilo=index(file,'.rzdat')
+ endif
+
+ if ((ilo.gt.1).and.(ilo.lt.fn_len)) then
+ file = file(1:ilo-1) // '.' // ifile // file(ilo:fn_len)
+ else
+ ABORT = .true.
+ RETURN
+ endif
+ write(*,*) ' Using segmented hms FPP rzdat files first filename: ',file
+ else
+ write(*,*) ' Not using segmented hms FPP rzdat files.'
+ endif
+
+ call h_fpp_nt_open(file,ABORT,err)
+
+ IF(ABORT) THEN
+ err= ':unable to create HMS FPP Ntuple'
+ call G_add_path(here,err)
+ ELSE
+ pat= ':created HMS FPP Ntuple'
+ call G_add_path(here,pat)
+ call G_log_message('INFO: '//pat)
+ ENDIF
+
+ RETURN
+ END
diff --git a/ENGINE/h_fpp_nt_keep.f b/ENGINE/h_fpp_nt_keep.f
new file mode 100644
index 0000000..f7bdf0e
--- /dev/null
+++ b/ENGINE/h_fpp_nt_keep.f
@@ -0,0 +1,199 @@
+ subroutine h_fpp_nt_keep(ABORT,err)
+*----------------------------------------------------------------------
+*
+* Purpose : Add entry to the HMS FPP Ntuple
+*
+* Output: ABORT - success or failure
+* : err - reason for failure, if any
+*
+*----------------------------------------------------------------------
+ implicit none
+ save
+*
+ character*13 here
+ parameter (here='h_fpp_nt_keep')
+*
+ logical ABORT
+ character*(*) err
+*
+ INCLUDE 'gen_data_structures.cmn'
+ INCLUDE 'gen_event_info.cmn'
+ INCLUDE 'hms_data_structures.cmn'
+ INCLUDE 'hms_physics_sing.cmn'
+ include 'gen_detectorids.par'
+ include 'gen_decode_common.cmn'
+ INCLUDE 'hms_fpp_event.cmn'
+ INCLUDE 'hms_fpp_params.cmn'
+ INCLUDE 'h_fpp_ntuple.cmn'
+
+ INCLUDE 'h_fpp_ntup.cwn'
+*
+ logical HEXIST !CERNLIB function
+*
+ integer iSet,iTrk,iCham,iLay,iWire,cluster
+ integer iHit,iRaw
+ integer n
+*
+*--------------------------------------------------------
+ err= ' '
+ ABORT = .FALSE.
+*
+c write(*,*)'In h_fp_nt_keep ...',h_fpp_nt_exists
+
+ IF(.NOT.h_fpp_nt_exists) RETURN !nothing to do
+
+c write(*,*)'Segments: ',h_fpp_nt_segmentevents,HFPP_nt_max_segmentevents
+ if (HFPP_nt_max_segmentevents .gt. 0) then
+ if (h_fpp_nt_segmentevents .gt. HFPP_nt_max_segmentevents) then
+ call h_fpp_nt_change(ABORT,err)
+ else
+ h_fpp_nt_segmentevents = h_fpp_nt_segmentevents +1
+ endif
+ endif
+*
+************************************************
+
+ cwnFPP_eventID = gen_event_ID_number
+ if(HFPP_eventclass.gt.63)HFPP_eventclass=63
+ cwnFPP_evtcode = HFPP_eventclass
+ cwnFPP_helicite = gbeam_helicity
+
+
+******* standard HMS info
+c write(*,*)HSDELTA,HSTHETA,HSPHI,HINVMASS
+c WRITE(*,*)HSZBEAM,HSX_FP,HSY_FP,HSXP_FP,HSYP_FP
+c write(*,*)'Beam helicity = ',gbeam_helicity_TS,gbeam_helicity
+ cwnFPP_hsdelta = HSDELTA
+ cwnFPP_hstheta = HSTHETA
+ cwnFPP_hsphi = HSPHI
+ cwnFPP_w = HINVMASS
+ cwnFPP_hszbeam = HSZBEAM
+ cwnFPP_hsxfp = HSX_FP
+ cwnFPP_hsyfp = HSY_FP
+ cwnFPP_hsxpfp = HSXP_FP
+ cwnFPP_hsypfp = HSYP_FP
+ cwnFPP_hsytar = HSY_TAR
+ cwnFPP_hsxptar = HSXP_TAR
+ cwnFPP_hsyptar = HSYP_TAR
+
+******* global FPP info
+c WRITE(*,*)HFPP_TRIGGER_TDC(1)
+c WRITE(*,*)HFPP_TRIGGER_TDC(2)
+c WRITE(*,*)HFPP_RAW_TOT_HITS
+ cwnFPP_trig_TDC1 = HFPP_trigger_TDC(1)
+ cwnFPP_trig_TDC2 = HFPP_trigger_TDC(2)
+
+ cwnFPP_RawHits = HFPP_raw_tot_hits
+
+
+******* FPP hits
+
+ n = 0
+ do iSet=1,2 ! Upstream & downstream polarimeter
+ do iCham=1, H_FPP_N_DCINSET ! record all 1st hits on all wires (=all cluster hits)
+ do iLay=1, H_FPP_N_DCLAYERS
+
+ do cluster=1,HFPP_nClusters(iSet,iCham,iLay)
+ iTrk = HFPP_ClusterinTrack(iSet,iCham,iLay,cluster)
+ do iHit=1,HFPP_nHitsinCluster(iSet,iCham,iLay,cluster)
+ n = min(n+1,MAX_cwn_goodhits)
+c write(*,*)iSet,iCham,iLay,cluster,iHit,n
+ iRaw = HFPP_Clusters(iSet,iCham,iLay,cluster,iHit)
+ iWire = HFPP_raw_wire(iRaw)
+c write(*,*)iraw
+c write(*,*)iSet,HFPP_raw_plane(iRaw),HFPP_raw_wire(iRaw),
+c > HFPP_HitTime(iRaw)
+ cwnFPP_Hit1_pol(n) = iSet
+ cwnFPP_Hit1_layer(n) = HFPP_raw_plane(iRaw)
+ cwnFPP_Hit1_wire(n) = iWire
+ cwnFPP_Hit1_d_HMS(n) = HFPP_dHMS(iSet,iCham,iLay,cluster,iHit)
+cBAD! cwnFPP_Hit1_time(n) = HFPP_HitTime(iRaw)
+ if (iTrk.le.0) then
+ cwnFPP_Hit1_itrack(n) = 0
+ cwnFPP_Hit1_time(n) = H_FPP_BAD_TIME
+ cwnFPP_Hit1_drift(n) = H_FPP_BAD_DRIFT
+ cwnFPP_Hit1_resid(n) = H_FPP_BAD_DRIFT
+ else
+c write(*,*)iTrk,
+c > HFPP_drift_dist(iSet,iCham,iLay,iWire),
+c > HFPP_track_residual(iSet,iCham,iLay,iTrk)
+ cwnFPP_Hit1_itrack(n) = iTrk
+ cwnFPP_Hit1_time(n) = HFPP_drift_time(iSet,iCham,iLay,iWire)
+ cwnFPP_Hit1_drift(n) = HFPP_drift_dist(iSet,iCham,iLay,iWire)
+ cwnFPP_Hit1_resid(n) = HFPP_track_residual(iSet,iCham,iLay,iTrk)
+ endif
+ enddo !iHit
+ enddo !cluster
+
+ enddo !iLay
+ enddo !iCham
+ enddo !iSet
+ cwnFPP_Nhits1 = n
+
+
+******* FPP tracks
+
+ n=0
+ do iSet=1,2 ! Upstream & downstream polarimeter
+ do iTrk=1,HFPP_N_tracks(iSet)
+c write(*,*)iSet,iTrk,HFPP_N_tracks(iSet)
+c write(*,*)iSet,iTrk
+c write(*,*)HFPP_track_Nlayers(iSet,iTrk)
+c write(*,*)HFPP_track_rough(iSet,iTrk,1),
+c > HFPP_track_rough(iSet,iTrk,2),
+c > HFPP_track_rough(iSet,iTrk,3),
+c > HFPP_track_rough(iSet,iTrk,4)
+c write(*,*)HFPP_track_dx(iSet,iTrk),
+c > HFPP_track_x(iSet,iTrk),
+c > HFPP_track_dy(iSet,iTrk),
+c > HFPP_track_y(iSet,iTrk)
+c write(*,*)HFPP_track_chi2(iSet,iTrk),
+c > HFPP_track_zclose(iSet,iTrk),
+c > HFPP_track_sclose(iSet,iTrk)
+c write(*,*)HFPP_track_theta(iSet,iTrk),
+c > HFPP_track_phi(iSet,iTrk)
+ n=n+1
+ cwnFPP_trk_pol(n) = iSet
+ cwnFPP_trk_num(n) = iTrk
+
+ cwnFPP_trk_hits(n) = HFPP_track_Nlayers(iSet,iTrk) ! # of layers w/hit on track
+
+ cwnFPP_simple_mx(n) = HFPP_track_rough(iSet,iTrk,1) ! simple (=no drift) track
+ cwnFPP_simple_bx(n) = HFPP_track_rough(iSet,iTrk,2)
+ cwnFPP_simple_my(n) = HFPP_track_rough(iSet,iTrk,3)
+ cwnFPP_simple_by(n) = HFPP_track_rough(iSet,iTrk,4)
+
+ cwnFPP_full_mx(n) = HFPP_track_dx(iSet,iTrk) ! track w/ drift
+ cwnFPP_full_bx(n) = HFPP_track_x(iSet,iTrk)
+ cwnFPP_full_my(n) = HFPP_track_dy(iSet,iTrk)
+ cwnFPP_full_by(n) = HFPP_track_y(iSet,iTrk)
+
+ cwnFPP_chi2(n) = HFPP_track_chi2(iSet,iTrk)
+
+ cwnFPP_zclose(n) = HFPP_track_zclose(iSet,iTrk)
+ cwnFPP_sclose(n) = HFPP_track_sclose(iSet,iTrk)
+ cwnFPP_conetest(n) = HFPP_track_conetest(iSet,iTrk)
+
+ cwnFPP_theta(n) = HFPP_track_theta(iSet,iTrk)
+ cwnFPP_phi(n) = HFPP_track_phi(iSet,iTrk)
+
+cfrw print *,gen_event_ID_number,n,iSet,cwnFPP_full_mx(n),cwnFPP_full_bx(n),cwnFPP_full_my(n),cwnFPP_full_by(n)
+
+ enddo !iTrk
+ enddo !iSet
+ cwnFPP_Ntracks = n
+
+
+************************************************
+* Fill ntuple for this event
+ ABORT= .NOT.HEXIST(h_fpp_nt_ID)
+ IF(ABORT) THEN
+ call G_build_note(':Ntuple ID#$ does not exist',
+ & '$',h_fpp_nt_ID,' ',0.,' ',err)
+ call G_add_path(here,err)
+ ELSE
+ call HFNT(h_fpp_nt_ID)
+ ENDIF
+*
+ RETURN
+ END
diff --git a/ENGINE/h_fpp_nt_open.f b/ENGINE/h_fpp_nt_open.f
new file mode 100644
index 0000000..b015f33
--- /dev/null
+++ b/ENGINE/h_fpp_nt_open.f
@@ -0,0 +1,206 @@
+ subroutine h_fpp_nt_open(file,ABORT,err)
+*----------------------------------------------------------------------
+*
+* Opens an HMS FPP Ntuple file
+*
+* Purpose : Books an HMS FPP Ntuple
+*
+* Output: ABORT - success or failure
+* : err - reason for failure, if any
+*
+*----------------------------------------------------------------------
+
+ implicit none
+ save
+
+ character*13 here
+ parameter (here='h_fpp_nt_open')
+ integer Nwpawc,h,nh
+ parameter (Nwpawc=150000)
+
+ logical ABORT
+ character*(*) err
+
+ INCLUDE 'gen_data_structures.cmn'
+ INCLUDE 'hms_data_structures.cmn'
+ INCLUDE 'h_fpp_ntuple.cmn'
+ include 'h_fpp_ntup.cwn'
+
+ integer iquest
+ common /PAWC/ h(Nwpawc)
+ common /QUEST/ iquest(100)
+
+ integer default_recL, default_bufS
+c parameter (default_recL= 8191) !record length
+c parameter (default_bufS= 8176) !record length
+ parameter (default_recL= 4096) !record length
+ parameter (default_bufS= 4096) !record length
+ character*80 title,file
+ character*80 directory,name
+ character*1000 pat,msg
+ integer status,size,io,id,recL,bufS,iv(10),m
+ real rv(10)
+
+ logical HEXIST !CERNLIB function
+
+*--------------------------------------------------------
+
+ err= ' '
+ ABORT = .FALSE.
+ IF(h_fpp_nt_exists) THEN
+ call h_fpp_nt_shutdown(ABORT,err)
+ If(ABORT) Then
+ call G_add_path(here,err)
+ RETURN
+ EndIf
+ ENDIF
+
+
+*- get any free IO channel
+
+ call g_IO_control(io,'ANY',ABORT,err)
+ h_fpp_nt_exists= .NOT.ABORT
+ IF(ABORT) THEN
+ call G_add_path(here,err)
+ RETURN
+ ENDIF
+ h_fpp_nt_IOchannel= io
+
+ id= h_fpp_nt_ID
+ name= h_fpp_nt_name
+ title= h_fpp_nt_title
+
+ ABORT= HEXIST(id)
+ IF(ABORT) THEN
+ call g_IO_control(h_fpp_nt_IOchannel,'FREE',ABORT,err)
+ call G_build_note(':HBOOK id#$ already in use',
+ & '$',id,' ',rv,' ',err)
+ call G_add_path(here,err)
+ RETURN
+ ENDIF
+
+ nh=Nwpawc
+c call HLIMIT(nh)
+
+ recL = default_recL
+ bufS = default_bufS
+ iquest(10) = 256000
+
+*-open New *.rzdat file-
+ CALL HCDIR(directory,'R') !CERNLIB read current directory
+ call HROPEN(io,name,file,'NQE',recL,status)
+
+ ABORT= status.NE.0
+ IF(ABORT) THEN
+ call g_IO_control(h_fpp_nt_IOchannel,'FREE',ABORT,err)
+ iv(1)= status
+ iv(2)= io
+ pat= ':HROPEN error#$ opening IO#$ "'//file//'"'
+ call G_build_note(pat,'$',iv,' ',rv,' ',err)
+ call G_add_path(here,err)
+ RETURN
+ ENDIF
+
+ call HBSET('BSIZE',bufS,status)
+ ABORT= status.NE.0
+ IF(ABORT) THEN
+ call g_IO_control(h_fpp_nt_IOchannel,'FREE',ABORT,err)
+ iv(1)= status
+ iv(2)= io
+ pat= ':HBSET error#$ allocating storage#$ "'//file//'"'
+ call G_build_note(pat,'$',iv,' ',rv,' ',err)
+ call G_add_path(here,err)
+ RETURN
+ ENDIF
+
+* Open COLUMNwise ntuple for variable number of entries
+ call HBNT(id,title,' ')
+ call HBNAME(id,' ',0,'$clear')
+
+
+* need to manually apply same ranges as defined for array limits!!
+* H_FPP_MAX_TRACKS=9
+* H_FPP_MAX_WIRES=104
+* max layers per chamber pair = 6
+* H_FPP_N_PLANES=12
+* H_FPP_MAX_RAWHITS=2400
+* MAX_cwn_goodhits= 100
+* max hit1/set = N chamb * N lay * max cluster/layer * max hit/cluster = 270
+
+ call HBNAME(id,'FPP1',cwnFPP_eventID,'eventID:U*4'
+ 1 //',evtcode[0,63]:U*4'
+ 1 //',helicite[-1,1]:I*4'
+ 1 //',hsdelta:R'
+ 1 //',hstheta:R'
+ 1 //',hsphi:R'
+ 1 //',w:R'
+ 1 //',hszbeam:R'
+ 1 //',hsxfp:R'
+ 1 //',hsyfp:R'
+ 1 //',hsxpfp:R'
+ 1 //',hsypfp:R'
+ 1 //',hsytar:R'
+ 1 //',hsxptar:R'
+ 1 //',hsyptar:R'
+ 1
+ 1 //',trig_TDC1:I*4'
+ 1 //',trig_TDC2:I*4'
+ 1
+ 1// ',RawHits[0,2400]:U*4'
+ 1
+ 1// ',Nhits1[0,100]:U*4'
+ 1// ',h1_Pol(Nhits1)[1,2]:U*4'
+ 1// ',h1_Layer(Nhits1)[0,12]:U*4'
+ 1// ',h1_Wire(Nhits1)[0,104]:U*4'
+ 1// ',h1_on_trk(Nhits1)[0,18]:U*4'
+ 1// ',h1_time(Nhits1):R'
+ 1// ',h1_drift(Nhits1):R'
+ 1// ',h1_resid(Nhits1):R'
+ 1// ',h1_d_HMS(Nhits1):R'
+ 1
+ 1// ',Ntrack[0,18]:U*4'
+ 1// ',Pol(Ntrack)[0,2]:U*4'
+ 1// ',trackNo(Ntrack)[0,9]:U*4'
+ 1// ',trk_hits(Ntrack)[0,6]:U*4'
+ 1// ',trk_conet(Ntrack):I*4'
+ 1// ',trk_s_xp(Ntrack):R'
+ 1// ',trk_s_x(Ntrack):R'
+ 1// ',trk_s_yp(Ntrack):R'
+ 1// ',trk_s_y(Ntrack):R'
+ 1// ',trk_f_xp(Ntrack):R'
+ 1// ',trk_f_x(Ntrack):R'
+ 1// ',trk_f_yp(Ntrack):R'
+ 1// ',trk_f_y(Ntrack):R'
+ 1// ',trk_chi2(Ntrack):R'
+ 1// ',trk_zclos(Ntrack):R'
+ 1// ',trk_sclos(Ntrack):R'
+ 1// ',trk_theta(Ntrack):R'
+ 1// ',trk_phi(Ntrack):R'
+ 1 )
+
+ call HCDIR(h_fpp_nt_directory,'R') !record Ntuple directory
+ CALL HCDIR(directory,' ') !reset CERNLIB directory
+
+ h_fpp_nt_exists= HEXIST(h_fpp_nt_ID)
+ ABORT= .NOT.h_fpp_nt_exists
+
+ iv(1)= id
+ iv(2)= io
+ pat= 'Ntuple id#$ [' // h_fpp_nt_directory // '/]' //
+ & name // ' IO#$ "' // file // '"'
+ call G_build_note(pat,'$',iv,' ',rv,' ',msg)
+ call sub_string(msg,' /]','/]')
+
+ IF(ABORT) THEN
+ err= ':unable to create '//msg
+ call G_add_path(here,err)
+ ELSE
+ pat= ':created '//msg
+ call G_add_path(here,pat)
+ call G_log_message('INFO: '//pat)
+ ENDIF
+
+ h_fpp_nt_segmentevents = 0
+
+ RETURN
+ END
diff --git a/ENGINE/h_fpp_nt_register.f b/ENGINE/h_fpp_nt_register.f
new file mode 100644
index 0000000..21e4c76
--- /dev/null
+++ b/ENGINE/h_fpp_nt_register.f
@@ -0,0 +1,38 @@
+ subroutine h_fpp_nt_register(ABORT,err)
+*----------------------------------------------------------------------
+*
+* CTP variable registration routine for the HMS FPP Ntuples
+*
+* Purpose : Register output filename for HMS FPP Ntuple; temporary
+* implementation to be superceeded by CTP Ntuples
+*
+* Output: ABORT - success or failure
+* : err - reason for failure, if any
+*
+*----------------------------------------------------------------------
+ implicit none
+ save
+*
+ character*17 here
+ parameter (here='h_fpp_nt_register')
+*
+ logical ABORT
+ character*(*) err
+*
+ INCLUDE 'h_fpp_ntuple.cmn'
+ INCLUDE 'gen_routines.dec'
+*
+ integer ierr
+*--------------------------------------------------------
+ err= ' '
+ ABORT = .FALSE.
+*
+ call G_reg_C('HMS_FPP_Ntuple',h_fpp_nt_file,ABORT,err)
+*
+ IF(ABORT) THEN
+ call G_prepend(':unable to register-',err)
+ call G_add_path(here,err)
+ ENDIF
+*
+ return
+ end
diff --git a/ENGINE/h_fpp_nt_shutdown.f b/ENGINE/h_fpp_nt_shutdown.f
new file mode 100644
index 0000000..6176e35
--- /dev/null
+++ b/ENGINE/h_fpp_nt_shutdown.f
@@ -0,0 +1,56 @@
+ subroutine h_fpp_nt_shutdown(ABORT,err)
+*----------------------------------------------------------------------
+*
+* Final shutdown of the HMS FPP Ntuple
+*
+* Purpose : Flushes and closes the HMS FPP Ntuple
+*
+* Output: ABORT - success or failure
+* : err - reason for failure, if any
+*
+*----------------------------------------------------------------------
+ implicit none
+ save
+*
+ character*17 here
+ parameter (here='h_fpp_nt_shutdown')
+*
+ logical ABORT
+ character*(*) err
+*
+ INCLUDE 'h_fpp_ntuple.cmn'
+ INCLUDE 'gen_routines.dec'
+*
+*
+ logical FAIL
+ character*80 why,directory,name
+ character*1000 msg
+ integer io,id,cycle,m
+*
+*--------------------------------------------------------
+ err= ' '
+ ABORT = .FALSE.
+*
+
+ IF(.NOT.h_fpp_nt_exists) RETURN !nothing to do
+c
+
+ call h_fpp_nt_close(ABORT,err)
+
+*
+ IF(h_fpp_nt_exists) then
+ ABORT = .true.
+ endif
+ h_fpp_nt_ID= 0
+ h_fpp_nt_name= ' '
+ h_fpp_nt_file= ' '
+ h_fpp_nt_title= ' '
+ do m=1,HMAX_FPPntuple_size
+ h_fpp_nt_tag(m)= ' '
+ h_fpp_nt_contents(m)= 0.
+ enddo
+*
+ IF(ABORT) call G_add_path(here,err)
+*
+ RETURN
+ END
diff --git a/ENGINE/h_fpp_ntup.cwn b/ENGINE/h_fpp_ntup.cwn
new file mode 100644
index 0000000..b570cd9
--- /dev/null
+++ b/ENGINE/h_fpp_ntup.cwn
@@ -0,0 +1,112 @@
+c common block of variables for column-wise Ntuple for HMS FPP
+***** these must NOT be used in the CTP system!!
+
+ integer MAX_cwn_goodhits
+ parameter (MAX_cwn_goodhits= 100) !!! must match limits in h_fpp_nt_open
+
+ integer MAX_cwn_tracks
+ parameter (MAX_cwn_tracks= 18) !!! should be 2*H_FPP_MAX_TRACKS !!!
+
+ integer*4 cwnFPP_eventID ! seqential trigger no
+
+ integer*4 cwnFPP_evtcode ! overall FPP event descriptor
+
+ integer*4 cwnFPP_helicite ! event by event beam helicity
+
+ real*4 cwnFPP_hsdelta ! momentum delta of HMS track
+ real*4 cwnFPP_hstheta ! angle of HMS track in hall
+ real*4 cwnFPP_hsphi ! azimuth of HMS track in hall
+ real*4 cwnFPP_w ! missing mass of HMS track (incl.)
+ real*4 cwnFPP_hszbeam ! z-coord of beam*HMS track in target
+ real*4 cwnFPP_hsxfp ! x-coord of HMS track at FP
+ real*4 cwnFPP_hsyfp ! y-coord of HMS track at FP
+ real*4 cwnFPP_hsxpfp ! dx/dz of HMS track at FP
+ real*4 cwnFPP_hsypfp ! dy/dz of HMS track at FP
+ real*4 cwnFPP_hsytar ! y-coord of HMS track at target
+ real*4 cwnFPP_hsxptar ! dx/dz of HMS track at target
+ real*4 cwnFPP_hsyptar ! dy/dz of HMS track at target
+
+ real*4 cwnFPP_trig_TDC1 ! TDC value of FPP trigger signal in VME 1
+ real*4 cwnFPP_trig_TDC2 ! TDC value of FPP trigger signal in VME 2
+
+ integer*4 cwnFPP_RawHits ! raw # of hits in FPP chambers
+
+ integer*4 cwnFPP_Nhits1 ! # of wires with usable hit in layers 1-6 (either pol)
+ integer*4 cwnFPP_Hit1_pol ! polarimeter 1 or 2
+ integer*4 cwnFPP_Hit1_layer ! layer # of each hit
+ integer*4 cwnFPP_Hit1_wire ! wire # of each hit
+ integer*4 cwnFPP_Hit1_itrack ! # of track hit is used in
+ real*4 cwnFPP_Hit1_time ! corrected TDC time of each hit
+ real*4 cwnFPP_Hit1_drift ! signed(!) drift distance
+ real*4 cwnFPP_Hit1_resid ! signed(!) residual between drift & track
+ real*4 cwnFPP_Hit1_d_HMS ! signed(!) distance between wire & HMS track
+
+ integer*4 cwnFPP_Ntracks ! # of tracks in upstream polarimeter
+ integer*4 cwnFPP_trk_pol ! upstream (1) or downstream (2) polarimeter
+ integer*4 cwnFPP_trk_num ! seq # of track in pol
+ integer*4 cwnFPP_trk_hits ! # of layers contributing
+ integer*4 cwnFPP_conetest ! fpp conetest variable
+ real*4 cwnFPP_simple_mx ! simple track dx/dz in chamber coords
+ real*4 cwnFPP_simple_bx ! x-coord in chamber system
+ real*4 cwnFPP_simple_my ! dy/dz in chamber coords
+ real*4 cwnFPP_simple_by ! y-coord in chamber system
+ real*4 cwnFPP_full_mx ! full track dx/dz in FP coords, upstream polarimeter
+ real*4 cwnFPP_full_bx ! x-coord in FP system
+ real*4 cwnFPP_full_my ! dy/dz in FP coords
+ real*4 cwnFPP_full_by ! y-coord in FP system
+ real*4 cwnFPP_chi2 ! reduced chi**2
+ real*4 cwnFPP_zclose ! z-coord of closest approach
+ real*4 cwnFPP_sclose ! distance of closest approach
+ real*4 cwnFPP_theta ! opening angle betw incident and re-scattered
+ real*4 cwnFPP_phi ! azimuthal angle
+
+
+ COMMON /CWNtupleFPP/ cwnFPP_eventID,
+ & cwnFPP_evtcode,
+ & cwnFPP_helicite,
+ & cwnFPP_hsdelta,
+ & cwnFPP_hstheta,
+ & cwnFPP_hsphi,
+ & cwnFPP_w,
+ & cwnFPP_hszbeam,
+ & cwnFPP_hsxfp,
+ & cwnFPP_hsyfp,
+ & cwnFPP_hsxpfp,
+ & cwnFPP_hsypfp,
+ & cwnFPP_hsytar,
+ & cwnFPP_hsxptar,
+ & cwnFPP_hsyptar,
+ &
+ & cwnFPP_trig_TDC1,
+ & cwnFPP_trig_TDC2,
+ &
+ & cwnFPP_RawHits,
+ &
+ & cwnFPP_Nhits1,
+ & cwnFPP_Hit1_pol(MAX_cwn_goodhits),
+ & cwnFPP_Hit1_layer(MAX_cwn_goodhits),
+ & cwnFPP_Hit1_wire(MAX_cwn_goodhits),
+ & cwnFPP_Hit1_iTrack(MAX_cwn_goodhits),
+ & cwnFPP_Hit1_time(MAX_cwn_goodhits),
+ & cwnFPP_Hit1_drift(MAX_cwn_goodhits),
+ & cwnFPP_Hit1_resid(MAX_cwn_goodhits),
+ & cwnFPP_Hit1_d_HMS(MAX_cwn_goodhits),
+ &
+ & cwnFPP_Ntracks,
+ & cwnFPP_trk_pol(MAX_cwn_tracks),
+ & cwnFPP_trk_num(MAX_cwn_tracks),
+ & cwnFPP_trk_hits(MAX_cwn_tracks),
+ & cwnFPP_conetest(MAX_cwn_tracks),
+ & cwnFPP_simple_mx(MAX_cwn_tracks),
+ & cwnFPP_simple_bx(MAX_cwn_tracks),
+ & cwnFPP_simple_my(MAX_cwn_tracks),
+ & cwnFPP_simple_by(MAX_cwn_tracks),
+ & cwnFPP_full_mx(MAX_cwn_tracks),
+ & cwnFPP_full_bx(MAX_cwn_tracks),
+ & cwnFPP_full_my(MAX_cwn_tracks),
+ & cwnFPP_full_by(MAX_cwn_tracks),
+ & cwnFPP_chi2(MAX_cwn_tracks),
+ & cwnFPP_zclose(MAX_cwn_tracks),
+ & cwnFPP_sclose(MAX_cwn_tracks),
+ & cwnFPP_theta(MAX_cwn_tracks),
+ & cwnFPP_phi(MAX_cwn_tracks)
diff --git a/ENGINE/h_initialize.f b/ENGINE/h_initialize.f
new file mode 100644
index 0000000..0bbe8dc
--- /dev/null
+++ b/ENGINE/h_initialize.f
@@ -0,0 +1,153 @@
+ SUBROUTINE H_initialize(ABORT,err)
+*--------------------------------------------------------
+*- Prototype C analysis routine
+*-
+*-
+*- Purpose and Methods : Initializes HMS quantities
+*-
+*- Output: ABORT - success or failure
+*- : err - reason for failure, if any
+*-
+*- Created 8-Nov-1993 Kevin B. Beard
+*- Modified 20-Nov-1993 KBB for new errors
+* $Log: h_initialize.f,v $
+* Revision 1.15.24.2 2007/10/22 15:16:52 cdaq
+* commented out diagnostic write statements
+*
+* Revision 1.15.24.1 2007/08/22 19:09:17 frw
+* added FPP
+*
+* Revision 1.20 2004/04/26 19:53:33 frw
+* inserted calls for FPP
+*
+* Revision 1.15 1996/09/04 14:40:46 saw
+* (JRA) Reorder some calls
+*
+* Revision 1.14 1995/10/09 18:46:28 cdaq
+* (SAW) Move ntuple initialization into g_ntuple_init
+*
+* Revision 1.13 1995/09/01 13:37:27 cdaq
+* (JRA) Initialize Cerenkov parameters
+*
+* Revision 1.12 1995/01/27 20:09:07 cdaq
+* (SAW) Add call to sieve slit ntuple initialization
+*
+* Revision 1.11 1994/10/11 18:44:11 cdaq
+* (SAW) Add hacks for event display
+*
+* Revision 1.10 1994/06/17 04:01:35 cdaq
+* (KBB) Upgrade error reporting
+*
+* Revision 1.9 1994/06/14 04:02:13 cdaq
+* (DFG) Add call to h_init_physics
+*
+* Revision 1.8 1994/05/12 19:34:06 cdaq
+* (DFG) Add call to h_targ_trans_init
+*
+* Revision 1.7 1994/04/13 04:31:00 cdaq
+* (DFG) Add initialize for scin and cal
+*
+* Revision 1.6 1994/04/12 17:20:27 cdaq
+* (KBB) Add ntuple call
+*
+* Revision 1.5 1994/02/22 15:12:37 cdaq
+* (DFG) Add call call to h_generate_geometry
+*
+* Revision 1.4 1994/02/11 18:35:40 cdaq
+* Split off CTP variables registration from initialize routines
+*
+* Revision 1.3 1994/02/04 17:35:56 cdaq
+* KBB replaced flag with title
+*
+*-
+*- All standards are from "Proposal for Hall C Analysis Software
+*- Vade Mecum, Draft 1.0" by D.F.Geesamn and S.Wood, 7 May 1993
+*-
+*--------------------------------------------------------
+ IMPLICIT NONE
+ SAVE
+*
+ character*12 here
+ parameter (here= 'H_initialize')
+*
+ logical ABORT
+ character*(*) err
+ character*20 mss
+ integer*4 istat
+*
+ logical FAIL
+ character*1000 why
+*HDISPLAY*
+*HDISPLAY include 'one_ev_io.cmn'
+*
+*--------------------------------------------------------
+ err= ' '
+ ABORT = .FALSE.
+*
+*-calculate physics singles constants
+ call h_init_physics(FAIL,why)
+ if(err.NE.' ' .and. why.NE.' ') then !keep warnings
+ call G_append(err,' & '//why)
+ elseif(why.NE.' ') then
+ err= why
+ endif
+ ABORT= ABORT .or. FAIL
+*
+*
+c write(*,*) ' call h_generate_geometry'
+ call h_generate_geometry ! Tracking routine
+*
+*-calculate secondary scintillator and time of flight parameters
+ call h_init_scin(FAIL,why)
+ if(why.NE.' ') then
+ err= why
+ endif
+ ABORT= ABORT .or. FAIL
+*
+*-calculate secondary cerenkov parameters
+ call h_init_cer(FAIL,why)
+ if(err.NE.' ' .and. why.NE.' ') then
+ call G_append(err,' & '//why)
+ elseif(why.NE.' ') then
+ err= why
+ endif
+ ABORT= ABORT .or. FAIL
+*
+*-calculate secondary FPP parameters
+ call h_init_fpp(FAIL,why)
+ if(err.NE.' ' .and. why.NE.' ') then
+ call G_append(err,' & '//why)
+ elseif(why.NE.' ') then
+ err= why
+ endif
+ ABORT= ABORT .or. FAIL
+*
+*-calculate secondary calorimeter parameters
+ call h_init_cal(FAIL,why)
+ if(err.NE.' ' .and. why.NE.' ') then
+ call G_append(err,' & '//why)
+ elseif(why.NE.' ') then
+ err= why
+ endif
+ ABORT= ABORT .or. FAIL
+*
+*HDISPLAY* If one_ev flag on, initialize the event display package
+*HDISPLAY if(one_ev.ne.0) call one_ev_init ! One event display init
+*
+*-read in Optical matrix elements
+ call h_targ_trans_init(FAIL,why,istat)
+ if(FAIL) then
+ call g_build_note(';istat=@','@',istat,' ',1.,'(I3)',mss)
+ call G_append(why,mss)
+ endif
+ if(err.NE.' ' .and. why.NE.' ') then !keep warnings
+ call G_append(err,' & '//why)
+ elseif(why.NE.' ') then
+ err= why
+ endif
+ ABORT= ABORT .or. FAIL
+*
+ if(ABORT .or. err.NE.' ') call g_add_path(here,err)
+*
+ return
+ end
diff --git a/ENGINE/h_keep_results.f b/ENGINE/h_keep_results.f
new file mode 100644
index 0000000..5503b12
--- /dev/null
+++ b/ENGINE/h_keep_results.f
@@ -0,0 +1,109 @@
+ SUBROUTINE H_keep_results(ABORT,err)
+*--------------------------------------------------------
+*- Prototype C analysis routine
+*-
+*-
+*- Purpose and Methods : Keeps statistics, etc.
+*-
+*- Output: ABORT - success or failure
+*- : err - reason for failure, if any
+*-
+*- Created 20-Nov-1993 Kevin B. Beard for new error standards
+*
+* $Log: h_keep_results.f,v $
+* Revision 1.6.24.3.2.2 2009/06/05 17:53:25 jones
+* Include call to fill bigcal ntuple. Needed for coincidence runs.
+*
+* Revision 1.6.24.3.2.1 2009/01/16 18:47:11 cdaq
+* *** empty log message ***
+*
+* Revision 1.6.24.3 2007/09/12 14:40:03 brash
+* *** empty log message ***
+*
+* Revision 1.6.24.2 2007/09/11 19:14:17 frw
+* fixed FPP related arrays and limits
+*
+* Revision 1.6.24.1 2007/08/22 19:09:17 frw
+* added FPP
+*
+* Revision 1.7 frw
+* added FPP call
+*
+* Revision 1.6 1996/09/04 14:42:14 saw
+* (JRA) Make HSNUM_FPTRACK.gt.0 instead of HNTRACKS_FP .gt. 0 the
+* criteria for adding to ntuples
+*
+* Revision 1.5 1996/01/16 17:03:06 cdaq
+* no change
+*
+* Revision 1.4 1995/07/27 19:40:29 cdaq
+* (JRA) Only add to ntuples when we have HNTRACKS_FP > 0
+*
+* Revision 1.3 1995/01/27 20:14:51 cdaq
+* (SAW) Add call to sieve slit ntuple keep routine
+*
+* Revision 1.2 1994/04/12 17:21:58 cdaq
+* (KBB) Add ntuple call
+*
+* Revision 1.1 1994/02/04 22:17:38 cdaq
+* Initial revision
+*
+*- All standards are from "Proposal for Hall C Analysis Software
+*- Vade Mecum, Draft 1.0" by D.F.Geesamn and S.Wood, 7 May 1993
+*-
+*-
+*--------------------------------------------------------
+ IMPLICIT NONE
+ SAVE
+*
+ include 'gen_detectorids.par'
+ include 'gen_decode_common.cmn'
+ include 'hms_data_structures.cmn'
+ INCLUDE 'hms_fpp_params.cmn'
+ INCLUDE 'hms_fpp_event.cmn'
+ include 'bigcal_data_structures.cmn'
+*
+ character*50 here
+ parameter (here= 'H_keep_results')
+*
+ logical ABORT
+ character*(*) err
+*
+*--------------------------------------------------------
+*-chance to flush any statistics, etc.
+*
+*
+ ABORT= .FALSE.
+ err= ' '
+*
+ if(bigcal_all_nclstr.gt.0) call b_ntuple_keep(ABORT,err,.false.)
+ if(HSNUM_FPTRACK.gt.0) call h_ntuple_keep(ABORT,err)! check for good tracks
+*
+ IF(ABORT) THEN
+ call G_add_path(here,err)
+ ELSE
+ err= ' '
+ ENDIF
+*
+*
+c write(*,*)'Calling h_fpp_nt_keep:',HFPP_eventclass,HFPP_min_event_code
+ if (HFPP_eventclass.ge.HFPP_min_event_code) call h_fpp_nt_keep(ABORT,err)
+*
+ IF(ABORT) THEN
+ call G_add_path(here,err)
+ ELSE
+ err= ' '
+ ENDIF
+*
+* Need to fix up the bloody error reporting
+*
+ if(HSNUM_FPTRACK.gt.0)call h_sv_nt_keep(ABORT,err) ! at least one track
+*
+ IF(ABORT) THEN
+ call G_add_path(here,err)
+ ELSE
+ err= ' '
+ ENDIF
+*
+ RETURN
+ END
diff --git a/ENGINE/h_ntuple_change.f b/ENGINE/h_ntuple_change.f
new file mode 100644
index 0000000..9bc5c63
--- /dev/null
+++ b/ENGINE/h_ntuple_change.f
@@ -0,0 +1,87 @@
+ subroutine h_ntuple_change(ABORT,err)
+*----------------------------------------------------------------------
+*
+* closes one HMS Ntuple file and opens another
+*
+* Purpose : switching from one file to the next
+*
+* Output: ABORT - success or failure
+* : err - reason for failure, if any
+*
+*----------------------------------------------------------------------
+
+ implicit none
+ save
+
+ character*15 here
+ parameter (here='h_ntuple_change')
+
+ logical ABORT
+ character*(*) err
+
+ INCLUDE 'h_ntuple.cmn'
+ include 'gen_run_info.cmn'
+
+ character*1 ifile
+ character*80 file
+ character*1000 pat
+
+ integer*4 ilo,fn_len
+
+* functions
+ integer g_important_length
+
+*--------------------------------------------------------
+
+
+ call h_ntuple_close(ABORT,err)
+
+
+
+ if (h_ntuple_exists) then
+ ABORT = .true.
+ endif
+
+ call NO_nulls(h_ntuple_file) !replace null characters with blanks
+
+ file= h_ntuple_file
+ call NO_nulls(file) !replace null characters with blanks
+ call g_sub_run_number(file,gen_run_number)
+
+ h_ntuple_filesegments = h_ntuple_filesegments + 1
+
+ if (h_ntuple_filesegments .le. 9) then
+ ifile = char(ichar('0')+h_ntuple_filesegments)
+ else
+ ifile = char(ichar('a')+h_ntuple_filesegments-10)
+ endif
+
+ fn_len = g_important_length(file)
+ ilo=index(file,'.hbook')
+ if ((ilo.le.1).or.(ilo.gt.fn_len-5)) then
+ ilo=index(file,'.rzdat')
+ endif
+
+ if ((ilo.gt.1).and.(ilo.lt.fn_len)) then
+ file = file(1:ilo-1) // '.' // ifile // file(ilo:fn_len)
+ else
+ ABORT = .true.
+ endif
+
+
+
+ IF (.not.ABORT) call h_ntuple_open(file,ABORT,err)
+
+
+ IF(ABORT) THEN
+ err= ':unable to change HMS Ntuple file segment'
+ call G_add_path(here,err)
+ ELSE
+ pat= ':changed HMS Ntuple file segment'
+ call G_add_path(here,pat)
+ call G_log_message('INFO: '//pat)
+ ENDIF
+
+
+ RETURN
+ END
diff --git a/ENGINE/h_ntuple_clear.f b/ENGINE/h_ntuple_clear.f
new file mode 100644
index 0000000..bcbcea6
--- /dev/null
+++ b/ENGINE/h_ntuple_clear.f
@@ -0,0 +1,30 @@
+ subroutine h_Ntuple_clear
+*----------------------------------------------------------------------
+*
+* Purpose : Clear vars that go to the HMS Ntuple
+*
+* csa 4/15/97
+*
+* $Log: h_ntuple_clear.f,v $
+* Revision 1.1 1999/02/24 14:52:36 saw
+* Dummy routine
+*
+*
+*----------------------------------------------------------------------
+ implicit none
+ save
+*
+* character*13 here
+* parameter (here='h_Ntuple_clear')
+*
+* logical ABORT
+* character*(*) err
+*
+
+* csa 2/2/99 -- This is a dummy routine in the CVS tree. The
+* real thing gets created in the user's Oscar directory based
+* on which variables are in the ntuple.lst file.
+
+*
+ RETURN
+ END
diff --git a/ENGINE/h_ntuple_close.f b/ENGINE/h_ntuple_close.f
new file mode 100644
index 0000000..6fd586e
--- /dev/null
+++ b/ENGINE/h_ntuple_close.f
@@ -0,0 +1,77 @@
+ subroutine h_Ntuple_close(ABORT,err)
+*----------------------------------------------------------------------
+*
+* closes the HMS Ntuple file
+*
+* Purpose : Flushes and closes the HMS Ntuple
+*
+* Output: ABORT - success or failure
+* : err - reason for failure, if any
+*
+*----------------------------------------------------------------------
+
+ implicit none
+ save
+
+ character*14 here
+ parameter (here='h_Ntuple_close')
+
+ logical ABORT
+ character*(*) err
+*
+ INCLUDE 'h_ntuple.cmn'
+ INCLUDE 'gen_routines.dec'
+*
+ logical HEXIST !CERNLIB function
+*
+ logical FAIL
+ character*80 why,directory,name
+ character*1000 msg
+ integer io,id,cycle,m
+*
+*--------------------------------------------------------
+
+ err= ' '
+ ABORT = .FALSE.
+
+ IF(.NOT.h_Ntuple_exists) RETURN !nothing to do
+
+ call HCDIR(directory,'R') !keep current directory
+
+ id= h_Ntuple_ID
+ io= h_Ntuple_IOchannel
+ name= h_Ntuple_name
+
+ ABORT= .NOT.HEXIST(id)
+ IF(ABORT) THEN
+ call G_add_path(here,err)
+ If(io.GT.0) Then
+ call G_IO_control(io,'FREE',FAIL,why) !free up
+ if(.NOT.FAIL) CLOSE(io)
+ EndIf
+ h_Ntuple_exists= .FALSE.
+ h_Ntuple_IOchannel= 0
+ RETURN
+ ENDIF
+
+ call HCDIR(h_Ntuple_directory,' ') !goto Ntuple directory
+
+ call G_add_path(here,msg)
+ call G_log_message('INFO: '//msg)
+
+ cycle= 0 !dummy for HROUT
+ call HROUT(id,cycle,' ') !flush CERNLIB buffers
+ call HREND(name) !CERNLIB close file
+ call G_IO_control(io,'FREE',ABORT,err) !free up IO channel
+ CLOSE(io) !close IO channel
+
+ call HCDIR(directory,' ') !return to current directory
+
+ h_Ntuple_directory= ' '
+ h_Ntuple_exists= .FALSE.
+ h_Ntuple_IOchannel= 0
+
+ IF(ABORT) call G_add_path(here,err)
+
+ RETURN
+ END
diff --git a/ENGINE/h_ntuple_init.f b/ENGINE/h_ntuple_init.f
new file mode 100644
index 0000000..93f1e3d
--- /dev/null
+++ b/ENGINE/h_ntuple_init.f
@@ -0,0 +1,287 @@
+ subroutine h_Ntuple_init(ABORT,err)
+*----------------------------------------------------------------------
+*
+* Creates an HMS Ntuple
+*
+* Purpose : Books an HMS Ntuple; defines structure of it
+*
+* Output: ABORT - success or failure
+* : err - reason for failure, if any
+*
+* Created: 8-Apr-1994 K.B.Beard, Hampton Univ.
+* $Log: h_ntuple_init.f,v $
+* Revision 1.11.18.5.2.5 2009/10/27 15:48:29 jones
+* eliminate duplicate xtar entry
+*
+* Revision 1.11.18.5.2.4 2009/09/15 20:52:47 jones
+* add variables for coin data
+*
+* Revision 1.11.18.5.2.3 2009/06/29 20:00:16 jones
+* add hsxtar
+* set units for hszbeam,hsytar and hsxtar to cm
+*
+* Revision 1.11.18.5.2.2 2008/11/06 14:35:46 cdaq
+* Removed S0, added helicte
+*
+* Revision 1.11.18.5 2007/12/12 15:54:17 cdaq
+* added focal plane time to HMS ntuple
+*
+* Revision 1.11.18.4 2007/10/29 21:59:41 cdaq
+* Modifications to HMS ntuple for beam raster/bpm information (MKJ)
+*
+* Revision 1.11.18.3 2007/10/28 01:59:30 cdaq
+* *** empty log message ***
+*
+* Revision 1.11.18.2 2007/10/26 16:49:21 cdaq
+* added number of hdc hits to HMS ntuple
+*
+* Revision 1.11.18.1 2007/10/16 20:20:31 cdaq
+* *** empty log message ***
+*
+* Revision 1.11 2004/02/17 17:26:34 jones
+* Changes to enable possiblity of segmenting rzdat files
+*
+* Revision 1.9.2.1 2003/04/04 12:54:42 cdaq
+* add beam parameters to ntuple
+*
+* Revision 1.9 1996/09/04 14:42:44 saw
+* (JRA) Some changes to ntuple contents
+*
+* Revision 1.8 1996/01/16 17:03:52 cdaq
+* (JRA) Modify ntuple contents
+*
+* Revision 1.7 1995/09/01 13:38:05 cdaq
+* (JRA) Add Cerenkov photoelectron count to ntuple
+*
+* Revision 1.6 1995/07/27 19:00:17 cdaq
+* (SAW) Relocate data statements for f2c compatibility
+*
+* Revision 1.5 1995/05/22 20:50:46 cdaq
+* (SAW) Split gen_data_data_structures into gen, hms, sos, and coin parts"
+*
+* Revision 1.4 1995/05/11 17:17:38 cdaq
+* (SAW) Allow %d for run number in filenames
+*
+* Revision 1.3 1995/01/27 20:09:59 cdaq
+* (JRA) Add Gas cerenkov to ntuple
+*
+* Revision 1.2 1994/06/17 02:34:12 cdaq
+* (KBB) Upgrade
+*
+* Revision 1.1 1994/04/12 16:15:02 cdaq
+* Initial revision
+*
+*
+*----------------------------------------------------------------------
+ implicit none
+ save
+*
+ character*13 here
+ parameter (here='h_Ntuple_init')
+*
+ logical ABORT
+ character*(*) err
+*
+ INCLUDE 'h_ntuple.cmn'
+ INCLUDE 'gen_routines.dec'
+ include 'hms_data_structures.cmn'
+ include 'gen_run_info.cmn'
+*
+ character*80 default_name
+ parameter (default_name= 'HMSntuple')
+c
+ character*80 file
+ character*80 name
+ character*1000 pat,msg
+ integerilo,fn_len,m
+ character*1 ifile
+
+ INCLUDE 'h_ntuple.dte'
+*
+*--------------------------------------------------------
+ err= ' '
+ ABORT = .FALSE.
+*
+ IF(h_Ntuple_exists) THEN
+ call h_Ntuple_shutdown(ABORT,err)
+ If(ABORT) Then
+ call G_add_path(here,err)
+ RETURN
+ EndIf
+ ENDIF
+*
+ call NO_nulls(h_Ntuple_file) !replace null characters with blanks
+*
+*-if name blank, just forget it
+ IF(h_Ntuple_file.EQ.' ') RETURN !do nothing
+ h_Ntuple_ID= default_h_Ntuple_ID
+ h_Ntuple_name= default_name
+ IF(h_Ntuple_title.EQ.' ') THEN
+ msg= name//' '//h_Ntuple_file
+ call only_one_blank(msg)
+ h_Ntuple_title= msg
+ ENDIF
+
+ file= h_Ntuple_file
+ call g_sub_run_number(file,gen_run_number)
+
+
+* * only needed if using more than one file
+ if (h_Ntuple_max_segmentevents .gt. 0) then
+ h_Ntuple_filesegments = 1
+
+ ifile = char(ichar('0')+h_Ntuple_filesegments)
+
+ fn_len = g_important_length(file)
+ ilo=index(file,'.hbook')
+ if ((ilo.le.1).or.(ilo.gt.fn_len-5)) then
+ ilo=index(file,'.rzdat')
+ endif
+
+ if ((ilo.gt.1).and.(ilo.lt.fn_len)) then
+ file = file(1:ilo-1) // '.' // ifile // file(ilo:fn_len)
+ else
+ ABORT = .true.
+ RETURN
+ endif
+ write(*,*) ' Using segmented hms rzdat files first filename: ',file
+ else
+ write(*,*) ' Not using segmented hms rzdat files.'
+ endif
+*
+ m= 0
+ m= m+1
+ h_Ntuple_tag(m)= 'hcer_npe' ! cerenkov photoelectron spectrum
+ m= m+1
+ h_Ntuple_tag(m)= 'hsp' ! Lab momentum of chosen track in GeV/c
+ m= m+1
+ h_Ntuple_tag(m)= 'hse' ! Lab total energy of chosen track in GeV
+ m= m+1
+ h_Ntuple_tag(m)= 'charge' ! charge
+ m= m+1
+ h_Ntuple_tag(m)= 'hsdelta' ! Spectrometer delta of chosen track
+ m= m+1
+ h_Ntuple_tag(m)= 'hstheta' ! Lab Scattering angle in radians
+ m= m+1
+ h_Ntuple_tag(m)= 'hsphi' ! Lab Azymuthal angle in radians
+ m= m+1
+ h_Ntuple_tag(m)= 'w' ! Invariant Mass of remaing hadronic system
+ m= m+1
+ h_Ntuple_tag(m)= 'hszbeam'! Lab Z coordinate of intersection of beam
+ ! track with spectrometer ray
+ m= m+1
+ h_Ntuple_tag(m)= 'hsdedx1' ! DEDX of chosen track in 1st scin plane
+ m= m+1
+ h_Ntuple_tag(m)= 'hsbeta' ! BETA of chosen track
+ m= m+1
+ h_Ntuple_tag(m)= 'hsshtrk' ! 'HSTRACK_ET' ! Total shower energy of chosen track
+ m= m+1
+ h_Ntuple_tag(m)= 'hsprtrk' !'HSTRACK_PRESHOWER_E' ! preshower of chosen track
+ m= m+1
+ h_Ntuple_tag(m)= 'hsxfp' ! X focal plane position
+ m= m+1
+ h_Ntuple_tag(m)= 'hsyfp'
+ m= m+1
+ h_Ntuple_tag(m)= 'hsxpfp'
+ m= m+1
+ h_Ntuple_tag(m)= 'hsypfp'
+ m= m+1
+ h_Ntuple_tag(m)= 'hsxtar'
+ m= m+1
+ h_Ntuple_tag(m)= 'hsytar'
+ m= m+1
+ h_Ntuple_tag(m)= 'hsxptar'
+ m= m+1
+ h_Ntuple_tag(m)= 'hsyptar'
+ m= m+1
+ h_Ntuple_tag(m)= 'hstart'
+ m= m+1
+ h_Ntuple_tag(m)= 'hsfptime'
+ m= m+1
+ h_Ntuple_tag(m)= 'eventID'
+ m= m+1
+ h_Ntuple_tag(m)= 'ev_type'
+
+* Experiment dependent entries start here.
+c
+ m= m+1
+ h_Ntuple_tag(m)= 'frast_y'
+ m= m+1
+ h_Ntuple_tag(m)= 'frast_x'
+ m= m+1
+ h_Ntuple_tag(m)= 'raw_srx'
+ m= m+1
+ h_Ntuple_tag(m)= 'raw_sry'
+ m= m+1
+ h_Ntuple_tag(m)= 'srast_y'
+ m= m+1
+ h_Ntuple_tag(m)= 'srast_x'
+ m=m+1
+ h_ntuple_tag(m)= 'helicite'
+ m=m+1
+ h_ntuple_tag(m)= 'betantrk'
+ m=m+1
+ h_ntuple_tag(m)= 'dctothit'
+ m=m+1
+ h_ntuple_tag(m)= 'dcntrk'
+ m=m+1
+ h_ntuple_tag(m)= 'sctothit'
+ m=m+1
+ h_ntuple_tag(m)= 'scallhit'
+ m=m+1
+ h_ntuple_tag(m)= 'scshould'
+ m=m+1
+ h_ntuple_tag(m)= 'ch1hit'
+ m=m+1
+ h_ntuple_tag(m)= 'ch2hit'
+ m=m+1
+ h_ntuple_tag(m)= 'caletot'
+c m=m+1
+c h_ntuple_tag(m)= 'hztar'
+ m=m+1
+ h_ntuple_tag(m)= 'dPel_HMS'
+ m=m+1
+ h_ntuple_tag(m)= 'X_HMS'
+ m=m+1
+ h_ntuple_tag(m)= 'Y_HMS'
+ m=m+1
+ h_ntuple_tag(m)= 'E_HMS'
+ m=m+1
+ h_ntuple_tag(m)= 'xclust'
+ m=m+1
+ h_ntuple_tag(m)= 'yclust'
+ m=m+1
+ h_ntuple_tag(m)= 'eclust'
+ m=m+1
+ h_ntuple_tag(m)= 'xcal_B0'
+ m=m+1
+ h_ntuple_tag(m)= 'ycal_B0'
+ m=m+1
+ h_ntuple_tag(m)= 'xdiff_shift'
+ m=m+1
+ h_ntuple_tag(m)= 'ydiff_shift'
+ m=m+1
+ h_ntuple_tag(m)= 'Eprime'
+ m=m+1
+ h_ntuple_tag(m)= 'nclust'
+ m=m+1
+ h_ntuple_tag(m)= 'rawnclus'
+ m=m+1
+ h_ntuple_tag(m)= 'hstubs'
+c
+ h_Ntuple_size= m !total size
+* Open ntuple
+
+ call h_Ntuple_open(file,ABORT,err)
+
+ IF(ABORT) THEN
+ err= ':unable to create HMS Ntuple'
+ call G_add_path(here,err)
+ ELSE
+ pat= ':created HMS Ntuple'
+ call G_add_path(here,pat)
+ call G_log_message('INFO: '//pat)
+ ENDIF
+
+ RETURN
+ END
diff --git a/ENGINE/h_ntuple_keep.f b/ENGINE/h_ntuple_keep.f
new file mode 100644
index 0000000..b9f3e6c
--- /dev/null
+++ b/ENGINE/h_ntuple_keep.f
@@ -0,0 +1,270 @@
+ subroutine h_Ntuple_keep(ABORT,err)
+*----------------------------------------------------------------------
+*
+* Purpose : Add entry to the HMS Ntuple
+*
+* Output: ABORT - success or failure
+* : err - reason for failure, if any
+*
+* Created: 11-Apr-1994 K.B.Beard, Hampton U.
+* $Log: h_ntuple_keep.f,v $
+* Revision 1.10.18.5.2.6 2009/10/27 15:48:41 jones
+* eliminate duplicate xtar entry
+*
+* Revision 1.10.18.5.2.5 2009/09/15 20:53:10 jones
+* add variables for coin data
+*
+* Revision 1.10.18.5.2.4 2009/06/29 20:00:16 jones
+* add hsxtar
+* set units for hszbeam,hsytar and hsxtar to cm
+*
+* Revision 1.10.18.5.2.3 2008/11/06 14:35:38 cdaq
+* Removed S0, added helicte
+*
+* Revision 1.10.18.5.2.1 2008/10/11 15:03:54 cdaq
+* slow raster
+*
+* Revision 1.10.18.5 2007/12/12 15:53:53 cdaq
+* added focal plane time to ntuple
+*
+* Revision 1.10.18.4 2007/10/29 21:59:41 cdaq
+* Modifications to HMS ntuple for beam raster/bpm information (MKJ)
+*
+* Revision 1.10.18.3 2007/10/28 01:59:24 cdaq
+* *** empty log message ***
+*
+* Revision 1.10.18.2 2007/10/26 16:48:14 cdaq
+* Added number of chamber hits to HMS ntuple
+*
+* Revision 1.10.18.1 2007/08/22 19:09:17 frw
+* added FPP
+*
+* Revision 1.11 2006/06/22 frw
+* added FPP entries
+*
+* Revision 1.10 2004/02/17 17:26:34 jones
+* Changes to enable possiblity of segmenting rzdat files
+*
+* Revision 1.8.2.1 2003/04/04 12:55:11 cdaq
+* add beam quantities to ntuple (MKJ)
+*
+* Revision 1.8 1996/09/04 14:43:17 saw
+* (JRA) Modify ntuple contents
+*
+* Revision 1.7 1996/01/16 17:01:55 cdaq
+* (JRA) Modify ntuple contents
+*
+* Revision 1.6 1995/09/01 13:38:28 cdaq
+* (JRA) Add Cerenkov photoelectron count to ntuple
+*
+* Revision 1.5 1995/05/22 20:50:46 cdaq
+* (SAW) Split gen_data_data_structures into gen, hms, sos, and coin parts"
+*
+* Revision 1.4 1995/05/11 17:37:13 cdaq
+* (SAW) Change HSDEDXn vars to an array.
+*
+* Revision 1.3 1995/01/27 20:10:27 cdaq
+* (JRA) Add Gas cerenkov to ntuple
+*
+* Revision 1.2 1994/06/17 02:44:38 cdaq
+* (KBB) Upgrade
+*
+* Revision 1.1 1994/04/12 16:15:21 cdaq
+* Initial revision
+*
+*
+*----------------------------------------------------------------------
+ implicit none
+ save
+*
+ character*13 here
+ parameter (here='h_Ntuple_keep')
+*
+ logical ABORT
+ character*(*) err
+*
+ INCLUDE 'hms_data_structures.cmn'
+ INCLUDE 'hms_scin_parms.cmn'
+ INCLUDE 'h_ntuple.cmn'
+ INCLUDE 'gen_data_structures.cmn'
+ INCLUDE 'gen_event_info.cmn'
+ INCLUDE 'hms_tracking.cmn'
+ INCLUDE 'hms_physics_sing.cmn'
+ INCLUDE 'hms_scin_tof.cmn'
+ INCLUDE 'gen_scalers.cmn'
+ INCLUDE 'hms_track_histid.cmn' !temp junk.
+ INCLUDE 'gep_data_structures.cmn'
+ include 'sane_ntuple.cmn'
+ include 'b_ntuple.cmn'
+ INCLUDE 'bigcal_data_structures.cmn'
+*
+ logical HEXIST !CERNLIB function
+*
+ integer m
+c
+ integer pln,cnt,ihit,nch1,nch2
+ real s0x1padc,s0x1nadc,s0x2nadc,s0x2padc
+ real s0x1ptdc,s0x1ntdc,s0x2ntdc,s0x2ptdc
+c
+ real proton_mass
+ parameter ( proton_mass = 0.93827247 ) ! [GeV/c^2]
+*
+*--------------------------------------------------------
+ err= ' '
+ ABORT = .FALSE.
+*
+ IF(.NOT.h_Ntuple_exists) RETURN !nothing to do
+c
+ if (h_Ntuple_max_segmentevents .gt. 0) then
+ if (h_Ntuple_segmentevents .gt. h_Ntuple_max_segmentevents) then
+ call h_ntuple_change(ABORT,err)
+ else
+ h_Ntuple_segmentevents = h_Ntuple_segmentevents +1
+ endif
+ endif
+*
+************************************************
+ m= 0
+*
+ m= m+1
+ h_Ntuple_contents(m)= HCER_NPE_SUM ! cerenkov photoelectron spectrum
+ m= m+1
+ h_Ntuple_contents(m)= HSP ! Lab momentum of chosen track in GeV/c
+ m= m+1
+ h_Ntuple_contents(m)= HSENERGY ! Lab total energy of chosen track in GeV
+ m= m+1
+ h_Ntuple_contents(m)= gbcm1_charge ! Charge of last scaler event
+ m= m+1
+ h_Ntuple_contents(m)= HSDELTA ! Spectrometer delta of chosen track
+ m= m+1
+ h_Ntuple_contents(m)= HSTHETA ! Lab Scattering angle in radians
+ m= m+1
+ h_Ntuple_contents(m)= HSPHI ! Lab Azymuthal angle in radians
+ m= m+1
+ h_Ntuple_contents(m)= HINVMASS ! Invariant Mass of remaing hadronic system
+ m= m+1
+ h_Ntuple_contents(m)= HSZBEAM*100 ! Lab Z coordinate of intersection of beam
+c ! track with spectrometer ray
+ m= m+1
+ h_Ntuple_contents(m)= HSDEDX(1) ! DEDX of chosen track in 1st scin plane
+ m= m+1
+ h_Ntuple_contents(m)= HSBETA ! BETA of chosen track
+ m= m+1
+ h_Ntuple_contents(m)= HSTRACK_ET ! Total shower energy of chosen track
+ m= m+1
+ h_Ntuple_contents(m)= HSTRACK_PRESHOWER_E ! preshower of chosen track
+ m= m+1
+ h_Ntuple_contents(m)= HSX_FP ! X focal plane position
+ m= m+1
+ h_Ntuple_contents(m)= HSY_FP
+ m= m+1
+ h_Ntuple_contents(m)= HSXP_FP
+ m= m+1
+ h_Ntuple_contents(m)= HSYP_FP
+ m= m+1
+ h_Ntuple_contents(m)= HSX_TAR*100
+ m= m+1
+ h_Ntuple_contents(m)= HSY_TAR*100
+ m= m+1
+ h_Ntuple_contents(m)= HSXP_TAR
+ m= m+1
+ h_Ntuple_contents(m)= HSYP_TAR
+ m= m+1
+ h_Ntuple_contents(m)= hstart_time
+ m= m+1
+ h_Ntuple_contents(m)= hstime_at_fp
+ m= m+1
+ h_Ntuple_contents(m)= float(gen_event_ID_number)
+ m= m+1
+ h_Ntuple_contents(m)= float(gen_event_type)
+ m= m+1
+ h_Ntuple_contents(m)= gfry_raw_adc
+ m= m+1
+ h_Ntuple_contents(m)= gfrx_raw_adc
+ m= m+1
+ h_Ntuple_contents(m)= gsrx_raw_adc
+ m= m+1
+ h_Ntuple_contents(m)= gsry_raw_adc
+ m= m+1
+ h_Ntuple_contents(m)= gsry_calib ! +Y vertical up in beam coordinate system
+ m= m+1
+ h_Ntuple_contents(m)= gsrx_calib ! X horizontal in beam coordinate system
+ m=m+1
+ h_ntuple_contents(m) = float(gbeam_helicity)
+ m=m+1
+ h_ntuple_contents(m) = hbeta_notrk
+ m=m+1
+ h_ntuple_contents(m) = float(HDC_TOT_HITS)
+ m=m+1
+ h_ntuple_contents(m) = float(HSNUM_FPTRACK)
+ m=m+1
+ h_ntuple_contents(m) = float(hscin_tot_hits)
+ m=m+1
+ h_ntuple_contents(m) = float(hscin_all_tot_hits)
+ m=m+1
+ h_ntuple_contents(m) = float(hgoodscinhits)
+ nch1 = 0
+ nch2 = 0
+ if ( HDC_TOT_HITS .gt. 0) then
+ do ihit=1, HDC_TOT_HITS
+ if ( hdc_plane_num(ihit) .le. 6) nch1 = nch1 + 1
+ if ( hdc_plane_num(ihit) .gt. 6) nch2 = nch2 + 1
+ enddo
+ endif
+ m=m+1
+ h_ntuple_contents(m) = float(nch1)
+ m=m+1
+ h_ntuple_contents(m) = float(nch2)
+ m=m+1
+ h_ntuple_contents(m) = hcal_et
+ m=m+1
+ h_ntuple_contents(m) = dPel_HMS
+ m=m+1
+ h_ntuple_contents(m) = X_HMS
+ m=m+1
+ h_ntuple_contents(m) = Y_HMS
+ m=m+1
+ h_ntuple_contents(m) = E_HMS
+ m=m+1
+ h_ntuple_contents(m) = xclust(bigcal_itrack_best)
+ m=m+1
+ h_ntuple_contents(m) = yclust(bigcal_itrack_best)
+ m=m+1
+ h_ntuple_contents(m) = eclust(bigcal_itrack_best)
+ m=m+1
+ h_ntuple_contents(m) = xcal_hexpect_B0
+ m=m+1
+ h_ntuple_contents(m) = ycal_hexpect_B0
+ m=m+1
+ h_ntuple_contents(m) = xdiff_shift
+ m=m+1
+ h_ntuple_contents(m) = ydiff_shift
+ m=m+1
+ h_ntuple_contents(m) = EprimeMeV
+ m=m+1
+ h_ntuple_contents(m) = nclust
+ m=m+1
+ h_ntuple_contents(m) = bigcal_all_nclstr
+ m=m+1
+ h_ntuple_contents(m) = hstubs
+c m=m+1
+c h_ntuple_contents(m) = hz_tar*100
+c write(6,'(i8,3f8.1)')gbeam_helicity,
+c > h_ntuple_contents(m),float(gbeam_helicity),
+c > h_ntuple_contents(m-1)
+
+* Experiment dependent entries start here.
+
+
+* Fill ntuple for this event
+ ABORT= .NOT.HEXIST(h_Ntuple_ID)
+ IF(ABORT) THEN
+ call G_build_note(':Ntuple ID#$ does not exist',
+ & '$',h_Ntuple_ID,' ',0.,' ',err)
+ call G_add_path(here,err)
+ ELSE
+ call HFN(h_Ntuple_ID,h_Ntuple_contents)
+ ENDIF
+*
+ RETURN
+ END
diff --git a/ENGINE/h_ntuple_open.f b/ENGINE/h_ntuple_open.f
new file mode 100644
index 0000000..13d5cca
--- /dev/null
+++ b/ENGINE/h_ntuple_open.f
@@ -0,0 +1,117 @@
+ subroutine h_Ntuple_open(file,ABORT,err)
+*----------------------------------------------------------------------
+*
+* Opens an HMS Ntuple file
+*
+* Purpose : Books an HMS Ntuple
+*
+* Output: ABORT - success or failure
+* : err - reason for failure, if any
+*
+*----------------------------------------------------------------------
+
+ implicit none
+ save
+
+ character*13 here
+ parameter (here='h_Ntuple_open')
+
+ logical ABORT
+ character*(*) err
+
+ INCLUDE 'h_ntuple.cmn'
+
+ integer default_bank,default_recL
+ parameter (default_bank= 8000) !4 bytes/word
+ parameter (default_recL= 1024) !record length
+ character*80 title,file
+ character*80 directory,name
+ character*1000 pat,msg
+ integer status,size,io,id,bank,recL,iv(10),m
+ real rv(10)
+
+ logical HEXIST !CERNLIB function
+
+*--------------------------------------------------------
+
+ err= ' '
+ ABORT = .FALSE.
+ IF(h_Ntuple_exists) THEN
+ call h_Ntuple_shutdown(ABORT,err)
+ If(ABORT) Then
+ call G_add_path(here,err)
+ RETURN
+ EndIf
+ ENDIF
+
+*- get any free IO channel
+
+ call g_IO_control(io,'ANY',ABORT,err)
+ h_Ntuple_exists= .NOT.ABORT
+ IF(ABORT) THEN
+ call G_add_path(here,err)
+ RETURN
+ ENDIF
+ h_Ntuple_IOchannel= io
+
+ id= h_Ntuple_ID
+ name= h_Ntuple_name
+ title= h_Ntuple_title
+ ABORT= HEXIST(id)
+ IF(ABORT) THEN
+ call g_IO_control(h_Ntuple_IOchannel,'FREE',ABORT,err)
+ call G_build_note(':HBOOK id#$ already in use',
+ & '$',id,' ',rv,' ',err)
+ call G_add_path(here,err)
+ RETURN
+ ENDIF
+
+ CALL HCDIR(directory,'R') !CERNLIB read current directory
+
+*-open New *.rzdat file-
+ recL= default_recL
+ call HROPEN(io,name,file,'N',recL,status) !CERNLIB
+
+ ABORT= status.NE.0
+ IF(ABORT) THEN
+ call g_IO_control(h_Ntuple_IOchannel,'FREE',ABORT,err)
+ iv(1)= status
+ iv(2)= io
+ pat= ':HROPEN error#$ opening IO#$ "'//file//'"'
+ call G_build_note(pat,'$',iv,' ',rv,' ',err)
+ call G_add_path(here,err)
+ RETURN
+ ENDIF
+
+ size= h_Ntuple_size
+ bank= default_bank
+ title= h_Ntuple_title
+ call HBOOKN(id,title,size,name,bank,h_Ntuple_tag) !create Ntuple
+
+ call HCDIR(h_Ntuple_directory,'R') !record Ntuple directory
+
+ CALL HCDIR(directory,' ') !reset CERNLIB directory
+
+ h_Ntuple_exists= HEXIST(h_Ntuple_ID)
+ ABORT= .NOT.h_Ntuple_exists
+
+ iv(1)= id
+ iv(2)= io
+ pat= 'Ntuple id#$ [' // h_Ntuple_directory // '/]' //
+ & name // ' IO#$ "' // file // '"'
+ call G_build_note(pat,'$',iv,' ',rv,' ',msg)
+ call sub_string(msg,' /]','/]')
+
+ IF(ABORT) THEN
+ err= ':unable to create '//msg
+ call G_add_path(here,err)
+ ELSE
+ pat= ':created '//msg
+ call G_add_path(here,pat)
+ call G_log_message('INFO: '//pat)
+ ENDIF
+
+ h_Ntuple_segmentevents = 0
+
+ RETURN
+ END
diff --git a/ENGINE/h_ntuple_register.f b/ENGINE/h_ntuple_register.f
new file mode 100644
index 0000000..7e148a8
--- /dev/null
+++ b/ENGINE/h_ntuple_register.f
@@ -0,0 +1,47 @@
+ subroutine h_Ntuple_register(ABORT,err)
+*----------------------------------------------------------------------
+*
+* CTP variable registration routine for the HMS Ntuples
+*
+* Purpose : Register output filename for HMS Ntuple; temporary
+* implementation to be superceeded by CTP Ntuples
+*
+* Output: ABORT - success or failure
+* : err - reason for failure, if any
+*
+* Created: 8-Apr-1994 K.B.Beard, HU: added Ntuples
+* $Log: h_ntuple_register.f,v $
+* Revision 1.2 1994/06/17 02:54:45 cdaq
+* (KBB) Upgrade
+*
+* Revision 1.1 1994/04/12 16:15:30 cdaq
+* Initial revision
+*
+*
+*----------------------------------------------------------------------
+ implicit none
+ save
+*
+ character*17 here
+ parameter (here='h_Ntuple_register')
+*
+ logical ABORT
+ character*(*) err
+*
+ INCLUDE 'h_ntuple.cmn'
+ INCLUDE 'gen_routines.dec'
+*
+ integer ierr
+*--------------------------------------------------------
+ err= ' '
+ ABORT = .FALSE.
+*
+ call G_reg_C('HMS_Ntuple',h_Ntuple_file,ABORT,err)
+*
+ IF(ABORT) THEN
+ call G_prepend(':unable to register-',err)
+ call G_add_path(here,err)
+ ENDIF
+*
+ return
+ end
diff --git a/ENGINE/h_ntuple_shutdown.f b/ENGINE/h_ntuple_shutdown.f
new file mode 100644
index 0000000..a8c7dca
--- /dev/null
+++ b/ENGINE/h_ntuple_shutdown.f
@@ -0,0 +1,78 @@
+ subroutine h_Ntuple_shutdown(ABORT,err)
+*----------------------------------------------------------------------
+*
+* Final shutdown of the HMS Ntuple
+*
+* Purpose : Flushes and closes the HMS Ntuple
+*
+* Output: ABORT - success or failure
+* : err - reason for failure, if any
+*
+* Created: 8-Apr-1994 K.B.Beard, HU: added Ntuples
+* $Log: h_ntuple_shutdown.f,v $
+* Revision 1.6 2004/02/17 17:26:34 jones
+* Changes to enable possiblity of segmenting rzdat files
+*
+* Revision 1.5 1998/12/01 15:56:25 saw
+* (SAW) Clean out archaic g_build_note stuff
+*
+* Revision 1.4 1996/01/16 17:01:06 cdaq
+* (SAW) Comment out an info message
+*
+* Revision 1.3 1994/06/29 03:27:43 cdaq
+* (KBB) Remove HDELET call
+*
+* Revision 1.2 1994/06/17 02:59:12 cdaq
+* (KBB) Upgrade
+*
+* Revision 1.1 1994/04/12 16:15:43 cdaq
+* Initial revision
+*
+*
+*----------------------------------------------------------------------
+ implicit none
+ save
+*
+ character*17 here
+ parameter (here='h_Ntuple_shutdown')
+*
+ logical ABORT
+ character*(*) err
+*
+ INCLUDE 'h_ntuple.cmn'
+ INCLUDE 'gen_routines.dec'
+*
+*
+ logical FAIL
+ character*80 why,directory,name
+ character*1000 msg
+ integer io,id,cycle,m
+*
+*--------------------------------------------------------
+ err= ' '
+ ABORT = .FALSE.
+*
+
+ IF(.NOT.h_Ntuple_exists) RETURN !nothing to do
+c
+
+ call h_ntuple_close(ABORT,err)
+
+*
+ IF(h_Ntuple_exists) then
+ ABORT = .true.
+ endif
+ h_Ntuple_ID= 0
+ h_Ntuple_name= ' '
+ h_Ntuple_file= ' '
+ h_Ntuple_title= ' '
+ h_Ntuple_size= 0
+ do m=1,HMAX_Ntuple_size
+ h_Ntuple_tag(m)= ' '
+ h_Ntuple_contents(m)= 0.
+ enddo
+*
+ IF(ABORT) call G_add_path(here,err)
+*
+ RETURN
+ END
diff --git a/ENGINE/h_proper_shutdown.f b/ENGINE/h_proper_shutdown.f
new file mode 100644
index 0000000..95e0cf5
--- /dev/null
+++ b/ENGINE/h_proper_shutdown.f
@@ -0,0 +1,106 @@
+ SUBROUTINE H_proper_shutdown(lunout,ABORT,err)
+*--------------------------------------------------------
+*- Prototype C analysis routine
+*-
+*-
+*- Purpose and Methods : Closes files properly, flushes, etc.
+*-
+*- Output: ABORT - success or failure
+*- : err - reason for failure, if any
+*-
+*- Created 20-Nov-1993 Kevin B. Beard for new error standards
+* $Log: h_proper_shutdown.f,v $
+* Revision 1.10 1995/10/09 18:55:48 cdaq
+* (JRA) Add bypass switches to efficiency shutdown routine calls
+*
+* Revision 1.9 1995/09/01 13:39:46 cdaq
+* (JRA) Add calls to more efficiency calculations and bad counter report
+*
+* Revision 1.8 1995/07/27 19:02:34 cdaq
+* (SAW) Move ntuple shutdown to g_ntuple_shutdown
+*
+* Revision 1.7 1995/05/22 13:29:49 cdaq
+* (JRA) Make a listing of potential detector problems
+*
+* Revision 1.6 1995/04/01 20:09:28 cdaq
+* (SAW) One report file for each of g, h, s, c instead of a single report file
+* Allow %d for run number in filenames
+*
+* Revision 1.5 1995/03/13 18:13:19 cdaq
+* (JRA) Add calls to h_scin_eff_shutdown and h_cal_eff_shutdown.
+*
+* Revision 1.4 1995/01/27 20:15:11 cdaq
+* (SAW) Add call to sieve slit ntuple shutdown routine
+*
+* Revision 1.3 1994/10/11 18:40:32 cdaq
+* (SAW) Protect agains blank blocknames
+*
+* Revision 1.2 1994/04/12 17:23:31 cdaq
+* (KBB) Add ntuple call
+*
+* Revision 1.1 1994/02/04 22:19:09 cdaq
+* Initial revision
+*
+*- All standards are from "Proposal for Hall C Analysis Software
+*- Vade Mecum, Draft 1.0" by D.F.Geesamn and S.Wood, 7 May 1993
+*-
+*--------------------------------------------------------
+ IMPLICIT NONE
+ SAVE
+*
+ include 'gen_routines.dec'
+ include 'gen_filenames.cmn'
+ include 'gen_run_info.cmn'
+ include 'hms_filenames.cmn'
+ include 'hms_bypass_switches.cmn'
+*
+ character*17 here
+ parameter (here= 'H_proper_shutdown')
+*
+ logical ABORT, report_abort
+ character*(*) err
+*
+ integer ierr
+ character*132 file
+ integer lunout
+*--------------------------------------------------------
+*-chance to flush any statistics, etc.
+*
+*
+ ABORT= .FALSE.
+ err= ' '
+*
+ if (hbypass_dc_eff.eq.0) then
+ call h_dc_eff_shutdown(lunout,ABORT,err)
+ call h_dc_trk_eff_shutdown(lunout,ABORT,err)
+ endif
+*
+ if (hbypass_scin_eff.eq.0) call h_scin_eff_shutdown(lunout,ABORT,err)
+*
+ if (hbypass_cer_eff.eq.0) call h_cer_eff_shutdown(lunout,ABORT,err)
+*
+ if (hbypass_cal_eff.eq.0) call h_cal_eff_shutdown(ABORT,err)
+*
+ call h_report_bad_data(lunout,ABORT,err)
+*
+ if(h_report_blockname.ne.' '.and.
+ $ h_report_output_filename.ne.' ') then
+
+ file = h_report_output_filename
+ call g_sub_run_number(file, gen_run_number)
+
+ ierr = threp(h_report_blockname, file)
+ if(ierr.ne.0) then
+ call g_append(err,'& threp failed to create report in file'//file)
+ report_abort = .true.
+ endif
+ endif
+*
+ IF(ABORT.or.report_abort) THEN
+ call G_add_path(here,err)
+ ELSE
+ err= ' '
+ ENDIF
+*
+ RETURN
+ END
diff --git a/ENGINE/h_register_variables.f b/ENGINE/h_register_variables.f
new file mode 100644
index 0000000..e8824e2
--- /dev/null
+++ b/ENGINE/h_register_variables.f
@@ -0,0 +1,126 @@
+ subroutine h_register_variables(ABORT,err)
+*----------------------------------------------------------------------
+*
+* CTP variable registration routine for the HMS
+*
+* Purpose : Register all variables that are to be used by CTP, that are
+* connected with the HMS. This includes externally configured
+* parameters/contants, event data that can be a histogram source, and
+* possible test results and scalers.
+*
+* Output: ABORT - success or failure
+* : err - reason for failure, if any
+*
+* Created: 9-Feb-1994 Stephen A. Wood
+*
+* $Log: h_register_variables.f,v $
+* Revision 1.12.24.1 2007/08/22 19:09:17 frw
+* added FPP
+*
+* Revision 1.13 2006/06/22 frw
+* added FPP structures
+*
+* Revision 1.12 1996/01/16 16:57:03 cdaq
+* no change
+*
+* Revision 1.11 1995/05/22 13:31:38 cdaq
+* (SAW) Add call to register hms_data_structures.cmn variables
+*
+* Revision 1.10 1995/05/11 18:57:25 cdaq
+* (SAW) Add calls to register h_ntuple.cmn and h_sieve_ntuple.cmn
+*
+* Revision 1.9 1995/01/27 20:15:54 cdaq
+* (SAW) Add call to sieve slit register routine
+*
+* Revision 1.8 1994/08/18 04:11:26 cdaq
+* (SAW) Call makereg generated routines to register variables
+*
+* Revision 1.7 1994/06/17 03:25:29 cdaq
+* (KBB) Execute all code despite registration errors
+*
+* Revision 1.6 1994/06/16 03:43:47 cdaq
+* (SAW) Register filenames for reports
+*
+* Revision 1.5 1994/04/12 17:25:03 cdaq
+* (KBB) Add ntuple call
+*
+* Revision 1.4 1994/02/22 19:37:53 cdaq
+* (SAW) Remove CTP register calls to fortran PARAMETER's
+*
+* Revision 1.3 1994/02/22 18:56:45 cdaq
+* (SAW) Make a call to h_register_param
+*
+* Revision 1.2 1994/02/11 18:36:17 cdaq
+* Split off CTP variables registration from initialize routines
+*
+* Revision 1.1 1994/02/11 04:18:24 cdaq
+* Initial revision
+*
+*
+*----------------------------------------------------------------------
+ implicit none
+ save
+*
+ character*20 here
+ parameter (here='h_register_variables')
+*
+ logical ABORT
+ character*(*) err
+*
+ logical FAIL
+ character*1000 why
+*--------------------------------------------------------
+ err= ' '
+ ABORT = .FALSE.
+*
+ call r_hms_data_structures
+
+ call r_hms_filenames
+
+ call r_h_ntuple
+
+ call r_h_sieve_ntuple
+
+ call r_hms_fpp_event
+ call r_h_fpp_ntuple
+
+ call h_register_param(FAIL,why) ! TRACKING ROUTINE
+ IF(err.NE.' ' .and. why.NE.' ') THEN !keep warnings
+ call G_append(err,' & '//why)
+ ELSEIF(why.NE.' ') THEN
+ err= why
+ ENDIF
+ ABORT= ABORT .or. FAIL
+*
+ call h_ntuple_register(FAIL,why) ! Remove this when ctp files fixed
+ IF(err.NE.' ' .and. why.NE.' ') THEN !keep warnings
+ call G_append(err,' & '//why)
+ ELSEIF(why.NE.' ') THEN
+ err= why
+ ENDIF
+ ABORT= ABORT .or. FAIL
+*
+ if(ABORT .or. err.NE.' ') call G_add_path(here,err)
+*
+ call h_sv_nt_register(FAIL,why) ! Remove this when ctp files fixed
+ IF(err.NE.' ' .and. why.NE.' ') THEN !keep warnings
+ call G_append(err,' & '//why)
+ ELSEIF(why.NE.' ') THEN
+ err= why
+ ENDIF
+ ABORT= ABORT .or. FAIL
+*
+ if(ABORT .or. err.NE.' ') call G_add_path(here,err)
+*
+ call h_fpp_nt_register(FAIL,why) ! Remove this when ctp files fixed
+ IF(err.NE.' ' .and. why.NE.' ') THEN !keep warnings
+ call G_append(err,' & '//why)
+ ELSEIF(why.NE.' ') THEN
+ err= why
+ ENDIF
+ ABORT= ABORT .or. FAIL
+*
+ if(ABORT .or. err.NE.' ') call G_add_path(here,err)
+*
+ return
+ end
diff --git a/ENGINE/h_reset_event.f b/ENGINE/h_reset_event.f
new file mode 100644
index 0000000..e91c47d
--- /dev/null
+++ b/ENGINE/h_reset_event.f
@@ -0,0 +1,312 @@
+ SUBROUTINE H_reset_event(ABORT,err)
+*--------------------------------------------------------
+*- Prototype C analysis routine
+*-
+*-
+*- Purpose and Methods : Resets all HMS quantities before event is processed.
+*-
+*-
+*- Output: ABORT - success or failure
+*- : err - reason for failure, if any
+*-
+*- Created 29-Oct-1993 Kevin B. Beard
+*- Modified 20-Nov-1993 KBB for new errors
+*-
+*- All standards are from "Proposal for Hall C Analysis Software
+*- Vade Mecum, Draft 1.0" by D.F.Geesamn and S.Wood, 7 May 1993
+*
+* $Log: h_reset_event.f,v $
+* Revision 1.17 2002/12/20 21:55:23 jones
+* Modified by Hamlet for new HMS aerogel
+*
+* Revision 1.17 2002/09/26
+* (Hamlet) Add reset for HMS Aerogel (Took from Vardan)
+*
+* Revision 1.16 1999/08/20 14:52:18 saw
+* Put in warning if Xscin_tdc_max is bigger than 4094
+*
+* Revision 1.15 1999/02/03 21:13:03 saw
+* Code for new Shower counter tubes
+*
+* Revision 1.14 1998/12/17 21:50:31 saw
+* Support extra set of tubes on HMS shower counter
+*
+* Revision 1.13 1996/09/04 15:14:56 saw
+* (JRA) Zero out some misc scalers
+*
+* Revision 1.12 1995/10/09 18:08:46 cdaq
+* (JRA) Add clear of HCER_RAW_ADC
+*
+* Revision 1.11 1995/07/27 19:41:10 cdaq
+* (JRA) Zero out pedestal arrays
+*
+* Revision 1.10 1995/05/22 20:50:47 cdaq
+* (SAW) Split gen_data_data_structures into gen, hms, sos, and coin parts"
+*
+* Revision 1.9 1995/05/11 18:58:17 cdaq
+* (SAW) Change HSDEDXn vars to an array
+*
+* Revision 1.8 1994/09/20 17:29:33 cdaq
+* (SAW) Add include of hms_tracking.cmn
+*
+* Revision 1.7 1994/07/07 21:16:38 cdaq
+* (JRA) Clear additional variables
+*
+* Revision 1.6 1994/06/28 20:07:00 cdaq
+* (SAW) Add clearing of HSCIN_ALL arrays
+*
+*-
+*--------------------------------------------------------
+ IMPLICIT NONE
+ SAVE
+*
+ character*50 here
+ parameter (here= 'H_reset_event')
+*
+ logical ABORT
+ character*(*) err
+*
+ INCLUDE 'hms_data_structures.cmn'
+ include 'hms_tracking.cmn'
+ include 'hms_pedestals.cmn'
+ include 'hms_scin_parms.cmn'
+ include 'hms_scin_tof.cmn'
+*
+ INTEGER hit,track,block,i,j,plane
+*
+*--------------------------------------------------------
+*
+ do i=1,hnum_scin_planes
+ do j=1,hnum_scin_elements
+ hhodo_pos_ped_num(i,j) = 0
+ hhodo_pos_ped_sum2(i,j) = 0
+ hhodo_pos_ped_sum(i,j) = 0
+ hhodo_neg_ped_num(i,j) = 0
+ hhodo_neg_ped_sum2(i,j) = 0
+ hhodo_neg_ped_sum(i,j) = 0
+ enddo
+ enddo
+
+ do i=1,hmax_cal_blocks
+ hcal_pos_ped_num(i)=0
+ hcal_pos_ped_sum2(i)=0
+ hcal_pos_ped_sum(i)=0
+ hcal_neg_ped_num(i)=0
+ hcal_neg_ped_sum2(i)=0
+ hcal_neg_ped_sum(i)=0
+ enddo
+
+ do i=1,hmax_cer_hits
+ hcer_ped_num(i)=0
+ hcer_ped_sum2(i)=0
+ hcer_ped_sum(i)=0
+ enddo
+
+ do i=1,hmax_aero_hits
+ haero_pos_ped_num(i)=0
+ haero_pos_ped_sum2(i)=0
+ haero_pos_ped_sum(i)=0
+ haero_neg_ped_num(i)=0
+ haero_neg_ped_sum2(i)=0
+ haero_neg_ped_sum(i)=0
+ enddo
+
+ DO hit= 1,HMAX_DC_HITS
+ HDC_RAW_PLANE_NUM(hit)= 0
+ HDC_RAW_WIRE_NUM(hit)= 0
+ HDC_RAW_TDC(hit)= 0
+ HDC_DRIFT_TIME(hit)= 0
+ HDC_DRIFT_DIS(hit)= 0
+ HDC_WIRE_CENTER(hit)= 0
+ HDC_WIRE_COORD(hit)= 0
+ HDC_PLANE_NUM(hit)= 0
+ HDC_WIRE_NUM(hit)= 0
+ HDC_TDC(hit)= 0
+ ENDDO
+ HDC_TOT_HITS= 0
+*
+ DO plane= 1,HMAX_NUM_DC_PLANES
+ HDC_HITS_PER_PLANE(plane)= 0
+ ENDDO
+*
+ DO hit= 1,HMAX_SCIN_HITS
+ HSCIN_ZPOS(hit)= 0.0
+ HSCIN_CENTER_COORD(hit)= 0.0
+ HSCIN_COR_ADC(hit)= 0
+ HSCIN_COR_TIME(hit)= 0
+ HSCIN_PLANE_NUM(hit)= 0
+ HSCIN_COUNTER_NUM(hit)= 0
+ HSCIN_ADC_POS(hit)= 0
+ HSCIN_ADC_NEG(hit)= 0
+ HSCIN_TDC_POS(hit)= 0
+ HSCIN_TDC_NEG(hit)= 0
+ HSCIN_ALL_PLANE_NUM(hit)= 0
+ HSCIN_ALL_COUNTER_NUM(hit)= 0
+ HSCIN_ALL_ADC_POS(hit)= 0
+ HSCIN_ALL_ADC_NEG(hit)= 0
+ HSCIN_ALL_TDC_POS(hit)= 0
+ HSCIN_ALL_TDC_NEG(hit)= 0
+ ENDDO
+ DO plane= 1,HNUM_SCIN_PLANES
+ HSCIN_HITS_PER_PLANE(plane)= 0
+ ENDDO
+ HSCIN_TOT_HITS= 0
+ HSCIN_ALL_TOT_HITS= 0
+*
+* HMS CALORIMETER HITS
+*
+ DO block= 1,HMAX_CAL_BLOCKS
+ HBLOCK_XC(block)= 0.
+ HBLOCK_ZC(block)= 0
+ HBLOCK_DE(block)= 0
+ HBLOCK_DE_POS(block)= 0
+ HBLOCK_DE_NEG(block)= 0
+ HCAL_ROW(block)= 0
+ HCAL_COLUMN(block)= 0
+ HCAL_ADC_POS(block)= 0
+ HCAL_ADC_NEG(block)= 0
+ HCAL_ADC(block)= 0
+ ENDDO
+ HCAL_POS_HITS= 0
+ HCAL_NEG_HITS= 0
+ HCAL_TOT_HITS= 0
+*
+* HMS CERENKOV HITS
+*
+ DO hit= 1,HMAX_CER_HITS
+ HCER_TUBE_NUM(hit)= 0
+ HCER_RAW_ADC(hit)= 0
+ HCER_ADC(hit)= 0
+ HCER_PLANE(hit)= 0
+ ENDDO
+ HCER_TOT_HITS= 0
+*
+* HMS AEROGEL HITS
+*
+ DO hit= 1,HMAX_AERO_HITS
+ HAERO_PAIR_NUM(hit) = 0
+ HAERO_ADC_POS(hit) = 0
+ HAERO_ADC_NEG(hit) = 0
+ HAERO_PLANE(hit) = 0
+ ENDDO
+ HAERO_TOT_HITS = 0
+
+*
+* HMS Miscleaneous hits
+*
+ do hit=1,HMAX_MISC_HITS
+ HMISC_RAW_ADDR1(hit) = 0
+ HMISC_RAW_ADDR2(hit) = 0
+ HMISC_RAW_DATA(hit) = 0
+ do plane=1,hnum_misc_planes
+ hmisc_scaler(hit,plane)=0
+ enddo
+ enddo
+ hmisc_tot_hits = 0
+*
+* HMS DETECTOR TRACK QUANTITIES
+*
+ DO track= 1,HNTRACKS_MAX
+ HX_FP(track)= 0
+ HY_FP(track)= 0
+ HZ_FP(track)= 0
+ HXP_FP(track)= 0
+ HYP_FP(track)= 0
+ HCHI2_FP(track)= 0
+ HDEL_FP(4,4,track)= 0
+ HNFREE_FP(track)= 0
+ Do hit= 1,HNTRACKHITS_MAX
+ HNTRACK_HITS(track,hit)= 0
+ EndDo
+ ENDDO
+ HNTRACKS_FP= 0
+*
+* HMS TARGET QUANTITIES
+*
+ DO track= 1,HNTRACKS_MAX
+ HX_TAR(track)= 0
+ HY_TAR(track)= 0
+ HZ_TAR(track)= 0
+ HXP_TAR(track)= 0
+ HYP_TAR(track)= 0
+ HDELTA_TAR(track)= 0
+ HP_TAR(track)= 0
+ HCHI2_TAR(track)= 0
+ HDEL_TAR(5,5,track)= 0
+ HNFREE_TAR(track)= 0
+ HLINK_TAR_FP(track)= 0
+ Do j= 1,5
+ do i= 1,5
+ HDEL_TAR(i,j,track)= 0.
+ enddo
+ EndDo
+ ENDDO
+ HNTRACKS_TAR= 0
+
+ DO track= 1,HNTRACKS_MAX
+ HNBLOCKS_CAL(track)= 0
+ HTRACK_E1(track)= 0.
+ HTRACK_E2(track)= 0.
+ HTRACK_E3(track)= 0.
+ HTRACK_E4(track)= 0.
+ HTRACK_ET(track)= 0.
+ HTRACK_E1_POS(track)= 0.
+ HTRACK_E1_NEG(track)= 0.
+ HTRACK_E2_POS(track)= 0.
+ HTRACK_E2_NEG(track)= 0.
+ HTRACK_PRESHOWER_E(track)= 0.
+ do hit = 1 , HMAX_SCIN_HITS
+ HSCIN_HIT(track,hit)= 0
+ enddo
+ do plane = 1 , HNUM_SCIN_PLANES
+ HDEDX(track,plane) = 0.
+ enddo
+ HNUM_SCIN_HIT(track)=0
+ HBETA(track)=0.
+ HBETA_CHISQ(track)=0.
+ HTIME_AT_FP(track)=0.
+ ENDDO
+
+ HSP=0.
+ HSENERGY=0.
+ HSDELTA=0.
+ HSTHETA=0.
+ HSPHI=0.
+ HSMINV=0.
+ HSZBEAM=0.
+ do plane = 1 , HNUM_SCIN_PLANES
+ HSDEDX(plane) = 0.
+ enddo
+ HSBETA=0.
+ HSTRACK_ET=0.
+ HSTRACK_PRESHOWER_E=0.
+ HSTIME_AT_FP=0.
+ HSX_FP=0.
+ HSY_FP=0.
+ HSXP_FP=0.
+ HSYP_FP=0.
+ HSCHI2PERDEG=0.
+ HSX_TAR=0.
+ HSY_TAR=0.
+ HSXP_TAR=0.
+ HSYP_TAR=0.
+ HSNUM_FPTRACK=0
+ HSNUM_TARTRACK=0
+ HSID_LUND=0
+ HSNFREE_FP=0
+*
+ if(hscin_tdc_max.gt.4094) then
+ print *,' '
+ print *,'WARNING!!: hscin_tdc_max is ',hscin_tdc_max
+ print *,'We usually run our high resolution TDC''s with 12 bit'
+ print *,'ranges. If hscin_tdc_max is set to a value higher than'
+ print *,'the TDC''s overflow channel, then overflowed TDC channels'
+ print *,'will not be rejected. Under high rate conditions, this'
+ print *,'can result in bad beta and timing calculations'
+ print *,' '
+ endif
+*
+ ABORT= .FALSE.
+ err= ' '
+ RETURN
+ END
diff --git a/ENGINE/h_sv_nt_init.f b/ENGINE/h_sv_nt_init.f
new file mode 100644
index 0000000..41a6edf
--- /dev/null
+++ b/ENGINE/h_sv_nt_init.f
@@ -0,0 +1,214 @@
+ subroutine h_sv_Nt_init(ABORT,err)
+*----------------------------------------------------------------------
+*
+* Creates an HMS Sieve slit Ntuple
+*
+* Purpose : Books an HMS Ntuple; defines structure of it
+*
+* Output: ABORT - success or failure
+* : err - reason for failure, if any
+*
+* Created: 1-Nov-1994
+* $Log: h_sv_nt_init.f,v $
+* Revision 1.6 1996/11/05 21:42:08 saw
+* (DD) Add gas cerenkov to ntuple
+*
+* Revision 1.5 1996/09/04 15:15:21 saw
+* (JRA) Change ntuple contents
+*
+* Revision 1.4 1996/04/29 19:49:21 saw
+* (JRA) Add HCAL_ET
+*
+* Revision 1.3 1995/07/27 19:43:22 cdaq
+* (SAW) Relocate data statements for f2c compatibility
+*
+* Revision 1.2 1995/05/11 18:58:55 cdaq
+* (SAW) Allow %d for run number in filenames
+*
+* Revision 1.1 1995/01/27 20:05:15 cdaq
+* Initial revision
+*
+*
+*----------------------------------------------------------------------
+ implicit none
+ save
+*
+ character*13 here
+ parameter (here='h_sv_Nt_init')
+*
+ logical ABORT
+ character*(*) err
+*
+ INCLUDE 'h_sieve_ntuple.cmn'
+ INCLUDE 'gen_routines.dec'
+ include 'gen_run_info.cmn'
+*
+ character*80 default_name
+ parameter (default_name= 'sieventuple')
+ character*80 default_title
+ parameter (default_title= 'SieveSlits')
+ integer default_bank,default_recL
+ parameter (default_bank= 8000) !4 bytes/word
+ parameter (default_recL= 1024) !record length
+ character*80 title,file
+ character*80 directory,name
+ character*1000 pat,msg
+ integer status,size,io,id,bank,recL,iv(10),m
+* parameter (id = 1)
+ real rv(10)
+*
+ logical HEXIST !CERNLIB function
+*
+ INCLUDE 'h_sieve_ntuple.dte'
+*
+*--------------------------------------------------------
+ err= ' '
+ ABORT = .FALSE.
+*
+ IF(h_sieve_Ntuple_exists) THEN
+ call h_sv_Nt_shutdown(ABORT,err)
+ If(ABORT) Then
+ call G_add_path(here,err)
+ RETURN
+ EndIf
+ ENDIF
+*
+
+ h_sieve_Ntuple_ID= default_h_sieve_Ntuple_ID
+ h_sieve_Ntuple_name= default_name
+ h_sieve_Ntuple_title= default_title
+
+ call NO_nulls(h_sieve_Ntuple_file) !replace null characters with blanks
+*
+*-if name blank, just forget it
+ IF(h_sieve_Ntuple_file.EQ.' ') RETURN !do nothing
+*
+*- get any free IO channel
+*
+ call g_IO_control(io,'ANY',ABORT,err)
+ h_sieve_Ntuple_exists= .NOT.ABORT
+ IF(ABORT) THEN
+ call G_add_path(here,err)
+ RETURN
+ ENDIF
+ h_sieve_Ntuple_IOchannel= io
+*
+ id= h_sieve_Ntuple_ID
+*
+
+ ABORT= HEXIST(id)
+ IF(ABORT) THEN
+ call g_IO_control(h_sieve_Ntuple_IOchannel,'FREE',ABORT,err)
+ call G_build_note(':HBOOK id#$ already in use',
+ & '$',id,' ',rv,' ',err)
+ call G_add_path(here,err)
+ RETURN
+ ENDIF
+*
+
+ CALL HCDIR(directory,'R') !CERNLIB read current directory
+
+*
+*
+ id= h_sieve_Ntuple_ID
+ name= h_sieve_Ntuple_name
+
+ file= h_sieve_Ntuple_file
+ call g_sub_run_number(file,gen_run_number)
+
+ recL= default_recL
+ io= h_sieve_Ntuple_IOchannel
+*
+*-open New *.rzdat file-
+ call HROPEN(io,name,file,'N',recL,status) !CERNLIB
+* !directory set to "//TUPLE"
+ io= h_sieve_Ntuple_IOchannel
+ ABORT= status.NE.0
+ IF(ABORT) THEN
+ call g_IO_control(h_sieve_Ntuple_IOchannel,'FREE',ABORT,err)
+ iv(1)= status
+ iv(2)= io
+ pat= ':HROPEN error#$ opening IO#$ "'//file//'"'
+ call G_build_note(pat,'$',iv,' ',rv,' ',err)
+ call G_add_path(here,err)
+ RETURN
+ ENDIF
+ h_sieve_Ntuple_file= file
+*
+**********begin insert description of contents of HMS tuple ******
+ m= 0
+*
+ m=m+1
+ h_sieve_Ntuple_tag(m)= 'HSXFP' ! X focal plane position
+ m= m+1
+ h_sieve_Ntuple_tag(m)= 'HSYFP'
+ m= m+1
+ h_sieve_Ntuple_tag(m)= 'HSXPFP'
+ m= m+1
+ h_sieve_Ntuple_tag(m)= 'HSYPFP'
+ m= m+1
+ h_sieve_Ntuple_tag(m)= 'HSDELTA'
+ m= m+1
+ h_sieve_Ntuple_tag(m)= 'HSXTAR'
+ m= m+1
+ h_sieve_Ntuple_tag(m)= 'HSYTAR'
+ m= m+1
+ h_sieve_Ntuple_tag(m)= 'HSXPTAR'
+ m= m+1
+ h_sieve_Ntuple_tag(m)= 'HSYPTAR'
+ m= m+1
+ h_sieve_Ntuple_tag(m)= 'HSSHTRK'
+ m= m+1
+ h_sieve_Ntuple_tag(m)= 'HCER'
+ m= m+1
+ h_sieve_Ntuple_tag(m)= 'EventID'
+*
+ h_sieve_Ntuple_size= m !total size
+***********end insert description of contents of HMS tuple********
+*
+ title= h_sieve_Ntuple_title
+ IF(title.EQ.' ') THEN
+ msg= name//' '//h_sieve_Ntuple_file
+ call only_one_blank(msg)
+ title= msg
+ h_sieve_Ntuple_title= title
+ ENDIF
+*
+
+ id= h_sieve_Ntuple_ID
+ io= h_sieve_Ntuple_IOchannel
+ name= h_sieve_Ntuple_name
+ title= h_sieve_Ntuple_title
+ size= h_sieve_Ntuple_size
+ file= h_sieve_Ntuple_file
+ bank= default_bank
+
+ call HBOOKN(id,title,size,name,bank,h_sieve_Ntuple_tag) !create Ntuple
+*
+ call HCDIR(h_sieve_Ntuple_directory,'R') !record Ntuple directory
+*
+
+ CALL HCDIR(directory,' ') !reset CERNLIB directory
+
+*
+ h_sieve_Ntuple_exists= HEXIST(h_sieve_Ntuple_ID)
+ ABORT= .NOT.h_sieve_Ntuple_exists
+*
+ iv(1)= id
+ iv(2)= io
+ pat= 'Ntuple id#$ [' // h_sieve_Ntuple_directory // '/]' //
+ & name // ' IO#$ "' // file // '"'
+ call G_build_note(pat,'$',iv,' ',rv,' ',msg)
+ call sub_string(msg,' /]','/]')
+*
+ IF(ABORT) THEN
+ err= ':unable to create '//msg
+ call G_add_path(here,err)
+ ELSE
+ pat= ':created '//msg
+ call G_add_path(here,pat)
+ call G_log_message('INFO: '//pat)
+ ENDIF
+*
+ RETURN
+ END
diff --git a/ENGINE/h_sv_nt_keep.f b/ENGINE/h_sv_nt_keep.f
new file mode 100644
index 0000000..39a3b7b
--- /dev/null
+++ b/ENGINE/h_sv_nt_keep.f
@@ -0,0 +1,92 @@
+ subroutine h_sv_Nt_keep(ABORT,err)
+*----------------------------------------------------------------------
+*
+* Purpose : Add entry to the HMS Sieve slit Ntuple
+*
+* Output: ABORT - success or failure
+* : err - reason for failure, if any
+*
+* Created: 1-Nov-1994
+* $Log: h_sv_nt_keep.f,v $
+* Revision 1.5 1996/11/05 21:42:28 saw
+* (DD) Add gas cerenkov to ntuple
+*
+* Revision 1.4 1996/09/04 15:15:38 saw
+* (JRA) Change ntuple contents
+*
+* Revision 1.3 1996/04/29 19:49:35 saw
+* (JRA) Add HCAL_ET
+*
+* Revision 1.2 1995/05/22 20:50:47 cdaq
+* (SAW) Split gen_data_data_structures into gen, hms, sos, and coin parts"
+*
+* Revision 1.1 1995/01/27 20:05:23 cdaq
+* Initial revision
+*
+*
+*----------------------------------------------------------------------
+ implicit none
+ save
+*
+ character*13 here
+ parameter (here='h_sv_nt_keep')
+*
+ logical ABORT
+ character*(*) err
+*
+ INCLUDE 'h_sieve_ntuple.cmn'
+ INCLUDE 'hms_data_structures.cmn'
+ INCLUDE 'gen_event_info.cmn'
+*
+ logical HEXIST !CERNLIB function
+*
+ integer m
+*
+*--------------------------------------------------------
+ err= ' '
+ ABORT = .FALSE.
+*
+ IF(.NOT.h_sieve_Ntuple_exists) RETURN !nothing to do
+*
+************************************************
+ m= 0
+*
+ m= m+1
+ h_sieve_Ntuple_contents(m)= HSX_FP ! X focal plane position
+ m= m+1
+ h_sieve_Ntuple_contents(m)= HSY_FP
+ m= m+1
+ h_sieve_Ntuple_contents(m)= HSXP_FP
+ m= m+1
+ h_sieve_Ntuple_contents(m)= HSYP_FP
+ m= m+1
+ h_sieve_Ntuple_contents(m)= HSDELTA
+ m= m+1
+ h_sieve_Ntuple_contents(m)= HSX_TAR
+ m= m+1
+ h_sieve_Ntuple_contents(m)= HSY_TAR
+ m= m+1
+ h_sieve_Ntuple_contents(m)= HSXP_TAR
+ m= m+1
+ h_sieve_Ntuple_contents(m)= HSYP_TAR
+ m= m+1
+ h_sieve_Ntuple_contents(m)= HSTRACK_ET
+ m= m+1
+ h_sieve_Ntuple_contents(m)= HCER_NPE_SUM
+ m= m+1
+ h_sieve_Ntuple_contents(m)= float(gen_event_ID_number)
+*
+************************************************
+*
+*
+ ABORT= .NOT.HEXIST(h_sieve_Ntuple_ID)
+ IF(ABORT) THEN
+ call G_build_note(':Ntuple ID#$ does not exist',
+ & '$',h_sieve_Ntuple_ID,' ',0.,' ',err)
+ call G_add_path(here,err)
+ ELSE
+ call HFN(h_sieve_Ntuple_ID,h_sieve_Ntuple_contents)
+ ENDIF
+*
+ RETURN
+ END
diff --git a/ENGINE/h_sv_nt_register.f b/ENGINE/h_sv_nt_register.f
new file mode 100644
index 0000000..6557f5d
--- /dev/null
+++ b/ENGINE/h_sv_nt_register.f
@@ -0,0 +1,43 @@
+ subroutine h_sv_Nt_register(ABORT,err)
+*----------------------------------------------------------------------
+*
+* CTP variable registration routine for the HMS Sieve Slit Ntuples
+*
+* Purpose : Register output filename for HMS Sieve slit Ntuple; temporary
+* implementation to be superceeded by CTP Ntuples
+*
+* Output: ABORT - success or failure
+* : err - reason for failure, if any
+*
+* Created: 1-Nov-1994 : added Ntuples
+* $Log: h_sv_nt_register.f,v $
+* Revision 1.1 1995/01/27 20:05:51 cdaq
+* Initial revision
+*
+*----------------------------------------------------------------------
+ implicit none
+ save
+*
+ character*17 here
+ parameter (here='h_sv_Nt_register')
+*
+ logical ABORT
+ character*(*) err
+*
+ INCLUDE 'h_sieve_ntuple.cmn'
+ INCLUDE 'gen_routines.dec'
+*
+ integer ierr
+*--------------------------------------------------------
+ err= ' '
+ ABORT = .FALSE.
+*
+ call G_reg_C('HMS_sieve_Ntuple',h_sieve_Ntuple_file,ABORT,err)
+*
+ IF(ABORT) THEN
+ call G_prepend(':unable to register-',err)
+ call G_add_path(here,err)
+ ENDIF
+*
+ return
+ end
diff --git a/ENGINE/h_sv_nt_shutdown.f b/ENGINE/h_sv_nt_shutdown.f
new file mode 100644
index 0000000..c3bfbe4
--- /dev/null
+++ b/ENGINE/h_sv_nt_shutdown.f
@@ -0,0 +1,117 @@
+ subroutine h_sv_Nt_shutdown(ABORT,err)
+*----------------------------------------------------------------------
+*
+* Final shutdown of the HMS Sieve Slit Ntuple
+*
+* Purpose : Flushes and closes the HMS Sieve slit Ntuple
+*
+* Output: ABORT - success or failure
+* : err - reason for failure, if any
+*
+* Created: 1-Nov-1994 added Ntuples
+* $Log: h_sv_nt_shutdown.f,v $
+* Revision 1.2 2003/02/13 15:08:20 jones
+* subroutine call G_build_note had 6 instead needed 7 arguments
+*
+* Revision 1.1 1995/01/27 20:06:10 cdaq
+* Initial revision
+*
+*----------------------------------------------------------------------
+ implicit none
+ save
+*
+ character*17 here
+ parameter (here='h_sv_Nt_shutdown')
+*
+ logical ABORT
+ character*(*) err
+*
+ INCLUDE 'h_sieve_ntuple.cmn'
+ INCLUDE 'gen_routines.dec'
+*
+ logical HEXIST !CERNLIB function
+*
+ logical FAIL
+ character*80 why,directory,name
+ character*1000 pat,msg
+ integer io,id,cycle,m,iv(10)
+*
+*--------------------------------------------------------
+ err= ' '
+ ABORT = .FALSE.
+*
+ IF(.NOT.h_sieve_Ntuple_exists) RETURN !nothing to do
+*
+ call HCDIR(directory,'R') !keep current directory
+
+ id= h_sieve_Ntuple_ID
+ io= h_sieve_Ntuple_IOchannel
+*
+ ABORT= .NOT.HEXIST(id)
+ IF(ABORT) THEN
+ pat= ': Ntuple ID#$ does not exist'
+ call G_build_note(pat,'$',id,' ',0.,' ',err)
+ call G_add_path(here,err)
+ If(io.GT.0) Then
+ call G_IO_control(io,'FREE',FAIL,why) !free up
+ if(.NOT.FAIL) CLOSE(io)
+ EndIf
+ h_sieve_Ntuple_exists= .FALSE.
+ h_sieve_Ntuple_ID= 0
+ h_sieve_Ntuple_name= ' '
+ h_sieve_Ntuple_IOchannel= 0
+ h_sieve_Ntuple_file= ' '
+ h_sieve_Ntuple_title= ' '
+ h_sieve_Ntuple_directory= ' '
+ h_sieve_Ntuple_size= 0
+ do m=1,HMAX_Ntuple_size
+ h_sieve_Ntuple_tag(m)= ' '
+ h_sieve_Ntuple_contents(m)= 0.
+ enddo
+ RETURN
+ ENDIF
+*
+
+ id= h_sieve_Ntuple_ID
+ io= h_sieve_Ntuple_IOchannel
+ name= h_sieve_Ntuple_name
+ call HCDIR(h_sieve_Ntuple_directory,' ') !goto Ntuple directory
+*
+ iv(1)= id
+ iv(2)= io
+ pat= 'closing ID#$ IO#$ "'//h_sieve_Ntuple_file//'"'
+
+ call G_build_note(pat,'$',iv,' ',0.,' ',msg)
+
+ call G_add_path(here,msg)
+
+ call G_log_message('INFO: '//msg)
+
+*
+ cycle= 0 !dummy for HROUT
+ call HROUT(id,cycle,' ') !flush CERNLIB buffers
+
+ call HREND(name) !CERNLIB close file
+* call HDELET(id) !CERNLIB delete tuple
+ call G_IO_control(io,'FREE',ABORT,err) !free up IO channel
+ CLOSE(io) !close IO channel
+*
+ call HCDIR(directory,' ') !return to current directory
+*
+ h_sieve_Ntuple_exists= .FALSE.
+ h_sieve_Ntuple_ID= 0
+ h_sieve_Ntuple_name= ' '
+ h_sieve_Ntuple_IOchannel= 0
+ h_sieve_Ntuple_file= ' '
+ h_sieve_Ntuple_title= ' '
+ h_sieve_Ntuple_directory= ' '
+ h_sieve_Ntuple_size= 0
+ do m=1,HMAX_Ntuple_size
+ h_sieve_Ntuple_tag(m)= ' '
+ h_sieve_Ntuple_contents(m)= 0.
+ enddo
+*
+ IF(ABORT) call G_add_path(here,err)
+*
+ RETURN
+ END
diff --git a/ENGINE/h_tree_init.f b/ENGINE/h_tree_init.f
new file mode 100644
index 0000000..169b17f
--- /dev/null
+++ b/ENGINE/h_tree_init.f
@@ -0,0 +1,30 @@
+ subroutine h_tree_init(abort,err)
+
+ implicit none
+ save
+
+ character*11 here
+ parameter(here='h_tree_init')
+
+ include 'hms_filenames.cmn'
+ include 'gen_routines.dec'
+ include 'hms_data_structures.cmn'
+ include 'gen_run_info.cmn'
+
+ logical abort
+ character*(*) err
+
+c only purpose of this routine is to substitute run number in
+c tree filename! CTP will take care of the rest!!!!!!!!!!!
+
+ call no_nulls(h_tree_filename)
+
+ if(h_tree_filename.eq.' ') return
+
+ call g_sub_run_number(h_tree_filename,gen_run_number)
+
+ abort=.false.
+ err=' '
+
+ return
+ end
diff --git a/ENGINE/params03.f b/ENGINE/params03.f
new file mode 100644
index 0000000..122ca88
--- /dev/null
+++ b/ENGINE/params03.f
@@ -0,0 +1,110 @@
+c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+c File param.f
+c
+c Contains the paraeterizations for both magnets.
+c Bneedd calculated B(p) for the dipole.
+c Ineedq calculates I(B.dl) for the quadrupoles.
+c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+c HISTORY
+c
+c 9Mar1999 DWM The fitting program had the same sign problem. New fit.
+c 8Mar1999 DWM fixed messed up signs on quadrupole constant parameters.
+c 27Feb1999 DWM Restored disabled parameterization with the correct
+c quadratic coeficient. Thanks Maurice.
+c 27Feb1999 MauriceB disabled parametrization for B>0.98T
+c 20Jan1999 DWM. First seperated from the main body of the field program
+c Changed to use the arrays for holding the parameters, instead of
+c imbedding them in a bunch of explicit calculations.
+c---------------------------------------------------------------------------
+
+c============================================================================
+c Function Bneedd
+c Calculate the fieldrequired for the dipole at a given current ``p''.
+c============================================================================
+ real*8 function Bneedd (p,silent)
+
+ implicit none
+
+ real*8 p
+ integer silent ! If not zero, don't print any diagnostics
+
+c The parameters of the magnet fits
+ real*8 FIELD_D
+ real*8 EFL_0, CUTOFF, QUADRATIC
+
+c Some intermediate values.
+ real*8 B0, B
+
+
+c Dipole field for 1 GeV is 0.2765
+ data FIELD_D /0.2765/
+ data EFL_0 /5.199/
+ data CUTOFF /0.9836/
+ data QUADRATIC /-7.3137e-2/
+
+
+c This is it.
+c Grind through the parameterization
+ B0 = p * FIELD_D
+
+ if (B0 .le. CUTOFF) then
+ B = B0
+ else
+c B = B0 * (1 - (B0 - CUTOFF)**2 * QUADRATIC / EFL_0 )
+ B = B0
+ if(silent.eq.0)
+ $ write(*,*) '###Parameterization for B>',CUTOFF
+ $ ,' is disabled###'
+ endif
+
+ Bneedd = B
+ return
+ end
+
+
+c============================================================================
+c Function Ineedq
+c Calculate the current required for quadrupole number `num'
+c to reach a the given `bl' (B.dl in Rolf's notation),
+c============================================================================
+ real*8 function Ineedq (bl,num)
+
+ implicit none
+
+ real*8 bl
+ integer num
+
+ integer NUM_MAGS
+ parameter (NUM_MAGS=3)
+
+c The parameters of the magnet fits
+ real*8 cutoff(NUM_MAGS), constant(NUM_MAGS)
+ real*8 linear(NUM_MAGS), cubic(NUM_MAGS)
+
+c The current needed.
+ real*8 cur
+
+c Q1 Q2 Q3
+c data cutoff / 2.114, 2.409, 2.389 /
+c data constant / 0.139, 0.277, 0.271 /
+c data linear / 297.38, 189.89, 189.28 /
+c data cubic / 9.55, 12.99, 12.68 /
+ data cutoff / 2.146, 2.423, 2.402 /
+ data constant / -0.139, -0.277, -0.271 /
+ data linear / 297.56, 190.19, 189.56 /
+ data cubic / 10.15, 13.18, 12.84 /
+
+
+c This is it.
+c Grind through the parameterization
+ if (bl .le. cutoff(num)) then
+ cur = constant(num) + linear(num) * bl
+ else
+ cur = constant(num) + linear(num) * bl
+ 1 + (bl - cutoff(num))**3 * cubic(num)
+ endif
+
+ Ineedq = cur
+ return
+ end
+
diff --git a/ENGINE/s_apply_offsets.f b/ENGINE/s_apply_offsets.f
new file mode 100644
index 0000000..a75dd38
--- /dev/null
+++ b/ENGINE/s_apply_offsets.f
@@ -0,0 +1,77 @@
+ SUBROUTINE S_apply_offsets(ABORT,err)
+*--------------------------------------------------------
+*- Prototype C analysis routine
+*-
+*-
+*- Purpose and Methods : applies offsets to SOS
+*- central momentum and central angle.
+*-
+*-
+*- Output: ABORT - success or failure
+*- : err - reason for failure, if any
+*-
+*- Created 31-Aug-1999 Chris Armstrong
+*-
+*-
+*- All standards are from "Proposal for Hall C Analysis Software
+*- Vade Mecum, Draft 1.0" by D.F.Geesamn and S.Wood, 7 May 1993
+*-
+*-
+*--------------------------------------------------------
+ IMPLICIT NONE
+ SAVE
+*
+ character*15 here
+ parameter (here= 'S_apply_offsets')
+*
+ logical ABORT
+ character*(*) err
+*
+ INCLUDE 'sos_data_structures.cmn'
+ INCLUDE 'sos_physics_sing.cmn'
+ INCLUDE 'gen_constants.par'
+*
+*--------------------------------------------------------
+*
+
+
+* csa 8/31/99 -- We really should be filling *new* variables
+* here!
+
+ if (s_oopcentral_offset .ne. 0 ) then
+ write(*,*) ' ******'
+ write(6,*)' s_apply_offs: s_oopcentral_offset =',s_oopcentral_offset,' rad'
+ write(6,*)' Used to offset ssxp_tar in s_physics.f '
+ endif
+c
+ if (spcentral_offset .ne. 0 ) then
+ write(*,*) ' ******'
+ write(6,*)' s_apply_offs: apply spcentral_offset(%) =',spcentral_offset
+ write(6,*)' s_apply_offs: before: spcentral =',spcentral
+ spcentral = spcentral * ( 1. + spcentral_offset / 100. )
+ write(6,*)' s_apply_offs: after: spcentral =',spcentral
+ endif
+c
+ if (smomentum_factor .gt. 0.1) then !avoid setting p=0
+ write(*,*) ' ******'
+ write(6,*)' s_apply_offs: apply smomentum_factor =',smomentum_factor
+ write(6,*)' s_apply_offs: before: spcentral =',spcentral
+ spcentral = spcentral * smomentum_factor
+ write(6,*)' s_apply_offs: after : spcentral =',spcentral
+ endif
+c
+ if (sthetacentral_offset .ne. 0 ) then
+ write(*,*) ' ******'
+ write(6,*)' s_apply_offs: before: stheta_lab =',stheta_lab
+ stheta_lab=stheta_lab + sthetacentral_offset/degree
+ write(6,*)' s_apply_offs: after: stheta_lab =',stheta_lab
+ cossthetas = cos(stheta_lab*degree)
+ sinsthetas = sin(stheta_lab*degree)
+ endif
+
+
+
+ ABORT= .FALSE.
+ err= ' '
+ RETURN
+ END
diff --git a/ENGINE/s_clear_event.f b/ENGINE/s_clear_event.f
new file mode 100644
index 0000000..edbd428
--- /dev/null
+++ b/ENGINE/s_clear_event.f
@@ -0,0 +1,137 @@
+ SUBROUTINE S_clear_event(ABORT,err)
+*--------------------------------------------------------
+*- Prototype C analysis routine
+*-
+*-
+*- Purpose and Methods : clears all SOS quantities before event is processed.
+*-
+*-
+*- Output: ABORT - success or failure
+*- : err - reason for failure, if any
+*-
+*- Created 2-Nov-1993 Kevin B. Beard
+*- Modified 20-Nov-1993 KBB for new errors
+* $Log: s_clear_event.f,v $
+* Revision 1.12 1999/02/23 18:27:50 csa
+* Add call to s_ntuple_clear
+*
+* Revision 1.11 1996/11/05 21:42:56 saw
+* (WH) Add lucite counter
+*
+* Revision 1.10 1995/10/09 18:08:15 cdaq
+* (JRA) Add clear of SCER_RAW_ADC
+*
+* Revision 1.9 1995/09/01 13:40:55 cdaq
+* (JRA) Clear some cerenkov variables
+*
+* Revision 1.8 1995/05/22 20:50:48 cdaq
+* (SAW) Split gen_data_data_structures into gen, hms, sos, and coin parts"
+*
+* Revision 1.7 1995/05/11 15:08:57 cdaq
+* (SAW) Add clear of Aerogel hit counter
+*
+* Revision 1.6 1995/04/01 20:10:55 cdaq
+* (SAW) Add missing SSCIN_ALL_TOT_HITS = 0
+*
+* Revision 1.5 1994/11/22 20:14:23 cdaq
+* (SPB) Bring up to date with h_clear_event
+*
+* Revision 1.4 1994/06/22 20:53:59 cdaq
+* (SAW) zero the miscleaneous hits counter
+*
+* Revision 1.3 1994/03/01 20:14:32 cdaq
+* (SAW) Add zeroing of the raw total hits counter for the drift chambers
+*
+* Revision 1.2 1994/02/22 19:04:02 cdaq
+* (SAW) SNUM_DC_PLANES --> SMAX_NUM_DC_PLANES
+*
+* Revision 1.1 1994/02/04 22:21:07 cdaq
+* Initial revision
+*
+*-
+*- All standards are from "Proposal for Hall C Analysis Software
+*- Vade Mecum, Draft 1.0" by D.F.Geesamn and S.Wood, 7 May 1993
+*-
+*--------------------------------------------------------
+ IMPLICIT NONE
+ SAVE
+*
+ character*13 here
+ parameter (here= 'S_clear_event')
+*
+ logical ABORT
+ character*(*) err
+*
+ INCLUDE 'sos_data_structures.cmn'
+ INCLUDE 'sos_tracking.cmn'
+ INCLUDE 'sos_statistics.cmn'
+ INCLUDE 'sos_scin_tof.cmn'
+ INCLUDE 'sos_scin_parms.cmn'
+ INCLUDE 'sos_cer_parms.cmn'
+ INCLUDE 'sos_calorimeter.cmn'
+*
+ INTEGER plane,tube
+*
+*--------------------------------------------------------
+*
+ SDC_RAW_TOT_HITS = 0
+*
+ SDC_TOT_HITS = 0
+*
+ DO plane= 1,SMAX_NUM_DC_PLANES
+ SDC_HITS_PER_PLANE(plane)= 0
+ ENDDO
+*
+ SSCIN_ALL_TOT_HITS = 0
+ SSCIN_TOT_HITS = 0
+*
+ DO plane= 1,SNUM_SCIN_PLANES
+ SSCIN_HITS_PER_PLANE(plane)= 0
+ ENDDO
+*
+* SOS CALORIMETER HITS
+*
+ SCAL_TOT_HITS= 0
+*
+ SCAL_NUM_HITS= 0
+*
+* SOS CERENKOV HITS
+*
+ SCER_TOT_HITS= 0
+ do tube = 1, SMAX_CER_HITS
+ SCER_RAW_ADC(tube) = 0
+ SCER_ADC(tube) = 0
+ SCER_NPE(tube) = 0.
+ enddo
+
+*
+* SOS AEROGEL HITS
+*
+ SAER_TOT_HITS = 0
+*
+* SOS LUCITE HITS
+*
+ SLUC_TOT_HITS = 0
+*
+* SOS Miscleaneous hits
+*
+ SMISC_TOT_HITS = 0
+*
+* SOS DETECTOR TRACK QUANTITIES
+*
+ SNTRACKS_FP= 0
+*
+* SOS TARGET QUANTITIES
+*
+ SNTRACKS_TAR= 0
+*
+ SSNUM_FPTRACK = 0
+ SSNUM_TARTRACK = 0
+*
+
+ call s_ntuple_clear
+
+ ABORT= .FALSE.
+ err= ' '
+ RETURN
+ END
diff --git a/ENGINE/s_fieldcorr.f b/ENGINE/s_fieldcorr.f
new file mode 100644
index 0000000..34140d0
--- /dev/null
+++ b/ENGINE/s_fieldcorr.f
@@ -0,0 +1,76 @@
+ SUBROUTINE S_fieldcorr(ABORT,err)
+*--------------------------------------------------------
+*- Prototype C analysis routine
+*-
+*-
+*- Purpose and Methods : apply correction to SOS
+*- central momentum as function of momentum.
+*-
+*-
+*- Output: ABORT - success or failure
+*- : err - reason for failure, if any
+*-
+*- Created 18-Feb-1999 M Jones
+*-
+*-
+*- All standards are from "Proposal for Hall C Analysis Software
+*- Vade Mecum, Draft 1.0" by D.F.Geesamn and S.Wood, 7 May 1993
+*-
+*-
+*--------------------------------------------------------
+ IMPLICIT NONE
+ SAVE
+*
+ character*11 here
+ parameter (here= 'S_fieldcorr')
+*
+ logical ABORT
+ character*(*) err
+*
+ include 'gen_data_structures.cmn'
+ INCLUDE 'sos_data_structures.cmn'
+*
+* local variables
+ real*8 sosp0corr
+*--------------------------------------------------------
+*
+
+ if (genable_sos_fieldcorr .eq. 1999 ) then
+ write(*,*) ' ******'
+ write(*,*) ' Enabled SOS central momentum correction'
+ write(*,*) ' Using J. Volmer parametrization'
+ write(*,*) ' Before correction: central mom = ',spcentral
+ sosp0corr=0.45
+ if (spcentral .gt. 0.51) sosp0corr=0.496-0.08845*spcentral
+ > -5.743e-4*exp(2.341*(spcentral**2.156))
+ spcentral = spcentral*(1+sosp0corr/100.)
+ write(*,*) ' After correction: central mom = ',spcentral
+ write(*,*) ' ******'
+ elseif (genable_sos_fieldcorr .eq. 2003 ) then
+ write(*,*) ' ******'
+ write(*,*) ' Enabled SOS central momentum correction'
+ write(*,*) ' Using C. Xu parametrization (2003)'
+ write(*,*) ' Before correction: central mom = ',spcentral
+
+ sosp0corr=0.035
+ if (spcentral .gt. 0.51)sosp0corr=0.10256 - 0.13242*spcentral
+ > -1.67002e-4*exp(2.33*(spcentral**2.4))
+ spcentral = spcentral*(1+sosp0corr/100.)
+ write(*,*) ' After correction: central mom = ',spcentral
+ write(*,*) ' ******'
+ else
+ write(*,*) ' ******'
+ write(*,*) ' SOS central momentum correction not enabled'
+ write(*,*) ' It is probably wise to enable by setting'
+ write(*,*) ' genable_sos_fieldcorr = 2003 '
+ write(*,*) ' to use C. Xu parametrization (2003)'
+ write(*,*) ' or genable_sos_fieldcorr = 1999 '
+ write(*,*) ' to use J. Volmer parametrization'
+ write(*,*) ' Set parameter in sosflags.param'
+ write(*,*) ' ******'
+ endif
+c
+ ABORT= .FALSE.
+ err= ' '
+ RETURN
+ END
diff --git a/ENGINE/s_initialize.f b/ENGINE/s_initialize.f
new file mode 100644
index 0000000..67f1c67
--- /dev/null
+++ b/ENGINE/s_initialize.f
@@ -0,0 +1,145 @@
+ SUBROUTINE S_initialize(ABORT,err)
+*--------------------------------------------------------
+*- Prototype C analysis routine
+*-
+*-
+*- Purpose and Methods : Initializes HMS quantities
+*-
+*- Output: ABORT - success or failure
+*- : err - reason for failure, if any
+*-
+*- Created 8-Nov-1993 Kevin B. Beard
+*- Modified 20-Nov-1993 KBB for new errors
+* $Log: s_initialize.f,v $
+* Revision 1.16 1996/09/04 15:17:01 saw
+* (JRA) Reorder calls
+*
+* Revision 1.15 1996/01/16 16:12:41 cdaq
+* (JRA) Comment out SOS minuit initialization
+*
+* Revision 1.14 1995/10/09 18:47:01 cdaq
+* (SAW) Move ntuple initialization into g_ntuple_init
+*
+* Revision 1.13 1995/08/11 15:37:05 cdaq
+* (DD) Add sos sieve slit ntuple
+*
+* Revision 1.12 1994/11/22 20:15:10 cdaq
+* (SAW) Cosmetic change
+*
+* Revision 1.11 1994/06/17 04:02:58 cdaq
+* (KBB) Upgrade error reporting
+*
+* Revision 1.10 1994/06/16 03:46:17 cdaq
+* *** empty log message ***
+*
+* Revision 1.9 1994/06/14 04:03:48 cdaq
+* (DFG) Add call to s_init_physics
+*
+* Revision 1.8 1994/05/13 03:13:45 cdaq
+* (DFG) Add call to s_targ_trans_init
+*
+* Revision 1.7 1994/04/13 18:15:23 cdaq
+* (DFG) Add scin and cal init
+*
+* Revision 1.6 1994/04/12 17:31:09 cdaq
+* (KBB) Add ntuple call
+*
+* Revision 1.5 1994/02/22 15:14:03 cdaq
+* (DFG) Add calls to s_generate_geometry and s_initialize_fitting
+*
+* Revision 1.4 1994/02/11 18:36:35 cdaq
+* Split off CTP variables registration from initialize routines
+*
+* Revision 1.3 1994/02/04 20:47:40 cdaq
+* Add read titles to regpar calls
+*
+* Revision 1.2 1994/02/03 14:28:27 cdaq
+* Make clear that last arg of reg calls is a title. Use null for now.
+*
+* Revision 1.1 1994/02/02 21:37:55 cdaq
+* Initial revision
+*
+*-
+*- All standards are from "Proposal for Hall C Analysis Software
+*- Vade Mecum, Draft 1.0" by D.F.Geesamn and S.Wood, 7 May 1993
+*-
+*--------------------------------------------------------
+ IMPLICIT NONE
+ SAVE
+*
+ character*12 here
+ parameter (here= 'S_initialize')
+*
+ logical ABORT
+ character*(*) err
+ character*20 err1
+ integer*4 istat
+*
+ logical FAIL
+ character*1000 why
+*SDISPLAY*
+*SDISPLAY include 'one_ev_io.cmn'
+*
+*--------------------------------------------------------
+ ABORT = .FALSE.
+ err= ' '
+*
+*-calculate physics singles constants
+ call s_init_physics(FAIL,why)
+ if(err.NE.' ' .and. why.NE.' ') then
+ call G_append(err,' & '//why)
+ elseif(why.NE.' ') then
+ err= why
+ endif
+ ABORT= ABORT .or. FAIL
+*
+*
+ call s_generate_geometry ! Tracking routine
+*
+c call s_initialize_fitting ! Minuit initialization
+*
+*-calculate secondary scintillator and time of flight parameters
+ call s_init_scin(FAIL,why)
+ if(why.NE.' ') then
+ err= why
+ endif
+ ABORT= ABORT .or. FAIL
+*
+*-calculate secondary cerenkov parameters
+ call s_init_cer(FAIL,why)
+ if(err.NE.' ' .and. why.NE.' ') then
+ call G_append(err,' & '//why)
+ elseif(why.NE.' ') then
+ err= why
+ endif
+ ABORT= ABORT .or. FAIL
+*
+*-calculate secondary calorimeter parameters
+ call s_init_cal(FAIL,why)
+ if(err.NE.' ' .and. why.NE.' ') then !keep warnings
+ call G_append(err,' & '//why)
+ elseif(why.NE.' ') then
+ err= why
+ endif
+ ABORT= ABORT .or. FAIL
+*SDISPLAY* If one_ev flag on, initialize the event display package
+* if(one_ev.ne.0) call one_ev_init !One event display unit
+*
+*
+*-read in Optical matrix elements
+ call s_targ_trans_init(FAIL,why,istat)
+ if(FAIL) then
+ write(err1,'(":istat=",i2)') istat
+ call G_prepend(err1,why)
+ endif
+ if(err.NE.' ' .and. why.NE.' ') then !keep warnings
+ call G_append(err,' & '//why)
+ elseif(why.NE.' ') then
+ err= why
+ endif
+ ABORT= ABORT .or. FAIL
+*
+ if(ABORT .or. err.NE.' ') call g_add_path(here,err)
+*
+ return
+ end
diff --git a/ENGINE/s_keep_results.f b/ENGINE/s_keep_results.f
new file mode 100644
index 0000000..e7799df
--- /dev/null
+++ b/ENGINE/s_keep_results.f
@@ -0,0 +1,73 @@
+ SUBROUTINE S_keep_results(ABORT,err)
+*--------------------------------------------------------
+*- Prototype C analysis routine
+*-
+*-
+*- Purpose and Methods : Keeps statistics, etc.
+*-
+*- Output: ABORT - success or failure
+*- : err - reason for failure, if any
+*-
+*- Created 20-Nov-1993 Kevin B. Beard for new error standards
+*
+* $Log: s_keep_results.f,v $
+* Revision 1.6 1996/09/04 15:17:33 saw
+* (JRA) Make SSNUM_FPTRACK.gt.0 instead of SNTRACKS_FP .gt. 0 the
+* criteria for adding to ntuples
+*
+* Revision 1.5 1996/01/16 16:42:34 cdaq
+* no change
+*
+* Revision 1.4 1995/08/11 15:43:11 cdaq
+* (DD) Add sos sieve slit ntuple
+*
+* Revision 1.3 1995/07/27 19:43:52 cdaq
+* (JRA) Only add to ntuples when we have HNTRACKS_FP > 0
+*
+* Revision 1.2 1994/04/12 17:29:18 cdaq
+* (KBB) Add ntuple call
+*
+* Revision 1.1 1994/02/04 22:18:31 cdaq
+* Initial revision
+*
+*- All standards are from "Proposal for Hall C Analysis Software
+*- Vade Mecum, Draft 1.0" by D.F.Geesamn and S.Wood, 7 May 1993
+*-
+*--------------------------------------------------------
+ IMPLICIT NONE
+ SAVE
+*
+ include 'sos_data_structures.cmn'
+*
+ character*50 here
+ parameter (here= 'S_keep_results')
+*
+ logical ABORT
+ character*(*) err
+*
+*--------------------------------------------------------
+*-chance to flush any statistics, etc.
+*
+*
+ ABORT= .FALSE.
+ err= ' '
+*
+ if(SSNUM_FPTRACK.gt.0) call s_ntuple_keep(ABORT,err)! check for good tracks.
+* proceed only if tracks found is greater than zero.
+*
+*
+ IF(ABORT) THEN
+ call G_add_path(here,err)
+ ELSE
+ err= ' '
+ ENDIF
+ if(SSNUM_FPTRACK.gt.0)call s_sv_nt_keep(ABORT,err)
+*
+ IF(ABORT) THEN
+ call G_add_path(here,err)
+ ELSE
+ err= ' '
+ ENDIF
+*
+ RETURN
+ END
diff --git a/ENGINE/s_ntuple_change.f b/ENGINE/s_ntuple_change.f
new file mode 100644
index 0000000..aef49d3
--- /dev/null
+++ b/ENGINE/s_ntuple_change.f
@@ -0,0 +1,87 @@
+ subroutine s_ntuple_change(ABORT,err)
+*----------------------------------------------------------------------
+*
+* closes one HMS Ntuple file and opens another
+*
+* Purpose : switching from one file to the next
+*
+* Output: ABORT - success or failure
+* : err - reason for failure, if any
+*
+*----------------------------------------------------------------------
+
+ implicit none
+ save
+
+ character*15 here
+ parameter (here='s_ntuple_change')
+
+ logical ABORT
+ character*(*) err
+
+ INCLUDE 's_ntuple.cmn'
+ include 'gen_run_info.cmn'
+
+ character*1 ifile
+ character*80 file
+ character*1000 pat
+
+ integer*4 ilo,fn_len
+
+* functions
+ integer g_important_length
+
+*--------------------------------------------------------
+
+
+ call s_ntuple_close(ABORT,err)
+
+
+
+ if (s_ntuple_exists) then
+ ABORT = .true.
+ endif
+
+ call NO_nulls(s_ntuple_file) !replace null characters with blanks
+
+ file= s_ntuple_file
+ call NO_nulls(file) !replace null characters with blanks
+ call g_sub_run_number(file,gen_run_number)
+
+ s_ntuple_filesegments = s_ntuple_filesegments + 1
+
+ if (s_ntuple_filesegments .le. 9) then
+ ifile = char(ichar('0')+s_ntuple_filesegments)
+ else
+ ifile = char(ichar('a')+s_ntuple_filesegments-10)
+ endif
+
+ fn_len = g_important_length(file)
+ ilo=index(file,'.hbook')
+ if ((ilo.le.1).or.(ilo.gt.fn_len-5)) then
+ ilo=index(file,'.rzdat')
+ endif
+
+ if ((ilo.gt.1).and.(ilo.lt.fn_len)) then
+ file = file(1:ilo-1) // '.' // ifile // file(ilo:fn_len)
+ else
+ ABORT = .true.
+ endif
+
+
+
+ IF (.not.ABORT) call s_ntuple_open(file,ABORT,err)
+
+
+ IF(ABORT) THEN
+ err= ':unable to change SOS Ntuple file segment'
+ call G_add_path(here,err)
+ ELSE
+ pat= ':changed SOS Ntuple file segment'
+ call G_add_path(here,pat)
+ call G_log_message('INFO: '//pat)
+ ENDIF
+
+
+ RETURN
+ END
diff --git a/ENGINE/s_ntuple_clear.f b/ENGINE/s_ntuple_clear.f
new file mode 100644
index 0000000..38c6a0c
--- /dev/null
+++ b/ENGINE/s_ntuple_clear.f
@@ -0,0 +1,30 @@
+ subroutine s_Ntuple_clear
+*----------------------------------------------------------------------
+*
+* Purpose : Clear vars that go to the SOS Ntuple
+*
+* csa 4/15/97
+*
+* $Log: s_ntuple_clear.f,v $
+* Revision 1.1 1999/02/24 14:50:24 saw
+* Dummy routine
+*
+*
+*----------------------------------------------------------------------
+ implicit none
+ save
+*
+* character*13 here
+* parameter (here='s_Ntuple_clear')
+*
+* logical ABORT
+* character*(*) err
+*
+
+* csa 2/2/99 -- This is a dummy routine in the CVS tree. The
+* real thing gets created in the user's Oscar directory based
+* on which variables are in the ntuple.lst file.
+
+*
+ RETURN
+ END
diff --git a/ENGINE/s_ntuple_close.f b/ENGINE/s_ntuple_close.f
new file mode 100644
index 0000000..b132976
--- /dev/null
+++ b/ENGINE/s_ntuple_close.f
@@ -0,0 +1,77 @@
+ subroutine s_Ntuple_close(ABORT,err)
+*----------------------------------------------------------------------
+*
+* closes the HMS Ntuple file
+*
+* Purpose : Flushes and closes the HMS Ntuple
+*
+* Output: ABORT - success or failure
+* : err - reason for failure, if any
+*
+*----------------------------------------------------------------------
+
+ implicit none
+ save
+
+ character*14 here
+ parameter (here='s_Ntuple_close')
+
+ logical ABORT
+ character*(*) err
+*
+ INCLUDE 's_ntuple.cmn'
+ INCLUDE 'gen_routines.dec'
+*
+ logical HEXIST !CERNLIB function
+*
+ logical FAIL
+ character*80 why,directory,name
+ character*1000 msg
+ integer io,id,cycle,m
+*
+*--------------------------------------------------------
+
+ err= ' '
+ ABORT = .FALSE.
+
+ IF(.NOT.s_Ntuple_exists) RETURN !nothing to do
+
+ call HCDIR(directory,'R') !keep current directory
+
+ id= s_Ntuple_ID
+ io= s_Ntuple_IOchannel
+ name= s_Ntuple_name
+
+ ABORT= .NOT.HEXIST(id)
+ IF(ABORT) THEN
+ call G_add_path(here,err)
+ If(io.GT.0) Then
+ call G_IO_control(io,'FREE',FAIL,why) !free up
+ if(.NOT.FAIL) CLOSE(io)
+ EndIf
+ s_Ntuple_exists= .FALSE.
+ s_Ntuple_IOchannel= 0
+ RETURN
+ ENDIF
+
+ call HCDIR(s_Ntuple_directory,' ') !goto Ntuple directory
+
+ call G_add_path(here,msg)
+ call G_log_message('INFO: '//msg)
+
+ cycle= 0 !dummy for HROUT
+ call HROUT(id,cycle,' ') !flush CERNLIB buffers
+ call HREND(name) !CERNLIB close file
+ call G_IO_control(io,'FREE',ABORT,err) !free up IO channel
+ CLOSE(io) !close IO channel
+
+ call HCDIR(directory,' ') !return to current directory
+
+ s_Ntuple_directory= ' '
+ s_Ntuple_exists= .FALSE.
+ s_Ntuple_IOchannel= 0
+
+ IF(ABORT) call G_add_path(here,err)
+
+ RETURN
+ END
diff --git a/ENGINE/s_ntuple_init.f b/ENGINE/s_ntuple_init.f
new file mode 100644
index 0000000..fcfccb4
--- /dev/null
+++ b/ENGINE/s_ntuple_init.f
@@ -0,0 +1,243 @@
+ subroutine s_Ntuple_init(ABORT,err)
+*----------------------------------------------------------------------
+*
+* Creates an SOS Ntuple
+*
+* Purpose : Books an SOS Ntuple; defines structure of it
+*
+* Output: ABORT - success or failure
+* : err - reason for failure, if any
+*
+* Created: 8-Apr-1994 K.B.Beard, Hampton Univ.
+* $Log: s_ntuple_init.f,v $
+* Revision 1.8.18.1 2007/10/16 20:20:31 cdaq
+* *** empty log message ***
+*
+* Revision 1.8 2004/02/17 17:26:34 jones
+* Changes to enable possiblity of segmenting rzdat files
+*
+* Revision 1.7.2.3 2003/08/12 17:35:32 cdaq
+* Add variables for e00-108 (hamlet)
+*
+* Revision 1.7.2.2 2003/06/26 12:39:52 cdaq
+* changes for e01-001 (mkj)
+*
+* Revision 1.7.2.1 2003/04/04 12:54:42 cdaq
+* add beam parameters to ntuple
+*
+* Revision 1.7 1996/09/04 15:18:02 saw
+* (JRA) Modify ntuple contents
+*
+* Revision 1.6 1996/01/16 16:41:14 cdaq
+* (JRA) Modify ntuple contents
+*
+* Revision 1.5 1995/09/01 13:38:59 cdaq
+* (JRA) Add Cerenkov photoelectron count to ntuple
+*
+* Revision 1.4 1995/07/27 19:00:31 cdaq
+* (SAW) Relocate data statements for f2c compatibility
+*
+* Revision 1.3 1995/05/11 19:00:02 cdaq
+* (SAW) Allow %d for run number in filenames
+*
+* Revision 1.2 1994/06/17 02:36:00 cdaq
+* (KBB) Upgrade
+*
+* Revision 1.1 1994/04/12 16:16:18 cdaq
+* Initial revision
+*
+*
+*----------------------------------------------------------------------
+ implicit none
+ save
+*
+ character*13 here
+ parameter (here='s_Ntuple_init')
+*
+ logical ABORT
+ character*(*) err
+*
+ INCLUDE 's_ntuple.cmn'
+ INCLUDE 'gen_routines.dec'
+ include 'gen_run_info.cmn'
+*
+ character*80 default_name
+ parameter (default_name= 'SOSntuple')
+c
+ character*80 file
+ character*80 name
+ character*1000 pat,msg
+ integerilo,fn_len,m
+ character*1 ifile
+ INCLUDE 's_ntuple.dte'
+*
+*--------------------------------------------------------
+ err= ' '
+ ABORT = .FALSE.
+*
+ IF(s_Ntuple_exists) THEN
+ call s_Ntuple_shutdown(ABORT,err)
+ If(ABORT) Then
+ call G_add_path(here,err)
+ RETURN
+ EndIf
+ ENDIF
+*
+ call NO_nulls(s_Ntuple_file) !replace null characters with blanks
+*
+*-if name blank, just forget it
+ IF(s_Ntuple_file.EQ.' ') RETURN !do nothing
+ s_Ntuple_ID= default_s_Ntuple_ID
+ s_Ntuple_name= default_name
+ IF(s_Ntuple_title.EQ.' ') THEN
+ msg= name//' '//s_Ntuple_file
+ call only_one_blank(msg)
+ s_Ntuple_title= msg
+ ENDIF
+*
+ file= s_Ntuple_file
+ call g_sub_run_number(file,gen_run_number)
+
+
+* * only needed if using more than one file
+ if (s_Ntuple_max_segmentevents .gt. 0) then
+ s_Ntuple_filesegments = 1
+
+ ifile = char(ichar('0')+s_Ntuple_filesegments)
+
+ fn_len = g_important_length(file)
+ ilo=index(file,'.hbook')
+ if ((ilo.le.1).or.(ilo.gt.fn_len-5)) then
+ ilo=index(file,'.rzdat')
+ endif
+
+ if ((ilo.gt.1).and.(ilo.lt.fn_len)) then
+ file = file(1:ilo-1) // '.' // ifile // file(ilo:fn_len)
+ else
+ ABORT = .true.
+ RETURN
+ endif
+ write(*,*) ' Using segmented SOS rzdat files first filename: ',file
+ else
+ write(*,*) ' Not using segmented SOS rzdat files.'
+ endif
+*
+ m= 0
+ m= m+1
+ s_Ntuple_tag(m)= 'omega' !
+ m= m+1
+ s_Ntuple_tag(m)= 'q2' !
+ m= m+1
+ s_Ntuple_tag(m)= 'xbj' !
+ m= m+1
+ s_Ntuple_tag(m)= 'qabs' !
+ m= m+1
+ s_Ntuple_tag(m)= 'W2' !
+ m= m+1
+ s_Ntuple_tag(m)= 'ssthet_g' !
+
+ m= m+1
+ s_Ntuple_tag(m)= 'scer_npe' ! cerenkov photoelectron spectrum
+ m= m+1
+ s_Ntuple_tag(m)= 'ssp' ! Lab momentum of chosen track in GeV/c
+ m= m+1
+ s_Ntuple_tag(m)= 'ssenergy'! Lab total energy of chosen track in GeV
+ m= m+1
+ s_Ntuple_tag(m)= 'ssdelta' ! Spectrometer delta of chosen track
+ m= m+1
+ s_Ntuple_tag(m)= 'sstheta' ! Lab Scattering angle in radians
+ m= m+1
+ s_Ntuple_tag(m)= 'ssphi' ! Lab Azymuthal angle in radians
+ m= m+1
+ s_Ntuple_tag(m)= 'w' ! Invariant Mass of remaing hadronic system
+ m= m+1
+ s_Ntuple_tag(m)= 'sszbeam'! Lab Z coordinate of intersection of beam
+ ! track with spectrometer ray
+ m= m+1
+ s_Ntuple_tag(m)= 'ssdedx1' ! DEDX of chosen track in 1st scin plane
+ m= m+1
+ s_Ntuple_tag(m)= 'ssbeta' ! BETA of chosen track
+ m= m+1
+ s_Ntuple_tag(m)= 'ssshtrk' ! 'SSTRACK_ET' ! Total shower energy of chosen track
+ m= m+1
+ s_Ntuple_tag(m)= 'ssprtrk'!'SSTRACK_PRESHOWER_E' ! preshower of chosen track
+ m= m+1
+ s_Ntuple_tag(m)= 'ssxfp' ! X focal plane position
+ m= m+1
+ s_Ntuple_tag(m)= 'ssyfp'
+ m= m+1
+ s_Ntuple_tag(m)= 'ssxpfp'
+ m= m+1
+ s_Ntuple_tag(m)= 'ssypfp'
+ m= m+1
+ s_Ntuple_tag(m)= 'ssytar'
+ m= m+1
+ s_Ntuple_tag(m)= 'ssxptar'
+ m= m+1
+ s_Ntuple_tag(m)= 'ssyptar'
+ m= m+1
+ s_Ntuple_tag(m)= 'eventID'
+ m= m+1
+ s_Ntuple_tag(m)= 'evtype'
+ m= m+1
+ s_Ntuple_tag(m)= 'sstart'
+ m= m+1
+ s_Ntuple_tag(m)= 'SAER_NPE'
+
+
+* Experiment dependent entries start here.
+ m= m+1
+ s_Ntuple_tag(m)= 'gfrx_raw'
+ m= m+1
+ s_Ntuple_tag(m)= 'gfry_raw'
+ m= m+1
+ s_Ntuple_tag(m)= 'gbeam_x'
+ m= m+1
+ s_Ntuple_tag(m)= 'gbeam_y'
+ m= m+1
+ s_Ntuple_tag(m)= 'bpma_x'
+ m= m+1
+ s_Ntuple_tag(m)= 'bpma_y'
+ m= m+1
+ s_Ntuple_tag(m)= 'bpmb_x'
+ m= m+1
+ s_Ntuple_tag(m)= 'bpmb_y'
+ m= m+1
+ s_Ntuple_tag(m)= 'bpmc_x'
+ m= m+1
+ s_Ntuple_tag(m)= 'bpmc_y'
+ m= m+1
+ s_Ntuple_tag(m)= 'MPSclock'
+ m= m+1
+ s_Ntuple_tag(m)= 'hplus'
+ m= m+1
+ s_Ntuple_tag(m)= 'hminus'
+ m= m+1
+ s_Ntuple_tag(m)= 'sceradc1'
+ m= m+1
+ s_Ntuple_tag(m)= 'sceradc2'
+ m= m+1
+ s_Ntuple_tag(m)= 'sceradc3'
+ m= m+1
+ s_Ntuple_tag(m)= 'sceradc4'
+
+
+* Open ntuple.
+*
+ s_Ntuple_size= m !total size
+*
+* Open ntuple
+
+ call s_Ntuple_open(file,ABORT,err)
+
+ IF(ABORT) THEN
+ err= ':unable to create SOS Ntuple'
+ call G_add_path(here,err)
+ ELSE
+ pat= ':created SOS Ntuple'
+ call G_add_path(here,pat)
+ call G_log_message('INFO: '//pat)
+ ENDIF
+c
+ RETURN
+ END
diff --git a/ENGINE/s_ntuple_keep.f b/ENGINE/s_ntuple_keep.f
new file mode 100644
index 0000000..0e7827a
--- /dev/null
+++ b/ENGINE/s_ntuple_keep.f
@@ -0,0 +1,208 @@
+ subroutine s_Ntuple_keep(ABORT,err)
+*----------------------------------------------------------------------
+*
+* Purpose : Add entry to the SOS Ntuple
+*
+* Output: ABORT - success or failure
+* : err - reason for failure, if any
+*
+* Created: 11-Apr-1994 K.B.Beard, Hampton U.
+* $Log: s_ntuple_keep.f,v $
+* Revision 1.8 2004/02/17 17:26:34 jones
+* Changes to enable possiblity of segmenting rzdat files
+*
+* Revision 1.7.2.3 2003/08/12 17:35:34 cdaq
+* Add variables for e00-108 (hamlet)
+*
+* Revision 1.7.2.2 2003/06/26 12:39:55 cdaq
+* changes for e01-001 (mkj)
+*
+* Revision 1.7.2.1 2003/04/04 12:54:42 cdaq
+* add beam parameters to ntuple
+*
+* Revision 1.7 1996/09/04 15:18:21 saw
+* (JRA) Modify ntuple contents
+*
+* Revision 1.6 1996/01/16 16:40:31 cdaq
+* (JRA) Modify ntuple contents
+*
+* Revision 1.5 1995/09/01 13:38:46 cdaq
+* (JRA) Add Cerenkov photoelectron count to ntuple
+*
+* Revision 1.4 1995/05/22 20:50:48 cdaq
+* (SAW) Split gen_data_data_structures into gen, hms, sos, and coin parts"
+*
+* Revision 1.3 1995/05/11 19:00:39 cdaq
+* (SAW) Change SSDEDXn vars to an array.
+*
+* Revision 1.2 1994/06/17 02:42:33 cdaq
+* (KBB) Upgrade
+*
+* Revision 1.1 1994/04/12 16:16:28 cdaq
+* Initial revision
+*
+*
+*----------------------------------------------------------------------
+ implicit none
+ save
+*
+ character*13 here
+ parameter (here='s_Ntuple_keep')
+*
+ logical ABORT
+ character*(*) err
+*
+ INCLUDE 's_ntuple.cmn'
+ INCLUDE 'sos_data_structures.cmn'
+ INCLUDE 'gen_data_structures.cmn'
+ INCLUDE 'gen_event_info.cmn'
+ INCLUDE 'sos_tracking.cmn'
+ INCLUDE 'sos_physics_sing.cmn'
+ INCLUDE 'sos_scin_tof.cmn'
+ include 'sos_track_histid.cmn'
+ include 'sos_aero_parms.cmn'
+ include 'sos_scin_parms.cmn'
+ INCLUDE 'sos_calorimeter.cmn'
+*
+ logical HEXIST !CERNLIB function
+*
+ integer m
+
+ real proton_mass
+ parameter ( proton_mass = 0.93827247 ) ! [GeV/c^2]
+
+ real Wsq
+*
+*--------------------------------------------------------
+ err= ' '
+ ABORT = .FALSE.
+*
+ IF(.NOT.s_Ntuple_exists) RETURN !nothing to do
+c
+ if (s_Ntuple_max_segmentevents .gt. 0) then
+ if (s_Ntuple_segmentevents .gt. s_Ntuple_max_segmentevents) then
+ call s_ntuple_change(ABORT,err)
+ s_Ntuple_segmentevents = 0
+ else
+ s_Ntuple_segmentevents = s_Ntuple_segmentevents +1
+ endif
+ endif
+*
+ m= 0
+ m= m+1
+ s_Ntuple_contents(m)= SSOMEGA !
+ m= m+1
+ s_Ntuple_contents(m)= SSBIGQ2 !
+ m= m+1
+ s_Ntuple_contents(m)= SSX_bj !
+ m= m+1
+ s_Ntuple_contents(m)= SSQ3 !
+ Wsq=SINVMASS*SINVMASS
+ m= m+1
+ s_Ntuple_contents(m)= Wsq !
+ m= m+1
+ s_Ntuple_contents(m)= SSTHET_GAMMA !
+
+ m= m+1
+ s_Ntuple_contents(m)= SCER_NPE_SUM ! cerenkov photoelectron spectrum
+ m= m+1
+ s_Ntuple_contents(m)= SSP ! Lab momentum of chosen track in GeV/c
+ m= m+1
+ s_Ntuple_contents(m)= SSENERGY! Lab total energy of chosen track in GeV
+ m= m+1
+ s_Ntuple_contents(m)= SSDELTA ! Spectrometer delta of chosen track
+ m= m+1
+ s_Ntuple_contents(m)= SSTHETA ! Lab Scattering angle in radians
+ m= m+1
+ s_Ntuple_contents(m)= SSPHI ! Lab Azymuthal angle in radians
+ m= m+1
+ s_Ntuple_contents(m)= SINVMASS ! Invariant Mass of remaing hadronic system
+ m= m+1
+ s_Ntuple_contents(m)= SSZBEAM! Lab Z coordinate of intersection of beam
+ ! track with spectrometer ray
+ m= m+1
+ s_Ntuple_contents(m)= SSDEDX(1) ! DEDX of chosen track in 1st scin plane
+ m= m+1
+ s_Ntuple_contents(m)= SSBETA ! BETA of chosen track
+ m= m+1
+ s_Ntuple_contents(m)= SSSHTRK ! Total shower energy / momentum
+ m= m+1
+ s_Ntuple_contents(m)= SSTRACK_PRESHOWER_E ! preshower of chosen track
+ m= m+1
+ s_Ntuple_contents(m)= SSX_FP ! X focal plane position
+ m= m+1
+ s_Ntuple_contents(m)= SSY_FP
+ m= m+1
+ s_Ntuple_contents(m)= SSXP_FP
+ m= m+1
+ s_Ntuple_contents(m)= SSYP_FP
+ m= m+1
+ s_Ntuple_contents(m)= SSY_TAR
+ m= m+1
+ s_Ntuple_contents(m)= SSXP_TAR
+ m= m+1
+ s_Ntuple_contents(m)= SSYP_TAR
+ m= m+1
+ s_Ntuple_contents(m)= float(gen_event_ID_number)
+ m= m+1
+ s_Ntuple_contents(m)= float(gen_event_type)
+ m= m+1
+ s_Ntuple_contents(m)= sstart_time
+ m= m+1
+ s_Ntuple_contents(m)= saer_npe_sum
+c
+ m= m+1
+ s_Ntuple_contents(m)= gfrx_raw_adc
+ m= m+1
+ s_Ntuple_contents(m)= gfry_raw_adc
+ m= m+1
+ s_Ntuple_contents(m)= gbeam_x
+ m= m+1
+ s_Ntuple_contents(m)= gbeam_y
+ m= m+1
+ s_Ntuple_contents(m)= gbpm_x(1)
+ m= m+1
+ s_Ntuple_contents(m)= gbpm_y(1)
+ m= m+1
+ s_Ntuple_contents(m)= gbpm_x(2)
+ m= m+1
+ s_Ntuple_contents(m)= gbpm_y(2)
+ m= m+1
+ s_Ntuple_contents(m)= gbpm_x(3)
+ m= m+1
+ s_Ntuple_contents(m)= gbpm_y(3)
+ m= m+1
+ s_Ntuple_contents(m)= smisc_dec_data(2,2)
+ m= m+1
+ s_Ntuple_contents(m)= smisc_dec_data(3,2)
+ m= m+1
+ s_Ntuple_contents(m)= smisc_dec_data(4,2)
+ m= m+1
+c s_Ntuple_contents(m)= smisc_dec_data(7,1)
+ s_Ntuple_contents(m)= scer_adc(1)
+ m= m+1
+c s_Ntuple_contents(m)= smisc_dec_data(8,1)
+ s_Ntuple_contents(m)= scer_adc(2)
+ m= m+1
+c s_Ntuple_contents(m)= smisc_dec_data(5,2)
+ s_Ntuple_contents(m)= scer_adc(3)
+ m= m+1
+c s_Ntuple_contents(m)= smisc_dec_data(6,2)
+ s_Ntuple_contents(m)= scer_adc(4)
+
+
+* Experiment dependent entries start here.
+
+
+* Fill ntuple for this event
+ ABORT= .NOT.HEXIST(s_Ntuple_ID)
+ IF(ABORT) THEN
+ call G_build_note(':Ntuple ID#$ does not exist',
+ & '$',s_Ntuple_ID,' ',0.,' ',err)
+ call G_add_path(here,err)
+ ELSE
+ call HFN(s_Ntuple_ID,s_Ntuple_contents)
+ ENDIF
+*
+ RETURN
+ END
diff --git a/ENGINE/s_ntuple_open.f b/ENGINE/s_ntuple_open.f
new file mode 100644
index 0000000..ec877dd
--- /dev/null
+++ b/ENGINE/s_ntuple_open.f
@@ -0,0 +1,115 @@
+ subroutine s_Ntuple_open(file,ABORT,err)
+*----------------------------------------------------------------------
+*
+* Opens an HMS Ntuple file
+*
+* Purpose : Books an HMS Ntuple
+*
+* Output: ABORT - success or failure
+* : err - reason for failure, if any
+*
+*----------------------------------------------------------------------
+
+ implicit none
+ save
+
+ character*13 here
+ parameter (here='s_Ntuple_open')
+
+ logical ABORT
+ character*(*) err
+
+ INCLUDE 's_ntuple.cmn'
+
+ integer default_bank,default_recL
+ parameter (default_bank= 8000) !4 bytes/word
+ parameter (default_recL= 1024) !record length
+ character*80 title,file
+ character*80 directory,name
+ character*1000 pat,msg
+ integer status,size,io,id,bank,recL,iv(10),m
+ real rv(10)
+
+ logical HEXIST !CERNLIB function
+
+*--------------------------------------------------------
+
+ err= ' '
+ ABORT = .FALSE.
+ IF(s_Ntuple_exists) THEN
+ call s_Ntuple_shutdown(ABORT,err)
+ If(ABORT) Then
+ call G_add_path(here,err)
+ RETURN
+ EndIf
+ ENDIF
+
+*- get any free IO channel
+
+ call g_IO_control(io,'ANY',ABORT,err)
+ s_Ntuple_exists= .NOT.ABORT
+ IF(ABORT) THEN
+ call G_add_path(here,err)
+ RETURN
+ ENDIF
+ s_Ntuple_IOchannel= io
+
+ id= s_Ntuple_ID
+ name= s_Ntuple_name
+ title= s_Ntuple_title
+ ABORT= HEXIST(id)
+ IF(ABORT) THEN
+ call g_IO_control(s_Ntuple_IOchannel,'FREE',ABORT,err)
+ call G_build_note(':HBOOK id#$ already in use',
+ & '$',id,' ',rv,' ',err)
+ call G_add_path(here,err)
+ RETURN
+ ENDIF
+
+ CALL HCDIR(directory,'R') !CERNLIB read current directory
+
+*-open New *.rzdat file-
+ recL= default_recL
+ call HROPEN(io,name,file,'N',recL,status) !CERNLIB
+
+ ABORT= status.NE.0
+ IF(ABORT) THEN
+ call g_IO_control(s_Ntuple_IOchannel,'FREE',ABORT,err)
+ iv(1)= status
+ iv(2)= io
+ pat= ':HROPEN error#$ opening IO#$ "'//file//'"'
+ call G_build_note(pat,'$',iv,' ',rv,' ',err)
+ call G_add_path(here,err)
+ RETURN
+ ENDIF
+
+ size= s_Ntuple_size
+ bank= default_bank
+ title= s_Ntuple_title
+ call HBOOKN(id,title,size,name,bank,s_Ntuple_tag) !create Ntuple
+
+ call HCDIR(s_Ntuple_directory,'R') !record Ntuple directory
+
+ CALL HCDIR(directory,' ') !reset CERNLIB directory
+
+ s_Ntuple_exists= HEXIST(s_Ntuple_ID)
+ ABORT= .NOT.s_Ntuple_exists
+
+ iv(1)= id
+ iv(2)= io
+ pat= 'Ntuple id#$ [' // s_Ntuple_directory // '/]' //
+ & name // ' IO#$ "' // file // '"'
+ call G_build_note(pat,'$',iv,' ',rv,' ',msg)
+ call sub_string(msg,' /]','/]')
+
+ IF(ABORT) THEN
+ err= ':unable to create '//msg
+ call G_add_path(here,err)
+ ELSE
+ pat= ':created '//msg
+ call G_add_path(here,pat)
+ call G_log_message('INFO: '//pat)
+ ENDIF
+
+ RETURN
+ END
diff --git a/ENGINE/s_ntuple_register.f b/ENGINE/s_ntuple_register.f
new file mode 100644
index 0000000..1c307b9
--- /dev/null
+++ b/ENGINE/s_ntuple_register.f
@@ -0,0 +1,47 @@
+ subroutine s_Ntuple_register(ABORT,err)
+*----------------------------------------------------------------------
+*
+* CTP variable registration routine for the SOS Ntuples
+*
+* Purpose : Register output filename for SOS Ntuple; temporary
+* implementation to be superceeded by CTP Ntuples
+*
+* Output: ABORT - success or failure
+* : err - reason for failure, if any
+*
+* Created: 8-Apr-1994 K.B.Beard, HU: added Ntuples
+* $Log: s_ntuple_register.f,v $
+* Revision 1.2 1994/06/17 02:56:26 cdaq
+* (KBB) Upgrade
+*
+* Revision 1.1 1994/04/12 16:16:38 cdaq
+* Initial revision
+*
+*
+*----------------------------------------------------------------------
+ implicit none
+ save
+*
+ character*17 here
+ parameter (here='s_Ntuple_register')
+*
+ logical ABORT
+ character*(*) err
+*
+ INCLUDE 's_ntuple.cmn'
+ INCLUDE 'gen_routines.dec'
+*
+ integer ierr
+*--------------------------------------------------------
+ err= ' '
+ ABORT = .FALSE.
+*
+ call G_reg_C('SOS_Ntuple',s_Ntuple_file,ABORT,err)
+*
+ IF(ABORT) THEN
+ call G_prepend(':unable to register-',err)
+ call G_add_path(here,err)
+ ENDIF
+*
+ return
+ end
diff --git a/ENGINE/s_ntuple_shutdown.f b/ENGINE/s_ntuple_shutdown.f
new file mode 100644
index 0000000..0371cd9
--- /dev/null
+++ b/ENGINE/s_ntuple_shutdown.f
@@ -0,0 +1,77 @@
+ subroutine s_Ntuple_shutdown(ABORT,err)
+*----------------------------------------------------------------------
+*
+* Final shutdown of the SOS Ntuple
+*
+* Purpose : Flushes and closes the SOS Ntuple
+*
+* Output: ABORT - success or failure
+* : err - reason for failure, if any
+*
+* Created: 8-Apr-1994 K.B.Beard, HU: added Ntuples
+* $Log: s_ntuple_shutdown.f,v $
+* Revision 1.6 2004/02/17 17:26:34 jones
+* Changes to enable possiblity of segmenting rzdat files
+*
+* Revision 1.5 1998/12/01 16:02:39 saw
+* (SAW) Clean out archaic g_build_note stuff
+*
+* Revision 1.4 1996/01/16 16:38:45 cdaq
+* (SAW) Comment out an info message
+*
+* Revision 1.3 1994/06/29 03:30:25 cdaq
+* (KBB) Remove HDELET call
+*
+* Revision 1.2 1994/06/17 02:57:45 cdaq
+* (KBB) Upgrade
+*
+* Revision 1.1 1994/04/12 16:16:53 cdaq
+* Initial revision
+*
+*
+*----------------------------------------------------------------------
+ implicit none
+ save
+*
+ character*17 here
+ parameter (here='s_Ntuple_shutdown')
+*
+ logical ABORT
+ character*(*) err
+*
+ INCLUDE 's_ntuple.cmn'
+ INCLUDE 'gen_routines.dec'
+*
+*
+ logical FAIL
+ character*80 why,directory,name
+ character*1000 msg
+ integer io,id,cycle,m
+*
+ err= ' '
+ ABORT = .FALSE.
+*
+
+ IF(.NOT.s_Ntuple_exists) RETURN !nothing to do
+c
+
+ call s_ntuple_close(ABORT,err)
+
+*
+ IF(s_Ntuple_exists) then
+ ABORT = .true.
+ endif
+ s_Ntuple_ID= 0
+ s_Ntuple_name= ' '
+ s_Ntuple_file= ' '
+ s_Ntuple_title= ' '
+ s_Ntuple_size= 0
+ do m=1,SMAX_Ntuple_size
+ s_Ntuple_tag(m)= ' '
+ s_Ntuple_contents(m)= 0.
+ enddo
+*
+ IF(ABORT) call G_add_path(here,err)
+*--------------------------------------------------------
+ RETURN
+ END
diff --git a/ENGINE/s_proper_shutdown.f b/ENGINE/s_proper_shutdown.f
new file mode 100644
index 0000000..099f072
--- /dev/null
+++ b/ENGINE/s_proper_shutdown.f
@@ -0,0 +1,111 @@
+ SUBROUTINE S_proper_shutdown(lunout,ABORT,err)
+*--------------------------------------------------------
+*- Prototype C analysis routine
+*-
+*-
+*- Purpose and Methods : Closes files properly, flushes, etc.
+*-
+*- Output: ABORT - success or failure
+*- : err - reason for failure, if any
+*-
+*- Created 20-Nov-1993 Kevin B. Beard for new error standards
+* $Log: s_proper_shutdown.f,v $
+* Revision 1.11 1995/10/09 18:56:25 cdaq
+* (JRA) Add bypass switches to efficiency shutdown routine calls
+*
+* Revision 1.10 1995/09/01 13:40:09 cdaq
+* (JRA) Add calls to more efficiency calculations and bad counter report
+*
+* Revision 1.9 1995/08/11 15:39:32 cdaq
+* (JRA) Add sos Cerenkov efficiencies
+* (DD) Add sos sieve slit ntuple
+*
+* Revision 1.8 1995/07/27 19:02:47 cdaq
+* (SAW) Move ntuple shutdown to g_ntuple_shutdown
+*
+* Revision 1.7 1995/05/22 13:29:39 cdaq
+* (JRA) Make a listing of potential detector problems
+*
+* Revision 1.6 1995/04/01 20:11:28 cdaq
+* (SAW) One report file for each of g, h, s, c instead of a single report file
+* Allow %d for run number in filenames
+*
+* Revision 1.5 1995/03/13 18:17:49 cdaq
+* (JRA) Add calls to s_scin_eff_shutdown and s_cal_eff_shutdown.
+*
+* Revision 1.4 1994/10/11 18:40:49 cdaq
+* (SAW) Protect agains blank blocknames
+*
+* Revision 1.3 1994/06/17 03:02:01 cdaq
+* (KBB) Fix typo
+*
+* Revision 1.2 1994/04/12 17:28:15 cdaq
+* (KBB) Add ntuple call
+*
+* Revision 1.1 1994/02/04 22:21:52 cdaq
+* Initial revision
+*
+*- All standards are from "Proposal for Hall C Analysis Software
+*- Vade Mecum, Draft 1.0" by D.F.Geesamn and S.Wood, 7 May 1993
+*-
+*--------------------------------------------------------
+ IMPLICIT NONE
+ SAVE
+*
+ include 'gen_routines.dec'
+ include 'gen_filenames.cmn'
+ include 'gen_run_info.cmn'
+ include 'sos_filenames.cmn'
+ include 'sos_bypass_switches.cmn'
+*
+ character*17 here
+ parameter (here= 'S_proper_shutdown')
+*
+ logical ABORT, report_abort
+ character*(*) err
+*
+ integer ierr
+ character*132 file
+ integer lunout
+*--------------------------------------------------------
+*- chance to flush any statistics, etc.
+*
+*
+ ABORT= .FALSE.
+ err= ' '
+*
+ if (sbypass_dc_eff.eq.0) then
+ call s_dc_eff_shutdown(lunout,ABORT,err)
+ call s_dc_trk_eff_shutdown(lunout,ABORT,err)
+ endif
+*
+ if (sbypass_scin_eff.eq.0) call s_scin_eff_shutdown(lunout,ABORT,err)
+*
+ if (sbypass_cer_eff.eq.0) call s_cer_eff_shutdown(lunout,ABORT,err)
+*
+ if (sbypass_cal_eff.eq.0) call s_cal_eff_shutdown(ABORT,err)
+*
+ call s_report_bad_data(lunout,ABORT,err)
+*
+ if(s_report_blockname.ne.' '.and.
+ $ s_report_output_filename.ne.' ') then
+
+ file = s_report_output_filename
+ call g_sub_run_number(file, gen_run_number)
+
+ ierr = threp(s_report_blockname, file)
+ if(ierr.ne.0) then
+ call g_append(err,'& threp failed to create report in file'//file)
+ report_abort = .true.
+ endif
+ endif
+*
+ IF(ABORT.or.report_abort) THEN
+ call G_add_path(here,err)
+ ELSE
+ err= ' '
+ ENDIF
+*
+ RETURN
+ END
+
diff --git a/ENGINE/s_register_variables.f b/ENGINE/s_register_variables.f
new file mode 100644
index 0000000..cea55ea
--- /dev/null
+++ b/ENGINE/s_register_variables.f
@@ -0,0 +1,101 @@
+ subroutine s_register_variables(ABORT,err)
+*----------------------------------------------------------------------
+*
+* CTP variable registration routine for the SOS
+*
+* Purpose : Register all variables that are to be used by CTP, that are
+* connected with the SOS. This includes externally configured
+* parameters/contants, event data that can be a histogram source, and
+* possible test results and scalers.
+*
+* Output: ABORT - success or failure
+* : err - reason for failure, if any
+*
+* Created: 9-Feb-1994 Stephen A. Wood
+*
+* $Log: s_register_variables.f,v $
+* Revision 1.11 1996/01/16 16:27:28 cdaq
+* no change
+*
+* Revision 1.10 1995/08/11 15:41:09 cdaq
+* (DD) Add sos sieve slit ntuple
+*
+* Revision 1.9 1995/05/22 13:32:11 cdaq
+* (SAW) Add call to register sos_data_structures.cmn variables
+*
+* Revision 1.8 1995/05/11 18:59:39 cdaq
+* (SAW) Add register call for s_ntuple.cmn
+*
+* Revision 1.7 1994/08/18 04:11:36 cdaq
+* (SAW) Call makereg generated routines to register variables
+*
+* Revision 1.6 1994/06/17 03:27:31 cdaq
+* (KBB) Execute all code despite registration errors
+*
+* Revision 1.5 1994/06/16 03:45:21 cdaq
+* (SAW) Register filenames for reports
+*
+* Revision 1.4 1994/04/12 17:26:00 cdaq
+* (KBB) Add ntuple call
+*
+* Revision 1.3 1994/02/22 19:39:19 cdaq
+* (SAW) Remove CTP register calls to fortran PARAMETER's
+*
+* Revision 1.2 1994/02/22 18:58:00 cdaq
+* (SAW) Make a call to h_register_param
+*
+* Revision 1.1 1994/02/11 04:18:56 cdaq
+* Initial revision
+*
+*
+*----------------------------------------------------------------------
+ implicit none
+ save
+*
+ character*20 here
+ parameter (here='s_register_variables')
+*
+ logical ABORT
+ character*(*) err
+*
+ logical FAIL
+ character*1000 why
+*
+*--------------------------------------------------------
+ err= ' '
+ ABORT = .FALSE.
+*
+ call r_sos_data_structures
+
+ call r_sos_filenames
+
+ call r_s_ntuple
+
+ call s_register_param(FAIL,why) ! TRACKING ROUTINE
+ IF(err.NE.' ' .and. why.NE.' ') THEN !keep warnings
+ call G_append(err,' & '//why)
+ ELSEIF(why.NE.' ') THEN
+ err= why
+ ENDIF
+ ABORT= ABORT .or. FAIL
+*
+ call s_ntuple_register(FAIL,why) ! Remove this when ctp files fixed
+ IF(err.NE.' ' .and. why.NE.' ') THEN !keep warnings
+ call G_append(err,' & '//why)
+ ELSEIF(why.NE.' ') THEN
+ err= why
+ ENDIF
+ ABORT= ABORT .or. FAIL
+*
+ call s_sv_nt_register(FAIL,why) ! Remove this when ctp files fixed
+ IF(err.NE.' ' .and. why.NE.' ') THEN !keep warnings
+ call G_append(err,' & '//why)
+ ELSEIF(why.NE.' ') THEN
+ err= why
+ ENDIF
+ ABORT= ABORT .or. FAIL
+*
+ if(ABORT .or. err.NE.' ') call G_add_path(here,err)
+*
+ return
+ end
diff --git a/ENGINE/s_reset_event.f b/ENGINE/s_reset_event.f
new file mode 100644
index 0000000..97b6a51
--- /dev/null
+++ b/ENGINE/s_reset_event.f
@@ -0,0 +1,336 @@
+ SUBROUTINE S_reset_event(ABORT,err)
+*--------------------------------------------------------
+*- Prototype C analysis routine
+*-
+*-
+*- Purpose and Methods : Resets all SOS quantities before event is processed.
+*-
+*-
+*- Output: ABORT - success or failure
+*- : err - reason for failure, if any
+*-
+*- Created 2-Nov-1993 Kevin B. Beard
+*- Modified 20-Nov-1993 KBB for new errors
+*- $Log: s_reset_event.f,v $
+*- Revision 1.15 1999/08/20 14:52:18 saw
+*- Put in warning if Xscin_tdc_max is bigger than 4094
+*-
+*- Revision 1.14 1999/02/03 21:13:04 saw
+*- Code for new Shower counter tubes
+*-
+*- Revision 1.13 1996/11/05 21:43:16 saw
+*- (WH) Add lucite counter
+*-
+*- Revision 1.12 1996/09/04 15:18:54 saw
+*- (JRA) Zero out some misc scalers
+*-
+*- Revision 1.11 1996/04/30 12:29:55 saw
+*- (JRA) Change SAER_ADC_LEFT/RIGHT to POS/NEG
+*-
+*- Revision 1.10 1995/10/09 18:09:01 cdaq
+*- (JRA) Add clear of SCER_RAW_ADC
+*-
+*- Revision 1.9 1995/07/27 19:44:17 cdaq
+*- (JRA) Zero out pedestal arrays
+*-
+* Revision 1.8 1995/05/22 20:50:48 cdaq
+* (SAW) Split gen_data_data_structures into gen, hms, sos, and coin parts"
+*
+* Revision 1.7 1995/05/11 15:08:32 cdaq
+* (SAW) Change SDEDXn vars to an array. Add reset of Aerogel structure.
+*
+* Revision 1.6 1994/11/22 20:15:35 cdaq
+* (SPB) Bring up to date with h_reset_event
+*
+* Revision 1.5 1994/06/22 20:51:22 cdaq
+* (SAW) Zero out the miscleaneous hits array
+*
+* Revision 1.4 1994/03/24 22:01:43 cdaq
+* Reflect changes in gen_data_structures.cmn
+*
+* Revision 1.3 1994/02/22 19:43:15 cdaq
+* (SAW) SNUM_DC_PLANES --> SMAX_NUM_DC_PLANES
+*
+* Revision 1.2 1994/02/11 04:12:30 cdaq
+* Change var names to reflect current gen_data_structures
+*
+* Revision 1.1 1994/02/04 22:16:02 cdaq
+* Initial revision
+*
+*-
+*-
+*- All standards are from "Proposal for Hall C Analysis Software
+*- Vade Mecum, Draft 1.0" by D.F.Geesamn and S.Wood, 7 May 1993
+*-
+*-
+*--------------------------------------------------------
+ IMPLICIT NONE
+ SAVE
+*
+ character*50 here
+ parameter (here= 'S_reset_event')
+*
+ logical ABORT
+ character*(*) err
+*
+ INCLUDE 'sos_data_structures.cmn'
+ INCLUDE 'sos_tracking.cmn'
+ INCLUDE 'sos_pedestals.cmn'
+ include 'sos_scin_parms.cmn'
+ include 'sos_scin_tof.cmn'
+*
+ INTEGER track,hit,block,i,j,plane
+*
+*--------------------------------------------------------
+*
+* SOS DECODED DATA
+*
+ do i=1,snum_scin_planes
+ do j=1,snum_scin_elements
+ shodo_pos_ped_num(i,j) = 0
+ shodo_pos_ped_sum2(i,j) = 0
+ shodo_pos_ped_sum(i,j) = 0
+ shodo_neg_ped_num(i,j) = 0
+ shodo_neg_ped_sum2(i,j) = 0
+ shodo_neg_ped_sum(i,j) = 0
+ enddo
+ enddo
+
+ do i=1,smax_cal_blocks
+ scal_pos_ped_num(i)=0
+ scal_pos_ped_sum2(i)=0
+ scal_pos_ped_sum(i)=0
+ scal_neg_ped_num(i)=0
+ scal_neg_ped_sum2(i)=0
+ scal_neg_ped_sum(i)=0
+ enddo
+
+ do i=1,smax_cer_hits
+ scer_ped_num(i)=0
+ scer_ped_sum2(i)=0
+ scer_ped_sum(i)=0
+ enddo
+
+ do i=1,smax_aer_hits
+ saer_pos_ped_num(i)=0
+ saer_pos_ped_sum2(i)=0
+ saer_pos_ped_sum(i)=0
+ saer_neg_ped_num(i)=0
+ saer_neg_ped_sum2(i)=0
+ saer_neg_ped_sum(i)=0
+ enddo
+
+ DO hit= 1,SMAX_DC_HITS
+ SDC_RAW_PLANE_NUM(hit)= 0
+ SDC_RAW_WIRE_NUM(hit)= 0
+ SDC_RAW_TDC(hit)= 0
+ SDC_DRIFT_TIME(hit)= 0.
+ SDC_DRIFT_DIS(hit)= 0.
+ SDC_WIRE_CENTER(hit)= 0.
+ SDC_WIRE_COORD(hit)= 0.
+ SDC_PLANE_NUM(hit)= 0.
+ SDC_WIRE_NUM(hit)= 0.
+ SDC_TDC(hit)= 0.
+ ENDDO
+ SDC_TOT_HITS= 0
+ DO plane= 1,SMAX_NUM_DC_PLANES
+ SDC_HITS_PER_PLANE(plane)= 0
+ ENDDO
+*
+* SOS SCINTILLATOR HITS
+*
+ DO hit= 1,SMAX_SCIN_HITS
+ SSCIN_ZPOS(hit)= 0.0
+ SSCIN_CENTER_COORD(hit)= 0.0
+ SSCIN_COR_ADC(hit)= 0.0
+ SSCIN_COR_TIME(hit)= 0.0
+ SSCIN_PLANE_NUM(hit)= 0
+ SSCIN_COUNTER_NUM(hit)= 0
+ SSCIN_ADC_POS(hit)= 0
+ SSCIN_ADC_NEG(hit)= 0
+ SSCIN_TDC_POS(hit)= 0
+ SSCIN_TDC_NEG(hit)= 0
+ SSCIN_ALL_PLANE_NUM(hit)= 0
+ SSCIN_ALL_COUNTER_NUM(hit)= 0
+ SSCIN_ALL_ADC_POS(hit)= 0
+ SSCIN_ALL_ADC_NEG(hit)= 0
+ SSCIN_ALL_TDC_POS(hit)= 0
+ SSCIN_ALL_TDC_NEG(hit)= 0
+ ENDDO
+ DO plane= 1,SNUM_SCIN_PLANES
+ SSCIN_HITS_PER_PLANE(plane)= 0
+ ENDDO
+ SSCIN_TOT_HITS= 0
+ SSCIN_ALL_TOT_HITS= 0
+*
+* SOS CALORIMETER HITS
+*
+ DO block= 1,SMAX_CAL_BLOCKS
+ SBLOCK_XC(block) = 0.
+ SBLOCK_ZC(block) = 0.
+ SBLOCK_DE(block) = 0.
+ SBLOCK_DE_POS(block)= 0
+ SBLOCK_DE_NEG(block)= 0
+ SCAL_ROW(block) = 0
+ SCAL_COLUMN(block) = 0
+ SCAL_ADC_POS(block)= 0
+ SCAL_ADC_NEG(block)= 0
+ SCAL_ADC(block) = 0
+ ENDDO
+ SCAL_TOT_HITS= 0
+*
+* SOS CERENKOV HITS
+*
+ DO hit= 1,SMAX_CER_HITS
+ SCER_TUBE_NUM(hit) = 0
+ SCER_RAW_ADC(hit) = 0
+ SCER_ADC(hit) = 0
+ SCER_PLANE(hit) = 0
+ ENDDO
+ SCER_TOT_HITS= 0
+*
+* SOS AEROGEL HITS
+*
+ DO hit= 1,SMAX_AER_HITS
+ SAER_PAIR_NUM(hit) = 0
+ SAER_ADC_POS(hit) = 0
+ SAER_ADC_NEG(hit) = 0
+ SAER_PLANE(hit) = 0
+ ENDDO
+ SAER_TOT_HITS = 0
+
+*
+* SOS LUCITE HITS
+*
+ DO hit= 1,SMAX_LUC_HITS
+ SLUC_PAIR_NUM(hit) = 0
+ SLUC_ADC_POS(hit) = 0
+ SLUC_ADC_NEG(hit) = 0
+ SLUC_TDC_POS(hit)= 0
+ SLUC_TDC_NEG(hit)= 0
+ SLUC_PLANE(hit) = 0
+ ENDDO
+ SLUC_TOT_HITS = 0
+
+*
+* SOS Miscleaneous hits
+*
+ do hit=1,SMAX_MISC_HITS
+ SMISC_RAW_ADDR1(hit) = 0
+ SMISC_RAW_ADDR2(hit) = 0
+ SMISC_RAW_DATA(hit) = 0
+ do plane=1,snum_misc_planes
+ smisc_scaler(hit,plane)=0
+ enddo
+ enddo
+ smisc_tot_hits = 0
+*
+* SOS DETECTOR TRACK QUANTITIES
+*
+ DO track= 1,SNTRACKS_MAX
+ SX_FP(track)= 0.
+ SY_FP(track)= 0.
+ SZ_FP(track)= 0.
+ SXP_FP(track)= 0.
+ SYP_FP(track)= 0.
+ SCHI2_FP(track)= 0.
+ SNFREE_FP(track)= 0.
+* Do j= 1,4
+* do i= 1,4
+* SDEL_FP(i,j,track)= 0.
+* enddo
+* EndDo
+ Do hit= 1,SNTRACKHITS_MAX
+ SNTRACK_HITS(track,hit)= 0
+ EndDo
+ ENDDO
+ SNTRACKS_FP= 0
+*
+* SOS TARGET QUANTITIES
+*
+ DO track= 1,SNTRACKS_MAX
+ SX_TAR(track)= 0.
+ SY_TAR(track)= 0.
+ SZ_TAR(track)= 0.
+ SXP_TAR(track)= 0.
+ SYP_TAR(track)= 0.
+ SDELTA_TAR(track)= 0.
+ SP_TAR(track)= 0.
+ SCHI2_TAR(track)= 0.
+ SDEL_TAR(5,5,track)= 0.
+ SNFREE_TAR(track)= 0.
+ SLINK_TAR_FP(track)= 0.
+ Do j= 1,5
+ do i= 1,5
+ SDEL_TAR(i,j,track)= 0.
+ enddo
+ EndDo
+ ENDDO
+ SNTRACKS_TAR= 0
+ DO track=1, SNTRACKS_MAX
+ SNBLOCKS_CAL(track)=0
+ STRACK_E1(track)=0
+ STRACK_E2(track)=0
+ STRACK_E3(track)=0
+ STRACK_E4(track)=0
+ STRACK_ET(track)=0
+ STRACK_E1_POS(track)= 0.
+ STRACK_E1_NEG(track)= 0.
+ STRACK_E2_POS(track)= 0.
+ STRACK_E2_NEG(track)= 0.
+ STRACK_PRESHOWER_E(track)=0
+ do hit = 1, SMAX_SCIN_HITS
+ SSCIN_HIT(track,hit)= 0
+ enddo
+ do plane = 1, SNUM_SCIN_PLANES
+ SDEDX(track,plane) = 0
+ enddo
+ SNUM_SCIN_HIT(track)=0
+ SBETA(track)=0
+ SBETA_CHISQ(track)=0
+ STIME_AT_FP(track)=0
+ ENDDO
+
+ SSP=0
+ SSENERGY=0
+ SSDELTA=0
+ SSTHETA=0
+ SSPHI=0
+ SSMINV=0
+ SSZBEAM=0
+ do plane = 1 , SNUM_SCIN_PLANES
+ SSDEDX(plane) = 0.
+ enddo
+ SSBETA=0
+ SSTRACK_ET=0
+ SSTRACK_PRESHOWER_E=0
+ SSTIME_AT_FP=0
+ SSX_FP=0
+ SSY_FP=0
+ SSXP_FP=0
+ SSYP_FP=0
+ SSCHI2PERDEG=0
+ SSX_TAR=0
+ SSY_TAR=0
+ SSXP_TAR=0
+ SSYP_TAR=0
+ SSNUM_FPTRACK=0
+ SSNUM_TARTRACK=0
+ SSID_LUND=0
+ SSNFREE_FP=0
+*
+ if(sscin_tdc_max.gt.4094) then
+ print *,' '
+ print *,'WARNING!!: sscin_tdc_max is ',sscin_tdc_max
+ print *,'We usually run our high resolution TDC''s with 12 bit'
+ print *,'ranges. If sscin_tdc_max is set to a value higher than'
+ print *,'the TDC''s overflow channel, then overflowed TDC channels'
+ print *,'will not be rejected. Under high rate conditions, this'
+ print *,'can result in bad beta and timing calculations'
+ print *,' '
+ endif
+*
+ ABORT= .FALSE.
+ err= ' '
+ RETURN
+ END
diff --git a/ENGINE/s_sv_nt_init.f b/ENGINE/s_sv_nt_init.f
new file mode 100644
index 0000000..d78dcdb
--- /dev/null
+++ b/ENGINE/s_sv_nt_init.f
@@ -0,0 +1,207 @@
+ subroutine s_sv_Nt_init(ABORT,err)
+*----------------------------------------------------------------------
+*
+* Creates an SOS Sieve slit Ntuple
+*
+* Purpose : Books an SOS Ntuple; defines structure of it
+*
+* Output: ABORT - success or failure
+* : err - reason for failure, if any
+*
+* Created: 1-Nov-1994
+* $Log: s_sv_nt_init.f,v $
+* Revision 1.4 1998/12/01 15:58:54 saw
+* (SAW) Output file name fixup
+*
+* Revision 1.3 1996/11/05 21:43:50 saw
+* (DD) Add gas cerenkov to ntuple
+*
+* Revision 1.2 1996/09/04 15:19:26 saw
+* (JRA) Modify ntuple contents
+*
+* Revision 1.1 1995/08/11 16:23:43 cdaq
+* Initial revision
+* s_sv_nt_init.f,v $
+*----------------------------------------------------------------------
+ implicit none
+ save
+*
+ character*13 here
+ parameter (here='s_sv_Nt_init')
+*
+ logical ABORT
+ character*(*) err
+*
+ INCLUDE 'gen_routines.dec'
+ INCLUDE 'gen_run_info.cmn'
+*
+ character*80 default_name
+ parameter (default_name= 'ssieventuple')
+ character*80 default_title
+ parameter (default_title= 'sSieveSlits')
+ integer default_bank,default_recL
+ parameter (default_bank= 8000) !4 bytes/word
+ parameter (default_recL= 1024) !record length
+ character*80 title,file
+ character*80 directory,name
+ character*1000 pat,msg
+ integer status,size,io,id,bank,recL,iv(10),m
+* parameter (id = 1)
+ real rv(10)
+*
+ logical HEXIST !CERNLIB function
+ INCLUDE 's_sieve_ntuple.cmn'
+ INCLUDE 's_sieve_ntuple.dte'
+*
+*--------------------------------------------------------
+ err= ' '
+ ABORT = .FALSE.
+*
+ IF(s_sieve_Ntuple_exists) THEN
+ call s_sv_Nt_shutdown(ABORT,err)
+ If(ABORT) Then
+ call G_add_path(here,err)
+ RETURN
+ EndIf
+ ENDIF
+*
+
+ s_sieve_Ntuple_ID= default_s_sieve_Ntuple_ID
+ s_sieve_Ntuple_name= default_name
+ s_sieve_Ntuple_title= default_title
+
+ call NO_nulls(s_sieve_Ntuple_file) !replace null characters with blanks
+*
+*-if name blank, just forget it
+ IF(s_sieve_Ntuple_file.EQ.' ') RETURN !do nothing
+*
+*- get any free IO channel
+*
+ call g_IO_control(io,'ANY',ABORT,err)
+ s_sieve_Ntuple_exists= .NOT.ABORT
+ IF(ABORT) THEN
+ call G_add_path(here,err)
+ RETURN
+ ENDIF
+ s_sieve_Ntuple_IOchannel= io
+*
+ id= s_sieve_Ntuple_ID
+*
+
+ ABORT= HEXIST(id)
+ IF(ABORT) THEN
+ call g_IO_control(s_sieve_Ntuple_IOchannel,'FREE',ABORT,err)
+ call G_build_note(':HBOOK id#$ already in use',
+ & '$',id,' ',rv,' ',err)
+ call G_add_path(here,err)
+ RETURN
+ ENDIF
+*
+
+ CALL HCDIR(directory,'R') !CERNLIB read current directory
+
+*
+*
+ id= s_sieve_Ntuple_ID
+ name= s_sieve_Ntuple_name
+
+ file= s_sieve_Ntuple_file
+ call g_sub_run_number(file,gen_run_number)
+
+ recL= default_recL
+ io= s_sieve_Ntuple_IOchannel
+*
+*-open New *.rzdat file-
+ call HROPEN(io,name,file,'N',recL,status) !CERNLIB
+* !directory set to "//TUPLE"
+ io= s_sieve_Ntuple_IOchannel
+ ABORT= status.NE.0
+ IF(ABORT) THEN
+ call g_IO_control(s_sieve_Ntuple_IOchannel,'FREE',ABORT,err)
+ iv(1)= status
+ iv(2)= io
+ pat= ':HROPEN error#$ opening IO#$ "'//file//'"'
+ call G_build_note(pat,'$',iv,' ',rv,' ',err)
+ call G_add_path(here,err)
+ RETURN
+ ENDIF
+ s_sieve_Ntuple_file= file
+*
+**********begin insert description of contents of HMS tuple ******
+ m= 0
+*
+ m=m+1
+ s_sieve_Ntuple_tag(m)= 'SSXFP' ! X focal plane position
+ m= m+1
+ s_sieve_Ntuple_tag(m)= 'SSYFP'
+ m= m+1
+ s_sieve_Ntuple_tag(m)= 'SSXPFP'
+ m= m+1
+ s_sieve_Ntuple_tag(m)= 'SSYPFP'
+ m= m+1
+ s_sieve_Ntuple_tag(m)= 'SSDELTA'
+ m= m+1
+ s_sieve_Ntuple_tag(m)= 'SSXTAR'
+ m= m+1
+ s_sieve_Ntuple_tag(m)= 'SSYTAR'
+ m= m+1
+ s_sieve_Ntuple_tag(m)= 'SSXPTAR'
+ m= m+1
+ s_sieve_Ntuple_tag(m)= 'SSYPTAR'
+ m=m+1
+ s_sieve_ntuple_tag(m)= 'SSSHTRK'
+ m=m+1
+ s_sieve_ntuple_tag(m)= 'SCER'
+ m=m+1
+ s_sieve_ntuple_tag(m)= 'EventID'
+
+*
+ s_sieve_Ntuple_size= m !total size
+***********end insert description of contents of HMS tuple********
+*
+ title= s_sieve_Ntuple_title
+ IF(title.EQ.' ') THEN
+ msg= name//' '//s_sieve_Ntuple_file
+ call only_one_blank(msg)
+ title= msg
+ s_sieve_Ntuple_title= title
+ ENDIF
+*
+
+ id= s_sieve_Ntuple_ID
+ io= s_sieve_Ntuple_IOchannel
+ name= s_sieve_Ntuple_name
+ title= s_sieve_Ntuple_title
+ size= s_sieve_Ntuple_size
+ file= s_sieve_Ntuple_file
+ bank= default_bank
+
+ call HBOOKN(id,title,size,name,bank,s_sieve_Ntuple_tag) !create Ntuple
+*
+ call HCDIR(s_sieve_Ntuple_directory,'R') !record Ntuple directory
+*
+
+ CALL HCDIR(directory,' ') !reset CERNLIB directory
+
+*
+ s_sieve_Ntuple_exists= HEXIST(s_sieve_Ntuple_ID)
+ ABORT= .NOT.s_sieve_Ntuple_exists
+*
+ iv(1)= id
+ iv(2)= io
+ pat= 'Ntuple id#$ [' // s_sieve_Ntuple_directory // '/]' //
+ & name // ' IO#$ "' // file // '"'
+ call G_build_note(pat,'$',iv,' ',rv,' ',msg)
+ call sub_string(msg,' /]','/]')
+*
+ IF(ABORT) THEN
+ err= ':unable to create '//msg
+ call G_add_path(here,err)
+ ELSE
+ pat= ':created '//msg
+ call G_add_path(here,pat)
+ call G_log_message('INFO: '//pat)
+ ENDIF
+*
+ RETURN
+ END
diff --git a/ENGINE/s_sv_nt_keep.f b/ENGINE/s_sv_nt_keep.f
new file mode 100644
index 0000000..e1d70dd
--- /dev/null
+++ b/ENGINE/s_sv_nt_keep.f
@@ -0,0 +1,87 @@
+ subroutine s_sv_Nt_keep(ABORT,err)
+*----------------------------------------------------------------------
+*
+* Purpose : Add entry to the SOS Sieve slit Ntuple
+*
+* Output: ABORT - success or failure
+* : err - reason for failure, if any
+*
+* Created: 1-Nov-1994
+* $Log: s_sv_nt_keep.f,v $
+* Revision 1.3 1996/11/05 21:44:04 saw
+* (DD) Add gas cerenkov to ntuple
+*
+* Revision 1.2 1996/09/04 15:19:37 saw
+* (JRA) Modify ntuple contents
+*
+* Revision 1.1 1995/08/11 16:23:12 cdaq
+* Initial revision
+*
+*----------------------------------------------------------------------
+ implicit none
+ save
+*
+ character*13 here
+ parameter (here='s_sv_nt_keep')
+*
+ logical ABORT
+ character*(*) err
+*
+ INCLUDE 's_sieve_ntuple.cmn'
+ INCLUDE 'gen_data_structures.cmn'
+ INCLUDE 'sos_data_structures.cmn'
+ INCLUDE 'gen_event_info.cmn'
+*
+ logical HEXIST !CERNLIB function
+*
+ integer m
+*
+*--------------------------------------------------------
+ err= ' '
+ ABORT = .FALSE.
+*
+ IF(.NOT.s_sieve_Ntuple_exists) RETURN !nothing to do
+*
+************************************************
+ m= 0
+*
+ m= m+1
+ s_sieve_Ntuple_contents(m)= SSX_FP ! X focal plane position
+ m= m+1
+ s_sieve_Ntuple_contents(m)= SSY_FP
+ m= m+1
+ s_sieve_Ntuple_contents(m)= SSXP_FP
+ m= m+1
+ s_sieve_Ntuple_contents(m)= SSYP_FP
+ m= m+1
+ s_sieve_Ntuple_contents(m)= SSDELTA
+ m= m+1
+ s_sieve_Ntuple_contents(m)= SSX_TAR
+ m= m+1
+ s_sieve_Ntuple_contents(m)= SSY_TAR
+ m= m+1
+ s_sieve_Ntuple_contents(m)= SSXP_TAR
+ m= m+1
+ s_sieve_Ntuple_contents(m)= SSYP_TAR
+ m=m+1
+ s_sieve_Ntuple_contents(m)= sstrack_et
+ m= m+1
+ s_sieve_Ntuple_contents(m)= scer_npe_sum
+ m= m+1
+ s_sieve_Ntuple_contents(m)= float(gen_event_ID_number)
+
+*
+************************************************
+*
+*
+ ABORT= .NOT.HEXIST(s_sieve_Ntuple_ID)
+ IF(ABORT) THEN
+ call G_build_note(':Ntuple ID#$ does not exist',
+ & '$',s_sieve_Ntuple_ID,' ',0.,' ',err)
+ call G_add_path(here,err)
+ ELSE
+ call HFN(s_sieve_Ntuple_ID,s_sieve_Ntuple_contents)
+ ENDIF
+*
+ RETURN
+ END
diff --git a/ENGINE/s_sv_nt_register.f b/ENGINE/s_sv_nt_register.f
new file mode 100644
index 0000000..41f41ec
--- /dev/null
+++ b/ENGINE/s_sv_nt_register.f
@@ -0,0 +1,43 @@
+ subroutine s_sv_Nt_register(ABORT,err)
+*----------------------------------------------------------------------
+*
+* CTP variable registration routine for the HMS Sieve Slit Ntuples
+*
+* Purpose : Register output filename for HMS Sieve slit Ntuple; temporary
+* implementation to be superceeded by CTP Ntuples
+*
+* Output: ABORT - success or failure
+* : err - reason for failure, if any
+*
+* Created: 1-Nov-1994 : added Ntuples
+* $Log: s_sv_nt_register.f,v $
+* Revision 1.1 1995/08/11 16:23:06 cdaq
+* Initial revision
+*
+*----------------------------------------------------------------------
+ implicit none
+ save
+*
+ character*17 here
+ parameter (here='s_sv_Nt_register')
+*
+ logical ABORT
+ character*(*) err
+*
+ INCLUDE 's_sieve_ntuple.cmn'
+ INCLUDE 'gen_routines.dec'
+*
+ integer ierr
+*--------------------------------------------------------
+ err= ' '
+ ABORT = .FALSE.
+*
+ call G_reg_C('SOS_sieve_Ntuple',s_sieve_Ntuple_file,ABORT,err)
+*
+ IF(ABORT) THEN
+ call G_prepend(':unable to register-',err)
+ call G_add_path(here,err)
+ ENDIF
+*
+ return
+ end
diff --git a/ENGINE/s_sv_nt_shutdown.f b/ENGINE/s_sv_nt_shutdown.f
new file mode 100644
index 0000000..658a5a1
--- /dev/null
+++ b/ENGINE/s_sv_nt_shutdown.f
@@ -0,0 +1,117 @@
+ subroutine s_sv_Nt_shutdown(ABORT,err)
+*----------------------------------------------------------------------
+*
+* Final shutdown of the HMS Sieve Slit Ntuple
+*
+* Purpose : Flushes and closes the HMS Sieve slit Ntuple
+*
+* Output: ABORT - success or failure
+* : err - reason for failure, if any
+*
+* Created: 1-Nov-1994 added Ntuples
+* $Log: s_sv_nt_shutdown.f,v $
+* Revision 1.2 2003/02/12 16:03:21 jones
+* Modified Call G_build_note to have the needed 7 variables instead of 6
+*
+* Revision 1.1 1995/08/11 16:23:18 cdaq
+* Initial revision
+*
+*----------------------------------------------------------------------
+ implicit none
+ save
+*
+ character*17 here
+ parameter (here='s_sv_Nt_shutdown')
+*
+ logical ABORT
+ character*(*) err
+*
+ INCLUDE 's_sieve_ntuple.cmn'
+ INCLUDE 'gen_routines.dec'
+*
+ logical HEXIST !CERNLIB function
+*
+ logical FAIL
+ character*80 why,directory,name
+ character*1000 pat,msg
+ integer io,id,cycle,m,iv(10)
+*
+*--------------------------------------------------------
+ err= ' '
+ ABORT = .FALSE.
+*
+ IF(.NOT.s_sieve_Ntuple_exists) RETURN !nothing to do
+*
+ call HCDIR(directory,'R') !keep current directory
+
+ id= s_sieve_Ntuple_ID
+ io= s_sieve_Ntuple_IOchannel
+*
+ ABORT= .NOT.HEXIST(id)
+ IF(ABORT) THEN
+ pat= ': Ntuple ID#$ does not exist'
+ call G_build_note(pat,'$',id,' ',0.,' ',err)
+ call G_add_path(here,err)
+ If(io.GT.0) Then
+ call G_IO_control(io,'FREE',FAIL,why) !free up
+ if(.NOT.FAIL) CLOSE(io)
+ EndIf
+ s_sieve_Ntuple_exists= .FALSE.
+ s_sieve_Ntuple_ID= 0
+ s_sieve_Ntuple_name= ' '
+ s_sieve_Ntuple_IOchannel= 0
+ s_sieve_Ntuple_file= ' '
+ s_sieve_Ntuple_title= ' '
+ s_sieve_Ntuple_directory= ' '
+ s_sieve_Ntuple_size= 0
+ do m=1,SMAX_sv_Ntuple_size
+ s_sieve_Ntuple_tag(m)= ' '
+ s_sieve_Ntuple_contents(m)= 0.
+ enddo
+ RETURN
+ ENDIF
+*
+
+ id= s_sieve_Ntuple_ID
+ io= s_sieve_Ntuple_IOchannel
+ name= s_sieve_Ntuple_name
+ call HCDIR(s_sieve_Ntuple_directory,' ') !goto Ntuple directory
+*
+ iv(1)= id
+ iv(2)= io
+ pat= 'closing ID#$ IO#$ "'//s_sieve_Ntuple_file//'"'
+
+ call G_build_note(pat,'$',iv,' ',0.,' ',msg)
+
+ call G_add_path(here,msg)
+
+ call G_log_message('INFO: '//msg)
+
+*
+ cycle= 0 !dummy for HROUT
+ call HROUT(id,cycle,' ') !flush CERNLIB buffers
+
+ call HREND(name) !CERNLIB close file
+* call HDELET(id) !CERNLIB delete tuple
+ call G_IO_control(io,'FREE',ABORT,err) !free up IO channel
+ CLOSE(io) !close IO channel
+*
+ call HCDIR(directory,' ') !return to current directory
+*
+ s_sieve_Ntuple_exists= .FALSE.
+ s_sieve_Ntuple_ID= 0
+ s_sieve_Ntuple_name= ' '
+ s_sieve_Ntuple_IOchannel= 0
+ s_sieve_Ntuple_file= ' '
+ s_sieve_Ntuple_title= ' '
+ s_sieve_Ntuple_directory= ' '
+ s_sieve_Ntuple_size= 0
+ do m=1,SMAX_sv_Ntuple_size
+ s_sieve_Ntuple_tag(m)= ' '
+ s_sieve_Ntuple_contents(m)= 0.
+ enddo
+*
+ IF(ABORT) call G_add_path(here,err)
+*
+ RETURN
+ END
diff --git a/EXE/CVS/Entries b/EXE/CVS/Entries
new file mode 100644
index 0000000..4fe2a6e
--- /dev/null
+++ b/EXE/CVS/Entries
@@ -0,0 +1,2 @@
+/Makefile/1.7.8.5.2.3/Sun Oct 26 19:19:32 2008//Tsane
+D
diff --git a/EXE/CVS/Repository b/EXE/CVS/Repository
new file mode 100644
index 0000000..9104e58
--- /dev/null
+++ b/EXE/CVS/Repository
@@ -0,0 +1 @@
+Analyzer/EXE
diff --git a/EXE/CVS/Root b/EXE/CVS/Root
new file mode 100644
index 0000000..6288c3f
--- /dev/null
+++ b/EXE/CVS/Root
@@ -0,0 +1 @@
+whit@cvs.jlab.org:/group/hallc/cvsroot
diff --git a/EXE/CVS/Tag b/EXE/CVS/Tag
new file mode 100644
index 0000000..25d73f7
--- /dev/null
+++ b/EXE/CVS/Tag
@@ -0,0 +1 @@
+Tsane
diff --git a/EXE/Makefile b/EXE/Makefile
new file mode 100644
index 0000000..bf36e62
--- /dev/null
+++ b/EXE/Makefile
@@ -0,0 +1,154 @@
+.DELETE_ON_ERROR: ;
+
+# To disable compilation of CTP Root Trees, make sure that the environment
+# variable ROOTSYS is undefined, or uncomment "#ROOTSYS=" line below.
+# The same must be done in CTP/Makefile.Unix
+
+ROOTSYS=
+
+disp_objs = glvolu.o
+
+Csoft=$(PWD)
+
+ifeq ($(MYOS),HPUX)
+ ifneq (,$(findstring 09,$(shell uname -r)))
+ HPUXVERSION := 09
+ else
+ HPUXVERSION := 10
+ endif
+ LIBROOT = $(Csoft)/../$(MYOS)$(HPUXVERSION)/lib
+else
+ LIBROOT = $(Csoft)/../$(MYOS)/lib
+endif
+
+ONEEVLIB = $(LIBROOT)/liboneev.a
+ENGINELIB = $(LIBROOT)/libengine.a
+UTILLIB = $(LIBROOT)/libutils.a
+CODALIB = $(LIBROOT)/libcoda.a
+ifdef ROOTSYS
+ CTPLIB = $(LIBROOT)/libctp_root.a
+ CTPCLIENTLIB = $(LIBROOT)/libctpclient_root.a
+ OTHERLIBS = $(shell $(ROOTSYS)/bin/root-config --libs)
+else
+ CTPLIB = $(LIBROOT)/libctp.a
+ CTPCLIENTLIB = $(LIBROOT)/libctpclient.a
+ OTHERLIBS=
+endif
+TRACKINGLIB = $(LIBROOT)/libtracking.a
+HTRACKINGLIB = $(LIBROOT)/libhtracking.a
+STRACKINGLIB = $(LIBROOT)/libstracking.a
+BTRACKINGLIB = $(LIBROOT)/libbtracking.a
+SANETRACKINGLIB = $(LIBROOT)/libsanetracking.a
+F1TRIGGER = $(LIBROOT)/libf1trigger.a
+SEM = $(LIBROOT)/libsem.a
+HACKLIB = $(LIBROOT)/libhack.a
+CERNLIBS = -lgeant$(GEANTVER) -lpawlib -lgraflib -lgrafX11 -lpacklib -lmathlib
+OURGENLIBS = $(ENGINELIB) $(HTRACKINGLIB) $(STRACKINGLIB) $(TRACKINGLIB) \
+ $(HACKLIB) $(UTILLIB) $(CODALIB) $(CTPLIB) $(CTPCLIENTLIB) \
+ $(BTRACKINGLIB) $(SANETRACKINGLIB) $(F1TRIGGER) $(SEM)
+MAKEREG=$(Csoft)/../$(MYOS)/bin/makereg
+
+ifeq ($(MYOS),HPUX)
+ FFLAGS=+U77 +ppu -C +es -O +Onolimit +FPVZOU -I$(Csoft)/INCLUDE
+ DISPFLAGS=+U77 +ppu +es -O +Onolimit +FPVZOU -I$(Csoft)/INCLUDE
+ LDFLAGS=-Wl,-a archive
+ OTHERLIBS += \
+ -Wl,-L$(CODA)/HP_UX/lib \
+ -Wl,-L$(CERN_ROOT)/lib -lpacklib $(CERNLIBS) \
+ -Wl,-L/usr/lib/X11R5 -lX11 -lm
+ MAKEREG=$(Csoft)/../$(MYOS)$(HPUXVERSION)/bin/makereg
+ OURLIBS := $(OURGENLIBS)
+endif
+
+ifeq ($(MYOS),ULTRIX)
+ FFLAGS=-check_bounds
+ DISPFLAGS=$(FFLAGS)
+ LDFLAGS=
+ OTHERLIBS += -L$(CODA)/ULTRIX/lib \
+ -lana -lmsg -lcoda -L$(CERN_ROOT)/lib -lpacklib
+ OURLIBS := $(OURGENLIBS)
+endif
+
+ifeq ($(MYOS),OSF1)
+ FFLAGS=-non_shared -check_bounds -align dcommons
+ DISPFLAGS=$(FFLAGS)
+ LDFLAGS=
+ OTHERLIBS += -L$(CERN_ROOT)/lib -lpacklib
+ OURLIBS := $(OURGENLIBS)
+endif
+
+ifeq ($(MYOS),Linux)
+ override FFLAGS += -I$(Csoft)/INCLUDE
+ DISPFLAGS=$(FFLAGS)
+ ifeq ($(MYREALOS),Darwin)
+ OTHERLIBS += -L$(CERN_ROOT)/lib -lpacklib -lc -lm
+ else
+ OTHERLIBS += -L$(CERN_ROOT)/lib -lpacklib -lc -lm -lnsl
+ endif
+ OURLIBS := $(OURGENLIBS) $(LIBROOT)/libport.a
+endif
+
+ifeq ($(MYOS),SunOS)
+ FFLAGS=-e -O -I$(Csoft)/INCLUDE
+ DISPFLAGS=$(FFLAGS)
+ ifeq ($(MYOS),SunOS4)
+ OTHERLIBS += -L$(CERN_ROOT)/lib $(CERNLIBS) -lnsl -lX11
+ else
+ OTHERLIBS += -L$(CERN_ROOT)/lib $(CERNLIBS) -lnsl -lsocket -lX11
+ endif
+ OURLIBS := $(OURGENLIBS)
+ ifndef CERN_ROOT
+ CERN_ROOT=/apps/cernlib/sun4_solaris2/97a
+ endif
+endif
+
+ifeq ($(MYOS),AIX)
+ FC=f77
+ FFLAGS=-g -qfixed=132 -qextname -O -I$(Csoft)/INCLUDE
+ DISPFLAGS=$(FFLAGS)
+ OTHERLIBS += -L$(CERN_ROOT)/lib -lpacklib $(CERNLIBS) -lX11
+ OURLIBS := $(OURGENLIBS) $(LIBROOT)/libport.a
+endif
+
+# There are no r_%.f files used or built -- this rule isn't used
+r_%.f : %.cmn $(MAKEREG)
+ $(MAKEREG) $< -o $@ -e /dev/null
+
+.PHONY: all engine_replay clean
+.PRECIOUS: r_%.f
+
+all: engine_replay
+
+display: evdisplay
+
+glvolu.o: glvolu.f
+ $(FC) $(FFLAGS) -c $(DISPFLAGS) $<
+
+evdisplay.o: evdisplay.f
+ $(FC) $(FFLAGS) -c $(DISPFLAGS) $<
+
+%.o: %.f
+ $(FC) $(FFLAGS) -c $< -o $@
+
+engine_replay_$(MYOS): Makefile engine.o $(OURLIBS)
+ $(FC) -o $@ $(FFLAGS) engine.o $(OURLIBS) $(OTHERLIBS)
+
+engine_replay: engine_replay_$(MYOS)
+ $(RM) ../../$(MYOS)/bin/engine_replay
+# ln -s $< $@
+ $(CP) engine_replay_$(MYOS) ../../$(MYOS)/bin/engine_replay
+ $(RM) engine_replay_$(MYOS)
+
+.INTERMEDIATE: engine.o
+engine.o: ../ENGINE/O.$(MYOS)/engine.o
+ $(CP) ../ENGINE/O.$(MYOS)/engine.o engine.o
+
+
+$(OURLIBS):
+ $(CP) ../ENGINE/O.$(MYOS)/engine.o engine.o
+
+evdisplay: $(disp_objs) Makefile evdisplay.o $(disp_objs) $(ONEEVLIB) $(OURLIBS)
+ $(FC) -o $@ $(DISPFLAGS) evdisplay.o $(disp_objs) $(ONEEVLIB) $(OURLIBS) $(OTHERLIBS)
+
+clean:
+ $(RM) *.o r_*.f engine_replay engine_replay_$(MYOS) evdisplay
diff --git a/F1TRIGGER/.cvsignore b/F1TRIGGER/.cvsignore
new file mode 100644
index 0000000..0b6ddf9
--- /dev/null
+++ b/F1TRIGGER/.cvsignore
@@ -0,0 +1,2 @@
+O.*
+r_*.f
diff --git a/F1TRIGGER/CVS/Entries b/F1TRIGGER/CVS/Entries
new file mode 100644
index 0000000..b454e1c
--- /dev/null
+++ b/F1TRIGGER/CVS/Entries
@@ -0,0 +1,10 @@
+/.cvsignore/1.1.2.1/Fri Apr 3 15:33:19 2009//Tsane
+/Makefile/1.1.2.1/Thu Oct 2 17:48:21 2008//Tsane
+/Makefile.Unix/1.1.2.1/Thu Oct 2 17:48:21 2008//Tsane
+/f1t_register_variables.f/1.1.2.1/Thu Oct 2 17:48:21 2008//Tsane
+/f1trigger_clear_event.f/1.1.2.1/Thu Oct 2 17:48:21 2008//Tsane
+/f1trigger_decode.f/1.1.2.2/Fri Jan 16 18:48:02 2009//Tsane
+/f1trigger_register_variables.f/1.1.2.1/Thu Oct 2 17:48:21 2008//Tsane
+/f1trigger_reset_event.f/1.1.2.1/Thu Oct 2 17:48:21 2008//Tsane
+/f1trigger_sort_by_counter.f/1.1.2.1/Thu Oct 2 17:48:21 2008//Tsane
+D
diff --git a/F1TRIGGER/CVS/Repository b/F1TRIGGER/CVS/Repository
new file mode 100644
index 0000000..337ddd5
--- /dev/null
+++ b/F1TRIGGER/CVS/Repository
@@ -0,0 +1 @@
+Analyzer/F1TRIGGER
diff --git a/F1TRIGGER/CVS/Root b/F1TRIGGER/CVS/Root
new file mode 100644
index 0000000..6288c3f
--- /dev/null
+++ b/F1TRIGGER/CVS/Root
@@ -0,0 +1 @@
+whit@cvs.jlab.org:/group/hallc/cvsroot
diff --git a/F1TRIGGER/CVS/Tag b/F1TRIGGER/CVS/Tag
new file mode 100644
index 0000000..25d73f7
--- /dev/null
+++ b/F1TRIGGER/CVS/Tag
@@ -0,0 +1 @@
+Tsane
diff --git a/F1TRIGGER/Makefile b/F1TRIGGER/Makefile
new file mode 100755
index 0000000..4eab6f7
--- /dev/null
+++ b/F1TRIGGER/Makefile
@@ -0,0 +1,17 @@
+#
+# $Log: Makefile,v $
+# Revision 1.1.2.1 2008/10/02 17:48:21 cdaq
+# *** empty log message ***
+#
+# Revision 1.1.2.1 2008/05/07 18:13:53 bhovik
+# starting files
+#
+# Revision 1.1.2.1 2007/05/15 01:19:10 jones
+# Start to Bigcal code
+#
+# Revision 1.1 1998/12/08 14:33:24 saw
+# Initial Setup
+#
+ETC=../etc
+
+include $(ETC)/Makefile.NEW
diff --git a/F1TRIGGER/Makefile.Unix b/F1TRIGGER/Makefile.Unix
new file mode 100644
index 0000000..88ad54e
--- /dev/null
+++ b/F1TRIGGER/Makefile.Unix
@@ -0,0 +1,55 @@
+NEWSTYLE=1
+include ../../etc/Makefile
+include ../../etc/Makefile.flags
+
+
+osources = f1trigger_clear_event.f f1trigger_register_variables.f \
+ f1trigger_decode.f f1trigger_reset_event.f \
+ f1trigger_sort_by_counter.f
+
+makeregstuff = r_f1trigger_data_structures.f
+
+
+sources = $(osources) $(makeregstuff)
+
+libsources = $(sources)
+
+lib_targets := $(patsubst %.f, libf1trigger.a(%.o), $(libsources))
+install-dirs := lib
+bin_targets =
+
+#default:
+# @echo "nothing to make"
+
+ifdef NFSDIRECTORY
+../%.f : $(NFSDIRECTORY)/F1TRIGGER/%.f
+ ln -s $< $@
+
+.PRECIOUS: ../%.f
+else
+#
+# Rule for making the register subroutines
+#
+../r_%.f : ../%.cmn $(MAKEREG)
+ (cd .. ; $(MAKEREG) $(<F) -o $(@F) -e /dev/null)
+
+.PRECIOUS: ../r_%.f
+endif
+
+#
+# Get include files from INCLUDE directory
+#
+
+%.cmn ../%.cmn:: ../../INCLUDE/%.cmn
+ $(CP) $< $@
+
+%.dec ../%.dec:: ../../INCLUDE/%.dec
+ $(CP) $< $@
+
+%.par ../%.par:: ../../INCLUDE/%.par
+ $(CP) $< $@
+
+%.dte ../%.dte:: ../../INCLUDE/%.dte
+ $(CP) $< $@
+
+include $(sources:.f=.d)
diff --git a/F1TRIGGER/f1t_register_variables.f b/F1TRIGGER/f1t_register_variables.f
new file mode 100644
index 0000000..effed32
--- /dev/null
+++ b/F1TRIGGER/f1t_register_variables.f
@@ -0,0 +1,34 @@
+ subroutine f1t_register_variables(ABORT,err)
+ implicit none
+ save
+
+ character*20 here
+ parameter (here='f1t_register_variables')
+
+ logical ABORT
+ character*(*) err
+
+ logical FAIL
+ character*1000 why
+
+ err= ' '
+ ABORT= .false.
+
+ call r_f1trigger_data_structures
+
+*****************************************************************************
+*****************************************************************************
+c if(err.ne.' '.and.why.ne.' ') then
+c call G_append(err,' & '//why)
+c else if(why.ne.' ') then
+c err=why
+c endif
+ abort = abort.or.fail
+
+ if(abort.or.err.ne.' ') call G_add_path(here,err)
+
+ return
+ end
+
+*****************************************************************************
+*
diff --git a/F1TRIGGER/f1trigger_clear_event.f b/F1TRIGGER/f1trigger_clear_event.f
new file mode 100644
index 0000000..1e66e7e
--- /dev/null
+++ b/F1TRIGGER/f1trigger_clear_event.f
@@ -0,0 +1,26 @@
+ subroutine F1TRIGGER_CLEAR_EVENT(ABORT,err)
+ IMPLICIT NONE
+ SAVE
+ include 'f1trigger_data_structures.cmn'
+
+ character*13 here
+ parameter (here= 'f1trigger_clear_event')
+
+ logical ABORT
+ character*(*) err
+ integer*4 i
+
+ TRIGGER_F1_RAW_TOT_HITS = 0
+
+ do i=1,TRIGGER_F1_MAX_HITS
+ TRIGGER_F1_RAW_PLANE(i) = 0
+ TRIGGER_F1_RAW_COUNTER(i) = 0
+ TRIGGER_F1_START_TDC(i) = 0
+ TRIGGER_F1_START_TDC_COUNTER(i) = 0
+ enddo
+
+ ABORT= .FALSE.
+ err= ' '
+ RETURN
+ end
+
diff --git a/F1TRIGGER/f1trigger_decode.f b/F1TRIGGER/f1trigger_decode.f
new file mode 100644
index 0000000..e212519
--- /dev/null
+++ b/F1TRIGGER/f1trigger_decode.f
@@ -0,0 +1,33 @@
+ subroutine f1trigger_decode(pointer,lastslot, roc, bank,
+ & maxwords, did)
+
+
+*****************************************
+*****************************************
+
+ implicit none
+ integer*4 pointer,lastslot, roc, bank(*)
+ integer*4 maxwords, did
+ integer*4 g_decode_fb_detector ! Detector unpacking routine
+ include 'gen_detectorids.par'
+ include 'f1trigger_data_structures.cmn'
+
+
+*****************************************
+ if(did.eq.F1TRIGGER_ID)then
+ pointer = pointer +
+ $ g_decode_fb_detector(lastslot, roc, bank(pointer),
+ $ maxwords, did,
+ $ TRIGGER_F1_MAX_HITS,
+ $ TRIGGER_F1_RAW_TOT_HITS,
+ $ TRIGGER_F1_RAW_PLANE,
+ $ TRIGGER_F1_RAW_COUNTER, 1,
+ $ TRIGGER_F1_START_TDC,
+ $ 0, 0, 0)
+c write(*,*)'F1 Trigger time = ',TRIGGER_F1_START_TDC
+
+ endif
+*****************************************
+
+ end
+
diff --git a/F1TRIGGER/f1trigger_register_variables.f b/F1TRIGGER/f1trigger_register_variables.f
new file mode 100644
index 0000000..f9fefe3
--- /dev/null
+++ b/F1TRIGGER/f1trigger_register_variables.f
@@ -0,0 +1,30 @@
+ subroutine f1trigger_register_variables(ABORT,err)
+ implicit none
+ save
+
+ character*20 here
+ parameter (here='f1trigger_register_variables')
+
+ logical ABORT
+ character*(*) err
+
+ logical FAIL
+ character*1000 why
+
+ err= ' '
+ ABORT= .false.
+
+ call r_f1trigger_data_structures
+
+*****************************************************************************
+*****************************************************************************
+
+ abort = abort.or.fail
+
+ if(abort.or.err.ne.' ') call G_add_path(here,err)
+
+ return
+ end
+
+*****************************************************************************
+*
diff --git a/F1TRIGGER/f1trigger_reset_event.f b/F1TRIGGER/f1trigger_reset_event.f
new file mode 100644
index 0000000..ff69754
--- /dev/null
+++ b/F1TRIGGER/f1trigger_reset_event.f
@@ -0,0 +1,26 @@
+ subroutine F1TRIGGER_RESET_EVENT(ABORT,err)
+ IMPLICIT NONE
+ SAVE
+ include 'f1trigger_data_structures.cmn'
+
+ character*13 here
+ parameter (here= 'f1trigger_clear_event')
+
+ logical ABORT
+ character*(*) err
+ integer*4 i
+
+ TRIGGER_F1_RAW_TOT_HITS = 0
+
+ do i=1,TRIGGER_F1_MAX_HITS
+ TRIGGER_F1_RAW_PLANE(i) = 0
+ TRIGGER_F1_RAW_COUNTER(i) = 0
+ TRIGGER_F1_START_TDC(i) = 0
+ TRIGGER_F1_START_TDC_COUNTER(i) = 0
+ enddo
+
+ ABORT= .FALSE.
+ err= ' '
+ RETURN
+ end
+
diff --git a/F1TRIGGER/f1trigger_sort_by_counter.f b/F1TRIGGER/f1trigger_sort_by_counter.f
new file mode 100644
index 0000000..07eda35
--- /dev/null
+++ b/F1TRIGGER/f1trigger_sort_by_counter.f
@@ -0,0 +1,23 @@
+ subroutine f1trigger_sort_by_counter()
+ IMPLICIT NONE
+ include 'f1trigger_data_structures.cmn'
+ integer*4 i
+c
+c
+c Subroutine sorts Start times by counter
+c
+c
+ do i = 1, TRIGGER_F1_RAW_TOT_HITS
+ TRIGGER_F1_START_TDC_COUNTER(TRIGGER_F1_RAW_COUNTER(i)) = TRIGGER_F1_START_TDC(i)
+ enddo
+c this seems to be wrong. Took out PB Oct. 2, 2008
+c do i = TRIGGER_F1_RAW_TOT_HITS, TRIGGER_F1_MAX_HITS
+c TRIGGER_F1_START_TDC_COUNTER(TRIGGER_F1_RAW_COUNTER(i)) = 0
+c enddo
+c write(6,'(''dbg f1 B'',3i10)')
+c > TRIGGER_F1_RAW_TOT_HITS,
+c > TRIGGER_F1_START_TDC(1),
+c > TRIGGER_F1_START_TDC_COUNTER(1)
+
+
+ end
diff --git a/HACK/.cvsignore b/HACK/.cvsignore
new file mode 100644
index 0000000..0b6ddf9
--- /dev/null
+++ b/HACK/.cvsignore
@@ -0,0 +1,2 @@
+O.*
+r_*.f
diff --git a/HACK/CVS/Entries b/HACK/CVS/Entries
new file mode 100644
index 0000000..2d03676
--- /dev/null
+++ b/HACK/CVS/Entries
@@ -0,0 +1,9 @@
+/.cvsignore/1.1/Thu Jul 8 18:40:50 2004//Tsane
+/Makefile/1.1/Mon Dec 7 22:11:19 1998//Tsane
+/Makefile.Unix/1.10.24.1/Mon Sep 10 20:08:02 2007//Tsane
+/hack_anal.f/1.4/Wed Oct 11 14:02:00 1995//Tsane
+/hack_copyevt.f/1.2/Wed May 24 13:47:29 1995//Tsane
+/hack_initialize.f/1.1/Mon Jul 25 18:03:30 1994//Tsane
+/hack_register_variables.f/1.4/Wed Oct 11 14:12:40 1995//Tsane
+/hack_shutdown.f/1.1/Mon Jul 25 18:03:54 1994//Tsane
+D
diff --git a/HACK/CVS/Repository b/HACK/CVS/Repository
new file mode 100644
index 0000000..0aa97ff
--- /dev/null
+++ b/HACK/CVS/Repository
@@ -0,0 +1 @@
+Analyzer/HACK
diff --git a/HACK/CVS/Root b/HACK/CVS/Root
new file mode 100644
index 0000000..6288c3f
--- /dev/null
+++ b/HACK/CVS/Root
@@ -0,0 +1 @@
+whit@cvs.jlab.org:/group/hallc/cvsroot
diff --git a/HACK/CVS/Tag b/HACK/CVS/Tag
new file mode 100644
index 0000000..25d73f7
--- /dev/null
+++ b/HACK/CVS/Tag
@@ -0,0 +1 @@
+Tsane
diff --git a/HACK/Makefile b/HACK/Makefile
new file mode 100644
index 0000000..e3ff2b4
--- /dev/null
+++ b/HACK/Makefile
@@ -0,0 +1,8 @@
+#
+# $Log: Makefile,v $
+# Revision 1.1 1998/12/07 22:11:19 saw
+# Initial setup
+#
+ETC=../etc
+
+include $(ETC)/Makefile.NEW
diff --git a/HACK/Makefile.Unix b/HACK/Makefile.Unix
new file mode 100644
index 0000000..b689f74
--- /dev/null
+++ b/HACK/Makefile.Unix
@@ -0,0 +1,73 @@
+#
+# $Log: Makefile.Unix,v $
+# Revision 1.10.24.1 2007/09/10 20:08:02 pcarter
+# Implemented changes to allow compilation on RHEL 3,4,5 and MacOSX
+#
+# Revision 1.10 1999/01/21 21:39:29 saw
+# Clean up Include file rules
+#
+# Revision 1.9 1998/12/09 16:31:16 saw
+# Remove dependence on Csoft environment variable
+#
+# Revision 1.8 1998/12/07 22:11:19 saw
+# Initial setup
+#
+# Revision 1.7 1996/09/04 15:41:55 saw
+# (SAW) Fixes for linux
+#
+# Revision 1.6 1996/04/30 12:30:51 saw
+# (SAW) New makefile style
+#
+# Revision 1.5 1996/01/16 21:29:41 cdaq
+# (SAW) Use $(CP) instead of cp
+#
+# Revision 1.4 1995/07/28 14:19:08 cdaq
+# (SAW) Add NFSDIRECTORY stuff
+#
+# Revision 1.3 1995/03/13 18:43:38 cdaq
+# (SAW) Add -f switch on include file copy commands
+#
+# Revision 1.2 1995/01/27 20:51:03 cdaq
+# SAW) Remove RCS from include file rules
+#
+# Revision 1.1 1994/07/25 18:03:10 cdaq
+# Initial revision
+#
+NEWSTYLE = 1
+include ../../etc/Makefile
+include ../../etc/Makefile.flags
+
+hack_source = hack_register_variables.f hack_initialize.f hack_anal.f \
+ hack_shutdown.f hack_copyevt.f r_hack_.f
+
+libsources = $(hack_source)
+
+sources = $(libsources)
+
+lib_targets := $(patsubst %.f, libhack.a(%.o), $(sources))
+
+install-dirs := lib
+bin_targets =
+
+#default:
+# @echo "nothing to make"
+
+#
+# Rule for making the register subroutines
+#
+../r_%.f : ../%.cmn $(MAKEREG)
+ (cd .. ; $(MAKEREG) $(<F) -o $(@F) -e /dev/null)
+
+.PRECIOUS: ../r_%.f
+
+ifdef NFSDIRECTORY
+../%.f : $(NFSDIRECTORY)/HACK/%.f
+ ln -s $< $@
+
+.PRECIOUS: ../%.f
+endif
+
+%.cmn ../%.cmn:: ../../INCLUDE/%.cmn
+ $(CP) $< $@
+
+include $(sources:.f=.d)
diff --git a/HACK/hack_anal.f b/HACK/hack_anal.f
new file mode 100644
index 0000000..d9d8907
--- /dev/null
+++ b/HACK/hack_anal.f
@@ -0,0 +1,80 @@
+ subroutine hack_anal(ABORT, err)
+*
+*-----------------------------------------------------------------------------
+*-- file: hack_anal.f
+*-- USER DEVELOPMENT routine; called for each event;
+*>>- user can communicate with setup files via the arrays
+*>> HACK_INT(MAX_USER_PAR) (integer) and HACK_REAL(MAX_USER_PAR) (real)
+*>> defined in a common block in file HACK_.CMN; max_user_par=1024.
+*- If additional variables are needed to be accessible from setup files
+* (e.g. histogram definitions, calibration parameters), these should be
+* defined in HACK_.CMN and
+* registered in file HACK_REGISTER_VARIABLES.F.
+*- Before event processing begins, HACK_REGISTER_VARIABLES and HACK_INITIALIZE
+* are called. They are available to be modified by the user.
+*- After all events have been processed, hack_shutdown in file
+* HACK_SHUTDOWN.F is called to allow final manipulations, e.g.
+* printed output.
+* $Log: hack_anal.f,v $
+* Revision 1.4 1995/10/11 14:02:00 cdaq
+* (JRA) Cleanup
+*
+* Revision 1.3 1995/07/28 14:21:57 cdaq
+* (SAW) Use specific bit manipulation routines for f2c compatibility
+*
+* Revision 1.2 1994/07/26 21:03:02 cdaq
+* (SAW) Remove event argument.
+*
+* Revision 1.1 94/07/25 18:03:25 18:03:25 cdaq (Data Acquisition Account)
+* Initial revision
+*
+*-----------------------------------------------------------------------------
+*--- for information, the following lines are copied from file hack_.cmn:
+*-- file: hack_.cmn
+*-- include file for USER DEVOLOPMENT common block definitions;
+*-- The parameter hack_enable must be set to .ne. 0 to enable execution of
+* hack_anal subroutine for each event.
+*-- any additional arrays or variables my be added by the user
+* integer*4 hack_enable
+* common /hack_c/ hack_enable
+* integer hack_hmssc_au(16,4) !raw HMS-scintillator ADC up in fixed array
+* integer hack_hmssc_ad(16,4) !raw HMS-scintillator ADC down in fixed array
+* integer hack_hmssc_tu(16,4) !raw HMS-scintillator TDC up in fixed array
+* integer hack_hmssc_td(16,4) !raw HMS-scintillator TDC down in fixed array
+* integer hack_hmssc_go(16,4) !info about which ADC/TDC fired
+* common/hack_copyeve_c/ hack_hmssc_au,hack_hmssc_ad,
+* & hack_hmssc_tu,hack_hmssc_td,hack_hmssc_go
+*-----------------------------------------------------------------------------
+*
+ implicit none
+ logical ABORT
+ character*(*) err
+*
+ include 'hms_data_structures.cmn'
+ include 'sos_data_structures.cmn'
+ include 'hack_.cmn'
+ integer*4 jiand ! To help f2c
+*
+ ABORT = .FALSE. !needed as default
+ err = ' ' !needed as default
+
+c if(jiand(event(2),'FFFF'X).ne.'10CC'X) return ! valid physics event?
+
+*-----------------------------------------------------------------
+*-- copy HMS scintillator data for one event into arrays hack_hmssc*(j,k)
+* *=au,ad,tu,td,go [adcup/do,tdcup/do,good data index (-1 to +2) ]
+* j=1-16 [scintillator number]
+* k=1-4 [plane number]
+** call hack_copyevt(ABORT,err)
+*-----------------------------------------------------------------
+*-- >>>>>>>insert user code here<<<<<<<<
+*EXAMP meantime = hack_hmssc_tu(s_nr,p_nr)+hack_hmssc_td(s_nr,p_nr))
+*EXAMP offset = 200
+*EXAMP index = (p_nr-1)*16 + s_nr + offset !output array index
+*EXAMP *-- assuming hack_real contains user supplied calibration values
+*EXAMP hack_int(index) = nint(meantime*hack_real(index)) !calibrated value
+*-----------------------------------------------------------------
+*
+ return
+ end
+*
diff --git a/HACK/hack_copyevt.f b/HACK/hack_copyevt.f
new file mode 100644
index 0000000..275926c
--- /dev/null
+++ b/HACK/hack_copyevt.f
@@ -0,0 +1,66 @@
+*----------------------------------------------------------------
+*-- file: hack_copyevt.f
+*- subroutine copies adc and tdc data into fixed array, it allows for
+* sparsified adc and tdc readout
+*- this is a complete routine and should have no additional user code
+* $Log: hack_copyevt.f,v $
+* Revision 1.2 1995/05/24 13:47:29 cdaq
+* (SAW) Split gen_data_data_structures into gen, hms, sos, and coin parts"
+*
+* Revision 1.1 1994/07/25 18:03:36 cdaq
+* Initial revision
+*
+*
+ subroutine hack_copyevt(ABORT, err)
+ implicit none
+ include 'hms_data_structures.cmn'
+ include 'hack_.cmn'
+ logical ABORT
+ character*(*) err
+*
+ integer i,j,k
+ integer tdcup,tdcdo,adcup,adcdo,plane,count
+*-----------------------------------------------------------------------------
+ ABORT = .FALSE.
+ err = ' '
+*-----------------------------------------------------------------------------
+* initialize array with values of -1
+ do k = 1,4 !4 planes
+ do j = 1,16 !scintillators in a plane
+ hack_hmssc_au(j,k) = -1 !"no data" value of -1, adc up
+ hack_hmssc_ad(j,k) = -1 !"no data" value of -1, adc down
+ hack_hmssc_tu(j,k) = -1 !"no data" value of -1, tdc up
+ hack_hmssc_td(j,k) = -1 !"no data" value of -1, tdc down
+ hack_hmssc_go(j,k) = -1 !"no data" value of -1, good data indic.
+ enddo
+ enddo
+*
+* copy HMS scintillator data into fixed array
+ do i = 1,hscin_all_tot_hits !copy all hits to hack array
+ tdcup = hscin_all_tdc_pos(i)
+ tdcdo = hscin_all_tdc_neg(i)
+ adcup = hscin_all_adc_pos(i)
+ adcdo = hscin_all_adc_neg(i)
+ plane = hscin_all_plane_num(i)
+ count = hscin_all_counter_num(i)
+ hack_hmssc_au(count,plane) = adcup
+ hack_hmssc_ad(count,plane) = adcdo
+ hack_hmssc_tu(count,plane) = tdcup
+ hack_hmssc_td(count,plane) = tdcdo
+ hack_hmssc_go(count,plane) = 0 !detector has data (-1=no data)
+ if ((tdcup.gt.0.and.tdcup.lt.4000).or.
+ & (tdcdo.gt.0.and.tdcdo.lt.4000))
+ & hack_hmssc_go(count,plane) = 1 !one tdc present
+ if ((tdcup.gt.0.and.tdcup.lt.4000).and.
+ & (tdcdo.gt.0.and.tdcdo.lt.4000))
+ & hack_hmssc_go(count,plane) = 2 !both tdcs present
+ enddo
+*
+* for non-sparsified readout the data can also be found in the following way
+* hscin_all_adc_pos(1-16) == S1X(1-16) (same for _neg)
+* (17-26) == S1Y(1-10)
+* (27-42) == S2X(1-16)
+* (43-52) == S2Y(1-10)
+ return
+ end
+*
diff --git a/HACK/hack_initialize.f b/HACK/hack_initialize.f
new file mode 100644
index 0000000..4ddffb1
--- /dev/null
+++ b/HACK/hack_initialize.f
@@ -0,0 +1,37 @@
+* ----------------------------------------------------------------------
+*-- file HACK_INITIALIZE.F
+*-- Initialization for User Develpment Code
+* $Log: hack_initialize.f,v $
+* Revision 1.1 1994/07/25 18:03:30 cdaq
+* Initial revision
+*
+*
+ subroutine hack_initialize(ABORT,err)
+*
+* ----------------------------------------------------------------------
+*-- first declare variables and store them in a common block (extra file)
+ implicit none
+ logical ABORT
+ character*(*) err
+ include 'gen_data_structures.cmn'
+ include 'hack_.cmn'
+*
+*EXAMP integer i
+*
+*-- >>>>>>>>>> insert additional user declarations here <<<<<<<<<
+* ----------------------------------------------------------------------
+ ABORT = .FALSE.
+ err = ' '
+* ----------------------------------------------------------------------
+* ----------------------------------------------------------------------
+*-- intialize any varibles that need initialization
+*EXAMP do i = 1, max_user_par
+*EXAMP hack_int(i) = 0
+*EXAMP hack_real(i) = 0.0
+*EXAMP enddo
+*
+*-- >>>>>>>>>> insert additional user code here <<<<<<<<<
+* ----------------------------------------------------------------------
+*
+ return
+ end
diff --git a/HACK/hack_register_variables.f b/HACK/hack_register_variables.f
new file mode 100644
index 0000000..56a2a96
--- /dev/null
+++ b/HACK/hack_register_variables.f
@@ -0,0 +1,32 @@
+ subroutine hack_register_variables(ABORT,err)
+*
+* ----------------------------------------------------------------------
+*-- file hack_register_variables.f
+*-- Initialization for User Develpment Code
+* $Log: hack_register_variables.f,v $
+* Revision 1.4 1995/10/11 14:12:40 cdaq
+* (SAW) Call makereg generated r_hack_ instead of making explicit reg calls
+*
+* Revision 1.3 1995/08/09 18:49:38 cdaq
+* (JRA) Comment out obnoxious print statement
+*
+* Revision 1.2 1995/07/28 14:22:29 cdaq
+* (SAW) Change type to print for f2c compatibility
+*
+* Revision 1.1 1994/07/25 18:03:44 cdaq
+* Initial revision
+* ----------------------------------------------------------------------
+ implicit none
+ save
+ logical ABORT
+ character*(*) err
+
+* ----------------------------------------------------------------------
+
+ ABORT = .FALSE.
+ err = ' '
+
+ call r_hack_
+
+ return
+ end
diff --git a/HACK/hack_shutdown.f b/HACK/hack_shutdown.f
new file mode 100644
index 0000000..2e8ba07
--- /dev/null
+++ b/HACK/hack_shutdown.f
@@ -0,0 +1,27 @@
+* ----------------------------------------------------------------
+*-- file: hack_shutdown.f
+*-- this subroutine does User Devolpment tasks after the
+* all events have been collected.
+* $Log: hack_shutdown.f,v $
+* Revision 1.1 1994/07/25 18:03:54 cdaq
+* Initial revision
+*
+*
+ subroutine hack_shutdown(ABORT, err)
+ implicit none !needed
+ include 'gen_data_structures.cmn' !needed
+ include 'hack_.cmn' !needed
+ logical ABORT !needed
+ character*(*) err !needed
+*-----------------------------------------------------------------------------
+ ABORT = .FALSE. !needed as default
+ err = ' ' !needed as default
+*-----------------------------------------------------------------------------
+*-- >>>>>>>>>>>>>> insert user code here <<<<<<<<<<<
+** call hack_f_c123(ABORT, err) !get centroids etc.
+** call hack_f_c4(ABORT, err) !make scint. pedestal centroid file
+** call hack_f_c5(ABORT, err) !make calorim. pedestal centroid file
+*-----------------------------------------------------------------------------
+ return
+ end
+*
diff --git a/HTRACKING/.cvsignore b/HTRACKING/.cvsignore
new file mode 100644
index 0000000..0b6ddf9
--- /dev/null
+++ b/HTRACKING/.cvsignore
@@ -0,0 +1,2 @@
+O.*
+r_*.f
diff --git a/HTRACKING/CVS/Entries b/HTRACKING/CVS/Entries
new file mode 100644
index 0000000..bff6f5d
--- /dev/null
+++ b/HTRACKING/CVS/Entries
@@ -0,0 +1,110 @@
+/.cvsignore/1.1/Thu Jul 8 18:10:18 2004//Tsane
+/Makefile/1.1/Tue Dec 8 14:33:24 1998//Tsane
+/Makefile.Unix/1.29.6.4.2.1/Tue Oct 21 20:33:17 2008//Tsane
+/h_aero.f/1.4.14.1.2.1/Wed Oct 8 17:23:14 2008//Tsane
+/h_analyze_pedestal.f/1.9/Fri Dec 20 21:53:34 2002//Tsane
+/h_cal.f/1.11/Thu Apr 3 00:43:13 2003//Tsane
+/h_cal_calib.f/1.3.20.1.2.1/Fri Jan 16 18:48:02 2009//Tsane
+/h_cal_eff.f/1.8/Wed Oct 2 13:42:42 2002//Tsane
+/h_cal_eff_shutdown.f/1.5/Tue Feb 23 18:35:24 1999//Tsane
+/h_calc_pedestal.f/1.14/Fri Sep 5 16:56:59 2003//Tsane
+/h_cer.f/1.2/Mon May 22 19:39:06 1995//Tsane
+/h_cer_eff.f/1.4/Wed Feb 10 18:19:06 1999//Tsane
+/h_cer_eff_shutdown.f/1.1/Thu Aug 31 14:54:31 1995//Tsane
+/h_chamnum.f/1.3/Tue Apr 30 12:32:51 1996//Tsane
+/h_choose_single_hit.f/1.4/Tue Jan 16 21:45:35 1996//Tsane
+/h_clusters_cal.f/1.5/Wed Feb 3 21:13:23 1999//Tsane
+/h_correct_cal.f/1.7/Thu Apr 3 00:43:13 2003//Tsane
+/h_correct_cal_neg.f/1.6/Thu Apr 3 00:43:13 2003//Tsane
+/h_correct_cal_pos.f/1.7/Thu Apr 3 00:43:13 2003//Tsane
+/h_dc_eff.f/1.1/Thu Aug 31 14:59:48 1995//Tsane
+/h_dc_eff_shutdown.f/1.2/Fri Aug 30 19:54:11 1996//Tsane
+/h_dc_trk_eff.f/1.2/Wed Jan 17 18:19:40 1996//Tsane
+/h_dc_trk_eff_shutdown.f/1.1/Mon Oct 9 20:04:23 1995//Tsane
+/h_dpsifun.f/1.3/Mon May 22 19:39:08 1995//Tsane
+/h_drift_dist_calc.f/1.7/Tue Apr 30 12:35:14 1996//Tsane
+/h_drift_time_calc.f/1.5/Mon Oct 9 20:16:02 1995//Tsane
+/h_dump_cal.f/1.4/Thu Jun 10 16:48:04 1999//Tsane
+/h_dump_peds.f/1.7.24.1/Thu Sep 13 04:02:18 2007//Tsane
+/h_dump_tof.f/1.7.24.1/Tue Jan 8 22:59:42 2008//Tsane
+/h_fcnchisq.f/1.3/Mon May 22 19:39:10 1995//Tsane
+/h_fill_aero_raw_hist.f/1.1/Fri Dec 20 21:54:28 2002//Tsane
+/h_fill_cal_hist.f/1.9/Wed Oct 2 13:42:43 2002//Tsane
+/h_fill_dc_dec_hist.f/1.6/Wed Oct 2 13:42:43 2002//Tsane
+/h_fill_dc_fp_hist.f/1.5/Mon May 22 19:39:11 1995//Tsane
+/h_fill_dc_target_hist.f/1.3/Mon May 22 19:39:11 1995//Tsane
+/h_fill_fpp.f/1.1.2.7/Thu Nov 29 21:09:20 2007//Tsane
+/h_fill_scin_raw_hist.f/1.9/Wed Jul 31 20:17:52 2002//Tsane
+/h_find_best_stub.f/1.6/Tue Jan 16 21:51:00 1996//Tsane
+/h_find_easy_space_point.f/1.1/Wed Oct 25 15:00:13 1995//Tsane
+/h_fpp.f/1.1.2.5/Mon Oct 22 15:23:45 2007//Tsane
+/h_fpp_drift.f/1.1.2.20/Tue Jan 8 23:00:10 2008//Tsane
+/h_fpp_fit.f/1.1.2.4/Thu Oct 25 00:06:54 2007//Tsane
+/h_fpp_geometry.f/1.1.2.8/Thu Nov 1 21:10:18 2007//Tsane
+/h_fpp_statistics.f/1.1.2.5/Thu Nov 1 19:14:51 2007//Tsane
+/h_fpp_tracking.f/1.1.2.12/Thu Nov 29 19:48:26 2007//Tsane
+/h_generate_geometry.f/1.9.24.1/Mon Oct 22 15:23:06 2007//Tsane
+/h_init_cal.f/1.5/Thu Apr 3 00:43:13 2003//Tsane
+/h_init_cer.f/1.1/Thu Aug 31 14:53:56 1995//Tsane
+/h_init_fpp.f/1.1.2.5/Thu Oct 25 00:06:54 2007//Tsane
+/h_init_histid.f/1.8.24.3/Tue Oct 30 00:28:27 2007//Tsane
+/h_init_physics.f/1.6/Wed Feb 10 18:15:58 1999//Tsane
+/h_init_scin.f/1.7/Tue Apr 30 12:44:35 1996//Tsane
+/h_left_right.f/1.13.24.1/Mon Sep 10 20:28:00 2007//Tsane
+/h_link_stubs.f/1.9/Tue Apr 1 15:21:33 2003//Tsane
+/h_pattern_recognition.f/1.14/Tue Apr 1 13:49:27 2003//Tsane
+/h_physics.f/1.23.20.2.2.2/Fri Jun 5 17:59:29 2009//Tsane
+/h_physics_stat.f/1.6/Tue Oct 10 16:50:08 1995//Tsane
+/h_print_decoded_dc.f/1.4/Tue Oct 10 16:51:54 1995//Tsane
+/h_print_links.f/1.2/Mon May 22 19:39:17 1995//Tsane
+/h_print_pr.f/1.2/Mon May 22 19:39:17 1995//Tsane
+/h_print_raw_dc.f/1.2/Mon May 22 19:39:17 1995//Tsane
+/h_print_stubs.f/1.2/Mon May 22 19:39:18 1995//Tsane
+/h_print_tar_tracks.f/1.3/Mon May 22 19:39:18 1995//Tsane
+/h_print_tracks.f/1.3/Mon May 22 19:39:19 1995//Tsane
+/h_prt_cal_clusters.f/1.3/Thu Jan 21 21:40:14 1999//Tsane
+/h_prt_cal_decoded.f/1.2/Mon May 22 19:39:19 1995//Tsane
+/h_prt_cal_raw.f/1.5/Thu Dec 17 22:02:39 1998//Tsane
+/h_prt_cal_sparsified.f/1.3/Thu Dec 17 22:02:39 1998//Tsane
+/h_prt_cal_tests.f/1.2/Mon May 22 19:39:22 1995//Tsane
+/h_prt_cal_tracks.f/1.5/Fri Mar 21 22:21:51 2003//Tsane
+/h_prt_dec_scin.f/1.8/Tue Jan 16 21:55:27 1996//Tsane
+/h_prt_raw_scin.f/1.6/Thu Jul 20 19:08:41 1995//Tsane
+/h_prt_tof.f/1.5.26.1/Mon Nov 17 15:58:28 2008//Tsane
+/h_prt_track_tests.f/1.2/Mon May 22 19:39:24 1995//Tsane
+/h_psifun.f/1.2/Mon May 22 19:39:24 1995//Tsane
+/h_raw_dump_all.f/1.2/Mon May 22 19:39:25 1995//Tsane
+/h_reconstruction.f/1.13.24.6/Fri Nov 2 19:52:52 2007//Tsane
+/h_register_param.f/1.11.24.1/Wed Aug 22 19:09:30 2007//Tsane
+/h_report_bad_data.f/1.3/Fri Aug 30 20:34:49 1996//Tsane
+/h_satcorr.f/1.2/Fri Dec 19 19:53:15 2003//Tsane
+/h_scin_eff.f/1.8/Fri Sep 5 21:08:34 2003//Tsane
+/h_scin_eff_shutdown.f/1.9/Tue Feb 23 18:40:48 1999//Tsane
+/h_select_best_track.f/1.6/Wed Mar 23 16:33:32 2005//Tsane
+/h_select_best_track_prune.f/1.1.8.1/Mon Sep 10 20:28:01 2007//Tsane
+/h_select_best_track_using_scin.f/1.1/Thu Feb 26 22:19:05 2004//Tsane
+/h_solve_3by3.f/1.4/Tue Oct 10 17:36:37 1995//Tsane
+/h_sp_destroy.f/1.1.22.1/Mon Sep 10 20:28:01 2007//Tsane
+/h_sp_multiwire.f/1.1.22.1/Mon Sep 10 20:28:01 2007//Tsane
+/h_sparsify_cal.f/1.13/Wed Oct 2 13:42:43 2002//Tsane
+/h_strip_scin.f/1.11.24.1/Mon Oct 22 15:22:50 2007//Tsane
+/h_targ_trans.f/1.16.24.2.2.9/Wed Sep 16 21:49:20 2009//Tsane
+/h_targ_trans_init.f/1.6.16.1.2.1/Tue Oct 21 20:33:17 2008//Tsane
+/h_tof.f/1.19.6.2.2.7/Tue Mar 31 19:33:00 2009//Tsane
+/h_tof_fit.f/1.10/Wed Sep 4 13:36:24 1996//Tsane
+/h_tof_init.f/1.6.24.1.2.1/Mon Nov 17 15:58:44 2008//Tsane
+/h_track.f/1.5.26.3/Tue Oct 25 16:12:30 2011//Tsane
+/h_track_fit.f/1.11/Tue Jan 16 21:42:18 1996//Tsane
+/h_track_tests.f/1.4/Tue Nov 15 18:39:18 2005//Tsane
+/h_tracks_cal.f/1.10/Tue Mar 15 20:09:12 2005//Tsane
+/h_trans_cal.f/1.8/Wed Mar 3 19:26:25 2004//Tsane
+/h_trans_cer.f/1.2/Tue Jan 16 21:38:47 1996//Tsane
+/h_trans_dc.f/1.15.26.2/Wed Sep 2 13:40:39 2009//Tsane
+/h_trans_fpp.f/1.1.2.9/Thu Nov 29 21:13:44 2007//Tsane
+/h_trans_fpp_hms.f/1.1.2.5/Tue Oct 16 23:47:33 2007//Tsane
+/h_trans_misc.f/1.7.26.1/Wed Oct 8 17:21:47 2008//Tsane
+/h_trans_scin.f/1.21.8.7/Tue Feb 23 14:50:40 2010//Tsane
+/h_wire_center_calc.f/1.5/Wed Sep 4 14:24:38 1996//Tsane
+/hms_sane_track.f/1.1.2.6/Fri Apr 15 21:52:30 2011//Tsane
+/mt19937.f/1.1.2.1/Tue Sep 18 02:47:50 2007//Tsane
+D
diff --git a/HTRACKING/CVS/Repository b/HTRACKING/CVS/Repository
new file mode 100644
index 0000000..8799c1b
--- /dev/null
+++ b/HTRACKING/CVS/Repository
@@ -0,0 +1 @@
+Analyzer/HTRACKING
diff --git a/HTRACKING/CVS/Root b/HTRACKING/CVS/Root
new file mode 100644
index 0000000..6288c3f
--- /dev/null
+++ b/HTRACKING/CVS/Root
@@ -0,0 +1 @@
+whit@cvs.jlab.org:/group/hallc/cvsroot
diff --git a/HTRACKING/CVS/Tag b/HTRACKING/CVS/Tag
new file mode 100644
index 0000000..25d73f7
--- /dev/null
+++ b/HTRACKING/CVS/Tag
@@ -0,0 +1 @@
+Tsane
diff --git a/HTRACKING/Makefile b/HTRACKING/Makefile
new file mode 100644
index 0000000..ad88f58
--- /dev/null
+++ b/HTRACKING/Makefile
@@ -0,0 +1,8 @@
+#
+# $Log: Makefile,v $
+# Revision 1.1 1998/12/08 14:33:24 saw
+# Initial Setup
+#
+ETC=../etc
+
+include $(ETC)/Makefile.NEW
diff --git a/HTRACKING/Makefile.Unix b/HTRACKING/Makefile.Unix
new file mode 100644
index 0000000..c2ea1d5
--- /dev/null
+++ b/HTRACKING/Makefile.Unix
@@ -0,0 +1,209 @@
+#
+# $Log: Makefile.Unix,v $
+# Revision 1.29.6.4.2.1 2008/10/21 20:33:17 cdaq
+# target recon with B field added
+#
+# Revision 1.29.6.4 2007/09/18 02:46:35 brash
+# Updates to FPP code to a) include simulated analyzers and b) fix bugs in FPP angle, zclose, and sclose calculations.
+#
+# Revision 1.29.6.3 2007/09/12 14:40:03 brash
+# *** empty log message ***
+#
+# Revision 1.29.6.2 2007/09/10 20:08:02 pcarter
+# Implemented changes to allow compilation on RHEL 3,4,5 and MacOSX
+#
+# Revision 1.29.6.1 2007/08/22 19:09:29 frw
+# added FPP
+#
+# Revision 1.30 2006/06/23 frw
+# add FPP files
+#
+# Revision 1.29 2005/03/23 16:33:32 jones
+# Add new code s_select_best_track_prune.f (P Bosted)
+#
+# Revision 1.28 2004/02/26 22:19:33 jones
+# add h_select_best_track_using_scin.o
+#
+# Revision 1.27 2003/04/01 15:20:55 jones
+# fix spelling of h_sp_destroy.f
+#
+# Revision 1.26 2003/04/01 13:49:27 jones
+# Modifications to tracking codes.
+# Mainly fix problems at high rates. (M. E. Christy)
+#
+# Revision 1.25 2003/03/21 22:21:51 jones
+# Modified and rearrange routines to calibrate the HMS calorimeter (V. Tadevosyan)
+#
+# Revision 1.24 2002/12/20 21:53:32 jones
+# Modified by Hamlet for new HMS aerogel
+#
+# Revision 1.23 2002/11/11 18:48:27 jones
+# Modify Makefile.Unix to include hcal_clb_det.f and hcal_raw_thr.f
+#
+# Revision 1.22 1999/02/23 18:30:11 csa
+# Add h_satcorr
+#
+# Revision 1.21 1999/01/21 21:40:13 saw
+# Extra shower counter tube modifications
+#
+# Revision 1.20 1998/12/07 22:11:21 saw
+# Initial setup
+#
+# Revision 1.19 1996/11/08 20:33:53 saw
+# (SAW) Add AIX compatibility
+#
+# Revision 1.18 1996/09/04 14:25:57 saw
+# (SAW) Fixup some O. subdirectory errors
+#
+# Revision 1.17 1996/04/29 18:29:23 saw
+# (SAW) New makefile style
+#
+# Revision 1.16 1996/01/16 21:32:55 cdaq
+# (SAW) Use $(CP) instead of cp. Add h_cer_eff, h_cer_eff_shutdown, h_init_cer,
+# h_trans_cer, h_dc_eff, h_dc_eff_shutdown, h_dump_peds, h_dump_cal,
+# h_report_bad_data, h_dc_trk_eff, h_dc_trk_eff_shutdown,
+# h_find_easy_space_point, r_hms_cer_parms
+#
+# Revision 1.15 1995/07/20 14:27:40 cdaq
+# (SAW) Add option to get source via softlink to read only source tree
+#
+# Revision 1.14 1995/05/24 13:22:33 cdaq
+# Add h_trans_misc, h_fill_cal_hist, h_init_histid, r_hms_pedestals
+#
+# Revision 1.13 1995/04/06 20:07:31 cdaq
+# (SAW) Add pedestal routines
+#
+# Revision 1.12 1995/03/08 20:33:52 cdaq
+# (SAW) Add h_scin_eff, h_scin_eff_shutdown, h_cal_eff, and h_cal_eff_shutdown
+#
+# Revision 1.11 1995/02/02 16:37:23 cdaq
+# (SAW) Add -f flag on copy of include files
+#
+# Revision 1.10 1995/01/27 20:49:23 cdaq
+# (SAW) Remove RCS from include file rules
+#
+# Revision 1.9 1994/11/23 15:36:37 cdaq
+# (SAW) Update list of sources
+#
+# Revision 1.8 1994/10/11 18:32:09 cdaq
+# *** empty log message ***
+#
+# Revision 1.7 1994/08/18 04:23:22 cdaq
+# (SAW) Call makereg generated routines to register variables
+#
+# Revision 1.6 1994/08/04 03:50:37 cdaq
+# (SAW) Add rule for .dte files
+#
+# Revision 1.5 1994/07/07 15:17:45 cdaq
+# (SAW) Fix a bug so that all sources not get compiled
+#
+# Revision 1.4 1994/06/14 05:02:00 cdaq
+# (SAW) Add h_init_physics and h_physics_stat
+#
+# Revision 1.3 1994/06/07 18:49:33 cdaq
+# Add register_bypass and register_statistics routines
+#
+# Revision 1.2 1994/05/19 13:55:04 cdaq
+# Add new routines from DFG
+#
+# Revision 1.1 1994/04/15 20:30:16 cdaq
+# Initial revision
+#
+NEWSTYLE = 1
+include ../../etc/Makefile
+include ../../etc/Makefile.flags
+
+osources = h_cal.f h_cer.f h_chamnum.f h_dpsifun.f \
+ h_drift_dist_calc.f h_drift_time_calc.f h_fcnchisq.f \
+ h_find_best_stub.f h_generate_geometry.f h_left_right.f \
+ h_link_stubs.f h_pattern_recognition.f h_physics.f h_print_links.f \
+ h_print_pr.f h_print_stubs.f h_print_tar_tracks.f h_print_tracks.f \
+ h_psifun.f h_register_param.f h_reconstruction.f h_targ_trans.f \
+ h_tof.f h_track.f h_track_fit.f \
+ h_trans_cal.f h_trans_dc.f h_trans_scin.f h_wire_center_calc.f \
+ h_print_decoded_dc.f h_print_raw_dc.f
+newstuff = h_clusters_cal.f h_correct_cal.f \
+ h_fill_dc_dec_hist.f h_fill_dc_fp_hist.f h_init_cal.f \
+ h_init_scin.f h_prt_cal_clusters.f h_prt_cal_decoded.f \
+ h_prt_cal_raw.f h_prt_cal_sparsified.f h_prt_cal_tests.f \
+ h_prt_cal_tracks.f h_prt_dec_scin.f h_prt_raw_scin.f h_prt_tof.f \
+ h_prt_track_tests.f h_raw_dump_all.f h_sparsify_cal.f h_tof_fit.f \
+ h_tof_init.f h_tracks_cal.f h_fill_scin_raw_hist.f
+newerstuff = h_fill_dc_target_hist.f h_targ_trans_init.f \
+ h_init_physics.f h_physics_stat.f \
+ h_strip_scin.f h_choose_single_hit.f h_solve_3by3.f \
+ h_dump_tof.f h_select_best_track.f h_select_best_track_using_scin.f \
+ h_scin_eff.f h_scin_eff_shutdown.f \
+ h_cal_eff.f h_cal_eff_shutdown.f h_analyze_pedestal.f \
+ h_calc_pedestal.f h_trans_misc.f h_fill_cal_hist.f h_init_histid.f \
+ h_cer_eff.f h_cer_eff_shutdown.f h_init_cer.f h_trans_cer.f \
+ h_dc_eff.f h_dc_eff_shutdown.f h_dump_peds.f h_dump_cal.f \
+ h_report_bad_data.f h_dc_trk_eff.f h_dc_trk_eff_shutdown.f \
+ h_find_easy_space_point.f h_track_tests.f \
+ h_correct_cal_pos.f h_correct_cal_neg.f \
+ h_satcorr.f \
+ h_cal_calib.f h_aero.f h_fill_aero_raw_hist.f hms_sane_track.f\
+ h_sp_multiwire.f h_sp_destroy.f \
+ h_select_best_track_prune.f
+fppstuff = h_fill_fpp.f h_fpp_drift.f h_fpp.f \
+ h_fpp_fit.f h_fpp_statistics.f \
+ h_fpp_tracking.f h_init_fpp.f \
+ h_trans_fpp.f h_trans_fpp_hms.f mt19937.f h_fpp_geometry.f
+makeregstuff = r_hms_filenames.f r_hms_scin_parms.f r_hms_scin_tof.f \
+ r_hms_calorimeter.f r_hms_id_histid.f r_hms_tracking.f \
+ r_hms_geometry.f r_hms_track_histid.f r_hms_recon_elements.f \
+ r_hms_physics_sing.f r_hms_bypass_switches.f r_hms_statistics.f \
+ r_hms_pedestals.f r_hms_cer_parms.f r_hms_aero_parms.f \
+ r_hms_fpp_params.f
+
+
+sources = $(osources) $(newstuff) $(newerstuff) $(fppstuff) $(makeregstuff)
+
+ifeq ($(MYOS),AIX)
+xsources := $(filter-out h_link_stubs.f h_track_tests.f ,$(sources))
+sources = h_link_stubs_aix.f h_track_tests_aix.f $(xsources)
+../h_%_aix.f : ../h_%.f
+ sed -e "s/access=.append./position='append'/"< $< > $@
+endif
+
+libsources = $(sources)
+
+lib_targets := $(patsubst %.f, libhtracking.a(%.o), $(libsources))
+install-dirs := lib
+bin_targets =
+
+#default:
+# @echo "nothing to make"
+
+ifdef NFSDIRECTORY
+../%.f : $(NFSDIRECTORY)/HTRACKING/%.f
+ ln -s $< $@
+
+.PRECIOUS: ../%.f
+else
+#
+# Rule for making the register subroutines
+#
+../r_%.f : ../%.cmn $(MAKEREG)
+ (cd .. ; $(MAKEREG) $(<F) -o $(@F) -e /dev/null)
+
+.PRECIOUS: ../r_%.f
+endif
+
+#
+# Get include files from INCLUDE directory
+#
+
+%.cmn ../%.cmn:: ../../INCLUDE/%.cmn
+ $(CP) $< $@
+
+%.dec ../%.dec:: ../../INCLUDE/%.dec
+ $(CP) $< $@
+
+%.par ../%.par:: ../../INCLUDE/%.par
+ $(CP) $< $@
+
+%.dte ../%.dte:: ../../INCLUDE/%.dte
+ $(CP) $< $@
+
+include $(sources:.f=.d)
diff --git a/HTRACKING/h_aero.f b/HTRACKING/h_aero.f
new file mode 100644
index 0000000..754c48f
--- /dev/null
+++ b/HTRACKING/h_aero.f
@@ -0,0 +1,212 @@
+ SUBROUTINE H_AERO(ABORT,err)
+*-
+* $Log: h_aero.f,v $
+* Revision 1.4.14.1.2.1 2008/10/08 17:23:14 cdaq
+* updated for F1 TDC
+*
+* Revision 1.4.14.1 2007/09/10 20:28:00 pcarter
+* Implemented changes to allow compilation on RHEL 3,4,5 and MacOSX
+*
+* Revision 1.4 2004/02/27 14:35:20 jones
+* Summed npe is incremented for all pmts regardless of whether they are
+* above or below the pedestal. Summing only pmts above the pedestal results
+* in an incorrect Summed npe for low beta particles. Consult the Fpi-2
+* calibration notes for details. ( G. Huber)
+*
+* Revision 1.3 2004/02/02 19:23:55 jones
+* 1) When filling haero_adc_pos_hits,haero_tot_good_hits,haero_adc_neg_hits
+* changed cut on npe from 0.1 to 0.3 .
+* 2) When filling haero_npe_sum changed cut on npe_sum from 0.1 to 0.5
+*
+* Revision 1.2 2003/09/05 16:48:01 jones
+* Merge in online03 changes (mkj)
+*
+* Revision 1.1.2.5 2003/07/28 18:01:38 cdaq
+* Use haero_new_ped_pos and haero_new_ped_neg instead of aero_new_threshold_neg
+* and haero_new_threshold_pos in IF statement (mkj)
+*
+* Revision 1.1.2.4 2003/07/18 18:22:49 cdaq
+* Fix bug that haero_adc_neg was compared to instead
+* of haero_new_threshold_neg (Vardan)
+*
+* Revision 1.1.2.3 2003/04/15 21:47:35 cdaq
+* Changed ind to ihit for better readability
+* add checks on haero_npe_sum (MKJ)
+*
+* Revision 1.1.2.2 2003/04/09 02:46:11 cdaq
+* Update variable names for the thresholds to match the modified common block
+*
+* Revision 1.1.2.1 2003/04/06 06:20:40 cdaq
+* updated variables for haero, cleaned up a few of the tests
+*
+* Revision 1.1 2002/12/20 21:54:29 jones
+* New files by Hamlet for new HMS aerogel
+*
+*
+* Revision 1.1 2002/10/21 (Hamlet)
+* Initial revision
+*
+*--------------------------------------------------------
+ IMPLICIT NONE
+ SAVE
+*
+ character*8 here
+ parameter (here= 'H_AERO')
+*
+ logical ABORT
+ character*(*) err
+*
+
+ integer*4 ihit,npmt,rawtime,corrtime
+*
+ INCLUDE 'hms_data_structures.cmn'
+ INCLUDE 'hms_pedestals.cmn'
+ INCLUDE 'hms_aero_parms.cmn'
+
+
+*
+*--------------------------------------------------------
+*
+
+c print*,'h_aero: haero_pos_gain =',haero_pos_gain
+c print*,'h_aero: haero_neg_gain =',haero_neg_gain
+c pause
+
+ ABORT= .FALSE.
+ err= ' '
+
+ haero_neg_npe_sum = 0.0
+ haero_pos_npe_sum = 0.0
+ haero_npe_sum = 0.0
+
+*** aero_pos = 0.0 !not in use any more
+*** aero_neg = 0.0 !not in use any more
+*** aero_tot = 0.0 !not in use any more
+
+ haero_tot_good_hits = 0
+ haero_adc_pos_hits = 0
+ haero_adc_neg_hits = 0
+ haero_tdc_pos_hits = 0
+ haero_tdc_neg_hits = 0
+
+ do ihit = 1,hmax_aero_hits
+
+ haero_pos_npe(ihit)=0.
+ haero_neg_npe(ihit)=0.
+
+ enddo
+
+
+
+
+! Correct for trigger time.
+! If NOT using F1 TDC's, comment this section out
+ do ihit = 1,haero_tot_hits
+ npmt=haero_pair_num(ihit)
+ rawtime = haero_tdc_pos(npmt)
+ if(rawtime.ge.0) then
+ call CORRECT_RAW_TIME_HMS(rawtime,corrtime)
+ haero_tdc_pos(npmt) = corrtime
+ endif
+ rawtime = haero_tdc_neg(npmt)
+ if(rawtime.ge.0) then
+ call CORRECT_RAW_TIME_HMS(rawtime,corrtime)
+ haero_tdc_neg(npmt) = corrtime
+ endif
+ enddo
+
+ do ihit = 1,haero_tot_hits
+
+* pedestal subtraction and gain adjustment
+
+* An ADC value of less than zero occurs when that particular
+* channel has been sparsified away and has not been read.
+* The NPE for that tube will be assigned zero by this code.
+* An ADC value of greater than 8192 occurs when the ADC overflows on
+* an input that is too large. Tubes with this characteristic will
+* be assigned NPE = 100.0.
+
+ npmt=haero_pair_num(ihit)
+
+ if (haero_adc_pos(ihit).lt.8000.) then
+ haero_pos_npe(npmt) = haero_pos_gain(npmt) *
+ & (haero_adc_pos(ihit)-haero_pos_ped_mean(npmt))
+ else
+ haero_pos_npe(npmt) = 100.
+ endif
+
+ if (haero_adc_neg(ihit).lt.8000.) then
+ haero_neg_npe(npmt) = haero_neg_gain(npmt) *
+ & (haero_adc_neg(ihit)-haero_neg_ped_mean(npmt))
+ else
+ haero_neg_npe(npmt) = 100.
+ endif
+c
+ haero_pos_npe_sum = haero_pos_npe_sum + haero_pos_npe(npmt)
+ haero_neg_npe_sum = haero_neg_npe_sum + haero_neg_npe(npmt)
+
+*
+
+
+
+*
+* sum positive and negative hits
+* To fill haero_tot_good_hits
+
+ if (haero_pos_npe(npmt).ge.0.3) then
+ haero_adc_pos_hits = haero_adc_pos_hits + 1
+ haero_tot_good_hits = haero_tot_good_hits + 1
+ endif
+
+ if (haero_neg_npe(npmt).ge.0.3) then
+ haero_adc_neg_hits = haero_adc_neg_hits + 1
+ haero_tot_good_hits = haero_tot_good_hits + 1
+ endif
+
+ if (haero_tdc_pos(npmt).ge.0.and.haero_tdc_pos(npmt).le.8000.)
+ & haero_tdc_pos_hits = haero_tdc_pos_hits + 1
+
+ if (haero_tdc_neg(npmt).ge.0.and.haero_tdc_neg(npmt).le.8000.)
+ & haero_tdc_neg_hits = haero_tdc_neg_hits + 1
+
+ enddo
+
+ if (haero_neg_npe_sum.ge.0.5.or.haero_pos_npe_sum.ge.0.5) then
+ haero_npe_sum = haero_neg_npe_sum + haero_pos_npe_sum
+ else
+ haero_npe_sum = 0.0
+ endif
+
+* If the total hits are 0, then give a noticable ridiculous NPE.
+
+ if (haero_tot_hits.lt.1) then
+
+ haero_npe_sum=0.0
+ endif
+
+
+
+* Next, fill the rawadc variables with the actual tube values
+* mainly for diagnostic purposes.
+
+ do ihit=1,haero_tot_hits
+
+ npmt=haero_pair_num(ihit)
+
+ haero_rawadc_pos(npmt)=haero_adc_pos(ihit)
+ aero_ep(npmt)=haero_rawadc_pos(ihit)
+
+ haero_rawadc_neg(npmt)=haero_adc_neg(ihit)
+ aero_en(npmt)=haero_rawadc_neg(ihit)
+
+ haero_rawtdc_neg(npmt)=haero_tdc_neg(ihit)
+ aero_tn(npmt)= haero_tdc_neg(ihit)
+
+ haero_rawtdc_pos(npmt)=haero_tdc_pos(ihit)
+ aero_tp(npmt)= haero_tdc_pos(ihit)
+
+ enddo
+
+ return
+ end
+
diff --git a/HTRACKING/h_analyze_pedestal.f b/HTRACKING/h_analyze_pedestal.f
new file mode 100644
index 0000000..b9e4170
--- /dev/null
+++ b/HTRACKING/h_analyze_pedestal.f
@@ -0,0 +1,190 @@
+ subroutine h_analyze_pedestal(ABORT,err)
+*
+* $Log: h_analyze_pedestal.f,v $
+* Revision 1.9 2002/12/20 21:53:34 jones
+* Modified by Hamlet for new HMS aerogel
+*
+* Revision 1.9 2002/09/24
+* (Hamlet) Add pedestals for HMS Aerogel
+*
+* Revision 1.8 1999/06/10 16:46:06 csa
+* (JRA) Removed two calorimeter debugging statements
+*
+* Revision 1.7 1999/02/23 18:33:31 csa
+* (JRA) Implement improved pedestal calcs
+*
+* Revision 1.6 1998/12/17 22:02:37 saw
+* Support extra set of tubes on HMS shower counter
+*
+* Revision 1.5 1996/01/24 15:55:06 saw
+* (JRA) Add ped analysis for misc channels
+*
+* Revision 1.4 1995/10/09 20:07:35 cdaq
+* (JRA) Use hcer_raw_adc instead of hcer_adc
+*
+* Revision 1.3 1995/05/22 19:37:05 cdaq
+* (SAW) Split gen_data_data_structures into gen, hms, sos, and coin parts"
+*
+* Revision 1.2 1995/05/17 13:56:04 cdaq
+* (JRA) Add Cernekov pedestals, cosmetic changes
+*
+* Revision 1.1 1995/04/01 19:36:40 cdaq
+* Initial revision
+*
+*
+ implicit none
+ save
+*
+ character*18 here
+ parameter (here='h_analyze_pedestal')
+*
+ logical ABORT
+ character*(*) err
+*
+ integer*4 ihit
+ integer*4 pln,cnt
+ integer*4 row,col
+ integer*4 blk
+ integer*4 pmt
+ integer*4 ind
+*
+ INCLUDE 'hms_data_structures.cmn'
+ INCLUDE 'hms_pedestals.cmn'
+ INCLUDE 'hms_scin_parms.cmn'
+*
+*
+* HODOSCOPE PEDESTALS
+*
+* Update ped limits after have enough events (h*_min_peds/5)
+*
+ do ihit = 1 , hscin_all_tot_hits
+ pln = hscin_all_plane_num(ihit)
+ cnt = hscin_all_counter_num(ihit)
+ if (hscin_all_adc_pos(ihit).le.hhodo_pos_ped_limit(pln,cnt)) then
+ hhodo_pos_ped_sum2(pln,cnt) = hhodo_pos_ped_sum2(pln,cnt) +
+ & hscin_all_adc_pos(ihit)*hscin_all_adc_pos(ihit)
+ hhodo_pos_ped_sum(pln,cnt) = hhodo_pos_ped_sum(pln,cnt) +
+ & hscin_all_adc_pos(ihit)
+ hhodo_pos_ped_num(pln,cnt) = hhodo_pos_ped_num(pln,cnt) + 1
+ if (hhodo_pos_ped_num(pln,cnt).eq.nint(hhodo_min_peds/5.)) then
+ hhodo_pos_ped_limit(pln,cnt) = 100 +
+ & hhodo_pos_ped_sum(pln,cnt) / hhodo_pos_ped_num(pln,cnt)
+ endif
+ endif
+ if (hscin_all_adc_neg(ihit).le.hhodo_neg_ped_limit(pln,cnt)) then
+ hhodo_neg_ped_sum2(pln,cnt) = hhodo_neg_ped_sum2(pln,cnt) +
+ & hscin_all_adc_neg(ihit)*hscin_all_adc_neg(ihit)
+ hhodo_neg_ped_sum(pln,cnt) = hhodo_neg_ped_sum(pln,cnt) +
+ & hscin_all_adc_neg(ihit)
+ hhodo_neg_ped_num(pln,cnt) = hhodo_neg_ped_num(pln,cnt) + 1
+ if (hhodo_neg_ped_num(pln,cnt).eq.nint(hhodo_min_peds/5.)) then
+ hhodo_neg_ped_limit(pln,cnt) = 100 +
+ & hhodo_neg_ped_sum(pln,cnt) / hhodo_neg_ped_num(pln,cnt)
+ endif
+ endif
+
+* fill pedestal histograms.
+c histval = hscin_all_adc_pos(ihit)-hscin_all_ped_pos(pln,cnt)
+c call hf1(hidsumposadc(pln),histval,1.)
+c histval = hscin_all_adc_neg(ihit)-hscin_all_ped_neg(pln,cnt)
+c call hf1(hidsumnegadc(pln),histval,1.)
+
+ enddo
+*
+*
+* CALORIMETER PEDESTALS
+*
+
+ do ihit = 1 , hcal_tot_hits
+ row = hcal_row(ihit)
+ col = hcal_column(ihit)
+ blk = row + (col-1)*hmax_cal_rows
+
+ if (hcal_adc_pos(ihit) .le. hcal_pos_ped_limit(blk)) then
+ hcal_pos_ped_sum2(blk) = hcal_pos_ped_sum2(blk) +
+ & hcal_adc_pos(ihit)*hcal_adc_pos(ihit)
+ hcal_pos_ped_sum(blk) = hcal_pos_ped_sum(blk) + hcal_adc_pos(ihit)
+ hcal_pos_ped_num(blk) = hcal_pos_ped_num(blk) + 1
+ if (hcal_pos_ped_num(blk).eq.nint(hcal_min_peds/5.)) then
+ hcal_pos_ped_limit(blk) = 100 +
+ & hcal_pos_ped_sum(blk) / hcal_pos_ped_num(blk)
+ endif
+ endif
+
+ if (hcal_adc_neg(ihit) .le. hcal_neg_ped_limit(blk)) then
+ hcal_neg_ped_sum2(blk) = hcal_neg_ped_sum2(blk) +
+ & hcal_adc_neg(ihit)*hcal_adc_neg(ihit)
+ hcal_neg_ped_sum(blk) = hcal_neg_ped_sum(blk) + hcal_adc_neg(ihit)
+ hcal_neg_ped_num(blk) = hcal_neg_ped_num(blk) + 1
+ if (hcal_neg_ped_num(blk).eq.nint(hcal_min_peds/5.)) then
+ hcal_neg_ped_limit(blk) = 100 +
+ & hcal_neg_ped_sum(blk) / hcal_neg_ped_num(blk)
+ endif
+ endif
+ enddo
+*
+*
+* CERENKOV PEDESTALS
+*
+ do ihit = 1 , hcer_tot_hits
+ pmt=hcer_tube_num(ihit) ! no sparsification yet - NEED TO FIX!!!!
+ if (hcer_raw_adc(ihit) .le. hcer_ped_limit(pmt)) then
+ hcer_ped_sum2(pmt) = hcer_ped_sum2(pmt) +
+ $ hcer_raw_adc(ihit)*hcer_raw_adc(ihit)
+ hcer_ped_sum(pmt) = hcer_ped_sum(pmt) + hcer_raw_adc(ihit)
+ hcer_ped_num(pmt) = hcer_ped_num(pmt) + 1
+ if (hcer_ped_num(pmt).eq.nint(hcer_min_peds/5.)) then
+ hcer_ped_limit(pmt) = 100 +
+ & hcer_ped_sum(pmt) / hcer_ped_num(pmt)
+ endif
+ endif
+ enddo
+*
+*.............................................................................
+*
+* AEROGEL CERENKOV PEDESTALS
+*
+ do ihit = 1 , haero_tot_hits
+ blk = haero_pair_num(ihit)
+ if (haero_adc_pos(ihit) .le. haero_pos_ped_limit(blk)) then
+ haero_pos_ped_sum2(blk) = haero_pos_ped_sum2(blk) + haero_adc_pos(ihit)*haero_adc_pos(ihit)
+ haero_pos_ped_sum(blk) = haero_pos_ped_sum(blk) + haero_adc_pos(ihit)
+ haero_pos_ped_num(blk) = haero_pos_ped_num(blk) + 1
+ if (haero_pos_ped_num(blk).eq.nint(haero_min_peds/5.)) then
+ haero_pos_ped_limit(blk) = 100 +
+ & haero_pos_ped_sum(blk) / haero_pos_ped_num(blk)
+ endif
+ endif
+ if (haero_adc_neg(ihit) .le. haero_neg_ped_limit(blk)) then
+ haero_neg_ped_sum2(blk) = haero_neg_ped_sum2(blk) + haero_adc_neg(ihit)*haero_adc_neg(ihit)
+ haero_neg_ped_sum(blk) = haero_neg_ped_sum(blk) + haero_adc_neg(ihit)
+ haero_neg_ped_num(blk) = haero_neg_ped_num(blk) + 1
+ if (haero_neg_ped_num(blk).eq.nint(haero_min_peds/5.)) then
+ haero_neg_ped_limit(blk) = 100 +
+ & haero_neg_ped_sum(blk) / haero_neg_ped_num(blk)
+ endif
+ endif
+ enddo
+*
+*............................................................................
+*
+* MISC PEDESTALS
+*
+ do ihit = 1 , hmisc_tot_hits
+ if (hmisc_raw_addr1(ihit).eq.2) then !ADCs
+ ind=hmisc_raw_addr2(ihit) ! no sparsification yet - NEED TO FIX!!!!
+ if (hmisc_raw_data(ihit) .le. hmisc_ped_limit(ind)) then
+ hmisc_ped_sum2(ind) = hmisc_ped_sum2(ind) +
+ $ hmisc_raw_data(ihit)*hmisc_raw_data(ihit)
+ hmisc_ped_sum(ind) = hmisc_ped_sum(ind) + hmisc_raw_data(ihit)
+ hmisc_ped_num(ind) = hmisc_ped_num(ind) + 1
+ if (hmisc_ped_num(ind).eq.nint(hmisc_min_peds/5.)) then
+ hmisc_ped_limit(ind) = 100 +
+ & hmisc_ped_sum(ind) / hmisc_ped_num(ind)
+ endif
+ endif
+ endif
+ enddo
+
+ return
+ end
diff --git a/HTRACKING/h_cal.f b/HTRACKING/h_cal.f
new file mode 100644
index 0000000..045e704
--- /dev/null
+++ b/HTRACKING/h_cal.f
@@ -0,0 +1,155 @@
+*=======================================================================
+ subroutine h_cal(abort,errmsg)
+*=======================================================================
+*-
+*- Purpose: Computes the calorimeter particle ID quantities.
+*- Corrects the energy depositions for impact point
+*- coordinate dependence.
+*-
+*- Input Bank: HMS_TRACKS_CAL
+*-
+*- Output Bank: HMS_TRACK_TESTS
+*-
+*- Output: ABORT - success or failure
+*- : err - reason for failure, if any
+*-
+*- Created: 15 Mar 1994 Tsolak A. Amatuni
+*
+* $Log: h_cal.f,v $
+* Revision 1.11 2003/04/03 00:43:13 jones
+* Update to calibration (V. Tadevosyan0
+*
+* Revision 1.10 2002/09/26 14:31:56 jones
+* the energy determination for planes A and B can use
+* both pos and neg PMT depending on setting of hcal_num_neg_columns.
+*
+* Revision 1.9 1999/06/10 16:46:58 csa
+* (JRA) Cosmetic changes
+*
+* Revision 1.8 1999/02/25 20:10:48 saw
+* Vardan Tadevosyan shower code updates
+*
+* Revision 1.7 1999/02/03 21:13:22 saw
+* Code for new Shower counter tubes
+*
+* Revision 1.6 1999/01/21 21:40:13 saw
+* Extra shower counter tube modifications
+*
+* Revision 1.5 1998/12/17 22:02:38 saw
+* Support extra set of tubes on HMS shower counter
+*
+* Revision 1.4 1995/05/22 19:39:04 cdaq
+* (SAW) Split gen_data_data_structures into gen, hms, sos, and coin parts"
+*
+* Revision 1.3 1994/09/13 19:39:14 cdaq
+* (JRA) Add preshower energy
+*
+* Revision 1.2 1994/04/12 21:24:55 cdaq
+* (DFG) Put in real code and change name of print routine.
+*
+* Revision 1.1 1994/02/19 06:12:35 cdaq
+* Initial revision
+*
+*--------------------------------------------------------
+ implicit none
+ save
+
+ logical abort
+ character*(*) errmsg
+
+ character*5 here
+ parameter (here='H_CAL')
+
+ integer*4 nt !Detector track number
+ integer*4 nc !Calorimeter cluster number
+ real*4 cor !Correction factor for X,Y dependenc. ! Single PMT
+ real*4 cor_pos !Correction factor for X,Y dependenc. ! Single "POS_PMT"
+ real*4 cor_neg !Correction factor for X,Y dependenc. ! Single "NEG_PMT"
+ real*4 h_correct_cal !External function to compute "cor".
+ real*4 h_correct_cal_pos !External function to compute "cor_pos".
+ real*4 h_correct_cal_neg !External function to compute "cor_neg"
+
+ include 'hms_data_structures.cmn'
+ include 'hms_calorimeter.cmn'
+*
+*--------------------------------------------------------
+*
+ do nt=1,hntracks_fp
+ htrack_e1_pos(nt)=0. ! Only pos_pmt for layer "A"
+ htrack_e1_neg(nt)=0. ! Only_neg_pmt for layer "A"
+ htrack_e2_pos(nt)=0. ! Only_pos_pmt for layer "B"
+ htrack_e2_neg(nt)=0. ! Only_neg_pmt for layer "B"
+ htrack_e1(nt)=0.
+ htrack_e2(nt)=0.
+ htrack_e3(nt)=0.
+ htrack_e4(nt)=0.
+ htrack_et(nt)=0.
+ htrack_preshower_e(nt)=0.
+ enddo
+
+ call h_clusters_cal(abort,errmsg)
+ if(abort) then
+ call g_add_path(here,errmsg)
+ return
+ endif
+
+ call h_tracks_cal(abort,errmsg)
+ if(abort) then
+ call g_add_path(here,errmsg)
+ return
+ endif
+*
+* Return if there are no tracks found or none of the found
+* tracks matches a cluster in the calorimeter.
+*
+ if(hntracks_fp .le.0) go to 100 !Return
+ if(hntracks_cal.le.0) go to 100 !Return
+
+ do nt =1,hntracks_fp
+
+ nc=hcluster_track(nt)
+
+ if(nc.gt.0) then
+ cor =h_correct_cal(htrack_xc(nt),htrack_yc(nt)) ! For single "pmt"
+ cor_pos=h_correct_cal_pos(htrack_xc(nt),htrack_yc(nt)) ! For single "pos_pmt"
+ cor_neg=h_correct_cal_neg(htrack_xc(nt),htrack_yc(nt)) ! For single "neg_pmt"
+
+ hnblocks_cal(nt)=hcluster_size(nc)
+*
+ if(hcal_num_neg_columns.ge.1) then
+ htrack_e1_pos(nt)=cor_pos*hcluster_e1_pos(nc) ! For "A" layer "POS_PMT"
+ htrack_e1_neg(nt)=cor_neg*hcluster_e1_neg(nc) ! For "A" layer "NEG_PMT"
+ htrack_e1(nt)=htrack_e1_pos(nt)+htrack_e1_neg(nt) ! For "A" layer "POS"+"NEG_PMT"
+ else
+ htrack_e1(nt)=cor_pos*hcluster_e1(nc) ! IF ONLY "POS_PMT" in layer "A"
+ endif
+
+ if(hcal_num_neg_columns.ge.2) then
+ htrack_e2_pos(nt)=cor_pos*hcluster_e2_pos(nc) ! For "B" layer "POS_PMT"
+ htrack_e2_neg(nt)=cor_neg*hcluster_e2_neg(nc) ! For "B" layer "NEG_PMT"
+ htrack_e2(nt)=htrack_e2_pos(nt)+htrack_e2_neg(nt) ! For "B" layer "POS"+"NEG_PMT"
+ else
+ htrack_e2(nt)=cor_pos*hcluster_e2(nc) ! IF ONLY "POS_PMT" in layer "B"
+ endif
+
+ if(hcal_num_neg_columns.ge.3) then
+ print *,"Extra tubes on more than two layers not supported"
+ endif
+
+ htrack_e3(nt)=cor*hcluster_e3(nc)
+ htrack_e4(nt)=cor*hcluster_e4(nc)
+
+ htrack_et(nt)=htrack_e1(nt)+htrack_e2(nt)+ htrack_e3(nt)
+ & +htrack_e4(nt)
+
+ htrack_preshower_e(nt)=htrack_e1(nt)
+
+ endif !End ... if nc > 0
+
+ enddo !End loop over detector tracks
+
+ 100 continue
+ if(hdbg_tests_cal.gt.0) call h_prt_cal_tests
+
+ return
+ end
diff --git a/HTRACKING/h_cal_calib.f b/HTRACKING/h_cal_calib.f
new file mode 100644
index 0000000..61f9a38
--- /dev/null
+++ b/HTRACKING/h_cal_calib.f
@@ -0,0 +1,628 @@
+*=======================================================================
+ subroutine h_cal_calib(mode)
+*=======================================================================
+
+c HMS calorimeter calibration with electrons.
+c
+c Input paramater mode = 0 means collect data for calibration,
+c otherwise calibrate.
+
+*
+ implicit none
+*
+ integer mode
+
+ include 'hms_data_structures.cmn'
+ include 'hms_calorimeter.cmn'
+ include 'hms_tracking.cmn'
+ include 'gen_run_info.cmn'
+ include 'gen_event_info.cmn'
+*
+ integer ihit
+ integer nblk
+ real adc_pos,adc_neg
+
+ integer nct_hit_blk(78),ipmt
+ logical write_out
+c
+ common/hcal_calib/nct_hit_blk,ncall,spare_id
+ integer ncall
+ data ncall/0/
+
+ real thr_lo,thr_hi !thresholds on sammed raw calorimeter signal.
+c
+ integer spare_id
+ logical ABORT
+ character*80 err
+c
+ ncall=ncall+1
+
+ if (ncall .eq. 1) then
+ call g_IO_control(spare_id,'ANY',ABORT,err) !get IO channel
+ open(spare_id,file='h_cal_calib.raw_data')
+ do ipmt=1,78
+ nct_hit_blk(ipmt)=0
+ enddo
+ endif
+
+c print*,'hntracks_fp =',hntracks_fp
+c print*,'hnclusters_cal =',hnclusters_cal
+c print*,'hntracks_cal =',hntracks_cal
+c print*,'hdelta_tar =',hdelta_tar
+c print*,'hcer_npe_sum =',hcer_npe_sum
+c print*,'hbeta =',hbeta
+c print*,'spare_id =',spare_id
+c pause
+
+ if(mode.eq.0) then !collect data.
+
+c Choose clean single electron tracks within HMS momentum acceptance.
+ if( (hntracks_fp.eq.1).and.
+ & (hnclusters_cal.eq.1).and.
+ & (hntracks_cal.eq.1).and.
+ & (abs(hdelta_tar(1)).lt.10.).and.
+ & (hcer_npe_sum.gt.4).and.
+ & (abs(hbeta(1)-1.).lt.0.1).and.
+ & spare_id .ne. 0 ) then
+*** & (hbeta_chisq(1).ge.0.).and.(hbeta_chisq(1).lt.1.) ) then
+
+c
+ write_out = .false.
+ do ihit=1,hcal_num_hits
+ nblk=(hcal_cols(ihit)-1)*hmax_cal_rows+hcal_rows(ihit)
+ nct_hit_blk(nblk) = nct_hit_blk(nblk) + 1
+ if (nct_hit_blk(nblk) .lt. 4000) write_out = .true.
+ enddo
+c
+ if (write_out) then
+c
+ write(spare_id,'(i2,1x,f7.4,2(1x,f5.1,1x,f9.6))')
+ & hcal_num_hits,hp_tar(1),
+ & htrack_xc(1),hxp_fp(1),htrack_yc(1),hyp_fp(1)
+
+ do ihit=1,hcal_num_hits
+
+ if(hcal_cols(ihit).le.hcal_num_neg_columns) then
+ adc_neg=hcal_adcs_neg(ihit)
+ else
+ adc_neg=0.
+ end if
+ adc_pos=hcal_adcs_pos(ihit)
+ nblk=(hcal_cols(ihit)-1)*hmax_cal_rows+hcal_rows(ihit)
+
+ write(spare_id,'(2(f9.3,1x),i2)'),
+ & adc_pos,adc_neg,nblk
+
+ end do
+
+ endif ! if write_out
+c
+ end if !electron in acceptance
+
+ else !mode<>0, calibrate.
+
+ close(spare_id)
+
+ print*,'=========================================================='
+ print*,'Calibrating HMS Calorimeter at event #',gen_event_id_number
+
+ call hcal_raw_thr(spare_id,thr_lo,thr_hi)
+ print*,'lo & hi thresholds:', thr_lo,thr_hi
+ call hcal_clb_det(spare_id,gen_run_number,thr_lo,thr_hi)
+
+ print*,'=========================================================='
+
+ end if !mode=0
+
+ end
+*=======================================================================
+ subroutine hcal_raw_thr(lun,thr_lo,thr_hi)
+
+ implicit none
+ integer lun
+ real thr_lo,thr_hi
+
+c Get thresholds around electron peak in summed raw calorimeter signal.
+
+ integer*4 num_negs
+ parameter (num_negs=26) !hms
+ integer*4 nhit
+ real*4 adc_pos,adc_neg
+ integer*4 nh
+ integer*4 nb
+ real*8 eb
+c
+ integer*4 nrow
+ parameter (nrow=13) !hms
+ real*4 zbl
+ parameter (zbl=10.)
+ real*4 x,xp,y,yp
+ real*4 xh,yh
+ integer*4 nc
+ real*4 sig,avr,t
+ real*4 qdc
+ integer nev
+
+ real h_correct_cal_neg, h_correct_cal_pos, h_correct_cal
+
+*
+* Get thresholds on total_signal/p_tar.
+*
+ open(lun,file='h_cal_calib.raw_data',err=989)
+ avr=0.
+ sig=0.
+ nev=0
+ do while(.true.)
+ read(lun,*,end=3) nhit,eb,x,xp,y,yp
+ qdc=0.
+ do nh=1,nhit
+ read(lun,*,end=3) adc_pos,adc_neg,nb
+ nc=(nb-1)/nrow+1
+ xh=x+xp*(nc-0.5)*zbl
+ yh=y+yp*(nc-0.5)*zbl
+ if(nb.le.num_negs) then
+ qdc=qdc+adc_pos*h_correct_cal_pos(xh,yh)*0.5
+ qdc=qdc+adc_neg*h_correct_cal_neg(xh,yh)*0.5
+ else
+ qdc=qdc+adc_pos*h_correct_cal(xh,yh)
+ end if
+ enddo
+ eb=eb*1000.
+ t=qdc/eb
+c write(lun,*) t
+c write(lun,*) t,nhit,eb,x,xp,y,yp,nev
+ avr=avr+t
+ sig=sig+t*t
+ nev=nev+1
+c print*,eb,qdc,nev, avr,sig
+c pause
+ end do
+
+ 3 close(lun)
+ print*,avr,sig,nev
+ avr=avr/nev
+ sig=sqrt(sig/nev-avr*avr)
+ thr_lo=avr-3.*sig
+ thr_hi=avr+3.*sig
+ write(*,*) 'thr_lo=',thr_lo,' thr_hi=',thr_hi
+
+ return
+
+ 989 write(*,*) ' error opening file h_cal_calib.raw_data, channel ',lun,
+ * ' in hcal_raw_thr.f'
+c
+ end
+*=======================================================================
+ subroutine hcal_clb_det(lun,nrun,thr_lo,thr_hi)
+ implicit none
+c
+ include 'hms_data_structures.cmn'
+ include 'hms_calorimeter.cmn'
+c
+ integer lun,nrun
+ real thr_lo,thr_hi
+
+ integer npmts
+ parameter (npmts=78) !hms
+ integer npmts2
+ parameter (npmts2=npmts*npmts)
+ integer nrow
+ parameter (nrow=13) !hms
+ real*8 q0(npmts)
+ real*8 qm(npmts,npmts)
+ real*8 qe(npmts)
+ real*8 q(npmts)
+ real*8 eb
+ real*8 e0
+ real*8 ac(npmts)
+ real*8 au(npmts)
+ real*8 s
+ integer nev
+ logical*1 eod
+ integer i,j
+ integer nf(npmts)
+ integer minf
+ parameter (minf=100) ! minimum number to hit pmt before including pmt in calib
+ integer nums(npmts)
+ integer numsel
+ real*8 q0s(npmts)
+ real*8 qes(npmts)
+ integer nsi,nsj
+ real*8 acs(npmts)
+ real*8 aus(npmts)
+ real*8 aux(npmts2)
+ integer jp
+ integer spare_id
+ logical ABORT
+ character*80 err
+ character*40 fn
+
+ real xh,yh
+
+ open(lun,file='h_cal_calib.raw_data')
+
+ do i=1,npmts
+ q0(i)=0.
+ qe(i)=0.
+ do j=1,npmts
+ qm(i,j)=0.
+ end do
+ au(i)=0.
+ ac(i)=0.
+ nf(i)=0
+ end do
+ e0=0.
+c
+ nev=0
+ eod=.false.
+ do while(.not.eod)
+ call h_get_data(lun,eb,q,xh,yh,eod,thr_lo,thr_hi)
+ if(.not.eod) then
+ do i=1,npmts
+ if(q(i).gt.0.) then
+ q0(i)=q0(i)+q(i)
+ qe(i)=qe(i)+eb*q(i)
+ do j=1,npmts
+ qm(i,j)=qm(i,j)+q(i)*q(j)
+ end do
+ nf(i)=nf(i)+1
+ end if
+ end do
+ e0=e0+eb
+ nev=nev+1
+c if(nev/1000*1000.eq.nev) write(*,'(e10.3,i7)') e0,nev
+ end if
+ end do
+ close(lun)
+
+ do i=1,npmts
+ q0(i)=q0(i)/nev
+ qe(i)=qe(i)/nev
+ do j=1,npmts
+ qm(i,j)=qm(i,j)/nev
+ end do
+ end do
+ e0=e0/nev
+
+ numsel=0
+ do i=1,npmts
+ if(nf(i).ge.minf) then
+ numsel=numsel+1
+ nums(numsel)=i
+c print*,nums(numsel),numsel,nf(i)
+ else
+ write(*,*) ' PMT ',i,' only ',nf(i),' events. Will not to be calibrated. Gain is set to 0.'
+ end if
+ end do
+c print*,'numsel =',numsel
+ write(*,'(''Number of events for each PMT for calib for run '',i7,'', '',
+ 1 i6,'' events processed'')') nrun,nev
+ write(*,*) ' PMT with less than', minf,' events are not included in calibration.'
+ write(*,*)
+ write(*,11) 'hcal_pos_gain_cor=',(nf(i),i= 1, nrow)
+ write(*,11) ' ',(nf(i),i= nrow+1,2*nrow)
+ write(*,11) ' ',(nf(i),i=2*nrow+1,3*nrow)
+ write(*,11) ' ',(nf(i),i=3*nrow+1,4*nrow)
+ write(*,11) 'hcal_neg_gain_cor=',(nf(i),i=4*nrow+1,5*nrow)
+ write(*,11) ' ',(nf(i),i=5*nrow+1,6*nrow)
+ write(*,11) ' ',(0., i=6*nrow+1,7*nrow)
+ write(*,11) ' ',(0., i=7*nrow+1,8*nrow)
+c
+ do i=1,numsel
+ nsi=nums(i)
+ q0s(i)=q0(nsi)
+ qes(i)=qe(nsi)
+ do j=1,numsel
+ nsj=nums(j)
+ jp=j+(i-1)*numsel
+ aux(jp)=qm(nsj,nsi)
+c write(65,'(e12.5)') aux(jp)
+ end do
+ end do
+
+ call calib(e0,q0s,qes,aux,numsel,numsel*numsel,aus,acs)
+
+ do i=1,numsel
+ nsi=nums(i)
+ au(nsi)=aus(i)
+ ac(nsi)=acs(i)
+ end do
+
+c write(*,'(2e10.3,i5)') (ac(i),au(i),i,i=1,npmts)
+
+ write(fn,'(a17,i5.5)') 'PARAM/hcal.param.',nrun
+ call g_IO_control(spare_id,'ANY',ABORT,err) !get IO channel
+ open(spare_id,file=fn)
+
+ write(spare_id,'(''; Calibration constants for run '',i7,'', '',
+ 1 i6,'' events processed'')') nrun,nev
+ write(spare_id,*)
+
+ write(spare_id,10) 'hcal_pos_gain_cor=',(ac(i)*1.D+3,i= 1, nrow)
+ write(spare_id,10) ' ',(ac(i)*1.D+3,i= nrow+1,2*nrow)
+ write(spare_id,10) ' ',(ac(i)*1.D+3,i=2*nrow+1,3*nrow)
+ write(spare_id,10) ' ',(ac(i)*1.D+3,i=3*nrow+1,4*nrow)
+ write(spare_id,10) 'hcal_neg_gain_cor=',(ac(i)*1.D+3,i=4*nrow+1,5*nrow)
+ write(spare_id,10) ' ',(ac(i)*1.D+3,i=5*nrow+1,6*nrow)
+ write(spare_id,10) ' ',(0., i=6*nrow+1,7*nrow)
+ write(spare_id,10) ' ',(0., i=7*nrow+1,8*nrow)
+* write(spare_id,10) 'hcal_pos_gain_cor=',(ac(i)*2.D+3,i= 1, nrow)
+* write(spare_id,10) ' ',(ac(i)*2.D+3,i= nrow+1,2*nrow)
+* write(spare_id,10) ' ',(ac(i)*1.D+3,i=2*nrow+1,3*nrow)
+* write(spare_id,10) ' ',(ac(i)*1.D+3,i=3*nrow+1,4*nrow)
+* write(spare_id,10) 'hcal_neg_gain_cor=',(ac(i)*2.D+3,i=4*nrow+1,5*nrow)
+* write(spare_id,10) ' ',(ac(i)*2.D+3,i=5*nrow+1,6*nrow)
+* write(spare_id,10) ' ',(0., i=6*nrow+1,7*nrow)
+* write(spare_id,10) ' ',(0., i=7*nrow+1,8*nrow)
+
+ close(spare_id)
+ call G_IO_control(spare_ID,'FREE',ABORT,err) !free up IO channel
+
+ write(*,*)
+ write(*,'(''Calibration constants for run '',i7,'', '',
+ 1 i6,'' events processed'')') nrun,nev
+ write(*,*)
+ write(*,*) ' constants written to ',fn
+ write(*,*)
+ write(*,10) 'hcal_pos_gain_cor=',(ac(i)*1.D+3,i= 1, nrow)
+ write(*,10) ' ',(ac(i)*1.D+3,i= nrow+1,2*nrow)
+ write(*,10) ' ',(ac(i)*1.D+3,i=2*nrow+1,3*nrow)
+ write(*,10) ' ',(ac(i)*1.D+3,i=3*nrow+1,4*nrow)
+ write(*,10) 'hcal_neg_gain_cor=',(ac(i)*1.D+3,i=4*nrow+1,5*nrow)
+ write(*,10) ' ',(ac(i)*1.D+3,i=5*nrow+1,6*nrow)
+ write(*,10) ' ',(0., i=6*nrow+1,7*nrow)
+ write(*,10) ' ',(0., i=7*nrow+1,8*nrow)
+
+ 10 format(a18,13(f6.3,','))
+ 11 format(a18,13(i5,','))
+
+ open(lun,file='h_cal_calib.raw_data')
+ call g_IO_control(spare_id,'ANY',ABORT,err) !get IO channel
+ open(spare_id,file='h_cal_calib.cal_data')
+ write(*,*) 'In hms shower cal creating h_cal_calib.cal_data, ',
+ * 'channel ',spare_id
+
+ nev=0
+ eod=.false.
+ do while(.not.eod)
+ call h_get_data(lun,eb,q,xh,yh,eod,0.,1.E+8)
+ if(.not.eod) then
+ s=0.
+* t=0.
+ do i=1,npmts
+ s=s+q(i)*ac(i)
+* t=t+q(i)*au(i)
+ end do
+ write(spare_id,*) s,eb,xh,yh
+ end if
+ end do
+
+ close(lun)
+ close(spare_id)
+ call G_IO_control(spare_ID,'FREE',ABORT,err) !free up IO channel
+
+ end
+*=======================================================================
+ subroutine calib(e0,q0,qe,aux,npmts,npmts2,au,ac)
+ implicit none
+ integer npmts,npmts2
+ real*8 e0
+ real*8 q0(npmts)
+ real*8 qe(npmts)
+ real*8 aux(npmts2)
+ real*8 ac(npmts)
+ real*8 au(npmts)
+ real*8 qm(npmts,npmts)
+c real*8 qm(100,100) !Phil
+ real*8 t
+ real*8 s
+ integer ifail
+ integer i,j
+ integer jp
+
+ do i=1,npmts
+ do j=1,npmts
+ jp=j+(i-1)*npmts
+ qm(j,i)=aux(jp)
+c write(66,'(e12.5)') qm(j,i)
+ end do
+ end do
+
+ print*,'Calib: npmts =',npmts
+ print*,' '
+
+ print*,'Inversing the Matrix...'
+ call smxinv(qm,npmts,ifail)
+ if(ifail.ne.0) then
+ stop '*** Singular Matrix ***'
+ else
+ print*,' ...done.'
+ end if
+
+ do i=1,npmts
+ au(i)=0.
+ do j=1,npmts
+ au(i)=au(i)+qm(i,j)*qe(j)
+ end do
+ end do
+
+ s=0.
+ do i=1,npmts
+ t=0.
+ do j=1,npmts
+ t=t+qm(i,j)*q0(j)
+ end do
+ s=s+q0(i)*t
+ end do
+
+ t=0.
+ do i=1,npmts
+ t=t+au(i)*q0(i)
+ end do
+ s=(e0-t)/s
+
+ do i=1,npmts
+ t=0.
+ do j=1,npmts
+ t=t+qm(i,j)*q0(j)
+ end do
+ ac(i)=s*t+au(i)
+ end do
+
+ end
+*-----------------------------------------------------------------------
+ subroutine h_get_data(lun,eb,q,xh,yh,eod,thr_lo,thr_hi)
+ implicit none
+c
+ integer lun
+ real*8 eb
+ integer*4 num_blocks,num_negs,num_pmts
+ parameter (num_blocks=52,num_negs=26,num_pmts=78) !hms.
+ real*8 q(num_pmts)
+ logical*1 eod
+
+ integer*4 nhit
+ real*4 adc_pos,adc_neg
+ integer*4 nh
+ integer*4 nb
+c
+ integer*4 nrow
+ parameter (nrow=13) !hms
+ real*4 zbl
+ parameter (zbl=10.)
+ real*4 x,xp,y,yp
+ real*4 xh,yh
+ integer*4 nc
+ real*4 h_correct_cal
+ real*4 h_correct_cal_pos,h_correct_cal_neg
+ real*4 thr_lo,thr_hi
+ logical*1 good_ev
+ real*4 qnet
+
+ good_ev=.false.
+ do while(.not.good_ev)
+
+ eb=0.d0
+ do nb=1,num_pmts
+ q(nb)=0.d0
+ end do
+ qnet=0.
+ eod=.true.
+
+ read(lun,*,end=5) nhit,eb,x,xp,y,yp
+ do nh=1,nhit
+ read(lun,*,end=5) adc_pos,adc_neg,nb
+ nc=(nb-1)/nrow+1
+ xh=x+xp*(nc-0.5)*zbl
+ yh=y+yp*(nc-0.5)*zbl
+ if(nb.le.num_negs) then
+ q(nb)=adc_pos*h_correct_cal_pos(xh,yh)
+ q(num_blocks+nb)=adc_neg*h_correct_cal_neg(xh,yh)
+ qnet=qnet+0.5*(q(nb)+q(num_blocks+nb))
+ else
+ q(nb)=adc_pos*h_correct_cal(xh,yh)
+ qnet=qnet+q(nb)
+ end if
+ enddo
+ eod=.false.
+
+ qnet=qnet/(eb*1000.)
+ good_ev=(qnet.gt.thr_lo).and.(qnet.lt.thr_hi)
+
+c write(99,*) qnet
+
+ end do !.not.good_ev
+
+ 5 continue
+
+ end
+*-----------------------------------------------------------------------
+ SUBROUTINE SMXINV (A,NDIM,IFAIL)
+C
+C CERN PROGLIB# F107 SMXINV .VERSION KERNFOR 1.0 720503
+C ORIG. 03/05/72 CL
+C
+ REAL*8 A(*),RI(100)
+ INTEGER*4 INDEX(100)
+C
+ DATA TOL / 1.D-14/
+C
+ IFAIL=0
+ N=NDIM
+ NP1=N+1
+ DO 10 I=1,N
+ 10 INDEX(I)=1
+C
+ DO 80 I=1,N
+C
+C-- FIND PIVOT
+ PIVOT=0.0D0
+ JJ=1
+ DO 20 J=1,N
+ IF (INDEX(J).EQ.0) GO TO 19
+ ELM=DABS (A(JJ))
+ IF (ELM.LE.PIVOT) GO TO 19
+ PIVOT=ELM
+ K=J
+ KK=JJ
+ 19 JJ=JJ+NP1
+ 20 CONTINUE
+ IF (PIVOT/DABS(A(1)).LT.TOL) GO TO 100
+ INDEX(K)=0
+ PIVOT=-A(KK)
+C
+C-- ELIMINATION
+ KJ=K
+ NP=N
+C
+ DO 70 J=1,N
+ IF ((J-K).EQ.0) THEN
+ GOTO 30
+ ELSE
+ GOTO 34
+ END IF
+C
+ 30 A(KJ)=1.0D0/PIVOT
+ RI(J)=0.0D0
+ NP=1
+ GO TO 70
+C
+ 34 ELM=-A(KJ)
+ RI(J)=ELM/PIVOT
+ IF (ELM.EQ.0.0D0) GO TO 50
+C
+ JL=J
+ DO 45 L=1,J
+ A(JL)=A(JL)+ELM*RI(L)
+ 45 JL=JL+N
+C
+ 50 A(KJ)=RI(J)
+C
+ 70 KJ=KJ+NP
+C
+ 80 CONTINUE
+C
+C-- CHANGE THE SIGN AND PROVISIONAL FILL-UP
+ IJ0=1
+ JI0=1
+ DO 95 I=1,N
+ IJ=IJ0
+ JI=JI0
+C
+ DO 90 J=1,I
+ A(IJ)=-A(IJ)
+ A(JI)=A(IJ)
+ IJ=IJ+N
+ JI=JI+1
+ 90 CONTINUE
+C
+ IJ0=IJ0+1
+ JI0=JI0+N
+ 95 CONTINUE
+ RETURN
+C
+C-- FAILURE RETURN
+ 100 IFAIL=1
+ RETURN
+ END
+*=======================================================================
diff --git a/HTRACKING/h_cal_eff.f b/HTRACKING/h_cal_eff.f
new file mode 100644
index 0000000..920b6ba
--- /dev/null
+++ b/HTRACKING/h_cal_eff.f
@@ -0,0 +1,131 @@
+ SUBROUTINE H_CAL_EFF(ABORT,errmsg)
+*--------------------------------------------------------
+*-
+*- Purpose and Methods : Analyze calorimeter statistics for each track
+*-
+*- Required Input BANKS HMS_CALORIMETER
+*- GEN_DATA_STRUCTURES
+*-
+*- Output: ABORT - success or failure
+*- : err - reason for failure, if any
+*-
+* author: John Arrington
+* created: 2/17/95
+*
+* h_cal_eff calculates efficiencies for the hodoscope.
+*
+* $Log: h_cal_eff.f,v $
+* Revision 1.8 2002/10/02 13:42:42 saw
+* Check that user hists are defined before filling
+*
+* Revision 1.7 1999/02/03 21:13:23 saw
+* Code for new Shower counter tubes
+*
+* Revision 1.6 1999/01/29 17:33:56 saw
+* Cosmetic changes
+*
+* Revision 1.5 1998/12/17 22:02:38 saw
+* Support extra set of tubes on HMS shower counter
+*
+* Revision 1.4 1996/08/30 19:52:12 saw
+* (JRA) Require more than one photoelectron
+*
+* Revision 1.3 1995/08/31 14:55:37 cdaq
+* (JRA) Fill dpos (pos. track - pos. hit) histograms
+*
+* Revision 1.2 1995/05/22 19:39:05 cdaq
+* (SAW) Split gen_data_data_structures into gen, hms, sos, and coin parts"
+*
+* Revision 1.1 1995/02/23 13:31:51 cdaq
+* Initial revision
+*
+*--------------------------------------------------------
+ IMPLICIT NONE
+*
+ character*9 here
+ parameter (here= 'H_CAL_EFF')
+*
+ logical ABORT
+ character*(*) errmsg
+*
+ INCLUDE 'hms_data_structures.cmn'
+ INCLUDE 'gen_constants.par'
+ INCLUDE 'gen_units.par'
+ include 'hms_calorimeter.cmn'
+ include 'hms_statistics.cmn'
+ include 'hms_id_histid.cmn'
+
+ integer col,row,blk
+ integer hit_row(hmax_cal_columns)
+ integer nhit
+ real adc_pos, adc_neg
+ real hit_pos(hmax_cal_columns),hit_dist(hmax_cal_columns)
+ real histval
+ save
+
+* find counters on track, and distance from center.
+
+ if (hschi2perdeg.le.hstat_cal_maxchisq .and. hcer_npe_sum.ge.1.)
+ & hstat_cal_numevents=hstat_cal_numevents+1
+
+ hit_pos(1)=hsx_fp + hsxp_fp*(hcal_1pr_zpos+0.5*hcal_1pr_thick)
+ hit_row(1)=nint((hit_pos(1)-hcal_block_xc(1))
+ & /hcal_block_xsize)+1
+ hit_row(1)=max(min(hit_row(1),hmax_cal_rows),1)
+ hit_dist(1)=hit_pos(1)-(hcal_block_xsize*(hit_row(1)-1)
+ & +hcal_block_xc(1))
+
+ hit_pos(2)=hsx_fp + hsxp_fp*(hcal_2ta_zpos+0.5*hcal_2ta_thick)
+ hit_row(2)=nint((hit_pos(2)-hcal_block_xc(hmax_cal_rows+1))
+ & /hcal_block_xsize)+1
+ hit_row(2)=max(min(hit_row(2),hmax_cal_rows),1)
+ hit_dist(2)=hit_pos(2)-(hcal_block_xsize*(hit_row(2)-1)
+ & +hcal_block_xc(hmax_cal_rows+1))
+
+ hit_pos(3)=hsx_fp + hsxp_fp*(hcal_3ta_zpos+0.5*hcal_3ta_thick)
+ hit_row(3)=nint((hit_pos(3)-hcal_block_xc(2*hmax_cal_rows+1))
+ & /hcal_block_xsize)+1
+ hit_row(3)=max(min(hit_row(3),hmax_cal_rows),1)
+ hit_dist(3)=hit_pos(3)-(hcal_block_xsize*(hit_row(3)-1)
+ & +hcal_block_xc(2*hmax_cal_rows+1))
+
+ hit_pos(4)=hsx_fp + hsxp_fp*(hcal_4ta_zpos+0.5*hcal_4ta_thick)
+ hit_row(4)=nint((hit_pos(4)-hcal_block_xc(3*hmax_cal_rows+1))
+ & /hcal_block_xsize)+1
+ hit_row(4)=max(min(hit_row(4),hmax_cal_rows),1)
+ hit_dist(4)=hit_pos(3)-(hcal_block_xsize*(hit_row(4)-1)
+ & +hcal_block_xc(3*hmax_cal_rows+1))
+
+* increment 'should have hit' counters
+ do col=1,hmax_cal_columns
+ if(abs(hit_dist(col)).le.hstat_cal_slop .and. !hit in middle of blk.
+ & hschi2perdeg.le.hstat_cal_maxchisq .and. hcer_npe_sum.ge.1.) then
+ hstat_cal_trk(col,hit_row(col))=hstat_cal_trk(col,hit_row(col))+1
+ endif
+ enddo
+
+ do nhit=1,hcal_num_hits
+ row=hcal_rows(nhit)
+ col=hcal_cols(nhit)
+* We don't actually do anything with the following values?
+ adc_pos=hcal_adcs_pos(nhit) ! Do we want hcal_adc_pos or hcal_adcs_pos
+ adc_neg=hcal_adcs_neg(nhit)
+ blk=row+hmax_cal_rows*(col-1)
+
+* fill the dpos histograms.
+ if (col .eq. 1) then
+ histval=(hcal_block_xc(1)+hcal_block_xsize*(row-1))-hit_pos(1)
+ if(hidcaldpos.gt.0) call hf1(hidcaldpos,histval,1.)
+ endif
+
+* Record the hits if track is near center of block and the chisquared of the
+* track is good
+ if(abs(hit_dist(col)).le.hstat_cal_slop .and. row.eq.hit_row(col)) then
+ if (hschi2perdeg.le.hstat_cal_maxchisq .and. hcer_npe_sum.ge.1.) then
+ hstat_cal_hit(col,hit_row(col))=hstat_cal_hit(col,hit_row(col))+1
+ endif !was it a good track.
+ endif !if hit was on track.
+ enddo
+
+ return
+ end
diff --git a/HTRACKING/h_cal_eff_shutdown.f b/HTRACKING/h_cal_eff_shutdown.f
new file mode 100644
index 0000000..3164657
--- /dev/null
+++ b/HTRACKING/h_cal_eff_shutdown.f
@@ -0,0 +1,76 @@
+ SUBROUTINE H_CAL_EFF_SHUTDOWN(ABORT,errmsg)
+*--------------------------------------------------------
+*-
+*- Purpose and Methods : Summary of calorimeter efficiencies.
+*-
+*- Required Input BANKS HMS_CALORIMETER
+*- GEN_DATA_STRUCTURES
+*-
+*- Output: ABORT - success or failure
+*- : err - reason for failure, if any
+*-
+* author: John Arrington
+* created: 2/17/95
+*
+* h_cal_eff calculates efficiencies for the calorimeter.
+* h_cal_eff_shutdown does some final manipulation of the numbers.
+*
+* $Log: h_cal_eff_shutdown.f,v $
+* Revision 1.5 1999/02/23 18:35:24 csa
+* (JRA) Remove hdebugcalcpeds stuff
+*
+* Revision 1.4 1995/10/09 20:09:37 cdaq
+* (JRA) Add bypass switch around writing of pedestal data
+*
+* Revision 1.3 1995/08/31 14:57:36 cdaq
+* (JRA) Calculate and printout pedestals
+*
+* Revision 1.2 1995/05/22 19:39:05 cdaq
+* (SAW) Split gen_data_data_structures into gen, hms, sos, and coin parts"
+*
+* Revision 1.1 1995/02/23 13:32:00 cdaq
+* Initial revision
+*
+*--------------------------------------------------------
+ IMPLICIT NONE
+*
+ character*18 here
+ parameter (here= 'H_CAL_EFF_SHUTDOWN')
+*
+ logical ABORT
+ character*(*) errmsg
+*
+ INCLUDE 'hms_data_structures.cmn'
+ INCLUDE 'gen_constants.par'
+ INCLUDE 'gen_units.par'
+ include 'hms_calorimeter.cmn'
+ include 'hms_statistics.cmn'
+ include 'hms_tracking.cmn'
+
+ integer col,row,blk
+ real ave,ave2,num
+ save
+
+! fill sums over counters
+ do col=1,hmax_cal_columns
+ hstat_cal_trksum(col)=0
+ hstat_cal_hitsum(col)=0
+ do row=1,hmax_cal_rows
+ hstat_cal_eff(col,row)=hstat_cal_hit(col,row)/max(.01,float(hstat_cal_trk(col,row)))
+ hstat_cal_trksum(col)=hstat_cal_trksum(col)+hstat_cal_trk(col,row)
+ hstat_cal_hitsum(col)=hstat_cal_hitsum(col)+hstat_cal_hit(col,row)
+ enddo
+ hstat_cal_effsum(col)=hstat_cal_hitsum(col)/max(.01,float(hstat_cal_trksum(col)))
+ enddo
+
+ do blk=1,hmax_cal_blocks
+ num=float(max(1,hcal_zero_num(blk)))
+ ave=float(hcal_zero_sum(blk))/num
+ ave2=float(hcal_zero_sum2(blk))/num
+ hcal_zero_ave(blk)=ave
+ hcal_zero_sig(blk)=sqrt(max(0.,ave2-ave*ave))
+ hcal_zero_thresh(blk)=min(50.,max(20.,3*hcal_zero_sig(blk)))
+ enddo
+
+ return
+ end
diff --git a/HTRACKING/h_calc_pedestal.f b/HTRACKING/h_calc_pedestal.f
new file mode 100644
index 0000000..2f271b9
--- /dev/null
+++ b/HTRACKING/h_calc_pedestal.f
@@ -0,0 +1,411 @@
+ subroutine h_calc_pedestal(ABORT,err)
+*
+* $Log: h_calc_pedestal.f,v $
+* Revision 1.14 2003/09/05 16:56:59 jones
+* Merge in online03 changes (mkj)
+*
+* Revision 1.13.2.6 2003/07/28 17:59:01 cdaq
+* Force h_aero_new_threshold_neg and pos to be 400. (mkj)
+*
+* Revision 1.13.2.5 2003/07/18 18:24:49 cdaq
+* Eliminate forced setting of haero_new_threshold_pos(pmt) = 400. and
+* use haero_new_ped_pos(pmt)+15. (Vardan)
+*
+* Revision 1.13.2.4 2003/04/16 12:10:27 cdaq
+* Modified max(1.,haero_pos_ped_num(pmt)) to max(1.,float(haero_pos_ped_num(pmt)))
+* and same for haero_neg_ped_num to compile on the Alpha machine (EB)
+*
+* Revision 1.13.2.3 2003/04/09 16:56:40 cdaq
+* Modified to force haero_new_threshold_neg = 400 and pos = 400 (MKJ)
+*
+* Revision 1.13.2.2 2003/04/09 02:45:33 cdaq
+* hardwire gas cerenkov thresholds to zero
+*
+* Revision 1.13.2.1 2003/04/06 06:21:28 cdaq
+* Added (hardwired) output of beamline ADC thresholds and automatic output of aerogel pedestals
+*
+* Revision 1.13 2002/12/20 21:53:32 jones
+* Modified by Hamlet for new HMS aerogel
+*
+* Revision 1.13 2002/09/24
+* (Hamlet) Add Aerogel
+*
+* Revision 1.12 1999/02/23 18:36:12 csa
+* (JRA) Cleanup
+*
+* Revision 1.11 1999/02/03 21:13:23 saw
+* Code for new Shower counter tubes
+*
+* Revision 1.10 1998/12/17 22:02:38 saw
+* Support extra set of tubes on HMS shower counter
+*
+* Revision 1.9 1996/08/30 19:53:01 saw
+* (JRA) Up thresholds from 10 channels to 15 chans above pedestal
+*
+* Revision 1.8 1996/01/24 15:56:28 saw
+* (JRA) Cleanup
+*
+* Revision 1.7 1996/01/16 21:44:03 cdaq
+* (JRA) Improve Gas Cerenkov pedestals, add misc pedestals, write results to file.
+*
+* Revision 1.6 1995/10/09 20:12:10 cdaq
+* (JRA) Note pedestals that differ by 2 sigma from parameter file
+*
+* Revision 1.5 1995/08/31 14:58:48 cdaq
+* (JRA) Change threshold limits
+*
+* Revision 1.4 1995/07/19 18:09:51 cdaq
+* (JRA) Cleanup statistics calculations
+*
+* Revision 1.3 1995/05/22 19:39:06 cdaq
+* (SAW) Split gen_data_data_structures into gen, hms, sos, and coin parts"
+*
+* Revision 1.2 1995/05/17 13:56:54 cdaq
+* (JRA) Float integer accumulators before arithmetic
+*
+* Revision 1.1 1995/04/01 19:36:25 cdaq
+* Initial revision
+
+*
+ implicit none
+ save
+*
+ character*18 here
+ parameter (here='h_calc_pedestal')
+*
+ logical ABORT
+ character*(*) err
+*
+ integer*4 pln,cnt
+ integer*4 blk
+ integer*4 pmt
+ integer*4 imisc
+ integer*4 ind,ihit
+ integer*4 roc,slot
+ integer*4 signalcount
+ real*4 sig2
+ real*4 num
+! character*132 file
+*
+ INCLUDE 'hms_data_structures.cmn'
+ INCLUDE 'hms_pedestals.cmn'
+ INCLUDE 'hms_scin_parms.cmn'
+ INCLUDE 'hms_calorimeter.cmn'
+ INCLUDE 'hms_cer_parms.cmn'
+ INCLUDE 'hms_filenames.cmn'
+ INCLUDE 'gen_run_info.cmn'
+ INCLUDE 'hms_aero_parms.cmn'
+*
+ integer SPAREID
+ parameter (SPAREID=67)
+
+*
+* HODOSCOPE PEDESTALS
+*
+ ind = 0
+ do pln = 1 , hnum_scin_planes
+ do cnt = 1 , hnum_scin_counters(pln)
+
+*calculate new pedestal values, positive tubes first.
+ num=max(1.,float(hhodo_pos_ped_num(pln,cnt)))
+ hhodo_new_ped_pos(pln,cnt) = float(hhodo_pos_ped_sum(pln,cnt)) / num
+ sig2 = float(hhodo_pos_ped_sum2(pln,cnt))/num -
+ & hhodo_new_ped_pos(pln,cnt)**2
+ hhodo_new_sig_pos(pln,cnt) = sqrt(max(0.,sig2))
+ hhodo_new_threshold_pos(pln,cnt)=hhodo_new_ped_pos(pln,cnt)+15.
+
+*note channels with 2 sigma difference from paramter file values.
+ if (abs(hscin_all_ped_pos(pln,cnt)-hhodo_new_ped_pos(pln,cnt))
+ & .ge.(2.*hhodo_new_sig_pos(pln,cnt))) then
+ ind = ind + 1 !final value of 'ind' is saved at end of loop
+ hhodo_changed_plane(ind)=pln
+ hhodo_changed_element(ind)=cnt
+ hhodo_changed_sign(ind)= 1 !1=pos,2=neg.
+ hhodo_ped_change(ind) = hhodo_new_ped_pos(pln,cnt) -
+ & hscin_all_ped_pos(pln,cnt)
+ endif !large pedestal change
+
+*replace old peds (from param file) with calculated pedestals
+ if (num.gt.hhodo_min_peds .and. hhodo_min_peds.ne.0) then
+ hscin_all_ped_pos(pln,cnt)=hhodo_new_ped_pos(pln,cnt)
+ endif
+
+*do it all again for negative tubes.
+ num=max(1.,float(hhodo_neg_ped_num(pln,cnt)))
+ hhodo_new_ped_neg(pln,cnt) = float(hhodo_neg_ped_sum(pln,cnt)) / num
+ sig2 = float(hhodo_neg_ped_sum2(pln,cnt))/num -
+ $ hhodo_new_ped_neg(pln,cnt)**2
+ hhodo_new_sig_neg(pln,cnt) = sqrt(max(0.,sig2))
+ hhodo_new_threshold_neg(pln,cnt)=hhodo_new_ped_neg(pln,cnt)+15.
+
+ if (abs(hscin_all_ped_neg(pln,cnt)-hhodo_new_ped_neg(pln,cnt))
+ & .ge.(2.*hhodo_new_sig_neg(pln,cnt))) then
+ ind = ind + 1
+ hhodo_changed_plane(ind)=pln
+ hhodo_changed_element(ind)=cnt
+ hhodo_changed_sign(ind)= 2 !1=pos, 2=neg.
+ hhodo_ped_change(ind) = hhodo_new_ped_neg(pln,cnt) -
+ & hscin_all_ped_neg(pln,cnt)
+ endif !large pedestal change
+
+ if (num.gt.hhodo_min_peds .and. hhodo_min_peds.ne.0) then
+ hscin_all_ped_neg(pln,cnt)=hhodo_new_ped_neg(pln,cnt)
+ endif
+
+ enddo !counters
+ enddo !planes
+ hhodo_num_ped_changes = ind
+
+*
+* CALORIMETER PEDESTALS
+*
+ ind = 0
+ do blk = 1 , hmax_cal_blocks
+
+* calculate new pedestal values, positive tubes first.
+ num=max(1.,float(hcal_pos_ped_num(blk)))
+ hcal_new_ped_pos(blk)=hcal_pos_ped_sum(blk)/num
+ sig2 = float(hcal_pos_ped_sum2(blk))/num - hcal_new_ped_pos(blk)**2
+ hcal_new_rms_pos(blk)=sqrt(max(0.,sig2))
+ hcal_new_adc_threshold_pos(blk)=hcal_new_ped_pos(blk)+15.
+ if (abs(hcal_pos_ped_mean(blk)-hcal_new_ped_pos(blk))
+ & .ge.(2.*hcal_new_rms_pos(blk))) then
+ ind = ind + 1
+ hcal_changed_block(ind)=blk
+ hcal_changed_sign(ind)=1 ! 1=pos,2=neg.
+ hcal_ped_change(ind)=hcal_new_ped_pos(blk)-
+ & hcal_pos_ped_mean(blk)
+ endif
+
+
+ if (num.gt.hcal_min_peds .and. hcal_min_peds.ne.0) then
+ hcal_pos_ped_mean(blk)=hcal_new_ped_pos(blk)
+ hcal_pos_ped_rms(blk)=hcal_new_rms_pos(blk)
+ hcal_pos_threshold(blk)=min(50.,max(10.,3.*hcal_new_rms_pos(blk)))
+ endif
+
+*do it all again for negative tubes.
+ num=max(1.,float(hcal_neg_ped_num(blk)))
+ hcal_new_ped_neg(blk)=hcal_neg_ped_sum(blk)/num
+ sig2 = float(hcal_neg_ped_sum2(blk))/num-hcal_new_ped_neg(blk)**2
+ hcal_new_rms_neg(blk)=sqrt(max(0.,sig2))
+ hcal_new_adc_threshold_neg(blk)=hcal_new_ped_neg(blk)+15.
+ if (abs(hcal_neg_ped_mean(blk)-hcal_new_ped_neg(blk))
+ & .ge.(2.*hcal_new_rms_neg(blk))) then
+ ind = ind + 1
+ hcal_changed_block(ind)=blk
+ hcal_changed_sign(ind)=2 ! 1=pos,2=neg.
+ hcal_ped_change(ind)=hcal_new_ped_neg(blk)-
+ & hcal_neg_ped_mean(blk)
+ endif
+
+ if (num.gt.hcal_min_peds .and. hcal_min_peds.ne.0) then
+ hcal_neg_ped_mean(blk)=hcal_new_ped_neg(blk)
+ hcal_neg_ped_rms(blk)=hcal_new_rms_neg(blk)
+ hcal_neg_threshold(blk)=min(50.,max(10.,3.*hcal_new_rms_neg(blk)))
+ endif
+
+ enddo
+ hcal_num_ped_changes = ind
+
+*
+* GAS CERENKOV PEDESTALS
+*
+ ind = 0
+ do pmt = 1 , hmax_cer_hits
+ num=max(1.,float(hcer_ped_num(pmt)))
+ hcer_new_ped(pmt) = float(hcer_ped_sum(pmt)) / num
+ sig2 = float(hcer_ped_sum2(pmt))/ num - hcer_new_ped(pmt)**2
+ hcer_new_rms(pmt) = sqrt(max(0.,sig2))
+ hcer_new_adc_threshold(pmt)=hcer_new_ped(pmt)+15.
+ if (abs(hcer_ped(pmt)-hcer_new_ped(pmt))
+ & .ge.(2.*hcer_new_rms(pmt))) then
+ ind = ind + 1
+ hcer_changed_tube(ind)=pmt
+ hcer_ped_change(ind)=hcer_new_ped(pmt)-hcer_ped(pmt)
+ endif
+ if (num.gt.hcer_min_peds .and. hcer_min_peds.ne.0) then
+ hcer_ped(pmt)=hcer_new_ped(pmt)
+ hcer_ped_rms(pmt)=hcer_new_rms(pmt)
+ endif
+ enddo
+ hcer_num_ped_changes = ind
+*........................................................................
+*
+*
+* AEROGEL CERENKOV PEDESTALS
+*
+*
+ ind = 0
+ do pmt = 1 , hmax_aero_hits
+
+*calculate new pedestal values, positive tubes first
+ num=max(1.,float(haero_pos_ped_num(pmt)))
+ haero_new_ped_pos(pmt) = float(haero_pos_ped_sum(pmt)) / num
+ sig2 = float(haero_pos_ped_sum2(pmt))/num -
+ & haero_new_ped_pos(pmt)**2
+ haero_new_rms_pos(pmt) = sqrt(max(0.,sig2))
+ haero_new_threshold_pos(pmt) = haero_new_ped_pos(pmt)+15.
+c
+ haero_new_threshold_pos(pmt) = 400. ! mkj 4/9/03 force to 400
+c
+*note channels with 2 sigma difference from parameter file values.
+* JRA - don't have the necessary variables (e.g. haero_all_ped_pos),
+* and as far as I can tell, this code doesn't work for any detector,
+* since the h*_all_ped* variables are not filled as far as I can tell
+
+*replace old peds with calculated peds
+ if (num.gt.haero_min_peds .and. haero_min_peds.ne.0) then
+ haero_pos_ped_mean(pmt) = haero_new_ped_pos(pmt)
+ haero_pos_ped_rms(pmt) = haero_new_rms_pos(pmt)
+ endif
+
+*do it all again for negative tubes.
+ num=max(1.,float(haero_neg_ped_num(pmt)))
+ haero_new_ped_neg(pmt) = float(haero_neg_ped_sum(pmt)) / num
+ sig2 = float(haero_neg_ped_sum2(pmt))/num -
+ & haero_new_ped_neg(pmt)**2
+ haero_new_rms_neg(pmt) = sqrt(max(0.,sig2))
+ haero_new_threshold_neg(pmt) = haero_new_ped_neg(pmt)+15.
+c
+ haero_new_threshold_neg(pmt) = 400. ! mkj 4/9/03 force to 400
+
+ if (num.gt.haero_min_peds .and. haero_min_peds.ne.0) then
+ haero_neg_ped_mean(pmt) = haero_new_ped_neg(pmt)
+ haero_neg_ped_rms(pmt) = haero_new_rms_neg(pmt)
+ endif
+
+ enddo
+
+* print *, ' '
+* print *, 'haero_pos_ped_mean =', haero_neg_ped_mean
+* print *, ' '
+* print *, 'haero_neg_ped_mean =', haero_pos_ped_mean
+* print *, ' '
+* print *, 'haero_pos_adc_threshold =', haero_new_threshold_pos
+* print *, ' '
+* print *, 'haero_neg_adc_threshold =', haero_new_threshold_neg
+* print *, ' '
+
+*.........................................................................
+*
+* MISC. PEDESTALS
+*
+ ind = 0
+ do ihit = 1 , hmax_misc_hits
+ if (hmisc_raw_addr1(ihit).eq.2) then ! ADC data.
+ imisc = hmisc_raw_addr2(ihit)
+ num=max(1.,float(hmisc_ped_num(imisc)))
+ hmisc_new_ped(imisc) = float(hmisc_ped_sum(imisc)) / num
+ sig2 = float(hmisc_ped_sum2(imisc))/ num - hmisc_new_ped(imisc)**2
+ hmisc_new_rms(imisc) = sqrt(max(0.,sig2))
+ hmisc_new_adc_threshold(imisc)=hmisc_new_ped(imisc)+15.
+ if (abs(hmisc_ped(imisc)-hmisc_new_ped(imisc))
+ & .ge.(2.*hmisc_new_rms(imisc))) then
+ ind = ind + 1
+ hmisc_changed_tube(ind)=imisc
+ hmisc_ped_change(ind)=hmisc_new_ped(imisc)-hmisc_ped(imisc)
+ endif
+ if (num.gt.hmisc_min_peds .and. hmisc_min_peds.ne.0) then
+ hmisc_ped(imisc)=hmisc_new_ped(imisc)
+ hmisc_ped_rms(imisc)=hmisc_new_rms(imisc)
+ endif
+ endif !chose ADC hits.
+ enddo
+ hmisc_num_ped_changes = ind
+
+*
+*
+* WRITE THRESHOLDS TO FILE FOR HARDWARE SPARCIFICATION
+*
+ if (h_threshold_output_filename.ne.' ') then
+
+* file opened in g_calc_beam_pedestal.f -- if needed
+! file=h_threshold_output_filename
+! call g_sub_run_number(file, gen_run_number)
+! open(unit=SPAREID,file=file,status='unknown')
+
+
+
+ write(SPAREID,*) '# This is the ADC threshold file generated automatically'
+ write(SPAREID,*) '# from the pedestal data from run number ',gen_run_number
+ write(SPAREID,*) '# Slot 13 (beamline stuff) is hardwired in h_calc_pedestal.f'
+ write(SPAREID,*) 'slot= 13'
+ do ind=1,16
+ write(SPAREID,*) ' 0' !BPM and raster stuff (4blank,2x4BPM,4raster)
+ enddo
+ do ind=17,20
+ write(SPAREID,*) ' 0' !?? "Paul Gueye" cable (4BPM)
+ enddo
+ do ind=21,32
+ write(SPAREID,*) ' 4000' !empty
+ enddo
+ do ind=33,64
+ write(SPAREID,*) ' 4000'
+ enddo
+
+
+
+
+ roc=1
+
+ slot=1
+ signalcount=2
+ write(SPAREID,*) 'slot=',slot
+ call g_output_thresholds(SPAREID,roc,slot,signalcount,hmax_cal_rows,
+ & hcal_new_adc_threshold_pos,hcal_new_adc_threshold_neg,
+ & hcal_new_rms_pos,hcal_new_rms_neg)
+
+*
+* JRA - 4/8/03 - Gaskell says he want's unsparsified gas cerernkov for
+* the '03 running:
+
+ slot=3
+ write(SPAREID,*) 'slot=',slot
+ do ind=1,2
+ write(SPAREID,'(a6)') ' 0'
+ enddo
+ do ind=3,64
+ write(SPAREID,'(a6)') ' 4000'
+ enddo
+
+* slot=3
+* signalcount=1
+* write(SPAREID,*) 'slot=',slot
+* call g_output_thresholds(SPAREID,roc,slot,signalcount,hmax_cer_hits,
+* & hcer_new_adc_threshold,0,hcer_new_rms,0)
+
+ slot=5
+ signalcount=2
+ write(SPAREID,*) 'slot=',slot
+ call g_output_thresholds(SPAREID,roc,slot,signalcount,hmax_cal_rows,
+ & hcal_new_adc_threshold_pos,hcal_new_adc_threshold_neg,
+ & hcal_new_rms_pos,hcal_new_rms_neg)
+
+ slot=7
+ signalcount=2
+ write(SPAREID,*) 'slot=',slot
+ call g_output_thresholds(SPAREID,roc,slot,signalcount,hnum_scin_planes,
+ & hhodo_new_threshold_pos,hhodo_new_threshold_neg,hhodo_new_sig_pos,
+ & hhodo_new_sig_neg)
+
+ slot=9
+ signalcount=2
+ write(SPAREID,*) 'slot=',slot
+ call g_output_thresholds(SPAREID,roc,slot,signalcount,hnum_scin_planes,
+ & hhodo_new_threshold_pos,hhodo_new_threshold_neg,hhodo_new_sig_pos,
+ & hhodo_new_sig_neg)
+
+ slot=11
+ signalcount=1
+ write(SPAREID,*) 'slot=',slot
+ call g_output_thresholds(SPAREID,roc,slot,signalcount,hmax_aero_hits,
+ & haero_new_threshold_pos,haero_new_threshold_neg,haero_pos_ped_rms,
+ & haero_neg_ped_rms)
+
+
+ close(unit=SPAREID)
+ endif
+
+ return
+ end
diff --git a/HTRACKING/h_cer.f b/HTRACKING/h_cer.f
new file mode 100644
index 0000000..4ee1a3a
--- /dev/null
+++ b/HTRACKING/h_cer.f
@@ -0,0 +1,44 @@
+ SUBROUTINE H_CER(ABORT,err)
+*--------------------------------------------------------
+*-
+*- Purpose and Methods : Analyze Cerenkov information for each track
+*-
+*- Required Input BANKS HMS_RAW_CER
+*- HMS_FOCAL_PLANE
+*-
+*- Output BANKS HMS_TRACK_TESTS
+*-
+*- Output: ABORT - success or failure
+*- : err - reason for failure, if any
+*-
+*- Created 19-JAN-1994 D. F. Geesaman
+*- Dummy Shell routine
+* $Log: h_cer.f,v $
+* Revision 1.2 1995/05/22 19:39:06 cdaq
+* (SAW) Split gen_data_data_structures into gen, hms, sos, and coin parts"
+*
+* Revision 1.1 1994/02/19 06:13:01 cdaq
+* Initial revision
+*
+*-
+*-
+*--------------------------------------------------------
+ IMPLICIT NONE
+ SAVE
+*
+ character*50 here
+ parameter (here= 'H_CER')
+*
+ logical ABORT
+ character*(*) err
+*
+ INCLUDE 'hms_data_structures.cmn'
+ INCLUDE 'gen_constants.par'
+ INCLUDE 'gen_units.par'
+*
+*--------------------------------------------------------
+*
+ ABORT= .FALSE.
+ err= ':dummy routine!'
+ RETURN
+ END
diff --git a/HTRACKING/h_cer_eff.f b/HTRACKING/h_cer_eff.f
new file mode 100644
index 0000000..901d201
--- /dev/null
+++ b/HTRACKING/h_cer_eff.f
@@ -0,0 +1,81 @@
+ SUBROUTINE H_CER_EFF(ABORT,errmsg)
+
+*--------------------------------------------------------
+*
+* Purpose and Methods : Analyze cerenkov information for the "best
+* track" as selected in h_select_best_track
+* Required Input BANKS: hms_cer_parms
+* HMS_DATA_STRUCTURES
+*
+* Output: ABORT - success or failure
+* : err - reason for failure, if any
+*
+*
+* author: Chris Cothran
+* created: 5/25/95
+* $Log: h_cer_eff.f,v $
+* Revision 1.4 1999/02/10 18:19:06 csa
+* Changed hscer_et test to use momentum-normalized variable
+*
+* Revision 1.3 1999/02/03 21:13:23 saw
+* Code for new Shower counter tubes
+*
+* Revision 1.2 1995/10/09 20:15:08 cdaq
+* (JRA) Move calculation of hit position on mirror to s_physics
+*
+* Revision 1.1 1995/08/31 14:54:09 cdaq
+* Initial revision
+*
+*--------------------------------------------------------
+
+ IMPLICIT NONE
+*
+ character*9 here
+ parameter (here= 'H_CER_EFF')
+*
+ logical ABORT
+ character*(*) errmsg
+*
+ include 'hms_data_structures.cmn'
+ include 'hms_cer_parms.cmn'
+ include 'hms_physics_sing.cmn'
+ include 'hms_calorimeter.cmn'
+
+ integer*4 nr
+*
+* test for a good electron. Use normalized, tracked shower counter
+* variable (hsshtrk).
+*
+ if (hntracks_fp .eq. 1
+ & .and. hschi2perdeg .gt. 0.
+ & .and. hschi2perdeg .lt. hcer_chi2max
+ & .and. hsbeta .gt. hcer_beta_min
+ & .and. hsbeta .lt. hcer_beta_max
+ & .and. hsshtrk .gt. hcer_et_min
+ & .and. hsshtrk .lt. hcer_et_max) then
+
+ do nr = 1, hcer_num_regions
+*
+* hit must be inside the region in order to continue.
+*
+ if (abs(hcer_region(nr,1)-hsx_cer).lt.hcer_region(nr,5)
+ > .and. abs(hcer_region(nr,2)-hsy_cer).lt.hcer_region(nr,6)
+ > .and. abs(hcer_region(nr,3)-hsxp_fp).lt.hcer_region(nr,7)
+ > .and. abs(hcer_region(nr,4)-hsyp_fp).lt.hcer_region(nr,8))
+ > then
+*
+* increment the 'should have fired' counters
+*
+ hcer_track_counter(nr) = hcer_track_counter(nr) + 1
+*
+* increment the 'did fire' counters
+*
+ if (HCER_NPE_SUM.gt.hcer_threshold) then
+ hcer_fired_counter(nr) = hcer_fired_counter(nr) + 1
+ endif
+ endif
+ enddo
+ endif
+
+ return
+ end
diff --git a/HTRACKING/h_cer_eff_shutdown.f b/HTRACKING/h_cer_eff_shutdown.f
new file mode 100644
index 0000000..b3a4dde
--- /dev/null
+++ b/HTRACKING/h_cer_eff_shutdown.f
@@ -0,0 +1,63 @@
+ SUBROUTINE H_CER_EFF_SHUTDOWN(lunout,ABORT,errmsg)
+
+*--------------------------------------------------------
+*
+* Purpose and Methods: Output Cerenkov efficiency information
+*
+* Required Input BANKS: HMS_CER_DIAGNOSTICS
+*
+* Output: ABORT - success or failure
+* : err - reason for failure, if any
+*
+* author: Chris Cothran
+* created: 5/25/95
+* $Log: h_cer_eff_shutdown.f,v $
+* Revision 1.1 1995/08/31 14:54:31 cdaq
+* Initial revision
+*
+*--------------------------------------------------------
+
+ IMPLICIT NONE
+*
+ character*18 here
+ parameter (here= 'H_CER_EFF_SHUTDOWN')
+*
+ logical ABORT
+ character*(*) errmsg
+*
+ INCLUDE 'hms_data_structures.cmn'
+ INCLUDE 'hms_cer_parms.cmn'
+
+ integer*4 lunout
+ integer*4 nr
+ logical written_header
+
+ save
+
+ written_header = .false. !haven't done the header yet
+
+ do nr = 1, hcer_num_regions
+ if (hcer_track_counter(nr) .gt. hcer_min_counts) then
+ hcer_region_eff(nr) = float(hcer_fired_counter(nr))
+ > /float(hcer_track_counter(nr))
+ else
+ hcer_region_eff(nr) = 1.0
+c write (lunout,'(A,I1,A)')
+c > 'Warning: Not enough counts for HMS Cerenkov efficiency
+c > measurement in Region #',nr,'.'
+ endif
+ if (hcer_region_eff(nr) .lt. hcer_min_eff) then
+ if (.not.written_header) then
+ write(lunout,*)
+ write(lunout,'(a,f6.3)') ' HMS cerenkov regions with effic. < ',hcer_min_eff
+ endif
+ write (lunout,'(2x,a,i1,a,f7.4)') 'region ',nr,' has eff = ',
+ & hcer_region_eff(nr)
+c write (lunout,'(A,I1,A,F7.5,A)')
+c > 'Warning: Efficiency of HMS Cerekov Region #',nr,' is ',
+c > hcer_region_eff(nr),'.'
+ endif
+ enddo
+
+ return
+ end
diff --git a/HTRACKING/h_chamnum.f b/HTRACKING/h_chamnum.f
new file mode 100644
index 0000000..db7300b
--- /dev/null
+++ b/HTRACKING/h_chamnum.f
@@ -0,0 +1,31 @@
+ function h_chamnum(ispace_point)
+* This function returns the chamber number of a space point
+* d.f. geesaman 17 January 1994
+* $Log: h_chamnum.f,v $
+* Revision 1.3 1996/04/30 12:32:51 saw
+* (JRA) Remove (unneeded?) check on plane range
+*
+* Revision 1.2 1995/05/22 19:39:07 cdaq
+* (SAW) Split gen_data_data_structures into gen, hms, sos, and coin parts"
+*
+* Revision 1.1 1994/02/19 06:13:14 cdaq
+* Initial revision
+*
+ implicit none
+ include "hms_data_structures.cmn"
+ include "hms_tracking.cmn"
+ include "hms_geometry.cmn"
+* output
+ integer*4 h_chamnum
+* input
+ integer*4 ispace_point
+* local variables
+ integer*4 plane
+
+
+ plane=HDC_PLANE_NUM(hspace_point_hits(ispace_point,3))
+ h_chamnum=hdc_chamber_planes(plane)
+
+ return
+ end
+*
diff --git a/HTRACKING/h_choose_single_hit.f b/HTRACKING/h_choose_single_hit.f
new file mode 100644
index 0000000..44b81d2
--- /dev/null
+++ b/HTRACKING/h_choose_single_hit.f
@@ -0,0 +1,99 @@
+ subroutine h_choose_single_hit(ABORT,err,nspace_points,
+ & space_point_hits)
+*--------------------------------------------------------
+*-
+*- Purpose and Methods : This routine looks at all hits in a space
+*- point. If two hits are in the same plane it
+*- rejects the one with the longer drift time
+*-
+*-
+*- Output: ABORT - success or failure
+*- : err - reason for failure, if any
+*-
+*- Created 28-JUN-1994 D. F. Geesaman
+* $Log: h_choose_single_hit.f,v $
+* Revision 1.4 1996/01/16 21:45:35 cdaq
+* (JRA) Misc changes
+*
+* Revision 1.3 1995/05/22 19:39:07 cdaq
+* (SAW) Split gen_data_data_structures into gen, hms, sos, and coin parts"
+*
+* Revision 1.2 1994/10/11 20:20:52 cdaq
+* (JRA) Fix bug that allowed two hits on a single plane
+*
+* Revision 1.1 1994/06/30 02:40:17 cdaq
+* Initial revision
+*
+*--------------------------------------------------------
+ IMPLICIT NONE
+ SAVE
+*
+ character*50 here
+ parameter (here= 'h_choose_single_hit')
+ integer*4 nspace_points
+*
+ logical ABORT
+ character*(*) err
+*
+ INCLUDE 'hms_data_structures.cmn'
+ INCLUDE 'gen_constants.par'
+ INCLUDE 'gen_units.par'
+ include 'hms_tracking.cmn'
+ include 'hms_geometry.cmn'
+
+*
+ integer*4 space_point_hits(hmax_space_points,hmax_hits_per_point+2)
+*
+* local variables
+ integer*4 point,startnum,finalnum,goodhit(hmax_dc_hits)
+ integer*4 plane1,plane2,hit1,hit2,drifttime1,drifttime2
+ integer*4 hits(hmax_hits_per_point)
+ integer*4 j,k
+
+*
+* temporary initialization
+ ABORT= .FALSE.
+ err=' '
+*
+*
+* loop over all space points
+ do point =1,nspace_points
+ startnum = space_point_hits(point,1)
+ finalnum=0
+
+ do j=3,startnum+2
+ goodhit(j) = 1
+ enddo
+
+ do j=3,startnum+1
+ hit1 = space_point_hits(point,j)
+ plane1 = hdc_plane_num(hit1)
+ drifttime1 = hdc_drift_time(hit1)
+ do k=j+1,startnum+2
+ hit2 = space_point_hits(point,k)
+ plane2 = hdc_plane_num(hit2)
+ drifttime2 = hdc_drift_time(hit2)
+ if(plane1 .eq. plane2 ) then
+ if(drifttime1.gt.drifttime2) then
+ goodhit(j) = 0
+ else !if equal times, choose 1st hit(arbitrary)
+ goodhit(k) = 0
+ endif
+ endif ! end test on equal planes
+ enddo ! end loop on k
+ enddo ! end loop on j
+ do j=3,startnum+2
+ if(goodhit(j).gt.0) then
+ finalnum = finalnum + 1
+ hits(finalnum)=space_point_hits(point,j)
+ endif ! end check on good hit
+ enddo
+* copy good hits to space_point_hits
+ space_point_hits(point,1) = finalnum
+ do j = 1, finalnum
+ space_point_hits(point,j+2) = hits(j)
+ enddo ! end of copy
+ enddo ! end loop on space points
+*
+ return
+ end
diff --git a/HTRACKING/h_clusters_cal.f b/HTRACKING/h_clusters_cal.f
new file mode 100644
index 0000000..779e9f9
--- /dev/null
+++ b/HTRACKING/h_clusters_cal.f
@@ -0,0 +1,215 @@
+*=======================================================================
+ subroutine h_clusters_cal(abort,errmsg)
+*=======================================================================
+*-
+*- Purpose: Finds clusters in the calorimeter and computes
+*- for each cluster it's size(number of hit blocks),
+*- position, energy deposition in the calorimeter
+*- columns and the total energy deposition.
+*- The energy depositions are not corrected yet for
+*- impact point coordinate dependence.
+*- A cluster is defined as a set of adjacent hit blocks
+*- which share a common edge or a corner. Any two hits
+*- from different clusters are separated by at least one
+*- block which has not fired.
+*-
+*- Input Banks: HMS_SPARSIFIED_CAL, HMS_DECODED_CAL
+*-
+*- Output Bank: HMS_CLUSTERS_CAL
+*-
+*- Created: 15 Mar 1994 Tsolak A. Amatuni
+*- Modified 25 Mar 1994 DFG
+*- Change name of print routine
+* 10 Apr 1994 DFG Protect for Et=0 division
+* $Log: h_clusters_cal.f,v $
+* Revision 1.5 1999/02/03 21:13:23 saw
+* Code for new Shower counter tubes
+*
+* Revision 1.4 1995/05/22 19:39:07 cdaq
+* (SAW) Split gen_data_data_structures into gen, hms, sos, and coin parts"
+*
+* Revision 1.3 1994/08/02 20:00:12 cdaq
+* (JRA) Catch some out of bounds problems
+*
+* Revision 1.2 1994/04/13 05:31:37 cdaq
+* *** empty log message ***
+*
+* Revision 1.1 1994/04/12 21:30:02 cdaq
+* Initial revision
+*
+*-
+*-----------------------------------------------------------------------
+*
+*
+ implicit none
+ save
+*
+ logical abort
+ character*(*) errmsg
+ character*14 here
+ parameter (here='H_CLUSTERS_CAL')
+*
+ integer*4 nc !Cluster number
+ integer*4 ihit,jhit,khit,nh !Internal loop counters.
+ integer*4 hits_tagged !Current number of tagged hits.
+ integer*4 irow,icol,jrow,jcol,col!Row and column indecies
+ integer*4 d_row,d_col !Distance between rows(columns)
+ logical tagged
+*
+ include 'hms_data_structures.cmn'
+ include 'hms_calorimeter.cmn'
+*
+*
+ hnclusters_cal=0
+ if(hcal_num_hits.le.0) go to 100 !Return
+*
+ do ihit=1,hmax_cal_blocks
+ hcluster_hit(ihit)=0
+ enddo
+*
+ nc = 1
+ hcluster_hit(1) =-1
+ hcluster_size(1) = 1
+ hits_tagged = 1
+ tagged =.true.
+*
+* Find the clusters.
+*
+*
+*-----Loop untill all the hits are tagged
+ do while(hits_tagged.le.hcal_num_hits)
+*
+*-------Loop untill there are no more hits
+*-------in the current cluster to be tagged
+ do while(tagged)
+ tagged=.false.
+*
+*---------Loop over all the hits
+ do ihit=1,hcal_num_hits
+*
+*-----------and find a hit("seed") which belongs to the
+*-----------current cluster, but it's neighbors are not tagged
+ if(hcluster_hit(ihit).lt.0) then
+ irow =hcal_rows(ihit)
+ icol =hcal_cols(ihit)
+*
+*-------------Loop over all the hits
+ do jhit=1,hcal_num_hits
+*
+*---------------and find hits which are not tagged yet
+ if(hcluster_hit(jhit).eq.0) then
+ jrow =hcal_rows(jhit)
+ jcol =hcal_cols(jhit)
+ d_row=iabs(jrow-irow)
+ d_col=iabs(jcol-icol)
+*
+*-----------------Are these hits a neighbor to "seed"?
+ if(d_row.le.1.and.d_col.le.1) then
+*
+*-------------------Assign them to the same current cluster
+ hcluster_hit(jhit)=hcluster_hit(ihit)
+ hcluster_size(nc) =hcluster_size(nc)+1
+ hits_tagged =hits_tagged+1
+ tagged =.true.
+*
+ endif !End ... if neighbor of "seed"
+*
+ endif !End ... if not scanned yet
+*
+ enddo !End loop over all hits
+*
+*-------------All the neighbors of "seed" were scanned
+ hcluster_hit(ihit)=-hcluster_hit(ihit)
+*
+ endif !End ... if "seed"
+*
+ enddo !End loop over all hits
+*
+ enddo !All the hits of the current cluster were tagged
+*
+*-------Initialize to start the search for the next cluster
+ nc =nc+1
+ hits_tagged =hits_tagged+1
+ tagged =.true.
+*
+*-------Find a hit which is not tagged
+ khit=1
+ do while(hcluster_hit(khit).ne.0 .AND. KHIT.LT.HMAX_CAL_BLOCKS)
+ khit=khit+1
+ enddo
+*
+*-------This will be the new "seed"
+ IF (NC.GT.HNCLUSTERS_MAX) NC=HNCLUSTERS_MAX !AVOID OUT/BOUNDS.
+ hcluster_hit(khit)=-nc
+ hcluster_size(nc) = 1
+*
+ enddo !End. Now all the hits are assigned to some cluster
+*
+*-----Number of clusters found
+ hnclusters_cal=nc-1
+*
+* For each cluster found, compute the center of gravity in X
+* projection, the energy deposited in succesive calorimeter columns
+* and the total energy deposition
+*
+ do nc=1,hnclusters_max
+ hcluster_e1_pos(nc)=0.
+ hcluster_e1_neg(nc)=0.
+ hcluster_e2_pos(nc)=0.
+ hcluster_e2_neg(nc)=0.
+*
+ hcluster_e1(nc)=0.
+ hcluster_e2(nc)=0.
+ hcluster_e3(nc)=0.
+ hcluster_e4(nc)=0.
+ hcluster_et(nc)=0.
+ hcluster_xc(nc)=0.
+ enddo
+*
+*
+ do nh=1,hcal_num_hits
+ nc = MAX(1,hcluster_hit(nh) ) !THIS DOES NOT HELP THE ANALYSIS,
+ !BUT IT AVOIDS SUBSCRIPT OUT/BOUNDS ERRS.
+ col=hcal_cols(nh)
+*
+ hcluster_xc(nc)=hcluster_xc(nc)+hblock_xc(nh)*hblock_de(nh)
+*
+ if(col.eq.1) then
+ if(hcal_num_neg_columns.ge.1) then
+ hcluster_e1_pos(nc)=hcluster_e1_pos(nc)+hblock_de_pos(nh)
+ hcluster_e1_neg(nc)=hcluster_e1_neg(nc)+hblock_de_neg(nh)
+ hcluster_e1(nc)=hcluster_e1_pos(nc)+hcluster_e1_neg(nc)
+ else
+ hcluster_e1(nc)=hcluster_e1(nc)+hblock_de(nh)
+ endif
+ else if (col.eq.2) then
+ if(hcal_num_neg_columns.ge.2) then
+ hcluster_e2_pos(nc)=hcluster_e2_pos(nc)+hblock_de_pos(nh)
+ hcluster_e2_neg(nc)=hcluster_e2_neg(nc)+hblock_de_neg(nh)
+ hcluster_e2(nc)=hcluster_e2_pos(nc)+hcluster_e2_neg(nc)
+ else
+ hcluster_e2(nc)=hcluster_e2(nc)+hblock_de(nh)
+ endif
+ else if(col.eq.3) then
+ hcluster_e3(nc)=hcluster_e3(nc)+hblock_de(nh)
+ else if(col.eq.4) then
+ hcluster_e4(nc)=hcluster_e4(nc)+hblock_de(nh)
+ endif
+ hcluster_et(nc)=hcluster_et(nc)+hblock_de(nh) ! Is hblock_de de_pos+de_neg?
+*
+ enddo
+*
+ do nc=1,hnclusters_cal
+* make sure hcluster_et .ne. zero so no divide by zero
+ if(hcluster_et(nc).gt.0.) then
+ hcluster_xc(nc)=hcluster_xc(nc)/hcluster_et(nc)
+ else
+ hcluster_xc(nc)= -1.0 ! Set fraction negative for bad et
+ endif
+ enddo
+*
+ 100 continue
+ if(hdbg_clusters_cal.gt.0) call h_prt_cal_clusters
+*
+ return
+ end
diff --git a/HTRACKING/h_correct_cal.f b/HTRACKING/h_correct_cal.f
new file mode 100644
index 0000000..0140096
--- /dev/null
+++ b/HTRACKING/h_correct_cal.f
@@ -0,0 +1,64 @@
+*=======================================================================
+ function h_correct_cal(x,y)
+*=======================================================================
+*-
+*- Purpose: Returns the impact point correction factor. This
+*- factor is to be applied to the energy depositions.
+*- The final energy is the ADC value TIMES the correction factor.
+*-
+*- Input Parameters: x,y - impact point coordinates
+*-
+*- Created 15 Mar 1994 Tsolak A. Amatuni
+*
+* $Log: h_correct_cal.f,v $
+* Revision 1.7 2003/04/03 00:43:13 jones
+* Update to calibration (V. Tadevosyan0
+*
+* Revision 1.6 2003/03/21 22:33:22 jones
+* Subroutines had arguments with abort,errmsg . But these arguments were not
+* used when the subroutine was called. Also abort ,errmsg were not used in the
+* subroutines. So eliminate abort,errmsg. (E. Brash)
+*
+* Revision 1.5 1996/01/16 21:46:10 cdaq
+* (JRA) Yet another sign change of quadratic term in attenuation correction
+*
+* Revision 1.4 1995/08/31 14:59:37 cdaq
+* (JRA) Change sign of quadratic term in attenuation correction
+*
+* Revision 1.3 1995/05/22 19:39:08 cdaq
+* (SAW) Split gen_data_data_structures into gen, hms, sos, and coin parts"
+*
+* Revision 1.2 1994/11/22 20:02:52 cdaq
+* (???) Hack in a correction for attenuation length
+*
+* Revision 1.1 1994/04/12 21:30:48 cdaq
+* Initial revision
+*
+*-----------------------------------------------------------------------
+*
+ implicit none
+ save
+*
+* logical abort
+* character*(*) errmsg
+ character*13 here
+ parameter (here='H_CORRECT_CAL')
+*
+ real*4 x,y !Impact point coordinates
+ real*4 h_correct_cal
+*
+ include 'hms_data_structures.cmn'
+ include 'hms_calorimeter.cmn'
+*
+*
+c Check calorimeter boundaries.
+
+ if(y.lt.hcal_ymin) y=hcal_ymin
+ if(y.gt.hcal_ymax) y=hcal_ymax
+*
+ h_correct_cal=exp(y/200.) !200 cm atten length.
+ h_correct_cal=h_correct_cal/(1. + y*y/8000.)
+
+*
+ return
+ end
diff --git a/HTRACKING/h_correct_cal_neg.f b/HTRACKING/h_correct_cal_neg.f
new file mode 100644
index 0000000..ae6987e
--- /dev/null
+++ b/HTRACKING/h_correct_cal_neg.f
@@ -0,0 +1,69 @@
+*=======================================================================
+ function h_correct_cal_neg(x,y)
+*=======================================================================
+*-
+*- Purpose: Returns the impact point correction factor. This
+*- factor is to be applied to the energy depositions.
+*- This correction for single "NEG_PMT" readout from
+*- LG-blocks. The final energy is the ADC value TIMES
+*- the correction factor.
+*-
+*- Input Parameters: x,y - impact point coordinates
+*-
+*- Created 09 October 1997 H. Mkrtchyan
+*
+* $Log: h_correct_cal_neg.f,v $
+* Revision 1.6 2003/04/03 00:43:13 jones
+* Update to calibration (V. Tadevosyan0
+*
+* Revision 1.5 2003/03/21 22:33:22 jones
+* Subroutines had arguments with abort,errmsg . But these arguments were not
+* used when the subroutine was called. Also abort ,errmsg were not used in the
+* subroutines. So eliminate abort,errmsg. (E. Brash)
+*
+* Revision 1.4 2002/09/26 14:43:17 jones
+* Different parameters a,b,c
+* Fit to pion data of run 23121
+* Different formula for h_correct_cal_neg
+*
+* Revision 1.2 1999/01/29 17:33:56 saw
+* Cosmetic changes
+*
+* Revision 1.1 1999/01/21 21:40:13 saw
+* Extra shower counter tube modifications
+*
+*
+*
+*-----------------------------------------------------------------------
+*
+ implicit none
+ save
+*
+* logical abort
+* character*(*) errmsg
+ character*17 here
+ parameter (here='H_CORRECT_CAL_NEG')
+*
+*
+ real*4 x,y ! Impact point coordinates
+ real*4 h_correct_cal_neg
+*
+ include 'hms_data_structures.cmn'
+ include 'hms_calorimeter.cmn'
+*
+
+c Check calorimeter boundaries.
+
+ if(y.lt.hcal_ymin) y=hcal_ymin
+ if(y.gt.hcal_ymax) y=hcal_ymax
+
+*
+* Fit to stright through pion data of run # 23121.
+*
+ h_correct_cal_neg=(64.36-y)/(64.36-y/1.66)
+
+ccc h_correct_cal_neg=exp(-y/200.) !200 cm atten length.
+ccc h_correct_cal_neg=h_correct_cal_neg*(1. + y*y/8000.)
+*
+ return
+ end
diff --git a/HTRACKING/h_correct_cal_pos.f b/HTRACKING/h_correct_cal_pos.f
new file mode 100644
index 0000000..cc2d730
--- /dev/null
+++ b/HTRACKING/h_correct_cal_pos.f
@@ -0,0 +1,80 @@
+*=======================================================================
+ function h_correct_cal_pos(x,y)
+*=======================================================================
+*-
+*- Purpose: Returns the impact point correction factor. This
+*- factor is to be applied to the energy depositions.
+*- The final energy is the ADC value TIMES the correction factor.
+*-
+*- Input Parameters: x,y - impact point coordinates
+*-
+*- Created 15 Mar 1994 Tsolak A. Amatuni
+*
+* $Log: h_correct_cal_pos.f,v $
+* Revision 1.7 2003/04/03 00:43:13 jones
+* Update to calibration (V. Tadevosyan0
+*
+* Revision 1.6 2003/03/21 22:33:22 jones
+* Subroutines had arguments with abort,errmsg . But these arguments were not
+* used when the subroutine was called. Also abort ,errmsg were not used in the
+* subroutines. So eliminate abort,errmsg. (E. Brash)
+*
+* Revision 1.5 2002/09/26 14:41:36 jones
+* Different parameters a,b,c
+* Fit to pion data of run 23121
+* Different formula for h_correct_cal_pos
+*
+* Revision 1.2 1999/01/29 17:33:56 saw
+* Cosmetic changes
+*
+* Revision 1.1 1999/01/21 21:40:14 saw
+* Extra shower counter tube modifications
+*
+* Revision 1.5 1996/01/16 21:46:10 cdaq
+* (JRA) Yet another sign change of quadratic term in attenuation correction
+*
+* Revision 1.4 1995/08/31 14:59:37 cdaq
+* (JRA) Change sign of quadratic term in attenuation correction
+*
+* Revision 1.3 1995/05/22 19:39:08 cdaq
+* (SAW) Split gen_data_data_structures into gen, hms, sos, and coin parts"
+*
+* Revision 1.2 1994/11/22 20:02:52 cdaq
+* (???) Hack in a correction for attenuation length
+*
+* Revision 1.1 1994/04/12 21:30:48 cdaq
+* Initial revision
+*
+*-----------------------------------------------------------------------
+*
+ implicit none
+ save
+*
+* logical abort
+* character*(*) errmsg
+ character*17 here
+ parameter (here='H_CORRECT_CAL_POS')
+*
+ real*4 x,y !Impact point coordinates
+ real*4 h_correct_cal_pos
+*
+ include 'hms_data_structures.cmn'
+ include 'hms_calorimeter.cmn'
+*
+
+c Check calorimeter boundaries.
+
+ if(y.lt.hcal_ymin) y=hcal_ymin
+ if(y.gt.hcal_ymax) y=hcal_ymax
+
+*
+* Fit to stright through pion data of run # 23121.
+*
+ h_correct_cal_pos=(64.36+y)/(64.36+y/1.66)
+
+ccc h_correct_cal_pos=exp(y/200.) !200 cm atten length.
+ccc h_correct_cal_pos=h_correct_cal_pos/(1. + y*y/8000.)
+
+*
+ return
+ end
diff --git a/HTRACKING/h_dc_eff.f b/HTRACKING/h_dc_eff.f
new file mode 100644
index 0000000..d091d3c
--- /dev/null
+++ b/HTRACKING/h_dc_eff.f
@@ -0,0 +1,54 @@
+ SUBROUTINE H_DC_EFF(ABORT,errmsg)
+*--------------------------------------------------------
+*-
+*- Purpose and Methods : Analyze scintillator information for each track
+*-
+*- Required Input BANKS HMS_STATISTICS
+*- GEN_DATA_STRUCTURES
+*-
+*- Output: ABORT - success or failure
+*- : err - reason for failure, if any
+*-
+* author: John Arrington
+* created: 8/17/95
+*
+* h_dc_eff calculates efficiencies for the drift chambers.
+*
+* $Log: h_dc_eff.f,v $
+* Revision 1.1 1995/08/31 14:59:48 cdaq
+* Initial revision
+*
+*--------------------------------------------------------
+ IMPLICIT NONE
+*
+ character*8 here
+ parameter (here= 'H_DC_EFF')
+*
+ logical ABORT
+ character*(*) errmsg
+*
+ INCLUDE 'hms_data_structures.cmn'
+ INCLUDE 'gen_constants.par'
+ INCLUDE 'gen_units.par'
+ include 'hms_statistics.cmn'
+ include 'hms_tracking.cmn'
+
+ integer*4 ind
+
+ save
+
+ hdc_tot_events = hdc_tot_events + 1
+ do ind = 1 , hdc_num_planes
+ if (hdc_hits_per_plane(ind).gt.0) hdc_events(ind)=hdc_events(ind)+1
+ enddo
+
+ if (hdc_hits_per_plane(1)+hdc_hits_per_plane(2)+hdc_hits_per_plane(3)
+ & +hdc_hits_per_plane(4)+hdc_hits_per_plane(5)+hdc_hits_per_plane(6)
+ & .ne. 0) hdc_cham_hits(1) = hdc_cham_hits(1) + 1
+
+ if (hdc_hits_per_plane( 7)+hdc_hits_per_plane( 8)+hdc_hits_per_plane( 9)
+ & +hdc_hits_per_plane(10)+hdc_hits_per_plane(11)+hdc_hits_per_plane(12)
+ & .ne. 0) hdc_cham_hits(2) = hdc_cham_hits(2) + 1
+
+ return
+ end
diff --git a/HTRACKING/h_dc_eff_shutdown.f b/HTRACKING/h_dc_eff_shutdown.f
new file mode 100644
index 0000000..95f0ed5
--- /dev/null
+++ b/HTRACKING/h_dc_eff_shutdown.f
@@ -0,0 +1,68 @@
+ SUBROUTINE H_DC_EFF_SHUTDOWN(lunout,ABORT,errmsg)
+*--------------------------------------------------------
+*-
+*- Purpose and Methods : Analyze and report drift chamber efficiencies.
+*-
+*- Required Input BANKS HMS_STATISTICS
+*- GEN_DATA_STRUCTURES
+*-
+*- Output: ABORT - success or failure
+*- : err - reason for failure, if any
+*-
+* author: John Arrington
+* created: 2/15/95
+*
+* h_dc_eff calculates efficiencies for the hodoscope.
+* h_dc_eff_shutdown does some final manipulation of the numbers.
+*
+* $Log: h_dc_eff_shutdown.f,v $
+* Revision 1.2 1996/08/30 19:54:11 saw
+* (JRA) Cosmetic
+*
+* Revision 1.1 1995/08/31 14:59:56 cdaq
+* Initial revision
+*
+*--------------------------------------------------------
+ IMPLICIT NONE
+*
+ character*17 here
+ parameter (here= 'H_DC_EFF_SHUTDOWN')
+*
+ logical ABORT
+ character*(*) errmsg
+*
+ INCLUDE 'hms_data_structures.cmn'
+ INCLUDE 'gen_constants.par'
+ INCLUDE 'gen_units.par'
+ include 'hms_statistics.cmn'
+ include 'hms_tracking.cmn'
+
+ logical written_header
+
+ integer*4 lunout
+ integer*4 ind
+ real*4 num ! real version of #/events (aviod repeated floats)
+ save
+
+ written_header = .false.
+
+ num = float(max(1,hdc_tot_events))
+ do ind = 1 , hdc_num_planes
+ hdc_plane_eff(ind) = float(hdc_events(ind))/num
+ if (hdc_plane_eff(ind) .le. hdc_min_eff(ind) .and. num.ge.1000) then
+ if (.not.written_header) then
+ write(lunout,*)
+ write(lunout,'(a,f6.3)') ' HMS DC planes with low raw hit (hits/trig) efficiencies'
+ written_header = .true.
+ endif
+ write(lunout,'(5x,a,i2,a,f5.3,a,f5.3)') 'eff. for plane #',ind,' is ',
+ & hdc_plane_eff(ind),', warning level is ',hdc_min_eff(ind)
+ endif
+ enddo
+
+ do ind = 1 , hdc_num_chambers
+ hdc_cham_eff(ind) = float(hdc_cham_hits(ind))/num
+ enddo
+
+ return
+ end
diff --git a/HTRACKING/h_dc_trk_eff.f b/HTRACKING/h_dc_trk_eff.f
new file mode 100644
index 0000000..1627a06
--- /dev/null
+++ b/HTRACKING/h_dc_trk_eff.f
@@ -0,0 +1,80 @@
+ SUBROUTINE H_DC_TRK_EFF(ABORT,errmsg)
+*--------------------------------------------------------
+*-
+*- Purpose and Methods : Analyze DC information for each track
+*-
+*- Required Input BANKS HMS_STATISTICS
+*- GEN_DATA_STRUCTURES
+*-
+*- Output: ABORT - success or failure
+*- : err - reason for failure, if any
+*-
+* author: John Arrington
+* created: 9/5/95
+*
+* h_dc_trk_eff calculates efficiencies for the drift chambers,
+* using the tracking information.
+*
+* $Log: h_dc_trk_eff.f,v $
+* Revision 1.2 1996/01/17 18:19:40 cdaq
+* (JRA) Change array sizes from hdc_num_planes to HMAX_NUM_DC_PLANES
+*
+* Revision 1.1 1995/10/09 20:01:28 cdaq
+* Initial revision
+*
+*--------------------------------------------------------
+ IMPLICIT NONE
+*
+ character*12 here
+ parameter (here= 'H_DC_TRK_EFF')
+*
+ logical ABORT
+ character*(*) errmsg
+*
+ INCLUDE 'hms_data_structures.cmn'
+ INCLUDE 'gen_constants.par'
+ INCLUDE 'gen_units.par'
+ include 'hms_tracking.cmn'
+ include 'hms_geometry.cmn'
+
+ integer*4 pln,hit,ihit
+ integer*4 iwire(HMAX_NUM_DC_PLANES)
+ integer*4 ihitwire
+ real*4 hitwire
+ real*4 hitdist(HMAX_NUM_DC_PLANES)
+
+ save
+
+* find nearest wire, and increment 'should have fired' counter.
+ do pln=1,hdc_num_planes
+ hitwire = hdc_central_wire(pln) +
+ & (hsdc_track_coord(pln)+hdc_center(pln))/hdc_pitch(pln)
+ hitdist(pln) = (hitwire - nint(hitwire))*hdc_pitch(pln)
+
+ if (hdc_wire_counting(pln).eq.0) then !normal wire numbering.
+ ihitwire = nint(hitwire)
+ else !backwards numbering.
+ ihitwire = (hdc_nrwire(pln) + 1 ) - nint(hitwire)
+ endif
+ iwire(pln) = max(1,min(hdc_nrwire(pln),ihitwire))
+ if (ihitwire.ne.iwire(pln)) hitdist(pln)=99. !if had to reset wire,
+ !make it a 'miss'
+
+ if (abs(hitdist(pln)).le.0.3) then ! hit close to wire.
+ hdc_shouldhit(pln,iwire(pln)) = hdc_shouldhit(pln,iwire(pln)) + 1
+ endif
+ enddo
+
+* note, this does not look for hits on the track which were NOT in the space
+* point used to fit the track!
+
+ do ihit=2,hntrack_hits(hsnum_fptrack,1)+1
+ hit=hntrack_hits(hsnum_fptrack,ihit)
+ pln=hdc_plane_num(hit)
+ if (iwire(pln).eq.hdc_wire_num(hit) .and. abs(hitdist(pln)).le.0.3)then
+ hdc_didhit(pln,iwire(pln)) = hdc_didhit(pln,iwire(pln)) + 1
+ endif
+ enddo
+
+ return
+ end
diff --git a/HTRACKING/h_dc_trk_eff_shutdown.f b/HTRACKING/h_dc_trk_eff_shutdown.f
new file mode 100644
index 0000000..7c69ce7
--- /dev/null
+++ b/HTRACKING/h_dc_trk_eff_shutdown.f
@@ -0,0 +1,83 @@
+ SUBROUTINE H_DC_TRK_EFF_SHUTDOWN(lunout,ABORT,errmsg)
+*--------------------------------------------------------
+*-
+*- Purpose and Methods : Analyze and report drift chamber efficiencies.
+*-
+*- Required Input BANKS HMS_STATISTICS
+*- GEN_DATA_STRUCTURES
+*-
+*- Output: ABORT - success or failure
+*- : err - reason for failure, if any
+*-
+* author: John Arrington
+* created: 9/5/95
+*
+* h_dc_trk_eff calculates efficiencies for the chambers (using tracking)
+* h_dc_trk_eff_shutdown does some final manipulation of the numbers.
+*
+* $Log: h_dc_trk_eff_shutdown.f,v $
+* Revision 1.1 1995/10/09 20:04:23 cdaq
+* Initial revision
+*
+*
+*--------------------------------------------------------
+ IMPLICIT NONE
+*
+ character*21 here
+ parameter (here= 'H_DC_TRK_EFF_SHUTDOWN')
+*
+ logical ABORT
+ character*(*) errmsg
+*
+ INCLUDE 'hms_data_structures.cmn'
+ INCLUDE 'gen_constants.par'
+ INCLUDE 'gen_units.par'
+ include 'hms_tracking.cmn'
+ include 'hms_geometry.cmn'
+
+ logical written_header
+
+ logical was_already_dead
+ integer*4 lunout
+ integer*4 pln,wire
+ integer*4 ind
+ real*4 wireeff,planeeff
+ real*4 num ! real version of #/events (aviod repeated floats)
+ save
+
+ written_header = .false.
+
+ do pln = 1 , hdc_num_planes
+ hdc_didsum(pln)=0
+ hdc_shouldsum(pln)=0
+ do wire = 1 , hdc_nrwire(pln)
+ hdc_shouldsum(pln) = hdc_shouldsum(pln) + 1
+ hdc_didsum(pln) = hdc_didsum(pln) + 1
+ num = float(max(1,hdc_shouldhit(pln,wire)))
+ wireeff = float(hdc_didhit(pln,wire)) / num
+ if (num.gt.50 .and. wireeff.lt.hdc_min_wire_eff) then
+ was_already_dead = .false.
+ do ind=1,hdc_num_deadwires
+ if (pln .eq. hdc_deadwire_plane(ind) .and.
+ & wire .eq. hdc_deadwire_num(ind)) was_already_dead=.true.
+ enddo
+ if (.not.was_already_dead) write(lunout,111) ' HMS pln=',pln,
+ & ', wire=',wire,', effic=',wireeff,' = ',hdc_didhit(pln,wire),
+ & '/',hdc_shouldhit(pln,wire)
+ endif
+ enddo
+ enddo
+111 format (a,i3,a,i4,a,f4.2,a,i6,a,i6)
+
+ do pln = 1 , hdc_num_planes
+ planeeff=float(hdc_didsum(pln))/float(max(1,hdc_shouldsum(pln)))
+ if (hdc_shouldsum(pln).gt.1000 .and.
+ & planeeff.gt.hdc_min_plane_eff(pln)) then
+ write(lunout,112) 'ave. effic for plane',pln,' is ',
+ & planeeff,' = ',hdc_didsum(pln),'/',hdc_shouldsum(pln)
+ endif
+ enddo
+112 format (a,i3,a,f4.2,a,i7,a,i7)
+
+ return
+ end
diff --git a/HTRACKING/h_dpsifun.f b/HTRACKING/h_dpsifun.f
new file mode 100644
index 0000000..f228887
--- /dev/null
+++ b/HTRACKING/h_dpsifun.f
@@ -0,0 +1,62 @@
+ function H_DPSIFUN(ray,iplane)
+* this function calculates the psi coordinate of the intersection
+* of a ray (defined by ray) with a hms wire chamber plane. the geometry
+* of the plane is contained in the coeff array calculated in the
+* array hplane_coeff
+* Note it is call by MINUIT via H_FCNCHISQ and so uses double precision
+* variables
+*
+* the ray is defined by
+* x = (z-zt)*tan(xp) + xt
+* y = (z-zt)*tan(yp) + yt
+* at some fixed value of zt*
+* ray(1) = xt
+* ray(2) = yt
+* ray(3) = tan(xp)
+* ray(4) = tan(yp)
+*
+* d.f. geesaman 17 January 1994
+* $Log: h_dpsifun.f,v $
+* Revision 1.3 1995/05/22 19:39:08 cdaq
+* (SAW) Split gen_data_data_structures into gen, hms, sos, and coin parts"
+*
+* Revision 1.2 1994/02/21 03:11:25 cdaq
+* (SAW) remove dfloat call since arg and result both real*8
+*
+c Revision 1.1 1994/02/19 06:13:29 cdaq
+c Initial revision
+c
+*
+ implicit none
+ include "hms_data_structures.cmn"
+ include "hms_geometry.cmn"
+*
+* input
+ real*8 ray(4) ! xt,yt,xpt,ypt
+ integer*4 iplane ! plane number
+* output
+ real*8 H_DPSIFUN ! value of psi coordinate of hit of ray in plane
+*
+* local variables
+ real*8 denom,infinity,cinfinity
+ parameter (infinity = 1.0d20)
+ parameter (cinfinity = 1/infinity)
+*
+ H_DPSIFUN = ray(3)*ray(2)*(hplane_coeff(1,iplane))
+ & + ray(4)*ray(1)*(hplane_coeff(2,iplane))
+ & + ray(3)*(hplane_coeff(3,iplane))
+ & + ray(4)*(hplane_coeff(4,iplane))
+ & + ray(1)*(hplane_coeff(5,iplane))
+ & + ray(2)*(hplane_coeff(6,iplane))
+*
+ denom = ray(3)*(hplane_coeff(7,iplane))
+ & + ray(4)*(hplane_coeff(8,iplane))
+ & + (hplane_coeff(9,iplane))
+*
+ if(abs(denom).lt.cinfinity) then
+ H_DPSIFUN=infinity
+ else
+ H_DPSIFUN = H_DPSIFUN/denom
+ endif
+ return
+ end
diff --git a/HTRACKING/h_drift_dist_calc.f b/HTRACKING/h_drift_dist_calc.f
new file mode 100644
index 0000000..ef61457
--- /dev/null
+++ b/HTRACKING/h_drift_dist_calc.f
@@ -0,0 +1,73 @@
+ real*4 function h_drift_dist_calc(plane,wire,time)
+*
+* function to calculate hms drift time from tdc value in hms
+* wire chambers
+*
+* d.f. geesaman 17 feb 1994
+* $Log: h_drift_dist_calc.f,v $
+* Revision 1.7 1996/04/30 12:35:14 saw
+* (JRA) Add drift time correction for disc card
+*
+* Revision 1.6 1995/10/10 13:01:04 cdaq
+* (JRA) Remove check for zero drift bin size
+*
+* Revision 1.5 1995/05/22 19:39:09 cdaq
+* (SAW) Split gen_data_data_structures into gen, hms, sos, and coin parts"
+*
+* Revision 1.4 1994/11/22 20:03:46 cdaq
+* (SAW) Change fract to hfract. Make fractinterp a local variable
+*
+* Revision 1.3 1994/08/18 03:34:21 cdaq
+* (DJM) Use a lookup table to map fractional area to distance. (worked for
+* the prototype chamber). Lots of parameters but easier than fitting.
+* Could not use a single map for all 12 planes since drift time spectra a
+* very different.
+*
+* Revision 1.2 1994/07/27 19:00:07 cdaq
+* (DJM) map fractional area to distance. worked for the prototype chamber!
+* (DFG) Add two regions of drift (commented out)
+*
+* Revision 1.1 1994/02/19 06:13:44 cdaq
+* Initial revision
+*
+ implicit none
+ include 'hms_data_structures.cmn'
+ include 'hms_geometry.cmn'
+ include 'hms_tracking.cmn' ! for lookup tables
+*
+* input
+*
+ integer*4 plane ! plane number of hit
+ integer*4 wire ! wire number of hit
+ integer*4 ilo,ihi ! interpolate between bins ilo and ilo+1
+ real*4 time ! drift time in ns
+ real*4 fractinterp ! interpolated fraction
+*
+* output
+*
+
+* look in the appropriate drift time to distance table and perform a linear
+* interpolation. minimum and maximum distance values are 0.0cm and 0.5cm.
+c if( hdriftbinsz.eq.0.0)then
+c fractinterp = -1.0
+c h_drift_dist_calc = 0.5*fractinterp
+c return
+c endif
+ ilo = int((time-hdrift1stbin)/hdriftbinsz) + 1
+ ihi = ilo + 1
+ if( ilo.ge.1 .and. ihi.le.hdriftbins)then
+ fractinterp = hfract(ilo,plane) +
+ & ( (hfract(ilo+1,plane)-hfract(ilo,plane))/hdriftbinsz )*
+ & (time - hdrift1stbin - (ilo-1)*hdriftbinsz)
+ else
+ if( ilo.lt.1 )then
+ fractinterp = 0.0
+ else
+ if( ihi.gt.hdriftbins )fractinterp = 1.0
+ endif
+ endif
+ h_drift_dist_calc = 0.5*fractinterp -
+ $ hdc_card_delay(hdc_card_no(wire,plane))
+
+ return
+ end
diff --git a/HTRACKING/h_drift_time_calc.f b/HTRACKING/h_drift_time_calc.f
new file mode 100644
index 0000000..6900db8
--- /dev/null
+++ b/HTRACKING/h_drift_time_calc.f
@@ -0,0 +1,45 @@
+ function h_drift_time_calc(plane,wire,tdc)
+*
+* function to calculate hms drift time from tdc value in hms
+* wire chambers
+*
+* d.f. geesaman 17 feb 1994
+* $Log: h_drift_time_calc.f,v $
+* Revision 1.5 1995/10/09 20:16:02 cdaq
+* (JRA) Remove monte carlo data option
+*
+* Revision 1.4 1995/05/22 19:39:09 cdaq
+* (SAW) Split gen_data_data_structures into gen, hms, sos, and coin parts"
+*
+* Revision 1.3 1994/10/11 21:07:05 cdaq
+* (JRA) Replace simple functions with existing ctp variables
+*
+* Revision 1.2 1994/03/24 18:51:52 cdaq
+* (DFG) Allow switch for monte carlo data
+*
+* Revision 1.1 1994/02/19 06:14:04 cdaq
+* Initial revision
+*
+*
+*
+ implicit none
+ include "hms_data_structures.cmn"
+ include "hms_tracking.cmn"
+ include "hms_geometry.cmn"
+*
+* input
+*
+ integer*4 plane ! plane number of hit
+ integer*4 wire ! wire number of hit
+ integer*4 tdc ! tdc value
+*
+* output
+*
+ real*4 h_drift_time_calc ! drift time in nanoseconds
+*
+ h_drift_time_calc = hstart_time
+ & - float(tdc)*hdc_tdc_time_per_channel
+ & + hdc_plane_time_zero(plane)
+ return
+ end
+
diff --git a/HTRACKING/h_dump_cal.f b/HTRACKING/h_dump_cal.f
new file mode 100644
index 0000000..7028b57
--- /dev/null
+++ b/HTRACKING/h_dump_cal.f
@@ -0,0 +1,73 @@
+ SUBROUTINE H_DUMP_CAL(ABORT,errmsg)
+*--------------------------------------------------------
+*-
+*- Purpose and Methods : Analyze scintillator information for each track
+*-
+*- Required Input BANKS HMS_CALORIMETER
+*- GEN_DATA_STRUCTURES
+*-
+*- Output: ABORT - success or failure
+*- : err - reason for failure, if any
+*-
+* author: John Arrington
+* created: 9/7/95
+*
+* h_dump_cal writes out the raw calorimeterinformation for the final tracks.
+* This data is analyzed by independent routines to fit the gains for each
+* block.
+*
+* $Log: h_dump_cal.f,v $
+* Revision 1.4 1999/06/10 16:48:04 csa
+* (JRA) Added ycal, emeas calculations
+*
+* Revision 1.3 1998/12/17 22:02:38 saw
+* Support extra set of tubes on HMS shower counter
+*
+* Revision 1.2 1996/01/17 18:17:47 cdaq
+* (SAW) Remove extra () pair around implied do loop in write statement
+*
+* Revision 1.1 1995/10/09 20:16:45 cdaq
+* Initial revision
+*
+*--------------------------------------------------------
+ IMPLICIT NONE
+*
+ character*10 here
+ parameter (here= 'H_DUMP_CAL')
+*
+ logical ABORT
+ character*(*) errmsg
+*
+ INCLUDE 'hms_data_structures.cmn'
+ include 'hms_calorimeter.cmn'
+
+ integer*4 blk
+ real*4 emeas,ycal
+
+ save
+
+*
+* Write out cal fitting data.
+*
+* What should this do for new tubes?
+*
+ if (abs(hsdelta).le.10 .and. hcer_npe_sum.gt.2) then
+
+! this correction comes from h_corect_cal_pos(neg).f
+
+ ycal=hsy_fp + hcal_1pr_zpos*hsyp_fp
+ ycal=min(35.,ycal)
+ ycal=max(-35.,ycal)
+ emeas=hsp*exp(ycal/165.4)/(1+ycal**2/50000.)
+
+ write(35,'(1x,52(1x,f6.1),1x,e11.4)')
+ & (hcal_realadc_pos(blk),blk=1,hmax_cal_blocks),emeas
+
+! if(hcal_num_neg_columns.gt.0) then
+! write(35,'(1x,52(1x,f6.1),1x,e11.4)')
+! & (hcal_realadc_neg(blk),blk=1,hmax_cal_blocks),hsp
+! endif
+ endif
+
+ RETURN
+ END
diff --git a/HTRACKING/h_dump_peds.f b/HTRACKING/h_dump_peds.f
new file mode 100644
index 0000000..0d3ab6d
--- /dev/null
+++ b/HTRACKING/h_dump_peds.f
@@ -0,0 +1,181 @@
+ subroutine h_dump_peds(ABORT,err)
+*
+* $Log: h_dump_peds.f,v $
+* Revision 1.7.24.1 2007/09/13 04:02:18 brash
+* Implement some minor changes to fix Mac OS X runtime errors ... ejb
+*
+* Revision 1.7 2002/12/20 21:53:34 jones
+* Modified by Hamlet for new HMS aerogel
+*
+* Revision 1.7 2002/09/26
+* (Hamlet) Add HMS aerogel detector
+*
+* Revision 1.6 1998/12/17 22:02:38 saw
+* Support extra set of tubes on HMS shower counter
+*
+* Revision 1.5 1996/04/30 12:35:35 saw
+* (JRA) Cleanup
+*
+* Revision 1.4 1996/01/24 15:57:06 saw
+* (JRA) Remove MISC pedestals
+*
+* Revision 1.3 1996/01/16 21:47:10 cdaq
+* (JRA)
+*
+* Revision 1.2 1995/10/09 20:18:06 cdaq
+* (JRA) Cleanup, add cerenkov pedestals
+*
+* Revision 1.1 1995/08/31 14:57:50 cdaq
+* Initial revision
+*
+*
+ implicit none
+ save
+*
+ character*11 here
+ parameter (here='h_dump_peds')
+*
+ logical ABORT
+ character*(*) err
+*
+ integer*4 pln,cnt
+ integer*4 blk
+ integer*4 pmt
+ character*132 file
+
+ integer SPAREID
+ parameter (SPAREID=67)
+*
+ INCLUDE 'hms_data_structures.cmn'
+ INCLUDE 'hms_pedestals.cmn'
+ INCLUDE 'hms_scin_parms.cmn'
+ INCLUDE 'hms_calorimeter.cmn'
+ INCLUDE 'hms_cer_parms.cmn'
+ INCLUDE 'hms_aero_parms.cmn'
+ INCLUDE 'hms_filenames.cmn'
+ INCLUDE 'gen_run_info.cmn'
+
+
+ if (h_pedestal_output_filename.ne.' ') then
+ file=h_pedestal_output_filename
+ call g_sub_run_number(file, gen_run_number)
+ open(unit=SPAREID,file=file,status='unknown')
+ else
+ return
+ endif
+
+ write(SPAREID,*) 'These are the values that were used for the analysis'
+ write(SPAREID,*) ' (from the param file or pedestal events)'
+ write(SPAREID,*)
+*
+*
+* HODOSCOPE PEDESTALS
+*
+ write(SPAREID,*) 'hscin_all_ped_pos ='
+ do cnt = 1 , hnum_scin_elements
+ write(SPAREID,111) (hscin_all_ped_pos(pln,cnt),pln=1,4)
+ enddo
+ write(SPAREID,*) 'hhodo_new_ped_pos ='
+ do cnt = 1 , hnum_scin_elements
+ write(SPAREID,111) (hhodo_new_ped_pos(pln,cnt),pln=1,4)
+ enddo
+ write(SPAREID,*) 'hhodo_new_sig_pos ='
+ do cnt = 1 , hnum_scin_elements
+ write(SPAREID,111) (hhodo_new_sig_pos(pln,cnt),pln=1,4)
+ enddo
+ write(SPAREID,*) 'hhodo_new_threshold_pos ='
+ do cnt = 1 , hnum_scin_elements
+ write(SPAREID,111) (hhodo_new_threshold_pos(pln,cnt),pln=1,4)
+ enddo
+ write(SPAREID,*) 'hscin_all_ped_neg ='
+ do cnt = 1 , hnum_scin_elements
+ write(SPAREID,111) (hscin_all_ped_neg(pln,cnt),pln=1,4)
+ enddo
+ write(SPAREID,*) 'hhodo_new_ped_neg ='
+ do cnt = 1 , hnum_scin_elements
+ write(SPAREID,111) (hhodo_new_ped_neg(pln,cnt),pln=1,4)
+ enddo
+ write(SPAREID,*) 'hhodo_new_sig_neg ='
+ do cnt = 1 , hnum_scin_elements
+ write(SPAREID,111) (hhodo_new_sig_neg(pln,cnt),pln=1,4)
+ enddo
+ write(SPAREID,*) 'hhodo_new_threshold_neg ='
+ do cnt = 1 , hnum_scin_elements
+ write(SPAREID,111) (hhodo_new_threshold_neg(pln,cnt),pln=1,4)
+ enddo
+
+111 format (10x,3(f6.1,','),f6.1)
+*
+*
+* CALORIMETER PEDESTALS ( Hamlet test version)
+*
+ write(SPAREID,*) ' hcal_pos_ped_mean = '
+ write(SPAREID,112) (hcal_pos_ped_mean(blk),blk=1,hmax_cal_rows)
+ write(SPAREID,112) (hcal_pos_ped_mean(blk),blk=hmax_cal_rows+1,2*hmax_cal_rows)
+ write(SPAREID,112) (hcal_pos_ped_mean(blk),blk=2*hmax_cal_rows+1,3*hmax_cal_rows)
+ write(SPAREID,112) (hcal_pos_ped_mean(blk),blk=3*hmax_cal_rows+1,4*hmax_cal_rows)
+ write(SPAREID,*) '; calorimeter ped. sigma (sqrt(variance))'
+ write(SPAREID,*) ' hcal_pos_ped_rms = '
+ write(SPAREID,112) (hcal_pos_ped_rms(blk),blk=1,hmax_cal_rows)
+ write(SPAREID,112) (hcal_pos_ped_rms(blk),blk=hmax_cal_rows+1,2*hmax_cal_rows)
+ write(SPAREID,112) (hcal_pos_ped_rms(blk),blk=2*hmax_cal_rows+1,3*hmax_cal_rows)
+ write(SPAREID,112) (hcal_pos_ped_rms(blk),blk=3*hmax_cal_rows+1,4*hmax_cal_rows)
+ write(SPAREID,*) '; calorimeter threshold above ped. =MIN(50,MAX(10,3*sigma))'
+ write(SPAREID,*) 'hcal_new_threshold_pos = '
+ write(SPAREID,112) (hcal_new_adc_threshold_pos(blk),blk=1,hmax_cal_rows)
+ write(SPAREID,112) (hcal_new_adc_threshold_pos(blk),blk=hmax_cal_rows+1,2*hmax_cal_rows)
+ write(SPAREID,112) (hcal_new_adc_threshold_pos(blk),blk=2*hmax_cal_rows+1,3*hmax_cal_rows)
+ write(SPAREID,112) (hcal_new_adc_threshold_pos(blk),blk=3*hmax_cal_rows+1,4*hmax_cal_rows)
+*
+ write(SPAREID,*) ' hcal_neg_ped_mean = '
+ write(SPAREID,112) (hcal_neg_ped_mean(blk),blk=1,hmax_cal_rows)
+ write(SPAREID,112) (hcal_neg_ped_mean(blk),blk=hmax_cal_rows+1,2*hmax_cal_rows)
+ write(SPAREID,112) (hcal_neg_ped_mean(blk),blk=2*hmax_cal_rows+1,3*hmax_cal_rows)
+ write(SPAREID,112) (hcal_neg_ped_mean(blk),blk=3*hmax_cal_rows+1,4*hmax_cal_rows)
+ write(SPAREID,*) '; calorimeter ped. sigma (sqrt(variance))'
+ write(SPAREID,*) ' hcal_ped_neg_rms = '
+ write(SPAREID,112) (hcal_neg_ped_rms(blk),blk=1,hmax_cal_rows)
+ write(SPAREID,112) (hcal_neg_ped_rms(blk),blk=hmax_cal_rows+1,2*hmax_cal_rows)
+ write(SPAREID,112) (hcal_neg_ped_rms(blk),blk=2*hmax_cal_rows+1,3*hmax_cal_rows)
+ write(SPAREID,112) (hcal_neg_ped_rms(blk),blk=3*hmax_cal_rows+1,4*hmax_cal_rows)
+ write(SPAREID,*) '; calorimeter threshold above ped. =MIN(50,MAX(10,3*sigma))'
+ write(SPAREID,*) 'hcal_new_threshold_neg = '
+ write(SPAREID,112) (hcal_new_adc_threshold_neg(blk),blk=1,hmax_cal_rows)
+ write(SPAREID,112) (hcal_new_adc_threshold_neg(blk),blk=hmax_cal_rows+1,2*hmax_cal_rows)
+ write(SPAREID,112) (hcal_new_adc_threshold_neg(blk),blk=2*hmax_cal_rows+1,3*hmax_cal_rows)
+ write(SPAREID,112) (hcal_new_adc_threshold_neg(blk),blk=3*hmax_cal_rows+1,4*hmax_cal_rows)
+***
+112 format (12(f5.1,','),f5.1)
+
+*
+*
+* GAS CERENKOV PEDESTALS
+*
+ write(SPAREID,*) 'hcer_ped = '
+ write(SPAREID,113) (hcer_ped(pmt),pmt=1,hmax_cer_hits)
+113 format (i6,',',i6)
+
+*
+*
+* HAERO PEDESTALS
+*
+ write(SPAREID,*)' '
+ write(SPAREID,*) 'haero_pos_ped_mean = '
+ write(SPAREID,114) (haero_pos_ped_mean(pmt), pmt=1,HMAX_AERO_HITS)
+ write(SPAREID,*) 'haero_neg_ped_mean = '
+ write(SPAREID,114) (haero_neg_ped_mean(pmt), pmt=1,HMAX_AERO_HITS)
+*
+ write(SPAREID,*)' '
+ write(SPAREID,*) 'haero_pos_ped_rms = '
+ write(SPAREID,114) (haero_pos_ped_rms(pmt), pmt=1,HMAX_AERO_HITS)
+ write(SPAREID,*) 'haero_neg_ped_rms = '
+ write(SPAREID,114) (haero_neg_ped_rms(pmt), pmt=1,HMAX_AERO_HITS)
+*
+114 format (8(f6.1,', '))
+
+
+*
+ close(SPAREID)
+
+ return
+ end
diff --git a/HTRACKING/h_dump_tof.f b/HTRACKING/h_dump_tof.f
new file mode 100644
index 0000000..ce2076f
--- /dev/null
+++ b/HTRACKING/h_dump_tof.f
@@ -0,0 +1,103 @@
+ SUBROUTINE H_DUMP_TOF(ABORT,errmsg)
+*--------------------------------------------------------
+*-
+*- Purpose and Methods : Analyze scintillator information for each track
+*-
+*- Required Input BANKS HMS_SCIN_TOF
+*- GEN_DATA_STRUCTURES
+*-
+*- Output: ABORT - success or failure
+*- : err - reason for failure, if any
+*-
+* author: John Arrington
+* created: 1/30/95
+*
+* h_dump_tof writes out the raw timing information for the final chosen tracks.
+* This data is analyzed by independent routines to fit the corrections for
+* pulse height walk, time lag from the hit to the pmt signal, and time offsets
+* for each signal.
+*
+* $Log: h_dump_tof.f,v $
+* Revision 1.7.24.1 2008/01/08 22:59:42 cdaq
+* removed cut on Cerenkov
+*
+* Revision 1.7 1999/11/04 20:36:01 saw
+* Linux/G77 compatibility fixes
+*
+* Revision 1.6 1999/06/10 16:49:09 csa
+* (JRA) Added test on hcer_npe_sum, changed output formats
+*
+* Revision 1.5 1999/02/10 18:20:08 csa
+* Fixed format problem with ph > 10,000
+*
+* Revision 1.4 1995/10/09 20:20:00 cdaq
+* (JRA) Subtract hstart_time from tdc output
+*
+* Revision 1.3 1995/05/22 19:39:09 cdaq
+* (SAW) Split gen_data_data_structures into gen, hms, sos, and coin parts"
+*
+* Revision 1.2 1995/05/11 19:03:50 cdaq
+* (JRA) Formatting changes
+*
+* Revision 1.1 1995/01/31 21:34:03 cdaq
+* Initial revision
+*
+*--------------------------------------------------------
+ IMPLICIT NONE
+*
+ character*50 here
+ parameter (here= 'H_DUMP_TOF')
+*
+ logical ABORT
+ character*(*) errmsg
+*
+ INCLUDE 'hms_data_structures.cmn'
+ INCLUDE 'gen_constants.par'
+ INCLUDE 'gen_units.par'
+ include 'hms_scin_parms.cmn'
+ include 'hms_scin_tof.cmn'
+ integer*4 hit, ind
+ integer*4 pmt,cnt,lay,dir
+ real*4 ph,tim,betap
+ save
+*
+* Write out TOF fitting data.
+*
+
+* In some circumstances you might also cut on
+* hcer_npe_sum and/or hsshtrk:
+ if (hsnum_pmt_hit.ge.4 .and. hsnum_pmt_hit.le.12) then
+
+* .and. hcer_npe_sum.gt.2) then
+
+ betap=1.
+ write(37,111) hsnum_pmt_hit,hsx_fp,hsxp_fp,
+ $ hsy_fp,hsyp_fp,betap
+ 111 format(i3,1x,f10.5,1x,f9.5,1x,f10.5,1x,f9.5,1x,f7.3)
+ do ind = 1, hsnum_scin_hit
+ hit = hscin_hit(hsnum_fptrack,ind)
+ if (hscin_tdc_pos(hit) .ge. hscin_tdc_min .and.
+ 1 hscin_tdc_pos(hit) .le. hscin_tdc_max) then
+ cnt=hscin_counter_num(hit)
+ lay=int((hscin_plane_num(hit)+1)/2)
+ dir=mod(hscin_plane_num(hit)+1,2)+1
+ pmt=1
+ tim=hscin_tdc_pos(hit)*hscin_tdc_to_time-hstart_time
+ ph=hscin_adc_pos(hit)
+ write(37,112) pmt,cnt,lay,dir,ph,tim
+ endif
+ if (hscin_tdc_neg(hit) .ge. hscin_tdc_min .and.
+ 1 hscin_tdc_neg(hit) .le. hscin_tdc_max) then
+ cnt=hscin_counter_num(hit)
+ lay=int((hscin_plane_num(hit)+1)/2)
+ dir=mod(hscin_plane_num(hit)+1,2)+1
+ pmt=2
+ tim=hscin_tdc_neg(hit)*hscin_tdc_to_time-hstart_time
+ ph=hscin_adc_neg(hit)
+ write(37,112) pmt,cnt,lay,dir,ph,tim
+ endif
+ enddo
+ 112 format(i2,1x,i3,2(1x,i2),1x,f7.1,1x,f8.3)
+ endif
+ RETURN
+ END
diff --git a/HTRACKING/h_fcnchisq.f b/HTRACKING/h_fcnchisq.f
new file mode 100644
index 0000000..729ddba
--- /dev/null
+++ b/HTRACKING/h_fcnchisq.f
@@ -0,0 +1,44 @@
+ subroutine H_FCNCHISQ(npar,grad,fval,ray,iflag,dumarg)
+* This subroutine calculates chi**2 for MINUIT for HMS. The
+* arguments are determined by MINUIT
+*
+* d.f. geesaman 17 January 1994
+* $Log: h_fcnchisq.f,v $
+* Revision 1.3 1995/05/22 19:39:10 cdaq
+* (SAW) Split gen_data_data_structures into gen, hms, sos, and coin parts"
+*
+* Revision 1.2 1994/04/13 20:38:06 cdaq
+* (SAW) Change name of dummy arg to dumarg
+*
+* Revision 1.1 1994/02/19 06:14:15 cdaq
+* Initial revision
+*
+*
+ implicit none
+ external H_DPSIFUN
+ real*8 H_DPSIFUN
+ include "hms_data_structures.cmn"
+ include "hms_tracking.cmn"
+ include "hms_geometry.cmn"
+*
+* input
+ real*8 ray(*),grad(*),dumarg
+ integer*4 npar,iflag
+* output
+ real*8 fval ! value of chi2
+*
+* local variables
+ real*8 diff
+ integer*4 ihit
+ integer*4 hitnum,planenum
+
+ fval=0.0d0
+ do ihit=1,HNTRACK_HITS(htrack_fit_num,1)
+ hitnum=HNTRACK_HITS(htrack_fit_num,ihit+1)
+ planenum=HDC_PLANE_NUM(hitnum)
+ diff=(dble(HDC_WIRE_COORD(hitnum))-H_DPSIFUN(ray,planenum))
+ & /dble(hdc_sigma(planenum))
+ fval=fval+diff*diff
+ enddo
+ return
+ end
diff --git a/HTRACKING/h_fill_aero_raw_hist.f b/HTRACKING/h_fill_aero_raw_hist.f
new file mode 100644
index 0000000..f8ede6d
--- /dev/null
+++ b/HTRACKING/h_fill_aero_raw_hist.f
@@ -0,0 +1,70 @@
+ subroutine h_fill_aero_raw_hist(Abort,err)
+*
+* routine to fill aerogel raw data histograms and hit pattern
+*
+* Revision 1.0 2002/10/05 (Hamlet)
+* Initial version
+*
+*
+*--------------------------------------------------------
+ IMPLICIT NONE
+*
+ external thgetid
+ integer*4 thgetid
+ character*20 here
+ parameter (here='h_fill_aero_raw_hist')
+*
+ logical ABORT
+ character*(*) err
+
+ real*4 histval
+ integer*4 ind
+
+
+ include 'hms_data_structures.cmn'
+ include 'hms_aero_parms.cmn'
+ include 'hms_pedestals.cmn'
+ include 'hms_id_histid.cmn'
+*
+ SAVE
+*--------------------------------------------------------
+*
+ ABORT= .FALSE.
+ err= ' '
+
+* Make sure there is at least 1 hit
+ if(hmax_aero_hits .LT. 1 ) then
+ return
+ endif
+* Loop over all PMT's
+
+* if(haero_tot_hits .gt. 0 ) then
+ do ind=1,HNUM_AERO_BLOCKS
+
+* Fill ADC hits
+
+ if(haero_pos_npe(ind).gt.0.1) then
+ histval=float(ind)
+ call hf1(hidhaero_adc_pos_hits,histval,1.)
+ endif
+
+ if(haero_neg_npe(ind).gt.0.1) then
+ histval=float(ind)
+ call hf1(hidhaero_adc_neg_hits,histval,1.)
+ endif
+
+* Fill TDC hits
+
+ if(haero_rawtdc_pos(ind).gt.0.and.haero_rawtdc_pos(ind).le.8000.) then
+ histval=float(ind)
+ call hf1(hidhaero_tdc_pos_hits,histval,1.)
+ endif
+
+ if(haero_rawtdc_neg(ind).gt.0.and.haero_rawtdc_neg(ind).le.8000.) then
+ histval=float(ind)
+ call hf1(hidhaero_tdc_neg_hits,histval,1.)
+ endif
+ enddo
+
+ return
+ end
diff --git a/HTRACKING/h_fill_cal_hist.f b/HTRACKING/h_fill_cal_hist.f
new file mode 100644
index 0000000..44a63d4
--- /dev/null
+++ b/HTRACKING/h_fill_cal_hist.f
@@ -0,0 +1,78 @@
+ subroutine h_fill_cal_hist(Abort,err)
+*
+* routine to fill histograms with hms_cal varibles
+*
+* Author: J. R. Arrington
+* Date: 26 April 1995
+* Copied from: h_fill_scin_raw_hist
+*
+*
+* $Log: h_fill_cal_hist.f,v $
+* Revision 1.9 2002/10/02 13:42:43 saw
+* Check that user hists are defined before filling
+*
+* Revision 1.8 1999/02/23 18:37:20 csa
+* (JRA) Remove obsolete hf1 call
+*
+* Revision 1.7 1999/02/03 21:13:23 saw
+* Code for new Shower counter tubes
+*
+* Revision 1.6 1999/01/27 16:02:39 saw
+* Check if some hists are defined before filling
+*
+* Revision 1.5 1998/12/17 22:02:39 saw
+* Support extra set of tubes on HMS shower counter
+*
+* Revision 1.4 1995/08/31 15:01:15 cdaq
+* (JRA) Move hidcalsumadc filling to h_sparsify_cal
+*
+* Revision 1.3 1995/07/19 18:12:18 cdaq
+* (JRA) Add calorimeter adc sum per hit histogram
+*
+* Revision 1.2 1995/05/22 19:39:10 cdaq
+* (SAW) Split gen_data_data_structures into gen, hms, sos, and coin parts"
+*
+* Revision 1.1 1995/04/27 20:41:13 cdaq
+* Initial revision
+*
+*--------------------------------------------------------
+ IMPLICIT NONE
+*
+ external thgetid
+ integer*4 thgetid
+ character*50 here
+ parameter (here= 'h_fill_cal_hist')
+*
+ logical ABORT
+ character*(*) err
+ real*4 histval
+ integer*4 row,col,ihit
+ include 'hms_data_structures.cmn'
+ include 'hms_id_histid.cmn'
+ include 'hms_calorimeter.cmn'
+*
+ SAVE
+*--------------------------------------------------------
+*
+ ABORT= .FALSE.
+ err= ' '
+*
+* Light in either tube will do
+*
+ if(hcal_num_hits .gt. 0 ) then
+ do ihit=1,hcal_num_hits
+ row=hcal_rows(ihit)
+ col=hcal_cols(ihit)
+ histval=float(col)
+ if(hidcalplane.gt.0) call hf1(hidcalplane,histval,1.)
+ histval=float(row)
+ if(hcal_adcs_pos(ihit).gt.0.1.and.hidcalposhits(col).gt.0)
+ $ call hf1(hidcalposhits(col),histval,1.)
+ if(hcal_adcs_neg(ihit).gt.0.1.and.hidcalneghits(col).gt.0)
+ $ call hf1(hidcalneghits(col),histval,1.)
+ enddo
+ endif
+
+ return
+ end
+
diff --git a/HTRACKING/h_fill_dc_dec_hist.f b/HTRACKING/h_fill_dc_dec_hist.f
new file mode 100644
index 0000000..9376d4e
--- /dev/null
+++ b/HTRACKING/h_fill_dc_dec_hist.f
@@ -0,0 +1,74 @@
+ subroutine h_fill_dc_dec_hist(Abort,err)
+*
+* routine to fill histograms with hms_decoded_dc varibles
+* In the future ID numbers are stored in hms_histid
+*
+* Author: D. F. Geesaman
+* Date: 30 March 1994
+* Modified: 9 April 1994 D. F. Geesaman
+* Put id's in hms_tracking_histid
+* implement flag to turn block off
+* $Log: h_fill_dc_dec_hist.f,v $
+* Revision 1.6 2002/10/02 13:42:43 saw
+* Check that user hists are defined before filling
+*
+* Revision 1.5 1996/04/30 12:36:43 saw
+* (JRA) Comment out HDC_DRIFT_DIS and HDC_DRIFT_TIME histograms
+*
+* Revision 1.4 1995/08/31 15:02:26 cdaq
+* (JRA) Comment out filling of hiddcwirecent (wire center) histogram
+*
+* Revision 1.3 1995/05/22 19:39:11 cdaq
+* (SAW) Split gen_data_data_structures into gen, hms, sos, and coin parts"
+*
+* Revision 1.2 1994/08/18 04:26:03 cdaq
+* (SAW) Indentation changes
+*
+* Revision 1.1 1994/04/13 15:38:24 cdaq
+* Initial revision
+*
+*-
+*--------------------------------------------------------
+ IMPLICIT NONE
+*
+ character*50 here
+ parameter (here= 'h_fill_dc_dec_hist_')
+*
+ logical ABORT
+ character*(*) err
+ real*4 histval
+ integer*4 planeoff,ihit
+*
+ include 'hms_data_structures.cmn'
+ include 'hms_tracking.cmn'
+ include 'hms_track_histid.cmn'
+ include 'gen_event_info.cmn'
+*
+ SAVE
+*--------------------------------------------------------
+*
+ ABORT= .FALSE.
+ err= ' '
+*
+* Is histogramming flag set
+ if(hturnon_decoded_dc_hist.ne.0) then
+* Make sure there is at least 1 hit
+ if(HDC_TOT_HITS .gt. 0 ) then
+* Loop over all hits
+ do ihit=1,HDC_TOT_HITS
+ planeoff=HDC_PLANE_NUM(ihit)
+ histval=HDC_WIRE_NUM(ihit)
+* Is plane number valid
+ if( (planeoff .gt. 0) .and. (planeoff.le. hdc_num_planes)
+ $ .and. hiddcwiremap(planeoff).gt.0) then
+ call hf1(hiddcwiremap(planeoff),histval,1.)
+c call hf1(hiddcwirecent(planeoff),HDC_WIRE_CENTER(ihit),1.)
+c call hf1(hiddcdriftdis(planeoff),HDC_DRIFT_DIS(ihit),1.)
+c call hf1(hiddcdrifttime(planeoff),HDC_DRIFT_TIME(ihit),1.)
+ endif ! end test on valid plane number
+ enddo ! end loop over hits
+ endif ! end test on zero hits
+ endif ! end test on histogram block turned on.
+ RETURN
+ END
+
diff --git a/HTRACKING/h_fill_dc_fp_hist.f b/HTRACKING/h_fill_dc_fp_hist.f
new file mode 100644
index 0000000..fb0648a
--- /dev/null
+++ b/HTRACKING/h_fill_dc_fp_hist.f
@@ -0,0 +1,83 @@
+ subroutine h_fill_dc_fp_hist(Abort,err)
+*
+* routine to fill histograms with hms_focal_plane varibles
+*
+* Author: D. F. Geesaman
+* Date: 30 March 1994
+* Modified: 9 April 1994 DFG
+* Transfer ID in common block
+* Implement flag to turn block on
+* $Log: h_fill_dc_fp_hist.f,v $
+* Revision 1.5 1995/05/22 19:39:11 cdaq
+* (SAW) Split gen_data_data_structures into gen, hms, sos, and coin parts"
+*
+* Revision 1.4 1995/04/06 19:27:11 cdaq
+* (JRA) Rename residuals variables
+*
+* Revision 1.3 1994/08/18 03:13:08 cdaq
+* (SAW) Use arrays of histids for residuals
+*
+* Revision 1.2 1994/08/18 02:35:36 cdaq
+* (DA) Add histograms for residuals
+*
+* Revision 1.1 1994/04/13 15:38:48 cdaq
+* Initial revision
+*
+*-
+*--------------------------------------------------------
+ IMPLICIT NONE
+*
+ character*50 here
+ parameter (here= 'h_fill_dc_fp_hist')
+*
+ include 'hms_data_structures.cmn'
+ include 'hms_track_histid.cmn'
+ include 'hms_tracking.cmn'
+*
+ logical ABORT
+ character*(*) err
+ real*4 histval
+ integer*4 itrk
+ integer*4 plane
+*
+ SAVE
+*--------------------------------------------------------
+*
+ ABORT= .FALSE.
+ err= ' '
+*
+* Is this histogram flag turned on
+ if(hturnon_focal_plane_hist .ne. 0 ) then
+* Make sure there is at least 1 track
+ if(HNTRACKS_FP .gt. 0 ) then
+* Loop over all hits
+ do itrk=1,HNTRACKS_FP
+ call hf1(hidhx_fp,HX_FP(itrk),1.)
+ call hf1(hidhy_fp,HY_FP(itrk),1.)
+ call hf1(hidhxp_fp,HXP_FP(itrk),1.)
+ call hf1(hidhyp_fp,HYP_FP(itrk),1.)
+ if(HCHI2_FP(itrk) .gt. 0 ) then
+ histval=log10(HCHI2_FP(itrk))
+ else
+ histval = 10.
+ endif
+ call hf1(hidhlogchi2_fp,histval,1.)
+ histval= HNFREE_FP(itrk)
+ call hf1(hidhnfree_fp,histval,1.)
+ if( HNFREE_FP(itrk) .ne.0) then
+ histval= HCHI2_FP(itrk) / HNFREE_FP(itrk)
+ else
+ histval = -1.
+ endif
+ call hf1(hidhchi2perdeg_fp,histval,1.)
+*
+ do plane = 1,hdc_num_planes
+ call hf1(hidres_fp(plane),hdc_double_residual(itrk,plane),1.)
+ call hf1(hidsingres_fp(plane),hdc_single_residual(itrk,plane),1.)
+ enddo
+
+ enddo ! end loop over hits
+ endif ! end test on zero hits
+ endif ! end test on histogramming flag
+ RETURN
+ END
diff --git a/HTRACKING/h_fill_dc_target_hist.f b/HTRACKING/h_fill_dc_target_hist.f
new file mode 100644
index 0000000..023148c
--- /dev/null
+++ b/HTRACKING/h_fill_dc_target_hist.f
@@ -0,0 +1,55 @@
+ subroutine h_fill_dc_target_hist(Abort,err)
+*
+* routine to fill histograms with HMS_TARGET varibles
+*
+* Author: D. F. Geesaman
+* Date: 3 May 1994
+* $Log: h_fill_dc_target_hist.f,v $
+* Revision 1.3 1995/05/22 19:39:11 cdaq
+* (SAW) Split gen_data_data_structures into gen, hms, sos, and coin parts"
+*
+* Revision 1.2 1994/08/18 04:28:53 cdaq
+* (SAW) Indentation changes
+*
+* Revision 1.1 1994/05/12 19:02:40 cdaq
+* Initial revision
+*
+*-
+*--------------------------------------------------------
+ IMPLICIT NONE
+*
+ character*50 here
+ parameter (here= 'h_fill_dc_target_hist')
+*
+ logical ABORT
+ character*(*) err
+ real*4 histval
+ integer*4 itrk
+
+*
+ include 'hms_data_structures.cmn'
+ include 'hms_track_histid.cmn'
+*
+ SAVE
+*--------------------------------------------------------
+*
+ ABORT= .FALSE.
+ err= ' '
+*
+* Make sure there is at least 1 track
+ if(HNTRACKS_FP .gt. 0 ) then
+* Loop over all hits
+ do itrk=1,HNTRACKS_FP
+ call hf1(hidhx_tar,HX_TAR(itrk),1.)
+ call hf1(hidhy_tar,HY_TAR(itrk),1.)
+ call hf1(hidhz_tar,HZ_TAR(itrk),1.)
+ call hf1(hidhxp_tar,HXP_TAR(itrk),1.)
+ call hf1(hidhyp_tar,HYP_TAR(itrk),1.)
+ call hf1(hidhdelta_tar,HDELTA_TAR(itrk),1.)
+ call hf1(hidhp_tar,HP_TAR(itrk),1.)
+*
+*
+ enddo ! end loop over hits
+ endif ! end test on zero hits
+ RETURN
+ END
diff --git a/HTRACKING/h_fill_fpp.f b/HTRACKING/h_fill_fpp.f
new file mode 100644
index 0000000..641dd50
--- /dev/null
+++ b/HTRACKING/h_fill_fpp.f
@@ -0,0 +1,271 @@
+ SUBROUTINE h_fill_fpp(ABORT,err)
+*--------------------------------------------------------
+* Hall C HMS Focal Plane Polarimeter Code
+*
+* Purpose: fill FPP histograms
+* histogram IDs are from common block in file
+* hms_id_histid.cmn and assigned in h_init_histid
+*
+* Created by Frank R. Wesselmann, February 2004
+*
+*--------------------------------------------------------
+
+ IMPLICIT NONE
+
+ INCLUDE 'hms_data_structures.cmn'
+ INCLUDE 'hms_id_histid.cmn'
+ include 'gen_detectorids.par'
+ include 'gen_decode_common.cmn'
+ INCLUDE 'hms_fpp_params.cmn'
+ INCLUDE 'hms_fpp_event.cmn'
+ INCLUDE 'hms_geometry.cmn'
+ INCLUDE 'hms_statistics.cmn'
+
+ character*10 here
+ parameter (here= 'h_fill_fpp')
+
+ integer*4 rad2deg
+ parameter (rad2deg=57.29578)
+
+ logical ABORT
+ character*(*) err
+
+ integer*4 DCset,iChamber,iLayer,iPlane,iWire,iHit,hit2,tdc,iTrack
+ integer*4 iCluster, Nraw, iRaw,hid,hid1,hid2, iROC, ii
+ real*4 dist,time, istat
+
+
+ ABORT= .FALSE.
+ err= ' '
+
+* * check if we have any work to do
+ if (HFPP_raw_tot_hits .le. 0) RETURN
+
+
+* * for each ROC, histogram TDC value of trigger reference
+ hid = hidFPP_tdcROC
+ do ii=0,G_DECODE_MAXROCS
+ iROC = HFPP_my_ROCs(ii)
+ if (iROC.lt.0) EXIT !end of list
+ call hf2(hid,float(iROC),float(HFPP_trigger_TDC(iROC)),1.)
+ enddo !ii
+
+* * for each plane, histogram all TDC values seen
+ do iHit=1, HFPP_raw_tot_hits
+ iPlane = HFPP_raw_plane(iHit)
+ iWire = HFPP_raw_wire(iHit)
+ tdc = HFPP_raw_TDC(iHit)
+ if (iPlane.le.H_FPP_N_PLANES) then
+ hid = hidFPP_tdc(iPlane)
+ call hf2(hid,float(tdc),float(iWire),1.)
+ endif
+ enddo
+
+* * for each plane, wire, histogram all hit times seen
+ do iHit=1, HFPP_raw_tot_hits
+ iPlane = HFPP_raw_plane(iHit)
+ iWire = HFPP_raw_wire(iHit)
+ time = HFPP_HitTime(iHit)
+ if (iPlane.le.H_FPP_N_PLANES) then
+ hid = hidFPP_alltimes(iPlane)
+ call hf2(hid,time,float(iWire),1.)
+ endif
+ enddo
+
+* * for each plane, wire, histogram times of first hit seen
+ do iPlane=1,H_FPP_N_PLANES
+ hid1 = hidFPP_planetime(iPlane)
+ hid2 = hidFPP_time1(iPlane)
+ do iWire=1,HFPP_Nwires(iPlane)
+ iHit = HFPP_hit1idx(iPlane,iWire)
+ if (iHit.gt.0) then
+ time = HFPP_HitTime(iHit)
+ call hf1(hid1,time,1.)
+ call hf2(hid2,time,float(iWire),1.)
+ endif
+ enddo
+ enddo
+
+* * for each plane, wire, histogram time difference between 1st and 2nd hit seen
+ do iPlane=1,H_FPP_N_PLANES
+ do iWire=1,HFPP_Nwires(iPlane)
+ hit2 = HFPP_hit2idx(iPlane,iWire)
+ if (hit2.gt.0) then
+ iHit = HFPP_hit1idx(iPlane,iWire)
+ time = HFPP_HitTime(hit2) - HFPP_HitTime(iHit)
+ hid = hidFPP_time12(iPlane)
+ call hf2(hid,time,float(iWire),1.)
+ endif
+ enddo
+ enddo
+
+* * for each plane, wire, histogram size of clusters
+ do DCset=1,H_FPP_N_DCSETS
+ do iChamber=1,H_FPP_N_DCINSET
+ do iLayer=1,H_FPP_N_DCLAYERS
+ iPlane = H_FPP_N_DCLAYERS * H_FPP_N_DCINSET * (DCset-1)
+ > + H_FPP_N_DCLAYERS * (iChamber-1)
+ > + iLayer
+ hid1 = hidFPP_rawinclust(iPlane)
+ hid2 = hidFPP_rate1(iPlane)
+ do iCluster=1,HFPP_nClusters(DCset,iChamber,iLayer)
+ Nraw = HFPP_nHitsinCluster(DCset,iChamber,iLayer,iCluster)
+ call hf1(hid1,float(Nraw),1.) !number of raw in cluster
+ do iRaw=1,Nraw
+ iHit = HFPP_Clusters(DCset,iChamber,iLayer,iCluster,iRaw)
+ iWire = HFPP_raw_wire(iHit)
+ call hf1(hid2,float(iWire),1.) !hit rate per wire
+ enddo !iRaw
+ enddo !iCluster
+ enddo !iLayer
+ enddo !iChamber
+ enddo !DCset
+
+
+* * for each DCset,iChamber,iLayer, histogram in-layer distance betw hit wires and HMS track
+ do DCset=1,H_FPP_N_DCSETS
+ do iChamber=1,H_FPP_N_DCINSET
+ do iLayer=1,H_FPP_N_DCLAYERS
+ hid = hid_HMSwire(DCset,iChamber,iLayer)
+ if (HFPP_nClusters(DCset,iChamber,iLayer).gt.0) then
+ do iCluster=1,HFPP_nClusters(DCset,iChamber,iLayer)
+ do iHit=1,HFPP_nHitsinCluster(DCset,iChamber,iLayer,iCluster)
+ iRaw = HFPP_Clusters(DCset,iChamber,iLayer,iCluster,iHit)
+ iWire = HFPP_raw_wire(iRaw)
+ dist = HFPP_dHMS(DCset,iChamber,iLayer,iCluster,iHit)
+ call hf2(hid,dist,float(iWire),1.)
+ enddo !iHit
+ enddo !iCluster
+ endif
+ enddo !iLayer
+ enddo !iChamber
+ enddo !DCset
+
+
+* * for each DCset,iChamber,iLayer, histogram drift distances
+ do DCset=1,H_FPP_N_DCSETS
+ do iChamber=1,H_FPP_N_DCINSET
+ do iLayer=1,H_FPP_N_DCLAYERS
+ iPlane = H_FPP_N_DCLAYERS * H_FPP_N_DCINSET * (DCset-1)
+ > + H_FPP_N_DCLAYERS * (iChamber-1)
+ > + iLayer
+ hid1 = hidFPP_driftT(DCset,iChamber,iLayer)
+ hid2 = hidFPP_driftX(DCset,iChamber,iLayer)
+ if (HFPP_nClusters(DCset,iChamber,iLayer).gt.0) then
+ do iCluster=1,HFPP_nClusters(DCset,iChamber,iLayer)
+ do iHit=1,HFPP_nHitsinCluster(DCset,iChamber,iLayer,iCluster)
+ iRaw = HFPP_Clusters(DCset,iChamber,iLayer,iCluster,iHit)
+ iWire = HFPP_raw_wire(iRaw)
+ time = HFPP_drift_time(DCset,iChamber,iLayer,iWire)
+ dist = HFPP_drift_dist(DCset,iChamber,iLayer,iWire)
+ call hf2(hid1,time,float(iWire),1.)
+ call hf2(hid2,dist,float(iWire),1.)
+ enddo !iHit
+ enddo !iCluster
+ endif
+ enddo !iLayer
+ enddo !iChamber
+ enddo !DCset
+
+
+* * for each DCset, histogram simple (Nick's) efficiency:
+* * if 5+ layers of set have hit, mark all layers (in) efficient
+* * if the do (not) have a hit
+ do DCset=1,H_FPP_N_DCSETS
+ if (HFPP_Nlayershit_set(DCset).ge.(H_FPP_N_DCINSET*H_FPP_N_DCLAYERS-1)) then
+ hid = hidFPP_NickEff(DCset)
+ do iChamber=1,H_FPP_N_DCINSET
+ do iLayer=1,H_FPP_N_DCLAYERS
+ iPlane = H_FPP_N_DCLAYERS * H_FPP_N_DCINSET * (DCset-1)
+ > + H_FPP_N_DCLAYERS * (iChamber-1)
+ > + iLayer
+ ii = H_FPP_N_DCLAYERS * (iChamber-1)
+ > + iLayer
+ if (HFPP_N_planehits(iPlane) .gt. 0) then
+ call hf1(hid,float(ii),1.)
+ else
+ call hf1(hid,float(ii),0.)
+ endif
+ enddo !iLayer
+ enddo !iChamber
+ endif
+ enddo !DCset
+
+
+* * for each DCset,iChamber,iLayer, histogram expected hits and actual
+ do DCset=1,H_FPP_N_DCSETS
+ do iChamber=1,H_FPP_N_DCINSET
+ do iLayer=1,H_FPP_N_DCLAYERS
+ hid1 = hidFPP_should(DCset,iChamber,iLayer)
+ hid2 = hidFPP_did(DCset,iChamber,iLayer)
+ do iTrack=1,HFPP_N_tracks(DCset)
+ iWire = HFPP_stat_shouldhit(DCset,iChamber,iLayer,iTrack)
+ if (HFPP_stat_diddhit(DCset,iChamber,iLayer,iTrack)) then
+ istat = 1.0
+ else
+ istat = 0.0
+ endif
+ call hf1(hid1,float(iWire),1.) ! expected hit frequency
+ call hf1(hid2,float(iWire),istat) ! hit efficiency
+ enddo !iTrack
+ enddo !iLayer
+ enddo !iChamber
+ enddo !DCset
+
+* * for each DCset,iChamber,iLayer, histogram min distance betw hits and track
+ do DCset=1,H_FPP_N_DCSETS
+ hid = hidFPP_dist(DCset)
+ do iChamber=1,H_FPP_N_DCINSET
+ do iLayer=1,H_FPP_N_DCLAYERS
+ ii = H_FPP_N_DCLAYERS * (iChamber-1) + iLayer
+ do iTrack=1,HFPP_N_tracks(DCset)
+ dist = HFPP_stat_dist2closest(DCset,iChamber,iLayer,iTrack)
+ call hf2(hid,float(ii),dist,1.)
+ enddo !iTrack
+ enddo !iLayer
+ enddo !iChamber
+ enddo !DCset
+
+* * for each DCset,iChamber,iLayer, histogram linear and angular resolutions
+ if (HFPP_calc_resolution.ne.0) then
+ do DCset=1,H_FPP_N_DCSETS
+ hid1 = hidFPP_resol_lin(DCset)
+ hid2 = hidFPP_resol_ang(DCset)
+ do iChamber=1,H_FPP_N_DCINSET
+ do iLayer=1,H_FPP_N_DCLAYERS
+ ii = H_FPP_N_DCLAYERS * (iChamber-1) + iLayer
+ do iTrack=1,HFPP_N_tracks(DCset)
+ call hf2(hid1,float(ii),HFPP_track_resolution(DCset,iChamber,iLayer,iTrack),1.)
+ call hf2(hid2,float(ii),HFPP_track_angresol(DCset,iChamber,iLayer,iTrack),1.)
+ enddo !iTrack
+ enddo !iLayer
+ enddo !iChamber
+ enddo !DCset
+ endif
+
+* * for each track in each set, track chi**2, mx,bx,my,by, # hits, HFPP_track_fine,
+* * sclose,zclose,theta,phi
+ do DCset=1,H_FPP_N_DCSETS
+ call hf1(hidFPP_Ntrk(DCset),float(HFPP_N_tracks(DCset)),1.)
+ do iTrack=1,HFPP_N_tracks(DCset)
+ call hf1(hidFPP_Nhitontrk(DCset),float(HFPP_track_Nlayers(DCset,iTrack)),1.)
+ call hf1(hidFPP_Nrawontrk(DCset),float(HFPP_track_Nhits(DCset,iTrack)),1.)
+ call hf1(hidFPP_trk_chi2(DCset),HFPP_track_chi2(DCset,iTrack),1.)
+ call hf1(hidFPP_trk_mx(DCset),HFPP_track_dx(DCset,iTrack),1.) !fp coords
+ call hf1(hidFPP_trk_bx(DCset),HFPP_track_x(DCset,iTrack),1.)
+ call hf1(hidFPP_trk_my(DCset),HFPP_track_dy(DCset,iTrack),1.)
+ call hf1(hidFPP_trk_by(DCset),HFPP_track_y(DCset,iTrack),1.)
+ call hf1(hidFPP_fine_mx(DCset),HFPP_track_fine(DCset,iTrack,1),1.) !chamber coords
+ call hf1(hidFPP_fine_bx(DCset),HFPP_track_fine(DCset,iTrack,2),1.)
+ call hf1(hidFPP_fine_my(DCset),HFPP_track_fine(DCset,iTrack,3),1.)
+ call hf1(hidFPP_fine_by(DCset),HFPP_track_fine(DCset,iTrack,4),1.)
+ call hf1(hidFPP_sclose(DCset),HFPP_track_sclose(DCset,iTrack),1.)
+ call hf1(hidFPP_zclose(DCset),HFPP_track_zclose(DCset,iTrack),1.)
+ call hf1(hidFPP_thetapol(DCset),HFPP_track_theta(DCset,iTrack),1.)
+ call hf1(hidFPP_phipol(DCset),HFPP_track_phi(DCset,iTrack),1.)
+ enddo !iTrack
+ enddo !DCset
+
+
+ RETURN
+ END
diff --git a/HTRACKING/h_fill_scin_raw_hist.f b/HTRACKING/h_fill_scin_raw_hist.f
new file mode 100644
index 0000000..b9101e6
--- /dev/null
+++ b/HTRACKING/h_fill_scin_raw_hist.f
@@ -0,0 +1,140 @@
+ subroutine h_fill_scin_raw_hist(Abort,err)
+*
+* routine to fill histograms with hms_raw_scin varibles
+* In the future ID numbers are stored in hms_histid
+*
+* Author: D. F. Geesaman
+* Date: 4 April 1994
+*
+* Modified 9 April 1994 DFG
+* Add CTP flag to turn on histogramming
+* id's in hms_id_histid
+* $Log: h_fill_scin_raw_hist.f,v $
+* Revision 1.9 2002/07/31 20:17:52 saw
+* Check that user hists are defined before filling
+*
+* Revision 1.8 1996/01/16 21:49:45 cdaq
+* (JRA)
+*
+* Revision 1.7 1995/10/10 13:11:20 cdaq
+* (JRA) Remove some unneeded validity tests
+*
+* Revision 1.6 1995/07/19 18:16:29 cdaq
+* (JRA) Fill hist's from "all" data structures
+*
+* Revision 1.5 1995/05/22 19:39:12 cdaq
+* (SAW) Split gen_data_data_structures into gen, hms, sos, and coin parts"
+*
+* Revision 1.4 1995/05/11 19:04:53 cdaq
+* (JRA) Modifications to user histograms
+*
+* Revision 1.3 1995/02/10 19:03:46 cdaq
+* (JRA) Change hscin_num_counters to hnum_scin_counters
+*
+* Revision 1.2 1995/02/02 13:13:46 cdaq
+* (JRA) Make hscin_all_adc_pos/neg floating
+*
+* Revision 1.1 1994/04/13 20:08:03 cdaq
+* Initial revision
+*
+*--------------------------------------------------------
+ IMPLICIT NONE
+*
+ external thgetid
+ integer*4 thgetid
+ character*50 here
+ parameter (here= 'h_fill_scin_raw_hist_')
+*
+ logical ABORT
+ character*(*) err
+ real*4 histval
+ real*4 rcnt
+ integer*4 pln,cnt,ihit
+ include 'hms_data_structures.cmn'
+ include 'hms_scin_parms.cmn'
+ include 'hms_id_histid.cmn'
+*
+ SAVE
+*--------------------------------------------------------
+*
+ ABORT= .FALSE.
+ err= ' '
+*
+* Make sure there is at least 1 hit
+ if(hscin_all_tot_hits .gt. 0 ) then
+* Loop over all hits
+ do ihit=1,hscin_all_tot_hits
+ pln=hscin_all_plane_num(ihit)
+ cnt=hscin_all_counter_num(ihit)
+ rcnt=float(cnt)
+* Fill plane map
+c histval = float(pln)
+c call hf1(hidscinplane,histval,1.)
+* Fill counter map
+ histval = rcnt
+ if (hidscincounters(pln).gt.0)
+ $ call hf1(hidscincounters(pln),histval,1.)
+* Fill ADC and TDC histograms for positive tubes.
+ if (hscin_all_tdc_pos(ihit).ne.-1) then !tube was hit
+ histval = rcnt
+ if (hidscinallpostdc(pln).gt.0)
+ $ call hf1(hidscinallpostdc(pln),histval,1.)
+ histval = FLOAT(hscin_all_tdc_pos(ihit))
+ if (hidsumpostdc(pln).gt.0)
+ $ call hf1(hidsumpostdc(pln),histval,1.)
+ else !tube was NOT hit
+ histval = hscin_all_adc_pos(ihit)-hscin_all_ped_pos(pln,cnt)
+ if (hidsumposadc(pln).gt.0)
+ $ call hf1(hidsumposadc(pln),histval,1.)
+ endif
+
+ if ((hscin_all_adc_pos(ihit)-hscin_all_ped_pos(pln,cnt))
+ $ .ge. 50) then
+ histval = rcnt
+ if (hidscinallposadc(pln).gt.0)
+ $ call hf1(hidscinallposadc(pln),histval,1.)
+ endif
+
+* Fill ADC and TDC histograms for negative tubes.
+ if (hscin_all_tdc_neg(ihit).ne.-1) then !tube was hit
+ histval = rcnt
+ if (hidscinallnegtdc(pln).gt.0)
+ $ call hf1(hidscinallnegtdc(pln),histval,1.)
+ histval = FLOAT(hscin_all_tdc_neg(ihit))
+ if (hidsumnegtdc(pln).gt.0)
+ $ call hf1(hidsumnegtdc(pln),histval,1.)
+ else !tube was NOT hit
+ histval = hscin_all_adc_neg(ihit)-hscin_all_ped_neg(pln,cnt)
+ if (hidsumnegadc(pln).gt.0)
+ $ call hf1(hidsumnegadc(pln),histval,1.)
+ endif
+
+ if ((hscin_all_adc_neg(ihit)-hscin_all_ped_neg(pln,cnt))
+ $ .ge. 50) then
+ histval = rcnt
+ if (hidscinallnegadc(pln).gt.0)
+ $ call hf1(hidscinallnegadc(pln),histval,1.)
+ endif
+
+
+* Do we want to histogram raw scintillators
+
+ if(hturnon_scin_raw_hist .ne. 0 ) then
+ histval = hscin_all_adc_pos(ihit)-hscin_all_ped_pos(pln,cnt)
+ if (hidscinposadc(pln,cnt).gt.0)
+ $ call hf1(hidscinposadc(pln,cnt),histval,1.)
+ histval = hscin_all_adc_neg(ihit)-hscin_all_ped_neg(pln,cnt)
+ if (hidscinnegadc(pln,cnt).gt.0)
+ $ call hf1(hidscinnegadc(pln,cnt),histval,1.)
+ histval = FLOAT(hscin_all_tdc_pos(ihit))
+ if (hidscinpostdc(pln,cnt).gt.0)
+ $ call hf1(hidscinpostdc(pln,cnt),histval,1.)
+ histval = FLOAT(hscin_all_tdc_neg(ihit))
+ if (hidscinnegtdc(pln,cnt).gt.0)
+ $ call hf1(hidscinnegtdc(pln,cnt),histval,1.)
+ endif ! end test on histogramming flag
+ enddo ! end loop over hits
+ endif ! end test on zero hits
+
+ return
+ end
diff --git a/HTRACKING/h_find_best_stub.f b/HTRACKING/h_find_best_stub.f
new file mode 100644
index 0000000..1e589ca
--- /dev/null
+++ b/HTRACKING/h_find_best_stub.f
@@ -0,0 +1,97 @@
+ subroutine h_find_best_stub(numhits,hits,pl,pindex,plusminus,stub,chi2)
+* This subroutine does a linear least squares fit of a line to the
+* hits in an individual chamber. It assumes that the y slope is 0
+* The wire coordinate is calculated
+* from the wire center + plusminus*(drift distance).
+* This is called in a loop over all combinations of plusminus
+*
+* d. f. geesaman
+* $Log: h_find_best_stub.f,v $
+* Revision 1.6 1996/01/16 21:51:00 cdaq
+* (JRA)
+*
+* Revision 1.5 1995/10/10 13:37:10 cdaq
+* (JRA) Cleanup
+*
+* Revision 1.4 1995/05/22 19:39:12 cdaq
+* (SAW) Split gen_data_data_structures into gen, hms, sos, and coin parts"
+*
+* Revision 1.3 1994/11/22 20:04:56 cdaq
+* (SAW) Matrix solver routine now called h_solve_3by3
+*
+* Revision 1.2 1994/10/12 18:38:46 cdaq
+* (DJM) Don't recalculate plane array, remove repetitive calc of AA matrix
+*
+* Revision 1.1 1994/02/19 06:14:29 cdaq
+* Initial revision
+*
+*
+* the four parameters of a stub are x_t,y_t,xp_t,yp_t
+*
+* Called by H_LEFT_RIGHT
+*
+ implicit none
+ include "hms_data_structures.cmn"
+ include "hms_tracking.cmn"
+ include "hms_geometry.cmn"
+
+* input quantities
+ integer*4 numhits
+ integer*4 hits(*)
+ real*4 plusminus(*)
+*
+* output quantitites
+ real*8 dstub(3) !x,y,xp of local line fit
+ real*4 stub(4)
+ real*4 chi2 ! chi2 of fit
+*
+* local variables
+ real*4 dpos(hmax_hits_per_point)
+ integer*4 pl(hmax_hits_per_point) !keep name same as in h_left_right.f
+ integer*4 pindex ! passed from h_left_right to h_solve_3by3
+ real*8 TT(3)
+ integer*4 hit
+ integer*4 i
+*
+ TT(1)=0.
+ TT(2)=0.
+ TT(3)=0.
+
+* calculate trial hit position and least squares matrix coefficients.
+ do hit=1,numhits
+ dpos(hit)=HDC_WIRE_CENTER(hits(hit)) +
+ & plusminus(hit)*HDC_DRIFT_DIS(hits(hit)) -
+ & hpsi0(pl(hit))
+ do i=1,3
+ TT(i)=TT(i)+((dpos(hit))*hstubcoef(pl(hit),i))/hdc_sigma(pl(hit))
+ enddo
+ enddo
+*
+* djm 10/2/94 removed repetitive calculations of matrix AA3. This matrix and its
+* inverse now calculated for the 14 most popular hit plane configurations and stored
+* at initialization. (See h_generate_geometry.f)
+
+* solve three by three equations using stored inverse matrix
+ccc call h_solve_3by3(TT,pindex,dstub)
+
+ dstub(1)=HAAINV3(1,1,pindex)*TT(1) + HAAINV3(1,2,pindex)*TT(2) +
+ & HAAINV3(1,3,pindex)*TT(3)
+ dstub(2)=HAAINV3(1,2,pindex)*TT(1) + HAAINV3(2,2,pindex)*TT(2) +
+ & HAAINV3(2,3,pindex)*TT(3)
+ dstub(3)=HAAINV3(1,3,pindex)*TT(1) + HAAINV3(2,3,pindex)*TT(2) +
+ & HAAINV3(3,3,pindex)*TT(3)
+
+* calculate chi2. Remember one power of sigma is in hstubcoef
+ chi2=0.
+ stub(1)=dstub(1)
+ stub(2)=dstub(2)
+ stub(3)=dstub(3)
+ stub(4)=0.
+ do hit=1,numhits
+ chi2=chi2+((dpos(hit))/hdc_sigma(pl(hit))
+ & -hstubcoef(pl(hit),1)*stub(1)
+ & -hstubcoef(pl(hit),2)*stub(2)
+ & -hstubcoef(pl(hit),3)*stub(3) )**2
+ enddo
+ return
+ end
diff --git a/HTRACKING/h_find_easy_space_point.f b/HTRACKING/h_find_easy_space_point.f
new file mode 100644
index 0000000..430c011
--- /dev/null
+++ b/HTRACKING/h_find_easy_space_point.f
@@ -0,0 +1,85 @@
+ subroutine h_find_easy_space_point(ncham_hits,
+ & hit_num, wire_center, ipln,space_point_criterion,
+ & nspace_point_len,
+ & y_hit,yp_hit,easy_space_point,
+ & nspace_points,space_points,space_point_hits)
+*
+* $Log: h_find_easy_space_point.f,v $
+* Revision 1.1 1995/10/25 15:00:13 cdaq
+* Initial revision
+*
+*
+* Simplified HMS find_space_point routine. It is given all y hits, and checks
+* to see if all x-like hits are close enough together to make a space point.
+*
+ implicit none
+*
+ INCLUDE 'hms_data_structures.cmn'
+ INCLUDE 'gen_constants.par'
+ INCLUDE 'gen_units.par'
+ INCLUDE 'hms_tracking.cmn'
+ INCLUDE 'hms_geometry.cmn'
+
+* input
+ integer*4 ncham_hits ! total number of hits in chamber
+ integer*4 hit_num(*) ! array of hit numbers
+ integer*4 ipln(*) ! array of plane numbers for each hit
+ real*4 wire_center(*) ! array of wire coordinates for hits
+ real*4 space_point_criterion ! squared distance limit for points
+ integer*4 nspace_point_len ! dimension of space point arrays
+ integer*4 y_hit,yp_hit !hit # of y and y' planes
+ logical easy_space_point
+*
+* outputs
+ integer*4 nspace_points ! number of space points in chamber
+ real*4 space_points(nspace_point_len,2) ! xt, yt of each space point
+ integer*4 space_point_hits(nspace_point_len,*)
+* ! hit numbers for each space point
+* internal Variables,
+ integer*4 k
+ integer*4 num_xhits
+ real*4 xt,yt
+ real*4 x_pos(hmax_hits_per_point)
+ real*4 max_dist
+*
+*
+ yt=(wire_center(y_hit)+wire_center(yp_hit))/2
+ xt=0.
+ num_xhits=0
+ nspace_points = 0
+ max_dist = sqrt(space_point_criterion/2)
+*
+
+* loop over all hits, find x of space point.
+ do k = 1, ncham_hits
+ if (k.ne.y_hit .and. k.ne.yp_hit) then !x-like hits
+ x_pos(k) = ( wire_center(k)-yt*hysp(ipln(k)) )/hxsp(ipln(k))
+ xt = xt + x_pos(k)
+ num_xhits = num_xhits + 1
+ else
+ x_pos(k) = 0.
+ endif
+ enddo
+ xt = xt / float(max(1,num_xhits))
+
+ easy_space_point = .true.
+ do k = 1, ncham_hits
+ if (k.ne.y_hit .and. k.ne.yp_hit) then
+ if (abs(xt-x_pos(k)).ge.max_dist) easy_space_point=.false.
+ endif
+ enddo
+
+* If easy_space_point is true, all hits were on the space points.
+ if (easy_space_point) then
+ nspace_points = 1
+ space_point_hits(1,1) = ncham_hits
+ space_point_hits(1,2) = 0 !no combos.
+ do k = 1, ncham_hits
+ space_point_hits(1,k+2) = hit_num(k)
+ enddo
+ space_points(1,1)=xt
+ space_points(1,2)=yt
+ endif
+
+ return
+ end
diff --git a/HTRACKING/h_fpp.f b/HTRACKING/h_fpp.f
new file mode 100644
index 0000000..98d326c
--- /dev/null
+++ b/HTRACKING/h_fpp.f
@@ -0,0 +1,62 @@
+ SUBROUTINE h_fpp(ABORT,err)
+*--------------------------------------------------------
+* Hall C HMS Focal Plane Polarimeter Code
+*
+* Purpose: analyze FPP portion of HMS event
+*
+* Created by Frank R. Wesselmann, February 2004
+*
+*--------------------------------------------------------
+
+ IMPLICIT NONE
+
+ include 'gen_detectorids.par'
+ include 'gen_decode_common.cmn'
+ INCLUDE 'hms_data_structures.cmn'
+ INCLUDE 'hms_fpp_params.cmn'
+ INCLUDE 'hms_fpp_event.cmn'
+
+ character*13 here
+ parameter (here= 'h_fpp')
+
+ logical ABORT
+ character*(*) err
+
+ integer*4 iset
+
+
+ ABORT= .FALSE.
+ err= ' '
+
+c write(*,*)'In h_fpp.f with hsnum_fptrack =',hsnum_fptrack
+ if (hsnum_fptrack.le.0) return ! No good HMS track
+* * note that the above value is determined in h_select_best_track
+* * so we have to wait until after it is called before we do the FPP!
+
+
+* * do tracking in each set of chambers separately
+ do iset=1, H_FPP_N_DCSETS
+c write(*,*)'Calling fpp_tracking ->'
+c write(*,*)'iset,layers,min = ',iset,HFPP_Nlayershit_set(iset),
+c & HFPP_minsethits
+ if (HFPP_Nlayershit_set(iset) .ge. HFPP_minsethits) then
+ call h_fpp_tracking(iset,ABORT,err)
+ if (ABORT) then
+ call g_add_path(here,err)
+ return
+ endif
+
+ endif
+ enddo !iset
+
+
+* * do statistical analysis, e.g. efficiencies
+ call h_fpp_statistics(ABORT,err)
+ if (ABORT) then
+ call g_add_path(here,err)
+ return
+ endif
+
+
+ RETURN
+ END
diff --git a/HTRACKING/h_fpp_drift.f b/HTRACKING/h_fpp_drift.f
new file mode 100644
index 0000000..d9f1750
--- /dev/null
+++ b/HTRACKING/h_fpp_drift.f
@@ -0,0 +1,549 @@
+ SUBROUTINE h_fpp_drift(hit,RoughTrack,prop_delay,
+ > drift_time,drift_distance,ABORT,err)
+*--------------------------------------------------------
+* Hall C HMS Focal Plane Polarimeter Code
+*
+* Purpose: determine fully corrected drift distance for raw hit
+*
+* Created by Frank R. Wesselmann, February 2004
+*
+*--------------------------------------------------------
+
+ IMPLICIT NONE
+
+ include 'gen_detectorids.par'
+ include 'gen_decode_common.cmn'
+ INCLUDE 'hms_data_structures.cmn'
+ INCLUDE 'hms_fpp_params.cmn'
+ INCLUDE 'hms_geometry.cmn'
+ INCLUDE 'hms_fpp_event.cmn'
+ INCLUDE 'hms_bypass_switches.cmn'
+
+ character*11 here
+ parameter (here= 'h_fpp_drift')
+
+ integer*4 hit ! number of hit in raw hits array
+ real*4 RoughTrack(6) ! rough track parameter for corrections
+ real*4 prop_delay ! wire propagation delay
+ real*4 drift_time ! fully corrected drift time
+ real*4 drift_time_orig ! un-corrected drift time
+ real*4 drift_distance ! drift distance determ. from drift time
+
+ logical ABORT
+ character*(*) err
+
+ integer*4 Plane, Wire
+ integer*4 Set,Chamber,Layer
+ integer*4 ii,p,i,j
+ integer*4 binno
+
+ real*4 correction, fraction, a
+ real*8 mx8,my8,mu8,Px8,Py8,alpha8
+
+ real*4 ejbtime ! really simple time to distance calc
+ real*4 ejbdrift ! really simple time to distance calc
+ common /HMS_FPP_ejbdrift/ ejbtime(120,4), ejbdrift(120,4)
+
+
+ ABORT= .FALSE.
+ err= ' '
+
+ drift_distance = H_FPP_BAD_DRIFT
+
+* * get hit data from raw array
+ Plane = HFPP_raw_plane(hit)
+ Wire = HFPP_raw_wire(hit)
+ drift_time = HFPP_HitTime(hit)
+ drift_time_orig = HFPP_HitTime(hit)
+
+ Set = HFPP_plane2set(Plane)
+ Chamber = HFPP_plane2chamber(Plane)
+ Layer = HFPP_plane2layer(Plane)
+
+ if(hbypass_trans_fpp.eq.2) then
+ drift_distance = abs(HFPP_drift_dist(Set,Chamber,Layer,Wire))
+ return
+ endif
+
+******************** corrections to drift time *******************************
+
+* drift time is expected to measure time from particle interacting in drift
+* cell until the signal is seen on the sense wire, meaning we expect the
+* time values to be more positive for longer drift distances!
+* in reality, we only know the trigger signal time and the time when the
+* sense wire signal hits the TDC
+* since the length of the signal cables and the processing delays are
+* independent of the geometric event, we can consider them fixed and they are
+* absorbed into the drift map or the time offset
+* this leaves the following corrections:
+* - trigger time: corrections to the tirgger time to obtain the actual
+* interaction time of the particle with the scintillator
+* - time of flight: interaction in lower-z layers are earlier (relative to
+* trigger!) than higher-z ones
+* - wire walk correction: signal needs to propagate along sense wire to
+* amplifier (readout) card and the path length depends on track geometry
+
+
+* * correct trigger time
+ drift_time = drift_time - hstart_time
+
+
+ if (.FALSE.) then
+* * apply time of flight correction to offset trigger time?
+* * we use the simple and consistent approach to correct based
+* * on an externally FIXED velocity based on our absolute
+* * z position, so trigger time is interpreted to be valid at z=0
+* * whatever offset is needed needs to be absorbed into HFPP_tDriftOffset
+* * it might be nice if the particle speed was NOT fixed...
+ correction = (HFPP_layerZ(Set,Chamber,Layer)+HFPP_Zoff(Set)) / HFPP_particlespeed
+ drift_time = drift_time - correction
+
+cfrw we could also base the TOF speed on the HMS track speed, as follows:
+cfrw p = hp_tar(HSNUM_FPTRACK)
+cfrw speed = speed_of_light * p/sqrt(p*p+hpartmass*hpartmass)
+
+cfrw actually, using the measured particle velocity, we can find ToF just like
+cfrw HMS DCs do -- or could because they use fixed, pre-determined ToF to each layer --
+cfrw but the event HMS reference time (hstart_time) is based on a corrected value,
+cfrw determined in h_trans_scin.f
+cfrw using this approach, we get the velocity as 29.979*hbeta_pcent where
+cfrw hbeta_pcent = hpcentral/sqrt(hpcentral*hpcentral+hpartmass*hpartmass)
+cfrw and the path is the wire z-coord in the same system as used by the hscin -- find
+cfrw the parameter assingment of hscin_1x_zpos to get details;
+cfrw the HMS reference time is calculated at z=0 is this system
+
+ endif
+
+
+
+
+ if (.TRUE.) then
+* * apply wire propagation delay correction, supplied externally
+ drift_time = drift_time - prop_delay
+ endif
+
+* write(*,*)'Drift time: ',drift_time_orig,prop_delay,correction,hstart_time,drift_time
+
+* implement drift time "kluge" (ejb)
+ if(hbypass_trans_fpp.eq.4) then
+ if(drift_time.gt.4000.0) then
+ drift_distance=H_FPP_BAD_DRIFT
+ return
+ endif
+ if(Set.eq.1) then
+ drift_distance=(drift_time+30.0)/210.0*1.38
+ else
+ drift_distance=(drift_time+10.0)/210.0*1.38
+ endif
+ if(drift_distance.lt.0)drift_distance=0.0001
+ if(drift_distance.gt.1.28)drift_distance=1.28
+c write(*,*)'Kluge: ',drift_time,drift_distance
+ return
+ endif
+
+
+******************** convert drift time to drift distance ********************
+c write(*,*)'Drift type = ',hfpp_drift_type
+
+ if (hfpp_drift_type.eq.0) then ! no drift, use 0.5cm ***************
+ drift_distance = 0.5
+
+ elseif (hfpp_drift_type.eq.1) then ! look-up table ***************
+
+ if (drift_time.lt.hfpp_drift_Tmin .or.
+ > drift_time.gt.hfpp_drift_Tmax ) then ! skip rare random/early hit
+ drift_distance = H_FPP_BAD_DRIFT
+ RETURN
+ endif
+
+* * find closest time bin for drift map
+ binno = 1 + int((drift_time-hfpp_drift_Tmin)/hfpp_drift_dT)
+ if (binno.lt.1 .or. binno.ge.hfpp_drift_Nbins) then ! should never happen
+ drift_distance = H_FPP_BAD_DRIFT
+ RETURN
+ endif
+
+* * interpolate between two relevant time bins
+ fraction = (drift_time-hfpp_drift_Tmin) / hfpp_drift_dT
+ binno = 1 + int(fraction)
+ fraction = fraction - float(binno) - 1.5 ! range -0.5 to 0.5
+
+ if (fraction.lt.0.0) then !below midpoint
+ fraction = -1.0*fraction
+ if (binno.eq.1) then !already at bottom bin
+ drift_distance = 2.0 * (1.0-fraction) * hfpp_driftmap(Layer,binno) !assume bottom edge of bin is 0 drift
+ else
+ drift_distance = fraction * hfpp_driftmap(Layer,binno-1)
+ > + (1.0-fraction) * hfpp_driftmap(Layer,binno)
+ endif
+
+ else !above midpoint
+ if (binno.eq.hfpp_drift_Nbins) then !already at top bin
+ drift_distance = H_FPP_BAD_DRIFT
+ RETURN
+ else
+ drift_distance = fraction * hfpp_driftmap(Layer,binno+1)
+ > + (1.0-fraction) * hfpp_driftmap(Layer,binno)
+ endif
+ endif
+
+ if (drift_distance.lt.0.0) then
+ drift_distance = H_FPP_BAD_DRIFT
+ RETURN
+ endif
+
+
+ elseif (hfpp_drift_type.eq.2) then ! polynomial ******************
+
+ if (drift_time.gt.hfpp_drift_Tmax) then
+ drift_distance = H_FPP_BAD_DRIFT
+ RETURN
+ elseif (drift_time.lt.hfpp_drift_Tmin) then
+ drift_distance = H_FPP_BAD_DRIFT
+ RETURN
+ endif
+
+ drift_distance = 0.0
+ do ii=1,hfpp_drift_Nterms
+ p = ii-1
+ a = hfpp_drift_coeffs(Layer,ii)
+ drift_distance = drift_distance + a * drift_time**p
+ enddo !ii
+
+ if (drift_distance.gt.hfpp_drift_Xmax) then
+ drift_distance = H_FPP_BAD_DRIFT
+ RETURN
+ endif
+
+ elseif (hfpp_drift_type.eq.3) then !simple ejb time to dist calculation
+ j=(Set-1)*2+Chamber
+ do i=2,100
+ if (ejbtime(i,j).gt.drift_time_orig) then
+ drift_distance = ejbdrift(i,j)-
+ > (ejbdrift(i,j)-ejbdrift(i-1,j))*
+ > ((ejbtime(i,j)-drift_time_orig)/
+ > (ejbtime(i,j)-ejbtime(i-1,j)))
+ goto 9191
+ endif
+ enddo
+9191 continue
+
+ if(Set.eq.1) then
+ if(drift_time_orig.lt.60.0) drift_distance=0.0001
+ if(drift_time_orig.gt.495.0) drift_distance=1.25
+ else
+ if(drift_time_orig.lt.75.0) drift_distance=0.0001
+ if(drift_time_orig.gt.495.0) drift_distance=1.25
+ endif
+ if(drift_time_orig.gt.4000.0) drift_distance = H_FPP_BAD_DRIFT
+
+ if (drift_distance.gt.hfpp_drift_Xmax) then
+ drift_distance = hfpp_drift_Xmax
+ RETURN
+ endif
+
+ elseif (hfpp_drift_type.eq.4) then ! constant speed **************
+
+ if (drift_time.gt.hfpp_drift_Tmax) then
+ drift_distance = H_FPP_BAD_DRIFT
+ RETURN
+ elseif (drift_time.lt.hfpp_drift_Tmin) then
+ drift_distance = H_FPP_BAD_DRIFT
+ RETURN
+ endif
+
+ drift_distance = hfpp_drift_dT * drift_time
+
+ if (drift_distance.gt.hfpp_drift_Xmax) then
+ drift_distance = H_FPP_BAD_DRIFT
+ RETURN
+ endif
+
+ if (drift_distance.lt.0.0) then
+ drift_distance = H_FPP_BAD_DRIFT
+ RETURN
+ endif
+
+
+ elseif (hfpp_drift_type.eq.5) then ! experimental hardcoded
+
+ if (drift_time.gt.hfpp_drift_Tmax) then
+ drift_distance = H_FPP_BAD_DRIFT
+ RETURN
+ elseif (drift_time.lt.hfpp_drift_Tmin) then
+ drift_distance = H_FPP_BAD_DRIFT
+ RETURN
+ endif
+
+ drift_distance = sqrt( (drift_time-hfpp_drift_Tmin) /
+ > (hfpp_drift_Tmax-hfpp_drift_Tmin) )
+
+ if (drift_distance.gt.hfpp_drift_Xmax) then
+ drift_distance = H_FPP_BAD_DRIFT
+ RETURN
+ endif
+
+ if (drift_distance.lt.0.0) then
+ drift_distance = H_FPP_BAD_DRIFT
+ RETURN
+ endif
+
+ else ! bad selector ****************
+ drift_distance = H_FPP_BAD_DRIFT
+ write(err,*) 'unknown drift map type: ',hfpp_drift_type
+ ABORT = .true.
+ call g_rep_err(ABORT,err)
+ RETURN
+ endif
+
+
+
+
+******************** corrections to drift distance ***************************
+
+
+ if (.FALSE.) then
+* * apply out-of-plane correction IF NEEDED
+* * this corrects for the fact that the drift distance is the
+* * closest approach distance, which is not generally in the
+* * wire plane, but the tracking uses the in-plane distance!
+* * note that this is NOT a correction to the time but to the distance!
+* * This correction may be obviated by the drift map if it gives the
+* * in-layer coordinate already (as GARFIELD simulations might)...
+ Px8 = dble(HFPP_direction(Set,Chamber,Layer,1)) !projection of u onto x
+ Py8 = dble(HFPP_direction(Set,Chamber,Layer,2)) !projection of u onto y
+ mx8 = dble(RoughTrack(1))
+ my8 = dble(RoughTrack(3))
+ mu8 = Px8*mx8 + Py8*my8
+ alpha8 = datan(mu8)
+ if (alpha8.ne.0.d0) then
+ drift_distance = drift_distance * sngl(1.d0 / dabs(dcos(alpha8)))
+ endif
+ endif
+
+
+* * make sure the result is meaningful!
+ if (drift_distance.gt.HFPP_maxdrift(Plane)) then
+ drift_distance = H_FPP_BAD_DRIFT
+ endif
+
+
+ RETURN
+ END
+
+
+c==============================================================================
+c==============================================================================
+c==============================================================================
+c==============================================================================
+
+
+ SUBROUTINE h_fpp_drift_init(ABORT,err)
+*--------------------------------------------------------
+* Hall C HMS Focal Plane Polarimeter Code
+*
+* Purpose: tracking in one set of FPP drift chambers
+* find best track fitted to wire centers
+* test all possible permutations until good track found
+*
+* Created by Frank R. Wesselmann, February 2004
+*
+*--------------------------------------------------------
+
+ IMPLICIT NONE
+
+ include 'gen_detectorids.par'
+ include 'gen_decode_common.cmn'
+ INCLUDE 'hms_data_structures.cmn'
+ INCLUDE 'hms_fpp_params.cmn'
+
+ character*16 here
+ parameter (here= 'h_fpp_drift_init')
+
+ logical ABORT
+ character*(*) err
+
+ integer LUN
+ integer*4 i,Plane
+ real*4 rflag
+ real*4 timebins(H_FPP_DRIFT_MAX_BINS)
+
+ real*4 ejbtime ! really simple time to distance calc
+ real*4 ejbdrift ! really simple time to distance calc
+ common /HMS_FPP_ejbdrift/ ejbtime(120,4), ejbdrift(120,4)
+
+
+ write(6,'(''\n[47;34;1m FPP Drift Map: [49;0m'')')
+
+ hfpp_drift_type = 0
+
+ hfpp_drift_Nbins = 0
+ hfpp_drift_dT = 0.0
+ hfpp_drift_Tmin = 0.0
+ hfpp_drift_Tmax = 0.0
+ hfpp_drift_Xmax = 0.0
+ hfpp_drift_Nterms = 0
+
+ if (hfpp_driftmap_filename.eq.' ') then
+ print *,' No drift map specified for the HMS FPP chambers.'
+ print *,' Using fixed drift distance of +/-0.5 cm, best fit.\n'
+ RETURN
+ endif
+
+
+ call g_IO_control(LUN,'ANY',ABORT,err) !get IO channel
+c write(*,*)'FPP Drift Map File:',hfpp_driftmap_filename
+ open(LUN,file=hfpp_driftmap_filename,err=900)
+
+ read(LUN,*,err=901,end=900) rflag, hfpp_drift_Xmax
+ hfpp_drift_type = int(rflag)
+
+
+ if (hfpp_drift_type.eq.1) then ! look-up table ***************
+
+ read(LUN,*,err=902,end=900) hfpp_drift_Nbins
+
+ if (hfpp_drift_Nbins.gt.H_FPP_DRIFT_MAX_BINS) then
+ hfpp_drift_Nbins = H_FPP_DRIFT_MAX_BINS
+ write(err,*) 'Too many bins in FPP drift map ',hfpp_driftmap_filename
+ call g_rep_err(ABORT,err)
+ endif
+
+ do i=1,hfpp_drift_Nbins
+ read(LUN,*,err=902,end=900)
+ > timebins(i), (hfpp_driftmap(Plane,i),Plane=1,H_FPP_N_PLANES)
+ enddo !i
+
+ if (hfpp_drift_Nbins.gt.2) then
+ hfpp_drift_dT = timebins(2) - timebins(1) !midpoints of bin!!!
+ hfpp_drift_Tmin = timebins(1)
+ > - 0.5*hfpp_drift_dT
+ hfpp_drift_Tmax = timebins(hfpp_drift_Nbins)
+ > + 0.5*hfpp_drift_dT
+ else
+ write(err,*) 'Only ',hfpp_drift_Nbins,' entries for FPP drift map ',hfpp_driftmap_filename
+ call g_rep_err(ABORT,err)
+ endif
+
+ if (hfpp_drift_Nbins.le.0) goto 902
+ if (hfpp_drift_dT.le.0.0) goto 902
+
+ print *,' The selected drift map file uses a look-up table to determine'
+ print *,' the drift in the focal plane polarimeter chambers.'
+ print *,' The selected map has ',hfpp_drift_Nbins,' time bins and a maximum.'
+ print *,' drift distance of ',hfpp_drift_Xmax,' cm.\n'
+
+
+ elseif (hfpp_drift_type.eq.2) then ! polynomial ******************
+
+ read(LUN,*,err=903,end=900) hfpp_drift_Tmin, hfpp_drift_Tmax
+
+ read(LUN,*,err=903,end=900) hfpp_drift_Nterms
+ if (hfpp_drift_Nterms.gt.H_FPP_DRIFT_MAX_TERMS) then
+ hfpp_drift_Nterms = H_FPP_DRIFT_MAX_TERMS
+ endif
+
+ do i=1,hfpp_drift_Nterms
+ read(LUN,*,err=903,end=900)
+ > (hfpp_drift_coeffs(Plane,i),Plane=1,H_FPP_N_PLANES)
+ enddo
+
+ print *,' The selected drift map file uses a polynomial to calculate'
+ print *,' the drift in the focal plane polarimeter chambers.'
+ print *,' The order of this polynomial is :',hfpp_drift_Nterms
+ print *,' The applicability range of this drift map is:'
+ print *,' ',hfpp_drift_Tmin,' < t_drift < ',hfpp_drift_Tmax,'\n'
+
+ elseif (hfpp_drift_type.eq.3) then ! EJB map *********************
+
+ print *,' The selected drift map file uses a REALLY simple look-up table to determine'
+ print *,' the drift in the focal plane polarimeter chambers. (ejb)\n'
+ do i=1,100
+ read(LUN,*,err=901,end=900)ejbtime(i,1),ejbdrift(i,1)
+ enddo
+ do i=1,100
+ read(LUN,*,err=901,end=900)ejbtime(i,2),ejbdrift(i,2)
+ enddo
+ do i=1,100
+ read(LUN,*,err=901,end=900)ejbtime(i,3),ejbdrift(i,3)
+ enddo
+ do i=1,100
+ read(LUN,*,err=901,end=900)ejbtime(i,4),ejbdrift(i,4)
+ enddo
+
+ elseif (hfpp_drift_type.eq.4) then ! constant speed **************
+
+ read(LUN,*,err=905,end=900) hfpp_drift_dT
+ read(LUN,*,err=905,end=900) hfpp_drift_Tmin, hfpp_drift_Tmax
+
+ print *,' The selected drift map file uses constant drift'
+ print *,' velocity in the focal plane polarimeter chambers.'
+ print *,' The speed is :',hfpp_drift_dT,' cm/ns'
+ print *,' The applicability range of this drift map is:'
+ print *,' ',hfpp_drift_Tmin,' ns < t_drift < ',hfpp_drift_Tmax,' ns'
+ print *,' with a maximum drift distance of ',hfpp_drift_Xmax,' cm.\n'
+
+ elseif (hfpp_drift_type.eq.5) then ! experimental
+
+ read(LUN,*,err=905,end=900) hfpp_drift_Tmin, hfpp_drift_Tmax
+
+ print *,' The selected drift map file uses a special function'
+ print *,' for the focal plane polarimeter chambers.'
+ print *,' The applicability range of this drift map is:'
+ print *,' ',hfpp_drift_Tmin,' ns < t_drift < ',hfpp_drift_Tmax,' ns'
+ print *,' with a maximum drift distance of ',hfpp_drift_Xmax,' cm.\n'
+
+ else ! bad selector ****************
+ goto 904
+ endif
+
+ goto 990
+
+
+ 900 continue
+ err = 'error opening drift map file: '//hfpp_driftmap_filename
+ ABORT = .true.
+ call g_rep_err(ABORT,err)
+ goto 990
+
+ 901 continue
+ err = 'error reading drift map file header: '//hfpp_driftmap_filename
+ ABORT = .true.
+ call g_rep_err(ABORT,err)
+ goto 990
+
+ 902 continue
+ err = 'error reading drift map - bad lookup table: '//hfpp_driftmap_filename
+ ABORT = .true.
+ call g_rep_err(ABORT,err)
+ goto 990
+
+ 903 continue
+ err = 'error reading drift map - bad polynomial: '//hfpp_driftmap_filename
+ ABORT = .true.
+ call g_rep_err(ABORT,err)
+ goto 990
+
+ 904 continue
+ err = 'error reading drift map - unknown drift map type: '//hfpp_driftmap_filename
+ ABORT = .true.
+ call g_rep_err(ABORT,err)
+ goto 990
+
+ 905 continue
+ err = 'error reading drift map - bad constant speed: '//hfpp_driftmap_filename
+ ABORT = .true.
+ call g_rep_err(ABORT,err)
+ goto 990
+
+
+ 990 continue
+ close(LUN)
+ call G_IO_control(LUN,'FREE',ABORT,err) !free up IO channel
+ IF(ABORT) THEN
+ call G_add_path(here,err)
+ ENDIF
+
+
+ RETURN
+ END
diff --git a/HTRACKING/h_fpp_fit.f b/HTRACKING/h_fpp_fit.f
new file mode 100644
index 0000000..9197ccc
--- /dev/null
+++ b/HTRACKING/h_fpp_fit.f
@@ -0,0 +1,458 @@
+ SUBROUTINE h_fpp_fit_simple(DCset,Clusters,nPoints,Track,ABORT,err)
+*--------------------------------------------------------
+* Hall C HMS Focal Plane Polarimeter Code
+*
+* Purpose: simple fit to wire centroids, treat all hits equally
+*
+* Created by Frank R. Wesselmann, February 2004
+*
+*--------------------------------------------------------
+
+ IMPLICIT NONE
+
+ INCLUDE 'hms_data_structures.cmn'
+ INCLUDE 'hms_geometry.cmn'
+ include 'gen_detectorids.par'
+ include 'gen_decode_common.cmn'
+ INCLUDE 'hms_fpp_event.cmn'
+
+ character*16 here
+ parameter (here= 'h_fpp_fit_simple')
+
+ integer*4 DCset ! set of FPP DCs we are working on
+ integer*4 Clusters(H_FPP_N_DCINSET,H_FPP_N_DCLAYERS)
+ integer*4 nPoints
+ real*4 Track(5)
+
+ logical ABORT
+ character*(*) err
+
+ real*4 wirepos
+ real*4 Coords(H_FPP_MAX_FITPOINTS,2)
+ real*4 Sigmas(H_FPP_MAX_FITPOINTS)
+ real*4 Project(H_FPP_MAX_FITPOINTS,2)
+ real*4 FitParm(5) ! does NOT include hit count
+
+ integer*4 iChamber, iLayer, iCluster, iRaw, iHit, ii
+
+
+* * init result to bad
+ Track(1) = H_FPP_BAD_COORD !mx
+ Track(2) = H_FPP_BAD_COORD !bx
+ Track(3) = H_FPP_BAD_COORD !my
+ Track(4) = H_FPP_BAD_COORD !by
+ Track(5) = H_FPP_BAD_CHI2
+
+
+* * transfer abstract Clusters into linear array of hit coords
+ nPoints = 0
+
+ do iChamber=1,H_FPP_N_DCINSET
+ do iLayer=1,H_FPP_N_DCLAYERS
+
+ iCluster = Clusters(iChamber,iLayer)
+ if (iCluster.gt.0) then
+ do iRaw=1,HFPP_nHitsinCluster(DCset,iChamber,iLayer,iCluster)
+
+ nPoints = nPoints + 1
+ iHit = HFPP_Clusters(DCset,iChamber,iLayer,iCluster,iRaw)
+
+ wirepos = HFPP_layeroffset(DCset,iChamber,iLayer)
+ > + HFPP_spacing(DCset,iChamber,iLayer)*HFPP_raw_wire(iHit)
+
+* * tracking works in u-z coordinate system
+ Coords(nPoints,1) = wirepos
+ Coords(nPoints,2) = HFPP_layerZ(DCset,iChamber,iLayer)
+
+ Project(nPoints,1) = HFPP_direction(DCset,iChamber,iLayer,1)
+ Project(nPoints,2) = HFPP_direction(DCset,iChamber,iLayer,2)
+
+* * we dont use drift here so use 1/3 wire spacing as sigma!
+ Sigmas(nPoints) = (HFPP_spacing(DCset,iChamber,iLayer)/3.0)**2
+
+ enddo !iRaw
+ endif
+
+ enddo !iLayer
+ enddo !iChamber
+
+
+* * then we feed these coords to our fitting routine to get track
+ if (nPoints.gt.0) then
+
+ call h_fpp_fit3d(nPoints, Coords, Sigmas, Project, FitParm)
+
+* * transfer results
+ do ii=1,5
+ Track(ii) = FitParm(ii)
+ enddo !ii
+
+ endif
+
+
+ RETURN
+ END
+
+
+c==============================================================================
+c==============================================================================
+c==============================================================================
+c==============================================================================
+
+
+ SUBROUTINE h_fpp_fit_best_permutation(nPoints, Points, Sigma2s,
+ > Projects, Drifts, BestTrack)
+*--------------------------------------------------------
+* Hall C HMS Focal Plane Polarimeter Code
+*
+* Purpose: find best fit among the possible permutations obtainable
+* by arranging drift to be to left or right of each wire
+*
+* WARNING: the array Drifts contains the unsigned (L?R ambiguous)
+* drifts as input but _replaces_ them with the resolved
+* signed drifts as output
+* PROCTECT THE DATA IN THE CALLING ROUTINE!!!
+*
+* Created by Frank R. Wesselmann, February 2004
+*
+*--------------------------------------------------------
+
+ IMPLICIT NONE
+
+ INCLUDE 'hms_data_structures.cmn'
+ INCLUDE 'hms_geometry.cmn'
+ include 'gen_detectorids.par'
+ include 'gen_decode_common.cmn'
+ INCLUDE 'hms_fpp_event.cmn'
+ INCLUDE 'hms_fpp_params.cmn'
+
+ integer*4 nPoints
+ real*4 Points(H_FPP_MAX_FITPOINTS,2) ! u,z
+ real*4 Sigma2s(H_FPP_MAX_FITPOINTS)
+ real*4 Projects(H_FPP_MAX_FITPOINTS,3)
+ real*4 Drifts(H_FPP_MAX_FITPOINTS)
+ real*4 BestTrack(6) ! does NOT include hit count
+
+
+** now we use the supplied hits and the absolute drift distance (in layer!)
+** to find the permutation of positive and negative drift directions that
+** produces the best track
+
+
+ real*4 HitPos(H_FPP_MAX_FITPOINTS,2)
+ real*4 DriftAbs(H_FPP_MAX_FITPOINTS), driftreal(H_FPP_MAX_FITPOINTS)
+ real*4 BestDrifts(H_FPP_MAX_FITPOINTS)
+ real*4 Track(6) ! does NOT include hit count
+
+ integer*4 iHit, attempts, toggleat, ii
+
+ logical*4 drift2plus(H_FPP_MAX_FITPOINTS)
+ logical*4 anyPerm2try, carry
+
+
+* * init result to bad
+ BestTrack(1) = H_FPP_BAD_COORD ! mx
+ BestTrack(2) = H_FPP_BAD_COORD ! bx
+ BestTrack(3) = H_FPP_BAD_COORD ! my
+ BestTrack(4) = H_FPP_BAD_COORD ! by
+ BestTrack(5) = H_FPP_BAD_CHI2
+
+
+ if (nPoints.lt.HFPP_minsethits) RETURN
+
+
+* * init
+ do iHit=1,nPoints
+ DriftAbs(iHit) = Drifts(iHit) ! save absolute drifts
+ drift2plus(iHit) = .false. ! init left/right pointer to LEFT
+ BestDrifts(iHit) = H_FPP_BAD_DRIFT
+ enddo !iHit
+
+
+ anyPerm2try = .true.
+ attempts = 0
+ do while (anyPerm2try)
+ attempts = attempts+1
+
+ do iHit=1,nPoints
+
+* * figure real drift from absolute and sign
+ if (drift2plus(iHit)) then
+ driftreal(iHit) = abs(DriftAbs(iHit))
+ else
+ driftreal(iHit) = -1.*abs(DriftAbs(iHit))
+ endif
+
+* * adjust hit position based on drift
+ HitPos(iHit,1) = Points(iHit,1) + driftreal(iHit) ! u
+ HitPos(iHit,2) = Points(iHit,2) ! z
+
+ enddo ! iHit
+
+
+* * get track based on these drift values
+ call h_fpp_fit3d(nPoints, HitPos, Sigma2s, Projects, Track)
+
+* * remember best track and set of drift flags
+ if (Track(5).lt.BestTrack(5).and.Track(5).gt.0.0) then
+ do ii=1,6
+ BestTrack(ii) = Track(ii)
+ enddo !ii
+ do iHit=1, nPoints
+ BestDrifts(iHit) = driftreal(iHit)
+ enddo !iHit
+ endif
+
+* * get next combination of drift directions to try
+* * binary adding: 0 --> 1
+* * or 1 --> 0+carry
+* * ALWAYS start at the lowest position and add the carry (if any)
+* * to the next highest; continue until no more carry or out of bits
+* * skip layers without a hit in use!
+* * we COULD do this using real binary math but this is likely faster
+* * than re-discovering the state of each "bit" for each iteration...
+ toggleat=0
+ carry = .true.
+ do while (carry)
+ toggleat = toggleat+1
+ if (toggleat.gt.nPoints) EXIT
+ carry = drift2plus(toggleat)
+ drift2plus(toggleat) = .not.drift2plus(toggleat)
+ enddo
+
+ anyPerm2try = .not.carry !only get carry here if all permutations were tried
+
+ enddo !anyPerm2try
+
+
+ do iHit=1, nPoints
+ Drifts(iHit) = BestDrifts(iHit)
+ enddo !iHit
+
+ RETURN
+ END
+
+
+c==============================================================================
+c==============================================================================
+c==============================================================================
+c==============================================================================
+
+
+ SUBROUTINE h_fpp_fit3d(n, coords, sig2s, projs, params)
+*--------------------------------------------------------
+* Hall C HMS Focal Plane Polarimeter Code
+*
+* Purpose: fit set of hits in 3space to FPP track
+*
+* Created by Frank R. Wesselmann, February 2004
+*
+*--------------------------------------------------------
+
+ IMPLICIT NONE
+
+ INCLUDE 'hms_data_structures.cmn'
+
+* * function arguments INPUT: n, coords, sig2s OUTPUT: params, chi2
+
+ integer*4 n ! number of points to fit
+ real*4 coords(H_FPP_MAX_FITPOINTS,2) ! coords of points to fit u,z
+ real*4 sig2s(H_FPP_MAX_FITPOINTS) ! resolution (sigma**2) of each
+ ! point on own axis
+ real*4 projs(H_FPP_MAX_FITPOINTS,2) ! u=proj(1)*x + proj(2)*y
+ real*4 params(5) ! resulting fit params mx bx my by
+ ! and the reduced chi2 of fit
+
+***
+*** code is extension of simple 1-dimensional straight-line fit
+***
+*** generalization is that we fit orthogonal straight line projections
+*** in x VS z and in y VS z simultaneously
+***
+*** each fit point is specified by an arbitrary coordinate u, which is
+*** some linear combination of x and y, and the global z coordinate
+*** also supplied are the projection factprs Px and Py correlating u
+*** with x,y as given by u = Px * x + Py * y
+*** presumably, the coordinate u is in a system native to the supplied
+*** data point, as in the measureing direction of a wire chamber plane
+*** and these projection factors can be pre-determined and kept fixed
+***
+*** the fit results are still produced in x and y coordinates, slopes
+*** and offsets s. th. x = z * mx + bx
+*** and y = z * my + by
+***
+*** since the fit is a chi-squared minimization, a weight (or scale) is
+*** needed to judge each points' significance; these are also to be
+*** interpreted in the u coordinate and are to be supplied as their own
+*** square, to remove the repetitive squaring calculation
+***
+***
+*** the expressions below for mx, bx, my and by were obtained using the
+*** symbolic algebra software REDUCE with the command:
+***
+*** solve({Suxz = mx*Sxxzz + my*Sxyzz + bx*Sxxz + by*Sxyz,
+*** Suyz = mx*Sxyzz + my*Syyzz + bx*Sxyz + by*Syyz,
+*** Sux = mx*Sxxz + my*Sxyz + bx*Sxx + by*Sxy,
+*** Suy = mx*Sxyz + my*Syyz + bx*Sxy + by*Syy}, {mx,my,bx,by});
+***
+*** for the sums we use the terminology that the S... variables are sums over
+*** the different terms in the chi**2 expression where u indicates the
+*** measured coordinate value, x and y are the respective projection factors
+*** and z is the z coordinate of the measurement; repetitions indicate powers
+*** chi**2 = Sum (u_i - Px*mx*z_i - Px*bx - Py*my*z_i - Py*by)**2 / sig_i**2
+***
+
+
+* * short form of fit parameters
+ real*8 mx, my, bx, by
+
+* * short form of point coords, sigma and projection factors
+ real*8 ui,zi, Px,Py, sigma2
+
+* * various sums
+ real*8 Sux, Suxz, Suy, Suyz, Suu
+ real*8 Sxx, Sxxz, Sxxzz
+ real*8 Sxy, Sxyz, Sxyzz
+ real*8 Syy, Syyz, Syyzz
+ real*8 chi2
+
+ real*8 denom
+ integer*4 i
+
+
+ mx = dble(H_FPP_BAD_COORD)
+ bx = dble(H_FPP_BAD_COORD)
+ my = dble(H_FPP_BAD_COORD)
+ by = dble(H_FPP_BAD_COORD)
+
+ chi2 = dble(H_FPP_BAD_CHI2)
+
+ if (n .ge. 2) then
+
+ Suu = 0.D0
+ Sux = 0.D0
+ Suy = 0.D0
+ Suxz = 0.D0
+ Suyz = 0.D0
+ Sxx = 0.D0
+ Sxy = 0.D0
+ Syy = 0.D0
+ Sxxz = 0.D0
+ Sxyz = 0.D0
+ Syyz = 0.D0
+ Sxxzz = 0.D0
+ Sxyzz = 0.D0
+ Syyzz = 0.D0
+
+ do i=1, n
+ ui = dble(coords(i,1))
+ zi = dble(coords(i,2))
+ Px = dble(projs(i,1))
+ Py = dble(projs(i,2))
+ sigma2 = dble(sig2s(i)) !sig2s are already squared!
+
+ if (sigma2 .gt. 0.d0) then
+ Suu = Suu + ui*ui/sigma2
+ Sux = Sux + ui*Px/sigma2
+ Suy = Suy + ui*Py/sigma2
+ Suxz = Suxz + ui*Px*zi/sigma2
+ Suyz = Suyz + ui*Py*zi/sigma2
+ Sxx = Sxx + Px*Px/sigma2
+ Sxy = Sxy + Px*Py/sigma2
+ Syy = Syy + Py*Py/sigma2
+ Sxxz = Sxxz + Px*Px*zi/sigma2
+ Sxyz = Sxyz + Px*Py*zi/sigma2
+ Syyz = Syyz + Py*Py*zi/sigma2
+ Sxxzz = Sxxzz + Px*Px*zi*zi/sigma2
+ Sxyzz = Sxyzz + Px*Py*zi*zi/sigma2
+ Syyzz = Syyzz + Py*Py*zi*zi/sigma2
+ endif
+ enddo !n
+
+
+ denom = Sxx*Sxxzz*Syy*Syyzz - Sxx*Sxxzz*Syyz*Syyz - Sxx*Sxyz*Sxyz*Syyzz
+ > + Sxx*Sxyz*Sxyzz*Syyz + Sxx*Sxyz*Sxyzz*Syyz - Sxx*Sxyzz*Sxyzz*Syy
+ > - Sxxz*Sxxz*Syy*Syyzz + Sxxz*Sxxz*Syyz*Syyz + Sxxz*Sxy*Sxyz*Syyzz
+ > + Sxxz*Sxy*Sxyz*Syyzz - Sxxz*Sxy*Sxyzz*Syyz - Sxxz*Sxy*Sxyzz*Syyz
+ > - Sxxz*Sxyz*Sxyz*Syyz - Sxxz*Sxyz*Sxyz*Syyz + Sxxz*Sxyz*Sxyzz*Syy
+ > + Sxxz*Sxyz*Sxyzz*Syy - Sxxzz*Sxy*Sxy*Syyzz + Sxxzz*Sxy*Sxyz*Syyz
+ > + Sxxzz*Sxy*Sxyz*Syyz - Sxxzz*Sxyz*Sxyz*Syy + Sxy*Sxy*Sxyzz*Sxyzz
+ > - Sxy*Sxyz*Sxyz*Sxyzz - Sxy*Sxyz*Sxyz*Sxyzz + Sxyz*Sxyz*Sxyz*Sxyz
+
+ if (denom .ne. 0.D0) then
+
+ denom = 1.d0/denom
+
+ mx = denom *
+ > ( Sux*Sxxz*Syyz*Syyz - Sux*Sxxz*Syy*Syyzz + Sux*Sxy*Sxyz*Syyzz
+ > - Sux*Sxy*Sxyzz*Syyz - Sux*Sxyz*Sxyz*Syyz + Sux*Sxyz*Sxyzz*Syy
+ > + Suxz*Sxx*Syy*Syyzz - Suxz*Sxx*Syyz*Syyz - Suxz*Sxy*Sxy*Syyzz
+ > + Suxz*Sxy*Sxyz*Syyz + Suxz*Sxy*Sxyz*Syyz - Suxz*Sxyz*Sxyz*Syy
+ > + Suy*Sxx*Sxyzz*Syyz + Suy*Sxxz*Sxy*Syyzz - Suy*Sxxz*Sxyz*Syyz
+ > - Suy*Sxy*Sxyz*Sxyzz + Suy*Sxyz*Sxyz*Sxyz + Suyz*Sxx*Sxyz*Syyz
+ > - Suyz*Sxx*Sxyzz*Syy - Suyz*Sxxz*Sxy*Syyz + Suyz*Sxxz*Sxyz*Syy
+ > + Suyz*Sxy*Sxy*Sxyzz - Suyz*Sxy*Sxyz*Sxyz - Suy*Sxx*Sxyz*Syyzz)
+
+ my = denom *
+ > ( Sux*Sxxz*Sxyzz*Syy - Sux*Sxxz*Sxyz*Syyz + Sux*Sxxzz*Sxy*Syyz
+ > - Sux*Sxxzz*Sxyz*Syy - Sux*Sxy*Sxyz*Sxyzz + Sux*Sxyz*Sxyz*Sxyz
+ > + Suxz*Sxx*Sxyz*Syyz - Suxz*Sxx*Sxyzz*Syy - Suxz*Sxxz*Sxy*Syyz
+ > + Suxz*Sxxz*Sxyz*Syy + Suxz*Sxy*Sxy*Sxyzz - Suxz*Sxy*Sxyz*Sxyz
+ > - Suy*Sxx*Sxxzz*Syyz + Suy*Sxx*Sxyz*Sxyzz + Suy*Sxxz*Sxxz*Syyz
+ > - Suy*Sxxz*Sxy*Sxyzz - Suy*Sxxz*Sxyz*Sxyz + Suy*Sxxzz*Sxy*Sxyz
+ > + Suyz*Sxx*Sxxzz*Syy - Suyz*Sxx*Sxyz*Sxyz - Suyz*Sxxz*Sxxz*Syy
+ > + Suyz*Sxxz*Sxy*Sxyz + Suyz*Sxxz*Sxy*Sxyz - Suyz*Sxxzz*Sxy*Sxy)
+
+ bx = denom *
+ > ( Sux*Sxxzz*Syy*Syyzz - Sux*Sxxzz*Syyz*Syyz - Sux*Sxyz*Sxyz*Syyzz
+ > + Sux*Sxyz*Sxyzz*Syyz + Sux*Sxyz*Sxyzz*Syyz - Sux*Sxyzz*Sxyzz*Syy
+ > + Suxz*Sxxz*Syyz*Syyz + Suxz*Sxy*Sxyz*Syyzz - Suxz*Sxy*Sxyzz*Syyz
+ > - Suxz*Sxyz*Sxyz*Syyz + Suxz*Sxyz*Sxyzz*Syy + Suy*Sxxz*Sxyz*Syyzz
+ > - Suy*Sxxz*Sxyzz*Syyz - Suy*Sxxzz*Sxy*Syyzz + Suy*Sxxzz*Sxyz*Syyz
+ > + Suy*Sxy*Sxyzz*Sxyzz - Suy*Sxyz*Sxyz*Sxyzz - Suyz*Sxxz*Sxyz*Syyz
+ > + Suyz*Sxxz*Sxyzz*Syy + Suyz*Sxxzz*Sxy*Syyz - Suyz*Sxxzz*Sxyz*Syy
+ > - Suyz*Sxy*Sxyz*Sxyzz + Suyz*Sxyz*Sxyz*Sxyz - Suxz*Sxxz*Syy*Syyzz)
+
+ by = denom *
+ > ( Sux*Sxxz*Sxyz*Syyzz - Sux*Sxxz*Sxyzz*Syyz - Sux*Sxxzz*Sxy*Syyzz
+ > + Sux*Sxxzz*Sxyz*Syyz + Sux*Sxy*Sxyzz*Sxyzz - Sux*Sxyz*Sxyz*Sxyzz
+ > - Suxz*Sxx*Sxyz*Syyzz + Suxz*Sxx*Sxyzz*Syyz + Suxz*Sxxz*Sxy*Syyzz
+ > - Suxz*Sxxz*Sxyz*Syyz - Suxz*Sxy*Sxyz*Sxyzz + Suxz*Sxyz*Sxyz*Sxyz
+ > + Suy*Sxx*Sxxzz*Syyzz - Suy*Sxx*Sxyzz*Sxyzz - Suy*Sxxz*Sxxz*Syyzz
+ > + Suy*Sxxz*Sxyz*Sxyzz + Suy*Sxxz*Sxyz*Sxyzz - Suy*Sxxzz*Sxyz*Sxyz
+ > + Suyz*Sxx*Sxyz*Sxyzz + Suyz*Sxxz*Sxxz*Syyz - Suyz*Sxxz*Sxy*Sxyzz
+ > - Suyz*Sxxz*Sxyz*Sxyz + Suyz*Sxxzz*Sxy*Sxyz - Suyz*Sxx*Sxxzz*Syyz)
+
+ chi2 = Suu - mx*Suxz - my*Suyz - bx*Sux - by*Suy
+ > - mx*Suxz + mx*mx*Sxxzz + mx*my*Sxyzz + mx*bx*Sxxz + mx*by*Sxyz
+ > - my*Suyz + my*mx*Sxyzz + my*my*Syyzz + my*bx*Sxyz + my*by*Syyz
+ > - bx*Sux + bx*mx*Sxxz + bx*my*Sxyz + bx*bx*Sxx + bx*by*Sxy
+ > - by*Suy + by*mx*Sxyz + by*my*Syyz + by*bx*Sxy + by*by*Syy
+
+ if (n.gt.4) then
+* * reduced chi**2 -- 4 params & only 1 coord per data point
+ chi2 = chi2/dfloat(n-4)
+ else
+ chi2 = -1.d0
+ endif
+ endif !denom
+
+
+ else ! whatever happened, no straight line fit is to be found here...
+
+ mx = dble(H_FPP_BAD_COORD)
+ bx = dble(H_FPP_BAD_COORD)
+ my = dble(H_FPP_BAD_COORD)
+ by = dble(H_FPP_BAD_COORD)
+ chi2 = dble(H_FPP_BAD_CHI2)
+
+ endif
+
+ params(1) = sngl(mx)
+ params(2) = sngl(bx)
+ params(3) = sngl(my)
+ params(4) = sngl(by)
+ params(5) = sngl(chi2)
+
+ RETURN
+ END
diff --git a/HTRACKING/h_fpp_geometry.f b/HTRACKING/h_fpp_geometry.f
new file mode 100644
index 0000000..20ee5ee
--- /dev/null
+++ b/HTRACKING/h_fpp_geometry.f
@@ -0,0 +1,508 @@
+*--------------------------------------------------------
+*--------------------------------------------------------
+*--------------------------------------------------------
+*
+* Hall C HMS Focal Plane Polarimeter Code
+*
+* Created by Frank R. Wesselmann, February 2004
+*
+*--------------------------------------------------------
+*
+* this file contains several small geometry related routines
+*
+*--------------------------------------------------------
+
+
+
+ SUBROUTINE h_fpp_uTrack(iSet,iCham,iLay,iTrack,uCoord)
+*--------------------------------------------------------
+* Hall C HMS Focal Plane Polarimeter Code
+*
+* Purpose: determine in-layer coordinate of intersection
+* of given track and given drift chamber layer
+*
+* Created by Frank R. Wesselmann, February 2004
+*
+*--------------------------------------------------------
+
+ IMPLICIT NONE
+
+ INCLUDE 'hms_data_structures.cmn'
+ INCLUDE 'hms_geometry.cmn'
+ include 'gen_detectorids.par'
+ include 'gen_decode_common.cmn'
+ INCLUDE 'hms_fpp_event.cmn'
+
+ integer*4 iSet, iCham, iLay, iTrack
+ real*4 uCoord
+
+ real*4 x,y,z
+
+ uCoord = H_FPP_BAD_COORD
+
+ if (HFPP_N_tracks(iSet).le.0) RETURN
+ if (iTrack.le.0.or.iTrack.gt.HFPP_N_tracks(iSet)) RETURN
+
+ if (iSet.le.0.or.iSet.gt.H_FPP_N_DCSETS) RETURN
+ if (iCham.le.0.or.iCham.gt.H_FPP_N_DCINSET) RETURN
+ if (iLay.le.0.or.iLay.gt.H_FPP_N_DCLAYERS) RETURN
+
+ z = HFPP_layerZ(iSet,iCham,iLay)
+
+ x = HFPP_track_fine(iSet,iTrack,2) + HFPP_track_fine(iSet,iTrack,1)*z
+ y = HFPP_track_fine(iSet,iTrack,4) + HFPP_track_fine(iSet,iTrack,3)*z
+
+* * determine generalized in-layer coordinate
+ uCoord = HFPP_direction(iSet,iCham,iLay,1) * x
+ > + HFPP_direction(iSet,iCham,iLay,2) * y
+
+ RETURN
+ END
+
+
+c==============================================================================
+c==============================================================================
+c==============================================================================
+c==============================================================================
+
+
+ SUBROUTINE h_fpp_FP2DC(iSet,Slope,FPcoords,DCcoords)
+*--------------------------------------------------------
+* Hall C HMS Focal Plane Polarimeter Code
+*
+* Purpose: transforms coordinates from HMS focal plane
+* system to the coord system of the specified
+* set of FPP drift chambers
+* alternatively transforms SLOPES
+*
+* Created by Frank R. Wesselmann, February 2004
+*
+*--------------------------------------------------------
+
+ IMPLICIT NONE
+
+ INCLUDE 'hms_data_structures.cmn'
+ INCLUDE 'hms_geometry.cmn'
+c INCLUDE 'hms_fpp_event.cmn'
+
+ integer*4 iSet
+ logical*4 Slope
+ real*4 FPcoords(3), DCcoords(3)
+
+ integer*4 i,j
+ real*4 MYcoords(3)
+
+
+ if (Slope) then
+* * for slopes, we can ignore any position offset
+ MYcoords(1) = FPcoords(1)
+ MYcoords(2) = FPcoords(2)
+ MYcoords(3) = FPcoords(3)
+ else
+* * for coordinates, we need to subtract the offset
+ MYcoords(1) = FPcoords(1) - HFPP_Xoff(iSet)
+ MYcoords(2) = FPcoords(2) - HFPP_Yoff(iSet)
+ MYcoords(3) = FPcoords(3) - HFPP_Zoff(iSet)
+ endif
+
+* * use rotation matrix to rotate from focal plane coords to DCset coords
+ do i=1,3 !x,y,z for DC
+ DCcoords(i) = 0.0
+ do j=1,3 !x,y,z for FP
+ DCcoords(i) = DCcoords(i) + HFPP_Mrotation(iSet,i,j) * MYcoords(j)
+ enddo
+ enddo
+
+ if (slope) then
+* * for slopes, we need to renormalize to dz=1
+ if (DCcoords(3).eq.0.0) then
+ DCcoords(1) = H_FPP_BAD_COORD
+ DCcoords(2) = H_FPP_BAD_COORD
+ else
+ DCcoords(1) = DCcoords(1) / DCcoords(3)
+ DCcoords(2) = DCcoords(2) / DCcoords(3)
+ DCcoords(3) = 1.0
+ endif
+ endif
+
+
+ RETURN
+ END
+
+
+c==============================================================================
+c==============================================================================
+c==============================================================================
+c==============================================================================
+
+
+ SUBROUTINE h_fpp_DC2FP(iSet,Slope,DCcoords,FPcoords)
+*--------------------------------------------------------
+* Hall C HMS Focal Plane Polarimeter Code
+*
+* Purpose: transforms coordinates from the coord system
+* of the specified set of FPP drift chambers to
+* the the HMS focal plane system
+* alternatively transforms SLOPES
+*
+* Created by Frank R. Wesselmann, February 2004
+*
+*--------------------------------------------------------
+
+ IMPLICIT NONE
+
+ INCLUDE 'hms_data_structures.cmn'
+ INCLUDE 'hms_geometry.cmn'
+c INCLUDE 'hms_fpp_event.cmn'
+
+ integer*4 iSet
+ logical*4 Slope
+ real*4 DCcoords(3), FPcoords(3)
+
+ integer*4 i,j
+
+
+* * use INVERSE rotation matrix to rotate from DCset coords to focal plane coords
+ do i=1,3 !x,y,z for FP
+ FPcoords(i) = 0.0
+ do j=1,3 !x,y,z for DC
+ FPcoords(i) = FPcoords(i) + HFPP_Irotation(iSet,i,j) * DCcoords(j)
+ enddo
+ enddo
+
+ if (Slope) then
+* * for slopes, we need to renormalize to dz=1 if possible
+ if (FPcoords(3).eq.0.0) then
+ FPcoords(1) = H_FPP_BAD_COORD
+ FPcoords(2) = H_FPP_BAD_COORD
+ else
+ FPcoords(1) = FPcoords(1) / FPcoords(3)
+ FPcoords(2) = FPcoords(2) / FPcoords(3)
+ FPcoords(3) = 1.0
+ endif
+
+ else
+* * for coordinates, we need to add the offset
+ FPcoords(1) = FPcoords(1) + HFPP_Xoff(iSet)
+ FPcoords(2) = FPcoords(2) + HFPP_Yoff(iSet)
+ FPcoords(3) = FPcoords(3) + HFPP_Zoff(iSet)
+ endif
+
+ RETURN
+ END
+
+
+c==============================================================================
+c==============================================================================
+c==============================================================================
+c==============================================================================
+
+
+ SUBROUTINE h_fpp_closest(Track1,Track2,sclose,zclose)
+*--------------------------------------------------------
+* Hall C HMS Focal Plane Polarimeter Code
+*
+* Purpose: given two lines (tracks) in space, determine
+* the distance of closest approach and the
+* average z-coordinate of the closest approach
+*
+* Created by Frank R. Wesselmann, February 2004
+*
+*--------------------------------------------------------
+
+ IMPLICIT NONE
+
+ INCLUDE 'hms_data_structures.cmn'
+
+ real*4 Track1(4), Track2(4) ! IN mx,bx,my,by of two tracks
+ real*4 sclose ! OUT distance at closest approach
+ real*4 zclose ! OUT average z-coordinate at c.a.
+
+ real*8 mx1,my1,bx1,by1
+ real*8 mx2,my2,bx2,by2
+ real*8 a1,a2,b,c1,c2
+ real*8 x1,x2,y1,y2,z1,z2
+ real*8 denom
+
+ mx1 = dble(Track1(1))
+ bx1 = dble(Track1(2))
+ my1 = dble(Track1(3))
+ by1 = dble(Track1(4))
+
+ mx2 = dble(Track2(1))
+ bx2 = dble(Track2(2))
+ my2 = dble(Track2(3))
+ by2 = dble(Track2(4))
+
+ a1 = mx1*mx1 + my1*my1 + 1
+ a2 = mx2*mx2 + my2*my2 + 1
+ b = mx1*mx2 + my1*my2 + 1
+ c1 = (bx1 - bx2)*mx1 + (by1 - by2)*my1
+ c2 = (bx1 - bx2)*mx2 + (by1 - by2)*my2
+
+ denom = b*b - a1*a2
+ if (denom.eq.0.0d0) then
+ zclose = H_FPP_BAD_COORD
+ sclose = H_FPP_BAD_COORD
+ else
+ z1 = (a2*c1 - b*c2) / denom
+ z2 = ( b*c1 - a1*c2) / denom
+
+ x1 = z1 * mx1 + bx1
+ y1 = z1 * my1 + by1
+
+ x2 = z2 * mx2 + bx2
+ y2 = z2 * my2 + by2
+
+ zclose = sngl(0.5d0*(z1 + z2))
+ sclose = sngl(sqrt( (x1-x2)**2 + (y1-y2)**2 + (z1-z2)**2 ))
+ endif
+
+c write(*,*)'Zclose calculation 1: ',mx1,mx2,my1,my2
+c write(*,*)'Zclose calculation 2: ',bx1,bx2,by1,by2
+c write(*,*)'Zclose calculation 2a:',b,denom
+c write(*,*)'Zclose calculation 2b:',a1,a2,c1,c2
+c write(*,*)'Zclose calculation 3: ',ztrack2,z1,z2
+c write(*,*)'Zclose calculation 4: ',x1,x2,y1,y2
+c write(*,*)'Zclose calculation 5: ',zclose,sclose
+
+ RETURN
+ END
+
+c==============================================================================
+c==============================================================================
+c==============================================================================
+c==============================================================================
+
+
+ SUBROUTINE h_fpp_conetest(Track1,DCset,zclose,theta,icone)
+*--------------------------------------------------------
+* Hall C HMS Focal Plane Polarimeter Code
+*
+* Purpose: Calculate FPP conetest variable - assumes elliptical projection
+* onto the last layer of the 2nd chamber in a set.
+*
+* Created by Edward J. Brash, September 2007
+*
+*--------------------------------------------------------
+
+ IMPLICIT NONE
+
+ INCLUDE 'hms_data_structures.cmn'
+ INCLUDE 'hms_geometry.cmn'
+
+ real*4 Track1(4) ! IN mx,bx,my,by of front track
+ integer*4 DCset ! which chamber set we are in
+ real*4 zclose ! previously calculated z of closest approach
+ real*4 theta ! polar scattering angle
+ integer*4 icone ! Cone-test variable (1=pass, 0=fail)
+
+ real*8 mx1,my1,bx1,by1
+ real*4 ztrack2 ! central z-position of FPP set
+ real*4 zback_off ! offset from cntrl. pos. of last layer
+ real*8 zback,xfront,yfront,ttheta
+ real*8 r1x,r1y,r2x,r2y,xmin,xmax,ymin,ymax
+ real*8 xpt1,xpt2,xpt3,xpt4,ypt1,ypt2,ypt3,ypt4
+ integer*4 iSet,iChamber,iLayer,iPlane
+
+ mx1 = Track1(1)*1.0d0
+ bx1 = Track1(2)*1.0d0
+ my1 = Track1(3)*1.0d0
+ by1 = Track1(4)*1.0d0
+
+ xmin=HFPP_Xoff(DCset)-HFPP_Xsize(DCset)/2.0
+ xmax=HFPP_Xoff(DCset)+HFPP_Xsize(DCset)/2.0
+ ymin=HFPP_Yoff(DCset)-HFPP_Ysize(DCset)/2.0
+ ymax=HFPP_Yoff(DCset)+HFPP_Ysize(DCset)/2.0
+
+ icone=1
+
+ iSet=DCset
+ do iChamber=1, H_FPP_N_DCINSET
+ do iLayer=1, H_FPP_N_DCLAYERS
+
+ iPlane = H_FPP_N_DCLAYERS * H_FPP_N_DCINSET * (iSet-1)
+ > + H_FPP_N_DCLAYERS * (iChamber-1)
+ > + iLayer
+
+ zback_off = HFPP_layerZ(iSet,iChamber,iLayer)
+ ztrack2 = HFPP_Zoff(iSet)
+ zback = ztrack2 + zback_off
+
+ xfront = bx1 + mx1*zback
+ yfront = by1 + my1*zback
+
+ ttheta=tan(theta)
+
+ r1x = (zback-zclose)*(mx1 + (ttheta-mx1)/(1.0+ttheta*mx1))
+ r2x = (zback-zclose)*((ttheta+mx1)/(1.0-ttheta*mx1) - mx1)
+ r1y = (zback-zclose)*(my1 +
+ & (ttheta-my1)/(1.0+ttheta*my1))
+ r2y = (zback-zclose)*((ttheta+my1)/(1.0-ttheta*my1)
+ & - my1)
+
+ xpt1=xfront-abs(r1x)
+ ypt1=yfront
+ xpt2=xfront+abs(r2x)
+ ypt2=yfront
+ xpt3=xfront
+ ypt3=yfront-abs(r1y)
+ xpt4=xfront
+ ypt4=yfront+abs(r2y)
+
+ if(xpt1.lt.xmin)icone=0
+ if(xpt2.gt.xmax)icone=0
+ if(ypt3.lt.ymin)icone=0
+ if(ypt4.gt.ymax)icone=0
+
+c if(icone.eq.0) then
+c write(*,*)'chamber limits ',xmin,xmax,ymin,ymax
+c write(*,*)'(',xpt1,',',ypt1,')'
+c write(*,*)'(',xpt2,',',ypt2,')'
+c write(*,*)'(',xpt3,',',ypt3,')'
+c write(*,*)'(',xpt4,',',ypt4,')'
+c endif
+
+ enddo ! iLayer
+ enddo ! iChamber
+
+ RETURN
+ END
+
+c==============================================================================
+c==============================================================================
+c==============================================================================
+c==============================================================================
+
+
+ SUBROUTINE h_fpp_relative_angles(mx_ref,my_ref,mx_new,my_new,theta,phi)
+*--------------------------------------------------------
+* Hall C HMS Focal Plane Polarimeter Code
+*
+* Purpose: find the POLAR angles between two tracks
+* reference track is likely the incident HMS track, and the
+* new track is probably the FPP track
+* tracks are only identified by horizontal and vertical slopes
+* we rotate both tracks s.th. the ref track is the new z axis
+* then the simple polar angles of the rotated "new" track are
+* the ones we want
+*
+* Created by Frank R. Wesselmann, February 2004
+*
+*--------------------------------------------------------
+
+ IMPLICIT NONE
+
+ INCLUDE 'hms_data_structures.cmn'
+
+ real*4 mx_ref,my_ref ! IN slopes of reference track (incident?)
+ real*4 mx_new,my_new ! IN slopes of interesting track (analyzer?)
+ real*4 theta,phi ! OUT _polar_ angles of new track relative to ref
+
+ real*8 alpha, beta ! horizontal and vertical angle of ref track
+ real*8 M(3,3) ! rotation matrix: (row,column)
+ real*8 r_i(3) ! unit vector along "new" track before rotation
+ real*8 r_f(3) ! unit vector along "new" track after rotation
+ real*8 r_in(3) ! unit vector along "in" track before rotation
+ real*8 r_fin(3) ! unit vector along "in" track after rotation
+ real*8 magnitude
+ real*8 dtheta,dphi ! for convenience, double precision versions of OUT
+ real*8 x,y,z,xin,yin,zin
+
+ integer i,j
+
+
+* * figure out rotation matrix
+
+c write(*,*)'Theta calculation 1: ',mx_ref,mx_new,my_ref,my_new
+
+ beta = datan(dble(my_ref))
+ alpha = datan(dble(mx_ref)*dcos(beta)) ! this ought to be safe as the negative angle works
+
+ M(1,1) = dcos(alpha)
+ M(1,2) = -1.d0*dsin(alpha)*dsin(beta)
+ M(1,3) = -1.d0*dsin(alpha)*dcos(beta)
+
+ M(2,1) = 0.d0
+ M(2,2) = dcos(beta)
+ M(2,3) = -1.d0* dsin(beta)
+
+ M(3,1) = dsin(alpha)
+ M(3,2) = dcos(alpha)*dsin(beta)
+ M(3,3) = dcos(alpha)*dcos(beta)
+
+* * normalize incoming vector
+
+ xin = dble(mx_ref)
+ yin = dble(my_ref)
+ zin = 1.d0
+ magnitude = dsqrt(xin*xin+yin*yin+zin*zin)
+ r_in(1)=xin/magnitude
+ r_in(2)=yin/magnitude
+ r_in(3)=zin/magnitude
+
+ do i=1,3
+ r_fin(i) = 0.d0
+ do j=1,3
+ r_fin(i) = r_fin(i) + M(i,j)*r_in(j)
+ enddo !j
+ enddo !i
+
+c write(*,*)r_in(1),r_in(2),r_in(3)
+c write(*,*)r_fin(1),r_fin(2),r_fin(3)
+
+* * normalize direction vector
+
+ x = dble(mx_new)
+ y = dble(my_new)
+ z = 1.d0
+ magnitude = dsqrt(x*x + y*y + z*z)
+ r_i(1) = x / magnitude
+ r_i(2) = y / magnitude
+ r_i(3) = z / magnitude
+
+
+* * rotate vector of interest
+
+ do i=1,3
+ r_f(i) = 0.d0
+ do j=1,3
+ r_f(i) = r_f(i) + M(i,j)*r_i(j)
+ enddo !j
+ enddo !i
+
+c write(*,*)r_i(1),r_i(2),r_i(3)
+c write(*,*)r_f(1),r_f(2),r_f(3)
+
+* * find polar angles
+
+ dtheta = dacos(r_f(3)) ! z = cos(theta)
+
+ if (r_f(1).ne.0.d0) then
+ if (r_f(1).gt.0.d0) then
+ if (r_f(2).gt.0.d0) then
+ dphi = datan( r_f(2)/r_f(1) ) ! y/x = tan(phi)
+ else
+ dphi = datan( r_f(2)/r_f(1) ) ! y/x = tan(phi)
+ dphi = dphi + 6.28318d0
+ endif
+ else
+ dphi = datan( r_f(2)/r_f(1) ) ! y/x = tan(phi)
+ dphi = dphi + 3.14159d0
+ endif
+ elseif (r_f(2).gt.0.d0) then
+ dphi = 1.57080d0 ! phi = +90
+ elseif (r_f(2).lt.0.d0) then
+ phi = 4.71239d0 ! phi = +270
+ else
+ dphi = 0.d0 ! phi undefined if theta=0 or r=0
+ endif
+
+ theta = sngl(dtheta)
+ phi = sngl(dphi)
+
+c write(*,*)'Theta, phi = ',theta*180.0/3.14159265,phi*180.0/3.14159265
+
+
+ RETURN
+ END
diff --git a/HTRACKING/h_fpp_statistics.f b/HTRACKING/h_fpp_statistics.f
new file mode 100644
index 0000000..b81d4e4
--- /dev/null
+++ b/HTRACKING/h_fpp_statistics.f
@@ -0,0 +1,211 @@
+ SUBROUTINE h_fpp_statistics(ABORT,err)
+*--------------------------------------------------------
+* Hall C HMS Focal Plane Polarimeter Code
+*
+* Purpose: statistical studies of FPP portion of HMS event
+*
+* Created by Frank R. Wesselmann, February 2004
+*
+*--------------------------------------------------------
+
+ IMPLICIT NONE
+
+ INCLUDE 'hms_data_structures.cmn'
+ INCLUDE 'hms_geometry.cmn'
+ INCLUDE 'hms_statistics.cmn'
+ include 'gen_detectorids.par'
+ include 'gen_decode_common.cmn'
+ INCLUDE 'hms_fpp_event.cmn'
+ INCLUDE 'hms_fpp_params.cmn'
+ include 'hms_id_histid.cmn'
+
+ character*16 here
+ parameter (here= 'h_fpp_statistics')
+
+ logical ABORT
+ character*(*) err
+
+ real*4 uTrack, uWire
+ real*4 mindist, rdist, rtime, residual, drift
+ real*4 DC_coords(3), FP_coords(3)
+ real*4 x,y,z,mx,my,bx,by,z0,u, wirepos
+
+ integer*4 iPlane, iSet, iCham, iLay, iClust, iTrk, iHit, iRaw, iWire, ii
+
+
+ ABORT= .FALSE.
+ err= ' '
+
+
+** geometric alignment against HMS
+
+ if (.TRUE.) then
+
+* * for each trigger, find the distance between each wire that fired
+* * and the HMS track IN THAT WIRE'S PLANE'S COORDINATE
+ if (HNTRACKS_FP.ge.1) then
+ do iSet=1,H_FPP_N_DCSETS
+ do iCham=1,H_FPP_N_DCINSET
+ do iLay=1,H_FPP_N_DCLAYERS
+ if (HFPP_nClusters(iSet,iCham,iLay).gt.0) then
+
+* * rotate to local coords, project HMS track to this plane
+ FP_coords(1) = hsx_fp ! transform offsets
+ FP_coords(2) = hsy_fp
+ FP_coords(3) = 0.0
+ call h_fpp_FP2DC(iSet,.false.,FP_coords,DC_coords)
+ bx = DC_coords(1)
+ by = DC_coords(2)
+ z0 = DC_coords(3)
+
+ FP_coords(1) = hsxp_fp ! transform slope
+ FP_coords(2) = hsyp_fp
+ FP_coords(3) = 1.0
+ call h_fpp_FP2DC(iSet,.true.,FP_coords,DC_coords)
+ mx = DC_coords(1)
+ my = DC_coords(2)
+
+ z = HFPP_layerZ(iSet,iCham,iLay)
+ x = bx + mx * (z-z0)
+ y = by + my * (z-z0)
+
+* * determine generalized in-layer coordinate
+ u = HFPP_direction(iSet,iCham,iLay,1) * x
+ > + HFPP_direction(iSet,iCham,iLay,2) * y
+
+* print *,' A ',x,y,z, ' z0 ',z0,' s ',mx,my
+* print *,' B ',hsx_fp + hsxp_fp*(z+HFPP_Zoff(iSet)),
+* > hsy_fp + hsyp_fp*(z+HFPP_Zoff(iSet)),
+* > z+HFPP_Zoff(iSet), ' s ',hsxp_fp,hsyp_fp
+
+ do iClust=1,HFPP_nClusters(iSet,iCham,iLay)
+ do iHit=1,HFPP_nHitsinCluster(iSet,iCham,iLay,iClust)
+
+ iRaw = HFPP_Clusters(iSet,iCham,iLay,iClust,iHit)
+ iWire = HFPP_raw_wire(iRaw)
+
+ wirepos = HFPP_layeroffset(iSet,iCham,iLay)
+ > + HFPP_spacing(iSet,iCham,iLay)*iWire
+
+ HFPP_dHMS(iSet,iCham,iLay,iClust,iHit) = u - wirepos
+
+ enddo !iHit
+ enddo !iClust
+
+ endif !HFPP_nClusters
+ enddo !iLay
+ enddo !iCham
+ enddo !iSet
+ endif !HNTRACKS_FP
+
+
+ endif !hard-coded
+
+
+** basic efficiency determinations
+
+* * in each layer, find which wire a track went through
+ do iSet=1,H_FPP_N_DCSETS
+ if (HFPP_N_tracks(iSet).gt.0) then
+
+ do iTrk=1,HFPP_N_tracks(iSet)
+ do iCham=1,H_FPP_N_DCINSET
+ do iLay=1,H_FPP_N_DCLAYERS
+
+ call h_fpp_uTrack(iSet,iCham,iLay,iTrk,uTrack)
+
+ HFPP_stat_shouldhit(iSet,iCham,iLay,iTrk) =
+ > int(0.5 + (uTrack - HFPP_layeroffset(iSet,iCham,iLay))
+ > / HFPP_spacing(iSet,iCham,iLay))
+
+* * now lets see if ANY wire within acceptable range WAS hit
+* * and find the closest one, record the distance
+ mindist = H_FPP_BAD_COORD
+ HFPP_stat_diddhit(iSet,iCham,iLay,iTrk) = .false.
+ if (HFPP_nClusters(iSet,iCham,iLay).gt.0) then
+ do iClust=1,HFPP_nClusters(iSet,iCham,iLay)
+ do iHit=1,HFPP_nHitsinCluster(iSet,iCham,iLay,iClust)
+
+ iRaw = HFPP_Clusters(iSet,iCham,iLay,iClust,iHit)
+ iWire = HFPP_raw_wire(iRaw)
+
+ rdist = uTrack - iWire * HFPP_spacing(iSet,iCham,iLay)
+ > - HFPP_layeroffset(iSet,iCham,iLay)
+ if (abs(rdist).lt.abs(mindist)) then
+ mindist = rdist
+ endif
+
+ if (abs(iWire-HFPP_stat_shouldhit(iSet,iCham,iLay,iTrk))
+ > .le. HFPP_effic_dist) then
+ HFPP_stat_diddhit(iSet,iCham,iLay,iTrk) = .true.
+ endif
+
+ enddo !iHit
+ enddo !iClust
+ endif
+
+ HFPP_stat_dist2closest(iSet,iCham,iLay,iTrk) = mindist
+
+* * convert to plane #s for CTP
+ iPlane = H_FPP_N_DCLAYERS * H_FPP_N_DCINSET * (iSet-1)
+ > + H_FPP_N_DCLAYERS * (iCham-1)
+ > + iLay
+
+ HFPP_stat_planeshould(iPlane,iTrk)
+ > = HFPP_stat_shouldhit(iSet,iCham,iLay,iTrk)
+ HFPP_stat_planedidd(iPlane,iTrk)
+ > = HFPP_stat_diddhit(iSet,iCham,iLay,iTrk)
+
+ enddo !iLay
+ enddo !iCham
+ enddo !iTrk
+
+ endif
+ enddo !iSet
+
+
+* * for external analysis, we need the wire number of hits, not the cluster
+* * reduce clusters to just one hit (wire) -- pick shortest drift time
+ do iSet=1,H_FPP_N_DCSETS
+ if (HFPP_N_tracks(iSet).ge.1) then
+ do iTrk=1,HFPP_N_tracks(iSet)
+ do iCham=1,H_FPP_N_DCINSET
+ do iLay=1,H_FPP_N_DCLAYERS
+
+ iClust = HFPP_TrackCluster(iSet,iCham,iLay,iTrk)
+ ii = 0
+ residual = H_FPP_BAD_DRIFT
+ if (iClust.gt.0) then
+
+ rtime = H_FPP_BAD_TIME
+ if (HFPP_nHitsinCluster(iSet,iCham,iLay,iClust).gt.0) then
+ do iHit = 1,HFPP_nHitsinCluster(iSet,iCham,iLay,iClust)
+ iRaw = HFPP_Clusters(iSet,iCham,iLay,iClust,iHit)
+ if (HFPP_HitTime(iRaw).lt.rtime) then
+ ii = iRaw
+ rtime = HFPP_HitTime(iRaw)
+ endif
+ enddo !iHit
+ endif
+
+* * now also figure the residual of this hit
+ iWire = HFPP_raw_wire(ii)
+ uWire = HFPP_layeroffset(iSet,iCham,iLay)
+ > + HFPP_spacing(iSet,iCham,iLay)*iWire
+ drift = HFPP_drift_dist(iSet,iCham,iLay,iWire)
+ call h_fpp_uTrack(iSet,iCham,iLay,iTrk,uTrack)
+ residual = uTrack - (uWire + drift)
+
+ endif !iClust
+ HFPP_TrackHit(iSet,iCham,iLay,iTrk) = ii
+ HFPP_track_residual(iSet,iCham,iLay,iTrk) = residual
+
+ enddo !iLay
+ enddo !iCham
+ enddo !iTrk
+ endif
+ enddo !iSet
+
+
+ RETURN
+ END
diff --git a/HTRACKING/h_fpp_tracking.f b/HTRACKING/h_fpp_tracking.f
new file mode 100644
index 0000000..f9a6ca0
--- /dev/null
+++ b/HTRACKING/h_fpp_tracking.f
@@ -0,0 +1,996 @@
+ SUBROUTINE h_fpp_tracking(DCset,ABORT,err)
+*--------------------------------------------------------
+* Hall C HMS Focal Plane Polarimeter Code
+*
+* Purpose: tracking in one set of FPP drift chambers
+*
+* Updated by Frank R. Wesselmann, May 2006
+* Created by Frank R. Wesselmann, February 2004
+*
+*--------------------------------------------------------
+
+ IMPLICIT NONE
+
+ include 'gen_detectorids.par'
+ include 'gen_decode_common.cmn'
+ INCLUDE 'hms_data_structures.cmn'
+ INCLUDE 'hms_geometry.cmn'
+ INCLUDE 'hms_fpp_event.cmn'
+ INCLUDE 'hms_fpp_params.cmn'
+ INCLUDE 'hms_id_histid.cmn'
+
+ character*14 here
+ parameter (here= 'h_fpp_tracking')
+
+ integer*4 DCset ! set of FPP DCs we are working on
+
+ logical ABORT
+ character*(*) err
+
+ real*4 SimpleTrack(6), FullTrack(6)
+
+ integer*4 BestClusters(H_FPP_N_DCINSET,H_FPP_N_DCLAYERS)
+
+ integer*4 myclass
+ logical*4 sufficient_hits, track_good, any_track, any_good, any_great
+
+ ABORT= .FALSE.
+ err= ' '
+
+* tracking code:
+** - determine # of hits in each layer & # of layers with any hits
+** - if enough layers with hits (Clusters!), loop over all possible
+** combinations of Clusters and make a BASIC track to each, finding best
+** - find best PROPER track to best set of hits, using L/R ambiguity
+** - mark hits used, start over
+
+* considerations:
+** to account for the fact that dropping the worst hit will always
+** improve the chi**2, even in the case of the reduced chi**2, we
+** changed the order in which we try to fit tracks:
+** instead of trying every combination with AT LEAST the minimum
+** number of hits, but possibly more, we now first determine the
+** maximum number of hits available and try ALL combinations with
+** EXACTLY that count;
+** if a sufficiently good track is found, we're done
+** if not, we reduce the hit count by one and again try all
+** possible combinations with that count, continuing until
+** we either get a sufficiently good track or run into the
+** externally decreed lower hit count limit
+** this biases us towards more hits on the track and also reduces
+** analysis time as there are fewer combinations using 5 out of 6
+** hits than there are using 4 out of 6 hits (for example)
+
+c write(*,*)'In fpp tracking routine ...'
+ any_track = .false.
+ any_good = .false.
+ any_great = .false.
+ myclass = H_FPP_ET_FEWHITS
+
+ HFPP_N_tracks(DCset) = 0 !No of tracks found
+
+
+* * see if we have enough hits to bother with tracking
+ call h_fpp_tracking_FreeHitCount(DCset,sufficient_hits)
+* * try to make tracks while we have hits and room to store tracks
+ do while (sufficient_hits .and. (HFPP_N_tracks(DCset).lt.H_FPP_MAX_TRACKS))
+
+* * first determine which hits to use by fitting track to wire positions only
+ call h_fpp_tracking_simple(DCset, BestClusters,SimpleTrack, ABORT,err)
+ if (ABORT) then
+ call g_add_path(here,err)
+ return
+ endif
+c write(*,*)'Simple track: Nraw = ',SimpleTrack(6),' Chi2 = ',Simpletrack(5)
+
+* * we really *should* have made the simple track results into shared
+* * variables and then fill the histogram from h_fill_fpp but this
+* * works just fine and we will probably stop filling these soon anyway!
+ if (.true.) then
+ if (int(SimpleTrack(6)).le.0) then
+ call hf1(hidFPP_trkrough(DCset,6),0.,1.) !Nraw
+ else
+ call hf1(hidFPP_trkrough(DCset,1),SimpleTrack(1),1.) !mx
+ call hf1(hidFPP_trkrough(DCset,2),SimpleTrack(2),1.) !bx
+ call hf1(hidFPP_trkrough(DCset,3),SimpleTrack(3),1.) !my
+ call hf1(hidFPP_trkrough(DCset,4),SimpleTrack(4),1.) !by
+ call hf1(hidFPP_trkrough(DCset,5),SimpleTrack(5),1.) !chi2
+ call hf1(hidFPP_trkrough(DCset,6),SimpleTrack(6),1.) !Nraw
+ endif
+ endif
+
+* * quit trying to make more tracks if we are out of hits
+* * or if we couldnt make a good one now
+ if (int(SimpleTrack(6)).le.0) exit
+ if (int(SimpleTrack(5)).eq.H_FPP_BAD_CHI2) exit
+
+ any_track = .true.
+
+ FullTrack(1) = H_FPP_BAD_COORD ! mx
+ FullTrack(2) = H_FPP_BAD_COORD ! bx
+ FullTrack(3) = H_FPP_BAD_COORD ! my
+ FullTrack(4) = H_FPP_BAD_COORD ! by
+ FullTrack(5) = H_FPP_BAD_CHI2
+ FullTrack(6) = 0.
+
+ call h_fpp_tracking_drifttrack(DCset,SimpleTrack, BestClusters,track_good,FullTrack, ABORT,err)
+* * the global tracking results are stored by this subroutine as well
+* * also note that BestClusters() may be changed in this call!
+ if (ABORT) then
+ call g_add_path(here,err)
+ return
+ endif
+c write(*,*)'FullTrack: Chi2 = ',FullTrack(5),' track_good = ',track_good
+
+
+* * update event quality flags
+ if (track_good) then
+ any_good = .true.
+ any_great = (any_great).or.(FullTrack(5).le.HFPP_aOK_chi2)
+ else
+ exit !since we did not use up any hits, stop trying to make more tracks!
+ endif !track_good
+
+* * see if we still have enough hits to bother with tracking
+ call h_fpp_tracking_FreeHitCount(DCset,sufficient_hits)
+
+ enddo !while hits 4 tracking
+
+
+* * update event descriptor
+ if (HFPP_N_tracks(DCset).gt.1) then !multiple good tracks
+ if (any_great) then
+ myclass = H_FPP_ET_MANYGREAT
+ else
+ myclass = H_FPP_ET_MANYGOOD
+ endif
+ elseif (HFPP_N_tracks(DCset).eq.1) then !only one good tracks
+ if (any_great) then
+ myclass = H_FPP_ET_1GREAT
+ else
+ myclass = H_FPP_ET_1GOOD
+ endif
+ elseif (any_track) then !only bad tracks
+ myclass = H_FPP_ET_BAD
+ endif
+
+c write(*,*)'Ntracks in set ',DCset,' = ',HFPP_N_tracks(DCset),
+c & ' myclass = ',myclass
+ if (HFPP_eventclass.lt.myclass) then
+ HFPP_eventclass = HFPP_eventclass
+ > + myclass * 2**(DCset-1)
+ endif
+
+ RETURN
+ END
+
+
+c==============================================================================
+c==============================================================================
+c==============================================================================
+c==============================================================================
+
+
+ SUBROUTINE h_fpp_tracking_simple(DCset,
+ > BestClusters,SimpleTrack,
+ > ABORT,err)
+*--------------------------------------------------------
+* Hall C HMS Focal Plane Polarimeter Code
+*
+* Purpose: tracking in one set of FPP drift chambers
+* find best track fitted to wire centers
+* test all possible permutations until good track found
+*
+* Created by Frank R. Wesselmann, February 2004
+*
+*--------------------------------------------------------
+
+ IMPLICIT NONE
+
+ INCLUDE 'hms_data_structures.cmn'
+ INCLUDE 'hms_geometry.cmn'
+ include 'gen_detectorids.par'
+ include 'gen_decode_common.cmn'
+ INCLUDE 'hms_fpp_event.cmn'
+ INCLUDE 'hms_fpp_params.cmn'
+
+ character*21 here
+ parameter (here= 'h_fpp_tracking_simple')
+
+ integer*4 DCset ! IN set of FPP DCs we are working on
+ integer*4 BestClusters(H_FPP_N_DCINSET,H_FPP_N_DCLAYERS)
+ ! OUT clusters in track for this set (implicit!), chamber, layer
+ real*4 SimpleTrack(6) ! OUT track based on wire positions only
+
+ logical ABORT
+ character*(*) err
+
+
+ integer*4 HitCluster(H_FPP_N_DCINSET,H_FPP_N_DCLAYERS)
+ integer*4 nPoints, nHitsInTrack, nHitsRequired, iterations
+ integer*4 iChamber, iLayer, ii
+
+ real*4 iTrack(5) ! does NOT include hit count
+
+ ABORT= .FALSE.
+ err= ' '
+
+
+ SimpleTrack(1) = H_FPP_BAD_COORD ! mx
+ SimpleTrack(2) = H_FPP_BAD_COORD ! bx
+ SimpleTrack(3) = H_FPP_BAD_COORD ! my
+ SimpleTrack(4) = H_FPP_BAD_COORD ! by
+ SimpleTrack(5) = H_FPP_BAD_CHI2
+ SimpleTrack(6) = 0.
+
+ do iChamber=1, H_FPP_N_DCINSET
+ do iLayer=1, H_FPP_N_DCLAYERS
+ BestClusters(iChamber,iLayer) = 0
+ enddo !iLayer
+ enddo !iChamber
+
+
+* * let h_fpp_tracking_NextHitCombo find out how many we can get MAX
+ nHitsRequired = H_FPP_N_PLANES + 1 ! flag for h_fpp_tracking_NextHitCombo
+ iterations = 0
+
+* * nHitsRequired == # of hits required on track for THIS iteration
+* * drop hits to find better tracks until we reach MIN
+ do while (nHitsRequired .ge. HFPP_minsethits)
+
+* * start by getting the first useful combo
+ nHitsInTrack = 0 !# of hits in combinations -- 0 means init
+ call h_fpp_tracking_NextHitCombo(DCset,nHitsRequired,nHitsInTrack, HitCluster)
+
+* * keep comparing permutations until we tried all possibilities
+ do while (nHitsInTrack.gt.0)
+
+ iterations = iterations+1
+ if (iterations.gt.HFPP_maxcombos) exit !while nHitsInTrack
+
+* * fit these hits using wire centers only
+ call h_fpp_fit_simple(DCset,HitCluster,nPoints,iTrack,ABORT,err)
+ if (ABORT) then
+ call g_add_path(here,err)
+ return
+ endif
+
+* * remember this track and set of hits as best choice
+ if (iTrack(5).lt.SimpleTrack(5)) then
+ do ii=1,5
+ SimpleTrack(ii) = iTrack(ii)
+ enddo !ii
+ SimpleTrack(6)= float(nPoints)
+ do iChamber=1, H_FPP_N_DCINSET
+ do iLayer=1, H_FPP_N_DCLAYERS
+ BestClusters(iChamber,iLayer) = HitCluster(iChamber,iLayer)
+ enddo !iLayer
+ enddo !iChamber
+ endif
+
+* * get next useful combo
+ call h_fpp_tracking_NextHitCombo(DCset,nHitsRequired,nHitsInTrack, HitCluster)
+ enddo !while permutations to try
+
+ if (iterations.gt.HFPP_maxcombos) then
+ SimpleTrack(5) = H_FPP_BAD_CHI2
+ exit
+ endif
+
+* * we have tried all combinations with the current number of hits
+* * if the current number of hits gives us a sufficiently good track,
+* * don't bother trying to find a track with fewer hits
+ if ((SimpleTrack(5).ge.0.0).and.(SimpleTrack(5).le.HFPP_aOK_chi2)) exit
+
+* * try again with fewer hits
+ nHitsRequired = nHitsRequired-1
+
+ enddo !while hit requirement exceeds minimum
+
+ RETURN
+ END
+
+
+
+c==============================================================================
+c==============================================================================
+c==============================================================================
+c==============================================================================
+
+
+ SUBROUTINE h_fpp_tracking_drifttrack(DCset,SimpleTrack,
+ > HitClusters,track_good,DriftTrack,
+ > ABORT,err)
+*--------------------------------------------------------
+* Hall C HMS Focal Plane Polarimeter Code
+*
+* Purpose: tracking in one set of FPP drift chambers
+*
+* Created by Frank R. Wesselmann, February 2004
+*
+*--------------------------------------------------------
+
+ IMPLICIT NONE
+
+ INCLUDE 'hms_data_structures.cmn'
+ INCLUDE 'hms_geometry.cmn'
+ include 'gen_detectorids.par'
+ include 'gen_decode_common.cmn'
+ INCLUDE 'hms_fpp_event.cmn'
+ INCLUDE 'hms_fpp_params.cmn'
+
+ character*25 here
+ parameter (here= 'h_fpp_tracking_drifttrack')
+
+ integer*4 DCset ! IN set of FPP DCs we are working on
+ real*4 SimpleTrack(6) ! IN track based on wire positions only
+ integer*4 HitClusters(H_FPP_N_DCINSET,H_FPP_N_DCLAYERS)
+ logical*4 track_good ! OUT flag
+ real*4 DriftTrack(6) ! OUT drift based track in chamber coords
+ logical ABORT
+ character*(*) err
+
+
+ real*4 newTrack(5) ! does NOT include hit count
+ real*4 HMStrack(4),FPPtrack(4)
+ real*4 DCcoords(3), FPcoords(3)
+ real*4 theta,phi
+ real*4 sclose,zclose
+ real*4 mydriftT,mydriftX,roughv,WirePropagation,wirepos,trackpos
+ real*4 x,y,z,m5,m6
+
+ real*4 Points(H_FPP_MAX_FITPOINTS,2), All_Points(H_FPP_MAX_FITPOINTS,2)
+ real*4 Sigma2s(H_FPP_MAX_FITPOINTS), All_Sigma2s(H_FPP_MAX_FITPOINTS)
+ real*4 Projects(H_FPP_MAX_FITPOINTS,2), All_Projects(H_FPP_MAX_FITPOINTS,2)
+ real*4 Drifts(H_FPP_MAX_FITPOINTS), DriftAbs(H_FPP_MAX_FITPOINTS)
+ ! IN hit clusters to fit to
+ integer*4 icone
+
+ integer*4 Chambers(H_FPP_MAX_FITPOINTS),All_Chambers(H_FPP_MAX_FITPOINTS)
+ integer*4 Layers(H_FPP_MAX_FITPOINTS), All_Layers(H_FPP_MAX_FITPOINTS)
+ integer*4 Wires(H_FPP_MAX_FITPOINTS), All_Wires(H_FPP_MAX_FITPOINTS)
+
+ integer*4 Nlayershit, nPoints, mPoints, nClusters, mClusters
+ integer*4 CSkip, LSkip, Cskipped, Lskipped, Llast
+ integer*4 iChamber, iLayer, iCluster, iRaw, iHit, iWire, iTrack, ii, jj
+
+
+ ABORT= .FALSE.
+ err= ' '
+
+ track_good = .FALSE.
+
+
+* * first decode Clusters into a single linear array of hits ***********
+
+ nPoints = 0
+ nClusters = 0
+ do iChamber=1,H_FPP_N_DCINSET
+ do iLayer=1,H_FPP_N_DCLAYERS
+ iCluster = HitClusters(iChamber,iLayer)
+ if (iCluster.gt.0) then
+ nClusters = nClusters + 1
+
+ z = HFPP_layerZ(DCset,iChamber,iLayer)
+ x = SimpleTrack(1)*z + SimpleTrack(2)
+ y = SimpleTrack(3)*z + SimpleTrack(4)
+
+c write(*,*)'----- fpp-tracking ----'
+c write(*,*)'xyz = ',x,y,z
+
+* * calculate time delay due to signal propagating along sense wire
+* * depends on position of event along wire, which side the read-out card
+* * is on, and the propagation speed
+* * INVERSE rotation to V coord !!!! SPECIAL case -- usually want U
+ roughv = y * HFPP_direction(DCset,iChamber,iLayer,1)
+ > - x * HFPP_direction(DCset,iChamber,iLayer,2)
+ roughv = roughv / HFPP_wirespeed ! convert distance to time value
+
+ do iRaw = 1,HFPP_nHitsinCluster(DCset,iChamber,iLayer,iCluster)
+
+ iHit = HFPP_Clusters(DCset,iChamber,iLayer,iCluster,iRaw)
+ iWire = HFPP_raw_wire(iHit)
+
+* * fix the sign depending on readout card being on +v or -v side!
+ WirePropagation = roughv * float(HFPP_cardpos(DCset,iChamber,iLayer,iWire))
+c write(*,*)'Calling h_fpp_drift ... ',WirePropagation
+ call h_fpp_drift(iHit,SimpleTrack,WirePropagation,
+ > mydriftT,mydriftX,ABORT,err)
+
+ HFPP_drift_time(DCset,iChamber,iLayer,iWire) = mydriftT !record for posterity
+ HFPP_drift_dist(DCset,iChamber,iLayer,iWire) = H_FPP_BAD_DRIFT !init to none
+
+c write(*,*)'iRaw,mydriftX =',iRaw,iHit,mydriftX
+ if (mydriftX.ne.H_FPP_BAD_DRIFT) then
+ nPoints = nPoints + 1
+
+ if (nPoints.gt.H_FPP_MAX_FITPOINTS) then
+ print *,' Too many fit points in ',here,' !!'
+ nPoints = H_FPP_MAX_FITPOINTS
+ exit
+ endif
+
+ All_Chambers(nPoints) = iChamber ! remember which chamber this hit is in
+ All_Layers(nPoints) = iLayer ! layer
+ All_Wires(nPoints) = iWire ! wire
+ All_Points(nPoints,1) = HFPP_layeroffset(DCset,iChamber,iLayer)
+ > + HFPP_spacing(DCset,iChamber,iLayer)*iWire
+ All_Points(nPoints,2) = HFPP_layerZ(DCset,iChamber,iLayer)
+ All_Sigma2s(nPoints) = HFPP_resolution(DCset,iChamber,iLayer)
+ All_Projects(nPoints,1) = HFPP_direction(DCset,iChamber,iLayer,1)
+ All_Projects(nPoints,2) = HFPP_direction(DCset,iChamber,iLayer,2)
+ DriftAbs(nPoints) = mydriftX ! and its drift distance (L/R ambiguous!!)
+ endif
+
+ enddo !iRaw
+ endif !iCluster
+ enddo !iLayer
+ enddo !iChamber
+
+
+* * now get the track with least chi2 based on left/right drift permutations ***********
+
+ do iHit=1,nPoints
+ Drifts(iHit) = DriftAbs(iHit)
+ enddo
+
+* * INPUT=absolute drifts OUTPUT=signed drifts
+c write(*,*)'Calling best_permutation ... nPoints = ',nPoints
+ call h_fpp_fit_best_permutation(nPoints, All_Points, All_Sigma2s, All_Projects, Drifts, newTrack)
+ DriftTrack(1) = newTrack(1) ! mx
+ DriftTrack(2) = newTrack(2) ! bx
+ DriftTrack(3) = newTrack(3) ! my
+ DriftTrack(4) = newTrack(4) ! by
+ DriftTrack(5) = newTrack(5) ! chi2/df
+ DriftTrack(6) = float(nPoints)
+c write(*,*)'Results: chi2 = ',newTrack(5),' nPoints = ',nPoints,' HFPP_min_chi2 = ',HFPP_min_chi2
+ if ( (newTrack(5).le.HFPP_min_chi2)
+ > .and.(newTrack(5).ge.0.0)
+ > .and.(newTrack(5).ne.H_FPP_BAD_CHI2) ) then ! store fit results
+
+* * save signed drifts
+ do iHit=1,nPoints
+ iChamber = All_Chambers(iHit)
+ iLayer = All_Layers(iHit)
+ iWire = All_Wires(iHit)
+ HFPP_drift_dist(DCset,iChamber,iLayer,iWire) = Drifts(iHit)
+ enddo !iHit
+ track_good = .true.
+
+ elseif (nClusters.gt.HFPP_minsethits) then ! greater, not equal!
+
+* * apparently we were not able to find a good track
+* * we now try dropping each cluster, one at a time, to see if a good track
+* * can be found -- note that this corresponds to ignoring one layer at a time
+
+ Cskipped = 0
+ Lskipped = 0
+ do CSkip=1,H_FPP_N_DCINSET
+ do LSkip=1,H_FPP_N_DCLAYERS
+
+ mPoints = 0
+ mClusters = 0
+ Llast = 0
+ do iHit=1,nPoints
+ if ((All_Chambers(iHit).eq.CSkip).and.
+ > (All_Layers(iHit).eq.LSkip)) cycle ! selectively skip this hit altogether
+ mPoints = mPoints + 1
+ Points(mPoints,1) = All_Points(iHit,1)
+ Points(mPoints,2) = All_Points(iHit,2)
+ Sigma2s(mPoints) = All_Sigma2s(iHit)
+ Projects(mPoints,1) = All_Projects(iHit,1)
+ Projects(mPoints,2) = All_Projects(iHit,2)
+ Drifts(mPoints) = DriftAbs(iHit)
+ Chambers(mPoints) = All_Chambers(iHit)
+ Layers(mPoints) = All_Layers(iHit)
+ Wires(mPoints) = All_Wires(iHit)
+ if (Llast.ne.All_Layers(iHit)) then !this works as long as hits are in order
+ Llast = All_Layers(iHit)
+ mClusters = mClusters + 1
+ endif
+ enddo !iHit
+
+ if (mClusters.ge.HFPP_minsethits) then
+
+ call h_fpp_fit_best_permutation(mPoints, Points, Sigma2s, Projects, Drifts, newTrack)
+
+* * use the new track if it is better
+ if ( (newTrack(5).lt.DriftTrack(5))
+ > .and.(newTrack(5).ge.0.0)
+ > .and.(newTrack(5).ne.H_FPP_BAD_CHI2) ) then
+ DriftTrack(1) = newTrack(1) ! mx
+ DriftTrack(2) = newTrack(2) ! bx
+ DriftTrack(3) = newTrack(3) ! my
+ DriftTrack(4) = newTrack(4) ! by
+ DriftTrack(5) = newTrack(5) ! chi2/df
+ DriftTrack(6) = float(mPoints)
+ Cskipped = CSkip ! remember skipped chamber
+ Lskipped = LSkip ! remember skipped layer
+ endif
+
+ endif !mClusters.ge.HFPP_minsethits
+
+ enddo !LSkip
+ enddo !CSkip
+
+ if ( (DriftTrack(5).le.HFPP_min_chi2)
+ > .and.(DriftTrack(5).ge.0.0)
+ > .and.(DriftTrack(5).ne.H_FPP_BAD_CHI2) ) then ! store fit results
+
+* * update Clusters used if we skipped one layer
+ if (Lskipped.ne.0) then
+ HitClusters(Cskipped,Lskipped) = 0 ! remove skipped cluster
+ endif !Lskipped
+
+* * save signed drifts
+ do iHit=1,mPoints
+ iChamber = Chambers(iHit)
+ iLayer = Layers(iHit)
+ iWire = Wires(iHit)
+ HFPP_drift_dist(DCset,iChamber,iLayer,iWire) = Drifts(iHit)
+ enddo !iHit
+ track_good = .true.
+ nPoints = mPoints !use stats of new, "smaller" track
+ nClusters = mClusters
+
+ endif !dropped_one
+
+ else
+ track_good = .false.
+ endif !track with all hits is/not bad
+
+
+* * store the tracking results if there was a good track ***********
+ if (track_good) then
+
+ iTrack = HFPP_N_tracks(DCset) + 1
+ if (iTrack.le.H_FPP_MAX_TRACKS) then
+
+ HFPP_N_tracks(DCset) = iTrack ! number of tracks in this chamber set so far
+
+* * store clusters and mark them used
+ Nlayershit = 0
+ do iChamber=1,H_FPP_N_DCINSET
+ do iLayer=1,H_FPP_N_DCLAYERS
+
+ iCluster = HitClusters(iChamber,iLayer)
+ HFPP_TrackCluster(DCset,iChamber,iLayer,iTrack) = iCluster
+ if (iCluster.gt.0) then
+ Nlayershit = Nlayershit + 1
+ HFPP_ClusterinTrack(DCset,iChamber,iLayer,iCluster) = iTrack
+ endif !iCluster.gt.0
+
+ enddo !iLayer
+ enddo !iChamber
+ HFPP_track_Nlayers(DCset,iTrack) = Nlayershit
+
+
+* * store track
+ do ii=1,4 ! store drift-based track in chamber coords
+ HFPP_track_fine(DCset,iTrack,ii) = DriftTrack(ii)
+ enddo !ii
+ HFPP_track_chi2(DCset,iTrack) = DriftTrack(5)
+ HFPP_track_Nhits(DCset,iTrack) = int(DriftTrack(6))
+
+ do ii=1,6 ! store simple track in chamber coords
+ HFPP_track_rough(DCset,iTrack,ii) = SimpleTrack(ii)
+ enddo !ii
+
+
+* * store drift based track in HMS focal plane coords
+ DCcoords(1) = DriftTrack(1) ! transform slope
+ DCcoords(2) = DriftTrack(3)
+ DCcoords(3) = 1.0
+ call h_fpp_DC2FP(DCset,.true.,DCcoords,FPcoords)
+ HFPP_track_dx(DCset,iTrack) = FPcoords(1)
+ HFPP_track_dy(DCset,iTrack) = FPcoords(2)
+
+ DCcoords(1) = DriftTrack(2) ! transform offsets
+ DCcoords(2) = DriftTrack(4)
+ DCcoords(3) = 0.0
+ call h_fpp_DC2FP(DCset,.false.,DCcoords,FPcoords)
+
+* * still need to project reference point back to z=0!!
+ HFPP_track_x(DCset,iTrack) = FPcoords(1)
+ > - FPcoords(3)*HFPP_track_dx(DCset,iTrack)
+ HFPP_track_y(DCset,iTrack) = FPcoords(2)
+ > - FPcoords(3)*HFPP_track_dy(DCset,iTrack)
+
+
+* * find angle between incident track and re-scattered track, in FP!!
+ call h_fpp_relative_angles(hsxp_fp,hsyp_fp,
+ > HFPP_track_dx(DCset,iTrack),
+ > HFPP_track_dy(DCset,iTrack),
+ > theta,phi)
+ HFPP_track_theta(DCset,iTrack) = theta
+ HFPP_track_phi(DCset,iTrack) = phi
+
+
+* * get point and distance of closest approach
+ HMStrack(1) = hsxp_fp
+ HMStrack(2) = hsx_fp
+ HMStrack(3) = hsyp_fp
+ HMStrack(4) = hsy_fp
+
+ FPPtrack(1) = HFPP_track_dx(DCset,iTrack)
+ FPPtrack(2) = HFPP_track_x(DCset,iTrack)
+ FPPtrack(3) = HFPP_track_dy(DCset,iTrack)
+ FPPtrack(4) = HFPP_track_y(DCset,iTrack)
+
+ call h_fpp_closest(HMStrack,FPPtrack,sclose,zclose)
+
+ HFPP_track_sclose(DCset,iTrack) = sclose
+ HFPP_track_zclose(DCset,iTrack) = zclose
+
+ icone=1
+
+ call h_fpp_conetest(HMStrack,DCset,zclose,theta,icone)
+
+ HFPP_track_conetest(DCset,iTrack) = icone
+
+* * determine resolution measure -- if requested
+ if (HFPP_calc_resolution.ne.0) then
+
+* * init to bad
+ do CSkip=1,H_FPP_N_DCINSET
+ do LSkip=1,H_FPP_N_DCLAYERS
+ HFPP_track_resolution(DCset,CSkip,LSkip,iTrack) = H_FPP_BAD_COORD
+ HFPP_track_angresol(DCset,CSkip,LSkip,iTrack) = H_FPP_BAD_COORD
+ enddo !LSkip
+ enddo !CSkip
+
+ if (nClusters.gt.HFPP_minsethits) then
+
+* * tracking resolution:
+* ** - require good quality track with 6 hits
+* ** - for each layer in turn, drop hit cluster from this layer
+* ** and re-figure track using remaining 5 hit cluster
+* ** - compare position of intersection of 5-hit track and currently
+* ** investigated layer with drift-corrected position of cluster
+* ** - difference is resolution
+* *
+* * Notes:
+* ** - if multiple tracks, use all good ones with 6 hits (external!)
+* ** - for multiple hits in cluster, use each hit
+
+ do CSkip=1,H_FPP_N_DCINSET
+ do LSkip=1,H_FPP_N_DCLAYERS
+
+* * figure subset of hits to use
+ mPoints = 0
+ jj=0
+ do ihit=1,nPoints
+ if (All_Chambers(ihit).eq.CSkip.and.
+ > All_Layers(ihit).eq.LSkip) then
+* * identify the hit in this layer with the shortest drift
+ if ((jj.eq.0).or.(DriftAbs(ihit).lt.DriftAbs(jj))) then
+ jj = ihit
+ endif
+ else ! use point on reduced track
+ mPoints = mPoints+1
+ Points(mPoints,1) = All_Points(ihit,1)
+ Points(mPoints,2) = All_Points(ihit,2)
+ Sigma2s(mPoints) = All_Sigma2s(ihit)
+ Projects(mPoints,1) = All_Projects(ihit,1)
+ Projects(mPoints,2) = All_Projects(ihit,2)
+ Drifts(mPoints) = DriftAbs(ihit)
+ endif
+ enddo !ihit
+
+ call h_fpp_fit_best_permutation(mPoints,Points,Sigma2s,Projects, Drifts,newTrack)
+
+* * now figure residual in skipped layer and call that the resolution
+* * use the hit with the smallest drift distance in this layer, determined above
+ if (jj.gt.0) then
+
+ iWire = All_Wires(jj)
+ wirepos = All_Points(jj,1)
+ > + HFPP_drift_dist(DCset,CSkip,LSkip,iWire) !signed drift!
+
+ x = newTrack(1)*z + newTrack(2)
+ y = newTrack(3)*z + newTrack(4)
+ z = All_Points(jj,2)
+
+ trackpos = HFPP_direction(DCset,CSkip,LSkip,1) * x
+ > + HFPP_direction(DCset,CSkip,LSkip,2) * y
+
+ HFPP_track_resolution(DCset,CSkip,LSkip,iTrack) = trackpos - wirepos
+
+* * now figure angular resolution as difference in slope between
+* * standard track and resolution track
+ m6 = DriftTrack(1) * HFPP_direction(DCset,CSkip,LSkip,1)
+ > + DriftTrack(3) * HFPP_direction(DCset,CSkip,LSkip,2)
+ m5 = newTrack(1) * HFPP_direction(DCset,CSkip,LSkip,1)
+ > + newTrack(3) * HFPP_direction(DCset,CSkip,LSkip,2)
+
+ HFPP_track_angresol(DCset,CSkip,LSkip,iTrack) = m5 - m6
+
+ endif !jj
+
+ enddo !LSkip
+ enddo !CSkip
+
+ endif !HFPP_minsethits
+ endif !HFPP_calc_resolution
+
+ endif !iTrack.le.H_FPP_MAX_TRACKS
+ endif !track_good
+
+
+ RETURN
+ END
+
+
+c==============================================================================
+c==============================================================================
+c==============================================================================
+c==============================================================================
+
+
+ SUBROUTINE h_fpp_tracking_NextHitCombo(DCSet,nHitsRequired,nHitsInTrack,Hits)
+*--------------------------------------------------------
+* Hall C HMS Focal Plane Polarimeter Code
+*
+* Purpose: determine next combination of hits from all possible
+*
+* Updated by Frank R. Wesselmann, May 2006
+* Created by Frank R. Wesselmann, February 2004
+*
+*--------------------------------------------------------
+
+ IMPLICIT NONE
+
+ INCLUDE 'hms_data_structures.cmn'
+ include 'gen_detectorids.par'
+ include 'gen_decode_common.cmn'
+ INCLUDE 'hms_fpp_event.cmn'
+ INCLUDE 'hms_fpp_params.cmn'
+
+ integer*4 DCSet ! set of FPP DCs we are working on
+ integer*4 nHitsRequired ! # of hits we are requiring for a track
+ ! generally IN, but if set excessively large
+ ! we interpret it as a flag to OUT maximum value
+ integer*4 nHitsInTrack ! IN: No of hits in combinations last tried
+ ! OUT: No of hits in combinations returned now
+ ! note that input value of 0 means initialize
+ integer*4 Hits(H_FPP_N_DCINSET,H_FPP_N_DCLAYERS) ! pointer to current
+ ! set of Clusters
+
+ integer*4 iChamber, iLayer, iHit
+ integer*4 Ncombos
+ logical*4 trynextlayer
+
+
+ if (nHitsInTrack.le.0) then
+* * init -- first call, determine starting set of hits
+* * also, if nHitsRequired is outrageously large, we interpret
+* * this to mean that we want to discover the max possible
+
+* * init pointers
+ do iChamber=1,H_FPP_N_DCINSET
+ do iLayer=1,H_FPP_N_DCLAYERS
+ Hits(iChamber,iLayer) = 0
+ enddo
+ enddo
+ nHitsInTrack = 0
+
+* * determine number of possible combinations
+ Ncombos = 1
+ do iChamber=1,H_FPP_N_DCINSET
+ do iLayer=1,H_FPP_N_DCLAYERS
+ if (HFPP_Nfreehits(DCset,iChamber,iLayer).gt.0) then
+ Ncombos = Ncombos * HFPP_Nfreehits(DCset,iChamber,iLayer)
+ endif
+ enddo
+ enddo
+
+* * if too many combinations are possible, the event is
+* * too noisy for meaningful tracking, so we'll skip it!
+ if (abs(Ncombos).gt.HFPP_maxcombos) then
+ nHitsInTrack = -1
+
+ else
+* * preset each layer to 1st hit until we have required # of hits
+ iChamber = 1
+ iLayer = 0
+ nHitsInTrack = 0
+ do while (nHitsInTrack.lt.nHitsRequired)
+
+* * loop over all layers and chambers in this set
+ iLayer = iLayer+1
+ if (iLayer.gt.H_FPP_N_DCLAYERS) then
+ iChamber = iChamber+1
+ iLayer = 1
+ endif
+ if (iChamber.gt.H_FPP_N_DCINSET) exit !insufficient hits available!
+
+* * simply set layer to first free hit, if any
+ if (HFPP_Nfreehits(DCset,iChamber,iLayer).gt.0) then
+ iHit = 1
+ do while ( (iHit .lt. HFPP_nClusters(DCset,iChamber,iLayer))
+ > .and. HFPP_ClusterinTrack(DCSet,iChamber,iLayer,iHit).gt.0 )
+ iHit = iHit+1
+ enddo
+ if (HFPP_ClusterinTrack(DCSet,iChamber,iLayer,iHit).eq.0) then
+ Hits(iChamber,iLayer) = iHit
+ nHitsInTrack = nHitsInTrack + 1
+ else
+ Hits(iChamber,iLayer) = 0
+ endif
+ endif
+
+ enddo !while
+
+* * initialize nHitsRequired based on max hits available -- if requested
+ if (nHitsRequired.gt.H_FPP_N_PLANES) then
+ nHitsRequired = max(nHitsInTrack,HFPP_minsethits)
+ endif
+
+* * ensure we do not bother with junk events
+ if (nHitsInTrack.lt.nHitsRequired) then
+ nHitsInTrack = 0
+ endif
+
+ endif !excessive hits
+
+
+ else !nHitsInTrack
+* * iterate -- determine next set of hits
+
+* * in each layer of this chamber set, cycle over all hit clusters,
+* * from NONE to first up to last like an odometer; return every combination
+* * that results in as many hits as we require, one combination per invocation;
+* * we have a counter that identifies the number of hits in this combination
+
+ iChamber = 1
+ iLayer = 0
+ trynextlayer = .true.
+
+* * loop over layers, adding hits until we have enough
+ do while (trynextlayer)
+
+* * goto next layer (loop over all layers and chambers in this set)
+ iLayer = iLayer+1
+ if (iLayer.gt.H_FPP_N_DCLAYERS) then
+ iChamber = iChamber+1
+ iLayer = 1
+ endif
+ if (iChamber.gt.H_FPP_N_DCINSET) exit
+
+
+* * go to next hit in this layer, if any, or to next layer
+ if (HFPP_Nfreehits(DCset,iChamber,iLayer).le.0) then
+ trynextlayer = .true.
+
+ else
+* * increase counter if we are adding a NEW hit
+ if (Hits(iChamber,iLayer).eq.0) then
+ nHitsInTrack = nHitsInTrack+1
+ endif
+
+* * find next free hit
+ iHit = Hits(iChamber,iLayer)+1
+ do while ( (iHit .lt. HFPP_nClusters(DCset,iChamber,iLayer))
+ > .and. HFPP_ClusterinTrack(DCSet,iChamber,iLayer,iHit).gt.0 )
+ iHit = iHit+1
+ enddo
+
+* * did we find a free hit?
+ if ( HFPP_ClusterinTrack(DCSet,iChamber,iLayer,iHit).gt.0 .or.
+ > (iHit .gt. HFPP_nClusters(DCset,iChamber,iLayer)) ) then
+ Hits(iChamber,iLayer) = 0 ! no free hit
+ nHitsInTrack = nHitsInTrack - 1
+ trynextlayer = .true. ! try next layer
+ else
+ Hits(iChamber,iLayer) = iHit ! found free hit
+ iLayer = 0 ! restart increment at lowest layer, chamber
+ iChamber = 1
+* * continue until we have enough hits in this combo
+ trynextlayer = (nHitsInTrack.lt.nHitsRequired)
+ endif
+
+ endif !(HFPP_Nfreehits(DCset,iChamber,iLayer).le.0)
+ enddo !trynextlayer
+
+* * change hit count to none if we exited due to layer count exceeded
+ if (trynextlayer) then
+ nHitsInTrack = 0
+ endif
+
+ endif !nHitsInTrack
+
+ RETURN
+ END
+
+
+c==============================================================================
+c==============================================================================
+c==============================================================================
+c==============================================================================
+
+
+ SUBROUTINE h_fpp_tracking_FreeHitCount(DCSet,DoTracking)
+*--------------------------------------------------------
+* Hall C HMS Focal Plane Polarimeter Code
+*
+* Purpose: determine how many layers have unused hits
+*
+* Updated by Frank R. Wesselmann, May 2006
+* Created by Frank R. Wesselmann, February 2004
+*
+*--------------------------------------------------------
+
+ IMPLICIT NONE
+
+ INCLUDE 'hms_data_structures.cmn'
+ include 'gen_detectorids.par'
+ include 'gen_decode_common.cmn'
+ INCLUDE 'hms_fpp_event.cmn'
+ INCLUDE 'hms_fpp_params.cmn'
+
+ integer*4 DCSet ! drift chamber set we are working in
+ logical*4 DoTracking ! are there enough available hits 4 tracking?
+
+ integer*4 iChamber, iLayer, iCluster
+ logical*4 anyWenough, allWmin
+
+
+ HFPP_NsetlayersWfreehits(DCSet) = 0
+
+ do iChamber=1, H_FPP_N_DCINSET
+
+ HFPP_NlayersWfreehits(DCSet,iChamber) = 0
+
+ do iLayer=1, H_FPP_N_DCLAYERS
+
+ HFPP_Nfreehits(DCSet,iChamber,iLayer) = 0
+
+ if (HFPP_nClusters(DCSet,iChamber,iLayer).gt.0) then
+ do iCluster=1, HFPP_nClusters(DCSet,iChamber,iLayer)
+
+ if (HFPP_ClusterinTrack(DCSet,iChamber,iLayer,iCluster).eq.0) then
+ HFPP_Nfreehits(DCSet,iChamber,iLayer) =
+ > HFPP_Nfreehits(DCSet,iChamber,iLayer) + 1
+
+ endif
+ enddo !iCluster
+ endif
+
+ if (HFPP_Nfreehits(DCSet,iChamber,iLayer).gt.0) then
+ HFPP_NlayersWfreehits(DCSet,iChamber) =
+ > HFPP_NlayersWfreehits(DCSet,iChamber) + 1
+ endif
+
+ enddo !ilayer
+
+ HFPP_NsetlayersWfreehits(DCSet) =
+ > HFPP_NsetlayersWfreehits(DCSet)
+ > + HFPP_NlayersWfreehits(DCSet,iChamber)
+
+ enddo !ichamber
+
+
+* * now see if there are enough hits to bother with tracking...
+ DoTracking = .false.
+
+ if (HFPP_NsetlayersWfreehits(DCSet).ge.HFPP_minsethits) then
+
+ allWmin = .true.
+ anyWenough = .false.
+
+ do iChamber=1, H_FPP_N_DCINSET
+ allWmin = allWmin .and.
+ > (HFPP_NlayersWfreehits(DCSet,iChamber).ge.HFPP_minchamberhits)
+ anyWenough = anyWenough .or.
+ > (HFPP_NlayersWfreehits(DCSet,iChamber).ge.HFPP_optchamberhits)
+ enddo !ichamber
+
+* * we need each chamber to have a minimum number of hit layers
+* * and at least one chamber must have the optimal number of hits
+ DoTracking = allWmin .and. anyWenough
+
+ endif
+
+
+ RETURN
+ END
diff --git a/HTRACKING/h_generate_geometry.f b/HTRACKING/h_generate_geometry.f
new file mode 100644
index 0000000..52130f1
--- /dev/null
+++ b/HTRACKING/h_generate_geometry.f
@@ -0,0 +1,390 @@
+ subroutine H_GENERATE_GEOMETRY
+*
+* This subroutine reads in the wire plane parameters and fills all the
+* geometrical constants used in Track Fitting for the HMS spectrometer
+* The constants are stored in hms_geometry.cmn
+*
+* d.f. geesaman 2 Sept 1993
+* modified 14 feb 1994 for CTP input.
+* Change HPLANE_PARAM to individual arrays
+* $Log: h_generate_geometry.f,v $
+* Revision 1.9.24.1 2007/10/22 15:23:06 cdaq
+* *** empty log message ***
+*
+* Revision 1.9 1999/02/10 18:23:48 csa
+* Added 4/6 tracking code (D. Meekins)
+*
+* Revision 1.7 1996/04/30 12:43:54 saw
+* (JRA) Set up card drift time delay structures
+*
+* Revision 1.6 1995/10/10 13:49:33 cdaq
+* (JRA) Cosmetics and comments
+*
+* Revision 1.5 1995/05/22 19:39:13 cdaq
+* (SAW) Split gen_data_data_structures into gen, hms, sos, and coin parts"
+*
+* Revision 1.4 1995/04/06 19:28:27 cdaq
+* (SAW) Remove hardwired plane and chamber counts
+*
+* Revision 1.3 1994/11/22 20:05:58 cdaq
+* (SAW) Add h's in front of fract, aa3, det3, aainv3.
+*
+* Revision 1.2 1994/10/12 18:23:47 cdaq
+* (DJM) Calculate 3x3 matrices and inverses
+*
+* Revision 1.1 1994/02/19 06:14:45 cdaq
+* Initial revision
+*
+*
+ implicit none
+ include "hms_data_structures.cmn"
+ include "hms_tracking.cmn"
+ include "hms_geometry.cmn"
+*
+* local variables
+ logical missing_card_no
+ integer*4 pln,i,j,k,pindex,ich,icounter
+ real*4 cosalpha,sinalpha,cosbeta,sinbeta,cosgamma,singamma,z0
+ real*4 stubxchi,stubxpsi,stubychi,stubypsi
+ real*4 sumsqupsi,sumsquchi,sumcross,denom
+*jv real*4 hdum4of6coeff(hdc_num_planes)
+ real*4 hdum4of6coeff(hmax_num_dc_planes)
+*
+* read basic parameters from CTP input file
+* hdc_zpos(pln) = Z0
+* hdc_alpha_angle(pln) = ALPHA
+* hdc_beta_angle(pln) = BETA
+* hdc_gamma_angle(pln) = GAMMA
+* hdc_pitch(pln) = Wire spacing
+* hdc_nrwire(pln) = Number of wires
+* hdc_central_wire(pln) = Location of center of wire 1
+* hdc_sigma(pln) = sigma
+*
+ hdc_planes_per_chamber = hdc_num_planes / hdc_num_chambers
+ missing_card_no = .false.
+ do j=1,hmax_num_dc_planes
+ do i=1,hdc_max_wires_per_plane
+ if (hdc_card_no(i,j).eq.0) then
+ missing_card_no = .true.
+ hdc_card_no(i,j)=1 !avoid 0 in array index
+ hdc_card_delay(1)=0. !no delay for wires
+ endif
+ enddo
+ enddo
+ if (missing_card_no) write(6,*) 'missing hdc_card_no, blame JRA'
+*
+* loop over all planes
+
+ do pln=1,hdc_num_planes
+ hdc_plane_num(pln)=pln
+ z0=hdc_zpos(pln)
+ cosalpha = cos(hdc_alpha_angle(pln))
+ sinalpha = sin(hdc_alpha_angle(pln))
+ cosbeta = cos(hdc_beta_angle(pln))
+ sinbeta = sin(hdc_beta_angle(pln))
+ cosgamma = cos(hdc_gamma_angle(pln))
+ singamma = sin(hdc_gamma_angle(pln))
+*
+ hsinbeta(pln) = sinbeta
+ hcosbeta(pln) = cosbeta
+* make sure cosbeta is not zero
+ if(abs(cosbeta).lt.1e-10) then
+ write(hluno,'('' unphysical beta rotation in hms plane'',i4,
+ & '' beta='',f10.5)') pln,hdc_beta_angle(pln)
+ endif
+ htanbeta(pln) = sinbeta / cosbeta
+*
+* compute chi,psi to x,y,z transformation coefficient(comments are beta=gamma=0)
+ hzchi(pln) = -cosalpha*sinbeta + sinalpha*cosbeta*singamma ! =0.
+ hzpsi(pln) = sinalpha*sinbeta + cosalpha*cosbeta*singamma ! =0.
+ hxchi(pln) = -cosalpha*cosbeta - sinalpha*sinbeta*singamma !-cos(a)
+ hxpsi(pln) = sinalpha*cosbeta - cosalpha*sinbeta*singamma ! sin(a)
+ hychi(pln) = sinalpha*cosgamma ! sin(a)
+ hypsi(pln) = cosalpha*cosgamma ! cos(a)
+*
+* stub transfromations are done in beta=gamma=0 system
+ stubxchi = -cosalpha !-cos(a)
+ stubxpsi = sinalpha ! sin(a)
+ stubychi = sinalpha ! sin(a)
+ stubypsi = cosalpha ! cos(a)
+
+* parameters for wire propogation correction. dt=distance from centerline of
+* chamber = ( xcoeff*x + ycoeff*y )*corr / veloc.
+ if (cosalpha .le. 0.707) then !x-like wire, need dist. from x=0 line
+ hdc_readout_x(pln) = .true.
+ hdc_readout_corr(pln) = 1./sinalpha
+ else !y-like wire, need dist. from y=0 line
+ hdc_readout_x(pln) = .false.
+ hdc_readout_corr(pln) = 1./cosalpha
+ endif
+*
+* fill hpsi0,hchi0,hz0 used in stub fit
+*
+ sumsqupsi = hzpsi(pln)**2 + hxpsi(pln)**2 + hypsi(pln)**2 ! =1.
+ sumsquchi = hzchi(pln)**2 + hxchi(pln)**2 + hychi(pln)**2 ! =1.
+ sumcross = hzpsi(pln)*hzchi(pln) + hxpsi(pln)*hxchi(pln)
+ & + hypsi(pln)*hychi(pln) ! =0.
+ denom = sumsqupsi*sumsquchi-sumcross**2 ! =1.
+ hpsi0(pln) = (-z0*hzpsi(pln)*sumsquchi ! =0.
+ & +z0*hzchi(pln)*sumcross) / denom
+ hchi0(pln) = (-z0*hzchi(pln)*sumsqupsi ! =0.
+ & +z0*hzpsi(pln)*sumcross) / denom
+* calculate magnitude of hphi0 ! =z0
+ hphi0(pln) = sqrt(
+ & (z0+hzpsi(pln)*hpsi0(pln)+hzchi(pln)*hchi0(pln))**2
+ & + (hxpsi(pln)*hpsi0(pln)+hxchi(pln)*hchi0(pln))**2
+ & + (hypsi(pln)*hpsi0(pln)+hychi(pln)*hchi0(pln))**2 )
+ if(z0.lt.0) hphi0(pln)=-hphi0(pln)
+*
+* hstubcoef used in stub fits. check these. I don't think they are correct.
+ denom = stubxpsi*stubychi - stubxchi*stubypsi ! =1.
+ hstubcoef(pln,1)= stubychi/(hdc_sigma(pln)*denom) !sin(a)/sigma
+ hstubcoef(pln,2)= -stubxchi/(hdc_sigma(pln)*denom) !cos(a)/sigma
+ hstubcoef(pln,3)= hphi0(pln)*hstubcoef(pln,1) !z0*sin(a)/sig
+ hstubcoef(pln,4)= hphi0(pln)*hstubcoef(pln,2) !z0*cos(a)/sig
+*
+* xsp and ysp used in space point pattern recognition
+*
+ hxsp(pln) = hychi(pln) / denom !sin(a)
+ hysp(pln) = -hxchi(pln) / denom !cos(a)
+*
+* compute track fitting coefficients
+*
+ hplane_coeff(1,pln)= hzchi(pln) ! =0.
+ hplane_coeff(2,pln)=-hzchi(pln) ! =0.
+ hplane_coeff(3,pln)= hychi(pln)*(hdc_zpos(pln)-hlocrayzt) !sin(a)*(z-hlocrayzt)
+ hplane_coeff(4,pln)= hxchi(pln)*(hlocrayzt-hdc_zpos(pln)) !cos(a)*(z-hlocrayzt)
+ hplane_coeff(5,pln)= hychi(pln) !sin(a)
+ hplane_coeff(6,pln)=-hxchi(pln) !cos(a)
+ hplane_coeff(7,pln)= hzchi(pln)*hypsi(pln) - hychi(pln)*hzpsi(pln) !0.
+ hplane_coeff(8,pln)=-hzchi(pln)*hxpsi(pln) + hxchi(pln)*hzpsi(pln) !0.
+ hplane_coeff(9,pln)= hychi(pln)*hxpsi(pln) - hxchi(pln)*hypsi(pln) !1.
+*
+ enddo ! end hdc_num_planes
+
+* djm 10/2/94 generate/store the inverse matrices HAAINV3(i,j,pindex) used in solve_3by3_hdc
+* pindex = 1 plane 1 missing from hdc1
+* pindex = 2 plane 2 missing from hdc1
+* etc.
+* pindex = 7 plane 1 missing from hdc2
+* pindex = 8 plane 2 missing from hdc2
+* etc.
+* pindex = 13 hdc1 no missing planes
+* pindex = 14 hdc2 no missing planes
+*
+* pindex for 4/6 planes is not as meaningful. you have to know what an
+* index represents in missing planes. pindex now has a meaningful
+* range of 1 to 26. from 15 to 26 there are 4/6 planes that fire and
+* both y and yprime must fire. that leaves 6 possiblities for each
+* chamber. the only way to setup haainv is to do it manually. pindex
+* is used in this fashion so that the 3rd index in haainv has meaning
+* and is contiuous running from 1 to 26 instead of jumping around which
+* would be the case if it were to contain useful plane information.
+* see h_left_right.f for a list of plane configurations that are
+* attached to pindex above 14.
+
+ do pindex=1, HDC_NUM_PLANES + HDC_NUM_CHAMBERS + 30
+
+* generate the matrix HAA3 for an hdc missing a particular plane
+ do i=1,3
+ do j=1,3
+ HAA3(i,j)=0.
+ if(j.lt.i)then ! HAA3 is symmetric so only calculate 6 terms
+ HAA3(i,j)=HAA3(j,i)
+ else
+ if(pindex.le.HDC_NUM_PLANES) then
+ ich = (pindex-1)/(HDC_PLANES_PER_CHAMBER)+1
+ do k=(ich-1)*(HDC_PLANES_PER_CHAMBER)+1
+ $ ,ich*(HDC_PLANES_PER_CHAMBER)
+ if(pindex.ne.k) then
+ HAA3(i,j)=HAA3(i,j) + hstubcoef(k,i)*hstubcoef(k,j)
+ endif
+ enddo
+ else
+ if(pindex.le.(HDC_NUM_PLANES+HDC_NUM_CHAMBERS)) then
+ ich = pindex - HDC_NUM_PLANES
+ do k=(ich-1)*(HDC_PLANES_PER_CHAMBER)+1
+ $ ,ich*(HDC_PLANES_PER_CHAMBER)
+ HAA3(i,j)=HAA3(i,j) + hstubcoef(k,i)*hstubcoef(k,j)
+ enddo
+ else ! 4/6 planes are hit
+ do icounter=1,hdc_num_planes
+ hdum4of6coeff(icounter)=1
+ enddo
+ if(pindex.eq.15.or.pindex.eq.30)then
+ hdum4of6coeff(6)=0 !plane 6 did not fire
+ hdum4of6coeff(5)=0 !plane 5 did not fire
+ hdum4of6coeff(12)=0 !plane 12 did not fire
+ hdum4of6coeff(11)=0 !plane 11 did not fire
+ endif
+ if(pindex.eq.16.or.pindex.eq.31)then
+ hdum4of6coeff(6)=0 !plane 6 did not fire
+ hdum4of6coeff(4)=0 !plane 4 did not fire
+ hdum4of6coeff(12)=0 !plane 12 did not fire
+ hdum4of6coeff(10)=0 !plane 10 did not fire
+ endif
+ if(pindex.eq.17.or.pindex.eq.32)then
+ hdum4of6coeff(6)=0 !plane 6 did not fire
+ hdum4of6coeff(3)=0 !plane 3 did not fire
+ hdum4of6coeff(12)=0 !plane 12 did not fire
+ hdum4of6coeff(9)=0 !plane 9 did not fire
+ endif
+ if(pindex.eq.18.or.pindex.eq.33)then
+ hdum4of6coeff(6)=0 !plane 6 did not fire
+ hdum4of6coeff(2)=0 !plane 2 did not fire
+ hdum4of6coeff(12)=0 !plane 12 did not fire
+ hdum4of6coeff(8)=0 !plane 9 did not fire
+ endif
+ if(pindex.eq.19.or.pindex.eq.34)then
+ hdum4of6coeff(6)=0 !plane 6 did not fire
+ hdum4of6coeff(1)=0 !plane 1 did not fire
+ hdum4of6coeff(12)=0 !plane 12 did not fire
+ hdum4of6coeff(7)=0 !plane 7 did not fire
+ endif
+ if(pindex.eq.20.or.pindex.eq.35)then
+ hdum4of6coeff(5)=0 !plane 5 did not fire
+ hdum4of6coeff(4)=0 !plane 4 did not fire
+ hdum4of6coeff(11)=0 !plane 11 did not fire
+ hdum4of6coeff(10)=0 !plane 10 did not fire
+ endif
+ if(pindex.eq.21.or.pindex.eq.36)then
+ hdum4of6coeff(5)=0 !plane 5 did not fire
+ hdum4of6coeff(3)=0 !plane 3 did not fire
+ hdum4of6coeff(11)=0 !plane 11 did not fire
+ hdum4of6coeff(9)=0 !plane 9 did not fire
+ endif
+ if(pindex.eq.22.or.pindex.eq.37)then
+ hdum4of6coeff(5)=0 !plane 5 did not fire
+ hdum4of6coeff(2)=0 !plane 2 did not fire
+ hdum4of6coeff(11)=0 !plane 11 did not fire
+ hdum4of6coeff(8)=0 !plane 8 did not fire
+ endif
+ if(pindex.eq.23.or.pindex.eq.38)then
+ hdum4of6coeff(5)=0 !plane 5 did not fire
+ hdum4of6coeff(1)=0 !plane 1 did not fire
+ hdum4of6coeff(11)=0 !plane 11 did not fire
+ hdum4of6coeff(7)=0 !plane 7 did not fire
+ endif
+ if(pindex.eq.24.or.pindex.eq.39)then
+ hdum4of6coeff(4)=0 !plane 4 did not fire
+ hdum4of6coeff(3)=0 !plane 3 did not fire
+ hdum4of6coeff(10)=0 !plane 10 did not fire
+ hdum4of6coeff(9)=0 !plane 9 did not fire
+ endif
+ if(pindex.eq.25.or.pindex.eq.40)then
+ hdum4of6coeff(4)=0 !plane 4 did not fire
+ hdum4of6coeff(2)=0 !plane 2 did not fire
+ hdum4of6coeff(10)=0 !plane 10 did not fire
+ hdum4of6coeff(8)=0 !plane 8 did not fire
+ endif
+ if(pindex.eq.26.or.pindex.eq.41)then
+ hdum4of6coeff(4)=0 !plane 4 did not fire
+ hdum4of6coeff(1)=0 !plane 1 did not fire
+ hdum4of6coeff(10)=0 !plane 10 did not fire
+ hdum4of6coeff(7)=0 !plane 7 did not fire
+ endif
+ if(pindex.eq.27.or.pindex.eq.42)then
+ hdum4of6coeff(3)=0 !plane 3 did not fire
+ hdum4of6coeff(2)=0 !plane 2 did not fire
+ hdum4of6coeff(9)=0 !plane 9 did not fire
+ hdum4of6coeff(8)=0 !plane 8 did not fire
+ endif
+ if(pindex.eq.28.or.pindex.eq.43)then
+ hdum4of6coeff(3)=0 !plane 3 did not fire
+ hdum4of6coeff(1)=0 !plane 1 did not fire
+ hdum4of6coeff(9)=0 !plane 9 did not fire
+ hdum4of6coeff(7)=0 !plane 7 did not fire
+ endif
+ if(pindex.eq.29.or.pindex.eq.44)then
+ hdum4of6coeff(2)=0 !plane 2 did not fire
+ hdum4of6coeff(1)=0 !plane 1 did not fire
+ hdum4of6coeff(8)=0 !plane 8 did not fire
+ hdum4of6coeff(7)=0 !plane 7 did not fire
+ endif
+ if(pindex.ge.15.and.pindex.le.29)then
+ ich=1
+ else
+ ich=2
+ endif
+ do k=(ich-1)*(HDC_PLANES_PER_CHAMBER)+1
+ $ ,ich*(HDC_PLANES_PER_CHAMBER)
+ HAA3(i,j)=HAA3(i,j) + hstubcoef(k,i)*hstubcoef(k,j)
+ $ *hdum4of6coeff(k)
+ enddo
+ endif
+ endif
+ endif !end test j lt i
+ enddo !end j loop
+ enddo !end i loop
+
+* form the inverse matrix HAAINV3 for each configuration
+ HAAINV3(1,1,pindex)=(HAA3(2,2)*HAA3(3,3)-HAA3(2,3)**2)
+ HAAINV3(1,2,pindex)=-(HAA3(1,2)*HAA3(3,3)-HAA3(1,3)*HAA3(2,3))
+ HAAINV3(1,3,pindex)=(HAA3(1,2)*HAA3(2,3)-HAA3(1,3)*HAA3(2,2))
+ HDET3(pindex)=HAA3(1,1)*HAAINV3(1,1,pindex)+HAA3(1,2)*HAAINV3(1,2
+ $ ,pindex)+HAA3(1,3)*HAAINV3(1,3,pindex)
+ if(abs(hdet3(pindex)).le.1e-20)then
+ write(6,*
+ $ )'******************************************************'
+ write(6,*
+ $ )'Warning! Determinate of matrix HAA3(i,j) is nearly zero.'
+ write(6,*)'All tracks using pindex=',pindex,' will be zerfucked.'
+ write(6,*)'Fix problem in h_generate_geometry.f or else!'
+ write(6,*
+ $ )'******************************************************'
+ hdet3(pindex)=1.
+ endif
+ HAAINV3(1,1,pindex)=HAAINV3(1,1,pindex)/HDET3(pindex)
+ HAAINV3(1,2,pindex)=HAAINV3(1,2,pindex)/HDET3(pindex)
+ HAAINV3(1,3,pindex)=HAAINV3(1,3,pindex)/HDET3(pindex)
+ HAAINV3(2,2,pindex)=(HAA3(1,1)*HAA3(3,3)-HAA3(1,3)**2)/HDET3(pindex
+ $ )
+ HAAINV3(2,3,pindex)= -(HAA3(1,1)*HAA3(2,3)-HAA3(1,2)*HAA3(3,1))
+ $ /HDET3(pindex)
+ HAAINV3(3,3,pindex)=(HAA3(1,1)*HAA3(2,2)-HAA3(1,2)**2)/HDET3(pindex
+ $ )
+
+ enddo !end pindex loop
+
+* for debug write out all parameters
+ if(hdebugflaggeometry.ne.0) then
+ write(hluno,'('' HMS PLANE PARAMETERS: '')')
+ write(hluno,'('' plane z0 alpha beta gamma wire ''
+ & '' number center resolution'')')
+ write(hluno,'('' number spacing ''
+ & '' wires position'')')
+ write(hluno,1000) (hdc_plane_num(j),
+ & hdc_zpos(j),
+ & hdc_alpha_angle(j),
+ & hdc_beta_angle(j),
+ & hdc_gamma_angle(j),
+ & hdc_pitch(j),
+ & hdc_nrwire(j),
+ & hdc_central_wire(j),
+ & hdc_sigma(j),j=1,hdc_num_planes)
+1000 format(1x,i4,f9.4,3f10.6,f8.4,i6,f10.4,f10.6)
+ write(hluno,'('' plane'',
+ & '' hzchi hzpsi hxchi hxpsi hychi hypsi'')')
+ write(hluno,1001) (i, hzchi(i),hzpsi(i),hxchi(i),hxpsi(i),hychi(i),
+ & hypsi(i),i=1,hdc_num_planes )
+1001 format(i5,6f10.6)
+ write(hluno,'(''plane'',
+ & '' hpsi0 hchi0 hphi0'')')
+ write(hluno,1002) (i, hpsi0(i),hchi0(i),hphi0(i),i=1,hdc_num_planes)
+1002 format(i5,3f12.6)
+ write(hluno,'('' plane'',
+ & '' hstubcoef 1 2 3 4'')')
+ write(hluno,1003) (i, hstubcoef(i,1),hstubcoef(i,2),hstubcoef(i,3),
+ & hstubcoef(i,4),i=1,hdc_num_planes)
+1003 format(i5,4f15.6)
+ write(hluno,'('' hplane_coeff'')')
+ write(hluno,'('' plane 1 2 3 4 5'',
+ & '' 6 7 8 9'')')
+ do j=1,hdc_num_planes
+ write(hluno,1004) j,(hplane_coeff(i,j),i=1,9)
+ enddo ! end of print over planes loop
+1004 format(1x,i3,f10.5,2f8.3,f9.3,4f8.3,f9.3)
+*
+ endif ! end if on debug print out
+ return
+ end
diff --git a/HTRACKING/h_init_cal.f b/HTRACKING/h_init_cal.f
new file mode 100644
index 0000000..3751da1
--- /dev/null
+++ b/HTRACKING/h_init_cal.f
@@ -0,0 +1,85 @@
+*=======================================================================
+ subroutine h_init_cal(abort,errmsg)
+*=======================================================================
+*-
+*- Purpose: HMS Calorimeter Initialization
+*-
+*- Created: 20 Mar 1994 Tsolak A. Amatuni
+* $Log: h_init_cal.f,v $
+* Revision 1.5 2003/04/03 00:43:13 jones
+* Update to calibration (V. Tadevosyan0
+*
+* Revision 1.4 1998/12/17 22:02:39 saw
+* Support extra set of tubes on HMS shower counter
+*
+* Revision 1.3 1995/05/22 19:39:13 cdaq
+* (SAW) Split gen_data_data_structures into gen, hms, sos, and coin parts"
+*
+* Revision 1.2 1994/06/14 03:12:22 cdaq
+* (DFG) make all parameters CTP, not hard wired
+*
+* Revision 1.1 1994/04/13 15:39:11 cdaq
+* Initial revision
+*
+*-----------------------------------------------------------------------
+*
+*
+ implicit none
+ save
+*
+ logical abort
+ character*(*) errmsg
+ character*10 here
+ parameter (here='H_INIT_CAL')
+*
+ integer*4 block !Block number
+ integer*4 row !Row number
+ integer*4 column !Column number
+*
+ include 'hms_data_structures.cmn'
+ include 'hms_calorimeter.cmn'
+ data hcal_num_neg_columns /0/ ! No extra tubes unless specified in parm files
+*
+*-----Initialize the positions
+ do column=1,hmax_cal_columns
+ do row=1,hmax_cal_rows
+ block=row+hmax_cal_rows*(column-1)
+*
+ if(column.eq.1) then
+ hcal_block_xc(block)=hcal_1pr_top(row)+0.5*hcal_1pr_thick
+ hcal_block_yc(block)=0.5*(hcal_1pr_left+hcal_1pr_right)
+ hcal_block_zc(block)=hcal_1pr_zpos+0.5*hcal_1pr_thick
+ else if(column.eq.2) then
+ hcal_block_xc(block)=hcal_2ta_top(row)+0.5*hcal_2ta_thick
+ hcal_block_yc(block)=0.5*(hcal_2ta_left+hcal_2ta_right)
+ hcal_block_zc(block)=hcal_2ta_zpos+0.5*hcal_2ta_thick
+ else if(column.eq.3) then
+ hcal_block_xc(block)=hcal_3ta_top(row)+0.5*hcal_3ta_thick
+ hcal_block_yc(block)=0.5*(hcal_3ta_left+hcal_3ta_right)
+ hcal_block_zc(block)=hcal_3ta_zpos+0.5*hcal_3ta_thick
+ else
+ hcal_block_xc(block)=hcal_4ta_top(row)+0.5*hcal_4ta_thick
+ hcal_block_yc(block)=0.5*(hcal_4ta_left+hcal_4ta_right)
+ hcal_block_zc(block)=hcal_4ta_zpos+0.5*hcal_4ta_thick
+ endif
+ enddo !End loop over rows
+ enddo !End loop over columns
+*
+ hcal_block_xsize= hcal_4ta_top(2) - hcal_4ta_top(1)
+ hcal_block_ysize= hcal_4ta_left - hcal_4ta_right
+ hcal_block_zsize= hcal_4ta_thick
+ hcal_xmax= hcal_4ta_top(hcal_4ta_nr) + hcal_block_xsize
+ hcal_xmin= hcal_4ta_top(1)
+ hcal_ymax= hcal_4ta_left
+ hcal_ymin= hcal_4ta_right
+ hcal_zmin= hcal_1pr_zpos
+ hcal_zmax= hcal_4ta_zpos
+ hcal_fv_xmin=hcal_xmin+5.
+ hcal_fv_xmax=hcal_xmax-5.
+ hcal_fv_ymin=hcal_ymin+5.
+ hcal_fv_ymax=hcal_ymax-5.
+ hcal_fv_zmin=hcal_zmin
+ hcal_fv_zmax=hcal_zmax
+*
+ return
+ end
diff --git a/HTRACKING/h_init_cer.f b/HTRACKING/h_init_cer.f
new file mode 100644
index 0000000..b12f98e
--- /dev/null
+++ b/HTRACKING/h_init_cer.f
@@ -0,0 +1,35 @@
+
+ subroutine h_init_cer(ABORT,err)
+
+*-------------------------------------------------------------------
+*
+* author: Chris Cothran
+* created: 5/25/95
+*
+* h_init_cer initializes parameters relevant to the HMS Cerenkov.
+* $Log: h_init_cer.f,v $
+* Revision 1.1 1995/08/31 14:53:56 cdaq
+* Initial revision
+*
+*-------------------------------------------------------------------
+
+ implicit none
+
+ include 'hms_cer_parms.cmn'
+
+ logical abort
+ character*(*) err
+ character*20 here
+ parameter (here='h_init_cer')
+
+ integer*4 ii
+
+ save
+
+ do ii = 1, hcer_num_regions
+ hcer_track_counter(ii) = 0
+ hcer_fired_counter(ii) = 0
+ enddo
+
+ return
+ end
diff --git a/HTRACKING/h_init_fpp.f b/HTRACKING/h_init_fpp.f
new file mode 100644
index 0000000..3a12968
--- /dev/null
+++ b/HTRACKING/h_init_fpp.f
@@ -0,0 +1,215 @@
+ SUBROUTINE h_init_fpp(ABORT,err)
+*--------------------------------------------------------
+* Hall C HMS Focal Plane Polarimeter Code
+*
+* Purpose: initialize FPP parameters and constants
+*
+* Created by Frank R. Wesselmann, February 2004
+*
+*--------------------------------------------------------
+
+ IMPLICIT NONE
+
+ include 'gen_detectorids.par'
+ include 'gen_decode_common.cmn'
+ INCLUDE 'hms_data_structures.cmn'
+ INCLUDE 'hms_fpp_params.cmn'
+ INCLUDE 'hms_geometry.cmn'
+
+ INCLUDE 'hms_fpp_params.dte'
+
+ character*10 here
+ parameter (here= 'h_init_fpp')
+
+ logical ABORT
+ character*(*) err
+
+ real*4 pi
+ parameter (pi=3.1415926535)
+
+ integer*4 iSet, iChamber, iLayer, iPlane, iWire
+ integer*4 ilab, iloc, ii, wlo, whi, wstep, sign
+ real*4 sinalpha, sinbeta, singamma
+ real*4 cosalpha, cosbeta, cosgamma
+ real*4 matrix(3,3)
+ real*4 Imatrix(3,3)
+
+ ABORT= .FALSE.
+ err= ' '
+
+
+* * re-map per-plane parameters into (set,chamber,layer) set
+ do iset=1, H_FPP_N_DCSETS
+ do ichamber=1, H_FPP_N_DCINSET
+ do ilayer=1, H_FPP_N_DCLAYERS
+
+* * for these first quantities, the values for all chamber sets are identical, thus
+* * they got defined only for one set and get duplicated for all (two) sets (pairs)
+ iPlane = H_FPP_N_DCLAYERS * (iChamber-1) + ilayer
+
+ HFPP_spacing(iset,ichamber,ilayer) = inplanespacing(iPlane)
+ HFPP_layeroffset(iset,ichamber,ilayer) = planeoffset(iPlane)
+ HFPP_layerZ(iset,ichamber,ilayer) = planeZ(iPlane)
+
+ HFPP_direction(iset,ichamber,ilayer,1) = cos( planeangle(iPlane) *pi/180.)
+ HFPP_direction(iset,ichamber,ilayer,2) = sin( planeangle(iPlane) *pi/180.)
+* * when we do tracking, we work in 2D only, u and z
+* * u is part of (u,v) which is defined by a rotation gamma around
+* * the z-axis, from the x-axis towards the y-axis (right-handed)
+* * the z axis here is defined by the CHAMBERS not the HMS
+* * we later rotate the tracks appropriately into the HMS frame
+* * for now all we need are Px and Py such that u = x*Px + y*Py
+
+* * the following quantities can have different values for each chamber sets,
+* * so we need to distinguish between chamber sets in the in/out, too!
+ iPlane = iPlane + H_FPP_N_DCLAYERS * H_FPP_N_DCINSET * (iSet-1)
+ HFPP_resolution(iset,ichamber,ilayer) = HFPP_planeresolution(iPlane)
+
+ enddo
+ enddo
+ enddo
+
+
+* * re-map card position array into (set,chamber,layer,wire) variable
+ do iset=1, H_FPP_N_DCSETS
+ do ichamber=1, H_FPP_N_DCINSET
+ do ilayer=1, H_FPP_N_DCLAYERS
+ do iWire=1, H_FPP_MAX_WIRES
+ HFPP_cardpos(iSet,iChamber,iLayer,iWire) = 0
+ enddo
+ enddo
+ enddo
+ enddo
+
+ do ii=1,FPPNUMCARDS
+ iSet = fpp_planemap(2,ii)
+ iChamber = fpp_planemap(3,ii)
+ iLayer = fpp_planemap(4,ii)
+ wlo = fpp_planemap(6,ii)
+ whi = fpp_planemap(7,ii)
+ sign = fpp_planemap(8,ii)
+ if (wlo.lt.whi) then
+ wstep = 1
+ else
+ wstep = -1
+ endif
+ do iWire=wlo,whi,wstep
+ HFPP_cardpos(iSet,iChamber,iLayer,iWire) = sign
+ enddo
+ enddo
+
+
+* * create mapping from plane to set,chamber,layer
+ do iset=1, H_FPP_N_DCSETS
+ do ichamber=1, H_FPP_N_DCINSET
+ do ilayer=1, H_FPP_N_DCLAYERS
+
+ iPlane = H_FPP_N_DCLAYERS * H_FPP_N_DCINSET * (iSet-1)
+ > + H_FPP_N_DCLAYERS * (iChamber-1)
+ > + iLayer
+
+ HFPP_plane2set(iPlane) = iSet
+ HFPP_plane2chamber(iPlane) = iChamber
+ HFPP_plane2layer(iPlane) = iLayer
+
+ enddo !ilayer
+ enddo !ichamber
+ enddo !iset
+
+
+
+ if (.true.) then
+* * output geometry params to verify proper reading of param file
+ do iset=1, H_FPP_N_DCSETS
+ write(6,123) iset,HFPP_Xoff(iset), HFPP_Yoff(iset)
+ do ichamber=1, H_FPP_N_DCINSET
+ write(6,*) ''
+ do ilayer=1, H_FPP_N_DCLAYERS
+
+ iPlane = H_FPP_N_DCLAYERS * H_FPP_N_DCINSET * (iSet-1)
+ > + H_FPP_N_DCLAYERS * (iChamber-1)
+ > + ilayer
+
+ write(6,124) ichamber,ilayer,
+ > HFPP_layerZ(iset,ichamber,ilayer),
+ > HFPP_direction(iset,ichamber,ilayer,1),HFPP_direction(iset,ichamber,ilayer,2),
+ > HFPP_layeroffset(iset,ichamber,ilayer), HFPP_Nwires(iplane),
+ > HFPP_spacing(iset,ichamber,ilayer), HFPP_resolution(iset,ichamber,ilayer),
+ > HFPP_gamma(iset)
+ enddo
+ enddo
+ enddo
+ endif
+
+ 123 FORMAT (2x,i1,' chamber x,y ', 2(1x,f5.1))
+ 124 FORMAT (5x,2(1x,i1),' z=',f6.1, ' dx,dy=',2(f6.3,1x),' Off=',f6.1,
+ > ' wires=',i3,' spc=',f4.2,' res=',f5.3,' rot=',f6.2)
+
+
+
+
+* * calculate the rotation matrices for chamber sets
+* * definition of Euler rotation angles as per G. Arfken, pp.199
+ do iset=1, H_FPP_N_DCSETS
+
+ sinalpha = sin( HFPP_alpha(iset) *pi/180.)
+ sinbeta = sin( HFPP_beta(iset) *pi/180.)
+ singamma = sin( HFPP_gamma(iset) *pi/180.)
+
+ cosalpha = cos( HFPP_alpha(iset) *pi/180.)
+ cosbeta = cos( HFPP_beta(iset) *pi/180.)
+ cosgamma = cos( HFPP_gamma(iset) *pi/180.)
+
+* * matrix is such that: (x,y,z CHAMBER) = [M] x (x,y,z HMS)
+*
+* * ,---- 1=x,2=y,3=z in layer's coords
+* * | ,-- 1=x,2=y,3=z in lab coords
+ matrix(1,1) = cosalpha*cosbeta*cosgamma - sinalpha*singamma
+ matrix(1,2) = sinalpha*cosbeta*cosgamma + cosalpha*singamma
+ matrix(1,3) = -1.0* sinbeta*cosgamma
+
+ matrix(2,1) = -1.0*cosalpha*cosbeta*singamma - sinalpha*cosgamma
+ matrix(2,2) = -1.0*sinalpha*cosbeta*singamma + cosalpha*cosgamma
+ matrix(2,3) = sinbeta*singamma
+
+ matrix(3,1) = cosalpha*sinbeta
+ matrix(3,2) = sinalpha*sinbeta
+ matrix(3,3) = cosbeta
+
+* * INVERSE matrix is such that: (x,y,z HMS) = [M-1] x (x,y,z CHAMBER)
+*
+* * ,---- 1=x,2=y,3=z in lab coords
+* * | ,-- 1=x,2=y,3=z in layer's coords
+ Imatrix(1,1) = cosalpha*cosbeta*cosgamma - sinalpha*singamma
+ Imatrix(1,2) = -1.0*cosalpha*cosbeta*singamma - sinalpha*cosgamma
+ Imatrix(1,3) = cosalpha*sinbeta
+
+ Imatrix(2,1) = sinalpha*cosbeta*cosgamma + cosalpha*singamma
+ Imatrix(2,2) = -1.0*sinalpha*cosbeta*singamma + cosalpha*cosgamma
+ Imatrix(2,3) = sinalpha*sinbeta
+
+ Imatrix(3,1) = -1.0* sinbeta*cosgamma
+ Imatrix(3,2) = sinbeta*singamma
+ Imatrix(3,3) = cosbeta
+
+* * now copy the easy-to-read local matrix to the shared array
+* * note the reversal of indices between the matrices!!
+ do ilab=1,3
+ do iloc=1,3
+ HFPP_Mrotation(iset,iloc,ilab) = matrix(iloc,ilab)
+ HFPP_Irotation(iset,ilab,iloc) = Imatrix(ilab,iloc)
+ enddo !iloc
+ enddo !ilab
+
+ enddo !iset
+
+
+* * initialize driftmap
+ call h_fpp_drift_init(ABORT,err)
+ IF(ABORT) THEN
+ call G_add_path(here,err)
+ ENDIF
+
+
+ RETURN
+ END
diff --git a/HTRACKING/h_init_histid.f b/HTRACKING/h_init_histid.f
new file mode 100644
index 0000000..bd5445c
--- /dev/null
+++ b/HTRACKING/h_init_histid.f
@@ -0,0 +1,385 @@
+ subroutine h_init_histid(Abort,err)
+*
+* routine to get HBOOK histogram ID numbers for all hard coded
+* histograms.
+*
+* Author: D. F. Geesaman
+* Date: 9 April 1994
+*
+* $Log: h_init_histid.f,v $
+* Revision 1.8.24.3 2007/10/30 00:28:27 cdaq
+* added FPP geometric alignment checks
+*
+* Revision 1.8.24.2 2007/10/22 18:39:10 cdaq
+* adjusted HMS FPP histos
+*
+* Revision 1.8.24.1 2007/08/22 19:09:30 frw
+* added FPP
+*
+* Revision 1.10 2006/06/22 frw
+* added HMS FPP entries
+*
+* Revision 1.9 2002/12/20 21:53:33 jones
+* Modified by Hamlet for new HMS aerogel
+*
+* Revision 1.8 2002/10/05 (Hamlet)
+* Add HMS Aerogel
+*
+* Revision 1.7 1999/02/23 18:38:56 csa
+* (JRA) Add pos/neg cal stuff
+*
+* Revision 1.6 1999/02/03 21:13:23 saw
+* Code for new Shower counter tubes
+*
+* Revision 1.5 1996/08/30 19:55:09 saw
+* (JRA) Get id for misc. TDC's
+*
+* Revision 1.4 1996/01/16 21:52:05 cdaq
+* (JRA) Add hidcuttdc, hidscinalltimes, and hidscintimes
+*
+* Revision 1.3 1995/08/31 14:53:47 cdaq
+* (JRA) Add dpos (pos. track - pos. hit) histograms
+*
+* Revision 1.2 1995/07/19 18:20:41 cdaq
+* (JRA) Add per hit adc/tdc sums for hodo and calormeter
+* (SAW) Relocate data statements for f2c compatibility
+*
+* Revision 1.1 1995/05/22 18:33:05 cdaq
+* Initial revision
+*
+* Revision 1.6 1995/05/12 12:23:22 cdaq
+* (JRA) Modify/add user histograms
+*
+* Revision 1.5 1995/04/06 20:33:34 cdaq
+* (SAW) Fix SOS wc plane names. Add SOS residuals histogram id's
+*
+c Revision 1.4 1995/03/14 21:01:18 cdaq
+c (SAW) Change ?scin_num_counters to ?num_scin_counters
+c
+c Revision 1.3 1994/08/18 03:13:51 cdaq
+c (SAW) Use arrays of histids for residuals, new names for residuals histos
+c
+c Revision 1.2 1994/05/12 18:59:14 cdaq
+c (DFG) Add hms_target and sos_target histid
+c
+c Revision 1.1 1994/05/12 18:56:22 cdaq
+c Initial revision
+c
+* Revision 1.1 1994/04/12 21:00:57 cdaq
+* Initial revision
+*
+*-
+*--------------------------------------------------------
+ IMPLICIT NONE
+*
+ character*13 here
+ parameter (here= 'h_init_histid')
+*
+ logical ABORT
+ character*(*) err
+ external thgetid
+ integer*4 thgetid
+ integer*4 plane,counter
+ integer*4 set,chamber,layer
+*
+ include 'hms_data_structures.cmn'
+ include 'hms_tracking.cmn'
+ include 'hms_track_histid.cmn'
+ include 'hms_scin_parms.cmn'
+ include 'hms_id_histid.cmn'
+
+ character*32 histname
+
+ character*8 wiremap
+ character*10 drifttime
+ character*9 driftdis
+ character*9 wirecent
+ character*9 residual
+ character*9 singres
+ character*6 hdcplanename(hmax_num_dc_planes)
+ character*1 hscinplanenum(HNUM_SCIN_PLANES)
+ character*10 hscinplane
+ character*7 hscinplanename(HNUM_SCIN_PLANES)
+ character*6 posadc,negadc,postdc,negtdc
+ character*7 hposadc,hnegadc,hpostdc,hnegtdc
+
+ data wiremap/'_wiremap'/
+ data drifttime/'_drifttime'/
+ data driftdis /'_driftdis'/
+ data wirecent/'_wirecent'/
+ data residual/'_residual'/
+ data singres/'_sing_res'/
+ data hdcplanename/'hdc1x1','hdc1y1','hdc1u1','hdc1v1','hdc1y2'
+ $ ,'hdc1x2','hdc2x1','hdc2y1','hdc2u1','hdc2v1','hdc2y2','hdc2x2'/
+ data hscinplanenum/'1','2','3','4'/
+ data hscinplane /'hscinplane'/
+ data hscinplanename/'hscin1x','hscin1y','hscin2x','hscin2y'/
+ data posadc /'posadc'/
+ data negadc /'negadc'/
+ data postdc /'postdc'/
+ data negtdc /'negtdc'/
+ data hposadc /'hposadc'/
+ data hnegadc /'hnegadc'/
+ data hpostdc /'hpostdc'/
+ data hnegtdc /'hnegtdc'/
+
+*
+ SAVE
+*--------------------------------------------------------
+*
+ ABORT= .FALSE.
+ err= ' '
+* Histogram block hms_target
+*
+ hidhx_tar = thgetid('hx_tar')
+ hidhy_tar = thgetid('hy_tar')
+ hidhz_tar = thgetid('hz_tar')
+ hidhxp_tar = thgetid('hxp_tar')
+ hidhyp_tar = thgetid('hyp_tar')
+ hidhdelta_tar = thgetid('hdelta_tar')
+ hidhp_tar = thgetid('hp_tar')
+
+* histogram block hms_focal_plane
+*
+ hidhx_fp = thgetid('hx_fp')
+ hidhy_fp = thgetid('hy_fp')
+ hidhxp_fp = thgetid('hxp_fp')
+ hidhyp_fp = thgetid('hyp_fp')
+ hidhlogchi2_fp = thgetid('hlogchi2_fp')
+ hidhnfree_fp = thgetid('hnfree_fp')
+ hidhchi2perdeg_fp = thgetid('hchi2perdeg_fp')
+
+* histogram block hms_decoded_dc
+ hidrawtdc = thgetid('hdcrawtdc')
+ hidcuttdc = thgetid('hdccuttdc')
+ do plane = 1, hdc_num_planes
+ histname = hdcplanename(plane)//wiremap
+ hiddcwiremap(plane) = thgetid(histname)
+ histname = hdcplanename(plane)//drifttime
+ hiddcdrifttime(plane) = thgetid(histname)
+ histname = hdcplanename(plane)//driftdis
+ hiddcdriftdis(plane) = thgetid(histname)
+ histname = hdcplanename(plane)//wirecent
+ hiddcwirecent(plane) = thgetid(histname)
+ histname = hdcplanename(plane)//residual
+ hidres_fp(plane) = thgetid(histname)
+ histname = hdcplanename(plane)//singres
+ hidsingres_fp(plane) = thgetid(histname)
+ enddo ! end loop over dc planes
+
+* histogram block hms_raw_sc
+
+ hidscinrawtothits = thgetid('hscintothits')
+ hidscinplane = thgetid('hscinplane')
+ hidscinalltimes = thgetid('hscinalltimes')
+ hidscintimes = thgetid('hscintimes')
+ hnum_scin_counters(1) = hscin_1x_nr
+ hnum_scin_counters(2) = hscin_1y_nr
+ hnum_scin_counters(3) = hscin_2x_nr
+ hnum_scin_counters(4) = hscin_2y_nr
+
+ hiddcdposx = thgetid('hdcdposx')
+ hiddcdposy = thgetid('hdcdposy')
+ hiddcdposxp = thgetid('hdcdposxp')
+ hiddcdposyp = thgetid('hdcdposyp')
+ hidcaldpos = thgetid('hcaldpos')
+
+ do plane = 1, HNUM_SCIN_PLANES
+ histname = hscinplane//hscinplanenum(plane)
+ hidscincounters(plane) = thgetid(histname)
+ histname = hpostdc//hscinplanenum(plane)
+ hidscinallpostdc(plane) = thgetid(histname)
+ histname = hnegtdc//hscinplanenum(plane)
+ hidscinallnegtdc(plane) = thgetid(histname)
+ histname = hposadc//hscinplanenum(plane)
+ hidscinallposadc(plane) = thgetid(histname)
+ histname = hnegadc//hscinplanenum(plane)
+ hidscinallnegadc(plane) = thgetid(histname)
+
+ histname = "hsumpostdc"//hscinplanenum(plane)
+ hidsumpostdc(plane) = thgetid(histname)
+ histname = "hsumnegtdc"//hscinplanenum(plane)
+ hidsumnegtdc(plane) = thgetid(histname)
+ histname = "hsumposadc"//hscinplanenum(plane)
+ hidsumposadc(plane) = thgetid(histname)
+ histname = "hsumnegadc"//hscinplanenum(plane)
+ hidsumnegadc(plane) = thgetid(histname)
+
+ histname = "hscindpos"//hscinplanenum(plane)
+ hidscindpos(plane) = thgetid(histname)
+ histname = "hscindpos_pid"//hscinplanenum(plane)
+ hidscindpos_pid(plane) = thgetid(histname)
+
+ do counter = 1,hnum_scin_counters(plane)
+* this is probably very awkward character manipulation
+*
+ if(counter.lt.10) then
+ write(histname,'(a7,i1,a6)') hscinplanename(plane),counter,posadc
+ else
+ write(histname,'(a7,i2,a6)') hscinplanename(plane),counter,posadc
+ endif
+ hidscinposadc(plane,counter) = thgetid(histname)
+ if(counter.lt.10) then
+ write(histname,'(a7,i1,a6)') hscinplanename(plane),counter,negadc
+ else
+ write(histname,'(a7,i2,a6)') hscinplanename(plane),counter,negadc
+ endif
+ hidscinnegadc(plane,counter) = thgetid(histname)
+ if(counter.lt.10) then
+ write(histname,'(a7,i1,a6)') hscinplanename(plane),counter,postdc
+ else
+ write(histname,'(a7,i2,a6)') hscinplanename(plane),counter,postdc
+ endif
+ hidscinpostdc(plane,counter) = thgetid(histname)
+ if(counter.lt.10) then
+ write(histname,'(a7,i1,a6)') hscinplanename(plane),counter,negtdc
+ else
+ write(histname,'(a7,i2,a6)') hscinplanename(plane),counter,negtdc
+ endif
+ hidscinnegtdc(plane,counter) = thgetid(histname)
+ enddo ! end loop over scintillator counters
+ enddo ! end loop over scintillator plane
+
+*
+ hidcalplane = thgetid('hcalplane')
+ hidcalposhits(1) = thgetid('hcalaposhits')
+ hidcalposhits(2) = thgetid('hcalbposhits')
+ hidcalposhits(3) = thgetid('hcalcposhits')
+ hidcalposhits(4) = thgetid('hcaldposhits')
+ hidcalneghits(1) = thgetid('hcalaneghits')
+ hidcalneghits(2) = thgetid('hcalbneghits')
+ hidcalneghits(3) = thgetid('hcalcneghits')
+ hidcalneghits(4) = thgetid('hcaldneghits')
+ hidcalsumadc = thgetid('hcalsumadc')
+
+ hidmisctdcs = thgetid('hmisctdcs')
+
+c
+* HMS Aerogel
+
+ hidhaero_adc_pos_hits = thgetid('haeroadcposhits')
+ hidhaero_adc_neg_hits = thgetid('haeroadcneghits')
+ hidhaero_tdc_pos_hits = thgetid('haerotdcposhits')
+ hidhaero_tdc_neg_hits = thgetid('haerotdcneghits')
+ hidhaero_adc_pos_pedsubtr = thgetid('haeroadcpospedsubtr')
+ hidhaero_adc_neg_pedsubtr = thgetid('haeroadcnegpedsubtr')
+c
+* HMS FPP
+
+ hidFPP_tdcROC = thgetid('hfpp_tdcroc')
+
+ do plane = 1,H_FPP_N_PLANES
+ if(plane.lt.10) then
+ write(histname,'(''hfpp_rawinclust'',i1)') plane
+ hidFPP_rawinclust(plane) = thgetid(histname)
+ write(histname,'(''hfpp_tdc'',i1)') plane
+ hidFPP_tdc(plane) = thgetid(histname)
+ write(histname,'(''hfpp_Tall'',i1)') plane
+ hidFPP_alltimes(plane) = thgetid(histname)
+ write(histname,'(''hfpp_Tone'',i1)') plane
+ hidFPP_time1(plane) = thgetid(histname)
+ write(histname,'(''hfpp_T12_'',i1)') plane
+ hidFPP_time12(plane) = thgetid(histname)
+ write(histname,'(''hfpp_rate1_'',i1)') plane
+ hidFPP_rate1(plane) = thgetid(histname)
+ write(histname,'(''hfpp_time'',i1)') plane
+ hidFPP_planetime(plane) = thgetid(histname)
+ else
+ write(histname,'(''hfpp_rawinclust'',i2)') plane
+ hidFPP_rawinclust(plane) = thgetid(histname)
+ write(histname,'(''hfpp_tdc'',i2)') plane
+ hidFPP_tdc(plane) = thgetid(histname)
+ write(histname,'(''hfpp_Tall'',i2)') plane
+ hidFPP_alltimes(plane) = thgetid(histname)
+ write(histname,'(''hfpp_Tone'',i2)') plane
+ hidFPP_time1(plane) = thgetid(histname)
+ write(histname,'(''hfpp_T12_'',i2)') plane
+ hidFPP_time12(plane) = thgetid(histname)
+ write(histname,'(''hfpp_rate1_'',i2)') plane
+ hidFPP_rate1(plane) = thgetid(histname)
+ write(histname,'(''hfpp_time'',i2)') plane
+ hidFPP_planetime(plane) = thgetid(histname)
+ endif
+ enddo
+
+ do set=1,H_FPP_N_DCSETS
+ write(histname,'(''hfpp_NickEff_'',i1)') set
+ hidFPP_NickEff(set) = thgetid(histname)
+
+ write(histname,'(''hfpp_'',i1,''ntrk'')') set
+ hidFPP_Ntrk(set) = thgetid(histname)
+ write(histname,'(''hfpp_'',i1,''trk_chi2'')') set
+ hidFPP_trk_chi2(set) = thgetid(histname)
+ write(histname,'(''hfpp_'',i1,''trk_mx'')') set ! focal plane coords
+ hidFPP_trk_mx(set) = thgetid(histname)
+ write(histname,'(''hfpp_'',i1,''trk_bx'')') set ! focal plane coords
+ hidFPP_trk_bx(set) = thgetid(histname)
+ write(histname,'(''hfpp_'',i1,''trk_my'')') set ! focal plane coords
+ hidFPP_trk_my(set) = thgetid(histname)
+ write(histname,'(''hfpp_'',i1,''trk_by'')') set ! focal plane coords
+ hidFPP_trk_by(set) = thgetid(histname)
+ write(histname,'(''hfpp_'',i1,''ntrkhit'')') set
+ hidFPP_Nhitontrk(set) = thgetid(histname)
+ write(histname,'(''hfpp_'',i1,''ntrkraw'')') set
+ hidFPP_Nrawontrk(set) = thgetid(histname)
+ write(histname,'(''hfpp_'',i1,''rough_mx'')') set ! chamber coords
+ hidFPP_trkrough(set,1) = thgetid(histname)
+ write(histname,'(''hfpp_'',i1,''rough_bx'')') set ! chamber coords
+ hidFPP_trkrough(set,2) = thgetid(histname)
+ write(histname,'(''hfpp_'',i1,''rough_my'')') set ! chamber coords
+ hidFPP_trkrough(set,3) = thgetid(histname)
+ write(histname,'(''hfpp_'',i1,''rough_by'')') set ! chamber coords
+ hidFPP_trkrough(set,4) = thgetid(histname)
+ write(histname,'(''hfpp_'',i1,''rough_chi2'')') set
+ hidFPP_trkrough(set,5) = thgetid(histname)
+ write(histname,'(''hfpp_'',i1,''rough_nraw'')') set
+ hidFPP_trkrough(set,6) = thgetid(histname)
+ write(histname,'(''hfpp_'',i1,''fine_mx'')') set ! chamber coords
+ hidFPP_fine_mx(set) = thgetid(histname)
+ write(histname,'(''hfpp_'',i1,''fine_my'')') set ! chamber coords
+ hidFPP_fine_my(set) = thgetid(histname)
+ write(histname,'(''hfpp_'',i1,''fine_bx'')') set ! chamber coords
+ hidFPP_fine_bx(set) = thgetid(histname)
+ write(histname,'(''hfpp_'',i1,''fine_by'')') set ! chamber coords
+ hidFPP_fine_by(set) = thgetid(histname)
+
+ write(histname,'(''hfpp_'',i1,''sclose'')') set ! closest approach
+ hidFPP_sclose(set) = thgetid(histname)
+ write(histname,'(''hfpp_'',i1,''zclose'')') set ! z at closets
+ hidFPP_zclose(set) = thgetid(histname)
+ write(histname,'(''hfpp_'',i1,''theta'')') set ! polar theta
+ hidFPP_thetapol(set) = thgetid(histname)
+ write(histname,'(''hfpp_'',i1,''phi'')') set ! polar phi
+ hidFPP_phipol(set) = thgetid(histname)
+
+ write(histname,'(''hfpp_'',i1,''distance'')') set ! track--wire dist
+ hidFPP_dist(set) = thgetid(histname)
+ write(histname,'(''hfpp_'',i1,''linresol'')') set ! lin track resol
+ hidFPP_resol_lin(set) = thgetid(histname)
+ write(histname,'(''hfpp_'',i1,''angresol'')') set ! angular trk res
+ hidFPP_resol_ang(set) = thgetid(histname)
+ enddo
+
+ do set=1,H_FPP_N_DCSETS
+ do chamber=1,H_FPP_N_DCINSET
+ do layer=1,H_FPP_N_DCLAYERS
+ write(histname,'(''hfpp_driftT_'',3i1)') set, chamber, layer
+ hidFPP_driftT(set,chamber,layer) = thgetid(histname)
+ write(histname,'(''hfpp_driftX_'',3i1)') set, chamber, layer
+ hidFPP_driftX(set,chamber,layer) = thgetid(histname)
+ write(histname,'(''hfpp_shouldhit_'',3i1)') set, chamber, layer
+ hidFPP_should(set,chamber,layer) = thgetid(histname)
+ write(histname,'(''hfpp_didhit_'',3i1)') set, chamber, layer
+ hidFPP_did(set,chamber,layer) = thgetid(histname)
+ write(histname,'(''hfpp_hmswire_'',3i1)') set, chamber, layer
+ hid_HMSwire(set,chamber,layer) = thgetid(histname)
+ enddo
+ enddo
+ enddo
+
+ hid_rawROC(13) = thgetid('rawROC13')
+ hid_rawROC(14) = thgetid('rawROC14')
+
+ RETURN
+ END
+
diff --git a/HTRACKING/h_init_physics.f b/HTRACKING/h_init_physics.f
new file mode 100644
index 0000000..38a4455
--- /dev/null
+++ b/HTRACKING/h_init_physics.f
@@ -0,0 +1,69 @@
+ SUBROUTINE h_init_physics(ABORT,err)
+*--------------------------------------------------------
+*-
+*- Purpose and Methods : Initialize constants for h_physics
+*-
+*-
+*- Output: ABORT - success or failure
+*- : err - reason for failure, if any
+*-
+*- Created 6-6-94 D. F. Geesaman
+* $Log: h_init_physics.f,v $
+* Revision 1.6 1999/02/10 18:15:58 csa
+* Bug fix in sin/coshthetas calculations
+*
+* Revision 1.5 1996/08/30 19:56:13 saw
+* (JRA) avoid setting p=0??
+*
+* Revision 1.4 1996/01/24 15:57:36 saw
+* (JRA) Change variables to lower case
+*
+* Revision 1.3 1995/05/22 19:39:13 cdaq
+* (SAW) Split gen_data_data_structures into gen, hms, sos, and coin parts"
+*
+* Revision 1.2 1995/05/11 16:21:07 cdaq
+* (SAW) Force HMS to be in plane beam right
+*
+* Revision 1.1 1994/06/14 03:54:14 cdaq
+* Initial revision
+*
+*--------------------------------------------------------
+ IMPLICIT NONE
+ SAVE
+*
+ character*50 here
+ parameter (here= 'h_init_physics')
+*
+ logical ABORT
+ character*(*) err
+*
+ INCLUDE 'gen_data_structures.cmn'
+ INCLUDE 'hms_data_structures.cmn'
+ INCLUDE 'gen_constants.par'
+ INCLUDE 'gen_units.par'
+ INCLUDE 'hms_physics_sing.cmn'
+*
+* local variables
+*--------------------------------------------------------
+*
+ ABORT= .FALSE.
+ err= ' '
+*
+* Fix HMS to be in plane, beam right
+*
+ hphi_lab = 3*tt/2
+*
+ if (hmomentum_factor .gt. 0.1) then !avoid setting p=0
+ hpcentral = hpcentral * hmomentum_factor
+ endif
+*
+ coshthetas = cos(htheta_lab*degree)
+ sinhthetas = sin(htheta_lab*degree)
+* Constants for elastic kinematics calcultion
+ hphysicsa = 2.*gebeam*gtarg_mass(gtarg_num) -
+ $ mass_electron**2 - hpartmass**2
+ hphysicsb = 2. * (gtarg_mass(gtarg_num) - gebeam)
+ hphysicab2 = hphysicsa**2 * hphysicsb**2
+ hphysicsm3b = hpartmass**2 * hphysicsb**2
+ return
+ end
diff --git a/HTRACKING/h_init_scin.f b/HTRACKING/h_init_scin.f
new file mode 100644
index 0000000..f55261b
--- /dev/null
+++ b/HTRACKING/h_init_scin.f
@@ -0,0 +1,107 @@
+ subroutine h_init_scin(ABORT,err)
+
+*-------------------------------------------------------------------
+* author: John Arrington
+* created: 2/22/94
+*
+* h_init_scin initializes the corrections and parameters
+* for the scintillators. Corrections are read from data files
+* or the database. Arrays used by the tof fitting routines
+* are filled from the CTP variables input from the hms_positions
+* parameter file.
+*
+* modifications:
+* 23 March 1993 DFG
+* Remove /nolist from include statement. UNIX doesn't like it.
+* $Log: h_init_scin.f,v $
+* Revision 1.7 1996/04/30 12:44:35 saw
+* (JRA) Calculate expected particle velocity
+*
+* Revision 1.6 1995/05/22 19:39:14 cdaq
+* (SAW) Split gen_data_data_structures into gen, hms, sos, and coin parts"
+*
+* Revision 1.5 1995/02/23 13:35:34 cdaq
+* (JRA) Remove _coord fro hhodo_center array. Edge coordinates by
+* center locations.
+*
+* Revision 1.4 1994/09/13 19:40:10 cdaq
+* (JRA) Remove some unused variables
+*
+* Revision 1.3 1994/06/14 03:58:10 cdaq
+* (DFG) remove hard wired numbers
+*
+* Revision 1.2 1994/06/01 15:36:20 cdaq
+* (SAW) Add Abort and err arguments
+*
+* Revision 1.1 1994/04/13 15:39:39 cdaq
+* Initial revision
+*
+*-------------------------------------------------------------------
+
+ implicit none
+
+ include 'hms_data_structures.cmn'
+ include 'hms_scin_parms.cmn'
+ include 'hms_scin_tof.cmn'
+ include 'hms_statistics.cmn'
+
+ logical abort
+ character*(*) err
+ character*20 here
+ parameter (here='h_init_scin')
+
+ integer*4 plane,counter
+ save
+*
+*
+* initialize some position parameters.
+ hnum_scin_counters(1) = hscin_1x_nr
+ hnum_scin_counters(2) = hscin_1y_nr
+ hnum_scin_counters(3) = hscin_2x_nr
+ hnum_scin_counters(4) = hscin_2y_nr
+
+ hstat_numevents=0
+
+ do plane = 1 , hnum_scin_planes
+ do counter = 1 , hnum_scin_counters(plane)
+
+* initialize tof parameters.
+
+ if (plane .eq. 1) then
+ hhodo_width(plane,counter) = hscin_1x_size
+ hhodo_center(plane,counter) =
+ 1 hscin_1x_center(counter) + hscin_1x_offset
+ else if (plane .eq. 2) then
+ hhodo_width(plane,counter) = hscin_1y_size
+ hhodo_center(plane,counter) =
+ 1 hscin_1y_center(counter) + hscin_1y_offset
+ else if (plane .eq. 3) then
+ hhodo_width(plane,counter) = hscin_2x_size
+ hhodo_center(plane,counter) =
+ 1 hscin_2x_center(counter) + hscin_2x_offset
+ else if (plane .eq. 4) then
+ hhodo_width(plane,counter) = hscin_2y_size
+ hhodo_center(plane,counter) =
+ 1 hscin_2y_center(counter) + hscin_2y_offset
+ else ! Error in plane number
+ abort = .true.
+ write(err,*) 'Trying to init. hms hodoscope plane',plane
+ call g_prepend(here,err)
+ return
+ endif
+
+ hstat_trk(plane,counter)=0
+ hstat_poshit(plane,counter)=0
+ hstat_neghit(plane,counter)=0
+ hstat_andhit(plane,counter)=0
+ hstat_orhit(plane,counter)=0
+
+ enddo !loop over counters
+ enddo !loop over planes
+
+* need expected particle velocity for start time calculation.
+ hbeta_pcent = hpcentral/sqrt(hpcentral*hpcentral+hpartmass*hpartmass)
+
+
+ return
+ end
diff --git a/HTRACKING/h_left_right.f b/HTRACKING/h_left_right.f
new file mode 100644
index 0000000..be27796
--- /dev/null
+++ b/HTRACKING/h_left_right.f
@@ -0,0 +1,373 @@
+ subroutine H_LEFT_RIGHT(ABORT,err)
+* This routine fits stubs to all possible left-right combinations of
+* drift distances and chooses the set with the minimum chi**2
+* It then fills the HDC_WIRE_COORD variable for each hit in a good
+* space point.
+* d. f. geesaman 17 January 1994
+* $Log: h_left_right.f,v $
+* Revision 1.13.24.1 2007/09/10 20:28:00 pcarter
+* Implemented changes to allow compilation on RHEL 3,4,5 and MacOSX
+*
+* Revision 1.13 1999/02/23 18:39:52 csa
+* (JRA) Correct two typos in 4/6 code
+*
+* Revision 1.12 1999/02/10 18:23:41 csa
+* Added 4/6 tracking code (D. Meekins)
+*
+* Revision 1.11 1996/01/16 21:52:43 cdaq
+* (JRA)
+*
+* Revision 1.10 1995/10/10 15:56:36 cdaq
+* (JRA) Cleanup massive nested if's. Remove hdc_sing_wcoord stuff.
+*
+* Revision 1.9 1995/07/19 20:12:46 cdaq
+* (SAW) Declear jibset for f2c compatibility
+*
+* Revision 1.8 1995/05/22 19:39:14 cdaq
+* (SAW) Split gen_data_data_structures into gen, hms, sos, and coin parts"
+*
+* Revision 1.7 1995/04/06 19:29:23 cdaq
+* (JRA) HMAX_NUM_DC_PLANES -> HDC_NUM_PLANES
+*
+* Revision 1.6 1994/10/12 18:30:52 cdaq
+* (DJM) Fill hit pattern arrays
+*
+* Revision 1.5 1994/10/11 18:59:15 cdaq
+* (DJM) Fill hdc_sing_wcoord for histogramming
+*
+* Revision 1.4 1994/08/16 13:26:50 cdaq
+* (DJA) Fix typo (Change wc from integer*4 to real*4)
+*
+* Revision 1.3 1994/08/14 02:11:18 cdaq
+* (DA) Change Y' in chamber 1 from plane 4 (wrong) to plane 5 (correct)
+*
+* Revision 1.2 1994/08/04 15:03:46 cdaq
+* (DA) Incorporate small angle approximation of L/R for YY' planes
+*
+* Revision 1.1 1994/02/19 06:15:15 cdaq
+* Initial revision
+*
+*
+ implicit none
+ save
+ include 'hms_data_structures.cmn'
+ include 'hms_tracking.cmn'
+ include 'hms_geometry.cmn'
+*
+ external jbit ! cernlib bit routine
+ external jibset
+ integer*4 jbit
+ integer*4 jibset ! Declare to help f2c
+*
+* local variables
+*
+ character*12 here
+ parameter (here= 'h_left_right')
+*
+ logical ABORT
+ character*(*) err
+ integer*4 isp, ihit, iswhit, idummy,pmloop
+ integer*4 nplusminus
+ integer*4 numhits
+ integer*4 hits(hmax_hits_per_point),pl(hmax_hits_per_point)
+ integer*4 pindex,icounter
+ real*4 wc(hmax_hits_per_point)
+ integer*4 plane, isa_y1, isa_y2
+ integer*4 plusminusknown(hmax_hits_per_point)
+ real*4 plusminus(hmax_hits_per_point)
+ real*4 plusminusbest(hmax_hits_per_point),tmppmbest(hmax_hits_per_point)
+ real*4 tmpbeststub(hnum_fpray_param)
+ real*4 chi2
+ real*4 minchi2,tmpminchi2
+ real*4 xp_fit, xp_expect, minxp
+ real*4 stub(4)
+ logical smallAngOK
+*
+ ABORT= .FALSE.
+ err=' '
+
+* djm 10/2/94 added initialization/setting of gplanehdc1(isp)/2 pattern
+* units. Presently we are accepting 5/6 or 6/6 planes per chamber.
+
+ do isp=1,hnspace_points_tot ! loop over all space points
+* write(6,*) 'h_left_right: check 1: spacepoint ',isp
+ gplanehdc1(isp) = 0
+ gplanehdc2(isp) = 0
+ minchi2=1e10
+ minxp=0.25
+ smallAngOK = .FALSE.
+ isa_y1 = 0
+ isa_y2 = 0
+ numhits=hspace_point_hits(isp,1)
+ if (numhits.lt.0) then
+ write(6,*) 'h_left_right: numhits < 0'
+ elseif (numhits.eq.0) then
+ write(6,*) 'h_left_right: numhits = 0'
+ endif
+ nplusminus=2**numhits
+ do ihit=1,numhits
+ hits(ihit)=hspace_point_hits(isp,2+ihit)
+ pl(ihit)=HDC_PLANE_NUM(hits(ihit))
+
+ if(pl(ihit).ge.1 .and. pl(ihit).le.6)then
+ gplanehdc1(isp)=jibset(gplanehdc1(isp),pl(ihit)-1)
+ else
+ gplanehdc2(isp)=jibset(gplanehdc2(isp),pl(ihit)-7)
+ endif
+
+ wc(ihit)=HDC_WIRE_CENTER(hits(ihit))
+ plusminusknown(ihit) = 0
+ if(pl(ihit).eq.2 .OR. pl(ihit).eq.8) isa_y1 = ihit
+ if(pl(ihit).eq.5 .OR. pl(ihit).eq.11) isa_y2 = ihit
+ enddo
+
+* djm 10/2/94 check bad hdc pattern units to set the index for the inverse
+* matrix AAINV(i,j,pindex).
+ if(pl(1).ge.1 .and. pl(1).le.6)then !use first hit to test if hdc1
+
+ if(gplanehdc1(isp).eq.63)then
+ pindex=13 !first 6 bits set, so 6 planes hit
+ else if(gplanehdc1(isp).eq.62)then
+ pindex=1 !missing lowest order bit, missing x1
+ else if(gplanehdc1(isp).eq.61)then
+ pindex=2
+ else if(gplanehdc1(isp).eq.59)then
+ pindex=3
+ else if(gplanehdc1(isp).eq.55)then
+ pindex=4
+ else if(gplanehdc1(isp).eq.47)then
+ pindex=5
+ else if(gplanehdc1(isp).eq.31)then
+ pindex=6
+ else if(gplanehdc1(isp).eq.15)then !4/6 planes fire
+ pindex=15
+ else if(gplanehdc1(isp).eq.23)then !4/6 planes fire
+ pindex=16
+ else if(gplanehdc1(isp).eq.27)then !4/6 planes fire
+ pindex=17
+ else if(gplanehdc1(isp).eq.29)then !4/6 planes fire
+ pindex=18
+ else if(gplanehdc1(isp).eq.30)then !4/6 planes fire
+ pindex=19
+ else if(gplanehdc1(isp).eq.39)then !4/6 planes fire
+ pindex=20
+ else if(gplanehdc1(isp).eq.43)then !4/6 planes fire
+ pindex=21
+ else if(gplanehdc1(isp).eq.45)then !4/6 planes fire
+ pindex=22
+ else if(gplanehdc1(isp).eq.46)then !4/6 planes fire
+ pindex=23
+ else if(gplanehdc1(isp).eq.51)then !4/6 planes fire
+ pindex=24
+ else if(gplanehdc1(isp).eq.53)then !4/6 planes fire
+ pindex=25
+ else if(gplanehdc1(isp).eq.54)then !4/6 planes fire
+ pindex=26
+ else if(gplanehdc1(isp).eq.57)then !4/6 planes fire
+ pindex=27
+ else if(gplanehdc1(isp).eq.58)then !4/6 planes fire
+ pindex=28
+ else if(gplanehdc1(isp).eq.60)then !4/6 planes fire
+ pindex=29
+ else
+ pindex=-1 !multiple missing planes or other problem
+ end if
+
+ else !must be hdc2
+
+ if(gplanehdc2(isp).eq.63)then
+ pindex=14 !first 6 bits set, so 6 planes hit
+ else if(gplanehdc2(isp).eq.62)then
+ pindex=7 !missing lowest order bit, missing x1
+ else if(gplanehdc2(isp).eq.61)then
+ pindex=8
+ else if(gplanehdc2(isp).eq.59)then
+ pindex=9
+ else if(gplanehdc2(isp).eq.55)then
+ pindex=10
+ else if(gplanehdc2(isp).eq.47)then
+ pindex=11
+ else if(gplanehdc2(isp).eq.31)then
+ pindex=12
+ else if(gplanehdc2(isp).eq.15)then !4/6 planes fire
+ pindex=30
+ else if(gplanehdc2(isp).eq.23)then !4/6 planes fire
+ pindex=31
+ else if(gplanehdc2(isp).eq.27)then !4/6 planes fire
+ pindex=32
+ else if(gplanehdc2(isp).eq.29)then !4/6 planes fire
+ pindex=33
+ else if(gplanehdc2(isp).eq.30)then !4/6 planes fire
+ pindex=34
+ else if(gplanehdc2(isp).eq.39)then !4/6 planes fire
+ pindex=35
+ else if(gplanehdc2(isp).eq.43)then !4/6 planes fire
+ pindex=36
+ else if(gplanehdc2(isp).eq.45)then !4/6 planes fire
+ pindex=37
+ else if(gplanehdc2(isp).eq.46)then !4/6 planes fire
+ pindex=38
+ else if(gplanehdc2(isp).eq.51)then !4/6 planes fire
+ pindex=39
+ else if(gplanehdc2(isp).eq.53)then !4/6 planes fire
+ pindex=40
+ else if(gplanehdc2(isp).eq.54)then !4/6 planes fire
+ pindex=41
+ else if(gplanehdc2(isp).eq.57)then !4/6 planes fire
+ pindex=42
+ else if(gplanehdc2(isp).eq.58)then !4/6 planes fire
+ pindex=43
+ else if(gplanehdc2(isp).eq.60)then !4/6 planes fire
+ pindex=44
+ else
+ pindex=-2 !multiple missing planes or other problem
+ end if
+ endif !end test whether hdc1 or hdc2
+
+* write(6,*) 'h_left_right: check 2: pindex = ',pindex
+
+* check if small angle L/R determination of Y and Y' planes is possible
+ if(isa_y1.gt.0 .AND. isa_y2.gt.0) smallAngOK = .TRUE.
+ if((hSmallAngleApprox.ne.0) .AND. (smallAngOK)) then
+ if(wc(isa_y2).le.wc(isa_y1)) then
+ plusminusknown(isa_y1) = -1
+ plusminusknown(isa_y2) = 1
+ else
+ plusminusknown(isa_y1) = 1
+ plusminusknown(isa_y2) = -1
+ endif
+ if ((numhits-2).lt.0) then
+ write(6,*) 'h_left_right: numhits-2 < 0'
+ elseif ((numhits-2).eq.0) then
+ write(6,*) 'h_left_right: numhits-2 = 0'
+ endif
+ nplusminus = 2**(numhits-2)
+ endif
+* use bit value of integer word to set + or -
+ do pmloop=0,nplusminus-1
+ iswhit = 1
+ do ihit=1,numhits
+ if(plusminusknown(ihit).ne.0) then
+ plusminus(ihit) = float(plusminusknown(ihit))
+ else
+ if(jbit(pmloop,iswhit).eq.1) then
+ plusminus(ihit)=1.0
+ else
+ plusminus(ihit)=-1.0
+ endif
+ iswhit = iswhit + 1
+ endif
+ enddo
+
+ if (pindex.ge.0 .and. pindex.le.14) then
+ call h_find_best_stub(numhits,hits,pl,pindex,plusminus,stub,chi2)
+*jv if(hdebugstubchisq.ne.0) write(hluno,'(''hms pmloop='',i4,
+*jv $ '' chi2='',e14.6)') pmloop,chi2
+ if(hdebugstubchisq.ne.0) write(6,'(''hms pmloop='',i4,
+ $ '' chi2='',e14.6)') pmloop,chi2
+
+* Take best chi2 IF x' of the stub agrees with x' as expected from x.
+* Sometimes an incorrect x' gives a good chi2 for the stub, even though it is
+* not the correct left/right combination for the real track.
+* Rotate x'(=stub(3)) to hut coordinates and compare to x' expected from x.
+* THIS ASSUMES STANDARD HMS TUNE!!!!, for which x' is approx. x/875.
+
+ if (chi2.lt.minchi2) then
+ if ((stub(3)*htanbeta(pl(1))) .eq. -1.) then
+ write(6,*) 'h_left_right: error 3'
+ endif
+ xp_fit=stub(3)-htanbeta(pl(1))/(1.0+stub(3)*htanbeta(pl(1)))
+ xp_expect = hspace_points(isp,1)/875. ! **TUNE DEPENDANT**
+ if (abs(xp_fit-xp_expect).le.hstub_max_xpdiff) then
+ minchi2=chi2
+ do idummy=1,numhits
+ plusminusbest(idummy)=plusminus(idummy)
+ enddo
+ do idummy=1,4
+ hbeststub(isp,idummy)=stub(idummy)
+ enddo
+ else !record best stub failing angle cut, in case none pass.
+ tmpminchi2=chi2
+ do idummy=1,numhits
+ tmppmbest(idummy)=plusminus(idummy)
+ enddo
+ do idummy=1,4
+ tmpbeststub(idummy)=stub(idummy)
+ enddo
+ endif
+ endif ! end if on lower chi2
+ else ! if pindex<0 or >14
+ if (pindex.ge.15.and.pindex.le.44) then ! 4/6 plane tracking
+ call h_find_best_stub(numhits,hits,pl,pindex,plusminus,stub
+ $ ,chi2)
+ if ((stub(3)*htanbeta(pl(1))) .eq. -1.) then
+ write(6,*) 'h_left_right: error 3'
+ endif
+ xp_fit=stub(3)-htanbeta(pl(1))/(1.0+stub(3)*htanbeta(pl(1)))
+ if(abs(xp_fit).le.abs(minxp)) then ! tune dependent
+ minxp=xp_fit
+ minchi2=chi2
+ do icounter=1,numhits
+ plusminusbest(icounter)=plusminus(icounter)
+ hbeststub(isp,icounter)=stub(icounter)
+ enddo
+ endif
+ else
+ write(6,*) 'pindex=',pindex,' in h_left_right','gplanehdc1/2=',gplanehdc1(isp),gplanehdc2(isp)
+ endif ! 4/6 plane tracking
+ endif
+ enddo ! end loop on possible left-right
+*
+* write(6,*) 'h_left_right: ! end loop on possible left-right'
+
+ if (minchi2.ge.9.9e+9) then !no track passed angle cut.
+ minchi2=tmpminchi2
+ do idummy=1,numhits
+ plusminusbest(idummy)=tmppmbest(idummy)
+ enddo
+ do idummy=1,4
+ hbeststub(isp,idummy)=tmpbeststub(idummy)
+ enddo
+ endif
+*
+* calculate final coordinate based on plusminusbest
+*
+ do ihit=1,numhits
+ HDC_WIRE_COORD(hspace_point_hits(isp,ihit+2))=
+ & HDC_WIRE_CENTER(hspace_point_hits(isp,ihit+2)) +
+ & plusminusbest(ihit)*HDC_DRIFT_DIS(hspace_point_hits(isp,ihit
+ $ +2))
+ enddo
+*
+* stubs are calculated in rotated coordinate system
+* use first hit to determine chamber
+ plane=HDC_PLANE_NUM(hits(1))
+ if (hbeststub(isp,3)-htanbeta(plane) .eq. -1.) then
+ write(6,*) 'h_left_right: stub3 error'
+ endif
+ stub(3)=(hbeststub(isp,3) - htanbeta(plane))
+ & /(1.0 + hbeststub(isp,3)*htanbeta(plane))
+
+ if (hbeststub(isp,3)*hsinbeta(plane) .eq. -hcosbeta(plane)) then
+ write(6,*) 'h_left_right: stub4 error'
+ endif
+ stub(4)=hbeststub(isp,4)
+ & /(hbeststub(isp,3)*hsinbeta(plane)+hcosbeta(plane))
+
+ stub(1)=hbeststub(isp,1)*hcosbeta(plane)
+ & - hbeststub(isp,1)*stub(3)*hsinbeta(plane)
+ stub(2)=hbeststub(isp,2)
+ & - hbeststub(isp,1)*stub(4)*hsinbeta(plane)
+ hbeststub(isp,1)=stub(1)
+ hbeststub(isp,2)=stub(2)
+ hbeststub(isp,3)=stub(3)
+ hbeststub(isp,4)=stub(4)
+*
+ enddo ! end loop over space points
+*
+* write out results if debugflagstubs is set
+ if(hdebugflagstubs.ne.0) then
+ call h_print_stubs
+ endif
+ return
+ end
diff --git a/HTRACKING/h_link_stubs.f b/HTRACKING/h_link_stubs.f
new file mode 100644
index 0000000..6fec388
--- /dev/null
+++ b/HTRACKING/h_link_stubs.f
@@ -0,0 +1,271 @@
+ subroutine H_LINK_STUBS(ABORT,err)
+* This subroutine compares all the space-point-stubs found in
+* H_LEFT_RIGHT.f and links together stubs to form tracks.
+* The criterion are that the stubs are in different chambers and
+* each of the four track parameters are within limit:
+* hxt_track_criterion for x_t
+* hyt_track_criterion for y_t
+* htx_track_criterion for t_x
+* hty_track_criterion for t_y
+*
+* d.f. geesaman 17 January 1994
+* $Log: h_link_stubs.f,v $
+* Revision 1.9 2003/04/01 15:21:33 jones
+* minor change
+*
+* Revision 1.8 2003/04/01 13:49:26 jones
+* Modifications to tracking codes.
+* Mainly fix problems at high rates. (M. E. Christy)
+*
+* Revision 1.7 1996/08/30 19:58:15 saw
+* (DVW) Added some track tests
+*
+* Revision 1.6 1996/01/16 22:02:16 cdaq
+* (JRA)
+*
+* Revision 1.5 1995/08/31 14:53:08 cdaq
+* (JRA) Calculate dpos (pos. track - pos. hit) variables
+*
+* Revision 1.4 1995/05/22 19:39:15 cdaq
+* (SAW) Split gen_data_data_structures into gen, hms, sos, and coin parts"
+*
+* Revision 1.3 1995/04/06 19:30:18 cdaq
+* (JRA) Fix typo
+*
+* Revision 1.2 1994/06/06 16:37:57 cdaq
+* Add switch to include single stub tracks
+*
+* Revision 1.1 1994/02/19 06:15:28 cdaq
+* Initial revision
+*
+*
+* The logic is 1) loop over all space points as seeds isp1
+* 2) Check if this space point is all ready in a track
+* 3) loop over all succeeding space pointss isp2
+* 4) check if there is a track-criterion match
+* either add to existing track
+* or if there is another point in same chamber
+* make a copy containing isp2 rather than
+* other point in same chamber
+* 5) If hsingle_stub is set, make a track of all single
+* stubs.
+*
+ implicit none
+ include "hms_data_structures.cmn"
+ include "hms_tracking.cmn"
+ include "hms_id_histid.cmn"
+ INCLUDE 'hms_track_histid.cmn' !TEMP. JUNK
+ include 'hms_bypass_switches.cmn'
+ INCLUDE 'gen_event_info.cmn'
+ external h_chamnum
+ integer*4 h_chamnum
+
+* local variables
+*
+ logical ABORT
+ character*12 here
+ parameter (here='H_LINK_STUBS')
+ character*(*) err
+ integer*4 isp1,isp2,isp ! loop index on space points
+ integer*4 ihit ! loop index on hits
+ integer*4 spindex,spoint,duppoint
+ integer*4 sptracks ! number of tracks with this seed
+ integer*4 stub_tracks(hntracks_max)
+ integer*4 numhits
+ integer*4 itrack ! loop index on tracks
+ integer*4 track
+ integer*4 track_space_points(hntracks_max,hmax_space_points+1)
+ integer*4 tryflag ! flag to loop over rest of points
+ integer*4 newtrack ! make a new track
+ real*4 dposx,dposy,dposxp,dposyp
+ if (hbypass_track_eff_files.eq.0) then
+ open(unit=13,file='scalers/htrackstubs.txt',status='unknown',
+ $ access='append')
+ endif
+ hstubtest = 0
+c
+ if (HNTRACKS_MAX_FP .eq. 0) HNTRACKS_MAX_FP = 10 ! in case not set in param file.
+ if (HNTRACKS_MAX_FP .gt. HNTRACKS_MAX) HNTRACKS_MAX_FP = HNTRACKS_MAX ! in case set too high in param file.
+c
+*
+ ABORT= .FALSE.
+ err=' '
+ hntracks_fp=0
+ if(hsingle_stub.eq.0 ) then
+* loop over all pairs of space points
+ if(hnspace_points_tot.ge.2) then ! return if less than 2 space points
+ do isp1=1,hnspace_points_tot-1 ! loop over all points
+* is this point all ready associated with a track
+ tryflag=1
+ if(hntracks_fp.gt.0) then
+ do itrack=1,hntracks_fp
+ if(track_space_points(itrack,1).gt.0) then
+ do isp2=1,track_space_points(itrack,1)
+ if(track_space_points(itrack,isp2+1).eq.isp1) then
+ tryflag=0 ! space point all ready in a track
+ endif ! end test on found point
+ enddo
+ endif ! end test of >0 point
+ enddo ! end loop over tracks
+ endif
+* if space point not all ready part of a track then look for matches
+ if( tryflag .eq.1) then
+ newtrack=1
+ do isp2=isp1+1,hnspace_points_tot
+* are these stubs in the same chamber. If so then skip
+ if(h_chamnum(isp1).ne.h_chamnum(isp2)) then
+* does this stub match
+
+ dposx = hbeststub(isp2,1)-hbeststub(isp1,1)
+ dposy = hbeststub(isp2,2)-hbeststub(isp1,2)
+ dposxp= hbeststub(isp2,3)-hbeststub(isp1,3)
+ dposyp= hbeststub(isp2,4)-hbeststub(isp1,4)
+
+******************************************************
+ if (abs(dposx).LT.abs(hstubminx)) hstubminx = dposx
+ if (abs(dposy).LT.abs(hstubminy)) hstubminy = dposy
+ if (abs(dposxp).LT.abs(hstubminxp)) hstubminxp = dposxp
+ if (abs(dposyp).LT.abs(hstubminyp)) hstubminyp = dposyp
+ if (hbypass_track_eff_files.eq.0) then
+ if (abs(hstubminx) .gt. hxt_track_criterion) then
+ write(13,*) 'event # ',gen_event_ID_number,
+ $ ' hstubminx = ',hstubminx
+ endif
+ if (abs(hstubminy) .gt. hyt_track_criterion) then
+ write(13,*) 'event # ',gen_event_ID_number,
+ $ ' hstubminy = ',hstubminy
+ endif
+ if (abs(hstubminxp) .gt. hxpt_track_criterion) then
+ write(13,*) 'event # ',gen_event_ID_number,
+ $ ' hstubminxp = ',hstubminxp
+ endif
+ if (abs(hstubminyp) .gt. hypt_track_criterion) then
+ write(13,*) 'event # ',gen_event_ID_number,
+ $ ' hstubminyp = ',hstubminyp
+ endif
+ close(13)
+ endif
+******************************************************
+ if (abs(dposx) .lt. hxt_track_criterion
+ & .and. abs(dposy) .lt. hyt_track_criterion
+ & .and. abs(dposxp).lt. hxpt_track_criterion
+ & .and. abs(dposyp).lt. hypt_track_criterion) then
+ if(newtrack.eq.1) then
+ hstubtest=1
+* make a new track
+ if(hntracks_fp.lt.hntracks_max_fp) then ! are there too many
+ hntracks_fp=hntracks_fp+1 ! increment the number of tracks
+ sptracks=1 ! one track with this seed
+ stub_tracks(1)=hntracks_fp
+ track_space_points(hntracks_fp,1)=2
+ track_space_points(hntracks_fp,2)=isp1
+ track_space_points(hntracks_fp,3)=isp2
+ hx_sp1(hntracks_fp)=hbeststub(isp1,1)
+ hx_sp2(hntracks_fp)=hbeststub(isp2,1)
+ hy_sp1(hntracks_fp)=hbeststub(isp1,2)
+ hy_sp2(hntracks_fp)=hbeststub(isp2,2)
+ hxp_sp1(hntracks_fp)=hbeststub(isp1,3)
+ hxp_sp2(hntracks_fp)=hbeststub(isp2,3)
+ newtrack=0 ! make no more tracks in this loop
+ else !! MEC - added the next 3 lines to
+ hntracks_fp = 0 !! fail events with more than the
+ return !! Max # of allowed tracks.
+ endif ! end test on too many tracks
+ else
+* check if there is another space point in same chamber
+ itrack=0
+ do while (itrack.lt.sptracks)
+ itrack=itrack+1
+ track=stub_tracks(itrack)
+ spoint=0
+ duppoint=0
+ do isp=1,track_space_points(track,1)
+ if(h_chamnum(isp2).eq.
+ & h_chamnum(track_space_points(track,isp+1))) then
+ spoint=isp
+ endif
+ if(isp2.eq.track_space_points(track,isp+1)) then
+ duppoint=1
+ endif
+ enddo ! end loop over sp in tracks with isp1
+* if there is no other space point in this chamber
+* add this space point to current track(2)
+ if(duppoint.eq.0) then
+ if(spoint.eq.0) then
+ spindex=track_space_points(track,1)+1
+ track_space_points(track,1)= spindex
+ track_space_points(track,spindex+1)=isp2
+* if there is another point in the same chamber in this track
+* create a new track with all the same space points except spoint
+ else
+ if(hntracks_fp.lt.hntracks_max_fp) then ! are there too many
+ hntracks_fp=hntracks_fp+1 ! increment the number of tracks
+ sptracks= sptracks+1 ! one track with this seed
+ stub_tracks(sptracks) = hntracks_fp
+ track_space_points(hntracks_fp,1)
+ $ =track_space_points(track,1)
+ do isp=1,track_space_points(track,1)
+ if(isp.ne.spoint) then
+ track_space_points(hntracks_fp,isp+1)=
+ & track_space_points(track,isp+1)
+ elseif(isp.eq.spoint) then
+ track_space_points(hntracks_fp,isp+1)= isp2
+ endif ! end check for dup on copy
+ enddo ! end copy of track
+ else !! MEC - added the next 3 lines to
+ hntracks_fp = 0 !! fail events with more than the
+ return !! Max # of allowed tracks.
+ endif ! end if on too many tracks
+ endif ! end if on same chamber
+ endif ! end if on duplicate point
+ enddo ! end do while over tracks with isp1
+ endif
+ endif
+ endif ! end test on same chamber
+ enddo ! end loop over new space points
+ endif ! end test on tryflag
+ enddo ! end outer loop over space points
+ endif ! end if on <2 space points
+ else ! if hsingle_stub .ne. 0
+* when hsingle_stub is set, make each space point a track
+* This will have poor resolution but may be appropriate for debugging
+*
+ do isp1=1,hnspace_points_tot ! loop over all points
+ if(hntracks_fp.lt.hntracks_max_fp) then ! are there too many
+ hntracks_fp=hntracks_fp+1 ! increment the number of tracks
+ track_space_points(hntracks_fp,1)= 1
+ track_space_points(hntracks_fp,2)= isp1
+ else !! MEC - added the next 3 lines to
+ hntracks_fp = 0 !! fail events with more than the
+ return !! Max # of allowed tracks.
+ endif ! end if on too many tracks
+ enddo ! end loop over all space points
+ endif ! end test on hsingle_stub
+* now list all hits on a track
+ if(hntracks_fp.gt.0) then
+ do itrack=1,hntracks_fp ! loop over all tracks
+ hntrack_hits(itrack,1)=0
+ do isp1=1,track_space_points(itrack,1)
+ spindex=track_space_points(itrack,isp1+1)
+ numhits=hspace_point_hits(spindex,1)
+ do ihit=1,numhits
+ if(hntrack_hits(itrack,1).lt.hntrackhits_max) then
+ hntrack_hits(itrack,1)=hntrack_hits(itrack,1)+1
+ hntrack_hits(itrack,hntrack_hits(itrack,1)+1)=
+ & hspace_point_hits(spindex,ihit+2)
+ endif ! end test on too many hits
+ enddo ! end loop over space point hits
+ enddo ! end loop over space points
+ enddo ! end loop over all tracks
+ endif
+ if(hdebuglinkstubs.ne.0) then
+ call h_print_links
+ endif
+ return
+ end
+*********
+* Local Variables:
+* mode: Fortran
+* fortran-if-indent: 1
+* fortran-do-indent: 1
+* End:
diff --git a/HTRACKING/h_pattern_recognition.f b/HTRACKING/h_pattern_recognition.f
new file mode 100644
index 0000000..f057aca
--- /dev/null
+++ b/HTRACKING/h_pattern_recognition.f
@@ -0,0 +1,243 @@
+ subroutine H_PATTERN_RECOGNITION(ABORT,err)
+*--------------------------------------------------------
+*-
+*- Purpose and Methods : Finds HMS Space points
+*-
+*- Required Input BANKS HMS_DECODED_DC
+*-
+*- Output BANKS HMS_FOCAL_PLANE
+*- HMS_DECODED_DC hit coordinates
+*-
+*- Output: ABORT - success or failure
+*- : err - reason for failure, if any
+*-
+*- Created 30-AUG-1993 D. F. Geesaman
+*- Modified 19-JAN-1994 DFG Include standard error form
+* $Log: h_pattern_recognition.f,v $
+* Revision 1.14 2003/04/01 13:49:27 jones
+* Modifications to tracking codes.
+* Mainly fix problems at high rates. (M. E. Christy)
+*
+* Revision 1.13 1996/11/05 21:51:08 saw
+* (JRA) Initialize hdc_sing_drifttime elements to -100
+*
+* Revision 1.12 1996/04/30 12:45:36 saw
+* (JRA) Histogram the card id.
+*
+* Revision 1.11 1996/01/16 21:53:24 cdaq
+* (JRA) Add code for easy space points
+*
+* Revision 1.10 1995/08/31 14:49:32 cdaq
+* (JRA) Fix typo
+*
+* Revision 1.9 1995/05/22 19:39:15 cdaq
+* (SAW) Split gen_data_data_structures into gen, hms, sos, and coin parts"
+*
+* Revision 1.8 1994/10/11 19:01:38 cdaq
+* (DJM) Move hdc_sing_wcoord filling into h_left_right
+*
+* Revision 1.7 1994/09/19 20:31:39 cdaq
+* (DJM) add some histogrammable wire positions and fine positions for each plane
+*
+* Revision 1.6 1994/08/31 19:39:43 cdaq
+* (DJM) Stuff drift time and distance into histogrammable and testable
+* registered variables.
+*
+* Revision 1.5 1994/08/22 19:54:11 cdaq
+* (DJA) Correct sign errors in wire velocity correction
+*
+* Revision 1.4 1994/08/16 13:08:50 cdaq
+* (DJA) Add wire velocity correction
+*
+* Revision 1.3 1994/06/30 02:27:48 cdaq
+* (DFG) Place a limit on total nubmer of hits in each chamber
+* Add filter to get minimum drift time in each plane
+*
+* Revision 1.2 1994/02/21 03:17:53 cdaq
+* (SAW) Removed reference to 3rd chamber in hnspace_points
+*
+* Revision 1.1 1994/02/19 06:15:47 cdaq
+* Initial revision
+*
+*-
+*
+* This routine finds the space points in each chamber using wire center
+* locations.
+*
+*--------------------------------------------------------
+ IMPLICIT NONE
+ SAVE
+*
+ character*21 here
+ parameter (here= 'H_PATTERN_RECOGNITION')
+*
+ logical ABORT
+ character*(*) err
+*
+ INCLUDE 'hms_data_structures.cmn'
+ INCLUDE 'gen_constants.par'
+ INCLUDE 'gen_units.par'
+ INCLUDE 'hms_tracking.cmn'
+ INCLUDE 'hms_geometry.cmn'
+*
+* local variables
+ integer*4 hit_number(hmax_chamber_hits)
+ integer*4 space_point_hits(hmax_space_points,hmax_hits_per_point+2)
+ integer*4 pln, isp, ihit, hit
+ integer*4 i,j,k,yy,yyprime
+ integer*4 yplane,yprimeplane
+ integer*4 ich, ip
+ logical easy_space_point
+*
+ real*4 space_points(hmax_space_points,2)
+ real*4 xdist,ydist
+ real*4 time_corr
+ real*4 h_drift_dist_calc
+ external h_drift_dist_calc
+
+*
+* temporary initialization
+ ABORT= .FALSE.
+ err=' '
+*
+*
+ do pln=1,12
+ hdc_sing_drifttime(pln)=-100
+ enddo
+
+ ihit = 0
+ hnspace_points_tot = 0
+ do ich=1,hdc_num_chambers
+ easy_space_point = .false.
+ hnspace_points(ich)=0
+ hncham_hits(ich)=0
+
+ do i = 1,hmax_space_points !! Initialize - MEC !!
+ space_points(i,1) = 0
+ space_points(i,2) = 0
+ enddo
+
+*
+* For this loop to work, hdc_planes_per_chamber must be
+* the number of planes per chamber. (And all chambers must have the
+* same number of planes.)
+*
+ do ip=(ich-1)*hdc_planes_per_chamber+1,ich*hdc_planes_per_chamber
+ hncham_hits(ich)=hncham_hits(ich)+hdc_hits_per_plane(ip)
+ enddo
+ yplane=2+(ich-1)*hdc_planes_per_chamber
+ yprimeplane=5+(ich-1)*hdc_planes_per_chamber
+ if(hncham_hits(ich).ge.hmin_hit(ich) .and.
+ $ hncham_hits(ich).lt.hmax_pr_hits(ich)) then
+ do i=ihit+1,ihit+hncham_hits(ich)
+ hit_number(i)=i
+ if(hdc_plane_num(i).eq.yplane) yy=i
+ if(hdc_plane_num(i).eq.yprimeplane) yyprime=i
+ enddo
+ if((hdc_hits_per_plane(yplane).eq.1) .and.
+ & (hdc_hits_per_plane(yprimeplane).eq.1).and.
+ & ((hdc_wire_center(yy)-hdc_wire_center(yyprime))**2.lt.
+ & (hspace_point_criterion(ich))) .and.
+ & (hncham_hits(ich).le.6)) then
+ call h_find_easy_space_point(hncham_hits(ich),hit_number(ihit+1),
+ & hdc_wire_center(ihit+1),hdc_plane_num(ihit+1),
+ & hspace_point_criterion(ich),hmax_space_points,yy-ihit,
+ & yyprime-ihit,easy_space_point,hnspace_points(ich),
+ & space_points,space_point_hits)
+ if (.not.easy_space_point) call find_space_points(hncham_hits(ich)
+ $ ,hit_number(ihit+1),hdc_wire_center(ihit+1)
+ $ ,hdc_plane_num(ihit+1),hspace_point_criterion(ich),hxsp(1)
+ $ ,hysp(1),hmax_space_points,hnspace_points(ich), space_points,
+ $ space_point_hits)
+ else
+ call find_space_points(hncham_hits(ich),hit_number(ihit+1),
+ & hdc_wire_center(ihit+1),
+ & hdc_plane_num(ihit+1),hspace_point_criterion(ich),
+ & hxsp(1),hysp(1),hmax_space_points,
+ & hnspace_points(ich), space_points, space_point_hits)
+ endif
+*
+ if (hnspace_points(ich).gt.0) then
+* If two hits in same plane, choose one with minimum drift time
+
+ if ( h_remove_sppt_if_one_y_plane .eq. 1) then
+ call h_sp_destroy(ABORT,err,hnspace_points(ich),
+ & space_point_hits,space_points,ich)
+ endif
+c
+ call h_sp_multiwire(ABORT,err,hnspace_points(ich),
+ & space_point_hits,space_points)
+c
+ call h_choose_single_hit(ABORT,err,hnspace_points(ich),
+ & space_point_hits)
+* Select on minimum number of combinations and hits
+ call select_space_points(hmax_space_points,hnspace_points(ich),
+ & space_points,space_point_hits,hmin_hit(ich),hmin_combos(ich),
+ $ easy_space_point)
+ endif
+
+
+ do i=1,hnspace_points(ich)
+ k=hnspace_points_tot+i
+ hspace_points(k,1)=space_points(i,1)
+ hspace_points(k,2)=space_points(i,2)
+ hspace_point_hits(k,1)=space_point_hits(i,1)
+ hspace_point_hits(k,2)=space_point_hits(i,2)
+ do j=1,space_point_hits(i,1)
+ hspace_point_hits(k,j+2)=space_point_hits(i,j+2)
+ enddo
+ enddo
+ endif
+ hnspace_points_tot = hnspace_points_tot+ hnspace_points(ich)
+ ihit = ihit + hncham_hits(ich)
+ enddo
+*
+* Now we know rough hit positions in the chambers so we can make
+* wire velocity drift time corrections for each hit in the space point
+*
+* Assume all wires for a plane are read out on the same side (l/r or t/b).
+* If the wire is closer to horizontal, read out left/right. If nearer
+* vertical, assume top/bottom. (Note, this is not always true for the
+* SOS u and v planes. They have 1 card each on the side, but the overall
+* time offset per card will cancel much of the error caused by this. The
+* alternative is to check by card, rather than by plane and this is harder.
+*
+ if(hnspace_points_tot.gt.0) then
+ do isp=1,hnspace_points_tot
+ xdist = hspace_points(isp,1)
+ ydist = hspace_points(isp,2)
+ do ihit=1,hspace_point_hits(isp,1)
+ hit = hspace_point_hits(isp,ihit+2)
+ pln = hdc_plane_num(hit)
+ if (hdc_readout_x(pln)) then !readout from side
+ time_corr = ydist*hdc_readout_corr(pln)/hdc_wire_velocity
+ else !readout from top/bottom
+ time_corr = xdist*hdc_readout_corr(pln)/hdc_wire_velocity
+ endif
+
+ hdc_drift_time(hit)=hdc_drift_time(hit) - hdc_central_time(pln)
+ & + hdc_drifttime_sign(pln)*time_corr
+ hdc_drift_dis(hit) = h_drift_dist_calc
+ & (pln,hdc_wire_num(hit),hdc_drift_time(hit))
+*
+* djm 8/25/94
+* Stuff drift time and distance into registered variables for histogramming and tests.
+* In the case of two separated hits per plane, the last one will be histogrammed.
+ hdc_sing_drifttime(pln) = hdc_drift_time(hit)
+ hdc_sing_driftdis(pln) = hdc_drift_dis(hit)
+ hdc_sing_cardid(pln) =
+ & hdc_card_no(hdc_wire_num(hit),hdc_plane_num(hit))
+ enddo
+ enddo
+ endif
+*
+* Histogram hdc_DECODED_DC
+ call h_fill_dc_dec_hist(ABORT,err)
+
+* write out results if debugflagpr is set
+ if(hdebugflagpr.ne.0) then
+ call h_print_pr
+ endif
+*
+ return
+ end
diff --git a/HTRACKING/h_physics.f b/HTRACKING/h_physics.f
new file mode 100644
index 0000000..239b309
--- /dev/null
+++ b/HTRACKING/h_physics.f
@@ -0,0 +1,526 @@
+ SUBROUTINE H_PHYSICS(ABORT,err)
+*--------------------------------------------------------
+*-
+*- Purpose and Methods : Do final HMS physics analysis on HMS only part of
+*- event.
+*-
+*- to decoded information
+*-
+*- Required Input BANKS HMS_FOCAL_PLANE
+*- HMS_TARGET
+*- HMS_TRACK_TESTS
+*-
+*- Output BANKS HMS_PHYSICS_R4
+*- HMS_PHYSICS_I4
+*-
+*- Output: ABORT - success or failure
+*- : err - reason for failure, if any
+*-
+*- Created 19-JAN-1994 D. F. Geesaman
+*- Dummy Shell routine
+*
+* $Log: h_physics.f,v $
+* Revision 1.23.20.2.2.2 2009/06/05 17:59:29 jones
+* Add horizontal raster correction to hszbeam calculation.
+* Remove energy loss hsenergy calculation.
+*
+* Revision 1.23.20.2.2.1 2008/11/17 01:17:55 cdaq
+* *** empty log message ***
+*
+* Revision 1.23.20.2 2007/11/06 19:14:42 cdaq
+* fix zbeam calculation
+*
+* Revision 1.23.20.1 2007/10/25 00:06:54 cdaq
+* *** empty log message ***
+*
+* Revision 1.23 2003/11/28 14:57:03 jones
+* Added variable hsxp_tar_temp = hsxp_tar + h_oopcentral_offset (MKJ)
+*
+* Revision 1.22 2003/09/05 18:20:30 jones
+* Merge in online03 changes (mkj)
+*
+* Revision 1.21.2.3 2003/09/04 21:30:12 jones
+* Add h_oopcentraloffset (mkj)
+*
+* Revision 1.21.2.2 2003/07/15 19:04:52 cdaq
+* add calculation of hsinplane
+*
+* Revision 1.21.2.1 2003/04/10 12:39:03 cdaq
+* add e_nonzero and modify p_nonzero. These are used in calculating E_cal/p and beta.
+*
+* Revision 1.21 2002/12/27 22:07:04 jones
+* a. Ioana Niculescu modified total_eloss call
+* b. CSA 4/15/99 -- changed hsbeta to hsbeta_p in total_eloss call
+* to yield reasonable calculation for hsbeta=0 events.
+* c. CSA 4/12/99 -- changed hscorre/p back to hsenergy and hsp so
+* I could keep those names in c_physics.f
+*
+* Revision 1.20 2002/10/02 13:42:43 saw
+* Check that user hists are defined before filling
+*
+* Revision 1.19 1999/02/10 17:45:41 csa
+* Cleanup and bugfixes (mostly G. Warren)
+*
+* Revision 1.18 1996/08/30 19:59:36 saw
+* (JRA) Improved track length calculation. Photon E calc. for (gamma,p)
+*
+* Revision 1.17 1996/04/30 12:46:06 saw
+* (JRA) Add pathlength and rf calculations
+*
+* Revision 1.16 1996/01/24 15:58:38 saw
+* (JRA) Change cpbeam/cebeam to gpbeam/gebeam
+*
+* Revision 1.15 1996/01/16 21:55:02 cdaq
+* (JRA) Calculate q, W for electrons
+*
+* Revision 1.14 1995/10/09 20:22:15 cdaq
+* (JRA) Add call to h_dump_cal, change upper to lower case
+*
+* Revision 1.13 1995/08/31 14:49:03 cdaq
+* (JRA) Add projection to cerenkov mirror pos, fill hdc_sing_res array
+*
+* Revision 1.12 1995/07/19 20:53:26 cdaq
+* (SAW) Declare sind and tand for f2c compatibility
+*
+* Revision 1.11 1995/05/22 19:39:15 cdaq
+* (SAW) Split gen_data_data_structures into gen, hms, sos, and coin parts"
+*
+* Revision 1.10 1995/05/11 17:15:07 cdaq
+* (SAW) Add additional kinematics variables
+*
+* Revision 1.9 1995/03/22 16:23:27 cdaq
+* (SAW) Target track data is now slopes.
+*
+* Revision 1.8 1995/02/23 13:37:31 cdaq
+* (SAW) Reformat and cleanup
+*
+* Revision 1.7 1995/02/10 18:44:47 cdaq
+* (SAW) _tar values are now angles instead of slopes
+*
+* Revision 1.6 1995/02/02 13:05:40 cdaq
+* (SAW) Moved best track selection code into H_SELECT_BEST_TRACK (new)
+*
+* Revision 1.5 1995/01/27 20:24:14 cdaq
+* (JRA) Add some useful physics quantities
+*
+* Revision 1.4 1995/01/18 16:29:26 cdaq
+* (SAW) Correct some trig and check for negative arg in elastic kin calculation
+*
+* Revision 1.3 1994/09/13 19:51:03 cdaq
+* (JRA) Add HBETA_CHISQ
+*
+* Revision 1.2 1994/06/14 03:49:49 cdaq
+* (DFG) Calculate physics quantities
+*
+* Revision 1.1 1994/02/19 06:16:08 cdaq
+* Initial revision
+*
+*-
+*-
+*--------------------------------------------------------
+ IMPLICIT NONE
+ SAVE
+*
+ character*9 here
+ parameter (here= 'H_PHYSICS')
+*
+ logical ABORT
+ character*(*) err
+ integer ierr
+*
+ include 'gen_data_structures.cmn'
+ INCLUDE 'hms_data_structures.cmn'
+ INCLUDE 'gen_routines.dec'
+ INCLUDE 'gen_constants.par'
+ INCLUDE 'gen_units.par'
+ INCLUDE 'hms_physics_sing.cmn'
+ INCLUDE 'hms_calorimeter.cmn'
+ INCLUDE 'hms_scin_parms.cmn'
+ INCLUDE 'hms_tracking.cmn'
+ INCLUDE 'hms_cer_parms.cmn'
+ INCLUDE 'hms_geometry.cmn'
+ INCLUDE 'hms_id_histid.cmn'
+ INCLUDE 'hms_track_histid.cmn'
+ include 'gen_event_info.cmn'
+ include 'hms_scin_tof.cmn'
+
+* local variables
+
+ integer*4 i,ip,ihit
+ integer*4 itrkfp
+ real*4 coshstheta,sinhstheta
+ real*4 p_nonzero,e_nonzero
+ real*4 xdist,ydist,dist(12),res(12)
+ real*4 tmp,W2
+ real*4 hsp_z
+ real*4 Wvec(4)
+ real*4 hstheta_1st
+ real*4 scalar,mink
+ real*4 hsxp_tar_temp
+*
+*--------------------------------------------------------
+*
+ ierr=0
+
+ if (hsnum_fptrack.le.0) return ! No Good track
+
+ itrkfp=hsnum_fptrack
+
+* Copy variables for ntuple so we can test on them
+
+ hsdelta = hdelta_tar(hsnum_tartrack)
+ hsx_tar = hx_tar(hsnum_tartrack)
+ hsy_tar = hy_tar(hsnum_tartrack)
+ hsxp_tar = hxp_tar(hsnum_tartrack) ! This is an angle (radians)
+ hsxp_tar_temp = hsxp_tar + h_oopcentral_offset
+ hsyp_tar = hyp_tar(hsnum_tartrack) ! This is an angle (radians)
+ hsbeta = hbeta(itrkfp)
+ hsbeta_chisq = hbeta_chisq(itrkfp)
+ hstime_at_fp = htime_at_fp(itrkfp)
+
+ hsx_fp = hx_fp(itrkfp)
+ hsy_fp = hy_fp(itrkfp)
+ hsxp_fp = hxp_fp(itrkfp) ! This is a slope (dx/dz)
+ hsyp_fp = hyp_fp(itrkfp) ! This is a slope (dy/dz)
+
+* Correct delta (this must be called AFTER filling
+* focal plane quantites).
+
+ call h_satcorr(ABORT,err)
+ hsp = hpcentral*(1.0 + hsdelta/100.) !Momentum in GeV
+ hsenergy = sqrt(hsp*hsp+hpartmass*hpartmass)
+
+ hstrack_et = htrack_et(itrkfp)
+ hstrack_preshower_e = htrack_preshower_e(itrkfp)
+ p_nonzero = hsp !reconstructed momentum with 'reasonable' limits.
+ !Used to calc. E_cal/p and beta.
+ p_nonzero = max(0.8*hpcentral,p_nonzero)
+ p_nonzero = min(1.2*hpcentral,p_nonzero)
+ e_nonzero = sqrt(p_nonzero**2+hpartmass**2)
+
+ hscal_suma = hcal_e1/p_nonzero !normalized cal. plane sums
+ hscal_sumb = hcal_e2/p_nonzero
+ hscal_sumc = hcal_e3/p_nonzero
+ hscal_sumd = hcal_e4/p_nonzero
+ hsprsum = hscal_suma
+ hsshsum = hcal_et/p_nonzero
+ hsprtrk = hstrack_preshower_e/p_nonzero
+ hsshtrk = hstrack_et/p_nonzero
+
+ hsx_sp1 = hx_sp1(itrkfp)
+ hsy_sp1 = hy_sp1(itrkfp)
+ hsxp_sp1 = hxp_sp1(itrkfp)
+ hsx_sp2 = hx_sp2(itrkfp)
+ hsy_sp2 = hy_sp2(itrkfp)
+ hsxp_sp2 = hxp_sp2(itrkfp)
+
+ if(hidscintimes.gt.0) then
+ do ihit=1,hnum_scin_hit(itrkfp)
+ call hf1(hidscintimes,hscin_fptime(itrkfp,ihit),1.)
+ enddo
+ endif
+
+ if(hidcuttdc.gt.0) then
+ do ihit=1,hntrack_hits(itrkfp,1)
+ call hf1(hidcuttdc,
+ & float(hdc_tdc(hntrack_hits(itrkfp,ihit+1))),1.)
+ enddo
+ endif
+
+ hsx_dc1 = hsx_fp + hsxp_fp * hdc_1_zpos
+ hsy_dc1 = hsy_fp + hsyp_fp * hdc_1_zpos
+ hsx_dc2 = hsx_fp + hsxp_fp * hdc_2_zpos
+ hsy_dc2 = hsy_fp + hsyp_fp * hdc_2_zpos
+ hsx_s1 = hsx_fp + hsxp_fp * hscin_1x_zpos
+ hsy_s1 = hsy_fp + hsyp_fp * hscin_1x_zpos
+ hsx_cer = hsx_fp + hsxp_fp * hcer_mirror_zpos
+ hsy_cer = hsy_fp + hsyp_fp * hcer_mirror_zpos
+ hsx_s2 = hsx_fp + hsxp_fp * hscin_2x_zpos
+ hsy_s2 = hsy_fp + hsyp_fp * hscin_2x_zpos
+ hsx_cal = hsx_fp + hsxp_fp * hcal_1pr_zpos
+ hsy_cal = hsy_fp + hsyp_fp * hcal_1pr_zpos
+
+c Used to use hsp, replace with p_nonzero, to give reasonable limits
+C (+/-20%) to avoid unreasonable hsbeta_p values
+c hsbeta_p = hsp/max(hsenergy,.00001)
+
+ hsbeta_p = p_nonzero/e_nonzero
+
+
+C old 'fit' value for pathlen correction
+C hspathlength = -1.47e-2*hsx_fp + 11.6*hsxp_fp - 36*hsxp_fp**2
+C new 'modeled' value.
+
+ hspathlength = 12.462*hsxp_fp + 0.1138*hsxp_fp*hsx_fp
+ & -0.0154*hsx_fp - 72.292*hsxp_fp**2
+ & -0.0000544*hsx_fp**2 - 116.52*hsyp_fp**2
+
+ hspath_cor = hspathlength/hsbeta_p -
+ & hpathlength_central/speed_of_light*(1/max(.01,hsbeta_p) - 1)
+
+ hsrftime = hmisc_dec_data(49,1)/9.46
+ & - (hstime_at_fp-hstart_time_center) - hspath_cor
+
+ do ip = 1,4
+ hsscin_elem_hit(ip) = 0
+ enddo
+
+ do i = 1,hnum_scin_hit(itrkfp)
+ ip = hscin_plane_num(hscin_hit(itrkfp,i))
+ if (hsscin_elem_hit(ip).eq.0) then
+ hsscin_elem_hit(ip) = hscin_counter_num(hscin_hit(itrkfp,i))
+ hsdedx(ip) = hdedx(itrkfp,i)
+ else ! more than 1 hit in plane
+ hsscin_elem_hit(ip) = 18
+ hsdedx(ip) = sqrt(hsdedx(ip)*hdedx(itrkfp,i))
+ endif
+ enddo
+
+ hsnum_scin_hit = hnum_scin_hit(itrkfp)
+ hsnum_pmt_hit = hnum_pmt_hit(itrkfp)
+
+ hschi2perdeg = hchi2_fp(itrkfp) / float(hnfree_fp(itrkfp))
+ hsnfree_fp = hnfree_fp(itrkfp)
+
+ do ip = 1, hdc_num_planes
+ hdc_sing_res(ip) = hdc_single_residual(itrkfp,ip)
+ hsdc_track_coord(ip) = hdc_track_coord(itrkfp,ip)
+ enddo
+
+ if (hntrack_hits(itrkfp,1).eq.12 .and. hschi2perdeg.le.4) then
+ xdist = hsx_dc1
+ ydist = hsy_dc1
+ do ip = 1,12
+ if (hdc_readout_x(ip)) then
+ dist(ip) = ydist*hdc_readout_corr(ip)
+ else !readout from top/bottom
+ dist(ip) = xdist*hdc_readout_corr(ip)
+ endif
+ res(ip) = hdc_sing_res(ip)
+ tmp = hdc_plane_wirecoord(itrkfp,ip)
+ $ - hdc_plane_wirecenter(itrkfp,ip)
+ if (tmp.eq.0) then !drift dist = 0
+ res(ip) = abs(res(ip))
+ else
+ res(ip) = res(ip) * (abs(tmp)/tmp) !convert +/- res to near/far res
+ endif
+ enddo
+c write(37,'(12f7.2,12f8.3,12f8.5)') (hsdc_track_coord(ip),ip=1,12),
+c & (dist(ip),ip=1,12),(res(ip),ip=1,12)
+ endif
+
+* Do energy loss, which is particle specific
+
+ hstheta_1st = htheta_lab*TT/180. - atan(hsyp_tar) ! rough scat
+ ! angle
+ hsinplane = htheta_lab*TT/180. - atan(hsyp_tar) ! rough scat angle
+
+ if (hpartmass .lt. 2.*mass_electron) then ! for electron
+ if (gtarg_z(gtarg_num).gt.0.) then
+ call total_eloss(1,.true.,hstheta_1st,1.0,hseloss)
+ else
+ hseloss=0.
+ endif
+ else ! not an electron
+ if (gtarg_z(gtarg_num).gt.0.) then
+ call total_eloss(1,.false.,hstheta_1st,hsbeta_p,hseloss)
+ else
+ hseloss=0.
+ endif
+ endif ! particle specific stuff
+
+* Correct hsenergy and hsp for eloss at the target
+* csa 4/12/99 -- changed hscorre/p back to hsenergy and hsp so
+* I could keep those names in c_physics.f
+
+c hsenergy = hsenergy + hseloss ! for SANE decide not to correct for energy loss
+ hsp = sqrt(hsenergy**2-hpartmass**2)
+
+* Begin Kinematic stuff
+
+* coordinate system :
+* z points downstream along beam
+* x points downward
+* y points toward beam left (away from HMS)
+*
+* This coordinate system is a just a simple rotation away from the
+* TRANSPORT coordinate system used in the spectrometers
+
+ hsp_z = hsp/sqrt(1.+hsxp_tar_temp**2+hsyp_tar**2)
+
+* Initial Electron
+
+ hs_kvec(1) = gebeam ! after energy loss in target
+ hs_kvec(2) = 0
+ hs_kvec(3) = 0
+ hs_kvec(4) = gebeam
+
+* Scattered Particle calculation without small angle approximation
+* - gaw 98/10/5
+
+ hs_kpvec(1) = hsenergy
+ hs_kpvec(2) = hsp_z*hsxp_tar_temp
+ hs_kpvec(3) = hsp_z*(hsyp_tar*coshthetas-sinhthetas)
+ hs_kpvec(4) = hsp_z*(hsyp_tar*sinhthetas+coshthetas)
+
+* Angles for Scattered particle. Theta and phi are conventional
+* polar/azimuthal angles defined w.r.t. coordinate system defined
+* above. In rad, of course. Note that phi is around -pi/2 for HMS,
+* +pi/2 for SOS.
+
+ if (abs(hs_kpvec(4)/hsp).le.1.) then
+ hstheta = acos(hs_kpvec(4)/hsp)
+ else
+ hstheta = -10.
+ endif
+ hsphi = atan2(hs_kpvec(3),hs_kpvec(2))
+c write(*,*)hsphi*57.3, hphi_lab*57.3,htheta_lab
+ sinhstheta = sin(hstheta)
+ coshstheta = cos(hstheta)
+c write(*,*) ' hsphi = ',hsphi,hphi_lab,hs_kpvec(3),hs_kpvec(2)
+
+ hsphi = hphi_lab + hsphi
+
+c if (hsphi .gt. 0.) hsphi = hsphi - tt
+
+* hszbeam is the intersection of the beam ray with the
+* spectrometer as measured along the z axis.
+
+ hszbeam = (coshthetas*hsy_tar+gsrx_calib/100.)
+ > /tan(htheta_lab*degree-hsyp_tar)+hsy_tar*sinhthetas
+
+* Target particle 4-momentum
+
+ hs_tvec(1) = gtarg_mass(gtarg_num)*m_amu
+ hs_tvec(2) = 0.
+ hs_tvec(3) = 0.
+ hs_tvec(4) = 0.
+
+* Initialize the electron-specific variables
+
+ do i=1,4
+ hs_qvec(i) = -1000.
+ Wvec(i) = -1000.
+ enddo
+
+ hsq3 = -1000.
+ hsbigq2 = -1000.
+ W2 = -1000.
+ hinvmass = -1000.
+
+* Calculate quantities that are meaningful only if
+* the particle in the HMS is an electron.
+
+ if (hpartmass .lt. 2.*mass_electron) then
+
+ do i=1,4
+ hs_qvec(i) = hs_kvec(i) - hs_kpvec(i)
+ Wvec(i) = hs_qvec(i) + hs_tvec(i) ! Q+P 4 vector
+ enddo
+
+* Magnitudes
+
+ hsq3 = sqrt(scalar(hs_qvec,hs_qvec))
+ hsbigq2 = -mink(hs_qvec,hs_qvec)
+ W2 = mink(Wvec,Wvec)
+ if(W2.ge.0 ) then
+ hinvmass = SQRT(W2)
+ else
+ hinvmass = 0.
+ endif
+
+* Calculate elastic scattering kinematical correction
+
+* t1 = 2.*hphysicsa*gpbeam*coshstheta
+* ta = 4.*gpbeam**2*coshstheta**2 - hphysicsb**2
+
+* SAW 1/17/95. Add the stuff after the or.
+
+* if(ta.eq.0.0 .or. ( hphysicab2 + hphysicsm3b * ta).lt.0.0) then
+* p3=0.
+* else
+* t3 = ta-hphysicsb**2
+* p3 = (T1 - sqrt( hphysicab2 + hphysicsm3b * ta)) / ta
+* endif
+
+* This is the difference in the momentum obtained by tracking
+* and the momentum from elastic kinematics
+
+* hselas_cor = hsp - P3
+
+ endif
+
+C-----------------------------------------------------------------------
+ if (.false.) then
+* if (.true.) then
+ write(6,*)' ***********************************'
+ write(6,*)' h_phys: htheta_lab, hphi_lab =',htheta_lab,hphi_lab
+ write(6,*)' h_phys: hsdelta =',hsdelta
+ write(6,*)' h_phys: hsx_tar, hsy_tar =',hsx_tar,hsy_tar
+ write(6,*)' h_phys: hsxp_tar, hsyp_tar =',hsxp_tar,hsyp_tar
+ write(6,*)' h_phys: hsbeta, hsbeta_p =',hsbeta,hsbeta_p
+ write(6,*)' h_phys: hsenergy, hsp =',hsenergy,hsp
+ write(6,*)' h_phys: hseloss =',hseloss
+* write(6,*)' h_phys: hscorre, hscorrp =',hscorre,hscorrp
+ write(6,*)' h_phys: hstheta_1st =',hstheta_1st
+ write(6,*)' h_phys: hsp_z =',hsp_z
+ write(6,*)' h_phys: hs_kvec =',hs_kvec
+ write(6,*)' h_phys: cos/sinhthetas =',coshthetas,sinhthetas
+ write(6,*)' h_phys: hs_kpvec =',hs_kpvec
+ write(6,*)' h_phys: hs_tvec =',hs_tvec
+ write(6,*)' h_phys: hs_qvec =',hs_qvec
+ write(6,*)' h_phys: Wvec =',Wvec
+ write(6,*)' h_phys: hsq3 =',hsq3
+ write(6,*)' h_phys: hsbigq2, W2 =',hsbigq2,W2
+ write(6,*)' h_phys: hstheta, hsphi =',hstheta,hsphi
+ endif
+
+* Write raw timing information for fitting.
+
+ if(hdebugdumptof.ne.0) call h_dump_tof
+ if(hdebugdumpcal.ne.0) call h_dump_cal
+
+* Calculate physics statistics and wire chamber efficencies.
+
+ call h_physics_stat(ABORT,err)
+ ABORT= ierr.ne.0 .or. ABORT
+ IF(ABORT) THEN
+ call G_add_path(here,err)
+ ENDIF
+
+ return
+ end
+
+***************************************************
+
+ real*4 function scalar(vec1,vec2)
+
+* scalar product of vec1 and vec2
+
+ real*4 vec1(4)
+ real*4 vec2(4)
+ integer*4 i
+
+ scalar = 0
+
+ do i=2,4
+ scalar=vec1(i)*vec2(i)+scalar
+ enddo
+
+ return
+ end
+
+***************************************************
+
+ real*4 function mink(vec1,vec2)
+
+* Minkowski product
+
+ implicit none
+
+ real*4 vec1(4),vec2(4)
+ real scalar
+
+ mink=vec1(1)*vec2(1)-scalar(vec1,vec2)
+ return
+ end
diff --git a/HTRACKING/h_physics_stat.f b/HTRACKING/h_physics_stat.f
new file mode 100644
index 0000000..ca3fa37
--- /dev/null
+++ b/HTRACKING/h_physics_stat.f
@@ -0,0 +1,108 @@
+ subroutine h_physics_stat(ABORT,err)
+*--------------------------------------------------------
+*-
+*- Purpose and Methods : Calculate statistics and chamber efficencies for
+*- HMS physics analysis on HMS only part of
+*- event.
+*-
+*-
+*- Required Input BANKS HMS_DECODED_DC
+*- HMS_FOCAL_PLANE
+*-
+*- Output BANKS CTP PARAMETERS
+*-
+*- Output: ABORT - success or failure
+*- : err - reason for failure, if any
+*-
+*- Created 10-JUN-1994 D. F. Geesaman
+* $Log: h_physics_stat.f,v $
+* Revision 1.6 1995/10/10 16:50:08 cdaq
+* (JRA) Comment out some redundant efficiency calculations
+*
+* Revision 1.5 1995/08/31 14:47:09 cdaq
+* (JRA) Add calls to h_dc_eff and h_cer_eff
+*
+* Revision 1.4 1995/05/22 19:39:16 cdaq
+* (SAW) Split gen_data_data_structures into gen, hms, sos, and coin parts"
+*
+* Revision 1.3 1995/02/23 15:37:57 cdaq
+* (JRA) Move scint eff's to h_scin_eff, add call to h_cal_eff
+*
+* Revision 1.2 1994/06/15 20:22:49 cdaq
+* (DFG) Add scin plane efficiency
+*
+* Revision 1.1 1994/06/15 19:09:37 cdaq
+* Initial revision
+*-
+*--------------------------------------------------------
+ IMPLICIT NONE
+ SAVE
+*
+ character*14 here
+ parameter (here= 'h_physics_stat')
+*
+ logical ABORT
+ character*(*) err
+*
+ INCLUDE 'hms_data_structures.cmn'
+ INCLUDE 'gen_routines.dec'
+ INCLUDE 'gen_constants.par'
+ INCLUDE 'gen_units.par'
+ INCLUDE 'hms_geometry.cmn'
+ INCLUDE 'hms_physics_sing.cmn'
+ INCLUDE 'hms_statistics.cmn'
+ INCLUDE 'hms_bypass_switches.cmn'
+*
+* local variables
+c integer*4 goodtrack,tothits,ihit,hitnum,plane
+c real*4 normsigma
+c real*8 ray(4) ! xt,yt,xpt,ypt
+c EXTERNAL H_DPSIFUN
+c REAL*8 H_DPSIFUN
+*--------------------------------------------------------
+*
+ ABORT= .FALSE.
+ err= ' '
+c* increment numbr of tracks
+c hgoodtracksctr = hgoodtracksctr +1
+c* loop over all hists
+c goodtrack = HSNUM_FPTRACK
+c tothits=HNTRACK_HITS(goodtrack,1)
+c if(tothits.gt.0) then
+c* get ray parameters
+c ray(1) = DBLE(HX_FP(goodtrack))
+c ray(2) = DBLE(HY_FP(goodtrack))
+c ray(3) = DBLE(HXP_FP(goodtrack))
+c ray(4) = DBLE(HYP_FP(goodtrack))
+
+c* loop over all hits in track
+c do ihit = 1, tothits
+c hitnum=HNTRACK_HITS(goodtrack,1+ihit)
+c plane = HDC_PLANE_NUM(hitnum)
+c normsigma = (HDC_WIRE_COORD(hitnum)
+c $ - REAL(H_DPSIFUN(ray,plane)))/hdc_sigma(plane)
+c hplanehitctr(plane) = hplanehitctr(plane) + 1
+c hplanesigmasq(plane) = hplanesigmasq(plane) + normsigma
+c $ *normsigma
+c hmeasuredsigma(plane) = SQRT(hplanesigmasq(plane)
+c & / FLOAT(hplanehitctr(plane)))
+c hchambereff(plane)=FLOAT(hplanehitctr(plane))
+c $ /FLOAT(hgoodtracksctr)
+c enddo ! endloop over hits in track
+c endif ! end test on zero hits
+*
+*
+* Drift chamber efficiencies
+ if (hbypass_dc_eff.eq.0) call h_dc_trk_eff
+*
+* Scintillator efficiencies
+ if (hbypass_scin_eff.eq.0) call h_scin_eff
+*
+* Cerenkov efficiencies
+ if (hbypass_cer_eff.eq.0) call h_cer_eff
+*
+* Calorimeter efficiencies
+ if (hbypass_cal_eff.eq.0) call h_cal_eff
+*
+ RETURN
+ END
diff --git a/HTRACKING/h_print_decoded_dc.f b/HTRACKING/h_print_decoded_dc.f
new file mode 100644
index 0000000..79f3d35
--- /dev/null
+++ b/HTRACKING/h_print_decoded_dc.f
@@ -0,0 +1,60 @@
+ SUBROUTINE h_print_decoded_dc(ABORT,err)
+*--------------------------------------------------------
+*-
+*- Purpose and Methods : Dump HMS_DECODED_DC BANKS
+*-
+*- Required Input BANKS HMS_DECODED_DC
+*-
+*- Output: ABORT - success or failure
+*- : err - reason for failure, if any
+*-
+*- Created 29-FEB-1994 D. F. Geesaman
+* $Log: h_print_decoded_dc.f,v $
+* Revision 1.4 1995/10/10 16:51:54 cdaq
+* (JRA) Remove drift distance from print out
+*
+* Revision 1.3 1995/05/22 19:39:16 cdaq
+* (SAW) Split gen_data_data_structures into gen, hms, sos, and coin parts"
+*
+* Revision 1.2 1995/01/27 19:10:23 cdaq
+* (JRA) Trivial write statement format changes
+*
+* Revision 1.1 1994/03/24 20:15:18 cdaq
+* Initial revision
+*
+*--------------------------------------------------------
+ IMPLICIT NONE
+ SAVE
+*
+ character*50 here
+ parameter (here= 'h_print_decoded_dc')
+*
+ logical ABORT
+ character*(*) err
+*
+ integer*4 j
+ include 'hms_data_structures.cmn'
+ include 'gen_constants.par'
+ include 'gen_units.par'
+ include 'hms_tracking.cmn'
+ include 'hms_geometry.cmn'
+*
+*--------------------------------------------------------
+ ABORT = .FALSE.
+ err = ' '
+ write(hluno,'('' HMS_DECODED_DC BANKS'')')
+ write(hluno,'('' HDC_TOT_HITS='',I4)') HDC_TOT_HITS
+ if(HDC_TOT_HITS.GT.0) then
+ write(hluno,'('' HDC_HITS_PER_PLANE'')')
+ write(hluno,'('' Plane='',18i4)') (j,j=1,hdc_num_planes)
+ write(hluno,'(7x,18i4)')
+ & (HDC_HITS_PER_PLANE(j),j=1,hdc_num_planes)
+ write(hluno,'('' Num Plane Wire Wire Center '',
+ & ''TDC Value RAW DRIFT TIME'')')
+ write(hluno,'(1x,i2,2x,i3,7x,i4,5x,F10.5,i8,2x,F10.5)')
+ & (j,HDC_PLANE_NUM(j),HDC_WIRE_NUM(j),
+ & HDC_WIRE_CENTER(j),HDC_TDC(j),HDC_DRIFT_TIME(j),
+ & j=1,HDC_TOT_HITS)
+ endif
+ RETURN
+ END
diff --git a/HTRACKING/h_print_links.f b/HTRACKING/h_print_links.f
new file mode 100644
index 0000000..02a17bf
--- /dev/null
+++ b/HTRACKING/h_print_links.f
@@ -0,0 +1,27 @@
+ subroutine h_print_links
+* prints the output of link matching
+* d.f. geesaman 7 Sept 1993
+* $Log: h_print_links.f,v $
+* Revision 1.2 1995/05/22 19:39:17 cdaq
+* (SAW) Split gen_data_data_structures into gen, hms, sos, and coin parts"
+*
+* Revision 1.1 1994/02/19 06:16:24 cdaq
+* Initial revision
+*
+*
+ implicit none
+ include "hms_data_structures.cmn"
+ include "hms_tracking.cmn"
+ integer*4 itrack,ihit
+ write(hluno,'('' NUMBER OF TRACKS FROM HMS LINKED STUBS='',i4)')
+ & HNTRACKS_FP
+ if(HNTRACKS_FP.gt.0) then
+ write(hluno,'('' Track HITS'')')
+ do itrack=1,HNTRACKS_FP
+ write(hluno,1000) itrack,(HNTRACK_HITS(itrack,ihit),
+ & ihit=2,HNTRACK_HITS(itrack,1)+1)
+1000 format(2x,i3,2x,24i3)
+ enddo
+ endif
+ return
+ end
diff --git a/HTRACKING/h_print_pr.f b/HTRACKING/h_print_pr.f
new file mode 100644
index 0000000..1df5650
--- /dev/null
+++ b/HTRACKING/h_print_pr.f
@@ -0,0 +1,39 @@
+ subroutine h_print_pr
+* subroutine to dump output of H_PATTERN_RECOGNITION
+* All the results are contained in hms_tracking.inc
+* d.f. geesaman 17 January 1994
+* $Log: h_print_pr.f,v $
+* Revision 1.2 1995/05/22 19:39:17 cdaq
+* (SAW) Split gen_data_data_structures into gen, hms, sos, and coin parts"
+*
+* Revision 1.1 1994/02/19 06:16:41 cdaq
+* Initial revision
+*
+ implicit none
+ include "hms_data_structures.cmn"
+ include "hms_tracking.cmn"
+ include "hms_geometry.cmn"
+* local variables
+ integer*4 i,j
+ write(hluno,'('' HMS PATTERN RECOGNITION RESULTS'')')
+ write(hluno,'('' chamber='',i3,'' number of hits='',i3)')
+ & (i,hncham_hits(i),i=1,hdc_num_chambers)
+ write(hluno,'('' Total number of space points found='',i3)')
+ & hnspace_points_tot
+ write(hluno,'('' chamber number'',i2,'' number of points='',i3)')
+ & (i,hnspace_points(i),i=1,hdc_num_chambers)
+ write(hluno,'('' Space point requirements'')')
+ write(hluno,'('' chamber='',i3,'' min_hit='',i4,'' min_combos='',i3)')
+ & (i,hmin_hit(i),hmin_combos(i),i=1,hdc_num_chambers)
+ if(hnspace_points_tot.ge.1) then
+ write(hluno,'('' point x y number number hits'')')
+ write(hluno,'('' number hits combos'')')
+1001 format(3x,i3,f10.4,f10.4,3x,i3,6x,i3,5x,11i3)
+ do i=1,hnspace_points_tot
+ write(hluno,1001) i, hspace_points(i,1),hspace_points(i,2),
+ & hspace_point_hits(i,1), hspace_point_hits(i,2),
+ & (hspace_point_hits(i,j+2),j=1,hspace_point_hits(i,1))
+ enddo
+ endif
+ return
+ end
diff --git a/HTRACKING/h_print_raw_dc.f b/HTRACKING/h_print_raw_dc.f
new file mode 100644
index 0000000..ab504c7
--- /dev/null
+++ b/HTRACKING/h_print_raw_dc.f
@@ -0,0 +1,48 @@
+ SUBROUTINE h_print_raw_dc(ABORT,err)
+*--------------------------------------------------------
+*-
+*- Purpose and Methods : Dump HMS_RAW_DC BANKS
+*-
+*- Required Input BANKS HMS_RAW_DC
+*-
+*- Output: ABORT - success or failure
+*- : err - reason for failure, if any
+*-
+*- Created 29-FEB-1994 D. F. Geesaman
+* $Log: h_print_raw_dc.f,v $
+* Revision 1.2 1995/05/22 19:39:17 cdaq
+* (SAW) Split gen_data_data_structures into gen, hms, sos, and coin parts"
+*
+* Revision 1.1 1994/03/24 20:15:58 cdaq
+* Initial revision
+*
+*--------------------------------------------------------
+ IMPLICIT NONE
+ SAVE
+*
+ character*50 here
+ parameter (here= 'h_print_raw_dc')
+*
+ logical ABORT
+ character*(*) err
+*
+ integer*4 j
+ include 'hms_data_structures.cmn'
+ include 'gen_constants.par'
+ include 'gen_units.par'
+ include 'hms_tracking.cmn'
+ include 'hms_geometry.cmn'
+*
+*--------------------------------------------------------
+ ABORT = .FALSE.
+ err = ' '
+ write(hluno,'('' HMS_RAW_DC BANKS'')')
+ write(hluno,'('' HDC_RAW_TOT_HITS='',I4)') HDC_RAW_TOT_HITS
+ if(HDC_RAW_TOT_HITS.GT.0) then
+ write(hluno,'('' Num Plane Wire TDC Value'')')
+ write(hluno,'(1x,i2,2x,i3,7x,i4,5x,i10)')
+ & (j,HDC_RAW_PLANE_NUM(j),HDC_RAW_WIRE_NUM(j),
+ & HDC_RAW_TDC(j),j=1,HDC_RAW_TOT_HITS)
+ endif
+ RETURN
+ END
diff --git a/HTRACKING/h_print_stubs.f b/HTRACKING/h_print_stubs.f
new file mode 100644
index 0000000..0655300
--- /dev/null
+++ b/HTRACKING/h_print_stubs.f
@@ -0,0 +1,37 @@
+ subroutine h_print_stubs
+* subroutine to dump output of H_LEFT_RIGHT
+* All the results are contained in hms_tracking.inc
+* d.f. geesaman 17 January 1994
+* $Log: h_print_stubs.f,v $
+* Revision 1.2 1995/05/22 19:39:18 cdaq
+* (SAW) Split gen_data_data_structures into gen, hms, sos, and coin parts"
+*
+* Revision 1.1 1994/02/19 06:16:52 cdaq
+* Initial revision
+*
+ implicit none
+ include "hms_data_structures.cmn"
+ include "hms_tracking.cmn"
+ include "hms_geometry.cmn"
+* local variables
+ integer*4 i,j
+ write(hluno,'('' HMS STUB FIT RESULTS'')')
+ if(hnspace_points_tot.ge.1) then
+ write(hluno,'(''point x_t y_t '',
+ & '' xp_t yp_t'')')
+ write(hluno,'('' [cm] [cm] '',
+ & '' [rad] [rad]'')')
+1001 format(3x,i3,4x,4e15.7)
+ do i=1,hnspace_points_tot
+ write(hluno,1001) i,(hbeststub(i,j),j=1,4)
+ enddo
+ write(hluno,'('' hit HDC_WIRE_CENTER HDC_DRIFT_DIS '',
+ & '' HDC_WIRE_COORD'')')
+ do i=1,HDC_TOT_HITS
+ write(hluno,1002) i,HDC_WIRE_CENTER(i),HDC_DRIFT_DIS(i),
+ & HDC_WIRE_COORD(i)
+1002 format(3x,i3,4x,e16.8,2x,e16.8,2x,e16.8)
+ enddo
+ endif
+ return
+ end
diff --git a/HTRACKING/h_print_tar_tracks.f b/HTRACKING/h_print_tar_tracks.f
new file mode 100644
index 0000000..c40b77d
--- /dev/null
+++ b/HTRACKING/h_print_tar_tracks.f
@@ -0,0 +1,69 @@
+ subroutine h_print_tar_tracks
+*______________________________________________________________________________
+*
+* Facility: CEBAF Hall-C software.
+*
+* Module: h_print_tar_tracks
+*
+* Version: 0.1 (In development) 18-Nov-1993 (DHP)
+*
+* Abstract: Print selected track data in HMS_TARGET common block.
+*
+* Author: David H. Potterveld, Argonne National Lab, Nov. 1993
+* modified: D. F. Geesaman 21 Jan 1994
+* changed name from h_target_dump to h_print_tar_tracks
+* made outpu lun hluno
+* $Log: h_print_tar_tracks.f,v $
+* Revision 1.3 1995/05/22 19:39:18 cdaq
+* (SAW) Split gen_data_data_structures into gen, hms, sos, and coin parts"
+*
+* Revision 1.2 1994/05/12 20:12:56 cdaq
+* (DFG) check for more than 0 tracks
+* (SAW) cosmetic formatting changes to source code
+*
+* Revision 1.1 1994/02/19 06:17:16 cdaq
+* Initial revision
+*
+*______________________________________________________________________________
+
+ implicit none
+
+* Include files.
+
+ include 'hms_data_structures.cmn'
+ include 'hms_tracking.cmn'
+
+* Misc. variables.
+
+ integer*4 itrk
+
+*=============================Executable Code =============================
+ if(hntracks_tar .gt. 0 ) then
+* Write out header.
+ write (hluno,1001) 'HMS TARGET TRACKS'
+ write (hluno,1002)
+
+* Loop over tracks.
+
+ do itrk = 1,hntracks_tar
+
+* Write out data lines.
+
+ write (hluno,1003) itrk,
+ $ hx_tar(itrk),hxp_tar(itrk),
+ $ hy_tar(itrk),hyp_tar(itrk),
+ $ hz_tar(itrk),
+ $ hdelta_tar(itrk),
+ $ hp_tar(itrk)
+ enddo
+ endif
+ return
+
+*============================Format Statements ============================
+
+ 1001 format(a)
+ 1002 format(/,1x,'TRK',t10,'HX_TAR',t20,'HXP_TAR',t30,'HY_TAR',t40
+ $ ,'HYP_TAR',t50,'HZ_TAR',t60,'HDELTA_TAR',t72,'HP_TAR')
+ 1003 format(1x,i2,t8,3(f10.6,f10.5),f10.5)
+
+ end
diff --git a/HTRACKING/h_print_tracks.f b/HTRACKING/h_print_tracks.f
new file mode 100644
index 0000000..e4ad538
--- /dev/null
+++ b/HTRACKING/h_print_tracks.f
@@ -0,0 +1,61 @@
+ subroutine h_print_tracks
+* prints the output of hms track fittinh
+* d.f. geesaman 17 January 1994
+* $Log: h_print_tracks.f,v $
+* Revision 1.3 1995/05/22 19:39:19 cdaq
+* (SAW) Split gen_data_data_structures into gen, hms, sos, and coin parts"
+*
+* Revision 1.2 1994/06/06 16:42:03 cdaq
+* (DFG) print warning if hsingle_stub is set.
+*
+* Revision 1.1 1994/02/19 06:17:36 cdaq
+* Initial revision
+*
+ implicit none
+ include "hms_data_structures.cmn"
+ include "hms_tracking.cmn"
+*
+ external H_DPSIFUN
+ real*8 H_DPSIFUN
+* local variables
+ integer*4 itrack,ihit
+ integer*4 hitnum,planenum
+ real*8 ray(hnum_fpray_param),calculated_position,residual
+ if(HNTRACKS_FP.gt.0) then
+ if(hsingle_stub.ne.0) then
+ write(hluno,'('' Warning - hsingle_stub is set'')')
+ endif
+ write(hluno,'('' point x_t y_t '',
+ & '' xp_t yp_t chi**2 degrees of'')')
+ write(hluno,'('' [cm] [cm] '',
+ & '' [rad] [rad] freedom'')')
+ do itrack=1,HNTRACKS_FP
+1001 format(1x,i3,2x,4e14.6,e10.3,1x,i3)
+ write(hluno,1001) itrack,HX_FP(itrack),HY_FP(itrack),
+ & HXP_FP(itrack),HYP_FP(itrack),HCHI2_FP(itrack),
+ & HNFREE_FP(itrack)
+ enddo
+ do itrack=1,HNTRACKS_FP
+ htrack_fit_num=itrack
+ ray(1)=dble(HX_FP(itrack))
+ ray(2)=dble(HY_FP(itrack))
+ ray(3)=dble(HXP_FP(itrack))
+ ray(4)=dble(HYP_FP(itrack))
+ write(hluno,'(a,i3)') ' Hits in HMS track number',itrack
+ write(hluno,'(a)')
+ & ' hit plane HDC_WIRE_COORD FIT POSITION RESIDUAL'
+*
+ do ihit=1,HNTRACK_HITS(itrack,1)
+ hitnum=HNTRACK_HITS(itrack,ihit+1)
+ planenum=HDC_PLANE_NUM(hitnum)
+ calculated_position=H_DPSIFUN(ray,planenum)
+ residual=dble(HDC_WIRE_COORD(hitnum))-calculated_position
+ write(hluno,1011) hitnum,planenum,HDC_WIRE_COORD(hitnum),
+ & calculated_position,residual
+1011 format(3x,i3,3x,i3,3x,e15.7,2d15.7)
+ enddo
+ enddo
+ endif
+ return
+ end
+
diff --git a/HTRACKING/h_prt_cal_clusters.f b/HTRACKING/h_prt_cal_clusters.f
new file mode 100644
index 0000000..4ee5557
--- /dev/null
+++ b/HTRACKING/h_prt_cal_clusters.f
@@ -0,0 +1,75 @@
+*=======================================================================
+ subroutine h_prt_cal_clusters
+*=======================================================================
+*-
+*- Dumps the calorimeter cluster data
+*-
+*- Created: 20 Mar 1994 Tsolak A. Amatuni
+*- Modified 25 Mar 1994 DFG
+*- change name and lun
+* $Log: h_prt_cal_clusters.f,v $
+* Revision 1.3 1999/01/21 21:40:14 saw
+* Extra shower counter tube modifications
+*
+* Revision 1.2 1995/05/22 19:39:19 cdaq
+* (SAW) Split gen_data_data_structures into gen, hms, sos, and coin parts"
+*
+* Revision 1.1 1994/04/13 15:40:35 cdaq
+* Initial revision
+*
+*-----------------------------------------------------------------------
+*
+*
+ implicit none
+ save
+*
+ integer*4 nh !Hit number
+ integer*4 nc !Cluster number
+*
+ include 'hms_data_structures.cmn'
+ include 'hms_calorimeter.cmn'
+ include 'hms_tracking.cmn'
+*
+*
+ write(hlun_dbg_cal,10) hnclusters_cal
+ 10 format(///' HMS Calorimeter Cluster Data', /,
+ & ' Total Number of Clusters:',i3,//,
+ & ' Hit # Cluster #')
+*
+ if(hcal_num_hits.le.0) return
+*
+*-----Print the link pointer to cluster number
+ do nh=1,hcal_num_hits
+ write(hlun_dbg_cal,20) nh,hcluster_hit(nh)
+ 20 format(i5,7x,i5)
+ enddo
+*
+ if(hnclusters_cal.le.0) return
+*
+*-----Print the cluster parameters
+ write(hlun_dbg_cal,30)
+ 30 format(/,
+ &' Cluster',/,
+ &' #(size) XC[cm] E1[GeV] E2[GeV] E3[GeV] E4[GeV] ET[GeV] E1_POS[GeV] E1_NEG[GeV] E2_POS[GeV] E2_NEG[GeV ')
+*
+ if(hnclusters_cal.le.0) return
+*
+ do nc=1,hnclusters_cal
+ write(hlun_dbg_cal,40)
+ & nc,
+ & hcluster_size(nc),
+ & hcluster_xc(nc),
+ & hcluster_e1(nc),
+ & hcluster_e2(nc),
+ & hcluster_e3(nc),
+ & hcluster_e4(nc),
+ & hcluster_et(nc),
+ & hcluster_e1_pos(nc),
+ & hcluster_e1_neg(nc),
+ & hcluster_e2_pos(nc),
+ & hcluster_e2_neg(nc)
+ 40 format(i3,'(',i3,')',4x,f6.2,9(1x,f8.4))
+ enddo
+*
+ return
+ end
diff --git a/HTRACKING/h_prt_cal_decoded.f b/HTRACKING/h_prt_cal_decoded.f
new file mode 100644
index 0000000..d86569f
--- /dev/null
+++ b/HTRACKING/h_prt_cal_decoded.f
@@ -0,0 +1,52 @@
+*=======================================================================
+ subroutine h_prt_cal_decoded
+*=======================================================================
+*-
+*- Dumps the decoded calorimeter data
+*-
+*- Created: 19 Mar 1994 Tsolak A. Amatuni
+*- Modified: 25 March 1994 DFG
+*- Change name
+*- Change lun
+* $Log: h_prt_cal_decoded.f,v $
+* Revision 1.2 1995/05/22 19:39:19 cdaq
+* (SAW) Split gen_data_data_structures into gen, hms, sos, and coin parts"
+*
+* Revision 1.1 1994/04/13 15:41:16 cdaq
+* Initial revision
+*
+*-----------------------------------------------------------------------
+*
+ implicit none
+ save
+*
+ integer*4 hit !Hit number
+*
+ include 'hms_data_structures.cmn'
+ include 'hms_calorimeter.cmn'
+ include 'hms_tracking.cmn'
+*
+ write(hlun_dbg_cal,10) hnhits_cal
+ 10 format(///' HMS Calorimeter Decoded Data ',/,
+ & ' Total Number of Hits:',i4, //,
+ & ' Hit # X[cm] Z[cm] Energy Deposition[GeV]')
+*
+*
+ if(hnhits_cal.le.0) return
+*
+ do hit=1,hnhits_cal
+ write(hlun_dbg_cal,20)
+ & hit,hblock_xc(hit),hblock_zc(hit),hblock_de(hit)
+ 20 format(i5,3x,f6.2,1x,f7.2,5x,f9.4)
+ enddo
+*
+ write(hlun_dbg_cal,30) hcal_e1,hcal_e2,hcal_e3,hcal_e4,hcal_et
+ 30 format( /,' Column # Energy Deposition[GeV]',/,
+ & ' 1 ',f9.4 ,/,
+ & ' 2 ',f9.4 ,/,
+ & ' 3 ',f9.4 ,/,
+ & ' 4 ',f9.4 ,/,
+ & ' Total:',f9.4)
+*
+ return
+ end
diff --git a/HTRACKING/h_prt_cal_raw.f b/HTRACKING/h_prt_cal_raw.f
new file mode 100644
index 0000000..608a0ea
--- /dev/null
+++ b/HTRACKING/h_prt_cal_raw.f
@@ -0,0 +1,66 @@
+*=======================================================================
+ subroutine h_prt_cal_raw
+*=======================================================================
+*-
+*- Dumps the raw calorimeter data
+*-
+*- Created: 19 Mar 1994 Tsolak A. Amatuni
+*- Modified 25 Mar 1994 DFG
+*- Change name
+*- Change lun
+*- 7 Apr 1884 DFG Change print order
+* $Log: h_prt_cal_raw.f,v $
+* Revision 1.5 1998/12/17 22:02:39 saw
+* Support extra set of tubes on HMS shower counter
+*
+* Revision 1.4 1995/07/19 18:54:55 cdaq
+* *** empty log message ***
+*
+* Revision 1.3 1995/05/22 19:39:20 cdaq
+* (SAW) Split gen_data_data_structures into gen, hms, sos, and coin parts"
+*
+* Revision 1.2 1995/01/27 20:26:00 cdaq
+* (JRA) Subtract pedestal from ADC value
+*
+* Revision 1.1 1994/04/13 15:41:33 cdaq
+* Initial revision
+*
+*-----------------------------------------------------------------------
+*
+ implicit none
+ save
+*
+ integer*4 hit !Hit number
+ integer*4 row,col,nb
+ real*4 adc_pos,adc_neg
+*
+ include 'hms_data_structures.cmn'
+ include 'hms_calorimeter.cmn'
+ include 'hms_tracking.cmn'
+*
+ write(hlun_dbg_cal,10) hcal_tot_hits
+ 10 format(///' HMS Calorimeter Raw Data ',/,
+ & ' Total Number of Hits:',i3, //,
+ & ' Hit # Column # Row # ADC Value')
+*
+*
+ if(hcal_tot_hits.le.0) return
+*
+ do hit=1,hcal_tot_hits
+ row=hcal_row(hit)
+ col=hcal_column(hit)
+ nb =row+hmax_cal_rows*(col-1)
+ adc_pos=float(hcal_adc_pos(hit))-hcal_pos_ped_mean(nb)
+ adc_neg=float(hcal_adc_neg(hit))-hcal_neg_ped_mean(nb)
+ if(col.le.hcal_num_neg_columns) then
+ write(hlun_dbg_cal,20)
+ & hit,hcal_column(hit),hcal_row(hit),adc_pos,adc_neg
+ 20 format(i5,3x,i5,4x,i5,7x,2f8.1)
+ else
+ write(hlun_dbg_cal,20)
+ & hit,hcal_column(hit),hcal_row(hit),adc_pos
+ endif
+ enddo
+*
+ return
+ end
diff --git a/HTRACKING/h_prt_cal_sparsified.f b/HTRACKING/h_prt_cal_sparsified.f
new file mode 100644
index 0000000..f981607
--- /dev/null
+++ b/HTRACKING/h_prt_cal_sparsified.f
@@ -0,0 +1,47 @@
+*=======================================================================
+ subroutine h_prt_cal_sparsified
+*=======================================================================
+*-
+*- Dumps the sparsified calorimeter data
+*-
+*- Created: 19 Mar 1994 Tsolak A. Amatuni
+*- Modified 25 Mar 1994 DFG
+*- change name and lun
+* $Log: h_prt_cal_sparsified.f,v $
+* Revision 1.3 1998/12/17 22:02:39 saw
+* Support extra set of tubes on HMS shower counter
+*
+* Revision 1.2 1995/05/22 19:39:21 cdaq
+* (SAW) Split gen_data_data_structures into gen, hms, sos, and coin parts"
+*
+* Revision 1.1 1994/04/13 15:41:58 cdaq
+* Initial revision
+*
+*-----------------------------------------------------------------------
+*
+ implicit none
+ save
+*
+ integer*4 hit !Hit number
+*
+ include 'hms_data_structures.cmn'
+ include 'hms_calorimeter.cmn'
+ include 'hms_tracking.cmn'
+*
+ write(hlun_dbg_cal,10) hcal_num_hits
+ 10 format(///' HMS Calorimeter Sparsified Data ',/,
+ & ' Total Number of Hits:',i7, //,
+ & ' Hit # Row # Column # ADC - PED')
+*
+*
+ if(hcal_num_hits.le.0) return
+*
+ do hit=1,hcal_num_hits
+ write(hlun_dbg_cal,20)
+ & hit,hcal_rows(hit),hcal_cols(hit),hcal_adcs_pos(hit)
+ & ,hcal_adcs_neg(hit)
+ 20 format(i5,3x,i5,4x,i5,6x,2f8.2)
+ enddo
+*
+ return
+ end
diff --git a/HTRACKING/h_prt_cal_tests.f b/HTRACKING/h_prt_cal_tests.f
new file mode 100644
index 0000000..1602a63
--- /dev/null
+++ b/HTRACKING/h_prt_cal_tests.f
@@ -0,0 +1,50 @@
+*=======================================================================
+ subroutine h_prt_cal_tests
+*=======================================================================
+*-
+*- Dumps the calorimeter particle ID information
+*-
+*- Created: 20 Mar 1994 Tsolak A. Amatuni
+*- Modified 25 Mar 1994 DFG
+*- Change name and lun
+* $Log: h_prt_cal_tests.f,v $
+* Revision 1.2 1995/05/22 19:39:22 cdaq
+* (SAW) Split gen_data_data_structures into gen, hms, sos, and coin parts"
+*
+* Revision 1.1 1994/04/13 15:42:13 cdaq
+* Initial revision
+*
+*-----------------------------------------------------------------------
+*
+*
+ implicit none
+ save
+*
+ integer*4 nt !Detector track number
+*
+ include 'hms_data_structures.cmn'
+ include 'hms_calorimeter.cmn'
+ include 'hms_tracking.cmn'
+*
+*
+ write(hlun_dbg_cal,10) hntracks_fp
+ 10 format(///' HMS Calorimeter Particle ID Quantities', /,
+ & ' Total Number of Detector Tracks:',i3,//,
+ &' Track # N-blocks E1[GeV] E2[GeV] E3[GeV] E4[GeV] Et[GeV]')
+*
+ if(hntracks_fp.le.0) return
+*
+ do nt=1,hntracks_fp
+ write(hlun_dbg_cal,20)
+ & nt,
+ & hnblocks_cal(nt),
+ & htrack_e1(nt),
+ & htrack_e2(nt),
+ & htrack_e3(nt),
+ & htrack_e4(nt),
+ & htrack_et(nt)
+ 20 format(3x,i5,5x,i5,5(1x,f8.4))
+ enddo
+*
+ return
+ end
diff --git a/HTRACKING/h_prt_cal_tracks.f b/HTRACKING/h_prt_cal_tracks.f
new file mode 100644
index 0000000..f8d7c87
--- /dev/null
+++ b/HTRACKING/h_prt_cal_tracks.f
@@ -0,0 +1,50 @@
+*=======================================================================
+ subroutine h_prt_cal_tracks
+*=======================================================================
+*-
+*- Dumps the calorimeter track quantities
+*-
+*- Created: 20 Mar 1994 Tsolak A. Amatuni
+*- Modified 25 Mar 1994 DFG
+*- Change name and lun
+* $Log: h_prt_cal_tracks.f,v $
+* Revision 1.5 2003/03/21 22:21:51 jones
+* Modified and rearrange routines to calibrate the HMS calorimeter (V. Tadevosyan)
+*
+* Revision 1.2 1995/05/22 19:39:23 cdaq
+* (SAW) Split gen_data_data_structures into gen, hms, sos, and coin parts"
+*
+* Revision 1.1 1994/04/13 15:42:40 cdaq
+* Initial revision
+*
+*-----------------------------------------------------------------------
+*
+*
+ implicit none
+ save
+*
+ integer*4 nt !Detector track number
+*
+ include 'hms_data_structures.cmn'
+ include 'hms_calorimeter.cmn'
+ include 'hms_tracking.cmn'
+*
+*
+ write(hlun_dbg_cal,10) hntracks_fp
+ 10 format(///' HMS Calorimeter Track Quantities', /,
+ & ' Total Number of Detector Tracks:',i3,//,
+ & ' Track # Cluster # X[cm] Y[cm]')
+*
+ if(hntracks_fp.le.0) return
+*
+ do nt=1,hntracks_fp
+ write(hlun_dbg_cal,20)
+ & nt,hcluster_track(nt),htrack_xc(nt),htrack_yc(nt)
+ 20 format(3x,i5,7x,i5,2(2x,f6.2))
+ enddo
+*
+ write(hlun_dbg_cal,30) hntracks_cal
+ 30 format(' Total Number of Calorimeter Tracks:',i3)
+*
+ return
+ end
diff --git a/HTRACKING/h_prt_dec_scin.f b/HTRACKING/h_prt_dec_scin.f
new file mode 100644
index 0000000..a22ff3b
--- /dev/null
+++ b/HTRACKING/h_prt_dec_scin.f
@@ -0,0 +1,89 @@
+ SUBROUTINE h_prt_dec_scin(ABORT,err)
+*--------------------------------------------------------
+*-
+*- Purpose and Methods : Dump HMS_DECODED_SCIN BANKS
+*-
+*- Required Input BANKS HMS_DECODED_SCIN
+*-
+*- Output: ABORT - success or failure
+*- : err - reason for failure, if any
+*-
+*- Created 29-FEB-1994 D. F. Geesaman
+* $Log: h_prt_dec_scin.f,v $
+* Revision 1.8 1996/01/16 21:55:27 cdaq
+* (JRA)
+*
+* Revision 1.7 1995/05/22 19:39:23 cdaq
+* (SAW) Split gen_data_data_structures into gen, hms, sos, and coin parts"
+*
+* Revision 1.6 1995/02/02 16:10:49 cdaq
+* (JRA) Make hscin_all_adc_pos/neg floating
+*
+* Revision 1.5 1994/09/13 20:23:29 cdaq
+* *** empty log message ***
+*
+* Revision 1.4 1994/09/13 20:20:21 cdaq
+* (JRA) Change output format, add missing variables
+*
+* Revision 1.3 1994/08/02 20:00:48 cdaq
+* (JRA) Print out some additional information
+*
+* Revision 1.2 1994/05/12 21:01:39 cdaq
+* (DFG) Fix typo
+*
+* Revision 1.1 1994/04/13 15:42:58 cdaq
+* Initial revision
+*
+*--------------------------------------------------------
+ IMPLICIT NONE
+ SAVE
+*
+ character*50 here
+ parameter (here= 'h_prt_dec_scin')
+*
+ logical ABORT
+ character*(*) err
+*
+ integer*4 j
+ include 'hms_data_structures.cmn'
+ include 'gen_constants.par'
+ include 'gen_units.par'
+ include 'hms_tracking.cmn'
+*
+*--------------------------------------------------------
+ ABORT = .FALSE.
+ err = ' '
+
+ write(hluno,'('' ***HMS_REAL_SCIN BANKS***'')')
+ write(hluno,'('' HSCIN_TOT_HITS='',I4)') HSCIN_TOT_HITS
+ if(HSCIN_TOT_HITS.GT.0) then
+ write(hluno,'('' Num Plane Counter ADC_POS'',
+ & '' ADC_NEG TDC_POS TDC_NEG'')')
+ write(hluno,'(1x,i2,2x,i3,5x,i4,8x,2f8.2,2i8)')
+ & (j,HSCIN_PLANE_NUM(j),HSCIN_COUNTER_NUM(j),
+ & HSCIN_ADC_POS(j),HSCIN_ADC_NEG(j),
+ & HSCIN_TDC_POS(j),HSCIN_TDC_NEG(j),
+ & j=1,HSCIN_TOT_HITS )
+ endif
+
+ write(hluno,'('' HMS_DECODED_SCIN BANKS'')')
+ if(HSCIN_TOT_HITS.GT.0) then
+ write(hluno,'('' Scintillator hits per plane'')')
+ write(hluno,'('' Plane '',10i4)') (j,j=1,HNUM_SCIN_PLANES)
+ write(hluno,'('' Number '',10i4)')
+ & (HSCIN_HITS_PER_PLANE(j),j=1,HNUM_SCIN_PLANES)
+ write(hluno,'('' Num ZPOS CENTER HIT_COORD SLOP'',
+ & '' COR_TDC TWO_GOOD'')')
+ write(hluno,'(1x,i2,2x,4f9.3,f10.3,4x,l2)')
+ & (j,HSCIN_ZPOS(j),HSCIN_CENTER_COORD(j),
+ & HSCIN_DEC_HIT_COORD(j),
+ & HSCIN_SLOP(j),HSCIN_COR_TIME(j),
+ & HTWO_GOOD_TIMES(j),
+ & j=1,HSCIN_TOT_HITS)
+ write(hluno,'('' HGOOD_START_TIME='', l2)')
+ & HGOOD_START_TIME
+ write(hluno,'('' HSTART_TIME='',e10.4)') HSTART_TIME
+ write(hluno,*)
+ endif
+ RETURN
+ END
diff --git a/HTRACKING/h_prt_raw_scin.f b/HTRACKING/h_prt_raw_scin.f
new file mode 100644
index 0000000..a261b29
--- /dev/null
+++ b/HTRACKING/h_prt_raw_scin.f
@@ -0,0 +1,68 @@
+ SUBROUTINE h_prt_raw_scin(ABORT,err)
+*--------------------------------------------------------
+*-
+*- Purpose and Methods : Dump HMS_RAW_SCIN BANKS
+*-
+*- Required Input BANKS HMS_RAW_SCIN
+*-
+*- Output: ABORT - success or failure
+*- : err - reason for failure, if any
+*-
+*- Created 29-FEB-1994 D. F. Geesaman
+* $Log: h_prt_raw_scin.f,v $
+* Revision 1.6 1995/07/20 19:08:41 cdaq
+* (SAW) Fix format
+*
+* Revision 1.5 1995/05/22 19:39:23 cdaq
+* (SAW) Split gen_data_data_structures into gen, hms, sos, and coin parts"
+*
+* Revision 1.4 1994/09/13 21:45:46 cdaq
+* (JRA) Use new pedestals
+*
+* Revision 1.3 1994/09/13 21:40:43 cdaq
+* (JRA) Remove include tmp_pedestals.dte
+*
+* Revision 1.2 1994/08/03 14:19:31 cdaq
+* (JRA) Fix variable names
+*
+* Revision 1.1 1994/04/13 15:43:19 cdaq
+* Initial revision
+*
+*--------------------------------------------------------
+ IMPLICIT NONE
+ SAVE
+*
+ character*50 here
+ parameter (here= 'h_prt_raw_scin')
+*
+ logical ABORT
+ character*(*) err
+*
+ integer*4 j
+ include 'hms_data_structures.cmn'
+ include 'gen_constants.par'
+ include 'gen_units.par'
+ include 'hms_tracking.cmn'
+ include 'hms_scin_parms.cmn'
+*
+*--------------------------------------------------------
+ ABORT = .FALSE.
+ err = ' '
+ write(hluno,'('' HMS_RAW_SCIN BANKS'')')
+ write(hluno,'('' HSCIN_ALL_TOT_HITS='',I4)') HSCIN_ALL_TOT_HITS
+ if(HSCIN_ALL_TOT_HITS.GT.0) then
+ write(hluno,'('' Num Plane Counter ADC_POS ''
+ & '' ADC_NEG TDC_POS TDC_NEG'')')
+ write(hluno,'(1x,i2,2x,i3,7x,i4,8x,2f8.1,2i8)')
+ & (j,HSCIN_ALL_PLANE_NUM(j),HSCIN_ALL_COUNTER_NUM(j),
+ & (HSCIN_ALL_ADC_POS(j)
+ $ -HSCIN_ALL_PED_POS(hscin_all_plane_num(j)
+ $ ,hscin_all_counter_num(j)))
+ $ ,(HSCIN_ALL_ADC_NEG(j)
+ $ -HSCIN_ALL_PED_NEG(hscin_all_plane_num(j)
+ $ ,hscin_all_counter_num(j)))
+ $ ,HSCIN_ALL_TDC_POS(j)
+ $ ,HSCIN_ALL_TDC_NEG(j),j=1,HSCIN_ALL_TOT_HITS )
+ endif
+ RETURN
+ END
diff --git a/HTRACKING/h_prt_tof.f b/HTRACKING/h_prt_tof.f
new file mode 100644
index 0000000..6cec7c3
--- /dev/null
+++ b/HTRACKING/h_prt_tof.f
@@ -0,0 +1,77 @@
+ subroutine h_prt_tof(itrk)
+
+*-------------------------------------------------------------------
+* author: John Arrington
+* created: 3/27/94
+*
+* h_prt_tof dumps the hms_scin_tof bank.
+*
+* modifications:
+* $Log: h_prt_tof.f,v $
+* Revision 1.5.26.1 2008/11/17 15:58:28 cdaq
+* Changed from old to new tof offset
+*
+* Revision 1.5 1996/01/24 15:59:22 saw
+* (JRA) Add scin.center column to output
+*
+* Revision 1.4 1995/05/22 19:39:24 cdaq
+* (SAW) Split gen_data_data_structures into gen, hms, sos, and coin parts"
+*
+* Revision 1.3 1995/02/02 13:12:45 cdaq
+* (JRA) Cosmetic changes
+*
+* Revision 1.2 1994/09/13 20:28:43 cdaq
+* (JRA) Change output format, add missing variables
+*
+* Revision 1.1 1994/04/13 15:43:38 cdaq
+* Initial revision
+*
+*-------------------------------------------------------------------
+
+ implicit none
+
+ include 'hms_data_structures.cmn'
+ include 'hms_scin_parms.cmn'
+ include 'hms_scin_tof.cmn'
+ include 'hms_tracking.cmn'
+
+* logical abort
+ integer*4 ihit, itrk
+* character*1024 errmsg
+* character*25 here
+* parameter (here = 'h_prt_tof')
+
+ save
+
+ write(hluno,'('' ***H_SCIN_TOF BANK***'')')
+ write(hluno,'('' TRACK NUMBER'',i3)') itrk
+ write(hluno,'(''POSITION/CALIBRATION VARIABLES:'')')
+ write(hluno,'('' +coord -coord '',
+ & '' pos_dt neg_dt +sigma -sigma scin.center'')')
+ do ihit=1,hscin_tot_hits
+ write(hluno,'(f8.3,f8.3,2f8.3,2f8.3,f10.2)')
+ & hscin_pos_coord(ihit), hscin_neg_coord(ihit),
+ & hscin_pos_invadc_offset(ihit),
+ > hscin_neg_invadc_offset(ihit),
+ & hscin_pos_sigma(ihit), hscin_neg_sigma(ihit),
+ & hscin_center_coord(ihit)
+ enddo
+ write(hluno,'(''HIT POSITION AND OTHER CALCULATED VARIABLES:'')')
+ write(hluno,'('' long_coord trans_coord +time -time'',
+ & '' scin_time scin_sig on_trk time@fp'')')
+ do ihit=1,hscin_tot_hits
+ write(hluno,'(2f12.4,2f9.3,f10.3,f8.3,l5,f10.3)')
+ & hscin_long_coord(ihit), hscin_trans_coord(ihit),
+ & hscin_pos_time(ihit), hscin_neg_time(ihit),
+ & hscin_time(ihit), hscin_sigma(ihit),
+ & hscin_on_track(itrk,ihit),hscin_time_fp(ihit)
+ enddo
+ write(hluno,'('' trk beta chisq_beta fp_time '',
+ & ''num_scin_hit num_pmt_hit'')')
+ write(hluno,'(i4,f8.4,f14.3,f9.3,i8,i12)') itrk,
+ & hbeta(itrk), hbeta_chisq(itrk), htime_at_fp(itrk),
+ & hnum_scin_hit(itrk),hnum_pmt_hit(itrk)
+ write(hluno,*)
+
+ return
+ end
diff --git a/HTRACKING/h_prt_track_tests.f b/HTRACKING/h_prt_track_tests.f
new file mode 100644
index 0000000..6c1adad
--- /dev/null
+++ b/HTRACKING/h_prt_track_tests.f
@@ -0,0 +1,63 @@
+ subroutine h_prt_track_tests
+
+*-------------------------------------------------------------------
+* author: John Arrington
+* created: 3/28/94
+*
+* h_prt_track_tests dumps the hms_track_tests bank.
+*
+* modifications:
+* $Log: h_prt_track_tests.f,v $
+* Revision 1.2 1995/05/22 19:39:24 cdaq
+* (SAW) Split gen_data_data_structures into gen, hms, sos, and coin parts"
+*
+* Revision 1.1 1994/04/13 15:43:55 cdaq
+* Initial revision
+*
+*-------------------------------------------------------------------
+
+ implicit none
+
+ include 'hms_data_structures.cmn'
+ include 'hms_scin_parms.cmn'
+ include 'hms_scin_tof.cmn'
+ include 'hms_tracking.cmn'
+
+ logical abort
+ integer*4 ihit, itrk
+ character*1024 errmsg
+ character*25 here
+ parameter (here = 'h_prt_track_tests')
+
+ save
+
+ if(hntracks_fp.gt.0) then
+ write(hluno,'('' h_TRACK_TESTS BANK'')')
+ write(hluno,'(''SHOWER COUNTER TESTS'')')
+ write(hluno,'('' num_blks plane1 plane2 plane3 plane4'',
+ & '' shtrk prtrk'')')
+ do itrk=1, hntracks_fp
+ write(hluno,'(i10,6f9.3)') hnblocks_cal(itrk),
+ & htrack_e1(itrk), htrack_e2(itrk),
+ & htrack_e3(itrk), htrack_e4(itrk),
+ & htrack_et(itrk), htrack_preshower_e(itrk)
+ enddo
+ write(hluno,'(''SCIN/CERENKOV TESTS'')')
+ write(hluno,'('' trk beta chisq_beta fp_time '',
+ & ''num_scin_hit'')')
+ do itrk=1, hntracks_fp
+ write(hluno,'(i4,f8.4,f10.4,f9.3,i12)') itrk,
+ & hbeta(itrk), hbeta_chisq(itrk), htime_at_fp(itrk),
+ & hnum_scin_hit(itrk)
+ enddo
+
+ do itrk=1, hntracks_fp
+ write(hluno,'(''hits on track number'',i3,'', and dE/dx:'')') itrk
+ write(hluno,'(16i6)')
+ & (hscin_hit(itrk,ihit),ihit=1,hnum_scin_hit(itrk))
+ write(hluno,'(16f6.1)')
+ & (hdedx(itrk,ihit),ihit=1,hnum_scin_hit(itrk))
+ enddo
+ endif ! end check on zero focal plane tracks
+ return
+ end
diff --git a/HTRACKING/h_psifun.f b/HTRACKING/h_psifun.f
new file mode 100644
index 0000000..1a8f921
--- /dev/null
+++ b/HTRACKING/h_psifun.f
@@ -0,0 +1,56 @@
+ function h_psifun(ray,iplane)
+* this function calculates the psi coordinate of the intersection
+* of a ray (defined by ray) with a wire chamber plane. the geometry
+* of the plane is contained in the coeff array calculated in the
+* array splane_coeff
+*
+* the ray is defined by
+* x = (z-zt)*tan(xp) + xt
+* y = (z-zt)*tan(yp) + yt
+* at some fixed value of zt*
+* ray(1) = xt
+* ray(2) = yt
+* ray(3) = tan(xp)
+* ray(4) = tan(yp)
+*
+* d.f. geesaman 1 September 1993
+* $Log: h_psifun.f,v $
+* Revision 1.2 1995/05/22 19:39:24 cdaq
+* (SAW) Split gen_data_data_structures into gen, hms, sos, and coin parts"
+*
+* Revision 1.1 1994/02/19 06:17:49 cdaq
+* Initial revision
+*
+*
+ implicit none
+ include "hms_data_structures.cmn"
+ include "hms_geometry.cmn"
+*
+* input
+ real*4 ray(4) ! xt,yt,xpt,ypt
+ integer*4 iplane ! plane number
+* output
+ real*4 H_PSIFUN ! value of psi coordinate of hit of ray in plane
+*
+* local variables
+ real*4 denom,infinity,cinfinity
+ parameter (infinity = 1.0d20)
+ parameter (cinfinity = 1/infinity)
+*
+ H_PSIFUN = ray(3)*ray(2)*hplane_coeff(1,iplane)
+ & + ray(4)*ray(1)*hplane_coeff(2,iplane)
+ & + ray(3)*hplane_coeff(3,iplane)
+ & + ray(4)*hplane_coeff(4,iplane)
+ & + ray(1)*hplane_coeff(5,iplane)
+ & + ray(2)*hplane_coeff(6,iplane)
+*
+ denom = ray(3)*hplane_coeff(7,iplane)
+ & + ray(4)*hplane_coeff(8,iplane) + hplane_coeff(9,iplane)
+*
+ if(abs(denom).lt.cinfinity) then
+ H_PSIFUN=infinity
+ else
+ H_PSIFUN = H_PSIFUN/denom
+ endif
+ return
+ end
diff --git a/HTRACKING/h_raw_dump_all.f b/HTRACKING/h_raw_dump_all.f
new file mode 100644
index 0000000..50430a8
--- /dev/null
+++ b/HTRACKING/h_raw_dump_all.f
@@ -0,0 +1,50 @@
+ SUBROUTINE h_raw_dump_all(ABORT,err)
+*--------------------------------------------------------
+*-
+*- Purpose and Methods : Dump all raw HMS banks
+*-
+*- Required Input BANKS HMS_RAW_SCIN,HMS_RAW_CAL,HMS_RAW_DC
+*-
+*- Output: ABORT - success or failure
+*- : err - reason for failure, if any
+*-
+*- Created 5-APR-1994 D. F. Geesaman
+* $Log: h_raw_dump_all.f,v $
+* Revision 1.2 1995/05/22 19:39:25 cdaq
+* (SAW) Split gen_data_data_structures into gen, hms, sos, and coin parts"
+*
+* Revision 1.1 1994/04/13 15:44:15 cdaq
+* Initial revision
+*
+*--------------------------------------------------------
+ IMPLICIT NONE
+ SAVE
+*
+ character*50 here
+ parameter (here= 'h_raw_dump_all')
+*
+ logical ABORT
+ character*(*) err
+*
+ include 'hms_data_structures.cmn'
+ include 'hms_scin_parms.cmn'
+ include 'hms_tracking.cmn'
+ include 'hms_calorimeter.cmn'
+*
+*--------------------------------------------------------
+ ABORT = .FALSE.
+ err = ' '
+* Dump raw bank if hdebugprintscinraw is set
+ if( hdebugprintscinraw .ne. 0) then
+ call h_prt_raw_scin(ABORT,err)
+ endif
+*
+*
+ if(hdbg_raw_cal.gt.0) call h_prt_cal_raw
+* call h_prt_raw_cer
+* Dump raw bank if debug flag set
+ if(hdebugprintrawdc.ne.0) then
+ call h_print_raw_dc(ABORT,err)
+ endif
+ RETURN
+ END
diff --git a/HTRACKING/h_reconstruction.f b/HTRACKING/h_reconstruction.f
new file mode 100644
index 0000000..0e0187b
--- /dev/null
+++ b/HTRACKING/h_reconstruction.f
@@ -0,0 +1,317 @@
+ SUBROUTINE H_reconstruction(ABORT,err)
+*--------------------------------------------------------
+*- Prototype C analysis routine
+*-
+*-
+*- Purpose and Methods : reconstruction of HMS quantities
+*-
+*- Output: ABORT - success or failure
+*- : err - reason for failure, if any
+*-
+*- Created 8-Nov-1993 Kevin B. Beard, HU
+*- Modified 20-Nov-1993 KBB for new errors
+* $Log: h_reconstruction.f,v $
+* Revision 1.13.24.6 2007/11/02 19:52:52 cdaq
+* Implementation of simple "constant drift velocity" type model. (ejb)
+*
+* Revision 1.13.24.5 2007/11/01 19:14:51 cdaq
+* added wire--HMS track distance to FPP Ntuple
+*
+* Revision 1.13.24.4 2007/10/22 18:14:53 cdaq
+* commented out print statement
+*
+* Revision 1.13.24.3 2007/10/17 19:38:50 cdaq
+* FPP fixes
+*
+* Revision 1.13.24.2 2007/09/12 14:40:03 brash
+* *** empty log message ***
+*
+* Revision 1.13.24.1 2007/08/22 19:09:30 frw
+* added FPP
+*
+*
+* Revision 1.20 2004/04/26 19:53:33 frw
+* inserted calls for FPP
+*
+* Revision 1.13 2002/12/20 21:53:33 jones
+* Modified by Hamlet for new HMS aerogel
+*
+* Revision 1.13 2002/09/30
+* (Hamlet) Add call HMS Aerogel (Took cp from Vardan)
+*
+* Revision 1.12 1996/08/30 20:33:42 saw
+* (DVW?) Add hbypass_track_eff
+*
+* Revision 1.11 1995/10/10 17:33:45 cdaq
+* (JRA) Don't make an error just because no track is found
+*
+* Revision 1.10 1995/08/31 14:46:06 cdaq
+* (JRA) Add call to h_trans_cer
+*
+* Revision 1.9 1995/05/22 19:39:25 cdaq
+* (SAW) Split gen_data_data_structures into gen, hms, sos, and coin parts"
+*
+* Revision 1.8 1995/05/11 19:05:48 cdaq
+* (JRA) Add call to h_trans_misc
+*
+* Revision 1.7 1995/02/02 13:06:13 cdaq
+* (SAW) Add call to h_select_best_track
+*
+* Revision 1.6 1994/06/06 16:49:49 cdaq
+* (DFG) add h_recon_num and bypass switches
+*
+* Revision 1.5 1994/05/12 21:18:13 cdaq
+* (DFG) Put h_prt_track_tests here. Remove from h_tof
+*
+* Revision 1.4 1994/04/13 16:06:00 cdaq
+* (DFG) Add consolidated call to h_raw_dump_all
+* Commented out returns after ABORT's
+*
+* Revision 1.3 1994/02/22 15:51:33 cdaq
+* (DFG) Replace with real version
+* (SAW) Move to TRACKING directory
+*
+* Revision 1.2 1994/02/04 20:49:31 cdaq
+* Print out some raw hit data
+*
+* Revision 1.1 1994/02/04 20:47:59 cdaq
+* Initial revision
+*
+*-
+*- All standards are from "Proposal for Hall C Analysis Software
+*- Vade Mecum, Draft 1.0" by D.F.Geesamn and S.Wood, 7 May 1993
+*-
+*--------------------------------------------------------
+ IMPLICIT NONE
+ SAVE
+*
+ character*16 here
+ parameter (here= 'H_reconstruction')
+*
+ logical ABORT
+ character*(*) err
+*
+ INCLUDE 'hms_data_structures.cmn'
+ INCLUDE 'gen_constants.par'
+ INCLUDE 'gen_units.par'
+ include 'hms_scin_parms.cmn'
+ include 'hms_bypass_switches.cmn'
+ include 'hms_statistics.cmn'
+*
+* Local variables
+ integer*4 istat
+*--------------------------------------------------------
+*
+ccc ABORT= .TRUE.
+ccc err= ':no events analyzed!'
+*
+* increment reconstructed number
+c h_recon_num= h_recon_num + 1
+*
+* dump
+ call h_raw_dump_all(ABORT,err)
+ if(ABORT) then
+ call g_add_path(here,err)
+ return
+ endif ! end test on h_raw_dump_all ABORT
+*
+* TRANSLATE SCINTILATORS AND CALCULATE START TIME
+* HMS_RAW_SCIN ====> HMS_DECODED_SCIN
+*
+ If(hbypass_trans_scin.eq.0) then
+ call H_TRANS_SCIN(ABORT,err)
+ if(ABORT) then
+ call G_add_path(here,err)
+* return
+ endif ! end test on SCIN ABORT
+ endif ! end test on hbypass_trans_scin
+*
+* TRANSLATE HMISC TDC HITS.
+* H_RAW_MISC ====> HMS_DECODED_MISC
+*
+ If(hbypass_trans_scin.eq.0) then
+ call H_TRANS_MISC(ABORT,err)
+ if(ABORT) then
+ call G_add_path(here,err)
+* return
+ endif ! end test on SCIN ABORT
+ endif ! end test on hbypass_trans_scin
+*
+* TRANSLATE CERENKOV
+* HMS_RAW_CER ====> HMS_DECODED_CER
+*
+ If(hbypass_trans_cer.eq.0) then
+ call H_TRANS_CER(ABORT,err)
+ if(ABORT) then
+ call G_add_path(here,err)
+* return
+ endif ! end test on CER ABORT
+ endif ! end test on hbypass_trans_cer
+*
+* TRANSLATE FPP
+* HMS_RAW_FPP ====> HMS_FPP_event
+*
+ If(hbypass_trans_fpp.eq.0.or.hbypass_trans_fpp.eq.4) then
+ call h_trans_fpp(ABORT,err)
+ if(ABORT) then
+ call G_add_path(here,err)
+* return
+ endif ! end test on FPP ABORT
+ endif
+*
+* Next Aerogel Cerenkov information
+* HMS_DECODED_AERO====> HMS_TRACK_TESTS
+*
+ if(hbypass_haero.eq.0) then
+ call H_AERO(ABORT,err)
+ if(ABORT) then
+ call G_add_path(here,err)
+* return
+ endif ! end test of H_AERO ABORT
+ endif ! end test on hbypass_aero
+*
+* TRANSLATE CALORIMETER
+* HMS_RAW_CAL ====> HMS_DECODED_CAL
+*
+ if(hbypass_trans_cal.eq.0) then
+ call H_TRANS_CAL(ABORT,err)
+ if(ABORT) then
+ call G_add_path(here,err)
+* return
+ endif ! end test on CAL ABORT
+ endif ! end test on hbypass_trans_cal
+*
+* TRANLATE DRIFT CHAMBERS
+* HMS_RAW_DC + HMS_DECODED_SCIN ====> HMS_DECODED_DC
+ if(hbypass_trans_dc.eq.0) then
+ call H_TRANS_DC(ABORT,err)
+ if(ABORT) then
+ call G_add_path(here,err)
+ return
+ endif ! end test on H_TRANS_DC ABORT
+ endif ! end test on hbypass_trans_dc
+ if(hbypass_track.eq.0) then
+ call H_TRACK(ABORT,err)
+ if(ABORT) then
+ call G_add_path(here,err)
+ return
+ endif ! end test on H_TRACK ABORT
+ if(hbypass_track_eff.eq.0) then
+ call h_track_tests
+ endif ! end test on hbypass_trackeff
+ endif ! end test on hbypass_track
+* only proceed if the number of tracks is greater than one
+*
+ if(HNTRACKS_FP .lt. 1) then
+c don't want error message every time a track is not found.
+c ABORT=.FALSE.
+c err=":no tracks found!"
+ else
+
+c print *,' HMS track found!'
+
+* Proceed if one or more track has been found
+*
+* Project tracks back to target
+* HMS_FOCAL_PLANE ====> HMS_TARGET
+*
+ if(hbypass_targ_trans.eq. 0) then
+ call H_TARG_TRANS(ABORT,err,istat)
+ if(ABORT) then
+ call G_add_path(here,err)
+ return
+ endif ! end test on H_TARG_TRANS ABORT
+ endif ! end test on hbypass_target_trans
+*
+* Now begin to process particle identification information
+* First scintillator and time of flight
+* HMS_RAW_SCIN ====> HMS_TRACK_TESTS
+*
+ if(hbypass_tof.eq.0) then
+ call H_TOF(ABORT,err)
+ if(ABORT) then
+ call G_add_path(here,err)
+ return
+ endif ! end test of H_TOF ABORT
+ endif ! end test on hbypass_tof
+* Next Calorimeter information
+* HMS_DECODED_CAL ====> HMS_TRACK_TESTS
+*
+ if(hbypass_cal.eq.0) then
+ call H_CAL(ABORT,err)
+ if(ABORT) then
+ call G_add_path(here,err)
+* return
+ endif ! end test of H_CAL ABORT
+ endif ! end test on hbypass_cal
+* Next Cerenkov information
+* HMS_DECODED_CER ====> HMS_TRACK_TESTS
+*
+ if(hbypass_cer.eq.0) then
+ call H_CER(ABORT,err)
+ if(ABORT) then
+ call G_add_path(here,err)
+* return
+ endif ! end test of H_CER ABORT
+ endif ! end test on hbypass_cer
+*
+* Dump HMS_TRACK_TESTS if hdebugprinttracktests is set
+ if( hdebugprinttracktests .ne. 0 ) then
+ call h_prt_track_tests
+ endif
+*
+* Combine results in HMS physics analysis
+* HMS_TARGET + HMS_TRACK_TESTS ====> HMS_PHYSICS
+*
+ if(hbypass_track.eq.0) then
+ call h_select_best_track(abort,err)
+ if(ABORT) then
+ call G_add_path(here,err)
+ return
+ endif
+ endif
+*
+ if(hbypass_physics.eq.0) then
+ call h_physics(abort,err)
+ if(ABORT) then
+ call G_add_path(here,err)
+ return
+ endif ! end test of H_PHYSICS ABORT
+ endif ! end test on hbypass_physics
+*
+* process FPP information
+*
+ if(hbypass_trans_fpp.eq.2) then !option to use HMS tracks to fill FPP variables
+ call h_trans_fpp_hms(ABORT,err)
+ if(ABORT) then
+ call G_add_path(here,err)
+* return
+ endif ! end test on FPP ABORT
+ endif ! end test on hbypass_trans_fpp
+ if(hbypass_fpp.eq.0) then
+ call h_fpp(ABORT,err)
+ if(ABORT) then
+ call G_add_path(here,err)
+* return
+ endif ! end test of h_fpp ABORT
+ endif ! end test on hbypass_fpp
+*
+ endif ! end test no tracks found
+
+
+* * fill FPP histogramms even if no HMS track
+ if(hbypass_fpp.eq.0) then
+ call h_fill_fpp(ABORT,err)
+ if (ABORT) then
+ call g_add_path(here,err)
+ return
+ endif
+ endif ! end test on hbypass_fpp
+
+*
+* Successful return
+ ABORT=.FALSE.
+ RETURN
+ END
+
+
diff --git a/HTRACKING/h_register_param.f b/HTRACKING/h_register_param.f
new file mode 100644
index 0000000..e6bf298
--- /dev/null
+++ b/HTRACKING/h_register_param.f
@@ -0,0 +1,108 @@
+ SUBROUTINE h_register_param(ABORT,err)
+*--------------------------------------------------------
+*-
+*- Purpose and Methods : Initializes HMS quantities
+*-
+*- Output: ABORT - success or failure
+*- : err - reason for failure, if any
+*-
+*- Created 8-Nov-1993 Kevin B. Beard
+*- Modified 20-Nov-1993 KBB for new errors
+*- 14 Feb-1994 DFG Put in real variables
+*-
+*- All standards are from "Proposal for Hall C Analysis Software
+*- Vade Mecum, Draft 1.0" by D.F.Geesamn and S.Wood, 7 May 1993
+* $Log: h_register_param.f,v $
+* Revision 1.11.24.1 2007/08/22 19:09:30 frw
+* added FPP
+*
+* Revision 1.12 2006/06/22 frw
+* added FPP structures
+*
+* Revision 1.11 2002/12/20 21:53:34 jones
+* Modified by Hamlet for new HMS aerogel
+*
+* Revision 1.10 1995/08/31 14:45:31 cdaq
+* (JRA) Register Cerenkov variables
+*
+* Revision 1.9 1995/05/17 13:57:20 cdaq
+* (JRA) Register pedestal variables
+*
+* Revision 1.8 1994/08/18 03:52:45 cdaq
+* (SAW) Call makereg generated routines to register variables
+*
+* Revision 1.7 1994/06/17 17:46:36 cdaq
+* (KBB) Upgrade error reporting
+*
+* Revision 1.6 1994/06/06 17:13:37 cdaq
+* (DFG) add call to register bypass switches and statistics
+*
+* Revision 1.5 1994/03/24 19:41:33 cdaq
+* (DFG) Move actual registereing of variables to subroutines
+*
+* Revision 1.4 1994/02/23 15:39:02 cdaq
+* (SAW) ABORT now when ierr.NE.0
+*
+* Revision 1.3 1994/02/22 20:39:21 cdaq
+* (SAW) Fix booboo
+*
+* Revision 1.2 1994/02/22 18:52:06 cdaq
+* (SAW) Move regpar declarations to gen_routines.dec. Make title arg null.
+*
+*-
+*--------------------------------------------------------
+ IMPLICIT NONE
+ SAVE
+*
+ character*16 here
+ parameter (here= 'H_register_param')
+*
+ logical ABORT
+ character*(*) err
+*
+ logical FAIL
+ character*1000 why
+*
+*--------------------------------------------------------
+ err= ' '
+ ABORT = .false.
+*
+* register tracking variables
+*
+
+ call r_hms_tracking
+ call r_hms_geometry
+ call r_hms_track_histid
+ call r_hms_recon_elements
+ call r_hms_physics_sing
+*
+* register cal, tof and cer variables
+*
+
+ call r_hms_scin_parms
+ call r_hms_scin_tof
+ call r_hms_cer_parms
+ call r_hms_calorimeter
+ call r_hms_id_histid
+ call r_hms_aero_parms
+*
+* register FPP variables
+*
+ call r_hms_fpp_params
+*
+* register bypass switches
+*
+
+ call r_hms_bypass_switches
+
+*
+* register hms statistics
+*
+
+ call r_hms_statistics
+ call r_hms_pedestals
+*
+ IF(ABORT .or. err.NE.' ') call G_add_path(here,err)
+*
+ RETURN
+ END
diff --git a/HTRACKING/h_report_bad_data.f b/HTRACKING/h_report_bad_data.f
new file mode 100644
index 0000000..9a64435
--- /dev/null
+++ b/HTRACKING/h_report_bad_data.f
@@ -0,0 +1,106 @@
+ SUBROUTINE H_REPORT_BAD_DATA(lunout,ABORT,errmsg)
+
+*--------------------------------------------------------
+*
+* Purpose and Methods: Output warnings for possible hardware problems
+* in file 'bad<runnum>.txt' (unit=lunout)
+*
+* NOTE: Nothing should be written to the file unless there is a warning
+* to be reported. (i.e. check for error messages before writing
+* headers.
+*
+* Required Input BANKS:
+*
+* Output: ABORT - success or failure
+* : err - reason for failure, if any
+*
+* author: John Arrington
+* created: 8/17/95
+* $Log: h_report_bad_data.f,v $
+* Revision 1.3 1996/08/30 20:34:49 saw
+* (JRA) Don't report difference between input pedestals and pedestals from
+* pedestal events
+*
+* Revision 1.2 1996/01/16 21:56:20 cdaq
+* (JRA) Warn when pedestals change too much
+*
+* Revision 1.1 1995/08/31 14:44:52 cdaq
+* Initial revision
+*
+*--------------------------------------------------------
+
+ IMPLICIT NONE
+*
+ character*17 here
+ parameter (here= 'H_REPORT_BAD_DATA')
+*
+ logical ABORT
+ character*(*) errmsg
+*
+ include 'hms_data_structures.cmn'
+ include 'hms_calorimeter.cmn'
+ include 'hms_pedestals.cmn'
+ include 'hms_cer_parms.cmn'
+
+ integer*4 lunout
+ integer*4 ind
+ integer*4 icol,irow
+
+ character*4 pln(hnum_scin_planes)
+ character*2 cnt(hnum_scin_elements)
+ character*1 sgn(2)
+ character*2 col(hmax_cal_columns)
+ character*2 row(hmax_cal_rows)
+ character*5 mir(hcer_num_mirrors)
+ save
+
+ data pln/'hS1X','hS1Y','hS2X','hS2Y'/
+ data cnt/'01','02','03','04','05','06','07','08',
+ & '09','10','11','12','13','14','15','16'/
+ data sgn/'+','-'/
+
+ data col/'hA','hB','hC','hD'/
+ data row/'01','02','03','04','05','06','07',
+ & '08','09','10','11','12','13'/
+
+ data mir/'hcer1','hcer2'/
+
+! Remove reporting of difference between pedestals and input pedestals
+! from parameter files now that we always use the pedestal events.
+!
+* report channels where the pedestal analysis differs from the param file.
+! if ((hhodo_num_ped_changes+hcal_num_ped_changes+hcer_num_ped_changes)
+! & .gt. 0) then
+!
+! write(lunout,*) ' HMS detectors with large (>2sigma) pedestal changes'
+! write(lunout,*)
+! write(lunout,*) ' Signal Pedestal change(new-old)'
+!
+! if (hhodo_num_ped_changes.gt.0) then
+! do ind=1,hhodo_num_ped_changes
+! write(lunout,'(2x,a4,a2,a1,f9.1)')
+! $ pln(hhodo_changed_plane(ind))
+! $ ,cnt(hhodo_changed_element(ind))
+! $ ,sgn(hhodo_changed_sign(ind)),hhodo_ped_change(ind)
+! enddo
+! endif
+!
+! if (hcal_num_ped_changes.gt.0) then
+! do ind=1,hcal_num_ped_changes
+! icol=(hcal_changed_block(ind)-0.5)/hmax_cal_rows + 1
+! irow=hcal_changed_block(ind)-hmax_cal_rows*(icol-1)
+! write(lunout,'(4x,a2,a2,f9.1)') col(icol),row(irow),
+! & hcal_ped_change(ind)
+! enddo
+! endif
+!
+! if (hcer_num_ped_changes.gt.0) then
+! do ind=1,hcer_num_ped_changes
+! write(lunout,'(3x,a4,f9.1)') mir(hcer_changed_tube(ind)),
+! & hcer_ped_change(ind)
+! enddo
+! endif
+! endif ! are there pedestal changes to report?
+
+ return
+ end
diff --git a/HTRACKING/h_satcorr.f b/HTRACKING/h_satcorr.f
new file mode 100644
index 0000000..b1cb0cc
--- /dev/null
+++ b/HTRACKING/h_satcorr.f
@@ -0,0 +1,80 @@
+ SUBROUTINE H_SATCORR(ABORT,err)
+*--------------------------------------------------------
+*-
+*- Purpose and Methods : Correct delta or other reconstructed physics variables
+*- for magnet saturation effects
+*-
+*- to decoded information
+*-
+*- Required Input BANKS HMS_FOCAL_PLANE
+*- HMS_TARGET
+*-
+*- Output BANKS HMS_PHYSICS_R4
+*- HMS_PHYSICS_I4
+*-
+*- Output: ABORT - success or failure
+*- : err - reason for failure, if any
+*-
+*- Created 24-JUN-1998 J. Volmer
+*- Dummy Shell routine
+* $Log: h_satcorr.f,v $
+* Revision 1.2 2003/12/19 19:53:15 jones
+* Add fit to 2003 data by T. Horn which should be applicable to data the
+* using field00.f or later to set magnets.
+* Change meaning of parameter enable_hms_satcorr.
+* enable_hms_satcorr = 2000 means use T.Horn parametrization
+* enable_hms_satcorr = 1999 means use old parametrization
+*
+* Revision 1.1 1999/02/10 18:34:42 csa
+* Initial revision
+*
+*
+* Revision 1.1 1994/02/19 06:16:08 cdaq
+* Initial revision
+*
+*-
+*-
+*--------------------------------------------------------
+ IMPLICIT NONE
+ SAVE
+*
+ character*9 here
+ parameter (here= 'H_SATCORR')
+*
+ logical ABORT
+ character*(*) err
+ integer ierr
+*
+ include 'gen_data_structures.cmn'
+ INCLUDE 'hms_data_structures.cmn'
+ INCLUDE 'gen_constants.par'
+ INCLUDE 'gen_units.par'
+*
+* local variables
+*
+ REAL*4 p0corr
+
+*--------------------------------------------------------
+*
+ ierr=0
+ ABORT=.FALSE.
+
+ p0corr=0.
+
+ if(genable_hms_satcorr.eq. 1999) then
+ if (hpcentral.lt.3.215) p0corr=-1.1298*(hpcentral-3.215)**2
+ hsdelta = hsdelta + p0corr*hsxp_fp
+ else if(genable_hms_satcorr .eq. 2000) then
+ p0corr = 0.82825*hpcentral-1.223
+ hsdelta = hsdelta + p0corr*hsxp_fp
+ endif
+
+* hsdelta = hsdelta + 0.
+
+ ABORT= ierr.ne.0 .or. ABORT
+
+ return
+ end
+
+
+
diff --git a/HTRACKING/h_scin_eff.f b/HTRACKING/h_scin_eff.f
new file mode 100644
index 0000000..b688ab8
--- /dev/null
+++ b/HTRACKING/h_scin_eff.f
@@ -0,0 +1,251 @@
+ SUBROUTINE H_SCIN_EFF(ABORT,errmsg)
+*--------------------------------------------------------
+*-
+*- Purpose and Methods : Analyze scintillator information for each track
+*-
+*- Required Input BANKS HMS_SCIN_TOF
+*- GEN_DATA_STRUCTURES
+*-
+*- Output: ABORT - success or failure
+*- : err - reason for failure, if any
+*-
+* author: John Arrington
+* created: 2/13/95
+*
+* h_scin_eff calculates efficiencies for the hodoscope.
+*
+* $Log: h_scin_eff.f,v $
+* Revision 1.8 2003/09/05 21:08:34 jones
+* Merge in online03 changes plus changes from E. Christy and E. Segbefia to
+* account for multiple scattering introduced by the aerogel (mkj)
+*
+* Revision 1.7.2.2 2003/04/03 14:02:13 cdaq
+* Remove extra enddo (JRA)
+*
+* Revision 1.7.2.1 2003/04/02 22:26:55 cdaq
+* added some extra scint. effic calculations (from oct 1999 online) - JRA
+*
+* Revision 1.7 2002/10/02 13:42:43 saw
+* Check that user hists are defined before filling
+*
+* Revision 1.6 1996/01/16 21:56:40 cdaq
+* (JRA) Fix typos
+*
+* Revision 1.5 1995/08/31 14:44:42 cdaq
+* (JRA) Fill dpos (pos. track - pos. hit) histograms
+*
+* Revision 1.4 1995/07/19 19:03:27 cdaq
+* (SAW) Put nint around some things for Ultrix compat. Put h in front of
+* various *good variables.
+*
+* Revision 1.3 1995/05/22 19:39:26 cdaq
+* (SAW) Split gen_data_data_structures into gen, hms, sos, and coin parts"
+*
+* Revision 1.2 1995/05/11 20:27:21 cdaq
+* (JRA) Add position calibration variables
+*
+* Revision 1.1 1995/02/23 13:31:41 cdaq
+* Initial revision
+*
+*--------------------------------------------------------
+ IMPLICIT NONE
+*
+ character*50 here
+ parameter (here= 'H_SCIN_EFF')
+*
+ logical ABORT
+ character*(*) errmsg
+*
+ INCLUDE 'hms_data_structures.cmn'
+ INCLUDE 'gen_constants.par'
+ INCLUDE 'gen_units.par'
+ include 'hms_scin_parms.cmn'
+ include 'hms_scin_tof.cmn'
+ include 'hms_statistics.cmn'
+ include 'hms_id_histid.cmn'
+ include 'hms_calorimeter.cmn'
+
+ integer pln,cnt,pln2
+ integer hit_cnt(hnum_scin_planes)
+ integer nhit,hitplane(hnum_scin_planes),check_hit(hnum_scin_planes)
+ real dist, histval
+ real hit_pos(hnum_scin_planes),hit_dist(hnum_scin_planes)
+ logical lookat(hnum_scin_planes)
+ real xatback,yatback
+
+ logical good_tdc_oneside(hnum_scin_planes)
+ logical good_tdc_bothsides(hnum_scin_planes)
+ logical otherthreehit
+
+ save
+
+* find counters on track, and distance from center.
+
+ do pln=1,hnum_scin_planes
+ lookat(pln) = .false.
+ check_hit(pln) = 2
+ enddo
+
+ if (hschi2perdeg.le.hstat_maxchisq) hstat_numevents=hstat_numevents+1
+
+ hit_pos(1)=hsx_fp + hsxp_fp*(hscin_1x_zpos+0.5*hscin_1x_dzpos)
+ hit_cnt(1)=nint((hit_pos(1)-hhodo_center(1,1))/hscin_1x_spacing)+1
+ hit_cnt(1)=max(min(hit_cnt(1),nint(hnum_scin_counters(1))),1)
+ hit_dist(1)=hit_pos(1)-(hscin_1x_spacing*(hit_cnt(1)-1)+hhodo_center(1,1))
+
+ hit_pos(2)=hsy_fp + hsyp_fp*(hscin_1y_zpos+0.5*hscin_1y_dzpos)
+ hit_cnt(2)=nint((hhodo_center(2,1)-hit_pos(2))/hscin_1y_spacing)+1
+ hit_cnt(2)=max(min(hit_cnt(2),nint(hnum_scin_counters(2))),1)
+ hit_dist(2)=hit_pos(2)-(hhodo_center(2,1)-hscin_1y_spacing*(hit_cnt(2)-1))
+
+ hit_pos(3)=hsx_fp + hsxp_fp*(hscin_2x_zpos+0.5*hscin_2x_dzpos)
+ hit_cnt(3)=nint((hit_pos(3)-hhodo_center(3,1))/hscin_2x_spacing)+1
+ hit_cnt(3)=max(min(hit_cnt(3),nint(hnum_scin_counters(3))),1)
+ hit_dist(3)=hit_pos(3)-(hscin_2x_spacing*(hit_cnt(3)-1)+hhodo_center(3,1))
+
+ hit_pos(4)=hsy_fp + hsyp_fp*(hscin_2y_zpos+0.5*hscin_2y_dzpos)
+ hit_cnt(4)=nint((hhodo_center(4,1)-hit_pos(4))/hscin_2y_spacing)+1
+ hit_cnt(4)=max(min(hit_cnt(4),nint(hnum_scin_counters(4))),1)
+ hit_dist(4)=hit_pos(4)-(hhodo_center(4,1)-hscin_2y_spacing*(hit_cnt(4)-1))
+
+ do pln=1,hnum_scin_planes
+ good_tdc_oneside(pln) = .false.
+ good_tdc_bothsides(pln) = .false.
+ enddo
+
+
+* Fill dpos (pos. track - pos. hit) histograms
+ do nhit=1,hscin_tot_hits
+ pln=hscin_plane_num(nhit)
+ cnt=hscin_counter_num(nhit)
+ histval = hhodo_center(pln,hscin_counter_num(nhit))-hit_pos(pln)
+ if(hidscindpos(pln).gt.0) call hf1(hidscindpos(pln),histval,1.)
+ if(cnt.EQ.hit_cnt(pln)) check_hit(pln) = 0
+ if(abs(cnt-hit_cnt(pln)).EQ.1.AND.check_hit(pln).NE.0)
+ & check_hit(pln) = 1
+ enddo
+
+* Record position differences between track and center of scin. and
+* increment 'should have hit' counters
+ do pln=1,hnum_scin_planes
+ cnt=hit_cnt(pln)
+ dist=hit_dist(pln)
+ if(abs(dist).le.hstat_slop .and. !hit in middle of scin.
+ & hschi2perdeg.le.hstat_maxchisq.and.(hsshtrk.GE.0.05)) then
+ hstat_trk(pln,cnt)=hstat_trk(pln,cnt)+1
+ lookat(pln) = .true.
+ endif
+ hitplane(pln) = 0
+ enddo
+
+ do nhit=1,hscin_tot_hits
+ cnt=hscin_counter_num(nhit)
+ pln=hscin_plane_num(nhit)
+
+* Record the hits as a "didhit" if track is near center of scintillator,
+* the chisquared of the track is good, and it is the 1st "didhit" in that
+* plane.
+
+cc write(6,*)lookat(pln),hscin_tot_hits,nhit,pln,cnt,hit_cnt(pln),
+cc & hitplane(pln),abs(cnt-hit_cnt(pln))
+
+
+ if(abs(hit_dist(pln)).le.hstat_slop.and.(abs(cnt-hit_cnt(pln))
+ & .LE.check_hit(pln)).and.(hsshtrk.GE.0.05).
+ & and.hitplane(pln).EQ.0.and.hschi2perdeg.le.hstat_maxchisq) then
+
+ hitplane(pln) = hitplane(pln) + 1
+
+ if (hgood_tdc_pos(hsnum_fptrack,nhit)) then
+ if (hgood_tdc_neg(hsnum_fptrack,nhit)) then !both fired
+ hstat_poshit(pln,hit_cnt(pln))=hstat_poshit(pln,hit_cnt(pln))+1
+ hstat_neghit(pln,hit_cnt(pln))=hstat_neghit(pln,hit_cnt(pln))+1
+ hstat_andhit(pln,hit_cnt(pln))=hstat_andhit(pln,hit_cnt(pln))+1
+ hstat_orhit(pln,hit_cnt(pln))=hstat_orhit(pln,hit_cnt(pln))+1
+ else !pos fired
+ hstat_poshit(pln,hit_cnt(pln))=hstat_poshit(pln,hit_cnt(pln))+1
+ hstat_orhit(pln,hit_cnt(pln))=hstat_orhit(pln,hit_cnt(pln))+1
+ endif
+ else !no pos tdc
+ if (hgood_tdc_neg(hsnum_fptrack,nhit)) then !neg fired
+ hstat_neghit(pln,hit_cnt(pln))=hstat_neghit(pln,hit_cnt(pln))+1
+ hstat_orhit(pln,hit_cnt(pln))=hstat_orhit(pln,hit_cnt(pln))+1
+ endif !if neg tdc fired.
+ endif !if pos tdc fired.
+
+ endif !if hit was on good track.
+
+
+* Increment pos/neg/both fired. Track indepenant, so no chisquared cut (but
+* note that only scintillators on the track are examined.
+
+ if (hgood_tdc_pos(hsnum_fptrack,nhit)) then
+ if (hgood_tdc_neg(hsnum_fptrack,nhit)) then !both fired
+ hbothgood(pln,cnt)=hbothgood(pln,cnt)+1
+ else !pos fired
+ hposgood(pln,cnt)=hposgood(pln,cnt)+1
+ endif
+ else
+ if (hgood_tdc_neg(hsnum_fptrack,nhit)) then !neg fired
+ hneggood(pln,cnt)=hneggood(pln,cnt)+1
+ endif
+ endif
+
+* Determine if one or both PMTs had a good tdc.
+ if (hgood_tdc_pos(hsnum_fptrack,nhit) .and.
+ & hgood_tdc_neg(hsnum_fptrack,nhit) ) good_tdc_bothsides(pln)=.true.
+ if (hgood_tdc_pos(hsnum_fptrack,nhit) .or.
+ & hgood_tdc_neg(hsnum_fptrack,nhit) ) good_tdc_oneside(pln)=.true.
+
+ enddo !loop over hsnum_pmt_hit
+
+* For each plane, see of other 3 fired. This means that they were enough
+* to form a 3/4 trigger, and so the fraction of times this plane fired is
+* the plane trigger efficiency. NOTE: we only require a TDC hit, not a
+* TDC hit within the SCIN 3/4 trigger window, so high rates will make
+* this seem better than it is. Also, make sure we're not near the edge
+* of the hodoscope (at the last plane), using the same hhodo_slop param. as for h_tof.f
+* NOTE ALSO: to make this check simpler, we are assuming that all planes
+* have identical active areas. y_scin = y_cent + y_offset, so shift track
+* position by offset for comparing to edges.
+
+ xatback = hsx_fp+hsxp_fp*hscin_2y_zpos - hscin_2x_offset
+ yatback = hsy_fp+hsyp_fp*hscin_2y_zpos - hscin_2y_offset
+
+ if ( xatback.lt.(hscin_2y_bot -2.*hhodo_slop(3)) .and.
+ & xatback.gt.(hscin_2y_top +2.*hhodo_slop(3)) .and.
+ & yatback.lt.(hscin_2x_left -2.*hhodo_slop(3)) .and.
+ & yatback.gt.(hscin_2x_right+2.*hhodo_slop(3))) then
+
+ do pln = 1,hnum_scin_planes
+ otherthreehit = .true.
+ do pln2 = 1,hnum_scin_planes !see of one of the others missed or pln2=pln
+ if (.not.(good_tdc_bothsides(pln2) .or. pln2.eq.pln)) then
+ otherthreehit = .false.
+ endif
+ enddo
+ if (otherthreehit) then
+ htrig_hodoshouldflag(pln) = .true.
+ if (good_tdc_bothsides(pln)) then
+ htrig_hododidflag(pln) = .true.
+ else
+ htrig_hododidflag(pln) = .false.
+ endif
+ else
+ htrig_hodoshouldflag(pln) = .false.
+ htrig_hododidflag(pln) = .false.
+ endif
+ enddo
+
+ else !outside of fiducial region
+ do pln=1,hnum_scin_planes
+ htrig_hodoshouldflag(pln) = .false.
+ htrig_hododidflag(pln) = .false.
+ enddo
+ endif
+
+ return
+ end
+
+
+
diff --git a/HTRACKING/h_scin_eff_shutdown.f b/HTRACKING/h_scin_eff_shutdown.f
new file mode 100644
index 0000000..c4efb24
--- /dev/null
+++ b/HTRACKING/h_scin_eff_shutdown.f
@@ -0,0 +1,149 @@
+ SUBROUTINE H_SCIN_EFF_SHUTDOWN(lunout,ABORT,errmsg)
+*--------------------------------------------------------
+*-
+*- Purpose and Methods : Analyze scintillator information for each track
+*-
+*- Required Input BANKS HMS_SCIN_TOF
+*- GEN_DATA_STRUCTURES
+*-
+*- Output: ABORT - success or failure
+*- : err - reason for failure, if any
+*-
+* author: John Arrington
+* created: 2/15/95
+*
+* h_scin_eff calculates efficiencies for the hodoscope.
+* h_scin_eff_shutdown does some final manipulation of the numbers.
+*
+* $Log: h_scin_eff_shutdown.f,v $
+* Revision 1.9 1999/02/23 18:40:48 csa
+* (JRA) Remove hdebugcalcpeds stuff
+*
+* Revision 1.8 1996/08/30 20:35:14 saw
+* (JRA) Cosmetic
+*
+* Revision 1.7 1996/01/16 21:57:27 cdaq
+* (JRA) Add debug control flag around write statements
+*
+* Revision 1.6 1995/08/30 18:14:15 cdaq
+* (JRA) Dump bad counter infomation
+*
+* Revision 1.5 1995/07/19 19:04:02 cdaq
+* (SAW) Move data statement for f2c compatibility
+*
+* Revision 1.4 1995/05/22 19:39:26 cdaq
+* (SAW) Split gen_data_data_structures into gen, hms, sos, and coin parts"
+*
+* Revision 1.3 1995/05/17 13:58:29 cdaq
+* (JRA) Write out list of potential PMT problems
+*
+* Revision 1.2 1995/05/11 20:27:13 cdaq
+* (JRA) Add position calibration variables
+*
+* Revision 1.1 1995/02/23 13:31:36 cdaq
+* Initial revision
+*
+*--------------------------------------------------------
+ IMPLICIT NONE
+*
+ character*19 here
+ parameter (here= 'H_SCIN_EFF_SHUTDOWN')
+*
+ logical ABORT
+ character*(*) errmsg
+*
+ INCLUDE 'hms_data_structures.cmn'
+ INCLUDE 'gen_constants.par'
+ INCLUDE 'gen_units.par'
+ include 'hms_scin_parms.cmn'
+ include 'hms_scin_tof.cmn'
+ include 'hms_statistics.cmn'
+ include 'hms_tracking.cmn'
+
+ logical written_header
+ integer pln,cnt
+ integer lunout
+ real*4 num_real,nhits_real
+ real*4 p1,p2,p3,p4 !prob. of having both tubes fire for planes1-4
+ real*4 p1234,p123,p124,p134,p234 !prob. of having combos fire
+
+ character*4 planename(HNUM_SCIN_PLANES)
+ data planename/'hS1X','hS1Y','hS2X','hS2Y'/
+
+ save
+
+ written_header = .false.
+
+! fill sums over counters
+ do pln=1,hnum_scin_planes
+ hstat_trksum(pln)=0
+ hstat_possum(pln)=0
+ hstat_negsum(pln)=0
+ hstat_andsum(pln)=0
+ hstat_orsum(pln)=0
+ do cnt=1,hnum_scin_counters(pln)
+ num_real=float(max(1,hscin_zero_num(pln,cnt)))
+ hscin_zero_pave(pln,cnt)=float(hscin_zero_pos(pln,cnt))/num_real
+ hscin_zero_nave(pln,cnt)=float(hscin_zero_neg(pln,cnt))/num_real
+ hstat_trksum(pln)=hstat_trksum(pln)+hstat_trk(pln,cnt)
+ hstat_possum(pln)=hstat_possum(pln)+hstat_poshit(pln,cnt)
+ hstat_negsum(pln)=hstat_negsum(pln)+hstat_neghit(pln,cnt)
+ hstat_andsum(pln)=hstat_andsum(pln)+hstat_andhit(pln,cnt)
+ hstat_orsum(pln)=hstat_orsum(pln)+hstat_orhit(pln,cnt)
+*
+* write out list of possible problms
+*
+ nhits_real = max(1.,float(hstat_trk(pln,cnt)))
+ hstat_peff(pln,cnt)=float(hstat_poshit(pln,cnt))/nhits_real
+ hstat_neff(pln,cnt)=float(hstat_neghit(pln,cnt))/nhits_real
+ hstat_oeff(pln,cnt)=float(hstat_orhit(pln,cnt))/nhits_real
+ hstat_aeff(pln,cnt)=float(hstat_andhit(pln,cnt))/nhits_real
+ if (nhits_real .gt. 100.) then !dump bad counter information
+ if (hstat_peff(pln,cnt).le.hstat_mineff) then
+ if (.not.written_header) then
+ write(lunout,*)
+ write(lunout,'(a,f6.3)') ' HMS scintillators with tracking based effic. < '
+ $ ,hstat_mineff
+ written_header = .true.
+ endif
+ write(lunout,'(5x,a4,i2,a,f7.4)') planename(pln),cnt,'+',hstat_peff(pln,cnt)
+ endif
+ if (hstat_neff(pln,cnt).le.hstat_mineff) then
+ if (.not.written_header) then
+ write(lunout,*)
+ write(lunout,'(a,f6.3)') ' HMS scintilators with effic. < '
+ $ ,hstat_mineff
+ written_header = .true.
+ endif
+ write(lunout,'(5x,a4,i2,a,f7.4)') planename(pln),cnt,'-',hstat_neff(pln,cnt)
+ endif
+ endif
+ enddo
+ hstat_poseff(pln)=hstat_possum(pln)/max(1.,float(hstat_trksum(pln)))
+ hstat_negeff(pln)=hstat_negsum(pln)/max(1.,float(hstat_trksum(pln)))
+ hstat_andeff(pln)=hstat_andsum(pln)/max(1.,float(hstat_trksum(pln)))
+ hstat_oreff(pln)=hstat_orsum(pln)/max(1.,float(hstat_trksum(pln)))
+ enddo
+
+ write(lunout,*) ' '
+
+ p1=hstat_andeff(1)
+ p2=hstat_andeff(2)
+ p3=hstat_andeff(3)
+ p4=hstat_andeff(4)
+
+! probability that ONLY the listed planes had triggers
+ p1234= p1*p2*p3*p4
+ p123 = p1*p2*p3*(1.-p4)
+ p124 = p1*p2*(1.-p3)*p4
+ p134 = p1*(1.-p2)*p3*p4
+ p234 = (1.-p1)*p2*p3*p4
+
+ heff_s1 = 1. - ((1.-p1)*(1.-p2))
+ heff_s2 = 1. - ((1.-p3)*(1.-p4))
+ heff_stof=heff_s1 * heff_s2
+ heff_3_of_4=p1234+p123+p124+p134+p234
+ heff_4_of_4=p1234
+
+ return
+ end
diff --git a/HTRACKING/h_select_best_track.f b/HTRACKING/h_select_best_track.f
new file mode 100644
index 0000000..fb74f77
--- /dev/null
+++ b/HTRACKING/h_select_best_track.f
@@ -0,0 +1,116 @@
+ SUBROUTINE H_SELECT_BEST_TRACK(ABORT,err)
+*--------------------------------------------------------
+*-
+*- Purpose and Methods : Select the best track through the HMS
+*-
+*-
+*- Required Input BANKS
+*-
+*- Output BANKS
+*-
+*- Output: ABORT - success or failure
+*- : err - reason for failure, if any
+*-
+*- $Log: h_select_best_track.f,v $
+*- Revision 1.6 2005/03/23 16:33:32 jones
+*- Add new code s_select_best_track_prune.f (P Bosted)
+*-
+*- Revision 1.5 2004/02/26 22:23:17 jones
+*- Add if statement to use subroutine h_select_best_track_using_scin.f
+*- when hsel_using_scin .eq. 1 . Otherwise picks the best track the old
+*- way.
+*-
+*- Revision 1.4 1995/07/19 19:12:22 cdaq
+*- (CC) Fix bug in best chisq finding
+*-
+* Revision 1.3 1995/05/22 19:39:27 cdaq
+* (SAW) Split gen_data_data_structures into gen, hms, sos, and coin parts"
+*
+* Revision 1.2 1995/02/23 13:31:01 cdaq
+* (JRA) Adjust include file ordering
+*
+* Revision 1.1 1995/01/31 21:33:54 cdaq
+* Initial revision
+*-
+*--------------------------------------------------------
+ IMPLICIT NONE
+ SAVE
+*
+ character*50 here
+ parameter (here= 'H_SELECT_BEST_TRACK')
+*
+ logical ABORT
+ character*(*) err
+*
+ INCLUDE 'hms_data_structures.cmn'
+ INCLUDE 'gen_routines.dec'
+ INCLUDE 'gen_constants.par'
+ INCLUDE 'gen_units.par'
+ INCLUDE 'hms_physics_sing.cmn'
+ INCLUDE 'hms_calorimeter.cmn'
+ INCLUDE 'hms_scin_parms.cmn'
+ INCLUDE 'hms_scin_tof.cmn'
+ INCLUDE 'hms_tracking.cmn'
+c
+*
+* local variables
+ integer*4 goodtrack,track,trk,savegood
+ logical first
+ real*4 chi2perdeg,chi2min
+c
+ integer*4 i,j
+ data first /.true./
+*--------------------------------------------------------
+*
+ ABORT= .FALSE.
+ err= ' '
+* Need to test to chose the best track
+ HSNUM_FPTRACK = 0
+ HSNUM_TARTRACK = 0
+
+c
+ if ( hsel_using_prune.eq. 1) then
+ if (first) write(*,*) ' HMS track selection using Pruning'
+ first = .false.
+ call H_SELECT_BEST_TRACK_PRUNE(ABORT,err)
+ return
+ endif
+
+ if ( hsel_using_scin .eq. 1) then
+ if (first) write(*,*) ' HMS track selection using scintillators'
+ first = .false.
+ call H_SELECT_BEST_TRACK_USING_SCIN(ABORT,err)
+ else
+c
+ if( HNTRACKS_FP.GT. 0) then
+ if (first) write(*,*) ' HMS track selection using chi-squared'
+ first = .false.
+ chi2min= 1e10
+ goodtrack = 0
+ do track = 1, HNTRACKS_FP
+
+ if( HNFREE_FP(track).ge. hsel_ndegreesmin) then
+ chi2perdeg = HCHI2_FP(track)/FLOAT(HNFREE_FP(track))
+ if(chi2perdeg .lt. chi2min) then
+* simple particle id tests
+ if( ( HDEDX(track,1) .gt. hsel_dedx1min) .and.
+ & ( HDEDX(track,1) .lt. hsel_dedx1max) .and.
+ & ( HBETA(track) .gt. hsel_betamin) .and.
+ & ( HBETA(track) .lt. hsel_betamax) .and.
+ & ( HTRACK_ET(track) .gt. hsel_etmin) .and.
+ & ( HTRACK_ET(track) .lt. hsel_etmax)) then
+ goodtrack = track
+ chi2min = chi2perdeg
+ endif ! end test on track id
+ endif ! end test on lower chisq
+ endif ! end test on minimum number of degrees of freedom
+ enddo ! end loop on track
+ HSNUM_TARTRACK = goodtrack
+ HSNUM_FPTRACK = goodtrack
+ if(goodtrack.eq.0) return ! return if no valid tracks
+ endif
+c
+ endif
+c
+ return
+ end
diff --git a/HTRACKING/h_select_best_track_prune.f b/HTRACKING/h_select_best_track_prune.f
new file mode 100644
index 0000000..06d58b9
--- /dev/null
+++ b/HTRACKING/h_select_best_track_prune.f
@@ -0,0 +1,309 @@
+ SUBROUTINE H_SELECT_BEST_TRACK_PRUNE(ABORT,err)
+*--------------------------------------------------------
+*-
+*- Purpose and Methods : Select the best track through the HMS
+*-
+*-
+*- Required Input BANKS
+*-
+*- Output BANKS
+*-
+*- Output: ABORT - success or failure
+*- : err - reason for failure, if any
+*-
+*- $Log: h_select_best_track_prune.f,v $
+*- Revision 1.1.8.1 2007/09/10 20:28:01 pcarter
+*- Implemented changes to allow compilation on RHEL 3,4,5 and MacOSX
+*-
+*- Revision 1.1 2005/03/23 16:33:32 jones
+*- Add new code s_select_best_track_prune.f (P Bosted)
+*-
+*
+* Revision 1.1 2005/03/08 bosted
+* Initial revision
+*-
+*--------------------------------------------------------
+ IMPLICIT NONE
+ SAVE
+*
+ character*50 here
+ parameter (here= 'H_SELECT_BEST_TRACK_PRUNE')
+*
+ logical ABORT
+ character*(*) err
+*
+ INCLUDE 'hms_data_structures.cmn'
+ INCLUDE 'gen_routines.dec'
+ INCLUDE 'gen_constants.par'
+ INCLUDE 'gen_units.par'
+ INCLUDE 'hms_physics_sing.cmn'
+ INCLUDE 'hms_calorimeter.cmn'
+ INCLUDE 'hms_scin_parms.cmn'
+ INCLUDE 'hms_scin_tof.cmn'
+ INCLUDE 'hms_tracking.cmn'
+c
+*
+* local variables
+ integer*4 goodtrack,track,ngood,reject(1000),trk
+ logical first,keep(1000)
+ real*4 chi2perdeg,chi2min,betap,p
+c
+c integer*4 i,j
+ data first /.true./
+*--------------------------------------------------------
+*
+ ABORT= .FALSE.
+ err= ' '
+* Need to test to chose the best track
+ HSNUM_FPTRACK = 0
+ HSNUM_TARTRACK = 0
+
+ if (first) then
+ write(*,*) ' HMS track selection using pruning method'
+ first = .false.
+! Make sure limits are reasonable
+ hprune_xp = max(0.08, hprune_xp)
+ hprune_yp = max(0.04, hprune_yp)
+ hprune_ytar = max(4.0, hprune_ytar)
+ hprune_delta = max(13.0, hprune_delta)
+ hprune_beta = max(0.1, hprune_beta)
+ hprune_df = max(1, hprune_df)
+ hprune_chibeta= max(2., hprune_chibeta)
+ hprune_fptime= max(5., hprune_fptime)
+ hprune_npmt = max(6, hprune_npmt)
+ write(*,'(1x,'' using following HMS limits''/
+ > 1x,''abs(xptar)<'',f6.3/
+ > 1x,''abs(yptar)<'',f6.3/
+ > 1x,''abs(ytar)<'',f6.3/
+ > 1x,''abs(delta)<'',f6.3/
+ > 1x,''abs(beta-betap)<'',f6.3/
+ > 1x,''ndegfreedom trk>='',i2/
+ > 1x,''beta chisq>'',f6.1/
+ > 1x,''num PMT hits >='',i3/
+ > 1x,''abs(fptime-hstart_time_center)<'',f6.1)')
+ > hprune_xp,hprune_yp,hprune_ytar,hprune_delta,
+ > hprune_beta,hprune_df,hprune_chibeta,hprune_npmt,hprune_fptime
+ endif
+c
+c
+ if( HNTRACKS_FP.GT. 0) then
+ chi2min= 1e10
+ goodtrack = 0
+
+! Initialize all tracks to be good
+ do track = 1, HNTRACKS_FP
+ keep(track) = .true.
+ reject(track)=0
+ enddo
+
+! Prune on xptar
+ ngood=0
+ do track = 1, HNTRACKS_FP
+ if( abs(hxp_tar(track)) .lt. hprune_xp .and. keep(track)) then
+ ngood = ngood + 1
+ endif
+ enddo
+ if(ngood.gt.0) then
+ do track = 1, HNTRACKS_FP
+ if( abs(hxp_tar(track)) .ge. hprune_xp) then
+ keep(track) = .false.
+ reject(track) = reject(track) + 1
+ endif
+ enddo
+ endif
+
+! Prune on yptar
+ ngood=0
+ do track = 1, HNTRACKS_FP
+ if( abs(hyp_tar(track)) .lt. hprune_yp .and. keep(track)) then
+ ngood = ngood + 1
+ endif
+ enddo
+ if(ngood.gt.0) then
+ do track = 1, HNTRACKS_FP
+ if( abs(hyp_tar(track)) .ge. hprune_yp) then
+ keep(track) = .false.
+ reject(track) = reject(track) + 2
+ endif
+ enddo
+ endif
+
+! Prune on ytar
+ ngood=0
+ do track = 1, HNTRACKS_FP
+ if( abs(hy_tar(track)) .lt. hprune_ytar .and. keep(track)) then
+ ngood = ngood + 1
+ endif
+ enddo
+ if(ngood.gt.0) then
+ do track = 1, HNTRACKS_FP
+ if( abs(hy_tar(track)) .ge. hprune_ytar) then
+ keep(track) = .false.
+ reject(track) = reject(track) + 10
+ endif
+ enddo
+ endif
+
+! Prune on delta
+ ngood=0
+ do track = 1, HNTRACKS_FP
+ if( abs(hdelta_tar(track)) .lt. hprune_delta
+ > .and. keep(track)) then
+ ngood = ngood + 1
+ endif
+ enddo
+ if(ngood.gt.0) then
+ do track = 1, HNTRACKS_FP
+ if(abs(hdelta_tar(track)) .ge. hprune_delta) then
+ keep(track) = .false.
+ reject(track) = reject(track) + 20
+ endif
+ enddo
+ endif
+
+! Prune on beta
+ ngood=0
+ do track = 1, HNTRACKS_FP
+ p = hp_tar(track)
+ betap = p/sqrt(p*p+hpartmass*hpartmass)
+ if( abs(hbeta(track)-betap) .lt. hprune_beta
+ > .and. keep(track)) then
+ ngood = ngood + 1
+ endif
+ enddo
+ if(ngood.gt.0) then
+ do track = 1, HNTRACKS_FP
+ p = hp_tar(track)
+ betap = p/sqrt(p*p+hpartmass*hpartmass)
+ if(abs(hbeta(track)-betap) .ge. hprune_beta) then
+ keep(track) = .false.
+ reject(track) = reject(track) + 100
+ endif
+ enddo
+ endif
+
+! Prune on deg. freedom for track chisq
+ ngood=0
+ do track = 1, HNTRACKS_FP
+ if(HNFREE_FP(track) .ge. hprune_df .and. keep(track)) then
+ ngood = ngood + 1
+ endif
+ enddo
+ if(ngood.gt.0) then
+ do track = 1, HNTRACKS_FP
+ if(HNFREE_FP(track) .lt. hprune_df) then
+ keep(track) = .false.
+ reject(track) = reject(track) + 200
+ endif
+ enddo
+ endif
+
+! Prune on num pmt hits
+ ngood=0
+ do track = 1, HNTRACKS_FP
+ if(hnum_pmt_hit(track) .ge. hprune_npmt.and. keep(track)) then
+ ngood = ngood + 1
+ endif
+ enddo
+ if(ngood.gt.0) then
+ do track = 1, HNTRACKS_FP
+ if(hnum_pmt_hit(track) .lt. hprune_npmt) then
+ keep(track) = .false.
+ reject(track) = reject(track) + 100000
+ endif
+ enddo
+ endif
+
+! Prune on beta chisqr
+ ngood=0
+ do track = 1, HNTRACKS_FP
+ if(hbeta_chisq(track) .lt. hprune_chibeta .and.
+ > hbeta_chisq(track) .gt. 0.01 .and. keep(track)) then
+ ngood = ngood + 1
+ endif
+ enddo
+ if(ngood.gt.0) then
+ do track = 1, HNTRACKS_FP
+ if(hbeta_chisq(track) .ge. hprune_chibeta .or.
+ > hbeta_chisq(track) .le. 0.01) then
+ keep(track) = .false.
+ reject(track) = reject(track) + 1000
+ endif
+ enddo
+ endif
+
+! Prune on fptime
+ ngood=0
+ do track = 1, HNTRACKS_FP
+ if( abs(htime_at_fp(track)-hstart_time_center).lt.hprune_fptime
+ > .and. keep(track)) then
+ ngood = ngood + 1
+ endif
+ enddo
+ if(ngood.gt.0) then
+ do track = 1, HNTRACKS_FP
+ if(abs(htime_at_fp(track)-hstart_time_center).ge.
+ > hprune_fptime) then
+ keep(track) = .false.
+ reject(track) = reject(track) + 2000
+ endif
+ enddo
+ endif
+
+! Prune on Y2 being hit
+ ngood=0
+ do track = 1, HNTRACKS_FP
+ if(hgood_plane_time(track,4).and. keep(track)) ngood = ngood + 1
+ enddo
+ if(ngood.gt.0) then
+ do track = 1, HNTRACKS_FP
+ if(.not.hgood_plane_time(track,4)) then
+ keep(track) = .false.
+ reject(track) = reject(track) + 10000
+ endif
+ enddo
+ endif
+
+! Prune on X2 being hit
+ ngood=0
+ do track = 1, HNTRACKS_FP
+ if(hgood_plane_time(track,3).and. keep(track)) ngood = ngood + 1
+ enddo
+ if(ngood.gt.0) then
+ do track = 1, HNTRACKS_FP
+ if(.not.hgood_plane_time(track,3)) then
+ keep(track) = .false.
+ reject(track) = reject(track) + 20000
+ endif
+ enddo
+ endif
+
+
+! Pick track with best chisq if more than one track passed prune tests
+ goodtrack = 1
+ do track = 1, HNTRACKS_FP
+ chi2perdeg = HCHI2_FP(track)/max(1.,FLOAT(HNFREE_FP(track)))
+ if(chi2perdeg .lt. chi2min .and. keep(track)) then
+ goodtrack = track
+ chi2min = chi2perdeg
+ endif
+ enddo
+ HSNUM_TARTRACK = goodtrack
+ HSNUM_FPTRACK = goodtrack
+ endif
+! for debugging
+ if( HNTRACKS_FP.GT. 100) then
+ write(*,'(/)')
+ do trk = 1, HNTRACKS_FP
+ write(*,'(3i3,4L2,7f6.1,L2,i9)') trk,HNFREE_FP(trk),
+ > hnum_pmt_hit(trk),
+ > hgood_plane_time(trk,1),hgood_plane_time(trk,3),
+ > hgood_plane_time(trk,2),hgood_plane_time(trk,4),
+ > htime_at_fp(trk),hbeta(trk),hbeta_chisq(trk),
+ > hdelta_tar(trk),hy_tar(trk),hxp_tar(trk),hyp_tar(trk),
+ > keep(trk),reject(trk)
+ enddo
+ write(*,'(1x,''good trk='',2i4)') goodtrack
+ endif
+ return
+ end
diff --git a/HTRACKING/h_select_best_track_using_scin.f b/HTRACKING/h_select_best_track_using_scin.f
new file mode 100644
index 0000000..f22b894
--- /dev/null
+++ b/HTRACKING/h_select_best_track_using_scin.f
@@ -0,0 +1,214 @@
+ SUBROUTINE H_SELECT_BEST_TRACK_USING_SCIN(ABORT,err)
+*--------------------------------------------------------
+*-
+*- Purpose and Methods : Select the best track through the HMS
+*- by see which track is closest to S2y
+*- or if no S2y then use closest to S2x
+*- if neither than smallest chi-squared.
+*-
+*- Required Input BANKS
+*-
+*- Output BANKS
+*-
+*- Output: ABORT - success or failure
+*- : err - reason for failure, if any
+*-
+*-
+*--------------------------------------------------------
+ IMPLICIT NONE
+ SAVE
+*
+ character*50 here
+ parameter (here= 'H_SELECT_BEST_TRACK')
+*
+ logical ABORT
+ character*(*) err
+*
+ INCLUDE 'hms_data_structures.cmn'
+ INCLUDE 'gen_routines.dec'
+ INCLUDE 'gen_constants.par'
+ INCLUDE 'gen_units.par'
+ INCLUDE 'hms_physics_sing.cmn'
+ INCLUDE 'hms_calorimeter.cmn'
+ INCLUDE 'hms_scin_parms.cmn'
+ INCLUDE 'hms_scin_tof.cmn'
+ INCLUDE 'hms_tracking.cmn'
+
+*
+* local variables
+ integer*4 goodtrack,track,i,j
+ real*4 chi2perdeg,chi2min
+
+ integer pln,cnt
+ integer hit_cnt(hnum_scin_planes)
+ integer nhit,zz,t
+ real*4 y2dmin,x2dmin,zap
+ real*4 hit_pos(hnum_scin_planes),hit_dist(hnum_scin_planes)
+ real*4 stub_x(HNTRACKS_MAX),stub_y(HNTRACKS_MAX)
+ real*4 y2d(HNTRACKS_MAX),x2d(HNTRACKS_MAX)
+*--------------------------------------------------------
+*
+ ABORT= .FALSE.
+ err= ' '
+* Need to test to chose the best track
+ HSNUM_FPTRACK = 0
+ HSNUM_TARTRACK = 0
+ if( HNTRACKS_FP.GT. 0) then !!! (1) !!!
+ chi2min= 1e10
+ goodtrack = 0
+ y2dmin=100.
+ x2dmin=100.
+ zap=0.
+ do track = 1, HNTRACKS_FP
+ if( HNFREE_FP(track).ge. hsel_ndegreesmin) then !!! (2) !!!
+ chi2perdeg = HCHI2_FP(track)/FLOAT(HNFREE_FP(track))
+* simple particle id tests
+ if(( HDEDX(track,1).gt.hsel_dedx1min).and. !!! (3) !!!
+ & ( HDEDX(track,1).lt.hsel_dedx1max).and.
+ & ( HBETA(track).gt.hsel_betamin).and.
+ & ( HBETA(track).lt.hsel_betamax).and.
+ & ( HTRACK_ET(track) .gt. hsel_etmin) .and.
+ & ( HTRACK_ET(track) .lt. hsel_etmax)) then
+*first, fill the arrays of which scins were hit
+ do i=1,4
+ do j=1,hscin_1x_nr
+ hscinhit(i,j)=0
+ enddo
+ enddo
+ do i=1,hscin_tot_hits
+ hscinhit(hscin_plane_num(i),hscin_counter_num(i))=1
+ enddo
+c
+ hit_pos(4)=hy_fp(track) + hyp_fp(track)*(hscin_2y_zpos+0.5*hscin_2y_dzpos)
+ hit_cnt(4)=nint((hhodo_center(4,1)-hit_pos(4))/hscin_2y_spacing)+1
+ hit_cnt(4)=max(min(hit_cnt(4),nint(hnum_scin_counters(4))),1)
+ hit_dist(4)=hit_pos(4)-(hhodo_center(4,1)-hscin_2y_spacing*(hit_cnt(4)-1))
+
+** hhodo_center(4.1) = 31.35
+** hscin_2y_spacing = 7.5
+** hnum_scin_counters(4) = 10
+** hscin_2y_zpos = 318.51
+** hscin_2y_dzpos = 2.12
+
+ if(hntracks_fp.gt.1) then !!! (4) !!!
+ zap=0.
+ t=0.
+ do j=1,10
+ if(hscinhit(4,j).eq.1) then
+ y2d(track)=abs(hit_cnt(4)-j)
+ t=t+1
+ if(t.eq.1) zap=y2d(track)
+
+ if(t.eq.2.and.y2d(track).lt.zap) then
+ zap=y2d(track)
+ endif
+ if(t.eq.3.and.y2d(track).lt.zap) then
+ zap=y2d(track)
+ endif
+ if(t.eq.4.and.y2d(track).lt.zap) then
+ zap=y2d(track)
+ endif
+ if(t.eq.5.and.y2d(track).lt.zap) then
+ zap=y2d(track)
+ endif
+ if(t.eq.6.and.y2d(track).lt.zap) then
+ zap=y2d(track)
+ endif
+
+ endif
+ enddo
+ y2d(track)=zap
+ endif !!! (4) !!!
+
+ if(hntracks_fp.eq.1) y2d(track)=0.
+
+ hit_pos(3)=hx_fp(track) + hxp_fp(track)*(hscin_2x_zpos+0.5*hscin_2x_dzpos)
+ hit_cnt(3)=nint((hit_pos(3)-hhodo_center(3,1))/hscin_2x_spacing)+1
+ hit_cnt(3)=max(min(hit_cnt(3),nint(hnum_scin_counters(3))),1)
+ hit_dist(3)=hit_pos(3)-(hscin_2x_spacing*(hit_cnt(3)-1)+hhodo_center(3,1))
+
+ if(hntracks_fp.gt.1) then !!! (4) !!!
+ zap=0.
+ t=0.
+ do j=1,16
+ if(hscinhit(3,j).eq.1) then
+ x2d(track)=abs(hit_cnt(3)-j)
+ t=t+1
+ if(t.eq.1) zap=x2d(track)
+ if(t.eq.2.and.x2d(track).lt.zap) then
+ zap=x2d(track)
+ endif
+ if(t.eq.3.and.x2d(track).lt.zap) then
+ zap=x2d(track)
+ endif
+ if(t.eq.4.and.x2d(track).lt.zap) then
+ zap=x2d(track)
+ endif
+ if(t.eq.5.and.x2d(track).lt.zap) then
+ zap=x2d(track)
+ endif
+ if(t.eq.6.and.x2d(track).lt.zap) then
+ zap=x2d(track)
+ endif
+ endif
+ enddo
+ x2d(track)=zap
+ endif !!! (4) !!!
+
+ if(hntracks_fp.eq.1) x2d(track)=0.
+
+ if(y2d(track).le.y2dmin) then
+ if(y2d(track).lt.y2dmin) then
+ x2dmin=100.
+ chi2min=1e10
+ endif
+
+ if(x2d(track).le.x2dmin) then
+ if(x2d(track).lt.x2dmin) then
+ chi2min=1e10
+ endif
+
+ if(chi2perdeg.lt.chi2min) then
+
+ goodtrack = track
+ y2dmin=y2d(track)
+ x2dmin=x2d(track)
+ chi2min=chi2perdeg
+ endif
+ endif
+ endif
+
+
+
+
+ endif !!! (3) !!!
+ endif !!! (2) !!!
+ enddo
+
+
+
+ if (goodtrack.eq.0) then
+ chi2min= 1e10
+ do track = 1, HNTRACKS_FP
+ if( HNFREE_FP(track).ge. hsel_ndegreesmin) then
+ chi2perdeg = HCHI2_FP(track)/FLOAT(HNFREE_FP(track))
+ if(chi2perdeg.lt.chi2min) then
+ goodtrack = track
+ chi2min = chi2perdeg
+ endif
+ endif
+ enddo
+ endif
+
+
+
+ HSNUM_TARTRACK = goodtrack
+ HSNUM_FPTRACK = goodtrack
+
+
+ if(goodtrack.eq.0) return ! return if no valid tracks
+ endif !!! (1) !!!
+
+
+ return
+ end
diff --git a/HTRACKING/h_solve_3by3.f b/HTRACKING/h_solve_3by3.f
new file mode 100644
index 0000000..af6014c
--- /dev/null
+++ b/HTRACKING/h_solve_3by3.f
@@ -0,0 +1,64 @@
+ subroutine h_solve_3by3(TT,pindex,stub,ierr)
+* Explicit solution of a symmetric three by three equation TT = AA * STUB
+* Remember AA must be a symmetrix matrix
+* Used in find_best_stub.f
+
+* $Log: h_solve_3by3.f,v $
+* Revision 1.4 1995/10/10 17:36:37 cdaq
+* (JRA) Cleanup
+*
+* Revision 1.3 1995/05/22 19:39:27 cdaq
+* (SAW) Split gen_data_data_structures into gen, hms, sos, and coin parts"
+*
+* Revision 1.2 1994/11/22 20:07:20 cdaq
+* (SAW) Change name, add h to aainv3, move to HTRACKING directory.
+*
+* Revision 1.1 1994/10/12 18:42:59 cdaq
+* Initial revision
+*
+*
+* djm 10/2/94
+* The present version replaces solve_three_by_three(TT,AA,stub,ierr) in
+* find_best_stub. New version is entirely based on dfg's version, but matrix
+* inversion is now done only at initialization for faster event sorting.
+
+*
+ implicit none
+ include 'hms_data_structures.cmn'
+ include 'hms_tracking.cmn'
+
+
+* input quantities
+ real*8 TT(3)
+ integer*4 pindex
+*
+* output quantities
+ real*8 stub(3)
+ integer*4 ierr ! ierr = 0 means valid solution
+*
+*
+ if(pindex.le.14)then !accept 5/6 or 6/6 good planes
+ ierr=0
+ stub(1)=HAAINV3(1,1,pindex)*TT(1) + HAAINV3(1,2,pindex)*TT(2) +
+ & HAAINV3(1,3,pindex)*TT(3)
+ stub(2)=HAAINV3(1,2,pindex)*TT(1) + HAAINV3(2,2,pindex)*TT(2) +
+ & HAAINV3(2,3,pindex)*TT(3)
+ stub(3)=HAAINV3(1,3,pindex)*TT(1) + HAAINV3(2,3,pindex)*TT(2) +
+ & HAAINV3(3,3,pindex)*TT(3)
+ else
+ ierr=1
+ endif !end test on plane index
+
+* write(6,*)'TT i=1,2,3',TT(1),TT(2),TT(3)
+*
+* write(6,*)'aainv(1,1,) (1,2,) (1,3,)',aainv(1,1,pindex),
+* & aainv(1,2,pindex),aainv(1,3,pindex)
+*
+* write(6,*)'aainv(2,2) (2,3) (3,3)',aainv(2,2,pindex),
+* & aainv(2,3,pindex),aainv(3,3,pindex)
+*
+* write(6,*)
+
+ return
+
+ end
diff --git a/HTRACKING/h_sp_destroy.f b/HTRACKING/h_sp_destroy.f
new file mode 100644
index 0000000..0674ec8
--- /dev/null
+++ b/HTRACKING/h_sp_destroy.f
@@ -0,0 +1,154 @@
+ subroutine h_sp_destroy(ABORT,err,nspace_points,
+ & space_point_hits,space_points,ich)
+*--------------------------------------------------------
+*-
+*- Purpose and Methods : This routine loops over space points and
+*- removes those with less than 4 planes hit
+*- and missing hits in Y,Y' planes
+*-
+*- Output: ABORT - success or failure
+*- : err - reason for failure, if any
+*-
+*--------------------------------------------------------
+ IMPLICIT NONE
+ SAVE
+*
+ character*50 here
+ parameter (here= 'h_sp_destroy')
+ integer*4 nspace_points
+*
+ logical ABORT
+ character*(*) err
+*
+ INCLUDE 'hms_data_structures.cmn'
+ INCLUDE 'gen_constants.par'
+ INCLUDE 'gen_units.par'
+ include 'hms_tracking.cmn'
+ include 'hms_geometry.cmn'
+*
+ integer*4 space_point_hits(hmax_space_points,hmax_hits_per_point+2)
+ integer*4 space_points(hmax_space_points,2)
+*
+* local variables
+ integer*4 point,oldpoint,plane,ich
+ integer*4 j,hit,nspace_points_good
+ integer*4 nhits_plane(hdc_planes_per_chamber)
+c integer*4 nhits_plane(100) !Phil
+ integer*4 space_points_temp(hmax_space_points,2)
+ integer*4 space_point_hits_temp(hmax_space_points,hmax_hits_per_point+2)
+ integer*4 nplanes_hit,space_points_good(nspace_points)
+c integer*4 nplanes_hit,space_points_good(100) !Phil
+*
+* temporary initialization
+ ABORT= .FALSE.
+ err=' '
+*
+cc write(6,*) "IN h_sp_destroy, ICH = ",ich !! MEC
+
+ nspace_points_good = 0
+
+ do j=1,nspace_points
+ space_points_good(j) = 0
+ enddo
+
+
+*- Start loop over SPs
+
+ do point = 1,nspace_points
+
+**-- Do some initialization
+
+ nplanes_hit = 0 !! # of planes with hits !!
+ do j=1,hdc_planes_per_chamber
+ nhits_plane(j) = 0 !! # of hits in each plane !!
+ enddo
+
+**-- End initialization
+
+**-- Count the number of hits in each plane and fill array with the hit #'s associated with each plane
+
+ do j = 3,space_point_hits(point,1)+2 !! Loop over all hits in sp - count multiple hits in each plane !!
+ hit = space_point_hits(point,j)
+ plane = hdc_plane_num(hit)
+ if(plane.GT.6) plane = plane - hdc_planes_per_chamber
+ nhits_plane(plane) = nhits_plane(plane) + 1
+ enddo
+
+**-- End counting
+
+**-- Now count the # of planes hit in the SP
+
+ do j = 1,hdc_planes_per_chamber !! count # of planes hit !!
+ if(nhits_plane(j).GT.0) nplanes_hit = nplanes_hit + 1
+ enddo
+
+ if(nplanes_hit.GE.hmin_hit(ich).AND.nhits_plane(2).GE.1.
+ & AND.nhits_plane(5).GE.1) then !! Don't clone if not enough planes or missing Y !!
+ nspace_points_good = nspace_points_good + 1
+ space_points_good(nspace_points_good) = point
+ else
+cc write(6,*) "Missing Y-hit!!"
+ endif
+
+cc write(6,*) "SP #: ", point," # of planes hit: ",nplanes_hit
+
+ enddo
+
+*- End loop over SPs
+
+cc write(6,*) "# of Good SPs = ",nspace_points_good
+cc write(6,*) "The Good SPs are: ",space_points_good
+
+*- Loop over SPs again and remove the bad ones
+
+ nspace_points = nspace_points_good
+ do point = 1,nspace_points
+ oldpoint = space_points_good(point)
+ space_points_temp(point,1) = space_points(oldpoint,1)
+ space_points_temp(point,2) = space_points(oldpoint,2)
+ do j = 1,hmax_hits_per_point+2
+ space_point_hits_temp(point,j) = space_point_hits(oldpoint,j)
+ enddo
+ enddo
+
+**-- Copy temporary SP hit array to new SP hit array
+
+
+ do point =1,hmax_space_points
+ if(point.LE.nspace_points) then
+ space_points(point,1) = space_points_temp(point,1) ! Update X,Y positions !
+ space_points(point,2) = space_points_temp(point,2)
+ do j = 1,hmax_hits_per_point+2
+ space_point_hits(point,j) = space_point_hits_temp(point,j)
+ enddo
+ else
+ space_points(point,1) = 0 ! Update X,Y positions !
+ space_points(point,2) = 0
+ endif
+ enddo
+
+**-- End SP hit array copy
+
+*- End remove bad SPs
+
+*
+ return
+ end
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
diff --git a/HTRACKING/h_sp_multiwire.f b/HTRACKING/h_sp_multiwire.f
new file mode 100644
index 0000000..c889b55
--- /dev/null
+++ b/HTRACKING/h_sp_multiwire.f
@@ -0,0 +1,237 @@
+ subroutine h_sp_multiwire(ABORT,err,nspace_points,
+ & space_point_hits,space_points)
+*--------------------------------------------------------
+*-
+*- Purpose and Methods : This routine loops over space points and
+*- looks at all hits in the space
+*- point. If more than 1 hit is in the same
+*- plane then the space point is cloned with
+*- all combinations of 1 wire per plane. The
+*- requirements for cloning are: 1) at least
+*- 4 planes fire, and 2) no more than 6 planes
+*- have multiple hits.
+*-
+*- Output: ABORT - success or failure
+*- : err - reason for failure, if any
+*-
+*--------------------------------------------------------
+ IMPLICIT NONE
+ SAVE
+*
+ character*50 here
+ parameter (here= 'h_sp_multiwire')
+ integer*4 nspace_points
+*
+ logical ABORT
+ character*(*) err
+*
+ INCLUDE 'hms_data_structures.cmn'
+ INCLUDE 'gen_constants.par'
+ INCLUDE 'gen_units.par'
+ include 'hms_tracking.cmn'
+ include 'hms_geometry.cmn'
+*
+ integer*4 space_point_hits(hmax_space_points,hmax_hits_per_point+2)
+ real*4 space_points(hmax_space_points,2) ! xt, yt of each space point
+*
+* local variables
+ integer*4 point,plane,n1,n2,n3,ntot,nspace_points_check
+ integer*4 i,j,k,hit,hit1,hit2,temp,newsp_num,endhit
+ integer*4 nspace_points_new, nhits_plane(hdc_planes_per_chamber)
+c integer*4 nspace_points_new, nhits_plane(100) !Phil
+ integer*4 nspace_points_tot,nplanes_mult,nplanes_hit,nplanes_single
+ integer*4 hits_plane(hdc_planes_per_chamber,hmax_hits_per_point+1)
+c integer*4 hits_plane(100,hmax_hits_per_point+1) !Phil
+ integer*4 maxplane(hdc_planes_per_chamber)
+c integer*4 maxplane(100) !Phil
+ integer*4 hit_order(hmax_hits_per_point)
+*
+* temporary initialization
+ ABORT= .FALSE.
+ err=' '
+*
+cc write(6,*) "IN h_sp_multiwire" !! MEC
+
+
+ nspace_points_tot = nspace_points
+ do point = 1,nspace_points !! Start loop over SPs !!
+
+cc write(6,*) "orig SP ",space_point_hits(point,1),space_point_hits(point,2),
+cc & space_point_hits(point,3),space_point_hits(point,4),
+cc & space_point_hits(point,5),space_point_hits(point,6),
+cc & space_point_hits(point,7),space_point_hits(point,8),
+cc & space_point_hits(point,9),space_point_hits(point,10)
+
+
+*- Do some initialization
+
+ nplanes_hit = 0 !! # of planes with hits !!
+ nplanes_mult = 0 !! # of planes with multiple hits !!
+ nspace_points_new = 1
+ do j=1,hdc_planes_per_chamber
+ nhits_plane(j) = 0 !! # of hits in each plane !!
+ do k=1,hmax_hits_per_point+1
+ hits_plane(j,k) = 0 !! hit array with hit #s for each plane !!
+ enddo
+ enddo
+
+*- End initialization
+
+*- Count the number of hits in each plane and fill array with the hit #'s associated with each plane
+
+ do j = 3,space_point_hits(point,1)+2 !! Loop over all hits in sp - !!
+ hit = space_point_hits(point,j) !! count multiple hits in each plane !!
+ hit_order(hit) = j-2
+ plane = hdc_plane_num(hit)
+ if(plane.GT.6) plane = plane - hdc_planes_per_chamber
+ nhits_plane(plane) = nhits_plane(plane) + 1
+ hits_plane(plane,1) = nhits_plane(plane)
+ hits_plane(plane,nhits_plane(plane)+1) = hit
+ enddo
+
+*- End counting
+
+*- Now do some counting of planes with various #s of hits
+
+ do j = 1,hdc_planes_per_chamber !! count # of planes hit !!
+ if(nhits_plane(j).GT.0) then
+ nplanes_hit = nplanes_hit + 1
+ nspace_points_new = nspace_points_new*nhits_plane(j)
+ endif
+ if(nhits_plane(j).GT.1) nplanes_mult = nplanes_mult + 1
+ enddo
+ nspace_points_new = nspace_points_new - 1
+ nspace_points_check = nspace_points_tot + nspace_points_new
+ nplanes_single = nplanes_hit - nplanes_mult
+
+*- End counting
+
+cc write(6,*) "NEW SP: ",nspace_points_new
+cc write(6,*) "sp",point,":",nhits_plane !! MEC
+c write(6,*) "sp",point,": # planes with single hit:",nplanes_single,"
+c &# with mult hits:",nplanes_mult !! MEC
+
+ ntot = 0
+
+*- Now do cloning if conditions are met
+
+ if(nplanes_hit.GE.4.AND.nplanes_mult.LT.4.AND.nplanes_mult.GT.0.AND.
+ & nspace_points_check.LT.20) then
+
+**-- Order Planes by decreasing # of hits
+
+ do j = 1,hdc_planes_per_chamber !! First start out sequentially !!
+ maxplane(j) = j !! Contains plane #s ordered with decreasing # of hits !!
+ enddo
+
+ do j = 1,hdc_planes_per_chamber
+ do k = j+1,hdc_planes_per_chamber
+ if(nhits_plane(maxplane(k)).GT.nhits_plane(maxplane(j))) then !! switch position of plane #s in maxplane !!
+ temp = maxplane(j)
+ maxplane(j) = maxplane(k)
+ maxplane(k) = temp
+ endif
+ enddo
+ enddo
+
+c write(6,*) "Max hit order is: ",maxplane
+
+**-- End Order Planes
+
+**-- First fill the clones with 1 hit each from the 3 planes with the most hits
+
+ ntot = 0
+ do n1 = 1,nhits_plane(maxplane(1))
+ do n2 = 1,nhits_plane(maxplane(2))
+ do n3 = 1,nhits_plane(maxplane(3))
+ ntot = ntot + 1
+ newsp_num = nspace_points_tot + ntot - 1
+ if(n1.EQ.1.AND.n2.EQ.1.AND.n3.EQ.1) newsp_num = point !! Copy first clone over original SP !!
+ space_points(newsp_num,1) = space_points(point,1)
+ space_points(newsp_num,2) = space_points(point,2)
+ space_point_hits(newsp_num,1) = nplanes_hit
+ space_point_hits(newsp_num,2) = space_point_hits(point,2)
+ space_point_hits(newsp_num,3) = hits_plane(maxplane(1),n1+1)
+ space_point_hits(newsp_num,4) = hits_plane(maxplane(2),n2+1)
+ space_point_hits(newsp_num,5) = hits_plane(maxplane(3),n3+1)
+ space_point_hits(newsp_num,6) = hits_plane(maxplane(4),2)
+ if(hits_plane(maxplane(5),1).EQ.1)
+ & space_point_hits(newsp_num,7) = hits_plane(maxplane(5),2)
+ if(hits_plane(maxplane(6),1).EQ.1)
+ & space_point_hits(newsp_num,8) = hits_plane(maxplane(6),2)
+ enddo
+ enddo
+ enddo
+
+*- Loop over clones and order hits in same way as parent SP
+
+ do i = 1,ntot
+ newsp_num = nspace_points_tot + i - 1
+ if(i.EQ.1) newsp_num = point
+ do j = 3,nplanes_hit+2
+ do k = 3,nplanes_hit+2
+ hit1 = space_point_hits(newsp_num,j)
+ hit2 = space_point_hits(newsp_num,k)
+ if(hit_order(hit2).GT.hit_order(hit1)) then
+ temp = space_point_hits(newsp_num,k) !! switch position of hits !!
+ space_point_hits(newsp_num,k) = space_point_hits(newsp_num,j)
+ space_point_hits(newsp_num,j) = temp
+ endif
+ enddo
+ enddo
+ enddo
+
+*- End order clone hits
+
+
+
+*- End cloning
+
+c do j = 1,ntot !! make clones of sp !!
+c space_point_hits(j + nspace_points,1) = hdc_planes_per_chamber !! now only 1 hit per plane !!
+c do k = 1,hmax_hits_per_point+2
+c space_point_hits(j + nspace_points,k) = space_point_hits(point,k) !! copy old SP hits to clones !!
+c enddo
+c enddo
+
+ nspace_points_tot = nspace_points_tot + ntot - 1 !! add new SPs to running total
+ else
+ ntot = 1
+ endif
+
+cc write(6,*) "Ntot: ",ntot
+cc write(6,*) "Running total of SPs = ",nspace_points_tot
+
+
+ enddo ! end loop on space points
+ if(nspace_points_tot.LE.20) nspace_points = nspace_points_tot !! Don't increment inside DO loop !!
+
+ do i = 1,nspace_points_tot !! Fill in zeros !!
+ endhit = 3 + space_point_hits(i,1)
+ do j = endhit,hmax_hits_per_point
+ space_point_hits(i,j) = 0
+ enddo
+ enddo
+
+c do i = 1,nspace_points_tot
+c write(6,*) space_point_hits(i,1),space_point_hits(i,2),space_point_hits(i,3),
+c & space_point_hits(i,4),space_point_hits(i,5),space_point_hits(i,6),
+c & space_point_hits(i,7),space_point_hits(i,8)
+c enddo
+
+*
+ return
+ end
+
+
+
+
+
+
+
+
+
+
+
+
+
diff --git a/HTRACKING/h_sparsify_cal.f b/HTRACKING/h_sparsify_cal.f
new file mode 100644
index 0000000..a7a2c03
--- /dev/null
+++ b/HTRACKING/h_sparsify_cal.f
@@ -0,0 +1,137 @@
+*=======================================================================
+ subroutine h_sparsify_cal(abort,errmsg)
+*=======================================================================
+*-
+*- Purpose: Sparsifies the calorimeter raw data.
+*-
+*- Input Banks: HMS_RAW_CAL, HMS_PEDESTALS_CAL
+*-
+*- Output Bank: HMS_SPARSIFIED_CAL
+*-
+*- Created: 15 Mar 1994 Tsolak A. Amatuni
+*- Modified 25 Mar 1994 DFG
+*- Change name of print routines
+*- 5 Apr 1994 DFG Move print routine to h_raw_dump_all
+* $Log: h_sparsify_cal.f,v $
+* Revision 1.13 2002/10/02 13:42:43 saw
+* Check that user hists are defined before filling
+*
+* Revision 1.12 1999/06/10 16:51:25 csa
+* (JRA) Removed adc_max, added adc sign test, structural and cosmetic changes
+*
+* Revision 1.11 1999/02/25 20:10:48 saw
+* Vardan Tadevosyan shower code updates
+*
+* Revision 1.10 1999/02/23 18:48:45 csa
+* (JRA) Add neg cal hf1 call
+*
+* Revision 1.9 1999/02/03 21:13:24 saw
+* Code for new Shower counter tubes
+*
+* Revision 1.8 1998/12/17 22:02:40 saw
+* Support extra set of tubes on HMS shower counter
+*
+* Revision 1.7 1996/01/16 21:58:51 cdaq
+* (JRA) Onlys histogram ADC's that are not 200 above pedestal
+*
+* Revision 1.6 1995/08/30 18:12:12 cdaq
+* (JRA) Add a hist of all adc's into one spectrum
+*
+* Revision 1.5 1995/07/19 20:04:25 cdaq
+* (JRA) Remove calorimeter raw data validity check
+*
+* Revision 1.4 1995/05/22 19:39:27 cdaq
+* (SAW) Split gen_data_data_structures into gen, hms, sos, and coin parts"
+*
+* Revision 1.3 1995/05/11 14:54:05 cdaq
+* (JRA) Add call to h_fill_cal_hist
+*
+* Revision 1.2 1994/09/13 20:31:08 cdaq
+* (JRA) Subtract pedestals in sparsified data
+*
+* Revision 1.1 1994/04/13 16:21:31 cdaq
+* Initial revision
+*
+*-----------------------------------------------------------------------
+*
+ implicit none
+ save
+
+ logical abort
+ character*(*) errmsg
+ character*14 here
+ parameter (here='H_SPARSIFY_CAL')
+
+ integer*4 nh !Loop variable for raw hits
+ integer*4 nb !Block number
+ integer*4 row,col !Row & column numbers
+ integer*4 adc_pos !ADC value
+ integer*4 adc_neg !ADC value
+
+ include 'hms_data_structures.cmn'
+ include 'hms_calorimeter.cmn'
+ include 'hms_id_histid.cmn'
+
+
+ errmsg=' '
+ if(hcal_tot_hits.lt.0.or.hcal_tot_hits.gt.hmax_cal_blocks) then
+ write(6,*) here,':hcal_tot_hits = ',hcal_tot_hits
+ return
+ endif
+
+ hcal_num_hits=0
+ do nb = 1 , hmax_cal_blocks
+ hcal_realadc_pos(nb)=-100
+ hcal_realadc_neg(nb)=-100
+ enddo
+ if(hcal_tot_hits.le.0) return
+*
+* Loop over raw hits
+*
+ do nh=1,hcal_tot_hits
+ row=hcal_row(nh)
+ col=hcal_column(nh)
+ nb =row+hmax_cal_rows*(col-1)
+ adc_pos=hcal_adc_pos(nh)
+ adc_neg=hcal_adc_neg(nh)
+
+ if (adc_pos.ge.0) then ! =-1 if no ADC value was read.
+ hcal_realadc_pos(nb) = float(adc_pos) - hcal_pos_ped_mean(nb)
+ if (hcal_realadc_pos(nb).le.200.and.hidcalsumadc.gt.0)
+ & call hf1(hidcalsumadc,hcal_realadc_pos(nb),1.)
+ endif
+
+ if (adc_neg.ge.0) then
+ hcal_realadc_neg(nb) = float(adc_neg) - hcal_neg_ped_mean(nb)
+ if (hcal_realadc_neg(nb).le.200.and.hidcalsumadc.gt.0)
+ & call hf1(hidcalsumadc,hcal_realadc_neg(nb),1.)
+ endif
+*
+* Sparsify the raw data
+*
+ if(hcal_realadc_pos(nb).gt.hcal_pos_threshold(nb) .or.
+ & hcal_realadc_neg(nb).gt.hcal_neg_threshold(nb)) then
+
+ hcal_num_hits=hcal_num_hits+1
+ hcal_rows(hcal_num_hits)=row
+ hcal_cols(hcal_num_hits)=col
+ if(hcal_realadc_pos(nb).lt.hcal_pos_threshold(nb)) then
+ hcal_adcs_pos(hcal_num_hits)=0.0
+ else
+ hcal_adcs_pos(hcal_num_hits)=hcal_realadc_pos(nb)
+ endif
+
+ if(hcal_realadc_neg(nb).lt.hcal_neg_threshold(nb)) then
+ hcal_adcs_neg(hcal_num_hits)=0.0
+ else
+ hcal_adcs_neg(hcal_num_hits)=hcal_realadc_neg(nb)
+ endif
+ endif
+ enddo !End loop over raw hits
+
+ if(hdbg_sparsified_cal.gt.0) call h_prt_cal_sparsified
+
+ call h_fill_cal_hist(abort,errmsg)
+
+ return
+ end
diff --git a/HTRACKING/h_strip_scin.f b/HTRACKING/h_strip_scin.f
new file mode 100644
index 0000000..59b834d
--- /dev/null
+++ b/HTRACKING/h_strip_scin.f
@@ -0,0 +1,109 @@
+ subroutine h_strip_scin(abort,err)
+
+*-------------------------------------------------------------------
+* author: John Arrington
+* created: 6/25/94
+*
+* h_strip_scin converts the raw hits to arrays over hits
+* with good TDC values.
+* $Log: h_strip_scin.f,v $
+* Revision 1.11.24.1 2007/10/22 15:22:50 cdaq
+* *** empty log message ***
+*
+* Revision 1.11 1999/02/23 18:49:18 csa
+* (JRA) Remove hdebugcalcpeds stuff
+*
+* Revision 1.10 1996/01/16 21:59:35 cdaq
+* (JRA) Add hdebugcalcpeds flag
+*
+* Revision 1.9 1995/08/30 17:35:14 cdaq
+* (JRA) Accumulate pedestals from pedestal events.
+*
+* Revision 1.8 1995/05/22 19:39:28 cdaq
+* (SAW) Split gen_data_data_structures into gen, hms, sos, and coin parts"
+*
+* Revision 1.7 1995/05/11 15:01:22 cdaq
+* (JRA) Cosmetic changes
+*
+* Revision 1.6 1995/02/02 13:07:17 cdaq
+* (JRA) Make hscin_all_adc_pos/neg floating
+*
+* Revision 1.5 1994/10/17 20:47:03 cdaq
+* (DJM) Change hscin_sing_counter index from ihit (wrong) to igoodhit (correct)
+*
+* Revision 1.4 1994/10/12 18:59:37 cdaq
+* (DJM) Fill hscin_sing_counter hit patterns for hodoscope
+*
+* Revision 1.3 1994/10/11 19:05:59 cdaq
+* (JRA) Subtract pedestals from adc's
+*
+* Revision 1.2 1994/06/29 03:42:15 cdaq
+* (JRA) Clear and set nscin_hits_per_plane array
+*
+* Revision 1.1 1994/06/27 02:41:12 cdaq
+* Initial revision
+*
+*-------------------------------------------------------------------
+
+ implicit none
+
+ include 'hms_data_structures.cmn'
+ include 'hms_scin_parms.cmn'
+ include 'hms_scin_tof.cmn'
+ include 'hms_tracking.cmn'
+
+ logical abort
+ character*(*) err
+ character*12 here
+ parameter (here = 'h_strip_scin')
+
+ integer*4 ihit,igoodhit,ind,plane,counter
+ integer*4 ip,ic
+ save
+ abort = .false.
+
+ igoodhit = 0
+ hscin_tot_hits = 0
+ do ind = 1, hnum_scin_planes
+ hscin_hits_per_plane(ind) = 0
+ hscin_sing_counter(ind) = -1
+ enddo
+
+ do ihit = 1 , hscin_all_tot_hits ! pick out 'good' hits.
+
+** Criteria for good hit is at least one valid tdc value.
+c write(*,*) ihit,hscin_all_adc_pos(ihit),hscin_all_adc_neg(ihit),
+c >hscin_all_tdc_pos(ihit),hscin_all_tdc_neg(ihit),
+c > hscin_tdc_min,hscin_tdc_max
+ if (((hscin_all_tdc_pos(ihit) .ge. hscin_tdc_min).and.
+ 1 (hscin_all_tdc_pos(ihit) .le. hscin_tdc_max)) .or.
+ 2 ((hscin_all_tdc_neg(ihit) .ge. hscin_tdc_min).and.
+ 3 (hscin_all_tdc_neg(ihit) .le. hscin_tdc_max))) then !good hit
+
+ igoodhit = igoodhit + 1
+ hscin_tot_hits = hscin_tot_hits + 1
+ ip = hscin_all_plane_num(ihit)
+ hscin_plane_num(igoodhit) = ip
+ ic = hscin_all_counter_num(ihit)
+ hscin_counter_num(igoodhit) = ic
+ hscin_adc_pos(igoodhit) = float(hscin_all_adc_pos(ihit)) -
+ $ hscin_all_ped_pos(ip,ic)
+ hscin_adc_neg(igoodhit) = float(hscin_all_adc_neg(ihit)) -
+ $ hscin_all_ped_neg(ip,ic)
+ hscin_tdc_pos(igoodhit) = hscin_all_tdc_pos(ihit)
+ hscin_tdc_neg(igoodhit) = hscin_all_tdc_neg(ihit)
+ hscin_hits_per_plane(hscin_plane_num(igoodhit)) =
+ $ hscin_hits_per_plane(hscin_plane_num(igoodhit)) + 1
+*djm register counter which is hit. if more than one counter is hit per event,
+* only the last one will be histogrammed. this will bias events which have more
+* than one hit per plane, so it's only really useful for looking at single hits.
+* if you need to see all the hits, then hardwire it.
+ plane = HSCIN_PLANE_NUM(igoodhit)
+ counter = HSCIN_COUNTER_NUM(igoodhit)
+ if(plane.ge.1.and.plane.le.4) hscin_sing_counter(plane) = counter
+ endif
+ enddo
+
+ abort = .false.
+ return
+ end
diff --git a/HTRACKING/h_targ_trans.f b/HTRACKING/h_targ_trans.f
new file mode 100644
index 0000000..478888f
--- /dev/null
+++ b/HTRACKING/h_targ_trans.f
@@ -0,0 +1,348 @@
+ SUBROUTINE H_TARG_TRANS(ABORT,err,istat)
+*--------------------------------------------------------
+*-
+*- Purpose and Methods : Transforms tracks from HMS focal plane to
+*- target.
+*-
+*- Required Input BANKS HMS_FOCAL_PLANE
+*-
+*- Output BANKS HMS_TARGET
+*-
+*- Output: ABORT - success or failure
+*- : err - reason for failure, if any
+*-
+*- istat (integer) Status flag. Value returned indicates the following:
+*- = 1 Normal return.
+*- = 2 Matrix elements not initted correctly.
+*-
+* $Log: h_targ_trans.f,v $
+* Revision 1.16.24.2.2.9 2009/09/16 21:49:20 jones
+* Use SANE_HMS_FIELD_THETA,SANE_HMS_FIELD_PHI defined in engine.f
+* in CALL trgInitFieldANGLES
+*
+* Revision 1.16.24.2.2.8 2009/09/15 20:36:53 jones
+* New variables theta_angle_diff,phi_angle_diff used in CALL trgInitFieldANGLES
+*
+* Revision 1.16.24.2.2.6 2009/02/11 21:34:54 cdaq
+* *** empty log message ***
+*
+* Revision 1.16.24.2.2.5 2008/12/11 20:26:43 cdaq
+* *** empty log message ***
+*
+* Revision 1.16.24.2.2.4 2008/11/17 01:17:55 cdaq
+* *** empty log message ***
+*
+* Revision 1.16.24.2.2.3 2008/10/31 07:59:10 cdaq
+* fix bug with enddo in wrong place
+*
+* Revision 1.16.24.2.2.2 2008/10/29 06:20:21 cdaq
+* Set hut(5)=rast_y
+* Set loop from 4 to 5
+*
+* Revision 1.16.24.2.2.1 2008/10/21 20:33:17 cdaq
+* target recon with B field added
+*
+* Revision 1.16.24.2 2007/10/27 21:15:32 cdaq
+* fix erroneous submissions
+*
+* Revision 1.16 1999/02/23 18:50:38 csa
+* (JRA) Correct (another) hut(5) error
+*
+* Revision 1.15 1999/02/10 17:47:27 csa
+* Sign change in hut(5)
+*
+* Revision 1.14 1996/09/04 13:32:36 saw
+* (JRA) Apply offsets to reconstruction
+*
+* Revision 1.13 1996/01/17 18:15:53 cdaq
+* (JRA)
+*
+* Revision 1.12 1995/10/10 17:49:31 cdaq
+* (JRA) Cleanup
+*
+* Revision 1.11 1995/08/08 16:01:17 cdaq
+* (DD) Add detector and angular offsets
+*
+* Revision 1.10 1995/05/22 19:39:28 cdaq
+* (SAW) Split gen_data_data_structures into gen, hms, sos, and coin parts"
+*
+* Revision 1.9 1995/04/06 19:31:54 cdaq
+* (SAW) Put in ddutta's pre cosy x-x', y-y' transformation
+*
+* Revision 1.8 1995/03/22 16:22:40 cdaq
+* (SAW) Previous change wrong. COSY wants slopes.
+* Target track data is now slopes.
+*
+* Revision 1.7 1995/02/10 18:46:01 cdaq
+* (SAW) Convert focal plane slopes to angles before COSY transport.
+* Target track data is now angles.
+*
+* Revision 1.6 1994/10/11 19:11:33 cdaq
+* (SAW) Are the target traceback calculations right now???
+*
+* Revision 1.5 1994/08/18 04:29:59 cdaq
+* (SAW) Arrington's changes??
+*
+* Revision 1.4 1994/06/14 04:51:21 cdaq
+* (DFG) Add fill HLINK_TAR_FP 1 to 1
+*
+* Revision 1.3 1994/06/06 17:03:17 cdaq
+* (DFG) Protect against asin argument > 1.0
+*
+* Revision 1.2 1994/05/13 02:28:59 cdaq
+* (DFG) Add call to h_fill_dc_target_hist
+* Add calculation of HP_TAR
+* (SAW) Cosmetic changes to source
+*
+* Revision 1.1 1994/02/19 06:19:24 cdaq
+* Initial revision
+*- Modified 21-JAN-94 D. F. Geesaman
+*- Add ABORT,err to returns.
+*- Version: 0.1 (In development) 18-Nov-1993 (DHP)
+*-
+*
+* Abstract: Reconstruct target scattering variables from track variables in
+* the detectors, using a polynomial (Taylor series) map. The track,
+* target, and map data are all maintained in common blocks.
+*
+* NOTE: This version assumes that the beam is not rastered.
+* Also, there is no treatment of error matrices, yet.
+*
+* Output arguments:
+*
+*
+* Right-handed coordinates are assumed: X=down, Z=downstream, Y = (Z cross X)
+*
+* Author: David H. Potterveld, Argonne National Lab, Nov. 1993
+*--------------------------------------------------------
+ IMPLICIT NONE
+ SAVE
+*
+ character*12 here
+ parameter (here= 'h_targ_trans')
+*
+ logical ABORT,ok
+ character*(*) err
+ integer*4 istat
+ real*4 x_coord, y_coord
+*
+ INCLUDE 'gen_data_structures.cmn'
+ INCLUDE 'hms_data_structures.cmn'
+ INCLUDE 'gen_constants.par'
+ INCLUDE 'gen_units.par'
+ INCLUDE 'hms_tracking.cmn'
+ INCLUDE 'hms_recon_elements.cmn'
+ INCLUDE 'hms_track_histid.cmn'
+ INCLUDE 'hms_physics_sing.cmn'
+ INCLUDE 'sane_data_structures.cmn'
+
+
+*
+*--------------------------------------------------------
+*
+* Misc. variables.
+
+ integer*4 i,j,itrk
+
+ real sum(4),hut(5),term
+ real bdl,dx
+ real trg(6),hut_rot(5)
+ integer spect
+ COMMON /hmsfocalplane/sum,hut_rot
+c
+ real*8 theta_angle_diff,phi_angle_diff
+ logical first
+ data first /.true./
+c
+*=============================Executable Code =============================
+ ABORT= .FALSE.
+ err= ' '
+* Check for correct initialization.
+
+ if (h_recon_initted.ne.1) then
+ istat = 2
+ return
+ endif
+ istat = 1
+
+ x_coord = -gsry_calib/100. ! SLOW RASTER BEAM X coordinate obtained from the ADCs, in meters
+ y_coord = -gsrx_calib/100. ! SLOW RASTER BEAM Y coordinate obtained from the ADCs, in meters
+c write(*,*)x_coord,y_coord
+
+* Loop over tracks.
+
+ hntracks_tar = hntracks_fp
+
+ do itrk = 1,hntracks_fp
+
+* set link between target and focal plane track. Currently 1 to 1
+
+ hlink_tar_fp(itrk) = itrk
+
+
+* Reset COSY sums.
+ do i = 1,4
+ sum(i) = 0.
+ enddo
+
+
+* Load track data into local array, Converting to COSY units.
+* It is assumed that the track coordinates are reported at
+* the same focal plane as the COSY matrix elements were calculated.
+* Also note that the COSY track slopes HUT(2) and HUT(4) are actually
+* the SINE of the track angle in the XZ and YZ planes.
+
+ hut(1) = hx_fp(itrk)/100. + h_z_true_focus*hxp_fp(itrk)
+ $ + h_det_offset_x ! include detector offset (m)
+! includes transformation to actual focus if not at Z=0.
+
+ hut(2) = hxp_fp(itrk) + h_ang_offset_x !radians
+
+ hut(3) = hy_fp(itrk)/100. + h_z_true_focus*hyp_fp(itrk)
+ $ + h_det_offset_y !m
+! again icludes transformation to true focus.
+
+ hut(4) = hyp_fp(itrk) + h_ang_offset_y !radians
+
+ hut(5)= x_coord ! spectrometer target X in meter!
+ ! note that pos. spect. X = neg. beam Y, here should be the coordinate given by the slow raster
+c hut(5)= x_coord ! spectrometer target X in meter - given by the Slow Raster!
+ ! note that pos. spect. X = neg. beam Y, here should be the coordinate given by the slow raster
+
+
+! now transform
+* hx_fp_rot(itrk)= hut(1) + h_det_offset_x ! include detector offset
+* hy_fp_rot(itrk)= hut(3) + h_det_offset_y
+* hxp_fp_rot(itrk)= hut(2) + hut(1)*h_ang_slope_x
+* hyp_fp_rot(itrk)= hut(4) + hut(3)*h_ang_slope_y
+* hut_rot(1)= hx_fp_rot(itrk)
+* hut_rot(2)= hxp_fp_rot(itrk)
+* hut_rot(3)= hy_fp_rot(itrk)
+* hut_rot(4)= hyp_fp_rot(itrk)
+* h*_fp_rot never used except here, so remove the intermediate step.
+
+ hut_rot(1) = hut(1)
+ hut_rot(2) = hut(2) + hut(1)*h_ang_slope_x
+ hut_rot(3) = hut(3)
+ hut_rot(4) = hut(4) + hut(3)*h_ang_slope_y
+ hut_rot(5) = hut(5)
+
+* Introducing the target magnetic field option
+
+
+* Compute COSY sums.
+
+ do i = 1,h_num_recon_terms
+ term = 1.
+ do j = 1,5
+ if (h_recon_expon(j,i).ne.0.)
+ , term = term*hut_rot(j)**h_recon_expon(j,i)
+ enddo
+ sum(1) = sum(1) + term*h_recon_coeff(1,i) ! xp uT(2) trg(2)
+ sum(2) = sum(2) + term*h_recon_coeff(2,i) ! y uT(3) trg(3)
+ sum(3) = sum(3) + term*h_recon_coeff(3,i) ! yp uT(4) trg(4)
+ sum(4) = sum(4) + term*h_recon_coeff(4,i) ! delta uT(6) trg(6)
+ enddo
+! uT(5),trg(5) is z-position along the HMS spectrometer axis
+! used in tracking back to the target
+! uT(1),trg(1) is xtarget position, measured by slow raster.
+
+* Load output values.
+
+ hx_tar(itrk) = x_coord ! beam slow raster coord.
+ hy_tar(itrk) = sum(2) !cm.
+ hxp_tar(itrk) = sum(1) !Slope xp
+ hyp_tar(itrk) = sum(3) !Slope yp
+ hz_tar(itrk) = 0.0 !Track is at origin
+ hdelta_tar(itrk) = sum(4)*100. !percent.
+c write(*,*)'1 ',hx_tar(itrk),hy_tar(itrk),hxp_tar(itrk),hyp_tar(itrk),hdelta_tar(itrk)
+ if (SANE_TGTFIELD_B.ne.0.0) then
+
+ trg(1) = 1
+ trg(2) = 0.1
+ trg(3) = 1
+ trg(4) = 0.1
+ trg(5) = 1
+ trg(6) = 1
+
+* Parameter:
+* subroutine genRecon(u,x,y,uT,ok,dx,bdl)
+* u I : focal plane coordinates
+* u(1,2) : x [m], dx/dz = out of plane coords. (downwards)
+* u(3,4) : y [m], dy/dz = inplane coords. (perp. on x,z)
+* u(5) : vert. beam offset [m] (out of plane coord.; downwards)
+* x_coord I : vert. beam offset [m] (out of plane coord.; downwards)
+* y_coord I : hori. beam offsey [m] (inplane coord.; perp on x-beam, z-beam)
+* uT O : target coordinates
+* uT(1,2) : x [m], dx/dz = out of plane coord. (downwards)
+* uT(3,4) : y [m], dy/dz = inplane coord. (perp. on x,z)
+* uT(5) : z [m] = in axis coordinate (towards HMS)
+* uT(6) : delta = relative deviation of the particle
+* momentum from p0
+* ok IO : status variable
+* - if false no action is taken
+* - set to false when no reconstruction is found
+
+
+ ok = .TRUE.
+ theta_angle_diff=abs(SANE_HMS_ANGLE_THETA+SANE_FIELD_ANGLE_THETA)
+ phi_angle_diff = 180.0d00
+ CALL trgInitFieldANGLES(SANE_HMS_FIELD_THETA,SANE_HMS_FIELD_PHI)
+c write(*,*)dx,htheta_lab,hpcentral, hpartmass
+ spect = 1 ! assume it is proton
+ if ( hpartmass .lt. .01) spect = -1 ! set for electron
+ CALL genRecon (hut_rot, x_coord, y_coord, trg, ok, dx, bdl,
+ > htheta_lab, hpcentral, hpartmass, spect)
+
+* CALL genRecon (hut_rot, x_coord, y_coord, trg, ok, dx, bdl,
+* > hpcentral, mass_electron, -1.) ! set for electrons
+
+c hx_tar(itrk) = x_coord ! beam slow raster coord.
+c hy_tar(itrk) = sum(2)*100. !cm.
+c hxp_tar(itrk) = sum(1) !Slope xp
+c hyp_tar(itrk) = sum(3) !Slope yp
+c hz_tar(itrk) = 0.0 !Track is at origin
+c hdelta_tar(itrk) = sum(4)*100. !percent.
+
+ hx_tar(itrk) = trg(1) ! target x
+ hy_tar(itrk) = trg(3) ! target y
+c write(*,*)x_coord,y_coord,hx_tar(itrk),hy_tar(itrk)
+ hz_tar(itrk) = trg(5) ! target z
+ hxp_tar(itrk) = trg(2) ! slope xp
+ hyp_tar(itrk) = trg(4) ! slope yp
+ hdelta_tar(itrk) = trg(6)*100 !percent.
+ h_bdl(itrk) = bdl
+c write(*,*)'2 ',hx_tar(itrk),hy_tar(itrk),hxp_tar(itrk),hyp_tar(itrk),hdelta_tar(itrk)
+c write(*,*)'2 '
+* write(*,*)'2 ',hx_tar(itrk),hy_tar(itrk),hxp_tar(itrk),hdelta_tar(itrk)
+* write(*,*)'++++++++++++++++++++++++++++++++++++++++'
+
+ endif ! loop over the magnetic field (on or off)
+
+
+* Apply offesets to the reconstructed variables
+
+ hdelta_tar(itrk) = hdelta_tar(itrk) + hdelta_offset
+ hyp_tar(itrk) = hyp_tar(itrk) + htheta_offset
+ hxp_tar(itrk) = hxp_tar(itrk) + hphi_offset
+
+ hp_tar(itrk) = hpcentral*(1.0 + hdelta_tar(itrk)/100.) !Momentum in GeV
+
+ enddo !End of loop over tracks.
+
+* All done...
+* print target bank if debug flag set
+ if(hdebugtartrackprint.gt.0) then
+ call h_print_tar_tracks
+ endif
+* Fill hardwired histograms if hturnon_target_hist is non zero
+*
+ if(hturnon_target_hist.gt.0) then
+ call h_fill_dc_target_hist(ABORT,err)
+ if(ABORT) then
+ call g_add_path(here,err)
+ endif
+ endif
+ return
+ end
+
diff --git a/HTRACKING/h_targ_trans_init.f b/HTRACKING/h_targ_trans_init.f
new file mode 100644
index 0000000..ff85957
--- /dev/null
+++ b/HTRACKING/h_targ_trans_init.f
@@ -0,0 +1,182 @@
+ subroutine h_targ_trans_init(ABORT,err,istat)
+*______________________________________________________________________________
+*
+* Facility: CEBAF Hall-C software.
+*
+* Module: h_targ_trans_init
+*
+* Version: 0.1 (In development)
+* $Log: h_targ_trans_init.f,v $
+* Revision 1.6.16.1.2.1 2008/10/21 20:33:17 cdaq
+* target recon with B field added
+*
+* Revision 1.6.16.1 2007/09/10 20:28:01 pcarter
+* Implemented changes to allow compilation on RHEL 3,4,5 and MacOSX
+*
+* Revision 1.6 2004/02/19 16:41:45 jones
+* Can set filename for the HMS matrix elements using the parameter
+* h_recon_coeff_filename . If parameter is not set then uses
+* hms_recon_coeff.dat
+*
+* Revision 1.5 1996/09/04 13:34:30 saw
+* (JRA) Add target x to track definition
+*
+* Revision 1.4 1995/08/08 16:01:37 cdaq
+* (DD) Add detector and angular offsets
+*
+* Revision 1.3 1995/05/11 19:13:27 cdaq
+* (JRA) Fix errors in reading of focal plane rot coeffs
+*
+* Revision 1.2 1995/04/06 19:32:19 cdaq
+* (SAW) Put in ddutta's pre cosy x-x', y-y' transformation
+*
+* Revision 1.1 1994/05/13 03:51:55 cdaq
+* Initial revision
+*
+*
+* Abstract: Temporary routine to initialize HMS reconstruction coefficients
+* from a datafile.
+*
+* Output arguments:
+*
+* istat (integer) Status flag. Value returned indicates the following:
+* = 1 Normal return.
+* = 2 Datafile could not be opened.
+* = 4 Error reading datafile.
+* = 6 Datafile overflowed the internal arrays.
+*
+* Author: David H. Potterveld, Argonne National Lab, Nov. 1993
+* Modified: D. F. Geesaman Add Abort, err arguments
+* Use G_IO_CONTROL to get LUN
+*______________________________________________________________________________
+
+ implicit none
+
+* Argument definitions.
+ logical ABORT
+ character*(*) err
+
+ integer istat
+
+* Include files.
+
+ include 'hms_recon_elements.cmn' !Recon coefficients.
+ include 'gen_filenames.cmn'
+ include 'hms_filenames.cmn'
+
+
+* Misc. variables.
+
+ integer*4 i,j,k,l,m,n,chan
+ logical*4 opened
+
+ character*132 line
+
+*============================= Executable Code ================================
+
+* Reset flag, and zero arrays.
+ err= ' '
+ ABORT = .FALSE.
+ h_recon_initted = 0
+
+
+c ! target field, vertical beam offset
+
+ do j = 1,hmax_recon_elements
+ do i = 1,4
+ h_recon_coeff(i,j) = 0.
+ h_recon_expon(i,j) = 0.
+ enddo
+ h_recon_expon(5,j) = 0.
+ enddo
+ h_ang_slope_x=0.0
+ h_ang_slope_y=0.0
+ h_ang_offset_x=0.0
+ h_ang_offset_y=0.0
+ h_det_offset_x=0.0
+ h_det_offset_y=0.0
+ h_z_true_focus=0.0
+
+ istat = 1 !Assume success.
+* Get an I/O unit to open datafiles.
+c call G_IO_control(chan,'ANY',ABORT,err) !"ASK"="ANY"
+ chan = G_LUN_TEMP
+
+* Open and read in coefficients.
+
+ if ( h_recon_coeff_filename .eq. ' ' ) then
+ h_recon_coeff_filename = 'hms_recon_coeff.dat'
+ endif
+ write(*,*) ' ********'
+ write(*,*) ' Opening HMS matrix element file ',h_recon_coeff_filename
+ write(*,*) ' ********'
+ open (unit=chan,status='old',file=h_recon_coeff_filename,err=92)
+
+
+* Read header comments.
+
+ line = '!'
+ do while (line(1:1).eq.'!')
+ read (chan,1001,err=94) line
+ enddo
+
+* Read in focal plane rotation coefficients.
+ do while (line(1:4).ne.' ---')
+ if(line(1:13).eq.'h_ang_slope_x')read(line,1201,err=94)h_ang_slope_x
+ if(line(1:13).eq.'h_ang_slope_y')read(line,1201,err=94)h_ang_slope_y
+ if(line(1:14).eq.'h_ang_offset_x')read(line,1201,err=94)h_ang_offset_x
+ if(line(1:14).eq.'h_ang_offset_y')read(line,1201,err=94)h_ang_offset_y
+ if(line(1:14).eq.'h_det_offset_x')read(line,1201,err=94)h_det_offset_x
+ if(line(1:14).eq.'h_det_offset_y')read(line,1201,err=94)h_det_offset_y
+ if(line(1:14).eq.'h_z_true_focus')read(line,1201,err=94)h_z_true_focus
+ read (chan,1001,err=94) line
+ enddo
+* Read in reconstruction coefficients and exponents.
+ line=' '
+ read (chan,1001,err=94) line
+ h_num_recon_terms = 0
+ do while (line(1:4).ne.' ---')
+ h_num_recon_terms = h_num_recon_terms + 1
+ if (h_num_recon_terms.gt.hmax_recon_elements) goto 96
+ read (line,1200,err=94) (h_recon_coeff(i,h_num_recon_terms),i=1,4)
+ $ ,(h_recon_expon(j,h_num_recon_terms),j=1,5)
+ read (chan,1001,err=94) line
+ enddo
+
+* Data read in OK.
+
+ h_recon_initted = 1
+ goto 100
+
+* File reading or data processing errors.
+
+ 92 istat = 2 !Error opening file.
+* If file does not exist, report err and then continue for development
+ err = 'error opening file '//h_recon_coeff_filename
+ call g_rep_err(ABORT,err)
+ goto 100
+
+ 94 istat = 4 !Error reading or processing data.
+ ABORT=.true.
+ err = 'error processing file '//h_recon_coeff_filename
+ goto 100
+
+ 96 istat = 6 !Too much data in file for arrays.
+ ABORT=.true.
+ err = 'too much data in file '//h_recon_coeff_filename
+ goto 100
+
+* Done with open file.
+
+ 100 close (unit=chan)
+* free lun
+c call G_IO_control(chan,'FREE',ABORT,err) !"FINISH"="FREE"
+ return
+
+*============================ Format Statements ===============================
+
+ 1001 format(a)
+ 1200 format(1x,4g16.9,1x,5i1)
+ 1201 format(17x,g16.9)
+
+ end
diff --git a/HTRACKING/h_tof.f b/HTRACKING/h_tof.f
new file mode 100644
index 0000000..12b7bc6
--- /dev/null
+++ b/HTRACKING/h_tof.f
@@ -0,0 +1,1014 @@
+ SUBROUTINE H_TOF(ABORT,errmsg)
+*--------------------------------------------------------
+*-
+*- Purpose and Methods : Analyze scintillator information for each track
+*-
+*- Required Input BANKS HMS_RAW_SCIN
+*- HMS_DECODED_SCIN
+*- HMS_FOCAL_PLANE
+*-
+*- Output BANKS HMS_TRACK_TESTS
+*-
+*- Output: ABORT - success or failure
+*- : err - reason for failure, if any
+*-
+* author: John Arrington
+* created: 2/22/94
+*
+* h_tof finds the time of flight for a particle from
+* the hodoscope TDC information. It corrects for pulse
+* height walk, time lag from the hit to the pmt signal,
+* and time offsets for each signal. It requires the
+* hodoscope ADC and TDC information, the track, and
+* the correction parameters.
+*
+* $Log: h_tof.f,v $
+* Revision 1.19.6.2.2.7 2009/03/31 19:33:00 cdaq
+* *** empty log message ***
+*
+* Revision 1.19.6.2.2.6 2008/12/11 17:11:43 cdaq
+* For gfortran compiler the arguements generic functions
+* must be the same type.
+*
+* Revision 1.19.6.2.2.5 2008/11/19 12:46:50 cdaq
+* Add line to reutrn if nparam < 1
+*
+* Revision 1.19.6.2.2.4 2008/11/17 16:03:47 cdaq
+* Fixed minor bug in printing of ADCHIST
+*
+* Revision 1.19.6.2.2.3 2008/11/17 16:00:22 cdaq
+* Major revision to do tof calibration internatlly
+*
+* Revision 1.19.6.2.2.2 2008/10/28 21:03:18 cdaq
+* Changed default betap to 1
+*
+* Revision 1.19.6.2.2.1 2008/10/27 16:34:54 cdaq
+* changes for F1 TDCs
+*
+* Revision 1.19.6.2 2007/10/26 16:44:55 pcarter
+* made the arguments to max() match data types -- GCC 4 is picky about that
+*
+* Revision 1.19.6.1 2007/10/24 16:37:16 cdaq
+* *** empty log message ***
+*
+* Revision 1.19.4.3 2007/05/16 19:50:02 cdaq
+* P. Bosted fixed bug in new code to dump TOF data
+*
+* Revision 1.19.4.2 2007/05/10 21:15:10 cdaq
+* changes for writing dump file for Peter's tof code
+*
+* Revision 1.19.4.1 2007/05/02 21:19:30 jones
+* Add new code needed for adjusting scintillator timing using P Bosted's method.
+*
+* Revision 1.19 2005/03/15 21:08:08 jones
+* Add code to filter the scintillator tdc hits and group them by time. ( P. Bosted)
+*
+* Revision 1.18 1999/06/10 16:52:12 csa
+* (JRA) Cosmetic changes
+*
+* Revision 1.17 1997/03/19 18:43:45 saw
+* (JRA) Don't neglect negative side of hodoscopes
+*
+* Revision 1.16 1996/09/04 13:36:00 saw
+* (JRA) Include actual beta in calculation of focal plane time.
+*
+* Revision 1.15 1996/01/16 22:00:15 cdaq
+* (JRA)
+*
+* Revision 1.14 1995/05/22 19:39:29 cdaq
+* (SAW) Split gen_data_data_structures into gen, hms, sos, and coin parts"
+*
+* Revision 1.13 1995/02/10 18:59:41 cdaq
+* (JRA) Add track index to hgood_plane_time, hgood_scin_time, hgood_tdc_pos,
+* and hgood_tdc_neg
+*
+* Revision 1.12 1995/02/02 16:35:25 cdaq
+* (JRA) Zero out some variables at start, minph variables now per pmt,
+* hscin_adc_pos/neg change to floats.
+*
+* Revision 1.11 1995/01/31 21:49:32 cdaq
+* (JRA) Added count of pmt's firing and cosmetic changes.
+*
+* Revision 1.10 1995/01/30 22:09:24 cdaq
+* (JRA) Cosmetic changes. Remove commented out code to dump time of
+* flight fitting data.
+*
+* Revision 1.9 1995/01/27 19:26:13 cdaq
+* (JRA) Add calculation of time for each plane. Add commented out
+* code to dump time of flight fitting data.
+*
+* Revision 1.8 1995/01/18 16:26:48 cdaq
+* (SAW) Catch negative ADC values in argument of square root
+*
+* Revision 1.7 1994/09/13 21:25:35 cdaq
+* (JRA) save extra diagnostic variables, require 2 hits/counter, add dedx
+*
+* Revision 1.6 1994/08/02 20:11:47 cdaq
+* (JRA) Some hacks
+*
+* Revision 1.5 1994/07/21 13:29:45 cdaq
+* (JRA) Correct sign on a time correction
+*
+* Revision 1.4 1994/07/08 19:43:53 cdaq
+* (JRA) Keep list of wether hits are on track or not
+*
+* Revision 1.3 1994/05/13 02:36:30 cdaq
+* (DFG) remove h_prt_track_tests call
+*
+* Revision 1.2 1994/04/13 16:28:53 cdaq
+* (DFG) Add check for zero track
+*
+* Revision 1.1 1994/02/21 16:06:29 cdaq
+* Initial revision
+*
+*--------------------------------------------------------
+ IMPLICIT NONE
+*
+ character*50 here
+ parameter (here= 'H_TOF')
+*
+ logical ABORT
+ character*(*) errmsg
+*
+ INCLUDE 'hms_data_structures.cmn'
+ INCLUDE 'gen_constants.par'
+ INCLUDE 'gen_units.par'
+ include 'hms_scin_parms.cmn'
+ include 'hms_scin_tof.cmn'
+ include 'hms_tracking.cmn'
+ integer*4 hit, trk
+ integer*4 plane,ind
+ integer*4 hntof_pairs
+ real*4 adc_ph !pulse height (channels)
+ real*4 xhit_coord,yhit_coord
+ real*4 time
+ real*4 p,betap !momentum and velocity from momentum, assuming desired mass
+ real*4 path,zcor,num_fp_time
+ real*4 sum_fp_time,sum_plane_time(hnum_scin_planes)
+ integer*4 num_plane_time(hnum_scin_planes)
+ integer timehist(200),i,j,jmax,maxhit,nfound
+ real*4 time_pos(1000),time_neg(1000),tmin,time_tolerance
+ logical keep_pos(1000),keep_neg(1000),first/.true./
+ integer nsv, idetsv(100)
+ real*8 tr0sv(100),psv(100),zcsv(100)
+ real*8 tc1sv(100),adcsv(100)
+ save
+*
+*--------------------------------------------------------
+*
+ ABORT= .FALSE.
+ errmsg = ' '
+
+ nsv = 0
+
+c if(hdumptof.eq.1) write(37,
+c > '(''ntrk,tothits''2i4,f8.3)')
+c > hntracks_fp,hscin_tot_hits,hscin_tdc_to_time
+ if(hntracks_fp.le.0 .or. hscin_tot_hits.le.0) then
+ do trk = 1 , hntracks_fp
+ hnum_scin_hit(trk) = 0
+ hnum_pmt_hit(trk) = 0
+ hbeta(trk) = 0
+ hbeta_chisq(trk) = -3
+ htime_at_fp(trk) = 0
+ enddo
+ goto 666
+ endif
+
+**MAIN LOOP: Loop over all tracks and get corrected time, tof, beta...
+ do trk = 1 , hntracks_fp
+
+** Initialize counter,flags...
+ hntof = 0
+ hntof_pairs = 0
+ sum_fp_time = 0.
+ num_fp_time = 0.
+ hnum_scin_hit(trk) = 0
+ hnum_pmt_hit(trk) = 0
+ p = hp_tar(trk)
+c if p=0, assume electrons
+ if(abs(p).lt.0.1) then
+ betap = 1.0
+ else
+ betap = p/sqrt(p*p+hpartmass*hpartmass)
+c put in check for reasonable
+ betap = min(1., max(0.3, betap))
+ endif
+ do plane = 1 , hnum_scin_planes
+ hgood_plane_time(trk,plane) = .false.
+ sum_plane_time(plane) = 0.
+ num_plane_time(plane) = 0
+ enddo
+
+! Calculate all corrected hit times and histogram
+! This uses a copy of code below. Results are save in time_pos,neg
+! including the z-pos. correction assuming nominal value of betap
+! Code is currently hard-wired to look for a peak in the
+! range of 0 to 100 nsec, with a group of times that all
+! agree withing a time_tolerance of time_tolerance nsec. The normal
+! peak position appears to be around 35 nsec.
+! NOTE: if want to find farticles with beta different than
+! reference particle, need to make sure this is big enough
+! to accomodate difference in TOF for other particles
+! Default value in case user hasnt definedd something reasonable
+ time_tolerance=20.0
+ if(htof_tolerance.gt.0.5.and.htof_tolerance.lt.10000.) then
+ time_tolerance=htof_tolerance
+ endif
+! Use wide window if dumping events for fitting
+cc if(hdumptof.eq.1) time_tolerance=25.0
+ if(first) then
+ first=.false.
+ write(*,'(1x,''Using '',f8.2,'' nsec window for'',
+ > '' hms tof and fp calculations'')') time_tolerance
+ if(hdumptof.eq.1)
+ > write(*,'(/1x,''TOF calibration being done:'',
+ > '' see output in HTOFCAL directory'')')
+ endif
+ nfound = 0
+ do j=1,200
+ timehist(j)=0
+ enddo
+ do hit = 1 , hscin_tot_hits
+ i=min(1000,hit)
+ time_pos(i)=-99.
+ time_neg(i)=-99.
+ keep_pos(i)=.false.
+ keep_neg(i)=.false.
+ plane = hscin_plane_num(hit)
+ xhit_coord = hx_fp(trk) + hxp_fp(trk)*hscin_zpos(hit)
+ yhit_coord = hy_fp(trk) + hyp_fp(trk)*hscin_zpos(hit)
+ if (plane.eq.1 .or. plane.eq.3) then !x plane
+ hscin_trans_coord(hit) = xhit_coord
+ hscin_long_coord(hit) = yhit_coord
+ else if (plane.eq.2 .or. plane.eq.4) then !y plane
+ hscin_trans_coord(hit) = yhit_coord
+ hscin_long_coord(hit) = xhit_coord
+ else !bad plane #.
+ abort = .true.
+ write(errmsg,*) 'hscin_plane_num(',hit,') = ',plane
+ call g_prepend(here,errmsg)
+ return
+ endif
+ if (abs(hscin_center_coord(hit)-hscin_trans_coord(hit))
+ & .lt.(hscin_width(hit)/2.+hscin_slop(hit))) then
+ if(hscin_tdc_pos(hit) .ge. hscin_tdc_min .and.
+ & hscin_tdc_pos(hit) .le. hscin_tdc_max) then
+ adc_ph = hscin_adc_pos(hit)
+ path = hscin_pos_coord(hit) - hscin_long_coord(hit)
+ time = hscin_tdc_pos(hit) * hscin_tdc_to_time
+ time = time - (hscin_zpos(hit)/(29.979*betap) *
+ & sqrt(1. + hxp_fp(trk)**2 + hyp_fp(trk)**2))
+ time_pos(i) = time - hscin_pos_invadc_offset(hit) -
+ > path / hscin_pos_invadc_linear(hit) -
+ > hscin_pos_invadc_adc(hit)/sqrt(max(20.,adc_ph))
+ nfound = nfound + 1
+ do j=1,200
+ tmin = 0.5*float(j)
+ if(time_pos(i) .gt. tmin .and.
+ > time_pos(i) .lt. tmin + time_tolerance)
+ > timehist(j) = timehist(j) + 1
+ enddo
+ endif
+ if (hscin_tdc_neg(hit).ge.hscin_tdc_min .and. !good tdc
+ 1 hscin_tdc_neg(hit).le.hscin_tdc_max) then
+ adc_ph = hscin_adc_neg(hit)
+ path = hscin_long_coord(hit) - hscin_neg_coord(hit)
+ time = hscin_tdc_neg(hit) * hscin_tdc_to_time
+ time = time - (hscin_zpos(hit)/(29.979*betap) *
+ & sqrt(1. + hxp_fp(trk)**2 + hyp_fp(trk)**2))
+ time_neg(i) = time - hscin_neg_invadc_offset(hit) -
+ > path / hscin_neg_invadc_linear(hit) -
+ > hscin_neg_invadc_adc(hit)/sqrt(max(20.,adc_ph))
+ nfound = nfound + 1
+ do j=1,200
+ tmin = 0.5*float(j)
+ if(time_neg(i) .gt. tmin .and.
+ > time_neg(i) .lt. tmin + time_tolerance)
+ > timehist(j) = timehist(j)+1
+ enddo
+ endif
+ endif
+ enddo
+! Find bin with most hits
+ jmax=0
+ maxhit=0
+ do j=1,200
+ if(timehist(j) .gt. maxhit) then
+ jmax = j
+ maxhit = timehist(j)
+ endif
+ enddo
+c$$$ if(hdumptof.eq.1) then
+c$$$ write(37,'(''trk='',2i3,8f8.3)') trk,jmax,
+c$$$ > hx_fp(trk),hxp_fp(trk),hy_fp(trk),hyp_fp(trk),
+c$$$ > hp_tar(trk)
+c$$$ endif
+ if(jmax.gt.0) then
+ tmin = 0.5*float(jmax)
+ do hit = 1 , hscin_tot_hits
+ i=min(1000,hit)
+ if(time_pos(i) .gt. tmin .and.
+ > time_pos(i) .lt. tmin + time_tolerance) then
+ keep_pos(i) = .true.
+ endif
+ if(time_neg(i) .gt. tmin .and.
+ > time_neg(i) .lt. tmin + time_tolerance) then
+ keep_neg(i) = .true.
+ endif
+ enddo
+ endif
+
+! Resume regular tof code, now using time filer from above
+ do hit = 1 , hscin_tot_hits
+ hgood_scin_time(trk,hit) = .false.
+ hgood_tdc_pos(trk,hit) = .false.
+ hgood_tdc_neg(trk,hit) = .false.
+ hscin_time(hit) = 0
+ hscin_sigma(hit) = 100.
+ enddo
+
+ do hit = 1 , hscin_tot_hits
+ plane = hscin_plane_num(hit)
+
+** Find hit position
+ xhit_coord = hx_fp(trk) + hxp_fp(trk)*hscin_zpos(hit)
+ yhit_coord = hy_fp(trk) + hyp_fp(trk)*hscin_zpos(hit)
+ if (plane.eq.1 .or. plane.eq.3) then !x plane
+ hscin_trans_coord(hit) = xhit_coord
+ hscin_long_coord(hit) = yhit_coord
+ else if (plane.eq.2 .or. plane.eq.4) then !y plane
+ hscin_trans_coord(hit) = yhit_coord
+ hscin_long_coord(hit) = xhit_coord
+ else !bad plane #.
+ abort = .true.
+ write(errmsg,*) 'hscin_plane_num(',hit,') = ',plane
+ call g_prepend(here,errmsg)
+ return
+ endif
+
+** Check if scin is on track
+ if (abs(hscin_center_coord(hit)-hscin_trans_coord(hit))
+ & .gt.(hscin_width(hit)/2.+hscin_slop(hit))) then
+
+ hscin_on_track(trk,hit) = .false.
+ else
+ hscin_on_track(trk,hit) = .true.
+** Check for good TDC
+ if (hscin_tdc_pos(hit) .ge. hscin_tdc_min .and.
+ & hscin_tdc_pos(hit) .le. hscin_tdc_max .and.
+ > keep_pos(hit)) then
+
+** Calculate time for each tube with a good tdc. 'pos' side first.
+ hgood_tdc_pos(trk,hit) = .true.
+ hntof = hntof + 1
+ adc_ph = hscin_adc_pos(hit)
+ path = hscin_pos_coord(hit) - hscin_long_coord(hit)
+
+* Convert TDC value to time, do pulse height correction, correction for
+* propogation of light thru scintillator, and offset.
+ time = hscin_tdc_pos(hit) * hscin_tdc_to_time
+ hscin_pos_time(hit)=time - hscin_pos_invadc_offset(hit) -
+ > path / hscin_pos_invadc_linear(hit) -
+ > hscin_pos_invadc_adc(hit)/sqrt(max(20.,adc_ph))
+ zcor = (hscin_zpos(hit)/(29.979*betap) * sqrt(1.+
+ > hxp_fp(trk)*hxp_fp(trk)+hyp_fp(trk)*hyp_fp(trk)))
+ if(hdumptof.eq.1) then
+c$$$ write(37,'(1x,''1'',2i3,5f10.3)')
+c$$$ > hscin_plane_num(hit),
+c$$$ > hscin_counter_num(hit),
+c$$$ > hscin_tdc_pos(hit) * hscin_tdc_to_time,
+c$$$ > path,zcor,
+c$$$ > hscin_pos_time(hit)-zcor,adc_ph
+ nsv = min(100, nsv + 1)
+ idetsv(nsv) = 20 * (hscin_plane_num(hit)-1) +
+ > hscin_counter_num(hit)
+ tr0sv(nsv) = hscin_tdc_pos(hit) *
+ > hscin_tdc_to_time
+ psv(nsv) = path
+ zcsv(nsv) = zcor
+ tc1sv(nsv) = hscin_pos_time(hit)-zcor
+ adcsv(nsv) = adc_ph
+ endif
+ endif
+
+** Repeat for pmts on 'negative' side
+ if (hscin_tdc_neg(hit).ge.hscin_tdc_min .and. !good tdc
+ 1 hscin_tdc_neg(hit).le.hscin_tdc_max.and.
+ > keep_neg(hit)) then
+
+ hgood_tdc_neg(trk,hit) = .true.
+ hntof = hntof + 1
+ adc_ph = hscin_adc_neg(hit)
+ path = hscin_long_coord(hit) - hscin_neg_coord(hit)
+ time = hscin_tdc_neg(hit) * hscin_tdc_to_time
+ hscin_neg_time(hit)=time - hscin_neg_invadc_offset(hit) -
+ > path / hscin_neg_invadc_linear(hit) -
+ > hscin_neg_invadc_adc(hit)/sqrt(max(20.,adc_ph))
+ zcor = (hscin_zpos(hit)/(29.979*betap) * sqrt(1.+
+ > hxp_fp(trk)*hxp_fp(trk)+hyp_fp(trk)*hyp_fp(trk)))
+c$$$ if(hdumptof.eq.1.and.hntracks_fp.eq.1.and.
+c$$$ $ timehist(max(1,jmax)).gt.6) then
+ if(hdumptof.eq.1) then
+c$$$ write(37,'(1x,''2'',2i3,5f10.3)')
+c$$$ > hscin_plane_num(hit),
+c$$$ > hscin_counter_num(hit),
+c$$$ > hscin_tdc_neg(hit) * hscin_tdc_to_time,
+c$$$ > path,zcor,
+c$$$ > hscin_neg_time(hit)-zcor,adc_ph
+ nsv = min(100, nsv + 1)
+ idetsv(nsv) = 20 * (hscin_plane_num(hit)-1) +
+ > hscin_counter_num(hit) + 100
+ tr0sv(nsv) = hscin_tdc_neg(hit) *
+ > hscin_tdc_to_time
+ psv(nsv) = path
+ zcsv(nsv) = zcor
+ tc1sv(nsv) = hscin_neg_time(hit)-zcor
+ adcsv(nsv) = adc_ph
+ endif
+ endif
+
+** Calculate ave time for scintillator and error.
+ if (hgood_tdc_pos(trk,hit)) then
+ if (hgood_tdc_neg(trk,hit)) then
+ hscin_time(hit) = (hscin_neg_time(hit) + hscin_pos_time(hit))/2.
+ hscin_sigma(hit) = max(0.1,sqrt(hscin_neg_sigma(hit)**2 +
+ 1 hscin_pos_sigma(hit)**2)/2.)
+ hgood_scin_time(trk,hit) = .true.
+ hntof_pairs = hntof_pairs + 1
+ else
+ hscin_time(hit) = hscin_pos_time(hit)
+ hscin_sigma(hit) = max(0.1,hscin_pos_sigma(hit))
+ hgood_scin_time(trk,hit) = .true.
+* hgood_scin_time(trk,hit) = .false.
+ endif
+ else ! if hgood_tdc_neg = .false.
+ if (hgood_tdc_neg(trk,hit)) then
+ hscin_time(hit) = hscin_neg_time(hit)
+ hscin_sigma(hit) = max(0.1,hscin_neg_sigma(hit))
+ hgood_scin_time(trk,hit) = .true.
+* hgood_scin_time(trk,hit) = .false.
+ endif
+ endif
+c Get time at focal plane
+ if (hgood_scin_time(trk,hit)) then
+ hscin_time_fp(hit) = hscin_time(hit)
+ & - (hscin_zpos(hit)/(29.979*betap) *
+ & sqrt(1.+hxp_fp(trk)*hxp_fp(trk)+hyp_fp(trk)*hyp_fp(trk)))
+ sum_fp_time = sum_fp_time + hscin_time_fp(hit) /
+ > hscin_sigma(hit)**2
+ num_fp_time = num_fp_time + 1./hscin_sigma(hit)**2
+ sum_plane_time(plane)=sum_plane_time(plane)
+ & +hscin_time_fp(hit)
+ num_plane_time(plane)=num_plane_time(plane)+1
+ hnum_scin_hit(trk) = hnum_scin_hit(trk) + 1
+ hscin_hit(trk,hnum_scin_hit(trk)) = hit
+ hscin_fptime(trk,hnum_scin_hit(trk)) = hscin_time_fp(hit)
+
+ if (hgood_tdc_pos(trk,hit) .and. hgood_tdc_neg(trk,hit)) then
+ hnum_pmt_hit(trk) = hnum_pmt_hit(trk) + 2
+ else
+ hnum_pmt_hit(trk) = hnum_pmt_hit(trk) + 1
+ endif
+ if (hgood_tdc_pos(trk,hit)) then
+ if (hgood_tdc_neg(trk,hit)) then
+ hdedx(trk,hnum_scin_hit(trk)) = sqrt(max(0.,
+ & hscin_adc_pos(hit)*hscin_adc_neg(hit)))
+ else
+ hdedx(trk,hnum_scin_hit(trk))=max(0.,hscin_adc_pos(hit))
+ endif
+ else
+ if (hgood_tdc_neg(trk,hit)) then
+ hdedx(trk,hnum_scin_hit(trk))=max(0.,hscin_adc_neg(hit))
+ else
+ hdedx(trk,hnum_scin_hit(trk)) = 0.
+ endif
+ endif
+ endif
+
+ endif !end of 'if scintillator was on the track'
+
+** See if there are any good time measurements in the plane.
+ if (hgood_scin_time(trk,hit)) then
+ hgood_plane_time(trk,plane) = .true. !still in loop over hits.
+ endif
+
+ enddo !end of loop over hit scintillators
+
+** Fit beta if there are enough time measurements (one upper, one lower)
+ if ((hgood_plane_time(trk,1) .or. hgood_plane_time(trk,2)) .and.
+ 1 (hgood_plane_time(trk,3) .or. hgood_plane_time(trk,4))) then
+ call h_tof_fit(abort,errmsg,trk) !fit velocity of particle
+ if (abort) then
+ call g_prepend(here,errmsg)
+ return
+ endif
+ else !cannot fit beta from given time measurements
+ hbeta(trk) = 0.
+ hbeta_chisq(trk) = -1.
+ endif
+ if (num_fp_time .ne. 0) then
+ htime_at_fp(trk) = sum_fp_time / num_fp_time
+ endif
+
+ do ind=1,4
+ if (num_plane_time(ind) .ne. 0) then
+ h_fptime(ind)=sum_plane_time(ind)/float(num_plane_time(ind))
+ else
+ h_fptime(ind)=1000.*ind
+ endif
+ enddo
+
+ h_fptimedif(1)=h_fptime(1)-h_fptime(2)
+ h_fptimedif(2)=h_fptime(1)-h_fptime(3)
+ h_fptimedif(3)=h_fptime(1)-h_fptime(4)
+ h_fptimedif(4)=h_fptime(2)-h_fptime(3)
+ h_fptimedif(5)=h_fptime(2)-h_fptime(4)
+ h_fptimedif(6)=h_fptime(3)-h_fptime(4)
+*
+* Dump tof common blocks if (hdebugprinttoftracks is set
+
+ if(hdebugprinttoftracks.ne.0 ) call h_prt_tof(trk)
+
+
+ if(hntracks_fp.gt.1000) then
+ if(trk.eq.1) write(*,'(/1x,''hms tol='',f8.2)') time_tolerance
+ write(*,'(5i3,4L2,7f7.2)') trk,nfound,jmax,timehist(max(1,jmax)),
+ > hnum_pmt_hit(trk),
+ > hgood_plane_time(trk,1),hgood_plane_time(trk,3),
+ > hgood_plane_time(trk,2),hgood_plane_time(trk,4),
+ > htime_at_fp(trk),hbeta(trk),hbeta_chisq(trk),
+ > hdelta_tar(trk),hy_tar(trk),hxp_tar(trk),hyp_tar(trk)
+ endif
+ if(hntracks_fp.eq.1.and.
+ > hdumptof.eq.1.and.
+ > timehist(max(1,jmax)).gt.6) then
+c if(hdumptof.eq.1) then
+ write(37,'(1x,''0'',2i3,5f10.3)') trk,hntracks_fp,
+ > p, betap
+ call h_tofcal_fill(nsv,idetsv,tr0sv,psv,zcsv,
+ > tc1sv,adcsv)
+ endif
+ enddo !end of loop over tracks
+
+ 666 continue
+
+ RETURN
+ END
+
+
+
+! Fit TOF for Hall C HMS with the form for each PMT:
+! tcorr = time - offset - path * velocity - adccor / sqrt(ADC)
+! where offset, velocity, and adccor are parameters
+! September 20085 P. Bosted
+! Modified to run automatically during replay: no longer
+! any need to dump large text files
+! To activate, set hdumptof = 1 in hdebug.param in
+! the PARAM directory (can also do from command line)
+! The output parameters will be in tof/hodoxxxx.param, where
+! xxxxx is the run number
+! Normal values of invadc_offset are between -50 and 50,
+! normal values of invadc_velocity are between 12 and 17 (50 is
+! default if not enough data for the fit), and normal values of
+! shodo_pos_invadc_adc are 20 to 50. Normal values of the sigmas
+! are 0.3 to 0.8 nsec.
+
+ subroutine h_tofcal_init
+! initialize common block variables at begin run
+ implicit none
+ integer i,j
+! common block variables
+ integer thist(200,10),adchist(200,18),phist(200,18)
+ integer nhit(200),ip1(200),ip2(200),ip3(200)
+ integer ipdet(600),iptyp(600),nparam
+ real*8 ax(1000,1000),bx(1000),avtime,ntime,avsig(200)
+ common/htofcal/ ax,bx,thist,adchist,phist,nhit,
+ > ip1,ip2,ip3,ipdet,iptyp,avtime,ntime,avsig,nparam
+
+ nparam=0
+ do i=1,200
+ nhit(i)=0
+ ip1(i)=0
+ ip2(i)=0
+ ip3(i)=0
+ avsig(i)=0.
+ do j=1,10
+ thist(i,j)=0
+ enddo
+ do j=1,18
+ adchist(i,j)=0
+ phist(i,j)=0
+ enddo
+ enddo
+ do i=1,600
+ ipdet(i)=0
+ iptyp(i)=0
+ enddo
+
+! Initialize the fitting arrays
+ do i=1,1000
+ bx(i)=0.
+ do j=1,1000
+ ax(i,j)=0.
+ enddo
+ enddo
+
+ avtime = 0.
+ ntime = 0.
+
+ return
+ end
+
+ subroutine h_tofcal_fill(n,idet,tr0,p,zc,tc1,adc)
+! Fill in the arrays for HMS tof cal
+! Inputs are:
+! n number of PMTs n
+! idet detector code (from 1 to 200)
+! tr0 TDCtime
+! p path length
+! zc time correction due to z
+! tc1 corrected time using current variables
+! adc ADC
+
+ implicit none
+
+! local and input variables
+ integer i,j,k,n,idt,idet(100)
+ integer k1,k2,k3,k4,k5,k6
+ real*8 tr0(100),p(100),zc(100),tc1(100),p2(100),adc(100),tr(100)
+ real*8 dt,avval
+ logical first_time/.true./
+! common block variables
+ integer thist(200,10),adchist(200,18),phist(200,18)
+ integer nhit(200),ip1(200),ip2(200),ip3(200)
+ integer ipdet(600),iptyp(600),nparam
+ real*8 ax(1000,1000),bx(1000),avtime,ntime,avsig(200)
+ common/htofcal/ ax,bx,thist,adchist,phist,nhit,
+ > ip1,ip2,ip3,ipdet,iptyp,avtime,ntime,avsig,nparam
+
+ if(first_time) then
+ first_time = .false.
+ call h_tofcal_init
+ endif
+
+! need at least 6 PMTs for fitting
+ if(n.le.5) return
+
+c write(6,'(/i3,10f6.1)') n,(tc1(i),i=1,min(10,n))
+c write(6,'(i3,10i6)') n,(idet(i),i=1,min(10,n))
+! Loop over all PMTs
+ avval = 0.
+ do i=1,n
+! Check for valid detector code
+ if(idet(i).le.0.or.idet(i).gt.200) then
+ write(6,'(''ERROR, in h_tofcal, idet='',2i8)') i,idet(i)
+ return
+ endif
+
+! Fill in ADC histograms
+ k = min(18., max(1., (adc(i)/20.)+1))
+ adchist(idet(i), k) = adchist(idet(i), k) + 1
+
+! correct raw times for zpos using betap
+ tr(i) = tr0(i)- zc(i)
+
+! Put 1./sqrt(ADC) in p2 variable
+ p2(i) = 1./sqrt(max(20., adc(i)))
+
+! Histogram path length variable
+ k = min(18, max(1, int(p(i)/7.)+1))
+ phist(idet(i), k) = phist(idet(i), k) + 1
+! average time
+ avval = avval + tc1(i)
+ enddo
+ avval = avval / float(n)
+
+! Loop over PMTS again
+! Get average h_start_time and sigmas for each PMT
+! THESE SHOULD BE DONE on a 2nd iteration of the
+! TOF calibration for a given run, setting
+! h_tof_tolerance to something small like 3 nsec
+ do j=1,n
+ nhit(idet(j))=nhit(idet(j))+1
+ avsig(idet(j)) = avsig(idet(j)) +
+ > (tc1(j) - avval)**2
+
+! If first time detector used, assign corresponding parameters
+! Note that detector 4 had has a fixed time offset (ip1) of zero
+! since all times are relative.
+ if(nhit(idet(j)).eq.1) then
+ if(idet(j).eq.4) then
+ ip1(idet(j))=0
+ else
+! fixed time offsets
+ nparam=nparam+1
+ ip1(idet(j))=nparam
+ ipdet(nparam)=idet(j)
+ iptyp(nparam)=1
+ endif
+
+! linear term in path
+! Changed 11/08 to make same for both pos. and neg. ends!
+ if(idet(j).le.100) then
+ nparam=nparam+1
+ ip2(idet(j))=nparam
+ ip2(idet(j)+100)=nparam
+ ipdet(nparam)=idet(j)
+ iptyp(nparam)=2
+ endif
+
+! 1/sqrt(adc) terms (or could be path length**2 if desired)
+ nparam=nparam+1
+ ip3(idet(j))=nparam
+ ipdet(nparam)=idet(j)
+ iptyp(nparam)=3
+ k=idet(j)
+c write(6,'(''h_tofcal_fill'',i3,4i5)')
+c > k,nhit(k),ip1(k),ip2(k),ip3(k)
+ endif
+ avtime = avtime + tc1(j)
+ ntime = ntime + 1.
+ enddo ! loop over n
+
+! now loop over all pairs in fill in the matrix
+! Also, histogram time differences using current corrections
+ do j=1,n-1
+ do k=j+1,n
+ if(ip2(idet(j)).gt.0.and.ip2(idet(k)).gt.0) then
+ dt = tc1(j)-tc1(k)
+ idt = min(10,max(1,int((dt+5.))+1))
+ thist(idet(j),idt) = thist(idet(j),idt) + 1
+ dt = tc1(k)-tc1(j)
+ idt = min(10,max(1,int((dt+5.))+1))
+ thist(idet(k),idt) = thist(idet(k),idt) + 1
+ k1 = idet(j)
+ k2 = idet(k)
+ k1=ip1(idet(j))
+ k2=ip1(idet(k))
+ k3=ip2(idet(j))
+ k4=ip2(idet(k))
+ k5=ip3(idet(j))
+ k6=ip3(idet(k))
+ if(k1.gt.0) then
+ bx(k1) = bx(k1) - (tr(j)-tr(k))
+ ax(k1,k1) = ax(k1,k1) + 1.
+ ax(k1,k3) = ax(k1,k3) + p(j)
+ ax(k1,k4) = ax(k1,k4) - p(k)
+ ax(k1,k5) = ax(k1,k5) + p2(j)
+ ax(k1,k6) = ax(k1,k6) - p2(k)
+ ax(k3,k1) = ax(k3,k1) + p(j)
+ ax(k4,k1) = ax(k4,k1) - p(k)
+ ax(k5,k1) = ax(k5,k1) + p2(j)
+ ax(k6,k1) = ax(k6,k1) - p2(k)
+ endif
+ if(k1.gt.0.and.k2.gt.0) then
+ ax(k1,k2) = ax(k1,k2) - 1.
+ ax(k2,k1) = ax(k2,k1) - 1.
+ endif
+ if(k2.gt.0) then
+ bx(k2) = bx(k2) + (tr(j)-tr(k))
+ ax(k2,k2) = ax(k2,k2) + 1.
+ ax(k2,k3) = ax(k2,k3) - p(j)
+ ax(k2,k4) = ax(k2,k4) + p(k)
+ ax(k2,k5) = ax(k2,k5) - p2(j)
+ ax(k2,k6) = ax(k2,k6) + p2(k)
+ ax(k3,k2) = ax(k3,k2) - p(j)
+ ax(k4,k2) = ax(k4,k2) + p(k)
+ ax(k5,k2) = ax(k5,k2) - p2(j)
+ ax(k6,k2) = ax(k6,k2) + p2(k)
+ endif
+ bx(k3) = bx(k3) - (tr(j)-tr(k)) * p(j)
+ bx(k4) = bx(k4) + (tr(j)-tr(k)) * p(k)
+ bx(k5) = bx(k5) - (tr(j)-tr(k)) * p2(j)
+ bx(k6) = bx(k6) + (tr(j)-tr(k)) * p2(k)
+ ax(k3,k3) = ax(k3,k3) + p(j)*p(j)
+ ax(k3,k4) = ax(k3,k4) - p(k)*p(j)
+ ax(k3,k5) = ax(k3,k5) + p2(j)*p(j)
+ ax(k3,k6) = ax(k3,k6) - p2(k)*p(j)
+ ax(k4,k3) = ax(k4,k3) - p(j)*p(k)
+ ax(k4,k4) = ax(k4,k4) + p(k)*p(k)
+ ax(k4,k5) = ax(k4,k5) - p2(j)*p(k)
+ ax(k4,k6) = ax(k4,k6) + p2(k)*p(k)
+ ax(k5,k3) = ax(k5,k3) + p(j)*p2(j)
+ ax(k5,k4) = ax(k5,k4) - p(k)*p2(j)
+ ax(k5,k5) = ax(k5,k5) + p2(j)*p2(j)
+ ax(k5,k6) = ax(k5,k6) - p2(k)*p2(j)
+ ax(k6,k3) = ax(k6,k3) - p(j)*p2(k)
+ ax(k6,k4) = ax(k6,k4) + p(k)*p2(k)
+ ax(k6,k5) = ax(k6,k5) - p2(j)*p2(k)
+ ax(k6,k6) = ax(k6,k6) + p2(k)*p2(k)
+ endif
+ enddo
+ enddo
+
+
+ return
+ end
+
+
+ subroutine h_tofcal_endrun(runno)
+! Solve simultaneous linear equations for best values of
+! tof parameters, and write to file
+! local and input variables
+ implicit none
+
+ INCLUDE 'hms_data_structures.cmn'
+ include 'hms_scin_parms.cmn'
+ include 'hms_scin_tof.cmn'
+ integer i,j,runno,iwork(1000),ifail
+ real*8 toff(200),vel(200),quad(200)
+ character*80 fname
+! common block variables
+ integer thist(200,10),adchist(200,18),phist(200,18)
+ integer nhit(200),ip1(200),ip2(200),ip3(200)
+ integer ipdet(600),iptyp(600),nparam
+ real*8 ax(1000,1000),bx(1000),avtime,ntime,avsig(200)
+ common/htofcal/ ax,bx,thist,adchist,phist,nhit,
+ > ip1,ip2,ip3,ipdet,iptyp,avtime,ntime,avsig,nparam
+
+
+! find the solutions
+ if (nparam .lt. 1) return
+ call deqn (nparam,ax,1000,iwork,ifail,1,bx)
+
+! association of parameters with detectors
+ do i=1,200
+ toff(i)=0
+ vel(i)=0.
+ quad(i)=0.
+ enddo
+
+ do i=1,nparam
+ if(iptyp(i).eq.1) toff(ipdet(i))=bx(i)
+ if(iptyp(i).eq.2) vel(ipdet(i))=bx(i)
+ if(iptyp(i).eq.2) vel(ipdet(i)+100)=bx(i)
+ if(iptyp(i).eq.3) quad(ipdet(i))=bx(i)
+ enddo
+
+
+! write solutions
+ write(fname,'(''HTOFCAL/htofcal'',i5.5,''.param'')')
+ > runno
+
+ open(unit=10,file=fname)
+
+ write(10,'(''; This parameter determines how close'',
+ > '' in time the ''/
+ > ''; corrected scint. have to be to each other. '',
+ > '' For initial calibrations, use 50. ''/
+ > ''; For final calibration,use 3. For regular '',
+ > '' running, use about 10.''/
+ > ''; Used in h_trans_scin.f and h_tof.f''/
+ > '' htof_tolerance = '',f6.1)')
+ > htof_tolerance
+
+ write(10,'(/''; This is default (average) value'',
+ > '' of start time for ''/
+ > ''; drift chambers. It is used in h_trans_scin.f''/
+ > '' hstart_time_center = '',f6.1)') avtime/
+ > max(1.,ntime)
+
+! copied from previous hhodo.param
+ write(10,'(/''; This is 1/2 width of winow'',
+ > '' on hstart_time_center''/
+ > ''; it is used in h_trans_scin.f''/
+ > '' hstart_time_slop = '',f6.1)')
+ > hstart_time_slop
+
+ write(10,'(/''; Minimum and Maximum raw TDC'',
+ > '' that will be used ''/
+ > ''; Check raw TDC spectra to make sure ok''/
+ > '' hscin_tdc_min = '',i6/
+ > '' hscin_tdc_max = '',i6)')
+ > int(hscin_tdc_min),int(hscin_tdc_max)
+
+ write(10,'(/''; TDC time in nsec per channel''/
+ > '' hscin_tdc_to_time = '',f8.4)')
+ > hscin_tdc_to_time
+
+ write(10,'(/''; Position tolerance in cm'',
+ > '' used in efficiency calcultions ''/
+ > ''; used in hms_scin_eff.f''/
+ > '' hhodo_slop = '',
+ > f5.0,'','',f5.0,'','',f5.0,'','',f5.0)')
+ > (hhodo_slop(i),i=1,4)
+
+ write(10,'(/''hhodo_pos_invadc_offset ='',3(f8.2,'',''),
+ > f8.2)') (-1.0*toff(i),i=1,80,20)
+ do j=2,16
+ write(10,'(1x,'' '',3(f8.2,'',''),
+ > f8.2)')(-1.0*toff(i),i=j,79+j,20)
+ enddo
+
+ write(10,'(/''hhodo_neg_invadc_offset ='',3(f8.2,'',''),
+ > f8.2)')(-1.0*toff(i),i=101,180,20)
+ do j=2,16
+ write(10,'(1x,'' '',3(f8.2,'',''),
+ > f8.2)')(-1.0*toff(i),i=100+j,179+j,20)
+ enddo
+
+ write(10,'(/''hhodo_pos_invadc_linear ='',3(f8.2,'',''),
+ > f8.2)')( -1./min(-0.02,vel(i)),i=1,80,20)
+ do j=2,16
+ write(10,'(1x,'' '',3(f8.2,'',''),
+ > f8.2)')(-1./min(-0.02,vel(i)),i=j,79+j,20)
+ enddo
+
+ write(10,'(/''hhodo_neg_invadc_linear ='',3(f8.2,'',''),
+ > f8.2)')( -1./min(-0.02,vel(i)),i=101,180,20)
+ do j=2,16
+ write(10,'(1x,'' '',3(f8.2,'',''),
+ > f8.2)')(-1./min(-0.02,vel(i)),i=100+j,179+j,20)
+ enddo
+
+ write(10,'(/''hhodo_pos_invadc_adc='',3(f9.2,'',''),
+ > f9.2)')(-1.*quad(i),i=1,80,20)
+ do j=2,16
+ write(10,'(1x,'' '',3(f9.2,'',''),
+ > f9.2)')(-1.*quad(i),i=j,79+j,20)
+ enddo
+
+ write(10,'(/''hhodo_neg_invadc_adc='',3(f9.2,'',''),
+ > f9.2)')(-1.0*quad(i),i=101,180,20)
+ do j=2,16
+ write(10,'(1x,'' '',3(f9.2,'',''),
+ > f9.2)')(-1.*quad(i),i=100+j,179+j,20)
+ enddo
+
+ do i=1,200
+ avsig(i) = avsig(i) / max(1,nhit(i))
+ enddo
+
+ write(10,'(/''hhodo_pos_sigma ='',3(f8.2,'',''),
+ > f8.2)') (max(0.1,min(100.,avsig(i))),i=1,80,20)
+ do j=2,16
+ write(10,'(1x,'' '',3(f8.2,'',''),
+ > f8.2)')(max(0.1,min(100.,avsig(i))),i=j,79+j,20)
+ enddo
+
+ write(10,'(/''hhodo_neg_sigma ='',3(f8.2,'',''),
+ > f8.2)') (max(0.3,min(100.,avsig(i))),i=101,180,20)
+ do j=2,16
+ write(10,'(1x,'' '',3(f8.2,'',''),
+ > f8.2)')(max(0.3,min(100.,avsig(i))),i=100+j,179+j,20)
+ enddo
+
+ write(10,'(/''hhodo_pos_ped_limit = 1000,'',
+ > ''1000,1000,1000,1000,1000,1000,1000''/
+ > 22x,''1000,1000,1000,1000,1000,1000,1000,1000''/
+ > 22x,''1000,1000,1000,1000,1000,1000,1000,1000''/
+ > 22x,''1000,1000,1000,1000,1000,1000,1000,1000''/
+ > 22x,''1000,1000,1000,1000,1000,1000,1000,1000''/
+ > 22x,''1000,1000,1000,1000,1000,1000,1000,1000''/
+ > 22x,''1000,1000,1000,1000,1000,1000,1000,1000''/
+ > 22x,''1000,1000,1000,1000,1000,1000,1000,1000'')')
+
+ write(10,'(/''hhodo_neg_ped_limit = 1000,'',
+ > ''1000,1000,1000,1000,1000,1000,1000''/
+ > 22x,''1000,1000,1000,1000,1000,1000,1000,1000''/
+ > 22x,''1000,1000,1000,1000,1000,1000,1000,1000''/
+ > 22x,''1000,1000,1000,1000,1000,1000,1000,1000''/
+ > 22x,''1000,1000,1000,1000,1000,1000,1000,1000''/
+ > 22x,''1000,1000,1000,1000,1000,1000,1000,1000''/
+ > 22x,''1000,1000,1000,1000,1000,1000,1000,1000''/
+ > 22x,''1000,1000,1000,1000,1000,1000,1000,1000'')')
+
+ close(unit=10)
+
+! Diagnositc information
+ write(fname,'(''HTOFCAL/htofcal'',i5.5,''.diag'')')
+ > runno
+ open(unit=10,file=fname)
+
+ write(10,'(1x,''ifail='',i10,
+ > '' (desired value is 0 if fit worked)'')') ifail
+
+ do i=1,100
+ if(nhit(i).gt.0 .or.nhit(100+i).gt.0.) then
+ write(10,'(i3,2i6,6f7.1)') i,nhit(i),nhit(100+i),
+ > -toff(i),-toff(100+i),-1./vel(i),-1./vel(100+i),
+ > -quad(i),-quad(100+i)
+ endif
+ enddo
+ write(10,'(''ADCHIST'')')
+ do i=1,200
+ if(nhit(i).gt.0) write(10,'(i4,16i4)')
+ > i,(adchist(i,j)/10,j=1,16)
+ enddo
+ write(10,'(''THIST'')')
+ do i=1,200
+ if(nhit(i).gt.0) write(10,'(i4,10i5)')
+ > i,(thist(i,j)/100,j=1,10)
+ enddo
+ write(10,'('' PHIST'')')
+ do i=1,200
+ if(nhit(i).gt.0) write(10,'(i4,16i4)')
+ > i,(phist(i,j)/20,j=1,16)
+ enddo
+
+ close(unit=10)
+
+ return
+ end
+
diff --git a/HTRACKING/h_tof_fit.f b/HTRACKING/h_tof_fit.f
new file mode 100644
index 0000000..f4d1a6b
--- /dev/null
+++ b/HTRACKING/h_tof_fit.f
@@ -0,0 +1,110 @@
+ subroutine h_tof_fit(abort,errmsg,trk)
+
+*-------------------------------------------------------------------
+* author: John Arrington
+* created: 2/22/94
+*
+* h_tof_fit fits the velocity of the paritcle from the corrected
+* times generated by h_tof.
+*
+* modifications:
+* $Log: h_tof_fit.f,v $
+* Revision 1.10 1996/09/04 13:36:24 saw
+* (JRA) Include actual beta in calculation of focal plane time.
+*
+* Revision 1.9 1995/05/22 19:39:29 cdaq
+* (SAW) Split gen_data_data_structures into gen, hms, sos, and coin parts"
+*
+* Revision 1.8 1995/02/23 13:29:15 cdaq
+* (SAW) Cosmetic Changes
+*
+* Revision 1.7 1995/02/10 18:49:57 cdaq
+* (JRA) Add track index to hgood_scin_time
+*
+* Revision 1.6 1994/09/13 21:26:53 cdaq
+* (JRA) fix chisq calculation
+*
+* Revision 1.5 1994/07/13 15:05:08 cdaq
+* (SAW) Add abs around tmpdenom that I left out last update
+*
+* Revision 1.4 1994/07/11 18:34:35 cdaq
+* (JRA) Increase comparison of tmpdenom from 1e-15 to 1e-10
+*
+* Revision 1.3 1994/07/08 19:42:31 cdaq
+* (JRA) Change fit from velocity to beta. Bad fits give beta=0
+*
+* Revision 1.2 1994/06/14 04:53:41 cdaq
+* (DFG) Protect against divide by 0 in beta calc
+*
+* Revision 1.1 1994/04/13 16:29:15 cdaq
+* Initial revision
+*
+*-------------------------------------------------------------------
+
+ implicit none
+
+ include 'hms_data_structures.cmn'
+ include 'hms_scin_parms.cmn'
+ include 'hms_scin_tof.cmn'
+
+ logical abort
+ character*1024 errmsg
+ character*20 here
+ parameter (here = 'h_tof_fit')
+
+ real*4 sumw, sumt, sumz, sumzz, sumtz
+ real*4 scin_weight
+ real*4 tmp, t0 ,tmpdenom
+ real*4 pathnorm
+ integer*4 hit, trk
+ save
+
+ sumw = 0.
+ sumt = 0.
+ sumz = 0.
+ sumzz = 0.
+ sumtz = 0.
+
+ do hit = 1 , hscin_tot_hits
+ if (hgood_scin_time(trk,hit)) then
+ scin_weight = 1./hscin_sigma(hit)**2
+ sumw = sumw + scin_weight
+ sumt = sumt + scin_weight * hscin_time(hit)
+ sumz = sumz + scin_weight * hscin_zpos(hit)
+ sumzz = sumzz + scin_weight * hscin_zpos(hit)**2
+ sumtz = sumtz + scin_weight * hscin_zpos(hit) *
+ 1 hscin_time(hit)
+ endif
+ enddo
+
+* The formula for beta (and t0) come from taking chi-squared (as
+* defined below), and differentiating with respect to each
+* of the fit paramters (beta and t0 for fit to z=beta*(t-t0)).
+* Setting both of these derivatives to zero gives the minumum
+* chisquared (since they are quadratic in beta and t0), and
+* gives a solution for beta in terms of sums of z, t, and w.
+
+ tmp = sumw*sumzz - sumz*sumz
+ t0 = (sumt*sumzz - sumz*sumtz) / tmp
+ tmpdenom = sumw*sumtz - sumz*sumt
+ if(abs(tmpdenom) .gt. 1.e-10) then
+ hbeta(trk) = tmp / tmpdenom !velocity in cm/ns.
+ hbeta_chisq(trk) = 0.
+ do hit = 1 , hscin_tot_hits
+ if (hgood_scin_time(trk,hit)) then
+ hbeta_chisq(trk) = hbeta_chisq(trk) +
+ 1 (hscin_zpos(hit)/hbeta(trk) -
+ 1 (hscin_time(hit) - t0))**2 / hscin_sigma(hit)**2
+ endif
+ enddo
+
+ pathnorm = sqrt(1 + hxp_fp(trk)**2 + hyp_fp(trk)**2)
+ hbeta(trk) = hbeta(trk) * pathnorm !take angle into account
+ hbeta(trk) = hbeta(trk) / 29.979 !velocity/c
+ else
+ hbeta(trk) = 0. ! set unphysical beta
+ hbeta_chisq(trk) = -2
+ endif ! end if on denomimator = 0.
+
+ return
+ end
diff --git a/HTRACKING/h_tof_init.f b/HTRACKING/h_tof_init.f
new file mode 100644
index 0000000..d4be5f7
--- /dev/null
+++ b/HTRACKING/h_tof_init.f
@@ -0,0 +1,120 @@
+ subroutine h_tof_init(abort,err)
+
+*-------------------------------------------------------------------
+* author: John Arrington
+* created: 2/22/94
+*
+* h_tof_init sets up the track independant parameters
+* for fitting the tof of the particle.
+*
+* modifications: 31 Mar 1994 DFG Check for 0 hits
+* $Log: h_tof_init.f,v $
+* Revision 1.6.24.1.2.1 2008/11/17 15:58:44 cdaq
+* Removed old tof varaibles
+*
+* Revision 1.6.24.1 2007/10/24 16:37:16 cdaq
+* *** empty log message ***
+*
+* Revision 1.6.22.1 2007/05/02 21:18:09 jones
+* Add new code needed for adjusting scintillator timing using P Bosted's method.
+*
+* Revision 1.6 1995/05/22 19:39:30 cdaq
+* (SAW) Split gen_data_data_structures into gen, hms, sos, and coin parts"
+*
+* Revision 1.5 1995/02/21 16:57:28 cdaq
+* (JRA) Change hhodo_center_coord to hhodo_center
+*
+* Revision 1.4 1995/02/02 16:12:50 cdaq
+* (JRA) Make minph variables into per pmt constants
+*
+* Revision 1.3 1994/09/13 21:30:01 cdaq
+* (JRA) Add staggering of scintillator counters
+*
+* Revision 1.2 1994/06/01 15:39:34 cdaq
+* (SAW) Change declaration of err to *(*)
+*
+* Revision 1.1 1994/04/13 16:29:31 cdaq
+* Initial revision
+*
+*-------------------------------------------------------------------
+
+ implicit none
+
+ include 'hms_data_structures.cmn'
+ include 'hms_scin_parms.cmn'
+ include 'hms_scin_tof.cmn'
+
+ logical abort
+ character*(*) err
+ character*20 here
+ parameter (here = 'h_tof_init')
+
+ integer*4 ihit,plane,counter
+ save
+
+ if(hscin_tot_hits.gt.0) then
+ do ihit = 1 , hscin_tot_hits
+
+ plane = hscin_plane_num(ihit) !from h_raw_scin common block.
+ counter = hscin_counter_num(ihit)
+
+ hscin_slop(ihit) = hhodo_slop(plane)
+ hscin_pos_sigma(ihit) = hhodo_pos_sigma(plane,counter)
+ hscin_neg_sigma(ihit) = hhodo_neg_sigma(plane,counter)
+ hscin_center_coord(ihit) = hhodo_center(plane,counter)
+ hscin_pos_invadc_offset(ihit) =
+ > hhodo_pos_invadc_offset(plane,counter)
+ hscin_neg_invadc_offset(ihit) =
+ > hhodo_neg_invadc_offset(plane,counter)
+ hscin_pos_invadc_linear(ihit) =
+ > max(10.,hhodo_pos_invadc_linear(plane,counter))
+ hscin_neg_invadc_linear(ihit) =
+ > max(10.,hhodo_neg_invadc_linear(plane,counter))
+ hscin_pos_invadc_adc(ihit) =
+ > hhodo_pos_invadc_adc(plane,counter)
+ hscin_neg_invadc_adc(ihit) =
+ > hhodo_neg_invadc_adc(plane,counter)
+
+ if (plane .eq. 1) then !1x
+ hscin_zpos(ihit) = hscin_1x_zpos
+ if (2*int(float(counter)/2.) .eq. counter) then !even tube, in back.
+ hscin_zpos(ihit) = hscin_zpos(ihit) + hscin_1x_dzpos
+ endif
+ hscin_pos_coord(ihit) = hscin_1x_left
+ hscin_neg_coord(ihit) = hscin_1x_right
+ hscin_width(ihit) = hscin_1x_size
+ else if (plane .eq. 2) then !1y
+ hscin_zpos(ihit) = hscin_1y_zpos
+ if (2*int(float(counter)/2.) .eq. counter) then !even tube, in back.
+ hscin_zpos(ihit) = hscin_zpos(ihit) + hscin_1y_dzpos
+ endif
+ hscin_pos_coord(ihit) = hscin_1y_bot
+ hscin_neg_coord(ihit) = hscin_1y_top
+ hscin_width(ihit) = hscin_1y_size
+ else if (plane .eq. 3) then !2x
+ hscin_zpos(ihit) = hscin_2x_zpos
+ if (2*int(float(counter)/2.) .eq. counter) then !even tube, in back.
+ hscin_zpos(ihit) = hscin_zpos(ihit) + hscin_2x_dzpos
+ endif
+ hscin_pos_coord(ihit) = hscin_2x_left
+ hscin_neg_coord(ihit) = hscin_2x_right
+ hscin_width(ihit) = hscin_2x_size
+ else if (plane .eq. 4) then !2y
+ hscin_zpos(ihit) = hscin_2y_zpos
+ if (2*int(float(counter)/2.) .eq. counter) then !even tube, in back.
+ hscin_zpos(ihit) = hscin_zpos(ihit) + hscin_2y_dzpos
+ endif
+ hscin_pos_coord(ihit) = hscin_2y_bot
+ hscin_neg_coord(ihit) = hscin_2y_top
+ hscin_width(ihit) = hscin_2y_size
+ else
+ abort = .true.
+ write(err,*) 'Trying to init. hms hodoscope plane',plane
+ call g_prepend(here,err)
+ return
+ endif
+
+ enddo
+ endif ! end test on zero hits
+ return
+ end
diff --git a/HTRACKING/h_track.f b/HTRACKING/h_track.f
new file mode 100644
index 0000000..073d027
--- /dev/null
+++ b/HTRACKING/h_track.f
@@ -0,0 +1,122 @@
+ SUBROUTINE H_TRACK(ABORT,err)
+*--------------------------------------------------------
+*-
+*- Purpose and Methods : Finds and fits tracks in HMS focal plane
+*-
+*- Required Input BANKS HMS_DECODED_DC
+*-
+*- Output BANKS HMS_FOCAL_PLANE
+*- HMS_DECODED_DC hit coordinates
+*-
+*- Output: ABORT - success or failure
+*- : err - reason for failure, if any
+*-
+*- Created 19-JAN-1994 D. F. Geesaman
+* $Log: h_track.f,v $
+* Revision 1.5.26.3 2011/10/25 16:12:30 jones
+* Elminate unneed variables and include files
+*
+* Revision 1.5.26.2 2011/10/25 16:07:07 jones
+* back to original h_track.f wihtout trying to do only one stub.
+*
+* Revision 1.5.26.1 2009/09/15 20:37:39 jones
+* Add code to track with single stub
+*
+* Revision 1.5 1996/09/04 13:37:02 saw
+* (JRA) Initialize hstubmin variables
+*
+* Revision 1.4 1995/10/11 12:19:50 cdaq
+* (JRA) Only call tracking routines when it is warranted
+*
+* Revision 1.3 1995/05/22 19:39:30 cdaq
+* (SAW) Split gen_data_data_structures into gen, hms, sos, and coin parts"
+*
+* Revision 1.2 1994/04/13 17:07:57 cdaq
+* (DFG) Added histograming call (h_fill_dc_fp_hist)
+*
+* Revision 1.1 1994/02/19 06:20:31 cdaq
+* Initial revision
+*
+*--------------------------------------------------------
+ IMPLICIT NONE
+ SAVE
+*
+ character*7 here
+ parameter (here= 'H_TRACK')
+*
+ logical ABORT
+ character*(*) err
+ integer*4 ierr
+ character*5 line_err
+*
+ INCLUDE 'hms_data_structures.cmn'
+ INCLUDE 'hms_tracking.cmn'
+ INCLUDE 'gen_constants.par'
+ INCLUDE 'gen_units.par'
+
+*
+*--------------------------------------------------------
+*
+*
+ ABORT = .false.
+ err = ' '
+
+ if (hdc_tot_hits.ne.0) then
+ call H_PATTERN_RECOGNITION(ABORT,err)
+ if(ABORT) then
+ call G_add_path(here,err)
+ return
+ endif
+
+*
+ if (hnspace_points_tot.ne.0) then
+ call H_LEFT_RIGHT(ABORT,err)
+ if(ABORT) then
+ call G_add_path(here,err)
+ return
+ endif
+*
+ hstubminx = 999999.
+ hstubminy = 999999.
+ hstubminxp = 999999.
+ hstubminyp = 999999.
+ call H_LINK_STUBS(ABORT,err)
+ if(ABORT) then
+ call G_add_path(here,err)
+ return
+ endif
+*
+ if (hntracks_fp.ne.0) then
+ call H_TRACK_FIT(ABORT,err,ierr)
+ if(ABORT) then
+ call G_add_path(here,err)
+ return
+ endif
+
+* Check for internal error in H_TRACK_FIT
+ if(ierr.ne.0) then
+ line_err=' '
+ call CSETDI(ierr,line_err,1,5)
+ err='ERROR IN H_TRACK_FIT' // line_err
+ call G_add_path(here,err)
+ call G_LOG_MESSAGE(err)
+ endif
+* histogram focal plane tracks
+*
+ call h_fill_dc_fp_hist(ABORT,err)
+ if(ABORT) then
+ call g_add_path(here,err)
+ return
+ endif
+*
+ endif !(hntracks_fp.ne.0)
+ endif !(hnspace_points_tot.ne.0)
+ endif !(hdc_tot_hits.ne.0)
+
+
+ return
+ end
+
+
+
+
diff --git a/HTRACKING/h_track_fit.f b/HTRACKING/h_track_fit.f
new file mode 100644
index 0000000..c3a5cdb
--- /dev/null
+++ b/HTRACKING/h_track_fit.f
@@ -0,0 +1,243 @@
+ subroutine H_TRACK_FIT(ABORT,err,ierr)
+* primary track fitting routine for the HMS spectrometer
+*
+* Called by H_TRACK
+*
+* d.f. geesaman 17 January 1994
+* modified
+* 17 Feb 1994 dfg
+* remove minuit. Make fit linear
+* still does not do errors properly
+* $Log: h_track_fit.f,v $
+* Revision 1.11 1996/01/16 21:42:18 cdaq
+* (JRA) Remove slices code, misc fixes, reindent.
+*
+* Revision 1.10 1995/08/30 16:11:39 cdaq
+* (JRA) Don't fill single_residual arrray
+*
+* Revision 1.9 1995/05/22 19:39:31 cdaq
+* (SAW) Split gen_data_data_structures into gen, hms, sos, and coin parts"
+*
+* Revision 1.8 1995/04/06 19:32:58 cdaq
+* (JRA) Rename residuals variables
+*
+* Revision 1.7 1995/01/27 20:26:50 cdaq
+* (JRA) Remove Mack's personal focalplane diceamatic (z slicer) code
+*
+* Revision 1.6 1994/12/06 15:45:27 cdaq
+* (DJM) Take slices in Z to look for best focus
+*
+* Revision 1.5 1994/10/12 18:52:06 cdaq
+* (DJM) Initialize some variables
+* (SAW) Prettify indentation
+*
+* Revision 1.4 1994/09/01 12:29:07 cdaq
+* (DJM) Make registered versions of residuals
+*
+* Revision 1.3 1994/08/18 02:45:53 cdaq
+* (DM) Add calculation of residuals
+*
+* Revision 1.2 1994/02/22 05:25:00 cdaq
+* (SAW) Remove dfloat calls with floating args
+*
+* Revision 1.1 1994/02/19 06:20:53 cdaq
+* Initial revision
+*
+*
+ implicit none
+ include "hms_data_structures.cmn"
+ include "hms_tracking.cmn"
+ include "hms_geometry.cmn"
+ external h_dpsifun
+*
+*
+* local variables
+*
+ logical ABORT
+ character*11 here
+ parameter (here='H_TRACK_FIT')
+ character*(*) err
+ integer*4 itrk ! track loop index
+ integer*4 ihit,ierr
+ integer*4 hit,pln
+ integer*4 i,j ! loop index
+* real*4 z_slice
+
+ real*8 h_dpsifun
+ real*8 pos
+ real*8 ray1(4)
+ real*8 ray2(4)
+ real*8 TT(hnum_fpray_param)
+ real*8 AA(hnum_fpray_param,hnum_fpray_param)
+ real*8 dray(hnum_fpray_param)
+ real*4 chi2,dummychi2
+ parameter (dummychi2 = 1.E4)
+* array to remap hplane_coeff to param number
+ integer*4 remap(hnum_fpray_param)
+ data remap/5,6,3,4/
+ save remap
+*
+ ABORT= .FALSE.
+ ierr=0
+* initailize residuals
+
+ do pln=1,hdc_num_planes
+ do itrk=1,hntracks_fp
+ hdc_double_residual(itrk,pln)=1000
+ hdc_single_residual(itrk,pln)=1000
+ enddo
+c fill the 1d arrays from the 2d arrays for good track (in h_physics)
+c hdc_sing_res(pln)=1000
+ hdc_dbl_res(pln)=1000
+ enddo
+
+* test for no tracks
+ if(hntracks_fp.ge.1) then
+ do itrk=1,hntracks_fp
+ chi2= dummychi2
+ htrack_fit_num=itrk
+
+* are there enough degrees of freedom
+ hnfree_fp(itrk)=hntrack_hits(itrk,1)-hnum_fpray_param
+ if(hnfree_fp(itrk).gt.0) then
+
+* initialize parameters
+ do i=1,hnum_fpray_param
+ TT(i)=0.
+ do ihit=2,hntrack_hits(itrk,1)+1
+ hit=hntrack_hits(itrk,ihit)
+ pln=hdc_plane_num(hit)
+ TT(i)=TT(i)+((hdc_wire_coord(hit)*
+ & hplane_coeff(remap(i),pln))
+ & /(hdc_sigma(pln)*hdc_sigma(pln)))
+ enddo
+ enddo
+ do i=1,hnum_fpray_param
+ do j=1,hnum_fpray_param
+ AA(i,j)=0.
+ if(j.lt.i)then
+ AA(i,j)=AA(j,i)
+ else
+ do ihit=2,hntrack_hits(itrk,1)+1
+ hit=hntrack_hits(itrk,ihit)
+ pln=hdc_plane_num(hit)
+ AA(i,j)=AA(i,j) + (
+ & hplane_coeff(remap(i),pln)*hplane_coeff(remap(j)
+ $ ,pln)/(hdc_sigma(pln)*hdc_sigma(pln)))
+ enddo ! end loop on ihit
+ endif ! end test on j .lt. i
+ enddo ! end loop on j
+ enddo ! end loop on i
+*
+* solve four by four equations
+ call solve_four_by_four(TT,AA,dray,ierr)
+*
+ if(ierr.ne.0) then
+ dray(1)=10000.
+ dray(2)=10000.
+ dray(3)=2.
+ dray(4)=2.
+ else
+* calculate chi2
+ chi2=0.
+
+* calculate hit coord at each plane for chisquared and efficiency calculations.
+ do pln=1,hdc_num_planes
+ hdc_track_coord(itrk,pln)=hplane_coeff(remap(1),pln)*dray(1)
+ & +hplane_coeff(remap(2),pln)*dray(2)
+ & +hplane_coeff(remap(3),pln)*dray(3)
+ & +hplane_coeff(remap(4),pln)*dray(4)
+ enddo
+
+ do ihit=2,hntrack_hits(itrk,1)+1
+ hit=hntrack_hits(itrk,ihit)
+ pln=hdc_plane_num(hit)
+
+* note chi2 is single precision
+
+ hdc_single_residual(itrk,pln)=
+ & hdc_wire_coord(hit)-hdc_track_coord(itrk,pln)
+ chi2=chi2+
+ & (hdc_single_residual(itrk,pln)/hdc_sigma(pln))**2
+ enddo
+ endif
+
+ hx_fp(itrk)=dray(1)
+ hy_fp(itrk)=dray(2)
+ hz_fp(itrk)=0. ! z=0 of tracking.
+ hxp_fp(itrk)=dray(3)
+ hyp_fp(itrk)=dray(4)
+ endif ! end test on degrees of freedom
+ hchi2_fp(itrk)=chi2
+ enddo ! end loop over tracks
+ endif
+
+* calculate residuals for each chamber if in single stub mode
+* and there were 2 tracks found one in first chanber and one in the second
+
+ if (hsingle_stub.ne.0) then
+ if (hntracks_fp.eq.2) then
+ itrk=1
+ ihit=2
+ hit=hntrack_hits(itrk,ihit)
+ pln=hdc_plane_num(hit)
+ if (pln.le.6) then
+ itrk=2
+ hit=hntrack_hits(itrk,ihit)
+ pln=hdc_plane_num(hit)
+ if (pln.ge.7) then
+
+* condition of above met calculating residuals
+* assigning rays to tracks in each chamber
+* ray1 is ray from first chamber fit
+* ray2 is ray from second chamber fit
+
+ ray1(1)=dble(hx_fp(1))
+ ray1(2)=dble(hy_fp(1))
+ ray1(3)=dble(hxp_fp(1))
+ ray1(4)=dble(hyp_fp(1))
+ ray2(1)=dble(hx_fp(2))
+ ray2(2)=dble(hy_fp(2))
+ ray2(3)=dble(hxp_fp(2))
+ ray2(4)=dble(hyp_fp(2))
+
+ itrk=1
+* loop over hits in second chamber
+ do ihit=1,hntrack_hits(itrk+1,1)
+
+* calculate residual in second chamber from first chamber track
+ hit=hntrack_hits(itrk+1,ihit+1)
+ pln=hdc_plane_num(hit)
+ pos=h_dpsifun(ray1,pln)
+ hdc_double_residual(itrk,pln)=hdc_wire_coord(hit)-pos
+* djm 8/31/94 stuff this variable into 1d array we can register
+ hdc_dbl_res(pln) = hdc_double_residual(1,pln)
+
+ enddo
+
+ itrk=2
+* loop over hits in first chamber
+ do ihit=1,hntrack_hits(itrk-1,1)
+
+* calculate residual in first chamber from second chamber track
+ hit=hntrack_hits(itrk-1,ihit+1)
+ pln=hdc_plane_num(hit)
+ pos=h_dpsifun(ray2,pln)
+ hdc_double_residual(itrk,pln)=hdc_wire_coord(hit)-pos
+* djm 8/31/94 stuff this variable into 1d array we can register
+ hdc_dbl_res(pln) = hdc_double_residual(2,pln)
+
+ enddo
+ endif ! end pln ge 7
+ endif ! end pln le 6
+ endif ! end hntracks_fp eq 2
+ endif ! end hsignle_stub .ne. 0
+
+* test if we want to dump out trackfit results
+ if(hdebugtrackprint.ne.0) then
+ call h_print_tracks
+ endif ! end test on zero tracks
+ 1000 return
+ end
+
+*
diff --git a/HTRACKING/h_track_tests.f b/HTRACKING/h_track_tests.f
new file mode 100644
index 0000000..4be87b7
--- /dev/null
+++ b/HTRACKING/h_track_tests.f
@@ -0,0 +1,399 @@
+ SUBROUTINE h_track_tests
+*
+* Derek made this in Mar 1996
+*
+* This routine delivers some handy tracking information. It's divided
+* into three parts. The first part looks at the chambers and their
+* efficiency. The second part defines some scintillator tests to determine
+* whether the chambers should have fired. The last part puts this info
+* into different files. Also, if you want to look at the stub tests you
+* you can uncomment some lines in h_link_stubs.f to get that output.
+* A final note. Many of these tests have similar counterparts in
+* trackeff.test; if you change something here, make sure it agrees with the
+* the tests there!!
+*
+* $Log: h_track_tests.f,v $
+* Revision 1.4 2005/11/15 18:39:18 jones
+* 1) Eliminate statements which checked if scintillator hits
+* where outside "good" region.
+* 2) Eliminate check that front and back hodoscope hits
+* near each other.
+* 3) These changes eliminate a bias in the routine in favor
+* of one-track events which gives wrong tracking efficiency
+* at high rates.
+* ( T.Horn, M.E. Christy, D. Gaskell)
+*
+* Revision 1.3 2002/09/26 14:50:10 jones
+* Add variables sweet1xscin,sweet1yscin,sweet2xscin,sweet2yscin
+* which record which scint got hit inside the defined scint region
+* Then hgoodscinhits is set to zero if front and back hodoscopes
+* are abs(sweet1xscin-sweet2xscin).gt.3 or bs(sweet1yscin-sweet2yscin).gt.2
+*
+* Revision 1.2 1996/09/04 13:39:02 saw
+* (JRA) Treat logicals as logicals
+*
+* Revision 1.1 1996/05/01 20:24:29 saw
+* Initial revision
+*
+ IMPLICIT NONE
+ SAVE
+
+ character*50 here
+ parameter (here= 'H_TRACK_TESTS')
+
+* logical ABORT
+* character*(*) err
+* integer*4 ierr
+* character*5 line_err
+*
+ INCLUDE 'hms_data_structures.cmn'
+ INCLUDE 'coin_data_structures.cmn'
+ INCLUDE 'gen_constants.par'
+ INCLUDE 'hms_tracking.cmn'
+ INCLUDE 'gen_units.par'
+ INCLUDE 'gen_event_info.cmn'
+ INCLUDE 'hms_scin_tof.cmn'
+ INCLUDE 'hms_scin_parms.cmn'
+ INCLUDE 'hms_calorimeter.cmn'
+ include 'hms_bypass_switches.cmn'
+
+ integer planetemp
+ real*4 htestbeta
+ integer txth,txthp,txthps,txthpss,txtft,txtct
+
+ integer i,j,count
+ integer testsum
+ integer hhitsweet1x,hhitsweet1y,hhitsweet2x,hhitsweet2y
+ integer sweet1xscin,sweet1yscin,sweet2xscin,sweet2yscin
+
+ real*4 lastcointime
+ real*4 thiscointime
+
+*In c_keep_results, the cointime is updated depending on tracking information
+*Because we're independent of tracking here, we have to do some tricks to
+*update the cointime. We set cointime=100.0 if the code hasn't updated it (ie,
+*it's the same as the previous event...) First, if it's not a coincidence
+*event, we just set the cointime to zero.
+
+ thiscointime=0.0
+ if (gen_event_type.eq.3) then
+ thiscointime=ccointime_hms
+ if (thiscointime.eq.lastcointime) then
+ thiscointime=100.0
+ endif
+ lastcointime=ccointime_hms
+ endif
+
+
+*this next file prints out events the fail to track and why. You can then
+*look at them with the event display to see if they're worrisome. If you
+*uncomment this line, be sure to uncomment the close statement at the end
+*of this file!
+ if (hbypass_track_eff_files.eq.0) then
+ open(unit=12,file='scalers/htrackeff.txt',status='unknown',
+ $ access='append')
+ endif
+
+*this next file outputs a huge ascii file with many tracking parameters. It
+*is intended for use with physica. The order of the ouput is given in the write
+*statement at the end of this file. I fyou uncomment this line, be sure to
+*uncomment the close statement at the end of this file!
+ if (hbypass_track_eff_files.eq.0) then
+ open(unit=14,file='scalers/htrack.out',status='unknown',
+ $ access='append')
+ endif
+
+*we start by looking at the chambers. First, we look to see if each plane fired
+
+ h1hit1 = (HDC_HITS_PER_PLANE(1).GE.1)
+ h1hit2 = (HDC_HITS_PER_PLANE(2).GE.1)
+ h1hit3 = (HDC_HITS_PER_PLANE(3).GE.1)
+ h1hit4 = (HDC_HITS_PER_PLANE(4).GE.1)
+ h1hit5 = (HDC_HITS_PER_PLANE(5).GE.1)
+ h1hit6 = (HDC_HITS_PER_PLANE(6).GE.1)
+ h1hit7 = (HDC_HITS_PER_PLANE(7).GE.1)
+ h1hit8 = (HDC_HITS_PER_PLANE(8).GE.1)
+ h1hit9 = (HDC_HITS_PER_PLANE(9).GE.1)
+ h1hit10 = (HDC_HITS_PER_PLANE(10).GE.1)
+ h1hit11 = (HDC_HITS_PER_PLANE(11).GE.1)
+ h1hit12 = (HDC_HITS_PER_PLANE(12).GE.1)
+
+*next, we see how many hits per plane there were ...
+
+ hnumhit1 = HDC_HITS_PER_PLANE(1)
+ hnumhit2 = HDC_HITS_PER_PLANE(2)
+ hnumhit3 = HDC_HITS_PER_PLANE(3)
+ hnumhit4 = HDC_HITS_PER_PLANE(4)
+ hnumhit5 = HDC_HITS_PER_PLANE(5)
+ hnumhit6 = HDC_HITS_PER_PLANE(6)
+ hnumhit7 = HDC_HITS_PER_PLANE(7)
+ hnumhit8 = HDC_HITS_PER_PLANE(8)
+ hnumhit9 = HDC_HITS_PER_PLANE(9)
+ hnumhit10 = HDC_HITS_PER_PLANE(10)
+ hnumhit11 = HDC_HITS_PER_PLANE(11)
+ hnumhit12 = HDC_HITS_PER_PLANE(12)
+
+ hnumhits1 = HDC_HITS_PER_PLANE(1) + HDC_HITS_PER_PLANE(2) +
+ $ HDC_HITS_PER_PLANE(3) + HDC_HITS_PER_PLANE(4) +
+ $ HDC_HITS_PER_PLANE(5) + HDC_HITS_PER_PLANE(6)
+
+ hnumhits2 = HDC_HITS_PER_PLANE(7) + HDC_HITS_PER_PLANE(8) +
+ $ HDC_HITS_PER_PLANE(9) + HDC_HITS_PER_PLANE(10) +
+ $ HDC_HITS_PER_PLANE(11) + HDC_HITS_PER_PLANE(12)
+
+*next we check to see if we have fewer than the max allowed hits per chamber
+*this number should agree with the value in trackeff.test.
+
+ h1hitslt = hnumhits1.LE.hmax_pr_hits(1)
+ h2hitslt = hnumhits2.LE.hmax_pr_hits(2)
+
+*next we check to see if we have the minimum number of planes per chamber
+*this number should agree with the value in trackeff.test.
+
+ planetemp = 0
+ if(HDC_HITS_PER_PLANE(1).GE.1) planetemp = planetemp+1
+ if(HDC_HITS_PER_PLANE(2).GE.1) planetemp = planetemp+1
+ if(HDC_HITS_PER_PLANE(3).GE.1) planetemp = planetemp+1
+ if(HDC_HITS_PER_PLANE(4).GE.1) planetemp = planetemp+1
+ if(HDC_HITS_PER_PLANE(5).GE.1) planetemp = planetemp+1
+ if(HDC_HITS_PER_PLANE(6).GE.1) planetemp = planetemp+1
+ hnumplanes1 = planetemp
+ planetemp = 0
+ if(HDC_HITS_PER_PLANE(7).GE.1) planetemp = planetemp+1
+ if(HDC_HITS_PER_PLANE(8).GE.1) planetemp = planetemp+1
+ if(HDC_HITS_PER_PLANE(9).GE.1) planetemp = planetemp+1
+ if(HDC_HITS_PER_PLANE(10).GE.1) planetemp = planetemp+1
+ if(HDC_HITS_PER_PLANE(11).GE.1) planetemp = planetemp+1
+ if(HDC_HITS_PER_PLANE(12).GE.1) planetemp = planetemp+1
+ hnumplanes2 = planetemp
+
+ h1planesgt = hnumplanes1.GE.hmin_hit(1)
+ h2planesgt = hnumplanes2.GE.hmin_hit(2)
+
+
+*we now fill in the chamber part of the track tests.
+
+ hfoundtrack = (hntracks_fp.NE.0)
+ if (hfoundtrack) then
+ htestbeta=hsbeta
+ else
+ htestbeta=0.0
+ endif
+ hcleantrack = (hsnum_fptrack.NE.0)
+*hhitslt is less than max allowed hits in both chambers
+ hhitslt = h1hitslt.AND.h2hitslt
+*hplanesgt is at least the minimum number of planes fired per chamber
+ hplanesgt = h1planesgt.AND.h2planesgt
+*hspacepoints is finding at least one space point in both chambers
+ hspacepoints = ((hnspace_points(1).GE.1).AND.(hnspace_points(2).GE.1))
+*hstublt is passing the stub criteria for at least one spacepoint in both chambers
+ hstublt = (hstubtest.ne.0)
+*hhitsplanes is passing not too many hits and not too few planes
+ hhitsplanes = hhitslt.AND.hplanesgt
+*hhitsplanes is that and finding a spacepoint
+ hhitsplanessps = hhitsplanes.AND.hspacepoints
+*hhitsplanesspsstubs is that and passing the stub tests
+ hhitsplanesspsstubs = hhitsplanessps.AND.hstublt
+*fXhspacepoints is pasisng htis and planes but failing to find a space point
+ f1hspacepoints = h1hitslt.AND.h1planesgt.AND.(hnspace_points(1).EQ.0)
+ f2hspacepoints = h2hitslt.AND.h2planesgt.AND.(hnspace_points(2).EQ.0)
+ fhspacepoints = f1hspacepoints.OR.f2hspacepoints
+ htest1 = (hhitsplanes.AND.(.not.hspacepoints))
+ htest2 = (hspacepoints.AND.(.not.hstublt))
+
+************************now look at some hodoscope tests
+*second, we move the scintillators. here we use scintillator cuts to see
+*if a track should have been found.
+
+ hnumscins1 = hscin_hits_per_plane(1)
+ hnumscins2 = hscin_hits_per_plane(2)
+ hnumscins3 = hscin_hits_per_plane(3)
+ hnumscins4 = hscin_hits_per_plane(4)
+
+*first, fill the arrays of which scins were hit
+ do i=1,4
+ do j=1,hscin_1x_nr
+ hscinhit(i,j)=0
+ enddo
+ enddo
+ do i=1,hscin_tot_hits
+ hscinhit(hscin_plane_num(i),hscin_counter_num(i))=1
+ enddo
+
+
+*next, look for clusters of hits in a scin plane. a cluster is a group of
+*adjacent scintillator hits separated by a non-firing scintillator.
+*Wwe count the number of three adjacent scintillators too. (A signle track
+*shouldn't fire three adjacent scintillators.
+ do i=1,hnum_scin_planes
+ hnclust(i)=0
+ hthreescin(i)=0
+ enddo
+
+*look for clusters in x planes... (16 scins) !this assume both x planes have same
+*number of scintillators.
+ do j=1,3,2
+ count=0
+ if (hscinhit(j,1).EQ.1) count=count+1
+ do i=1,(hscin_1x_nr-1) !look for number of clusters of 1 or more hits
+ if ((hscinhit(j,i).EQ.0).AND.(hscinhit(j,i+1).EQ.1)) count=count+1
+ enddo
+ hnclust(j)=count
+ count=0
+ do i=1,(hscin_1x_nr-2) !look for three or more adjacent hits
+ if ((hscinhit(j,i).EQ.1).AND.(hscinhit(j,i+1).EQ.1).AND.
+ $ (hscinhit(j,i+2).EQ.1)) count=count+1
+ enddo
+ if (count.GT.0) hthreescin(j)=1
+ enddo
+*look for clusters in y planes... (10 scins) !this assume both y planes have same
+*number of scintillators.
+ do j=2,4,2
+ count=0
+ if (hscinhit(j,1).EQ.1) count=count+1
+ do i=1,(hscin_1y_nr-1) !look for number of clusters of 1 or more hits
+ if ((hscinhit(j,i).EQ.0).AND.(hscinhit(j,i+1).EQ.1)) count=count+1
+ enddo
+ hnclust(j)=count
+ count=0
+ do i=1,(hscin_1y_nr-2) !look for three or more adjacent hits
+ if ((hscinhit(j,i).EQ.1).AND.(hscinhit(j,i+1).EQ.1).AND.
+ $ (hscinhit(j,i+2).EQ.1)) count=count+1
+ enddo
+ if (count.GT.0) hthreescin(j)=1
+ enddo
+
+*now put some "tracking" like cuts on the hslopes, based only on scins...
+*by "slope" here, I mean the difference in the position of scin hits in two
+*like-planes. For example, a track that those great straight through will
+*have a slope of zero. If it moves one scin over from s1x to s2x it has an
+*x-slope of 1... I pick the minimum slope if there are multiple scin hits.
+ hbestxpscin=100
+ hbestypscin=100
+ do i=1,hscin_1x_nr
+ do j=1,hscin_1x_nr
+ if ((hscinhit(1,i).EQ.1).AND.(hscinhit(3,j).EQ.1)) then
+ hslope=abs(i-j)
+ if (hslope.LT.hbestxpscin) hbestxpscin=hslope
+ endif
+ enddo
+ enddo
+ do i=1,hscin_1y_nr
+ do j=1,hscin_1y_nr
+ if ((hscinhit(2,i).EQ.1).AND.(hscinhit(4,j).EQ.1)) then
+ hslope=abs(i-j)
+ if (hslope.LT.hbestypscin) hbestypscin=hslope
+ endif
+ enddo
+ enddo
+
+*next we mask out the edge scintillators, and look at triggers that happened
+*at the center of the acceptance. To change which scins are in the mask
+*change the values of h*loscin and h*hiscin in htracking.param
+ hhitsweet1x=0
+ hhitsweet1y=0
+ hhitsweet2x=0
+ hhitsweet2y=0
+ hgoodscinhits=0
+*first x plane. first see if there are hits inside the scin region
+ do i=hxloscin(1),hxhiscin(1)
+ if (hscinhit(1,i).EQ.1) then
+ hhitsweet1x=1
+ sweet1xscin=i
+ endif
+ enddo
+*second x plane. first see if there are hits inside the scin region
+ do i=hxloscin(2),hxhiscin(2)
+ if (hscinhit(3,i).EQ.1) then
+ hhitsweet2x=1
+ sweet2xscin=i
+ endif
+ enddo
+
+*first y plane. first see if there are hits inside the scin region
+ do i=hyloscin(1),hyhiscin(1)
+ if (hscinhit(2,i).EQ.1) then
+ hhitsweet1y=1
+ sweet1yscin=i
+ endif
+ enddo
+*second y plane. first see if there are hits inside the scin region
+ do i=hyloscin(2),hyhiscin(2)
+ if (hscinhit(4,i).EQ.1) then
+ hhitsweet2y=1
+ sweet2yscin=i
+ endif
+ enddo
+
+ testsum=hhitsweet1x+hhitsweet1y+hhitsweet2x+hhitsweet2y
+* now define a 3/4 or 4/4 trigger of only good scintillators the value
+* is specified in htracking.param...
+ if (testsum.GE.htrack_eff_test_num_scin_planes) hgoodscinhits=1
+
+
+*******************************************************************************
+* Here's where we start writing to the files. Uncomment these lines and
+* the corresponding file open and close lines at the beginning and end
+* of this file if you want this output. the scaler report should take
+* care of most people though...
+
+*
+ if (hbypass_track_eff_files.eq.0) then
+ if (hgoodscinhits.EQ.1) then
+ write(12,*) 'sweet spot hit, event number ',gen_event_ID_number
+ endif
+ if (.not.hhitslt) then
+ write(12,*) 'too many hits, event number ',gen_event_ID_number
+ endif
+ if (.not.hplanesgt) then
+ write(12,*) 'too few planes event number ',
+ $ gen_event_ID_number
+ endif
+ if (hhitsplanes.AND.(.not.hspacepoints)) then
+ write(12,*) 'p hits/planes, f sp # = ',gen_event_ID_number
+ endif
+ if ((.not.hfoundtrack).AND.hhitsplanessps) then
+ write(12,*) 'p hits/planes/sps, f track # = ',gen_event_ID_number
+ endif
+ if (hspacepoints.AND.(.not.hstublt)) then
+ write(12,*) 'p sp, f stubs # = ',gen_event_ID_number
+ endif
+ endif
+
+
+*the rest of this file prepares the output of htrack.out. If you're not
+*writing to that file, don't worry about this.
+
+ if (hbypass_track_eff_files.eq.0) then
+ txth=0
+ if (hhitslt) txth=1
+ txthp=0
+ if (hhitsplanes) txthp=1
+ txthps=0
+ if (hhitsplanessps) txthps=1
+ txthpss=0
+ if (hhitsplanesspsstubs) txthpss=1
+ txtft=0
+ if (hfoundtrack) txtft=1
+ txtct=0
+ if (hcleantrack) txtct=1
+
+ write(14,902) gen_event_ID_number,hnumhits1,hnumhits2,
+ $ hnumhit1,hnumhit2,hnumhit3,hnumhit4,
+ $ hnumhit5,hnumhit6,hnumhit7,hnumhit8,
+ $ hnumhit9,hnumhit10,hnumhit11,hnumhit12,
+ $ hnumplanes1,hnumplanes2,hnumscins1,hnumscins2,
+ $ hnumscins3,hnumscins4,hnclust(1),hnclust(2),
+ $ hnclust(3),hnclust(4),hthreescin(1),hthreescin(2),
+ $ hthreescin(3),hthreescin(4),hbestxpscin,hbestypscin,
+ $ hgoodscinhits,
+ $ txtft,txtct,hntracks_fp,hbeta_notrk,htestbeta,hcal_et,
+ $ hsshtrk,
+ $ hcer_npe_sum,hschi2perdeg,hsdelta,thiscointime
+ 902 format(1x,i6,i4,i4,12(i4),2(i2),4(i3),8(i2),2(i4),i2,i2,i2,i2,f10.3,f9.3,
+ $ f9.3,f9.3,f9.3,f10.3,f10.3,f10.3)
+
+ close(12)
+ close(14)
+ endif
+ end
diff --git a/HTRACKING/h_tracks_cal.f b/HTRACKING/h_tracks_cal.f
new file mode 100644
index 0000000..bc7a856
--- /dev/null
+++ b/HTRACKING/h_tracks_cal.f
@@ -0,0 +1,158 @@
+*=======================================================================
+ subroutine h_tracks_cal(abort,errmsg)
+*=======================================================================
+*-
+*- Purpose: Associates clusters with detector tracks which are inside
+*- the calorimeter fiducial volume. A track and a cluster
+*- are considered as matched if the distance in X projection
+*- between these two is less than half the block width.
+*-
+*- Input Banks: HMS_CLUSTERS_CAL, HMS_FOCAL_PLANE,HMS_GEOMETRY_CAL
+*-
+*- Output Bank: HMS_TRACK_CAL
+*-
+*- Created: 15 Mar 1994 Tsolak A. Amatuni
+*- Modified 25 Mar 1994 DFG
+*- Change name of print routine
+*- Modified 9 Apr 1998 Added a switch to turn on the fiducial
+*- cut. The default for this is now no cut.
+*- K.G. Vansyoc
+* $Log: h_tracks_cal.f,v $
+* Revision 1.10 2005/03/15 20:09:12 jones
+* Modify the criterion for matching track and calorimeter cluster. As before,
+* the track must hit within (0.5*scal_block_xsize + scal_slop) of the cluster
+* position. Previously if more than one cluster was within (0.5*scal_block_xsize + scal_slop) then the last cluster in the loop was associated with the track.
+* Now, if more than one cluster meets that condition then cluster which has a position
+* closest to the track is associated with the track. ( T. Horn)
+*
+* Revision 1.9 2003/03/21 22:21:51 jones
+* Modified and rearrange routines to calibrate the HMS calorimeter (V. Tadevosyan)
+*
+* Revision 1.8 1999/02/23 18:52:07 csa
+* (JRA) Clean up logical structure, remove hdebugcalcpeds stuff
+*
+* Revision 1.7 1998/12/17 22:02:40 saw
+* Support extra set of tubes on HMS shower counter
+*
+* Revision 1.6 1997/02/13 14:12:36 saw
+* (JRA) Correct error in position of top edge of fiducial cut.
+*
+* Revision 1.5 1996/01/16 22:00:40 cdaq
+* (JRA) Add hdebugcalcpeds flag
+*
+* Revision 1.4 1995/08/30 17:34:24 cdaq
+* (JRA) Use off-track blocks to accumulate pedestal data
+*
+* Revision 1.3 1995/05/22 19:39:31 cdaq
+* (SAW) Split gen_data_data_structures into gen, hms, sos, and coin parts"
+*
+* Revision 1.2 1994/10/11 19:24:54 cdaq
+* (SAW) Formatting changes
+*
+* Revision 1.1 1994/04/13 17:33:38 cdaq
+* Initial revision
+*
+*-----------------------------------------------------------------------
+*
+*
+ implicit none
+ save
+*
+ logical abort
+ character*(*) errmsg
+ character*12 here
+ parameter (here='H_TRACKS_CAL')
+*
+ integer*4 nt !Track number
+ integer*4 nc !Cluster number
+ real*4 xf !X position of track on calorimeter front surface
+ real*4 xb !X position of track on calorimeter back surface
+ real*4 yf !Y position of track on calorimeter front surface
+ real*4 yb !Y position of track on calorimeter back surface
+ real*4 dz_f !Distance along Z axis between focal plane and
+ real*4 dz_b !calorimeter front(f) and back(b) surfaces
+ real*4 delta_x !Distance between track & cluster in X projection
+ logical*4 track_in_fv
+
+ integer*4 t_nt, t_nc
+ real*4 t_minx, temp_x
+
+ include 'hms_data_structures.cmn'
+ include 'hms_calorimeter.cmn'
+ include 'hms_tracking.cmn'
+
+ hntracks_cal=0
+ if(hntracks_fp.le.0) go to 100 !Return
+*
+* Compute impact point coordinates on the calorimeter front and back surfaces
+*
+ do nt=1,hntracks_fp
+ dz_f=hcal_zmin-hz_fp(nt)
+ dz_b=hcal_zmax-hz_fp(nt)
+
+ xf=hx_fp(nt)+hxp_fp(nt)*dz_f
+ xb=hx_fp(nt)+hxp_fp(nt)*dz_b
+
+ yf=hy_fp(nt)+hyp_fp(nt)*dz_f
+ yb=hy_fp(nt)+hyp_fp(nt)*dz_b
+
+ htrack_xc(nt) = xf
+ htrack_yc(nt) = yf
+
+ track_in_fv = (xf.le.hcal_fv_xmax .and. xf.ge.hcal_fv_xmin .and.
+ & xb.le.hcal_fv_xmax .and. xb.ge.hcal_fv_xmin .and.
+ & yf.le.hcal_fv_ymax .and. yf.ge.hcal_fv_ymin .and.
+ & yb.le.hcal_fv_ymax .and. yb.ge.hcal_fv_ymin)
+
+* Initialize hcluster_track(nt)
+ if(hcal_fv_test.eq.0) then !not using fv test
+ hcluster_track(nt)=-1
+ else !using fv test
+ if (track_in_fv) then
+ hcluster_track(nt)=0 !Track is inside the fiducial volume
+ else
+ hcluster_track(nt)=-1 !Track is outside the fiducial volume
+ endif
+ endif
+*
+*----------If inside fv (or no test), Search for a cluster matching this track
+*
+ if( (hcal_fv_test.ne.0.and.track_in_fv) .or. hcal_fv_test.eq.0) then
+
+ if(hnclusters_cal.gt.0) then
+!! TH - Initialize minimum distance between track and cluster location.
+ t_minx = 99999
+ t_nt = 1
+ t_nc = 1
+ do nc=1,hnclusters_cal
+!! TH - Distance to match track with cluster
+ delta_x=abs(xf-hcluster_xc(nc))
+ if(delta_x.le.(0.5*hcal_block_xsize + hcal_slop)) then
+!! TH - Check the deviation distance for each track for each cluster. If
+!! distance smaller assign to t_minx. Eventually want to associate
+!! the track with the smallest deviation to the cluster. Increment
+!! tracks for calorimeter though whenever condition above is passed.
+
+ temp_x = delta_x
+ if(temp_x.lt.t_minx) then
+ t_minx = temp_x
+ t_nt = nt
+ t_nc = nc
+ endif
+ hntracks_cal =hntracks_cal+1
+ endif !End ... if matched
+ enddo !End loop over clusters
+ hcluster_track(t_nt)=t_nc !Track matches cluster #nc with min deviation
+ endif !End ... if number of clusters > 0
+ endif
+ enddo !End loop over detector tracks
+
+ 100 continue
+
+ if(hdbg_tracks_cal.gt.0) call h_prt_cal_tracks
+
+c Collect data for HMS calorimeter calibration.
+ if(hdbg_tracks_cal.lt.0) call h_cal_calib(0)
+
+ return
+ end
diff --git a/HTRACKING/h_trans_cal.f b/HTRACKING/h_trans_cal.f
new file mode 100644
index 0000000..6405300
--- /dev/null
+++ b/HTRACKING/h_trans_cal.f
@@ -0,0 +1,136 @@
+ subroutine h_trans_cal(abort,errmsg)
+*=======================================================================
+*-
+*- Purpose: Computes the energy deposited in each of the hit
+*- counters, the energy deposition in calorimeter
+*- columns and the total energy deposition, using only
+*- the calorimeter information.
+*- The energy depositions are not corrected yet for
+*- impact point coordinate dependence.
+*- The subroutine also returns the X and Z coordinates
+*- of the hit block centers.
+*-
+*- Input Banks: HMS_SPARSIFIED_CAL, HMS_CAL_CONST,HMS_CAL_MONITOR
+*-
+*- Output Bank: HMS_DECODED_CAL
+*-
+*- Created: 15 Mar 1994 Tsolak A. Amatuni
+* $Log: h_trans_cal.f,v $
+* Revision 1.8 2004/03/03 19:26:25 jones
+* Initialize hsshsum and hsshtrk to zero.
+*
+* Revision 1.7 1999/02/04 18:18:14 saw
+* Fix calculation of energy for blocks with two tubes
+*
+* Revision 1.6 1999/02/03 21:13:24 saw
+* Code for new Shower counter tubes
+*
+* Revision 1.5 1999/01/29 17:33:57 saw
+* Cosmetic changes
+*
+* Revision 1.4 1998/12/17 22:02:40 saw
+* Support extra set of tubes on HMS shower counter
+*
+* Revision 1.3 1995/05/22 19:39:31 cdaq
+* (SAW) Split gen_data_data_structures into gen, hms, sos, and coin parts"
+*
+* Revision 1.2 1994/04/13 17:36:40 cdaq
+* (DFG) Change name of print routine
+*
+* Revision 1.1 1994/02/19 06:21:11 cdaq
+* Initial revision
+*
+*--------------------------------------------------------
+ implicit none
+ save
+*
+ logical abort
+ character*(*) errmsg
+ character*11 here
+ parameter (here='H_TRANS_CAL')
+*
+ integer*4 nb !Block number
+ integer*4 nh !Hit number
+ integer*4 row !Row number
+ integer*4 col !Column number
+ real*4 adc_pos, adc_neg !ADC-PED value
+*
+ include 'hms_data_structures.cmn'
+ include 'hms_calorimeter.cmn'
+*
+* Sparsify the raw data
+*
+ call h_sparsify_cal(abort,errmsg)
+ if(abort) then
+ call g_add_path(here,errmsg)
+ return
+ endif
+*
+ hnhits_cal =0
+ hcal_e1 =0.
+ hcal_e2 =0.
+ hcal_e3 =0.
+ hcal_e4 =0.
+ hcal_et =0.
+ hsshsum = 0.
+ hsshtrk = 0.
+*
+ hcal_e1_pos =0.
+ hcal_e1_neg =0.
+*
+ hcal_e2_pos =0.
+ hcal_e2_neg =0.
+
+ if(hcal_num_hits.le.0) go to 100 !Return
+*
+* Loop over hits
+*
+ do nh=1,hcal_num_hits
+ row=hcal_rows(nh)
+ col=hcal_cols(nh)
+ adc_pos=hcal_adcs_pos(nh)
+ adc_neg=hcal_adcs_neg(nh)
+ nb =row+hmax_cal_rows*(col-1)
+*
+*------Determine position and energy deposition for each block
+ hblock_xc(nh)=hcal_block_xc(nb)
+ hblock_zc(nh)=hcal_block_zc(nb)
+ if(col.le.hcal_num_neg_columns) then ! Blocks with two tubes
+ hblock_de_pos(nh)=adc_pos*hcal_pos_cal_const(nb)
+ $ *hcal_pos_gain_cor(nb)
+ hblock_de_neg(nh)=adc_neg*hcal_neg_cal_const(nb)
+ $ *hcal_neg_gain_cor(nb)
+ hblock_de(nh)=hblock_de_pos(nh)+hblock_de_neg(nh)
+ else ! Blocks with single tube
+ hblock_de(nh)=adc_pos*hcal_pos_cal_const(nb)*hcal_pos_gain_cor(nb)
+ hblock_de_pos(nh)=hblock_de(nh)
+ endif
+*
+*------Accumulate the integral energy depositions
+ if(col.eq.1) then
+ hcal_e1=hcal_e1+hblock_de(nh)
+ if(hcal_num_neg_columns.ge.1) then
+ hcal_e1_pos=hcal_e1_pos+hblock_de_pos(nh)
+ hcal_e1_neg=hcal_e1_neg+hblock_de_neg(nh)
+ endif
+ else if (col.eq.2) then
+ hcal_e2=hcal_e2+hblock_de(nh)
+ if(hcal_num_neg_columns.ge.2) then
+ hcal_e2_pos=hcal_e2_pos+hblock_de_pos(nh)
+ hcal_e2_neg=hcal_e2_neg+hblock_de_neg(nh)
+ endif
+ else if(col.eq.3) then
+ hcal_e3=hcal_e3+hblock_de(nh)
+ else if(col.eq.4) then
+ hcal_e4=hcal_e4+hblock_de(nh)
+ endif
+ hcal_et=hcal_et+hblock_de(nh) ! Is hblock_de de_pos+de_neg?
+*
+ enddo !End loop over hits
+ hnhits_cal=hcal_num_hits
+*
+ 100 continue
+ if(hdbg_decoded_cal.gt.0) call h_prt_cal_decoded
+*
+ return
+ end
diff --git a/HTRACKING/h_trans_cer.f b/HTRACKING/h_trans_cer.f
new file mode 100644
index 0000000..36c3bc6
--- /dev/null
+++ b/HTRACKING/h_trans_cer.f
@@ -0,0 +1,52 @@
+ subroutine h_trans_cer(abort,errmsg)
+
+*-------------------------------------------------------------------
+* author: Chris Cothran
+* created: 5/25/95
+*
+* h_trans_cer fills the hms_decoded_cer common block
+* with track independent corrections and parameters
+* $Log: h_trans_cer.f,v $
+* Revision 1.2 1996/01/16 21:38:47 cdaq
+* (JRA) Make hcer_adc pedestal subtracted value
+*
+* Revision 1.1 1995/08/30 15:30:15 cdaq
+* Initial revision
+*
+*-------------------------------------------------------------------
+
+ implicit none
+
+ include 'hms_data_structures.cmn'
+ include 'hms_cer_parms.cmn'
+
+ logical abort
+ character*1024 errmsg
+ character*20 here
+ parameter (here = 'h_trans_cer')
+
+ integer*4 nhit,tube
+
+ save
+
+ abort = .false.
+
+ hcer_num_hits = 0
+ do tube=1,hcer_num_mirrors
+ hcer_npe(tube) = 0.
+ hcer_adc(tube) = 0.
+ enddo
+ hcer_npe_sum = 0.
+ do nhit = 1, hcer_tot_hits
+ tube = hcer_tube_num(nhit)
+ hcer_adc(tube) = hcer_raw_adc(nhit) - hcer_ped(tube)
+ if (hcer_adc(tube) .gt. hcer_width(tube)) then
+ hcer_num_hits = hcer_num_hits + 1
+ hcer_tube_num(hcer_num_hits) = tube
+ hcer_npe(tube) = hcer_adc(tube) * hcer_adc_to_npe(tube)
+ hcer_npe_sum = hcer_npe_sum + hcer_npe(tube)
+ endif
+ enddo
+
+ return
+ end
diff --git a/HTRACKING/h_trans_dc.f b/HTRACKING/h_trans_dc.f
new file mode 100644
index 0000000..7c568c7
--- /dev/null
+++ b/HTRACKING/h_trans_dc.f
@@ -0,0 +1,351 @@
+ SUBROUTINE H_TRANS_DC(ABORT,err)
+*--------------------------------------------------------
+*-
+*- Purpose and Methods : Translate HMS raw drift and start time
+*- to decoded information
+*-
+*- Required Input BANKS HMS_RAW_DC
+*- HMS_DECODED_SCIN
+*-
+*- Output BANKS HMS_DECODED_DC
+*-
+*- Output: ABORT - success or failure
+*- : err - reason for failure, if any
+*-
+* $Log: h_trans_dc.f,v $
+* Revision 1.15.26.2 2009/09/02 13:40:39 jones
+* eliminate commented emacs definitions
+*
+* Revision 1.15.26.1 2009/05/18 14:08:00 jones
+* 1) add code to remove all DC hits for one plane if that plane
+* has more than h_max_hits_per_plane..
+* 2) add code to purge DC hits based on matching the location of
+* paddles in S1X and S1Y
+*
+* Revision 1.15 2002/10/02 13:42:43 saw
+* Check that user hists are defined before filling
+*
+* Revision 1.14 1996/09/04 14:23:38 saw
+* (??) Cosmetic
+*
+* Revision 1.13 1996/01/16 21:37:13 cdaq
+* (JRA) Change sign on hstart_time
+*
+* Revision 1.12 1995/10/11 13:51:04 cdaq
+* (JRA) Cleanup, add bypass switch to h_dc_eff call
+*
+* Revision 1.11 1995/08/30 15:27:39 cdaq
+* (JRA) Add call to h_dc_eff, warn about invalid plane numbers
+*
+* Revision 1.10 1995/05/22 19:39:32 cdaq
+* (SAW) Split gen_data_data_structures into gen, hms, sos, and coin parts"
+*
+* Revision 1.9 1995/05/17 14:02:20 cdaq
+* (JRA) Add hist for all dc tdc's in one histogram.
+*
+* Revision 1.8 1995/04/06 19:34:34 cdaq
+* (JRA) HMAX_NUM_DC_PLANES -> HDC_NUM_PLANES
+*
+* Revision 1.7 1994/09/14 14:10:49 cdaq
+* (JRA) Initialize hdc_center array first time.
+*
+* Revision 1.6 1994/08/16 13:24:58 cdaq
+* (DJA) Move call to h_fill_dc_dec_hist to h_pattern_recognition
+*
+* Revision 1.5 1994/06/15 20:35:59 cdaq
+* (DFG) Add upper and lower limit for valid TDC
+*
+* Revision 1.4 1994/04/13 17:59:46 cdaq
+* (DFG) add histogram call and remove raw dump
+*
+* Revision 1.3 1994/03/24 19:48:48 cdaq
+* (DFG) add print routines and flags
+* check plane number and wire number for validity
+*
+* Revision 1.2 1994/02/22 05:27:06 cdaq
+* (SAW) Make err ' ' instead of ''
+*
+* Revision 1.1 1994/02/19 06:21:23 cdaq
+* Initial revision
+*
+*--------------------------------------------------------
+ IMPLICIT NONE
+ SAVE
+*
+ character*10 here
+ parameter (here= 'H_TRANS_DC')
+*
+ logical ABORT
+ character*(*) err
+*
+ include 'hms_data_structures.cmn'
+ include 'gen_constants.par'
+ include 'gen_units.par'
+ include 'hms_tracking.cmn'
+ include 'hms_geometry.cmn'
+ include 'hms_track_histid.cmn'
+ include 'hms_bypass_switches.cmn'
+c added for pruning of junk wires
+ include 'hms_scin_tof.cmn'
+
+*
+*--------------------------------------------------------
+ real*4 h_drift_dist_calc
+ external h_drift_dist_calc
+ integer*4 ihit,goodhit,old_wire,old_pln,wire,pln,chamber
+ real*4 histval
+*
+c new arrays for checking the two arrays below.
+ integer dcscin(2,16,12,128),plane,counter,ihitsc
+ common/pybtest/ dcscin
+
+c hard-wired values of the peak positions
+c in the DC plane distributions corresponding to
+c X1 or Y1 hodoscope hit counters. These come from
+c fitting the distribtuions in dsscin array from
+c run 72994, April 28, 2009 P. Bosted
+ real iw0(12)/111.5, -11.0, 1.3, 108.1, 64., 2.0,
+ > 115.0, -12.5,-3.0, 113.6, 67., -1.5/
+ real iwsl(12)/ -6.5, 6.8, 6.4, -6.3, -6.7, 6.5,
+ > -7.0, 7.0, 7.0, -7.0, -7.0, 7.0/
+ real iwcntr
+
+c Tolerance for how many wires on each side of the
+c peak position will be kept by the "wire cleaning"
+c code below. Adjusted to keep essentailly all good
+c hits for now.
+ real iwtol(12)/8., 8., 11., 11., 8., 8.,
+ > 7., 7., 11., 11., 7., 7./
+
+c array to decide if a wire should be purged from
+c the list beacuse does not match a good hodoscope hit
+ logical purgewire(1000)
+
+c array to decide if wire purging should take place
+c for a given plane
+ logical purgeplane(12),first/.true./
+
+c array to count how many RAW hits passing TDC cuts
+c there are per plane
+ integer wperplane(12)
+
+ ABORT= .FALSE.
+ err= ' '
+ old_wire = -1
+ old_pln = -1
+ goodhit = 0
+
+c make sure wire purging parameters are reasonable
+ if(first) then
+ write(*,'(//''Using '',f6.1,
+ > '' nsec for wire purging'')') h_iwslop
+ if(h_iwslop.lt.-3.0) then
+ h_iwslop = 0.0
+ write(*,'(//''*******************************'')')
+ write(*,'(''This is too small to work: reset'',
+ > '' h_iwslop to 0.0 nsec'')')
+ write(*,'(//''*******************************'')')
+ endif
+ if(h_iwslop.gt.60.0) then
+ write(*,'(''This means wire purging essentially'',
+ > '' is turned off!'')')
+ endif
+ write(*,'(//''Using max of '',i6,
+ > '' hits per plnae'')') h_max_hits_per_plane
+ if(h_max_hits_per_plane.lt.1) then
+ h_max_hits_per_plane=6
+ write(*,'(''*********************************'')')
+ write(*,'(''This is too small: Resetting to 6'')')
+ endif
+ first = .false.
+ endif
+
+ if (hdc_center(1).eq.0.) then !initialize hdc_center if not yet set.
+ do pln = 1, hdc_num_planes
+ chamber = hdc_chamber_planes(pln)
+ hdc_center(pln) = hdc_xcenter(chamber)*sin(hdc_alpha_angle(pln))+
+ & hdc_ycenter(chamber)*cos(hdc_alpha_angle(pln))
+ enddo
+ endif
+
+! Inititalize this array
+ do pln=1,12
+ wperplane(pln)=0
+ purgeplane(pln) = .false.
+ enddo
+
+! Check if any X1 or Y1 hodoscope hits. Need at least
+! cone to purge wires in corresponding planes
+ do ihitsc = 1 , hscin_tot_hits
+ plane = hscin_plane_num(ihitsc)
+ counter = hscin_counter_num(ihitsc)
+ if(hgood_scin_time(1,ihitsc)) then
+ if(plane.eq.1.and.counter.gt.1.and.
+ > counter.lt.16) then
+ purgeplane(1)=.true.
+ purgeplane(3)=.true.
+ purgeplane(4)=.true.
+ purgeplane(6)=.true.
+ purgeplane(7)=.true.
+ purgeplane(9)=.true.
+ purgeplane(10)=.true.
+ purgeplane(12)=.true.
+ endif
+ if(plane.eq.2.and.counter.gt.1.and.
+ > counter.lt.10) then
+ purgeplane(2)=.true.
+ purgeplane(5)=.true.
+ purgeplane(8)=.true.
+ purgeplane(11)=.true.
+ endif
+ endif
+ enddo
+
+* Are there any raw hits
+ if(hdc_raw_tot_hits.gt.0) then
+* loop over all raw hits
+ do ihit=1,hdc_raw_tot_hits
+ pln = hdc_raw_plane_num(ihit)
+ wire = hdc_raw_wire_num(ihit)
+
+! Initialize all wires in this plane to be purged,
+! if there is appropriate X1 or Y1 to test on below
+ purgewire(min(1000,ihit))=
+ > purgeplane(max(1,min(12,pln)))
+
+! Count how many hits passing TDC cuts there are per
+! plane (to use later to remove planes with too many hits)
+ if(hdc_raw_tdc(ihit).gt.hdc_tdc_min_win(pln).and.
+ > hdc_raw_tdc(ihit).lt.hdc_tdc_max_win(pln).and.
+ > pln.gt.0.and.pln.le.12) then
+ wperplane(pln)=wperplane(pln)+1
+ endif
+
+c actually set the purging flag
+ do ihitsc = 1 , hscin_tot_hits
+ plane = hscin_plane_num(ihitsc)
+ counter = hscin_counter_num(ihitsc)
+ if(hgood_scin_time(1,ihitsc).and.
+ > pln.gt.0.and.pln.le.12.and.
+ > plane.gt.0 .and. plane.lt.3) then
+ iwcntr = iw0(pln) + iwsl(pln)*counter
+ if(plane.eq.1.and.(pln.eq.1.or.pln.eq.3.or.
+ > pln.eq.4.or.pln.eq.6.or.pln.eq.7.or.
+ > pln.eq.9.or.pln.eq.10.or.pln.eq.12).and.
+ > counter.gt.1.and.counter.lt.16) then
+ if(wire.gt.iwcntr - iwtol(pln) - h_iwslop .and.
+ > wire.lt.iwcntr + iwtol(pln) + h_iwslop) then
+ purgewire(min(1000,ihit))= .false.
+ endif
+ endif
+ if(plane.eq.2.and.(pln.eq.2.or.pln.eq.5.or.
+ > pln.eq.8.or.pln.eq.11).and.
+ > counter.gt.1.and.counter.lt.10) then
+ if(wire.gt.iwcntr - iwtol(pln) - h_iwslop .and.
+ > wire.lt.iwcntr + iwtol(pln) + h_iwslop) then
+ purgewire(min(1000,ihit))= .false.
+ endif
+ endif
+ endif
+ enddo
+
+c Increment one-line histograms to see corresponance
+c of hodoscope and wire numbers for each plane, wire
+ do ihitsc = 1 , hscin_tot_hits
+ plane = hscin_plane_num(ihitsc)
+ counter = hscin_counter_num(ihitsc)
+ if(hgood_scin_time(1,ihitsc).and.
+ > counter.gt.0 .and. counter.le.16.and.
+ > pln.gt.0.and.pln.le.12.and.
+ > wire.gt.0.and.wire.le.128.and.
+ > hdc_raw_tdc(ihit).gt.hdc_tdc_min_win(pln).and.
+ > hdc_raw_tdc(ihit).lt.hdc_tdc_max_win(pln).and.
+ > plane.gt.0 .and. plane.lt.3) then
+ if(hdc_raw_tot_hits.lt.17) then
+ dcscin(plane,counter,pln,wire) =
+ > dcscin(plane,counter,pln,wire) + 1
+ endif
+ endif
+ enddo
+
+* check valid plane and wire number
+ if(pln.gt.0 .and. pln.le. hdc_num_planes) then
+ histval=float(hdc_raw_tdc(ihit))
+ if(hidrawtdc.gt.0) call hf1(hidrawtdc,histval,1.)
+* test if tdc value less than lower limit for good hits
+ if(hdc_raw_tdc(ihit) .lt. hdc_tdc_min_win(pln)) then
+ hwire_early_mult(wire,pln) = hwire_early_mult(wire,pln)+1
+ else
+ if(hdc_raw_tdc(ihit) .gt. hdc_tdc_max_win(pln)) then
+ hwire_late_mult(wire,pln) = hwire_late_mult(wire,pln)+1
+ else
+* test for valid wire number
+ if(wire .gt. 0 .and. wire .le. hdc_nrwire(pln) ) then
+* test for multiple hit on the same wire
+c if(pln .eq. old_pln .and. wire .eq. old_wire ) then
+c added test on number wires in a plane. If too many,
+c none of them will be used. 4/28/2009 P. Bosted
+c also added the wire purging based on hodo X1 and Y1
+c in this place
+ if((pln .eq. old_pln .and.
+ > wire .eq. old_wire ).or.
+c 6 is optimum value
+ > wperplane(min(12,max(1,pln))).gt.
+ > h_max_hits_per_plane .or.
+ > purgewire(min(1000,ihit)))then
+ hwire_extra_mult(wire,pln) =
+ > hwire_extra_mult(wire,pln)+1
+ else
+
+* valid hit proceed with decoding
+ goodhit = goodhit + 1
+ hdc_plane_num(goodhit) = hdc_raw_plane_num(ihit)
+ hdc_wire_num(goodhit) = hdc_raw_wire_num(ihit)
+ hdc_tdc(goodhit) = hdc_raw_tdc(ihit)
+
+ if(hdc_wire_counting(pln).eq.0) then !normal ordering
+ hdc_wire_center(goodhit) = hdc_pitch(pln)
+ & * (float(wire)-hdc_central_wire(pln))
+ & - hdc_center(pln)
+ else
+ hdc_wire_center(goodhit) = hdc_pitch(pln)
+ & * ((hdc_nrwire(pln)+(1-wire))
+ & - hdc_central_wire(pln)) - hdc_center(pln)
+ endif
+
+ hdc_drift_time(goodhit) = - hstart_time
+ & - float(hdc_tdc(goodhit))*hdc_tdc_time_per_channel
+ & + hdc_plane_time_zero(pln)
+* find dist in pattern_recognition, after apply propogation correction.
+* hdc_drift_dis(goodhit) = h_drift_dist_calc
+* $ (pln,wire,hdc_drift_time(goodhit))
+ hdc_hits_per_plane(pln) = hdc_hits_per_plane(pln) + 1
+ hwire_mult(wire,pln) = hwire_mult(wire,pln)+1
+
+ endif ! end test on duplicate wire
+ old_pln = pln
+ old_wire = wire
+ endif ! end test on valid wire number
+ endif ! end test on hdc_tdc_max_win
+ endif ! end test on hdc_tdc_min_win
+ else ! if not a valid plane number
+ write(6,*) 'H_TRANS_DC: invalid plane number = ',pln
+ endif ! end test on valid plane number
+ enddo ! end loop over raw hits
+*
+* set total number of good hits
+*
+ HDC_TOT_HITS = goodhit
+*
+ if (hbypass_dc_eff.eq.0) call h_dc_eff !only call if there is a hit.
+*
+ endif ! end test on hdc_raw_tot_hits.gt.0
+*
+*
+* Dump decoded banks if flag is set
+ if(hdebugprintdecodeddc.ne.0) then
+ call h_print_decoded_dc(ABORT,err)
+ endif
+*
+ RETURN
+ END
diff --git a/HTRACKING/h_trans_fpp.f b/HTRACKING/h_trans_fpp.f
new file mode 100644
index 0000000..1c406aa
--- /dev/null
+++ b/HTRACKING/h_trans_fpp.f
@@ -0,0 +1,254 @@
+ SUBROUTINE h_trans_fpp(ABORT,err)
+*--------------------------------------------------------
+* Hall C HMS Focal Plane Polarimeter Code
+*
+* Purpose: process raw hits by layer, chamber, set
+* and accumulate some relevant statistics
+*
+* Created by Frank R. Wesselmann, February 2004
+*
+*--------------------------------------------------------
+
+ IMPLICIT NONE
+
+ INCLUDE 'hms_data_structures.cmn'
+ INCLUDE 'hms_geometry.cmn'
+ include 'gen_detectorids.par'
+ include 'gen_decode_common.cmn'
+ INCLUDE 'gen_decode_F1tdc.cmn'
+ INCLUDE 'hms_fpp_event.cmn'
+ INCLUDE 'hms_fpp_params.cmn'
+
+ character*11 here
+ parameter (here= 'h_trans_fpp')
+
+ logical ABORT
+ character*(*) err
+
+
+ logical active_cluster
+
+ integer*4 hit_pointer(H_FPP_N_PLANES,H_FPP_MAX_RAWperPLANE)
+
+ integer*4 Ccount, hitno, rawhitidx, tdiff
+ integer*4 iSet, iChamber, iLayer, iPlane, iWire, iHit, iCluster, ROC
+
+ real*4 hit1time(H_FPP_MAX_WIRES), hit2time(H_FPP_MAX_WIRES)
+
+
+ ABORT= .FALSE.
+ err= ' '
+
+
+* * check if we have any work to do
+c write(*,*)'In h_trans_fpp ... ',HFPP_raw_tot_hits
+ if (HFPP_raw_tot_hits .le. 0) RETURN
+
+
+* * init storage
+ do iPlane=1,H_FPP_N_PLANES
+ do iWire=1,HFPP_Nwires(iPlane)
+ HFPP_hit1idx(iPlane,iWire) = 0
+ enddo
+ enddo
+
+ do iPlane=1,H_FPP_N_PLANES
+ do iWire=1,HFPP_Nwires(iPlane)
+ HFPP_hit2idx(iPlane,iWire) = 0
+ enddo
+ enddo
+
+ do iSet=1, H_FPP_N_DCSETS
+ HFPP_Nlayershit_set(iSet) = 0
+ enddo
+
+ do iSet=1, H_FPP_N_DCSETS
+ do iChamber=1, H_FPP_N_DCINSET
+ do iLayer=1, H_FPP_N_DCLAYERS
+ do iCluster=1, H_FPP_MAX_CLUSTERS
+ HFPP_nHitsinCluster(iSet,iChamber,iLayer,iCluster) = 0
+ enddo
+ enddo
+ enddo
+ enddo
+
+ do iSet=1, H_FPP_N_DCSETS
+ do iChamber=1, H_FPP_N_DCINSET
+ do iLayer=1, H_FPP_N_DCLAYERS
+ HFPP_nClusters(iSet,iChamber,iLayer) = 0
+ enddo
+ enddo
+ enddo
+
+ do iPlane=1,H_FPP_N_PLANES
+ HFPP_NplaneClusters(iPlane) = 0
+ enddo
+
+
+* * find TDC trigger time!! skip whatever we can!
+ do rawhitidx=1, HFPP_raw_tot_hits
+ if (HFPP_raw_plane(rawhitidx).lt.HFPP_trigger_plane) CYCLE
+ if (HFPP_raw_wire(rawhitidx) .ne.HFPP_trigger_wire) CYCLE
+
+ ROC = g_decode_roc(HFPP_ID,HFPP_raw_plane(rawhitidx),
+ > HFPP_raw_wire(rawhitidx),0)
+ HFPP_trigger_TDC(ROC) = HFPP_raw_TDC(rawhitidx)
+ enddo !rawhitidx
+
+
+* * identify raw hits by planes -- assume unsorted raw data
+ do rawhitidx=1, HFPP_raw_tot_hits
+
+ iPlane = HFPP_raw_plane(rawhitidx)
+ iWire = HFPP_raw_wire(rawhitidx)
+
+* * weed out obviously bad hits and thus speed up processing
+ if ((HFPP_raw_TDC(rawhitidx).ge.HFPP_minTDC) .and.
+ > (HFPP_raw_TDC(rawhitidx).le.HFPP_maxTDC)) then
+
+ if (iPlane.lt.1) CYCLE
+ if (iWire.lt.1) CYCLE
+ if (iPlane.gt.H_FPP_N_PLANES) CYCLE
+ if (iWire.gt.HFPP_Nwires(iPlane)) CYCLE
+* * the above cuts also weed out the already processed trigger reference time!
+
+* * TDC times from F1 TDC are meaningful only relative to each other
+* * thus we need to subtract the measured trigger time!
+* * also account for the case that the wire hit times
+* * may have rolled over but the trigger time did not!
+ ROC = g_decode_roc(HFPP_ID,iPlane,iWire,0)
+
+ if (HFPP_trigger_TDC(ROC).lt.0) then ! missing trigger time?!!
+ call G_build_note(':(FPP) TDC data in ROC $ missing trigger reference!',
+ & '$',ROC, ' ',0.,' ', err)
+ call G_add_path(here,err)
+ RETURN
+ endif
+
+* * although we operate in COMMON STOP mode, the F1 TDCs are free-running
+* * counters, so as time passes the count value increases
+* * ignoring the overflow due to the limited counting range that means
+* * earlier events should have a smaller TDC count than later events
+* * the trigger should be the last signal and ought to have the largest
+* * value; if it does not, we have a roll-over of the trigger time
+ if (HFPP_raw_TDC(rawhitidx) .gt. HFPP_trigger_TDC(ROC)) then
+ tdiff = HFPP_raw_TDC(rawhitidx) - HFPP_trigger_TDC(ROC)
+ > - F1TDC_WINDOW_SIZE(ROC)
+ else
+ tdiff = HFPP_raw_TDC(rawhitidx) - HFPP_trigger_TDC(ROC)
+ endif
+ HFPP_HitTime(rawhitidx) = HFPP_tDriftOffset(iPlane,iWire)
+ > + float(tdiff) * HFPP_tdc_time_per_channel
+
+ hitno = HFPP_N_planehitsraw(iPlane) + 1
+ if (hitno .le. H_FPP_MAX_RAWperPLANE) then
+ HFPP_N_planehitsraw(iPlane) = hitno
+ hit_pointer(iPlane,hitno) = rawhitidx ! local -- all raw hits
+ endif
+
+ else
+ print *,' NOTE: FPP hit outside accepted time window: plane,wire,TDC= ',
+ > iPlane,iWire,HFPP_raw_TDC(rawhitidx)
+ endif
+ enddo !rawhitidx
+
+
+
+* * find the earliest accpetable hit for each wire -- assume unsorted raw data
+* * also, determine # of layers with usefull hits to see if any tracking to be done
+ do iSet=1, H_FPP_N_DCSETS
+ do iChamber=1, H_FPP_N_DCINSET
+ do iLayer=1, H_FPP_N_DCLAYERS
+
+ iPlane = H_FPP_N_DCLAYERS * H_FPP_N_DCINSET * (iSet-1)
+ > + H_FPP_N_DCLAYERS * (iChamber-1)
+ > + iLayer
+
+* * check all hits in layer
+ do iHit=1, HFPP_N_planehitsraw(iPlane)
+ rawhitidx = hit_pointer(iPlane,iHit)
+ if (HFPP_HitTime(rawhitidx).lt.HFPP_mintime) CYCLE !skip too early hits
+ if (HFPP_HitTime(rawhitidx).gt.HFPP_maxtime) CYCLE !skip too late hits
+
+ iWire = HFPP_raw_wire(rawhitidx)
+ if (HFPP_hit1idx(iPlane,iWire).eq.0) then !first hit on wire, keep!
+ HFPP_hit1idx(iPlane,iWire) = rawhitidx
+ hit1time(iWire) = HFPP_HitTime(rawhitidx)
+ HFPP_N_planehits(iPlane) = HFPP_N_planehits(iPlane) + 1
+ elseif (HFPP_HitTime(rawhitidx).lt.hit1time(iWire)) then !replace if earlier
+ HFPP_hit2idx(iPlane,iWire) = HFPP_hit1idx(iPlane,iWire)
+ HFPP_hit1idx(iPlane,iWire) = rawhitidx
+ hit2time(iWire) = hit1time(iWire)
+ hit1time(iWire) = HFPP_HitTime(rawhitidx)
+ elseif (HFPP_hit2idx(iPlane,iWire).eq.0) then !first 2nd hit on wire, keep!
+ HFPP_hit2idx(iPlane,iWire) = rawhitidx
+ hit2time(iWire) = HFPP_HitTime(rawhitidx)
+ elseif (HFPP_HitTime(rawhitidx).lt.hit2time(iWire)) then !replace if earlier
+ HFPP_hit2idx(iPlane,iWire) = rawhitidx
+ hit2time(iWire) = HFPP_HitTime(rawhitidx)
+ endif
+ enddo
+
+ if (HFPP_N_planehits(iPlane) .gt. 0) then
+ HFPP_Nlayershit_set(iSet) = HFPP_Nlayershit_set(iSet)+1
+ endif
+
+ enddo !iLayer
+ enddo !iChamber
+ enddo !iSet
+
+
+
+* * now turn raw hits per plane into CLUSTERS per (set,chamber,layer)
+* * if clustering is not desired (HFPP_use_clusters), each cluster has 1 hit only
+ do iSet=1, H_FPP_N_DCSETS
+ if (HFPP_Nlayershit_set(iSet).ge.HFPP_minsethits) then ! enough hits for tracking
+
+ do iChamber=1, H_FPP_N_DCINSET
+ do iLayer=1, H_FPP_N_DCLAYERS
+
+ iPlane = H_FPP_N_DCLAYERS * H_FPP_N_DCINSET * (iSet-1)
+ > + H_FPP_N_DCLAYERS * (iChamber-1)
+ > + iLayer
+
+ active_cluster = .false.
+ iCluster = 0
+
+ do iWire=1,HFPP_Nwires(iPlane)
+
+ if (HFPP_hit1idx(iPlane,iWire).eq.0) then ! terminate any active cluster
+ active_cluster = .false.
+ else
+ if (active_cluster) then ! add to active cluster
+ Ccount = HFPP_nHitsinCluster(iSet,iChamber,iLayer,iCluster) + 1
+ else !start new cluster
+ active_cluster = (HFPP_use_clusters.gt.0) ! only make clusters if instructed
+ iCluster = min(iCluster+1,H_FPP_MAX_CLUSTERS)
+ HFPP_ClusterinTrack(iSet,iChamber,iLayer,iCluster) = 0
+ Ccount = 1
+ endif
+ if (Ccount.le.H_FPP_MAX_HITSperCLUSTER) then
+* * we can only have so many hits in a cluster -- skip excess
+ HFPP_nHitsinCluster(iSet,iChamber,iLayer,iCluster) = Ccount
+ HFPP_Clusters(iSet,iChamber,iLayer,iCluster,Ccount)
+ > = HFPP_hit1idx(iPlane,iWire)
+ endif
+ endif !HFPP_hit1idx.eq.0
+
+ HFPP_drift_time(iSet,iChamber,iLayer,iWire) = H_FPP_BAD_TIME
+ HFPP_drift_dist(iSet,iChamber,iLayer,iWire) = H_FPP_BAD_DRIFT !init to none
+
+ enddo !iWire
+
+ HFPP_nClusters(iSet,iChamber,iLayer) = iCluster
+ HFPP_NplaneClusters(iPlane) = iCluster !for CTP usage -- max 2d array
+
+ enddo !iLayer
+ enddo !iChamber
+
+ endif !Nplanes_hit
+ enddo !iSet
+
+
+ RETURN
+ END
diff --git a/HTRACKING/h_trans_fpp_hms.f b/HTRACKING/h_trans_fpp_hms.f
new file mode 100644
index 0000000..7c19baa
--- /dev/null
+++ b/HTRACKING/h_trans_fpp_hms.f
@@ -0,0 +1,344 @@
+ SUBROUTINE h_trans_fpp_hms(ABORT,err)
+*--------------------------------------------------------
+* Hall C HMS Focal Plane Polarimeter Code
+*
+* Purpose: Fill FPP variables based on projecting HMS tracks
+* and accumulate some relevant statistics
+*
+* Created by Edward J. Brash, September 5, 2007
+*
+*--------------------------------------------------------
+
+ IMPLICIT NONE
+
+ INCLUDE 'hms_data_structures.cmn'
+ INCLUDE 'hms_geometry.cmn'
+ include 'gen_detectorids.par'
+ include 'gen_decode_common.cmn'
+ INCLUDE 'gen_decode_F1tdc.cmn'
+ INCLUDE 'hms_fpp_event.cmn'
+ INCLUDE 'hms_fpp_params.cmn'
+
+ character*11 here
+ parameter (here= 'h_trans_fpp_hms')
+
+ logical ABORT
+ character*(*) err
+
+ logical active_cluster
+
+ integer*4 hit_pointer(H_FPP_N_PLANES,H_FPP_MAX_RAWperPLANE)
+
+ integer*4 Ccount, hitno, rawhitidx, tdiff
+ integer*4 iSet, iChamber, iLayer, iPlane, iWire, iHit, iCluster, ROC
+ real*4 zlocal,xlocal,ylocal,uCoord,uCoord_wire,drift_dist_local
+ integer*4 iWireHit,iSetScatter,i,j
+ real*4 hit1time(H_FPP_MAX_WIRES), hit2time(H_FPP_MAX_WIRES)
+ real*4 xsmear,ysmear
+ real*8 grnd,zScatter,rnum,t1,t2,t3,t4,t5,t6,poisson,mu,mu2,x,ga
+ real*8 xp_local,yp_local,xhms,yhms,deltaz,phi_local,theta_local
+ real*8 r_in(3),r_fin(3),M(3,3),magnitude,alpha,beta,xin,yin,zin
+
+ ABORT= .FALSE.
+ err= ' '
+
+ print *,'\n You should not be here!!!\n'
+ STOP
+
+c write(*,*)'Basic Track information: ',hsxp_fp,hsx_fp, hsyp_fp,hsy_fp
+
+ HFPP_raw_tot_hits=0
+
+c
+c decide where the scattering is going to occur - analyzer 1 or 2
+c
+ rnum=grnd()
+ if (rnum.le.0.500) then ! first analyzer
+ iSetScatter = 1
+ zScatter =
+ > hdc_zpos(12)+2.0+rnum*((HFPP_Zoff(1)+
+c > hdc_zpos(12)+2.0+0.5*((HFPP_Zoff(1)+
+ > HFPP_layerZ(1,1,1)-2.0)-(hdc_zpos(12)+2.0))
+ elseif (rnum.le.1.000) then ! second analyzer
+ iSetScatter = 2
+ zScatter =
+ > (HFPP_Zoff(1)+HFPP_layerZ(1,2,3)+2.0)+rnum*((HFPP_Zoff(2)+
+c > (HFPP_Zoff(1)+HFPP_layerZ(1,2,3)+2.0)+0.5*((HFPP_Zoff(2)+
+ > HFPP_layerZ(2,1,1)-2.0)-(HFPP_Zoff(1)+HFPP_layerZ(1,2,3)+2.0))
+ else ! no scattering
+ iSetScatter = 0
+ endif
+c
+c choose scattering angle from randomized double poisson distribution
+c
+ mu=2.0
+ mu2=10.0
+100 rnum=grnd()
+ x=30*rnum
+ CALL GAMMA(X,GA)
+ t1=exp(-1.0*mu)
+ t2=mu**x
+ t3=x*ga
+ t4=exp(-1.0*mu2)
+ t5=mu2**x
+ t6=x*ga
+ poisson = (3.0*t1*t2/t3+t4*t5/t6)/4.0
+ rnum=grnd()
+ if(rnum.gt.poisson) goto 100
+
+ theta_local=x*3.14159265/180.0
+ rnum=grnd()
+ phi_local=rnum*2.0*3.14159265
+ xp_local=sin(theta_local)*cos(phi_local)/cos(theta_local)
+ yp_local=sin(theta_local)*sin(phi_local)/cos(theta_local)
+
+ beta = datan(dble(hsyp_fp))
+ alpha = datan(dble(hsxp_fp)*dcos(beta))
+
+ M(1,1) = dcos(alpha)
+ M(1,2) = -1.d0*dsin(alpha)*dsin(beta)
+ M(1,3) = dsin(alpha)*dcos(beta)
+
+ M(2,1) = 0.d0
+ M(2,2) = dcos(beta)
+ M(2,3) = dsin(beta)
+
+ M(3,1) = -1.d0*dsin(alpha)
+ M(3,2) = -1.d0*dcos(alpha)*dsin(beta)
+ M(3,3) = dcos(alpha)*dcos(beta)
+
+c Normalize new direction vector
+
+ xin = dble(xp_local)
+ yin = dble(yp_local)
+ zin = 1.d0
+ magnitude = dsqrt(xin*xin+yin*yin+zin*zin)
+ r_in(1)=xin/magnitude
+ r_in(2)=yin/magnitude
+ r_in(3)=zin/magnitude
+
+ do i=1,3
+ r_fin(i)=0.d0
+ do j=1,3
+ r_fin(i)=r_fin(i)+M(i,j)*r_in(j)
+ enddo
+ enddo
+
+c write(*,*)r_fin(1),r_fin(2),r_fin(3)
+
+ xp_local = r_fin(1)/r_fin(3)
+ yp_local = r_fin(2)/r_fin(3)
+
+c write(*,*)'xp,yp final: ',xp_local,yp_local
+
+ xhms=hsx_fp+hsxp_fp*zScatter
+ yhms=hsy_fp+hsyp_fp*zScatter
+
+c
+c write(*,*)'Z-positions:'
+c write(*,*)'hdc: ',(hdc_zpos(12)+2.0)
+c write(*,*)'fpp1-front: ',(HFPP_Zoff(1)+HFPP_layerZ(1,1,1)-2.0)
+c write(*,*)'fpp1-rear: ',(HFPP_Zoff(1)+HFPP_layerZ(1,2,3)+2.0)
+c write(*,*)'fpp2-front: ',(HFPP_Zoff(2)+HFPP_layerZ(2,1,1)-2.0)
+c write(*,*)'scattering:',iSetScatter,theta_local*180.0/3.14159,phi_local*180.0/3.14159
+c write(*,*)'x,y,z scatter: ',xhms,yhms,zScatter
+c
+c now, loop over both sets
+c
+c write(*,*)'HMS: ',hsxp_fp,hsyp_fp
+ do iSet=1, H_FPP_N_DCSETS
+
+ HFPP_Nlayershit_set(iSet) = 0
+
+ do iChamber=1, H_FPP_N_DCINSET
+ do iLayer=1, H_FPP_N_DCLAYERS
+
+ iPlane = H_FPP_N_DCLAYERS * H_FPP_N_DCINSET * (iSet-1)
+ > + H_FPP_N_DCLAYERS * (iChamber-1)
+ > + iLayer
+
+ HFPP_raw_tot_hits=HFPP_raw_tot_hits+1
+
+ do iWire=1,HFPP_Nwires(iPlane)
+ HFPP_hit1idx(iPlane,iWire) = 0
+ HFPP_hit2idx(iPlane,iWire) = 0
+ enddo
+c
+c Now, we want to calculate a position where track hits the chambers
+c
+ if (iSetScatter.eq.1) then!scattering in first chamber
+ zlocal=HFPP_layerZ(iSet,iChamber,iLayer) + HFPP_Zoff(iSet)
+ deltaz=zlocal-zScatter
+ xlocal=xhms+xp_local*deltaz
+ ylocal=yhms+yp_local*deltaz
+ elseif (iSetScatter.eq.2) then
+ if (iSet.eq.1) then
+ zlocal=HFPP_layerZ(iSet,iChamber,iLayer) + HFPP_Zoff(iSet)
+ xlocal=hsx_fp+hsxp_fp*zlocal
+ ylocal=hsy_fp+hsyp_fp*zlocal
+ else
+ zlocal=HFPP_layerZ(iSet,iChamber,iLayer) + HFPP_Zoff(iSet)
+ deltaz=zlocal-zScatter
+ xlocal=xhms+xp_local*deltaz
+ ylocal=yhms+yp_local*deltaz
+ endif
+ else
+ zlocal=HFPP_layerZ(iSet,iChamber,iLayer) + HFPP_Zoff(iSet)
+ xlocal=hsx_fp+hsxp_fp*zlocal
+ ylocal=hsy_fp+hsyp_fp*zlocal
+ endif
+
+c write(*,*)'Xlocal,Ylocal,Zlocal: ',xlocal,ylocal,zlocal
+
+c
+c Choose smearing of drift distance ...
+c
+c xsmear=0.0
+ xsmear=-0.02+.04*grnd()
+
+ uCoord = HFPP_direction(iSet,iChamber,iLayer,1)*xlocal+
+ > HFPP_direction(iSet,iChamber,iLayer,2)*ylocal
+
+ iWireHit = int(0.5 + (uCoord - HFPP_layeroffset(iSet,
+ > iChamber,iLayer))/HFPP_spacing(iSet,iChamber,iLayer))
+
+ uCoord_wire = iWireHit*HFPP_spacing(iSet,iChamber,iLayer)
+ > + HFPP_layeroffset(iSet,iChamber,iLayer)
+c write(*,*)'U-Coords = ',uCoord,uCoord_wire
+ drift_dist_local = uCoord-uCoord_wire+xsmear
+c write(*,*)'Drift distance =',drift_dist_local
+ if(iWireHit.le.0.or.iWireHit.gt.HFPP_Nwires(iPlane)) then
+ HFPP_raw_tot_hits=HFPP_raw_tot_hits-1
+ goto 1234
+ endif
+ HFPP_drift_dist(iSet,iChamber,iLayer,iWireHit)=drift_dist_local
+c write(*,*)'Slopes,dist,Wire ='
+c > ,hsxp_fp,hsyp_fp,HFPP_drift_dist(iSet,iChamber,iLayer,iWireHit),iWireHit
+c write(*,*)'Wire Number = ',iWireHit
+
+ HFPP_raw_plane(HFPP_raw_tot_hits)=iPlane
+ HFPP_raw_wire(HFPP_raw_tot_hits)=iWireHit
+ HFPP_N_planehitsraw(iPlane)=1
+ HFPP_N_planehits(iPlane)=1
+ HFPP_Nlayershit_set(iSet) = HFPP_Nlayershit_set(iSet)+1
+ HFPP_hit1idx(iPlane,iWireHit) = HFPP_raw_tot_hits
+c write(*,*)'Raw hits: ',iSet,iChamber,iLayer,iPlane,iWireHit,HFPP_raw_tot_hits
+
+1234 continue
+ enddo ! iLayer
+ enddo ! iChamber
+ enddo ! iSet
+
+* * check if we have any work to do
+ if (HFPP_raw_tot_hits .le. 0) RETURN
+
+
+* * now turn raw hits per plane into CLUSTERS per (set,chamber,layer)
+* * if clustering is not desired (HFPP_use_clusters), each cluster has 1 hit only
+ do iSet=1, H_FPP_N_DCSETS
+ if (HFPP_Nlayershit_set(iSet).ge.HFPP_minsethits-5) then ! enough hits for tracking
+
+ do iChamber=1, H_FPP_N_DCINSET
+ do iLayer=1, H_FPP_N_DCLAYERS
+
+ iPlane = H_FPP_N_DCLAYERS * H_FPP_N_DCINSET * (iSet-1)
+ > + H_FPP_N_DCLAYERS * (iChamber-1)
+ > + iLayer
+
+ active_cluster = .false.
+ iCluster = 0
+
+ do iWire=1,HFPP_Nwires(iPlane)
+
+ if (HFPP_hit1idx(iPlane,iWire).eq.0) then ! terminate any active cluster
+ active_cluster = .false.
+ else
+c write(*,*)'Active cluster: ',iPlane,iWire,HFPP_hit1idx(iPlane,iWire)
+ if (active_cluster) then ! add to active cluster
+ Ccount = HFPP_nHitsinCluster(iSet,iChamber,iLayer,iCluster) + 1
+ else !start new cluster
+ active_cluster = (HFPP_use_clusters.gt.0) ! only make clusters if instructed
+ iCluster = min(iCluster+1,H_FPP_MAX_CLUSTERS)
+ HFPP_ClusterinTrack(iSet,iChamber,iLayer,iCluster) = 0
+ Ccount = 1
+ endif
+ if (Ccount.le.H_FPP_MAX_HITSperCLUSTER) then
+* * we can only have so many hits in a cluster -- skip excess
+ HFPP_nHitsinCluster(iSet,iChamber,iLayer,iCluster) = Ccount
+ HFPP_Clusters(iSet,iChamber,iLayer,iCluster,Ccount)
+ > = HFPP_hit1idx(iPlane,iWire)
+ endif
+ endif !HFPP_hit1idx.eq.0
+
+ enddo !iWire
+
+ HFPP_nClusters(iSet,iChamber,iLayer) = iCluster
+ HFPP_NplaneClusters(iPlane) = iCluster !for CTP usage -- max 2d array
+
+c write(*,*)"clustering:"
+c write(*,*)iSet,iChamber,iLayer,iPlane,HFPP_nClusters(iSet,iChamber,iLayer)
+ enddo !iLayer
+ enddo !iChamber
+
+ endif !Nplanes_hit
+ enddo !iSet
+
+
+ RETURN
+ END
+
+ SUBROUTINE GAMMA(X,GA)
+C
+C ==================================================
+C Purpose: Compute the gamma function â(x)
+C Input : x --- Argument of â(x)
+C ( x is not equal to 0,-1,-2,úúú )
+C Output: GA --- â(x)
+C ==================================================
+C
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+ DIMENSION G(26)
+ PI=3.141592653589793D0
+ IF (X.EQ.INT(X)) THEN
+ IF (X.GT.0.0D0) THEN
+ GA=1.0D0
+ M1=X-1
+ DO 10 K=2,M1
+10 GA=GA*K
+ ELSE
+ GA=1.0D+300
+ ENDIF
+ ELSE
+ IF (DABS(X).GT.1.0D0) THEN
+ Z=DABS(X)
+ M=INT(Z)
+ R=1.0D0
+ DO 15 K=1,M
+15 R=R*(Z-K)
+ Z=Z-M
+ ELSE
+ Z=X
+ ENDIF
+ DATA G/1.0D0,0.5772156649015329D0,
+ & -0.6558780715202538D0, -0.420026350340952D-1,
+ & 0.1665386113822915D0,-.421977345555443D-1,
+ & -.96219715278770D-2, .72189432466630D-2,
+ & -.11651675918591D-2, -.2152416741149D-3,
+ & .1280502823882D-3, -.201348547807D-4,
+ & -.12504934821D-5, .11330272320D-5,
+ & -.2056338417D-6, .61160950D-8,
+ & .50020075D-8, -.11812746D-8,
+ & .1043427D-9, .77823D-11,
+ & -.36968D-11, .51D-12,
+ & -.206D-13, -.54D-14, .14D-14, .1D-15/
+ GR=G(26)
+ DO 20 K=25,1,-1
+20 GR=GR*Z+G(K)
+ GA=1.0D0/(GR*Z)
+ IF (DABS(X).GT.1.0D0) THEN
+ GA=GA*R
+ IF (X.LT.0.0D0) GA=-PI/(X*GA*DSIN(PI*X))
+ ENDIF
+ ENDIF
+ RETURN
+ end
diff --git a/HTRACKING/h_trans_misc.f b/HTRACKING/h_trans_misc.f
new file mode 100644
index 0000000..cd0ce44
--- /dev/null
+++ b/HTRACKING/h_trans_misc.f
@@ -0,0 +1,83 @@
+ subroutine h_trans_misc(abort,errmsg)
+*-------------------------------------------------------------------
+* author: John Arrington
+* created: 4/8/95
+*
+* h_trans_misc fills the hms_decoded_misc common block
+*
+* $Log: h_trans_misc.f,v $
+* Revision 1.7.26.1 2008/10/08 17:21:47 cdaq
+* updated for F1 TDC
+*
+* Revision 1.7 1999/01/27 16:02:39 saw
+* Check if some hists are defined before filling
+*
+* Revision 1.6 1996/09/04 14:24:13 saw
+* (JRA) Add misc. tdc's
+*
+* Revision 1.5 1996/01/24 16:00:04 saw
+* (JRA) Replace 48 with hmax_misc_hits
+*
+* Revision 1.4 1996/01/16 21:36:43 cdaq
+* (JRA) Misc. fixes.
+*
+* Revision 1.3 1995/07/20 14:26:00 cdaq
+* (JRA) Add second index (TDC/ADC) to hmisc_dec_data
+*
+* Revision 1.2 1995/05/22 19:39:32 cdaq
+* (SAW) Split gen_data_data_structures into gen, hms, sos, and coin parts"
+*
+* Revision 1.1 1995/04/12 03:59:32 cdaq
+* Initial revision
+*
+*
+*--------------------------------------------------------
+
+ implicit none
+
+ include 'hms_data_structures.cmn'
+ include 'hms_scin_parms.cmn'
+ include 'hms_id_histid.cmn'
+
+ logical abort
+ character*1024 errmsg
+ character*20 here
+ parameter (here = 'h_trans_misc')
+
+ integer*4 ihit,ich,isig,rawtime,corrtime
+
+ save
+
+! Correct for trigger time.
+! If NOT using F1 TDC's, comment this section out
+ do ihit = 1,hmisc_tot_hits
+ ich=hmisc_raw_addr2(ihit)
+ isig=hmisc_raw_addr1(ihit)
+! check if TDC
+! for now just do channels 1-32
+ if(ich.le.32 .and.isig.eq.1) then
+ rawtime = hmisc_raw_data(ihit)
+ if(rawtime.ge.0) then
+ call CORRECT_RAW_TIME_HMS(rawtime,corrtime)
+ hmisc_raw_data(ihit) = corrtime
+ endif
+ endif
+ enddo
+
+ do ihit = 1 , hmax_misc_hits
+ hmisc_dec_data(ihit,1) = 0 ! Clear TDC's
+ hmisc_dec_data(ihit,2) = -1 ! Clear ADC's
+ enddo
+
+ do ihit = 1 , hmisc_tot_hits
+ ich=hmisc_raw_addr2(ihit)
+ isig=hmisc_raw_addr1(ihit)
+ hmisc_dec_data(ich,isig) = hmisc_raw_data(ihit)
+ hmisc_scaler(ich,isig) = hmisc_scaler(ich,isig) + 1
+ if (isig.eq.1.and.hidmisctdcs.gt.0) then !TDC
+ call hf1(hidmisctdcs,float(hmisc_dec_data(ich,isig)),1.)
+ endif
+ enddo
+
+ return
+ end
diff --git a/HTRACKING/h_trans_scin.f b/HTRACKING/h_trans_scin.f
new file mode 100644
index 0000000..bdb091f
--- /dev/null
+++ b/HTRACKING/h_trans_scin.f
@@ -0,0 +1,508 @@
+ subroutine h_trans_scin(abort,errmsg)
+*-------------------------------------------------------------------
+* author: John Arrington
+* created: 2/22/94
+*
+* h_trans_scin fills the hms_decoded_scin common block
+* with track independant corrections and parameters
+* needed for the drift chamber and tof analysis.
+*
+* modifications:
+* Added corrections for trigger time and rollover
+* for F1 TDCs (should still work if go back to FASTBUS)
+* 2008/09/30 P. Bosted
+* $Log: h_trans_scin.f,v $
+* Revision 1.21.8.7 2010/02/23 14:50:40 jones
+* Remove "HMS trigger time max" write statements
+*
+* Revision 1.21.8.6 2009/09/01 19:23:24 jones
+* Initialize hbeta_notrk and hbeta(1) = -100 for every event.
+*
+* Revision 1.21.8.5 2008/11/17 15:59:18 cdaq
+* Changed from old to new tof varaibles
+*
+* Revision 1.21.8.3 2008/10/28 20:57:10 cdaq
+* Changed tdc_offset
+*
+* Revision 1.21.8.2 2008/10/27 16:34:47 cdaq
+* changes for F1 TDCs
+*
+* Revision 1.21.8.1 2008/10/02 17:13:47 cdaq
+* Added F1trig subraction
+*
+* Revision 1.21 2005/03/15 21:08:08 jones
+* Add code to filter the scintillator tdc hits and group them by time. ( P. Bosted)
+*
+* Revision 1.20 2002/10/02 13:42:43 saw
+* Check that user hists are defined before filling
+*
+* Revision 1.19 1999/06/10 16:53:04 csa
+* (JRA) Cosmetic changes
+*
+* Revision 1.18 1996/04/30 12:46:50 saw
+* (JRA) Clean up
+*
+* Revision 1.17 1996/01/16 21:35:37 cdaq
+* (JRA) Misc. fixes.
+*
+* Revision 1.16 1995/05/22 19:39:33 cdaq
+* (SAW) Split gen_data_data_structures into gen, hms, sos, and coin parts"
+*
+* Revision 1.15 1995/05/17 14:12:13 cdaq
+* (JRA) Add hscintimes user histogram
+*
+* Revision 1.14 1995/05/11 19:11:45 cdaq
+* (JRA) Replace hardwired TDC offsets with ctp variables.
+*
+* Revision 1.13 1995/02/23 13:23:49 cdaq
+* (JRA) Add a calculation of beta without finding a track
+*
+* Revision 1.12 1995/02/02 16:36:22 cdaq
+* (JRA) minph variables now per pmt, hscin_adc_pos/neg change to floats
+*
+* Revision 1.11 1995/01/31 21:51:13 cdaq
+* (JRA) Put hit in center of scint if only one tube fired
+*
+* Revision 1.10 1995/01/27 19:28:48 cdaq
+* (JRA) Adjust start time cut to be hardwired for December 94 run. Need a
+* better way to do this eventually.
+*
+* Revision 1.9 1995/01/18 16:28:08 cdaq
+* (SAW) Catch negative ADC values in argument of square root
+*
+* Revision 1.8 1994/09/13 21:40:06 cdaq
+* (JRA) remove obsolete code, fix check for 2 hits, fix hit position
+*
+* Revision 1.7 1994/08/19 03:41:21 cdaq
+* (SAW) Remove a debugging statement that was left in (type *,fptime)
+*
+* Revision 1.6 1994/08/03 14:42:39 cdaq
+* (JRA) Remove outliers from start time calculation
+*
+* Revision 1.5 1994/08/02 20:34:00 cdaq
+* (JRA) Some hacks
+*
+* Revision 1.4 1994/07/27 19:25:56 cdaq
+* ??
+*
+* Revision 1.3 1994/06/29 03:43:27 cdaq
+* (JRA) Add call to h_strip_scin to get good hits from HSCIN_ALL arrays
+*
+* Revision 1.2 1994/04/13 18:03:14 cdaq
+* (DFG) 4/6 Add call to h_fill_scin_raw_hist
+* (DFG) 4/5 Move call to h_prt_raw_scin to h_dump_all_raw
+* (DFG) 3/24 Add h_prt_scin_raw raw bank dump routine
+* Add h_prt_scin_dec decoded print routine
+* Add test for zero hits and skip all but initialization
+* Commented out setting abort = .true.
+* Add ABORT and errmsg to arguements
+*
+* Revision 1.1 1994/02/19 06:21:37 cdaq
+* Initial revision
+*
+*--------------------------------------------------------
+
+ implicit none
+
+ include 'hms_data_structures.cmn'
+ include 'hms_scin_parms.cmn'
+ include 'hms_scin_tof.cmn'
+ include 'hms_id_histid.cmn'
+ include 'f1trigger_data_structures.cmn'
+
+ logical abort
+ character*1024 errmsg
+ character*20 here
+ parameter (here = 'h_trans_scin')
+
+ integer*4 dumtrk
+ parameter (dumtrk=1)
+ integer*4 ihit, plane
+ integer*4 time_num
+ real*4 time_sum
+ real*4 fptime
+ real*4 scint_center
+ real*4 hit_position
+ real*4 dist_from_center,hscin_vel_light
+ real*4 pos_path, neg_path
+ real*4 pos_ph(hmax_scin_hits) !pulse height (channels)
+ real*4 neg_ph(hmax_scin_hits)
+ real*4 postime(hmax_scin_hits)
+ real*4 negtime(hmax_scin_hits)
+ logical goodtime(hnum_scin_planes)
+ integer timehist(200),i,j,jmax,maxhit,nfound
+ real*4 time_pos(1000),time_neg(1000),tmin,time_tolerance
+ logical keep_pos(1000),keep_neg(1000),first/.true./
+ integer rawtime, corrtime
+ save
+
+ abort = .false.
+ hbeta_notrk = -100.
+ hbeta(1) = -100.
+
+
+! Correct for trigger time.
+! If NOT using F1 TDC's, comment this section out
+c write(37,'(/1x,''alltothits='',i3)')
+c > hscin_all_tot_hits
+ do ihit = 1 , hscin_all_tot_hits
+ rawtime = hscin_all_tdc_pos(ihit)
+c postime(ihit) = rawtime
+ if(rawtime.ge.0) then
+ call CORRECT_RAW_TIME_HMS(rawtime,corrtime)
+ hscin_all_tdc_pos(ihit) = corrtime
+ endif
+ rawtime = hscin_all_tdc_neg(ihit)
+c negtime(ihit) = rawtime
+ if(rawtime.ge.0) then
+ call CORRECT_RAW_TIME_HMS(rawtime,corrtime)
+ hscin_all_tdc_neg(ihit) = corrtime
+ endif
+c if(postime(ihit).ge.0. .or.
+c > negtime(ihit).ge.0.)
+c > write(37,'(2i3,f6.0,i5,f6.0,3i5)')
+c > hscin_all_plane_num(ihit),
+c > hscin_all_counter_num(ihit),
+c > postime(ihit),hscin_all_tdc_pos(ihit),
+c > postime(ihit),hscin_all_tdc_neg(ihit),
+c > hscin_all_adc_pos(ihit),
+c > hscin_all_adc_neg(ihit)
+ enddo
+
+
+** Find scintillators with real hits (good TDC values)
+ call h_strip_scin(abort,errmsg)
+ if (abort) then
+ call g_prepend(here,errmsg)
+ return
+ endif
+
+** Initialize track-independant quantaties.
+ call h_tof_init(abort,errmsg)
+ if (abort) then
+ call g_prepend(here,errmsg)
+ return
+ endif
+
+ hgood_start_time = .false.
+ if( hscin_tot_hits .gt. 0) then
+** Histogram raw scin
+ call h_fill_scin_raw_hist(abort,errmsg)
+ if (abort) then
+ call g_prepend(here,errmsg)
+ return
+ endif
+ endif
+
+** Return if no valid hits.
+ if( hscin_tot_hits .le. 0) return
+
+! Calculate all corrected hit times and histogram
+! This uses a copy of code below. Results are save in time_pos,neg
+! including the z-pos. correction assuming nominal value of betap
+! Code is currently hard-wired to look for a peak in the
+! range of 0 to 100 nsec, with a group of times that all
+! agree withing a time_tolerance of time_tolerance nsec. The normal
+! peak position appears to be around 35 nsec (SOS0 or 31 nsec (HMS)
+! NOTE: if want to find farticles with beta different than
+! reference particle, need to make sure this is big enough
+! to accomodate difference in TOF for other particles
+! Default value in case user hasnt definedd something reasonable
+ time_tolerance=3.0
+ if(htof_tolerance.gt.0.5.and.htof_tolerance.lt.10000.) then
+ time_tolerance=htof_tolerance
+ endif
+ if(first) then
+ first=.false.
+ write(*,'(//1x,''USING '',f8.2,'' NSEC WINDOW FOR'',
+ > '' HMS FP NO_TRACK CALCULATIONS'')') time_tolerance
+ write(*,'(//)')
+ endif
+ nfound = 0
+ do j=1,200
+ timehist(j)=0
+ enddo
+ do ihit = 1 , hscin_tot_hits
+ i=min(1000,ihit)
+ time_pos(i)=-99.
+ time_neg(i)=-99.
+ keep_pos(i)=.false.
+ keep_neg(i)=.false.
+ if ((hscin_tdc_pos(ihit) .ge. hscin_tdc_min) .and.
+ 1 (hscin_tdc_pos(ihit) .le. hscin_tdc_max) .and.
+ 2 (hscin_tdc_neg(ihit) .ge. hscin_tdc_min) .and.
+ 3 (hscin_tdc_neg(ihit) .le. hscin_tdc_max)) then
+
+ pos_ph(ihit) = hscin_adc_pos(ihit)
+ postime(ihit) = hscin_tdc_pos(ihit) * hscin_tdc_to_time
+ postime(ihit) = postime(ihit) -
+ > hscin_pos_invadc_offset(ihit) -
+ > hscin_pos_invadc_adc(ihit)/
+ > sqrt(max(20.,pos_ph(ihit)))
+ neg_ph(ihit) = hscin_adc_neg(ihit)
+ negtime(ihit) = hscin_tdc_neg(ihit) * hscin_tdc_to_time
+ negtime(ihit) = negtime(ihit) -
+ > hscin_neg_invadc_offset(ihit) -
+ > hscin_neg_invadc_adc(ihit)/
+ > sqrt(max(20.,neg_ph(ihit)))
+
+* Find hit position. If postime larger, then hit was nearer negative side.
+c changed to here use a fixed velocity of 15 cm/nsec
+ hscin_vel_light=15.
+ dist_from_center = 0.5*(negtime(ihit) - postime(ihit))
+ 1 * hscin_vel_light
+ scint_center = (hscin_pos_coord(ihit)+hscin_neg_coord(ihit))/2.
+ hit_position = scint_center + dist_from_center
+ hit_position = min(hscin_pos_coord(ihit),hit_position)
+ hit_position = max(hscin_neg_coord(ihit),hit_position)
+ hscin_dec_hit_coord(ihit) = hit_position
+
+* Get corrected time.
+ pos_path = hscin_pos_coord(ihit) - hit_position
+ neg_path = hit_position - hscin_neg_coord(ihit)
+ postime(ihit) = postime(ihit) -
+ > pos_path/hscin_pos_invadc_linear(ihit)
+ negtime(ihit) = negtime(ihit) -
+ > neg_path/hscin_neg_invadc_linear(ihit)
+ time_pos(i) = postime(ihit) -
+ > hscin_zpos(ihit) / (29.979*hbeta_pcent)
+ time_neg(i) = negtime(ihit) -
+ > hscin_zpos(ihit) / (29.979*hbeta_pcent)
+ nfound = nfound + 1
+ do j=1,200
+ tmin = 0.5*float(j)
+ if(time_pos(i) .gt. tmin .and.
+ > time_pos(i) .lt. tmin + time_tolerance)
+ > timehist(j) = timehist(j) + 1
+ enddo
+ nfound = nfound + 1
+ do j=1,200
+ tmin = 0.5*float(j)
+ if(time_neg(i) .gt. tmin .and.
+ > time_neg(i) .lt. tmin + time_tolerance)
+ > timehist(j) = timehist(j) + 1
+ enddo
+ endif
+ enddo
+! Find bin with most hits
+ jmax=0
+ maxhit=0
+ do j=1,200
+ if(timehist(j) .gt. maxhit) then
+ jmax = j
+ maxhit = timehist(j)
+ endif
+ enddo
+ if(jmax.gt.0) then
+ tmin = 0.5*float(jmax)
+ do ihit = 1 , hscin_tot_hits
+ i=min(1000,ihit)
+ if(time_pos(i) .gt. tmin .and.
+ > time_pos(i) .lt. tmin + time_tolerance) then
+ keep_pos(i) = .true.
+ endif
+ if(time_neg(i) .gt. tmin .and.
+ > time_neg(i) .lt. tmin + time_tolerance) then
+ keep_neg(i) = .true.
+ endif
+ enddo
+ endif
+
+! Resume regular tof code, now using time filer from above
+** Check for two good TDC values.
+ do ihit = 1 , hscin_tot_hits
+ if ((hscin_tdc_pos(ihit) .ge. hscin_tdc_min) .and.
+ 1 (hscin_tdc_pos(ihit) .le. hscin_tdc_max) .and.
+ 2 (hscin_tdc_neg(ihit) .ge. hscin_tdc_min) .and.
+ 3 (hscin_tdc_neg(ihit) .le. hscin_tdc_max).and.
+ 4 keep_pos(ihit).and.keep_neg(ihit)) then
+ htwo_good_times(ihit) = .true.
+ else
+ htwo_good_times(ihit) = .false.
+ endif
+ enddo !end of loop that finds tube setting time.
+
+** Get corrected time/adc for each scintillator hit
+ do ihit = 1 , hscin_tot_hits
+ if (htwo_good_times(ihit)) then !both tubes fired
+
+* Correct time for everything except veloc. correction in order to
+* find hit location from difference in tdc.
+ pos_ph(ihit) = hscin_adc_pos(ihit)
+ postime(ihit) = hscin_tdc_pos(ihit) * hscin_tdc_to_time
+ postime(ihit) = postime(ihit) -
+ > hscin_pos_invadc_offset(ihit) -
+ > hscin_pos_invadc_adc(ihit)/
+ > sqrt(max(20.,pos_ph(ihit)))
+ neg_ph(ihit) = hscin_adc_neg(ihit)
+ negtime(ihit) = hscin_tdc_neg(ihit) * hscin_tdc_to_time
+ negtime(ihit) = negtime(ihit) -
+ > hscin_neg_invadc_offset(ihit) -
+ > hscin_neg_invadc_adc(ihit)/
+ > sqrt(max(20.,neg_ph(ihit)))
+* Find hit position. If postime larger, then hit was nearer negative side.
+ dist_from_center = 0.5*(negtime(ihit) - postime(ihit))
+ 1 * hscin_vel_light
+ scint_center = (hscin_pos_coord(ihit)+hscin_neg_coord(ihit))/2.
+ hit_position = scint_center + dist_from_center
+ hit_position = min(hscin_pos_coord(ihit),hit_position)
+ hit_position = max(hscin_neg_coord(ihit),hit_position)
+ hscin_dec_hit_coord(ihit) = hit_position
+
+* Get corrected time.
+ pos_path = hscin_pos_coord(ihit) - hit_position
+ neg_path = hit_position - hscin_neg_coord(ihit)
+ postime(ihit) = postime(ihit) -
+ > pos_path/hscin_pos_invadc_linear(ihit)
+ negtime(ihit) = negtime(ihit) -
+ > neg_path/hscin_neg_invadc_linear(ihit)
+ hscin_cor_time(ihit) = ( postime(ihit) + negtime(ihit) )/2.
+
+ else !only 1 tube fired
+ hscin_dec_hit_coord(ihit) = 0.
+ hscin_cor_time(ihit) = 0. !not a very good 'flag', but there is
+ ! the logical htwo_good_hits.
+ endif
+ enddo !loop over hits to find ave time,adc.
+
+* start time calculation. assume xp=yp=0 radians. project all
+* time values to focal plane. use average for start time.
+ time_num = 0
+ time_sum = 0.
+ do ihit = 1 , hscin_tot_hits
+ if (htwo_good_times(ihit)) then
+ fptime = hscin_cor_time(ihit) - hscin_zpos(ihit)/(29.979*hbeta_pcent)
+ if(hidscinalltimes.gt.0) call hf1(hidscinalltimes,fptime,1.)
+ if (abs(fptime-hstart_time_center).le.hstart_time_slop) then
+ time_sum = time_sum + fptime
+ time_num = time_num + 1
+ endif
+ endif
+ enddo
+ if (time_num.eq.0) then
+ hgood_start_time = .false.
+ hstart_time = hstart_time_center
+ else
+ hgood_start_time = .true.
+ hstart_time = time_sum / float(time_num)
+ endif
+
+
+* Dump decoded bank if hdebugprintscindec is set
+ if( hdebugprintscindec .ne. 0) call h_prt_dec_scin(ABORT,errmsg)
+
+* Calculate beta without finding track (to reject cosmics for efficiencies)
+* using tube only if both pmts fired since the velocity correction is
+* position (track) dependant.
+* Fitting routine fills variables assuming track=1.
+
+ do plane = 1 , hnum_scin_planes
+ goodtime(plane)=.false.
+ enddo
+
+ do ihit = 1 , hscin_tot_hits
+ hgood_scin_time(dumtrk,ihit)=.false.
+ if (htwo_good_times(ihit)) then !require 2 tubes to be track indep.
+ if (abs(fptime-hstart_time_center).le.hstart_time_slop) then ! throw out outliers.
+ hgood_scin_time(dumtrk,ihit)=.true.
+ hscin_time(ihit)=hscin_cor_time(ihit)
+ hscin_sigma(ihit)=sqrt(hscin_neg_sigma(ihit)**2 +
+ & hscin_pos_sigma(ihit)**2)/2.
+ goodtime(hscin_plane_num(ihit))=.true.
+ endif
+ endif
+ enddo
+
+
+* Fit beta if there are enough time measurements (one upper, one lower)
+ if ((goodtime(1) .or. goodtime(2)) .and.
+ 1 (goodtime(3) .or. goodtime(4))) then
+
+ hxp_fp(dumtrk)=0.0
+ hyp_fp(dumtrk)=0.0
+ call h_tof_fit(abort,errmsg,dumtrk) !fit velocity of particle
+ if (abort) then
+ call g_prepend(here,errmsg)
+ return
+ endif
+ hbeta_notrk = hbeta(dumtrk)
+ hbeta_chisq_notrk = hbeta_chisq(dumtrk)
+ else
+ hbeta_notrk = 0.
+ hbeta_chisq_notrk = -1.
+ endif
+
+ return
+ end
+
+c subtract trigger times
+ SUBROUTINE CORRECT_RAW_TIME_HMS(RAW_TDC,CORRECTED_TDC)
+ IMPLICIT NONE
+ include 'hms_data_structures.cmn'
+ include 'f1trigger_data_structures.cmn'
+c
+c Function arguments are RAW_TDC -raw TDC value
+c and CORRECTED_TDC -Corrected by Trigger time and rolover time
+c MAKE SURE TO Include correct parameter files
+c
+c
+ integer*4 RAW_TDC, CORRECTED_TDC,tdc_offset
+ integer*4 nprint
+ logical roll
+ save
+
+c hard-wired to make TDC spectra centered on 1500
+c or so. This is for F1 TDCs
+ tdc_offset=1200
+
+C correct for trigger time. If using F1 TDC's, make
+C sure rolloever values are defined in parameter file
+ if(HMS_TRIGGER_COUNTER.eq.0.or.
+ > HMS_TRIGGER_COUNTER.gt.10) then
+ write(6,'(''error, HMS_TRIGGER_COUNTER='',i4)')
+ > HMS_TRIGGER_COUNTER
+c set to useful default
+ HMS_TRIGGER_COUNTER=1
+ endif
+ if(HMS_TRIGGER_WINDOW.lt.100) then
+ write(6,'(''error, HMS_TRIGGER_WINDOW='',i5)')
+ > HMS_TRIGGER_WINDOW
+ HMS_TRIGGER_WINDOW = 2000
+ endif
+
+c find largest value of trigger time, to check rollover
+
+c subtract trigger time
+c and add a constant so generally in range
+c of 1000 to 3000
+ CORRECTED_TDC = RAW_TDC -
+ > TRIGGER_F1_START_TDC_COUNTER(HMS_TRIGGER_COUNTER)
+ > + tdc_offset
+c
+c Taking care of ROLOVER For
+c
+ roll = .false.
+c This happens if scin. TDC rolled over
+ if(CORRECTED_TDC.lt.-30000) then
+ CORRECTED_TDC = CORRECTED_TDC +
+ > TRIGGER_F1_ROLOVER(HMS_TRIGGER_COUNTER)
+ roll = .true.
+ endif
+
+c This happens if trigger TDC rolled over
+ if(CORRECTED_TDC.gt.30000) then
+ CORRECTED_TDC = CORRECTED_TDC -
+ > TRIGGER_F1_ROLOVER(HMS_TRIGGER_COUNTER)
+ roll=.true.
+ endif
+
+ if(nprint.lt.0.and.roll) then
+ write(6,'(''dbg hscin'',4i8)')
+ > RAW_TDC, CORRECTED_TDC,
+ > TRIGGER_F1_START_TDC_COUNTER(
+ > HMS_TRIGGER_COUNTER)
+ nprint = nprint+1
+ endif
+
+ return
+ end
diff --git a/HTRACKING/h_wire_center_calc.f b/HTRACKING/h_wire_center_calc.f
new file mode 100644
index 0000000..e1ac50e
--- /dev/null
+++ b/HTRACKING/h_wire_center_calc.f
@@ -0,0 +1,52 @@
+ function h_wire_center_calc(plane,wire)
+*
+* function to calculate hms wire center positions in hms
+* wire chambers
+*
+* d.f. geesaman 17 feb 1994
+*
+* modified dfg 18 feb 1994
+* add option to reverse plane wire numbering
+* $Log: h_wire_center_calc.f,v $
+* Revision 1.5 1996/09/04 14:24:38 saw
+* (??) Cosmetic
+*
+* Revision 1.4 1995/05/22 19:39:33 cdaq
+* (SAW) Split gen_data_data_structures into gen, hms, sos, and coin parts"
+*
+* Revision 1.3 1994/09/13 21:49:06 cdaq
+* (JRA) Calculate wire chamber offsets
+*
+* Revision 1.2 1994/02/22 05:34:03 cdaq
+* (SAW) Remove FLOAT call on floating arg
+*
+* Revision 1.1 1994/02/19 06:22:00 cdaq
+* Initial revision
+*
+*
+*
+ implicit none
+ include "hms_data_structures.cmn"
+ include "hms_geometry.cmn"
+*
+* input
+*
+ integer*4 plane ! plane number of hit
+ integer*4 wire ! wire number of hit
+*
+* output
+*
+ real*4 h_wire_center_calc ! wire center in cm
+*
+* if hdc_sire_counting(plane) is 1 then wires are number in reverse order
+ if(hdc_wire_counting(plane).eq.0) then
+* normal ordering
+ h_wire_center_calc = (FLOAT(wire)-hdc_central_wire(plane))
+ & * hdc_pitch(plane) - hdc_center(plane)
+ else
+ h_wire_center_calc =
+ & ((hdc_nrwire(plane) + (1 - wire))- hdc_central_wire(plane))
+ & * hdc_pitch(plane) - hdc_center(plane)
+ endif
+ return
+ end
diff --git a/HTRACKING/hms_sane_track.f b/HTRACKING/hms_sane_track.f
new file mode 100755
index 0000000..7220d00
--- /dev/null
+++ b/HTRACKING/hms_sane_track.f
@@ -0,0 +1,383 @@
+*------------------------------------------------------------------------
+*
+* HMS_TRACK HMS Tracking Routines
+* -=========-
+*
+* Forward and Backward Tracking of electrons in the Jlab HMS hall
+* C spectrometer
+*
+* Note: - the HMS routines use a lab (HMS) coord. system
+* and the corresponding COSY coord. system, both
+* right handed with
+* x : pointing downwards
+* y : perpendicular to x,z,
+* pointing to the left (if seen in z-direction)
+* z : HMS axis, pointing from the target to the focal plane
+*
+* - all lengths (x,y,z,l,...) are measured in [m]
+* - all angles are measured as dx/dz,dy/dz (lab coords.)
+* or as A,B (COSY coords.)
+* - the momentum is measured in delta (relative momentum
+* deviation = 1-p0/pHMS)
+*
+* PART 1: Forward tracking using COSY transport matrices
+*
+*
+* PART 2: Reconstruction (backward tracking) using reconstruction
+* and COSY transport matrices (including the
+* effects of a vertical beam offset (out-of plane))
+*
+*
+* written by Markus Muehlbauer for the GEN Experiment
+*
+* frw 9/2000
+* changes made in the course of the migration to g77 compiler:
+* - fixed some typos (old ones, too)
+* - all COSY conversion code was already commented out (why?
+* by who?) so I removed it and made the code more readable
+* - various variables were not initialized prior to reading
+* from file. This may or may not be an issue, but fixed it
+* anyway
+*
+*------------------------------------------------------------------------
+
+*------------------------------------------------------------------------
+*
+* PART 1: HMS Forward Tracking (Target to Focal Plane)
+* -=======-
+*
+* Forward tracking in the Jlab HMS hall C spectrometer
+* using COSY transport matrices
+*
+* developed by Cris Cothran
+* modified by Markus Muehlbauer
+* - CCs orignal program converted into subroutines
+* - mad additions for pure tracking, without checking the acceptance
+* - and changed the innermost loops applying the matrix
+* (which speeds up the whole thing by a factor of about 30)
+*
+* Supplies:
+* hmsInitForward (map)
+* load the forward transport maps
+* hmsForward (uT,zT,u,z)
+* make a single step transport calculation
+* (without treating the acceptance)
+* hmsAccept (uT,zT,u,z)
+* make a multi step transport calculation
+* (also treating the acceptance)
+*
+* Note: - Before calling hmsForward or hmsAccept the forward
+* transport maps have to be loaded by a call to hmsInitForward
+*------------------------------------------------------------------------
+
+*------------------------------------------------------------------------
+
+
+*------------------------------------------------------------------------
+*------------------------------------------------------------------------
+*
+* PART 2: HMS Reconstruction (Backward Tracking; Focal Plane to Target)
+* -=======-
+*
+* Reconstruction (backward tracking) in the Jlab HMS hall C
+* spectrometer using reconstruction and forward COSY matrices
+* (including the effects of beam offsets (out-of plane))
+*
+* Both the normal in-plane scattering and the more special
+* out-of-plane scattering are handeled. The later makes use
+* of the forward COSY matrices. The algorithm was tested for
+* beam offsets in the range of cm (up or below the
+* nominal scattering plane)
+*
+* Supplies:
+* hmsInitRecon (map,p0)
+* load the reconstruction maps
+* hmsInPlane (u,uT,ok)
+* reconstruction of the target coordinates
+* (delta, dx/dz, y, dy/dz) at z=0
+* hmsOutOfPlane (u,x,uT,ok)
+* reconstruction of the target coordinates
+* (delta, dx/dz, y, dy/dz) at z=0 including the
+* vertical beam offset
+*
+* Note: - Before calling hmsReconInPlane or hmsReconOutOfPlaneAccept
+* the reconstruction map has to be loaded by a call to
+* hmsInitRecon
+* - Before calling hmsReconOutOfPlane the forward transport
+* maps have to be loaded by a call to hmsInitForward
+*------------------------------------------------------------------------
+
+************************************************************
+************************************************************
+
+ SUBROUTINE genRecon (u,x,y,uT,ok,dx,bdl,th,p,mass,spect)
+ IMPLICIT NONE
+ REAL u(5),x,y,uT(6)
+
+ LOGICAL ok
+ real p,pp,p_spec ! momentum (MeV). (mom<0 for e-, mom>0 for p,d)
+ real mass ! mass of particle (MeV)
+ integer spect
+ REAL*8 TARGET_COORD(6),Eprot,Pprot
+ COMMON/TARGET_GENRECON/TARGET_COORD,Eprot,Pprot
+ INCLUDE 'gen_constants.par'
+
+
+* -- performs the reconstruction of the target coordinates
+* (delta, dx/dz, y, dy/dz) including the effects of the
+* target magnetic field and the vertical beam offset
+*
+* Parameter:
+* u I : focal plane coordinates
+* u(1,2) : x [m], dx/dz = out of plane coords. (downwards)
+* u(3,4) : y [m], dy/dz = inplane coords. (perp. on x,z)
+* u(5) : vert. beam offset [m] (out of plane coord.; downwards)
+* x I : vert. beam offset [m] (out of plane coord.; downwards)
+* y I : hori. beam offsey [m] (inplane coord.; perp on x-beam, z-beam)
+* uT O : target coordinates
+* uT(1,2) : x [m], dx/dz = out of plane coord. (downwards)
+* uT(3,4) : y [m], dy/dz = inplane coord. (perp. on x,z)
+* uT(5) : z [m] = in axis coordinate (towards HMS)
+* uT(6) : delta = relative deviation of the particle
+* momentum from p0
+* spect = -1 track electron +1 track proton
+* ok IO : status variable
+* - if false no action is taken
+* - set to false when no reconstruction is found
+ real*4 th
+ REAL*8 ctheta,stheta ! cosine and sine of central spectrometer angle
+
+* COMMON /genParameter/theta,ctheta,stheta,p
+c
+ INCLUDE 'gen_event_info.cmn'
+ logical outside_fieldmap
+ common /mkjtemp/ outside_fieldmap
+
+! REAL xx,dx,vT(6),vTx(6),utsave(6),vtsave(6),usave(4)
+ REAL*8 xx,vT(9),vTx(9),utsave(6),vtsave(6),usave(6)
+ real dx
+ real*8 save_dx,save_diff_dx,vtfirst(9)
+ INTEGER i,n,ii
+ real*8 REF_VAL
+ parameter (REF_VAL=100.) ! converts to cm
+ real*8 OTHER_REF
+ parameter (OTHER_REF=30.)
+
+ REAL eps ! accurracy for x in mm
+ PARAMETER (eps = 0.2) ! (one more iteration is performed
+! after the given accuraccy is reached)
+ real bdl
+ real*8 eng ! energy of the particle
+ integer flag_az ! OR - 7/04
+ common /azimuth/ flag_az ! OR - 7/04
+
+ flag_az = 1 ! OR - 7/04
+c
+ bdl = 0.0
+ xx = u(5)
+
+! find a first approximation for uT
+ CALL hmsReconXtar (u,uT,ok)
+c write(*,*)dx,th,p,mass
+ IF (.NOT. ok) RETURN
+! drift to a field free region and calculate the velocities
+ vT(1) = REF_VAL*(uT(1)+1.*uT(2))
+ vT(2) = REF_VAL*(uT(3)+1.*uT(4))
+ vT(3) = REF_VAL*1.
+ vT(6) = OTHER_REF/SQRT(1+uT(2)**2+uT(4)**2)
+ vT(4) = uT(2)*vT(6)
+ vT(5) = uT(4)*vT(6)
+ do ii=1,6
+ utsave(ii)=ut(ii)
+ vtsave(ii)=vt(ii)
+ enddo
+
+* Here need to to implement detection of protons/electrons in the HMS arm
+* p should be initialized as hpcentral
+
+ ctheta = COS(th*degree)
+ stheta = SIN(th*degree)
+ p_spec = p
+ pp=(uT(6)-1)*p_spec
+ eng = spect*sqrt(pp**2+mass**2)/MeV
+
+ do i=1,6
+ vtfirst(i) = vt(i)
+ enddo
+! track into the magnetic field to the beam plane (perp. to y)
+ CALL trgTrackToPlaneBDL (vT,eng,1.0d00,0.0d00,-ctheta,stheta,y*REF_VAL,ok)
+ vtfirst(7) = vT(7)
+ vtfirst(8) = vT(8)
+ vtfirst(9) = vT(9)
+
+c if ( .not. ok) then
+c write(*,*) '**** failed first call to trgTrackToPlane in gen_recon *** outside fieldmap = ',outside_fieldmap
+c endif
+ n = 0
+ dx = 1.
+ save_diff_dx = 1.
+ save_dx=dx
+ DO WHILE ((dx .GT. .1) .AND. (n .LT. 10) .and. (save_diff_dx .gt. 0) .AND. ok)
+ dx = abs(x*REF_VAL-vT(1))
+
+! track to the z=0 plane to find a correction for the x-offset
+ vTx(1) = REF_VAL*x
+
+ DO i=2,6
+ vTx(i) = vT(i)
+ ENDDO
+ CALL trgTrackToPlaneBDL (vT,eng,1.0d00,0.0d00,0.0d00,1.0d00,0.0d00,ok)
+ CALL trgTrackToPlaneBDL (vTx,eng,1.0d00,0.0d00,0.0d00,1.0d00,0.0d00,ok)
+ xx = xx + (vTx(1)-vT(1))*0.01
+ u(5) = xx
+ CALL hmsReconXtar (u,uT,ok)
+ pp=(uT(6)-1)*p_spec
+ eng = spect*sqrt(pp**2+mass**2)/MeV
+c write(*,*)'1 ',REF_VAL*(uu1T(1)+1.*uu1T(2))-x*ref_val,REF_VAL*(uu1T(3)+1.*uu1T(4))-y*ref_val
+c write(*,*)'2 ',REF_VAL*(uu2T(1)+1.*uu2T(2))-x*ref_val,REF_VAL*(uu2T(3)+1.*uu2T(4))-y*ref_val
+c write(*,*)'3 ',REF_VAL*(uu3T(1)+1.*uu3T(2))-x*ref_val,REF_VAL*(uu3T(3)+1.*uu3T(4))-y*ref_val
+
+! drift to a field free region and calculate the velocities
+ vT(1) = REF_VAL*(uT(1)+1.*uT(2))
+ vT(2) = REF_VAL*(uT(3)+1.*uT(4))
+ vT(3) = REF_VAL*1.
+ vT(6) = OTHER_REF/SQRT(1+uT(2)**2+uT(4)**2)
+ vT(4) = uT(2)*vT(6)
+ vT(5) = uT(4)*vT(6)
+
+
+ CALL trgTrackToPlaneBDL (vT,eng,1.0d00,0.0d00,-ctheta,stheta,y*REF_VAL,ok)
+
+
+
+
+ bdl = sqrt(vT(7)**2+vT(8)**2+vT(9)**2)
+ dx = abs(x*REF_VAL-vT(1))
+ save_diff_dx = save_dx - dx
+ if (save_diff_dx .lt. 0 .and. n .ne. 0) then
+ do ii=1,6
+ vt(ii)=vtsave(ii)
+ enddo
+ ok = .false.
+ if ( save_dx .le. 1.0) ok = .true.
+ else
+ n = n+1
+ do ii=1,6
+ vtsave(ii)=vt(ii)
+ enddo
+ save_dx = dx
+ endif
+ ENDDO
+ IF (n .ge. 10 ) ok = .FALSE.
+ if (.not. ok) then
+ endif
+! calculate the result in HMS coordinates
+
+ TARGET_COORD(1) = VT(1)
+ TARGET_COORD(2) = VT(2)
+ TARGET_COORD(3) = VT(3)
+ TARGET_COORD(4) = VT(4) !p*1000*VT(4)/29.97/eng
+ TARGET_COORD(5) = VT(5) !p*1000*VT(5)/29.97/eng
+ TARGET_COORD(6) = VT(6) !p*1000*VT(6)/29.97/eng
+ Eprot = eng
+ Pprot = p
+c write(*,*)x*100.,y*100
+c write(*,*)Vt(1),Vt(2)
+c write(*,*)Vtold(1),Vtold(2)
+
+ uT(1) = 0.01*vT(1)
+ uT(2) = vT(4)/vT(6)
+ uT(3) = 0.01*vT(2)
+ uT(4) = vT(5)/vT(6)
+ uT(5) = 0.01*vT(3)
+c write(*,*) ' after tracktoplane uT = ',uT
+ RETURN
+ END
+
+**************************************************************
+**************************************************************
+
+ SUBROUTINE hmsReconXtar (u,uT,ok)
+ IMPLICIT NONE
+ REAL u(5),uT(6)
+ LOGICAL ok
+
+
+ include 'gen_filenames.cmn'
+ include 'gen_data_structures.cmn'
+ include 'hms_filenames.cmn'
+ include 'hms_data_structures.cmn'
+ include 'hms_recon_elements.cmn'
+ include 'hms_bypass_switches.cmn'
+
+ INCLUDE 'gen_constants.par'
+ INCLUDE 'gen_units.par'
+ INCLUDE 'hms_tracking.cmn'
+ INCLUDE 'hms_track_histid.cmn'
+ INCLUDE 'hms_physics_sing.cmn'
+ INCLUDE 'sane_data_structures.cmn'
+
+
+* -- performs the reconstruction of the target coordinates
+* (delta, dx/dz, y, dy/dz) at z=0
+*
+* Parameter:
+* u I : focal plane coordinates (lab)
+* u(1,2) : x [m], dx/dz = out of plane coord. (downwards)
+* u(3,4) : y [m], dy/dz = inplane coord. (perp. on x,z)
+* u(5) : xtarget [m] from raster info
+* uT O : target coordinates (lab)
+* uT(1,2) : x [m], dx/dz = out of plane coord. (downwards)
+* uT(3,4) : y [m], dy/dz = inplane coord. (perp. on x,z)
+* uT(5) : z [m] = in axis coordinate (towards HMS)
+* uT(6) : delta (relative deviation of the particle
+* momentum from p0)
+* ok IO : status variable
+* - if false no action is taken
+* - set to false when no reconstruction is found
+
+ ! matrix elemnts needed for calculating the focal plane offset
+
+ INTEGER i,j
+ REAL tm
+ real sum(4),hut_rot(5)
+
+ COMMON /hmsfocalplane/sum,hut_rot
+ DO i=1,6
+ uT(i) = 0.
+ ENDDO
+
+* Reset COSY sums.
+ do i = 1,4
+ sum(i) = 0.
+ enddo
+
+
+ do i = 1,h_num_recon_terms
+ tm = 1
+ do j = 1,5
+ if (h_recon_expon(j,i).ne.0.) then
+ tm = tm*u(j)**h_recon_expon(j,i)
+ endif
+ enddo
+ sum(1) = sum(1) + tm*h_recon_coeff(1,i) ! xp uT(2) trg(2)
+ sum(2) = sum(2) + tm*h_recon_coeff(2,i) ! y uT(3) trg(3)
+ sum(3) = sum(3) + tm*h_recon_coeff(3,i) ! yp uT(4) trg(4)
+ sum(4) = sum(4) + tm*h_recon_coeff(4,i) ! delta uT(6) trg(6)
+ enddo
+ ! uT(5),trg(5) is z-position along the HMS spectrometer axis
+ ! used in tracking back to the target
+! uT(1),trg(1) is xtarget position, measured by slow raster.
+ uT(1) = u(5)
+ uT(2) = sum(1) ! unit meters
+ uT(3) = sum(2) ! unit meters
+ uT(4) = sum(3)
+ uT(5) = 0 ! not important at this point
+ uT(6) = sum(4) !
+
+
+ ok = ((ABS(uT(2)) .LT. 1.) .AND. (ABS(uT(3)) .LT. 1.) .AND.
+ > (ABS(uT(4)) .LT. 1.) .AND. (ABS(uT(6)) .LT. 1.))
+ RETURN
+ END
+
diff --git a/HTRACKING/mt19937.f b/HTRACKING/mt19937.f
new file mode 100644
index 0000000..a2ac254
--- /dev/null
+++ b/HTRACKING/mt19937.f
@@ -0,0 +1,161 @@
+* A C-program for MT19937: Real number version
+* genrand() generates one pseudorandom real number (double)
+* which is uniformly distributed on [0,1]-interval, for each
+* call. sgenrand(seed) set initial values to the working area
+* of 624 words. Before genrand(), sgenrand(seed) must be
+* called once. (seed is any 32-bit integer except for 0).
+* Integer generator is obtained by modifying two lines.
+* Coded by Takuji Nishimura, considering the suggestions by
+* Topher Cooper and Marc Rieffel in July-Aug. 1997.
+*
+* This library is free software; you can redistribute it and/or
+* modify it under the terms of the GNU Library General Public
+* License as published by the Free Software Foundation; either
+* version 2 of the License, or (at your option) any later
+* version.
+* This library is distributed in the hope that it will be useful,
+* but WITHOUT ANY WARRANTY; without even the implied warranty of
+* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+* See the GNU Library General Public License for more details.
+* You should have received a copy of the GNU Library General
+* Public License along with this library; if not, write to the
+* Free Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
+* 02111-1307 USA
+*
+* Copyright (C) 1997 Makoto Matsumoto and Takuji Nishimura.
+* When you use this, send an email to: matumoto@math.keio.ac.jp
+* with an appropriate reference to your work.
+*
+************************************************************************
+* Fortran translation by Hiroshi Takano. Jan. 13, 1999.
+*
+* genrand() -> double precision function grnd()
+* sgenrand(seed) -> subroutine sgrnd(seed)
+* integer seed
+*
+* This program uses the following non-standard intrinsics.
+* ishft(i,n): If n>0, shifts bits in i by n positions to left.
+* If n<0, shifts bits in i by n positions to right.
+* iand (i,j): Performs logical AND on corresponding bits of i and j.
+* ior (i,j): Performs inclusive OR on corresponding bits of i and j.
+* ieor (i,j): Performs exclusive OR on corresponding bits of i and j.
+*
+************************************************************************
+* this main() outputs first 1000 generated numbers
+ccc program main
+ccc
+ccc implicit integer(i-n)
+ccc implicit double precision(a-h,o-z)
+ccc
+ccc parameter(no=1000)
+ccc dimension r(0:7)
+ccc
+ccc* call sgrnd(4357)
+ccc* any nonzero integer can be used as a seed
+ccc do 1000 j=0,no-1
+ccc r(mod(j,8))=grnd()
+ccc if(mod(j,8).eq.7) then
+ccc write(*,'(8(f8.6,'' ''))') (r(k),k=0,7)
+ccc else if(j.eq.no-1) then
+ccc write(*,'(8(f8.6,'' ''))') (r(k),k=0,mod(no-1,8))
+ccc endif
+ccc 1000 continue
+ccc
+ccc stop
+ccc end
+************************************************************************
+ subroutine sgrnd(seed)
+
+ implicit none
+
+* Period parameters
+ integer N
+ parameter(N=624)
+
+ integer mti
+ integer mt(0:N-1) !the array for the state vector
+ common /block/mti,mt
+ save /block/
+
+ integer seed
+
+*setting initial seeds to mt[N] using the generator Line 25 of Table 1 in
+* [KNUTH 1981, The Art of Computer Programming Vol. 2 (2nd Ed.), pp102]
+
+ mt(0)= iand(seed,-1)
+ do 1000 mti=1,N-1
+ mt(mti) = iand(69069 * mt(mti-1),-1)
+ 1000 continue
+
+ return
+ end
+************************************************************************
+ double precision function grnd()
+
+ implicit none
+
+ integer N,N1,M
+ integer MATA,UMASK,LMASK
+ integer TMASKB,TMASKC
+
+* Period parameters
+ parameter(N = 624)
+ parameter(N1 = N+1)
+ parameter(M = 397)
+ parameter(MATA = -1727483681) !constant vector a
+c parameter(UMASK = -2147483648) !most significant w-r bits
+ parameter(LMASK = 2147483647) !least significant r bits
+* Tempering parameters
+ parameter(TMASKB= -1658038656)
+ parameter(TMASKC= -272236544)
+
+ integer mti
+ integer mt(0:N-1) !the array for the state vector
+ common /block/mti,mt
+ save /block/
+
+ integer mag01(0:1)
+ save mag01 !mag01(x) = x * MATA for x=0,1
+
+ integer y
+ integer kk
+
+ data mti/N1/ !mti==N+1 means mt[N] is not initialized
+ data mag01/0, MATA/
+
+ UMASK=-2**30
+ UMASK=-2*UMASK
+
+ if(mti.ge.N) then !generate N words at one time
+ if(mti.eq.N+1) then !if sgrnd() has not been called,
+ call sgrnd(4357) !a default initial seed is used
+ endif
+
+ do 1000 kk=0,N-M-1
+ y=ior(iand(mt(kk),UMASK),iand(mt(kk+1),LMASK))
+ mt(kk)=ieor(ieor(mt(kk+M),ishft(y,-1)),mag01(iand(y,1)))
+ 1000 continue
+ do 1100 kk=N-M,N-2
+ y=ior(iand(mt(kk),UMASK),iand(mt(kk+1),LMASK))
+ mt(kk)=ieor(ieor(mt(kk+(M-N)),ishft(y,-1)),mag01(iand(y,1)))
+ 1100 continue
+ y=ior(iand(mt(N-1),UMASK),iand(mt(0),LMASK))
+ mt(N-1)=ieor(ieor(mt(M-1),ishft(y,-1)),mag01(iand(y,1)))
+ mti = 0
+ endif
+
+ y=mt(mti)
+ mti=mti+1
+ y=ieor(y,ishft(y,-11))
+ y=ieor(y,iand(ishft(y,7),TMASKB))
+ y=ieor(y,iand(ishft(y,15),TMASKC))
+ y=ieor(y,ishft(y,-18))
+
+ if(y.lt.0) then
+ grnd=(dble(y)+2.0d0**32)/(2.0d0**32-1.0d0)
+ else
+ grnd=dble(y)/(2.0d0**32-1.0d0)
+ endif
+
+ return
+ end
diff --git a/INCLUDE/CVS/Entries b/INCLUDE/CVS/Entries
new file mode 100644
index 0000000..7675ec2
--- /dev/null
+++ b/INCLUDE/CVS/Entries
@@ -0,0 +1,102 @@
+/Makefile/1.10.24.4/Wed Sep 12 10:35:15 2007//Tsane
+/b_ntuple.cmn/1.1.2.19.2.3/Mon Jun 28 13:34:54 2010//Tsane
+/b_ntuple.dte/1.1.2.1/Tue May 15 02:53:33 2007//Tsane
+/bigcal_bypass_switches.cmn/1.1.2.10.2.2/Tue Mar 31 19:32:59 2009//Tsane
+/bigcal_data_structures.cmn/1.1.2.22.2.1/Tue Mar 31 19:32:59 2009//Tsane
+/bigcal_filenames.cmn/1.1.2.8/Thu Nov 29 19:07:19 2007//Tsane
+/bigcal_gain_parms.cmn/1.1.2.5/Wed Oct 24 16:56:35 2007//Tsane
+/bigcal_geometry.cmn/1.1.2.2/Tue Jul 17 23:03:15 2007//Tsane
+/bigcal_hist_id.cmn/1.1.2.9/Sun Nov 25 23:35:50 2007//Tsane
+/bigcal_shower_parms.cmn/1.1.2.3.2.1/Thu May 15 19:04:32 2008//Tsane
+/bigcal_tof_parms.cmn/1.1.2.3/Fri Dec 7 21:41:25 2007//Tsane
+/c_ntuple.cmn/1.4/Tue Feb 17 16:41:45 2004//Tsane
+/c_ntuple.dte/1.1/Fri Jun 17 02:05:04 1994//Tsane
+/coin_bypass_switches.cmn/1.1/Thu May 11 15:21:44 1995//Tsane
+/coin_data_structures.cmn/1.4/Thu Dec 18 18:11:02 2003//Tsane
+/coin_filenames.cmn/1.7/Wed Feb 16 20:44:57 2005//Tsane
+/f1trigger_data_structures.cmn/1.1.2.1/Thu Oct 2 18:01:48 2008//Tsane
+/gen_constants.par/1.5/Mon Dec 7 22:11:23 1998//Tsane
+/gen_craw.cmn/1.2/Fri Mar 19 15:22:31 1999//Tsane
+/gen_data_structures.cmn/1.35.20.7.2.6/Fri Jan 16 18:48:01 2009//Tsane
+/gen_decode_F1tdc.cmn/1.1.2.3/Tue Oct 16 19:44:48 2007//Tsane
+/gen_decode_common.cmn/1.4.24.7/Tue Sep 11 19:14:18 2007//Tsane
+/gen_detectorids.par/1.8.24.3.2.4/Fri Jan 30 20:33:28 2009//Tsane
+/gen_epics.cmn/1.1/Wed Feb 24 14:39:05 1999//Tsane
+/gen_event_info.cmn/1.2.24.1/Wed Oct 17 16:04:23 2007//Tsane
+/gen_filenames.cmn/1.14/Fri Sep 5 20:10:27 2003//Tsane
+/gen_input_info.cmn/1.1/Mon Feb 7 19:39:25 1994//Tsane
+/gen_one_ev_gckine.cmn/1.1/Wed Jan 17 15:43:35 1996//Tsane
+/gen_one_ev_gctrak.cmn/1.1/Wed Jan 17 15:44:19 1996//Tsane
+/gen_one_ev_gcvolu.cmn/1.1/Wed Jan 17 15:44:43 1996//Tsane
+/gen_one_ev_info.cmn/1.1/Mon Sep 18 20:22:39 1995//Tsane
+/gen_one_ev_info.dte/1.1/Wed Jan 17 15:46:04 1996//Tsane
+/gen_output_info.cmn/1.1/Tue Feb 22 20:04:11 1994//Tsane
+/gen_pawspace.cmn/1.2.24.3.2.1/Fri Jan 16 18:48:01 2009//Tsane
+/gen_routines.dec/1.9/Thu Jul 8 18:11:52 2004//Tsane
+/gen_run_info.cmn/1.7.24.5/Fri Nov 2 22:36:53 2007//Tsane
+/gen_run_info.dte/1.3/Fri Jul 28 15:15:48 1995//Tsane
+/gen_run_pref.cmn/1.4/Tue Oct 18 20:34:47 1994//Tsane
+/gen_run_pref.dte/1.2/Tue Oct 18 20:28:01 1994//Tsane
+/gen_scalers.cmn/1.13.14.1.2.3/Wed Nov 4 15:09:42 2009//Tsane
+/gen_units.par/1.1/Mon Feb 7 20:14:29 1994//Tsane
+/gep_data_structures.cmn/1.1.2.14.2.2/Tue Sep 15 20:33:10 2009//Tsane
+/gep_filenames.cmn/1.1.2.2/Tue Aug 7 19:11:48 2007//Tsane
+/gep_hist_id.cmn/1.1.2.7.2.2/Sun Oct 19 21:49:53 2008//Tsane
+/gep_ntuple.cmn/1.1.2.1/Tue May 15 02:53:33 2007//Tsane
+/gep_ntuple.dte/1.1.2.1/Tue May 15 02:53:33 2007//Tsane
+/h_fpp_ntuple.cmn/1.1.2.1/Wed Aug 22 19:09:31 2007//Tsane
+/h_fpp_ntuple.dte/1.1.2.1/Wed Aug 22 19:09:31 2007//Tsane
+/h_ntuple.cmn/1.4/Tue Feb 17 16:41:45 2004//Tsane
+/h_ntuple.dte/1.1/Fri Jun 17 02:13:10 1994//Tsane
+/h_sieve_ntuple.cmn/1.2/Mon May 22 19:05:58 1995//Tsane
+/h_sieve_ntuple.dte/1.1/Sat Dec 17 22:21:16 1994//Tsane
+/hack_.cmn/1.3/Wed Jan 17 15:58:04 1996//Tsane
+/hms_aero_parms.cmn/1.2/Fri Sep 5 20:30:48 2003//Tsane
+/hms_bypass_switches.cmn/1.6.24.1/Wed Aug 22 19:09:31 2007//Tsane
+/hms_calorimeter.cmn/1.12/Tue Feb 23 19:08:04 1999//Tsane
+/hms_cer_parms.cmn/1.2/Fri Dec 20 21:52:33 2002//Tsane
+/hms_data_structures.cmn/1.12.20.1.2.4/Wed Sep 16 19:00:45 2009//Tsane
+/hms_filenames.cmn/1.5.6.2/Thu Nov 29 19:07:19 2007//Tsane
+/hms_fpp_event.cmn/1.1.2.5/Thu Nov 1 19:14:44 2007//Tsane
+/hms_fpp_params.cmn/1.1.2.8/Thu Nov 1 17:35:03 2007//Tsane
+/hms_fpp_params.dte/1.1.2.3/Sat Oct 27 21:15:28 2007//Tsane
+/hms_geometry.cmn/1.11.24.2/Wed Sep 26 21:04:16 2007//Tsane
+/hms_id_histid.cmn/1.13.24.3/Tue Oct 30 00:28:32 2007//Tsane
+/hms_one_ev.par/1.2/Wed Jan 17 16:02:39 1996//Tsane
+/hms_pedestals.cmn/1.7/Fri Sep 5 20:32:28 2003//Tsane
+/hms_physics_sing.cmn/1.11/Wed Mar 23 16:35:04 2005//Tsane
+/hms_recon_elements.cmn/1.5/Wed Sep 4 16:13:02 1996//Tsane
+/hms_scin_parms.cmn/1.11.24.1.2.1/Mon Nov 17 15:57:39 2008//Tsane
+/hms_scin_tof.cmn/1.12.6.1.2.1/Mon Nov 17 15:57:00 2008//Tsane
+/hms_statistics.cmn/1.12.20.1/Wed Aug 22 19:09:31 2007//Tsane
+/hms_track_histid.cmn/1.8/Wed Jan 17 16:04:21 1996//Tsane
+/hms_tracking.cmn/1.27.20.3.2.2/Mon May 18 14:19:07 2009//Tsane
+/mc_structures.cmn/1.2/Wed Jun 8 19:49:44 1994//Tsane
+/s_ntuple.cmn/1.4/Tue Feb 17 16:41:45 2004//Tsane
+/s_ntuple.dte/1.1/Fri Jun 17 02:12:52 1994//Tsane
+/s_sieve_ntuple.cmn/1.1/Fri Aug 11 16:24:58 1995//Tsane
+/s_sieve_ntuple.dte/1.1/Fri Aug 11 16:24:52 1995//Tsane
+/sane_data_structures.cmn/1.1.2.13/Mon Jun 28 13:37:46 2010//Tsane
+/sane_filenames.cmn/1.1.2.1/Fri Sep 26 21:42:49 2008//Tsane
+/sane_ntuple.cmn/1.1.2.18/Mon Jul 12 18:56:05 2010//Tsane
+/sane_ntuple.dte/1.1.2.1/Fri Sep 26 21:42:49 2008//Tsane
+/sem_data_structures.cmn/1.1.2.1/Sat Oct 25 12:48:43 2008//Tsane
+/sos_aero_parms.cmn/1.2/Wed Oct 2 19:56:46 1996//Tsane
+/sos_bypass_switches.cmn/1.7/Tue Nov 19 18:48:39 1996//Tsane
+/sos_calorimeter.cmn/1.11/Mon Oct 11 13:42:41 1999//Tsane
+/sos_cer_parms.cmn/1.1/Tue Aug 8 19:15:10 1995//Tsane
+/sos_data_structures.cmn/1.10/Fri Sep 5 20:37:14 2003//Tsane
+/sos_filenames.cmn/1.5.6.1/Tue May 15 02:53:03 2007//Tsane
+/sos_geometry.cmn/1.8/Wed Sep 4 16:28:21 1996//Tsane
+/sos_id_histid.cmn/1.11/Tue Feb 23 19:20:42 1999//Tsane
+/sos_lucite_parms.cmn/1.1/Wed Oct 2 18:58:07 1996//Tsane
+/sos_one_ev.par/1.1/Fri Jul 28 20:27:00 1995//Tsane
+/sos_pedestals.cmn/1.9/Tue Feb 23 19:21:23 1999//Tsane
+/sos_physics_sing.cmn/1.11/Wed Mar 23 16:35:04 2005//Tsane
+/sos_recon_elements.cmn/1.5/Wed Sep 4 16:31:01 1996//Tsane
+/sos_scin_parms.cmn/1.8/Wed Sep 4 16:31:26 1996//Tsane
+/sos_scin_tof.cmn/1.9/Tue Mar 15 21:14:28 2005//Tsane
+/sos_statistics.cmn/1.13/Fri Sep 5 20:41:27 2003//Tsane
+/sos_track_histid.cmn/1.7/Wed Jan 17 15:06:31 1996//Tsane
+/sos_tracking.cmn/1.18/Tue Feb 23 19:22:52 1999//Tsane
+D
diff --git a/INCLUDE/CVS/Repository b/INCLUDE/CVS/Repository
new file mode 100644
index 0000000..86e87f7
--- /dev/null
+++ b/INCLUDE/CVS/Repository
@@ -0,0 +1 @@
+Analyzer/INCLUDE
diff --git a/INCLUDE/CVS/Root b/INCLUDE/CVS/Root
new file mode 100644
index 0000000..6288c3f
--- /dev/null
+++ b/INCLUDE/CVS/Root
@@ -0,0 +1 @@
+whit@cvs.jlab.org:/group/hallc/cvsroot
diff --git a/INCLUDE/CVS/Tag b/INCLUDE/CVS/Tag
new file mode 100644
index 0000000..25d73f7
--- /dev/null
+++ b/INCLUDE/CVS/Tag
@@ -0,0 +1 @@
+Tsane
diff --git a/INCLUDE/Makefile b/INCLUDE/Makefile
new file mode 100644
index 0000000..5255726
--- /dev/null
+++ b/INCLUDE/Makefile
@@ -0,0 +1,121 @@
+#
+# $Log: Makefile,v $
+# Revision 1.10.24.4 2007/09/12 10:35:15 pcarter
+# Implemented changes to allow compilation on RHEL 3,4,5 and MacOSX
+#
+# Revision 1.10.24.3 2007/09/10 20:08:02 pcarter
+# Implemented changes to allow compilation on RHEL 3,4,5 and MacOSX
+#
+# Revision 1.10.24.2 2007/08/22 19:09:31 frw
+# added FPP
+#
+# Revision 1.11 2006/06/23 frw
+# added new HMS FPP commons
+#
+# Revision 1.10.24.1 2007/05/15 02:53:03 jones
+# Start to Bigcal code
+#
+# Revision 1.10 2002/12/20 21:52:32 jones
+# Modified by Hamlet for new HMS aerogel
+#
+# Revision 1.9 1999/02/23 19:02:59 csa
+# Add gen_epics.cmn
+#
+# Revision 1.8 1996/11/08 21:08:23 saw
+# (WH) Add Lucite counter common blocks
+#
+# Revision 1.7 1996/04/30 13:26:59 saw
+# (SAW) Add aerogel include file
+#
+# Revision 1.6 1996/01/17 14:02:15 cdaq
+# (SAW) Add one event display includes
+#
+# Revision 1.5 1995/07/28 14:25:20 cdaq
+# (SAW) Update list of include files. Add NFSDIRECTORY stuff
+#
+# Revision 1.4 1995/05/24 13:50:06 cdaq
+# (SAW) Update and make cosmetic changes
+#
+# Revision 1.3 1995/04/06 20:12:33 cdaq
+# (SAW) Remove tmp_pedestals.dte
+#
+# Revision 1.2 1995/01/27 21:08:31 cdaq
+# *** empty log message ***
+#
+# Revision 1.1 1994/04/15 20:29:37 cdaq
+# Initial revision
+#
+##include $(Csoft)/etc/Makefile
+.DELETE_ON_ERROR: ;
+
+include ../etc/Makefile.variables
+
+ntuples = c_ntuple.cmn h_ntuple.cmn s_ntuple.cmn b_ntuple.cmn gep_ntuple.cmn
+
+cmn = gen_data_structures.cmn gen_craw.cmn gen_decode_common.cmn \
+ gen_event_info.cmn gen_filenames.cmn gen_output_info.cmn \
+ gen_pawspace.cmn gen_run_info.cmn gen_run_pref.cmn gen_scalers.cmn \
+ gen_epics.cmn \
+ hms_data_structures.cmn hms_bypass_switches.cmn hms_calorimeter.cmn \
+ hms_filenames.cmn hms_geometry.cmn hms_id_histid.cmn \
+ hms_physics_sing.cmn hms_recon_elements.cmn hms_scin_parms.cmn \
+ hms_scin_tof.cmn hms_statistics.cmn hms_track_histid.cmn \
+ hms_tracking.cmn hms_pedestals.cmn \
+ hms_cer_parms.cmn hms_aero_parms.cmn \
+ h_ntuple.cmn h_sieve_ntuple.cmn \
+ sos_data_structures.cmn sos_bypass_switches.cmn sos_calorimeter.cmn \
+ sos_filenames.cmn sos_geometry.cmn sos_id_histid.cmn \
+ sos_physics_sing.cmn sos_recon_elements.cmn sos_scin_parms.cmn \
+ sos_scin_tof.cmn sos_statistics.cmn sos_track_histid.cmn \
+ sos_tracking.cmn sos_pedestals.cmn \
+ sos_cer_parms.cmn sos_aero_parms.cmn \
+ s_ntuple.cmn s_sieve_ntuple.cmn \
+ coin_data_structures.cmn coin_bypass_switches.cmn c_ntuple.cmn \
+ coin_filenames.cmn \
+ hack_.cmn \
+ mc_structures.cmn sos_lucite_parms.cmn \
+ gen_decode_F1tdc.cmn \
+ hms_fpp_event.cmn hms_fpp_params.cmn \
+ h_fpp_ntuple.cmn \
+ bigcal_data_structures.cmn \
+ bigcal_filenames.cmn bigcal_bypass_switches.cmn bigcal_gain_parms.cmn \
+ bigcal_geometry.cmn bigcal_shower_parms.cmn bigcal_tof_parms.cmn \
+ gep_data_structures.cmn gep_filenames.cmn
+
+dte = c_ntuple.dte gen_run_pref.dte h_sieve_ntuple.dte h_fpp_ntuple.dte \
+ gen_run_info.dte h_ntuple.dte s_ntuple.dte s_sieve_ntuple.dte \
+ gep_ntuple.dte b_ntuple.dte
+
+par = gen_constants.par gen_detectorids.par gen_units.par
+
+dec = gen_routines.dec
+
+# One event display
+oneev = gen_one_ev_info.cmn gen_one_ev_info.dte hms_one_ev.par \
+ sos_one_ev.par gen_one_ev_gckine.cmn gen_one_ev_gctrak.cmn \
+ gen_one_ev_gcvolu.cmn
+
+include_files = $(cmn) $(dte) $(par) $(dec) $(oneev)
+
+install-dirs :=
+
+.PHONY: all
+
+all : $(include_files)
+
+ifdef NFSDIRECTORY
+%.cmn : $(NFSDIRECTORY)/INCLUDE/%.cmn
+ ln -s $(NFSDIRECTORY)/INCLUDE/$@ $@
+
+%.dte : $(NFSDIRECTORY)/INCLUDE/%.dte
+ ln -s $(NFSDIRECTORY)/INCLUDE/$@ $@
+
+%.par : $(NFSDIRECTORY)/INCLUDE/%.par
+ ln -s $(NFSDIRECTORY)/INCLUDE/$@ $@
+
+%.dec : $(NFSDIRECTORY)/INCLUDE/%.dec
+ ln -s $(NFSDIRECTORY)/INCLUDE/$@ $@
+
+.PRECIOUS: %.cmn %.dte %.par %.dec
+
+endif
diff --git a/INCLUDE/b_ntuple.cmn b/INCLUDE/b_ntuple.cmn
new file mode 100755
index 0000000..09f1474
--- /dev/null
+++ b/INCLUDE/b_ntuple.cmn
@@ -0,0 +1,320 @@
+*
+* CTPTYPE=parm
+*
+ integer BMAX_Ntuple_size
+ parameter (BMAX_Ntuple_size=100)
+ integer default_b_Ntuple_ID
+ parameter (default_b_Ntuple_ID=9030)
+* array dimensions for cluster ntuple:
+ integer maxnclust
+ parameter(maxnclust=50)
+ integer maxncellclust
+ parameter(maxncellclust=50)
+* array dimensions for cosmics ntuple:
+ integer maxahit
+ parameter(maxahit=1856)
+ integer maxthit
+ parameter(maxthit=3072)
+ integer maxtahit
+ parameter(maxtahit=38)
+ integer maxtthit
+ parameter(maxtthit=42*8)
+
+ logical b_Ntuple_exists
+ integer b_Ntuple_ID
+ integer b_Ntuple_size
+ integer b_Ntuple_IOchannel
+ integer bigcal_ntuple_type
+ character*80 b_Ntuple_name
+ character*80 b_Ntuple_title
+ character*132 b_Ntuple_directory
+ character*256 b_Ntuple_file
+c character*256 b_tree_filename
+ character*8 b_Ntuple_tag(BMAX_Ntuple_size)
+ integer b_Ntuple_max_segmentevents
+ integer b_ntuple_switch ! 0 means is off.
+*
+* CTPTYPE=event
+*
+ integer b_Ntuple_segmentevents
+ integer b_Ntuple_filesegments
+ real b_Ntuple_contents(BMAX_Ntuple_size)
+
+ common/BIGCAL_Ntuple/
+ $ b_Ntuple_exists,b_Ntuple_ID,b_Ntuple_size,b_Ntuple_IOchannel,
+ $ b_Ntuple_name,b_Ntuple_title,b_Ntuple_directory,
+ $ b_Ntuple_file,b_Ntuple_tag,
+ $ b_Ntuple_max_segmentevents,
+ $ b_Ntuple_segmentevents,b_Ntuple_filesegments,
+ $ b_Ntuple_contents,bigcal_ntuple_type,b_ntuple_switch
+
+* Basic event info:
+
+ integer*4 bgid ! copy of gen_event_id_number
+ integer*4 bgtype ! copy of gen_event_type
+ integer*4 btrigtype
+ real*4 btrigtime ! coincidence time, set a reference for all other tdcs
+ common/bevinfo/
+ $ bgid,
+ $ bgtype,
+ $ btrigtype,
+ $ btrigtime
+
+* ADC related quantities
+
+ integer*4 nclust
+ integer*4 ncellclust(maxnclust)
+ integer*4 ncellbad(maxnclust)
+ integer*4 ncellx(maxnclust)
+ integer*4 ncelly(maxnclust)
+ integer*4 iycell(maxncellclust,maxnclust)
+ integer*4 ixcell(maxncellclust,maxnclust)
+ logical cellbad(maxncellclust,maxnclust)
+ real*4 xcell(maxncellclust,maxnclust)
+ real*4 ycell(maxncellclust,maxnclust)
+ real*4 eblock(maxncellclust,maxnclust)
+ real*4 ablock(maxncellclust,maxnclust)
+ real*4 xmoment(maxnclust)
+ real*4 ymoment(maxnclust)
+ real*4 eclust(maxnclust)
+ real*4 aclust(maxnclust)
+ real*4 xclust(maxnclust)
+ real*4 yclust(maxnclust)
+ double precision NN_delX
+ double precision NN_delY
+ double precision NN_delE
+
+ common/clustblock/
+ $ NN_delX,
+ $ NN_delY,
+ $ NN_delE,
+ $ nclust,
+ $ ncellclust,
+ $ ncellbad,
+ $ ncellx,
+ $ ncelly,
+ $ iycell,
+ $ ixcell,
+ $ cellbad,
+ $ xcell,
+ $ ycell,
+ $ eblock,
+ $ ablock,
+ $ xmoment,
+ $ ymoment,
+ $ eclust,
+ $ aclust,
+ $ xclust,
+ $ yclust
+
+ integer*4 nclust8
+ integer*4 ncell8clust(maxnclust)
+ integer*4 irow8hit(10,maxnclust)
+ integer*4 icol8hit(10,maxnclust)
+ integer*4 nhit8clust(10,maxnclust)
+ real*4 s8(10,maxnclust)
+ real*4 tcell8(10,8,maxnclust)
+ real*4 tclust8(maxnclust)
+ real*4 tcut8(maxnclust)
+ real*4 tcut8cor(maxnclust)
+ real*4 trms8(maxnclust)
+ common/clusttdc/
+ $ nclust8,
+ $ ncell8clust,
+ $ irow8hit,
+ $ icol8hit,
+ $ nhit8clust,
+ $ s8,
+ $ tcell8,
+ $ tclust8,
+ $ tcut8,
+ $ tcut8cor,
+ $ trms8
+
+* trigger related quantities
+
+ integer*4 nclust64 ! copy of nclust
+ integer*4 ncell64clust(maxnclust)
+ integer*4 irow64hit(6,maxnclust)
+ integer*4 icol64hit(6,maxnclust)
+ integer*4 nhit64clust(6,maxnclust)
+ real*4 tcell64(6,8,maxnclust)
+ real*4 a64(6,maxnclust)
+ real*4 s64(6,maxnclust)
+ real*4 tclust64(maxnclust)
+ real*4 tcut64(maxnclust)
+ real*4 tcut64cor(maxnclust)
+ real*4 trms64(maxnclust)
+ common/clusttrig/
+ $ nclust64,
+ $ ncell64clust,
+ $ irow64hit,
+ $ icol64hit,
+ $ nhit64clust,
+ $ tcell64,
+ $ a64,
+ $ s64,
+ $ tclust64,
+ $ tcut64,
+ $ tcut64cor,
+ $ trms64
+
+* reconstructed physics quantities
+ integer*4 ntrack
+ integer*4 ibest
+ real*4 thetarad(maxnclust)
+ real*4 phirad(maxnclust)
+ real*4 energy(maxnclust) ! corrected for eloss
+ real*4 xface(maxnclust)
+ real*4 yface(maxnclust)
+ real*4 zface(maxnclust)
+ real*4 px(maxnclust)
+ real*4 py(maxnclust)
+ real*4 pz(maxnclust)
+ real*4 ctime_clust(maxnclust)
+ real*4 chi2clust(maxnclust)
+ real*4 chi2contr(6,maxnclust)
+ common/clustphys/
+ $ ntrack,
+ $ ibest,
+ $ thetarad,
+ $ phirad,
+ $ energy,
+ $ xface,
+ $ yface,
+ $ zface,
+ $ px,
+ $ py,
+ $ pz,
+ $ ctime_clust,
+ $ chi2clust,
+ $ chi2contr
+
+* bad cluster flags:
+
+ integer*4 nmax
+ logical edge_max(maxnclust)
+ logical not_enough(maxnclust)
+ logical too_long_x(maxnclust)
+ logical too_long_y(maxnclust)
+ logical below_thresh(maxnclust)
+ logical above_max(maxnclust)
+ logical second_max(maxnclust)
+ common/bad_clust/
+ $ nmax,
+ $ edge_max,
+ $ not_enough,
+ $ too_long_x,
+ $ too_long_y,
+ $ below_thresh,
+ $ above_max,
+ $ second_max
+* For online basic detector checks, include a list of additional basic variables:
+ integer*4 ngooda
+ integer*4 ngoodt
+ integer*4 ngoodta
+ integer*4 ngoodtt
+ integer*4 irowmax
+ integer*4 icolmax
+ real*4 max_adc
+ common/bhits/
+ $ ngooda,
+ $ ngoodt,
+ $ ngoodta,
+ $ ngoodtt,
+ $ irowmax,
+ $ icolmax,
+ $ max_adc
+
+* in case of Monte Carlo analysis, actual event info for comparison to reconstructed:
+* one "vertex" per event is assumed. Fill if and only if cluster ntuple gets filled.
+ integer*4 evid_g
+ integer*4 ntrk_g
+ integer*4 pid_g(maxnclust)
+ real*4 xvertex_g
+ real*4 yvertex_g
+ real*4 zvertex_g
+ real*4 pxgeant(maxnclust)
+ real*4 pygeant(maxnclust)
+ real*4 pzgeant(maxnclust)
+ real*4 xgeant(maxnclust) ! x in calo-centered coordinate system
+ real*4 ygeant(maxnclust) ! y in calo-centered coordinate system
+ real*4 egeant(maxnclust) ! actual energy of particle
+ real*4 pgeant(maxnclust) ! magnitude of momentum of particle
+ real*4 gthetarad(maxnclust)
+ real*4 gphirad(maxnclust)
+ common/MC_Clust/
+ $ evid_g,
+ $ ntrk_g,
+ $ pid_g,
+ $ xvertex_g,
+ $ yvertex_g,
+ $ zvertex_g,
+ $ pxgeant,
+ $ pygeant,
+ $ pzgeant,
+ $ xgeant,
+ $ ygeant,
+ $ egeant,
+ $ pgeant,
+ $ gthetarad,
+ $ gphirad
+
+* in case of Coincidence analysis, HMS info for comparison to reconstructed:
+ real*4 TH_HMS
+ real*4 PH_HMS
+ real*4 E_HMS ! cal. using hsp
+ real*4 X_HMS
+ real*4 Y_HMS
+ real*4 dPel_HMS ! difference between Pel(htheta) and PHMS, normalized to hpcentral
+ common/hmsblk/
+ $ TH_HMS,
+ $ PH_HMS,
+ $ E_HMS,
+ $ X_HMS,
+ $ Y_HMS,
+ $ dPel_HMS
+
+ integer*4 nahit
+ integer*4 xa(maxahit)
+ integer*4 ya(maxahit)
+ integer*4 aa(maxahit)
+ integer*4 nthit
+ integer*4 xt(maxthit)
+ integer*4 yt(maxthit)
+ integer*4 hn(maxthit)
+ integer*4 tt(maxthit)
+ integer*4 ntahit
+ integer*4 xta(maxtahit)
+ integer*4 yta(maxtahit)
+ integer*4 taa(maxtahit)
+ integer*4 ntthit
+ integer*4 xtt(maxtthit)
+ integer*4 ytt(maxtthit)
+ integer*4 hnt(maxtthit)
+ integer*4 ttt(maxtthit)
+
+ common/cosmic_hits/
+ $ nahit,
+ $ xa,
+ $ ya,
+ $ aa,
+ $ nthit,
+ $ xt,
+ $ yt,
+ $ hn,
+ $ tt,
+ $ ntahit,
+ $ xta,
+ $ yta,
+ $ taa,
+ $ ntthit,
+ $ xtt,
+ $ ytt,
+ $ hnt,
+ $ ttt
+
+*
+* CTPTYPE=parm
+*
+
diff --git a/INCLUDE/b_ntuple.dte b/INCLUDE/b_ntuple.dte
new file mode 100644
index 0000000..daf61d4
--- /dev/null
+++ b/INCLUDE/b_ntuple.dte
@@ -0,0 +1,10 @@
+ data b_ntuple_exists/.false./
+ data b_ntuple_id/0/
+ data b_ntuple_size/0/
+ data b_ntuple_iochannel/0/
+ data b_ntuple_name/' '/
+ data b_ntuple_title/' '/
+ data b_ntuple_directory/' '/
+ data b_ntuple_file/' '/
+ data b_ntuple_tag/bmax_ntuple_size*' '/
+ data b_ntuple_contents/bmax_ntuple_size*0/
diff --git a/INCLUDE/bigcal_bypass_switches.cmn b/INCLUDE/bigcal_bypass_switches.cmn
new file mode 100755
index 0000000..d5c3b82
--- /dev/null
+++ b/INCLUDE/bigcal_bypass_switches.cmn
@@ -0,0 +1,59 @@
+*
+* CTPTYPE=parm
+*
+ integer*4 bbypass_prot
+ integer*4 bbypass_rcs
+ integer*4 bbypass_sum8
+ integer*4 bbypass_sum64
+ integer*4 bbypass_find_clusters
+ integer*4 bbypass_calc_cluster_time
+ integer*4 bbypass_calc_shower_coord
+ integer*4 bbypass_prune_clusters
+ integer*4 b_prune_flags(8)
+ integer*4 bbypass_calc_physics
+ integer*4 bdebug_print_bad
+ integer*4 bdebug_print_adc
+ integer*4 bdebug_print_tdc
+ integer*4 bdebug_print_trig
+ integer*4 bdebug_print_clusters
+ integer*4 b_use_bad_chan_list
+ integer*4 bigcal_do_calibration
+ integer*4 bigcal_do_time_calib
+ integer*4 bigcal_min_calib_events
+ integer*4 b_use_peds_in_hist
+ integer*4 b_use_size_measurements
+ integer*4 b_suppress_annoying_pulser
+ integer*4 b_recon_using_map
+ integer*4 b_use_distcorr
+ integer*4 b_fix_double_ped
+c integer*4 bmake_tdc_hist
+c integer*4 bmake_ttdc_hist
+ integer*4 bluno ! logical unit number for debugging output
+ common/bigcal_bypass_switches/
+ $ bbypass_prot,
+ $ bbypass_rcs,
+ $ bbypass_sum8,
+ $ bbypass_sum64,
+ $ bbypass_find_clusters,
+ $ bbypass_calc_cluster_time,
+ $ bbypass_calc_shower_coord,
+ $ bbypass_prune_clusters,
+ $ b_prune_flags,
+ $ bbypass_calc_physics,
+ $ bdebug_print_bad,
+ $ bdebug_print_adc,
+ $ bdebug_print_tdc,
+ $ bdebug_print_trig,
+ $ bdebug_print_clusters,
+ $ b_use_bad_chan_list,
+ $ bigcal_do_calibration,
+ $ bigcal_do_time_calib,
+ $ bigcal_min_calib_events,
+ $ b_use_peds_in_hist,
+ $ b_use_size_measurements,
+ $ b_suppress_annoying_pulser,
+ $ b_recon_using_map,
+ $ b_use_distcorr,
+ $ b_fix_double_ped,
+ $ bluno
+
diff --git a/INCLUDE/bigcal_data_structures.cmn b/INCLUDE/bigcal_data_structures.cmn
new file mode 100755
index 0000000..6ace0d2
--- /dev/null
+++ b/INCLUDE/bigcal_data_structures.cmn
@@ -0,0 +1,731 @@
+****************************************************
+*
+* include file bigcal_data_structures.cmn
+*
+* Author: Andrew Puckett 8 January 2007
+*
+* Change Log:
+*
+*
+*
+*
+*
+*
+*
+*
+*
+*
+*
+* start with constants/array dimensions:
+* we will treat BigCal ADCs/TDCs as separate detectors.
+* we will also treat the sections of BigCal (RCS, Protvino) separately
+*
+*
+* CTPTYPE=parm
+*
+* Protvino half ADCs
+ integer*4 BIGCAL_PROT_MAXHITS
+ parameter (BIGCAL_PROT_MAXHITS=1024)
+ integer*4 BIGCAL_PROT_NX
+ parameter (BIGCAL_PROT_NX=32)
+ integer*4 BIGCAL_PROT_NY
+ parameter (BIGCAL_PROT_NY=32)
+
+* RCS half ADCs
+
+ integer*4 BIGCAL_RCS_MAXHITS
+ parameter (BIGCAL_RCS_MAXHITS=720)
+ integer*4 BIGCAL_RCS_NX
+ parameter (BIGCAL_RCS_NX=30)
+ integer*4 BIGCAL_RCS_NY
+ parameter (BIGCAL_RCS_NY=24)
+* array dimensions for combined hit and detector arrays:
+ integer*4 BIGCAL_ALL_MAXHITS
+ parameter(BIGCAL_ALL_MAXHITS=1744)
+
+* cluster array dimensions
+c$$$ integer*4 BIGCAL_PROT_NCLSTR_MAX
+c$$$ parameter(BIGCAL_PROT_NCLSTR_MAX=10)
+c$$$ integer*4 BIGCAL_RCS_NCLSTR_MAX
+c$$$ parameter(BIGCAL_RCS_NCLSTR_MAX=10)
+c$$$ integer*4 BIGCAL_MID_NCLSTR_MAX
+c$$$ parameter(BIGCAL_MID_NCLSTR_MAX=5)
+ integer*4 BIGCAL_ALL_NCLSTR_MAX
+ parameter(BIGCAL_ALL_NCLSTR_MAX=25) ! must equal sum of prot, rcs, and mid or problems will happen
+
+c make these parameters instead (see bigcal_clstr_cuts common block)
+c except that we don't want clstr_ncell_max changed because the
+c structure of the ntuple depends on it.
+ integer*4 BIGCAL_CLSTR_NCELL_MAX
+ parameter(BIGCAL_CLSTR_NCELL_MAX=25)
+c$$$
+c$$$ integer*4 BIGCAL_CLSTR_NCELLX_MAX
+c$$$ parameter(BIGCAL_CLSTR_NCELLX_MAX=8)
+c$$$ integer*4 BIGCAL_CLSTR_NCELLY_MAX
+c$$$ parameter(BIGCAL_CLSTR_NCELLY_MAX=8)
+
+c$$$ integer*4 BIGCAL_CLSTR_NCELL_MIN
+c$$$ parameter(BIGCAL_CLSTR_NCELL_MIN=2)
+* tdc and trigger array dimensions
+ integer*4 BIGCAL_MAX_TDC
+ parameter (BIGCAL_MAX_TDC=224)
+ integer*4 BIGCAL_MAX_ROWS
+ parameter (BIGCAL_MAX_ROWS=56)
+ integer*4 BIGCAL_MAX_GROUPS
+ parameter (BIGCAL_MAX_GROUPS=4)
+ integer*4 BIGCAL_ATRIG_MAXHITS
+ parameter (BIGCAL_ATRIG_MAXHITS=38)
+ integer*4 BIGCAL_TDC_MAXHITS
+ parameter (BIGCAL_TDC_MAXHITS=1792) ! 224 x 8
+ integer*4 BIGCAL_TTRIG_MAXHITS
+ parameter (BIGCAL_TTRIG_MAXHITS=336) ! 42 x 8
+ integer*4 BIGCAL_TTRIG_MAXGROUPS
+ parameter (BIGCAL_TTRIG_MAXGROUPS=42)
+* track array dimensions
+ integer*4 BIGCAL_MAX_NTRACK
+ parameter(BIGCAL_MAX_NTRACK=25)
+
+
+ real*4 BIGCAL_THETA_DEG ! BigCal angle in deg.
+ real*4 BIGCAL_THETA_RAD ! BigCal angle in radians
+ real*4 BIGCAL_SINTHETA ! sin of bigcal angle
+ real*4 BIGCAL_COSTHETA ! cos of bigcal angle
+ real*4 BIGCAL_R_TGT ! distance from target in cm
+ real*4 BIGCAL_HEIGHT ! height relative to pivot height = 0
+* yaw, pitch, and roll angles: only nonzero if a survey was done in place--these angles are used to correct the measured cluster position
+ real*4 BIGCAL_YAW_DEG ! rotation angle viewed from above
+ real*4 BIGCAL_PITCH_DEG ! rotation angle viewed from beam right
+ real*4 BIGCAL_ROLL_DEG ! rotation angle viewed from upstream
+ real*4 BIGCAL_ROT_MATRIX(3,3) ! 3D rotation matrix from "real" to "ideal" BigCal coordinates
+ common/BIGCAL_KIN_SETTINGS/
+ $ BIGCAL_THETA_DEG,
+ $ BIGCAL_THETA_RAD,
+ $ BIGCAL_SINTHETA,
+ $ BIGCAL_COSTHETA,
+ $ BIGCAL_R_TGT,
+ $ BIGCAL_HEIGHT,
+ $ BIGCAL_YAW_DEG,
+ $ BIGCAL_PITCH_DEG,
+ $ BIGCAL_ROLL_DEG,
+ $ BIGCAL_ROT_MATRIX
+
+
+* ALL TDCs:
+* 4 * 32 = 128 Prot. groups + 4 * 24 = 96 RCS groups = 224 + 38 trigger logic groups = 262 + master trigger signal = 263 TDC signals. All TDCs are in slots in the FB crate shared with the RCS ADCs
+* for now, we will only accommodate running with one trigger type for the
+* calorimeter.
+
+*
+* CTPTYPE=event
+*
+* the BigCal raw TDC signals:
+
+ logical bigcal_annoying_pulser_event
+ common/b_annoying_pulser/
+ $ bigcal_annoying_pulser_event
+
+ integer*4 BIGCAL_TDC_RAW_IROW(BIGCAL_TDC_MAXHITS)
+ integer*4 BIGCAL_TDC_RAW_IGROUP(BIGCAL_TDC_MAXHITS)
+ integer*4 BIGCAL_TDC_RAW(BIGCAL_TDC_MAXHITS)
+ integer*4 BIGCAL_TDC_NHIT
+ common/BIGCAL_RAW_TDC/
+ $ BIGCAL_TDC_NHIT,
+ $ BIGCAL_TDC_RAW_IGROUP,
+ $ BIGCAL_TDC_RAW_IROW,
+ $ BIGCAL_TDC_RAW
+
+* decoded quantities for calorimeter TDCs:
+* (filled by b_trans_tdc)
+
+ integer*4 BIGCAL_TDC_NDECODED
+ integer*4 BIGCAL_TDC_IROW(BIGCAL_TDC_MAXHITS)
+ integer*4 BIGCAL_TDC_IGROUP(BIGCAL_TDC_MAXHITS)
+ integer*4 BIGCAL_TDC(BIGCAL_TDC_MAXHITS)
+ integer*4 BIGCAL_TIME_NGOOD
+ integer*4 BIGCAL_TIME_IROW(BIGCAL_TDC_MAXHITS)
+ integer*4 BIGCAL_TIME_IGROUP(BIGCAL_TDC_MAXHITS)
+ integer*4 BIGCAL_TDC_GOOD(BIGCAL_TDC_MAXHITS)
+ real*4 BIGCAL_HIT_TIME(BIGCAL_TDC_MAXHITS)
+ common/BIGCAL_GOOD_TDC/
+ $ BIGCAL_TDC_NDECODED,
+ $ BIGCAL_TDC_IROW,
+ $ BIGCAL_TDC_IGROUP,
+ $ BIGCAL_TDC,
+ $ BIGCAL_TIME_NGOOD,
+ $ BIGCAL_TIME_IROW,
+ $ BIGCAL_TIME_IGROUP,
+ $ BIGCAL_TDC_GOOD,
+ $ BIGCAL_HIT_TIME
+* the BigCal raw trigger signals (ADC):
+ integer*4 BIGCAL_ATRIG_NHIT
+ integer*4 BIGCAL_ATRIG_IGROUP(BIGCAL_ATRIG_MAXHITS)
+ integer*4 BIGCAL_ATRIG_IHALF(BIGCAL_ATRIG_MAXHITS)
+ integer*4 BIGCAL_ATRIG_ADC_RAW(BIGCAL_ATRIG_MAXHITS)
+ common/BIGCAL_RAW_ATRIG/
+ $ BIGCAL_ATRIG_NHIT,
+ $ BIGCAL_ATRIG_IGROUP,
+ $ BIGCAL_ATRIG_IHALF,
+ $ BIGCAL_ATRIG_ADC_RAW
+* the BigCal raw trigger signals (TDC): (better to separate TADC and TTDC because the TDCs are multihit)
+ integer*4 BIGCAL_TTRIG_NHIT
+ integer*4 BIGCAL_TTRIG_IGROUP(BIGCAL_TTRIG_MAXHITS)
+ integer*4 BIGCAL_TTRIG_IHALF(BIGCAL_TTRIG_MAXHITS)
+ integer*4 BIGCAL_TTRIG_TDC_RAW(BIGCAL_TTRIG_MAXHITS)
+ common/BIGCAL_RAW_TTRIG/
+ $ BIGCAL_TTRIG_NHIT,
+ $ BIGCAL_TTRIG_IGROUP,
+ $ BIGCAL_TTRIG_IHALF,
+ $ BIGCAL_TTRIG_TDC_RAW
+
+* decoded and "good" trigger signals (ADC)
+ integer*4 BIGCAL_ATRIG_NGOOD
+ integer*4 BIGCAL_ATRIG_GOOD_IGROUP(BIGCAL_ATRIG_MAXHITS)
+ integer*4 BIGCAL_ATRIG_GOOD_IHALF(BIGCAL_ATRIG_MAXHITS)
+ real*4 BIGCAL_ATRIG_ADC_DEC(BIGCAL_ATRIG_MAXHITS)
+ real*4 BIGCAL_ATRIG_ADC_GOOD(BIGCAL_ATRIG_MAXHITS)
+ real*4 BIGCAL_ATRIG_ESUM(BIGCAL_ATRIG_MAXHITS)
+ common/BIGCAL_DECODED_ATRIG/
+ $ BIGCAL_ATRIG_NGOOD,
+ $ BIGCAL_ATRIG_GOOD_IGROUP,
+ $ BIGCAL_ATRIG_GOOD_IHALF,
+ $ BIGCAL_ATRIG_ADC_DEC,
+ $ BIGCAL_ATRIG_ADC_GOOD,
+ $ BIGCAL_ATRIG_ESUM
+
+* decoded and "good" trigger signals (TDC)
+
+ integer*4 BIGCAL_TTRIG_NDECODED
+ integer*4 BIGCAL_TTRIG_NGOOD
+ integer*4 BIGCAL_TTRIG_DEC_IGROUP(BIGCAL_TTRIG_MAXHITS)
+ integer*4 BIGCAL_TTRIG_DEC_IHALF(BIGCAL_TTRIG_MAXHITS)
+ integer*4 BIGCAL_TTRIG_GOOD_IGROUP(BIGCAL_TTRIG_MAXHITS)
+ integer*4 BIGCAL_TTRIG_GOOD_IHALF(BIGCAL_TTRIG_MAXHITS)
+ integer*4 BIGCAL_TTRIG_TDC_DEC(BIGCAL_TTRIG_MAXHITS)
+ integer*4 BIGCAL_TTRIG_TDC_GOOD(BIGCAL_TTRIG_MAXHITS)
+ real*4 BIGCAL_TTRIG_TIME_GOOD(BIGCAL_TTRIG_MAXHITS)
+ common/BIGCAL_DECODED_TTRIG/
+ $ BIGCAL_TTRIG_NDECODED,
+ $ BIGCAL_TTRIG_NGOOD,
+ $ BIGCAL_TTRIG_DEC_IGROUP,
+ $ BIGCAL_TTRIG_DEC_IHALF,
+ $ BIGCAL_TTRIG_GOOD_IGROUP,
+ $ BIGCAL_TTRIG_GOOD_IHALF,
+ $ BIGCAL_TTRIG_TDC_DEC,
+ $ BIGCAL_TTRIG_TDC_GOOD,
+ $ BIGCAL_TTRIG_TIME_GOOD
+
+* The hit arrays (ADCs):
+*Protvino:
+ integer*4 BIGCAL_PROT_NHIT
+ integer*4 BIGCAL_PROT_IY(BIGCAL_PROT_MAXHITS)
+ integer*4 BIGCAL_PROT_IX(BIGCAL_PROT_MAXHITS)
+ integer*4 BIGCAL_PROT_ADC_RAW(BIGCAL_PROT_MAXHITS)
+
+*RCS:
+ integer*4 BIGCAL_RCS_NHIT
+ integer*4 BIGCAL_RCS_IY(BIGCAL_RCS_MAXHITS)
+ integer*4 BIGCAL_RCS_IX(BIGCAL_RCS_MAXHITS)
+ integer*4 BIGCAL_RCS_ADC_RAW(BIGCAL_RCS_MAXHITS)
+
+ common/BIGCAL_RAW_ADC/
+ $ BIGCAL_PROT_NHIT,
+ $ BIGCAL_PROT_IX,
+ $ BIGCAL_PROT_IY,
+ $ BIGCAL_PROT_ADC_RAW,
+ $ BIGCAL_RCS_NHIT,
+ $ BIGCAL_RCS_IX,
+ $ BIGCAL_RCS_IY,
+ $ BIGCAL_RCS_ADC_RAW
+
+* The bad hit arrays (regular and trigger ADCs):
+ integer*4 BIGCAL_PROT_NHIT_CH(BIGCAL_PROT_MAXHITS)
+ integer*4 BIGCAL_RCS_NHIT_CH(BIGCAL_RCS_MAXHITS)
+ integer*4 BIGCAL_ATRIG_NHIT_CH(BIGCAL_ATRIG_MAXHITS)
+
+ integer*4 BIGCAL_PROT_NBAD
+ integer*4 BIGCAL_PROT_BADPLUSGOOD
+ integer*4 BIGCAL_PROT_IYBAD(BIGCAL_PROT_MAXHITS)
+ integer*4 BIGCAL_PROT_IXBAD(BIGCAL_PROT_MAXHITS)
+ integer*4 BIGCAL_PROT_ADC_BAD(BIGCAL_PROT_MAXHITS)
+
+ integer*4 BIGCAL_RCS_NBAD
+ integer*4 BIGCAL_RCS_BADPLUSGOOD
+ integer*4 BIGCAL_RCS_IYBAD(BIGCAL_RCS_MAXHITS)
+ integer*4 BIGCAL_RCS_IXBAD(BIGCAL_RCS_MAXHITS)
+ integer*4 BIGCAL_RCS_ADC_BAD(BIGCAL_RCS_MAXHITS)
+
+ integer*4 BIGCAL_ATRIG_NBAD
+ integer*4 BIGCAL_ATRIG_BADPLUSGOOD
+ integer*4 BIGCAL_ATRIG_IGROUP_BAD(BIGCAL_ATRIG_MAXHITS)
+ integer*4 BIGCAL_ATRIG_IHALF_BAD(BIGCAL_ATRIG_MAXHITS)
+ integer*4 BIGCAL_ATRIG_ADC_BAD(BIGCAL_ATRIG_MAXHITS)
+
+ common/BIGCAL_BAD_ADC/
+ $ BIGCAL_PROT_NHIT_CH,
+ $ BIGCAL_RCS_NHIT_CH,
+ $ BIGCAL_ATRIG_NHIT_CH,
+ $ BIGCAL_PROT_NBAD,
+ $ BIGCAL_RCS_NBAD,
+ $ BIGCAL_ATRIG_NBAD,
+ $ BIGCAL_PROT_BADPLUSGOOD,
+ $ BIGCAL_RCS_BADPLUSGOOD,
+ $ BIGCAL_ATRIG_BADPLUSGOOD,
+ $ BIGCAL_PROT_IYBAD,
+ $ BIGCAL_PROT_IXBAD,
+ $ BIGCAL_PROT_ADC_BAD,
+ $ BIGCAL_RCS_IYBAD,
+ $ BIGCAL_RCS_IXBAD,
+ $ BIGCAL_RCS_ADC_BAD,
+ $ BIGCAL_ATRIG_IGROUP_BAD,
+ $ BIGCAL_ATRIG_IHALF_BAD,
+ $ BIGCAL_ATRIG_ADC_BAD
+
+*decoded quantities for calorimeter ADCs:
+
+ integer*4 BIGCAL_PROT_NGOOD
+ integer*4 BIGCAL_PROT_IYGOOD(BIGCAL_PROT_MAXHITS)
+ integer*4 BIGCAL_PROT_IXGOOD(BIGCAL_PROT_MAXHITS)
+
+ integer*4 BIGCAL_RCS_NGOOD
+ integer*4 BIGCAL_RCS_IYGOOD(BIGCAL_RCS_MAXHITS)
+ integer*4 BIGCAL_RCS_IXGOOD(BIGCAL_RCS_MAXHITS)
+
+ real*4 BIGCAL_PROT_ADC_DECODED(BIGCAL_PROT_MAXHITS)
+ real*4 BIGCAL_PROT_ADC_GOOD(BIGCAL_PROT_MAXHITS)
+ real*4 BIGCAL_PROT_ECELL(BIGCAL_PROT_MAXHITS)
+ real*4 BIGCAL_PROT_XGOOD(BIGCAL_PROT_MAXHITS)
+ real*4 BIGCAL_PROT_YGOOD(BIGCAL_PROT_MAXHITS)
+
+ real*4 BIGCAL_RCS_ADC_DECODED(BIGCAL_RCS_MAXHITS)
+ real*4 BIGCAL_RCS_ADC_GOOD(BIGCAL_RCS_MAXHITS)
+ real*4 BIGCAL_RCS_ECELL(BIGCAL_RCS_MAXHITS)
+ real*4 BIGCAL_RCS_XGOOD(BIGCAL_RCS_MAXHITS)
+ real*4 BIGCAL_RCS_YGOOD(BIGCAL_RCS_MAXHITS)
+
+ integer*4 BIGCAL_ALL_NGOOD
+ integer*4 BIGCAL_ALL_IYGOOD(BIGCAL_ALL_MAXHITS)
+ integer*4 BIGCAL_ALL_IXGOOD(BIGCAL_ALL_MAXHITS)
+
+ real*4 BIGCAL_ALL_ADC_GOOD(BIGCAL_ALL_MAXHITS)
+ real*4 BIGCAL_ALL_ECELL(BIGCAL_ALL_MAXHITS)
+ real*4 BIGCAL_ALL_XGOOD(BIGCAL_ALL_MAXHITS)
+ real*4 BIGCAL_ALL_YGOOD(BIGCAL_ALL_MAXHITS)
+
+ common/BIGCAL_DECODED_ADC/
+ $ BIGCAL_PROT_NGOOD,
+ $ BIGCAL_RCS_NGOOD,
+ $ BIGCAL_PROT_IYGOOD,
+ $ BIGCAL_PROT_IXGOOD,
+ $ BIGCAL_RCS_IYGOOD,
+ $ BIGCAL_RCS_IXGOOD,
+ $ BIGCAL_PROT_ADC_DECODED,
+ $ BIGCAL_PROT_ADC_GOOD,
+ $ BIGCAL_PROT_ECELL,
+ $ BIGCAL_PROT_XGOOD,
+ $ BIGCAL_PROT_YGOOD,
+ $ BIGCAL_RCS_ADC_DECODED,
+ $ BIGCAL_RCS_ADC_GOOD,
+ $ BIGCAL_RCS_ECELL,
+ $ BIGCAL_RCS_XGOOD,
+ $ BIGCAL_RCS_YGOOD,
+ $ BIGCAL_ALL_NGOOD,
+ $ BIGCAL_ALL_IYGOOD,
+ $ BIGCAL_ALL_IXGOOD,
+ $ BIGCAL_ALL_ADC_GOOD,
+ $ BIGCAL_ALL_ECELL,
+ $ BIGCAL_ALL_XGOOD,
+ $ BIGCAL_ALL_YGOOD
+
+* diagnostic variables for some initial histograms to check sanity of data
+
+ integer*4 BIGCAL_IYMAX_ADC
+ integer*4 BIGCAL_IXMAX_ADC
+ integer*4 BIGCAL_ITRIGMAX_ADC
+ real*4 BIGCAL_MAX_ADC
+ common/BIGCAL_SIGNAL_MAX/
+ $ bigcal_iymax_adc,
+ $ bigcal_ixmax_adc,
+ $ bigcal_itrigmax_adc,
+ $ bigcal_max_adc
+
+* "detector" arrays: organize the data for histogramming and
+* analysis purposes. define only "raw" and "good" arrays:
+* also define cumulative quantities that get incremented during
+* the run for efficiency calculations:
+c also define the list of bad channels:
+ logical bigcal_bad_chan_list(bigcal_all_maxhits) ! true = bad channel
+ integer*4 BIGCAL_PROT_RAW_DET(BIGCAL_PROT_MAXHITS)
+ integer*4 BIGCAL_RCS_RAW_DET(BIGCAL_RCS_MAXHITS)
+ integer*4 BIGCAL_TDC_RAW_DET(BIGCAL_MAX_TDC,8)
+ integer*4 BIGCAL_TDC_DET_NHIT(BIGCAL_MAX_TDC)
+ integer*4 BIGCAL_TDC_DET_NGOOD(BIGCAL_MAX_TDC)
+ integer*4 BIGCAL_ATRIG_RAW_DET(BIGCAL_ATRIG_MAXHITS)
+ integer*4 BIGCAL_TTRIG_RAW_DET(BIGCAL_TTRIG_MAXGROUPS,8)
+ integer*4 BIGCAL_TTRIG_DET_NHIT(BIGCAL_TTRIG_MAXGROUPS)
+ integer*4 BIGCAL_TTRIG_DET_NGOOD(BIGCAL_TTRIG_MAXGROUPS)
+ real*4 BIGCAL_PROT_GOOD_DET(BIGCAL_PROT_MAXHITS)
+ real*4 BIGCAL_RCS_GOOD_DET(BIGCAL_RCS_MAXHITS)
+ real*4 BIGCAL_ALL_ADC_DET(BIGCAL_ALL_MAXHITS)
+ real*4 BIGCAL_ALL_GOOD_DET(BIGCAL_ALL_MAXHITS)
+ real*4 BIGCAL_TDC_GOOD_DET(BIGCAL_MAX_TDC,8)
+ real*4 BIGCAL_TDC_SUM8(BIGCAL_MAX_TDC)
+ real*4 BIGCAL_ATRIG_GOOD_DET(BIGCAL_ATRIG_MAXHITS)
+ real*4 BIGCAL_ATRIG_SUM64(BIGCAL_ATRIG_MAXHITS)
+ real*4 BIGCAL_TTRIG_GOOD_DET(BIGCAL_TTRIG_MAXGROUPS,8)
+
+ common/BIGCAL_DETECTOR/
+ $ bigcal_bad_chan_list,
+ $ BIGCAL_PROT_RAW_DET,
+ $ BIGCAL_RCS_RAW_DET,
+ $ BIGCAL_TDC_RAW_DET,
+ $ BIGCAL_TDC_DET_NHIT,
+ $ BIGCAL_TDC_DET_NGOOD,
+ $ BIGCAL_ATRIG_RAW_DET,
+ $ BIGCAL_TTRIG_RAW_DET,
+ $ BIGCAL_TTRIG_DET_NHIT,
+ $ BIGCAL_TTRIG_DET_NGOOD,
+ $ BIGCAL_PROT_GOOD_DET,
+ $ BIGCAL_RCS_GOOD_DET,
+ $ BIGCAL_ALL_ADC_DET,
+ $ BIGCAL_ALL_GOOD_DET,
+ $ BIGCAL_TDC_GOOD_DET,
+ $ BIGCAL_TDC_SUM8,
+ $ BIGCAL_ATRIG_GOOD_DET,
+ $ BIGCAL_ATRIG_SUM64,
+ $ BIGCAL_TTRIG_GOOD_DET
+
+* define cumulative quantities for the whole run which will
+* compute the cell-by-cell hits/clusters efficiency and average energy
+ integer*4 b_all_run_clst_good(bigcal_all_maxhits)
+ integer*4 b_all_run_clst_bad(bigcal_all_maxhits)
+ integer*4 b_all_run_Enum(bigcal_all_maxhits)
+ real*4 b_all_run_clst_eff(bigcal_all_maxhits)
+ real*4 b_all_run_Esum(bigcal_all_maxhits)
+ common/bigcal_clust_eff/
+ $ b_all_run_clst_good,
+ $ b_all_run_clst_bad,
+ $ b_all_run_Enum,
+ $ b_all_run_clst_eff,
+ $ b_all_run_Esum
+
+* arrays for middle section hits to find clusters in the boundary rows:
+
+c$$$ real*4 BIGCAL_MID_EHIT(30:35,32)
+c$$$ real*4 BIGCAL_MID_XHIT(30:35,32)
+c$$$ real*4 BIGCAL_MID_YHIT(30:35,32)
+c$$$
+c$$$ common/BIGCAL_MID_HITS/
+c$$$ $ BIGCAL_MID_EHIT,
+c$$$ $ BIGCAL_MID_XHIT,
+c$$$ $ BIGCAL_MID_YHIT
+
+* analysis quantities: "clusters"
+
+
+*
+* CTPTYPE=parm
+*
+* cluster and cell cuts!!
+ integer*4 BIGCAL_CLSTR_NCELL_MIN
+ integer*4 BIGCAL_CLSTR_NCELLX_MAX
+ integer*4 BIGCAL_CLSTR_NCELLY_MAX
+ integer*4 BIGCAL_CLSTR_NXMOM_MAX ! number of blocks away from maximum to include in moment calculation
+ integer*4 BIGCAL_CLSTR_NYMOM_MAX ! number of blocks away from maximum to include in moment calculation
+ integer*4 BIGCAL_CLSTR_NXECL_MAX ! number of blocks away from maximum to include in energy sum
+ integer*4 BIGCAL_CLSTR_NYECL_MAX ! number of blocks away from maximum to include in energy sum
+ real*4 B_CLUSTER_CUT ! min. cluster energy
+ real*4 B_CLUSTER_MAX ! max. cluster energy
+ real*4 B_CELL_CUT_RCS ! min cell energy, RCS
+ real*4 B_CELL_CUT_PROT ! min cell energy, Prot
+ real*4 B_MIN_EMAX ! minimum energy of maximum cell
+ real*4 b_min_2max(2) !1 = min. fraction to reject cluster for 2nd max.
+ !2 = min. energy to reject cluster for 2nd max.
+ real*4 b_prune_eclust(2)
+ real*4 b_trig_cut ! for monte carlo analysis only: trig threshold
+ common/BIGCAL_CLSTR_CUTS/
+ $ BIGCAL_CLSTR_NCELL_MIN,
+ $ BIGCAL_CLSTR_NCELLX_MAX,
+ $ BIGCAL_CLSTR_NCELLY_MAX,
+ $ BIGCAL_CLSTR_NXMOM_MAX,
+ $ BIGCAL_CLSTR_NYMOM_MAX,
+ $ BIGCAL_CLSTR_NXECL_MAX,
+ $ BIGCAL_CLSTR_NYECL_MAX,
+ $ B_CLUSTER_CUT,
+ $ B_CLUSTER_MAX,
+ $ B_CELL_CUT_PROT,
+ $ B_CELL_CUT_RCS,
+ $ B_MIN_EMAX,
+ $ b_min_2max,
+ $ b_prune_eclust,
+ $ b_trig_cut
+* arrays of closest column number in row 33 to column number in row 32
+* and vice versa
+ integer*4 bigcal_ixclose_prot(bigcal_prot_nx)
+ integer*4 bigcal_ixclose_rcs(bigcal_rcs_nx)
+ common/bigcal_ixclose_mid/
+ $ bigcal_ixclose_prot,
+ $ bigcal_ixclose_rcs
+
+*
+* CTPTYPE=event
+*
+* cluster arrays and checks
+ integer*4 BIGCAL_ALL_NCLUST_GOOD
+ integer*4 BIGCAL_ALL_NCLSTR
+ integer*4 BIGCAL_ALL_CLSTR_NCELL(BIGCAL_ALL_NCLSTR_MAX)
+ integer*4 BIGCAL_ALL_CLSTR_NCELLX(BIGCAL_ALL_NCLSTR_MAX)
+ integer*4 BIGCAL_ALL_CLSTR_NCELLY(BIGCAL_ALL_NCLSTR_MAX)
+ integer*4 BIGCAL_ALL_CLSTR_NBADLIST(BIGCAL_ALL_NCLSTR_MAX)
+ integer*4 BIGCAL_ALL_CLSTR_IYMAX(BIGCAL_ALL_NCLSTR_MAX)
+ integer*4 BIGCAL_ALL_CLSTR_IXMAX(BIGCAL_ALL_NCLSTR_MAX)
+ integer*4 BIGCAL_ALL_CLSTR_IYLO(BIGCAL_ALL_NCLSTR_MAX)
+ integer*4 BIGCAL_ALL_CLSTR_IYHI(BIGCAL_ALL_NCLSTR_MAX)
+ integer*4 BIGCAL_ALL_CLSTR_IXLO(BIGCAL_ALL_NCLSTR_MAX,3)
+ integer*4 BIGCAL_ALL_CLSTR_IXHI(BIGCAL_ALL_NCLSTR_MAX,3)
+ integer*4 BIGCAL_ALL_CLSTR_IYCELL(BIGCAL_ALL_NCLSTR_MAX,BIGCAL_CLSTR_NCELL_MAX)
+ integer*4 BIGCAL_ALL_CLSTR_IXCELL(BIGCAL_ALL_NCLSTR_MAX,BIGCAL_CLSTR_NCELL_MAX)
+ integer*4 BIGCAL_ALL_CLSTR_NCELL8(BIGCAL_ALL_NCLSTR_MAX)
+ integer*4 BIGCAL_ALL_CLSTR_NCELL64(BIGCAL_ALL_NCLSTR_MAX)
+ integer*4 BIGCAL_ALL_CLSTR_NHIT8(BIGCAL_ALL_NCLSTR_MAX,10)
+ integer*4 BIGCAL_ALL_CLSTR_NHIT64(BIGCAL_ALL_NCLSTR_MAX,6)
+ integer*4 BIGCAL_ALL_CLSTR_IROW8(BIGCAL_ALL_NCLSTR_MAX,10)
+ integer*4 BIGCAL_ALL_CLSTR_ICOL8(BIGCAL_ALL_NCLSTR_MAX,10)
+ integer*4 BIGCAL_ALL_CLSTR_IROW64(BIGCAL_ALL_NCLSTR_MAX,6)
+ integer*4 BIGCAL_ALL_CLSTR_ICOL64(BIGCAL_ALL_NCLSTR_MAX,6)
+ real*4 BIGCAL_ALL_CLSTR_XCELL(BIGCAL_ALL_NCLSTR_MAX,BIGCAL_CLSTR_NCELL_MAX)
+ real*4 BIGCAL_ALL_CLSTR_YCELL(BIGCAL_ALL_NCLSTR_MAX,BIGCAL_CLSTR_NCELL_MAX)
+ real*4 BIGCAL_ALL_CLSTR_ECELL(BIGCAL_ALL_NCLSTR_MAX,BIGCAL_CLSTR_NCELL_MAX)
+ real*4 BIGCAL_ALL_CLSTR_ACELL(BIGCAL_ALL_NCLSTR_MAX,BIGCAL_CLSTR_NCELL_MAX)
+ real*4 BIGCAL_ALL_CLSTR_S8(BIGCAL_ALL_NCLSTR_MAX,10) ! sum of hits in this cluster
+ real*4 BIGCAL_ALL_CLSTR_TCELL8(BIGCAL_ALL_NCLSTR_MAX,10,8) ! max of 10 unique sum8, 8 hits per tdc
+ real*4 BIGCAL_ALL_CLSTR_TCELL64(BIGCAL_ALL_NCLSTR_MAX,6,8) ! max of 6 unique sum64, 8 hits per tdc
+ real*4 BIGCAL_ALL_CLSTR_A64(BIGCAL_ALL_NCLSTR_MAX,6) ! trigger group amplitudes
+ real*4 BIGCAL_ALL_CLSTR_SUM64(BIGCAL_ALL_NCLSTR_MAX,6) ! sum of blocks comprising group
+ real*4 BIGCAL_ALL_CLSTR_XMOM(BIGCAL_ALL_NCLSTR_MAX)
+ real*4 BIGCAL_ALL_CLSTR_YMOM(BIGCAL_ALL_NCLSTR_MAX)
+ real*4 BIGCAL_ALL_CLSTR_X(BIGCAL_ALL_NCLSTR_MAX)
+ real*4 BIGCAL_ALL_CLSTR_Y(BIGCAL_ALL_NCLSTR_MAX)
+ real*4 BIGCAL_ALL_CLSTR_ETOT(BIGCAL_ALL_NCLSTR_MAX)
+ real*4 BIGCAL_ALL_CLSTR_ATOT(BIGCAL_ALL_NCLSTR_MAX)
+ real*4 BIGCAL_ALL_CLSTR_T8MEAN(BIGCAL_ALL_NCLSTR_MAX)
+ real*4 BIGCAL_ALL_CLSTR_T8RMS(BIGCAL_ALL_NCLSTR_MAX)
+ real*4 BIGCAL_ALL_CLSTR_T8CUT(bigcal_all_nclstr_max)
+ real*4 BIGCAL_ALL_CLSTR_T8CUT_COR(bigcal_all_nclstr_max) !
+ real*4 BIGCAL_ALL_CLSTR_T64MEAN(BIGCAL_ALL_NCLSTR_MAX)
+ real*4 bigcal_all_clstr_t64cut(bigcal_all_nclstr_max)
+ real*4 bigcal_all_clstr_t64cut_cor(bigcal_all_nclstr_max)
+ real*4 BIGCAL_ALL_CLSTR_T64RMS(BIGCAL_ALL_NCLSTR_MAX)
+ real*4 BIGCAL_ALL_CLSTR_CHI2(BIGCAL_ALL_NCLSTR_MAX)
+ real*4 BIGCAL_ALL_CLSTR_CHI2CONTR(BIGCAL_ALL_NCLSTR_MAX,6)
+ logical bigcal_clstr_bad_chan(bigcal_all_nclstr_max,bigcal_clstr_ncell_max) ! is channel in the bad list?
+ logical bigcal_clstr_keep(bigcal_all_nclstr_max) ! did this cluster pass prune checks?
+
+ common/BIGCAL_CLUSTERS/
+ $ bigcal_all_nclust_good,
+ $ BIGCAL_ALL_NCLSTR,
+ $ BIGCAL_ALL_CLSTR_NCELL,
+ $ BIGCAL_ALL_CLSTR_NCELLX,
+ $ BIGCAL_ALL_CLSTR_NCELLY,
+ $ BIGCAL_ALL_CLSTR_NBADLIST,
+ $ BIGCAL_ALL_CLSTR_IYMAX,
+ $ BIGCAL_ALL_CLSTR_IXMAX,
+ $ BIGCAL_ALL_CLSTR_IYLO,
+ $ BIGCAL_ALL_CLSTR_IYHI,
+ $ BIGCAL_ALL_CLSTR_IXLO,
+ $ BIGCAL_ALL_CLSTR_IXHI,
+ $ BIGCAL_ALL_CLSTR_IYCELL,
+ $ BIGCAL_ALL_CLSTR_IXCELL,
+ $ BIGCAL_ALL_CLSTR_NCELL8,
+ $ BIGCAL_ALL_CLSTR_NCELL64,
+ $ BIGCAL_ALL_CLSTR_NHIT8,
+ $ BIGCAL_ALL_CLSTR_NHIT64,
+ $ BIGCAL_ALL_CLSTR_IROW8,
+ $ BIGCAL_ALL_CLSTR_ICOL8,
+ $ BIGCAL_ALL_CLSTR_IROW64,
+ $ BIGCAL_ALL_CLSTR_ICOL64,
+ $ BIGCAL_ALL_CLSTR_XCELL,
+ $ BIGCAL_ALL_CLSTR_YCELL,
+ $ BIGCAL_ALL_CLSTR_ECELL,
+ $ BIGCAL_ALL_CLSTR_ACELL,
+ $ BIGCAL_ALL_CLSTR_S8,
+ $ BIGCAL_ALL_CLSTR_TCELL8,
+ $ BIGCAL_ALL_CLSTR_TCELL64,
+ $ BIGCAL_ALL_CLSTR_A64,
+ $ BIGCAL_ALL_CLSTR_SUM64,
+ $ BIGCAL_ALL_CLSTR_XMOM,
+ $ BIGCAL_ALL_CLSTR_YMOM,
+ $ BIGCAL_ALL_CLSTR_X,
+ $ BIGCAL_ALL_CLSTR_Y,
+ $ BIGCAL_ALL_CLSTR_ETOT,
+ $ BIGCAL_ALL_CLSTR_ATOT,
+ $ BIGCAL_ALL_CLSTR_T8MEAN,
+ $ BIGCAL_ALL_CLSTR_T8RMS,
+ $ bigcal_all_clstr_t8cut,
+ $ bigcal_all_clstr_t8cut_cor,
+ $ BIGCAL_ALL_CLSTR_T64MEAN,
+ $ BIGCAL_ALL_CLSTR_T64RMS,
+ $ bigcal_all_clstr_t64cut,
+ $ bigcal_all_clstr_t64cut_cor,
+ $ BIGCAL_ALL_CLSTR_CHI2,
+ $ BIGCAL_ALL_CLSTR_CHI2CONTR,
+ $ bigcal_clstr_bad_chan,
+ $ bigcal_clstr_keep
+
+ integer BIGCAL_NMAXIMA ! number of maxima found
+ logical BIGCAL_EDGE_MAX(BIGCAL_ALL_NCLSTR_MAX) ! maximum is at edge
+ logical BIGCAL_NOT_ENOUGH(BIGCAL_ALL_NCLSTR_MAX) ! cluster has only one cell with a hit
+ logical BIGCAL_TOO_LONG_X(BIGCAL_ALL_NCLSTR_MAX) ! cluster horizontal length too long
+ logical BIGCAL_TOO_LONG_Y(BIGCAL_ALL_NCLSTR_MAX) ! cluster vertical length is too long
+ logical BIGCAL_BELOW_CUT(BIGCAL_ALL_NCLSTR_MAX) ! cluster energy sum is below cluster cut
+ logical BIGCAL_ABOVE_MAX(BIGCAL_ALL_NCLSTR_MAX) ! cluster energy sum is above cluster max
+ logical BIGCAL_SECOND_MAX(BIGCAL_ALL_NCLSTR_MAX) ! cluster has two maxima, more than one showering particle
+ common/BIGCAL_CLUSTER_CHECKS/
+ $ BIGCAL_NMAXIMA,
+ $ BIGCAL_EDGE_MAX,
+ $ BIGCAL_NOT_ENOUGH,
+ $ BIGCAL_TOO_LONG_X,
+ $ BIGCAL_TOO_LONG_Y,
+ $ BIGCAL_BELOW_CUT,
+ $ BIGCAL_ABOVE_MAX,
+ $ BIGCAL_SECOND_MAX
+
+c bigcal_physics: reconstructed physics quantities
+
+ integer*4 BIGCAL_PHYS_NTRACK
+ real*4 BIGCAL_TRACK_THETARAD(BIGCAL_MAX_NTRACK)
+ real*4 BIGCAL_TRACK_THETADEG(BIGCAL_MAX_NTRACK)
+ real*4 BIGCAL_TRACK_PHIRAD(BIGCAL_MAX_NTRACK)
+ real*4 BIGCAL_TRACK_PHIDEG(BIGCAL_MAX_NTRACK)
+ real*4 BIGCAL_TRACK_ENERGY(BIGCAL_MAX_NTRACK)
+ real*4 BIGCAL_TRACK_ELOSS(BIGCAL_MAX_NTRACK)
+ real*4 BIGCAL_TRACK_TIME(BIGCAL_MAX_NTRACK)
+ real*4 BIGCAL_TRACK_XFACE(BIGCAL_MAX_NTRACK)
+ real*4 BIGCAL_TRACK_YFACE(BIGCAL_MAX_NTRACK)
+ real*4 BIGCAL_TRACK_ZFACE(BIGCAL_MAX_NTRACK)
+ real*4 BIGCAL_TRACK_PX(BIGCAL_MAX_NTRACK)
+ real*4 BIGCAL_TRACK_PY(BIGCAL_MAX_NTRACK)
+ real*4 BIGCAL_TRACK_PZ(BIGCAL_MAX_NTRACK)
+ real*4 BIGCAL_TRACK_BETA(BIGCAL_MAX_NTRACK)
+ real*4 BIGCAL_TRACK_TOF(BIGCAL_MAX_NTRACK)
+ real*4 bigcal_track_tof_cor(bigcal_max_ntrack)
+ real*4 BIGCAL_TRACK_COIN_TIME(BIGCAL_MAX_NTRACK)
+
+ common/BIGCAL_PHYSICS/
+ $ BIGCAL_PHYS_NTRACK,
+ $ BIGCAL_TRACK_THETARAD,
+ $ BIGCAL_TRACK_THETADEG,
+ $ BIGCAL_TRACK_PHIRAD,
+ $ BIGCAL_TRACK_PHIDEG,
+ $ BIGCAL_TRACK_ENERGY,
+ $ BIGCAL_TRACK_ELOSS,
+ $ BIGCAL_TRACK_TIME,
+ $ BIGCAL_TRACK_XFACE,
+ $ BIGCAL_TRACK_YFACE,
+ $ BIGCAL_TRACK_ZFACE,
+ $ BIGCAL_TRACK_PX,
+ $ BIGCAL_TRACK_PY,
+ $ BIGCAL_TRACK_PZ,
+ $ BIGCAL_TRACK_BETA,
+ $ BIGCAL_TRACK_TOF,
+ $ bigcal_track_tof_cor,
+ $ BIGCAL_TRACK_COIN_TIME
+
+c bigcal_coin_physics: choose the best track!
+
+ integer*4 bigcal_itrack_best
+ real*4 bigcal_thetarad
+ real*4 bigcal_phirad
+ real*4 bigcal_energy
+ real*4 bigcal_time
+ real*4 bigcal_xface
+ real*4 bigcal_yface
+ real*4 bigcal_zface
+ real*4 bigcal_px
+ real*4 bigcal_py
+ real*4 bigcal_pz
+ real*4 bigcal_beta
+ real*4 bigcal_eloss
+ real*4 bigcal_tof
+ real*4 bigcal_tof_cor
+ real*4 bigcal_ctime
+
+ common/bigcal_singles/
+ $ bigcal_itrack_best,
+ $ bigcal_thetarad,
+ $ bigcal_phirad,
+ $ bigcal_energy,
+ $ bigcal_time,
+ $ bigcal_xface,
+ $ bigcal_yface,
+ $ bigcal_zface,
+ $ bigcal_px,
+ $ bigcal_py,
+ $ bigcal_pz,
+ $ bigcal_beta,
+ $ bigcal_eloss,
+ $ bigcal_tof,
+ $ bigcal_tof_cor,
+ $ bigcal_ctime
+c variables for BigCal ep (or MC) calibration:
+ real*4 bigcal_matrix(bigcal_all_maxhits,bigcal_all_maxhits)
+ real*4 bigcal_vector(bigcal_all_maxhits)
+ integer*4 bigcal_matr_iflag
+ integer*4 bigcal_nmatr_event
+ integer*4 bigcal_matr_iochan
+ integer*4 bigcal_matr_nempty
+ integer*4 bigcal_matr_nsmalldiag
+ integer*4 bigcal_matr_iempty(bigcal_all_maxhits)
+ integer*4 bigcal_matr_ismalld(bigcal_all_maxhits)
+ common/bigcal_calibration/
+ $ bigcal_matrix,
+ $ bigcal_vector,
+ $ bigcal_matr_iflag,
+ $ bigcal_nmatr_event,
+ $ bigcal_matr_iochan,
+ $ bigcal_matr_nempty,
+ $ bigcal_matr_nsmalldiag,
+ $ bigcal_matr_iempty,
+ $ bigcal_matr_ismalld
+*
+* CTPTYPE=parm
+*
+ integer*4 bigcal_Ncalib
+ integer*4 bigcal_calib_iylo
+ integer*4 bigcal_calib_iyhi
+ integer*4 bigcal_calib_ixlo(2)
+ integer*4 bigcal_calib_ixhi(2)
+ common/bigcal_calib_range/
+ $ bigcal_Ncalib,
+ $ bigcal_calib_iylo,
+ $ bigcal_calib_iyhi,
+ $ bigcal_calib_ixlo,
+ $ bigcal_calib_ixhi
+
+*
+* CTPTYPE=event
+*
+
+c variables for reading Protvino Monte Carlo events ('.dat' style output!!!)
+
+ integer*4 iev_mc
+ integer*4 nvtrk_mc
+ integer*4 pid_mc(100)
+ integer*4 isum_mc(2),ix_mc,iy_mc
+ integer*4 idesum_mc(2)
+ integer*4 iev_p_mc
+ real*4 xv_mc,yv_mc,zv_mc,px_mc(100),py_mc(100),pz_mc(100)
+ real*4 esum_mc(2)
+ real*4 allde_mc(2)
+ real*4 npe_mc,dedx_mc
+ real*4 pp_mc,ptheta_mc,pphi_mc,xv_p_mc,yv_p_mc,zv_p_mc
+ logical EOF_MC_DAT
+
+ common/BIGCAL_MC_STUFF/
+ $ iev_mc,nvtrk_mc,pid_mc,isum_mc,ix_mc,iy_mc,
+ $ idesum_mc,iev_p_mc,
+ $ xv_mc,yv_mc,zv_mc,px_mc,py_mc,pz_mc,esum_mc,
+ $ allde_mc,npe_mc,dedx_mc,
+ $ pp_mc,ptheta_mc,pphi_mc,xv_p_mc,yv_p_mc,zv_p_mc,
+ $ EOF_MC_DAT
+
+
diff --git a/INCLUDE/bigcal_filenames.cmn b/INCLUDE/bigcal_filenames.cmn
new file mode 100755
index 0000000..207d5ee
--- /dev/null
+++ b/INCLUDE/bigcal_filenames.cmn
@@ -0,0 +1,33 @@
+*
+* CTPTYPE=parm
+*
+ character*80 b_report_template_filename ! CTP file with bigcal report
+ character*80 b_report_blockname
+ character*80 b_report_output_filename
+ character*80 b_roc11_threshold_output_filename
+ character*80 b_roc12_threshold_output_filename
+ character*80 b_pedestal_output_filename
+ character*80 b_tree_filename
+ character*80 b_calib_matrix_filename
+ character*80 b_calib_parm_filename
+ character*80 b_debug_output_filename
+ character*80 b_bad_chan_list_filename
+ character*80 b_calib_input_filename
+
+ logical b_calib_rebook
+
+ common/bigcal_filenames/
+ $ b_report_template_filename,
+ $ b_report_blockname,
+ $ b_report_output_filename,
+ $ b_roc11_threshold_output_filename,
+ $ b_roc12_threshold_output_filename,
+ $ b_pedestal_output_filename,
+ $ b_tree_filename,
+ $ b_calib_matrix_filename,
+ $ b_calib_parm_filename,
+ $ b_debug_output_filename,
+ $ b_bad_chan_list_filename,
+ $ b_calib_input_filename,
+ $ b_calib_rebook
+
diff --git a/INCLUDE/bigcal_gain_parms.cmn b/INCLUDE/bigcal_gain_parms.cmn
new file mode 100755
index 0000000..3608429
--- /dev/null
+++ b/INCLUDE/bigcal_gain_parms.cmn
@@ -0,0 +1,154 @@
+ integer*4 BIGCAL_PROT_NPMT
+ parameter(BIGCAL_PROT_NPMT=1024)
+ integer*4 BIGCAL_RCS_NPMT
+ parameter(BIGCAL_RCS_NPMT=720)
+ integer*4 BIGCAL_TRIG_NGROUP
+ parameter(BIGCAL_TRIG_NGROUP=38)
+*
+* CTPTYPE=event
+*
+* arrays for analysis of ped. events:
+ integer*4 bigcal_prot_ped_sum2 ! sum of pedestal squared
+ integer*4 bigcal_prot_ped_sum ! sum of pedestal
+ integer*4 bigcal_prot_ped_num ! number of ped. events
+ integer*4 bigcal_prot_num_ped_changes ! number of >2sigma changes
+ integer*4 bigcal_prot_change_irow ! iy of changed ped.
+ integer*4 bigcal_prot_change_icol ! ix of changed ped.
+ real*4 bigcal_prot_ped_change ! amount of change
+ real*4 bigcal_prot_new_rms ! new rms value
+ real*4 bigcal_prot_new_ped ! new mean value
+ common/bigcal_prot_ped_stats/
+ $ bigcal_prot_ped_sum2(BIGCAL_PROT_NPMT),
+ $ bigcal_prot_ped_sum(BIGCAL_PROT_NPMT),
+ $ bigcal_prot_ped_num(BIGCAL_PROT_NPMT),
+ $ bigcal_prot_num_ped_changes,
+ $ bigcal_prot_change_irow(BIGCAL_PROT_NPMT),
+ $ bigcal_prot_change_icol(BIGCAL_PROT_NPMT),
+ $ bigcal_prot_ped_change(BIGCAL_PROT_NPMT),
+ $ bigcal_prot_new_rms(BIGCAL_PROT_NPMT),
+ $ bigcal_prot_new_ped(BIGCAL_PROT_NPMT)
+
+ integer*4 bigcal_rcs_ped_sum2 ! sum of pedestal squared
+ integer*4 bigcal_rcs_ped_sum ! sum of pedestal
+ integer*4 bigcal_rcs_ped_num ! number of ped. events
+ integer*4 bigcal_rcs_num_ped_changes ! number of >2sigma changes
+ integer*4 bigcal_rcs_change_irow ! iy of changed ped.
+ integer*4 bigcal_rcs_change_icol ! ix of changed ped.
+ real*4 bigcal_rcs_ped_change ! amount of change
+ real*4 bigcal_rcs_new_rms ! new rms value
+ real*4 bigcal_rcs_new_ped ! new mean value
+ common/bigcal_rcs_ped_stats/
+ $ bigcal_rcs_ped_sum2(BIGCAL_RCS_NPMT),
+ $ bigcal_rcs_ped_sum(BIGCAL_RCS_NPMT),
+ $ bigcal_rcs_ped_num(BIGCAL_RCS_NPMT),
+ $ bigcal_rcs_num_ped_changes,
+ $ bigcal_rcs_change_irow(BIGCAL_RCS_NPMT),
+ $ bigcal_rcs_change_icol(BIGCAL_RCS_NPMT),
+ $ bigcal_rcs_ped_change(BIGCAL_RCS_NPMT),
+ $ bigcal_rcs_new_rms(BIGCAL_RCS_NPMT),
+ $ bigcal_rcs_new_ped(BIGCAL_RCS_NPMT)
+
+ integer*4 bigcal_trig_ped_sum2 ! sum of pedestal squared
+ integer*4 bigcal_trig_ped_sum ! sum of pedestal
+ integer*4 bigcal_trig_ped_num ! number of ped. events
+ integer*4 bigcal_trig_num_ped_changes ! number of >2sigma changes
+ integer*4 bigcal_trig_change_irow ! iy of changed ped.
+ integer*4 bigcal_trig_change_icol ! ix of changed ped.
+ real*4 bigcal_trig_ped_change ! amount of change
+ real*4 bigcal_trig_new_rms ! new rms value
+ real*4 bigcal_trig_new_ped ! new mean value
+ common/bigcal_trig_ped_stats/
+ $ bigcal_trig_ped_sum2(BIGCAL_TRIG_NGROUP),
+ $ bigcal_trig_ped_sum(BIGCAL_TRIG_NGROUP),
+ $ bigcal_trig_ped_num(BIGCAL_TRIG_NGROUP),
+ $ bigcal_trig_num_ped_changes,
+ $ bigcal_trig_change_irow(BIGCAL_TRIG_NGROUP),
+ $ bigcal_trig_change_icol(BIGCAL_TRIG_NGROUP),
+ $ bigcal_trig_ped_change(BIGCAL_TRIG_NGROUP),
+ $ bigcal_trig_new_rms(BIGCAL_TRIG_NGROUP+1),
+ $ bigcal_trig_new_ped(BIGCAL_TRIG_NGROUP+1)
+
+ real*4 bigcal_prot_new_threshold
+ real*4 bigcal_rcs_new_threshold
+ real*4 bigcal_trig_new_threshold
+ common/bigcal_new_adc_threshold/
+ $ bigcal_prot_new_threshold(BIGCAL_PROT_NPMT),
+ $ bigcal_rcs_new_threshold(BIGCAL_RCS_NPMT),
+ $ bigcal_trig_new_threshold(BIGCAL_TRIG_NGROUP+1)
+
+*
+* CTPTYPE=parm
+*
+* parameters for analysis of ped events:
+
+ integer*4 bigcal_prot_min_peds
+ integer*4 bigcal_prot_ped_limit
+ integer*4 bigcal_rcs_min_peds
+ integer*4 bigcal_rcs_ped_limit
+ integer*4 bigcal_trig_min_peds
+ integer*4 bigcal_trig_ped_limit
+ integer*4 bigcal_prot_nsparse ! hardware threshold in channels for Protvino
+ integer*4 bigcal_rcs_nsparse ! hardware threshold in channels for RCS
+ integer*4 bigcal_trig_nsparse ! hardware threshold in channels for TRIG
+
+ common/bigcal_ped_stat_parms/
+ $ bigcal_prot_min_peds,
+ $ bigcal_prot_ped_limit(BIGCAL_PROT_NPMT),
+ $ bigcal_rcs_min_peds,
+ $ bigcal_rcs_ped_limit(BIGCAL_RCS_NPMT),
+ $ bigcal_trig_min_peds,
+ $ bigcal_trig_ped_limit(BIGCAL_TRIG_NGROUP),
+ $ bigcal_prot_nsparse,
+ $ bigcal_rcs_nsparse,
+ $ bigcal_trig_nsparse
+
+* Bigcal ADC pedestals for analysis of physics events:
+
+ real*4 bigcal_prot_min_thresh ! lower limit on (software) threshold
+ real*4 bigcal_prot_max_thresh ! upper limit on (software) threshold
+ real*4 bigcal_rcs_min_thresh ! lower limit on (software) threshold
+ real*4 bigcal_rcs_max_thresh ! upper limit on (software) threshold
+ real*4 bigcal_trig_min_thresh ! lower limit on (software) threshold
+ real*4 bigcal_trig_max_thresh ! upper limit on (software) threshold
+ real*4 bigcal_prot_ped_mean
+ real*4 bigcal_prot_ped_rms
+ real*4 bigcal_prot_adc_threshold
+ real*4 bigcal_rcs_ped_mean
+ real*4 bigcal_rcs_ped_rms
+ real*4 bigcal_rcs_adc_threshold
+ real*4 bigcal_trig_ped_mean
+ real*4 bigcal_trig_ped_rms
+ real*4 bigcal_trig_adc_threshold
+ common/bigcal_pedestals/
+ $ bigcal_prot_min_thresh,
+ $ bigcal_prot_max_thresh,
+ $ bigcal_rcs_min_thresh,
+ $ bigcal_rcs_max_thresh,
+ $ bigcal_trig_min_thresh,
+ $ bigcal_trig_max_thresh,
+ $ bigcal_prot_ped_mean(BIGCAL_PROT_NPMT),
+ $ bigcal_prot_ped_rms(BIGCAL_PROT_NPMT),
+ $ bigcal_prot_adc_threshold(BIGCAL_PROT_NPMT),
+ $ bigcal_rcs_ped_mean(BIGCAL_RCS_NPMT),
+ $ bigcal_rcs_ped_rms(BIGCAL_RCS_NPMT),
+ $ bigcal_rcs_adc_threshold(BIGCAL_RCS_NPMT),
+ $ bigcal_trig_ped_mean(BIGCAL_TRIG_NGROUP),
+ $ bigcal_trig_ped_rms(BIGCAL_TRIG_NGROUP),
+ $ bigcal_trig_adc_threshold(BIGCAL_TRIG_NGROUP)
+
+* calibration constants:
+* cfac converts ADC to amplitude
+* gain_cor adjust for small drifts detected since last calibration
+ real*4 bigcal_prot_cfac ! E = cfac * adc
+ real*4 bigcal_rcs_cfac ! E = cfac * adc
+ real*4 bigcal_trig_cfac ! E = cfac * adc
+ real*4 bigcal_prot_gain_cor
+ real*4 bigcal_rcs_gain_cor
+ real*4 bigcal_trig_gain_cor
+ common/bigcal_calib_const/
+ $ bigcal_prot_cfac(BIGCAL_PROT_NPMT),
+ $ bigcal_rcs_cfac(BIGCAL_RCS_NPMT),
+ $ bigcal_trig_cfac(BIGCAL_TRIG_NGROUP),
+ $ bigcal_prot_gain_cor(bigcal_prot_npmt),
+ $ bigcal_rcs_gain_cor(bigcal_rcs_npmt),
+ $ bigcal_trig_gain_cor(bigcal_trig_ngroup)
diff --git a/INCLUDE/bigcal_geometry.cmn b/INCLUDE/bigcal_geometry.cmn
new file mode 100755
index 0000000..3b2b561
--- /dev/null
+++ b/INCLUDE/bigcal_geometry.cmn
@@ -0,0 +1,47 @@
+*
+* CTPTYPE=parm
+*
+ integer*4 BIGCAL_PROT_NCELL
+ parameter(BIGCAL_PROT_NCELL=1024)
+ integer*4 BIGCAL_RCS_NCELL
+ parameter(BIGCAL_RCS_NCELL=720)
+ integer*4 BIGCAL_ALL_NCELL
+ parameter(BIGCAL_ALL_NCELL=1744)
+
+ real*4 BIGCAL_PROT_XCENTER(BIGCAL_PROT_NCELL)
+ real*4 BIGCAL_PROT_YCENTER(BIGCAL_PROT_NCELL)
+ real*4 BIGCAL_RCS_XCENTER(BIGCAL_RCS_NCELL)
+ real*4 BIGCAL_RCS_YCENTER(BIGCAL_RCS_NCELL)
+
+ real*4 BIGCAL_ALL_XCENTER(BIGCAL_ALL_NCELL)
+ real*4 BIGCAL_ALL_YCENTER(BIGCAL_ALL_NCELL)
+
+ real*4 BIGCAL_PROT_SIZE_X
+ real*4 BIGCAL_PROT_SIZE_Y
+ real*4 BIGCAL_PROT_SIZE_Z
+ real*4 BIGCAL_RCS_SIZE_X
+ real*4 BIGCAL_RCS_SIZE_Y
+ real*4 BIGCAL_RCS_SIZE_Z
+ real*4 BIGCAL_PROT_SHIFT_X
+ real*4 BIGCAL_PROT_SHIFT_Y
+ real*4 BIGCAL_RCS_SHIFT_X
+ real*4 BIGCAL_RCS_SHIFT_Y
+
+ common/bigcal_geometry/
+ $ BIGCAL_PROT_XCENTER,
+ $ BIGCAL_PROT_YCENTER,
+ $ BIGCAL_RCS_XCENTER,
+ $ BIGCAL_RCS_YCENTER,
+ $ BIGCAL_ALL_XCENTER,
+ $ BIGCAL_ALL_YCENTER,
+ $ BIGCAL_PROT_SIZE_X,
+ $ BIGCAL_PROT_SIZE_Y,
+ $ BIGCAL_PROT_SIZE_Z,
+ $ BIGCAL_RCS_SIZE_X,
+ $ BIGCAL_RCS_SIZE_Y,
+ $ BIGCAL_RCS_SIZE_Z,
+ $ BIGCAL_PROT_SHIFT_X,
+ $ BIGCAL_PROT_SHIFT_Y,
+ $ BIGCAL_RCS_SHIFT_X,
+ $ BIGCAL_RCS_SHIFT_Y
+
diff --git a/INCLUDE/bigcal_hist_id.cmn b/INCLUDE/bigcal_hist_id.cmn
new file mode 100644
index 0000000..4828ae0
--- /dev/null
+++ b/INCLUDE/bigcal_hist_id.cmn
@@ -0,0 +1,121 @@
+*%% include 'bigcal_data_structures.cmn'
+*
+* CTPTYPE=parm
+*
+ integer*4 bid_bcal_row
+ integer*4 bid_bcal_col
+ integer*4 bid_bcal_rowcol
+ integer*4 bid_bcal_prot_eff
+ integer*4 bid_bcal_rcs_eff
+ integer*4 bid_bcal_tadcvsum64
+ integer*4 bid_bcal_trchvmax64
+ integer*4 bid_bcal_ttdcvtdc
+ integer*4 bid_bcal_xclust
+ integer*4 bid_bcal_yclust
+ integer*4 bid_bcal_eclust
+ integer*4 bid_bcal_exy
+ integer*4 bid_bcal_xy
+ integer*4 bid_bcal_ncellclst
+ integer*4 bid_bcal_nxclust
+ integer*4 bid_bcal_nyclust
+ integer*4 bid_bcal_theta
+ integer*4 bid_bcal_phi
+ integer*4 bid_bcal_xmom
+ integer*4 bid_bcal_ymom
+ integer*4 bid_bcal_tmean
+ integer*4 bid_bcal_trms
+ integer*4 bid_bcal_nxny
+ integer*4 bid_badc(bigcal_all_maxhits)
+ integer*4 bid_btdc(bigcal_max_tdc)
+c integer*4 bid_btimewalk(bigcal_max_tdc)
+ integer*4 bid_btadc(bigcal_atrig_maxhits)
+ integer*4 bid_bttdc(bigcal_ttrig_maxgroups)
+ integer*4 bid_bcal_empty
+ integer*4 bid_bcal_small
+ integer*4 bid_bcal_cfac_old
+ integer*4 bid_bcal_cfac_new
+ integer*4 bid_bcal_cfac_dist
+ integer*4 bid_bcal_oldxnew
+ integer*4 bid_bcal_ixclust
+ integer*4 bid_bcal_iyclust
+ integer*4 bid_bcal_rowcolclust
+ integer*4 bid_bcal_ped_mean_prot
+ integer*4 bid_bcal_ped_mean_rcs
+ integer*4 bid_bcal_ped_mean_trig
+ integer*4 bid_bcal_ped_rms_prot
+ integer*4 bid_bcal_ped_rms_rcs
+ integer*4 bid_bcal_ped_rms_trig
+ integer*4 bid_bcal_pedw_prot
+ integer*4 bid_bcal_pedw_rcs
+ integer*4 bid_bcal_pedw_trig
+ integer*4 bid_bcal_raw_photodiode
+ integer*4 bid_bcal_row8
+ integer*4 bid_bcal_col8
+ integer*4 bid_bcal_row8vscol8
+ integer*4 bid_bcal_trow64
+ integer*4 bid_bcal_tcol64
+ integer*4 bid_bcal_trow64vstcol64
+ integer*4 bid_bcal_arow64
+ integer*4 bid_bcal_acol64
+ integer*4 bid_bcal_arow64vsacol64
+ integer*4 bid_bcal_ttchanvstachan
+ integer*4 bid_bcal_ttchanvstgroup
+ common/bigcal_hist_id/
+ $ bid_bcal_row,
+ $ bid_bcal_col,
+ $ bid_bcal_rowcol,
+ $ bid_bcal_prot_eff,
+ $ bid_bcal_rcs_eff,
+ $ bid_bcal_tadcvsum64,
+ $ bid_bcal_trchvmax64,
+ $ bid_bcal_ttdcvtdc,
+ $ bid_bcal_xclust,
+ $ bid_bcal_yclust,
+ $ bid_bcal_eclust,
+ $ bid_bcal_exy,
+ $ bid_bcal_xy,
+ $ bid_bcal_ncellclst,
+ $ bid_bcal_nxclust,
+ $ bid_bcal_nyclust,
+ $ bid_bcal_theta,
+ $ bid_bcal_phi,
+ $ bid_bcal_xmom,
+ $ bid_bcal_ymom,
+ $ bid_bcal_tmean,
+ $ bid_bcal_trms,
+ $ bid_bcal_nxny,
+ $ bid_badc,
+ $ bid_btdc,
+c $ bid_btimewalk,
+ $ bid_btadc,
+ $ bid_bttdc,
+ $ bid_bcal_empty,
+ $ bid_bcal_small,
+ $ bid_bcal_cfac_old,
+ $ bid_bcal_cfac_new,
+ $ bid_bcal_cfac_dist,
+ $ bid_bcal_oldxnew,
+ $ bid_bcal_ixclust,
+ $ bid_bcal_iyclust,
+ $ bid_bcal_rowcolclust,
+ $ bid_bcal_ped_mean_prot,
+ $ bid_bcal_ped_mean_rcs,
+ $ bid_bcal_ped_mean_trig,
+ $ bid_bcal_ped_rms_prot,
+ $ bid_bcal_ped_rms_rcs,
+ $ bid_bcal_ped_rms_trig,
+ $ bid_bcal_pedw_prot,
+ $ bid_bcal_pedw_rcs,
+ $ bid_bcal_pedw_trig,
+ $ bid_bcal_raw_photodiode,
+ $ bid_bcal_row8,
+ $ bid_bcal_col8,
+ $ bid_bcal_row8vscol8,
+ $ bid_bcal_trow64,
+ $ bid_bcal_tcol64,
+ $ bid_bcal_trow64vstcol64,
+ $ bid_bcal_arow64,
+ $ bid_bcal_acol64,
+ $ bid_bcal_arow64vsacol64,
+ $ bid_bcal_ttchanvstachan,
+ $ bid_bcal_ttchanvstgroup
diff --git a/INCLUDE/bigcal_shower_parms.cmn b/INCLUDE/bigcal_shower_parms.cmn
new file mode 100755
index 0000000..4e476e9
--- /dev/null
+++ b/INCLUDE/bigcal_shower_parms.cmn
@@ -0,0 +1,83 @@
+*%% include 'bigcal_data_structures.cmn'
+*
+* CTPTYPE=parm
+*
+* parameters for shower cluster coordinate reconstruction:
+* x = p0*arctan(p1*xmom**4 + p2*xmom**3 + p3*xmom**2 + p4*xmom + p5)
+* y = p0*arctan(p1*ymom**4 + p2*ymom**3 + p3*ymom**2 + p4*ymom + p5)
+* p1 and p2 generally small, p0,p3,p4,p5 typically most important
+ integer*4 BIGCAL_SHOWER_NPAR
+ parameter(BIGCAL_SHOWER_NPAR=6)
+
+ integer*4 bigcal_map_maxbins
+ parameter(bigcal_map_maxbins=100)
+
+ real*4 bigcal_pxdet_par(BIGCAL_PROT_NX*BIGCAL_SHOWER_NPAR)
+ real*4 bigcal_pydet_par(BIGCAL_PROT_NY*BIGCAL_SHOWER_NPAR)
+ real*4 bigcal_rxdet_par(BIGCAL_RCS_NX*BIGCAL_SHOWER_NPAR)
+ real*4 bigcal_rydet_par(BIGCAL_RCS_NY*BIGCAL_SHOWER_NPAR)
+
+ real*4 BIGCAL_PROT_XPAR(BIGCAL_PROT_NX,BIGCAL_SHOWER_NPAR)
+ real*4 BIGCAL_PROT_YPAR(BIGCAL_PROT_NY,BIGCAL_SHOWER_NPAR)
+ real*4 BIGCAL_RCS_XPAR(BIGCAL_RCS_NX,BIGCAL_SHOWER_NPAR)
+ real*4 BIGCAL_RCS_YPAR(BIGCAL_RCS_NY,BIGCAL_SHOWER_NPAR)
+
+ integer*4 BIGCAL_SHAPE_OPT ! 1 = asymmetric, otherwise symmetric
+
+ real*4 BIGCAL_SSHAPE_A
+ real*4 BIGCAL_SSHAPE_B
+c real*4 BIGCAL_SSHAPE_D
+
+ real*4 BIGCAL_ASHAPE_A
+ real*4 BIGCAL_ASHAPE_BX
+ real*4 BIGCAL_ASHAPE_BY
+c real*4 BIGCAL_ASHAPE_D
+
+ common/bigcal_shower_parms/
+ $ BIGCAL_PXDET_PAR,
+ $ BIGCAL_PYDET_PAR,
+ $ BIGCAL_RXDET_PAR,
+ $ BIGCAL_RYDET_PAR,
+ $ BIGCAL_PROT_XPAR,
+ $ BIGCAL_PROT_YPAR,
+ $ BIGCAL_RCS_XPAR,
+ $ BIGCAL_RCS_YPAR,
+ $ BIGCAL_SHAPE_OPT,
+ $ BIGCAL_SSHAPE_A,
+ $ BIGCAL_SSHAPE_B,
+ $ BIGCAL_ASHAPE_A,
+ $ BIGCAL_ASHAPE_BX,
+ $ BIGCAL_ASHAPE_BY
+
+ real*4 bigcal_shower_map_shift(2) ! 1=X, 2=Y
+ real*4 bigcal_shower_map_slope(2) ! 1=X, 2=Y
+
+ integer*4 bigcal_xmap_nbin(28)
+ integer*4 bigcal_ymap_nbin(28)
+
+ real*4 bigcal_xmap_mmin(28)
+ real*4 bigcal_ymap_mmin(28)
+ real*4 bigcal_xmap_mmax(28)
+ real*4 bigcal_ymap_mmax(28)
+
+ real*4 bigcal_xmap_frac(2800)
+ real*4 bigcal_ymap_frac(2800)
+
+ real*4 bigcal_xmap_xfrac(28,100)
+ real*4 bigcal_ymap_yfrac(28,100)
+
+ common/bigcal_map_parms/
+ $ bigcal_shower_map_shift,
+ $ bigcal_shower_map_slope,
+ $ bigcal_xmap_nbin,
+ $ bigcal_ymap_nbin,
+ $ bigcal_xmap_mmin,
+ $ bigcal_ymap_mmin,
+ $ bigcal_xmap_mmax,
+ $ bigcal_ymap_mmax,
+ $ bigcal_xmap_frac,
+ $ bigcal_ymap_frac,
+ $ bigcal_xmap_xfrac,
+ $ bigcal_ymap_yfrac
+
+
diff --git a/INCLUDE/bigcal_tof_parms.cmn b/INCLUDE/bigcal_tof_parms.cmn
new file mode 100755
index 0000000..69e99f9
--- /dev/null
+++ b/INCLUDE/bigcal_tof_parms.cmn
@@ -0,0 +1,46 @@
+ integer*4 BIGCAL_N8
+ parameter(BIGCAL_N8=224) ! 32*56 / 8 = 1792/8 = 224
+ integer*4 BIGCAL_N64
+ parameter(BIGCAL_N64=42) ! sum of 64 groups
+*
+* CTPTYPE = parm
+*
+ real*4 bigcal_tdc_min
+ real*4 bigcal_tdc_max
+ real*4 bigcal_tdc_to_time
+ real*4 bigcal_window_center
+ real*4 bigcal_window_slop
+ real*4 bigcal_tof_central ! central value of bigcal time of flight
+ real*4 bigcal_end_time ! value used to invert hit times in cmn stop
+ real*4 b_timing_cut
+ real*4 b_trig_offset ! offset to account for changes in trig. cable length
+ real*4 bigcal_g8_time_offset(bigcal_n8)
+ real*4 bigcal_g8_phc_p0(bigcal_n8)
+ real*4 bigcal_g8_phc_p1(bigcal_n8)
+ real*4 bigcal_g8_phc_p2(bigcal_n8)
+ real*4 bigcal_g8_phc_p3(bigcal_n8)
+ real*4 bigcal_g8_phc_minph(bigcal_n8)
+ real*4 bigcal_g8_phc_maxph(bigcal_n8)
+ real*4 bigcal_g64_time_offset(bigcal_n64)
+ real*4 bigcal_g64_phc_p0(bigcal_n64)
+ real*4 bigcal_g64_phc_p1(bigcal_n64)
+ real*4 bigcal_g64_phc_p2(bigcal_n64)
+ real*4 bigcal_g64_phc_p3(bigcal_n64)
+ real*4 bigcal_g64_phc_minph(bigcal_n64)
+ real*4 bigcal_g64_phc_maxph(bigcal_n64)
+
+ common/bigcal_tof_parms/
+ $ bigcal_tdc_min,bigcal_tdc_max,bigcal_tdc_to_time,
+ $ bigcal_window_center,bigcal_window_slop,
+ $ bigcal_tof_central,
+ $ bigcal_end_time,b_timing_cut,b_trig_offset,
+ $ bigcal_g8_time_offset,
+ $ bigcal_g8_phc_p0,bigcal_g8_phc_p1,
+ $ bigcal_g8_phc_p2,bigcal_g8_phc_p3,
+ $ bigcal_g8_phc_minph,bigcal_g8_phc_maxph,
+ $ bigcal_g64_time_offset,
+ $ bigcal_g64_phc_p0,bigcal_g64_phc_p1,
+ $ bigcal_g64_phc_p2,bigcal_g64_phc_p3,
+ $ bigcal_g64_phc_minph,bigcal_g64_phc_maxph
+
+
diff --git a/INCLUDE/c_ntuple.cmn b/INCLUDE/c_ntuple.cmn
new file mode 100644
index 0000000..0bbd6e0
--- /dev/null
+++ b/INCLUDE/c_ntuple.cmn
@@ -0,0 +1,51 @@
+**************************begin: c_ntuple.cmn ***********************
+*-
+*- Created 8-Apr-1994 Kevin B. Beard, Hampton Univ.
+*........................................................................
+*- Misc. info. required for COIN Ntuple
+* $Log: c_ntuple.cmn,v $
+* Revision 1.4 2004/02/17 16:41:45 jones
+* Add parameters and variables needed for segmenting rzdat files
+*
+* Revision 1.3 1995/05/22 19:05:06 cdaq
+* (SAW) Correct some CTP class types
+*
+* Revision 1.2 1994/06/17 02:02:14 cdaq
+* (KBB) Fix typos, change variable names, reorder common
+*
+* Revision 1.1 1994/04/14 16:05:45 cdaq
+* Initial revision
+*
+*
+ integer CMAX_Ntuple_size
+ parameter (CMAX_Ntuple_size= 100)
+ integer default_c_Ntuple_ID
+ parameter (default_c_Ntuple_ID= 9500)
+*
+* CTPTYPE=parm
+*
+ logical c_Ntuple_exists
+ integer c_Ntuple_ID
+ integer c_Ntuple_size
+ integer c_Ntuple_IOchannel
+ character*80 c_Ntuple_name
+ character*80 c_Ntuple_title
+ character*132 c_Ntuple_directory
+ character*256 c_Ntuple_file
+ character*8 c_Ntuple_tag(CMAX_Ntuple_size)
+ integer c_Ntuple_max_segmentevents
+*
+* CTPTYPE=event
+*
+ integer c_Ntuple_segmentevents
+ integer c_Ntuple_filesegments
+ real c_Ntuple_contents(CMAX_Ntuple_size)
+*
+ COMMON /COIN_Ntuple/ c_Ntuple_exists,c_Ntuple_ID,
+ & c_Ntuple_size,c_Ntuple_IOchannel,
+ & c_Ntuple_name,c_Ntuple_title,
+ & c_Ntuple_directory,c_Ntuple_file,
+ & c_Ntuple_tag,c_Ntuple_contents,
+ > c_Ntuple_max_segmentevents,c_Ntuple_segmentevents,
+ > c_Ntuple_filesegments
+*****************************end: c_ntuple.cmn ***********************
diff --git a/INCLUDE/c_ntuple.dte b/INCLUDE/c_ntuple.dte
new file mode 100644
index 0000000..56e8f97
--- /dev/null
+++ b/INCLUDE/c_ntuple.dte
@@ -0,0 +1,21 @@
+**************************begin: c_ntuple.dte ***********************
+*-
+*- Created 15-Jun-1994 Kevin B. Beard, Hampton Univ.
+*........................................................................
+*- leave clean field for HMS Ntuple
+* $Log: c_ntuple.dte,v $
+* Revision 1.1 1994/06/17 02:05:04 cdaq
+* Initial revision
+*
+ data c_Ntuple_exists/.FALSE./
+ data c_Ntuple_ID/0/
+ data c_Ntuple_file/' '/
+ data c_Ntuple_name/' '/
+ data c_Ntuple_title/' '/
+ data c_Ntuple_directory/' '/
+ data c_Ntuple_IOchannel/0/
+ data c_Ntuple_size/0/
+ data c_Ntuple_tag/CMAX_Ntuple_size*' '/
+ data c_Ntuple_contents/CMAX_Ntuple_size*0/
+*
+****************************end: c_ntuple.dte ***********************
diff --git a/INCLUDE/coin_bypass_switches.cmn b/INCLUDE/coin_bypass_switches.cmn
new file mode 100644
index 0000000..55ed9dc
--- /dev/null
+++ b/INCLUDE/coin_bypass_switches.cmn
@@ -0,0 +1,17 @@
+* coin_bypass_switches.cmn
+*
+* common blocks of CTP switches to bypass reconstruction code
+* elements.
+*
+* Created: S.A. Wood 3 May 1995
+* $Log: coin_bypass_switches.cmn,v $
+* Revision 1.1 1995/05/11 15:21:44 cdaq
+* Initial revision
+*
+*
+* CTPTYPE=parm
+*
+ integer*4 cbypass_physics
+*
+ common/coin_bypass_switches/
+ $ cbypass_physics
diff --git a/INCLUDE/coin_data_structures.cmn b/INCLUDE/coin_data_structures.cmn
new file mode 100644
index 0000000..cedeae0
--- /dev/null
+++ b/INCLUDE/coin_data_structures.cmn
@@ -0,0 +1,82 @@
+*****************begin: coin_data_structures.cmn*************************
+*
+* include file coin_data_structures.cmn
+*
+* Author: D. F. Geesaman 1 September 1993
+*
+* $Log: coin_data_structures.cmn,v $
+* Revision 1.4 2003/12/18 18:11:02 jones
+* Added variables C_costhcm,C_phicm calculated in ENGINE/delta_physics.f
+*
+* Revision 1.3 1999/02/23 19:04:41 csa
+* Add some physics vars, cleanup
+*
+* Revision 1.2 1996/04/30 13:33:33 saw
+* (JRA) Add some coincidence kinematics variables
+*
+* Revision 1.1 1995/05/22 18:42:27 cdaq
+* Initial revision
+*
+
+****************************************************************************
+* COIN_PHYSICS COMMON BLOCKS
+*
+* These are filled by C_PHYSICS.
+*
+*
+* CTPTYPE=event
+*
+ REAL*4 CMISSING_MASS ! Missing mass of undetected hadron system
+ REAL*4 CMISSING_MOM ! Magnitude of missing momentum
+ REAL*4 CMISSING_MOMS ! Missing momentum with an attitude adjustment
+ REAL*4 CMISSING_MOMX ! X component of missing momentum
+ REAL*4 CMISSING_MOMY ! Y component of missing momentum
+ REAL*4 CMISSING_MOMZ ! Z component of missing momentum
+ REAL*4 CMISSING_E ! Missing E (Binding Energy)
+ REAL*4 CTIME_COIN_COR ! Corrected Coincidence time
+ REAL*4 CS ! s computed from spectrometers only
+ REAL*4 CTHETAPQ ! Angle between q and hadron
+ REAL*4 CPHIPQ ! Azimuthal angle of hadron about q
+ REAL*4 W2,C_INVMASS,P_SOS_CORR,P_HMS_CORR,OMEGA
+ REAL*4 CMISSING_MOM_PAR,CMISSING_MOM_PERP,CMISSING_MOM_OOP
+ REAL*4 C_BIGQ2,C_costhcm,C_phicm
+*
+ COMMON/COIN_PHYSICS_R4/
+ & CMISSING_MASS,
+ & CMISSING_MOM,
+ & CMISSING_MOMS,
+ & CMISSING_MOMX,
+ & CMISSING_MOMY,
+ & CMISSING_MOMZ,
+ & CMISSING_E,
+ & CTIME_COIN_COR,
+ & CS,
+ & CTHETAPQ,
+ & CPHIPQ,
+ & W2,
+ & C_INVMASS,
+ & P_SOS_CORR,
+ & P_HMS_CORR,
+ & OMEGA,
+ & CMISSING_MOM_PAR,
+ & CMISSING_MOM_PERP,
+ & CMISSING_MOM_OOP,
+ & C_BIGQ2,C_costhcm,C_phicm
+
+*
+* CTPTYPE=event
+*
+ real*4 ccointime_hms
+ real*4 ccointime_sos
+
+ common/coin_timing_vars/
+ & ccointime_hms,
+ & ccointime_sos
+*
+*
+*******************end: coin_data_structures.cmn*************************
+* Local Variables:
+* mode: fortran
+* fortran-continuation-string: "&"
+* comment-column: 35
+* End:
diff --git a/INCLUDE/coin_filenames.cmn b/INCLUDE/coin_filenames.cmn
new file mode 100644
index 0000000..456b289
--- /dev/null
+++ b/INCLUDE/coin_filenames.cmn
@@ -0,0 +1,38 @@
+******************* begin: coin_filenames.cmn ***********************
+*
+*-Common block with filenames
+* $Log: coin_filenames.cmn,v $
+* Revision 1.7 2005/02/16 20:44:57 saw
+* Missing ,
+*
+* Revision 1.6 2005/02/16 20:43:40 saw
+* Add filename for coincidence root tree
+*
+* Revision 1.5 1995/04/06 20:15:28 cdaq
+* (SAW) Add report output filenames
+*
+* Revision 1.4 1994/08/30 13:47:45 cdaq
+* (SAW) Name of common block was wrong (hms_filenames), fixed it.
+*
+* Revision 1.3 1994/08/15 13:17:20 cdaq
+* (SAW) Add "CTPTYPE=parm" directive for auto generation of CTP reg calls
+*
+* Revision 1.2 1994/06/15 18:46:26 cdaq
+* (SAW) Fix typo
+*
+* Revision 1.1 1994/06/15 18:15:45 cdaq
+* Initial revision
+*
+* CTPTYPE=parm
+*
+ character*80 c_report_template_filename ! CTP file with coin report
+ character*80 c_report_blockname
+ character*80 c_report_output_filename
+ character*80 c_tree_filename
+*
+ common /coin_filenames/
+ $ c_report_template_filename,
+ $ c_report_blockname,
+ $ c_report_output_filename,
+ $ c_tree_filename
+*
diff --git a/INCLUDE/f1trigger_data_structures.cmn b/INCLUDE/f1trigger_data_structures.cmn
new file mode 100644
index 0000000..cd3e90b
--- /dev/null
+++ b/INCLUDE/f1trigger_data_structures.cmn
@@ -0,0 +1,48 @@
+*****************begin: luc_data_structures.cmn*************************
+*
+* include file f1trigger_data_structures.cmn
+*
+* Author: H. Baghdasaryan 18 Jan,2008
+*
+* $Log: f1trigger_data_structures.cmn,v $
+* Revision 1.1.2.1 2008/10/02 18:01:48 cdaq
+* *** empty log message ***
+*
+
+c
+c
+c F1 Trigger RAW DATA Structure
+c
+c
+
+c
+c VERY IMPORTANT look at CTPTYPE DO not ignore.. Makes sence.
+c
+
+*
+*
+* CTPTYPE=event
+*
+
+ INTEGER*4 TRIGGER_F1_MAX_HITS ! MAXIMUM TOTAL NUMBER OF TRIGGERS
+ PARAMETER (TRIGGER_F1_MAX_HITS=10) ! Should exceed # of paddles
+ integer*4 TRIGGER_F1_MAX_COUNTERS
+ PARAMETER (TRIGGER_F1_MAX_COUNTERS=10)
+ INTEGER*4 TRIGGER_F1_RAW_COUNTER(TRIGGER_F1_MAX_HITS)
+ INTEGER*4 TRIGGER_F1_RAW_PLANE(TRIGGER_F1_MAX_HITS)
+ INTEGER*4 TRIGGER_F1_START_TDC(TRIGGER_F1_MAX_HITS)
+ INTEGER*4 TRIGGER_F1_RAW_TOT_HITS
+ INTEGER*4 TRIGGER_F1_START_TDC_COUNTER(TRIGGER_F1_MAX_COUNTERS)
+ COMMON/TRIGGER_F1_RAW/
+ & TRIGGER_F1_RAW_PLANE,
+ & TRIGGER_F1_RAW_COUNTER,
+ & TRIGGER_F1_START_TDC,
+ & TRIGGER_F1_RAW_TOT_HITS,
+ & TRIGGER_F1_START_TDC_COUNTER
+
+*
+* CTPTYPE=parm
+*
+* parameters from CALIBRATION
+ INTEGER*4 TRIGGER_F1_ROLOVER(TRIGGER_F1_MAX_COUNTERS)
+ COMMON/TRIGGER_F1_ROL/TRIGGER_F1_ROLOVER
diff --git a/INCLUDE/gen_constants.par b/INCLUDE/gen_constants.par
new file mode 100644
index 0000000..758957c
--- /dev/null
+++ b/INCLUDE/gen_constants.par
@@ -0,0 +1,80 @@
+********************** begin: gen_constants.par *******************************
+* $Log: gen_constants.par,v $
+* Revision 1.5 1998/12/07 22:11:23 saw
+* Initial setup
+*
+* Revision 1.4 1995/05/22 19:13:19 cdaq
+* (SAW) Add "nucleon" mass
+*
+* Revision 1.3 1994/06/14 03:36:50 cdaq
+* (DFG) Add electron mass
+*
+* Revision 1.2 1994/02/08 04:23:05 cdaq
+* Small fix
+*
+* Revision 1.1 1994/02/07 20:06:14 cdaq
+* Initial revision
+*
+*
+* general purpose constants
+*
+ real TT
+ parameter (TT= 3.141592653) !pi- a fundamental constant
+*
+ real infinity
+ parameter (infinity= 9.9999E+29) !practical infinity
+*
+*-energy units
+ real GeV,MeV,KeV,eV
+ parameter (GeV= 1.) !GeV standard hallC energy unit
+ parameter (MeV= 0.001*GeV) !MeV
+ parameter (KeV= 0.001*MeV) !KeV
+ parameter (eV= 0.001*KeV) !eV
+*
+*-time units
+ real nanoSec,microSec,milliSec,Second,picoSec
+ parameter (nanoSec= 1.) !nS std. hallC time unit
+ parameter (microSec= 1000.*nanoSec) !uS
+ parameter (milliSec= 1000.*microSec) !mS
+ parameter (Second= 1000.*milliSec) !second
+ parameter (picoSec= 0.001*nanoSec) !pS
+*
+*-distance units
+ real centimeter,meter,millimeter,micron,inch,foot,mil
+ parameter (centimeter= 1.) !cm standard hallC distance unit
+ parameter (meter= 100.*centimeter) !m
+ parameter (millimeter= 0.1*centimeter) !mm
+ parameter (micron= 0.001*millimeter) !um
+ parameter (inch= 2.540*centimeter) !US in.
+ parameter (foot= 12.0*inch) !US ft.
+ parameter (mil= 0.001*inch) !US mil
+*
+*-angle units
+ real radian,degree
+ parameter (radian= 1.) !standard hallC angle unit
+ parameter (degree= TT/180.*radian) !radians/degree
+*
+*-magnetic field units
+ real Tesla,Kgauss,gauss
+ parameter (Tesla= 1.) !standard hallC unit
+ parameter (Kgauss= 0.1*Tesla)
+ parameter (gauss= 0.001*Kgauss)
+*
+ real speed_of_light
+ parameter (speed_of_light= 29.9792458*centimeter/nanoSec)
+*
+ real index_of_refraction
+ parameter (index_of_refraction= 1.581) !plastic scint. n
+ real speed_in_plastic
+ parameter (speed_in_plastic= speed_of_light/index_of_refraction)
+*
+ real*4 mass_electron
+ parameter (mass_electron = 0.000510999)
+ real*4 mass_nucleon
+ parameter (mass_nucleon = 0.93827)
+ real*4 m_amu
+ parameter (m_amu = 0.9315016)
+************************ end: gen_constants.par *******************************
+* Local Variables:
+* mode: fortran
+* End:
diff --git a/INCLUDE/gen_craw.cmn b/INCLUDE/gen_craw.cmn
new file mode 100644
index 0000000..9237f6c
--- /dev/null
+++ b/INCLUDE/gen_craw.cmn
@@ -0,0 +1,25 @@
+*
+* include file gen_craw.cmn
+*
+* Buffer to hold the raw event for off-line analysis. (Not used for
+* online as CODA supplies the buffer.)
+*
+* $Log: gen_craw.cmn,v $
+* Revision 1.2 1999/03/19 15:22:31 saw
+* (SAW) Increase maximum event size from 20000 to 40000
+*
+* Revision 1.1 1994/04/12 18:33:42 cdaq
+* Initial revision
+*
+*
+* RAW DATA
+*
+* ARRAY NAME CRAW
+* DIMENSION LENGTH LENGTH_CRAW
+*
+ INTEGER*4 LENGTH_CRAW
+ PARAMETER (LENGTH_CRAW=40000)
+ INTEGER*4 CRAW
+*
+ COMMON/COIN_CRAW/ CRAW(LENGTH_CRAW)
+*
diff --git a/INCLUDE/gen_data_structures.cmn b/INCLUDE/gen_data_structures.cmn
new file mode 100644
index 0000000..a6c4380
--- /dev/null
+++ b/INCLUDE/gen_data_structures.cmn
@@ -0,0 +1,545 @@
+*****************begin: gen_data_structures.cmn*************************
+*
+* include file gen_data_structures.cmn
+*
+* Author: D. F. Geesaman 1 September 1993
+*
+* $Log: gen_data_structures.cmn,v $
+* Revision 1.35.20.7.2.6 2009/01/16 18:48:01 cdaq
+* *** empty log message ***
+*
+* Revision 1.35.20.7.2.5 2008/10/31 08:26:25 cdaq
+* *** empty log message ***
+*
+* Revision 1.35.20.7.2.4 2008/10/25 12:41:09 cdaq
+* *** empty log message ***
+*
+* Revision 1.35.20.7.2.3 2008/10/11 15:04:23 cdaq
+* slow raster
+*
+* Revision 1.35.20.7.2.2 2008/10/08 17:38:19 cdaq
+* Added 2nd copy of slow raster info
+*
+* Revision 1.35.20.7.2.1 2008/09/26 21:42:49 cdaq
+* *** empty log message ***
+*
+* Revision 1.35.20.7 2007/10/23 17:02:07 cdaq
+* Added eloss parameters for everything in front of BigCal: 4 inch Al absorber, .5 inch lucite, .75 inches Al (.5 in front plate and .25 in support frame for lucite)
+*
+* Revision 1.35.20.6 2007/10/20 19:52:02 cdaq
+* Added helicity_ADC and helicity_TS variables so we can compare
+*
+* Revision 1.35.20.5 2007/10/19 14:57:57 cdaq
+* *** empty log message ***
+*
+* Revision 1.35.20.4 2007/10/17 16:03:28 cdaq
+* Added beam helicity variable
+*
+* Revision 1.35.20.3 2007/10/17 15:51:27 cdaq
+* Added helicity flag
+*
+* Revision 1.35.20.2 2007/08/07 19:11:34 puckett
+* *** empty log message ***
+*
+* Revision 1.35 2003/09/05 20:08:09 jones
+* Merge in online03 changes (mkj)
+*
+* Revision 1.34.2.1 2003/04/09 02:59:22 cdaq
+* Changed gtarg_type from a scaler to an array: gtarg_type(gtarg_num)
+*
+* Revision 1.34 2003/02/21 14:54:04 jones
+* Added parameter genable_sos_fieldcorr used in ENGINE/s_fieldcorr.f
+* as flag for enabling correction to SOS central momentum
+*
+* Revision 1.33 2002/12/27 21:43:14 jones
+* add variable geloss to common gen_beam
+* add gtarg_type to common gen_target
+* change GMAX_NUM_BPMS=3
+* change GBPM_KAPPA to array GBPM_KAPPA(GMAX_NUM_BPMS)
+*
+* Revision 1.32 2002/09/24 20:30:17 jones
+* a. Add genable_hms_fieldcorr to common/gen_satcorr/
+* b. Move array definitions from COMMON block to REAL statement
+*
+*
+*
+* Revision 1.31 1999/02/23 19:05:55 csa
+* (JRA) Remove slow raster stuff
+*
+* Revision 1.30 1999/02/10 17:50:04 csa
+* Added target eloss variables (D. Mack, K. Vansyoc, J. Volmer),
+* bpm variables (P. Gueye), and raster variables (J. Reinhold)
+*
+* Revision 1.29 1998/12/01 20:21:02 saw
+* (SAW) Change GNUM_MISC_PLANES from 2 to 3
+*
+* Revision 1.28 96/09/04 15:45:04 15:45:04 saw (Stephen A. Wood)
+* (JRA) Increase # of possible targets. Add fast raster variables.
+*
+* Revision 1.27 1996/04/30 13:34:25 saw
+* (JRA) Swap index order in GBPM_ADC_PED, GBPM_RAW_ADC
+*
+* Revision 1.26 1996/01/24 16:18:29 saw
+* (JRA) Change raster to use misc arrays. Change some variable names
+* for beam position and target information.
+*
+* Revision 1.25 1995/05/22 18:40:21 cdaq
+* (SAW) Split gen_data_data_structures into gen, hms, sos, and coin parts
+*
+* Revision 1.24 1995/05/11 15:16:26 cdaq
+* (SAW) Add new singles and coin kinematics. Add aerogel structure.
+* (JRA) Change ?SDEDXn vars to arrays.
+*
+* Revision 1.23 1995/04/06 20:16:28 cdaq
+* (SAW) Add ddutta's pre cosy rotation stuff. Add arrays for BPM data
+*
+* Revision 1.22 1995/03/13 18:54:22 cdaq
+* (JRA) ?SCIN_ADC_??? now real, add several element max's for array sizes, add
+* ?NUM_PMT_HIT, ?SNUM_SCIN_HIT, ?SNUM_PMT_HIT
+*
+* Revision 1.21 1995/01/03 13:59:37 cdaq
+* (HGM) Increase # of HMS shower counter blocks to 52
+*
+* Revision 1.20 1994/11/22 18:37:46 cdaq
+* (SPB) Brought SOS commons up to date
+* (SAW) Cleaned up ?DC_NUM_CHAMBERS and ?MAX_NUM_CHAMBERS stuff
+*
+* Revision 1.19 1994/09/19 20:26:44 cdaq
+* (SAW) Remove HDC_HITS_PER_PLANE from HMS_DECODED_DC common
+*
+* Revision 1.18 1994/09/13 21:47:19 cdaq
+* (JRA) Remove HGOOD_START_PLANE
+*
+* Revision 1.17 1994/09/13 19:15:21 cdaq
+* (JRA) Add chisq, shower c. raw adc, number of chambers, shower c slop
+*
+* Revision 1.16 1994/08/15 13:20:47 cdaq
+* (SAW) CEBEAM and CPBEAM are parm not event
+*
+* Revision 1.15 1994/08/15 04:39:29 cdaq
+* (SAW) Change CTPTYPE to parm for some variables
+*
+* Revision 1.14 1994/08/03 19:57:07 cdaq
+* (SAW) Add "CTPTYPE=event" directive for auto generation of CTP reg calls
+*
+* Revision 1.13 1994/06/26 02:32:07 cdaq
+* (JA&SAW) Add rawer data structure for HMS scintillator hits.
+* Increase HMS DC max hits to 3600.
+*
+* Revision 1.12 1994/06/22 15:34:35 cdaq
+* (SAW) Increase max # of hits for hodoscopes to allow for non sparsified data
+*
+* Revision 1.11 1994/06/21 19:22:59 cdaq
+* (SAW) Add hit counters to H_RAW_MISC, S_RAW_MISC and G_RAW_UNINST commons
+*
+* Revision 1.10 1994/06/18 02:49:49 cdaq
+* (SAW) Add code for miscleaneous data and uninstrumented channels
+*
+* Revision 1.9 1994/06/14 03:05:42 cdaq
+* (DFG) Add hms_physics, sos_physics, and coin_physics
+* Add particle mass to hms_spectrometer and sos_spectrometer
+*
+* Revision 1.8 1994/04/14 16:25:43 cdaq
+* (SAW) Fix typo
+*
+* Revision 1.7 1994/04/12 20:42:22 cdaq
+* (SAW) Put column first in shower commons (column == plane)
+* Add a structure for hits on uninstrumented channels
+* Correct "FILLED BY" comment
+*
+* Revision 1.6 1994/04/12 18:38:15 cdaq
+* (DFG) Change dimension of HNTRACK_HITS(HNTRACKS_MAX,HNTRACKHITS_MAX+1)
+* SNTRACK_HITS(SNTRACKS_MAX,SNTRACKHITS_MAX+1)
+* to allow space for number of hits.
+* (SAW) Remove craw common to gen_craw.cmn
+*
+* Revision 1.5 1994/03/24 17:02:03 cdaq
+* DFG change decoded scin to arrington format in both hms and sos
+* change track tests to amatouni format
+*
+* Revision 1.4 1994/02/21 02:54:22 cdaq
+* DFG Separate dimensioning parameters from actual number
+* SNUM_DC_PLANES --> SMAX_NUM_DC_PLANES
+* HNUM_DC_PLANES --> HMAX_NUM_DC_PLANES
+*
+* Revision 1.3 1994/02/09 22:26:10 cdaq
+* (DFG) Add beam and spectrometer geometry banks.
+* Separate raw and decoded data for scin and cal
+* Change XCER_COR_ADC to XCER_PLANE
+*
+* Revision 1.2 1994/02/08 21:19:34 cdaq
+* Geesaman's Jan 5 copy adding HMS_TRACK_TESTS and SOS_TRACK_TESTS
+*
+* Revision 1.1 1994/02/07 17:05:43 cdaq
+* Initial revision
+*
+*
+* BASIC BEAM PARAMETERS
+* None of these are really coincidence things, and some are constant
+* while some are event by event.
+*
+*
+* CTPTYPE=parm
+*
+ REAL*4 GEBEAM ! BEAM ENERGY (GEV)
+ REAL*4 GPBEAM ! BEAM MOMENTUM (GEV/C)
+ REAL*4 G_BEAM_TARGET_S ! s computed from beam and target info
+*
+* CTPTYPE=event
+*
+ integer*4 ncalls_calc_ped
+ integer*4 gbeam_helicity ! whatever we decide
+ integer*4 gbeam_helicity_ADC ! value from ADC
+ integer*4 gbeam_helicity_TS ! value from TS
+ REAL*4 GBEAM_X,GBEAM_Y !final beam position from bpm & raster info
+ REAL*4 GBEAM_XP,GBEAM_YP !final beam angles from bpm & raster info
+ REAL*4 geloss
+
+ COMMON/GEN_BEAM/
+ & GEBEAM,
+ & GPBEAM,
+ & G_BEAM_TARGET_S,
+ & ncalls_calc_ped,
+ & gbeam_helicity,
+ & gbeam_helicity_ADC,
+ & gbeam_helicity_TS,
+ & GBEAM_X,GBEAM_Y,
+ & GBEAM_XP,GBEAM_YP,
+ & geloss
+*
+* CTPTYPE=parm
+*
+* BASIC TARGET PARAMETERS
+*
+ integer gmax_targets
+ parameter(gmax_targets=30)
+ integer gtarg_num !position in target ladder
+ REAL*4 gtarg_mass(gmax_targets) !target mass
+ REAL*4 gtarg_z(gmax_targets) !target Z
+ REAL*4 gtarg_a (gmax_targets) !target A
+ REAL*4 gtarg_lrad(gmax_targets) !radiation length in %
+ REAL*4 gtarg_thick(gmax_targets) !thickness in g/cm^2
+ REAL*4 gtarg_dens(gmax_targets) !density in g/cm^3
+ REAL*4 gtarg_theta !angle of target to beam. Note that
+ !90 degrees is target normal to beam!
+ integer gtarg_type(gmax_targets) ! 1=tuna can, 2=beer can, >=21 solid tgt
+ COMMON/GEN_TARGET/
+ & gtarg_num,
+ & gtarg_theta,
+ & gtarg_mass,
+ & gtarg_z,
+ & gtarg_a,
+ & gtarg_lrad,
+ & gtarg_thick,
+ & gtarg_dens,
+ & gtarg_type
+*
+* Energy loss parameters for the targets. Vansyoc, March 98
+*
+* CTPTYPE=parm
+*
+
+
+ INTEGER gelossdebug,gen_eloss_enable
+ REAL*4 hscat_win_thk,hscat_win_den,hscat_win_a,hscat_win_z
+ REAL*4 hdet_ent_thk,hdet_ent_den,hdet_ent_a,hdet_ent_z
+ REAL*4 sscat_win_thk,sscat_win_den,sscat_win_a,sscat_win_z
+ REAL*4 sdet_ent_thk,sdet_ent_den,sdet_ent_a,sdet_ent_z
+ REAL*4 gcell_radius,gz_cell,ga_cell,gcell_den,gwall_thk,gend_thk
+ REAL*4 gfront_thk,gair_dens,gair_thk,gair_a,gair_z
+ real*4 bscat_win_thk,bscat_win_den,bscat_win_a,bscat_win_z
+ real*4 babs_thk,babs_den,babs_a,babs_z
+ real*4 bluc_thk,bluc_den,bluc_a,bluc_z
+ real*4 bfpl_thk,bfpl_den,bfpl_a,bfpl_z
+
+ COMMON/TARG_LOSS/
+ & gelossdebug,gen_eloss_enable,
+ & hscat_win_thk,hscat_win_den,hscat_win_a,hscat_win_z,
+ & hdet_ent_thk,hdet_ent_den,hdet_ent_a,hdet_ent_z,
+ & sscat_win_thk,sscat_win_den,sscat_win_a,sscat_win_z,
+ & sdet_ent_thk,sdet_ent_den,sdet_ent_a,sdet_ent_z,
+ & gcell_radius,gz_cell,ga_cell,gcell_den,gwall_thk,gend_thk,
+ & gfront_thk,gair_dens,gair_thk,gair_a,gair_z,
+ & bscat_win_thk,bscat_win_den,bscat_win_a,bscat_win_z,
+ & babs_thk,babs_den,babs_a,babs_z,
+ & bluc_thk,bluc_den,bluc_a,bluc_z,
+ & bfpl_thk,bfpl_den,bfpl_a,bfpl_z
+
+*
+* CTPTYPE=event
+*
+*
+* Hits from Uninstrumented fastbus channels
+* filled by G_decode_event_by_banks
+*
+ INTEGER GMAX_UNINST_HITS
+ PARAMETER(GMAX_UNINST_HITS=1000)
+ INTEGER*4 GUNINST_TOT_HITS
+ INTEGER*4 GUNINST_RAW_ROCSLOT(GMAX_UNINST_HITS) ! ROC*2**16 + SLOT
+ INTEGER*4 GUNINST_RAW_SUBADD(GMAX_UNINST_HITS) ! Fastbus channel
+ INTEGER*4 GUNINST_RAW_DATAWORD(GMAX_UNINST_HITS) ! Full fastbus dataword
+ COMMON/G_RAW_UNINST/
+ & GUNINST_RAW_ROCSLOT,
+ & GUNINST_RAW_SUBADD,
+ & GUNINST_RAW_DATAWORD,
+ & GUNINST_TOT_HITS
+*
+*
+* Decoded data from ADC's encoding beam position.
+* The raw data comes from the 'hmisc' detector.
+*
+*
+* CTPTYPE=event
+*
+
+ INTEGER*4 GMAX_NUM_BPMS
+ PARAMETER(GMAX_NUM_BPMS=3)
+ INTEGER*4 GNUM_BPM_SIGNALS
+ PARAMETER(GNUM_BPM_SIGNALS=4) !1=X+,2=X-,3=Y+,4=Y-
+
+ REAL*4 GBPM_ADC_PED(GNUM_BPM_SIGNALS,GMAX_NUM_BPMS)
+ REAL*4 GBPM_RAW_ADC(GNUM_BPM_SIGNALS,GMAX_NUM_BPMS)
+ REAL*4 GBPM_ADC(GNUM_BPM_SIGNALS,GMAX_NUM_BPMS)
+ REAL*4 GBPM_XPRIME(GMAX_NUM_BPMS)
+ REAL*4 GBPM_YPRIME(GMAX_NUM_BPMS)
+ REAL*4 GBPM_X(GMAX_NUM_BPMS)
+ REAL*4 GBPM_Y(GMAX_NUM_BPMS)
+ REAL*4 GBPM_MEANX(GMAX_NUM_BPMS)
+ REAL*4 GBPM_MEANY(GMAX_NUM_BPMS)
+ REAL*4 GBPM_BEAM_X,GBPM_BEAM_XP
+ REAL*4 GBPM_BEAM_Y,GBPM_BEAM_YP
+*
+* CTPTYPE=parm
+*
+ real*4 GBPM_KAPPA(GMAX_NUM_BPMS)
+ real*4 GBPM_ALPHA_X(GMAX_NUM_BPMS),GBPM_ALPHA_Y(GMAX_NUM_BPMS)
+ real*4 GBPM_X_OFF(GMAX_NUM_BPMS),GBPM_Y_OFF(GMAX_NUM_BPMS)
+ real*4 GBPM_XP_PED(GMAX_NUM_BPMS),GBPM_XM_PED(GMAX_NUM_BPMS)
+ real*4 GBPM_YP_PED(GMAX_NUM_BPMS),GBPM_YM_PED(GMAX_NUM_BPMS)
+ real*4 GBPM_ZPOS(GMAX_NUM_BPMS)
+ integer*4 GBPM_SAMPLE,GBPM_SAMPLE_MAX
+ integer*4 GUSE_BPM_IN_RECON
+ integer*4 GUSE_BPMC
+ parameter(GBPM_SAMPLE_MAX=5000)
+
+ COMMON/COIN_DEC_BPM/
+ & GBPM_ADC_PED,
+ & GBPM_RAW_ADC,
+ & GBPM_ADC,
+ & GBPM_XPRIME,
+ & GBPM_YPRIME,
+ & GBPM_X,
+ & GBPM_Y,
+ & GBPM_MEANX,
+ & GBPM_MEANY,
+ & GBPM_BEAM_X,
+ & GBPM_BEAM_XP,
+ & GBPM_BEAM_Y,
+ & GBPM_BEAM_YP,
+ & GBPM_KAPPA,
+ & GBPM_ALPHA_X,GBPM_ALPHA_Y,
+ & GBPM_X_OFF,GBPM_Y_OFF,
+ & GBPM_XP_PED,GBPM_XM_PED,GBPM_YP_PED,GBPM_YM_PED,
+ & GBPM_ZPOS,
+ & GBPM_SAMPLE,
+ & GUSE_BPM_IN_RECON,
+ & GUSE_BPMC
+
+* Decoded data from ADC's encoding fast/slow raster position (FR/SR).
+* The raw data comes from the 'hmisc' detector.
+* The CBEAM variables are final beam positions from raster and bpm signals.
+
+* CTPTYPE=event
+
+ REAL*4 GFRX_ADC_PED,GFRY_ADC_PED
+ REAL*4 GFRX_RAW_ADC,GFRY_RAW_ADC
+ REAL*4 GFRX_ADC,GFRY_ADC
+ REAL*4 GFRX_SYNC,GFRY_SYNC
+ REAL*4 GFRX_SYNC_MEAN,GFRY_SYNC_MEAN
+ REAL*4 GFRX,GFRY
+ REAL*4 GFRXP,GFRYP
+* SLOW Raster PART as read by HMS
+ REAL*4 GSRX_ADC_PED,GSRY_ADC_PED
+ REAL*4 GSRX_RAW_ADC,GSRY_RAW_ADC
+ REAL*4 GSRX_SYNC,GSRY_SYNC
+* SLOW Raster PART as read by BETA
+ REAL*4 GSRX_ADC_PED2,GSRY_ADC_PED2
+ REAL*4 GSRX_RAW_ADC2,GSRY_RAW_ADC2
+ REAL*4 GSRX_SYNC2,GSRY_SYNC2
+ REAL*4 GSRX_ADC,GSRY_ADC
+ REAL*4 GSRX_CALIB,GSRY_CALIB
+ REAL*4 GSR_beamx,GSR_beamy
+
+*
+* CTPTYPE=parm
+*
+ INTEGER*4 GUSEFR,GUSE_FRDEFAULT
+ REAL*4 GFR_CAL_MOM
+ REAL*4 GFRX_ADCPERCM,GFRY_ADCPERCM
+ REAL*4 GFRX_ADCMAX,GFRX_MAXSIZE
+ REAL*4 GFRY_ADCMAX,GFRY_MAXSIZE
+ REAL*4 GFRX_DPHASE,GFRX_SYNCCUT
+ REAL*4 GFRY_DPHASE,GFRY_SYNCCUT
+ REAL*4 GFRX_DIST,GFRY_DIST
+
+ REAL*4 GBEAM_XOFF,GBEAM_XPOFF
+ REAL*4 GBEAM_YOFF,GBEAM_YPOFF
+ REAL*4 GSPEC_XOFF,GSPEC_XPOFF
+ REAL*4 GSPEC_YOFF,GSPEC_YPOFF
+
+ COMMON/COIN_DEC_RASTER/
+ & GFRX_ADC_PED,GFRY_ADC_PED,
+ & GFRX_RAW_ADC,GFRY_RAW_ADC,
+ & GFRX_ADC,GFRY_ADC,
+ & GFRX,GFRY,
+ & GFRX_SYNC,GFRY_SYNC,
+ & GFRX_SYNC_MEAN,GFRY_SYNC_MEAN,
+ & GFRXP,GFRYP,
+ & GUSEFR,GUSE_FRDEFAULT,
+ & GFR_CAL_MOM,
+ & GFRX_ADCPERCM,GFRY_ADCPERCM,
+ & GFRX_ADCMAX,GFRX_MAXSIZE,
+ & GFRY_ADCMAX,GFRY_MAXSIZE,
+ & GFRX_DPHASE,GFRX_SYNCCUT,
+ & GFRY_DPHASE,GFRY_SYNCCUT,
+ & GFRX_DIST,GFRY_DIST,
+ & GBEAM_XOFF,GBEAM_XPOFF,
+ & GBEAM_YOFF,GBEAM_YPOFF,
+ & GSPEC_XOFF,GSPEC_XPOFF,
+ & GSPEC_YOFF,GSPEC_YPOFF,
+ & GSRX_RAW_ADC,GSRY_RAW_ADC, ! SLOW raster part
+ & GSRX_SYNC,GSRY_SYNC,
+ & GSRX_RAW_ADC2,GSRY_RAW_ADC2, ! SLOW raster 2
+ & GSRX_SYNC2,GSRY_SYNC2,
+ & GSRX_ADC_PED,GSRY_ADC_PED,
+ & GSRX_ADC_PED2,GSRY_ADC_PED2,
+ & GSRX_ADC,GSRY_ADC,
+ & GSRX_CALIB,GSRY_CALIB,
+ & GSR_BEAMX,GSR_BEAMY
+*
+*
+* TRIGGER TIMING
+*
+*
+ real*4 T_trgHMS, T_trgBIG, T_trgPI0, T_trgBETA, T_trgCOIN1,T_trgCOIN2
+ COMMON /TRIGGERTIME/T_trgHMS, T_trgBIG, T_trgPI0, T_trgBETA, T_trgCOIN1,T_trgCOIN2
+*
+*
+*
+*
+* ! B E A M P O S I T I O N -- S E M
+*
+* CTPTYPE=parm
+ integer slow_raster_correction ! STATUS of correction
+ real*4 n_sr_size
+ real*4 n_sr_slopex
+ real*4 n_sr_offsetx
+ real*4 n_sr_slopey
+ real*4 n_sr_offsety
+ real*4 n_sr_adcy_zero
+ real*4 n_sr_adcx_zero
+
+ common /n_raster_calib/
+ & slow_raster_correction,n_sr_size,
+ & n_sr_slopex,
+ & n_sr_offsetx,
+ & n_sr_slopey,
+ & n_sr_offsety,n_sr_adcy_zero,n_sr_adcx_zero
+
+ real*4 n_fr_size
+ real*4 n_fr_slopex
+ real*4 n_fr_offsetx
+ real*4 n_fr_slopey
+ real*4 n_fr_offsety
+ real*4 n_fr_adcy_zero
+ real*4 n_fr_adcx_zero
+ common /n_fraster_calib/
+ & n_fr_size,
+ & n_fr_slopex,
+ & n_fr_offsetx,
+ & n_fr_slopey,
+ & n_fr_offsety,n_fr_adcy_zero,n_fr_adcx_zero
+
+
+
+*
+* Misc. signals read out for hms AND sos events. Mostly
+* beamline information: BPMs, BLMs, Fast Raster, slow raster, ...
+*
+*
+* CTPTYPE=parm
+*
+ INTEGER GMAX_MISC_HITS
+ PARAMETER(GMAX_MISC_HITS=100)
+ INTEGER*4 GNUM_MISC_PLANES
+ PARAMETER(GNUM_MISC_PLANES=3)
+*
+* CTPTYPE=event
+*
+ INTEGER*4 GMISC_TOT_HITS
+ INTEGER*4 GMISC_RAW_ADDR1(GMAX_MISC_HITS) ! "Plane" (1=TDC,2=ADC)
+ INTEGER*4 GMISC_RAW_ADDR2(GMAX_MISC_HITS) ! "Counter"
+ INTEGER*4 GMISC_RAW_DATA(GMAX_MISC_HITS)
+ INTEGER*4 GMISC_DEC_DATA(GMAX_MISC_HITS,GNUM_MISC_PLANES)
+
+ COMMON/G_RAW_MISC/
+ & GMISC_TOT_HITS,
+ & GMISC_RAW_ADDR1,
+ & GMISC_RAW_ADDR2,
+ & GMISC_RAW_DATA,
+ & GMISC_DEC_DATA
+*
+*
+* MISC. PEDESTALS
+*
+*
+* CTPTYPE=event
+*
+ integer*4 gmisc_ped_sum2(gmax_misc_hits,gnum_misc_planes)
+ integer*4 gmisc_ped_sum(gmax_misc_hits,gnum_misc_planes)
+ integer*4 gmisc_ped_num(gmax_misc_hits,gnum_misc_planes)
+ integer*4 gmisc_num_ped_changes
+ integer*4 gmisc_changed_tube(gmax_misc_hits)
+ real*4 gmisc_ped_change(gmax_misc_hits)
+ real*4 gmisc_ped(gmax_misc_hits,gnum_misc_planes)
+ real*4 gmisc_ped_rms(gmax_misc_hits,gnum_misc_planes)
+ real*4 gmisc_new_ped(gmax_misc_hits,gnum_misc_planes)
+ real*4 gmisc_new_rms(gmax_misc_hits,gnum_misc_planes)
+ real*4 gmisc_new_adc_threshold(gmax_misc_hits,gnum_misc_planes)
+ real*4 gmisc_dum_adc_threshold(gmax_misc_hits,gnum_misc_planes)
+*
+* CTPTYPE=parm
+*
+ integer*4 gmisc_min_peds
+*
+ common/gen_misc_pedestals/
+ & gmisc_ped,
+ & gmisc_ped_sum2, !sum of squares
+ & gmisc_ped_sum, !sum of peds
+ & gmisc_ped_num, !number of peds
+ & gmisc_min_peds, !# of peds required to override default pedestal
+ & gmisc_ped_rms,
+ & gmisc_new_ped,
+ & gmisc_new_rms,
+ & gmisc_num_ped_changes,!# of peds with 2 sigma changes from param file
+ & gmisc_changed_tube, !list of changed tubes
+ & gmisc_ped_change, !change in pedestal
+ & gmisc_new_adc_threshold,
+ & gmisc_dum_adc_threshold
+*
+* CTPTYPE=parm
+*
+ integer*4 genable_hms_satcorr,genable_sos_satcorr
+ integer*4 genable_hms_fieldcorr,genable_sos_fieldcorr
+*
+ common/gen_satcorr/
+ & genable_hms_satcorr,genable_sos_satcorr,
+ & genable_hms_fieldcorr,genable_sos_fieldcorr
+*
+*
+*******************end: gen_data_structures.cmn*************************
+* Local Variables:
+* mode: fortran
+* fortran-continuation-string: "&"
+* comment-column: 35
+* End:
diff --git a/INCLUDE/gen_decode_F1tdc.cmn b/INCLUDE/gen_decode_F1tdc.cmn
new file mode 100644
index 0000000..526db00
--- /dev/null
+++ b/INCLUDE/gen_decode_F1tdc.cmn
@@ -0,0 +1,27 @@
+* frw 4/2007
+*
+* specifics for F1 TDC that are independent of detector
+*
+*%% include 'gen_detectorids.par'
+*%% include 'gen_decode_common.cmn'
+*
+*
+* CTPTYPE=parm
+*
+ INTEGER*4 G_F1_MULTIHIT
+ Parameter(G_F1_MULTIHIT=8)
+*
+ INTEGER*4 ESCIN_F1TDC_MODE(0:G_DECODE_MAXROCS)
+ INTEGER*4 F1TDC_WINDOW_SIZE(0:G_DECODE_MAXROCS) !in counts NOT ns !!
+
+ Common/GEN_F1TDC/
+ & ESCIN_F1TDC_MODE,
+ & F1TDC_WINDOW_SIZE
+
+*
+* CTPTYPE=event
+*
+
+* Local Variables:
+* mode: fortran
+* End:
diff --git a/INCLUDE/gen_decode_common.cmn b/INCLUDE/gen_decode_common.cmn
new file mode 100644
index 0000000..c5e78fe
--- /dev/null
+++ b/INCLUDE/gen_decode_common.cmn
@@ -0,0 +1,101 @@
+*
+* Common block that contains the mapping of physical fastbus locations
+* to logical detector identification.
+*
+* $Log: gen_decode_common.cmn,v $
+* Revision 1.4.24.7 2007/09/11 19:14:18 frw
+* fixed FPP related arrays and limits
+*
+* Revision 1.4.24.6 2007/09/10 21:18:13 frw
+* fixed FPP related arrays and limits
+*
+* Revision 1.4.24.5 2007/09/07 21:55:07 puckett
+* increased maxplanes, maxcounters to 999,changed range of index 4 of array g_decode_roc
+*
+* Revision 1.4.24.4 2007/08/27 20:24:42 puckett
+* Increased "max planes" from 15 to 56
+*
+* Revision 1.4.24.3 2007/08/22 19:09:31 frw
+* added FPP
+*
+* Revision 1.5 4/2007 frw
+* added flag to identify module type in VME bins -- unused for FastBus
+*
+* Revision 1.4.24.2 2007/06/04 15:11:23 puckett
+* changed hit array structure for trigger-related signals
+*
+* Revision 1.4.24.1 2007/05/15 02:53:02 jones
+* Start to Bigcal code
+*
+* Revision 1.4 1996/01/17 15:40:59 cdaq
+* (SAW) Change roc index in arrays to start at zero.
+* (JRA) Add structures needed to produce adc threshold setting files.
+*
+* Revision 1.3 1994/10/20 12:26:44 cdaq
+* (JRA) Increate G_DECODE_MAXROCS from 8 to 9
+*
+* Revision 1.2 1994/04/05 14:31:10 cdaq
+* Add g_decode_subaddbit for location in FB word of sub address
+*
+* Revision 1.1 1994/02/07 19:36:23 cdaq
+* Initial revision
+*
+*%% include 'gen_detectorids.par'
+*
+ integer G_DECODE_MAXWORDS ! Must exceed number of
+ parameter (G_DECODE_MAXWORDS=10000) ! installed FB channels
+ integer G_DECODE_MAXROCS
+ parameter (G_DECODE_MAXROCS=15) ! Largest ROC # + 1
+ integer G_DECODE_MAXSLOTS
+ parameter (G_DECODE_MAXSLOTS=25) ! # slots in a FB crate
+
+ integer G_DECODE_MAXPLANES
+ parameter (G_DECODE_MAXPLANES=99) ! Largest plane #
+ integer G_DECODE_MAXCOUNTERS
+ parameter (G_DECODE_MAXCOUNTERS=999) ! Largest counter #
+ integer G_DECODE_MAXSIGNALS
+ parameter (G_DECODE_MAXSIGNALS=3) ! Largest signal #
+
+ integer*4 g_decode_slotpointer ! Pointer into map arrays
+ integer*4 g_decode_subaddcnt ! Number of subadds per slot
+ integer*4 g_decode_subaddbit ! bit shift to get subadd
+ integer*4 g_decode_modtyp ! flag to identify module type
+ integer*4 g_decode_slotmask
+ integer*4 g_decode_didmap
+ integer*4 g_decode_planemap, g_decode_countermap
+ integer*4 g_decode_sigtypmap
+ integer*4 g_decode_nextpointer ! Next free in map arrays
+ integer*4 g_decode_roc
+ common /UPCOMMON/
+ $ g_decode_slotpointer(0:G_DECODE_MAXROCS, G_DECODE_MAXSLOTS),
+ $ g_decode_subaddcnt(0:G_DECODE_MAXROCS,G_DECODE_MAXSLOTS),
+ $ g_decode_subaddbit(0:G_DECODE_MAXROCS,G_DECODE_MAXSLOTS),
+ $ g_decode_slotmask(0:G_DECODE_MAXROCS,G_DECODE_MAXSLOTS),
+ $ g_decode_didmap(G_DECODE_MAXWORDS),
+ $ g_decode_planemap(G_DECODE_MAXWORDS),
+ $ g_decode_countermap(G_DECODE_MAXWORDS),
+ $ g_decode_sigtypmap(G_DECODE_MAXWORDS),
+ $ g_decode_nextpointer,
+ $ g_decode_modtyp(0:G_DECODE_MAXROCS,G_DECODE_MAXSLOTS),
+ $ g_decode_roc(0:MAXID,G_DECODE_MAXPLANES,
+ $ G_DECODE_MAXCOUNTERS,0:G_DECODE_MAXSIGNALS)
+
+ integer*4 gmax_roc_with_adc
+ integer*4 gmax_slot_with_adc
+ integer*4 gnum_adc_channels
+ parameter (gmax_roc_with_adc=12)
+ parameter (gmax_slot_with_adc=22)
+ parameter (gnum_adc_channels=64)
+
+* use slot,roc so that g_threshold_readback(1,3,7) >>> thresholds(*) gives
+* the thresholds(1-64) = the 64 thresholds in roc3,slot7.
+
+ integer*4 g_threshold_readback(gnum_adc_channels,
+ & gmax_roc_with_adc,gmax_slot_with_adc)
+
+ common/gen_threshold_check/
+ & g_threshold_readback
+
+* Local Variables:
+* mode: fortran
+* End:
diff --git a/INCLUDE/gen_detectorids.par b/INCLUDE/gen_detectorids.par
new file mode 100644
index 0000000..b4c22ce
--- /dev/null
+++ b/INCLUDE/gen_detectorids.par
@@ -0,0 +1,107 @@
+*
+* detectorids.inc
+*
+* It would be nice if the data file that set's up the unpacker could
+* use symbolic names instead of numbers.
+*
+* Revision 1.9 2007/01/09 13:28 puckett
+* Added new detector ids for BigCal
+*
+* $Log: gen_detectorids.par,v $
+* Revision 1.8.24.3.2.4 2009/01/30 20:33:28 cdaq
+* *** empty log message ***
+*
+* Revision 1.8.24.3.2.3 2008/10/25 12:45:30 cdaq
+* *** empty log message ***
+*
+* Revision 1.8.24.3.2.2 2008/10/02 18:01:48 cdaq
+* *** empty log message ***
+*
+* Revision 1.8.24.3.2.1 2008/05/15 19:04:32 bhovik
+* 1'st version
+*
+* Revision 1.8.24.3 2007/08/27 17:05:58 frw
+* clean replay for GEp-III
+*
+* Revision 1.8.24.2 2007/06/04 15:11:23 puckett
+* changed hit array structure for trigger-related signals
+*
+* Revision 1.8.24.1 2007/05/15 02:53:03 jones
+* Start to Bigcal code
+*
+* Revision 1.8 2002/12/20 21:52:34 jones
+* Modified by Hamlet for new HMS aerogel
+*
+* Revision 1.8 2002/09/26
+* (Hamlet) Add HAERO_ID=18 for HMS Aerogel
+*
+* Revision 1.7 1996/11/08 21:20:05 saw
+* (WH) Add Lucite counter detector ID
+*
+* Revision 1.6 1996/01/24 16:26:08 saw
+* (JRA) Change CBPM_D to GMISC_ID
+*
+* Revision 1.5 1995/05/22 19:13:41 cdaq
+* (SAW) Add Aerogel detector id
+*
+* Revision 1.4 1995/04/06 20:31:38 cdaq
+* (SAW) Add BPM id
+*
+* Revision 1.3 1994/06/18 02:50:30 cdaq
+* (SAW) Add code for miscleaneous data and uninstrumented channels and
+* change name to gen_detectorids.par (was gen_detectorids.cmn)
+*
+* Revision 1.2 1994/04/11 15:11:25 cdaq
+* (SAW) Add uninstrumented channel "detector" id
+*
+* Revision 1.1 1994/02/07 19:37:01 cdaq
+* Initial revision
+*
+*
+ integer MAXID, UNINST_ID, HDC_ID, HSCIN_ID, HCER_ID, HCAL_ID, HMISC_ID,
+ $ GMISC_ID, SDC_ID, SSCIN_ID, SCER_ID, SCAL_ID, SMISC_ID, SAER_ID,
+ $ SLUC_ID, HAERO_ID, BIGCAL_PROT_ID, BIGCAL_RCS_ID,
+ $ BIGCAL_TDC_ID, BIGCAL_ATRIG_ID, BIGCAL_TTRIG_ID, HFPP_ID,
+ $ LUCITE_SANE_ID,LUCITE_SANE_ID2,LUCITE_SANE_ID3,
+ $ CERENKOV_SANE_ID,CERENKOV_SANE_ID2,TRACKER_SANE_X_ID,
+ $ TRACKER_SANE_Y_ID, F1TRIGGER_ID, SEM_ID
+
+ parameter (MAXID=40)
+ parameter (UNINST_ID=0) ! Uninstrumented channels
+ parameter (HDC_ID=1)
+ parameter (HSCIN_ID=2)
+ parameter (HCER_ID=3)
+ parameter (HCAL_ID=4)
+ parameter (HMISC_ID=5) ! Misclaneous FB channels
+ parameter (GMISC_ID=6) ! BPM/Raster data
+ parameter (HAERO_ID=7)
+ parameter (HFPP_ID=20) ! Focal Plane Polarimeter
+
+ parameter (TRACKER_SANE_X_ID=21) ! SANE X Tracker DETECTOR
+ parameter (TRACKER_SANE_Y_ID=22) ! SANE Y Tracker DETECTOR
+ parameter (CERENKOV_SANE_ID=23) ! SANE CERENKOV DETECTOR
+ parameter (CERENKOV_SANE_ID2=32) ! SANE CERENKOV DETECTOR TDC
+ parameter (LUCITE_SANE_ID=24) ! SANE LUCITE DETECTOR ADC
+ parameter (LUCITE_SANE_ID2=30) ! SANE LUCITE DETECTOR TDCPOS
+ parameter (LUCITE_SANE_ID3=31) ! SANE LUCITE DETECTOR TDCNEG
+
+ parameter (F1TRIGGER_ID=25) ! F1 TRIGGER
+ parameter (SEM_ID=26) ! SEM Detector
+cajp
+ parameter (BIGCAL_PROT_ID=8) ! protvino glass ADCs
+ parameter (BIGCAL_RCS_ID=9) ! RCS glass ADCs
+ parameter (BIGCAL_TDC_ID=10) ! groups of 8 TDCs
+ parameter (BIGCAL_ATRIG_ID=18) ! groups of 64 ADC and TDC
+ parameter (BIGCAL_TTRIG_ID=19)
+cajp
+ parameter (SDC_ID=11)
+ parameter (SSCIN_ID=12)
+ parameter (SCER_ID=13)
+ parameter (SCAL_ID=14)
+ parameter (SMISC_ID=15) ! Miscilaneous FB channels
+ parameter (SAER_ID=16)
+ parameter (SLUC_ID=17)
+
+* Local Variables:
+* mode: fortran
+* End:
diff --git a/INCLUDE/gen_epics.cmn b/INCLUDE/gen_epics.cmn
new file mode 100644
index 0000000..4938f20
--- /dev/null
+++ b/INCLUDE/gen_epics.cmn
@@ -0,0 +1,22 @@
+* This include file contains all the epics extracted variables,
+* which should be parsed to the engine for further use.
+*
+* $Log: gen_epics.cmn,v $
+* Revision 1.1 1999/02/24 14:39:05 saw
+* Added to official source tree by csa.
+*
+*
+* CTPTYPE=event
+*
+ real*4 gepics_delta_ebeam
+ real*4 gepics_xh00a,gepics_yh00a,gepics_xh00b,gepics_yh00b
+ real*4 gepics_beam_xpos,gepics_beam_ypos
+
+ COMMON/g_epics_events/
+ & gepics_delta_ebeam,
+ & gepics_xh00a,
+ & gepics_yh00a,
+ & gepics_xh00b,
+ & gepics_yh00b,
+ & gepics_beam_xpos,
+ & gepics_beam_ypos
diff --git a/INCLUDE/gen_event_info.cmn b/INCLUDE/gen_event_info.cmn
new file mode 100644
index 0000000..96003fa
--- /dev/null
+++ b/INCLUDE/gen_event_info.cmn
@@ -0,0 +1,28 @@
+**************************begin: gen_event_info.cmn ***********************
+*-
+*- Created 22-Apr-1994 Kevin B. Beard, Hampton Univ.
+* $Log: gen_event_info.cmn,v $
+* Revision 1.2.24.1 2007/10/17 16:04:23 cdaq
+* Added trig type array to hold trigger type information from TS
+*
+* Revision 1.2 1994/08/03 20:10:42 cdaq
+* (SAW) Add "CTPTYPE=event" directive for auto generation of CTP reg calls
+*
+* Revision 1.1 1994/05/27 15:12:28 cdaq
+* Initial revision
+*
+*........................................................................
+*- Misc. info. about a run
+*
+* CTPTYPE=event
+*
+ INTEGER gen_event_ID_number,gen_event_type,gen_event_class
+ INTEGER gen_event_ROC_summary
+ INTEGER gen_event_sequence_N
+ INTEGER gen_event_trigtype(12) ! trigger type from trigger supervisor
+*
+ COMMON /gen_event_info/ gen_event_ID_number,gen_event_type,
+ & gen_event_class,gen_event_ROC_summary,
+ & gen_event_sequence_N,gen_event_trigtype
+*
+****************************end: gen_event_info.cmn ***********************
diff --git a/INCLUDE/gen_filenames.cmn b/INCLUDE/gen_filenames.cmn
new file mode 100644
index 0000000..1f63561
--- /dev/null
+++ b/INCLUDE/gen_filenames.cmn
@@ -0,0 +1,156 @@
+******************* begin: gen_filenames.cmn ***********************
+*
+*-Common block with filenames
+* $Log: gen_filenames.cmn,v $
+* Revision 1.14 2003/09/05 20:10:27 jones
+* Merge in online03 changes (mkj)
+*
+* Revision 1.13.2.2 2003/08/14 16:13:15 cdaq
+* Corrected mistake in setting G_LUN_WRITEOUT_SCALER ( mkj)
+*
+* Revision 1.13.2.1 2003/08/14 00:44:13 cdaq
+* Modify to be able to write scaler rates for each read to a file (mkj)
+*
+* Revision 1.13 2002/09/25 13:54:16 jones
+* a. change g_data_source_filename to character*120
+* b. add variable g_segment
+*
+* Revision 1.12 1996/11/19 18:13:44 saw
+* (SAW) Add some filenames and variables for LUN's
+*
+* Revision 1.11 1996/09/04 15:48:00 saw
+* (JRA) Add flags for writting out preproccesd (filtered) events
+*
+* Revision 1.10 1996/04/30 13:37:06 saw
+* (JRA) Add filename for pedestal output
+*
+* Revision 1.9 1996/01/17 15:41:50 cdaq
+* (JRA) Add filename/ctp names for tcl statistics screen
+*
+* Revision 1.8 1995/09/01 13:01:16 cdaq
+* (JRA) Add a file for run number based CTP parameter (kinematics) settings
+*
+* Revision 1.7 1995/07/28 14:25:59 cdaq
+* (SAW) Add g_ctp_database_filename
+*
+* Revision 1.6 1994/10/19 19:52:22 cdaq
+* (SAW) Add g_label variable for labels on reports
+*
+* Revision 1.5 1994/08/03 20:06:50 cdaq
+* (SAW) Add "CTPTYPE=parm" directive for auto generation of CTP reg calls
+*
+* Revision 1.4 1994/06/21 15:05:11 cdaq
+* (SAW) Add g_report_rebook flag
+*
+* Revision 1.3 1994/06/15 18:12:17 cdaq
+* (SAW) Add variables for report generator
+*
+* Revision 1.2 1994/03/24 16:49:57 cdaq
+* (SAW) Make logical's logical*4 so they can be registered to CTP
+*
+* Revision 1.1 1994/02/07 19:38:11 cdaq
+* Initial revision
+*
+* CTPTYPE=parm
+*
+ integer G_LUN_CONFIG
+ parameter (G_LUN_CONFIG= 55)
+*
+ integer G_LUN_TEMP
+ parameter (G_LUN_TEMP= G_LUN_CONFIG+1)
+*
+ integer G_LUN_CHARGE_SCALER
+ parameter (G_LUN_CHARGE_SCALER=G_LUN_TEMP+1)
+*
+ integer G_LUN_EPICS_OUTPUT
+ parameter (G_LUN_EPICS_OUTPUT=G_LUN_CHARGE_SCALER+1)
+*
+ integer G_LUN_WRITEOUT_SCALER
+ parameter (G_LUN_WRITEOUT_SCALER=G_LUN_EPICS_OUTPUT+1)
+*
+
+ character*80 g_config_filename
+ character*80 g_ctp_hist_filename
+ character*80 g_ctp_test_filename
+ character*80 g_ctp_parm_filename
+ character*120 g_data_source_filename ! Coda/other input file
+ character*80 g_alias_filename ! PAW histogram name aliases
+ character*80 g_histout_filename ! File to write histograms to
+ character*80 g_decode_map_filename ! File containing unpack map
+ character*80 g_report_template_filename
+ character*80 g_report_output_filename
+ character*80 g_report_blockname
+ character*80 g_label ! A string that can label reports, etc
+ character*80 g_ctp_database_filename ! Run number dependent variables
+ character*80 g_ctp_kinematics_filename ! Run number dependent variables
+ character*80 g_stats_template_filename !online statistics report
+ character*80 g_stats_output_filename
+ character*80 g_stats_blockname
+ character*80 g_pedestal_output_filename
+ character*80 g_bad_output_filename
+ character*80 g_preproc_filename
+ character*80 g_charge_scaler_filename
+ character*80 g_writeout_scaler_filename
+ character*80 g_epics_output_filename
+*
+ common /gen_filenames/
+ $ g_config_filename,
+ $ g_ctp_hist_filename,
+ $ g_ctp_test_filename,
+ $ g_ctp_parm_filename,
+ $ g_data_source_filename,
+ $ g_alias_filename,
+ $ g_histout_filename,
+ $ g_decode_map_filename,
+ $ g_report_template_filename,
+ $ g_report_output_filename,
+ $ g_report_blockname,
+ $ g_label,
+ $ g_ctp_database_filename,
+ $ g_ctp_kinematics_filename,
+ $ g_stats_template_filename,
+ $ g_stats_output_filename,
+ $ g_stats_blockname,
+ $ g_pedestal_output_filename,
+ $ g_bad_output_filename,
+ $ g_preproc_filename,
+ $ g_writeout_scaler_filename,
+ $ g_charge_scaler_filename,
+ $ g_epics_output_filename
+
+*
+ logical*4 g_hist_rebook
+ logical*4 g_test_rebook
+ logical*4 g_parm_rebook
+ logical*4 g_report_rebook
+*
+ logical*4 g_config_loaded !Make sure this is false first time
+ logical*4 g_data_source_opened !whether FASTBUS CODA file opened OK
+ integer g_data_source_in_hndl !IO channel assigned by CODA library
+ integer g_max_events !quit after this number events
+ logical*4 g_preproc_opened !status of preprocessor output file opening
+ integer*4 g_preproc_in_hndl !IO channel assigned by CODA for above file
+ integer*4 g_preproc_on !flag to turn on event preprocessing
+*
+ common /gen_config_flags/
+ $ g_hist_rebook, g_test_rebook, g_parm_rebook,
+ $ g_report_rebook,
+ $ g_config_loaded,
+ $ g_data_source_opened, g_data_source_in_hndl,
+ $ g_max_events,
+ $ g_preproc_opened,
+ $ g_preproc_in_hndl,
+ $ g_preproc_on
+
+ integer*4 g_segment
+
+ common /gen_segmented_runs/
+ $ g_segment
+
+*
+* Local Variables:
+* mode: fortran
+* End:
+*
+******************** end: gen_filenames.cmn ***********************
+
diff --git a/INCLUDE/gen_input_info.cmn b/INCLUDE/gen_input_info.cmn
new file mode 100644
index 0000000..e91e02e
--- /dev/null
+++ b/INCLUDE/gen_input_info.cmn
@@ -0,0 +1,19 @@
+********************** begin: gen_input_info.cmn *****************************
+*
+* $Log: gen_input_info.cmn,v $
+* Revision 1.1 1994/02/07 19:39:25 cdaq
+* Initial revision
+*
+*
+ CHARACTER*132 G_input_file_name !file or device name
+ CHARACTER*80 G_input_file_type !ASCII, UNPACKED_CODA, ....
+ INTEGER G_input_channel !assigned by CODA, not user
+ LOGICAL G_input_OK !successfully open input
+*
+ COMMON /GEN_INPUT_INFO/ G_input_file_name,G_input_file_type,
+ & G_input_channel,G_input_OK
+*
+************************ end: gen_input_info.cmn *****************************
+* Local Variables:
+* mode: fortran
+* End:
diff --git a/INCLUDE/gen_one_ev_gckine.cmn b/INCLUDE/gen_one_ev_gckine.cmn
new file mode 100644
index 0000000..ee06435
--- /dev/null
+++ b/INCLUDE/gen_one_ev_gckine.cmn
@@ -0,0 +1,33 @@
+* gen_one_ev_gckine.cmn
+* include file for One Event Display
+*-- Original Author : Pat Welch
+*-- Most recent Author : Derek van Westrum
+* $Log: gen_one_ev_gckine.cmn,v $
+* Revision 1.1 1996/01/17 15:43:35 cdaq
+* Initial revision
+*
+*
+* since I normally use implicit none I'll need to type what is here.
+*
+
+c GCKINE common block as described in the GEANT manual on page BASE 030-4
+
+ integer ikine ! Number of user kinematic parameters
+ real pkine ! user kinematic parameters
+ integer itra ! Current track number
+ integer istak ! Current stack-track number
+ integer ivert ! Current vertex number
+ integer ipart ! current particle number
+ integer itrtyp ! tracking type of current particle
+ integer napart ! name of current particle
+ real amass ! mass of current particle in AMU
+ real charge ! charge of current particle in |e|
+ real tlife ! life-time of current particle
+ real vert ! vertex coordinates for current track
+ real pvert ! track kinematic at origin
+ integer ipaold ! particle number of the last track
+
+ COMMON/GCKINE/IKINE,PKINE(10),ITRA,ISTAK,IVERT,IPART,ITRTYP
+ + ,NAPART(5),AMASS,CHARGE,TLIFE,VERT(3),PVERT(4),IPAOLD
+C
+
diff --git a/INCLUDE/gen_one_ev_gctrak.cmn b/INCLUDE/gen_one_ev_gctrak.cmn
new file mode 100644
index 0000000..4709d08
--- /dev/null
+++ b/INCLUDE/gen_one_ev_gctrak.cmn
@@ -0,0 +1,69 @@
+* gen_one_ev_gctrak.cmn
+* include file for One Event Display
+*-- Original Author : Pat Welch
+*-- Most recent Author : Derek van Westrum
+* $Log: gen_one_ev_gctrak.cmn,v $
+* Revision 1.1 1996/01/17 15:44:19 cdaq
+* Initial revision
+*
+*
+* since I normally use implicit none I'll need to type what is here.
+*
+
+c This common block is described in the GEANT manual on page BASE 030-10
+
+c integer MAXMEC ! maximum number of mechanisms
+c real vect ! curreent track params (x,y,z,px/p,py/p,pz/p,p)
+c real getot ! Current track total energy
+c real gekin ! current track kinetic energy
+c real vout ! same as vect after extrapolation (i.e. at end of step)
+c integer nmec ! Number of mechanisms for current step
+c integer lmec ! list of mechanism indices for current step
+c character*4 namec! list of names for the current mechanisms
+c integer nstep ! Number of steps so far
+c integer maxnst ! Maximum number of steps allowed
+c real destep ! total energy lost in this step
+c real destel ! step length
+c real safety ! Overestimated distance to closest medium boundary
+c real sleng ! track length at current point
+c real step ! size of current tracking step
+c real snext ! straight distance to next current medium boundary
+c real sfield ! field turning angle step size evaluation
+c real tofg ! current time of flight
+c real gekrat ! Interpolation factor in table ELOW
+c real upwght ! ?
+c integer ignext ! Flag set to 1 when SNEXT has to be recomputed
+c integer inwvol ! Flag set to 1 when enetering a volume,
+c ! 2 when leaving a volume, and
+c ! 3 when leaving the experimental setup
+c integer istop ! Flag set to 1 when track looses its identiy,
+c ! 2 when energy below cut
+c integer igauto ! ?
+c integer iekbin ! Current kinetic energy bin in table ELOW
+c integer ilosl ! ?
+c integer imull ! ?
+c integer ingoto ! ?
+c integer nldown ! ?
+c integer nlevin ! ?
+c integer nlvsav ! ?
+c integer istory ! ?
+c integer MAXME1 ! ?
+c real polar
+c integer namec1
+
+ INTEGER NMEC,LMEC,NAMEC,NSTEP ,MAXNST,IGNEXT,INWVOL,ISTOP,MAXMEC
+ + ,IGAUTO,IEKBIN,ILOSL, IMULL,INGOTO,NLDOWN,NLEVIN,NLVSAV,ISTORY
+ + ,MAXME1,NAMEC1
+ REAL VECT,GETOT,GEKIN,VOUT,DESTEP,DESTEL,SAFETY,SLENG ,STEP
+ + ,SNEXT,SFIELD,TOFG ,GEKRAT,UPWGHT
+ REAL POLAR
+ PARAMETER (MAXMEC=30)
+ COMMON/GCTRAK/VECT(7),GETOT,GEKIN,VOUT(7),NMEC,LMEC(MAXMEC)
+ + ,NAMEC(MAXMEC),NSTEP ,MAXNST,DESTEP,DESTEL,SAFETY,SLENG
+ + ,STEP ,SNEXT ,SFIELD,TOFG ,GEKRAT,UPWGHT,IGNEXT,INWVOL
+ + ,ISTOP ,IGAUTO,IEKBIN, ILOSL, IMULL,INGOTO,NLDOWN,NLEVIN
+ + ,NLVSAV,ISTORY
+ PARAMETER (MAXME1=30)
+ COMMON/GCTPOL/POLAR(3), NAMEC1(MAXME1)
+C
+
diff --git a/INCLUDE/gen_one_ev_gcvolu.cmn b/INCLUDE/gen_one_ev_gcvolu.cmn
new file mode 100644
index 0000000..2035d00
--- /dev/null
+++ b/INCLUDE/gen_one_ev_gcvolu.cmn
@@ -0,0 +1,36 @@
+* gen_one_ev_gcvolu.cmn
+* include file for One Event Display
+*-- Original Author : Pat Welch
+*-- Most recent Author : Derek van Westrum
+* $Log: gen_one_ev_gcvolu.cmn,v $
+* Revision 1.1 1996/01/17 15:44:43 cdaq
+* Initial revision
+*
+*
+* since I normally use implicit none I'll need to type what is here.
+*
+
+c This common block is described in the GEANT manual on page BASE 030-11
+
+c integer nlevel ! # at which the last medium search stopped
+c character*4 names ! Volume names at each level
+c integer number ! User volume numbers at each level
+c integer lvolum ! System volume numbers at each level
+c integer lindex ! Physical tree volume indices at each level
+c integer infrom ! ?
+c integer nlevmx ! ?
+c integer nldev ! ?
+c integer linmx ! ?
+c real gtran ! (x,y,z) offsets of the cumulative coord xforms
+c real grmat ! Rotation matrix elements for cumulative xforms
+c real gonly ! uniqueness flags at each level
+c real glx ! current poin in local coordinates system
+
+ INTEGER NLEVEL,NAMES,NUMBER,LVOLUM,LINDEX,INFROM,NLEVMX,
+ + NLDEV,LINMX
+ REAL GTRAN,GRMAT,GONLY,GLX
+ COMMON/GCVOLU/NLEVEL,NAMES(15),NUMBER(15),
+ +LVOLUM(15),LINDEX(15),INFROM,NLEVMX,NLDEV(15),LINMX(15),
+ +GTRAN(3,15),GRMAT(10,15),GONLY(15),GLX(3)
+C
+
diff --git a/INCLUDE/gen_one_ev_info.cmn b/INCLUDE/gen_one_ev_info.cmn
new file mode 100644
index 0000000..f4f8fd7
--- /dev/null
+++ b/INCLUDE/gen_one_ev_info.cmn
@@ -0,0 +1,55 @@
+**************************begin: gen_one_ev_info.cmn ***********************
+*-
+*- Created 4-Sep-1994 Kevin B. Beard, Hampton Univ.
+*........................................................................
+*- Misc. info. needed for remote display
+*
+* $Log: gen_one_ev_info.cmn,v $
+* Revision 1.1 1995/09/18 20:22:39 cdaq
+* Initial revision
+*
+*
+ INTEGER gen_display_server_RPCprgmID
+ INTEGER gen_display_server_RPCversionID
+ CHARACTER*80 gen_display_server_machine
+ INTEGER gen_display_RPCclientID
+ INTEGER gen_display_everything
+ INTEGER gen_display_event_info
+ INTEGER gen_display_device
+ INTEGER gen_display_wait_events
+ INTEGER gen_display_wait_seconds
+ CHARACTER*132 gen_display_interesting
+*
+ COMMON /gen_display_info/ gen_display_server_RPCprgmID,
+ & gen_display_server_RPCversionID,
+ & gen_display_server_machine,
+ & gen_display_RPCclientID,
+ & gen_display_everything,gen_display_event_info,
+ & gen_display_device,gen_display_wait_events,
+ & gen_display_wait_seconds,gen_display_interesting
+*
+
+* CTPTYPE=parm
+*
+ integer*4 ONE_EV,GRAPH_IO_DEV
+*
+* parameter (ONE_EV = -1)
+* parameter (GRAPH_IO_DEV = 1)
+*
+ common/one_ev_io/ ONE_EV,GRAPH_IO_DEV
+*
+* CERN lib stuff
+*
+ integer NGBANK ! size of GCBANK common block
+ parameter (NGBANK = 1000000)
+
+ integer NHBOOK ! size of PAWC common block
+ parameter (NHBOOK = 1000000)
+
+ REAL GCworking(NGBANK) ! GCBANK memory
+ COMMON /GCBANK/ GCworking
+*
+ REAL HBOOKworking(NGBANK) ! PAWC memory
+ COMMON /PAWC/ HBOOKworking
+
+****************************end: gen_display_info.cmn ***********************
diff --git a/INCLUDE/gen_one_ev_info.dte b/INCLUDE/gen_one_ev_info.dte
new file mode 100644
index 0000000..cd221e0
--- /dev/null
+++ b/INCLUDE/gen_one_ev_info.dte
@@ -0,0 +1,21 @@
+* gen_one_ev_info.dte
+* include file for One Event Display
+*-- Original Author : Kevin B. Beard, Hampton Univ.
+*-- Most recent Author : Derek van Westrum
+* $Log: gen_one_ev_info.dte,v $
+* Revision 1.1 1996/01/17 15:46:04 cdaq
+* Initial revision
+*
+*........................................................................
+*- Misc. info. needed for remote display
+*
+ DATA gen_display_RPCclientID/0/
+ DATA gen_display_server_RPCprgmID/0/
+ DATA gen_display_server_machine/' '/
+ DATA gen_display_everything/0/ !handle#
+ DATA gen_display_event_info/0/ !handle#
+ DATA gen_display_wait_events/1000/ !give up after this many events
+ DATA gen_display_wait_seconds/100./ !give up after this time
+ DATA gen_display_interesting/'1'/ !anything is interesting
+*
+
diff --git a/INCLUDE/gen_output_info.cmn b/INCLUDE/gen_output_info.cmn
new file mode 100644
index 0000000..e7f7b64
--- /dev/null
+++ b/INCLUDE/gen_output_info.cmn
@@ -0,0 +1,19 @@
+********************* begin: gen_output_info.cmn *****************************
+* $Log: gen_output_info.cmn,v $
+* Revision 1.1 1994/02/22 20:04:11 cdaq
+* Initial revision
+*
+*
+ CHARACTER*132 G_OUTPUT_file_name !file or device name
+ CHARACTER*80 G_OUTPUT_file_type !ASCII, UNPACKED_CODA, ....
+ INTEGER G_OUTPUT_channel !assigned by CODA, not user
+ LOGICAL G_OUTPUT_OK !successfully open OUTPUT
+ INTEGER G_OUTPUT_tty !tty channel for messages
+*
+ COMMON /GEN_OUTPUT_INFO/ G_OUTPUT_file_name,G_OUTPUT_file_type,
+ & G_OUTPUT_channel,G_OUTPUT_OK,G_OUTPUT_tty
+*
+*********************** end: gen_output_info.cmn *****************************
+* Local Variables:
+* mode: fortran
+* End:
diff --git a/INCLUDE/gen_pawspace.cmn b/INCLUDE/gen_pawspace.cmn
new file mode 100644
index 0000000..092e1d3
--- /dev/null
+++ b/INCLUDE/gen_pawspace.cmn
@@ -0,0 +1,39 @@
+**************** begin: gen_pawspace.cmn **********************
+* $Log: gen_pawspace.cmn,v $
+* Revision 1.2.24.3.2.1 2009/01/16 18:48:01 cdaq
+* *** empty log message ***
+*
+* Revision 1.2.24.3 2007/12/07 21:40:33 puckett
+* doubled size of paw memory from 5000000 to 10000000. Hope this doesn't cause trouble
+*
+* Revision 1.2.24.2 2007/10/29 19:46:13 cdaq
+* Increased size of HBOOK memory from 3000000 to 5000000
+*
+* Revision 1.2.24.1 2007/09/24 20:40:23 puckett
+* Increased PAW memory to accomodate BigCal histograms for each channel
+*
+* Revision 1.2 1994/04/12 20:46:15 cdaq
+* Increase size of common to 1000000
+*
+* Revision 1.1 1994/02/07 19:41:18 cdaq
+* Initial revision
+*
+*
+*-sizes of CERNLIB working space
+*
+ INTEGER G_sizeHBOOK,G_sizeHIGZ,G_sizeKUIP,G_sizePAW
+ PARAMETER (G_sizeHBOOK= 150000000)
+ PARAMETER (G_sizeHIGZ= 100000)
+ PARAMETER (G_sizeKUIP= 120000)
+ PARAMETER (G_sizePAW=G_sizeHIGZ+G_sizeKUIP+
+ & G_sizeHBOOK+100000)
+*
+*-CERNLIB working space
+*
+ integer G_CERNmemory(G_sizePAW)
+ COMMON /PAWC/ G_CERNmemory !special nonstandard name!
+*
+**************** end: gen_pawspace.cmn **********************
+* Local Variables:
+* mode: fortran
+* End:
diff --git a/INCLUDE/gen_routines.dec b/INCLUDE/gen_routines.dec
new file mode 100644
index 0000000..b5c3408
--- /dev/null
+++ b/INCLUDE/gen_routines.dec
@@ -0,0 +1,123 @@
+**************** begin: GEN_routines.DEC ***************************
+* $Log: gen_routines.dec,v $
+* Revision 1.9 2004/07/08 18:11:52 saw
+* Add routines for manipulating ROOT trees
+*
+* Revision 1.8 1996/01/17 15:46:25 cdaq
+* (SAW) Add CTP group routines
+*
+* Revision 1.7 1994/10/18 20:34:06 cdaq
+* (SAW) Add several new CTP routines (RPC stuff)
+*
+* Revision 1.6 1994/07/21 19:49:27 cdaq
+* (SAW) Add thgethit and thgethitb
+*
+* Revision 1.5 1994/06/22 21:03:51 cdaq
+* (SAW) Add CTP report routines
+*
+* Revision 1.4 1994/06/14 02:45:53 cdaq
+* (DFG) Correct some typos
+*
+* Revision 1.3 1994/02/22 18:41:25 cdaq
+* (SAW) Add more CTP routines
+*
+* Revision 1.2 1994/02/22 18:27:44 cdaq
+* (SAW) Add more CTP routines, declare each function external
+*
+* Revision 1.1 1994/02/22 18:18:24 cdaq
+* Initial revision
+*
+*-
+*-commonly used functions....
+*-
+ INTEGER G_important_length
+ EXTERNAL G_important_length
+ INTEGER G_shift_len
+ EXTERNAL G_shift_len
+*-
+*-CTP package
+ INTEGER regparmint
+ EXTERNAL regparmint
+ INTEGER regparmreal
+ EXTERNAL regparmreal
+ INTEGER regparmdouble
+ EXTERNAL regparmdouble
+ INTEGER regparmintarray
+ EXTERNAL regparmintarray
+ INTEGER regparmrealarray
+ EXTERNAL regparmrealarray
+ INTEGER regparmdoublearray
+ EXTERNAL regparmdoublearray
+*
+ INTEGER regtestint
+ EXTERNAL regtestint
+ INTEGER regtestreal
+ EXTERNAL regtestreal
+ INTEGER regtestdouble
+ EXTERNAL regtestdouble
+ INTEGER regtestintarray
+ EXTERNAL regtestintarray
+ INTEGER regtestrealarray
+ EXTERNAL regtestrealarray
+ INTEGER regtestdoublearray
+ EXTERNAL regtestdoublearray
+*
+ INTEGER regeventint
+ EXTERNAL regeventint
+ INTEGER regeventreal
+ EXTERNAL regeventreal
+ INTEGER regeventdouble
+ EXTERNAL regeventdouble
+ INTEGER regeventintarray
+ EXTERNAL regeventintarray
+ INTEGER regeventrealarray
+ EXTERNAL regeventrealarray
+ INTEGER regeventdoublearray
+ EXTERNAL regeventdoublearray
+*
+ INTEGER regparmstring
+ EXTERNAL regparmstring
+*
+ INTEGER thload
+ EXTERNAL thload
+ INTEGER thbook
+ EXTERNAL thbook
+ INTEGER thwhalias
+ EXTERNAL thwhalias
+ INTEGER thtstexe, thtstexeb, thtstexeg
+ EXTERNAL thtstexe, thtstexeb, thtstexeg
+ INTEGER thhstexe, thhstexeb, thhstexeg
+ EXTERNAL thhstexe, thhstexeb, thhstexeg
+ INTEGER thtstins
+ EXTERNAL thtstins
+ INTEGER thtstinsb
+ EXTERNAL thtstinsb
+ INTEGER thtstcls
+ EXTERNAL thtstcls
+ INTEGER thtstclsb
+ EXTERNAL thtstclsb
+ INTEGER threp, threpa
+ EXTERNAL threp, threpa
+ INTEGER thgethit, thgethitb, thgethitg
+ EXTERNAL thgethit, thgethitb, thgethitg
+ INTEGER thtreeexeg, thtreecloseg, thtreewriteg
+ EXTERNAL thtreeexeg, thtreecloseg, thtreewriteg
+*-
+ integer clnt_create
+ external clnt_create
+ integer thcrlist, thaddlist, thgetlist, thcgetlist, thremlist
+ external thcrlist, thaddlist, thgetlist, thcgetlist, thremlist
+ integer itheval,thevalchk
+ external itheval,thevalchk
+ integer thservone,thcallback
+ external thservone,thcallback
+ real*4 ftheval
+ external ftheval
+ real*8 dtheval
+ external dtheval
+*-
+****************** end: GEN_routines.DEC ***************************
+* Local Variables:
+* mode: fortran
+* fortran-continuation-string: "&"
+* End:
diff --git a/INCLUDE/gen_run_info.cmn b/INCLUDE/gen_run_info.cmn
new file mode 100644
index 0000000..438b36a
--- /dev/null
+++ b/INCLUDE/gen_run_info.cmn
@@ -0,0 +1,112 @@
+**************************begin: gen_run_info.cmn ***********************
+*-
+*- Created 22-Apr-1994 Kevin B. Beard, Hampton Univ.
+* $Log: gen_run_info.cmn,v $
+* Revision 1.7.24.5 2007/11/02 22:36:53 cdaq
+* Added additional prescale factors
+*
+* Revision 1.7.24.4 2007/10/23 13:27:44 cdaq
+* Added "gtrig7" and "gtrig8" equivalences for gen_run_enable
+*
+* Revision 1.7.24.3 2007/09/12 19:29:42 puckett
+* fixed incorrect usage of array index of gen_run_enable(type)
+*
+* Revision 1.7.24.2 2007/06/20 18:38:23 puckett
+* Added BigCal Monte Carlo analysis capability
+*
+* Revision 1.7.24.1 2007/06/04 15:11:23 puckett
+* changed hit array structure for trigger-related signals
+*
+* Revision 1.7 1996/09/04 15:46:13 saw
+* (JRA) Add prescale factors and some a debugging flag
+*
+* Revision 1.6 1996/01/17 15:57:28 cdaq
+* (JRA) Add some short equivalences for CTP convenience
+*
+* Revision 1.5 1995/03/13 19:01:03 cdaq
+* (SAW) Change gen_run_enable from logical to integer
+*
+* Revision 1.4 1995/01/31 15:52:04 cdaq
+* (SAW) Add gen_run_hist_dump_interval for in run hist dumping
+*
+* Revision 1.3 1994/10/20 14:19:12 cdaq
+* (SAW) Add accumulators for analyzed event counts ("May process")
+*
+* Revision 1.2 1994/08/03 20:11:50 cdaq
+* (SAW) Add "CTPTYPE=parm" directive for auto generation of CTP reg calls
+*
+* Revision 1.1 1994/05/27 15:12:47 cdaq
+* Initial revision
+*
+*........................................................................
+*- Misc. info. about a run
+*
+* CTPTYPE=parm
+*
+ INTEGER gen_run_number,gen_run_type
+ INTEGER gen_run_total_events !reported by CODA
+ INTEGER gen_run_UTC_start,gen_run_UTC_stop,gen_run_UTC_last
+ CHARACTER*80 gen_run_date_start,gen_run_date_stop
+ CHARACTER*80 gen_run_date_last
+ CHARACTER*800 gen_run_comment
+*
+ COMMON /gen_run_info/ gen_run_number,gen_run_type,
+ & gen_run_total_events,gen_run_UTC_start,gen_run_UTC_stop,
+ & gen_run_UTC_last,gen_run_date_start,gen_run_date_stop,
+ & gen_run_date_last,gen_run_comment
+*
+*
+* CTPTYPE=parm
+*
+ INTEGER gen_MAX_trigger_types
+ PARAMETER (gen_MAX_trigger_types= 15)
+ INTEGER gen_run_enable(0:gen_MAX_trigger_types) !1=process, 0=ignore
+ INTEGER gen_run_triggered(0:gen_MAX_trigger_types) !triggers found
+ INTEGER gen_run_analyzed(0:gen_MAX_trigger_types) ! NOT USED ANYWHERE
+ INTEGER gen_run_hist_dump_interval
+ INTEGER gen_run_starting_event,gen_run_stopping_event
+ INTEGER gen_analyze_beamline !1=enable beamline, 0=disable
+ integer gen_bigcal_mc !0=disable, 1=dat, 2=ntup, 3=dat with proton
+*
+ COMMON /gen_run_cntrl/ gen_run_starting_event,
+ & gen_run_stopping_event,
+ & gen_run_enable,
+ & gen_run_triggered,
+ & gen_run_analyzed,
+ & gen_run_hist_dump_interval,
+ $ gen_analyze_beamline,
+ $ gen_bigcal_mc
+*
+*-shorter names for command line input
+ integer grun,gstart,gstop,gdump,gtrig1,gtrig2,gtrig3,gtrig4 ! aliases
+ integer gtrig5,gtrig6,gtrig7,gtrig8,gbeam,gmc
+ equivalence (grun,gen_run_number)
+ equivalence (gstart,gen_run_starting_event)
+ equivalence (gstop,gen_run_stopping_event)
+ equivalence (gdump,gen_run_hist_dump_interval)
+ equivalence (gtrig1,gen_run_enable(0))
+ equivalence (gtrig2,gen_run_enable(1))
+ equivalence (gtrig3,gen_run_enable(2))
+ equivalence (gtrig4,gen_run_enable(3))
+ equivalence (gtrig5,gen_run_enable(4))
+ equivalence (gtrig6,gen_run_enable(5))
+ equivalence (gtrig7,gen_run_enable(6))
+ equivalence (gtrig8,gen_run_enable(7))
+ equivalence (gbeam,gen_analyze_beamline)
+ equivalence (gmc,gen_bigcal_mc)
+
+*
+* CTPTYPE=parm
+*
+ real*4 gps1,gps2,gps3,gps4,gps5,gps6,gps7 !prescale factors (1-S1S0x1,2-s1s0x2,3-bigcal,4-coin1,5-coin2,6-BC cosmics,7-LED)
+*
+ common/gen_prescales/ gps1,gps2,gps3,gps4,gps5,gps6,gps7
+
+*
+* CTPTYPE=parm
+*
+ integer gdebugdumpepics
+*
+ common/gen_debuggingstuff/ gdebugdumpepics
+
+****************************end: gen_run_info.cmn ***********************
diff --git a/INCLUDE/gen_run_info.dte b/INCLUDE/gen_run_info.dte
new file mode 100644
index 0000000..053e4a4
--- /dev/null
+++ b/INCLUDE/gen_run_info.dte
@@ -0,0 +1,31 @@
+**************************begin: gen_run_info.dte ***********************
+*-
+*- Created 24-May-1994 Kevin B. Beard, Hampton Univ.
+* $Log: gen_run_info.dte,v $
+* Revision 1.3 1995/07/28 15:15:48 cdaq
+* (SAW) Change .TRUE. to 1 for f2c compatibility
+*
+* Revision 1.2 1995/01/31 15:52:22 cdaq
+* (SAW) Add gen_run_hist_dump_interval for in run hist dumping
+*
+* Revision 1.1 1994/06/04 04:49:24 cdaq
+* Initial revision
+*
+*-
+*........................................................................
+*- Misc. info. about a run
+*
+ data gen_run_number,gen_run_type/2*0/
+ data gen_run_total_events/0/
+ data gen_run_UTC_start,gen_run_UTC_stop,gen_run_UTC_last/3*0/
+ data gen_run_date_start,gen_run_date_stop/2*' '/
+ data gen_run_date_last/' '/
+ data gen_run_comment/' '/
+*
+ data gen_run_enable/1,gen_MAX_trigger_types*1/
+ data gen_run_triggered/0,gen_MAX_trigger_types*0/
+*
+ data gen_run_starting_event,gen_run_stopping_event/2*0/
+ data gen_run_hist_dump_interval/0/ ! No in-run dumping by default
+*
+****************************end: gen_run_info.dte ***********************
diff --git a/INCLUDE/gen_run_pref.cmn b/INCLUDE/gen_run_pref.cmn
new file mode 100644
index 0000000..7159f50
--- /dev/null
+++ b/INCLUDE/gen_run_pref.cmn
@@ -0,0 +1,39 @@
+**************************begin: gen_run_pref.cmn ***********************
+*-
+*- Created 24-May-1994 Kevin B. Beard, Hampton Univ.
+*- Modified 3-Jun-1994 KBB
+* $Log: gen_run_pref.cmn,v $
+* Revision 1.4 1994/10/18 20:34:47 cdaq
+* (SAW) Add rpc control variables, comment out unused variables
+*
+* Revision 1.3 1994/08/03 20:12:37 cdaq
+* (SAW) Add "CTPTYPE=parm" directive for auto generation of CTP reg calls
+*
+* Revision 1.2 1994/06/04 05:14:41 cdaq
+* Fix typo
+*
+*Revision 1.1 1994/06/04 04:53:28 cdaq
+*Initial revision
+*
+*........................................................................
+*- Misc. display controls
+*
+* CTPTYPE=parm
+*
+* LOGICAL gen_show_progress
+* INTEGER gen_show_interval
+*
+* COMMON /gen_run_show/ gen_show_progress,gen_show_interval
+*
+*- Misc. preferences
+*
+* LOGICAL gen_pref_muddleON
+* COMMON /gen_run_pref/ gen_pref_muddleON
+*
+* Flags for RPC control
+*
+ integer rpc_on ! Make engine listen to RPC
+ integer rpc_control ! 0 block on rpc, >0 count down, <0 no block
+ common /gen_rpc_flags/ rpc_on, rpc_control
+*
+****************************end: gen_run_pref.cmn ***********************
diff --git a/INCLUDE/gen_run_pref.dte b/INCLUDE/gen_run_pref.dte
new file mode 100644
index 0000000..50eb7ca
--- /dev/null
+++ b/INCLUDE/gen_run_pref.dte
@@ -0,0 +1,20 @@
+**************************begin: gen_run_pref.cmn ***********************
+*-
+*- Created 24-May-1994 Kevin B. Beard, Hampton Univ.
+*- Modified 3-Jun-1994 KBB
+* $Log: gen_run_pref.dte,v $
+* Revision 1.2 1994/10/18 20:28:01 cdaq
+* (SAW) Comment out everything as it's not used
+*
+* Revision 1.1 1994/06/04 04:54:14 cdaq
+* Initial revision
+*
+*.............
+* data gen_show_progress/.FALSE./
+* data gen_show_interval/1/
+*
+*- Misc. preferences
+*
+* data gen_pref_muddleON/.TRUE./
+*
+****************************end: gen_run_pref.cmn ***********************
diff --git a/INCLUDE/gen_scalers.cmn b/INCLUDE/gen_scalers.cmn
new file mode 100644
index 0000000..5aa550a
--- /dev/null
+++ b/INCLUDE/gen_scalers.cmn
@@ -0,0 +1,209 @@
+******************* begin: gen_filenames.cmn ***********************
+*
+* Common block to hold the raw scaler information and
+* quantities calculated from the scaler events (time, current, etc...)
+*
+* $Log: gen_scalers.cmn,v $
+* Revision 1.13.14.1.2.3 2009/11/04 15:09:42 jones
+* Add vairable g_run_time_beam_on
+*
+* Revision 1.13.14.1.2.2 2009/09/29 14:02:17 jones
+* Add variables for charge asymmetry calcualtion
+*
+* Revision 1.13.14.1.2.1 2009/03/31 19:32:59 cdaq
+* *** empty log message ***
+*
+* Revision 1.13.14.1 2007/11/09 17:16:33 cdaq
+* increased gscaler array to 1000
+*
+* Revision 1.13 2004/05/11 18:23:26 jones
+* Add logical variable skip_events to BEAMCURRENT common block
+*
+* Revision 1.12 2003/09/05 20:29:03 jones
+* Merge in online03 changes (mkj)
+*
+* Revision 1.11.2.2 2003/09/05 14:12:17 jones
+* Updates for using syncfilter (mkj)
+*
+* Revision 1.11.2.1 2003/08/14 00:44:13 cdaq
+* Modify to be able to write scaler rates for each read to a file (mkj)
+*
+* Revision 1.11 1999/02/23 19:07:06 csa
+* (JRA) Add WEIRD_CLEARS common
+*
+* Revision 1.10 1999/02/10 17:40:52 csa
+* Added beam-on variables (D. McKee)
+*
+* Revision 1.9 1996/09/04 15:46:56 saw
+* (JRA) Add g_scaler_event_num
+*
+* Revision 1.8 1996/04/30 14:05:12 saw
+* (JRA) Add some bcm stuff
+*
+* Revision 1.7 1996/01/17 15:47:29 cdaq
+* (JRA) Add current monitor variables, time variable, and delta_scalers
+*
+* Revision 1.6 1995/09/01 13:02:09 cdaq
+* (JRA) Add time into run variable
+*
+* Revision 1.5 1995/05/11 15:13:43 cdaq
+* (SAW) Change scalers and evscalers to be real*8
+*
+* Revision 1.4 1995/04/06 20:16:52 cdaq
+* (SAW) Make scalers real
+*
+* Revision 1.3 1994/12/18 04:04:53 cdaq
+* (SAW) Add array and common for event by event scalers
+*
+* Revision 1.2 1994/08/03 20:13:12 cdaq
+* (SAW) Add "CTPTYPE=parm" directive for auto generation of CTP reg calls
+*
+* Revision 1.1 1994/06/21 16:36:57 cdaq
+* Initial revision
+*
+* CTPTYPE=parm
+*
+ integer*4 MAX_NUM_SCALERS
+ parameter (MAX_NUM_SCALERS=1000)
+ integer*4 MAX_NUM_EVSCALERS
+ parameter (MAX_NUM_EVSCALERS=16)
+ integer*4 MAX_WRITEOUT_SCALERS
+ parameter (MAX_WRITEOUT_SCALERS=10)
+ integer*4 INDEX_WRITEOUT_SCALERS(10)
+ integer*4 NUM_WRITEOUT_SCALERS
+
+ integer*4 gclock_index !index of hardware scaler clock.
+ real*8 gclock_rate ! rate of hardware scaler clock.
+*
+* CTPTYPE=event
+*
+ integer gscaler_nroll(MAX_NUM_SCALERS)
+ real*8 gscaler(MAX_NUM_SCALERS) ! Current scaler values
+ real*8 gscaler_old(MAX_NUM_SCALERS) ! Scaler values at last event
+ real*8 gscaler_change(MAX_NUM_SCALERS) ! prev_scalers - scalers
+ real*8 gscaler_skipped(MAX_NUM_SCALERS) ! prev_scalers - scalers
+ real*8 gscaler_saved(MAX_NUM_SCALERS) ! prev_scalers - scalers
+ real*8 g_run_time,g_run_time_beam_on !time of run at most recent scaler event
+ real*8 g_beam_on_run_time(2) ! accumulated time of run for which
+ real*8 g_beam_on_run_time_help(2) ! accumulated time of run for which
+ real*8 g_beam_on_run_time_helm(2) ! accumulated time of run for which
+ ! beam current exceeded beam_on_thresh_cur.
+ real*8 ave_current_bcm(3)
+ real*8 ave_current_bcm_help(2)
+ real*8 ave_current_bcm_helm(2)
+ integer g_replay_time !time since start of run (from cpu clock)
+ logical syncfilter_on
+ integer insync
+*
+ common /SCALERS/ gscaler, gscaler_old, gscaler_change,
+ $ ave_current_bcm,ave_current_bcm_help,ave_current_bcm_helm,gscaler_skipped,gscaler_saved,
+ $ gclock_rate, g_run_time,g_run_time_beam_on, gclock_index, g_replay_time,
+ $ gscaler_nroll, g_beam_on_run_time, g_beam_on_run_time_help, g_beam_on_run_time_helm,syncfilter_on,insync
+
+
+ccccccccccccccccccccccccc
+cc InSANE SCALERS ccccccc
+ccccccccccccccccccccccccc
+c For now I will only grab the scaler value and the change
+c since HBOOK can only handle common blocks with <1000 columns
+ real*8 runtime,runtimebeam,beamonruntime(2)
+ real*8 beamonruntimehelp(2),beamonruntimehelm(2)
+ real*8 cerscaler(12),cerscaler_change(12),cerscaler_skipped(12)
+ real*8 cerscaler_old(12),cerscaler_saved(12)
+ integer cerscalernroll(12)
+ real*8 tkscaler(32),tkscaler_change(32),tkscaler_skipped(32)
+ real*8 tkscaler_old(32),tkscaler_saved(32)
+ integer tkscalernroll(32)
+ integer nbcscalers
+ real*8 bcscaler(272),bcscaler_change(272),bcscaler_skipped(272)
+ real*8 bcscaler_old(272),bcscaler_saved(272)
+ integer bcscalernroll(272)
+ real*8 lucscaler(12),lucscaler_change(12),lucscaler_skipped(12)
+ real*8 lucscaler_old(12),lucscaler_saved(12)
+ integer lucscalernroll(12)
+ common /SCALERS1/ nbcscalers,runtime, runtimebeam, beamonruntime,
+ $ beamonruntimehelp,
+ $ beamonruntimehelm
+ $ ,cerscaler,cerscaler_change
+c,cerscaler_skipped,
+c $ cerscalernroll,cerscaler_old
+c $ ,cerscaler_saved
+ $ ,tkscaler,tkscaler_change
+c,tkscaler_skipped,
+c $ tkscalernroll,tkscaler_old
+c,tkscaler_saved
+ $ ,bcscaler,bcscaler_change
+c,bcscaler_skipped,
+c $ bcscalernroll,bcscaler_old,bcscaler_saved
+ $ ,lucscaler,lucscaler_change
+c,lucscaler_skipped,
+c $ lucscalernroll,lucscaler_old,lucscaler_saved
+ccccccccccccccccccccccccc
+cc InSANE SCALERS ccccccc
+ccccccccccccccccccccccccc
+
+
+c For Gen it is noticed that some scaler channels are randomly clearing
+c themselves. The following is to
+
+ real*8 gscalweird_lostcounts(MAX_NUM_SCALERS)
+ integer*4 gscalweird_nclears(MAX_NUM_SCALERS)
+ integer*4 gscalweird_lastval(MAX_NUM_SCALERS)
+* CTPTYPE=parm
+ integer*4 gscalweirdcorrect_flag
+* CTPTYPE=event
+
+ common /WEIRD_CLEARS/ gscalweird_lostcounts,
+ $ gscalweird_nclears,gscalweird_lastval,gscalweirdcorrect_flag
+
+*
+ integer*4 gscal_lastevnum(2) ! check for missing/out of order of scaler events
+ integer*4 gscal_evnum_roll(2)
+ real*8 evscalers(MAX_NUM_EVSCALERS)
+*
+ common /EVSCALERS/ evscalers, gscal_lastevnum, gscal_evnum_roll
+*
+* CTPTYPE=parm
+*
+ integer*4 gbcm1_index
+ integer*4 gbcm2_index
+ integer*4 gbcm3_index
+ integer*4 gunser_index
+ integer*4 bcm_for_threshold_cut
+ real*8 gbcm1_gain
+ real*8 gbcm2_gain
+ real*8 gbcm3_gain
+ real*8 gunser_gain
+ real*8 gbcm1_offset
+ real*8 gbcm2_offset
+ real*8 gbcm3_offset
+ real*8 gunser_offset
+ real*8 g_beam_on_thresh_cur(2) ! threshold for beam to be on.
+*
+* CTPTYPE=event
+*
+ real*8 gbcm1_charge,gbcm1_charge_help,gbcm1_charge_helm
+ real*8 gbcm2_charge,gbcm2_charge_help,gbcm2_charge_helm
+ real*8 gbcm3_charge
+ real*8 gunser_charge
+ real*8 g_beam_on_bcm_charge(2) ! "beam on" accumulated charge
+ real*8 g_beam_on_bcm_charge_help(2) ! "beam on" accumulated charge
+ real*8 g_beam_on_bcm_charge_helm(2) ! "beam on" accumulated charge
+ integer*4 gscaler_event_num
+ logical skip_events
+
+*
+ common/BEAMCURRENT/
+ & gbcm1_gain, gbcm2_gain, gbcm3_gain, gunser_gain,
+ & gbcm1_offset, gbcm2_offset, gbcm3_offset, gunser_offset,
+ & gbcm1_charge, gbcm2_charge, gbcm3_charge, gunser_charge,
+ & gbcm1_charge_help,gbcm1_charge_helm,gbcm2_charge_help,gbcm2_charge_helm,
+ & g_beam_on_bcm_charge,g_beam_on_bcm_charge_help,g_beam_on_bcm_charge_helm, g_beam_on_thresh_cur,
+ & gbcm1_index, gbcm2_index, gbcm3_index, gunser_index,bcm_for_threshold_cut,
+ & gscaler_event_num,skip_events
+ common/ WRITESCALERS/
+ & NUM_WRITEOUT_SCALERS,INDEX_WRITEOUT_SCALERS
+
+ integer*4 g_hel_pos
+ integer*4 g_hel_neg
+ common/HelScaler/g_hel_pos,g_hel_neg
\ No newline at end of file
diff --git a/INCLUDE/gen_units.par b/INCLUDE/gen_units.par
new file mode 100644
index 0000000..a5cfc9b
--- /dev/null
+++ b/INCLUDE/gen_units.par
@@ -0,0 +1,38 @@
+********************** begin: GEN_UNITS.PAR *******************************
+*
+* short unit names
+*
+* $Log: gen_units.par,v $
+* Revision 1.1 1994/02/07 20:14:29 cdaq
+* Initial revision
+*
+*
+*-time units
+ real nS,uS,mS,Sec,pS
+ parameter (nS= nanoSec) !nS std. hallC time unit
+ parameter (uS= microSec) !uS
+ parameter (mS= milliSec) !mS
+ parameter (Sec= Second) !second
+ parameter (pS= picoSec) !pS
+*
+*-distance units
+ real cm,mm,um,in,ft
+ parameter (cm= centimeter) !cm standard hallC distance unit
+ parameter (mm= millimeter) !mm
+ parameter (um= micron) !um
+ parameter (in= inch) !US in.
+ parameter (ft= foot) !US ft.
+*
+*-angle units
+ real rad,deg
+ parameter (rad= radian) !standard hallC angle unit
+ parameter (deg= degree) !radians/degree
+*
+*-magnetic field units
+ real Kg
+ parameter (Kg= Kgauss)
+*
+************************ end: GEN_UNITS.PAR ********************************
+* Local Variables:
+* mode: fortran
+* End:
diff --git a/INCLUDE/gep_data_structures.cmn b/INCLUDE/gep_data_structures.cmn
new file mode 100755
index 0000000..84c8887
--- /dev/null
+++ b/INCLUDE/gep_data_structures.cmn
@@ -0,0 +1,174 @@
+*
+* CTPTYPE=parm
+*
+c resolution parameters for picking best bigcal track using hms info!
+ real*4 GEP_sigma_xdiff
+ real*4 GEP_sigma_ydiff
+ real*4 GEP_sigma_thdiff ! difference in polar scat. angle for e- (radian)
+ real*4 GEP_sigma_phdiff ! difference in azimuthal scar. angle for e- (radian)
+ real*4 GEP_sigma_Ediff
+ real*4 GEP_sigma_tdiff
+ common/GEP_res/
+ $ GEP_sigma_xdiff,
+ $ GEP_sigma_ydiff,
+ $ GEP_sigma_thdiff,
+ $ GEP_sigma_phdiff,
+ $ GEP_sigma_Ediff,
+ $ GEP_sigma_tdiff
+c event selection cuts for BigCal calibration:
+ real*4 gep_bcalib_cut_ctime
+ real*4 gep_bcalib_cut_dx
+ real*4 gep_bcalib_cut_dy
+ real*4 gep_bcalib_cut_theta
+ real*4 gep_bcalib_cut_phi
+ real*4 gep_bcalib_cut_elastic ! cut on (hpel(hstheta)-hsp)/hpel(hstheta))
+ real*4 gep_bcalib_cut_ehms(2) ! 1 = min, 2 = max
+ common/gep_bcalib/
+ $ gep_bcalib_cut_ctime,
+ $ gep_bcalib_cut_dx,
+ $ gep_bcalib_cut_dy,
+ $ gep_bcalib_cut_theta,
+ $ gep_bcalib_cut_phi,
+ $ gep_bcalib_cut_elastic,
+ $ gep_bcalib_cut_ehms
+c coincidence timing window parameters (weed out background hits)
+ real*4 gep_h1time_center
+ real*4 gep_h2time_center
+ real*4 gep_h1time_slop
+ real*4 gep_h2time_slop
+ real*4 gep_btime_center
+ real*4 gep_btime_elastic
+ real*4 gep_btime_slop
+ real*4 gep_htrig_delay ! typically 16 ns
+
+ common/gep_coin_time_window/
+ $ gep_h1time_center,
+ $ gep_h2time_center,
+ $ gep_h1time_slop,
+ $ gep_h2time_slop,
+ $ gep_btime_center,
+ $ gep_btime_elastic,
+ $ gep_btime_slop,
+ $ gep_htrig_delay
+
+ real*4 btrig_phc_p0
+ real*4 btrig_phc_p1
+ real*4 btrig_phc_p2
+ real*4 btrig_phc_p3
+ real*4 btrig_phc_minph
+ real*4 btrig_phc_maxph
+
+ common/btrig_walk_corr/
+ $ btrig_phc_p0,
+ $ btrig_phc_p1,
+ $ btrig_phc_p2,
+ $ btrig_phc_p3,
+ $ btrig_phc_minph,
+ $ btrig_phc_maxph
+
+*
+* CTPTYPE=event
+*
+ integer*4 ntrigH1,ntrigH2,ntrigB
+ real*4 GEP_ctime_hms ! HMS coincidence time
+ real*4 GEP_ctime_cal ! BigCal coincidence time
+ real*4 GEP_H1time(8) ! HMS trigger1 hits (up to 8/event)
+ real*4 GEP_H2time(8) ! HMS trigger2 hits (up to 8/event)
+ real*4 GEP_Btime(8) ! HMS BigCal trigger hits (up to 8/event)
+ real*4 gep_btime_raw ! BigCal trigger chosen time
+ real*4 gep_btime_corr
+ real*4 GEP_Q2 ! 4 momentum transfer squared: BigCal angle, HMS momentum
+ real*4 GEP_Q2_H ! Q2 from HMS only
+ real*4 GEP_Q2_B ! Q2 from BigCal & HMS vertex, but no HMS momentum
+ real*4 GEP_E_electron ! scattered electron energy in GeV
+ real*4 GEP_P_proton ! scattered proton momentum in GeV
+ real*4 GEP_Pel_htheta ! proton momentum from spect. theta. assume elastic
+ real*4 GEP_Pel_btheta ! proton momentum from BigCal angle assume elastic (and correct angle for HMS vertex)
+ real*4 GEP_delta_p ! proton p - p0 in %, where p0 is HMS central mom.
+ real*4 GEP_xfp_p ! proton x at focal plane
+ real*4 GEP_yfp_p ! proton y at focal plane
+ real*4 GEP_xpfp_p ! proton dx/dz at focal plane
+ real*4 GEP_ypfp_p ! proton dy/dz at focal plane
+ real*4 GEP_xptar_p ! proton dx/dz at target
+ real*4 GEP_yptar_p ! proton dy/dz at target
+ real*4 GEP_ytar_p ! proton ytar
+ real*4 GEP_epsilon ! virtual photon long. polarization, usual definition
+ real*4 GEP_etheta_deg ! electron scattering angle in degrees
+ real*4 GEP_ptheta_deg ! proton scattering angle in degrees
+ real*4 GEP_ephi_deg ! electron azimuthal scattering angle in degrees
+ real*4 GEP_pphi_deg ! proton azimuthal scattering angle in degrees
+ real*4 GEP_Emiss ! missing energy in GeV
+ real*4 GEP_Pmissx ! x cpt. of missing momentum
+ real*4 GEP_Pmissy ! y cpt. of missing momentum
+ real*4 GEP_Pmissz ! z cpt. of missing momentum
+ real*4 GEP_Pmiss ! magnitude of missing momentum in GeV
+ real*4 GEP_W2 ! invariant mass of detected particles: should equal Mp^2
+ real*4 GEP_Mmiss ! missing mass = sqrt(W^2 - Mp^2)
+c For GEp, all our "missing" quantities should be zero, because W^2 = M^2,
+c and the e- and p carry all of the energy and momentum in the reaction.
+c by defining both polar and azimuthal scattering angles theta and phi, we
+c can define the unit vector in the q-direction, which defines the coord.
+c system for the polarization measurement.
+c trigger times (up to 10 per trigger type) from F1
+c TDCs in electronics bunker in Hall
+ real*4 gep_trigtimes(8,10)
+ integer gep_ntrigs(8)
+
+ common/GEPBLOCK/
+ $ ntrigH1,
+ $ ntrigH2,
+ $ ntrigB,
+ $ GEP_ctime_hms,
+ $ GEP_ctime_cal,
+ $ GEP_H1time,
+ $ GEP_H2time,
+ $ GEP_Btime,
+ $ gep_btime_raw,
+ $ GEP_btime_corr,
+ $ GEP_Q2,
+ $ GEP_Q2_H,
+ $ GEP_Q2_B,
+ $ GEP_E_electron,
+ $ GEP_P_proton,
+ $ GEP_Pel_htheta,
+ $ GEP_Pel_btheta,
+ $ GEP_delta_p,
+ $ GEP_xptar_p,
+ $ GEP_yptar_p,
+ $ GEP_ytar_p,
+ $ GEP_epsilon,
+ $ GEP_etheta_deg,
+ $ GEP_ptheta_deg,
+ $ GEP_ephi_deg,
+ $ GEP_pphi_deg,
+ $ GEP_Emiss,
+ $ GEP_Pmissx,
+ $ GEP_Pmissy,
+ $ GEP_Pmissz,
+ $ GEP_Pmiss,
+ $ GEP_W2,
+ $ GEP_Mmiss,
+ $ GEP_xfp_p,
+ $ GEP_yfp_p,
+ $ GEP_xpfp_p,
+ $ GEP_ypfp_p,
+ > gep_trigtimes,
+ > gep_ntrigs
+
+c expected hit positions in the calorimeter from the HMS:
+
+ real*4 GEP_etheta_expect_H ! in radians
+ real*4 GEP_ephi_expect_H ! in radians
+ real*4 GEP_bx_expect_H
+ real*4 GEP_by_expect_H
+
+ real*4 xdiff_shift,ydiff_shift,EprimeMeV
+ real*4 xcal_hexpect_B0,ycal_hexpect_B0
+
+ common/gep_bcoord_expect/
+ $ GEP_etheta_expect_H,
+ $ GEP_ephi_expect_H,
+ $ GEP_bx_expect_H,
+ $ GEP_by_expect_H,
+ $ xdiff_shift,ydiff_shift,EprimeMeV,
+ $ xcal_hexpect_B0,ycal_hexpect_B0
diff --git a/INCLUDE/gep_filenames.cmn b/INCLUDE/gep_filenames.cmn
new file mode 100755
index 0000000..dcb20db
--- /dev/null
+++ b/INCLUDE/gep_filenames.cmn
@@ -0,0 +1,12 @@
+*
+* CTPTYPE=parm
+*
+ character*80 gep_report_template_filename
+ character*80 gep_report_blockname
+ character*80 gep_report_output_filename
+ character*80 gep_tree_filename
+ common/gep_filenames/
+ $ gep_report_template_filename,
+ $ gep_report_blockname,
+ $ gep_report_output_filename,
+ $ gep_tree_filename
diff --git a/INCLUDE/gep_hist_id.cmn b/INCLUDE/gep_hist_id.cmn
new file mode 100644
index 0000000..741365c
--- /dev/null
+++ b/INCLUDE/gep_hist_id.cmn
@@ -0,0 +1,79 @@
+*
+* CTPTYPE=parm
+*
+
+ integer*4 gepid_gep_trigtype
+ integer*4 gepid_gep_evtype
+ integer*4 gepid_gep_trigtype_vs_evtype
+ integer*4 gepid_gep_ntrigs
+ integer*4 gepid_gep_HMS1_rawtdc
+ integer*4 gepid_gep_HMS2_rawtdc
+ integer*4 gepid_gep_bigcal_rawtdc
+ integer*4 gepid_gep_coin1_times
+ integer*4 gepid_gep_coin2_times
+ integer*4 gepid_gep_ntrig_h1
+ integer*4 gepid_gep_ntrig_h2
+ integer*4 gepid_gep_ntrig_bigcal
+ integer*4 gepid_hgep_delta(2)
+ integer*4 gepid_hgep_q2_hms(2)
+ integer*4 gepid_hgep_q2_cal(2)
+ integer*4 gepid_hgep_q2(2)
+ integer*4 gepid_hgep_ecal(2)
+ integer*4 gepid_hgep_pp(2)
+ integer*4 gepid_hgep_epsilon(2)
+ integer*4 gepid_hgep_etheta(2)
+ integer*4 gepid_hgep_ephi(2)
+ integer*4 gepid_hgep_ptheta(2)
+ integer*4 gepid_hgep_pphi(2)
+ integer*4 gepid_hgep_emiss(2)
+ integer*4 gepid_hgep_pmissx(2)
+ integer*4 gepid_hgep_pmissy(2)
+ integer*4 gepid_hgep_pmissz(2)
+ integer*4 gepid_hgep_xdiff(2)
+ integer*4 gepid_hgep_ydiff(2)
+ integer*4 gepid_hgep_xydiff(2)
+ integer*4 gepid_hgep_ediff(2)
+ integer*4 gepid_hgep_dpel(2)
+ integer*4 gepid_slowrastx
+ integer*4 gepid_slowrasty
+ integer*4 gepid_slowrastxy
+ integer*4 gepid_slowrastxy2
+
+ common/gep_hist_id/
+ $ gepid_gep_trigtype,
+ $ gepid_gep_evtype,
+ $ gepid_gep_trigtype_vs_evtype,
+ $ gepid_gep_ntrigs,
+ $ gepid_gep_HMS1_rawtdc,
+ $ gepid_gep_HMS2_rawtdc,
+ $ gepid_gep_bigcal_rawtdc,
+ $ gepid_gep_coin1_times,
+ $ gepid_gep_coin2_times,
+ $ gepid_gep_ntrig_h1,
+ $ gepid_gep_ntrig_h2,
+ $ gepid_gep_ntrig_bigcal,
+ $ gepid_hgep_delta,
+ $ gepid_hgep_q2_hms,
+ $ gepid_hgep_q2_cal,
+ $ gepid_hgep_q2,
+ $ gepid_hgep_ecal,
+ $ gepid_hgep_pp,
+ $ gepid_hgep_epsilon,
+ $ gepid_hgep_etheta,
+ $ gepid_hgep_ephi,
+ $ gepid_hgep_ptheta,
+ $ gepid_hgep_pphi,
+ $ gepid_hgep_emiss,
+ $ gepid_hgep_pmissx,
+ $ gepid_hgep_pmissy,
+ $ gepid_hgep_pmissz,
+ $ gepid_hgep_xdiff,
+ $ gepid_hgep_ydiff,
+ $ gepid_hgep_xydiff,
+ $ gepid_hgep_ediff,
+ $ gepid_hgep_dpel,
+ > gepid_slowrastx,
+ > gepid_slowrasty,
+ > gepid_slowrastxy,
+ > gepid_slowrastxy2
+
diff --git a/INCLUDE/gep_ntuple.cmn b/INCLUDE/gep_ntuple.cmn
new file mode 100755
index 0000000..2c7e4bd
--- /dev/null
+++ b/INCLUDE/gep_ntuple.cmn
@@ -0,0 +1,39 @@
+*
+ integer gep_max_ntuple_size
+ parameter (gep_max_ntuple_size=100)
+ integer default_gep_ntuple_ID
+ parameter (default_gep_ntuple_ID=9510)
+*
+* CTPTYPE=parm
+*
+ logical gep_ntuple_exists
+ integer gep_ntuple_ID
+ integer gep_ntuple_size
+ integer gep_ntuple_IO_channel
+ character*80 gep_ntuple_name
+ character*80 gep_ntuple_title
+ character*132 gep_ntuple_directory
+ character*256 gep_ntuple_file
+ character*8 gep_ntuple_tag(gep_max_ntuple_size)
+ integer gep_ntuple_max_segmentevents
+*
+* CTPTYPE=event
+*
+ integer gep_ntuple_segmentevents
+ integer gep_ntuple_filesegments
+ real gep_ntuple_contents(gep_max_ntuple_size)
+*
+ common/gep_ntuple/
+ $ gep_ntuple_exists,
+ $ gep_ntuple_ID,
+ $ gep_ntuple_size,
+ $ gep_ntuple_IO_channel,
+ $ gep_ntuple_name,
+ $ gep_ntuple_title,
+ $ gep_ntuple_directory,
+ $ gep_ntuple_file,
+ $ gep_ntuple_tag,
+ $ gep_ntuple_max_segmentevents,
+ $ gep_ntuple_segmentevents,
+ $ gep_ntuple_filesegments,
+ $ gep_ntuple_contents
diff --git a/INCLUDE/gep_ntuple.dte b/INCLUDE/gep_ntuple.dte
new file mode 100644
index 0000000..d422ce1
--- /dev/null
+++ b/INCLUDE/gep_ntuple.dte
@@ -0,0 +1,13 @@
+c leave clean field for gep ntuple:
+
+ data gep_ntuple_exists/.false./
+ data gep_ntuple_ID/0/
+ data gep_ntuple_file/' '/
+ data gep_ntuple_name/' '/
+ data gep_ntuple_title/' '/
+ data gep_ntuple_directory/' '/
+ data gep_ntuple_IO_channel/0/
+ data gep_ntuple_size/0/
+ data gep_ntuple_tag/gep_max_ntuple_size*' '/
+ data gep_ntuple_contents/gep_max_ntuple_size*0/
+
diff --git a/INCLUDE/h_fpp_ntuple.cmn b/INCLUDE/h_fpp_ntuple.cmn
new file mode 100644
index 0000000..18d348c
--- /dev/null
+++ b/INCLUDE/h_fpp_ntuple.cmn
@@ -0,0 +1,35 @@
+**************************begin: h_fpp_nt.cmn ***********************
+*
+ integer HMAX_FPPntuple_size
+ parameter (HMAX_FPPntuple_size= 100)
+ integer default_h_fpp_nt_ID
+ parameter (default_h_fpp_nt_ID= 9013)
+*
+* CTPTYPE=parm
+*
+ logical h_fpp_nt_exists
+ integer h_fpp_nt_ID
+ integer h_fpp_nt_IOchannel
+ character*80 h_fpp_nt_name
+ character*80 h_fpp_nt_title
+ character*132 h_fpp_nt_directory
+ character*256 h_fpp_nt_file
+ character*8 h_fpp_nt_tag(HMAX_FPPntuple_size)
+ integer HFPP_nt_max_segmentevents
+*
+* CTPTYPE=event
+*
+ integer h_fpp_nt_segmentevents
+ integer h_fpp_nt_filesegments
+ real h_fpp_nt_contents(HMAX_FPPntuple_size)
+*
+ COMMON /HMS_FPP_Ntuple/ h_fpp_nt_exists,h_fpp_nt_ID,
+ & h_fpp_nt_IOchannel,
+ & h_fpp_nt_name,h_fpp_nt_title,
+ & h_fpp_nt_directory,h_fpp_nt_file,
+ & h_fpp_nt_tag,h_fpp_nt_contents,
+ > HFPP_nt_max_segmentevents,h_fpp_nt_segmentevents,
+ > h_fpp_nt_filesegments
+*
+****************************end: h_fpp_nt.cmn ***********************
+
diff --git a/INCLUDE/h_fpp_ntuple.dte b/INCLUDE/h_fpp_ntuple.dte
new file mode 100644
index 0000000..5fb47ea
--- /dev/null
+++ b/INCLUDE/h_fpp_ntuple.dte
@@ -0,0 +1,13 @@
+**************************begin: h_fpp_nt.dte ***********************
+*
+ data h_fpp_nt_exists/.FALSE./
+ data h_fpp_nt_ID/0/
+ data h_fpp_nt_file/' '/
+ data h_fpp_nt_name/' '/
+ data h_fpp_nt_title/' '/
+ data h_fpp_nt_directory/' '/
+ data h_fpp_nt_IOchannel/0/
+ data h_fpp_nt_tag/HMAX_FPPntuple_size*' '/
+ data h_fpp_nt_contents/HMAX_FPPntuple_size*0/
+*
+****************************end: h_fpp_nt.dte ***********************
diff --git a/INCLUDE/h_ntuple.cmn b/INCLUDE/h_ntuple.cmn
new file mode 100644
index 0000000..3769ab3
--- /dev/null
+++ b/INCLUDE/h_ntuple.cmn
@@ -0,0 +1,53 @@
+**************************begin: h_ntuple.cmn ***********************
+*-
+*- Created 8-Apr-1994 Kevin B. Beard, Hampton Univ.
+*........................................................................
+*- Misc. info. required for HMS Ntuple
+* $Log: h_ntuple.cmn,v $
+* Revision 1.4 2004/02/17 16:41:45 jones
+* Add parameters and variables needed for segmenting rzdat files
+*
+* Revision 1.3 1995/05/22 19:05:38 cdaq
+* (SAW) Correct some CTP class types
+*
+* Revision 1.2 1994/06/17 02:11:45 cdaq
+* (KBB) Fix typos, change variable names, reorder common
+*
+* Revision 1.1 1994/04/14 16:05:12 cdaq
+* Initial revision
+*
+*
+ integer HMAX_Ntuple_size
+ parameter (HMAX_Ntuple_size= 100)
+ integer default_h_Ntuple_ID
+ parameter (default_h_Ntuple_ID= 9010)
+*
+* CTPTYPE=parm
+*
+ logical h_Ntuple_exists
+ integer h_Ntuple_ID
+ integer h_Ntuple_size
+ integer h_Ntuple_IOchannel
+ character*80 h_Ntuple_name
+ character*80 h_Ntuple_title
+ character*132 h_Ntuple_directory
+ character*256 h_Ntuple_file
+ character*8 h_Ntuple_tag(HMAX_Ntuple_size)
+ integer h_Ntuple_max_segmentevents
+*
+* CTPTYPE=event
+*
+ integer h_Ntuple_segmentevents
+ integer h_Ntuple_filesegments
+ real h_Ntuple_contents(HMAX_Ntuple_size)
+*
+ COMMON /HMS_Ntuple/ h_Ntuple_exists,h_Ntuple_ID,
+ & h_Ntuple_size,h_Ntuple_IOchannel,
+ & h_Ntuple_name,h_Ntuple_title,
+ & h_Ntuple_directory,h_Ntuple_file,
+ & h_Ntuple_tag,h_Ntuple_contents,
+ > h_Ntuple_max_segmentevents,h_Ntuple_segmentevents,
+ > h_Ntuple_filesegments
+*
+****************************end: h_ntuple.cmn ***********************
+
diff --git a/INCLUDE/h_ntuple.dte b/INCLUDE/h_ntuple.dte
new file mode 100644
index 0000000..9bb4531
--- /dev/null
+++ b/INCLUDE/h_ntuple.dte
@@ -0,0 +1,21 @@
+**************************begin: h_ntuple.dte ***********************
+*-
+*- Created 15-Jun-1994 Kevin B. Beard, Hampton Univ.
+*........................................................................
+*- leave clean field for HMS Ntuple
+* $Log: h_ntuple.dte,v $
+* Revision 1.1 1994/06/17 02:13:10 cdaq
+* Initial revision
+*
+ data h_Ntuple_exists/.FALSE./
+ data h_Ntuple_ID/0/
+ data h_Ntuple_file/' '/
+ data h_Ntuple_name/' '/
+ data h_Ntuple_title/' '/
+ data h_Ntuple_directory/' '/
+ data h_Ntuple_IOchannel/0/
+ data h_Ntuple_size/0/
+ data h_Ntuple_tag/HMAX_Ntuple_size*' '/
+ data h_Ntuple_contents/HMAX_Ntuple_size*0/
+*
+****************************end: h_ntuple.dte ***********************
diff --git a/INCLUDE/h_sieve_ntuple.cmn b/INCLUDE/h_sieve_ntuple.cmn
new file mode 100644
index 0000000..b5cd3c8
--- /dev/null
+++ b/INCLUDE/h_sieve_ntuple.cmn
@@ -0,0 +1,42 @@
+**************************begin: h_ntuple.cmn ***********************
+*-
+*- Created 1-Nov-1994
+*........................................................................
+*- Misc. info. required for HMS sieve slit Ntuple
+* $Log: h_sieve_ntuple.cmn,v $
+* Revision 1.2 1995/05/22 19:05:58 cdaq
+* (SAW) Correct some CTP class types
+*
+* Revision 1.1 1994/12/17 22:14:28 cdaq
+* Initial revision
+*
+*
+*
+ integer HMAX_Ntuple_size
+ parameter (HMAX_Ntuple_size= 100)
+ integer default_h_sieve_Ntuple_ID
+ parameter (default_h_sieve_Ntuple_ID= 1411)
+*
+* CTPTYPE=parm
+*
+ logical h_sieve_Ntuple_exists
+ integer h_sieve_Ntuple_ID
+ integer h_sieve_Ntuple_size
+ integer h_sieve_Ntuple_IOchannel
+ character*80 h_sieve_Ntuple_name
+ character*80 h_sieve_Ntuple_title
+ character*132 h_sieve_Ntuple_directory
+ character*256 h_sieve_Ntuple_file
+ character*8 h_sieve_Ntuple_tag(HMAX_Ntuple_size)
+*
+* CTPTYPE=event
+*
+ real h_sieve_Ntuple_contents(HMAX_Ntuple_size)
+*
+ COMMON /HMS_sieve_Ntuple/ h_sieve_Ntuple_exists,h_sieve_Ntuple_ID,
+ & h_sieve_Ntuple_size,h_sieve_Ntuple_IOchannel,
+ & h_sieve_Ntuple_name,h_sieve_Ntuple_title,
+ & h_sieve_Ntuple_directory,h_sieve_Ntuple_file,
+ & h_sieve_Ntuple_tag,h_sieve_Ntuple_contents
+
+*****************************end: h_sieve_ntuple.cmn ***********************
diff --git a/INCLUDE/h_sieve_ntuple.dte b/INCLUDE/h_sieve_ntuple.dte
new file mode 100644
index 0000000..2a29a2b
--- /dev/null
+++ b/INCLUDE/h_sieve_ntuple.dte
@@ -0,0 +1,22 @@
+**************************begin: h_ntuple.dte ***********************
+*-
+*- Created 1-Nov-1994
+*........................................................................
+*- leave clean field for HMS sieve slit Ntuple
+* $Log: h_sieve_ntuple.dte,v $
+* Revision 1.1 1994/12/17 22:21:16 cdaq
+* Initial revision
+*
+*
+ data h_sieve_Ntuple_exists/.FALSE./
+ data h_sieve_Ntuple_ID/0/
+ data h_sieve_Ntuple_file/' '/
+ data h_sieve_Ntuple_name/' '/
+ data h_sieve_Ntuple_title/' '/
+ data h_sieve_Ntuple_directory/' '/
+ data h_sieve_Ntuple_IOchannel/0/
+ data h_sieve_Ntuple_size/0/
+ data h_sieve_Ntuple_tag/HMAX_Ntuple_size*' '/
+ data h_sieve_Ntuple_contents/HMAX_Ntuple_size*0/
+*
+****************************end: h_sieve_Ntuple.dte ***********************
diff --git a/INCLUDE/hack_.cmn b/INCLUDE/hack_.cmn
new file mode 100644
index 0000000..ebf6bba
--- /dev/null
+++ b/INCLUDE/hack_.cmn
@@ -0,0 +1,36 @@
+*---------------------------------------------------------------------------
+*-- file: hack_.cmn
+*-- include file for USER DEVOLOPMENT common block definitions;
+* used in files HACK_*.F
+*-- The parameter hack_enable must be set to .ne. 0 to enable execution of
+* hack_anal subroutine for each event.
+*-- any additional arrays or variables my be added by the user
+*---------------------------------------------------------------------------
+* $Log: hack_.cmn,v $
+* Revision 1.3 1996/01/17 15:58:04 cdaq
+* (JRA) Hacked it a bit
+*
+* Revision 1.2 1994/07/25 18:02:18 cdaq
+* (HB) New version
+*
+* Revision 1.1 1994/07/22 13:55:48 cdaq
+* Initial revision
+*
+*---------------------------------------------------------------------------
+*
+* CTPTYPE=parm
+*
+ integer*4 hack_enable
+ common /hack_c/ hack_enable
+*
+*
+* CTPTYPE=event
+*
+ integer hack_hmssc_au(16,4) !raw HMS-scintillator ADC up in fixed array
+ integer hack_hmssc_ad(16,4) !raw HMS-scintillator ADC down in fixed array
+ integer hack_hmssc_tu(16,4) !raw HMS-scintillator TDC up in fixed array
+ integer hack_hmssc_td(16,4) !raw HMS-scintillator TDC down in fixed array
+ integer hack_hmssc_go(16,4) !info about which ADC/TDC fired
+*
+ common/hack_copyeve_c/ hack_hmssc_au,hack_hmssc_ad,
+ & hack_hmssc_tu,hack_hmssc_td,hack_hmssc_go
diff --git a/INCLUDE/hms_aero_parms.cmn b/INCLUDE/hms_aero_parms.cmn
new file mode 100644
index 0000000..9fb4879
--- /dev/null
+++ b/INCLUDE/hms_aero_parms.cmn
@@ -0,0 +1,82 @@
+* hms_aero_parms.cmn
+*
+* $Log: hms_aero_parms.cmn,v $
+* Revision 1.2 2003/09/05 20:30:48 jones
+* Merge in online03 changes (mkj)
+*
+* Revision 1.1.2.2 2003/07/18 21:13:37 cdaq
+* Comment out aero_pos, aero_neg, aero_tot which are not used anymore (Vardan)
+*
+* Revision 1.1.2.1 2003/04/06 06:19:49 cdaq
+* updated variables for haero
+*
+* Revision 1.1 2002/12/20 21:52:32 jones
+* Modified by Hamlet for new HMS aerogel
+*
+* Revision 1.1 (hamlet) 2002/09/24
+* As initial version took cp from sos_aero_parms.cmn
+*
+*%% include 'hms_data_structures.cmn'
+
+*
+* CTPTYPE = parm
+*
+ real*4 haero_pos_gain(HMAX_AERO_HITS)
+ real*4 haero_neg_gain(HMAX_AERO_HITS)
+
+*
+* CTPTYPE = event
+*
+ integer*4 haero_tot_good_hits
+
+ integer*4 haero_adc_pos_hits,haero_adc_neg_hits
+ integer*4 haero_tdc_pos_hits,haero_tdc_neg_hits
+
+ integer*4 haero_rawadc_neg(HMAX_AERO_HITS)
+ integer*4 haero_rawadc_pos(HMAX_AERO_HITS)
+
+ integer*4 haero_rawtdc_neg(HMAX_AERO_HITS)
+ integer*4 haero_rawtdc_pos(HMAX_AERO_HITS)
+
+ integer*4 aero_tp(HMAX_AERO_HITS)
+ integer*4 aero_tn(HMAX_AERO_HITS)
+
+ integer*4 aero_ep(HMAX_AERO_HITS)
+ integer*4 aero_en(HMAX_AERO_HITS)
+
+ real*4 haero_pos_npe(HMAX_AERO_HITS)
+ real*4 haero_neg_npe(HMAX_AERO_HITS)
+ real*4 haero_sum(HMAX_AERO_HITS)
+ real*4 haero_neg_npe_sum
+ real*4 haero_pos_npe_sum
+ real*4 haero_npe_sum
+
+*** real*4 aero_pos !not in use any more
+*** real*4 aero_neg !not in use any more
+*** real*4 aero_tot !not in use any more
+
+ common /aeroi_calib/
+ & haero_tot_good_hits,
+ & haero_adc_pos_hits,
+ & haero_adc_neg_hits,
+ & haero_tdc_pos_hits,
+ & haero_tdc_neg_hits,
+ & haero_pos_npe,
+ & haero_neg_npe,
+ & haero_pos_gain,
+ & haero_neg_gain,
+ & haero_neg_npe_sum,
+ & haero_pos_npe_sum,
+ & haero_npe_sum,
+ & haero_sum,
+*** & aero_pos, !not in use any more
+*** & aero_neg, !not in use any more
+*** & aero_tot, !not in use any more
+ & haero_rawadc_neg,
+ & haero_rawadc_pos,
+ & haero_rawtdc_neg,
+ & haero_rawtdc_pos,
+ & aero_tp,
+ & aero_tn,
+ & aero_ep,
+ & aero_en
diff --git a/INCLUDE/hms_bypass_switches.cmn b/INCLUDE/hms_bypass_switches.cmn
new file mode 100644
index 0000000..66cc809
--- /dev/null
+++ b/INCLUDE/hms_bypass_switches.cmn
@@ -0,0 +1,80 @@
+* hms_bypass_switches.cmn
+*
+* common blocks of CTP switches to bypass reconstruction code
+* elements.
+*
+* Created: D.F.Geesaman 22 May 1994
+* $Log: hms_bypass_switches.cmn,v $
+* Revision 1.6.24.1 2007/08/22 19:09:31 frw
+* added FPP
+*
+*
+* Revision 1.8 2006/06/22
+* (frw) Add bypass switches for FPP
+*
+* Revision 1.7 2002/12/20 21:52:32 jones
+* Modified by Hamlet for new HMS aerogel
+*
+* Revision 1.6 2002/09/26
+* (Hamlet)) Add bypass switch for Aerogel
+*
+* Revision 1.5 1996/09/04 15:48:31 saw
+* (JRA) Add bypass of tracking efficiency flags
+*
+* Revision 1.4 1996/01/17 15:59:03 cdaq
+* (JRA) Add bypass switches for efficiency calculations
+*
+* Revision 1.3 1995/08/08 18:22:27 cdaq
+* (JRA) Add hbypass_trans_cer
+*
+* Revision 1.2 1994/08/05 19:37:01 cdaq
+* (SAW) Add "CTPTYPE=parm" directive for auto generation of CTP reg calls
+*
+* Revision 1.1 1994/06/06 16:51:47 cdaq
+* Initial revision
+*
+* CTPTYPE=parm
+*
+ integer*4 hbypass_trans_scin
+ integer*4 hbypass_trans_cer
+ integer*4 hbypass_trans_fpp
+ integer*4 hbypass_trans_cal
+ integer*4 hbypass_trans_dc
+ integer*4 hbypass_track
+ integer*4 hbypass_targ_trans
+ integer*4 hbypass_tof
+ integer*4 hbypass_cal
+ integer*4 hbypass_fpp
+ integer*4 hbypass_cer
+ integer*4 hbypass_haero
+ integer*4 hbypass_physics
+ integer*4 hbypass_dc_eff
+ integer*4 hbypass_scin_eff
+ integer*4 hbypass_cal_eff
+ integer*4 hbypass_cer_eff
+ integer*4 hbypass_track_eff
+ integer*4 hbypass_track_eff_files
+*
+ common/hms_bypass_switches/
+ & hbypass_trans_scin,
+ & hbypass_trans_cer,
+ & hbypass_trans_fpp,
+ & hbypass_trans_cal,
+ & hbypass_trans_dc,
+ & hbypass_track,
+ & hbypass_targ_trans,
+ & hbypass_tof,
+ & hbypass_cal,
+ & hbypass_fpp,
+ & hbypass_cer,
+ & hbypass_haero,
+ & hbypass_physics,
+ & hbypass_dc_eff,
+ & hbypass_scin_eff,
+ & hbypass_cal_eff,
+ & hbypass_cer_eff,
+ & hbypass_track_eff,
+ & hbypass_track_eff_files
+
+
+
diff --git a/INCLUDE/hms_calorimeter.cmn b/INCLUDE/hms_calorimeter.cmn
new file mode 100644
index 0000000..a7d2640
--- /dev/null
+++ b/INCLUDE/hms_calorimeter.cmn
@@ -0,0 +1,303 @@
+*
+* HMS calorimeter. Parameters from hms_positions.parm
+*
+* $Log: hms_calorimeter.cmn,v $
+* Revision 1.12 1999/02/23 19:08:04 csa
+* Add hcal_fv_test
+*
+* Revision 1.11 1999/01/21 21:40:30 saw
+* Extra shower counter tube modifications
+*
+* Revision 1.10 1998/12/17 22:02:40 saw
+* Support extra set of tubes on HMS shower counter
+*
+* Revision 1.9 1998/12/01 20:28:57 saw
+* (SAW) Cosmetics
+*
+* Revision 1.8 1996/01/17 15:59:26 cdaq
+* (JRA) Add normalized event quantities
+*
+* Revision 1.7 1995/08/11 16:27:42 cdaq
+* (JRA) Add accumulators for calorimeter
+*
+* Revision 1.6 1995/05/22 19:06:29 cdaq
+* (SAW) Split gen_data_data_structures into gen, hms, sos, and coin parts
+*
+* Revision 1.5 1995/03/13 19:01:46 cdaq
+* (JRA) Move hmax_cal_rows and hmax_cal_columns to gen_data_structures
+*
+* Revision 1.4 1995/01/04 17:09:32 cdaq
+* (HGM) Increase hmax_cal_rows to 13
+*
+* Revision 1.3 1994/10/11 19:44:44 cdaq
+* (SAW) Add hcal_slop
+*
+* Revision 1.2 1994/08/05 15:35:42 cdaq
+* (SAW) Add makereg directive with required include files
+* Add "CTPTYPE=event" directive for auto generation of CTP reg calls
+*
+* Revision 1.1 1994/04/12 21:32:21 cdaq
+* Initial revision
+*
+* The following include statments must precede the inclusion of this
+* file in each routine that uses it. The *%% syntax is also a
+* directive to makereg to tell it to include the code in the program
+* that it generates.
+*
+*%% include 'hms_data_structures.cmn'
+*
+* CTPTYPE=parm
+*
+ real*4 hcal_1pr_zpos ! Z positions of front of shower counter layers
+ real*4 hcal_2ta_zpos !
+ real*4 hcal_3ta_zpos !
+ real*4 hcal_4ta_zpos !
+ real*4 hcal_1pr_thick ! Thickness of shower counter blocks
+ real*4 hcal_2ta_thick !
+ real*4 hcal_3ta_thick !
+ real*4 hcal_4ta_thick !
+ integer*4 hcal_1pr_nr !Number of shower blocks per column
+ integer*4 hcal_2ta_nr !
+ integer*4 hcal_3ta_nr !
+ integer*4 hcal_4ta_nr !
+ real*4 hcal_1pr_left !Y position, column #1
+ real*4 hcal_1pr_right !
+ real*4 hcal_1pr_top ! X positions, column #1
+ real*4 hcal_2ta_left ! Y position, column #2
+ real*4 hcal_2ta_right !
+ real*4 hcal_2ta_top ! X positions, column#2
+ real*4 hcal_3ta_left ! Y position, column #3
+ real*4 hcal_3ta_right !
+ real*4 hcal_3ta_top ! X positions, column #3
+ real*4 hcal_4ta_left ! Y position, column #4
+ real*4 hcal_4ta_right !
+ real*4 hcal_4ta_top ! X positions, column #4
+ REAL*4 HCAL_SLOP !SLOP IN DISTANCE BETWEEN TRACK AND BLOCK
+ integer*4 hcal_fv_test !Turn on fiducial volume cut
+
+ common/hms_cal_parms/
+ & hcal_1pr_zpos,
+ & hcal_2ta_zpos,
+ & hcal_3ta_zpos,
+ & hcal_4ta_zpos,
+ & hcal_1pr_thick,
+ & hcal_2ta_thick,
+ & hcal_3ta_thick,
+ & hcal_4ta_thick,
+ & hcal_1pr_nr,
+ & hcal_2ta_nr,
+ & hcal_3ta_nr,
+ & hcal_4ta_nr,
+ & hcal_1pr_left,
+ & hcal_1pr_right,
+ & hcal_1pr_top(HMAX_CAL_ROWS),
+ & hcal_2ta_left,
+ & hcal_2ta_right,
+ & hcal_2ta_top(HMAX_CAL_ROWS),
+ & hcal_3ta_left,
+ & hcal_3ta_right,
+ & hcal_3ta_top(HMAX_CAL_ROWS),
+ & hcal_4ta_left,
+ & hcal_4ta_right,
+ & hcal_4ta_top(HMAX_CAL_ROWS),
+ & hcal_slop,
+ & hcal_fv_test
+*
+* HMS calorimeter. Geometrical constants filled by h_init_cal
+*
+ real*4 hcal_block_xsize !
+ real*4 hcal_block_ysize !Block dimensions - 10*70*10 cm^3
+ real*4 hcal_block_zsize !
+ real*4 hcal_block_xc !
+ real*4 hcal_block_yc !X,Y,Z coordinates of block centers
+ real*4 hcal_block_zc !
+ real*4 hcal_xmin !
+ real*4 hcal_xmax !
+ real*4 hcal_ymin !Boundaries of the HMS
+ real*4 hcal_ymax !calorimeter stack
+ real*4 hcal_zmin !
+ real*4 hcal_zmax !
+ real*4 hcal_fv_xmin !
+ real*4 hcal_fv_xmax !
+ real*4 hcal_fv_ymin !Boundaries of the
+ real*4 hcal_fv_ymax !fiducial volume
+ real*4 hcal_fv_zmin !
+ real*4 hcal_fv_zmax !
+ common/hms_geometry_cal/
+ & hcal_block_xsize,
+ & hcal_block_ysize,
+ & hcal_block_zsize,
+ & hcal_block_xc(HMAX_CAL_BLOCKS),
+ & hcal_block_yc(HMAX_CAL_BLOCKS),
+ & hcal_block_zc(HMAX_CAL_BLOCKS),
+ & hcal_xmin,hcal_xmax,
+ & hcal_ymin,hcal_ymax,
+ & hcal_zmin,hcal_zmax,
+ & hcal_fv_xmin,hcal_fv_xmax,
+ & hcal_fv_ymin,hcal_fv_ymax,
+ & hcal_fv_zmin,hcal_fv_zmax
+*
+* HMS calorimeter. Sparsified data filled by h_sparsify_cal
+*
+* CTPTYPE=event
+*
+ integer*4 hcal_rows !Row number. Copied from hms_raw_cal
+ integer*4 hcal_cols !Column number. Copied from hms_raw_cal
+ real*4 hcal_adcs_pos !Pulse height in channels(ADC_POS-PED).
+ real*4 hcal_adcs_neg !Pulse height in channels(ADC_NEG-PED).
+ integer*4 hcal_num_hits !Total number of hits above threshold
+ common/hms_sparsified_cal/
+ & hcal_rows(HMAX_CAL_BLOCKS),
+ & hcal_cols(HMAX_CAL_BLOCKS),
+ & hcal_adcs_pos(HMAX_CAL_BLOCKS),
+ & hcal_adcs_neg(HMAX_CAL_BLOCKS),
+ & hcal_num_hits
+*
+* HMS calorimeter. Cluster data, filled by h_clusters_cal
+*
+ integer*4 hnclusters_max !Number of clusters allowed in the calorimeter
+ parameter (hnclusters_max=5) !Set the maximum to 5
+ integer*4 hnclusters_cal !Number of clusters found
+ integer*4 hcluster_hit !Link pointer to cluster number for each hit
+ integer*4 hcluster_size !Number of hits in a cluster
+ real*4 hcluster_xc !X-coordinate of a cluster
+ real*4 hcluster_e1 !Energy deposition in column #1
+ real*4 hcluster_e2 ! #2
+ real*4 hcluster_e3 ! #3
+ real*4 hcluster_e4 ! #4
+ real*4 hcluster_et !Total energy deposition
+
+ real*4 hcluster_e1_pos !Energy deposition in column #POS_1
+ real*4 hcluster_e1_neg !Energy deposition in column #NEG_1
+*
+ real*4 hcluster_e2_pos !Energy deposition in column #POS_2
+ real*4 hcluster_e2_neg !Energy deposition in column #NEG_2
+ common/hms_clusters_cal/
+ & hcluster_hit(HMAX_CAL_BLOCKS),
+ & hcluster_size(hnclusters_max),
+ & hcluster_xc(hnclusters_max),
+ & hcluster_e1(hnclusters_max),
+ & hcluster_e2(hnclusters_max),
+ & hcluster_e3(hnclusters_max),
+ & hcluster_e4(hnclusters_max),
+ & hcluster_e1_pos(hnclusters_max),
+ & hcluster_e1_neg(hnclusters_max),
+ & hcluster_e2_pos(hnclusters_max),
+ & hcluster_e2_neg(hnclusters_max),
+ & hcluster_et(hnclusters_max),
+ & hnclusters_cal
+*
+* HMS calorimeter. Calorimeter track quantities,filled by h_tracks_cal
+*
+ real*4 htrack_xc !X,Y position of track on
+ real*4 htrack_yc ! calorimeter front surface
+ integer*4 hcluster_track !Link pointer to calorimeter cluster number
+ integer*4 hntracks_cal !Number of tracks for which a cluster was found
+ common/hms_tracks_cal/
+ & htrack_xc(HNTRACKS_MAX),
+ & htrack_yc(HNTRACKS_MAX),
+ & hcluster_track(HNTRACKS_MAX),
+ & hntracks_cal
+*
+* CTPTYPE=parm
+*
+*
+* HMS calorimeter. ADC pedestals and thresholds
+*
+ real*4 hcal_pos_ped_mean !Mean pedestal value
+ real*4 hcal_pos_ped_rms !Pedestal rms deviation
+ real*4 hcal_pos_threshold !Threshold=3.*hcal_ped_rms
+ real*4 hcal_neg_ped_mean !Mean pedestal value
+ real*4 hcal_neg_ped_rms !Pedestal rms deviation
+ real*4 hcal_neg_threshold !Threshold=3.*hcal_ped_rms
+ common/hms_cal_pedestals/
+ & hcal_pos_ped_mean(HMAX_CAL_BLOCKS),
+ & hcal_pos_ped_rms(HMAX_CAL_BLOCKS),
+ & hcal_pos_threshold(HMAX_CAL_BLOCKS),
+ & hcal_neg_ped_mean(HMAX_CAL_BLOCKS),
+ & hcal_neg_ped_rms(HMAX_CAL_BLOCKS),
+ & hcal_neg_threshold(HMAX_CAL_BLOCKS)
+*
+* HMS calorimeter. Calibration constants
+*
+ real*4 hcal_pos_cal_const !Calibration constants for pos PMTs
+ real*4 hcal_neg_cal_const !Calibration constants for neg PMTs
+ common/hms_cal_const/
+ & hcal_pos_cal_const(HMAX_CAL_BLOCKS),
+ & hcal_neg_cal_const(HMAX_CAL_BLOCKS)
+*
+* HMS calorimeter. Relative gains & correction factors
+*
+ real*4 hcal_pos_gain_ini !Relative gains during the last calibration
+ real*4 hcal_pos_gain_cur !Current relative gains
+ real*4 hcal_pos_gain_cor !Correction factor: cor=ini/cur
+ real*4 hcal_neg_gain_ini !Relative gains during the last calibration
+ real*4 hcal_neg_gain_cur !Current relative gains
+ real*4 hcal_neg_gain_cor !Correction factor: cor=ini/cur
+ common/hms_cal_monitor/
+ & hcal_pos_gain_ini(HMAX_CAL_BLOCKS),
+ & hcal_pos_gain_cur(HMAX_CAL_BLOCKS),
+ & hcal_pos_gain_cor(HMAX_CAL_BLOCKS),
+ & hcal_neg_gain_ini(HMAX_CAL_BLOCKS),
+ & hcal_neg_gain_cur(HMAX_CAL_BLOCKS),
+ & hcal_neg_gain_cor(HMAX_CAL_BLOCKS)
+*
+* HMS calorimeter. Debuging LUN and flags
+*
+ integer*4 hlun_dbg_cal
+ integer*4 hdbg_raw_cal
+ integer*4 hdbg_sparsified_cal
+ integer*4 hdbg_decoded_cal
+ integer*4 hdbg_clusters_cal
+ integer*4 hdbg_tracks_cal
+ integer*4 hdbg_tests_cal
+ integer*4 hcal_num_neg_columns
+ common/hms_cal_flags/
+ & hlun_dbg_cal,
+ & hdbg_raw_cal,
+ & hdbg_sparsified_cal,
+ & hdbg_decoded_cal,
+ & hdbg_clusters_cal,
+ & hdbg_tracks_cal,
+ & hdbg_tests_cal,
+ $ hcal_num_neg_columns
+
+*
+* CTPTYPE=event
+*
+ integer*4 hcal_zero_sum(HMAX_CAL_BLOCKS)
+ integer*4 hcal_zero_sum2(HMAX_CAL_BLOCKS)
+ integer*4 hcal_zero_num(HMAX_CAL_BLOCKS)
+ real*4 hcal_zero_ave(HMAX_CAL_BLOCKS)
+ real*4 hcal_zero_sig(HMAX_CAL_BLOCKS)
+ real*4 hcal_zero_thresh(HMAX_CAL_BLOCKS)
+
+ common /hms_cal_zero/
+ & hcal_zero_ave,
+ & hcal_zero_sig,
+ & hcal_zero_thresh,
+ & hcal_zero_num,
+ & hcal_zero_sum,
+ & hcal_zero_sum2
+
+*
+* CTPTYPE=event
+*
+ real*4 hscal_suma !normalized sum of layer A.
+ real*4 hscal_sumb !normalized sum of layer B.
+ real*4 hscal_sumc !normalized sum of layer C.
+ real*4 hscal_sumd !normalized sum of layer D.
+ real*4 hsprsum !normalized PR sum.
+ real*4 hsshsum !normalized total sum.
+ real*4 hsprtrk !normalized PR sum on track.
+ real*4 hsshtrk !normalized total sum on track.
+
+ common /hms_cal_normalized/
+ & hscal_suma,
+ & hscal_sumb,
+ & hscal_sumc,
+ & hscal_sumd,
+ & hsprsum,
+ & hsshsum,
+ & hsprtrk,
+ & hsshtrk
diff --git a/INCLUDE/hms_cer_parms.cmn b/INCLUDE/hms_cer_parms.cmn
new file mode 100644
index 0000000..f2c4148
--- /dev/null
+++ b/INCLUDE/hms_cer_parms.cmn
@@ -0,0 +1,81 @@
+* hms_cer_parms.cmn
+*
+* $Log: hms_cer_parms.cmn,v $
+* Revision 1.2 2002/12/20 21:52:33 jones
+* Modified by Hamlet for new HMS aerogel
+*
+* Revision 1.1 1995/08/08 19:15:12 cdaq
+* Initial revision
+*
+*
+* CTPTYPE=parm
+*
+ real*4 hcer_chi2max
+ real*4 hcer_beta_min
+ real*4 hcer_beta_max
+ real*4 hcer_et_min
+ real*4 hcer_et_max
+ real*4 hcer_mirror_zpos
+ real*4 hcer_region
+ real*4 hcer_min_eff
+ real*4 hcer_threshold
+
+ integer*4 hcer_num_mirrors
+ parameter(hcer_num_mirrors=2)
+ integer*4 hcer_num_regions
+ parameter(hcer_num_regions=hcer_num_mirrors+1)
+
+ common/hms_cer_parms/
+ & hcer_chi2max,
+ & hcer_beta_min,
+ & hcer_beta_max,
+ & hcer_et_min,
+ & hcer_et_max,
+ & hcer_mirror_zpos,
+ & hcer_region(hcer_num_regions,8),
+ & hcer_min_eff,
+ & hcer_threshold
+*
+* CTPTYPE=parm
+*
+ real*4 hcer_adc_to_npe(hcer_num_mirrors)
+
+ integer*4 hcer_ped(hcer_num_mirrors)
+ integer*4 hcer_width(hcer_num_mirrors)
+
+ common/hms_cer_trans/
+ & hcer_ped,
+ & hcer_width,
+ & hcer_adc_to_npe
+*
+* CTPTYPE=event
+*
+ real*4 hcer_region_eff(hcer_num_regions)
+
+ integer*4 hcer_track_counter(hcer_num_regions)
+ integer*4 hcer_fired_counter(hcer_num_regions)
+
+ integer*4 hcer_min_counts
+ parameter(hcer_min_counts=1)
+
+ common/hms_cer_effs/
+ & hcer_track_counter,
+ & hcer_fired_counter,
+ & hcer_region_eff
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
diff --git a/INCLUDE/hms_data_structures.cmn b/INCLUDE/hms_data_structures.cmn
new file mode 100644
index 0000000..60f043d
--- /dev/null
+++ b/INCLUDE/hms_data_structures.cmn
@@ -0,0 +1,775 @@
+*****************begin: hms_data_structures.cmn*************************
+*
+* include file hms_data_structures.cmn
+*
+* Author: D. F. Geesaman 1 September 1993
+*
+* $Log: hms_data_structures.cmn,v $
+* Revision 1.12.20.1.2.4 2009/09/16 19:00:45 jones
+* Move SANE_HMS_ANGLE_THETA, SANE_HMS_ANGLE_PHI to sane_data_structures.cmn
+*
+* Revision 1.12.20.1.2.3 2009/09/15 20:33:31 jones
+* New variables used in h_track.f
+*
+* Revision 1.12.20.1.2.2 2008/10/25 12:38:14 cdaq
+* *** empty log message ***
+*
+* Revision 1.12.20.1.2.1 2008/10/02 18:01:49 cdaq
+* *** empty log message ***
+*
+* Revision 1.12.20.1 2007/08/22 19:09:31 frw
+* added FPP
+*
+* Revision 1.13 2006/06/22 frw
+* added FPP definitions
+*
+* Revision 1.12 2003/09/05 20:39:18 jones
+* Merge in online03 changes (mkj)
+*
+* Revision 1.11 2003/04/01 13:55:08 jones
+* Add variables hntracks_max_fp and h_remove_sppt_if_one_y_plane to
+* hms_tracking.cmn
+*
+* Revision 1.10.2.2 2003/07/15 19:04:03 cdaq
+* add hsinplane
+*
+* Revision 1.10.2.1 2003/04/10 12:36:56 cdaq
+* comments added
+*
+* Revision 1.10 2003/01/02 18:34:51 jones
+* change HNTRACKS_MAX from 5 to 20
+*
+* Revision 1.9 2002/12/20 21:52:34 jones
+* Modified by Hamlet for new HMS aerogel
+*
+*
+* Revision 1.9 2002/09/26
+* (Hamlet) Add structures for HMS Aerogel
+*
+* Revision 1.8 1999/02/23 19:09:29 csa
+* Change some physics vars
+*
+* Revision 1.7 1999/01/21 21:40:31 saw
+* Extra shower counter tube modifications
+*
+* Revision 1.6 1998/12/17 22:02:41 saw
+* Support extra set of tubes on HMS shower counter
+*
+* Revision 1.5 1996/09/04 15:49:31 saw
+* (SAW) Double of all ' 's in comments
+*
+* Revision 1.4 1996/01/24 16:18:59 saw
+* (JRA) Cosmetic change
+*
+* Revision 1.3 1996/01/17 16:00:02 cdaq
+* (JRA) ADD HCER_RAW_ADC and HSCIN_FPTIME
+*
+* Revision 1.2 1995/08/11 16:28:46 cdaq
+* (CC) Add structure for # of photoelectrons in Cerenkov
+*
+* Revision 1.1 1995/05/22 18:41:15 cdaq
+* Initial revision
+*
+*
+* CTPTYPE=parm
+*
+* HTHETA_LAB HMS LAB ANGLE THETA (RADIANS)
+* HPHI_LAB HMS LAB ANGLE PHI
+* HPCENTRAL HMS CENTRAL MOMENUTM (GEV)
+* HBFIELD HMS B FIELD INCLUDING SIGN
+*
+ REAL*4 HTHETA_LAB ! HMS LAB ANGLE THETA (RADIANS)
+ REAL*4 HPHI_LAB ! HMS LAB ANGLE PHI
+ REAL*4 HPCENTRAL ! HMS CENTRAL MOMENUTM (GEV)
+ REAL*4 HBFIELD ! HMS B FIELD INCLUDING SIGN
+ REAL*4 HPARTMASS ! EXPECTED MASS OF DETECTED PARTICLE IN HMS
+
+ COMMON/HMS_SPECTROMETER/
+ & HTHETA_LAB,
+ & HPHI_LAB,
+ & HPCENTRAL,
+ & HBFIELD,
+ & HPARTMASS
+*
+* CTPTYPE=event
+*
+* HMS DECODED DATA
+*
+* FILLED BY G_decode_event_by_banks
+* HMS DRIFT CHAMBER HITS
+* EACH CHAMBER HIT (TDC VALUE) HAS A
+* PLANE NUMBER
+* WIRE NUMBER
+* TDC VALUE
+*
+* THE TOTAL NUMBER OF HITS IS GIVEN IN HDC_RAW_TOT_HITS
+*
+ INTEGER*4 HMAX_DC_HITS ! MAXIUM NUMBER OF DRIFT CHAMBER HITS
+ INTEGER*4 HMAX_NUM_DC_PLANES ! MAX NUMBER OF HMS DRIFT CHAMBER PLANES
+ INTEGER*4 HMAX_NUM_CHAMBERS ! NUMBER OF HMS DRIFT CHAMBERS
+ PARAMETER(HMAX_DC_HITS=3600)
+ PARAMETER(HMAX_NUM_DC_PLANES=12)
+ PARAMETER(HMAX_NUM_CHAMBERS=2)
+ INTEGER*4 HDC_RAW_PLANE_NUM
+ INTEGER*4 HDC_RAW_WIRE_NUM
+ INTEGER*4 HDC_RAW_TDC
+ INTEGER*4 HDC_RAW_TOT_HITS
+ COMMON/HMS_RAW_DC/
+ 1 HDC_RAW_PLANE_NUM(HMAX_DC_HITS),
+ 2 HDC_RAW_WIRE_NUM(HMAX_DC_HITS),
+ 3 HDC_RAW_TDC(HMAX_DC_HITS),
+ 4 HDC_RAW_TOT_HITS
+*
+* HMS DECODED DC DATA
+*
+* FILLED BY H_TRANS_DC TRANSLATION ROUTINE
+* HMS DRIFT CHAMBER HITS
+* EACH CHAMBER HIT (TDC VALUE) HAS A
+* PLANE NUMBER
+* WIRE NUMBER
+* TDC VALUE
+* DRIFT TIME
+* DRIFT DISTANCE
+* GENERALIZED COORDINATE OF HIT WIRE CENTER
+* GENERALIZED COORDINATE OF HIT PERPENDICULAR TO WIRE DIRECTION
+*
+* THE TOTAL NUMBER OF HITS IN EACH PLANE IS GIVEN IN HDC_HITS_PER_PLANE(I)
+* THE TOTAL NUMBER OF HITS IS GIVEN IN HDC_TOT_HITS
+*
+ INTEGER*4 HDC_PLANE_NUM ! copied from HMS_RAW_DC
+ INTEGER*4 HDC_WIRE_NUM ! copied from HMS_RAW_DC
+ INTEGER*4 HDC_TDC ! copied from HMS_RAW_DC
+ INTEGER*4 HDC_TOT_HITS
+ REAL*4 HDC_DRIFT_TIME
+ REAL*4 HDC_DRIFT_DIS
+ REAL*4 HDC_WIRE_CENTER
+ REAL*4 HDC_WIRE_COORD
+ COMMON/HMS_DECODED_DC/
+ 1 HDC_DRIFT_TIME(HMAX_DC_HITS),
+ 2 HDC_DRIFT_DIS(HMAX_DC_HITS),
+ 3 HDC_WIRE_CENTER(HMAX_DC_HITS),
+ 4 HDC_WIRE_COORD(HMAX_DC_HITS),
+ 5 HDC_PLANE_NUM(HMAX_DC_HITS),
+ 6 HDC_WIRE_NUM(HMAX_DC_HITS),
+ 7 HDC_TDC(HMAX_DC_HITS),
+ 9 HDC_TOT_HITS
+*
+* HMS RAW SCINTILLATOR HITS
+* FILLED BY g_decode_evebt_by_banks
+* EACH SCINTILLATOR HIT IS SPECIFIED BY A
+* SCINTILLATOR PLANE NUMBER
+* SCINTILLATOR COUNTER NUMBER
+* SCINTILLATOR ADC AT POSITIVE GENERALIZED COORDINATE END
+* SCINTILLATOR ADC AT NEGATIVE GENERALIZED COORDINATE END
+* SCINTILLATOR TDC AT POSITIVE GENERALIZED COORDINATE END
+* SCINTILLATOR TDC AT NEGATIVE GENERALIZED COORDINATE END
+* THE TOTAL NUMBER OF HITS IS GIVEN BY HSCIN_ALL_TOT_HITS
+ INTEGER*4 HMAX_ALL_SCIN_HITS ! MAXIMUM TOTAL NUMBER OF SCIN HITS
+ PARAMETER (HMAX_ALL_SCIN_HITS=53) ! Number of elements + 1
+ INTEGER*4 HNUM_ALL_SCIN_PLANES ! TOTAL NUMBER OF SCIN PLANES
+ PARAMETER (HNUM_ALL_SCIN_PLANES=4)
+ INTEGER*4 HSCIN_ALL_PLANE_NUM
+ INTEGER*4 HSCIN_ALL_COUNTER_NUM
+ INTEGER*4 HSCIN_ALL_ADC_POS
+ INTEGER*4 HSCIN_ALL_ADC_NEG
+ INTEGER*4 HSCIN_ALL_TDC_POS
+ INTEGER*4 HSCIN_ALL_TDC_NEG
+ INTEGER*4 HSCIN_ALL_TOT_HITS
+*
+ COMMON/HMS_RAW_SCIN/
+ & HSCIN_ALL_PLANE_NUM(HMAX_ALL_SCIN_HITS),
+ & HSCIN_ALL_COUNTER_NUM(HMAX_ALL_SCIN_HITS),
+ & HSCIN_ALL_ADC_POS(HMAX_ALL_SCIN_HITS),
+ & HSCIN_ALL_ADC_NEG(HMAX_ALL_SCIN_HITS),
+ & HSCIN_ALL_TDC_POS(HMAX_ALL_SCIN_HITS),
+ & HSCIN_ALL_TDC_NEG(HMAX_ALL_SCIN_HITS),
+ & HSCIN_ALL_TOT_HITS
+*
+* HMS REAL SCINTILLATOR HITS (Hits with no TDC data stripped out)
+* FILLED BY H_strip_scin (which is called by h_trans_scin)
+* EACH SCINTILLATOR HIT IS SPECIFIED BY A
+* SCINTILLATOR PLANE NUMBER
+* SCINTILLATOR COUNTER NUMBER
+* SCINTILLATOR ADC AT POSITIVE GENERALIZED COORDINATE END
+* SCINTILLATOR ADC AT NEGATIVE GENERALIZED COORDINATE END
+* SCINTILLATOR TDC AT POSITIVE GENERALIZED COORDINATE END
+* SCINTILLATOR TDC AT NEGATIVE GENERALIZED COORDINATE END
+* THE TOTAL NUMBER OF HITS IS GIVEN BY HSCIN_TOT_HITS
+ INTEGER*4 HMAX_SCIN_HITS ! MAXIMUM TOTAL NUMBER OF SCIN HITS
+ PARAMETER (HMAX_SCIN_HITS=53) ! Number of elements + 1
+ INTEGER*4 HNUM_SCIN_PLANES ! TOTAL NUMBER OF SCIN PLANES
+ PARAMETER (HNUM_SCIN_PLANES=4)
+ INTEGER*4 HNUM_SCIN_ELEMENTS
+ PARAMETER (HNUM_SCIN_ELEMENTS=16)
+ INTEGER*4 HSCIN_PLANE_NUM
+ INTEGER*4 HSCIN_COUNTER_NUM
+ REAL*4 HSCIN_ADC_POS
+ REAL*4 HSCIN_ADC_NEG
+ INTEGER*4 HSCIN_TDC_POS
+ INTEGER*4 HSCIN_TDC_NEG
+ INTEGER*4 HSCIN_TOT_HITS
+ INTEGER*4 HSCIN_SING_COUNTER ! DJM''s registered hit counter
+*
+ COMMON/HMS_REAL_SCIN/
+ & HSCIN_PLANE_NUM(HMAX_SCIN_HITS),
+ & HSCIN_COUNTER_NUM(HMAX_SCIN_HITS),
+ & HSCIN_ADC_POS(HMAX_SCIN_HITS),
+ & HSCIN_ADC_NEG(HMAX_SCIN_HITS),
+ & HSCIN_TDC_POS(HMAX_SCIN_HITS),
+ & HSCIN_TDC_NEG(HMAX_SCIN_HITS),
+ & HSCIN_TOT_HITS,
+ & HSCIN_SING_COUNTER(HNUM_SCIN_PLANES)
+*
+*
+* DECODED SCIN HITS
+* FILLED BY H_TRANS_SCIN
+* THIS USES SCINTILLATOR INFORMATION ONLY TO CALCUATE
+* HSCIN_APPROX_HIT_COORD GENERALIZED COORDINATE ALONG HIT
+* SCINTILLATOR DETERMINED FROM TDC INFO.
+* HSCIN_COR_ADC CORRECTED PULSE HEIGHT AT HIT
+* HSCIN_COR_TIME CORRECTED TIME AT HIT
+* THE TOTAL NUMBER OF HITS IN EACH PLANE IS GIVEN BY HSCIN_HITS_PER_PLANE
+* THE HSTART_TIME IS DEFINED AS THE TIME IF THE TRACK HAD GONE THROUGH
+* THE CENTER OF S1X. IT IS USED BY H_TRANS_DC FOR THE DRIFT TIME
+* CALCULATION.
+* HTWO_GOOD_TIMES IS A LOGICAL VARIABLE WHICH IS TRUE IF BOTH ENDS
+* OF THE SCINTILLATOR ARE HIT AND FALSE IF ONLY ONE END IS HIT.
+* HGOOD_START_TIME IS TRUE IF A START TIME WAS FOUND
+*
+ REAL*4 HSCIN_ZPOS(HMAX_SCIN_HITS)
+ REAL*4 HSCIN_CENTER_COORD(HMAX_SCIN_HITS)
+ REAL*4 HSCIN_DEC_HIT_COORD(HMAX_SCIN_HITS)
+ REAL*4 HSCIN_WIDTH(HMAX_SCIN_HITS)
+ REAL*4 HSCIN_SLOP(HMAX_SCIN_HITS)
+ REAL*4 HSCIN_COR_ADC(HMAX_SCIN_HITS)
+ REAL*4 HSCIN_COR_TIME(HMAX_SCIN_HITS)
+ REAL*4 HSTART_TIME
+ INTEGER*4 HSTART_HITNUM
+ INTEGER*4 HSTART_HITSIDE
+ INTEGER*4 HSCIN_HITS_PER_PLANE(HNUM_SCIN_PLANES)
+ LOGICAL*4 HTWO_GOOD_TIMES(HMAX_SCIN_HITS)
+ LOGICAL*4 HGOOD_START_TIME
+
+ COMMON/HMS_DECODED_SCIN/
+ & HSCIN_ZPOS,
+ & HSCIN_CENTER_COORD,
+ & HSCIN_WIDTH,
+ & HSCIN_SLOP,
+ & HSCIN_DEC_HIT_COORD,
+ & HSCIN_COR_ADC,
+ & HSCIN_COR_TIME,
+ & HSTART_TIME,
+ & HSCIN_HITS_PER_PLANE,
+ & HSTART_HITNUM,
+ & HSTART_HITSIDE,
+ & HTWO_GOOD_TIMES,
+ & HGOOD_START_TIME
+*
+*
+* HMS CALORIMETER HITS
+*
+* ALLOW FOR NO SPARCIFICATION OF SHOWER COUNTER ELEMENTS
+*
+* EACH COUNTER HAS A
+* COLUMN NUMBER
+* ROW NUMBER
+* ADC VALUE AT Positive End (This end if only one end used)
+* ADC VALUE AT Negative End
+*
+* THE TOTAL NUMBER OF SHOWER HITS IS HCAL_TOT_HITS
+*
+ INTEGER*4 HMAX_CAL_BLOCKS ! TOTAL NUMBER OF SHOWER BLOCKS
+ PARAMETER (HMAX_CAL_BLOCKS=52)
+ INTEGER*4 HMAX_CAL_ROWS !Number of calorimeter rows
+ PARAMETER (HMAX_CAL_ROWS=13)
+ INTEGER*4 HMAX_CAL_COLUMNS !Number of calorimeter columns
+ PARAMETER (HMAX_CAL_COLUMNS=4)
+ INTEGER*4 HCAL_TOT_HITS
+ INTEGER*4 HCAL_POS_HITS
+ INTEGER*4 HCAL_NEG_HITS
+ INTEGER*4 HCAL_COLUMN(HMAX_CAL_BLOCKS)
+ INTEGER*4 HCAL_ROW(HMAX_CAL_BLOCKS)
+ INTEGER*4 HCAL_ADC_POS(HMAX_CAL_BLOCKS)
+ INTEGER*4 HCAL_ADC_NEG(HMAX_CAL_BLOCKS)
+ INTEGER*4 HCAL_ADC(HMAX_CAL_BLOCKS)
+ equivalence (hcal_adc, hcal_adc_pos) ! For old code
+ REAL*4 HCAL_REALADC_POS(HMAX_CAL_BLOCKS)
+ REAL*4 HCAL_REALADC_NEG(HMAX_CAL_BLOCKS)
+ REAL*4 HCAL_REALADC(HMAX_CAL_BLOCKS)
+ equivalence (hcal_realadc, hcal_realadc_pos)
+
+ COMMON/HMS_RAW_CAL/
+ & HCAL_COLUMN,
+ & HCAL_ROW,
+ & HCAL_ADC_POS,
+ & HCAL_ADC_NEG,
+ & HCAL_REALADC_POS,
+ & HCAL_REALADC_NEG,
+ & HCAL_TOT_HITS,
+ & HCAL_POS_HITS,
+ & HCAL_NEG_HITS
+*
+* DECODED CALORIMETER QUANTITIES
+* FILLED BY H_TRANS_CAL USING ONLY THE CALORIMETER INFORMATION
+*
+* X COORDINATE OF BLOCK CENTER
+* Z COORDINATE OF BLOCK CENTER
+* ENERGY DEPOSITED IN THE BLOCK
+* ENERGY DEPOSITED IN COLUMN #1
+* #2
+* #3
+* #4
+* TOTAL ENERGY IN THE CALORIMETER
+ INTEGER*4 HNHITS_CAL !NUMBER OF CALORIMETER HITS ABOVE THRESHOLD
+ REAL*4 HBLOCK_XC !X COORDINATE OF BLOCK CENTER
+ REAL*4 HBLOCK_ZC !Z COORDINATE OF BLOCK CENTER
+ REAL*4 HBLOCK_DE !ENERGY DEPOSITION IN THE BLOCKS
+ REAL*4 HCAL_E1 !ENERGY DEPOSITION IN COLUMN #1
+ REAL*4 HCAL_E2 ! #2
+ REAL*4 HCAL_E3 ! #3
+ REAL*4 HCAL_E4 ! #4
+ REAL*4 HCAL_ET !TOTAL ENERGY IN THE CALORIMETER
+ REAL*4 HCAL_E1_POS
+ REAL*4 HCAL_E1_NEG
+ REAL*4 HCAL_E2_POS
+ REAL*4 HCAL_E2_NEG
+ REAL*4 HBLOCK_DE_POS
+ REAL*4 HBLOCK_DE_NEG
+ COMMON/HMS_DECODED_CAL/
+ & HBLOCK_XC(HMAX_CAL_BLOCKS),
+ & HBLOCK_ZC(HMAX_CAL_BLOCKS),
+ & HBLOCK_DE(HMAX_CAL_BLOCKS),
+ & HCAL_E1,
+ & HCAL_E2,
+ & HCAL_E3,
+ & HCAL_E4,
+ & HCAL_ET,
+ & HCAL_E1_POS,
+ & HCAL_E1_NEG,
+ & HCAL_E2_POS,
+ & HCAL_E2_NEG,
+ & HBLOCK_DE_POS(HMAX_CAL_BLOCKS),
+ & HBLOCK_DE_NEG(HMAX_CAL_BLOCKS),
+ & HNHITS_CAL
+*
+* HMS CERENKOV HITS
+* FILLED BY G_decode_event_by_banks
+*
+* THERE ARE TWO CERENKOV PHOTOTUBES. EACH HIT HAS
+* TUBE NUMBER
+* ADC VALUE
+* THE TOTAL NUMBER OF PHOTOTUBE HITS IS HCER_TOT_HITS
+* HOWEVER TO MAKE THE DECODERS SYMMETRICAL TO A SCINT WE MUST ADD
+* A DUMMY PLANE NUMBER.
+ INTEGER*4 HMAX_CER_HITS
+ PARAMETER(HMAX_CER_HITS=2)
+ INTEGER*4 HCER_TOT_HITS
+ INTEGER*4 HCER_TUBE_NUM
+ INTEGER*4 HCER_RAW_ADC
+ INTEGER*4 HCER_PLANE
+ COMMON/HMS_RAW_CER/
+ & HCER_TUBE_NUM(HMAX_CER_HITS),
+ & HCER_RAW_ADC(HMAX_CER_HITS),
+ & HCER_PLANE(HMAX_CER_HITS),
+ & HCER_TOT_HITS
+*
+* DECODED CERENKOV QUANTITIES
+* FILLED BY H_TRANS_CER
+*
+ INTEGER*4 HCER_NUM_HITS ! NUMBER OF CERENKOV HITS ABOVE THRESHOLD
+ REAL*4 HCER_NPE ! ADC CONVERTED TO NUMBER OF PHOTOELECTRONS
+ REAL*4 HCER_NPE_SUM ! SUM OVER TUBES OF NPE''S
+ REAL*4 HCER_ADC ! PED SUBTRACTED ADC FOR EACH *TUBE*
+ COMMON/HCER_DECODED_CER/
+ & HCER_NUM_HITS,
+ & HCER_NPE(HMAX_CER_HITS),
+ & HCER_NPE_SUM,
+ & HCER_ADC(HMAX_CER_HITS)
+*
+*..........................................................................
+* (Last revison 01 Dec'02; Hamlet)
+*
+* HMS AEROGEL HITS
+* FILLED BY G_decode_event_by_banks
+*
+* THERE ARE 16 AEROGEL PHOTOTUBES. We will pair tubes on the left and
+* right side so that are 8 "counters".
+* POS pmt's on the positive side of Y axis (as for Hodoscope)
+*
+* TUBE Row
+* ADC Left VALUE
+* ADC Right VALUE
+* THE TOTAL NUMBER OF PHOTOTUBE HITS IS HAERO_TOT_HITS
+* HOWEVER TO MAKE THE DECODERS SYMMETRICAL TO A SCINT WE MUST ADD
+* A DUMMY PLANE NUMBER.
+ INTEGER*4 HMAX_AERO_HITS
+ PARAMETER(HMAX_AERO_HITS=8)
+ INTEGER*4 HNUM_AERO_BLOCKS
+ PARAMETER(HNUM_AERO_BLOCKS=8)
+ INTEGER*4 HAERO_TOT_HITS
+ INTEGER*4 HAERO_PLANE
+ INTEGER*4 HAERO_PAIR_NUM
+ INTEGER*4 HAERO_ADC_POS
+ INTEGER*4 HAERO_ADC_NEG
+ INTEGER*4 HAERO_TDC_POS
+ INTEGER*4 HAERO_TDC_NEG
+ COMMON/HMS_RAW_AERO/
+ & HAERO_PLANE(HMAX_AERO_HITS),
+ & HAERO_PAIR_NUM(HMAX_AERO_HITS),
+ & HAERO_ADC_POS(HMAX_AERO_HITS),
+ & HAERO_ADC_NEG(HMAX_AERO_HITS),
+ & HAERO_TDC_POS(HMAX_AERO_HITS),
+ & HAERO_TDC_NEG(HMAX_AERO_HITS),
+ & HAERO_TOT_HITS
+
+*
+*..........................................................................
+*
+*
+* HMS DETECTOR TRACK QUANTITIES
+* FILLED BY H_TRACK SUBROUTINE
+*
+ INTEGER*4 HNTRACKS_MAX ! size of array
+ PARAMETER (HNTRACKS_MAX=20) ! SET MAXIMUM TO 20
+ INTEGER*4 HNTRACKHITS_MAX ! MAXIMUM NUMBER OF HITS IN EACH TRACK
+ PARAMETER (HNTRACKHITS_MAX=16) ! SET MAXIMUM TO 15
+ INTEGER*4 HNTRACKS_FP ! NUMBER OF FOCAL PLANE TRACKS FOUND
+ INTEGER*4 HSTUBS ! NUMBER OF STUBS
+* ALL THE FOLLOWING VARIABLES ARE ARRAYS
+*
+ REAL*4 HX_FP ! X POSITION OF TRACK IN FOCAL PLANE
+ REAL*4 HY_FP ! Y POSITION OF TRACK IN FOCAL PLANE
+ REAL*4 HZ_FP ! Z POSITION OF TRACK IN FOCAL PLANE
+ REAL*4 HXP_FP ! X SLOPE OF TRACK IN FOCAL PLANE
+ REAL*4 HYP_FP ! Y SLOPE OF TRACK IN FOCAL PLANE
+ REAL*4 HCHI2_FP ! FIT QUALITY IN FOCAL PLANE
+ REAL*4 H_BDL ! Bdl of track thru target field
+ REAL*4 HCHI2PERDOF_FP ! fp chi2 per degree of freedom
+ INTEGER*4 HNFREE_FP ! NUMBER OF DEGREES OF FREEDOM IN FIT
+ INTEGER*4 HNTRACK_HITS ! LIST OF HITS ON EACH TRACK
+ REAL*4 HDEL_FP ! FOCAL PLANE ERROR MATRIX
+ REAL*4 HX_FP_rot ! x in rotated focal plane
+ REAL*4 HY_FP_rot ! y in rotated f plane
+ REAL*4 HXP_FP_rot ! x slope in rotated f plane
+ REAL*4 HYP_FP_rot ! y slope in rot f plane
+
+* THE FOCAL PLANE ERROR MATRIX IS A 4 BY 4 BY HNTRACK_MAX ARRAY
+* THE FOUR INDECIES FOR EACH TRACK ARE X, XP, Y, YP
+* THE ERROR MATRIX FOR EACH TRACK IS SYMMETRIC ABOUT THE DIAGONAL
+* DELXX DELXXP DELXY DELXYP
+* DELXPX DELXPXP DELXPY DELXPYP
+* DELYPX DELYXP DELYY DELYYP
+* DELYPX DELYPXP DELYPY DELYPYP
+ COMMON/HMS_FOCAL_PLANE/
+ 1 H_BDL(HNTRACKS_MAX),
+ 1 HX_FP(HNTRACKS_MAX),
+ 2 HY_FP(HNTRACKS_MAX),
+ 3 HZ_FP(HNTRACKS_MAX),
+ 4 HXP_FP(HNTRACKS_MAX),
+ 5 HYP_FP(HNTRACKS_MAX),
+ 6 HCHI2_FP(HNTRACKS_MAX),
+ 7 HDEL_FP(4,4,HNTRACKS_MAX),
+ 8 HNTRACK_HITS(HNTRACKS_MAX,HNTRACKHITS_MAX+1),
+ 9 HNFREE_FP(HNTRACKS_MAX),
+ A HNTRACKS_FP,HSTUBS,HCHI2PERDOF_FP(HNTRACKS_MAX),
+ > HX_FP_rot(HNTRACKS_MAX),
+ > HY_FP_rot(HNTRACKS_MAX),
+ > HXP_FP_rot(HNTRACKS_MAX),
+ > HYP_FP_rot(HNTRACKS_MAX)
+
+
+
+* HMS TARGET QUANTITIES
+* ASSUME THE SAME NUMBER OF MAXIMUM TRACKS AS IN THE FOCAL PLANE
+* HNTRACKS_MAX
+*
+* FILLED BY H_TARG_TRANS SUBROUTINE
+ INTEGER*4 HNTRACKS_TAR ! NUMBER OF TARGET TRACKS FOUND
+* ALL THE FOLLOWING VARIABLES ARE ARRAYS
+*
+ REAL*4 HX_TAR ! X POSITION OF TRACK AT TARGET
+ REAL*4 HY_TAR ! Y POSITION OF TRACK AT TARGET
+ REAL*4 HZ_TAR ! Z POSITION OF TRACK AT TARGET
+ REAL*4 HXP_TAR ! X SLOPE OF TRACK AT TARGET
+ REAL*4 HYP_TAR ! Y SLOPE OF TRACK AT TARGET
+ REAL*4 HDELTA_TAR ! FRACTION TRACK MOMENTUM
+ REAL*4 HP_TAR ! MOMENTUM OF TRACK AT TARGET
+ REAL*4 HCHI2_TAR ! FIT QUALITY AT TARGET
+ INTEGER*4 HNFREE_TAR ! NUMBER OF DEGREES OF FREEDOM IN FIT
+ REAL*4 HDEL_TAR ! TARGET ERROR MATRIX
+* THE FOCAL PLANE ERROR MATRIX IS A 5 BY 5 BY HNTRACK_MAX ARRAY
+* THE FIVE INDECIES FOR EACH TRACK ARE X, Y , XP, YP and P
+* THE ERROR MATRIX FOR EACH TRACK IS SYMMETRIC ABOUT THE DIAGONAL
+* DELXX DELXXP DELXY DELXYP DELXP
+* DELXPX DELXPXP DELXPY DELXPYP DELXPP
+* DELYX DELYXPY DELYY DELYYP DELYP
+* DELYPX DELYPXP DELYPY DELYPYP DELYPP
+* DELPX DELPXP DELPY DELPXP DELPP
+ INTEGER*4 HLINK_TAR_FP ! LINK POINTER TO FOCAL PLANE TRACK NUMBER
+ COMMON/HMS_TARGET/
+ 1 HX_TAR(HNTRACKS_MAX),
+ 2 HY_TAR(HNTRACKS_MAX),
+ 3 HZ_TAR(HNTRACKS_MAX),
+ 4 HXP_TAR(HNTRACKS_MAX),
+ 5 HYP_TAR(HNTRACKS_MAX),
+ 6 HDELTA_TAR(HNTRACKS_MAX),
+ 7 HP_TAR(HNTRACKS_MAX),
+ 8 HCHI2_TAR(HNTRACKS_MAX),
+ 9 HDEL_TAR(5,5,HNTRACKS_MAX),
+ A HNFREE_TAR(HNTRACKS_MAX),
+ B HLINK_TAR_FP(HNTRACKS_MAX),
+ C HNTRACKS_TAR
+*
+*
+* HMS_TRACK_TESTS
+*
+* PARTICLE ID INFORMATION FILLED BY H_TOF and H_CAL
+* THIS STORES THE RESULTS OF SHOWER AND SCINTILLATOR CALCULATIONS
+* FOR EACH OF THE TRACKS GENERATED BY H_TRACK
+*
+ INTEGER*4 HNBLOCKS_CAL(HNTRACKS_MAX)
+ REAL*4 HTRACK_E1(HNTRACKS_MAX)
+ REAL*4 HTRACK_E2(HNTRACKS_MAX)
+ REAL*4 HTRACK_E3(HNTRACKS_MAX)
+ REAL*4 HTRACK_E4(HNTRACKS_MAX)
+ REAL*4 HTRACK_ET(HNTRACKS_MAX)
+ REAL*4 HTRACK_PRESHOWER_E(HNTRACKS_MAX)
+ REAL*4 HTRACK_E1_POS(HNTRACKS_MAX)
+ REAL*4 HTRACK_E1_NEG(HNTRACKS_MAX)
+ REAL*4 HTRACK_E2_POS(HNTRACKS_MAX)
+ REAL*4 HTRACK_E2_NEG(HNTRACKS_MAX)
+*
+ INTEGER*4 HSCIN_HIT(HNTRACKS_MAX,HMAX_SCIN_HITS)
+ INTEGER*4 HNUM_SCIN_HIT(HNTRACKS_MAX)
+ INTEGER*4 HNUM_PMT_HIT(HNTRACKS_MAX)
+ REAL*4 HDEDX(HNTRACKS_MAX,HMAX_SCIN_HITS)
+ REAL*4 HBETA(HNTRACKS_MAX)
+ REAL*4 HBETA_CHISQ(HNTRACKS_MAX)
+ REAL*4 HTIME_AT_FP(HNTRACKS_MAX)
+ REAL*4 HSCIN_FPTIME(HNTRACKS_MAX,HMAX_SCIN_HITS)
+*
+ COMMON/HMS_TRACK_TESTS/
+ 1 HTRACK_E1, ! ENERGY IN FIRST COLUMN NEAR TRACK
+ 2 HTRACK_E2, ! SECOND COLUMN
+ 3 HTRACK_E3, ! THIRD COLUMN
+ 4 HTRACK_E4, ! FOURTH COLUMN
+ 5 HTRACK_ET, ! TOTAL SHOWER ENERGY ALONG TRACK
+ 6 HTRACK_PRESHOWER_E, ! PRESHOWER ENERGY-Note definition is exp. dep.
+ 7 HDEDX, !
+ 8 HBETA, ! VELOCITY OF TRACK
+ 9 HBETA_CHISQ, ! CHISQ OF FIT TO BETA OF TRACK
+ A HTIME_AT_FP, !
+ B HNBLOCKS_CAL, ! NUMBER OF SHOWER BLOCKS ON EACH TRACK
+ C HSCIN_HIT, ! ARRAY OF SCIN HITS ASSOCIATED WITH
+ D ! EACH TRACK
+ E HNUM_SCIN_HIT, ! NUMBER OF HITS FOR EACH TRACK
+ F HNUM_PMT_HIT, ! NUMBER OF PMT HITS FOR EACH TRACK
+ G HSCIN_FPTIME,
+ H HTRACK_E1_POS,
+ I HTRACK_E1_NEG,
+ J HTRACK_E2_POS,
+ K HTRACK_E2_NEG
+*
+* HMS SINGLES PHYSICS COMMON BLOCKS
+* THESE ARE FILLED BY H_PHYSICS
+*
+*
+ REAL*4 HSP ! Lab momentum of chosen track in GeV/c
+ REAL*4 HSENERGY ! Lab total energy of chosen track in GeV
+ REAL*4 HSCORRP ! electron momentum corrected for eloss
+ REAL*4 HSCORRE ! electron energy corrected for eloss
+ REAL*4 HSDELTA ! Spectrometer delta of chosen track
+ REAL*4 HSTHETA ! Lab Scattering angle in radians
+ REAL*4 HSPHI ! Lab Azymuthal angle in radians
+ REAL*4 HSINPLANE ! In plane angle
+ REAL*4 HSMINV ! Invariant Mass of remaing hadronic system
+ REAL*4 HSZBEAM ! Lab Z coordinate of intersection of beam
+ ! track with spectrometer ray
+ REAL*4 HSDEDX(4) ! DEDX of chosen track in each scin plane
+ REAL*4 HSBETA ! BETA of chosen track
+ REAL*4 HSTRACK_ET ! Total shower energy of chosen track
+ REAL*4 HSTRACK_PRESHOWER_E ! preshower of chosen track
+ REAL*4 HSTRACK_E1_POS ! Shower energy E1_POS of chosen track
+ REAL*4 HSTRACK_E1_NEG ! Shower energy E1_NEG of chosen track
+ REAL*4 HSTRACK_E2_POS ! Shower energy E2_POS of chosen track
+ REAL*4 HSTRACK_E2_NEG ! Shower energy E2_NEG of chosen track
+ REAL*4 HSTIME_AT_FP
+ REAL*4 HSX_FP ! X focal plane position
+ REAL*4 HSY_FP
+ REAL*4 HSXP_FP
+ REAL*4 HSYP_FP
+ REAL*4 HSCHI2PERDEG ! CHI2 per degree of freedom of chosen track.
+ REAL*4 HSX_TAR
+ REAL*4 HSY_TAR
+ REAL*4 HSXP_TAR
+ REAL*4 HSYP_TAR
+ REAL*4 HSBETA_CHISQ
+*
+ real*4 hsmass2 ! Mass squared
+ real*4 hst ! invariant t
+ real*4 hsu ! invariant u
+ real*4 hseloss
+ real*4 hsq3 ! Lab frame momentum transfer
+* real*4 hsthetaq, hsphiq ! Direction of q3
+ real*4 hsbigq2 ! Q**2
+ real*4 hsx ! fraction of nucleon p carried by quark
+ real*4 hsy ! fraction of lepton''s E lost in lab
+ real*4 hsw ! Invariant mass of recoil system
+ real*4 hsw2 ! Invariant mass**2 of recoil system
+*
+ INTEGER*4 HSNUM_FPTRACK ! Index of focal plane track chosen
+ INTEGER*4 HSNUM_TARTRACK ! Index of target track chosen
+ INTEGER*4 HSID_LUND ! LUND particle ID code -- not yet filled
+ INTEGER*4 HSNFREE_FP
+ INTEGER*4 HSNUM_SCIN_HIT ! # OF SCINTILLATORS ON TRACK
+ INTEGER*4 HSNUM_PMT_HIT ! # OF HODOSCOPE PMTS ON TRACK
+*
+ COMMON/HMS_PHYSICS_R4/
+ & HSP,
+ & HSENERGY,
+ & HSDELTA,
+ & HSTHETA,
+ & HSPHI,
+ & HSINPLANE,
+ & HSMINV,
+ & HSZBEAM,
+ & HSDEDX,
+ & HSBETA,
+ & HSTRACK_ET,
+ & HSTRACK_PRESHOWER_E,
+ & HSTRACK_E1_POS,
+ & HSTRACK_E1_NEG,
+ & HSTRACK_E2_POS,
+ & HSTRACK_E2_NEG,
+ & HSTIME_AT_FP,
+ & HSX_FP ,
+ & HSY_FP ,
+ & HSXP_FP ,
+ & HSYP_FP ,
+ & HSCHI2PERDEG ,
+ & HSX_TAR ,
+ & HSY_TAR ,
+ & HSXP_TAR ,
+ & HSYP_TAR ,
+ & HSBETA_CHISQ,
+ & hsmass2,
+ & hst,
+ & hsu,
+ & hseloss,
+ & hsq3,
+ & hsbigq2,
+ & hsx,
+ & hsy,
+ & hsw,
+ & hsw2,
+ & hscorrp,
+ & hscorre
+* & hsthetaq,hsphiq
+*
+ COMMON/HMS_PHYSICS_I4/
+ & HSNUM_FPTRACK,
+ & HSNUM_TARTRACK,
+ & HSID_LUND,
+ & HSNFREE_FP,
+ & HSNUM_SCIN_HIT,
+ & HSNUM_PMT_HIT
+*
+*
+* Non-Hits data with HMS gates or starts.
+* (Energy SUMS, logic timing,...)
+*
+ INTEGER HMAX_MISC_HITS
+ PARAMETER(HMAX_MISC_HITS=100)
+ INTEGER*4 HMISC_TOT_HITS
+ INTEGER*4 HMISC_RAW_ADDR1 ! "Plane" (1=TDC,2=ADC)
+ INTEGER*4 HMISC_RAW_ADDR2 ! "Counter"
+ INTEGER*4 HMISC_RAW_DATA
+ COMMON/H_RAW_MISC/
+ & HMISC_RAW_ADDR1(HMAX_MISC_HITS),
+ & HMISC_RAW_ADDR2(HMAX_MISC_HITS),
+ & HMISC_RAW_DATA(HMAX_MISC_HITS),
+ & HMISC_TOT_HITS
+
+*
+* CTPTYPE=parm
+*
+* constants definitions for Foacl Plane Polarimeter (frw 2006/06/22)
+* these are used for array limits etc.
+*
+
+
+ integer HMS_TRIGGER_COUNTER,HMS_TRIGGER_WINDOW
+ common/hmstrig/ HMS_TRIGGER_COUNTER,
+ > HMS_TRIGGER_WINDOW
+
+ integer*4 H_FPP_N_DCSETS ! # of DC sets
+ parameter (H_FPP_N_DCSETS=2)
+
+ integer*4 H_FPP_N_DCINSET ! # of DCs in one set
+ parameter (H_FPP_N_DCINSET=2)
+
+ integer*4 H_FPP_N_DCLAYERS ! # of layers per DC
+ parameter (H_FPP_N_DCLAYERS=3)
+
+ integer*4 H_FPP_N_PLANES ! sets * dc-in-set * layers
+ parameter (H_FPP_N_PLANES=12)
+
+ integer*4 H_FPP_MAX_WIRES ! MAX # of wires per layer
+ parameter (H_FPP_MAX_WIRES=104)
+
+ integer*4 H_FPP_MAX_RAWperPLANE ! MAX # of raw FPP DC hits per plane
+ parameter (H_FPP_MAX_RAWperPLANE=100)
+
+ integer*4 H_FPP_MAX_RAWHITS ! MAX # of raw FPP DC hits total
+ parameter (H_FPP_MAX_RAWHITS=2400)
+
+ integer*4 H_FPP_MAX_CLUSTERS ! MAX # of clusters per layer
+ parameter (H_FPP_MAX_CLUSTERS=15)
+
+ integer*4 H_FPP_MAX_HITSperCLUSTER ! MAX # of hits to group into cluster hit
+ parameter (H_FPP_MAX_HITSperCLUSTER=3)
+
+ integer*4 H_FPP_MAX_TRACKS ! MAX # of tracks per DC set
+ parameter (H_FPP_MAX_TRACKS=9)
+
+ integer*4 H_FPP_MAX_FITPOINTS ! MAX # of space points to fit
+ parameter (H_FPP_MAX_FITPOINTS=18)
+
+* readability constants
+
+ real*4 H_FPP_BAD_COORD ! identifies invalid coordinate
+ parameter (H_FPP_BAD_COORD=9999.9)
+
+ real*4 H_FPP_BAD_TIME ! identifies invalid time
+ parameter (H_FPP_BAD_TIME=9999.9)
+
+ real*4 H_FPP_BAD_CHI2 ! identifies bad fit or no fit
+ parameter (H_FPP_BAD_CHI2=9876.54321)
+
+ real*4 H_FPP_BAD_DRIFT ! identifies bad drift distance
+ parameter (H_FPP_BAD_DRIFT=0.0)
+
+*
+* CTPTYPE=event
+*
+ integer*4 HFPP_raw_tot_hits ! actual # of total FPP hits
+ integer*4 HFPP_raw_plane ! array of plane number of hits
+ integer*4 HFPP_raw_wire ! array of wire number of hits
+ integer*4 HFPP_raw_TDC ! array of TDC value of hits
+
+ common/HMS_RAW_FPP/ HFPP_raw_tot_hits
+ & , HFPP_raw_plane(H_FPP_MAX_RAWHITS)
+ & , HFPP_raw_wire(H_FPP_MAX_RAWHITS)
+ & , HFPP_raw_TDC(H_FPP_MAX_RAWHITS)
+
+
+*
+*
+*
+
+*******************end: hms_data_structures.cmn*************************
+* Local Variables:
+* mode: fortran
+* fortran-continuation-string: "&"
+* comment-column: 35
+* End:
diff --git a/INCLUDE/hms_filenames.cmn b/INCLUDE/hms_filenames.cmn
new file mode 100644
index 0000000..fb23e18
--- /dev/null
+++ b/INCLUDE/hms_filenames.cmn
@@ -0,0 +1,51 @@
+******************* begin: hms_filenames.cmn ***********************
+*
+*-Common block with filenames
+* $Log: hms_filenames.cmn,v $
+* Revision 1.5.6.2 2007/11/29 19:07:19 puckett
+* added special calib and driftmap input filenames for HMS and BigCal
+*
+* Revision 1.5.6.1 2007/05/15 02:53:02 jones
+* Start to Bigcal code
+*
+* Revision 1.5 2005/02/16 20:46:02 saw
+* Add filename for hms root tree
+*
+* Revision 1.4 1996/01/17 16:00:24 cdaq
+* (JRA) Add threshold and pedestal output filenames
+*
+* Revision 1.3 1995/04/06 20:17:07 cdaq
+* (SAW) Add report output filename
+*
+* Revision 1.2 1994/08/03 20:33:34 cdaq
+* (SAW) Add "CTPTYPE=parm" directive for auto generation of CTP reg calls
+*
+* Revision 1.1 1994/06/15 18:12:33 cdaq
+* Initial revision
+*
+* CTPTYPE=parm
+*
+ character*80 h_recon_coeff_filename
+ character*80 h_report_template_filename ! CTP file with hms report
+ character*80 h_report_blockname
+ character*80 h_report_output_filename
+ character*80 h_threshold_output_filename
+ character*80 h_pedestal_output_filename
+ character*80 h_tree_filename
+ character*80 h_angle_output_filename
+ character*80 h_driftmap_input_filename
+
+ logical h_driftmap_rebook
+*
+ common /hms_filenames/
+ $ h_recon_coeff_filename,
+ $ h_report_template_filename,
+ $ h_report_blockname,
+ $ h_report_output_filename,
+ $ h_threshold_output_filename,
+ $ h_pedestal_output_filename,
+ $ h_angle_output_filename,
+ $ h_tree_filename,
+ $ h_driftmap_input_filename,
+ $ h_driftmap_rebook
+*
diff --git a/INCLUDE/hms_fpp_event.cmn b/INCLUDE/hms_fpp_event.cmn
new file mode 100644
index 0000000..9405109
--- /dev/null
+++ b/INCLUDE/hms_fpp_event.cmn
@@ -0,0 +1,164 @@
+* hms_fpp_event.cmn
+*--------------------------------------------------------
+* Hall C HMS Focal Plane Polarimeter Code
+*
+* Purpose: HMS FPP non-raw event common block variables
+*
+* Created by Frank R. Wesselmann, February 2004
+*
+*--------------------------------------------------------
+
+* The following include statments must precede the inclusion of this
+* file in each routine that uses it. The *%% syntax is also a
+* directive to makereg to tell it to include the code in the program
+* that it generates.
+*
+*%% include 'hms_data_structures.cmn'
+*%% include 'gen_detectorids.par'
+*%% include 'gen_decode_common.cmn'
+
+
+
+*
+* CTPTYPE=event
+*
+* mid-level event variables but not quite raw -- use plane numbers
+ integer*4 HFPP_N_planehitsraw ! actual # hits per plane
+ integer*4 HFPP_N_planehits ! useable # hits per plane
+ integer*4 HFPP_Nlayershit_set ! # of layers with usable hits per set of DCs
+ integer*4 HFPP_hit1idx ! pointer to 1st hit on given wire
+ integer*4 HFPP_hit2idx ! pointer to 2nd hit on given wire
+ integer*4 HFPP_trigger_TDC ! TDC value of F1 TDC trigger
+*
+* high level event variables -- determined per event -- uses set,chamber,layer
+ integer*4 HFPP_NplaneClusters ! # of clusters in each plane(!)
+ integer*4 HFPP_nClusters ! # of clusters in each s,c,l
+ integer*4 HFPP_nHitsinCluster ! # of raw hits grouped into cluster
+ integer*4 HFPP_ClusterinTrack ! is this WIDE hit already used?
+ integer*4 HFPP_Clusters ! index in raw hit array for hits
+
+ integer*4 HFPP_Nfreehits ! # unused hits in layer
+ integer*4 HFPP_NlayersWfreehits ! (# layers with >=MIN hits) in chamber
+ integer*4 HFPP_NsetlayersWfreehits ! (# layers with >=MIN hits) in set
+
+ real*4 HFPP_HitTime ! drift time of ALL hits but only
+ ! good hits value is meaningful!
+
+ real*4 HFPP_drift_time ! fully corrected drift time of hits on each wire
+ real*4 HFPP_drift_dist ! drift distance of hits on each wire
+ !!! both only valid if hit is used in track
+ real*4 HFPP_dHMS ! distance between wire and HMS track
+
+ common/HMS_FPP_event/
+ & HFPP_N_planehitsraw(H_FPP_N_PLANES)
+ & , HFPP_N_planehits(H_FPP_N_PLANES)
+ & , HFPP_Nlayershit_set(H_FPP_N_DCSETS)
+ & , HFPP_hit1idx(H_FPP_N_PLANES,H_FPP_MAX_WIRES)
+ & , HFPP_hit2idx(H_FPP_N_PLANES,H_FPP_MAX_WIRES)
+ & , HFPP_NplaneClusters(H_FPP_N_PLANES)
+ & , HFPP_nClusters(H_FPP_N_DCSETS,H_FPP_N_DCINSET,H_FPP_N_DCLAYERS)
+ & , HFPP_nHitsinCluster(H_FPP_N_DCSETS,H_FPP_N_DCINSET,
+ > H_FPP_N_DCLAYERS,H_FPP_MAX_CLUSTERS)
+ & , HFPP_ClusterinTrack(H_FPP_N_DCSETS,H_FPP_N_DCINSET,H_FPP_N_DCLAYERS,
+ > H_FPP_MAX_CLUSTERS)
+ & , HFPP_Clusters(H_FPP_N_DCSETS,H_FPP_N_DCINSET,H_FPP_N_DCLAYERS,
+ > H_FPP_MAX_CLUSTERS,H_FPP_MAX_HITSperCLUSTER)
+ & , HFPP_Nfreehits(H_FPP_N_DCSETS,H_FPP_N_DCINSET,H_FPP_N_DCLAYERS)
+ & , HFPP_NlayersWfreehits(H_FPP_N_DCSETS,H_FPP_N_DCINSET)
+ & , HFPP_NsetlayersWfreehits(H_FPP_N_DCSETS)
+ & , HFPP_HitTime(0:H_FPP_MAX_RAWHITS)
+ & , HFPP_drift_time(H_FPP_N_DCSETS,H_FPP_N_DCINSET,H_FPP_N_DCLAYERS,
+ > H_FPP_MAX_WIRES)
+ & , HFPP_drift_dist(H_FPP_N_DCSETS,H_FPP_N_DCINSET,H_FPP_N_DCLAYERS,
+ > H_FPP_MAX_WIRES)
+ & , HFPP_trigger_TDC(0:G_DECODE_MAXROCS)
+ & , HFPP_dHMS(H_FPP_N_DCSETS,H_FPP_N_DCINSET,H_FPP_N_DCLAYERS,
+ > H_FPP_MAX_CLUSTERS,H_FPP_MAX_HITSperCLUSTER)
+
+
+* readability constants to use when setting HFPP_eventclass
+*
+* CTPTYPE=parm
+*
+ integer*4 H_FPP_ET_NOHITS ! no hits in DC set at all
+ parameter (H_FPP_ET_NOHITS=0)
+ integer*4 H_FPP_ET_FEWHITS ! insufficient hits in DC set (bit 0/1)
+ parameter (H_FPP_ET_FEWHITS=1)
+ integer*4 H_FPP_ET_BAD ! only tracks with bad chi2 (bit 2/3)
+ parameter (H_FPP_ET_BAD=4)
+ integer*4 H_FPP_ET_1GOOD ! only one track had good chi2 (<HFPP_min_chi2) (bit 4/5)
+ parameter (H_FPP_ET_1GOOD=16)
+ integer*4 H_FPP_ET_MANYGOOD ! >1 tracks and at least one had good chi2 (bit 6/7)
+ parameter (H_FPP_ET_MANYGOOD=64)
+ integer*4 H_FPP_ET_1GREAT ! only one track but that one had chi2 <HFPP_aOK_chi2 (bit 4/5 AND 8/9)
+ parameter (H_FPP_ET_1GREAT=272)
+ integer*4 H_FPP_ET_MANYGREAT ! >1 tracks and at least one had chi2 <HFPP_aOK_chi2 (bit 6/7 AND 8/9)
+ parameter (H_FPP_ET_MANYGREAT=320)
+
+
+* tracking variables -- determined per event
+*
+* CTPTYPE=event
+*
+ integer*4 HFPP_eventclass ! simple classification of tracking results
+ ! see above for details
+
+ integer*4 HFPP_N_tracks ! actual # of tracks in set
+
+ integer*4 HFPP_track_Nlayers ! # of layers with hits used on track
+ integer*4 HFPP_track_Nhits ! # of raw hits used on track
+
+ integer*4 HFPP_TrackCluster ! Clusters used in track
+ integer*4 HFPP_TrackHit ! above cluster reduced to 1 wire
+ integer*4 HFPP_track_conetest ! conetest variable
+
+ real*4 HFPP_track_residual ! uTrack - (uWire + drift)
+ real*4 HFPP_track_resolution ! similar but uses special tracking
+ real*4 HFPP_track_angresol ! angular resolution
+
+ real*4 HFPP_track_x ! x of track at focal plane usinf HMS FP coords
+ real*4 HFPP_track_y ! y of track at focal plane
+ real*4 HFPP_track_dx ! dx/dz of track
+ real*4 HFPP_track_dy ! dy/dz of track
+ real*4 HFPP_track_chi2 ! chi**2/df of track
+
+ real*4 HFPP_track_theta ! opening angle betw incident and re-scattered track
+ real*4 HFPP_track_phi ! azimuthal angle
+
+ real*4 HFPP_track_sclose ! closest approach between pre and post anaylser track
+ real*4 HFPP_track_zclose ! z-coord of closest approach
+
+ real*4 HFPP_track_rough ! simple fit results using in-set coordinates
+ ! dx/dz, x, dy/dz, y, chi2, N
+
+ real*4 HFPP_track_fine ! full track params using in-set coordinates
+ ! dx/dz, x, dy/dz, y
+
+
+ common/HMS_FPP_track/
+ & HFPP_eventclass
+ & , HFPP_N_tracks(H_FPP_N_DCSETS)
+ & , HFPP_track_Nlayers(H_FPP_N_DCSETS,H_FPP_MAX_TRACKS)
+ & , HFPP_track_Nhits(H_FPP_N_DCSETS,H_FPP_MAX_TRACKS)
+ & , HFPP_TrackCluster(H_FPP_N_DCSETS,H_FPP_N_DCINSET,
+ > H_FPP_N_DCLAYERS,H_FPP_MAX_TRACKS)
+ & , HFPP_TrackHit(H_FPP_N_DCSETS,H_FPP_N_DCINSET,
+ > H_FPP_N_DCLAYERS,H_FPP_MAX_TRACKS)
+ & , HFPP_track_conetest(H_FPP_N_DCSETS,H_FPP_MAX_TRACKS)
+ & , HFPP_track_x(H_FPP_N_DCSETS,H_FPP_MAX_TRACKS)
+ & , HFPP_track_dx(H_FPP_N_DCSETS,H_FPP_MAX_TRACKS)
+ & , HFPP_track_y(H_FPP_N_DCSETS,H_FPP_MAX_TRACKS)
+ & , HFPP_track_dy(H_FPP_N_DCSETS,H_FPP_MAX_TRACKS)
+ & , HFPP_track_chi2(H_FPP_N_DCSETS,H_FPP_MAX_TRACKS)
+ & , HFPP_track_rough(H_FPP_N_DCSETS,H_FPP_MAX_TRACKS,6)
+ & , HFPP_track_fine(H_FPP_N_DCSETS,H_FPP_MAX_TRACKS,4)
+ & , HFPP_track_sclose(H_FPP_N_DCSETS,H_FPP_MAX_TRACKS)
+ & , HFPP_track_zclose(H_FPP_N_DCSETS,H_FPP_MAX_TRACKS)
+ & , HFPP_track_theta(H_FPP_N_DCSETS,H_FPP_MAX_TRACKS)
+ & , HFPP_track_phi(H_FPP_N_DCSETS,H_FPP_MAX_TRACKS)
+ & , HFPP_track_residual(H_FPP_N_DCSETS,H_FPP_N_DCINSET,
+ > H_FPP_N_DCLAYERS,H_FPP_MAX_TRACKS)
+ & , HFPP_track_resolution(H_FPP_N_DCSETS,H_FPP_N_DCINSET,
+ > H_FPP_N_DCLAYERS,H_FPP_MAX_TRACKS)
+ & , HFPP_track_angresol(H_FPP_N_DCSETS,H_FPP_N_DCINSET,
+ > H_FPP_N_DCLAYERS,H_FPP_MAX_TRACKS)
diff --git a/INCLUDE/hms_fpp_params.cmn b/INCLUDE/hms_fpp_params.cmn
new file mode 100644
index 0000000..7ee9cae
--- /dev/null
+++ b/INCLUDE/hms_fpp_params.cmn
@@ -0,0 +1,128 @@
+* include file hms_fpp_params.cmn
+*--------------------------------------------------------
+* Hall C HMS Focal Plane Polarimeter Code
+*
+* Purpose: HMS FPP control and limit parameter
+*
+* Created by Frank R. Wesselmann, February 2004
+*
+*--------------------------------------------------------
+
+* The following include statments must precede the inclusion of this
+* file in each routine that uses it. The *%% syntax is also a
+* directive to makereg to tell it to include the code in the program
+* that it generates.
+*
+*%% include 'hms_data_structures.cmn'
+*%% include 'gen_detectorids.par'
+*%% include 'gen_decode_common.cmn'
+*
+* CTPTYPE=parm
+*
+ integer*4 HFPP_minTDC ! minimum TDC value to bother with hit
+ integer*4 HFPP_maxTDC ! maximum TDC value to bother with hit
+
+ real*4 HFPP_tdc_time_per_channel ! hms FPP tdc calibration
+
+ real*4 HFPP_wirespeed ! signal propagation speed on sense wires
+
+ real*4 HFPP_particlespeed ! TOF speed of detected particle
+
+ real*4 HFPP_mintime ! min hit time for meaningful drift (= 0 distance)
+ real*4 HFPP_maxtime ! max hit time for meaningful drift (cut noise)
+
+ real*4 HFPP_maxdrift ! maximum drift distance to allow by PLANE
+
+ real*4 HFPP_tDriftOffset ! drift time offsets by PLANE and WIRE
+
+ integer*4 HFPP_optchamberhits ! one chamber must have this many hits
+ integer*4 HFPP_minchamberhits ! every chamber must have this many hits
+ integer*4 HFPP_minsethits ! minimum # of layers with hits in set
+ integer*4 HFPP_maxcombos ! maximum # of hit combinations
+ ! if there are more we skip event!
+
+ real*4 HFPP_min_chi2 ! minimum chi**2 for kept track
+ real*4 HFPP_aOK_chi2 ! sufficient chi**2 for extra hit
+
+ integer*4 HFPP_effic_dist ! how far hit wire can be from track and
+ ! still be considered hit for "efficient"
+
+ common/HMS_FPP_limits/
+ & HFPP_maxdrift(H_FPP_N_PLANES)
+ & , HFPP_tDriftOffset(H_FPP_N_PLANES,H_FPP_MAX_WIRES)
+ & , HFPP_minTDC
+ & , HFPP_maxTDC
+ & , HFPP_tdc_time_per_channel
+ & , HFPP_wirespeed
+ & , HFPP_particlespeed
+ & , HFPP_mintime
+ & , HFPP_maxtime
+ & , HFPP_optchamberhits
+ & , HFPP_minchamberhits
+ & , HFPP_minsethits
+ & , HFPP_maxcombos
+ & , HFPP_min_chi2
+ & , HFPP_aOK_chi2
+ & , HFPP_effic_dist
+
+*
+* CTPTYPE=parm
+*
+ integer*4 HFPP_my_ROCs(0:G_DECODE_MAXROCS) ! list of ROCs used for FPP
+ integer*4 HFPP_trigger_plane ! wire plane of TDC trigger time
+ integer*4 HFPP_trigger_wire ! wire in same that actually has data
+
+ integer*4 HFPP_calc_resolution ! switch to turn on resolution calc EXPENSIVE!
+ integer*4 HFPP_use_clusters ! use adjacent hits together for tracking
+ integer*4 HFPP_min_event_code ! lowest FPP event code to store in Ntuple
+
+ common/HMS_FPP_config/
+ & HFPP_my_ROCs
+ & , HFPP_trigger_plane
+ & , HFPP_trigger_wire
+ & , HFPP_calc_resolution
+ & , HFPP_use_clusters
+ & , HFPP_min_event_code
+
+*
+* CTPTYPE=parm
+*
+ integer*4 H_FPP_DRIFT_MAX_BINS
+ parameter (H_FPP_DRIFT_MAX_BINS=1000) ! maximum # of entries in drift map
+
+ integer*4 H_FPP_DRIFT_MAX_TERMS
+ parameter (H_FPP_DRIFT_MAX_TERMS=10) ! maximum # of terms in polynomial
+
+ integer*4 hfpp_drift_type ! method of drift calculation:
+ ! 1 = look-up table, time bins give distance
+ ! 2 = polynomial
+
+ integer*4 hfpp_drift_Nbins ! actual # of entries in drift map
+ integer*4 hfpp_drift_Nterms ! actual # of terms in drift map polynomial
+
+ real*4 hfpp_drift_coeffs ! coefficient of terms in drift map polynomial
+
+ real*4 hfpp_drift_Tmin ! lowest acceptable drift time for this map
+ real*4 hfpp_drift_Tmax ! largest acceptable drift time for this map
+ real*4 hfpp_drift_dT ! time difference between entries in drift map
+ real*4 hfpp_drift_Xmax ! largest acceptable drift distance for this map
+ real*4 hfpp_driftmap ! dirft distances by time bins
+ character*80 hfpp_driftmap_filename
+
+ common/HMS_FPP_drift/
+ & hfpp_drift_type
+ & , hfpp_drift_Nbins
+ & , hfpp_drift_Tmin, hfpp_drift_Tmax, hfpp_drift_dT
+ & , hfpp_drift_Xmax
+ & , hfpp_driftmap(H_FPP_N_PLANES,H_FPP_DRIFT_MAX_BINS)
+ & , hfpp_drift_Nterms
+ & , hfpp_drift_coeffs(H_FPP_N_PLANES,H_FPP_DRIFT_MAX_TERMS)
+ & , hfpp_driftmap_filename
+
+*
+* CTPTYPE=parm
+*
+ real*4 HFPP_planeresolution ! expected tracking resolution, for chi2
+
+ common/HMS_FPP_remap/
+ & HFPP_planeresolution(H_FPP_N_PLANES)
diff --git a/INCLUDE/hms_fpp_params.dte b/INCLUDE/hms_fpp_params.dte
new file mode 100644
index 0000000..5fdf6c7
--- /dev/null
+++ b/INCLUDE/hms_fpp_params.dte
@@ -0,0 +1,218 @@
+*--------------------------------------------------------
+* Hall C HMS Focal Plane Polarimeter Code
+*
+* Purpose: set immutable HMS FPP parameters
+* this file is included by h_init_fpp.f
+*
+* Created by Frank R. Wesselmann, February 2004
+*
+*--------------------------------------------------------
+*
+*%% include 'hms_data_structures.cmn'
+*%% include 'hms_geometry.cmn'
+
+* * these declarations are for LOCAL use only!!
+ integer*4 FPPNUMCARDS
+ parameter (FPPNUMCARDS=148)
+
+ integer*4 fpp_planemap(8,FPPNUMCARDS)
+
+ real*4 planeZ(H_FPP_N_DCLAYERS*H_FPP_N_DCINSET)
+ real*4 planeangle(H_FPP_N_DCLAYERS*H_FPP_N_DCINSET)
+ real*4 inplanespacing(H_FPP_N_DCLAYERS*H_FPP_N_DCINSET)
+ real*4 planeoffset(H_FPP_N_DCLAYERS*H_FPP_N_DCINSET)
+
+
+** number of wires per plane
+ data HFPP_Nwires/ 104, 83, 104, 104, 83, 104,
+ + 104, 83, 104, 104, 83, 104/
+
+** z-position of chamber layers within each chamber set (pair)
+ data planeZ/ -12.25, -10.65, -9.05, 9.05, 10.65, 12.25/
+
+* angle of wires in each plane relative to
+* positive x-axis -- in-layer axis goes from wire 1 to wire 104/83
+* we define chamber y to be along the wires and chamber x along measure
+* gamma of zero degrees has lowest wire at -x and highest at +x
+* thus x-layer has gamma=0, u has +45 and v has -45
+ data planeangle/ -45.0, 0.0, 45.0, -45.0, 0.0, 45.0/
+
+* spacing of sense wires in each plane
+ data inplanespacing/ 2.0, 2.0, 2.0, 2.0, 2.0, 2.0/
+
+* offset of layer along its measurement direction by plane
+* this is the difference between (wire no)*(spacing) and (coordinate)
+ data planeoffset/ -104.0, -84.0, -104.0, -104.0, -84.0, -104.0/
+
+** Chamber Wire Numbers against card position mapping
+*
+* note that sometimes the wire numbering is backwards
+* compared to the TDC channel numbering!
+* That is another reason for using this file:
+* to verify the cabling map that it has the proper channels in
+* decreasing order. Actually used is only the value CARDPOS.
+*
+* plane is the linearized labeling for the drift chamber layers,
+* in order of increasing z
+* most of the code uses the (set,chamber,layer) notation instead
+*
+* position refers to the read-out card connector position that is
+* part of the chamber itself; the numbering was defined by the
+* chamber builders and is indicated on the chambers by yellow labels
+*
+* cardpos indicates if readout of wire occurs from the +v or -v
+* side of wire, where (u,v) is the RH coord system of the layer
+*
+* layers 1, 4, 7, 10 are +45
+* layers 2, 5, 8, 11 are 0
+* layers 3, 6, 9, 12 are -45
+
+* plane set chamber layer position wire_lo wire_hi cardpos
+ data fpp_planemap/ 1, 1, 1, 1, 1, 8, 1, 1,
+ + 1, 1, 1, 1, 2, 16, 9, 1,
+ + 1, 1, 1, 1, 3, 24, 17, 1,
+ + 1, 1, 1, 1, 4, 32, 25, 1,
+ + 1, 1, 1, 1, 5, 40, 33, 1,
+ + 1, 1, 1, 1, 6, 48, 41, 1,
+ + 1, 1, 1, 1, 7, 56, 49, 1,
+ + 1, 1, 1, 1, 8, 57, 64, -1,
+ + 1, 1, 1, 1, 9, 65, 72, -1,
+ + 1, 1, 1, 1, 10, 73, 80, -1,
+ + 1, 1, 1, 1, 11, 81, 88, -1,
+ + 1, 1, 1, 1, 12, 89, 96, -1,
+ + 1, 1, 1, 1, 13, 97, 104, -1,
+ + 2, 1, 1, 2, 1, 8, 1, 1,
+ + 2, 1, 1, 2, 2, 16, 9, 1,
+ + 2, 1, 1, 2, 3, 24, 17, 1,
+ + 2, 1, 1, 2, 4, 32, 25, 1,
+ + 2, 1, 1, 2, 5, 40, 33, 1,
+ + 2, 1, 1, 2, 6, 48, 41, 1,
+ + 2, 1, 1, 2, 7, 56, 49, 1,
+ + 2, 1, 1, 2, 8, 64, 57, 1,
+ + 2, 1, 1, 2, 9, 72, 65, 1,
+ + 2, 1, 1, 2, 10, 80, 73, 1,
+ + 2, 1, 1, 2, 11, 88, 81, 1,
+ + 3, 1, 1, 3, 1, 1, 8, -1,
+ + 3, 1, 1, 3, 2, 9, 16, -1,
+ + 3, 1, 1, 3, 3, 17, 24, -1,
+ + 3, 1, 1, 3, 4, 25, 32, -1,
+ + 3, 1, 1, 3, 5, 33, 40, -1,
+ + 3, 1, 1, 3, 6, 41, 48, -1,
+ + 3, 1, 1, 3, 7, 49, 56, -1,
+ + 3, 1, 1, 3, 8, 64, 57, 1,
+ + 3, 1, 1, 3, 9, 72, 65, 1,
+ + 3, 1, 1, 3, 10, 80, 73, 1,
+ + 3, 1, 1, 3, 11, 88, 81, 1,
+ + 3, 1, 1, 3, 12, 96, 89, 1,
+ + 3, 1, 1, 3, 13, 104, 97, 1,
+ + 4, 1, 2, 1, 1, 8, 1, 1,
+ + 4, 1, 2, 1, 2, 16, 9, 1,
+ + 4, 1, 2, 1, 3, 24, 17, 1,
+ + 4, 1, 2, 1, 4, 32, 25, 1,
+ + 4, 1, 2, 1, 5, 40, 33, 1,
+ + 4, 1, 2, 1, 6, 48, 41, 1,
+ + 4, 1, 2, 1, 7, 56, 49, 1,
+ + 4, 1, 2, 1, 8, 57, 64, -1,
+ + 4, 1, 2, 1, 9, 65, 72, -1,
+ + 4, 1, 2, 1, 10, 73, 80, -1,
+ + 4, 1, 2, 1, 11, 81, 88, -1,
+ + 4, 1, 2, 1, 12, 89, 96, -1,
+ + 4, 1, 2, 1, 13, 97, 104, -1,
+ + 5, 1, 2, 2, 1, 8, 1, 1,
+ + 5, 1, 2, 2, 2, 16, 9, 1,
+ + 5, 1, 2, 2, 3, 24, 17, 1,
+ + 5, 1, 2, 2, 4, 32, 25, 1,
+ + 5, 1, 2, 2, 5, 40, 33, 1,
+ + 5, 1, 2, 2, 6, 48, 41, 1,
+ + 5, 1, 2, 2, 7, 56, 49, 1,
+ + 5, 1, 2, 2, 8, 64, 57, 1,
+ + 5, 1, 2, 2, 9, 72, 65, 1,
+ + 5, 1, 2, 2, 10, 80, 73, 1,
+ + 5, 1, 2, 2, 11, 88, 81, 1,
+ + 6, 1, 2, 3, 1, 1, 8, -1,
+ + 6, 1, 2, 3, 2, 9, 16, -1,
+ + 6, 1, 2, 3, 3, 17, 24, -1,
+ + 6, 1, 2, 3, 4, 25, 32, -1,
+ + 6, 1, 2, 3, 5, 33, 40, -1,
+ + 6, 1, 2, 3, 6, 41, 48, -1,
+ + 6, 1, 2, 3, 7, 49, 56, -1,
+ + 6, 1, 2, 3, 8, 64, 57, 1,
+ + 6, 1, 2, 3, 9, 72, 65, 1,
+ + 6, 1, 2, 3, 10, 80, 73, 1,
+ + 6, 1, 2, 3, 11, 88, 81, 1,
+ + 6, 1, 2, 3, 12, 96, 89, 1,
+ + 6, 1, 2, 3, 13, 104, 97, 1,
+ + 7, 2, 1, 1, 1, 8, 1, 1,
+ + 7, 2, 1, 1, 2, 16, 9, 1,
+ + 7, 2, 1, 1, 3, 24, 17, 1,
+ + 7, 2, 1, 1, 4, 32, 25, 1,
+ + 7, 2, 1, 1, 5, 40, 33, 1,
+ + 7, 2, 1, 1, 6, 48, 41, 1,
+ + 7, 2, 1, 1, 7, 56, 49, 1,
+ + 7, 2, 1, 1, 8, 57, 64, -1,
+ + 7, 2, 1, 1, 9, 65, 72, -1,
+ + 7, 2, 1, 1, 10, 73, 80, -1,
+ + 7, 2, 1, 1, 11, 81, 88, -1,
+ + 7, 2, 1, 1, 12, 89, 96, -1,
+ + 7, 2, 1, 1, 13, 97, 104, -1,
+ + 8, 2, 1, 2, 1, 8, 1, 1,
+ + 8, 2, 1, 2, 2, 16, 9, 1,
+ + 8, 2, 1, 2, 3, 24, 17, 1,
+ + 8, 2, 1, 2, 4, 32, 25, 1,
+ + 8, 2, 1, 2, 5, 40, 33, 1,
+ + 8, 2, 1, 2, 6, 48, 41, 1,
+ + 8, 2, 1, 2, 7, 56, 49, 1,
+ + 8, 2, 1, 2, 8, 64, 57, 1,
+ + 8, 2, 1, 2, 9, 72, 65, 1,
+ + 8, 2, 1, 2, 10, 80, 73, 1,
+ + 8, 2, 1, 2, 11, 88, 81, 1,
+ + 9, 2, 1, 3, 1, 1, 8, -1,
+ + 9, 2, 1, 3, 2, 9, 16, -1,
+ + 9, 2, 1, 3, 3, 17, 24, -1,
+ + 9, 2, 1, 3, 4, 25, 32, -1,
+ + 9, 2, 1, 3, 5, 33, 40, -1,
+ + 9, 2, 1, 3, 6, 41, 48, -1,
+ + 9, 2, 1, 3, 7, 49, 56, -1,
+ + 9, 2, 1, 3, 8, 64, 57, 1,
+ + 9, 2, 1, 3, 9, 72, 65, 1,
+ + 9, 2, 1, 3, 10, 80, 73, 1,
+ + 9, 2, 1, 3, 11, 88, 81, 1,
+ + 9, 2, 1, 3, 12, 96, 89, 1,
+ + 9, 2, 1, 3, 13, 104, 97, 1,
+ + 10, 2, 2, 1, 1, 8, 1, 1,
+ + 10, 2, 2, 1, 2, 16, 9, 1,
+ + 10, 2, 2, 1, 3, 24, 17, 1,
+ + 10, 2, 2, 1, 4, 32, 25, 1,
+ + 10, 2, 2, 1, 5, 40, 33, 1,
+ + 10, 2, 2, 1, 6, 48, 41, 1,
+ + 10, 2, 2, 1, 7, 56, 49, 1,
+ + 10, 2, 2, 1, 8, 57, 64, -1,
+ + 10, 2, 2, 1, 9, 65, 72, -1,
+ + 10, 2, 2, 1, 10, 73, 80, -1,
+ + 10, 2, 2, 1, 11, 81, 88, -1,
+ + 10, 2, 2, 1, 12, 89, 96, -1,
+ + 10, 2, 2, 1, 13, 97, 104, -1,
+ + 11, 2, 2, 2, 1, 8, 1, 1,
+ + 11, 2, 2, 2, 2, 16, 9, 1,
+ + 11, 2, 2, 2, 3, 24, 17, 1,
+ + 11, 2, 2, 2, 4, 32, 25, 1,
+ + 11, 2, 2, 2, 5, 40, 33, 1,
+ + 11, 2, 2, 2, 6, 48, 41, 1,
+ + 11, 2, 2, 2, 7, 56, 49, 1,
+ + 11, 2, 2, 2, 8, 64, 57, 1,
+ + 11, 2, 2, 2, 9, 72, 65, 1,
+ + 11, 2, 2, 2, 10, 80, 73, 1,
+ + 11, 2, 2, 2, 11, 88, 81, 1,
+ + 12, 2, 2, 3, 1, 1, 8, -1,
+ + 12, 2, 2, 3, 2, 9, 16, -1,
+ + 12, 2, 2, 3, 3, 17, 24, -1,
+ + 12, 2, 2, 3, 4, 25, 32, -1,
+ + 12, 2, 2, 3, 5, 33, 40, -1,
+ + 12, 2, 2, 3, 6, 41, 48, -1,
+ + 12, 2, 2, 3, 7, 49, 56, -1,
+ + 12, 2, 2, 3, 8, 64, 57, 1,
+ + 12, 2, 2, 3, 9, 72, 65, 1,
+ + 12, 2, 2, 3, 10, 80, 73, 1,
+ + 12, 2, 2, 3, 11, 88, 81, 1,
+ + 12, 2, 2, 3, 12, 96, 89, 1,
+ + 12, 2, 2, 3, 13, 104, 97, 1/
diff --git a/INCLUDE/hms_geometry.cmn b/INCLUDE/hms_geometry.cmn
new file mode 100644
index 0000000..cbebfdc
--- /dev/null
+++ b/INCLUDE/hms_geometry.cmn
@@ -0,0 +1,240 @@
+* hms_geometry.cmn
+*
+* This include file has all the geometrical coefficients for the
+* HMS wire chambers.
+*
+* d.f. geesaman 1 September 1993
+* modifed dfg 14 Feb 1994
+* change HPLANE_PARAM(2,) to hdc_zpos
+* change HPLANE_PARAM(3,) to hdc_alpha_angle
+* change HPLANE_PARAM(4,) to hdc_beta_angle
+* change HPLANE_PARAM(5,) to hdc_gamma_angle
+* change HPLANE_PARAM(6,) to hdc_pitch
+* change HPLANE_PARAM(7,) to hdc_nrwire
+* change HPLANE_PARAM(8,) to hdc_central_wire
+* change HPLANE_PARAM(9,) to hdc_sigma
+* change HPLANE_LABEL to hdc_plane_name
+* add hdc_xcenter
+* hdc_ycenter
+* $Log: hms_geometry.cmn,v $
+* Revision 1.11.24.2 2007/09/26 21:04:16 brash
+* Updates to FPP tracking codes - mostly for conetest calculation.
+*
+* Revision 1.11.24.1 2007/08/22 19:09:31 frw
+* added FPP
+*
+* Revision 1.12 2006/06/22 frw
+* (frw) added FPP geometry variables, common block
+*
+* Revision 1.11 1996/09/04 15:49:59 saw
+* (JRA) Make hdc_nrwire integer
+*
+* Revision 1.10 1995/05/22 19:07:02 cdaq
+* (SAW) Split gen_data_data_structures into gen, hms, sos, and coin parts
+*
+* Revision 1.9 1995/01/27 20:21:00 cdaq
+* (JRA) Remove no longer used drift time->distance parameters
+*
+* Revision 1.8 1994/11/22 18:43:10 cdaq
+* (SAW) Cleaned up ?DC_NUM_CHAMBERS and ?MAX_NUM_CHAMBERS stuff
+*
+* Revision 1.7 1994/09/13 19:19:37 cdaq
+* (JRA) Add global Wire chamber offsets
+*
+* Revision 1.6 1994/08/05 17:54:15 cdaq
+* (SAW) Add makereg directive with required include files
+* Add "CTPTYPE=parm" directive for auto generation of CTP reg calls
+*
+* Revision 1.5 1994/07/27 19:15:18 cdaq
+* (DFG) Add hdrift_x0_break and hdrift_t0_break (probably obsoleted by DJM's
+* Change to h_drift_dist_calc
+*
+* Revision 1.4 1994/06/14 03:21:25 cdaq
+* (DFG) Added hdc_tdc_time_zero
+*
+* Revision 1.3 1994/04/13 17:33:06 cdaq
+* (DFG) Added dummy and dmytst
+*
+* Revision 1.2 1994/03/24 18:36:06 cdaq
+* (DFG) Additional parameters
+*
+* Revision 1.1 1994/02/22 14:46:27 cdaq
+* Initial revision
+*
+* The following include statments must precede the inclusion of this
+* file in each routine that uses it. The *%% syntax is also a
+* directive to makereg to tell it to include the code in the program
+* that it generates.
+*
+*%% include 'hms_data_structures.cmn'
+*
+* CTPTYPE=parm ! Probably don't really want the following registered
+*
+ real*4 hzchi,hzpsi ! geometrical coefficients defining z-z0
+ real*4 hxchi,hxpsi ! x and y for each wire plane.
+ real*4 hychi,hypsi
+*
+ real*4 hz0 ! z coordinate of intersection of chamber with
+ ! z axis
+ real*4 hpsi0,hchi0,hphi0 ! psi, chi and phi coordinates where a
+ ! chamber normal passing through the origin
+ ! intersects the chamber. Used in stub fits
+
+ real*4 hstubcoef ! coefficents used in stub fits
+ ! note these contain one power of sigma
+
+ real*4 htanbeta,hsinbeta,hcosbeta
+*
+ real*4 hxsp ! coefficents used in space point fits.
+ real*4 hysp
+*
+ real*8 hplane_coeff ! coefficients used in final track fit
+*
+ integer*4 HNUM_PLANE_COEFF ! number of plane track fit coefficients
+ parameter (HNUM_PLANE_COEFF=9)
+ integer*4 HNUM_RAY_PARAM ! number of ray parameters
+ parameter (HNUM_RAY_PARAM=4)
+*
+ common/HMS_GEOMETRY/
+ & hplane_coeff(HNUM_PLANE_COEFF,HMAX_NUM_DC_PLANES),
+ & hzpsi(HMAX_NUM_DC_PLANES),hzchi(HMAX_NUM_DC_PLANES),
+ & hxpsi(HMAX_NUM_DC_PLANES),hxchi(HMAX_NUM_DC_PLANES),
+ & hypsi(HMAX_NUM_DC_PLANES),hychi(HMAX_NUM_DC_PLANES),
+ & hz0(HMAX_NUM_DC_PLANES),hpsi0(HMAX_NUM_DC_PLANES),
+ & hchi0(HMAX_NUM_DC_PLANES),hphi0(HMAX_NUM_DC_PLANES),
+ & hstubcoef(HMAX_NUM_DC_PLANES,HNUM_RAY_PARAM),
+ & hxsp(HMAX_NUM_DC_PLANES),hysp(HMAX_NUM_DC_PLANES),
+ & htanbeta(HMAX_NUM_DC_PLANES),hsinbeta(HMAX_NUM_DC_PLANES),
+ & hcosbeta(HMAX_NUM_DC_PLANES)
+*
+ real*4 hdc_zpos
+ real*4 hdc_alpha_angle
+ real*4 hdc_beta_angle
+ real*4 hdc_gamma_angle
+ real*4 hdc_pitch
+ integer*4 hdc_nrwire
+ real*4 hdc_central_wire
+ real*4 hdc_sigma
+ real*4 hdc_xcenter
+ real*4 hdc_ycenter
+ real*4 hdc_center
+ integer*4 hdc_chamber_planes
+ character*16 hdc_plane_name
+ common/HMS_PLANE_PARAMETERS/
+ & hdc_zpos(HMAX_NUM_DC_PLANES),
+ & hdc_alpha_angle(HMAX_NUM_DC_PLANES),
+ & hdc_beta_angle(HMAX_NUM_DC_PLANES),
+ & hdc_gamma_angle(HMAX_NUM_DC_PLANES),
+ & hdc_pitch(HMAX_NUM_DC_PLANES),
+ & hdc_central_wire(HMAX_NUM_DC_PLANES),
+ & hdc_nrwire(HMAX_NUM_DC_PLANES),
+ & hdc_sigma(HMAX_NUM_DC_PLANES),
+ & hdc_xcenter(HMAX_NUM_CHAMBERS),
+ & hdc_ycenter(HMAX_NUM_CHAMBERS),
+ & hdc_chamber_planes(HMAX_NUM_DC_PLANES),
+ & hdc_plane_name(HMAX_NUM_DC_PLANES),
+ & hdc_center(HMAX_NUM_DC_PLANES)
+*
+*
+ real*4 hlocrayzt
+ parameter (hlocrayzt=0.)
+*
+* CTPTYPE=parm
+*
+* parameter file variables. Separate by type to make it easy to add
+* at the end
+* REAL*4
+*
+* real*4 hdrift_velocity ! hms drift velocity in cm/ns
+ real*4 hdc_tdc_time_per_channel ! hms drift chamber tdc calibration
+ real*4 hdc_1_zpos
+ real*4 hdc_2_zpos
+ real*4 dummy
+ real*4 hdc_plane_time_zero ! zero time for drift chamber planes
+* real*4 hdrift_t0_break ! start of linear drift region in t
+* real*4 hdrift_x0_break ! start of linear drift region in x
+ common/HMS_CHAMBER_READOUT_REAL/
+* & hdrift_velocity,
+ & hdc_tdc_time_per_channel,
+ & hdc_1_zpos,
+ & hdc_2_zpos,
+ & dummy,
+ & hdc_plane_time_zero(HMAX_NUM_DC_PLANES)
+* & hdrift_t0_break(HMAX_NUM_DC_PLANES),
+* & hdrift_x0_break(HMAX_NUM_DC_PLANES)
+*
+* INTEGER*4
+ integer*4 hdc_wire_counting ! readout numbering order
+ integer*4 dmytst
+*
+ common/HMS_CHAMBER_READOUT_INT/
+ & hdc_wire_counting(HMAX_NUM_DC_PLANES),
+ & dmytst
+
+
+*
+* CTPTYPE=parm
+*
+ integer*4 HFPP_Nwires ! actual # of wires in each layer (plane!!)
+
+ integer*4 HFPP_plane2set ! mapping from plane# to set#
+ integer*4 HFPP_plane2chamber ! mapping from plane# to chamber#
+ integer*4 HFPP_plane2layer ! mapping from plane# to layer#
+
+* * the following offsets and rotations are expressed in the HMS FP coords
+* * thus they describe how the chamber set is positioned relative to the
+* * other detectors; we expect the rotation to be carried out before the
+* * translation, i.e. the origins of the coord systems will coincide
+* * the translation is however expressed in HMS FP coords
+* * the chamber set coord system mirrors HMS trasport conventions, with the
+* * z-axis going through the center of each layer; the origin is midway
+* * between the two cha,mbers of the set
+
+ real*4 HFPP_alpha ! rotation angle alpha of each chamber set
+ real*4 HFPP_beta ! rotation angle beta of each chamber set
+ real*4 HFPP_gamma ! rotation angle gamma of each chamber set
+
+ real*4 HFPP_Xoff ! x offset in lab of each chamber set (cm)
+ real*4 HFPP_Yoff ! y offset in lab of each chamber set (cm)
+ real*4 HFPP_Zoff ! z offset in lab of each chamber set (cm)
+
+ real*4 HFPP_Xsize ! useful size (x) of each chamber set (cm)
+ real*4 HFPP_Ysize ! useful size (y) of each chamber set (cm)
+
+ real*4 HFPP_layerZ ! z coord of each LAYER in lab (cm)
+
+ real*4 HFPP_spacing ! wire spacing of each layer
+
+ real*4 HFPP_resolution ! track fit hit sigma**2 of each layer in layer
+
+ real*4 HFPP_layeroffset ! offset of each layer (along its measure)
+
+ real*4 HFPP_Mrotation ! coordinate rotation matrix from HMS to FPP
+ real*4 HFPP_Irotation ! coordinate rotation matrix from FPP to HMS
+
+ real*4 HFPP_direction ! direction of unit vector along layer''s measure
+ ! based on parameter file variable HFPP_layerangle
+
+ integer*4 HFPP_cardpos ! is readout card on +v or -v side of chamber?
+ ! where u is measuring coord, v is along wires and z is beam
+
+ common/HMS_FPP_geometry/
+ & HFPP_Nwires(H_FPP_N_PLANES)
+ & , HFPP_plane2set(H_FPP_N_PLANES),HFPP_plane2chamber(H_FPP_N_PLANES)
+ & , HFPP_plane2layer(H_FPP_N_PLANES)
+ & , HFPP_alpha(H_FPP_N_DCSETS)
+ & , HFPP_beta(H_FPP_N_DCSETS)
+ & , HFPP_gamma(H_FPP_N_DCSETS)
+ & , HFPP_Xoff(H_FPP_N_DCSETS)
+ & , HFPP_Yoff(H_FPP_N_DCSETS)
+ & , HFPP_Zoff(H_FPP_N_DCSETS)
+ & , HFPP_Xsize(H_FPP_N_DCSETS)
+ & , HFPP_Ysize(H_FPP_N_DCSETS)
+ & , HFPP_Mrotation(H_FPP_N_DCSETS,3,3)
+ & , HFPP_Irotation(H_FPP_N_DCSETS,3,3)
+ & , HFPP_direction(H_FPP_N_DCSETS,H_FPP_N_DCINSET,H_FPP_N_DCLAYERS,2)
+ & , HFPP_spacing(H_FPP_N_DCSETS,H_FPP_N_DCINSET,H_FPP_N_DCLAYERS)
+ & , HFPP_resolution(H_FPP_N_DCSETS,H_FPP_N_DCINSET,H_FPP_N_DCLAYERS)
+ & , HFPP_layerZ(H_FPP_N_DCSETS,H_FPP_N_DCINSET,H_FPP_N_DCLAYERS)
+ & , HFPP_layeroffset(H_FPP_N_DCSETS,H_FPP_N_DCINSET,H_FPP_N_DCLAYERS)
+ & , HFPP_cardpos(H_FPP_N_DCSETS,H_FPP_N_DCINSET,H_FPP_N_DCLAYERS,H_FPP_MAX_WIRES)
diff --git a/INCLUDE/hms_id_histid.cmn b/INCLUDE/hms_id_histid.cmn
new file mode 100644
index 0000000..6da69b0
--- /dev/null
+++ b/INCLUDE/hms_id_histid.cmn
@@ -0,0 +1,223 @@
+*_______________________________________________________________________
+* hms_id_histid.cmn
+*
+* This common block contains the HBOOK histogram id numbers
+* for all hms particle id histograms in which direct hfill
+* calls are made.
+*
+* It also contains the paramter flags to turn on and off histograming
+* of each of the hard coded blocks.
+*
+* Created 9 April 1994 D. F. Geesaman
+*
+* $Log: hms_id_histid.cmn,v $
+* Revision 1.13.24.3 2007/10/30 00:28:32 cdaq
+* added FPP geometric alignment checks
+*
+* Revision 1.13.24.2 2007/10/22 18:39:10 cdaq
+* adjusted HMS FPP histos
+*
+* Revision 1.13.24.1 2007/08/22 19:09:31 frw
+* added FPP
+*
+*
+* Revision 1.15 2006/06/22 frw
+* added FPP hids
+*
+* Revision 1.14 2002/12/20 21:52:33 jones
+* Modified by Hamlet for new HMS aerogel
+*
+* Revision 1.13 2002/10/08 (Hamlet)
+* Add HMS Aerogel histograms
+*
+* Revision 1.12 1999/02/23 19:10:42 csa
+* (JRA) Add hidscindpos_pid, cleanup
+*
+* Revision 1.11 1999/02/03 21:13:34 saw
+* Code for new Shower counter tubes
+*
+* Revision 1.10 1996/09/04 15:51:24 saw
+* Add hidmisctdcs
+*
+* Revision 1.9 1996/01/17 16:01:00 cdaq
+* (JRA) Add hidscintimes histogram
+*
+* Revision 1.8 1995/09/01 13:02:31 cdaq
+* (JRA) Add dpos histid's
+*
+* Revision 1.7 1995/08/11 16:30:58 cdaq
+* (JRA) Add dpos (track pos - hit pos) histograms
+*
+* Revision 1.6 1995/07/28 14:26:52 cdaq
+* (JRA) Add hidsum histogram id holders
+*
+* Revision 1.5 1995/05/22 19:07:28 cdaq
+* (SAW) Split gen_data_data_structures into gen, hms, sos, and coin parts
+*
+* Revision 1.4 1995/05/12 12:23:39 cdaq
+* (JRA) Modify/add user histograms
+*
+* Revision 1.3 1994/08/05 15:41:18 cdaq
+* (SAW) Add makereg directive with required include files
+*
+* Revision 1.2 1994/08/04 20:51:58 cdaq
+* (SAW) Add "CTPTYPE=parm" directive for auto generation of CTP reg calls
+*
+* Revision 1.1 1994/04/12 21:11:59 cdaq
+* Initial revision
+*
+* The following include statments must precede the inclusion of this
+* file in each routine that uses it. The *%% syntax is also a
+* directive to makereg to tell it to include the code in the program
+* that it generates.
+*
+*%% include 'hms_data_structures.cmn'
+*%% include 'hms_scin_parms.cmn'
+*
+* The following don't need to be registered??
+* CTPTYPE=parm
+ integer*4 hidscinrawtothits
+ integer*4 hidscinplane
+ integer*4 hidscinallpostdc(HNUM_SCIN_PLANES)
+ integer*4 hidscinallnegtdc(HNUM_SCIN_PLANES)
+ integer*4 hidscinallposadc(HNUM_SCIN_PLANES)
+ integer*4 hidscinallnegadc(HNUM_SCIN_PLANES)
+ integer*4 hidscincounters(HNUM_SCIN_PLANES)
+ integer*4 hidscinposadc(HNUM_SCIN_PLANES,hnum_scin_elements)
+ integer*4 hidscinnegadc(HNUM_SCIN_PLANES,hnum_scin_elements)
+ integer*4 hidscinpostdc(HNUM_SCIN_PLANES,hnum_scin_elements)
+ integer*4 hidscinnegtdc(HNUM_SCIN_PLANES,hnum_scin_elements)
+ integer*4 hidscinalltimes
+ integer*4 hidscindpos(HNUM_SCIN_PLANES)
+ integer*4 hidscindpos_pid(HNUM_SCIN_PLANES)
+ integer*4 hidsumposadc(HNUM_SCIN_PLANES)
+ integer*4 hidsumnegadc(HNUM_SCIN_PLANES)
+ integer*4 hidsumpostdc(HNUM_SCIN_PLANES)
+ integer*4 hidsumnegtdc(HNUM_SCIN_PLANES)
+ integer*4 hidscintimes
+
+ integer*4 hidcalplane
+ integer*4 hidcalhits(HMAX_CAL_COLUMNS)
+ integer*4 hidcalposhits(HMAX_CAL_COLUMNS)
+ integer*4 hidcalneghits(HMAX_CAL_COLUMNS)
+ integer*4 hidcalsumadc
+ integer*4 hidcaldpos
+ integer*4 hiddcdposx,hiddcdposy,hiddcdposxp,hiddcdposyp
+ integer*4 hidmisctdcs
+*
+ integer*4 hidhaero_adc_pos_hits
+ integer*4 hidhaero_adc_neg_hits
+
+ integer*4 hidhaero_adc_pos_pedsubtr
+ integer*4 hidhaero_adc_neg_pedsubtr
+
+ integer*4 hidhaero_tdc_pos_hits
+ integer*4 hidhaero_tdc_neg_hits
+
+c
+ common/hms_id_histid/
+ & hidscinrawtothits,
+ & hidscinplane,
+ & hidscinallpostdc,
+ & hidscinallnegtdc,
+ & hidscinallposadc,
+ & hidscinallnegadc,
+ & hidscincounters,
+ & hidscinposadc,
+ & hidscinnegadc,
+ & hidscinpostdc,
+ & hidscinnegtdc,
+ & hidscinalltimes,
+ & hidscintimes,
+ & hidsumposadc,
+ & hidsumnegadc,
+ & hidsumpostdc,
+ & hidsumnegtdc,
+ & hidscindpos,
+ & hidcalplane,
+ & hidcalhits,
+ & hidcalsumadc,
+ & hidcalposhits,
+ & hidcalneghits,
+ & hidcaldpos,
+ & hiddcdposx,hiddcdposy,hiddcdposxp,hiddcdposyp,
+ & hidmisctdcs,
+ & hidscindpos_pid,
+ & hidhaero_adc_pos_pedsubtr,hidhaero_adc_neg_pedsubtr,
+ & hidhaero_adc_pos_hits,hidhaero_adc_neg_hits,
+ & hidhaero_tdc_pos_hits,hidhaero_tdc_neg_hits
+
+
+ integer*4 hidFPP_tdc(H_FPP_N_PLANES)
+ integer*4 hidFPP_tdcROC
+ integer*4 hidFPP_alltimes(H_FPP_N_PLANES)
+ integer*4 hidFPP_planetime(H_FPP_N_PLANES)
+ integer*4 hidFPP_rate1(H_FPP_N_PLANES)
+ integer*4 hidFPP_time1(H_FPP_N_PLANES)
+ integer*4 hidFPP_time12(H_FPP_N_PLANES)
+ integer*4 hidFPP_driftT(H_FPP_N_DCSETS,H_FPP_N_DCINSET,H_FPP_N_DCLAYERS)
+ integer*4 hidFPP_driftX(H_FPP_N_DCSETS,H_FPP_N_DCINSET,H_FPP_N_DCLAYERS)
+ integer*4 hidFPP_should(H_FPP_N_DCSETS,H_FPP_N_DCINSET,H_FPP_N_DCLAYERS)
+ integer*4 hidFPP_did(H_FPP_N_DCSETS,H_FPP_N_DCINSET,H_FPP_N_DCLAYERS)
+ integer*4 hidFPP_dist(H_FPP_N_DCSETS)
+ integer*4 hidFPP_rawinclust(H_FPP_N_PLANES)
+ integer*4 hidFPP_trk_chi2(H_FPP_N_DCSETS)
+ integer*4 hidFPP_trk_mx(H_FPP_N_DCSETS)
+ integer*4 hidFPP_trk_bx(H_FPP_N_DCSETS)
+ integer*4 hidFPP_trk_my(H_FPP_N_DCSETS)
+ integer*4 hidFPP_trk_by(H_FPP_N_DCSETS)
+ integer*4 hidFPP_Ntrk(H_FPP_N_DCSETS)
+ integer*4 hidFPP_Nhitontrk(H_FPP_N_DCSETS)
+ integer*4 hidFPP_Nrawontrk(H_FPP_N_DCSETS)
+ integer*4 hidFPP_trkrough(H_FPP_N_DCSETS,6)
+ integer*4 hidFPP_fine_mx(H_FPP_N_DCSETS)
+ integer*4 hidFPP_fine_bx(H_FPP_N_DCSETS)
+ integer*4 hidFPP_fine_my(H_FPP_N_DCSETS)
+ integer*4 hidFPP_fine_by(H_FPP_N_DCSETS)
+
+ integer*4 hidFPP_NickEff(H_FPP_N_DCSETS)
+
+ integer*4 hidFPP_sclose(H_FPP_N_DCSETS)
+ integer*4 hidFPP_zclose(H_FPP_N_DCSETS)
+ integer*4 hidFPP_thetapol(H_FPP_N_DCSETS)
+ integer*4 hidFPP_phipol(H_FPP_N_DCSETS)
+
+ integer*4 hidFPP_resol_lin(H_FPP_N_DCSETS)
+ integer*4 hidFPP_resol_ang(H_FPP_N_DCSETS)
+
+ integer*4 hid_HMSwire(H_FPP_N_DCSETS,H_FPP_N_DCINSET,H_FPP_N_DCLAYERS)
+
+ integer*4 hid_rawROC(0:15)
+
+c
+ common/hms_fpp_histid/
+ & hidFPP_tdc,
+ & hidFPP_rate1, hidFPP_planetime,
+ & hidFPP_alltimes, hidFPP_time1, hidFPP_time12,
+ & hidFPP_driftT, hidFPP_driftX,
+ & hidFPP_should, hidFPP_did,
+ & hidFPP_dist,
+ & hidFPP_rawinclust,
+ & hidFPP_trk_chi2,
+ & hidFPP_trk_mx, hidFPP_trk_bx,
+ & hidFPP_trk_my, hidFPP_trk_by,
+ & hidFPP_Ntrk,
+ & hidFPP_Nhitontrk,
+ & hidFPP_Nrawontrk,
+ & hidFPP_trkrough,
+ & hidFPP_fine_mx, hidFPP_fine_my,
+ & hidFPP_fine_bx, hidFPP_fine_by,
+ & hidFPP_resol_lin, hidFPP_resol_ang,
+ & hidFPP_tdcROC,
+ & hidFPP_NickEff,
+ & hidFPP_sclose, hidFPP_zclose,
+ & hidFPP_thetapol, hidFPP_phipol,
+ & hid_rawROC,hid_HMSwire
+*
+* CTPTYPE=parm
+*
+* flags to turn on (.eq.1) or off (.eq. 0) hard coded histograms
+ integer*4 hturnon_scin_raw_hist
+*
+ common/hms_id_hist_flags/
+ & hturnon_scin_raw_hist
diff --git a/INCLUDE/hms_one_ev.par b/INCLUDE/hms_one_ev.par
new file mode 100644
index 0000000..5f610a6
--- /dev/null
+++ b/INCLUDE/hms_one_ev.par
@@ -0,0 +1,47 @@
+* hms_one_ev.par
+* include file for One Event Display
+*-- Author : Derek van Westrum
+*
+* contains information needed for the one event display
+*
+* $Log: hms_one_ev.par,v $
+* Revision 1.2 1996/01/17 16:02:39 cdaq
+* (DVW)
+*
+* Revision 1.1 1995/07/28 20:22:59 cdaq
+* Initial revision
+*
+********************************************************************************
+
+ real*4 HHUT_WIDTH,HHUT_HEIGHT
+ real*4 LOWER_CHAMBER_X_OFFSET,LOWER_CHAMBER_Y_OFFSET
+ real*4 UPPER_CHAMBER_X_OFFSET,UPPER_CHAMBER_Y_OFFSET
+ real*4 HODO_THICKNESS
+ real*4 HODO_LOWER_X_OFFSET,HODO_LOWER_Y_OFFSET
+ real*4 HODO_UPPER_X_OFFSET,HODO_UPPER_Y_OFFSET
+ real*4 SHOWER_X_OFFSET,SHOWER_Y_OFFSET
+ integer*4 LOWER_HODO_X_PADDLES,LOWER_HODO_Y_PADDLES
+ integer*4 UPPER_HODO_X_PADDLES,UPPER_HODO_Y_PADDLES
+
+ parameter (HHUT_WIDTH = 100.) ! full width of the det. hut
+ parameter (HHUT_HEIGHT = 800.) ! full height of the det. hut
+
+ parameter (LOWER_CHAMBER_X_OFFSET = 0.) ! offset
+ parameter (LOWER_CHAMBER_Y_OFFSET = 0.) ! offset
+ parameter (UPPER_CHAMBER_X_OFFSET = 0.) ! offset
+ parameter (UPPER_CHAMBER_Y_OFFSET = 0.) ! offset
+
+ parameter (LOWER_HODO_X_PADDLES = 16) ! # of paddles in X direction
+ parameter (LOWER_HODO_Y_PADDLES = 10) ! # of paddles in Y direction
+ parameter (UPPER_HODO_X_PADDLES = 16) ! # of paddles in X direction
+ parameter (UPPER_HODO_Y_PADDLES = 10) ! # of paddles in Y direction
+
+ parameter (HODO_THICKNESS = 1.0) ! full thickness of hodoscope
+
+ parameter (HODO_LOWER_X_OFFSET = 0.) ! offset
+ parameter (HODO_LOWER_Y_OFFSET = 0.) ! offset
+ parameter (HODO_UPPER_X_OFFSET = 0.) ! offset
+ parameter (HODO_UPPER_Y_OFFSET = 0.) ! offset
+
+ parameter (SHOWER_X_OFFSET = 0.) ! offset
+ parameter (SHOWER_Y_OFFSET = 0.) ! offset
diff --git a/INCLUDE/hms_pedestals.cmn b/INCLUDE/hms_pedestals.cmn
new file mode 100644
index 0000000..fa08038
--- /dev/null
+++ b/INCLUDE/hms_pedestals.cmn
@@ -0,0 +1,298 @@
+* hms_pedestals.cmn - counters used for calculating pedestals from the set
+* of pedestal events at the beginning of each run.
+
+*
+
+* $Log: hms_pedestals.cmn,v $
+* Revision 1.7 2003/09/05 20:32:28 jones
+* Merge in online03 changes (mkj)
+*
+* Revision 1.6.2.1 2003/04/06 06:19:41 cdaq
+* updated variables for haero
+*
+* Revision 1.6 2002/12/20 21:52:32 jones
+* Modified by Hamlet for new HMS aerogel
+*
+* Revision 1.6 2002/09/26
+* (Hamlet) Add Aerogel pedestals
+*
+* Revision 1.5 1999/02/23 19:16:02 csa
+* (JRA) Add vars for improved pedestal calcs
+*
+* Revision 1.4 1998/12/17 22:02:41 saw
+* Support extra set of tubes on HMS shower counter
+*
+* Revision 1.3 1996/01/17 16:03:04 cdaq
+* (JRA) Add "_new_" pedestal variables
+*
+* Revision 1.2 1995/06/27 15:58:12 cdaq
+* (JRA) Add hhodo_all_sig_pos
+*
+* Revision 1.1 1995/05/26 16:14:28 cdaq
+* Initial revision
+*
+* Revision 1.2 1995/05/22 19:08:49 cdaq
+* (SAW) Split gen_data_data_structures into gen, hms, sos, and coin parts
+* Fix conflicting common block names. Add Cerenkov pedestals
+*
+* Revision 1.1 1995/04/06 20:17:19 cdaq
+* Initial revision
+*
+*
+* The following include statments must precede the inclusion of this
+* file in each routine that uses it. The *%% syntax is also a
+* directive to makereg to tell it to include the code in the program
+* that it generates.
+*
+*%% include 'hms_data_structures.cmn'
+*
+* CTPTYPE=event
+*
+*
+* HODOSCOPE PEDESTALS
+* replace hscin_all_ped_pos with float(hhodo_pos_ped_sum/hhodo_pos_ped_num)
+* if hhodo_pos_ped_num > hhodo_min_peds.
+*
+ integer*4 hhodo_pos_ped_sum2(hnum_scin_planes,hnum_scin_elements)
+ integer*4 hhodo_neg_ped_sum2(hnum_scin_planes,hnum_scin_elements)
+ integer*4 hhodo_pos_ped_sum(hnum_scin_planes,hnum_scin_elements)
+ integer*4 hhodo_neg_ped_sum(hnum_scin_planes,hnum_scin_elements)
+ integer*4 hhodo_pos_ped_num(hnum_scin_planes,hnum_scin_elements)
+ integer*4 hhodo_neg_ped_num(hnum_scin_planes,hnum_scin_elements)
+ integer*4 hhodo_num_ped_changes
+ integer*4 hhodo_changed_plane(2*hnum_scin_planes*hnum_scin_elements)
+ integer*4 hhodo_changed_element(2*hnum_scin_planes*hnum_scin_elements)
+ integer*4 hhodo_changed_sign(2*hnum_scin_planes*hnum_scin_elements)
+ real*4 hhodo_ped_change(2*hnum_scin_planes*hnum_scin_elements)
+ real*4 hhodo_new_sig_pos(hnum_scin_planes,hnum_scin_elements)
+ real*4 hhodo_new_sig_neg(hnum_scin_planes,hnum_scin_elements)
+ real*4 hhodo_new_ped_pos(hnum_scin_planes,hnum_scin_elements)
+ real*4 hhodo_new_ped_neg(hnum_scin_planes,hnum_scin_elements)
+*
+* CTPTYPE=parm
+*
+ integer*4 hhodo_min_peds
+ integer*4 hhodo_pos_ped_limit(hnum_scin_planes,hnum_scin_elements)
+ integer*4 hhodo_neg_ped_limit(hnum_scin_planes,hnum_scin_elements)
+*
+ common/hms_scin_pedestals/
+ & hhodo_pos_ped_sum2, !sum of squares
+ & hhodo_neg_ped_sum2, !sum of squares
+ & hhodo_pos_ped_sum, !sum of peds
+ & hhodo_neg_ped_sum, !sum of peds
+ & hhodo_pos_ped_num, !number of peds
+ & hhodo_neg_ped_num, !number of peds
+ & hhodo_pos_ped_limit, !max. allowed ped (reject hits during ped trig)
+ & hhodo_neg_ped_limit, !max. allowed ped
+ & hhodo_min_peds, !# of peds required to override default pedestals
+ & hhodo_new_sig_pos,
+ & hhodo_new_sig_neg,
+ & hhodo_new_ped_pos,
+ & hhodo_new_ped_neg,
+ & hhodo_num_ped_changes, !# of peds with 2 sigma change from param file
+ & hhodo_changed_plane,
+ & hhodo_changed_element,
+ & hhodo_changed_sign, !1=pos,2=neg
+ & hhodo_ped_change
+*
+*
+* CALORIMETER PEDESTALS
+* replace hcal_ped_mean with float(hcal_ped_sum/hcal_ped_num),
+* hcal_ped_rms with (appropriate formula),
+* and hcal_threshold with (something like) min(10.,3.*hcal_ped_rms)
+* if hcal_num > hcal_min_peds.
+*
+*
+* CTPTYPE=event
+*
+ integer*4 hcal_pos_ped_sum2(hmax_cal_blocks)
+ integer*4 hcal_neg_ped_sum2(hmax_cal_blocks)
+ integer*4 hcal_pos_ped_sum(hmax_cal_blocks)
+ integer*4 hcal_neg_ped_sum(hmax_cal_blocks)
+ integer*4 hcal_pos_ped_num(hmax_cal_blocks)
+ integer*4 hcal_neg_ped_num(hmax_cal_blocks)
+
+ integer*4 hcal_num_ped_changes
+ integer*4 hcal_changed_block(2*hmax_cal_blocks)
+ integer*4 hcal_changed_sign(2*hmax_cal_blocks) ! Which end?
+ real*4 hcal_ped_change(2*hmax_cal_blocks)
+
+ real*4 hcal_new_ped_pos(2*hmax_cal_blocks)
+ real*4 hcal_new_ped_neg(2*hmax_cal_blocks)
+ real*4 hcal_new_rms_pos(2*hmax_cal_blocks)
+ real*4 hcal_new_rms_neg(2*hmax_cal_blocks)
+*
+* CTPTYPE=parm
+*
+ integer*4 hcal_min_peds
+ integer*4 hcal_pos_ped_limit(hmax_cal_blocks)
+ integer*4 hcal_neg_ped_limit(hmax_cal_blocks)
+*
+ common/hms_cal_ped_stats/
+ & hcal_pos_ped_sum2, !sum of squares
+ & hcal_neg_ped_sum2, !sum of squares
+ & hcal_pos_ped_sum, !sum of peds
+ & hcal_neg_ped_sum, !sum of peds
+ & hcal_pos_ped_num, !number of peds
+ & hcal_neg_ped_num, !number of peds
+ & hcal_pos_ped_limit, !max. allowed ped (reject hits during ped trig)
+ & hcal_neg_ped_limit, !max. allowed ped
+ & hcal_min_peds, !# of peds required to override default pedestals
+ & hcal_new_ped_pos, !(new) calculated pedestals.
+ & hcal_new_ped_neg, !(new) calculated pedestals.
+ & hcal_new_rms_pos, !(new) calculated rms.
+ & hcal_new_rms_neg, !(new) calculated rms.
+ & hcal_num_ped_changes,!# of peds with 2 sigma changes from param file
+ & hcal_changed_block,
+ & hcal_changed_sign, ! 1=pos, 2=neg
+ & hcal_ped_change
+*
+* CERENKOV PEDESTALS
+* replace hcer_ped with float(hcer_ped_sum/hcer_ped_num),
+* hcer_ped_rms with (appropriate formula),
+*
+*
+* CTPTYPE=event
+*
+ integer*4 hcer_ped_sum2(hmax_cer_hits)
+ integer*4 hcer_ped_sum(hmax_cer_hits)
+ integer*4 hcer_ped_num(hmax_cer_hits)
+ integer*4 hcer_num_ped_changes
+ integer*4 hcer_changed_tube(hmax_cer_hits)
+ real*4 hcer_ped_change(hmax_cer_hits)
+ real*4 hcer_ped_mean(hmax_cer_hits)
+ real*4 hcer_ped_rms(hmax_cer_hits)
+ real*4 hcer_new_ped(hmax_cer_hits)
+ real*4 hcer_new_rms(hmax_cer_hits)
+*
+* CTPTYPE=parm
+*
+ integer*4 hcer_min_peds
+ integer*4 hcer_ped_limit(hmax_cer_hits)
+*
+ common/hms_cer_pedestals/
+ & hcer_ped_sum2, !sum of squares
+ & hcer_ped_sum, !sum of peds
+ & hcer_ped_num, !number of peds
+ & hcer_ped_limit, !max. allowed ped (reject hits during ped trig)
+ & hcer_min_peds, !# of peds required to override default pedestals
+ & hcer_ped_mean,
+ & hcer_ped_rms,
+ & hcer_new_ped,
+ & hcer_new_rms,
+ & hcer_num_ped_changes,!# of peds with 2 sigma changes from param file
+ & hcer_changed_tube, !list of changed tubes
+ & hcer_ped_change !change in pedestal
+
+*.........................................................................
+* cp from sos lucite (hamlet)
+*
+*
+* AEROGEL CERENKOV PEDESTALS
+*
+* CTPTYPE=event
+*
+ integer*4 haero_pos_ped_sum2(hmax_aero_hits)
+ integer*4 haero_neg_ped_sum2(hmax_aero_hits)
+ integer*4 haero_pos_ped_sum(hmax_aero_hits)
+ integer*4 haero_neg_ped_sum(hmax_aero_hits)
+ integer*4 haero_pos_ped_num(hmax_aero_hits)
+ integer*4 haero_neg_ped_num(hmax_aero_hits)
+*
+* CTPTYPE=parm
+*
+ integer*4 haero_min_peds
+ real*4 haero_new_ped_pos(hmax_aero_hits)
+ real*4 haero_new_ped_neg(hmax_aero_hits)
+ real*4 haero_new_rms_pos(hmax_aero_hits)
+ real*4 haero_new_rms_neg(hmax_aero_hits)
+
+ real*4 haero_pos_ped_mean(hmax_aero_hits)
+ real*4 haero_neg_ped_mean(hmax_aero_hits)
+ real*4 haero_pos_ped_rms(hmax_aero_hits)
+ real*4 haero_neg_ped_rms(hmax_aero_hits)
+
+ integer*4 haero_pos_ped_limit(hmax_aero_hits)
+ integer*4 haero_neg_ped_limit(hmax_aero_hits)
+
+ common/hms_aeroi_pedestals/
+ & haero_pos_ped_sum2, !sum of squares
+ & haero_neg_ped_sum2, !sum of squares
+ & haero_pos_ped_sum, !sum of peds
+ & haero_neg_ped_sum, !sum of peds
+ & haero_pos_ped_num, !number of peds
+ & haero_neg_ped_num, !number of peds
+ & haero_pos_ped_limit, !max. allowed ped
+ & haero_neg_ped_limit, !max. allowed ped
+ & haero_min_peds, !# of peds required to override default pedestals
+ & haero_pos_ped_mean, !calculated pedestal value
+ & haero_neg_ped_mean,
+ & haero_pos_ped_rms, !calculated pedestal width
+ & haero_neg_ped_rms,
+ & haero_new_ped_pos,
+ & haero_new_ped_neg,
+ & haero_new_rms_pos,
+ & haero_new_rms_neg
+*
+*.........................................................................
+*
+* MISC. PEDESTALS
+*
+*
+* CTPTYPE=event
+*
+ integer*4 hmisc_ped_sum2(hmax_misc_hits)
+ integer*4 hmisc_ped_sum(hmax_misc_hits)
+ integer*4 hmisc_ped_num(hmax_misc_hits)
+ integer*4 hmisc_num_ped_changes
+ integer*4 hmisc_changed_tube(hmax_misc_hits)
+*
+ real*4 hmisc_ped(hmax_misc_hits)
+ real*4 hmisc_ped_change(hmax_misc_hits)
+ real*4 hmisc_ped_mean(hmax_misc_hits)
+ real*4 hmisc_ped_rms(hmax_misc_hits)
+ real*4 hmisc_new_ped(hmax_misc_hits)
+ real*4 hmisc_new_rms(hmax_misc_hits)
+*
+* CTPTYPE=parm
+*
+ integer*4 hmisc_min_peds
+ integer*4 hmisc_ped_limit(hmax_misc_hits)
+*
+ common/hms_misc_pedestals/
+ & hmisc_ped,
+ & hmisc_ped_sum2, !sum of squares
+ & hmisc_ped_sum, !sum of peds
+ & hmisc_ped_num, !number of peds
+ & hmisc_ped_limit, !max. allowed ped (reject hits during ped trig)
+ & hmisc_min_peds, !# of peds required to override default pedestals
+ & hmisc_ped_mean,
+ & hmisc_ped_rms,
+ & hmisc_new_ped,
+ & hmisc_new_rms,
+ & hmisc_num_ped_changes,!# of peds with 2 sigma changes from param file
+ & hmisc_changed_tube, !list of changed tubes
+ & hmisc_ped_change !change in pedestal
+
+*
+* CTPTYPE=event
+*
+ real*4 hhodo_new_threshold_pos(hnum_scin_planes,hnum_scin_elements)
+ real*4 hhodo_new_threshold_neg(hnum_scin_planes,hnum_scin_elements)
+ real*4 hcal_new_adc_threshold_pos(hmax_cal_blocks)
+ real*4 hcal_new_adc_threshold_neg(hmax_cal_blocks)
+ real*4 hcer_new_adc_threshold(hmax_cer_hits)
+ real*4 hmisc_new_adc_threshold(hmax_misc_hits)
+ real*4 haero_new_threshold_pos(hmax_aero_hits)
+ real*4 haero_new_threshold_neg(hmax_aero_hits)
+*
+ common/hms_adc_thresholds/
+ & hhodo_new_threshold_pos,
+ & hhodo_new_threshold_neg,
+ & hcal_new_adc_threshold_pos,
+ & hcal_new_adc_threshold_neg,
+ & hcer_new_adc_threshold,
+ & hmisc_new_adc_threshold,
+ & haero_new_threshold_pos,
+ & haero_new_threshold_neg
+
diff --git a/INCLUDE/hms_physics_sing.cmn b/INCLUDE/hms_physics_sing.cmn
new file mode 100644
index 0000000..768721d
--- /dev/null
+++ b/INCLUDE/hms_physics_sing.cmn
@@ -0,0 +1,230 @@
+* This include file contains all the variables required for h_physics
+* $Log: hms_physics_sing.cmn,v $
+* Revision 1.11 2005/03/23 16:35:04 jones
+* Add new code s_select_best_track_prune.f and h_select_best_track_prune.f (P Bosted)
+*
+* Revision 1.10 2004/02/26 22:14:53 jones
+* Add parameter hsel_using_scin. When hsel_using_scin= 1 then new code
+* HTRACKING/h_select_track_using_scin.f which selects track
+* base on which hits closest to the scintillator hits.
+* When hsel_using_scin= 0 then previous way of selecting best
+* track based on chi-squared is used.
+*
+* Revision 1.9 2003/09/08 21:03:03 jones
+* Change h_phicentral_offset to h_oopcentral_offset (mkj)
+*
+* Revision 1.8 2002/09/24 20:29:04 jones
+* add parameters hphicentral_offset, hpcentral_offset,
+* hthetacentral_offset
+*
+* Revision 1.7 1999/02/23 19:16:52 csa
+* Add some physics vars
+*
+* Revision 1.6 1996/09/04 16:11:28 saw
+* (JRA,DD) Add some egamma variables and some angle/momentum offset
+* variables
+*
+* Revision 1.5 1996/04/30 13:39:20 saw
+* (JRA) Add pathlength, rf, and photodisintigration variables
+*
+* Revision 1.4 1995/09/01 13:03:31 cdaq
+* (JRA) Add cerenkov position variables
+*
+* Revision 1.3 1995/01/27 20:18:34 cdaq
+* (JRA) Add hms_tmp_stuff array of useful physics quantities
+*
+* Revision 1.2 1994/08/05 19:37:37 cdaq
+* (SAW) Add "CTPTYPE=event,parm" directives for auto generation of CTP reg calls
+*
+* Revision 1.1 1994/06/14 03:25:33 cdaq
+* Initial revision
+*
+* CTPTYPE=event
+*
+* Event varaibles to calculate
+ REAL*4 HSELAS_COR ! Difference between momentum measured
+ ! by tracking and elastic kinematics
+ COMMON/HMS_PHYSIC_SING/
+ & HSELAS_COR
+*
+* CTPTYPE=parm
+*
+* initializiation paramters
+ REAL*4 HPHYSICSA ! Coefficients of p3 in elastic cal
+ REAL*4 HPHYSICSB !
+ REAL*4 HPHYSICAB2 !
+ REAL*4 HPHYSICSM3B !
+ REAL*4 COSHTHETAS ! COS(HTHETA_LAB)
+ REAL*4 SINHTHETAS ! SIN(HTHETA_LAB)
+ COMMON/HMS_PHYSICS_PARAM_R4/
+ & HPHYSICSA,
+ & HPHYSICSB,
+ & HPHYSICAB2,
+ & HPHYSICSM3B,
+ & COSHTHETAS,
+ & SINHTHETAS
+*
+* Parameters that select the best track. Note these should be
+* loose cuts to make sure we select one track. The final
+* tighter cuts should be made with tests.
+*
+ REAL*4 hsel_chi2_fpperdegmax ! Maximun chi2 per degree of freedom
+ ! at the focal plane
+ REAL*4 hsel_dedx1min ! Minimum dedx in chamber 1
+ REAL*4 hsel_dedx1max ! Maximum dedx in chamber 1
+ REAL*4 hsel_betamin ! Minimum beta
+ REAL*4 hsel_betamax ! Maximum beta
+ REAL*4 hsel_etmin ! Minimum track et
+ REAL*4 hsel_etmax ! Maximum track et
+
+! following parameters are only used if pruning is selected
+! see the code h_select_best_track_prune.f for meaning
+! Note: all these limits are for abs(quantity) except df, chibeta
+ real*4 hprune_xp ! Maximum xp angle in radians
+ real*4 hprune_yp ! maximum yp angle in radianss
+ real*4 hprune_ytar ! maximum ytar in cm
+ real*4 hprune_delta ! Maximum delta in percent
+ real*4 hprune_beta ! Maximum beta-1
+ integer hprune_df ! Minimum d.f. for track
+ real*4 hprune_chibeta ! Maximum beta chisq
+ real*4 hprune_fptime ! Maximum fptime - nominal
+ integer hprune_npmt ! Minimum PMTs for track
+
+ INTEGER*4 hsel_ndegreesmin ! Minimum number of degrees of freedom
+ INTEGER*4 hsel_using_scin ! =1 select best track using scin info
+ ! = 0 select best track suing just chi2
+ INTEGER*4 hsel_using_prune ! =1 select best track using new
+ ! routine and prune values
+ ! = 0 then using_scin applies
+*
+ COMMON/hms_chose_one_track_r4/
+ & hsel_chi2_fpperdegmax,
+ & hsel_dedx1min,
+ & hsel_dedx1max,
+ & hsel_betamin,
+ & hsel_betamax,
+ & hsel_etmin,
+ & hsel_etmax,
+ & hprune_xp,
+ & hprune_yp,
+ & hprune_ytar,
+ & hprune_delta,
+ & hprune_beta,
+ & hprune_df,
+ & hprune_chibeta,
+ & hprune_npmt,
+ & hprune_fptime
+*
+ COMMON/hms_chose_one_track_i4/
+ & hsel_ndegreesmin,
+ & hsel_using_scin,
+ & hsel_using_prune
+
+*
+* CTPTYPE=event
+*
+ real*4 hsx_dc1, hsy_dc1
+ real*4 hsx_dc2, hsy_dc2
+ real*4 hsx_s1, hsy_s1
+ real*4 hsx_cer, hsy_cer
+ real*4 hsx_s2, hsy_s2
+ real*4 hsx_cal, hsy_cal
+ integer*4 hsscin_elem_hit(4)
+
+ COMMON/hms_tmp_stuff/
+ & hsx_dc1, hsy_dc1,
+ & hsx_dc2, hsy_dc2,
+ & hsx_s1, hsy_s1,
+ & hsx_cer, hsy_cer,
+ & hsx_s2, hsy_s2,
+ & hsx_cal, hsy_cal,
+ & hsscin_elem_hit
+
+*
+* CTPTYPE=parm
+*
+ real*4 hpathlength_central
+*
+* CTPTYPE=event
+*
+ real*4 hsbeta_p
+ real*4 hspathlength
+ real*4 hspath_cor
+ real*4 hsrftime
+
+ COMMON/hms_timing_stuff/
+ & hpathlength_central,
+ & hsbeta_p,
+ & hspathlength,
+ & hspath_cor,
+ & hsrftime
+
+*
+* CTPTYPE=event
+*
+ real*4 hqx,hqy,hqz,hqabs
+ real*4 hinvmass
+
+ common/hms_physics_quantaties/
+ & hqx,hqy,hqz,hqabs,
+ & hinvmass
+
+
+c------------------------------------------------------------------
+c For photodisintegration calculations.
+c M.Miller, NPL UIUC, 10-Sept-1995, miller5@uiuc.edu
+*
+* CTPTYPE=parm
+*
+ real*4 hphoto_mtarget ! Mass of target [Gev/c^2]
+ real*4 hphoto_mrecoil ! Mass of recoil system [Gev/c^2]
+*
+* CTPTYPE=event
+*
+ real*4 hsegamma
+ real*4 hsegamma_p !Egamma, assuming proton
+ real*4 hsegamma_d !Egamma, assuming deuteron
+
+ common /hms_photo_param/
+ & hphoto_mtarget,
+ & hphoto_mrecoil,
+ & hsegamma,
+ & hsegamma_p,
+ & hsegamma_d
+
+*
+* CTPTYPE=parm
+*
+c D.Dutta, 24th-Apr-1996
+ real*4 hdelta_offset ! hms delta offset
+ real*4 htheta_offset ! hms scatteringangel offset
+ real*4 hphi_offset
+ real*4 hmomentum_factor ! multiplier for the hms momentum
+c J.Volmer, 9th-Jul-1999
+ real*4 hpcentral_offset ! hms central momentum offset
+ real*4 hthetacentral_offset ! hms central angle offset
+ real*4 h_oopcentral_offset ! hms central oop angle offset
+*
+* CTPTYPE=event
+*
+ common /hms_offsets/
+ & hdelta_offset,
+ & htheta_offset,
+ & hphi_offset,
+ & hmomentum_factor,
+ & hpcentral_offset,
+ & hthetacentral_offset,
+ & h_oopcentral_offset
+*
+* CTPTYPE=event
+*
+ real*4 hs_qvec(4)
+ real*4 hs_kpvec(4)
+ real*4 hs_kvec(4)
+ real*4 hs_tvec(4)
+
+ COMMON/hs_vectors/
+ & hs_qvec,
+ & hs_kpvec,
+ & hs_kvec,
+ & hs_tvec
diff --git a/INCLUDE/hms_recon_elements.cmn b/INCLUDE/hms_recon_elements.cmn
new file mode 100644
index 0000000..20b986f
--- /dev/null
+++ b/INCLUDE/hms_recon_elements.cmn
@@ -0,0 +1,48 @@
+* hms_recon_elements.cmn
+******************** Cosy reconstruction matrix elements. **********************
+* High Momentum Spectrometer *
+* Version 1.0, 18-Nov-1993 *
+* David Potterveld, Argonne National Lab. *
+* modified: 21-JAN-94 DFG change max_ to hmax_
+* $Log: hms_recon_elements.cmn,v $
+* Revision 1.5 1996/09/04 16:13:02 saw
+* (JRA) Add 5th element to h_recon_expon
+*
+* Revision 1.4 1995/08/08 15:41:57 cdaq
+* (DD) Add detector and angular offsets
+*
+* Revision 1.3 1995/04/06 20:19:23 cdaq
+* (SAW) Add parameters for ddutta's pre cosy transformation
+*
+* Revision 1.2 1994/08/05 19:30:03 cdaq
+* (SAW) Add "CTPTYPE=parm" directive for auto generation of CTP reg calls
+*
+* Revision 1.1 1994/02/22 14:45:52 cdaq
+* Initial revision
+*
+********************************************************************************
+* CTPTYPE=parm
+*
+ integer*4 hmax_recon_elements
+ parameter (hmax_recon_elements = 1000) !Max # coeff elements
+
+ real*4 h_recon_coeff(4,hmax_recon_elements)
+ real*4 h_ang_slope_x,h_ang_slope_y
+ real*4 h_ang_offset_x,h_ang_offset_y
+ real*4 h_det_offset_x,h_det_offset_y
+ real*4 h_z_true_focus ! Z position of HMS focus
+ integer*4 h_recon_expon(5,hmax_recon_elements)
+ integer*4 h_num_recon_terms
+ integer*4 h_recon_initted
+
+ common /hms_recon_elements/
+ > h_recon_initted, !Initialization flag.
+ > h_num_recon_terms, !Number of terms.
+ > h_recon_coeff, !Coefficients.
+ > h_recon_expon, !Exponents.
+ > h_ang_slope_x, h_ang_slope_y, ! Slopes for rotation of f plane
+ > h_ang_offset_x, h_ang_offset_y, ! Slopes for rotation of f plane
+ > h_det_offset_x,h_det_offset_y, ! Detector offsets
+ > h_z_true_focus ! Z position of SOS focus
+
+********************************************************************************
diff --git a/INCLUDE/hms_scin_parms.cmn b/INCLUDE/hms_scin_parms.cmn
new file mode 100644
index 0000000..34579cc
--- /dev/null
+++ b/INCLUDE/hms_scin_parms.cmn
@@ -0,0 +1,207 @@
+* hms_scin_parms.cmn - two common blocks:
+*
+* hms_scin_parms - variables from the hms_positions.parm file
+* hms_tof_parms - tof correction parameters and position parameters
+* converted to arrays over plane,counter by h_init_scin.
+*
+* NOTE: Variables whose names start with hHODO are arrays over
+* plane and counter. hSCIN is used for parameters from the
+* .parm files and for arrays over hits.
+*
+* Modified 23 March 1994 DFG
+* Add definition of hnum_scin_elements and set parameter value
+* $Log: hms_scin_parms.cmn,v $
+* Revision 1.11.24.1.2.1 2008/11/17 15:57:39 cdaq
+* Removed old tof varaibles
+*
+* Revision 1.11.24.1 2007/10/24 16:37:21 cdaq
+* *** empty log message ***
+*
+* Revision 1.11.22.1 2007/05/02 21:10:47 jones
+* Add new HMS hodo params for adjusting scintillator timing using P Bosted's method.
+*
+* Revision 1.11 1996/09/04 16:24:13 saw
+* (JRA) Add misc scaler
+*
+* Revision 1.10 1996/01/24 16:19:42 saw
+* (JRA) Cosmetic change
+*
+* Revision 1.9 1995/08/11 16:32:51 cdaq
+* (JRA) Remove old dpos stuff
+* Add hscin_zero accumulators
+*
+* Revision 1.8 1995/07/28 14:37:25 cdaq
+* (JRA) Add dimension to hmisc_dec_data
+*
+* Revision 1.7 1995/05/22 19:11:18 cdaq
+* (SAW) Split gen_data_data_structures into gen, hms, sos, and coin parts.
+* Make pedestal arrays real. Add hms_scin_positions and hms_misc_parms commons
+*
+* Revision 1.6 1995/03/13 19:08:45 cdaq
+* (JRA) Move hnum_scin_elements to gen_data_structures, remove
+* hscin_num_counters. Change hscin_??_top and _left to center and offset.
+* Add hscin_??_spacing parms. Change hhodo_center_coord to hhodo_center.
+* Add hhodo_???_minph tables.
+*
+* Revision 1.5 1994/09/13 21:01:55 cdaq
+* (JRA) Include arrays for scintillator pedestals
+*
+* Revision 1.4 1994/09/13 19:24:18 cdaq
+* (JRA) Remove hhodo_zpos, add staggering of scintillators
+*
+* Revision 1.3 1994/08/05 15:27:18 cdaq
+* (SAW) Add makereg directive with required include files
+*
+* Revision 1.2 1994/08/04 17:55:08 cdaq
+* (SAW) Add "CTPTYPE=parm" directive for auto generation of CTP reg calls
+*
+* Revision 1.1 1994/04/12 21:10:43 cdaq
+* Initial revision
+*
+* The following include statments must precede the inclusion of this
+* file in each routine that uses it. The *%% syntax is also a
+* directive to makereg to tell it to include the code in the program
+* that it generates.
+*
+*%% include 'hms_data_structures.cmn'
+*
+* CTPTYPE=parm
+*
+* from parameter file
+ integer*4 hscin_1x_nr
+ integer*4 hscin_1y_nr
+ integer*4 hscin_2x_nr
+ integer*4 hscin_2y_nr
+ integer*4 hdebugprintscinraw
+ integer*4 hdebugprintscindec
+ integer*4 hdebugprinttoftracks
+ integer*4 hdebugprinttracktests
+ real*4 hscin_1x_zpos
+ real*4 hscin_1y_zpos
+ real*4 hscin_2x_zpos
+ real*4 hscin_2y_zpos
+ real*4 hscin_1x_dzpos
+ real*4 hscin_1y_dzpos
+ real*4 hscin_2x_dzpos
+ real*4 hscin_2y_dzpos
+ real*4 hscin_1x_left
+ real*4 hscin_1y_top
+ real*4 hscin_2x_left
+ real*4 hscin_2y_top
+ real*4 hscin_1x_right
+ real*4 hscin_1y_bot
+ real*4 hscin_2x_right
+ real*4 hscin_2y_bot
+ real*4 hscin_1x_center(hnum_scin_elements)
+ real*4 hscin_1y_center(hnum_scin_elements)
+ real*4 hscin_2x_center(hnum_scin_elements)
+ real*4 hscin_2y_center(hnum_scin_elements)
+ real*4 hscin_1x_offset
+ real*4 hscin_1y_offset
+ real*4 hscin_2x_offset
+ real*4 hscin_2y_offset
+ real*4 hscin_1x_size
+ real*4 hscin_1y_size
+ real*4 hscin_2x_size
+ real*4 hscin_2y_size
+ real*4 hscin_1x_spacing
+ real*4 hscin_1y_spacing
+ real*4 hscin_2x_spacing
+ real*4 hscin_2y_spacing
+ real*4 hscin_all_ped_pos(hnum_scin_planes,hnum_scin_elements)
+ real*4 hscin_all_ped_neg(hnum_scin_planes,hnum_scin_elements)
+
+ common/hms_scin_parms/ !variables from h_positions.parm
+ & hscin_1x_nr, hscin_1y_nr, !Elements per plane
+ & hscin_2x_nr, hscin_2y_nr,
+ & hscin_1x_zpos, hscin_1y_zpos, !z position of plane.
+ & hscin_2x_zpos, hscin_2y_zpos,
+ & hscin_1x_dzpos, hscin_1y_dzpos,
+ & hscin_2x_dzpos, hscin_2y_dzpos,
+ & hscin_1x_left, hscin_1y_top, !position of 'negative'(??) end.
+ & hscin_2x_left, hscin_2y_top,
+ & hscin_1x_right, hscin_1y_bot, !position of 'positive'(??) end.
+ & hscin_2x_right, hscin_2y_bot,
+ & hscin_1x_center, hscin_1y_center, !center (transverse) of element.
+ & hscin_2x_center, hscin_2y_center,
+ & hscin_1x_size, hscin_1y_size, !width of elements.
+ & hscin_2x_size, hscin_2y_size,
+ & hscin_1x_spacing, hscin_1y_spacing, !separation of centers.
+ & hscin_2x_spacing, hscin_2y_spacing,
+ & hdebugprintscinraw,
+ & hdebugprintscindec,
+ & hdebugprinttoftracks,
+ & hdebugprinttracktests,
+ & hscin_all_ped_pos,
+ & hscin_all_ped_neg,
+ & hscin_1x_offset, hscin_1y_offset, !offset from nominal trans pos.
+ & hscin_2x_offset, hscin_2y_offset
+
+* Physical paramteres of counters. Use hhodo_* for arrays that include
+* the entire hodoscope, hscin_* for arrays that loop over hits.
+ real*4 hnum_scin_counters(hnum_scin_planes)
+ real*4 hhodo_center(hnum_scin_planes,hnum_scin_elements)
+ real*4 hhodo_width(hnum_scin_planes,hnum_scin_elements)
+ real*4 hhodo_pos_coord(hnum_scin_planes,hnum_scin_elements)
+ real*4 hhodo_neg_coord(hnum_scin_planes,hnum_scin_elements)
+
+* callibration type variables.
+ real*4 hhodo_slop(hnum_scin_planes)
+ real*4 hhodo_pos_sigma(hnum_scin_planes,hnum_scin_elements)
+ real*4 hhodo_neg_sigma(hnum_scin_planes,hnum_scin_elements)
+ real*4 hhodo_pos_invadc_offset(hnum_scin_planes,hnum_scin_elements)
+ real*4 hhodo_neg_invadc_offset(hnum_scin_planes,hnum_scin_elements)
+ real*4 hhodo_pos_invadc_linear(hnum_scin_planes,hnum_scin_elements)
+ real*4 hhodo_neg_invadc_linear(hnum_scin_planes,hnum_scin_elements)
+ real*4 hhodo_pos_invadc_adc(hnum_scin_planes,hnum_scin_elements)
+ real*4 hhodo_neg_invadc_adc(hnum_scin_planes,hnum_scin_elements)
+
+* correction parameters and position information converted to arryas
+* over plane and counter
+
+ common/hms_tof_parms/
+ & hnum_scin_counters,
+ & hhodo_center,
+ & hhodo_width,
+ & hhodo_pos_coord,
+ & hhodo_neg_coord,
+ & hhodo_slop,
+ & hhodo_pos_sigma,
+ & hhodo_neg_sigma,
+ > hhodo_pos_invadc_offset,
+ > hhodo_neg_invadc_offset,
+ > hhodo_pos_invadc_linear,
+ > hhodo_neg_invadc_linear,
+ > hhodo_pos_invadc_adc,
+ > hhodo_neg_invadc_adc
+*
+*
+* hms_misc_parms.cmn - misc tdc's filled as array over signal number
+* (tdc is sparsified, so the raw signals are array over hits)
+*
+* CTPTYPE=parm
+*
+ integer*4 hnum_misc_planes
+ parameter(hnum_misc_planes=2) !(1=TDC, 2=ADC)
+*
+* CTPTYPE=event
+*
+ integer*4 hmisc_dec_data(hmax_misc_hits,hnum_misc_planes)
+ integer*4 hmisc_scaler(hmax_misc_hits,hnum_misc_planes)
+
+ common/hms_misc_parms/
+ & hmisc_dec_data,
+ & hmisc_scaler
+
+
+ integer*4 hscin_zero_pos(hnum_scin_planes,hnum_scin_elements)
+ integer*4 hscin_zero_neg(hnum_scin_planes,hnum_scin_elements)
+ integer*4 hscin_zero_num(hnum_scin_planes,hnum_scin_elements)
+ real*4 hscin_zero_pave(hnum_scin_planes,hnum_scin_elements)
+ real*4 hscin_zero_nave(hnum_scin_planes,hnum_scin_elements)
+
+ common /hms_scin_zero/
+ & hscin_zero_pos,hscin_zero_neg,
+ & hscin_zero_num,
+ & hscin_zero_pave,hscin_zero_nave
+
diff --git a/INCLUDE/hms_scin_tof.cmn b/INCLUDE/hms_scin_tof.cmn
new file mode 100644
index 0000000..bc2c8c4
--- /dev/null
+++ b/INCLUDE/hms_scin_tof.cmn
@@ -0,0 +1,165 @@
+* hms_scin_tof.cmn: common block used by the subroutines that
+* calculate the hms time of flight.
+* $Log: hms_scin_tof.cmn,v $
+* Revision 1.12.6.1.2.1 2008/11/17 15:57:00 cdaq
+* Removed old tof varaibles
+*
+* Revision 1.12.6.1 2007/10/24 16:37:21 cdaq
+* *** empty log message ***
+*
+* Revision 1.12.4.1 2007/05/02 21:16:08 jones
+* Add new internal arrays used for adjusting scintillator timing using P Bosted's method.
+*
+* Revision 1.12 2005/03/15 21:14:28 jones
+* Add variables htof_tolerance and stof_tolerance to be used to filter the scintillator tdc hits and group them by time. ( P. Bosted)
+*
+*
+* Revision 1.11 1996/04/30 13:40:30 saw
+* (JRA) Add hbeta_p, hbeta_pcent
+*
+* Revision 1.10 1995/05/22 19:04:27 cdaq
+* (SAW) Split gen_data_data_structures into gen, hms, sos, and coin parts
+* Add some varaibles.
+*
+* Revision 1.9 1995/03/13 19:13:03 cdaq
+* (JRA) Change hscin_minph to hscin_???_minph arrays. Add tracks index to
+* hgood_tdc_pos, hgood_tdc_neg, hgood_scin_time, hgood_plane_time,
+* and hgood_beta.
+*
+* Revision 1.8 1995/01/27 21:03:16 cdaq
+* (SAW) Add htof_debugging common
+*
+* Revision 1.7 1994/09/13 19:29:50 cdaq
+* (JRA) Add focal plane time
+*
+* Revision 1.6 1994/08/16 03:56:33 cdaq
+* (SAW) Change some variables to parm CTPTYPE
+*
+* Revision 1.5 1994/08/05 15:29:44 cdaq
+* (SAW) Add makereg directive with required include files
+*
+* Revision 1.4 1994/08/04 18:02:13 cdaq
+* (SAW) Add "CTPTYPE=event" directive for auto generation of CTP reg calls
+*
+* Revision 1.3 1994/07/08 19:27:12 cdaq
+* (JRA) Add hscin_on_track table
+*
+* Revision 1.2 1994/05/13 02:51:53 cdaq
+* (DFG) Remove parameter statements. More are CTP variables
+*
+* Revision 1.1 1994/04/13 18:06:20 cdaq
+* Initial revision
+*
+* The following include statments must precede the inclusion of this
+* file in each routine that uses it. The *%% syntax is also a
+* directive to makereg to tell it to include the code in the program
+* that it generates.
+*
+*%% include 'hms_data_structures.cmn'
+*%% include 'hms_scin_parms.cmn'
+*
+* CTPTYPE=event
+*
+ integer*4 hntof
+
+ real*4 hscin_long_coord(hmax_scin_hits)
+ real*4 hscin_trans_coord(hmax_scin_hits)
+ real*4 hscin_pos_coord(hmax_scin_hits)
+ real*4 hscin_neg_coord(hmax_scin_hits)
+ real*4 hscin_pos_sigma(hmax_scin_hits)
+ real*4 hscin_neg_sigma(hmax_scin_hits)
+ real*4 hscin_pos_time(hmax_scin_hits)
+ real*4 hscin_neg_time(hmax_scin_hits)
+ real*4 hscin_sigma(hmax_scin_hits)
+ real*4 hscin_time(hmax_scin_hits)
+ real*4 hscin_time_fp(hmax_scin_hits)
+ real*4 hscin_pos_invadc_offset(hmax_scin_hits)
+ real*4 hscin_neg_invadc_offset(hmax_scin_hits)
+ real*4 hscin_pos_invadc_linear(hmax_scin_hits)
+ real*4 hscin_neg_invadc_linear(hmax_scin_hits)
+ real*4 hscin_pos_invadc_adc(hmax_scin_hits)
+ real*4 hscin_neg_invadc_adc(hmax_scin_hits)
+
+*
+* CTPTYPE=parm
+*
+ real*4 hscin_tdc_min
+ real*4 hscin_tdc_max
+ real*4 hscin_tdc_to_time
+ real*4 hstart_time_center ! center of time window on scin. hits
+ real*4 hstart_time_slop ! 1/2 width of time window on scin. hits
+ real*4 htof_tolerance ! tolerance for tof window in nsec
+*
+* CTPTYPE=event
+*
+ logical*4 hgood_tdc_pos(hntracks_max,hmax_scin_hits)
+ logical*4 hgood_tdc_neg(hntracks_max,hmax_scin_hits)
+ logical*4 hgood_scin_time(hntracks_max,hmax_scin_hits)
+ logical*4 hgood_plane_time(hntracks_max,hnum_scin_planes)
+ logical*4 hgood_beta(hntracks_max)
+ logical*4 hscin_on_track(hntracks_max,hmax_scin_hits)
+
+ common/hms_scin_tof/
+ & hntof,
+ & hscin_long_coord,
+ & hscin_trans_coord,
+ & hscin_pos_coord,hscin_neg_coord, !position of tubes
+ & hscin_pos_sigma,hscin_neg_sigma, !time resolution for tubes
+ & hscin_pos_time, hscin_neg_time, !time for 'pos' and 'neg' tubes.
+ & hscin_sigma, !time resolution for scin.
+ & hscin_time, !time for scin. (ave of tubes)
+ & hscin_tdc_min,
+ & hscin_tdc_max,
+ & hscin_tdc_to_time,
+ & hgood_tdc_pos, hgood_tdc_neg, !did pos/neg tube had good tdc?
+ & hgood_scin_time, !was a time found for the hit?
+ & hgood_plane_time, !was a time found for the plane?
+ & hgood_beta, !was a value of beta found?
+ & hscin_on_track, !list of scins on each track.
+ & hscin_time_fp, !scin time (ave) projected to fp
+ & hstart_time_center,
+ & hstart_time_slop,
+ & htof_tolerance,
+ > hscin_pos_invadc_offset,
+ > hscin_neg_invadc_offset,
+ > hscin_pos_invadc_linear,
+ > hscin_neg_invadc_linear,
+ > hscin_pos_invadc_adc,
+ > hscin_neg_invadc_adc
+
+*
+* CTPTYPE=event
+*
+ real*4 h_fptime(hnum_scin_planes) !time at fp from all hits in 1 plane
+ real*4 h_fptimedif(6) !fp time differences
+ real*4 hbeta_notrk
+ real*4 hbeta_chisq_notrk
+ real*4 hbeta_p !beta from mass and momentum
+ real*4 hbeta_pcent !beta for central momentum
+
+ common/htof_notrk/
+ & h_fptime,
+ & h_fptimedif,
+ & hbeta_notrk,
+ & hbeta_chisq_notrk,
+ & hbeta_p,
+ & hbeta_pcent
+
+c integer*4 hscin_pos_did(hnum_scin_planes,hnum_scin_elements)
+c integer*4 hscin_neg_did(hnum_scin_planes,hnum_scin_elements)
+c integer*4 hscin_pos_should(hnum_scin_planes,hnum_scin_elements)
+c integer*4 hscin_neg_should(hnum_scin_planes,hnum_scin_elements)
+c real*4 hscin_pos_eff(hnum_scin_planes,hnum_scin_elements)
+c real*4 hscin_neg_eff(hnum_scin_planes,hnum_scin_elements)
+c real*4 hscin_pos_solo(hnum_scin_planes,hnum_scin_elements)
+c real*4 hscin_neg_solo(hnum_scin_planes,hnum_scin_elements)
+c
+c common/hmore_debugging/
+c & hscin_pos_eff,
+c & hscin_neg_eff,
+c & hscin_pos_solo,
+c & hscin_neg_solo,
+c & hscin_pos_did,
+c & hscin_neg_did,
+c & hscin_pos_should,
+c & hscin_neg_should
diff --git a/INCLUDE/hms_statistics.cmn b/INCLUDE/hms_statistics.cmn
new file mode 100644
index 0000000..eee1849
--- /dev/null
+++ b/INCLUDE/hms_statistics.cmn
@@ -0,0 +1,219 @@
+* hms_statistics.cmn
+* common blocks containing event statistics for h_reconstruction
+* $Log: hms_statistics.cmn,v $
+* Revision 1.12.20.1 2007/08/22 19:09:31 frw
+* added FPP
+*
+* Revision 1.13 2006/06/22 frw
+* added FPP variables
+*
+* Revision 1.12 2003/09/05 21:05:10 jones
+* Merge in online03 changes (mkj)
+*
+* Revision 1.11.2.1 2003/04/02 22:26:20 cdaq
+* added some variables for scint. effic tests (from oct 1999 online) - JRA
+*
+* Revision 1.11 1996/09/04 16:24:34 saw
+* (SAW) Change ' to '' in comments
+*
+* Revision 1.10 1996/01/17 16:03:53 cdaq
+* (JRA) Remove some obsolete common blocks
+*
+* Revision 1.9 1995/09/01 13:04:38 cdaq
+* (JRA) Add counter efficiency variables
+*
+* Revision 1.8 1995/08/11 16:36:30 cdaq
+* (JRA) Add hstat_mineff as a ctp parameter
+*
+* Revision 1.7 1995/07/28 14:42:20 cdaq
+* (JRA) Add pos/neg/both good arrays
+*
+* Revision 1.6 1995/05/22 19:02:26 cdaq
+* (SAW) Split gen_data_data_structures into gen, hms, sos, and coin parts
+* Fix a conflicting common block name
+*
+* Revision 1.5 1995/03/13 19:15:31 cdaq
+* (JRA) Add many new statistics
+*
+* Revision 1.4 1994/08/05 19:40:20 cdaq
+* * (SAW) Add makereg directive with required include files
+* Add "CTPTYPE=parm" directive for auto generation of CTP reg calls
+*
+* Revision 1.3 1994/06/15 21:00:27 cdaq
+* (DFG) add scin plane efficiency
+*
+* Revision 1.2 1994/06/14 03:30:16 cdaq
+* (DFG) add chamber efficiency and sigma
+*
+* Revision 1.1 1994/06/06 16:52:57 cdaq
+* Initial revision
+*
+* The following include statments must precede the inclusion of this
+* file in each routine that uses it. The *%% syntax is also a
+* directive to makereg to tell it to include the code in the program
+* that it generates.
+*
+*%% include 'hms_data_structures.cmn'
+
+*
+* CTPTYPE=parm
+*
+ real*4 hstat_maxchisq
+ real*4 hstat_slop
+ real*4 hstat_mineff
+*
+* CTPTYPE=event
+*
+ integer*4 hstat_numevents
+ integer*4 hstat_trk(hnum_scin_planes,hnum_scin_elements)
+ integer*4 hstat_poshit(hnum_scin_planes,hnum_scin_elements)
+ integer*4 hstat_neghit(hnum_scin_planes,hnum_scin_elements)
+ integer*4 hstat_orhit(hnum_scin_planes,hnum_scin_elements)
+ integer*4 hstat_andhit(hnum_scin_planes,hnum_scin_elements)
+ integer*4 hstat_trksum(hnum_scin_planes)
+ integer*4 hstat_possum(hnum_scin_planes)
+ integer*4 hstat_negsum(hnum_scin_planes)
+ integer*4 hstat_orsum(hnum_scin_planes)
+ integer*4 hstat_andsum(hnum_scin_planes)
+ real*4 hstat_peff(hnum_scin_planes,hnum_scin_elements)
+ real*4 hstat_neff(hnum_scin_planes,hnum_scin_elements)
+ real*4 hstat_oeff(hnum_scin_planes,hnum_scin_elements)
+ real*4 hstat_aeff(hnum_scin_planes,hnum_scin_elements)
+ real*4 hstat_poseff(hnum_scin_planes)
+ real*4 hstat_negeff(hnum_scin_planes)
+ real*4 hstat_oreff(hnum_scin_planes)
+ real*4 hstat_andeff(hnum_scin_planes)
+ real*4 heff_s1
+ real*4 heff_s2
+ real*4 heff_stof
+ real*4 heff_4_of_4
+ real*4 heff_3_of_4
+
+ common/hscin_statistics/
+ & hstat_numevents,
+ & hstat_trk, !# of times track points near center of scin.
+ & hstat_poshit, !# of times the pos tube on scintillator fired
+ & hstat_neghit, !# of times the pos tube on scintillator fired
+ & hstat_orhit, !# of times either tube fired
+ & hstat_andhit, !# of times both tubes fired
+ & hstat_trksum, !summed over all counters on plane
+ & hstat_possum, !summed over all counters on plane
+ & hstat_negsum, !summed over all counters on plane
+ & hstat_orsum, !summed over all counters on plane
+ & hstat_andsum, !summed over all counters on plane
+ & hstat_peff, !pos efficiency for given counter.
+ & hstat_neff, !neg efficiency for given counter.
+ & hstat_oeff, !or efficiency for given counter.
+ & hstat_aeff, !and efficiency for given counter.
+ & hstat_poseff, !efficiency over all counters on plane
+ & hstat_negeff, !efficiency over all counters on plane
+ & hstat_oreff, !efficiency over all counters on plane
+ & hstat_andeff, !efficiency over all counters on plane
+ & hstat_slop, !distance allowed from center of scintillator.
+ & hstat_mineff, !give warning if effic. < hstat_mineff
+ & hstat_maxchisq, !maximum chisq allowed to use track for eff. calc.
+ & heff_s1, !calculated trigger eff. for s1 =(s1x .or. s1y).
+ & heff_s2, !calculated trigger eff. for s2 =(s2x .or. s2y).
+ & heff_stof, !calculated trigger eff. for stof =(s1 .and. s2).
+ & heff_4_of_4, !calculated trigger eff. for 4/4 planes.
+ & heff_3_of_4 !calculated trigger eff. for 3/4 planes.
+
+
+*
+* CTPTYPE=parm
+*
+ real*4 hstat_cal_maxchisq
+ real*4 hstat_cal_slop
+*
+* CTPTYPE=event
+*
+ integer*4 hstat_cal_numevents
+ integer*4 hstat_cal_trk(hmax_cal_columns,hmax_cal_rows)
+ integer*4 hstat_cal_hit(hmax_cal_columns,hmax_cal_rows)
+ integer*4 hstat_cal_trksum(hmax_cal_columns)
+ integer*4 hstat_cal_hitsum(hmax_cal_columns)
+ real*4 hstat_cal_eff(hmax_cal_columns,hmax_cal_rows)
+ real*4 hstat_cal_effsum(hmax_cal_columns)
+
+ common/hcal_statistics/
+ & hstat_cal_numevents,
+ & hstat_cal_trk, !# of times track points near center of block.
+ & hstat_cal_hit, !# of times the tube on block was over threshold.
+ & hstat_cal_trksum, !summed over all blocks on plane.
+ & hstat_cal_hitsum, !summed over all blocks on plane.
+ & hstat_cal_eff, !efficiency for a given block.
+ & hstat_cal_effsum, !efficiency over all counters on plane.
+ & hstat_cal_slop, !distance allowed from center of block.
+ & hstat_cal_maxchisq !maximum chisq allowed to use track for eff. calc.
+
+*
+* CTPTYPE=event
+*
+ integer*4 hbothgood(hnum_scin_planes,hnum_scin_elements)
+ integer*4 hposgood(hnum_scin_planes,hnum_scin_elements)
+ integer*4 hneggood(hnum_scin_planes,hnum_scin_elements)
+
+ common/hscin_posneg_stats/
+ & hbothgood,
+ & hposgood,
+ & hneggood
+*
+* CTPTYPE=parm
+*
+ real*4 hdc_min_eff(hmax_num_dc_planes) !''warning'' value for plane eff.
+*
+* CTPTYPE=event
+*
+ integer*4 hdc_tot_events !total number of events examined
+ integer*4 hdc_events(hmax_num_dc_planes) !counter of times plane was hit
+ integer*4 hdc_cham_hits(hmax_num_chambers)
+ real*4 hdc_plane_eff(hmax_num_dc_planes) !effic=events(pln)/tot_events
+ real*4 hdc_cham_eff(hmax_num_chambers)
+
+ common/hdc_statistics/
+ & hdc_tot_events,
+ & hdc_events,
+ & hdc_min_eff,
+ & hdc_plane_eff,
+ & hdc_cham_hits,
+ & hdc_cham_eff
+
+
+* The logical variables just record if that particular event passed the test
+* for 'plane should have fired' and 'plane did fire'. In CTP tests, we'll
+* apply additional cuts and check the efficiency.
+* 'Should' = event where other 3 hodoscope planes fired.
+* 'Did' = 'Should' && plane in question did fire.
+
+*
+* CTPTYPE=event
+*
+ logical*4 htrig_hodoshouldflag(hnum_scin_planes)
+ logical*4 htrig_hododidflag(hnum_scin_planes)
+ common/htrig_hodostatistics/
+ & htrig_hodoshouldflag,
+ & htrig_hododidflag
+
+*
+* Focal Plane Polarimeter variables (frw 2006/06/22)
+*
+*
+* CTPTYPE=event
+*
+ real*4 HFPP_stat_dist2closest ! distance to closest hit wire
+ integer*4 HFPP_stat_shouldhit ! # of wire fitted track passed
+ logical*4 HFPP_stat_diddhit ! true if shouldhit was hit (w/ slop)
+
+* * now the same again with sequential plane numbers for CTP
+ integer*4 HFPP_stat_planeshould
+ logical*4 HFPP_stat_planedidd
+
+ common/HMS_FPP_stats/
+ & HFPP_stat_dist2closest(H_FPP_N_DCSETS,H_FPP_N_DCINSET,
+ > H_FPP_N_DCLAYERS,H_FPP_MAX_TRACKS),
+ & HFPP_stat_shouldhit(H_FPP_N_DCSETS,H_FPP_N_DCINSET,
+ > H_FPP_N_DCLAYERS,H_FPP_MAX_TRACKS),
+ & HFPP_stat_diddhit(H_FPP_N_DCSETS,H_FPP_N_DCINSET,
+ > H_FPP_N_DCLAYERS,H_FPP_MAX_TRACKS),
+ & HFPP_stat_planeshould(H_FPP_N_PLANES,H_FPP_MAX_TRACKS),
+ & HFPP_stat_planedidd(H_FPP_N_PLANES,H_FPP_MAX_TRACKS)
diff --git a/INCLUDE/hms_track_histid.cmn b/INCLUDE/hms_track_histid.cmn
new file mode 100644
index 0000000..f131765
--- /dev/null
+++ b/INCLUDE/hms_track_histid.cmn
@@ -0,0 +1,104 @@
+*_______________________________________________________________________
+* hms_tracking_histid.cmn
+*
+* This common block contains the HBOOK histogram id numbers
+* for all hms histograms in which direct hfill calls are made.
+*
+* It also contains the paramter flags to turn on and off histograming
+* of each of the hard coded blocks.
+*
+* Created 9 April 1994 D. F. Geesaman
+* $Log: hms_track_histid.cmn,v $
+* Revision 1.8 1996/01/17 16:04:21 cdaq
+* (JRA) Add hidcuttdc and a temporary junk common block
+*
+* Revision 1.7 1995/05/22 19:12:18 cdaq
+* (SAW) Split gen_data_data_structures into gen, hms, sos, and coin parts
+*
+* Revision 1.6 1995/05/12 12:23:53 cdaq
+* (JRA) Modify/add user histograms
+*
+* Revision 1.5 1994/08/18 03:14:21 cdaq
+* * (SAW) Use arrays of histids for residuals
+*
+* Revision 1.4 1994/08/18 01:59:15 cdaq
+* (DM) Add residuals histid's
+*
+* Revision 1.3 1994/08/05 19:22:30 cdaq
+* (SAW) Add makereg directive with required include files
+* Add "CTPTYPE=parm" directive for auto generation of CTP reg calls
+*
+* Revision 1.2 1994/05/13 02:59:26 cdaq
+* (DFG) Add h_fill_dc_target_hist id's
+*
+* Revision 1.1 1994/04/12 21:08:57 cdaq
+* Initial revision
+*
+* The following include statments must precede the inclusion of this
+* file in each routine that uses it. The *%% syntax is also a
+* directive to makereg to tell it to include the code in the program
+* that it generates.
+*
+*%% include 'hms_data_structures.cmn'
+*
+* CTPTYPE=parm ! The following probably should not be registered
+*
+ integer*4 hiddcwiremap(hmax_num_dc_planes)
+ integer*4 hiddcdrifttime(hmax_num_dc_planes)
+ integer*4 hiddcdriftdis(hmax_num_dc_planes)
+ integer*4 hiddcwirecent(hmax_num_dc_planes)
+ integer*4 hidhx_fp,hidhy_fp,hidhxp_fp,hidhyp_fp,hidhlogchi2_fp,
+ & hidhnfree_fp,hidhchi2perdeg_fp
+ integer*4 hidhx_tar, hidhy_tar, hidhz_tar, hidhxp_tar, hidhyp_tar,
+ & hidhdelta_tar, hidhp_tar
+ integer*4 hidres_fp(hmax_num_dc_planes)
+ integer*4 hidsingres_fp(hmax_num_dc_planes)
+ integer*4 hidrawtdc
+ integer*4 hidcuttdc
+
+ common/hms_tracking_histid/
+ & hiddcwiremap,
+ & hiddcdrifttime,
+ & hiddcdriftdis,
+ & hiddcwirecent,
+ & hidhx_fp,
+ & hidhy_fp,
+ & hidhxp_fp,
+ & hidhyp_fp,
+ & hidhlogchi2_fp,
+ & hidhnfree_fp,
+ & hidhchi2perdeg_fp,
+ & hidhx_tar,
+ & hidhy_tar,
+ & hidhz_tar,
+ & hidhxp_tar,
+ & hidhyp_tar,
+ & hidhdelta_tar,
+ & hidhp_tar,
+ & hidres_fp,
+ & hidsingres_fp,
+ & hidrawtdc,
+ & hidcuttdc
+
+*
+* CTPTYPE=parm
+*
+ integer*4 hturnon_decoded_dc_hist
+ integer*4 hturnon_focal_plane_hist
+ integer*4 hturnon_target_hist
+ common/hms_hist_flags/
+ & hturnon_decoded_dc_hist,
+ & hturnon_focal_plane_hist,
+ & hturnon_target_hist
+
+* temporary junk common block.
+*
+* CTPTYPE=event
+*
+ real*4 hx_sp1(hntracks_max),hy_sp1(hntracks_max),hxp_sp1(hntracks_max)
+ real*4 hx_sp2(hntracks_max),hy_sp2(hntracks_max),hxp_sp2(hntracks_max)
+ real*4 hsx_sp1,hsy_sp1,hsxp_sp1
+ real*4 hsx_sp2,hsy_sp2,hsxp_sp2
+*
+ common/htemp_junk_cb/hx_sp1,hy_sp1,hxp_sp1,hx_sp2,hy_sp2,hxp_sp2,
+ & hsx_sp1,hsy_sp1,hsxp_sp1,hsx_sp2,hsy_sp2,hsxp_sp2
diff --git a/INCLUDE/hms_tracking.cmn b/INCLUDE/hms_tracking.cmn
new file mode 100644
index 0000000..61db216
--- /dev/null
+++ b/INCLUDE/hms_tracking.cmn
@@ -0,0 +1,482 @@
+* hms_tracking.cmn
+* include file for hms tracking intermediate results
+* D. F. Geesaman 1 September 1993
+* modified dfg 10 Feb 94
+* change name to hms_tracking.cmn
+* put hluno and debugflags from parameters to CTP
+* 15 Feb
+* separate dimensioning and number of planes
+* and chambers
+* $Log: hms_tracking.cmn,v $
+* Revision 1.27.20.3.2.2 2009/05/18 14:19:07 jones
+* Add parameters h_iwslop,h_max_hits_per_plane used in updated
+* h_trans_dc.f to prune raw DC hits.
+*
+* Revision 1.27.20.3.2.1 2009/05/04 14:37:31 jones
+* Increased hmax_space_points from 50 to 100
+*
+* Revision 1.27.20.3 2007/10/24 20:48:03 cdaq
+* *** empty log message ***
+*
+* Revision 1.27.20.2 2007/10/24 16:37:21 cdaq
+* *** empty log message ***
+*
+* Revision 1.27.20.1 2007/09/12 14:40:03 brash
+* *** empty log message ***
+*
+* Revision 1.27 2003/04/01 13:55:09 jones
+* Add variables hntracks_max_fp and h_remove_sppt_if_one_y_plane to
+* hms_tracking.cmn
+*
+* Revision 1.26 1999/02/23 19:18:42 csa
+* (JRA) Correct HMS_TFIT_MATRIX indices, remove hdebugcalcpeds
+*
+* Revision 1.25 1998/12/01 20:29:47 saw
+* (SAW) Put HMS_DRIFT common block before equivalences
+*
+* Revision 1.24 1996/09/04 16:25:26 saw
+* (DVW) Add slew of variables for derek's hms track tests
+*
+* Revision 1.23 1996/04/30 13:44:09 saw
+* (JRA) Lots of changes
+*
+* Revision 1.22 1996/01/17 15:18:42 cdaq
+* (JRA) Change name of various correction variables.
+* Add some efficiency accumulator variables.
+*
+* Revision 1.21 1995/05/22 19:01:32 cdaq
+* (SAW) Split gen_data_data_structures into gen, hms, sos, and coin parts
+*
+* Revision 1.20 1995/04/06 20:19:58 cdaq
+* (JRA) Change residuals variable names
+*
+* Revision 1.19 1995/01/27 20:19:59 cdaq
+* (JRA) Remove Mack's personal focalplane diceamatic (z slicer) code
+*
+* Revision 1.18 1994/12/06 12:46:07 cdaq
+* (DJM) Variables for focal plane z slices
+*
+* Revision 1.17 1994/11/22 18:42:03 cdaq
+* (SAW) Add h's in front of fract, aa3, det3, aainv3. Remove fractinterp
+* Cleaned up ?DC_NUM_CHAMBERS and ?MAX_NUM_CHAMBERS stuff
+*
+* Revision 1.16 1994/10/28 15:55:24 cdaq
+* (DM) Change drift time array parmeters to variables
+*
+* Revision 1.15 1994/10/12 18:16:13 cdaq
+* (DJM) Add good plane pattern arrays, add matrix inversion to initialization
+*
+* Revision 1.14 1994/09/20 17:13:25 cdaq
+* (SAW) Change HDC_HITS_PER_PLANE, HDC_SING_WCENTER, HDC_SING_WCOORD
+* to CTPTYPE=event registration
+*
+* Revision 1.13 1994/09/19 20:27:42 cdaq
+* (SAW) Add HDC_HITS_PER_PLANE (from gen_data_structures.cmn)
+* (DJM) Add HDC_SING_WCENTER and HDC_SING_WCOORD
+*
+* Revision 1.12 1994/08/31 19:38:59 cdaq
+* (DJM) Add by plane arrays of corrected drift time and distance
+* Add by plane arrays of residuals suitable for histogramming by CTP
+*
+* Revision 1.11 1994/08/18 02:15:35 cdaq
+* (DM) Add 2-d arrays for residuals
+* (DJM) Add parameter for drift time to ditance calculation
+*
+* Revision 1.10 1994/08/16 13:25:30 cdaq
+* (DJA) Add wire velocity correction parameters
+*
+* Revision 1.9 1994/08/16 03:56:54 cdaq
+* (SAW) Change some variables to parm CTPTYPE
+*
+* Revision 1.8 1994/08/05 15:47:37 cdaq
+* (SAW) Add makereg directive with required include files
+*
+* Revision 1.7 1994/08/04 15:31:41 cdaq
+* (DA) Incorporate small angle approximation of L/R for YY' planes
+*
+* Revision 1.6 1994/06/30 02:26:14 cdaq
+* (DFG) Add hmax_pr_hits
+*
+* Revision 1.5 1994/06/27 02:54:59 cdaq
+* (SAW) Increase hmax_chamber_hits to 544 from 100.
+*
+* Revision 1.4 1994/06/15 21:19:17 cdaq
+* (DFG) Add hdc_tdc_min_win and hdc_tdc_max_win.
+* Add hwire_early_mult, hwire_late_mult, hwire_extra_mult
+*
+* Revision 1.3 1994/06/06 16:40:04 cdaq
+* (DFG) add hsingle_stub
+*
+* Revision 1.2 1994/03/24 18:39:05 cdaq
+* (DFG) Additional parameters
+*
+* Revision 1.1 1994/02/22 14:46:44 cdaq
+* Initial revision
+*
+* The following include statments must precede the inclusion of this
+* file in each routine that uses it. The *%% syntax is also a
+* directive to makereg to tell it to include the code in the program
+* that it generates.
+*
+*%% include 'hms_data_structures.cmn'
+
+*----------------------------------------------------------------------
+* PARAMETERS FOR DRIFT TIME TO DISTANCE CALCULATION
+*
+* CTPTYPE=parm
+*
+ integer*4 hdriftbins_max ! number of bins for drift time lookup table
+ parameter (hdriftbins_max=138)
+ real*4 hdriftbins ! number of bins for drift time lookup table
+ real*4 hdriftbinsz ! drift bin size in nsec of lookup table
+ real*4 hdrift1stbin ! drift time of 1st bin in nsec of lookup
+ real*4 hfract !fraction of integrated time spectrum
+
+ real*4 hwc1x1fract(hdriftbins_max),hwc1y1fract(hdriftbins_max),
+ & hwc1u1fract(hdriftbins_max),hwc1v1fract(hdriftbins_max),
+ & hwc1y2fract(hdriftbins_max),hwc1x2fract(hdriftbins_max),
+ & hwc2x1fract(hdriftbins_max),hwc2y1fract(hdriftbins_max),
+ & hwc2u1fract(hdriftbins_max),hwc2v1fract(hdriftbins_max),
+ & hwc2y2fract(hdriftbins_max),hwc2x2fract(hdriftbins_max)
+
+ common/HMS_DRIFT/
+ $ hfract(hdriftbins_max,hmax_num_dc_planes),
+ $ hdriftbinsz,
+ $ hdrift1stbin,
+ $ hdriftbins
+
+ equivalence (hwc1x1fract(1),hfract(1,1))
+ equivalence (hwc1y1fract(1),hfract(1,2))
+ equivalence (hwc1u1fract(1),hfract(1,3))
+ equivalence (hwc1v1fract(1),hfract(1,4))
+ equivalence (hwc1y2fract(1),hfract(1,5))
+ equivalence (hwc1x2fract(1),hfract(1,6))
+ equivalence (hwc2x1fract(1),hfract(1,7))
+ equivalence (hwc2y1fract(1),hfract(1,8))
+ equivalence (hwc2u1fract(1),hfract(1,9))
+ equivalence (hwc2v1fract(1),hfract(1,10))
+ equivalence (hwc2y2fract(1),hfract(1,11))
+ equivalence (hwc2x2fract(1),hfract(1,12))
+
+*----------------------------------------------------------------------
+* INFORMATION ABOUT PLANE GEOMETRY AND TRACKING PARAMETERS
+*
+* CTPTYPE=parm
+*
+ integer*4 hmax_chamber_hits
+ parameter (hmax_chamber_hits=544)
+ integer*4 hmax_space_points ! maximum number of space points
+ parameter (hmax_space_points=100)
+ integer*4 hmax_hits_per_point ! maximum number of hits per point
+ parameter (hmax_hits_per_point=1000)
+ integer*4 hnum_fpray_param ! number of ray parameters in focal plane
+ parameter (hnum_fpray_param=4)
+ integer*4 hdc_num_cards ! #/discriminator cards
+ parameter (hdc_num_cards=72)
+ integer*4 hdc_max_wires_per_plane
+ parameter (hdc_max_wires_per_plane=113)
+
+ integer*4 hdc_num_planes ! actual number of dc chambers - set in CTP
+ integer*4 hdc_num_chambers ! actual number of chambers - set in CTP
+ integer*4 hdc_planes_per_chamber
+ integer*4 hdc_tdc_min_win ! drift chamber tdc min value for good hit
+ integer*4 hdc_tdc_max_win ! drfit chamber tdc max value for good hit
+ integer*4 hmin_hit ! minimum hits for space point
+ integer*4 hmin_combos ! minimum combos for space point
+ integer*4 hmax_pr_hits ! max number of hits in each plane for
+ ! pattern recognition to be done in that pla
+* wire velocity corrections.
+ logical hdc_readout_x !true = read out from side (like x plane)
+ real*4 hdc_readout_corr !wire path length/dist. to readout side
+ real*4 hdc_wire_velocity ! propogation velocity of signal on wire(cm/ns)
+ real*4 hdc_drifttime_sign !sign of correction term.
+ real*4 hdc_central_time !ave. time (ns) for signal to reach disc. card.
+ ! (both times are from center of the chamber)
+* timing offsets per card.
+ integer*4 hdc_sing_cardid ! array of card id''s so one can put cuts/test on a per/card basys
+ integer*4 hdc_card_no ! card number
+ real*4 hdc_card_delay ! delay for a given card
+
+ real*4 hxt_track_criterion ! stub link criterion on x_t
+ real*4 hyt_track_criterion ! stub link criterion on y_t
+ real*4 hxpt_track_criterion ! stub link criterion on xp_t
+ real*4 hypt_track_criterion ! stub link criterion on yp_t
+ real*4 hstub_max_xpdiff ! stub criterion for l/r determination
+ real*4 hspace_point_criterion ! maximum distance**2 to join pairs/combos.
+ INTEGER*4 HNTRACKS_MAX_FP ! NUMBER OF TRACKS ALLOWED IN FOCAL PLANE
+ integer*4 h_remove_sppt_if_one_y_plane ! flag used in h_pattern_recognition.f
+* parameter used in purging bad wire from DC in h_trans_dc.f
+* recommended value is 0
+ real h_iwslop
+* parameter used in purging excess wires in h_trans_dc.f
+* recommended value is 6
+ integer h_max_hits_per_plane
+*
+* CTPTYPE=event
+*
+ integer*4 hncham_hits
+ integer*4 hnspace_points ! number of space points in each chamber
+ integer*4 hdc_hits_per_plane
+ integer*4 htrack_fit_num ! track number in fitting loop
+ integer*4 hnspace_points_tot ! total number of space points after select.
+ integer*4 gplanehdc1,gplanehdc2 ! good plane pattern unit, set bit if respective plane hit
+ integer*4 hspace_point_hits ! array of n rows of space points
+ ! (n,1) = number of hits
+ ! (n,2) = number of valid combinations
+ ! (n,3...) hit numbers for space point
+ real*4 hspace_points ! array of x, y of space points
+ real*4 hbeststub ! array of stubs fit to each space point
+ real*4 hdc_sing_drifttime ! array of fully corrected drift times for each plane
+ real*4 hdc_sing_driftdis ! array of final drift distances for each plane
+
+*
+ common/HMS_TRACKING/
+ & hdc_num_chambers,hdc_num_planes,
+ & hdc_planes_per_chamber,
+ & hdc_hits_per_plane(hmax_num_dc_planes),
+ & gplanehdc1(hmax_space_points),
+ & gplanehdc2(hmax_space_points),
+ & hspace_points(hmax_space_points,2),
+ & hspace_point_hits(hmax_space_points,hmax_hits_per_point+2),
+ & hnspace_points(hmax_num_chambers),
+ & hnspace_points_tot,
+ & hbeststub(hmax_space_points,hnum_fpray_param),
+ & hncham_hits(hmax_num_chambers),
+ & htrack_fit_num,
+ & hspace_point_criterion(hmax_num_chambers),
+ & hdc_tdc_min_win(hmax_num_dc_planes),
+ & hdc_tdc_max_win(hmax_num_dc_planes),
+ & hmin_hit(hmax_num_chambers),hmin_combos(hmax_num_chambers),
+ & hmax_pr_hits(hmax_num_chambers),
+ & hxt_track_criterion,hyt_track_criterion,
+ & hxpt_track_criterion,hypt_track_criterion,
+ & hstub_max_xpdiff,
+ & hdc_sing_drifttime(hmax_num_dc_planes),
+ & hdc_sing_driftdis(hmax_num_dc_planes),
+ & hdc_wire_velocity,
+ & hdc_central_time(hmax_num_dc_planes),
+ & hdc_drifttime_sign(hmax_num_dc_planes),
+ & hdc_readout_corr(hmax_num_dc_planes),
+ & hdc_readout_x(hmax_num_dc_planes),
+ & hdc_card_delay(hdc_num_cards),
+ & hdc_card_no(hdc_max_wires_per_plane,hmax_num_dc_planes),
+ & hdc_sing_cardid(hmax_num_dc_planes),
+ & HNTRACKS_MAX_FP,h_remove_sppt_if_one_y_plane
+ > ,h_iwslop,h_max_hits_per_plane
+
+
+
+*----------------------------------------------------------------------
+* MATRICES FOR 3 PARAMETER FITS.
+*
+* CTPTYPE=parm
+*
+ real*8 haa3,haainv3 ! matrix AA and its inverse AAINV
+ real*8 hdet3 ! array of determinants of AA
+ common/HMS_TFIT_MATRIX/
+ & haa3(3,3),haainv3(3,3,44),hdet3(44)
+
+
+
+*----------------------------------------------------------------------
+* DRIFT CHAMBER DEBUGGING FLAGS/INFO.
+*
+* CTPTYPE=parm
+*
+* debug print flags, if flags .ne. 0 then execute debug code
+ integer*4 hdebugprintrawdc
+ integer*4 hdebugprintdecodeddc
+ integer*4 hdebugflagpsi
+ integer*4 hdebugflaggeometry
+ integer*4 hdebugflagpr
+ integer*4 hdebugflagstubs
+ integer*4 hdebuglinkstubs
+ integer*4 hdebugtrackprint
+ integer*4 hdebugstubchisq
+ integer*4 hdebugtartrackprint ! call h_print_tar_track
+ integer*4 hdebugdumptof ! dumps tof fitting data
+ integer*4 hdebugdumpcal ! dumps cal fitting data
+ integer*4 hsingle_stub ! switch to make tracks of all stubs
+ integer*4 hSmallAngleApprox ! switch for alternate L/R determ. of Y,Yprime planes
+ integer*4 hluno ! logical unit number for debugging output
+
+ integer*4 hdumptof ! dumps tof fitting data from h_tof
+
+ common/HMS_TRACKFLAGS/
+ & hluno,
+ & hdumptof,
+ & hdebugflagpsi,
+ & hdebugflaggeometry,
+ & hdebugflagpr,
+ & hdebugflagstubs,
+ & hdebuglinkstubs,
+ & hdebugtrackprint,
+ & hdebugstubchisq,
+ & hdebugtartrackprint,
+ & hdebugprintrawdc,
+ & hdebugprintdecodeddc,
+ & hdebugdumptof,
+ & hdebugdumpcal,
+ & hsingle_stub,
+ & hSmallAngleApprox
+
+*----------------------------------------------------------------------
+* DRIFT CHAMBER EFFICIENCY MEASUREMENTS.
+*
+* CTPTYPE=parm
+*
+* warning levels for efficiency
+ real*4 hdc_min_plane_eff(hmax_num_dc_planes)
+ real*4 hdc_min_wire_eff
+*
+* CTPTYPE=event
+*
+* multiple hits per wire statistics.
+ integer*4 hwire_mult(hdc_max_wires_per_plane,hmax_num_dc_planes)
+ integer*4 hwire_early_mult(hdc_max_wires_per_plane,hmax_num_dc_planes)
+ integer*4 hwire_late_mult(hdc_max_wires_per_plane,hmax_num_dc_planes)
+ integer*4 hwire_extra_mult(hdc_max_wires_per_plane,hmax_num_dc_planes)
+* stuff for calcualting efficiency per wire.
+ integer*4 hdc_shouldhit(hmax_num_dc_planes,hdc_max_wires_per_plane)
+ integer*4 hdc_didhit(hmax_num_dc_planes,hdc_max_wires_per_plane)
+ integer*4 hdc_shouldsum(hmax_num_dc_planes)
+ integer*4 hdc_didsum(hmax_num_dc_planes)
+ integer*4 hdc_eff(hmax_num_dc_planes)
+ real*4 hdc_track_coord(hntracks_max,hmax_num_dc_planes)
+ real*4 hsdc_track_coord(hmax_num_dc_planes)
+
+ common/hms_dc_track_efficiency/
+ & hdc_track_coord, !track position per plane, in x,y,u,v directions.
+ & hsdc_track_coord, !track position in x,y,,u,v directions-final track.
+ & hdc_shouldhit, !times a wire should have fired.
+ & hdc_didhit, !times a wire did fire.
+ & hdc_shouldsum, !sum over plane.
+ & hdc_didsum, !sum over plane.
+ & hdc_eff, !effic. per plane.
+ & hdc_min_wire_eff, !warning level for wire effic.
+ & hdc_min_plane_eff, !warning level for plane effic.
+ & hwire_mult,
+ & hwire_early_mult,
+ & hwire_late_mult,
+ & hwire_extra_mult
+
+
+*----------------------------------------------------------------------
+* DRIFT CHAMBER RESIDUALS
+*
+* CTPTYPE=event
+*
+* complete 2-D array for residuals in all planes over all tracks
+ real*4 hdc_single_residual(hntracks_max,hmax_num_dc_planes)
+ real*4 hdc_double_residual(hntracks_max,hmax_num_dc_planes)
+
+* djm 8/26/94 arrays containing single and double residual arrays which can be
+* histogrammed in the normal fashion (ie, not hardwired histograms).
+
+ real*4 hdc_sing_res(hmax_num_dc_planes)
+ real*4 hdc_dbl_res(hmax_num_dc_planes)
+ real*4 hdc_plane_wirecoord(hntracks_max,hmax_num_dc_planes)
+ real*4 hdc_plane_wirecenter(hntracks_max,hmax_num_dc_planes)
+
+ common/HMS_RESIDUAL/
+ & hdc_single_residual,
+ & hdc_double_residual,
+ & hdc_sing_res,
+ & hdc_dbl_res,
+ & hdc_plane_wirecoord,
+ & hdc_plane_wirecenter
+
+
+*----------------------------------------------------------------------
+* DEADWIRE LIST
+*
+* CTPTYPE=parm
+*
+ integer*4 hmax_num_deadwires
+ parameter (hmax_num_deadwires=60)
+ integer*4 hdc_num_deadwires
+ integer*4 hdc_deadwire_plane(hmax_num_deadwires)
+ integer*4 hdc_deadwire_num(hmax_num_deadwires)
+
+ common/hms_dead_wires/
+ & hdc_num_deadwires, !number of dead wires.
+ & hdc_deadwire_plane, !list of plane numbers.
+ & hdc_deadwire_num !list of wire numbers.
+*
+* CTPTYPE=parm
+*
+ logical h1hit1,h1hit2,h1hit3,h1hit4,h1hit5,h1hit6
+ logical h1hit7,h1hit8,h1hit9,h1hit10,h1hit11,h1hit12
+ integer hnumhit1,hnumhit2,hnumhit3,hnumhit4,hnumhit5,hnumhit6
+ integer hnumhit7,hnumhit8,hnumhit9,hnumhit10,hnumhit11,hnumhit12
+ logical h1hitslt,h2hitslt,h1planesgt,h2planesgt
+ logical hhitslt,hplanesgt
+ logical hstublt
+ logical f1hspacepoints,f2hspacepoints,fhspacepoints
+ logical hhitsplanes,hhitsplanessps,hhitsplanesspsstubs
+ logical hspacepoints
+ logical htest1,htest2
+ logical hfoundtrack, hcleantrack
+ integer hnumhits1,hnumhits2,hnumplanes1,hnumplanes2
+ integer hnumscins1,hnumscins2,hnumscins3,hnumscins4
+ integer hstubtest
+ real*4 hstubminx,hstubminy,hstubminxp,hstubminyp
+ integer hscinhit(4,16)
+ integer hnclust(4)
+ integer hthreescin(4)
+ integer hslope
+ integer hbestxpscin
+ integer hbestypscin
+ integer hgoodscinhits
+ integer hxloscin(hmax_num_chambers),hxhiscin(hmax_num_chambers)
+ integer hyloscin(hmax_num_chambers),hyhiscin(hmax_num_chambers)
+ integer htrack_eff_test_num_scin_planes
+
+ common/dereks_hms_track_tests/
+ & h1hit1,
+ & h1hit2,
+ & h1hit3,
+ & h1hit4,
+ & h1hit5,
+ & h1hit6,
+ & h1hit7,
+ & h1hit8,
+ & h1hit9,
+ & h1hit10,
+ & h1hit11,
+ & h1hit12,
+ & hnumhit1,hnumhit2,hnumhit3,hnumhit4,hnumhit5,hnumhit6,
+ & hnumhit7,hnumhit8,hnumhit9,hnumhit10,hnumhit11,hnumhit12,
+ & h1hitslt,
+ & h2hitslt,
+ & h1planesgt,
+ & h2planesgt,
+ & hhitslt,
+ & hplanesgt,
+ & hstublt,
+ & f1hspacepoints,
+ & f2hspacepoints,
+ & fhspacepoints,
+ & hhitsplanes,
+ & hhitsplanessps,
+ & hhitsplanesspsstubs,
+ & hspacepoints,
+ & htest1,htest2,
+ & hfoundtrack,
+ & hcleantrack,
+ & hnumhits1,hnumhits2,hnumplanes1,hnumplanes2,
+ & hnumscins1,hnumscins2,hnumscins3,hnumscins4,
+ & hstubtest,
+ & hstubminx,
+ & hstubminy,
+ & hstubminxp,
+ & hstubminyp,
+ & hscinhit,
+ & hnclust,
+ & hthreescin,
+ & hslope,
+ & hbestxpscin,
+ & hbestypscin,
+ & hgoodscinhits,
+ & hxloscin,hxhiscin,hyloscin,hyhiscin,
+ & htrack_eff_test_num_scin_planes
diff --git a/INCLUDE/insane_scalers.cmn b/INCLUDE/insane_scalers.cmn
new file mode 100644
index 0000000..9e5b6b8
--- /dev/null
+++ b/INCLUDE/insane_scalers.cmn
@@ -0,0 +1,4 @@
+**************************begin: insane_scalers.cmn ***********************
+ INTEGER insane_last_event_id, insane_run_number
+ COMMON /insane_scalers/ insane_last_event_id, insane_run_number
+****************************end: insane_scalers.cmn ***********************
diff --git a/INCLUDE/mc_structures.cmn b/INCLUDE/mc_structures.cmn
new file mode 100644
index 0000000..cf689f3
--- /dev/null
+++ b/INCLUDE/mc_structures.cmn
@@ -0,0 +1,117 @@
+*****************begin: mc_structures.cmn*************************
+*-
+*- This file defines the structure of GEANT simulated quantities
+*- to be packed in a FASTBUS-CODA file.
+*- 6-Feb-1994 K.B.Beard, Hampton U.
+*- Modified to add path length, internal setup 7-Feb-1994 KBB
+*-
+*- note: units are hall C standard units: GeV, cm, nSec
+* ID numbers are as given by "g_decode" package.
+* $Log: mc_structures.cmn,v $
+* Revision 1.2 1994/06/08 19:49:44 cdaq
+* (KBB) Modified to change storage (24-Feb-1994)
+*
+* Revision 1.1 1994/02/17 21:01:14 cdaq
+* Initial revision
+*
+*-
+ CHARACTER*4 mc_TEST_C4
+ REAL*4 mc_TEST_R4
+ INTEGER*4 mc_TEST_I4
+*-
+*- following are used to determine the proper byte swapping;
+*- sort of a "Rosetta Stone" for CODA files
+*-
+*- each of 4 bytes unique!
+ PARAMETER (mc_TEST_C4= 'gMc_') !program pkg
+ PARAMETER (mc_TEST_R4= 2.24) !version
+ PARAMETER (mc_TEST_I4= '23fb1994'x) !date
+*-
+*- identifing status and ROC integer
+ INTEGER mc_status_and_ROC
+ PARAMETER (mc_status_and_ROC= 'FFFF'x)
+*-
+*- status of all subsequent Monte Carlo info.
+ LOGICAL mc_READY
+*-
+*- All tracks are put in sequentially (don't start over with #1 for 2nd arm)
+*-
+ INTEGER mc_MAX_Trks !upper limit on tracks
+ PARAMETER (mc_MAX_Trks= 1000)
+*
+ INTEGER mc_N_Trks !present # of target tracks
+ INTEGER mc_Trk_ancestor(mc_MAX_Trks) !ancestor track ID (0=none)
+ CHARACTER*4 mc_Trk_system(mc_MAX_Trks) !name trk coord. (LAB,HMS,SOS..)
+ REAL mc_Trk_X(mc_MAX_Trks)
+ REAL mc_Trk_Y(mc_MAX_Trks) !position[cm]
+ REAL mc_Trk_Z(mc_MAX_Trks)
+ REAL mc_Trk_T(mc_MAX_Trks) !time[nS]
+ REAL mc_Trk_Px(mc_MAX_Trks)
+ REAL mc_Trk_Py(mc_MAX_Trks) !momentum[GeV/c]
+ REAL mc_Trk_Pz(mc_MAX_Trks)
+ REAL mc_Trk_M(mc_MAX_Trks) !mass[GeV/c2]
+ REAL mc_Trk_path(mc_MAX_Trks) !distance to end of track[cm]
+ INTEGER mc_Trk_geantID(mc_MAX_Trks) !GEANT particle type ID
+ CHARACTER*4 mc_Trk_comment(mc_MAX_Trks) !very brief comment (optional)
+ INTEGER mc_Trk_extra(mc_MAX_Trks) !resv'd for additional information
+*
+*-
+*- All hits are put in sequentially (relevant trackk ID# and detector ID#
+*- determine which arm (don't start over with 1 for 2nd arm).
+*-
+ INTEGER mc_MAX_Hits !upper limit on # of hits
+ PARAMETER (mc_MAX_Hits= 1000)
+*
+*- standare hall C detector,plane|row,wire|element|column ID numbers
+*- assigned according to those specified in "gen_detectorids.cmn"
+*
+ INTEGER mc_N_Hits !present # of hits
+ INTEGER mc_Hit_ancestor(mc_MAX_Hits) !relevant track ID#
+ CHARACTER*4 mc_Hit_system(mc_MAX_Hits) !name hit coord. (HMSf,SOSf,...)
+ REAL mc_Hit_X(mc_MAX_Hits)
+ REAL mc_Hit_Y(mc_MAX_Hits) !position[cm]
+ REAL mc_Hit_Z(mc_MAX_Hits)
+ REAL mc_Hit_T(mc_MAX_Hits) !time[nS]
+ REAL mc_Hit_Px(mc_MAX_Hits)
+ REAL mc_Hit_Py(mc_MAX_Hits) !momentum[GeV/c]
+ REAL mc_Hit_Pz(mc_MAX_Hits)
+ REAL mc_Hit_dE(mc_MAX_Hits) !energy loss[GeV]
+ INTEGER mc_Hit_detector(mc_MAX_Hits) !detector ID#
+ INTEGER mc_Hit_plane(mc_MAX_Hits) !plane-row ID#
+ INTEGER mc_Hit_element(mc_MAX_Hits) !wire-element-column ID#
+ INTEGER mc_Hit_extra(mc_MAX_Hits) !resv'd for additional information
+*-
+ COMMON /Mc_status/ mc_READY
+*-
+ COMMON /Mc_tracks/ mc_N_Trks,mc_Trk_ancestor,mc_Trk_system,
+ & mc_Trk_X,mc_Trk_Y,mc_Trk_Z,mc_Trk_T,mc_Trk_Px,mc_Trk_Py,
+ & mc_Trk_Pz,mc_Trk_M,mc_Trk_path,mc_Trk_geantID,mc_Trk_comment,
+ & mc_Trk_extra
+*
+ COMMON /Mc_hits/ mc_N_Hits,mc_Hit_ancestor,mc_Hit_system,
+ & mc_Hit_X,mc_Hit_Y,mc_Hit_Z,mc_Hit_T,mc_Hit_Px,mc_Hit_Py,
+ & mc_Hit_Pz,mc_Hit_dE,mc_Hit_detector,mc_Hit_plane,
+ & mc_Hit_element,mc_Hit_extra
+*
+*-reported coordinate systems used in simulation
+*
+ INTEGER mcCo_MAX_coords
+ PARAMETER (mcCo_MAX_coords= 20)
+* !note: "LAB" always exists!
+ INTEGER mcCo_N_coords !# of coordinates to follow
+ CHARACTER*4 mcCo_NAME(mcCo_MAX_coords) !name of coordinate system
+ CHARACTER*4 mcCo_reference(mcCo_MAX_coords) !system define w.r.t.
+*-first translate
+ REAL mcCo_Lo_to_Xo(mcCo_MAX_coords)
+ REAL mcCo_Lo_to_Yo(mcCo_MAX_coords) !from LAB to system
+ REAL mcCo_Lo_to_Zo(mcCo_MAX_coords)
+*-next Euler rotatation
+ REAL mcCo_Lo_THETA_rot(mcCo_MAX_coords) !about Z
+ REAL mcCo_Lo_PHI_rot(mcCo_MAX_coords) !about Y'
+ REAL mcCo_Lo_THETAprime_rot(mcCo_MAX_coords) !about Z'
+*
+ COMMON /mcCo_systems/ mcCo_N_coords,mcCo_NAME,mcCo_reference,
+ & mcCo_Lo_to_Xo,mcCo_Lo_to_Yo,mcCo_Lo_to_Zo,
+ & mcCo_Lo_THETA_rot,mcCo_Lo_PHI_rot,mcCo_Lo_THETAprime_rot
+*
+*******************end: mc_structures.cmn*************************
diff --git a/INCLUDE/s_ntuple.cmn b/INCLUDE/s_ntuple.cmn
new file mode 100644
index 0000000..54e96a0
--- /dev/null
+++ b/INCLUDE/s_ntuple.cmn
@@ -0,0 +1,52 @@
+**************************begin: s_Ntuple.cmn ***********************
+*-
+*- Created 8-Apr-1994 Kevin B. Beard, Hampton Univ.
+*........................................................................
+*- Misc. info. required for SOS Ntuple
+* $Log: s_ntuple.cmn,v $
+* Revision 1.4 2004/02/17 16:41:45 jones
+* Add parameters and variables needed for segmenting rzdat files
+*
+* Revision 1.3 1995/05/22 19:05:27 cdaq
+* (SAW) Correct some CTP class types
+*
+* Revision 1.2 1994/06/17 03:14:40 cdaq
+* (KBB) Fix typos, change variable names, reorder common
+*
+* Revision 1.1 1994/04/14 16:05:24 cdaq
+* Initial revision
+*
+*
+ integer SMAX_Ntuple_size
+ parameter (SMAX_Ntuple_size= 100)
+ integer default_s_Ntuple_ID
+ parameter (default_s_Ntuple_ID= 9020)
+*
+* CTPTYPE=parm
+*
+ logical s_Ntuple_exists
+ integer s_Ntuple_ID
+ integer s_Ntuple_size
+ integer s_Ntuple_IOchannel
+ character*80 s_Ntuple_name
+ character*80 s_Ntuple_title
+ character*132 s_Ntuple_directory
+ character*256 s_Ntuple_file
+ character*8 s_Ntuple_tag(SMAX_Ntuple_size)
+ integer s_Ntuple_max_segmentevents
+*
+* CTPTYPE=event
+*
+ integer s_Ntuple_segmentevents
+ integer s_Ntuple_filesegments
+ real s_Ntuple_contents(SMAX_Ntuple_size)
+*
+ COMMON /SOS_Ntuple/ s_Ntuple_exists,s_Ntuple_ID,
+ & s_Ntuple_size,s_Ntuple_IOchannel,
+ & s_Ntuple_name,s_Ntuple_title,
+ & s_Ntuple_directory,s_Ntuple_file,
+ & s_Ntuple_tag,s_Ntuple_contents,
+ > s_Ntuple_max_segmentevents,s_Ntuple_segmentevents,
+ > s_Ntuple_filesegments
+*
+****************************end: s_ntuple.cmn ***********************
diff --git a/INCLUDE/s_ntuple.dte b/INCLUDE/s_ntuple.dte
new file mode 100644
index 0000000..cc88096
--- /dev/null
+++ b/INCLUDE/s_ntuple.dte
@@ -0,0 +1,21 @@
+**************************begin: s_ntuple.dte ***********************
+*-
+*- Created 15-Jun-1994 Kevin B. Beard, Hampton Univ.
+*........................................................................
+*- leave clean field for HMS Ntuple
+* $Log: s_ntuple.dte,v $
+* Revision 1.1 1994/06/17 02:12:52 cdaq
+* Initial revision
+*
+ data s_Ntuple_exists/.FALSE./
+ data s_Ntuple_ID/0/
+ data s_Ntuple_file/' '/
+ data s_Ntuple_name/' '/
+ data s_Ntuple_title/' '/
+ data s_Ntuple_directory/' '/
+ data s_Ntuple_IOchannel/0/
+ data s_Ntuple_size/0/
+ data s_Ntuple_tag/SMAX_Ntuple_size*' '/
+ data s_Ntuple_contents/SMAX_Ntuple_size*0/
+*
+****************************end: s_ntuple.dte ***********************
diff --git a/INCLUDE/s_sieve_ntuple.cmn b/INCLUDE/s_sieve_ntuple.cmn
new file mode 100644
index 0000000..6344a0f
--- /dev/null
+++ b/INCLUDE/s_sieve_ntuple.cmn
@@ -0,0 +1,37 @@
+**************************begin: s_sieve_ntuple.cmn ***********************
+*-
+*........................................................................
+*- Misc. info. required for SOS sieve slit Ntuple
+* $Log: s_sieve_ntuple.cmn,v $
+* Revision 1.1 1995/08/11 16:24:58 cdaq
+* Initial revision
+*
+*
+ integer SMAX_sv_Ntuple_size
+ parameter (SMAX_sv_Ntuple_size= 100)
+ integer default_s_sieve_Ntuple_ID
+ parameter (default_s_sieve_Ntuple_ID= 1412)
+*
+* CTPTYPE=parm
+*
+ logical s_sieve_Ntuple_exists
+ integer s_sieve_Ntuple_ID
+ integer s_sieve_Ntuple_size
+ integer s_sieve_Ntuple_IOchannel
+ character*80 s_sieve_Ntuple_name
+ character*80 s_sieve_Ntuple_title
+ character*132 s_sieve_Ntuple_directory
+ character*256 s_sieve_Ntuple_file
+ character*8 s_sieve_Ntuple_tag(SMAX_sv_Ntuple_size)
+*
+* CTPTYPE=event
+*
+ real s_sieve_Ntuple_contents(SMAX_sv_Ntuple_size)
+*
+ COMMON /SOS_sieve_Ntuple/ s_sieve_Ntuple_exists,s_sieve_Ntuple_ID,
+ & s_sieve_Ntuple_size,s_sieve_Ntuple_IOchannel,
+ & s_sieve_Ntuple_name,s_sieve_Ntuple_title,
+ & s_sieve_Ntuple_directory,s_sieve_Ntuple_file,
+ & s_sieve_Ntuple_tag,s_sieve_Ntuple_contents
+
+*****************************end: s_sieve_ntuple.cmn ***********************
diff --git a/INCLUDE/s_sieve_ntuple.dte b/INCLUDE/s_sieve_ntuple.dte
new file mode 100644
index 0000000..64d9b34
--- /dev/null
+++ b/INCLUDE/s_sieve_ntuple.dte
@@ -0,0 +1,21 @@
+**************************begin: s_sieve_ntuple.dte ***********************
+*-
+*........................................................................
+*- leave clean field for SOS sieve slit Ntuple
+* $Log: s_sieve_ntuple.dte,v $
+* Revision 1.1 1995/08/11 16:24:52 cdaq
+* Initial revision
+*
+*
+ data s_sieve_Ntuple_exists/.FALSE./
+ data s_sieve_Ntuple_ID/0/
+ data s_sieve_Ntuple_file/' '/
+ data s_sieve_Ntuple_name/' '/
+ data s_sieve_Ntuple_title/' '/
+ data s_sieve_Ntuple_directory/' '/
+ data s_sieve_Ntuple_IOchannel/0/
+ data s_sieve_Ntuple_size/0/
+ data s_sieve_Ntuple_tag/SMAX_Sv_Ntuple_size*' '/
+ data s_sieve_Ntuple_contents/SMAX_sv_Ntuple_size*0/
+*
+****************************end: s_sieve_Ntuple.dte ***********************
diff --git a/INCLUDE/sane_data_structures.cmn b/INCLUDE/sane_data_structures.cmn
new file mode 100644
index 0000000..2feb693
--- /dev/null
+++ b/INCLUDE/sane_data_structures.cmn
@@ -0,0 +1,386 @@
+*****************begin: luc_data_structures.cmn*************************
+*
+* include file sane_data_structures.cmn
+*
+* Author: H. Baghdasaryan 18 Jan,2008
+*
+* $Log: sane_data_structures.cmn,v $
+* Revision 1.1.2.13 2010/06/28 13:37:46 jones
+* Add
+* real BIGCAL_CER_COL1_SHIFT(19,9)
+* real BIGCAL_CER_COL2_SHIFT(19,8)
+* real BIGCAL_CERB_COL1_SHIFT(19,9)
+* real BIGCAL_CERB_COL2_SHIFT(19,8)
+*
+* Revision 1.1.2.11 2009/09/16 19:04:05 jones
+* Add SANE_HMS_ANGLE_THETA,SANE_HMS_ANGLE_PHI from hms_data_structures.cmn
+* Add variables SANE_HMS_FIELD_THETA,SANE_HMS_FIELD_PHI
+* Add variables SANE_BETA_FIELD_THETA,SANE_BETA_FIELD_PHI
+* Delete variables SANE_HMS_OMEGA, SANE_HMS_PHI, SANE_FIELD_THETA,SANE_FIELD_PHI
+*
+* Revision 1.1.2.10 2009/09/15 20:34:21 jones
+* New variables used h_targ_trans.f and gep_physics.f
+*
+* Revision 1.1.2.9 2009/09/02 13:42:29 jones
+* increase BIG_TIME_SHIFT_CH(4) to BIG_TIME_SHIFT_CH(12)
+* add CER_SANE_TIME_WALK(8)
+* add CERENKOV_SANE_RAW_PLANE2 to ERENKOV_SANE_RAW_SCIN common block
+*
+* Revision 1.1.2.8 2009/03/31 19:32:59 cdaq
+* *** empty log message ***
+*
+* Revision 1.1.2.7 2009/02/11 21:42:33 cdaq
+* *** empty log message ***
+*
+* Revision 1.1.2.6 2009/01/30 20:33:28 cdaq
+* *** empty log message ***
+*
+* Revision 1.1.2.5 2008/10/31 08:26:02 cdaq
+* *** empty log message ***
+*
+* Revision 1.1.2.4 2008/10/25 12:39:42 cdaq
+* *** empty log message ***
+*
+* Revision 1.1.2.3 2008/10/11 15:05:05 cdaq
+* slow raster
+*
+* Revision 1.1.2.2 2008/10/02 18:01:49 cdaq
+* *** empty log message ***
+*
+* Revision 1.1.2.1 2008/09/26 21:42:48 cdaq
+* *** empty log message ***
+*
+
+c
+c
+c SANE RAW DATA Structure
+c
+c
+
+c
+c VERY IMPORTANT look at CTPTYPE DO not ignore.. Makes sence.
+c
+
+*
+*
+* CTPTYPE=event
+*
+
+ INTEGER*4 LUCITE_SANE_MAX_HITS ! MAXIMUM TOTAL NUMBER OF LUCITE HITS
+ PARAMETER (LUCITE_SANE_MAX_HITS=190) ! Should exceed # of paddles
+ INTEGER*4 LUCITE_SANE_MAX_COUNTER_NUM ! MAXIMUM TOTAL NUMBER OF LUCITE HITS
+ PARAMETER (LUCITE_SANE_MAX_COUNTER_NUM=28) ! Should exceed # of paddles
+ INTEGER*4 LUCITE_SANE_RAW_PLANE(LUCITE_SANE_MAX_HITS)
+ INTEGER*4 LUCITE_SANE_RAW_PLANE2(LUCITE_SANE_MAX_HITS)
+ INTEGER*4 LUCITE_SANE_RAW_PLANE3(LUCITE_SANE_MAX_HITS)
+ INTEGER*4 LUCITE_SANE_RAW_COUNTER_NUM(LUCITE_SANE_MAX_HITS)
+ INTEGER*4 LUCITE_SANE_RAW_COUNTER_NUM2(LUCITE_SANE_MAX_HITS)
+ INTEGER*4 LUCITE_SANE_RAW_COUNTER_NUM3(LUCITE_SANE_MAX_HITS)
+ INTEGER*4 LUCITE_SANE_RAW_ADC_POS(LUCITE_SANE_MAX_HITS)
+ INTEGER*4 LUCITE_SANE_RAW_ADC_NEG(LUCITE_SANE_MAX_HITS)
+ INTEGER*4 LUCITE_SANE_RAW_TDC_POS(LUCITE_SANE_MAX_HITS)
+ INTEGER*4 LUCITE_SANE_RAW_TDC_NEG(LUCITE_SANE_MAX_HITS)
+ INTEGER*4 LUCITE_SANE_RAW_TOT_HITS
+ INTEGER*4 LUCITE_SANE_RAW_TOT_HITS2
+ INTEGER*4 LUCITE_SANE_RAW_TOT_HITS3
+
+ COMMON/LUCITE_SANE_RAW_SCIN/
+ & LUCITE_SANE_RAW_COUNTER_NUM,
+ & LUCITE_SANE_RAW_COUNTER_NUM2,
+ & LUCITE_SANE_RAW_COUNTER_NUM3,
+ & LUCITE_SANE_RAW_ADC_POS,
+ & LUCITE_SANE_RAW_ADC_NEG,
+ & LUCITE_SANE_RAW_TDC_POS,
+ & LUCITE_SANE_RAW_TDC_NEG,
+ & LUCITE_SANE_RAW_TOT_HITS,
+ & LUCITE_SANE_RAW_TOT_HITS2,
+ & LUCITE_SANE_RAW_TOT_HITS3,
+ & LUCITE_SANE_RAW_PLANE,
+ & LUCITE_SANE_RAW_PLANE2,
+ & LUCITE_SANE_RAW_PLANE3
+
+ccc END of the RAW DATA
+
+
+cccccccccccccccccccccccccccccccccc
+c
+c LUCITE Pedestal Structure
+c
+cccccccccccccccccccccccccccccccccc
+ INTEGER*4 luc_min_peds
+ INTEGER*4 luc_ped_num_neg(LUCITE_SANE_MAX_COUNTER_NUM)
+ INTEGER*4 luc_ped_sum2_neg(LUCITE_SANE_MAX_COUNTER_NUM)
+ INTEGER*4 luc_ped_sum_neg(LUCITE_SANE_MAX_COUNTER_NUM)
+ INTEGER*4 luc_ped_limit_neg(LUCITE_SANE_MAX_COUNTER_NUM)
+ INTEGER*4 luc_ped_num_pos(LUCITE_SANE_MAX_COUNTER_NUM)
+ INTEGER*4 luc_ped_sum2_pos(LUCITE_SANE_MAX_COUNTER_NUM)
+ INTEGER*4 luc_ped_sum_pos(LUCITE_SANE_MAX_COUNTER_NUM)
+ INTEGER*4 luc_ped_limit_pos(LUCITE_SANE_MAX_COUNTER_NUM)
+ real*4 luc_ped_threshold_neg(LUCITE_SANE_MAX_COUNTER_NUM)
+ real*4 luc_ped_threshold_pos(LUCITE_SANE_MAX_COUNTER_NUM)
+ real*4 luc_ped_mean_neg(LUCITE_SANE_MAX_COUNTER_NUM)
+ real*4 luc_ped_mean_pos(LUCITE_SANE_MAX_COUNTER_NUM)
+ real*4 luc_ped_rms_neg(LUCITE_SANE_MAX_COUNTER_NUM)
+ real*4 luc_ped_rms_pos(LUCITE_SANE_MAX_COUNTER_NUM)
+
+
+ COMMON /LUCITE_SANE_PED_SCIN/
+ $ luc_min_peds,
+ $ luc_ped_num_neg,
+ $ luc_ped_sum2_neg,
+ $ luc_ped_sum_neg,
+ $ luc_ped_limit_neg,
+ $ luc_ped_num_pos,
+ $ luc_ped_sum2_pos,
+ $ luc_ped_sum_pos,
+ $ luc_ped_limit_pos,
+ & luc_ped_threshold_neg,
+ & luc_ped_threshold_pos,
+ & luc_ped_mean_neg,
+ & luc_ped_mean_pos,
+ & luc_ped_rms_neg,
+ & luc_ped_rms_pos
+
+ccc END OF THE PEDESTAL
+cccc
+c
+c Cerenkov SANE
+c
+cc
+
+ INTEGER*4 CERENKOV_SANE_MAX_HITS ! MAXIMUM TOTAL NUMBER OF Cerenkov HITS
+ PARAMETER (CERENKOV_SANE_MAX_HITS=35) ! Should exceed # of paddles
+ INTEGER*4 CERENKOV_SANE_MAX_CER_COUNTER ! MAXIMUM TOTAL NUMBER OF Cerenkov HITS
+ PARAMETER (CERENKOV_SANE_MAX_CER_COUNTER=12)
+ INTEGER*4 CERENKOV_SANE_RAW_PLANE(CERENKOV_SANE_MAX_HITS)
+ INTEGER*4 CERENKOV_SANE_RAW_PLANE2(CERENKOV_SANE_MAX_HITS)
+ INTEGER*4 CERENKOV_SANE_RAW_COUNTER_NUM(CERENKOV_SANE_MAX_HITS)
+ INTEGER*4 CERENKOV_SANE_RAW_COUNTER_NUM2(CERENKOV_SANE_MAX_HITS)
+ INTEGER*4 CERENKOV_SANE_RAW_ADC(CERENKOV_SANE_MAX_HITS)
+ INTEGER*4 CERENKOV_SANE_RAW_TDC(CERENKOV_SANE_MAX_HITS)
+ INTEGER*4 CERENKOV_SANE_RAW_TOT_HITS
+ INTEGER*4 CERENKOV_SANE_RAW_TOT_HITS2
+
+ COMMON/CERENKOV_SANE_RAW_SCIN/
+ & CERENKOV_SANE_RAW_COUNTER_NUM,
+ & CERENKOV_SANE_RAW_COUNTER_NUM2,
+ & CERENKOV_SANE_RAW_ADC,
+ & CERENKOV_SANE_RAW_TDC,
+ & CERENKOV_SANE_RAW_TOT_HITS,
+ & CERENKOV_SANE_RAW_TOT_HITS2,
+ & CERENKOV_SANE_RAW_PLANE,
+ & CERENKOV_SANE_RAW_PLANE2
+
+ccc END of the RAW DATA
+
+
+cccccccccccccccccccccccccccccccccc
+c
+c CER_SANE Pedestal Structure
+c
+cccccccccccccccccccccccccccccccccc
+
+ INTEGER*4 cer_sane_min_peds
+ INTEGER*4 cer_sane_ped_num(CERENKOV_SANE_MAX_CER_COUNTER)
+ INTEGER*4 cer_sane_ped_sum2(CERENKOV_SANE_MAX_CER_COUNTER)
+ INTEGER*4 cer_sane_ped_sum(CERENKOV_SANE_MAX_CER_COUNTER)
+ INTEGER*4 cer_sane_ped_limit(CERENKOV_SANE_MAX_CER_COUNTER)
+ real*4 cer_sane_ped_threshold(CERENKOV_SANE_MAX_CER_COUNTER)
+ real*4 cer_sane_ped_mean(CERENKOV_SANE_MAX_CER_COUNTER)
+ real*4 cer_sane_ped_rms(CERENKOV_SANE_MAX_CER_COUNTER)
+
+
+ COMMON /CERENKOV_SANE_PED_SCIN/
+ $ cer_sane_min_peds,
+ $ cer_sane_ped_num,
+ $ cer_sane_ped_sum2,
+ $ cer_sane_ped_sum,
+ $ cer_sane_ped_limit,
+ & cer_sane_ped_threshold,
+ & cer_sane_ped_mean,
+ & cer_sane_ped_rms
+
+ccc END OF THE PEDESTAL
+cccc
+c
+c Traker SANE
+c
+cc
+
+ INTEGER*4 TRACKER_SANE_MAX_HITS ! MAXIMUM TOTAL NUMBER OF Tracker HITS
+ PARAMETER (TRACKER_SANE_MAX_HITS=448) ! Should exceed # of paddles
+c PARAMETER (TRACKER_SANE_RAW_COUNTER=448) ! Should exceed # of paddles
+ INTEGER*4 TRACKER_SANE_RAW_PLANE_Y(TRACKER_SANE_MAX_HITS)
+ INTEGER*4 TRACKER_SANE_RAW_PLANE_X(TRACKER_SANE_MAX_HITS)
+ INTEGER*4 TRACKER_SANE_RAW_COUNTER_Y(TRACKER_SANE_MAX_HITS)
+ INTEGER*4 TRACKER_SANE_RAW_COUNTER_X(TRACKER_SANE_MAX_HITS)
+ INTEGER*4 TRACKER_SANE_RAW_TDC_Y(TRACKER_SANE_MAX_HITS)
+ INTEGER*4 TRACKER_SANE_RAW_TDC_X(TRACKER_SANE_MAX_HITS)
+ INTEGER*4 TRACKER_SANE_RAW_TOT_HITS_Y
+ INTEGER*4 TRACKER_SANE_RAW_TOT_HITS_X
+
+ COMMON/TRACKER_SANE_RAW/
+ & TRACKER_SANE_RAW_PLANE_Y,
+ & TRACKER_SANE_RAW_PLANE_X,
+ & TRACKER_SANE_RAW_COUNTER_Y,
+ & TRACKER_SANE_RAW_COUNTER_X,
+ & TRACKER_SANE_RAW_TDC_Y,
+ & TRACKER_SANE_RAW_TDC_X,
+ & TRACKER_SANE_RAW_TOT_HITS_Y,
+ & TRACKER_SANE_RAW_TOT_HITS_X
+
+*
+* CTPTYPE=parm
+*
+* parameters from CALIBRATION
+
+ INTEGER*4 TRACKER_SANE_XCALIBRATION(64)
+ INTEGER*4 TRACKER_SANE_Y1CALIBRATION(128)
+ INTEGER*4 TRACKER_SANE_Y2CALIBRATION(128)
+ INTEGER*4 TRACKER_SANE_XSIGMA(64)
+ INTEGER*4 TRACKER_SANE_Y1SIGMA(128)
+ INTEGER*4 TRACKER_SANE_Y2SIGMA(128)
+ COMMON/TRACKER_CALIB/
+ & TRACKER_SANE_XCALIBRATION,
+ & TRACKER_SANE_Y1CALIBRATION,
+ & TRACKER_SANE_Y2CALIBRATION,
+ & TRACKER_SANE_XSIGMA,
+ & TRACKER_SANE_Y1SIGMA,
+ & TRACKER_SANE_Y2SIGMA
+
+ real LUCITE_SANE_TDC_TIMING(28)
+ real LUCITE_SANE_MEAN_POS(28)
+ real LUCITE_SANE_MEAN_NEG(28)
+ real LUCITE_SANE_SIGMA_POS(28)
+ real LUCITE_SANE_SIGMA_NEG(28)
+ real LUCITE_SANE_COEF(28)
+ real LUCITE_SANE_SHIFT(28)
+ COMMON/LUCITE_CALIB/
+ & LUCITE_SANE_TDC_TIMING,
+ & LUCITE_SANE_MEAN_POS,
+ & LUCITE_SANE_MEAN_NEG,
+ & LUCITE_SANE_SIGMA_POS,
+ & LUCITE_SANE_SIGMA_NEG,
+ & LUCITE_SANE_COEF,LUCITE_SANE_SHIFT
+
+ real CER_SANE_MEAN(8)
+ real CER_SANE_SIGMA(8)
+ real CER_SANE_TDC_TIMING(8)
+ real CER_SANE_ADC_CUT(8)
+ real CER_SANE_GEOM_CUT_LOW(8)
+ real CER_SANE_GEOM_CUT_HI(8)
+ integer CER_SANE_GEOM_CUT_X(8)
+ real CER_SANE_TIME_WALK(8)
+c
+c For Runs with BIGCAL trigger Added
+c BIGCAL_CER_TIME_WALK_SHIFT(8)
+c BIGCAL_CER_TIME_WALK_SLOPE(8)
+c COR = BIGCAL_CER_TIME_WALK_SHIFT+BIGCAL_CER_TIME_WALK_SLOPE/aclust
+c
+c
+ real BIGCAL_CER_TIME_WALK_SHIFT(8)
+ real BIGCAL_CER_TIME_WALK_SLOPE(8)
+ real BIGCAL_CER_COL1_SHIFT(19,9)
+ real BIGCAL_CER_COL2_SHIFT(19,8)
+ real BIGCAL_CERB_COL1_SHIFT(19,9)
+ real BIGCAL_CERB_COL2_SHIFT(19,8)
+
+ COMMON/CER_CALIB/
+ & CER_SANE_MEAN,
+ & CER_SANE_SIGMA,
+ & CER_SANE_TDC_TIMING,
+ & CER_SANE_ADC_CUT,
+ & CER_SANE_GEOM_CUT_LOW,
+ & CER_SANE_GEOM_CUT_HI,
+ & CER_SANE_GEOM_CUT_X,
+ & CER_SANE_TIME_WALK,
+ & BIGCAL_CER_TIME_WALK_SHIFT,
+ & BIGCAL_CER_TIME_WALK_SLOPE,
+ $ BIGCAL_CER_COL1_SHIFT,
+ & BIGCAL_CER_COL2_SHIFT,
+ $ BIGCAL_CERB_COL1_SHIFT,
+ & BIGCAL_CERB_COL2_SHIFT
+
+c
+c
+c Cerenkov time shift due to different triggers
+c T_TRGBIG_SHIFT(1) correspond to 25
+c T_TRGBETA_SHIFT(1) correspond to 45
+c T_TRGPI0_SHIFT(1) correspond to 45
+c
+cccccccccccccccccccccccccccccccccccccccc
+
+
+ real T_TRGBIG_SHIFT(30)
+ real T_TRGBETA_SHIFT(30)
+ real T_TRGPI0_SHIFT(30)
+
+ COMMON/TRIG_SHIFT/T_TRGBIG_SHIFT,T_TRGBETA_SHIFT,T_TRGPI0_SHIFT
+
+
+
+c
+c
+c Time calibration constants for Bigcal 4 quarters
+c
+c
+c BIG_TIME_SHIFT_CH(12) 1,2,3,4 -reserved for Cerenkov 5,6,7,8 For Lucite ,9,10,11,12 for tracker
+cc
+
+
+
+
+
+ real BIG_TIME_SHIFT_CH(12)
+ COMMON/BIG_CALIB/BIG_TIME_SHIFT_CH
+
+ real TrackerX_SHIFT(4) ! position in X,Y,Z Z-betta detector dirrection, 4- angleof betta detector
+ real TrackerY1_SHIFT(4) ! position in Z-betta detector dirrection
+ real TrackerY2_SHIFT(4) ! position in Z-betta detector dirrection
+ real Lucite_SHIFT(4) ! position in Z-betta detector dirrection
+ real Bigcal_SHIFT(4) ! position in Z-betta detector dirrection
+ COMMON/Z_SHIFTS/
+ & TrackerX_SHIFT,
+ & TrackerY1_SHIFT,
+ & TrackerY2_SHIFT,
+ & Lucite_SHIFT,
+ & Bigcal_SHIFT
+ real BigCal_Calib_Gain(32,56)
+ COMMON/BigCal_Calib_H/BigCal_Calib_Gain
+c
+c
+c SANE TRIGGER COUNTER is for F1 TDC
+c We need it to subtract TDC value of each detector.
+c PLEASE MAKE SURE YOU INCLUDED it in one of the param files.
+c
+ integer*4 SANE_TRIGGER_COUNTER, SANE_TRIGGER_WINDOW
+ COMMON/SANE_TRIG_COUNTER/SANE_TRIGGER_COUNTER, SANE_TRIGGER_WINDOW
+
+c
+c Parameters for Tracking Tranformatio
+c
+c
+ real SANE_TRANSFORM_MATRIX_THETA(15),SANE_TRANSFORM_MATRIX_PHI(15)
+ COMMON/SANE_TRANSFORM/SANE_TRANSFORM_MATRIX_THETA,SANE_TRANSFORM_MATRIX_PHI
+
+ccc END of the RAW DATA
+
+c
+c SANE TARGET FIELD AND ANGLES
+c
+
+ real*8 SANE_BETA_ANGLE_THETA, SANE_BETA_ANGLE_PHI
+ real*8 SANE_HMS_ANGLE_THETA, SANE_HMS_ANGLE_PHI
+ real*8 SANE_FIELD_ANGLE_THETA, SANE_FIELD_ANGLE_PHI
+ real*8 SANE_TGTFIELD_B
+ real*8 SANE_BETA_OMEGA, SANE_BETA_PHI
+ real*8 SANE_HMS_FIELD_THETA,SANE_HMS_FIELD_PHI
+ real*8 SANE_BETA_FIELD_THETA,SANE_BETA_FIELD_PHI
+ COMMON /SANEFIELDANGLES/ SANE_BETA_ANGLE_THETA, SANE_BETA_ANGLE_PHI,
+ , SANE_FIELD_ANGLE_THETA, SANE_FIELD_ANGLE_PHI,
+ , SANE_HMS_ANGLE_THETA, SANE_HMS_ANGLE_PHI,
+ , SANE_TGTFIELD_B,
+ , SANE_BETA_OMEGA, SANE_BETA_PHI,
+ , SANE_HMS_FIELD_THETA,SANE_HMS_FIELD_PHI,
+ , SANE_BETA_FIELD_THETA,SANE_BETA_FIELD_PHI
+
diff --git a/INCLUDE/sane_filenames.cmn b/INCLUDE/sane_filenames.cmn
new file mode 100644
index 0000000..9ef92a1
--- /dev/null
+++ b/INCLUDE/sane_filenames.cmn
@@ -0,0 +1,24 @@
+*
+* CTPTYPE=parm
+*
+ character*80 sane_report_template_filename ! CTP file with bigcal report
+ character*80 sane_report_blockname
+ character*80 sane_report_output_filename
+ character*80 sane_pedestal_output_filename
+ character*80 sane_tree_filename
+ character*80 sane_calib_matrix_filename
+ character*80 sane_calib_parm_filename
+ character*80 sane_debug_output_filename
+ character*80 sane_bad_chan_list_filename
+
+ common/sane_filenames/
+ $ sane_report_template_filename,
+ $ sane_report_blockname,
+ $ sane_report_output_filename,
+ $ sane_pedestal_output_filename,
+ $ sane_tree_filename,
+ $ sane_calib_matrix_filename,
+ $ sane_calib_parm_filename,
+ $ sane_debug_output_filename,
+ $ sane_bad_chan_list_filename
+
diff --git a/INCLUDE/sane_ntuple.cmn b/INCLUDE/sane_ntuple.cmn
new file mode 100644
index 0000000..295acce
--- /dev/null
+++ b/INCLUDE/sane_ntuple.cmn
@@ -0,0 +1,277 @@
+*
+* CTPTYPE=parm
+*
+c
+c EPIC Memory parameters
+c
+c
+
+c integer sane_bigcal_time_include
+c integer sane_bigcal_clust8_include
+c integer sane_bigcal_clust64_include
+c integer sane_bigcal_ntrack_include
+c integer sane_bigcal_badclust_include
+c integer sane_bigcal_hms_include
+
+ integer SANEMAX_Ntuple_size
+ parameter (SANEMAX_Ntuple_size=200)
+ integer default_SANE_Ntuple_ID
+ parameter (default_sane_Ntuple_ID=9502)
+* array dimensions for cluster ntuple:
+
+ logical sane_Ntuple_exists
+ integer sane_Ntuple_ID
+ integer sane_Ntuple_size
+ integer sane_Ntuple_IOchannel
+ integer sane_ntuple_type
+ character*80 sane_Ntuple_name
+ character*80 sane_Ntuple_title
+ character*132 sane_Ntuple_directory
+ character*256 sane_Ntuple_file
+c character*256 b_tree_filename
+ character*8 sane_Ntuple_tag(SANEMAX_Ntuple_size)
+ integer sane_ntuple_max_segmentevents
+
+ character*80 polarization_data_table,charge_data_table
+ logical polarization_data_open,charge_data_open
+ INTEGER polarization_data_unit,charge_data_unit
+ logical charge_ch,polarization_ch
+ common/CHECK/ charge_ch,polarization_ch
+
+*
+* CTPTYPE=event
+*
+ integer sane_Ntuple_segmentevents,isane_plots
+ integer sane_Ntuple_filesegments
+ integer sane_ntuple_auxsegments
+ real sane_Ntuple_contents(SANEMAX_Ntuple_size)
+ common/sane_ntuple/
+ $ sane_Ntuple_exists,sane_Ntuple_ID,
+ $ sane_ntuple_size,sane_Ntuple_IOchannel,
+ $ sane_Ntuple_name,sane_Ntuple_title,sane_Ntuple_directory,
+ $ sane_Ntuple_file,sane_Ntuple_tag,
+ $ sane_Ntuple_max_segmentevents,
+ $ sane_Ntuple_segmentevents,sane_Ntuple_filesegments,
+ $ sane_Ntuple_contents,sane_ntuple_type,
+ $ sane_ntuple_auxsegments,isane_plots,
+ $ polarization_data_table,charge_data_table,
+ $ polarization_data_open,charge_data_open,
+ $ polarization_data_unit,charge_data_unit
+
+ real*8 tcharge,tcharge_help,tcharge_helm
+ real*8 charge2s,charge2s_help,charge2s_helm
+ real*8 polarea,polarization
+ integer*4 hel_p_scaler
+ integer*4 hel_n_scaler
+ integer*4 hel_p_trig
+ integer*4 hel_n_trig
+ real*8 dtime_p,dtime_n
+ real*4 half_plate
+
+ common/SANEEV/
+ $ tcharge,
+ $ charge2s,
+ $ tcharge_help,charge2s_help,tcharge_helm,charge2s_helm,
+ $ polarea,polarization,
+ $ hel_p_scaler,
+ $ hel_n_scaler,
+ $ hel_p_trig,
+ $ hel_n_trig,
+ $ dtime_p,dtime_n,half_plate
+ integer*4 pol_id_change,charge_id_change
+ common/SANEEVI/pol_id_change,charge_id_change
+
+
+
+ integer TRACKER_MAX_HITS
+ parameter (TRACKER_MAX_HITS=900)
+
+ integer*4 y1t_hit
+ integer*4 y1t_row(TRACKER_MAX_HITS)
+ integer*4 y1t_tdc(TRACKER_MAX_HITS)
+ real*4 y1t_y(TRACKER_MAX_HITS)
+
+ common/SANEY1/y1t_hit, y1t_row, y1t_tdc, y1t_y
+
+ integer*4 y2t_hit
+ integer*4 y2t_row(TRACKER_MAX_HITS)
+ integer*4 y2t_tdc(TRACKER_MAX_HITS)
+ real*4 y2t_y(TRACKER_MAX_HITS)
+ common/SANEY2/y2t_hit, y2t_row, y2t_tdc, y2t_y
+
+ integer*4 y3t_hit
+ integer*4 y3t_row(TRACKER_MAX_HITS)
+ integer*4 y3t_tdc(TRACKER_MAX_HITS)
+ real*4 y3t_y(TRACKER_MAX_HITS)
+ common/SANEY3/y3t_hit, y3t_row, y3t_tdc, y3t_y
+
+ integer*4 x1t_hit
+ integer*4 x1t_row(TRACKER_MAX_HITS)
+ integer*4 x1t_tdc(TRACKER_MAX_HITS)
+ real*4 x1t_x(TRACKER_MAX_HITS)
+ common/SANEX1/x1t_hit, x1t_row, x1t_tdc, x1t_x
+
+ integer*4 cer_hit,ceradc_hit
+ integer*4 cer_num(50)
+ integer*4 cer_tdc(50),cer_adcc(50)
+ integer*4 ceradc_num(15),cer_adc(50)
+ common/SANECER/cer_hit, cer_num, cer_tdc,cer_adcc
+ common/SANEADC/ceradc_hit, ceradc_num,cer_adc
+
+
+ integer*4 luc_hit
+ integer*4 luc_row(90)
+ integer*4 ladc_pos(90),ladc_neg(90)
+ integer*4 ltdc_pos(90),ltdc_neg(90)
+ real*4 luc_y(90)
+ common/SANELUC/luc_hit, luc_row, ladc_pos, ladc_neg,
+ , ltdc_pos, ltdc_neg, luc_y
+
+
+ real*4 hms_p
+ real*4 hms_e
+ real*4 hms_theta
+ real*4 hms_phi
+ real*4 hsxfp_s,hsyfp_s,hsxpfp_s,hsypfp_s
+ real*4 hms_xtar,hms_ytar,hms_yptar,hms_xptar
+ real*4 hms_delta
+ real*4 hms_start
+ real*4 hsshtrk_s, hsshsum_s, hsbeta_s
+ real*4 rast_x
+ real*4 rast_y
+ real*4 slow_rast_x
+ real*4 slow_rast_y
+ real*4 sem_x,sem_y
+ integer*4 i_helicity
+ real*4 hms_cer_npe1,hms_cer_npe2, hms_cer_adc1,hms_cer_adc2
+
+
+ COMMON/HMSINFO/hms_p,hms_e,hms_theta,hms_phi,
+ , hsxfp_s,hsyfp_s,hsxpfp_s,hsypfp_s,
+ , hms_xtar,hms_ytar,hms_yptar,hms_xptar,
+ , hms_delta, hms_start,
+ , hsshtrk_s, hsshsum_s, hsbeta_s,
+ , hms_cer_npe1,hms_cer_npe2, hms_cer_adc1,hms_cer_adc2
+
+ COMMON/RASTINFO/
+ , rast_x, rast_y,
+ , slow_rast_x, slow_rast_y,
+ , sem_x,sem_y,i_helicity
+
+
+
+ integer*4 maxcl
+ parameter (maxcl=15)
+ integer*4 n_clust
+ integer*4 luc_h(maxcl)
+ integer*4 trc_hx(maxcl)
+ integer*4 trc_hy1(maxcl)
+ integer*4 trc_hy2(maxcl)
+
+
+ real*4 E_clust(maxcl)
+ real*4 X_clust(maxcl)
+ real*4 Y_clust(maxcl)
+ real*4 Z_clust(maxcl)
+ real*4 X_clust_r(maxcl)
+ real*4 Y_clust_r(maxcl)
+ real*4 Z_clust_r(maxcl)
+
+ real*4 X_luc(20,maxcl)
+ real*4 Y_luc(20,maxcl)
+ real*4 Z_luc(20,maxcl)
+ real*4 X_luc_r(20,maxcl)
+ real*4 Y_luc_r(20,maxcl)
+ real*4 Z_luc_r(20,maxcl)
+
+ real*4 X_trc(20,maxcl)
+ real*4 Y1_trc(20,maxcl)
+ real*4 Y2_trc(20,maxcl)
+ real*4 Z_trc(20,maxcl)
+ real*4 Z1_trc(20,maxcl)
+ real*4 Z2_trc(20,maxcl)
+ real*4 Tr_Vertex(3,maxcl)
+ real*4 Tr_Vertex_r(3,maxcl)
+ real*4 Theta_e(maxcl),Phi_e(maxcl)
+ real*4 Delta_Y(maxcl),Delta_X(maxcl)
+ real*4 X_Bjorken(maxcl), Q2(maxcl), W2(maxcl), ENue(maxcl)
+ integer*4 cer_h(maxcl),cer_geom(maxcl)
+ integer*4 cerb_time(maxcl),
+ , cerb_adc(maxcl),bigc_time(maxcl),bigc_adc(maxcl),cerbc_num(maxcl)
+ COMMON/SANEPHYS/n_clust,
+ $ E_clust,
+ $ X_clust, Y_clust,
+ $ Z_clust,
+ $ X_clust_r, Y_clust_r,
+ $ Z_clust_r,
+ $ luc_h,
+ $ X_luc, Y_luc, Z_luc,
+ $ X_luc_r,Y_luc_r,
+ $ Z_luc_r,
+ $ trc_hx,
+ $ X_trc,
+ $ Z_trc,
+ $ trc_hy1,
+ $ Y1_trc,
+ $ Z1_trc,
+ $ trc_hy2,
+ $ Y2_trc,
+ $ Z2_trc,
+ $ Tr_Vertex, Tr_Vertex_r,
+ $ cer_h,cer_geom,
+ $ cerb_time,
+ $ cerb_adc,bigc_time,bigc_adc,cerbc_num,
+ $ Theta_e,Phi_e,
+ $ Delta_Y,Delta_X,
+ $ X_Bjorken, Q2,
+ $ W2, ENue
+
+
+c COMMON/SANEPHYS/n_clust,
+c , E_clust,
+c , X_clust, Y_clust, Z_clust,
+c , X_clust_r, Y_clust_r, Z_clust_r,
+c , luc_h,
+c , X_luc, Y_luc, Z_luc,
+c , X_luc_r, Y_luc_r, Z_luc_r,
+c , trc_hx, X_trc,
+c , trc_hy1, Y1_trc,
+c , trc_hy2, Y2_trc,
+c , Tr_Vertex, Tr_Vertex_r, cer_h,
+c , Theta_e, Phi_e, Delta_Y, Delta_X,
+c , X_Bjorken, Q2, W2, ENue
+
+ real*4 X_luc_av(maxcl),Y_luc_av(maxcl),Z_luc_av(maxcl)
+ real*4 X_tr_av(maxcl),Y_tr_av(maxcl),Z_tr_av(maxcl)
+
+ COMMON/AverPhysEventPositions/X_luc_av,
+ , Y_luc_av,Z_luc_av,
+ , X_tr_av,Y_tr_av,Z_tr_av
+
+c
+c
+c Parameters to define tracker and bigcal Planes
+c
+c
+
+ real*4 P1_track_r(3),P2_track_r(3),P3_track_r(3)
+ real*4 P1_track(3),P2_track(3),P3_track(3)
+ real*4 P1_bigcal(3),P2_bigcal(3),P3_bigcal(3)
+ real*4 P1_bigcal_r(3),P2_bigcal_r(3),P3_bigcal_r(3)
+ real*8 a_tracker, b_tracker, c_tracker, d_tracker
+ real*8 a_bigcal, b_bigcal, c_bigcal, d_bigcal
+
+ COMMON /BETA_PLANE/P1_track, P2_track, P3_track,
+ , P1_track_r, P2_track_r, P3_track_r,
+ , P1_bigcal, P2_bigcal, P3_bigcal,
+ , P1_bigcal_r, P2_bigcal_r, P3_bigcal_r,
+ , a_tracker, b_tracker, c_tracker, d_tracker,
+ , a_bigcal, b_bigcal, c_bigcal, d_bigcal
+
+ real SANE_IF_ELECTRON_ANGLE_THETA
+ real SANE_IF_ELECTRON_ANGLE_PHI
+ real SANE_DISTANCE_FROM_ELECTRON_TRACK
+ COMMON /ANGLE_TRACK/SANE_IF_ELECTRON_ANGLE_THETA,
+ , SANE_IF_ELECTRON_ANGLE_PHI,
+ , SANE_DISTANCE_FROM_ELECTRON_TRACK
+
diff --git a/INCLUDE/sane_ntuple.dte b/INCLUDE/sane_ntuple.dte
new file mode 100644
index 0000000..cfb554f
--- /dev/null
+++ b/INCLUDE/sane_ntuple.dte
@@ -0,0 +1,10 @@
+ data sane_ntuple_exists/.false./
+ data sane_ntuple_id/0/
+ data sane_ntuple_size/0/
+ data sane_ntuple_iochannel/0/
+ data sane_ntuple_name/' '/
+ data sane_ntuple_title/' '/
+ data sane_ntuple_directory/' '/
+ data sane_ntuple_file/' '/
+ data sane_ntuple_tag/sanemax_ntuple_size*' '/
+ data sane_ntuple_contents/sanemax_ntuple_size*0/
diff --git a/INCLUDE/sem_data_structures.cmn b/INCLUDE/sem_data_structures.cmn
new file mode 100644
index 0000000..ab5c52d
--- /dev/null
+++ b/INCLUDE/sem_data_structures.cmn
@@ -0,0 +1,112 @@
+*
+*
+* CTPTYPE = parm NEUTRON DETECTOR PARAMETERS
+*
+ integer NUM_TBPM
+ parameter (NUM_TBPM=8)
+*
+* TBPM
+*
+*
+* CTPTYPE=event
+*
+*
+
+ integer*4 N_TBPM_ALL_CHAN
+ parameter (N_TBPM_ALL_CHAN=64)
+ integer*4 N_TBPM_TOT_HITS
+ integer*4 N_TBPM_ADDR1(N_TBPM_ALL_CHAN)
+ integer*4 N_TBPM_ADDR2(N_TBPM_ALL_CHAN)
+ integer*4 N_TBPM_RAW_DATA(N_TBPM_ALL_CHAN)
+ real*4 N_TBPM_DATA(N_TBPM_ALL_CHAN)
+ real*4 ntbpmx,ntbpmy
+*
+* CTPTYPE=event
+*
+*
+ COMMON /N_TBPM/
+ & N_TBPM_TOT_HITS,
+ & N_TBPM_ADDR1,
+ & N_TBPM_ADDR2,
+ & N_TBPM_RAW_DATA,
+ & N_TBPM_DATA,
+ & ntbpmx,ntbpmy
+*
+*
+*
+* CTPTYPE=parm
+*
+*
+ integer*4 n_tbpm_methode
+ real*4 n_tbpm_cutoff
+ real*4 n_tbpm_adccut
+
+ COMMON /N_TBPM_PAR/
+ $ n_tbpm_methode,
+ $ n_tbpm_cutoff,
+ $ n_tbpm_adccut
+
+ real*4 n_force_SEMx
+ real*4 n_force_SEMy
+
+ common/ndet_special_options/
+ $ n_force_SEMx,
+ $ n_force_SEMy
+
+*
+*
+* ! B E A M P O S I T I O N -- S E M
+*
+* CTPTYPE=parm
+*
+ integer*4 gsemx_index !SEM x position
+ integer*4 gsemy_index !SEM y position
+ integer*4 gsemdx_index !SEM size -- x diameter
+ integer*4 gsemdy_index !SEM size -- y diameter
+*
+ real*4 gsem_xcal_lo !SEM calibration frequency at x= -15mm
+ real*4 gsem_xcal_hi !SEM calibration frequency at x= +15mm
+ real*4 gsem_ycal_lo !SEM calibration frequency at y= -15mm
+ real*4 gsem_ycal_hi !SEM calibration frequency at y= +15mm
+ real*4 gsem_dxcal_lo !SEM calibration frequency at x dia = 0
+ real*4 gsem_dxcal_hi !SEM calibration frequency at x dia = 30mm
+ real*4 gsem_dycal_lo !SEM calibration frequency at y dia = 0
+ real*4 gsem_dycal_hi !SEM calibration frequency at y dia = 30mm
+*
+* CTPTYPE=event
+*
+ real*4 gsem_meanxpos
+ real*4 gsem_meanypos
+ real*4 gsem_meanxsize
+ real*4 gsem_meanysize
+*
+ common/BEAMPOSITION/
+ & gsemx_index, gsemy_index, gsemdx_index, gsemdy_index,
+ & gsem_xcal_lo, gsem_xcal_hi, gsem_dxcal_lo, gsem_dxcal_hi,
+ & gsem_ycal_lo, gsem_ycal_hi, gsem_dycal_lo, gsem_dycal_hi,
+ & gsem_meanxpos, gsem_meanxsize,
+ & gsem_meanypos, gsem_meanysize
+*
+*
+* CTPTYPE=event
+*
+* Neutron Detector PEDESTALS
+* replace ndet_all_ped_pos with float(ndet_pos_ped_sum/ndet_pos_ped_num)
+* if ndet_pos_ped_num > ndet_min_peds.
+*
+ real*4 ndet_ped_tbpm(N_tbpm_all_chan)
+ real*4 ndet_ped_tbpm_sig(N_tbpm_all_chan)
+ real*4 ndet_thresh_tbpm(N_tbpm_all_chan)
+ real*4 ndet_thresh_tbpm_sig(N_tbpm_all_chan)
+ integer*4 ndet_ped_tbpm_sum(N_tbpm_all_chan)
+ integer*4 ndet_ped_tbpm_sum2(N_tbpm_all_chan)
+ integer*4 ndet_tbpm_ped_counts
+*
+ common/ndet_ped_tbpm/
+ & ndet_ped_tbpm,
+ & ndet_ped_tbpm_sig,
+ & ndet_thresh_tbpm,
+ & ndet_thresh_tbpm_sig,
+ & ndet_ped_tbpm_sum,
+ & ndet_ped_tbpm_sum2,
+ & ndet_tbpm_ped_counts
diff --git a/INCLUDE/sos_aero_parms.cmn b/INCLUDE/sos_aero_parms.cmn
new file mode 100644
index 0000000..b5eeef8
--- /dev/null
+++ b/INCLUDE/sos_aero_parms.cmn
@@ -0,0 +1,44 @@
+* $Log: sos_aero_parms.cmn,v $
+* Revision 1.2 1996/10/02 19:56:46 saw
+* (RMM) Add rawadc arrays for diagnostic purposes and saer_sumA/B
+* variables
+*
+* Revision 1.1 1996/04/30 13:44:22 saw
+* Initial revision
+*
+*%% include 'sos_data_structures.cmn'
+
+*
+* CTPTYPE = parm
+*
+ real*4 saer_pos_gain(smax_aer_hits)
+ real*4 saer_neg_gain(smax_aer_hits)
+
+*
+* CTPTYPE = event
+*
+ integer*4 saer_tot_good_hits
+ integer*4 saer_rawadc_neg(smax_aer_hits)
+ integer*4 saer_rawadc_pos(smax_aer_hits)
+ integer*4 saer_sumA
+ integer*4 saer_sumB
+
+ real*4 saer_pos_npe(smax_aer_hits)
+ real*4 saer_neg_npe(smax_aer_hits)
+ real*4 saer_neg_npe_sum
+ real*4 saer_pos_npe_sum
+ real*4 saer_npe_sum
+
+ common /aero_calib/
+ & saer_tot_good_hits,
+ & saer_rawadc_neg,
+ & saer_rawadc_pos,
+ & saer_sumA,
+ & saer_sumB,
+ & saer_pos_npe,
+ & saer_neg_npe,
+ & saer_pos_gain,
+ & saer_neg_gain,
+ & saer_neg_npe_sum,
+ & saer_pos_npe_sum,
+ & saer_npe_sum
diff --git a/INCLUDE/sos_bypass_switches.cmn b/INCLUDE/sos_bypass_switches.cmn
new file mode 100644
index 0000000..1cc79cd
--- /dev/null
+++ b/INCLUDE/sos_bypass_switches.cmn
@@ -0,0 +1,68 @@
+* sos_bypass_switches.cmn
+*
+* common blocks of CTP switches to bypass reconstruction code
+* elements.
+*
+* Created: D.F.Geesaman 22 May 1994
+* $Log: sos_bypass_switches.cmn,v $
+* Revision 1.7 1996/11/19 18:48:39 saw
+* (WH) Add bypass switch for lucite counter
+*
+* Revision 1.6 1996/09/04 16:25:51 saw
+* (JRA) Add bypass of tracking efficiency flags
+*
+* Revision 1.5 1996/04/30 13:45:23 saw
+* (JRA) Add bypass switch for Aerogel
+*
+* Revision 1.4 1996/01/17 15:13:31 cdaq
+* (JRA) Add bypass switches for efficiency calculations
+*
+* Revision 1.3 1995/08/08 18:22:08 cdaq
+* (JRA) Add sbypass_trans_cer
+*
+* Revision 1.2 1994/08/05 21:18:39 cdaq
+* (SAW) Add "CTPTYPE=parm" directive for auto generation of CTP reg calls
+*
+* Revision 1.1 1994/06/07 02:03:11 cdaq
+* Initial revision
+*
+* CTPTYPE=parm
+*
+ integer*4 sbypass_trans_scin
+ integer*4 sbypass_trans_cer
+ integer*4 sbypass_trans_cal
+ integer*4 sbypass_trans_dc
+ integer*4 sbypass_track
+ integer*4 sbypass_targ_trans
+ integer*4 sbypass_tof
+ integer*4 sbypass_cal
+ integer*4 sbypass_cer
+ integer*4 sbypass_aero
+ integer*4 sbypass_lucite
+ integer*4 sbypass_physics
+ integer*4 sbypass_dc_eff
+ integer*4 sbypass_scin_eff
+ integer*4 sbypass_cal_eff
+ integer*4 sbypass_cer_eff
+ integer*4 sbypass_track_eff
+ integer*4 sbypass_track_eff_files
+*
+ common/sos_bypass_switches/
+ & sbypass_trans_scin,
+ & sbypass_trans_cer,
+ & sbypass_trans_cal,
+ & sbypass_trans_dc,
+ & sbypass_track,
+ & sbypass_targ_trans,
+ & sbypass_tof,
+ & sbypass_cal,
+ & sbypass_cer,
+ & sbypass_physics,
+ & sbypass_dc_eff,
+ & sbypass_scin_eff,
+ & sbypass_cal_eff,
+ & sbypass_cer_eff,
+ & sbypass_aero,
+ & sbypass_lucite,
+ & sbypass_track_eff,
+ & sbypass_track_eff_files
diff --git a/INCLUDE/sos_calorimeter.cmn b/INCLUDE/sos_calorimeter.cmn
new file mode 100644
index 0000000..4ae4cc4
--- /dev/null
+++ b/INCLUDE/sos_calorimeter.cmn
@@ -0,0 +1,302 @@
+*
+* SOS calorimeter. Parameters from sos_positions.parm
+* $Log: sos_calorimeter.cmn,v $
+* Revision 1.11 1999/10/11 13:42:41 saw
+* Cosmetic
+*
+* Revision 1.10 1999/02/23 19:19:23 csa
+* Add scal_fv_test
+*
+* Revision 1.9 1999/01/29 17:34:22 saw
+* Add variables for second tubes on shower counter
+*
+* Revision 1.8 1996/09/04 16:26:21 saw
+* (JRA) Add variable for normalized sum of first 3 layers on track.
+*
+* Revision 1.7 1996/01/17 15:13:07 cdaq
+* (JRA) Add normalized event quantities
+*
+* Revision 1.6 1995/08/11 16:27:59 cdaq
+* (JRA) Add accumulators for calorimeter
+*
+* Revision 1.5 1995/05/22 19:06:46 cdaq
+* (SAW) Split gen_data_data_structures into gen, hms, sos, and coin parts
+*
+* Revision 1.4 1995/03/13 19:02:05 cdaq
+* (JRA) Move smax_cal_rows and smax_cal_columns to gen_data_structures
+*
+* Revision 1.3 1994/11/21 17:59:01 cdaq
+* (SPB) Recopied from hms file and modified names for SOS
+*
+* Revision 1.2 1994/08/05 21:03:44 cdaq
+* (SAW) Add makereg directive with required include files
+* Add "CTPTYPE=event,parm" directive for auto generation of CTP reg calls
+*
+* Revision 1.1 1994/04/13 19:00:49 cdaq
+* Initial revision
+*
+* The following include statments must precede the inclusion of this
+* file in each routine that uses it. The *%% syntax is also a
+* directive to makereg to tell it to include the code in the program
+* that it generates.
+*
+*%% include 'sos_data_structures.cmn'
+*
+* CTPTYPE=parm
+*
+ real*4 scal_1pr_zpos ! Z positions of front of shower counter layers
+ real*4 scal_2ta_zpos !
+ real*4 scal_3ta_zpos !
+ real*4 scal_4ta_zpos !
+ real*4 scal_1pr_thick ! Thickness of shower counter blocks
+ real*4 scal_2ta_thick !
+ real*4 scal_3ta_thick !
+ real*4 scal_4ta_thick !
+ integer*4 scal_1pr_nr !Number of shower blocks per column
+ integer*4 scal_2ta_nr !
+ integer*4 scal_3ta_nr !
+ integer*4 scal_4ta_nr !
+ real*4 scal_1pr_left !Y position, column #1
+ real*4 scal_1pr_right !
+ real*4 scal_1pr_top ! X positions, column #1
+ real*4 scal_2ta_left ! Y position, column #2
+ real*4 scal_2ta_right !
+ real*4 scal_2ta_top ! X positions, column#2
+ real*4 scal_3ta_left ! Y position, column #3
+ real*4 scal_3ta_right !
+ real*4 scal_3ta_top ! X positions, column #3
+ real*4 scal_4ta_left ! Y position, column #4
+ real*4 scal_4ta_right !
+ real*4 scal_4ta_top ! X positions, column #4
+ REAL*4 SCAL_SLOP !SLOP IN DISTANCE BETWEEN TRACK AND BLOCK
+ integer*4 scal_fv_test !Turn on SOS fiducial cut
+
+ common/sos_cal_parms/
+ & scal_1pr_zpos,
+ & scal_2ta_zpos,
+ & scal_3ta_zpos,
+ & scal_4ta_zpos,
+ & scal_1pr_thick,
+ & scal_2ta_thick,
+ & scal_3ta_thick,
+ & scal_4ta_thick,
+ & scal_1pr_nr,
+ & scal_2ta_nr,
+ & scal_3ta_nr,
+ & scal_4ta_nr,
+ & scal_1pr_left,
+ & scal_1pr_right,
+ & scal_1pr_top(SMAX_CAL_ROWS),
+ & scal_2ta_left,
+ & scal_2ta_right,
+ & scal_2ta_top(SMAX_CAL_ROWS),
+ & scal_3ta_left,
+ & scal_3ta_right,
+ & scal_3ta_top(SMAX_CAL_ROWS),
+ & scal_4ta_left,
+ & scal_4ta_right,
+ & scal_4ta_top(SMAX_CAL_ROWS),
+ & scal_slop,
+ & scal_fv_test
+*
+* SOS calorimeter. Geometrical constants filled by s_init_cal
+*
+ real*4 scal_block_xsize !
+ real*4 scal_block_ysize !Block dimensions - 10*70*10 cm^3
+ real*4 scal_block_zsize !
+ real*4 scal_block_xc !
+ real*4 scal_block_yc !X,Y,Z coordinates of block centers
+ real*4 scal_block_zc !
+ real*4 scal_xmin !
+ real*4 scal_xmax !
+ real*4 scal_ymin !Boundaries of the SOS
+ real*4 scal_ymax !calorimeter stack
+ real*4 scal_zmin !
+ real*4 scal_zmax !
+ real*4 scal_fv_xmin !
+ real*4 scal_fv_xmax !
+ real*4 scal_fv_ymin !Boundaries of the
+ real*4 scal_fv_ymax !fiducial volume
+ real*4 scal_fv_zmin !
+ real*4 scal_fv_zmax !
+ common/sos_geometry_cal/
+ & scal_block_xsize,
+ & scal_block_ysize,
+ & scal_block_zsize,
+ & scal_block_xc(SMAX_CAL_BLOCKS),
+ & scal_block_yc(SMAX_CAL_BLOCKS),
+ & scal_block_zc(SMAX_CAL_BLOCKS),
+ & scal_xmin,scal_xmax,
+ & scal_ymin,scal_ymax,
+ & scal_zmin,scal_zmax,
+ & scal_fv_xmin,scal_fv_xmax,
+ & scal_fv_ymin,scal_fv_ymax,
+ & scal_fv_zmin,scal_fv_zmax
+*
+* SOS calorimeter. Sparsified data filled by s_sparsify_cal
+*
+* CTPTYPE=event
+*
+ integer*4 scal_rows !Row number. Copied from sos_raw_cal
+ integer*4 scal_cols !Column number. Copied from sos_raw_cal
+ real*4 scal_adcs_pos !Pulse height in channels(ADC-PED).
+ real*4 scal_adcs_neg !Pulse height in channels(ADC-PED).
+ integer*4 scal_num_hits !Total number of hits above threshold
+ common/sos_sparsified_cal/
+ & scal_rows(SMAX_CAL_BLOCKS),
+ & scal_cols(SMAX_CAL_BLOCKS),
+ & scal_adcs_neg(SMAX_CAL_BLOCKS),
+ & scal_adcs_pos(SMAX_CAL_BLOCKS),
+ & scal_num_hits
+*
+* SOS calorimeter. Cluster data, filled by s_clusters_cal
+*
+ integer*4 snclusters_max !Number of clusters allowed in the calorimeter
+ parameter (snclusters_max=5) !Set the maximum to 5
+ integer*4 snclusters_cal !Number of clusters found
+ integer*4 scluster_hit !Link pointer to cluster number for each hit
+ integer*4 scluster_size !Number of hits in a cluster
+ real*4 scluster_xc !X-coordinate of a cluster
+ real*4 scluster_e1 !Energy deposition in column #1
+ real*4 scluster_e2 ! #2
+ real*4 scluster_e3 ! #3
+ real*4 scluster_e4 ! #4
+ real*4 scluster_et !Total energy deposition
+
+ real*4 scluster_e1_pos !Energy deposition in column #POS_1
+ real*4 scluster_e1_neg !Energy deposition in column #NEG_1
+*
+ real*4 scluster_e2_pos !Energy deposition in column #POS_2
+ real*4 scluster_e2_neg !Energy deposition in column #NEG_2
+
+ common/sos_clusters_cal/
+ & scluster_hit(SMAX_CAL_BLOCKS),
+ & scluster_size(snclusters_max),
+ & scluster_xc(snclusters_max),
+ & scluster_e1(snclusters_max),
+ & scluster_e2(snclusters_max),
+ & scluster_e3(snclusters_max),
+ & scluster_e4(snclusters_max),
+ & scluster_e1_pos(snclusters_max),
+ & scluster_e1_neg(snclusters_max),
+ & scluster_e2_pos(snclusters_max),
+ & scluster_e2_neg(snclusters_max),
+ & scluster_et(snclusters_max),
+ & snclusters_cal
+*
+* SOS calorimeter. Calorimeter track quantities,filled by s_tracks_cal
+*
+ real*4 strack_xc !X,Y position of track on
+ real*4 strack_yc ! calorimeter front surface
+ integer*4 scluster_track !Link pointer to calorimeter cluster number
+ integer*4 sntracks_cal !Number of tracks for which a cluster was found
+ common/sos_tracks_cal/
+ & strack_xc(sntracks_max),
+ & strack_yc(sntracks_max),
+ & scluster_track(sntracks_max),
+ & sntracks_cal
+*
+* CTPTYPE=parm
+*
+* SOS calorimeter. ADC pedestals and thresholds
+*
+ real*4 scal_pos_ped_mean !Mean pedestal value
+ real*4 scal_pos_ped_rms !Pedestal rms deviation
+ real*4 scal_pos_threshold !Threshold=3.*scal_ped_rms
+ real*4 scal_neg_ped_mean !Mean pedestal value
+ real*4 scal_neg_ped_rms !Pedestal rms deviation
+ real*4 scal_neg_threshold !Threshold=3.*scal_ped_rms
+ common/sos_cal_pedestals/
+ & scal_pos_ped_mean(SMAX_CAL_BLOCKS),
+ & scal_pos_ped_rms(SMAX_CAL_BLOCKS),
+ & scal_pos_threshold(SMAX_CAL_BLOCKS),
+ & scal_neg_ped_mean(SMAX_CAL_BLOCKS),
+ & scal_neg_ped_rms(SMAX_CAL_BLOCKS),
+ & scal_neg_threshold(SMAX_CAL_BLOCKS)
+*
+* SOS calorimeter. Calibration constants
+*
+ real*4 scal_pos_cal_const !Calibration constants
+ real*4 scal_neg_cal_const !Calibration constants
+ common/sos_cal_const/
+ & scal_pos_cal_const(SMAX_CAL_BLOCKS),
+ & scal_neg_cal_const(SMAX_CAL_BLOCKS)
+*
+* SOS calorimeter. Relative gains & correction factors
+*
+ real*4 scal_pos_gain_ini !Relative gains during the last calibration
+ real*4 scal_pos_gain_cur !Current relative gains
+ real*4 scal_pos_gain_cor !Correction factor: cor=ini/cur
+ real*4 scal_neg_gain_ini !Relative gains during the last calibration
+ real*4 scal_neg_gain_cur !Current relative gains
+ real*4 scal_neg_gain_cor !Correction factor: cor=ini/cur
+ common/sos_cal_monitor/
+ & scal_pos_gain_ini(SMAX_CAL_BLOCKS),
+ & scal_pos_gain_cur(SMAX_CAL_BLOCKS),
+ & scal_pos_gain_cor(SMAX_CAL_BLOCKS),
+ & scal_neg_gain_ini(SMAX_CAL_BLOCKS),
+ & scal_neg_gain_cur(SMAX_CAL_BLOCKS),
+ & scal_neg_gain_cor(SMAX_CAL_BLOCKS)
+*
+* SOS calorimeter. Debuging LUN and flags
+*
+ integer*4 slun_dbg_cal
+ integer*4 sdbg_raw_cal
+ integer*4 sdbg_sparsified_cal
+ integer*4 sdbg_decoded_cal
+ integer*4 sdbg_clusters_cal
+ integer*4 sdbg_tracks_cal
+ integer*4 sdbg_tests_cal
+ integer*4 scal_num_neg_columns
+ common/sos_cal_flags/
+ & slun_dbg_cal,
+ & sdbg_raw_cal,
+ & sdbg_sparsified_cal,
+ & sdbg_decoded_cal,
+ & sdbg_clusters_cal,
+ & sdbg_tracks_cal,
+ & sdbg_tests_cal,
+ $ scal_num_neg_columns
+
+
+*
+* CTPTYPE=event
+*
+ integer*4 scal_zero_sum(SMAX_CAL_BLOCKS)
+ integer*4 scal_zero_sum2(SMAX_CAL_BLOCKS)
+ integer*4 scal_zero_num(SMAX_CAL_BLOCKS)
+ real*4 scal_zero_ave(SMAX_CAL_BLOCKS)
+ real*4 scal_zero_sig(SMAX_CAL_BLOCKS)
+ real*4 scal_zero_thresh(SMAX_CAL_BLOCKS)
+
+ common /sos_cal_zero/
+ & scal_zero_ave,
+ & scal_zero_sig,
+ & scal_zero_thresh,
+ & scal_zero_num,
+ & scal_zero_sum,
+ & scal_zero_sum2
+
+*
+* CTPTYPE=event
+*
+ real*4 sscal_suma !normalized sum of layer A.
+ real*4 sscal_sumb !normalized sum of layer B.
+ real*4 sscal_sumc !normalized sum of layer C.
+ real*4 sscal_sumd !normalized sum of layer D.
+ real*4 ssprsum !normalized PR sum.
+ real*4 ssshsum !normalized total sum.
+ real*4 ssprtrk !normalized PR sum on track.
+ real*4 ssshtrk !normalized total sum on track.
+ real*4 ssshtrk3 !normalized sum of first 3 layers on track.
+
+ common /sos_cal_normalized/
+ & sscal_suma,
+ & sscal_sumb,
+ & sscal_sumc,
+ & sscal_sumd,
+ & ssprsum,
+ & ssshsum,
+ & ssprtrk,
+ & ssshtrk,
+ & ssshtrk3
diff --git a/INCLUDE/sos_cer_parms.cmn b/INCLUDE/sos_cer_parms.cmn
new file mode 100644
index 0000000..df30bbf
--- /dev/null
+++ b/INCLUDE/sos_cer_parms.cmn
@@ -0,0 +1,61 @@
+* sos_cer_parms.cmn
+*
+* $Log: sos_cer_parms.cmn,v $
+* Revision 1.1 1995/08/08 19:15:10 cdaq
+* Initial revision
+*
+
+* CTPTYPE=parm
+*
+ real*4 scer_chi2max
+ real*4 scer_beta_min
+ real*4 scer_beta_max
+ real*4 scer_et_min
+ real*4 scer_et_max
+ real*4 scer_mirror_zpos
+ real*4 scer_region
+ real*4 scer_min_eff
+ real*4 scer_threshold
+
+ integer*4 scer_num_mirrors
+ parameter(scer_num_mirrors=4)
+ integer*4 scer_num_regions
+ parameter(scer_num_regions=scer_num_mirrors+1)
+
+ common/sos_cer_parms/
+ & scer_chi2max,
+ & scer_beta_min,
+ & scer_beta_max,
+ & scer_et_min,
+ & scer_et_max,
+ & scer_mirror_zpos,
+ & scer_region(scer_num_regions,8),
+ & scer_min_eff,
+ & scer_threshold
+*
+* CTPTYPE=parm
+*
+ real*4 scer_adc_to_npe(scer_num_mirrors)
+
+ integer*4 scer_ped(scer_num_mirrors)
+ integer*4 scer_width(scer_num_mirrors)
+
+ common/sos_cer_trans/
+ & scer_ped,
+ & scer_width,
+ & scer_adc_to_npe
+*
+* CTPTYPE=event
+*
+ real*4 scer_region_eff(scer_num_regions)
+
+ integer*4 scer_track_counter(scer_num_regions)
+ integer*4 scer_fired_counter(scer_num_regions)
+
+ integer*4 scer_min_counts
+ parameter(scer_min_counts=1)
+
+ common/sos_cer_effs/
+ & scer_track_counter,
+ & scer_fired_counter,
+ & scer_region_eff
diff --git a/INCLUDE/sos_data_structures.cmn b/INCLUDE/sos_data_structures.cmn
new file mode 100644
index 0000000..22fbbb5
--- /dev/null
+++ b/INCLUDE/sos_data_structures.cmn
@@ -0,0 +1,711 @@
+*****************begin: sos_data_structures.cmn*************************
+*
+* include file sos_data_structures.cmn
+*
+* Author: D. F. Geesaman 1 September 1993
+*
+* $Log: sos_data_structures.cmn,v $
+* Revision 1.10 2003/09/05 20:37:14 jones
+* Merge in online03 changes (mkj)
+*
+* Revision 1.9.2.2 2003/08/12 17:35:57 cdaq
+* Add variables for e00-108 (hamlet)
+*
+* Revision 1.9.2.1 2003/07/15 19:04:15 cdaq
+* add ssinplane
+*
+* Revision 1.9 1999/02/23 19:19:57 csa
+* Change some physics vars
+*
+* Revision 1.8 1999/01/29 17:34:23 saw
+* Add variables for second tubes on shower counter
+*
+* Revision 1.7 1996/11/19 18:49:15 saw
+* (WH) Add data structures for Lucite counter
+*
+* Revision 1.6 1996/09/04 16:29:41 saw
+* (JRA) Add energies for layers of shower counter
+*
+* Revision 1.5 1996/04/30 13:54:42 saw
+* (JRA) Change array sizes to two chambers instead of 3
+*
+* Revision 1.4 1996/01/24 16:19:27 saw
+* (JRA) Double size of misc hits data structures
+*
+* Revision 1.3 1996/01/17 15:12:27 cdaq
+* (JRA) ADD SCER_RAW_ADC and SSCIN_FPTIME
+*
+* Revision 1.2 1995/08/11 16:29:08 cdaq
+* (CC) Add structure for # of photoelectrons in Cerenkov
+*
+* Revision 1.1 1995/05/22 18:42:33 cdaq
+* Initial revision
+*
+*
+* CTPTYPE=parm
+*
+* STHETA_LAB SOS LAB ANGLE THETA (RADIANS)
+* SPHI_LAB SOS LAB ANGLE PHI
+* SPCENTRAL SOS CENTRAL MOMENUTM (GEV)
+* SBFIELD SOS B FIELD INCLUDING SIGN
+*
+ REAL*4 STHETA_LAB ! SOS LAB ANGLE THETA (RADIANS)
+ REAL*4 SPHI_LAB ! SOS LAB ANGLE PHI
+ REAL*4 SPCENTRAL ! SOS CENTRAL MOMENUTM (GEV)
+ REAL*4 SBFIELD ! SOS B FIELD INCLUDING SIGN
+ REAL*4 SPARTMASS ! EXPECTED MASS OF DETECTED PARTICLE IN SOS
+ COMMON/SOS_SPECTROMETER/
+ & STHETA_LAB,
+ & SPHI_LAB,
+ & SPCENTRAL,
+ & SBFIELD,
+ & SPARTMASS
+*
+* CTPTYPE=event
+*
+*
+* SOS DATA
+*
+* RAW DC DATA FILLED BY G_decode_event_by_banks
+* SOS DRIFT CHAMBER HITS
+* EACH CHAMBER HIT (TDC VALUE) HAS A
+* PLANE NUMBER
+* WIRE NUMBER
+* TDC VALUE
+* THE TOTAL NUMBER OF HITS IS GIVEN IN SDC_RAW_TOT_HITS
+*
+ INTEGER*4 SMAX_DC_HITS ! MAXIUM NUMBER OF DRIFT CHAMBER HITS
+ INTEGER*4 SMAX_NUM_DC_PLANES ! MAX NUMBER OF SOS DRIFT CHAMBER PLANES
+ INTEGER*4 SMAX_NUM_CHAMBERS ! MAX NUMBER OF SOS DRIFT CHAMBERS
+ PARAMETER(SMAX_DC_HITS=3600)
+ PARAMETER(SMAX_NUM_DC_PLANES=12)
+ PARAMETER(SMAX_NUM_CHAMBERS=2)
+ INTEGER*4 SDC_RAW_PLANE_NUM
+ INTEGER*4 SDC_RAW_WIRE_NUM
+ INTEGER*4 SDC_RAW_TDC
+ INTEGER*4 SDC_RAW_TOT_HITS
+ COMMON/SOS_RAW_DC/
+ 1 SDC_RAW_PLANE_NUM(SMAX_DC_HITS),
+ 2 SDC_RAW_WIRE_NUM(SMAX_DC_HITS),
+ 3 SDC_RAW_TDC(SMAX_DC_HITS),
+ 4 SDC_RAW_TOT_HITS
+*
+* SOS DC DECODED DATA
+*
+* FILLED BY S_TRANS_DC ROUTINE
+* SOS DRIFT CHAMBER HITS
+* EACH CHAMBER HIT (TDC VALUE) HAS A
+* PLANE NUMBER
+* WIRE NUMBER
+* TDC VALUE
+* DRIFT TIME
+* DRIFT DISTANCE
+* GENERALIZED COORDINATE OF HIT WIRE CENTER
+* GENERALIZED COORDINATE OF HIT PERPENDICULAR TO WIRE DIRECTION
+*
+* THE TOTAL NUMBER OF HITS IN EACH PLANE IS GIVEN IN SDC_HITS_PER_PLANE(I)
+* THE TOTAL NUMBER OF HITS IS GIVEN IN SDC_TOT_HITS
+*
+ INTEGER*4 SDC_PLANE_NUM ! COPIED FROM SOS_RAW_DC
+ INTEGER*4 SDC_WIRE_NUM ! COPIED FROM SOS_RAW_DC
+ INTEGER*4 SDC_TDC ! COPIED FROM SOS_RAW_DC
+* INTEGER*4 SDC_HITS_PER_PLANE
+ INTEGER*4 SDC_TOT_HITS
+ REAL*4 SDC_DRIFT_TIME
+ REAL*4 SDC_DRIFT_DIS
+ REAL*4 SDC_WIRE_CENTER
+ REAL*4 SDC_WIRE_COORD
+ COMMON/SMS_DECODED_DC/
+ 1 SDC_DRIFT_TIME(SMAX_DC_HITS),
+ 2 SDC_DRIFT_DIS(SMAX_DC_HITS),
+ 3 SDC_WIRE_CENTER(SMAX_DC_HITS),
+ 4 SDC_WIRE_COORD(SMAX_DC_HITS),
+ 5 SDC_PLANE_NUM(SMAX_DC_HITS),
+ 6 SDC_WIRE_NUM(SMAX_DC_HITS),
+ 7 SDC_TDC(SMAX_DC_HITS),
+* 8 SDC_HITS_PER_PLANE(SMAX_NUM_DC_PLANES),
+ 9 SDC_TOT_HITS
+*
+* SOS RAW SCINTILLATOR HITS
+* FILLED BY G_decode_event_by_banks
+* EACH SCINTILLATOR HIT IS SPECIFIED BY A
+* SCINTILLATOR PLANE NUMBER
+* SCINTILLATOR COUNTER NUMBER
+* SCINTILLATOR ADC AT POSITIVE GENERALIZED COORDINATE END
+* SCINTILLATOR ADC AT NEGATIVE GENERALIZED COORDINATE END
+* SCINTILLATOR TDC AT POSITIVE GENERALIZED COORDINATE END
+* SCINTILLATOR TDC AT NEGATIVE GENERALIZED COORDINATE END
+* THE TOTAL NUMBER OF HITS IS GIVEN BY SSCIN_TOT_HITS
+ INTEGER*4 SMAX_ALL_SCIN_HITS ! MAXIMUM TOTAL NUMBER OF SCIN HITS
+ PARAMETER (SMAX_ALL_SCIN_HITS=53) ! Should exceed # of paddles
+ INTEGER*4 SNUM_ALL_SCIN_PLANES ! TOTAL NUMBER OF SCIN PLANES
+ PARAMETER (SNUM_ALL_SCIN_PLANES=4)
+ INTEGER*4 SSCIN_ALL_PLANE_NUM
+ INTEGER*4 SSCIN_ALL_COUNTER_NUM
+ INTEGER*4 SSCIN_ALL_ADC_POS
+ INTEGER*4 SSCIN_ALL_ADC_NEG
+ INTEGER*4 SSCIN_ALL_TDC_POS
+ INTEGER*4 SSCIN_ALL_TDC_NEG
+ INTEGER*4 SSCIN_ALL_TOT_HITS
+*
+ COMMON/SOS_RAW_SCIN/
+ & SSCIN_ALL_PLANE_NUM(SMAX_ALL_SCIN_HITS),
+ & SSCIN_ALL_COUNTER_NUM(SMAX_ALL_SCIN_HITS),
+ & SSCIN_ALL_ADC_POS(SMAX_ALL_SCIN_HITS),
+ & SSCIN_ALL_ADC_NEG(SMAX_ALL_SCIN_HITS),
+ & SSCIN_ALL_TDC_POS(SMAX_ALL_SCIN_HITS),
+ & SSCIN_ALL_TDC_NEG(SMAX_ALL_SCIN_HITS),
+ & SSCIN_ALL_TOT_HITS
+*
+* SOS REAL SCINTILLATOR HITS (Hits with no TDC data stripped out)
+* FILLED BY S_strip_scin (which is called by s_trans_scin)
+* EACH SCINTILLATOR HIT IS SPECIFIED BY A
+* SCINTILLATOR PLANE NUMBER
+* SCINTILLATOR COUNTER NUMBER
+* SCINTILLATOR ADC AT POSITIVE GENERALIZED COORDINATE END
+* SCINTILLATOR ADC AT NEGATIVE GENERALIZED COORDINATE END
+* SCINTILLATOR TDC AT POSITIVE GENERALIZED COORDINATE END
+* SCINTILLATOR TDC AT NEGATIVE GENERALIZED COORDINATE END
+* THE TOTAL NUMBER OF HITS IS GIVEN BY SSCIN_TOT_HITS
+ INTEGER*4 SMAX_SCIN_HITS ! MAXIMUM TOTAL NUMBER OF SCIN HITS
+ PARAMETER (SMAX_SCIN_HITS=53) ! Should exceed # of paddles
+ INTEGER*4 SNUM_SCIN_PLANES ! TOTAL NUMBER OF SCIN PLANES
+ PARAMETER (SNUM_SCIN_PLANES=4)
+ INTEGER*4 SNUM_SCIN_ELEMENTS
+ PARAMETER (SNUM_SCIN_ELEMENTS=16)
+ INTEGER*4 SSCIN_PLANE_NUM
+ INTEGER*4 SSCIN_COUNTER_NUM
+ REAL*4 SSCIN_ADC_POS
+ REAL*4 SSCIN_ADC_NEG
+ INTEGER*4 SSCIN_TDC_POS
+ INTEGER*4 SSCIN_TDC_NEG
+ INTEGER*4 SSCIN_TOT_HITS
+ INTEGER*4 SSCIN_SING_COUNTER !DJM''S registered hit counter
+
+*
+ COMMON/SOS_REAL_SCIN/
+ & SSCIN_PLANE_NUM(SMAX_SCIN_HITS),
+ & SSCIN_COUNTER_NUM(SMAX_SCIN_HITS),
+ & SSCIN_ADC_POS(SMAX_SCIN_HITS),
+ & SSCIN_ADC_NEG(SMAX_SCIN_HITS),
+ & SSCIN_TDC_POS(SMAX_SCIN_HITS),
+ & SSCIN_TDC_NEG(SMAX_SCIN_HITS),
+ & SSCIN_TOT_HITS,
+ & SSCIN_SING_COUNTER(SNUM_SCIN_PLANES)
+*
+*
+* DECODED SCIN HITS
+* FILLED BY S_TRANS_SCIN
+* THIS USES SCINTILLATOR INFORMATION ONLY TO CALCUATE
+* SSCIN_APPROX_HIT_COORD GENERALIZED COORDINATE ALONG HIT
+* SCINTILLATOR DETERMINED FROM TDC INFO.
+* SSCIN_COR_ADC CORRECTED PULSE HEIGHT AT HIT
+* SSCIN_COR_TIME CORRECTED TIME AT HIT
+* THE TOTAL NUMBER OF HITS IN EACH PLANE IS GIVEN BY SSCIN_HITS_PER_PLANE
+* THE SSTART_TIME IS DEFINED AS THE TIME IF THE TRACK HAD GONE THROUGH
+* THE CENTER OF S1X. IT IS USED BY S_TRANS_DC FOR THE DRIFT TIME
+* CALCULATION.
+* STWO_GOOD_TIMES IS A LOGICAL VARIABLE WHICH IS TRUE IF BOTH ENDS
+* OF THE SCINTILLATOR ARE HIT AND FALSE IF ONLY ONE END IS HIT.
+* SGOOD_START_TIME IS TRUE IF A START TIME WAS FOUND
+*
+ REAL*4 SSCIN_ZPOS(SMAX_SCIN_HITS)
+ REAL*4 SSCIN_CENTER_COORD(SMAX_SCIN_HITS)
+ REAL*4 SSCIN_DEC_HIT_COORD(SMAX_SCIN_HITS)
+ REAL*4 SSCIN_WIDTH(SMAX_SCIN_HITS)
+ REAL*4 SSCIN_SLOP(SMAX_SCIN_HITS)
+ REAL*4 SSCIN_COR_ADC(SMAX_SCIN_HITS)
+ REAL*4 SSCIN_COR_TIME(SMAX_SCIN_HITS)
+ REAL*4 SSTART_TIME
+ INTEGER*4 SSTART_HITNUM
+ INTEGER*4 SSTART_HITSIDE
+ INTEGER*4 SSCIN_HITS_PER_PLANE(SNUM_SCIN_PLANES)
+ LOGICAL*4 STWO_GOOD_TIMES(SMAX_SCIN_HITS)
+ LOGICAL*4 SGOOD_START_TIME
+* LOGICAL*4 SGOOD_START_PLANE
+
+ COMMON/SOS_DECODED_SCIN/
+ & SSCIN_ZPOS,
+ & SSCIN_CENTER_COORD,
+ & SSCIN_WIDTH,
+ & SSCIN_SLOP,
+ & SSCIN_DEC_HIT_COORD,
+ & SSCIN_COR_ADC,
+ & SSCIN_COR_TIME,
+ & SSTART_TIME,
+ & SSCIN_HITS_PER_PLANE,
+ & SSTART_HITNUM,
+ & SSTART_HITSIDE,
+ & STWO_GOOD_TIMES,
+ & SGOOD_START_TIME
+* & SGOOD_START_PLANE
+*
+*
+* SOS CALORIMETER HITS
+* FILLED BY G_decode_event_by_banks
+*
+* ALLOW FOR NO SPARCIFICATION OF SHOWER COUNTER ELEMENTS
+*
+* EACH COUNTER HAS A
+* COLUMN NUMBER
+* ROW NUMBER
+* ADC VALUE
+*
+* THE TOTAL NUMBER OF SHOWER HITS IS SCAL_TOT_HITS
+*
+ INTEGER*4 SMAX_CAL_BLOCKS ! TOTAL NUMBER OF SHOWER BLOCKS
+ PARAMETER (SMAX_CAL_BLOCKS=44)
+ INTEGER*4 SMAX_CAL_ROWS !Number of calorimeter rows
+ PARAMETER (SMAX_CAL_ROWS=11)
+ INTEGER*4 SMAX_CAL_COLUMNS !Number of calorimeter columns
+ PARAMETER (SMAX_CAL_COLUMNS=4)
+ INTEGER*4 SCAL_TOT_HITS
+ INTEGER*4 SCAL_POS_HITS
+ INTEGER*4 SCAL_NEG_HITS
+ INTEGER*4 SCAL_COLUMN(SMAX_CAL_BLOCKS)
+ INTEGER*4 SCAL_ROW(SMAX_CAL_BLOCKS)
+ INTEGER*4 SCAL_ADC_POS(SMAX_CAL_BLOCKS)
+ INTEGER*4 SCAL_ADC_NEG(SMAX_CAL_BLOCKS)
+ INTEGER*4 SCAL_ADC(SMAX_CAL_BLOCKS)
+ equivalence (scal_adc, scal_adc_pos) ! For old code
+ REAL*4 SCAL_REALADC_POS(SMAX_CAL_BLOCKS)
+ REAL*4 SCAL_REALADC_NEG(SMAX_CAL_BLOCKS)
+ REAL*4 SCAL_REALADC(SMAX_CAL_BLOCKS)
+ equivalence (scal_realadc, scal_realadc_pos)
+
+ COMMON/SOS_RAW_CAL/
+ & SCAL_COLUMN,
+ & SCAL_ROW,
+ & SCAL_ADC_POS,
+ & SCAL_ADC_NEG,
+ & SCAL_REALADC_POS,
+ & SCAL_REALADC_NEG,
+ & SCAL_TOT_HITS,
+ & SCAL_POS_HITS,
+ & SCAL_NEG_HITS
+*
+* DECODED CALORIMETER QUANTITIES
+* FILLED BY S_TRANS_CAL USING ONLY THE CALORIMETER INFORMATION
+*
+* X COORDINATE OF BLOCK CENTER
+* Z COORDINATE OF BLOCK CENTER
+* ENERGY DEPOSITED IN THE BLOCK
+* ENERGY DEPOSITED IN COLUMN #1
+* #2
+* #3
+* #4
+* TOTAL ENERGY IN THE CALORIMETER
+ INTEGER*4 SNHITS_CAL !NUMBER OF CALORIMETER HITS ABOVE THRESHOLD
+ REAL*4 SBLOCK_XC !X COORDINATE OF BLOCK CENTER
+ REAL*4 SBLOCK_ZC !Z COORDINATE OF BLOCK CENTER
+ REAL*4 SBLOCK_DE !ENERGY DEPOSITION IN THE BLOCKS
+ REAL*4 SCAL_E1 !ENERGY DEPOSITION IN COLUMN #1
+ REAL*4 SCAL_E2 ! #2
+ REAL*4 SCAL_E3 ! #3
+ REAL*4 SCAL_E4 ! #4
+ REAL*4 SCAL_ET !TOTAL ENERGY IN THE CALORIMETER
+ REAL*4 SCAL_E1_POS
+ REAL*4 SCAL_E1_NEG
+ REAL*4 SCAL_E2_POS
+ REAL*4 SCAL_E2_NEG
+ REAL*4 SBLOCK_DE_POS
+ REAL*4 SBLOCK_DE_NEG
+ COMMON/SOS_DECODED_CAL/
+ & SBLOCK_XC(SMAX_CAL_BLOCKS),
+ & SBLOCK_ZC(SMAX_CAL_BLOCKS),
+ & SBLOCK_DE(SMAX_CAL_BLOCKS),
+ & SCAL_E1,
+ & SCAL_E2,
+ & SCAL_E3,
+ & SCAL_E4,
+ & SCAL_ET,
+ & SCAL_E1_POS,
+ & SCAL_E1_NEG,
+ & SCAL_E2_POS,
+ & SCAL_E2_NEG,
+ & SBLOCK_DE_POS(SMAX_CAL_BLOCKS),
+ & SBLOCK_DE_NEG(SMAX_CAL_BLOCKS),
+ & SNHITS_CAL
+*
+*
+* SOS CERENKOV HITS
+* FILLED BY G_decode_event_by_banks
+*
+* THERE ARE FOUR CERENKOV PHOTOTUBES. EACH HIT HAS
+* TUBE NUMBER
+* ADC VALUE
+* THE TOTAL NUMBER OF PHOTOTUBE HITS IS SCER_TOT_HITS
+* HOWEVER TO MAKE THE DECODERS SYMMETRICAL TO A SCINT WE MUST ADD
+* A DUMMY PLANE NUMBER.
+ INTEGER*4 SMAX_CER_HITS
+ PARAMETER(SMAX_CER_HITS=4)
+ INTEGER*4 SCER_TOT_HITS
+ INTEGER*4 SCER_TUBE_NUM
+ INTEGER*4 SCER_RAW_ADC
+ INTEGER*4 SCER_PLANE
+ COMMON/SOS_RAW_CER/
+ & SCER_TUBE_NUM(SMAX_CER_HITS),
+ & SCER_RAW_ADC(SMAX_CER_HITS),
+ & SCER_PLANE(SMAX_CER_HITS),
+ & SCER_TOT_HITS
+*
+*
+* DECODED CERENKOV QUANTITIES
+* FILLED BY S_TRANS_CER
+*
+ INTEGER*4 SCER_NUM_HITS ! NUMBER OF CERENKOV HITS ABOVE THRESHOLD
+ REAL*4 SCER_NPE ! ADC CONVERTED TO NUMBER OF PHOTOELECTRONS
+ REAL*4 SCER_NPE_SUM ! SUM OVER TUBES OF NPE''S
+ REAL*4 SCER_ADC ! PED SUBTRACTED ADC FOR EACH *TUBE*
+ COMMON/SCER_DECODED_CER/
+ & SCER_NUM_HITS,
+ & SCER_NPE(SMAX_CER_HITS),
+ & SCER_NPE_SUM,
+ & SCER_ADC(SMAX_CER_HITS)
+*
+*
+*
+* SOS AEROGEL HITS
+* FILLED BY G_decode_event_by_banks
+*
+* THERE ARE 14 AEROGEL PHOTOTUBES. We will pair tubes on the left and
+* right side so that are 7 "counters"
+* for evalutation of the amplifier/adder prototype there follow 8 left +
+* 8 right adc values, 7 each are ampliefied signals, the 8th is sum of 7
+* each
+* TUBE Row
+* ADC Left VALUE
+* ADC Right VALUE
+* THE TOTAL NUMBER OF PHOTOTUBE HITS IS SCER_TOT_HITS
+* HOWEVER TO MAKE THE DECODERS SYMMETRICAL TO A SCINT WE MUST ADD
+* A DUMMY PLANE NUMBER.
+ INTEGER*4 SMAX_AER_HITS
+ PARAMETER(SMAX_AER_HITS=8)
+ INTEGER*4 SNUM_AER_BLOCKS
+ PARAMETER(SNUM_AER_BLOCKS=7)
+ INTEGER*4 SAER_TOT_HITS
+ INTEGER*4 SAER_PAIR_NUM
+ INTEGER*4 SAER_ADC_POS
+ INTEGER*4 SAER_ADC_NEG
+ INTEGER*4 SAER_DUMMY
+ INTEGER*4 SAER_PLANE
+ COMMON/SOS_RAW_AER/
+ & SAER_PLANE(SMAX_AER_HITS),
+ & SAER_PAIR_NUM(SMAX_AER_HITS),
+ & SAER_ADC_POS(SMAX_AER_HITS),
+ & SAER_ADC_NEG(SMAX_AER_HITS),
+ & SAER_DUMMY(SMAX_AER_HITS),
+ & SAER_TOT_HITS
+*
+*
+*
+*
+*
+* SOS LUCITE HITS
+* FILLED BY G_decode_event_by_banks
+*
+* THERE ARE 16 LUCITE PHOTOTUBES. We will pair tubes on the left and
+* right side so that are 8 "counters"
+* TUBE Row
+* ADC Left VALUE
+* ADC Right VALUE
+* THE TOTAL NUMBER OF PHOTOTUBE HITS IS SLUC_TOT_HITS
+* HOWEVER TO MAKE THE DECODERS SYMMETRICAL TO A SCINT WE MUST ADD
+* A DUMMY PLANE NUMBER.
+ INTEGER*4 SMAX_LUC_HITS
+ PARAMETER(SMAX_LUC_HITS=9)
+ INTEGER*4 SNUM_LUC_BLOCKS
+ PARAMETER(SNUM_LUC_BLOCKS=8)
+ INTEGER*4 SLUC_TOT_HITS
+ INTEGER*4 SLUC_PLANE
+ INTEGER*4 SLUC_PAIR_NUM
+ INTEGER*4 SLUC_ADC_POS
+ INTEGER*4 SLUC_ADC_NEG
+ INTEGER*4 SLUC_TDC_POS
+ INTEGER*4 SLUC_TDC_NEG
+ COMMON/SOS_RAW_LUC/
+ & SLUC_PLANE(SMAX_LUC_HITS),
+ & SLUC_PAIR_NUM(SMAX_LUC_HITS),
+ & SLUC_ADC_POS(SMAX_LUC_HITS),
+ & SLUC_ADC_NEG(SMAX_LUC_HITS),
+ & SLUC_TDC_POS(SMAX_LUC_HITS),
+ & SLUC_TDC_NEG(SMAX_LUC_HITS),
+ & SLUC_TOT_HITS
+
+
+* SOS DETECTOR TRACK QUANTITIES
+* FILLED BY S_TRACK SUBROUTINE
+*
+ INTEGER*4 SNTRACKS_MAX ! NUMBER OF TRACKS ALLOWED IN FOCAL PLANE
+ PARAMETER (SNTRACKS_MAX=10) ! SET MAXIMUM TO 10
+ INTEGER*4 SNTRACKHITS_MAX ! MAXIMUM NUMBER OF HITS IN EACH TRACK
+ PARAMETER (SNTRACKHITS_MAX=24) ! SET MAXIMUM TO 24
+ INTEGER*4 SNTRACKS_FP ! NUMBER OF FOCAL PLANE TRACKS FOUND
+* ALL THE FOLLOWING VARIABLES ARE ARRAYS
+*
+ REAL*4 SX_FP ! X POSITION OF TRACK IN FOCAL PLANE
+ REAL*4 SY_FP ! Y POSITION OF TRACK IN FOCAL PLANE
+ REAL*4 SZ_FP ! Z POSITION OF TRACK IN FOCAL PLANE
+ REAL*4 SXP_FP ! X SLOPE OF TRACK IN FOCAL PLANE
+ REAL*4 SYP_FP ! Y SLOPE OF TRACK IN FOCAL PLANE
+ REAL*4 SCHI2_FP ! FIT QUALITY IN FOCAL PLANE
+ REAL*4 SCHI2PERDOF_FP ! FP CHI2 PER DEGREE OF FREEDOM
+ INTEGER*4 SNFREE_FP ! NUMBER OF DEGREES OF FREEDOM IN FIT
+ INTEGER*4 SNTRACK_HITS ! LIST OF HITS ON EACH TRACK
+ REAL*4 SDEL_FP ! FOCAL PLANE ERROR MATRIX
+ REAL*4 SX_FP_rot ! x in rotated focal plane
+ REAL*4 SY_FP_rot ! y in rotated f plane
+ REAL*4 SXP_FP_rot ! x slope in rotated f plane
+ REAL*4 SYP_FP_rot ! y slope in rot f plane
+* THE FOCAL PLANE ERROR MATRIX IS A 4 BY 4 BY SNTRACK_MAX ARRAY
+* THE FOUR INDECIES FOR EACH TRACK ARE X, XP, Y, YP
+* THE ERROR MATRIX FOR EACH TRACK IS SYMMETRIC ABOUT THE DIAGONAL
+* DELXX DELXXP DELXY DELXYP
+* DELXPX DELXPXP DELXPY DELXPYP
+* DELYPX DELYXP DELYY DELYYP
+* DELYPX DELYPXP DELYPY DELYPYP
+ COMMON/SOS_FOCAL_PLANE/
+ 1 SX_FP(SNTRACKS_MAX),
+ 2 SY_FP(SNTRACKS_MAX),
+ 3 SZ_FP(SNTRACKS_MAX),
+ 4 SXP_FP(SNTRACKS_MAX),
+ 5 SYP_FP(SNTRACKS_MAX),
+ 6 SCHI2_FP(SNTRACKS_MAX),
+ 7 SDEL_FP(4,4,SNTRACKS_MAX),
+ 8 SNTRACK_HITS(SNTRACKS_MAX,SNTRACKHITS_MAX+1),
+ 9 SNFREE_FP(SNTRACKS_MAX),
+ A SNTRACKS_FP,SCHI2PERDOF_FP(SNTRACKS_MAX),
+ > SX_FP_rot(SNTRACKS_MAX),
+ > SY_FP_rot(SNTRACKS_MAX),
+ > SXP_FP_rot(SNTRACKS_MAX),
+ > SYP_FP_rot(SNTRACKS_MAX)
+
+* SOS TARGET QUANTITIES
+* ASSUME THE SAME NUMBER OF MAXIMUM TRACKS AS IN THE FOCAL PLANE
+* SNTRACKS_MAX
+*
+* FILLED BY S_TARG_TRANS SUBROUTINE
+ INTEGER*4 SNTRACKS_TAR ! NUMBER OF TARGET TRACKS FOUND
+* ALL THE FOLLOWING VARIABLES ARE ARRAYS
+*
+ REAL*4 SX_TAR ! X POSITION OF TRACK AT TARGET
+ REAL*4 SY_TAR ! Y POSITION OF TRACK AT TARGET
+ REAL*4 SZ_TAR ! Z POSITION OF TRACK AT TARGET
+ REAL*4 SXP_TAR ! X SLOPE OF TRACK AT TARGET
+ REAL*4 SYP_TAR ! Y SLOPE OF TRACK AT TARGET
+ REAL*4 SDELTA_TAR ! FRACTION TRACK MOMENTUM
+ REAL*4 SP_TAR ! MOMENTUM OF TRACK AT TARGET
+ REAL*4 SCHI2_TAR ! FIT QUALITY AT TARGET
+ INTEGER*4 SNFREE_TAR ! NUMBER OF DEGREES OF FREEDOM IN FIT
+ REAL*4 SDEL_TAR ! TARGET ERROR MATRIX
+* THE FOCAL PLANE ERROR MATRIX IS A 5 BY 5 BY SNTRACK_MAX ARRAY
+* THE FIVE INDECIES FOR EACH TRACK ARE X, Y , XP, YP and P
+* THE ERROR MATRIX FOR EACH TRACK IS SYMMETRIC ABOUT THE DIAGONAL
+* DELXX DELXXP DELXY DELXYP DELXP
+* DELXPX DELXPXP DELXPY DELXPYP DELXPP
+* DELYX DELYXPY DELYY DELYYP DELYP
+* DELYPX DELYPXP DELYPY DELYPYP DELYPP
+* DELPX DELPXP DELPY DELPXP DELPP
+ INTEGER*4 SLINK_TAR_FP ! LINK POINTER TO FOCAL PLANE TRACK NUMBER
+ COMMON/SOS_TARGET/
+ 1 SX_TAR(SNTRACKS_MAX),
+ 2 SY_TAR(SNTRACKS_MAX),
+ 3 SZ_TAR(SNTRACKS_MAX),
+ 4 SXP_TAR(SNTRACKS_MAX),
+ 5 SYP_TAR(SNTRACKS_MAX),
+ 6 SDELTA_TAR(SNTRACKS_MAX),
+ 7 SP_TAR(SNTRACKS_MAX),
+ 8 SCHI2_TAR(SNTRACKS_MAX),
+ 9 SDEL_TAR(5,5,SNTRACKS_MAX),
+ A SNFREE_TAR(SNTRACKS_MAX),
+ B SLINK_TAR_FP(SNTRACKS_MAX),
+ C SNTRACKS_TAR
+*
+*
+* SOS_TRACK_TESTS
+*
+* PARTICLE ID INFORMATION FILLED BY S_TOF and S_CAL
+* THIS STORES THE RESULTS OF SHOWER AND SCINTILLATOR CALCULATIONS
+* FOR EACH OF THE TRACKS GENERATED BY S_TRACK
+*
+ INTEGER*4 SNBLOCKS_CAL(SNTRACKS_MAX)
+ REAL*4 STRACK_E1(SNTRACKS_MAX)
+ REAL*4 STRACK_E2(SNTRACKS_MAX)
+ REAL*4 STRACK_E3(SNTRACKS_MAX)
+ REAL*4 STRACK_E4(SNTRACKS_MAX)
+ REAL*4 STRACK_ET(SNTRACKS_MAX)
+ REAL*4 STRACK_PRESHOWER_E(SNTRACKS_MAX)
+ REAL*4 STRACK_E1_POS(SNTRACKS_MAX)
+ REAL*4 STRACK_E1_NEG(SNTRACKS_MAX)
+ REAL*4 STRACK_E2_POS(SNTRACKS_MAX)
+ REAL*4 STRACK_E2_NEG(SNTRACKS_MAX)
+*
+ INTEGER*4 SSCIN_HIT(SNTRACKS_MAX,SMAX_SCIN_HITS)
+ INTEGER*4 SNUM_SCIN_HIT(SNTRACKS_MAX)
+ INTEGER*4 SNUM_PMT_HIT(SNTRACKS_MAX)
+ REAL*4 SDEDX(SNTRACKS_MAX,SMAX_SCIN_HITS)
+ REAL*4 SBETA(SNTRACKS_MAX)
+ REAL*4 SBETA_CHISQ(SNTRACKS_MAX)
+ REAL*4 STIME_AT_FP(SNTRACKS_MAX)
+ REAL*4 SSCIN_FPTIME(SNTRACKS_MAX,SMAX_SCIN_HITS)
+*
+*
+ COMMON/SOS_TRACK_TESTS/
+ 1 STRACK_E1, ! ENERGY IN FIRST CALORIMETER COLUMN NEAR TRACK
+ 2 STRACK_E2, ! SECOND COLUMN
+ 3 STRACK_E3, ! THIRD COLUMN
+ 4 STRACK_E4, ! FOURTH COLUMN
+ 5 STRACK_ET, ! TOTAL SHOWER ENERGY ALONG TRACK
+ 6 STRACK_PRESHOWER_E, ! Preshower energy on track Note exp dependent.
+ 7 SDEDX, !
+ 8 SBETA, ! VELOCITY OF TRACK
+ 9 SBETA_CHISQ, ! CHISQ OF FIT TO BETA OF TRACK
+ A STIME_AT_FP, !
+ B SNBLOCKS_CAL, ! NUMBER OF SHOWER BLOCKS ON EACH TRACK
+ C SSCIN_HIT, ! ARRAY OF SCIN HITS ASSOCIATED WITH
+ D ! EACH TRACK
+ E SNUM_SCIN_HIT, ! NUMBER OF HITS FOR EACH TRACK
+ F SNUM_PMT_HIT, ! NUMBER OF PMT HITS FOR EACH TRACK
+ G SSCIN_FPTIME,
+ H STRACK_E1_POS,
+ I STRACK_E1_NEG,
+ J STRACK_E2_POS,
+ K STRACK_E2_NEG
+
+*
+*
+* SOS SINGLES PHYSICS COMMON BLOCKS
+* THESE ARE FILLED BY S_PHYSICS
+*
+*
+ REAL*4 SSP ! Lab momentum of chosen track in GeV/c
+ REAL*4 SSENERGY ! Lab total energy of chosen track in GeV
+ REAL*4 SSCORRP ! electron momentum corrected for eloss
+ REAL*4 SSCORRE ! electron energy corrected for eloss
+ REAL*4 SSDELTA ! Spectrometer delta of chosen track
+ REAL*4 SSTHETA ! Lab Scattering angle in radians
+ REAL*4 SSPHI ! Lab Azymuthal angle in radians
+ REAL*4 SSINPLANE ! In plane scattering angle
+ REAL*4 SSMINV ! Invariant Mass of remaing hadronic system
+ REAL*4 SSZBEAM ! Lab Z coordinate of intersection of beam
+ ! track with spectrometer ray
+ REAL*4 SSDEDX(4) ! DEDX of chosen track in each plane
+ REAL*4 SSBETA ! BETA of chosen track
+ REAL*4 SSTRACK_ET ! Total shower energy of chosen track
+ REAL*4 SSTRACK_PRESHOWER_E ! preshower of chosen track
+ REAL*4 SSTRACK_E1 ! layer 1 shower energy of chosen track
+ REAL*4 SSTRACK_E2 ! layer 2 shower energy of chosen track
+ REAL*4 SSTRACK_E3 ! layer 3 shower energy of chosen track
+ REAL*4 SSTRACK_E4 ! layer 4 shower energy of chosen track
+ REAL*4 SSTIME_AT_FP
+ REAL*4 SSX_FP ! X focal plane position
+ REAL*4 SSY_FP
+ REAL*4 SSXP_FP
+ REAL*4 SSYP_FP
+ REAL*4 SSCHI2PERDEG ! CHI2 per degree of freedom of chosen track.
+ REAL*4 SSX_TAR
+ REAL*4 SSY_TAR
+ REAL*4 SSXP_TAR
+ REAL*4 SSYP_TAR
+ REAL*4 SSBETA_CHISQ
+*
+ REAL*4 SSMASS2 ! Mass squared
+ REAL*4 SST ! invariant t
+ REAL*4 SSU ! invariant u
+ REAL*4 SSELOSS
+ REAL*4 SSQ3 ! Lab frame momentum transfer
+* REAL*4 SSTHETAQ, SSPHIQ ! Direction of q3
+ REAL*4 SSBIGQ2 ! Q**2
+ REAL*4 SSX ! fraction of nucleon p carried by quark
+ REAL*4 SSY ! fraction of lepton''s E lost in lab
+ REAL*4 SSW ! Invariant mass of recoil system
+ REAL*4 SSW2 ! Invariant mass**2 of recoil system
+
+ REAL*4 SSOMEGA
+ REAL*4 SSTHET_GAMMA
+ REAL*4 SSX_bj
+*
+ INTEGER*4 SSNUM_FPTRACK ! Index of focal plane track chosen
+ INTEGER*4 SSNUM_TARTRACK ! Index of target track chosen
+ INTEGER*4 SSID_LUND ! LUND particle ID code -- not yet filled
+ INTEGER*4 SSNFREE_FP
+ INTEGER*4 SSNUM_SCIN_HIT ! # OF SCINTILLATORS ON TRACK
+ INTEGER*4 SSNUM_PMT_HIT ! # OF HODOSCOPE PMTS ON TRACK
+*
+ COMMON/SOS_PHYSICS_R4/
+ & SSP,
+ & SSENERGY,
+ & SSDELTA,
+ & SSTHETA,
+ & SSPHI,
+ & SSINPLANE,
+ & SSMINV,
+ & SSZBEAM,
+ & SSDEDX,
+ & SSBETA,
+ & SSTRACK_ET,
+ & SSTRACK_PRESHOWER_E,
+ & SSTIME_AT_FP,
+ & SSX_FP ,
+ & SSY_FP ,
+ & SSXP_FP ,
+ & SSYP_FP ,
+ & SSCHI2PERDEG ,
+ & SSX_TAR ,
+ & SSY_TAR ,
+ & SSXP_TAR ,
+ & SSYP_TAR ,
+ & SSBETA_CHISQ,
+ & SSMASS2,
+ & SST,
+ & SSU,
+ & SSELOSS,
+ & SSQ3,
+ & SSBIGQ2,
+ & SSX,
+ & SSY,
+ & SSW,
+ & SSW2,
+ & SSTRACK_E1,
+ & SSTRACK_E2,
+ & SSTRACK_E3,
+ & SSTRACK_E4,
+ & SSCORRP,
+ & SSCORRE,
+ & SSOMEGA,
+ & SSTHET_GAMMA,
+ & SSX_bj
+* & SSTHETAQ, SSPHIQ,
+*
+ COMMON/SOS_PHYSICS_I4/
+ & SSNUM_FPTRACK,
+ & SSNUM_TARTRACK,
+ & SSID_LUND,
+ & SSNFREE_FP,
+ & SSNUM_SCIN_HIT,
+ & SSNUM_PMT_HIT
+
+* Non-Hits data with SOS gates or starts.
+* (Energy SUMS, logic timing,...)
+*
+ INTEGER SMAX_MISC_HITS
+ PARAMETER(SMAX_MISC_HITS=100)
+ INTEGER*4 SMISC_TOT_HITS
+ INTEGER*4 SMISC_RAW_ADDR1 ! "Plane" (1=TDC,2=ADC)
+ INTEGER*4 SMISC_RAW_ADDR2 ! "Counter"
+ INTEGER*4 SMISC_RAW_DATA
+ COMMON/S_RAW_MISC/
+ & SMISC_RAW_ADDR1(SMAX_MISC_HITS),
+ & SMISC_RAW_ADDR2(SMAX_MISC_HITS),
+ & SMISC_RAW_DATA(SMAX_MISC_HITS),
+ & SMISC_TOT_HITS
+*
+*
+*
+*******************end: sos_data_structures.cmn*************************
+* Local Variables:
+* mode: fortran
+* fortran-continuation-string: "&"
+* comment-column: 35
+* End:
+
diff --git a/INCLUDE/sos_filenames.cmn b/INCLUDE/sos_filenames.cmn
new file mode 100644
index 0000000..e50419d
--- /dev/null
+++ b/INCLUDE/sos_filenames.cmn
@@ -0,0 +1,43 @@
+******************* begin: sos_filenames.cmn ***********************
+*
+*-Common block with filenames
+* $Log: sos_filenames.cmn,v $
+* Revision 1.5.6.1 2007/05/15 02:53:03 jones
+* Start to Bigcal code
+*
+* Revision 1.5 2005/02/16 20:44:45 saw
+* Add filename for sos root tree
+*
+* Revision 1.4 1996/01/17 15:10:02 cdaq
+* (JRA) Add threshold and pedestal output filenames
+*
+* Revision 1.3 1995/04/06 20:20:19 cdaq
+* (SAW) Add report output filename
+*
+* Revision 1.2 1994/08/15 04:13:08 cdaq
+* (SAW) Add "CTPTYPE=parm" directive for auto generation of CTP reg calls
+*
+* Revision 1.1 1994/06/15 18:12:47 cdaq
+* Initial revision
+*
+* CTPTYPE=parm
+*
+ character*80 s_recon_coeff_filename
+ character*80 s_report_template_filename ! CTP file with sos report
+ character*80 s_report_blockname ! Name of block for sos report template
+ character*80 s_report_output_filename
+ character*80 s_threshold_output_filename
+ character*80 s_pedestal_output_filename
+ character*80 s_tree_filename
+ character*80 s_angle_output_filename
+*
+ common /sos_filenames/
+ $ s_recon_coeff_filename,
+ $ s_report_template_filename,
+ $ s_report_blockname,
+ $ s_report_output_filename,
+ $ s_threshold_output_filename,
+ $ s_pedestal_output_filename,
+ $ s_angle_output_filename,
+ $ s_tree_filename
+*
diff --git a/INCLUDE/sos_geometry.cmn b/INCLUDE/sos_geometry.cmn
new file mode 100644
index 0000000..7428b3a
--- /dev/null
+++ b/INCLUDE/sos_geometry.cmn
@@ -0,0 +1,150 @@
+* sos_geometry.cmn
+*
+* This include file has all the geometrical coefficients for the
+* SOS wire chambers.
+*
+* d.f. geesaman 1 September 1993
+*
+* modifed dfg 14 Feb 1994
+* change SPLANE_PARAM(2,) to sdc_zpos
+* change SPLANE_PARAM(3,) to sdc_alpha_angle
+* change SPLANE_PARAM(4,) to sdc_beta_angle
+* change SPLANE_PARAM(5,) to sdc_gamma_angle
+* change SPLANE_PARAM(6,) to sdc_pitch
+* change SPLANE_PARAM(7,) to sdc_nrwire
+* change SPLANE_PARAM(8,) to sdc_central_wire
+* change SPLANE_PARAM(9,) to sdc_sigma
+* change SPLANE_LABEL to sdc_plane_name
+* add sdc_xcenter
+* sdc_ycenter
+* $Log: sos_geometry.cmn,v $
+* Revision 1.8 1996/09/04 16:28:21 saw
+* (JRA) Make hdc_nrwire integer
+*
+* Revision 1.7 1995/05/22 19:07:14 cdaq
+* (SAW) Split gen_data_data_structures into gen, hms, sos, and coin parts
+*
+* Revision 1.6 1995/01/27 20:21:25 cdaq
+* (JRA) Remove no longer used drift time->distance parameters
+*
+* Revision 1.5 1994/11/22 18:44:30 cdaq
+* (SPB) Brought up to date with hms_geometry.cmn
+* (SAW) Cleaned up ?DC_NUM_CHAMBERS and ?MAX_NUM_CHAMBERS stuff
+*
+* Revision 1.4 1994/08/05 20:36:42 cdaq
+* * (SAW) Add makereg directive with required include files
+* Add "CTPTYPE=parm" directive for auto generation of CTP reg calls
+*
+* Revision 1.3 1994/06/14 03:23:06 cdaq
+* (DFG) Add sdc_plane_time_zero
+*
+* Revision 1.2 1994/03/24 18:37:29 cdaq
+* (DFG) Additional parameters
+*
+* Revision 1.1 1994/02/22 14:47:24 cdaq
+* Initial revision
+*
+* The following include statments must precede the inclusion of this
+* file in each routine that uses it. The *%% syntax is also a
+* directive to makereg to tell it to include the code in the program
+* that it generates.
+*
+*%% include 'sos_data_structures.cmn'
+*
+* CTPTYPE=parm ! Probably don't really want the following registered
+*
+ real*4 szchi,szpsi ! geometrical coefficients defining z-z0
+ real*4 sxchi,sxpsi ! x and y for each wire plane.
+ real*4 sychi,sypsi
+*
+ real*4 sz0 ! z coordinate of intersection of chamber with
+ ! z axis
+ real*4 spsi0,schi0,sphi0 ! psi, chi and phi coordinates where a
+ ! chamber normal passing through the origin
+ ! intersects the chamber. Used in stub fits
+
+ real*4 sstubcoef ! coefficents used in stub fits
+ ! note these contain one power of sigma
+
+ real*4 stanbeta,ssinbeta,scosbeta
+*
+ real*4 sxsp ! coefficents used in space point fits.
+ real*4 sysp
+*
+ real*8 splane_coeff ! coefficients used in final track fit
+*
+ integer*4 SNUM_PLANE_COEFF ! number of plane track fit coefficients
+ parameter (SNUM_PLANE_COEFF=9)
+ integer*4 SNUM_RAY_PARAM ! number of ray parameters
+ parameter (SNUM_RAY_PARAM=4)
+*
+ common/SOS_GEOMETRY/
+ & splane_coeff(SNUM_PLANE_COEFF,SMAX_NUM_DC_PLANES),
+ & szpsi(SMAX_NUM_DC_PLANES),szchi(SMAX_NUM_DC_PLANES),
+ & sxpsi(SMAX_NUM_DC_PLANES),sxchi(SMAX_NUM_DC_PLANES),
+ & sypsi(SMAX_NUM_DC_PLANES),sychi(SMAX_NUM_DC_PLANES),
+ & sz0(SMAX_NUM_DC_PLANES),spsi0(SMAX_NUM_DC_PLANES),
+ & schi0(SMAX_NUM_DC_PLANES),sphi0(SMAX_NUM_DC_PLANES),
+ & sstubcoef(SMAX_NUM_DC_PLANES,SNUM_RAY_PARAM),
+ & sxsp(SMAX_NUM_DC_PLANES),sysp(SMAX_NUM_DC_PLANES),
+ & stanbeta(SMAX_NUM_DC_PLANES),ssinbeta(SMAX_NUM_DC_PLANES),
+ & scosbeta(SMAX_NUM_DC_PLANES)
+*
+ real*4 sdc_zpos
+ real*4 sdc_alpha_angle
+ real*4 sdc_beta_angle
+ real*4 sdc_gamma_angle
+ real*4 sdc_pitch
+ integer*4 sdc_nrwire
+ real*4 sdc_central_wire
+ real*4 sdc_sigma
+ real*4 sdc_xcenter
+ real*4 sdc_ycenter
+ real*4 sdc_center
+* real*4 SPLANE_PARAM
+ integer*4 sdc_chamber_planes
+ character*16 sdc_plane_name
+ common/SOS_PLANE_PARAMETERS/
+ & sdc_zpos(SMAX_NUM_DC_PLANES),
+ & sdc_alpha_angle(SMAX_NUM_DC_PLANES),
+ & sdc_beta_angle(SMAX_NUM_DC_PLANES),
+ & sdc_gamma_angle(SMAX_NUM_DC_PLANES),
+ & sdc_pitch(SMAX_NUM_DC_PLANES),
+ & sdc_central_wire(SMAX_NUM_DC_PLANES),
+ & sdc_nrwire(SMAX_NUM_DC_PLANES),
+ & sdc_sigma(SMAX_NUM_DC_PLANES),
+ & sdc_xcenter(SMAX_NUM_CHAMBERS),
+ & sdc_ycenter(SMAX_NUM_CHAMBERS),
+ & sdc_chamber_planes(SMAX_NUM_DC_PLANES),
+ & sdc_plane_name(SMAX_NUM_DC_PLANES),
+ & sdc_center(SMAX_NUM_DC_PLANES)
+
+ real*4 slocrayzt
+ parameter (slocrayzt=0.)
+*
+* CTPTYPE=parm
+*
+* parameter file variables. Separate by type to make it easy to add
+* at the end
+* REAL*4
+*
+* real*4 sdrift_velocity ! sos drift velocity in cm/ns
+ real*4 sdc_tdc_time_per_channel
+ real*4 sdc_1_zpos
+ real*4 sdc_2_zpos
+ real*4 sdc_3_zpos
+ real*4 sdc_plane_time_zero
+ common/SOS_CHAMBER_READOUT_REAL/
+* & sdrift_velocity,
+ & sdc_tdc_time_per_channel,
+ & sdc_1_zpos,
+ & sdc_2_zpos,
+ & sdc_3_zpos,
+ & sdc_plane_time_zero(SMAX_NUM_DC_PLANES)
+*
+* INTEGER*4
+*
+ integer*4 sdc_wire_counting ! readout numbering order
+*
+ common/SOS_CHAMBER_READOUT_INT/
+ & sdc_wire_counting(SMAX_NUM_DC_PLANES)
diff --git a/INCLUDE/sos_id_histid.cmn b/INCLUDE/sos_id_histid.cmn
new file mode 100644
index 0000000..5718edd
--- /dev/null
+++ b/INCLUDE/sos_id_histid.cmn
@@ -0,0 +1,119 @@
+*_______________________________________________________________________
+* sos_id_histid.cmn
+*
+* This common block contains the HBOOK histogram id numbers
+* for all sos particle id histograms in which direct hfill
+* calls are made.
+*
+* It also contains the paramter flags to turn on and off histograming
+* of each of the hard coded blocks.
+*
+* Created 9 April 1994 D. F. Geesaman
+*
+* $Log: sos_id_histid.cmn,v $
+* Revision 1.11 1999/02/23 19:20:42 csa
+* (JRA) Add sidscindpos_pid, cleanup
+*
+* Revision 1.10 1999/02/03 21:13:34 saw
+* Code for new Shower counter tubes
+*
+* Revision 1.9 1996/09/04 16:28:58 saw
+* (JRA) Add sidmisctdcs
+*
+* Revision 1.8 1996/01/17 15:09:34 cdaq
+* (JRA) Add sidscintimes histogram
+*
+* Revision 1.7 1995/09/01 13:02:48 cdaq
+* (JRA) Add dpos histid's
+*
+* Revision 1.6 1995/08/11 16:31:11 cdaq
+* (JRA) Add dpos (track pos - hit pos) histograms
+*
+* Revision 1.5 1995/07/28 14:27:26 cdaq
+* (JRA) Add sidsum histogram id holders
+*
+* Revision 1.4 1995/05/22 19:07:42 cdaq
+* (SAW) Split gen_data_data_structures into gen, hms, sos, and coin parts
+*
+* Revision 1.3 1995/05/12 12:23:46 cdaq
+* (JRA) Modify/add user histograms
+*
+* Revision 1.2 1994/08/05 21:05:04 cdaq
+* (SAW) Add makereg directive with required include files
+* Add "CTPTYPE=parm" directive for auto generation of CTP reg calls
+*
+* Revision 1.1 1994/04/12 21:16:27 cdaq
+* Initial revision
+*
+*%% include 'sos_data_structures.cmn'
+*%% include 'sos_scin_parms.cmn'
+*
+* The following don't need to be registered??
+* CTPTYPE=parm
+ integer*4 sidscinrawtothits
+ integer*4 sidscinplane
+ integer*4 sidscinallpostdc(SNUM_SCIN_PLANES)
+ integer*4 sidscinallnegtdc(SNUM_SCIN_PLANES)
+ integer*4 sidscinallposadc(SNUM_SCIN_PLANES)
+ integer*4 sidscinallnegadc(SNUM_SCIN_PLANES)
+ integer*4 sidscincounters(SNUM_SCIN_PLANES)
+ integer*4 sidscinposadc(SNUM_SCIN_PLANES,snum_scin_elements)
+ integer*4 sidscinnegadc(SNUM_SCIN_PLANES,snum_scin_elements)
+ integer*4 sidscinpostdc(SNUM_SCIN_PLANES,snum_scin_elements)
+ integer*4 sidscinnegtdc(SNUM_SCIN_PLANES,snum_scin_elements)
+ integer*4 sidscinalltimes
+ integer*4 sidscindpos(SNUM_SCIN_PLANES)
+ integer*4 sidscindpos_pid(SNUM_SCIN_PLANES)
+ integer*4 sidsumposadc(SNUM_SCIN_PLANES)
+ integer*4 sidsumnegadc(SNUM_SCIN_PLANES)
+ integer*4 sidsumpostdc(SNUM_SCIN_PLANES)
+ integer*4 sidsumnegtdc(SNUM_SCIN_PLANES)
+ integer*4 sidscintimes
+
+ integer*4 sidcalplane
+ integer*4 sidcalhits(SMAX_CAL_COLUMNS)
+ integer*4 sidcalposhits(SMAX_CAL_COLUMNS)
+ integer*4 sidcalneghits(SMAX_CAL_COLUMNS)
+ integer*4 sidcalsumadc
+ integer*4 sidcaldpos
+
+ integer*4 siddcdposx,siddcdposy,siddcdposxp,siddcdposyp
+ integer*4 sidmisctdcs
+*
+ common/sos_id_histid/
+ & sidscinrawtothits,
+ & sidscinplane,
+ & sidscinallpostdc,
+ & sidscinallnegtdc,
+ & sidscinallposadc,
+ & sidscinallnegadc,
+ & sidscincounters,
+ & sidscinposadc,
+ & sidscinnegadc,
+ & sidscinpostdc,
+ & sidscinnegtdc,
+ & sidscinalltimes,
+ & sidscintimes,
+ & sidsumposadc,
+ & sidsumnegadc,
+ & sidsumpostdc,
+ & sidsumnegtdc,
+ & sidscindpos,
+ & sidcalplane,
+ & sidcalhits,
+ & sidcalsumadc,
+ & sidcalposhits,
+ & sidcalneghits,
+ & sidcaldpos,
+ & siddcdposx,siddcdposy,siddcdposxp,siddcdposyp,
+ & sidmisctdcs,
+ & sidscindpos_pid
+
+*
+* CTPTYPE=parm
+*
+* flags to turn on (.eq.1) or off (.eq. 0) hard coded histograms
+ integer*4 sturnon_scin_raw_hist
+*
+ common/sos_id_hist_flags/
+ & sturnon_scin_raw_hist
diff --git a/INCLUDE/sos_lucite_parms.cmn b/INCLUDE/sos_lucite_parms.cmn
new file mode 100644
index 0000000..9da55d1
--- /dev/null
+++ b/INCLUDE/sos_lucite_parms.cmn
@@ -0,0 +1,39 @@
+*
+* $Log: sos_lucite_parms.cmn,v $
+* Revision 1.1 1996/10/02 18:58:07 saw
+* Initial revision
+*
+*%% include 'sos_data_structures.cmn'
+
+*
+* CTPTYPE = parm
+*
+ real*4 sluc_pos_gain(smax_luc_hits)
+ real*4 sluc_neg_gain(smax_luc_hits)
+
+*
+* CTPTYPE = event
+*
+ integer*4 sluc_tot_good_hits
+ integer*4 sluc_rawadc_neg(smax_luc_hits)
+ integer*4 sluc_rawadc_pos(smax_luc_hits)
+ real*4 sluc_pos_npe(smax_luc_hits)
+ real*4 sluc_neg_npe(smax_luc_hits)
+ real*4 sluc_sum(smax_luc_hits)
+ real*4 sluc_neg_npe_sum
+ real*4 sluc_pos_npe_sum
+ real*4 sluc_npe_sum
+
+
+ common /luci_calib/
+ & sluc_tot_good_hits,
+ & sluc_pos_npe,
+ & sluc_neg_npe,
+ & sluc_pos_gain,
+ & sluc_neg_gain,
+ & sluc_neg_npe_sum,
+ & sluc_pos_npe_sum,
+ & sluc_npe_sum,
+ & sluc_sum,
+ & sluc_rawadc_neg,
+ & sluc_rawadc_pos
diff --git a/INCLUDE/sos_one_ev.par b/INCLUDE/sos_one_ev.par
new file mode 100644
index 0000000..e79050e
--- /dev/null
+++ b/INCLUDE/sos_one_ev.par
@@ -0,0 +1,52 @@
+********************************************************************************
+*
+* include file one_ev_disp.inc
+*
+* contains all information needed for the one event display
+*
+* Modified from the HMS version, hms_one_ev.par, March 1995 by
+* Derek van Westrum (vanwestr@cebaf.gov)
+*
+* $Log: sos_one_ev.par,v $
+* Revision 1.1 1995/07/28 20:27:00 cdaq
+* Initial revision
+*
+********************************************************************************
+
+ real*4 SHUT_WIDTH,SHUT_HEIGHT
+ real*4 CHAMBER_WIDTH,CHAMBER_HEIGHT
+ real*4 LOWER_CHAMBER_X_OFFSET,LOWER_CHAMBER_Y_OFFSET
+ real*4 UPPER_CHAMBER_X_OFFSET,UPPER_CHAMBER_Y_OFFSET
+ real*4 HODO_THICKNESS
+ real*4 HODO_LOWER_X_OFFSET,HODO_LOWER_Y_OFFSET
+ real*4 HODO_UPPER_X_OFFSET,HODO_UPPER_Y_OFFSET
+ real*4 SHOWER_X_OFFSET,SHOWER_Y_OFFSET
+ integer*4 LOWER_HODO_X_PADDLES,LOWER_HODO_Y_PADDLES
+ integer*4 UPPER_HODO_X_PADDLES,UPPER_HODO_Y_PADDLES
+ real*4 zoffset
+ parameter (zoffset = 100.)
+
+ parameter (SHUT_WIDTH = 100.) ! full width of the det. hut
+ parameter (SHUT_HEIGHT = 800.) ! full height of the det. hut
+
+ parameter (CHAMBER_WIDTH = 40.)
+ parameter (CHAMBER_HEIGHT = 70.)
+ parameter (LOWER_CHAMBER_X_OFFSET = 0.) ! offset
+ parameter (LOWER_CHAMBER_Y_OFFSET = 0.) ! offset
+ parameter (UPPER_CHAMBER_X_OFFSET = 0.) ! offset
+ parameter (UPPER_CHAMBER_Y_OFFSET = 0.) ! offset
+
+ parameter (LOWER_HODO_X_PADDLES = 9) ! # of paddles in X direction
+ parameter (LOWER_HODO_Y_PADDLES = 9) ! # of paddles in Y direction
+ parameter (UPPER_HODO_X_PADDLES = 16) ! # of paddles in X direction
+ parameter (UPPER_HODO_Y_PADDLES = 9) ! # of paddles in Y direction
+
+ parameter (HODO_THICKNESS = 1.0) ! full thickness of hodoscope
+
+ parameter (HODO_LOWER_X_OFFSET = 0.) ! offset
+ parameter (HODO_LOWER_Y_OFFSET = 0.) ! offset
+ parameter (HODO_UPPER_X_OFFSET = 0.) ! offset
+ parameter (HODO_UPPER_Y_OFFSET = 0.) ! offset
+
+ parameter (SHOWER_X_OFFSET = 0.) ! offset
+ parameter (SHOWER_Y_OFFSET = 0.) ! offset
diff --git a/INCLUDE/sos_pedestals.cmn b/INCLUDE/sos_pedestals.cmn
new file mode 100644
index 0000000..936c473
--- /dev/null
+++ b/INCLUDE/sos_pedestals.cmn
@@ -0,0 +1,290 @@
+* sos_pedestals.cmn - counters used for calculating pedestals from the set
+* of pedestal events at the beginning of each run.
+*
+* $Log: sos_pedestals.cmn,v $
+* Revision 1.9 1999/02/23 19:21:23 csa
+* (JRA) Add vars for improved pedestal calcs
+*
+* Revision 1.8 1999/01/29 17:34:23 saw
+* Add variables for second tubes on shower counter
+*
+* Revision 1.7 1996/11/19 18:49:39 saw
+* (WH) Add data structures for Lucite counter
+*
+* Revision 1.6 1996/09/04 16:30:06 saw
+* (JRA) Add thresholds for aerogel
+*
+* Revision 1.5 1996/04/30 14:02:09 saw
+* (JRA) Make aerogel parameters PARM type
+*
+* Revision 1.4 1996/01/17 15:09:10 cdaq
+* (JRA) Add "_new_" pedestal variables
+*
+* Revision 1.3 1995/07/28 14:38:58 cdaq
+* (JRA) Add shodo_all_sig_pos/neg, pedestall stuff
+*
+* Revision 1.2 1995/05/22 19:09:30 cdaq
+* (SAW) Split gen_data_data_structures into gen, hms, sos, and coin parts
+* Fix conflicting common block names. Add Cerenkov and Aerogel pedestals
+*
+* Revision 1.1 1995/04/06 20:18:01 cdaq
+* Initial revision
+*
+*
+* The following include statments must precede the inclusion of this
+* file in each routine that uses it. The *%% syntax is also a
+* directive to makereg to tell it to include the code in the program
+* that it generates.
+*
+*%% include 'sos_data_structures.cmn'
+*
+* CTPTYPE=event
+*
+*
+* HODOSCOPE PEDESTALS
+* replace sscin_all_ped_pos with float(shodo_pos_ped_sum/shodo_pos_ped_num)
+* if shodo_pos_ped_num > shodo_min_peds.
+*
+ integer*4 shodo_pos_ped_sum2(snum_scin_planes,snum_scin_elements)
+ integer*4 shodo_neg_ped_sum2(snum_scin_planes,snum_scin_elements)
+ integer*4 shodo_pos_ped_sum(snum_scin_planes,snum_scin_elements)
+ integer*4 shodo_neg_ped_sum(snum_scin_planes,snum_scin_elements)
+ integer*4 shodo_pos_ped_num(snum_scin_planes,snum_scin_elements)
+ integer*4 shodo_neg_ped_num(snum_scin_planes,snum_scin_elements)
+ integer*4 shodo_num_ped_changes
+ integer*4 shodo_changed_plane(2*smax_all_scin_hits)
+ integer*4 shodo_changed_element(2*smax_all_scin_hits)
+ integer*4 shodo_changed_sign(2*smax_all_scin_hits)
+ real*4 shodo_ped_change(2*smax_all_scin_hits)
+ real*4 shodo_new_sig_pos(snum_scin_planes,snum_scin_elements)
+ real*4 shodo_new_sig_neg(snum_scin_planes,snum_scin_elements)
+ real*4 shodo_new_ped_pos(snum_scin_planes,snum_scin_elements)
+ real*4 shodo_new_ped_neg(snum_scin_planes,snum_scin_elements)
+*
+* CTPTYPE=parm
+*
+ integer*4 shodo_min_peds
+ integer*4 shodo_pos_ped_limit(snum_scin_planes,snum_scin_elements)
+ integer*4 shodo_neg_ped_limit(snum_scin_planes,snum_scin_elements)
+*
+ common/sos_scin_pedestals/
+ & shodo_pos_ped_sum2, !sum of squares
+ & shodo_neg_ped_sum2, !sum of squares
+ & shodo_pos_ped_sum, !sum of peds
+ & shodo_neg_ped_sum, !sum of peds
+ & shodo_pos_ped_num, !number of peds
+ & shodo_neg_ped_num, !number of peds
+ & shodo_pos_ped_limit, !max. allowed ped (reject hits during ped trig)
+ & shodo_neg_ped_limit, !max. allowed ped
+ & shodo_min_peds, !# of peds required to override default pedestals
+ & shodo_new_sig_pos,
+ & shodo_new_sig_neg,
+ & shodo_new_ped_pos,
+ & shodo_new_ped_neg,
+ & shodo_num_ped_changes,!# of peds with 2 sigma change from param file.
+ & shodo_changed_plane,
+ & shodo_changed_element,
+ & shodo_changed_sign, !1=pos,2=neg
+ & shodo_ped_change
+*
+*
+* CALORIMETER PEDESTALS
+* replace scal_ped_mean with float(scal_ped_sum/scal_ped_num),
+* scal_ped_rms with (appropriate formula),
+* and scal_threshold with (something like) min(10.,3.*scal_ped_rms)
+* if scal_num > scal_min_peds.
+*
+*
+* CTPTYPE=event
+*
+ integer*4 scal_pos_ped_sum2(smax_cal_blocks)
+ integer*4 scal_neg_ped_sum2(smax_cal_blocks)
+ integer*4 scal_pos_ped_sum(smax_cal_blocks)
+ integer*4 scal_neg_ped_sum(smax_cal_blocks)
+ integer*4 scal_pos_ped_num(smax_cal_blocks)
+ integer*4 scal_neg_ped_num(smax_cal_blocks)
+
+ integer*4 scal_num_ped_changes
+ integer*4 scal_changed_block(2*smax_cal_blocks)
+ integer*4 scal_changed_sign(2*smax_cal_blocks) ! 1=pos, 2=neg
+ real*4 scal_ped_change(2*smax_cal_blocks)
+
+ real*4 scal_new_ped_pos(2*smax_cal_blocks)
+ real*4 scal_new_ped_neg(2*smax_cal_blocks)
+ real*4 scal_new_rms_pos(2*smax_cal_blocks)
+ real*4 scal_new_rms_neg(2*smax_cal_blocks)
+*
+* CTPTYPE=parm
+*
+ integer*4 scal_min_peds
+ integer*4 scal_pos_ped_limit(smax_cal_blocks)
+ integer*4 scal_neg_ped_limit(smax_cal_blocks)
+*
+ common/sos_cal_ped_stats/
+ & scal_pos_ped_sum2, !sum of squares
+ & scal_neg_ped_sum2, !sum of squares
+ & scal_pos_ped_sum, !sum of peds
+ & scal_neg_ped_sum, !sum of peds
+ & scal_pos_ped_num, !number of peds
+ & scal_neg_ped_num, !number of peds
+ & scal_pos_ped_limit, !max. allowed ped (reject hits during ped trig)
+ & scal_neg_ped_limit, !max. allowed ped
+ & scal_min_peds, !# of peds required to override default pedestals
+ & scal_new_ped_pos, !(new) calculated pedestals.
+ & scal_new_ped_neg, !(new) calculated pedestals.
+ & scal_new_rms_pos, !(new) calculated rms.
+ & scal_new_rms_neg, !(new) calculated rms.
+ & scal_num_ped_changes,!# of peds with 2 sigma changes from param file
+ & scal_changed_block,
+ & scal_changed_sign, ! 1=pos, 2=neg
+ & scal_ped_change
+*
+* GAS CERENKOV PEDESTALS
+* replace scer_ped with float(scer_ped_sum/scer_ped_num),
+* scer_ped_rms with (appropriate formula),
+* and scer_width with (something like) min(10.,3.*scer_ped_rms)
+* scer_ped_rms with (appropriate formula),if scer_num > scer_min_peds.
+*
+* CTPTYPE=event
+*
+ integer*4 scer_ped_sum2(smax_cer_hits)
+ integer*4 scer_ped_sum(smax_cer_hits)
+ integer*4 scer_ped_num(smax_cer_hits)
+ integer*4 scer_num_ped_changes
+ integer*4 scer_changed_tube(smax_cer_hits)
+ real*4 scer_ped_change(smax_cer_hits)
+ real*4 scer_new_ped(smax_cer_hits)
+ real*4 scer_new_rms(smax_cer_hits)
+*
+* CTPTYPE=parm
+*
+ integer*4 scer_min_peds
+ integer*4 scer_ped_limit(smax_cer_hits)
+*
+ common/sos_cer_pedestals/
+ & scer_ped_sum2, !sum of squares
+ & scer_ped_sum, !sum of peds
+ & scer_ped_num, !number of peds
+ & scer_ped_limit, !max. allowed ped (reject hits during ped trig)
+ & scer_min_peds, !# of peds required to override default pedestals
+ & scer_new_ped,
+ & scer_new_rms,
+ & scer_num_ped_changes,!# of peds with 2 sigma changes from param file
+ & scer_changed_tube, !list of changed tubes
+ & scer_ped_change !change in pedestal
+
+*
+*
+* AEROGEL CERENKOV PEDESTALS
+* replace saer_ped_mean with float(saer_ped_sum/saer_ped_num),
+* saer_ped_rms with (appropriate formula),
+* and saer_threshold with (something like) min(10.,3.*saer_ped_rms)
+* saer_ped_rms with (appropriate formula),if saer_num > saer_min_peds.
+*
+*
+* CTPTYPE=event
+*
+ integer*4 saer_pos_ped_sum2(smax_aer_hits)
+ integer*4 saer_neg_ped_sum2(smax_aer_hits)
+ integer*4 saer_pos_ped_sum(smax_aer_hits)
+ integer*4 saer_neg_ped_sum(smax_aer_hits)
+ integer*4 saer_pos_ped_num(smax_aer_hits)
+ integer*4 saer_neg_ped_num(smax_aer_hits)
+*
+* CTPTYPE=parm
+*
+ integer*4 saer_min_peds
+ real*4 saer_pos_ped_mean(smax_aer_hits)
+ real*4 saer_neg_ped_mean(smax_aer_hits)
+ real*4 saer_pos_ped_rms(smax_aer_hits)
+ real*4 saer_neg_ped_rms(smax_aer_hits)
+ real*4 saer_pos_threshold(smax_aer_hits)
+ real*4 saer_neg_threshold(smax_aer_hits)
+ integer*4 saer_pos_adc_threshold(smax_aer_hits)
+ integer*4 saer_neg_adc_threshold(smax_aer_hits)
+ integer*4 saer_pos_ped_limit(smax_aer_hits)
+ integer*4 saer_neg_ped_limit(smax_aer_hits)
+*
+ common/sos_aero_pedestals/
+ & saer_pos_ped_sum2, !sum of squares
+ & saer_neg_ped_sum2, !sum of squares
+ & saer_pos_ped_sum, !sum of peds
+ & saer_neg_ped_sum, !sum of peds
+ & saer_pos_ped_num, !number of peds
+ & saer_neg_ped_num, !number of peds
+ & saer_pos_ped_limit, !max. allowed ped (reject hits during ped trig)
+ & saer_neg_ped_limit, !max. allowed ped
+ & saer_min_peds, !# of peds required to override default pedestals
+ & saer_pos_ped_mean, !calculated pedestal value
+ & saer_neg_ped_mean,
+ & saer_pos_ped_rms, !calculated pedestal width
+ & saer_neg_ped_rms,
+ & saer_pos_threshold,
+ & saer_neg_threshold,
+ & saer_pos_adc_threshold,
+ & saer_neg_adc_threshold
+
+
+*
+*
+* LUCITE CERENKOV PEDESTALS
+*
+*
+* CTPTYPE=event
+*
+ integer*4 sluc_pos_ped_sum2(smax_luc_hits)
+ integer*4 sluc_neg_ped_sum2(smax_luc_hits)
+ integer*4 sluc_pos_ped_sum(smax_luc_hits)
+ integer*4 sluc_neg_ped_sum(smax_luc_hits)
+ integer*4 sluc_pos_ped_num(smax_luc_hits)
+ integer*4 sluc_neg_ped_num(smax_luc_hits)
+*
+* CTPTYPE=parm
+*
+ integer*4 sluc_min_peds
+ real*4 sluc_pos_ped_mean(smax_luc_hits)
+ real*4 sluc_neg_ped_mean(smax_luc_hits)
+ real*4 sluc_pos_ped_rms(smax_luc_hits)
+ real*4 sluc_neg_ped_rms(smax_luc_hits)
+* real*4 sluc_pos_threshold(smax_luc_hits)
+* real*4 sluc_neg_threshold(smax_luc_hits)
+ integer*4 sluc_pos_adc_threshold(smax_luc_hits)
+ integer*4 sluc_neg_adc_threshold(smax_luc_hits)
+ integer*4 sluc_pos_ped_limit(smax_luc_hits)
+ integer*4 sluc_neg_ped_limit(smax_luc_hits)
+*
+ common/sos_luci_pedestals/
+ & sluc_pos_ped_sum2, !sum of squares
+ & sluc_neg_ped_sum2, !sum of squares
+ & sluc_pos_ped_sum, !sum of peds
+ & sluc_neg_ped_sum, !sum of peds
+ & sluc_pos_ped_num, !number of peds
+ & sluc_neg_ped_num, !number of peds
+ & sluc_pos_ped_limit, !max. allowed ped (reject hits during ped trig)
+ & sluc_neg_ped_limit, !max. allowed ped
+ & sluc_min_peds, !# of peds required to override default pedestals
+ & sluc_pos_ped_mean, !calculated pedestal value
+ & sluc_neg_ped_mean,
+ & sluc_pos_ped_rms, !calculated pedestal width
+ & sluc_neg_ped_rms,
+* & sluc_pos_threshold,
+* & sluc_neg_threshold,
+ & sluc_pos_adc_threshold,
+ & sluc_neg_adc_threshold
+
+
+*
+* CTPTYPE=event
+*
+ real*4 shodo_new_threshold_pos(snum_scin_planes,snum_scin_elements)
+ real*4 shodo_new_threshold_neg(snum_scin_planes,snum_scin_elements)
+ real*4 scal_new_adc_threshold_pos(smax_cal_blocks)
+ real*4 scal_new_adc_threshold_neg(smax_cal_blocks)
+ real*4 scer_new_adc_threshold(smax_cer_hits)
+*
+ common/sos_adc_thresholds/
+ & shodo_new_threshold_pos,
+ & shodo_new_threshold_neg,
+ & scal_new_adc_threshold_pos,
+ & scal_new_adc_threshold_neg,
+ & scer_new_adc_threshold
diff --git a/INCLUDE/sos_physics_sing.cmn b/INCLUDE/sos_physics_sing.cmn
new file mode 100644
index 0000000..3cf97d4
--- /dev/null
+++ b/INCLUDE/sos_physics_sing.cmn
@@ -0,0 +1,222 @@
+* This include file contains all the variables required for s_physics
+* $Log: sos_physics_sing.cmn,v $
+* Revision 1.11 2005/03/23 16:35:04 jones
+* Add new code s_select_best_track_prune.f and h_select_best_track_prune.f (P Bosted)
+*
+* Revision 1.10 2005/03/23 16:16:28 jones
+* Add variable ssel_using_scin . Set ssel_using_scin = 1 in param files and new code
+* used to select best track for SOS.
+*
+* Revision 1.9 2003/09/08 21:03:18 jones
+* Change s_phicentral_offset to s_oopcentral_offset (mkj)
+*
+* Revision 1.8 2002/09/24 20:29:37 jones
+* add parameters sphicentral_offset, spcentral_offset,
+* sthetacentral_offset
+*
+* Revision 1.7 1999/02/23 19:21:59 csa
+* Add some physics vars
+*
+* Revision 1.6 1996/09/04 16:30:39 saw
+* (JRA,DD) Add some egamma variables and some angle/momentum offset
+* variables
+*
+* Revision 1.5 1996/04/30 14:03:28 saw
+* (JRA) Add path length, rf, and photodisintigration variables
+*
+* Revision 1.4 1995/09/01 13:03:47 cdaq
+* (JRA) Add cerenkov position variables
+*
+* Revision 1.3 1995/03/13 19:17:02 cdaq
+* (SAW) Bring up to date with hms_physics_sing.cmn
+*
+* Revision 1.2 1994/08/05 20:44:48 cdaq
+* (SAW) Add "CTPTYPE=event,parm" directive for auto generation of CTP reg calls
+*
+* Revision 1.1 1994/06/14 03:25:37 cdaq
+* Initial revision
+*
+* CTPTYPE=event
+*
+* Event varaibles to calculate
+ REAL*4 SSELAS_COR ! Difference between momentum measured
+ ! by tracking and elastic kinematics
+ COMMON/SOS_PHYSICS_SING/
+ & SSELAS_COR
+*
+* CTPTYPE=parm
+*
+* initializiation paramters
+ REAL*4 SPHYSICSA ! Coefficients of p3 in elastic cal
+ REAL*4 SPHYSICSB !
+ REAL*4 SPHYSICAB2 !
+ REAL*4 SPHYSICSM3B !
+ REAL*4 COSSTHETAS ! COS(STHETA_LAB)
+ REAL*4 SINSTHETAS ! SIN(STHETA_LAB)
+ COMMON/SOS_PHYSICS_PARAM_R4/
+ & SPHYSICSA,
+ & SPHYSICSB,
+ & SPHYSICAB2,
+ & SPHYSICSM3B,
+ & COSSTHETAS,
+ & SINSTHETAS
+*
+* Parameters that select the best track. Note these should be
+* loose cuts to make sure we select one track. The final
+* tighter cuts should be made with tests.
+ REAL*4 ssel_chi2_fpperdegmax ! Maximun chi2 per degree of freedom
+ ! at the focal plane
+ REAL*4 ssel_dedx1min ! Minimum dedx in chamber 1
+ REAL*4 ssel_dedx1max ! Maximum dedx in chamber 1
+ REAL*4 ssel_betamin ! Minimum beta
+ REAL*4 ssel_betamax ! Maximum beta
+ REAL*4 ssel_etmin ! Minimum track et
+ REAL*4 ssel_etmax ! Maximum track et
+ INTEGER*4 ssel_ndegreesmin ! Minimum number of degrees of freedom
+! following parameters are only used if pruning is selected
+! see the code h_select_best_track_prune.f for meaning
+! Note: all these limits are for abs(quantity) except df, chibeta
+ real*4 sprune_xp ! Maximum xp angle in radians
+ real*4 sprune_yp ! maximum yp angle in radianss
+ real*4 sprune_ytar ! maximum ytar in cm
+ real*4 sprune_delta ! Maximum delta in percent
+ real*4 sprune_beta ! Maximum beta-1
+ integer sprune_df ! Minimum d.f. for track
+ real*4 sprune_chibeta ! Maximum beta chisq
+ real*4 sprune_fptime ! Maximum fptime - nominal
+ integer sprune_npmt ! Minimum PMTs for track
+
+ INTEGER*4 ssel_using_scin ! =1 select best track using scin info
+ ! = 0 select best track suing just chi2
+ INTEGER*4 ssel_using_prune ! =1 select best track using new
+ ! routine and prune values
+ ! = 0 then using_scin applies
+*
+ COMMON/sos_chose_one_track_r4/
+ & ssel_chi2_fpperdegmax,
+ & ssel_dedx1min,
+ & ssel_dedx1max,
+ & ssel_betamin,
+ & ssel_betamax,
+ & ssel_etmin,
+ & ssel_etmax,
+ & sprune_xp,
+ & sprune_yp,
+ & sprune_ytar,
+ & sprune_delta,
+ & sprune_beta,
+ & sprune_df,
+ & sprune_chibeta,
+ & sprune_npmt,
+ & sprune_fptime
+*
+ COMMON/sos_chose_one_track_i4/
+ & ssel_ndegreesmin,
+ & ssel_using_scin,
+ & ssel_using_prune
+
+*
+* CTPTYPE=event
+*
+ real*4 ssx_dc1, ssy_dc1
+ real*4 ssx_dc2, ssy_dc2
+ real*4 ssx_s1, ssy_s1
+ real*4 ssx_cer, ssy_cer
+ real*4 ssx_s2, ssy_s2
+ real*4 ssx_cal, ssy_cal
+ integer*4 ssscin_elem_hit(4)
+
+ COMMON/sos_tmp_stuff/
+ & ssx_dc1, ssy_dc1,
+ & ssx_dc2, ssy_dc2,
+ & ssx_s1, ssy_s1,
+ & ssx_cer, ssy_cer,
+ & ssx_s2, ssy_s2,
+ & ssx_cal, ssy_cal,
+ & ssscin_elem_hit
+
+*
+* CTPTYPE=parm
+*
+ real*4 spathlength_central
+*
+* CTPTYPE=event
+*
+ real*4 ssbeta_p
+ real*4 sspathlength
+ real*4 sspath_cor
+ real*4 ssrftime
+
+ COMMON/sos_timing_stuff/
+ & spathlength_central,
+ & ssbeta_p,
+ & sspathlength,
+ & sspath_cor,
+ & ssrftime
+*
+* CTPTYPE=event
+*
+ real*4 sqx,sqy,sqz,sqabs
+ real*4 sinvmass
+
+ common/sos_physics_quantaties/
+ & sqx,sqy,sqz,sqabs,
+ & sinvmass
+
+
+c------------------------------------------------------------------
+c For photodisintegration calculations.
+c M.Miller, NPL UIUC, 10-Sept-1995, miller5@uiuc.edu
+*
+* CTPTYPE=parm
+*
+ real*4 sphoto_mtarget ! Mass of target [Gev/c^2]
+ real*4 sphoto_mrecoil ! Mass of recoil system [Gev/c^2]
+*
+* CTPTYPE=event
+*
+ real*4 ssegamma
+ real*4 ssegamma_p
+
+ common /sos_photo_param/
+ & sphoto_mtarget,
+ & sphoto_mrecoil,
+ & ssegamma,
+ & ssegamma_p
+
+*
+* CTPTYPE=parm
+*
+c D.Dutta, 24th-Apr-1996
+
+ real*4 sdelta_offset ! hms delta offset
+ real*4 stheta_offset ! hms scatteringangel offset
+ real*4 sphi_offset
+ real*4 smomentum_factor ! multiplier for the hms momentum
+c J.Volmer, 9th-Jul-1999
+ real*4 spcentral_offset ! sos central momentum offset
+ real*4 sthetacentral_offset ! sos central angle offset
+ real*4 s_oopcentral_offset ! sos central oop angle offset
+
+ COMMON /sos_offsets/
+ & sdelta_offset,
+ & stheta_offset,
+ & sphi_offset,
+ & smomentum_factor,
+ & spcentral_offset,
+ & sthetacentral_offset,
+ & s_oopcentral_offset
+
+*
+* CTPTYPE=event
+*
+ real*4 ss_qvec(4)
+ real*4 ss_kpvec(4)
+ real*4 ss_kvec(4)
+ real*4 ss_tvec(4)
+
+ COMMON/ss_vectors/
+ & ss_qvec,
+ & ss_kpvec,
+ & ss_kvec,
+ & ss_tvec
diff --git a/INCLUDE/sos_recon_elements.cmn b/INCLUDE/sos_recon_elements.cmn
new file mode 100644
index 0000000..014a3be
--- /dev/null
+++ b/INCLUDE/sos_recon_elements.cmn
@@ -0,0 +1,50 @@
+* sos_recon_elements.cmn
+******************** Cosy reconstruction matrix elements. **********************
+* Short Orbit Spectrometer *
+* Version 1.0, 18-Nov-1993 *
+* David Potterveld, Argonne National Lab. *
+* Modified: 21-JAN-94 DFG change max_ to smax_
+* $Log: sos_recon_elements.cmn,v $
+* Revision 1.5 1996/09/04 16:31:01 saw
+* (JRA) Add 5th element to s_recon_expon
+*
+* Revision 1.4 1995/08/08 15:42:30 cdaq
+* (DD) Add detector and angular offsets
+*
+* Revision 1.3 1995/04/06 20:30:40 cdaq
+* (SAW) Add ddutta's pre cosy transformation stuff
+*
+* Revision 1.2 1994/08/05 20:43:13 cdaq
+* (SAW) Add "CTPTYPE=parm" directive for auto generation of CTP reg calls
+*
+* Revision 1.1 1994/02/22 14:47:47 cdaq
+* Initial revision
+*
+********************************************************************************
+* CTPTYPE=parm
+*
+ integer*4 smax_recon_elements
+ parameter (smax_recon_elements = 1000) !Max # coeff elements
+
+ real*4 s_recon_coeff(4,smax_recon_elements)
+ real*4 s_ang_slope_x,s_ang_slope_y
+ real*4 s_ang_offset_x,s_ang_offset_y
+ real*4 s_det_offset_x,s_det_offset_y
+ real*4 s_z_true_focus ! Z position of SOS focus
+ integer*4 s_recon_expon(5,smax_recon_elements)
+ integer*4 s_num_recon_terms
+ integer*4 s_recon_initted
+
+ common /sos_recon_elements/
+ > s_recon_initted, !Initialization flag.
+ > s_num_recon_terms, !Number of terms.
+ > s_recon_coeff, !Coefficients.
+ > s_recon_expon, !Exponents.
+ > s_ang_slope_x, s_ang_slope_y, ! Slopes for rotation of f plane
+ > s_ang_offset_x, s_ang_offset_y, ! Slopes for rotation of f plane
+ > s_det_offset_x,s_det_offset_y, ! Detector offsets
+ > s_z_true_focus ! Z position of SOS focus
+
+********************************************************************************
+
+
diff --git a/INCLUDE/sos_scin_parms.cmn b/INCLUDE/sos_scin_parms.cmn
new file mode 100644
index 0000000..926d25e
--- /dev/null
+++ b/INCLUDE/sos_scin_parms.cmn
@@ -0,0 +1,194 @@
+* sos_scin_parms.cmn - two common blocks:
+*
+* sos_scin_parms - variables from the sos_positions.parm file
+* sos_tof_parms - tof correction parameters and position parameters
+* converted to arrays over plane,counter by s_init_scin.
+*
+* NOTE: Variables whose names start with sHODO are arrays over
+* plane and counter. sSCIN is used for parameters from the
+* .parm files and for arrays over hits.
+*
+* Modified 23 March 1994 DFG
+* Add definition of snum_scin_elements and set parameter value
+*
+* $Log: sos_scin_parms.cmn,v $
+* Revision 1.8 1996/09/04 16:31:26 saw
+* (JRA) Add misc scaler
+*
+* Revision 1.7 1996/01/24 16:20:17 saw
+* (JRA) Make smisc_dec_data two dimensional
+*
+* Revision 1.6 1995/08/11 16:35:55 cdaq
+* (JRA) Remove old dpos stuff
+* Add sscin_zero accumulators
+*
+* Revision 1.5 1995/05/22 19:11:54 cdaq
+* (SAW) Split gen_data_data_structures into gen, hms, sos, and coin parts.
+* Make pedestal arrays real. Add sos_scin_positions and sos_misc_parms commons
+*
+* Revision 1.4 1995/03/13 19:09:11 cdaq
+* (JRA) Move snum_scin_elements to gen_data_structures, remove
+* sscin_num_counters. Change sscin_??_top and _left to center and offset.
+* Add sscin_??_spacing parms. Change shodo_center_coord to shodo_center.
+* Add shodo_???_minph tables.
+*
+* Revision 1.3 1994/11/21 18:01:35 cdaq
+* * (SPB) Recopied from hms file and modified names for SOS
+*
+* Revision 1.2 1994/08/05 21:00:21 cdaq
+* (SAW) Add makereg directive with required include files
+* Add "CTPTYPE=parm" directive for auto generation of CTP reg calls
+*
+* Revision 1.1 1994/04/12 21:15:29 cdaq
+* Initial revision
+*
+* The following include statments must precede the inclusion of this
+* file in each routine that uses it. The *%% syntax is also a
+* directive to makereg to tell it to include the code in the program
+* that it generates.
+*
+*%% include 'sos_data_structures.cmn'
+*
+* CTPTYPE=parm
+*
+* from parameter file
+ integer*4 sscin_1x_nr
+ integer*4 sscin_1y_nr
+ integer*4 sscin_2x_nr
+ integer*4 sscin_2y_nr
+c integer*4 sscin_num_counters(SNUM_SCIN_PLANES)
+ integer*4 sdebugprintscinraw
+ integer*4 sdebugprintscindec
+ integer*4 sdebugprinttoftracks
+ integer*4 sdebugprinttracktests
+ real*4 sscin_1x_zpos
+ real*4 sscin_1y_zpos
+ real*4 sscin_2x_zpos
+ real*4 sscin_2y_zpos
+ real*4 sscin_1x_dzpos
+ real*4 sscin_1y_dzpos
+ real*4 sscin_2x_dzpos
+ real*4 sscin_2y_dzpos
+ real*4 sscin_1x_left
+ real*4 sscin_1y_top
+ real*4 sscin_2x_left
+ real*4 sscin_2y_top
+ real*4 sscin_1x_right
+ real*4 sscin_1y_bot
+ real*4 sscin_2x_right
+ real*4 sscin_2y_bot
+ real*4 sscin_1x_center(snum_scin_elements)
+ real*4 sscin_1y_center(snum_scin_elements)
+ real*4 sscin_2x_center(snum_scin_elements)
+ real*4 sscin_2y_center(snum_scin_elements)
+ real*4 sscin_1x_offset
+ real*4 sscin_1y_offset
+ real*4 sscin_2x_offset
+ real*4 sscin_2y_offset
+ real*4 sscin_1x_size
+ real*4 sscin_1y_size
+ real*4 sscin_2x_size
+ real*4 sscin_2y_size
+ real*4 sscin_1x_spacing
+ real*4 sscin_1y_spacing
+ real*4 sscin_2x_spacing
+ real*4 sscin_2y_spacing
+ real*4 sscin_all_ped_pos(snum_scin_planes,snum_scin_elements)
+ real*4 sscin_all_ped_neg(snum_scin_planes,snum_scin_elements)
+
+ common/sos_scin_parms/ !variables from s_positions.parm
+ & sscin_1x_nr, sscin_1y_nr, !Elements per plane
+ & sscin_2x_nr, sscin_2y_nr,
+ & sscin_1x_zpos, sscin_1y_zpos, !z position of plane.
+ & sscin_2x_zpos, sscin_2y_zpos,
+ & sscin_1x_dzpos, sscin_1y_dzpos,
+ & sscin_2x_dzpos, sscin_2y_dzpos,
+ & sscin_1x_left, sscin_1y_top, !position of 'negative'(??) end.
+ & sscin_2x_left, sscin_2y_top,
+ & sscin_1x_right, sscin_1y_bot, !position of 'positive'(??) end.
+ & sscin_2x_right, sscin_2y_bot,
+ & sscin_1x_center, sscin_1y_center, !center (transverse) of element.
+ & sscin_2x_center, sscin_2y_center,
+ & sscin_1x_size, sscin_1y_size, !width of elements.
+ & sscin_2x_size, sscin_2y_size,
+ & sscin_1x_spacing, sscin_1y_spacing, !separation of centers.
+ & sscin_2x_spacing, sscin_2y_spacing,
+ & sdebugprintscinraw,
+ & sdebugprintscindec,
+ & sdebugprinttoftracks,
+ & sdebugprinttracktests,
+ & sscin_all_ped_pos,
+ & sscin_all_ped_neg,
+ & sscin_1x_offset, sscin_1y_offset, !offset from nominal trans pos.
+ & sscin_2x_offset, sscin_2y_offset
+
+* Physical paramteres of counters. Use shodo_* for arrays that include
+* the entire hodoscope, sscin_* for arrays that loop over hits.
+ real*4 snum_scin_counters(snum_scin_planes)
+ real*4 shodo_center(snum_scin_planes,snum_scin_elements)
+ real*4 shodo_width(snum_scin_planes,snum_scin_elements)
+ real*4 shodo_pos_coord(snum_scin_planes,snum_scin_elements)
+ real*4 shodo_neg_coord(snum_scin_planes,snum_scin_elements)
+
+* callibration type variables.
+ real*4 shodo_slop(snum_scin_planes)
+ real*4 shodo_vel_light(snum_scin_planes,snum_scin_elements)
+ real*4 shodo_pos_sigma(snum_scin_planes,snum_scin_elements)
+ real*4 shodo_neg_sigma(snum_scin_planes,snum_scin_elements)
+ real*4 shodo_pos_phc_coeff(snum_scin_planes,snum_scin_elements)
+ real*4 shodo_neg_phc_coeff(snum_scin_planes,snum_scin_elements)
+ real*4 shodo_pos_time_offset(snum_scin_planes,snum_scin_elements)
+ real*4 shodo_neg_time_offset(snum_scin_planes,snum_scin_elements)
+ real*4 shodo_pos_minph(snum_scin_planes,snum_scin_elements) ! ADC offset for PH correction
+ real*4 shodo_neg_minph(snum_scin_planes,snum_scin_elements) ! ADC offset for PH correction
+
+* correction parameters and position information converted to arryas
+* over plane and counter
+
+ common/sos_tof_parms/
+ & snum_scin_counters,
+ & shodo_center,
+ & shodo_width,
+ & shodo_pos_coord,
+ & shodo_neg_coord,
+ & shodo_slop,
+ & shodo_vel_light,
+ & shodo_pos_sigma,
+ & shodo_neg_sigma,
+ & shodo_pos_phc_coeff,
+ & shodo_neg_phc_coeff,
+ & shodo_pos_time_offset,
+ & shodo_neg_time_offset,
+ $ shodo_pos_minph,
+ $ shodo_neg_minph
+*
+*
+* sos_misc_parms.cmn - misc tdc's filled as array over signal number
+* (tdc is sparsified, so the raw signals are array over hits)
+*
+* CTPTYPE=parm
+*
+ integer*4 snum_misc_planes
+ parameter(snum_misc_planes=2) !(1=TDC, 2=ADC)
+*
+*
+* CTPTYPE=event
+*
+ integer*4 smisc_dec_data(smax_misc_hits,snum_misc_planes)
+ integer*4 smisc_scaler(smax_misc_hits,snum_misc_planes)
+
+ common/sos_misc_parms/
+ & smisc_dec_data,
+ & smisc_scaler
+
+
+ integer*4 sscin_zero_pos(snum_scin_planes,snum_scin_elements)
+ integer*4 sscin_zero_neg(snum_scin_planes,snum_scin_elements)
+ integer*4 sscin_zero_num(snum_scin_planes,snum_scin_elements)
+ real*4 sscin_zero_pave(snum_scin_planes,snum_scin_elements)
+ real*4 sscin_zero_nave(snum_scin_planes,snum_scin_elements)
+
+ common /sos_scin_zero/
+ & sscin_zero_pos,sscin_zero_neg,
+ & sscin_zero_num,
+ & sscin_zero_pave,sscin_zero_nave
diff --git a/INCLUDE/sos_scin_tof.cmn b/INCLUDE/sos_scin_tof.cmn
new file mode 100644
index 0000000..89f4dc1
--- /dev/null
+++ b/INCLUDE/sos_scin_tof.cmn
@@ -0,0 +1,147 @@
+* sos_scin_tof.cmn: common block used by the subroutines that
+* calculate the sos time of flight.
+* $Log: sos_scin_tof.cmn,v $
+* Revision 1.9 2005/03/15 21:14:28 jones
+* Add variables htof_tolerance and stof_tolerance to be used to filter the scintillator tdc hits and group them by time. ( P. Bosted)
+*
+*
+* Revision 1.8 1996/04/30 14:04:07 saw
+* (JRA) Add sbeta_p, and sbeta_pcent
+*
+* Revision 1.7 1995/05/22 19:03:32 cdaq
+* (SAW) Split gen_data_data_structures into gen, hms, sos, and coin parts
+* Add some varaibles and fix typos
+*
+* Revision 1.6 1995/03/13 19:13:57 cdaq
+* (JRA) Change sscin_minph to sscin_???_minph arrays. Add tracks index to
+* sgood_tdc_pos, sgood_tdc_neg, sgood_scin_time, sgood_plane_time,
+* and sgood_beta.
+*
+* Revision 1.5 1994/11/21 18:02:11 cdaq
+* * (SPB) Recopied from hms file and modified names for SOS
+*
+* Revision 1.4 1994/08/16 03:56:41 cdaq
+* (SAW) Change some variables to parm CTPTYPE
+*
+* Revision 1.3 1994/08/05 21:02:04 cdaq
+* (SAW) Add makereg directive with required include files
+* Add "CTPTYPE=event" directive for auto generation of CTP reg calls
+*
+* Revision 1.2 1994/05/13 03:58:46 cdaq
+* (DFG) Remove parameters to .parm file
+*
+* Revision 1.1 1994/04/13 19:01:46 cdaq
+* Initial revision
+*
+* The following include statments must precede the inclusion of this
+* file in each routine that uses it. The *%% syntax is also a
+* directive to makereg to tell it to include the code in the program
+* that it generates.
+*
+*%% include 'sos_data_structures.cmn'
+*%% include 'sos_scin_parms.cmn'
+*
+* CTPTYPE=event
+*
+ integer*4 sntof
+
+ real*4 sscin_long_coord(smax_scin_hits)
+ real*4 sscin_trans_coord(smax_scin_hits)
+ real*4 sscin_pos_coord(smax_scin_hits)
+ real*4 sscin_neg_coord(smax_scin_hits)
+ real*4 sscin_pos_sigma(smax_scin_hits)
+ real*4 sscin_neg_sigma(smax_scin_hits)
+ real*4 sscin_pos_time(smax_scin_hits)
+ real*4 sscin_neg_time(smax_scin_hits)
+ real*4 sscin_sigma(smax_scin_hits)
+ real*4 sscin_time(smax_scin_hits)
+ real*4 sscin_vel_light(smax_scin_hits)
+ real*4 sscin_pos_phc_coeff(smax_scin_hits)
+ real*4 sscin_neg_phc_coeff(smax_scin_hits)
+ real*4 sscin_pos_time_offset(smax_scin_hits)
+ real*4 sscin_neg_time_offset(smax_scin_hits)
+ real*4 sscin_time_fp(smax_scin_hits)
+
+*
+* CTPTYPE=parm
+*
+ real*4 sscin_pos_minph(smax_scin_hits) ! ADC Offset for PH correction
+ real*4 sscin_neg_minph(smax_scin_hits) ! ADC Offset for PH correction
+ real*4 sscin_tdc_min
+ real*4 sscin_tdc_max
+ real*4 sscin_tdc_to_time
+ real*4 sstart_time_center ! center of time window on scin. hits
+ real*4 sstart_time_slop ! 1/2 width of time window on scin. hits
+ real*4 stof_tolerance ! tolerance for tof window in nsec
+*
+* CTPTYPE=event
+*
+ logical*4 sgood_tdc_pos(sntracks_max,smax_scin_hits)
+ logical*4 sgood_tdc_neg(sntracks_max,smax_scin_hits)
+ logical*4 sgood_scin_time(sntracks_max,smax_scin_hits)
+ logical*4 sgood_plane_time(sntracks_max,snum_scin_planes)
+ logical*4 sgood_beta(sntracks_max)
+ logical*4 sscin_on_track(sntracks_max,smax_scin_hits)
+
+ common/sos_scin_tof/
+ & sntof,
+ & sscin_long_coord,
+ & sscin_trans_coord,
+ & sscin_pos_coord,sscin_neg_coord, !position of tubes
+ & sscin_pos_sigma,sscin_neg_sigma, !time resolution for tubes
+ & sscin_pos_time, sscin_neg_time, !time for 'pos' and 'neg' tubes.
+ & sscin_sigma, !time resolution for scin.
+ & sscin_time, !time for scin. (ave of tubes)
+ & sscin_vel_light,
+ & sscin_pos_phc_coeff,sscin_neg_phc_coeff,
+ & sscin_pos_time_offset,sscin_neg_time_offset,
+ & sscin_pos_minph, sscin_neg_minph,
+ & sscin_tdc_min,
+ & sscin_tdc_max,
+ & sscin_tdc_to_time,
+ & sgood_tdc_pos, sgood_tdc_neg, !did pos/neg tube had good tdc?
+ & sgood_scin_time, !was a time found for the hit?
+ & sgood_plane_time, !was a time found for the plane?
+ & sgood_beta, !was a value of beta found?
+ & sscin_on_track, !list of scins on each track.
+ & sscin_time_fp, !scin time (ave) projected to fp
+ & sstart_time_center,
+ & sstart_time_slop,
+ & stof_tolerance
+
+*
+* CTPTYPE=event
+*
+ real*4 s_fptime(snum_scin_planes) !time at fp from all hits in 1 plane
+ real*4 s_fptimedif(6) !fp time differences
+ real*4 sbeta_notrk
+ real*4 sbeta_chisq_notrk
+ real*4 sbeta_p
+ real*4 sbeta_pcent
+
+ common/stof_notrk/
+ & s_fptime,
+ & s_fptimedif,
+ & sbeta_notrk,
+ & sbeta_chisq_notrk,
+ & sbeta_p,
+ & sbeta_pcent
+
+c integer*4 sscin_pos_did(snum_scin_planes,16)
+c integer*4 sscin_neg_did(snum_scin_planes,16)
+c integer*4 sscin_pos_should(snum_scin_planes,16)
+c integer*4 sscin_neg_should(snum_scin_planes,16)
+c real*4 sscin_pos_eff(snum_scin_planes,16)
+c real*4 sscin_neg_eff(snum_scin_planes,16)
+c real*4 sscin_pos_solo(snum_scin_planes,16)
+c real*4 sscin_neg_solo(snum_scin_planes,16)
+c
+c common/smore_debugging/
+c & sscin_pos_eff,
+c & sscin_neg_eff,
+c & sscin_pos_solo,
+c & sscin_neg_solo,
+c & sscin_pos_did,
+c & sscin_neg_did,
+c & sscin_pos_should,
+c & sscin_neg_should
diff --git a/INCLUDE/sos_statistics.cmn b/INCLUDE/sos_statistics.cmn
new file mode 100644
index 0000000..2539e58
--- /dev/null
+++ b/INCLUDE/sos_statistics.cmn
@@ -0,0 +1,193 @@
+* sos_statistics.cmn
+* common blocks containing event statistics for s_reconstruction
+* $Log: sos_statistics.cmn,v $
+* Revision 1.13 2003/09/05 20:41:27 jones
+* Merge in online03 changes (mkj)
+*
+* Revision 1.12.2.1 2003/04/02 22:26:28 cdaq
+* added some variables for scint. effic tests (from oct 1999 online) - JRA
+*
+* Revision 1.12 1996/09/04 16:31:47 saw
+* (SAW) Change ' to '' in comments
+*
+* Revision 1.11 1996/01/17 15:07:45 cdaq
+* (JRA) Remove some obsolete common blocks
+*
+* Revision 1.10 1995/09/01 13:04:45 cdaq
+* (JRA) Add counter efficiency variables
+*
+* Revision 1.9 1995/08/11 16:36:47 cdaq
+* (JRA) Add sstat_mineff as a ctp parameter
+*
+* Revision 1.8 1995/07/28 14:42:37 cdaq
+* (JRA) Add pos/neg/both good arrays
+*
+* Revision 1.7 1995/05/22 19:02:13 cdaq
+* (SAW) Split gen_data_data_structures into gen, hms, sos, and coin parts
+* Fix a conflicting common block name
+*
+* Revision 1.6 1995/04/06 20:21:08 cdaq
+* (SAW) Remove hms isms and hardwired array sizes
+*
+* Revision 1.5 1995/03/13 19:15:42 cdaq
+* (JRA) Add many new statistics
+*
+* Revision 1.4 1994/11/21 18:02:39 cdaq
+* * (SPB) Recopied from hms file and modified names for SOS
+*
+* Revision 1.3 1994/08/05 21:19:32 cdaq
+* (SAW) Add makereg directive with required include files
+* Add "CTPTYPE=event" directive for auto generation of CTP reg calls
+*
+* Revision 1.2 1994/06/14 03:34:25 cdaq
+* (DFG) add chamber efficiency and sigma
+*
+* Revision 1.1 1994/06/07 02:00:48 cdaq
+* Initial revision
+*
+* The following include statments must precede the inclusion of this
+* file in each routine that uses it. The *%% syntax is also a
+* directive to makereg to tell it to include the code in the program
+* that it generates.
+*
+*%% include 'sos_data_structures.cmn'
+
+*
+* CTPTYPE=parm
+*
+ real*4 sstat_maxchisq
+ real*4 sstat_slop
+ real*4 sstat_mineff
+*
+* CTPTYPE=event
+*
+ integer*4 sstat_numevents
+ integer*4 sstat_trk(snum_scin_planes,snum_scin_elements)
+ integer*4 sstat_poshit(snum_scin_planes,snum_scin_elements)
+ integer*4 sstat_neghit(snum_scin_planes,snum_scin_elements)
+ integer*4 sstat_orhit(snum_scin_planes,snum_scin_elements)
+ integer*4 sstat_andhit(snum_scin_planes,snum_scin_elements)
+ integer*4 sstat_trksum(snum_scin_planes)
+ integer*4 sstat_possum(snum_scin_planes)
+ integer*4 sstat_negsum(snum_scin_planes)
+ integer*4 sstat_orsum(snum_scin_planes)
+ integer*4 sstat_andsum(snum_scin_planes)
+ real*4 sstat_peff(snum_scin_planes,snum_scin_elements)
+ real*4 sstat_neff(snum_scin_planes,snum_scin_elements)
+ real*4 sstat_oeff(snum_scin_planes,snum_scin_elements)
+ real*4 sstat_aeff(snum_scin_planes,snum_scin_elements)
+ real*4 sstat_poseff(snum_scin_planes)
+ real*4 sstat_negeff(snum_scin_planes)
+ real*4 sstat_oreff(snum_scin_planes)
+ real*4 sstat_andeff(snum_scin_planes)
+ real*4 seff_s1
+ real*4 seff_s2
+ real*4 seff_stof
+ real*4 seff_4_of_4
+ real*4 seff_3_of_4
+
+ common/sscin_statistics/
+ & sstat_numevents,
+ & sstat_trk, !# of times track points near center of scin.
+ & sstat_poshit, !# of times the pos tube on scintillator fired
+ & sstat_neghit, !# of times the pos tube on scintillator fired
+ & sstat_orhit, !# of times either tube fired
+ & sstat_andhit, !# of times both tubes fired
+ & sstat_trksum, !summed over all counters on plane
+ & sstat_possum, !summed over all counters on plane
+ & sstat_negsum, !summed over all counters on plane
+ & sstat_orsum, !summed over all counters on plane
+ & sstat_andsum, !summed over all counters on plane
+ & sstat_peff, !pos efficiency for given counter.
+ & sstat_neff, !neg efficiency for given counter.
+ & sstat_oeff, !or efficiency for given counter.
+ & sstat_aeff, !and efficiency for given counter.
+ & sstat_poseff, !efficiency over all counters on plane
+ & sstat_negeff, !efficiency over all counters on plane
+ & sstat_oreff, !efficiency over all counters on plane
+ & sstat_andeff, !efficiency over all counters on plane
+ & sstat_slop, !distance allowed from center of scintillator.
+ & sstat_mineff, !give warning if effic. < sstat_mineff
+ & sstat_maxchisq, !maximum chisq allowed to use track for eff. calc.
+ & seff_s1, !calculated trigger eff. for s1 =(s1x .or. s1y).
+ & seff_s2, !calculated trigger eff. for s2 =(s2x .or. s2y).
+ & seff_stof, !calculated trigger eff. for stof =(s1 .and. s2).
+ & seff_4_of_4, !calculated trigger eff. for 4/4 planes.
+ & seff_3_of_4 !calculated trigger eff. for 3/4 planes.
+
+
+*
+* CTPTYPE=parm
+*
+ real*4 sstat_cal_maxchisq
+ real*4 sstat_cal_slop
+*
+* CTPTYPE=event
+*
+ integer*4 sstat_cal_numevents
+ integer*4 sstat_cal_trk(smax_cal_columns,smax_cal_rows)
+ integer*4 sstat_cal_hit(smax_cal_columns,smax_cal_rows)
+ integer*4 sstat_cal_trksum(smax_cal_columns)
+ integer*4 sstat_cal_hitsum(smax_cal_columns)
+ real*4 sstat_cal_eff(smax_cal_columns,smax_cal_rows)
+ real*4 sstat_cal_effsum(smax_cal_columns)
+
+ common/scal_statistics/
+ & sstat_cal_numevents,
+ & sstat_cal_trk, !# of times track points near center of block.
+ & sstat_cal_hit, !# of times the tube on block was over threshold.
+ & sstat_cal_trksum, !summed over all blocks on plane.
+ & sstat_cal_hitsum, !summed over all blocks on plane.
+ & sstat_cal_eff, !efficiency for a given block.
+ & sstat_cal_effsum, !efficiency over all counters on plane.
+ & sstat_cal_slop, !distance allowed from center of block.
+ & sstat_cal_maxchisq !maximum chisq allowed to use track for eff. calc.
+
+*
+* CTPTYPE=event
+*
+ integer sbothgood(snum_scin_planes,snum_scin_elements)
+ integer sposgood(snum_scin_planes,snum_scin_elements)
+ integer sneggood(snum_scin_planes,snum_scin_elements)
+
+ common/sscin_posneg_stats/
+ & sbothgood,
+ & sposgood,
+ & sneggood
+*
+* CTPTYPE=parm
+*
+ real*4 sdc_min_eff(smax_num_dc_planes) !''warning'' value for plane eff.
+*
+* CTPTYPE=event
+*
+ integer*4 sdc_tot_events !total number of events examined
+ integer*4 sdc_events(smax_num_dc_planes) !counter of times plane was hit
+ integer*4 sdc_cham_hits(smax_num_chambers)
+ real*4 sdc_plane_eff(smax_num_dc_planes) !effic=events(pln)/tot_events
+ real*4 sdc_cham_eff(smax_num_chambers)
+
+ common/sdc_statistics/
+ & sdc_tot_events,
+ & sdc_events,
+ & sdc_min_eff,
+ & sdc_plane_eff,
+ & sdc_cham_hits,
+ & sdc_cham_eff
+
+* The logical variables just record if that particular event passed the test
+* for 'plane should have fired' and 'plane did fire'. In CTP tests, we'll
+* apply additional cuts and check the efficiency.
+* 'Should' = event where other 3 hodoscope planes fired.
+* 'Did' = 'Should' && plane in question did fire.
+
+*
+* CTPTYPE=event
+*
+ logical*4 strig_hodoshouldflag(snum_scin_planes)
+ logical*4 strig_hododidflag(snum_scin_planes)
+ !(based on s1x,s1y... signals)
+ common/strig_hodostatistics/
+ & strig_hodoshouldflag,
+ & strig_hododidflag
+
diff --git a/INCLUDE/sos_track_histid.cmn b/INCLUDE/sos_track_histid.cmn
new file mode 100644
index 0000000..64dc80f
--- /dev/null
+++ b/INCLUDE/sos_track_histid.cmn
@@ -0,0 +1,103 @@
+*_______________________________________________________________________
+* sos_track_histid.cmn
+*
+* This common block contains the HBOOK histogram id numbers
+* for all sos histograms in which direct hfill calls are made.
+*
+* It also contains the paramter flags to turn on and off histograming
+* of each of the hard coded blocks.
+*
+* Created 9 April 1994 D. F. Geesaman
+*
+* $Log: sos_track_histid.cmn,v $
+* Revision 1.7 1996/01/17 15:06:31 cdaq
+* (JRA) Add sidcuttdc and a temporary junk common block
+*
+* Revision 1.6 1995/05/22 19:12:33 cdaq
+* (SAW) Split gen_data_data_structures into gen, hms, sos, and coin parts
+*
+* Revision 1.5 1995/05/12 12:24:01 cdaq
+* (JRA) Modify/add user histograms
+*
+* Revision 1.4 1995/04/06 20:22:13 cdaq
+* (SAW) Add residuals histogram ids
+*
+* Revision 1.3 1994/08/05 20:38:26 cdaq
+* (SAW) Add makereg directive with required include files
+* Add "CTPTYPE=event" directive for auto generation of CTP reg calls
+*
+* Revision 1.2 1994/05/13 04:00:50 cdaq
+* (DFG) Add s_fill_dc_target_hist id's
+*
+* Revision 1.1 1994/04/12 21:13:42 cdaq
+* Initial revision
+*
+* The following include statments must precede the inclusion of this
+* file in each routine that uses it. The *%% syntax is also a
+* directive to makereg to tell it to include the code in the program
+* that it generates.
+*
+*%% include 'sos_data_structures.cmn'
+*
+* CTPTYPE=parm
+*
+ integer*4 siddcwiremap(smax_num_dc_planes)
+ integer*4 siddcdrifttime(smax_num_dc_planes)
+ integer*4 siddcdriftdis(smax_num_dc_planes)
+ integer*4 siddcwirecent(smax_num_dc_planes)
+ integer*4 sidsx_fp,sidsy_fp,sidsxp_fp,sidsyp_fp,sidslogchi2_fp,
+ & sidsnfree_fp,sidschi2perdeg_fp
+ integer*4 sidsx_tar, sidsy_tar, sidsz_tar, sidsxp_tar, sidsyp_tar,
+ & sidsdelta_tar, sidsp_tar
+ integer*4 sidres_fp(smax_num_dc_planes)
+ integer*4 sidsingres_fp(smax_num_dc_planes)
+ integer*4 sidrawtdc
+ integer*4 sidcuttdc
+
+ common/sos_tracking_histid/
+ & siddcwiremap,
+ & siddcdrifttime,
+ & siddcdriftdis,
+ & siddcwirecent,
+ & sidsx_fp,
+ & sidsy_fp,
+ & sidsxp_fp,
+ & sidsyp_fp,
+ & sidslogchi2_fp,
+ & sidsnfree_fp,
+ & sidschi2perdeg_fp,
+ & sidsx_tar,
+ & sidsy_tar,
+ & sidsz_tar,
+ & sidsxp_tar,
+ & sidsyp_tar,
+ & sidsdelta_tar,
+ & sidsp_tar,
+ & sidres_fp,
+ & sidsingres_fp,
+ & sidrawtdc,
+ & sidcuttdc
+
+*
+* CTPTYPE=parm
+*
+ integer*4 sturnon_decoded_dc_hist
+ integer*4 sturnon_focal_plane_hist
+ integer*4 sturnon_target_hist
+ common/sos_hist_flags/
+ & sturnon_decoded_dc_hist,
+ & sturnon_focal_plane_hist,
+ & sturnon_target_hist
+
+
+* temporary junk common block.
+*
+* CTPTYPE=event
+*
+ real*4 sx_sp1(sntracks_max),sy_sp1(sntracks_max),sxp_sp1(sntracks_max)
+ real*4 sx_sp2(sntracks_max),sy_sp2(sntracks_max),sxp_sp2(sntracks_max)
+ real*4 ssx_sp1,ssy_sp1,ssxp_sp1
+ real*4 ssx_sp2,ssy_sp2,ssxp_sp2
+*
+ common/stemp_junk_cb/sx_sp1,sy_sp1,sxp_sp1,sx_sp2,sy_sp2,sxp_sp2,
+ & ssx_sp1,ssy_sp1,ssxp_sp1,ssx_sp2,ssy_sp2,ssxp_sp2
diff --git a/INCLUDE/sos_tracking.cmn b/INCLUDE/sos_tracking.cmn
new file mode 100644
index 0000000..c6b8ffe
--- /dev/null
+++ b/INCLUDE/sos_tracking.cmn
@@ -0,0 +1,429 @@
+* sos_tracking.cmn
+* include file for sos tracking intermediate results
+* D. F. Geesaman 1 September 1993
+* modified dfg 10 Feb 94
+* change name to sos_tracking.cmn
+* put sluno and debugflags from parameters to CTP
+* $Log: sos_tracking.cmn,v $
+* Revision 1.18 1999/02/23 19:22:52 csa
+* (JRA) Remove sdebugcalcpeds
+*
+* Revision 1.17 1998/12/01 20:30:16 saw
+* * (SAW) Put SOS_DRIFT common block before equivalences
+*
+* Revision 1.16 1996/09/04 16:32:10 saw
+* (DVW) Add slew of variables for derek's hms track tests
+*
+* Revision 1.15 1996/04/30 14:04:39 saw
+* (JRA) Bunch of changes
+*
+* Revision 1.14 1996/01/17 15:05:05 cdaq
+* (JRA) Change name of various correction variables.
+* Add some efficiency accumulator variables.
+*
+* Revision 1.13 1995/05/22 19:01:16 cdaq
+* (SAW) Split gen_data_data_structures into gen, hms, sos, and coin parts
+*
+* Revision 1.12 1995/04/06 20:30:04 cdaq
+* (SAW) Fix wc plane names. Change residuals variable names
+*
+* Revision 1.11 1995/03/13 19:18:06 cdaq
+* (SAW) Names of fract equivalence arrays reflect SOS chamber plane names
+*
+* Revision 1.10 1995/01/27 20:22:58 cdaq
+* (SAW) Let sdc_planes_per_chamber be a ctp parameter
+*
+* Revision 1.9 1994/12/01 17:22:08 cdaq
+* (SAW) Add s_hms_style_chambers flag to treat SOS chambers like HMS
+* Add sdc_planes_per_chamber (calculated in s_generate_geometry)
+* Make gplanesdc equivalenced with gplanesdc1, ...
+*
+* Revision 1.8 1994/11/22 18:40:41 cdaq
+* (SAW) Add s's in front of fract, aa3, det3, aainv3. Remove fractinterp
+* Cleaned up ?DC_NUM_CHAMBERS and ?MAX_NUM_CHAMBERS stuff
+*
+* Revision 1.7 1994/11/21 18:02:58 cdaq
+* (SPB) Recopied from hms file and modified names for SOS
+*
+* Revision 1.6 1994/08/16 03:57:09 cdaq
+* (SAW) Change some variables to parm CTPTYPE
+*
+* Revision 1.5 1994/08/05 20:06:27 cdaq
+* (SAW) Add makereg directive with required include files
+*
+* Revision 1.4 1994/08/05 20:00:36 cdaq
+* (SAW) Add "CTPTYPE=event,parm" directive for auto generation of CTP reg calls
+*
+* Revision 1.3 1994/06/06 17:06:05 cdaq
+* (DFG) add ssingle_stub
+*
+* Revision 1.2 1994/03/24 18:40:37 cdaq
+* (DFG) Additional parameters
+*
+* Revision 1.1 1994/02/22 14:47:57 cdaq
+* Initial revision
+*
+* The following include statments must precede the inclusion of this
+* file in each routine that uses it. The *%% syntax is also a
+* directive to makereg to tell it to include the code in the program
+* that it generates.
+*
+*%% include 'sos_data_structures.cmn'
+
+
+*----------------------------------------------------------------------
+* PARAMETERS FOR DRIFT TIME TO DISTANCE CALCULATION
+*
+* CTPTYPE=parm
+*
+ integer*4 sdriftbins_max ! number of bins for drift time lookup table
+ parameter (sdriftbins_max=138)
+ real*4 sdriftbins ! number of bins for drift time lookup table
+ real*4 sdriftbinsz ! drift bin size in nsec of lookup table
+ real*4 sdrift1stbin ! drift time of 1st bin in nsec of lookup
+ real*4 sfract
+ !fraction of integrated time spectrum
+
+ real*4 swc1u1fract(sdriftbins_max),swc1u2fract(sdriftbins_max),
+ & swc1x1fract(sdriftbins_max),swc1x2fract(sdriftbins_max),
+ & swc1v1fract(sdriftbins_max),swc1v2fract(sdriftbins_max),
+ & swc2u1fract(sdriftbins_max),swc2u2fract(sdriftbins_max),
+ & swc2x1fract(sdriftbins_max),swc2x2fract(sdriftbins_max),
+ & swc2v1fract(sdriftbins_max),swc2v2fract(sdriftbins_max)
+
+ common/SOS_DRIFT/
+ & sfract(sdriftbins_max,smax_num_dc_planes),
+ & sdriftbinsz,
+ & sdrift1stbin,
+ & sdriftbins
+
+ equivalence (swc1u1fract(1),sfract(1,1))
+ equivalence (swc1u2fract(1),sfract(1,2))
+ equivalence (swc1x1fract(1),sfract(1,3))
+ equivalence (swc1x2fract(1),sfract(1,4))
+ equivalence (swc1v1fract(1),sfract(1,5))
+ equivalence (swc1v2fract(1),sfract(1,6))
+ equivalence (swc2u1fract(1),sfract(1,7))
+ equivalence (swc2u2fract(1),sfract(1,8))
+ equivalence (swc2x1fract(1),sfract(1,9))
+ equivalence (swc2x2fract(1),sfract(1,10))
+ equivalence (swc2v1fract(1),sfract(1,11))
+ equivalence (swc2v2fract(1),sfract(1,12))
+
+*----------------------------------------------------------------------
+* INFORMATION ABOUT PLANE GEOMETRY AND TRACKING PARAMETERS
+*
+* CTPTYPE=parm
+*
+ integer*4 smax_chamber_hits
+ parameter (smax_chamber_hits=544)
+ integer*4 smax_space_points ! maximum number of space points
+ parameter (smax_space_points=50)
+ integer*4 smax_hits_per_point ! maximum number of hits per point
+ parameter (smax_hits_per_point=15)
+ integer*4 snum_fpray_param ! number of ray parameters in focal plane
+ parameter (snum_fpray_param=4)
+ integer*4 sdc_num_cards ! #/discriminator cards
+ parameter (sdc_num_cards=40)
+ integer*4 sdc_max_wires_per_plane
+ parameter (sdc_max_wires_per_plane=64)
+
+ integer*4 sdc_num_planes ! actual number of dc chambers - set in CTP
+ integer*4 sdc_num_chambers ! actual number of chambers - set in CTP
+ integer*4 sdc_planes_per_chamber
+ integer*4 sdc_tdc_min_win ! drift chamber tdc min value for good hit
+ integer*4 sdc_tdc_max_win ! drfit chamber tdc max value for good hit
+ integer*4 smin_hit ! minimum hits for space point
+ integer*4 smin_combos ! minimum combos for space point
+ integer*4 smax_pr_hits ! max number of hits in each plane for
+ ! pattern recognition to be done in that pla
+* wire velocity corrections.
+ logical sdc_readout_x !true = read out from side (like x plane)
+ real*4 sdc_readout_corr !wire path length/dist. to readout side
+ real*4 sdc_wire_velocity ! propogation velocity of signal on wire(cm/ns)
+ real*4 sdc_drifttime_sign !sign of correction term.
+ real*4 sdc_central_time !ave. time (ns) for signal to reach disc. card.
+ ! (both times are from center of the chamber)
+* timing offsets per card.
+ integer*4 sdc_sing_cardid ! array of card id''s so one can put cuts/test on a per/card basys
+ integer*4 sdc_card_no ! card number
+ real*4 sdc_card_delay ! delay for a given card
+
+ real*4 sxt_track_criterion ! stub link criterion on x_t
+ real*4 syt_track_criterion ! stub link criterion on y_t
+ real*4 sxpt_track_criterion ! stub link criterion on xp_t
+ real*4 sypt_track_criterion ! stub link criterion on yp_t
+ real*4 sspace_point_criterion ! maximum distance**2 to join pairs/combos.
+*
+* CTPTYPE=event
+*
+ integer*4 sncham_hits
+ integer*4 snspace_points ! number of space points in each chamber
+ integer*4 sdc_hits_per_plane
+ integer*4 strack_fit_num ! track number in fitting loop
+ integer*4 snspace_points_tot ! total number of space points after select.
+ integer*4 gplanesdc(smax_space_points,smax_num_chambers) ! good plane pattern unit, set bit if respective plane hit
+ integer*4 gplanesdc1(smax_space_points) ! good plane pattern unit,
+ integer*4 gplanesdc2(smax_space_points) ! set bit if respective plane
+ integer*4 gplanesdc3(smax_space_points) ! was hit.
+
+ equivalence (gplanesdc1(1),gplanesdc(1,1))
+ equivalence (gplanesdc2(1),gplanesdc(2,1))
+ equivalence (gplanesdc3(1),gplanesdc(3,1))
+
+ integer*4 sspace_point_hits ! array of n rows of space points
+ ! (n,1) = number of hits
+ ! (n,2) = number of valid combinations
+ ! (n,3...) hit numbers for space point
+ real*4 sspace_points ! array of x, y of space points
+ real*4 sbeststub ! array of stubs fit to each space point
+ real*4 sdc_sing_drifttime ! array of fully corrected drift times for each plane
+ real*4 sdc_sing_driftdis ! array of final drift distances for each plane
+
+*
+ common/SOS_TRACKING/
+ & sdc_num_chambers,sdc_num_planes,
+ & sdc_planes_per_chamber,
+ & sdc_hits_per_plane(smax_num_dc_planes),
+ & gplanesdc,
+ & sspace_points(smax_space_points,2),
+ & sspace_point_hits(smax_space_points,smax_hits_per_point+2),
+ & snspace_points(smax_num_chambers),
+ & snspace_points_tot,
+ & sbeststub(smax_space_points,snum_fpray_param),
+ & sncham_hits(smax_num_chambers),
+ & strack_fit_num,
+ & sspace_point_criterion(smax_num_chambers),
+ & sdc_tdc_min_win(smax_num_dc_planes),
+ & sdc_tdc_max_win(smax_num_dc_planes),
+ & smin_hit(smax_num_chambers),smin_combos(smax_num_chambers),
+ & smax_pr_hits(smax_num_chambers),
+ & sxt_track_criterion,syt_track_criterion,
+ & sxpt_track_criterion,sypt_track_criterion,
+ & sdc_sing_drifttime(smax_num_dc_planes),
+ & sdc_sing_driftdis(smax_num_dc_planes),
+ & sdc_wire_velocity,
+ & sdc_central_time(smax_num_dc_planes),
+ & sdc_drifttime_sign(smax_num_dc_planes),
+ & sdc_readout_corr(smax_num_dc_planes),
+ & sdc_readout_x(smax_num_dc_planes),
+ & sdc_card_delay(sdc_num_cards),
+ & sdc_card_no(sdc_max_wires_per_plane,smax_num_dc_planes),
+ & sdc_sing_cardid(smax_num_dc_planes)
+
+
+*----------------------------------------------------------------------
+* MATRICES FOR 3 PARAMETER FITS.
+*
+* CTPTYPE=parm
+*
+ real*8 saa3,saainv3 ! matrix AA and its inverse AAINV
+ real*8 sdet3 ! array of determinants of AA
+ common/SOS_TFIT_MATRIX/
+ & saa3(3,3),
+ & saainv3(3,3,smax_num_dc_planes+smax_num_chambers),
+ & sdet3(smax_num_dc_planes+smax_num_chambers)
+
+
+
+*----------------------------------------------------------------------
+* DRIFT CHAMBER DEBUGGING FLAGS/INFO.
+*
+* CTPTYPE=parm
+*
+* debug print flags, if flags .ne. 0 then execute debug code
+ integer*4 sdebugprintrawdc
+ integer*4 sdebugprintdecodeddc
+ integer*4 sdebugflagpsi
+ integer*4 sdebugflaggeometry
+ integer*4 sdebugflagpr
+ integer*4 sdebugflagstubs
+ integer*4 sdebuglinkstubs
+ integer*4 sdebugtrackprint
+ integer*4 sdebugstubchisq
+ integer*4 sdebugtartrackprint ! call h_print_tar_track
+ integer*4 sdebugdumptof ! dumps tof fitting data
+ integer*4 sdebugdumpcal ! dumps cal fitting data
+ integer*4 ssingle_stub ! switch to make tracks of all stubs
+ integer*4 ssmallAngleApprox ! switch for alternate L/R determ. of Y,Yprime planes
+ integer*4 s_hms_style_chambers ! Using HMS style drift chambers.
+ integer*4 sluno ! logical unit number for debugging output
+ common/SOS_TRACKFLAGS/
+ & sluno,
+ & sdebugflagpsi,
+ & sdebugflaggeometry,
+ & sdebugflagpr,
+ & sdebugflagstubs,
+ & sdebuglinkstubs,
+ & sdebugtrackprint,
+ & sdebugstubchisq,
+ & sdebugtartrackprint,
+ & sdebugprintrawdc,
+ & sdebugprintdecodeddc,
+ & sdebugdumptof,
+ & sdebugdumpcal,
+ & ssingle_stub,
+ & ssmallAngleApprox,
+ & s_hms_style_chambers
+
+*----------------------------------------------------------------------
+* DRIFT CHAMBER EFFICIENCY MEASUREMENTS.
+*
+* CTPTYPE=parm
+*
+* warning levels for efficiency
+ real*4 sdc_min_plane_eff(smax_num_dc_planes)
+ real*4 sdc_min_wire_eff
+*
+* CTPTYPE=event
+*
+* multiple hits per wire statistics.
+ integer*4 swire_mult(sdc_max_wires_per_plane,smax_num_dc_planes)
+ integer*4 swire_early_mult(sdc_max_wires_per_plane,smax_num_dc_planes)
+ integer*4 swire_late_mult(sdc_max_wires_per_plane,smax_num_dc_planes)
+ integer*4 swire_extra_mult(sdc_max_wires_per_plane,smax_num_dc_planes)
+* stuff for calcualting efficiency per wire.
+ integer*4 sdc_shouldhit(smax_num_dc_planes,sdc_max_wires_per_plane)
+ integer*4 sdc_didhit(smax_num_dc_planes,sdc_max_wires_per_plane)
+ integer*4 sdc_shouldsum(smax_num_dc_planes)
+ integer*4 sdc_didsum(smax_num_dc_planes)
+ integer*4 sdc_eff(smax_num_dc_planes)
+ real*4 sdc_track_coord(sntracks_max,smax_num_dc_planes)
+ real*4 ssdc_track_coord(smax_num_dc_planes)
+
+ common/sos_dc_track_efficiency/
+ & sdc_track_coord, !track position per plane, in x,y,u,v directions.
+ & ssdc_track_coord, !track position in x,y,,u,v directions-final track.
+ & sdc_shouldhit, !times a wire should have fired.
+ & sdc_didhit, !times a wire did fire.
+ & sdc_shouldsum, !sum over plane.
+ & sdc_didsum, !sum over plane.
+ & sdc_eff, !effic. per plane.
+ & sdc_min_wire_eff, !warning level for wire effic.
+ & sdc_min_plane_eff, !warning level for plane effic.
+ & swire_mult,
+ & swire_early_mult,
+ & swire_late_mult,
+ & swire_extra_mult
+
+
+*----------------------------------------------------------------------
+* DRIFT CHAMBER RESIDUALS
+*
+* CTPTYPE=event
+*
+* complete 2-D array for residuals in all planes over all tracks
+ real*4 sdc_single_residual(sntracks_max,smax_num_dc_planes)
+ real*4 sdc_double_residual(sntracks_max,smax_num_dc_planes)
+
+* djm 8/26/94 arrays containing single and double residual arrays which can be
+* histogrammed in the normal fashion (ie, not hardwired histograms).
+
+ real*4 sdc_sing_res(smax_num_dc_planes)
+ real*4 sdc_dbl_res(smax_num_dc_planes)
+ real*4 sdc_plane_wirecoord(sntracks_max,smax_num_dc_planes)
+ real*4 sdc_plane_wirecenter(sntracks_max,smax_num_dc_planes)
+
+ common/SOS_RESIDUAL/
+ & sdc_single_residual,
+ & sdc_double_residual,
+ & sdc_sing_res,
+ & sdc_dbl_res,
+ & sdc_plane_wirecoord,
+ & sdc_plane_wirecenter
+
+
+*----------------------------------------------------------------------
+* DEADWIRE LIST
+*
+* CTPTYPE=parm
+*
+ integer*4 smax_num_deadwires
+ parameter (smax_num_deadwires=60)
+ integer*4 sdc_num_deadwires
+ integer*4 sdc_deadwire_plane(smax_num_deadwires)
+ integer*4 sdc_deadwire_num(smax_num_deadwires)
+
+ common/sos_dead_wires/
+ & sdc_num_deadwires, !number of dead wires.
+ & sdc_deadwire_plane, !list of plane numbers.
+ & sdc_deadwire_num !list of wire numbers.
+
+*
+* CTPTYPE=parm
+*
+ logical s1hit1,s1hit2,s1hit3,s1hit4,s1hit5,s1hit6
+ logical s1hit7,s1hit8,s1hit9,s1hit10,s1hit11,s1hit12
+ integer snumhit1,snumhit2,snumhit3,snumhit4,snumhit5,snumhit6
+ integer snumhit7,snumhit8,snumhit9,snumhit10,snumhit11,snumhit12
+ logical s1hitslt,s2hitslt,s1planesgt,s2planesgt
+ logical shitslt,splanesgt
+ logical sstublt
+ logical f1sspacepoints,f2sspacepoints,fsspacepoints
+ logical shitsplanes,shitsplanessps,shitsplanesspsstubs
+ logical sspacepoints
+ logical stest1,stest2
+ logical sfoundtrack, scleantrack
+ integer snumhits1,snumhits2,snumplanes1,snumplanes2
+ integer snumscins1,snumscins2,snumscins3,snumscins4
+ integer sstubtest
+ real*4 sstubminx,sstubminy,sstubminxp,sstubminyp
+ integer sscinhit(4,16)
+ integer snclust(4)
+ integer sthreescin(4)
+ integer sslope
+ integer sbestxpscin
+ integer sbestypscin
+ integer sgoodscinhits
+ integer sxloscin(smax_num_chambers),sxhiscin(smax_num_chambers)
+ integer syloscin(smax_num_chambers),syhiscin(smax_num_chambers)
+ integer strack_eff_test_num_scin_planes
+
+ common/dereks_sos_track_tests/
+ & s1hit1,
+ & s1hit2,
+ & s1hit3,
+ & s1hit4,
+ & s1hit5,
+ & s1hit6,
+ & s1hit7,
+ & s1hit8,
+ & s1hit9,
+ & s1hit10,
+ & s1hit11,
+ & s1hit12,
+ & snumhit1,snumhit2,snumhit3,snumhit4,snumhit5,snumhit6,
+ & snumhit7,snumhit8,snumhit9,snumhit10,snumhit11,snumhit12,
+ & s1hitslt,
+ & s2hitslt,
+ & s1planesgt,
+ & s2planesgt,
+ & shitslt,
+ & splanesgt,
+ & sstublt,
+ & f1sspacepoints,
+ & f2sspacepoints,
+ & fsspacepoints,
+ & shitsplanes,
+ & shitsplanessps,
+ & shitsplanesspsstubs,
+ & sspacepoints,
+ & stest1,stest2,
+ & sfoundtrack,
+ & scleantrack,
+ & snumhits1,snumhits2,snumplanes1,snumplanes2,
+ & snumscins1,snumscins2,snumscins3,snumscins4,
+ & sstubtest,
+ & sstubminx,
+ & sstubminy,
+ & sstubminxp,
+ & sstubminyp,
+ & sscinhit,
+ & snclust,
+ & sthreescin,
+ & sslope,
+ & sbestxpscin,
+ & sbestypscin,
+ & sgoodscinhits,
+ & sxloscin,sxhiscin,syloscin,syhiscin,
+ & strack_eff_test_num_scin_planes
diff --git a/ONEEV/CVS/Entries b/ONEEV/CVS/Entries
new file mode 100644
index 0000000..2aa0481
--- /dev/null
+++ b/ONEEV/CVS/Entries
@@ -0,0 +1,36 @@
+/Makefile/1.1/Mon Dec 7 22:11:25 1998//Tsane
+/Makefile.Unix/1.13/Fri Feb 14 18:25:17 2003//Tsane
+/evdisplay.f/1.7/Tue Dec 1 21:47:10 1998//Tsane
+/g_uglast.f/1.1/Tue Mar 14 21:27:32 1995//Tsane
+/g_ugsvolu.f/1.1/Tue Mar 14 21:27:25 1995//Tsane
+/glvolu.f/1.2/Wed Sep 4 19:46:28 1996//Tsane
+/h_one_ev_cal.f/1.3/Fri Nov 22 15:36:14 1996//Tsane
+/h_one_ev_det_reset.f/1.2/Mon Sep 18 13:53:01 1995//Tsane
+/h_one_ev_detectors.f/1.2/Mon Sep 18 14:38:33 1995//Tsane
+/h_one_ev_display.f/1.5/Wed Jan 17 16:31:18 1996//Tsane
+/h_one_ev_generate.f/1.2/Wed Sep 4 20:06:16 1996//Tsane
+/h_one_ev_geometry.f/1.8/Fri Nov 22 15:36:37 1996//Tsane
+/h_one_ev_head_view.f/1.1/Mon Sep 18 14:43:31 1995//Tsane
+/h_one_ev_hodo.f/1.3/Fri Nov 22 15:37:36 1996//Tsane
+/h_one_ev_persp_view.f/1.1/Mon Sep 18 14:44:02 1995//Tsane
+/h_one_ev_topside_view.f/1.1/Wed Jan 17 16:35:46 1996//Tsane
+/h_one_ev_track.f/1.1/Wed Jan 17 16:39:41 1996//Tsane
+/h_one_ev_wc.f/1.2/Wed Jan 17 16:39:33 1996//Tsane
+/h_uginit.f/1.1/Tue Mar 14 21:27:13 1995//Tsane
+/revdis_ask.f/1.1/Wed Jan 17 16:31:52 1996//Tsane
+/revdis_getev.f/1.2/Wed Jan 17 16:32:49 1996//Tsane
+/revdis_init.f/1.4/Fri Feb 14 18:27:22 2003//Tsane
+/s_one_ev_cal.f/1.3/Fri Nov 22 15:35:56 1996//Tsane
+/s_one_ev_det_reset.f/1.2/Wed Jan 17 16:40:27 1996//Tsane
+/s_one_ev_detectors.f/1.2/Mon Sep 18 14:38:09 1995//Tsane
+/s_one_ev_display.f/1.3/Wed Jan 17 16:31:33 1996//Tsane
+/s_one_ev_generate.f/1.2/Wed Sep 4 20:06:35 1996//Tsane
+/s_one_ev_geometry.f/1.5/Fri Nov 22 15:37:10 1996//Tsane
+/s_one_ev_head_view.f/1.1/Mon Sep 18 14:43:39 1995//Tsane
+/s_one_ev_hodo.f/1.3/Fri Nov 22 15:38:35 1996//Tsane
+/s_one_ev_persp_view.f/1.2/Wed Jan 17 16:38:44 1996//Tsane
+/s_one_ev_topside_view.f/1.1/Wed Jan 17 16:37:05 1996//Tsane
+/s_one_ev_track.f/1.1/Wed Jan 17 16:38:09 1996//Tsane
+/s_one_ev_wc.f/1.1/Wed Jan 17 16:38:04 1996//Tsane
+/s_uginit.f/1.1/Mon Jul 31 15:15:28 1995//Tsane
+D
diff --git a/ONEEV/CVS/Repository b/ONEEV/CVS/Repository
new file mode 100644
index 0000000..ca873e1
--- /dev/null
+++ b/ONEEV/CVS/Repository
@@ -0,0 +1 @@
+Analyzer/ONEEV
diff --git a/ONEEV/CVS/Root b/ONEEV/CVS/Root
new file mode 100644
index 0000000..6288c3f
--- /dev/null
+++ b/ONEEV/CVS/Root
@@ -0,0 +1 @@
+whit@cvs.jlab.org:/group/hallc/cvsroot
diff --git a/ONEEV/CVS/Tag b/ONEEV/CVS/Tag
new file mode 100644
index 0000000..25d73f7
--- /dev/null
+++ b/ONEEV/CVS/Tag
@@ -0,0 +1 @@
+Tsane
diff --git a/ONEEV/Makefile b/ONEEV/Makefile
new file mode 100644
index 0000000..b9ffac3
--- /dev/null
+++ b/ONEEV/Makefile
@@ -0,0 +1,8 @@
+#
+# $Log: Makefile,v $
+# Revision 1.1 1998/12/07 22:11:25 saw
+# Initial setup
+#
+ETC=../etc
+
+include $(ETC)/Makefile.NEW
diff --git a/ONEEV/Makefile.Unix b/ONEEV/Makefile.Unix
new file mode 100644
index 0000000..36358de
--- /dev/null
+++ b/ONEEV/Makefile.Unix
@@ -0,0 +1,183 @@
+#
+# $Log: Makefile.Unix,v $
+# Revision 1.13 2003/02/14 18:25:17 jones
+# added if statements for Alpha OSF1 systems (E. Brash)
+#
+# Revision 1.12 1999/11/04 20:36:11 saw
+# Linux/G77 compatibility fixes
+#
+# Revision 1.11 1999/03/19 15:23:16 saw
+# Fix CTP library ordering so that event display links on SunOS.
+#
+# Revision 1.10 1998/12/09 16:31:16 saw
+# Remove dependence on Csoft environment variable
+#
+# Revision 1.9 1998/12/01 20:34:21 saw
+# (SAW) HPUX 10 fix
+#
+# Revision 1.8 1996/11/22 17:05:00 saw
+# (SAW) Add SunOS compatibility
+#
+# Revision 1.7 1996/09/04 16:37:02 saw
+# (SAW) New makefile style
+#
+# Revision 1.6 1996/01/17 20:25:00 saw
+# (SAW) Remove gmc library from DEPLIBS
+#
+# Revision 1.5 1996/01/17 16:28:36 cdaq
+# (SAW) New filenames
+#
+# Revision 1.4 1995/07/20 19:21:12 cdaq
+# (SAW) Add OTHERLIBS definition for IRIX
+#
+# Revision 1.3 1995/05/24 14:02:20 cdaq
+# *** empty log message ***
+#
+# Revision 1.2 1995/03/13 19:54:10 cdaq
+# (SAW) Add -f switch on include file copy commands
+#
+# Revision 1.1 1995/01/27 20:49:35 cdaq
+# Initial revision
+#
+NEWSTYLE = 1
+include ../../etc/Makefile
+
+oneev_sources = evdisplay.f revdis_getev.f revdis_init.f revdis_ask.f \
+ g_ugsvolu.f g_uglast.f glvolu.f
+
+hms_sources = h_one_ev_detectors.f h_one_ev_geometry.f \
+ h_one_ev_display.f h_one_ev_det_reset.f h_uginit.f \
+ h_one_ev_cal.f h_one_ev_hodo.f h_one_ev_wc.f \
+ h_one_ev_head_view.f h_one_ev_persp_view.f h_one_ev_topside_view.f \
+ h_one_ev_track.f h_one_ev_generate.f
+sos_sources = s_one_ev_detectors.f s_one_ev_geometry.f \
+ s_one_ev_display.f s_one_ev_det_reset.f s_uginit.f \
+ s_one_ev_cal.f s_one_ev_hodo.f s_one_ev_wc.f \
+ s_one_ev_head_view.f s_one_ev_persp_view.f s_one_ev_topside_view.f \
+ s_one_ev_track.f s_one_ev_generate.f
+
+sources = $(oneev_sources) $(hms_sources) $(sos_sources)
+
+libsources = $(sources)
+
+lib_targets := $(patsubst %.f, liboneev.a(%.o), $(libsources))
+
+#install-dirs := lib bin
+install-dirs := lib
+
+bin_targets = evdisplay
+
+ONEEVLIB = $(LIBROOT)/liboneev.a
+
+DEPLIBS = $(LIBROOT)/libengine.a \
+ $(LIBROOT)/libhtracking.a $(LIBROOT)/libstracking.a \
+ $(LIBROOT)/libtracking.a $(LIBROOT)/libhack.a \
+ $(LIBROOT)/libutils.a
+
+CTPCLIENT = $(LIBROOT)/libctpclient.a
+CTP = $(LIBROOT)/libctp.a
+
+GEANTVER = 321
+CERNLIBS = -lgeant$(GEANTVER) -lpawlib -lgraflib -lgrafX11 -lpacklib -lmathlib
+ifeq ($(ARCH),HPUX)
+ FFLAGS = -g +ppu +es -O +Onolimit +O2 +FPVZOU
+ OTHERLIBS = -Wl,-L$(LIBROOT) -lctpclient -lctp -Wl,-L$(CODA)/HP_UX/lib \
+ -Wl,-L$(CERN_ROOT)/lib $(CERNLIBS) \
+ -Wl,-L/usr/lib/X11R5 -lX11 -lm
+
+endif
+
+ifeq ($(ARCH),IRIX)
+ OTHERLIBS = -L$(LIBROOT) -lctpclient -lctp \
+ -L$(CERN_ROOT)/lib $(CERNLIBS) \
+ -L/usr/lib -lX11 -lm
+endif
+
+ifeq ($(ARCH),ULTRIX)
+ OTHERLIBS = -L$(CODA)/ULTRIX/lib \
+ -lana -lmsg -lcoda -L$(CERN_ROOT)/lib $(CERNLIBS) -L/usr/lib -lX11 -lm
+endif
+
+ifeq ($(ARCH),OSF1)
+ OTHERLIBS = -L$(CERN_ROOT)/lib $(CERNLIBS) -L/usr/lib -lX11 -lm
+endif
+
+ifeq ($(ARCH),SunOS)
+ OTHERLIBS = -L$(LIBROOT) -lctpclient -lctp -L$(CERN_ROOT)/lib $(CERNLIBS) \
+ -lnsl -lsocket -lX11
+endif
+
+ifeq ($(ARCH),AIX)
+ OTHERLIBS = -L$(LIBROOT) -lctpclient -lctp \
+ -L$(CERN_ROOT)/lib $(CERNLIBS) -lX11
+endif
+
+ifeq ($(ARCH),Linux)
+ CERN_ROOT = /usr/local/cernlib/95b
+ CERNLIBS = -lgeant$(GEANTVER) -lpawlib -lgraflib -lgrafX11 -lmathlib -lpacklib -lkernlib -lmathlib -lpacklib
+ OTHERLIBS = -L$(LIBROOT) -lctpclient -lctp -L$(CERN_ROOT)/lib \
+ $(CERNLIBS) -L/usr/X11/lib -lX11 -lm
+ DEPLIBS := $(DEPLIBS) $(LIBROOT)/libport.a
+
+$(LIBROOT)/libport.a:
+ @make -C $(Csoft)/SRC/PORT
+
+endif
+
+# Rules to make ENGINE source files that must be tweaked
+#
+#engine_display: engine.o $(ONEEVLIB) $(DEPLIBS)
+# $(F77) $(FFLAGS) -o engine_display engine.o -u g_register_variables.o \
+# -u g_initialize.o -u h_initialize.o $(ONEEVLIB) $(DEPLIBS) \
+# $(OTHERLIBS)
+
+evdisplay: evdisplay.o $(ONEEVLIB) $(DEPLIBS) $(CTPCLIENT) $(CTP)
+ $(F77) $(FFLAGS) -o evdisplay evdisplay.o \
+ $(ONEEVLIB) $(DEPLIBS) \
+ $(OTHERLIBS)
+
+#h_initialize.f: ../ENGINE/h_initialize.f
+# @sed -e 's/*ONEEV//' $< >$@
+# May want to remove ntuple init stuff
+
+#
+# Rule for making the register subroutines
+#
+#r_%.f : %.cmn $(MAKEREG)
+# $(MAKEREG) $< -o $@ -e /dev/null
+
+#%.f : %.F
+# $(F77) -F -DHDISPLAY $<
+
+#.PRECIOUS: r_%.f
+
+ifdef NFSDIRECTORY
+../%.f : $(NFSDIRECTORY)/ONEEV/%.f
+ ln -s $< $@
+
+.PRECIOUS: ../%.f
+endif
+#
+# Get include files from INCLUDE directory
+#
+
+%.cmn :: ../../INCLUDE/%.cmn
+ $(CP) $< $@
+ $(CP) $< ../$@
+
+%.dec :: ../../INCLUDE/%.dec
+ $(CP) $< $@
+ $(CP) $< ../$@
+
+%.par :: ../../INCLUDE/%.par
+ $(CP) $< $@
+ $(CP) $< ../$@
+
+%.dte :: ../../INCLUDE/%.dte
+ $(CP) $< $@
+ $(CP) $< ../$@
+
+include $(sources:.f=.d)
+
+
+
diff --git a/ONEEV/evdisplay.f b/ONEEV/evdisplay.f
new file mode 100644
index 0000000..b866007
--- /dev/null
+++ b/ONEEV/evdisplay.f
@@ -0,0 +1,275 @@
+*--------------------------------------------------------------
+*
+*- standalone DISPLAY for hall C
+*
+* $Log: evdisplay.f,v $
+* Revision 1.7 1998/12/01 21:47:10 saw
+* (SAW) Put correct number of arguments in g_rep_err call
+*
+* Revision 1.6 1996/11/22 15:53:10 saw
+* (SAW) Fix typo
+*
+* Revision 1.5 1996/09/04 16:40:13 saw
+* (SAW) Reorder data statements for f2c compatibility
+*
+* Revision 1.4 1996/01/24 16:28:28 saw
+* (DVW) Add code for automatic redisplay mode
+*
+* Revision 1.3 1996/01/17 16:30:02 cdaq
+* (SAW) Adjust RPC nums for new online analyzer (DD system).
+* Add menu for view selection
+*
+* Revision 1.2 1995/09/18 13:47:44 cdaq
+* (DVW, SAW) Reorganize
+*
+* Revision 1.1 1995/03/14 21:25:27 cdaq
+* Initial revision
+*
+*--------------------------------------------------------------
+ IMPLICIT NONE
+*
+ character*9 here
+ parameter (here= 'evdisplay')
+*
+ INCLUDE 'gen_pawspace.cmn'
+*
+ INCLUDE 'gen_filenames.cmn'
+*
+ INCLUDE 'gen_run_info.cmn'
+ INCLUDE 'gen_event_info.cmn'
+*
+ INCLUDE 'gen_one_ev_info.cmn'
+*
+ logical FAIL,QUIT
+ character*800 why
+ character*132 line
+ logical ABORT
+ character*800 err
+ integer i,j
+*
+ integer*4 dispmode ! to display every 10 seconds or not
+ character*1 spect
+ integer*4 view, newview
+ integer*4 revdis_ask
+ logical isdata
+ INCLUDE 'gen_one_ev_info.dte'
+*******************************************************************
+*
+ PRINT *
+ PRINT *,' Standalone DISPLAY for hall C'
+ PRINT *,' R.Ent,S.Wood, & K.Beard Oct.1994'
+ PRINT *,' and Derek van Westrum Jul 1995'
+ PRINT *
+ PRINT *,'****************************************************'
+ PRINT *,'* *'
+ PRINT *,'* Confused? Don''t be. Read the file *'
+ PRINT *,'* *'
+ PRINT *,'* ~cdaq/documents/analysis_code/evdisplay.help *'
+ PRINT *,'* *'
+ PRINT *,'****************************************************'
+ PRINT *
+ PRINT *,' 0: Connect to offline replay'
+ PRINT *,' 1: Connect online analyzer'
+ PRINT *,' Other: A non-default RPC Program ID and version'
+ READ(5,'(2i30)') i,j
+ if(i.eq.0) then
+ gen_display_server_RPCprgmID = '2c0daFF8'x !default offline
+ gen_display_server_RPCversionID = 1 ! default offline
+ call getenv("HOST",gen_display_server_machine)
+ else if(i.eq.1) then
+c gen_display_server_RPCprgmID = '2c0da005'x !default online
+ gen_display_server_RPCprgmID = '2c0daFF8'x !default online
+ gen_display_server_RPCversionID = 2 ! default online
+ gen_display_server_machine = 'cdaq2.cebaf.gov'
+ else
+ gen_display_server_RPCprgmID = i
+ gen_display_server_RPCversionID = j
+ call getenv("HOST",gen_display_server_machine)
+ endif
+*
+ PRINT *
+ PRINT *,' 0: to choose events manually (default)'
+ PRINT *,' 1: to display every 10 seconds'
+ READ(5,'(i)') dispmode
+ IF (dispmode.NE.1) dispmode=0
+
+ PRINT *
+ PRINT *,' Enter the name of the machine running "engine" or CODA:'
+ i=index(gen_display_server_machine,' ')
+ if(i.gt.1) i = i-1
+ WRITE(6,'($,a)') '[cdaq1,cdaq2,hallc1,hallc2,cebafh, ... ['//
+ $ gen_display_server_machine(1:i)//']: '
+ READ(5,'(a)') line
+ IF(line.EQ.' '.and.gen_display_server_machine.eq.' ') THEN
+ why= ':machine name must be specified!'
+ call G_add_path(here,why)
+ call G_rep_err(.TRUE.,why)
+ STOP
+ ELSE if(line.ne.' ') then
+ call NO_comments(line)
+ gen_display_server_machine= line
+ ENDIF
+*
+ 100 print *
+ print *, 'Type "h" for the HMS, or "s" for the SOS:'
+ read *, spect
+ if(spect.eq.'S') spect='s'
+ if(spect.eq.'H') spect='h'
+ if ((spect .ne. 's') .and. (spect .ne. 'h')) then
+ print*, 'Invalid option. Please type "h" or "s".'
+ goto 100
+ endif
+*
+ print *,"Server Program #=",gen_display_server_RPCprgmID
+*
+ PRINT *
+ PRINT *,' display type? [1= Xwindow[def.], 7878=GraphOn]'
+ READ(5,'(i30)') graph_io_dev
+ if(graph_io_dev.eq.0) graph_io_dev = 1
+*
+ call G_register_variables(FAIL,why)
+ IF(FAIL) THEN
+ call G_add_path(here,why)
+ call G_rep_err(FAIL,why)
+ STOP
+ ENDIF
+ PRINT *,' G_register_variables OK'
+ PRINT *
+* CALL r_one_ev_io
+
+*
+*
+*
+*
+ call revdis_init(FAIL,why) ! Build lists of variables to get
+
+ IF(FAIL) THEN
+ call G_add_path(here,why)
+ call G_rep_err(FAIL,why)
+ STOP
+ ELSE IF(g_config_filename.EQ.' ') THEN
+ PRINT *
+ PRINT *,' rpc/CTP FAILURE TO COMMUNICATE!'
+ PRINT *
+ STOP
+ ENDIF
+
+*
+*
+* Do the initialization that g_initialize was supposed to do
+*
+ call GZEBRA(NGBANK)
+ call hlimit (-NHBOOK) ! init HBOOK memory
+ if (spect .eq. 'h') then
+ call h_initialize(ABORT,err)
+ elseif (spect .eq. 's') then
+ call s_initialize(ABORT,err)
+ endif
+* call c_initialize(ABORT,err)
+ call g_reset_event(ABORT,err)
+*
+ if(graph_io_dev .ne. 0) call hplint(graph_io_dev)
+ if (graph_io_dev .eq. 0) then
+ call hplint(0) ! init graphics
+ call igmeta(-8,-111) ! init HIGZ meta junk
+ endif
+
+ if (spect .eq. 'h') then
+ CALL h_uginit
+ elseif (spect .eq. 's') then
+ CALL s_uginit
+ endif
+*
+ PRINT *,' Connected to a Hall C analyzer at '
+ $ ,gen_display_server_machine(1:30)
+ print *,' Server analyzer has the label'
+ print *,' '
+ print *,g_label
+ print *,' '
+ PRINT *,' ............begin loop......................'
+ print *,' '
+ print *,' '
+*
+ QUIT= .FALSE.
+
+ view = 1
+ isdata = .false.
+
+ if(dispmode.ne.1) then
+ DO WHILE (.NOT.QUIT)
+*
+ PRINT *,'Run Number = ',gen_run_number,
+ $ ' Event Number = ',gen_event_ID_number
+ PRINT *,' Enter a CTP condition for the next event (?=help,1=any).'
+ newview = revdis_ask(view)
+ if(newview.lt.0) then
+ QUIT = .TRUE.
+ isdata = .false. ! Don't try to view
+ else if(newview.eq.0) then ! Get a new event
+ call revdis_getev(FAIL,why)
+ If(FAIL) Then
+ call G_rep_err(FAIL,why)
+ Endif
+ write(6,'("Run",i6,", event ID",i7," sequence",i7)')
+ $ gen_run_number,gen_event_ID_number, gen_event_sequence_N
+ if(spect.eq.'h') then
+ call h_one_ev_generate
+ else if(spect.eq.'s') then
+ call s_one_ev_generate
+ endif
+ isdata = .true.
+ else
+ view = newview
+ endif
+ if(isdata) then ! There is an event to display
+ if(spect.eq.'h') then
+ call h_one_ev_display(view)
+ else if(spect.eq.'s') then
+ call s_one_ev_display(view)
+ endif
+ endif
+*
+ ENDDO
+ elseif (dispmode.EQ.1) then
+ DO WHILE (.NOT.QUIT)
+ call system('sleep 5')
+*
+ PRINT *,'Run Number = ',gen_run_number,
+ $ ' Event Number = ',gen_event_ID_number
+ PRINT *,' Enter a CTP condition for the next event (?=help,1=any).'
+* newview = revdis_ask(view)
+ newview = 0
+ if(newview.lt.0) then
+ QUIT = .TRUE.
+ isdata = .false. ! Don't try to view
+ else if(newview.eq.0) then ! Get a new event
+ call revdis_getev(FAIL,why)
+ If(FAIL) Then
+ call G_rep_err(FAIL,why)
+ Endif
+ write(6,'("Run",i6,", event ID",i7," sequence",i7)')
+ $ gen_run_number,gen_event_ID_number, gen_event_sequence_N
+ if(spect.eq.'h') then
+ call h_one_ev_generate
+ else if(spect.eq.'s') then
+ call s_one_ev_generate
+ endif
+ isdata = .true.
+ else
+ view = newview
+ endif
+ if(isdata) then ! There is an event to display
+ if(spect.eq.'h') then
+ call h_one_ev_display(view)
+ else if(spect.eq.'s') then
+ call s_one_ev_display(view)
+ endif
+ endif
+*
+ ENDDO
+ endif
+*
+ 99 continue
+ call IGEND !properly terminate HIGZ and any&all metafiles
+ STOP
+ END
diff --git a/ONEEV/g_uglast.f b/ONEEV/g_uglast.f
new file mode 100644
index 0000000..71add6f
--- /dev/null
+++ b/ONEEV/g_uglast.f
@@ -0,0 +1,18 @@
+ subroutine g_uglast
+*
+* This routine cleans up after GEANT
+*
+* August, 1994, Pat Welch, Oregon State University, tpw@physics.orst.edu
+*
+* $Log: g_uglast.f,v $
+* Revision 1.1 1995/03/14 21:27:32 cdaq
+* Initial revision
+*
+
+ implicit none
+
+ call glast ! print statistics and histograms
+
+ call igend ! close HIGZ files
+
+ end
diff --git a/ONEEV/g_ugsvolu.f b/ONEEV/g_ugsvolu.f
new file mode 100644
index 0000000..956ffad
--- /dev/null
+++ b/ONEEV/g_ugsvolu.f
@@ -0,0 +1,34 @@
+ subroutine g_ugsvolu (name, shape, nmed, par, npar, ivolu)
+*
+* Simple interface to gsvolu which checks for error conditions on return
+* See page GEOM 100-1 in GEANT manual
+*
+* 1992, Pat Welch, Oregon State University, tpw@physics.orst.edu
+*
+* $Log: g_ugsvolu.f,v $
+* Revision 1.1 1995/03/14 21:27:25 cdaq
+* Initial revision
+*
+
+ implicit none
+
+ character*4 name ! Unique name for this volume
+ character*4 shape ! Geometric shape for this volume
+ integer*4 nmed ! Tracking medium
+ integer*4 npar ! Number of user parameters for this vol
+ real*4 par(npar) ! User parameters for this volume
+ integer*4 ivolu ! system volume number returned
+
+ call gsvolu (name, shape, nmed, par, npar, ivolu)
+
+ if (ivolu .le. 0) then
+ write (*,*) ' ERROR: gsvolu returned an error!'
+ write (*,*) ' name ', name, ' shape ', shape
+ write (*,*) ' nmed ', nmed, ' npar ', npar, ' ivolu ', ivolu
+ if (npar .gt. 0) then
+ write (*,*)' par(i) ', par
+ endif
+ endif
+
+ end
+
diff --git a/ONEEV/glvolu.f b/ONEEV/glvolu.f
new file mode 100644
index 0000000..80c187f
--- /dev/null
+++ b/ONEEV/glvolu.f
@@ -0,0 +1,538 @@
+ SUBROUTINE GLVOLU (NLEV, LNAM, LNUM, IER)
+* $Log: glvolu.f,v $
+* Revision 1.2 1996/09/04 19:46:28 saw
+* (SAW) Comment out debugging statement
+*
+* Revision 1.1 1996/01/17 16:30:34 cdaq
+* Initial revision
+*
+C.
+C. ******************************************************************
+C. * *
+C. * Loads the common block GCVOLU for the volume at lebel NLEV *
+C. * as described by the lists of names (LNAM) and numbers (LNUM) *
+C. * *
+C. * The routine is optimized and does not re-compute the part of *
+C. * history already available in GCVOLU. *
+C. * *
+C. * IER returns non zero in case of fatal error *
+C. * *
+C. * Called by : 'User', GDRVOL *
+C. * Authors : S.Banerjee, F.Bruyant, A.McPherson *
+C. * *
+C. ******************************************************************
+C.
+*KEEP,GCBANK.
+ INTEGER IQ,LQ,NZEBRA,IXSTOR,IXDIV,IXCONS,LMAIN,LR1,JCG
+ INTEGER KWBANK,KWWORK,IWS
+ REAL GVERSN,ZVERSN,FENDQ,WS,Q
+C
+ PARAMETER (KWBANK=69000,KWWORK=5200)
+ COMMON/GCBANK/NZEBRA,GVERSN,ZVERSN,IXSTOR,IXDIV,IXCONS,FENDQ(16)
+ + ,LMAIN,LR1,WS(KWBANK)
+ DIMENSION IQ(7992),Q(7992),LQ(8000),IWS(2)
+ EQUIVALENCE (Q(1),IQ(1),LQ(9)),(LQ(1),LMAIN),(IWS(1),WS(1))
+ EQUIVALENCE (JCG,JGSTAT)
+ INTEGER JDIGI ,JDRAW ,JHEAD ,JHITS ,JKINE ,JMATE ,JPART
+ + ,JROTM ,JRUNG ,JSET ,JSTAK ,JGSTAT,JTMED ,JTRACK,JVERTX
+ + ,JVOLUM,JXYZ ,JGPAR ,JGPAR2,JSKLT
+C
+ COMMON/GCLINK/JDIGI ,JDRAW ,JHEAD ,JHITS ,JKINE ,JMATE ,JPART
+ + ,JROTM ,JRUNG ,JSET ,JSTAK ,JGSTAT,JTMED ,JTRACK,JVERTX
+ + ,JVOLUM,JXYZ ,JGPAR ,JGPAR2,JSKLT
+C
+*KEEP,GCONSP.
+ DOUBLE PRECISION PI,TWOPI,PIBY2,DEGRAD,RADDEG,CLIGHT,BIG,EMASS
+ DOUBLE PRECISION EMMU,PMASS,AVO
+*
+ PARAMETER (PI=3.14159265358979324D0)
+ PARAMETER (TWOPI=6.28318530717958648D0)
+ PARAMETER (PIBY2=1.57079632679489662D0)
+ PARAMETER (DEGRAD=0.0174532925199432958D0)
+ PARAMETER (RADDEG=57.2957795130823209D0)
+ PARAMETER (CLIGHT=29979245800.D0)
+ PARAMETER (BIG=10000000000.D0)
+ PARAMETER (EMASS=0.0005109990615D0)
+ PARAMETER (EMMU=0.105658387D0)
+ PARAMETER (PMASS=0.9382723128D0)
+ PARAMETER (AVO=0.60221367D0)
+*
+*KEEP,GCUNIT.
+ COMMON/GCUNIT/LIN,LOUT,NUNITS,LUNITS(5)
+ INTEGER LIN,LOUT,NUNITS,LUNITS
+ COMMON/GCMAIL/CHMAIL
+ CHARACTER*132 CHMAIL
+C
+*KEEP,GCVOLU.
+ COMMON/GCVOLU/NLEVEL,NAMES(15),NUMBER(15),
+ +LVOLUM(15),LINDEX(15),INFROM,NLEVMX,NLDEV(15),LINMX(15),
+ +GTRAN(3,15),GRMAT(10,15),GONLY(15),GLX(3)
+C
+ INTEGER NLEVEL,NAMES,NUMBER,LVOLUM,LINDEX,INFROM,NLEVMX,
+ + NLDEV,LINMX
+ REAL GTRAN,GRMAT,GONLY,GLX
+*KEND.
+ PARAMETER (NLVMAX=15)
+ INTEGER LNUM(*), LNAM(*), IDTYP(3,12)
+ DIMENSION LVOLS(NLVMAX), LINDX(NLVMAX)
+ REAL XC(3)
+ CHARACTER*4 KNAME
+ SAVE IDTYP
+C.
+ DATA IDTYP / 1, 1, 1, 0, 1, 1, 0, 0, 1, 0, 0, 1, 2, 3, 1,
+ + 2, 3, 1, 2, 3, 1, 2, 3, 1, 2, 4, 3, 1, 1, 1,
+ + 2, 3, 1, 2, 3, 1/
+C.
+C. ------------------------------------------------------------------
+*
+ IER = 0
+ NLEVL=NLEV
+ IF (NLEVL.LE.0.OR.NLEVL.GT.NLVMAX) GO TO 910
+ IF (JGPAR.EQ.0) THEN
+ CALL MZBOOK (IXCONS, JGPAR, JGPAR, 1, 'GPAR', NLVMAX, 0,
+ + NLVMAX, 2, 0)
+ ENDIF
+ IF (NLEVEL.EQ.0) GO TO 20
+*
+* *** Scan tree from top to bottom to
+* check if some levels are already filled
+*
+ NLMX = MIN (NLEVL, NLEVEL)
+ NLEVEL = 0
+ DO 10 I = 1,NLMX
+ IF (LNAM(I).NE.NAMES(I)) GO TO 15
+ IF (LNUM(I).NE.NUMBER(I)) GO TO 15
+ NLEVEL = NLEVEL +1
+ 10 CONTINUE
+ IF (NLEVL.GT.NLEVEL) GO TO 95
+ nlevel=0
+ 15 IF (NLEVEL.NE.0) GO TO 95
+*
+* *** Special case, first volume
+*
+ 20 IF (JVOLUM.EQ.0) GO TO 920
+c print *,jvolum
+ IF (IQ(JVOLUM+1).EQ.LNAM(1)) THEN
+ IVO = 1
+ ELSE
+ IF (IQ(JVOLUM-1).LE.1) GO TO 920
+ DO 25 IV=2,IQ(JVOLUM-1)
+ IF (IQ(JVOLUM+IV).EQ.LNAM(1)) THEN
+ IVO = IV
+ GO TO 30
+ ENDIF
+ 25 CONTINUE
+ WRITE (CHMAIL, 8000) LNAM(1)
+ CALL GMAIL (0, 0)
+ GO TO 999
+ ENDIF
+ 30 NLEVEL = 1
+ JVO = LQ(JVOLUM-IVO)
+ LVOLUM(NLEVEL) = IVO
+ NAMES(NLEVEL) = IQ(JVOLUM+IVO)
+ NUMBER(NLEVEL) = LNUM(1)
+ GONLY(NLEVEL) = 1.
+ IF (LQ(JVO).EQ.0) THEN
+ NLDEV(1) = NLVMAX
+ ELSE
+ NLDEV(1) = 1
+ ENDIF
+ IF (IVO.EQ.1) THEN
+ LINDEX(NLEVEL) = 1
+ LINMX (NLEVEL) = 1
+ NLDM = 0
+ IQ(JGPAR+NLEVEL) = Q(JVO+5)
+ LQ(JGPAR-NLEVEL) = JVO + 6
+ ELSE
+ CALL UHTOC(NAMES,4,KNAME,4)
+ CALL GLMOTH (KNAME, NUMBER, NLDM, LVOLS, LINDX)
+ IF (NLDM.GT.0) THEN
+ JVOM = LQ(JVOLUM-LVOLS(NLDM))
+ NIN = Q(JVOM+3)
+ IF (NIN.LT.0) THEN
+ LINDEX(NLEVEL) = LNUM(1)
+ ELSE
+ LINMX(NLEVEL) = NIN
+ DO 70 IN = 1, NIN
+ JIN = LQ(JVOM-IN)
+ IF (IFIX(Q(JIN+2)).NE.LVOLUM(1)) GO TO 70
+ IF (IFIX(Q(JIN+3)).NE.LNUM(1)) GO TO 70
+ LINDEX(NLEVEL) = IN
+ GO TO 75
+ 70 CONTINUE
+ GO TO 920
+ ENDIF
+ 75 JPAR = LQ(LQ(JVOLUM-LVOLS(1)))
+ IF (NLDM.GT.1) THEN
+ DO 76 ILEV = 2, NLDM
+ IF (IQ(JPAR+1).EQ.0) THEN
+ JPAR = LQ(JPAR-LINDX(ILEV))
+ IF (JPAR.EQ.0) GO TO 77
+ ELSE IF (IQ(JPAR-3).GT.1) THEN
+ JPAR = LQ(JPAR-LINDX(ILEV))
+ ELSE
+ JPAR = LQ(JPAR-1)
+ ENDIF
+ 76 CONTINUE
+ ENDIF
+ IF (NIN.GT.0) THEN
+ JPAR = LQ(JPAR-IN)
+ IF (JPAR.EQ.0) GO TO 77
+ ELSE
+ NDIV = IQ(JPAR+1)
+ LINMX(NLEVEL) = NDIV
+ IF (LINDEX(1).GT.NDIV) THEN
+ NL1 = 1
+ NAME = IQ(JVOLUM+LVOLS(NLDM))
+ GO TO 950
+ ENDIF
+ IF (IQ(JPAR-3).GT.1) THEN
+ IF (LINDEX(1).GT.0) THEN
+ JPAR = LQ(JPAR-LINDEX(1))
+ ELSE
+ JPAR = LQ(JPAR-1)
+ ENDIF
+ ELSE
+ JPAR = LQ(JPAR-1)
+ ENDIF
+ ENDIF
+ IQ(JGPAR+NLEVEL) = IQ(JPAR+5)
+ LQ(JGPAR-NLEVEL) = JPAR + 5
+ GO TO 78
+ 77 NPAR = Q(JVO+5)
+ IF (NPAR.EQ.0.AND.NIN.GT.0) THEN
+ IQ(JGPAR+NLEVEL) = Q(JIN+9)
+ LQ(JGPAR-NLEVEL) = JIN+9
+ ELSE
+ IQ(JGPAR+NLEVEL) = NPAR
+ LQ(JGPAR-NLEVEL) = JVO + 6
+ ENDIF
+ ELSE
+ LINDEX(NLEVEL) = 1
+ LINMX(NLEVEL) = 1
+ IQ(JGPAR+NLEVEL) = Q(JVO+5)
+ LQ(JGPAR-NLEVEL) = JVO + 6
+ ENDIF
+ ENDIF
+ 78 CONTINUE
+*
+ DO 90 I = 1,3
+ GTRAN(I,1) = 0.
+ DO 80 J = 1,3
+ K = (I-1)*3 +J
+ GRMAT(K,1) = 0.
+ 80 CONTINUE
+ K = I*4 -3
+ GRMAT(K,1) = 1.
+ 90 CONTINUE
+ GRMAT(10,1) = 0.
+ IF (NLEVL.GT.1) THEN
+ GO TO 100
+ ELSE
+ GO TO 990
+ ENDIF
+*
+* *** Check if there are volumes up in the tree where development
+* structure exists
+*
+ 95 IF (LVOLUM(1).EQ.1.OR.NLDEV(1).EQ.1) THEN
+ NLDM = 0
+ ELSE
+ CALL UHTOC(NAMES,4,KNAME,4)
+ CALL GLMOTH (KNAME, NUMBER, NLDM, LVOLS, LINDX)
+ ENDIF
+*
+* ** Next level
+*
+ 100 CONTINUE
+ IVO = LVOLUM(NLEVEL)
+ JVO = LQ(JVOLUM-IVO)
+ NLD = NLDEV(NLEVEL)
+ NIN = Q(JVO+3)
+ IF (NIN.EQ.0) GO TO 930
+ NL1 = NLEVEL +1
+*
+ IF (NIN.GT.0) THEN
+*
+* * Content obtained by positioning
+*
+ DO 110 IN=1,NIN
+ JIN=LQ(JVO-IN)
+ IVOT=Q(JIN+2)
+ IF (IQ(JVOLUM+IVOT).NE.LNAM(NL1)) GO TO 110
+ INUM = Q(JIN+3)
+ IF (INUM.EQ.LNUM(NL1)) GO TO 115
+ 110 CONTINUE
+ GO TO 940
+ 115 IF (NLEVEL.GE.NLD) THEN
+* (case with JVOLUM structure locally developed)
+ JPAR = LQ(LQ(JVOLUM-LVOLUM(NLD)))
+ DO 120 ILEV = NLD, NLEVEL
+ IF (IQ(JPAR+1).EQ.0) THEN
+ IF (ILEV.EQ.NLEVEL) THEN
+ JPAR = LQ(JPAR-IN)
+ ELSE
+ JPAR = LQ(JPAR-LINDEX(ILEV+1))
+ ENDIF
+ IF (JPAR.EQ.0) GO TO 125
+ ELSE IF (IQ(JPAR-3).GT.1) THEN
+ JPAR = LQ(JPAR-LINDEX(ILEV+1))
+ ELSE
+ JPAR = LQ(JPAR-1)
+ ENDIF
+ 120 CONTINUE
+ JPAR = JPAR + 5
+ NPAR = IQ(JPAR)
+ GO TO 130
+ ELSE IF (NLDM.GT.0) THEN
+ JPAR = LQ(LQ(JVOLUM-LVOLS(1)))
+ IF (NLDM.GT.1) THEN
+ DO 121 ILEV = 2, NLDM
+ IF (IQ(JPAR+1).EQ.0) THEN
+ JPAR = LQ(JPAR-LINDX(ILEV))
+ IF (JPAR.EQ.0) GO TO 125
+ ELSE IF (IQ(JPAR-3).GT.1) THEN
+ JPAR = LQ(JPAR-LINDX(ILEV))
+ ELSE
+ JPAR = LQ(JPAR-1)
+ ENDIF
+ 121 CONTINUE
+ ENDIF
+ DO 122 ILEV = 1, NL1
+ IF (IQ(JPAR+1).EQ.0) THEN
+ IF (ILEV.EQ.NL1) THEN
+ JPAR = LQ(JPAR-IN)
+ ELSE
+ JPAR = LQ(JPAR-LINDEX(ILEV))
+ ENDIF
+ IF (JPAR.EQ.0) GO TO 125
+ ELSE IF (IQ(JPAR-3).GT.1) THEN
+ JPAR = LQ(JPAR-LINDEX(ILEV))
+ ELSE
+ JPAR = LQ(JPAR-1)
+ ENDIF
+ 122 CONTINUE
+ JPAR = JPAR + 5
+ NPAR = IQ(JPAR)
+ GO TO 130
+ ENDIF
+* (normal case)
+ 125 JVOT = LQ(JVOLUM-IVOT)
+ NPAR = Q(JVOT+5)
+ IF (NPAR.EQ.0) THEN
+ JPAR = JIN + 9
+ NPAR = Q(JPAR)
+ ELSE
+ JPAR = JVOT + 6
+ ENDIF
+*
+ 130 IROTT = Q(JIN+4)
+ NINSK = NIN
+ GONLY(NL1) = Q(JIN+8)
+ CALL GTRMUL (GTRAN(1,NLEVEL), GRMAT(1,NLEVEL), Q(JIN+5), IROTT
+ +, GTRAN(1,NL1), GRMAT(1,NL1))
+*
+ ELSE
+*
+* * This section for divided objects
+*
+ JDIV = LQ(JVO-1)
+ IVOT = Q(JDIV+2)
+ IF (LNAM(NL1).NE.IQ(JVOLUM+IVOT)) GO TO 960
+ JVOT = LQ(JVOLUM-IVOT)
+ IF (NLEVEL.GT.NLD) THEN
+* (case with JVOLUM structure locally developed)
+ JPAR = LQ(LQ(JVOLUM-LVOLUM(NLD)))
+ DO 135 ILEV = NLD, NLEVEL-1
+ IF (IQ(JPAR+1).EQ.0) THEN
+ JPAR = LQ(JPAR-LINDEX(ILEV+1))
+ IF (JPAR.EQ.0) GO TO 140
+ ELSE IF (IQ(JPAR-3).GT.1) THEN
+ JPAR = LQ(JPAR-LINDEX(ILEV+1))
+ ELSE
+ JPAR = LQ(JPAR-1)
+ ENDIF
+ IF (ILEV.EQ.NLEVEL-1) THEN
+ NDIV = IQ(JPAR+1)
+ ORIG = Q(JPAR+2)
+ STEP = Q(JPAR+3)
+ ENDIF
+ 135 CONTINUE
+ GO TO 145
+ ELSE IF (NLD.EQ.NLEVEL) THEN
+ JPAR = LQ(LQ(JVOLUM-LVOLUM(NLD)))
+ ELSE IF (NLDM.GT.0) THEN
+ JPAR = LQ(LQ(JVOLUM-LVOLS(1)))
+ IF (NLDM.GT.1) THEN
+ DO 136 ILEV = 2, NLDM
+ IF (IQ(JPAR+1).EQ.0) THEN
+ JPAR = LQ(JPAR-LINDX(ILEV))
+ IF (JPAR.EQ.0) GO TO 140
+ ELSE IF (IQ(JPAR-3).GT.1) THEN
+ JPAR = LQ(JPAR-LINDX(ILEV))
+ ELSE
+ JPAR = LQ(JPAR-1)
+ ENDIF
+ 136 CONTINUE
+ ENDIF
+ DO 137 ILEV = 1, NLEVEL
+ IF (IQ(JPAR+1).EQ.0) THEN
+ JPAR = LQ(JPAR-LINDEX(ILEV))
+ IF (JPAR.EQ.0) GO TO 140
+ ELSE IF (IQ(JPAR-3).GT.1) THEN
+ JPAR = LQ(JPAR-LINDEX(ILEV))
+ ELSE
+ JPAR = LQ(JPAR-1)
+ ENDIF
+ IF (ILEV.EQ.NLEVEL) THEN
+ NDIV = IQ(JPAR+1)
+ ORIG = Q(JPAR+2)
+ STEP = Q(JPAR+3)
+ ENDIF
+ 137 CONTINUE
+ GO TO 145
+ ELSE
+ JPAR = 0
+ ENDIF
+* (normal case)
+ 140 NDIV = Q(JDIV+3)
+ ORIG = Q(JDIV+4)
+ STEP = Q(JDIV+5)
+ 145 IN = LNUM(NL1)
+ IF (IN.LT.1.OR.IN.GT.NDIV) THEN
+ NAME = NAMES(NLEVEL)
+ GO TO 950
+ ENDIF
+*
+ IF (JPAR.NE.0) THEN
+ IF (IQ(JPAR-3).GT.1) THEN
+ JPAR = LQ(JPAR-IN)
+ ELSE
+ JPAR = LQ(JPAR-1)
+ ENDIF
+ JPAR = JPAR + 5
+ NPAR = IQ(JPAR)
+ ELSE
+ NPAR = Q(JVOT+5)
+ JPAR = JVOT + 6
+ ENDIF
+ GONLY(NL1) = GONLY(NLEVEL)
+*
+ IAXIS = Q(JDIV+1)
+ ISH = Q(JVO+2)
+ IDT = IDTYP(IAXIS,ISH)
+ NINSK = NDIV
+*
+ IF (IDT.EQ.1) THEN
+ DO 151 I = 1, 3
+ 151 XC(I) = 0.
+ XC(IAXIS) = ORIG + (IN - 0.5) * STEP
+ IF (ISH.EQ.4.OR.(ISH.EQ.10.AND.IAXIS.NE.1)) THEN
+ CALL GCENT (IAXIS, XC)
+ ENDIF
+ IF (GRMAT(10,NLEVEL).EQ.0.0) THEN
+ DO 152 I = 1, 3
+ 152 GTRAN(I,NL1) = GTRAN(I,NLEVEL)+XC(I)
+ DO 153 I = 1, 10
+ 153 GRMAT(I,NL1) = GRMAT(I,NLEVEL)
+ ELSE
+ CALL GTRMUL (GTRAN(1,NLEVEL), GRMAT(1,NLEVEL), XC, 0,
+ + GTRAN(1,NL1), GRMAT(1,NL1))
+ ENDIF
+*
+ ELSE IF (IDT.EQ.3.OR.IDT.EQ.4) THEN
+ IF (IDT.EQ.3) THEN
+ PH0 = DEGRAD * (ORIG + (IN - 0.5) * STEP)
+ CPHR = COS (PH0)
+ SPHR = SIN (PH0)
+ ELSE
+ PH0 = 0.0
+ CPHR = 1.0
+ SPHR = 0.0
+ ENDIF
+ DO 154 I = 1, 3
+ GTRAN(I ,NL1) = GTRAN(I ,NLEVEL)
+ GRMAT(I ,NL1) = GRMAT(I ,NLEVEL)*CPHR
+ + + GRMAT(I+3,NLEVEL)*SPHR
+ GRMAT(I+3,NL1) = GRMAT(I+3,NLEVEL)*CPHR
+ + - GRMAT(I ,NLEVEL)*SPHR
+ GRMAT(I+6,NL1) = GRMAT(I+6,NLEVEL)
+ 154 CONTINUE
+ IF (PH0.EQ.0.0.AND.GRMAT(10,NLEVEL).EQ.0.0) THEN
+ GRMAT(10,NL1) = 0.0
+ ELSE
+ GRMAT(10,NL1) = 1.0
+ ENDIF
+*
+ ELSE
+ DO 155 I = 1, 3
+ 155 GTRAN(I,NL1) = GTRAN(I,NLEVEL)
+ DO 156 I = 1, 10
+ 156 GRMAT(I,NL1) = GRMAT(I,NLEVEL)
+ ENDIF
+ ENDIF
+*
+ 200 LINDEX(NL1) = IN
+ LVOLUM(NL1) = IVOT
+ NAMES(NL1) = LNAM(NL1)
+ NUMBER(NL1) = LNUM(NL1)
+ LINMX(NL1) = NINSK
+ IF (LQ(LQ(JVOLUM-IVOT)).EQ.0) THEN
+ NLDEV(NL1) = NLD
+ ELSE
+ NLDEV(NL1) = NL1
+ ENDIF
+ IQ(JGPAR+NL1) = NPAR
+ LQ(JGPAR-NL1) = JPAR
+ NLEVEL = NL1
+ IF (NLEVEL.EQ.NLEVL) GO TO 990
+ GO TO 100
+*
+* *** Error messages
+*
+ 910 IER = 1
+ WRITE (CHMAIL, 1000) NLEV
+ CALL GMAIL (0, 0)
+ GO TO 999
+*
+ 920 IER = 2
+ WRITE (CHMAIL, 2000) LNAM(1)
+ CALL GMAIL (0, 0)
+ GO TO 999
+*
+ 930 IER = 3
+ WRITE (CHMAIL, 3000) NLEVEL,NLEV,NAMES(NLEVEL)
+ CALL GMAIL (0, 0)
+ GO TO 999
+*
+ 940 IER = 4
+* WRITE (CHMAIL, 4000) LNAM(NL1),NL1,NAMES(NLEVEL)
+* CALL GMAIL (0, 0)
+ GO TO 999
+*
+ 950 IER = 5
+ WRITE (CHMAIL, 5000) NL1,LNUM(NL1),NAME,NDIV
+ CALL GMAIL (0, 0)
+ GO TO 999
+*
+ 960 IER = 6
+ WRITE (CHMAIL, 6000) NL1,LNAM(NL1),IQ(JVOLUM+IVOT)
+ CALL GMAIL (0, 0)
+ GO TO 999
+*
+ 990 CONTINUE
+*
+ 1000 FORMAT (' GLVOLU : called with useless Level # ',I5)
+ 2000 FORMAT (' GLVOLU : Volume ',A4,' not top of tree, or no tree')
+ 3000 FORMAT (' GLVOLU : at Level ',I3,' of ',I3,' there are no',
+ * ' contents for Volume ',A4)
+ 4000 FORMAT (' GLVOLU : Volume ',A4,' for Level ',I3,
+ * ' does not exist in Volume ',A4)
+ 5000 FORMAT (' GLVOLU : at Level ',I3,' asked for #',I3,
+ * ' in divided Volume ',A4,' which has ',I3,' divisions.')
+ 6000 FORMAT (' GLVOLU : at Level ',I3,' user name ',A4,
+ * ' not equal to name ',A4,' of division.')
+ 8000 FORMAT (' GLVOLU : Volume ',A4,' Level 1 does not exist')
+* END GLVOLU
+ 999 END
+
diff --git a/ONEEV/h_one_ev_cal.f b/ONEEV/h_one_ev_cal.f
new file mode 100644
index 0000000..53243d8
--- /dev/null
+++ b/ONEEV/h_one_ev_cal.f
@@ -0,0 +1,51 @@
+ subroutine h_one_ev_cal
+*
+* $Log: h_one_ev_cal.f,v $
+* Revision 1.3 1996/11/22 15:36:14 saw
+* (SAW) Fix some error messages at startup, some code cleanup
+*
+* Revision 1.2 1996/06/13 13:03:49 saw
+* (SAW) Replace huge list of gsdet/gsdeth calls with do loops over the
+* detector geometry.
+*
+* Revision 1.1 1995/09/18 13:48:10 cdaq
+* Initial revision
+*
+ implicit none
+
+ include 'hms_data_structures.cmn'
+ include 'hms_calorimeter.cmn'
+ include 'hms_one_ev.par'
+
+ integer iset, idet
+ character*4 varinames(3)
+ integer varibits(3)
+ integer calbits(2)
+ real origin(3),factor(3)
+
+ integer ilayer,iblock
+
+ character*4 specname
+ character*4 calname(2)
+
+ data specname /'HMS '/
+
+ data varinames /'x', 'y', 'z'/
+ data varibits /32, 32, 32/
+ data calbits /4,4/
+ data origin /HHUT_HEIGHT, HHUT_HEIGHT, HHUT_HEIGHT/
+ data factor /1e3, 1e3, 1e3/
+
+
+ do ilayer=1,hmax_cal_columns
+ write (calname(1),'("LAY",i1)') ilayer
+ do iblock=1,hmax_cal_rows
+ write (calname(2),'("BL",i1,a1)') ilayer, char(ichar('A')+iblock-1)
+ call gsdet(specname,calname(2),2,calname,calbits,
+ $ 2,100,100,iset,idet)
+ call gsdeth(specname,calname(2),3,varinames,varibits,origin,factor)
+ enddo
+ enddo
+
+ return
+ end
diff --git a/ONEEV/h_one_ev_det_reset.f b/ONEEV/h_one_ev_det_reset.f
new file mode 100644
index 0000000..df649d6
--- /dev/null
+++ b/ONEEV/h_one_ev_det_reset.f
@@ -0,0 +1,132 @@
+ subroutine h_one_ev_det_reset
+*
+* This routine will reset the hit indicators for the detector elements
+* Hall C
+*
+* July 1995 Derek van Westrum (vanwestr@cebaf.gov)
+*
+*
+* $Log: h_one_ev_det_reset.f,v $
+* Revision 1.2 1995/09/18 13:53:01 cdaq
+* (SAW) Change some include file names
+*
+* Revision 1.1 1995/07/31 15:24:41 cdaq
+* Initial revision
+*
+
+ implicit none
+
+ include 'hms_data_structures.cmn'
+ include 'hms_tracking.cmn'
+ include 'hms_geometry.cmn'
+ include 'hms_calorimeter.cmn'
+ include 'gen_event_info.cmn'
+ include 'hms_one_ev.par'
+ include 'gen_one_ev_gctrak.cmn'
+ include 'gen_one_ev_gckine.cmn'
+ include 'gen_one_ev_gcvolu.cmn'
+ character*5 scinname
+ character*5 blockname
+ integer istrip
+ integer ihodo
+ integer ilayer
+ integer iblock
+ character*4 wire
+ integer ichamber
+ integer isector
+ integer iwire
+*
+* First, clear the lower xpaddles
+*
+ do istrip=1,LOWER_HODO_X_PADDLES
+ write (scinname,'(a,a)') 'H1X',char(64 + istrip)
+ call gsatt (scinname,'COLO',1)
+ call gsatt (scinname,'FILL',0)
+ enddo
+*
+* next, clear the upper x hodoscopes:
+*
+ do istrip=1,UPPER_HODO_X_PADDLES
+ write (scinname,'(a,a)') 'H2X',char(64 + istrip)
+ call gsatt (scinname,'COLO',1)
+ call gsatt (scinname,'FILL',0)
+ enddo
+*
+* now clear the lower Y hodoscopes:
+*
+ do istrip=1,LOWER_HODO_Y_PADDLES
+ write (scinname,'(a,a)') 'H1Y',char(64 + istrip)
+ call gsatt (scinname,'COLO',1)
+ call gsatt (scinname,'FILL',0)
+ enddo
+*
+* finally, clear the upper y hodoscopes:
+*
+ do istrip=1,UPPER_HODO_Y_PADDLES
+ write (scinname,'(a,a)') 'H2Y',char(64 + istrip)
+ call gsatt (scinname,'COLO',1)
+ call gsatt (scinname,'FILL',0)
+ enddo
+*
+* Now clear the shower counter blocks.
+*
+ do ilayer=1,hmax_cal_columns
+ do iblock=1,hmax_cal_rows
+ write (blockname,'(a,i1,a)') 'BL',ilayer,CHAR(64 + iblock)
+ call gsatt (blockname,'COLO',1)
+ call gsatt (blockname,'FILL',0)
+ enddo
+ enddo
+*
+* Now clear the wire chambers...
+*
+* then the X wires
+ do ichamber=1,2
+ do isector=1,12
+ do iwire = 1,19
+ write (wire,'(a,a,a,a)') char(64 + ichamber),'X',
+ $ char(64 + isector),char(64 + iwire)
+ call gsatt (wire,'COLO',1)
+ call gsatt (wire,'SEEN',0)
+ call gsatt (wire,'FILL',0)
+ enddo
+ enddo
+ enddo
+* then the Y wires
+ do ichamber=1,2
+ do isector=1,4
+ do iwire = 1,26
+ write (wire,'(a,a,a,a)') char(64 + ichamber),'Y',
+ $ char(64 + isector),char(64 + iwire)
+ call gsatt (wire,'COLO',1)
+ call gsatt (wire,'SEEN',0)
+ call gsatt (wire,'FILL',0)
+ enddo
+ enddo
+ enddo
+* first the U wires...
+ do ichamber=1,2
+ do isector=1,6
+ do iwire = 1,18
+ write (wire,'(a,a,a,a)') char(64 + ichamber),'U',
+ $ char(64 + isector),char(64 + iwire)
+ call gsatt (wire,'COLO',1)
+ call gsatt (wire,'SEEN',0)
+ call gsatt (wire,'FILL',0)
+ enddo
+ enddo
+ enddo
+* then the V wires
+ do ichamber=1,2
+ do isector=1,6
+ do iwire = 1,18
+ write (wire,'(a,a,a,a)') char(64 + ichamber),'V',
+ $ char(64 + isector),char(64 + iwire)
+ call gsatt (wire,'COLO',1)
+ call gsatt (wire,'SEEN',0)
+ call gsatt (wire,'FILL',0)
+ enddo
+ enddo
+ enddo
+
+ end
diff --git a/ONEEV/h_one_ev_detectors.f b/ONEEV/h_one_ev_detectors.f
new file mode 100644
index 0000000..4eac925
--- /dev/null
+++ b/ONEEV/h_one_ev_detectors.f
@@ -0,0 +1,21 @@
+ subroutine h_one_ev_detectors
+*
+* Define geant detector sets
+*
+* August, 1994, Pat Welch, Oregon State University, tpw@physics.orst.edu
+*
+* $Log: h_one_ev_detectors.f,v $
+* Revision 1.2 1995/09/18 14:38:33 cdaq
+* (SAW) Remove unneeded declartions
+*
+* Revision 1.1 1995/03/14 21:26:57 cdaq
+* Initial revision
+*
+
+ call h_one_ev_hodo
+ call h_one_ev_cal
+ call h_one_ev_wc
+
+ return
+ end
+
diff --git a/ONEEV/h_one_ev_display.f b/ONEEV/h_one_ev_display.f
new file mode 100644
index 0000000..57d5bb1
--- /dev/null
+++ b/ONEEV/h_one_ev_display.f
@@ -0,0 +1,38 @@
+ subroutine h_one_ev_display(iview)
+*
+* This routine will store digitized hits for use in the one event display for
+* Hall C
+*
+* August, 1994, Pat Welch, Oregon State University, tpw@physics.orst.edu
+* Modified by Derek van Westrum (vanwestr@cebaf.gov) Jul 1995
+* $Log: h_one_ev_display.f,v $
+* Revision 1.5 1996/01/17 16:31:18 cdaq
+* (DVW) Add iview argument, make improvements.
+*
+* Revision 1.4 1995/09/18 14:43:05 cdaq
+* (DVW) Improvements
+*
+* Revision 1.3 1995/09/14 15:18:55 cdaq
+* (??) Updates
+*
+* Revision 1.2 1995/05/22 18:59:09 cdaq
+* (SAW) Split gen_data_data_structures into gen, hms, sos, and coin parts
+*
+* Revision 1.1 1995/03/14 21:26:49 cdaq
+* Initial revision
+*
+ implicit none
+
+ integer iview
+
+ call ixclrwi
+ if (iview.le.1) then
+ call h_one_ev_persp_view !draw the perspective view
+ elseif (iview.eq.2) then
+ call h_one_ev_topside_view !draw the two side views
+ elseif (iview.ge.3) then
+ call h_one_ev_head_view !draw the head on view
+ endif
+
+ end
+
diff --git a/ONEEV/h_one_ev_generate.f b/ONEEV/h_one_ev_generate.f
new file mode 100644
index 0000000..e746fa4
--- /dev/null
+++ b/ONEEV/h_one_ev_generate.f
@@ -0,0 +1,513 @@
+ subroutine h_one_ev_generate
+*
+* $Log: h_one_ev_generate.f,v $
+* Revision 1.2 1996/09/04 20:06:16 saw
+* (SAW) hdc_nrwire already integer, don't nint it.
+*
+* Revision 1.1 1996/01/17 16:35:11 cdaq
+* Initial revision
+*
+
+ implicit none
+
+ include 'hms_data_structures.cmn'
+ include 'hms_tracking.cmn'
+ include 'hms_geometry.cmn'
+ include 'hms_calorimeter.cmn'
+ include 'gen_event_info.cmn'
+ include 'gen_run_info.cmn'
+ include 'hms_one_ev.par'
+ include 'gen_one_ev_gctrak.cmn'
+ include 'gen_one_ev_gckine.cmn'
+ include 'gen_one_ev_gcvolu.cmn'
+
+ character*4 lnames(0:3) ! volume names
+ integer lnums(0:3) ! volume numbers or copies
+ real xd(3), xm(3) ! coordinates
+ integer error_code ! error return code
+ integer chamhit,scinhit,showhit ! index variables
+ integer wirenum ! indicates GEANT wirenumber
+
+ character*5 wire !define names and indicies to loop over...
+ character*5 scinname
+ character*4 blockname
+ character*5 layername
+
+*
+* Reset the detector hit indicators...
+ call h_one_ev_det_reset
+*
+* Clear any previous drawing
+*
+ call iclrwk (0, 0)
+ call gtrigc
+ call gtrigi
+*
+* define some colors for the various wires, and turn shading on
+*
+ call iscr(1,1,.5,.5,.5) !make the detectors grey
+ call iscr(1,15,1.,0.7,0.2) !define an "orange"
+ call iscr(1,13,0.,0.65,0.) !define a dark green
+ call iscr(1,14,0.,0.,1.) !define a dark blue
+ call iscr(1,16,0.65,0.,0.65) !define a dark purple
+ call gdopt ('SHAD','ON')
+*
+* Now loop over all the detector elements "lighting" each one if it has been hit
+*
+ xd(1) = 0. ! find the center of the detector
+ xd(2) = 0. ! find the center of the detector
+ xd(3) = 0. ! find the center of the detector
+*
+*
+* Start with the wire chambers
+* See the file "displaynumbering.help" for a description of the numbering of the
+* various detector elements
+*
+ if (HDC_TOT_HITS .GT. 0) then
+ lnames(0) = 'HHUT'
+ lnums(0) = 1
+ do chamhit = 1, HDC_TOT_HITS
+*************************************************************************
+*XXX
+****
+ if (HDC_PLANE_NUM(chamhit) .EQ. 1) then
+ nlevel = 0 ! initial value for # of levels
+ lnames(1) = 'WCHA' ! level one
+ lnums(1) = 1 ! copy one, higher chamber
+ lnames(2) = 'WAAX' ! X plane
+ lnums(2) = 1 ! copy one
+ wirenum = (hdc_nrwire(HDC_PLANE_NUM(chamhit))) + 1
+ & - HDC_WIRE_NUM(chamhit)
+ if (HDC_WIRE_COUNTING(HDC_PLANE_NUM(chamhit)) .EQ. 1)
+ & wirenum = HDC_WIRE_NUM(chamhit)
+ if (wirenum .le. 19) write (wire,'(a,a,a,a)') 'AXA',char(64+wirenum)
+ if ((wirenum .gt. 19) .and. (wirenum .le. 38)) write (wire,'(a,a,a,a)')
+ $ 'AXB',char(64 - 19 + wirenum)
+ if ((wirenum .gt. 38) .and. (wirenum .le. 57)) write (wire,'(a,a,a,a)')
+ $ 'AXC',char(64 - 38 + wirenum)
+ if ((wirenum .gt. 57) .and. (wirenum .le. 76)) write (wire,'(a,a,a,a)')
+ $ 'AXD',char(64 - 57 + wirenum)
+ if ((wirenum .gt. 76) .and. (wirenum .le. 95)) write (wire,'(a,a,a,a)')
+ $ 'AXE',char(64 - 76 + wirenum)
+ if (wirenum .gt. 95) write (wire,'(a,a,a,a)') 'AXF',char(64 - 95 + wirenum)
+ lnames(3) = wire
+ lnums(3) = wirenum ! wire number
+ call glvolu (4, lnames, lnums, error_code)
+ call gdtom (xd, xm, 1) ! transform from detector to MARS
+ call gsatt (wire,'SEEN',1)
+ call gsatt (wire,'COLO',13)
+* call gsahit (1, 4, 1, lnums(1), xm, ihit) ! store the hit
+*************************************************************************
+*YYY
+****
+ elseif (HDC_PLANE_NUM(chamhit) .EQ. 2) then
+ nlevel = 0 ! initial value for # of levels
+ lnames(1) = 'WCHA' ! level one
+ lnums(1) = 1 ! copy one, higher chamber
+ lnames(2) = 'WAAY' ! Y plane
+ lnums(2) = 1 ! copy one
+ wirenum = HDC_WIRE_NUM(chamhit)
+ if (HDC_WIRE_COUNTING(HDC_PLANE_NUM(chamhit)) .EQ. 1)
+ & wirenum = (hdc_nrwire(HDC_PLANE_NUM(chamhit)))+1
+ $ -wirenum
+ if (wirenum .le. 26) write (wire,'(a,a,a,a)') 'AYA',char(64+wirenum)
+ if (wirenum .gt. 26) write (wire,'(a,a,a,a)') 'AYB',char(64 - 26 + wirenum)
+ lnames(3) = wire
+ lnums(3) = wirenum ! wire number
+ call glvolu (4, lnames, lnums, error_code)
+ call gdtom (xd, xm, 1) ! transform from detector to MARS
+ call gsatt (wire,'SEEN',1)
+ call gsatt (wire,'COLO',13)
+* call gsahit (1, 5, 1, lnums(1), xm, ihit) ! store the hit
+*************************************************************************
+*UUU
+****
+ elseif (HDC_PLANE_NUM(chamhit) .EQ. 3) then
+ nlevel = 0 ! initial value for # of levels
+ lnames(1) = 'WCHA' ! level one
+ lnums(1) = 1 ! copy one, higher chamber
+ lnames(2) = 'WAAU' ! U plane
+ lnums(2) = 1 ! copy one
+ wirenum = (hdc_nrwire(HDC_PLANE_NUM(chamhit))) + 1
+ & - HDC_WIRE_NUM(chamhit)
+ if (HDC_WIRE_COUNTING(HDC_PLANE_NUM(chamhit)) .EQ. 1)
+ & wirenum = HDC_WIRE_NUM(chamhit)
+ if (wirenum .le. 18) write (wire,'(a,a,a,a)') 'AUA',char(64+wirenum)
+ if ((wirenum .gt. 18) .and. (wirenum .le. 36)) write (wire,'(a,a,a,a)')
+ $ 'AUB',char(64 - 18 + wirenum)
+ if ((wirenum .gt. 36) .and. (wirenum .le. 54)) write (wire,'(a,a,a,a)')
+ $ 'AUC',char(64 - 36 + wirenum)
+ if ((wirenum .gt. 54) .and. (wirenum .le. 72)) write (wire,'(a,a,a,a)')
+ $ 'AUD',char(64 - 54 + wirenum)
+ if ((wirenum .gt. 72) .and. (wirenum .le. 90)) write (wire,'(a,a,a,a)')
+ $ 'AUE',char(64 - 72 + wirenum)
+ if (wirenum .gt. 90) write (wire,'(a,a,a,a)') 'AUF',char(64 - 90 + wirenum)
+ lnames(3) = wire
+ lnums(3) = wirenum ! wire number
+ call glvolu (4, lnames, lnums, error_code)
+ call gdtom (xd, xm, 1) ! transform from detector to MARS
+ call gsatt (wire,'SEEN',1)
+ call gsatt (wire,'COLO',13)
+* call gsahit (1, 6, 1, lnums(1), xm, ihit) ! store the hit
+*************************************************************************
+*VVV
+****
+ elseif (HDC_PLANE_NUM(chamhit) .EQ. 4) then
+ nlevel = 0 ! initial value for # of levels
+ lnames(1) = 'WCHA' ! level one
+ lnums(1) = 1 ! copy one, higher chamber
+ lnames(2) = 'WAAV' ! V plane
+ lnums(2) = 1 ! copy one
+ wirenum = (hdc_nrwire(HDC_PLANE_NUM(chamhit))) + 1
+ & - HDC_WIRE_NUM(chamhit)
+ if (HDC_WIRE_COUNTING(HDC_PLANE_NUM(chamhit)) .EQ. 1)
+ & wirenum = HDC_WIRE_NUM(chamhit)
+ if (wirenum .le. 18) write (wire,'(a,a,a,a)') 'AVA',char(64+wirenum)
+ if ((wirenum .gt. 18) .and. (wirenum .le. 36)) write (wire,'(a,a,a,a)')
+ $ 'AVB',char(64 - 18 + wirenum)
+ if ((wirenum .gt. 36) .and. (wirenum .le. 54)) write (wire,'(a,a,a,a)')
+ $ 'AVC',char(64 - 36 + wirenum)
+ if ((wirenum .gt. 54) .and. (wirenum .le. 72)) write (wire,'(a,a,a,a)')
+ $ 'AVD',char(64 - 54 + wirenum)
+ if ((wirenum .gt. 72) .and. (wirenum .le. 90)) write (wire,'(a,a,a,a)')
+ $ 'AVE',char(64 - 72 + wirenum)
+ if (wirenum .gt. 90) write (wire,'(a,a,a,a)') 'AVF',char(64 - 90 + wirenum)
+ lnames(3) = wire
+ lnums(3) = wirenum ! wire number
+ call glvolu (4, lnames, lnums, error_code)
+ call gdtom (xd, xm, 1) ! transform from detector to MARS
+ call gsatt (wire,'SEEN',1)
+ call gsatt (wire,'COLO',13)
+* call gsahit (1, 7, 1, lnums(1), xm, ihit) ! store the hit
+*************************************************************************
+*YYY
+****
+ elseif (HDC_PLANE_NUM(chamhit) .EQ. 5) then
+ nlevel = 0 ! initial value for # of levels
+ lnames(1) = 'WCHA' ! level one
+ lnums(1) = 1 ! copy one, higher chamber
+ lnames(2) = 'WABY' ! Y plane
+ lnums(2) = 1 ! copy one
+ wirenum = HDC_WIRE_NUM(chamhit)
+ if (HDC_WIRE_COUNTING(HDC_PLANE_NUM(chamhit)) .EQ. 1)
+ & wirenum = (hdc_nrwire(HDC_PLANE_NUM(chamhit)))+1
+ $ -wirenum
+ if (wirenum .le. 26) write (wire,'(a,a,a,a)') 'AYC',char(64+wirenum)
+ if (wirenum .gt. 26) write (wire,'(a,a,a,a)') 'AYD',char(64 - 26 + wirenum)
+ lnames(3) = wire
+ lnums(3) = wirenum ! wire number
+ call glvolu (4, lnames, lnums, error_code)
+ call gdtom (xd, xm, 1) ! transform from detector to MARS
+ call gsatt (wire,'SEEN',1)
+ call gsatt (wire,'COLO',13)
+* call gsahit (1, 5, 1, lnums(1), xm, ihit) ! store the hit
+*************************************************************************
+*XXX
+****
+ elseif (HDC_PLANE_NUM(chamhit) .EQ. 6) then
+ nlevel = 0 ! initial value for # of levels
+ lnames(1) = 'WCHA' ! level one
+ lnums(1) = 1 ! copy one, higher chamber
+ lnames(2) = 'WABX' ! X plane
+ lnums(2) = 1 ! copy one
+ wirenum = (hdc_nrwire(HDC_PLANE_NUM(chamhit))) + 1
+ & - HDC_WIRE_NUM(chamhit)
+ if (HDC_WIRE_COUNTING(HDC_PLANE_NUM(chamhit)) .EQ. 1)
+ & wirenum = HDC_WIRE_NUM(chamhit)
+ if (wirenum .le. 19) write (wire,'(a,a,a,a)') 'AXG',char(64+wirenum)
+ if ((wirenum .gt. 19) .and. (wirenum .le. 38)) write (wire,'(a,a,a,a)')
+ $ 'AXH',char(64 - 19 + wirenum)
+ if ((wirenum .gt. 38) .and. (wirenum .le. 57)) write (wire,'(a,a,a,a)')
+ $ 'AXI',char(64 - 38 + wirenum)
+ if ((wirenum .gt. 57) .and. (wirenum .le. 76)) write (wire,'(a,a,a,a)')
+ $ 'AXJ',char(64 - 57 + wirenum)
+ if ((wirenum .gt. 76) .and. (wirenum .le. 95)) write (wire,'(a,a,a,a)')
+ $ 'AXK',char(64 -76 + wirenum)
+ if (wirenum .gt. 95) write (wire,'(a,a,a,a)') 'AXL',char(64 - 95 + wirenum)
+ lnames(3) = wire
+ lnums(3) = wirenum ! wire number
+ call glvolu (4, lnames, lnums, error_code)
+ call gdtom (xd, xm, 1) ! transform from detector to MARS
+ call gsatt (wire,'SEEN',1)
+ call gsatt (wire,'COLO',13)
+* call gsahit (1, 4, 1, lnums(1), xm, ihit) ! store the hit
+*************************************************************************
+*************************************************************************
+*XXX
+****
+ elseif (HDC_PLANE_NUM(chamhit) .EQ. 7) then
+ nlevel = 0 ! initial value for # of levels
+ lnames(1) = 'WCHB' ! level one
+ lnums(1) = 1 ! copy one, higher chamber
+ lnames(2) = 'WBAX' ! X plane
+ lnums(2) = 1 ! copy one
+ wirenum = (hdc_nrwire(HDC_PLANE_NUM(chamhit))) + 1
+ & - HDC_WIRE_NUM(chamhit)
+ if (HDC_WIRE_COUNTING(HDC_PLANE_NUM(chamhit)) .EQ. 1)
+ & wirenum = HDC_WIRE_NUM(chamhit)
+ if (wirenum .le. 19) write (wire,'(a,a,a,a)') 'BXA',char(64+wirenum)
+ if ((wirenum .gt. 19) .and. (wirenum .le. 38)) write (wire,'(a,a,a,a)')
+ $ 'BXB',char(64 - 19 + wirenum)
+ if ((wirenum .gt. 38) .and. (wirenum .le. 57)) write (wire,'(a,a,a,a)')
+ $ 'BXC',char(64 - 38 + wirenum)
+ if ((wirenum .gt. 57) .and. (wirenum .le. 76)) write (wire,'(a,a,a,a)')
+ $ 'BXD',char(64 - 57 + wirenum)
+ if ((wirenum .gt. 76) .and. (wirenum .le. 95)) write (wire,'(a,a,a,a)')
+ $ 'BXE',char(64 - 76 + wirenum)
+ if (wirenum .gt. 95) write (wire,'(a,a,a,a)') 'BXF',char(64 - 95 + wirenum)
+ lnames(3) = wire
+ lnums(3) = wirenum ! wire number
+ call glvolu (4, lnames, lnums, error_code)
+ call gdtom (xd, xm, 1) ! transform from detector to MARS
+ call gsatt (wire,'SEEN',1)
+ call gsatt (wire,'COLO',15)
+* call gsahit (1, 4, 1, lnums(1), xm, ihit) ! store the hit
+*************************************************************************
+*YYY
+****
+ elseif (HDC_PLANE_NUM(chamhit) .EQ. 8) then
+ nlevel = 0 ! initial value for # of levels
+ lnames(1) = 'WCHB' ! level one
+ lnums(1) = 1 ! copy one, higher chamber
+ lnames(2) = 'WBAY' ! Y plane
+ lnums(2) = 1 ! copy one
+ wirenum = HDC_WIRE_NUM(chamhit)
+ if (HDC_WIRE_COUNTING(HDC_PLANE_NUM(chamhit)) .EQ. 1)
+ & wirenum = (hdc_nrwire(HDC_PLANE_NUM(chamhit)))+1
+ $ -wirenum
+ if (wirenum .le. 26) write (wire,'(a,a,a,a)') 'BYA',char(64+wirenum)
+ if (wirenum .gt. 26) write (wire,'(a,a,a,a)') 'BYB',char(64 - 26 + wirenum)
+ lnames(3) = wire
+ lnums(3) = wirenum ! wire number
+ call glvolu (4, lnames, lnums, error_code)
+ call gdtom (xd, xm, 1) ! transform from detector to MARS
+ call gsatt (wire,'SEEN',1)
+ call gsatt (wire,'COLO',15)
+* call gsahit (1, 5, 1, lnums(1), xm, ihit) ! store the hit
+*************************************************************************
+*UUU
+****
+ elseif (HDC_PLANE_NUM(chamhit) .EQ. 9) then
+ nlevel = 0 ! initial value for # of levels
+ lnames(1) = 'WCHB' ! level one
+ lnums(1) = 1 ! copy one, higher chamber
+ lnames(2) = 'WBAU' ! U plane
+ lnums(2) = 1 ! copy one
+ wirenum = (hdc_nrwire(HDC_PLANE_NUM(chamhit))) + 1
+ & - HDC_WIRE_NUM(chamhit)
+ if (HDC_WIRE_COUNTING(HDC_PLANE_NUM(chamhit)) .EQ. 1)
+ & wirenum = HDC_WIRE_NUM(chamhit)
+ if (wirenum .le. 18) write (wire,'(a,a,a,a)') 'BUA',char(64+wirenum)
+ if ((wirenum .gt. 18) .and. (wirenum .le. 36)) write (wire,'(a,a,a,a)')
+ $ 'BUB',char(64 -18 + wirenum)
+ if ((wirenum .gt. 36) .and. (wirenum .le. 54)) write (wire,'(a,a,a,a)')
+ $ 'BUC',char(64 - 36 + wirenum)
+ if ((wirenum .gt. 54) .and. (wirenum .le. 72)) write (wire,'(a,a,a,a)')
+ $ 'BUD',char(64 - 54 + wirenum)
+ if ((wirenum .gt. 72) .and. (wirenum .le. 90)) write (wire,'(a,a,a,a)')
+ $ 'BUE',char(64 - 72 + wirenum)
+ if (wirenum .gt. 90) write (wire,'(a,a,a,a)') 'BUF',char(64 - 90 + wirenum)
+ lnames(3) = wire
+ lnums(3) = wirenum ! wire number
+ call glvolu (4, lnames, lnums, error_code)
+ call gdtom (xd, xm, 1) ! transform from detector to MARS
+ call gsatt (wire,'SEEN',1)
+ call gsatt (wire,'COLO',15)
+* call gsahit (1, 6, 1, lnums(1), xm, ihit) ! store the hit
+*************************************************************************
+*YYY
+****
+ elseif (HDC_PLANE_NUM(chamhit) .EQ. 10) then
+ nlevel = 0 ! initial value for # of levels
+ lnames(1) = 'WCHB' ! level one
+ lnums(1) = 1 ! copy one, higher chamber
+ lnames(2) = 'WBAV' ! V plane
+ lnums(2) = 1 ! copy one
+ wirenum = (hdc_nrwire(HDC_PLANE_NUM(chamhit))) + 1
+ & - HDC_WIRE_NUM(chamhit)
+ if (HDC_WIRE_COUNTING(HDC_PLANE_NUM(chamhit)) .EQ. 1)
+ & wirenum = HDC_WIRE_NUM(chamhit)
+ if (wirenum .le. 18) write (wire,'(a,a,a,a)') 'BVA',char(64+wirenum)
+ if ((wirenum .gt. 18) .and. (wirenum .le. 36)) write (wire,'(a,a,a,a)')
+ $ 'BVB',char(64 - 18 + wirenum)
+ if ((wirenum .gt. 36) .and. (wirenum .le. 54)) write (wire,'(a,a,a,a)')
+ $ 'BVC',char(64 - 36 + wirenum)
+ if ((wirenum .gt. 54) .and. (wirenum .le. 72)) write (wire,'(a,a,a,a)')
+ $ 'BVD',char(64 - 54 + wirenum)
+ if ((wirenum .gt. 72) .and. (wirenum .le. 90)) write (wire,'(a,a,a,a)')
+ $ 'BVE',char(64 - 72 + wirenum)
+ if (wirenum .gt. 90) write (wire,'(a,a,a,a)') 'BVF',char(64 - 90 + wirenum)
+ lnames(3) = wire
+ lnums(3) = wirenum ! wire number
+ call glvolu (4, lnames, lnums, error_code)
+ call gdtom (xd, xm, 1) ! transform from detector to MARS
+ call gsatt (wire,'SEEN',1)
+ call gsatt (wire,'COLO',15)
+* call gsahit (1, 7, 1, lnums(1), xm, ihit) ! store the hit
+*************************************************************************
+ elseif (HDC_PLANE_NUM(chamhit) .EQ. 11) then
+ nlevel = 0 ! initial value for # of levels
+ lnames(1) = 'WCHB' ! level one
+ lnums(1) = 1 ! copy one, higher chamber
+ lnames(2) = 'WBBY' ! Y plane
+ lnums(2) = 1 ! copy one
+ wirenum = HDC_WIRE_NUM(chamhit)
+ if (HDC_WIRE_COUNTING(HDC_PLANE_NUM(chamhit)) .EQ. 1)
+ & wirenum = (hdc_nrwire(HDC_PLANE_NUM(chamhit)))+1
+ $ -wirenum
+ if (wirenum .le. 26) write (wire,'(a,a,a,a)') 'BYC',char(64+wirenum)
+ if (wirenum .gt. 26) write (wire,'(a,a,a,a)') 'BYD',char(64 - 26 + wirenum)
+ lnames(3) = wire
+ lnums(3) = wirenum ! wire number
+ call glvolu (4, lnames, lnums, error_code)
+ call gdtom (xd, xm, 1) ! transform from detector to MARS
+ call gsatt (wire,'SEEN',1)
+ call gsatt (wire,'COLO',15)
+* call gsahit (1, 5, 1, lnums(1), xm, ihit) ! store the hit
+*************************************************************************
+*XXX
+****
+ elseif (HDC_PLANE_NUM(chamhit) .EQ. 12) then
+ nlevel = 0 ! initial value for # of levels
+ lnames(1) = 'WCHB' ! level one
+ lnums(1) = 1 ! copy one, higher chamber
+ lnames(2) = 'WBBX' ! X plane
+ lnums(2) = 1 ! copy one
+ wirenum = (hdc_nrwire(HDC_PLANE_NUM(chamhit))) + 1
+ & - HDC_WIRE_NUM(chamhit)
+ if (HDC_WIRE_COUNTING(HDC_PLANE_NUM(chamhit)) .EQ. 1)
+ & wirenum = HDC_WIRE_NUM(chamhit)
+ if (wirenum .le. 19) write (wire,'(a,a,a,a)') 'BXG',char(64+wirenum)
+ if ((wirenum .gt. 19) .and. (wirenum .le. 38)) write (wire,'(a,a,a,a)')
+ $ 'BXH',char(64 -19 + wirenum)
+ if ((wirenum .gt. 38) .and. (wirenum .le. 57)) write (wire,'(a,a,a,a)')
+ $ 'BXI',char(64 - 38 + wirenum)
+ if ((wirenum .gt. 57) .and. (wirenum .le. 76)) write (wire,'(a,a,a,a)')
+ $ 'BXJ',char(64 - 57 + wirenum)
+ if ((wirenum .gt. 76) .and. (wirenum .le. 95)) write (wire,'(a,a,a,a)')
+ $ 'BXK',char(64 - 76 + wirenum)
+ if (wirenum .gt. 95) write (wire,'(a,a,a,a)') 'BXL',char(64 - 95 + wirenum)
+ lnames(3) = wire
+ lnums(3) = wirenum ! wire number
+ call glvolu (4, lnames, lnums, error_code)
+ call gdtom (xd, xm, 1) ! transform from detector to MARS
+ call gsatt (wire,'SEEN',1)
+ call gsatt (wire,'COLO',15)
+* call gsahit (1, 4, 1, lnums(1), xm, ihit) ! store the hit
+*************************************************************************
+ endif
+ enddo
+ endif
+*
+* Take a look at the hodoscopes
+* See the file "displaynumbering.help" for a description of the numbering of the
+* various detector elements
+*
+ if (HSCIN_TOT_HITS .GT. 0) then
+ lnames(0) = 'HHUT' ! relative to the hut
+ lnums(0) = 1 ! copy 1
+ do scinhit = 1, HSCIN_TOT_HITS
+*
+* First the lower X
+*
+ if (HSCIN_PLANE_NUM(scinhit) .EQ. 1) then
+ nlevel = 0 ! initial value for # of levels
+ lnames(1) = 'HOD1' ! level one
+ lnums(1) = 1 ! copy one, lower hodo
+ lnames(2) = 'HDX1' ! X strips
+ lnums(2) = 1 ! copy one
+ write (scinname,'(a,a)') 'H1X',char(64 + HSCIN_COUNTER_NUM(scinhit))
+ lnames(3) = scinname ! X strips
+ lnums(3) = HSCIN_COUNTER_NUM(scinhit) ! X strip number
+ call glvolu (4, lnames, lnums, error_code)
+ call gdtom (xd, xm, 1) ! transform from detector to MARS
+* call gsahit (1, 2, 1, lnums(1), xm, ihit) ! store the hit
+ call gsatt (scinname,'COLO',4) !change the color of the it element
+ call gsatt (scinname,'FILL',5)
+ call gsatt (scinname,'LWID',1)
+*
+* now the upper X
+*
+ elseif (HSCIN_PLANE_NUM(scinhit) .EQ. 3) then
+ nlevel = 0 ! initial value for # of levels
+ lnames(1) = 'HOD2' ! level one
+ lnums(1) = 2 ! copy two, upper hodo
+ lnames(2) = 'HDX2' ! X strips
+ lnums(2) = 1 ! copy one
+ write (scinname,'(a,a)') 'H2X',char(64 + HSCIN_COUNTER_NUM(scinhit))
+ lnames(3) = scinname
+ lnums(3) = HSCIN_COUNTER_NUM(scinhit) ! X strip number
+ call glvolu (4, lnames, lnums, error_code)
+ call gdtom (xd, xm, 1) ! transform from detector
+* call gsahit (1, 2, 1, lnums(1), xm, ihit) ! store the hit
+ call gsatt (scinname,'COLO',4) !change the color of the it element
+ call gsatt (scinname,'FILL',5)
+ call gsatt (scinname,'LWID',1)
+*
+* now the lower Y
+*
+ elseif (HSCIN_PLANE_NUM(scinhit) .EQ. 2) then
+ nlevel = 0 ! initial value for # of levels
+ lnames(1) = 'HOD1'
+ lnums(1) = 1 ! copy one, lower hodo
+ lnames(2) = 'HDY1' ! Y strips
+ lnums(2) = 1 ! copy one
+ write (scinname,'(a,a)') 'H1Y',char(64 + HSCIN_COUNTER_NUM(scinhit))
+ lnames(3) = scinname ! Y strips
+ lnums(3) = HSCIN_COUNTER_NUM(scinhit) ! Y strip number
+ call glvolu (4, lnames, lnums, error_code)
+ call gdtom (xd, xm, 1) ! transform from detector to MARS
+* call gsahit (1, 3, 1, lnums(1), xm, ihit) ! store the hit
+ call gsatt (scinname,'COLO',4) !change the color of the it element
+ call gsatt (scinname,'FILL',5)
+ call gsatt (scinname,'LWID',1)
+*
+* now the upper Y
+*
+ elseif (HSCIN_PLANE_NUM(scinhit) .EQ. 4) then
+ nlevel = 0 ! initial value for # of levels
+ lnames(1) = 'HOD2'
+ lnums(1) = 1 ! copy two, upper hodo
+ lnames(2) = 'HDY2' ! Y strips
+ lnums(2) = 1 ! copy one
+ write (scinname,'(a,a)') 'H2Y',char(64 + HSCIN_COUNTER_NUM(scinhit))
+ lnames(3) = scinname ! Y strips
+ lnums(3) = HSCIN_COUNTER_NUM(scinhit) ! Y strip number
+ call glvolu (4, lnames, lnums, error_code)
+ call gdtom (xd, xm, 1) ! transform from detector to MARS
+* call gsahit (1, 3, 1, lnums(1), xm, ihit) ! store the hit
+ call gsatt (scinname,'COLO',4) !change the color of the it element
+ call gsatt (scinname,'FILL',5)
+ call gsatt (scinname,'LWID',1)
+ endif
+ enddo
+ endif
+*
+* Now take care of the shower detector
+* See the file "displaynumbering.help" for a description of the numbering of the
+* various detector elements
+*
+ lnames(0) = 'HHUT'
+ lnums(0) = 1
+ if (HCAL_NUM_HITS .GE. 0) then
+ do showhit = 1, hcal_num_hits
+ nlevel = 0
+ lnames(1) = 'SHOW' ! shower detector
+ lnums(1) = 4
+ write (layername,'(a,i1)') 'LAY',hcal_cols(showhit)
+ lnames(2) = layername ! x subdivisions
+ lnums(2) = 13
+ lnums(3) = 1
+ write (blockname,'(a,i1,a)') 'BL',hcal_cols(showhit),
+ $ char(64 + hcal_rows(showhit))
+ lnames(3) = blockname
+ call glvolu(4, lnames, lnums, error_code)
+ call gdtom (xd, xm, 1) ! transform from det to MARS
+* call gsahit (1, 1, 1, lnums(2), xm, ihit) ! store the hit
+ call gsatt (blockname,'COLO',4) !change the color of the it element
+ call gsatt (blockname,'FILL',5)
+ call gsatt (blockname,'LWID',2)
+ enddo
+ endif
+
+ end
diff --git a/ONEEV/h_one_ev_geometry.f b/ONEEV/h_one_ev_geometry.f
new file mode 100644
index 0000000..86680ba
--- /dev/null
+++ b/ONEEV/h_one_ev_geometry.f
@@ -0,0 +1,441 @@
+ subroutine h_one_ev_geometry
+*
+* This routine will get the detector position and size information from CTP,
+* then use this information for defining the different GEANT geometry structures
+*
+* August, 1994, Pat Welch, Oregon State University, tpw@physics.orst.edu
+*
+* Note: Subdivided volumes won't work for doing coordinate transforms. Or
+* at least I didn't see a method around them. So I have defined all
+* the subvolumes explicitly. (TPW)
+* $Log: h_one_ev_geometry.f,v $
+* Revision 1.8 1996/11/22 15:36:37 saw
+* (SAW) Some code cleanup
+*
+* Revision 1.7 1996/04/30 14:09:54 saw
+* (JRA) Some new code
+*
+* Revision 1.6 1996/01/17 16:35:37 cdaq
+* (DVW) Tweak hodoscale
+*
+* Revision 1.5 1995/10/06 18:39:36 cdaq
+* (DVW) Changed to ctp geometry variables and eliminated call to h_one_ev.par.
+*
+* Revision 1.4 1995/09/18 14:35:22 cdaq
+* (DVW) Improvements
+*
+* Revision 1.3 1995/05/22 18:58:03 cdaq
+* (SAW) Split gen_data_data_structures into gen, hms, sos, and coin parts
+*
+* Revision 1.2 1995/01/27 19:31:37 cdaq
+* (SAW) Change file names to be hms specific.
+*
+c Revision 1.1 1995/01/10 18:43:44 cdaq
+c Initial revision
+c
+*
+ implicit none
+
+ include 'hms_data_structures.cmn'
+ include 'hms_geometry.cmn'
+ include 'hms_calorimeter.cmn'
+ include 'hms_scin_parms.cmn'
+
+ real*4 HHUT_WIDTH,HHUT_HEIGHT
+ parameter (HHUT_WIDTH = 100.) ! full width of the det. hut
+ parameter (HHUT_HEIGHT = 800.) ! full height of the det. hut
+
+ integer HHUTMEDIA ! non-sensitive tracking media
+ integer DETMEDIA ! sensitive tracking media
+ parameter (HHUTMEDIA = 1, DETMEDIA = 2)
+ real*4 hodoscale
+ parameter (hodoscale = 2.)
+ real*4 wcscale
+ parameter (wcscale = 1.)
+ real*4 xwirelength
+ real*4 ywirelength
+ real*4 uwirelength
+ real*4 vwirelength
+
+ real*4 numxwires ! add 1 to the number of x, u, and v wires
+ real*4 numywires ! for ease in looping over the wires...
+ real*4 numuwires
+ real*4 numvwires
+
+ character*5 scinname
+ character*5 layername
+ character*5 planename
+ character*5 plane
+ character*5 wire
+ character*5 blockname
+ integer isector
+ integer iplane
+ integer iwire
+ integer ichamber
+ integer ilayer
+ integer irow
+
+ integer ivolu ! internal volume number
+ real par(10) ! geometry parameters
+ real x, y, z ! offset position for placement of dets
+ integer i ! index variable
+ real wspace ! Wire spacing temp variable
+ real*4 raddeg
+ parameter (raddeg = 3.14159265/180.)
+
+
+* First define two general media that everything is made of
+* one is insensitive, and the other is sensitive
+
+ call gstmed (HHUTMEDIA, 'air', 15, 0, 0,0.,20.,1.,0.5,1.,1.,0,0)
+ call gstmed (DETMEDIA, 'det', 15, 1, 0,0.,20.,1.,0.5,1.,1.,0,0)
+
+* Now define the mother volume that the detectors sit in
+
+ par(1) = HHUT_WIDTH / 2. ! half width in x of mother volume
+ par(2) = HHUT_WIDTH / 2. ! half width in y of mother volume
+ par(3) = HHUT_HEIGHT / 2. ! half height in z of mother volume
+ call g_ugsvolu ('HHUT', 'BOX ', HHUTMEDIA, par, 3, ivolu)
+ call gsatt ('HHUT', 'SEEN', 0) ! can't see the hut
+
+* Get the number of wires from the ctp file, and add one to the x, u, and v for
+* ease in looping over the wires
+* See the file "displaynumbering.help" for a description of the numbering of the
+* various detector elements
+*
+
+ numxwires = hdc_nrwire(1) + 1.
+ numywires = hdc_nrwire(2)
+ numuwires = hdc_nrwire(3) + 1.
+ numvwires = hdc_nrwire(4) + 1.
+ xwirelength = numywires*hdc_pitch(2)
+ ywirelength = numxwires * hdc_pitch(1)
+ uwirelength = xwirelength / SIN(hdc_alpha_angle(3))
+ vwirelength = xwirelength / SIN(hdc_alpha_angle(4))
+
+* Now define the wire chambers as a collection of 6 planes
+
+ par(1) = numxwires*hdc_pitch(1)/ 2. ! half width of chamber planes
+ par(2) = numywires*hdc_pitch(2)/ 2. ! half width of chamber planes
+ par(3) = wcscale * (hdc_zpos(2) - hdc_zpos(1))/ 2.
+ do ichamber = 1,2
+ do iplane = 1,2
+ write(planename,'(a,a,a,a)') "W",char(64+ichamber),char(64+iplane),"X"
+ call g_ugsvolu (planename, 'BOX ', DETMEDIA, par, 3, ivolu)
+ write(planename,'(a,a,a,a)') "W",char(64+ichamber),char(64+iplane),"Y"
+ call g_ugsvolu (planename, 'BOX ', DETMEDIA, par, 3, ivolu)
+ write(planename,'(a,a,a,a)') "W",char(64+ichamber),char(64+iplane),"U"
+ call g_ugsvolu (planename, 'BOX ', DETMEDIA, par, 3, ivolu)
+ write(planename,'(a,a,a,a)') "W",char(64+ichamber),char(64+iplane),"V"
+ call g_ugsvolu (planename, 'BOX ', DETMEDIA, par, 3, ivolu)
+ enddo
+ enddo
+
+* make a volumes for 6 planes
+ par(3) = wcscale * (6./5. * (hdc_zpos(6) - hdc_zpos(1))) / 2.
+ call g_ugsvolu ('WCHA', 'BOX ', DETMEDIA, par, 3, ivolu) ! Wire chamber
+ call g_ugsvolu ('WCHB', 'BOX ', DETMEDIA, par, 3, ivolu) ! Wire chamber
+
+* Now place the planes within the wire chamber, start with X
+
+ z = -(5. / 2.) * (hdc_zpos(2) -hdc_zpos(1))
+ call gspos ('WAAX', 1, 'WCHA', 0., 0., z, 0, 'ONLY') ! X plane
+ z = (5. / 2.) * (hdc_zpos(2) -hdc_zpos(1))
+ call gspos ('WABX', 1, 'WCHA', 0., 0., z, 0, 'ONLY') ! X plane
+ z = -(5. / 2.) * (hdc_zpos(2) -hdc_zpos(1))
+ call gspos ('WBAX', 1, 'WCHB', 0., 0., z, 0, 'ONLY') ! X plane
+ z = (5. / 2.) * (hdc_zpos(2) -hdc_zpos(1))
+ call gspos ('WBBX', 1, 'WCHB', 0., 0., z, 0, 'ONLY') ! X plane
+
+* Now place the planes within the wire chamber, now the Y's
+
+ z = -(3. / 2.) * (hdc_zpos(2) -hdc_zpos(1))
+ call gspos ('WAAY', 1, 'WCHA', 0., 0., z, 0, 'ONLY') ! Y plane
+ z = (3. / 2.) * (hdc_zpos(2) -hdc_zpos(1))
+ call gspos ('WABY', 1, 'WCHA', 0., 0., z, 0, 'ONLY') ! Y plane
+ z = -(3. / 2.) * (hdc_zpos(2) -hdc_zpos(1))
+ call gspos ('WBAY', 1, 'WCHB', 0., 0., z, 0, 'ONLY') ! Y plane
+ z = (3. / 2.) * (hdc_zpos(2) -hdc_zpos(1))
+ call gspos ('WBBY', 1, 'WCHB', 0., 0., z, 0, 'ONLY') ! Y plane
+
+* Now place the planes within the wire chamber, now the U's
+
+ z = -(1. / 2.) * (hdc_zpos(2) -hdc_zpos(1))
+ call gspos ('WAAU', 1, 'WCHA', 0., 0., z, 0, 'ONLY') ! U plane
+ z = -(1. / 2.) * (hdc_zpos(2) -hdc_zpos(1))
+ call gspos ('WBAU', 1, 'WCHB', 0., 0., z, 0, 'ONLY') ! U plane
+
+* Now place the planes within the wire chamber, now the V's
+
+ z = (1. / 2.) * (hdc_zpos(2) -hdc_zpos(1))
+ call gspos ('WAAV', 1, 'WCHA', 0., 0., z, 0, 'ONLY') ! V plane
+ z = (1. / 2.) * (hdc_zpos(2) -hdc_zpos(1))
+ call gspos ('WBAV', 1, 'WCHB', 0., 0., z, 0, 'ONLY') ! V plane
+
+
+* Now place the wire chambers in the mother volume
+
+ x = hdc_xcenter(1)
+ y = - hdc_ycenter(1)
+ z = hdc_1_zpos
+ call gspos ('WCHA', 1, 'HHUT', x, y, z, 0, 'ONLY') ! upper chamber
+ x = hdc_xcenter(2)
+ y = - hdc_ycenter(2)
+ z = hdc_2_zpos
+ call gspos ('WCHB', 1, 'HHUT', x, y, z, 0, 'ONLY') ! bottom chamber
+*
+* Define the individual wire cells
+* See the file "displaynumbering.help" for a description of the numbering of the
+* various detector elements
+*
+*****
+*XXXX
+*****
+ par(1) = hdc_pitch(1) / 2./1000. ! make the cells "wire" thin
+ par(2) = xwirelength/ 2. ! half width of chamber planes
+ par(3) = (hdc_zpos(2) - hdc_zpos(1))/ 2. /1000. ! half width of chamber planes
+
+ wspace = hdc_pitch(1)
+*
+* Now position the X wires plane by plane
+*
+ do ichamber=1,2
+ iplane = 1
+ x = - (numxwires) /2. * wspace
+ do isector=1,12
+ if (isector.eq.7) then
+ iplane = 2
+ x = - (numxwires) /2. * wspace
+ endif
+ write (plane,'(a,a,a,a)') 'W',char(64+ichamber),char(64+iplane),'X'
+ do iwire=1,19
+ x = x + wspace
+ write (wire,'(a,a,a,a)') char(64+ichamber),"X",
+ $ char(64 + isector),char(64 + iwire)
+ call g_ugsvolu (wire, 'BOX ', DETMEDIA, par, 3, ivolu) ! X cell
+ call gsatt (wire, 'SEEN', 0) ! can't see the wire cells
+ call gspos (wire, 1, plane, x, 0., 0., 0, 'ONLY')
+ enddo
+ enddo
+ enddo
+*
+
+*****
+*YYYY
+*****
+ par(1) = ywirelength/ 2. ! half width of chamber planes
+ par(2) = hdc_pitch(2) / 2. / 1000. ! half width of cell
+ par(3) = (hdc_zpos(3) - hdc_zpos(2))/ 2./1000. ! half width of chamber planes
+ wspace = hdc_pitch(2)
+*
+* Now position the Y wires plane by plane
+*
+ do ichamber=1,2
+ iplane = 1
+ y = -(numywires + 1.) / 2. * wspace
+ do isector=1,4
+ if(isector.eq.3) then
+ iplane = 2
+ y = -(numywires + 1.) / 2. * wspace
+ endif
+ write (plane,'(a,a,a,a)') 'W',char(64+ichamber),char(64+iplane),'Y'
+ do iwire=1,26
+ y = y + wspace
+ write (wire,'(a,a,a,a)') char(64+ichamber),"Y",
+ $ char(64 + isector),char(64 + iwire)
+ call g_ugsvolu (wire, 'BOX ', DETMEDIA, par, 3, ivolu) ! Y cell
+ call gsatt (wire, 'SEEN', 0) ! can't see the wire cells
+ call gspos (wire, 1, plane, 0., y, 0., 0, 'ONLY')
+ enddo
+ enddo
+ enddo
+*
+*****
+*UUUU
+*****
+ par(1) = hdc_pitch(1) / 2./1000. ! make the cells "wire" thin
+ par(2) = uwirelength/2.
+ par(3) = (hdc_zpos(2) - hdc_zpos(1))/ 2. /1000. ! half width of chamber planes
+ wspace = hdc_pitch(3) / SIN (hdc_alpha_angle(3))
+
+* Now position the U wires plane by plane...
+ do ichamber=1,2
+ x = -(numuwires) / 2. * wspace
+ write (plane,'(a,a,a)') "W",char(64+ichamber),"AU"
+ do isector=1,6
+ do iwire=1,18
+ x = x + wspace
+ write (wire,'(a,a,a,a)') char(64+ichamber),"U",
+ $ char(64 + isector),char(64 + iwire)
+ call g_ugsvolu (wire, 'BOX ', DETMEDIA, par, 3, ivolu) ! U cell
+ call gsatt (wire, 'SEEN', 0) ! can't see the wire cells
+ call gspos (wire, 1, plane, x, 0.0 , 0., 4, 'ONLY')
+ enddo
+ enddo
+ enddo
+*****
+*VVVV
+*****
+ par(1) = hdc_pitch(1) / 2./1000. ! make the cells "wire" thin
+ par(2) = vwirelength/2.
+ par(3) = (hdc_zpos(2) - hdc_zpos(1))/ 2. /1000. ! half width of chamber planes
+
+ wspace = hdc_pitch(4) / SIN (hdc_alpha_angle(4))
+
+* Now position the V wires plane by plane...
+ do ichamber=1,2
+ x = - (numvwires) / 2. * wspace
+ write (plane,'(a,a,a)') "W",char(64+ichamber),"AV"
+ do isector=1,6
+ do iwire=1,18
+ x = x + wspace
+ write (wire,'(a,a,a,a)') char(64+ichamber),"V",
+ $ char(64 + isector),char(64 + iwire)
+ call g_ugsvolu (wire, 'BOX ', DETMEDIA, par, 3, ivolu) ! V cell
+ call gsatt (wire, 'SEEN', 0) ! can't see the wire cells
+ call gspos (wire, 1, plane, x, 0., 0., 3, 'ONLY')
+ enddo
+ enddo
+ enddo
+*
+* Now define the hodoscope layers
+* See the file "displaynumbering.help" for a description of the numbering of the
+* various detector elements
+
+ par(1) = hscin_1x_size * hscin_1x_nr / 2. ! half width of X strips
+ par(2) = hscin_1y_size * hscin_1y_nr / 2. ! half width of Y strips
+ par(3) = hscin_1x_dzpos * hodoscale / 2. !half thickness of hodoscope in z
+ call g_ugsvolu ('HDX1', 'BOX ', DETMEDIA, par, 3, ivolu) ! X plane hodo
+ call g_ugsvolu ('HDY1', 'BOX ', DETMEDIA, par, 3, ivolu) ! Y plane hodo
+
+ call gsatt ('HDX1', 'SEEN', 0) ! can't see the hodo box
+ call gsatt ('HDY1', 'SEEN', 0) ! can't see the hodo box
+ par(1) = hscin_2x_size * hscin_2x_nr / 2. ! half width of X strips
+ par(2) = hscin_2y_size * hscin_2y_nr / 2. ! half width of Y strips
+ par(3) = hscin_2x_dzpos * hodoscale / 2. !half thickness of hodoscope in z
+ call g_ugsvolu ('HDX2', 'BOX ', DETMEDIA, par, 3, ivolu) ! X plane hodo
+ call g_ugsvolu ('HDY2', 'BOX ', DETMEDIA, par, 3, ivolu) ! Y plane hodo
+ call gsatt ('HDX2', 'SEEN', 0) ! can't see the hodo box
+ call gsatt ('HDY2', 'SEEN', 0) ! can't see the hodo box
+
+! box for front hodos
+ par(1) = hscin_1x_size * hscin_1x_nr / 2.
+ par(2) = hscin_1y_size * hscin_1y_nr / 2.
+ par(3) = hscin_1x_dzpos*hodoscale + (hscin_1y_zpos-hscin_1x_zpos)/2.
+ call g_ugsvolu ('HOD1', 'BOX ', DETMEDIA, par, 3, ivolu) ! hodoscope box
+ call gsatt ('HOD1', 'SEEN', 0) ! can't see the hodo box
+* added by Derek
+! box for back hodos
+ par(1) = hscin_2x_size * hscin_2x_nr / 2.
+ par(2) = hscin_2y_size * hscin_2y_nr / 2.
+ par(3) = hscin_2x_dzpos*hodoscale + (hscin_2y_zpos-hscin_2x_zpos)/2.
+ call g_ugsvolu ('HOD2', 'BOX ', DETMEDIA, par, 3, ivolu) ! hodoscope box
+ call gsatt ('HOD2', 'SEEN', 0) ! can't see the hodo box
+
+ x = -hscin_1x_offset
+ y = hscin_1y_offset
+ z = hscin_1x_zpos
+ call gspos ('HOD1', 1, 'HHUT', x, y, z, 0, 'ONLY') ! lower hodo
+ x = -hscin_2x_offset
+ y = hscin_2y_offset
+ z = hscin_2x_zpos
+ call gspos ('HOD2', 1, 'HHUT', x, y, z, 0, 'ONLY') ! upper hodo
+
+ z= -(hscin_1x_dzpos*hodoscale + (hscin_1y_zpos-hscin_1x_zpos))/2.
+ call gspos ('HDX1', 1, 'HOD1', 0., 0., z, 0, 'ONLY') ! X plane
+ call gspos ('HDY1', 1, 'HOD1', 0., 0., -z, 0, 'ONLY') ! Y plane
+ z= -(hscin_2x_dzpos*hodoscale + (hscin_2y_zpos-hscin_2x_zpos))/2.
+ call gspos ('HDX2', 1, 'HOD2', 0., 0., z, 0, 'ONLY') ! X plane
+ call gspos ('HDY2', 1, 'HOD2', 0., 0., -z, 0, 'ONLY') ! Y plane
+
+* Now define the strips for the hodoscopes
+
+ x = (hscin_1x_nr + 1.) * hscin_1x_size / 2. ! starting loci
+ do i = 1, hscin_1x_nr
+ x = x - hscin_1x_size
+ write (scinname,'(a,a)') "H1X",char(64 + i)
+ par(1) = hscin_1x_size / 2. !half width of X strips
+ par(2) = hscin_1y_size * hscin_1y_nr / 2.
+ par(3) = hscin_1x_dzpos * hodoscale / 2.
+ call g_ugsvolu (scinname, 'BOX ', DETMEDIA, par, 3, ivolu)
+ call gspos (scinname, 1, 'HDX1', x, 0., 0., 0, 'ONLY')
+ enddo
+ y = (hscin_1y_nr + 1.) * hscin_1y_size / 2. ! starting loci
+ do i = 1, hscin_1y_nr
+ y = y - hscin_1y_size
+ write (scinname,'(a,a)') "H1Y",char(64 + i)
+ par(1) = hscin_1x_size * hscin_1x_nr / 2.
+ par(2) = hscin_1y_size / 2. !half width of X strips
+ par(3) = hscin_1y_dzpos * hodoscale / 2.
+ call g_ugsvolu (scinname, 'BOX ', DETMEDIA, par, 3, ivolu)
+ call gspos (scinname, 1, 'HDY1', 0., y, 0., 0, 'ONLY')
+ enddo
+ x = (hscin_2x_nr + 1.) * hscin_2x_size / 2. ! starting loci
+ do i = 1, hscin_2x_nr
+ x = x - hscin_2x_size
+ write (scinname,'(a,a)') "H2X",char(64 + i)
+ par(1) = hscin_2x_size / 2. !half width of X strips
+ par(2) = hscin_2y_size * hscin_2y_nr / 2.
+ par(3) = hscin_2x_dzpos * hodoscale / 2.
+ call g_ugsvolu (scinname, 'BOX ', DETMEDIA, par, 3, ivolu)
+ call gspos (scinname, 1, 'HDX2', x, 0., 0., 0, 'ONLY')
+ enddo
+ y = (hscin_2y_nr + 1.) * hscin_2y_size / 2. ! starting loci
+ do i = 1, hscin_2y_nr
+ y = y - hscin_2y_size
+ write (scinname,'(a,a)') "H2Y",char(64 + i)
+ par(1) = hscin_2x_size * hscin_2x_nr / 2.
+ par(2) = hscin_2y_size / 2. !half width of X strips
+ par(3) = hscin_2y_dzpos * hodoscale / 2.
+ call g_ugsvolu (scinname, 'BOX ', DETMEDIA, par, 3, ivolu)
+ call gspos (scinname, 1, 'HDY2', 0., y, 0., 0, 'ONLY')
+ enddo
+
+* Now define the shower detector
+* See the file "displaynumbering.help" for a description of the numbering of the
+* various detector elements
+
+! half width of the shower in x
+ par(1) = hmax_cal_rows * hcal_block_zsize / 2.
+! half width of the shower in y
+ par(2) = hcal_block_ysize / 2.
+! half height of the shower detector
+ par(3) = hmax_cal_columns * hcal_block_xsize / 2.
+ call g_ugsvolu ('SHOW', 'BOX ', DETMEDIA, par, 3, ivolu)
+
+!for the x offset, we take the center of the top and bottom blocks
+!This assumes that all the blocks are
+!the same heighth and width as scal_1pr
+
+ x = -(hcal_block_xc(1) + hcal_block_xc(hmax_cal_rows))/2
+ y = hcal_block_yc(1)
+ z = hcal_1pr_zpos + hmax_cal_columns*hcal_block_xsize/2.
+ call gspos ('SHOW', 1, 'HHUT', x, y, z, 0, 'ONLY')
+ call gsatt ('SHOW', 'SEEN',0)
+
+
+ par(1) = hmax_cal_rows * hcal_block_zsize / 2. ! half width of shower in x
+ par(2) = hcal_block_ysize / 2. ! half width of the shower in y
+ par(3) = hcal_block_xsize / 2. ! half height of the shower detector
+
+ z = -(hmax_cal_columns + 1.) / 2. * hcal_block_xsize
+ do ilayer = 1,hmax_cal_columns
+ z = z + hcal_block_xsize
+
+ write (layername,'(a,i1)') 'LAY',ilayer
+
+ par(1) = hmax_cal_rows * hcal_block_zsize / 2.
+ call g_ugsvolu (layername, 'BOX ', DETMEDIA, par, 3, ivolu)
+ call gspos(layername, 1, 'SHOW', 0., 0., z, 0, 'ONLY')
+
+ par(1) = hcal_block_zsize / 2. ! half width of a block
+ x = (hmax_cal_rows - 1.) / 2. * hcal_block_zsize
+ do irow = 1, hmax_cal_rows
+ write (blockname,'(a,i1,a)') 'BL',ilayer,char(64 + irow)
+ call g_ugsvolu (blockname, 'BOX ', DETMEDIA, par, 3, ivolu)
+ call gspos(blockname,1,layername, x, 0., 0., 0, 'ONLY')
+ x = x - hcal_block_zsize
+ enddo
+ enddo
+
+ end
diff --git a/ONEEV/h_one_ev_head_view.f b/ONEEV/h_one_ev_head_view.f
new file mode 100644
index 0000000..ef4a3cb
--- /dev/null
+++ b/ONEEV/h_one_ev_head_view.f
@@ -0,0 +1,100 @@
+ subroutine h_one_ev_head_view
+*
+* $Log: h_one_ev_head_view.f,v $
+* Revision 1.1 1995/09/18 14:43:31 cdaq
+* Initial revision
+*
+
+ implicit none
+
+ include 'hms_data_structures.cmn'
+ include 'hms_tracking.cmn'
+ include 'hms_geometry.cmn'
+ include 'hms_calorimeter.cmn'
+ include 'gen_event_info.cmn'
+ include 'hms_one_ev.par'
+ include 'gen_one_ev_gctrak.cmn'
+ include 'gen_one_ev_gckine.cmn'
+ include 'gen_one_ev_gcvolu.cmn'
+
+ character*5 scinname
+ integer iscin
+ character*4 blockname
+ character*5 layername
+ integer ilayer
+ integer irow
+
+ call gdopen (5)
+* first, get all the background junk out of the picture...
+ call gsatt ('HDX1','SEEN',0)
+ call gsatt ('HDX2','SEEN',0)
+ call gsatt ('HDY1','SEEN',0)
+ call gsatt ('HDY2','SEEN',0)
+ call gsatt ('SHOW','SEEN',0)
+ do iscin=1,LOWER_HODO_X_PADDLES
+ write(scinname,'(a,a)') 'H1X',char(64 + iscin)
+ call gsatt (scinname,'SEEN',0)
+ enddo
+ do iscin=1,LOWER_HODO_Y_PADDLES
+ write(scinname,'(a,a)') 'H1Y',char(64 + iscin)
+ call gsatt (scinname,'SEEN',0)
+ enddo
+ do iscin=1,UPPER_HODO_X_PADDLES
+ write(scinname,'(a,a)') 'H2X',char(64 + iscin)
+ call gsatt (scinname,'SEEN',0)
+ enddo
+ do iscin=1,UPPER_HODO_Y_PADDLES
+ write(scinname,'(a,a)') 'H2Y',char(64 + iscin)
+ call gsatt (scinname,'SEEN',0)
+ enddo
+ do ilayer =1,HMAX_CAL_COLUMNS
+ write(layername,'(a,i1)') 'LAY',ilayer
+ call gsatt (layername,'SEEN',0)
+ do irow = 1,HMAX_CAL_ROWS
+ write(blockname,'(a,i1,a)') 'BL',ilayer,char(64 + irow)
+ call gsatt (blockname,'SEEN',0)
+ enddo
+ enddo
+ call gdhits ('* ', '* ', 0, 850, 0.3)
+ call gdrawt (3.,2.,'HEAD ON VIEW',.5,0.,2,0)
+ call gdrawt (3.,1.,'HMS',.5,0.,2,0)
+ call gdraw ('HHUT', 0., 0., 90., 10.0, 10.5,0.14,0.14)
+ call h_one_ev_track
+ call gdclos (5)
+ call gdshow (5)
+ call gdshow (5)
+
+* It's already been stored, so now make everything visible again for
+* the next pass
+*
+ call gsatt ('HDX1','SEEN',1)
+ call gsatt ('HDY1','SEEN',1)
+ call gsatt ('HDX2','SEEN',1)
+ call gsatt ('HDY2','SEEN',1)
+ do iscin=1,LOWER_HODO_X_PADDLES
+ write(scinname,'(a,a)') 'H1X',char(64 + iscin)
+ call gsatt (scinname,'SEEN',1)
+ enddo
+ do iscin=1,LOWER_HODO_Y_PADDLES
+ write(scinname,'(a,a)') 'H1Y',char(64 + iscin)
+ call gsatt (scinname,'SEEN',1)
+ enddo
+ do iscin=1,UPPER_HODO_X_PADDLES
+ write(scinname,'(a,a)') 'H2X',char(64 + iscin)
+ call gsatt (scinname,'SEEN',1)
+ enddo
+ do iscin=1,UPPER_HODO_Y_PADDLES
+ write(scinname,'(a,a)') 'H2Y',char(64 + iscin)
+ call gsatt (scinname,'SEEN',1)
+ enddo
+ do ilayer =1,HMAX_CAL_COLUMNS
+ write(layername,'(a,i1)') 'LAY',ilayer
+ call gsatt (layername,'SEEN',1)
+ do irow = 1,HMAX_CAL_ROWS
+ write(blockname,'(a,i1,a)') 'BL',ilayer,char(64 + irow)
+ call gsatt (blockname,'SEEN',1)
+ enddo
+ enddo
+ call gdelet (5)
+
+ end
diff --git a/ONEEV/h_one_ev_hodo.f b/ONEEV/h_one_ev_hodo.f
new file mode 100644
index 0000000..08abe49
--- /dev/null
+++ b/ONEEV/h_one_ev_hodo.f
@@ -0,0 +1,57 @@
+ Subroutine h_one_ev_hodo
+*
+* $Log: h_one_ev_hodo.f,v $
+* Revision 1.3 1996/11/22 15:37:36 saw
+* (SAW) Fix some startup errors
+*
+* Revision 1.2 1996/06/13 14:50:23 saw
+* (SAW) Replace huge list of gsdet/gsdeth calls with do loops over the
+* detector geometry.
+*
+* Revision 1.1 1995/09/18 14:38:53 cdaq
+* Initial revision
+*
+ implicit none
+
+ include 'hms_one_ev.par'
+
+ integer iset, idet
+ character*4 varinames(3)
+ integer varibits(3)
+ integer hodobits(3)
+ real origin(3), factor(3)
+
+ integer ihod,iplane,ipaddle
+
+ character*4 specname
+ character*4 hodoname(3)
+ character*1 planenames(2)
+ integer nhods,nplanes,npaddles(4)
+
+ data specname /'HMS'/
+ data planenames /'X','Y'/
+ data nhods,nplanes,npaddles /2,2,16,10,16,10/
+
+ data varinames /'x', 'y', 'z'/
+ data varibits /32, 32, 32/
+ data hodobits /2,2,5/
+ data origin /HHUT_HEIGHT, HHUT_HEIGHT, HHUT_HEIGHT/
+ data factor /1e3, 1e3, 1e3/
+
+ do ihod=1,nhods
+ write (hodoname(1),'("HOD",i1)') ihod
+ do iplane=1,nplanes
+ write (hodoname(2),'("HD",a1,i1)') planenames(iplane),ihod
+ do ipaddle=1,npaddles((ihod-1)*2+iplane)
+ write (hodoname(3),'("H",i1,a1,a1)') ihod,planenames(iplane)
+ $ ,char(ichar('A')+ipaddle-1)
+ call gsdet(specname,hodoname(3),3,hodoname,hodobits,
+ $ 2,100,100,iset,idet)
+ call gsdeth(specname,hodoname(3),3,varinames,varibits,
+ $ origin,factor)
+ enddo
+ enddo
+ enddo
+
+ return
+ end
diff --git a/ONEEV/h_one_ev_persp_view.f b/ONEEV/h_one_ev_persp_view.f
new file mode 100644
index 0000000..7465c55
--- /dev/null
+++ b/ONEEV/h_one_ev_persp_view.f
@@ -0,0 +1,66 @@
+ subroutine h_one_ev_persp_view
+*
+* $Log: h_one_ev_persp_view.f,v $
+* Revision 1.1 1995/09/18 14:44:02 cdaq
+* Initial revision
+*
+
+ implicit none
+
+ include 'hms_data_structures.cmn'
+ include 'hms_tracking.cmn'
+ include 'hms_geometry.cmn'
+ include 'hms_calorimeter.cmn'
+ include 'gen_event_info.cmn'
+ include 'hms_one_ev.par'
+ include 'gen_one_ev_gctrak.cmn'
+ include 'gen_one_ev_gckine.cmn'
+ include 'gen_one_ev_gcvolu.cmn'
+
+ character*5 scinname
+ integer iscin
+ call gdopen (8)
+ call gdrawt (5.,2.,'PERSPECTIVE VIEW',.5,0.,2,0)
+ call gdrawt (5.,1.,'HMS',.5,0.,2,0)
+ call gdraw ('HHUT', 45., 115., 90., 3.5, 9.0, 0.05, 0.05)
+ call h_one_ev_track
+ call gdhits ('* ', '* ', 0, 850, 0.1)
+ call gdclos (8)
+*
+* blow up the wire chambers, and make the hodoscopes invisible
+*
+ call gdopen (9)
+ call gsatt ('HDX1','SEEN',0)
+ call gsatt ('HDY1','SEEN',0)
+ do iscin=1,LOWER_HODO_X_PADDLES
+ write(scinname,'(a,a)') 'H1X',char(64 + iscin)
+ call gsatt (scinname,'SEEN',0)
+ enddo
+ do iscin=1,LOWER_HODO_Y_PADDLES
+ write(scinname,'(a,a)') 'H1Y',char(64 + iscin)
+ call gsatt (scinname,'SEEN',0)
+ enddo
+ call gdraw ('HHUT', 45., 115., 90., 14.0, 6.1, 0.08, 0.08)
+ call h_one_ev_track
+ call gdhits ('* ', '* ', 0, 850, 0.3)
+ call gdclos (9)
+ call gsatt ('HDX1','SEEN',1)
+ call gsatt ('HDY1','SEEN',1)
+ call gdclos (9)
+* Now make them visible again for the next pass...
+ do iscin=1,LOWER_HODO_X_PADDLES
+ write(scinname,'(a,a)') 'H1X',char(64 + iscin)
+ call gsatt (scinname,'SEEN',1)
+ enddo
+ do iscin=1,LOWER_HODO_Y_PADDLES
+ write(scinname,'(a,a)') 'H1Y',char(64 + iscin)
+ call gsatt (scinname,'SEEN',1)
+ enddo
+ call gdshow (9)
+ call gdshow (8)
+ call gdshow (9)
+ call gdelet (8)
+ call gdelet (9)
+
+ end
+
diff --git a/ONEEV/h_one_ev_topside_view.f b/ONEEV/h_one_ev_topside_view.f
new file mode 100644
index 0000000..f04b1ef
--- /dev/null
+++ b/ONEEV/h_one_ev_topside_view.f
@@ -0,0 +1,49 @@
+ subroutine h_one_ev_topside_view
+*
+* $Log: h_one_ev_topside_view.f,v $
+* Revision 1.1 1996/01/17 16:35:46 cdaq
+* Initial revision
+*
+
+ implicit none
+
+ include 'hms_data_structures.cmn'
+ include 'hms_tracking.cmn'
+ include 'hms_geometry.cmn'
+ include 'hms_calorimeter.cmn'
+ include 'gen_event_info.cmn'
+ include 'hms_one_ev.par'
+ include 'gen_one_ev_gctrak.cmn'
+ include 'gen_one_ev_gckine.cmn'
+ include 'gen_one_ev_gcvolu.cmn'
+
+ call gdopen (7)
+ call gsatt ('HDX1','SEEN',0)
+ call gsatt ('HDX2','SEEN',0)
+ call gdrawt (4.4,2.,'TOP VIEW',.5,0.,2,0)
+ call gdrawt (4.4,1.,'HMS',.5,0.,2,0)
+ call gdraw ('HHUT', 270., 0., 90., 4.4,5.5, 0.035, 0.07)
+ call h_one_ev_track
+ call gdhits ('* ', '* ', 0, 850, 0.1)
+ call gdhits ('HOD1', 'HDY1', 0, 850, 0.1)
+ call gdhits ('HOD2', 'HDY2', 0, 850, 0.1)
+ call gdclos (7)
+*
+*
+* Other side view
+*
+ call gdopen (6)
+ call gsatt ('HDY1','SEEN',0)
+ call gsatt ('HDY2','SEEN',0)
+ call gdrawt (14.75,2.,'SIDE VIEW',.5,0.,2,0)
+ call gdraw ('HHUT', 90., 90., 90., 14.75,5.5,0.035, 0.07)
+ call h_one_ev_track
+ call gdhits ('* ', '* ', 0, 850, 0.1)
+ call gdclos (6)
+ call gdshow (7)
+ call gdshow (6)
+ call gdshow (7)
+ call gdelet (6)
+ call gdelet (7)
+
+ end
diff --git a/ONEEV/h_one_ev_track.f b/ONEEV/h_one_ev_track.f
new file mode 100644
index 0000000..12bb6f8
--- /dev/null
+++ b/ONEEV/h_one_ev_track.f
@@ -0,0 +1,75 @@
+ subroutine h_one_ev_track
+*
+* $Log: h_one_ev_track.f,v $
+* Revision 1.1 1996/01/17 16:39:41 cdaq
+* Initial revision
+*
+
+ implicit none
+
+ include 'hms_data_structures.cmn'
+ include 'hms_tracking.cmn'
+ include 'hms_geometry.cmn'
+ include 'hms_calorimeter.cmn'
+ include 'gen_event_info.cmn'
+ include 'hms_one_ev.par'
+ include 'gen_one_ev_gctrak.cmn'
+ include 'gen_one_ev_gckine.cmn'
+ include 'gen_one_ev_gcvolu.cmn'
+
+ real track_x, track_y, track_z ! a point on the track
+ real track_x_slope, track_y_slope ! slope of the track
+ real x, y, z ! coordinates
+ real z_distance ! z distance to end of hut
+ integer track ! index variables
+*
+* Take care of creating the reconstructed tracks
+*
+ vect(4) = 0.0
+ vect(5) = 0.0
+ vect(6) = 1.
+ vect(7) = 1.
+* ipart = 3 !electron to make track red
+* ipart = 13 !neutron to make track black
+* ipart = 5 !muon to make track green
+ ipart = 1 !photon to make track blue
+ tofg = 1e-5
+ itra = 1
+* amass = 0.511e-3
+* amass = 0.93957
+ sleng = 200.
+ step = 200.
+
+ do track = 1, HNTRACKS_FP
+ ipart = 1 !photon to make track blue
+ if (track.eq.HSNUM_FPTRACK) then
+ ipart = 3 !electron to make track red
+ endif
+ track_x = -hx_fp(track) ! x position on track
+ track_y = hy_fp(track) ! y position on track
+ track_z = 0 ! z position on track
+ track_x_slope = -hxp_fp(track) ! track slope in x
+ track_y_slope = hyp_fp(track) ! track slope in y
+
+ z = -HHUT_HEIGHT / 2. ! bottom of hut
+ z_distance = track_z - z ! distance from point to floor
+ x = track_x - z_distance * sin(track_x_slope) ! x loci
+ y = track_y - z_distance * sin(track_y_slope) ! y loci
+ vect(1) = x
+ vect(2) = y
+ vect(3) = z
+ call gsxyz
+ z = HHUT_HEIGHT / 2. ! bottom of hut
+ z_distance = z - track_z ! distance from point to roof
+ x = track_x + z_distance * sin(track_x_slope) ! x loci
+ y = track_y + z_distance * sin(track_y_slope) ! y loci
+ vect(1) = x
+ vect(2) = y
+ vect(3) = z
+ call gsxyz
+ call gdxyz (track)
+* call gdpart (itra,01,0.5) !this will number the tracks
+ itra = itra+1
+* ipart = ipart+1 !this changes the color for each track
+ enddo
+ end
diff --git a/ONEEV/h_one_ev_wc.f b/ONEEV/h_one_ev_wc.f
new file mode 100644
index 0000000..2261ff6
--- /dev/null
+++ b/ONEEV/h_one_ev_wc.f
@@ -0,0 +1,79 @@
+ subroutine h_one_ev_wc
+*
+* $Log: h_one_ev_wc.f,v $
+* Revision 1.2 1996/01/17 16:39:33 cdaq
+* (DVW) Fixes
+*
+* Revision 1.1 1995/09/14 15:42:40 cdaq
+* Initial revision
+*
+
+ implicit none
+ include 'hms_one_ev.par'
+
+ integer iset, idet
+ character*4 varinames(3)
+ integer varibits(3)
+ integer chambits(3)
+ real origin(3),factor(3)
+ integer i
+
+ character*4 wire
+ integer ichamber
+ integer isector
+ integer iwire
+ integer iplane
+
+ character*4 specname
+ character*4 wcname(3)
+ character*1 sectorthingy
+ integer nchambers
+ integer nplanes
+ character*1 planenames(4)
+ integer sectors(4),wires(4)
+
+ data specname,nchambers /'HMS ',2/
+ data nplanes /4/
+ data planenames /'X','Y','U','V'/
+ data sectors /12,4,6,6/
+ data wires /19,26,18,18/
+
+ data varinames /'x','y','z'/
+ data chambits /2,3,8/
+
+ do i=1,3
+ varibits(i)=32
+ origin(i)=HHUT_HEIGHT
+ factor(i)=1e3
+ enddo
+
+ do ichamber=1,nchambers
+ write (wcname(1),'("WCH",a1)') char(64 + ichamber)
+ do iplane=1,nplanes
+ do isector=1,sectors(iplane)
+ sectorthingy = 'A'
+*
+* There is only one U and one V plane per chamber
+*
+ if(planenames(iplane).ne.'U'.and.planenames(iplane).ne.'V'
+ $ .and.isector.gt.sectors(iplane)/2) then
+ sectorthingy = 'B'
+ endif
+ write(wcname(2),'("W",3a1)') char(64 + ichamber)
+ $ ,sectorthingy,planenames(iplane)
+ do iwire = 1,wires(iplane)
+ write (wire,'(a,a,a,a)') char(64 + ichamber)
+ $ ,planenames(iplane),char(64 + isector)
+ $ ,char(64 + iwire)
+ wcname(3) = wire
+ call gsdet(specname,wire,3,wcname,chambits,
+ $ 2, 100, 100, iset, idet)
+ call gsdeth(specname,wire,3,varinames,varibits,origin,factor)
+ enddo
+ enddo
+ enddo
+ enddo
+
+ return
+ end
+
diff --git a/ONEEV/h_uginit.f b/ONEEV/h_uginit.f
new file mode 100644
index 0000000..47a5f2c
--- /dev/null
+++ b/ONEEV/h_uginit.f
@@ -0,0 +1,31 @@
+ subroutine h_uginit
+*
+* Do the GEANT initalization
+*
+* August, 1994, Pat Welch, Oregon State University, tpw@physics.orst.edu
+*
+* $Log: h_uginit.f,v $
+* Revision 1.1 1995/03/14 21:27:13 cdaq
+* Initial revision
+*
+
+ implicit none
+
+ call ginit ! init GEANT
+ call gzinit ! init GEANT data structs
+ call gdinit ! init GEANT drawing package
+
+ call gpart ! init particle structures
+ call gmate ! init materials structures
+ call gsrotm(1,90.,0.,90.,90.,0.,0.)
+ call gsrotm(2,90.,90.,90.,0.,0.,0.)
+ call gsrotm(3,90.,15.,90.,105.,0.,0.)
+ call gsrotm(4,90.,345.,90.,75.,0.,0.)
+
+ call h_one_ev_geometry ! define the geometry
+ call h_one_ev_detectors ! define sensitive detectors
+ call ggclos ! close geometry structures
+
+ call gphysi ! init physics interaction vars
+
+ end
diff --git a/ONEEV/revdis_ask.f b/ONEEV/revdis_ask.f
new file mode 100644
index 0000000..d381c4a
--- /dev/null
+++ b/ONEEV/revdis_ask.f
@@ -0,0 +1,130 @@
+ integer function revdis_ask(view)
+*
+* User interaction.
+*
+* Return -1 to exit, 0 to go to the next event, or a number to review
+* the current event with a different view.
+*
+* $Log: revdis_ask.f,v $
+* Revision 1.1 1996/01/17 16:31:52 cdaq
+* Initial revision
+*
+*
+ implicit none
+ save
+
+ integer view
+
+ INCLUDE 'gen_one_ev_info.cmn'
+ include 'gen_routines.dec'
+
+ integer*4 MLEN
+ parameter (MLEN=132)
+ character*132 oline,line,line_copy
+ integer retval,i
+ integer NVIEWS
+ parameter (NVIEWS=3)
+ real*8 deval
+ integer*4 ieval
+ character*1 cviews(NVIEWS)
+ integer*4 iviews(NVIEWS)
+ character*20 ffmt
+ character*20 ifmt
+ data cviews /'A','B','C'/
+ data iviews /1,2,3/
+ data ffmt/'e12.4'/
+ data ifmt/'i10'/
+
+ do while (.true.)
+ write(6,'($,a)') ': '
+ read(5,'(a)',err=99,end=99) oline
+
+ call shiftall(oline,line)
+ call no_blanks(line)
+ if(line.eq.' ') then ! Display next event
+ retval = 0
+ goto 1000 ! return
+ endif
+
+ if(line(1:1).eq.line) then ! Single character view selection
+ do i=1,NVIEWS
+ if(line.eq.cviews(i)) then
+ retval = iviews(i)
+ goto 1000
+ endif
+ enddo
+ endif
+ if(line(1:10).eq.'MAXEVENTS=') then
+ read(line(11:MLEN),'(i10)') gen_display_wait_events
+ else if(line(1:8).eq.'MAXTIME=') then
+ read(line(9:MLEN),'(i10)') gen_display_wait_seconds
+ else if(line(1:5).eq.'VIEW=') then
+ read(line(6:MLEN),'(i10)') retval
+ if(retval.le.0) retval=1
+ goto 1000
+ else if(line(1:5).eq.'IFMT=') then
+ ifmt = line(6:MLEN)
+ else if(line(1:5).eq.'FFMT=') then
+ ffmt = line(6:MLEN)
+ else if(line(1:7).eq.'STATUS ') then
+ write(6,'("Test= ",a)') gen_display_interesting(1:67)
+ write(6,'("MAXTIME= ",i7," seconds")') gen_display_wait_seconds
+ write(6,'("MAXEVENTS=",i7," events")') gen_display_wait_events
+ write(6,'("VIEW= ",i7)') view
+ else if(line(1:1).eq.'?') then
+ write(6,*) ' Options:'
+ write(6,*) ' MAXTIME= seconds ! time limit'
+ write(6,*) ' MAXEVENTS= n ! event limit'
+ write(6,*) ' STATUS ! display info'
+ write(6,*) ' QUIT or EXIT ! exit the program'
+ write(6,*) ' =ctp expression ! Print expression value'
+ write(6,*) ' ctp logical expression ! Event selection test'
+ write(6,*) ' a ! Display 3D view'
+ write(6,*) ' b ! Display top and side views'
+ write(6,*) ' c ! Display a head on view of the chambers'
+ write(6,*) ' '
+ else if(line(1:1).eq.'=') then
+ line_copy = line(2:MLEN)
+ if(thevalchk(line_copy).eq.0) then
+ deval = dtheval(line_copy)
+ ieval = deval
+ if(ieval.eq.deval) then
+ write(6,'("Expression = "'//ifmt//')') ieval
+ else
+ write(6,'("Expression = "'//ffmt//')') deval
+ endif
+ else
+ write(6,*) 'Invalid Expression'
+ endif
+ else if(line(1:5).eq.'EXIT '.or.line(1:5).eq.'QUIT
+ $ '.or.line(1:2).eq.'Q ') then
+ retval = -1
+ goto 1000
+ else ! Presumed to be a test expression
+ if(thevalchk(line).ne.0) then
+ write(6,*) "Illegal event selection test"
+ else if(index(line,'=').gt.0 .and.
+ $ (index(line,'==').eq.0
+ $ .and. index(line,'!=').eq.0
+ $ .and. index(line,'>=').eq.0
+ $ .and. index(line,'<=').eq.0)) then
+ write(6,*) 'Illegal: Use "==" for (is equal to) operator'
+ else
+ gen_display_interesting = line
+ retval=0
+ goto 1000
+ endif
+ endif
+ enddo
+*
+
+
+ 99 continue
+ retval = -1
+ goto 1000
+
+ 1000 continue
+ revdis_ask = retval
+ return
+
+ end
diff --git a/ONEEV/revdis_getev.f b/ONEEV/revdis_getev.f
new file mode 100644
index 0000000..91618be
--- /dev/null
+++ b/ONEEV/revdis_getev.f
@@ -0,0 +1,51 @@
+ subroutine revdis_getev(FAIL,why)
+*--------------------------------------------------------
+*- Return an interesting event or give up after a wait
+*
+* 4-Oct-1994 K.B.Beard, Hampton U.
+* $Log: revdis_getev.f,v $
+* Revision 1.2 1996/01/17 16:32:49 cdaq
+* (SAW) Change an include file name
+*
+* Revision 1.1 1995/03/14 21:25:45 cdaq
+* Initial revision
+*
+*--------------------------------------------------------
+ IMPLICIT NONE
+ SAVE
+*
+ CHARACTER*12 here
+ PARAMETER (here= 'revdis_getev')
+*
+ logical FAIL
+ character*(*) why
+*
+ integer ierr
+*
+ INCLUDE 'gen_one_ev_info.cmn'
+ INCLUDE 'gen_routines.dec'
+*
+*--------------------------------------------------------
+*
+ FAIL = .false.
+*
+ call thservset(gen_display_server_RPCprgmID,2)
+ ierr = thcgetlist(gen_display_event_info,gen_display_RPCclientID
+ $ ,gen_display_interesting,gen_display_wait_seconds
+ $ ,gen_display_wait_events)
+ call thservunset(gen_display_server_RPCprgmID,2)
+
+ if(ierr.ne.0) then
+ write(why,'(":thcgetlist failed with error",i5)') ierr
+ call G_add_path(here,why)
+ FAIL = .true.
+ else
+ why = ' '
+ endif
+*
+ RETURN
+ END
+
+
+
+
diff --git a/ONEEV/revdis_init.f b/ONEEV/revdis_init.f
new file mode 100644
index 0000000..f824720
--- /dev/null
+++ b/ONEEV/revdis_init.f
@@ -0,0 +1,161 @@
+ subroutine revdis_init(ABORT,err)
+*--------------------------------------------------------
+* $Log: revdis_init.f,v $
+* Revision 1.4 2003/02/14 18:27:22 jones
+* minor change to run on Alpha OSF1 systems (E. Brash)
+*
+* Revision 1.3 1996/01/17 16:34:52 cdaq
+* (SAW) Change an include file name
+*
+* Revision 1.2 1995/07/28 18:08:03 cdaq
+* (SAW) Cosmetic changes
+*
+* Revision 1.1 1995/03/14 21:26:16 cdaq
+* Initial revision
+*
+*--------------------------------------------------------
+*
+ IMPLICIT NONE
+ SAVE
+*
+ character*11 here
+ parameter (here= 'revdis_init')
+*
+ logical ABORT
+ character*(*) err
+*
+ INCLUDE 'gen_one_ev_info.cmn'
+ INCLUDE 'gen_routines.dec'
+*
+ integer size
+ logical wait
+ real now,tstart,waitS
+ integer got,get_fail
+
+ real MAX_time
+ parameter (MAX_time= 10.) !seconds
+
+ integer MAX_failures
+ parameter (MAX_failures= 100) !attempts
+*
+*--------------------------------------------------------
+*
+ err= ' '
+*
+ gen_display_RPCclientID= clnt_create(
+ & gen_display_server_machine,
+ & gen_display_server_RPCprgmID,
+ & gen_display_server_RPCversionID,'tcp')
+*
+ ABORT= gen_display_RPCclientID.EQ.0
+ IF(ABORT) THEN
+ write(err,'(":clnt_create ABORTed for RPC program ID# (",i10,",",i5
+ $ ,") [0x",z8,",0x",z5,"] on machine ",a)')
+ $ gen_display_server_RPCprgmID,gen_display_server_RPCversionID,
+ $ gen_display_server_RPCprgmID,gen_display_server_RPCversionID,
+ $ gen_display_server_machine
+ call G_append(here,err)
+ RETURN
+ ELSE
+ write(err,'(":clnt_create OK for RPC program ID#",i10," [0x",z8,"] on machine ",a)')
+ $ gen_display_server_RPCprgmID,gen_display_server_RPCprgmID
+ $ ,gen_display_server_machine
+ call G_add_path(here,err)
+ call G_add_path('INFO--',err)
+ call G_wrap_note(6,err)
+ err= ' '
+ ENDIF
+*
+ gen_display_everything= thcrlist()
+ size= thaddlist(gen_display_everything,'*') !list of everything
+* size= thremlist(gen_display_everything,'parm.ONE_EV')
+* size= thremlist(gen_display_everything,'parm.GRAPH_IO_DEV')
+ ABORT= size.LE.0
+ IF(ABORT) THEN
+ write(err,'(":ABORTed to get list for gen_display_everything",
+ $ i10)') gen_display_everything
+ call G_add_path(here,err)
+ RETURN
+ ELSE
+ write(err,'(":list gen_display_everything handle=",i10,
+ $ " size=",i5)') gen_display_everything,size
+ call G_add_path(here,err)
+ call G_add_path('INFO--',err)
+ call G_wrap_note(6,err)
+ err= ' '
+ ENDIF
+*
+ gen_display_event_info= thcrlist()
+ size= thaddlist(gen_display_event_info,'event.*') !list of all event stuff
+
+ ABORT= size.LE.0
+ IF(ABORT) THEN
+ write(err,'(":ABORTed to get list for gen_display_event_info",
+ $ i10)') gen_display_event_info
+ call G_add_path(here,err)
+ RETURN
+ ELSE
+ write(err,'(":list gen_display_event_info handle=",i10,
+ $ " size=",i5)') gen_display_event_info,size
+ call G_add_path(here,err)
+ call G_add_path('INFO--',err)
+ call G_wrap_note(6,err)
+ err= ' '
+ ENDIF
+*
+* Now dowload all the variables from the server
+*
+ call TIMEX(tstart)
+ get_fail= 0
+ err= ' '
+ wait= .TRUE.
+*
+ DO WHILE(wait)
+*
+ got=
+ & thgetlist(gen_display_everything,gen_display_RPCclientID)
+*
+ PRINT *,here//' got=',got
+
+ ABORT= got.lt.0
+ If(ABORT) get_fail= get_fail+1
+*
+ call TIMEX(now)
+ waitS= now-tstart !seconds since entered this routine
+*
+ wait= ABORT .and. waitS.LE.MAX_time .and.
+ & get_fail.LT.MAX_failures
+*
+ ENDDO
+*
+ IF(ABORT) THEN
+ write(err,'(":quit after",f6.1," [",f6.1,"] seconds and",i7," ["
+ $ ,i7,"] thgetlist failures#",i7,a)') waitS,MAX_time,get_fail
+ $ ,MAX_failures, got
+ call G_append(here,err)
+ ELSEIF(get_fail.GT.0) THEN !info. message
+ write(err,'(":quit after",f6.1," [",f6.1,"] seconds and",i7," ["
+ $ ,i7,"] thgetlist failures#",i7,a)') waitS,MAX_time,get_fail
+ $ ,MAX_failures, got
+ call G_append(here,err)
+ ELSE
+ err= ' ' !first try success!
+ ENDIF
+
+
+
+c call G_edisp_start(ABORT,err)
+ IF(ABORT) THEN
+ call G_add_path(here,err)
+ RETURN
+ ELSEIF(err.NE.' ') THEN
+ call G_add_path(here,err)
+ call G_add_path('INFO--',err)
+ call G_wrap_note(6,err)
+ err= ' '
+ ENDIF
+*
+ RETURN
+ END
+
+
diff --git a/ONEEV/s_one_ev_cal.f b/ONEEV/s_one_ev_cal.f
new file mode 100644
index 0000000..e6d0201
--- /dev/null
+++ b/ONEEV/s_one_ev_cal.f
@@ -0,0 +1,53 @@
+ subroutine s_one_ev_cal
+*
+* $Log: s_one_ev_cal.f,v $
+* Revision 1.3 1996/11/22 15:35:56 saw
+* (SAW) Fix some error messages at startup, some code cleanup
+*
+* Revision 1.2 1996/09/04 20:07:58 saw
+* (SAW) Replace huge list of gsdet/gsdeth calls with do loops over the
+* detector geometry.
+*
+* Revision 1.1 1995/09/18 14:37:33 cdaq
+* Initial revision
+*
+
+ implicit none
+
+ include 'sos_data_structures.cmn'
+ include 'sos_calorimeter.cmn'
+ include 'sos_one_ev.par'
+
+ integer iset, idet
+ character*4 varinames(3)
+ integer varibits(3)
+ integer calbits(2)
+ real origin(3),factor(3)
+
+ integer ilayer,iblock
+
+ character*4 specname
+ character*4 calname(2)
+
+ data specname /'SOS '/
+
+ data varinames /'x', 'y', 'z'/
+ data varibits /32, 32, 32/
+ data calbits /4,4/
+ data origin /SHUT_HEIGHT, SHUT_HEIGHT, SHUT_HEIGHT/
+ data factor /1e3, 1e3, 1e3/
+
+
+ do ilayer=1,smax_cal_columns
+ write (calname(1),'("LAY",i1)') ilayer
+ do iblock=1,smax_cal_rows
+ write (calname(2),'("BL",i1,a1)') ilayer, char(ichar('A')+iblock-1)
+ call gsdet(specname,calname(2),2,calname,calbits,
+ $ 2,100,100,iset,idet)
+ call gsdeth(specname,calname(2),3,varinames,varibits,origin,factor)
+ enddo
+ enddo
+
+ return
+ end
+
diff --git a/ONEEV/s_one_ev_det_reset.f b/ONEEV/s_one_ev_det_reset.f
new file mode 100644
index 0000000..6da059f
--- /dev/null
+++ b/ONEEV/s_one_ev_det_reset.f
@@ -0,0 +1,119 @@
+ subroutine s_one_ev_det_reset
+*
+* This routine will reset the hit indicators for the detector elements
+* Hall C
+*
+* July 1995 Derek van Westrum (vanwestr@cebaf.gov)
+*
+* $Log: s_one_ev_det_reset.f,v $
+* Revision 1.2 1996/01/17 16:40:27 cdaq
+* (SAW) Change an include file name
+*
+* Revision 1.1 1995/07/31 15:24:52 cdaq
+* Initial revision
+*
+
+ implicit none
+
+ include 'sos_data_structures.cmn'
+ include 'sos_tracking.cmn'
+ include 'sos_geometry.cmn'
+ include 'sos_calorimeter.cmn'
+ include 'gen_event_info.cmn'
+ include 'sos_one_ev.par'
+ include 'gen_one_ev_gctrak.cmn'
+ include 'gen_one_ev_gckine.cmn'
+ include 'gen_one_ev_gcvolu.cmn'
+ character*5 scinname
+ character*5 blockname
+ integer istrip
+ integer ihodo
+ integer ilayer
+ integer iblock
+ character*4 wire
+ integer ichamber
+ integer isector
+ integer iwire
+*
+* First, clear the lower xpaddles
+*
+ do istrip=1,LOWER_HODO_X_PADDLES
+ write (scinname,'(a,a)') 'H1X',char(64 + istrip)
+ call gsatt (scinname,'COLO',1)
+ call gsatt (scinname,'FILL',0)
+ enddo
+*
+* next, clear the upper x hodoscopes:
+*
+ do istrip=1,UPPER_HODO_X_PADDLES
+ write (scinname,'(a,a)') 'H2X',char(64 + istrip)
+ call gsatt (scinname,'COLO',1)
+ call gsatt (scinname,'FILL',0)
+ enddo
+*
+* now clear the lower Y hodoscopes:
+*
+ do istrip=1,LOWER_HODO_Y_PADDLES
+ write (scinname,'(a,a)') 'H1Y',char(64 + istrip)
+ call gsatt (scinname,'COLO',1)
+ call gsatt (scinname,'FILL',0)
+ enddo
+*
+* finally, clear the upper y hodoscopes:
+*
+ do istrip=1,UPPER_HODO_Y_PADDLES
+ write (scinname,'(a,a)') 'H2Y',char(64 + istrip)
+ call gsatt (scinname,'COLO',1)
+ call gsatt (scinname,'FILL',0)
+ enddo
+*
+* Now clear the shower counter blocks.
+*
+ do ilayer=1,smax_cal_columns
+ do iblock=1,smax_cal_rows
+ write (blockname,'(a,i1,a)') 'BL',ilayer,CHAR(64 + iblock)
+ call gsatt (blockname,'COLO',1)
+ call gsatt (blockname,'FILL',0)
+ enddo
+ enddo
+*
+* Now clear the wire chambers...
+*
+* first the U wires...
+ do ichamber=1,2
+ do isector=1,4
+ do iwire = 1,24
+ write (wire,'(a,a,a,a)') char(64 + ichamber),'U',
+ $ char(64 + isector),char(64 + iwire)
+ call gsatt (wire,'COLO',1)
+ call gsatt (wire,'SEEN',0)
+ call gsatt (wire,'FILL',0)
+ enddo
+ enddo
+ enddo
+* then the X wires
+ do ichamber=1,2
+ do isector=1,8
+ do iwire = 1,16
+ write (wire,'(a,a,a,a)') char(64 + ichamber),'X',
+ $ char(64 + isector),char(64 + iwire)
+ call gsatt (wire,'COLO',1)
+ call gsatt (wire,'SEEN',0)
+ call gsatt (wire,'FILL',0)
+ enddo
+ enddo
+ enddo
+* then the V wires
+ do ichamber=1,2
+ do isector=1,4
+ do iwire = 1,24
+ write (wire,'(a,a,a,a)') char(64 + ichamber),'V',
+ $ char(64 + isector),char(64 + iwire)
+ call gsatt (wire,'COLO',1)
+ call gsatt (wire,'SEEN',0)
+ call gsatt (wire,'FILL',0)
+ enddo
+ enddo
+ enddo
+
+ end
diff --git a/ONEEV/s_one_ev_detectors.f b/ONEEV/s_one_ev_detectors.f
new file mode 100644
index 0000000..11294d3
--- /dev/null
+++ b/ONEEV/s_one_ev_detectors.f
@@ -0,0 +1,22 @@
+ subroutine s_one_ev_detectors
+*
+* Define geant detector sets
+*
+* August, 1994, Pat Welch, Oregon State University, tpw@physics.orst.edu
+*
+* Modified from HMS version, h_one_ev_detectors, March 1995 by
+* Derek van Westrum (vanwestr@cebaf.gov)
+*
+* $Log: s_one_ev_detectors.f,v $
+* Revision 1.2 1995/09/18 14:38:09 cdaq
+* (SAW) Remove unneeded declartions
+*
+* Revision 1.1 1995/07/31 15:23:05 cdaq
+* Initial revision
+*
+
+ call s_one_ev_hodo
+ call s_one_ev_cal
+ call s_one_ev_wc
+
+ end
diff --git a/ONEEV/s_one_ev_display.f b/ONEEV/s_one_ev_display.f
new file mode 100644
index 0000000..8d260ec
--- /dev/null
+++ b/ONEEV/s_one_ev_display.f
@@ -0,0 +1,35 @@
+ subroutine s_one_ev_display(iview)
+*
+* This routine will store digitized hits for use in the one event display for
+* Hall C
+*
+* August, 1994, Pat Welch, Oregon State University, tpw@physics.orst.edu
+*
+* Modified from HMS version, h_one_ev_display, on March 1995 by
+* Derek van Westrum (vanwestr@cebaf.gov)
+*
+* $Log: s_one_ev_display.f,v $
+* Revision 1.3 1996/01/17 16:31:33 cdaq
+* (DVW) Add iview argument, make improvements.
+*
+* Revision 1.2 1995/09/18 14:43:20 cdaq
+* (DVW) Improvements
+*
+* Revision 1.1 1995/07/31 15:25:20 cdaq
+* Initial revision
+*
+
+ implicit none
+
+ integer iview
+
+ call ixclrwi
+ if (iview.le.1) then
+ call s_one_ev_persp_view !draw the perspective view
+ elseif (iview.eq.2) then
+ call s_one_ev_topside_view !draw the two side views
+ elseif (iview.ge.3) then
+ call s_one_ev_head_view !draw the head on view
+ endif
+
+ end
diff --git a/ONEEV/s_one_ev_generate.f b/ONEEV/s_one_ev_generate.f
new file mode 100644
index 0000000..d234ad1
--- /dev/null
+++ b/ONEEV/s_one_ev_generate.f
@@ -0,0 +1,486 @@
+ subroutine s_one_ev_generate
+*
+* $Log: s_one_ev_generate.f,v $
+* Revision 1.2 1996/09/04 20:06:35 saw
+* (SAW) hdc_nrwire already integer, don't nint it.
+*
+* Revision 1.1 1996/01/17 16:37:21 cdaq
+* Initial revision
+*
+
+ implicit none
+
+ include 'sos_data_structures.cmn'
+ include 'sos_tracking.cmn'
+ include 'sos_geometry.cmn'
+ include 'sos_calorimeter.cmn'
+ include 'gen_event_info.cmn'
+ include 'gen_run_info.cmn'
+ include 'sos_one_ev.par'
+ include 'gen_one_ev_gctrak.cmn'
+ include 'gen_one_ev_gckine.cmn'
+ include 'gen_one_ev_gcvolu.cmn'
+
+ character*4 lnames(0:3) ! volume names
+ integer lnums(0:3) ! volume numbers or copies
+ real xd(3), xm(3) ! coordinates
+ integer error_code ! error return code
+ integer chamhit,scinhit,showhit ! index variables
+ integer wirenum ! indicates GEANT wirenumber
+
+ character*5 wire !define names and indicies to loop over...
+ character*5 scinname
+ character*4 blockname
+ character*5 layername
+
+*
+* Reset the detector hit indicators...
+ call s_one_ev_det_reset
+*
+* Clear any previous drawing
+*
+ call iclrwk (0, 0)
+ call gtrigc
+ call gtrigi
+*
+* define some colors for the various wires, and turn shading on
+*
+ call iscr(1,1,.5,.5,.5) !make the detectors grey
+ call iscr(1,15,1.,0.7,0.2) !define an "orange"
+ call iscr(1,13,0.,.65,0.) !define a "dark green"
+ call iscr(1,14,0.,0.,1.) !define a dark blue
+ call gdopt ('SHAD','ON')
+
+*
+* Now loop over all the detector elements "lighting" each one if it has been hit
+*
+ xd(1) = 0. ! find the center of the detector
+ xd(2) = 0. ! find the center of the detector
+ xd(3) = 0. ! find the center of the detector
+* Start with the wire chambers
+* See the file "displaynumbering.help" for a description of the numbering of the
+* various detector elements
+*
+ if (SDC_TOT_HITS .GT. 0) then
+ lnames(0) = 'SHUT'
+ lnums(0) = 1
+ do chamhit = 1, SDC_TOT_HITS
+**************************************************************************************
+*UUU
+****
+ if (SDC_PLANE_NUM(chamhit) .EQ. 1) then
+ nlevel = 0 ! initial value for # of levels
+ lnames(1) = 'WCHA' ! level one
+ lnums(1) = 1 ! copy one, higher chamber
+ lnames(2) = 'WAAU' ! U plane
+ lnums(2) = 1 ! copy one
+ wirenum = (sdc_nrwire(SDC_PLANE_NUM(chamhit))) + 1
+ & - SDC_WIRE_NUM(chamhit)
+ if (SDC_WIRE_COUNTING(SDC_PLANE_NUM(chamhit)) .EQ. 1)
+ & wirenum = SDC_WIRE_NUM(chamhit)
+ if (wirenum .le. 24) write(wire,'(a,a,a,a)') 'AUA',char(64 + wirenum)
+ if (wirenum .gt. 24) write(wire,'(a,a,a,a)') 'AUB',char(64 - 24 + wirenum)
+ lnames(3) = wire ! U wires
+ lnums(3) = wirenum ! wire number
+ call glvolu (4, lnames, lnums, error_code)
+ call gdtom (xd, xm, 1) ! transform from detector to MARS
+ call gsatt (wire,'SEEN',1)
+ call gsatt (wire,'COLO',13)
+* call gsahit (1, 4, 1, lnums(1), xm, ihit) ! store the hit
+**************************************************************************************
+*UUU
+****
+ elseif (SDC_PLANE_NUM(chamhit) .EQ. 2) then
+ nlevel = 0 ! initial value for # of levels
+ lnames(1) = 'WCHA' ! level one
+ lnums(1) = 1 ! copy one, higher chamber
+ lnames(2) = 'WABU' ! U plane
+ lnums(2) = 1 ! copy one
+ wirenum = (sdc_nrwire(SDC_PLANE_NUM(chamhit))) + 1
+ & - SDC_WIRE_NUM(chamhit)
+ if (SDC_WIRE_COUNTING(SDC_PLANE_NUM(chamhit)) .EQ. 1)
+ & wirenum = SDC_WIRE_NUM(chamhit)
+ if (wirenum .le. 24) write(wire,'(a,a,a,a)') 'AUC',char(64 + wirenum)
+ if (wirenum .gt. 24) write(wire,'(a,a,a,a)') 'AUD',char(64 - 24 + wirenum)
+ lnames(3) = wire ! U wires
+ lnums(3) = wirenum ! wire number
+ call glvolu (4, lnames, lnums, error_code)
+ call gdtom (xd, xm, 1) ! transform from detector to MARS
+ call gsatt (wire,'SEEN',1)
+ call gsatt (wire,'COLO',13)
+* call gsahit (1, 4, 1, lnums(1), xm, ihit) ! store the hit
+**************************************************************************************
+*VVV
+****
+ elseif (SDC_PLANE_NUM(chamhit) .EQ. 3) then
+ nlevel = 0 ! initial value for # of levels
+ lnames(1) = 'WCHA' ! level one
+ lnums(1) = 1 ! copy one, higher chamber
+ lnames(2) = 'WAAX' ! X plane
+ lnums(2) = 1 ! copy one
+ wirenum = (SDC_nrwire(SDC_PLANE_NUM(chamhit))) + 1
+ & - SDC_WIRE_NUM(chamhit)
+ if (SDC_WIRE_COUNTING(SDC_PLANE_NUM(chamhit)) .EQ. 1)
+ & wirenum = SDC_WIRE_NUM(chamhit)
+ if (wirenum .le. 16) write(wire,'(a,a,a,a)') 'AXA',char(64 + wirenum)
+ if ((wirenum .gt. 16) .and. (wirenum .le. 32)) write(wire,'(a,a,a,a)')
+ $ 'AXB',char(64 - 16 + wirenum)
+ if ((wirenum .gt. 32) .and. (wirenum .le. 48)) write(wire,'(a,a,a,a)')
+ $ 'AXC',char(64 - 32 + wirenum)
+ if ((wirenum .gt. 48) .and. (wirenum .le. 64)) write(wire,'(a,a,a,a)')
+ $ 'AXD',char(64 - 48 + wirenum)
+ lnames(3) = wire
+ lnums(3) = wirenum ! wire number
+ call glvolu (4, lnames, lnums, error_code)
+ call gdtom (xd, xm, 1) ! transform from detector to MARS
+ call gsatt (wire,'SEEN',1)
+ call gsatt (wire,'COLO',13)
+* call gsahit (1, 6, 1, lnums(1), xm, ihit) ! store the hit
+**************************************************************************************
+*VVV
+****
+ elseif (SDC_PLANE_NUM(chamhit) .EQ. 4) then
+ nlevel = 0 ! initial value for # of levels
+ lnames(1) = 'WCHA' ! level one
+ lnums(1) = 1 ! copy one, higher chamber
+ lnames(2) = 'WABX' ! X plane
+ lnums(2) = 1 ! copy one
+ wirenum = (SDC_nrwire(SDC_PLANE_NUM(chamhit))) + 1
+ & - SDC_WIRE_NUM(chamhit)
+ if (SDC_WIRE_COUNTING(SDC_PLANE_NUM(chamhit)) .EQ. 1)
+ & wirenum = SDC_WIRE_NUM(chamhit)
+ if (wirenum .le. 16) write(wire,'(a,a,a,a)') 'AXE',char(64 +
+ $ wirenum)
+ if ((wirenum .gt. 16) .and. (wirenum .le. 32)) write(wire
+ $ ,'(a,a,a,a)')'AXF',char(64 - 16 + wirenum)
+ if ((wirenum .gt. 32) .and. (wirenum .le. 48)) write(wire
+ $ ,'(a,a,a,a)')'AXG',char(64 - 32 + wirenum)
+ if ((wirenum .gt. 48) .and. (wirenum .le. 64)) write(wire
+ $ ,'(a,a,a,a)')'AXH',char(64 - 48 + wirenum)
+ lnames(3) = wire
+ lnums(3) = wirenum ! wire number
+ call glvolu (4, lnames, lnums, error_code)
+ call gdtom (xd, xm, 1) ! transform from detector to MARS
+ call gsatt (wire,'SEEN',1)
+ call gsatt (wire,'COLO',13)
+* call gsahit (1, 6, 1, lnums(1), xm, ihit) ! store the hit
+**************************************************************************************
+*XXX
+****
+ elseif (SDC_PLANE_NUM(chamhit) .EQ. 5) then
+ nlevel = 0 ! initial value for # of levels
+ lnames(1) = 'WCHA' ! level one
+ lnums(1) = 1 ! copy one, higher chamber
+ lnames(2) = 'WAAV' ! V plane
+ lnums(2) = 1 ! copy one
+ wirenum = (SDC_nrwire(SDC_PLANE_NUM(chamhit))) + 1
+ & - SDC_WIRE_NUM(chamhit)
+ if (SDC_WIRE_COUNTING(SDC_PLANE_NUM(chamhit)) .EQ. 1)
+ & wirenum = SDC_WIRE_NUM(chamhit)
+ if (wirenum .le. 24) write(wire,'(a,a,a,a)') 'AVA',char(64 +
+ $ wirenum)
+ if (wirenum .gt. 24) write(wire,'(a,a,a,a)') 'AVB',char(64 - 24
+ $ + wirenum)
+ lnames(3) = wire ! V wires
+ lnums(3) = wirenum ! wire number
+ call glvolu (4, lnames, lnums, error_code)
+ call gdtom (xd, xm, 1) ! transform from detector to MARS
+ call gsatt (wire,'SEEN',1)
+ call gsatt (wire,'COLO',13)
+* call gsahit (1, 5, 1, lnums(1), xm, ihit) ! store the hit
+* call gsahit (1, 90, 1, lnums(1), xm, ihit) ! store the hit
+**************************************************************************************
+*XXX
+****
+ elseif (SDC_PLANE_NUM(chamhit) .EQ. 6) then
+ nlevel = 0 ! initial value for # of levels
+ lnames(1) = 'WCHA' ! level one
+ lnums(1) = 1 ! copy one, higher chamber
+ lnames(2) = 'WABV' ! V plane
+ lnums(2) = 1 ! copy one
+ wirenum = (SDC_nrwire(SDC_PLANE_NUM(chamhit))) + 1
+ & - SDC_WIRE_NUM(chamhit)
+ if (SDC_WIRE_COUNTING(SDC_PLANE_NUM(chamhit)) .EQ. 1)
+ & wirenum = SDC_WIRE_NUM(chamhit)
+ if (wirenum .le. 24) write(wire,'(a,a,a,a)') 'AVC',char(64 +
+ $ wirenum)
+ if (wirenum .gt. 24) write(wire,'(a,a,a,a)') 'AVD',char(64 - 24
+ $ + wirenum)
+ lnames(3) = wire ! V wires
+ lnums(3) = wirenum ! wire number
+ call glvolu (4, lnames, lnums, error_code)
+ call gdtom (xd, xm, 1) ! transform from detector to MARS
+ call gsatt (wire,'SEEN',1)
+ call gsatt (wire,'COLO',13)
+* call gsahit (1, 5, 1, lnums(1), xm, ihit) ! store the hit
+* call gsahit (1, 90, 1, lnums(1), xm, ihit) ! store the hit
+**************************************************************************************
+**************************************************************************************
+*UUU
+****
+ elseif (SDC_PLANE_NUM(chamhit) .EQ. 7) then
+ nlevel = 0 ! initial value for # of levels
+ lnames(1) = 'WCHB' ! level one
+ lnums(1) = 1 ! copy one, higher chamber
+ lnames(2) = 'WBAU' ! U plane
+ lnums(2) = 1 ! copy one
+ wirenum = (sdc_nrwire(SDC_PLANE_NUM(chamhit))) + 1
+ & - SDC_WIRE_NUM(chamhit)
+ if (SDC_WIRE_COUNTING(SDC_PLANE_NUM(chamhit)) .EQ. 1)
+ & wirenum = SDC_WIRE_NUM(chamhit)
+ if (wirenum .le. 24) write(wire,'(a,a,a,a)') 'BUA',char(64 +
+ $ wirenum)
+ if (wirenum .gt. 24) write(wire,'(a,a,a,a)') 'BUB',char(64 - 24
+ $ + wirenum)
+ lnames(3) = wire ! U wires
+ lnums(3) = wirenum ! wire number
+ call glvolu (4, lnames, lnums, error_code)
+ call gdtom (xd, xm, 1) ! transform from detector to MARS
+ call gsatt (wire,'SEEN',1)
+ call gsatt (wire,'COLO',15)
+* call gsahit (1, 4, 1, lnums(1), xm, ihit) ! store the hit
+**************************************************************************************
+*UUU
+****
+ elseif (SDC_PLANE_NUM(chamhit) .EQ. 8) then
+ nlevel = 0 ! initial value for # of levels
+ lnames(1) = 'WCHB' ! level one
+ lnums(1) = 1 ! copy one, higher chamber
+ lnames(2) = 'WBBU' ! U plane
+ lnums(2) = 1 ! copy one
+ wirenum = (sdc_nrwire(SDC_PLANE_NUM(chamhit))) + 1
+ & - SDC_WIRE_NUM(chamhit)
+ if (SDC_WIRE_COUNTING(SDC_PLANE_NUM(chamhit)) .EQ. 1)
+ & wirenum = SDC_WIRE_NUM(chamhit)
+ if (wirenum .le. 24) write(wire,'(a,a,a,a)') 'BUC',char(64 +
+ $ wirenum)
+ if (wirenum .gt. 24) write(wire,'(a,a,a,a)') 'BUD',char(64 - 24
+ $ + wirenum)
+ lnames(3) = wire ! U wires
+ lnums(3) = wirenum ! wire number
+ call glvolu (4, lnames, lnums, error_code)
+ call gdtom (xd, xm, 1) ! transform from detector to MARS
+ call gsatt (wire,'SEEN',1)
+ call gsatt (wire,'COLO',15)
+* call gsahit (1, 4, 1, lnums(1), xm, ihit) ! store the hit
+**************************************************************************************
+*VVV
+****
+ elseif (SDC_PLANE_NUM(chamhit) .EQ. 9) then
+ nlevel = 0 ! initial value for # of levels
+ lnames(1) = 'WCHB' ! level one
+ lnums(1) = 1 ! copy one, higher chamber
+ lnames(2) = 'WBAX' ! X plane
+ lnums(2) = 1 ! copy one
+ wirenum = (SDC_nrwire(SDC_PLANE_NUM(chamhit))) + 1
+ & - SDC_WIRE_NUM(chamhit)
+ if (SDC_WIRE_COUNTING(SDC_PLANE_NUM(chamhit)) .EQ. 1)
+ & wirenum = SDC_WIRE_NUM(chamhit)
+ if (wirenum .le. 16) write(wire,'(a,a,a,a)') 'BXA',char(64 +
+ $ wirenum)
+ if ((wirenum .gt. 16) .and. (wirenum .le. 32)) write(wire
+ $ ,'(a,a,a,a)')'BXB',char(64 - 16 + wirenum)
+ if ((wirenum .gt. 32) .and. (wirenum .le. 48)) write(wire
+ $ ,'(a,a,a,a)')'BXC',char(64 - 32 + wirenum)
+ if ((wirenum .gt. 48) .and. (wirenum .le. 64)) write(wire
+ $ ,'(a,a,a,a)')'BXD',char(64 - 48 + wirenum)
+ lnames(3) = wire
+ lnums(3) = wirenum ! wire number
+ call glvolu (4, lnames, lnums, error_code)
+ call gdtom (xd, xm, 1) ! transform from detector to MARS
+ call gsatt (wire,'SEEN',1)
+ call gsatt (wire,'COLO',15)
+* call gsahit (1, 6, 1, lnums(1), xm, ihit) ! store the hit
+**************************************************************************************
+*VVV
+****
+ elseif (SDC_PLANE_NUM(chamhit) .EQ. 10) then
+ nlevel = 0 ! initial value for # of levels
+ lnames(1) = 'WCHB' ! level one
+ lnums(1) = 1 ! copy one, higher chamber
+ lnames(2) = 'WBBX' ! X plane
+ lnums(2) = 1 ! copy one
+ wirenum = (SDC_nrwire(SDC_PLANE_NUM(chamhit))) + 1
+ & - SDC_WIRE_NUM(chamhit)
+ if (SDC_WIRE_COUNTING(SDC_PLANE_NUM(chamhit)) .EQ. 1)
+ & wirenum = SDC_WIRE_NUM(chamhit)
+ if (wirenum .le. 16) write(wire,'(a,a,a,a)') 'BXE',char(64 +
+ $ wirenum)
+ if ((wirenum .gt. 16) .and. (wirenum .le. 32)) write(wire
+ $ ,'(a,a,a,a)')'BXF',char(64 - 16 + wirenum)
+ if ((wirenum .gt. 32) .and. (wirenum .le. 48)) write(wire
+ $ ,'(a,a,a,a)')'BXG',char(64 - 32 + wirenum)
+ if ((wirenum .gt. 48) .and. (wirenum .le. 64)) write(wire
+ $ ,'(a,a,a,a)')'BXH',char(64 - 48 + wirenum)
+ lnames(3) = wire
+ lnums(3) = wirenum ! wire number
+ call glvolu (4, lnames, lnums, error_code)
+ call gdtom (xd, xm, 1) ! transform from detector to MARS
+ call gsatt (wire,'SEEN',1)
+ call gsatt (wire,'COLO',15)
+* call gsahit (1, 6, 1, lnums(1), xm, ihit) ! store the hit
+**************************************************************************************
+*XXX
+****
+ elseif (SDC_PLANE_NUM(chamhit) .EQ. 11) then
+ nlevel = 0 ! initial value for # of levels
+ lnames(1) = 'WCHB' ! level one
+ lnums(1) = 1 ! copy one, higher chamber
+ lnames(2) = 'WBAV' ! V plane
+ lnums(2) = 1 ! copy one
+ wirenum = (SDC_nrwire(SDC_PLANE_NUM(chamhit))) + 1
+ & - SDC_WIRE_NUM(chamhit)
+ if (SDC_WIRE_COUNTING(SDC_PLANE_NUM(chamhit)) .EQ. 1)
+ & wirenum = SDC_WIRE_NUM(chamhit)
+ if (wirenum .le. 24) write(wire,'(a,a,a,a)') 'BVA',char(64 +
+ $ wirenum)
+ if (wirenum .gt. 24) write(wire,'(a,a,a,a)') 'BVB',char(64 - 24
+ $ + wirenum)
+ lnames(3) = wire ! V wires
+ lnums(3) = wirenum ! wire number
+ call glvolu (4, lnames, lnums, error_code)
+ call gdtom (xd, xm, 1) ! transform from detector to MARS
+ call gsatt (wire,'SEEN',1)
+ call gsatt (wire,'COLO',15)
+* call gsahit (1, 5, 1, lnums(1), xm, ihit) ! store the hit
+* call gsahit (1, 90, 1, lnums(1), xm, ihit) ! store the hit
+**************************************************************************************
+*XXX
+****
+ elseif (SDC_PLANE_NUM(chamhit) .EQ. 12) then
+ nlevel = 0 ! initial value for # of levels
+ lnames(1) = 'WCHB' ! level one
+ lnums(1) = 1 ! copy one, higher chamber
+ lnames(2) = 'WBBV' ! V plane
+ lnums(2) = 1 ! copy one
+ wirenum = (SDC_nrwire(SDC_PLANE_NUM(chamhit))) + 1
+ & - SDC_WIRE_NUM(chamhit)
+ if (SDC_WIRE_COUNTING(SDC_PLANE_NUM(chamhit)) .EQ. 1)
+ & wirenum = SDC_WIRE_NUM(chamhit)
+ if (wirenum .le. 24) write(wire,'(a,a,a,a)') 'BVC',char(64 +
+ $ wirenum)
+ if (wirenum .gt. 24) write(wire,'(a,a,a,a)') 'BVD',char(64 - 24
+ $ + wirenum)
+ lnames(3) = wire ! V wires
+ lnums(3) = wirenum ! wire number
+ call glvolu (4, lnames, lnums, error_code)
+ call gdtom (xd, xm, 1) ! transform from detector to MARS
+ call gsatt (wire,'SEEN',1)
+ call gsatt (wire,'COLO',15)
+* call gsahit (1, 5, 1, lnums(1), xm, ihit) ! store the hit
+* call gsahit (1, 90, 1, lnums(1), xm, ihit) ! store the hit
+**************************************************************************************
+ endif
+ enddo
+ endif
+
+* Take a look at the hodoscopes
+* See the file "displaynumbering.help" for a description of the numbering of the
+* various detector elements
+*
+ if (SSCIN_TOT_HITS .GT. 0) then
+ lnames(0) = 'SHUT' ! relative to the hut
+ lnums(0) = 1 ! copy 1
+ do scinhit = 1, SSCIN_TOT_HITS
+*
+* First the lower X
+*
+ if (SSCIN_PLANE_NUM(scinhit) .EQ. 1) then
+ nlevel = 0 ! initial value for # of levels
+ lnames(1) = 'HOD1' ! level one
+ lnums(1) = 1 ! copy one, lower hodo
+ lnames(2) = 'HDX1' ! X strips
+ lnums(2) = 1 ! copy one
+ write (scinname,'(a,a)') 'H1X',char(64 + SSCIN_COUNTER_NUM(scinhit))
+ lnames(3) = scinname ! X strips
+ lnums(3) = SSCIN_COUNTER_NUM(scinhit) ! X strip number
+ call glvolu (4, lnames, lnums, error_code)
+ call gdtom (xd, xm, 1) ! transform from detector to MARS
+* call gsahit (1, 2, 1, lnums(1), xm, ihit) ! store the hit
+ call gsatt (scinname,'COLO',14) !change the color of the it element
+ call gsatt (scinname,'FILL',5)
+ call gsatt (scinname,'LWID',1)
+*
+* now the upper X
+*
+ elseif (SSCIN_PLANE_NUM(scinhit) .EQ. 3) then
+ nlevel = 0 ! initial value for # of levels
+ lnames(1) = 'HOD2' ! level one
+ lnums(1) = 1 ! copy two, upper hodo
+ lnames(2) = 'HDX2' ! X strips
+ lnums(2) = 1 ! copy one
+ write (scinname,'(a,a)') 'H2X',char(64 + SSCIN_COUNTER_NUM(scinhit))
+ lnames(3) = scinname ! X strips
+ lnums(3) = SSCIN_COUNTER_NUM(scinhit) ! X strip number
+ call glvolu (4, lnames, lnums, error_code)
+ call gdtom (xd, xm, 1) ! transform from detector to MARS
+* call gsahit (1, 2, 1, lnums(1), xm, ihit) ! store the hit
+ call gsatt (scinname,'COLO',14) !change the color of the it element
+ call gsatt (scinname,'FILL',5)
+ call gsatt (scinname,'LWID',1)
+*
+* now the lower Y
+*
+ elseif (SSCIN_PLANE_NUM(scinhit) .EQ. 2) then
+ nlevel = 0 ! initial value for # of levels
+ lnames(1) = 'HOD1'
+ lnums(1) = 1 ! copy one, lower hodo
+ lnames(2) = 'HDY1' ! Y strips
+ lnums(2) = 1 ! copy one
+ write (scinname,'(a,a)') 'H1Y',char(64 + SSCIN_COUNTER_NUM(scinhit))
+ lnames(3) = scinname ! Y strips
+ lnums(3) = SSCIN_COUNTER_NUM(scinhit) ! Y strip number
+ call glvolu (4, lnames, lnums, error_code)
+ call gdtom (xd, xm, 1) ! transform from detector to MARS
+* call gsahit (1, 3, 1, lnums(1), xm, ihit) ! store the hit
+ call gsatt (scinname,'COLO',14) !change the color of the it element
+ call gsatt (scinname,'FILL',5)
+ call gsatt (scinname,'LWID',1)
+*
+* now the upper Y
+*
+ elseif (SSCIN_PLANE_NUM(scinhit) .EQ. 4) then
+ nlevel = 0 ! initial value for # of levels
+ lnames(1) = 'HOD2'
+ lnums(1) = 1 ! copy two, upper hodo
+ lnames(2) = 'HDY2' ! Y strips
+ lnums(2) = 1 ! copy one
+ write (scinname,'(a,a)') 'H2Y',char(64 + SSCIN_COUNTER_NUM(scinhit))
+ lnames(3) = scinname ! Y strips
+ lnums(3) = SSCIN_COUNTER_NUM(scinhit) ! Y strip number
+ call glvolu (4, lnames, lnums, error_code)
+ call gdtom (xd, xm, 1) ! transform from detector to MARS
+* call gsahit (1, 3, 1, lnums(1), xm, ihit) ! store the hit
+ call gsatt (scinname,'COLO',14) !change the color of the it element
+ call gsatt (scinname,'FILL',5)
+ call gsatt (scinname,'LWID',1)
+ endif
+ enddo
+ endif
+*
+* Now take care of the shower detector
+* See the file "displaynumbering.help" for a description of the numbering of the
+* various detector elements
+*
+ lnames(0) = 'SHUT'
+ lnums(0) = 1
+ if (SCAL_NUM_HITS .GE. 0) then
+ do showhit = 1, SCAL_NUM_HITS
+ nlevel = 0
+ lnames(1) = 'SHOW' ! shower detector
+ lnums(1) = 4 ! copy 1
+ write(layername,'(a,i1)') 'LAY',SCAL_COLS(showhit)
+ lnames(2) = layername ! x subdivisions
+ lnums(2) = 11
+ lnums(3) = 1
+ write (blockname,'(a,i1,a)') 'BL',SCAL_COLS(showhit),
+ $ char(64 + scal_rows(showhit))
+ lnames(3) = blockname ! z subdivisions
+ call glvolu(4, lnames, lnums, error_code)
+ call gdtom (xd, xm, 1) ! transform from det to MARS
+ call gsatt (blockname,'COLO',14) !change the color of the it element
+ call gsatt (blockname,'FILL',5)
+ call gsatt (blockname,'LWID',2)
+ enddo
+ endif
+ end
diff --git a/ONEEV/s_one_ev_geometry.f b/ONEEV/s_one_ev_geometry.f
new file mode 100644
index 0000000..e7df7f1
--- /dev/null
+++ b/ONEEV/s_one_ev_geometry.f
@@ -0,0 +1,455 @@
+ subroutine s_one_ev_geometry
+*
+* This routine will get the detector position and size information from CTP,
+* then use this information for defining the different GEANT geometry structures
+*
+* August, 1994, Pat Welch, Oregon State University, tpw@physics.orst.edu
+*
+* Note: Subdivided volumes won't work for doing coordinate transforms. Or
+* at least I didn't see a method around them. So I have defined all
+* the subvolumes explicitly. (TPW)
+*
+* Modified from HMS version, h_one_ev_geometry, March 1995 by
+* Derek van Westrum (vanwestr@cebaf.gov)
+*
+* $Log: s_one_ev_geometry.f,v $
+* Revision 1.5 1996/11/22 15:37:10 saw
+* (SAW) Don't let U&V wires extend beyond chamber. Some code cleanup.
+*
+* Revision 1.4 1996/04/30 14:10:39 saw
+* (DVW) Code update
+*
+* Revision 1.3 1996/01/17 16:37:48 cdaq
+* (DVW) Tweak hodoscale
+*
+* Revision 1.2 1995/10/06 18:24:18 cdaq
+* (DVW) Changed to ctp geometry variables and eliminated call to s_one_ev.par.
+*
+* Revision 1.1 1995/07/31 15:23:38 cdaq
+* Initial revision
+* h_one_ev_geometry.f,v $
+
+ implicit none
+
+ include 'sos_data_structures.cmn'
+ include 'sos_geometry.cmn'
+ include 'sos_calorimeter.cmn'
+ include 'sos_scin_parms.cmn'
+
+ real*4 SHUT_WIDTH,SHUT_HEIGHT
+ parameter (SHUT_WIDTH = 100.) ! full width of the det. hut
+ parameter (SHUT_HEIGHT = 800.) ! full height of the det. hut
+ integer SHUTMEDIA ! non-sensitive tracking media
+ integer DETMEDIA ! sensitive tracking media
+ parameter (SHUTMEDIA = 1, DETMEDIA = 2)
+ real*4 hodoscale
+ parameter (hodoscale = 2.)
+ real*4 wcscale
+* parameter (wcscale = 5.)
+ parameter (wcscale = 1.)
+ real*4 xwirelength
+ real*4 ywirelength
+ real*4 uwirelength
+ real*4 vwirelength
+ parameter(xwirelength = 40.0)
+ parameter(ywirelength = 66.0)
+ parameter(uwirelength = 80) != xwirelength/sin(60 degrees)
+ parameter(vwirelength = 80) != xwirelength/sin(60 degrees)
+
+
+ character*5 scinname
+ character*5 layername
+ character*5 planename
+ character*5 plane
+ character*5 wire
+ character*5 blockname
+ integer isector
+ integer iplane
+ integer iwire
+ integer ichamber
+ integer ilayer
+ integer irow
+
+ integer ivolu ! internal volume number
+ real par(10) ! geometry parameters
+ real x, y, z ! offset position for placement of dets
+ integer i ! index variable
+
+ real wspace ! Wire spacing temp variable
+ real xtemp,ytemp ! Temporary variables for
+ real xplus,yplus ! display correct wire lengths.
+ real xminus,yminus
+
+ real*4 raddeg
+ parameter (raddeg = 3.14159265/180.)
+
+* First define two general media that everything is made of
+* one is insensitive, and the other is sensitive
+
+ call gstmed (SHUTMEDIA, 'air', 15, 0, 0,0.,20.,1.,0.5,1.,1.,0,0)
+ call gstmed (DETMEDIA, 'det', 15, 1, 0,0.,20.,1.,0.5,1.,1.,0,0)
+
+* Now define the mother volume that the detectors sit in
+ par(1) = SHUT_WIDTH / 2. ! half width in x of mother volume
+ par(2) = SHUT_WIDTH / 2. ! half width in y of mother volume
+ par(3) = SHUT_HEIGHT / 2. ! half height in z of mother volume
+ call g_ugsvolu ('SHUT', 'BOX ', SHUTMEDIA, par, 3, ivolu)
+ call gsatt ('SHUT', 'SEEN', 0) ! can't see the hut
+
+
+* Now define the wire chambers as a collection of planes
+* First the U and V planes.
+*
+ par(1) = ywirelength/2.
+ par(2) = xwirelength/2.
+ par(3) = wcscale * (sdc_zpos(2) - sdc_zpos(1))/ 2. ! half width of chamber planes
+ do ichamber = 1,2
+ do iplane = 1,2
+ write(planename,'(a,a,a,a)') "W",char(64+ichamber),char(64+iplane),"U"
+ call g_ugsvolu (planename, 'BOX ', DETMEDIA, par, 3, ivolu)
+ write(planename,'(a,a,a,a)') "W",char(64+ichamber),char(64+iplane),"V"
+ call g_ugsvolu (planename, 'BOX ', DETMEDIA, par, 3, ivolu)
+ enddo
+ enddo
+*
+* Now do the X planes.
+*
+ par(1) = ywirelength/2.
+ par(2) = xwirelength/2.
+ par(3) = wcscale * (sdc_zpos(2) - sdc_zpos(1))/ 2. ! half width of chamber planes
+ do ichamber = 1,2
+ do iplane = 1,2
+ write(planename,'(a,a,a,a)') "W",char(64+ichamber),char(64+iplane),"X"
+ call g_ugsvolu (planename, 'BOX ', DETMEDIA, par, 3, ivolu)
+ enddo
+ enddo
+
+! make a volume for 6 planes. The size here should be cool. DVW 18 jul 95
+ par(1) = ywirelength/2.
+ par(2) = xwirelength/2.
+ par(3) = wcscale * (6./5. * (sdc_zpos(6) - sdc_zpos(1))) / 2.
+ call g_ugsvolu ('WCHA', 'BOX ', DETMEDIA, par, 3, ivolu) ! Wire chamber
+ call g_ugsvolu ('WCHB', 'BOX ', DETMEDIA, par, 3, ivolu) ! Wire chamber
+
+* Now place the planes within the wire chamber. Start with U
+ z = - wcscale * (5. / 2.) * (sdc_zpos(2) -sdc_zpos(1))
+ call gspos ('WAAU', 1, 'WCHA', 0., 0., z, 0, 'ONLY') ! U plane
+ z = - wcscale * (3. / 2.) * (sdc_zpos(2) -sdc_zpos(1))
+ call gspos ('WABU', 1, 'WCHA', 0., 0., z, 0, 'ONLY') ! U plane
+ z = - wcscale * (5. / 2.) * (sdc_zpos(2) -sdc_zpos(1))
+ call gspos ('WBAU', 1, 'WCHB', 0., 0., z, 0, 'ONLY') ! U plane
+ z = - wcscale * (3. / 2.) * (sdc_zpos(2) -sdc_zpos(1))
+ call gspos ('WBBU', 1, 'WCHB', 0., 0., z, 0, 'ONLY') ! U plane
+*
+ z = - wcscale * (1. / 2.) * (sdc_zpos(2) -sdc_zpos(1))
+ call gspos ('WAAX', 1, 'WCHA', 0., 0., z, 0, 'ONLY') ! X plane
+ z = wcscale * (1. / 2.) * (sdc_zpos(2) -sdc_zpos(1))
+ call gspos ('WABX', 1, 'WCHA', 0., 0., z, 0, 'ONLY') ! X plane
+ z = - wcscale * (1. / 2.) * (sdc_zpos(2) -sdc_zpos(1))
+ call gspos ('WBAX', 1, 'WCHB', 0., 0., z, 0, 'ONLY') ! X plane
+ z = wcscale * (1. / 2.) * (sdc_zpos(2) -sdc_zpos(1))
+ call gspos ('WBBX', 1, 'WCHB', 0., 0., z, 0, 'ONLY') ! X plane
+*
+ z = wcscale * (3. / 2.) * (sdc_zpos(2) -sdc_zpos(1))
+ call gspos ('WAAV', 1, 'WCHA', 0., 0., z, 0, 'ONLY') ! V plane
+ z = wcscale * (5. / 2.) * (sdc_zpos(2) -sdc_zpos(1))
+ call gspos ('WABV', 1, 'WCHA', 0., 0., z, 0, 'ONLY') ! V plane
+ z = wcscale * (3. / 2.) * (sdc_zpos(2) -sdc_zpos(1))
+ call gspos ('WBAV', 1, 'WCHB', 0., 0., z, 0, 'ONLY') ! V plane
+ z = wcscale * (5. / 2.) * (sdc_zpos(2) -sdc_zpos(1))
+ call gspos ('WBBV', 1, 'WCHB', 0., 0., z, 0, 'ONLY') ! V plane
+
+* Now place the wire chambers in the mother volume
+*
+ x = sdc_xcenter(1)
+ y = - sdc_ycenter(1)
+ z = sdc_1_zpos
+ call gspos ('WCHA', 1, 'SHUT', x, y, z, 0, 'ONLY') ! upper chamber
+ x = sdc_xcenter(2)
+ y = - sdc_ycenter(2)
+ z = sdc_2_zpos
+ call gspos ('WCHB', 1, 'SHUT', x, y, z, 0, 'ONLY') ! bottom chamber
+*
+* Define the individual wire cells
+* See the file "displaynumbering.help" for a description of the numbering of the
+* various detector elements
+*
+*****
+*UUUU
+*****
+ par(1) = sdc_pitch(1) / 2./1000. ! make the cells "wire" thin
+ par(2) = uwirelength/2.
+ par(3) = (sdc_zpos(2) - sdc_zpos(1))/ 2./1000. ! half width of chamber planes
+ wspace = sdc_pitch(1) / SIN(sdc_alpha_angle(1))
+*
+* First define all the "boxes" for all the U wires in both chambers...
+* Then position the U wires plane by plane
+ do ichamber=1,2
+ iplane = 1
+ x = -(sdc_nrwire(1) + 1.) / 2. * wspace
+ do isector=1,4
+ if(isector.eq.3) then
+ iplane = 2
+ x = -(sdc_nrwire(1) + 1.) / 2. * wspace
+ endif
+ write(plane,'(a,a,a,a)') 'W',char(64 + ichamber),char(64+iplane),'U'
+ do iwire = 1,24
+ x = x + wspace
+ ytemp = xwirelength/2.0
+ xtemp = ytemp/tan(sdc_alpha_angle(1)) + x
+ if(xtemp.gt.ywirelength/2.0) then
+ xplus = ywirelength/2.0
+ yplus = (xplus-x)*tan(sdc_alpha_angle(1))
+ else
+ xplus = xtemp
+ yplus = ytemp
+ endif
+ ytemp = -xwirelength/2.0
+ xtemp = ytemp/tan(sdc_alpha_angle(1)) + x
+ if(xtemp.lt.-ywirelength/2.0) then
+ xminus = -ywirelength/2.0
+ yminus = (xminus-x)*tan(sdc_alpha_angle(1))
+ else
+ xminus = xtemp
+ yminus = ytemp
+ endif
+ par(2) = sqrt((xplus-xminus)**2+(yplus-yminus)**2)/2.0
+ write (wire,'(a,a,a,a)') char(64 + ichamber),'U',
+ $ char(64 + isector),char(64 + iwire)
+ call g_ugsvolu (wire, 'BOX ', DETMEDIA, par, 3, ivolu) ! U cell
+ call gsatt (wire, 'SEEN', 0) ! can't see the wire cells
+ call gspos (wire, 1, plane, (xminus+xplus)/2
+ $ , (yminus+yplus)/2, 0., 3, 'ONLY')
+ enddo
+ enddo
+ enddo
+*
+
+*****
+*XXX
+*****
+ par(1) = sdc_pitch(3) / 2. /1000. ! half width of cell
+ par(2) = xwirelength/2. ! the length of the xwirelengths
+ par(3) = (sdc_zpos(4) - sdc_zpos(3))/ 2./1000. ! half width of chamber planes
+ wspace = sdc_pitch(3)
+*
+* First define all the "boxes" for all the X wires in both chambers...
+* Then position the X wires plane by plane...
+*
+ do ichamber=1,2
+ iplane = 1
+ x = -(sdc_nrwire(3) + 1.) / 2. * wspace
+ do isector=1,8
+ if(isector.eq.5) then
+ iplane = 2
+ x = -(sdc_nrwire(3) + 1.) / 2. * wspace
+ endif
+ write (plane,'(a,a,a,a)') 'W',char(64 + ichamber),char(64+iplane),'X'
+ do iwire = 1,16
+ x = x + wspace
+ write (wire,'(a,a,a,a)') char(64 + ichamber),'X',
+ $ char(64 + isector),char(64 + iwire)
+ call g_ugsvolu (wire, 'BOX ', DETMEDIA, par, 3, ivolu) ! X cell
+ call gsatt (wire, 'SEEN', 0) ! can't see the wire cells
+ call gspos (wire, 1, plane, x, 0., 0., 0, 'ONLY')
+ enddo
+ enddo
+ enddo
+*
+*
+*****
+*VVVV
+*****
+ par(1) = sdc_pitch(5) / 2./1000. ! half width of cell
+ par(2) = vwirelength/2.
+ par(3) = (sdc_zpos(6) - sdc_zpos(5))/ 2./1000. ! half width of chamber planes
+*
+ wspace = sdc_pitch(5) / SIN(sdc_alpha_angle(5))
+
+* First define all the "boxes" for all the V wires in both chambers...
+* Then position the V wires plane by plane...
+ do ichamber=1,2
+ iplane =1
+ x = -(sdc_nrwire(5) + 1.) / 2. * wspace
+ do isector=1,4
+ if(isector.eq.3) then
+ iplane = 2
+ x = -(sdc_nrwire(5) + 1.) / 2. * wspace
+ endif
+ write (plane,'(a,a,a,a)') 'W',char(64 + ichamber),char(64+iplane),'V'
+ do iwire = 1,24
+ x = x + wspace
+ ytemp = -xwirelength/2.0
+ xtemp = ytemp/tan(sdc_alpha_angle(5)) + x
+ if(xtemp.gt.ywirelength/2.0) then
+ xplus = ywirelength/2.0
+ yplus = (xplus-x)*tan(sdc_alpha_angle(5))
+ else
+ xplus = xtemp
+ yplus = ytemp
+ endif
+ ytemp = xwirelength/2.0
+ xtemp = ytemp/tan(sdc_alpha_angle(5)) + x
+ if(xtemp.lt.-ywirelength/2.0) then
+ xminus = -ywirelength/2.0
+ yminus = (xminus-x)*tan(sdc_alpha_angle(5))
+ else
+ xminus = xtemp
+ yminus = ytemp
+ endif
+ par(2) = sqrt((xplus-xminus)**2+(yplus-yminus)**2)/2.0
+ write (wire,'(a,a,a,a)') char(64 + ichamber),'V',
+ $ char(64 + isector),char(64 + iwire)
+ call g_ugsvolu (wire, 'BOX ', DETMEDIA, par, 3, ivolu) ! U cell
+ call gsatt (wire, 'SEEN', 0) ! can't see the wire cells
+
+c write (wire,'(a,a,a,a)') char(64 + ichamber),'V',
+c $ char(64 + isector),char(64 + iwire)
+ call gspos (wire, 1, plane, (xminus+xplus)/2
+ $ , (yminus+yplus)/2, 0., 4, 'ONLY')
+ enddo
+ enddo
+ enddo
+*
+*
+* Now define the hodoscope layers
+* See the file "displaynumbering.help" for a description of the numbering of the
+* various detector elements
+
+ par(1) = sscin_1x_size * sscin_1x_nr / 2.
+ par(2) = sscin_1y_size * sscin_1y_nr / 2.
+ par(3) = sscin_1x_dzpos * hodoscale / 2.
+ call g_ugsvolu ('HDX1', 'BOX ', DETMEDIA, par, 3, ivolu) ! X plane hodo
+ call g_ugsvolu ('HDY1', 'BOX ', DETMEDIA, par, 3, ivolu) ! Y plane hodo
+ call gsatt ('HDX1', 'SEEN', 0) ! can't see the hodo box
+ call gsatt ('HDY1', 'SEEN', 0) ! can't see the hodo box
+ par(1) = sscin_2x_size * sscin_2x_nr / 2.
+ par(2) = sscin_2y_size * sscin_2y_nr / 2.
+ par(3) = sscin_2x_dzpos * hodoscale /2.
+ call g_ugsvolu ('HDX2', 'BOX ', DETMEDIA, par, 3, ivolu) ! X plane hodo
+ call g_ugsvolu ('HDY2', 'BOX ', DETMEDIA, par, 3, ivolu) ! Y plane hodo
+ call gsatt ('HDX2', 'SEEN', 0) ! can't see the hodo box
+ call gsatt ('HDY2', 'SEEN', 0) ! can't see the hodo box
+
+! box for front hodos
+ par(1) = sscin_1x_size * sscin_1x_nr / 2.
+ par(2) = sscin_1y_size * sscin_1y_nr / 2.
+ par(3) = sscin_1x_dzpos*hodoscale + (sscin_1y_zpos-sscin_1x_zpos)/2.
+ call g_ugsvolu ('HOD1', 'BOX ', DETMEDIA, par, 3, ivolu) ! hodoscope box
+ call gsatt ('HOD1', 'SEEN', 0) ! can't see the hodo box
+
+! box for back hodos
+ par(1) = sscin_2x_size * sscin_2x_nr / 2.
+ par(2) = sscin_2y_size * sscin_2y_nr / 2.
+ par(3) = sscin_2x_dzpos*hodoscale + (sscin_2y_zpos-sscin_2x_zpos)/2.
+ call g_ugsvolu ('HOD2', 'BOX ', DETMEDIA, par, 3, ivolu) ! hodoscope box
+ call gsatt ('HOD2', 'SEEN', 0) ! can't see the hodo box
+* added by Derek
+*
+ x = -sscin_1x_offset
+ y = sscin_1y_offset
+ z = sscin_1x_zpos
+ call gspos ('HOD1', 1, 'SHUT', x, y, z, 0, 'ONLY') ! lower hodo
+ x = -sscin_2x_offset
+ y = sscin_2y_offset
+ z = sscin_2x_zpos
+ call gspos ('HOD2', 1, 'SHUT', x, y, z, 0, 'ONLY') ! upper hodo
+
+ z= -(sscin_1x_offset*hodoscale + (sscin_1y_zpos-sscin_1x_zpos))/2.
+ call gspos ('HDX1', 1, 'HOD1', 0., 0., z, 0, 'ONLY') ! X plane
+ call gspos ('HDY1', 1, 'HOD1', 0., 0., -z, 0, 'ONLY') ! Y plane
+ z= -(sscin_2x_offset*hodoscale + (sscin_2y_zpos-sscin_2x_zpos))/2.
+ call gspos ('HDX2', 1, 'HOD2', 0., 0., z, 0, 'ONLY') ! X plane
+ call gspos ('HDY2', 1, 'HOD2', 0., 0., -z, 0, 'ONLY') ! Y plane
+
+* Now define the strips for the hodoscopes
+
+ x = (sscin_1x_nr + 1.) * sscin_1x_size / 2. ! starting loci
+ do i = 1, sscin_1x_nr
+ x = x - sscin_1x_size
+ write (scinname,'(a,a)') 'H1X',char(64 + i)
+ par(1) = sscin_1x_size / 2. ! half width of X strips
+ par(2) = sscin_1y_size * sscin_1y_nr / 2.
+ par(3) = sscin_1x_dzpos * hodoscale / 2. !half thickness of hodoscope in z
+ call g_ugsvolu (scinname, 'BOX ', DETMEDIA, par, 3, ivolu) ! X plane hodo
+ call gspos (scinname, i, 'HDX1', x, 0., 0., 0, 'ONLY')
+ enddo
+ y = (sscin_1y_nr + 1.) * sscin_1y_size / 2. ! starting loci
+ do i = 1, sscin_1y_nr
+ y = y - sscin_1y_size
+ write (scinname,'(a,a)') 'H1Y',char(64 + i)
+ par(1) = sscin_1x_size * sscin_1x_nr / 2.
+ ! half width of hodoscope in x
+ par(2) = sscin_1y_size / 2. ! half width of X strips
+ par(3) = sscin_1y_dzpos * hodoscale / 2. !half thickness of hodoscope in z
+ call g_ugsvolu (scinname, 'BOX ', DETMEDIA, par, 3, ivolu) ! Y plane hodo
+ call gspos (scinname, i, 'HDY1', 0., y, 0., 0, 'ONLY')
+ enddo
+ x = (sscin_2x_nr + 1.) * sscin_2x_size / 2. ! starting loci
+ do i = 1,sscin_2x_nr
+ x = x - sscin_2x_size
+ write (scinname,'(a,a)') 'H2X',char(64 + i)
+ par(1) = sscin_2x_size / 2. ! half width of X strips
+ par(2) = sscin_2y_size * sscin_2y_nr / 2.
+ par(3) = sscin_2x_dzpos * hodoscale / 2. !half thickness of hodoscope in z
+ call g_ugsvolu (scinname, 'BOX ', DETMEDIA, par, 3, ivolu) ! X plane hodo
+ call gspos (scinname, i, 'HDX2', x, 0., 0., 0, 'ONLY')
+ enddo
+ y = (sscin_2y_nr + 1.) * sscin_2y_size / 2. ! starting loci
+ do i = 1, sscin_2y_nr
+ y = y - sscin_2y_size
+ write (scinname,'(a,a)') 'H2Y',char(64 + i)
+ par(1) = sscin_2x_size * sscin_2x_nr / 2.
+ par(2) = sscin_2y_size / 2. ! half width of X strips
+ par(3) = sscin_2y_dzpos * hodoscale / 2. !half thickness of hodoscope in z
+ call g_ugsvolu (scinname, 'BOX ', DETMEDIA, par, 3, ivolu) ! Y plane hodo
+ call gspos (scinname, i, 'HDY2', 0., y, 0., 0, 'ONLY')
+ enddo
+
+* Now define the shower detector
+* See the file "displaynumbering.help" for a description of the numbering of the
+* various detector elements
+
+! half width of the shower in x
+ par(1) = smax_cal_rows * scal_block_zsize / 2.
+! half width of the shower in y
+ par(2) = scal_block_ysize / 2.
+! half height of the shower detector
+ par(3) = smax_cal_columns * scal_block_xsize / 2.
+ call g_ugsvolu ('SHOW', 'BOX ', DETMEDIA, par, 3, ivolu)
+
+!for the x offset, we take the center of the top and bottom blocks
+!This assumes that all the blocks are
+!the same heighth and width as scal_1pr
+ x = -(scal_block_xc(1) + scal_block_xc(smax_cal_rows))/2
+ y = scal_block_yc(1)
+ z = scal_1pr_zpos + smax_cal_columns*scal_block_xsize/2.
+ call gspos ('SHOW', 1, 'SHUT', x, y, z, 0, 'ONLY')
+ call gsatt ('SHOW','SEEN',0)
+
+ par(1) = smax_cal_rows * scal_block_zsize / 2.! half width of shower in x
+ par(2) = scal_block_ysize / 2. ! half width of the shower in y
+ par(3) = scal_block_xsize / 2. ! half height of the shower detector
+
+ z = -(smax_cal_columns + 1.) / 2. * scal_block_xsize
+ do ilayer =1,smax_cal_columns
+ z = z + scal_block_xsize
+
+ write (layername,'(a,i1)') 'LAY',ilayer
+
+ par(1) = smax_cal_rows * scal_block_zsize / 2. ! half width of shower
+ call g_ugsvolu (layername, 'BOX ', DETMEDIA, par, 3, ivolu)
+ call gspos(layername, 1, 'SHOW', 0., 0., z, 0, 'ONLY')
+
+ par(1) = scal_block_zsize / 2. ! half width of a block
+ x = (smax_cal_rows - 1.) / 2. * scal_block_zsize
+ do irow = 1, smax_cal_rows
+ write (blockname,'(a,i1,a)') 'BL',ilayer,char(64 + irow)
+ call g_ugsvolu (blockname, 'BOX ', DETMEDIA, par, 3, ivolu)
+ call gspos(blockname, 1, layername, x, 0., 0., 0, 'ONLY')
+ x = x - scal_block_zsize
+ enddo
+ enddo
+*
+
+ end
diff --git a/ONEEV/s_one_ev_head_view.f b/ONEEV/s_one_ev_head_view.f
new file mode 100644
index 0000000..5bce0db
--- /dev/null
+++ b/ONEEV/s_one_ev_head_view.f
@@ -0,0 +1,97 @@
+ subroutine s_one_ev_head_view
+*
+* $Log:
+
+ implicit none
+
+ include 'sos_data_structures.cmn'
+ include 'sos_tracking.cmn'
+ include 'sos_geometry.cmn'
+ include 'sos_calorimeter.cmn'
+ include 'gen_event_info.cmn'
+ include 'sos_one_ev.par'
+ include 'gen_one_ev_gctrak.cmn'
+ include 'gen_one_ev_gckine.cmn'
+ include 'gen_one_ev_gcvolu.cmn'
+
+ character*5 scinname
+ integer iscin
+ character*4 blockname
+ character*5 layername
+ integer ilayer
+ integer irow
+
+
+ call gdopen (5)
+* first, get all the background junk out of the picture...
+ call gsatt ('HDX1','SEEN',0)
+ call gsatt ('HDX2','SEEN',0)
+ call gsatt ('HDY1','SEEN',0)
+ call gsatt ('HDY2','SEEN',0)
+ call gsatt ('SHOW','SEEN',0)
+ do iscin=1,LOWER_HODO_X_PADDLES
+ write(scinname,'(a,a)') 'H1X',char(64 + iscin)
+ call gsatt (scinname,'SEEN',0)
+ enddo
+ do iscin=1,LOWER_HODO_Y_PADDLES
+ write(scinname,'(a,a)') 'H1Y',char(64 + iscin)
+ call gsatt (scinname,'SEEN',0)
+ enddo
+ do iscin=1,UPPER_HODO_X_PADDLES
+ write(scinname,'(a,a)') 'H2X',char(64 + iscin)
+ call gsatt (scinname,'SEEN',0)
+ enddo
+ do iscin=1,UPPER_HODO_Y_PADDLES
+ write(scinname,'(a,a)') 'H2Y',char(64 + iscin)
+ call gsatt (scinname,'SEEN',0)
+ enddo
+ do ilayer =1,SMAX_CAL_COLUMNS
+ write(layername,'(a,i1)') 'LAY',ilayer
+ call gsatt (layername,'SEEN',0)
+ do irow = 1,SMAX_CAL_ROWS
+ write(blockname,'(a,i1,a)') 'BL',ilayer,char(64 + irow)
+ call gsatt (blockname,'SEEN',0)
+ enddo
+ enddo
+ call gdhits ('* ', '* ', 0, 850, 0.3)
+ call gdrawt (3.,2.,'HEAD ON VIEW',.5,0.,2,0)
+ call gdrawt (3.,1.,'SOS',.5,0.,2,0)
+ call gdraw ('SHUT', 0., 0., 90., 10.0, 8.5,0.25,0.25)
+ call s_one_ev_track
+ call gdclos (5)
+ call gdshow (5)
+ call gdshow (5)
+
+* It's already been stored, so now make everything visible again for
+* the next pass
+ call gsatt ('HDX1','SEEN',1)
+ call gsatt ('HDY1','SEEN',1)
+ call gsatt ('HDX2','SEEN',1)
+ call gsatt ('HDY2','SEEN',1)
+ do iscin=1,LOWER_HODO_X_PADDLES
+ write(scinname,'(a,a)') 'H1X',char(64 + iscin)
+ call gsatt (scinname,'SEEN',1)
+ enddo
+ do iscin=1,LOWER_HODO_Y_PADDLES
+ write(scinname,'(a,a)') 'H1Y',char(64 + iscin)
+ call gsatt (scinname,'SEEN',1)
+ enddo
+ do iscin=1,UPPER_HODO_X_PADDLES
+ write(scinname,'(a,a)') 'H2X',char(64 + iscin)
+ call gsatt (scinname,'SEEN',1)
+ enddo
+ do iscin=1,UPPER_HODO_Y_PADDLES
+ write(scinname,'(a,a)') 'H2Y',char(64 + iscin)
+ call gsatt (scinname,'SEEN',1)
+ enddo
+ do ilayer =1,SMAX_CAL_COLUMNS
+ write(layername,'(a,i1)') 'LAY',ilayer
+ call gsatt (layername,'SEEN',1)
+ do irow = 1,SMAX_CAL_ROWS
+ write(blockname,'(a,i1,a)') 'BL',ilayer,char(64 + irow)
+ call gsatt (blockname,'SEEN',1)
+ enddo
+ enddo
+ call gdelet (5)
+*
+ end
diff --git a/ONEEV/s_one_ev_hodo.f b/ONEEV/s_one_ev_hodo.f
new file mode 100644
index 0000000..d61c33a
--- /dev/null
+++ b/ONEEV/s_one_ev_hodo.f
@@ -0,0 +1,57 @@
+ Subroutine s_one_ev_hodo
+*
+* $Log: s_one_ev_hodo.f,v $
+* Revision 1.3 1996/11/22 15:38:35 saw
+* (SAW) Fix some startup errors
+*
+* Revision 1.2 1996/09/04 20:09:04 saw
+* (SAW) Replace huge list of gsdet/gsdeth calls with do loops over the
+* detector geometry.
+*
+* Revision 1.1 1995/09/18 14:38:47 cdaq
+* Initial revision
+*
+ implicit none
+
+ include 'sos_one_ev.par'
+
+ integer iset, idet
+ character*4 varinames(3)
+ integer varibits(3)
+ integer hodobits(3)
+ real origin(3), factor(3)
+
+ integer ihod,iplane,ipaddle
+
+ character*4 specname
+ character*4 hodoname(3)
+ character*1 planenames(2)
+ integer nhods,nplanes,npaddles(4)
+
+ data specname /'SOS'/
+ data planenames /'X','Y'/
+ data nhods,nplanes,npaddles /2,2,9,9,16,9/
+
+ data varinames /'x', 'y', 'z'/
+ data varibits /32, 32, 32/
+ data hodobits /2,2,5/
+ data origin /SHUT_HEIGHT, SHUT_HEIGHT, SHUT_HEIGHT/
+ data factor /1e3, 1e3, 1e3/
+
+ do ihod=1,nhods
+ write (hodoname(1),'("HOD",i1)') ihod
+ do iplane=1,nplanes
+ write (hodoname(2),'("HD",a1,i1)') planenames(iplane),ihod
+ do ipaddle=1,npaddles((ihod-1)*2+iplane)
+ write (hodoname(3),'("H",i1,a1,a1)') ihod,planenames(iplane)
+ $ ,char(ichar('A')+ipaddle-1)
+ call gsdet(specname,hodoname(3),3,hodoname,hodobits,
+ $ 2,100,100,iset,idet)
+ call gsdeth(specname,hodoname(3),3,varinames,varibits,
+ $ origin,factor)
+ enddo
+ enddo
+ enddo
+
+ return
+ end
diff --git a/ONEEV/s_one_ev_persp_view.f b/ONEEV/s_one_ev_persp_view.f
new file mode 100644
index 0000000..7abd95a
--- /dev/null
+++ b/ONEEV/s_one_ev_persp_view.f
@@ -0,0 +1,70 @@
+ subroutine s_one_ev_persp_view
+*
+* $Log: s_one_ev_persp_view.f,v $
+* Revision 1.2 1996/01/17 16:38:44 cdaq
+* (DVW) Tweak args in gdraw calls
+*
+* Revision 1.1 1995/09/18 14:44:08 cdaq
+* Initial revision
+*
+
+ implicit none
+
+ include 'sos_data_structures.cmn'
+ include 'sos_tracking.cmn'
+ include 'sos_geometry.cmn'
+ include 'sos_calorimeter.cmn'
+ include 'gen_event_info.cmn'
+ include 'sos_one_ev.par'
+ include 'gen_one_ev_gctrak.cmn'
+ include 'gen_one_ev_gckine.cmn'
+ include 'gen_one_ev_gcvolu.cmn'
+
+ character*5 scinname
+ integer iscin
+
+
+ call gdopen (8)
+ call gdrawt (5.,2.,'PERSPECTIVE VIEW',.5,0.,2,0)
+ call gdrawt (5.,1.,'SOS',.5,0.,2,0)
+ call gdraw ('SHUT', 45., 115., 90., 1.8, 8.0, 0.06, 0.06)
+ call s_one_ev_track
+ call gdhits ('* ', '* ', 0, 850, 0.1)
+ call gdclos (8)
+*
+* blow up the wire chambers, and make the hodoscopes invisible
+*
+ call gdopen (9)
+ call gsatt ('HDX1','SEEN',0)
+ call gsatt ('HDY1','SEEN',0)
+ do iscin=1,LOWER_HODO_X_PADDLES
+ write(scinname,'(a,a)') 'H1X',char(64 + iscin)
+ call gsatt (scinname,'SEEN',0)
+ enddo
+ do iscin=1,LOWER_HODO_Y_PADDLES
+ write(scinname,'(a,a)') 'H1Y',char(64 + iscin)
+ call gsatt (scinname,'SEEN',0)
+ enddo
+ call gdraw ('SHUT', 45., 115., 90., 12.8, 5.1, 0.15, 0.15)
+ call s_one_ev_track
+ call gdhits ('* ', '* ', 0, 850, 0.3)
+ call gdclos (9)
+ call gsatt ('HDX1','SEEN',1)
+ call gsatt ('HDY1','SEEN',1)
+ call gdclos (9)
+* Now make them visible again for the next pass...
+ do iscin=1,LOWER_HODO_X_PADDLES
+ write(scinname,'(a,a)') 'H1X',char(64 + iscin)
+ call gsatt (scinname,'SEEN',1)
+ enddo
+ do iscin=1,LOWER_HODO_Y_PADDLES
+ write(scinname,'(a,a)') 'H1Y',char(64 + iscin)
+ call gsatt (scinname,'SEEN',1)
+ enddo
+ call gdshow (9)
+ call gdshow (8)
+ call gdshow (9)
+ call gdelet (8)
+ call gdelet (9)
+
+ end
diff --git a/ONEEV/s_one_ev_topside_view.f b/ONEEV/s_one_ev_topside_view.f
new file mode 100644
index 0000000..94bb15c
--- /dev/null
+++ b/ONEEV/s_one_ev_topside_view.f
@@ -0,0 +1,49 @@
+ subroutine s_one_ev_topside_view
+*
+* $Log: s_one_ev_topside_view.f,v $
+* Revision 1.1 1996/01/17 16:37:05 cdaq
+* Initial revision
+*
+
+ implicit none
+
+ include 'sos_data_structures.cmn'
+ include 'sos_tracking.cmn'
+ include 'sos_geometry.cmn'
+ include 'sos_calorimeter.cmn'
+ include 'gen_event_info.cmn'
+ include 'sos_one_ev.par'
+ include 'gen_one_ev_gctrak.cmn'
+ include 'gen_one_ev_gckine.cmn'
+ include 'gen_one_ev_gcvolu.cmn'
+
+ call gdopen (7)
+ call gsatt ('HDX1','SEEN',0)
+ call gsatt ('HDX2','SEEN',0)
+ call gdrawt (4.4,2.,'TOP VIEW',.5,0.,2,0)
+ call gdrawt (4.4,1.,'SOS',.5,0.,2,0)
+ call gdraw ('SHUT', 270., 0., 90., 4.4,4.0, 0.045, 0.080)
+ call s_one_ev_track
+ call gdhits ('* ', '* ', 0, 850, 0.1)
+ call gdhits ('HOD1', 'HDY1', 0, 850, 0.1)
+ call gdhits ('HOD2', 'HDY2', 0, 850, 0.1)
+ call gdclos (7)
+*
+*
+* Other side view
+*
+ call gdopen (6)
+ call gsatt ('HDY1','SEEN',0)
+ call gsatt ('HDY2','SEEN',0)
+ call gdrawt (14.75,2.,'SIDE VIEW',.5,0.,2,0)
+ call gdraw ('SHUT', 90., 90., 90., 14.75,4.0,0.045, 0.080)
+ call s_one_ev_track
+ call gdhits ('* ', '* ', 0, 850, 0.1)
+ call gdclos (6)
+ call gdshow (7)
+ call gdshow (6)
+ call gdshow (7)
+ call gdelet (6)
+ call gdelet (7)
+*
+ end
diff --git a/ONEEV/s_one_ev_track.f b/ONEEV/s_one_ev_track.f
new file mode 100644
index 0000000..0ce7745
--- /dev/null
+++ b/ONEEV/s_one_ev_track.f
@@ -0,0 +1,77 @@
+ subroutine s_one_ev_track
+*
+* $Log: s_one_ev_track.f,v $
+* Revision 1.1 1996/01/17 16:38:09 cdaq
+* Initial revision
+*
+
+ implicit none
+
+ include 'sos_data_structures.cmn'
+ include 'sos_tracking.cmn'
+ include 'sos_geometry.cmn'
+ include 'sos_calorimeter.cmn'
+ include 'gen_event_info.cmn'
+ include 'sos_one_ev.par'
+ include 'gen_one_ev_gctrak.cmn'
+ include 'gen_one_ev_gckine.cmn'
+ include 'gen_one_ev_gcvolu.cmn'
+
+ real track_x, track_y, track_z ! a point on the track
+ real track_x_slope, track_y_slope ! slope of the track
+ real x, y, z ! coordinates
+ real z_distance ! z distance to end of hut
+ integer track ! index variables
+
+*
+* Take care of creating the reconstructed tracks
+*
+ vect(4) = 0.0
+ vect(5) = 0.0
+ vect(6) = 1.
+ vect(7) = 1.
+* ipart = 3 !electron to make track red
+* ipart = 13 !neutron to make track black
+* ipart = 5 !muon to make track green
+ ipart = 1 !photon to make track blue
+ tofg = 1e-5
+ itra = 1
+* amass = 0.511e-3
+* amass = 0.93957
+ sleng = 200.
+ step = 200.
+
+ do track = 1, SNTRACKS_FP
+ ipart = 1 !photon to make track blue
+ if (track.eq.SSNUM_FPTRACK) then
+ ipart = 3 !electron to make track red
+ endif
+ track_x = -sx_fp(track) ! x position on track
+ track_y = sy_fp(track) ! y position on track
+ track_z = 0 ! z position on track
+ track_x_slope = -sxp_fp(track) ! track slope in x
+ track_y_slope = syp_fp(track) ! track slope in y
+
+ z = -SHUT_HEIGHT / 2. ! bottom of hut
+ z_distance = track_z - z ! distance from point to floor
+ x = track_x - z_distance * sin(track_x_slope) ! x loci
+ y = track_y - z_distance * sin(track_y_slope) ! y loci
+ vect(1) = x
+ vect(2) = y
+ vect(3) = z
+ call gsxyz
+ z = SHUT_HEIGHT / 2. ! bottom of hut
+ z_distance = z - track_z ! distance from point to roof
+ x = track_x + z_distance * sin(track_x_slope) ! x loci
+ y = track_y + z_distance * sin(track_y_slope) ! y loci
+ vect(1) = x
+ vect(2) = y
+ vect(3) = z
+ call gsxyz
+ call gdxyz (track)
+* call gdpart (itra,01,0.5) !this will number the tracks
+ itra = itra+1
+* ipart = ipart+1 !this changes the color for each track
+ enddo
+*
+ end
diff --git a/ONEEV/s_one_ev_wc.f b/ONEEV/s_one_ev_wc.f
new file mode 100644
index 0000000..7c5155c
--- /dev/null
+++ b/ONEEV/s_one_ev_wc.f
@@ -0,0 +1,71 @@
+ subroutine s_one_ev_wc
+*
+* $Log: s_one_ev_wc.f,v $
+* Revision 1.1 1996/01/17 16:38:04 cdaq
+* Initial revision
+*
+
+ implicit none
+ include 'sos_one_ev.par'
+
+ integer iset, idet
+ character*4 varinames(3)
+ integer varibits(3)
+ integer chambits(3)
+ real origin(3),factor(3)
+ integer i
+
+ character*4 wire
+ integer ichamber
+ integer isector
+ integer iwire
+ integer iplane
+
+ character*4 specname
+ character*4 wcname(3)
+ character*1 sectorthingy
+ integer nchambers
+ integer nplanes
+ character*1 planenames(4)
+ integer sectors(4),wires(4)
+
+ data specname,nchambers /'SOS ',2/
+ data nplanes /3/
+ data planenames /'U','X','V',' '/
+ data sectors /4,8,4,0/
+ data wires /24,16,24,0/
+
+ data varinames /'x','y','z'/
+ data chambits /2,3,8/
+
+ do i=1,3
+ varibits(i)=32
+ origin(i)=SHUT_HEIGHT
+ factor(i)=1e3
+ enddo
+
+ do ichamber=1,nchambers
+ write (wcname(1),'("WCH",a1)') char(64 + ichamber)
+ do iplane=1,nplanes
+ do isector=1,sectors(iplane)
+ sectorthingy = 'A'
+ if(isector.gt.sectors(iplane)/2) then
+ sectorthingy = 'B'
+ endif
+ write(wcname(2),'("W",3a1)') char(64 + ichamber)
+ $ ,sectorthingy,planenames(iplane)
+ do iwire = 1,wires(iplane)
+ write (wire,'(a,a,a,a)') char(64 + ichamber)
+ $ ,planenames(iplane),char(64 + isector)
+ $ ,char(64 + iwire)
+ wcname(3) = wire
+ call gsdet(specname,wire,3,wcname,chambits,
+ $ 2, 100, 100, iset, idet)
+ call gsdeth(specname,wire,3,varinames,varibits,origin,factor)
+ enddo
+ enddo
+ enddo
+ enddo
+
+ return
+ end
diff --git a/ONEEV/s_uginit.f b/ONEEV/s_uginit.f
new file mode 100644
index 0000000..fa516de
--- /dev/null
+++ b/ONEEV/s_uginit.f
@@ -0,0 +1,37 @@
+ subroutine s_uginit
+*
+* Do the GEANT initalization
+*
+* August, 1994, Pat Welch, Oregon State University, tpw@physics.orst.edu
+*
+* Modified from HMS version, h_uginit, March 1995 by
+* Derek van Westrum (vanwestr@cebaf.gov)
+*
+* $Log: s_uginit.f,v $
+* Revision 1.1 1995/07/31 15:15:28 cdaq
+* Initial revision
+*
+
+ implicit none
+
+ call ginit ! init GEANT
+ call gzinit ! init GEANT data structs
+ call gdinit ! init GEANT drawing package
+
+ call gpart ! init particle structures
+ call gmate ! init materials structures
+ call gsrotm(1,90.,0.,90.,90.,0.,0.)
+ call gsrotm(2,90.,90.,90.,0.,0.,0.)
+* call gsrotm(3,90.,15.,90.,105.,0.,0.)
+ call gsrotm(3,90.,-60.,90.,-150.,0.,0.)
+ call gsrotm(4,90.,60.,90.,150.,0.,0.)
+* call gsrotm(3,90.,-30.,90.,-120.,0.,0.)
+* call gsrotm(4,90.,30.,90.,120.,0.,0.)
+
+ call s_one_ev_geometry ! define the geometry
+ call s_one_ev_detectors ! define sensitive detectors
+ call ggclos ! close geometry structures
+
+ call gphysi ! init physics interaction vars
+
+ end
diff --git a/ONLINE/CVS/Entries b/ONLINE/CVS/Entries
new file mode 100644
index 0000000..57b5ce3
--- /dev/null
+++ b/ONLINE/CVS/Entries
@@ -0,0 +1,10 @@
+/Makefile/1.6/Fri Feb 14 18:10:21 2003//Tsane
+/usrdownload.f/1.2/Thu Jun 16 18:37:06 1994//Tsane
+/usrdump.f/1.1/Tue Jun 14 20:42:33 1994//Tsane
+/usrend.f/1.1/Tue Jun 14 20:42:02 1994//Tsane
+/usrevent.f/1.2/Thu Jul 7 15:21:24 1994//Tsane
+/usrgo.f/1.1/Tue Jun 14 20:42:05 1994//Tsane
+/usrmain.f/1.2/Thu Jun 16 18:36:15 1994//Tsane
+/usrpause.f/1.1/Thu Jun 16 03:49:44 1994//Tsane
+/usrprestart.f/1.1/Tue Jun 14 20:42:13 1994//Tsane
+D
diff --git a/ONLINE/CVS/Repository b/ONLINE/CVS/Repository
new file mode 100644
index 0000000..6ee1351
--- /dev/null
+++ b/ONLINE/CVS/Repository
@@ -0,0 +1 @@
+Analyzer/ONLINE
diff --git a/ONLINE/CVS/Root b/ONLINE/CVS/Root
new file mode 100644
index 0000000..6288c3f
--- /dev/null
+++ b/ONLINE/CVS/Root
@@ -0,0 +1 @@
+whit@cvs.jlab.org:/group/hallc/cvsroot
diff --git a/ONLINE/CVS/Tag b/ONLINE/CVS/Tag
new file mode 100644
index 0000000..25d73f7
--- /dev/null
+++ b/ONLINE/CVS/Tag
@@ -0,0 +1 @@
+Tsane
diff --git a/ONLINE/Makefile b/ONLINE/Makefile
new file mode 100644
index 0000000..6ab973e
--- /dev/null
+++ b/ONLINE/Makefile
@@ -0,0 +1,81 @@
+#
+# $Log: Makefile,v $
+# Revision 1.6 2003/02/14 18:10:21 jones
+# Add if statement for Alpha OSF1 (E. Brash)
+#
+# Revision 1.5 1996/01/17 16:48:24 cdaq
+# (SAW) Add libengine.a to library list
+#
+# Revision 1.4 1995/05/24 14:04:15 cdaq
+# (SAW) Add -lm library for CTP
+#
+# Revision 1.3 1995/01/27 21:09:22 cdaq
+# (SAW) Remove RCS from include file rules
+#
+# Revision 1.2 1994/08/04 03:51:30 cdaq
+# (SAW) Add libhack.a to library list
+#
+# Revision 1.1 1994/07/07 15:25:03 cdaq
+# Initial revision
+#
+#
+include $(Csoft)/etc/Makefile
+
+sources = usrmain.f usrprestart.f usrevent.f usrdump.f usrend.f usrpause.f \
+ usrdownload.f usrgo.f
+
+install-dirs := lib bin
+
+bin_targets = engine_online
+
+lib_targets := $(patsubst %.f, libonline.a(%.o), $(sources))
+
+objects := $(patsubst %.f, %.o, $(sources))
+
+ifeq ($(ARCH),HPUX)
+ CC = gcc
+ OTHERLIBS = -Wl,-L$(CODA)/HP_UX/lib \
+ -lana -lmsg -lcoda -Wl,-L$(CERN_ROOT)/lib -lpacklib -lm
+endif
+
+ifeq ($(ARCH),ULTRIX)
+ CC = gcc
+ OTHERLIBS = -L$(CODA)/ULTRIX/lib -lana -lmsg -lcoda -L$(CERN_ROOT)/lib -lpacklib
+endif
+
+ifeq ($(ARCH),OSF1)
+ CC = cc
+ OTHERLIBS = -L$(CERN_ROOT)/lib -lpacklib
+endif
+
+bin_targets = engine_online
+
+DEPLIBS = $(LIBROOT)/libengine.a \
+ $(LIBROOT)/libhtracking.a $(LIBROOT)/libstracking.a \
+ $(LIBROOT)/libengine.a \
+ $(LIBROOT)/libtracking.a $(LIBROOT)/libhack.a \
+ $(LIBROOT)/libgmc.a $(LIBROOT)/libutils.a $(LIBROOT)/libctp.a
+
+default:
+ @echo "nothing to make"
+
+$(LIBROOT)/libutils.a:
+ @make -C $(Csoft)/SRC/UTILSUBS csoft
+
+$(LIBROOT)/libgmc.a:
+ @make -C $(Csoft)/SRC/GMC csoft
+
+$(LIBROOT)/libtracking.a:
+ @make -C $(Csoft)/SRC/TRACKING csoft
+
+$(LIBROOT)/libctp.a:
+ @make -C $(Csoft)/SRC/CTP csoft
+
+
+engine_online: $(objects) $(DEPLIBS)
+ $(F77) $(FFLAGS) -o engine_online $(objects) $(DEPLIBS) $(OTHERLIBS)
+
+%.cmn :: ../INCLUDE/%.cmn,v
+ cp $< $@
+
+include $(sources:.f=.d)
diff --git a/ONLINE/usrdownload.f b/ONLINE/usrdownload.f
new file mode 100644
index 0000000..1ac2442
--- /dev/null
+++ b/ONLINE/usrdownload.f
@@ -0,0 +1,63 @@
+ subroutine usrdownload(fname)
+*
+* ONLINE ENGINE - Hall C online Analyzer
+*
+* $Log: usrdownload.f,v $
+* Revision 1.2 1994/06/16 18:37:06 cdaq
+* (SAW) Move in code from usrmain
+*
+* Revision 1.1 1994/06/14 20:43:41 cdaq
+* Initial revision
+*
+ implicit none
+ save
+ character*(*) fname
+*
+ character*11 here
+ parameter (here='usrdownload')
+*
+ logical oncethru
+ data oncethru /.false./
+*
+* This common block also used in usrprestart.f. Should probably
+* move these two lines to an include file.
+*
+ character*80 g_config_environmental_var
+ common /ENVVAR/ g_config_environmental_var
+*
+ logical ABORT
+ character*800 err
+*
+ if(.not.oncethru) then
+
+ ABORT = .FALSE.
+ err = ' '
+ g_config_environmental_var = 'ONLINE_CONFIG_FILE'
+
+ call g_register_variables(ABORT,err)
+ if(ABORT .or. err.ne.' ') then
+ call g_add_path(here,err)
+ call dalogmsg(err)
+ endif
+
+ ABORT = .FALSE.
+ err = ' '
+ call g_init_filenames(ABORT,err,g_config_environmental_var)
+ if(ABORT .or. err.ne.' ') then
+ call g_add_path(here,err)
+ call dalogmsg(err)
+ endif
+
+ ABORT = .FALSE.
+ err = ' '
+ call g_decode_init(ABORT,err)
+ if(ABORT .or. err.ne.' ') then
+ call g_add_path(here,err)
+ call dalogmsg(err)
+ endif
+
+ oncethru = .true.
+ endif
+*
+ return
+ end
diff --git a/ONLINE/usrdump.f b/ONLINE/usrdump.f
new file mode 100644
index 0000000..9b1529e
--- /dev/null
+++ b/ONLINE/usrdump.f
@@ -0,0 +1,25 @@
+ subroutine usrdump
+*
+* $Log: usrdump.f,v $
+* Revision 1.1 1994/06/14 20:42:33 cdaq
+* Initial revision
+*
+*
+ implicit none
+ save
+
+ character*7 here
+ parameter (here='usrdump')
+*
+ logical OK,ABORT
+ character*800 err
+*
+ call g_dump_histograms(ABORT,err)
+*
+ if(ABORT .or. err.ne.' ') then
+ call g_add_path(here,err)
+ call dalogmsg(err)
+ endif
+*
+ return
+ end
diff --git a/ONLINE/usrend.f b/ONLINE/usrend.f
new file mode 100644
index 0000000..ac44d82
--- /dev/null
+++ b/ONLINE/usrend.f
@@ -0,0 +1,29 @@
+ subroutine usrend
+*
+* $Log: usrend.f,v $
+* Revision 1.1 1994/06/14 20:42:02 cdaq
+* Initial revision
+*
+*
+ implicit none
+ save
+
+ character*6 here
+ parameter (here='usrend')
+*
+ logical ABORT
+ character*800 err
+*
+ call g_proper_shutdown(ABORT,err)
+*
+ if(ABORT .or. err.ne.' ') then
+ call g_add_path(here,err)
+ call dalogmsg(err)
+ endif
+*
+* Do we need to rename the run?
+*
+ return
+ end
+
+
diff --git a/ONLINE/usrevent.f b/ONLINE/usrevent.f
new file mode 100644
index 0000000..a7789c0
--- /dev/null
+++ b/ONLINE/usrevent.f
@@ -0,0 +1,81 @@
+ subroutine usrevent(event, len, flag)
+*
+* ONLINE ENGINE - Hall C online Analyzer
+*
+* $Log: usrevent.f,v $
+* Revision 1.2 1994/07/07 15:21:24 cdaq
+* (SAW) Add scaler analysis
+*
+* Revision 1.1 1994/06/16 03:49:10 cdaq
+* Initial revision
+*
+*
+ implicit none
+ integer*4 event(*), len, flag
+*
+* event(*) - Contains the event.
+* event(1)+1 is the total length of the event
+* event(event(1)+2) [First word after event] contains the number
+* of events that are waiting to be analyzed.
+* len - Amount of space available for the event. (len-event(1)) is
+* the amount of data that could be appended to the event.
+* flag - If true (the default), write the event to disk after
+* usrevent returns.
+*
+ character*8 here
+ parameter (here='usrevent')
+*
+ logical OK, ABORT, problems
+ character*800 err
+*
+ INCLUDE 'gen_run_info.cmn'
+*
+ integer evtype
+*
+* We need to make sure that clear_event doesn't know about event array.
+*
+ ABORT = .false.
+ err = ' '
+ call g_clear_event(ABORT,err)
+ if(ABORT .or. err.ne.' ') then
+ call g_add_path(here,err)
+ call dalogmsg(err)
+ endif
+*
+ ABORT = .false.
+ err = ' '
+
+ evtype = ishft(event(2),-16)
+
+ if(evtype.le.gen_MAX_trigger_types) then
+ call g_examine_physics_event(event,ABORT,err)
+*
+ if(.NOT.ABORT) then
+ call g_reconstruction(event,ABORT,err)
+ if(ABORT .or. err.ne.' ') then
+ call g_add_path(here,err)
+ call dalogmsg(err)
+ endif
+
+*
+ ABORT = .false.
+ err = ' '
+ call g_keep_results(ABORT,err)
+* if(ABORT .or. err.ne.' ') then
+ if(ABORT) then ! Don't show warnings.
+ call g_add_path(here,err)
+ call dalogmsg(err)
+ endif
+*
+ endif
+ else ! Analyze scalers
+* Assume for now that all other events are scalers
+ call g_analyze_scalers(event,ABORT,err)
+ endif
+
+ return
+ end
+
+
+
+
diff --git a/ONLINE/usrgo.f b/ONLINE/usrgo.f
new file mode 100644
index 0000000..417f025
--- /dev/null
+++ b/ONLINE/usrgo.f
@@ -0,0 +1,25 @@
+ subroutine usrgo()
+*
+* ONLINE ENGINE - Hall C online Analyzer
+*
+* $Log: usrgo.f,v $
+* Revision 1.1 1994/06/14 20:42:05 cdaq
+* Initial revision
+*
+ implicit none
+ save
+
+ character*5 here
+ parameter (here='usrgo')
+*
+ logical OK, ABORT
+ character*800 err
+
+ call g_clear_event(ABORT,err)
+ if(ABORT .or. err.ne.' ') then
+ call g_add_path(here,err)
+ call dalogmsg(err)
+ endif
+*
+ return
+ end
diff --git a/ONLINE/usrmain.f b/ONLINE/usrmain.f
new file mode 100644
index 0000000..66d2603
--- /dev/null
+++ b/ONLINE/usrmain.f
@@ -0,0 +1,33 @@
+*
+* ONLINE ENGINE - Hall C online Analyzer
+*
+* $Log: usrmain.f,v $
+* Revision 1.2 1994/06/16 18:36:15 cdaq
+* (SAW) Move register, g_init_filenames call and map file reading to usrdownload
+*
+* Revision 1.1 1994/06/16 03:49:26 cdaq
+* Initial revision
+*
+
+ program usrmain
+
+ implicit none
+ save
+*
+* We will be an analysis program so need the analysis services
+*
+ integer rc_service_eb, rc_service_ana ! Pointers to common blocks
+ common/rc_service_eb/rc_service_eb
+ common/rc_service_ana/rc_service_ana
+*
+*
+* Open communication with Run Control
+*
+ call rcService(rc_service_eb)
+ call rcService(rc_service_ana)
+ call rcExecute()
+
+* Never return from rcService
+
+ end
+
diff --git a/ONLINE/usrpause.f b/ONLINE/usrpause.f
new file mode 100644
index 0000000..856821c
--- /dev/null
+++ b/ONLINE/usrpause.f
@@ -0,0 +1,13 @@
+ subroutine usrpause
+*
+* $Log: usrpause.f,v $
+* Revision 1.1 1994/06/16 03:49:44 cdaq
+* Initial revision
+*
+ implicit none
+ save
+
+ return
+ end
+
+
diff --git a/ONLINE/usrprestart.f b/ONLINE/usrprestart.f
new file mode 100644
index 0000000..b4c5710
--- /dev/null
+++ b/ONLINE/usrprestart.f
@@ -0,0 +1,52 @@
+ subroutine usrprestart(run_number, run_type)
+*
+* $Log: usrprestart.f,v $
+* Revision 1.1 1994/06/14 20:42:13 cdaq
+* Initial revision
+*
+*
+ implicit none
+ save
+*
+ character*11 here
+ parameter (here='usrprestart')
+*
+ integer*4 run_number, run_type
+*
+* This common block also used in usrprestart.f. Should probably
+* move these two lines to an include file.
+ character*80 g_config_environmental_var
+ common /ENVVAR/ g_config_environmental_var
+*
+ logical ABORT
+ character*800 err
+*
+* Every new run we may change the filenames
+*
+ ABORT = .false.
+ err = ' '
+*
+ call g_init_filenames(ABORT,err,g_config_environmental_var)
+ if(ABORT .or. err.ne.' ') then
+ call g_add_path(here,err)
+ call dalogmsg(err)
+ endif
+*
+ ABORT = .false.
+ err = ' '
+ call g_initialize(ABORT,err)
+ if(ABORT .or. err.ne.' ') then
+ call g_add_path(here,err)
+ call dalogmsg(err)
+ endif
+*
+ ABORT = .false.
+ err = ' '
+ call g_reset_event(ABORT,err)
+ if(ABORT .or. err.ne.' ') then
+ call g_add_path(here,err)
+ call dalogmsg(err)
+ endif
+*
+ return
+ end
diff --git a/PORT/.cvsignore b/PORT/.cvsignore
new file mode 100644
index 0000000..92aeffc
--- /dev/null
+++ b/PORT/.cvsignore
@@ -0,0 +1 @@
+O.*
diff --git a/PORT/CVS/Entries b/PORT/CVS/Entries
new file mode 100644
index 0000000..1d807bb
--- /dev/null
+++ b/PORT/CVS/Entries
@@ -0,0 +1,9 @@
+/.cvsignore/1.1/Thu Jul 8 18:41:24 2004//Tsane
+/Makefile/1.1/Tue Dec 8 15:56:42 1998//Tsane
+/Makefile.Unix/1.5.24.1/Mon Sep 10 20:08:02 2007//Tsane
+/bit_wrappers.f/1.3.24.1/Mon Sep 10 20:28:01 2007//Tsane
+/cwrappers.c/1.1.24.1/Mon Sep 10 21:32:48 2007//Tsane
+/other_wrappers.f/1.1/Thu Nov 30 14:24:44 2000//Tsane
+/ran_wrappers.f/1.1/Wed Feb 24 15:29:17 1999//Tsane
+/trig_wrappers.f/1.1/Wed Feb 24 15:29:17 1999//Tsane
+D
diff --git a/PORT/CVS/Repository b/PORT/CVS/Repository
new file mode 100644
index 0000000..de17697
--- /dev/null
+++ b/PORT/CVS/Repository
@@ -0,0 +1 @@
+Analyzer/PORT
diff --git a/PORT/CVS/Root b/PORT/CVS/Root
new file mode 100644
index 0000000..6288c3f
--- /dev/null
+++ b/PORT/CVS/Root
@@ -0,0 +1 @@
+whit@cvs.jlab.org:/group/hallc/cvsroot
diff --git a/PORT/CVS/Tag b/PORT/CVS/Tag
new file mode 100644
index 0000000..25d73f7
--- /dev/null
+++ b/PORT/CVS/Tag
@@ -0,0 +1 @@
+Tsane
diff --git a/PORT/Makefile b/PORT/Makefile
new file mode 100644
index 0000000..218e9d9
--- /dev/null
+++ b/PORT/Makefile
@@ -0,0 +1,8 @@
+#
+# $Log: Makefile,v $
+# Revision 1.1 1998/12/08 15:56:42 saw
+# Initial setup
+#
+ETC=../etc
+
+include $(ETC)/Makefile.NEW
diff --git a/PORT/Makefile.Unix b/PORT/Makefile.Unix
new file mode 100644
index 0000000..ead2711
--- /dev/null
+++ b/PORT/Makefile.Unix
@@ -0,0 +1,67 @@
+#
+# This directory contains code that is needed to in some ports of the
+# Hall C analyzer to platforms other than HPUX. For example, it contains
+# definitions of some fortran functions that are missing under F2C/Linux.
+#
+# $Log: Makefile.Unix,v $
+# Revision 1.5.24.1 2007/09/10 20:08:02 pcarter
+# Implemented changes to allow compilation on RHEL 3,4,5 and MacOSX
+#
+# Revision 1.5 2000/11/30 14:23:03 saw
+# Add other_wrappers.f for jidnnt
+#
+# Revision 1.4 1998/12/09 16:31:16 saw
+# Remove dependence on Csoft environment variable
+#
+# Revision 1.3 1998/12/01 20:37:29 saw
+# (SAW) Linux fixes
+#
+# Revision 1.2 1996/11/22 17:05:53 saw
+# (SAW) Add routines for porting to Linux and AIX
+#
+# Revision 1.1 1996/09/09 13:34:01 saw
+# Initial revision
+#
+NEWSTYLE=1
+include ../../etc/Makefile
+include ../../etc/Makefile.flags
+
+ifeq ($(MYOS),AIX)
+ libsources = bit_wrappers.f
+ install-dirs := lib
+else
+ ifeq ($(MYOS),Linux)
+ ifeq ($(F77COMPILER),Absoft)
+ libsources = absoft_wrappers.f
+ else
+ libsources = bit_wrappers.f trig_wrappers.f ran_wrappers.f \
+ other_wrappers.f
+ endif
+ install-dirs := lib
+ else
+ libsources =
+ install-dirs :=
+ endif
+endif
+
+sources = $(libsources)
+
+lib_targets := $(patsubst %.f, libport.a(%.o), $(libsources)) \
+ libport.a(cwrappers.o)
+
+#default:
+# @echo "nothing to make"
+
+ifdef NFSDIRECTORY
+../%.f : $(NFSDIRECTORY)/PORT/%.f
+ ln -s $< $@
+
+../%.c : $(NFSDIRECTORY)/PORT/%.c
+ ln -s $< $@
+
+.PRECIOUS: ../%.f ../%.c
+endif
+
+cwrappers.o: ../cwrappers.c
+
+include $(libsources:.f=.d) cwrappers.d
diff --git a/PORT/bit_wrappers.f b/PORT/bit_wrappers.f
new file mode 100644
index 0000000..bb22043
--- /dev/null
+++ b/PORT/bit_wrappers.f
@@ -0,0 +1,57 @@
+*
+* Wrappers for F2C intrinsic functions that have different names
+* from standard f77s.
+*
+* $Log: bit_wrappers.f,v $
+* Revision 1.3.24.1 2007/09/10 20:28:01 pcarter
+* Implemented changes to allow compilation on RHEL 3,4,5 and MacOSX
+*
+* Revision 1.3 1999/11/04 20:36:32 saw
+* Linux/G77 compatibility fixes - Add jieor function
+*
+* Revision 1.2 1996/11/22 17:06:27 saw
+* (SAW) Move trig routines to trig_wrappers.f
+*
+* Revision 1.1 1996/09/09 13:34:26 saw
+* Initial revision
+*
+*
+ integer*4 function jishft(a1,a2)
+ external lshift, rshift
+ integer lshift, rshift
+ integer*4 a1,a2
+ if(a2.lt.0) then
+ jishft = rshift(a1,-a2)
+ else
+ jishft = lshift(a1,a2)
+ endif
+ return
+ end
+
+ integer*4 function jiand(a1,a2)
+ integer*4 a1,a2
+ jiand = and(a1,a2)
+ return
+ end
+
+ integer*4 function jieor(a1,a2)
+ integer*4 a1,a2
+ jieor = xor(a1,a2)
+ return
+ end
+
+ integer*4 function jibset(a1,a2)
+ integer*4 a1,a2
+ external lshift
+ integer lshift
+ jibset = or(a1,lshift(1,a2))
+ return
+ end
+
+ logical*4 function bjtest(a1,a2)
+ external lshift
+ integer lshift
+ integer*4 a1,a2
+ bjtest = (and(a1,lshift(1,a2)).ne.0)
+ return
+ end
diff --git a/PORT/cwrappers.c b/PORT/cwrappers.c
new file mode 100644
index 0000000..0c0d78a
--- /dev/null
+++ b/PORT/cwrappers.c
@@ -0,0 +1,22 @@
+#include <stdlib.h>
+
+long int random_(void){
+ return(random());
+}
+
+void qsort_(void *base, int *nmemb, int *size,
+ int (*compar)(const void *,const void *))
+{
+ qsort(base,*nmemb,*size,compar);
+}
+
+// lshift and rshift are intrinsics provided by g77 and gfortran 4.2,
+// but not by gfortran 4.1.1
+
+int lshift_(int *Num2Shift, int *NumBits ) {
+ return(*Num2Shift << *NumBits);
+}
+
+int rshift_(int *Num2Shift, int *NumBits ) {
+ return(*Num2Shift >> *NumBits);
+}
diff --git a/PORT/other_wrappers.f b/PORT/other_wrappers.f
new file mode 100644
index 0000000..10fde9c
--- /dev/null
+++ b/PORT/other_wrappers.f
@@ -0,0 +1,18 @@
+*
+* Wrapperse for G77 intrinsic functions that have different names from
+* other f77's
+*
+* $Log: other_wrappers.f,v $
+* Revision 1.1 2000/11/30 14:24:44 saw
+* JIDNNT function
+*
+*
+* JIDNNT Return nearest INT for a REAL*16 number
+*
+ integer*4 function jidnnt(f)
+ real*8 f
+*
+ jidnnt = nint(f)
+ return
+ end
+
diff --git a/PORT/ran_wrappers.f b/PORT/ran_wrappers.f
new file mode 100644
index 0000000..092cd39
--- /dev/null
+++ b/PORT/ran_wrappers.f
@@ -0,0 +1,26 @@
+*
+* Wrappers for the ran function for f2c fortran
+*
+* $Log: ran_wrappers.f,v $
+* Revision 1.1 1999/02/24 15:29:17 saw
+* Add to CVS tree
+*
+*
+ real*4 function ran(seed)
+ integer*4 seed
+ logical started
+ save started
+ real*4 RAND_MAX
+ parameter(RAND_MAX=2147483647)
+ integer*4 random
+ real*4 fran
+
+ data started /.false./
+
+c
+c Ignore any seeds
+c
+ fran = (random()+1.0)/(RAND_MAX+1.0)
+ ran = fran
+ return
+ end
diff --git a/PORT/trig_wrappers.f b/PORT/trig_wrappers.f
new file mode 100644
index 0000000..10be700
--- /dev/null
+++ b/PORT/trig_wrappers.f
@@ -0,0 +1,30 @@
+*
+* Wrappers for F2C intrinsic functions that have different names
+* from standard f77s.
+*
+* $Log: trig_wrappers.f,v $
+* Revision 1.1 1999/02/24 15:29:17 saw
+* Add to CVS tree
+*
+* Revision 1.1 1996/09/09 13:34:26 saw
+* Initial revision
+*
+*
+
+ real*4 function sind(x)
+ real*4 x
+ sind = sin(x*3.1415926535/180)
+ return
+ end
+
+ real*4 function cosd(x)
+ real*4 x
+ cosd = cos(x*3.1415926535/180)
+ return
+ end
+
+ real*4 function tand(x)
+ real*4 x
+ tand = tan(x*3.1415926535/180)
+ return
+ end
diff --git a/SANE/#sane_ntuple_keep.f# b/SANE/#sane_ntuple_keep.f#
new file mode 100644
index 0000000..8279b29
--- /dev/null
+++ b/SANE/#sane_ntuple_keep.f#
@@ -0,0 +1,776 @@
+ subroutine sane_ntuple_keep(ABORT,err)
+
+ implicit none
+ save
+ integer iflag_write
+
+ character*13 here
+ parameter(here='sane_ntuple_keep')
+
+ logical abort
+ character*(*) err
+ integer i,j,status(100,100),k,m
+
+ include 'b_ntuple.cmn'
+ include 'bigcal_data_structures.cmn'
+ include 'bigcal_tof_parms.cmn'
+ include 'hms_data_structures.cmn'
+ include 'bigcal_gain_parms.cmn'
+ include 'gen_event_info.cmn'
+ include 'gen_data_structures.cmn'
+ include 'gep_data_structures.cmn'
+ include 'sane_ntuple.cmn'
+ include 'sane_data_structures.cmn'
+ include 'sem_data_structures.cmn'
+ INCLUDE 'h_ntuple.cmn'
+ include 'f1trigger_data_structures.cmn'
+ include 'hms_calorimeter.cmn'
+ include 'gen_detectorids.par'
+ include 'gen_scalers.cmn'
+ include 'gen_run_info.cmn'
+ logical HEXIST ! CERNLIB function
+ integer t_sane,l_sane,cer_sane
+ integer icycle,inum,ihit
+ real*8 Eb,theta_big, phi_big!,ccx,ccy,ccz
+ real P_el(4),p_e,WW2
+ common/FAKEBIG/Eb,theta_big, phi_big
+ real*8 tcharge_old,tcharge_help_old,tcharge_helm_old
+ real*8 charge2s_old,charge2s_help_old,charge2s_helm_old
+ real*8 polarea_old ,polarization_old
+ integer*4 hel_p_scaler_old
+ integer*4 hel_n_scaler_old
+ integer*4 hel_p_trig_old
+ integer*4 hel_n_trig_old
+ real*8 dtime_p_old ,dtime_n_old
+ real*4 half_plate_old
+ common/SANEEV_old /
+ $ tcharge_old ,
+ $ charge2s_old ,
+ $ tcharge_help_old,charge2s_help_old,
+ $ tcharge_helm_old,charge2s_helm_old ,
+ $ polarea_old ,polarization_old,
+ $ hel_p_scaler_old ,
+ $ hel_n_scaler_old ,
+ $ hel_p_trig_old ,
+ $ hel_n_trig_old ,
+ $ dtime_p_old ,dtime_n_old,half_plate_old
+
+
+ real Mp
+ parameter(Mp=.938272)
+ real*8 cer_adc_save(12)
+ real Pi0Mass,dist,cosg1g2,Pg1(4),Pg2(4)
+
+
+ err=' '
+ ABORT=.false.
+c write(*,*)'Starting sane'
+c INQUIRE(FILE="input.txt",EXIST=file_exist)
+c write(*,*)file_exist
+c write(*,*)nclust
+
+ if(.not.sane_ntuple_exists) return
+ if(.not.charge_data_open.and.charge_ch)then
+ charge2s = gbcm1_charge-tcharge
+ tcharge = gbcm1_charge
+ charge2s_help = gbcm1_charge_help -tcharge_help
+ tcharge_help = gbcm1_charge_help
+ charge2s_helm = gbcm1_charge_helm -tcharge_helm
+ tcharge_helm = gbcm1_charge_helm
+c write(*,*)'MMM'
+c endif
+c if(.not.charge_data_open.and.gscaler_change(538).ne.hel_p_scaler)then
+c hel_p_scaler=gscaler_change(538)
+ hel_p_scaler= 0.985*gscaler_change(510)-gscaler_change(538)
+ hel_p_trig= g_hel_pos
+ dtime_p =1.
+ if(abs(hel_p_scaler).gt.0)then
+ dtime_p =float(g_hel_pos)/float(hel_p_scaler)
+ endif
+ call NANcheckF(dtime_p,0)
+ g_hel_pos =0
+c write(*,*)'MMM P'
+c endif
+c if(.not.charge_data_open.and.gscaler_change(546).ne.hel_n_scaler)then
+
+c hel_n_scaler= 0.985*gscaler_change(510)-gscaler_change(538)
+ hel_n_scaler=gscaler_change(538)
+ hel_n_trig= g_hel_neg
+ dtime_n=1
+ if(abs(hel_n_scaler).gt.0.0)then
+ dtime_n = float(g_hel_neg)/float(hel_n_scaler)
+ endif
+ call NANcheckF(dtime_n,0)
+ g_hel_neg =0
+c write(*,*)'MMM N'
+ endif
+ if(polarization_data_open)then
+ polarea = polarea_old
+ polarization =polarization_old
+ half_plate =half_plate_old
+ endif
+ if(charge_data_open)then
+ charge2s = charge2s_old
+ tcharge = tcharge_old
+ charge2s_help = charge2s_help_old
+ tcharge_help = tcharge_help_old
+ charge2s_helm = charge2s_helm_old
+ tcharge_helm = tcharge_helm_old
+ hel_p_scaler = hel_p_scaler_old
+ hel_p_trig = hel_p_trig_old
+ dtime_p = dtime_p
+ hel_n_scaler = hel_n_scaler_old
+ hel_n_trig = hel_n_trig_old
+ dtime_n = dtime_n_old
+c if(abs(gbcm1_charge-tcharge).lt.0.001)charge_ch = .TRUE.
+ endif
+ if(polarization_data_open.and.gen_event_ID_number.eq.pol_id_change)then
+ read(polarization_data_unit,*,end=19)pol_id_change,polarea_old,polarization_old,half_plate_old
+c write(*,*)'HELP ',polarea_old
+ polarea = polarea_old
+ polarization=polarization_old
+ half_plate =half_plate_old
+ polarization_ch = .FALSE.
+ else if(.not.polarization_data_open.and.polarization_ch)then
+ write(polarization_data_unit,*)gen_event_ID_number,polarea ,polarization ,half_plate
+ polarization_ch = .FALSE.
+ endif
+
+ if(charge_data_open.and.gen_event_ID_number.eq.charge_id_change)then
+c write(*,*)'HELP charge Had',tcharge,gbcm1_charge
+ read(charge_data_unit,*,end=18)
+ , charge_id_change,charge2s_old,tcharge_old,
+ , tcharge_help_old,charge2s_help_old,
+ , tcharge_helm_old,charge2s_helm_old ,
+ , hel_p_scaler_old,hel_p_trig_old,dtime_p_old,
+ , hel_n_scaler_old,hel_n_trig_old,dtime_n_old
+
+
+c write(*,*)'HELP charge NOW',tcharge_old,gbcm1_charge
+ charge2s = charge2s_old
+ tcharge = tcharge_old
+ charge2s_help = charge2s_help_old
+ tcharge_help = tcharge_help_old
+ charge2s_helm = charge2s_helm_old
+ tcharge_helm = tcharge_helm_old
+ hel_p_scaler = hel_p_scaler_old
+ hel_p_trig = hel_p_trig_old
+ dtime_p = dtime_p_old
+ hel_n_scaler = hel_n_scaler_old
+ hel_n_trig = hel_n_trig_old
+ dtime_n = dtime_n_old
+ charge_ch = .FALSE.
+
+c write(*,*)gbcm1_charge,tcharge
+ else if(.not.charge_data_open.and.charge_ch)then
+ write(charge_data_unit,*)
+ , gen_event_ID_number,charge2s,tcharge,
+ , tcharge_help,charge2s_help,
+ , tcharge_helm,charge2s_helm ,
+ > hel_p_scaler,hel_p_trig,dtime_p,
+ , hel_n_scaler,hel_n_trig,dtime_n
+ charge_ch = .FALSE.
+ endif
+c write(*,*)'HALF PLATE ',half_plate
+
+c if(charge_ch)then
+c write(*,*)polarea,charge2s,tcharge,hel_n_trig,hel_p_trig,hel_p_scaler
+c endif
+c if(polarization_ch)then
+c write(*,*)polarea,charge2s,tcharge,hel_n_trig,hel_p_trig,hel_p_scaler
+c endif
+c write(*,*)gbcm1_charge
+
+
+
+
+ T_trgHMS = gmisc_dec_data(11,1)
+ call NANcheckF(T_trgHMS,3)
+ T_trgBIG = gmisc_dec_data(12,1)
+ call NANcheckF(T_trgBIG,3)
+ T_trgPI0 = gmisc_dec_data(13,1)
+ call NANcheckF(T_trgPI0,3)
+ T_trgBETA = gmisc_dec_data(14,1)
+ call NANcheckF(T_trgBETA,3)
+ T_trgCOIN1 = gmisc_dec_data(15,1)
+ call NANcheckF(T_trgCOIN1,3)
+ T_trgCOIN2 = gmisc_dec_data(16,1)
+ call NANcheckF(T_trgCOIN2,3)
+
+cccccccccc Lucite Hodoscope
+ luc_hit = 0
+c write(*,*) LUCITE_SANE_RAW_TOT_HITS,LUCITE_SANE_RAW_TOT_HITS2,LUCITE_SANE_RAW_TOT_HITS3
+c write(*,*) LUCITE_SANE_RAW_TOT_HITS,LUCITE_SANE_RAW_TOT_HITS3
+c write(*,*) LUCITE_SANE_RAW_TDC_POS
+c write(*,*) LUCITE_SANE_RAW_TDC_POS
+
+
+! do i=1,LUCITE_SANE_RAW_TOT_HITS2 ! TDC hit counter for positive side
+c if(LUCITE_SANE_RAW_COUNTER_NUM2(i).eq.7)write(*,*)7
+! if(LUCITE_SANE_RAW_TDC_POS(i).gt.0)then
+! do j=1,LUCITE_SANE_RAW_TOT_HITS3 !TDC hit counter for negative side
+c if(LUCITE_SANE_RAW_COUNTER_NUM3(j).eq.7)write(*,*)72
+! if ( luc_hit .lt. 90) then ! check hard coded array max
+! if(LUCITE_SANE_RAW_TDC_NEG(j).gt.0.and.
+! , LUCITE_SANE_RAW_COUNTER_NUM2(i).eq.LUCITE_SANE_RAW_COUNTER_NUM3(j))then
+! luc_hit = luc_hit+1
+! luc_row(luc_hit) = LUCITE_SANE_RAW_COUNTER_NUM2(i)
+! ladc_pos(luc_hit) = LUCITE_SANE_RAW_ADC_POS(luc_row(luc_hit)) !- luc_ped_mean_pos(luc_row(luc_hit))
+! ladc_neg(luc_hit) = LUCITE_SANE_RAW_ADC_NEG(luc_row(luc_hit)) !- luc_ped_mean_neg(luc_row(luc_hit))
+! luc_y(luc_hit) = -82.35 + (luc_row(luc_hit)-1)*6.1
+! call NANcheck(luc_hit,LUCITE_SANE_ID)
+! call NANcheck(luc_row(luc_hit),LUCITE_SANE_ID)
+! call NANcheck(ladc_neg(luc_hit),LUCITE_SANE_ID)
+! call NANcheck(ladc_pos(luc_hit),LUCITE_SANE_ID)
+! call NANcheck(ltdc_neg(luc_hit),LUCITE_SANE_ID)
+! call NANcheck(ltdc_pos(luc_hit),LUCITE_SANE_ID)
+! call CORRECT_RAW_TIME_SANE(LUCITE_SANE_RAW_TDC_POS(i),ltdc_pos(luc_hit))
+! call CORRECT_RAW_TIME_SANE(LUCITE_SANE_RAW_TDC_NEG(j),ltdc_NEG(luc_hit))
+c call HFILL(10121, float(luc_row(luc_hit)), float(ltdc_pos(luc_hit)), 1.)
+c call HFILL(10122, float(luc_row(luc_hit)), float(ltdc_neg(luc_hit)), 1.)
+c call HFILL(10125, float(luc_row(luc_hit)), float(ladc_pos(luc_hit)), 1.)
+c call HFILL(10126, float(luc_row(luc_hit)), float(ladc_neg(luc_hit)), 1.)
+! LUCITE_SANE_RAW_TDC_NEG(j) = 0
+! endif
+! endif
+! enddo
+! LUCITE_SANE_RAW_TDC_POS(i) = 0
+
+! endif
+! enddo
+c write(*,*)'LUC sane done'
+ do i=1,LUCITE_SANE_RAW_TOT_HITS2
+ if(LUCITE_SANE_RAW_TDC_POS(i).gt.0)then
+ luc_hit = luc_hit+1
+ luc_row(luc_hit) = LUCITE_SANE_RAW_COUNTER_NUM2(i)
+ ladc_pos(luc_hit) = LUCITE_SANE_RAW_ADC_POS(luc_row(luc_hit)) - luc_ped_mean_pos(luc_row(luc_hit))
+ ladc_neg(luc_hit) = -100000
+ call CORRECT_RAW_TIME_SANE(LUCITE_SANE_RAW_TDC_POS(i),ltdc_pos(luc_hit))
+ ltdc_NEG(luc_hit) = -100000
+ LUCITE_SANE_RAW_TDC_POS(i) = 0
+c call HFILL(10121, float(luc_row(luc_hit)), float(ltdc_pos(luc_hit)), 1.)
+c call HFILL(10125, float(luc_row(luc_hit)), float(ladc_pos(luc_hit)), 1.)
+
+ endif
+ enddo
+ do i=1,LUCITE_SANE_RAW_TOT_HITS3
+ if(LUCITE_SANE_RAW_TDC_NEG(i).gt.0)then
+ luc_hit = luc_hit+1
+ luc_row(luc_hit) = LUCITE_SANE_RAW_COUNTER_NUM3(i)
+ ladc_neg(luc_hit) = LUCITE_SANE_RAW_ADC_NEG(luc_row(luc_hit)) - luc_ped_mean_pos(luc_row(luc_hit))
+ ladc_pos(luc_hit) = -100000
+ call CORRECT_RAW_TIME_SANE(LUCITE_SANE_RAW_TDC_NEG(i),ltdc_neg(luc_hit))
+ ltdc_POS(luc_hit) = -100000
+ LUCITE_SANE_RAW_TDC_NEG(i) = 0
+c call HFILL(10122, float(luc_row(luc_hit)), float(ltdc_neg(luc_hit)), 1.)
+c call HFILL(10126, float(luc_row(luc_hit)), float(ladc_neg(luc_hit)), 1.)
+
+ endif
+ enddo
+cccccccccc End Lucite Hodoscope
+
+! luc_hit = 0
+! c write(*,*) LUCITE_SANE_RAW_TOT_HITS2,LUCITE_SANE_RAW_TOT_HITS3
+! c write(*,*)LUCITE_SANE_RAW_TDC_POS
+! ! write(*,*) luc_ped_mean_pos(1)
+!
+! do i=1,LUCITE_SANE_RAW_TOT_HITS2
+! c if(LUCITE_SANE_RAW_COUNTER_NUM2(i).eq.7)write(*,*)7
+! if(LUCITE_SANE_RAW_TDC_POS(i).gt.0)then
+! do j=1,LUCITE_SANE_RAW_TOT_HITS3
+! c if(LUCITE_SANE_RAW_COUNTER_NUM3(j).eq.7)write(*,*)72
+! if ( luc_hit .lt. 90) then
+! if(LUCITE_SANE_RAW_TDC_NEG(j).gt.0.and.
+! , LUCITE_SANE_RAW_COUNTER_NUM2(i).eq.LUCITE_SANE_RAW_COUNTER_NUM3(j))then
+! luc_hit = luc_hit+1
+! luc_row(luc_hit) = LUCITE_SANE_RAW_COUNTER_NUM2(i)
+! ladc_pos(luc_hit) = LUCITE_SANE_RAW_ADC_POS(luc_row(luc_hit)) - luc_ped_mean_pos(luc_row(luc_hit))
+! ladc_neg(luc_hit) = LUCITE_SANE_RAW_ADC_NEG(luc_row(luc_hit)) - luc_ped_mean_neg(luc_row(luc_hit))
+! luc_y(luc_hit) = -82.35 + (luc_row(luc_hit)-1)*6.1
+! call NANcheck(luc_hit,LUCITE_SANE_ID)
+! call NANcheck(luc_row(luc_hit),LUCITE_SANE_ID)
+! call NANcheck(ladc_neg(luc_hit),LUCITE_SANE_ID)
+! call NANcheck(ladc_pos(luc_hit),LUCITE_SANE_ID)
+! call NANcheck(ltdc_neg(luc_hit),LUCITE_SANE_ID)
+! call NANcheck(ltdc_pos(luc_hit),LUCITE_SANE_ID)
+! call CORRECT_RAW_TIME_SANE(LUCITE_SANE_RAW_TDC_POS(i),ltdc_pos(luc_hit))
+! call CORRECT_RAW_TIME_SANE(LUCITE_SANE_RAW_TDC_NEG(j),ltdc_NEG(luc_hit))
+! c call HFILL(10121, float(luc_row(luc_hit)), float(ltdc_pos(luc_hit)), 1.)
+! c call HFILL(10122, float(luc_row(luc_hit)), float(ltdc_neg(luc_hit)), 1.)
+! c call HFILL(10125, float(luc_row(luc_hit)), float(ladc_pos(luc_hit)), 1.)
+! c call HFILL(10126, float(luc_row(luc_hit)), float(ladc_neg(luc_hit)), 1.)
+! LUCITE_SANE_RAW_TDC_NEG(j) = 0
+! endif
+! endif
+! enddo
+! LUCITE_SANE_RAW_TDC_POS(i) = 0
+!
+! endif
+! enddo
+c write(*,*)'LUC sane done'
+c do i=1,LUCITE_SANE_RAW_TOT_HITS2
+c if(LUCITE_SANE_RAW_TDC_POS(i).gt.0)then
+c luc_hit = luc_hit+1
+c luc_row(luc_hit) = LUCITE_SANE_RAW_COUNTER_NUM2(i)
+c ladc_pos(luc_hit) = LUCITE_SANE_RAW_ADC_POS(luc_row(luc_hit)) - luc_ped_mean_pos(luc_row(luc_hit))
+c ladc_neg(luc_hit) = -100000
+c call CORRECT_RAW_TIME_SANE(LUCITE_SANE_RAW_TDC_POS(i),ltdc_pos(luc_hit))
+c ltdc_NEG(luc_hit) = -100000
+c LUCITE_SANE_RAW_TDC_POS(i) = 0
+c call HFILL(10121, float(luc_row(luc_hit)), float(ltdc_pos(luc_hit)), 1.)
+c call HFILL(10125, float(luc_row(luc_hit)), float(ladc_pos(luc_hit)), 1.)
+c
+c endif
+c enddo
+c do i=1,LUCITE_SANE_RAW_TOT_HITS3
+c if(LUCITE_SANE_RAW_TDC_NEG(i).gt.0)then
+c luc_hit = luc_hit+1
+c luc_row(luc_hit) = LUCITE_SANE_RAW_COUNTER_NUM3(i)
+c ladc_neg(luc_hit) = LUCITE_SANE_RAW_ADC_NEG(luc_row(luc_hit)) - luc_ped_mean_pos(luc_row(luc_hit))
+c ladc_pos(luc_hit) = -100000
+c call CORRECT_RAW_TIME_SANE(LUCITE_SANE_RAW_TDC_NEG(i),ltdc_neg(luc_hit))
+c ltdc_POS(luc_hit) = -100000
+c LUCITE_SANE_RAW_TDC_NEG(i) = 0
+c call HFILL(10122, float(luc_row(luc_hit)), float(ltdc_neg(luc_hit)), 1.)
+c call HFILL(10126, float(luc_row(luc_hit)), float(ladc_neg(luc_hit)), 1.)
+c
+c endif
+c enddo
+! write(*,*) cer_sane_ped_mean(1)
+
+! do i=1,12
+! cer_adc_save(i) = -10000.
+! enddo
+! ceradc_hit = 0
+! do i=1,CERENKOV_SANE_RAW_TOT_HITS
+! if (ceradc_hit .le. 15) then
+! ceradc_hit = ceradc_hit + 1
+! ceradc_num(ceradc_hit) = CERENKOV_SANE_RAW_COUNTER_NUM(i)
+! cer_adc(ceradc_hit) = CERENKOV_SANE_RAW_ADC(ceradc_num(ceradc_hit))-cer_sane_ped_mean(ceradc_num(ceradc_hit))
+! if (ceradc_num(ceradc_hit) .le. 12) cer_adc_save(ceradc_num(ceradc_hit))= cer_adc(ceradc_hit)
+! call NANcheck(ceradc_hit,CERENKOV_SANE_ID2)
+! call NANcheck(ceradc_num(ceradc_hit),CERENKOV_SANE_ID2)
+! call NANcheck(cer_adc(ceradc_hit),CERENKOV_SANE_ID2)
+! c call HFILL(10112,float(ceradc_num(ceradc_hit)),float(cer_adc(ceradc_hit)), 1.)
+! endif
+! enddo
+! cer_hit = 0
+! c write(*,*)'c, ',CERENKOV_SANE_RAW_COUNTER_NUM
+! c write(*,*)'a, ' ,CERENKOV_SANE_RAW_ADC
+! do i=1,CERENKOV_SANE_RAW_TOT_HITS2
+! if(CERENKOV_SANE_RAW_TDC(i).gt.0)then
+! if(cer_hit.le.50)then
+! cer_hit = cer_hit+1
+! cer_num(cer_hit) = CERENKOV_SANE_RAW_COUNTER_NUM2(i)
+! call CORRECT_RAW_TIME_SANE(CERENKOV_SANE_RAW_TDC(i),cer_tdc(cer_hit))
+! cer_adcc(cer_hit) = cer_adc_save(cer_num(cer_hit))
+! c call HFILL(10111,float(cer_num(cer_hit)),float(cer_TDC(cer_hit)), 1.)
+!
+! call NANcheck(cer_hit,CERENKOV_SANE_ID)
+! call NANcheck(cer_num(cer_hit),CERENKOV_SANE_ID)
+! call NANcheck(cer_adcc(cer_hit),CERENKOV_SANE_ID2)
+! call NANcheck(cer_tdc(cer_hit),CERENKOV_SANE_ID)
+! c if ( T_trgBIG.ge.40) then
+! c call HFILL(10500+cer_num(cer_hit),float(cer_adcc(cer_hit)),float(cer_tdc(cer_hit)),1.)
+! c endif
+! endif
+! endif
+! enddo
+
+
+ccccccc Cherenkov
+ cer_hit = 0
+c write(*,*)'c, ',CERENKOV_SANE_RAW_COUNTER_NUM
+c write(*,*)'a, ' ,CERENKOV_SANE_RAW_ADC
+ do i=1,CERENKOV_SANE_RAW_TOT_HITS2
+ if(CERENKOV_SANE_RAW_TDC(i).gt.0)then
+ cer_hit = cer_hit+1
+ cer_num(cer_hit) = CERENKOV_SANE_RAW_COUNTER_NUM2(i)
+ call CORRECT_RAW_TIME_SANE(CERENKOV_SANE_RAW_TDC(i),cer_tdc(cer_hit))
+ cer_adcc(cer_hit) = CERENKOV_SANE_RAW_ADC(cer_num(cer_hit))-cer_sane_ped_mean(cer_num(cer_hit))
+ call HFILL(10111,float(cer_num(cer_hit)),float(cer_TDC(cer_hit)), 1.)
+
+ call NANcheck(cer_hit,CERENKOV_SANE_ID)
+ call NANcheck(cer_num(cer_hit),CERENKOV_SANE_ID)
+ call NANcheck(cer_adcc(cer_hit),CERENKOV_SANE_ID2)
+ call NANcheck(cer_tdc(cer_hit),CERENKOV_SANE_ID)
+c if ( T_trgBIG.ge.40) then
+c call HFILL(10500+cer_num(cer_hit),float(cer_adcc(cer_hit)),float(cer_tdc(cer_hit)),1.)
+c endif
+ endif
+ enddo
+
+c write(*,*)CERENKOV_SANE_RAW_TOT_HITS2,' ',
+c ^ CERENKOV_SANE_RAW_TOT_HITS
+
+ ceradc_hit = 0
+ do i=1,CERENKOV_SANE_RAW_TOT_HITS
+ if (ceradc_hit .le. 15) then
+ ceradc_hit = ceradc_hit + 1
+ ceradc_num(ceradc_hit) = CERENKOV_SANE_RAW_COUNTER_NUM(i)
+ cer_adc(ceradc_hit) = CERENKOV_SANE_RAW_ADC(ceradc_num(ceradc_hit))-cer_sane_ped_mean(ceradc_num(ceradc_hit))
+ call NANcheck(ceradc_hit,CERENKOV_SANE_ID2)
+ call NANcheck(ceradc_num(ceradc_hit),CERENKOV_SANE_ID2)
+ call NANcheck(cer_adc(ceradc_hit),CERENKOV_SANE_ID2)
+ call HFILL(10112,float(ceradc_num(ceradc_hit)),float(cer_adc(ceradc_hit)), 1.)
+ endif
+ enddo
+ccccccccc END Cherenkov
+c write(*,*)'Cer sane done'
+
+ x1t_hit = 0
+ do i=1,TRACKER_SANE_RAW_TOT_HITS_X
+ if(TRACKER_SANE_RAW_TDC_X(i).gt.0)then
+ x1t_hit = x1t_hit+1
+ if(x1t_hit.gt.300) go to 10
+ x1t_row(x1t_hit) = TRACKER_SANE_RAW_COUNTER_X(i)
+ call CORRECT_RAW_TIME_SANE(TRACKER_SANE_RAW_TDC_X(i),x1t_tdc(x1t_hit))
+ x1t_x(x1t_hit) = -12.32+0.37422*(x1t_row(x1t_hit)-1)
+
+c call HFILL(10100,float(x1t_row(x1t_hit)),float(x1t_tdc(x1t_hit)),1.)
+ call NANcheck(x1t_hit,TRACKER_SANE_X_ID)
+ call NANcheck(x1t_row(x1t_hit),TRACKER_SANE_X_ID)
+ call NANcheck(x1t_tdc(x1t_hit),TRACKER_SANE_X_ID)
+ endif
+ enddo
+ 10 CONTINUE
+
+ y1t_hit=0
+ y2t_hit=0
+c write(*,*)gen_event_ID_number,TRACKER_SANE_RAW_TOT_HITS_Y
+
+ do i=1,TRACKER_SANE_RAW_TOT_HITS_Y
+c write(*,*)'TDC, ', TRACKER_SANE_RAW_TDC_Y(i),TRACKER_SANE_RAW_COUNTER_Y(i)
+ if(TRACKER_SANE_RAW_TDC_Y(i).lt.67000.and.
+ , TRACKER_SANE_RAW_TDC_Y(i).gt.0)then
+ if(TRACKER_SANE_RAW_COUNTER_Y(i).lt.129)then
+ y1t_hit = y1t_hit + 1
+c write(*,*)'Tracker TDC', y1t_hit,TRACKER_SANE_RAW_TDC_Y(i)
+ if(y1t_hit.gt.300) go to 20
+ y1t_row(y1t_hit) = TRACKER_SANE_RAW_COUNTER_Y(i)
+ call CORRECT_RAW_TIME_SANE(TRACKER_SANE_RAW_TDC_Y(i),y1t_tdc(y1t_hit))
+ y1t_y(y1t_hit) = -22.225+(y1t_row(y1t_hit)-1)*0.35
+c call HFILL(10101,float(y1t_row(y1t_hit)),float(y1t_tdc(y1t_hit)),1.)
+ call NANcheck(y1t_hit,TRACKER_SANE_Y_ID)
+ call NANcheck(y1t_row(y1t_hit),TRACKER_SANE_Y_ID)
+ call NANcheck(y1t_tdc(y1t_hit),TRACKER_SANE_Y_ID)
+
+ else if(TRACKER_SANE_RAW_COUNTER_Y(i).lt.257)then
+ y2t_hit = y2t_hit + 1
+ if(y2t_hit.gt.300) go to 20
+ y2t_row(y2t_hit) = TRACKER_SANE_RAW_COUNTER_Y(i)-128
+ call CORRECT_RAW_TIME_SANE(TRACKER_SANE_RAW_TDC_Y(i),y2t_tdc(y2t_hit))
+ y2t_y(y2t_hit) = -22.4+(y2t_row(y2t_hit)-1)*0.35
+c call HFILL(10102,float(y2t_row(y2t_hit)),float(y2t_tdc(y2t_hit)),1.)
+ call NANcheck(y2t_hit,TRACKER_SANE_Y_ID)
+ call NANcheck(y2t_row(y2t_hit),TRACKER_SANE_Y_ID)
+ call NANcheck(y2t_tdc(y2t_hit),TRACKER_SANE_Y_ID)
+ endif
+ endif
+ 20 CONTINUE
+ enddo
+c write(*,*)'TRACK sane done'
+c do inum=1,nclust
+c enddo
+ hms_p = 0
+ if(HSNUM_FPTRACK.gt.0)then
+c write(*,*)HSNUM_FPTRACK,hsp,hstheta
+ hms_p = hsp
+ call NANcheckF(hms_p,4)
+ hms_e = hsenergy
+ call NANcheckF(hms_e,4)
+ hms_theta = hstheta
+ call NANcheckF(hms_theta,4)
+ hms_phi = hsphi
+ call NANcheckF(hms_phi,4)
+ hsxfp_s = hsx_fp
+ call NANcheckF(hsxfp_s,4)
+ hsyfp_s = hsy_fp
+ call NANcheckF(hsyfp_s,4)
+ hsxpfp_s = hsxp_fp
+ call NANcheckF(hsxpfp_s,4)
+ hsypfp_s = hsyp_fp
+ call NANcheckF(hsypfp_s,4)
+ hms_xtar = hsx_tar*100
+ call NANcheckF(hms_xtar,4)
+ hms_ytar = hsy_tar*100
+ call NANcheckF(hms_ytar,4)
+c write(*,*)hms_ytar,hsy_tar
+ hms_yptar = hsyp_tar
+ call NANcheckF(hms_yptar,4)
+ hms_xptar = hsxp_tar
+c write(*,*)hms_yptar,hms_xptar
+ call NANcheckF(hms_xptar,4)
+ hms_delta = hsdelta
+ call NANcheckF(hms_delta,4)
+ hms_start = hstart_time
+ call NANcheck(hms_start,4)
+ hsshtrk_s = HSTRACK_ET
+ call NANcheckF(hsshtrk_s,4)
+ hsshsum_s = hsshsum
+ call NANcheckF(hsshsum_s,4)
+ hsbeta_s = hsbeta
+ call NANcheckF(hsbeta_s,4)
+ hms_cer_npe1 = hcer_npe(1)
+ call NANcheckF(hms_cer_npe1,4)
+ hms_cer_npe2 = hcer_npe(2)
+ call NANcheckF(hms_cer_npe2,4)
+ hms_cer_adc1 = hcer_adc(1)
+ call NANcheckF(hms_cer_adc1,4)
+ hms_cer_adc2 = hcer_adc(2)
+ call NANcheckF(hms_cer_adc2,4)
+ call HFILL(10302,X_HMS,Y_HMS,1.)
+c if(nclust.eq.1)then
+ do i=1,nclust
+ call HFILL(10300,X_HMS,xclust(i)+Bigcal_SHIFT(1),1.)
+
+ call HFILL(10304,X_HMS-Xclust(i),Y_HMS-Yclust(i),1.)
+ call HFILL(10301,Y_HMS,Yclust(i)+Bigcal_SHIFT(2),1.)
+c write(*,*)Bigcal_SHIFT(1),Bigcal_SHIFT(2)
+ if(abs(X_HMS-xclust(i)-Bigcal_SHIFT(1)).lt.10.and.
+ , abs(Y_HMS-Yclust(i)-Bigcal_SHIFT(2)).lt.10)then
+c write(*,*)'Slow raster ',gsrx_calib,gsry_calib
+c write(*,*)'HMS raster ',hms_xtar,hms_ytar
+ call HFILL(10303,Xclust(i)+Bigcal_SHIFT(1),Yclust(i)+Bigcal_SHIFT(2),1.)
+ call HFILL(10310,hms_delta,hms_yptar ,1.)
+ call HFILL(10311,hms_delta,hms_xptar ,1.)
+ call HFILL(10312,dpel_hms,hms_yptar ,1.)
+ call HFILL(10313,dpel_hms,hms_xptar ,1.)
+ call HFILL(10315,dpel_hms,hms_ytar ,1.)
+ call HFILL(10314,dpel_hms,hms_xtar ,1.)
+ call HF1(10321,0.006*hms_delta+0.01-hms_yptar,1.)
+ P_e = hms_p
+ P_el(1) = p_e*sin(hms_theta)*cos(HMS_phi)
+ P_el(2) = p_e*sin(hms_theta)*sin(HMS_phi)
+ P_el(3) = p_e*cos(hms_theta)
+ P_el(4) = hms_e
+ ww2 = (GEBEAM+Mp-P_el(4))**2-
+ , (P_el(1)**2+p_el(2)**2+(GEBEAM-p_el(3))**2)
+c write(*,*)ww2
+ call HF1(10322,ww2,1.)
+ call HFILL(10323,ww2,hms_yptar,1.)
+ call HFILL(10324,ww2,hms_xtar,1.)
+
+ endif
+ enddo
+c endif
+
+ endif
+
+
+ rast_x = gfry_raw_adc
+ call NANcheckF(rast_x,3)
+ rast_y = gfrx_raw_adc
+ call NANcheckF(rast_y,3)
+ i_helicity = gbeam_helicity
+ call NANcheck(i_helicity,3)
+c if(sane_ntuple_type.eq.1)then
+ slow_rast_x = gsrx_calib
+ call NANcheckF(gsrx_raw_adc,3)
+ slow_rast_y = gsry_calib
+ call NANcheckF(gsry_raw_adc,3)
+c else
+c slow_rast_x = gsrx_raw_adc
+c call NANcheckF(gsrx_raw_adc,3)
+c slow_rast_y = gsry_raw_adc
+c call NANcheckF(gsry_raw_adc,3)
+
+c endif
+ call HFILL(10215,gsry_raw_adc,gsrx_raw_adc, 1.)
+
+ call HFILL(10216,gsrx_calib,gsry_calib, 1.)
+
+ if(HSNUM_FPTRACK.gt.0)then
+
+ call HFILL(10316,slow_rast_y,-hms_xtar ,1.)
+ call HFILL(10317,slow_rast_x,hms_ytar ,1.)
+ endif
+ call NANcheckF(gsry_raw_adc,3)
+ sem_x = -ntbpmx/10.
+ call NANcheckF(sem_x,3)
+ sem_y = ntbpmy/10.
+ call NANcheckF(sem_y,3)
+ call HFILL(10214,sem_x,sem_y, 1.)
+
+
+ n_clust = nclust
+ if ( n_clust .gt. 15) n_clust = 15
+ do i =1, n_clust
+
+ call Bigcal_Betta(i)
+ call PHYSICS_VARIABLES(i,Theta_e(i),Phi_e(i))
+c call Bigcal_Betta(i)
+
+ call tracker(i)
+ call TrackerCoordnate(i)
+ call GeometryMatch(i)
+ call Lucite(i)
+ do j=1, ncellclust(i)
+ call HFILL(10200,float(ixcell(j,i)),float(iycell(j,i)), 1.)
+ enddo
+c if(sane_ntuple_type.eq.1)then
+c n_clust = nclust
+c call Lucite(i)
+c endif
+ enddo
+c write(*,*)'Sane is Done'
+c
+
+ abort=.not.HEXIST(sane_ntuple_ID)
+ if(abort) then
+ call G_build_note(':Ntuple ID#$ does not exist',
+ $ '$',sane_ntuple_ID,' ',0.,' ',err)
+ call G_add_path(here,err)
+ else
+
+c Gamma1E,Gamma2E,dist,cosg1g2,Pg1(4),Pg2(4)
+ if(n_clust.eq.2.and.cer_h(1).eq.0.and.cer_h(2).eq.0.and.
+ , E_clust(1).gt.0.6.and.E_clust(2).gt.0.6.and.
+ , ncellclust(1).ge.6.and.ncellclust(2).ge.6)then
+ Pg1(4) = E_clust(1)
+ Pg2(4) = E_clust(2)
+ Pg1(1) = X_clust(1)/sqrt(X_clust(1)**2+(Y_clust(1)-slow_rast_y)**2+Z_clust(1)**2)
+ Pg1(2) = (Y_clust(1)-slow_rast_y)/sqrt(X_clust(1)**2+(Y_clust(1)-slow_rast_y)**2+Z_clust(1)**2)
+ Pg1(3) = Z_clust(1)/sqrt(X_clust(1)**2+(Y_clust(1)-slow_rast_y)**2+Z_clust(1)**2)
+
+ Pg2(1) = X_clust(2)/sqrt(X_clust(2)**2+(Y_clust(2)-slow_rast_y)**2+Z_clust(2)**2)
+ Pg2(2) = Y_clust(2)/sqrt(X_clust(2)**2+(Y_clust(2)-slow_rast_y)**2+Z_clust(2)**2)
+ Pg2(3) = Z_clust(2)/sqrt(X_clust(2)**2+(Y_clust(2)-slow_rast_y)**2+Z_clust(2)**2)
+
+ cosg1g2= (pg1(1)*pg2(1)+pg1(2)*pg2(2)+pg1(3)*pg2(3))/
+ , sqrt(pg1(1)**2+pg1(2)**2+pg1(3)**2)/
+ , sqrt(pg2(1)**2+pg2(2)**2+pg2(3)**2)
+ Pi0Mass = 2*pg1(4)*pg2(4)*(1-cosg1g2)
+ dist =sqrt((X_clust(1)-X_clust(2))**2+(Y_clust(1)-Y_clust(2))**2)
+
+
+ if(dist.gt.20.and.dist.lt.80)then
+ call HF1(10622,sqrt(Pi0Mass),1.)
+c write(*,*)1,sqrt(Pi0Mass)
+ endif
+
+ Pg1(1) = Pg1(4)*sin(Theta_e(1)*3.1415926536/180.)*cos(Phi_e(1)*3.1415926536/180.)
+ Pg1(2) = Pg1(4)*sin(Theta_e(1)*3.1415926536/180.)*sin(Phi_e(1)*3.1415926536/180.)
+ Pg1(3) = Pg1(4)*cos(Theta_e(1)*3.1415926536/180.)
+
+ Pg2(1) = Pg2(4)*sin(Theta_e(2)*3.1415926536/180.)*cos(Phi_e(2)*3.1415926536/180.)
+ Pg2(2) = Pg2(4)*sin(Theta_e(2)*3.1415926536/180.)*sin(Phi_e(2)*3.1415926536/180.)
+ Pg2(3) = Pg2(4)*cos(Theta_e(2)*3.1415926536/180.)
+c write(*,*)Pg1,sin(Theta_e(1)*3.14159/180.),cos(Phi_e(1)*3.1415926536/180.)
+c write(*,*)Pg2,Theta_e(2),Phi_e(2)
+c write(*,*)sqrt(pg1(1)**2+pg1(2)**2+pg1(3)**2)
+c write(*,*)sqrt(pg2(1)**2+pg2(2)**2+pg2(3)**2)
+ cosg1g2= (pg1(1)*pg2(1)+pg1(2)*pg2(2)+pg1(3)*pg2(3))/
+ , sqrt(pg1(1)**2+pg1(2)**2+pg1(3)**2)/
+ , sqrt(pg2(1)**2+pg2(2)**2+pg2(3)**2)
+
+ Pi0Mass = 2*pg1(4)*pg2(4)*(1-cosg1g2)
+ if(dist.gt.20.and.dist.lt.80)then
+ call HF1(10623,sqrt(Pi0Mass),1.)
+c write(*,*)'INTO 10623'
+c write(*,*)2,sqrt(Pi0Mass),Pi0Mass,cosg1g2
+ endif
+
+ endif
+c icycle=999999
+c write(*,*)sane_ntuple_segmentevents,gen_event_ID_number
+ if(sane_ntuple_type.lt.3 )then
+ if(sane_ntuple_max_segmentevents.gt.0) then
+ if(sane_ntuple_segmentevents.gt.sane_ntuple_max_segmentevents)then
+ call sane_ntup_change(ABORT,err)
+ sane_ntuple_segmentevents=0
+ else
+ sane_ntuple_segmentevents = sane_ntuple_segmentevents + 1
+ endif
+ endif
+ call HFNT(sane_ntuple_ID)
+ elseif (sane_ntuple_type.eq.3.and.
+ , ((nclust.eq.2.and.cer_h(1).eq.0.and.cer_h(2).eq.0).or.
+ , (nclust.eq.1.and.cer_h(1).eq.0.and.e_clust(1).gt.1.4).or.
+ , (nclust.eq.2.and.cer_h(1).gt.0.and.cer_h(2).gt.0)).or.
+ , nclust.eq.2
+ , )then
+ if(nclust.eq.2.and.cer_h(1).gt.0.and.cer_h(2).gt.0)nclust=20
+ if(nclust.eq.2.and.(cer_h(1).eq.0.or.cer_h(2).eq.0))nclust=21
+ if(nclust.eq.21.and.cer_h(1).eq.0.and.cer_h(2).eq.0)nclust=2
+ if(sane_ntuple_max_segmentevents.gt.0) then
+ if(sane_ntuple_segmentevents.gt.sane_ntuple_max_segmentevents)then
+ call sane_ntup_change(ABORT,err)
+ sane_ntuple_segmentevents=0
+ else
+ sane_ntuple_segmentevents = sane_ntuple_segmentevents + 2
+ endif
+ endif
+
+ call HFNT(sane_ntuple_ID)
+
+ endif
+
+ endif
+
+c endif
+
+ return
+ 18 write(*,*)'HELP charge error',charge2s,gbcm1_charge
+ return
+ 19 write(*,*)'HELP Polarization error'
+ return
+ end
+
+ SUBROUTINE CORRECT_RAW_TIME_SANE(RAW_TDC,CORRECTED_TDC)
+ IMPLICIT NONE
+ include 'sane_data_structures.cmn'
+ include 'f1trigger_data_structures.cmn'
+c
+c Function arguments are RAW_TDC -raw TDC value
+c and CORRECTED_TDC -Corrected by Trigger time and rolover time
+c MAKE SURE TO Include correct parameter files
+c
+c
+ integer*4 RAW_TDC, CORRECTED_TDC, f1trigmax
+ save
+
+c find largest value of trigger time, to check rollover
+ if(TRIGGER_F1_START_TDC_COUNTER(
+ > SANE_TRIGGER_COUNTER) .gt.f1trigmax) then
+ write(6,'('' SANE trigger time max='',i8)')
+ > TRIGGER_F1_START_TDC_COUNTER(
+ > SANE_TRIGGER_COUNTER)
+ f1trigmax =
+ > TRIGGER_F1_START_TDC_COUNTER(
+ > SANE_TRIGGER_COUNTER)
+ endif
+ if(RAW_TDC.gt.0)then
+ CORRECTED_TDC = RAW_TDC -
+ , TRIGGER_F1_START_TDC_COUNTER(SANE_TRIGGER_COUNTER)
+c
+c Taking care of ROLOVER For positive TDC
+c
+ if(CORRECTED_TDC.lt.-30000)
+ , CORRECTED_TDC = CORRECTED_TDC+TRIGGER_F1_ROLOVER(SANE_TRIGGER_COUNTER)
+ if(CORRECTED_TDC.gt.30000)
+ , CORRECTED_TDC = CORRECTED_TDC-TRIGGER_F1_ROLOVER(SANE_TRIGGER_COUNTER)
+ else
+ CORRECTED_TDC =0
+ endif
+
+ end
+
+ subroutine NANcheck(l,did)
+ IMPLICIT NONE
+ integer*4 l
+ integer did
+ if(l.ne.l)then
+ l=0
+c write(*,*)did
+ endif
+ end
+ subroutine NANcheckF(l,did)
+ IMPLICIT NONE
+ real*4 l
+ integer did
+ if(l.ne.l)then
+ l=0
+c write(*,*)did
+ endif
+ end
diff --git a/SANE/.cvsignore b/SANE/.cvsignore
new file mode 100644
index 0000000..971fea4
--- /dev/null
+++ b/SANE/.cvsignore
@@ -0,0 +1,3 @@
+O.*
+r_*.f
+r_sane_*.f
diff --git a/SANE/CVS/Entries b/SANE/CVS/Entries
new file mode 100644
index 0000000..618fb24
--- /dev/null
+++ b/SANE/CVS/Entries
@@ -0,0 +1,24 @@
+/.cvsignore/1.1.2.2/Wed Sep 2 13:47:23 2009//Tsane
+/Makefile/1.1.2.1/Wed May 7 18:13:53 2008//Tsane
+/Makefile.Unix/1.1.2.5/Fri Jun 25 21:44:34 2010//Tsane
+/sane_analyze_pedestal.f/1.1.2.1/Wed May 7 18:13:53 2008//Tsane
+/sane_calc_pedestal.f/1.1.2.1/Wed May 7 18:13:53 2008//Tsane
+/sane_clear_event.f/1.1.2.6/Fri Jun 25 21:46:31 2010//Tsane
+/sane_close_scalers.f/1.1.2.5/Mon Jun 28 13:30:39 2010//Tsane
+/sane_decode.f/1.1.2.5/Fri Jan 30 20:33:28 2009//Tsane
+/sane_dump_ntup_var.f/1.1.2.4/Mon Jan 23 22:10:02 2012//Tsane
+/sane_geometry_suplement.f/1.1.2.2/Sat Oct 11 15:39:22 2008//Tsane
+/sane_keep_results.f/1.1.2.10/Fri Jun 25 21:55:25 2010//Tsane
+/sane_n100xye.f/1.1.2.1/Fri Jun 25 21:45:19 2010//Tsane
+/sane_ntup_change.f/1.1.2.2/Fri Jan 16 18:48:01 2009//Tsane
+/sane_ntup_close.f/1.1.2.15/Mon Jul 12 18:56:48 2010//Tsane
+/sane_ntup_init.f/1.1.2.6/Tue Oct 27 19:28:03 2009//Tsane
+/sane_ntup_open.f/1.1.2.22/Mon Jul 12 18:59:09 2010//Tsane
+/sane_ntup_register.f/1.1.2.1/Wed May 7 18:13:54 2008//Tsane
+/sane_ntup_shutdown.f/1.1.2.1/Wed May 7 18:13:54 2008//Tsane
+/sane_ntuple_keep.f/1.1.2.27/Mon Jul 12 20:01:48 2010//Tsane
+/sane_physics.f/1.1.2.22/Fri Dec 17 23:01:19 2010//Tsane
+/sane_register_variables.f/1.1.2.1/Wed May 7 18:13:54 2008//Tsane
+/sane_reset_event.f/1.1.2.5/Mon Jun 28 13:26:02 2010//Tsane
+/sane_trgtrack.f/1.1.2.7/Tue Sep 15 20:38:46 2009//Tsane
+D
diff --git a/SANE/CVS/Repository b/SANE/CVS/Repository
new file mode 100644
index 0000000..ae5e6d7
--- /dev/null
+++ b/SANE/CVS/Repository
@@ -0,0 +1 @@
+Analyzer/SANE
diff --git a/SANE/CVS/Root b/SANE/CVS/Root
new file mode 100644
index 0000000..6288c3f
--- /dev/null
+++ b/SANE/CVS/Root
@@ -0,0 +1 @@
+whit@cvs.jlab.org:/group/hallc/cvsroot
diff --git a/SANE/CVS/Tag b/SANE/CVS/Tag
new file mode 100644
index 0000000..25d73f7
--- /dev/null
+++ b/SANE/CVS/Tag
@@ -0,0 +1 @@
+Tsane
diff --git a/SANE/Makefile b/SANE/Makefile
new file mode 100755
index 0000000..915cc93
--- /dev/null
+++ b/SANE/Makefile
@@ -0,0 +1,14 @@
+#
+# $Log: Makefile,v $
+# Revision 1.1.2.1 2008/05/07 18:13:53 bhovik
+# starting files
+#
+# Revision 1.1.2.1 2007/05/15 01:19:10 jones
+# Start to Bigcal code
+#
+# Revision 1.1 1998/12/08 14:33:24 saw
+# Initial Setup
+#
+ETC=../etc
+
+include $(ETC)/Makefile.NEW
diff --git a/SANE/Makefile.Unix b/SANE/Makefile.Unix
new file mode 100644
index 0000000..bb1a341
--- /dev/null
+++ b/SANE/Makefile.Unix
@@ -0,0 +1,60 @@
+NEWSTYLE=1
+include ../../etc/Makefile
+include ../../etc/Makefile.flags
+
+
+osources = sane_n100xye.f \
+ sane_analyze_pedestal.f sane_ntup_close.f sane_ntup_register.f \
+ sane_calc_pedestal.f sane_ntup_init.f sane_ntup_shutdown.f \
+ sane_clear_event.f sane_ntuple_keep.f sane_register_variables.f \
+ sane_keep_results.f sane_ntup_open.f sane_reset_event.f \
+ sane_decode.f sane_ntup_register.f sane_dump_ntup_var.f \
+ sane_ntup_change.f sane_physics.f sane_trgtrack.f \
+ sane_geometry_suplement.f sane_close_scalers.f
+
+makeregstuff = r_sane_data_structures.f r_sane_filenames.f r_sane_ntuple.f
+
+
+sources = $(osources) $(makeregstuff)
+
+libsources = $(sources)
+
+lib_targets := $(patsubst %.f, libsanetracking.a(%.o), $(libsources))
+install-dirs := lib
+bin_targets =
+
+#default:
+# @echo "nothing to make"
+
+ifdef NFSDIRECTORY
+../%.f : $(NFSDIRECTORY)/SANE/%.f
+ ln -s $< $@
+
+.PRECIOUS: ../%.f
+else
+#
+# Rule for making the register subroutines
+#
+../r_%.f : ../%.cmn $(MAKEREG)
+ (cd .. ; $(MAKEREG) $(<F) -o $(@F) -e /dev/null)
+
+.PRECIOUS: ../r_%.f
+endif
+
+#
+# Get include files from INCLUDE directory
+#
+
+%.cmn ../%.cmn:: ../../INCLUDE/%.cmn
+ $(CP) $< $@
+
+%.dec ../%.dec:: ../../INCLUDE/%.dec
+ $(CP) $< $@
+
+%.par ../%.par:: ../../INCLUDE/%.par
+ $(CP) $< $@
+
+%.dte ../%.dte:: ../../INCLUDE/%.dte
+ $(CP) $< $@
+
+include $(sources:.f=.d)
diff --git a/SANE/sane_analyze_pedestal.f b/SANE/sane_analyze_pedestal.f
new file mode 100644
index 0000000..34ab722
--- /dev/null
+++ b/SANE/sane_analyze_pedestal.f
@@ -0,0 +1,131 @@
+ subroutine sane_analyze_pedestal(ABORT,err)
+ implicit none
+ save
+
+ logical ABORT
+ character*(*) err
+ character*18 here
+ parameter (here='sane_analyze_pedestal')
+*
+ call lucite_sane_analyze_pedestal(ABORT,err) ! bigcal
+ if(ABORT) then
+ call G_add_path(here,err)
+ return
+ endif
+*
+ call cerenkov_sane_analyze_pedestal(ABORT,err) ! bigcal
+ if(ABORT) then
+ call G_add_path(here,err)
+ return
+ endif
+*
+
+ end
+
+*********************************************************************
+*********************************************************************
+
+ subroutine lucite_sane_analyze_pedestal(ABORT,err)
+ implicit none
+ save
+
+ logical ABORT
+ character*(*) err
+*
+ integer*4 ihit
+ integer*4 blk
+
+ INCLUDE 'sane_data_structures.cmn'
+
+
+*
+*
+* LUCITE CERENKOV PEDESTALS
+*
+*
+
+ do ihit = 1 , lucite_sane_raw_tot_hits
+ blk = lucite_sane_raw_counter_num(ihit)
+ luc_ped_limit_pos(blk)=1500
+ luc_ped_limit_neg(blk)=1500
+ CALL Analyze_PED(
+ & lucite_sane_raw_adc_neg(ihit),
+ & luc_ped_num_neg(blk),
+ & luc_ped_sum2_neg(blk),
+ & luc_ped_sum_neg(blk),
+ & luc_min_peds,
+ & luc_ped_limit_neg(blk)
+ & )
+c write(*,*)"RAW ADC",luc_raw_adc_neg(ihit)
+c write(*,*)"COUNTER",blk
+c write(*,*)"SUM",luc_ped_sum_neg(blk)
+
+ CALL Analyze_PED(
+ & lucite_sane_raw_adc_pos(ihit),
+ & luc_ped_num_pos(blk),
+ & luc_ped_sum2_pos(blk),
+ & luc_ped_sum_pos(blk),
+ & luc_min_peds,
+ & luc_ped_limit_pos(blk)
+ & )
+ enddo
+c write(*,*)'LUC SUM',luc_ped_sum_pos
+ end
+
+*********************************************************************
+*********************************************************************
+
+ subroutine cerenkov_sane_analyze_pedestal(ABORT,err)
+ implicit none
+ save
+
+ logical ABORT
+ character*(*) err
+*
+ integer*4 ihit
+ integer*4 blk
+
+ INCLUDE 'sane_data_structures.cmn'
+
+
+*
+*
+* cer_saneITE CERENKOV PEDESTALS
+*
+ do ihit = 1 , cerenkov_sane_raw_tot_hits
+ blk = cerenkov_sane_raw_counter_num(ihit)
+ cer_sane_ped_limit(blk)=10000
+ CALL Analyze_PED(
+ & cerenkov_sane_raw_adc(ihit),
+ & cer_sane_ped_num(blk),
+ & cer_sane_ped_sum2(blk),
+ & cer_sane_ped_sum(blk),
+ & cer_sane_min_peds,
+ & cer_sane_ped_limit(blk)
+ & )
+ enddo
+ end
+
+*********************************************************************
+*********************************************************************
+
+
+ Subroutine Analyze_PED(Raw,Ped,Sum2,Sum,PedMin,PedLimit)
+ implicit none
+ integer *4 RAW,PED,SUM2,SUM,PedMin,PedLimit
+
+ if (Raw .le. PedLimit) then
+
+ SUM2 = SUM2 + RAW*RAW
+ SUM = SUM + RAW
+
+ Ped = Ped + 1
+
+ if (Ped.eq.nint(PedMin/5.)) then
+ PedLimit = 100 + SUM/Ped
+ endif
+
+ endif
+
+
+ end
diff --git a/SANE/sane_calc_pedestal.f b/SANE/sane_calc_pedestal.f
new file mode 100644
index 0000000..e838714
--- /dev/null
+++ b/SANE/sane_calc_pedestal.f
@@ -0,0 +1,107 @@
+ SUBROUTINE sane_calc_pedestal(ABORT,err)
+ implicit none
+ save
+
+ logical ABORT
+ character*(*) err
+ character*18 here
+ parameter (here='sane_calc_pedestal')
+
+ call lucite_sane_calc_pedestal(ABORT,err)
+ if(ABORT) then
+ call G_add_path(here,err)
+ return
+ endif
+ call cerenkov_sane_calc_pedestal(ABORT,err)
+ if(ABORT) then
+ call G_add_path(here,err)
+ return
+ endif
+
+ end
+
+****************************************************************
+****************************************************************
+
+ Subroutine lucite_sane_calc_pedestal(ABORT,err)
+ implicit none
+ save
+
+ logical ABORT
+ character*(*) err
+*
+ integer*4 pmt
+ INCLUDE 'sane_data_structures.cmn'
+ luc_min_peds=7
+ do pmt = 1 , (LUCITE_SANE_MAX_COUNTER_NUM)
+ call Calc_Ped(
+ & luc_ped_num_pos(pmt),
+ & luc_min_peds,
+ & luc_ped_mean_pos(pmt),
+ & luc_ped_rms_pos(pmt),
+ & luc_ped_sum_pos(pmt),
+ & luc_ped_sum2_pos(pmt))
+c write(*,*)'NUM ',pmt,luc_ped_num_pos(pmt)
+c write(*,*)'Sum ',pmt, luc_ped_sum_pos(pmt)
+
+ call Calc_Ped(
+ & luc_ped_num_neg(pmt),
+ & luc_min_peds,
+ & luc_ped_mean_neg(pmt),
+ & luc_ped_rms_neg(pmt),
+ & luc_ped_sum_neg(pmt),
+ & luc_ped_sum2_neg(pmt))
+
+ luc_ped_threshold_neg(pmt) = luc_ped_mean_neg(pmt)
+ luc_ped_threshold_pos(pmt) = luc_ped_mean_pos(pmt)
+
+ enddo
+ end
+
+****************************************************************
+****************************************************************
+
+ Subroutine cerenkov_sane_calc_pedestal(ABORT,err)
+ implicit none
+ save
+
+ logical ABORT
+ character*(*) err
+*
+ integer*4 pmt
+ INCLUDE 'sane_data_structures.cmn'
+ cer_sane_min_peds=7
+ do pmt = 1 , (CERENKOV_SANE_MAX_CER_COUNTER)
+ call Calc_Ped(
+ & cer_sane_ped_num(pmt),
+ & cer_sane_min_peds,
+ & cer_sane_ped_mean(pmt),
+ & cer_sane_ped_rms(pmt),
+ & cer_sane_ped_sum(pmt),
+ & cer_sane_ped_sum2(pmt))
+c write(*,*)'NUM ',pmt,luc_ped_num_pos(pmt)
+c write(*,*)'Sum ',pmt, luc_ped_sum_pos(pmt)
+
+ cer_sane_ped_threshold(pmt) = cer_sane_ped_mean(pmt)
+
+ enddo
+
+ end
+
+****************************************************************
+****************************************************************
+
+ Subroutine Calc_Ped(Ped,PedMin,Mean,RMS,Sum,Sum2)
+ implicit none
+ save
+ integer*4 Ped, PedMin, Sum, Sum2
+ real*4 Mean, RMS, sig2
+ if (Ped .ge. PedMin .and. PedMin .ne. 0) then
+ Mean = Sum /float(Ped)
+ sig2 = float(SUM2)/float(Ped)-Mean**2
+ RMS = sqrt(max(0.,sig2))
+ endif
+
+ end
+
+
diff --git a/SANE/sane_clear_event.f b/SANE/sane_clear_event.f
new file mode 100644
index 0000000..47e41bc
--- /dev/null
+++ b/SANE/sane_clear_event.f
@@ -0,0 +1,148 @@
+ subroutine SANE_CLEAR_EVENT(ABORT,err)
+ IMPLICIT NONE
+ SAVE
+
+ character*13 here
+ parameter (here= 'sane_clear_event')
+
+ logical ABORT
+ character*(*) err
+
+ call lucite_sane_clear_event(ABORT,err)
+ call cerenkov_sane_clear_event(ABORT,err)
+ call tracker_sane_clear_event(ABORT,err)
+ call SANE_DUMP_NTUP_VAR()
+
+ end
+
+**********************************************************
+**********************************************************
+
+ SUBROUTINE lucite_sane_clear_event(ABORT,err)
+ IMPLICIT NONE
+ SAVE
+
+ INCLUDE 'sane_data_structures.cmn'
+ INCLUDE 'sane_ntuple.cmn'
+ character*13 here
+ parameter (here= 'lucite_sane_clear_event')
+
+ logical ABORT
+ character*(*) err
+ integer*4 i
+
+ LUCITE_SANE_RAW_TOT_HITS = 0
+ LUCITE_SANE_RAW_TOT_HITS2 = 0
+ LUCITE_SANE_RAW_TOT_HITS3 = 0
+c LUCITE_SANE_RAW_PLANE = 0
+
+ do i=1,LUCITE_SANE_MAX_HITS
+
+ LUCITE_SANE_RAW_COUNTER_NUM(i) = 0
+ LUCITE_SANE_RAW_COUNTER_NUM2(i) = 0
+ LUCITE_SANE_RAW_COUNTER_NUM3(i) = 0
+ LUCITE_SANE_RAW_ADC_POS(i) = 0
+ LUCITE_SANE_RAW_ADC_NEG(i) = 0
+ LUCITE_SANE_RAW_TDC_POS(i) = 0
+ LUCITE_SANE_RAW_TDC_NEG(i) = 0
+
+ enddo
+ do i=1,luc_hit
+ ltdc_pos(i) = 0
+ ltdc_neg(i) = 0
+ ladc_pos(i) = 0
+ ladc_neg(i) = 0
+ enddo
+
+ luc_hit = 0
+
+ ABORT= .FALSE.
+ err= ' '
+ RETURN
+ END
+
+**********************************************************
+**********************************************************
+
+ SUBROUTINE cerenkov_sane_clear_event(ABORT,err)
+ IMPLICIT NONE
+ SAVE
+
+ INCLUDE 'sane_data_structures.cmn'
+ INCLUDE 'sane_ntuple.cmn'
+ character*13 here
+ parameter (here= 'cerenkov_sane_clear_event')
+
+ logical ABORT
+ character*(*) err
+ integer*4 i
+
+ CERENKOV_SANE_RAW_TOT_HITS = 0
+ CERENKOV_SANE_RAW_TOT_HITS2 = 0
+c CERENKOV_SANE_RAW_PLANE = 0
+
+ do i=1,CERENKOV_SANE_MAX_HITS
+ CERENKOV_SANE_RAW_COUNTER_NUM(i) = 0
+ CERENKOV_SANE_RAW_COUNTER_NUM2(i) = 0
+ CERENKOV_SANE_RAW_ADC(i) = 0
+ CERENKOV_SANE_RAW_TDC(i) = 0
+ if(i.le.cer_hit)then
+ cer_tdc(i) = 0
+ cer_adcc(i) = 0
+ endif
+
+ enddo
+ cer_hit = 0
+
+
+ ABORT= .FALSE.
+ err= ' '
+ RETURN
+ END
+
+**********************************************************
+**********************************************************
+
+ SUBROUTINE tracker_sane_clear_event(ABORT,err)
+ IMPLICIT NONE
+ SAVE
+
+ character*50 here
+ parameter (here= 'tracker_sane_clear_event')
+
+ logical ABORT
+ character*(*) err
+
+ INCLUDE 'sane_data_structures.cmn'
+ INCLUDE 'sane_ntuple.cmn'
+ integer*4 i
+
+ TRACKER_SANE_RAW_TOT_HITS_Y = 0
+ TRACKER_SANE_RAW_TOT_HITS_X = 0
+c TRACKER_SANE_RAW_PLANE_Y = 0
+c TRACKER_SANE_RAW_PLANE_X = 0
+
+ do i=1,TRACKER_SANE_MAX_HITS
+ TRACKER_SANE_RAW_COUNTER_Y(i) = 0
+ TRACKER_SANE_RAW_COUNTER_X(i) = 0
+ TRACKER_SANE_RAW_TDC_Y(i) = 0
+ TRACKER_SANE_RAW_TDC_X(i) = 0
+ x1t_tdc(i) = 0
+ x1t_row(i) = -200
+ y1t_tdc(i) = 0
+ y1t_row(i) = -200
+ y2t_tdc(i) = 0
+ y2t_row(i) = -200
+ enddo
+ x1t_hit = 0
+ y1t_hit = 0
+ y2t_hit = 0
+
+ ABORT= .FALSE.
+ err= ' '
+ RETURN
+
+ end
+
+**********************************************************
+**********************************************************
diff --git a/SANE/sane_close_scalers.f b/SANE/sane_close_scalers.f
new file mode 100644
index 0000000..34ff0a0
--- /dev/null
+++ b/SANE/sane_close_scalers.f
@@ -0,0 +1,80 @@
+ subroutine sane_close_scalers()
+ IMPLICIT NONE
+ include 'b_ntuple.cmn'
+ include 'bigcal_data_structures.cmn'
+ include 'bigcal_tof_parms.cmn'
+ include 'hms_data_structures.cmn'
+ include 'bigcal_gain_parms.cmn'
+ include 'gen_event_info.cmn'
+ include 'gen_data_structures.cmn'
+ include 'gep_data_structures.cmn'
+ include 'sane_ntuple.cmn'
+ include 'sane_data_structures.cmn'
+ include 'sem_data_structures.cmn'
+ INCLUDE 'h_ntuple.cmn'
+ include 'f1trigger_data_structures.cmn'
+ include 'hms_calorimeter.cmn'
+ include 'gen_detectorids.par'
+ include 'gen_scalers.cmn'
+ include 'gen_run_info.cmn'
+
+ if(.not.charge_data_open)then
+ charge2s = gbcm1_charge-tcharge
+ tcharge = gbcm1_charge
+ charge2s_help = gbcm1_charge_help -tcharge_help
+ tcharge_help = gbcm1_charge_help
+ charge2s_helm = gbcm1_charge_helm -tcharge_helm
+ tcharge_helm = gbcm1_charge_helm
+c write(*,*)'MMM'
+c endif
+c if(.not.charge_data_open.and.gscaler_change(538).ne.hel_p_scaler)then
+c hel_p_scaler= gscaler_change(538)
+ hel_p_scaler= 0.985*gscaler_change(510)-gscaler_change(538)
+ hel_p_trig= g_hel_pos
+ dtime_p =1.
+ if(abs(hel_p_scaler).gt.0.0)then
+ dtime_p = float(g_hel_pos)/float(hel_p_scaler)
+ endif
+ call NANcheckF(dtime_p,0)
+ g_hel_pos =0
+c write(*,*)'MMM P'
+c endif
+c if(.not.charge_data_open.and.gscaler_change(546).ne.hel_n_scaler)then
+c hel_n_scaler= 0.985*gscaler_change(510)-gscaler_change(538)
+ hel_n_scaler=gscaler_change(538)
+ hel_n_trig= g_hel_neg
+ dtime_n=1.
+ if(abs(hel_n_scaler).gt.0.0)then
+ dtime_n =float(g_hel_neg)/float(hel_n_scaler)
+ endif
+ call NANcheckF(dtime_n,0)
+ g_hel_neg =0
+c write(*,*)'MMM N'
+ endif
+ write(*,*)'Writing Last SCALER'
+ if(.not.polarization_data_open)then
+ write(polarization_data_unit,*)gen_event_ID_number,polarea, polarization,half_plate
+ polarization_ch = .FALSE.
+ endif
+
+ if(.not.charge_data_open)then
+ write(charge_data_unit,*)
+ , gen_event_ID_number,charge2s,tcharge,
+ , tcharge_help,charge2s_help,
+ , tcharge_helm,charge2s_helm ,
+ , hel_p_scaler,hel_p_trig,dtime_p,
+ , hel_n_scaler,hel_n_trig,dtime_n
+
+ charge_ch = .FALSE.
+ endif
+c write(*,*)gen_event_ID_number,charge2s,tcharge,
+c , tcharge_help,charge2s_help,
+c , tcharge_helm,charge2s_helm ,
+c , hel_p_scaler,hel_p_trig,dtime_p,
+c , hel_n_scaler,hel_n_trig,dtime_n
+
+ close(polarization_data_unit)
+ close(charge_data_unit)
+
+
+ end
diff --git a/SANE/sane_decode.f b/SANE/sane_decode.f
new file mode 100644
index 0000000..e079d81
--- /dev/null
+++ b/SANE/sane_decode.f
@@ -0,0 +1,110 @@
+ subroutine sane_decode(pointer,lastslot, roc, bank,
+ & maxwords, did)
+
+
+*****************************************
+*****************************************
+
+ implicit none
+ integer*4 pointer,lastslot, roc, bank(*)
+ integer*4 maxwords, did
+ integer*4 g_decode_fb_detector ! Detector unpacking routine
+ include 'gen_detectorids.par'
+ include 'sane_data_structures.cmn'
+
+
+*****************************************
+*****************************************
+
+
+ if(did.eq.LUCITE_SANE_ID)then
+ pointer = pointer +
+ $ g_decode_fb_detector(lastslot, roc, bank(pointer),
+ & maxwords, did,
+ $ LUCITE_SANE_MAX_HITS,
+ $ LUCITE_SANE_RAW_TOT_HITS,
+ $ LUCITE_SANE_RAW_PLANE,
+ $ LUCITE_SANE_RAW_COUNTER_NUM, 2,
+ $ LUCITE_SANE_RAW_ADC_POS,
+ $ LUCITE_SANE_RAW_ADC_NEG,
+ $ 0,
+ $ 0)
+ else if(did.eq.LUCITE_SANE_ID2)then
+ pointer = pointer +
+ $ g_decode_fb_detector(lastslot, roc, bank(pointer),
+ & maxwords, did,
+ $ LUCITE_SANE_MAX_HITS,
+ $ LUCITE_SANE_RAW_TOT_HITS2,
+ $ LUCITE_SANE_RAW_PLANE2,
+ $ LUCITE_SANE_RAW_COUNTER_NUM2, 1,
+ $ LUCITE_SANE_RAW_TDC_POS,
+ $ 0,
+ $ 0,
+ $ 0)
+c write(*,*)'LUC TDC POS ',LUCITE_SANE_RAW_TDC_POS
+ else if(did.eq.LUCITE_SANE_ID3)then
+ pointer = pointer +
+ $ g_decode_fb_detector(lastslot, roc, bank(pointer),
+ & maxwords, did,
+ $ LUCITE_SANE_MAX_HITS,
+ $ LUCITE_SANE_RAW_TOT_HITS3,
+ $ LUCITE_SANE_RAW_PLANE3,
+ $ LUCITE_SANE_RAW_COUNTER_NUM3, 1,
+ $ LUCITE_SANE_RAW_TDC_NEG,
+ $ 0,
+ $ 0,
+ $ 0)
+c write(*,*)'LUC TDC NEG ',LUCITE_SANE_RAW_TDC_NEG
+ else if(did.eq.CERENKOV_SANE_ID)then
+c WRITE(*,*)'HITS = ',CERENKOV_SANE_RAW_TOT_HITS
+ pointer = pointer +
+ $ g_decode_fb_detector(lastslot, roc, bank(pointer),
+ $ maxwords, did,
+ $ CERENKOV_SANE_MAX_HITS,
+ $ CERENKOV_SANE_RAW_TOT_HITS,
+ $ CERENKOV_SANE_RAW_PLANE,
+ $ CERENKOV_SANE_RAW_COUNTER_NUM, 1,
+ $ CERENKOV_SANE_RAW_ADC,
+ $ 0, 0, 0)
+c WRITE(*,*)'cer ADC ',CERENKOV_SANE_RAW_ADC
+ else if(did.eq.CERENKOV_SANE_ID2)then
+
+ pointer = pointer +
+ $ g_decode_fb_detector(lastslot, roc, bank(pointer),
+ $ maxwords, did,
+ $ CERENKOV_SANE_MAX_HITS,
+ $ CERENKOV_SANE_RAW_TOT_HITS2,
+ $ CERENKOV_SANE_RAW_PLANE2,
+ $ CERENKOV_SANE_RAW_COUNTER_NUM2, 1,
+ $ CERENKOV_SANE_RAW_TDC,
+ $ 0, 0, 0)
+c WRITE(*,*)'HITS = ',CERENKOV_SANE_RAW_TOT_HITS2
+c WRITE(*,*)'cer tdc ',CERENKOV_SANE_RAW_TDC
+C WRITE(*,*)'cer ADC ',CERENKOV_SANE_RAW_ADC
+
+
+ else if(did.eq.TRACKER_SANE_X_ID)then
+ pointer = pointer +
+ $ g_decode_fb_detector(lastslot, roc, bank(pointer),
+ $ maxwords, did,
+ $ TRACKER_SANE_MAX_HITS,
+ $ TRACKER_SANE_RAW_TOT_HITS_X,
+ $ TRACKER_SANE_RAW_PLANE_X,
+ $ TRACKER_SANE_RAW_COUNTER_X, 1,
+ $ TRACKER_SANE_RAW_TDC_X,
+ $ 0, 0, 0)
+ else if(did.eq.TRACKER_SANE_Y_ID)then
+
+ pointer = pointer +
+ $ g_decode_fb_detector(lastslot, roc, bank(pointer),
+ $ maxwords, did,
+ $ TRACKER_SANE_MAX_HITS,
+ $ TRACKER_SANE_RAW_TOT_HITS_Y,
+ $ TRACKER_SANE_RAW_PLANE_Y,
+ $ TRACKER_SANE_RAW_COUNTER_Y, 1,
+ $ TRACKER_SANE_RAW_TDC_Y,
+ $ 0, 0, 0)
+
+ endif
+
+ end
diff --git a/SANE/sane_dump_ntup_var.f b/SANE/sane_dump_ntup_var.f
new file mode 100644
index 0000000..33164f9
--- /dev/null
+++ b/SANE/sane_dump_ntup_var.f
@@ -0,0 +1,114 @@
+ Subroutine SANE_DUMP_NTUP_VAR()
+ include 'b_ntuple.cmn'
+ include 'sane_ntuple.cmn'
+ integer i,j
+
+
+ nclust = 0
+ y1t_hit = 0
+ y2t_hit = 0
+ x1t_hit = 0
+ y3t_hit = 0
+ cer_hit = 0
+ luc_hit = 0
+ do i=1,TRACKER_MAX_HITS
+ y1t_row(i) = 0
+ y1t_tdc(i) = 0
+ y1t_y(i) = 0
+ y2t_row(i) = 0
+ y2t_tdc(i) = 0
+ y2t_y(i) = 0
+ y3t_row(i) = 0
+ y3t_tdc(i) = 0
+ y3t_y(i) = 0
+ x1t_row(i) = 0
+ x1t_tdc(i) = 0
+ x1t_x(i) = 0
+ enddo
+
+ do i=1,maxnclust
+ ncellclust(i) = 0
+ ncellbad(i) = 0
+ ncellx(i) = 0
+ ncelly(i) = 0
+ xmoment(i) = 0
+ ymoment(i) = 0
+ eclust(i) = 0
+ aclust(i) = 0
+ xclust(i) = 0
+ yclust(i) = 0
+
+ cer_num(i) = 0
+ cer_tdc(i) = 0
+ cer_adc(i) = 0
+
+ luc_row(i) = 0
+ ladc_pos(i) = 0
+ ladc_neg(i) = 0
+ ltdc_pos(i) = 0
+ ltdc_neg(i) = 0
+ luc_y(i) = 0
+
+ do j=1,maxncellclust
+ xcell(j,i) = 0
+ ycell(j,i) = 0
+ eblock(j,i) = 0
+ ablock(j,i) = 0
+ enddo
+ enddo
+ hms_p = 0
+ hms_e = 0
+ hms_theta = 0
+ hms_phi = 0
+ hms_ytar = 0
+ hms_yptar = 0
+ hms_xptar = 0
+ hms_delta = 0
+
+ do j=1,maxcl
+ E_clust(j) = 0
+ X_clust(j) = 0
+ Y_clust(j) = 0
+ Z_clust(j) = 0
+ X_clust_r(j) = 0
+ Y_clust_r(j) = 0
+ Z_clust_r(j) = 0
+ luc_h(j) = 0
+ trc_hx(j) = 0
+ trc_hy1(j) = 0
+ trc_hy2(j) = 0
+ do i=1,20
+ X_luc(i,j) = 0
+ Y_luc(i,j) = 0
+ Z_luc(i,j) = 0
+ X_luc_r(i,j) = 0
+ Y_luc_r(i,j) = 0
+ Z_luc_r(i,j) = 0
+ X_trc(i,j) = 0
+ Z_trc(i,j) = 0
+ Y1_trc(i,j) = 0
+ Z1_trc(i,j) = 0
+ Y2_trc(i,j) = 0
+ Z2_trc(i,j) = 0
+ enddo
+ do i=1,3
+ Tr_Vertex(i,j) = 0
+ Tr_Vertex_r(i,j) = 0
+ enddo
+ cer_h(j) = 0
+ cerb_time(j) = 0
+ cerb_adc(j) = 0
+ bigc_time(j) = 0
+ bigc_adc(j) = 0
+ Theta_e(j) = 0
+ Phi_e(j) = 0
+ Delta_Y(j) = 0
+ Delta_X(j) = 0
+ X_Bjorken(j) = 0
+ Q2(j) = 0
+ W2(j) = 0
+ ENue(j) = 0
+
+ enddo
+ return
+ end
diff --git a/SANE/sane_geometry_suplement.f b/SANE/sane_geometry_suplement.f
new file mode 100644
index 0000000..f86ef7d
--- /dev/null
+++ b/SANE/sane_geometry_suplement.f
@@ -0,0 +1,162 @@
+ subroutine Plane(P1,P2,P3,a,b,c,d)
+ IMPLICIT NONE
+c
+c Finds Plane constants a,b,c,d Using three points (P1,P2,P3)
+c
+
+ real*4 P1(3),P2(3),P3(3)
+ real*8 a,b,c,d
+
+
+ a = (p2(2)-p1(2))*(p3(3)-p1(3))-(p2(3)-p1(3))*(p3(2)-p1(2))
+ b = (p2(3)-p1(3))*(p3(1)-p1(1))-(p2(1)-p1(1))*(p3(3)-p1(3))
+ c = (p2(1)-p1(1))*(p3(2)-p1(2))-(p3(1)-p1(1))*(p2(2)-p1(2))
+ d = -p1(1)*a-p1(2)*b-p1(3)*c
+
+ end
+
+ccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+
+ subroutine PlaneV(P,DOT,a,b,c,d)
+ IMPLICIT NONE
+c
+c Finds Plane constants a,b,c,d Using normal vector to the plane (P)
+c and point on plane (DOT)
+c
+ real*8 P(3),DOT(3)
+ real*8 a,b,c,d
+ a = P(1)
+ b = P(2)
+ c = P(3)
+ d = -(P(1)*Dot(1)+P(2)*Dot(2)+P(3)*Dot(3))
+ end
+
+ccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+
+ subroutine Rotate(P,phi,th,psi,P1)
+ IMPLICIT NONE
+c iflag=1 -Rotate from P system to LAB
+c iflag=-1 -Rotate from LAB system to P
+ real*4 P(3),P1(3)
+ real*8 a(3,3)
+ real phi,th,psi
+ real pphi,pth,ppsi
+ integer i,j
+ pphi =phi
+ pth =th
+ ppsi =psi
+ if( abs(pphi).lt.0.002) pphi=0
+
+ if( abs(pth).le.0.002 ) pth=0
+
+ if( abs(ppsi).le.0.002 ) ppsi=0
+
+ a(1,1) = -sin(ppsi)*sin(pphi)+cos(pth)*cos(pphi)*cos(ppsi)
+ a(1,2) = -sin(ppsi)*cos(pphi)+cos(pth)*sin(pphi)*cos(ppsi)
+ a(1,3) = -sin(pth)*cos(ppsi)
+ a(2,1) = -sin(pphi)*cos(ppsi)-cos(pth)*cos(pphi)*sin(ppsi)
+ a(2,2) = cos(pphi)*cos(ppsi)-cos(pth)*sin(pphi)*sin(ppsi)
+ a(2,3) = sin(pth)*sin(ppsi)
+ a(3,1) = sin(pth)*cos(pphi)
+ a(3,2) = sin(pth)*sin(pphi)
+ a(3,3) = cos(pth)
+c write(*,"(3F10.3)")a
+ do 100 i=1,3
+ P1(i)=0
+ do 200 j=1,3
+ if(abs(a(i,j)).lt.1e-7)a(i,j)=0
+c write(*,*)P1(i),a(i,j)
+ P1(i)=P1(i)+a(i,j)*P(j)
+ 200 continue
+ if(abs(P1(i)).lt.1e-3)P1(i)=0.
+ 100 continue
+ end
+
+cccccccccccccccccccccccccccccccccccccccccccccccccccc
+
+ subroutine EqVector(V1,V2)
+ real*8 V1(6),V2(6)
+ integer i
+ do i=1,6
+ V2(i)=V1(i)
+ enddo
+ end
+
+ccccccccccccccccccccccccccccccccccccccccccccccccccccc
+
+ subroutine sub6vec(V1,V2,V3)
+ IMPLICIT NONE
+ real*8 V1(6),V2(6),V3(6)
+ integer i
+
+ do i=1,3
+ v3(i)=V1(i)-V2(i)
+ enddo
+ end
+
+ccccccccccccccccccccccccccccccccccccccccccccccccccccc
+
+ subroutine val6vec(V,val)
+ IMPLICIT NONE
+c
+c finds the distance from origin for 6 Vector
+c
+ real*8 V(6),val
+ val = sqrt(V(1)**2+V(2)**2+V(3)**2)
+ end
+
+cccccccccccccccccccccccccccccccccccccccccccccccccccc
+
+ subroutine mom6vec(V,val)
+ IMPLICIT NONE
+c
+c finds momentum of 6 vector
+c
+ real*8 V(6),val
+ val = sqrt(V(4)**2+V(5)**2+V(6)**2)
+ end
+
+c
+ccccccccccccccccccccccccccccccccccccccccc
+ subroutine CalcMomComp(xluc,yluc,zluc,xbig,ybig,zbig,px,py,pz,E,pM)
+ IMPLICIT NONE
+ real*4 xluc,yluc,zluc,xbig,ybig,zbig,px,py,pz
+ real*4 dist,E,pM
+ dist = sqrt((xluc-xbig)**2+(yluc-ybig)**2+(zluc-zbig)**2)
+ px = sqrt(E**2-pm**2)*(xluc-xbig)/dist
+ py = sqrt(E**2-pm**2)*(yluc-ybig)/dist
+ pz = sqrt(E**2-pm**2)*(zluc-zbig)/dist
+
+ end
+ccccccccccccccccccccccccccccc
+ subroutine PlaneLineIntersection(a,b,c,d,P1,P2,P_i)
+ IMPLICIT NONE
+c
+c Calculates intersection point of plane with line
+c a,b,c,d- are plane parameters
+c P1, and P2 are points of Lane
+c P_i -intersection poin
+c
+ real*8 a,b,c,d
+ real*4 P1(3),P2(3),P_i(3)
+ real*4 u
+ if((a*(P1(1)-P2(1))+b*(P1(2)-P2(2))+c*(P1(3)-P2(3))).ne.0)then
+
+ u = ( a*P1(1) + b*P1(2) + c*P1(3) + d )/
+ , ( a*(P1(1)-P2(1)) + b*(P1(2)-P2(2)) + c*(P1(3)-P2(3)) )
+
+ P_i(1)=(P2(1)-P1(1))*u+P1(1)
+
+ P_i(2)=(P2(2)-P1(2))*u+P1(2)
+
+ P_i(3)=(P2(3)-P1(3))*u+P1(3)
+
+C write(*,*)P_i
+
+ else
+ P_i(1)=0
+ P_i(2)=0
+ P_i(3)=0
+ write(*,*)'Line is paralel to plane'
+ endif
+ end
diff --git a/SANE/sane_keep_results.f b/SANE/sane_keep_results.f
new file mode 100644
index 0000000..5a97745
--- /dev/null
+++ b/SANE/sane_keep_results.f
@@ -0,0 +1,56 @@
+
+ subroutine sane_keep_results(ABORT,err)
+
+ implicit none
+ save
+
+ include 'bigcal_data_structures.cmn'
+ include 'sane_data_structures.cmn'
+ include 'b_ntuple.cmn'
+ include 'sane_ntuple.cmn'
+ include 'gen_event_info.cmn'
+ include 'hms_data_structures.cmn'
+
+
+ character*14 here
+ parameter(here='sane_keep_results')
+
+ logical abort
+ character*(*) err
+
+ abort=.false.
+ err=' '
+
+c check whether there is a cluster.
+c if there is a cluster, then keep the ntuple
+
+c$$$ if(BIGCAL_PROT_NCLSTR.gt.0.or.BIGCAL_RCS_NCLSTR.gt.0.or.
+c$$$ $ BIGCAL_MID_NCLSTR.gt.0) then
+c$$$ call b_ntuple_keep(ABORT,err)
+c$$$ endif
+c write(*,*)nclust
+! if (gen_event_type .eq. 4) return
+ if(sane_ntuple_type.gt.0)then
+! if((bigcal_all_nclstr.gt.0.or.gen_event_type .eq. 8
+! , .or.HSNUM_FPTRACK.gt.0)
+! , ) then
+ call SANE_DUMP_NTUP_VAR()
+ call b_ntuple_keep(ABORT,err,.false.)
+
+ call sane_ntuple_keep(ABORT,err)
+ call SANE_DUMP_NTUP_VAR()
+
+c call B_reset_event(ABORT,err)
+ bigcal_all_nclstr=0
+ bigcal_nmaxima=0
+! endif
+ endif
+
+ if(abort) then
+ call G_add_path(here,err)
+ else
+ err=' '
+ endif
+
+ return
+ end
diff --git a/SANE/sane_n100xye.f b/SANE/sane_n100xye.f
new file mode 100644
index 0000000..fd8235b
--- /dev/null
+++ b/SANE/sane_n100xye.f
@@ -0,0 +1,2767 @@
+ subroutine NueralParam(i,ixmax,iymax,jmax,etot,
+ , XX,YY,Eyx)
+ IMPLICIT NONE
+ include 'bigcal_data_structures.cmn'
+ include 'sane_data_structures.cmn'
+ include 'b_ntuple.cmn'
+ include 'sane_ntuple.cmn'
+ include 'gen_data_structures.cmn'
+ include 'gen_event_info.cmn'
+
+ real xmomsqr,xmom,xmomsq,ymomsqr,ymom,ymomsq
+ integer jmax
+ real emax
+
+ real eyx(5,5),XX(5,5),YY(5,5),en,Emt,Etot9,Etot
+ integer ixmax, iymax,jj,i,ii
+ real Xmomf
+
+ do ii=1,5
+
+ do jj=1,5
+ eyx(ii,jj)=0
+ xx(ii,jj)=0
+ yy(ii,jj)=0
+ enddo
+ enddo
+
+ emax=0
+ do jj=1,ncellclust(i)
+ en = eblock(jj,i)
+ if(en.gt.emax)then
+ emax = en
+ ixmax = ixcell(jj,i)
+ iymax = iycell(jj,i)
+ jmax = jj
+ endif
+ enddo
+
+ etot =0
+ do jj=1,ncellclust(i)
+ en = eblock(jj,i)
+ if(en.gt.0.01.and.En.eq.En)then
+
+ if(iycell(jj,i).lt.33.and.
+ , iycell(jj,i).gt.0.and.ixcell(jj,i).gt.0.and.
+ , ixcell(jj,i).lt.33.and.
+ , iycell(jj,i)-iymax+3.gt.0.and.
+ , iycell(jj,i)-iymax+3.lt.6.and.
+ , ixcell(jj,i)-ixmax+3.gt.0.and.
+ , ixcell(jj,i)-ixmax+3.lt.6
+ , )then
+ Eyx(iycell(jj,i)-iymax+3,ixcell(jj,i)-ixmax+3)=en
+ XX(iycell(jj,i)-iymax+3,ixcell(jj,i)-ixmax+3)=xcell(jj,i)
+ YY(iycell(jj,i)-iymax+3,ixcell(jj,i)-ixmax+3)=ycell(jj,i)
+ elseif(iycell(jj,i).lt.57.and.iycell(jj,i).gt.32.and.
+ , ixcell(jj,i).gt.0.and.ixcell(jj,i).lt.31.and.
+ , iycell(jj,i)-iymax+3.gt.0.and.
+ , iycell(jj,i)-iymax+3.lt.6.and.
+ , ixcell(jj,i)-ixmax+3.gt.0.and.
+ , ixcell(jj,i)-ixmax+3.lt.6
+ , )then
+
+ Eyx(iycell(jj,i)-iymax+3,ixcell(jj,i)-ixmax+3)=en
+ XX(iycell(jj,i)-iymax+3,ixcell(jj,i)-ixmax+3)=xcell(jj,i)
+ YY(iycell(jj,i)-iymax+3,ixcell(jj,i)-ixmax+3)=ycell(jj,i)
+ endif
+ endif
+ enddo
+ etot =eyx(1,1)+eyx(1,2)+eyx(1,3)+eyx(1,4)+eyx(1,5)+
+ , eyx(2,1)+eyx(2,2)+eyx(2,3)+eyx(2,4)+eyx(2,5)+
+ , eyx(3,1)+eyx(3,2)+eyx(3,3)+eyx(3,4)+eyx(3,5)+
+ , eyx(4,1)+eyx(4,2)+eyx(4,3)+eyx(4,4)+eyx(4,5)+
+ , eyx(5,1)+eyx(5,2)+eyx(5,3)+eyx(5,4)+eyx(5,5)
+
+
+ end
+
+
+ double precision function sane_n100xye(x, index)
+ implicit double precision (a-h,n-z)
+ double precision x(27),etot
+ integer i
+
+C --- Last Layer
+ etot=0
+ do i=1,25
+ if(x(i).gt.0.01)then
+ etot=etot+x(i)
+ endif
+ enddo
+ if (index.eq.0) then
+ sane_n100xye=neuron0x8ba5c78(x)
+ else if (index.eq.1) then
+ sane_n100xye=neuron0x8ba83b0(x)
+ else if (index.eq.2) then
+ if(x(27).lt.2.or.x(27).gt.55)then
+ sane_n100xye=neuron0x8ba8718(x)+
+ , 0.8*exp(-10*etot)+0.18*etot-0.07
+ else
+ sane_n100xye=neuron0x8ba8718(x)-(0.11-0.11/3.7*etot)
+ endif
+ if(x(26).lt.2) sane_n100xye= sane_n100xye+
+ , exp(-10*etot)+0.12*etot
+
+ if(x(26).gt.31)sane_n100xye= sane_n100xye+
+ , exp(-10*etot)+0.08*etot
+ if(x(26).gt.29.and.x(27).gt.32)sane_n100xye= sane_n100xye+
+ , exp(-10*etot)+0.12*etot
+
+ else
+ sane_n100xye=0.d0
+ endif
+ end
+C --- First and Hidden layers
+ double precision function neuron0x8b9f9f0(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ neuron0x8b9f9f0 = (x(1) - 0d0)/1d0
+ end
+ double precision function neuron0x8b9fb80(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ neuron0x8b9fb80 = (x(2) - 0d0)/1d0
+ end
+ double precision function neuron0x8b9fd58(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ neuron0x8b9fd58 = (x(3) - 0d0)/1d0
+ end
+ double precision function neuron0x8b9ff30(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ neuron0x8b9ff30 = (x(4) - 0d0)/1d0
+ end
+ double precision function neuron0x8ba0108(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ neuron0x8ba0108 = (x(5) - 0d0)/1d0
+ end
+ double precision function neuron0x8ba02e0(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ neuron0x8ba02e0 = (x(6) - 0d0)/1d0
+ end
+ double precision function neuron0x8ba04b8(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ neuron0x8ba04b8 = (x(7) - 0d0)/1d0
+ end
+ double precision function neuron0x8ba06a8(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ neuron0x8ba06a8 = (x(8) - 0d0)/1d0
+ end
+ double precision function neuron0x8ba0898(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ neuron0x8ba0898 = (x(9) - 0d0)/1d0
+ end
+ double precision function neuron0x8ba0a88(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ neuron0x8ba0a88 = (x(10) - 0d0)/1d0
+ end
+ double precision function neuron0x8ba0c78(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ neuron0x8ba0c78 = (x(11) - 0d0)/1d0
+ end
+ double precision function neuron0x8ba0e68(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ neuron0x8ba0e68 = (x(12) - 0d0)/1d0
+ end
+ double precision function neuron0x8ba1058(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ neuron0x8ba1058 = (x(13) - 0d0)/1d0
+ end
+ double precision function neuron0x8ba1248(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ neuron0x8ba1248 = (x(14) - 0d0)/1d0
+ end
+ double precision function neuron0x8ba1438(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ neuron0x8ba1438 = (x(15) - 0d0)/1d0
+ end
+ double precision function neuron0x8ba1628(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ neuron0x8ba1628 = (x(16) - 0d0)/1d0
+ end
+ double precision function neuron0x8ba1818(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ neuron0x8ba1818 = (x(17) - 0d0)/1d0
+ end
+ double precision function neuron0x8ba1b18(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ neuron0x8ba1b18 = (x(18) - 0d0)/1d0
+ end
+ double precision function neuron0x8ba1d08(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ neuron0x8ba1d08 = (x(19) - 0d0)/1d0
+ end
+ double precision function neuron0x8ba1ef8(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ neuron0x8ba1ef8 = (x(20) - 0d0)/1d0
+ end
+ double precision function neuron0x8ba20e8(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ neuron0x8ba20e8 = (x(21) - 0d0)/1d0
+ end
+ double precision function neuron0x8ba22d8(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ neuron0x8ba22d8 = (x(22) - 0d0)/1d0
+ end
+ double precision function neuron0x8ba24c8(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ neuron0x8ba24c8 = (x(23) - 0d0)/1d0
+ end
+ double precision function neuron0x8ba26b8(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ neuron0x8ba26b8 = (x(24) - 0d0)/1d0
+ end
+ double precision function neuron0x8ba28a8(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ neuron0x8ba28a8 = (x(25) - 0d0)/1d0
+ end
+ double precision function neuron0x8ba2a98(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ neuron0x8ba2a98 = (x(26) - 0d0)/1d0
+ end
+ double precision function neuron0x8ba2c88(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ neuron0x8ba2c88 = (x(27) - 0d0)/1d0
+ end
+ double precision function neuron0x8ba2f98(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ neuron0x8ba2f98 = -0.747233d0
+ neuron0x8ba2f98 = neuron0x8ba2f98 + synapse0x8b81ae8(x)
+ neuron0x8ba2f98 = neuron0x8ba2f98 + synapse0x89c73b8(x)
+ neuron0x8ba2f98 = neuron0x8ba2f98 + synapse0x8ba3170(x)
+ neuron0x8ba2f98 = neuron0x8ba2f98 + synapse0x8ba3198(x)
+ neuron0x8ba2f98 = neuron0x8ba2f98 + synapse0x8ba31c0(x)
+ neuron0x8ba2f98 = neuron0x8ba2f98 + synapse0x8ba31e8(x)
+ neuron0x8ba2f98 = neuron0x8ba2f98 + synapse0x8ba3210(x)
+ neuron0x8ba2f98 = neuron0x8ba2f98 + synapse0x8ba3238(x)
+ neuron0x8ba2f98 = neuron0x8ba2f98 + synapse0x8ba3260(x)
+ neuron0x8ba2f98 = neuron0x8ba2f98 + synapse0x8ba3288(x)
+ neuron0x8ba2f98 = neuron0x8ba2f98 + synapse0x8ba32b0(x)
+ neuron0x8ba2f98 = neuron0x8ba2f98 + synapse0x8ba32d8(x)
+ neuron0x8ba2f98 = neuron0x8ba2f98 + synapse0x8ba3300(x)
+ neuron0x8ba2f98 = neuron0x8ba2f98 + synapse0x8ba3328(x)
+ neuron0x8ba2f98 = neuron0x8ba2f98 + synapse0x8ba3350(x)
+ neuron0x8ba2f98 = neuron0x8ba2f98 + synapse0x8ba3378(x)
+ neuron0x8ba2f98 = neuron0x8ba2f98 + synapse0x8ba33a0(x)
+ neuron0x8ba2f98 = neuron0x8ba2f98 + synapse0x8ba3450(x)
+ neuron0x8ba2f98 = neuron0x8ba2f98 + synapse0x8ba3478(x)
+ neuron0x8ba2f98 = neuron0x8ba2f98 + synapse0x8ba34a0(x)
+ neuron0x8ba2f98 = neuron0x8ba2f98 + synapse0x8ba34c8(x)
+ neuron0x8ba2f98 = neuron0x8ba2f98 + synapse0x8ba34f0(x)
+ neuron0x8ba2f98 = neuron0x8ba2f98 + synapse0x8ba3518(x)
+ neuron0x8ba2f98 = neuron0x8ba2f98 + synapse0x8ba3540(x)
+ neuron0x8ba2f98 = neuron0x8ba2f98 + synapse0x8ba3568(x)
+ neuron0x8ba2f98 = neuron0x8ba2f98 + synapse0x8ba3590(x)
+ neuron0x8ba2f98 = neuron0x8ba2f98 + synapse0x8ba35b8(x)
+ neuron0x8ba2f98= (exp(-neuron0x8ba2f98*neuron0x8ba2f98))
+ end
+ double precision function neuron0x8ba35e0(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ neuron0x8ba35e0 = 0.400749d0
+ neuron0x8ba35e0 = neuron0x8ba35e0 + synapse0x89d14d0(x)
+ neuron0x8ba35e0 = neuron0x8ba35e0 + synapse0x89d14f8(x)
+ neuron0x8ba35e0 = neuron0x8ba35e0 + synapse0x8ba4788(x)
+ neuron0x8ba35e0 = neuron0x8ba35e0 + synapse0x8ba47b0(x)
+ neuron0x8ba35e0 = neuron0x8ba35e0 + synapse0x8ba47d8(x)
+ neuron0x8ba35e0 = neuron0x8ba35e0 + synapse0x8ba4800(x)
+ neuron0x8ba35e0 = neuron0x8ba35e0 + synapse0x8ba33c8(x)
+ neuron0x8ba35e0 = neuron0x8ba35e0 + synapse0x8ba33f0(x)
+ neuron0x8ba35e0 = neuron0x8ba35e0 + synapse0x8ba3418(x)
+ neuron0x8ba35e0 = neuron0x8ba35e0 + synapse0x8ba4930(x)
+ neuron0x8ba35e0 = neuron0x8ba35e0 + synapse0x8ba4958(x)
+ neuron0x8ba35e0 = neuron0x8ba35e0 + synapse0x8ba4980(x)
+ neuron0x8ba35e0 = neuron0x8ba35e0 + synapse0x8ba49a8(x)
+ neuron0x8ba35e0 = neuron0x8ba35e0 + synapse0x8ba49d0(x)
+ neuron0x8ba35e0 = neuron0x8ba35e0 + synapse0x8ba49f8(x)
+ neuron0x8ba35e0 = neuron0x8ba35e0 + synapse0x8ba4a20(x)
+ neuron0x8ba35e0 = neuron0x8ba35e0 + synapse0x8ba4ad0(x)
+ neuron0x8ba35e0 = neuron0x8ba35e0 + synapse0x8ba4af8(x)
+ neuron0x8ba35e0 = neuron0x8ba35e0 + synapse0x8ba4b20(x)
+ neuron0x8ba35e0 = neuron0x8ba35e0 + synapse0x8ba4b48(x)
+ neuron0x8ba35e0 = neuron0x8ba35e0 + synapse0x8ba4b70(x)
+ neuron0x8ba35e0 = neuron0x8ba35e0 + synapse0x8ba4b98(x)
+ neuron0x8ba35e0 = neuron0x8ba35e0 + synapse0x8ba4bc0(x)
+ neuron0x8ba35e0 = neuron0x8ba35e0 + synapse0x8ba4be8(x)
+ neuron0x8ba35e0 = neuron0x8ba35e0 + synapse0x8ba4c10(x)
+ neuron0x8ba35e0 = neuron0x8ba35e0 + synapse0x8ba4c38(x)
+ neuron0x8ba35e0 = neuron0x8ba35e0 + synapse0x8ba4c60(x)
+ neuron0x8ba35e0= (exp(-neuron0x8ba35e0*neuron0x8ba35e0))
+ end
+ double precision function neuron0x8ba4c88(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ neuron0x8ba4c88 = -0.299935d0
+ neuron0x8ba4c88 = neuron0x8ba4c88 + synapse0x8ba4e38(x)
+ neuron0x8ba4c88 = neuron0x8ba4c88 + synapse0x8ba4e60(x)
+ neuron0x8ba4c88 = neuron0x8ba4c88 + synapse0x8ba4e88(x)
+ neuron0x8ba4c88 = neuron0x8ba4c88 + synapse0x8ba4eb0(x)
+ neuron0x8ba4c88 = neuron0x8ba4c88 + synapse0x8ba4ed8(x)
+ neuron0x8ba4c88 = neuron0x8ba4c88 + synapse0x8ba4f00(x)
+ neuron0x8ba4c88 = neuron0x8ba4c88 + synapse0x8ba4f28(x)
+ neuron0x8ba4c88 = neuron0x8ba4c88 + synapse0x8ba4f50(x)
+ neuron0x8ba4c88 = neuron0x8ba4c88 + synapse0x8ba4f78(x)
+ neuron0x8ba4c88 = neuron0x8ba4c88 + synapse0x8ba4fa0(x)
+ neuron0x8ba4c88 = neuron0x8ba4c88 + synapse0x8ba4fc8(x)
+ neuron0x8ba4c88 = neuron0x8ba4c88 + synapse0x89c7788(x)
+ neuron0x8ba4c88 = neuron0x8ba4c88 + synapse0x89c7348(x)
+ neuron0x8ba4c88 = neuron0x8ba4c88 + synapse0x89c7370(x)
+ neuron0x8ba4c88 = neuron0x8ba4c88 + synapse0x89c7540(x)
+ neuron0x8ba4c88 = neuron0x8ba4c88 + synapse0x89c7568(x)
+ neuron0x8ba4c88 = neuron0x8ba4c88 + synapse0x8ba48b0(x)
+ neuron0x8ba4c88 = neuron0x8ba4c88 + synapse0x8ba48d8(x)
+ neuron0x8ba4c88 = neuron0x8ba4c88 + synapse0x8ba4900(x)
+ neuron0x8ba4c88 = neuron0x8ba4c88 + synapse0x8b7dca8(x)
+ neuron0x8ba4c88 = neuron0x8ba4c88 + synapse0x8b7dcd0(x)
+ neuron0x8ba4c88 = neuron0x8ba4c88 + synapse0x89c7a08(x)
+ neuron0x8ba4c88 = neuron0x8ba4c88 + synapse0x89c7a30(x)
+ neuron0x8ba4c88 = neuron0x8ba4c88 + synapse0x89c7a58(x)
+ neuron0x8ba4c88 = neuron0x8ba4c88 + synapse0x89c7a80(x)
+ neuron0x8ba4c88 = neuron0x8ba4c88 + synapse0x89c7aa8(x)
+ neuron0x8ba4c88 = neuron0x8ba4c88 + synapse0x89c7ad0(x)
+ neuron0x8ba4c88= (exp(-neuron0x8ba4c88*neuron0x8ba4c88))
+ end
+ double precision function neuron0x89c7bb8(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ neuron0x89c7bb8 = -0.0871005d0
+ neuron0x89c7bb8 = neuron0x89c7bb8 + synapse0x89c7af8(x)
+ neuron0x89c7bb8 = neuron0x89c7bb8 + synapse0x8ba4ff0(x)
+ neuron0x89c7bb8 = neuron0x89c7bb8 + synapse0x8ba5018(x)
+ neuron0x89c7bb8 = neuron0x89c7bb8 + synapse0x8ba5040(x)
+ neuron0x89c7bb8 = neuron0x89c7bb8 + synapse0x8ba5068(x)
+ neuron0x89c7bb8 = neuron0x89c7bb8 + synapse0x8ba5090(x)
+ neuron0x89c7bb8 = neuron0x89c7bb8 + synapse0x8ba50b8(x)
+ neuron0x89c7bb8 = neuron0x89c7bb8 + synapse0x8ba50e0(x)
+ neuron0x89c7bb8 = neuron0x89c7bb8 + synapse0x8ba5108(x)
+ neuron0x89c7bb8 = neuron0x89c7bb8 + synapse0x8ba5130(x)
+ neuron0x89c7bb8 = neuron0x89c7bb8 + synapse0x8ba5158(x)
+ neuron0x89c7bb8 = neuron0x89c7bb8 + synapse0x8ba5180(x)
+ neuron0x89c7bb8 = neuron0x89c7bb8 + synapse0x8ba51a8(x)
+ neuron0x89c7bb8 = neuron0x89c7bb8 + synapse0x8ba51d0(x)
+ neuron0x89c7bb8 = neuron0x89c7bb8 + synapse0x8ba51f8(x)
+ neuron0x89c7bb8 = neuron0x89c7bb8 + synapse0x8ba5220(x)
+ neuron0x89c7bb8 = neuron0x89c7bb8 + synapse0x8ba52d0(x)
+ neuron0x89c7bb8 = neuron0x89c7bb8 + synapse0x8ba52f8(x)
+ neuron0x89c7bb8 = neuron0x89c7bb8 + synapse0x8ba5320(x)
+ neuron0x89c7bb8 = neuron0x89c7bb8 + synapse0x8ba5348(x)
+ neuron0x89c7bb8 = neuron0x89c7bb8 + synapse0x8ba5370(x)
+ neuron0x89c7bb8 = neuron0x89c7bb8 + synapse0x8ba5398(x)
+ neuron0x89c7bb8 = neuron0x89c7bb8 + synapse0x8ba53c0(x)
+ neuron0x89c7bb8 = neuron0x89c7bb8 + synapse0x8ba53e8(x)
+ neuron0x89c7bb8 = neuron0x89c7bb8 + synapse0x8ba5410(x)
+ neuron0x89c7bb8 = neuron0x89c7bb8 + synapse0x8ba5438(x)
+ neuron0x89c7bb8 = neuron0x89c7bb8 + synapse0x8ba5460(x)
+ neuron0x89c7bb8= (exp(-neuron0x89c7bb8*neuron0x89c7bb8))
+ end
+ double precision function neuron0x8ba5488(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ neuron0x8ba5488 = -0.179616d0
+ neuron0x8ba5488 = neuron0x8ba5488 + synapse0x8ba5618(x)
+ neuron0x8ba5488 = neuron0x8ba5488 + synapse0x8ba5640(x)
+ neuron0x8ba5488 = neuron0x8ba5488 + synapse0x8ba5668(x)
+ neuron0x8ba5488 = neuron0x8ba5488 + synapse0x8ba5690(x)
+ neuron0x8ba5488 = neuron0x8ba5488 + synapse0x8ba56b8(x)
+ neuron0x8ba5488 = neuron0x8ba5488 + synapse0x8ba56e0(x)
+ neuron0x8ba5488 = neuron0x8ba5488 + synapse0x8ba5708(x)
+ neuron0x8ba5488 = neuron0x8ba5488 + synapse0x8ba5730(x)
+ neuron0x8ba5488 = neuron0x8ba5488 + synapse0x8ba5758(x)
+ neuron0x8ba5488 = neuron0x8ba5488 + synapse0x8ba5780(x)
+ neuron0x8ba5488 = neuron0x8ba5488 + synapse0x8ba57a8(x)
+ neuron0x8ba5488 = neuron0x8ba5488 + synapse0x8ba57d0(x)
+ neuron0x8ba5488 = neuron0x8ba5488 + synapse0x8ba57f8(x)
+ neuron0x8ba5488 = neuron0x8ba5488 + synapse0x8ba5820(x)
+ neuron0x8ba5488 = neuron0x8ba5488 + synapse0x8ba5848(x)
+ neuron0x8ba5488 = neuron0x8ba5488 + synapse0x8ba5870(x)
+ neuron0x8ba5488 = neuron0x8ba5488 + synapse0x8ba5920(x)
+ neuron0x8ba5488 = neuron0x8ba5488 + synapse0x8ba5948(x)
+ neuron0x8ba5488 = neuron0x8ba5488 + synapse0x8ba5970(x)
+ neuron0x8ba5488 = neuron0x8ba5488 + synapse0x8ba5998(x)
+ neuron0x8ba5488 = neuron0x8ba5488 + synapse0x8ba59c0(x)
+ neuron0x8ba5488 = neuron0x8ba5488 + synapse0x89339c8(x)
+ neuron0x8ba5488 = neuron0x8ba5488 + synapse0x89c7800(x)
+ neuron0x8ba5488 = neuron0x8ba5488 + synapse0x89c7828(x)
+ neuron0x8ba5488 = neuron0x8ba5488 + synapse0x89c7850(x)
+ neuron0x8ba5488 = neuron0x8ba5488 + synapse0x89c7878(x)
+ neuron0x8ba5488 = neuron0x8ba5488 + synapse0x89c78a0(x)
+ neuron0x8ba5488= (exp(-neuron0x8ba5488*neuron0x8ba5488))
+ end
+ double precision function neuron0x89c78c8(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ neuron0x89c78c8 = 0.905333d0
+ neuron0x89c78c8 = neuron0x89c78c8 + synapse0x89c79c8(x)
+ neuron0x89c78c8 = neuron0x89c78c8 + synapse0x8ba1a90(x)
+ neuron0x89c78c8 = neuron0x89c78c8 + synapse0x8ba1ab8(x)
+ neuron0x89c78c8 = neuron0x89c78c8 + synapse0x8ba1ae0(x)
+ neuron0x89c78c8 = neuron0x89c78c8 + synapse0x8ba5fd0(x)
+ neuron0x89c78c8 = neuron0x89c78c8 + synapse0x8ba5ff8(x)
+ neuron0x89c78c8 = neuron0x89c78c8 + synapse0x8ba6020(x)
+ neuron0x89c78c8 = neuron0x89c78c8 + synapse0x8ba6048(x)
+ neuron0x89c78c8 = neuron0x89c78c8 + synapse0x8ba6070(x)
+ neuron0x89c78c8 = neuron0x89c78c8 + synapse0x8ba6098(x)
+ neuron0x89c78c8 = neuron0x89c78c8 + synapse0x8ba60c0(x)
+ neuron0x89c78c8 = neuron0x89c78c8 + synapse0x8ba60e8(x)
+ neuron0x89c78c8 = neuron0x89c78c8 + synapse0x8ba6110(x)
+ neuron0x89c78c8 = neuron0x89c78c8 + synapse0x8ba6138(x)
+ neuron0x89c78c8 = neuron0x89c78c8 + synapse0x8ba6160(x)
+ neuron0x89c78c8 = neuron0x89c78c8 + synapse0x8ba6188(x)
+ neuron0x89c78c8 = neuron0x89c78c8 + synapse0x8ba6238(x)
+ neuron0x89c78c8 = neuron0x89c78c8 + synapse0x8ba6260(x)
+ neuron0x89c78c8 = neuron0x89c78c8 + synapse0x8ba6288(x)
+ neuron0x89c78c8 = neuron0x89c78c8 + synapse0x8ba62b0(x)
+ neuron0x89c78c8 = neuron0x89c78c8 + synapse0x8ba62d8(x)
+ neuron0x89c78c8 = neuron0x89c78c8 + synapse0x8ba6300(x)
+ neuron0x89c78c8 = neuron0x89c78c8 + synapse0x8ba6328(x)
+ neuron0x89c78c8 = neuron0x89c78c8 + synapse0x8ba6350(x)
+ neuron0x89c78c8 = neuron0x89c78c8 + synapse0x8ba6378(x)
+ neuron0x89c78c8 = neuron0x89c78c8 + synapse0x8ba63a0(x)
+ neuron0x89c78c8 = neuron0x89c78c8 + synapse0x8ba63c8(x)
+ neuron0x89c78c8= (exp(-neuron0x89c78c8*neuron0x89c78c8))
+ end
+ double precision function neuron0x8ba63f0(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ neuron0x8ba63f0 = 0.121249d0
+ neuron0x8ba63f0 = neuron0x8ba63f0 + synapse0x8ba6580(x)
+ neuron0x8ba63f0 = neuron0x8ba63f0 + synapse0x8ba65a8(x)
+ neuron0x8ba63f0 = neuron0x8ba63f0 + synapse0x8ba65d0(x)
+ neuron0x8ba63f0 = neuron0x8ba63f0 + synapse0x8ba65f8(x)
+ neuron0x8ba63f0 = neuron0x8ba63f0 + synapse0x8ba6620(x)
+ neuron0x8ba63f0 = neuron0x8ba63f0 + synapse0x8ba6648(x)
+ neuron0x8ba63f0 = neuron0x8ba63f0 + synapse0x8ba6670(x)
+ neuron0x8ba63f0 = neuron0x8ba63f0 + synapse0x8ba6698(x)
+ neuron0x8ba63f0 = neuron0x8ba63f0 + synapse0x8ba66c0(x)
+ neuron0x8ba63f0 = neuron0x8ba63f0 + synapse0x8ba66e8(x)
+ neuron0x8ba63f0 = neuron0x8ba63f0 + synapse0x8ba6710(x)
+ neuron0x8ba63f0 = neuron0x8ba63f0 + synapse0x8ba6738(x)
+ neuron0x8ba63f0 = neuron0x8ba63f0 + synapse0x8ba6760(x)
+ neuron0x8ba63f0 = neuron0x8ba63f0 + synapse0x8ba6788(x)
+ neuron0x8ba63f0 = neuron0x8ba63f0 + synapse0x8ba67b0(x)
+ neuron0x8ba63f0 = neuron0x8ba63f0 + synapse0x8ba67d8(x)
+ neuron0x8ba63f0 = neuron0x8ba63f0 + synapse0x8ba6888(x)
+ neuron0x8ba63f0 = neuron0x8ba63f0 + synapse0x8ba68b0(x)
+ neuron0x8ba63f0 = neuron0x8ba63f0 + synapse0x8ba68d8(x)
+ neuron0x8ba63f0 = neuron0x8ba63f0 + synapse0x8ba6900(x)
+ neuron0x8ba63f0 = neuron0x8ba63f0 + synapse0x8ba6928(x)
+ neuron0x8ba63f0 = neuron0x8ba63f0 + synapse0x8ba6950(x)
+ neuron0x8ba63f0 = neuron0x8ba63f0 + synapse0x8ba6978(x)
+ neuron0x8ba63f0 = neuron0x8ba63f0 + synapse0x8ba69a0(x)
+ neuron0x8ba63f0 = neuron0x8ba63f0 + synapse0x8ba69c8(x)
+ neuron0x8ba63f0 = neuron0x8ba63f0 + synapse0x8ba69f0(x)
+ neuron0x8ba63f0 = neuron0x8ba63f0 + synapse0x8ba6a18(x)
+ neuron0x8ba63f0= (exp(-neuron0x8ba63f0*neuron0x8ba63f0))
+ end
+ double precision function neuron0x8ba6a40(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ neuron0x8ba6a40 = 0.0532247d0
+ neuron0x8ba6a40 = neuron0x8ba6a40 + synapse0x8ba6bd0(x)
+ neuron0x8ba6a40 = neuron0x8ba6a40 + synapse0x8ba6bf8(x)
+ neuron0x8ba6a40 = neuron0x8ba6a40 + synapse0x8ba6c20(x)
+ neuron0x8ba6a40 = neuron0x8ba6a40 + synapse0x8ba6c48(x)
+ neuron0x8ba6a40 = neuron0x8ba6a40 + synapse0x8ba6c70(x)
+ neuron0x8ba6a40 = neuron0x8ba6a40 + synapse0x8ba6c98(x)
+ neuron0x8ba6a40 = neuron0x8ba6a40 + synapse0x8ba6cc0(x)
+ neuron0x8ba6a40 = neuron0x8ba6a40 + synapse0x8ba6ce8(x)
+ neuron0x8ba6a40 = neuron0x8ba6a40 + synapse0x8ba6d10(x)
+ neuron0x8ba6a40 = neuron0x8ba6a40 + synapse0x8ba6d38(x)
+ neuron0x8ba6a40 = neuron0x8ba6a40 + synapse0x8ba6d60(x)
+ neuron0x8ba6a40 = neuron0x8ba6a40 + synapse0x8ba6d88(x)
+ neuron0x8ba6a40 = neuron0x8ba6a40 + synapse0x8ba6db0(x)
+ neuron0x8ba6a40 = neuron0x8ba6a40 + synapse0x8ba6dd8(x)
+ neuron0x8ba6a40 = neuron0x8ba6a40 + synapse0x8ba6e00(x)
+ neuron0x8ba6a40 = neuron0x8ba6a40 + synapse0x8ba6e28(x)
+ neuron0x8ba6a40 = neuron0x8ba6a40 + synapse0x8ba6ed8(x)
+ neuron0x8ba6a40 = neuron0x8ba6a40 + synapse0x8ba6f00(x)
+ neuron0x8ba6a40 = neuron0x8ba6a40 + synapse0x8ba6f28(x)
+ neuron0x8ba6a40 = neuron0x8ba6a40 + synapse0x8ba6f50(x)
+ neuron0x8ba6a40 = neuron0x8ba6a40 + synapse0x8ba6f78(x)
+ neuron0x8ba6a40 = neuron0x8ba6a40 + synapse0x8ba6fa0(x)
+ neuron0x8ba6a40 = neuron0x8ba6a40 + synapse0x8ba6fc8(x)
+ neuron0x8ba6a40 = neuron0x8ba6a40 + synapse0x8ba6ff0(x)
+ neuron0x8ba6a40 = neuron0x8ba6a40 + synapse0x8ba7018(x)
+ neuron0x8ba6a40 = neuron0x8ba6a40 + synapse0x8ba7040(x)
+ neuron0x8ba6a40 = neuron0x8ba6a40 + synapse0x8ba7068(x)
+ neuron0x8ba6a40= (exp(-neuron0x8ba6a40*neuron0x8ba6a40))
+ end
+ double precision function neuron0x8ba7090(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ neuron0x8ba7090 = -0.695478d0
+ neuron0x8ba7090 = neuron0x8ba7090 + synapse0x8ba7240(x)
+ neuron0x8ba7090 = neuron0x8ba7090 + synapse0x8ba7268(x)
+ neuron0x8ba7090 = neuron0x8ba7090 + synapse0x8ba7290(x)
+ neuron0x8ba7090 = neuron0x8ba7090 + synapse0x8ba72b8(x)
+ neuron0x8ba7090 = neuron0x8ba7090 + synapse0x8ba72e0(x)
+ neuron0x8ba7090 = neuron0x8ba7090 + synapse0x8ba7308(x)
+ neuron0x8ba7090 = neuron0x8ba7090 + synapse0x8ba7330(x)
+ neuron0x8ba7090 = neuron0x8ba7090 + synapse0x8ba7358(x)
+ neuron0x8ba7090 = neuron0x8ba7090 + synapse0x8ba7380(x)
+ neuron0x8ba7090 = neuron0x8ba7090 + synapse0x8ba73a8(x)
+ neuron0x8ba7090 = neuron0x8ba7090 + synapse0x8ba73d0(x)
+ neuron0x8ba7090 = neuron0x8ba7090 + synapse0x8ba73f8(x)
+ neuron0x8ba7090 = neuron0x8ba7090 + synapse0x8ba7420(x)
+ neuron0x8ba7090 = neuron0x8ba7090 + synapse0x8ba7448(x)
+ neuron0x8ba7090 = neuron0x8ba7090 + synapse0x8ba7470(x)
+ neuron0x8ba7090 = neuron0x8ba7090 + synapse0x8ba7498(x)
+ neuron0x8ba7090 = neuron0x8ba7090 + synapse0x8ba7548(x)
+ neuron0x8ba7090 = neuron0x8ba7090 + synapse0x8ba7570(x)
+ neuron0x8ba7090 = neuron0x8ba7090 + synapse0x8ba7598(x)
+ neuron0x8ba7090 = neuron0x8ba7090 + synapse0x8ba75c0(x)
+ neuron0x8ba7090 = neuron0x8ba7090 + synapse0x8ba75e8(x)
+ neuron0x8ba7090 = neuron0x8ba7090 + synapse0x8ba7610(x)
+ neuron0x8ba7090 = neuron0x8ba7090 + synapse0x8ba7638(x)
+ neuron0x8ba7090 = neuron0x8ba7090 + synapse0x8ba7660(x)
+ neuron0x8ba7090 = neuron0x8ba7090 + synapse0x8ba7688(x)
+ neuron0x8ba7090 = neuron0x8ba7090 + synapse0x8ba76b0(x)
+ neuron0x8ba7090 = neuron0x8ba7090 + synapse0x8ba76d8(x)
+ neuron0x8ba7090= (exp(-neuron0x8ba7090*neuron0x8ba7090))
+ end
+ double precision function neuron0x8ba7700(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ neuron0x8ba7700 = 0.396814d0
+ neuron0x8ba7700 = neuron0x8ba7700 + synapse0x8ba78b0(x)
+ neuron0x8ba7700 = neuron0x8ba7700 + synapse0x8ba78d8(x)
+ neuron0x8ba7700 = neuron0x8ba7700 + synapse0x8ba7900(x)
+ neuron0x8ba7700 = neuron0x8ba7700 + synapse0x8ba7928(x)
+ neuron0x8ba7700 = neuron0x8ba7700 + synapse0x8ba7950(x)
+ neuron0x8ba7700 = neuron0x8ba7700 + synapse0x8ba7978(x)
+ neuron0x8ba7700 = neuron0x8ba7700 + synapse0x8ba79a0(x)
+ neuron0x8ba7700 = neuron0x8ba7700 + synapse0x8ba79c8(x)
+ neuron0x8ba7700 = neuron0x8ba7700 + synapse0x8ba79f0(x)
+ neuron0x8ba7700 = neuron0x8ba7700 + synapse0x8ba7a18(x)
+ neuron0x8ba7700 = neuron0x8ba7700 + synapse0x8ba7a40(x)
+ neuron0x8ba7700 = neuron0x8ba7700 + synapse0x8ba7a68(x)
+ neuron0x8ba7700 = neuron0x8ba7700 + synapse0x8ba7a90(x)
+ neuron0x8ba7700 = neuron0x8ba7700 + synapse0x8ba7ab8(x)
+ neuron0x8ba7700 = neuron0x8ba7700 + synapse0x8ba59e8(x)
+ neuron0x8ba7700 = neuron0x8ba7700 + synapse0x8ba5a10(x)
+ neuron0x8ba7700 = neuron0x8ba7700 + synapse0x8ba5ac0(x)
+ neuron0x8ba7700 = neuron0x8ba7700 + synapse0x8ba5ae8(x)
+ neuron0x8ba7700 = neuron0x8ba7700 + synapse0x8ba5b10(x)
+ neuron0x8ba7700 = neuron0x8ba7700 + synapse0x8ba5b38(x)
+ neuron0x8ba7700 = neuron0x8ba7700 + synapse0x8ba5b60(x)
+ neuron0x8ba7700 = neuron0x8ba7700 + synapse0x8ba5b88(x)
+ neuron0x8ba7700 = neuron0x8ba7700 + synapse0x8ba5bb0(x)
+ neuron0x8ba7700 = neuron0x8ba7700 + synapse0x8ba5bd8(x)
+ neuron0x8ba7700 = neuron0x8ba7700 + synapse0x8ba5c00(x)
+ neuron0x8ba7700 = neuron0x8ba7700 + synapse0x8ba5c28(x)
+ neuron0x8ba7700 = neuron0x8ba7700 + synapse0x8ba5c50(x)
+ neuron0x8ba7700= (exp(-neuron0x8ba7700*neuron0x8ba7700))
+ end
+ double precision function neuron0x8ba5c78(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ neuron0x8ba5c78 = -3.64843d0
+ neuron0x8ba5c78 = neuron0x8ba5c78 + synapse0x8ba2ee8(x)
+ neuron0x8ba5c78 = neuron0x8ba5c78 + synapse0x8ba2f10(x)
+ neuron0x8ba5c78 = neuron0x8ba5c78 + synapse0x8ba2f38(x)
+ neuron0x8ba5c78 = neuron0x8ba5c78 + synapse0x8ba5dc0(x)
+ neuron0x8ba5c78 = neuron0x8ba5c78 + synapse0x8ba2f60(x)
+ neuron0x8ba5c78 = neuron0x8ba5c78 + synapse0x8ba82e8(x)
+ neuron0x8ba5c78 = neuron0x8ba5c78 + synapse0x8ba8310(x)
+ neuron0x8ba5c78 = neuron0x8ba5c78 + synapse0x8ba8338(x)
+ neuron0x8ba5c78 = neuron0x8ba5c78 + synapse0x8ba8360(x)
+ neuron0x8ba5c78 = neuron0x8ba5c78 + synapse0x8ba8388(x)
+ end
+ double precision function neuron0x8ba83b0(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ neuron0x8ba83b0 = -6.51084d0
+ neuron0x8ba83b0 = neuron0x8ba83b0 + synapse0x8ba8588(x)
+ neuron0x8ba83b0 = neuron0x8ba83b0 + synapse0x8ba85b0(x)
+ neuron0x8ba83b0 = neuron0x8ba83b0 + synapse0x8ba85d8(x)
+ neuron0x8ba83b0 = neuron0x8ba83b0 + synapse0x8ba8600(x)
+ neuron0x8ba83b0 = neuron0x8ba83b0 + synapse0x8ba8628(x)
+ neuron0x8ba83b0 = neuron0x8ba83b0 + synapse0x8ba8650(x)
+ neuron0x8ba83b0 = neuron0x8ba83b0 + synapse0x8ba8678(x)
+ neuron0x8ba83b0 = neuron0x8ba83b0 + synapse0x8ba86a0(x)
+ neuron0x8ba83b0 = neuron0x8ba83b0 + synapse0x8ba86c8(x)
+ neuron0x8ba83b0 = neuron0x8ba83b0 + synapse0x8ba86f0(x)
+ end
+ double precision function neuron0x8ba8718(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ neuron0x8ba8718 = 0.177408d0
+ neuron0x8ba8718 = neuron0x8ba8718 + synapse0x8ba2e78(x)
+ neuron0x8ba8718 = neuron0x8ba8718 + synapse0x8ba88f0(x)
+ neuron0x8ba8718 = neuron0x8ba8718 + synapse0x8ba8918(x)
+ neuron0x8ba8718 = neuron0x8ba8718 + synapse0x8ba8940(x)
+ neuron0x8ba8718 = neuron0x8ba8718 + synapse0x8ba8968(x)
+ neuron0x8ba8718 = neuron0x8ba8718 + synapse0x8ba8990(x)
+ neuron0x8ba8718 = neuron0x8ba8718 + synapse0x8ba89b8(x)
+ neuron0x8ba8718 = neuron0x8ba8718 + synapse0x8ba89e0(x)
+ neuron0x8ba8718 = neuron0x8ba8718 + synapse0x8ba8a08(x)
+ neuron0x8ba8718 = neuron0x8ba8718 + synapse0x8ba8a30(x)
+ end
+C --- Synapses
+ double precision function synapse0x8b81ae8(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8b81ae8=neuron0x8b9f9f0(x)*(0.483642)
+ end
+
+ double precision function synapse0x89c73b8(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x89c73b8=neuron0x8b9fb80(x)*(-0.331845)
+ end
+
+ double precision function synapse0x8ba3170(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8ba3170=neuron0x8b9fd58(x)*(-0.197671)
+ end
+
+ double precision function synapse0x8ba3198(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8ba3198=neuron0x8b9ff30(x)*(-0.0389979)
+ end
+
+ double precision function synapse0x8ba31c0(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8ba31c0=neuron0x8ba0108(x)*(-0.390161)
+ end
+
+ double precision function synapse0x8ba31e8(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8ba31e8=neuron0x8ba02e0(x)*(-0.0414126)
+ end
+
+ double precision function synapse0x8ba3210(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8ba3210=neuron0x8ba04b8(x)*(-0.122874)
+ end
+
+ double precision function synapse0x8ba3238(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8ba3238=neuron0x8ba06a8(x)*(-0.132127)
+ end
+
+ double precision function synapse0x8ba3260(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8ba3260=neuron0x8ba0898(x)*(-0.100542)
+ end
+
+ double precision function synapse0x8ba3288(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8ba3288=neuron0x8ba0a88(x)*(-0.132274)
+ end
+
+ double precision function synapse0x8ba32b0(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8ba32b0=neuron0x8ba0c78(x)*(-0.0979607)
+ end
+
+ double precision function synapse0x8ba32d8(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8ba32d8=neuron0x8ba0e68(x)*(-0.213274)
+ end
+
+ double precision function synapse0x8ba3300(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8ba3300=neuron0x8ba1058(x)*(-0.143064)
+ end
+
+ double precision function synapse0x8ba3328(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8ba3328=neuron0x8ba1248(x)*(-0.144841)
+ end
+
+ double precision function synapse0x8ba3350(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8ba3350=neuron0x8ba1438(x)*(0.119818)
+ end
+
+ double precision function synapse0x8ba3378(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8ba3378=neuron0x8ba1628(x)*(0.195316)
+ end
+
+ double precision function synapse0x8ba33a0(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8ba33a0=neuron0x8ba1818(x)*(-2.14051)
+ end
+
+ double precision function synapse0x8ba3450(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8ba3450=neuron0x8ba1b18(x)*(-5.32795)
+ end
+
+ double precision function synapse0x8ba3478(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8ba3478=neuron0x8ba1d08(x)*(-1.95969)
+ end
+
+ double precision function synapse0x8ba34a0(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8ba34a0=neuron0x8ba1ef8(x)*(0.158245)
+ end
+
+ double precision function synapse0x8ba34c8(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8ba34c8=neuron0x8ba20e8(x)*(-0.142672)
+ end
+
+ double precision function synapse0x8ba34f0(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8ba34f0=neuron0x8ba22d8(x)*(-0.611092)
+ end
+
+ double precision function synapse0x8ba3518(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8ba3518=neuron0x8ba24c8(x)*(-0.304743)
+ end
+
+ double precision function synapse0x8ba3540(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8ba3540=neuron0x8ba26b8(x)*(0.139128)
+ end
+
+ double precision function synapse0x8ba3568(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8ba3568=neuron0x8ba28a8(x)*(-0.397478)
+ end
+
+ double precision function synapse0x8ba3590(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8ba3590=neuron0x8ba2a98(x)*(-0.0147352)
+ end
+
+ double precision function synapse0x8ba35b8(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8ba35b8=neuron0x8ba2c88(x)*(0.000893497)
+ end
+
+ double precision function synapse0x89d14d0(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x89d14d0=neuron0x8b9f9f0(x)*(-0.281456)
+ end
+
+ double precision function synapse0x89d14f8(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x89d14f8=neuron0x8b9fb80(x)*(-0.141963)
+ end
+
+ double precision function synapse0x8ba4788(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8ba4788=neuron0x8b9fd58(x)*(-0.345699)
+ end
+
+ double precision function synapse0x8ba47b0(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8ba47b0=neuron0x8b9ff30(x)*(-0.263971)
+ end
+
+ double precision function synapse0x8ba47d8(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8ba47d8=neuron0x8ba0108(x)*(0.182912)
+ end
+
+ double precision function synapse0x8ba4800(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8ba4800=neuron0x8ba02e0(x)*(0.00114743)
+ end
+
+ double precision function synapse0x8ba33c8(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8ba33c8=neuron0x8ba04b8(x)*(0.150389)
+ end
+
+ double precision function synapse0x8ba33f0(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8ba33f0=neuron0x8ba06a8(x)*(-0.0681054)
+ end
+
+ double precision function synapse0x8ba3418(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8ba3418=neuron0x8ba0898(x)*(-0.168092)
+ end
+
+ double precision function synapse0x8ba4930(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8ba4930=neuron0x8ba0a88(x)*(-0.471032)
+ end
+
+ double precision function synapse0x8ba4958(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8ba4958=neuron0x8ba0c78(x)*(0.126851)
+ end
+
+ double precision function synapse0x8ba4980(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8ba4980=neuron0x8ba0e68(x)*(0.367946)
+ end
+
+ double precision function synapse0x8ba49a8(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8ba49a8=neuron0x8ba1058(x)*(-0.198735)
+ end
+
+ double precision function synapse0x8ba49d0(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8ba49d0=neuron0x8ba1248(x)*(0.232556)
+ end
+
+ double precision function synapse0x8ba49f8(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8ba49f8=neuron0x8ba1438(x)*(-0.278)
+ end
+
+ double precision function synapse0x8ba4a20(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8ba4a20=neuron0x8ba1628(x)*(0.124528)
+ end
+
+ double precision function synapse0x8ba4ad0(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8ba4ad0=neuron0x8ba1818(x)*(0.422353)
+ end
+
+ double precision function synapse0x8ba4af8(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8ba4af8=neuron0x8ba1b18(x)*(-0.159403)
+ end
+
+ double precision function synapse0x8ba4b20(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8ba4b20=neuron0x8ba1d08(x)*(0.0333493)
+ end
+
+ double precision function synapse0x8ba4b48(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8ba4b48=neuron0x8ba1ef8(x)*(-0.183193)
+ end
+
+ double precision function synapse0x8ba4b70(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8ba4b70=neuron0x8ba20e8(x)*(-0.0531818)
+ end
+
+ double precision function synapse0x8ba4b98(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8ba4b98=neuron0x8ba22d8(x)*(0.417614)
+ end
+
+ double precision function synapse0x8ba4bc0(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8ba4bc0=neuron0x8ba24c8(x)*(0.140168)
+ end
+
+ double precision function synapse0x8ba4be8(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8ba4be8=neuron0x8ba26b8(x)*(0.447215)
+ end
+
+ double precision function synapse0x8ba4c10(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8ba4c10=neuron0x8ba28a8(x)*(0.0160476)
+ end
+
+ double precision function synapse0x8ba4c38(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8ba4c38=neuron0x8ba2a98(x)*(-0.357885)
+ end
+
+ double precision function synapse0x8ba4c60(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8ba4c60=neuron0x8ba2c88(x)*(-0.214542)
+ end
+
+ double precision function synapse0x8ba4e38(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8ba4e38=neuron0x8b9f9f0(x)*(0.421851)
+ end
+
+ double precision function synapse0x8ba4e60(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8ba4e60=neuron0x8b9fb80(x)*(-0.412416)
+ end
+
+ double precision function synapse0x8ba4e88(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8ba4e88=neuron0x8b9fd58(x)*(-0.0465749)
+ end
+
+ double precision function synapse0x8ba4eb0(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8ba4eb0=neuron0x8b9ff30(x)*(0.0473863)
+ end
+
+ double precision function synapse0x8ba4ed8(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8ba4ed8=neuron0x8ba0108(x)*(-0.0988909)
+ end
+
+ double precision function synapse0x8ba4f00(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8ba4f00=neuron0x8ba02e0(x)*(-0.446179)
+ end
+
+ double precision function synapse0x8ba4f28(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8ba4f28=neuron0x8ba04b8(x)*(-0.0340558)
+ end
+
+ double precision function synapse0x8ba4f50(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8ba4f50=neuron0x8ba06a8(x)*(-0.211673)
+ end
+
+ double precision function synapse0x8ba4f78(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8ba4f78=neuron0x8ba0898(x)*(-0.455498)
+ end
+
+ double precision function synapse0x8ba4fa0(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8ba4fa0=neuron0x8ba0a88(x)*(-0.0921243)
+ end
+
+ double precision function synapse0x8ba4fc8(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8ba4fc8=neuron0x8ba0c78(x)*(0.455445)
+ end
+
+ double precision function synapse0x89c7788(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x89c7788=neuron0x8ba0e68(x)*(0.303778)
+ end
+
+ double precision function synapse0x89c7348(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x89c7348=neuron0x8ba1058(x)*(0.00956873)
+ end
+
+ double precision function synapse0x89c7370(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x89c7370=neuron0x8ba1248(x)*(0.409565)
+ end
+
+ double precision function synapse0x89c7540(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x89c7540=neuron0x8ba1438(x)*(0.18915)
+ end
+
+ double precision function synapse0x89c7568(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x89c7568=neuron0x8ba1628(x)*(0.0801067)
+ end
+
+ double precision function synapse0x8ba48b0(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8ba48b0=neuron0x8ba1818(x)*(-0.0761627)
+ end
+
+ double precision function synapse0x8ba48d8(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8ba48d8=neuron0x8ba1b18(x)*(0.390446)
+ end
+
+ double precision function synapse0x8ba4900(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8ba4900=neuron0x8ba1d08(x)*(-0.366271)
+ end
+
+ double precision function synapse0x8b7dca8(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8b7dca8=neuron0x8ba1ef8(x)*(0.301853)
+ end
+
+ double precision function synapse0x8b7dcd0(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8b7dcd0=neuron0x8ba20e8(x)*(-0.203622)
+ end
+
+ double precision function synapse0x89c7a08(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x89c7a08=neuron0x8ba22d8(x)*(-0.0491364)
+ end
+
+ double precision function synapse0x89c7a30(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x89c7a30=neuron0x8ba24c8(x)*(0.233908)
+ end
+
+ double precision function synapse0x89c7a58(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x89c7a58=neuron0x8ba26b8(x)*(-0.18159)
+ end
+
+ double precision function synapse0x89c7a80(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x89c7a80=neuron0x8ba28a8(x)*(0.23617)
+ end
+
+ double precision function synapse0x89c7aa8(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x89c7aa8=neuron0x8ba2a98(x)*(-1.75266)
+ end
+
+ double precision function synapse0x89c7ad0(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x89c7ad0=neuron0x8ba2c88(x)*(-0.960705)
+ end
+
+ double precision function synapse0x89c7af8(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x89c7af8=neuron0x8b9f9f0(x)*(0.325898)
+ end
+
+ double precision function synapse0x8ba4ff0(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8ba4ff0=neuron0x8b9fb80(x)*(0.263696)
+ end
+
+ double precision function synapse0x8ba5018(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8ba5018=neuron0x8b9fd58(x)*(0.132032)
+ end
+
+ double precision function synapse0x8ba5040(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8ba5040=neuron0x8b9ff30(x)*(0.194925)
+ end
+
+ double precision function synapse0x8ba5068(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8ba5068=neuron0x8ba0108(x)*(-0.172608)
+ end
+
+ double precision function synapse0x8ba5090(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8ba5090=neuron0x8ba02e0(x)*(-0.0458847)
+ end
+
+ double precision function synapse0x8ba50b8(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8ba50b8=neuron0x8ba04b8(x)*(-0.328044)
+ end
+
+ double precision function synapse0x8ba50e0(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8ba50e0=neuron0x8ba06a8(x)*(-0.36284)
+ end
+
+ double precision function synapse0x8ba5108(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8ba5108=neuron0x8ba0898(x)*(-0.247904)
+ end
+
+ double precision function synapse0x8ba5130(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8ba5130=neuron0x8ba0a88(x)*(-0.122628)
+ end
+
+ double precision function synapse0x8ba5158(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8ba5158=neuron0x8ba0c78(x)*(-0.0522122)
+ end
+
+ double precision function synapse0x8ba5180(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8ba5180=neuron0x8ba0e68(x)*(-0.0939796)
+ end
+
+ double precision function synapse0x8ba51a8(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8ba51a8=neuron0x8ba1058(x)*(-0.0664104)
+ end
+
+ double precision function synapse0x8ba51d0(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8ba51d0=neuron0x8ba1248(x)*(-0.051941)
+ end
+
+ double precision function synapse0x8ba51f8(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8ba51f8=neuron0x8ba1438(x)*(-0.0516786)
+ end
+
+ double precision function synapse0x8ba5220(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8ba5220=neuron0x8ba1628(x)*(0.336215)
+ end
+
+ double precision function synapse0x8ba52d0(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8ba52d0=neuron0x8ba1818(x)*(0.160129)
+ end
+
+ double precision function synapse0x8ba52f8(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8ba52f8=neuron0x8ba1b18(x)*(0.201977)
+ end
+
+ double precision function synapse0x8ba5320(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8ba5320=neuron0x8ba1d08(x)*(0.181614)
+ end
+
+ double precision function synapse0x8ba5348(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8ba5348=neuron0x8ba1ef8(x)*(0.132444)
+ end
+
+ double precision function synapse0x8ba5370(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8ba5370=neuron0x8ba20e8(x)*(0.096479)
+ end
+
+ double precision function synapse0x8ba5398(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8ba5398=neuron0x8ba22d8(x)*(0.00953369)
+ end
+
+ double precision function synapse0x8ba53c0(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8ba53c0=neuron0x8ba24c8(x)*(0.330827)
+ end
+
+ double precision function synapse0x8ba53e8(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8ba53e8=neuron0x8ba26b8(x)*(0.0676924)
+ end
+
+ double precision function synapse0x8ba5410(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8ba5410=neuron0x8ba28a8(x)*(-0.0307955)
+ end
+
+ double precision function synapse0x8ba5438(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8ba5438=neuron0x8ba2a98(x)*(-0.0267607)
+ end
+
+ double precision function synapse0x8ba5460(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8ba5460=neuron0x8ba2c88(x)*(-0.000553303)
+ end
+
+ double precision function synapse0x8ba5618(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8ba5618=neuron0x8b9f9f0(x)*(-0.341355)
+ end
+
+ double precision function synapse0x8ba5640(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8ba5640=neuron0x8b9fb80(x)*(0.281942)
+ end
+
+ double precision function synapse0x8ba5668(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8ba5668=neuron0x8b9fd58(x)*(0.447172)
+ end
+
+ double precision function synapse0x8ba5690(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8ba5690=neuron0x8b9ff30(x)*(-0.331888)
+ end
+
+ double precision function synapse0x8ba56b8(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8ba56b8=neuron0x8ba0108(x)*(0.315836)
+ end
+
+ double precision function synapse0x8ba56e0(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8ba56e0=neuron0x8ba02e0(x)*(-0.390168)
+ end
+
+ double precision function synapse0x8ba5708(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8ba5708=neuron0x8ba04b8(x)*(-0.0601401)
+ end
+
+ double precision function synapse0x8ba5730(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8ba5730=neuron0x8ba06a8(x)*(-0.301931)
+ end
+
+ double precision function synapse0x8ba5758(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8ba5758=neuron0x8ba0898(x)*(-0.32006)
+ end
+
+ double precision function synapse0x8ba5780(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8ba5780=neuron0x8ba0a88(x)*(0.432483)
+ end
+
+ double precision function synapse0x8ba57a8(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8ba57a8=neuron0x8ba0c78(x)*(0.159891)
+ end
+
+ double precision function synapse0x8ba57d0(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8ba57d0=neuron0x8ba0e68(x)*(-0.12196)
+ end
+
+ double precision function synapse0x8ba57f8(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8ba57f8=neuron0x8ba1058(x)*(-0.570038)
+ end
+
+ double precision function synapse0x8ba5820(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8ba5820=neuron0x8ba1248(x)*(-0.19222)
+ end
+
+ double precision function synapse0x8ba5848(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8ba5848=neuron0x8ba1438(x)*(0.12489)
+ end
+
+ double precision function synapse0x8ba5870(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8ba5870=neuron0x8ba1628(x)*(0.0177232)
+ end
+
+ double precision function synapse0x8ba5920(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8ba5920=neuron0x8ba1818(x)*(-0.455668)
+ end
+
+ double precision function synapse0x8ba5948(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8ba5948=neuron0x8ba1b18(x)*(-0.365744)
+ end
+
+ double precision function synapse0x8ba5970(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8ba5970=neuron0x8ba1d08(x)*(0.0764771)
+ end
+
+ double precision function synapse0x8ba5998(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8ba5998=neuron0x8ba1ef8(x)*(0.440436)
+ end
+
+ double precision function synapse0x8ba59c0(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8ba59c0=neuron0x8ba20e8(x)*(-0.287184)
+ end
+
+ double precision function synapse0x89339c8(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x89339c8=neuron0x8ba22d8(x)*(0.208308)
+ end
+
+ double precision function synapse0x89c7800(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x89c7800=neuron0x8ba24c8(x)*(0.0569996)
+ end
+
+ double precision function synapse0x89c7828(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x89c7828=neuron0x8ba26b8(x)*(0.257768)
+ end
+
+ double precision function synapse0x89c7850(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x89c7850=neuron0x8ba28a8(x)*(0.393571)
+ end
+
+ double precision function synapse0x89c7878(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x89c7878=neuron0x8ba2a98(x)*(-1.44881)
+ end
+
+ double precision function synapse0x89c78a0(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x89c78a0=neuron0x8ba2c88(x)*(-0.496482)
+ end
+
+ double precision function synapse0x89c79c8(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x89c79c8=neuron0x8b9f9f0(x)*(-0.41576)
+ end
+
+ double precision function synapse0x8ba1a90(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8ba1a90=neuron0x8b9fb80(x)*(0.368259)
+ end
+
+ double precision function synapse0x8ba1ab8(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8ba1ab8=neuron0x8b9fd58(x)*(-0.498272)
+ end
+
+ double precision function synapse0x8ba1ae0(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8ba1ae0=neuron0x8b9ff30(x)*(0.235496)
+ end
+
+ double precision function synapse0x8ba5fd0(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8ba5fd0=neuron0x8ba0108(x)*(0.188456)
+ end
+
+ double precision function synapse0x8ba5ff8(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8ba5ff8=neuron0x8ba02e0(x)*(0.224277)
+ end
+
+ double precision function synapse0x8ba6020(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8ba6020=neuron0x8ba04b8(x)*(0.450063)
+ end
+
+ double precision function synapse0x8ba6048(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8ba6048=neuron0x8ba06a8(x)*(-0.199829)
+ end
+
+ double precision function synapse0x8ba6070(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8ba6070=neuron0x8ba0898(x)*(0.0574969)
+ end
+
+ double precision function synapse0x8ba6098(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8ba6098=neuron0x8ba0a88(x)*(-0.00192779)
+ end
+
+ double precision function synapse0x8ba60c0(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8ba60c0=neuron0x8ba0c78(x)*(-0.200774)
+ end
+
+ double precision function synapse0x8ba60e8(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8ba60e8=neuron0x8ba0e68(x)*(-0.323178)
+ end
+
+ double precision function synapse0x8ba6110(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8ba6110=neuron0x8ba1058(x)*(0.442817)
+ end
+
+ double precision function synapse0x8ba6138(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8ba6138=neuron0x8ba1248(x)*(-0.507636)
+ end
+
+ double precision function synapse0x8ba6160(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8ba6160=neuron0x8ba1438(x)*(0.336788)
+ end
+
+ double precision function synapse0x8ba6188(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8ba6188=neuron0x8ba1628(x)*(0.40458)
+ end
+
+ double precision function synapse0x8ba6238(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8ba6238=neuron0x8ba1818(x)*(-0.0220729)
+ end
+
+ double precision function synapse0x8ba6260(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8ba6260=neuron0x8ba1b18(x)*(0.12406)
+ end
+
+ double precision function synapse0x8ba6288(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8ba6288=neuron0x8ba1d08(x)*(-0.381275)
+ end
+
+ double precision function synapse0x8ba62b0(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8ba62b0=neuron0x8ba1ef8(x)*(0.316392)
+ end
+
+ double precision function synapse0x8ba62d8(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8ba62d8=neuron0x8ba20e8(x)*(0.196836)
+ end
+
+ double precision function synapse0x8ba6300(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8ba6300=neuron0x8ba22d8(x)*(0.199231)
+ end
+
+ double precision function synapse0x8ba6328(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8ba6328=neuron0x8ba24c8(x)*(0.279028)
+ end
+
+ double precision function synapse0x8ba6350(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8ba6350=neuron0x8ba26b8(x)*(-0.0367043)
+ end
+
+ double precision function synapse0x8ba6378(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8ba6378=neuron0x8ba28a8(x)*(-0.0211602)
+ end
+
+ double precision function synapse0x8ba63a0(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8ba63a0=neuron0x8ba2a98(x)*(-1.06024)
+ end
+
+ double precision function synapse0x8ba63c8(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8ba63c8=neuron0x8ba2c88(x)*(1.88141)
+ end
+
+ double precision function synapse0x8ba6580(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8ba6580=neuron0x8b9f9f0(x)*(0.156752)
+ end
+
+ double precision function synapse0x8ba65a8(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8ba65a8=neuron0x8b9fb80(x)*(-0.0323652)
+ end
+
+ double precision function synapse0x8ba65d0(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8ba65d0=neuron0x8b9fd58(x)*(0.139572)
+ end
+
+ double precision function synapse0x8ba65f8(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8ba65f8=neuron0x8b9ff30(x)*(0.0994379)
+ end
+
+ double precision function synapse0x8ba6620(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8ba6620=neuron0x8ba0108(x)*(-0.293711)
+ end
+
+ double precision function synapse0x8ba6648(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8ba6648=neuron0x8ba02e0(x)*(-0.433942)
+ end
+
+ double precision function synapse0x8ba6670(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8ba6670=neuron0x8ba04b8(x)*(-0.40288)
+ end
+
+ double precision function synapse0x8ba6698(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8ba6698=neuron0x8ba06a8(x)*(-0.28495)
+ end
+
+ double precision function synapse0x8ba66c0(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8ba66c0=neuron0x8ba0898(x)*(0.229911)
+ end
+
+ double precision function synapse0x8ba66e8(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8ba66e8=neuron0x8ba0a88(x)*(-0.186718)
+ end
+
+ double precision function synapse0x8ba6710(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8ba6710=neuron0x8ba0c78(x)*(-0.204478)
+ end
+
+ double precision function synapse0x8ba6738(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8ba6738=neuron0x8ba0e68(x)*(0.243337)
+ end
+
+ double precision function synapse0x8ba6760(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8ba6760=neuron0x8ba1058(x)*(0.404864)
+ end
+
+ double precision function synapse0x8ba6788(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8ba6788=neuron0x8ba1248(x)*(0.243137)
+ end
+
+ double precision function synapse0x8ba67b0(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8ba67b0=neuron0x8ba1438(x)*(0.247726)
+ end
+
+ double precision function synapse0x8ba67d8(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8ba67d8=neuron0x8ba1628(x)*(0.25275)
+ end
+
+ double precision function synapse0x8ba6888(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8ba6888=neuron0x8ba1818(x)*(0.475473)
+ end
+
+ double precision function synapse0x8ba68b0(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8ba68b0=neuron0x8ba1b18(x)*(-0.377163)
+ end
+
+ double precision function synapse0x8ba68d8(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8ba68d8=neuron0x8ba1d08(x)*(0.378175)
+ end
+
+ double precision function synapse0x8ba6900(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8ba6900=neuron0x8ba1ef8(x)*(-0.261134)
+ end
+
+ double precision function synapse0x8ba6928(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8ba6928=neuron0x8ba20e8(x)*(0.184549)
+ end
+
+ double precision function synapse0x8ba6950(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8ba6950=neuron0x8ba22d8(x)*(-0.494884)
+ end
+
+ double precision function synapse0x8ba6978(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8ba6978=neuron0x8ba24c8(x)*(0.381179)
+ end
+
+ double precision function synapse0x8ba69a0(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8ba69a0=neuron0x8ba26b8(x)*(0.00860764)
+ end
+
+ double precision function synapse0x8ba69c8(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8ba69c8=neuron0x8ba28a8(x)*(0.310692)
+ end
+
+ double precision function synapse0x8ba69f0(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8ba69f0=neuron0x8ba2a98(x)*(1.26516)
+ end
+
+ double precision function synapse0x8ba6a18(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8ba6a18=neuron0x8ba2c88(x)*(-1.61491)
+ end
+
+ double precision function synapse0x8ba6bd0(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8ba6bd0=neuron0x8b9f9f0(x)*(-0.186545)
+ end
+
+ double precision function synapse0x8ba6bf8(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8ba6bf8=neuron0x8b9fb80(x)*(-0.254109)
+ end
+
+ double precision function synapse0x8ba6c20(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8ba6c20=neuron0x8b9fd58(x)*(0.0269172)
+ end
+
+ double precision function synapse0x8ba6c48(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8ba6c48=neuron0x8b9ff30(x)*(-0.172717)
+ end
+
+ double precision function synapse0x8ba6c70(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8ba6c70=neuron0x8ba0108(x)*(-0.0934297)
+ end
+
+ double precision function synapse0x8ba6c98(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8ba6c98=neuron0x8ba02e0(x)*(-0.499022)
+ end
+
+ double precision function synapse0x8ba6cc0(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8ba6cc0=neuron0x8ba04b8(x)*(0.213978)
+ end
+
+ double precision function synapse0x8ba6ce8(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8ba6ce8=neuron0x8ba06a8(x)*(0.0658566)
+ end
+
+ double precision function synapse0x8ba6d10(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8ba6d10=neuron0x8ba0898(x)*(-0.078723)
+ end
+
+ double precision function synapse0x8ba6d38(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8ba6d38=neuron0x8ba0a88(x)*(-0.0812947)
+ end
+
+ double precision function synapse0x8ba6d60(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8ba6d60=neuron0x8ba0c78(x)*(-0.469538)
+ end
+
+ double precision function synapse0x8ba6d88(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8ba6d88=neuron0x8ba0e68(x)*(0.232)
+ end
+
+ double precision function synapse0x8ba6db0(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8ba6db0=neuron0x8ba1058(x)*(0.0461328)
+ end
+
+ double precision function synapse0x8ba6dd8(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8ba6dd8=neuron0x8ba1248(x)*(-0.112159)
+ end
+
+ double precision function synapse0x8ba6e00(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8ba6e00=neuron0x8ba1438(x)*(-0.118729)
+ end
+
+ double precision function synapse0x8ba6e28(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8ba6e28=neuron0x8ba1628(x)*(-0.498684)
+ end
+
+ double precision function synapse0x8ba6ed8(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8ba6ed8=neuron0x8ba1818(x)*(0.21095)
+ end
+
+ double precision function synapse0x8ba6f00(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8ba6f00=neuron0x8ba1b18(x)*(0.0407828)
+ end
+
+ double precision function synapse0x8ba6f28(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8ba6f28=neuron0x8ba1d08(x)*(-0.132153)
+ end
+
+ double precision function synapse0x8ba6f50(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8ba6f50=neuron0x8ba1ef8(x)*(-0.0744378)
+ end
+
+ double precision function synapse0x8ba6f78(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8ba6f78=neuron0x8ba20e8(x)*(-0.169081)
+ end
+
+ double precision function synapse0x8ba6fa0(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8ba6fa0=neuron0x8ba22d8(x)*(0.18493)
+ end
+
+ double precision function synapse0x8ba6fc8(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8ba6fc8=neuron0x8ba24c8(x)*(0.00853669)
+ end
+
+ double precision function synapse0x8ba6ff0(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8ba6ff0=neuron0x8ba26b8(x)*(-0.0612235)
+ end
+
+ double precision function synapse0x8ba7018(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8ba7018=neuron0x8ba28a8(x)*(-0.0627871)
+ end
+
+ double precision function synapse0x8ba7040(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8ba7040=neuron0x8ba2a98(x)*(-7.72112e-05)
+ end
+
+ double precision function synapse0x8ba7068(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8ba7068=neuron0x8ba2c88(x)*(0.0164225)
+ end
+
+ double precision function synapse0x8ba7240(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8ba7240=neuron0x8b9f9f0(x)*(-0.129423)
+ end
+
+ double precision function synapse0x8ba7268(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8ba7268=neuron0x8b9fb80(x)*(0.26977)
+ end
+
+ double precision function synapse0x8ba7290(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8ba7290=neuron0x8b9fd58(x)*(-0.194298)
+ end
+
+ double precision function synapse0x8ba72b8(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8ba72b8=neuron0x8b9ff30(x)*(-0.011063)
+ end
+
+ double precision function synapse0x8ba72e0(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8ba72e0=neuron0x8ba0108(x)*(0.129084)
+ end
+
+ double precision function synapse0x8ba7308(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8ba7308=neuron0x8ba02e0(x)*(0.550802)
+ end
+
+ double precision function synapse0x8ba7330(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8ba7330=neuron0x8ba04b8(x)*(-0.155118)
+ end
+
+ double precision function synapse0x8ba7358(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8ba7358=neuron0x8ba06a8(x)*(-0.141736)
+ end
+
+ double precision function synapse0x8ba7380(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8ba7380=neuron0x8ba0898(x)*(-1.74905)
+ end
+
+ double precision function synapse0x8ba73a8(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8ba73a8=neuron0x8ba0a88(x)*(-0.238317)
+ end
+
+ double precision function synapse0x8ba73d0(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8ba73d0=neuron0x8ba0c78(x)*(0.309336)
+ end
+
+ double precision function synapse0x8ba73f8(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8ba73f8=neuron0x8ba0e68(x)*(-0.161452)
+ end
+
+ double precision function synapse0x8ba7420(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8ba7420=neuron0x8ba1058(x)*(-0.15577)
+ end
+
+ double precision function synapse0x8ba7448(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8ba7448=neuron0x8ba1248(x)*(-3.78829)
+ end
+
+ double precision function synapse0x8ba7470(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8ba7470=neuron0x8ba1438(x)*(-0.100874)
+ end
+
+ double precision function synapse0x8ba7498(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8ba7498=neuron0x8ba1628(x)*(0.551909)
+ end
+
+ double precision function synapse0x8ba7548(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8ba7548=neuron0x8ba1818(x)*(-0.182996)
+ end
+
+ double precision function synapse0x8ba7570(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8ba7570=neuron0x8ba1b18(x)*(-0.295265)
+ end
+
+ double precision function synapse0x8ba7598(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8ba7598=neuron0x8ba1d08(x)*(-2.19072)
+ end
+
+ double precision function synapse0x8ba75c0(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8ba75c0=neuron0x8ba1ef8(x)*(-0.404249)
+ end
+
+ double precision function synapse0x8ba75e8(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8ba75e8=neuron0x8ba20e8(x)*(0.275802)
+ end
+
+ double precision function synapse0x8ba7610(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8ba7610=neuron0x8ba22d8(x)*(-0.328414)
+ end
+
+ double precision function synapse0x8ba7638(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8ba7638=neuron0x8ba24c8(x)*(-0.235894)
+ end
+
+ double precision function synapse0x8ba7660(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8ba7660=neuron0x8ba26b8(x)*(-0.115492)
+ end
+
+ double precision function synapse0x8ba7688(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8ba7688=neuron0x8ba28a8(x)*(-0.303967)
+ end
+
+ double precision function synapse0x8ba76b0(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8ba76b0=neuron0x8ba2a98(x)*(-0.000975913)
+ end
+
+ double precision function synapse0x8ba76d8(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8ba76d8=neuron0x8ba2c88(x)*(-0.00985096)
+ end
+
+ double precision function synapse0x8ba78b0(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8ba78b0=neuron0x8b9f9f0(x)*(-0.433113)
+ end
+
+ double precision function synapse0x8ba78d8(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8ba78d8=neuron0x8b9fb80(x)*(-0.0912424)
+ end
+
+ double precision function synapse0x8ba7900(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8ba7900=neuron0x8b9fd58(x)*(0.161767)
+ end
+
+ double precision function synapse0x8ba7928(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8ba7928=neuron0x8b9ff30(x)*(-0.337497)
+ end
+
+ double precision function synapse0x8ba7950(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8ba7950=neuron0x8ba0108(x)*(-0.0898866)
+ end
+
+ double precision function synapse0x8ba7978(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8ba7978=neuron0x8ba02e0(x)*(-0.427305)
+ end
+
+ double precision function synapse0x8ba79a0(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8ba79a0=neuron0x8ba04b8(x)*(-0.0576224)
+ end
+
+ double precision function synapse0x8ba79c8(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8ba79c8=neuron0x8ba06a8(x)*(-0.238349)
+ end
+
+ double precision function synapse0x8ba79f0(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8ba79f0=neuron0x8ba0898(x)*(0.402586)
+ end
+
+ double precision function synapse0x8ba7a18(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8ba7a18=neuron0x8ba0a88(x)*(-0.358019)
+ end
+
+ double precision function synapse0x8ba7a40(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8ba7a40=neuron0x8ba0c78(x)*(0.408022)
+ end
+
+ double precision function synapse0x8ba7a68(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8ba7a68=neuron0x8ba0e68(x)*(-0.444476)
+ end
+
+ double precision function synapse0x8ba7a90(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8ba7a90=neuron0x8ba1058(x)*(-0.32721)
+ end
+
+ double precision function synapse0x8ba7ab8(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8ba7ab8=neuron0x8ba1248(x)*(0.295231)
+ end
+
+ double precision function synapse0x8ba59e8(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8ba59e8=neuron0x8ba1438(x)*(0.198907)
+ end
+
+ double precision function synapse0x8ba5a10(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8ba5a10=neuron0x8ba1628(x)*(-0.393812)
+ end
+
+ double precision function synapse0x8ba5ac0(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8ba5ac0=neuron0x8ba1818(x)*(0.349365)
+ end
+
+ double precision function synapse0x8ba5ae8(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8ba5ae8=neuron0x8ba1b18(x)*(0.228748)
+ end
+
+ double precision function synapse0x8ba5b10(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8ba5b10=neuron0x8ba1d08(x)*(-0.0183166)
+ end
+
+ double precision function synapse0x8ba5b38(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8ba5b38=neuron0x8ba1ef8(x)*(0.440304)
+ end
+
+ double precision function synapse0x8ba5b60(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8ba5b60=neuron0x8ba20e8(x)*(0.254315)
+ end
+
+ double precision function synapse0x8ba5b88(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8ba5b88=neuron0x8ba22d8(x)*(0.00929533)
+ end
+
+ double precision function synapse0x8ba5bb0(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8ba5bb0=neuron0x8ba24c8(x)*(-0.370687)
+ end
+
+ double precision function synapse0x8ba5bd8(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8ba5bd8=neuron0x8ba26b8(x)*(0.33127)
+ end
+
+ double precision function synapse0x8ba5c00(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8ba5c00=neuron0x8ba28a8(x)*(-0.234409)
+ end
+
+ double precision function synapse0x8ba5c28(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8ba5c28=neuron0x8ba2a98(x)*(0.806624)
+ end
+
+ double precision function synapse0x8ba5c50(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8ba5c50=neuron0x8ba2c88(x)*(-3.0504)
+ end
+
+ double precision function synapse0x8ba2ee8(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8ba2ee8=neuron0x8ba2f98(x)*(-5.5854)
+ end
+
+ double precision function synapse0x8ba2f10(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8ba2f10=neuron0x8ba35e0(x)*(-0.299975)
+ end
+
+ double precision function synapse0x8ba2f38(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8ba2f38=neuron0x8ba4c88(x)*(0.195642)
+ end
+
+ double precision function synapse0x8ba5dc0(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8ba5dc0=neuron0x89c7bb8(x)*(7.10471)
+ end
+
+ double precision function synapse0x8ba2f60(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8ba2f60=neuron0x8ba5488(x)*(-0.260853)
+ end
+
+ double precision function synapse0x8ba82e8(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8ba82e8=neuron0x89c78c8(x)*(-0.0280156)
+ end
+
+ double precision function synapse0x8ba8310(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8ba8310=neuron0x8ba63f0(x)*(-0.00626868)
+ end
+
+ double precision function synapse0x8ba8338(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8ba8338=neuron0x8ba6a40(x)*(-0.361893)
+ end
+
+ double precision function synapse0x8ba8360(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8ba8360=neuron0x8ba7090(x)*(0.575083)
+ end
+
+ double precision function synapse0x8ba8388(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8ba8388=neuron0x8ba7700(x)*(-0.0426063)
+ end
+
+ double precision function synapse0x8ba8588(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8ba8588=neuron0x8ba2f98(x)*(1.35428)
+ end
+
+ double precision function synapse0x8ba85b0(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8ba85b0=neuron0x8ba35e0(x)*(0.11457)
+ end
+
+ double precision function synapse0x8ba85d8(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8ba85d8=neuron0x8ba4c88(x)*(0.166879)
+ end
+
+ double precision function synapse0x8ba8600(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8ba8600=neuron0x89c7bb8(x)*(-0.237741)
+ end
+
+ double precision function synapse0x8ba8628(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8ba8628=neuron0x8ba5488(x)*(-0.0333829)
+ end
+
+ double precision function synapse0x8ba8650(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8ba8650=neuron0x89c78c8(x)*(0.0583778)
+ end
+
+ double precision function synapse0x8ba8678(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8ba8678=neuron0x8ba63f0(x)*(0.0326881)
+ end
+
+ double precision function synapse0x8ba86a0(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8ba86a0=neuron0x8ba6a40(x)*(10.7016)
+ end
+
+ double precision function synapse0x8ba86c8(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8ba86c8=neuron0x8ba7090(x)*(-6.77237)
+ end
+
+ double precision function synapse0x8ba86f0(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8ba86f0=neuron0x8ba7700(x)*(0.106134)
+ end
+
+ double precision function synapse0x8ba2e78(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8ba2e78=neuron0x8ba2f98(x)*(-0.0101696)
+ end
+
+ double precision function synapse0x8ba88f0(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8ba88f0=neuron0x8ba35e0(x)*(0.538128)
+ end
+
+ double precision function synapse0x8ba8918(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8ba8918=neuron0x8ba4c88(x)*(0.0136202)
+ end
+
+ double precision function synapse0x8ba8940(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8ba8940=neuron0x89c7bb8(x)*(-0.0188615)
+ end
+
+ double precision function synapse0x8ba8968(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8ba8968=neuron0x8ba5488(x)*(-0.199188)
+ end
+
+ double precision function synapse0x8ba8990(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8ba8990=neuron0x89c78c8(x)*(0.00329828)
+ end
+
+ double precision function synapse0x8ba89b8(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8ba89b8=neuron0x8ba63f0(x)*(-0.026726)
+ end
+
+ double precision function synapse0x8ba89e0(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8ba89e0=neuron0x8ba6a40(x)*(-0.00918066)
+ end
+
+ double precision function synapse0x8ba8a08(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8ba8a08=neuron0x8ba7090(x)*(-0.0203866)
+ end
+
+ double precision function synapse0x8ba8a30(x)
+ implicit double precision (a-h,n-z)
+ double precision x(27)
+
+ synapse0x8ba8a30=neuron0x8ba7700(x)*(0.0475111)
+ end
+
+
+
diff --git a/SANE/sane_ntup_change.f b/SANE/sane_ntup_change.f
new file mode 100644
index 0000000..600ad3d
--- /dev/null
+++ b/SANE/sane_ntup_change.f
@@ -0,0 +1,80 @@
+ subroutine sane_ntup_change(ABORT,err)
+
+ implicit none
+ save
+
+ character*15 here
+ parameter(here='sane_ntuple_change')
+
+ logical ABORT
+ character*(*) err
+
+ include 'sane_ntuple.cmn'
+ include 'gen_run_info.cmn'
+
+ character*1 ifile
+ character*1 iifile
+ character*80 file
+ character*1000 pat
+
+ integer*4 ilo,fn_len
+
+ integer g_important_length
+
+ call sane_ntup_close(ABORT,err)
+
+ if(sane_ntuple_exists) then
+ ABORT=.true.
+ endif
+
+ call NO_nulls(sane_ntuple_file)
+
+ file = sane_ntuple_file
+
+ call NO_nulls(file)
+ call g_sub_run_number(file,gen_run_number)
+
+ sane_ntuple_filesegments = sane_ntuple_filesegments + 1
+ if(sane_ntuple_filesegments.eq.10)then
+ sane_ntuple_filesegments = 1
+ sane_ntuple_auxsegments = sane_ntuple_auxsegments + 1
+ endif
+ !write(*,*) 'computing ifile'
+c if(sane_ntuple_filesegments.lt.10) then
+ ifile = char(ichar('0')+sane_ntuple_filesegments)
+ iifile = char(ichar('0')+sane_ntuple_auxsegments)
+c else
+c ifile = char(ichar('a')+sane_ntuple_filesegments-10)
+c endif
+c write(*,*), 'ifile = ',ifile, file
+
+ fn_len = g_important_length(file)
+ ilo = index(file,'.hbook')
+ if((ilo.le.1).or.(ilo.gt.fn_len-5)) then
+ ilo=index(file,'.rzdat')
+ endif
+
+ if((ilo.gt.1).and.(ilo.lt.fn_len)) then
+ file = file(1:ilo-1)//'.'//iifile//'.'//ifile//file(ilo:fn_len)
+ sane_Ntuple_name = sane_Ntuple_name(1:ilo-7)//'_'//iifile//'_'//ifile
+c write(*,*)'File name is', file
+c else
+c abort=.true.
+ endif
+
+ !write(*,*) 'new file name = ',file
+
+ if(.not.abort) call sane_ntup_open(file,ABORT,err)
+
+ if(abort) then
+ err=':unable to change BigCal ntuple file segment'
+ call G_add_path(here,err)
+ else
+ pat=':changed SANE ntuple file segment'
+ call G_add_path(here,pat)
+ call G_log_message('INFO: '//pat)
+ endif
+
+ return
+ end
+
diff --git a/SANE/sane_ntup_close.f b/SANE/sane_ntup_close.f
new file mode 100644
index 0000000..d31dd40
--- /dev/null
+++ b/SANE/sane_ntup_close.f
@@ -0,0 +1,159 @@
+ subroutine sane_ntup_close(ABORT,err)
+
+ implicit none
+ save
+
+ character*14 here
+ parameter(here='sane_ntup_close')
+
+ logical ABORT
+ character*(*) err
+
+ include 'b_ntuple.cmn'
+ include 'sane_ntuple.cmn'
+ include 'gen_routines.dec'
+
+ logical HEXIST ! CERNLIB function
+
+ logical FAIL
+ character*80 why,directory,name
+ character*1000 msg
+ integer io,id,cycle,m,i,itcol,itrow,icc
+
+ err=' '
+ abort=.false.
+
+ if(.not.sane_ntuple_exists) return
+
+ call HCDIR(directory,'R') ! keep current directory
+
+ id=sane_ntuple_ID
+ io=sane_ntuple_IOchannel
+ name=sane_Ntuple_name
+
+ abort=.not.HEXIST(id)
+
+ if(abort) then
+ call G_add_path(here,err)
+ if(io.gt.0) then
+ call G_IO_control(io,'FREE',FAIL,why) ! free up
+ if(.not.fail) close(io)
+ endif
+ endif
+
+ call HCDIR(sane_ntuple_directory,' ') ! go to ntuple directory
+
+ call G_add_path(here,msg)
+ call G_log_message('INFO: '//msg)
+
+c write(*,*) HEXIST(9502),sane_ntuple_directory
+ cycle= 0
+ call HROUT(id,cycle,' ')
+c call HROUT(10100,cycle,' ')
+c call HROUT(10101,cycle,' ')
+c call HROUT(10102,cycle,' ')
+ call HROUT(10103,cycle,' ')
+ call HROUT(10104,cycle,' ')
+ call HROUT(10105,cycle,' ')
+ call HROUT(10106,cycle,' ')
+ call HROUT(10107,cycle,' ')
+ call HROUT(10108,cycle,' ')
+c call HROUT(10109,cycle,' ')
+
+c call HROUT(10111,cycle,' ')
+c call HROUT(10112,cycle,' ')
+c call HROUT(10113,cycle,' ')
+c call HROUT(10114,cycle,' ')
+ call HROUT(10121,cycle,' ')
+ call HROUT(10122,cycle,' ')
+c call HROUT(10125,cycle,' ')
+c call HROUT(10126,cycle,' ')
+ call HROUT(10128,cycle,' ')
+ do i =1,18
+ call HROUT(17100+i,cycle,' ')
+ call HROUT(17200+i,cycle,' ')
+ call HROUT(18100+i,cycle,' ')
+ call HROUT(18200+i,cycle,' ')
+ enddo
+ do i =1,8
+ call HROUT(10500+i,cycle,' ')
+ call HROUT(10510+i,cycle,' ')
+ call HROUT(10520+i,cycle,' ')
+ call HROUT(10530+i,cycle,' ')
+ call HROUT(10540+i,cycle,' ')
+ call HROUT(10560+i,cycle,' ')
+ call HROUT(10570+i,cycle,' ')
+ call HROUT(10580+i,cycle,' ')
+ call HROUT(10710+i,cycle,' ')
+ call HROUT(10720+i,cycle,' ')
+ call HROUT(10730+i,cycle,' ')
+ call HROUT(10740+i,cycle,' ')
+
+ enddo
+c if ( sane_ntuple_type .eq. 1) then
+ do i =1,28
+c call HROUT(10150+i,cycle,' ')
+c call HROUT(20150+i,cycle,' ')
+c call HROUT(20250+i,cycle,' ')
+ enddo
+c endif
+ call HROUT(10200,cycle,' ')
+ do i =0,6
+ call HROUT(10210+i,cycle,' ')
+
+ enddo
+
+* call HROUT(10300,cycle,' ')
+* call HROUT(10301,cycle,' ')
+* call HROUT(10302,cycle,' ')
+* call HROUT(10303,cycle,' ')
+* call HROUT(10304,cycle,' ')
+* call HROUT(10310,cycle,' ')
+* call HROUT(10311,cycle,' ')
+* call HROUT(10312,cycle,' ')
+* call HROUT(10313,cycle,' ')
+* call HROUT(10314,cycle,' ')
+* call HROUT(10315,cycle,' ')
+* call HROUT(10316,cycle,' ')
+* call HROUT(10317,cycle,' ')
+* call HROUT(10321,cycle,' ')
+* call HROUT(10322,cycle,' ')
+* call HROUT(10323,cycle,' ')
+* call HROUT(10324,cycle,' ')
+
+
+
+c call HROUT(10550,cycle,' ')
+c call HROUT(10551,cycle,' ')
+
+c call HROUT(10601,cycle,' ')
+c call HROUT(10611,cycle,' ')
+c call HROUT(10602,cycle,' ')
+c call HROUT(10612,cycle,' ')
+c call HROUT(10603,cycle,' ')
+c call HROUT(10613,cycle,' ')
+c call HROUT(10604,cycle,' ')
+c call HROUT(10614,cycle,' ')
+c call HROUT(10620,cycle,' ')
+c call HROUT(10621,cycle,' ')
+ call HROUT(10622,cycle,' ')
+ call HROUT(10623,cycle,' ')
+
+c call HPRINT(9502)
+
+ write(*,*)name!,10623
+ call HREND(name)
+ call G_IO_control(io,'FREE',ABORT,err)
+ close(io)
+
+ call HCDIR(directory,' ') ! return to "current" directory
+
+ sane_ntuple_directory=' '
+ sane_ntuple_exists=.false.
+ sane_ntuple_IOchannel= 0
+
+ if(abort) call G_add_path(here,err)
+
+ return
+ end
+
diff --git a/SANE/sane_ntup_init.f b/SANE/sane_ntup_init.f
new file mode 100644
index 0000000..cd44768
--- /dev/null
+++ b/SANE/sane_ntup_init.f
@@ -0,0 +1,182 @@
+ Subroutine sane_ntup_init(ABORT,err)
+ implicit none
+ save
+
+ character*13 here
+ parameter(here='sane_ntuple_init')
+ include 'b_ntuple.cmn'
+ include 'sane_ntuple.cmn'
+ include 'sane_ntuple.dte'
+ include 'gen_routines.dec'
+ include 'gen_run_info.cmn'
+
+ character*80 default_name
+ parameter(default_name='sane_ntuple')
+
+ logical ABORT
+ character*(*) err
+
+ character*80 file,file_pol,file_charge
+ character*80 name
+ character*1000 pat,msg
+ integer ilo,fn_len,m,i,j,k,unit
+ character*1 ifile
+ character*1 iifile
+ real*8 tcharge_old ,tcharge_help_old,tcharge_helm_old
+ real*8 charge2s_old ,charge2s_help_old,charge2s_helm_old
+ real*8 polarea_old, polarization_old
+ integer*4 hel_p_scaler_old
+ integer*4 hel_n_scaler_old
+ integer*4 hel_p_trig_old
+ integer*4 hel_n_trig_old
+ real*8 dtime_p_old ,dtime_n_old
+ real*4 half_plate_old
+
+ common/SANEEV_old /
+ $ tcharge_old ,
+ $ charge2s_old ,
+ $ tcharge_help_old,charge2s_help_old,
+ $ tcharge_helm_old,charge2s_helm_old ,
+ $ polarea_old ,polarization_old,
+ $ hel_p_scaler_old ,
+ $ hel_n_scaler_old ,
+ $ hel_p_trig_old ,
+ $ hel_n_trig_old ,
+ $ dtime_p_old ,dtime_n_old, half_plate_old
+ err=' '
+ abort=.false.
+
+
+ if(sane_ntuple_exists) then
+ call sane_ntup_shutdown(ABORT,err)
+ if(abort) then
+ call G_add_path(here,err)
+ return
+ endif
+ endif
+ if(polarization_data_table.eq.' ')then
+ polarization_data_table = "poltemp.dat"
+ file_pol=polarization_data_table
+ OPEN(unit=22,file=file_pol)
+ polarization_data_unit = 22
+ else
+ file_pol=polarization_data_table
+ call g_sub_run_number(file_pol,gen_run_number)
+ unit=22
+ if(polarization_data_unit.gt.0)unit = polarization_data_unit
+ polarization_data_unit = unit
+ INQUIRE(FILE= file_pol, EXIST=polarization_data_open)
+ if(polarization_data_open)then
+ OPEN(unit=unit,file=file_pol)
+ read(polarization_data_unit,*)pol_id_change,polarea_old,polarization_old, half_plate_old
+c write(*,*)'HELP 11',polarea_old
+ else
+ OPEN(unit=unit,file=file_pol)
+
+ endif
+
+ endif
+ if(charge_data_table.eq.' ')then
+ charge_data_table = "chargetemp.dat"
+ file_charge=charge_data_table
+ OPEN(unit=23,file=file_charge)
+ charge_data_unit = 23
+ else
+ file_charge=charge_data_table
+ call g_sub_run_number(file_charge,gen_run_number)
+ unit=23
+ if(charge_data_unit.gt.0)unit = charge_data_unit
+ charge_data_unit = unit
+ INQUIRE(FILE= file_charge, EXIST=charge_data_open)
+ if(charge_data_open)then
+ OPEN(unit=unit,file=file_charge)
+ read(charge_data_unit,*)
+ , charge_id_change,charge2s_old,tcharge_old,
+ , tcharge_help_old,charge2s_help_old,
+ , tcharge_helm_old,charge2s_helm_old ,
+ , hel_p_scaler_old,hel_p_trig_old,dtime_p_old,
+ , hel_n_scaler_old,hel_n_trig_old,dtime_n_old
+ else
+ OPEN(unit=unit,file=file_charge)
+ endif
+
+ endif
+
+
+c if(charge_data_table.eq.' ')
+c , polarization_data_table = 'poltemp.dat'
+
+
+ call no_nulls(sane_ntuple_file) ! replace null characters with blanks
+
+ if(sane_ntuple_file.eq.' ') return
+ sane_ntuple_id = default_sane_ntuple_ID
+ sane_ntuple_name = default_name
+ if(sane_ntuple_title.eq.' ') then
+ msg = sane_ntuple_name//' '//sane_ntuple_file
+ call only_one_blank(msg)
+ sane_ntuple_title= msg
+c sane_ntuple_title= sane_ntuple_file
+
+ endif
+
+ file = sane_ntuple_file
+
+ call g_sub_run_number(file,gen_run_number)
+ if(sane_ntuple_max_segmentevents.gt.0) then
+ sane_ntuple_filesegments = 1
+ sane_ntuple_auxsegments = sane_ntuple_auxsegments + 1
+ ifile = char(ichar('0')+sane_ntuple_filesegments)
+ iifile = char(ichar('0')+sane_ntuple_auxsegments)
+ fn_len = g_important_length(file)
+ ilo=index(file,'.hbook')
+ if((ilo.le.1).or.(ilo.gt.fn_len-5))then
+ ilo=index(file,'.rzdat')
+ endif
+
+ if((ilo.gt.1).and.(ilo.lt.fn_len)) then
+ file = file(1:ilo-1)//'.'//iifile//'.'//ifile//file(ilo:fn_len)
+ sane_Ntuple_name = default_name(1:ilo-7)//'_'//iifile//'_'//ifile
+ else
+ abort=.true.
+ return
+ endif
+
+ write(*,*) ' using segmented sane rzdat files
+ $ first filename: ',file
+ else
+ write(*,*) ' Not using segmented sane rzdat files
+ $ first filename: ',file
+ endif
+
+ if(sane_ntuple_type.eq.1) then ! physics ntuple added Jul 3,2008
+ sane_ntuple_id = 9501
+ write(*,*)'SANE NT ID is',sane_ntuple_id
+ endif
+ if(sane_ntuple_type.eq.2) then ! raw ntuple
+ sane_ntuple_id = 9502
+ write(*,*)'SANE NT ID is',sane_ntuple_id
+ endif
+ if(sane_ntuple_type.eq.9) then ! whit's raw ntuple
+ sane_ntuple_id = 9509
+ write(*,*)'SANE NT ID is',sane_ntuple_id
+ endif
+
+
+ write(*,*)'SANE INIT',file,sane_ntuple_type
+
+ call sane_ntup_open(file,ABORT,err)
+
+
+ if(abort) then
+ err= ':unable to create SANE ntuple'
+ call G_add_path(here,err)
+ else
+ pat= ':created SANE ntuple'
+ call G_add_path(here,pat)
+ call G_log_message('INFO: '//pat)
+ endif
+
+ return
+
+ end
diff --git a/SANE/sane_ntup_open.f b/SANE/sane_ntup_open.f
new file mode 100644
index 0000000..6e07c46
--- /dev/null
+++ b/SANE/sane_ntup_open.f
@@ -0,0 +1,615 @@
+ Subroutine sane_ntup_open(file,ABORT,err)
+ implicit none
+ save
+
+ character*13 here
+ parameter(here='sane_ntuple_open')
+
+ logical ABORT
+ character*(*) err
+ integer iquest
+ Common /QUEST/ Iquest(100)
+
+ include 'b_ntuple.cmn'
+ include 'sane_ntuple.cmn'
+ include 'bigcal_bypass_switches.cmn'
+ include 'gen_run_info.cmn'
+ include 'gen_data_structures.cmn'
+ include 'gen_event_info.cmn'
+ include 'gen_scalers.cmn'
+ include 'sane_data_structures.cmn'
+ include 'bigcal_data_structures.cmn'
+
+ integer default_bank,default_recl, histnum,ii
+ parameter(default_bank=8000) !4 bytes/word
+ parameter(default_recl=8191) !record length
+ character*80 title,file
+ character*80 directory,name
+ character*1000 pat,msg,chform
+ integer status,size,io,id,bank,recL,iv(10),m,itcol,itrow,icc
+ real rv(10)
+
+
+ logical HEXIST !CERNLIB function
+ccccccccccccccc
+ err=' '
+ ABORT=.false.
+ if(sane_ntuple_exists) then
+ call sane_ntup_shutdown(ABORT,err)
+ if(abort) then
+ call G_add_path(here,err)
+ return
+ endif
+ endif
+
+c get any free IO channel
+
+ call g_IO_control(io,'ANY',ABORT,err)
+c sane_ntuple_exists = .not.ABORT
+ if(ABORT) then
+ call G_add_path(here,err)
+ return
+ endif
+
+ sane_ntuple_iochannel = io
+
+ id = sane_ntuple_id
+ name = sane_ntuple_name
+ title = sane_ntuple_title
+ ABORT = HEXIST(id)
+ if(ABORT) then
+ call g_IO_control(sane_ntuple_iochannel,'FREE',ABORT,err)
+ call g_build_note(':HBOOK id#$ already in use',
+ $ '$',id,' ',rv,' ',err)
+ call G_add_path(here,err)
+ return
+ endif
+
+ call HCDIR(directory,'R') !CERNLIB read current directory
+ write(*,*)'DIR ',directory,name
+c call HLIMIT(NWPAWC)
+ recL = 8191
+ iquest(10) = 512000
+ call HROPEN(io,name,file,'NQ',recL,status)
+
+ write(*,*)'ifile=',file
+ ABORT= status.ne.0
+ if(ABORT) then
+ call g_IO_control(sane_ntuple_iochannel,'FREE',ABORT,err)
+ iv(1) = status
+ iv(2) = io
+ pat= ':HROPEN error#$ opening IO#$ "'//file//'"'
+ call G_build_note(pat,'$',iv,' ',rv,' ',err)
+ call G_add_path(here,err)
+ return
+ endif
+
+ size = sane_ntuple_size
+ bank = default_bank
+ title = sane_ntuple_title
+
+ call hbset('BSIZE',8176,status)
+ call HBNT(id,title,' ')
+ if(sane_ntuple_type.eq.1 .or. (sane_ntuple_type.eq.3) .or. (sane_ntuple_type.eq.9))then
+ call HBNAME(id,'SANEEV',tcharge,'tcharge:R*8,charge2s:R*8,'//
+ $ 'tcharge_help:R*8,charge2s_help:R*8,'//
+ $ 'tcharge_helm:R*8,charge2s_helm:R*8,'//
+ $ 'polarea:R*8,polarization:R*8,'//
+ $ 'hel_p_scaler:I*4, hel_n_scaler:I*4,'//
+ $ 'hel_p_trig:I*4, hel_n_trig:I*4,'//
+ $ 'dtime_p:R*8,dtime_n:R*8,half_plate:R*4')
+ endif
+
+ if(sane_ntuple_type.ge.2 .and. sane_ntuple_type.le.6 ) then ! col-wise ntuple for cluster analysis
+ ! for calibration purposses
+ if(sane_ntuple_type.eq.2)then
+
+ call HBNAME(id,'bevinfo',bgid,'bgid:I*4,bgtype:I*4,'//
+ $ 'btrigtype:I*4')
+ call HBNAME(id,'bhits',ngooda,'ngooda:I*4,ngoodt:I*4,'//
+ $ 'ngoodta:I*4,ngoodtt:I*4,irowmax:I*4,icolmax:I*4,'//
+ $ 'max_adc:R*4')
+ call HBNAME(id,'SANEY1',y1t_hit,
+ $ 'y1t_hit[0,900]:I*4,y1t_row(y1t_hit):I*4,'//
+ $ 'y1t_tdc(y1t_hit):I*4,'//
+ $ 'y1t_y(y1t_hit):R*4')
+ call HBNAME(id,'SANEY2',y2t_hit,
+ $ 'y2t_hit[0,900]:I*4,y2t_row(y2t_hit):I*4,'//
+ $ 'y2t_tdc(y2t_hit):I*4,'//
+ $ 'y2t_y(y2t_hit):R*4')
+ call HBNAME(id,'SANEX1',x1t_hit,
+ $ 'x1t_hit[0,900]:I*4,x1t_row(x1t_hit):I*4,'//
+ $ 'x1t_tdc(x1t_hit):I*4,'//
+ $ 'x1t_x(x1t_hit):R*4')
+ call HBNAME(id,'SANECER',cer_hit,
+ $ 'cer_hit[0,50]:I*4,cer_num(cer_hit):I*4,'//
+ $ 'cer_tdc(cer_hit):I*4,cer_adcc(cer_hit):I*4')
+ call HBNAME(id,'SANEADC',ceradc_hit,
+ $ 'ceradc_hit[0,15]:I*4,ceradc_num(ceradc_hit):I*4,'//
+ $ 'cer_adc(ceradc_hit):I*4')
+ call HBNAME(id,'SANELUC',luc_hit,
+ $ 'luc_hit[0,90]:I*4,luc_row(luc_hit):I*4,'//
+ $ 'ladc_pos(luc_hit):I*4,ladc_neg(luc_hit):I*4,'//
+ $ 'ltdc_pos(luc_hit):I*4,ltdc_neg(luc_hit):I*4,'//
+ $ 'luc_y(luc_hit):R*4')
+
+
+ endif
+
+ if(bbypass_find_clusters.eq.0) then
+ call HBNAME(id,'clustblock',nclust,
+ $ 'nclust[0,50]:I*4,ncellclust(nclust)[0,50]:I*4,'//
+ $ 'ncellbad(nclust)[0,50]:I*4,'//
+ $ 'ncellx(nclust),ncelly(nclust),iycell(50,nclust),'//
+ $ 'ixcell(50,nclust),cellbad(50,nclust):L,'//
+ $ 'xcell(50,nclust),ycell(50,nclust),'//
+ $ 'eblock(50,nclust),ablock(50,nclust),'//
+ $ 'xmoment(nclust),ymoment(nclust),'//
+ $ 'eclust(nclust),aclust(nclust),'//
+ $ 'xclust(nclust),yclust(nclust)')
+ if(bbypass_calc_cluster_time.eq.0) then
+ if(bbypass_sum8.eq.0) then
+ call HBNAME(id,'clusttdc',nclust8,
+ $ 'nclust8[0,50]:I*4,'//
+ $ 'ncell8clust(nclust8)[0,10]:I*4,'//
+ $ 'irow8hit(10,nclust8)[0,56]:I*4,'//
+ $ 'icol8hit(10,nclust8)[0,4]:I*4,'//
+ $ 'nhit8clust(10,nclust8)[0,8]:I*4,'//
+ $ 's8(10,nclust8),'//
+ $ 'tcell8(10,8,nclust8),tclust8(nclust8),'//
+ $ 'tcut8(nclust8),tcut8cor(nclust8),'//
+ $ 'trms8(nclust8)')
+
+ endif
+
+ if(bbypass_sum64.eq.0) then
+ call HBNAME(id,'clusttrig',nclust64,
+ $ 'nclust64[0,50]:I*4,'//
+ $ 'ncell64clust(nclust64)[0,6]:I*4,'//
+ $ 'irow64hit(6,nclust64)[0,19]:I*4,'//
+ $ 'icol64hit(6,nclust64)[0,2]:I*4,'//
+ $ 'nhit64clust(6,nclust64)[0,8]:I*4,'//
+ $ 'tcell64(6,8,nclust64),a64(6,nclust64),'//
+ $ 's64(6,nclust64),tclust64(nclust64),'//
+ $ 'tcut64(nclust64),tcut64cor(nclust64),'//
+ $ 'trms64(nclust64)')
+ endif
+ endif
+
+
+
+ if(bbypass_calc_physics.eq.0)then
+ call HBNAME(id,'clustphys',ntrack,'ntrack[0,50]:I*4,'//
+ $ 'ibest[0,50]:I*4,thetarad(ntrack),'//
+ $ 'phirad(ntrack),energy(ntrack),'//
+ $ 'xface(ntrack),yface(ntrack),'//
+ $ 'zface(ntrack),px(ntrack),py(ntrack),pz(ntrack),'//
+ $ 'ctime_clust(ntrack)')
+ endif
+ if(sane_ntuple_type.eq.2)then
+ call HBNAME(id,'bad_clust',nmax,'nmax[0,50]:I*4,'//
+ $ 'edge_max(nmax):L,not_enough(nmax):L,'//
+ $ 'too_long_x(nmax):L,too_long_y(nmax):L,'//
+ $ 'below_thresh(nmax):L,above_max(nmax):L,'//
+ $ 'second_max(nmax):L')
+ endif
+ endif
+
+c
+c
+c
+ endif
+c isane_plots = 100
+ if(isane_plots.ne.100)then
+ isane_plots = 100
+cccc ! For physics analysis added on Jul 3 2008
+c call HBOOK2(10100,'TRACK X1',64, 1., 65., 200, -7500., -4500.,0.)
+c call HBOOK2(10101,'TRACK Y1',128,1., 129., 200, -7500., -4500.,0.)
+c call HBOOK2(10102,'TRACK Y2',128,1., 129., 200, -7500., -4500.,0.)
+c
+ call HBOOK2(10103,'TRACK X1 cer',64, 1., 65., 200, -7500., -4500.,0.)
+ call HBOOK2(10104,'TRACK Y1 cer',128,1., 129., 200, -7500., -4500.,0.)
+ call HBOOK2(10105,'TRACK Y2 cer',128,1., 129., 200, -7500., -4500.,0.)
+ call HBOOK2(10106,'TRACK X1 vs BIG',64,-22., 22., 64, -22., 22.,0.)
+ call HBOOK2(10107,'TRACK Y1 vs BIG',128,-22., 22., 128, -22., 22.,0.)
+ call HBOOK2(10108,'TRACK Y2 vs BIG',128,-22., 22., 128, -22., 22.,0.)
+c call HBOOK2(10109,'TRACK Y2 vs BIG',128,1., 129., 128, -22., 22.,0.)
+
+
+c call HBOOK2(10111,'CER TDC',8, 1., 9., 200, -4000, 500., 0.)
+c call HBOOK2(10112,'CER ADC',8, 1., 9., 100, 0.1, 5000., 0.)
+c call HBOOK1(10113,'BIGCAL TDC',400, 300.,400,0.)
+c call HBOOK2(10114,'BIGCAL TDC vs CER TDC',100, 310, 350., 100, -3000, -1000., 0.)
+ do histnum=1,18
+ call HBOOK2(17100+histnum,'Aclust vs cer TDC ',100, 0., 2000., 200, -3000, -1000., 0.)
+ call HBOOK2(17200+histnum,'Aclust vs cer TDC ',100, 0., 2000., 200, -3000, -1000., 0.)
+ call HBOOK2(18100+histnum,'Aclust vs cer TDC ',100, 0., 2000., 100, 300, 400., 0.)
+ call HBOOK2(18200+histnum,'Aclust vs cer TDC ',100, 0., 2000., 100, 300, 400., 0.)
+ enddo
+
+ do histnum=1,8
+ call HBOOK2(10500+histnum,'CER ADC vs TDC ',100, 10., 2000., 200, -3000, -1000., 0.)
+ call HBOOK2(10520+histnum,'Aclust vs cer TDC ',100, 0., 2000., 200, -3000, -1000., 0.)
+ call HBOOK2(10530+histnum,'Aclust vs cer TDC cor ',100, 0., 2000., 200, -3000, -1000., 0.)
+ call HBOOK2(10510+histnum,'BIGCAL' ,33,0., 33., 56, 0., 56., 0.)
+ call HBOOK2(10540+histnum,'CER ADC vs TDC ',100, 10., 2000., 200, -3000, -1000., 0.)
+ call HBOOK2(10560+histnum,'TRIGBIG vs Cer TDC ',30, 25., 55., 200, -3000, -1000., 0.)
+ call HBOOK2(10570+histnum,'TRIGBETA vs Cer TDC ',30, 45., 75., 200, -3000, -1000., 0.)
+ call HBOOK2(10580+histnum,'TRIGBIG C vs Cer TDC ',30, 25., 55., 200, -3000, -1000., 0.)
+
+c if(grun.le.72487)then
+ call HBOOK2(10710+histnum,'BIGCAL TDC vs CER TDC',20, 1, 21., 200, -500, 1000., 0.)
+ call HBOOK2(10720+histnum,'BIGCAL TDC vs CER TDC',20, 1, 21., 200, -500, 1000., 0.)
+c else
+c call HBOOK2(10710+histnum,'BIGCAL TDC vs CER TDC',20, 1, 21., 60, -30, 30., 0.)
+c call HBOOK2(10720+histnum,'BIGCAL TDC vs CER TDC',20, 1, 21., 60, -30, 30., 0.)
+
+c endif
+ call HBOOK2(10730+histnum,'BIGCAL TDC vs CER TDC',20, 1, 21., 200, -500, 1000., 0.)
+ call HBOOK2(10740+histnum,'BIGCAL TDC vs CER TDC',20, 1, 21., 200, -500, 1000., 0.)
+
+ enddo
+ call HBOOK2(10121,'LUC TDCPOS',28,1., 29., 200, -3500., 0., 0.)
+ call HBOOK2(10122,'LUC TDCNEG',28,1., 29., 200, -3500., 0., 0.)
+c call HBOOK2(10125,'LUC ADCPOS',28,1., 29., 200, 0.1, 4000., 0.)
+c call HBOOK2(10126,'LUC ADCNEG',28,1., 29., 200, 0.1, 4000., 0.)
+c call HBOOK2(10131,'LUC TDCPOS cut',28,1., 29., 1500, -2250., -850., 0.)
+c call HBOOK2(10132,'LUC TDCNEG cut',28,1., 29., 1500, -2250., -850., 0.)
+c call HBOOK2(10135,'LUC ADCPOS cut',28,1., 29., 200, 0.1, 4000., 0.)
+c call HBOOK2(10136,'LUC ADCNEG cut',28,1., 29., 200, 0.1, 4000., 0.)
+ if(sane_ntuple_type.eq.1) then
+ call HBOOK2(10128,'LUC_Y vs BIG_Y',40,-120., 120., 60, -120., 120., 0.)
+ do ii=1,28
+cc call HBPROF(10150+ii,'LUC_X vs BIG_X',100,-60., 60., 100, -60., 60., 0.)
+c call HBPROF(10150+ii,'LUC_X vs BIG_X',100,-65., 65., -60, 60., 'S')
+c call HBOOK2(20250+ii,'Big_Y vs BIG_X',100,-100., 100, 120., -120, 120., 0.)
+c call HBOOK2(20150+ii,'LUC_X vs BIG_X',100,-100., 300, 80., -60, 100., 0.)
+ enddo
+
+
+c call HBOOK2(10220,'LUC_Y vs BIG_Y', 60, -120., 120., 120,-20., 20., 0.)
+c call HBOOK2(10221,'LUC_Y vs BIG_Y', 60, -120., 120., 120,-20., 20., 0.)
+c call HBOOK2(10221,'LUC_Y vs BIG_Yo',120,-20., 20., 60, -120., 120., 0.)
+c call HBOOK2(10222,'dLUC_Y vs BIG_X', 80,-80., 80., 60, -20., 20., 0.)
+c call HBOOK2(10223,'LUC_X vs BIG_Xo',60,-20., 20., 60, -120., 120., 0.)
+cc call HBOOK2(10225,'dLUC_Y vs e',120,-30., 30., 40, 0., 2.4, 0.)
+c call HBPROF(10225,'dLUC_Y vs e',40, 0., 2.6, -20, 20., 'S')
+c call HBOOK2(10226,'dLUC_X vs e',120,-30., 30., 16, 0.4, 2., 0.)
+c call HBOOK2(10227,'Big_Y vs BIG_Yo', 120, -120., 120.,120,-10., 10., 0.)
+
+ endif
+ call HBOOK2(10200,'BIGCAL' ,33,0., 33., 56, 0., 56., 0.)
+
+ call HBOOK2(10210,'SLOW RASTER ADC' ,90,5000., 8000., 90, 5000., 8000., 0.)
+ call HBOOK2(10211,'FAST RASTER ADC' ,90,2000., 5000., 90, 2000., 5000., 0.)
+ call HBOOK2(10212,'SLOW RASTER ADC Corrected' ,90,-2.5, 2.5, 90, -2.5, 2.5, 0.)
+ call HBOOK2(10213,'FAST RASTER ADC Corrected' ,90,-2.5, 2.5, 90, -2.5, 2.5, 0.)
+ call HBOOK2(10214,'SEM X Y' ,90,-3., 3., 90, -3., 3., 0.)
+ call HBOOK2(10215,'SLOW RASTER ADC' ,90,5000., 8000., 90, 5000., 8000., 0.)
+ call HBOOK2(10216,'SLOW RASTER ADC Corrected' ,90,-3., 3., 90, -3., 3., 0.)
+
+c call HBOOK2(10300,'X_HMS vs xclust' ,60,-60., 60., 60, -60., 60., 0.)
+c call HBOOK2(10301,'Y_HMS vs yclust' ,120,-120., 120., 120, -120., 120., 0.)
+c call HBOOK2(10302,'X_HMS vs Y_HMS' ,60,-60., 60., 120, -120., 120., 0.)
+c call HBOOK2(10303,'Xclust vs Yclust' ,60,-60., 60., 120, -120., 120., 0.)
+c call HBOOK2(10304,'DX vs DY' ,40,-40., 40., 60, -60., 60., 0.)
+c call HBOOK2(10310,'hsdelta vs hsyptar' ,40,-20., 20., 100, -0.1, 0.1, 0.)
+c call HBOOK2(10311,'hsdelta vs hsxptar' ,40,-20., 20., 200, -0.1, 0.3, 0.)
+c call HBOOK2(10312,'dpel_hms vs hsyptar' ,40,-0.2, 0.2, 100, -0.1, 0.1, 0.)
+c call HBOOK2(10313,'dpel_hms vs hsxptar' ,40,-0.2, 0.2, 200, -0.1, 0.3, 0.)
+c call HBOOK2(10314,'dpel_hms vs hsxtar' ,40,-0.2, 0.2, 100, -3, 3, 0.)
+c call HBOOK2(10315,'dpel_hms vs hsytar' ,40,-0.2, 0.2, 100, -3, 3, 0.)
+c call HBOOK2(10316,'raster_x vs xtar' ,100,-3., 3., 100, -3., 3., 0.)
+c call HBOOK2(10317,'raster_y vs ytar' ,100,-3., 3., 100, -3., 3., 0.)
+
+
+
+c call HBOOK1(10321, 'hsdelta' , 100,-.1,.1,0.)
+c call HBOOK1(10322, 'W2', 100, -0.3, 0.6,0.)
+c call HBOOK2(10323,' W2 vs hsxtar' ,100,-0.3, 0.3, 100, -0.1, 0.1, 0.)
+c call HBOOK2(10324,' W2 vs hsxtar' ,100,-0.3, 0.3, 100, -3, 3, 0.)
+
+
+ call HBOOK2(10550,'Ytracker-Yrec vs P' ,100, 0.7, 1.5, 100, -1.5, 1.5, 0.)
+ call HBOOK2(10551,'Xtracker-Xrec vs P' ,100, 0.7, 1.5, 100, -1.5, 1.5, 0.)
+
+c call HBOOK1(10601,'Xbj 2.5<Q2<3.5 helicity normalized' ,30, 0.2, 2.0 ,0.)
+c call HBOOK1(10611,'Xbj 2.5<Q2<3.5 no helicity normalized' ,30, 0.2, 2.0 ,0.)
+c call HBOOK1(10602,'Xbj 3.5<Q2<4.5 helicity normalized' ,30, 0.2, 2.0 ,0.)
+c call HBOOK1(10612,'Xbj 3.5<Q2<4.5 no helicity normalized' ,30, 0.2, 2.0 ,0.)
+c call HBOOK1(10603,'Xbj 4.5<Q2<5.5 helicity normalized' ,30, 0.2, 2.0 ,0.)
+c call HBOOK1(10613,'Xbj 4.5<Q2<5.5 no helicity normalized' ,30, 0.2, 2.0 ,0.)
+c call HBOOK1(10604,'Xbj 5.5<Q2<6.5 helicity normalized' ,30, 0.2, 2.0 ,0.)
+c call HBOOK1(10614,'Xbj 5.5<Q2<6.5 no helicity normalized' ,30, 0.2, 2.0 ,0.)
+
+c call HBOOK2(10620,'Xbj vs Q2' ,140, 0.1, 1.5, 100, 0., 8., 0.)
+c call HBOOK2(10621,'W2 vs Q2' ,100, 0.5, 2.5, 100, 0., 8., 0.)
+ call HBOOK1(10622,'Mpi0' ,200, 0.05, 0.25, 0.)
+ call HBOOK1(10623,'Mpi0_angles' ,200, 0.05, 0.25, 0.)
+c
+c
+c Physics Histograms
+c
+ endif
+
+! if(sane_ntuple_type.lt.4.and.sane_ntuple_type.ge.4)then
+ if(sane_ntuple_type.lt.4)then
+
+ call HBNAME(id,'TRIGGERTIME',T_trgHMS,
+ $ 'T_trgHMS:R*4, T_trgBIG:R*4, T_trgPI0:R*4,'//
+ $ 'T_trgBETA:R*4, T_trgCOIN1:R*4,T_trgCOIN2:R*4')
+ call HBNAME(id,'SANECER',cer_hit,
+ $ 'cer_hit[0,50]:I*4,cer_num(cer_hit):I*4,'//
+ $ 'cer_tdc(cer_hit):I*4,cer_adcc(cer_hit):I*4')
+
+ endif
+ if(sane_ntuple_type.eq.3) then ! col-wise ntuple
+ call HBNAME(id,'hmsblk',TH_HMS,'TH_HMS,PH_HMS,E_HMS,'//
+ $ 'X_HMS,Y_HMS,dPel_HMS')
+ call HBNAME(id,'HMSINFO',hms_p,
+ $ 'hms_p:R*4,hms_e:R*4,hms_theta:R*4,hms_phi:R*4,'//
+ $ 'hsxfp_s:R*4,hsyfp_s:R*4,hsxpfp_s:R*4,hsypfp_s:R*4,'//
+ $ 'hms_xtar:R*4,hms_ytar:R*4,hms_yptar:R*4,'//
+ $ 'hms_xptar:R*4,hms_delta:R*4,hms_start:R*4,'//
+ $ 'hsshtrk_s:R*4, hsshsum_s:R*4, hsbeta_s:R*4,'//
+ $ 'hms_cer_npe1:R*4,hms_cer_npe2:R*4,'//
+ $ ' hms_cer_adc1:R*4,hms_cer_adc2:R*4')
+ call HBNAME(id,'RASTINFO',rast_x,
+ $ 'rast_x:R*4,rast_y:R*4,'//
+ $ 'slow_rast_x:R*4,slow_rast_y:R*4,'//
+ $ 'sem_x:R*4,sem_y:R*4,'//
+ $ 'i_helicity:I*4')
+ endif
+
+ if(sane_ntuple_type.eq.1) then ! col-wise ntuple
+ ! for Physics purposses
+ call HBNAME(id,'RASTINFO',rast_x,
+ $ 'rast_x:R*4,rast_y:R*4,'//
+ $ 'slow_rast_x:R*4,slow_rast_y:R*4,'//
+ $ 'sem_x:R*4,sem_y:R*4,'//
+ $ 'i_helicity:I*4')
+
+ call HBNAME(id,'bevinfo',bgid,'bgid:I*4,bgtype:I*4,'//
+ $ 'btrigtype:I*4')
+ call HBNAME(id,'bhits',ngooda,'ngooda:I*4,ngoodt:I*4,'//
+ $ 'ngoodta:I*4,ngoodtt:I*4,irowmax:I*4,icolmax:I*4,'//
+ $ 'max_adc:R*4')
+
+
+
+ call HBNAME(id,'SANEPHYS',n_clust,
+ $ 'n_clust[0,15]:I*4,'//
+ $ 'E_clust(n_clust):R*4,'//
+ $ 'X_clust(n_clust):R*4, Y_clust(n_clust):R*4,'//
+ $ 'Z_clust(n_clust):R*4,'//
+ $ 'X_clust_r(n_clust):R*4, Y_clust_r(n_clust):R*4,'//
+ $ 'Z_clust_r(n_clust):R*4,'//
+ $ 'luc_h(n_clust)[0,20]:I*4,'//
+ $ 'X_luc(20,n_clust), Y_luc(20,n_clust), Z_luc(20,n_clust),'//
+ $ 'X_luc_r(20,n_clust),Y_luc_r(20,n_clust),'//
+ $ 'Z_luc_r(20,n_clust),'//
+ $ 'trc_hx(n_clust)[0,20]:I*4,'//
+ $ 'X_trc(20,n_clust),'//
+ $ 'Z_trc(20,n_clust),'//
+ $ 'trc_hy1(n_clust)[0,20]:I*4,'//
+ $ 'Y1_trc(20,n_clust),'//
+ $ 'Z1_trc(20,n_clust),'//
+ $ 'trc_hy2(n_clust)[0,20]:I*4,'//
+ $ 'Y2_trc(20,n_clust),'//
+ $ 'Z2_trc(20,n_clust),'//
+ $ 'Tr_Vertex(3,n_clust), Tr_Vertex_r(3,n_clust),'//
+ $ 'cer_h(n_clust)[0,20]:I*4,'//
+ $ 'cer_geom(n_clust)[0,20]:I*4,'//
+ $ 'cerb_time(n_clust):I*4,'//
+ $ 'cerb_adc(n_clust):I*4,'//
+ $ 'bigc_time(n_clust):I*4,'//
+ $ 'bigc_adc(n_clust):I*4,'//
+ $ 'cerbc_num(n_clust):I*4,'//
+ $ 'Theta_e(n_clust):R*4,Phi_e(n_clust):R*4,'//
+ $ 'Delta_Y(n_clust):R*4,Delta_X(n_clust):R*4,'//
+ $ 'X_Bjorken(n_clust):R*4, Q2(n_clust):R*4,'//
+ $ ' W2(n_clust):R*4, ENue(n_clust):R*4')
+c call HBNAME(id,'SANEADC',ceradc_hit,
+c $ 'ceradc_hit[0,15]:I*4,ceradc_num(ceradc_hit):I*4,'//
+c $ 'cer_adc(ceradc_hit):I*4')
+
+ endif
+
+cccccccc InSANE Ntuple
+ if(sane_ntuple_type.eq.9) then ! whits ntuple
+c This stuff is the same as the first part of sane_ntuple_type.eq.2
+c below
+ call HBNAME(id,'bevinfo',bgid,'bgid:I*4,bgtype:I*4,'//
+ $ 'btrigtype:I*4')
+ call HBNAME(id,'bhits',ngooda,'ngooda:I*4,ngoodt:I*4,'//
+ $ 'ngoodta:I*4,ngoodtt:I*4,irowmax:I*4,icolmax:I*4,'//
+ $ 'max_adc:R*4')
+ call HBNAME(id,'SANEY1',y1t_hit,
+ $ 'y1t_hit[0,900]:I*4,y1t_row(y1t_hit):I*4,'//
+ $ 'y1t_tdc(y1t_hit):I*4,'//
+ $ 'y1t_y(y1t_hit):R*4')
+ call HBNAME(id,'SANEY2',y2t_hit,
+ $ 'y2t_hit[0,900]:I*4,y2t_row(y2t_hit):I*4,'//
+ $ 'y2t_tdc(y2t_hit):I*4,'//
+ $ 'y2t_y(y2t_hit):R*4')
+ call HBNAME(id,'SANEX1',x1t_hit,
+ $ 'x1t_hit[0,900]:I*4,x1t_row(x1t_hit):I*4,'//
+ $ 'x1t_tdc(x1t_hit):I*4,'//
+ $ 'x1t_x(x1t_hit):R*4')
+ call HBNAME(id,'SANECER',cer_hit,
+ $ 'cer_hit[0,50]:I*4,cer_num(cer_hit):I*4,'//
+ $ 'cer_tdc(cer_hit):I*4,cer_adcc(cer_hit):I*4')
+ call HBNAME(id,'SANEADC',ceradc_hit,
+ $ 'ceradc_hit[0,15]:I*4,ceradc_num(ceradc_hit):I*4,'//
+ $ 'cer_adc(ceradc_hit):I*4')
+ call HBNAME(id,'SANELUC',luc_hit,
+ $ 'luc_hit[0,90]:I*4,luc_row(luc_hit):I*4,'//
+ $ 'ladc_pos(luc_hit):I*4,ladc_neg(luc_hit):I*4,'//
+ $ 'ltdc_pos(luc_hit):I*4,ltdc_neg(luc_hit):I*4,'//
+ $ 'luc_y(luc_hit):R*4')
+
+c Test include for LUCITE_SANE_RAW_SCIN common block
+c call HBNAME(id,'LUCITE_S',
+c $ LUCITE_SANE_RAW_COUNTER_NUM,
+c $ 'LUCITE_SANE_RAW_COUNTER_NUM[0,190]:I*4,'//
+c $ 'LUCITE_SANE_RAW_COUNTER_NUM2[0,190]:I*4,'//
+c $ 'LUCITE_SANE_RAW_COUNTER_NUM3[0,190]:I*4,'//
+c $ 'LUCITE_SANE_RAW_ADC_POS(LUCITE_SANE_RAW_COUNTER_NUM):I*4,'//
+c $ 'LUCITE_SANE_RAW_ADC_NEG(LUCITE_SANE_RAW_COUNTER_NUM):I*4,'//
+c $ 'LUCITE_SANE_RAW_TDC_POS(LUCITE_SANE_RAW_COUNTER_NUM2):I*4,'//
+c $ 'LUCITE_SANE_RAW_TDC_NEG(LUCITE_SANE_RAW_COUNTER_NUM3):I*4,'//
+c $ 'LUCITE_SANE_RAW_TOT_HITS[0,190]:I*4,'//
+c $ 'LUCITE_SANE_RAW_TOT_HITS2[0,190]:I*4,'//
+c $ 'LUCITE_SANE_RAW_TOT_HITS3[0,190]:I*4,'//
+c $ 'LUCITE_SANE_RAW_PLANE(LUCITE_SANE_RAW_COUNTER_NUM):I*4,'//
+c $ 'LUCITE_SANE_RAW_PLANE2(LUCITE_SANE_RAW_COUNTER_NUM2):I*4,'//
+c $ 'LUCITE_SANE_RAW_PLANE3(LUCITE_SANE_RAW_COUNTER_NUM3):I*4')
+c Now we include the raw BIGCAL ADC and TDC values
+ call HBNAME(id,'BIGCAL_RAW_TDC',BIGCAL_TDC_NHIT,
+ $ 'BIGCAL_TDC_NHIT[0,1792]:I*4,'//
+ $ 'BIGCAL_TDC_RAW_IGROUP(bigcal_tdc_nhit):I*4,'//
+ $ 'BIGCAL_TDC_RAW_IROW(bigcal_tdc_nhit):I*4,'//
+ $ 'BIGCAL_TDC_RAW(bigcal_tdc_nhit):I*4')
+ call HBNAME(id,'BIGCAL_RAW_ADC',BIGCAL_PROT_NHIT,
+ $ 'BIGCAL_PROT_NHIT[0,1024]:I*4,'//
+ $ 'BIGCAL_PROT_IX(BIGCAL_PROT_NHIT):I*4,'//
+ $ 'BIGCAL_PROT_IY(BIGCAL_PROT_NHIT):I*4,'//
+ $ 'BIGCAL_PROT_ADC_RAW(BIGCAL_PROT_NHIT):I*4,'//
+ $ 'BIGCAL_RCS_NHIT[0,720]:I*4,'//
+ $ 'BIGCAL_RCS_IX(BIGCAL_RCS_NHIT):I*4,'//
+ $ 'BIGCAL_RCS_IY(BIGCAL_RCS_NHIT):I*4,'//
+ $ 'BIGCAL_RCS_ADC_RAW(BIGCAL_RCS_NHIT):I*4')
+ call HBNAME(id,'bigcal_raw_atrig',bigcal_atrig_nhit,
+ $ 'BIGCAL_ATRIG_NHIT[0,38]:I*4,'//
+ $ 'BIGCAL_ATRIG_IGROUP(bigcal_atrig_nhit):I*4,'//
+ $ 'BIGCAL_ATRIG_IHALF(bigcal_atrig_nhit):I*4,'//
+ $ 'BIGCAL_ATRIG_ADC_RAW(bigcal_atrig_nhit):I*4')
+ call HBNAME(id,'bigcal_raw_ttrig',bigcal_ttrig_nhit,
+ $ 'BIGCAL_TTRIG_NHIT[0,336]:I*4,'//
+ $ 'BIGCAL_TTRIG_IGROUP(bigcal_ttrig_nhit):I*4,'//
+ $ 'BIGCAL_TTRIG_IHALF(bigcal_ttrig_nhit):I*4,'//
+ $ 'BIGCAL_TTRIG_TDC_RAW(bigcal_ttrig_nhit):I*4')
+ call HBNAME(id,'gen_event_info', gen_event_ID_number,
+ $ 'gen_event_ID_number:I,gen_event_type:I,'//
+ $ 'gen_event_class:I,gen_event_ROC_summary:I,'//
+ $ 'gen_event_sequence_N:I,gen_event_trigtype(12):I')
+ call HBNAME(id,'BEAMCURRENT', gbcm1_gain,
+ & 'gbcm1_gain:R*8,gbcm2_gain:R*8,gbcm3_gain:R*8,gunser_gain:R*8'//
+ & 'gbcm1_offset:R*8,gbcm2_offset:R*8,gbcm3_offset:R*8,'//
+ & 'gunser_offset:R*8,'//
+ & 'gbcm1_charge:R*8,gbcm2_charge:R*8,gbcm3_charge:R*8,'//
+ & 'gunser_charge:R*8,'//
+ & 'gbcm1_charge_help:R*8,gbcm1_charge_helm:R*8,'//
+ & 'gbcm2_charge_help:R*8,gbcm2_charge_helm:R*8'//
+ & 'g_beam_on_bcm_charge(2):R*8,g_beam_on_bcm_charge_help(2):R*8'//
+ & 'g_beam_on_bcm_charge_helm(2):R*8,g_beam_on_thresh_cur(2):I*4'//
+ & 'gbcm1_index:I*4,gbcm2_index:I*4,gbcm3_index:I*4,'//
+ & 'gunser_index:I*4,bcm_for_threshold_cut:I*4,'//
+ & 'gscaler_event_num:I*4' )
+c Insert into a scalers ntuple 9504
+
+c $ 'tkscaler_skipped(32):R*8,tkscalernroll(32):I,'//
+c $ 'tkscaler_old(32):R*8,tkscaler_saved(32):R*8,'//
+c $ 'bcscaler(nbcscalers):R*8,'//
+c $ 'bcscaler_change(nbcscalers):R*8')
+c $ 'bcscaler_skipped(nbcscalers):R*8')
+c,bcscalernroll(271):I')
+c//
+c $ 'bcscaler_old(271):R*8,bcscaler_saved(271):R*8,'//
+c $ 'lucscaler(12):R*8,'//
+c $ 'lucscaler_change(12):R*8')
+c $ 'lucscaler_skipped(12):R*8,lucscalernroll(12):I,'//
+c $ 'lucscaler_old(12):R*8,lucscaler_saved(12):R*8')
+ call HBNAME(id,'TRIGGERTIME',T_trgHMS,
+ $ 'T_trgHMS:R*4, T_trgBIG:R*4, T_trgPI0:R*4,'//
+ $ 'T_trgBETA:R*4, T_trgCOIN1:R*4,T_trgCOIN2:R*4')
+
+ call HBNAME(id,'GEN_BEAM',GEBEAM,
+ $ 'GEBEAM:I*4, GPBEAM:I*4, G_BEAM_TARGET_S:I*4,'//
+ $ 'ncalls_calc_ped:I*4,gbeam_helicity:I*4,'//
+ $ 'gbeam_helicity_ADC:I*4,gbeam_helicity_TS:I*4,'//
+ $ 'GBEAM_X:R*4,GBEAM_Y:R*4,'//
+ $ 'GBEAM_XP:R*4, GBEAM_YP:R*4,geloss:R*4')
+
+
+
+ call HBNT(id+1,'SCALERS1','')
+! call HBNT(id+2,title//'Scalers2',' ')
+! call HBNT(id+3,title//'Scalers3',' ')
+! call HBNT(id+4,title//'Scalers4',' ')
+! call HBNT(id+5,title//'Scalers5',' ')
+ call HBNAME(id+1,'SCALERS1',nbcscalers,
+ $ 'nbcscalers[0,272]:I,runtime:R*8, runtimebeam:R*8,'//
+ $ 'beamonruntime(2):R*8,beamonruntimehelp(2):R*8,'//
+ $ 'beamonruntimehelm(2):R*8,cerscaler(12):R*8,'//
+ $ 'cerscaler_change(12):R*8,'//
+c $ 'cerscaler_skipped(12):R*8,cerscalernroll(12):I,'//
+c $ 'cerscaler_old(12):R*8,cerscaler_saved(12):R*8,'//
+ $ 'tkscaler(32):R*8,'//
+ $ 'tkscaler_change(32):R*8')
+
+ call HBNAME(id+1,'gen_event_info', gen_event_ID_number,
+ $ 'gen_event_ID_number:I,gen_event_type:I,'//
+ $ 'gen_event_class:I,gen_event_ROC_summary:I,'//
+ $ 'gen_event_sequence_N:I,gen_event_trigtype(12):I')
+
+ call HBNAME(id,'hmsblk',TH_HMS,'TH_HMS,PH_HMS,E_HMS,'//
+ $ 'X_HMS,Y_HMS,dPel_HMS')
+ call HBNAME(id,'HMSINFO',hms_p,
+ $ 'hms_p:R*4,hms_e:R*4,hms_theta:R*4,hms_phi:R*4,'//
+ $ 'hsxfp_s:R*4,hsyfp_s:R*4,hsxpfp_s:R*4,hsypfp_s:R*4,'//
+ $ 'hms_xtar:R*4,hms_ytar:R*4,hms_yptar:R*4,'//
+ $ 'hms_xptar:R*4,hms_delta:R*4,hms_start:R*4,'//
+ $ 'hsshtrk_s:R*4, hsshsum_s:R*4, hsbeta_s:R*4,'//
+ $ 'hms_cer_npe1:R*4,hms_cer_npe2:R*4,'//
+ $ ' hms_cer_adc1:R*4,hms_cer_adc2:R*4')
+ call HBNAME(id,'RASTINFO',rast_x,
+ $ 'rast_x:R*4,rast_y:R*4,'//
+ $ 'slow_rast_x:R*4,slow_rast_y:R*4,'//
+ $ 'sem_x:R*4,sem_y:R*4,'//
+ $ 'i_helicity:I*4')
+
+c call HBNAME(id,'HMSINFO',hms_p,
+c $ 'hms_p:R*4,hms_e:R*4,hms_theta:R*4,hms_phi:R*4,'//
+c $ 'hsxfp_s:R*4,hsyfp_s:R*4,hsxpfp_s:R*4,hsypfp_s:R*4,'//
+c $ 'hms_xtar:R*4,hms_ytar:R*4,hms_yptar:R*4,'//
+c $ 'hms_xptar:R*4,hms_delta:R*4,hms_start:R*4,'//
+c $ 'hsshtrk_s:R*4, hsshsum_s:R*4, hsbeta_s:R*4,'//
+c $ 'rast_x:R*4,rast_y:R*4,'//
+c $ 'slow_rast_x:R*4,slow_rast_y:R*4,'//
+c $ 'sem_x:R*4,sem_y:R*4,'//
+c $ 'i_helicity:I*4,'//
+c $ 'hms_cer_npe1:R*4,hms_cer_npe2:R*4,'//
+c $ 'hms_cer_adc1:R*4,hms_cer_adc2:R*4')
+
+ endif ! sane_ntuple_type.eq.9
+
+ call HCDIR(sane_ntuple_directory,'R') ! record ntuple directory
+ write(*,*)'SANE DIR ',sane_ntuple_directory
+ call HCDIR(directory,' ') !reset CERNLIB directory
+
+ sane_ntuple_exists = HEXIST(sane_ntuple_id)
+
+ abort = .not.sane_ntuple_exists
+
+ iv(1) = id
+ iv(2) = io
+ pat = 'Ntuple id#$ [' // sane_ntuple_directory // '/]' //
+ $ name // ' IO#$ "' // file // '"'
+ call G_build_note(pat,'$',iv,' ',rv,' ',msg)
+
+ call sub_string(msg,'/]','/]')
+
+ if(abort) then
+ err = 'unable to create '//msg
+ call G_add_path(here,err)
+ else
+ pat=':created '//msg
+ call G_add_path(here,pat)
+ call G_log_message('INFO: '//pat)
+ endif
+
+ return
+
+
+ end
diff --git a/SANE/sane_ntup_register.f b/SANE/sane_ntup_register.f
new file mode 100644
index 0000000..85438c9
--- /dev/null
+++ b/SANE/sane_ntup_register.f
@@ -0,0 +1,29 @@
+ subroutine sane_ntup_register(ABORT,err)
+
+ implicit none
+ save
+
+ character*17 here
+ parameter(here='sane_ntuple_register')
+
+ logical ABORT
+ character*(*) err
+
+ include 'b_ntuple.cmn'
+ include 'sane_ntuple.cmn'
+ include 'gen_routines.dec'
+
+ integer ierr
+
+ err=' '
+ abort=.false.
+ write(*,*)'SANE REGISTERING VARIABLES'
+ call G_reg_C('sane_ntuple',sane_ntuple_file,ABORT,err)
+
+ if(abort) then
+ call G_prepend(':unable to register-',err)
+ call G_add_path(here,err)
+ endif
+
+ return
+ end
diff --git a/SANE/sane_ntup_shutdown.f b/SANE/sane_ntup_shutdown.f
new file mode 100644
index 0000000..86e44ae
--- /dev/null
+++ b/SANE/sane_ntup_shutdown.f
@@ -0,0 +1,45 @@
+ subroutine sane_ntup_shutdown(ABORT,err)
+c final shutdown of BigCal ntuple
+ implicit none
+ save
+
+ character*17 here
+ parameter(here='sane_ntuple_shutdown')
+
+ logical abort
+ character*(*) err
+
+ include 'b_ntuple.cmn'
+ include 'sane_ntuple.cmn'
+ include 'gen_routines.dec'
+
+ logical fail
+ character*80 why,directory,name
+ character*1000 msg
+ integer io,id,cycle,m
+
+ err=' '
+ abort=.false.
+
+ if(.not.sane_ntuple_exists) return ! nothing to do
+
+ call sane_ntup_close(ABORT,err)
+
+ if(sane_ntuple_exists) then
+ abort=.true.
+ endif
+
+ sane_ntuple_ID=0
+ sane_ntuple_name=' '
+ sane_ntuple_file=' '
+ sane_ntuple_title=' '
+ sane_ntuple_size=0
+ do m=1,sanemax_ntuple_size
+ sane_ntuple_tag(m)= ' '
+ sane_ntuple_contents(m) = 0.
+ enddo
+
+ if(abort) call G_add_path(here,err)
+
+ return
+ end
diff --git a/SANE/sane_ntuple_keep.f b/SANE/sane_ntuple_keep.f
new file mode 100644
index 0000000..1d6733e
--- /dev/null
+++ b/SANE/sane_ntuple_keep.f
@@ -0,0 +1,641 @@
+ subroutine sane_ntuple_keep(ABORT,err)
+
+ implicit none
+ save
+
+ character*13 here
+ parameter(here='sane_ntuple_keep')
+
+ logical abort
+ character*(*) err
+ integer i,j,status(100,100),k,m
+
+ include 'b_ntuple.cmn'
+ include 'bigcal_data_structures.cmn'
+ include 'bigcal_tof_parms.cmn'
+ include 'hms_data_structures.cmn'
+ include 'bigcal_gain_parms.cmn'
+ include 'gen_event_info.cmn'
+ include 'gen_data_structures.cmn'
+ include 'gep_data_structures.cmn'
+ include 'sane_ntuple.cmn'
+ include 'sane_data_structures.cmn'
+ include 'sem_data_structures.cmn'
+ INCLUDE 'h_ntuple.cmn'
+ include 'f1trigger_data_structures.cmn'
+ include 'hms_calorimeter.cmn'
+ include 'gen_detectorids.par'
+ include 'gen_scalers.cmn'
+ include 'gen_run_info.cmn'
+ logical HEXIST ! CERNLIB function
+ integer t_sane,l_sane,cer_sane
+ integer icycle,inum,ihit
+ real*8 Eb,theta_big, phi_big!,ccx,ccy,ccz
+ real P_el(4),p_e,WW2
+ common/FAKEBIG/Eb,theta_big, phi_big
+ real*8 tcharge_old,tcharge_help_old,tcharge_helm_old
+ real*8 charge2s_old,charge2s_help_old,charge2s_helm_old
+ real*8 polarea_old ,polarization_old
+ integer*4 hel_p_scaler_old
+ integer*4 hel_n_scaler_old
+ integer*4 hel_p_trig_old
+ integer*4 hel_n_trig_old
+ real*8 dtime_p_old ,dtime_n_old
+ real*4 half_plate_old
+ common/SANEEV_old /
+ $ tcharge_old ,
+ $ charge2s_old ,
+ $ tcharge_help_old,charge2s_help_old,
+ $ tcharge_helm_old,charge2s_helm_old ,
+ $ polarea_old ,polarization_old,
+ $ hel_p_scaler_old ,
+ $ hel_n_scaler_old ,
+ $ hel_p_trig_old ,
+ $ hel_n_trig_old ,
+ $ dtime_p_old ,dtime_n_old,half_plate_old
+
+
+ real Mp
+ parameter(Mp=.938272)
+
+
+ err=' '
+ ABORT=.false.
+c write(*,*)'Starting sane'
+c INQUIRE(FILE="input.txt",EXIST=file_exist)
+c write(*,*)file_exist
+
+ if(sane_ntuple_max_segmentevents.gt.0) then
+ if(sane_ntuple_segmentevents.gt.sane_ntuple_max_segmentevents) then
+ call sane_ntup_change(ABORT,err)
+ sane_ntuple_segmentevents=0
+ else
+ sane_ntuple_segmentevents = sane_ntuple_segmentevents + 1
+ endif
+ endif
+
+ if(.not.sane_ntuple_exists) return
+ if(.not.charge_data_open.and.charge_ch)then
+ charge2s = gbcm1_charge-tcharge
+ tcharge = gbcm1_charge
+ charge2s_help = gbcm1_charge_help -tcharge_help
+ tcharge_help = gbcm1_charge_help
+ charge2s_helm = gbcm1_charge_helm -tcharge_helm
+ tcharge_helm = gbcm1_charge_helm
+c write(*,*)'MMM'
+c endif
+c if(.not.charge_data_open.and.gscaler_change(538).ne.hel_p_scaler)then
+ hel_p_scaler=gscaler_change(538)
+c hel_p_scaler= 0.985*gscaler_change(510)-gscaler_change(538)
+ hel_p_trig= g_hel_pos
+ dtime_p =1.
+ if(abs(hel_p_scaler).gt.0)then
+ dtime_p =float(g_hel_pos)/float(hel_p_scaler)
+ endif
+ call NANcheckF(dtime_p,0)
+ g_hel_pos =0
+c write(*,*)'MMM P'
+c endif
+c if(.not.charge_data_open.and.gscaler_change(546).ne.hel_n_scaler)then
+
+ hel_n_scaler= 0.985*gscaler_change(510)-gscaler_change(538)
+ hel_n_trig= g_hel_neg
+ dtime_n=1
+ if(abs(hel_n_scaler).gt.0.0)then
+ dtime_n = float(g_hel_neg)/float(hel_n_scaler)
+ endif
+ call NANcheckF(dtime_n,0)
+ g_hel_neg =0
+c write(*,*)'MMM N'
+ endif
+ if(polarization_data_open)then
+ polarea = polarea_old
+ polarization =polarization_old
+ half_plate =half_plate_old
+ endif
+ if(charge_data_open)then
+ charge2s = charge2s_old
+ tcharge = tcharge_old
+ charge2s_help = charge2s_help_old
+ tcharge_help = tcharge_help_old
+ charge2s_helm = charge2s_helm_old
+ tcharge_helm = tcharge_helm_old
+ hel_p_scaler = hel_p_scaler_old
+ hel_p_trig = hel_p_trig_old
+ dtime_p = dtime_p
+ hel_n_scaler = hel_n_scaler_old
+ hel_n_trig = hel_n_trig_old
+ dtime_n = dtime_n_old
+c if(abs(gbcm1_charge-tcharge).lt.0.001)charge_ch = .TRUE.
+ endif
+ if(polarization_data_open.and.gen_event_ID_number.eq.pol_id_change)then
+ read(polarization_data_unit,*,end=19)pol_id_change,polarea_old,polarization_old,half_plate_old
+c write(*,*)'HELP ',polarea_old
+ polarea = polarea_old
+ polarization=polarization_old
+ half_plate =half_plate_old
+ polarization_ch = .FALSE.
+ else if(.not.polarization_data_open.and.polarization_ch)then
+ write(polarization_data_unit,*)gen_event_ID_number,polarea ,polarization ,half_plate
+ polarization_ch = .FALSE.
+ endif
+ if(charge_data_open.and.gen_event_ID_number.eq.charge_id_change)then
+c write(*,*)'HELP charge Had',tcharge,gbcm1_charge
+ read(charge_data_unit,*,end=18)
+ , charge_id_change,charge2s_old,tcharge_old,
+ , tcharge_help_old,charge2s_help_old,
+ , tcharge_helm_old,charge2s_helm_old ,
+ , hel_p_scaler_old,hel_p_trig_old,dtime_p_old,
+ , hel_n_scaler_old,hel_n_trig_old,dtime_n_old
+
+c write(*,*)'HELP charge NOW',tcharge_old,gbcm1_charge
+ charge2s = charge2s_old
+ tcharge = tcharge_old
+ charge2s_help = charge2s_help_old
+ tcharge_help = tcharge_help_old
+ charge2s_helm = charge2s_helm_old
+ tcharge_helm = tcharge_helm_old
+ hel_p_scaler = hel_p_scaler_old
+ hel_p_trig = hel_p_trig_old
+ dtime_p = dtime_p_old
+ hel_n_scaler = hel_n_scaler_old
+ hel_n_trig = hel_n_trig_old
+ dtime_n = dtime_n_old
+ charge_ch = .FALSE.
+
+c write(*,*)gbcm1_charge,tcharge
+ else if(.not.charge_data_open.and.charge_ch)then
+ write(charge_data_unit,*)
+ , gen_event_ID_number,charge2s,tcharge,
+ , tcharge_help,charge2s_help,
+ , tcharge_helm,charge2s_helm ,
+ > hel_p_scaler,hel_p_trig,dtime_p,
+ , hel_n_scaler,hel_n_trig,dtime_n
+ charge_ch = .FALSE.
+ endif
+ call NANcheckF(polarization,3)
+
+c write(*,*)'HALF PLATE ',half_plate
+
+c if(charge_ch)then
+c write(*,*)polarea,charge2s,tcharge,hel_n_trig,hel_p_trig,hel_p_scaler
+c endif
+c if(polarization_ch)then
+c write(*,*)polarea,charge2s,tcharge,hel_n_trig,hel_p_trig,hel_p_scaler
+c endif
+c write(*,*)gbcm1_charge
+ T_trgHMS = gmisc_dec_data(11,1)
+ call NANcheckF(T_trgHMS,3)
+ T_trgBIG = gmisc_dec_data(12,1)
+ call NANcheckF(T_trgBIG,3)
+ T_trgPI0 = gmisc_dec_data(13,1)
+ call NANcheckF(T_trgPI0,3)
+ T_trgBETA = gmisc_dec_data(14,1)
+ call NANcheckF(T_trgBETA,3)
+ T_trgCOIN1 = gmisc_dec_data(15,1)
+ call NANcheckF(T_trgCOIN1,3)
+ T_trgCOIN2 = gmisc_dec_data(16,1)
+ call NANcheckF(T_trgCOIN2,3)
+
+
+
+cccccccccc Lucite Hodoscope
+ luc_hit = 0
+c write(*,*) LUCITE_SANE_RAW_TOT_HITS,LUCITE_SANE_RAW_TOT_HITS2,LUCITE_SANE_RAW_TOT_HITS3
+c write(*,*) LUCITE_SANE_RAW_TOT_HITS,LUCITE_SANE_RAW_TOT_HITS3
+c write(*,*) LUCITE_SANE_RAW_TDC_POS
+c write(*,*) LUCITE_SANE_RAW_TDC_POS
+
+
+! do i=1,LUCITE_SANE_RAW_TOT_HITS2 ! TDC hit counter for positive side
+c if(LUCITE_SANE_RAW_COUNTER_NUM2(i).eq.7)write(*,*)7
+! if(LUCITE_SANE_RAW_TDC_POS(i).gt.0)then
+! do j=1,LUCITE_SANE_RAW_TOT_HITS3 !TDC hit counter for negative side
+c if(LUCITE_SANE_RAW_COUNTER_NUM3(j).eq.7)write(*,*)72
+! if ( luc_hit .lt. 90) then ! check hard coded array max
+! if(LUCITE_SANE_RAW_TDC_NEG(j).gt.0.and.
+! , LUCITE_SANE_RAW_COUNTER_NUM2(i).eq.LUCITE_SANE_RAW_COUNTER_NUM3(j))then
+! luc_hit = luc_hit+1
+! luc_row(luc_hit) = LUCITE_SANE_RAW_COUNTER_NUM2(i)
+! ladc_pos(luc_hit) = LUCITE_SANE_RAW_ADC_POS(luc_row(luc_hit)) !- luc_ped_mean_pos(luc_row(luc_hit))
+! ladc_neg(luc_hit) = LUCITE_SANE_RAW_ADC_NEG(luc_row(luc_hit)) !- luc_ped_mean_neg(luc_row(luc_hit))
+! luc_y(luc_hit) = -82.35 + (luc_row(luc_hit)-1)*6.1
+! call NANcheck(luc_hit,LUCITE_SANE_ID)
+! call NANcheck(luc_row(luc_hit),LUCITE_SANE_ID)
+! call NANcheck(ladc_neg(luc_hit),LUCITE_SANE_ID)
+! call NANcheck(ladc_pos(luc_hit),LUCITE_SANE_ID)
+! call NANcheck(ltdc_neg(luc_hit),LUCITE_SANE_ID)
+! call NANcheck(ltdc_pos(luc_hit),LUCITE_SANE_ID)
+! call CORRECT_RAW_TIME_SANE(LUCITE_SANE_RAW_TDC_POS(i),ltdc_pos(luc_hit))
+! call CORRECT_RAW_TIME_SANE(LUCITE_SANE_RAW_TDC_NEG(j),ltdc_NEG(luc_hit))
+c call HFILL(10121, float(luc_row(luc_hit)), float(ltdc_pos(luc_hit)), 1.)
+c call HFILL(10122, float(luc_row(luc_hit)), float(ltdc_neg(luc_hit)), 1.)
+c call HFILL(10125, float(luc_row(luc_hit)), float(ladc_pos(luc_hit)), 1.)
+c call HFILL(10126, float(luc_row(luc_hit)), float(ladc_neg(luc_hit)), 1.)
+! LUCITE_SANE_RAW_TDC_NEG(j) = 0
+! endif
+! endif
+! enddo
+! LUCITE_SANE_RAW_TDC_POS(i) = 0
+
+! endif
+! enddo
+c write(*,*)'LUC sane done'
+ do i=1,LUCITE_SANE_RAW_TOT_HITS2
+ if(LUCITE_SANE_RAW_TDC_POS(i).gt.0)then
+ luc_hit = luc_hit+1
+ luc_row(luc_hit) = LUCITE_SANE_RAW_COUNTER_NUM2(i)
+ ladc_pos(luc_hit) = LUCITE_SANE_RAW_ADC_POS(luc_row(luc_hit)) - luc_ped_mean_pos(luc_row(luc_hit))
+ ladc_neg(luc_hit) = -100000
+ call CORRECT_RAW_TIME_SANE(LUCITE_SANE_RAW_TDC_POS(i),ltdc_pos(luc_hit))
+ ltdc_NEG(luc_hit) = -100000
+ LUCITE_SANE_RAW_TDC_POS(i) = 0
+c call HFILL(10121, float(luc_row(luc_hit)), float(ltdc_pos(luc_hit)), 1.)
+c call HFILL(10125, float(luc_row(luc_hit)), float(ladc_pos(luc_hit)), 1.)
+
+ endif
+ enddo
+ do i=1,LUCITE_SANE_RAW_TOT_HITS3
+ if(LUCITE_SANE_RAW_TDC_NEG(i).gt.0)then
+ luc_hit = luc_hit+1
+ luc_row(luc_hit) = LUCITE_SANE_RAW_COUNTER_NUM3(i)
+ ladc_neg(luc_hit) = LUCITE_SANE_RAW_ADC_NEG(luc_row(luc_hit)) - luc_ped_mean_pos(luc_row(luc_hit))
+ ladc_pos(luc_hit) = -100000
+ call CORRECT_RAW_TIME_SANE(LUCITE_SANE_RAW_TDC_NEG(i),ltdc_neg(luc_hit))
+ ltdc_POS(luc_hit) = -100000
+ LUCITE_SANE_RAW_TDC_NEG(i) = 0
+c call HFILL(10122, float(luc_row(luc_hit)), float(ltdc_neg(luc_hit)), 1.)
+c call HFILL(10126, float(luc_row(luc_hit)), float(ladc_neg(luc_hit)), 1.)
+
+ endif
+ enddo
+cccccccccc End Lucite Hodoscope
+
+cccccccccccccccccccccccccccccccccc
+cc InSANE SCALERS cccccccccccccccc
+cccccccccccccccccccccccccccccccccc
+c Cherenkov Scalers 6*12=72
+c Cherenkov Scalers start at 519
+ do i=1,12
+ cerscalernroll(i)=gscaler_nroll(518+i)
+ cerscaler(i)=gscaler(518+i)
+ cerscaler_change(i)=gscaler_change(518+i)
+ cerscaler_old(i)=gscaler_old(518+i)
+ cerscaler_skipped(i)=gscaler_skipped(518+i)
+ cerscaler_saved(i)=gscaler_saved(518+i)
+
+ enddo
+c Hodoscope Scalers 6*56*2 = 672
+C Hodoscope Scalers start at??????
+ do i=1,12
+ lucscalernroll(i)=gscaler_nroll(518+i)
+ lucscaler(i)=gscaler(518+i)
+ lucscaler_change(i)=gscaler_change(518+i)
+ lucscaler_old(i)=gscaler_old(518+i)
+ lucscaler_skipped(i)=gscaler_skipped(518+i)
+ lucscaler_saved(i)=gscaler_saved(518+i)
+ enddo
+c Bigcal scalers 6*271=1626
+c Bigcal scalers start at index 271
+ nbcscalers=272
+ do i=1,272
+ bcscalernroll(i)=gscaler_nroll(230+i)
+ bcscaler(i)=gscaler(230+i)
+ bcscaler_change(i)=gscaler_change(230+i)
+ bcscaler_old(i)=gscaler_old(230+i)
+ bcscaler_skipped(i)=gscaler_skipped(230+i)
+ bcscaler_saved(i)=gscaler_saved(230+i)
+
+ enddo
+c Forward Tracker scalers 32*6=192
+c Forward Tracker scalers start at index 550
+ do i=1,32
+ tkscalernroll(i)=gscaler_nroll(550+i)
+ tkscaler(i)=gscaler(550+i)
+ tkscaler_change(i)=gscaler_change(550+i)
+ tkscaler_old(i)=gscaler_old(550+i)
+ tkscaler_skipped(i)=gscaler_skipped(550+i)
+ tkscaler_saved(i)=gscaler_saved(550+i)
+ enddo
+c
+c Total BETA Detector Scalers = 2562
+c
+ccccccccccccccccccccccccccccccccc
+cc END InSANE SCALERS ccccccccccc
+ccccccccccccccccccccccccccccccccc
+
+ccccccc Cherenkov
+ cer_hit = 0
+c write(*,*)'c, ',CERENKOV_SANE_RAW_COUNTER_NUM
+c write(*,*)'a, ' ,CERENKOV_SANE_RAW_ADC
+ do i=1,CERENKOV_SANE_RAW_TOT_HITS2
+ if(CERENKOV_SANE_RAW_TDC(i).gt.0)then
+ cer_hit = cer_hit+1
+ cer_num(cer_hit) = CERENKOV_SANE_RAW_COUNTER_NUM2(i)
+ call CORRECT_RAW_TIME_SANE(CERENKOV_SANE_RAW_TDC(i),cer_tdc(cer_hit))
+ cer_adcc(cer_hit) = CERENKOV_SANE_RAW_ADC(cer_num(cer_hit))-cer_sane_ped_mean(cer_num(cer_hit))
+ call HFILL(10111,float(cer_num(cer_hit)),float(cer_TDC(cer_hit)), 1.)
+
+ call NANcheck(cer_hit,CERENKOV_SANE_ID)
+ call NANcheck(cer_num(cer_hit),CERENKOV_SANE_ID)
+ call NANcheck(cer_adcc(cer_hit),CERENKOV_SANE_ID2)
+ call NANcheck(cer_tdc(cer_hit),CERENKOV_SANE_ID)
+c if ( T_trgBIG.ge.40) then
+c call HFILL(10500+cer_num(cer_hit),float(cer_adcc(cer_hit)),float(cer_tdc(cer_hit)),1.)
+c endif
+ endif
+ enddo
+
+c write(*,*)CERENKOV_SANE_RAW_TOT_HITS2,' ',
+c ^ CERENKOV_SANE_RAW_TOT_HITS
+
+ ceradc_hit = 0
+ do i=1,CERENKOV_SANE_RAW_TOT_HITS
+ if (ceradc_hit .le. 15) then
+ ceradc_hit = ceradc_hit + 1
+ ceradc_num(ceradc_hit) = CERENKOV_SANE_RAW_COUNTER_NUM(i)
+ cer_adc(ceradc_hit) = CERENKOV_SANE_RAW_ADC(ceradc_num(ceradc_hit))-cer_sane_ped_mean(ceradc_num(ceradc_hit))
+ call NANcheck(ceradc_hit,CERENKOV_SANE_ID2)
+ call NANcheck(ceradc_num(ceradc_hit),CERENKOV_SANE_ID2)
+ call NANcheck(cer_adc(ceradc_hit),CERENKOV_SANE_ID2)
+ call HFILL(10112,float(ceradc_num(ceradc_hit)),float(cer_adc(ceradc_hit)), 1.)
+ endif
+ enddo
+c
+
+c
+c write(*,*)'Cer sane done'
+
+ x1t_hit = 0
+ if(x1t_hit.gt.300) go to 10
+ do i=1,TRACKER_SANE_RAW_TOT_HITS_X
+ if(TRACKER_SANE_RAW_TDC_X(i).gt.0)then
+ x1t_hit = x1t_hit+1
+ x1t_row(x1t_hit) = TRACKER_SANE_RAW_COUNTER_X(i)
+ call CORRECT_RAW_TIME_SANE(TRACKER_SANE_RAW_TDC_X(i),x1t_tdc(x1t_hit))
+ x1t_x(x1t_hit) = -12.32+0.37422*(x1t_row(x1t_hit)-1)
+
+ call HFILL(10100,float(x1t_row(x1t_hit)),float(x1t_tdc(x1t_hit)),1.)
+ call NANcheck(x1t_hit,TRACKER_SANE_X_ID)
+ call NANcheck(x1t_row(x1t_hit),TRACKER_SANE_X_ID)
+ call NANcheck(x1t_tdc(x1t_hit),TRACKER_SANE_X_ID)
+ endif
+ enddo
+ y1t_hit=0
+ y2t_hit=0
+c write(*,*)gen_event_ID_number,TRACKER_SANE_RAW_TOT_HITS_Y
+
+ do i=1,TRACKER_SANE_RAW_TOT_HITS_Y
+c write(*,*)'TDC, ', TRACKER_SANE_RAW_TDC_Y(i),TRACKER_SANE_RAW_COUNTER_Y(i)
+ if(TRACKER_SANE_RAW_TDC_Y(i).lt.67000.and.
+ , TRACKER_SANE_RAW_TDC_Y(i).gt.0)then
+ if(TRACKER_SANE_RAW_COUNTER_Y(i).lt.129)then
+ y1t_hit = y1t_hit + 1
+c write(*,*)'Tracker TDC', y1t_hit,TRACKER_SANE_RAW_TDC_Y(i)
+ if(y1t_hit.gt.300) go to 20
+ y1t_row(y1t_hit) = TRACKER_SANE_RAW_COUNTER_Y(i)
+ call CORRECT_RAW_TIME_SANE(TRACKER_SANE_RAW_TDC_Y(i),y1t_tdc(y1t_hit))
+ y1t_y(y1t_hit) = -22.225+(y1t_row(y1t_hit)-1)*0.35
+ call HFILL(10101,float(y1t_row(y1t_hit)),float(y1t_tdc(y1t_hit)),1.)
+ call NANcheck(y1t_hit,TRACKER_SANE_Y_ID)
+ call NANcheck(y1t_row(y1t_hit),TRACKER_SANE_Y_ID)
+ call NANcheck(y1t_tdc(y1t_hit),TRACKER_SANE_Y_ID)
+
+ else if(TRACKER_SANE_RAW_COUNTER_Y(i).lt.257)then
+ y2t_hit = y2t_hit + 1
+ if(y2t_hit.gt.300) go to 20
+ y2t_row(y2t_hit) = TRACKER_SANE_RAW_COUNTER_Y(i)-128
+ call CORRECT_RAW_TIME_SANE(TRACKER_SANE_RAW_TDC_Y(i),y2t_tdc(y2t_hit))
+ y2t_y(y2t_hit) = -22.4+(y2t_row(y2t_hit)-1)*0.35
+ call HFILL(10102,float(y2t_row(y2t_hit)),float(y2t_tdc(y2t_hit)),1.)
+ call NANcheck(y2t_hit,TRACKER_SANE_Y_ID)
+ call NANcheck(y2t_row(y2t_hit),TRACKER_SANE_Y_ID)
+ call NANcheck(y2t_tdc(y2t_hit),TRACKER_SANE_Y_ID)
+ endif
+ endif
+ 20 CONTINUE
+ enddo
+c write(*,*)'TRACK sane done'
+c do inum=1,nclust
+c enddo
+ hms_p = 0
+ if(HSNUM_FPTRACK.gt.0)then
+c write(*,*)HSNUM_FPTRACK,hsp,hstheta
+ hms_p = hsp
+ call NANcheckF(hms_p,4)
+ hms_e = hsenergy
+ call NANcheckF(hms_e,4)
+ hms_theta = hstheta
+ call NANcheckF(hms_theta,4)
+ hms_phi = hsphi
+ call NANcheckF(hms_phi,4)
+ hsxfp_s = hsx_fp
+ call NANcheckF(hsxfp_s,4)
+ hsyfp_s = hsy_fp
+ call NANcheckF(hsyfp_s,4)
+ hsxpfp_s = hsxp_fp
+ call NANcheckF(hsxpfp_s,4)
+ hsypfp_s = hsyp_fp
+ call NANcheckF(hsypfp_s,4)
+ hms_xtar = hsx_tar*100
+ call NANcheckF(hms_xtar,4)
+ hms_ytar = hsy_tar*100
+ call NANcheckF(hms_ytar,4)
+c write(*,*)hms_ytar,hsy_tar
+ hms_yptar = hsyp_tar
+ call NANcheckF(hms_yptar,4)
+ hms_xptar = hsxp_tar
+c write(*,*)hms_yptar,hms_xptar
+ call NANcheckF(hms_xptar,4)
+ hms_delta = hsdelta
+ call NANcheckF(hms_delta,4)
+ hms_start = hstart_time
+ call NANcheck(hms_start,4)
+ hsshtrk_s = HSTRACK_ET
+ call NANcheckF(hsshtrk_s,4)
+ hsshsum_s = hsshsum
+ call NANcheckF(hsshsum_s,4)
+ hsbeta_s = hsbeta
+ call NANcheckF(hsbeta_s,4)
+ hms_cer_npe1 = hcer_npe(1)
+ call NANcheckF(hms_cer_npe1,4)
+ hms_cer_npe2 = hcer_npe(2)
+ call NANcheckF(hms_cer_npe2,4)
+ hms_cer_adc1 = hcer_adc(1)
+ call NANcheckF(hms_cer_adc1,4)
+ hms_cer_adc2 = hcer_adc(2)
+ call NANcheckF(hms_cer_adc2,4)
+ call HFILL(10302,X_HMS,Y_HMS,1.)
+c if(nclust.eq.1)then
+ do i=1,nclust
+! call HFILL(10300,X_HMS,xclust(i)+Bigcal_SHIFT(1),1.)
+! call HFILL(10304,X_HMS-Xclust(i),Y_HMS-Yclust(i),1.)
+! call HFILL(10301,Y_HMS,Yclust(i)+Bigcal_SHIFT(2),1.)
+c write(*,*)Bigcal_SHIFT(1),Bigcal_SHIFT(2)
+ if(abs(X_HMS-xclust(i)-Bigcal_SHIFT(1)).lt.10.and.
+ , abs(Y_HMS-Yclust(i)-Bigcal_SHIFT(2)).lt.10)then
+c write(*,*)'Slow raster ',gsrx_calib,gsry_calib
+c write(*,*)'HMS raster ',hms_xtar,hms_ytar
+! call HFILL(10303,Xclust(i)+Bigcal_SHIFT(1),Yclust(i)+Bigcal_SHIFT(2),1.)
+! call HFILL(10310,hms_delta,hms_yptar ,1.)
+! call HFILL(10311,hms_delta,hms_xptar ,1.)
+! call HFILL(10312,dpel_hms,hms_yptar ,1.)
+! call HFILL(10313,dpel_hms,hms_xptar ,1.)
+! call HFILL(10315,dpel_hms,hms_ytar ,1.)
+! call HFILL(10314,dpel_hms,hms_xtar ,1.)
+! call HF1(10321,0.006*hms_delta+0.01-hms_yptar,1.)
+ P_e = hms_p
+ P_el(1) = p_e*sin(hms_theta)*cos(HMS_phi)
+ P_el(2) = p_e*sin(hms_theta)*sin(HMS_phi)
+ P_el(3) = p_e*cos(hms_theta)
+ P_el(4) = hms_e
+ ww2 = (GEBEAM+Mp-P_el(4))**2-
+ , (P_el(1)**2+p_el(2)**2+(GEBEAM-p_el(3))**2)
+c write(*,*)ww2
+! call HF1(10322,ww2,1.)
+! call HFILL(10323,ww2,hms_yptar,1.)
+! call HFILL(10324,ww2,hms_xtar,1.)
+
+ endif
+ enddo
+c endif
+
+ endif
+
+ rast_x = gfry_raw_adc
+ call NANcheckF(rast_x,3)
+ rast_y = gfrx_raw_adc
+ call NANcheckF(rast_y,3)
+ i_helicity = gbeam_helicity
+ call NANcheck(i_helicity,3)
+! write(*,*)'i_helicity',i_helicity
+
+c if(sane_ntuple_type.eq.1)then
+ slow_rast_x = gsrx_calib
+ call NANcheckF(gsrx_raw_adc,3)
+ slow_rast_y = gsry_calib
+ call NANcheckF(gsry_raw_adc,3)
+c else
+c slow_rast_x = gsrx_raw_adc
+c call NANcheckF(gsrx_raw_adc,3)
+c slow_rast_y = gsry_raw_adc
+c call NANcheckF(gsry_raw_adc,3)
+
+c endif
+ call HFILL(10215,gsry_raw_adc,gsrx_raw_adc, 1.)
+
+ call HFILL(10216,gsrx_calib,gsry_calib, 1.)
+
+ if(HSNUM_FPTRACK.gt.0)then
+
+ call HFILL(10316,slow_rast_y,-hms_xtar ,1.)
+ call HFILL(10317,slow_rast_x,hms_ytar ,1.)
+ endif
+ call NANcheckF(gsry_raw_adc,3)
+ sem_x = -ntbpmx/10.
+ call NANcheckF(sem_x,3)
+ sem_y = ntbpmy/10.
+ call NANcheckF(sem_y,3)
+ call HFILL(10214,sem_x,sem_y, 1.)
+
+ n_clust = nclust
+ do i =1, n_clust
+
+ call Bigcal_Betta(i)
+ call icer(i)
+c call Bigcal_Betta(i)
+ call tracker(i)
+ call TrackerCoordnate(i)
+ call GeometryMatch(i)
+ call Lucite(i)
+ do j=1, ncellclust(i)
+ call HFILL(10200,float(ixcell(j,i)),float(iycell(j,i)), 1.)
+ enddo
+c if(sane_ntuple_type.eq.1)then
+c n_clust = nclust
+c call Lucite(i)
+c endif
+ enddo
+c write(*,*)'Sane is Done'
+ abort=.not.HEXIST(sane_ntuple_ID)
+ if(abort) then
+ call G_build_note(':Ntuple ID#$ does not exist',
+ $ '$',sane_ntuple_ID,' ',0.,' ',err)
+ call G_add_path(here,err)
+ else
+ icycle=999999
+ call HFNT(sane_ntuple_ID)
+ if(sane_ntuple_type.eq.9) then
+ call HFNT(sane_ntuple_ID+1)
+c call HFNT(sane_ntuple_ID+2)
+c call HFNT(sane_ntuple_ID+3)
+c call HFNT(sane_ntuple_ID+4)
+c call HFNT(sane_ntuple_ID+5)
+ endif
+ endif
+ 10 CONTINUE
+
+ return
+ 18 write(*,*)'HELP charge error',charge2s,gbcm1_charge
+ return
+ 19 write(*,*)'HELP Polarization error'
+ return
+ end
+
+ SUBROUTINE CORRECT_RAW_TIME_SANE(RAW_TDC,CORRECTED_TDC)
+ IMPLICIT NONE
+ include 'sane_data_structures.cmn'
+ include 'f1trigger_data_structures.cmn'
+c
+c Function arguments are RAW_TDC -raw TDC value
+c and CORRECTED_TDC -Corrected by Trigger time and rolover time
+c MAKE SURE TO Include correct parameter files
+c
+c
+ integer*4 RAW_TDC, CORRECTED_TDC, f1trigmax
+ save
+
+c find largest value of trigger time, to check rollover
+ if(TRIGGER_F1_START_TDC_COUNTER(
+ > SANE_TRIGGER_COUNTER) .gt.f1trigmax) then
+ write(6,'('' SANE trigger time max='',i8)')
+ > TRIGGER_F1_START_TDC_COUNTER(
+ > SANE_TRIGGER_COUNTER)
+ f1trigmax =
+ > TRIGGER_F1_START_TDC_COUNTER(
+ > SANE_TRIGGER_COUNTER)
+ endif
+ if(RAW_TDC.gt.0)then
+ CORRECTED_TDC = RAW_TDC -
+ , TRIGGER_F1_START_TDC_COUNTER(SANE_TRIGGER_COUNTER)
+c
+c Taking care of ROLOVER For positive TDC
+c
+ if(CORRECTED_TDC.lt.-30000)
+ , CORRECTED_TDC = CORRECTED_TDC+TRIGGER_F1_ROLOVER(SANE_TRIGGER_COUNTER)
+ if(CORRECTED_TDC.gt.30000)
+ , CORRECTED_TDC = CORRECTED_TDC-TRIGGER_F1_ROLOVER(SANE_TRIGGER_COUNTER)
+ else
+ CORRECTED_TDC =0
+ endif
+
+ end
+
+ subroutine NANcheck(l,did)
+ IMPLICIT NONE
+ integer*4 l
+ integer did
+ if(l.ne.l)then
+ l=0
+c write(*,*)did
+ endif
+ end
+ subroutine NANcheckF(l,did)
+ IMPLICIT NONE
+ real*4 l
+ integer did
+ if(l.ne.l)then
+ l=0
+c write(*,*)did
+ endif
+ end
diff --git a/SANE/sane_physics.f b/SANE/sane_physics.f
new file mode 100644
index 0000000..216dba5
--- /dev/null
+++ b/SANE/sane_physics.f
@@ -0,0 +1,1248 @@
+ subroutine Bigcal_Betta(inum)
+ IMPLICIT NONE
+ include 'bigcal_data_structures.cmn'
+ include 'sane_data_structures.cmn'
+ include 'b_ntuple.cmn'
+ include 'sane_ntuple.cmn'
+ include 'gen_data_structures.cmn'
+ include 'gen_run_info.cmn'
+ integer inum
+ real*4 Vector(3),Vector_r(3)
+ real*4 coorX, coorY
+ real*4 coorX1,coorX3,coorY1,coorY3
+ real*8 Eb,theta_big, phi_big!,shift,ccx,ccy,ccz, emax,jmax
+
+ common/FAKEBIG/Eb,theta_big, phi_big
+ integer ixmax,iymax
+c real Etot3pm,Etot3mp,Etot3mm,Etot3pp,Etot,etot9
+ real xmomsqr,xmom,xmomsq,ymomsqr,ymom,ymomsq
+ real Emt,Etot,etot9,xx(5,5),yy(5,5),eyx(5,5)
+* double precision VectorN(12)
+ double precision VectorN(27)
+ double precision COORE,coorX2,coorY2
+ integer jmax
+ real emax
+ common/EBL/jmax,emax
+ double precision FixX,FixY,FixE
+ common/SNEU/FixX,FixY,FixE
+ real temp_phi,temp_th
+ double precision sane_n100xye
+
+
+c
+c Call for NeuralParam subroutine which prepares the input parameters for Neural network
+c
+c
+
+ call NueralParam(inum,ixmax,iymax,jmax,etot,
+ , XX,YY,Eyx)
+
+* call NueralParam(inum,Emax,Emt,Etot9,Etot,
+* , xmomsqr,xmom,xmomsq,ymomsqr,ymom,ymomsq,
+* , ixmax,iymax,jmax,XX,YY)
+
+c
+c Set the input vector for Neural Network
+c 25 -energies from 5x5 cluster
+c and position of max energy cluster
+c
+
+
+ VectorN(1) = eyx(1,1)
+ VectorN(2) = eyx(2,1)
+ VectorN(3) = eyx(3,1)
+ VectorN(4) = eyx(4,1)
+ VectorN(5) = eyx(5,1)
+ VectorN(6) = eyx(1,2)
+ VectorN(7) = eyx(2,2)
+ VectorN(8) = eyx(3,2)
+ VectorN(9) = eyx(4,2)
+ VectorN(10) = eyx(5,2)
+ VectorN(11) = eyx(1,3)
+ VectorN(12) = eyx(2,3)
+ VectorN(13) = eyx(3,3)
+ VectorN(14) = eyx(4,3)
+ VectorN(15) = eyx(5,3)
+ VectorN(16) = eyx(1,4)
+ VectorN(17) = eyx(2,4)
+ VectorN(18) = eyx(3,4)
+ VectorN(19) = eyx(4,4)
+ VectorN(20) = eyx(5,4)
+ VectorN(21) = eyx(1,5)
+ VectorN(22) = eyx(2,5)
+ VectorN(23) = eyx(3,5)
+ VectorN(24) = eyx(4,5)
+ VectorN(25) = eyx(5,5)
+
+ VectorN(26) = DBLE(ixmax)
+ VectorN(27) =DBLE(iymax)
+
+
+
+c
+c sane_n100xye(VectorN,n) -is neural network function
+c if n=0 -correction for x
+c n=1 -correction for y
+c n=2 -correction for energy
+c
+
+ COORX2 = sane_n100xye(VectorN,0)
+ COORY2 = sane_n100xye(VectorN,1)
+ COORE = sane_n100xye(VectorN,2)
+
+
+c
+c Calculations of final coordinate and energy of the cluster at z=335
+c
+c
+
+ x_clust(inum) = xcell(jmax,inum)+coorX2
+ Y_clust(inum) = ycell(jmax,inum)+coorY2
+ xclust(inum) = x_clust(inum)
+ yclust(inum) = Y_clust(inum)
+
+c write(*,*)iycell(jmax,inum),ycell(jmax,inum),y_clust(inum)
+
+
+ if(ncellclust(inum).gt.6)then
+ call HFILL(10227,y_clust(inum),Y_clust(inum)-yclust(inum),1.)
+ endif
+ Z_clust(inum) = Bigcal_SHIFT(3) !to be 335 cm
+ E_clust(inum) = Etot+COORE
+ eclust(inum) = e_clust(inum)
+
+
+c
+c Obtaining the coordinates in Lab system
+c
+c
+ Vector(1) = x_clust(inum)
+ Vector(2) = y_clust(inum)
+ Vector(3) = Z_clust(inum)
+ call ROTATE(Vector,0.,-Bigcal_SHIFT(4)*3.1415926536/180.,0.,Vector_r)
+
+ X_clust_r(inum) = Vector_r(1)
+ Y_clust_r(inum) = Vector_r(2)
+ Z_clust_r(inum) = Vector_r(3)
+c
+c Cheching for NAN
+c
+c
+ call NANcheckF(E_clust(inum),33)
+ call NANcheckF(x_clust(inum),33)
+ call NANcheckF(y_clust(inum),33)
+ call NANcheckF(Z_clust(inum),33)
+ call NANcheckF(X_clust_r(inum),33)
+ call NANcheckF(Y_clust_r(inum),33)
+ call NANcheckF(Z_clust_r(inum),33)
+
+
+
+
+
+c
+c Calling cerenkov for info
+c
+c
+CORRECT_ANGLES(X,Y,Z,EE,TH,PHI,cer_stat,srx,sry)
+
+ call icer(inum)
+
+cc
+cc OBTAIN Angles THeta and Phi Assuming the particle was Electron
+c Angles are in degree
+ if(cer_h(inum).gt.0)then
+c
+c If cerenkov fired use electron corrections
+c
+
+ call CORRECT_ANGLES(
+ , X_clust_r(inum),
+ , Y_clust_r(inum)-Bigcal_SHIFT(2),
+ , Z_clust_r(inum),E_clust(inum),
+ , SANE_IF_ELECTRON_ANGLE_THETA,
+ , SANE_IF_ELECTRON_ANGLE_PHI,1,slow_rast_x,slow_rast_y)
+ else
+c
+c else use photon corrections
+c
+c
+ call CORRECT_ANGLES(
+ , X_clust_r(inum),
+ , Y_clust_r(inum)-Bigcal_SHIFT(2),
+ , Z_clust_r(inum),E_clust(inum),
+ , SANE_IF_ELECTRON_ANGLE_THETA,
+ , SANE_IF_ELECTRON_ANGLE_PHI,0,slow_rast_x,slow_rast_y)
+
+ endif
+c
+c Fill and check for NAN theta_e and phi_e ntuple variables
+c
+c
+
+ Theta_e(inum) = SANE_IF_ELECTRON_ANGLE_THETA
+ Phi_e(inum) = SANE_IF_ELECTRON_ANGLE_PHI
+
+
+ call NANcheckF(Theta_e(inum),33)
+ call NANcheckF(Phi_e(inum),33)
+c write(*,*)inum,x_clust(inum),xclust(inum),ixcell(jmax,inum),xcell(jmax,inum)
+
+
+ end
+cccccccccccccccccccccccccccccccccccccccccccccccccccc
+c
+c real function ener(e)
+c real e
+c ener=e
+c end
+c
+c
+c Tracker
+c
+c
+
+ subroutine tracker(inum) ! inum -cluster number !
+ IMPLICIT NONE
+ include 'bigcal_data_structures.cmn'
+ include 'sane_data_structures.cmn'
+ include 'b_ntuple.cmn'
+ include 'sane_ntuple.cmn'
+ real*4 X_trc_r(20,maxcl)
+ real*4 Y1_trc_r(20,maxcl)
+ real*4 Y2_trc_r(20,maxcl)
+ real*4 Z_trc_r(20,maxcl)
+ real*4 Z1_trc_r(20,maxcl)
+ real*4 Z2_trc_r(20,maxcl)
+ integer x1t_stat,y1t_stat,y2t_stat
+ integer i,inum
+ integer i4,itrig
+ logical cut1,cut2
+ common /B_TIME_SHIFT/i4,itrig
+ x1t_stat = 0
+ y1t_stat = 0
+ y2t_stat = 0
+ trc_hx(inum) =0
+ccccc
+c
+c Geometrical matching
+c
+ccccc
+c write(*,*)'Tracker Start X',nclust
+c write(*,*)ixcell(1,inum),iycell(1,inum),ncellclust(inum)
+
+c
+c Do the tracking only for particles wth cerenkov
+c
+c
+ if(cer_h(inum).ge.0 .and. i4 .gt. 0)then
+ do i=1,x1t_hit
+c
+c for Some runs part of bigcal had timing shift. if this shift is there then correct for it
+c
+c
+ x1t_tdc(i)=x1t_tdc(i)-BIG_TIME_SHIFT_CH(i4)
+c
+c Very wide geometrical cut
+c
+ cut1 = .FALSE.
+ cut1 = abs(x1t_tdc(i)-TRACKER_SANE_XCALIBRATION(x1t_row(i))).lt.
+ , TRACKER_SANE_XSIGMA(x1t_row(i))
+ cut2 = .FALSE.
+c
+c Define cuts for tracker
+c
+c
+ if(BIG_TIME_SHIFT_CH(9).ne.0)then
+ cut2 = abs(x1t_tdc(i)-BIG_TIME_SHIFT_CH(9)-TRACKER_SANE_XCALIBRATION(x1t_row(i))).lt.
+ , TRACKER_SANE_XSIGMA(x1t_row(i))
+ endif
+c call HFILL(10103,float(x1t_row(i)),float(x1t_tdc(i)),1.)
+ if(cut1.or.cut2)then
+ call HFILL(10106,x1t_x(i)-TrackerX_SHIFT(1),TrackerX_SHIFT(3)/Bigcal_SHIFT(3)*
+ , (xclust(inum))-Bigcal_SHIFT(1),1.)
+ if(cer_h(inum).gt.0)then
+ call HFILL(10103,float(x1t_row(i)),float(x1t_tdc(i)),1.)
+ endif
+ endif
+c
+c Apply the riming cuts with geometrical cut
+c
+c
+
+ IF(abs(x1t_x(i)-TrackerX_SHIFT(1)-
+ , TrackerX_SHIFT(3)/(Bigcal_SHIFT(3))*
+ , (x_clust(inum)-Bigcal_SHIFT(1)) ).lt.2.)then
+
+c
+c TDC CUT
+c
+ if(cut1.or.cut2)then
+ x1t_stat = x1t_stat+1
+ trc_hx(inum) = x1t_stat
+ if(x1t_stat.gt.0)then
+c
+ X_trc(trc_hx(inum),inum) = x1t_x(i)-TrackerX_SHIFT(1)
+ X_trc_r(trc_hx(inum),inum) = 0
+ Z_trc_r(trc_hx(inum),inum) = 0
+ call NANcheckF(X_trc(trc_hx(inum),inum),35)
+ Z_trc(trc_hx(inum),inum) = TrackerX_SHIFT(3)
+
+ endif
+ endif
+ ENDIF
+ enddo
+c write(*,*)'Tracker Start Y1'
+ trc_hy1(inum) =0
+ do i=1,y1t_hit
+ y1t_tdc(i)=y1t_tdc(i)-BIG_TIME_SHIFT_CH(i4)
+c
+c Very wide geometrical cut
+c
+ cut1 = .FALSE.
+ cut1 = abs(y1t_tdc(i)-TRACKER_SANE_Y1CALIBRATION(y1t_row(i))).lt.
+ , TRACKER_SANE_Y1SIGMA(y1t_row(i))
+ cut2 = .FALSE.
+ if(BIG_TIME_SHIFT_CH(9).ne.0)then
+ cut2 = abs(y1t_tdc(i)-BIG_TIME_SHIFT_CH(9)-TRACKER_SANE_Y1CALIBRATION(y1t_row(i))).lt.
+ , TRACKER_SANE_Y1SIGMA(y1t_row(i))
+ endif
+
+ if(cut1.or.cut2)then
+ call HFILL(10107,y1t_y(i)-TrackerY1_SHIFT(2),TrackerY1_SHIFT(3)/Bigcal_SHIFT(3)*
+ , (y_clust(inum))-Bigcal_SHIFT(2),1.)
+ if(cer_h(inum).gt.0)then
+ call HFILL(10104,float(y1t_row(i)),float(y1t_tdc(i)),1.)
+ endif
+ endif
+
+ IF(abs(y1t_y(i)-TrackerY1_SHIFT(2)-
+ , TrackerY1_SHIFT(3)/(Bigcal_SHIFT(3))*
+ , (y_clust(inum)-Bigcal_SHIFT(2))).lt.2.)then
+c
+c TDC CUT
+c
+ if(cut1.or.cut2)then
+ y1t_stat = y1t_stat +1
+ trc_hy1(inum) = y1t_stat
+ if(y1t_stat.gt.0)then
+
+ Y1_trc(trc_hy1(inum),inum) = y1t_y(i)-TrackerY1_SHIFT(2)
+ Y1_trc_r(trc_hy1(inum),inum) = 0
+ Z1_trc_r(trc_hy1(inum),inum) = 0
+ call NANcheckF(Y1_trc(trc_hy1(inum),inum),35)
+ Z1_trc(trc_hy1(inum),inum) = TrackerY1_SHIFT(3)
+ endif
+ endif
+ ENDIF
+ enddo
+ trc_hy2(inum) =0
+c write(*,*)'Tracker Start Y2'
+ do i=1,y2t_hit
+ y2t_tdc(i)=y2t_tdc(i)-BIG_TIME_SHIFT_CH(i4)
+c
+c Very wide geometrical cut
+c
+ cut1 = .FALSE.
+ cut1 = abs(y2t_tdc(i)-TRACKER_SANE_Y2CALIBRATION(y2t_row(i))).lt.
+ , TRACKER_SANE_Y2SIGMA(y2t_row(i))
+ cut2 = .FALSE.
+ if(BIG_TIME_SHIFT_CH(9).ne.0)then
+ cut2 = abs(y2t_tdc(i)-BIG_TIME_SHIFT_CH(9)-TRACKER_SANE_Y2CALIBRATION(y2t_row(i))).lt.
+ , TRACKER_SANE_Y2SIGMA(y2t_row(i))
+ endif
+
+ if(cut1.or.cut2)then
+ call HFILL(10108,y2t_y(i)-TrackerY2_SHIFT(2),TrackerY2_SHIFT(3)/Bigcal_SHIFT(3)*
+ , (y_clust(inum))-Bigcal_SHIFT(2),1.)
+ call HFILL(10109,float(y2t_row(i)),TrackerY2_SHIFT(3)/Bigcal_SHIFT(3)*
+ , (y_clust(inum))-Bigcal_SHIFT(2),1.)
+ if(cer_h(inum).gt.0)then
+ call HFILL(10105,float(y2t_row(i)),float(y2t_tdc(i)),1.)
+ endif
+ endif
+c write(*,*)y2t_tdc(i),TRACKER_SANE_Y2CALIBRATION(y2t_row(i)),TRACKER_SANE_Y1SIGMA(y1t_row(i))
+ IF(abs(y2t_y(i)-TrackerY2_SHIFT(2)-
+ , TrackerY2_SHIFT(3)/(Bigcal_SHIFT(3))*
+ , (y_clust(inum)-Bigcal_SHIFT(2))).lt.2.)then
+c
+c TDC CUT
+c
+ if(cut1.or.cut2)then
+
+ y2t_stat = y2t_stat +1
+ trc_hy2(inum) = y2t_stat
+ if(y2t_stat.gt.0)then
+
+ Y2_trc(trc_hy2(inum),inum) = y2t_y(i)-TrackerY2_SHIFT(2)
+ Y2_trc_r(trc_hy2(inum),inum) = 0
+ Z2_trc_r(trc_hy2(inum),inum) = 0
+ call NANcheckF(Y2_trc(trc_hy2(inum),inum),35)
+
+ Z2_trc(trc_hy2(inum),inum) = TrackerY2_SHIFT(3)
+ endif
+
+ endif
+
+ ENDIF
+ enddo
+ endif
+
+ end
+
+cccccccccccccccccccccccccccccc
+c
+c Lucite
+c
+ccccccccccccccccccccccccccccccccccccc
+
+ subroutine lucite(inum)
+ IMPLICIT NONE
+ include 'bigcal_data_structures.cmn'
+ include 'sane_data_structures.cmn'
+ include 'b_ntuple.cmn'
+ include 'sane_ntuple.cmn'
+ integer jmax
+ real emax
+ common/EBL/jmax,emax
+
+ integer inum,i,ibar
+ integer luc,ip
+ real*4 tdc_dif, xDelta1,koef,yfake,ytracker,ztracker,ipi(10)
+ real*4 Vector(3),Vector_r(3),Zbigclust,xattrack,yattrack
+ integer i4,itrig
+ logical cut,cut1,cut2
+ common /B_TIME_SHIFT/i4,itrig
+ luc=0
+ ip=0
+c
+c calculations are done if cherenkov triggered.
+c
+c
+
+ if(luc_hit.gt.0
+ , .and.cer_h(inum).ge.0
+ , .and. i4 .gt. 0)then
+ do i=1,luc_hit
+ ltdc_pos(i) = ltdc_pos(i) -BIG_TIME_SHIFT_CH(i4)!-BIG_TIME_SHIFT_CH(itrig)
+ ltdc_neg(i) = ltdc_neg(i) -BIG_TIME_SHIFT_CH(i4)!-BIG_TIME_SHIFT_CH(itrig)
+
+c
+c
+c Define cuts for timing for lucite
+c
+c
+ cut =abs(ltdc_pos(i)-LUCITE_SANE_MEAN_POS(luc_row(i))).lt.
+ , 3*LUCITE_SANE_SIGMA_POS(luc_row(i)).and.
+ , abs(ltdc_neg(i)-LUCITE_SANE_MEAN_NEG(luc_row(i))).lt.
+ , 3*LUCITE_SANE_SIGMA_NEG(luc_row(i))
+ cut1 = .FALSE.
+ cut2 = .FALSE.
+ if(BIG_TIME_SHIFT_CH(5).ne.0)then
+ cut =(abs(ltdc_pos(i)-LUCITE_SANE_MEAN_POS(luc_row(i))).lt.
+ , 3.*LUCITE_SANE_SIGMA_POS(luc_row(i)).and.
+ , abs(ltdc_neg(i)-LUCITE_SANE_MEAN_NEG(luc_row(i))).lt.
+ , 3.*LUCITE_SANE_SIGMA_NEG(luc_row(i))).or.
+ , (abs(ltdc_pos(i)-BIG_TIME_SHIFT_CH(5)-LUCITE_SANE_MEAN_POS(luc_row(i))).lt.
+ , 3.*LUCITE_SANE_SIGMA_POS(luc_row(i)).and.
+ , abs(ltdc_neg(i)-BIG_TIME_SHIFT_CH(5)-LUCITE_SANE_MEAN_NEG(luc_row(i))).lt.
+ , 3.*LUCITE_SANE_SIGMA_NEG(luc_row(i)))
+
+ cut1 = (abs(ltdc_pos(i)-LUCITE_SANE_MEAN_POS(luc_row(i))).lt.
+ , 3.*LUCITE_SANE_SIGMA_POS(luc_row(i)).and.
+ , abs(ltdc_neg(i)-BIG_TIME_SHIFT_CH(5)-LUCITE_SANE_MEAN_NEG(luc_row(i))).lt.
+ , 3.*LUCITE_SANE_SIGMA_NEG(luc_row(i)))
+ cut2 =
+ , (abs(ltdc_pos(i)-BIG_TIME_SHIFT_CH(5)-LUCITE_SANE_MEAN_POS(luc_row(i))).lt.
+ , 3.*LUCITE_SANE_SIGMA_POS(luc_row(i)).and.
+ , abs(ltdc_neg(i)-LUCITE_SANE_MEAN_NEG(luc_row(i))).lt.
+ , 3.*LUCITE_SANE_SIGMA_NEG(luc_row(i)))
+ endif
+
+c
+c Apply cuts and find the x coordinate of hit
+c
+
+ If(cut.or.cut1.or.cut2
+ , )then
+
+ call HFILL(10121, float(luc_row(i)), float(ltdc_pos(i)), 1.)
+ call HFILL(10122, float(luc_row(i)), float(ltdc_neg(i)), 1.)
+ call HFILL(10125, float(luc_row(i)), float(ladc_pos(i)), 1.)
+ call HFILL(10126, float(luc_row(i)), float(ladc_neg(i)), 1.)
+ tdc_dif=float(ltdc_pos(i))-
+ , float(ltdc_neg(i))
+ , +LUCITE_SANE_MEAN_NEG(luc_row(i))
+ , -LUCITE_SANE_MEAN_POS(luc_row(i))
+c
+c X coordinate for Lucite
+c
+
+ xDelta1 =
+ , -(tdc_dif)*LUCITE_SANE_TDC_TIMING(luc_row(i))*
+ , 29.979/1.49*0.7313*LUCITE_SANE_COEF(luc_row(i))-LUCITE_SANE_SHIFT(luc_row(i))*Lucite_SHIFT(3)/Bigcal_SHIFT(3)
+c$$$
+C
+C Y Geometrical CUT
+C
+**********
+ call HFILL(10128,luc_y(i),y_clust(inum),1.)
+
+ IF(abs(luc_y(i)-Lucite_SHIFT(2)-
+ , Lucite_SHIFT(3)/(Bigcal_SHIFT(3))*
+ , (y_clust(inum)-Bigcal_SHIFT(2))).lt.30)then
+
+c if(luc_row(i).eq.18)write(*,*)xDelta1-Lucite_SHIFT(1)
+
+ call HFILL(10150+luc_row(i),xDelta1-Lucite_SHIFT(1),
+ , sqrt(Lucite_SHIFT(3)**2+luc_y(i)**2)/sqrt(Bigcal_SHIFT(3)**2+
+ , y_clust(inum)**2)*xclust(inum),1.)
+ call HFILL(20150+luc_row(i),(xDelta1-Lucite_SHIFT(1))*
+ , Bigcal_SHIFT(3)/Lucite_SHIFT(3),
+ , Xclust(inum),1.)
+c endif
+ if(abs(xclust(inum)).lt.5)then
+ call HFILL(10131, float(luc_row(i)), float(ltdc_pos(i)), 1.)
+ call HFILL(10132, float(luc_row(i)), float(ltdc_neg(i)), 1.)
+ call HFILL(10135, float(luc_row(i)), float(ladc_pos(i)), 1.)
+ call HFILL(10136, float(luc_row(i)), float(ladc_neg(i)), 1.)
+ endif
+ ip=ip+1
+ ipi(ip) = i
+C
+C X Geometrical CUT
+C
+***********
+c write(*,*)luc_row(i)
+ If(abs(xDelta1-Lucite_SHIFT(1)-
+ , Lucite_SHIFT(3)/Bigcal_SHIFT(3)*
+ , (xclust(inum))-Bigcal_SHIFT(1)).lt.20)then
+
+c write(*,*)xDelta1
+c
+
+c
+c Fill lucite coordinates
+c
+c
+ luc = luc+1
+ X_luc(luc,inum) = xDelta1-Lucite_SHIFT(1)
+ Y_luc(luc,inum) = luc_y(i)-Lucite_SHIFT(2)
+ Z_luc(luc,inum) = sqrt(Lucite_SHIFT(3)**2-
+ , X_luc(luc,inum)**2)
+ call NANcheckF(X_luc(luc,inum),333)
+ call NANcheckF(Y_luc(luc,inum),444)
+ call NANcheckF(Z_luc(luc,inum),555)
+c
+c
+c Rotate lucite coordinates into Lab system
+c
+
+ Vector(1) = X_luc(luc,inum)
+ Vector(2) = Y_luc(luc,inum)
+ Vector(3) = Z_luc(luc,inum)
+ call ROTATE(Vector,0.,-BIGCAL_SHIFT(4)*3.1415926536/180.,0.,Vector_r)
+ X_luc_r(luc,inum) = Vector_r(1)
+ Y_luc_r(luc,inum) = Vector_r(2)
+ Z_luc_r(luc,inum) = Vector_r(3)
+ call NANcheckF(X_luc_r(luc,inum),34)
+ call NANcheckF(Y_luc_r(luc,inum),34)
+ call NANcheckF(Z_luc_r(luc,inum),34)
+ ENDIF
+
+ Endif
+
+c ENDIF
+
+ endif
+
+ enddo
+ luc_h(inum) = luc
+c write(*,*)luc
+ X_luc_av(inum) = 0
+ Y_luc_av(inum) = 0
+ Z_luc_av(inum) = 0
+c
+c
+c Some plots to look at two lucite hits at the same time
+c
+c
+ if(luc_h(inum).eq.2)then
+c write(*,*)X_luc(1,inum),X_luc(2,inum)
+ if(abs(Y_luc(1,inum)-Y_luc(2,inum)).lt.7.and.e_clust(inum).gt.0.7.and.
+ , abs(X_luc(1,inum)-X_luc(2,inum)).lt.5.and.ncellclust(inum).gt.6)then
+c write(32,*)X_luc(1,inum),X_luc(2,inum),luc_row(ipi(1)),luc_row(ipi(2))
+c write(*,*)luc_h(inum)
+
+c
+c GOOD LUCITE HIT
+c
+ X_luc_av(inum) = (X_luc(1,inum)+X_luc(2,inum))/2.
+ Z_luc_av(inum) = (Z_luc(1,inum)+Z_luc(2,inum))/2.
+ Y_luc_av(inum) = (Y_luc(1,inum)+Y_luc(2,inum))/2.
+ ibar = (Y_luc_av(inum)+82.35)/6.1+1
+
+c write(*,*)ibar
+ Y_luc_av(inum) = Y_luc_av(inum)-3.5/2.*Y_luc_av(inum)/Z_luc_av(inum)
+c write(*,*)' ',Y_luc_av(inum)S
+
+ if(abs(x_clust(inum)).lt.103)then
+ if((trc_hy1(inum).eq.1.and.trc_hy2(inum).eq.1.and.trc_hx(inum).eq.1))then
+c write(*,*)trc_hy1(inum),trc_hy2(inum),trc_hx(inum)
+ ytracker = 0
+
+ if(trc_hy2(inum).eq.1.and.trc_hy1(inum).eq.0)then
+ ytracker = Y2_trc(trc_hy2(inum),inum)
+ ztracker = TrackerY2_SHIFT(3)
+ endif
+ if(trc_hy1(inum).eq.1.and.trc_hy2(inum).eq.0)then
+ ytracker = Y1_trc(trc_hy1(inum),inum)
+ ztracker = TrackerY1_SHIFT(3)
+ endif
+ if(trc_hy2(inum).eq.1.and.trc_hy1(inum).eq.1.and.
+ , abs(Y2_trc(trc_hy2(inum),inum)-Y1_trc(trc_hy1(inum),inum)).lt.0.4)then
+c write(*,*)Y2_trc(trc_hy2(inum),inum),Y1_trc(trc_hy1(inum),inum)
+ ytracker = 0.5*(Y2_trc(trc_hy2(inum),inum)+Y1_trc(trc_hy1(inum),inum))
+ ztracker = 0.5*(TrackerY2_SHIFT(3)+TrackerY1_SHIFT(3))
+
+ endif
+ if(ytracker.ne.0.and.e_clust(inum).gt.1)then
+
+ xattrack = X_luc_av(inum)*TrackerX_SHIFT(3)/Z_luc_av(inum)
+ yattrack = y_luc_av(inum)*ztracker/Z_luc_av(inum)
+
+
+ koef = (Y_luc_av(inum)-ytracker)/(Z_luc_av(inum)-ztracker)
+ yfake = koef*(Bigcal_SHIFT(3)-ztracker-10)+ytracker
+ Zbigclust = (y_clust(inum)-ytracker)/koef+ztracker-Bigcal_SHIFT(3)
+
+ call HFILL(10220,Yfake,yfake-y_clust(inum),1.)
+ call HFILL(10221,yfake,Y_luc_av(inum)*Bigcal_SHIFT(3)/Z_luc_av(inum)-yclust(inum),1.)
+ call HFILL(10225,eclust(inum),yfake-y_clust(inum),1.)
+ call HFILL(20250+ibar,xcell(jmax,inum),ycell(jmax,inum),1.)
+ if(yfake.gt.50)then
+ call HFILL(10222,xclust(inum),(yfake-y_clust(inum)),1.)
+ endif
+ endif
+ endif
+ endif
+ if(abs(Y_Clust(inum)).lt.10)then
+ call HFILL(10223,X_luc_av(inum)*(Bigcal_SHIFT(3))/Z_luc_av(inum)-X_clust(inum),X_clust(inum),1.)
+ call HFILL(10226,X_luc_av(inum)*(Bigcal_SHIFT(3))/Z_luc_av(inum)-x_clust(inum),eclust(inum),1.)
+ endif
+ endif
+ endif
+c do i=1,luc
+c fluc = luc
+c X_luc_av(inum) = X_luc_av(inum) + X_luc(i,inum)/fluc
+c Y_luc_av(inum) = Y_luc_av(inum) + Y_luc(i,inum)/fluc
+c Z_luc_av(inum) = Z_luc_av(inum) + Z_luc(i,inum)/fluc
+c enddo
+ endif
+ end
+
+ccccccccccccccccccccccccccccccccccccccccccc
+c
+c Cerenkov
+c
+ccccccccccc
+ Subroutine icer(inum)
+ IMPLICIT NONE
+ include 'bigcal_data_structures.cmn'
+ include 'sane_data_structures.cmn'
+ include 'b_ntuple.cmn'
+ include 'sane_ntuple.cmn'
+ include 'gen_data_structures.cmn'
+ include 'gen_run_info.cmn'
+ integer inum,i,j,cer_n
+ integer i4,itrig,itrigcellX,itrigcellY
+ real T_trgBIG_CUT_U,T_trgBIG_CUT_D
+ common /B_TIME_SHIFT/i4,itrig
+ real amax,dtime
+ real Brow,a64c
+ integer iBnum,ibcol,ibrow
+c integer BIGCAL_CER_330_SHIT(8)
+c data BIGCAL_CER_330_SHIT/0,-3,1,1,3,3,1,3/
+
+ cer_h(inum)=0
+ cer_geom(inum)=0
+ cerb_time(inum)=0
+ cerb_adc(inum) = 0
+
+ if(ncellclust(inum).gt.4)then
+ i4=1
+ itrig = 1
+ amax = ablock(1,inum)
+
+ if(iycell(1,inum).gt.32) then
+ i4=2
+ else
+ i4=1
+ endif
+ T_trgBIG_CUT_U=50
+ T_trgBIG_CUT_D=30
+ if(grun.le.72400)then !!!!!!!!!!!!!! NEEDS TO BE CHANGED TO CORRECT ONE
+ T_trgBIG_CUT_U=55
+ T_trgBIG_CUT_D=34
+ endif
+c itrig = 3
+
+c write(*,*)"Amax= ",amax,ncellclust(inum)
+c do k=1,ncellclust(inum)
+c if(ablock(k,inum).ge.amax)then
+c
+c amax = ablock(k,inum)
+c i4 = iycell(k,inum)
+c write(*,*)"i4=",i4,k,iycell(k,inum)
+c endif
+c enddo
+ do i=1, min(cer_hit,50)
+ if(cer_num(i).lt.9 .and. ncell64clust(inum) .gt. 0)then
+ cer_n = cer_num(i)
+c write(*,*)1,cer_tdc(i),cer_adcc(i),cer_num(i)
+
+
+ iBnum = 10700+icol64hit(ncell64clust(inum),inum)*10+cer_num(i)
+ Brow=float( irow64hit(ncell64clust(inum),inum) )
+ call HF2( iBnum,Brow,float(cer_tdc(i))+2090,1.)
+ if(grun.le.72487)then
+
+ if(abs(cer_tdc(i)+1678).lt.60)cer_tdc(i)=100000
+
+ if(grun.le.72487.and.icol64hit(ncell64clust(inum),inum).eq.1.and.
+ , abs(BIGCAL_CER_COL1_SHIFT(irow64hit(ncell64clust(inum),inum),cer_num(i))).lt.0.0001)cer_tdc(i)=100000
+ if(grun.le.72487.and.icol64hit(ncell64clust(inum),inum).eq.2.and.
+ , abs(BIGCAL_CER_COL2_SHIFT(irow64hit(ncell64clust(inum),inum),cer_num(i))).lt.0.0001)cer_tdc(i)=100000
+
+ if(icol64hit(ncell64clust(inum),inum).eq.1)
+ , cer_tdc(i) = cer_tdc(i) -BIGCAL_CER_COL1_SHIFT(irow64hit(ncell64clust(inum),inum),cer_num(i))
+ if(icol64hit(ncell64clust(inum),inum).eq.2)
+ , cer_tdc(i) = cer_tdc(i) -BIGCAL_CER_COL2_SHIFT(irow64hit(ncell64clust(inum),inum),cer_num(i))
+
+ iBnum = 10730+cer_num(i)
+ Brow=float( irow64hit(ncell64clust(inum),inum) )
+ call HF2( iBnum,Brow,float(cer_tdc(i))+2090,1.)
+ endif
+
+ccccccccccccccccccccccccccc
+
+ if(y_clust(inum).gt.(CER_SANE_GEOM_CUT_LOW(cer_n)*4-1)-120..and.
+ , y_clust(inum).lt.(CER_SANE_GEOM_CUT_HI(cer_n)*4+1)-120.and.
+ , CER_SANE_GEOM_CUT_X(cer_n)*x_clust(inum).gt.-20)then
+ if(T_trgBIG.gt.T_trgBIG_CUT_D)then
+c write(*,*)T_trgBIG
+ call HFILL(10560+cer_num(i),T_trgBIG,float(cer_tdc(i)),1.)
+ call HFILL(10570+cer_num(i),T_trgBETA,float(cer_tdc(i)),1.)
+ endif
+ endif
+
+c
+c
+c Trigger SHIFT COrrections
+c
+c
+ if(int(T_trgBETA-45).gt.0.and. int(T_trgBETA-45) .le. 30)then
+ cer_tdc(i) = cer_tdc(i) -T_TRGBETA_SHIFT(int(T_trgBETA-45))
+ endif
+ if(grun.le.72487)then
+
+ if(T_trgBIG.gt.42.and.cer_num(i).ne.5)cer_tdc(i)=100000
+
+ endif
+
+
+
+c write(*,*)cer_n,CER_SANE_GEOM_CUT_LOW(cer_n),CER_SANE_GEOM_CUT_HI(cer_n)
+ if(y_clust(inum).gt.(CER_SANE_GEOM_CUT_LOW(cer_n)-1)*4-120..and.
+ , y_clust(inum).lt.(CER_SANE_GEOM_CUT_HI(cer_n)+1)*4-120.and.
+ , CER_SANE_GEOM_CUT_X(cer_n)*x_clust(inum).gt.-20.and.
+ , T_trgBIG.ge.T_trgBIG_CUT_D.and.T_trgBIG.le.T_trgBIG_CUT_U)then
+
+c write(*,*)1,2,cer_tdc(i),cer_adcc(i),cer_num(i)
+ call HFILL(10580+cer_num(i),T_trgBIG,float(cer_tdc(i)),1.)
+
+
+ if(aclust(inum).gt.500)then
+ call HFILL(10520+cer_num(i),aclust(inum),float(cer_tdc(i)),1.)
+ if(grun.le.72487)then !!!!!!!!!!!!!! NEEDS TO BE CHANGED TO CORRECT ONE
+ cer_tdc(i) = cer_tdc(i) -
+ , (BIGCAL_CER_TIME_WALK_SHIFT(cer_num(i))-
+ , BIGCAL_CER_TIME_WALK_SLOPE(cer_num(i))/aclust(inum)-
+ , CER_SANE_TIME_WALK(cer_num(i))/cer_adcc(i))
+ endif
+
+ endif
+c write(*,*)cer_tdc(i),cer_adcc(i),cer_num(i)
+ call HFILL(10530+cer_num(i),aclust(inum),float(cer_tdc(i)),1.)
+ call HFILL(10500+cer_num(i),float(cer_adcc(i)),float(cer_tdc(i)),1.)
+ if (ncell64clust(inum) .gt. 0) then
+ ibcol = icol64hit(ncell64clust(inum),inum)
+ ibrow = irow64hit(ncell64clust(inum),inum)
+ a64c = s64(ncell64clust(inum),inum)
+ iBnum = 17000+ibrow+100*ibcol
+ if(iBnum.eq.106)write(*,*)iBnum,a64c,cer_tdc(i)
+ call HF2(iBnum,a64c,float(cer_tdc(i)),1.)
+ endif
+
+
+ endif
+
+ bigc_time(inum) = tclust64(inum)!-(5000/s64(ncell64clust(inum),inum)-4)
+ if (ncell64clust(inum) .gt. 0) then
+ if(grun.gt.72487.and.icol64hit(ncell64clust(inum),inum).eq.1.and.
+ , abs(BIGCAL_CERB_COL1_SHIFT(irow64hit(ncell64clust(inum),inum),cer_num(i))).lt.0.0001)bigc_time(inum)=100000
+ if(grun.gt.72487.and.icol64hit(ncell64clust(inum),inum).eq.2.and.
+ , abs(BIGCAL_CERB_COL2_SHIFT(irow64hit(ncell64clust(inum),inum),cer_num(i))).lt.0.0001)bigc_time(inum)=100000
+
+ if(icol64hit(ncell64clust(inum),inum).eq.1)
+ , bigc_time(inum) = bigc_time(inum) -BIGCAL_CERB_COL1_SHIFT(irow64hit(ncell64clust(inum),inum),cer_num(i))
+ if(icol64hit(ncell64clust(inum),inum).eq.2)
+ , bigc_time(inum) = bigc_time(inum) -BIGCAL_CERB_COL2_SHIFT(irow64hit(ncell64clust(inum),inum),cer_num(i))
+ endif
+c write(*,*)grun,bigc_time(inum),ncell64clust(inum),inum
+c if(grun.gt.72487)then
+c iBnum = 10700+icol64hit(ncell64clust(inum),inum)*10+cer_num(i)
+c Brow=float( irow64hit(ncell64clust(inum),inum) )
+c call HF2( iBnum,Brow,float(bigc_time(inum))-330,1.)
+c endif
+
+c bigc_time(inum) = bigc_time(inum) -(5000/s64(ncell64clust(inum),inum)-4)
+
+
+ bigc_adc(inum) = s64(ncell64clust(inum),inum)
+ iBnum = 18000+ibrow+100*ibcol
+ call HF2(iBnum,float(bigc_adc(inum)),float(bigc_time(inum)),1.)
+ if(
+ , T_trgBIG.ge.T_trgBIG_CUT_D.and.T_trgBIG.le.T_trgBIG_CUT_U)then
+ if(y_clust(inum).gt.(CER_SANE_GEOM_CUT_LOW(cer_n)*4-1)-120..and.
+ , y_clust(inum).lt.(CER_SANE_GEOM_CUT_HI(cer_n)*4+1)-120.and.
+ , CER_SANE_GEOM_CUT_X(cer_n)*x_clust(inum).gt.-20)then
+ cer_geom(inum)=cer_geom(inum)+1
+
+ if(cer_h(inum).eq.0)then
+ cerb_time(inum)=cer_tdc(i)
+ cerb_adc(inum) = cer_adcc(i)
+ cerbc_num(inum) = cer_num(i)
+
+ endif
+
+ iBnum = 10740+cer_num(i)
+ Brow=float( irow64hit(ncell64clust(inum),inum) )
+ call HF2( iBnum,Brow,float(cer_tdc(i))+2090,1.)
+
+ if(
+ , abs(cer_tdc(i)-CER_SANE_MEAN(cer_num(i))).lt.
+ , CER_SANE_SIGMA(cer_n)
+ , )then
+
+ cer_h(inum)=cer_h(inum)+1
+ if(cer_h(inum).eq.1)then
+ cerb_time(inum)=cer_tdc(i)
+ cerb_adc(inum) = cer_adcc(i)
+ cerbc_num(inum) = cer_num(i)*10**(cer_h(inum)-1)
+
+ else
+ cerb_time(inum)=cerb_time(inum)+cer_tdc(i)
+ cerb_adc(inum) = cerb_adc(inum)+cer_adcc(i)
+ cerbc_num(inum) = cer_num(i)*10**(cer_h(inum)-1)+cerbc_num(inum)
+ endif
+
+c write(*,*)cer_h(inum),cer_hit,cer_n
+ call HFILL(10540+cer_num(i),float(cer_adcc(i)),float(cer_tdc(i)),1.)
+ call HF1(10113,tclust64(inum),1.)
+ call HF2(10114,tclust64(inum),float(cer_tdc(i)),1.)
+
+ do j=1, ncellclust(inum)
+c write(*,*)inum,x_clust(inum),xclust(inum),ixcell(j,inum),xcell(j,inum)
+ call HFILL(10510+cer_n,float(ixcell(j,inum)),float(iycell(j,inum)), 1.)
+ enddo
+ endif
+ endif
+ endif
+ endif
+ enddo
+ if(cer_h(inum).gt.0)cerb_time(inum)=cerb_time(inum)/float(cer_h(inum))
+
+ endif
+ end
+c
+c
+c Particle ID
+c
+cccccccccccccccccccccccccccccccccccccccccc
+ subroutine TrackerCoordnate(inum)
+ IMPLICIT NONE
+ include 'sane_data_structures.cmn'
+ include 'sane_ntuple.cmn'
+ real*4 TrakerVertex(3), TrakerVertex_r(3)
+ real*4 TrakerTEMP_Y1,TrakerTEMP_Y2
+ integer i,inum
+ logical TRAKER_STATUS
+ common/TRACKER_LOGICS/TRAKER_STATUS
+ TRAKER_STATUS=.FALSE.
+
+c
+c Average coordinate on X plane
+ Tr_Vertex(1,inum) = 0
+ Tr_Vertex(2,inum) = 0
+ Tr_Vertex(3,inum) = 0
+
+ Tr_Vertex_r(1,inum) = 0
+ Tr_Vertex_r(2,inum) = 0
+ Tr_Vertex_r(3,inum) = 0
+ TrakerVertex(3) = TrackerY2_SHIFT(3)
+ if(trc_hx(inum).gt.0.and.(trc_hy1(inum).gt.0.or.trc_hy2(inum).gt.0))then
+ TRAKER_STATUS=.TRUE.
+
+ TrakerVertex(1) = 0
+ if(trc_hx(inum).eq.1)then
+ TrakerVertex(1) = X_trc(trc_hx(inum),inum)
+ else if(trc_hx(inum).gt.1)then
+ do i=1, trc_hx(inum)
+ TrakerVertex(1) = TrakerVertex(1) + X_trc(trc_hx(inum),inum)/trc_hx(inum)
+ enddo
+ endif
+ TrakerVertex(2) = 0
+c
+c Average coordinate on Y1 plane
+
+ TrakerTEMP_Y1 = 0
+ if(trc_hy1(inum).eq.1)then
+ TrakerTEMP_Y1 = Y1_trc(trc_hy1(inum),inum)
+ else if(trc_hy1(inum).gt.1)then
+ do i=1, trc_hy1(inum)
+ TrakerTEMP_Y1 = TrakerTEMP_Y1 + Y1_trc(trc_hy1(inum),inum)/trc_hy1(inum)
+ enddo
+ endif
+c
+c Average coordinate on Y2 plane
+
+ TrakerTEMP_Y2 = 0
+ if(trc_hy2(inum).eq.1)then
+ TrakerTEMP_Y2 = Y2_trc(trc_hy2(inum),inum)
+ else if(trc_hy2(inum).gt.1)then
+ do i=1, trc_hy2(inum)
+ TrakerTEMP_Y2 = TrakerTEMP_Y2 + Y2_trc(trc_hy2(inum),inum)/trc_hy2(inum)
+ enddo
+ endif
+c write(*,*)TrakerTEMP_Y1,TrakerTEMP_Y2
+ if(TrakerTEMP_Y1.ne.0.and.TrakerTEMP_Y2.ne.0)then
+ TrakerVertex(2) = (TrakerTEMP_Y1+TrakerTEMP_Y2)/2.
+ TrakerVertex(3) = (TrackerY1_SHIFT(3)+TrackerY2_SHIFT(3))/2.
+ else if(TrakerTEMP_Y1.ne.0.and.TrakerTEMP_Y2.eq.0)then
+ TrakerVertex(2) = TrakerTEMP_Y1
+ TrakerVertex(3) = TrackerY1_SHIFT(3)
+ else if(TrakerTEMP_Y1.eq.0.and.TrakerTEMP_Y2.ne.0)then
+ TrakerVertex(2) = TrakerTEMP_Y2
+ TrakerVertex(3) = TrackerY2_SHIFT(3)
+ else if(TrakerTEMP_Y1.eq.0.and.TrakerTEMP_Y2.eq.0)then
+ TrakerVertex(2) = 0
+ TrakerVertex(3) = TrackerY2_SHIFT(3)
+ endif
+ if(Z_trc(trc_hx(inum),inum).ne.0)then
+ TrakerVertex(1) = TrakerVertex(1)*TrakerVertex(3)/Z_trc(trc_hx(inum),inum)
+ endif
+ call ROTATE(TrakerVertex,0.,-Bigcal_SHIFT(4)*3.1415926536/180.,0.,TrakerVertex_r)
+c WRITE(*,*)1,TrakerVertex,TrakerVertex_r
+ Tr_Vertex(1,inum) = TrakerVertex(1)
+ Tr_Vertex(2,inum) = TrakerVertex(2)
+ Tr_Vertex(3,inum) = TrakerVertex(3)
+
+ Tr_Vertex_r(1,inum) = TrakerVertex_r(1)
+ Tr_Vertex_r(2,inum) = TrakerVertex_r(2)
+ Tr_Vertex_r(3,inum) = TrakerVertex_r(3)
+ call NANcheckF(Tr_Vertex(1,inum),33)
+ call NANcheckF(Tr_Vertex(2,inum),33)
+ call NANcheckF(Tr_Vertex(3,inum),33)
+ call NANcheckF(Tr_Vertex_r(1,inum),33)
+ call NANcheckF(Tr_Vertex_r(2,inum),33)
+ call NANcheckF(Tr_Vertex_r(2,inum),33)
+
+ endif
+ end
+c
+c Real Angles
+c
+ccccccccccccccccccccccccccccccccccccccccccccccccccccc
+ Subroutine CORRECT_ANGLES(X,Y,Z,EE,TH,PHI,cer_stat,srx,sry)
+ IMPLICIT NONE
+c
+c X = X(Bigcal)-X(raster)
+c Y = Y(Bigcal)-Y(raster)
+c Z = Z(Bigcal)
+c EE - energy in GEV
+c RETURNS THeta and PHI In Degree.
+c
+cccccccccccc
+ include 'sane_data_structures.cmn'
+ include 'gen_run_info.cmn'
+ real*4 X,Y,Z,TH,Phi,thr,phr,EE
+ real*4 DIST,srx,sry
+ real*8 P_th(10),P_phi(10)
+
+ integer cer_stat
+ data P_th /
+ , -2.199987805718, 1.312318933346, 0.644032653274,
+ , 2.001711272282 , 4.831055345667,
+ , 0.596870277140 , 0.237530064696 , -0.444891749961,
+ , -0.668604044519 , -1.988327254812/
+ data P_Phi /
+ , -1.206886920591, 3.898203794202, 1.409952555564 ,
+ , -0.737821993549, 4.693839032660,
+ , -0.853486677346, -3.282568717839 , 1.891695882259,
+ , 1.158605334109 , -4.578605424909/
+ DIST = sqrt(X**2+Y**2+Z**2)
+ thr = acos(Z/Dist)
+ phr= atan2(y/Dist,x/Dist)
+
+ if(gen_run_number.lt.72900)then
+ SANE_BETA_OMEGA=40
+ else
+ SANE_BETA_OMEGA=140
+ endif
+ if(cer_stat.gt.0)then
+ call POLYNOM_CORRECTION(SANE_TRANSFORM_MATRIX_THETA,
+ , SANE_TRANSFORM_MATRIX_PHI,thr,
+ , phr,EE,TH,PHI,srx,sry)
+c if(x.lt.179.and.y.gt.10)
+c . write(*,*)thr*180/3.1415926,th,phr*180/3.1415926,phi
+
+ else
+c phi=phr*180/3.14159
+c th = thr*180/3.14159
+
+ DIST = sqrt((X-srx)**2+(Y-sry)**2+Z**2)
+ thr = acos(Z/Dist)
+ phr= atan2((y-sry)/Dist,(x-srx)/Dist)
+ th = THR*180/3.1415926+
+ , (P_th(1)+P_th(2)*phr+P_th(3)*thr+P_th(4)*phr**2+P_th(5)*thr**2)/EE+
+ , (P_th(6)+P_th(7)*thr+P_th(8)*phr+P_th(9)*phr**2+P_th(10)*thr**2)/EE**2
+ phi = phR*180/3.1415926
+ , +(P_phi(1)+P_phi(2)*phr+P_phi(3)*phr**2+
+ , P_phi(4)*phr**3+P_phi(5)*thr+P_phi(6)*thr**2+
+ , P_phi(7)*thr**3+P_phi(8)*phr*thr+
+ , P_phi(9)*phr**2*thr+
+ , P_phi(10)*phr*thr**2)
+ endif
+
+c write(*,*)phr*180/3.141-90,phi,SANE_BETA_OMEGA
+
+c write(28,*)thr*180/3.1415926,th,phr*180/3.1415926-phi,SANE_BETA_OMEGA,gen_run_number
+ end
+ccccccc
+ Subroutine POLYNOM_CORRECTION(P_th,P_phi,thr,phr,EE,TH,PHI,srx,sry)
+ IMPLICIT NONE
+
+c
+c Input patameters are P(26) -transformation Matrix
+c input thr and phr angles from CALORIMETER ,THr and PHr in radians
+c EE Energy in GEV
+c Output :TH and Phi Correctes in degrees
+cc
+ real*4 TH,Phi,thr,phr,EE
+ REAL*8 OMEGA,srx,sry
+ real*4 P_th(15),P_phi(15),COSOM,SINOM
+ cosom = cos(omega*3.1415926/180.)
+ sinom = sin(omega*3.1415926/180.)
+c write(*,*)P_th
+
+ th = THR*180/3.1415926+
+ , (p_th(1)+p_th(2)*thr+p_th(3)*phr+p_th(4)*thr**2+
+ , p_th(5)*phr**2+p_th(6)*thr*phr)*
+ , (p_th(7)+p_th(8)/EE+p_th(9)/EE**2)*
+ , (p_th(10)+p_th(11)*srx+p_th(12)*srx**2)*
+ , (p_th(13)+p_th(14)*sry+p_th(15)*sry**2)
+
+
+
+ phi = phR*180/3.1415926+
+ , (p_phi(1)+p_phi(2)*thr+p_phi(3)*phr+p_phi(4)*thr**2+
+ , p_phi(5)*phr**2+p_phi(6)*thr*phr)*
+ , (p_phi(7)+p_phi(8)/EE+p_phi(9)/EE**2)*
+ , (p_phi(10)+p_phi(11)*srx+p_phi(12)*srx**2)*
+ , (p_phi(13)+p_phi(14)*sry+p_phi(15)*sry**2)
+
+ end
+
+c
+c Geometry match of the tracks
+c
+ccccccccccccccccccccccccccccccccccccc
+ Subroutine GeometryMatch(inum)
+ IMPLICIT NONE
+ include 'bigcal_data_structures.cmn'
+ include 'sane_data_structures.cmn'
+ include 'b_ntuple.cmn'
+ include 'sane_ntuple.cmn'
+ integer inum
+c real*8 U, U_pos, U_neg
+ real*8 dl
+ real*4 P_tr(3),P_big(3),P_tar(3)
+c real*4 Vector(3),Vector_r(3)
+c LOGICAL ok1
+ logical TRAKER_STATUS
+ data P1_track /0.,0.,66./
+ data P2_track /0.,1.,66./
+ data P3_track /1.,0.,66./
+ common/TRACKER_LOGICS/TRAKER_STATUS
+ if(TRAKER_STATUS)then
+ P1_track(3) = Tr_Vertex(3,inum)
+ P2_track(3) = Tr_Vertex(3,inum)
+ P3_track(3) = Tr_Vertex(3,inum)
+ dl =0.1
+C if(a_tracker.eq.0.and.b_tracker.eq.0.and.c_tracker.eq.0)then
+c c
+c Define Traker plane
+c
+ call ROTATE(P1_track, 0., -Bigcal_SHIFT(4)*3.1415926536/180., 0.,P1_track_r)
+ call ROTATE(P2_track, 0., -Bigcal_SHIFT(4)*3.1415926536/180., 0.,P2_track_r)
+ call ROTATE(P3_track, 0., -Bigcal_SHIFT(4)*3.1415926536/180., 0.,P3_track_r)
+ call Plane(P1_track_r,P2_track_r,P3_track_r,
+ , a_tracker,b_tracker,c_tracker,d_tracker)
+
+C endif
+C if(a_bigcal.eq.0.and.b_bigcal.eq.0.and.c_bigcal.eq.0)then
+c c
+c Define Bigcal plane
+c
+c call ROTATE(P1_bigcal, 0., Bigcal_SHIFT(4)*3.141/180., 0. ,P1_bigcal_r)
+c call ROTATE(P2_bigcal, 0., Bigcal_SHIFT(4)*3.141/180., 0. ,P2_bigcal_r)
+c call ROTATE(P3_bigcal, 0., Bigcal_SHIFT(4)*3.141/180., 0. ,P3_bigcal_r)
+ call Plane(P1_track,P2_track,P3_track,
+ , a_bigcal,b_bigcal,c_bigcal,d_bigcal)
+
+C endif
+c
+c
+c Start Particle Identification
+c
+c
+
+ Delta_Y(inum) =-100
+ Delta_X(inum) =-100
+ if(cer_h(inum).ge.0)then
+c
+c It's most probably electron or positron
+c Next step is calculate distance between tracker position and
+c Virtual position reconstructed by linear track to target.
+c
+ P_tar(1) = slow_rast_x
+ P_tar(2) = slow_rast_y
+ P_tar(3) = 0
+ P_tar(1) = 0
+ P_tar(2) = 0
+ P_tar(3) = 0
+
+c P_big(1) = X_clust_r(inum)
+c P_big(2) = Y_clust_r(inum)
+c P_big(3) = Z_clust_r(inum)
+c call PlaneLineIntersection(a_tracker,b_tracker,c_tracker,
+c , d_tracker,P_tar,P_big,P_tr)
+c Delta_Y(inum) = Tr_Vertex_r(2,inum)-P_tr(2)
+c Delta_X(inum) = Tr_Vertex_r(1,inum)-P_tr(1)
+
+c write(*,*) 'TRACK MATCH 1',Delta_X(inum)
+ P_tar(1) = 0
+ P_tar(2) = 0
+ P_tar(3) = 0
+ P_big(1) = x_clust(inum)
+ P_big(2) = y_clust(inum)
+ P_big(3) = Z_clust(inum)
+ call PlaneLineIntersection(a_bigcal,b_bigcal,c_bigcal,
+ , d_bigcal,P_tar,P_big,P_tr)
+ Delta_Y(inum) = Tr_Vertex(2,inum)-P_tr(2)
+ Delta_X(inum) = Tr_Vertex(1,inum)-P_tr(1)
+ call NANcheckF(Delta_Y(inum),4)
+ call NANcheckF(Delta_X(inum),4)
+ call HFILL(10550,E_clust(inum),Delta_Y(inum), 1.)
+ call HFILL(10551,E_clust(inum),Delta_X(inum), 1.)
+c write(*,*) 'TRACK MATCH 2',Delta_X(inum)
+c write(*,*) 'TRACK MATCH 3'
+
+c c
+cc The particle is charged.
+c c
+c if(luc_h(inum).gt.0)then
+c do i=1,luc_h(inum)
+c call CalcMomComp(
+c , X_luc_r(i,inum),Y_luc_r(i,inum),Z_luc_r(i,inum),
+c , X_clust_r(inum),Y_clust_r(inum),Z_clust_r(inum),
+c , px, py, pz, E_clust(inum), 0.0005)
+c call TransformTo6Vector(
+c , X_luc_r(i,inum),Y_luc_r(i,inum),Z_luc_r(i,inum),
+c , px,py,pz,E_clust(inum),U)
+c call EqVector(U,U_pos)
+c call EqVector(U,U_neg)
+c
+c ok1 = .TRUE.
+c call trgTrackToPlane(U_pos,E_clust(inum),dl,
+c , a_tracker,b_tracker,c_tracker,d_tracker,ok1)
+c ok1 = .TRUE.
+c call trgTrackToPlane(U_neg,-E_clust(inum),dl,
+c , a_tracker,b_tracker,c_tracker,d_tracker,ok1)
+c
+c enddo
+c
+c endif
+ else
+
+
+ endif
+ endif
+
+ end
+ Subroutine PHYSICS_VARIABLES(inum,theta,phi)
+ IMPLICIT NONE
+ include 'sane_ntuple.cmn'
+ include 'gen_data_structures.cmn'
+ include 'sane_data_structures.cmn'
+ include 'b_ntuple.cmn'
+ real*8 Eb,theta_big, phi_big!,ccx,ccy,ccz
+ common/FAKEBIG/Eb,theta_big, phi_big
+ integer inum, ihistnum
+ real*4 theta,phi
+ real*4 thetar,phir
+ real*4 deg2rad, Mp,shelicity
+ Mp = 0.938272309
+ deg2rad = 3.1415926536/180.
+ ENue(inum) = 0
+ Q2(inum) = 0
+ X_Bjorken(inum) = 0
+ W2(inum) = 0
+ if(cer_h(inum).ge.0.and.
+ , E_clust(inum).gt.0.6.and.
+ , E_clust(inum).lt.GEBeam)then
+ thetar= theta*deg2rad
+ phir= phi*deg2rad
+
+ ENue(inum) = GEBeam - E_clust(inum)
+ Q2(inum) = 2*GEBeam*E_clust(inum)*(1-cos(thetar))
+ X_Bjorken(inum) = Q2(inum)/( 2*Mp*ENue(inum) )
+ W2(inum) = Mp**2 + 2*Mp*ENue(inum) -Q2(inum)
+ ihistnum = (Q2(inum)-2.5)+1
+c WRITE(*,*)cer_h(inum),E_clust(inum),X_Bjorken(inum),theta,(1-cos(thetar))
+
+ call NANcheckF(ENue(inum),5)
+ call NANcheckF(Q2(inum),5)
+ call NANcheckF(X_Bjorken(inum),5)
+ call NANcheckF(W2(inum),5)
+c shelicity = i_helicity
+ if(i_helicity.gt.0)then
+ shelicity=1.
+ else if(i_helicity.lt.0)then
+ shelicity=-1.
+ endif
+c write(18,'(4I13,2F10.5)')bgid,i_helicity,inum,cer_h(inum),Q2(inum),X_Bjorken(inum)
+ call NANcheckF(shelicity,5)
+
+ if(ihistnum.gt.0.and.ihistnum.lt.5)then
+ call HF1(10600+ihistnum,X_Bjorken(inum),shelicity)
+ call HF1(10610+ihistnum,X_Bjorken(inum),1.)
+ endif
+
+ call HFILL(10620,X_Bjorken(inum),Q2(inum),1.)
+ call HFILL(10621,W2(inum),Q2(inum),1.)
+ endif
+
+ end
+
diff --git a/SANE/sane_register_variables.f b/SANE/sane_register_variables.f
new file mode 100644
index 0000000..a9935a1
--- /dev/null
+++ b/SANE/sane_register_variables.f
@@ -0,0 +1,41 @@
+ subroutine sane_register_variables(ABORT,err)
+ implicit none
+ save
+
+ character*20 here
+ parameter (here='sane_register_variables')
+
+ logical ABORT
+ character*(*) err
+
+ logical FAIL
+ character*1000 why
+
+ err= ' '
+ ABORT= .false.
+
+ call r_sane_data_structures
+
+ call r_sane_filenames
+
+ call r_sane_ntuple
+
+*****************************************************************************
+*****************************************************************************
+
+ call sane_ntup_register(FAIL,why) ! remove this when ctp files fixed
+ if(err.ne.' '.and.why.ne.' ') then
+ call G_append(err,' & '//why)
+ else if(why.ne.' ') then
+ err=why
+ endif
+ abort = abort.or.fail
+
+ if(abort.or.err.ne.' ') call G_add_path(here,err)
+
+ return
+ end
+
+*****************************************************************************
+*****************************************************************************
+
diff --git a/SANE/sane_reset_event.f b/SANE/sane_reset_event.f
new file mode 100644
index 0000000..350cd34
--- /dev/null
+++ b/SANE/sane_reset_event.f
@@ -0,0 +1,150 @@
+ subroutine SANE_RESET_EVENT(ABORT,err)
+ IMPLICIT NONE
+ SAVE
+
+ character*13 here
+ parameter (here= 'sane_clear_event')
+
+ logical ABORT
+ character*(*) err
+
+ call lucite_sane_clear_event(ABORT,err)
+ call cerenkov_sane_clear_event(ABORT,err)
+ call tracker_sane_clear_event(ABORT,err)
+ call SANE_DUMP_NTUP_VAR()
+
+
+ end
+
+**********************************************************
+**********************************************************
+
+ SUBROUTINE lucite_sane_reset_event(ABORT,err)
+ IMPLICIT NONE
+ SAVE
+
+ INCLUDE 'sane_data_structures.cmn'
+ INCLUDE 'sane_ntuple.cmn'
+ character*13 here
+ parameter (here= 'lucite_sane_clear_event')
+
+ logical ABORT
+ character*(*) err
+ integer*4 i
+
+ LUCITE_SANE_RAW_TOT_HITS = 0
+ LUCITE_SANE_RAW_TOT_HITS2 = 0
+ LUCITE_SANE_RAW_TOT_HITS3 = 0
+c LUCITE_SANE_RAW_PLANE = 0
+
+ do i=1,LUCITE_SANE_MAX_HITS
+
+ LUCITE_SANE_RAW_COUNTER_NUM(i) = 0
+ LUCITE_SANE_RAW_COUNTER_NUM2(i) = 0
+ LUCITE_SANE_RAW_COUNTER_NUM3(i) = 0
+ LUCITE_SANE_RAW_ADC_POS(i) = 0
+ LUCITE_SANE_RAW_ADC_NEG(i) = 0
+ LUCITE_SANE_RAW_TDC_POS(i) = 0
+ LUCITE_SANE_RAW_TDC_NEG(i) = 0
+
+ enddo
+ do i=1,luc_hit
+ ltdc_pos(i) = 0
+ ltdc_neg(i) = 0
+ ladc_pos(i) = 0
+ ladc_neg(i) = 0
+ enddo
+
+ luc_hit = 0
+
+ ABORT= .FALSE.
+ err= ' '
+ RETURN
+ END
+
+**********************************************************
+**********************************************************
+
+ SUBROUTINE cerenkov_sane_reset_event(ABORT,err)
+ IMPLICIT NONE
+ SAVE
+
+ INCLUDE 'sane_data_structures.cmn'
+ INCLUDE 'sane_ntuple.cmn'
+ character*13 here
+ parameter (here= 'cerenkov_sane_clear_event')
+
+ logical ABORT
+ character*(*) err
+ integer*4 i
+
+ CERENKOV_SANE_RAW_TOT_HITS = 0
+ CERENKOV_SANE_RAW_TOT_HITS2 = 0
+c CERENKOV_SANE_RAW_PLANE = 0
+
+ do i=1,CERENKOV_SANE_MAX_HITS
+ CERENKOV_SANE_RAW_COUNTER_NUM(i) = 0
+ CERENKOV_SANE_RAW_COUNTER_NUM2(i) = 0
+ CERENKOV_SANE_RAW_ADC(i) = 0
+ CERENKOV_SANE_RAW_TDC(i) = 0
+ if(i.le.cer_hit)then
+ cer_tdc(i) = 0
+ cer_adcc(i) = 0
+ endif
+
+
+ enddo
+ cer_hit = 0
+
+
+ ABORT= .FALSE.
+ err= ' '
+ RETURN
+ END
+
+**********************************************************
+**********************************************************
+
+ SUBROUTINE tracker_sane_reset_event(ABORT,err)
+ IMPLICIT NONE
+ SAVE
+
+ character*50 here
+ parameter (here= 'tracker_sane_clear_event')
+
+ logical ABORT
+ character*(*) err
+
+ INCLUDE 'sane_data_structures.cmn'
+ INCLUDE 'sane_ntuple.cmn'
+ integer*4 i
+
+ TRACKER_SANE_RAW_TOT_HITS_Y = 0
+ TRACKER_SANE_RAW_TOT_HITS_X = 0
+c TRACKER_SANE_RAW_PLANE_Y = 0
+c TRACKER_SANE_RAW_PLANE_X = 0
+
+ do i=1,TRACKER_SANE_MAX_HITS
+ TRACKER_SANE_RAW_COUNTER_Y(i) = 0
+ TRACKER_SANE_RAW_COUNTER_X(i) = 0
+ TRACKER_SANE_RAW_TDC_Y(i) = 0
+ TRACKER_SANE_RAW_TDC_X(i) = 0
+ x1t_tdc(i) = 0
+ x1t_row(i) = -200
+ y1t_tdc(i) = 0
+ y1t_row(i) = -200
+ y2t_tdc(i) = 0
+ y2t_row(i) = -200
+ enddo
+ x1t_hit = 0
+ y1t_hit = 0
+ y2t_hit = 0
+
+ ABORT= .FALSE.
+ err= ' '
+ RETURN
+
+ end
+
+**********************************************************
+**********************************************************
diff --git a/SANE/sane_trgtrack.f b/SANE/sane_trgtrack.f
new file mode 100644
index 0000000..73d4aaa
--- /dev/null
+++ b/SANE/sane_trgtrack.f
@@ -0,0 +1,903 @@
+*------------------------------------------------------------------------
+*
+* TRG_TRACK GEN Target Rracking routines
+* -=========-
+*
+* tracks ELECTRONS through polarized target B field
+*
+* Raytracing of 3-d motion in polarized target field by solution
+* of differential equations of motion via 4th order Runge-Kutta. Field
+* orientation arbitrary.
+*
+* Note: - the HMS routines use a right handed coord. system with
+* x : pointing downwards
+* y : perpendicular to x,z,
+* pointing to the left (if seen in z-direction)
+* z : BEAM axis or HMS axis, pointing downstream or
+* from the target to the focal plane respectively
+*
+* - the B field map uses a cylindrical coordinate system
+* with z along the field axis and r perpendicular to it
+*
+* - all length (x,y,z,dl,l,...) are measured in [cm]
+* - all velocities are measured in [cm/ns]
+* - all angles are measured counter clock wise in [deg]
+* - time is measured in [ns]
+* - the B field is measured in [T]
+*
+* original devloped by ???
+* widely modified by MM
+* - converted into subroutines
+* - rotation algorytm correced (at moment: phi==0 assumed)
+* - changed coordinate system
+* beam direction: z
+* horizontal plane: zy
+* out of plane: x (points downwards)
+*
+* Supplies:
+* trgInit (map,theta,phi)
+* load the target field map
+* trgTrack (u,E,dl,l)
+*
+* Note: - Before calling trgTrack,trgXTrack or trgTrackToPlane
+* the target field map has to be loaded by a call to
+* trgInit
+*------------------------------------------------------------------------
+
+
+*------------------------------------------------------------------------------
+* load the field map and calculate the magnetic field strength
+*
+ SUBROUTINE trgInit(map)
+ IMPLICIT NONE
+ CHARACTER map*(*)
+ include 'sane_data_structures.cmn'
+* -- read field map (for calculations in the LAB system)
+*
+* Parameter:
+* map I : filename of the fieldmap (=' ': uniform field test case)
+*
+* note: currently phi is always treated as 0
+*
+
+ INTEGER nz,nr
+ PARAMETER (nz = 337)
+ PARAMETER (nr = 337)
+
+ REAL*8 B_field_z(nz,nr),B_field_r(nz,nr),zz(nz),rr(nr)
+ REAL*8 B_theta,B_stheta,B_ctheta,B_phi,B_sphi,B_cphi
+
+ COMMON /trgFieldStrength/ B_field_z,B_field_r,zz,rr
+ COMMON /trgFieldAngles/ B_theta,B_stheta,B_ctheta,
+ , B_phi, B_sphi, B_cphi
+
+ REAL*8 pi180
+ PARAMETER (pi180 = 3.141592653/180.)
+
+ INTEGER ir,iz
+ REAL*8 xx, scale
+
+
+ ! if desired target field is 0, set it to nominal 5.1
+ ! if it is -999.9 set it to 0
+c scale = 10.0d0 ! return field in kG for GEANT, not T
+
+ if (SANE_TGTFIELD_B .eq. 0.0) then
+ scale = 1.0
+ print *," f-f-f-f target field NOT rescaled f-f-f-f"
+ elseif (SANE_TGTFIELD_B.eq. -999.9) then
+ scale = 0.0
+ print *," f-f-f-f target field scaled to 0 f-f-f-f"
+ else
+ scale = SANE_TGTFIELD_B/5.1
+ print *," f-f-f-f target field scaled to ",
+ , " f-f-f-f"
+ endif
+c scale=10000
+
+ IF (map .NE. ' ') THEN !read in numerical field map
+ write(*,*)'OPENING MAP FILE =',map
+ OPEN (unit=1,file=map,status='old')
+ DO ir=1,nr
+ rr(ir) = 2.*float(ir-1)
+ zz(ir) = 2.*float(ir-1)
+ DO iz=1,nz
+ READ (1,*)xx,xx,B_field_z(iz,ir),B_field_r(iz,ir),xx,xx,xx
+ ! rescale field to desired value
+ B_field_z(iz,ir) = B_field_z(iz,ir) * scale
+ B_field_r(iz,ir) = B_field_r(iz,ir) * scale
+ ENDDO
+ ENDDO
+ CLOSE (unit=1)
+ ELSE
+ DO ir=1,nr ! uniform 5T field over 26 cm in z
+ rr(ir) = 2.*float(ir-1) ! and 16 cm in r
+ zz(ir) = 2.*float(ir-1)
+ DO iz=1,nz
+ B_field_r(iz,ir) = 0.
+ IF (rr(ir) .LE. 16. .and. zz(ir) .LE. 26.) THEN
+ B_field_z(iz,ir) = SANE_TGTFIELD_B
+ ELSE
+ B_field_z(iz,ir) = 0.0
+ ENDIF
+ ENDDO
+ ENDDO
+ ENDIF
+
+ write(*,*) 'Target field : ',SANE_TGTFIELD_B
+ write(*,*) 'Target field initiated with file: ',map
+
+ RETURN
+ END
+
+* ******************************************************
+ Subroutine trgInitFieldANGLES(theta,phi)
+* theta,phi I : inplane (theta) and out of plane (phi) angle
+ IMPLICIT NONE
+ REAL*8 theta,phi
+
+ REAL*8 B_theta,B_stheta,B_ctheta,B_phi,B_sphi,B_cphi
+ COMMON /trgFieldAngles/ B_theta,B_stheta,B_ctheta,
+ > B_phi, B_sphi, B_cphi
+ REAL*8 pi180,p,p0
+ PARAMETER (pi180 = 3.141592653/180.)
+c write(*,*) 'target theta = ',theta
+ B_theta = theta
+ B_stheta = SIN(theta*pi180)*cos(phi*pi180)
+ B_ctheta = COS(theta*pi180)
+
+ ! Note: for performance reasons B_phi is always treated 0 in trgField
+ B_phi = phi
+ B_sphi = SIN(phi*pi180)
+ B_cphi = COS(phi*pi180)
+ end
+
+
+
+*------------------------------------------------------------------------
+ subroutine TransformTo6Vector(x,y,z,px,py,pz,E,U)
+cc
+c
+c x,y,z coordinates ! Coor should be in z - along beamline
+c y - along the target insert
+c x perpendicular
+c px,py,pz - momentum components in GEV
+c E - energy in GEV
+c U(6) is six dimentional vector used in Tracking
+c
+cc
+ real*8 U(6)
+ real*4 x,y,z,px,py,pz,E
+
+ U(1) = y
+ U(2) = x
+ U(3) = z
+ U(4) = py/E*29.97
+ U(5) = px/E*29.97
+ U(6) = pz/E*29.97
+ end
+ subroutine TransformFROM6Vector(PCooR,PMom,E,U)
+cc
+c
+c x,y,z coordinates ! Coor should be in z - along beamline
+c y - along the target insert
+c x perpendicular
+c px,py,pz - momentum components in GEV
+c E - energy in GEV
+c U(6) is six dimentional vector used in Tracking
+c
+cc
+ real*8 U(6)
+ real*4 PCoor(3),PMom(3),E
+
+ PCoor(2) = U(1)
+ PCoor(1) = U(2)
+ PCoor(3) = U(3)
+ Pmom(2) = U(4)*E/29.97
+ Pmom(1) = U(5)*E/29.97
+ Pmom(3) = U(6)*E/29.97
+ end
+
+ subroutine TransformFrom6VectorC(x,y,z,px,py,pz,E,U)
+cc
+c Transforms from 6 Vector from tracking to XYZ,PX,PY,PZ
+c x,y,z coordinates ! Coor should be in z - along beamline
+c y - along the target insert
+c x perpendicular
+c px,py,pz - momentum components in GEV
+c E - energy in GEV
+c U(6) is six dimentional vector used in Tracking
+c
+cc
+ real*8 U(6)
+ real*4 x,y,z,px,py,pz,E
+
+ y = U(1)
+ x = U(2)
+ z = U(3)
+ py = U(4)*E/29.97
+ px = U(5)*E/29.97
+ pz = U(6)*E/29.97
+ end
+
+ccccccccccccccccccccccccccccccccccccccccccccccccc
+
+
+ SUBROUTINE trgTrack (u,E,dl,l)
+ IMPLICIT NONE
+ REAL*8 u(6),E,dl,l
+* -- track a single particle with given start parameters
+*
+* Parameter:
+* u IO : coordinate vector (initial/final)
+* u(1,2,3) : x, y, z [cm]
+* u(4,5,6) : dx/dt, dy/dt, dz/dt [cm/ns]
+* E I : particle energy [MeV] * sign of particle charge
+* (negative for electrons, positive for protons/deuterons)
+* dl I : step size [cm]
+* l I : tracking distance [cm]
+
+ REAL*8 factor
+ COMMON /trgConversionFactor/factor
+
+ REAL*8 ts
+ INTEGER i,n
+
+ factor = 90./E
+ ts = dl/30.
+ n = ABS(l/dl)
+
+ DO i=1,n !step thru time
+ CALL trgRK4(u,u,ts) !solve diff. eqs.
+ ENDDO
+
+ RETURN
+ END
+
+*------------------------------------------------------------------------
+
+ SUBROUTINE trgXTrack (u,E,dl,l,Bdl,Xfun,id)
+ IMPLICIT NONE
+ REAL*8 u(6),E,dl,l,Bdl
+ INTEGER id
+ INTEGER Xfun
+ EXTERNAL Xfun
+* -- track a single particle with given start parameters and
+* writes the track's coordinates to a hbook file
+*
+* Parameter:
+* u IO : coordinate vector (initial/final)
+* u(1,2,3) : x, y, z [cm]
+* u(4,5,6) : dx/dt, dy/dt, dz/dt [cm/ns]
+* E I : particle energy [MeV] * sign of particle charge
+* (negative for electrons, positive for protons/deuterons)
+* dl I : step size [cm]
+* l I : tracking distance [cm]
+* Bdl O : Integrated Bdl [Tcm]
+* Xfun I : external function called after every iteration
+* int Xfun (id,t,l,u)
+* int id as passed to trgXtrack
+* real*8t,l,u(9) time, pathlength and act. coordinates
+* id I : histogram id
+
+
+ REAL*8 factor
+ COMMON /trgConversionFactor/factor
+
+ REAL*8 ts,uu(9)
+ INTEGER i,n,x
+
+ factor = 90./E
+ ts = dl/30.
+ n = l/dl
+
+ ! book start location
+ DO i=1,6
+ uu (i) = u(i)
+ ENDDO
+ DO i=7,9
+ uu (i) = 0.
+ ENDDO
+ x = Xfun(id,0.,0.,uu)
+
+ ! track the particle and book location
+ DO i=1,n
+ CALL trgRK4Bdl(uu,uu,ts) ! solve diff. eqs.
+ x = Xfun (id,i*ts,i*dl,uu)
+ ENDDO
+
+ DO i=1,6
+ u(i) = uu (i)
+ ENDDO
+
+ ! calculate Bdl ( B_x^2+B_y^2+B_z^2 )
+ Bdl = SQRT(uu(7)**2+uu(8)**2+uu(9)**2)
+
+ RETURN
+ END
+
+*------------------------------------------------------------------------
+
+ SUBROUTINE trgTrackToLine (u,E,dl,P1,P2,ok)
+ IMPLICIT NONE
+ REAL*8 u(6),E,dl,p1(3),P2(3)
+ LOGICAL ok
+* -- track a single particle with given start parameters
+* and find the closest aproach of the particle track with a given lane
+*
+* Parameter:
+* u IO : coordinate vector (initial/final)
+* u0(1,2,3) : x, y, z [cm]
+* u0(4,5,6) : dx/dt, dy/dt, dz/dt [cm/ns]
+* E I : particle energy [MeV] * sign of particle charge
+* (negative for electrons, positive for protons/deuterons)
+* dl I : step size [cm]
+* P1 and P2 I : two poinst on the lane
+* ok IO : status variable
+* - if false no action is taken
+* - set to false when no intersection point is found
+*
+
+ REAL*8 factor
+ COMMON /trgConversionFactor/factor
+ REAL*8 one, Coordinate(3)
+ REAL*8 ts,n,an,bn,cn,dn,maxdist,dist0,dist1,u0(6),u1(6)
+ integer idist0,idist1,icount
+ INTEGER i
+ one = 1.
+
+ IF (.NOT. OK) RETURN
+
+ factor = 90./E
+ ts = -dl/30.
+ Coordinate(1) = u(1)
+ Coordinate(2) = u(2)
+ Coordinate(3) = u(3)
+ call Dist2Lane(P1,P2,Coordinate,dist0)
+ maxdist = max(ABS(dist0)*4.,1.0)
+
+ ! check for the tracking direction
+ CALL trgRK4(u,u0,ts)
+ do i=1,6
+ u1(i) = u0(i)
+ enddo
+
+ Coordinate(1) = u1(1)
+ Coordinate(2) = u1(2)
+ Coordinate(3) = u1(3)
+ call Dist2Lane(P1,P2,Coordinate,dist1)
+ IF (dist1.gt.dist0) ts=-ts
+
+ ! track through the intersection plane
+ dist0 = dist1
+ icount=0
+ DO WHILE (dist1.le.dist0.and.icount.lt.100000)
+c write(*,*)dist0,dist1,icount
+ icount=icount+1
+ dist0 = dist1
+ do i=1,6
+ u1(i) = u0(i)
+ enddo
+ CALL trgRK4(u1,u0,ts)
+ Coordinate(1) = u0(1)
+ Coordinate(2) = u0(2)
+ Coordinate(3) = u0(3)
+ call Dist2Lane(P1,P2,Coordinate,dist1)
+
+ ENDDO
+ if(icount.lt.100000)then
+ do i=1,6
+ u(i) = u1(i)
+ enddo
+ endif
+ if(icount.gt.100000) write(*,*)'Failed'
+ RETURN
+ END
+
+ SUBROUTINE trgTrackToLineBDL (u,E,dl,P1,P2,ok)
+ IMPLICIT NONE
+ REAL*8 u(9),E,dl,p1(3),P2(3)
+ LOGICAL ok
+* -- track a single particle with given start parameters
+* and find the closest aproach of the particle track with a given lane
+*
+* Parameter:
+* u IO : coordinate vector (initial/final)
+* u0(1,2,3) : x, y, z [cm]
+* u0(4,5,6) : dx/dt, dy/dt, dz/dt [cm/ns]
+* E I : particle energy [MeV] * sign of particle charge
+* (negative for electrons, positive for protons/deuterons)
+* dl I : step size [cm]
+* P1 and P2 I : two poinst on the lane
+* ok IO : status variable
+* - if false no action is taken
+* - set to false when no intersection point is found
+*
+
+ REAL*8 factor
+ COMMON /trgConversionFactor/factor
+ REAL*8 one, Coordinate(3)
+ REAL*8 ts,n,an,bn,cn,dn,maxdist,dist0,dist1,u0(6),u1(6)
+ integer idist0,idist1,icount
+ INTEGER i
+ one = 1.
+
+ IF (.NOT. OK) RETURN
+
+ factor = 90./E
+ ts = -dl/30.
+ Coordinate(1) = u(1)
+ Coordinate(2) = u(2)
+ Coordinate(3) = u(3)
+ call Dist2Lane(P1,P2,Coordinate,dist0)
+ maxdist = max(ABS(dist0)*4.,1.0)
+
+ ! check for the tracking direction
+ CALL trgRK4(u,u0,ts)
+ do i=1,6
+ u1(i) = u0(i)
+ enddo
+
+ Coordinate(1) = u1(1)
+ Coordinate(2) = u1(2)
+ Coordinate(3) = u1(3)
+ call Dist2Lane(P1,P2,Coordinate,dist1)
+ IF (dist1.gt.dist0) ts=-ts
+
+ ! track through the intersection plane
+ dist0 = dist1
+ icount=0
+ DO WHILE (dist1.le.dist0.and.icount.lt.100000)
+c write(*,*)dist0,dist1,icount
+ icount=icount+1
+ dist0 = dist1
+ do i=1,6
+ u1(i) = u0(i)
+ enddo
+ CALL trgRK4(u1,u0,ts)
+ Coordinate(1) = u0(1)
+ Coordinate(2) = u0(2)
+ Coordinate(3) = u0(3)
+ call Dist2Lane(P1,P2,Coordinate,dist1)
+
+ ENDDO
+ if(icount.lt.100000)then
+ do i=1,6
+ u(i) = u1(i)
+ enddo
+ endif
+ if(icount.gt.100000) write(*,*)'Failed'
+ RETURN
+ END
+c
+c
+ Subroutine Dist2Lane(PLine1,PLine2,Dot,Dist)
+ IMPLICIT NONE
+ real*8 PLine1(3),PLine2(3),Dot(3)
+ real*8 Vect1(3),Vect2(3),VectCross(3)
+ real*8 Dist,val0,val1
+ call Sub3Vec(PLine1,PLine2,Vect1)
+ call Sub3Vec(PLine1,DOT,Vect2)
+ call CROSS(Vect1,Vect2,VectCross)
+ call value(VectCross,val0)
+ call value(Vect1,val1)
+ Dist = val0/val1
+ end
+c
+ Subroutine CROSS(P1,P2,P12)
+ IMPLICIT NONE
+ real*8 P1(3),P2(3),P12(3)
+ p12(1) = P1(2)*P2(3) - P1(3)*P2(2)
+ p12(2) = P1(3)*P2(1) - P1(1)*P2(3)
+ p12(3) = P1(1)*P2(2) - P1(2)*P2(1)
+ end
+c
+ Subroutine Value(P,val)
+ IMPLICIT NONE
+ real*8 P(3)
+ real*8 Val
+ Val = sqrt(P(1)**2+P(2)**2+P(3)**2)
+ end
+c
+ Subroutine Sub3Vec(P1,P2,P12)
+ IMPLICIT NONE
+ real*8 P1(3),P2(3),P12(3)
+ P12(1) = P1(1) - P2(1)
+ P12(2) = P1(2) - P2(2)
+ P12(3) = P1(3) - P2(3)
+ end
+
+*------------------------------------------------------------------------
+
+ SUBROUTINE trgTrackToPlaneBDL (u,E,dl,a,b,c,d,ok)
+ IMPLICIT NONE
+! REAL u(6),E,dl,a,b,c,d
+ REAL*8 u(9),E,dl,a,b,c,d
+ LOGICAL ok
+* -- track a single particle with given start parameters
+* and find the intersection of the particle track with a given plane
+*
+* Parameter:
+* u IO : coordinate vector (initial/final)
+* u0(1,2,3) : x, y, z [cm]
+* u0(4,5,6) : dx/dt, dy/dt, dz/dt [cm/ns]
+* E I : particle energy [MeV] * sign of particle charge
+* (negative for electrons, positive for protons/deuterons)
+* dl I : step size [cm]
+* a..d I : parameter of the intersection plane
+* 0 = a*x+b*y+c*z+d;
+* ok IO : status variable
+* - if false no action is taken
+* - set to false when no intersection point is found
+*
+c
+ INCLUDE 'gen_event_info.cmn'
+ logical outside_fieldmap
+ common /mkjtemp/ outside_fieldmap
+c
+ REAL*8 factor
+ COMMON /trgConversionFactor/factor
+
+! REAL ts,n,an,bn,cn,dn,maxdist,dist0,dist1,u0(6),u1(6)
+ REAL*8 ts,n,an,bn,cn,dn,maxdist,dist0,dist1,u0(9),u1(9)
+
+ INTEGER i,steps,max_steps
+! For Bdl
+ do i=7,9
+ u(i)=0.0
+ u0(i)=0.0
+ u1(i)=0.0
+ end do
+
+ IF (.NOT. OK) RETURN
+
+ n = 1/SQRT (a*a+b*b+c*c)
+ an = a*n
+ bn = b*n
+ cn = c*n
+ dn = d*n
+
+ factor = 90./E
+! ts = -dl/30.
+ ts = -dl/sqrt(u(4)**2+u(5)**2+u(6)**2) ! to match MC OR - 4/04
+
+
+ dist0 = u(1)*an + u(2)*bn + u(3)*cn + dn
+ maxdist = max(ABS(dist0)*4.,1.0)
+
+ ! check for the tracking direction
+! CALL trgRK4(u,u1,ts)
+ CALL trgRK4Bdl(u,u1,ts)
+ dist1 = u1(1)*an + u1(2)*bn + u1(3)*cn + dn
+ IF ((sign(1.d00,dist0) .EQ. sign(1.d00,dist1)) .AND.
+ > (ABS(dist0) .LT. ABS(dist1))) ts=-ts
+
+ ! track through the intersection plane
+ steps=0
+ max_steps = int(max(dist0,10.*dl)/dl)*10
+ if (sign(1.d00,dist0) .EQ. sign(1.d00,dist1)) then
+ dist1 = dist0
+ DO WHILE ((sign(1.d00,dist0) .EQ. sign(1.d00,dist1)) .AND. ok)
+! CALL trgRK4(u1,u0,ts)
+ CALL trgRK4Bdl(u1,u0,ts)
+ dist0 = u0(1)*an + u0(2)*bn + u0(3)*cn + dn
+ IF (sign(1.d00,dist0) .EQ. sign(1.d00,dist1)) THEN
+! CALL trgRK4(u0,u1,ts)
+ CALL trgRK4Bdl(u0,u1,ts)
+ dist1 = u1(1)*an + u1(2)*bn + u1(3)*cn + dn
+ ENDIF
+ ok = (ABS(dist1) .LT. maxdist) .and. steps .lt. max_steps
+ steps = steps + 1
+ ENDDO
+ else
+ do i=1,6
+ u0(i) = u(i)
+ enddo
+ endif
+
+
+
+ IF (ok) THEN
+ ! calculate the intersection point
+ DO i=1,6
+ u(i) = u0(i) + (u1(i)-u0(i)) * dist0/(dist0-dist1)
+ ENDDO
+
+! Bdl
+
+ do i=7,9
+ u(i) = u0(i) + (u1(i)-u0(i)) * dist0/(dist0-dist1)
+! u(i)=u0(i)
+ end do
+
+ ENDIF
+
+ RETURN
+ END
+
+*------------------------------------------------------------------------
+
+ SUBROUTINE trgTrackToPlane (u,E,dl,a,b,c,d,ok)
+ IMPLICIT NONE
+ REAL*8 u(6),E,dl,a,b,c,d
+ LOGICAL ok
+* -- track a single particle with given start parameters
+* and find the intersection of the particle track with a given plane
+*
+* Parameter:
+* u IO : coordinate vector (initial/final)
+* u0(1,2,3) : x, y, z [cm]
+* u0(4,5,6) : dx/dt, dy/dt, dz/dt [cm/ns]
+* E I : particle energy [MeV] * sign of particle charge
+* (negative for electrons, positive for protons/deuterons)
+* dl I : step size [cm]
+* a..d I : parameter of the intersection plane
+* 0 = a*x+b*y+c*z+d;
+* ok IO : status variable
+* - if false no action is taken
+* - set to false when no intersection point is found
+*
+
+ REAL*8 factor
+ COMMON /trgConversionFactor/factor
+ REAL*8 one
+ REAL*8 ts,n,an,bn,cn,dn,maxdist,dist0,dist1,u0(6),u1(6)
+ integer idist0,idist1
+ INTEGER i
+ one = 1.
+ IF (.NOT. OK) RETURN
+
+ n = 1/SQRT (a*a+b*b+c*c)
+ an = a*n
+ bn = b*n
+ cn = c*n
+ dn = d*n
+
+ factor = 90./E
+ ts = -dl/30.
+
+ dist0 = u(1)*an + u(2)*bn + u(3)*cn + dn
+ maxdist = max(ABS(dist0)*4.,1.0)
+
+ ! check for the tracking direction
+ CALL trgRK4(u,u1,ts)
+ dist1 = u1(1)*an + u1(2)*bn + u1(3)*cn + dn
+ IF ((SIGN(one,dist0) .EQ. SIGN(one,dist1)) .AND.
+ > (ABS(dist0) .LT. ABS(dist1))) ts=-ts
+
+ ! track through the intersection plane
+ dist1 = dist0
+ DO WHILE ((SIGN(one,dist0) .EQ. SIGN(one,dist1)) .AND. ok)
+ CALL trgRK4(u1,u0,ts)
+ dist0 = u0(1)*an + u0(2)*bn + u0(3)*cn + dn
+
+ IF (SIGN(one,dist0) .EQ. SIGN(one,dist1)) THEN
+ CALL trgRK4(u0,u1,ts)
+ dist1 = u1(1)*an + u1(2)*bn + u1(3)*cn + dn
+ ENDIF
+ ok = (ABS(dist1) .LT. maxdist)
+ ENDDO
+
+ IF (ok) THEN
+ ! calculate the intersection point
+ DO i=1,6
+ u(i) = u0(i) + (u1(i)-u0(i)) * dist0/(dist0-dist1)
+ ENDDO
+ ENDIF
+
+ RETURN
+ END
+
+*------------------------------------------------------------------------
+
+ SUBROUTINE trgField (x_,B_)
+ IMPLICIT NONE
+ REAL*8 x_(3),B_(3)
+* -- calculate actual field
+*
+* Parameter:
+* x_ I : lab coordinates
+* B_ O : B field in lab coordinates
+*
+* Notes:
+* - 2-Dimensional Linear Interpolation:
+* Assumes uniform spacing of fieldmap in x,y
+* - for performance reasons B_phi is always treated 0
+
+ INTEGER nz,nr
+ PARAMETER (nz = 337)
+ PARAMETER (nr = 337)
+
+ REAL*8 B_field_z(nz,nr),B_field_r(nz,nr),zz(nz),rr(nr)
+ REAL*8 B_theta,B_stheta,B_ctheta,B_phi,B_sphi,B_cphi
+
+ COMMON /trgFieldStrength/ B_field_z,B_field_r,zz,rr
+ COMMON /trgFieldAngles/ B_theta,B_stheta,B_ctheta,
+ > B_phi, B_sphi, B_cphi
+
+ INTEGER i,j
+ REAL*8 x(3),B(3),z,r,az,ar,a0,a1
+
+ ! rotate to coordinates with z' along field direction
+ x(1) = x_(1)
+ x(2) = B_stheta*x_(3) + B_ctheta*x_(2)
+ x(3) = B_ctheta*x_(3) - B_stheta*x_(2)
+
+ ! compute zylinder coordinates
+ z = ABS (x(3))
+ r = SQRT (x(1)**2 + x(2)**2)
+
+ ! interpolate the field map
+ i = INT((z-zz(1))/(zz(2)-zz(1))) + 1
+ j = INT((r-rr(1))/(rr(2)-rr(1))) + 1
+ IF ((i+1 .GT. nz) .OR. (i .LT. 1) .OR.
+ > (j+1 .GT. nr) .OR. (j .LT. 1)) THEN
+ B(1)=0.
+ B(2)=0.
+ B(3)=0.
+ B_(1)=0.
+ B_(2)=0.
+ B_(3)=0.
+ ELSE
+ ! calculate the Bz component
+ az = ((z-zz(i))/(zz(2)-zz(1)))
+ ar = ((r-rr(j))/(rr(2)-rr(1)))
+ a0=az*(B_field_z(i+1,j) -B_field_z(i,j)) +B_field_z(i,j)
+ a1=az*(B_field_z(i+1,j+1)-B_field_z(i,j+1))+B_field_z(i,j+1)
+ B(3) = (ar*(a1-a0)+a0)
+ IF (r .gt. 0.) THEN
+ ! calculate the Bx,By components
+ a0=az*(B_field_r(i+1,j) -B_field_r(i,j)) +B_field_r(i,j)
+ a1=az*(B_field_r(i+1,j+1)-B_field_r(i,j+1))+B_field_r(i,j+1)
+ B(2) = (ar*(a1-a0)+a0)/r
+ IF (x(3) .LT. 0.) B(2)= -B(2)
+ B(1) = B(2)*x(1)
+ B(2) = B(2)*x(2)
+
+ ! transform B field to lab. system
+ B_(1) = B(1)
+ B_(2) = - B_stheta*B(3) + B_ctheta*B(2)
+ B_(3) = B_ctheta*B(3) + B_stheta*B(2)
+ ELSE
+ B_(1) = 0.
+ B_(2) = - B_stheta*B(3)
+ B_(3) = B_ctheta*B(3)
+ ENDIF
+ ENDIF
+
+ RETURN
+ END
+
+*------------------------------------------------------------------------------
+* solve the differential equation of the particle
+*
+ SUBROUTINE trgDeriv(u,dudt)
+ IMPLICIT NONE
+ REAL*8 u(9),dudt(9)
+* -- calculate the derivatives du(i)/dt for the runke kutta routine
+*
+* Parameter:
+* u I : actual coordinate vector
+* u(1,2,3) I : x, y, z
+* u(4,5,6) I : dx/dt, dy/dt, dz/dt
+* u(7,8,9) I : integral Bxdx, Bydy, Bzdz
+* dudt O : derivative du/dt
+* dudt(1,2,3) : dx/dt, dy/dt, dz/dt
+* dudt(4,5,6) : d^2xdt^2, d^2ydt^2, d^2zdt^2
+* dudt(7,8,9) : B x v
+
+ REAL*8 factor
+ COMMON /trgConversionFactor/factor
+
+ REAL*8 B(3)
+
+ CALL trgField (u,B)
+
+ ! These are just the velocities
+ dudt(1) = u(4)
+ dudt(2) = u(5)
+ dudt(3) = u(6)
+
+ ! This is just (v_vec X B_vec)
+ dudt(7) = u(5)*B(3) - u(6)*B(2)
+ dudt(8) = u(6)*B(1) - u(4)*B(3)
+ dudt(9) = u(4)*B(2) - u(5)*B(1)
+
+ ! This is just (v_vec X B_vec) * factor
+ dudt(4) = dudt(7)*factor
+ dudt(5) = dudt(8)*factor
+ dudt(6) = dudt(9)*factor
+
+ RETURN
+ END
+
+*------------------------------------------------------------------------------
+
+ SUBROUTINE trgRK4(u0,u1,h)
+ IMPLICIT NONE
+ REAL*8 u0(6),u1(6),h
+* -- Fourth-order Runge-Kutta from Numerical Recipes book
+* for tracking through the target field
+*
+* Parameter:
+* u0 I : input coordinate vector
+* u1 O : output coordinate vector
+* u(1,2,3) : x, y, z
+* u(4,5,6) : dx/dt, dy/dt, dz/dt
+* h I : time step
+
+ INTEGER i
+ REAL*8 ut(6),dudt(9),dut(9),dum(9),hh,h6
+
+ hh=h*0.5
+ h6=h/6.
+
+ CALL trgDeriv(u0,dudt)
+ DO i=1,6
+ ut(i) = u0(i) + hh*dudt(i)
+ ENDDO
+
+ CALL trgDeriv(ut,dut)
+ DO i=1,6
+ ut(i) = u0(i) + hh*dut(i)
+ ENDDO
+
+ CALL trgDeriv(ut,dum)
+ DO i=1,6
+ ut(i) = u0(i) +h*dum(i)
+ dum(i)= dut(i) +dum(i)
+ ENDDO
+
+ CALL trgDeriv(ut,dut)
+ DO i=1,6
+ u1(i)=u0(i)+h6*(dudt(i)+dut(i)+2.*dum(i))
+ ENDDO
+
+ RETURN
+ END
+
+*------------------------------------------------------------------------------
+
+ SUBROUTINE trgRK4Bdl(u0,u1,h)
+ IMPLICIT NONE
+ REAL*8 u0(9),u1(9),h
+* -- Fourth-order Runge-Kutta from Numerical Recipes book
+* for tracking through the target field (incl. B/dl calculation)
+*
+* Parameter:
+* u0 I : input coordinate vector
+* u1 O : output coordinate vector
+* u(1,2,3) : x, y, z
+* u(4,5,6) : dx/dt, dy/dt, dz/dt
+* u(7,8,9) : integral Bxdx, Bydy, Bzdz
+* h I : time step
+
+ INTEGER i
+ REAL*8 ut(9),dudt(9),dut(9),dum(9),hh,h6
+
+ hh=h*0.5
+ h6=h/6.
+
+ CALL trgDeriv(u0,dudt)
+ DO i=1,9
+ ut(i) = u0(i) + hh*dudt(i)
+ ENDDO
+
+ CALL trgDeriv(ut,dut)
+ DO i=1,9
+ ut(i) = u0(i) + hh*dut(i)
+ ENDDO
+
+ CALL trgDeriv(ut,dum)
+ DO i=1,9
+ ut(i) = u0(i) +h*dum(i)
+ dum(i)= dut(i) +dum(i)
+ ENDDO
+
+ CALL trgDeriv(ut,dut)
+ DO i=1,9
+ u1(i)=u0(i)+h6*(dudt(i)+dut(i)+2.*dum(i))
+ ENDDO
+
+ RETURN
+ END
diff --git a/SEM/.cvsignore b/SEM/.cvsignore
new file mode 100644
index 0000000..0b6ddf9
--- /dev/null
+++ b/SEM/.cvsignore
@@ -0,0 +1,2 @@
+O.*
+r_*.f
diff --git a/SEM/CVS/Entries b/SEM/CVS/Entries
new file mode 100644
index 0000000..b9760b7
--- /dev/null
+++ b/SEM/CVS/Entries
@@ -0,0 +1,12 @@
+/.cvsignore/1.1.2.1/Fri Apr 3 15:33:18 2009//Tsane
+/Makefile/1.1.2.1/Sat Oct 25 12:49:15 2008//Tsane
+/Makefile.Unix/1.1.2.1/Sat Oct 25 12:49:15 2008//Tsane
+/sem_analyze_pedestal.f/1.1.2.1/Sat Oct 25 12:49:15 2008//Tsane
+/sem_calc_pedestal.f/1.1.2.1/Sat Oct 25 12:49:15 2008//Tsane
+/sem_calc_sr_beampos.f/1.1.2.4/Fri Jun 5 18:08:02 2009//Tsane
+/sem_clear_event.f/1.1.2.1/Sat Oct 25 12:49:16 2008//Tsane
+/sem_decode.f/1.1.2.2/Fri Jan 16 18:48:01 2009//Tsane
+/sem_fill_tbpm.f/1.1.2.3/Wed Feb 11 21:42:32 2009//Tsane
+/sem_register_variables.f/1.1.2.1/Sat Oct 25 12:49:16 2008//Tsane
+/sem_reset_event.f/1.1.2.1/Sat Oct 25 12:49:16 2008//Tsane
+D
diff --git a/SEM/CVS/Repository b/SEM/CVS/Repository
new file mode 100644
index 0000000..008f05c
--- /dev/null
+++ b/SEM/CVS/Repository
@@ -0,0 +1 @@
+Analyzer/SEM
diff --git a/SEM/CVS/Root b/SEM/CVS/Root
new file mode 100644
index 0000000..6288c3f
--- /dev/null
+++ b/SEM/CVS/Root
@@ -0,0 +1 @@
+whit@cvs.jlab.org:/group/hallc/cvsroot
diff --git a/SEM/CVS/Tag b/SEM/CVS/Tag
new file mode 100644
index 0000000..25d73f7
--- /dev/null
+++ b/SEM/CVS/Tag
@@ -0,0 +1 @@
+Tsane
diff --git a/SEM/Makefile b/SEM/Makefile
new file mode 100755
index 0000000..d37f2d3
--- /dev/null
+++ b/SEM/Makefile
@@ -0,0 +1,17 @@
+#
+# $Log: Makefile,v $
+# Revision 1.1.2.1 2008/10/25 12:49:15 cdaq
+# *** empty log message ***
+#
+# Revision 1.1.2.1 2008/05/07 18:13:53 bhovik
+# starting files
+#
+# Revision 1.1.2.1 2007/05/15 01:19:10 jones
+# Start to Bigcal code
+#
+# Revision 1.1 1998/12/08 14:33:24 saw
+# Initial Setup
+#
+ETC=../etc
+
+include $(ETC)/Makefile.NEW
diff --git a/SEM/Makefile.Unix b/SEM/Makefile.Unix
new file mode 100644
index 0000000..7fd0a3e
--- /dev/null
+++ b/SEM/Makefile.Unix
@@ -0,0 +1,55 @@
+NEWSTYLE=1
+include ../../etc/Makefile
+include ../../etc/Makefile.flags
+
+
+osources = sem_analyze_pedestal.f sem_calc_pedestal.f sem_fill_tbpm.f \
+ sem_clear_event.f sem_register_variables.f sem_reset_event.f \
+ sem_decode.f sem_calc_sr_beampos.f
+
+makeregstuff = r_sem_data_structures.f
+
+
+sources = $(osources) $(makeregstuff)
+
+libsources = $(sources)
+
+lib_targets := $(patsubst %.f, libsem.a(%.o), $(libsources))
+install-dirs := lib
+bin_targets =
+
+#default:
+# @echo "nothing to make"
+
+ifdef NFSDIRECTORY
+../%.f : $(NFSDIRECTORY)/SEM/%.f
+ ln -s $< $@
+
+.PRECIOUS: ../%.f
+else
+#
+# Rule for making the register subroutines
+#
+../r_%.f : ../%.cmn $(MAKEREG)
+ (cd .. ; $(MAKEREG) $(<F) -o $(@F) -e /dev/null)
+
+.PRECIOUS: ../r_%.f
+endif
+
+#
+# Get include files from INCLUDE directory
+#
+
+%.cmn ../%.cmn:: ../../INCLUDE/%.cmn
+ $(CP) $< $@
+
+%.dec ../%.dec:: ../../INCLUDE/%.dec
+ $(CP) $< $@
+
+%.par ../%.par:: ../../INCLUDE/%.par
+ $(CP) $< $@
+
+%.dte ../%.dte:: ../../INCLUDE/%.dte
+ $(CP) $< $@
+
+include $(sources:.f=.d)
diff --git a/SEM/sem_analyze_pedestal.f b/SEM/sem_analyze_pedestal.f
new file mode 100644
index 0000000..3ff1785
--- /dev/null
+++ b/SEM/sem_analyze_pedestal.f
@@ -0,0 +1,58 @@
+ subroutine sem_analyze_pedestal(ABORT,err)
+ implicit none
+ save
+
+ INCLUDE 'sem_data_structures.cmn'
+
+ logical ABORT
+ character*(*) err
+ character*18 here
+ parameter (here='sem_analyze_pedestal')
+*
+ integer*4 ihit,counter,plane
+
+ logical atleastone
+
+
+
+
+ integer PLANE_TBPM
+ parameter (PLANE_TBPM=2)
+
+*-------------------------------------------------------
+
+ atleastone = .false.
+
+ do ihit = 1 , N_TBPM_TOT_HITS
+
+ plane = N_TBPM_ADDR1(ihit)
+ counter = N_TBPM_ADDR2(ihit)
+
+ if (plane .ne. PLANE_TBPM) then
+ write(6,*) ' !!!!! bad SEM plane ID=',plane,
+ > ' !!!! (should be=',PLANE_TBPM,') counter=',counter
+
+ elseif (counter .gt. num_tbpm) then
+ write(6,*) ' !!!!! bad SEM counter ID=,counter,
+ > ' !!!! (should not exceed ', num_tbpm, ')'
+
+ else
+ atleastone = .true.
+ ndet_ped_tbpm_sum2(counter) = ndet_ped_tbpm_sum2(counter) +
+ & N_TBPM_RAW_DATA(counter)* N_TBPM_RAW_DATA(counter)
+ ndet_ped_tbpm_sum(counter) = ndet_ped_tbpm_sum(counter) +
+ & N_TBPM_RAW_DATA(counter)
+
+ endif
+
+ enddo
+
+ if (atleastone) ndet_tbpm_ped_counts = ndet_tbpm_ped_counts + 1
+ if(ABORT) then
+ call G_add_path(here,err)
+ return
+ endif
+*
+
+ end
+
diff --git a/SEM/sem_calc_pedestal.f b/SEM/sem_calc_pedestal.f
new file mode 100644
index 0000000..641346c
--- /dev/null
+++ b/SEM/sem_calc_pedestal.f
@@ -0,0 +1,23 @@
+ SUBROUTINE sem_calc_pedestal(ABORT,err)
+ implicit none
+ save
+ INCLUDE 'sem_data_structures.cmn'
+
+ logical ABORT
+ character*(*) err
+ character*18 here
+ parameter (here='sem_calc_pedestal')
+ integer*4 pmt,i
+ real*4 num
+ num = ndet_tbpm_ped_counts
+ print *, 'artificially set PEDESTALS='
+ do i = 1,N_TBPM_ALL_CHAN
+ ndet_ped_tbpm(i) = float(ndet_ped_tbpm_sum(i))/num
+ ndet_ped_tbpm_sig(i) = sqrt(abs(float(ndet_ped_tbpm_sum2(i))/num
+ & - (ndet_ped_tbpm(i))**2))
+ enddo
+
+
+ end
+
+
diff --git a/SEM/sem_calc_sr_beampos.f b/SEM/sem_calc_sr_beampos.f
new file mode 100644
index 0000000..55c2c6d
--- /dev/null
+++ b/SEM/sem_calc_sr_beampos.f
@@ -0,0 +1,128 @@
+ SUBROUTINE sem_calc_sr_beampos
+*--------------------------------------------------------
+*-
+*- Purpose and Methods : determines position of raster beam
+*- at the target based on selected data.
+*-
+*--------------------------------------------------------
+ IMPLICIT NONE
+ SAVE
+
+ character*17 here
+ parameter (here= 'sem_calc_sr_beampos')
+
+ include 'gen_data_structures.cmn'
+c INCLUDE 'gen_constants.par'
+c include 'hms_bypass_switches.cmn'
+ include 'sem_data_structures.cmn'
+ include 'gen_constants.par'
+ include 'gen_event_info.cmn'
+c include 'gen_scalers.cmn'
+c include 'n_id_histid.cmn'
+
+ real*4 x_coord, y_coord
+
+
+* some comments before the code:
+* the SEM coordinate system is different from the HALL C coordinate
+* system that is used throughout the analysis code.
+*
+* 1) the positive SEM x coordinate points to the right when looking
+* in beam direction, this corresponds to negative y direction of
+* the HALL C transport coordinate system.
+* the ADC positive x coordinate points DOWN.
+*
+* 2) the positive SEM y coordinate points vertical up when looking
+* down stream this corresponds to negative x of the HALL C coordinate
+* system.
+* the ADC positive y coordinate points RIGHT, but historically
+* it has been assumed that it points left, thus all signs are
+* inverted in the code -- but that's OK, because the ADC calibration
+* automatically fixes that
+*
+* 3) the raster adc values are calibrated using the sem by fitting
+* the profile spectrum of SEM vs RASTER_ADC. So converting
+* from raster adc into mm gives results in SEM coordinate system
+* and to convert back to HALL C system one has to change signs of
+* the parameters!
+*
+* 4) we now have a new SEM mode, slow_raster_correction=4
+* the MEAN beam position comes from the SEM, via scalers, and the
+* event deviation is obtained from the raster ADC
+* we use the same ADC calibration constants for this mode
+* we use the same ADC calibration constants for this mode
+* but they have somewhat different meaning...
+*
+* 5) calibration of slow raster with SEM
+* * the ntbpmx and ntbpmy unit is millimeter
+* * the shared variables gSR_beamx,gSR_beamy use centimeters!
+
+*=============================Executable Code =============================
+
+* gsrx_adc is in ADC system
+* ntbpmx is in SEM system
+* x_coord is in SEM system
+* gsrx_calib is in SEM system
+* gSR_beamx is in TRANSPORT system
+
+
+ if ((slow_raster_correction.eq.0)
+ > .or. (slow_raster_correction.eq.-1)
+ > .or. (slow_raster_correction.eq.1)) then !use SEM data
+ x_coord = ntbpmx
+ y_coord = ntbpmy
+ gsrx_calib = gsry_raw_adc ! uncalibrated so we can
+ gsry_calib = gsrx_raw_adc ! determine calibration
+*
+*
+* mkj 2/20/2004 added parameters n_sr_adcx_zero,n_sr_adcy_zero
+* so that now n_sr_offsety,n_sr_offsetx are offsets in beam
+* position in which +x is horizontal beam right,+y is vertical up.
+*
+ else if (slow_raster_correction.eq.2) then ! use raster data
+c write(*,*)n_sr_size,n_sr_slopex,n_sr_adcx_zero
+ gsry_calib = n_sr_size/n_sr_slopey*(gsry_raw_adc-n_sr_adcy_zero)!-
+c , n_fr_size/n_fr_slopex*(gfrx_raw_adc-n_fr_adcx_zero)
+ gsrx_calib = n_sr_size/n_sr_slopex*(gsrx_raw_adc-n_sr_adcx_zero)!+
+ gsry_calib = gsry_calib + n_sr_offsety
+ gsrx_calib = gsrx_calib + n_sr_offsetx
+c , n_fr_size/n_fr_slopey*(gfry_raw_adc-n_fr_adcy_zero)
+c write(*,*)n_fr_slopey,n_fr_slopex
+ x_coord = gsrx_calib
+ y_coord = gsry_calib
+ if (gen_event_type .ne. 4 ) then
+ call HFILL(10210,gsry_raw_adc,gsrx_raw_adc, 1.)
+ call HFILL(10211,gfry_raw_adc,gfrx_raw_adc, 1.)
+
+ call HFILL(10212,gsrx_calib,gsry_calib, 1.)
+ call HFILL(10213,gbeam_y,gbeam_x, 1.)
+ endif
+c write(*,*)gsrx_calib,gsry_calib
+c else if (slow_raster_correction.eq.4) then ! use mixed mode
+c gsrx_calib = n_sr_slopex*(gsry_adc-n_sr_adcx_zero) + n_sr_offsetx
+c gsry_calib = n_sr_slopey*(gsrx_adc-n_sr_adcy_zero) + n_sr_offsety
+c x_coord = gsrx_calib - gsem_meanxpos
+c y_coord = gsry_calib - gsem_meanypos
+
+ else ! shouldn't happen!
+ x_coord = 0.
+ y_coord = 0.
+
+ endif
+* * correct units and switch to TRANSPORT system
+ gSR_beamx = x_coord
+ gSR_beamy = y_coord
+c write(*,*)gSR_beamx,gSR_beamy
+
+c* * in any case plot event SEM vs calib ADC
+c* mkj 1/23/02 change to plot tbpm without negative sign
+c call hf2(nidSEM_ADCx, n_sr_slopex*gsrx_adc+n_sr_offsetx, ntbpmy, 1.)
+c call hf2(nidSEM_ADCy, n_sr_slopey*gsry_adc+n_sr_offsety, ntbpmx, 1.)
+c
+cc mkj 1/23/02 switch y to horz axis
+c call hf2(nidndetsrADC, n_sr_slopey*gsry_adc+n_sr_offsety,
+c > n_sr_slopex*gsrx_adc+n_sr_offsetx, 1.)
+
+
+ return
+ end
diff --git a/SEM/sem_clear_event.f b/SEM/sem_clear_event.f
new file mode 100644
index 0000000..45b4369
--- /dev/null
+++ b/SEM/sem_clear_event.f
@@ -0,0 +1,24 @@
+ subroutine SEM_CLEAR_EVENT(ABORT,err)
+ IMPLICIT NONE
+ SAVE
+ INCLUDE 'sem_data_structures.cmn'
+
+ character*13 here
+ parameter (here= 'sem_clear_event')
+
+ logical ABORT
+ character*(*) err
+ integer i
+* SEM hits
+
+ N_TBPM_TOT_HITS = 0
+ do i=1,N_TBPM_ALL_CHAN
+ n_tbpm_addr1(i) = 0
+ n_tbpm_addr2(i) = 0
+ N_TBPM_RAW_DATA(i) = 0
+ enddo
+
+
+ end
+
+**********************************************************
diff --git a/SEM/sem_decode.f b/SEM/sem_decode.f
new file mode 100644
index 0000000..984badd
--- /dev/null
+++ b/SEM/sem_decode.f
@@ -0,0 +1,31 @@
+ subroutine sem_decode(pointer,lastslot, roc, bank,
+ & maxwords, did)
+
+
+*****************************************
+*****************************************
+
+ implicit none
+ integer*4 pointer,lastslot, roc, bank(*)
+ integer*4 maxwords, did
+ integer*4 g_decode_fb_detector ! Detector unpacking routine
+ include 'gen_detectorids.par'
+ include 'sem_data_structures.cmn'
+
+
+*****************************************
+*****************************************
+
+
+ if(did.eq.SEM_ID)then
+ pointer = pointer +
+ $ g_decode_fb_detector(lastslot, roc, bank(pointer),
+ & maxwords, did,
+ $ N_TBPM_ALL_CHAN , N_TBPM_TOT_HITS, N_TBPM_ADDR1,
+ $ N_TBPM_ADDR2, 1, N_TBPM_RAW_DATA, 0, 0, 0)
+c write(*,*)'SEM ',N_TBPM_TOT_HITS,did
+c write(*,*)'SEM ',N_TBPM_ADDR2
+c write(*,*)'SEM ',N_TBPM_RAW_DATA
+ endif
+
+ end
diff --git a/SEM/sem_fill_tbpm.f b/SEM/sem_fill_tbpm.f
new file mode 100644
index 0000000..3bda09f
--- /dev/null
+++ b/SEM/sem_fill_tbpm.f
@@ -0,0 +1,154 @@
+ subroutine sem_fill_tbpm()
+
+***********************************************************
+* Author: B. Zihlmann
+* Date: 16 june 1998
+*
+************************************************************
+* THE ADC IS LOCATED IN THE HMS FASTBUS CRATE SLOT 14
+* IN THE INPUT CHANNELS 0 - 7
+*
+* N_TBPM_RAW_DATA(1): I_CENTER_X
+* N_TBPM_RAW_DATA(2): INV I_CENTER_X
+* N_TBPM_RAW_DATA(3): I_EDGE_X
+* N_TBPM_RAW_DATA(4): INV I_EDGE_X
+*
+* N_TBPM_RAW_DATA(5): I_CENTER_Y
+* N_TBPM_RAW_DATA(6): INV I_CENTER_Y
+* N_TBPM_RAW_DATA(7): I_EDGE_Y
+* N_TBPM_RAW_DATA(8): INV I_EDGE_Y
+*
+* VARIABLE N_TBPM_CUTOFF: USED TO ELIMINATE ZERO DATA DUE TO BEAM OFF
+* VARIABLE N_TBPM_ADCCUT: CHECKS FOR ADC OVERFLOW
+*
+* ERROR MESSAGE IS CREATED WHEN ADC OVERFLOW OCCURE TOO FREQUENETLY
+*******************************************************************
+* changes
+* changes
+*
+* mz 04/17/00 Changed n_fill_tbpm.f from foil numbers to mm
+* (according to propsition from M. Steinacher)
+*
+* frw 11-2000 changed code to allow for out-of-plane reconstruction
+* even without raster.
+* new hms_recon_xychoice value of 0 forces bad SEM
+* event to be interpreted as being at center of target
+* frw 8-2001 new hms_recon_xychoice value of -1 forces SEM event
+* mode position to whatever user has specified
+* changed mode=0 to also use these values (0 is an option)
+* vht 11-2008 re-coded the new method of the old code, changed
+* the mapping of raw data in accordance with cabling
+* for SANE experiment.
+*******************************************************************
+
+ IMPLICIT NONE
+
+ character*50 here
+ parameter (here= 'sem_fill_tbpm')
+
+ include 'sem_data_structures.cmn'
+ include 'gen_data_structures.cmn'
+ include 'gen_constants.par'
+
+
+ integer*4 i,counter,plane
+
+ integer PLANE_TBPM
+ parameter (PLANE_TBPM=2)
+
+ real*4 cent_x, edge_x, cent_y, edge_y
+ real*4 cent_x_inv, edge_x_inv, cent_y_inv, edge_y_inv
+ real*4 cent,edge
+
+ logical inv
+
+ real*4 sem_coordinate
+ sem_coordinate(cent,edge)=-7.5*(1.+(edge-cent)/(edge+cent))+0.5
+
+*--------------------------------------------------------
+
+* decode TBPM hit array
+ do i = 1 , N_TBPM_TOT_HITS
+
+ plane = N_TBPM_ADDR1(i)
+ counter = N_TBPM_ADDR2(i)
+
+ if (plane .ne. PLANE_TBPM) then
+ write(6,*) ' !!!!! bad SEM plane ID=',plane,
+ > ' !!!! (should be=',PLANE_TBPM,') counter=',counter
+ pause
+ elseif (counter .gt. num_tbpm) then
+ write(6,*) ' !!!!! bad SEM counter ID=,counter,
+ > ' !!!! (should be<=',num_tbpm,')'
+ pause
+ else
+ N_TBPM_DATA(counter) = float(N_TBPM_RAW_DATA(i))
+ endif
+
+ enddo
+
+* subtract pedestals
+ do i = 1,NUM_TBPM
+ N_TBPM_DATA(i) = MAX((N_TBPM_DATA(i) - ndet_ped_tbpm(i)),0.)
+ enddo
+
+
+* This mapping is for SANE.
+ edge_x =n_tbpm_data(1)
+ edge_x_inv=n_tbpm_data(2)
+ cent_x =n_tbpm_data(3)
+ cent_x_inv=n_tbpm_data(4)
+
+ edge_y =n_tbpm_data(5)
+ edge_y_inv=n_tbpm_data(6)
+ cent_y =n_tbpm_data(7)
+ cent_y_inv=n_tbpm_data(8)
+
+* X coordinate.
+
+ if(cent_x+edge_x.gt.cent_x_inv+edge_x_inv) then
+ cent=cent_x
+ edge=edge_x
+ inv=.false.
+ else
+ cent=cent_x_inv
+ edge=edge_x_inv
+ inv=.true.
+ end if
+ if(edge+cent.lt.n_tbpm_cutoff.or.
+ , abs(edge-cent).eq.abs(edge+cent)) then
+ ntbpmx=-20.
+ elseif(edge+cent.gt.n_tbpm_adccut) then
+ ntbpmx= 20.
+ else
+ ntbpmx=sem_coordinate(cent,edge)
+ end if
+c write(2,*)edge_x,edge_x_inv,cent_x,cent_x_inv,edge_y,edge_y_inv,cent_y,cent_y_inv
+
+ if(inv) ntbpmx=-ntbpmx
+
+* Y coordinate
+
+ if(cent_y+edge_y.gt.cent_y_inv+edge_y_inv) then
+ cent=cent_y
+ edge=edge_y
+ inv=.false.
+ else
+ cent=cent_y_inv
+ edge=edge_y_inv
+ inv=.true.
+ end if
+
+
+ if(edge+cent.lt.n_tbpm_cutoff.or.
+ , abs(edge-cent).eq.abs(edge+cent)) then
+ ntbpmy=-20.
+ elseif(edge+cent.gt.n_tbpm_adccut) then
+ ntbpmy= 20.
+ else
+ ntbpmy=sem_coordinate(cent,edge)
+ end if
+
+ if(inv) ntbpmy=-ntbpmy
+
+ end
diff --git a/SEM/sem_register_variables.f b/SEM/sem_register_variables.f
new file mode 100644
index 0000000..271953f
--- /dev/null
+++ b/SEM/sem_register_variables.f
@@ -0,0 +1,38 @@
+ subroutine sem_register_variables(ABORT,err)
+ implicit none
+ save
+
+ character*20 here
+ parameter (here='sem_register_variables')
+
+ logical ABORT
+ character*(*) err
+
+ logical FAIL
+ character*1000 why
+
+ err= ' '
+ ABORT= .false.
+
+ call r_sem_data_structures
+
+
+*****************************************************************************
+*****************************************************************************
+
+
+ if(err.ne.' '.and.why.ne.' ') then
+ call G_append(err,' & '//why)
+ else if(why.ne.' ') then
+ err=why
+ endif
+ abort = abort.or.fail
+
+ if(abort.or.err.ne.' ') call G_add_path(here,err)
+
+ return
+ end
+
+*****************************************************************************
+*****************************************************************************
+
diff --git a/SEM/sem_reset_event.f b/SEM/sem_reset_event.f
new file mode 100644
index 0000000..1e8d78b
--- /dev/null
+++ b/SEM/sem_reset_event.f
@@ -0,0 +1,24 @@
+ subroutine SEM_RESET_EVENT(ABORT,err)
+ IMPLICIT NONE
+ SAVE
+ INCLUDE 'sem_data_structures.cmn'
+
+ character*13 here
+ parameter (here= 'sem_reset_event')
+
+ logical ABORT
+ character*(*) err
+ integer i
+* SEM hits
+
+ N_TBPM_TOT_HITS = 0
+ do i=1,N_TBPM_ALL_CHAN
+ n_tbpm_addr1(i) = 0
+ n_tbpm_addr2(i) = 0
+ N_TBPM_RAW_DATA(i) = 0
+ enddo
+
+
+ end
+
+**********************************************************
diff --git a/STRACKING/.cvsignore b/STRACKING/.cvsignore
new file mode 100644
index 0000000..0b6ddf9
--- /dev/null
+++ b/STRACKING/.cvsignore
@@ -0,0 +1,2 @@
+O.*
+r_*.f
diff --git a/STRACKING/CVS/Entries b/STRACKING/CVS/Entries
new file mode 100644
index 0000000..c4edd47
--- /dev/null
+++ b/STRACKING/CVS/Entries
@@ -0,0 +1,100 @@
+/.cvsignore/1.1/Thu Jul 8 18:10:46 2004//Tsane
+/Makefile/1.1/Tue Dec 8 15:45:53 1998//Tsane
+/Makefile.Unix/1.27.6.1/Mon Sep 10 20:08:02 2007//Tsane
+/s_aero.f/1.3/Thu Nov 7 19:48:28 1996//Tsane
+/s_analyze_pedestal.f/1.10/Thu Jun 10 16:55:48 1999//Tsane
+/s_cal.f/1.9/Thu Apr 3 00:45:01 2003//Tsane
+/s_cal_calib.f/1.2.20.1/Mon Sep 10 20:28:01 2007//Tsane
+/s_cal_eff.f/1.7/Wed Jul 31 20:20:57 2002//Tsane
+/s_cal_eff_shutdown.f/1.5/Tue Feb 23 18:55:22 1999//Tsane
+/s_calc_pedestal.f/1.13/Tue Feb 23 18:57:19 1999//Tsane
+/s_cer.f/1.2/Mon May 22 19:45:33 1995//Tsane
+/s_cer_eff.f/1.4/Wed Feb 10 18:20:29 1999//Tsane
+/s_cer_eff_shutdown.f/1.1/Thu Aug 31 15:04:56 1995//Tsane
+/s_chamnum.f/1.2/Mon May 22 19:45:33 1995//Tsane
+/s_choose_single_hit.f/1.3/Wed Jan 17 19:04:08 1996//Tsane
+/s_clusters_cal.f/1.4/Wed Feb 3 21:13:44 1999//Tsane
+/s_correct_cal.f/1.7/Thu Apr 3 00:45:01 2003//Tsane
+/s_correct_cal_neg.f/1.4/Thu Apr 3 00:45:01 2003//Tsane
+/s_correct_cal_pos.f/1.4/Fri Mar 21 22:58:02 2003//Tsane
+/s_correct_cal_two.f/1.2/Fri Mar 21 22:58:02 2003//Tsane
+/s_dc_eff.f/1.1/Thu Aug 31 15:07:28 1995//Tsane
+/s_dc_eff_shutdown.f/1.2/Thu Sep 5 13:29:49 1996//Tsane
+/s_dc_trk_eff.f/1.2/Wed Jan 17 17:09:36 1996//Tsane
+/s_dc_trk_eff_shutdown.f/1.1/Mon Oct 9 20:05:32 1995//Tsane
+/s_dpsifun.f/1.3/Mon May 22 19:45:35 1995//Tsane
+/s_drift_dist_calc.f/1.5/Tue Apr 30 17:01:21 1996//Tsane
+/s_drift_time_calc.f/1.5/Mon Oct 9 20:16:16 1995//Tsane
+/s_dump_cal.f/1.4/Thu Jun 10 16:56:30 1999//Tsane
+/s_dump_peds.f/1.6.24.1/Thu Sep 13 04:02:18 2007//Tsane
+/s_dump_tof.f/1.7/Thu Nov 4 20:36:47 1999//Tsane
+/s_fcnchisq.f/1.3/Mon May 22 19:45:37 1995//Tsane
+/s_fill_cal_hist.f/1.10/Thu Dec 19 22:05:45 2002//Tsane
+/s_fill_dc_dec_hist.f/1.6/Wed Jul 31 20:20:58 2002//Tsane
+/s_fill_dc_fp_hist.f/1.5/Wed Jul 31 20:20:58 2002//Tsane
+/s_fill_dc_target_hist.f/1.4/Wed Jul 31 20:20:58 2002//Tsane
+/s_fill_scin_raw_hist.f/1.7/Wed Jan 17 19:04:54 1996//Tsane
+/s_find_best_stub.f/1.5/Wed Jan 17 19:05:23 1996//Tsane
+/s_find_easy_space_point.f/1.1/Thu Oct 26 14:18:53 1995//Tsane
+/s_generate_geometry.f/1.7/Thu Sep 5 13:30:18 1996//Tsane
+/s_init_cal.f/1.3/Mon May 22 19:45:40 1995//Tsane
+/s_init_cer.f/1.1/Thu Aug 31 15:05:05 1995//Tsane
+/s_init_histid.f/1.7/Tue Feb 23 18:58:40 1999//Tsane
+/s_init_physics.f/1.6/Wed Feb 10 18:15:40 1999//Tsane
+/s_init_scin.f/1.6/Tue Apr 30 17:32:20 1996//Tsane
+/s_initialize_fitting.f/1.3/Thu Sep 5 20:09:06 1996//Tsane
+/s_left_right.f/1.12.24.1/Mon Sep 10 20:28:01 2007//Tsane
+/s_link_stubs.f/1.7/Thu Sep 5 19:55:23 1996//Tsane
+/s_lucite.f/1.1/Thu Nov 7 19:50:56 1996//Tsane
+/s_pattern_recognition.f/1.10/Thu Sep 5 20:09:36 1996//Tsane
+/s_physics.f/1.21/Fri Nov 28 14:57:30 2003//Tsane
+/s_physics_stat.f/1.5/Tue Oct 10 16:49:32 1995//Tsane
+/s_print_decoded_dc.f/1.4/Tue Oct 10 16:52:50 1995//Tsane
+/s_print_links.f/1.2/Mon May 22 19:45:45 1995//Tsane
+/s_print_pr.f/1.2/Mon May 22 19:45:45 1995//Tsane
+/s_print_raw_dc.f/1.2/Mon May 22 19:45:46 1995//Tsane
+/s_print_stubs.f/1.3/Mon May 22 19:45:46 1995//Tsane
+/s_print_tar_tracks.f/1.3/Mon May 22 19:45:46 1995//Tsane
+/s_print_tracks.f/1.3/Mon May 22 19:45:47 1995//Tsane
+/s_prt_cal_clusters.f/1.3/Fri Jan 29 17:34:58 1999//Tsane
+/s_prt_cal_decoded.f/1.2/Mon May 22 19:45:48 1995//Tsane
+/s_prt_cal_raw.f/1.4/Fri Jan 29 17:34:59 1999//Tsane
+/s_prt_cal_sparsified.f/1.3/Fri Jan 29 17:34:59 1999//Tsane
+/s_prt_cal_tests.f/1.2/Mon May 22 19:45:49 1995//Tsane
+/s_prt_cal_tracks.f/1.2/Mon May 22 19:45:49 1995//Tsane
+/s_prt_dec_scin.f/1.7/Wed Jan 17 19:00:09 1996//Tsane
+/s_prt_raw_scin.f/1.6/Fri Sep 5 19:58:29 2003//Tsane
+/s_prt_tof.f/1.3/Mon May 22 19:45:51 1995//Tsane
+/s_prt_track_tests.f/1.2/Mon May 22 19:45:52 1995//Tsane
+/s_psifun.f/1.2/Mon May 22 19:45:53 1995//Tsane
+/s_raw_dump_all.f/1.2/Mon May 22 19:45:53 1995//Tsane
+/s_reconstruction.f/1.13/Thu Nov 7 19:53:12 1996//Tsane
+/s_register_param.f/1.11/Thu Nov 7 19:53:37 1996//Tsane
+/s_report_bad_data.f/1.3/Thu Sep 5 20:14:25 1996//Tsane
+/s_satcorr.f/1.2/Fri Sep 5 20:00:03 2003//Tsane
+/s_scin_eff.f/1.8/Fri Sep 5 20:01:02 2003//Tsane
+/s_scin_eff_shutdown.f/1.9/Tue Feb 23 18:59:27 1999//Tsane
+/s_select_best_track.f/1.6/Wed Mar 23 16:34:09 2005//Tsane
+/s_select_best_track_prune.f/1.1/Wed Mar 23 16:34:08 2005//Tsane
+/s_select_best_track_using_scin.f/1.2/Wed Mar 23 16:18:14 2005//Tsane
+/s_solve_3by3.f/1.3/Tue Oct 10 17:36:30 1995//Tsane
+/s_sparsify_cal.f/1.13/Wed Jul 31 20:20:58 2002//Tsane
+/s_strip_scin.f/1.7/Tue Feb 23 19:00:39 1999//Tsane
+/s_targ_trans.f/1.15/Tue Feb 23 19:01:10 1999//Tsane
+/s_targ_trans_init.f/1.5.16.1/Mon Sep 10 20:28:01 2007//Tsane
+/s_tdc_time_per_channel.f/1.3/Mon May 22 19:45:57 1995//Tsane
+/s_tdc_zero.f/1.3/Mon May 22 19:45:58 1995//Tsane
+/s_tof.f/1.14.6.1/Mon Sep 10 20:28:01 2007//Tsane
+/s_tof_fit.f/1.6/Wed Sep 4 20:36:55 1996//Tsane
+/s_tof_init.f/1.5/Mon May 22 19:46:00 1995//Tsane
+/s_track.f/1.5/Wed Sep 4 20:19:45 1996//Tsane
+/s_track_fit.f/1.8/Wed Jan 17 18:56:08 1996//Tsane
+/s_track_tests.f/1.3/Thu Sep 26 14:54:03 2002//Tsane
+/s_tracks_cal.f/1.10.6.1/Mon Sep 10 20:28:01 2007//Tsane
+/s_trans_cal.f/1.8/Wed May 12 15:38:59 2004//Tsane
+/s_trans_cer.f/1.2/Wed Jan 17 18:45:10 1996//Tsane
+/s_trans_dc.f/1.13/Wed Jul 31 20:20:58 2002//Tsane
+/s_trans_misc.f/1.6/Wed Jan 27 16:02:45 1999//Tsane
+/s_trans_scin.f/1.14/Tue Mar 15 21:13:09 2005//Tsane
+/s_wire_center_calc.f/1.5/Wed Sep 4 20:17:35 1996//Tsane
+D
diff --git a/STRACKING/CVS/Repository b/STRACKING/CVS/Repository
new file mode 100644
index 0000000..8818f07
--- /dev/null
+++ b/STRACKING/CVS/Repository
@@ -0,0 +1 @@
+Analyzer/STRACKING
diff --git a/STRACKING/CVS/Root b/STRACKING/CVS/Root
new file mode 100644
index 0000000..6288c3f
--- /dev/null
+++ b/STRACKING/CVS/Root
@@ -0,0 +1 @@
+whit@cvs.jlab.org:/group/hallc/cvsroot
diff --git a/STRACKING/CVS/Tag b/STRACKING/CVS/Tag
new file mode 100644
index 0000000..25d73f7
--- /dev/null
+++ b/STRACKING/CVS/Tag
@@ -0,0 +1 @@
+Tsane
diff --git a/STRACKING/Makefile b/STRACKING/Makefile
new file mode 100644
index 0000000..09247cb
--- /dev/null
+++ b/STRACKING/Makefile
@@ -0,0 +1,8 @@
+#
+# $Log: Makefile,v $
+# Revision 1.1 1998/12/08 15:45:53 saw
+# Initial setup
+#
+ETC=../etc
+
+include $(ETC)/Makefile.NEW
diff --git a/STRACKING/Makefile.Unix b/STRACKING/Makefile.Unix
new file mode 100644
index 0000000..4f4ad97
--- /dev/null
+++ b/STRACKING/Makefile.Unix
@@ -0,0 +1,178 @@
+#
+# $Log: Makefile.Unix,v $
+# Revision 1.27.6.1 2007/09/10 20:08:02 pcarter
+# Implemented changes to allow compilation on RHEL 3,4,5 and MacOSX
+#
+# Revision 1.27 2005/03/23 16:34:08 jones
+# Add new code s_select_best_track_prune.f (P Bosted)
+#
+# Revision 1.26 2005/03/23 16:18:14 jones
+# Add new code s_select_best_track_using_scin.f . Copy of code used for HMS.
+#
+# Revision 1.25 2003/04/03 00:45:01 jones
+# Update to calorimeter calibration (V. Tadevosyan)
+#
+# Revision 1.24 1999/03/04 21:38:24 saw
+# Another typo
+#
+# Revision 1.23 1999/03/04 19:07:33 saw
+# Fix typo
+#
+# Revision 1.22 1999/02/23 18:53:46 csa
+# Add s_satcorr
+#
+# Revision 1.21 1999/01/29 17:34:56 saw
+# Add variables for second tubes on shower counter
+#
+# Revision 1.20 1999/01/21 21:41:48 saw
+# Clean up Include file rules
+#
+# Revision 1.19 1998/12/09 16:31:16 saw
+# Remove dependence on Csoft environment variable
+#
+# Revision 1.18 1998/12/07 22:11:29 saw
+# Initial setup
+#
+# Revision 1.17 1996/11/07 19:54:28 saw
+# (SAW) Add Lucite Cerenkov routines and AIX support
+#
+# Revision 1.16 1996/09/04 20:15:59 saw
+# (SAW) Add routines. Linux compatibility updates
+#
+# Revision 1.15 1996/04/29 18:29:40 saw
+# (SAW) New makefile style
+#
+# Revision 1.14 1996/01/17 17:00:27 cdaq
+# (SAW) Use $(CP) instead of cp. Add s_cer_eff, s_cer_eff_shutdown, s_init_cer,
+# s_trans_cer, s_dc_eff, s_dc_eff_shutdown, s_dump_peds, s_dump_cal,
+# s_report_bad_data, s_dc_trk_eff, s_dc_trk_eff_shutdown,
+# s_find_easy_space_point, r_sos_cer_parms.f
+#
+# Revision 1.13 1995/07/20 19:09:05 cdaq
+# (SAW) Add option to get source via softlink to read only source tree
+#
+# Revision 1.12 1995/05/24 13:23:13 cdaq
+# Add s_init_histid, r_sos_pedestals
+#
+# Revision 1.11 1995/05/11 21:18:16 cdaq
+# (SAW) Compile s_trans_misc.f and s_fill_cal_hist.f
+#
+# Revision 1.10 1995/04/06 20:07:09 cdaq
+# (SAW) Add pedestal routines
+#
+# Revision 1.9 1995/03/08 20:34:23 cdaq
+# (SAW) Add new routines, add -f to include file copy statements
+#
+# Revision 1.8 1995/01/27 20:49:07 cdaq
+# (SAW) Remove RCS from include file rules
+#
+# Revision 1.7 1994/11/23 15:36:04 cdaq
+# (SAW) Update list of sources to bring in line with HMS
+#
+# Revision 1.6 1994/08/18 04:23:42 cdaq
+# (SAW) Call makereg generated routines to register variables
+#
+# Revision 1.5 1994/07/07 15:17:56 cdaq
+# (SAW) Fix a bug so that all sources not get compiled
+#
+# Revision 1.4 1994/06/14 05:02:25 cdaq
+# (SAW) Add s_init_physics and s_physics_stat
+#
+# Revision 1.3 1994/06/07 18:50:41 cdaq
+# Add register_bypass and register_statistics routines
+#
+# Revision 1.2 1994/05/19 13:55:24 cdaq
+# Add new routines from DFG
+#
+# Revision 1.1 1994/04/15 20:28:07 cdaq
+# Initial revision
+#
+NEWSTYLE = 1
+include ../../etc/Makefile
+include ../../etc/Makefile.flags
+
+osources = s_cal.f s_cer.f s_chamnum.f s_dpsifun.f s_drift_dist_calc.f \
+ s_drift_time_calc.f s_fcnchisq.f s_find_best_stub.f \
+ s_generate_geometry.f s_initialize_fitting.f s_left_right.f \
+ s_link_stubs.f s_pattern_recognition.f s_physics.f s_print_links.f \
+ s_print_pr.f s_print_stubs.f s_print_tar_tracks.f s_print_tracks.f \
+ s_psifun.f s_register_param.f s_reconstruction.f s_targ_trans.f \
+ s_tdc_time_per_channel.f s_tdc_zero.f s_tof.f s_track.f s_track_fit.f \
+ s_trans_cal.f s_trans_dc.f s_trans_scin.f s_wire_center_calc.f \
+ s_print_decoded_dc.f s_print_raw_dc.f
+newstuff = s_clusters_cal.f s_correct_cal.f s_fill_dc_dec_hist.f \
+ s_fill_dc_fp_hist.f s_init_cal.f s_init_scin.f s_prt_cal_clusters.f \
+ s_prt_cal_decoded.f s_prt_cal_raw.f s_prt_cal_sparsified.f \
+ s_prt_cal_tests.f s_prt_cal_tracks.f s_prt_dec_scin.f \
+ s_prt_raw_scin.f s_prt_tof.f s_prt_track_tests.f s_raw_dump_all.f \
+ s_sparsify_cal.f s_tof.f s_tof_init.f s_tof_fit.f s_tracks_cal.f \
+ s_trans_cal.f s_trans_scin.f s_fill_scin_raw_hist.f
+newerstuff = s_fill_dc_target_hist.f s_targ_trans_init.f \
+ s_init_physics.f s_physics_stat.f \
+ s_strip_scin.f s_choose_single_hit.f s_solve_3by3.f \
+ s_dump_tof.f s_select_best_track.f s_select_best_track_using_scin.f \
+ s_scin_eff.f s_scin_eff_shutdown.f \
+ s_cal_eff.f s_cal_eff_shutdown.f s_analyze_pedestal.f \
+ s_calc_pedestal.f s_trans_misc.f s_fill_cal_hist.f s_init_histid.f \
+ s_cer_eff.f s_cer_eff_shutdown.f s_init_cer.f s_trans_cer.f \
+ s_dc_eff.f s_dc_eff_shutdown.f s_dump_peds.f s_dump_cal.f \
+ s_report_bad_data.f s_dc_trk_eff.f s_dc_trk_eff_shutdown.f \
+ s_find_easy_space_point.f s_aero.f s_track_tests.f s_lucite.f \
+ s_correct_cal_pos.f s_correct_cal_neg.f s_cal_calib.f \
+ s_satcorr.f s_select_best_track_prune.f
+makeregstuff = r_sos_filenames.f r_sos_tracking.f r_sos_geometry.f \
+ r_sos_track_histid.f r_sos_recon_elements.f r_sos_physics_sing.f \
+ r_sos_scin_parms.f r_sos_scin_tof.f r_sos_calorimeter.f \
+ r_sos_id_histid.f r_sos_bypass_switches.f r_sos_statistics.f \
+ r_sos_pedestals.f r_sos_cer_parms.f r_sos_aero_parms.f \
+ r_sos_lucite_parms.f
+
+sources = $(osources) $(newstuff) $(newerstuff) $(makeregstuff)
+
+ifeq ($(MYOS),AIX)
+xsources := $(filter-out s_link_stubs.f s_track_tests.f ,$(sources))
+sources = s_link_stubs_aix.f s_track_tests_aix.f $(xsources)
+../s_%_aix.f : ../s_%.f
+ sed -e "s/access=.append./position='append'/"< $< > $@
+endif
+
+libsources = $(sources)
+
+lib_targets := $(patsubst %.f, libstracking.a(%.o), $(libsources))
+
+install-dirs := lib
+bin_targets =
+
+#default:
+# @echo "nothing to make"
+
+
+ifdef NFSDIRECTORY
+../%.f : $(NFSDIRECTORY)/STRACKING/%.f
+ ln -s $< $@
+
+.PRECIOUS: ../%.f
+else
+#
+# Rule for making the register subroutines
+#
+../r_%.f : ../%.cmn $(MAKEREG)
+ (cd .. ; $(MAKEREG) $(<F) -o $(@F) -e /dev/null)
+
+.PRECIOUS: ../r_%.f
+endif
+
+#
+# Get include files from INCLUDE directory
+#
+
+%.cmn ../%.cmn:: ../../INCLUDE/%.cmn
+ $(CP) $< $@
+
+%.dec ../%.dec:: ../../INCLUDE/%.dec
+ $(CP) $< $@
+
+%.par ../%.par:: ../../INCLUDE/%.par
+ $(CP) $< $@
+
+include $(sources:.f=.d)
diff --git a/STRACKING/s_aero.f b/STRACKING/s_aero.f
new file mode 100644
index 0000000..daba4ff
--- /dev/null
+++ b/STRACKING/s_aero.f
@@ -0,0 +1,131 @@
+ SUBROUTINE S_AERO(ABORT,err)
+*--------------------------------------------------------
+*-
+*- Purpose and Methods : Analyze aerogel information for each track
+*-
+*- Required Input BANKS SOS_RAW_AER
+*-
+*- Output BANKS SOS_TRACK_TESTS
+*-
+*- Output: ABORT - success or failure
+*- : err - reason for failure, if any
+*-
+*- Created 13-MAY-1995 H. Breuer and R. Mohring, UMD
+*- SOS Aerogel detector calibration routine
+*-
+* $Log: s_aero.f,v $
+* Revision 1.3 1996/11/07 19:48:28 saw
+* (JRA) Handle over and underflows
+*
+* Revision 1.2 1996/09/05 13:13:14 saw
+* (JRA) ??
+*
+* Revision 1.1 1996/04/30 17:12:40 saw
+* Initial revision
+*
+*--------------------------------------------------------
+ IMPLICIT NONE
+ SAVE
+*
+ character*6 here
+ parameter (here= 'S_AERO')
+*
+ logical ABORT
+ character*(*) err
+*
+ integer*4 ind,npmt
+*
+ INCLUDE 'sos_data_structures.cmn'
+ INCLUDE 'sos_pedestals.cmn'
+ INCLUDE 'sos_aero_parms.cmn'
+ INCLUDE 'sos_scin_parms.cmn' ! For smisc_dec_data bank
+*
+*--------------------------------------------------------
+*
+ ABORT= .FALSE.
+ err= ' '
+
+ saer_neg_npe_sum = 0.0
+ saer_pos_npe_sum = 0.0
+ saer_tot_good_hits = 0
+
+ do ind = 1,smax_aer_hits
+ saer_pos_npe(ind)=0.0
+ saer_neg_npe(ind)=0.0
+ enddo
+
+ do ind = 1,saer_tot_hits
+* pedestal subtraction and gain adjustment
+* Note: rmm 28-aug-96
+* An ADC value of less than zero occurs when that particular
+* channel has been sparsified away and has not been read. The NPE
+* for that tube will be assigned zero by this code (the NPE
+* variables are initialized above.) An ADC value of greater than
+* 8000 (more specifically, 8192) occurs when the ADC overflows on
+* an input that is too large. Tubes with this characteristic will
+* be assigned NPE = 100.0.
+
+ npmt=saer_pair_num(ind)
+
+ if (saer_adc_pos(ind).gt.0) then
+ if (saer_adc_pos(ind).lt.8000) then
+ saer_pos_npe(npmt) =
+ & (saer_adc_pos(ind)-saer_pos_ped_mean(npmt))*saer_pos_gain(npmt)
+ else
+ saer_pos_npe(npmt) = 100.0
+ endif ! pos.lt.8000
+ endif ! gt.0
+
+ if (saer_adc_neg(ind).gt.0) then
+ if (saer_adc_neg(ind).lt.8000) then
+ saer_neg_npe(npmt) =
+ & (saer_adc_neg(ind)-saer_neg_ped_mean(npmt))*saer_neg_gain(npmt)
+ else
+ saer_neg_npe(npmt) = 100.0
+ endif ! neg.lt.8000
+ endif ! gt.0
+
+* sum positive and negative hits if above software threshold
+* also, fill saer_tot_good_hits for those events that have
+* more than 0.3 npe (mostly cuts out scintillation)
+
+ if (saer_neg_npe(npmt).ge.saer_neg_threshold(npmt)) then
+ saer_neg_npe_sum = saer_neg_npe_sum + saer_neg_npe(npmt)
+ if (saer_neg_npe(npmt).ge.0.3)
+ & saer_tot_good_hits = saer_tot_good_hits + 1
+ endif
+ if (saer_pos_npe(npmt).ge.saer_pos_threshold(npmt)) then
+ saer_pos_npe_sum = saer_pos_npe_sum + saer_pos_npe(npmt)
+ if (saer_pos_npe(npmt).ge.0.3)
+ & saer_tot_good_hits = saer_tot_good_hits + 1
+ endif
+ enddo
+
+ saer_npe_sum = saer_neg_npe_sum + saer_pos_npe_sum
+
+* If the total hits are 0, then make sure NPE=0
+ if (saer_tot_hits.lt.1) then
+ saer_npe_sum=0.
+ endif
+
+
+* Next, fill the rawadc variables with the actual tube values
+* mainly for diagnostic purposes.
+
+ do ind=1,7
+ saer_rawadc_neg(ind)=-100
+ saer_rawadc_pos(ind)=-100
+ enddo
+
+ do ind=1,saer_tot_hits
+ npmt=saer_pair_num(ind)
+ saer_rawadc_neg(npmt)=saer_adc_neg(ind)
+ saer_rawadc_pos(npmt)=saer_adc_pos(ind)
+ enddo
+
+*RMM added 28-aug-96 summing amp outputs:
+ saer_sumA = smisc_dec_data(17,2)
+ saer_sumB = smisc_dec_data(18,2)
+
+ return
+ end
diff --git a/STRACKING/s_analyze_pedestal.f b/STRACKING/s_analyze_pedestal.f
new file mode 100644
index 0000000..847c8de
--- /dev/null
+++ b/STRACKING/s_analyze_pedestal.f
@@ -0,0 +1,182 @@
+ subroutine s_analyze_pedestal(ABORT,err)
+*
+* $Log: s_analyze_pedestal.f,v $
+* Revision 1.10 1999/06/10 16:55:48 csa
+* (JRA) Removed two calorimeter debugging statements
+*
+* Revision 1.9 1999/02/23 18:54:33 csa
+* (JRA) Implement improved pedestal calcs
+*
+* Revision 1.8 1999/01/29 17:34:56 saw
+* Add variables for second tubes on shower counter
+*
+* Revision 1.7 1996/11/07 19:49:10 saw
+* (WH) Add pedestal analysis for lucite cerenkov
+*
+* Revision 1.6 1996/04/30 17:00:53 saw
+* (JRA) Change some aerogel variable names
+*
+* Revision 1.5 1995/10/09 20:07:55 cdaq
+* (JRA) Use scer_raw_adc instead of hcer_adc
+*
+* Revision 1.4 1995/07/20 14:45:42 cdaq
+* (???) Fix typo in Gas Cerenkov Pedestals section
+*
+* Revision 1.3 1995/05/22 19:45:30 cdaq
+* (SAW) Split gen_data_data_structures into gen, hms, sos, and coin parts"
+*
+* Revision 1.2 1995/05/17 16:41:08 cdaq
+* (JRA) Add Cernekov pedestals, cosmetic changes
+*
+* Revision 1.1 1995/04/01 19:35:31 cdaq
+* Initial revision
+*
+*
+ implicit none
+ save
+*
+ character*18 here
+ parameter (here='s_analyze_pedestal')
+*
+ logical ABORT
+ character*(*) err
+*
+ integer*4 ihit
+ integer*4 pln,cnt
+ integer*4 row,col
+ integer*4 blk
+ integer*4 pmt
+*
+ INCLUDE 'sos_data_structures.cmn'
+ INCLUDE 'sos_pedestals.cmn'
+*
+*
+* HODOSCOPE PEDESTALS
+*
+
+ do ihit = 1 , sscin_all_tot_hits
+ pln = sscin_all_plane_num(ihit)
+ cnt = sscin_all_counter_num(ihit)
+ if (sscin_all_adc_pos(ihit).le.shodo_pos_ped_limit(pln,cnt)) then
+ shodo_neg_ped_sum2(pln,cnt) = shodo_neg_ped_sum2(pln,cnt) +
+ & sscin_all_adc_neg(ihit)*sscin_all_adc_neg(ihit)
+ shodo_neg_ped_sum(pln,cnt) = shodo_neg_ped_sum(pln,cnt) +
+ & sscin_all_adc_neg(ihit)
+ shodo_neg_ped_num(pln,cnt) = shodo_neg_ped_num(pln,cnt) + 1
+ if (shodo_pos_ped_num(pln,cnt).eq.nint(shodo_min_peds/5.)) then
+ shodo_pos_ped_limit(pln,cnt) = 100 +
+ & shodo_pos_ped_sum(pln,cnt) / shodo_pos_ped_num(pln,cnt)
+ endif
+ endif
+ if (sscin_all_adc_neg(ihit).le.shodo_neg_ped_limit(pln,cnt)) then
+ shodo_pos_ped_sum2(pln,cnt) = shodo_pos_ped_sum2(pln,cnt) +
+ & sscin_all_adc_pos(ihit)*sscin_all_adc_pos(ihit)
+ shodo_pos_ped_sum(pln,cnt) = shodo_pos_ped_sum(pln,cnt) +
+ & sscin_all_adc_pos(ihit)
+ shodo_pos_ped_num(pln,cnt) = shodo_pos_ped_num(pln,cnt) + 1
+ if (shodo_neg_ped_num(pln,cnt).eq.nint(shodo_min_peds/5.)) then
+ shodo_neg_ped_limit(pln,cnt) = 100 +
+ & shodo_neg_ped_sum(pln,cnt) / shodo_neg_ped_num(pln,cnt)
+ endif
+ endif
+ enddo
+*
+* CALORIMETER PEDESTALS
+*
+ do ihit = 1 , scal_tot_hits
+ row = scal_row(ihit)
+ col = scal_column(ihit)
+ blk = row + (col-1)*smax_cal_rows
+
+ if (scal_adc_pos(ihit) .le. scal_pos_ped_limit(blk)) then
+ scal_pos_ped_sum2(blk) = scal_pos_ped_sum2(blk) +
+ $ scal_adc_pos(ihit)*scal_adc_pos(ihit)
+ scal_pos_ped_sum(blk) = scal_pos_ped_sum(blk) + scal_adc_pos(ihit)
+ scal_pos_ped_num(blk) = scal_pos_ped_num(blk) + 1
+ if (scal_pos_ped_num(blk).eq.nint(scal_min_peds/5.)) then
+ scal_pos_ped_limit(blk) = 100 +
+ & scal_pos_ped_sum(blk) / scal_pos_ped_num(blk)
+ endif
+ endif
+
+ if (scal_adc_neg(ihit) .le. scal_neg_ped_limit(blk)) then
+ scal_neg_ped_sum2(blk) = scal_neg_ped_sum2(blk) +
+ $ scal_adc_neg(ihit)*scal_adc_neg(ihit)
+ scal_neg_ped_sum(blk) = scal_neg_ped_sum(blk) + scal_adc_neg(ihit)
+ scal_neg_ped_num(blk) = scal_neg_ped_num(blk) + 1
+ if (scal_neg_ped_num(blk).eq.nint(scal_min_peds/5.)) then
+ scal_neg_ped_limit(blk) = 100 +
+ & scal_neg_ped_sum(blk) / scal_neg_ped_num(blk)
+ endif
+ endif
+ enddo
+*
+*
+* GAS CERENKOV PEDESTALS
+*
+ do ihit = 1 , scer_tot_hits
+ pmt=scer_tube_num(ihit) ! no sparsification yet - NEED TO FIX!!!!
+ if (scer_raw_adc(ihit) .le. scer_ped_limit(pmt)) then
+ scer_ped_sum2(pmt) = scer_ped_sum2(pmt) +
+ $ scer_raw_adc(ihit)*scer_raw_adc(ihit)
+ scer_ped_sum(pmt) = scer_ped_sum(pmt) + scer_raw_adc(ihit)
+ scer_ped_num(pmt) = scer_ped_num(pmt) + 1
+ if (scer_ped_num(pmt).eq.nint(scer_min_peds/5.)) then
+ scer_ped_limit(pmt) = 100 +
+ & scer_ped_sum(pmt) / scer_ped_num(pmt)
+ endif
+ endif
+ enddo
+*
+*
+* AEROGEL CERENKOV PEDESTALS
+*
+ do ihit = 1 , saer_tot_hits
+ blk = saer_pair_num(ihit)
+ if (saer_adc_pos(ihit) .le. saer_pos_ped_limit(blk)) then
+ saer_pos_ped_sum2(blk) = saer_pos_ped_sum2(blk) + saer_adc_pos(ihit)*saer_adc_pos(ihit)
+ saer_pos_ped_sum(blk) = saer_pos_ped_sum(blk) + saer_adc_pos(ihit)
+ saer_pos_ped_num(blk) = saer_pos_ped_num(blk) + 1
+ if (saer_pos_ped_num(blk).eq.nint(scer_min_peds/5.)) then
+ saer_pos_ped_limit(blk) = 100 +
+ & saer_pos_ped_sum(blk) / saer_pos_ped_num(blk)
+ endif
+ endif
+ if (saer_adc_neg(ihit) .le. saer_neg_ped_limit(blk)) then
+ saer_neg_ped_sum2(blk) = saer_neg_ped_sum2(blk) + saer_adc_neg(ihit)*saer_adc_neg(ihit)
+ saer_neg_ped_sum(blk) = saer_neg_ped_sum(blk) + saer_adc_neg(ihit)
+ saer_neg_ped_num(blk) = saer_neg_ped_num(blk) + 1
+ if (saer_neg_ped_num(blk).eq.nint(scer_min_peds/5.)) then
+ saer_neg_ped_limit(blk) = 100 +
+ & saer_neg_ped_sum(blk) / saer_neg_ped_num(blk)
+ endif
+ endif
+ enddo
+*
+*
+* LUCITE CERENKOV PEDESTALS
+*
+ do ihit = 1 , sluc_tot_hits
+ blk = sluc_pair_num(ihit)
+ if (sluc_adc_pos(ihit) .le. sluc_pos_ped_sum(blk)) then
+ sluc_pos_ped_sum2(blk) = sluc_pos_ped_sum2(blk) + sluc_adc_pos(ihit)*sluc_adc_pos(ihit)
+ sluc_pos_ped_sum(blk) = sluc_pos_ped_sum(blk) + sluc_adc_pos(ihit)
+ sluc_pos_ped_num(blk) = sluc_pos_ped_num(blk) + 1
+ if (sluc_pos_ped_num(blk).eq.nint(scer_min_peds/5.)) then
+ sluc_pos_ped_limit(blk) = 100 +
+ & sluc_pos_ped_sum(blk) / sluc_pos_ped_num(blk)
+ endif
+ endif
+ if (sluc_adc_neg(ihit) .le. sluc_neg_ped_sum(blk)) then
+ sluc_neg_ped_sum2(blk) = sluc_neg_ped_sum2(blk) + sluc_adc_neg(ihit)*sluc_adc_neg(ihit)
+ sluc_neg_ped_sum(blk) = sluc_neg_ped_sum(blk) + sluc_adc_neg(ihit)
+ sluc_neg_ped_num(blk) = sluc_neg_ped_num(blk) + 1
+ if (sluc_neg_ped_num(blk).eq.nint(scer_min_peds/5.)) then
+ sluc_neg_ped_limit(blk) = 100 +
+ & sluc_neg_ped_sum(blk) / sluc_neg_ped_num(blk)
+ endif
+ endif
+ enddo
+
+ return
+ end
diff --git a/STRACKING/s_cal.f b/STRACKING/s_cal.f
new file mode 100644
index 0000000..fcea0c4
--- /dev/null
+++ b/STRACKING/s_cal.f
@@ -0,0 +1,157 @@
+ SUBROUTINE S_CAL(ABORT,err)
+*--------------------------------------------------------
+*-
+*- Purpose and Methods : Analyze Calorimeter information for each track
+*-
+*- Required Input BANKS SOS_RAW_CAL
+*- SOS_DECODED_CAL
+*- SOS_FOCAL_PLANE
+*-
+*- Output BANKS SOS_TRACK_TESTS
+*-
+*- Output: ABORT - success or failure
+*- : err - reason for failure, if any
+*-
+*- Created 19-JAN-1994 D. F. Geesaman
+*- Dummy Shell routine
+* $Log: s_cal.f,v $
+* Revision 1.9 2003/04/03 00:45:01 jones
+* Update to calorimeter calibration (V. Tadevosyan)
+*
+* Revision 1.8 1999/06/10 16:56:02 csa
+* (JRA) Cosmetic changes
+*
+* Revision 1.7 1999/02/25 20:18:40 saw
+* Vardan Tadevosyan shower code updates
+*
+* Revision 1.6 1999/02/03 21:13:44 saw
+* Code for new Shower counter tubes
+*
+* Revision 1.5 1999/01/29 17:34:56 saw
+* Add variables for second tubes on shower counter
+*
+* Revision 1.4 1995/05/22 19:45:31 cdaq
+* (SAW) Split gen_data_data_structures into gen, hms, sos, and coin parts"
+*
+* Revision 1.3 1995/05/11 21:02:26 cdaq
+* (JRA) Add call to s_tracks_cal
+*
+* Revision 1.2 1994/11/22 21:05:51 cdaq
+* (SPB) Recopied from hms file and modified names for SOS
+*
+* Revision 1.1 1994/02/21 16:06:52 cdaq
+* Initial revision
+*-
+*--------------------------------------------------------
+ IMPLICIT NONE
+ SAVE
+
+ logical ABORT
+ character*(*) err
+
+ character*5 here
+ parameter (here= 'S_CAL')
+
+ integer*4 nt !Detector track number
+ integer*4 nc !Calorimeter cluster number
+ real*4 cor !Correction factor for X,Y dependence ! Single PMT.
+ real*4 cor_pos !Correction factor for X,Y dependence ! Pos
+ real*4 cor_neg !Correction factor for X,Y dependence ! Neg
+ real*4 s_correct_cal !External function to compute "cor"
+ real*4 s_correct_cal_pos !External function to compute "cor_pos"
+ real*4 s_correct_cal_neg !External function to compute "cor_neg"
+
+ include 'sos_data_structures.cmn'
+ include 'sos_calorimeter.cmn'
+ include 'gen_run_info.cmn' !To get run number.
+*
+*--------------------------------------------------------
+*
+ do nt=1, sntracks_fp
+ strack_e1_pos(nt)=0. ! Only pos_pmt for layer "A"
+ strack_e1_neg(nt)=0. ! Only_neg_pmt for layer "A"
+ strack_e2_pos(nt)=0. ! Only_pos_pmt for layer "B"
+ strack_e2_neg(nt)=0. ! Only_neg_pmt for layer "B"
+ strack_e1(nt)=0.
+ strack_e2(nt)=0.
+ strack_e3(nt)=0.
+ strack_e4(nt)=0.
+ strack_et(nt)=0.
+ strack_preshower_e(nt)=0.
+ enddo
+
+ call s_clusters_cal(abort,err)
+ if(abort) then
+ call g_add_path(here,err)
+ return
+ endif
+
+ call s_tracks_cal(abort,err)
+ if (abort) then
+ call g_add_path(here,err)
+ return
+ endif
+*
+* Return if there are no tracks found or none of the found tracks
+* matches a cluster in the calorimeter
+*
+ if(sntracks_fp .le.0) go to 100 !Return
+ if(sntracks_cal.le.0) go to 100 !Return
+
+ do nt =1,sntracks_fp
+
+ nc=scluster_track(nt)
+
+ if(nc.gt.0) then
+
+ cor =s_correct_cal(strack_xc(nt),strack_yc(nt)) ! Single PMT
+ cor_pos=s_correct_cal_pos(strack_xc(nt),strack_yc(nt)) ! Single pos PMT
+ cor_neg=s_correct_cal_neg(strack_xc(nt),strack_yc(nt)) ! Single neg PMT
+
+c... Correction factors for old runs, with single PMT modules only.
+
+ if(gen_run_number.lt.22000) then
+ cor_pos=cor
+ cor_neg=0.
+ end if
+c...
+ snblocks_cal(nt)=scluster_size(nc)
+*
+ if(scal_num_neg_columns.ge.1) then
+ strack_e1_pos(nt)=cor_pos*scluster_e1_pos(nc) ! For "A" layer "POS_PMT"
+ strack_e1_neg(nt)=cor_neg*scluster_e1_neg(nc) ! For "A" layer "NEG_PMT"
+ strack_e1(nt)=strack_e1_pos(nt)+strack_e1_neg(nt) ! For "A" layer "POS"+"NEG_PMT"
+ else
+ strack_e1(nt)=cor_pos*scluster_e1(nc) ! IF ONLY "POS_PMT" in layer "A"
+ endif
+
+ if(scal_num_neg_columns.ge.2) then
+ strack_e2_pos(nt)=cor_pos*scluster_e2_pos(nc) ! For "B" layer "POS_PMT"
+ strack_e2_neg(nt)=cor_neg*scluster_e2_neg(nc) ! For "B" layer "NEG_PMT"
+ strack_e2(nt)=strack_e2_pos(nt)+strack_e2_neg(nt) ! For "B" layer "POS"+"NEG_PMT"
+ else
+ strack_e2(nt)=cor_pos*scluster_e2(nc) ! IF ONLY "POS_PMT" in layer "B"
+ endif
+
+ if(scal_num_neg_columns.ge.3) then
+ print *,"Extra tubes on more than two layers not supported"
+ endif
+
+ strack_e3(nt)=cor*scluster_e3(nc)
+ strack_e4(nt)=cor*scluster_e4(nc)
+
+ strack_et(nt)=strack_e1(nt)+strack_e2(nt)+ strack_e3(nt)
+ & +strack_e4(nt)
+
+ strack_preshower_e(nt)=strack_e1(nt)
+
+ endif !End ... if nc > 0
+
+ enddo !End loop over detetor tracks
+
+ 100 continue
+ if(sdbg_tests_cal.gt.0) call s_prt_cal_tests
+
+ return
+ end
+
diff --git a/STRACKING/s_cal_calib.f b/STRACKING/s_cal_calib.f
new file mode 100644
index 0000000..799d5b1
--- /dev/null
+++ b/STRACKING/s_cal_calib.f
@@ -0,0 +1,628 @@
+*=======================================================================
+ subroutine s_cal_calib(mode)
+*=======================================================================
+
+c SOS calorimeter calibration with electrons.
+c
+c Input paramater mode = 0 means collect data for calibration,
+c otherwise calibrate.
+
+*
+ implicit none
+*
+ integer mode
+
+ include 'sos_data_structures.cmn'
+ include 'sos_calorimeter.cmn'
+ include 'sos_tracking.cmn'
+ include 'gen_run_info.cmn'
+ include 'gen_event_info.cmn'
+*
+ integer ihit
+ integer nblk
+ real adc_pos,adc_neg
+
+ integer nct_hit_blk(66),ipmt !sos
+ logical write_out
+c
+ common/scal_calib/nct_hit_blk,ncall,spare_id
+ integer ncall
+ data ncall/0/
+
+ real thr_lo,thr_hi !thresholds on sammed raw calorimeter signal.
+c
+ integer spare_id
+ logical ABORT
+ character*80 err
+c
+ ncall=ncall+1
+
+ if (ncall .eq. 1) then
+ call g_IO_control(spare_id,'ANY',ABORT,err) !get IO channel
+ open(spare_id,file='s_cal_calib.raw_data')
+ do ipmt=1,66
+ nct_hit_blk(ipmt)=0
+ enddo
+ endif
+
+ if(mode.eq.0) then !collect data.
+
+c Choose clean single electron tracks within SOS momentum acceptance.
+ if( (sntracks_fp.eq.1).and.
+ & (snclusters_cal.eq.1).and.
+ & (sntracks_cal.eq.1).and.
+ & (scer_npe_sum.gt.4).and.
+ & (abs(sdelta_tar(1)).lt.20.).and.
+ & (abs(sbeta(1)-1.).lt.0.1).and.
+ & spare_id .ne. 0 ) then
+*** & (sbeta_chisq(1).ge.0.).and.(sbeta_chisq(1).lt.1.) ) then
+
+c
+ write_out = .false.
+ do ihit=1,scal_num_hits
+ nblk=(scal_cols(ihit)-1)*smax_cal_rows+scal_rows(ihit)
+ nct_hit_blk(nblk) = nct_hit_blk(nblk) + 1
+ if (nct_hit_blk(nblk) .lt. 4000) write_out = .true.
+ enddo
+c
+ if (write_out) then
+c
+ write(spare_id,'(i2,1x,f7.4,2(1x,f5.1,1x,f9.6))')
+ & scal_num_hits,sp_tar(1),
+ & strack_xc(1),sxp_fp(1),strack_yc(1),syp_fp(1)
+
+ do ihit=1,scal_num_hits
+
+ if(scal_cols(ihit).le.scal_num_neg_columns) then
+ adc_neg=scal_adcs_neg(ihit)
+ else
+ adc_neg=0.
+ end if
+ adc_pos=scal_adcs_pos(ihit)
+ nblk=(scal_cols(ihit)-1)*smax_cal_rows+scal_rows(ihit)
+
+ write(spare_id,'(2(f9.3,1x),i2)'),
+ & adc_pos,adc_neg,nblk
+
+ end do
+
+ endif ! if write_out
+c
+ end if !electron in acceptance
+
+ else !mode<>0, calibrate.
+
+ close(spare_id)
+
+ print*,'=========================================================='
+ print*,'Calibrating SOS Calorimeter at event #',gen_event_id_number
+
+ call scal_raw_thr(spare_id,thr_lo,thr_hi)
+ print*,'lo & hi thresholds:', thr_lo,thr_hi
+ call scal_clb_det(spare_id,gen_run_number,thr_lo,thr_hi)
+
+ print*,'=========================================================='
+
+ end if !mode=0
+
+ end
+*=======================================================================
+ subroutine scal_raw_thr(lun,thr_lo,thr_hi)
+
+ implicit none
+ integer lun
+ real thr_lo,thr_hi
+
+c Get thresholds around electron peak in summed raw calorimeter signal.
+
+ integer*4 num_negs
+ parameter (num_negs=22) !sos
+ integer*4 nhit
+ real*4 adc_pos,adc_neg
+ integer*4 nh
+ integer*4 nb
+ real*8 eb
+c
+ integer*4 nrow
+ parameter (nrow=11) !sos
+ real*4 zbl
+ parameter (zbl=10.)
+ real*4 x,xp,y,yp
+ real*4 xh,yh
+ integer*4 nc
+ real*4 sig,avr,t
+ real*4 qdc
+ integer nev
+
+ real s_correct_cal_neg, s_correct_cal_pos, s_correct_cal
+
+*
+* Get thresholds on total_signal/p_tar.
+*
+ open(lun,file='s_cal_calib.raw_data',err=989)
+ avr=0.
+ sig=0.
+ nev=0
+ do while(.true.)
+ read(lun,*,end=3) nhit,eb,x,xp,y,yp
+ qdc=0.
+ do nh=1,nhit
+ read(lun,*,end=3) adc_pos,adc_neg,nb
+ nc=(nb-1)/nrow+1
+ xh=x+xp*(nc-0.5)*zbl
+ yh=y+yp*(nc-0.5)*zbl
+ if(nb.le.num_negs) then
+ qdc=qdc+adc_pos*s_correct_cal_pos(xh,yh)*0.5
+ qdc=qdc+adc_neg*s_correct_cal_neg(xh,yh)*0.5
+ else
+ qdc=qdc+adc_pos*s_correct_cal(xh,yh)
+ end if
+ enddo
+ eb=eb*1000.
+ t=qdc/eb
+c write(lun,*) t
+c write(lun,*) t,nhit,eb,x,xp,y,yp,nev
+ avr=avr+t
+ sig=sig+t*t
+ nev=nev+1
+c print*,eb,qdc,nev
+ end do
+
+ 3 close(lun)
+c print*,avr,sig,nev
+ avr=avr/nev
+ sig=sqrt(sig/nev-avr*avr)
+ thr_lo=avr-3.*sig
+ thr_hi=avr+3.*sig
+c write(*,*) 'thr_lo=',thr_lo,' thr_hi=',thr_hi
+
+ return
+
+ 989 write(*,*) ' error opening file s_cal_calib.raw_data, channel',lun,
+ * ' in scal_raw_thr.f'
+c
+ end
+*=======================================================================
+ subroutine scal_clb_det(lun,nrun,thr_lo,thr_hi)
+ implicit none
+c
+ include 'sos_data_structures.cmn'
+ include 'sos_calorimeter.cmn'
+c
+ integer lun,nrun
+ real thr_lo,thr_hi
+
+ integer npmts
+ parameter (npmts=66) !sos
+ integer npmts2
+ parameter (npmts2=npmts*npmts)
+ integer nrow
+ parameter (nrow=11) !sos
+ real*8 q0(npmts)
+ real*8 qm(npmts,npmts)
+ real*8 qe(npmts)
+ real*8 q(npmts)
+ real*8 eb
+ real*8 e0
+ real*8 ac(npmts)
+ real*8 au(npmts)
+c real*8 t
+ real*8 s
+ integer nev
+ logical*1 eod
+ integer i,j
+ integer nf(npmts)
+ integer minf
+ parameter (minf=200) ! minimum number to hit pmt before including pmt in calib
+ integer nums(npmts)
+ integer numsel
+ real*8 q0s(npmts)
+ real*8 qes(npmts)
+ integer nsi,nsj
+ real*8 acs(npmts)
+ real*8 aus(npmts)
+ real*8 aux(npmts2)
+ integer jp
+ integer spare_id
+ logical ABORT
+ character*80 err
+ character*40 fn
+
+ real xh,yh
+
+ open(lun,file='s_cal_calib.raw_data')
+
+ do i=1,npmts
+ q0(i)=0.
+ qe(i)=0.
+ do j=1,npmts
+ qm(i,j)=0.
+ end do
+ au(i)=0.
+ ac(i)=0.
+ nf(i)=0
+ end do
+ e0=0.
+c
+ nev=0
+ eod=.false.
+ do while(.not.eod)
+ call s_get_data(lun,eb,q,xh,yh,eod,thr_lo,thr_hi)
+ if(.not.eod) then
+ do i=1,npmts
+ if(q(i).gt.0.) then
+ q0(i)=q0(i)+q(i)
+ qe(i)=qe(i)+eb*q(i)
+ do j=1,npmts
+ qm(i,j)=qm(i,j)+q(i)*q(j)
+ end do
+ nf(i)=nf(i)+1
+ end if
+ end do
+ e0=e0+eb
+ nev=nev+1
+c if(nev/1000*1000.eq.nev) write(*,'(e10.3,i7)') e0,nev
+ end if
+ end do
+ close(lun)
+
+ do i=1,npmts
+ q0(i)=q0(i)/nev
+ qe(i)=qe(i)/nev
+ do j=1,npmts
+ qm(i,j)=qm(i,j)/nev
+ end do
+ end do
+ e0=e0/nev
+
+ numsel=0
+ do i=1,npmts
+ if(nf(i).ge.minf) then
+ numsel=numsel+1
+ nums(numsel)=i
+c print*,nums(numsel),numsel,nf(i)
+ else
+ write(*,*) ' PMT ',i,' only ',nf(i),' events. Will not to be calibrated. Gain is set to 0.'
+ end if
+ end do
+c print*,'numsel =',numsel
+ write(*,'(''Number of events for each PMT for calib for run '',i7,'', '',
+ 1 i6,'' events processed'')') nrun,nev
+ write(*,*) ' PMT with less than', minf,' events are not included in calibration.'
+ write(*,*)
+ write(*,11) 'scal_pos_gain_cor=',(nf(i),i= 1, nrow)
+ write(*,11) ' ',(nf(i),i= nrow+1,2*nrow)
+ write(*,11) ' ',(nf(i),i=2*nrow+1,3*nrow)
+ write(*,11) ' ',(nf(i),i=3*nrow+1,4*nrow)
+ write(*,11) 'scal_neg_gain_cor=',(nf(i),i=4*nrow+1,5*nrow)
+ write(*,11) ' ',(nf(i),i=5*nrow+1,6*nrow)
+ write(*,11) ' ',(0., i=6*nrow+1,7*nrow)
+ write(*,11) ' ',(0., i=7*nrow+1,8*nrow)
+c
+ do i=1,numsel
+ nsi=nums(i)
+ q0s(i)=q0(nsi)
+ qes(i)=qe(nsi)
+ do j=1,numsel
+ nsj=nums(j)
+ jp=j+(i-1)*numsel
+ aux(jp)=qm(nsj,nsi)
+c write(65,'(e12.5)') aux(jp)
+ end do
+ end do
+
+ call calib(e0,q0s,qes,aux,numsel,numsel*numsel,aus,acs)
+
+ do i=1,numsel
+ nsi=nums(i)
+ au(nsi)=aus(i)
+ ac(nsi)=acs(i)
+ end do
+
+c write(*,'(2e10.3,i5)') (ac(i),au(i),i,i=1,npmts)
+
+ write(fn,'(a17,i5.5)') 'PARAM/scal.param.',nrun
+ call g_IO_control(spare_id,'ANY',ABORT,err) !get IO channel
+ open(spare_id,file=fn)
+
+ write(spare_id,'(''; Calibration constants for run '',i7,'', '',
+ 1 i6,'' events processed'')') nrun,nev
+ write(spare_id,*)
+
+ write(spare_id,10) 'scal_pos_gain_cor=',(ac(i)*1.D+3,i= 1, nrow)
+ write(spare_id,10) ' ',(ac(i)*1.D+3,i= nrow+1,2*nrow)
+ write(spare_id,10) ' ',(ac(i)*1.D+3,i=2*nrow+1,3*nrow)
+ write(spare_id,10) ' ',(ac(i)*1.D+3,i=3*nrow+1,4*nrow)
+ write(spare_id,10) 'scal_neg_gain_cor=',(ac(i)*1.D+3,i=4*nrow+1,5*nrow)
+ write(spare_id,10) ' ',(ac(i)*1.D+3,i=5*nrow+1,6*nrow)
+ write(spare_id,10) ' ',(0., i=6*nrow+1,7*nrow)
+ write(spare_id,10) ' ',(0., i=7*nrow+1,8*nrow)
+* write(spare_id,10) 'scal_pos_gain_cor=',(ac(i)*2.D+3,i= 1, nrow)
+* write(spare_id,10) ' ',(ac(i)*2.D+3,i= nrow+1,2*nrow)
+* write(spare_id,10) ' ',(ac(i)*1.D+3,i=2*nrow+1,3*nrow)
+* write(spare_id,10) ' ',(ac(i)*1.D+3,i=3*nrow+1,4*nrow)
+* write(spare_id,10) 'scal_neg_gain_cor=',(ac(i)*2.D+3,i=4*nrow+1,5*nrow)
+* write(spare_id,10) ' ',(ac(i)*2.D+3,i=5*nrow+1,6*nrow)
+* write(spare_id,10) ' ',(0., i=6*nrow+1,7*nrow)
+* write(spare_id,10) ' ',(0., i=7*nrow+1,8*nrow)
+
+ close(spare_id)
+ call G_IO_control(spare_ID,'FREE',ABORT,err) !free up IO channel
+
+ write(*,*)
+ write(*,'(''Calibration constants for run '',i7,'', '',
+ 1 i6,'' events processed'')') nrun,nev
+ write(*,*)
+ write(*,*) ' constants written to ',fn
+ write(*,*)
+ write(*,10) 'scal_pos_gain_cor=',(ac(i)*1.D+3,i= 1, nrow)
+ write(*,10) ' ',(ac(i)*1.D+3,i= nrow+1,2*nrow)
+ write(*,10) ' ',(ac(i)*1.D+3,i=2*nrow+1,3*nrow)
+ write(*,10) ' ',(ac(i)*1.D+3,i=3*nrow+1,4*nrow)
+ write(*,10) 'scal_neg_gain_cor=',(ac(i)*1.D+3,i=4*nrow+1,5*nrow)
+ write(*,10) ' ',(ac(i)*1.D+3,i=5*nrow+1,6*nrow)
+ write(*,10) ' ',(0., i=6*nrow+1,7*nrow)
+ write(*,10) ' ',(0., i=7*nrow+1,8*nrow)
+* write(*,10) 'scal_pos_gain_cor=',(ac(i)*2.D+3,i= 1, nrow)
+* write(*,10) ' ',(ac(i)*2.D+3,i= nrow+1,2*nrow)
+* write(*,10) ' ',(ac(i)*1.D+3,i=2*nrow+1,3*nrow)
+* write(*,10) ' ',(ac(i)*1.D+3,i=3*nrow+1,4*nrow)
+* write(*,10) 'scal_neg_gain_cor=',(ac(i)*2.D+3,i=4*nrow+1,5*nrow)
+* write(*,10) ' ',(ac(i)*2.D+3,i=5*nrow+1,6*nrow)
+* write(*,10) ' ',(0., i=6*nrow+1,7*nrow)
+* write(*,10) ' ',(0., i=7*nrow+1,8*nrow)
+
+ 10 format(a18,13(f6.3,','))
+ 11 format(a18,13(i5,','))
+
+ open(lun,file='s_cal_calib.raw_data')
+ call g_IO_control(spare_id,'ANY',ABORT,err) !get IO channel
+ open(spare_id,file='s_cal_calib.cal_data')
+ write(*,*) 'In sos shower cal creating file s_cal_calib.cal_data, ',
+ * 'channel ',spare_id
+
+ nev=0
+ eod=.false.
+ do while(.not.eod)
+ call s_get_data(lun,eb,q,xh,yh,eod,0.,1.E+8)
+ if(.not.eod) then
+ s=0.
+* t=0.
+ do i=1,npmts
+ s=s+q(i)*ac(i)
+* t=t+q(i)*au(i)
+ end do
+ write(spare_id,*) s,eb,xh,yh
+ end if
+ end do
+
+ close(lun)
+ close(spare_id)
+ call G_IO_control(spare_ID,'FREE',ABORT,err) !free up IO channel
+
+ end
+*=======================================================================
+c
+c... Done already in h_cal_calib.f.
+c
+c subroutine calib(e0,q0,qe,aux,npmts,npmts2,au,ac)
+c implicit none
+c integer npmts,npmts2
+c real*8 e0
+c real*8 q0(npmts)
+c real*8 qe(npmts)
+c real*8 aux(npmts2)
+c real*8 ac(npmts)
+c real*8 au(npmts)
+c real*8 qm(npmts,npmts)
+c real*8 t
+c real*8 s
+c integer ifail
+c integer i,j
+c integer jp
+c
+c do i=1,npmts
+c do j=1,npmts
+c jp=j+(i-1)*npmts
+c qm(j,i)=aux(jp)
+cD write(66,'(e12.5)') qm(j,i)
+c end do
+c end do
+c
+c print*,'Calib: npmts =',npmts
+c print*,' '
+c
+c print*,'Inversing the Matrix...'
+c call smxinv(qm,npmts,ifail)
+c if(ifail.ne.0) then
+c stop '*** Singular Matrix ***'
+c else
+c print*,' ...done.'
+c end if
+c
+c do i=1,npmts
+c au(i)=0.
+c do j=1,npmts
+c au(i)=au(i)+qm(i,j)*qe(j)
+c end do
+c end do
+c
+c s=0.
+c do i=1,npmts
+c t=0.
+c do j=1,npmts
+c t=t+qm(i,j)*q0(j)
+c end do
+c s=s+q0(i)*t
+c end do
+c
+c t=0.
+c do i=1,npmts
+c t=t+au(i)*q0(i)
+c end do
+c s=(e0-t)/s
+c
+c do i=1,npmts
+c t=0.
+c do j=1,npmts
+c t=t+qm(i,j)*q0(j)
+c end do
+c ac(i)=s*t+au(i)
+c end do
+c
+c end
+*-----------------------------------------------------------------------
+ subroutine s_get_data(lun,eb,q,xh,yh,eod,thr_lo,thr_hi)
+ implicit none
+c
+ integer lun
+ real*8 eb
+ integer*4 num_blocks,num_negs,num_pmts
+ parameter (num_blocks=44,num_negs=22,num_pmts=66) !sos.
+ real*8 q(num_pmts)
+ logical*1 eod
+
+ integer*4 nhit
+ real*4 adc_pos,adc_neg
+ integer*4 nh
+ integer*4 nb
+c
+ integer*4 nrow
+ parameter (nrow=11) !sos
+ real*4 zbl
+ parameter (zbl=10.)
+ real*4 x,xp,y,yp
+ real*4 xh,yh
+ integer*4 nc
+ real*4 s_correct_cal
+ real*4 s_correct_cal_pos,s_correct_cal_neg
+ real*4 thr_lo,thr_hi
+ logical*1 good_ev
+ real*4 qnet
+
+ good_ev=.false.
+ do while(.not.good_ev)
+
+ eb=0.d0
+ do nb=1,num_pmts
+ q(nb)=0.d0
+ end do
+ qnet=0.
+ eod=.true.
+
+ read(lun,*,end=5) nhit,eb,x,xp,y,yp
+ do nh=1,nhit
+ read(lun,*,end=5) adc_pos,adc_neg,nb
+ nc=(nb-1)/nrow+1
+ xh=x+xp*(nc-0.5)*zbl
+ yh=y+yp*(nc-0.5)*zbl
+ if(nb.le.num_negs) then
+ q(nb)=adc_pos*s_correct_cal_pos(xh,yh)
+ q(num_blocks+nb)=adc_neg*s_correct_cal_neg(xh,yh)
+ qnet=qnet+0.5*(q(nb)+q(num_blocks+nb))
+ else
+ q(nb)=adc_pos*s_correct_cal(xh,yh)
+ qnet=qnet+q(nb)
+ end if
+ enddo
+ eod=.false.
+
+ qnet=qnet/(eb*1000.)
+ good_ev=(qnet.gt.thr_lo).and.(qnet.lt.thr_hi)
+
+c write(99,*) qnet
+
+ end do !.not.good_ev
+
+ 5 continue
+
+ end
+*-----------------------------------------------------------------------
+c
+c... Done already in h_cal_calib.f.
+c
+c SUBROUTINE SMXINV (A,NDIM,IFAIL)
+C
+C CERN PROGLIB# F107 SMXINV .VERSION KERNFOR 1.0 720503
+C ORIG. 03/05/72 CL
+C
+c REAL*8 A(*),RI(100)
+c INTEGER*4 INDEX(100)
+C
+c DATA TOL / 1.D-14/
+C
+c IFAIL=0
+c N=NDIM
+c NP1=N+1
+c DO 10 I=1,N
+c 10 INDEX(I)=1
+C
+c DO 80 I=1,N
+C
+C-- FIND PIVOT
+c PIVOT=0.0D0
+c JJ=1
+c DO 20 J=1,N
+c IF (INDEX(J).EQ.0) GO TO 19
+c ELM=DABS (A(JJ))
+c IF (ELM.LE.PIVOT) GO TO 19
+c PIVOT=ELM
+c K=J
+c KK=JJ
+c 19 JJ=JJ+NP1
+c 20 CONTINUE
+c IF (PIVOT/DABS(A(1)).LT.TOL) GO TO 100
+c INDEX(K)=0
+c PIVOT=-A(KK)
+C
+C-- ELIMINATION
+c KJ=K
+c NP=N
+C
+c DO 70 J=1,N
+c IF (J-K) 34,30,34
+C
+c 30 A(KJ)=1.0D0/PIVOT
+c RI(J)=0.0D0
+c NP=1
+c GO TO 70
+C
+c 34 ELM=-A(KJ)
+c 40 RI(J)=ELM/PIVOT
+c IF (ELM.EQ.0.0D0) GO TO 50
+C
+c JL=J
+c DO 45 L=1,J
+c A(JL)=A(JL)+ELM*RI(L)
+c 45 JL=JL+N
+C
+c 50 A(KJ)=RI(J)
+C
+c 70 KJ=KJ+NP
+C
+c 80 CONTINUE
+C
+C-- CHANGE THE SIGN AND PROVISIONAL FILL-UP
+c IJ0=1
+c JI0=1
+c DO 95 I=1,N
+c IJ=IJ0
+c JI=JI0
+C
+c DO 90 J=1,I
+c A(IJ)=-A(IJ)
+c A(JI)=A(IJ)
+c IJ=IJ+N
+c JI=JI+1
+c 90 CONTINUE
+C
+c IJ0=IJ0+1
+c JI0=JI0+N
+c 95 CONTINUE
+c RETURN
+C
+C-- FAILURE RETURN
+c 100 IFAIL=1
+c RETURN
+c END
+*=======================================================================
diff --git a/STRACKING/s_cal_eff.f b/STRACKING/s_cal_eff.f
new file mode 100644
index 0000000..98a4d57
--- /dev/null
+++ b/STRACKING/s_cal_eff.f
@@ -0,0 +1,129 @@
+ SUBROUTINE S_CAL_EFF(ABORT,errmsg)
+*--------------------------------------------------------
+*-
+*- Purpose and Methods : Analyze calorimeter statistics for each track
+*-
+*- Required Input BANKS SOS_CALORIMETER
+*- GEN_DATA_STRUCTURES
+*-
+*- Output: ABORT - success or failure
+*- : err - reason for failure, if any
+*-
+* author: John Arrington
+* created: 2/17/95
+*
+* s_cal_eff calculates efficiencies for the hodoscope.
+*
+* $Log: s_cal_eff.f,v $
+* Revision 1.7 2002/07/31 20:20:57 saw
+* Only try to fill user hists that are defined
+*
+* Revision 1.6 1999/01/29 17:34:56 saw
+* Add variables for second tubes on shower counter
+*
+* Revision 1.5 1996/09/04 20:17:05 saw
+* (JRA) Require more than one photoelectron
+*
+* Revision 1.4 1995/08/31 15:06:45 cdaq
+* (JRA) Fill dpos (pos. track - pos. hit) histograms
+*
+* Revision 1.3 1995/05/22 19:45:31 cdaq
+* (SAW) Split gen_data_data_structures into gen, hms, sos, and coin parts"
+*
+* Revision 1.2 1995/04/01 20:39:32 cdaq
+* (SAW) Fix typos
+*
+* Revision 1.1 1995/02/23 15:42:27 cdaq
+* Initial revision
+*
+*--------------------------------------------------------
+ IMPLICIT NONE
+*
+ character*9 here
+ parameter (here= 'S_CAL_EFF')
+*
+ logical ABORT
+ character*(*) errmsg
+*
+ INCLUDE 'sos_data_structures.cmn'
+ INCLUDE 'gen_constants.par'
+ INCLUDE 'gen_units.par'
+ include 'sos_calorimeter.cmn'
+ include 'sos_statistics.cmn'
+ include 'sos_id_histid.cmn'
+
+ integer col,row,blk
+ integer hit_row(smax_cal_columns)
+ integer nhit
+ real adc_pos, adc_neg
+ real hit_pos(smax_cal_columns),hit_dist(smax_cal_columns)
+ real histval
+ save
+
+* find counters on track, and distance from center.
+
+ if (sschi2perdeg.le.sstat_cal_maxchisq .and. scer_npe_sum.ge.1.)
+ & sstat_cal_numevents=sstat_cal_numevents+1
+
+ hit_pos(1)=ssx_fp + ssxp_fp*(scal_1pr_zpos+0.5*scal_1pr_thick)
+ hit_row(1)=nint((hit_pos(1)-scal_block_xc(1))
+ & /scal_block_xsize)+1
+ hit_row(1)=max(min(hit_row(1),smax_cal_rows),1)
+ hit_dist(1)=hit_pos(1)-(scal_block_xsize*(hit_row(1)-1)
+ & +scal_block_xc(1))
+
+ hit_pos(2)=ssx_fp + ssxp_fp*(scal_2ta_zpos+0.5*scal_2ta_thick)
+ hit_row(2)=nint((hit_pos(2)-scal_block_xc(smax_cal_rows+1))
+ & /scal_block_xsize)+1
+ hit_row(2)=max(min(hit_row(2),smax_cal_rows),1)
+ hit_dist(2)=hit_pos(2)-(scal_block_xsize*(hit_row(2)-1)
+ & +scal_block_xc(smax_cal_rows+1))
+
+ hit_pos(3)=ssx_fp + ssxp_fp*(scal_3ta_zpos+0.5*scal_3ta_thick)
+ hit_row(3)=nint((hit_pos(3)-scal_block_xc(2*smax_cal_rows+1))
+ & /scal_block_xsize)+1
+ hit_row(3)=max(min(hit_row(3),smax_cal_rows),1)
+ hit_dist(3)=hit_pos(3)-(scal_block_xsize*(hit_row(3)-1)
+ & +scal_block_xc(2*smax_cal_rows+1))
+
+ hit_pos(4)=ssx_fp + ssxp_fp*(scal_4ta_zpos+0.5*scal_4ta_thick)
+ hit_row(4)=nint((hit_pos(4)-scal_block_xc(3*smax_cal_rows+1))
+ & /scal_block_xsize)+1
+ hit_row(4)=max(min(hit_row(4),smax_cal_rows),1)
+ hit_dist(4)=hit_pos(3)-(scal_block_xsize*(hit_row(4)-1)
+ & +scal_block_xc(3*smax_cal_rows+1))
+
+* increment 'should have hit' counters
+ do col=1,smax_cal_columns
+ if(abs(hit_dist(col)).le.sstat_cal_slop .and. !hit in middle of blk.
+ & sschi2perdeg.le.sstat_cal_maxchisq .and. scer_npe_sum.ge.1.) then
+ sstat_cal_trk(col,hit_row(col))=sstat_cal_trk(col,hit_row(col))+1
+ endif
+ enddo
+
+ do nhit=1,scal_num_hits
+ row=scal_rows(nhit)
+ col=scal_cols(nhit)
+* We don't actually do anything with the following values?
+ adc_pos=scal_adcs_pos(nhit)
+ adc_neg=scal_adcs_neg(nhit)
+ blk=row+smax_cal_rows*(col-1)
+
+* fill the dpos histograms.
+ if (col .eq. 1) then
+ histval=(scal_block_xc(1)+scal_block_xsize*(row-1))-hit_pos(1)
+ if (sidcaldpos.gt.0)
+ $ call hf1(sidcaldpos,histval,1.)
+ endif
+
+* Record the hits if track is near center of block and the chisquared of the
+* track is good
+ if(abs(hit_dist(col)).le.sstat_cal_slop .and. row.eq.hit_row(col)) then
+ if (sschi2perdeg.le.sstat_cal_maxchisq .and. scer_npe_sum.ge.1.) then
+ sstat_cal_hit(col,hit_row(col))=sstat_cal_hit(col,hit_row(col))+1
+ endif !was it a good track.
+ endif !if hit was on track.
+ enddo
+
+ return
+ end
diff --git a/STRACKING/s_cal_eff_shutdown.f b/STRACKING/s_cal_eff_shutdown.f
new file mode 100644
index 0000000..4e9b3b9
--- /dev/null
+++ b/STRACKING/s_cal_eff_shutdown.f
@@ -0,0 +1,78 @@
+ SUBROUTINE S_CAL_EFF_SHUTDOWN(ABORT,errmsg)
+*--------------------------------------------------------
+*-
+*- Purpose and Methods : Summary of calorimeter efficiencies.
+*-
+*- Required Input BANKS SOS_CALORIMETER
+*- GEN_DATA_STRUCTURES
+*-
+*- Output: ABORT - success or failure
+*- : err - reason for failure, if any
+*-
+* author: John Arrington
+* created: 2/17/95
+*
+* s_cal_eff calculates efficiencies for the calorimeter.
+* s_cal_eff_shutdown does some final manipulation of the numbers.
+*
+* $Log: s_cal_eff_shutdown.f,v $
+* Revision 1.5 1999/02/23 18:55:22 csa
+* (JRA) Remove sdebugcalcpeds stuff
+*
+* Revision 1.4 1995/10/09 20:09:10 cdaq
+* (JRA) Add bypass switch around writing of pedestal data
+*
+* Revision 1.3 1995/08/31 18:04:19 cdaq
+* (JRA) Calculate and printout pedestals
+*
+* Revision 1.2 1995/05/22 19:45:32 cdaq
+* (SAW) Split gen_data_data_structures into gen, hms, sos, and coin parts"
+*
+* Revision 1.1 1995/02/23 15:42:42 cdaq
+* Initial revision
+*
+*--------------------------------------------------------
+ IMPLICIT NONE
+*
+ character*18 here
+ parameter (here= 'S_CAL_EFF_SHUTDOWN')
+*
+ logical ABORT
+ character*(*) errmsg
+*
+ INCLUDE 'sos_data_structures.cmn'
+ INCLUDE 'gen_constants.par'
+ INCLUDE 'gen_units.par'
+ include 'sos_calorimeter.cmn'
+ include 'sos_statistics.cmn'
+ include 'sos_tracking.cmn'
+
+ integer col,row,blk
+ real ave,ave2,num
+ save
+
+! fill sums over counters
+ do col=1,smax_cal_columns
+ sstat_cal_trksum(col)=0
+ sstat_cal_hitsum(col)=0
+ do row=1,smax_cal_rows
+ sstat_cal_eff(col,row)=sstat_cal_hit(col,row)
+ $ /max(.01,float(sstat_cal_trk(col,row)))
+ sstat_cal_trksum(col)=sstat_cal_trksum(col)+sstat_cal_trk(col,row)
+ sstat_cal_hitsum(col)=sstat_cal_hitsum(col)+sstat_cal_hit(col,row)
+ enddo
+ sstat_cal_effsum(col)=sstat_cal_hitsum(col)
+ $ /max(.01,float(sstat_cal_trksum(col)))
+ enddo
+
+ do blk=1,smax_cal_blocks
+ num=float(max(1,scal_zero_num(blk)))
+ ave=float(scal_zero_sum(blk))/num
+ ave2=float(scal_zero_sum2(blk))/num
+ scal_zero_ave(blk)=ave
+ scal_zero_sig(blk)=sqrt(max(0.,ave2-ave*ave))
+ scal_zero_thresh(blk)=min(50.,max(20.,3*scal_zero_sig(blk)))
+ enddo
+
+ return
+ end
diff --git a/STRACKING/s_calc_pedestal.f b/STRACKING/s_calc_pedestal.f
new file mode 100644
index 0000000..17d3236
--- /dev/null
+++ b/STRACKING/s_calc_pedestal.f
@@ -0,0 +1,359 @@
+ subroutine s_calc_pedestal(ABORT,err)
+*
+* $Log: s_calc_pedestal.f,v $
+* Revision 1.13 1999/02/23 18:57:19 csa
+* (JRA) Sparsify aerogel/lucite channels, cleanup
+*
+* Revision 1.12 1999/02/03 21:13:44 saw
+* Code for new Shower counter tubes
+*
+* Revision 1.11 1999/01/29 17:34:57 saw
+* Add variables for second tubes on shower counter
+*
+* Revision 1.10 1996/11/07 19:49:46 saw
+* (WH) Add calculations for Lucite Cerenkov
+*
+* Revision 1.9 1996/09/05 13:15:15 saw
+* (JRA) Slight increase in threshold above pedestal
+*
+* Revision 1.8 1996/01/24 16:06:55 saw
+* (JRA) Adjust which channels are disabled on Areogel
+*
+* Revision 1.7 1996/01/17 19:03:49 cdaq
+* (JRA) Fixes, write results to file.
+*
+* Revision 1.6 1995/10/09 20:12:30 cdaq
+* (JRA) Note pedestals that differ by 2 sigma from parameter file
+*
+* Revision 1.5 1995/08/31 18:04:55 cdaq
+* (JRA) Change threshold limits
+*
+* Revision 1.4 1995/07/20 14:46:39 cdaq
+* (JRA) Cleanup statistics calculations
+*
+* Revision 1.3 1995/05/22 19:45:32 cdaq
+* (SAW) Split gen_data_data_structures into gen, hms, sos, and coin parts"
+*
+* Revision 1.2 1995/05/17 16:42:40 cdaq
+* (JRA) Add gas cerenkov and Aerogel, float integer accumulators before arithmetic
+*
+* Revision 1.1 1995/04/01 19:36:03 cdaq
+* Initial revision
+*
+*
+ implicit none
+ save
+*
+ character*18 here
+ parameter (here='s_calc_pedestal')
+*
+ logical ABORT
+ character*(*) err
+*
+ integer*4 pln,cnt
+ integer*4 blk
+ integer*4 pmt
+ integer*4 ind
+ integer*4 roc,slot
+ integer*4 signalcount
+ real*4 sig2
+ real*4 num
+ character*80 file
+*
+ INCLUDE 'sos_data_structures.cmn'
+ INCLUDE 'sos_pedestals.cmn'
+ INCLUDE 'sos_scin_parms.cmn'
+ INCLUDE 'sos_calorimeter.cmn'
+ INCLUDE 'sos_cer_parms.cmn'
+ INCLUDE 'sos_filenames.cmn'
+ INCLUDE 'gen_run_info.cmn'
+*
+ integer SPAREID
+ parameter (SPAREID=67)
+*
+*
+* HODOSCOPE PEDESTALS
+*
+ ind = 0
+ do pln = 1 , snum_scin_planes
+ do cnt = 1 , snum_scin_counters(pln)
+
+*calculate new pedestal values, positive tubes first.
+ num=max(1.,float(shodo_pos_ped_num(pln,cnt)))
+ shodo_new_ped_pos(pln,cnt) = float(shodo_pos_ped_sum(pln,cnt)) / num
+ sig2 = float(shodo_pos_ped_sum2(pln,cnt))/num -
+ $ shodo_new_ped_pos(pln,cnt)**2
+ shodo_new_sig_pos(pln,cnt) = sqrt(max(0.,sig2))
+ shodo_new_threshold_pos(pln,cnt) = shodo_new_ped_pos(pln,cnt)+15.
+
+*note channels with 2 sigma difference from paramter file values.
+ if (abs(sscin_all_ped_pos(pln,cnt)-shodo_new_ped_pos(pln,cnt))
+ & .ge.(2.*shodo_new_sig_pos(pln,cnt))) then
+ ind = ind + 1 !final value of 'ind' is saved at end of loop
+ shodo_changed_plane(ind)=pln
+ shodo_changed_element(ind)=cnt
+ shodo_changed_sign(ind)= 1 !1=pos,2=neg.
+ shodo_ped_change(ind) = shodo_new_ped_pos(pln,cnt) -
+ & sscin_all_ped_pos(pln,cnt)
+ endif !large pedestal change
+
+*replace old peds (from param file) with calculated pedestals
+ if (num.gt.shodo_min_peds .and. shodo_min_peds.ne.0) then
+ sscin_all_ped_pos(pln,cnt)=shodo_new_ped_pos(pln,cnt)
+ endif
+
+*do it all again for negative tubes.
+ num=max(1.,float(shodo_neg_ped_num(pln,cnt)))
+ shodo_new_ped_neg(pln,cnt) = float(shodo_neg_ped_sum(pln,cnt)) / num
+ sig2 = float(shodo_neg_ped_sum2(pln,cnt))/num -
+ $ shodo_new_ped_neg(pln,cnt)**2
+ shodo_new_sig_neg(pln,cnt) = sqrt(max(0.,sig2))
+ shodo_new_threshold_neg(pln,cnt) = shodo_new_ped_neg(pln,cnt)+15.
+
+ if (abs(sscin_all_ped_neg(pln,cnt)-shodo_new_ped_neg(pln,cnt))
+ & .ge.(2.*shodo_new_sig_neg(pln,cnt))) then
+ ind = ind + 1
+ shodo_changed_plane(ind)=pln
+ shodo_changed_element(ind)=cnt
+ shodo_changed_sign(ind)= 2 !1=pos, 2=neg.
+ shodo_ped_change(ind) = shodo_new_ped_neg(pln,cnt) -
+ & sscin_all_ped_neg(pln,cnt)
+ endif !large pedestal change
+
+ if (num.gt.shodo_min_peds .and. shodo_min_peds.ne.0) then
+ sscin_all_ped_neg(pln,cnt)=shodo_new_ped_neg(pln,cnt)
+ endif
+
+ enddo !counters
+ enddo !planes
+ shodo_num_ped_changes = ind
+*
+*
+* CALORIMETER PEDESTALS
+*
+ ind = 0
+ do blk = 1 , smax_cal_blocks
+
+* calculate new pedestal values, positive tubes first.
+ num=max(1.,float(scal_pos_ped_num(blk)))
+ scal_new_ped_pos(blk)=scal_pos_ped_sum(blk)/num
+ sig2 = float(scal_pos_ped_sum2(blk))/num - scal_new_ped_pos(blk)**2
+ scal_new_rms_pos(blk)=sqrt(max(0.,sig2))
+ scal_new_adc_threshold_pos(blk)=scal_new_ped_pos(blk)+15.
+ if (abs(scal_pos_ped_mean(blk)-scal_new_ped_pos(blk))
+ & .ge.(2.*scal_new_rms_pos(blk))) then
+ ind = ind + 1
+ scal_changed_block(ind)=blk
+ scal_changed_sign(ind)=1 ! 1=pos,2=neg.
+ scal_ped_change(ind)=scal_new_ped_pos(blk)-
+ & scal_pos_ped_mean(blk)
+ endif
+
+
+ if (num.gt.scal_min_peds .and. scal_min_peds.ne.0) then
+ scal_pos_ped_mean(blk)=scal_new_ped_pos(blk)
+ scal_pos_ped_rms(blk)=scal_new_rms_pos(blk)
+ scal_pos_threshold(blk)=min(50.,max(10.,3.*scal_new_rms_pos(blk)))
+ endif
+
+*do it all again for negative tubes.
+ num=max(1.,float(scal_neg_ped_num(blk)))
+ scal_new_ped_neg(blk)=scal_neg_ped_sum(blk)/num
+ sig2 = float(scal_neg_ped_sum2(blk))/num-scal_new_ped_neg(blk)**2
+ scal_new_rms_neg(blk)=sqrt(max(0.,sig2))
+ scal_new_adc_threshold_neg(blk)=scal_new_ped_neg(blk)+15.
+ if (abs(scal_neg_ped_mean(blk)-scal_new_ped_neg(blk))
+ & .ge.(2.*scal_new_rms_neg(blk))) then
+ ind = ind + 1
+ scal_changed_block(ind)=blk
+ scal_changed_sign(ind)=2 ! 1=pos,2=neg.
+ scal_ped_change(ind)=scal_new_ped_neg(blk)-
+ & scal_neg_ped_mean(blk)
+ endif
+
+c type *,num,scal_min_peds
+ if (num.gt.scal_min_peds .and. scal_min_peds.ne.0) then
+ scal_neg_ped_mean(blk)=scal_new_ped_neg(blk)
+ scal_neg_ped_rms(blk)=scal_new_rms_neg(blk)
+ scal_neg_threshold(blk)=min(50.,max(10.,3.*scal_new_rms_neg(blk)))
+ endif
+
+ enddo
+ scal_num_ped_changes = ind
+
+*
+* GAS CERENKOV PEDESTALS
+*
+ ind = 0
+ do pmt = 1 , smax_cer_hits
+ num=max(1.,float(scer_ped_num(pmt)))
+ scer_new_ped(pmt) = float(scer_ped_sum(pmt)) / num
+ sig2 = float(scer_ped_sum2(pmt))/ num - scer_new_ped(pmt)**2
+ scer_new_rms(pmt) = sqrt(max(0.,sig2))
+ scer_new_adc_threshold(pmt) = scer_new_ped(pmt)+15.
+ if (abs(scer_ped(pmt)-scer_new_ped(pmt))
+ & .ge.(2.*scer_new_rms(pmt))) then
+ ind = ind + 1
+ scer_changed_tube(ind)=pmt
+ scer_ped_change(ind)=scer_new_ped(pmt)-scer_ped(pmt)
+ endif
+
+ if (num.gt.scer_min_peds .and. scer_min_peds.ne.0) then
+ scer_ped(pmt)=scer_new_ped(pmt)
+ endif
+
+ enddo
+ scer_num_ped_changes = ind
+*
+*
+* AEROGEL CERENKOV PEDESTALS
+*
+ do pmt = 1 , (smax_aer_hits-1)
+ if (saer_pos_ped_num(pmt) .ge. saer_min_peds .and.
+ & saer_min_peds .ne. 0) then
+ saer_pos_ped_mean(pmt) = saer_pos_ped_sum(pmt) /
+ & float(saer_pos_ped_num(pmt))
+ sig2 = float(saer_pos_ped_sum2(pmt))/
+ & float(saer_pos_ped_num(pmt))-
+ & saer_pos_ped_mean(pmt)**2
+ saer_pos_ped_rms(pmt) = sqrt(max(0.,sig2))
+ endif
+ if (saer_neg_ped_num(pmt) .ge. saer_min_peds .and.
+ & saer_min_peds .ne. 0) then
+ saer_neg_ped_mean(pmt) = saer_neg_ped_sum(pmt) /
+ & float(saer_neg_ped_num(pmt))
+ sig2 = float(saer_neg_ped_sum2(pmt))/
+ & float(saer_neg_ped_num(pmt))-
+ & saer_neg_ped_mean(pmt)**2
+ saer_neg_ped_rms(pmt) = sqrt(max(0.,sig2))
+
+ saer_neg_adc_threshold(pmt) = saer_neg_ped_mean(pmt)+15.
+ saer_pos_adc_threshold(pmt) = saer_pos_ped_mean(pmt)+15.
+
+ endif
+ enddo
+
+** LUCITE CERENKOV PEDESTALS
+*
+ do pmt = 1 , (smax_luc_hits-1)
+ if (sluc_pos_ped_num(pmt) .ge. sluc_min_peds .and.
+ & sluc_min_peds .ne. 0) then
+ sluc_pos_ped_mean(pmt) = sluc_pos_ped_sum(pmt) /
+ & float(sluc_pos_ped_num(pmt))
+ sig2 = float(sluc_pos_ped_sum2(pmt))/
+ & float(sluc_pos_ped_num(pmt))-
+ & sluc_pos_ped_mean(pmt)**2
+ sluc_pos_ped_rms(pmt) = sqrt(max(0.,sig2))
+ endif
+ if (sluc_neg_ped_num(pmt) .ge. sluc_min_peds .and.
+ & sluc_min_peds .ne. 0) then
+ sluc_neg_ped_mean(pmt) = sluc_neg_ped_sum(pmt) /
+ & float(sluc_neg_ped_num(pmt))
+ sig2 = float(sluc_neg_ped_sum2(pmt))/
+ & float(sluc_neg_ped_num(pmt))-
+ & sluc_neg_ped_mean(pmt)**2
+ sluc_neg_ped_rms(pmt) = sqrt(max(0.,sig2))
+
+ sluc_neg_adc_threshold(pmt) = sluc_neg_ped_mean(pmt)
+ sluc_pos_adc_threshold(pmt) = sluc_pos_ped_mean(pmt)
+
+ endif
+ enddo
+
+
+*
+* WRITE THRESHOLDS TO FILE FOR HARDWARE SPARCIFICATION
+*
+ if (s_threshold_output_filename.ne.' ') then
+ file=s_threshold_output_filename
+ call g_sub_run_number(file, gen_run_number)
+
+ open(unit=SPAREID,file=file,status='unknown')
+
+ write(SPAREID,*) '# This is the ADC threshold file generated automatically'
+ write(SPAREID,*) 'from the pedestal data from run number ',gen_run_number
+
+ roc=3
+
+ slot=1
+ signalcount=1
+ write(SPAREID,*) 'slot=',slot
+ call g_output_thresholds(SPAREID,roc,slot,signalcount,smax_cal_rows,
+ & scal_new_adc_threshold_pos,scal_new_adc_threshold_neg,
+ & scal_new_rms_pos,scal_new_rms_neg)
+
+c Want aero as well. For now, don't sparsify at all.
+c slot=3
+c signalcount=1
+c write(SPAREID,*) 'slot=',slot
+c call g_output_thresholds(SPAREID,roc,slot,signalcount,smax_cer_hits,
+c & scer_new_adc_threshold,0,scer_new_rms,0)
+c
+
+*
+* JRA - 2/18/99 - sparsify all aerogel/lucite channels for early '99
+* running.
+*
+ slot=3
+ write(SPAREID,*) 'slot=',slot
+ do ind=1,4
+ write(SPAREID,*) int(scer_new_adc_threshold(ind))
+ enddo
+ do ind=5,64
+ write(SPAREID,'(a6)') ' 4000'
+ enddo
+
+c slot=3
+c write(SPAREID,*) 'slot=',slot
+c do ind=1,4
+c write(SPAREID,'(i6)') int(scer_new_adc_threshold(ind))
+c enddo
+c do ind=5,15
+c write(SPAREID,'(a6)') '4000'
+c enddo
+c* Lucite
+c do pmt=1,8
+c write(SPAREID,'(i6)') sluc_pos_adc_threshold(pmt)
+c write(SPAREID,'(i6)') sluc_neg_adc_threshold(pmt)
+c enddo
+c
+c do ind=32,34
+c write(SPAREID,'(a6)') '4000'
+c enddo
+c do pmt=1,7
+c write(SPAREID,'(i6)') saer_pos_adc_threshold(pmt)
+c enddo
+c do pmt=1,7
+c write(SPAREID,'(i6)') saer_neg_adc_threshold(pmt)
+c enddo
+c do ind=49,64
+c write(SPAREID,'(a6)') '4000'
+c enddo
+
+ slot=5
+ signalcount=2
+ write(SPAREID,*) 'slot=',slot
+ call g_output_thresholds(SPAREID,roc,slot,signalcount,smax_cal_rows,
+ & scal_new_adc_threshold_pos,scal_new_adc_threshold_neg,
+ & scal_new_rms_pos,scal_new_rms_neg)
+
+ slot=7
+ signalcount=2
+ write(SPAREID,*) 'slot=',slot
+ call g_output_thresholds(SPAREID,roc,slot,signalcount,snum_scin_planes,
+ & shodo_new_threshold_pos,shodo_new_threshold_neg,shodo_new_sig_pos,
+ & shodo_new_sig_neg)
+
+ slot=9
+ signalcount=2
+ write(SPAREID,*) 'slot=',slot
+ call g_output_thresholds(SPAREID,roc,slot,signalcount,snum_scin_planes,
+ & shodo_new_threshold_pos,shodo_new_threshold_neg,shodo_new_sig_pos,
+ & shodo_new_sig_neg)
+
+ close (unit=SPAREID)
+
+ endif
+
+ return
+ end
diff --git a/STRACKING/s_cer.f b/STRACKING/s_cer.f
new file mode 100644
index 0000000..462e112
--- /dev/null
+++ b/STRACKING/s_cer.f
@@ -0,0 +1,44 @@
+ SUBROUTINE S_CER(ABORT,err)
+*--------------------------------------------------------
+*-
+*- Purpose and Methods : Analyze Cerenkov information for each track
+*-
+*- Required Input BANKS SOS_RAW_CER
+*- SOS_FOCAL_PLANE
+*-
+*- Output BANKS SOS_TRACK_TESTS
+*-
+*- Output: ABORT - success or failure
+*- : err - reason for failure, if any
+*-
+*- Created 19-JAN-1994 D. F. Geesaman
+*- Dummy Shell routine
+* $Log: s_cer.f,v $
+* Revision 1.2 1995/05/22 19:45:33 cdaq
+* (SAW) Split gen_data_data_structures into gen, hms, sos, and coin parts"
+*
+* Revision 1.1 1994/02/21 16:07:11 cdaq
+* Initial revision
+*
+*-
+*-
+*--------------------------------------------------------
+ IMPLICIT NONE
+ SAVE
+*
+ character*50 here
+ parameter (here= 'S_CER')
+*
+ logical ABORT
+ character*(*) err
+*
+ INCLUDE 'sos_data_structures.cmn'
+ INCLUDE 'gen_constants.par'
+ INCLUDE 'gen_units.par'
+*
+*--------------------------------------------------------
+*
+ ABORT= .FALSE.
+ err= ':dummy routine!'
+ RETURN
+ END
diff --git a/STRACKING/s_cer_eff.f b/STRACKING/s_cer_eff.f
new file mode 100644
index 0000000..b9b758d
--- /dev/null
+++ b/STRACKING/s_cer_eff.f
@@ -0,0 +1,81 @@
+ SUBROUTINE S_CER_EFF(ABORT,errmsg)
+
+*--------------------------------------------------------
+*
+* Purpose and Methods : Analyze cerenkov information for the "best
+* track" as selected in s_select_best_track
+* Required Input BANKS: sos_cer_parms
+* SOS_DATA_STRUCTURES
+*
+* Output: ABORT - success or failure
+* : err - reason for failure, if any
+*
+*
+* author: Chris Cothran
+* created: 5/25/95
+* $Log: s_cer_eff.f,v $
+* Revision 1.4 1999/02/10 18:20:29 csa
+* Changed sscer_et test to use momentum-normalized variable
+*
+* Revision 1.3 1999/02/03 21:13:44 saw
+* Code for new Shower counter tubes
+*
+* Revision 1.2 1995/10/09 20:14:50 cdaq
+* (JRA) Move calculation of hit position on mirror to s_physics
+*
+* Revision 1.1 1995/08/31 15:04:48 cdaq
+* Initial revision
+*
+*--------------------------------------------------------
+
+ IMPLICIT NONE
+*
+ character*9 here
+ parameter (here= 'S_CER_EFF')
+*
+ logical ABORT
+ character*(*) errmsg
+*
+ include 'sos_data_structures.cmn'
+ include 'sos_cer_parms.cmn'
+ include 'sos_physics_sing.cmn'
+ include 'sos_calorimeter.cmn'
+
+ integer*4 nr
+*
+* test for a good electron. Use normalized, tracked shower counter
+* variable (hsshtrk).
+*
+ if (sntracks_fp .eq. 1
+ & .and. sschi2perdeg .gt. 0.
+ & .and. sschi2perdeg .lt. scer_chi2max
+ & .and. ssbeta .gt. scer_beta_min
+ & .and. ssbeta .lt. scer_beta_max
+ & .and. ssshtrk .gt. scer_et_min
+ & .and. ssshtrk .lt. scer_et_max) then
+
+ do nr = 1, scer_num_regions
+*
+* hit must be inside the region in order to continue
+*
+ if (abs(scer_region(nr,1)-ssx_cer).lt.scer_region(nr,5)
+ > .and. abs(scer_region(nr,2)-ssy_cer).lt.scer_region(nr,6)
+ > .and. abs(scer_region(nr,3)-ssxp_fp).lt.scer_region(nr,7)
+ > .and. abs(scer_region(nr,4)-ssyp_fp).lt.scer_region(nr,8))
+ > then
+*
+* increment the 'should have fired' counters
+*
+ scer_track_counter(nr) = scer_track_counter(nr) + 1
+*
+* increment the 'did fire' counters
+*
+ if (SCER_NPE_SUM.gt.scer_threshold) then
+ scer_fired_counter(nr) = scer_fired_counter(nr) + 1
+ endif
+ endif
+ enddo
+ endif
+
+ return
+ end
diff --git a/STRACKING/s_cer_eff_shutdown.f b/STRACKING/s_cer_eff_shutdown.f
new file mode 100644
index 0000000..83d42e7
--- /dev/null
+++ b/STRACKING/s_cer_eff_shutdown.f
@@ -0,0 +1,63 @@
+ SUBROUTINE S_CER_EFF_SHUTDOWN(lunout,ABORT,errmsg)
+
+*--------------------------------------------------------
+*
+* Purpose and Methods: Output Cerenkov efficiency information
+*
+* Required Input BANKS: SOS_CER_DIAGNOSTICS
+*
+* Output: ABORT - success or failure
+* : err - reason for failure, if any
+*
+* author: Chris Cothran
+* created: 5/25/95
+* $Log: s_cer_eff_shutdown.f,v $
+* Revision 1.1 1995/08/31 15:04:56 cdaq
+* Initial revision
+*
+*--------------------------------------------------------
+
+ IMPLICIT NONE
+*
+ character*18 here
+ parameter (here= 'S_CER_EFF_SHUTDOWN')
+*
+ logical ABORT
+ character*(*) errmsg
+*
+ INCLUDE 'sos_data_structures.cmn'
+ INCLUDE 'sos_cer_parms.cmn'
+
+ integer*4 lunout
+ integer*4 nr
+ logical written_header
+
+ save
+
+ written_header = .false. !haven't done the header yet
+
+ do nr = 1, scer_num_regions
+ if (scer_track_counter(nr) .gt. scer_min_counts) then
+ scer_region_eff(nr) = float(scer_fired_counter(nr))
+ > /float(scer_track_counter(nr))
+ else
+ scer_region_eff(nr) = 1.0
+c write (lunout,'(A,I1,A)')
+c > 'Warning: Not enough counts for SOS Cerenkov efficiency
+c > measurement in Region #',nr,'.'
+ endif
+ if (scer_region_eff(nr) .lt. scer_min_eff) then
+ if (.not.written_header) then
+ write(lunout,*)
+ write(lunout,'(a,f6.3)') ' SOS cerenkov regions with effic. < ',scer_min_eff
+ endif
+ write (lunout,'(2x,a,i1,a,f7.4)') 'region ',nr,' has eff = ',
+ & scer_region_eff(nr)
+c write (lunout,'(A,I1,A,F7.5,A)')
+c > 'Warning: Efficiency of SOS Cerekov Region #',nr,' is ',
+c > scer_region_eff(nr),'.'
+ endif
+ enddo
+
+ return
+ end
diff --git a/STRACKING/s_chamnum.f b/STRACKING/s_chamnum.f
new file mode 100644
index 0000000..ebb85c4
--- /dev/null
+++ b/STRACKING/s_chamnum.f
@@ -0,0 +1,28 @@
+ function s_chamnum(ispace_point)
+* This function returns the chamber number of a space point
+* d.f. geesaman 8 Sept 1993
+* $Log: s_chamnum.f,v $
+* Revision 1.2 1995/05/22 19:45:33 cdaq
+* (SAW) Split gen_data_data_structures into gen, hms, sos, and coin parts"
+*
+* Revision 1.1 1994/02/21 16:07:27 cdaq
+* Initial revision
+*
+ implicit none
+ include "sos_data_structures.cmn"
+ include "sos_tracking.cmn"
+ include "sos_geometry.cmn"
+* output
+ integer*4 s_chamnum
+* input
+ integer*4 ispace_point
+* local variables
+ integer*4 plane
+ s_chamnum=0
+ plane=SDC_PLANE_NUM(sspace_point_hits(ispace_point,3))
+ if(plane.gt.0 .and. plane.le. sdc_num_planes) then
+ s_chamnum=sdc_chamber_planes(plane)
+ endif
+ return
+ end
+*
diff --git a/STRACKING/s_choose_single_hit.f b/STRACKING/s_choose_single_hit.f
new file mode 100644
index 0000000..6272462
--- /dev/null
+++ b/STRACKING/s_choose_single_hit.f
@@ -0,0 +1,96 @@
+ subroutine s_choose_single_hit(ABORT,err,nspace_points,
+ & space_point_hits)
+*--------------------------------------------------------
+*-
+*- Purpose and Methods : This routine looks at all hits in a space
+*- point. If two hits are in the same plane it
+*- rejects the one with the longer drift time
+*-
+*-
+*- Output: ABORT - success or failure
+*- : err - reason for failure, if any
+*-
+*- Created 28-JUN-1994 D. F. Geesaman
+* $Log: s_choose_single_hit.f,v $
+* Revision 1.3 1996/01/17 19:04:08 cdaq
+* (JRA) Misc changes
+*
+* Revision 1.2 1995/05/22 19:45:33 cdaq
+* (SAW) Split gen_data_data_structures into gen, hms, sos, and coin parts"
+*
+* Revision 1.1 1994/11/22 21:06:12 cdaq
+* Initial revision
+*
+*--------------------------------------------------------
+ IMPLICIT NONE
+ SAVE
+*
+ character*50 here
+ parameter (here= 's_choose_single_hit')
+ integer*4 nspace_points
+*
+ logical ABORT
+ character*(*) err
+*
+ INCLUDE 'sos_data_structures.cmn'
+ INCLUDE 'gen_constants.par'
+ INCLUDE 'gen_units.par'
+ include 'sos_tracking.cmn'
+ include 'sos_geometry.cmn'
+
+*
+ integer*4 space_point_hits(smax_space_points,smax_hits_per_point+2)
+*
+* local variables
+ integer*4 point,startnum,finalnum,goodhit(smax_dc_hits)
+ integer*4 plane1,plane2,hit1,hit2,drifttime1,drifttime2
+ integer*4 hits(smax_hits_per_point)
+ integer*4 j,k
+
+*
+* temporary initialization
+ ABORT= .FALSE.
+ err=' '
+*
+*
+* loop over all space points
+ do point =1,nspace_points
+ startnum = space_point_hits(point,1)
+ finalnum=0
+
+ do j=3,startnum+2
+ goodhit(j) = 1
+ enddo
+
+ do j=3,startnum+1
+ hit1 = space_point_hits(point,j)
+ plane1 = sdc_plane_num(hit1)
+ drifttime1 = sdc_drift_time(hit1)
+ do k=j+1,startnum+2
+ hit2 = space_point_hits(point,k)
+ plane2 = sdc_plane_num(hit2)
+ drifttime2 = sdc_drift_time(hit2)
+ if(plane1 .eq. plane2 ) then
+ if(drifttime1.gt.drifttime2) then
+ goodhit(j) = 0
+ else !if equal times, choose 1st hit(arbitrary)
+ goodhit(k) = 0
+ endif
+ endif ! end test on equal planes
+ enddo ! end loop on k
+ enddo ! end loop on j
+ do j=3,startnum+2
+ if(goodhit(j).gt.0) then
+ finalnum = finalnum + 1
+ hits(finalnum)=space_point_hits(point,j)
+ endif ! end check on good hit
+ enddo
+* copy good hits to space_point_hits
+ space_point_hits(point,1) = finalnum
+ do j = 1, finalnum
+ space_point_hits(point,j+2) = hits(j)
+ enddo ! end of copy
+ enddo ! end loop on space points
+*
+ return
+ end
diff --git a/STRACKING/s_clusters_cal.f b/STRACKING/s_clusters_cal.f
new file mode 100644
index 0000000..8ea7cf7
--- /dev/null
+++ b/STRACKING/s_clusters_cal.f
@@ -0,0 +1,211 @@
+*=======================================================================
+ subroutine s_clusters_cal(abort,errmsg)
+*=======================================================================
+*-
+*- Purpose: Finds clusters in the calorimeter and computes
+*- for each cluster it's size(number of hit blocks),
+*- position, energy deposition in the calorimeter
+*- columns and the total energy deposition.
+*- The energy depositions are not corrected yet for
+*- impact point coordinate dependence.
+*- A cluster is defined as a set of adjacent hit blocks
+*- which share a common edge or a corner. Any two hits
+*- from different clusters are separated by at least one
+*- block which has not fired.
+*-
+*- Input Banks: SOS_SPARSIFIED_CAL, SOS_DECODED_CAL
+*-
+*- Output Bank: SOS_CLUSTERS_CAL
+*-
+*- Created: 15 Mar 1994 Tsolak A. Amatuni
+*- Modified 25 Mar 1994 DFG
+*- Change name of print routine
+*- 11 Apr 1994 DFG Check if E_t =0 before division
+* $Log: s_clusters_cal.f,v $
+* Revision 1.4 1999/02/03 21:13:44 saw
+* Code for new Shower counter tubes
+*
+* Revision 1.3 1995/05/22 19:45:34 cdaq
+* (SAW) Split gen_data_data_structures into gen, hms, sos, and coin parts"
+*
+* Revision 1.2 1994/11/22 21:08:54 cdaq
+* (SPB) Recopied from hms file and modified names for SOS
+*
+* Revision 1.1 1994/04/13 18:09:34 cdaq
+* Initial revision
+*
+*-----------------------------------------------------------------------
+*
+*
+ implicit none
+ save
+*
+ logical abort
+ character*(*) errmsg
+ character*14 here
+ parameter (here='S_CLUSTERS_CAL')
+*
+ integer*4 nc !Cluster number
+ integer*4 ihit,jhit,khit,nh !Internal loop counters.
+ integer*4 hits_tagged !Current number of tagged hits.
+ integer*4 irow,icol,jrow,jcol,col!Row and column indecies
+ integer*4 d_row,d_col !Distance between rows(columns)
+ logical tagged
+*
+ include 'sos_data_structures.cmn'
+ include 'sos_calorimeter.cmn'
+*
+*
+ snclusters_cal=0
+ if(scal_num_hits.le.0) go to 100 !Return
+*
+ do ihit=1,smax_cal_blocks
+ scluster_hit(ihit)=0
+ enddo
+*
+ nc = 1
+ scluster_hit(1) =-1
+ scluster_size(1) = 1
+ hits_tagged = 1
+ tagged =.true.
+*
+* Find the clusters.
+*
+*
+*-----Loop untill all the hits are tagged
+ do while(hits_tagged.le.scal_num_hits)
+*
+*--------Loop untill there are no more hits
+*--------in the current cluster to be tagged
+ do while(tagged)
+ tagged=.false.
+*
+*-----------Loop over all the hits
+ do ihit=1,scal_num_hits
+*
+*--------------and find a hit("seed") which belongs to the
+*--------------current cluster, but it's neighbors are not tagged
+ if(scluster_hit(ihit).lt.0) then
+ irow =scal_rows(ihit)
+ icol =scal_cols(ihit)
+*
+*-----------------Loop over all the hits
+ do jhit=1,scal_num_hits
+*
+*--------------------and find hits which are not tagged yet
+ if(scluster_hit(jhit).eq.0) then
+ jrow =scal_rows(jhit)
+ jcol =scal_cols(jhit)
+ d_row=iabs(jrow-irow)
+ d_col=iabs(jcol-icol)
+*
+*-----------------------Are these hits a neighbor to "seed"?
+ if(d_row.le.1.and.d_col.le.1) then
+*
+*--------------------------Assign them to the same current cluster
+ scluster_hit(jhit)=scluster_hit(ihit)
+ scluster_size(nc) =scluster_size(nc)+1
+ hits_tagged =hits_tagged+1
+ tagged =.true.
+*
+ endif !End ... if neighbor of "seed"
+*
+ endif !End ... if not scanned yet
+*
+ enddo !End loop over all hits
+*
+*-----------------All the neighbors of "seed" were scanned
+ scluster_hit(ihit)=-scluster_hit(ihit)
+*
+ endif !End ... if "seed"
+*
+ enddo !End loop over all hits
+*
+ enddo !All the hits of the current cluster were tagged
+*
+*--------Initialize to start the search for the next cluster
+ nc =nc+1
+ hits_tagged =hits_tagged+1
+ tagged =.true.
+*
+*--------Find a hit which is not tagged
+ khit=1
+ do while(scluster_hit(khit).ne.0 .AND. KHIT.LT.SMAX_CAL_BLOCKS)
+ khit=khit+1
+ enddo
+*
+*--------This will be the new "seed"
+ IF (NC.GT.SNCLUSTERS_MAX) NC=SNCLUSTERS_MAX !AVOID OUT/BOUNDS
+ scluster_hit(khit)=-nc
+ scluster_size(nc) = 1
+*
+ enddo !End. Now all the hits are assigned to some cluster
+*
+*-----Number of clusters found
+ snclusters_cal=nc-1
+*
+* For each cluster found, compute the center of gravity in X
+* projection, the energy deposited in succesive calorimeter columns
+* and the total energy deposition
+*
+ do nc=1,snclusters_max
+ scluster_e1_pos(nc)=0.
+ scluster_e1_neg(nc)=0.
+ scluster_e2_pos(nc)=0.
+ scluster_e2_neg(nc)=0.
+*
+ scluster_e1(nc)=0.
+ scluster_e2(nc)=0.
+ scluster_e3(nc)=0.
+ scluster_e4(nc)=0.
+ scluster_et(nc)=0.
+ scluster_xc(nc)=0.
+ enddo
+*
+*
+ do nh=1,scal_num_hits
+ nc =MAX(1,scluster_hit(nh)) !AVOIDS OUT/BOUNDS ERRORS
+
+ col=scal_cols(nh)
+*
+ scluster_xc(nc)=scluster_xc(nc)+sblock_xc(nh)*sblock_de(nh)
+*
+ if(col.eq.1) then
+ if(scal_num_neg_columns.ge.1) then
+ scluster_e1_pos(nc)=scluster_e1_pos(nc)+sblock_de_pos(nh)
+ scluster_e1_neg(nc)=scluster_e1_neg(nc)+sblock_de_neg(nh)
+ scluster_e1(nc)=scluster_e1_pos(nc)+scluster_e1_neg(nc)
+ else
+ scluster_e1(nc)=scluster_e1(nc)+sblock_de(nh)
+ endif
+ else if (col.eq.2) then
+ if(scal_num_neg_columns.ge.2) then
+ scluster_e2_pos(nc)=scluster_e2_pos(nc)+sblock_de_pos(nh)
+ scluster_e2_neg(nc)=scluster_e2_neg(nc)+sblock_de_neg(nh)
+ scluster_e2(nc)=scluster_e2_pos(nc)+scluster_e2_neg(nc)
+ else
+ scluster_e2(nc)=scluster_e2(nc)+sblock_de(nh)
+ endif
+ else if(col.eq.3) then
+ scluster_e3(nc)=scluster_e3(nc)+sblock_de(nh)
+ else if(col.eq.4) then
+ scluster_e4(nc)=scluster_e4(nc)+sblock_de(nh)
+ endif
+ scluster_et(nc)=scluster_et(nc)+sblock_de(nh) ! Is sblock_de de_pos+de_neg?
+*
+ enddo
+*
+ do nc=1,snclusters_cal
+* MAKE SURE SCLUSTERS_ET .NE. ZERO SO NO DIVIDE BY ZERO
+ if(scluster_et(nc) .gt. 0.) then
+ scluster_xc(nc)=scluster_xc(nc)/scluster_et(nc)
+ else
+ scluster_xc(nc) = -1.
+ endif
+ enddo
+*
+ 100 continue
+ if(sdbg_clusters_cal.gt.0) call s_prt_cal_clusters
+*
+ return
+ end
diff --git a/STRACKING/s_correct_cal.f b/STRACKING/s_correct_cal.f
new file mode 100644
index 0000000..7cea272
--- /dev/null
+++ b/STRACKING/s_correct_cal.f
@@ -0,0 +1,62 @@
+*=======================================================================
+ function s_correct_cal(x,y)
+*=======================================================================
+*-
+*- Purpose: Returns the impact point correction factor. This
+*- factor is to be applied to the energy depositions.
+*-
+*- Input Parameters: x,y - impact point coordinates
+*-
+*- Created 15 Mar 1994 Tsolak A. Amatuni
+* $Log: s_correct_cal.f,v $
+* Revision 1.7 2003/04/03 00:45:01 jones
+* Update to calorimeter calibration (V. Tadevosyan)
+*
+* Revision 1.6 2003/03/21 22:58:02 jones
+* Subroutines had arguments with abort,errmsg . But these arguments were not
+* used when the subroutine was called. Also abort ,errmsg were not used in the
+* subroutines. So eliminate abort,errmsg. (E. Brash)
+*
+* Revision 1.5 1999/01/29 17:34:57 saw
+* Add variables for second tubes on shower counter
+*
+* Revision 1.4 1995/05/22 19:45:34 cdaq
+* (SAW) Split gen_data_data_structures into gen, hms, sos, and coin parts"
+*
+* Revision 1.3 1995/05/11 21:02:59 cdaq
+* (???) Tweak hardwired attenuation length
+*
+* Revision 1.2 1994/11/22 21:09:22 cdaq
+* (SPB) Recopied from hms file and modified names for SOS
+*
+* Revision 1.1 1994/04/13 18:10:02 cdaq
+* Initial revision
+*
+*-----------------------------------------------------------------------
+*
+ implicit none
+ save
+*
+* logical abort
+* character*(*) errmsg
+ character*13 here
+ parameter (here='S_CORRECT_CAL')
+*
+ real*4 x,y !Impact point coordinates
+ real*4 s_correct_cal
+*
+ include 'sos_data_structures.cmn'
+ include 'sos_calorimeter.cmn'
+*
+*
+
+c Check calorimeter boundaries.
+
+ if(y.lt.scal_ymin) y=scal_ymin
+ if(y.gt.scal_ymax) y=scal_ymax
+*
+ s_correct_cal=exp(-y/400.) !400 cm atten length.
+ s_correct_cal=s_correct_cal/(1. + y*y/12000)
+*
+ return
+ end
diff --git a/STRACKING/s_correct_cal_neg.f b/STRACKING/s_correct_cal_neg.f
new file mode 100644
index 0000000..89dc8a0
--- /dev/null
+++ b/STRACKING/s_correct_cal_neg.f
@@ -0,0 +1,59 @@
+*=======================================================================
+ function s_correct_cal_neg(x,y)
+*=======================================================================
+*-
+*- Purpose: Returns the impact point correction factor. This
+*- factor is to be applied to the energy depositions.
+*- This correction for single "NEG_PMT" readout from
+*- LG-blocks. The final energy is the ADC value TIMES
+*- the correction factor.
+*-
+*- Input Parameters: x,y - impact point coordinates
+*-
+*- Created 27 January 1999 SAW
+*
+* $Log: s_correct_cal_neg.f,v $
+* Revision 1.4 2003/04/03 00:45:01 jones
+* Update to calorimeter calibration (V. Tadevosyan)
+*
+* Revision 1.3 2003/03/21 22:58:02 jones
+* Subroutines had arguments with abort,errmsg . But these arguments were not
+* used when the subroutine was called. Also abort ,errmsg were not used in the
+* subroutines. So eliminate abort,errmsg. (E. Brash)
+*
+* Revision 1.2 1999/02/25 20:18:40 saw
+* Vardan Tadevosyan shower code updates
+*
+* Revision 1.1 1999/01/29 17:34:57 saw
+* Add variables for second tubes on shower counter
+*
+*
+*
+*-----------------------------------------------------------------------
+*
+ implicit none
+ save
+*
+* logical abort
+* character*(*) errmsg
+ character*17 here
+ parameter (here='S_CORRECT_CAL_NEG')
+*
+*
+ real*4 x,y ! Impact point coordinates
+ real*4 s_correct_cal_neg
+*
+ include 'sos_data_structures.cmn'
+ include 'sos_calorimeter.cmn'
+*
+
+c Check calorimeter boundaries.
+
+ if(y.lt.scal_ymin) y=scal_ymin
+ if(y.gt.scal_ymax) y=scal_ymax
+
+c Tuned to straight through pions of run #23121. Works well for |Y|<20.
+
+ s_correct_cal_neg=(100.+y)/(100.+y/3.)
+
+ end
diff --git a/STRACKING/s_correct_cal_pos.f b/STRACKING/s_correct_cal_pos.f
new file mode 100644
index 0000000..be56307
--- /dev/null
+++ b/STRACKING/s_correct_cal_pos.f
@@ -0,0 +1,61 @@
+*=======================================================================
+ function s_correct_cal_pos(x,y)
+*=======================================================================
+*-
+*- Purpose: Returns the impact point correction factor. This
+*- factor is to be applied to the energy depositions.
+*- The final energy is the ADC value TIMES the correction factor.
+*-
+*- Input Parameters: x,y - impact point coordinates
+*-
+*- Created 15 Mar 1994 Tsolak A. Amatuni
+*
+* $Log: s_correct_cal_pos.f,v $
+* Revision 1.4 2003/03/21 22:58:02 jones
+* Subroutines had arguments with abort,errmsg . But these arguments were not
+* used when the subroutine was called. Also abort ,errmsg were not used in the
+* subroutines. So eliminate abort,errmsg. (E. Brash)
+*
+* Revision 1.3 1999/06/10 17:04:19 csa
+* (JRA) Changed s_correct_cal_pos calculation
+*
+* Revision 1.2 1999/02/25 20:18:40 saw
+* Vardan Tadevosyan shower code updates
+*
+* Revision 1.1 1999/01/29 17:34:57 saw
+* Add variables for second tubes on shower counter
+*
+*
+*-----------------------------------------------------------------------
+*
+ implicit none
+ save
+*
+* logical abort
+* character*(*) errmsg
+ character*17 here
+ parameter (here='S_CORRECT_CAL_POS')
+ real a,b,c ! Fit parameters.
+ parameter (a=2.3926,b=-0.371375,c=-0.25401)
+*
+ real*4 x,y !Impact point coordinates
+ real*4 s_correct_cal_pos
+ real*4 d,al ! Auxiliary variables.
+*
+ include 'sos_data_structures.cmn'
+ include 'sos_calorimeter.cmn'
+*
+* Fit to MC data in the range of y [-30,+30].
+*
+! d=y-35. !need to insure d is never less than -35!!!
+! al=alog(d)
+! s_correct_cal_pos=1./(a+b*al+c/al)
+
+*
+* Fit to data (run23121)
+*
+ s_correct_cal_pos=exp(-y/210.7) !~200 cm atten length.
+ s_correct_cal_pos=s_correct_cal_pos/(1.+y*y/22000.)
+
+ return
+ end
diff --git a/STRACKING/s_correct_cal_two.f b/STRACKING/s_correct_cal_two.f
new file mode 100644
index 0000000..368f241
--- /dev/null
+++ b/STRACKING/s_correct_cal_two.f
@@ -0,0 +1,49 @@
+*=======================================================================
+ function s_correct_cal_two(x,y)
+*=======================================================================
+*-
+*- Purpose: Returns the impact point correction factor. This
+*- factor is to be applied to the energy depositions.
+*- (This correction for the case when "POS_PMT"+"NEG_PMT".
+*- The final energy is the ADC value TIMES the correction factor.
+*-
+*- Input Parameters: x,y - impact point coordinates
+*-
+*- Created 27 September 1999 SAW
+*
+* $Log: s_correct_cal_two.f,v $
+* Revision 1.2 2003/03/21 22:58:02 jones
+* Subroutines had arguments with abort,errmsg . But these arguments were not
+* used when the subroutine was called. Also abort ,errmsg were not used in the
+* subroutines. So eliminate abort,errmsg. (E. Brash)
+*
+* Revision 1.1 1999/01/29 17:34:57 saw
+* Add variables for second tubes on shower counter
+*
+*
+*
+*-----------------------------------------------------------------------
+*
+ implicit none
+ save
+*
+* logical abort
+* character*(*) errmsg
+ character*17 here
+ parameter (here='S_CORRECT_CAL_TWO')
+*
+*
+ real*4 x,y !Impact point coordinates
+ real*4 s_correct_cal_two
+*
+ include 'sos_data_structures.cmn'
+ include 'sos_calorimeter.cmn'
+*
+* ! I was used simple combination of "s_correct_cal_pos" and
+* and "s_correct_cal_neg". To be corrected !! (Hamlet)
+*
+ s_correct_cal_two=exp(y/200.)+exp(-y/200.) !200 cm atten length.
+ s_correct_cal_two=s_correct_cal_two*(1. + y*y/8000.)
+*
+ return
+ end
diff --git a/STRACKING/s_dc_eff.f b/STRACKING/s_dc_eff.f
new file mode 100644
index 0000000..b00c277
--- /dev/null
+++ b/STRACKING/s_dc_eff.f
@@ -0,0 +1,54 @@
+ SUBROUTINE S_DC_EFF(ABORT,errmsg)
+*--------------------------------------------------------
+*-
+*- Purpose and Methods : Analyze scintillator information for each track
+*-
+*- Required Input BANKS SOS_STATISTICS
+*- GEN_DATA_STRUCTURES
+*-
+*- Output: ABORT - success or failure
+*- : err - reason for failure, if any
+*-
+* author: John Arrington
+* created: 8/17/95
+*
+* s_dc_eff calculates efficiencies for the drift chambers.
+*
+* $Log: s_dc_eff.f,v $
+* Revision 1.1 1995/08/31 15:07:28 cdaq
+* Initial revision
+*
+*--------------------------------------------------------
+ IMPLICIT NONE
+*
+ character*8 here
+ parameter (here= 'S_DC_EFF')
+*
+ logical ABORT
+ character*(*) errmsg
+*
+ INCLUDE 'sos_data_structures.cmn'
+ INCLUDE 'gen_constants.par'
+ INCLUDE 'gen_units.par'
+ include 'sos_statistics.cmn'
+ include 'sos_tracking.cmn'
+
+ integer*4 ind
+
+ save
+
+ sdc_tot_events = sdc_tot_events + 1
+ do ind = 1 , sdc_num_planes
+ if (sdc_hits_per_plane(ind).gt.0) sdc_events(ind)=sdc_events(ind)+1
+ enddo
+
+ if (sdc_hits_per_plane(1)+sdc_hits_per_plane(2)+sdc_hits_per_plane(3)
+ & +sdc_hits_per_plane(4)+sdc_hits_per_plane(5)+sdc_hits_per_plane(6)
+ & .ne. 0) sdc_cham_hits(1) = sdc_cham_hits(1) + 1
+
+ if (sdc_hits_per_plane( 7)+sdc_hits_per_plane( 8)+sdc_hits_per_plane( 9)
+ & +sdc_hits_per_plane(10)+sdc_hits_per_plane(11)+sdc_hits_per_plane(12)
+ & .ne. 0) sdc_cham_hits(2) = sdc_cham_hits(2) + 1
+
+ return
+ end
diff --git a/STRACKING/s_dc_eff_shutdown.f b/STRACKING/s_dc_eff_shutdown.f
new file mode 100644
index 0000000..76748b6
--- /dev/null
+++ b/STRACKING/s_dc_eff_shutdown.f
@@ -0,0 +1,68 @@
+ SUBROUTINE S_DC_EFF_SHUTDOWN(lunout,ABORT,errmsg)
+*--------------------------------------------------------
+*-
+*- Purpose and Methods : Analyze and report drift chamber efficiencies.
+*-
+*- Required Input BANKS SOS_STATISTICS
+*- GEN_DATA_STRUCTURES
+*-
+*- Output: ABORT - success or failure
+*- : err - reason for failure, if any
+*-
+* author: John Arrington
+* created: 2/15/95
+*
+* s_dc_eff calculates efficiencies for the hodoscope.
+* s_dc_eff_shutdown does some final manipulation of the numbers.
+*
+* $Log: s_dc_eff_shutdown.f,v $
+* Revision 1.2 1996/09/05 13:29:49 saw
+* (JRA) Cosmetic
+*
+* Revision 1.1 1995/08/31 15:07:37 cdaq
+* Initial revision
+*
+*--------------------------------------------------------
+ IMPLICIT NONE
+*
+ character*17 here
+ parameter (here= 'S_DC_EFF_SHUTDOWN')
+*
+ logical ABORT
+ character*(*) errmsg
+*
+ INCLUDE 'sos_data_structures.cmn'
+ INCLUDE 'gen_constants.par'
+ INCLUDE 'gen_units.par'
+ include 'sos_statistics.cmn'
+ include 'sos_tracking.cmn'
+
+ logical written_header
+
+ integer*4 lunout
+ integer*4 ind
+ real*4 num ! real version of #/events (aviod repeated floats)
+ save
+
+ written_header = .false.
+
+ num = float(max(1,sdc_tot_events))
+ do ind = 1 , sdc_num_planes
+ sdc_plane_eff(ind) = float(sdc_events(ind))/num
+ if (sdc_plane_eff(ind) .le. sdc_min_eff(ind) .and. num.ge.1000) then
+ if (.not.written_header) then
+ write(lunout,*)
+ write(lunout,'(a,f6.3)') ' SOS DC planes with low raw hit (hits/trig)efficiencies'
+ written_header = .true.
+ endif
+ write(lunout,'(5x,a,i2,a,f5.3,a,f5.3)') 'eff. for plane #',ind,' is ',
+ & sdc_plane_eff(ind),', warning level is ',sdc_min_eff(ind)
+ endif
+ enddo
+
+ do ind = 1 , sdc_num_chambers
+ sdc_cham_eff(ind) = float(sdc_cham_hits(ind))/num
+ enddo
+
+ return
+ end
diff --git a/STRACKING/s_dc_trk_eff.f b/STRACKING/s_dc_trk_eff.f
new file mode 100644
index 0000000..084f62b
--- /dev/null
+++ b/STRACKING/s_dc_trk_eff.f
@@ -0,0 +1,81 @@
+ SUBROUTINE S_DC_TRK_EFF(ABORT,errmsg)
+*--------------------------------------------------------
+*-
+*- Purpose and Methods : Analyze DC information for each track
+*-
+*- Required Input BANKS SOS_STATISTICS
+*- GEN_DATA_STRUCTURES
+*-
+*- Output: ABORT - success or failure
+*- : err - reason for failure, if any
+*-
+* author: John Arrington
+* created: 9/5/95
+*
+* s_dc_trk_eff calculates efficiencies for the drift chambers,
+* using the tracking information.
+*
+* $Log: s_dc_trk_eff.f,v $
+* Revision 1.2 1996/01/17 17:09:36 cdaq
+* (JRA) Change array sizes from sdc_num_planes to SMAX_NUM_DC_PLANES
+*
+* Revision 1.1 1995/10/09 20:02:37 cdaq
+* Initial revision
+*
+*--------------------------------------------------------
+ IMPLICIT NONE
+*
+ character*12 here
+ parameter (here= 'S_DC_TRK_EFF')
+*
+ logical ABORT
+ character*(*) errmsg
+*
+ INCLUDE 'sos_data_structures.cmn'
+ INCLUDE 'gen_constants.par'
+ INCLUDE 'gen_units.par'
+ include 'sos_tracking.cmn'
+ include 'sos_geometry.cmn'
+
+ integer*4 pln,hit,ihit
+ integer*4 iwire(SMAX_NUM_DC_PLANES)
+ integer*4 ihitwire
+ real*4 hitwire
+ real*4 hitdist(SMAX_NUM_DC_PLANES)
+
+ save
+
+* find nearest wire, and increment 'should have fired' counter.
+ do pln=1,sdc_num_planes
+ hitwire = sdc_central_wire(pln) +
+ & (ssdc_track_coord(pln)+sdc_center(pln))/sdc_pitch(pln)
+ hitdist(pln) = (hitwire - nint(hitwire))*sdc_pitch(pln)
+
+ if (sdc_wire_counting(pln).eq.0) then !normal wire numbering.
+ ihitwire = nint(hitwire)
+ else !backwards numbering.
+ ihitwire = (sdc_nrwire(pln) + 1 ) - nint(hitwire)
+ endif
+ iwire(pln) = max(1,min(sdc_nrwire(pln),ihitwire))
+ if (ihitwire.ne.iwire(pln)) hitdist(pln)=99. !if had to reset wire,
+ !make it a 'miss'
+
+ if (abs(hitdist(pln)).le.0.3) then !hit close to wire.
+ sdc_shouldhit(pln,iwire(pln)) = sdc_shouldhit(pln,iwire(pln)) + 1
+ endif
+ enddo
+
+* note, this does not look for hits on the track which were NOT in the space
+* point used to fit the track! (though this is probably OK).
+
+ do ihit=2,sntrack_hits(ssnum_fptrack,1)+1
+ hit=sntrack_hits(ssnum_fptrack,ihit)
+ pln=sdc_plane_num(hit)
+ if (iwire(pln).eq.sdc_wire_num(hit) .and.
+ & abs(hitdist(pln)).le.0.3)then
+ sdc_didhit(pln,iwire(pln)) = sdc_didhit(pln,iwire(pln)) + 1
+ endif
+ enddo
+
+ return
+ end
diff --git a/STRACKING/s_dc_trk_eff_shutdown.f b/STRACKING/s_dc_trk_eff_shutdown.f
new file mode 100644
index 0000000..e282432
--- /dev/null
+++ b/STRACKING/s_dc_trk_eff_shutdown.f
@@ -0,0 +1,77 @@
+ SUBROUTINE S_DC_TRK_EFF_SHUTDOWN(lunout,ABORT,errmsg)
+*--------------------------------------------------------
+*-
+*- Purpose and Methods : Analyze and report drift chamber efficiencies.
+*-
+*- Required Input BANKS SOS_STATISTICS
+*- GEN_DATA_STRUCTURES
+*-
+*- Output: ABORT - success or failure
+*- : err - reason for failure, if any
+*-
+* author: John Arrington
+* created: 9/5/95
+*
+* s_dc_trk_eff calculates efficiencies for the chambers (using tracking)
+* s_dc_trk_eff_shutdown does some final manipulation of the numbers.
+*
+* $Log: s_dc_trk_eff_shutdown.f,v $
+* Revision 1.1 1995/10/09 20:05:32 cdaq
+* Initial revision
+*
+*
+*--------------------------------------------------------
+ IMPLICIT NONE
+*
+ character*21 here
+ parameter (here= 'S_DC_TRK_EFF_SHUTDOWN')
+*
+ logical ABORT
+ character*(*) errmsg
+*
+ INCLUDE 'sos_data_structures.cmn'
+ INCLUDE 'gen_constants.par'
+ INCLUDE 'gen_units.par'
+ include 'sos_tracking.cmn'
+ include 'sos_geometry.cmn'
+
+ logical written_header
+
+ integer*4 lunout
+ integer*4 pln,wire
+ real*4 wireeff,planeeff
+ real*4 num ! real version of #/events (aviod repeated floats)
+ save
+
+ written_header = .false.
+
+ do pln = 1 , sdc_num_planes
+ sdc_didsum(pln)=0
+ sdc_shouldsum(pln)=0
+ do wire = 1 , sdc_nrwire(pln)
+ sdc_shouldsum(pln) = sdc_shouldsum(pln) + 1
+ sdc_didsum(pln) = sdc_didsum(pln) + 1
+ num = float(max(1,sdc_shouldhit(pln,wire)))
+ wireeff = float(sdc_didhit(pln,wire)) / num
+ if (num.gt.50 .and. wireeff.lt.sdc_min_wire_eff) then
+ write(lunout,111) ' SOS pln=',pln,', wire=',wire,
+ & ', effic=',wireeff,' = ',sdc_didhit(pln,wire),'/',
+ & sdc_shouldhit(pln,wire)
+
+ endif
+ enddo
+ enddo
+111 format (a,i3,a,i4,a,f4.2,a,i6,a,i6)
+
+ do pln = 1 , sdc_num_planes
+ planeeff=float(sdc_didsum(pln))/float(max(1,sdc_shouldsum(pln)))
+ if (sdc_shouldsum(pln).gt.1000 .and.
+ & planeeff.gt.sdc_min_plane_eff(pln)) then
+ write(lunout,112) 'ave. effic for plane',pln,' is ',
+ & planeeff,' = ',sdc_didsum(pln),'/',sdc_shouldsum(pln)
+ endif
+ enddo
+112 format (a,i3,a,f4.2,a,i7,a,i7)
+
+ return
+ end
diff --git a/STRACKING/s_dpsifun.f b/STRACKING/s_dpsifun.f
new file mode 100644
index 0000000..d693d1f
--- /dev/null
+++ b/STRACKING/s_dpsifun.f
@@ -0,0 +1,62 @@
+ function S_DPSIFUN(ray,iplane)
+* this function calculates the psi coordinate of the intersection
+* of a ray (defined by ray) with a wire chamber plane. the geometry
+* of the plane is contained in the coeff array calculated in the
+* array splane_coeff
+* Note it is call by MINUIT via S_FCNCHISQ and so uses double precision
+* variables
+*
+* the ray is defined by
+* x = (z-zt)*tan(xp) + xt
+* y = (z-zt)*tan(yp) + yt
+* at some fixed value of zt*
+* ray(1) = xt
+* ray(2) = yt
+* ray(3) = tan(xp)
+* ray(4) = tan(yp)
+*
+* d.f. geesaman 1 September 1993
+* $Log: s_dpsifun.f,v $
+* Revision 1.3 1995/05/22 19:45:35 cdaq
+* (SAW) Split gen_data_data_structures into gen, hms, sos, and coin parts"
+*
+* Revision 1.2 1994/02/22 05:47:45 cdaq
+* (SAW) Removed dfloat calls with floating args
+*
+* Revision 1.1 1994/02/21 16:07:39 cdaq
+* Initial revision
+*
+*
+ implicit none
+ include "sos_data_structures.cmn"
+ include "sos_geometry.cmn"
+*
+* input
+ real*8 ray(4) ! xt,yt,xpt,ypt
+ integer*4 iplane ! plane number
+* output
+ real*8 S_DPSIFUN ! value of psi coordinate of hit of ray in plane
+*
+* local variables
+ real*8 denom,infinity,cinfinity
+ parameter (infinity = 1.0d20)
+ parameter (cinfinity = 1/infinity)
+*
+ S_DPSIFUN = ray(3)*ray(2)*(splane_coeff(1,iplane))
+ & + ray(4)*ray(1)*(splane_coeff(2,iplane))
+ & + ray(3)*(splane_coeff(3,iplane))
+ & + ray(4)*(splane_coeff(4,iplane))
+ & + ray(1)*(splane_coeff(5,iplane))
+ & + ray(2)*(splane_coeff(6,iplane))
+*
+ denom = ray(3)*(splane_coeff(7,iplane))
+ & + ray(4)*(splane_coeff(8,iplane))
+ & + (splane_coeff(9,iplane))
+*
+ if(abs(denom).lt.cinfinity) then
+ S_DPSIFUN=infinity
+ else
+ S_DPSIFUN = S_DPSIFUN/denom
+ endif
+ return
+ end
diff --git a/STRACKING/s_drift_dist_calc.f b/STRACKING/s_drift_dist_calc.f
new file mode 100644
index 0000000..1772adb
--- /dev/null
+++ b/STRACKING/s_drift_dist_calc.f
@@ -0,0 +1,67 @@
+ real*4 function s_drift_dist_calc(plane,wire,time)
+*
+* function to calculate sos drift time from tdc value in sos
+* wire chambers
+*
+* d.f. geesaman 17 feb 1994
+* $Log: s_drift_dist_calc.f,v $
+* Revision 1.5 1996/04/30 17:01:21 saw
+* (JRA) Add drift time correction for disc card
+*
+* Revision 1.4 1995/10/10 13:02:39 cdaq
+* (JRA) Remove check for zero drift bin size
+*
+* Revision 1.3 1995/05/22 19:45:35 cdaq
+* (SAW) Split gen_data_data_structures into gen, hms, sos, and coin parts"
+*
+* Revision 1.2 1994/11/22 21:09:59 cdaq
+* (SPB) Recopied from hms file and modified names for SOS
+*
+* Revision 1.1 1994/02/21 16:08:13 cdaq
+* Initial revision
+*
+*
+ implicit none
+ include 'sos_data_structures.cmn'
+ include 'sos_geometry.cmn'
+ include 'sos_tracking.cmn' ! for lookup tables
+*
+* input
+*
+ integer*4 plane ! plane number of hit
+ integer*4 wire ! wire number of hit
+ integer*4 ilo,ihi ! interpolate between bins ilo and ilo+1
+ real*4 time ! drift time in ns
+ real*4 fractinterp ! interpolated fraction
+*
+* output
+*
+
+
+* look in the appropriate drift time to distance table and perform a linear
+* interpolation. minimum and maximum distance values are 0.0cm and 0.5cm.
+c if( sdriftbinsz.eq.0.0)then
+c fractinterp = -1.0
+c s_drift_dist_calc = 0.5*fractinterp
+c return
+c endif
+ ilo = int((time-sdrift1stbin)/sdriftbinsz) + 1
+ ihi = ilo + 1
+ if( ilo.ge.1 .and. ihi.le.sdriftbins)then
+ fractinterp = sfract(ilo,plane) +
+ & ( (sfract(ilo+1,plane)-sfract(ilo,plane))/sdriftbinsz )*
+ & (time - sdrift1stbin - (ilo-1)*sdriftbinsz)
+ else
+ if( ilo.lt.1 )then
+ fractinterp = 0.0
+ else
+ if( ihi.gt.sdriftbins )fractinterp = 1.0
+ endif
+ endif
+
+ s_drift_dist_calc = 0.5*fractinterp -
+ $ sdc_card_delay(sdc_card_no(wire,plane))
+
+ return
+ end
+
diff --git a/STRACKING/s_drift_time_calc.f b/STRACKING/s_drift_time_calc.f
new file mode 100644
index 0000000..0634302
--- /dev/null
+++ b/STRACKING/s_drift_time_calc.f
@@ -0,0 +1,44 @@
+ function s_drift_time_calc(plane,wire,tdc)
+*
+* function to calculate sos drift time from tdc value in sos
+* wire chambers
+*
+* d.f. geesaman 17 feb 1994
+* $Log: s_drift_time_calc.f,v $
+* Revision 1.5 1995/10/09 20:16:16 cdaq
+* (JRA) Remove monte carlo data option
+*
+* Revision 1.4 1995/05/22 19:45:36 cdaq
+* (SAW) Split gen_data_data_structures into gen, hms, sos, and coin parts"
+*
+* Revision 1.3 1994/11/22 21:10:31 cdaq
+* (SPB) Recopied from hms file and modified names for SOS
+*
+* Revision 1.2 1994/03/24 19:52:20 cdaq
+* (DFG) Allow switch for monte carlo data
+*
+* Revision 1.1 1994/02/21 16:08:30 cdaq
+* Initial revision
+*
+*
+ implicit none
+ include "sos_data_structures.cmn"
+ include "sos_tracking.cmn"
+ include "sos_geometry.cmn"
+*
+* input
+*
+ integer*4 plane ! plane number of hit
+ integer*4 wire ! wire number of hit
+ integer*4 tdc ! tdc value
+*
+* output
+*
+ real*4 s_drift_time_calc ! drift time in nanoseconds
+
+*
+ s_drift_time_calc = sstart_time
+ & - float(tdc)*sdc_tdc_time_per_channel
+ & + sdc_plane_time_zero(plane)
+ return
+ end
diff --git a/STRACKING/s_dump_cal.f b/STRACKING/s_dump_cal.f
new file mode 100644
index 0000000..14d9cad
--- /dev/null
+++ b/STRACKING/s_dump_cal.f
@@ -0,0 +1,69 @@
+ SUBROUTINE S_DUMP_CAL(ABORT,errmsg)
+*--------------------------------------------------------
+*-
+*- Purpose and Methods : Analyze scintillator information for each track
+*-
+*- Required Input BANKS SOS_CALORIMETER
+*- GEN_DATA_STRUCTURES
+*-
+*- Output: ABORT - success or failure
+*- : err - reason for failure, if any
+*-
+* author: John Arrington
+* created: 9/7/95
+*
+* s_dump_cal writes out the raw calorimeter information for the final tracks.
+* This data is analyzed by independent routines to fit the gains for each
+* block.
+*
+* $Log: s_dump_cal.f,v $
+* Revision 1.4 1999/06/10 16:56:30 csa
+* (JRA) Added ycal, emeas calculations, changed test condition
+*
+* Revision 1.3 1999/01/29 17:34:58 saw
+* Add variables for second tubes on shower counter
+*
+* Revision 1.2 1996/01/17 18:07:51 cdaq
+* (JRA) Put track and delta cuts on what get's written out
+*
+* Revision 1.1 1995/10/09 20:17:10 cdaq
+* Initial revision
+*
+*--------------------------------------------------------
+ IMPLICIT NONE
+*
+ character*10 here
+ parameter (here= 'S_DUMP_CAL')
+*
+ logical ABORT
+ character*(*) errmsg
+*
+ INCLUDE 'sos_data_structures.cmn'
+ include 'sos_calorimeter.cmn'
+
+ integer*4 blk
+ real*4 emeas,ycal
+
+ save
+
+*
+* Write out cal fitting data.
+*
+* What should this do for new tubes?
+*
+ if (abs(ssdelta).le.18 .and. scer_npe_sum.ge.2.0) then
+
+ ycal=ssy_fp + scal_1pr_zpos*ssyp_fp
+ ycal=min(35.,ycal)
+ ycal=max(-35.,ycal)
+ emeas=ssp*exp(-ycal/210.7)/(1+ycal**2/22000.)
+
+ write(36,'(1x,44(1x,f6.1),1x,e11.4)')
+ & (scal_realadc_pos(blk),blk=1,smax_cal_blocks),emeas
+! if(scal_num_neg_columns.gt.0) then
+! write(36,'(1x,44(1x,f6.1),1x,e11.4)')
+! & (scal_realadc_neg(blk),blk=1,smax_cal_blocks),ssp
+! endif
+ endif
+ RETURN
+ END
diff --git a/STRACKING/s_dump_peds.f b/STRACKING/s_dump_peds.f
new file mode 100644
index 0000000..09dceb7
--- /dev/null
+++ b/STRACKING/s_dump_peds.f
@@ -0,0 +1,152 @@
+ subroutine s_dump_peds(ABORT,err)
+*
+* $Log: s_dump_peds.f,v $
+* Revision 1.6.24.1 2007/09/13 04:02:18 brash
+* Implement some minor changes to fix Mac OS X runtime errors ... ejb
+*
+* Revision 1.6 1999/01/29 17:34:58 saw
+* Add variables for second tubes on shower counter
+*
+* Revision 1.5 1996/11/07 19:50:44 saw
+* (JRA) ??
+*
+* Revision 1.4 1996/04/30 17:11:20 saw
+* (JRA) Cleanup
+*
+* Revision 1.3 1996/01/17 19:04:27 cdaq
+* (JRA)
+*
+* Revision 1.2 1995/10/09 20:18:31 cdaq
+* (JRA) Cleanup, add cerenkov pedestals
+*
+* Revision 1.1 1995/08/31 18:06:45 cdaq
+* Initial revision
+*
+*
+ implicit none
+ save
+*
+ character*11 here
+ parameter (here='s_dump_peds')
+*
+ logical ABORT
+ character*(*) err
+*
+ integer*4 pln,cnt
+ integer*4 blk
+ integer*4 pmt
+ character*132 file
+
+ integer*4 SPAREID
+ parameter (SPAREID=67)
+*
+ INCLUDE 'sos_data_structures.cmn'
+ INCLUDE 'sos_pedestals.cmn'
+ INCLUDE 'sos_scin_parms.cmn'
+ INCLUDE 'sos_calorimeter.cmn'
+ INCLUDE 'sos_cer_parms.cmn'
+ INCLUDE 'sos_filenames.cmn'
+ INCLUDE 'gen_run_info.cmn'
+
+ if (s_pedestal_output_filename.ne.' ') then
+ file=s_pedestal_output_filename
+ call g_sub_run_number(file, gen_run_number)
+ open(unit=SPAREID,file=file,status='unknown')
+ else
+ return
+ endif
+
+ write(SPAREID,*) 'These are the values that were used for the analysis'
+ write(SPAREID,*) ' (from the param file or pedestal events)'
+ write(SPAREID,*)
+*
+*
+* HODOSCOPE PEDESTALS
+*
+ write(SPAREID,*) 'sscin_all_ped_pos ='
+ do cnt = 1 , snum_scin_elements
+ write(SPAREID,111) (sscin_all_ped_pos(pln,cnt),pln=1,4)
+ enddo
+ write(SPAREID,*) 'shodo_new_ped_pos ='
+ do cnt = 1 , snum_scin_elements
+ write(SPAREID,111) (shodo_new_ped_pos(pln,cnt),pln=1,4)
+ enddo
+ write(SPAREID,*) 'shodo_new_sig_pos ='
+ do cnt = 1 , snum_scin_elements
+ write(SPAREID,111) (shodo_new_sig_pos(pln,cnt),pln=1,4)
+ enddo
+ write(SPAREID,*) 'shodo_new_threshold_pos ='
+ do cnt = 1 , snum_scin_elements
+ write(SPAREID,111) (shodo_new_threshold_pos(pln,cnt),pln=1,4)
+ enddo
+ write(SPAREID,*) 'sscin_all_ped_neg ='
+ do cnt = 1 , snum_scin_elements
+ write(SPAREID,111) (sscin_all_ped_neg(pln,cnt),pln=1,4)
+ enddo
+ write(SPAREID,*) 'shodo_new_ped_neg ='
+ do cnt = 1 , snum_scin_elements
+ write(SPAREID,111) (shodo_new_ped_neg(pln,cnt),pln=1,4)
+ enddo
+ write(SPAREID,*) 'shodo_new_sig_neg ='
+ do cnt = 1 , snum_scin_elements
+ write(SPAREID,111) (shodo_new_sig_neg(pln,cnt),pln=1,4)
+ enddo
+ write(SPAREID,*) 'shodo_new_threshold_neg ='
+ do cnt = 1 , snum_scin_elements
+ write(SPAREID,111) (shodo_new_threshold_neg(pln,cnt),pln=1,4)
+ enddo
+
+111 format(10x,3(f6.1,','),f6.1)
+*
+*
+* CALORIMETER PEDESTALS ( Hamlet test version)
+*
+ write(SPAREID,*) ' scal_pos_ped_mean = '
+ write(SPAREID,112) (scal_pos_ped_mean(blk),blk=1,smax_cal_rows)
+ write(SPAREID,112) (scal_pos_ped_mean(blk),blk=smax_cal_rows+1,2*smax_cal_rows)
+ write(SPAREID,112) (scal_pos_ped_mean(blk),blk=2*smax_cal_rows+1,3*smax_cal_rows)
+ write(SPAREID,112) (scal_pos_ped_mean(blk),blk=3*smax_cal_rows+1,4*smax_cal_rows)
+ write(SPAREID,*) '; calorimeter ped. sigma (sqrt(variance))'
+ write(SPAREID,*) ' scal_pos_ped_rms = '
+ write(SPAREID,112) (scal_pos_ped_rms(blk),blk=1,smax_cal_rows)
+ write(SPAREID,112) (scal_pos_ped_rms(blk),blk=smax_cal_rows+1,2*smax_cal_rows)
+ write(SPAREID,112) (scal_pos_ped_rms(blk),blk=2*smax_cal_rows+1,3*smax_cal_rows)
+ write(SPAREID,112) (scal_pos_ped_rms(blk),blk=3*smax_cal_rows+1,4*smax_cal_rows)
+ write(SPAREID,*) '; calorimeter threshold above ped. =MIN(50,MAX(10,3*sigma))'
+ write(SPAREID,*) 'scal_new_threshold_pos = '
+ write(SPAREID,112) (scal_new_adc_threshold_pos(blk),blk=1,smax_cal_rows)
+ write(SPAREID,112) (scal_new_adc_threshold_pos(blk),blk=smax_cal_rows+1,2*smax_cal_rows)
+ write(SPAREID,112) (scal_new_adc_threshold_pos(blk),blk=2*smax_cal_rows+1,3*smax_cal_rows)
+ write(SPAREID,112) (scal_new_adc_threshold_pos(blk),blk=3*smax_cal_rows+1,4*smax_cal_rows)
+*
+ write(SPAREID,*) ' scal_neg_ped_mean = '
+ write(SPAREID,112) (scal_neg_ped_mean(blk),blk=1,smax_cal_rows)
+ write(SPAREID,112) (scal_neg_ped_mean(blk),blk=smax_cal_rows+1,2*smax_cal_rows)
+ write(SPAREID,112) (scal_neg_ped_mean(blk),blk=2*smax_cal_rows+1,3*smax_cal_rows)
+ write(SPAREID,112) (scal_neg_ped_mean(blk),blk=3*smax_cal_rows+1,4*smax_cal_rows)
+ write(SPAREID,*) '; calorimeter ped. sigma (sqrt(variance))'
+ write(SPAREID,*) ' scal_ped_neg_rms = '
+ write(SPAREID,112) (scal_neg_ped_rms(blk),blk=1,smax_cal_rows)
+ write(SPAREID,112) (scal_neg_ped_rms(blk),blk=smax_cal_rows+1,2*smax_cal_rows)
+ write(SPAREID,112) (scal_neg_ped_rms(blk),blk=2*smax_cal_rows+1,3*smax_cal_rows)
+ write(SPAREID,112) (scal_neg_ped_rms(blk),blk=3*smax_cal_rows+1,4*smax_cal_rows)
+ write(SPAREID,*) '; calorimeter threshold above ped. =MIN(50,MAX(10,3*sigma))'
+ write(SPAREID,*) 'scal_new_threshold_neg = '
+ write(SPAREID,112) (scal_new_adc_threshold_neg(blk),blk=1,smax_cal_rows)
+ write(SPAREID,112) (scal_new_adc_threshold_neg(blk),blk=smax_cal_rows+1,2*smax_cal_rows)
+ write(SPAREID,112) (scal_new_adc_threshold_neg(blk),blk=2*smax_cal_rows+1,3*smax_cal_rows)
+ write(SPAREID,112) (scal_new_adc_threshold_neg(blk),blk=3*smax_cal_rows+1,4*smax_cal_rows)
+***
+112 format (12(f5.1,','),f5.1)
+
+*
+* GAS CERENKOV PEDESTALS
+*
+ write(SPAREID,*) 'scer_ped = '
+ write(SPAREID,113) (scer_ped(pmt),pmt=1,smax_cer_hits)
+113 format (3(i6,','),i6)
+
+ close(SPAREID)
+
+ return
+ end
diff --git a/STRACKING/s_dump_tof.f b/STRACKING/s_dump_tof.f
new file mode 100644
index 0000000..04d3a0e
--- /dev/null
+++ b/STRACKING/s_dump_tof.f
@@ -0,0 +1,97 @@
+ SUBROUTINE S_DUMP_TOF(ABORT,errmsg)
+*--------------------------------------------------------
+*-
+*- Purpose and Methods : Analyze scintillator information for each track
+*-
+*- Required Input BANKS SOS_SCIN_TOF
+*- GEN_DATA_STRUCTURES
+*-
+*- Output: ABORT - success or failure
+*- : err - reason for failure, if any
+*-
+* author: John Arrington
+* created: 1/30/95
+*
+* s_dump_tof writes out the raw timing information for the final chosen tracks.
+* This data is analyzed by independent routines to fit the corrections for
+* pulse height walk, time lag from the hit to the pmt signal, and time offsets
+* for each signal.
+*
+* $Log: s_dump_tof.f,v $
+* Revision 1.7 1999/11/04 20:36:47 saw
+* Linux/G77 compatibility fixes
+*
+* Revision 1.6 1999/06/10 16:57:17 csa
+* (JRA) Added test on scer_npe_sum, changed output formats
+*
+* Revision 1.5 1999/02/10 18:20:40 csa
+* Fixed format problem with ph > 10,000
+*
+* Revision 1.4 1995/10/09 20:20:18 cdaq
+* (JRA) Subtract sstart_time from tdc output
+*
+* Revision 1.3 1995/05/22 19:45:36 cdaq
+* (SAW) Split gen_data_data_structures into gen, hms, sos, and coin parts"
+*
+* Revision 1.2 1995/05/11 21:03:28 cdaq
+* (JRA) Formatting changes
+*
+* Revision 1.1 1995/04/01 20:39:50 cdaq
+* Initial revision
+*
+*--------------------------------------------------------
+ IMPLICIT NONE
+*
+ character*50 here
+ parameter (here= 'S_DUMP_TOF')
+*
+ logical ABORT
+ character*(*) errmsg
+*
+ INCLUDE 'sos_data_structures.cmn'
+ INCLUDE 'gen_constants.par'
+ INCLUDE 'gen_units.par'
+ include 'sos_scin_parms.cmn'
+ include 'sos_scin_tof.cmn'
+ integer*4 hit, ind
+ integer*4 pmt,cnt,lay,dir
+ real*4 ph,tim,betap
+ save
+*
+* Write out TOF fitting data.
+*
+
+* In some circumstances you might also cut on
+* scer_npe_sum and/or ssshtrk:
+ if (ssnum_pmt_hit.ge.4 .and. ssnum_pmt_hit.le.12 .and. scer_npe_sum.gt.2) then
+ betap=1.
+ write(38,111) ssnum_pmt_hit,ssx_fp,ssxp_fp,
+ $ ssy_fp,ssyp_fp,betap
+111 format(i3,1x,f10.5,1x,f8.5,1x,f10.5,1x,f8.5,1x,f7.3)
+ do ind = 1, ssnum_scin_hit
+ hit = sscin_hit(ssnum_fptrack,ind)
+ if (sscin_tdc_pos(hit) .ge. sscin_tdc_min .and.
+ 1 sscin_tdc_pos(hit) .le. sscin_tdc_max) then
+ cnt=sscin_counter_num(hit)
+ lay=int((sscin_plane_num(hit)+1)/2)
+ dir=mod(sscin_plane_num(hit)+1,2)+1
+ pmt=1
+ tim=sscin_tdc_pos(hit)*sscin_tdc_to_time-sstart_time
+ ph=sscin_adc_pos(hit)
+ write(38,112) pmt,cnt,lay,dir,ph,tim
+ endif
+ if (sscin_tdc_neg(hit) .ge. sscin_tdc_min .and.
+ 1 sscin_tdc_neg(hit) .le. sscin_tdc_max) then
+ cnt=sscin_counter_num(hit)
+ lay=int((sscin_plane_num(hit)+1)/2)
+ dir=mod(sscin_plane_num(hit)+1,2)+1
+ pmt=2
+ tim=sscin_tdc_neg(hit)*sscin_tdc_to_time-sstart_time
+ ph=sscin_adc_neg(hit)
+ write(38,112) pmt,cnt,lay,dir,ph,tim
+ endif
+ enddo
+ 112 format(i2,1x,i3,2(1x,i2),1x,f7.1,1x,f8.3)
+ endif
+ RETURN
+ END
diff --git a/STRACKING/s_fcnchisq.f b/STRACKING/s_fcnchisq.f
new file mode 100644
index 0000000..d7c45cd
--- /dev/null
+++ b/STRACKING/s_fcnchisq.f
@@ -0,0 +1,46 @@
+ subroutine S_FCNCHISQ(npar,grad,fval,ray,iflag,dumarg)
+* This subroutine calculates chi**2 for MINUIT. The
+* arguments are determined by MINUIT
+*
+* d.f. geesaman 8 September 1993
+* modified dfg 14 Feb 1993 Change SPLANE_PARAM to
+* sdc_sigma
+* $Log: s_fcnchisq.f,v $
+* Revision 1.3 1995/05/22 19:45:37 cdaq
+* (SAW) Split gen_data_data_structures into gen, hms, sos, and coin parts"
+*
+* Revision 1.2 1994/11/22 21:11:17 cdaq
+* (SPB) Recopied from hms file and modified names for SOS
+*
+* Revision 1.1 1994/02/21 16:13:20 cdaq
+* Initial revision
+*
+*
+ implicit none
+ external S_DPSIFUN
+ real*8 S_DPSIFUN
+ include 'sos_data_structures.cmn'
+ include 'sos_tracking.cmn'
+ include 'sos_geometry.cmn'
+*
+* input
+ real*8 ray(*),grad(*),dumarg
+ integer*4 npar,iflag
+* output
+ real*8 fval ! value of chi2
+*
+* local variables
+ real*8 diff
+ integer*4 ihit
+ integer*4 hitnum,planenum
+
+ fval=0.0d0
+ do ihit=1,SNTRACK_HITS(strack_fit_num,1)
+ hitnum=SNTRACK_HITS(strack_fit_num,ihit+1)
+ planenum=SDC_PLANE_NUM(hitnum)
+ diff=(dble(SDC_WIRE_COORD(hitnum))-S_DPSIFUN(ray,planenum))
+ & /dble(sdc_sigma(planenum))
+ fval=fval+diff*diff
+ enddo
+ return
+ end
diff --git a/STRACKING/s_fill_cal_hist.f b/STRACKING/s_fill_cal_hist.f
new file mode 100644
index 0000000..e3937a4
--- /dev/null
+++ b/STRACKING/s_fill_cal_hist.f
@@ -0,0 +1,81 @@
+ subroutine s_fill_cal_hist(Abort,err)
+*
+* routine to fill histograms with sos_cal varibles
+*
+* Author: J. R. Arrington
+* Date: 26 April 1995
+* Copied from: s_fill_scin_raw_hist
+*
+*
+* $Log: s_fill_cal_hist.f,v $
+* Revision 1.10 2002/12/19 22:05:45 jones
+* sidcalposhits and sidcalneghits are integer*4 not logical
+* so sidcalposhits(col).gt.0 replaces sidcalposhits(col) in if statement
+*
+* Revision 1.9 2002/07/31 20:20:58 saw
+* Only try to fill user hists that are defined
+*
+* Revision 1.8 1999/02/23 18:58:02 csa
+* (JRA) Remove obsolete hf1 call
+*
+* Revision 1.7 1999/02/03 21:13:45 saw
+* Code for new Shower counter tubes
+*
+* Revision 1.6 1999/01/29 17:34:58 saw
+* Add variables for second tubes on shower counter
+*
+* Revision 1.5 1999/01/27 16:02:45 saw
+* Check if some hists are defined before filling
+*
+* Revision 1.4 1995/08/31 18:07:29 cdaq
+* (JRA) Move sidcalsumadc filling to s_sparsify_cal
+*
+* Revision 1.3 1995/07/20 14:49:57 cdaq
+* (JRA) Add calorimeter adc sum per hit histogram
+*
+* Revision 1.2 1995/05/22 19:45:37 cdaq
+* (SAW) Split gen_data_data_structures into gen, hms, sos, and coin parts"
+*
+* Revision 1.1 1995/04/27 20:40:22 cdaq
+* Initial revision
+*
+*--------------------------------------------------------
+ IMPLICIT NONE
+*
+ external thgetid
+ integer*4 thgetid
+ character*50 here
+ parameter (here= 's_fill_cal_hist')
+*
+ logical ABORT
+ character*(*) err
+ real*4 histval
+ integer*4 row,col,ihit
+ include 'sos_data_structures.cmn'
+ include 'sos_id_histid.cmn'
+ include 'sos_calorimeter.cmn'
+*
+ SAVE
+*--------------------------------------------------------
+*
+ ABORT= .FALSE.
+ err= ' '
+*
+* Light in either tube will do
+*
+ if(scal_num_hits .gt. 0 ) then
+ do ihit=1,scal_num_hits
+ row=scal_rows(ihit)
+ col=scal_cols(ihit)
+ histval=float(col)
+ if(sidcalplane.gt.0) call hf1(sidcalplane,histval,1.)
+ histval=float(row)
+ if(scal_adcs_pos(ihit).gt.0.1.and.sidcalposhits(col).gt.0)
+ $ call hf1(sidcalposhits(col),histval,1.)
+ if(scal_adcs_neg(ihit).gt.0.1.and.sidcalneghits(col).gt.0)
+ $ call hf1(sidcalneghits(col),histval,1.)
+ enddo
+ endif
+
+ return
+ end
diff --git a/STRACKING/s_fill_dc_dec_hist.f b/STRACKING/s_fill_dc_dec_hist.f
new file mode 100644
index 0000000..4b647b8
--- /dev/null
+++ b/STRACKING/s_fill_dc_dec_hist.f
@@ -0,0 +1,72 @@
+ subroutine s_fill_dc_dec_hist(Abort,err)
+*
+* routine to fill histograms with sos_decoded_dc varibles
+*
+* Author: D. F. Geesaman
+* Date: 30 March 1994
+* Modified: 9 April 1994 D. F. Geesaman
+* Put id's in sos_tracking_histid
+* implement flag to turn block off
+* $Log: s_fill_dc_dec_hist.f,v $
+* Revision 1.6 2002/07/31 20:20:58 saw
+* Only try to fill user hists that are defined
+*
+* Revision 1.5 1996/04/30 17:12:04 saw
+* (JRA) Comment out SDC_DRIFT_DIS and SDC_DRIFT_TIME histograms
+*
+* Revision 1.4 1995/08/31 18:42:28 cdaq
+* (JRA) Comment out filling of siddcwirecent (wire center) histogram
+*
+* Revision 1.3 1995/05/22 19:45:38 cdaq
+* (SAW) Split gen_data_data_structures into gen, hms, sos, and coin parts"
+*
+* Revision 1.2 1994/08/18 04:33:13 cdaq
+* (SAW) Indentation changes
+*
+* Revision 1.1 1994/04/13 18:10:22 cdaq
+* Initial revision
+*
+*--------------------------------------------------------
+ IMPLICIT NONE
+*
+ character*50 here
+ parameter (here= 's_fill_dc_dec_hist_')
+*
+ logical ABORT
+ character*(*) err
+ real*4 histval
+ integer*4 plane,ihit
+*
+ include 'sos_data_structures.cmn'
+ include 'sos_tracking.cmn'
+ include 'sos_track_histid.cmn'
+ include 'gen_event_info.cmn'
+*
+ SAVE
+*--------------------------------------------------------
+*
+ ABORT= .FALSE.
+ err= ' '
+*
+* Is histogramming flag set
+ if(sturnon_decoded_dc_hist.ne.0 ) then
+* Make sure there is at least 1 hit
+ if(SDC_TOT_HITS .gt. 0 ) then
+* Loop over all hits
+ do ihit=1,SDC_TOT_HITS
+ plane=SDC_PLANE_NUM(ihit)
+ histval=SDC_WIRE_NUM(ihit)
+* Is plane number valid
+ if( (plane .gt. 0) .and. (plane.le. sdc_num_planes)) then
+ if(siddcwiremap(plane).gt.0)
+ $ call hf1(siddcwiremap(plane),histval,1.)
+c call hf1(siddcwirecent(plane),SDC_WIRE_CENTER(ihit),1.)
+c call hf1(siddcdriftdis(plane),SDC_DRIFT_DIS(ihit),1.)
+c call hf1(siddcdrifttime(plane),SDC_DRIFT_TIME(ihit),1.)
+ endif ! end test on valid plane number
+ enddo ! end loop over hits
+ endif ! end test on zero hits
+ endif ! end test on histogram block turned on.
+ RETURN
+ END
+
diff --git a/STRACKING/s_fill_dc_fp_hist.f b/STRACKING/s_fill_dc_fp_hist.f
new file mode 100644
index 0000000..81cfd7a
--- /dev/null
+++ b/STRACKING/s_fill_dc_fp_hist.f
@@ -0,0 +1,93 @@
+ subroutine s_fill_dc_fp_hist(Abort,err)
+*
+* routine to fill histograms with sos_focal_plane varibles
+*
+* Author: D. F. Geesaman
+* Date: 30 March 1994
+* Modified: 9 April 1994 DFG
+* Transfer ID in common block
+* Implement flag to turn block on
+* $Log: s_fill_dc_fp_hist.f,v $
+* Revision 1.5 2002/07/31 20:20:58 saw
+* Only try to fill user hists that are defined
+*
+* Revision 1.4 1995/05/22 19:45:38 cdaq
+* (SAW) Split gen_data_data_structures into gen, hms, sos, and coin parts"
+*
+* Revision 1.3 1995/04/06 19:35:40 cdaq
+* (JRA) Add WC residual histograms
+*
+* Revision 1.2 1994/08/18 04:34:23 cdaq
+* (SAW) Indentation changes
+*
+* Revision 1.1 1994/04/13 18:10:39 cdaq
+* Initial revision
+*
+*--------------------------------------------------------
+ IMPLICIT NONE
+*
+ character*50 here
+ parameter (here= 's_fill_dc_fp_hist')
+*
+ logical ABORT
+ character*(*) err
+ real*4 histval
+ integer*4 itrk
+ integer*4 plane
+*
+ include 'sos_data_structures.cmn'
+ include 'sos_track_histid.cmn'
+ include 'sos_tracking.cmn'
+*
+ SAVE
+*--------------------------------------------------------
+*
+ ABORT= .FALSE.
+ err= ' '
+*
+* Is this histogram flag turned on
+ if(sturnon_focal_plane_hist .ne. 0 ) then
+* Make sure there is at least 1 track
+ if(SNTRACKS_FP .gt. 0 ) then
+* Loop over all hits
+ do itrk=1,SNTRACKS_FP
+ if(sidsx_fp.gt.0)
+ $ call hf1(sidsx_fp,SX_FP(itrk),1.)
+ if(sidsy_fp.gt.0)
+ $ call hf1(sidsy_fp,SY_FP(itrk),1.)
+ if(sidsxp_fp.gt.0)
+ $ call hf1(sidsxp_fp,SXP_FP(itrk),1.)
+ if(sidsyp_fp.gt.0)
+ $ call hf1(sidsyp_fp,SYP_FP(itrk),1.)
+ if(SCHI2_FP(itrk) .gt. 0 ) then
+ histval=log10(SCHI2_FP(itrk))
+ else
+ histval = 10.
+ endif
+ if(sidslogchi2_fp.gt.0)
+ $ call hf1(sidslogchi2_fp,histval,1.)
+ histval= SNFREE_FP(itrk)
+ if(sidsnfree_fp.gt.0)
+ $ call hf1(sidsnfree_fp,histval,1.)
+ if( SNFREE_FP(itrk) .ne.0) then
+ histval= SCHI2_FP(itrk) / SNFREE_FP(itrk)
+ else
+ histval = -1.
+ endif
+ if(sidschi2perdeg_fp.gt.0)
+ $ call hf1(sidschi2perdeg_fp,histval,1.)
+*
+ do plane = 1,sdc_num_planes
+ if(sidres_fp(plane).gt.0)
+ $ call hf1(sidres_fp(plane),
+ $ sdc_double_residual(itrk,plane),1.)
+ if(sidsingres_fp(plane).gt.0)
+ $ call hf1(sidsingres_fp(plane),
+ $ sdc_single_residual(itrk,plane),1.)
+ enddo
+
+ enddo ! end loop over hits
+ endif ! end test on zero hits
+ endif ! end test on histogramming flag
+ RETURN
+ END
diff --git a/STRACKING/s_fill_dc_target_hist.f b/STRACKING/s_fill_dc_target_hist.f
new file mode 100644
index 0000000..97b2682
--- /dev/null
+++ b/STRACKING/s_fill_dc_target_hist.f
@@ -0,0 +1,65 @@
+ subroutine s_fill_dc_target_hist(Abort,err)
+*
+* routine to fill histograms with SOS_TARGET varibles
+*
+* Author: D. F. Geesaman
+* Date: 3 May 1994
+* $Log: s_fill_dc_target_hist.f,v $
+* Revision 1.4 2002/07/31 20:20:58 saw
+* Only try to fill user hists that are defined
+*
+* Revision 1.3 1995/05/22 19:45:38 cdaq
+* (SAW) Split gen_data_data_structures into gen, hms, sos, and coin parts"
+*
+* Revision 1.2 1994/08/18 04:31:47 cdaq
+* (SAW) Indentation changes
+*
+* Revision 1.1 1994/05/13 03:04:19 cdaq
+* Initial revision
+*
+*-
+*--------------------------------------------------------
+ IMPLICIT NONE
+*
+ character*50 here
+ parameter (here= 's_fill_dc_target_hist')
+*
+ logical ABORT
+ character*(*) err
+ real*4 histval
+ integer*4 itrk
+
+*
+ include 'sos_data_structures.cmn'
+ include 'sos_track_histid.cmn'
+*
+ SAVE
+*--------------------------------------------------------
+*
+ ABORT= .FALSE.
+ err= ' '
+*
+* Make sure there is at least 1 track
+ if(SNTRACKS_FP .gt. 0 ) then
+* Loop over all hits
+ do itrk=1,SNTRACKS_FP
+ if (sidsx_tar.gt.0)
+ $ call hf1(sidsx_tar,SX_TAR(itrk),1.)
+ if (sidsy_tar.gt.0)
+ $ call hf1(sidsy_tar,SY_TAR(itrk),1.)
+ if (sidsz_tar.gt.0)
+ $ call hf1(sidsz_tar,SZ_TAR(itrk),1.)
+ if (sidsxp_tar.gt.0)
+ $ call hf1(sidsxp_tar,SXP_TAR(itrk),1.)
+ if (sidsyp_tar.gt.0)
+ $ call hf1(sidsyp_tar,SYP_TAR(itrk),1.)
+ if (sidsdelta_tar.gt.0)
+ $ call hf1(sidsdelta_tar,SDELTA_TAR(itrk),1.)
+ if (sidsp_tar.gt.0)
+ $ call hf1(sidsp_tar,SP_TAR(itrk),1.)
+*
+*
+ enddo ! end loop over hits
+ endif ! end test on zero hits
+ RETURN
+ END
diff --git a/STRACKING/s_fill_scin_raw_hist.f b/STRACKING/s_fill_scin_raw_hist.f
new file mode 100644
index 0000000..15cd8c5
--- /dev/null
+++ b/STRACKING/s_fill_scin_raw_hist.f
@@ -0,0 +1,119 @@
+ subroutine s_fill_scin_raw_hist(Abort,err)
+*
+* routine to fill histograms with sos_raw_scin varibles
+*
+* Author: D. F. Geesaman
+* Date: 4 April 1994
+*
+* Modified 9 April 1994 DFG
+* Add CTP flag to turn on histogramming
+* id's in sos_id_histid
+* $Log: s_fill_scin_raw_hist.f,v $
+* Revision 1.7 1996/01/17 19:04:54 cdaq
+* (JRA)
+*
+* Revision 1.6 1995/10/10 13:27:45 cdaq
+* (JRA) Remove some unneeded validity tests
+*
+* Revision 1.5 1995/07/20 14:52:20 cdaq
+* (JRA) Fill hist's from "all" data structures
+*
+* Revision 1.4 1995/05/22 19:45:39 cdaq
+* (SAW) Split gen_data_data_structures into gen, hms, sos, and coin parts"
+*
+* Revision 1.3 1995/05/11 21:04:14 cdaq
+* (JRA) Modifications to user histograms
+*
+* Revision 1.2 1995/02/10 19:11:36 cdaq
+* (JRA) Change sscin_num_counters to snum_scin_counters
+*
+* Revision 1.1 1994/04/13 20:07:48 cdaq
+* Initial revision
+*
+*--------------------------------------------------------
+ IMPLICIT NONE
+*
+ external thgetid
+ integer*4 thgetid
+ character*20 here
+ parameter (here='s_fill_scin_raw_hist')
+*
+ logical ABORT
+ character*(*) err
+ real*4 histval
+ real*4 rcnt
+ integer*4 pln,cnt,ihit
+ include 'sos_data_structures.cmn'
+ include 'sos_scin_parms.cmn'
+ include 'sos_id_histid.cmn'
+*
+ SAVE
+*--------------------------------------------------------
+*
+ ABORT= .FALSE.
+ err= ' '
+* Do we want to histogram raw scintillators
+
+* Make sure there is at least 1 hit
+ if(sscin_all_tot_hits .gt. 0 ) then
+* Loop over all hits
+ do ihit=1,sscin_all_tot_hits
+ pln=sscin_all_plane_num(ihit)
+ cnt=sscin_all_counter_num(ihit)
+ rcnt=float(cnt)
+* Fill plane map
+c histval = float(pln)
+c call hf1(sidscinplane,histval,1.)
+* Fill counter map
+ histval = rcnt
+ call hf1(sidscincounters(pln),histval,1.)
+* Fill ADC and TDC histograms for positive tubes.
+ if (sscin_all_tdc_pos(ihit).ne.-1) then !tube was hit.
+ histval = rcnt
+ call hf1(sidscinallpostdc(pln),histval,1.)
+ histval = float(sscin_all_tdc_pos(ihit))
+ call hf1(sidsumpostdc(pln),histval,1.)
+ else !tube was NOT hit.
+ histval = sscin_all_adc_pos(ihit)-sscin_all_ped_pos(pln,cnt)
+ call hf1(sidsumposadc(pln),histval,1.)
+ endif
+
+ if ((sscin_all_adc_pos(ihit)-sscin_all_ped_pos(pln,cnt))
+ $ .ge.50) then
+ histval = rcnt
+ call hf1(sidscinallposadc(pln),histval,1.)
+ endif
+
+* Fill ADC and TDC histograms for negative tubes.
+ if (sscin_all_tdc_neg(ihit).ne.-1) then !tube was hit.
+ histval = rcnt
+ call hf1(sidscinallnegtdc(pln),histval,1.)
+ histval = float(sscin_all_tdc_neg(ihit))
+ call hf1(sidsumnegtdc(pln),histval,1.)
+ else !tube was NOT hit.
+ histval = sscin_all_adc_neg(ihit)-sscin_all_ped_neg(pln,cnt)
+ call hf1(sidsumnegadc(pln),histval,1.)
+ endif
+
+ if ((sscin_all_adc_neg(ihit)-sscin_all_ped_neg(pln,cnt))
+ $ .ge.50) then
+ histval = rcnt
+ call hf1(sidscinallnegadc(pln),histval,1.)
+ endif
+
+
+ if(sturnon_scin_raw_hist .ne. 0 ) then
+ histval = sscin_all_adc_pos(ihit)-sscin_all_ped_pos(pln,cnt)
+ call hf1(sidscinposadc(pln,cnt),histval,1.)
+ histval = sscin_all_adc_neg(ihit)-sscin_all_ped_neg(pln,cnt)
+ call hf1(sidscinnegadc(pln,cnt),histval,1.)
+ histval = float(sscin_all_tdc_pos(ihit))
+ call hf1(sidscinpostdc(pln,cnt),histval,1.)
+ histval = float(sscin_all_tdc_neg(ihit))
+ call hf1(sidscinnegtdc(pln,cnt),histval,1.)
+ endif ! end test on histogramming flag
+ enddo ! end loop over hits
+ endif ! end test on zero hits
+
+ return
+ end
diff --git a/STRACKING/s_find_best_stub.f b/STRACKING/s_find_best_stub.f
new file mode 100644
index 0000000..c4301b9
--- /dev/null
+++ b/STRACKING/s_find_best_stub.f
@@ -0,0 +1,90 @@
+ subroutine s_find_best_stub(numhits,hits,pl,pindex,plusminus,stub,chi2)
+* This subroutine does a linear least squares fit of a line to the
+* hits in an individual chamber. It assumes that the y slope is 0
+* The wire coordinate is calculated
+* from the wire center + plusminus*(drift distance).
+* This is called in a loop over all combinations of plusminus
+*
+* d. f. geesaman
+* $Log: s_find_best_stub.f,v $
+* Revision 1.5 1996/01/17 19:05:23 cdaq
+* (JRA)
+*
+* Revision 1.4 1995/10/10 13:39:56 cdaq
+* (JRA) Cleanup
+*
+* Revision 1.3 1995/05/22 19:45:39 cdaq
+* (SAW) Split gen_data_data_structures into gen, hms, sos, and coin parts"
+*
+* Revision 1.2 1994/11/22 21:11:50 cdaq
+* (SPB) Recopied from hms file and modified names for SOS
+*
+* Revision 1.1 1994/02/21 16:13:42 cdaq
+* Initial revision
+*
+*
+* the four parameters of a stub are x_t,y_t,xp_t,yp_t
+*
+* Called by S_LEFT_RIGHT
+*
+ implicit none
+ include 'sos_data_structures.cmn'
+ include 'sos_tracking.cmn'
+ include 'sos_geometry.cmn'
+* input quantities
+ integer*4 numhits
+ integer*4 hits(*)
+ real*4 plusminus(*)
+*
+* output quantitites
+ real*8 dstub(3) ! x, xp , y of local line fit
+ real*4 stub(4)
+ real*4 chi2 ! chi2 of fit
+*
+* local variables
+ real*4 dpos(smax_hits_per_point)
+ integer*4 pl(smax_hits_per_point)
+ integer*4 pindex
+ real*8 TT(3)
+ integer*4 hit
+ integer*4 i
+
+ TT(1)=0.
+ TT(2)=0.
+ TT(3)=0.
+
+* calculate trail hit position and least squares matrix coefficients.
+ do hit=1,numhits
+ dpos(hit)=SDC_WIRE_CENTER(hits(hit)) +
+ & plusminus(hit)*SDC_DRIFT_DIS(hits(hit)) -
+ & spsi0(pl(hit))
+ do i=1,3
+ TT(i)=TT(i)+(dpos(hit)*sstubcoef(pl(hit),i))/sdc_sigma(pl(hit))
+ enddo
+ enddo
+*
+* solve three by three equations
+ccc call s_solve_3by3(TT,pindex,dstub,ierr)
+
+ dstub(1)=SAAINV3(1,1,pindex)*TT(1) + SAAINV3(1,2,pindex)*TT(2) +
+ & SAAINV3(1,3,pindex)*TT(3)
+ dstub(2)=SAAINV3(1,2,pindex)*TT(1) + SAAINV3(2,2,pindex)*TT(2) +
+ & SAAINV3(2,3,pindex)*TT(3)
+ dstub(3)=SAAINV3(1,3,pindex)*TT(1) + SAAINV3(2,3,pindex)*TT(2) +
+ & SAAINV3(3,3,pindex)*TT(3)
+
+*
+* calculate chi2. Remember one power of sigma is in sstubcoef
+ chi2=0.
+ stub(1)=dstub(1)
+ stub(2)=dstub(2)
+ stub(3)=dstub(3)
+ stub(4)=0.
+ do hit=1,numhits
+ chi2=chi2+(dpos(hit)/sdc_sigma(pl(hit))
+ & -sstubcoef(pl(hit),1)*stub(1)
+ & -sstubcoef(pl(hit),2)*stub(2)
+ & -sstubcoef(pl(hit),3)*stub(3) )**2
+ enddo
+ return
+ end
diff --git a/STRACKING/s_find_easy_space_point.f b/STRACKING/s_find_easy_space_point.f
new file mode 100644
index 0000000..82ae2ca
--- /dev/null
+++ b/STRACKING/s_find_easy_space_point.f
@@ -0,0 +1,84 @@
+ subroutine s_find_easy_space_point(ncham_hits,
+ & hit_num, wire_center, ipln,space_point_criterion,
+ & nspace_point_len,
+ & x_hit,xp_hit,easy_space_point,
+ & nspace_points,space_points,space_point_hits)
+*
+* $Log: s_find_easy_space_point.f,v $
+* Revision 1.1 1995/10/26 14:18:53 cdaq
+* Initial revision
+*
+* Simplified SOS find_space_point routine. It is given all x hits, and checks
+* to see if all y-like hits are close enough together to make a space point.
+*
+ implicit none
+*
+ INCLUDE 'sos_data_structures.cmn'
+ INCLUDE 'gen_constants.par'
+ INCLUDE 'gen_units.par'
+ INCLUDE 'sos_tracking.cmn'
+ INCLUDE 'sos_geometry.cmn'
+
+* input
+ integer*4 ncham_hits ! total number of hits in chamber
+ integer*4 hit_num(*) ! array of hit numbers
+ integer*4 ipln(*) ! array of plane numbers for each hit
+ real*4 wire_center(*) ! array of wire coordinates for hits
+ real*4 space_point_criterion ! squared distance limit for points
+ integer*4 nspace_point_len ! dimension of space point arrays
+ integer*4 x_hit,xp_hit ! hit # of x and x' planes
+ logical easy_space_point
+*
+* outputs
+ integer*4 nspace_points ! number of space points in chamber
+ real*4 space_points(nspace_point_len,2) ! xt, yt of each space point
+ integer*4 space_point_hits(nspace_point_len,*)
+* ! hit numbers for each space point
+* internal Variables,
+ integer*4 k
+ integer*4 num_yhits
+ real*4 xt,yt
+ real*4 y_pos(smax_hits_per_point)
+ real*4 max_dist
+*
+*
+ xt=(wire_center(x_hit)+wire_center(xp_hit))/2
+ yt=0.
+ num_yhits=0
+ nspace_points = 0
+ max_dist = sqrt(space_point_criterion/2)
+*
+
+* loop over all hits, find y of space point.
+ do k = 1, ncham_hits
+ if (k.ne.x_hit .and. k.ne.xp_hit) then !y-like hits
+ y_pos(k) = ( wire_center(k)-xt*sxsp(ipln(k)) )/sysp(ipln(k))
+ yt = yt + y_pos(k)
+ num_yhits = num_yhits + 1
+ else
+ y_pos(k) = 0.
+ endif
+ enddo
+ yt = yt / float(max(1,num_yhits))
+
+ easy_space_point = .true.
+ do k = 1, ncham_hits
+ if (k.ne.x_hit .and. k.ne.xp_hit) then
+ if (abs(yt-y_pos(k)).ge.max_dist) easy_space_point=.false.
+ endif
+ enddo
+
+* If easy_space_point is true, all hits were on the space points.
+ if (easy_space_point) then
+ nspace_points = 1
+ space_point_hits(1,1) = ncham_hits
+ space_point_hits(1,2) = 0 !no combos.
+ do k = 1, ncham_hits
+ space_point_hits(1,k+2) = hit_num(k)
+ enddo
+ space_points(1,1)=xt
+ space_points(1,2)=yt
+ endif
+
+ return
+ end
diff --git a/STRACKING/s_generate_geometry.f b/STRACKING/s_generate_geometry.f
new file mode 100644
index 0000000..754649f
--- /dev/null
+++ b/STRACKING/s_generate_geometry.f
@@ -0,0 +1,273 @@
+ subroutine s_generate_geometry
+*
+* This subroutine reads in the wire plane parameters and fills all the
+* geometrical constants used in Track Fitting for the SOS spectrometer
+* The constants are stored in sos_geometry.cmn
+*
+* d.f. geesaman 2 Sept 1993
+* modified 14 feb 1994 for CTP input.
+* Change SPLANE_PARAM to individual arrays
+* $Log: s_generate_geometry.f,v $
+* Revision 1.7 1996/09/05 13:30:18 saw
+* (JRA) Format statement changes
+*
+* Revision 1.6 1996/04/30 17:13:09 saw
+* (JRA) Set up card drift time delay structures
+*
+* Revision 1.5 1995/10/10 14:21:21 cdaq
+* (JRA) Calculate wire velocity correction parameters. Cosmetics and comments
+*
+* Revision 1.4 1995/05/22 19:45:40 cdaq
+* (SAW) Split gen_data_data_structures into gen, hms, sos, and coin parts"
+*
+* Revision 1.3 1995/04/01 20:42:06 cdaq
+* (SAW) Use sdc_planes_per_chamber instead of (sdc_num_planes/sdc_num_chambers)
+*
+* Revision 1.2 1994/11/22 20:19:22 cdaq
+* (SPB) Recopied from hms file and modified names for SOS
+* (SAW) Remove hardwired plane and chamber counts.
+*
+* Revision 1.1 1994/02/21 16:14:17 cdaq
+* Initial revision
+*
+*
+ implicit none
+ include "sos_data_structures.cmn"
+ include "sos_tracking.cmn"
+ include "sos_geometry.cmn"
+*
+* local variables
+ logical missing_card_no
+ integer*4 pln,i,j,k,pindex,ich
+ real*4 cosalpha,sinalpha,cosbeta,sinbeta,cosgamma,singamma,z0
+ real*4 stubxchi,stubxpsi,stubychi,stubypsi
+ real*4 sumsqupsi,sumsquchi,sumcross,denom
+*
+* read basic parameters from CTP input file
+* sdc_zpos(pln) = Z0
+* sdc_alpha_angle(pln) = ALPHA
+* sdc_beta_angle(pln) = BETA
+* sdc_gamma_angle(pln) = GAMMA
+* sdc_pitch(pln) = Wire spacing
+* sdc_nrwire(pln) = Number of wires
+* sdc_central_wire(pln) = Location of center of wire 1
+* sdc_sigma(pln) = sigma
+*
+ sdc_planes_per_chamber = sdc_num_planes / sdc_num_chambers
+
+ missing_card_no = .false.
+ do j=1,smax_num_dc_planes
+ do i=1,sdc_max_wires_per_plane
+ if (sdc_card_no(i,j).eq.0) then
+ write(6,*) 'card number = 0 for wire,plane=',i,j
+ missing_card_no = .true.
+ sdc_card_no(i,j)=1 !avoid 0 in array index
+ sdc_card_delay(1)=0 !no delay for wires
+ endif
+ enddo
+ enddo
+ if (missing_card_no) write(6,*) 'missing sdc_card_no(IGNORE THIS-JRA)'
+*
+* loop over all planes
+*
+ do pln=1,sdc_num_planes
+ sdc_plane_num(pln)=pln
+ z0=sdc_zpos(pln)
+ cosalpha = cos(sdc_alpha_angle(pln))
+ sinalpha = sin(sdc_alpha_angle(pln))
+ cosbeta = cos(sdc_beta_angle(pln))
+ sinbeta = sin(sdc_beta_angle(pln))
+ cosgamma = cos(sdc_gamma_angle(pln))
+ singamma = sin(sdc_gamma_angle(pln))
+*
+ ssinbeta(pln) = sinbeta
+ scosbeta(pln) = cosbeta
+* make sure cosbeta is not zero
+ if(abs(cosbeta).lt.1e-10) then
+ write(sluno,'('' unphysical beta rotation in sos plane'',i4,
+ & '' beta='',f10.5)') pln,sdc_beta_angle(pln)
+ endif
+ stanbeta(pln) = sinbeta / cosbeta
+*
+* compute chi,psi to x,y,z transformation coefficient(comments are beta=gamma=0)
+ szchi(pln) = -cosalpha*sinbeta + sinalpha*cosbeta*singamma ! =0.
+ szpsi(pln) = sinalpha*sinbeta + cosalpha*cosbeta*singamma ! =0.
+ sxchi(pln) = -cosalpha*cosbeta - sinalpha*sinbeta*singamma !-cos(a)
+ sxpsi(pln) = sinalpha*cosbeta - cosalpha*sinbeta*singamma ! sin(a)
+ sychi(pln) = sinalpha*cosgamma ! sin(a)
+ sypsi(pln) = cosalpha*cosgamma ! cos(a)
+*
+* stub transformations are done in beta=gamma=0 system
+ stubxchi = -cosalpha !-cos(a)
+ stubxpsi = sinalpha ! sin(a)
+ stubychi = sinalpha ! sin(a)
+ stubypsi = cosalpha ! cos(a)
+
+* parameters for wire propogation correction. dt=distance from centerline of
+* chamber = ( xcoeff*x + ycoeff*y )*corr / veloc.
+ if (cosalpha .le. 0.707) then !x-like wire, need dist. from x=0 line
+ sdc_readout_x(pln) = .true.
+ sdc_readout_corr(pln) = 1./sinalpha
+ else !y-like wire, need dist. from y=0 line
+ sdc_readout_x(pln) = .false.
+ sdc_readout_corr(pln) = 1./cosalpha
+ endif
+*
+* fill spsi0,schi0,sz0 used in stub fit
+*
+ sumsqupsi = szpsi(pln)**2 + sxpsi(pln)**2 + sypsi(pln)**2 ! =1.
+ sumsquchi = szchi(pln)**2 + sxchi(pln)**2 + sychi(pln)**2 ! =1.
+ sumcross = szpsi(pln)*szchi(pln) + sxpsi(pln)*sxchi(pln)
+ & + sypsi(pln)*sychi(pln) ! =0.
+ denom = sumsqupsi*sumsquchi-sumcross**2 ! =1.
+ spsi0(pln) = (-z0*szpsi(pln)*sumsquchi ! =0.
+ & +z0*szchi(pln)*sumcross) / denom
+ schi0(pln) = (-z0*szchi(pln)*sumsqupsi ! =0.
+ & +z0*szpsi(pln)*sumcross) / denom
+* calculate magnitude of sphi0 ! =z0
+ sphi0(pln) = sqrt(
+ & (z0+szpsi(pln)*spsi0(pln)+szchi(pln)*schi0(pln))**2
+ & + (sxpsi(pln)*spsi0(pln)+sxchi(pln)*schi0(pln))**2
+ & + (sypsi(pln)*spsi0(pln)+sychi(pln)*schi0(pln))**2 )
+ if(z0.lt.0) sphi0(pln)=-sphi0(pln)
+*
+* sstubcoef used in stub fits. check these. I don't think they are correct
+ denom = stubxpsi*stubychi - stubxchi*stubypsi ! =1.
+ sstubcoef(pln,1)= stubychi/(sdc_sigma(pln)*denom) !sin(a)/sigma
+ sstubcoef(pln,2)= -stubxchi/(sdc_sigma(pln)*denom) !cos(a)/sigma
+ sstubcoef(pln,3)= sphi0(pln)*sstubcoef(pln,1) !z0*sin(a)/sig
+ sstubcoef(pln,4)= sphi0(pln)*sstubcoef(pln,2) !z0*cos(a)/sig
+*
+* xsp and ysp used in space point pattern recognition
+*
+ sxsp(pln) = sychi(pln) / denom !sin(a)
+ sysp(pln) = -sxchi(pln) / denom !cos(a)
+*
+* compute track fitting coefficients
+*
+ splane_coeff(1,pln)= szchi(pln) ! =0.
+ splane_coeff(2,pln)=-szchi(pln) ! =0.
+ splane_coeff(3,pln)= sychi(pln)*(sdc_zpos(pln)-slocrayzt) !sin(a)*(z-slocrayzt)
+ splane_coeff(4,pln)= sxchi(pln)*(slocrayzt-sdc_zpos(pln)) !cos(a)*(z-slocrayzt)
+ splane_coeff(5,pln)= sychi(pln) !sin(a)
+ splane_coeff(6,pln)=-sxchi(pln) !cos(a)
+ splane_coeff(7,pln)= szchi(pln)*sypsi(pln) - sychi(pln)*szpsi(pln) !0.
+ splane_coeff(8,pln)=-szchi(pln)*sxpsi(pln) + sxchi(pln)*szpsi(pln) !0.
+ splane_coeff(9,pln)= sychi(pln)*sxpsi(pln) - sxchi(pln)*sypsi(pln) !1.
+*
+ enddo ! end loop over all planes
+
+* djm 10/2/94 generate/store the inverse matrices SAAINV3(i,j,pindex) used in solve_3by3_hdc
+* pindex = 1 plane 1 missing from sdc1
+* pindex = 2 plane 2 missing from sdc1
+* etc.
+* pindex = 7 plane 1 missing from sdc2
+* pindex = 8 plane 2 missing from sdc2
+* etc.
+* pindex = 13 sdc1 no missing planes
+* pindex = 14 sdc2 no missing planes
+
+*
+* The following is pretty gross, but might actually work for an
+* arbitrary number of chambers if each chamber has the same number of
+* planes and sdc_num_planes is SDC_NUM_CHAMBERS * # of planes/chamber
+*
+ do pindex=1,sdc_num_planes+SDC_NUM_CHAMBERS
+
+* generate the matrix SAA3 for an sdc missing a particular plane
+ do i=1,3
+ do j=1,3
+ SAA3(i,j)=0.
+ if(j.lt.i)then ! SAA3 is symmetric so only calculate 6 terms
+ SAA3(i,j)=SAA3(j,i)
+ else
+ if(pindex.le.sdc_num_planes) then
+ ich = (pindex-1)/(sdc_planes_per_chamber)+1
+ do k=(ich-1)*(sdc_planes_per_chamber)+1
+ $ ,ich*(sdc_planes_per_chamber)
+ if(pindex.ne.k) then
+ SAA3(i,j)=SAA3(i,j) + sstubcoef(k,i)*sstubcoef(k,j)
+ endif
+ enddo
+ else
+ ich = pindex - sdc_num_planes
+ do k=(ich-1)*(sdc_planes_per_chamber)+1
+ $ ,ich*(sdc_planes_per_chamber)
+ SAA3(i,j)=SAA3(i,j) + sstubcoef(k,i)*sstubcoef(k,j)
+ enddo
+ endif
+ endif !end test j lt i
+ enddo !end j loop
+ enddo !end i loop
+
+* form the inverse matrix SAAINV3 for each configuration
+ SAAINV3(1,1,pindex)=(SAA3(2,2)*SAA3(3,3)-SAA3(2,3)**2)
+ SAAINV3(1,2,pindex)=-(SAA3(1,2)*SAA3(3,3)-SAA3(1,3)*SAA3(2,3))
+ SAAINV3(1,3,pindex)=(SAA3(1,2)*SAA3(2,3)-SAA3(1,3)*SAA3(2,2))
+ SDET3(pindex)=SAA3(1,1)*SAAINV3(1,1,pindex)+SAA3(1,2)*SAAINV3(1,2
+ $ ,pindex)+SAA3(1,3)*SAAINV3(1,3,pindex)
+ if(abs(sdet3(pindex)).le.1e-20)then
+ write(6,*
+ $ )'******************************************************'
+ write(6,*
+ $ )'Warning! Determinate of matrix SAA3(i,j) is nearly zero.'
+ write(6,*)'All tracks using pindex=',pindex,' will be zerfucked.'
+ write(6,*)'Fix problem in h_generate_geometry.f or else!'
+ write(6,*
+ $ )'******************************************************'
+ sdet3(pindex)=1.
+ endif
+ SAAINV3(1,1,pindex)=SAAINV3(1,1,pindex)/SDET3(pindex)
+ SAAINV3(1,2,pindex)=SAAINV3(1,2,pindex)/SDET3(pindex)
+ SAAINV3(1,3,pindex)=SAAINV3(1,3,pindex)/SDET3(pindex)
+ SAAINV3(2,2,pindex)=(SAA3(1,1)*SAA3(3,3)-SAA3(1,3)**2)/SDET3(pindex
+ $ )
+ SAAINV3(2,3,pindex)= -(SAA3(1,1)*SAA3(2,3)-SAA3(1,2)*SAA3(3,1))
+ $ /SDET3(pindex)
+ SAAINV3(3,3,pindex)=(SAA3(1,1)*SAA3(2,2)-SAA3(1,2)**2)/SDET3(pindex
+ $ )
+
+ enddo !end pindex loop
+
+* for debug write out all parameters
+ if(sdebugflaggeometry.ne.0) then
+ write(sluno,'('' SOS PLANE PARAMETERS: '')')
+ write(sluno,'('' plane z0 alpha beta gamma wire ''
+ & '' number center resolution'')')
+ write(sluno,'('' number spacing ''
+ & '' wires position'')')
+ write(sluno,1000) (sdc_plane_num(j),
+ & sdc_zpos(j),
+ & sdc_alpha_angle(j),
+ & sdc_beta_angle(j),
+ & sdc_gamma_angle(j),
+ & sdc_pitch(j),
+ & sdc_nrwire(j),
+ & sdc_central_wire(j),
+ & sdc_sigma(j),j=1,sdc_num_planes)
+1000 format(1x,i4,f9.4,3f10.6,f8.4,i6,f10.4,f10.6)
+ write(sluno,'('' plane'',
+ & '' szchi szpsi sxchi sxpsi sychi sypsi'')')
+ write(sluno,1001) (i, szchi(i),szpsi(i),sxchi(i),sxpsi(i),sychi(i),
+ & sypsi(i),i=1,sdc_num_planes )
+1001 format(i5,6f10.6)
+ write(sluno,'(''plane'',
+ & '' spsi0 schi0 sphi0'')')
+ write(sluno,1002) (i, spsi0(i),schi0(i),sphi0(i),i=1,sdc_num_planes)
+1002 format(i5,3f12.6)
+ write(sluno,'('' plane'',
+ & '' sstubcoef 1 2 3 4'')')
+ write(sluno,1003) (i, sstubcoef(i,1),sstubcoef(i,2),sstubcoef(i,3),
+ & sstubcoef(i,4),i=1,sdc_num_planes)
+1003 format(i5,4f15.6)
+ write(sluno,'('' splane_coeff'')')
+ write(sluno,'('' plane 1 2 3 4 5'',
+ & '' 6 7 8 9'')')
+ do j=1,sdc_num_planes
+ write(sluno,1004) j,(splane_coeff(i,j),i=1,9)
+ enddo ! end of print over planes loop
+1004 format(1x,i3,f10.5,2f8.3,f9.3,4f8.3,f9.3)
+*
+ endif ! end if on debug print out
+ return
+ end
diff --git a/STRACKING/s_init_cal.f b/STRACKING/s_init_cal.f
new file mode 100644
index 0000000..c09a1e2
--- /dev/null
+++ b/STRACKING/s_init_cal.f
@@ -0,0 +1,79 @@
+*=======================================================================
+ subroutine s_init_cal(abort,errmsg)
+*=======================================================================
+*-
+*- Purpose: SOS Calorimeter Initialization
+*-
+*- Created: 20 Mar 1994 Tsolak A. Amatuni
+* $Log: s_init_cal.f,v $
+* Revision 1.3 1995/05/22 19:45:40 cdaq
+* (SAW) Split gen_data_data_structures into gen, hms, sos, and coin parts"
+*
+* Revision 1.2 1994/06/14 04:30:27 cdaq
+* (DFG) Remove hardwired parameters
+*
+* Revision 1.1 1994/04/13 18:18:40 cdaq
+* Initial revision
+*
+*-----------------------------------------------------------------------
+*
+*
+ implicit none
+ save
+*
+ logical abort
+ character*(*) errmsg
+ character*10 here
+ parameter (here='S_INIT_CAL')
+*
+ integer*4 block !Block number
+ integer*4 row !Row number
+ integer*4 column !Column number
+*
+ include 'sos_data_structures.cmn'
+ include 'sos_calorimeter.cmn'
+*
+*-----Initialize the positions
+ do column=1,smax_cal_columns
+ do row=1,smax_cal_rows
+ block=row+smax_cal_rows*(column-1)
+*
+ if(column.eq.1) then
+ scal_block_xc(block)=scal_1pr_top(row)+0.5*scal_1pr_thick
+ scal_block_yc(block)=0.5*(scal_1pr_left+scal_1pr_right)
+ scal_block_zc(block)=scal_1pr_zpos+0.5*scal_1pr_thick
+ else if(column.eq.2) then
+ scal_block_xc(block)=scal_2ta_top(row)+0.5*scal_2ta_thick
+ scal_block_yc(block)=0.5*(scal_2ta_left+scal_2ta_right)
+ scal_block_zc(block)=scal_2ta_zpos+0.5*scal_2ta_thick
+ else if(column.eq.3) then
+ scal_block_xc(block)=scal_3ta_top(row)+0.5*scal_3ta_thick
+ scal_block_yc(block)=0.5*(scal_3ta_left+scal_3ta_right)
+ scal_block_zc(block)=scal_3ta_zpos+0.5*scal_3ta_thick
+ else
+ scal_block_xc(block)=scal_4ta_top(row)+0.5*scal_4ta_thick
+ scal_block_yc(block)=0.5*(scal_4ta_left+scal_4ta_right)
+ scal_block_zc(block)=scal_4ta_zpos+0.5*scal_4ta_thick
+ endif
+ enddo !End loop over rows
+ enddo !End loop over columns
+*
+*
+ scal_block_xsize= scal_4ta_top(2) - scal_4ta_top(1)
+ scal_block_ysize= scal_4ta_left - scal_4ta_right
+ scal_block_zsize= scal_4ta_thick
+ scal_xmax= scal_4ta_top(scal_4ta_nr) + scal_block_xsize
+ scal_xmin= scal_4ta_top(1)
+ scal_ymax= scal_4ta_left
+ scal_ymin= scal_4ta_right
+ scal_zmin= scal_1pr_zpos
+ scal_zmax= scal_4ta_zpos
+ scal_fv_xmin=scal_xmin+5.
+ scal_fv_xmax=scal_xmax-5.
+ scal_fv_ymin=scal_ymin+5.
+ scal_fv_ymax=scal_ymax-5.
+ scal_fv_zmin=scal_zmin
+ scal_fv_zmax=scal_zmax
+*
+ return
+ end
diff --git a/STRACKING/s_init_cer.f b/STRACKING/s_init_cer.f
new file mode 100644
index 0000000..96babc7
--- /dev/null
+++ b/STRACKING/s_init_cer.f
@@ -0,0 +1,35 @@
+
+ subroutine s_init_cer(ABORT,err)
+
+*-------------------------------------------------------------------
+*
+* author: Chris Cothran
+* created: 5/25/95
+*
+* s_init_cer initializes parameters relevant to the SOS Cerenkov.
+* $Log: s_init_cer.f,v $
+* Revision 1.1 1995/08/31 15:05:05 cdaq
+* Initial revision
+*
+*-------------------------------------------------------------------
+
+ implicit none
+
+ include 'sos_cer_parms.cmn'
+
+ logical abort
+ character*(*) err
+ character*20 here
+ parameter (here='s_init_cer')
+
+ integer*4 ii
+
+ save
+
+ do ii = 1, scer_num_regions
+ scer_track_counter(ii) = 0
+ scer_fired_counter(ii) = 0
+ enddo
+
+ return
+ end
diff --git a/STRACKING/s_init_histid.f b/STRACKING/s_init_histid.f
new file mode 100644
index 0000000..2fded07
--- /dev/null
+++ b/STRACKING/s_init_histid.f
@@ -0,0 +1,240 @@
+ subroutine s_init_histid(Abort,err)
+*
+* routine to get HBOOK histogram ID numbers for all hard coded
+* histograms.
+*
+* Author: D. F. Geesaman
+* Date: 9 April 1994
+*
+* $Log: s_init_histid.f,v $
+* Revision 1.7 1999/02/23 18:58:40 csa
+* (JRA) Add pos/neg cal stuff
+*
+* Revision 1.6 1999/02/03 21:13:45 saw
+* Code for new Shower counter tubes
+*
+* Revision 1.5 1996/09/05 19:53:39 saw
+* (JRA) Get id for misc. TDC's
+*
+* Revision 1.4 1996/01/17 19:02:45 cdaq
+* (JRA) Add sidcuttdc, sidscinalltimes, and sidscintimes
+*
+* Revision 1.3 1995/08/31 18:43:01 cdaq
+* (JRA) Add dpos (pos. track - pos. hit) histograms
+*
+* Revision 1.2 1995/07/20 18:57:12 cdaq
+* (JRA) Add per hit adc/tdc sums for hodo and calormeter
+* (SAW) Relocate data statements for f2c compatibility
+*
+* Revision 1.1 1995/05/22 18:32:10 cdaq
+* Initial revision
+*
+* Revision 1.6 1995/05/12 12:23:22 cdaq
+* (JRA) Modify/add user histograms
+*
+* Revision 1.5 1995/04/06 20:33:34 cdaq
+* (SAW) Fix SOS wc plane names. Add SOS residuals histogram id's
+*
+c Revision 1.4 1995/03/14 21:01:18 cdaq
+c (SAW) Change ?scin_num_counters to ?num_scin_counters
+c
+c Revision 1.3 1994/08/18 03:13:51 cdaq
+c (SAW) Use arrays of histids for residuals, new names for residuals histos
+c
+c Revision 1.2 1994/05/12 18:59:14 cdaq
+c (DFG) Add hms_target and sos_target histid
+c
+c Revision 1.1 1994/05/12 18:56:22 cdaq
+c Initial revision
+c
+* Revision 1.1 1994/04/12 21:00:57 cdaq
+* Initial revision
+*
+*-
+*--------------------------------------------------------
+ IMPLICIT NONE
+*
+ character*13 here
+ parameter (here= 's_init_histid')
+*
+ logical ABORT
+ character*(*) err
+ external thgetid
+ integer*4 thgetid
+ integer*4 plane,counter
+*
+ include 'sos_data_structures.cmn'
+ include 'sos_tracking.cmn'
+ include 'sos_track_histid.cmn'
+ include 'sos_scin_parms.cmn'
+ include 'sos_id_histid.cmn'
+
+ character*32 histname
+ character*8 wiremap
+ character*10 drifttime
+ character*9 driftdis
+ character*9 wirecent
+ character*9 residual
+ character*9 singres
+ character*6 posadc,negadc,postdc,negtdc
+ character*6 sdcplanename(smax_num_dc_planes)
+ character*1 sscinplanenum(SNUM_SCIN_PLANES)
+ character*10 sscinplane
+ character*7 sposadc,snegadc,spostdc,snegtdc
+ character*7 sscinplanename(SNUM_SCIN_PLANES)
+
+ data wiremap/'_wiremap'/
+ data drifttime/'_drifttime'/
+ data driftdis /'_driftdis'/
+ data wirecent/'_wirecent'/
+ data residual/'_residual'/
+ data singres/'_sing_res'/
+ data posadc /'posadc'/
+ data negadc /'negadc'/
+ data postdc /'postdc'/
+ data negtdc /'negtdc'/
+ data sdcplanename/'sdc1u1','sdc1u2','sdc1x1','sdc1x2','sdc1v1'
+ $ ,'sdc1v2','sdc2u1','sdc2u2','sdc2x1','sdc2x2','sdc2v1','sdc2v2'/
+ data sscinplanenum/'1','2','3','4'/
+ data sscinplane /'sscinplane'/
+ data sposadc /'sposadc'/
+ data snegadc /'snegadc'/
+ data spostdc /'spostdc'/
+ data snegtdc /'snegtdc'/
+ data sscinplanename/'sscin1x','sscin1y','sscin2x','sscin2y'/
+*
+ SAVE
+*--------------------------------------------------------
+*
+ ABORT= .FALSE.
+ err= ' '
+*
+* Histogram block sos_target
+*
+ sidsx_tar = thgetid('sx_tar')
+ sidsy_tar = thgetid('sy_tar')
+ sidsz_tar = thgetid('sz_tar')
+ sidsxp_tar = thgetid('sxp_tar')
+ sidsyp_tar = thgetid('syp_tar')
+ sidsdelta_tar = thgetid('sdelta_tar')
+ sidsp_tar = thgetid('sp_tar')
+
+*
+* histogram block sos_focal_plane
+
+ sidsx_fp = thgetid('sx_fp')
+ sidsy_fp = thgetid('sy_fp')
+ sidsxp_fp = thgetid('sxp_fp')
+ sidsyp_fp = thgetid('syp_fp')
+ sidslogchi2_fp = thgetid('slogchi2_fp')
+ sidsnfree_fp = thgetid('snfree_fp')
+ sidschi2perdeg_fp = thgetid('schi2perdeg_fp')
+* histogram block sos_decoded_dc
+ sidrawtdc = thgetid('sdcrawtdc')
+ sidcuttdc = thgetid('sdccuttdc')
+ do plane = 1, sdc_num_planes
+ histname = sdcplanename(plane)//wiremap
+ siddcwiremap(plane) = thgetid(histname)
+ histname = sdcplanename(plane)//drifttime
+ siddcdrifttime(plane) = thgetid(histname)
+ histname = sdcplanename(plane)//driftdis
+ siddcdriftdis(plane) = thgetid(histname)
+ histname = sdcplanename(plane)//wirecent
+ siddcwirecent(plane) = thgetid(histname)
+ histname = sdcplanename(plane)//residual
+ sidres_fp(plane) = thgetid(histname)
+ histname = sdcplanename(plane)//singres
+ sidsingres_fp(plane) = thgetid(histname)
+ enddo ! end loop over dc planes
+
+* histogram block sos_raw_sc
+
+ sidscinrawtothits = thgetid('sscintothits')
+ sidscinplane = thgetid('sscinplane')
+ sidscinalltimes = thgetid('sscinalltimes')
+ sidscintimes = thgetid('sscintimes')
+
+ snum_scin_counters(1) = sscin_1x_nr
+ snum_scin_counters(2) = sscin_1y_nr
+ snum_scin_counters(3) = sscin_2x_nr
+ snum_scin_counters(4) = sscin_2y_nr
+
+ siddcdposx = thgetid('sdcdposx')
+ siddcdposy = thgetid('sdcdposy')
+ siddcdposxp = thgetid('sdcdposxp')
+ siddcdposyp = thgetid('sdcdposyp')
+ sidcaldpos = thgetid('scaldpos')
+
+ do plane = 1, SNUM_SCIN_PLANES
+ histname = sscinplane//sscinplanenum(plane)
+ sidscincounters(plane) = thgetid(histname)
+ histname = spostdc//sscinplanenum(plane)
+ sidscinallpostdc(plane) = thgetid(histname)
+ histname = snegtdc//sscinplanenum(plane)
+ sidscinallnegtdc(plane) = thgetid(histname)
+ histname = sposadc//sscinplanenum(plane)
+ sidscinallposadc(plane) = thgetid(histname)
+ histname = snegadc//sscinplanenum(plane)
+ sidscinallnegadc(plane) = thgetid(histname)
+
+ histname = "ssumpostdc"//sscinplanenum(plane)
+ sidsumpostdc(plane) = thgetid(histname)
+ histname = "ssumnegtdc"//sscinplanenum(plane)
+ sidsumnegtdc(plane) = thgetid(histname)
+ histname = "ssumposadc"//sscinplanenum(plane)
+ sidsumposadc(plane) = thgetid(histname)
+ histname = "ssumnegadc"//sscinplanenum(plane)
+ sidsumnegadc(plane) = thgetid(histname)
+
+ histname = "sscindpos"//sscinplanenum(plane)
+ sidscindpos(plane) = thgetid(histname)
+
+ histname = "sscindpos_pid"//sscinplanenum(plane)
+ sidscindpos_pid(plane) = thgetid(histname)
+
+ do counter = 1,snum_scin_counters(plane)
+* this is probably very awkward character manipulation
+*
+ if(counter.lt.10) then
+ write(histname,'(a7,i1,a6)') sscinplanename(plane),counter,posadc
+ else
+ write(histname,'(a7,i2,a6)') sscinplanename(plane),counter,posadc
+ endif
+ sidscinposadc(plane,counter) = thgetid(histname)
+ if(counter.lt.10) then
+ write(histname,'(a7,i1,a6)') sscinplanename(plane),counter,negadc
+ else
+ write(histname,'(a7,i2,a6)') sscinplanename(plane),counter,negadc
+ endif
+ sidscinnegadc(plane,counter) = thgetid(histname)
+ if(counter.lt.10) then
+ write(histname,'(a7,i1,a6)') sscinplanename(plane),counter,postdc
+ else
+ write(histname,'(a7,i2,a6)') sscinplanename(plane),counter,postdc
+ endif
+ sidscinpostdc(plane,counter) = thgetid(histname)
+ if(counter.lt.10) then
+ write(histname,'(a7,i1,a6)') sscinplanename(plane),counter,negtdc
+ else
+ write(histname,'(a7,i2,a6)') sscinplanename(plane),counter,negtdc
+ endif
+ sidscinnegtdc(plane,counter) = thgetid(histname)
+ enddo ! end loop over scintillator counters
+ enddo ! end loop over scintillator plane
+
+ sidcalplane = thgetid('scalplane')
+ sidcalposhits(1) = thgetid('scalaposhits')
+ sidcalposhits(2) = thgetid('scalbposhits')
+ sidcalposhits(3) = thgetid('scalcposhits')
+ sidcalposhits(4) = thgetid('scaldposhits')
+ sidcalneghits(1) = thgetid('scalaneghits')
+ sidcalneghits(2) = thgetid('scalbneghits')
+ sidcalneghits(3) = thgetid('scalcneghits')
+ sidcalneghits(4) = thgetid('scaldneghits')
+ sidcalsumadc = thgetid('scalsumadc')
+
+ sidmisctdcs = thgetid('smisctdcs')
+
+ RETURN
+ END
+
diff --git a/STRACKING/s_init_physics.f b/STRACKING/s_init_physics.f
new file mode 100644
index 0000000..48f7765
--- /dev/null
+++ b/STRACKING/s_init_physics.f
@@ -0,0 +1,69 @@
+ SUBROUTINE s_init_physics(ABORT,err)
+*--------------------------------------------------------
+*-
+*- Purpose and Methods : Initialize constants for s_physics
+*-
+*-
+*- Output: ABORT - success or failure
+*- : err - reason for failure, if any
+*-
+*- Created 6-6-94 D. F. Geesaman
+* $Log: s_init_physics.f,v $
+* Revision 1.6 1999/02/10 18:15:40 csa
+* Bug fix in sin/cossthetas calculations
+*
+* Revision 1.5 1996/09/05 19:54:16 saw
+* (JRA) avoid setting p=0??
+*
+* Revision 1.4 1996/01/24 16:07:34 saw
+* (JRA) Change upper case to lower case, cebeam to gebeam
+*
+* Revision 1.3 1995/05/22 19:45:41 cdaq
+* (SAW) Split gen_data_data_structures into gen, hms, sos, and coin parts"
+*
+* Revision 1.2 1995/05/11 17:07:14 cdaq
+* (SAW) Fix SOS to be in plane, beam left
+*
+* Revision 1.1 1994/06/14 04:09:12 cdaq
+* Initial revision
+*
+*--------------------------------------------------------
+ IMPLICIT NONE
+ SAVE
+*
+ character*50 here
+ parameter (here= 's_init_physics')
+*
+ logical ABORT
+ character*(*) err
+*
+ INCLUDE 'gen_data_structures.cmn'
+ INCLUDE 'sos_data_structures.cmn'
+ INCLUDE 'gen_constants.par'
+ INCLUDE 'gen_units.par'
+ INCLUDE 'sos_physics_sing.cmn'
+*
+* local variables
+*--------------------------------------------------------
+*
+ ABORT= .FALSE.
+ err= ' '
+*
+* Fix SOS to be in plane, beam left
+*
+ sphi_lab = tt/2
+*
+ if (smomentum_factor .gt. 0.1) then !avoid setting p=0
+ spcentral = spcentral * smomentum_factor
+ endif
+*
+ cossthetas = cos(stheta_lab*degree)
+ sinsthetas = sin(stheta_lab*degree)
+* Constants for elastic kinematics calcultion
+ sphysicsa = 2.*gebeam*gtarg_mass(gtarg_num) -
+ $ mass_electron**2 - spartmass**2
+ sphysicsb = 2. * (gtarg_mass(gtarg_num) - gebeam)
+ sphysicab2 = sphysicsa**2 * sphysicsb**2
+ sphysicsm3b = spartmass**2 * sphysicsb**2
+ return
+ end
diff --git a/STRACKING/s_init_scin.f b/STRACKING/s_init_scin.f
new file mode 100644
index 0000000..57b40e1
--- /dev/null
+++ b/STRACKING/s_init_scin.f
@@ -0,0 +1,103 @@
+ subroutine s_init_scin(ABORT,err)
+
+*-------------------------------------------------------------------
+* author: John Arrington
+* created: 2/22/94
+*
+* s_init_scin initializes the corrections and parameters
+* for the scintillators. Corrections are read from data files
+* or the database. Arrays used by the tof fitting routines
+* are filled from the CTP variables input from the sos_positions
+* parameter file.
+*
+* modifications:
+* 23 March 1993 DFG
+* Remove /nolist from include statement. UNIX doesn't like it.
+* $Log: s_init_scin.f,v $
+* Revision 1.6 1996/04/30 17:32:20 saw
+* (JRA) Calculate expected particle velocity
+*
+* Revision 1.5 1995/05/22 19:45:41 cdaq
+* (SAW) Split gen_data_data_structures into gen, hms, sos, and coin parts"
+*
+* Revision 1.4 1995/02/23 13:36:31 cdaq
+* * (JRA) Remove _coord fro shodo_center array. Edge coordinates replaced by
+* * center locations.
+*
+* Revision 1.3 1994/11/22 21:12:11 cdaq
+* (SPB) Recopied from hms file and modified names for SOS
+*
+* Revision 1.2 1994/06/01 15:37:05 cdaq
+* (SAW) Add Abort and err arguments
+*
+* Revision 1.1 1994/04/13 18:19:01 cdaq
+* Initial revision
+*
+*-------------------------------------------------------------------
+
+ implicit none
+
+ include 'sos_data_structures.cmn'
+ include 'sos_scin_parms.cmn'
+ include 'sos_scin_tof.cmn'
+ include 'sos_statistics.cmn'
+
+ logical abort
+ character*(*) err
+ character*20 here
+ parameter (here='s_init_scin')
+
+ integer*4 plane,counter
+ save
+*
+*
+* initialize some position parameters.
+ snum_scin_counters(1) = sscin_1x_nr
+ snum_scin_counters(2) = sscin_1y_nr
+ snum_scin_counters(3) = sscin_2x_nr
+ snum_scin_counters(4) = sscin_2y_nr
+
+ sstat_numevents=0
+
+ do plane = 1 , snum_scin_planes
+ do counter = 1 , snum_scin_counters(plane)
+
+* initialize tof parameters.
+
+ if (plane .eq. 1) then
+ shodo_width(plane,counter) = sscin_1x_size
+ shodo_center(plane,counter) =
+ 1 sscin_1x_center(counter) + sscin_1x_offset
+ else if (plane .eq. 2) then
+ shodo_width(plane,counter) = sscin_1y_size
+ shodo_center(plane,counter) =
+ 1 sscin_1y_center(counter) + sscin_1y_offset
+ else if (plane .eq. 3) then
+ shodo_width(plane,counter) = sscin_2x_size
+ shodo_center(plane,counter) =
+ 1 sscin_2x_center(counter) + sscin_2x_offset
+ else if (plane .eq. 4) then
+ shodo_width(plane,counter) = sscin_2y_size
+ shodo_center(plane,counter) =
+ 1 sscin_2y_center(counter) + sscin_2y_offset
+ else ! Error in plane number
+ abort = .true.
+ write(err,*) 'Trying to init. sos hodoscope plane',plane
+ call g_prepend(here,err)
+ return
+ endif
+
+ sstat_trk(plane,counter)=0
+ sstat_poshit(plane,counter)=0
+ sstat_neghit(plane,counter)=0
+ sstat_andhit(plane,counter)=0
+ sstat_orhit(plane,counter)=0
+
+ enddo !loop over counters
+ enddo !loop over planes
+
+* need expected particle velocity for start time calculation.
+ sbeta_pcent = spcentral/sqrt(spcentral*spcentral+spartmass*spartmass)
+
+ return
+ end
diff --git a/STRACKING/s_initialize_fitting.f b/STRACKING/s_initialize_fitting.f
new file mode 100644
index 0000000..d76b905
--- /dev/null
+++ b/STRACKING/s_initialize_fitting.f
@@ -0,0 +1,34 @@
+ subroutine s_initialize_fitting
+* This subroutine does the MINUIT initialization for track fitting
+*
+* d.f. geesaman 8 Sept 1993
+* $Log: s_initialize_fitting.f,v $
+* Revision 1.3 1996/09/05 20:09:06 saw
+* (JRA) Cosmetic
+*
+* Revision 1.2 1995/05/22 19:45:41 cdaq
+* (SAW) Split gen_data_data_structures into gen, hms, sos, and coin parts"
+*
+* Revision 1.1 1994/02/21 16:14:30 cdaq
+* Initial revision
+*
+*
+ implicit none
+ external S_FCNCHISQ
+ real*8 S_FCNCHISQ
+ include "sos_data_structures.cmn"
+ include "sos_tracking.cmn"
+* local variables
+ integer*4 ierr,dummy
+ integer*4 mlunin,mlunsave
+ real*8 arglis(10)
+ parameter(mlunin=5)
+ parameter(mlunsave=10)
+* initialize MINUIT lun settings
+ call MNINIT(mlunin,sluno,mlunsave)
+* set print to -1 (no output)
+ arglis(1)=-1
+ call MNEXCM(S_FCNCHISQ,'SET PRI',arglis,1,ierr,dummy)
+ call MNSETI( ' Track fitting in SOS Spectrometer')
+ return
+ end
diff --git a/STRACKING/s_left_right.f b/STRACKING/s_left_right.f
new file mode 100644
index 0000000..cf207d2
--- /dev/null
+++ b/STRACKING/s_left_right.f
@@ -0,0 +1,262 @@
+ subroutine s_left_right(ABORT,err)
+* Warning: This routine contains lots of gobbledeguk that won't work if the
+* number of chambers is changed to 3.
+*
+*
+* This routine fits stubs to all possible left-right combinations of
+* drift distances and chooses the set with the minimum chi**2
+* It then fills the SDC_WIRE_COORD variable for each hit in a good
+* space point.
+* d. f. geesaman 31 August 1993
+* $Log: s_left_right.f,v $
+* Revision 1.12.24.1 2007/09/10 20:28:01 pcarter
+* Implemented changes to allow compilation on RHEL 3,4,5 and MacOSX
+*
+* Revision 1.12 1999/11/04 20:36:47 saw
+* Linux/G77 compatibility fixes
+*
+* Revision 1.11 1996/09/05 19:54:51 saw
+* (JRA) Cosmetic
+*
+* Revision 1.10 1996/01/17 19:01:59 cdaq
+* (JRA)
+*
+* Revision 1.9 1995/10/10 15:59:06 cdaq
+* (JRA) Remove sdc_sing_wcoord stuff
+*
+* Revision 1.8 1995/08/31 18:44:23 cdaq
+* (JRA) Fix some logic in small angle L/R determination loop
+*
+* Revision 1.7 1995/07/20 18:57:39 cdaq
+* (SAW) Declare jibset for f2c compatibility
+*
+* Revision 1.6 1995/05/22 19:45:42 cdaq
+* (SAW) Split gen_data_data_structures into gen, hms, sos, and coin parts"
+*
+* Revision 1.5 1995/05/11 21:05:32 cdaq
+* (JRA) Fix errors in left right selection. Add some commented out code
+*
+* Revision 1.4 1995/04/01 20:42:35 cdaq
+* (SAW) Fix typos
+*
+* Revision 1.3 1994/12/01 21:55:08 cdaq
+* (SAW) Generalize for variable # of chambers.
+* Add Small Ang approx for Brookhaven chambers
+*
+* Revision 1.2 1994/11/22 21:14:25 cdaq
+* (SPB) Recopied from hms file and modified names for SOS
+* (SAW) Don't count on Mack's monster if statement working for
+* sdc_num_chambers > 2
+*
+* Revision 1.1 1994/02/21 16:14:42 cdaq
+* Initial revision
+*
+*
+ implicit none
+ save
+ include 'sos_data_structures.cmn'
+ include 'sos_tracking.cmn'
+ include 'sos_geometry.cmn'
+*
+ external jbit ! cernlib bit routine
+ external jieor, jibset
+ integer*4 jbit
+ integer*4 jibset ! Declare to help f2c
+ integer*4 jieor ! Declare to help f2c
+*
+* local variables
+*
+ character*12 here
+ parameter (here= 's_left_right')
+*
+ logical ABORT
+ character*(*) err
+ integer*4 isp, ihit,iswhit, idummy, pmloop, ich
+ integer*4 nplusminus
+ integer*4 numhits,npaired,ihit2
+ integer*4 hits(smax_hits_per_point), pl(smax_hits_per_point)
+ integer*4 pindex
+ real*4 wc(smax_hits_per_point)
+ integer*4 plane, isa_y1, isa_y2
+ integer*4 plusminusknown(smax_hits_per_point)
+ real*4 plusminus(smax_hits_per_point)
+ real*4 plusminusbest(smax_hits_per_point)
+ real*4 chi2
+ real*4 minchi2
+ real*4 stub(4)
+ logical smallAngOk
+*
+ ABORT= .FALSE.
+ err=' '
+
+ do isp=1,snspace_points_tot ! loop over all space points
+ do ich=1,sdc_num_chambers
+ gplanesdc(isp,ich) = 0
+ enddo
+ minchi2=1e10
+ smallAngOK = .FALSE.
+ isa_y1 = 0
+ isa_y2 = 0
+ numhits=sspace_point_hits(isp,1)
+ nplusminus=2**numhits
+*
+* Identify which plane the space point is in.
+*
+ ich = (SDC_PLANE_NUM(sspace_point_hits(isp,2+1))-1)
+ $ /(sdc_planes_per_chamber)+1
+ do ihit=1,numhits
+ hits(ihit)=sspace_point_hits(isp,2+ihit)
+ pl(ihit)=SDC_PLANE_NUM(hits(ihit))
+
+ gplanesdc(isp,ich)=jibset(gplanesdc(isp,ich),pl(ihit)-
+ $ ((ich-1)*(sdc_planes_per_chamber)+1))
+
+c if(pl(ihit).ge.1 .and. pl(ihit).le.6)then
+c gplanesdc1(isp)=jibset(gplanesdc1(isp),pl(ihit)-1)
+c else
+c gplanesdc2(isp)=jibset(gplanesdc2(isp),pl(ihit)-7)
+c endif
+
+ wc(ihit)=SDC_WIRE_CENTER(hits(ihit))
+ plusminusknown(ihit) = 0
+ if(s_hms_style_chambers.eq.1) then
+ if(pl(ihit).eq.2 .OR. pl(ihit).eq.8) isa_y1 = ihit
+ if(pl(ihit).eq.5 .OR. pl(ihit).eq.11) isa_y2 = ihit
+ endif
+ enddo
+
+
+* djm 10/2/94 check bad sdc pattern units to set the index for the inverse
+* matrix SAAINV(i,j,pindex).
+*
+ if(jieor(gplanesdc(isp,ich),'3F'x).eq.0) then
+ pindex=sdc_num_planes+ich
+ else if (jieor(gplanesdc(isp,ich),'3E'x).eq.0) then
+ pindex=(ich-1)*(sdc_planes_per_chamber) + 1
+ else if (jieor(gplanesdc(isp,ich),'3D'x).eq.0) then
+ pindex=(ich-1)*(sdc_planes_per_chamber) + 2
+ else if (jieor(gplanesdc(isp,ich),'3B'x).eq.0) then
+ pindex=(ich-1)*(sdc_planes_per_chamber) + 3
+ else if (jieor(gplanesdc(isp,ich),'37'x).eq.0) then
+ pindex=(ich-1)*(sdc_planes_per_chamber) + 4
+ else if (jieor(gplanesdc(isp,ich),'2F'x).eq.0) then
+ pindex=(ich-1)*(sdc_planes_per_chamber) + 5
+ else if (jieor(gplanesdc(isp,ich),'1F'x).eq.0) then
+ pindex=(ich-1)*(sdc_planes_per_chamber) + 6
+ else
+ pindex=-1
+ endif
+
+* check if small angle L/R determination of Y and Y' planes is possible
+ if(sSmallAngleApprox.ne.0) then
+ if(s_hms_style_chambers.eq.1) then
+ if(isa_y1.gt.0 .AND. isa_y2.gt.0) then
+ if(wc(isa_y2).le.wc(isa_y1)) then
+ plusminusknown(isa_y1) = -1
+ plusminusknown(isa_y2) = 1
+ else
+ plusminusknown(isa_y1) = 1
+ plusminusknown(isa_y2) = -1
+ endif
+ nplusminus = 2**(numhits-2)
+ endif
+ else ! SOS chambers
+*
+* Brookhaven chamber L/R code
+* Can we assume that hits are sorted by plane? As best I (SAW) can
+* tell, we can not.
+*
+ ihit = 1
+ npaired = 0
+ do ihit=1,numhits
+ if(pl(ihit)-2*(pl(ihit)/2) .eq. 1) then ! Odd plane
+ do ihit2=1,numhits ! Look for the adjacent plane
+ if(pl(ihit2)-pl(ihit).eq.1) then ! Adjacent plane found
+ if(wc(ihit2).le.wc(ihit)) then
+ plusminusknown(ihit) = -1
+ plusminusknown(ihit2) = 1
+ else
+ plusminusknown(ihit) = 1
+ plusminusknown(ihit2) = -1
+ endif
+ npaired = npaired + 2
+ endif
+ enddo
+ endif
+ enddo
+ endif
+ nplusminus = 2**(numhits-npaired)
+* Let's hope that following code will work with nplusminus = 1
+ endif
+
+* use bit value of integer word to set + or -
+ do pmloop=0,nplusminus-1
+ iswhit = 1
+ do ihit=1,numhits
+ if(plusminusknown(ihit).ne.0) then
+ plusminus(ihit) = float(plusminusknown(ihit))
+ else
+ if(jbit(pmloop,iswhit).eq.1) then
+ plusminus(ihit)=1.0
+ else
+ plusminus(ihit)=-1.0
+ endif
+ iswhit = iswhit + 1
+ endif
+ enddo
+
+ if (pindex.ge.0 .and. pindex.le.14) then
+ call s_find_best_stub(numhits,hits,pl,pindex,plusminus,stub,chi2)
+ if(sdebugstubchisq.ne.0) then
+ write(sluno,'('' sos pmloop='',i4,'' chi2='',e14.6)')
+ & pmloop,chi2
+ endif
+ if (chi2.lt.minchi2) then
+ minchi2=chi2
+ do idummy=1,numhits
+ plusminusbest(idummy)=plusminus(idummy)
+ enddo
+ do idummy=1,4
+ sbeststub(isp,idummy)=stub(idummy)
+ enddo
+ endif ! end if on lower chi2
+ else ! if pindex<0 or >14
+ write(6,*) 'pindex=',pindex,' in s_left_right'
+ endif
+ enddo ! end loop on possible left-right
+*
+* calculate final coordinate based on plusminusbest
+*
+ do ihit=1,numhits
+ SDC_WIRE_COORD(sspace_point_hits(isp,ihit+2))=
+ & SDC_WIRE_CENTER(sspace_point_hits(isp,ihit+2)) +
+ & plusminusbest(ihit)*SDC_DRIFT_DIS(sspace_point_hits(isp,ihit
+ $ +2))
+ enddo
+*
+* stubs are calculated in rotated coordinate system
+* use first hit to determine chamber
+ plane=SDC_PLANE_NUM(hits(1))
+ stub(3)=(sbeststub(isp,3) - stanbeta(plane))
+ & /(1.0 + sbeststub(isp,3)*stanbeta(plane))
+ stub(4)=sbeststub(isp,4)
+ & /(sbeststub(isp,3)*ssinbeta(plane)+scosbeta(plane))
+
+ stub(1)=sbeststub(isp,1)*scosbeta(plane)
+ & - sbeststub(isp,1)*stub(3)*ssinbeta(plane)
+ stub(2)=sbeststub(isp,2)
+ & - sbeststub(isp,1)*stub(4)*ssinbeta(plane)
+ sbeststub(isp,1)=stub(1)
+ sbeststub(isp,2)=stub(2)
+ sbeststub(isp,3)=stub(3)
+ sbeststub(isp,4)=stub(4)
+
+*
+ enddo ! end loop over space points
+*
+* write out results if sdebugflagstubs is set
+ if(sdebugflagstubs.ne.0) then
+ call s_print_stubs
+ endif
+ return
+ end
diff --git a/STRACKING/s_link_stubs.f b/STRACKING/s_link_stubs.f
new file mode 100644
index 0000000..4064540
--- /dev/null
+++ b/STRACKING/s_link_stubs.f
@@ -0,0 +1,264 @@
+ subroutine S_LINK_STUBS(ABORT,err)
+* This subroutine compares all the space-point-stubs found in
+* S_LEFT_RIGHT.f and links together stubs to form tracks.
+* The criterion are that the stubs are in different chambers and
+* each of the four track parameters are within limit:
+* sxt_track_criterion for x_t
+* syt_track_criterion for y_t
+* stx_track_criterion for t_x
+* sty_track_criterion for t_y
+*
+* d.f. geesaman 7-September 1993
+* $Log: s_link_stubs.f,v $
+* Revision 1.7 1996/09/05 19:55:23 saw
+* (DVW) Added some track tests
+*
+* Revision 1.6 1996/01/17 19:01:38 cdaq
+* (JRA)
+*
+* Revision 1.5 1995/08/31 18:44:51 cdaq
+* (JRA) Calculate dpos (pos. track - pos. hit) variables
+*
+* Revision 1.4 1995/05/22 19:45:42 cdaq
+* (SAW) Split gen_data_data_structures into gen, hms, sos, and coin parts"
+*
+* Revision 1.3 1995/04/01 20:42:57 cdaq
+* (SAW) Fix typos
+*
+* Revision 1.2 1994/06/07 04:41:19 cdaq
+* (DFG) Add switch to include single stub tracks
+*
+* Revision 1.1 1994/02/21 16:14:56 cdaq
+* Initial revision
+*
+*
+* The logic is 1) loop over all space points as seeds isp1
+* 2) Check if this space point is all ready in a track
+* 3) loop over all succeeding space pointss isp2
+* 4) check if there is a track-criterion match
+* either add to existing track
+* or if there is another point in same chamber
+* make a copy containing isp2 rather than
+* other point in same chamber
+* 5) If ssingle_stub is set, make a track of all single
+* stubs.
+*
+ implicit none
+ include 'sos_data_structures.cmn'
+ include 'sos_tracking.cmn'
+ include 'sos_id_histid.cmn'
+ include 'sos_geometry.cmn'
+ INCLUDE 'sos_track_histid.cmn' ! TEMP. JUNK
+*Derek added these next lines
+ include 'sos_bypass_switches.cmn'
+ INCLUDE 'gen_event_info.cmn'
+ external s_chamnum
+ integer*4 s_chamnum
+
+* local variables
+*
+ logical ABORT
+ character*12 here
+ parameter (here='S_LINK_STUBS')
+ character*(*) err
+ integer*4 isp1,isp2,isp ! loop index on space points
+ integer*4 ihit ! loop index on hits
+ integer*4 spindex,spoint,duppoint
+ integer*4 sptracks ! number of tracks with this seed
+ integer*4 stub_tracks(SNTRACKS_MAX)
+ integer*4 numhits
+ integer*4 itrack ! loop index on tracks
+ integer*4 track
+ integer*4 track_space_points(SNTRACKS_MAX,smax_space_points+1)
+ integer*4 tryflag ! flag to loop over rest of points
+ integer*4 newtrack ! make a new track
+ real*4 dposx,dposy,dposxp,dposyp
+ real*4 y1,y2
+*Derek added these next lines
+ if (sbypass_track_eff_files.eq.0) then
+ open(unit=16,file='scalers/strackstubs.txt',status='unknown',
+ $ access='append')
+ endif
+ sstubtest = 0
+*
+ ABORT= .FALSE.
+ err=' '
+ SNTRACKS_FP=0
+ if(ssingle_stub.eq.0 ) then
+* loop over all pairs of space points
+ if(snspace_points_tot.ge.2) then ! return if less than 2 space points
+ do isp1=1,snspace_points_tot-1 ! loop over all points
+* is this point all ready associated with a track
+ tryflag=1
+ if(SNTRACKS_FP.gt.0) then
+ do itrack=1,SNTRACKS_FP
+ if(track_space_points(itrack,1).gt.0) then
+ do isp2=1,track_space_points(itrack,1)
+ if(track_space_points(itrack,isp2+1).eq.isp1) then
+ tryflag=0 ! space point all ready in a track
+ endif ! end test on found point
+ enddo
+ endif ! end test of >0 point
+ enddo ! end loop over tracks
+ endif
+* if space point not all ready part of a track then look for matches
+ if( tryflag .eq.1) then
+ newtrack=1
+ do isp2=isp1+1,snspace_points_tot
+* are these stubs in the same chamber. If so then skip
+ if(s_chamnum(isp1).ne.s_chamnum(isp2)) then
+* does this stub match
+
+* since single chamber angular resolution is ~50mr, and the maximum y'
+* angle is about 30mr, use difference between y AT CHAMBERS, rather than
+* at focal plane. (project back to chamber, to take out y' uncertainty).
+ dposx = sbeststub(isp2,1)-sbeststub(isp1,1)
+ y1=sbeststub(isp1,2)+sdc_1_zpos*sbeststub(isp1,4)
+ y2=sbeststub(isp2,2)+sdc_2_zpos*sbeststub(isp2,4)
+ dposy=y2-y1
+ dposxp= sbeststub(isp2,3)-sbeststub(isp1,3)
+ dposyp= sbeststub(isp2,4)-sbeststub(isp1,4)
+******************************************************
+* Derek added this for track tests...
+ if (abs(dposx).LT.abs(sstubminx)) sstubminx = dposx
+ if (abs(dposy).LT.abs(sstubminy)) sstubminy = dposy
+ if (abs(dposxp).LT.abs(sstubminxp)) sstubminxp = dposxp
+ if (abs(dposyp).LT.abs(sstubminyp)) sstubminyp = dposyp
+ if (sbypass_track_eff_files.eq.0) then
+ if (abs(sstubminx) .gt. sxt_track_criterion) then
+ write(16,*) 'event # ',gen_event_ID_number,
+ $ ' sstubminx = ',sstubminx
+ endif
+ if (abs(sstubminy) .gt. syt_track_criterion) then
+ write(16,*) 'event # ',gen_event_ID_number,
+ $ ' sstubminy = ',sstubminy
+ endif
+ if (abs(sstubminxp) .gt. sxpt_track_criterion) then
+ write(16,*) 'event # ',gen_event_ID_number,
+ $ ' sstubminxp = ',sstubminxp
+ endif
+ if (abs(sstubminyp) .gt. sypt_track_criterion) then
+ write(16,*) 'event # ',gen_event_ID_number,
+ $ ' sstubminyp = ',sstubminyp
+ endif
+ close(16)
+ endif
+******************************************************
+
+ if (abs(dposx) .lt. sxt_track_criterion
+ $ .and. abs(dposy) .lt. syt_track_criterion
+ $ .and. abs(dposxp).lt. sxpt_track_criterion
+ $ .and. abs(dposyp).lt. sypt_track_criterion) then
+ if(newtrack.eq.1) then
+*Derek add this next line
+ sstubtest=1
+
+* make a new track
+ if(SNTRACKS_FP.lt.SNTRACKS_MAX) then ! are there too many
+ SNTRACKS_FP=SNTRACKS_FP+1 ! increment the number of tracks
+ sptracks=1 ! one track with this seed
+ stub_tracks(1)=SNTRACKS_FP
+ track_space_points(SNTRACKS_FP,1)=2
+ track_space_points(SNTRACKS_FP,2)=isp1
+ track_space_points(SNTRACKS_FP,3)=isp2
+ sx_sp1(sntracks_fp)=sbeststub(isp1,1)
+ sx_sp2(sntracks_fp)=sbeststub(isp2,1)
+ sy_sp1(sntracks_fp)=sbeststub(isp1,2)
+ sy_sp2(sntracks_fp)=sbeststub(isp2,2)
+ sxp_sp1(sntracks_fp)=sbeststub(isp1,3)
+ sxp_sp2(sntracks_fp)=sbeststub(isp2,3)
+ newtrack=0 ! make no more track in this loop
+ endif ! end test on too many tracks
+ else
+* check if there is another space point in same chamber
+ itrack=0
+ do while (itrack.lt.sptracks)
+ itrack=itrack+1
+ track=stub_tracks(itrack)
+ spoint=0
+ duppoint=0
+ do isp=1,track_space_points(track,1)
+ if(s_chamnum(isp2).eq.
+ & s_chamnum(track_space_points(track,isp+1))) then
+ spoint=isp
+ endif
+ if(isp2.eq.track_space_points(track,isp+1)) then
+ duppoint=1
+ endif
+ enddo ! end loop over sp in tracks with isp1
+* if there is no other space point in this chamber
+* add this space point to current track(2)
+ if(duppoint.eq.0) then
+ if(spoint.eq.0) then
+ spindex=track_space_points(track,1)+1
+ track_space_points(track,1)= spindex
+ track_space_points(track,spindex+1)=isp2
+* if there is another point in the same chamber in this track
+* create a new track with all the same space points except spoint
+ else
+ if(SNTRACKS_FP.lt.SNTRACKS_MAX) then ! are there too many
+ SNTRACKS_FP=SNTRACKS_FP+1 ! increment the number of tracks
+ sptracks= sptracks+1 ! one track with this seed
+ stub_tracks(sptracks) = SNTRACKS_FP
+ track_space_points(SNTRACKS_FP,1)
+ $ =track_space_points(track,1)
+ do isp=1,track_space_points(track,1)
+ if(isp.ne.spoint) then
+ track_space_points(SNTRACKS_FP,isp+1)=
+ & track_space_points(track,isp+1)
+ elseif(isp.eq.spoint) then
+ track_space_points(SNTRACKS_FP,isp+1)= isp2
+ endif ! end check for dup on copy
+ enddo ! end copy of track
+ endif ! end if on too many tracks
+ endif ! end if on same chamber
+ endif ! end if on duplicate point
+ enddo ! end do while over tracks with isp1
+ endif
+ endif
+ endif ! end test on same chamber
+ enddo ! end loop over new space points
+ endif ! end test on tryflag
+ enddo ! end outer loop over space points
+ endif ! end if on <2 space points
+ else ! if ssingle_stub .ne. 0
+* when ssingle_stub is set, make each space point a track
+* This will have poor resolution but may be appropriate for debugging
+*
+ do isp1=1,snspace_points_tot ! loop over all points
+ if(SNTRACKS_FP.lt.SNTRACKS_MAX) then ! are there too many
+ SNTRACKS_FP=SNTRACKS_FP+1 ! increment the number of tracks
+ track_space_points(SNTRACKS_FP,1)= 1
+ track_space_points(SNTRACKS_FP,2)= isp1
+ endif ! end if on too many tracks
+ enddo ! end loop over all space points
+ endif ! end test on ssingle_stub
+*
+* now list all hits on a track
+ if(SNTRACKS_FP.gt.0) then
+ do itrack=1,SNTRACKS_FP ! loop over all tracks
+ SNTRACK_HITS(itrack,1)=0
+ do isp1=1,track_space_points(itrack,1)
+ spindex=track_space_points(itrack,isp1+1)
+ numhits=sspace_point_hits(spindex,1)
+ do ihit=1,numhits
+ if(SNTRACK_HITS(itrack,1).lt.SNTRACKHITS_MAX) then
+ SNTRACK_HITS(itrack,1)=SNTRACK_HITS(itrack,1)+1
+ SNTRACK_HITS(itrack,SNTRACK_HITS(itrack,1)+1)=
+ & sspace_point_hits(spindex,ihit+2)
+ endif ! end test on too many hits
+ enddo ! end loop over space point hits
+ enddo ! end loop over space points
+ enddo ! end loop over all tracks
+ endif
+ if(sdebuglinkstubs.ne.0) then
+ call s_print_links
+ endif
+ return
+ end
+*********
+* Local Variables:
+* mode: fortran
+* fortran-if-indent: 1
+* fortran-do-indent: 1
+* End:
diff --git a/STRACKING/s_lucite.f b/STRACKING/s_lucite.f
new file mode 100644
index 0000000..73658d4
--- /dev/null
+++ b/STRACKING/s_lucite.f
@@ -0,0 +1,96 @@
+ SUBROUTINE S_LUCITE(ABORT,err)
+*--------------------------------------------------------
+*-
+*- Purpose and Methods : Analyze lucite aerogel information for each track
+*-
+*- Required Input BANKS SOS_RAW_LUC
+*-
+*- Output BANKS SOS_TRACK_TESTS
+*-
+*- Output: ABORT - success or failure
+*- : err - reason for failure, if any
+*-
+* $Log: s_lucite.f,v $
+* Revision 1.1 1996/11/07 19:50:56 saw
+* Initial revision
+*
+*--------------------------------------------------------
+ IMPLICIT NONE
+ SAVE
+*
+ character*8 here
+ parameter (here= 'S_LUCITE')
+*
+ logical ABORT
+ character*(*) err
+*
+
+ integer*4 ind,npmt
+*
+ INCLUDE 'sos_data_structures.cmn'
+ INCLUDE 'sos_pedestals.cmn'
+ INCLUDE 'sos_lucite_parms.cmn'
+
+*
+*--------------------------------------------------------
+*
+ ABORT= .FALSE.
+ err= ' '
+
+ sluc_neg_npe_sum = 0.0
+ sluc_pos_npe_sum = 0.0
+ sluc_tot_good_hits = 0
+
+ do ind = 1,smax_luc_hits
+ sluc_pos_npe(ind)=0.
+ sluc_neg_npe(ind)=0.
+ enddo
+
+ do ind = 1,sluc_tot_hits
+* pedestal subtraction and gain adjustment
+ npmt=sluc_pair_num(ind)
+ sluc_pos_npe(npmt) =
+ & (sluc_adc_pos(ind)-sluc_pos_ped_mean(npmt))*sluc_pos_gain(npmt)
+ sluc_neg_npe(npmt) =
+ & (sluc_adc_neg(ind)-sluc_neg_ped_mean(npmt))*sluc_neg_gain(npmt)
+
+* sum positive and negative hits
+* also, fill sluc_tot_good_hits
+
+ sluc_neg_npe_sum = sluc_neg_npe_sum + sluc_neg_npe(npmt)
+ if (sluc_neg_npe(npmt).ge.1.0)
+ & sluc_tot_good_hits = sluc_tot_good_hits + 1
+
+
+ sluc_pos_npe_sum = sluc_pos_npe_sum + sluc_pos_npe(npmt)
+ if (sluc_pos_npe(npmt).ge.0.3)
+ & sluc_tot_good_hits = sluc_tot_good_hits + 1
+ enddo
+
+
+ sluc_npe_sum = sluc_neg_npe_sum + sluc_pos_npe_sum
+
+* If the total hits are 0, then give a noticable ridiculous NPE.
+
+ if (sluc_tot_hits.lt.1) then
+ sluc_npe_sum=100.
+ endif
+
+
+* Next, fill the rawadc variables with the actual tube values
+* mainly for diagnostic purposes.
+
+ do ind=1,8
+ sluc_rawadc_neg(ind)=-100
+ sluc_rawadc_pos(ind)=-100
+ enddo
+
+ do ind=1,sluc_tot_hits
+ npmt=sluc_pair_num(ind)
+ sluc_rawadc_neg(npmt)=sluc_adc_neg(ind)
+ sluc_rawadc_pos(npmt)=sluc_adc_pos(ind)
+ enddo
+
+ return
+ end
+
diff --git a/STRACKING/s_pattern_recognition.f b/STRACKING/s_pattern_recognition.f
new file mode 100644
index 0000000..8538603
--- /dev/null
+++ b/STRACKING/s_pattern_recognition.f
@@ -0,0 +1,211 @@
+ subroutine s_pattern_recognition(ABORT,err)
+*--------------------------------------------------------
+*-
+*- Purpose and Methods : Finds SOS Space points
+*-
+*- Required Input BANKS SOS_DECODED_DC
+*-
+*- Output BANKS SOS_FOCAL_PLANE
+*- SOS_DECODED_DC hit coordinates
+*-
+*- Output: ABORT - success or failure
+*- : err - reason for failure, if any
+*-
+*- Created 30-AUG-1993 D. F. Geesaman
+*- Modified 19-JAN-1994 DFG Include standard error form
+* $Log: s_pattern_recognition.f,v $
+* Revision 1.10 1996/09/05 20:09:36 saw
+* (JRA) Cosmetic
+*
+* Revision 1.9 1996/04/30 17:34:56 saw
+* (JRA) Histogram the card id.
+*
+* Revision 1.8 1996/01/17 19:01:21 cdaq
+* (JRA) Add code for easy space points
+*
+* Revision 1.7 1995/10/10 16:13:47 cdaq
+* (JRA) Remove sdc_sing_wcenter, cosmetics.
+*
+* Revision 1.6 1995/07/20 18:58:50 cdaq
+* (SAW) Declare sind and cosd for f2c compatibility
+*
+* Revision 1.5 1995/05/22 19:45:43 cdaq
+* (SAW) Split gen_data_data_structures into gen, hms, sos, and coin parts"
+*
+* Revision 1.4 1995/04/06 19:36:53 cdaq
+* (SAW) Hopefully improve wire velocity correction for SOS chambers
+*
+* Revision 1.3 1994/12/06 15:33:06 cdaq
+* (SAW) First pass at wire velocity correction for Brookhaven chambers
+*
+* Revision 1.2 1994/11/22 21:48:45 cdaq
+* (SPB) Recopied from hms file and modified names for SOS
+* (SAW) Improved some code hardwired for 3 chambers. NOTE: the wire velocity
+* correction stuff at the end is HMS specific. This needs to
+* be worked on.
+*
+* Revision 1.1 1994/02/21 16:15:19 cdaq
+* Initial revision
+*
+*
+* This routine finds the space points in each chamber using wire center
+* locations.
+*
+*--------------------------------------------------------
+ IMPLICIT NONE
+ SAVE
+*
+ character*21 here
+ parameter (here= 's_pattern_recognition')
+*
+ logical ABORT
+ character*(*) err
+*
+ INCLUDE 'sos_data_structures.cmn'
+ INCLUDE 'gen_constants.par'
+ INCLUDE 'gen_units.par'
+ INCLUDE 'sos_tracking.cmn'
+ INCLUDE 'sos_geometry.cmn'
+*
+* local variables
+ integer*4 hit_number(smax_chamber_hits)
+ integer*4 space_point_hits(smax_space_points,smax_hits_per_point+2)
+ integer*4 pln, isp, ihit, hit
+ integer*4 i,j,k,xx,xxprime
+ integer*4 xplane,xprimeplane
+ integer*4 ich, ip
+ logical easy_space_point
+*
+ real*4 space_points(smax_space_points,2)
+ real*4 xdist,ydist
+ real*4 time_corr
+ real*4 s_drift_dist_calc
+ external s_drift_dist_calc
+
+*
+* temporary initialization
+ ABORT= .FALSE.
+ err=' '
+*
+*
+ ihit = 0
+ snspace_points_tot = 0
+ do ich=1,sdc_num_chambers
+ easy_space_point = .false.
+ snspace_points(ich)=0
+ sncham_hits(ich)=0
+*
+* For this loop to work, sdc_planes_per_chamber must be
+* the number of planes per chamber. (And all chambers must have the
+* same number of planes.)
+*
+ do ip=(ich-1)*sdc_planes_per_chamber+1,ich*sdc_planes_per_chamber
+ sncham_hits(ich)=sncham_hits(ich)+sdc_hits_per_plane(ip)
+ enddo
+ xplane=3+(ich-1)*sdc_planes_per_chamber
+ xprimeplane=4+(ich-1)*sdc_planes_per_chamber
+ if(sncham_hits(ich).ge.smin_hit(ich) .and.
+ $ sncham_hits(ich).lt.smax_pr_hits(ich)) then
+ do i=ihit+1,ihit+sncham_hits(ich)
+ hit_number(i)=i
+ if(sdc_plane_num(i).eq.xplane) xx=i
+ if(sdc_plane_num(i).eq.xprimeplane) xxprime=i
+ enddo
+ if((sdc_hits_per_plane(xplane).eq.1) .and.
+ & (sdc_hits_per_plane(xprimeplane).eq.1).and.
+ & ((sdc_wire_center(xx)-sdc_wire_center(xxprime))**2.lt.
+ & (sspace_point_criterion(ich))) .and.
+ & (sncham_hits(ich).le.6)) then
+ call s_find_easy_space_point(sncham_hits(ich),hit_number(ihit+1),
+ & sdc_wire_center(ihit+1),sdc_plane_num(ihit+1),
+ & sspace_point_criterion(ich),smax_space_points,xx-ihit,
+ & xxprime-ihit,easy_space_point,snspace_points(ich),
+ & space_points,space_point_hits)
+ if (.not.easy_space_point) call find_space_points(sncham_hits(ich),
+ & hit_number(ihit+1),sdc_wire_center(ihit+1),
+ & sdc_plane_num(ihit+1),sspace_point_criterion(ich),
+ & sxsp(1),sysp(1),smax_space_points,
+ & snspace_points(ich), space_points, space_point_hits)
+ else
+ call find_space_points(sncham_hits(ich),hit_number(ihit+1),
+ & sdc_wire_center(ihit+1),
+ & sdc_plane_num(ihit+1),sspace_point_criterion(ich),
+ & sxsp(1),sysp(1),smax_space_points,
+ & snspace_points(ich), space_points, space_point_hits)
+ endif
+*
+ if (snspace_points(ich).gt.0) then
+* If two hits in same plane, choose one with minimum drift time
+ call s_choose_single_hit(ABORT,err,snspace_points(ich),
+ & space_point_hits)
+* Select on minimum number of combinations and hits
+ call select_space_points(smax_space_points,snspace_points(ich),
+ & space_points,space_point_hits,smin_hit(ich),smin_combos(ich),
+ $ easy_space_point)
+ endif
+
+
+ do i=1,snspace_points(ich)
+ k=snspace_points_tot+i
+ sspace_points(k,1)=space_points(i,1)
+ sspace_points(k,2)=space_points(i,2)
+ sspace_point_hits(k,1)=space_point_hits(i,1)
+ sspace_point_hits(k,2)=space_point_hits(i,2)
+ do j=1,space_point_hits(i,1)
+ sspace_point_hits(k,j+2)=space_point_hits(i,j+2)
+ enddo
+ enddo
+ endif
+ snspace_points_tot = snspace_points_tot+ snspace_points(ich)
+ ihit = ihit + sncham_hits(ich)
+ enddo
+*
+* Now we know rough hit positions in the chambers so we can make
+* wire velocity drift time corrections for each hit in the space point
+*
+* Assume all wires for a plane are read out on the same side (l/r or t/b).
+* If the wire is closer to horizontal, read out left/right. If nearer
+* vertical, assume top/bottom. (Note, this is not always true for the
+* SOS u and v planes. They have 1 card each on the side, but the overall
+* time offset per card will cancel much of the error caused by this. The
+* alternative is to check by card, rather than by plane and this is harder.
+*
+ if(snspace_points_tot.gt.0) then
+ do isp=1,snspace_points_tot
+ xdist = sspace_points(isp,1)
+ ydist = sspace_points(isp,2)
+ do ihit=1,sspace_point_hits(isp,1)
+ hit = sspace_point_hits(isp,ihit+2)
+ pln = sdc_plane_num(hit)
+ if (sdc_readout_x(pln)) then !readout from side
+ time_corr = ydist*sdc_readout_corr(pln)/sdc_wire_velocity
+ else !readout from top/bottom
+ time_corr = xdist*sdc_readout_corr(pln)/sdc_wire_velocity
+ endif
+
+ sdc_drift_time(hit)=sdc_drift_time(hit) - sdc_central_time(pln)
+ & + sdc_drifttime_sign(pln)*time_corr
+ sdc_drift_dis(hit) = s_drift_dist_calc
+ & (pln,sdc_wire_num(hit),sdc_drift_time(hit))
+*
+* djm 8/25/94
+* Stuff drift time and distance into registered variables for histogramming and tests.
+* In the case of two separated hits per plane, the last one will be histogrammed.
+ sdc_sing_drifttime(pln) = sdc_drift_time(hit)
+ sdc_sing_driftdis(pln) = sdc_drift_dis(hit)
+ sdc_sing_cardid(pln) =
+ & sdc_card_no(sdc_wire_num(hit),sdc_plane_num(hit))
+ enddo
+ enddo
+ endif
+*
+* Histogram sdc_DECODED_DC
+ call s_fill_dc_dec_hist(ABORT,err)
+
+* write out results if debugflagpr is set
+ if(sdebugflagpr.ne.0) then
+ call s_print_pr
+ endif
+*
+ return
+ end
diff --git a/STRACKING/s_physics.f b/STRACKING/s_physics.f
new file mode 100644
index 0000000..aa5707a
--- /dev/null
+++ b/STRACKING/s_physics.f
@@ -0,0 +1,486 @@
+ SUBROUTINE S_PHYSICS(ABORT,err)
+*--------------------------------------------------------
+*-
+*- Purpose and Methods : Do final SOS physics analysis on SOS only part of
+*- event.
+*-
+*- to decoded information
+*-
+*- Required Input BANKS SOS_FOCAL_PLANE
+*- SOS_TARGET
+*- SOS_TRACK_TESTS
+*-
+*- Output BANKS SOS_PHYSICS_R4
+*- SOS_PHYSICS_I4
+*-
+*- Output: ABORT - success or failure
+*- : err - reason for failure, if any
+*-
+*- Created 19-JAN-1994 D. F. Geesaman
+*- Dummy Shell routine
+*
+*
+* $Log: s_physics.f,v $
+* Revision 1.21 2003/11/28 14:57:30 jones
+* Added variable ssxp_tar_temp = ssxp_tar + s_oopcentral_offset (MKJ)
+*
+* Revision 1.20 2003/09/05 19:52:01 jones
+* Merge in online03 changes (mkj)
+*
+* Revision 1.19.2.4 2003/09/05 14:32:57 jones
+* Use s_oopcentral_offset (mkj)
+*
+* Revision 1.19.2.3 2003/08/12 17:36:21 cdaq
+* Add variables for e00-108 (hamlet)
+*
+* Revision 1.19.2.2 2003/07/15 19:04:40 cdaq
+* add calculation of ssinplane
+*
+* Revision 1.19.2.1 2003/04/10 12:40:30 cdaq
+* add e_nonzero and modify p_nonzero. These are used in calculating E_cal/p and beta.
+*
+* Revision 1.19 2002/12/27 22:13:00 jones
+* a. Ioana Niculescu modified total_eloss call
+* b. CSA 4/15/99 -- changed ssbeta to ssbeta_p in total_eloss call
+* to yield reasonable calculation for ssbeta=0 events.
+* c. CSA 4/12/99 -- changed sscorre/p back to ssenergy and ssp so
+* I could keep those names in c_physics.f
+*
+* Revision 1.18 2002/07/31 20:20:58 saw
+* Only try to fill user hists that are defined
+*
+* Revision 1.17 1999/02/10 17:46:15 csa
+* Cleanup and bugfixes (mostly G. Warren)
+*
+* Revision 1.16 1996/11/07 19:51:38 saw
+* (JRA) Correct error in mass calculation
+*
+* Revision 1.15 1996/09/05 20:13:14 saw
+* (JRA) Improved track length calculation. Photon E calc. for (gamma,p)
+*
+* Revision 1.14 1996/04/30 17:13:48 saw
+* (JRA) Add pathlength and rf calculations
+*
+* Revision 1.13 1996/01/24 16:08:14 saw
+* (JRA) Change cpbeam/cebeam to gpbeam/gebeam
+*
+* Revision 1.12 1996/01/17 19:00:50 cdaq
+* (JRA) Calculate q, W for electrons
+*
+* Revision 1.11 1995/10/10 12:54:30 cdaq
+* (JRA) Add call to s_dump_cal, change upper to lower case
+*
+* Revision 1.10 1995/08/31 18:45:26 cdaq
+* (JRA) Add projection to cerenkov mirror pos, fill sdc_sing_res array
+*
+* Revision 1.9 1995/07/20 18:59:15 cdaq
+* (SAW) Declare sind and tand for f2c compatibility
+*
+* Revision 1.8 1995/05/22 19:45:43 cdaq
+* (SAW) Split gen_data_data_structures into gen, hms, sos, and coin parts"
+*
+* Revision 1.7 1995/05/11 17:15:15 cdaq
+* (SAW) Add additional kinematics variables
+*
+* Revision 1.6 1995/04/06 19:37:30 cdaq
+* (SAW) Fix typo
+*
+* Revision 1.5 1995/02/23 13:39:13 cdaq
+* (SAW) Moved best track selection code into S_SELECT_BEST_TRACK (new)
+*
+* Revision 1.4 1995/01/18 20:57:12 cdaq
+* (SAW) Correct some trig and check for negative arg in elastic kin calculation
+*
+* Revision 1.4 1995/01/18 20:00:04 cdaq
+* (SAW) Correct some trig and check for negative arg in elastic kin calculation
+*
+* Revision 1.3 1994/11/23 13:55:03 cdaq
+* (SPB) Recopied from hms file and modified names for SOS
+*
+* Revision 1.2 1994/06/14 03:41:10 cdaq
+* (DFG) Calculate physics quantities
+*
+* Revision 1.1 1994/02/21 16:15:43 cdaq
+* Initial revision
+*
+*--------------------------------------------------------
+ IMPLICIT NONE
+ SAVE
+*
+ character*9 here
+ parameter (here= 'S_PHYSICS')
+*
+ logical ABORT
+ character*(*) err
+ integer ierr
+*
+ include 'gen_data_structures.cmn'
+ INCLUDE 'sos_data_structures.cmn'
+ INCLUDE 'gen_routines.dec'
+ INCLUDE 'gen_constants.par'
+ INCLUDE 'gen_units.par'
+ INCLUDE 'sos_physics_sing.cmn'
+ INCLUDE 'sos_calorimeter.cmn'
+ INCLUDE 'sos_scin_parms.cmn'
+ INCLUDE 'sos_tracking.cmn'
+ INCLUDE 'sos_cer_parms.cmn'
+ INCLUDE 'sos_geometry.cmn'
+ INCLUDE 'sos_id_histid.cmn'
+ INCLUDE 'sos_track_histid.cmn'
+ include 'gen_event_info.cmn'
+ include 'sos_scin_tof.cmn'
+
+* local variables
+
+ integer*4 i,ip,ihit
+ integer*4 itrkfp
+ real*4 cossstheta,sinsstheta
+ real*4 p_nonzero,e_nonzero
+ real*4 xdist,ydist,dist(12),res(12)
+ real*4 tmp,W2
+ real*4 ssp_z
+ real*4 Wvec(4)
+ real*4 sstheta_1st
+ real*4 scalar,mink
+ real*4 ssxp_tar_temp
+*
+*--------------------------------------------------------
+*
+ ierr=0
+ sphi_lab=0.0
+
+ if (ssnum_fptrack.le.0) return ! No Good track
+
+ itrkfp=ssnum_fptrack
+
+* Copy variables for ntuple so we can test on them
+
+ ssdelta = sdelta_tar(ssnum_tartrack)
+ ssx_tar = sx_tar(ssnum_tartrack)
+ ssy_tar = sy_tar(ssnum_tartrack)
+ ssxp_tar = sxp_tar(ssnum_tartrack) ! This is an angle (radians)
+ ssxp_tar_temp = ssxp_tar + s_oopcentral_offset
+ ssyp_tar = syp_tar(ssnum_tartrack) ! This is an angle (radians)
+ ssbeta = sbeta(itrkfp)
+ ssbeta_chisq = sbeta_chisq(itrkfp)
+ sstime_at_fp = stime_at_fp(itrkfp)
+
+ ssx_fp = sx_fp(itrkfp)
+ ssy_fp = sy_fp(itrkfp)
+ ssxp_fp = sxp_fp(itrkfp) ! This is a slope (dx/dz)
+ ssyp_fp = syp_fp(itrkfp) ! This is a slope (dy/dz)
+
+* Correct delta (this must be called AFTER filling
+* focal plane quantites).
+
+ call s_satcorr(ABORT,err)
+ ssp = spcentral*(1.0 + ssdelta/100.) !Momentum in GeV
+ ssenergy = sqrt(ssp*ssp+spartmass*spartmass)
+
+ sstrack_et = strack_et(itrkfp)
+ sstrack_preshower_e = strack_preshower_e(itrkfp)
+ p_nonzero = ssp !reconstructed momentum with 'reasonable' limits.
+ !Used to calc. E_cal/p and beta.
+ p_nonzero = max(0.6*spcentral,p_nonzero)
+ p_nonzero = min(1.4*spcentral,p_nonzero)
+ e_nonzero = sqrt(p_nonzero**2+spartmass**2)
+
+ sscal_suma = scal_e1/p_nonzero !normalized cal. plane sums
+ sscal_sumb = scal_e2/p_nonzero
+ sscal_sumc = scal_e3/p_nonzero
+ sscal_sumd = scal_e4/p_nonzero
+ ssprsum = sscal_suma
+ ssshsum = scal_et/p_nonzero
+ ssprtrk = sstrack_preshower_e/p_nonzero
+ ssshtrk = sstrack_et/p_nonzero
+
+ ssx_sp1 = sx_sp1(itrkfp)
+ ssy_sp1 = sy_sp1(itrkfp)
+ ssxp_sp1 = sxp_sp1(itrkfp)
+ ssx_sp2 = sx_sp2(itrkfp)
+ ssy_sp2 = sy_sp2(itrkfp)
+ ssxp_sp2 = sxp_sp2(itrkfp)
+
+ if (sidscintimes.gt.0) then
+ do ihit=1,snum_scin_hit(itrkfp)
+ call hf1(sidscintimes,sscin_fptime(itrkfp,ihit),1.)
+ enddo
+ endif
+
+ if (sidcuttdc.gt.0) then
+ do ihit=1,sntrack_hits(itrkfp,1)
+ call hf1(sidcuttdc,
+ & float(sdc_tdc(sntrack_hits(itrkfp,ihit+1))),1.)
+ enddo
+ endif
+
+ ssx_dc1 = ssx_fp + ssxp_fp * sdc_1_zpos
+ ssy_dc1 = ssy_fp + ssyp_fp * sdc_1_zpos
+ ssx_dc2 = ssx_fp + ssxp_fp * sdc_2_zpos
+ ssy_dc2 = ssy_fp + ssyp_fp * sdc_2_zpos
+ ssx_s1 = ssx_fp + ssxp_fp * sscin_1x_zpos
+ ssy_s1 = ssy_fp + ssyp_fp * sscin_1x_zpos
+ ssx_cer = ssx_fp + ssxp_fp * scer_mirror_zpos
+ ssy_cer = ssy_fp + ssyp_fp * scer_mirror_zpos
+ ssx_s2 = ssx_fp + ssxp_fp * sscin_2x_zpos
+ ssy_s2 = ssy_fp + ssyp_fp * sscin_2x_zpos
+ ssx_cal = ssx_fp + ssxp_fp * scal_1pr_zpos
+ ssy_cal = ssy_fp + ssyp_fp * scal_1pr_zpos
+
+c Used to use hsp, replace with p_nonzero, to give reasonable limits
+C (+/-40%) to avoid unreasonable hsbeta_p values
+c ssbeta_p = ssp/max(ssenergy,.00001)
+
+ ssbeta_p = p_nonzero/e_nonzero
+
+
+C old 'fit' value for pathlen correction
+C sspathlength = 2.78*ssxp_fp - 3.5*ssxp_fp**2 + 2.9e-3*ssy_fp
+C new 'modeled' value.
+
+ sspathlength = 2.923*ssxp_fp - 6.1065*ssxp_fp**2
+ & +0.006908*ssx_fp*ssxp_fp + 0.001225*ssx_fp
+ & -0.0000324*ssx_fp**2 -21.936*ssyp_fp**2
+
+ sspath_cor = sspathlength/ssbeta_p -
+ & spathlength_central/speed_of_light*(1/max(.01,ssbeta_p) - 1)
+
+ ssrftime = smisc_dec_data(8,1)/9.68
+ & - (sstime_at_fp-sstart_time_center) - sspath_cor
+
+ do ip = 1,4
+ ssscin_elem_hit(ip) = 0
+ enddo
+
+ do i = 1,snum_scin_hit(itrkfp)
+ ip = sscin_plane_num(sscin_hit(itrkfp,i))
+ if (ssscin_elem_hit(ip).eq.0) then
+ ssscin_elem_hit(ip) = sscin_counter_num(sscin_hit(itrkfp,i))
+ ssdedx(ip) = sdedx(itrkfp,i)
+ else ! more than 1 hit in plane
+ ssscin_elem_hit(ip) = 18
+ ssdedx(ip) = sqrt(ssdedx(ip)*sdedx(itrkfp,i))
+ endif
+ enddo
+
+ ssnum_scin_hit = snum_scin_hit(itrkfp)
+ ssnum_pmt_hit = snum_pmt_hit(itrkfp)
+
+ sschi2perdeg = schi2_fp(itrkfp) / float(snfree_fp(itrkfp))
+ ssnfree_fp = snfree_fp(itrkfp)
+
+ do ip = 1, sdc_num_planes
+ sdc_sing_res(ip) = sdc_single_residual(itrkfp,ip)
+ ssdc_track_coord(ip) = sdc_track_coord(itrkfp,ip)
+ enddo
+
+ if (sntrack_hits(itrkfp,1).eq.12 .and. sschi2perdeg.le.4) then
+ xdist = ssx_dc1
+ ydist = ssy_dc1
+ do ip = 1,12
+ if (sdc_readout_x(ip)) then
+ dist(ip) = ydist*sdc_readout_corr(ip)
+ else !readout from top/bottom
+ dist(ip) = xdist*sdc_readout_corr(ip)
+ endif
+ res(ip) = sdc_sing_res(ip)
+ tmp = sdc_plane_wirecoord(itrkfp,ip)
+ $ - sdc_plane_wirecenter(itrkfp,ip)
+ if (tmp.eq.0) then !drift dist = 0
+ res(ip) = abs(res(ip))
+ else
+ res(ip) = res(ip) * (abs(tmp)/tmp) !convert +/- res to near/far res
+ endif
+ enddo
+c write(37,'(12f7.2,12f8.3,12f8.5)') (ssdc_track_coord(ip),ip=1,12),
+c & (dist(ip),ip=1,12),(res(ip),ip=1,12)
+ endif
+
+* Do energy loss, which is particle specific
+
+ sstheta_1st = stheta_lab*TT/180. + atan(ssyp_tar) ! rough scat angle
+c
+ ssinplane = stheta_lab*TT/180. + atan(ssyp_tar) ! In plane scat angle (rad)
+
+ if (spartmass .lt. 2.*mass_electron) then ! for electron
+ if (gtarg_z(gtarg_num).gt.0.) then
+ call total_eloss(2,.true.,sstheta_1st,1.0,sseloss)
+ else
+ sseloss=0.
+ endif
+ else ! not an electron
+ if (gtarg_z(gtarg_num).gt.0.) then
+ call total_eloss(2,.false.,sstheta_1st,ssbeta_p,sseloss)
+ else
+ sseloss=0.
+ endif
+ endif ! particle specific stuff
+
+* Correct ssenergy and ssp for eloss at the target
+* csa 4/12/99 -- changed sscorre/p back to ssenergy and ssp so
+* I could keep those names in c_physics.f
+
+ ssenergy = ssenergy + sseloss
+ ssp = sqrt(ssenergy**2-spartmass**2)
+
+* Begin Kinematic stuff
+
+* coordinate system :
+* z points downstream along beam
+* x points downward
+* y points toward beam left (away from HMS)
+*
+* This coordinate system is a just a simple rotation away from the
+* TRANSPORT coordinate system used in the spectrometers
+
+ ssp_z = ssp/sqrt(1.+ssxp_tar_temp**2+ssyp_tar**2)
+
+* Initial Electron
+
+ ss_kvec(1) = gebeam ! after energy loss in target
+ ss_kvec(2) = 0
+ ss_kvec(3) = 0
+ ss_kvec(4) = gebeam
+
+* Scattered Electron (not meaningful if hadron is in SOS!)
+* calculation without small angle approximation - gaw 98/10/5 csa
+* 12/21/98 -- notice assumption of no out-of-plane offset
+
+ ss_kpvec(1) = ssenergy
+ ss_kpvec(2) = ssp_z*ssxp_tar_temp
+ ss_kpvec(3) = ssp_z*(ssyp_tar*cossthetas+sinsthetas)
+ ss_kpvec(4) = ssp_z*(-ssyp_tar*sinsthetas+cossthetas)
+
+* Angles for Scattered particle. Theta and phi are conventional
+* polar/azimuthal angles defined w.r.t. coordinate system defined
+* above. In rad, of course. Note that phi is around -pi/2 for HMS,
+* +pi/2 for SOS.
+
+ if (abs(ss_kpvec(4)/ssp).le.1.) then
+ sstheta = acos(ss_kpvec(4)/ssp)
+ else
+ sstheta = -10.
+ endif
+ ssphi = atan(ss_kpvec(3)/ss_kpvec(2))
+
+ sinsstheta = sin(sstheta)
+ cossstheta = cos(sstheta)
+
+ ssphi = sphi_lab + ssphi
+c if (ssphi .lt. 0.) ssphi = ssphi + tt
+
+* sszbeam is the intersection of the beam ray with the
+* spectrometer as measured along the z axis.
+
+ if( sinsstheta .eq. 0.) then
+ sszbeam = 0.
+ else
+ sszbeam = sin(ssphi) * ( -ssy_tar + gbeam_y * cossstheta) /
+ $ sinsstheta
+ endif ! end test on sinsstheta=0
+
+* Target particle 4-momentum
+
+ ss_tvec(1) = gtarg_mass(gtarg_num)*m_amu
+ ss_tvec(2) = 0.
+ ss_tvec(3) = 0.
+ ss_tvec(4) = 0.
+
+* Initialize the electron-specific variables
+
+ do i=1,4
+ ss_qvec(i) = -1000.
+ Wvec(i) = -1000.
+ enddo
+
+ ssq3 = -1000.
+ ssbigq2 = -1000.
+ W2 = -1000.
+ sinvmass = -1000.
+
+* Calculate quantities that are meaningful only if
+* the particle in the SOS is an electron.
+
+ if (spartmass .lt. 2.*mass_electron) then
+
+ do i=1,4
+ ss_qvec(i) = ss_kvec(i) - ss_kpvec(i)
+ Wvec(i) = ss_qvec(i) + ss_tvec(i) ! Q+P 4 vector
+ enddo
+
+* Magnitudes
+
+ ssq3 = sqrt(scalar(ss_qvec,ss_qvec))
+ ssbigq2 = -mink(ss_qvec,ss_qvec)
+ W2 = mink(Wvec,Wvec)
+
+ ssomega = gebeam-ssenergy
+ ssthet_gamma = asin((ssenergy*sin(sstheta))/ssq3)
+ ssx_bj = ssbigq2/(2.0*mass_nucleon*ssomega)
+
+ if(W2.ge.0 ) then
+ sinvmass = SQRT(W2)
+ else
+ sinvmass = 0.
+ endif
+
+* Calculate elastic scattering kinematical correction
+
+* t1 = 2.*sphysicsa*gpbeam*cossstheta
+* ta = 4.*gpbeam**2*cossstheta**2 - sphysicsb**2
+
+* SAW 1/17/95. Add the stuff after the or.
+
+* if(ta.eq.0.0 .or. ( sphysicab2 + sphysicsm3b * ta).lt.0.0) then
+* p3=0.
+* else
+* t3 = ta-sphysicsb**2
+* p3 = (T1 - sqrt( sphysicab2 + sphysicsm3b * ta)) / ta
+* endif
+
+* This is the difference in the momentum obtained by tracking
+* and the momentum from elastic kinematics
+
+* sselas_cor = ssp - P3
+
+ endif
+
+ if (.false.) then
+* if (.true.) then
+ write(6,*)' ***********************************'
+ write(6,*)' s_phys: stheta_lab, sphi_lab =',stheta_lab,sphi_lab
+ write(6,*)' s_phys: ssdelta =',ssdelta
+ write(6,*)' s_phys: ssx_tar, ssy_tar =',ssx_tar,ssy_tar
+ write(6,*)' s_phys: ssxp_tar, ssyp_tar =',ssxp_tar,ssyp_tar
+ write(6,*)' s_phys: ssbeta, ssbeta_p =',ssbeta,ssbeta_p
+ write(6,*)' s_phys: ssenergy, ssp =',ssenergy,ssp
+ write(6,*)' s_phys: sseloss =',sseloss
+* write(6,*)' s_phys: sscorre, sscorrp =',sscorre,sscorrp
+ write(6,*)' s_phys: sstheta_1st =',sstheta_1st
+ write(6,*)' s_phys: ssp_z =',ssp_z
+ write(6,*)' s_phys: ss_kvec =',ss_kvec
+ write(6,*)' s_phys: cos/sinsthetas =',cossthetas,sinsthetas
+ write(6,*)' s_phys: ss_kpvec =',ss_kpvec
+ write(6,*)' s_phys: ss_tvec =',ss_tvec
+ write(6,*)' s_phys: ss_qvec =',ss_qvec
+ write(6,*)' s_phys: Wvec =',Wvec
+ write(6,*)' s_phys: ssq3 =',ssq3
+ write(6,*)' s_phys: ssbigq2, W2 =',ssbigq2,W2
+ write(6,*)' s_phys: sstheta, ssphi =',sstheta,ssphi
+ endif
+
+* Write raw timing information for fitting.
+
+ if(sdebugdumptof.ne.0) call s_dump_tof
+ if(sdebugdumpcal.ne.0) call s_dump_cal
+
+* Calculate physics statistics and wire chamber efficencies.
+
+ call s_physics_stat(ABORT,err)
+ ABORT= ierr.ne.0 .or. ABORT
+ IF(ABORT) THEN
+ call G_add_path(here,err)
+ ENDIF
+
+ return
+ end
diff --git a/STRACKING/s_physics_stat.f b/STRACKING/s_physics_stat.f
new file mode 100644
index 0000000..21b1680
--- /dev/null
+++ b/STRACKING/s_physics_stat.f
@@ -0,0 +1,104 @@
+ subroutine s_physics_stat(ABORT,err)
+*--------------------------------------------------------
+*-
+*- Purpose and Methods : Calculate statistics and chamber efficencies for
+*- SOS physics analysis on SOS only part of
+*- event.
+*-
+*-
+*- Required Input BANKS SOS_DECODED_DC
+*- SOS_FOCAL_PLANE
+*-
+*- Output BANKS CTP PARAMETERS
+*-
+*- Output: ABORT - success or failure
+*- : err - reason for failure, if any
+*-
+*- Created 10-JUN-1994 D. F. Geesaman
+* $Log: s_physics_stat.f,v $
+* Revision 1.5 1995/10/10 16:49:32 cdaq
+* (JRA) Comment out some redundant efficiency calculations
+*
+* Revision 1.4 1995/08/31 18:56:53 cdaq
+* (JRA) Add call to s_cer_eff
+*
+* Revision 1.3 1995/05/22 19:45:44 cdaq
+* (SAW) Split gen_data_data_structures into gen, hms, sos, and coin parts"
+*
+* Revision 1.2 1995/02/23 15:38:41 cdaq
+* (JRA) Move scint eff's to s_scin_eff, add call to s_cal_eff
+*
+* Revision 1.1 1994/06/14 04:10:43 cdaq
+* Initial revision
+*
+*--------------------------------------------------------
+ IMPLICIT NONE
+ SAVE
+*
+ character*14 here
+ parameter (here= 's_physics_stat')
+*
+ logical ABORT
+ character*(*) err
+*
+ INCLUDE 'sos_data_structures.cmn'
+ INCLUDE 'gen_routines.dec'
+ INCLUDE 'gen_constants.par'
+ INCLUDE 'gen_units.par'
+ INCLUDE 'sos_geometry.cmn'
+ INCLUDE 'sos_physics_sing.cmn'
+ INCLUDE 'sos_statistics.cmn'
+ INCLUDE 'sos_bypass_switches.cmn'
+*
+* local variables
+c integer*4 goodtrack,tothits,ihit,hitnum,plane
+c real*4 normsigma
+c real*8 ray(4) ! xt,yt,xpt,ypt
+c EXTERNAL S_DPSIFUN
+c REAL*8 S_DPSIFUN
+*--------------------------------------------------------
+*
+ ABORT= .FALSE.
+ err= ' '
+c* increment numbr of tracks
+c sgoodtracksctr = sgoodtracksctr +1
+c* loop over all hists
+c goodtrack = SSNUM_FPTRACK
+c tothits=SNTRACK_HITS(goodtrack,1)
+c if(tothits.gt.0) then
+c* get ray parameters
+c ray(1) = DBLE(SX_FP(goodtrack))
+c ray(2) = DBLE(SY_FP(goodtrack))
+c ray(3) = DBLE(SXP_FP(goodtrack))
+c ray(4) = DBLE(SYP_FP(goodtrack))
+
+c* loop over all hits in track
+c do ihit = 1, tothits
+c hitnum=SNTRACK_HITS(goodtrack,1+ihit)
+c plane = SDC_PLANE_NUM(hitnum)
+c normsigma = (SDC_WIRE_COORD(hitnum)
+c $ - REAL(S_DPSIFUN(ray,plane)))/sdc_sigma(plane)
+c splanehitctr(plane) = splanehitctr(plane) + 1
+c splanesigmasq(plane) = splanesigmasq(plane) + normsigma
+c $ *normsigma
+c smeasuredsigma(plane) = SQRT(splanesigmasq(plane)
+c & / FLOAT(splanehitctr(plane)))
+c schambereff(plane) =FLOAT(splanehitctr(plane))
+c $ /FLOAT(sgoodtracksctr)
+c enddo ! endloop over hits in track
+c endif ! end test on zero hits
+*
+* Drift chamber efficiencies
+ if (sbypass_dc_eff.eq.0) call s_dc_trk_eff
+*
+* Scintillator efficiencies
+ if (sbypass_scin_eff.eq.0) call s_scin_eff
+*
+* Cerenkov efficiencies
+ if (sbypass_cer_eff.eq.0) call s_cer_eff
+*
+* Calorimeter efficiencies
+ if (sbypass_cal_eff.eq.0) call s_cal_eff
+*
+ RETURN
+ END
diff --git a/STRACKING/s_print_decoded_dc.f b/STRACKING/s_print_decoded_dc.f
new file mode 100644
index 0000000..35b7b5f
--- /dev/null
+++ b/STRACKING/s_print_decoded_dc.f
@@ -0,0 +1,60 @@
+ SUBROUTINE s_print_decoded_dc(ABORT,err)
+*--------------------------------------------------------
+*-
+*- Purpose and Methods : Dump SOS_DECODED_DC BANKS
+*-
+*- Required Input BANKS SOSS_DECODED_DC
+*-
+*- Output: ABORT - success or failure
+*- : err - reason for failure, if any
+*-
+*- Created 29-FEB-1994 D. F. Geesaman
+* $Log: s_print_decoded_dc.f,v $
+* Revision 1.4 1995/10/10 16:52:50 cdaq
+* (JRA) Remove drift distance from print out
+*
+* Revision 1.3 1995/05/22 19:45:44 cdaq
+* (SAW) Split gen_data_data_structures into gen, hms, sos, and coin parts"
+*
+* Revision 1.2 1995/04/06 19:38:33 cdaq
+* (JRA) Remove SDC_WIRE_COORD
+*
+* Revision 1.1 1994/03/24 20:29:16 cdaq
+* Initial revision
+*
+*--------------------------------------------------------
+ IMPLICIT NONE
+ SAVE
+*
+ character*50 here
+ parameter (here= 's_print_decoded_dc')
+*
+ logical ABORT
+ character*(*) err
+*
+ integer*4 j
+ include 'sos_data_structures.cmn'
+ include 'gen_constants.par'
+ include 'gen_units.par'
+ include 'sos_tracking.cmn'
+ include 'sos_geometry.cmn'
+*
+*--------------------------------------------------------
+ ABORT = .FALSE.
+ err = ' '
+ write(sluno,'('' SOS_DECODED_DC BANKS'')')
+ write(sluno,'('' SDC_TOT_HITS='',I4)') SDC_TOT_HITS
+ if(SDC_TOT_HITS.GT.0) then
+ write(sluno,'('' SDC_HITS_PER_PLANE'')')
+ write(sluno,'('' Plane='',18i4)') (j,j=1,sdc_num_planes)
+ write(sluno,'(7x,18i4)')
+ & (SDC_HITS_PER_PLANE(j),j=1,sdc_num_planes)
+ write(sluno,'('' Num Plane Wire Wire Center '',
+ & ''TDC Value RAW DRIFT TIME'')')
+ write(sluno,'(1x,i2,2x,i3,7x,i4,5x,F10.5,i8,2x,F10.5)')
+ & (j,SDC_PLANE_NUM(j),SDC_WIRE_NUM(j),
+ & SDC_WIRE_CENTER(j),SDC_TDC(j),SDC_DRIFT_TIME(j),
+ & j=1,SDC_TOT_HITS)
+ endif
+ RETURN
+ END
diff --git a/STRACKING/s_print_links.f b/STRACKING/s_print_links.f
new file mode 100644
index 0000000..477af02
--- /dev/null
+++ b/STRACKING/s_print_links.f
@@ -0,0 +1,27 @@
+ subroutine s_print_links
+* prints the output of link matching
+* d.f. geesaman 7 Sept 1993
+* $Log: s_print_links.f,v $
+* Revision 1.2 1995/05/22 19:45:45 cdaq
+* (SAW) Split gen_data_data_structures into gen, hms, sos, and coin parts"
+*
+* Revision 1.1 1994/02/21 16:15:59 cdaq
+* Initial revision
+*
+*
+ implicit none
+ include "sos_data_structures.cmn"
+ include "sos_tracking.cmn"
+ integer*4 itrack,ihit
+ write(sluno,
+ & '('' NUMBER OF TRACKS FROM SOS LINKED STUBS='',i4)') SNTRACKS_FP
+ if(SNTRACKS_FP.gt.0) then
+ write(sluno,'('' Track HITS'')')
+ do itrack=1,SNTRACKS_FP
+ write(sluno,1000) itrack,(SNTRACK_HITS(itrack,ihit),
+ & ihit=2,SNTRACK_HITS(itrack,1)+1)
+1000 format(2x,i3,2x,24i3)
+ enddo
+ endif
+ return
+ end
diff --git a/STRACKING/s_print_pr.f b/STRACKING/s_print_pr.f
new file mode 100644
index 0000000..bcdb58f
--- /dev/null
+++ b/STRACKING/s_print_pr.f
@@ -0,0 +1,39 @@
+ subroutine s_print_pr
+* subroutine to dump output of S_PATTERN_RECOGNITION
+* All the results are contained in sos_tracking.inc
+* d.f. geesaman 5 September 1993
+* $Log: s_print_pr.f,v $
+* Revision 1.2 1995/05/22 19:45:45 cdaq
+* (SAW) Split gen_data_data_structures into gen, hms, sos, and coin parts"
+*
+* Revision 1.1 1994/02/21 16:37:52 cdaq
+* Initial revision
+*
+ implicit none
+ include "sos_data_structures.cmn"
+ include "sos_tracking.cmn"
+ include "sos_geometry.cmn"
+* local variables
+ integer*4 i,j
+ write(sluno,'('' SOS PATTERN RECOGNITION RESULTS'')')
+ write(sluno,'('' chamber='',i3,'' number of hits='',i3)')
+ & (i,sncham_hits(i),i=1,sdc_num_chambers)
+ write(sluno,'('' Total number of space points found='',i3)')
+ & snspace_points_tot
+ write(sluno,'('' chamber number'',i2,'' number of points='',i3)')
+ & (i,snspace_points(i),i=1,sdc_num_chambers)
+ write(sluno,'('' Space point requirements'')')
+ write(sluno,'('' chamber='',i3,'' min_hit='',i4,'' min_combos='',i3)')
+ & (i,smin_hit(i),smin_combos(i),i=1,sdc_num_chambers)
+ if(snspace_points_tot.ge.1) then
+ write(sluno,'('' point x y number number hits'')')
+ write(sluno,'('' number hits combos'')')
+1001 format(3x,i3,f10.4,f10.4,3x,i3,6x,i3,5x,11i3)
+ do i=1,snspace_points_tot
+ write(sluno,1001) i, sspace_points(i,1),sspace_points(i,2),
+ & sspace_point_hits(i,1), sspace_point_hits(i,2),
+ & (sspace_point_hits(i,j+2),j=1,sspace_point_hits(i,1))
+ enddo
+ endif
+ return
+ end
diff --git a/STRACKING/s_print_raw_dc.f b/STRACKING/s_print_raw_dc.f
new file mode 100644
index 0000000..7b3157c
--- /dev/null
+++ b/STRACKING/s_print_raw_dc.f
@@ -0,0 +1,48 @@
+ SUBROUTINE s_print_raw_dc(ABORT,err)
+*--------------------------------------------------------
+*-
+*- Purpose and Methods : Dump SOS_RAW_DC BANKS
+*-
+*- Required Input BANKS SOS_RAW_DC
+*-
+*- Output: ABORT - success or failure
+*- : err - reason for failure, if any
+*-
+*- Created 29-FEB-1994 D. F. Geesaman
+* $Log: s_print_raw_dc.f,v $
+* Revision 1.2 1995/05/22 19:45:46 cdaq
+* (SAW) Split gen_data_data_structures into gen, hms, sos, and coin parts"
+*
+* Revision 1.1 1994/03/24 20:30:01 cdaq
+* Initial revision
+*
+*--------------------------------------------------------
+ IMPLICIT NONE
+ SAVE
+*
+ character*50 here
+ parameter (here= 's_print_raw_dc')
+*
+ logical ABORT
+ character*(*) err
+*
+ integer*4 j
+ include 'sos_data_structures.cmn'
+ include 'gen_constants.par'
+ include 'gen_units.par'
+ include 'sos_tracking.cmn'
+ include 'sos_geometry.cmn'
+*
+*--------------------------------------------------------
+ ABORT = .FALSE.
+ err = ' '
+ write(sluno,'('' SOS_RAW_DC BANKS'')')
+ write(sluno,'('' SDC _RAW_TOT_HITS='',I4)') SDC_RAW_TOT_HITS
+ if(SDC_RAW_TOT_HITS.GT.0) then
+ write(sluno,'('' Num Plane Wire TDC Value'')')
+ write(sluno,'(1x,i2,2x,i3,7x,i4,5x,i10)')
+ & (j,SDC_RAW_PLANE_NUM(j),SDC_RAW_WIRE_NUM(j),
+ & SDC_RAW_TDC(j),j=1,SDC_RAW_TOT_HITS)
+ endif
+ RETURN
+ END
diff --git a/STRACKING/s_print_stubs.f b/STRACKING/s_print_stubs.f
new file mode 100644
index 0000000..a87584c
--- /dev/null
+++ b/STRACKING/s_print_stubs.f
@@ -0,0 +1,44 @@
+ subroutine s_print_stubs
+* subroutine to dump output of S_LEFT_RIGHT
+* All the results are contained in sos_tracking.inc
+* d.f. geesaman 5 September 1993
+* $Log: s_print_stubs.f,v $
+* Revision 1.3 1995/05/22 19:45:46 cdaq
+* (SAW) Split gen_data_data_structures into gen, hms, sos, and coin parts"
+*
+* Revision 1.2 1995/05/11 21:06:54 cdaq
+* (JRA) ???
+*
+* Revision 1.1 1994/02/21 16:38:06 cdaq
+* Initial revision
+*
+ implicit none
+ include "sos_data_structures.cmn"
+ include "sos_tracking.cmn"
+ include "sos_geometry.cmn"
+* local variables
+ integer*4 i,j,k
+ write(sluno,'('' SOS STUB FIT RESULTS'')')
+ if(snspace_points_tot.ge.1) then
+ write(sluno,'(''point x_t y_t '',
+ & '' xp_t yp_t'')')
+ write(sluno,'('' [cm] [cm] '',
+ & '' [rad] [rad]'')')
+1001 format(3x,i3,4x,4e15.7)
+ do i=1,snspace_points_tot
+ write(sluno,1001) i,(sbeststub(i,j),j=1,4)
+ enddo
+ write(sluno,'('' hit plane SDC_WIRE_CENTER SDC_DRIFT_DIS '',
+ & '' SDC_WIRE_COORD'')')
+ do i=1,snspace_points_tot
+ do j=1,sspace_point_hits(i,1)
+ k=sspace_point_hits(i,2+j)
+ write(sluno,1002) k,sdc_plane_num(k),SDC_WIRE_CENTER(k),
+ & SDC_DRIFT_DIS(k),SDC_WIRE_COORD(k)
+ 1002 format(2x,i3,i4,4x,e16.8,2x,e16.8,2x,e16.8)
+ enddo
+ write(sluno,*) ' '
+ enddo
+ endif
+ return
+ end
diff --git a/STRACKING/s_print_tar_tracks.f b/STRACKING/s_print_tar_tracks.f
new file mode 100644
index 0000000..3d4f79e
--- /dev/null
+++ b/STRACKING/s_print_tar_tracks.f
@@ -0,0 +1,71 @@
+ subroutine s_print_tar_tracks
+*______________________________________________________________________________
+*
+* Facility: CEBAF Hall-C software.
+*
+* Module: s_print_tar_tracks
+*
+* Version: 0.1 (In development) 18-Nov-1993 (DHP)
+*
+* Abstract: Dump selected track data in SOS_TARGET common block.
+*
+* Author: David H. Potterveld, Argonne National Lab, Nov. 1993
+* modified D. F. Geesaman 21 Jan 94
+* changed name for s_target_dump to s_print_tar_tracks
+* made output lun sluno
+* $Log: s_print_tar_tracks.f,v $
+* Revision 1.3 1995/05/22 19:45:46 cdaq
+* (SAW) Split gen_data_data_structures into gen, hms, sos, and coin parts"
+*
+* Revision 1.2 1994/05/13 03:20:37 cdaq
+* (DFG) Check for more than zero tracks
+*
+* Revision 1.1 1994/02/21 16:38:38 cdaq
+* Initial revision
+*
+*______________________________________________________________________________
+
+ implicit none
+
+! Include files.
+
+ include 'sos_data_structures.cmn'
+ include 'sos_tracking.cmn'
+
+! Misc. variables.
+
+ integer*4 itrk
+
+* ============================= Executable Code ===============================
+ if(sntracks_tar .gt. 0 ) then
+! Write out header.
+ write (sluno,1001) 'SOS TARGET TRACKS'
+ write (sluno,1002)
+
+! Loop over tracks.
+
+ do itrk = 1,sntracks_tar
+
+! Write out data lines.
+
+ write (sluno,1003) itrk,
+ > sx_tar(itrk),sxp_tar(itrk),
+ > sy_tar(itrk),syp_tar(itrk),
+ > sz_tar(itrk),
+ > sdelta_tar(itrk),
+ > sp_tar(itrk)
+
+ enddo
+ endif
+ return
+
+* ============================ Format Statements ==============================
+
+ 1001 format(a)
+ 1002 format(/,1x,'TRK',t10,'SX_TAR',t20,'SXP_TAR',t30,'SY_TAR',t40
+ $ ,'SYP_TAR',t50,'SZ_TAR',t60,'SDELTA_TAR',t72,'SP_TAR')
+ 1003 format(1x,i2,t8,3(f10.6,f10.5),f10.5)
+
+ end
+
+
diff --git a/STRACKING/s_print_tracks.f b/STRACKING/s_print_tracks.f
new file mode 100644
index 0000000..9b28485
--- /dev/null
+++ b/STRACKING/s_print_tracks.f
@@ -0,0 +1,62 @@
+ subroutine s_print_tracks
+* prints the output of track matching
+* d.f. geesaman 7 Sept 1993
+* $Log: s_print_tracks.f,v $
+* Revision 1.3 1995/05/22 19:45:47 cdaq
+* (SAW) Split gen_data_data_structures into gen, hms, sos, and coin parts"
+*
+* Revision 1.2 1994/06/07 04:43:40 cdaq
+* (DFG) print warning if ssingle_stub is set
+*
+* Revision 1.1 1994/02/21 16:40:41 cdaq
+* Initial revision
+*
+*
+ implicit none
+ include "sos_data_structures.cmn"
+ include "sos_tracking.cmn"
+*
+ external S_DPSIFUN
+ real*8 S_DPSIFUN
+* local variables
+ integer*4 itrack,ihit
+ integer*4 hitnum,planenum
+ real*8 ray(snum_fpray_param),calculated_position,residual
+ if(SNTRACKS_FP.gt.0) then
+ if(ssingle_stub.ne.0) then
+ write(sluno,'('' Warning - ssingle_stub is set'')')
+ endif
+ write(sluno,'('' point x_t y_t '',
+ & '' xp_t yp_t chi**2 degrees of'')')
+ write(sluno,'('' [cm] [cm] '',
+ & '' [rad] [rad] freedom'')')
+ do itrack=1,SNTRACKS_FP
+ 1001 format(1x,i3,2x,4e14.6,e10.3,1x,i3)
+ write(sluno,1001) itrack,SX_FP(itrack),SY_FP(itrack),
+ & SXP_FP(itrack),SYP_FP(itrack),SCHI2_FP(itrack),
+ & SNFREE_FP(itrack)
+ enddo
+ do itrack=1,SNTRACKS_FP
+ strack_fit_num=itrack
+ ray(1)=dble(SX_FP(itrack))
+ ray(2)=dble(SY_FP(itrack))
+ ray(3)=dble(SXP_FP(itrack))
+ ray(4)=dble(SYP_FP(itrack))
+ write(sluno,'(a,i3)') ' Hits in SOS track number',itrack
+ write(sluno,'(a)')
+ & ' hit plane SDC_WIRE_COORD FIT POSITION RESIDUAL'
+*
+ do ihit=1,SNTRACK_HITS(itrack,1)
+ hitnum=SNTRACK_HITS(itrack,ihit+1)
+ planenum=SDC_PLANE_NUM(hitnum)
+ calculated_position=S_DPSIFUN(ray,planenum)
+ residual=dble(SDC_WIRE_COORD(hitnum))-calculated_position
+ write(sluno,1011) hitnum,planenum,SDC_WIRE_COORD(hitnum),
+ & calculated_position,residual
+ 1011 format(3x,i3,3x,i3,3x,e15.7,2d15.7)
+ enddo
+ enddo
+ endif
+ return
+ end
+
diff --git a/STRACKING/s_prt_cal_clusters.f b/STRACKING/s_prt_cal_clusters.f
new file mode 100644
index 0000000..65e0aad
--- /dev/null
+++ b/STRACKING/s_prt_cal_clusters.f
@@ -0,0 +1,75 @@
+*=======================================================================
+ subroutine s_prt_cal_clusters
+*=======================================================================
+*-
+*- Dumps the calorimeter cluster data
+*-
+*- Created: 20 Mar 1994 Tsolak A. Amatuni
+*- Modified 25 Mar 1994 DFG
+*- change name and lun
+* $Log: s_prt_cal_clusters.f,v $
+* Revision 1.3 1999/01/29 17:34:58 saw
+* Add variables for second tubes on shower counter
+*
+* Revision 1.2 1995/05/22 19:45:47 cdaq
+* (SAW) Split gen_data_data_structures into gen, hms, sos, and coin parts"
+*
+* Revision 1.1 1994/04/13 18:19:30 cdaq
+* Initial revision
+*
+*-----------------------------------------------------------------------
+*
+*
+ implicit none
+ save
+*
+ integer*4 nh !Hit number
+ integer*4 nc !Cluster number
+*
+ include 'sos_data_structures.cmn'
+ include 'sos_calorimeter.cmn'
+ include 'sos_tracking.cmn'
+*
+*
+ write(slun_dbg_cal,10) snclusters_cal
+ 10 format(///' SOS Calorimeter Cluster Data', /,
+ & ' Total Number of Clusters:',i3,//,
+ & ' Hit # Cluster #')
+*
+ if(scal_num_hits.le.0) return
+*
+*-----Print the link pointer to cluster number
+ do nh=1,scal_num_hits
+ write(slun_dbg_cal,20) nh,scluster_hit(nh)
+ 20 format(i5,7x,i5)
+ enddo
+*
+ if(snclusters_cal.le.0) return
+*
+*-----Print the cluster parameters
+ write(slun_dbg_cal,30)
+ 30 format(/,
+ &' Cluster',/,
+ &' #(size) XC[cm] E1[GeV] E2[GeV] E3[GeV] E4[GeV] ET[GeV]] E1_POS[GeV] E1_NEG[GeV] E2_POS[GeV] E2_NEG[GeV] ')
+*
+ if(snclusters_cal.le.0) return
+*
+ do nc=1,snclusters_cal
+ write(slun_dbg_cal,40)
+ & nc,
+ & scluster_size(nc),
+ & scluster_xc(nc),
+ & scluster_e1(nc),
+ & scluster_e2(nc),
+ & scluster_e3(nc),
+ & scluster_e4(nc),
+ & scluster_et(nc),
+ & scluster_e1_pos(nc),
+ & scluster_e1_neg(nc),
+ & scluster_e2_pos(nc),
+ & scluster_e2_neg(nc)
+ 40 format(i3,'(',i3,')',4x,f6.2,5(1x,f8.4))
+ enddo
+*
+ return
+ end
diff --git a/STRACKING/s_prt_cal_decoded.f b/STRACKING/s_prt_cal_decoded.f
new file mode 100644
index 0000000..6c289bd
--- /dev/null
+++ b/STRACKING/s_prt_cal_decoded.f
@@ -0,0 +1,52 @@
+*=======================================================================
+ subroutine s_prt_cal_decoded
+*=======================================================================
+*-
+*- Dumps the decoded calorimeter data
+*-
+*- Created: 19 Mar 1994 Tsolak A. Amatuni
+*- Modified: 25 March 1994 DFG
+*- Change name
+*- Change lun
+* $Log: s_prt_cal_decoded.f,v $
+* Revision 1.2 1995/05/22 19:45:48 cdaq
+* (SAW) Split gen_data_data_structures into gen, hms, sos, and coin parts"
+*
+* Revision 1.1 1994/04/13 18:19:52 cdaq
+* Initial revision
+*
+*-----------------------------------------------------------------------
+*
+ implicit none
+ save
+*
+ integer*4 hit !Hit number
+*
+ include 'sos_data_structures.cmn'
+ include 'sos_calorimeter.cmn'
+ include 'sos_tracking.cmn'
+*
+ write(slun_dbg_cal,10) snhits_cal
+ 10 format(///' SOS Calorimeter Decoded Data ',/,
+ & ' Total Number of Hits:',i4, //,
+ & ' Hit # X[cm] Z[cm] Energy Deposition[GeV]')
+*
+*
+ if(snhits_cal.le.0) return
+*
+ do hit=1,snhits_cal
+ write(slun_dbg_cal,20)
+ & hit,sblock_xc(hit),sblock_zc(hit),sblock_de(hit)
+ 20 format(i5,3x,f6.2,1x,f7.2,5x,f9.4)
+ enddo
+*
+ write(slun_dbg_cal,30) scal_e1,scal_e2,scal_e3,scal_e4,scal_et
+ 30 format( /,' Column # Energy Deposition[GeV]',/,
+ & ' 1 ',f9.4 ,/,
+ & ' 2 ',f9.4 ,/,
+ & ' 3 ',f9.4 ,/,
+ & ' 4 ',f9.4 ,/,
+ & ' Total:',f9.4)
+*
+ return
+ end
diff --git a/STRACKING/s_prt_cal_raw.f b/STRACKING/s_prt_cal_raw.f
new file mode 100644
index 0000000..95cfbab
--- /dev/null
+++ b/STRACKING/s_prt_cal_raw.f
@@ -0,0 +1,64 @@
+*=======================================================================
+ subroutine s_prt_cal_raw
+*=======================================================================
+*-
+*- Dumps the raw calorimeter data
+*-
+*- Created: 19 Mar 1994 Tsolak A. Amatuni
+*- Modified 25 Mar 1994 DFG
+*- Change name
+*- Change lun
+*- 7 Apr 1994 DFG Change print order
+* $Log: s_prt_cal_raw.f,v $
+* Revision 1.4 1999/01/29 17:34:59 saw
+* Add variables for second tubes on shower counter
+*
+* Revision 1.3 1995/08/31 20:41:54 cdaq
+* (JRA) Subtract pedestal in raw data dump
+*
+* Revision 1.2 1995/05/22 19:45:48 cdaq
+* (SAW) Split gen_data_data_structures into gen, hms, sos, and coin parts"
+*
+* Revision 1.1 1994/04/13 18:20:03 cdaq
+* Initial revision
+*
+*-----------------------------------------------------------------------
+*
+ implicit none
+ save
+*
+ integer*4 hit !Hit number
+ integer*4 row,col,nb
+ real*4 adc_pos, adc_neg
+
+*
+ include 'sos_data_structures.cmn'
+ include 'sos_calorimeter.cmn'
+ include 'sos_tracking.cmn'
+*
+ write(slun_dbg_cal,10) scal_tot_hits
+ 10 format(///' SOS Calorimeter Raw Data ',/,
+ & ' Total Number of Hits:',i3, //,
+ & ' Hit # Column # Row # ADC Value')
+*
+*
+ if(scal_tot_hits.le.0) return
+*
+ do hit=1,scal_tot_hits
+ row=scal_row(hit)
+ col=scal_column(hit)
+ nb =row+smax_cal_rows*(col-1)
+ adc_pos=float(scal_adc_pos(hit))-scal_pos_ped_mean(nb)
+ adc_neg=float(scal_adc_neg(hit))-scal_neg_ped_mean(nb)
+ if(col.le.scal_num_neg_columns) then
+ write(slun_dbg_cal,20)
+ & hit,scal_column(hit),scal_row(hit),adc_pos,adc_neg
+ 20 format(i5,3x,i5,4x,i5,7x,2f8.1)
+ else
+ write(slun_dbg_cal,20)
+ & hit,scal_column(hit),scal_row(hit),adc_pos
+ endif
+ enddo
+*
+ return
+ end
diff --git a/STRACKING/s_prt_cal_sparsified.f b/STRACKING/s_prt_cal_sparsified.f
new file mode 100644
index 0000000..c761e89
--- /dev/null
+++ b/STRACKING/s_prt_cal_sparsified.f
@@ -0,0 +1,47 @@
+*=======================================================================
+ subroutine s_prt_cal_sparsified
+*=======================================================================
+*-
+*- Dumps the sparsified calorimeter data
+*-
+*- Created: 19 Mar 1994 Tsolak A. Amatuni
+*- Modified 25 Mar 1994 DFG
+*- change name and lun
+* $Log: s_prt_cal_sparsified.f,v $
+* Revision 1.3 1999/01/29 17:34:59 saw
+* Add variables for second tubes on shower counter
+*
+* Revision 1.2 1995/05/22 19:45:49 cdaq
+* (SAW) Split gen_data_data_structures into gen, hms, sos, and coin parts"
+*
+* Revision 1.1 1994/04/13 18:20:30 cdaq
+* Initial revision
+*
+*-----------------------------------------------------------------------
+*
+ implicit none
+ save
+*
+ integer*4 hit !Hit number
+*
+ include 'sos_data_structures.cmn'
+ include 'sos_calorimeter.cmn'
+ include 'sos_tracking.cmn'
+*
+ write(slun_dbg_cal,10) scal_num_hits
+ 10 format(///' SOS Calorimeter Sparsified Data ',/,
+ & ' Total Number of Hits:',i7, //,
+ & ' Hit # Row # Column # ADC - PED')
+*
+*
+ if(scal_num_hits.le.0) return
+*
+ do hit=1,scal_num_hits
+ write(slun_dbg_cal,20)
+ & hit,scal_rows(hit),scal_cols(hit),scal_adcs_pos(hit)
+ & ,scal_adcs_neg(hit)
+ 20 format(i5,3x,i5,4x,i5,6x,2f8.2)
+ enddo
+*
+ return
+ end
diff --git a/STRACKING/s_prt_cal_tests.f b/STRACKING/s_prt_cal_tests.f
new file mode 100644
index 0000000..54b72b9
--- /dev/null
+++ b/STRACKING/s_prt_cal_tests.f
@@ -0,0 +1,50 @@
+*=======================================================================
+ subroutine s_prt_cal_tests
+*=======================================================================
+*-
+*- Dumps the calorimeter particle ID information
+*-
+*- Created: 20 Mar 1994 Tsolak A. Amatuni
+*- Modified 25 Mar 1994 DFG
+*- Change name and lun
+* $Log: s_prt_cal_tests.f,v $
+* Revision 1.2 1995/05/22 19:45:49 cdaq
+* (SAW) Split gen_data_data_structures into gen, hms, sos, and coin parts"
+*
+* Revision 1.1 1994/04/13 18:20:44 cdaq
+* Initial revision
+*
+*-----------------------------------------------------------------------
+*
+*
+ implicit none
+ save
+*
+ integer*4 nt !Detector track number
+*
+ include 'sos_data_structures.cmn'
+ include 'sos_calorimeter.cmn'
+ include 'sos_tracking.cmn'
+*
+*
+ write(slun_dbg_cal,10) sntracks_fp
+ 10 format(///' SOS Calorimeter Particle ID Quantities', /,
+ & ' Total Number of Detector Tracks:',i3,//,
+ &' Track # N-blocks E1[GeV] E2[GeV] E3[GeV] E4[GeV] Et[GeV]')
+*
+ if(sntracks_fp.le.0) return
+*
+ do nt=1,sntracks_fp
+ write(slun_dbg_cal,20)
+ & nt,
+ & snblocks_cal(nt),
+ & strack_e1(nt),
+ & strack_e2(nt),
+ & strack_e3(nt),
+ & strack_e4(nt),
+ & strack_et(nt)
+ 20 format(3x,i5,5x,i5,5(1x,f8.4))
+ enddo
+*
+ return
+ end
diff --git a/STRACKING/s_prt_cal_tracks.f b/STRACKING/s_prt_cal_tracks.f
new file mode 100644
index 0000000..5e4fdbb
--- /dev/null
+++ b/STRACKING/s_prt_cal_tracks.f
@@ -0,0 +1,47 @@
+*=======================================================================
+ subroutine s_prt_cal_tracks
+*=======================================================================
+*-
+*- Dumps the calorimeter track quantities
+*-
+*- Created: 20 Mar 1994 Tsolak A. Amatuni
+*- Modified 25 Mar 1994 DFG
+*- Change name and lun
+* $Log: s_prt_cal_tracks.f,v $
+* Revision 1.2 1995/05/22 19:45:49 cdaq
+* (SAW) Split gen_data_data_structures into gen, hms, sos, and coin parts"
+*
+* Revision 1.1 1994/04/13 18:21:11 cdaq
+* Initial revision
+*
+*-----------------------------------------------------------------------
+*
+*
+ implicit none
+ save
+*
+ integer*4 nt !Detector track number
+*
+ include 'sos_data_structures.cmn'
+ include 'sos_calorimeter.cmn'
+ include 'sos_tracking.cmn'
+*
+*
+ write(slun_dbg_cal,10) sntracks_fp
+ 10 format(///' SOS Calorimeter Track Quantities', /,
+ & ' Total Number of Detector Tracks:',i3,//,
+ & ' Track # Cluster # X[cm] Y[cm]')
+*
+ if(sntracks_fp.le.0) return
+*
+ do nt=1,sntracks_fp
+ write(slun_dbg_cal,20)
+ & nt,scluster_track(nt),strack_xc(nt),strack_yc(nt)
+ 20 format(3x,i5,7x,i5,2(2x,f6.2))
+ enddo
+*
+ write(slun_dbg_cal,30) sntracks_cal
+ 30 format(' Total Number of Calorimeter Tracks:',i3)
+*
+ return
+ end
diff --git a/STRACKING/s_prt_dec_scin.f b/STRACKING/s_prt_dec_scin.f
new file mode 100644
index 0000000..4126941
--- /dev/null
+++ b/STRACKING/s_prt_dec_scin.f
@@ -0,0 +1,89 @@
+ SUBROUTINE s_prt_dec_scin(ABORT,err)
+*--------------------------------------------------------
+*-
+*- Purpose and Methods : Dump SOS_DECODED_SCIN BANKS
+*-
+*- Required Input BANKS SOS_DECODED_SCIN
+*-
+*- Output: ABORT - success or failure
+*- : err - reason for failure, if any
+*-
+*- Created 29-FEB-1994 D. F. Geesaman
+* $Log: s_prt_dec_scin.f,v $
+* Revision 1.7 1996/01/17 19:00:09 cdaq
+* (JRA)
+*
+* Revision 1.6 1995/05/22 19:45:50 cdaq
+* (SAW) Split gen_data_data_structures into gen, hms, sos, and coin parts"
+*
+* Revision 1.5 1995/04/06 19:40:51 cdaq
+* (SAW) Fix typo
+*
+* Revision 1.4 1995/02/10 19:57:47 cdaq
+* (JRA) Make sscin_all_adc_pos/neg floating
+*
+* Revision 1.4 1995/02/10 19:13:11 cdaq
+* (JRA) Make sscin_all_adc_pos/neg floating
+*
+* Revision 1.3 1994/11/23 13:56:18 cdaq
+* (SPB) Recopied from hms file and modified names for SOS
+*
+* Revision 1.2 1994/05/13 03:22:48 cdaq
+* (DFG) Fix logical format statement
+*
+* Revision 1.1 1994/04/13 18:21:29 cdaq
+* Initial revision
+*
+*--------------------------------------------------------
+ IMPLICIT NONE
+ SAVE
+*
+ character*50 here
+ parameter (here= 's_prt_dec_scin')
+*
+ logical ABORT
+ character*(*) err
+*
+ integer*4 j
+ include 'sos_data_structures.cmn'
+ include 'gen_constants.par'
+ include 'gen_units.par'
+ include 'sos_tracking.cmn'
+*
+*--------------------------------------------------------
+ ABORT = .FALSE.
+ err = ' '
+
+ write(sluno,'('' ***SOS_REAL_SCIN BANKS***'')')
+ write(sluno,'('' SSCIN_TOT_HITS='',I4)') SSCIN_TOT_HITS
+ if(SSCIN_TOT_HITS.GT.0) then
+ write(sluno,'('' Num Plane Counter ADC_POS'',
+ & ''ADC_NEG TDC_POS TDC_NEG'')')
+ write(sluno,'(1x,i2,2x,i3,5x,i4,8x,2f8.2,2i8)')
+ & (j,SSCIN_PLANE_NUM(j),SSCIN_COUNTER_NUM(j),
+ & SSCIN_ADC_POS(j),SSCIN_ADC_NEG(j),
+ & SSCIN_TDC_POS(j),SSCIN_TDC_NEG(j),
+ & j=1,SSCIN_TOT_HITS )
+ endif
+
+ write(sluno,'('' SOS_DECODED_SCIN BANKS'')')
+ if(SSCIN_TOT_HITS.GT.0) then
+ write(sluno,'('' Scintillator hits per plane'')')
+ write(sluno,'('' Plane '',10i4)') (j,j=1,SNUM_SCIN_PLANES)
+ write(sluno,'('' Number '',10i4)')
+ & (SSCIN_HITS_PER_PLANE(j),j=1,SNUM_SCIN_PLANES)
+ write(sluno,'('' Num ZPOS CENTER HIT_COORD SLOP'',
+ & '' COR_TDC TWO_GOOD'')')
+ write(sluno,'(1x,i2,2x,4f9.3,f10.3,4x,l2)')
+ & (j,SSCIN_ZPOS(j),SSCIN_CENTER_COORD(j),
+ & SSCIN_DEC_HIT_COORD(j),
+ & SSCIN_SLOP(j),SSCIN_COR_TIME(j),
+ & STWO_GOOD_TIMES(j),
+ & j=1,SSCIN_TOT_HITS)
+ write(sluno,'('' SGOOD_START_TIME='', l2)')
+ & SGOOD_START_TIME
+ write(sluno,'('' SSTART_TIME='',e10.4)') SSTART_TIME
+ write(sluno,*)
+ endif
+ RETURN
+ END
diff --git a/STRACKING/s_prt_raw_scin.f b/STRACKING/s_prt_raw_scin.f
new file mode 100644
index 0000000..d5276d7
--- /dev/null
+++ b/STRACKING/s_prt_raw_scin.f
@@ -0,0 +1,82 @@
+ SUBROUTINE s_prt_raw_scin(ABORT,err)
+*--------------------------------------------------------
+*-
+*- Purpose and Methods : Dump SOS_RAW_SCIN BANKS
+*-
+*- Required Input BANKS SOS_RAW_SCIN
+*-
+*- Output: ABORT - success or failure
+*- : err - reason for failure, if any
+*-
+*- Created 29-FEB-1994 D. F. Geesaman
+* $Log: s_prt_raw_scin.f,v $
+* Revision 1.6 2003/09/05 19:58:29 jones
+* Merge in online03 changes (mkj)
+*
+* Revision 1.5.2.1 2003/04/10 12:42:26 cdaq
+* Print out additional info on raw scint
+*
+* Revision 1.5 1995/07/20 18:59:35 cdaq
+* (SAW) Fix format
+*
+* Revision 1.4 1995/05/22 19:45:50 cdaq
+* (SAW) Split gen_data_data_structures into gen, hms, sos, and coin parts"
+*
+* Revision 1.3 1995/04/06 19:42:03 cdaq
+* (JRA) SSCIN_TOT_HITS -> SSCIN_ALL_TOT_HITS
+*
+* Revision 1.2 1994/11/23 13:56:57 cdaq
+* (SPB) Recopied from hms file and modified names for SOS
+*
+* Revision 1.1 1994/04/13 18:21:45 cdaq
+* Initial revision
+*
+*--------------------------------------------------------
+ IMPLICIT NONE
+ SAVE
+*
+ character*50 here
+ parameter (here= 's_prt_raw_scin')
+*
+ logical ABORT
+ character*(*) err
+*
+ integer*4 j
+ include 'sos_data_structures.cmn'
+ include 'gen_constants.par'
+ include 'gen_units.par'
+ include 'sos_tracking.cmn'
+ include 'sos_scin_parms.cmn'
+*
+*--------------------------------------------------------
+ ABORT = .FALSE.
+ err = ' '
+ write(sluno,'('' SOS_RAW_SCIN BANKS'')')
+ write(sluno,'('' SSCIN_ALL_TOT_HITS='',I4)') SSCIN_ALL_TOT_HITS
+ if(SSCIN_ALL_TOT_HITS.GT.0) then
+ write(sluno,'('' Num Plane Counter ADC_POS ''
+ & '' ADC_NEG TDC_POS TDC_NEG'')')
+ write(sluno,'(1x,i2,2x,i3,7x,i4,8x,2f8.1,2i8)')
+ & (j,SSCIN_ALL_PLANE_NUM(j),SSCIN_ALL_COUNTER_NUM(j),
+ & (SSCIN_ALL_ADC_POS(j)
+ $ -SSCIN_ALL_PED_POS(sscin_all_plane_num(j)
+ $ ,sscin_all_counter_num(j)))
+ $ ,(SSCIN_ALL_ADC_NEG(j)
+ $ -SSCIN_ALL_PED_NEG(sscin_all_plane_num(j)
+ $ ,sscin_all_counter_num(j)))
+ $ ,SSCIN_ALL_TDC_POS(j)
+ $ ,SSCIN_ALL_TDC_NEG(j),j=1,SSCIN_ALL_TOT_HITS )
+
+ write(sluno,'('' Num Plane Counter RAW_ADC_+ ''
+ & ''RAW_ADC_- PED_POS PED_NEG'')')
+ write(sluno,'(3i5,4f10.2)')
+ & (j,SSCIN_ALL_PLANE_NUM(j),SSCIN_ALL_COUNTER_NUM(j),
+ & float(SSCIN_ALL_ADC_POS(j)),
+ $ float(SSCIN_ALL_ADC_NEG(j)),
+ $ SSCIN_ALL_PED_POS(sscin_all_plane_num(j),sscin_all_counter_num(j)),
+ $ SSCIN_ALL_PED_NEG(sscin_all_plane_num(j),sscin_all_counter_num(j)),
+ $ j=1,SSCIN_ALL_TOT_HITS )
+
+ endif
+ RETURN
+ END
diff --git a/STRACKING/s_prt_tof.f b/STRACKING/s_prt_tof.f
new file mode 100644
index 0000000..68df2a5
--- /dev/null
+++ b/STRACKING/s_prt_tof.f
@@ -0,0 +1,62 @@
+ subroutine s_prt_tof(itrk)
+
+*-------------------------------------------------------------------
+* author: John Arrington
+* created: 3/27/94
+*
+* s_prt_tof dumps the sos_scin_tof bank.
+*
+* modifications:
+* $Log: s_prt_tof.f,v $
+* Revision 1.3 1995/05/22 19:45:51 cdaq
+* (SAW) Split gen_data_data_structures into gen, hms, sos, and coin parts"
+*
+* Revision 1.2 1994/11/23 13:57:39 cdaq
+* (SPB) Recopied from hms file and modified names for SOS
+*
+* Revision 1.1 1994/04/13 18:22:01 cdaq
+* Initial revision
+*
+*-------------------------------------------------------------------
+
+ implicit none
+
+ include 'sos_data_structures.cmn'
+ include 'sos_scin_parms.cmn'
+ include 'sos_scin_tof.cmn'
+ include 'sos_tracking.cmn'
+
+ integer*4 ihit, itrk
+
+ save
+
+ write(sluno,'('' ***S_SCIN_TOF BANK***'')')
+ write(sluno,'('' TRACK NUMBER'',i3)') itrk
+ write(sluno,'(''POSITION/CALIBRATION VARIABLES:'')')
+ write(sluno,'('' +coord -coord '',
+ & '' pos_dt neg_dt +sigma +sigma'')')
+ do ihit=1,sscin_tot_hits
+ write(sluno,'(f8.3,f8.3,2f8.3,2f8.3)')
+ & sscin_pos_coord(ihit), sscin_neg_coord(ihit),
+ & sscin_neg_time_offset(ihit), sscin_pos_time_offset(ihit),
+ & sscin_pos_sigma(ihit), sscin_neg_sigma(ihit)
+ enddo
+ write(sluno,'(''HIT POSITION AND OTHER CALCULATED VARIABLES:'')')
+ write(sluno,'('' long_coord trans_coord +time -time'',
+ & '' scin_time scin_sig on_track time@fp'')')
+ do ihit=1,sscin_tot_hits
+ write(sluno,'(2f12.4,2f9.3,2f10.3,l2,f10.3)')
+ & sscin_long_coord(ihit), sscin_trans_coord(ihit),
+ & sscin_pos_time(ihit), sscin_neg_time(ihit),
+ & sscin_time(ihit), sscin_sigma(ihit),
+ & sscin_on_track(itrk,ihit),sscin_time_fp(ihit)
+ enddo
+ write(sluno,'('' trk beta chisq_beta fp_time '',
+ & ''num_scin_hit'')')
+ write(sluno,'(i4,f8.4,f14.3,f9.3,i8)') itrk,
+ & sbeta(itrk), sbeta_chisq(itrk), stime_at_fp(itrk),
+ & snum_scin_hit(itrk)
+ write(sluno,*)
+
+ return
+ end
diff --git a/STRACKING/s_prt_track_tests.f b/STRACKING/s_prt_track_tests.f
new file mode 100644
index 0000000..040ec74
--- /dev/null
+++ b/STRACKING/s_prt_track_tests.f
@@ -0,0 +1,63 @@
+ subroutine s_prt_track_tests
+
+*-------------------------------------------------------------------
+* author: John Arrington
+* created: 3/28/94
+*
+* s_prt_track_tests dumps the sos_track_tests bank.
+*
+* modifications:
+* $Log: s_prt_track_tests.f,v $
+* Revision 1.2 1995/05/22 19:45:52 cdaq
+* (SAW) Split gen_data_data_structures into gen, hms, sos, and coin parts"
+*
+* Revision 1.1 1994/04/13 18:22:19 cdaq
+* Initial revision
+*
+*-------------------------------------------------------------------
+
+ implicit none
+
+ include 'sos_data_structures.cmn'
+ include 'sos_scin_parms.cmn'
+ include 'sos_scin_tof.cmn'
+ include 'sos_tracking.cmn'
+
+ logical abort
+ integer*4 ihit, itrk
+ character*1024 errmsg
+ character*25 here
+ parameter (here = 's_prt_track_tests')
+
+ save
+
+ if(sntracks_fp.gt.0) then
+ write(sluno,'('' SOS_TRACK_TESTS BANK'')')
+ write(sluno,'(''SHOWER COUNTER TESTS'')')
+ write(sluno,'('' num_blks plane1 plane2 plane3 plane4'',
+ & '' shtrk prtrk'')')
+ do itrk=1, sntracks_fp
+ write(sluno,'(i10,6f9.3)') snblocks_cal(itrk),
+ & strack_e1(itrk), strack_e2(itrk),
+ & strack_e3(itrk), strack_e4(itrk),
+ & strack_et(itrk), strack_preshower_e(itrk)
+ enddo
+ write(sluno,'(''SCIN/CERENKOV TESTS'')')
+ write(sluno,'('' trk beta chisq_beta fp_time '',
+ & ''num_scin_hit'')')
+ do itrk=1, sntracks_fp
+ write(sluno,'(i4,f8.4,f10.4,f9.3,i12)') itrk,
+ & sbeta(itrk), sbeta_chisq(itrk), stime_at_fp(itrk),
+ & snum_scin_hit(itrk)
+ enddo
+
+ do itrk=1, sntracks_fp
+ write(sluno,'(''hits on track number'',i3,'', and dE/dx:'')') itrk
+ write(sluno,'(16i6)')
+ & (sscin_hit(itrk,ihit),ihit=1,snum_scin_hit(itrk))
+ write(sluno,'(16f6.1)')
+ & (sdedx(itrk,ihit),ihit=1,snum_scin_hit(itrk))
+ enddo
+ endif ! end check on zero focal plane tracks
+ return
+ end
diff --git a/STRACKING/s_psifun.f b/STRACKING/s_psifun.f
new file mode 100644
index 0000000..97e71a4
--- /dev/null
+++ b/STRACKING/s_psifun.f
@@ -0,0 +1,56 @@
+ function s_psifun(ray,iplane)
+* this function calculates the psi coordinate of the intersection
+* of a ray (defined by ray) with a wire chamber plane. the geometry
+* of the plane is contained in the coeff array calculated in the
+* array splane_coeff
+*
+* the ray is defined by
+* x = (z-zt)*tan(xp) + xt
+* y = (z-zt)*tan(yp) + yt
+* at some fixed value of zt*
+* ray(1) = xt
+* ray(2) = yt
+* ray(3) = tan(xp)
+* ray(4) = tan(yp)
+*
+* d.f. geesaman 1 September 1993
+* $Log: s_psifun.f,v $
+* Revision 1.2 1995/05/22 19:45:53 cdaq
+* (SAW) Split gen_data_data_structures into gen, hms, sos, and coin parts"
+*
+* Revision 1.1 1994/02/21 16:40:53 cdaq
+* Initial revision
+*
+*
+ implicit none
+ include "sos_data_structures.cmn"
+ include "sos_geometry.cmn"
+*
+* input
+ real*4 ray(4) ! xt,yt,xpt,ypt
+ integer*4 iplane ! plane number
+* output
+ real*4 S_PSIFUN ! value of psi coordinate of hit of ray in plane
+*
+* local variables
+ real*4 denom,infinity,cinfinity
+ parameter (infinity = 1.0d20)
+ parameter (cinfinity = 1/infinity)
+*
+ S_PSIFUN = ray(3)*ray(2)*splane_coeff(1,iplane)
+ & + ray(4)*ray(1)*splane_coeff(2,iplane)
+ & + ray(3)*splane_coeff(3,iplane)
+ & + ray(4)*splane_coeff(4,iplane)
+ & + ray(1)*splane_coeff(5,iplane)
+ & + ray(2)*splane_coeff(6,iplane)
+*
+ denom = ray(3)*splane_coeff(7,iplane)
+ & + ray(4)*splane_coeff(8,iplane) + splane_coeff(9,iplane)
+*
+ if(abs(denom).lt.cinfinity) then
+ S_PSIFUN=infinity
+ else
+ S_PSIFUN = S_PSIFUN/denom
+ endif
+ return
+ end
diff --git a/STRACKING/s_raw_dump_all.f b/STRACKING/s_raw_dump_all.f
new file mode 100644
index 0000000..f357c57
--- /dev/null
+++ b/STRACKING/s_raw_dump_all.f
@@ -0,0 +1,50 @@
+ SUBROUTINE s_raw_dump_all(ABORT,err)
+*--------------------------------------------------------
+*-
+*- Purpose and Methods : Dump all raw SOS banks
+*-
+*- Required Input BANKS SOS_RAW_SCIN,SOS_RAW_CAL,SOS_RAW_DC
+*-
+*- Output: ABORT - success or failure
+*- : err - reason for failure, if any
+*-
+*- Created 5-APR-1994 D. F. Geesaman
+* $Log: s_raw_dump_all.f,v $
+* Revision 1.2 1995/05/22 19:45:53 cdaq
+* (SAW) Split gen_data_data_structures into gen, hms, sos, and coin parts"
+*
+* Revision 1.1 1994/04/13 16:07:03 cdaq
+* Initial revision
+*
+*--------------------------------------------------------
+ IMPLICIT NONE
+ SAVE
+*
+ character*50 here
+ parameter (here= 's_raw_dump_all')
+*
+ logical ABORT
+ character*(*) err
+*
+ include 'sos_data_structures.cmn'
+ include 'sos_scin_parms.cmn'
+ include 'sos_tracking.cmn'
+ include 'sos_calorimeter.cmn'
+*
+*--------------------------------------------------------
+ ABORT = .FALSE.
+ err = ' '
+* Dump raw bank if sdebugprintscinraw is set
+ if( sdebugprintscinraw .ne. 0) then
+ call s_prt_raw_scin(ABORT,err)
+ endif
+*
+*
+ if(sdbg_raw_cal.gt.0) call s_prt_cal_raw
+* call s_prt_raw_cer
+* Dump raw bank if debug flag set
+ if(sdebugprintrawdc.ne.0) then
+ call s_print_raw_dc(ABORT,err)
+ endif
+ RETURN
+ END
diff --git a/STRACKING/s_reconstruction.f b/STRACKING/s_reconstruction.f
new file mode 100644
index 0000000..354a0e5
--- /dev/null
+++ b/STRACKING/s_reconstruction.f
@@ -0,0 +1,258 @@
+ SUBROUTINE S_reconstruction(ABORT,err)
+*--------------------------------------------------------
+*- Prototype C analysis routine
+*-
+*-
+*- Purpose and Methods : reconstruction of SOS quantities
+*-
+*- Output: ABORT - success or failure
+*- : err - reason for failure, if any
+*-
+* $Log: s_reconstruction.f,v $
+* Revision 1.13 1996/11/07 19:53:12 saw
+* (WH) Add lucite information
+*
+* Revision 1.12 1996/09/05 20:13:45 saw
+* (JRA) Add sbypass_track_eff
+*
+* Revision 1.11 1996/04/30 17:14:36 saw
+* (JRA) Add call to aerogel routine
+*
+* Revision 1.10 1995/10/10 17:33:31 cdaq
+* (JRA) Don't make an error just because no track is found
+*
+* Revision 1.9 1995/08/31 20:43:03 cdaq
+* (JRA) Add call to s_trans_cer
+*
+* Revision 1.8 1995/05/22 19:45:54 cdaq
+* (SAW) Split gen_data_data_structures into gen, hms, sos, and coin parts"
+*
+* Revision 1.7 1995/05/11 21:07:26 cdaq
+* (JRA) Add call to s_trans_misc
+*
+* Revision 1.6 1995/04/06 19:42:47 cdaq
+* (JRA) Add call to s_select_best_track before s_physics
+*
+* Revision 1.5 1994/06/07 04:46:21 cdaq
+* (DFG) add s_recon_num and bypass switches
+*
+* Revision 1.4 1994/05/13 03:34:52 cdaq
+* (DFG) Put s_prt_track_tests here. Remove from s_tof
+*
+* Revision 1.3 1994/04/13 18:30:40 cdaq
+* (DFG) add call to s_raw_dump_all and comment out some returns after ABORT's
+*
+* Revision 1.2 1994/02/22 15:56:17 cdaq
+* (DFG) Replace with real version
+* (SAW) Move to TRACKING directory
+*
+* Revision 1.1 1994/02/04 22:16:44 cdaq
+* Initial revision
+*
+*-
+*- All standards are from "Proposal for Hall C Analysis Software
+*- Vade Mecum, Draft 1.0" by D.F.Geesamn and S.Wood, 7 May 1993
+*-
+*--------------------------------------------------------
+ IMPLICIT NONE
+ SAVE
+*
+ character*16 here
+ parameter (here= 'S_reconstruction')
+*
+ logical ABORT
+ character*(*) err
+*
+ INCLUDE 'sos_data_structures.cmn'
+ INCLUDE 'gen_constants.par'
+ INCLUDE 'gen_units.par'
+ include 'sos_scin_parms.cmn'
+ include 'sos_bypass_switches.cmn'
+ include 'sos_statistics.cmn'
+*
+* local variables
+ integer*4 istat
+*--------------------------------------------------------
+*
+ccc ABORT= .TRUE.
+ccc err= ':no events analyzed!'
+* increment reconstructed number
+c s_recon_num= s_recon_num + 1
+*
+* dump all raw data
+ call s_raw_dump_all(ABORT,err)
+ if(ABORT) then
+ call g_add_path(here,err)
+ return
+ endif
+*
+* TRANSLATE SCINTILATORS AND CALCULATE START TIME
+* SOS_RAW_SCIN ====> SOS_DECODED_SCIN
+*
+ If(sbypass_trans_scin.eq.0) then
+ call S_TRANS_SCIN(ABORT,err)
+ if(ABORT) then
+ call G_add_path(here,err)
+* return
+ endif ! end test on SCIN ABORT
+ endif ! end test on sbypass_trans_scin
+*
+* TRANSLATE SMISC TDC HITS.
+* S_RAW_MISC ====> SOS_DECODED_MISC
+*
+ If(sbypass_trans_scin.eq.0) then
+ call S_TRANS_MISC(ABORT,err)
+ if(ABORT) then
+ call G_add_path(here,err)
+* return
+ endif ! end test on SCIN ABORT
+ endif ! end test on hbypass_trans_scin
+*
+* TRANSLATE CERENKOV
+* HMS_RAW_CER ====> HMS_DECODED_CER
+*
+ If(sbypass_trans_cer.eq.0) then
+ call S_TRANS_CER(ABORT,err)
+ if(ABORT) then
+ call G_add_path(here,err)
+* return
+ endif ! end test on CER ABORT
+ endif ! end test on sbypass_trans_cer
+*
+* TRANSLATE CALORIMETER
+* SOS_RAW_CAL ====> SOS_DECODED_CAL
+*
+ if(sbypass_trans_cal.eq.0) then
+ call S_TRANS_CAL(ABORT,err)
+ if(ABORT) then
+ call G_add_path(here,err)
+* return
+ endif ! end test on CAL ABORT
+ endif ! end test on sbypass_trans_cal
+*
+* TRANLATE DRIFT CHAMBERS
+* SOS_RAW_DC + SOS_DECODED_SCIN ====> SOS_DECODED_DC
+ if(sbypass_trans_dc.eq.0) then
+ call S_TRANS_DC(ABORT,err)
+ if(ABORT) then
+ call G_add_path(here,err)
+ return
+ endif ! end test on S_TRANS_DC ABORT
+ endif ! end test on sbypass_trans_dc
+*
+ if(sbypass_track.eq.0) then
+ call S_TRACK(ABORT,err)
+ if(ABORT) then
+ call G_add_path(here,err)
+ return
+ endif ! end test on S_TRACK ABORT
+ if(sbypass_track_eff.eq.0) then
+ call s_track_tests
+ endif ! end test on sbypass_trackeff
+ endif ! end test on sbypass_track
+* only proceed if the number of tracks is greater than one
+*
+ if(SNTRACKS_FP .lt. 1) then
+c don't want error message every time a track is not found.
+c ABORT=.FALSE.
+c err=":no tracks found!"
+ return
+ else
+* Proceed if one or more track has been found
+*
+* Project tracks back to target
+* SOS_FOCAL_PLANE ====> SOS_TARGET
+*
+ if(sbypass_targ_trans.eq. 0) then
+ call S_TARG_TRANS(ABORT,err,istat)
+ if(ABORT) then
+ call G_add_path(here,err)
+ return
+ endif ! end test on S_TARG_TRANS ABORT
+ endif ! end test on sbypass_target_trans
+*
+* Now begin to process particle identification information
+* First scintillator and time of flight
+* SOS_RAW_SCIN ====> SOS_TRACK_TESTS
+*
+ if(sbypass_tof.eq.0) then
+ call S_TOF(ABORT,err)
+ if(ABORT) then
+ call G_add_path(here,err)
+ return
+ endif ! end test of S_TOF ABORT
+ endif ! end test on sbypass_tof
+* Next Calorimeter information
+* SOS_DECODED_CAL ====> SOS_TRACK_TESTS
+*
+ if(sbypass_cal.eq.0) then
+ call S_CAL(ABORT,err)
+ if(ABORT) then
+ call G_add_path(here,err)
+ return
+ endif ! end test of S_CAL ABORT
+ endif ! end test on sbypass_cal
+* Next Cerenkov information
+* SOS_DECODED_CER ====> SOS_TRACK_TESTS
+*
+ if(sbypass_cer.eq.0) then
+ call S_CER(ABORT,err)
+ if(ABORT) then
+ call G_add_path(here,err)
+* return
+ endif ! end test of S_CER ABORT
+ endif ! end test on sbypass_cer
+* Next Aerogel Cerenkov information
+* SOS_DECODED_AER ====> SOS_TRACK_TESTS
+*
+ if(sbypass_aero.eq.0) then
+ call S_AERO(ABORT,err)
+ if(ABORT) then
+ call G_add_path(here,err)
+* return
+ endif ! end test of S_AERO ABORT
+ endif ! end test on sbypass_aero
+*
+* Next Lucite Cerenkov information
+* SOS_DECODED_LUC ====> SOS_TRACK_TESTS
+*
+ if(sbypass_lucite.eq.0) then
+ call S_LUCITe(ABORT,err)
+ if(ABORT) then
+ call G_add_path(here,err)
+* return
+ endif ! end test of S_LUCITE ABORT
+ endif ! end test on sbypass_lucite
+
+
+*
+* Dump SOS_TRACK_TESTS if sdebugprinttracktests is set
+ if( sdebugprinttracktests .ne. 0 ) then
+ call s_prt_track_tests
+ endif
+* Combine results in SOS physics analysis
+* SOS_TARGET + SOS_TRACK_TESTS ====> SOS_PHYSICS
+*
+ if(sbypass_track.eq.0) then
+ call s_select_best_track(abort,err)
+ if(ABORT) then
+ call G_add_path(here,err)
+ return
+ endif
+ endif
+*
+ if(sbypass_physics.eq.0) then
+ call S_PHYSICS(ABORT,err)
+ if(ABORT) then
+ call G_add_path(here,err)
+* return
+ endif ! end test of S_PHYSICS ABORT
+ endif ! end test on sbypass_physics
+*
+ endif ! end test no tracks found
+*
+*
+* Successful return
+ ABORT=.FALSE.
+ RETURN
+ END
diff --git a/STRACKING/s_register_param.f b/STRACKING/s_register_param.f
new file mode 100644
index 0000000..a94e3e9
--- /dev/null
+++ b/STRACKING/s_register_param.f
@@ -0,0 +1,97 @@
+ SUBROUTINE s_register_param(ABORT,err)
+*--------------------------------------------------------
+*-
+*- Purpose and Methods : Initializes SOS quantities
+*-
+*- Output: ABORT - success or failure
+*- : err - reason for failure, if any
+*-
+*- Created 8-Nov-1993 Kevin B. Beard
+*- Modified 20-Nov-1993 KBB for new errors
+*- 14 Feb-1994 DFG Put in real variables
+*-
+*- All standards are from "Proposal for Hall C Analysis Software
+*- Vade Mecum, Draft 1.0" by D.F.Geesamn and S.Wood, 7 May 1993
+* $Log: s_register_param.f,v $
+* Revision 1.11 1996/11/07 19:53:37 saw
+* (WH) Add lucite parameters
+*
+* Revision 1.10 1996/04/30 17:15:12 saw
+* (JRA) Register Aerogel variables
+*
+* Revision 1.9 1995/08/31 20:43:41 cdaq
+* (JRA) Register Cerenkov variables
+*
+* Revision 1.8 1995/05/17 16:43:28 cdaq
+* (JRA) Register pedestal variables
+*
+* Revision 1.7 1994/08/18 03:59:50 cdaq
+* (SAW) Call makereg generated routines to register variables
+*
+* Revision 1.6 1994/06/07 03:01:22 cdaq
+* (DFG) add call to register bypass switches and statistics
+*
+* Revision 1.5 1994/03/24 19:54:54 cdaq
+* (DFG) Put actual registering of variables in subroutines
+*
+* Revision 1.4 1994/02/23 15:39:50 cdaq
+* (SAW) ABORT now when ierr.NE.0
+*
+* Revision 1.3 1994/02/22 20:39:28 cdaq
+* (SAW) Fix booboo
+*
+* Revision 1.2 1994/02/22 18:52:19 cdaq
+* (SAW) Move regpar declarations to gen_routines.dec. Make title arg null.
+*
+* Revision 1.1 1994/02/22 18:42:21 cdaq
+* Initial revision
+*
+*-
+*--------------------------------------------------------
+ IMPLICIT NONE
+ SAVE
+*
+ character*16 here
+ parameter (here= 's_register_param')
+*
+ logical ABORT
+ character*(*) err
+*
+*--------------------------------------------------------
+ err= ' '
+ ABORT = .false.
+*
+* register tracking variables
+*
+
+ call r_sos_tracking
+ call r_sos_geometry
+ call r_sos_track_histid
+ call r_sos_recon_elements
+ call r_sos_physics_sing
+*
+* register cal, tof and cer variables
+*
+
+ call r_sos_scin_parms
+ call r_sos_scin_tof
+ call r_sos_cer_parms
+ call r_sos_aero_parms
+ call r_sos_lucite_parms
+ call r_sos_calorimeter
+ call r_sos_id_histid
+*
+* register bypass switches
+*
+
+ call r_sos_bypass_switches
+
+*
+* register sos statistics
+*
+
+ call r_sos_statistics
+ call r_sos_pedestals
+*
+ return
+ end
diff --git a/STRACKING/s_report_bad_data.f b/STRACKING/s_report_bad_data.f
new file mode 100644
index 0000000..b65b86b
--- /dev/null
+++ b/STRACKING/s_report_bad_data.f
@@ -0,0 +1,106 @@
+ SUBROUTINE S_REPORT_BAD_DATA(lunout,ABORT,errmsg)
+
+*--------------------------------------------------------
+*
+* Purpose and Methods: Output warnings for possible hardware problems
+* in file 'bad<runnum>.txt' (unit=lunout)
+*
+* NOTE: Nothing should be written to the file unless there is a warning
+* to be reported. (i.e. check for error messages before writing
+* headers.
+*
+* Required Input BANKS:
+*
+* Output: ABORT - success or failure
+* : err - reason for failure, if any
+*
+* author: John Arrington
+* created: 8/17/95
+* $Log: s_report_bad_data.f,v $
+* Revision 1.3 1996/09/05 20:14:25 saw
+* (JRA) Don't report difference between input pedestals and pedestals from
+* pedestal events
+*
+* Revision 1.2 1996/01/17 18:59:46 cdaq
+* (JRA) Warn when pedestals change too much
+*
+* Revision 1.1 1995/08/31 20:43:52 cdaq
+* Initial revision
+*
+*--------------------------------------------------------
+
+ IMPLICIT NONE
+*
+ character*17 here
+ parameter (here= 'S_REPORT_BAD_DATA')
+*
+ logical ABORT
+ character*(*) errmsg
+*
+ include 'sos_data_structures.cmn'
+ include 'sos_calorimeter.cmn'
+ include 'sos_pedestals.cmn'
+ include 'sos_cer_parms.cmn'
+
+ integer*4 lunout
+ integer*4 ind
+ integer*4 icol,irow
+
+ character*4 pln(snum_scin_planes)
+ character*2 cnt(snum_scin_elements)
+ character*1 sgn(2)
+ character*2 col(smax_cal_columns)
+ character*2 row(smax_cal_rows)
+ character*5 mir(scer_num_mirrors)
+ save
+
+ data pln/'sS1X','sS1Y','sS2X','sS2Y'/
+ data cnt/'01','02','03','04','05','06','07','08',
+ & '09','10','11','12','13','14','15','16'/
+ data sgn/'+','-'/
+
+ data col/'sA','sB','sC','sD'/
+ data row/'01','02','03','04','05','06','07',
+ & '08','09','10','11'/
+
+ data mir/'scer1','scer2','scer3','scer4'/
+
+! Remove reporting of difference between pedestals and input pedestals
+! from parameter files now that we always use the pedestal events.
+!
+* report channels where the pedestal analysis differs from the param file.
+! if ((shodo_num_ped_changes+scal_num_ped_changes+scer_num_ped_changes)
+! & .gt. 0) then
+!
+! write(lunout,*) ' SOS detectors with large (>2sigma) pedestal changes'
+! write(lunout,*)
+! write(lunout,*) ' Signal Pedestal change(new-old)'
+!
+! if (shodo_num_ped_changes.gt.0) then
+! do ind=1,shodo_num_ped_changes
+! write(lunout,'(2x,a4,a2,a1,f9.1)')
+! $ pln(shodo_changed_plane(ind))
+! $ ,cnt(shodo_changed_element(ind))
+! $ ,sgn(shodo_changed_sign(ind)),shodo_ped_change(ind)
+! enddo
+! endif
+!
+! if (scal_num_ped_changes.gt.0) then
+! do ind=1,scal_num_ped_changes
+! icol=(scal_changed_block(ind)-0.5)/smax_cal_rows + 1
+! irow=scal_changed_block(ind)-smax_cal_rows*(icol-1)
+! write(lunout,'(4x,a2,a2,f9.1)') col(icol),row(irow),
+! & scal_ped_change(ind)
+! enddo
+! endif
+!
+! if (scer_num_ped_changes.gt.0) then
+! do ind=1,scer_num_ped_changes
+! write(lunout,'(3x,a4,f9.1)') mir(scer_changed_tube(ind)),
+! & scer_ped_change(ind)
+! enddo
+! endif
+! endif ! are there pedestal changes to report?
+
+ return
+ end
diff --git a/STRACKING/s_satcorr.f b/STRACKING/s_satcorr.f
new file mode 100644
index 0000000..53234d1
--- /dev/null
+++ b/STRACKING/s_satcorr.f
@@ -0,0 +1,85 @@
+ SUBROUTINE S_SATCORR(ABORT,err)
+*--------------------------------------------------------
+*-
+*- Purpose and Methods : Correct delta or other reconstructed physics variables
+*- for magnet saturation effects
+*-
+*- to decoded information
+*-
+*- Required Input BANKS SOS_FOCAL_PLANE
+*- SOS_TARGET
+*-
+*- Output BANKS SOS_PHYSICS_R4
+*- SOS_PHYSICS_I4
+*-
+*- Output: ABORT - success or failure
+*- : err - reason for failure, if any
+*-
+*- Created 24-JUN-1998 J. Volmer
+*- Dummy Shell routine
+* $Log: s_satcorr.f,v $
+* Revision 1.2 2003/09/05 20:00:03 jones
+* Merge in online03 changes (mkj)
+*
+* Revision 1.1.2.1 2003/04/11 14:01:34 cdaq
+* eliminate p0corr since already in s_fieldcorr.f (mkj)
+*
+* Revision 1.1 1999/02/10 18:35:01 csa
+* Initial revision
+*
+*
+* Revision 1.1 1998/06/24 14:58:18 jv
+* Initial revision
+*
+*-
+*-
+*--------------------------------------------------------
+ IMPLICIT NONE
+ SAVE
+*
+ character*9 here
+ parameter (here= 'S_SATCORR')
+*
+ logical ABORT
+ character*(*) err
+ integer ierr
+*
+ include 'gen_data_structures.cmn'
+ INCLUDE 'sos_data_structures.cmn'
+ INCLUDE 'gen_constants.par'
+ INCLUDE 'gen_units.par'
+*
+* local variables
+*
+ REAL*4 deltacorr,p0corr
+
+*--------------------------------------------------------
+*
+ ierr=0
+ ABORT=.FALSE.
+
+ p0corr=0.
+ deltacorr=0.
+
+ if (genable_sos_satcorr.ne.0) then
+ if (spcentral.gt.0.96296) then
+ deltacorr = 46.729-137.21*spcentral+181.15*spcentral**2
+ > -76.089*spcentral**3
+ else
+ deltacorr = 14.6369
+ endif
+
+c p0corr = .225
+c if (spcentral.gt.1.483) p0corr=p0corr-16.7*(spcentral-1.483)**2
+ endif
+
+* write(6,*)' s_satcorr: ssdelta, ssxp_fp =',ssdelta, ssxp_fp
+* write(6,*)' s_satcorr: deltacorr, p0corr =',deltacorr,p0corr
+c ssdelta = ssdelta + deltacorr*ssxp_fp**2 + p0corr
+ ssdelta = ssdelta + deltacorr*ssxp_fp**2
+* write(6,*)' s_satcorr: ssdelta =',ssdelta
+
+ ABORT= ierr.ne.0 .or. ABORT
+
+ return
+ end
diff --git a/STRACKING/s_scin_eff.f b/STRACKING/s_scin_eff.f
new file mode 100644
index 0000000..282bf9e
--- /dev/null
+++ b/STRACKING/s_scin_eff.f
@@ -0,0 +1,222 @@
+ SUBROUTINE S_SCIN_EFF(ABORT,errmsg)
+*--------------------------------------------------------
+*-
+*- Purpose and Methods : Analyze scintillator information for each track
+*-
+*- Required Input BANKS SOS_SCIN_TOF
+*- GEN_DATA_STRUCTURES
+*-
+*- Output: ABORT - success or failure
+*- : err - reason for failure, if any
+*-
+* author: John Arrington
+* created: 2/13/95
+*
+* s_scin_eff calculates efficiencies for the hodoscope.
+*
+* $Log: s_scin_eff.f,v $
+* Revision 1.8 2003/09/05 20:01:02 jones
+* Merge in online03 changes (mkj)
+*
+* Revision 1.7.2.1 2003/04/02 22:27:03 cdaq
+* added some extra scint. effic calculations (from oct 1999 online) - JRA
+*
+* Revision 1.7 1996/01/17 18:59:15 cdaq
+* (JRA) Fix typos
+*
+* Revision 1.6 1995/08/31 15:08:15 cdaq
+* (JRA) Fill dpos (pos. track - pos. hit) histograms
+*
+* Revision 1.5 1995/07/20 19:00:29 cdaq
+* (SAW) Put nint around some things for Ultrix compat. Put h in front of
+* various *good variables.
+*
+* Revision 1.4 1995/05/22 19:45:54 cdaq
+* (SAW) Split gen_data_data_structures into gen, hms, sos, and coin parts"
+*
+* Revision 1.3 1995/05/11 21:17:23 cdaq
+* (JRA) Add position calibration variables
+*
+* Revision 1.2 1995/04/06 19:43:37 cdaq
+* (JRA) Fix some latent HMS variable names
+*
+* Revision 1.1 1995/02/23 15:42:08 cdaq
+* Initial revision
+*
+*--------------------------------------------------------
+ IMPLICIT NONE
+*
+ character*50 here
+ parameter (here= 'S_SCIN_EFF')
+*
+ logical ABORT
+ character*(*) errmsg
+*
+ INCLUDE 'sos_data_structures.cmn'
+ INCLUDE 'gen_constants.par'
+ INCLUDE 'gen_units.par'
+ include 'sos_scin_parms.cmn'
+ include 'sos_scin_tof.cmn'
+ include 'sos_statistics.cmn'
+ include 'sos_id_histid.cmn'
+
+ integer pln,cnt,pln2
+ integer hit_cnt(snum_scin_planes)
+ integer nhit
+ real dist, histval
+ real hit_pos(snum_scin_planes),hit_dist(snum_scin_planes)
+ real xatback,yatback
+
+ logical good_tdc_oneside(snum_scin_planes)
+ logical good_tdc_bothsides(snum_scin_planes)
+ logical otherthreehit
+
+ save
+
+* find counters on track, and distance from center.
+
+ if (sschi2perdeg.le.sstat_maxchisq) sstat_numevents=sstat_numevents+1
+
+ hit_pos(1)=ssx_fp + ssxp_fp*(sscin_1x_zpos+0.5*sscin_1x_dzpos)
+ hit_cnt(1)=nint((hit_pos(1)-shodo_center(1,1))/sscin_1x_spacing)+1
+ hit_cnt(1)=max(min(hit_cnt(1),nint(snum_scin_counters(1))),1)
+ hit_dist(1)=hit_pos(1)-(sscin_1x_spacing*(hit_cnt(1)-1)+shodo_center(1,1))
+
+ hit_pos(2)=ssy_fp + ssyp_fp*(sscin_1y_zpos+0.5*sscin_1y_dzpos)
+ hit_cnt(2)=nint((shodo_center(2,1)-hit_pos(2))/sscin_1y_spacing)+1
+ hit_cnt(2)=max(min(hit_cnt(2),nint(snum_scin_counters(2))),1)
+ hit_dist(2)=hit_pos(2)-(shodo_center(2,1)-sscin_1y_spacing*(hit_cnt(2)-1))
+
+ hit_pos(3)=ssx_fp + ssxp_fp*(sscin_2x_zpos+0.5*sscin_2x_dzpos)
+ hit_cnt(3)=nint((hit_pos(3)-shodo_center(3,1))/sscin_2x_spacing)+1
+ hit_cnt(3)=max(min(hit_cnt(3),nint(snum_scin_counters(3))),1)
+ hit_dist(3)=hit_pos(3)-(sscin_2x_spacing*(hit_cnt(3)-1)+shodo_center(3,1))
+
+ hit_pos(4)=ssy_fp + ssyp_fp*(sscin_2y_zpos+0.5*sscin_2y_dzpos)
+ hit_cnt(4)=nint((shodo_center(4,1)-hit_pos(4))/sscin_2y_spacing)+1
+ hit_cnt(4)=max(min(hit_cnt(4),nint(snum_scin_counters(4))),1)
+ hit_dist(4)=hit_pos(4)-(shodo_center(4,1)-sscin_2y_spacing*(hit_cnt(4)-1))
+
+ do pln=1,snum_scin_planes
+ good_tdc_oneside(pln) = .false.
+ good_tdc_bothsides(pln) = .false.
+ enddo
+
+
+* Fill dpos (pos. track - pos. hit) histograms
+ do nhit=1,sscin_tot_hits
+ pln=sscin_plane_num(nhit)
+ histval = shodo_center(pln,sscin_counter_num(nhit))-hit_pos(pln)
+ call hf1(sidscindpos(pln),histval,1.)
+ enddo
+
+* Record position differences between track and center of scin. and
+* increment 'should have hit' counters
+ do pln=1,snum_scin_planes
+ cnt=hit_cnt(pln)
+ dist=hit_dist(pln)
+ if(abs(dist).le.sstat_slop .and. !hit in middle of scin.
+ & sschi2perdeg.le.sstat_maxchisq) then
+ sstat_trk(pln,hit_cnt(pln))=sstat_trk(pln,hit_cnt(pln))+1
+ endif
+ enddo
+
+ do nhit=1,sscin_tot_hits
+ cnt=sscin_counter_num(nhit)
+ pln=sscin_plane_num(nhit)
+
+* Record the hits if track is near center of track and the chisquared of the
+* track is good.
+ if(abs(hit_dist(pln)).le.sstat_slop .and. cnt.eq.hit_cnt(pln) .and.
+ & sschi2perdeg.le.sstat_maxchisq) then
+
+ if (sgood_tdc_pos(ssnum_fptrack,nhit)) then
+ if (sgood_tdc_neg(ssnum_fptrack,nhit)) then !both fired
+ sstat_poshit(pln,hit_cnt(pln))=sstat_poshit(pln,hit_cnt(pln))+1
+ sstat_neghit(pln,hit_cnt(pln))=sstat_neghit(pln,hit_cnt(pln))+1
+ sstat_andhit(pln,hit_cnt(pln))=sstat_andhit(pln,hit_cnt(pln))+1
+ sstat_orhit(pln,hit_cnt(pln))=sstat_orhit(pln,hit_cnt(pln))+1
+ else !pos fired
+ sstat_poshit(pln,hit_cnt(pln))=sstat_poshit(pln,hit_cnt(pln))+1
+ sstat_orhit(pln,hit_cnt(pln))=sstat_orhit(pln,hit_cnt(pln))+1
+ endif
+ else !no pos tdc
+ if (sgood_tdc_neg(ssnum_fptrack,nhit)) then !neg fired
+ sstat_neghit(pln,hit_cnt(pln))=sstat_neghit(pln,hit_cnt(pln))+1
+ sstat_orhit(pln,hit_cnt(pln))=sstat_orhit(pln,hit_cnt(pln))+1
+ endif !if neg tdc fired.
+ endif !if pos tdc fired.
+
+ endif !if hit was on good track.
+
+
+* Increment pos/neg/both fired. Track indepenant, so no chisquared cut (but
+* note that only scintillators on the track are examined.
+
+ if (sgood_tdc_pos(ssnum_fptrack,nhit)) then
+ if (sgood_tdc_neg(ssnum_fptrack,nhit)) then !both fired
+ sbothgood(pln,cnt)=sbothgood(pln,cnt)+1
+ else !pos fired
+ sposgood(pln,cnt)=sposgood(pln,cnt)+1
+ endif
+ else
+ if (sgood_tdc_neg(ssnum_fptrack,nhit)) then !neg fired
+ sneggood(pln,cnt)=sneggood(pln,cnt)+1
+ endif
+ endif
+
+* Determine if one or both PMTs had a good tdc.
+ if (sgood_tdc_pos(ssnum_fptrack,nhit) .and.
+ & sgood_tdc_neg(ssnum_fptrack,nhit) ) good_tdc_bothsides(pln)=.true.
+ if (sgood_tdc_pos(ssnum_fptrack,nhit) .or.
+ & sgood_tdc_neg(ssnum_fptrack,nhit) ) good_tdc_oneside(pln)=.true.
+
+ enddo !loop over ssnum_pmt_hit
+
+
+* For each plane, see of other 3 fired. This means that they were enough
+* to form a 3/4 trigger, and so the fraction of times this plane fired is
+* the plane trigger efficiency. NOTE: we only require a TDC hit, not a
+* TDC hit within the SCIN 3/4 trigger window, so high rates will make
+* this seem better than it is. Also, make sure we're not near the edge
+* of the hodoscope (at the last plane), using the same shodo_slop param. as for h_tof.f
+* NOTE ALSO: to make this check simpler, we are assuming that all planes
+* have identical active areas. y_scin = y_cent + y_offset, so shift track
+* position by offset for comparing to edges.
+
+ xatback = ssx_fp+ssxp_fp*sscin_2y_zpos - sscin_2x_offset
+ yatback = ssy_fp+ssyp_fp*sscin_2y_zpos - sscin_2y_offset
+
+ if ( xatback.lt.(sscin_2y_bot -2.*shodo_slop(3)) .and.
+ & xatback.gt.(sscin_2y_top +2.*shodo_slop(3)) .and.
+ & yatback.lt.(sscin_2x_left -2.*shodo_slop(3)) .and.
+ & yatback.gt.(sscin_2x_right+2.*shodo_slop(3))) then
+
+ do pln=1,snum_scin_planes
+ otherthreehit=.true.
+ do pln2=1,snum_scin_planes !see of one of the others missed or pln2=pln
+ if (.not.(good_tdc_bothsides(pln2) .or. pln2.eq.pln)) then
+ otherthreehit=.false.
+ endif
+ enddo
+ if (otherthreehit) then
+ strig_hodoshouldflag(pln) = .true.
+ if (good_tdc_bothsides(pln)) then
+ strig_hododidflag(pln) = .true.
+ else
+ strig_hododidflag(pln) = .false.
+ endif
+ else
+ strig_hodoshouldflag(pln) = .false.
+ strig_hododidflag(pln) = .false.
+ endif
+ enddo
+
+ else !outside of fiducial region
+ do pln=1,snum_scin_planes
+ strig_hodoshouldflag(pln) = .false.
+ strig_hododidflag(pln) = .false.
+ enddo
+ endif
+ return
+ end
diff --git a/STRACKING/s_scin_eff_shutdown.f b/STRACKING/s_scin_eff_shutdown.f
new file mode 100644
index 0000000..d136135
--- /dev/null
+++ b/STRACKING/s_scin_eff_shutdown.f
@@ -0,0 +1,148 @@
+ SUBROUTINE S_SCIN_EFF_SHUTDOWN(lunout,ABORT,errmsg)
+*--------------------------------------------------------
+*-
+*- Purpose and Methods : Analyze scintillator information for each track
+*-
+*- Required Input BANKS SOS_SCIN_TOF
+*- GEN_DATA_STRUCTURES
+*-
+*- Output: ABORT - success or failure
+*- : err - reason for failure, if any
+*-
+* author: John Arrington
+* created: 2/15/95
+*
+* s_scin_eff calculates efficiencies for the hodoscope.
+* s_scin_eff_shutdown does some final manipulation of the numbers.
+*
+* $Log: s_scin_eff_shutdown.f,v $
+* Revision 1.9 1999/02/23 18:59:27 csa
+* (JRA) Remove sdebugcalcpeds stuff
+*
+* Revision 1.8 1996/09/05 20:15:12 saw
+* (JRA) Cosmetic
+*
+* Revision 1.7 1996/01/17 18:58:53 cdaq
+* (JRA) Add debug control flag around write statements
+*
+* Revision 1.6 1995/08/31 15:08:52 cdaq
+* (JRA) Dump bad counter infomation
+*
+* Revision 1.5 1995/07/20 19:00:54 cdaq
+* (SAW) Move data statement for f2c compatibility
+*
+* Revision 1.4 1995/05/22 19:45:54 cdaq
+* (SAW) Split gen_data_data_structures into gen, hms, sos, and coin parts"
+*
+* Revision 1.3 1995/05/17 16:44:17 cdaq
+* (JRA) Write out list of potential PMT problems
+*
+* Revision 1.2 1995/05/11 21:17:34 cdaq
+* (JRA) Add position calibration variables
+*
+* Revision 1.1 1995/03/13 18:18:07 cdaq
+* Initial revision
+*
+*--------------------------------------------------------
+ IMPLICIT NONE
+*
+ character*19 here
+ parameter (here= 'S_SCIN_EFF_SHUTDOWN')
+*
+ logical ABORT
+ character*(*) errmsg
+*
+ INCLUDE 'sos_data_structures.cmn'
+ INCLUDE 'gen_constants.par'
+ INCLUDE 'gen_units.par'
+ include 'sos_scin_parms.cmn'
+ include 'sos_scin_tof.cmn'
+ include 'sos_statistics.cmn'
+ include 'sos_tracking.cmn'
+
+ logical written_header
+ integer pln,cnt
+ integer lunout
+ real*4 num_real,nhits_real
+ real*4 p1,p2,p3,p4 !prob. of having both tubes fire for planes1-4
+ real*4 p1234,p123,p124,p134,p234 !prob. of having combos fire
+
+ character*4 planename(SNUM_SCIN_PLANES)
+ data planename/'sS1X','sS1Y','sS2X','sS2Y'/
+
+ save
+
+ written_header = .false.
+
+! fill sums over counters
+ do pln=1,snum_scin_planes
+ sstat_trksum(pln)=0
+ sstat_possum(pln)=0
+ sstat_negsum(pln)=0
+ sstat_andsum(pln)=0
+ sstat_orsum(pln)=0
+ do cnt=1,snum_scin_counters(pln)
+ num_real=float(max(1,sscin_zero_num(pln,cnt)))
+ sscin_zero_pave(pln,cnt)=float(sscin_zero_pos(pln,cnt))/num_real
+ sscin_zero_nave(pln,cnt)=float(sscin_zero_neg(pln,cnt))/num_real
+ sstat_trksum(pln)=sstat_trksum(pln)+sstat_trk(pln,cnt)
+ sstat_possum(pln)=sstat_possum(pln)+sstat_poshit(pln,cnt)
+ sstat_negsum(pln)=sstat_negsum(pln)+sstat_neghit(pln,cnt)
+ sstat_andsum(pln)=sstat_andsum(pln)+sstat_andhit(pln,cnt)
+ sstat_orsum(pln)=sstat_orsum(pln)+sstat_orhit(pln,cnt)
+*
+* write out list of possible problms
+*
+ nhits_real = max(1.,float(sstat_trk(pln,cnt)))
+ sstat_neff(pln,cnt)=float(sstat_neghit(pln,cnt))/nhits_real
+ sstat_peff(pln,cnt)=float(sstat_poshit(pln,cnt))/nhits_real
+ sstat_oeff(pln,cnt)=float(sstat_orhit(pln,cnt))/nhits_real
+ sstat_aeff(pln,cnt)=float(sstat_andhit(pln,cnt))/nhits_real
+ if (nhits_real .gt. 100.) then !dump bad counter information
+ if (sstat_peff(pln,cnt).le.sstat_mineff) then
+ if (.not.written_header) then
+ write(lunout,*)
+ write(lunout,'(a,f6.3)') ' SOS scintilators with effic. < '
+ $ ,sstat_mineff
+ written_header = .true.
+ endif
+ write(lunout,'(5x,a4,i2,a,f7.4)') planename(pln),cnt,'+',sstat_peff(pln,cnt)
+ endif
+ if (sstat_neff(pln,cnt).le.sstat_mineff) then
+ if (.not.written_header) then
+ write(lunout,*)
+ write(lunout,'(a,f6.3)') ' SOS scintillators with tracking based effic. < '
+ $ ,sstat_mineff
+ written_header = .true.
+ endif
+ write(lunout,'(5x,a4,i2,a,f7.4)') planename(pln),cnt,'-',sstat_neff(pln,cnt)
+ endif
+ endif
+ enddo
+ sstat_poseff(pln)=sstat_possum(pln)/max(1.,float(sstat_trksum(pln)))
+ sstat_negeff(pln)=sstat_negsum(pln)/max(1.,float(sstat_trksum(pln)))
+ sstat_andeff(pln)=sstat_andsum(pln)/max(1.,float(sstat_trksum(pln)))
+ sstat_oreff(pln)=sstat_orsum(pln)/max(1.,float(sstat_trksum(pln)))
+ enddo
+
+ write(lunout,*) ' '
+ p1=sstat_andeff(1)
+ p2=sstat_andeff(2)
+ p3=sstat_andeff(3)
+ p4=sstat_andeff(4)
+
+! probability that ONLY the listed planes had triggers
+ p1234= p1*p2*p3*p4
+ p123 = p1*p2*p3*(1.-p4)
+ p124 = p1*p2*(1.-p3)*p4
+ p134 = p1*(1.-p2)*p3*p4
+ p234 = (1.-p1)*p2*p3*p4
+
+ seff_s1 = 1. - ((1.-p1)*(1.-p2))
+ seff_s2 = 1. - ((1.-p3)*(1.-p4))
+ seff_stof=seff_s1 * seff_s2
+ seff_3_of_4=p1234+p123+p124+p134+p234
+ seff_4_of_4=p1234
+
+ return
+ end
diff --git a/STRACKING/s_select_best_track.f b/STRACKING/s_select_best_track.f
new file mode 100644
index 0000000..47481c0
--- /dev/null
+++ b/STRACKING/s_select_best_track.f
@@ -0,0 +1,112 @@
+ SUBROUTINE S_SELECT_BEST_TRACK(ABORT,err)
+*--------------------------------------------------------
+*-
+*- Purpose and Methods : Select the best track through the HMS
+*-
+*-
+*- Required Input BANKS
+*-
+*- Output BANKS
+*-
+*- Output: ABORT - success or failure
+*- : err - reason for failure, if any
+*-
+*- $Log: s_select_best_track.f,v $
+*- Revision 1.6 2005/03/23 16:34:09 jones
+*- Add new code s_select_best_track_prune.f (P Bosted)
+*-
+*- Revision 1.5 2005/03/23 16:18:14 jones
+*- Add new code s_select_best_track_using_scin.f . Copy of code used for HMS.
+*-
+*- Revision 1.4 1995/07/20 19:01:37 cdaq
+*- (CC) Fix bug in best chisq finding
+*-
+c Revision 1.3 1995/05/22 19:45:55 cdaq
+c (SAW) Split gen_data_data_structures into gen, hms, sos, and coin parts"
+c
+c Revision 1.2 1995/04/06 19:44:04 cdaq
+c (JRA) Fix some latent HMS variable names
+c
+c Revision 1.1 1995/02/23 13:29:49 cdaq
+c Initial revision
+c
+*--------------------------------------------------------
+ IMPLICIT NONE
+ SAVE
+*
+ character*50 here
+ parameter (here= 'S_SELECT_BEST_TRACK')
+*
+ logical ABORT
+ character*(*) err
+*
+ INCLUDE 'sos_data_structures.cmn'
+ INCLUDE 'gen_routines.dec'
+ INCLUDE 'gen_constants.par'
+ INCLUDE 'gen_units.par'
+ INCLUDE 'sos_physics_sing.cmn'
+ INCLUDE 'sos_calorimeter.cmn'
+ INCLUDE 'sos_scin_parms.cmn'
+ INCLUDE 'sos_scin_tof.cmn'
+ INCLUDE 'sos_tracking.cmn'
+*
+* local variables
+ integer*4 goodtrack,track,trk,savegood
+ logical first
+ real*4 chi2perdeg,chi2min
+c
+ integer*4 i,j
+ data first /.true./
+*--------------------------------------------------------
+*
+ ABORT= .FALSE.
+ err= ' '
+* Need to test to chose the best track
+ SSNUM_FPTRACK = 0
+ SSNUM_TARTRACK = 0
+
+* adding choice to use scintillators to choose best track...
+ if ( ssel_using_prune .eq. 1) then
+ if (first) write(*,*) ' SOS track selection using Pruning'
+ first = .false.
+ call S_SELECT_BEST_TRACK_PRUNE(ABORT,err)
+ return
+ endif
+
+* adding choice to use scintillators to choose best track...
+ if ( ssel_using_scin .eq. 1) then
+ if (first) write(*,*) ' SOS track selection using scintillators'
+ first = .false.
+ call S_SELECT_BEST_TRACK_USING_SCIN(ABORT,err)
+ else
+* done here...
+ if( SNTRACKS_FP.GT. 0) then
+ if (first) write(*,*) ' SOS track selection using chi-squared'
+ first = .false.
+ chi2min= 1e10
+ goodtrack = 0
+ do track = 1, SNTRACKS_FP
+
+ if( SNFREE_FP(track).ge. ssel_ndegreesmin) then
+ chi2perdeg = SCHI2_FP(track)/FLOAT(SNFREE_FP(track))
+ if(chi2perdeg .lt. chi2min) then
+* simple particle id tests
+ if( ( SDEDX(track,1) .gt. ssel_dedx1min) .and.
+ & ( SDEDX(track,1) .lt. ssel_dedx1max) .and.
+ & ( SBETA(track) .gt. ssel_betamin) .and.
+ & ( SBETA(track) .lt. ssel_betamax) .and.
+ & ( STRACK_ET(track) .gt. ssel_etmin) .and.
+ & ( STRACK_ET(track) .lt. ssel_etmax)) then
+ goodtrack = track
+ chi2min = chi2perdeg
+ endif ! end test on track id
+ endif ! end test on lower chisq
+ endif ! end test on minimum number of degrees of freedom
+ enddo ! end loop on track
+ SSNUM_TARTRACK = goodtrack
+ SSNUM_FPTRACK = goodtrack
+ if(goodtrack.eq.0) return ! return if no valid tracks
+ endif
+ endif
+ return
+ end
diff --git a/STRACKING/s_select_best_track_prune.f b/STRACKING/s_select_best_track_prune.f
new file mode 100644
index 0000000..97a6ecd
--- /dev/null
+++ b/STRACKING/s_select_best_track_prune.f
@@ -0,0 +1,304 @@
+ SUBROUTINE s_SELECT_BEST_TRACK_PRUNE(ABORT,err)
+*--------------------------------------------------------
+*-
+*- Purpose and Methods : Select the best track through the HMS
+*-
+*-
+*- Required Input BANKS
+*-
+*- Output BANKS
+*-
+*- Output: ABORT - success or failure
+*- : err - reason for failure, if any
+*-
+*- $Log: s_select_best_track_prune.f,v $
+*- Revision 1.1 2005/03/23 16:34:08 jones
+*- Add new code s_select_best_track_prune.f (P Bosted)
+*-
+*
+*-
+*--------------------------------------------------------
+ IMPLICIT NONE
+ SAVE
+*
+ character*50 here
+ parameter (here= 's_SELECT_BEST_TRACK_PRUNE')
+*
+ logical ABORT
+ character*(*) err
+*
+ INCLUDE 'sos_data_structures.cmn'
+ INCLUDE 'gen_routines.dec'
+ INCLUDE 'gen_constants.par'
+ INCLUDE 'gen_units.par'
+ INCLUDE 'sos_physics_sing.cmn'
+ INCLUDE 'sos_calorimeter.cmn'
+ INCLUDE 'sos_scin_parms.cmn'
+ INCLUDE 'sos_scin_tof.cmn'
+ INCLUDE 'sos_tracking.cmn'
+c
+*
+* local variables
+ integer*4 goodtrack,track,ngood,reject(1000),trk
+ logical first,keep(1000)
+ real*4 chi2perdeg,chi2min,betap,p
+c
+ integer*4 i,j
+ data first /.true./
+*--------------------------------------------------------
+*
+ ABORT= .FALSE.
+ err= ' '
+* Need to test to chose the best track
+ sSNUM_FPTRACK = 0
+ sSNUM_TARTRACK = 0
+
+ if (first) then
+ write(*,*) ' sos track selection using pruning method'
+ first = .false.
+! Make sure limits are reasonable
+ sprune_xp = max(0.04, sprune_xp)
+ sprune_yp = max(0.08, sprune_yp)
+ sprune_ytar = max(4.0, sprune_ytar)
+ sprune_delta = max(25.0, sprune_delta)
+ sprune_beta = max(0.1, sprune_beta)
+ sprune_df = max(2, sprune_df)
+ sprune_chibeta= max(2., sprune_chibeta)
+ sprune_fptime= max(5., sprune_fptime)
+ sprune_npmt = max(6 , sprune_npmt)
+ write(*,'(1x,'' using following SOS limits''/
+ > 1x,''abs(xptar)<'',f6.3/
+ > 1x,''abs(yptar)<'',f6.3/
+ > 1x,''abs(ytar)<'',f6.3/
+ > 1x,''abs(delta)<'',f6.3/
+ > 1x,''abs(beta-betap)<'',f6.3/
+ > 1x,''ndegfreedom trk>='',i2/
+ > 1x,''beta chisq>'',f6.1/
+ > 1x,''num PMT hits >='',i3/
+ > 1x,''abs(fptime-sstart_time_center)<'',f6.1)')
+ > sprune_xp,sprune_yp,sprune_ytar,sprune_delta,
+ > sprune_beta,sprune_df,sprune_chibeta,sprune_npmt,sprune_fptime
+ endif
+c
+c
+ if( sNTRACKS_FP.GT. 0) then
+ chi2min= 1e10
+ goodtrack = 0
+
+! Initialize all tracks to be good
+ do track = 1, sNTRACKS_FP
+ keep(track) = .true.
+ reject(track)=0
+ enddo
+
+! Prune on xptar
+ ngood=0
+ do track = 1, sNTRACKS_FP
+ if( abs(sxp_tar(track)) .lt. sprune_xp .and. keep(track)) then
+ ngood = ngood + 1
+ endif
+ enddo
+ if(ngood.gt.0) then
+ do track = 1, sNTRACKS_FP
+ if( abs(sxp_tar(track)) .ge. sprune_xp) then
+ keep(track) = .false.
+ reject(track) = reject(track) + 1
+ endif
+ enddo
+ endif
+
+! Prune on yptar
+ ngood=0
+ do track = 1, sNTRACKS_FP
+ if( abs(syp_tar(track)) .lt. sprune_yp .and. keep(track)) then
+ ngood = ngood + 1
+ endif
+ enddo
+ if(ngood.gt.0) then
+ do track = 1, sNTRACKS_FP
+ if( abs(syp_tar(track)) .ge. sprune_yp) then
+ keep(track) = .false.
+ reject(track) = reject(track) + 2
+ endif
+ enddo
+ endif
+
+! Prune on ytar
+ ngood=0
+ do track = 1, sNTRACKS_FP
+ if( abs(sy_tar(track)) .lt. sprune_ytar .and. keep(track)) then
+ ngood = ngood + 1
+ endif
+ enddo
+ if(ngood.gt.0) then
+ do track = 1, sNTRACKS_FP
+ if( abs(sy_tar(track)) .ge. sprune_ytar) then
+ keep(track) = .false.
+ reject(track) = reject(track) + 10
+ endif
+ enddo
+ endif
+
+! Prune on delta
+ ngood=0
+ do track = 1, sNTRACKS_FP
+ if( abs(sdelta_tar(track)) .lt. sprune_delta
+ > .and. keep(track)) then
+ ngood = ngood + 1
+ endif
+ enddo
+ if(ngood.gt.0) then
+ do track = 1, sNTRACKS_FP
+ if(abs(sdelta_tar(track)) .ge. sprune_delta) then
+ keep(track) = .false.
+ reject(track) = reject(track) + 20
+ endif
+ enddo
+ endif
+
+! Prune on beta
+ ngood=0
+ do track = 1, sNTRACKS_FP
+ p = sp_tar(track)
+ betap = p/sqrt(p*p+spartmass*spartmass)
+ if( abs(sbeta(track)-betap) .lt. sprune_beta
+ > .and. keep(track)) then
+ ngood = ngood + 1
+ endif
+ enddo
+ if(ngood.gt.0) then
+ do track = 1, sNTRACKS_FP
+ p = sp_tar(track)
+ betap = p/sqrt(p*p+spartmass*spartmass)
+ if(abs(sbeta(track)-betap) .ge. sprune_beta) then
+ keep(track) = .false.
+ reject(track) = reject(track) + 100
+ endif
+ enddo
+ endif
+
+! Prune on deg. freedom for track chisq
+ ngood=0
+ do track = 1, sNTRACKS_FP
+ if(sNFREE_FP(track) .ge. sprune_df .and. keep(track)) then
+ ngood = ngood + 1
+ endif
+ enddo
+ if(ngood.gt.0) then
+ do track = 1, sNTRACKS_FP
+ if(sNFREE_FP(track) .lt. sprune_df) then
+ keep(track) = .false.
+ reject(track) = reject(track) + 200
+ endif
+ enddo
+ endif
+
+! Prune on num pmt hits
+ ngood=0
+ do track = 1, sNTRACKS_FP
+ if(snum_pmt_hit(track) .ge. sprune_npmt.and. keep(track)) then
+ ngood = ngood + 1
+ endif
+ enddo
+ if(ngood.gt.0) then
+ do track = 1, sNTRACKS_FP
+ if(snum_pmt_hit(track) .lt. sprune_npmt) then
+ keep(track) = .false.
+ reject(track) = reject(track) + 100000
+ endif
+ enddo
+ endif
+
+! Prune on beta chisqr
+ ngood=0
+ do track = 1, sNTRACKS_FP
+ if(sbeta_chisq(track) .lt. sprune_chibeta .and.
+ > sbeta_chisq(track) .gt. 0.01 .and. keep(track)) then
+ ngood = ngood + 1
+ endif
+ enddo
+ if(ngood.gt.0) then
+ do track = 1, sNTRACKS_FP
+ if(sbeta_chisq(track) .ge. sprune_chibeta .or.
+ > sbeta_chisq(track) .le. 0.01) then
+ keep(track) = .false.
+ reject(track) = reject(track) + 1000
+ endif
+ enddo
+ endif
+
+! Prune on fptime
+ ngood=0
+ do track = 1, sNTRACKS_FP
+ if( abs(stime_at_fp(track)-sstart_time_center).lt.sprune_fptime
+ > .and. keep(track)) then
+ ngood = ngood + 1
+ endif
+ enddo
+ if(ngood.gt.0) then
+ do track = 1, sNTRACKS_FP
+ if(abs(stime_at_fp(track)-sstart_time_center).ge.
+ > sprune_fptime) then
+ keep(track) = .false.
+ reject(track) = reject(track) + 2000
+ endif
+ enddo
+ endif
+
+! Prune on Y2 being hit
+ ngood=0
+ do track = 1, sNTRACKS_FP
+ if(sgood_plane_time(track,4).and. keep(track)) ngood = ngood + 1
+ enddo
+ if(ngood.gt.0) then
+ do track = 1, sNTRACKS_FP
+ if(.not.sgood_plane_time(track,4)) then
+ keep(track) = .false.
+ reject(track) = reject(track) + 10000
+ endif
+ enddo
+ endif
+
+! Prune on X2 being hit
+ ngood=0
+ do track = 1, sNTRACKS_FP
+ if(sgood_plane_time(track,3).and. keep(track)) ngood = ngood + 1
+ enddo
+ if(ngood.gt.0) then
+ do track = 1, sNTRACKS_FP
+ if(.not.sgood_plane_time(track,3)) then
+ keep(track) = .false.
+ reject(track) = reject(track) + 20000
+ endif
+ enddo
+ endif
+
+
+! Pick track with best chisq if more than one track passed prune tests
+ goodtrack = 1
+ do track = 1, sNTRACKS_FP
+ chi2perdeg = sCHI2_FP(track)/max(1.,FLOAT(sNFREE_FP(track)))
+ if(chi2perdeg .lt. chi2min .and. keep(track)) then
+ goodtrack = track
+ chi2min = chi2perdeg
+ endif
+ enddo
+ sSNUM_TARTRACK = goodtrack
+ sSNUM_FPTRACK = goodtrack
+ endif
+! for debugging
+ if( sNTRACKS_FP.GT. 100) then
+ write(*,'(/)')
+ do trk = 1, sNTRACKS_FP
+ write(*,'(3i3,4L2,7f6.1,L2,i9)') trk,sNFREE_FP(trk),
+ > snum_pmt_hit(trk),
+ > sgood_plane_time(trk,1),sgood_plane_time(trk,3),
+ > sgood_plane_time(trk,2),sgood_plane_time(trk,4),
+ > stime_at_fp(trk),sbeta(trk),sbeta_chisq(trk),
+ > sdelta_tar(trk),sy_tar(trk),sxp_tar(trk),syp_tar(trk),
+ > keep(trk),reject(trk)
+ enddo
+ write(*,'(1x,''good trk='',2i4)') goodtrack
+ endif
+ return
+ end
diff --git a/STRACKING/s_select_best_track_using_scin.f b/STRACKING/s_select_best_track_using_scin.f
new file mode 100644
index 0000000..6e412aa
--- /dev/null
+++ b/STRACKING/s_select_best_track_using_scin.f
@@ -0,0 +1,220 @@
+ SUBROUTINE S_SELECT_BEST_TRACK_USING_SCIN(ABORT,err)
+*--------------------------------------------------------
+* -
+* - Purpose and Methods : Select the best track through the SOS
+* - by see which track is closest to S2y
+* - or if no S2y then use closest to S2x
+* - if neither than smallest chi-squared.
+* -
+* - Required Input BANKS
+* -
+* - Output BANKS
+* -
+* - Output: ABORT - success or failure
+* - : err - reason for failure, if any
+* -
+* -
+*--------------------------------------------------------
+ IMPLICIT NONE
+ SAVE
+*
+ character*50 here
+ parameter (here= 'S_SELECT_BEST_TRACK')
+*
+ logical ABORT
+ character*(*) err
+*
+ INCLUDE 'sos_data_structures.cmn'
+ INCLUDE 'gen_routines.dec'
+ INCLUDE 'gen_constants.par'
+ INCLUDE 'gen_units.par'
+ INCLUDE 'sos_physics_sing.cmn'
+ INCLUDE 'sos_calorimeter.cmn'
+ INCLUDE 'sos_scin_parms.cmn'
+ INCLUDE 'sos_scin_tof.cmn'
+ INCLUDE 'sos_tracking.cmn'
+
+*
+* local variables
+ integer*4 goodtrack,track,i,j
+ real*4 chi2perdeg,chi2min
+
+ integer pln,cnt
+ integer hit_cnt(snum_scin_planes)
+ integer nhit,zz,t
+ real*4 y2dmin,x2dmin,zap
+ real*4 hit_pos(snum_scin_planes),hit_dist(snum_scin_planes)
+ real*4 stub_x(SNTRACKS_MAX),stub_y(SNTRACKS_MAX)
+ real*4 y2d(SNTRACKS_MAX),x2d(SNTRACKS_MAX)
+*--------------------------------------------------------
+*
+ ABORT= .FALSE.
+ err= ' '
+* Need to test to chose the best track
+ SSNUM_FPTRACK = 0
+ SSNUM_TARTRACK = 0
+ if( SNTRACKS_FP.GT. 0) then !!! (1) !!!
+ chi2min= 1e10
+ goodtrack = 0
+ y2dmin=100.
+ x2dmin=100.
+ zap=0.
+ do track = 1, SNTRACKS_FP
+ if( SNFREE_FP(track).ge. ssel_ndegreesmin) then !!! (2) !!!
+ chi2perdeg = SCHI2_FP(track)/FLOAT(SNFREE_FP(track))
+* simple particle id tests
+ if(( SDEDX(track,1).gt.ssel_dedx1min).and. !!! (3) !!!
+ & ( SDEDX(track,1).lt.ssel_dedx1max).and.
+ & ( SBETA(track).gt.ssel_betamin).and.
+ & ( SBETA(track).lt.ssel_betamax).and.
+ & ( STRACK_ET(track) .gt. ssel_etmin) .and.
+ & ( STRACK_ET(track) .lt. ssel_etmax)) then
+* first, fill the arrays of which scins were hit
+ do i=1,4
+ do j=1,sscin_1x_nr
+ sscinhit(i,j)=0
+ enddo
+ enddo
+ do i=1,sscin_tot_hits
+ sscinhit(sscin_plane_num(i),sscin_counter_num(i))=1
+ enddo
+c
+ hit_pos(4)=sy_fp(track) + syp_fp(track)*(sscin_2y_zpos+0.5*sscin_2y_dzpos)
+ hit_cnt(4)=nint((shodo_center(4,1)-hit_pos(4))/sscin_2y_spacing)+1
+ hit_cnt(4)=max(min(hit_cnt(4),nint(snum_scin_counters(4))),1)
+ hit_dist(4)=hit_pos(4)-(shodo_center(4,1)-sscin_2y_spacing*(hit_cnt(4)-1))
+
+* * shodo_center(4.1) = 31.35
+* * sscin_2y_spacing = 7.5
+* * snum_scin_counters(4) = 10
+* * sscin_2y_zpos = 318.51
+* * sscin_2y_dzpos = 2.12
+
+ if(sntracks_fp.gt.1) then !!! (4) !!!
+ zap=0.
+ t=0.
+ do j=1,10
+ if(sscinhit(4,j).eq.1) then
+ y2d(track)=abs(hit_cnt(4)-j)
+ t=t+1
+ if(t.eq.1) zap=y2d(track)
+
+ if(t.eq.2.and.y2d(track).lt.zap) then
+ zap=y2d(track)
+ endif
+ if(t.eq.3.and.y2d(track).lt.zap) then
+ zap=y2d(track)
+ endif
+ if(t.eq.4.and.y2d(track).lt.zap) then
+ zap=y2d(track)
+ endif
+ if(t.eq.5.and.y2d(track).lt.zap) then
+ zap=y2d(track)
+ endif
+ if(t.eq.6.and.y2d(track).lt.zap) then
+ zap=y2d(track)
+ endif
+
+ endif
+ enddo
+ y2d(track)=zap
+ endif !!! (4) !!!
+
+ if(sntracks_fp.eq.1) y2d(track)=0.
+
+ hit_pos(3)=sx_fp(track) + sxp_fp(track)*(sscin_2x_zpos
+ & +0.5*sscin_2x_dzpos)
+ hit_cnt(3)=nint((hit_pos(3)-
+ & shodo_center(3,1))/sscin_2x_spacing)+1
+ hit_cnt(3)=max(min(hit_cnt(3),
+ & nint(snum_scin_counters(3))),1)
+ hit_dist(3)=hit_pos(3)-
+ & (sscin_2x_spacing*(hit_cnt(3)-1)
+ & +shodo_center(3,1))
+
+ if(sntracks_fp.gt.1) then !!! (4) !!!
+ zap=0.
+ t=0.
+ do j=1,16
+ if(sscinhit(3,j).eq.1) then
+ x2d(track)=abs(hit_cnt(3)-j)
+ t=t+1
+ if(t.eq.1) zap=x2d(track)
+ if(t.eq.2.and.x2d(track).lt.zap) then
+ zap=x2d(track)
+ endif
+ if(t.eq.3.and.x2d(track).lt.zap) then
+ zap=x2d(track)
+ endif
+ if(t.eq.4.and.x2d(track).lt.zap) then
+ zap=x2d(track)
+ endif
+ if(t.eq.5.and.x2d(track).lt.zap) then
+ zap=x2d(track)
+ endif
+ if(t.eq.6.and.x2d(track).lt.zap) then
+ zap=x2d(track)
+ endif
+ endif
+ enddo
+ x2d(track)=zap
+ endif !!! (4) !!!
+
+ if(sntracks_fp.eq.1) x2d(track)=0.
+
+ if(y2d(track).le.y2dmin) then
+ if(y2d(track).lt.y2dmin) then
+ x2dmin=100.
+ chi2min=1e10
+ endif
+
+ if(x2d(track).le.x2dmin) then
+ if(x2d(track).lt.x2dmin) then
+ chi2min=1e10
+ endif
+
+ if(chi2perdeg.lt.chi2min) then
+
+ goodtrack = track
+ y2dmin=y2d(track)
+ x2dmin=x2d(track)
+ chi2min=chi2perdeg
+ endif
+ endif
+ endif
+
+
+
+
+ endif !!! (3) !!!
+ endif !!! (2) !!!
+ enddo
+
+
+
+ if (goodtrack.eq.0) then
+ chi2min= 1e10
+ do track = 1, SNTRACKS_FP
+ if( SNFREE_FP(track).ge. ssel_ndegreesmin) then
+ chi2perdeg = SCHI2_FP(track)/FLOAT(SNFREE_FP(track))
+ if(chi2perdeg.lt.chi2min) then
+ goodtrack = track
+ chi2min = chi2perdeg
+ endif
+ endif
+ enddo
+ endif
+
+
+
+ SSNUM_TARTRACK = goodtrack
+ SSNUM_FPTRACK = goodtrack
+
+
+ if(goodtrack.eq.0) return ! return if no valid tracks
+ endif !!! (1) !!!
+
+
+ return
+ end
+
diff --git a/STRACKING/s_solve_3by3.f b/STRACKING/s_solve_3by3.f
new file mode 100644
index 0000000..1f9d072
--- /dev/null
+++ b/STRACKING/s_solve_3by3.f
@@ -0,0 +1,60 @@
+ subroutine s_solve_3by3(TT,pindex,stub,ierr)
+* Explicit solution of a symmetric three by three equation TT = AA * STUB
+* Remember AA must be a symmetrix matrix
+* Used in find_best_stub.f
+
+* $Log: s_solve_3by3.f,v $
+* Revision 1.3 1995/10/10 17:36:30 cdaq
+* (JRA) Cleanup
+*
+* Revision 1.2 1995/05/22 19:45:55 cdaq
+* (SAW) Split gen_data_data_structures into gen, hms, sos, and coin parts"
+*
+c Revision 1.1 1994/11/23 13:59:37 cdaq
+c Initial revision
+c
+*
+* djm 10/2/94
+* The present version replaces solve_three_by_three(TT,AA,stub,ierr) in
+* find_best_stub. New version is entirely based on dfg's version, but matrix
+* inversion is now done only at initialization for faster event sorting.
+
+*
+ implicit none
+ include 'sos_data_structures.cmn'
+ include 'sos_tracking.cmn'
+
+
+* input quantities
+ real*8 TT(3)
+ integer*4 pindex
+*
+* output quantities
+ real*8 stub(3)
+ integer*4 ierr ! ierr = 0 means valid solution
+*
+ if(pindex.le.SDC_NUM_PLANES+SDC_NUM_CHAMBERS)then !accept 5/6 or 6/6 good planes
+ ierr=0
+ stub(1)=SAAINV3(1,1,pindex)*TT(1) + SAAINV3(1,2,pindex)*TT(2) +
+ & SAAINV3(1,3,pindex)*TT(3)
+ stub(2)=SAAINV3(1,2,pindex)*TT(1) + SAAINV3(2,2,pindex)*TT(2) +
+ & SAAINV3(2,3,pindex)*TT(3)
+ stub(3)=SAAINV3(1,3,pindex)*TT(1) + SAAINV3(2,3,pindex)*TT(2) +
+ & SAAINV3(3,3,pindex)*TT(3)
+ else
+ ierr=1
+ endif !end test on plane index
+
+* write(6,*)'TT i=1,2,3',TT(1),TT(2),TT(3)
+*
+* write(6,*)'aainv(1,1,) (1,2,) (1,3,)',aainv(1,1,pindex),
+* & aainv(1,2,pindex),aainv(1,3,pindex)
+*
+* write(6,*)'aainv(2,2) (2,3) (3,3)',aainv(2,2,pindex),
+* & aainv(2,3,pindex),aainv(3,3,pindex)
+*
+* write(6,*)
+
+ return
+
+ end
diff --git a/STRACKING/s_sparsify_cal.f b/STRACKING/s_sparsify_cal.f
new file mode 100644
index 0000000..80e179b
--- /dev/null
+++ b/STRACKING/s_sparsify_cal.f
@@ -0,0 +1,136 @@
+*=======================================================================
+ subroutine s_sparsify_cal(abort,errmsg)
+*=======================================================================
+*-
+*- Purpose: Sparsifies the calorimeter raw data.
+*-
+*- Input Banks: SOS_RAW_CAL, SOS_PEDESTALS_CAL
+*-
+*- Output Bank: SOS_SPARSIFIED_CAL
+*-
+*- Created: 15 Mar 1994 Tsolak A. Amatuni
+*- Modified 25 Mar 1994 DFG
+*- Change name of print routines
+*- 5 Apr 1994 DFG Move print routine to s_raw_dump_all
+* $Log: s_sparsify_cal.f,v $
+* Revision 1.13 2002/07/31 20:20:58 saw
+* Only try to fill user hists that are defined
+*
+* Revision 1.12 1999/06/10 16:57:38 csa
+* (JRA) Removed adc_max, added adc sign test, structural and cosmetic changes
+*
+* Revision 1.11 1999/02/25 20:18:40 saw
+* Vardan Tadevosyan shower code updates
+*
+* Revision 1.10 1999/02/23 19:00:04 csa
+* (JRA) Add neg cal hf1 call
+*
+* Revision 1.9 1999/02/03 21:13:45 saw
+* Code for new Shower counter tubes
+*
+* Revision 1.8 1999/01/29 17:34:59 saw
+* Add variables for second tubes on shower counter
+*
+* Revision 1.7 1996/01/17 18:58:19 cdaq
+* (JRA) Only histogram ADC's that are not 200 above pedestal
+*
+* Revision 1.6 1995/08/31 18:08:04 cdaq
+* (JRA) Add a hist of all adc's into one spectrum
+*
+* Revision 1.5 1995/07/20 19:04:20 cdaq
+* (JRA) Fix typo's, init scal_realadc array
+*
+* Revision 1.4 1995/05/22 19:45:56 cdaq
+* (SAW) Split gen_data_data_structures into gen, hms, sos, and coin parts"
+*
+* Revision 1.3 1995/05/11 14:55:09 cdaq
+* (JRA) Add call to s_fill_cal_hist
+*
+* Revision 1.2 1994/11/23 14:01:04 cdaq
+* (SPB) Recopied from hms file and modified names for SOS
+*
+* Revision 1.1 1994/04/13 18:44:11 cdaq
+* Initial revision
+*
+*-----------------------------------------------------------------------
+*
+ implicit none
+ save
+
+ logical abort
+ character*(*) errmsg
+ character*14 here
+ parameter (here='S_SPARSIFY_CAL')
+
+ integer*4 nh !Loop variable for raw hits
+ integer*4 nb !Block number
+ integer*4 row,col !Row & column numbers
+ integer*4 adc_pos !ADC value
+ integer*4 adc_neg !ADC value
+
+ include 'sos_data_structures.cmn'
+ include 'sos_calorimeter.cmn'
+ include 'sos_id_histid.cmn'
+
+
+ errmsg=' '
+ if(scal_tot_hits.lt.0.or.scal_tot_hits.gt.smax_cal_blocks) then
+ write(6,*) here,':scal_tot_hits = ',scal_tot_hits
+ return
+ endif
+
+ scal_num_hits=0
+ do nb = 1 , smax_cal_blocks
+ scal_realadc_pos(nb)=-100
+ scal_realadc_neg(nb)=-100
+ enddo
+ if(scal_tot_hits.le.0) return
+*
+* Loop over raw hits
+*
+ do nh=1,scal_tot_hits
+ row=scal_row(nh)
+ col=scal_column(nh)
+ nb =row+smax_cal_rows*(col-1)
+ adc_pos=scal_adc_pos(nh)
+ adc_neg=scal_adc_neg(nh)
+
+ if (adc_pos.ge.0) then ! =-1 if no ADC value was read.
+ scal_realadc_pos(nb) = float(adc_pos) - scal_pos_ped_mean(nb)
+ if (scal_realadc_pos(nb).le.200.and.sidcalsumadc.gt.0)
+ & call hf1(sidcalsumadc,scal_realadc_pos(nb),1.)
+ endif
+
+ if (adc_neg.ge.0) then ! =-1 if no ADC value was read.
+ scal_realadc_neg(nb) = float(adc_neg) - scal_neg_ped_mean(nb)
+ if (scal_realadc_neg(nb).le.200.and.sidcalsumadc.gt.0)
+ & call hf1(sidcalsumadc,scal_realadc_neg(nb),1.)
+ endif
+*
+* Sparsify the raw data
+*
+ if(scal_realadc_pos(nb).gt.scal_pos_threshold(nb) .or.
+ & scal_realadc_neg(nb).gt.scal_neg_threshold(nb)) then
+
+ scal_num_hits=scal_num_hits+1
+ scal_rows(scal_num_hits)=row
+ scal_cols(scal_num_hits)=col
+ if(scal_realadc_pos(nb).lt.scal_pos_threshold(nb)) then
+ scal_adcs_pos(scal_num_hits)= 0.0
+ else
+ scal_adcs_pos(scal_num_hits)=scal_realadc_pos(nb)
+ endif
+ if(scal_realadc_neg(nb).lt.scal_neg_threshold(nb)) then
+ scal_adcs_neg(scal_num_hits)= 0.0
+ else
+ scal_adcs_neg(scal_num_hits)=scal_realadc_neg(nb)
+ endif
+ endif
+ enddo !End loop over raw hits
+
+ if(sdbg_sparsified_cal.gt.0) call s_prt_cal_sparsified
+
+ call s_fill_cal_hist(abort,errmsg)
+
+ return
+ end
diff --git a/STRACKING/s_strip_scin.f b/STRACKING/s_strip_scin.f
new file mode 100644
index 0000000..11c7c6e
--- /dev/null
+++ b/STRACKING/s_strip_scin.f
@@ -0,0 +1,91 @@
+ subroutine s_strip_scin(abort,err)
+
+*-------------------------------------------------------------------
+* author: John Arrington
+* created: 6/25/94
+*
+* s_strip_scin converts the raw hits to arrays over hits
+* with good TDC values.
+* $Log: s_strip_scin.f,v $
+* Revision 1.7 1999/02/23 19:00:39 csa
+* (JRA) Remove sdebugcalcpeds stuff
+*
+* Revision 1.6 1996/01/17 18:57:36 cdaq
+* (JRA) Add sdebugcalcpeds flag
+*
+* Revision 1.5 1995/08/31 20:44:25 cdaq
+* (JRA) Accumulate pedestals from pedestal events.
+*
+* Revision 1.4 1995/05/22 19:45:56 cdaq
+* (SAW) Split gen_data_data_structures into gen, hms, sos, and coin parts"
+*
+* Revision 1.3 1995/05/11 15:02:18 cdaq
+* (JRA) Cosmetic changes
+*
+* Revision 1.2 1995/02/10 19:14:37 cdaq
+* JRA) Make sscin_all_adc_pos/neg floating
+*
+* Revision 1.1 1994/11/23 14:01:45 cdaq
+* Initial revision
+*
+*-------------------------------------------------------------------
+
+ implicit none
+
+ include 'sos_data_structures.cmn'
+ include 'sos_scin_parms.cmn'
+ include 'sos_scin_tof.cmn'
+ include 'sos_tracking.cmn'
+
+ logical abort
+ character*(*) err
+ character*12 here
+ parameter (here = 's_strip_scin')
+
+ integer*4 ihit,igoodhit,ind,plane,counter
+ integer*4 ip,ic
+ save
+ abort = .false.
+
+ igoodhit = 0
+ sscin_tot_hits = 0
+ do ind = 1, snum_scin_planes
+ sscin_hits_per_plane(ind) = 0
+ sscin_sing_counter(ind) = -1
+ enddo
+
+ do ihit = 1 , sscin_all_tot_hits ! pick out 'good' hits.
+
+** Criteria for good hit is at least one valid tdc value.
+ if (((sscin_all_tdc_pos(ihit) .ge. sscin_tdc_min).and.
+ 1 (sscin_all_tdc_pos(ihit) .le. sscin_tdc_max)) .or.
+ 2 ((sscin_all_tdc_neg(ihit) .ge. sscin_tdc_min).and.
+ 3 (sscin_all_tdc_neg(ihit) .le. sscin_tdc_max))) then !good hit
+
+ igoodhit = igoodhit + 1
+ sscin_tot_hits = sscin_tot_hits + 1
+ ip = sscin_all_plane_num(ihit)
+ sscin_plane_num(igoodhit) = ip
+ ic = sscin_all_counter_num(ihit)
+ sscin_counter_num(igoodhit) = ic
+ sscin_adc_pos(igoodhit) = float(sscin_all_adc_pos(ihit)) -
+ $ sscin_all_ped_pos(ip,ic)
+ sscin_adc_neg(igoodhit) = float(sscin_all_adc_neg(ihit)) -
+ $ sscin_all_ped_neg(ip,ic)
+ sscin_tdc_pos(igoodhit) = sscin_all_tdc_pos(ihit)
+ sscin_tdc_neg(igoodhit) = sscin_all_tdc_neg(ihit)
+ sscin_hits_per_plane(sscin_plane_num(igoodhit)) =
+ $ sscin_hits_per_plane(sscin_plane_num(igoodhit)) + 1
+*djm register counter which is hit. if more than one counter is hit per event,
+* only the last one will be histogrammed. this will bias events which have more
+* than one hit per plane, so it's only really useful for looking at single hits.
+* if you need to see all the hits, then hardwire it.
+ plane = sscin_PLANE_NUM(igoodhit)
+ counter = sscin_COUNTER_NUM(igoodhit)
+ if(plane.ge.1.and.plane.le.4) sscin_sing_counter(plane) = counter
+ endif
+ enddo
+
+ abort = .false.
+ return
+ end
diff --git a/STRACKING/s_targ_trans.f b/STRACKING/s_targ_trans.f
new file mode 100644
index 0000000..03a398b
--- /dev/null
+++ b/STRACKING/s_targ_trans.f
@@ -0,0 +1,225 @@
+ SUBROUTINE S_TARG_TRANS(ABORT,err,istat)
+*--------------------------------------------------------
+*-
+*- Purpose and Methods : Transforms tracks from SOS focal plane to
+*- target.
+*-
+*- Required Input BANKS SOS_FOCAL_PLANE
+*-
+*- Output BANKS SOS_TARGET
+*-
+*- Output: ABORT - success or failure
+*- : err - reason for failure, if any
+*- istat (integer) Status flag. Value returned indicates the following:
+*- = 1 Normal return.
+*- = 2 Matrix elements not initted correctly.
+*-
+* Version: 0.1 (In development) 18-Nov-1993 (DHP)
+*-
+*-Modified 21-JAN-94 D.F.Geesaman
+*- Add ABORT and err
+* $Log: s_targ_trans.f,v $
+* Revision 1.15 1999/02/23 19:01:10 csa
+* (JRA) Correct (another) hut(5) error
+*
+* Revision 1.14 1999/02/10 17:47:17 csa
+* Sign change in hut(5)
+*
+* Revision 1.13 1996/09/05 20:15:53 saw
+* (JRA) Apply offsets to reconstruction
+*
+* Revision 1.12 1996/01/17 18:10:27 cdaq
+* (JRA)
+*
+* Revision 1.11 1995/10/10 17:52:40 cdaq
+* (JRA) Cleanup
+*
+* Revision 1.10 1995/08/08 16:01:57 cdaq
+* (DD) Add detector and angular offsets
+*
+* Revision 1.9 1995/05/22 19:45:57 cdaq
+* (SAW) Split gen_data_data_structures into gen, hms, sos, and coin parts"
+*
+* Revision 1.8 1995/03/23 16:51:57 cdaq
+* (SAW) Previous change wrong. COSY wants slopes.
+* Target track data is now slopes.
+*
+* Revision 1.7 1995/02/23 16:03:05 cdaq
+* (SAW) Convert focal plane slopes to angles before COSY transport.
+* Target track data is now angles.
+*
+* Revision 1.6 1994/11/23 14:03:27 cdaq
+* (SPB) Recopied from hms file and modified names for SOS
+*
+* Revision 1.5 1994/08/18 04:35:28 cdaq
+* (SAW) ???
+*
+* Revision 1.4 1994/06/14 04:33:22 cdaq
+* (DFG) Add fill SLINK_TAR_FP 1 to 1
+*
+* Revision 1.3 1994/06/07 01:58:56 cdaq
+* (DFG) Protect against asin argument > 1.0
+*
+* Revision 1.2 1994/05/13 03:45:52 cdaq
+* (DFG) Add call to s_fill_dc_target_hist
+* Add calculation of SP_TAR
+* (SAW) Cosmetic changes to source
+*
+* Revision 1.1 1994/02/21 16:41:11 cdaq
+* Initial revision
+*
+*
+* Abstract: Reconstruct target scattering variables from track variables in
+* the detectors, using a polynomial (Taylor series) map. The track,
+* target, and map data are all maintained in common blocks.
+*
+* NOTE: This version assumes that the beam is not rastered.
+* Also, there is no treatment of error matrices, yet.
+*-
+* Right-handed coordinates are assumed: X=down, Z=downstream, Y = (Z cross X)
+*
+* Author: David H. Potterveld, Argonne National Lab, Nov. 1993
+*______________________________________________________________________________
+ IMPLICIT NONE
+ SAVE
+*
+ character*12 here
+ parameter (here= 's_targ_trans')
+*
+ logical ABORT
+ character*(*) err
+ integer*4 istat
+*
+ INCLUDE 'gen_data_structures.cmn'
+ INCLUDE 'sos_data_structures.cmn'
+ INCLUDE 'gen_constants.par'
+ INCLUDE 'gen_units.par'
+ include 'sos_tracking.cmn'
+ include 'sos_recon_elements.cmn'
+ include 'sos_track_histid.cmn'
+ include 'sos_physics_sing.cmn'
+*
+* Misc. variables.
+
+ integer*4 i,j,itrk
+
+ real*8 sum(4),hut(5),term,hut_rot(5)
+
+*============================= Executable Code ================================
+ ABORT= .FALSE.
+ err= ' '
+
+* Check for correct initialization.
+
+ if (s_recon_initted.ne.1) then
+ istat = 2
+ return
+ endif
+ istat = 1
+
+* Loop over tracks.
+
+ sntracks_tar = sntracks_fp
+ do itrk = 1,sntracks_fp
+*
+* set link between target and focal plane track. Currenty 1 to 1
+ slink_tar_fp(itrk) = itrk
+*
+* Reset COSY sums.
+ do i = 1,4
+ sum(i) = 0.
+ enddo
+
+* Load track data into local array, Converting to COSY units.
+* Note: At this point, the focal plane variables sxp_fp and syp_fp are
+* still slopes. We convert them to angles before running them through the
+* COSY transport matrices.
+* It is assumed that the track coordinates are reported at
+* the same focal plane as the COSY matrix elements were calculated.
+ hut(1) = sx_fp(itrk)/100.+ s_z_true_focus*sxp_fp(itrk)
+ $ + s_det_offset_x !m + detector offset
+! includes transformation to actual focus if not at Z=0.
+
+ hut(2) = sxp_fp(itrk) + s_ang_offset_x !COSY wants slopes
+
+ hut(3) = sy_fp(itrk)/100. + s_z_true_focus*syp_fp(itrk)
+ $ + s_det_offset_y !m + detector offset
+! again icludes transformation to true focus.
+
+ hut(4) = syp_fp(itrk) + s_ang_offset_y !COSY wants slopes
+
+ hut(5) = -gbeam_y/100. ! spectrometer target X in meter!
+
+! now transform
+ hut_rot(1) = hut(1)
+ hut_rot(3) = hut(3)
+ hut_rot(2) = hut(2) + hut(1)*s_ang_slope_x
+ hut_rot(4) = hut(4) + hut(3)*s_ang_slope_y
+ hut_rot(5) = hut(5)
+* Compute COSY sums.
+
+ do i = 1,s_num_recon_terms
+ term = 1.
+ do j = 1,5
+ if (s_recon_expon(j,i).ne.0.)
+ $ term = term*hut(j)**s_recon_expon(j,i)
+ enddo
+ sum(1) = sum(1) + term*s_recon_coeff(1,i)
+ sum(2) = sum(2) + term*s_recon_coeff(2,i)
+ sum(3) = sum(3) + term*s_recon_coeff(3,i)
+ enddo
+
+! For the SOS only the delta needs the transformation
+
+ do i = 1,s_num_recon_terms
+ term = 1.
+ do j = 1,5
+ if (s_recon_expon(j,i).ne.0.)
+ $ term = term*hut_rot(j)**s_recon_expon(j,i)
+ enddo
+ sum(4) = sum(4) + term*s_recon_coeff(4,i)
+ enddo
+
+* Protect against asin argument > 1.
+c if(sum(1).gt. 1.0) sum(1)= 0.99
+c if(sum(1).lt. -1.0) sum(1)= -.99
+c if(sum(3).gt. 1.0) sum(3)= 0.99
+c if(sum(3).lt. -1.0) sum(3)= -.99
+
+* Load output values.
+ sx_tar(itrk) = 0 ! ** No beam raster **
+ sy_tar(itrk) = sum(2)*100. !cm.
+ sxp_tar(itrk) = sum(1) !Slope xp
+ syp_tar(itrk) = sum(3) !Slope yp
+
+ sz_tar(itrk) = 0.0 !Track is at origin
+ sdelta_tar(itrk) = sum(4)*100. !percent.
+
+* Apply offsets to reconstruction.
+ sdelta_tar(itrk) = sdelta_tar(itrk) + sdelta_offset
+ syp_tar(itrk) = syp_tar(itrk) + stheta_offset
+ sxp_tar(itrk) = sxp_tar(itrk) + sphi_offset
+
+ sp_tar(itrk) = spcentral*(1.0 + sdelta_tar(itrk)/100.) !Momentum in GeV
+
+* The above coordinates are in the spectrometer reference frame in which the
+* Z axis is along the central ray. Do we need to rotate to the lab frame?
+* For now, I assume not.
+
+ enddo !End of loop over tracks.
+
+* All done...
+* check print flag to print results
+ if(sdebugtartrackprint.gt.0) then
+ call s_print_tar_tracks
+ endif
+* Fill hardwired histograms if sturnon_target_hist is non zero
+*
+ if(sturnon_target_hist.gt.0) then
+ call s_fill_dc_target_hist(ABORT,err)
+ if(ABORT) then
+ call g_add_path(here,err)
+ endif
+ endif
+ return
+ end
diff --git a/STRACKING/s_targ_trans_init.f b/STRACKING/s_targ_trans_init.f
new file mode 100644
index 0000000..a789493
--- /dev/null
+++ b/STRACKING/s_targ_trans_init.f
@@ -0,0 +1,175 @@
+ subroutine s_targ_trans_init(ABORT,err,istat)
+*______________________________________________________________________________
+*
+* Facility: CEBAF Hall-C software.
+*
+* Module: s_targ_trans_init
+*
+* Version: 0.1 (In development)
+*
+* $Log: s_targ_trans_init.f,v $
+* Revision 1.5.16.1 2007/09/10 20:28:01 pcarter
+* Implemented changes to allow compilation on RHEL 3,4,5 and MacOSX
+*
+* Revision 1.5 2004/02/19 16:42:13 jones
+* Can set filename for the SOS matrix elements using the parameter
+* s_recon_coeff_filename . If parameter is not set then uses
+* sos_recon_coeff.dat
+*
+* Revision 1.4 1996/09/04 20:57:23 saw
+* (JRA) Add target x to track definition
+*
+* Revision 1.3 1996/01/17 18:56:58 cdaq
+* (JRA)
+*
+* Revision 1.2 1995/08/08 16:08:36 cdaq
+* (DD) Add detector and angular offsets
+*
+* Revision 1.1 1994/05/13 03:50:18 cdaq
+* Initial revision
+*
+* Abstract: Temporary routine to initialize SOS reconstruction coefficients
+* from a datafile.
+*
+* Output arguments:
+*
+* istat (integer) Status flag. Value returned indicates the following:
+* = 1 Normal return.
+* = 2 Datafile could not be opened.
+* = 4 Error reading datafile.
+* = 6 Datafile overflowed the internal arrays.
+*
+* Author: David H. Potterveld, Argonne National Lab, Nov. 1993
+* Modified: D. F. Geesaman Add Abort, err arguments
+* Use G_IO_CONTROL to get LUN
+*______________________________________________________________________________
+
+ implicit none
+
+! Argument definitions.
+ logical ABORT
+ character*(*) err
+
+ integer istat
+
+! Include files.
+
+ include 'sos_recon_elements.cmn' !Recon coefficients.
+ include 'gen_filenames.cmn'
+ include 'sos_filenames.cmn'
+
+! Misc. variables.
+
+ integer*4 i,j,chan
+
+ character*132 line
+
+! ============================= Executable Code ================================
+
+! Reset flag, and zero arrays.
+ err= ' '
+ ABORT = .FALSE.
+ s_recon_initted = 0
+ do j = 1,smax_recon_elements
+ do i = 1,4
+ s_recon_coeff(i,j) = 0.
+ s_recon_expon(i,j) = 0.
+ enddo
+ s_recon_expon(5,j) = 0.
+ enddo
+
+ s_ang_slope_x=0.0
+ s_ang_slope_y=0.0
+ s_ang_offset_x=0.0
+ s_ang_offset_y=0.0
+ s_det_offset_x=0.0
+ s_det_offset_y=0.0
+ s_z_true_focus=0.0
+
+ istat = 1 !Assume success.
+! Get an I/O unit to open datafiles.
+c call G_IO_control(chan,'ANY',ABORT,err) !"ASK"="ANY"
+ chan = G_LUN_TEMP
+
+! Open and read in coefficients.
+
+ if ( s_recon_coeff_filename .eq. ' ' ) then
+ s_recon_coeff_filename = 'sos_recon_coeff.dat'
+ else
+ endif
+ write(*,*) '*******'
+ write(*,*) ' Opening SOS matrix element file ',s_recon_coeff_filename
+ write(*,*) '*******'
+ open (unit=chan,status='old',file=s_recon_coeff_filename,err=92)
+
+! Read header comments.
+
+ line = '!'
+ do while (line(1:1).eq.'!')
+ read (chan,1001,err=94) line
+ enddo
+
+* Read in focal plane rotation coefficients.
+ do while (line(1:4).ne.' ---')
+ if(line(1:13).eq.'s_ang_slope_x')read(line,1201,err=94)s_ang_slope_x
+ if(line(1:13).eq.'s_ang_slope_y')read(line,1201,err=94)s_ang_slope_y
+ if(line(1:14).eq.'s_ang_offset_x')read(line,1201,err=94)s_ang_offset_x
+ if(line(1:14).eq.'s_ang_offset_y')read(line,1201,err=94)s_ang_offset_y
+ if(line(1:14).eq.'s_det_offset_x')read(line,1201,err=94)s_det_offset_x
+ if(line(1:14).eq.'s_det_offset_y')read(line,1201,err=94)s_det_offset_y
+ if(line(1:14).eq.'s_z_true_focus')read(line,1201,err=94)s_z_true_focus
+ read (chan,1001,err=94) line
+ enddo
+
+! Read in coefficients and exponents.
+ line =' '
+ read (chan,1001,err=94) line
+ s_num_recon_terms = 0
+ do while (line(1:4).ne.' ---')
+ s_num_recon_terms = s_num_recon_terms + 1
+ if (s_num_recon_terms.gt.smax_recon_elements) goto 96
+ read (line,1200,err=94) (s_recon_coeff(i,s_num_recon_terms),i=1,4),
+ > (s_recon_expon(j,s_num_recon_terms),j=1,5)
+ read (chan,1001,err=94) line
+ enddo
+
+! Data read in OK.
+
+ s_recon_initted = 1
+ goto 100
+
+! File reading or data processing errors.
+
+ 92 istat = 2 !Error opening file.
+* If file does not exist, report err and then continue for development
+ err = 'error opening file '//s_recon_coeff_filename
+ call g_rep_err(ABORT,err)
+ stop
+ goto 100
+
+ 94 istat = 4 !Error reading or processing data.
+ ABORT=.true.
+ err = 'error processing file'//s_recon_coeff_filename
+ stop
+ goto 100
+
+ 96 istat = 6 !Too much data in file for arrays.
+ ABORT=.true.
+ err = 'too much data in file '//s_recon_coeff_filename
+ stop
+ goto 100
+
+! Done with open file.
+
+ 100 close (unit=chan)
+* free lun
+c call G_IO_control(chan,'FREE',ABORT,err) !"FINISH"="FREE"
+ return
+
+! ============================ Format Statements ===============================
+
+ 1001 format(a)
+ 1200 format(1x,4g16.9,1x,5i1)
+ 1201 format(17x,g16.9)
+
+ end
diff --git a/STRACKING/s_tdc_time_per_channel.f b/STRACKING/s_tdc_time_per_channel.f
new file mode 100644
index 0000000..249ae1d
--- /dev/null
+++ b/STRACKING/s_tdc_time_per_channel.f
@@ -0,0 +1,36 @@
+ function s_tdc_time_per_channel(plane,wire)
+*
+* routinne to return tdc slope (in ns/channel ) for a given sos plane and
+* wire
+*
+* d.f. geesaman 17 feb 1994 first dummy routine
+* $Log: s_tdc_time_per_channel.f,v $
+* Revision 1.3 1995/05/22 19:45:57 cdaq
+* (SAW) Split gen_data_data_structures into gen, hms, sos, and coin parts"
+*
+* Revision 1.2 1994/03/24 19:56:24 cdaq
+* (DFG) Add includes, return value now a registered variable
+*
+* Revision 1.1 1994/02/21 16:41:23 cdaq
+* Initial revision
+*
+*
+ implicit none
+ include 'sos_data_structures.cmn'
+ include 'sos_geometry.cmn'
+* inputs
+*
+ integer*4 plane ! sos plane number of hit
+ integer*4 wire ! sos wire number of hit
+*
+* output
+*
+ real*4 s_tdc_time_per_channel
+*
+* s_drift_time_calc = SSTART_TIME
+* & - FLOAT(tdc)*s_tdc_time_per_channel(plane,wire)
+* & + s_tdc_zero(plane,wire)
+*
+ s_tdc_time_per_channel = sdc_tdc_time_per_channel
+ return
+ end
diff --git a/STRACKING/s_tdc_zero.f b/STRACKING/s_tdc_zero.f
new file mode 100644
index 0000000..2dd2e9b
--- /dev/null
+++ b/STRACKING/s_tdc_zero.f
@@ -0,0 +1,39 @@
+ function s_tdc_zero(plane,wire)
+*
+* routine to return tdc_zero offset (in ns) for a given sos plane and
+* wire
+*
+* d.f. geesaman 17 feb 1994 first dummy routine
+* $Log: s_tdc_zero.f,v $
+* Revision 1.3 1995/05/22 19:45:58 cdaq
+* (SAW) Split gen_data_data_structures into gen, hms, sos, and coin parts"
+*
+* Revision 1.2 1994/06/14 04:38:30 cdaq
+* (DFG) Make zero time a parameter
+*
+* Revision 1.1 1994/02/21 16:41:38 cdaq
+* Initial revision
+*
+*
+* inputs
+*
+* integer*4 plane sos plane number of hit
+* integer*4 wire sos wire number of hit
+*
+* output
+*
+* real*4 s_tdc_zero offset
+*
+* s_drift_time_calc = SSTART_TIME
+* & - FLOAT(tdc)*s_tdc_time_per_channel(plane,wire)
+* & + s_tdc_zero(plane,wire)
+*
+ implicit none
+ include 'sos_data_structures.cmn'
+ include 'sos_tracking.cmn'
+ include 'sos_geometry.cmn'
+ integer*4 plane,wire
+ real*4 s_tdc_zero
+ s_tdc_zero=sdc_plane_time_zero(plane)
+ return
+ end
diff --git a/STRACKING/s_tof.f b/STRACKING/s_tof.f
new file mode 100644
index 0000000..eb45889
--- /dev/null
+++ b/STRACKING/s_tof.f
@@ -0,0 +1,444 @@
+ SUBROUTINE S_TOF(ABORT,errmsg)
+*--------------------------------------------------------
+*-
+*- Purpose and Methods : Analyze SOS scintillator information for each track
+*-
+*- Required Input BANKS SOS_RAW_SCIN
+*- SOS_DECODED_SCIN
+*- SOS_FOCAL_PLANE
+*-
+*- Output BANKS SOS_TRACK_TESTS
+*-
+*- Output: ABORT - success or failure
+*- : err - reason for failure, if any
+*-
+*- Created 22-FEB-1994 John Arrington
+*
+* $Log: s_tof.f,v $
+* Revision 1.14.6.1 2007/09/10 20:28:01 pcarter
+* Implemented changes to allow compilation on RHEL 3,4,5 and MacOSX
+*
+* Revision 1.14 2005/03/15 21:13:09 jones
+* Add code to filter the scintillator tdc hits and group them by time. ( P. Bosted)
+*
+*
+* Revision 1.13 1999/06/10 16:57:49 csa
+* (JRA) Cosmetic changes
+*
+* Revision 1.12 1997/03/19 18:18:58 saw
+* (JRA) Don't neglect negative side of hodoscopes
+*
+* Revision 1.11 1996/09/05 20:16:28 saw
+* (JRA) Include actual beta in calculation of focal plane time.
+*
+* Revision 1.10 1996/01/17 18:56:31 cdaq
+* (JRA)
+*
+* Revision 1.9 1995/05/22 19:45:58 cdaq
+* (SAW) Split gen_data_data_structures into gen, hms, sos, and coin parts"
+*
+* Revision 1.8 1995/05/17 16:46:14 cdaq
+* (JRA) Add sum_plane_time and num_plane_time
+*
+* Revision 1.7 1995/02/23 15:47:24 cdaq
+* (JRA) Catch up to HMS. Add track index to hgood_plane_time,
+* hgood_scin_time, hgood_tdc_pos, and hgood_tdc_neg. Zero out some
+* variables at start, minph variables now per pmt, hscin_adc_pos/neg
+* change to floats. Added count of pmt's firing and cosmetic changes.
+* Cosmetic changes. Remove commented out code to dump time of light
+* fitting data. Add calculation of time for each plane. Add commented
+* out code to dump time of flight fitting data.
+*
+* Revision 1.6 1995/01/18 20:41:48 cdaq
+* (SAW) Catch negative ADC values in argument of square root
+*
+* Revision 1.5 1994/11/23 14:15:23 cdaq
+* (SPB) Recopied from hms file and modified names for SOS
+*
+* Revision 1.4 1994/05/13 03:55:14 cdaq
+* (DFG) Remove s_prt_track_tests call
+*
+* Revision 1.3 1994/04/13 05:34:55 cdaq
+* (SAW) Fix typo
+*
+* Revision 1.2 1994/04/13 05:30:02 cdaq
+* Put in arrington code
+* (DFG) Add check for zero track
+* Add calls to print routines
+* Add check for zero hits
+*
+* Revision 1.1 1994/02/21 16:41:51 cdaq
+* Initial revision
+*
+* s_tof finds the time of flight for a particle from
+* the hodoscope TDC information. It corrects for pulse
+* height walk, time lag from the hit to the pmt signal,
+* and time offsets for each signal. It requires the
+* hodoscope ADC and TDC information, the track, and
+* the correction parameters.
+*--------------------------------------------------------
+ IMPLICIT NONE
+ SAVE
+*
+ character*50 here
+ parameter (here= 'S_TOF')
+*
+ logical ABORT
+ character*(*) errmsg
+*
+ INCLUDE 'sos_data_structures.cmn'
+ INCLUDE 'gen_constants.par'
+ INCLUDE 'gen_units.par'
+ include 'sos_scin_parms.cmn'
+ include 'sos_scin_tof.cmn'
+ integer*4 hit, trk
+ integer*4 plane,ind
+ integer*4 sntof_pairs
+ real*4 adc_ph !pulse height (channels)
+ real*4 xhit_coord,yhit_coord
+ real*4 time
+ real*4 p,betap !momentum and velocity from momentum, assuming desired mass
+ real*4 path
+ real*4 sum_fp_time,sum_plane_time(snum_scin_planes)
+ integer*4 num_fp_time,num_plane_time(snum_scin_planes)
+ integer timehist(200),i,j,jmax,maxhit,nfound
+ real*4 time_pos(1000),time_neg(1000),tmin,time_tolerance
+ logical keep_pos(1000),keep_neg(1000),first/.true./
+ save
+*
+*--------------------------------------------------------
+*
+ ABORT= .FALSE.
+ errmsg = ' '
+
+ if(sntracks_fp.le.0 .or. sscin_tot_hits.le.0) then
+ do trk = 1 , sntracks_fp
+ snum_scin_hit(trk) = 0
+ snum_pmt_hit(trk) = 0
+ sbeta(trk) = 0
+ sbeta_chisq(trk) = -3
+ stime_at_fp(trk) = 0
+ enddo
+ goto 666
+ endif
+
+** MAIN LOOP: Loop over all tracks and get corrected time, tof, beta...
+ do trk = 1 , sntracks_fp
+
+** Initialize counter,flags...
+ sntof = 0
+ sntof_pairs = 0
+ sum_fp_time = 0.
+ num_fp_time = 0
+ snum_scin_hit(trk) = 0
+ snum_pmt_hit(trk) = 0
+ p = sp_tar(trk)
+ betap = p/sqrt(p*p+spartmass*spartmass)
+
+! Calculate all corrected hit times and histogram
+! This uses a copy of code below. Results are saved in time_pos,neg
+! including the z-pos. correction assuming nominal value of betap
+! Code is currently hard-wired to look for a peak in the
+! range of 0 to 100 nsec, with a group of times that all
+! agree withing a time_tolerance of time_tolerance nsec. The normal
+! peak position appears to be around 35 nsec.
+! NOTE: if want to find farticles with beta different than
+! reference particle, need to make sure this is big enough
+! to accomodate difference in TOF for other particles
+! Default value in case user hasnt definedd something reasonable
+ time_tolerance=3.0
+ if(stof_tolerance.gt.0.5.and.stof_tolerance.lt.10000.) then
+ time_tolerance=stof_tolerance
+ endif
+ if(first) then
+ first=.false.
+ write(*,'(//1x,''USING '',f8.2,'' NSEC WINDOW FOR'',
+ > '' SOS TOF AND FP CALCULATIONS'')') time_tolerance
+ write(*,'(//)')
+ endif
+ nfound = 0
+ do j=1,200
+ timehist(j)=0
+ enddo
+ do hit = 1 , sscin_tot_hits
+ i=min(1000,hit)
+ time_pos(i)=-99.
+ time_neg(i)=-99.
+ keep_pos(i)=.false.
+ keep_neg(i)=.false.
+ plane = sscin_plane_num(hit)
+ xhit_coord = sx_fp(trk) + sxp_fp(trk)*sscin_zpos(hit)
+ yhit_coord = sy_fp(trk) + syp_fp(trk)*sscin_zpos(hit)
+ if (plane.eq.1 .or. plane.eq.3) then !x plane
+ sscin_trans_coord(hit) = xhit_coord
+ sscin_long_coord(hit) = yhit_coord
+ else if (plane.eq.2 .or. plane.eq.4) then !y plane
+ sscin_trans_coord(hit) = yhit_coord
+ sscin_long_coord(hit) = xhit_coord
+ else !bad plane #.
+ abort = .true.
+ write(errmsg,*) 'sscin_plane_num(',hit,') = ',plane
+ call g_prepend(here,errmsg)
+ return
+ endif
+ if (abs(sscin_center_coord(hit)-sscin_trans_coord(hit))
+ & .lt.(sscin_width(hit)/2.+sscin_slop(hit))) then
+ if(sscin_tdc_pos(hit) .ge. sscin_tdc_min .and.
+ & sscin_tdc_pos(hit) .le. sscin_tdc_max) then
+ adc_ph = sscin_adc_pos(hit)
+ path = sscin_pos_coord(hit) - sscin_long_coord(hit)
+ time = sscin_tdc_pos(hit) * sscin_tdc_to_time
+ time = time - sscin_pos_phc_coeff(hit) *
+ & sqrt(max(0.,(adc_ph/sscin_pos_minph(hit)-1.)))
+ time = time - path/sscin_vel_light(hit)
+ & - (sscin_zpos(hit)/(29.979*betap) *
+ & sqrt(1.+sxp_fp(trk)*sxp_fp(trk)+syp_fp(trk)*syp_fp(trk)))
+ time_pos(i) = time - sscin_pos_time_offset(hit)
+ nfound = nfound + 1
+ do j=1,200
+ tmin = 0.5*float(j)
+ if(time_pos(i) .gt. tmin .and.
+ > time_pos(i) .lt. tmin + time_tolerance)
+ > timehist(j) = timehist(j) + 1
+ enddo
+ endif
+ if (sscin_tdc_neg(hit).ge.sscin_tdc_min .and. !good tdc
+ 1 sscin_tdc_neg(hit).le.sscin_tdc_max) then
+ adc_ph = sscin_adc_neg(hit)
+ path = sscin_long_coord(hit) - sscin_neg_coord(hit)
+ time = sscin_tdc_neg(hit) * sscin_tdc_to_time
+ time = time - sscin_neg_phc_coeff(hit) *
+ & sqrt(max(0.,(adc_ph/sscin_neg_minph(hit)-1.)))
+ time = time - path/sscin_vel_light(hit)
+ & - (sscin_zpos(hit)/(29.979*betap) *
+ & sqrt(1.+sxp_fp(trk)*sxp_fp(trk)+syp_fp(trk)*syp_fp(trk)))
+ time_neg(i) = time - sscin_neg_time_offset(hit)
+ nfound = nfound + 1
+ do j=1,200
+ tmin = 0.5*float(j)
+ if(time_neg(i) .gt. tmin .and.
+ > time_neg(i) .lt. tmin + time_tolerance)
+ > timehist(j) = timehist(j)+1
+ enddo
+ endif
+ endif
+ enddo
+! Find bin with most hits
+ jmax=0
+ maxhit=0
+ do j=1,200
+ if(timehist(j) .gt. maxhit) then
+ jmax = j
+ maxhit = timehist(j)
+ endif
+ enddo
+ if(jmax.gt.0) then
+ tmin = 0.5*float(jmax)
+ do hit = 1 , sscin_tot_hits
+ i=min(1000,hit)
+ if(time_pos(i) .gt. tmin .and.
+ > time_pos(i) .lt. tmin + time_tolerance) then
+ keep_pos(i) = .true.
+ endif
+ if(time_neg(i) .gt. tmin .and.
+ > time_neg(i) .lt. tmin + time_tolerance) then
+ keep_neg(i) = .true.
+ endif
+ enddo
+ endif
+
+! Resume regular tof code, now using time filer from above
+ do plane = 1 , snum_scin_planes
+ sgood_plane_time(trk,plane) = .false.
+ sum_plane_time(plane) = 0.
+ num_plane_time(plane) = 0
+ enddo
+
+ do hit = 1 , sscin_tot_hits
+ sgood_scin_time(trk,hit) = .false.
+ sgood_tdc_pos(trk,hit) = .false.
+ sgood_tdc_neg(trk,hit) = .false.
+ sscin_time(hit) = 0
+ sscin_sigma(hit) = 0
+ enddo
+
+ do hit = 1 , sscin_tot_hits
+ plane = sscin_plane_num(hit)
+
+** Find hit position
+ xhit_coord = sx_fp(trk) + sxp_fp(trk)*sscin_zpos(hit)
+ yhit_coord = sy_fp(trk) + syp_fp(trk)*sscin_zpos(hit)
+ if (plane.eq.1 .or. plane.eq.3) then !x plane
+ sscin_trans_coord(hit) = xhit_coord
+ sscin_long_coord(hit) = yhit_coord
+ else if (plane.eq.2 .or. plane.eq.4) then !y plane
+ sscin_trans_coord(hit) = yhit_coord
+ sscin_long_coord(hit) = xhit_coord
+ else !bad plane #.
+ abort = .true.
+ write(errmsg,*) 'sscin_plane_num(',hit,') = ',plane
+ call g_prepend(here,errmsg)
+ return
+ endif
+
+** Check if scin is on track
+ if (abs(sscin_center_coord(hit)-sscin_trans_coord(hit)) .gt
+ & .(sscin_width(hit)/2.+sscin_slop(hit))) then
+
+ sscin_on_track(trk,hit) = .false.
+ else
+ sscin_on_track(trk,hit) = .true.
+*** Check for good TDC
+ if (sscin_tdc_pos(hit) .ge. sscin_tdc_min .and.
+ & sscin_tdc_pos(hit) .le. sscin_tdc_max.and.
+ > keep_pos(hit)) then
+
+** Calculate time for each tube with a good tdc. 'pos' side first.
+ sgood_tdc_pos(trk,hit) = .true.
+ sntof = sntof + 1
+ adc_ph = sscin_adc_pos(hit)
+ path = sscin_pos_coord(hit) - sscin_long_coord(hit)
+
+* Convert TDC value to time, do pulse height correction, correction for
+* propogation of light thru scintillator, and offset.
+ time = sscin_tdc_pos(hit) * sscin_tdc_to_time
+ time = time - sscin_pos_phc_coeff(hit) *
+ & sqrt(max(0.,(adc_ph/sscin_pos_minph(hit)-1.)))
+ time = time - path/sscin_vel_light(hit)
+ sscin_pos_time(hit) = time - sscin_pos_time_offset(hit)
+ endif
+
+** Repeat for pmts on 'negative' side
+ if (sscin_tdc_neg(hit).ge.sscin_tdc_min .and. !good tdc
+ 1 sscin_tdc_neg(hit).le.sscin_tdc_max.and.
+ > keep_neg(hit)) then
+
+ sgood_tdc_neg(trk,hit) = .true.
+ sntof = sntof + 1
+ adc_ph = sscin_adc_neg(hit)
+ path = sscin_long_coord(hit) - sscin_neg_coord(hit)
+ time = sscin_tdc_neg(hit) * sscin_tdc_to_time
+ time = time - sscin_neg_phc_coeff(hit) *
+ & sqrt(max(0.,(adc_ph/sscin_neg_minph(hit)-1.)))
+ time = time - path/sscin_vel_light(hit)
+ sscin_neg_time(hit) = time - sscin_neg_time_offset(hit)
+ endif
+
+** Calculate ave time for scintillator and error.
+ if (sgood_tdc_pos(trk,hit)) then
+ if (sgood_tdc_neg(trk,hit)) then
+ sscin_time(hit) = (sscin_neg_time(hit) + sscin_pos_time(hit))/2.
+ sscin_sigma(hit) = sqrt(sscin_neg_sigma(hit)**2 +
+ 1 sscin_pos_sigma(hit)**2)/2.
+ sgood_scin_time(trk,hit) = .true.
+ sntof_pairs = sntof_pairs + 1
+ else
+ sscin_time(hit) = sscin_pos_time(hit)
+ sscin_sigma(hit) = sscin_pos_sigma(hit)
+ sgood_scin_time(trk,hit) = .true.
+* sgood_scin_time(trk,hit) = .false.
+ endif
+ else ! if sgood_tdc_neg = .false.
+ if (sgood_tdc_neg(trk,hit)) then
+ sscin_time(hit) = sscin_neg_time(hit)
+ sscin_sigma(hit) = sscin_neg_sigma(hit)
+ sgood_scin_time(trk,hit) = .true.
+* sgood_scin_time(trk,hit) = .false.
+ endif
+ endif
+c Get time at focal plane
+ if (sgood_scin_time(trk,hit)) then
+ sscin_time_fp(hit) = sscin_time(hit)
+ & - (sscin_zpos(hit)/(29.979*betap) *
+ & sqrt(1.+sxp_fp(trk)*sxp_fp(trk)+syp_fp(trk)*syp_fp(trk)) )
+ sum_fp_time = sum_fp_time + sscin_time_fp(hit)
+ num_fp_time = num_fp_time + 1
+ sum_plane_time(plane)=sum_plane_time(plane)
+ & +sscin_time_fp(hit)
+ num_plane_time(plane)=num_plane_time(plane)+1
+ snum_scin_hit(trk) = snum_scin_hit(trk) + 1
+ sscin_hit(trk,snum_scin_hit(trk)) = hit
+ sscin_fptime(trk,snum_scin_hit(trk)) = sscin_time_fp(hit)
+
+ if (sgood_tdc_pos(trk,hit) .and. sgood_tdc_neg(trk,hit)) then
+ snum_pmt_hit(trk) = snum_pmt_hit(trk) + 2
+ else
+ snum_pmt_hit(trk) = snum_pmt_hit(trk) + 1
+ endif
+ if (sgood_tdc_pos(trk,hit)) then
+ if (sgood_tdc_neg(trk,hit)) then
+ sdedx(trk,snum_scin_hit(trk)) = sqrt(max(0.,
+ & sscin_adc_pos(hit)*sscin_adc_neg(hit)))
+ else
+ sdedx(trk,snum_scin_hit(trk))=max(0.,sscin_adc_pos(hit))
+ endif
+ else
+ if(sgood_tdc_neg(trk,hit)) then
+ sdedx(trk,snum_scin_hit(trk))=max(0.,sscin_adc_neg(hit))
+ else
+ sdedx(trk,snum_scin_hit(trk))=0.
+ endif
+ endif
+ endif
+
+ endif !end of 'if scintillator was on the track'
+
+** See if there are any good time measurements in the plane.
+ if (sgood_scin_time(trk,hit)) then
+ sgood_plane_time(trk,plane) = .true. !still in loop over hits.
+ endif
+
+ enddo !end of loop over hit scintillators
+
+** Fit beta if there are enough time measurements (one upper, one lower)
+ if ((sgood_plane_time(trk,1) .or. sgood_plane_time(trk,2)) .and.
+ 1 (sgood_plane_time(trk,3) .or. sgood_plane_time(trk,4))) then
+ call s_tof_fit(abort,errmsg,trk) !fit velocity of particle
+ if (abort) then
+ call g_prepend(here,errmsg)
+ return
+ endif
+ else !cannot fit beta from given time measurements
+ sbeta(trk) = 0.
+ sbeta_chisq(trk) = -1.
+ endif
+
+ if (num_fp_time .ne. 0) then
+ stime_at_fp(trk) = sum_fp_time / float(num_fp_time)
+ endif
+
+ do ind=1,4
+ if (num_plane_time(ind) .ne. 0) then
+ s_fptime(ind)=sum_plane_time(ind)/float(num_plane_time(ind))
+ else
+ s_fptime(ind)=1000.*ind
+ endif
+ enddo
+
+ s_fptimedif(1)=s_fptime(1)-s_fptime(2)
+ s_fptimedif(2)=s_fptime(1)-s_fptime(3)
+ s_fptimedif(3)=s_fptime(1)-s_fptime(4)
+ s_fptimedif(4)=s_fptime(2)-s_fptime(3)
+ s_fptimedif(5)=s_fptime(2)-s_fptime(4)
+ s_fptimedif(6)=s_fptime(3)-s_fptime(4)
+*
+* Dump tof common blocks if (sdebugprinttoftracks is set
+
+ if(sdebugprinttoftracks.ne.0 ) call s_prt_tof(trk)
+
+ if(sntracks_fp.gt.1000) then
+ if(trk.eq.1) write(*,'(/1x,''sos tol='',f8.2)') time_tolerance
+ write(*,'(5i3,4L2,7f7.2)') trk,nfound,jmax,timehist(max(1,jmax)),
+ > snum_pmt_hit(trk),
+ > sgood_plane_time(trk,1),sgood_plane_time(trk,3),
+ > sgood_plane_time(trk,2),sgood_plane_time(trk,4),
+ > stime_at_fp(trk),sbeta(trk),sbeta_chisq(trk),
+ > sdelta_tar(trk),sy_tar(trk),sxp_tar(trk),syp_tar(trk)
+ endif
+
+ enddo !end of loop over tracks
+*
+ 666 continue
+
+ RETURN
+ END
diff --git a/STRACKING/s_tof_fit.f b/STRACKING/s_tof_fit.f
new file mode 100644
index 0000000..e1e3e82
--- /dev/null
+++ b/STRACKING/s_tof_fit.f
@@ -0,0 +1,98 @@
+ subroutine s_tof_fit(abort,errmsg,trk)
+
+*-------------------------------------------------------------------
+* author: John Arrington
+* created: 2/22/94
+*
+* s_tof_fit fits the velocity of the paritcle from the corrected
+* times generated by s_tof.
+*
+* modifications:
+* $Log: s_tof_fit.f,v $
+* Revision 1.6 1996/09/04 20:36:55 saw
+* (JRA) Don't forget the sqrt in pathnorm
+*
+* Revision 1.5 1995/05/22 19:45:59 cdaq
+* (SAW) Split gen_data_data_structures into gen, hms, sos, and coin parts"
+*
+* Revision 1.4 1995/02/23 13:28:35 cdaq
+* (JRA) Add track index to sgood_scin_time
+*
+* Revision 1.3 1994/11/23 14:15:49 cdaq
+* * (SPB) Recopied from hms file and modified names for SOS
+*
+* Revision 1.2 1994/06/14 04:36:30 cdaq
+* (DFG) Protect against divide by 0 in beta calc
+*
+* Revision 1.1 1994/04/13 18:45:19 cdaq
+* Initial revision
+*
+*-------------------------------------------------------------------
+
+ implicit none
+
+ include 'sos_data_structures.cmn'
+ include 'sos_scin_parms.cmn'
+ include 'sos_scin_tof.cmn'
+
+ logical abort
+ character*1024 errmsg
+ character*20 here
+ parameter (here = 's_tof_fit')
+
+ real*4 sumw, sumt, sumz, sumzz, sumtz
+ real*4 scin_weight
+ real*4 tmp, t0 ,tmpdenom
+ real*4 pathnorm
+ integer*4 hit, trk
+ save
+
+ sumw = 0.
+ sumt = 0.
+ sumz = 0.
+ sumzz = 0.
+ sumtz = 0.
+
+ do hit = 1 , sscin_tot_hits
+ if (sgood_scin_time(trk,hit)) then
+ scin_weight = 1./sscin_sigma(hit)**2
+ sumw = sumw + scin_weight
+ sumt = sumt + scin_weight * sscin_time(hit)
+ sumz = sumz + scin_weight * sscin_zpos(hit)
+ sumzz = sumzz + scin_weight * sscin_zpos(hit)**2
+ sumtz = sumtz + scin_weight * sscin_zpos(hit) *
+ 1 sscin_time(hit)
+ endif
+ enddo
+
+* The formula for beta (and t0) come from taking chi-squared (as
+* defined below), and differentiating with respect to each
+* of the fit paramters (beta and t0 for fit to z=beta*(t-t0)).
+* Setting both of these derivatives to zero gives the minumum
+* chisquared (since they are quadratic in beta and t0), and
+* gives a solution for beta in terms of sums of z, t, and w.
+
+ tmp = sumw*sumzz - sumz*sumz
+ t0 = (sumt*sumzz - sumz*sumtz) / tmp
+ tmpdenom = sumw*sumtz - sumz*sumt
+ if(tmpdenom .gt. 1.e-10) then
+ sbeta(trk) = tmp / tmpdenom !velocity in cm/ns.
+ sbeta_chisq(trk) = 0.
+ do hit = 1 , sscin_tot_hits
+ if (sgood_scin_time(trk,hit)) then
+ sbeta_chisq(trk) = sbeta_chisq(trk) +
+ 1 (sscin_zpos(hit)/sbeta(trk) -
+ 1 (sscin_time(hit) - t0))**2 / sscin_sigma(hit)**2
+ endif
+ enddo
+
+ pathnorm = sqrt(1 + sxp_fp(trk)**2 + syp_fp(trk)**2)
+ sbeta(trk) = sbeta(trk) * pathnorm !take angle into account
+ sbeta(trk) = sbeta(trk) / 29.979 !velocity/c
+ else
+ sbeta(trk) = 0. !set unphysical beta
+ sbeta_chisq(trk) = -2
+ endif !end if on denomimator = 0.
+
+ return
+ end
diff --git a/STRACKING/s_tof_init.f b/STRACKING/s_tof_init.f
new file mode 100644
index 0000000..8e8f506
--- /dev/null
+++ b/STRACKING/s_tof_init.f
@@ -0,0 +1,104 @@
+ subroutine s_tof_init(abort,err)
+
+*-------------------------------------------------------------------
+* author: John Arrington
+* created: 2/22/94
+*
+* s_tof_init sets up the track independant parameters
+* for fitting the tof of the particle.
+*
+* modifications: 31 Mar 1994 DFG Check for 0 hits
+* $Log: s_tof_init.f,v $
+* Revision 1.5 1995/05/22 19:46:00 cdaq
+* (SAW) Split gen_data_data_structures into gen, hms, sos, and coin parts"
+*
+* Revision 1.4 1995/02/23 15:58:54 cdaq
+* (JRA) Change shodo_center_coord to shodo_center.
+* Make minph variables into per pmt constants.
+*
+* Revision 1.3 1994/11/23 14:23:05 cdaq
+* (SPB) Recopied from hms file and modified names for SOS
+*
+* Revision 1.2 1994/06/01 15:40:08 cdaq
+* (SAW) Change declaration of err to *(*)
+*
+* Revision 1.1 1994/04/13 18:45:03 cdaq
+* Initial revision
+*
+*-------------------------------------------------------------------
+
+ implicit none
+
+ include 'sos_data_structures.cmn'
+ include 'sos_scin_parms.cmn'
+ include 'sos_scin_tof.cmn'
+
+ logical abort
+ character*(*) err
+ character*20 here
+ parameter (here = 's_tof_init')
+
+ integer*4 ihit,plane,counter
+ save
+
+ if(sscin_tot_hits.gt.0) then
+ do ihit = 1 , sscin_tot_hits
+
+ plane = sscin_plane_num(ihit) !from s_raw_scin common block.
+ counter = sscin_counter_num(ihit)
+
+ sscin_slop(ihit) = shodo_slop(plane)
+ sscin_pos_sigma(ihit) = shodo_pos_sigma(plane,counter)
+ sscin_neg_sigma(ihit) = shodo_neg_sigma(plane,counter)
+ sscin_center_coord(ihit) = shodo_center(plane,counter)
+ sscin_vel_light(ihit) = shodo_vel_light(plane,counter)
+ sscin_pos_phc_coeff(ihit) = shodo_pos_phc_coeff(plane,counter)
+ sscin_neg_phc_coeff(ihit) = shodo_neg_phc_coeff(plane,counter)
+ sscin_pos_time_offset(ihit) = shodo_pos_time_offset(plane,counter)
+ sscin_neg_time_offset(ihit) = shodo_neg_time_offset(plane,counter)
+ sscin_pos_minph(ihit) = shodo_pos_minph(plane,counter)
+ sscin_neg_minph(ihit) = shodo_neg_minph(plane,counter)
+
+ if (plane .eq. 1) then !1x
+ sscin_zpos(ihit) = sscin_1x_zpos
+ if (2*int(float(counter)/2.) .eq. counter) then !even tube, in back.
+ sscin_zpos(ihit) = sscin_zpos(ihit) + sscin_1x_dzpos
+ endif
+ sscin_pos_coord(ihit) = sscin_1x_left
+ sscin_neg_coord(ihit) = sscin_1x_right
+ sscin_width(ihit) = sscin_1x_size
+ else if (plane .eq. 2) then !1y
+ sscin_zpos(ihit) = sscin_1y_zpos
+ if (2*int(float(counter)/2.) .eq. counter) then !even tube, in back.
+ sscin_zpos(ihit) = sscin_zpos(ihit) + sscin_1y_dzpos
+ endif
+ sscin_pos_coord(ihit) = sscin_1y_bot
+ sscin_neg_coord(ihit) = sscin_1y_top
+ sscin_width(ihit) = sscin_1y_size
+ else if (plane .eq. 3) then !2x
+ sscin_zpos(ihit) = sscin_2x_zpos
+ if (2*int(float(counter)/2.) .eq. counter) then !even tube, in back.
+ sscin_zpos(ihit) = sscin_zpos(ihit) + sscin_2x_dzpos
+ endif
+ sscin_pos_coord(ihit) = sscin_2x_left
+ sscin_neg_coord(ihit) = sscin_2x_right
+ sscin_width(ihit) = sscin_2x_size
+ else if (plane .eq. 4) then !2y
+ sscin_zpos(ihit) = sscin_2y_zpos
+ if (2*int(float(counter)/2.) .eq. counter) then !even tube, in back.
+ sscin_zpos(ihit) = sscin_zpos(ihit) + sscin_2y_dzpos
+ endif
+ sscin_pos_coord(ihit) = sscin_2y_bot
+ sscin_neg_coord(ihit) = sscin_2y_top
+ sscin_width(ihit) = sscin_2y_size
+ else
+ abort = .true.
+ write(err,*) 'Trying to init. sos hodoscope plane',plane
+ call g_prepend(here,err)
+ return
+ endif
+
+ enddo
+ endif ! end test on zero hits
+ return
+ end
diff --git a/STRACKING/s_track.f b/STRACKING/s_track.f
new file mode 100644
index 0000000..fbc5f28
--- /dev/null
+++ b/STRACKING/s_track.f
@@ -0,0 +1,103 @@
+ SUBROUTINE S_TRACK(ABORT,err)
+*--------------------------------------------------------
+*-
+*- Purpose and Methods : Finds and fits tracks in SOS focal plane
+*-
+*- Required Input BANKS SOS_DECODED_DC
+*-
+*- Output BANKS SOS_FOCAL_PLANE
+*- SOS_DECODED_DC hit coordinates
+*-
+*- Output: ABORT - success or failure
+*- : err - reason for failure, if any
+*-
+*- Created 19-JAN-1994 D. F. Geesaman
+* $Log: s_track.f,v $
+* Revision 1.5 1996/09/04 20:19:45 saw
+* (JRA) Initialize sstubmin variables
+*
+* Revision 1.4 1995/10/11 12:31:21 cdaq
+* (JRA) Only call tracking routines when it is warranted
+*
+* Revision 1.3 1995/05/22 19:46:00 cdaq
+* (SAW) Split gen_data_data_structures into gen, hms, sos, and coin parts"
+*
+* Revision 1.2 1994/04/13 18:51:49 cdaq
+* (DFG) Add call to s_fill_dc_fp_hist
+*
+* Revision 1.1 1994/02/21 16:42:12 cdaq
+* Initial revision
+*
+*--------------------------------------------------------
+ IMPLICIT NONE
+ SAVE
+*
+ character*7 here
+ parameter (here= 'S_TRACK')
+*
+ logical ABORT
+ character*(*) err
+ integer*4 ierr
+ character*5 line_err
+*
+ INCLUDE 'sos_data_structures.cmn'
+ INCLUDE 'sos_tracking.cmn'
+ INCLUDE 'gen_constants.par'
+ INCLUDE 'gen_units.par'
+
+*--------------------------------------------------------
+*
+*
+ if (sdc_tot_hits.ne.0) then
+ call S_PATTERN_RECOGNITION(ABORT,err)
+ if(ABORT) then
+ call G_add_path(here,err)
+ return
+ endif
+
+*
+ if (snspace_points_tot.ne.0) then
+ call S_LEFT_RIGHT(ABORT,err)
+ if(ABORT) then
+ call G_add_path(here,err)
+ return
+ endif
+*
+ sstubminx = 999999.
+ sstubminy = 999999.
+ sstubminxp = 999999.
+ sstubminyp = 999999.
+ call S_LINK_STUBS(ABORT,err)
+ if(ABORT) then
+ call G_add_path(here,err)
+ return
+ endif
+*
+ if (sntracks_fp.ne.0) then
+ call S_TRACK_FIT(ABORT,err,ierr)
+ if(ABORT) then
+ call G_add_path(here,err)
+ return
+ endif
+* Check for internal error in S_TRACK_FIT
+ if(ierr.ne.0) then
+ line_err=' '
+ call CSETDI(ierr,line_err,1,5)
+ err='MUNUIT ERROR IN S_TRACK_FIT' // line_err
+ call G_add_path(here,err)
+ call G_LOG_MESSAGE(err)
+ endif
+* histogram focal plane tracks
+*
+ call s_fill_dc_fp_hist(ABORT,err)
+ if(ABORT) then
+ call g_add_path(here,err)
+ return
+ endif
+*
+ endif !(sntracks_fp.ne.0)
+ endif !(snspace_points_tot.ne.0)
+ endif !(sdc_tot_hits.ne.0)
+
+ return
+ end
diff --git a/STRACKING/s_track_fit.f b/STRACKING/s_track_fit.f
new file mode 100644
index 0000000..64d412a
--- /dev/null
+++ b/STRACKING/s_track_fit.f
@@ -0,0 +1,228 @@
+ subroutine S_TRACK_FIT(ABORT,err,ierr)
+* primary track fitting routine for the SOS spectrometer
+*
+* Called by S_TRACK
+*
+* d.f. geesaman 8 Sept 1993
+* $Log: s_track_fit.f,v $
+* Revision 1.8 1996/01/17 18:56:08 cdaq
+* (JRA) Fill sdc_plane_wirecenter and sdc_plane_wirecoord arrays
+*
+* Revision 1.7 1995/10/11 18:15:12 cdaq
+* (JRA) Comment out MINUIT track fitting for now.
+*
+* Revision 1.6 1995/08/31 20:44:56 cdaq
+* (JRA) Don't fill single_residual arrray
+*
+* Revision 1.5 1995/07/20 19:06:05 cdaq
+* (SAW) Move data statements for f2c compatibility
+*
+* Revision 1.4 1995/05/22 19:46:01 cdaq
+* (SAW) Split gen_data_data_structures into gen, hms, sos, and coin parts"
+*
+* Revision 1.3 1995/04/06 19:45:16 cdaq
+* (JRA) Rename residuals variables
+*
+* Revision 1.2 1994/11/23 14:24:18 cdaq
+* (SPB) Recopied from hms file and modified names for SOS
+*
+* Revision 1.1 1994/02/21 16:42:27 cdaq
+* Initial revision
+*
+ implicit none
+ include "sos_data_structures.cmn"
+ include "sos_tracking.cmn"
+ include "sos_geometry.cmn"
+*
+c external S_FCNCHISQ
+c external S_DPSIFUN
+c real*8 S_DPSIFUN
+c real*8 S_FCNCHISQ
+*
+* local variables
+*
+ logical ABORT
+ character*11 here
+ parameter (here='S_TRACK_FIT')
+ character*(*) err
+ integer*4 itrk ! track loop index
+ integer*4 i,j ! loop index
+ integer*4 ierr ! error return flag
+c integer*4 ivarbl ! dummy MINUIT variable
+ integer*4 ihit, pln, hit
+c real*8 pos
+ real*8 dray(snum_fpray_param)
+ real*8 TT(snum_fpray_param)
+ real*8 AA(snum_fpray_param,snum_fpray_param)
+c real*8 error(snum_fpray_param)
+c real*8 initialray(snum_fpray_param)
+c real*8 initialsteps(snum_fpray_param)
+c real*8 zero
+c real*8 arglis(10)
+c real*8 bnd1,bnd2 ! unused MUNUIT output variables
+ real*8 chi2
+c real*8 fedm,errder ! unused MUNUIT output variables
+c integer*4 npari,nparz,istat ! unused MUNUIT output variables
+c character*10 fitnames(4)
+
+c data initialray/0.D0,0.D0,.5D-2,.5D-2/ ! starting ray values
+c data initialsteps/1.D0,1.D0,.5E-2,.5D-2/
+c data zero/0.0D0/
+c data fitnames/' x_t ',' y_t ','tan(xp)','tan(yp)'/
+
+c save initialray,initialsteps,fitnames ! starting ray, steps, names
+ integer*4 remap(snum_fpray_param)
+ data remap/5,6,3,4/
+ save remap
+*
+ ABORT= .FALSE.
+ ierr=0
+* initailize residuals
+
+ do pln=1,sdc_num_planes
+ do itrk=1,sntracks_fp
+ sdc_double_residual(itrk,pln)=1000
+ sdc_single_residual(itrk,pln)=1000
+ enddo
+c fill the 1d arrays from the 2d arrays in h_physics (don't clear here).
+c sdc_sing_res(pln)=1000
+ sdc_dbl_res(pln)=1000
+ enddo
+
+* test for no tracks
+ if(sntracks_fp.ge.1) then
+ do itrk=1,sntracks_fp
+ strack_fit_num=itrk
+
+* are there enough degrees of freedom
+ snfree_fp(itrk)=sntrack_hits(itrk,1)-snum_fpray_param
+ if(snfree_fp(itrk).gt.0) then
+
+c* initialize parameters
+c do i=1,snum_fpray_param
+c call MNPARM(i,fitnames(i),initialray(i),initialsteps(i),
+c & zero,zero,ierr)
+c if(ierr.ne.0) then
+c write(sluno,'(a,i,a)') ' Unable to define parameter no.',i,
+c & fitnames(i)
+c ierr=1
+c go to 1000 ! error return
+c endif
+c enddo ! end loop over track param
+c do i=1,10
+c arglis(i)=0.
+c enddo
+c* Do track fit on track number strack_fit_num (passes in sos_tracking)
+c Call MNSETI(' Track Fitting in SOS Spectrometer')
+c Call MNEXCM(S_FCNCHISQ,'MIGRAD',arglis,0,ierr)
+c Call MNEXCM(S_FCNCHISQ,'MINOS',arglis,0,ierr)
+c Call MNSTAT(chi2,fedm,errder,npari,nparz,istat)
+c do i=1,snum_fpray_param
+c call MNPOUT(i,fitnames(i),ray(i),error(i),bnd1,bnd2,ivarbl)
+c enddo
+c sx_fp(itrk)=real(ray(1))
+c sy_fp(itrk)=real(ray(2))
+c sz_fp(itrk)=0. ! z=0 of tracking.
+c sxp_fp(itrk)=real(ray(3))
+c syp_fp(itrk)=real(ray(4))
+c schi2_fp(itrk)=real(chi2)
+c
+c* calculate residuals
+c ray1(1)=dble(sx_fp(itrk))
+c ray1(2)=dble(sy_fp(itrk))
+c ray1(3)=dble(sxp_fp(itrk))
+c ray1(4)=dble(syp_fp(itrk))
+c do ihit=2,sntrack_hits(itrk,1)+1
+c hit=sntrack_hits(itrk,ihit)
+c pln=sdc_plane_num(hit)
+c pos=s_dpsifun(ray1,pln)
+c sdc_single_residual(itrk,pln)=sdc_wire_coord(hit)-pos
+c enddo
+c endif ! end test on degrees of freedom
+c enddo ! end loop over tracks
+c endif
+
+* initialize parameters
+ do i=1,snum_fpray_param
+ TT(i)=0.
+ do ihit=2,sntrack_hits(itrk,1)+1
+ hit=sntrack_hits(itrk,ihit)
+ pln=sdc_plane_num(hit)
+ TT(i)=TT(i)+((sdc_wire_coord(hit)*
+ & splane_coeff(remap(i),pln))
+ & /(sdc_sigma(pln)*sdc_sigma(pln)))
+ enddo
+ enddo
+ do i=1,snum_fpray_param
+ do j=1,snum_fpray_param
+ AA(i,j)=0.
+ if(j.lt.i)then
+ AA(i,j)=AA(j,i)
+ else
+ do ihit=2,sntrack_hits(itrk,1)+1
+ hit=sntrack_hits(itrk,ihit)
+ pln=sdc_plane_num(hit)
+ AA(i,j)=AA(i,j) + (
+ & splane_coeff(remap(i),pln)*splane_coeff(remap(j)
+ $ ,pln)/(sdc_sigma(pln)*sdc_sigma(pln)))
+ enddo ! end loop on ihit
+ endif ! end test on j .lt. i
+ enddo ! end loop on j
+ enddo ! end loop on i
+*
+* solve four by four equations
+ call solve_four_by_four(TT,AA,dray,ierr)
+*
+ if(ierr.ne.0) then
+ dray(1)=10000.
+ dray(2)=10000.
+ dray(3)=2.
+ dray(4)=2.
+ else
+* calculate chi2
+ chi2=0.
+
+* ray(1)=dray(1)
+* ray(2)=dray(2)
+* ray(3)=dray(3)
+* ray(4)=dray(4)
+
+* calculate hit coord at each plane for chisquared and efficiency calculations.
+ do pln=1,sdc_num_planes
+ sdc_track_coord(itrk,pln)=splane_coeff(remap(1),pln)*dray(1)
+ & +splane_coeff(remap(2),pln)*dray(2)
+ & +splane_coeff(remap(3),pln)*dray(3)
+ & +splane_coeff(remap(4),pln)*dray(4)
+ enddo
+
+ do ihit=2,sntrack_hits(itrk,1)+1
+ hit=sntrack_hits(itrk,ihit)
+ pln=sdc_plane_num(hit)
+
+* note chi2 is single precision
+ sdc_plane_wirecenter(itrk,pln)=sdc_wire_center(hit)
+ sdc_plane_wirecoord(itrk,pln)=sdc_wire_coord(hit)
+
+ sdc_single_residual(itrk,pln)=
+ & sdc_wire_coord(hit)-sdc_track_coord(itrk,pln)
+ chi2=chi2+
+ & (sdc_single_residual(itrk,pln)/sdc_sigma(pln))**2
+ enddo
+ endif
+
+ sx_fp(itrk)=dray(1)
+ sy_fp(itrk)=dray(2)
+ sz_fp(itrk)=0. ! z=0 of tracking.
+ sxp_fp(itrk)=dray(3)
+ syp_fp(itrk)=dray(4)
+ endif ! end test on degrees of freedom
+ schi2_fp(itrk)=chi2
+ enddo ! end loop over tracks
+ endif
+
+* test if we want to dump out trackfit results
+ if(sdebugtrackprint.ne.0) then
+ call s_print_tracks
+ endif ! end test on zero tracks
+1000 return
+ end
diff --git a/STRACKING/s_track_tests.f b/STRACKING/s_track_tests.f
new file mode 100644
index 0000000..87a7b87
--- /dev/null
+++ b/STRACKING/s_track_tests.f
@@ -0,0 +1,421 @@
+ SUBROUTINE s_track_tests
+*
+* Derek made this in Mar 1996
+*
+* This routine delivers some handy tracking information. It's divided
+* into three parts. The first part looks at the chambers and their
+* efficiency. The second part defines some scintillator tests to determine
+* whether the chambers should have fired. The last part puts this info
+* into different files. Also, if you want to look at the stub tests you
+* you can uncomment some lines in s_link_stubs.f to get that output.
+* A final note. Many of these tests have similar counterparts in
+* trackeff.test; if you change something here, make sure it agrees with the
+* the tests there!!
+*
+* $Log: s_track_tests.f,v $
+* Revision 1.3 2002/09/26 14:54:03 jones
+* Add variables sweet1xscin,sweet1yscin,sweet2xscin,sweet2yscin
+* which record which scint got hit inside the defined scint region
+* Then hgoodscinhits is set to zero if front and back hodoscopes
+* are abs(sweet1xscin-sweet2xscin).gt.3 or bs(sweet1yscin-sweet2yscin).gt.2
+*
+* Revision 1.2 1996/09/04 20:19:12 saw
+* (JRA) Treat logicals as logicals
+*
+* Revision 1.1 1996/05/02 14:38:55 saw
+* Initial revision
+*
+ IMPLICIT NONE
+ SAVE
+*
+ character*50 here
+ parameter (here= 'S_TRACK_TESTS')
+
+ INCLUDE 'sos_data_structures.cmn'
+ INCLUDE 'coin_data_structures.cmn'
+ INCLUDE 'gen_constants.par'
+ INCLUDE 'sos_tracking.cmn'
+ INCLUDE 'gen_units.par'
+ INCLUDE 'gen_event_info.cmn'
+ INCLUDE 'sos_scin_tof.cmn'
+ INCLUDE 'sos_scin_parms.cmn'
+ INCLUDE 'sos_calorimeter.cmn'
+ include 'sos_bypass_switches.cmn'
+
+ integer planetemp
+ real*4 stestbeta
+ integer txth,txthp,txthps,txthpss,txtft,txtct
+
+ integer i,j,count
+ integer testsum
+ integer shitsweet1x,shitsweet1y,shitsweet2x,shitsweet2y
+ integer sweet1xscin,sweet1yscin,sweet2xscin,sweet2yscin
+
+ real*4 lastcointime
+ real*4 thiscointime
+
+*In c_keep_results, the cointime is updated depending on tracking information
+*Because we're independent of tracking here, we have to do some tricks to
+*update the cointime. We set cointime=100.0 if the code hasn't updated it (ie,
+*it's the same as the previous event...). First, if it's not a coincidence
+*event, we just set the cointime to zero.
+
+ thiscointime=0.0
+ if (gen_event_type.eq.3) then
+ thiscointime=ccointime_sos
+ if (thiscointime.eq.lastcointime) then
+ thiscointime=100.0
+ endif
+ lastcointime=ccointime_sos
+ endif
+
+*this next file prints out events the fail to track and why. You can then
+*look at them with the event display to see if they're worrisome.
+ if (sbypass_track_eff_files.eq.0) then
+ open(unit=15,file='scalers/strackeff.txt',status='unknown',
+ $ access='append')
+ endif
+
+*this next file outputs a huge ascii file with many tracking parameters. It
+*is intended for use with physica. The order of the ouput is given in the write
+*statement at the end of this file.
+ if (sbypass_track_eff_files.eq.0) then
+ open(unit=17,file='scalers/strack.out',status='unknown',
+ $ access='append')
+ endif
+
+*we start by looking at the chambers. First, we look to see if each plane fired
+
+ s1hit1 = (SDC_HITS_PER_PLANE(1).GE.1)
+ s1hit2 = (SDC_HITS_PER_PLANE(2).GE.1)
+ s1hit3 = (SDC_HITS_PER_PLANE(3).GE.1)
+ s1hit4 = (SDC_HITS_PER_PLANE(4).GE.1)
+ s1hit5 = (SDC_HITS_PER_PLANE(5).GE.1)
+ s1hit6 = (SDC_HITS_PER_PLANE(6).GE.1)
+ s1hit7 = (SDC_HITS_PER_PLANE(7).GE.1)
+ s1hit8 = (SDC_HITS_PER_PLANE(8).GE.1)
+ s1hit9 = (SDC_HITS_PER_PLANE(9).GE.1)
+ s1hit10 = (SDC_HITS_PER_PLANE(10).GE.1)
+ s1hit11 = (SDC_HITS_PER_PLANE(11).GE.1)
+ s1hit12 = (SDC_HITS_PER_PLANE(12).GE.1)
+
+*next, we see how many hits per plane there were ...
+
+ snumhit1 = SDC_HITS_PER_PLANE(1)
+ snumhit2 = SDC_HITS_PER_PLANE(2)
+ snumhit3 = SDC_HITS_PER_PLANE(3)
+ snumhit4 = SDC_HITS_PER_PLANE(4)
+ snumhit5 = SDC_HITS_PER_PLANE(5)
+ snumhit6 = SDC_HITS_PER_PLANE(6)
+ snumhit7 = SDC_HITS_PER_PLANE(7)
+ snumhit8 = SDC_HITS_PER_PLANE(8)
+ snumhit9 = SDC_HITS_PER_PLANE(9)
+ snumhit10 = SDC_HITS_PER_PLANE(10)
+ snumhit11 = SDC_HITS_PER_PLANE(11)
+ snumhit12 = SDC_HITS_PER_PLANE(12)
+
+ snumhits1 = SDC_HITS_PER_PLANE(1) + SDC_HITS_PER_PLANE(2) +
+ $ SDC_HITS_PER_PLANE(3) + SDC_HITS_PER_PLANE(4) +
+ $ SDC_HITS_PER_PLANE(5) + SDC_HITS_PER_PLANE(6)
+ snumhits2 = SDC_HITS_PER_PLANE(7) + SDC_HITS_PER_PLANE(8) +
+ $ SDC_HITS_PER_PLANE(9) + SDC_HITS_PER_PLANE(10) +
+ $ SDC_HITS_PER_PLANE(11) + SDC_HITS_PER_PLANE(12)
+
+*next we check to see if we have fewer than the max allowed hits per chamber
+*this number should agree with the value in trackeff.test.
+
+ s1hitslt = snumhits1.LE.smax_pr_hits(1)
+ s2hitslt = snumhits2.LE.smax_pr_hits(2)
+
+*next we check to see if we have the minimum number of planes per chamber
+*this number should agree with the value in trackeff.test.
+
+ planetemp = 0
+ if(SDC_HITS_PER_PLANE(1).GE.1) planetemp = planetemp+1
+ if(SDC_HITS_PER_PLANE(2).GE.1) planetemp = planetemp+1
+ if(SDC_HITS_PER_PLANE(3).GE.1) planetemp = planetemp+1
+ if(SDC_HITS_PER_PLANE(4).GE.1) planetemp = planetemp+1
+ if(SDC_HITS_PER_PLANE(5).GE.1) planetemp = planetemp+1
+ if(SDC_HITS_PER_PLANE(6).GE.1) planetemp = planetemp+1
+ snumplanes1 = planetemp
+ planetemp = 0
+ if(SDC_HITS_PER_PLANE(7).GE.1) planetemp = planetemp+1
+ if(SDC_HITS_PER_PLANE(8).GE.1) planetemp = planetemp+1
+ if(SDC_HITS_PER_PLANE(9).GE.1) planetemp = planetemp+1
+ if(SDC_HITS_PER_PLANE(10).GE.1) planetemp = planetemp+1
+ if(SDC_HITS_PER_PLANE(11).GE.1) planetemp = planetemp+1
+ if(SDC_HITS_PER_PLANE(12).GE.1) planetemp = planetemp+1
+ snumplanes2 = planetemp
+
+ s1planesgt = snumplanes1.GE.smin_hit(1)
+ s2planesgt = snumplanes2.GE.smin_hit(2)
+
+*we now fill in the chamber part of the track tests.
+
+ sfoundtrack = (sntracks_fp.NE.0)
+ if (sfoundtrack) then
+ stestbeta=ssbeta
+ else
+ stestbeta=0.0
+ endif
+ scleantrack = (ssnum_fptrack.NE.0).AND.(ssbeta.GT.(0.1))
+*shitslt is less than max allowed hits in both chambers
+ shitslt = s1hitslt.AND.s2hitslt
+*splanesgt is at least the minimum number of planes fired per chamber
+ splanesgt = s1planesgt.AND.s2planesgt
+*sspacepoints is finding at least one space point in both chambers
+ sspacepoints = ((snspace_points(1).GE.1).AND.(snspace_points(2).GE.1))
+*sstublt is passing the stub criteria for at least one spacepoint in both chambers
+ sstublt = (sstubtest.ne.0)
+*shitsplanes is passing not too many hits and not too few planes
+ shitsplanes = shitslt.AND.splanesgt
+*shitsplanessps is that and finding a spacepoint
+ shitsplanessps = shitsplanes.AND.sspacepoints
+*shitsplanesspsstubs is that and passing the stub tests
+ shitsplanesspsstubs = shitsplanessps.AND.sstublt
+*fXsspacepoints is pasisng htis and planes but failing to find a space point
+ f1sspacepoints = s1hitslt.AND.s1planesgt.AND.(snspace_points(1).EQ.0)
+ f2sspacepoints = s2hitslt.AND.s2planesgt.AND.(snspace_points(2).EQ.0)
+ fsspacepoints = f1sspacepoints.OR.f2sspacepoints
+
+************************now look at some hodoscope tests
+*second, we move the scintillators. here we use scintillator cuts to see
+*if a track should have been found.
+
+ snumscins1 = sscin_hits_per_plane(1)
+ snumscins2 = sscin_hits_per_plane(2)
+ snumscins3 = sscin_hits_per_plane(3)
+ snumscins4 = sscin_hits_per_plane(4)
+
+*first, fill the arrays of which scins were sit
+ do i=1,4
+ do j=1,sscin_2x_nr
+ sscinhit(i,j)=0
+ enddo
+ enddo
+ do i=1,sscin_tot_hits
+ sscinhit(sscin_plane_num(i),sscin_counter_num(i))=1
+ enddo
+
+*next, look for clusters of hits in a scin plane. a cluster is a group of
+*adjacent scintillator hits separated by a non-firing scintillator.
+*Wwe count the number of three adjacent scintillators too. (A signle track
+*shouldn't fire three adjacent scintillators.
+
+ do i=1,4
+ snclust(i)=0
+ sthreescin(i)=0
+ enddo
+
+*look for clusters in first x plane... (9 scins)
+ count=0
+ if (sscinhit(1,1).EQ.1) count=count+1
+ do i=1,(sscin_1x_nr-1) !look for number of clusters of 1 or more hits
+ if ((sscinhit(1,i).EQ.0).AND.(sscinhit(1,i+1).EQ.1)) count=count+1
+ enddo
+ snclust(1)=count
+ count=0
+ do i=1,(sscin_1x_nr-2) !look for three or more adjacent hits
+ if ((sscinhit(1,i).EQ.1).AND.(sscinhit(1,i+1).EQ.1).AND.
+ $ (sscinhit(1,i+2).EQ.1)) count=count+1
+ enddo
+ if (count.GT.0) sthreescin(1)=1
+*look for clusters in second x plane... (16 scins)
+ count=0
+ if (sscinhit(3,1).EQ.1) count=count+1
+ do i=1,(sscin_2x_nr-1) !look for number of clusters of 1 or more hits
+ if ((sscinhit(3,i).EQ.0).AND.(sscinhit(3,i+1).EQ.1)) count=count+1
+ enddo
+ snclust(3)=count
+ count=0
+ do i=1,(sscin_2x_nr-2) !look for three or more adjacent hits
+ if ((sscinhit(3,i).EQ.1).AND.(sscinhit(3,i+1).EQ.1).AND.
+ $ (sscinhit(3,i+2).EQ.1)) count=count+1
+ enddo
+ if (count.GT.0) sthreescin(3)=1
+*look for clusters in y planes... (9 scins)
+ do j=2,4,2
+ count=0
+ if (sscinhit(j,1).EQ.1) count=count+1
+ do i=1,(sscin_1y_nr-1) !look for number of clusters of 1 or more hits
+ if ((sscinhit(j,i).EQ.0).AND.(sscinhit(j,i+1).EQ.1)) count=count+1
+ enddo
+ snclust(j)=count
+ count=0
+ do i=1,(sscin_1y_nr-2) !look for three or more adjacent sits
+ if ((sscinhit(j,i).EQ.1).AND.(sscinhit(j,i+1).EQ.1).AND.
+ $ (sscinhit(j,i+2).EQ.1)) count=count+1
+ enddo
+ if (count.GT.0) sthreescin(j)=1
+ enddo
+ if ((gen_event_ID_number.GT.1000).AND.((snclust(2).GT.1).OR.
+ $ (sthreescin(2).EQ.1))) then
+ if (sbypass_track_eff_files.eq.0) then
+ write(15,*) 'three or cluster in 1st yplane event',gen_event_ID_number
+ endif
+ endif
+
+*now put some "tracking" like cuts on the sslopes, based only on scins...
+*by "slope" here, I mean the difference in the position of scin hits in two
+*like-planes. For example, a track that those great straight through will
+*have a slope of zero. If it moves one scin over from s1x to s2x it has an
+*x-slope of 1... I pick the minimum slope if there are multiple scin hits.
+ sbestxpscin=100
+ sbestypscin=100
+ do i=1,sscin_2x_nr
+ do j=1,sscin_2x_nr
+ if ((sscinhit(1,i).EQ.1).AND.(sscinhit(3,j).EQ.1)) then
+ sslope=abs(i-j)
+ if (sslope.LT.sbestxpscin) sbestxpscin=sslope
+ endif
+ enddo
+ enddo
+ do i=1,10
+ do j=1,10
+ if ((sscinhit(2,i).EQ.1).AND.(sscinhit(4,j).EQ.1)) then
+ sslope=abs(i-j)
+ if (sslope.LT.sbestypscin) sbestypscin=sslope
+ endif
+ enddo
+ enddo
+
+*next we mask out the edge scintillators, and look at triggers that happened
+*at the center of the acceptance. To change which scins are in the mask
+*change the values of s*loscin and s*hiscin in stracking.param
+ shitsweet1x=0
+ shitsweet1y=0
+ shitsweet2x=0
+ shitsweet2y=0
+ sgoodscinhits=0
+*first x plane. first see if there are hits inside the scin region
+ do i=sxloscin(1),sxhiscin(1)
+ if (sscinhit(1,i).EQ.1) then
+ shitsweet1x=1
+ sweet1xscin=i
+ endif
+ enddo
+* next make sure nothing fired outside the good region
+ do i=1,sxloscin(1)-1
+ if (sscinhit(1,i).EQ.1) shitsweet1x=-1
+ enddo
+ do i=sxhiscin(1)+1,sscin_1x_nr
+ if (sscinhit(1,i).EQ.1) shitsweet1x=-1
+ enddo
+*second x plane. first see if there are hits inside the scin region
+ do i=sxloscin(2),sxhiscin(2)
+ if (sscinhit(3,i).EQ.1) then
+ shitsweet2x=1
+ sweet2xscin=i
+ endif
+ enddo
+* next make sure nothing fired outside the good region
+ do i=1,sxloscin(2)-1
+ if (sscinhit(3,i).EQ.1) shitsweet2x=-1
+ enddo
+ do i=sxhiscin(2)+1,sscin_2x_nr
+ if (sscinhit(3,i).EQ.1) shitsweet2x=-1
+ enddo
+
+*first y plane. first see if there are hits inside the scin region
+ do i=syloscin(1),syhiscin(1)
+ if (sscinhit(2,i).EQ.1) then
+ shitsweet1y=1
+ sweet1yscin=i
+ endif
+ enddo
+* next make sure nothing fired outside the good region
+ do i=1,syloscin(1)-1
+ if (sscinhit(2,i).EQ.1) shitsweet1y=-1
+ enddo
+ do i=syhiscin(1)+1,sscin_1y_nr
+ if (sscinhit(2,i).EQ.1) shitsweet1y=-1
+ enddo
+*second y plane. first see if there are hits inside the scin region
+ do i=syloscin(2),syhiscin(2)
+ if (sscinhit(4,i).EQ.1) then
+ shitsweet2y=1
+ sweet2yscin=i
+ endif
+ enddo
+* next make sure nothing fired outside the good region
+ do i=1,syloscin(2)-1
+ if (sscinhit(4,i).EQ.1) shitsweet2y=-1
+ enddo
+ do i=syhiscin(2)+1,sscin_2y_nr
+ if (sscinhit(4,i).EQ.1) shitsweet2y=-1
+ enddo
+
+ testsum=shitsweet1x+shitsweet1y+shitsweet2x+shitsweet2y
+* now define a 3/4 or 4/4 trigger of only good scintillators the value
+* is specified in stracking.param...
+ if (testsum.GE.strack_eff_test_num_scin_planes) sgoodscinhits=1
+
+* require front/back hodoscopes be within close to each other.,
+ if (sgoodscinhits.eq.1 .and. strack_eff_test_num_scin_planes.eq.4) then
+ if (abs(sweet1xscin-sweet2xscin).gt.3) sgoodscinhits=0
+ if (abs(sweet1yscin-sweet2yscin).gt.2) sgoodscinhits=0
+ endif
+
+*******************************************************************************
+* here's where we start writing to the files. Uncomment these lines and
+* the corresponding file open and close lines at the beginning and end
+* of this file if you want this output. the scaler report should take
+* care of most people though...
+*
+ if (sbypass_track_eff_files.eq.0) then
+ if (sgoodscinhits.EQ.1) then
+ write(15,*) 'sweet spot hit, event number ',gen_event_ID_number
+ endif
+ if (.not.shitslt) then
+ write(15,*) 'too many hits, event number ',gen_event_ID_number
+ endif
+ if (.not.splanesgt) then
+ write(15,*) 'too few planes event number ',
+ $ gen_event_ID_number
+ endif
+ if (shitsplanes.AND.(.not.sspacepoints)) then
+ write(15,*) 'p sits/planes, f sp # = ',gen_event_ID_number
+ endif
+ if ((.not.sfoundtrack).AND.shitsplanessps) then
+ write(15,*) 'p sits/planes/sps, f track # = ',gen_event_ID_number
+ endif
+ if (sspacepoints.AND.(.not.sstublt)) then
+ write(15,*) 'p sp, f stubs # = ',gen_event_ID_number
+ endif
+ endif
+
+*the rest of this file prepares the output of htrack.out. If you're not
+*writing to that file, do't' worry about this.
+
+ if (sbypass_track_eff_files.eq.0) then
+ txth=0
+ if (shitslt) txth=1
+ txthp=0
+ if (shitsplanes) txthp=1
+ txthps=0
+ if (shitsplanessps) txthps=1
+ txthpss=0
+ if (shitsplanesspsstubs) txthpss=1
+ txtft=0
+ if (sfoundtrack) txtft=1
+ txtct=0
+ if (scleantrack) txtct=1
+
+ write(17,902) gen_event_ID_number,snumhits1,snumhits2,
+ $ snumhit1,snumhit2,snumhit3,snumhit4,
+ $ snumhit5,snumhit6,snumhit7,snumhit8,
+ $ snumhit9,snumhit10,snumhit11,snumhit12,
+ $ snumplanes1,snumplanes2,snumscins1,snumscins2,
+ $ snumscins3,snumscins4,snclust(1),snclust(2),
+ $ snclust(3),snclust(4),sthreescin(1),sthreescin(2),
+ $ sthreescin(3),sthreescin(4),sbestxpscin,sbestypscin,
+ $ sgoodscinhits,
+ $ txtft,txtct,sntracks_fp,sbeta_notrk,stestbeta,scal_et,ssshtrk,
+ $ scer_npe_sum,sschi2perdeg,ssdelta,thiscointime
+ 902 format(1x,i6,i4,i4,12(i4),2(i2),4(i3),8(i2),2(i4),i2,i2,i2,i2,f10.3,f9.3,
+ $ f9.3,f9.3,f9.3,f10.3,f10.3,f10.3)
+
+ close(15) !closes "strackeff.txt"
+ close(17) !closes "strack.out"
+ endif
+ end
diff --git a/STRACKING/s_tracks_cal.f b/STRACKING/s_tracks_cal.f
new file mode 100644
index 0000000..01a7783
--- /dev/null
+++ b/STRACKING/s_tracks_cal.f
@@ -0,0 +1,165 @@
+*=======================================================================
+ subroutine s_tracks_cal(abort,errmsg)
+*=======================================================================
+*-
+*- Purpose: Associates clusters with detector tracks which are inside
+*- the calorimeter fiducial volume. A track and a cluster
+*- are considered as matched if the distance in X projection
+*- between these two is less than half the block width.
+*-
+*- Input Banks: SOS_CLUSTERS_CAL, SOS_FOCAL_PLANE,SOS_GEOMETRY_CAL
+*-
+*- Output Bank: SOS_TRACK_CAL
+*-
+*- Created: 15 Mar 1994 Tsolak A. Amatuni
+*- Modified 25 Mar 1994 DFG
+*- Change name of print routine
+*- Modified 9 Apr 1998 Added a switch to turn on the fiducial
+*- cut. The default for this is now no cut.
+*- K.G. Vansyoc
+* $Log: s_tracks_cal.f,v $
+* Revision 1.10.6.1 2007/09/10 20:28:01 pcarter
+* Implemented changes to allow compilation on RHEL 3,4,5 and MacOSX
+*
+* Revision 1.10 2005/03/15 20:08:23 jones
+* Modify the criterion for matching track and calorimeter cluster. As before,
+* the track must hit within (0.5*scal_block_xsize + scal_slop) of the cluster
+* position. Previously if more than one cluster was within
+* (0.5*scal_block_xsize + scal_slop) then the last cluster in the loop was
+* associated with the track. Now, if more than one cluster meets that
+* condition then cluster which has a position closest to the track is
+* associated with the track.
+*
+* Revision 1.9 2003/04/03 00:45:01 jones
+* Update to calorimeter calibration (V. Tadevosyan)
+*
+* Revision 1.8 1999/02/23 19:01:45 csa
+* (JRA) Clean up logical structure, remove sdebugcalcpeds stuff
+*
+* Revision 1.7 1999/01/29 17:34:59 saw
+* Add variables for second tubes on shower counter
+*
+* Revision 1.6 1997/02/13 14:13:29 saw
+* (JRA) Correct error in position of top edge of fiducial cut.
+*
+* Revision 1.5 1996/01/17 18:54:41 cdaq
+* (JRA) Add sdebugcalcpeds flag
+*
+* Revision 1.4 1995/08/31 20:45:28 cdaq
+* (JRA) Use off-track blocks to accumulate pedestal data
+*
+* Revision 1.3 1995/05/22 19:46:01 cdaq
+* (SAW) Split gen_data_data_structures into gen, hms, sos, and coin parts"
+*
+* Revision 1.2 1994/11/23 14:24:46 cdaq
+* * (SPB) Recopied from hms file and modified names for SOS
+*
+* Revision 1.1 1994/04/13 16:16:04 cdaq
+* Initial revision
+*
+*-----------------------------------------------------------------------
+*
+*
+ implicit none
+ save
+*
+ logical abort
+ character*(*) errmsg
+ character*12 here
+ parameter (here='S_TRACKS_CAL')
+*
+ integer*4 nt !Track number
+ integer*4 nc !Cluster number
+ real*4 xf !X position of track on calorimeter front surface
+ real*4 xb !X position of track on calorimeter back surface
+ real*4 yf !Y position of track on calorimeter front surface
+ real*4 yb !Y position of track on calorimeter back surface
+ real*4 dz_f !Distance along Z axis between focal plane and
+ real*4 dz_b !calorimeter front(f) and back(b) surfaces
+ real*4 delta_x !Distance between track & cluster in X projection
+ logical*4 track_in_fv
+
+ integer*4 t_nt, t_nc
+ real*4 t_minx, temp_x
+
+ include 'sos_data_structures.cmn'
+ include 'sos_calorimeter.cmn'
+ include 'sos_tracking.cmn'
+
+ sntracks_cal=0
+ if(sntracks_fp.le.0) go to 100 !Return
+*
+* Compute impact point coordinates on the calorimeter front and back surfaces
+*
+ do nt=1,sntracks_fp
+ dz_f=scal_zmin-sz_fp(nt)
+ dz_b=scal_zmax-sz_fp(nt)
+
+ xf=sx_fp(nt)+sxp_fp(nt)*dz_f
+ xb=sx_fp(nt)+sxp_fp(nt)*dz_b
+
+ yf=sy_fp(nt)+syp_fp(nt)*dz_f
+ yb=sy_fp(nt)+syp_fp(nt)*dz_b
+
+ strack_xc(nt) = xf
+ strack_yc(nt) = yf
+
+ track_in_fv = (xf.le.scal_fv_xmax .and. xf.ge.scal_fv_xmin .and.
+ & xb.le.scal_fv_xmax .and. xb.ge.scal_fv_xmin .and.
+ & yf.le.scal_fv_ymax .and. yf.ge.scal_fv_ymin .and.
+ & yb.le.scal_fv_ymax .and. yb.ge.scal_fv_ymin)
+
+
+
+* Initialize scluster_track(nt)
+ if(scal_fv_test.eq.0) then !not using fv test
+ scluster_track(nt)=-1
+ else !using fv test
+ if (track_in_fv) then
+ scluster_track(nt)=0 !Track is inside the fiducial volume
+ else
+ scluster_track(nt)=-1 !Track is outside the fiducial volume
+ endif
+ endif
+
+*
+*----------If inside fv (or no test), search for a cluster matching this track
+*
+ if((scal_fv_test.ne.0.and.track_in_fv) .or. scal_fv_test.eq.0) then
+
+ if(snclusters_cal.gt.0) then
+ t_minx = 99999
+ t_nt = 1
+ t_nc = 1
+ do nc=1,snclusters_cal
+ delta_x=abs(xf-scluster_xc(nc))
+ if(delta_x.le.(0.5*scal_block_xsize + scal_slop)) then
+
+!! TH - Check the deviation distance for each track for each cluster. If
+!! distance smaller assign to t_minx. Eventually want to associate
+!! the track with the smallest deviation to the cluster. Increment
+!! tracks for calorimeter though whenever condition above is passed
+
+ temp_x = delta_x
+ if(temp_x.lt.t_minx) then
+ t_minx = temp_x
+ t_nt = nt
+ t_nc = nc
+ endif
+ sntracks_cal =sntracks_cal+1
+ endif !End ... if matched
+ enddo !End loop over clusters
+
+ scluster_track(t_nt)=t_nc !Track matches cluster #nc with min deviation
+ endif !End ... if number of clusters > 0
+ endif !End ... if inside fiducial volume
+ enddo !End loop over detector tracks
+
+ 100 continue
+ if(sdbg_tracks_cal.gt.0) call s_prt_cal_tracks
+
+c Collect data for SOS calorimeter calibration.
+ if(sdbg_tracks_cal.lt.0) call s_cal_calib(0)
+
+ return
+ end
diff --git a/STRACKING/s_trans_cal.f b/STRACKING/s_trans_cal.f
new file mode 100644
index 0000000..35d4b0c
--- /dev/null
+++ b/STRACKING/s_trans_cal.f
@@ -0,0 +1,135 @@
+ subroutine s_trans_cal(abort,errmsg)
+*=======================================================================
+*-
+*- Purpose: Computes the energy deposited in each of the hit
+*- counters, the energy deposition in calorimeter
+*- columns and the total energy deposition, using only
+*- the calorimeter information.
+*- The energy depositions are not corrected yet for
+*- impact point coordinate dependence.
+*- The subroutine also returns the X and Z coordinates
+*- of the hit block centers.
+*-
+*- Input Banks: SOS_SPARSIFIED_CAL, SOS_CAL_CONST,SOS_CAL_MONITOR
+*-
+*- Output Bank: SOS_DECODED_CAL
+*-
+*- Created: 15 Mar 1994 Tsolak A. Amatuni
+* $Log: s_trans_cal.f,v $
+* Revision 1.8 2004/05/12 15:38:59 jones
+* Initialize ssshsum and ssshtrk to zero.
+*
+* Revision 1.7 2003/04/03 00:45:01 jones
+* Update to calorimeter calibration (V. Tadevosyan)
+*
+* Revision 1.6 1999/02/04 18:18:30 saw
+* Fix calculation of energy for blocks with two tubes
+*
+* Revision 1.5 1999/02/03 21:13:45 saw
+* Code for new Shower counter tubes
+*
+* Revision 1.4 1999/01/29 17:34:59 saw
+* Add variables for second tubes on shower counter
+*
+* Revision 1.3 1995/05/22 19:46:02 cdaq
+* (SAW) Split gen_data_data_structures into gen, hms, sos, and coin parts"
+*
+* Revision 1.2 1994/11/23 14:45:40 cdaq
+* * (SPB) Recopied from hms file and modified names for SOS
+*
+* Revision 1.1 1994/02/21 16:42:44 cdaq
+* Initial revision
+*
+*--------------------------------------------------------
+ implicit none
+ save
+*
+ logical abort
+ character*(*) errmsg
+ character*11 here
+ parameter (here='S_TRANS_CAL')
+*
+ integer*4 nb !Block number
+ integer*4 nh !Hit number
+ integer*4 row !Row number
+ integer*4 col !Column number
+ real*4 adc_pos, adc_neg !ADC-PED value
+*
+ include 'sos_data_structures.cmn'
+ include 'sos_calorimeter.cmn'
+*
+* Sparsify the raw data
+*
+ call s_sparsify_cal(abort,errmsg)
+ if(abort) then
+ call g_add_path(here,errmsg)
+ return
+ endif
+*
+ snhits_cal =0
+ scal_e1 =0.
+ scal_e2 =0.
+ scal_e3 =0.
+ scal_e4 =0.
+ scal_et =0.
+ ssshsum = 0.
+ ssshtrk = 0.
+*
+ scal_e1_pos =0.
+ scal_e1_neg =0.
+*
+ scal_e2_pos =0.
+ scal_e2_neg =0.
+
+ if(scal_num_hits.le.0) go to 100 !Return
+*
+* Loop over hits
+*
+ do nh=1,scal_num_hits
+ row=scal_rows(nh)
+ col=scal_cols(nh)
+ adc_pos=scal_adcs_pos(nh)
+ adc_neg=scal_adcs_neg(nh)
+ nb =row+smax_cal_rows*(col-1)
+*
+*------Determine position and energy deposition for each block
+ sblock_xc(nh)=scal_block_xc(nb)
+ sblock_zc(nh)=scal_block_zc(nb)
+ if(col.le.scal_num_neg_columns) then ! Blocks with two tubes
+ sblock_de_pos(nh)=adc_pos*scal_pos_cal_const(nb)
+ $ *scal_pos_gain_cor(nb)
+ sblock_de_neg(nh)=adc_neg*scal_neg_cal_const(nb)
+ $ *scal_neg_gain_cor(nb)
+ sblock_de(nh)=sblock_de_pos(nh)+sblock_de_neg(nh)
+ else ! Blocks with single tube
+ sblock_de(nh)=adc_pos*scal_pos_cal_const(nb)*scal_pos_gain_cor(nb)
+ sblock_de_pos(nh)=sblock_de(nh)
+ endif
+*
+*------Accumulate the integral energy depositions
+ if(col.eq.1) then
+ scal_e1=scal_e1+sblock_de(nh)
+ if(scal_num_neg_columns.ge.1) then
+ scal_e1_pos=scal_e1_pos+sblock_de_pos(nh)
+ scal_e1_neg=scal_e1_neg+sblock_de_neg(nh)
+ endif
+ else if (col.eq.2) then
+ scal_e2=scal_e2+sblock_de(nh)
+ if(scal_num_neg_columns.ge.2) then
+ scal_e2_pos=scal_e2_pos+sblock_de_pos(nh)
+ scal_e2_neg=scal_e2_neg+sblock_de_neg(nh)
+ endif
+ else if(col.eq.3) then
+ scal_e3=scal_e3+sblock_de(nh)
+ else if(col.eq.4) then
+ scal_e4=scal_e4+sblock_de(nh)
+ endif
+ scal_et=scal_et+sblock_de(nh) ! Is sblock_de de_pos+de_neg?
+ enddo !End loop over hits
+ snhits_cal=scal_num_hits
+*
+ 100 continue
+ if(sdbg_decoded_cal.gt.0) call s_prt_cal_decoded
+*
+ return
+ end
diff --git a/STRACKING/s_trans_cer.f b/STRACKING/s_trans_cer.f
new file mode 100644
index 0000000..9c2452b
--- /dev/null
+++ b/STRACKING/s_trans_cer.f
@@ -0,0 +1,52 @@
+ subroutine s_trans_cer(abort,errmsg)
+
+*-------------------------------------------------------------------
+* author: Chris Cothran
+* created: 5/25/95
+*
+* s_trans_cer fills the sos_decoded_cer common block
+* with track independent corrections and parameters
+* $Log: s_trans_cer.f,v $
+* Revision 1.2 1996/01/17 18:45:10 cdaq
+* (JRA) Make scer_adc pedestal subtracted value
+*
+* Revision 1.1 1995/08/31 15:04:22 cdaq
+* Initial revision
+*
+*-------------------------------------------------------------------
+
+ implicit none
+
+ include 'sos_data_structures.cmn'
+ include 'sos_cer_parms.cmn'
+
+ logical abort
+ character*1024 errmsg
+ character*20 here
+ parameter (here = 's_trans_cer')
+
+ integer*4 nhit,tube
+
+ save
+
+ abort = .false.
+
+ scer_num_hits = 0
+ do tube=1,scer_num_mirrors
+ scer_npe(tube) = 0.
+ scer_adc(tube) = 0.
+ enddo
+ scer_npe_sum = 0.
+ do nhit = 1, scer_tot_hits
+ tube = scer_tube_num(nhit)
+ scer_adc(tube) = scer_raw_adc(nhit) - scer_ped(tube)
+ if (scer_adc(tube) .gt. scer_width(tube)) then
+ scer_num_hits = scer_num_hits + 1
+ scer_tube_num(scer_num_hits) = tube
+ scer_npe(tube) = scer_adc(tube) * scer_adc_to_npe(tube)
+ scer_npe_sum = scer_npe_sum + scer_npe(tube)
+ endif
+ enddo
+
+ return
+ end
diff --git a/STRACKING/s_trans_dc.f b/STRACKING/s_trans_dc.f
new file mode 100644
index 0000000..33aa548
--- /dev/null
+++ b/STRACKING/s_trans_dc.f
@@ -0,0 +1,172 @@
+ SUBROUTINE S_TRANS_DC(ABORT,err)
+*--------------------------------------------------------
+*-
+*- Purpose and Methods : Translate SOS raw drift and start time
+*- to decoded information
+*-
+*- Required Input BANKS SOS_RAW_DC
+*- SOS_DECODED_SCIN
+*-
+*- Output BANKS SOS_DECODED_DC
+*-
+*- Output: ABORT - success or failure
+*- : err - reason for failure, if any
+*-
+* $Log: s_trans_dc.f,v $
+* Revision 1.13 2002/07/31 20:20:58 saw
+* Only try to fill user hists that are defined
+*
+* Revision 1.12 1996/09/04 20:18:35 saw
+* (??) Cosmetic
+*
+* Revision 1.11 1996/01/17 18:44:30 cdaq
+* (JRA) Change sign on sstart_time
+*
+* Revision 1.10 1995/10/11 13:54:18 cdaq
+* (JRA) Cleanup, add bypass switch to s_dc_eff call
+*
+* Revision 1.9 1995/08/31 15:04:12 cdaq
+* (JRA) Add call to s_dc_eff, warn about invalid plane numbers
+*
+* Revision 1.8 1995/05/22 19:46:02 cdaq
+* (SAW) Split gen_data_data_structures into gen, hms, sos, and coin parts"
+*
+* Revision 1.7 1995/05/17 16:47:43 cdaq
+* (JRA) Add hist for all dc tdc's in one histogram.
+*
+* Revision 1.6 1995/04/06 19:52:15 cdaq
+* (JRA) SMAX_NUM_DC_PLANES -> SDC_NUM_PLANES
+*
+* Revision 1.5 1994/11/23 15:08:04 cdaq
+* (SPB) Recopied from hms file and modified names for SOS
+*
+* Revision 1.4 1994/04/13 18:56:40 cdaq
+* (DFG) Add call to s_fill_dc_dec_hist, remove s_raw_dump_all call
+*
+* Revision 1.3 1994/03/24 19:59:03 cdaq
+* (DFG) add print routines and flags
+* check plane number and wire number for validity
+*
+* Revision 1.2 1994/02/22 14:22:58 cdaq
+* (SAW) replace err='' with ' '
+*
+* Revision 1.1 1994/02/21 16:42:58 cdaq
+* Initial revision
+*
+*--------------------------------------------------------
+ IMPLICIT NONE
+ SAVE
+*
+ character*10 here
+ parameter (here= 'S_TRANS_DC')
+*
+ logical ABORT
+ character*(*) err
+*
+ include 'sos_data_structures.cmn'
+ include 'gen_constants.par'
+ include 'gen_units.par'
+ include 'sos_tracking.cmn'
+ include 'sos_geometry.cmn'
+ include 'sos_track_histid.cmn'
+ include 'sos_bypass_switches.cmn'
+*
+*--------------------------------------------------------
+ real*4 s_drift_dist_calc
+ external s_drift_dist_calc
+ integer*4 ihit,goodhit,old_wire,old_pln,wire,pln,chamber
+ real*4 histval
+*
+ ABORT= .FALSE.
+ err= ' '
+ old_wire = -1
+ old_pln = -1
+ goodhit = 0
+ if (sdc_center(1).eq.0.) then !initialize hdc_center if not yet set.
+ do pln = 1, sdc_num_planes
+ chamber = sdc_chamber_planes(pln)
+ sdc_center(pln) = sdc_xcenter(chamber)
+ $ *sin(sdc_alpha_angle(pln))+sdc_ycenter(chamber)
+ $ *cos(sdc_alpha_angle(pln))
+ enddo
+ endif
+* Are there any raw hits
+ if(sdc_raw_tot_hits.gt.0) then
+* loop over all raw hits
+ do ihit=1,sdc_raw_tot_hits
+ pln = sdc_raw_plane_num(ihit)
+ wire = sdc_raw_wire_num(ihit)
+* check valid plane and wire number
+ if(pln.gt.0 .and. pln.le. sdc_num_planes) then
+ histval=float(sdc_raw_tdc(ihit))
+ if(sidrawtdc.gt.0) call hf1(sidrawtdc,histval,1.)
+* test if tdc value less than lower limit for good hits
+ if(sdc_raw_tdc(ihit) .lt. sdc_tdc_min_win(pln)) then
+ swire_early_mult(wire,pln)
+ $ = swire_early_mult(wire,pln)+1
+ else
+ if(sdc_raw_tdc(ihit) .gt. sdc_tdc_max_win(pln)) then
+ swire_late_mult(wire,pln)
+ $ = swire_late_mult(wire,pln)+1
+ else
+* test for valid wire number
+ if(wire.gt.0 .and. wire.le.sdc_nrwire(pln)) then
+* test for multiple hit on the same wire
+ if(pln.eq.old_pln .and. wire.eq.old_wire) then
+ swire_extra_mult(wire,pln) =
+ $ swire_extra_mult(wire,pln)+1
+ else
+
+* valid hit proceed with decoding
+ goodhit = goodhit + 1
+ sdc_plane_num(goodhit) = sdc_raw_plane_num(ihit)
+ sdc_wire_num(goodhit) = sdc_raw_wire_num(ihit)
+ sdc_tdc(goodhit) = sdc_raw_tdc(ihit)
+
+* if sdc_wire_counting(pln) is 1 then wires are number in reverse order
+ if(sdc_wire_counting(pln).eq.0) then !normal ordering
+ sdc_wire_center(goodhit) = sdc_pitch(pln)
+ & * (float(wire) - sdc_central_wire(pln))
+ & - sdc_center(pln)
+ else
+ sdc_wire_center(goodhit) = sdc_pitch(pln)
+ & * ( (sdc_nrwire(pln) + (1 - wire))
+ & - sdc_central_wire(pln) ) - sdc_center(pln)
+ endif
+
+ sdc_drift_time(goodhit) = - sstart_time
+ & - float(sdc_tdc(goodhit))*sdc_tdc_time_per_channel
+ & + sdc_plane_time_zero(pln)
+
+* find dist in pattern_recognition, after apply propogation correction.
+* sdc_drift_dis(goodhit) =
+* & s_drift_dist_calc(pln,wire,sdc_drift_time(goodhit))
+ sdc_hits_per_plane(pln)=sdc_hits_per_plane(pln)+1
+ endif ! end test on duplicate wire
+ old_pln = pln
+ old_wire = wire
+ endif ! end test on valid wire number
+ endif ! end test on hdc_tdc_max_win
+ endif ! end test on hdc_tdc_min_win
+ else ! if not a valid plane number
+ write(6,*) 'S_TRANS_DC: invalid plane number = ',pln
+ endif ! end test on valid plane number
+ enddo ! end loop over raw hits
+
+*
+* set total number of good hits
+*
+ sdc_tot_hits = goodhit
+*
+ if (sbypass_dc_eff.eq.0) call s_dc_eff !only call if there was a hit.
+*
+ endif ! end test on sdc_raw_tot_hits.gt.0
+*
+*
+* Dump decoded banks if flag is set
+ if(sdebugprintdecodeddc.ne.0) then
+ call s_print_decoded_dc(ABORT,err)
+ endif
+*
+ RETURN
+ END
diff --git a/STRACKING/s_trans_misc.f b/STRACKING/s_trans_misc.f
new file mode 100644
index 0000000..bc4a944
--- /dev/null
+++ b/STRACKING/s_trans_misc.f
@@ -0,0 +1,61 @@
+ subroutine s_trans_misc(abort,errmsg)
+*-------------------------------------------------------------------
+* author: John Arrington
+* created: 4/8/95
+*
+* s_trans_misc fills the sos_decoded_misc common block
+*
+* $Log: s_trans_misc.f,v $
+* Revision 1.6 1999/01/27 16:02:45 saw
+* Check if some hists are defined before filling
+*
+* Revision 1.5 1996/09/04 20:18:07 saw
+* (JRA) Add misc. tdc's
+*
+* Revision 1.4 1996/01/24 16:08:38 saw
+* (JRA) Replace 48 with smax_misc_hits
+*
+* Revision 1.3 1996/01/17 18:12:35 cdaq
+* (JRA) Misc. fixes.
+*
+* Revision 1.2 1995/05/22 19:46:03 cdaq
+* (SAW) Split gen_data_data_structures into gen, hms, sos, and coin parts"
+*
+* Revision 1.1 1995/04/12 03:59:23 cdaq
+* Initial revision
+*
+*
+*--------------------------------------------------------
+
+ implicit none
+
+ include 'sos_data_structures.cmn'
+ include 'sos_scin_parms.cmn'
+ include 'sos_id_histid.cmn'
+
+ logical abort
+ character*1024 errmsg
+ character*20 here
+ parameter (here = 's_trans_misc')
+
+ integer*4 ihit,ich,isig
+
+ save
+
+ do ihit = 1 , smax_misc_hits
+ smisc_dec_data(ihit,1) = 0 ! Clear TDC's
+ smisc_dec_data(ihit,2) = -1 ! Clear ADC's
+ enddo
+
+ do ihit = 1 , smisc_tot_hits
+ ich=smisc_raw_addr2(ihit)
+ isig=smisc_raw_addr1(ihit)
+ smisc_dec_data(ich,isig) = smisc_raw_data(ihit)
+ smisc_scaler(ich,isig) = smisc_scaler(ich,isig) + 1
+ if (isig.eq.1.and.sidmisctdcs.gt.0) then !TDC
+ call hf1(sidmisctdcs,float(smisc_dec_data(ich,isig)),1.)
+ endif
+ enddo
+
+ return
+ end
diff --git a/STRACKING/s_trans_scin.f b/STRACKING/s_trans_scin.f
new file mode 100644
index 0000000..ad7fa47
--- /dev/null
+++ b/STRACKING/s_trans_scin.f
@@ -0,0 +1,353 @@
+ subroutine s_trans_scin(abort,errmsg)
+*--------------------------------------------------------
+* author: John Arrington
+* created: 2/22/94
+*
+* s_trans_scin fills the sos_decoded_scin common block
+* with track independant corrections and parameters
+* needed for the drift chamber and tof analysis.
+*
+* $Log: s_trans_scin.f,v $
+* Revision 1.14 2005/03/15 21:13:09 jones
+* Add code to filter the scintillator tdc hits and group them by time. ( P. Bosted)
+*
+* Revision 1.13 1999/06/10 16:57:58 csa
+* (JRA) Cosmetic changes
+*
+* Revision 1.12 1996/04/30 17:15:39 saw
+* (JRA) Cleanup
+*
+* Revision 1.11 1996/01/17 18:21:56 cdaq
+* (JRA) Misc. fixes.
+*
+* Revision 1.10 1995/05/22 19:46:03 cdaq
+* (SAW) Split gen_data_data_structures into gen, hms, sos, and coin parts"
+*
+* Revision 1.9 1995/05/17 16:48:22 cdaq
+* (JRA) Add hscintimes user histogram
+*
+* Revision 1.8 1995/05/11 15:10:59 cdaq
+* (JRA) Replace hardwired TDC offsets with ctp variables. Fix latent hmsism.
+*
+* Revision 1.7 1995/04/06 19:52:59 cdaq
+* (JRA) Change hardwired TDC offset to 100
+*
+* Revision 1.6 1995/02/23 13:25:28 cdaq
+* (JRA) Add a calculation of beta without finding a track
+*
+* Revision 1.5 1995/01/18 21:00:24 cdaq
+* (SAW) Catch negative ADC values in argument of square root
+*
+* Revision 1.4 1994/11/23 15:08:24 cdaq
+* * (SPB) Recopied from hms file and modified names for SOS
+*
+* Revision 1.3 1994/04/13 20:07:02 cdaq
+* (SAW) Fix a typo
+*
+* Revision 1.2 1994/04/13 19:00:06 cdaq
+* (DFG) 3/24 Add s_prt_scin_raw raw bank dump routine
+* Add s_prt_scin_dec decoded print routine
+* Add test for zero hits and skip all but initialization
+* Commented out setting abort = .true.
+* Add ABORT and errmsg to arguements
+* (DFG) 4/5 Move prt_scin_raw to s_raw_dump_all routine
+* (DFG) 4/12 Add call to s_fill_scin_raw_hist
+*
+* Revision 1.1 1994/02/21 16:43:53 cdaq
+* Initial revision
+*
+*--------------------------------------------------------
+
+ implicit none
+
+ include 'sos_data_structures.cmn'
+ include 'sos_scin_parms.cmn'
+ include 'sos_scin_tof.cmn'
+ include 'sos_id_histid.cmn'
+
+ logical abort
+ character*1024 errmsg
+ character*20 here
+ parameter (here = 's_trans_scin')
+
+ integer*4 dumtrk
+ parameter (dumtrk=1)
+ integer*4 ihit, plane
+ integer*4 time_num
+ real*4 time_sum
+ real*4 fptime
+ real*4 scint_center
+ real*4 hit_position
+ real*4 dist_from_center
+ real*4 pos_path, neg_path
+ real*4 pos_ph(smax_scin_hits) !pulse height (channels)
+ real*4 neg_ph(smax_scin_hits)
+ real*4 postime(smax_scin_hits)
+ real*4 negtime(smax_scin_hits)
+ logical goodtime(snum_scin_planes)
+ integer timehist(200),i,j,jmax,maxhit,nfound
+ real*4 time_pos(1000),time_neg(1000),tmin,time_tolerance
+ logical keep_pos(1000),keep_neg(1000),first/.true./
+ save
+
+ abort = .false.
+
+** Find scintillators with real hits (good TDC values)
+ call s_strip_scin(abort,errmsg)
+ if (abort) then
+ call g_prepend(here,errmsg)
+ return
+ endif
+
+** Initialize track-independant quantaties.
+ call s_tof_init(abort,errmsg)
+ if (abort) then
+ call g_prepend(here,errmsg)
+ return
+ endif
+
+ sgood_start_time = .false.
+ if( sscin_tot_hits .gt. 0) then
+** Histogram raw scin
+ call s_fill_scin_raw_hist(abort,errmsg)
+ if (abort) then
+ call g_prepend(here,errmsg)
+ return
+ endif
+ endif
+
+** Return if no valid hits.
+ if( sscin_tot_hits .le. 0) return
+
+! Calculate all corrected hit times and histogram
+! This uses a copy of code below. Results are save in time_pos,neg
+! including the z-pos. correction assuming nominal value of betap
+! Code is currently hard-wired to look for a peak in the
+! range of 0 to 100 nsec, with a group of times that all
+! agree withing a time_tolerance of time_tolerance nsec. The normal
+! peak position appears to be around 35 nsec (SOS0 or 31 nsec (HMS)
+! NOTE: if want to find farticles with beta different than
+! reference particle, need to make sure this is big enough
+! to accomodate difference in TOF for other particles
+! Default value in case user hasnt definedd something reasonable
+ time_tolerance=3.0
+ if(stof_tolerance.gt.0.5.and.stof_tolerance.lt.10000.) then
+ time_tolerance=stof_tolerance
+ endif
+ if(first) then
+ first=.false.
+ write(*,'(//1x,''USING '',f8.2,'' NSEC WINDOW FOR'',
+ > '' SOS FP NO_TRACK CALCULATIONS'')') time_tolerance
+ write(*,'(//)')
+ endif
+ nfound = 0
+ do j=1,200
+ timehist(j)=0
+ enddo
+ do ihit = 1 , sscin_tot_hits
+ i=min(1000,ihit)
+ time_pos(i)=-99.
+ time_neg(i)=-99.
+ keep_pos(i)=.false.
+ keep_neg(i)=.false.
+ if ((sscin_tdc_pos(ihit) .ge. sscin_tdc_min) .and.
+ 1 (sscin_tdc_pos(ihit) .le. sscin_tdc_max) .and.
+ 2 (sscin_tdc_neg(ihit) .ge. sscin_tdc_min) .and.
+ 3 (sscin_tdc_neg(ihit) .le. sscin_tdc_max)) then
+
+ pos_ph(ihit) = sscin_adc_pos(ihit)
+ postime(ihit) = sscin_tdc_pos(ihit) * sscin_tdc_to_time
+ postime(ihit) = postime(ihit) - sscin_pos_phc_coeff(ihit) *
+ 1 sqrt(max(0.,(pos_ph(ihit)/sscin_pos_minph(ihit)-1.)))
+ postime(ihit) = postime(ihit) - sscin_pos_time_offset(ihit)
+
+ neg_ph(ihit) = sscin_adc_neg(ihit)
+ negtime(ihit) = sscin_tdc_neg(ihit) * sscin_tdc_to_time
+ negtime(ihit) = negtime(ihit) - sscin_neg_phc_coeff(ihit) *
+ 1 sqrt(max(0.,(neg_ph(ihit)/sscin_neg_minph(ihit)-1.)))
+ negtime(ihit) = negtime(ihit) - sscin_neg_time_offset(ihit)
+
+* Find hit position. If postime larger, then hit was nearer negative side.
+ dist_from_center = 0.5*(negtime(ihit) - postime(ihit))
+ 1 * sscin_vel_light(ihit)
+ scint_center = (sscin_pos_coord(ihit)+sscin_neg_coord(ihit))/2.
+ hit_position = scint_center + dist_from_center
+ hit_position = min(sscin_pos_coord(ihit),hit_position)
+ hit_position = max(sscin_neg_coord(ihit),hit_position)
+ sscin_dec_hit_coord(ihit) = hit_position
+
+* Get corrected time.
+ pos_path = sscin_pos_coord(ihit) - hit_position
+ neg_path = hit_position - sscin_neg_coord(ihit)
+ postime(ihit) = postime(ihit) - pos_path/sscin_vel_light(ihit)
+ negtime(ihit) = negtime(ihit) - neg_path/sscin_vel_light(ihit)
+ time_pos(i) = postime(ihit) -
+ > sscin_zpos(ihit) / (29.979*sbeta_pcent)
+ time_neg(i) = negtime(ihit) -
+ > sscin_zpos(ihit) / (29.979*sbeta_pcent)
+ nfound = nfound + 1
+ do j=1,200
+ tmin = 0.5*float(j)
+ if(time_pos(i) .gt. tmin .and.
+ > time_pos(i) .lt. tmin + time_tolerance)
+ > timehist(j) = timehist(j) + 1
+ enddo
+ nfound = nfound + 1
+ do j=1,200
+ tmin = 0.5*float(j)
+ if(time_neg(i) .gt. tmin .and.
+ > time_neg(i) .lt. tmin + time_tolerance)
+ > timehist(j) = timehist(j) + 1
+ enddo
+ endif
+ enddo
+! Find bin with most hits
+ jmax=0
+ maxhit=0
+ do j=1,200
+ if(timehist(j) .gt. maxhit) then
+ jmax = j
+ maxhit = timehist(j)
+ endif
+ enddo
+ if(jmax.gt.0) then
+ tmin = 0.5*float(jmax)
+ do ihit = 1 , sscin_tot_hits
+ i=min(1000,ihit)
+ if(time_pos(i) .gt. tmin .and.
+ > time_pos(i) .lt. tmin + time_tolerance) then
+ keep_pos(i) = .true.
+ endif
+ if(time_neg(i) .gt. tmin .and.
+ > time_neg(i) .lt. tmin + time_tolerance) then
+ keep_neg(i) = .true.
+ endif
+ enddo
+ endif
+
+! Resume regular tof code, now using time filer from above
+
+** Check for two good TDC values.
+ do ihit = 1 , sscin_tot_hits
+ if ((sscin_tdc_pos(ihit) .ge. sscin_tdc_min) .and.
+ 1 (sscin_tdc_pos(ihit) .le. sscin_tdc_max) .and.
+ 2 (sscin_tdc_neg(ihit) .ge. sscin_tdc_min) .and.
+ 3 (sscin_tdc_neg(ihit) .le. sscin_tdc_max).and.
+ 4 keep_pos(ihit).and.keep_neg(ihit)) then
+ stwo_good_times(ihit) = .true.
+ else
+ stwo_good_times(ihit) = .false.
+ endif
+ enddo !end of loop that finds tube setting time.
+
+** Get corrected time/adc for each scintillator hit
+ do ihit = 1 , sscin_tot_hits
+ if (stwo_good_times(ihit)) then !both tubes fired
+
+* Correct time for everything except veloc. correction in order to
+* find hit location from difference in tdc.
+ pos_ph(ihit) = sscin_adc_pos(ihit)
+ postime(ihit) = sscin_tdc_pos(ihit) * sscin_tdc_to_time
+ postime(ihit) = postime(ihit) - sscin_pos_phc_coeff(ihit) *
+ 1 sqrt(max(0.,(pos_ph(ihit)/sscin_pos_minph(ihit)-1.)))
+ postime(ihit) = postime(ihit) - sscin_pos_time_offset(ihit)
+
+ neg_ph(ihit) = sscin_adc_neg(ihit)
+ negtime(ihit) = sscin_tdc_neg(ihit) * sscin_tdc_to_time
+ negtime(ihit) = negtime(ihit) - sscin_neg_phc_coeff(ihit) *
+ 1 sqrt(max(0.,(neg_ph(ihit)/sscin_neg_minph(ihit)-1.)))
+ negtime(ihit) = negtime(ihit) - sscin_neg_time_offset(ihit)
+
+* Find hit position. If postime larger, then hit was nearer negative side.
+ dist_from_center = 0.5*(negtime(ihit) - postime(ihit))
+ 1 * sscin_vel_light(ihit)
+ scint_center = (sscin_pos_coord(ihit)+sscin_neg_coord(ihit))/2.
+ hit_position = scint_center + dist_from_center
+ hit_position = min(sscin_pos_coord(ihit),hit_position)
+ hit_position = max(sscin_neg_coord(ihit),hit_position)
+ sscin_dec_hit_coord(ihit) = hit_position
+
+* Get corrected time.
+ pos_path = sscin_pos_coord(ihit) - hit_position
+ neg_path = hit_position - sscin_neg_coord(ihit)
+ postime(ihit) = postime(ihit) - pos_path/sscin_vel_light(ihit)
+ negtime(ihit) = negtime(ihit) - neg_path/sscin_vel_light(ihit)
+ sscin_cor_time(ihit) = ( postime(ihit) + negtime(ihit) )/2.
+
+ else !only 1 tube fired
+ sscin_dec_hit_coord(ihit) = 0.
+ sscin_cor_time(ihit) = 0. !not a very good 'flag', but there is
+ ! the logical stwo_good_hits.
+ endif
+ enddo !loop over hits to find ave time,adc.
+
+* start time calculation. assume xp=yp=0 radians. project all
+* time values to focal plane. use average for start time.
+ time_num = 0
+ time_sum = 0.
+ do ihit = 1 , sscin_tot_hits
+ if (stwo_good_times(ihit)) then
+ fptime = sscin_cor_time(ihit) - sscin_zpos(ihit)/(29.979*sbeta_pcent)
+ call hf1(sidscinalltimes,fptime,1.)
+ if (abs(fptime-sstart_time_center).le.sstart_time_slop) then
+ time_sum = time_sum + fptime
+ time_num = time_num + 1
+ endif
+ endif
+ enddo
+ if (time_num.eq.0) then
+ sgood_start_time = .false.
+ sstart_time = sstart_time_center
+ else
+ sgood_start_time = .true.
+ sstart_time = time_sum / float(time_num)
+ endif
+
+
+* Dump decoded bank if sdebugprintscindec is set
+ if( sdebugprintscindec .ne. 0) call s_prt_dec_scin(ABORT,errmsg)
+
+* Calculate beta without finding track (to reject cosmics for efficiencies)
+* using tube only if both pmts fired since the velocity correction is
+* position (track) dependant.
+* Fitting routine fills variables assuming track=1.
+
+ do plane = 1 , snum_scin_planes
+ goodtime(plane)=.false.
+ enddo
+
+ do ihit = 1 , sscin_tot_hits
+ sgood_scin_time(dumtrk,ihit)=.false.
+ if (stwo_good_times(ihit)) then !require 2 tubes to be track indep.
+ if (abs(fptime-sstart_time_center).le.sstart_time_slop) then !throw out outliers.
+ sgood_scin_time(dumtrk,ihit)=.true.
+ sscin_time(ihit)=sscin_cor_time(ihit)
+ sscin_sigma(ihit)=sqrt(sscin_neg_sigma(ihit)**2 +
+ & sscin_pos_sigma(ihit)**2)/2.
+ goodtime(sscin_plane_num(ihit))=.true.
+ endif
+ endif
+ enddo
+
+
+* Fit beta if there are enough time measurements (one upper, one lower)
+ if ((goodtime(1) .or. goodtime(2)) .and.
+ 1 (goodtime(3) .or. goodtime(4))) then
+
+ sxp_fp(dumtrk)=0.0
+ syp_fp(dumtrk)=0.0
+ call s_tof_fit(abort,errmsg,dumtrk) !fit velocity of particle
+ if (abort) then
+ call g_prepend(here,errmsg)
+ return
+ endif
+ sbeta_notrk = sbeta(dumtrk)
+ sbeta_chisq_notrk = sbeta_chisq(dumtrk)
+ else
+ sbeta_notrk = 0.
+ sbeta_chisq_notrk = -1.
+ endif
+
+ return
+ end
+
diff --git a/STRACKING/s_wire_center_calc.f b/STRACKING/s_wire_center_calc.f
new file mode 100644
index 0000000..5e85265
--- /dev/null
+++ b/STRACKING/s_wire_center_calc.f
@@ -0,0 +1,48 @@
+ function s_wire_center_calc(plane,wire)
+*
+* function to calculate sos wire center positions in sos
+* wire chambers
+*
+* d.f. geesaman 17 feb 1994
+* $Log: s_wire_center_calc.f,v $
+* Revision 1.5 1996/09/04 20:17:35 saw
+* (??) Cosmetic
+*
+* Revision 1.4 1995/05/22 19:46:04 cdaq
+* (SAW) Split gen_data_data_structures into gen, hms, sos, and coin parts"
+*
+* Revision 1.3 1994/11/23 15:08:41 cdaq
+* * (SPB) Recopied from hms file and modified names for SOS
+*
+* Revision 1.2 1994/03/24 20:04:21 cdaq
+* (DFG) allow for reverse wire ordering
+*
+* Revision 1.1 1994/02/21 16:44:09 cdaq
+* Initial revision
+*
+*
+ implicit none
+ include "sos_data_structures.cmn"
+ include "sos_geometry.cmn"
+*
+* input
+*
+ integer*4 plane ! plane number of hit
+ integer*4 wire ! wire number of hit
+*
+* output
+*
+ real*4 s_wire_center_calc ! wire center in cm
+*
+* if sdc_sire_counting(plane) is 1 then wires are number in reverse order
+ if(sdc_wire_counting(plane).eq.0) then
+* normal ordering
+ s_wire_center_calc = (FLOAT(wire)-sdc_central_wire(plane))
+ & * sdc_pitch(plane) - sdc_center(plane)
+ else
+ s_wire_center_calc =
+ & ((sdc_nrwire(plane) + (1 - wire))-
+ & sdc_central_wire(plane))* sdc_pitch(plane)-sdc_center(plane)
+ endif
+ return
+ end
diff --git a/SYNCFILTER/CVS/Entries b/SYNCFILTER/CVS/Entries
new file mode 100644
index 0000000..2721a25
--- /dev/null
+++ b/SYNCFILTER/CVS/Entries
@@ -0,0 +1,3 @@
+/Makefile/1.3.8.2.2.1/Wed Sep 2 14:01:33 2009//Tsane
+/syncfilter.c/1.3/Fri Dec 19 17:46:30 2003//Tsane
+D
diff --git a/SYNCFILTER/CVS/Repository b/SYNCFILTER/CVS/Repository
new file mode 100644
index 0000000..ef55ace
--- /dev/null
+++ b/SYNCFILTER/CVS/Repository
@@ -0,0 +1 @@
+Analyzer/SYNCFILTER
diff --git a/SYNCFILTER/CVS/Root b/SYNCFILTER/CVS/Root
new file mode 100644
index 0000000..6288c3f
--- /dev/null
+++ b/SYNCFILTER/CVS/Root
@@ -0,0 +1 @@
+whit@cvs.jlab.org:/group/hallc/cvsroot
diff --git a/SYNCFILTER/CVS/Tag b/SYNCFILTER/CVS/Tag
new file mode 100644
index 0000000..25d73f7
--- /dev/null
+++ b/SYNCFILTER/CVS/Tag
@@ -0,0 +1 @@
+Tsane
diff --git a/SYNCFILTER/Makefile b/SYNCFILTER/Makefile
new file mode 100644
index 0000000..af8381a
--- /dev/null
+++ b/SYNCFILTER/Makefile
@@ -0,0 +1,14 @@
+.DELETE_ON_ERROR: ;
+
+include ../etc/Makefile.variables
+
+.PHONY: all
+
+override CFLAGS += -L../../$(MYOS)/lib
+
+all: ../../$(MYOS)/bin/syncfilter
+
+../../$(MYOS)/bin/syncfilter: syncfilter.c ../../$(MYOS)/lib/libcoda.a
+ $(CC) $(CFLAGS) -o syncfilter syncfilter.c -lcoda
+ $(CP) syncfilter ../../$(MYOS)/bin/syncfilter
+ $(RM) syncfilter
diff --git a/SYNCFILTER/syncfilter.c b/SYNCFILTER/syncfilter.c
new file mode 100644
index 0000000..9e8fdf7
--- /dev/null
+++ b/SYNCFILTER/syncfilter.c
@@ -0,0 +1,369 @@
+/*
+ *Dump out CODA event bank information
+ Bad codes
+
+ dcff0000 Not all modules converted. Probable missing gate
+ dcfe Extra buffers at Sync event. Each dcfe gives # extra events
+ for a given slot
+ dcee ROC1 only missing BPM ADC data on SOS event.
+
+ Assume for now any type 0 event is a sync event. If that event has dcfe
+ stuff in it, then all data back to the previous sync is suspect.
+
+ */
+#define DEBUG 0
+#include <stdio.h>
+#define OUTSYNC 1
+#define INSYNC 0
+#define EARLYEND 2
+#define SYNCANALYSISFLAG 251
+#define SCALERSYNC 0
+#define TIMEDSYNC 16
+#define GOEVENT 18
+
+#define TYPE_BANK 0x10
+
+#define MAX_EVENT_LEN 163840
+#define MAX_REALLYBIGBUFFER 3000000
+
+void list_banks(int evno, int *buffer);
+void printbadstuff(int evno, int *buffer);
+int problems(int evno, int *buffer);
+void appendevent(int *really_big_buffer,int *buffer,int *endpointer);
+void writeoutofsyncevent(int ohandle, int nev);
+void writeoutthebigbuffer(int ohandle,int *really_big_buffer,int *endpointer,
+ int *evcounts);
+void writeinsyncevent(int ohandle,int nev);
+void writeearlyendevent(int ohandle,int nev);
+
+
+int GetNextEvent(char *fname,int *handle,int *buffer) {
+ int status;
+ char *filename;
+ char *xfilename;
+
+ static char infileext[3];
+ static int segno = -1;
+
+ /*
+ If current value of HANDLE is -1, the file has not been opened yet
+ so open it and start reading
+ If read returns error, check segment number: if it's -1, then
+ we're in single segment mode and the run has ended. If segno
+ is 0 or larger, we are in multi-segment mode and need to switch
+ segments
+ */
+
+ if (*handle == -1) { /* open first file */
+ filename = (char *)malloc(strlen(fname)+1);
+ strcpy(filename,fname);
+ fprintf(stderr,"///syncfilter: filename %s\n",
+ filename);
+ status = evOpen(filename,"r",handle);
+ if(status==0) {
+ segno = -1;
+ fprintf(stderr,"///syncfilter: Processing singular input file %s\n",
+ filename);
+ } else {
+ segno = 0;
+ infileext[0] = '.';
+ infileext[1] = '0';
+ infileext[2] = '\0';
+ xfilename = (char *)malloc(strlen(fname)+3);
+ strcpy(xfilename,fname);
+ strcat(xfilename,infileext);
+ status=evOpen(xfilename,"r",handle);
+ if(status!=0) {
+ fprintf(stderr,"///syncfilter TROUBLE: ");
+ fprintf(stderr,"Error opening input file (%d)\n\n",status);
+ fprintf(stderr,"///syncfilter: Processing input file segment %s\n\n",
+ xfilename);
+ free(xfilename);
+ return(status);
+ }
+ fprintf(stderr,"///syncfilter: Processing input file segment %s\n\n",
+ xfilename);
+ free(xfilename);
+ }
+ }
+
+ status=evRead(*handle,buffer,MAX_EVENT_LEN);
+ if(status!=0 && segno>=0) {
+ evClose(*handle);
+ segno++;
+ infileext[1]++;
+ xfilename = (char *)malloc(strlen(fname)+3);
+ strcpy(xfilename,fname);
+ strcat(xfilename,infileext);
+ status=evOpen(xfilename,"r",handle);
+ if(status==0) {
+ fprintf(stderr,"///syncfilter: Continuing with ");
+ fprintf(stderr,"input segment %d (%s)\n\n",segno,xfilename);
+ status=evRead(*handle,buffer,MAX_EVENT_LEN);
+ }
+ free(xfilename);
+ }
+
+ if (status == 1) evClose(*handle);
+
+ return(status);
+}
+
+
+
+main(int argc, char **argv)
+{
+ int nevents,evtype,count,diff;
+ int buffer[MAX_EVENT_LEN];
+ /* int really_big_buffer[MAX_REALLYBIGBUFFER];*/
+ int *really_big_buffer;
+ int endpointer;
+ char err[500];
+ int ihandle,ohandle,status;
+ int pointer,evlen,evnum,datatype;
+ int sumlen;
+ int outofsync;
+ int n_at_outofsync;
+ int writeoutput;
+ int goodevs[16],badevs[16],endevs[16];
+ int i;
+ int num_between_scalread;
+ int num_event4;
+ int nscalread;
+ char *infilename;
+ char *outfilename;
+
+ really_big_buffer = (int *) malloc(MAX_REALLYBIGBUFFER*sizeof(int));
+ writeoutput = 1;
+ if(argc>1) {
+ infilename = (char *)malloc(strlen(argv[1])+1);
+ strcpy(infilename,argv[1]);
+ if(argc>2) {
+ outfilename = (char *)malloc(strlen(argv[2])+1);
+ strcpy(outfilename,argv[2]);
+ } else {
+ outfilename = "-";
+ }
+ } else {
+ infilename = "-";
+ outfilename = "-";
+ }
+ ihandle=-1;
+ if (DEBUG) fprintf(stderr,"\n///syncfilter infilename %s ",infilename);
+ if (DEBUG) fprintf(stderr,"\n///syncfilter outfilename %s ",outfilename);
+
+ status = evOpen(outfilename,"w",&ohandle);
+ if(status!=0) {
+ fprintf(stderr,"\n///syncfilter TROUBLE: couldn't open ");
+ fprintf(stderr,"output file, scanning input for errors\n");
+ status = evOpen("/dev/null","w",&ohandle);
+ }
+
+ for(i=0;i<16;i++) {
+ goodevs[i] = badevs[i] = endevs[i] = 0; /* Initialize event counters */
+ }
+
+ nevents = 0;
+ num_between_scalread=0;
+ endpointer = 0;
+ outofsync = 0;
+ n_at_outofsync = 0;
+ num_event4=0;
+ nscalread=0;
+ writeinsyncevent(ohandle,nevents);
+
+ while ((status=GetNextEvent(infilename,&ihandle,buffer)) == 0) {
+ nevents++;
+ sumlen = 1;
+ evtype = buffer[1]>>16;
+ evlen = buffer[0];
+ datatype = (buffer[1] & 0xff00) >> 8;
+
+
+ /* if(!outofsync && problems(nevents,buffer)) {
+ outofsync = 1;
+ }*/
+ if( problems(nevents,buffer) && !outofsync ) {
+ outofsync = 1;
+ }
+
+ if(evtype==4) {
+ num_event4++;
+ if(DEBUG) fprintf(stderr,"%d: %d %d\n",nevents,evtype,num_event4);
+ }
+ if(evtype==20) {
+ fprintf(stderr,"END event found, number of events since last scaler read : %d\n",num_between_scalread);
+ appendevent(really_big_buffer,buffer,&endpointer);
+ break;
+ }
+ if(evtype==16 || evtype==0 || evtype==18 ) {
+ if(nevents>1000) {
+ if(DEBUG) fprintf(stderr,"%d: %d\n",nevents,evtype);
+ }
+ if ( num_event4 != 1000 && evtype==0 ) {
+ fprintf(stderr,"Number of Scaler reads before 1000 event type 4 =%d\n",nscalread);
+ }
+ if (evtype==0) {
+ nscalread++;
+ }
+ num_between_scalread=0;
+ if(outofsync) {
+ writeoutofsyncevent(ohandle,n_at_outofsync);
+ evWrite(ohandle,&buffer[0]);
+ writeoutthebigbuffer(ohandle,really_big_buffer,&endpointer,badevs);
+ writeinsyncevent(ohandle,nevents);
+ outofsync = 0;
+ } else {
+ if(evtype==0) {
+ evWrite(ohandle,&buffer[0]);
+ writeoutthebigbuffer(ohandle,really_big_buffer,&endpointer,goodevs);
+ } else {
+ writeoutthebigbuffer(ohandle,really_big_buffer,&endpointer,goodevs);
+ evWrite(ohandle,&buffer[0]);
+ }
+ }
+ if(DEBUG) fprintf(stderr,"Events=%d\n",nevents);
+ n_at_outofsync = nevents+1;
+ } else {
+ appendevent(really_big_buffer,buffer,&endpointer);
+ num_between_scalread++;
+ }
+ }
+
+ fprintf(stderr,"Done\n");
+ if(endpointer) {
+ if(evtype!=20) {
+ writeearlyendevent(ohandle,n_at_outofsync);
+ writeoutthebigbuffer(ohandle,really_big_buffer,&endpointer,endevs);
+ } else if(outofsync) {
+ fprintf(stderr,"Last buffer sent (out-of-sync)\n");
+ writeoutofsyncevent(ohandle,n_at_outofsync);
+ writeoutthebigbuffer(ohandle,really_big_buffer,&endpointer,badevs);
+ } else {
+ fprintf(stderr,"Last buffer sent (in-sync) \n");
+ writeoutthebigbuffer(ohandle,really_big_buffer,&endpointer,goodevs);
+ }
+
+ if(DEBUG) fprintf(stderr,"Events=%d\n",nevents);
+ }
+ if (DEBUG) fprintf(stderr,"%d:%s\n",status,err);
+ fprintf(stderr,"%d events in run\n",nevents);
+ evClose(ihandle);
+ evClose(ohandle);
+
+ for(i=0;i<16;i++) {
+ fprintf(stderr,"%2d: %8d %8d %8d\n",i,goodevs[i],badevs[i],endevs[i]);
+ }
+
+ exit(0);
+}
+
+int problems(int evno, int *buffer)
+{
+ int len = buffer[0];
+ int *end = buffer+len;
+ int datatype = (buffer[1] & 0xff00) >> 8;
+ int *pointer=buffer;
+ int bankn=0;
+ int result;
+ int evprinted;
+
+ result = 0;
+ evprinted=0;
+ if(datatype == TYPE_BANK){
+ pointer += 2;
+ while(pointer<end) {
+ int roc = (*(pointer+1) >> 16)&0x1f;
+ int len = *pointer;
+ int i;
+ bankn++;
+ if(roc>0 && roc <=4) {
+ for(i=2;i<=len;i++) {
+ if((pointer[i]&0xff000000) == 0xdc000000 ||
+ (pointer[i]&0xff000000) == 0xfb000000) {
+ result = 1;
+ if(!evprinted) {
+ fprintf(stderr,"Evno: %d\n",evno);
+ evprinted=0;
+ }
+ fprintf(stderr,"Roc: %d, Word: %d, %x\n",roc,i,pointer[i]);
+ }
+ }
+ }
+ pointer += (*pointer + 1);
+ }
+ }
+ return(result);
+}
+void appendevent(int *really_big_buffer,int *buffer,int *endpointer)
+{
+ int end;
+ int i;
+ int newendpointer;
+
+ newendpointer = *endpointer + buffer[0]+1;
+ if(newendpointer>MAX_REALLYBIGBUFFER) {
+ fprintf(stderr,"Amount of data between sync's exceeds buffer size\n");
+ exit(1);
+ }
+ for(i=0;i<=buffer[0];i++) {
+ really_big_buffer[*endpointer+i] = buffer[i];
+ }
+ *endpointer = newendpointer;
+}
+
+void writeoutthebigbuffer(int ohandle,int *really_big_buffer,int *endpointer,
+ int *evcounts)
+{
+ int pointer;
+ int evtype;
+ if(DEBUG) {
+ fprintf(stderr,"endpointer=%d\n",*endpointer);
+ fprintf(stderr,"Writing a big bunch of stuff\n");
+ }
+ pointer = 0;
+ while(pointer < *endpointer) {
+ evtype = really_big_buffer[pointer+1]>>16;
+ if(evtype < 16) {
+ evcounts[evtype]++;
+ }
+ evWrite(ohandle,&really_big_buffer[pointer]);
+ pointer += really_big_buffer[pointer]+1;
+ }
+ *endpointer=0; /* Clear the buffer */
+}
+
+void writeoutofsyncevent(int ohandle,int nev)
+{
+ int evbuf[5];
+ evbuf[0] = 4;
+ evbuf[1] = (SYNCANALYSISFLAG<<16) + 0x10cc;
+ evbuf[2] = 2;
+ evbuf[3] = 1<<8; /* Integer type */
+ evbuf[4] = OUTSYNC;
+ evWrite(ohandle,evbuf);
+ fprintf(stderr,"SF: OUT OF SYNC at %d\n",nev);
+}
+void writeinsyncevent(int ohandle,int nev)
+{
+ int evbuf[5];
+ evbuf[0] = 4;
+ evbuf[1] = (SYNCANALYSISFLAG<<16) + 0x10cc;
+ evbuf[2] = 2;
+ evbuf[3] = 1<<8; /* Integer type */
+ evbuf[4] = INSYNC;
+ evWrite(ohandle,evbuf);
+ fprintf(stderr,"SF: IN OF SYNC at %d\n",nev);
+}
+void writeearlyendevent(int ohandle,int nev)
+{
+ int evbuf[5];
+ evbuf[0] = 4;
+ evbuf[1] = (SYNCANALYSISFLAG<<16) + 0x10cc;
+ evbuf[2] = 2;
+ evbuf[3] = 1<<8; /* Integer type */
+ evbuf[4] = EARLYEND;
+ evWrite(ohandle,evbuf);
+ fprintf(stderr,"END missing, adding flag at last SYNC: %d\n",nev);
+}
+
diff --git a/T20/CVS/Entries b/T20/CVS/Entries
new file mode 100644
index 0000000..7f21169
--- /dev/null
+++ b/T20/CVS/Entries
@@ -0,0 +1,63 @@
+/Makefile/1.1/Mon Dec 7 22:11:31 1998//Tsane
+/Makefile.Unix/1.2/Mon Dec 7 22:11:31 1998//Tsane
+/g_analyze_misc.f/1.1/Mon Dec 7 22:11:31 1998//Tsane
+/g_analyze_pedestal.f/1.1/Tue Dec 1 21:01:12 1998//Tsane
+/g_analyze_scalers.f/1.1/Fri May 23 13:52:06 1997//Tsane
+/g_calc_pedestal.f/1.1/Tue Dec 1 21:01:16 1998//Tsane
+/g_clear_event.f/1.1/Tue Dec 1 21:01:21 1998//Tsane
+/g_decode_fb_bank.f/1.1/Tue Dec 1 20:58:23 1998//Tsane
+/g_decode_fb_detector.f/1.1.24.1/Tue Sep 11 19:14:18 2007//Tsane
+/g_examine_go_info.f/1.1.24.1/Tue Sep 11 19:14:18 2007//Tsane
+/g_get_next_event.f/1.1/Fri May 23 19:22:54 1997//Tsane
+/g_init_filenames.f/1.1/Tue Dec 1 20:58:38 1998//Tsane
+/g_initialize.f/1.1/Tue Dec 1 20:58:42 1998//Tsane
+/g_open_source.f/1.1/Fri May 23 19:38:57 1997//Tsane
+/g_proper_shutdown.f/1.1/Tue Dec 1 20:57:53 1998//Tsane
+/g_reconstruction.f/1.2/Tue Dec 1 20:59:06 1998//Tsane
+/g_register_variables.f/1.2/Fri May 23 19:48:43 1997//Tsane
+/g_reset_event.f/1.1.24.1/Tue Sep 11 19:14:18 2007//Tsane
+/g_scaler.f/1.1/Tue Dec 1 20:57:58 1998//Tsane
+/g_trans_misc.f/1.1/Tue Dec 1 21:00:45 1998//Tsane
+/gen_data_structures.cmn/1.1/Tue Dec 1 21:03:43 1998//Tsane
+/gen_misc.cmn/1.1/Tue Dec 1 21:03:34 1998//Tsane
+/gen_run_info.cmn/1.2/Tue Dec 1 21:04:07 1998//Tsane
+/h_ntuple_init.f/1.1/Tue Dec 1 20:58:08 1998//Tsane
+/h_ntuple_keep.f/1.1/Tue Dec 1 20:58:13 1998//Tsane
+/t20_bypass_switches.cmn/1.1/Tue Dec 1 21:02:48 1998//Tsane
+/t20_data_structures.cmn/1.2/Tue May 20 19:32:50 1997//Tsane
+/t20_filenames.cmn/1.1/Tue Dec 1 21:04:18 1998//Tsane
+/t20_geometry.cmn/1.1/Tue Dec 1 21:04:30 1998//Tsane
+/t20_hms.cmn/1.1/Tue Dec 1 21:02:39 1998//Tsane
+/t20_hodo.cmn/1.1/Tue Dec 1 21:03:15 1998//Tsane
+/t20_hodo_parms.cmn/1.1/Tue Dec 1 21:04:41 1998//Tsane
+/t20_misc.cmn/1.1/Tue Dec 1 21:04:53 1998//Tsane
+/t20_pedestals.cmn/1.1/Tue Dec 1 21:02:30 1998//Tsane
+/t20_reg_polder_structures.cmn/1.1/Tue Dec 1 21:05:04 1998//Tsane
+/t20_test_detectors.cmn/1.2/Tue Dec 1 21:02:25 1998//Tsane
+/t20_test_histid.cmn/1.1/Tue Dec 1 21:05:10 1998//Tsane
+/t20_track_histid.cmn/1.1/Tue Dec 1 21:02:09 1998//Tsane
+/t20_tracking.cmn/1.2/Tue Dec 1 21:02:01 1998//Tsane
+/t_analyze_pedestal.f/1.1/Tue Dec 1 20:56:24 1998//Tsane
+/t_calc_pedestal.f/1.1/Tue Dec 1 20:56:28 1998//Tsane
+/t_clear_event.f/1.1/Tue Dec 1 20:57:37 1998//Tsane
+/t_dump_peds.f/1.1/Tue Dec 1 20:57:41 1998//Tsane
+/t_hms.f/1.1/Fri May 23 20:51:35 1997//Tsane
+/t_hodos.f/1.1/Tue Dec 1 20:56:31 1998//Tsane
+/t_init_histid.f/1.1/Tue Dec 1 20:56:35 1998//Tsane
+/t_init_physics.f/1.1/Tue Dec 1 20:56:44 1998//Tsane
+/t_initialize.f/1.1/Tue Dec 1 20:56:51 1998//Tsane
+/t_misc.f/1.1/Tue Dec 1 20:57:23 1998//Tsane
+/t_mwpc.f/1.1/Tue Dec 1 20:55:18 1998//Tsane
+/t_ntuple.cmn/1.1/Tue Dec 1 21:01:41 1998//Tsane
+/t_ntuple_register.f/1.1/Tue Dec 1 20:56:56 1998//Tsane
+/t_proper_shutdown.f/1.1/Tue Dec 1 20:57:27 1998//Tsane
+/t_prt_raw_hodo.f/1.1/Tue Dec 1 20:57:05 1998//Tsane
+/t_prt_raw_mwpc.f/1.1/Tue Dec 1 20:57:33 1998//Tsane
+/t_raw_dump_all.f/1.1/Tue Dec 1 20:57:09 1998//Tsane
+/t_reconstruction.f/1.1/Tue Dec 1 20:54:23 1998//Tsane
+/t_register_param.f/1.1/Tue Dec 1 20:57:13 1998//Tsane
+/t_register_variables.f/1.1/Tue Dec 1 20:57:17 1998//Tsane
+/t_reset_event.f/1.1/Tue Dec 1 20:54:42 1998//Tsane
+/t_test_straw_analyze.f/1.3/Tue Dec 1 20:55:11 1998//Tsane
+/tengine.f/1.1/Tue Dec 1 20:55:32 1998//Tsane
+D
diff --git a/T20/CVS/Repository b/T20/CVS/Repository
new file mode 100644
index 0000000..997846e
--- /dev/null
+++ b/T20/CVS/Repository
@@ -0,0 +1 @@
+Analyzer/T20
diff --git a/T20/CVS/Root b/T20/CVS/Root
new file mode 100644
index 0000000..6288c3f
--- /dev/null
+++ b/T20/CVS/Root
@@ -0,0 +1 @@
+whit@cvs.jlab.org:/group/hallc/cvsroot
diff --git a/T20/CVS/Tag b/T20/CVS/Tag
new file mode 100644
index 0000000..25d73f7
--- /dev/null
+++ b/T20/CVS/Tag
@@ -0,0 +1 @@
+Tsane
diff --git a/T20/Makefile b/T20/Makefile
new file mode 100644
index 0000000..b3c52ee
--- /dev/null
+++ b/T20/Makefile
@@ -0,0 +1,8 @@
+#
+# $Log: Makefile,v $
+# Revision 1.1 1998/12/07 22:11:31 saw
+# Initial setup
+#
+ETC=../etc
+
+include $(ETC)/Makefile.NEW
diff --git a/T20/Makefile.Unix b/T20/Makefile.Unix
new file mode 100644
index 0000000..9b43435
--- /dev/null
+++ b/T20/Makefile.Unix
@@ -0,0 +1,182 @@
+#
+# $Log: Makefile.Unix,v $
+# Revision 1.2 1998/12/07 22:11:31 saw
+# Initial setup
+#
+# Revision 1.1 1998/12/01 20:56:12 saw
+# Initial revision
+#
+NEWSTYLE = 1
+include $(Csoft)/etc/Makefile
+
+t20_sources = g_register_variables.f g_initialize.f \
+ g_decode_fb_bank.f g_decode_fb_detector.f \
+ g_clear_event.f g_reset_event.f g_reconstruction.f \
+ g_init_filenames.f g_proper_shutdown.f g_analyze_pedestal.f \
+ g_calc_pedestal.f t_test_straw_analyze.f t_clear_event.f \
+ t_reset_event.f t_reconstruction.f t_register_variables.f \
+ t_ntuple_register.f t_register_param.f t_initialize.f \
+ t_analyze_pedestal.f t_calc_pedestal.f t_dump_peds.f \
+ t_proper_shutdown.f t_init_physics.f t_init_histid.f \
+ t_raw_dump_all.f t_prt_raw_mwpc.f t_prt_raw_hodo.f \
+ t_hodos.f t_misc.f t_mwpc.f t_hms.f \
+ g_examine_go_info.f g_scaler.f g_trans_misc.f g_analyze_misc.f \
+ g_analyze_scalers.f g_get_next_event.f g_open_source.f \
+ h_ntuple_init.f h_ntuple_keep.f
+
+# Sources that are not changed, but that need to be rebuilt because of include files
+unchanged_sources = g_analyze_beam_pedestal.f g_calc_beam_pedestal.f
+
+t20_makereg_sources = r_t20_bypass_switches.f r_t20_data_structures.f \
+ r_t20_test_detectors.f r_t_ntuple.f r_t20_tracking.f \
+ r_t20_pedestals.f r_t20_filenames.f r_t20_test_histid.f \
+ r_gen_run_info.f r_t20_test_histid.f r_t20_test_detectors.f \
+ r_t20_hodo.f r_t20_geometry.f r_t20_track_histid.f r_t20_hms.f \
+ r_t20_misc.f r_gen_misc.f r_gen_data_structures.f
+
+include_files = gen_detectorids.par t20_filenames.cmn t20_test_histid.cmn \
+ t20_hodo_parms.cmn t20_tracking.cmn t20_bypass_switches.cmn \
+ t20_pedestals.cmn t_ntuple.cmn t20_data_structures.cmn \
+ t20_test_detectors.cmn gen_run_info.cmn
+
+treplay_source = tengine.f
+
+libsources = $(t20_sources) $(unchaged_sources) $(t20_makereg_sources)
+
+sources = $(libsources) $(treplay_source)
+
+lib_targets := $(patsubst %.f, libt20.a(%.o), $(libsources))
+bin_targets = tengine
+
+install-dirs := lib bin
+
+
+T20LIB = $(LIBROOT)/libt20.a
+
+DEPLIBS = $(LIBROOT)/libengine.a \
+ $(LIBROOT)/libhtracking.a \
+ $(LIBROOT)/libtracking.a $(LIBROOT)/libhack.a \
+ $(LIBROOT)/libutils.a
+
+CTPCLIENT = $(LIBROOT)/libctpclient.a
+CTP = $(LIBROOT)/libctp.a
+
+GEANTVER = 321
+#CERNLIBS = -lgeant$(GEANTVER) -lpawlib -lgraflib -lgrafX11 -lpacklib -lmathlib
+CERNLIBS = -lpacklib
+ifeq ($(ARCH),HPUX)
+ FFLAGS = -g +ppu +es -O +Obb1000 +FPVZOU
+ OTHERLIBS = -Wl,-L$(LIBROOT) -lctpclient -lctp -Wl,-L$(CODA)/HP_UX/lib \
+ -Wl,-L$(CERN_ROOT)/lib $(CERNLIBS) -lU77 -lm
+
+endif
+
+ifeq ($(ARCH),IRIX)
+ OTHERLIBS = -L$(LIBROOT) -lctpclient -lctp \
+ -L$(CERN_ROOT)/lib $(CERNLIBS) \
+ -L/usr/lib -lX11 -lm
+endif
+
+ifeq ($(ARCH),ULTRIX)
+ OTHERLIBS = -L$(CODA)/ULTRIX/lib \
+ -lana -lmsg -lcoda -L$(CERN_ROOT)/lib $(CERNLIBS) -L/usr/lib -lX11 -lm
+endif
+
+ifeq ($(ARCH),SunOS)
+ OTHERLIBS = -L$(LIBROOT) -lctpclient -lctp -L$(CERN_ROOT)/lib $(CERNLIBS) -lX11
+endif
+
+ifeq ($(ARCH),AIX)
+ OTHERLIBS = -L$(LIBROOT) -lctpclient -lctp \
+ -L$(CERN_ROOT)/lib $(CERNLIBS) -lX11
+endif
+
+ifeq ($(ARCH),Linux)
+# CERNLIBS = -lgeant$(GEANTVER) -lpawlib -lgraflib -lgrafX11 -lmathlib -lpacklib -lkernlib -lmathlib -lpacklib
+ OTHERLIBS = -L$(LIBROOT) -lctpclient -lctp -L$(CERN_ROOT)/lib \
+ $(CERNLIBS) -L/usr/X11/lib -lX11 -lm
+ DEPLIBS := $(DEPLIBS) $(LIBROOT)/libport.a
+
+$(LIBROOT)/libport.a:
+ @make -C $(Csoft)/SRC/PORT
+
+endif
+
+ifeq ($(ARCH),OSF1)
+tengine: $(T20LIB) $(DEPLIBS)
+ $(AR) x $(T20LIB) tengine.o
+ $(F77) $(FLDFLAGS) -o tengine tengine.o $(T20LIB) $(DEPLIBS) $(OTHERLIBS)
+ $(RM) tengine.o
+else
+tengine: $(T20LIB) $(DEPLIBS)
+ $(AR) x $(T20LIB) tengine.o
+ $(F77) $(FFLAGS) -o tengine tengine.o $(T20LIB) $(DEPLIBS) $(OTHERLIBS)
+ $(RM) tengine.o
+endif
+
+ifdef NFSDIRECTORY
+../%.f : $(NFSDIRECTORY)/T20/%.f
+ ln -s $< $@
+
+../t%.cmn : $(NFSDIRECTORY)/T20/t%.cmn
+ ln -s $< $@
+
+../gen_data_structures.cmn : $(NFSDIRECTORY)/T20/gen_data_structures.cmn
+ ln -s $< $@
+
+../gen_misc.cmn : $(NFSDIRECTORY)/T20/gen_misc.cmn
+ ln -s $< $@
+
+../gen_run_info.cmn : $(NFSDIRECTORY)/T20/gen_run_info.cmn
+ ln -s $< $@
+
+../gen_detectorids.par : $(NFSDIRECTORY)/T20/gen_detectorids.par
+ ln -s $< $@
+
+.PRECIOUS: ../%.f ../t%.cmn
+.PRECIOUS: ../gen_data_structures.cmn ../gen_misc.cmn ../gen_run_info.cmn
+.PRECIOUS: ../gen_detectorids.par
+else
+#
+# Rule for making the register subroutines
+#
+../r_%.f : ../%.cmn $(MAKEREG)
+ (cd .. ; $(MAKEREG) $(<F) -o $(@F) -e /dev/null)
+
+.PRECIOUS: ../r_%.f
+endif
+#
+# Get include files from INCLUDE directory. Need an exclusion
+# on replacements for gen_* include files. How do I do this?
+# For now, it is only gen_detectorids.par that is reused. We'll
+# just put in explicit rules for .par files as needed.
+#
+
+%.cmn:: ../%.cmn
+ $(CP) $< $@
+
+%.dec:: ../%.dec
+ $(CP) $< $@
+
+../%.dec :: ../../INCLUDE/%.dec
+ $(CP) $< $@
+
+%.par:: ../%.par
+ $(CP) $< $@
+
+../gen_units.par:: ../../INCLUDE/gen_units.par
+ $(CP) $< $@
+
+../gen_constants.par:: ../../INCLUDE/gen_constants.par
+ $(CP) $< $@
+
+%.dte:: ../%.dte
+ $(CP) $< $@
+
+../%.dte:: ../../INCLUDE/%.dte
+ $(CP) $< $@
+
+include $(sources:.f=.d)
+
+
+
diff --git a/T20/g_analyze_misc.f b/T20/g_analyze_misc.f
new file mode 100644
index 0000000..c50fed7
--- /dev/null
+++ b/T20/g_analyze_misc.f
@@ -0,0 +1,100 @@
+ subroutine g_analyze_misc(abort,errmsg)
+*-------------------------------------------------------------------
+* author: John Arrington
+* created: 1/17/96
+*
+* g_analyze_misc takes the gen_decoded_misc common block and
+* generates decoded bpm/raster information.
+*
+* $Log: g_analyze_misc.f,v $
+* Revision 1.1 1998/12/07 22:11:31 saw
+* Initial setup
+*
+* Revision 1.3 1996/09/04 14:30:41 saw
+* (JRA) Add beam position calculations
+*
+* Revision 1.2 1996/04/29 19:41:09 saw
+* (JRA) Update BPM code
+*
+* Revision 1.1 1996/01/22 15:08:37 saw
+* Initial revision
+*
+*--------------------------------------------------------
+
+ implicit none
+
+ include 'gen_data_structures.cmn'
+
+ logical abort
+ character*1024 errmsg
+ character*20 here
+ parameter (here = 'g_analyze_misc')
+
+ integer*4 ibpm,isig
+ real*8 normfry,fryphase,frydphase
+
+ save
+
+ abort = .false.
+ errmsg = ' '
+
+* BPM Signals.
+
+ do ibpm=1,gmax_num_bpms !need some kind of 'map' for this.
+ do isig=1,gnum_bpm_signals
+ gbpm_raw_adc(isig,ibpm) = gmisc_dec_data(4*(ibpm-1)+isig,2)
+ gbpm_adc(isig,ibpm)=gbpm_raw_adc(isig,ibpm)-gbpm_adc_ped(isig,ibpm)
+ enddo
+ enddo
+
+
+* Raster Signals.
+
+ gfrx_raw_adc = gmisc_dec_data(14,2)
+ gfry_raw_adc = gmisc_dec_data(16,2)
+ gfrx_adc = gfrx_raw_adc - gfrx_adc_ped
+ gfry_adc = gfry_raw_adc - gfry_adc_ped
+ gfrx_sync = gmisc_dec_data(13,2) - gfrx_sync_mean !sign gives sync phase.
+ gfry_sync = gmisc_dec_data(15,2) - gfry_sync_mean
+
+* Beam position on target: this block calculates the beam Y position (beam
+* line coordinate system) on the target in mm: gbeam_y
+*
+* --- use Chen Yan's formula to calculate the Y amplitude ---
+* Vamp = 0.278*Ebeam*Xamp, where:
+* Vamp is the amplitude of the monitor signal in Volts
+* Ebeam is the beam energy in GeV (gpbeam)
+* Xamp is the raster amplitude on target in mm
+* need two calibration constants to be defined in gconstants.param
+* gfry_defcalib := .278 or whatever it will be in the future
+* gfry_vperch := 1/(ADC channels per Volt input)
+*
+ if (gusefr .eq. 0) then !do not correct for raster
+ gbeam_y = gbeam_yoff
+ else !correct for raster
+
+ if (guse_frdefault .ne. 0) then ! use nominal calibration
+ gbeam_y = gfry_adc*gfry_vperch/(gfry_defcalib*gpbeam)
+ else ! use user calibration
+
+ if (guse_frphase .eq. 0) then ! do not correct for FR phase
+ gbeam_y = (gfry_adc/gfry_adcmax)*gfry_maxsize
+ else ! correct for FR phase
+ normfry = gfry_adc/gfry_adcmax
+ normfry = min(1.0D0,normfry)
+ normfry = max(-1.0D0,normfry)
+ fryphase = asin(normfry)
+ if( gfry_sync .gt. gfry_synccut ) then
+ frydphase = gfry_dphase*3.141/180.
+ else
+ frydphase = -gfry_dphase*3.141/180.
+ endif
+ fryphase = fryphase + frydphase
+ gbeam_y = sin(fryphase)*gfry_maxsize
+ endif
+ endif
+ gbeam_y = gbeam_y + gbeam_yoff
+ endif
+
+ return
+ end
diff --git a/T20/g_analyze_pedestal.f b/T20/g_analyze_pedestal.f
new file mode 100644
index 0000000..c7bf00c
--- /dev/null
+++ b/T20/g_analyze_pedestal.f
@@ -0,0 +1,41 @@
+ subroutine g_analyze_pedestal(ABORT,err)
+*
+* $Log: g_analyze_pedestal.f,v $
+* Revision 1.1 1998/12/01 21:01:12 saw
+* Initial revision
+*
+* Revision 1.2 1996/01/22 15:09:24 saw
+* (JRA) Add call to g_analyze_beam_pedestal
+*
+* Revision 1.1 1995/04/01 19:36:55 cdaq
+* Initial revision
+*
+*
+ implicit none
+*
+ character*18 here
+ parameter (here='g_analyze_pedestal')
+*
+ logical ABORT
+ character*(*) err
+*
+ call g_analyze_beam_pedestal(ABORT,err)
+ if(ABORT) then
+ call G_add_path(here,err)
+ return
+ endif
+*
+ call h_analyze_pedestal(ABORT,err)
+ if(ABORT) then
+ call G_add_path(here,err)
+ return
+ endif
+*
+ call t_analyze_pedestal(ABORT,err)
+ if(ABORT) then
+ call G_add_path(here,err)
+ return
+ endif
+*
+ return
+ end
diff --git a/T20/g_analyze_scalers.f b/T20/g_analyze_scalers.f
new file mode 100644
index 0000000..a327451
--- /dev/null
+++ b/T20/g_analyze_scalers.f
@@ -0,0 +1,216 @@
+ subroutine g_analyze_scalers(event,ABORT,err)
+*
+*
+* $Log: g_analyze_scalers.f,v $
+* Revision 1.1 1997/05/23 13:52:06 saw
+* Initial revision
+*
+*
+*
+ implicit none
+ save
+ integer*4 event(*)
+*
+ character*17 here
+ parameter (here='g_analyze_scalers')
+*
+ logical ABORT
+ character*(*) err
+*
+ INCLUDE 'gen_scalers.cmn'
+ INCLUDE 'gen_run_info.cmn'
+ INCLUDE 'gen_filenames.cmn'
+*
+ integer ind
+ integer*4 cratenum ! 1=hms,2=sos
+ real*8 realscal
+ logical update_bcms
+*
+ integer*4 jiand, jishft ! Declare to help f2c
+*
+* Scaler events have a header in from of each scaler. High 16 bits
+* will contain the address (the switch settings). Address for hall C
+* will be of the form DANN, where NN is the scaler number. The low 16
+* bits will contain the number of scaler values to follow (this should
+* be no larger than 16, but we will allow more.)
+*
+*
+* NOTE that the variables gscaler(i) is REAL!!!!!
+* this is so that we can record the correct value when the
+* hardware scalers (32 bit <> I*4) overflow.
+*
+
+ integer evtype, evnum, evlen, pointer
+ integer scalid, countinmod, address, counter
+*
+* Temporary variables for beam current and charge calculations
+*
+ real*8 ave_current_bcm1, ave_current_bcm2, ave_current_bcm3
+ real*8 ave_current_unser
+ real*8 delta_time
+*
+* Find if hms or sos scaler event (assumes first HMS scaler is DA01).
+ if (jiand(jishft(event(3),-16),'FFFF'X).eq.'DA01'X) then !first scaler
+ cratenum=1 !hms
+ else
+ cratenum=2 !sos
+ endif
+*
+ evtype = jishft(event(2),-16)
+ evnum = jiand(event(2),'FF'x) ! last 2 bytes give event number (mod 256)
+*
+* evnum is mod(256), so must reset lastevnum for rollover
+ if (evnum.eq.0 .and. gscal_lastevnum(cratenum).gt.200) then
+ gscal_lastevnum(cratenum)=0
+ else if (evnum.le.gscal_lastevnum(cratenum)) then
+ write(6,*) 'STATUS: skipping outoforder scaler event:',
+ & ' crate,oldevnum,newevnum=',cratenum,
+ & gscal_lastevnum(cratenum),evnum
+ return
+ endif
+*
+ gscal_lastevnum(cratenum)=evnum
+*
+* Should check against list of known scaler events
+*
+ evlen = event(1) + 1
+ update_bcms = .false.
+ if(evlen.gt.3) then ! We have a scaler bank
+ pointer = 3
+*
+ do while(pointer.lt.evlen)
+*
+ scalid = jiand(jishft(event(pointer),-16),'FF'x)
+ countinmod = jiand(event(pointer),'FFFF'x)
+ if(jiand(event(pointer),'FF000000'x).eq.'DA000000'x) then
+c Old style header with scaler ID @ 00FF0000
+ scalid = jiand(jishft(event(pointer),-16),'FF'x)
+ address = scalid*16
+*
+* Might want to check that count is not to big.
+*
+ if(countinmod.ne.16) then
+ err = 'Scaler module header word has count<>16'
+ ABORT = .true.
+ call g_add_path(here,err)
+ return ! Safest action
+ endif
+ else
+c
+c New style header with scaler ID @ FFF?0000
+c (If ? is non zero, it means we are starting in the middle of a scaler)
+c Allows for non multiple of 16 address starts
+c
+ address = jishft(event(pointer),-16)
+*
+* Might want to check that count is not to big.
+*
+ if(countinmod.gt.16) then
+ err = 'Scaler module header word has count >16'
+ ABORT = .true.
+ call g_add_path(here,err)
+ return ! Safest action
+ endif
+ endif
+*
+ address = scalid*16
+ do counter = 1,countinmod
+ ind=address+counter
+ realscal=dfloat(event(pointer+counter))
+ if (ind.eq.gbcm1_index) update_bcms=.true. !assume bcms in same crate
+
+* Save scaler value from previous scaler event:
+ gscaler_old(ind) = gscaler(ind)
+
+ if (realscal.lt.-0.5) then
+ realscal=realscal+4294967296.
+ endif
+ if ( (realscal+dfloat(gscaler_nroll(ind))*4294967296.) .ge.
+ & gscaler(ind) ) then ! 2**32 = 4.295e+9
+ gscaler(ind) = realscal + gscaler_nroll(ind)*4294967296.
+ else !32 bit scaler rolled over.
+ gscaler_nroll(ind)=gscaler_nroll(ind)+1
+ gscaler(ind) = realscal + gscaler_nroll(ind)*4294967296.
+ endif
+* Calculate difference between current scaler value and previous value:
+ gscaler_change(ind) = gscaler(ind) - gscaler_old(ind)
+ enddo
+ pointer = pointer + countinmod + 1 ! Add 17 to pointer
+ enddo
+ else
+ err = 'Event not big enough to contain scalers'
+ ABORT = .true.
+ call g_add_path(here,err)
+ return
+ endif
+
+* calculate time of run (must not be zero to avoid div. by zero).
+ g_run_time = max(0.001D00,gscaler(gclock_index)/gclock_rate)
+
+* Calculate beam current and charge between scaler events
+
+ if (update_bcms) then ! can't assume in hms crate, moved for some runs
+
+ delta_time = max(gscaler_change(gclock_index)/gclock_rate,.0001D00)
+*
+ if (gen_run_number.le.13000) then
+ ave_current_bcm1 = gbcm1_gain*sqrt(max(0.0D00,
+ & (gscaler_change(gbcm1_index)/delta_time)-gbcm1_offset))
+ else
+ ave_current_bcm1 = gbcm1_gain*((gscaler_change(gbcm1_index)
+ & /delta_time) - gbcm1_offset)
+ endif
+
+ ave_current_bcm3 = gbcm3_gain*((gscaler_change(gbcm3_index)
+ & /delta_time) - gbcm3_offset)
+*
+ ave_current_unser = gunser_gain*((gscaler_change(gunser_index)
+ & /delta_time) - gunser_offset)
+
+ if (gen_run_number.le.6268) then
+ ave_current_bcm2 = gbcm2_gain*sqrt(max(0.0D00,
+ & (gscaler_change(gbcm2_index)/delta_time)-gbcm2_offset))
+ else
+ ave_current_bcm2 = gbcm2_gain*((gscaler_change(gbcm2_index)
+ & /delta_time) - gbcm2_offset)
+ endif
+
+ if (delta_time.gt.0.0001) then
+ gbcm1_charge = gbcm1_charge + ave_current_bcm1*delta_time
+ gbcm2_charge = gbcm2_charge + ave_current_bcm2*delta_time
+ gbcm3_charge = gbcm3_charge + ave_current_bcm3*delta_time
+ gunser_charge = gunser_charge + ave_current_unser*delta_time
+
+ gscaler_event_num = gscaler_event_num + 1
+
+* Write out pertinent charge scaler rates for each scaler event.
+
+ if (g_charge_scaler_filename.ne.' ') then
+ write(G_LUN_CHARGE_SCALER,1001) gscaler_event_num,!scaler event num
+ & gscaler_change(gunser_index)/delta_time, !scaler rate(Hz)
+ & gscaler_change(gbcm1_index)/delta_time, !scaler rate(Hz)
+ & gscaler_change(gbcm2_index)/delta_time, !scaler rate(Hz)
+ & gscaler_change(gbcm3_index)/delta_time, !scaler rate(Hz)
+ & delta_time !time since last scaler event (sec)
+
+ endif
+ endif
+ endif
+
+ 1001 format(i7,4f15.2,f14.6)
+ return
+ end
+
+
+
+
+
+
+
+
+
+
+
+
+
+
diff --git a/T20/g_calc_pedestal.f b/T20/g_calc_pedestal.f
new file mode 100644
index 0000000..ad3f4c6
--- /dev/null
+++ b/T20/g_calc_pedestal.f
@@ -0,0 +1,41 @@
+ subroutine g_calc_pedestal(ABORT,err)
+*
+* $Log: g_calc_pedestal.f,v $
+* Revision 1.1 1998/12/01 21:01:16 saw
+* Initial revision
+*
+* Revision 1.2 1996/01/22 15:12:35 saw
+* (JRA) Add call to g_calc_beam_pedestal
+*
+* Revision 1.1 1995/04/01 19:37:06 cdaq
+* Initial revision
+*
+*
+ implicit none
+*
+ character*18 here
+ parameter (here='g_calc_pedestal')
+*
+ logical ABORT
+ character*(*) err
+*
+ call g_calc_beam_pedestal(ABORT,err)
+ if(ABORT) then
+ call G_add_path(here,err)
+ return
+ endif
+*
+ call h_calc_pedestal(ABORT,err)
+ if(ABORT) then
+ call G_add_path(here,err)
+ return
+ endif
+*
+ call t_calc_pedestal(ABORT,err)
+ if(ABORT) then
+ call G_add_path(here,err)
+ return
+ endif
+*
+ return
+ end
diff --git a/T20/g_clear_event.f b/T20/g_clear_event.f
new file mode 100644
index 0000000..5c60b9b
--- /dev/null
+++ b/T20/g_clear_event.f
@@ -0,0 +1,95 @@
+ SUBROUTINE G_clear_event(ABORT,err)
+*--------------------------------------------------------
+*- Prototype C analysis routine
+*-
+*-
+*- Purpose and Methods : clears all quantities AT THE START OF EACH EVENT
+*-
+*-
+*- Output: ABORT - success or failure
+*- : err - reason for failure, if any
+*-
+*- Created 29-Oct-1993 Kevin B. Beard, Hampton U.
+*- Modified 19-Nov-1993 Kevin B. Beard for new error standards
+*- $Log: g_clear_event.f,v $
+*- Revision 1.1 1998/12/01 21:01:21 saw
+*- Initial revision
+*-
+*- Revision 1.10 1996/09/04 14:33:10 saw
+*- (SAW) Don't use gmc_abort since gmc stuff not called
+*-
+*- Revision 1.9 1996/01/22 15:14:48 saw
+*- (JRA) Put BPM/Raster data into MISC data structures
+*-
+*- Revision 1.8 1996/01/16 18:41:36 cdaq
+*- (JRA) Explain that routine runs at start of each event
+*-
+*- Revision 1.7 1995/07/27 19:06:40 cdaq
+*- (SAW) Disable monte carlo (GMC)
+*-
+* Revision 1.6 1995/04/01 19:44:31 cdaq
+* (SAW) Add clear of BPM hit counter
+*
+* Revision 1.5 1994/06/22 20:23:47 cdaq
+* (SAW) Clear the uninstrumented channel hit counter
+*
+* Revision 1.4 1994/04/15 20:33:43 cdaq
+* (SAW) Changes for ONLINE use
+*
+* Revision 1.3 1994/02/22 19:47:07 cdaq
+* Change gmc_clear_event to gmc_mc_clear
+*
+* Revision 1.2 1994/02/17 21:46:03 cdaq
+* Add call to gmc_clear_event
+*
+* Revision 1.1 1994/02/04 21:48:38 cdaq
+* Initial revision
+*
+*-
+*- All standards are from "Proposal for Hall C Analysis Software
+*- Vade Mecum, Draft 1.0" by D.F.Geesamn and S.Wood, 7 May 1993
+*-
+*-
+*--------------------------------------------------------
+ IMPLICIT NONE
+ SAVE
+*
+ character*13 here
+ parameter (here= 'G_clear_event')
+*
+ logical ABORT
+ character*(*) err
+*
+ INCLUDE 'gen_data_structures.cmn'
+*
+ logical HMS_ABORT,T20_ABORT,COIN_ABORT
+ character*132 HMS_err,T20_err,COIN_err
+*
+*--------------------------------------------------------
+*
+ err= ' '
+ HMS_err= ' '
+ T20_err= ' '
+*
+ GUNINST_TOT_HITS = 0 ! Unistrumented hit counter
+ GMISC_TOT_HITS = 0
+*
+ call H_clear_event(HMS_ABORT,HMS_err)
+*
+ call T_clear_event(T20_ABORT,T20_err)
+*
+ call C_clear_event(COIN_ABORT,COIN_err)
+*
+ ABORT= HMS_ABORT .or. T20_ABORT .or. COIN_ABORT
+*
+ IF(ABORT) THEN
+ err= COIN_err
+ call G_prepend(T20_err,err)
+ call G_prepend(HMS_err,err)
+ call G_add_path(here,err)
+ ELSE
+ err= ' '
+ ENDIF
+*
+ RETURN
+ END
diff --git a/T20/g_decode_fb_bank.f b/T20/g_decode_fb_bank.f
new file mode 100644
index 0000000..f77da8c
--- /dev/null
+++ b/T20/g_decode_fb_bank.f
@@ -0,0 +1,361 @@
+ subroutine g_decode_fb_bank(bank, ABORT, error)
+*
+* Purpose and Methods: Decode a Fastbus bank.
+*
+* Looks at detector ID for a word in a data bank and passes the
+* appopriate data structure pointers to the g_decode_fb_detector routine.
+* That routine will return when it gets to another detector in which
+* case the the present routine will dispatch g_decode_fb_detector with a
+* new set of pointers.
+*
+* This routine must be modified when new detectors are added. It may
+* also may need to modified if fastbus modules other than from LeCroy
+* are used.
+*
+* It is the responsibility of the calling routine to call
+* g_decode_fb_bank only for banks of fastbus data.
+*
+* Inputs:
+*
+* bank Pointer to the first word (length) of a data bank.
+*
+* Outputs:
+*
+* ABORT
+* error
+*
+* Created 16-NOV-1993 Stephen Wood, CEBAF
+* Modified 3-Dec-1993 Kevin Beard, Hampton U.
+* $Log: g_decode_fb_bank.f,v $
+* Revision 1.1 1998/12/01 20:58:23 saw
+* Initial revision
+*
+* Revision 1.24 1996/11/08 15:48:01 saw
+* (WH) Add decoding for lucite counter
+*
+* Revision 1.23 1996/04/29 19:45:37 saw
+* (JRA) Update Aerogel variable names
+*
+* Revision 1.22 1996/01/22 15:13:56 saw
+* (JRA) Put BPM/Raster data into MISC data structures
+*
+* Revision 1.21 1996/01/16 20:49:40 cdaq
+* (SAW) Handle banks containing two parallel link ROC banks
+*
+* Revision 1.20 1995/12/06 19:04:24 cdaq
+* (SAW) What is this version? Two bank banks processing lost.
+*
+* Revision 1.19 1995/11/28 18:50:03 cdaq
+* (SAW) Quick hack to accept banks with 2 rocs (from parallel link)
+*
+* Revision 1.18 1995/10/09 18:20:51 cdaq
+* (JRA) Change HCER_ADC to HCER_RAW_ADC
+* Replace g_decode_getdid call with explicit calculation (for speed)
+*
+* Revision 1.17 1995/07/27 19:06:02 cdaq
+* (SAW) Use specific bit manipulation routines for f2c compatibility
+* Get FB roc from header on parallel link banks
+*
+* Revision 1.16 1995/05/22 20:50:45 cdaq
+* (SAW) Split gen_data_data_structures into gen, hms, sos, and coin parts"
+*
+* Revision 1.15 1995/05/22 13:35:40 cdaq
+* (SAW) Fix up some problems with decoding of parallel link wrappers around
+* fastbus events. Still doesn't hadle two fb rocs wrapped into one bank.
+*
+* Revision 1.14 1995/05/11 17:17:00 cdaq
+* (SAW) Extend || link hack for SOS. Add Aerogel detector.
+*
+* Revision 1.13 1995/04/01 19:44:50 cdaq
+* (SAW) Add BPM hitlist
+*
+* Revision 1.12 1995/01/27 20:12:48 cdaq
+* (SAW) Add hacks to deal with parallel link data. Pass lastslot variable to
+* g_decode_fb_detector so it can find 1881M/1877 headers.
+*
+* Revision 1.11 1994/11/22 20:13:02 cdaq
+* (SPB) Update array names for raw SOS Scintillator bank
+*
+* Revision 1.10 1994/06/28 20:01:23 cdaq
+* (SAW) Change arrays that HMS scintillators go into
+*
+* Revision 1.9 1994/06/18 02:45:49 cdaq
+* (SAW) Add code for miscleaneous data and uninstrumented channels
+*
+* Revision 1.8 1994/06/09 04:48:28 cdaq
+* (SAW) Fix length argument on gmc_mc_decode call again
+*
+* Revision 1.7 1994/04/13 18:49:10 cdaq
+* (KBB Fix length argument on gmc_mc_deocde call
+*
+*
+ implicit none
+ SAVE
+*
+ character*16 here
+ parameter (here='g_decode_fb_bank')
+*
+ logical ABORT
+ character*(*) error
+ integer*4 bank(*)
+
+* This routine unpacks a ROC bank. It looks a fastbus word to
+* determine which detector it belongs to. It then passes the
+* appropriate arrays for that detector to detector independent unpacker
+* G_DECODE_FB_DETECTOR which will unpack words from the bank into the
+* hit arrays until the detector changes or it runs out of data.
+* G_DECODE_FB_DETECTOR returns a pointer to the next data word to be
+* processed.
+*
+ include 'gen_detectorids.par'
+ include 'gen_data_structures.cmn'
+ include 'hms_data_structures.cmn'
+ include 't20_data_structures.cmn'
+ include 'gen_decode_common.cmn'
+* include 'mc_structures.cmn'
+ include 'gen_event_info.cmn'
+
+ integer*4 pointer ! Pointer FB data word
+ integer*4 banklength,maxwords
+ integer*4 roc,subadd,slot,lastslot
+ integer*4 stat_roc
+ integer*4 slotp ! temp variable
+ integer*4 did ! Detector ID
+ integer*4 g_decode_fb_detector ! Detector unpacking routine
+ integer*4 last_first ! Last word of first bank in || bank
+*
+ integer*4 jiand, jishft ! Declare to help f2c
+
+ banklength = bank(1) + 1 ! Bank length including count
+ last_first = banklength
+
+ stat_roc = jishft(bank(2),-16)
+ roc = jiand(stat_roc,'1F'X) ! Get ROC from header
+ if(roc.eq.15) roc = 4 ! Map t20 EEL ROC# to 4
+
+*
+* First look for special Monte Carlo Banks
+*
+c if(stat_roc.eq.mc_status_and_ROC) then
+c* call gmc_mc_decode(banklength-2,bank(3),ABORT,error)
+c ABORT = .TRUE.
+c error = 'Monte Carlo Event analysis disabled'
+c if(ABORT) then
+c call g_add_path(here,error)
+c endif
+c return
+c endif
+c*
+ if(roc.gt.G_DECODE_MAXROCS .and. roc.ne.9) then
+ ABORT = .false. ! Just warn
+ write(error,*) ':ROC out of range, ROC#=',roc
+ call g_add_path(here,error)
+ return
+ endif
+*
+ pointer = 3 ! First word of bank
+*
+ if (roc.eq.7 .or. roc.eq.8 .or. roc.eq.9) then
+*
+* These 3 rocs are VME front ends for fastbus crates. At present
+* we assume that each VME front end is only taking data from one
+* FB roc and that this FB roc # is in 4 word of the bank. This
+* hack will not work when we have roc 8 taking data from both
+* fbch1 and fbch2. But it should work for runs up through
+* at least 5/31/95.
+*
+ last_first = pointer + bank(pointer) ! Last word in sub bank
+ stat_roc = jishft(bank(pointer+1),-16)!2 words are fb roc header.
+ roc = jiand(stat_roc,'1F'X)
+ if(roc.eq.15) roc = 4 ! Map t20 EEL ROC# to 4
+ pointer=pointer+2 !using parallel link, so next
+ endif
+
+ lastslot = -1
+ do while (pointer .le. banklength)
+ if(pointer.eq.(last_first+1)) then ! Second bank in a two bank bank
+ last_first = banklength ! Reset to end of second bank
+ stat_roc = jishft(bank(pointer+1),-16) !2 words are fb roc header
+ roc = jiand(stat_roc,'1F'X) ! New roc
+ if(roc.eq.15) roc = 4 ! Map t20 EEL ROC# to 4
+ endif
+*
+* Look for and report empty ROCs.
+*
+ if (bank(pointer).eq.'DCFF0000'X) then
+ if (roc.eq.1 .or. roc.eq.2) then !missing hms data
+ if (gen_event_type.ne.2) then !event type 2 is sos only event.
+ write(6,'(a,i3,a,i8,a,z8,a,i2)') 'roc',roc,' has no data for event'
+ & ,gen_event_id_number,' scanmask=',bank(pointer+1)
+ $ ,', evtype=',gen_event_type
+ endif
+ else !missing sos data
+ if (gen_event_type.ne.1) then !event type 1 is hms only data.
+ write(6,'(a,i3,a,i8,a,z8,a,i2)') 'roc',roc,' has no data for event'
+ & ,gen_event_id_number,' scanmask=',bank(pointer+1)
+ $ ,', evtype=',gen_event_type
+ endif
+ endif
+ endif
+*
+ slot = jiand(jishft(bank(pointer),-27),'1F'X)
+ if(slot.gt.0.and.slot.le.G_DECODE_MAXSLOTS .and.
+ $ roc.gt.0 .and. roc.le.g_decode_maxrocs) then
+c write(6,*) 'pointer,roc,slot=',pointer,roc,slot
+ subadd = jiand(jishft(bank(pointer),
+ $ -g_decode_subaddbit(roc,slot)),'7F'X)
+
+ if (subadd .lt. '7F'X) then ! Only valid subaddress
+ ! This skips module headers
+
+ slotp = g_decode_slotpointer(roc,slot)
+ if (slotp.gt.0) then
+ did = g_decode_didmap(slotp+subadd)
+ else
+ did = UNINST_ID
+ endif
+
+ maxwords = last_first - pointer + 1
+*
+* 1 2 3 4 5 6 7
+*23456789012345678901234567890123456789012345678901234567890123456789012
+*
+ if(did.eq.HDC_ID) then
+ pointer = pointer +
+ $ g_decode_fb_detector(lastslot, roc, bank(pointer),
+ & maxwords, did,
+ $ HMAX_DC_HITS, HDC_RAW_TOT_HITS, HDC_RAW_PLANE_NUM,
+ $ HDC_RAW_WIRE_NUM,1 ,HDC_RAW_TDC,0, 0, 0)
+
+ else if (did.eq.HSCIN_ID) then
+ pointer = pointer +
+ $ g_decode_fb_detector(lastslot, roc, bank(pointer),
+ & maxwords, did,
+ $ HMAX_ALL_SCIN_HITS, HSCIN_ALL_TOT_HITS,
+ $ HSCIN_ALL_PLANE_NUM, HSCIN_ALL_COUNTER_NUM, 4,
+ $ HSCIN_ALL_ADC_POS, HSCIN_ALL_ADC_NEG,
+ $ HSCIN_ALL_TDC_POS, HSCIN_ALL_TDC_NEG)
+
+ else if (did.eq.HCAL_ID) then
+ pointer = pointer +
+ $ g_decode_fb_detector(lastslot, roc, bank(pointer),
+ & maxwords, did,
+ $ HMAX_CAL_BLOCKS, HCAL_TOT_HITS, HCAL_COLUMN,
+ $ HCAL_ROW, 1, HCAL_ADC, 0, 0, 0)
+
+ else if (did.eq.HCER_ID) then
+*
+* Cerenkov has no plane array. Pass it HCER_COR_ADC. Unpacker will
+* fill it with zeros or ones. (Or whatever we tell the unpacker the
+* plane number is.)
+*
+ pointer = pointer +
+ $ g_decode_fb_detector(lastslot, roc, bank(pointer),
+ & maxwords, did,
+ $ HMAX_CER_HITS, HCER_TOT_HITS, HCER_PLANE,
+ $ HCER_TUBE_NUM, 1, HCER_RAW_ADC, 0, 0, 0)
+
+ else if (did.eq.HMISC_ID) then
+*
+* This array is for data words that don't belong to a specific
+* detector counter. Things like energy sums, and TDC's from various
+* points in the logic will go here. Most likely we will set ADDR1
+* always to 1, and ADDR2 will start at 1.
+*
+ pointer = pointer +
+ $ g_decode_fb_detector(lastslot, roc, bank(pointer),
+ & maxwords, did,
+ $ HMAX_MISC_HITS, HMISC_TOT_HITS, HMISC_RAW_ADDR1,
+ $ HMISC_RAW_ADDR2, 1, HMISC_RAW_DATA, 0, 0, 0)
+
+*
+* 1 2 3 4 5 6 7
+*23456789012345678901234567890123456789012345678901234567890123456789012
+*
+* T20 Detector POLDER and Test detection counters. Not DONE!
+*
+ else if (did.eq.TMWPC_ID) then
+
+ pointer = pointer +
+ $ g_decode_fb_detector(lastslot, roc, bank(pointer),
+ & maxwords, did,
+ $ TMAX_MWPC_HITS, TMWPC_RAW_TOT_HITS, TMWPC_RAW_PLANE_NUM,
+ $ TMWPC_RAW_WIRE_NUM, 1, TMWPC_RAW_TDC, 0, 0, 0)
+
+ else if (did.eq.THODO_ID) then
+
+ pointer = pointer +
+ $ g_decode_fb_detector(lastslot, roc, bank(pointer),
+ & maxwords, did,
+ $ TMAX_HODO_HITS, THODO_TOT_HITS, THODO_PLANE_NUM,
+ $ THODO_BAR_NUM, 1, THODO_TDC_VAL, 0, 0, 0)
+
+*
+* This array is for data words that don't belong to a specific
+* detector counter. Things like energy sums, and TDC's from various
+* points in the logic will go here. Most likely we will set ADDR1
+* always to 1, and ADDR2 will start at 1.
+*
+ else if (did.eq.TMISC_ID) then
+*
+ pointer = pointer +
+ $ g_decode_fb_detector(lastslot, roc, bank(pointer),
+ & maxwords, did,
+ $ TMAX_MISC_HITS, TMISC_TOT_HITS, TMISC_RAW_ADDR1,
+ $ TMISC_RAW_ADDR2, 1, TMISC_RAW_DATA, 0, 0, 0)
+
+ else if (did.eq.TSTRAW_ID) then
+ pointer = pointer +
+ $ g_decode_fb_detector(lastslot, roc, bank(pointer),
+ & maxwords, did,
+ $ TTSTMAX_STRAW_HITS, TTST_RAW_TOT_HITS, TTST_RAW_PLANE_NUM,
+ $ TTST_RAW_GROUP_NUM, 1, TTST_RAW_TDC, 0, 0, 0)
+
+ccc else if (did.eq.TSTRAW_MISC_ID) then
+*
+* BPM/Raster ADC values.
+*
+ else if (did.eq.GMISC_ID) then
+ pointer = pointer +
+ $ g_decode_fb_detector(lastslot, roc, bank(pointer),
+ & maxwords, did,
+ $ GMAX_MISC_HITS, GMISC_TOT_HITS, GMISC_RAW_ADDR1,
+ $ GMISC_RAW_ADDR2, 1, GMISC_RAW_DATA, 0, 0, 0)
+
+*
+* Data from Uninstrumented channels and slots go into a special array
+*
+ else if (did.eq.UNINST_ID) then
+ pointer = pointer +
+ $ g_decode_fb_detector(lastslot, roc, bank(pointer),
+ & maxwords, did,
+ $ GMAX_UNINST_HITS, GUNINST_TOT_HITS, GUNINST_RAW_ROCSLOT,
+ $ GUNINST_RAW_SUBADD, 1, GUNINST_RAW_DATAWORD, 0, 0, 0)
+
+ else
+* Should never get here. Unknown detector ID's or did=-1 for bad ROC#
+* or SLOT# will come here.
+*
+ print *,"BAD DID, unknown ROC,SLOT",roc,slot,did
+ pointer = pointer + 1 ! Skip unknown detector id's
+ endif
+ else
+ lastslot = slot
+ pointer = pointer + 1 ! Skip Bad subaddresses (module header)
+ endif
+*
+ else
+ pointer = pointer + 1 ! Skip bad slots
+ endif
+*
+ enddo
+ ABORT= .FALSE.
+ error= ' '
+ return
+ end
+**************
+* Local Variables:
+* mode: fortran
+* fortran-if-indent: 2
+* fortran-do-indent: 2
+* End:
diff --git a/T20/g_decode_fb_detector.f b/T20/g_decode_fb_detector.f
new file mode 100644
index 0000000..9b4bea7
--- /dev/null
+++ b/T20/g_decode_fb_detector.f
@@ -0,0 +1,335 @@
+ INTEGER*4 FUNCTION g_decode_fb_detector(oslot,roc,evfrag,length,did,
+ $ maxhits,hitcount,planelist,counterlist,signalcount,signal0,
+ $ signal1,signal2,signal3)
+*----------------------------------------------------------------------
+*- Created ? Steve Wood, CEBAF
+*- Corrected 3-Dec-1993 Kevin Beard, Hampton U.
+* $Log: g_decode_fb_detector.f,v $
+* Revision 1.1.24.1 2007/09/11 19:14:18 frw
+* fixed FPP related arrays and limits
+*
+* Revision 1.1 1998/12/01 20:58:30 saw
+* Initial revision
+*
+* Revision 1.18 1997/04/03 10:56:05 saw
+* (SAW) Better report of DCFE code words. Prints out roc, slot, event
+* number and how many extra events are in the module.
+*
+* Revision 1.17 96/09/04 14:34:19 14:34:19 saw (Stephen A. Wood)
+* (JRA) More error reporting of error codes in FB data stream
+*
+* Revision 1.16 1996/04/29 19:46:19 saw
+* (JRA) Tweak diagnostic messages
+*
+* Revision 1.15 1996/01/16 20:51:55 cdaq
+* (SAW) Fixes: Forgot why
+*
+* Revision 1.14 1995/11/28 18:59:24 cdaq
+* (SAW) Change arrays that use roc as index to start with zero.
+*
+* Revision 1.13 1995/10/09 18:23:29 cdaq
+* (JRA) Comment out some debugging statements
+*
+* Revision 1.12 1995/07/27 19:10:02 cdaq
+* (SAW) Use specific bit manipulation routines for f2c compatibility
+*
+* Revision 1.11 1995/01/31 15:55:52 cdaq
+* (SAW) Make sure mappointer and subaddbit are set on program entry.
+*
+* Revision 1.10 1995/01/27 20:14:04 cdaq
+* (SAW) Add assorted diagnostic printouts. Add hack to look for the headers
+* on new 1881M/1877 modules while maintaining backward compatibility.
+*
+* Revision 1.9 1994/10/20 12:34:55 cdaq
+* (SAW) Only print out "Max exceeded, did=" meesage once
+*
+* Revision 1.8 1994/06/27 02:14:18 cdaq
+* (SAW) Ignore all words that start with DC
+*
+* Revision 1.7 1994/06/22 20:21:24 cdaq
+* (SAW) Put -1 in hodoscope signals that don't get any data
+*
+* Revision 1.6 1994/06/22 20:07:37 cdaq
+* (SAW) Fix problems with filling of hodoscope type hit lists (multiple signal)
+*
+* Revision 1.5 1994/06/21 16:02:54 cdaq
+* (SAW) Ignore DCFF0000 headers from Arrington's CRL's
+*
+* Revision 1.4 1994/06/18 02:48:04 cdaq
+* (SAW) Add code for miscleaneous data and uninstrumented channels
+*
+* Revision 1.3 1994/04/06 18:03:38 cdaq
+* (SAW) # of bits to get channel number is now configurable (g_decode_subaddbit).
+* Changed range of signal types from 1:4 to 0:3 to agree with documentation.
+*
+* Revision 1.2 1994/03/24 22:00:15 cdaq
+* Temporarily change shift to get subaddress from 17 to 16
+*
+* Revision 1.1 1994/02/04 21:50:03 cdaq
+* Initial revision
+*
+*----------------------------------------------------------------------
+ implicit none
+ SAVE
+*
+* The following arguments don't get modified.
+ integer*4 roc,evfrag(*),length,did,maxhits,signalcount
+
+* The following arguments get modified.
+ integer*4 oslot
+ integer*4 buffer
+ integer*4 hitcount,planelist(*),counterlist(*)
+ integer*4 signal0(*),signal1(*),signal2(*),signal3(*)
+ integer pointer,newdid,subadd,slot,mappointer,plane
+ integer counter,signal,sigtyp
+*
+ include 'gen_detectorids.par'
+ include 'gen_decode_common.cmn'
+ include 'gen_scalers.cmn'
+ include 'gen_event_info.cmn'
+ integer iscaler,nscalers
+*
+ integer h,hshift
+ integer subaddbit
+ logical printerr !flag to turn off printing of error after 1 time.
+ logical firsttime
+*
+ integer*4 jishft, jiand
+*
+ printerr = .true.
+ pointer = 1
+ newdid = did
+
+ firsttime = .true.
+ do while(pointer.le.length .and. did.eq.newdid)
+*
+ if(jiand(evfrag(pointer),'FFFFFFFF'x).eq.'DCAA0000'x) then ! VME/FB event length mismatch
+ write(6,'(a,i10)') 'ERROR: VME/Fastbus event length mismatch for event #',gen_event_id_number
+ write(6,'(a,z9,a,z9,a)') ' Fastbus event length:',evfrag(pointer+1),
+ & ' VME event length:',evfrag(pointer+2),' (or vice-versa).'
+ pointer = pointer + 3
+ goto 987
+! Check for extra events in FB modules on sync events
+ else if(jiand(evfrag(pointer),'FFFF0000'x).eq.'DCFE0000'x) then
+ write(6,'(a,i2,a,i3,a,i3,a,i10)') 'ROC',roc,': Slot'
+ $ ,jiand(jishft(evfrag(pointer),-11),'1F'x),': '
+ $ ,jiand(evfrag(pointer),'7FF'x),' extra events, event=',
+ & gen_event_id_number
+ pointer = pointer + 1
+ goto 987
+ else if(jiand(evfrag(pointer),'FF000000'x).eq.'DC000000'x) then ! Catch arrington's headers
+ write(6,'(a,i2,a,i10,a,z10)') 'ROC',roc,': no gate or too much data, event=',
+ & gen_event_id_number,' error dataword=',evfrag(pointer)
+ pointer = pointer + 1
+ goto 987
+ endif
+
+*
+* Check for event by event scalers thrown in by the scaler hack.
+*
+* if(jiand(evfrag(pointer),'FF000000'x).eq.'DA000000'x) then ! Magic header
+* nscalers = jiand(evfrag(pointer),'FF'x)
+* do iscaler=1,nscalers
+* evscalers(iscaler) = evfrag(pointer+iscaler)
+* enddo
+* pointer = pointer + nscalers + 1
+* goto 987
+* endif
+
+ if(evfrag(pointer).le.1.and.evfrag(pointer).ge.0) then
+
+! on sync events, get zeros at end of event.
+ if (gen_event_id_number .eq. 1000*int(gen_event_id_number/1000)) then
+ if (evfrag(pointer).ne.0) then
+
+ write(6,'(" ERROR: BAD FB value evfrag(",i4,")=",z10," ROC=",i2,"event=",i7)')
+ $ pointer,evfrag(pointer),roc,gen_event_id_number
+ endif
+ endif
+ pointer = pointer + 1
+ goto 987
+ endif
+ slot = jiand(JISHFT(evfrag(pointer),-27),'1F'X)
+ if(slot.ne.oslot.or.firsttime) then
+ if (slot.le.0 .or. slot.ge.26 .or. roc.le.0 .or. roc.ge.9) then
+ write (6,'(a,i2,i3,z10,a,i5,a,i8)') 'roc,slot,evfrag=',roc,
+ & slot,evfrag(pointer),
+ $ '(p=',pointer,') for event #',gen_event_id_number
+ write (6,'(a,i3)') ' Probably after slot',jiand(JISHFT(evfrag(pointer-1),-27),'1F'X)
+ pointer = pointer + 1
+ goto 987
+ else
+ mappointer = g_decode_slotpointer(roc,slot)
+ subaddbit = g_decode_subaddbit(roc,slot) ! Usually 16 or 17
+ endif
+ endif
+ if(slot.ne.oslot) then
+ oslot = slot
+
+c
+c On 1881M's and 1877, a subaddress of zero could be a header word, so
+c we need to put in some hackery to catch these. We need to make sure
+c that 1881's and 1876's will still work.
+c
+c A real ugly hack that looks to see if the first word of an 1881M or
+c 1877 has a subaddress of zero, in which case it is the header word and must
+c be discarded. If it is an 1881 or 1876, then the the first word of a
+c new slot will have a subaddress of '7F' and later be discarded.
+c
+ if(subaddbit.eq.17) then ! Is not an 1872A (which has not headers)
+ if(jiand(evfrag(pointer),'00FE0000'X).eq.0) then ! probably a header
+ if(jiand(evfrag(pointer),'07FF0000'X).ne.0) then
+ print *,"SHIT:misidentified real data word as a header"
+ print *,"DID=",did,", SLOT=",slot,", POINTER=",pointer
+ else
+ pointer = pointer + 1
+ goto 987
+ endif
+ endif
+ endif
+ endif
+*
+***********************
+cc write(6,*) buffer
+c buffer = jiand(JISHFT(evfrag(pointer),-24),'03'X)
+c if (g_decode_bufnum .ne. buffer) then
+c if (g_decode_bufnum.eq.-1) then
+c g_decode_bufnum=buffer
+c else
+c write (6,*) 'g_decode_fb_detector: roc,slot,buffer='
+c & ,roc,slot,buffer,'but previous data was buffer=',
+c & g_decode_bufnum
+c write (6,*) 'gen_event_id_number=',gen_event_id_number
+cc stop
+c endif
+c endif
+*************************
+ subadd = jiand(JISHFT(evfrag(pointer),-subaddbit),'7F'X)
+*
+* If a module that uses a shift of 17 for the subaddress is in a slot
+* that we havn't told the map file about, it's data will end up in the
+* unstrimented channel "detector" hit list. However, the decoder will
+* think that the subaddress starts in channel 16 (since some Lecroy
+* modules do so), The next statement will mean that only the first 64
+* channels will end up in the uninstrumented hit list. The rest will
+* be lost. If you don't want to put this module in the map file, put
+* in a single entry for it with a detector id of UNINST_ID (zero) and
+* the proper BSUB value.
+*
+ if (subadd .lt. '7F'X) then ! Only valid subaddresses
+ ! Skips headers for 1881 and 1876
+ if(mappointer.gt.0) then
+ newdid = g_decode_didmap(mappointer+subadd)
+ else
+ newdid = UNINST_ID
+ endif
+ if(newdid.eq.did) then
+ if(did.ne.UNINST_ID) then
+ plane = g_decode_planemap(mappointer+subadd)
+ counter = g_decode_countermap(mappointer+subadd)
+ signal =jiand(evfrag(pointer),g_decode_slotmask(roc,slot))
+ else
+ plane = jishft(roc,16) + slot
+ counter = subadd
+ signal = evfrag(pointer)
+ endif
+ if(hitcount .lt. maxhits) then ! Don't overwrite arrays
+ if(signalcount .eq. 1) then ! single signal counter
+*
+* Starting at end of hit list, search back until a hit earlier in
+* the sort order is found.
+*
+ h = hitcount
+ do while(h .gt. 0 .and. (plane .lt. planelist(h)
+ $ .or.(plane .eq. planelist(h).and. counter .lt.
+ $ counterlist(h))))
+*
+* Shift hit to next place in list
+*
+ planelist(h+1) = planelist(h)
+ counterlist(h+1) = counterlist(h)
+ signal0(h+1) = signal0(h)
+ h = h - 1
+ enddo
+ h = h + 1 ! Put hit pointer to blank
+ planelist(h) = plane
+ counterlist(h) = counter
+ signal0(h) = signal
+ hitcount = hitcount + 1
+ else if(signalcount.eq.4) then ! Multiple signal counter
+*
+* Starting at the end of the hist list, search back until a hit on
+* the same counter or earlier in the sort order is found.
+*
+ h = hitcount
+ do while(h .gt. 0 .and. (plane .lt. planelist(h)
+ $ .or.(plane .eq. planelist(h).and. counter .lt.
+ $ counterlist(h))))
+ h = h - 1
+ enddo
+*
+* If plane/counter match is not found, then need to shift up the array
+* to make room for the new hit.
+*
+ if(h.le.0.or.plane.ne.planelist(h) ! Plane and counter
+ $ .or.counter.ne.counterlist(h)) then ! not found
+ h = h + 1
+ do hshift=hitcount,h,-1 ! Shift up to make room
+ planelist(hshift+1) = planelist(hshift)
+ counterlist(hshift+1) = counterlist(hshift)
+ signal0(hshift+1) = signal0(hshift)
+ signal1(hshift+1) = signal1(hshift)
+ signal2(hshift+1) = signal2(hshift)
+ signal3(hshift+1) = signal3(hshift)
+ enddo
+ planelist(h) = plane
+ counterlist(h) = counter
+ signal0(h) = -1
+ signal1(h) = -1
+ signal2(h) = -1
+ signal3(h) = -1
+ hitcount = hitcount + 1
+ endif
+*
+ sigtyp = g_decode_sigtypmap(mappointer+subadd)
+*
+ if(sigtyp.eq.0) then
+ signal0(h) = signal
+ else if (sigtyp.eq.1) then
+ signal1(h) = signal
+ else if (sigtyp.eq.2) then
+ signal2(h) = signal
+ else if (sigtyp.eq.3) then
+ signal3(h) = signal
+ endif
+ endif
+ else if(hitcount.eq.maxhits .and. printerr) then ! Only print this message once
+c print *,'g_decode_fb_detector: Max exceeded, did=',
+c $ did,', max=',maxhits,': event',gen_event_id_number
+c print *,' roc,slot,cntr=',roc,slot,counter
+ printerr = .false.
+*
+* Print/generate some kind of error that the hit array has been
+* exceeded.
+*
+ endif
+ pointer = pointer + 1
+* else
+* exit and get called back with the correct arrays for the new did
+ endif
+ else
+ pointer = pointer + 1
+ endif
+ 987 continue
+ enddo
+
+ g_decode_fb_detector = pointer - 1 ! Number of words processed
+
+ return
+ end
+**************
+* Local Variables:
+* mode: fortran
+* fortran-if-indent: 2
+* fortran-do-indent: 2
+* End:
diff --git a/T20/g_examine_go_info.f b/T20/g_examine_go_info.f
new file mode 100644
index 0000000..5edb13b
--- /dev/null
+++ b/T20/g_examine_go_info.f
@@ -0,0 +1,136 @@
+ SUBROUTINE G_examine_go_info(buffer,ABORT,err)
+*-----------------------------------------------------
+*-
+*- Purpose and Methods : examine the go information and gather various
+*- quantities
+*-
+*- Input: buffer - raw data buffer
+*- : ABORT - success or failure
+*- : err - reason for failure, if any
+*-
+*- Created 30-Nov-1995 John Arrington, Caltech.
+*-
+* $Log: g_examine_go_info.f,v $
+* Revision 1.1.24.1 2007/09/11 19:14:18 frw
+* fixed FPP related arrays and limits
+*
+* Revision 1.1 1997/05/23 20:39:42 saw
+* Initial revision
+*
+*
+*--------------------------------------------------------
+ IMPLICIT NONE
+ SAVE
+*
+ character*18 here
+ parameter (here= 'G_examine_go_info')
+*
+ INTEGER buffer(*)
+ LOGICAL ABORT
+ CHARACTER*(*) err
+*
+ include 'gen_detectorids.par'
+ include 'gen_decode_common.cmn'
+ include 'gen_run_info.cmn'
+*
+ integer EvType
+ integer*4 pointer,subpntr,ind
+ integer*4 evlen,sublen,subheader,slotheader,numvals
+ integer*4 roc,slot
+ integer*4 jiand,jishft
+ logical*4 found_thresholds,found_prescale
+ character*80 prescale_string
+ character*4 tmpstring
+ integer*4 ilo,prescale_len
+* functions
+ integer g_important_length
+*
+*----------------------------------------------------------------------
+ err= ' '
+*
+ EvType = jISHFT(buffer(2),-16)
+ if (evtype.ne.133) then
+ err = 'Event is not a control event'
+ ABORT = .true.
+ call g_add_path(here,err)
+ return
+ endif
+*
+ found_thresholds = .false.
+ found_prescale = .false.
+ prescale_string = ' '
+ evlen = buffer(1)
+
+
+c write(6,*) 'evlen=',buffer(1)
+ pointer = 3 !1=#/words, 2=event type
+ roc= (jiand(buffer(2),'FF'x))
+c write(6,*) 'roc=',roc,'evtype=',evtype
+
+ do while (.not.found_thresholds .and. pointer.le.evlen)
+ sublen=buffer(pointer)
+c write(6,*) ' sublen=',sublen
+ subheader=buffer(pointer+1)
+c write(6,'(a,z10)') ' subheader=',subheader
+
+ if (jishft(jiand(subheader,'FF0000'x),-16) .eq. '10'x) then !thresholds
+ found_thresholds = .true.
+c write(6,*) ' THRESHOLDS!'
+ subpntr=2 !skip past main subheader.
+c write(6,*) ' subpntr=',subpntr
+ do while (subpntr .lt. sublen)
+ slotheader=buffer(pointer+subpntr)
+ slot=jishft(jiand(slotheader,'FF000000'x),-24)
+c write(6,'(a,z10)') ' slotheader=',slotheader
+ numvals=jiand(slotheader,'FF'x)
+c write(6,*) ' slot#',slot,' has ',numvals,' thresholds'
+ do ind=1,numvals
+ subpntr=subpntr+1
+ g_threshold_readback(ind,roc,slot)=buffer(pointer+subpntr)
+c write(6,*) 'g_threshold_readback(',ind,roc,slot,')=',g_threshold_readback(ind,roc,slot)
+ enddo
+ subpntr=subpntr+1 !skip to next slotheader
+c write(6,*) 'subpntr=',subpntr
+ enddo !NEED CHECK FOR NEXT HEADER.
+ pointer=pointer+subpntr
+ else if (roc.eq.0 .and.
+ & jishft(jiand(subheader,'FF0000'x),-16).eq.'02'x) then
+c write(6,*) 'PRESCALE FACTORS'
+ found_prescale=.true.
+ do ind=2,sublen
+c write(6,'(3x,a,i4,2x,a4) ') 'ind=',ind,buffer(pointer+ind)
+ write(tmpstring,'(a4)') buffer(pointer+ind)
+ prescale_string(4*(ind-2)+1:4*(ind-1)) = tmpstring
+ enddo
+ prescale_len=4*(sublen-1)
+ pointer=pointer+sublen+1
+ else
+c write(6,*) ' NOT THRESHOLDS,NOT PS FACTORS. WHO CARES.'
+ pointer=pointer+sublen+1
+ endif
+ enddo
+*
+ if (found_prescale .and. prescale_len.ne.0) then
+ prescale_len = g_important_length(prescale_string(1:prescale_len))
+ if(ichar(prescale_string(prescale_len:prescale_len)).eq.10)
+ $ prescale_len = prescale_len - 1
+ ilo=index(prescale_string(1:prescale_len),'=')+1
+ read(prescale_string(ilo:prescale_len),*,err=998) gps1
+ ilo=index(prescale_string(ilo+1:prescale_len),'=')+ilo+1
+ read(prescale_string(ilo:prescale_len),*,err=998) gps2
+ ilo=index(prescale_string(ilo+1:prescale_len),'=')+ilo+1
+ read(prescale_string(ilo:prescale_len),*,err=998) gps3
+ ilo=index(prescale_string(ilo+1:prescale_len),'=')+ilo+1
+ read(prescale_string(ilo:prescale_len),*,err=998) gps4
+ ilo=index(prescale_string(ilo+1:prescale_len),'=')+ilo+1
+ read(prescale_string(ilo:prescale_len),*,err=998) gps5
+
+c write(6,*) 'gps1=',gps1,'gps2=',gps2,'gps3=',gps3,'gps4=',gps4,'gps5='
+c $ ,gps5
+ endif
+*
+ goto 999
+998 write(6,*) 'WARNING: g_examine_go_info.f >>> error extracting prescale factors, giving up'
+999 continue
+ RETURN
+ END
diff --git a/T20/g_get_next_event.f b/T20/g_get_next_event.f
new file mode 100644
index 0000000..6b11587
--- /dev/null
+++ b/T20/g_get_next_event.f
@@ -0,0 +1,76 @@
+ SUBROUTINE G_get_next_event(ABORT,err)
+*--------------------------------------------------------
+*- Prototype C analysis routine
+*-
+*-
+*- Purpose and Methods : gets the CRAW (C raw data) buffer
+*- from a FASTBUS CODA file
+*-
+*- Output: ABORT - success or failure
+*- : err - reason for failure, if any
+*-
+*- Created 29-Oct-1993 Kevin B. Beard
+*- Modified 1-Dec-1993 KBB: borrowed L.Dennis's hall B routines
+* $Log: g_get_next_event.f,v $
+* Revision 1.1 1997/05/23 19:22:54 saw
+* Initial revision
+*
+*-
+*- All standards are from "Proposal for Hall C Analysis Software
+*- Vade Mecum, Draft 1.0" by D.F.Geesamn and S.Wood, 7 May 1993
+*-
+*-
+*--------------------------------------------------------
+ IMPLICIT NONE
+ SAVE
+*
+ character*16 here
+ parameter (here= 'G_get_next_event')
+*
+ logical ABORT
+ character*(*) err
+*
+ INCLUDE 'gen_data_structures.cmn'
+ include 'gen_craw.cmn'
+ INCLUDE 'gen_filenames.cmn'
+ include 'gen_run_info.cmn'
+*
+ integer maxsize
+ integer*4 status
+ integer*4 evread ! Coda event read routine
+ integer*4 tc_read ! Saturne t20 calib event read routine
+*
+*--------------------------------------------------------
+*
+ err= ' '
+*
+ ABORT= .NOT.g_data_source_opened
+*
+ IF(ABORT) THEN
+*
+ err= ':no data source open'
+*
+ ELSE !try to get next event
+*
+ maxsize= LENGTH_CRAW
+
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC POLDER
+* change for the t20 experiment D.P. 2/21/97 (21.2.97)
+ if(gen_run_number.GT.100000) then
+ status = tc_read(g_data_source_in_hndl,CRAW,maxsize)
+ else
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+ status = evread(g_data_source_in_hndl,CRAW,maxsize)
+ endif
+
+ if(status.ne.0) then
+ call cemsg(status,0,err) ! Get error string from CODA
+ ABORT = .true.
+ endif
+ ENDIF
+*
+ IF(ABORT) call G_add_path(here,err)
+*
+ RETURN
+ END
+
diff --git a/T20/g_init_filenames.f b/T20/g_init_filenames.f
new file mode 100644
index 0000000..4e6a330
--- /dev/null
+++ b/T20/g_init_filenames.f
@@ -0,0 +1,191 @@
+ subroutine g_init_filenames(ABORT, err, env_var)
+*----------------------------------------------------------------------
+*- Purpose and Methods:
+*-
+*- Read a configuration file with set of filenames and options.
+*- Much of this will be handled by CTP when a string capability is added
+*- to CTP parameter files. Allowed keywords in config file are
+*- 'hist', 'test', 'parm', 'alias', 'data', 'hbook', 'map', 'nevents', 'data'
+*-
+*- This routine does the booking of hist, test, and parm files. This
+*- booking should be moved to another file.
+*-
+*- Inputs:
+*-
+*- env_var Environment variable pointing to the config file.
+*-
+*- Outputs:
+*-
+*- ABORT
+*- err
+*-
+*- Created Steve Wood, CEBAF
+*- Modified 3-Dec-1993 Kevin Beard, Hampton U.
+*- Modified 8-Dec-1993 Kevin Beard; rewrote parsing,added 'data' type
+* $Log: g_init_filenames.f,v $
+* Revision 1.1 1998/12/01 20:58:38 saw
+* Initial revision
+*
+* Revision 1.17 1996/11/05 21:40:59 saw
+* (JRA) Add g_epics_output_filename
+*
+* Revision 1.16 1996/09/04 14:36:59 saw
+* (JRA) Add read of command line parameters
+*
+* Revision 1.15 1996/04/29 19:47:11 saw
+* (JRA) Add g_pedestal_output_filename
+*
+* Revision 1.14 1996/01/16 18:31:26 cdaq
+* (JRA) Add file for tcl stats display, add files for thresholds and pedestals
+*
+* Revision 1.13 1995/10/09 18:37:52 cdaq
+* (SAW) Move g_ctp_database call to engine.f
+*
+* Revision 1.12 1995/09/01 14:31:03 cdaq
+* (JRA) Blank out g_ctp_kinematics_filename
+*
+* Revision 1.11 1995/07/27 19:35:15 cdaq
+* (SAW) Add call to g_ctp_database to set ctp vars by run number
+*
+* Revision 1.10 1995/05/11 19:01:29 cdaq
+* (SAW) Check 0 in g_config_filename in case user doesn't update engine.f
+*
+* Revision 1.9 1995/05/11 16:16:11 cdaq
+* (SAW) Don't get g_config_filename from environment if it is already set
+* from the command line and allow %d run number substitution in it.
+*
+* Revision 1.8 1995/04/01 19:46:13 cdaq
+* (SAW) One report file for each of g, h, s, c instead of a single report file
+*
+* Revision 1.7 1994/10/19 19:51:55 cdaq
+* (SAW) Add g_label variable for labels on reports
+*
+* Revision 1.6 1994/06/22 20:57:14 cdaq
+* (SAW) Add more variables for reports
+*
+* Revision 1.5 1994/06/16 03:47:57 cdaq
+* (SAW) Blank out filenames for reports
+*
+* Revision 1.4 1994/03/24 22:02:21 cdaq
+* Reorganize for online compatibility
+*
+* Revision 1.3 1994/02/11 18:34:34 cdaq
+* Split off CTP variables registration from initialize routines
+*
+* Revision 1.2 1994/02/03 18:12:17 cdaq
+* Use CTP parameter block to get the filenames
+*
+* Revision 1.1 1994/02/02 20:08:15 cdaq
+* Initial revision
+*
+*----------------------------------------------------------------------
+ implicit none
+ SAVE
+*
+ character*16 here
+ parameter (here= 'g_init_filenames')
+*
+ logical ABORT
+ character*(*) err
+ character*(*) env_var
+*
+ include 'gen_filenames.cmn'
+ include 'hms_filenames.cmn'
+ include 't20_filenames.cmn'
+ include 'coin_filenames.cmn'
+ include 'gen_routines.dec'
+ include 'gen_run_info.cmn'
+*
+ integer ierr
+ character*132 file
+*
+*-all crucial setup information here; failure is fatal
+*
+ g_hist_rebook = .true.
+ g_test_rebook = .true.
+ g_parm_rebook = .true.
+ g_report_rebook = .true.
+ g_ctp_parm_filename = ' '
+ g_ctp_test_filename = ' '
+ g_ctp_hist_filename = ' '
+ g_data_source_filename= ' '
+ g_alias_filename = ' '
+ g_histout_filename = ' '
+ g_decode_map_filename = ' '
+ g_ctp_database_filename = ' '
+ g_ctp_kinematics_filename = ' '
+ g_charge_scaler_filename = ' '
+*
+ t_recon_coeff_filename = ' '
+ h_recon_coeff_filename = ' '
+*
+ h_report_template_filename = ' '
+ t_report_template_filename = ' '
+ g_report_template_filename = ' '
+ c_report_template_filename = ' '
+ g_stats_template_filename = ' '
+*
+ h_report_output_filename = ' '
+ t_report_output_filename = ' '
+ g_report_output_filename = ' '
+ c_report_output_filename = ' '
+ g_stats_output_filename = ' '
+ g_bad_output_filename = ' '
+ g_epics_output_filename = ' '
+*
+ h_report_blockname = ' '
+ t_report_blockname = ' '
+ g_report_blockname = ' '
+ c_report_blockname = ' '
+ g_stats_blockname = ' '
+*
+ h_threshold_output_filename = ' '
+ t_threshold_output_filename = ' '
+ g_pedestal_output_filename = ' '
+ h_pedestal_output_filename = ' '
+ t_pedestal_output_filename = ' '
+*
+ g_label = ' ' ! Label for reports etc.
+*
+ if(g_config_filename.eq.' '.or.
+ $ ichar(g_config_filename(1:1)).eq.0) ! Only if not already set
+ $ call getenv(env_var,g_config_filename)
+*
+ call engine_command_line(.false.)
+*
+ ABORT= g_config_filename.EQ.' '
+ IF(ABORT) THEN
+ err= here//':blank environmental variable '//env_var
+ RETURN
+ ENDIF
+*
+ file = g_config_filename
+ call g_sub_run_number(file,gen_run_number)
+ ierr = thload(file) ! Config file is now a CTP parm file
+ if(ierr.ne.0) goto 999
+ ierr = thbook()
+ if(ierr.eq.0) then
+ g_config_loaded = .true.
+ else
+ g_config_loaded = .false.
+ endif
+
+ ABORT= .NOT.g_config_loaded
+ IF(ABORT) THEN
+ err= ':opened OK, but thbook command failed from "'//file//'"'
+ call G_add_path(here,err)
+ ELSE
+ err= ' '
+ ENDIF
+*
+ return
+*
+999 g_config_loaded= .FALSE.
+ ABORT= .NOT.g_config_loaded
+ err= ':unable to open file "'//file//'"'
+ call G_add_path(here,err)
+ return
+*
+ end
+
+
diff --git a/T20/g_initialize.f b/T20/g_initialize.f
new file mode 100644
index 0000000..2ec7919
--- /dev/null
+++ b/T20/g_initialize.f
@@ -0,0 +1,326 @@
+ SUBROUTINE G_initialize(ABORT,err)
+*----------------------------------------------------------------------
+*- Prototype hall C initialize routine
+*-
+*- Purpose and Methods : Initialization is performed and status returned
+*-
+*- Output: ABORT - success or failure
+*- : err - reason for failure, if any
+*-
+*- Created 9-Nov-1993 Kevin B. Beard
+*- Modified 20-Nov-1993 Kevin B. Beard
+* $Log: g_initialize.f,v $
+* Revision 1.1 1998/12/01 20:58:42 saw
+* Initial revision
+*
+* Revision 1.21 1996/11/05 21:41:36 saw
+* (SAW) Use CTP routines as functions rather than subroutines for
+* porting.
+*
+* Revision 1.20 1996/09/04 14:37:56 saw
+* (JRA) Open output file for charge scalers
+*
+* Revision 1.19 1996/04/29 19:47:42 saw
+* (JRA) Add call to engine_command_line
+*
+* Revision 1.18 1996/01/22 15:18:12 saw
+* (JRA) Add call to g_target_initialize. Remove call to
+* g_kludge_up_kinematics
+*
+* Revision 1.17 1996/01/16 18:24:47 cdaq
+* (JRA) Get kinematics for runinfo event, create a tcl stats screen. Groupify
+* CTP calls
+*
+* Revision 1.16 1995/10/09 18:42:57 cdaq
+* (SAW) Move loading of ctp_kinematics database to before CTP loading. Take
+* ntuple inialization out of spec specific init routines into a all ntuple
+* init routine.
+*
+* Revision 1.15 1995/09/01 14:29:41 cdaq
+* (JRA) Zero run time variable, read kinematics database after last book
+*
+* Revision 1.14 1995/07/27 19:36:41 cdaq
+* (SAW) Relocate data statements for f2c compatibility, check error returns
+* on thload calls and quit if important files are missing.
+*
+* Revision 1.13 1995/05/22 20:41:40 cdaq
+* (SAW) Split g_init_histid into h_init_histid and s_init_histid
+*
+* Revision 1.12 1995/04/01 19:47:22 cdaq
+* (SAW) One report file for each of g, h, s, c instead of a single report file
+* Allow %d for run number in filenames
+*
+* Revision 1.11 1994/10/11 18:39:40 cdaq
+* (SAW) Add some hacks for event display
+*
+* Revision 1.10 1994/09/21 19:52:57 cdaq
+* (SAW) Cosmetic change
+*
+* Revision 1.9 1994/08/30 14:47:41 cdaq
+* (SAW) Add calls to clear the test flags and scalers
+*
+* Revision 1.8 1994/08/18 03:45:01 cdaq
+* (SAW) Correct typo in adding hack stuff
+*
+* Revision 1.7 1994/08/04 03:08:11 cdaq
+* (SAW) Add call to Breuer's hack_initialize
+*
+* Revision 1.6 1994/06/22 20:55:14 cdaq
+* (SAW) Load report templates
+*
+* Revision 1.5 1994/06/04 02:35:59 cdaq
+* (KBB) Make sure CTP files are non-blank before trying to thload them
+*
+* Revision 1.4 1994/04/12 20:59:21 cdaq
+* (SAW) Add call to calculation of histid's for hfilled histograms
+*
+* Revision 1.3 1994/03/24 22:02:31 cdaq
+* Reorganize for online compatibility
+*
+* Revision 1.2 1994/02/11 18:34:49 cdaq
+* Split off CTP variables registration from initialize routines
+*
+* Revision 1.1 1994/02/04 22:00:26 cdaq
+* Initial revision
+*
+*-
+*- All standards are from "Proposal for Hall C Analysis Software
+*- Vade Mecum, Draft 1.0" by D.F.Geesamn and S.Wood, 7 May 1993
+*-
+*--------------------------------------------------------
+ IMPLICIT NONE
+ SAVE
+*
+ character*12 here
+ parameter (here= 'G_initialize')
+*
+ logical ABORT
+ character*(*) err
+*
+ INCLUDE 'gen_filenames.cmn' !all setup files
+ INCLUDE 'hms_filenames.cmn'
+ INCLUDE 't20_filenames.cmn'
+ INCLUDE 'coin_filenames.cmn'
+ INCLUDE 'gen_routines.dec'
+ INCLUDE 'gen_pawspace.cmn' !includes sizes of special CERNLIB space
+ INCLUDE 'gen_run_info.cmn'
+ include 'gen_scalers.cmn'
+ include 'hms_data_structures.cmn'
+ include 't20_data_structures.cmn'
+*
+ integer ierr
+ logical HMS_ABORT,T20_ABORT, HACK_ABORT
+ character*132 HMS_err,T20_err, HACK_err
+*
+ character*132 file
+ logical*4 first_time ! Allows routine to be called
+ save first_time
+ data first_time /.true./ ! by online code
+*
+*--------------------------------------------------------
+*
+ ABORT= .FALSE. !clear any old flags
+ err= ' ' !erase any old errors
+ HMS_err= ' '
+ T20_err= ' '
+*
+* set the runtime variable to avoid divide by zero during report
+*
+ g_run_time = 0.0001
+*
+* Book the histograms, tests and parameters
+*
+ if(first_time) then
+ call HLIMIT(G_sizeHBOOK) !set in "gen_pawspace.cmn"
+ endif
+* Load and book all the CTP files
+*
+*
+ if((first_time.or.g_parm_rebook).and.g_ctp_parm_filename.ne.' ') then
+ file = g_ctp_parm_filename
+ call g_sub_run_number(file,gen_run_number)
+ if(thload(file).ne.0) then
+ ABORT = .true.
+ err = file
+ endif
+ ierr = thbook() ! Assert parm values
+ endif ! so that ctp_database can override
+*
+*
+* Now if there is a g_ctp_kinematics_filename set, pass the run number
+* to it to set CTP variables. Parameters placed in this file will
+* override values defined in the CTP input files.
+*
+ if(.not.ABORT.and.g_ctp_kinematics_filename.ne.' ') then
+ write(6,'(a,a60)') 'KINEMATICS FROM ',g_ctp_kinematics_filename(1:60)
+ call g_ctp_database(ABORT, err
+ $ ,gen_run_number, g_ctp_kinematics_filename)
+ IF(ABORT) THEN
+ call G_add_path(here,err)
+ endif
+ ENDIF
+*
+ if((first_time.or.g_test_rebook).and.g_ctp_test_filename.ne.' ') then
+ file = g_ctp_test_filename
+ call g_sub_run_number(file,gen_run_number)
+ print *,'Test:',file
+ if(thload(file).ne.0) then
+ ABORT = .true.
+ if(err.ne.' ') then
+ call g_append(err,' & '//file)
+ else
+ err = file
+ endif
+ endif
+ endif
+
+ write(6,'(a)') 'COMMAND LINE FLAGS'
+ call engine_command_line(.true.) ! Reset CTP vars from command line
+
+* that was the last call to engine_command_line, the last time to input
+* ctp variables. Set some here to avoid divide by zero errors if they
+* were not read in.
+ if (hpcentral.le.0.001) hpcentral = 1.
+ if (tpcentral.le.0.001) tpcentral = 1.
+ if (htheta_lab.le.0.001) htheta_lab = 90.
+ if (ttheta_lab.le.0.001) ttheta_lab = 90.
+
+ if((first_time.or.g_hist_rebook).and.g_ctp_hist_filename.ne.' ') then
+ file = g_ctp_hist_filename
+ call g_sub_run_number(file,gen_run_number)
+ print *,'Hist:',file
+ if(thload(file).ne.0) then
+ ABORT = .true.
+ if(err.ne.' ') then
+ call g_append(err,' & '//file)
+ else
+ err = file
+ endif
+ endif
+ endif
+*
+ if(ABORT) then
+ call g_add_path(here,err)
+ return ! Don't try to proceed
+ endif
+
+*
+* Load the report definitions
+*
+ if((first_time.or.g_report_rebook)
+ $ .and.g_report_template_filename.ne.' ') then
+ file = g_report_template_filename
+ call g_sub_run_number(file,gen_run_number)
+ ierr = thload(file)
+ endif
+*
+ if((first_time.or.g_report_rebook)
+ $ .and.g_stats_template_filename.ne.' ') then
+ file = g_stats_template_filename
+ call g_sub_run_number(file,gen_run_number)
+ ierr = thload(file)
+ endif
+*
+ if((first_time.or.g_report_rebook)
+ $ .and.t_report_template_filename.ne.' ') then
+ file = t_report_template_filename
+ call g_sub_run_number(file,gen_run_number)
+ ierr = thload(file)
+ endif
+*
+ if((first_time.or.g_report_rebook)
+ $ .and.h_report_template_filename.ne.' ') then
+ file = h_report_template_filename
+ call g_sub_run_number(file,gen_run_number)
+ ierr = thload(file)
+ endif
+*
+ if((first_time.or.g_report_rebook)
+ $ .and.c_report_template_filename.ne.' ') then
+ file = c_report_template_filename
+ call g_sub_run_number(file,gen_run_number)
+ ierr = thload(file)
+ endif
+*
+* Call thbook if any new files have been loaded
+*
+ if(first_time.or.g_parm_rebook.or.g_test_rebook
+ $ .or.g_hist_rebook.or.g_report_rebook) then
+ ierr = thbook()
+*
+* Recalculate all histogram id's of user (hard wired) histograms
+*
+ call h_init_histid(ABORT,err)
+ call t_init_histid(ABORT,err)
+*
+ if(g_alias_filename.ne.' ') then
+ file = g_alias_filename
+ call g_sub_run_number(file,gen_run_number)
+ ierr = thwhalias(file)
+ if (ierr.ne.0) print *,'called haliaswrite',ierr
+ endif
+ endif
+*
+ call thtstclrg("default") ! Clear test flags
+ call thtstclsg("default") ! Clear test scalers
+*
+ call g_target_initialize(ABORT,err)
+
+* Open output file for charge scalers.
+ if (g_charge_scaler_filename.ne.' ') then
+ file=g_charge_scaler_filename
+ call g_sub_run_number(file,gen_run_number)
+ open(unit=G_LUN_CHARGE_SCALER,file=file,status='unknown')
+ write(G_LUN_CHARGE_SCALER,*) '!Charge scalers - Run #',gen_run_number
+ write(G_LUN_CHARGE_SCALER,*) '!event Unser(Hz) BCM1(Hz) BCM2(Hz)',
+ & ' BCM3(Hz) Time(s)'
+ endif
+
+* Open output file for epics events.
+ if (g_epics_output_filename.ne.' ') then
+ file=g_epics_output_filename
+ call g_sub_run_number(file,gen_run_number)
+ open(unit=G_LUN_EPICS_OUTPUT,file=file,status='unknown')
+ endif
+
+*-HMS initialize
+ call H_initialize(HMS_ABORT,HMS_err)
+*
+*-T20 initialize
+ call T_initialize(T20_ABORT,T20_err)
+*
+ ABORT= HMS_ABORT .or. T20_ABORT
+ If(HMS_ABORT .and. .NOT.T20_ABORT) Then
+ err= HMS_err
+ ElseIf(T20_ABORT .and. .NOT.HMS_ABORT) Then
+ err= T20_err
+ ElseIf(HMS_ABORT .and. T20_ABORT) Then
+ err= '&'//T20_err
+ call G_prepend(HMS_err,err)
+ EndIf
+*
+ IF(.NOT.ABORT) THEN
+*
+*-COIN initialize
+*
+ call C_initialize(ABORT,err)
+*
+ ENDIF
+*
+ call g_ntuple_init(HACK_ABORT,HACK_err) ! Ingore error return for now
+*
+ call hack_initialize(HACK_ABORT,HACK_err) ! Ignore error return for now
+*
+*-force reset of all space of all working arrays
+*-(clear just zeros the index of each array)
+ IF(.NOT.ABORT) THEN
+ call G_reset_event(ABORT,err)
+*
+ ENDIF
+*
+ IF(ABORT .or. err.NE.' ') call G_add_path(here,err)
+*
+ first_time = .false.
+*
+ RETURN
+ END
diff --git a/T20/g_open_source.f b/T20/g_open_source.f
new file mode 100644
index 0000000..808da05
--- /dev/null
+++ b/T20/g_open_source.f
@@ -0,0 +1,71 @@
+ SUBROUTINE G_open_source(ABORT,err)
+*----------------------------------------------------------------------
+*- Prototype hall C open (FASTBUS) CODA file routine
+*-
+*- Purpose and Methods : Initialization is performed and status returned
+*-
+*- Output: ABORT - success or failure
+*- : err - reason for failure, if any
+*-
+*- Created 30-Nov-1993 Kevin B. Beard
+*
+* $Log: g_open_source.f,v $
+* Revision 1.1 1997/05/23 19:38:57 saw
+* Initial revision
+*
+*-
+*- All standards are from "Proposal for Hall C Analysis Software
+*- Vade Mecum, Draft 1.0" by D.F.Geesamn and S.Wood, 7 May 1993
+*-
+*--------------------------------------------------------
+ IMPLICIT NONE
+ SAVE
+*
+ character*13 here
+ parameter (here= 'G_open_source')
+*
+ logical ABORT
+ character*(*) err
+*
+ INCLUDE 'gen_filenames.cmn'
+ INCLUDE 'gen_run_info.cmn'
+*
+ integer*4 status
+ integer*4 evopen ! CODA routine
+ integer*4 tc_open ! polder calibration data file opener
+ character*132 file
+*
+*--------------------------------------------------------
+ err= ' '
+ ABORT = .FALSE.
+ g_data_source_in_hndl= 0
+*
+ file = g_data_source_filename
+ call g_sub_run_number(file,gen_run_number)
+
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC POLDER
+* change here for t20 D.P. 21/02/97
+ if(gen_run_number.GT.100000) then
+ write(6,*) "|",file,"|"
+ status = tc_open(file,'r',g_data_source_in_hndl)
+ else
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+ status = evopen(file,'r',g_data_source_in_hndl)
+ endif
+
+ if(status.ne.0) then
+* call cemsg(status,0,err)
+ g_data_source_opened = .false.
+ else
+ g_data_source_opened = .true.
+ endif
+*
+ IF(.not.g_data_source_opened) THEN
+ err= ':could not open "'//file//'"'
+ call G_add_path(here,err)
+ ABORT = .TRUE.
+ ENDIF
+*
+ RETURN
+ END
+
diff --git a/T20/g_proper_shutdown.f b/T20/g_proper_shutdown.f
new file mode 100644
index 0000000..5c49d16
--- /dev/null
+++ b/T20/g_proper_shutdown.f
@@ -0,0 +1,160 @@
+ SUBROUTINE G_proper_shutdown(ABORT,err)
+*--------------------------------------------------------
+*- Prototype C analysis routine
+*-
+*-
+*- Purpose and Methods : Closes files properly, flushes, etc.
+*-
+*- Output: ABORT - success or failure
+*- : err - reason for failure, if any
+*-
+*- Created 20-Nov-1993 Kevin B. Beard for new error standards
+* $Log: g_proper_shutdown.f,v $
+* Revision 1.1 1998/12/01 20:57:53 saw
+* Initial revision
+*
+* Revision 1.11 1996/09/04 14:40:05 saw
+* (JRA) Get filename for "bad" report from a ctp variable
+*
+* Revision 1.10 1995/10/09 18:44:27 cdaq
+* (JRA) Only write pedestal file if appropriate control flag(s) set.
+*
+* Revision 1.9 1995/09/01 15:46:41 cdaq
+* (JRA) Open temp file for pedestal outputs
+*
+* Revision 1.8 1995/07/27 19:03:36 cdaq
+* (SAW) Error return fix up
+*
+* Revision 1.7 1995/05/22 13:29:24 cdaq
+* (JRA) Make a listing of potential detector problems
+*
+* Revision 1.6 1995/04/01 19:42:36 cdaq
+* (SAW) One report file for each of g, h, s, c instead of a single report file
+*
+* Revision 1.5 1994/08/04 03:45:46 cdaq
+* (SAW) Add call to Breuer's hack_shutdown
+*
+* Revision 1.4 1994/06/22 19:49:31 cdaq
+* (SAW) Create report file and append g_report_template to it
+*
+* Revision 1.3 1994/06/14 19:13:20 cdaq
+* (SAW) Move histogram saving to new routine g_dump_histograms
+*
+* Revision 1.2 1994/04/15 20:36:49 cdaq
+* (KBB) Add ntuple handling
+*
+* Revision 1.1 1994/02/04 22:12:15 cdaq
+* Initial revision
+*
+*-
+*- All standards are from "Proposal for Hall C Analysis Software
+*- Vade Mecum, Draft 1.0" by D.F.Geesamn and S.Wood, 7 May 1993
+*-
+*-
+*--------------------------------------------------------
+ IMPLICIT NONE
+ SAVE
+*
+ character*17 here
+ parameter (here= 'G_proper_shutdown')
+*
+ logical ABORT
+ character*(*) err
+*
+ logical bad_report,bad_HMS,bad_T20,bad_COIN,bad_HBK,bad_hack
+ character*132 err_report,err_HMS,err_T20,err_COIN,err_HBK,err_hack
+ integer SPAREID
+ parameter (SPAREID=67)
+*
+ include 'gen_filenames.cmn'
+ include 'gen_routines.dec'
+ include 'gen_run_info.cmn'
+ include 'hms_data_structures.cmn'
+ include 'hms_tracking.cmn'
+ include 't20_data_structures.cmn'
+ include 't20_tracking.cmn'
+*
+ integer ierr
+ character*132 file
+*--------------------------------------------------------
+ bad_report = .TRUE.
+ err_report = 'Failed to open report file'
+
+ if (g_bad_output_filename.ne.' ') then
+ file = g_bad_output_filename
+ call g_sub_run_number(file, gen_run_number)
+
+ open(unit=SPAREID,file=file,status='unknown')
+ else
+ open(unit=SPAREID,file='bad.tmp',status='unknown')
+ endif
+
+c temporary files for pedestal calculation.
+ if (hdebugcalcpeds.ne.0 .or. tdebugcalcpeds.ne.0) then
+ open(unit=39,file='peds.calc',status='unknown')
+ write(39,*) 'pedestals as extracted from analysis',
+ & 'of the physics events'
+ endif
+
+*-chance to flush any statistics, etc.
+ call H_proper_shutdown(SPAREID,bad_HMS,err_HMS)
+*
+ call T_proper_shutdown(SPAREID,bad_T20,err_T20)
+*
+ call C_proper_shutdown(SPAREID,bad_COIN,err_COIN)
+*
+ close(unit=SPAREID)
+*
+ call hack_shutdown(bad_hack,err_hack)
+*
+ call g_dump_histograms(bad_HBK,err_HBK)
+*
+ bad_report = .false.
+ err_report = ' '
+*
+ if(g_report_blockname.ne.' '.and.
+ $ g_report_output_filename.ne.' ') then
+
+ file = g_report_output_filename
+ call g_sub_run_number(file, gen_run_number)
+
+ ierr = threp(g_report_blockname,file)
+ if(ierr.ne.0) then
+ bad_report = .true.
+ err_report = 'threp failed to create report in file '//file
+ endif
+ endif
+*
+ ABORT= bad_HMS .or. bad_T20 .or. bad_COIN .or. bad_HBK
+ $ .or. bad_report
+ err= ' '
+ IF(ABORT) THEN !assemble error message
+ if(bad_report) err = err_report
+ If(bad_HBK) Then
+ call G_prepend(err_HBK//' &',err)
+ elseif (bad_HBK) then
+ err= err_HBK
+ EndIf
+ If(bad_COIN .and. err.NE.' ') Then
+ call G_prepend(err_COIN//' &',err)
+ ElseIf(bad_COIN) Then
+ err= err_COIN
+ EndIf
+ If(bad_T20 .and. err.NE.' ') Then
+ call G_prepend(err_T20//' &',err)
+ ElseIf(bad_T20) Then
+ err= err_T20
+ EndIf
+ If(bad_HMS .and. err.NE.' ') Then
+ call G_prepend(err_HMS//' &',err)
+ ElseIf(bad_HMS) Then
+ err= err_HMS
+ EndIf
+ call G_add_path(here,err)
+ ENDIF
+
+ bad_HBK = .false.
+ err_HBK = ' '
+
+ RETURN
+ END
diff --git a/T20/g_reconstruction.f b/T20/g_reconstruction.f
new file mode 100644
index 0000000..0f112e7
--- /dev/null
+++ b/T20/g_reconstruction.f
@@ -0,0 +1,152 @@
+ SUBROUTINE G_reconstruction(event,ABORT,err)
+*----------------------------------------------------------------------
+*- Prototype hall C reconstruction routine
+*-
+*- Purpose and Methods : Given previously filled data structures,
+*- reconstruction is performed and status returned
+*-
+*- Inputs:
+*- event Pointer to the first word (length) of an event data bank.
+*-
+*- Output: ABORT - success or failure
+*- : err - reason for failure, if any
+*-
+*- Created 20-Oct-1993 Kevin B. Beard
+*- Modified 20-Nov-1993 KBB for new error routines
+* $Log: g_reconstruction.f,v $
+* Revision 1.2 1998/12/01 20:59:06 saw
+* (SAW) Checkin
+*
+*-
+*- All standards are from "Proposal for Hall C Analysis Software
+*- Vade Mecum, Draft 1.0" by D.F.Geesamn and S.Wood, 7 May 1993
+*-
+*--------------------------------------------------------
+ IMPLICIT NONE
+ SAVE
+*
+ integer*4 event(*)
+*
+ character*16 here
+ parameter (here= 'G_reconstruction')
+*
+ logical ABORT
+ character*(*) err
+*
+ INCLUDE 'gen_data_structures.cmn'
+ INCLUDE 'gen_event_info.cmn'
+ INCLUDE 'hack_.cmn'
+*
+ logical FAIL
+ character*1024 why
+*
+ logical update_peds ! TRUE = There is new pedestal data
+*--------------------------------------------------------
+*
+ ABORT= .FALSE.
+ err= ' ' !erase any old errors
+*
+ call G_decode_event_by_banks(event,ABORT,err)
+ IF(ABORT) THEN
+ call G_add_path(here,err)
+ RETURN
+ ENDIF
+*
+*
+* INTERRUPT ANALYSIS FOR PEDESTAL EVENTS.
+*
+*
+ IF(gen_event_type .eq. 4) then !pedestal event
+ call g_analyze_pedestal(ABORT,err)
+ update_peds = .true. !need to recalculate pedestals
+ RETURN
+ ENDIF
+*
+* check to see if pedestals need to be recalculated. Note that this is only
+* done if the event was NOT a scaler event, because of the 'return' at the
+* end of the pedestal handling call.
+*
+ IF(update_peds) then
+ call g_calc_pedestal(ABORT,err)
+ update_peds = .false.
+ ENDIF
+*
+*-Beamline reconstruction
+ IF((gen_event_type.ge.1).and.(gen_event_type.le.15).and.(gen_event_type.ne.4)) then !HMS/POLDER/COIN trig
+ call g_trans_misc(FAIL,why)
+ IF(err.NE.' ' .and. why.NE.' ') THEN
+ call G_append(err,' & '//why)
+ ELSEIF(why.NE.' ') THEN
+ err= why
+ ENDIF
+ ABORT= ABORT .or. FAIL
+ call g_analyze_misc(FAIL,why)
+ IF(err.NE.' ' .and. why.NE.' ') THEN
+ call G_append(err,' & '//why)
+ ELSEIF(why.NE.' ') THEN
+ err= why
+ ENDIF
+ ABORT= ABORT .or. FAIL
+ ENDIF
+*
+*-HMS reconstruction
+ IF((gen_event_type.ne.2).and.(gen_event_type.ne.4)) then !HMS/COIN trig
+ call H_reconstruction(FAIL,why)
+ IF(err.NE.' ' .and. why.NE.' ') THEN
+ call G_append(err,' & '//why)
+ ELSEIF(why.NE.' ') THEN
+ err= why
+ ENDIF
+ ABORT= ABORT .or. FAIL
+ ENDIF
+*
+*-POLDER reconstruction (T20 experiment)
+ IF((gen_event_type.ne.1).and.(gen_event_type.ne.4)) then !Polder/COIN trig
+ call t_reconstruction(FAIL,why)
+ IF(err.NE.' ' .and. why.NE.' ') THEN
+ call G_append(err,' & '//why)
+ ELSEIF(why.NE.' ') THEN
+ err= why
+ ENDIF
+ ABORT= ABORT .or. FAIL
+ ENDIF
+*
+*-Fill histogram(s) with scaler values, for all event types
+ IF(gen_event_type.ne.4) then !physics events
+ call g_scaler(FAIL,why)
+ IF(err.NE.' ' .and. why.NE.' ') THEN
+ call G_append(err,' & '//why)
+ ELSEIF(why.NE.' ') THEN
+ err= why
+ ENDIF
+ ABORT= ABORT .or. FAIL
+ ENDIF
+
+*
+*-COIN reconstruction
+*+++ gen_event_type 1 is an HMS single gen_event_type 2 is POLDER single
+*++ and gen_event_type 4 is a pedestal
+ IF((gen_event_type.ne.1).and.(gen_event_type.ne.2).and.(gen_event_type.ne.4)) then !COIN trig
+ call C_reconstruction(FAIL,why)
+ IF(err.NE.' ' .and. why.NE.' ') THEN
+ call G_append(err,' & '//why)
+ ELSEIF(why.NE.' ') THEN
+ err= why
+ ENDIF
+ ABORT= ABORT .or. FAIL
+ ENDIF
+*
+ IF(ABORT .or. err.NE.' ') call G_add_path(here,err)
+*
+ IF(hack_enable.ne.0) then
+ call hack_anal(FAIL,why)
+ IF(err.NE.' ' .and. why.NE.' ') THEN
+ call G_append(err,' & '//why)
+ ELSEIF(why.NE.' ') THEN
+ err= why
+ ENDIF
+ ABORT= ABORT .or. FAIL
+ ENDIF
+*
+ RETURN
+ END
diff --git a/T20/g_register_variables.f b/T20/g_register_variables.f
new file mode 100644
index 0000000..4a08e53
--- /dev/null
+++ b/T20/g_register_variables.f
@@ -0,0 +1,163 @@
+ subroutine g_register_variables(ABORT,err)
+*----------------------------------------------------------------------
+*
+* CTP variable registration routine
+*
+* Purpose : Register all variables that are to be used by CTP. This
+* includes externally configured parameters/contants, event data that
+* can be a histogram source, and possible test results and scalers.
+*
+* Method: 1. Register variables needed to use CTP to get various
+* filenames. And register other common variables.
+* 2. Call Register routines for HMS, Polder and coincidence.
+*
+* Output: ABORT - success or failure
+* : err - reason for failure, if any
+*
+* Created: 9-Feb-1994 Stephen A. Wood
+* Modified: 17-May-1994 Kevin B. Beard, Hampton U.
+* Modified: 24-May-1994 K.B.Beard
+*
+* $Log: g_register_variables.f,v $
+* Revision 1.2 1997/05/23 19:48:43 saw
+* (t20) Call r_gen_misc
+*
+* Revision 1.1 1997/05/23 19:47:04 saw
+* Initial revision
+*
+*----------------------------------------------------------------------
+ implicit none
+ save
+*
+ character*20 here
+ parameter (here='g_register_variables')
+*
+ logical ABORT
+ character*(*) err
+*
+ include 'gen_routines.dec'
+*
+ include 'gen_run_info.cmn'
+ include 'gen_run_pref.cmn'
+
+ integer ierr,m,i
+ logical FAIL
+ character*1000 why
+ character*30 msg
+*
+ include 'gen_run_info.dte'
+ include 'gen_run_pref.dte'
+*
+*----------------------------------------------------------------------
+*
+* Register the variables that contain the filenames and other
+* configuration variables.
+*
+ ABORT= .FALSE.
+ err = ' '
+*
+ call r_gen_filenames
+
+ call r_gen_run_info
+
+ call r_gen_event_info
+
+ call r_gen_scalers
+
+ call r_gen_run_pref
+
+ call r_gen_data_structures ! Contains both HMS and Polder stuff
+
+ call r_gen_misc !(3/21/97) the t20 hms/polder coin timing/scaler cmn
+
+*HDISPLAY call r_one_ev_io
+*
+* Need to change in parm files
+* hist_filename -> g_ctp_hist_filename
+* g_hist_rebook -> hist_rebook
+* parm_filename -> g_ctp_parm_filename
+* parm_rebook -> g_parm_rebook
+* test_filename -> g_ctp_test_filename
+* test_rebook -> g_test_rebook
+* report_rebook -> g_report_rebook
+* data_source_filename -> g_data_source_filename
+* alias_filename -> g_alias_filename
+* histout_filename -> g_histout_filename
+* decode_map_filename -> g_decode_map_filename
+* g_report_template_filename -> g_report_template_filename
+* g_report_output_filename -> g_report_output_filename
+* g_report_blockname -> g_report_blockname
+* max_events -> g_max_events
+* RUN_number -> gen_run_number
+* RUN_type -> gen_run_type
+* RUN_total_events -> gen_run_total_events
+* RUN_comment -> gen_run_comment
+* RUN_start_date -> gen_run_date_start
+* RUN_stop_date -> gen_run_date_stop
+* RUN_last_date -> gen_run_date_last
+* RUN_start_event -> gen_run_starting_event
+* RUN_stop_event -> gen_run_stopping_event
+* EVENT_id -> gen_event_ID_number
+* EVENT_type -> gen_event_type
+* EVENT_class -> gen_event_class
+* EVENT_sequenceN -> gen_event_sequence_N
+* SHOW_progress -> gen_show_progress
+* SHOW_interval -> gen_show_interval
+* PREF_muddleON -> gen_pref_muddleON
+
+*
+* Leave in these aliases
+*
+ Do m=0,gen_MAX_trigger_types
+ write(msg,'("enable_EvType",i4)') m
+ call squeeze(msg,i)
+ ierr= regparmint(msg(1:i),gen_run_enable(m),0)
+ if(ierr.ne.0) call G_append(err,',"'//msg(1:i)//'"')
+ ABORT= ierr.ne.0 .or. ABORT
+ EndDo
+*
+ Do m=0,gen_MAX_trigger_types
+ write(msg,'("triggered_EvType",i4)') m
+ call squeeze(msg,i)
+ ierr= regparmint(msg(1:i),gen_run_triggered(m),0)
+ if(ierr.ne.0) call G_append(err,',"'//msg(1:i)//'"')
+ ABORT= ierr.ne.0 .or. ABORT
+ EndDo
+*
+*
+ call h_register_variables(FAIL,why) ! HMS
+ IF(err.NE.' ' .and. why.NE.' ') THEN
+ call G_append(err,' & '//why)
+ ELSEIF(why.NE.' ') THEN
+ err= why
+ ENDIF
+ ABORT= ABORT .or. FAIL
+*
+ call t_register_variables(FAIL,why) ! Polder
+ IF(err.NE.' ' .and. why.NE.' ') THEN
+ call G_append(err,' & '//why)
+ ELSEIF(why.NE.' ') THEN
+ err= why
+ ENDIF
+ ABORT= ABORT .or. FAIL
+*
+ call c_register_variables(FAIL,why)
+ IF(err.NE.' ' .and. why.NE.' ') THEN
+ call G_append(err,' & '//why)
+ ELSEIF(why.NE.' ') THEN
+ err= why
+ ENDIF
+ ABORT= ABORT .or. FAIL
+*
+ call hack_register_variables(FAIL,why)
+ IF(err.NE.' ' .and. why.NE.' ') THEN
+ call G_append(err,' & '//why)
+ ELSEIF(why.NE.' ') THEN
+ err= why
+ ENDIF
+ ABORT= ABORT .or. FAIL
+
+ if(ABORT .or. err.NE.' ') call g_add_path(here,err)
+*
+ return
+ end
diff --git a/T20/g_reset_event.f b/T20/g_reset_event.f
new file mode 100644
index 0000000..60fcd18
--- /dev/null
+++ b/T20/g_reset_event.f
@@ -0,0 +1,151 @@
+ SUBROUTINE G_reset_event(ABORT,err)
+*--------------------------------------------------------
+*- Prototype C analysis routine
+*-
+*-
+*- Purpose and Methods : Resets all quantities AT THE BEGINNING OF THE RUN
+*-
+*-
+*- Output: ABORT - success or failure
+*- : err - reason for failure, if any
+*-
+*- Created 29-Oct-1993 Kevin B. Beard
+*- Modified 3-Dec-1993 Kevin B. Beard, Hampton U.
+* $Log: g_reset_event.f,v $
+* Revision 1.1.24.1 2007/09/11 19:14:18 frw
+* fixed FPP related arrays and limits
+*
+* Revision 1.1 1998/12/01 21:00:36 saw
+* Initial revision
+*
+* Revision 1.11 1996/01/22 15:15:01 saw
+* (JRA) Put BPM/Raster data into MISC data structures
+*
+* Revision 1.10 1996/01/16 17:07:55 cdaq
+* (JRA) Zero out ADC threshold readback array
+*
+* Revision 1.9 1995/10/09 18:45:20 cdaq
+* (JRA) Add scaler event reset call. Remove monte carlo stuff.
+*
+* Revision 1.8 1995/07/27 19:39:25 cdaq
+* (SAW) Disable monte carlo (GMC)
+*
+* Revision 1.7 1995/04/01 19:50:55 cdaq
+* (SAW) Add BPM hitlist
+*
+* Revision 1.6 1994/06/22 20:24:23 cdaq
+* (SAW) Zero out uninstrumented channel hit data structure
+*
+* Revision 1.5 1994/04/12 18:42:05 cdaq
+* (SAW) Remove clearing of CRAW event buffer to online compatibility
+*
+* Revision 1.4 1994/02/22 19:47:36 cdaq
+* Change gmc_reset_event to gmc_mc_reset
+*
+* Revision 1.3 1994/02/17 21:49:57 cdaq
+* Simplify error handling to be like g_clear_event
+*
+* Revision 1.2 1994/02/17 21:43:39 cdaq
+* Add call to gmc_reset_event
+*
+* Revision 1.1 1994/02/04 22:13:26 cdaq
+* Initial revision
+*
+*-
+*-
+*- All standards are from "Proposal for Hall C Analysis Software
+*- Vade Mecum, Draft 1.0" by D.F.Geesamn and S.Wood, 7 May 1993
+*-
+*-
+*--------------------------------------------------------
+ IMPLICIT NONE
+ SAVE
+*
+ character*13 here
+ parameter (here= 'G_reset_event')
+*
+ logical ABORT
+ character*(*) err
+*
+ logical HMS_ABORT,T20_ABORT,COIN_ABORT,SCAL_ABORT
+ character*132 HMS_err,T20_err,COIN_err,SCAL_err
+*
+ integer hit,chan,roc,slot
+*
+ INCLUDE 'gen_data_structures.cmn'
+ include 'gen_detectorids.par'
+ INCLUDE 'gen_decode_common.cmn'
+ INCLUDE 'gen_misc.cmn'
+*
+*--------------------------------------------------------
+*
+ err = ' '
+ hms_err = ' '
+ t20_err = ' '
+*
+* Uninstrumented hits
+*
+ do hit=1,GMAX_UNINST_HITS
+ GUNINST_RAW_ROCSLOT(hit) = 0
+ GUNINST_RAW_SUBADD(hit) = 0
+ GUNINST_RAW_DATAWORD(hit) = 0
+ enddo
+ GUNINST_TOT_HITS = 0
+*
+ do hit=1,GMAX_MISC_HITS
+ GMISC_RAW_ADDR1(hit) = 0
+ GMISC_RAW_ADDR2(hit) = 0
+ GMISC_RAW_DATA(hit) = 0
+ enddo
+ GMISC_TOT_HITS = 0
+*
+ do slot=1,gmax_slot_with_adc
+ do roc=1,gmax_roc_with_adc
+ do chan=1,gnum_adc_channels
+ g_threshold_readback(chan,roc,slot)=0
+ enddo
+ enddo
+ enddo
+*
+ do chan = 1, g_maxscal_h
+ g_scaler_h1(chan) = 0
+ g_scaler_h2(chan) = 0
+ g_scaler_h3(chan) = 0
+ g_scaler_h4(chan) = 0
+ g_scaler_h5(chan) = 0
+ g_scaler_h6(chan) = 0
+ g_scaler_h7(chan) = 0
+ g_scaler_h8(chan) = 0
+ g_scaler_h3(chan) = 0
+ g_scaler_h_old1(chan) = 0
+ g_scaler_h_old2(chan) = 0
+ g_scaler_h_old3(chan) = 0
+ g_scaler_h_old4(chan) = 0
+ g_scaler_h_old5(chan) = 0
+ g_scaler_h_old6(chan) = 0
+ g_scaler_h_old7(chan) = 0
+ g_scaler_h_old8(chan) = 0
+ enddo
+*
+ call g_scaler_reset_event(SCAL_ABORT,SCAL_err)
+*
+ call H_reset_event(HMS_ABORT,HMS_err)
+*
+ call T_reset_event(T20_ABORT,T20_err)
+*
+ call C_reset_event(COIN_ABORT,COIN_err)
+*
+ abort = hms_abort.or.t20_abort.or.coin_abort.or.scal_abort
+*
+ IF(ABORT) then
+ err= COIN_err
+ call G_prepend(T20_err,err)
+ call G_prepend(HMS_err,err)
+ call G_prepend(SCAL_err,err)
+ call G_add_path(here,err)
+ else
+ err = ' '
+ endif
+*
+ RETURN
+ END
diff --git a/T20/g_scaler.f b/T20/g_scaler.f
new file mode 100755
index 0000000..b1b6b13
--- /dev/null
+++ b/T20/g_scaler.f
@@ -0,0 +1,81 @@
+ subroutine g_scaler(ABORT,err)
+*
+* Purpose: program to copy scaler values to histogram
+* for software scalers (from tests) needs to have
+* t20.test file to fill the array
+*
+* $Log: g_scaler.f,v $
+* Revision 1.1 1998/12/01 20:57:58 saw
+* Initial revision
+*
+*--------------------------------------------------------
+ IMPLICIT NONE
+ SAVE
+*
+ character*12 here
+ parameter (here= ' ')
+*
+ logical ABORT
+ character*(*) err
+*
+c include 't20_data_structures.cmn'
+c include 't20_tracking.cmn'
+c include 't20_geometry.cmn'
+c include 't20_track_histid.cmn'
+c include 't20_bypass_switches.cmn'
+ include 'gen_misc.cmn'
+
+ integer ichan
+ real*4 rtdc, rinc
+**********************************************************
+c note: currently: the old scaler value is first subtracted from histogram,
+c and then the new scaler value is added; alternately (better) the
+c histogram could be cleared first and then updated with current value
+c
+ do ichan = 1,g_maxscal_h
+ rtdc = float(ichan)
+
+ rinc = g_scaler_h1(ichan)-g_scaler_h_old1(ichan)
+ call hf1(g_scal_his1,rtdc,rinc)
+ g_scaler_h_old1(ichan) = g_scaler_h1(ichan)
+
+ rinc = g_scaler_h2(ichan)-g_scaler_h_old2(ichan)
+ call hf1(g_scal_his2,rtdc,rinc)
+ g_scaler_h_old2(ichan) = g_scaler_h2(ichan)
+
+ rinc = g_scaler_h3(ichan)-g_scaler_h_old3(ichan)
+ call hf1(g_scal_his3,rtdc,rinc)
+ g_scaler_h_old3(ichan) = g_scaler_h3(ichan)
+
+ rinc = g_scaler_h4(ichan)-g_scaler_h_old4(ichan)
+ call hf1(g_scal_his4,rtdc,rinc)
+ g_scaler_h_old4(ichan) = g_scaler_h4(ichan)
+
+ rinc = g_scaler_h5(ichan)-g_scaler_h_old5(ichan)
+ call hf1(g_scal_his5,rtdc,rinc)
+ g_scaler_h_old5(ichan) = g_scaler_h5(ichan)
+
+ rinc = g_scaler_h6(ichan)-g_scaler_h_old6(ichan)
+ call hf1(g_scal_his6,rtdc,rinc)
+ g_scaler_h_old6(ichan) = g_scaler_h6(ichan)
+
+ rinc = g_scaler_h7(ichan)-g_scaler_h_old7(ichan)
+ call hf1(g_scal_his7,rtdc,rinc)
+ g_scaler_h_old7(ichan) = g_scaler_h7(ichan)
+
+ rinc = g_scaler_h8(ichan)-g_scaler_h_old8(ichan)
+ call hf1(g_scal_his8,rtdc,rinc)
+ g_scaler_h_old8(ichan) = g_scaler_h8(ichan)
+
+ enddo
+**********************************************************
+c
+ RETURN
+ END
+*********
+* Local Variables:
+* mode: fortran
+* fortran-if-indent: 2
+* fortran-do-indent: 2
+* End:
+
diff --git a/T20/g_trans_misc.f b/T20/g_trans_misc.f
new file mode 100644
index 0000000..369e441
--- /dev/null
+++ b/T20/g_trans_misc.f
@@ -0,0 +1,62 @@
+ subroutine g_trans_misc(abort,errmsg)
+*-------------------------------------------------------------------
+* author: John Arrington
+* created: 1/16/96
+*
+* Modified for t20 on 1997/0321 by Glenn Collins
+*
+* g_trans_misc fills the gen_decoded_misc common block
+*
+* $Log: g_trans_misc.f,v $
+* Revision 1.1 1998/12/01 21:00:45 saw
+* Initial revision
+*
+* Revision 1.1 1996/01/22 15:14:10 saw
+* Initial revision
+*
+*--------------------------------------------------------
+
+ implicit none
+
+ include 'gen_data_structures.cmn'
+ include 'gen_misc.cmn'
+ logical abort
+ character*1024 errmsg
+ character*20 here
+ parameter (here = 'g_trans_misc')
+
+ integer*4 ihit
+
+ save
+
+ abort = .false.
+ errmsg = ' '
+
+ do ihit = 1 , gmax_misc_hits
+ gmisc_dec_data(ihit,1) = 0 ! Clear HRTDCs
+ gmisc_dec_data(ihit,2) = -1 ! Clear ADCs
+**later gmisc_dec_data(ihit,3) = 0 ! Clear MHTDCs
+ enddo
+C
+C*** Note for clarity, the first number in the gmisc_dec_data array is the
+C "signal" number (addr2), while the second is the LeCroy unit type (addr1)
+C For GMISC events, the module types have the following addr1
+C 1872A HRTDC: 1
+C 1881M ADC: 2
+C 1877 MHTDC: 3
+C
+ do ihit = 1 , gmisc_tot_hits
+ gmisc_dec_data(gmisc_raw_addr2(ihit),gmisc_raw_addr1(ihit)) =
+ $ gmisc_raw_data(ihit)
+C*** Note: Possibly want to fill user filled histograms here in the loop. for mh-tdc
+ enddo
+c
+c c_hrtdc_s22 = gmisc_dec_data(10,1)
+c c_hrtdc_tts1 = gmisc_dec_data(64,1)
+c c_hrtdc_hms = gmisc_dec_data(1,1)
+**later c_mhtdc_s22 = gmisc_dec_data(1,3)
+**later c_mhtdc_tts1 = gmisc_dec_data(2,3)
+**later c_mhtdc_hms = gmisc_dec_data(16,3)
+
+ return
+ end
diff --git a/T20/gen_data_structures.cmn b/T20/gen_data_structures.cmn
new file mode 100644
index 0000000..1acb8e1
--- /dev/null
+++ b/T20/gen_data_structures.cmn
@@ -0,0 +1,333 @@
+*****************begin: gen_data_structures.cmn*************************
+*
+* include file gen_data_structures.cmn
+*
+* Author: D. F. Geesaman 1 September 1993
+*
+* $Log: gen_data_structures.cmn,v $
+* Revision 1.1 1998/12/01 21:03:43 saw
+* Initial revision
+*
+* Revision 1.28 96/09/04 15:45:04 15:45:04 saw (Stephen A. Wood)
+* (JRA) Increase # of possible targets. Add fast raster variables.
+*
+* Revision 1.27 1996/04/30 13:34:25 saw
+* (JRA) Swap index order in GBPM_ADC_PED, GBPM_RAW_ADC
+*
+* Revision 1.26 1996/01/24 16:18:29 saw
+* (JRA) Change raster to use misc arrays. Change some variable names
+* for beam position and target information.
+*
+* Revision 1.25 1995/05/22 18:40:21 cdaq
+* (SAW) Split gen_data_data_structures into gen, hms, sos, and coin parts
+*
+* Revision 1.24 1995/05/11 15:16:26 cdaq
+* (SAW) Add new singles and coin kinematics. Add aerogel structure.
+* (JRA) Change ?SDEDXn vars to arrays.
+*
+* Revision 1.23 1995/04/06 20:16:28 cdaq
+* (SAW) Add ddutta's pre cosy rotation stuff. Add arrays for BPM data
+*
+* Revision 1.22 1995/03/13 18:54:22 cdaq
+* (JRA) ?SCIN_ADC_??? now real, add several element max's for array sizes, add
+* ?NUM_PMT_HIT, ?SNUM_SCIN_HIT, ?SNUM_PMT_HIT
+*
+* Revision 1.21 1995/01/03 13:59:37 cdaq
+* (HGM) Increase # of HMS shower counter blocks to 52
+*
+* Revision 1.20 1994/11/22 18:37:46 cdaq
+* (SPB) Brought SOS commons up to date
+* (SAW) Cleaned up ?DC_NUM_CHAMBERS and ?MAX_NUM_CHAMBERS stuff
+*
+* Revision 1.19 1994/09/19 20:26:44 cdaq
+* (SAW) Remove HDC_HITS_PER_PLANE from HMS_DECODED_DC common
+*
+* Revision 1.18 1994/09/13 21:47:19 cdaq
+* (JRA) Remove HGOOD_START_PLANE
+*
+* Revision 1.17 1994/09/13 19:15:21 cdaq
+* (JRA) Add chisq, shower c. raw adc, number of chambers, shower c slop
+*
+* Revision 1.16 1994/08/15 13:20:47 cdaq
+* (SAW) CEBEAM and CPBEAM are parm not event
+*
+* Revision 1.15 1994/08/15 04:39:29 cdaq
+* (SAW) Change CTPTYPE to parm for some variables
+*
+* Revision 1.14 1994/08/03 19:57:07 cdaq
+* (SAW) Add "CTPTYPE=event" directive for auto generation of CTP reg calls
+*
+* Revision 1.13 1994/06/26 02:32:07 cdaq
+* (JA&SAW) Add rawer data structure for HMS scintillator hits.
+* Increase HMS DC max hits to 3600.
+*
+* Revision 1.12 1994/06/22 15:34:35 cdaq
+* (SAW) Increase max # of hits for hodoscopes to allow for non sparsified data
+*
+* Revision 1.11 1994/06/21 19:22:59 cdaq
+* (SAW) Add hit counters to H_RAW_MISC, S_RAW_MISC and G_RAW_UNINST commons
+*
+* Revision 1.10 1994/06/18 02:49:49 cdaq
+* (SAW) Add code for miscleaneous data and uninstrumented channels
+*
+* Revision 1.9 1994/06/14 03:05:42 cdaq
+* (DFG) Add hms_physics, sos_physics, and coin_physics
+* Add particle mass to hms_spectrometer and sos_spectrometer
+*
+* Revision 1.8 1994/04/14 16:25:43 cdaq
+* (SAW) Fix typo
+*
+* Revision 1.7 1994/04/12 20:42:22 cdaq
+* (SAW) Put column first in shower commons (column == plane)
+* Add a structure for hits on uninstrumented channels
+* Correct "FILLED BY" comment
+*
+* Revision 1.6 1994/04/12 18:38:15 cdaq
+* (DFG) Change dimension of HNTRACK_HITS(HNTRACKS_MAX,HNTRACKHITS_MAX+1)
+* SNTRACK_HITS(SNTRACKS_MAX,SNTRACKHITS_MAX+1)
+* to allow space for number of hits.
+* (SAW) Remove craw common to gen_craw.cmn
+*
+* Revision 1.5 1994/03/24 17:02:03 cdaq
+* DFG change decoded scin to arrington format in both hms and sos
+* change track tests to amatouni format
+*
+* Revision 1.4 1994/02/21 02:54:22 cdaq
+* DFG Separate dimensioning parameters from actual number
+* SNUM_DC_PLANES --> SMAX_NUM_DC_PLANES
+* HNUM_DC_PLANES --> HMAX_NUM_DC_PLANES
+*
+* Revision 1.3 1994/02/09 22:26:10 cdaq
+* (DFG) Add beam and spectrometer geometry banks.
+* Separate raw and decoded data for scin and cal
+* Change XCER_COR_ADC to XCER_PLANE
+*
+* Revision 1.2 1994/02/08 21:19:34 cdaq
+* Geesaman's Jan 5 copy adding HMS_TRACK_TESTS and SOS_TRACK_TESTS
+*
+* Revision 1.1 1994/02/07 17:05:43 cdaq
+* Initial revision
+*
+*
+* BASIC BEAM PARAMETERS
+* None of these are really coincidence things, and some are constant
+* while some are event by event.
+*
+*
+* CTPTYPE=parm
+*
+ REAL*4 GEBEAM ! BEAM ENERGY (GEV)
+ REAL*4 GPBEAM ! BEAM MOMENTUM (GEV/C)
+ REAL*4 G_BEAM_TARGET_S ! s computed from beam and target info
+*
+* CTPTYPE=event
+*
+ REAL*4 GBEAM_X,GBEAM_Y !final beam position from bpm & raster info
+ REAL*4 GBEAM_XP,GBEAM_YP !final beam angles from bpm & raster info
+
+ COMMON/GEN_BEAM/
+ & GEBEAM,
+ & GPBEAM,
+ & G_BEAM_TARGET_S,
+ & GBEAM_X,GBEAM_Y,
+ & GBEAM_XP,GBEAM_YP
+*
+* CTPTYPE=parm
+*
+* BASIC TARGET PARAMETERS
+*
+ integer gmax_targets
+ parameter(gmax_targets=30)
+ integer gtarg_num !position in target ladder
+ REAL*4 gtarg_mass !target mass
+ REAL*4 gtarg_z !target Z
+ REAL*4 gtarg_a !target A
+ REAL*4 gtarg_lrad !radiation length in %
+ REAL*4 gtarg_thick !thickness in g/cm^2
+ REAL*4 gtarg_dens !density in g/cm^3
+ REAL*4 gtarg_theta !angle of target to beam. Note that
+ !90 degrees is target normal to beam!
+
+ COMMON/GEN_TARGET/
+ & gtarg_num,
+ & gtarg_theta,
+ & gtarg_mass(gmax_targets),
+ & gtarg_z(gmax_targets),
+ & gtarg_a(gmax_targets),
+ & gtarg_lrad(gmax_targets),
+ & gtarg_thick(gmax_targets),
+ & gtarg_dens(gmax_targets)
+*
+* CTPTYPE=event
+*
+*
+* Hits from Uninstrumented fastbus channels
+* filled by G_decode_event_by_banks
+*
+ INTEGER GMAX_UNINST_HITS
+ PARAMETER(GMAX_UNINST_HITS=1000)
+ INTEGER*4 GUNINST_TOT_HITS
+ INTEGER*4 GUNINST_RAW_ROCSLOT ! ROC*2**16 + SLOT
+ INTEGER*4 GUNINST_RAW_SUBADD ! Fastbus channel
+ INTEGER*4 GUNINST_RAW_DATAWORD ! Full fastbus dataword
+ COMMON/G_RAW_UNINST/
+ & GUNINST_RAW_ROCSLOT(GMAX_UNINST_HITS),
+ & GUNINST_RAW_SUBADD(GMAX_UNINST_HITS),
+ & GUNINST_RAW_DATAWORD(GMAX_UNINST_HITS),
+ & GUNINST_TOT_HITS
+*
+*
+* Decoded data from ADC's encoding beam position.
+* The raw data comes from the 'hmisc' detector.
+*
+*
+* CTPTYPE=event
+*
+ INTEGER*4 GMAX_NUM_BPMS
+ PARAMETER(GMAX_NUM_BPMS=4) !enough for 2 bpms, 2 readouts each.
+ INTEGER*4 GNUM_BPM_SIGNALS
+ PARAMETER(GNUM_BPM_SIGNALS=4) !1=X+,2=X-,3=Y+,4=Y-
+
+ REAL*4 GBPM_ADC_PED(GNUM_BPM_SIGNALS,GMAX_NUM_BPMS)
+ REAL*4 GBPM_RAW_ADC(GNUM_BPM_SIGNALS,GMAX_NUM_BPMS)
+ REAL*4 GBPM_ADC(GNUM_BPM_SIGNALS,GMAX_NUM_BPMS)
+ REAL*4 GBPM_XPRIME(GMAX_NUM_BPMS)
+ REAL*4 GBPM_YPRIME(GMAX_NUM_BPMS)
+ REAL*4 GBPM_X(GMAX_NUM_BPMS)
+ REAL*4 GBPM_Y(GMAX_NUM_BPMS)
+
+ COMMON/COIN_DEC_BPM/
+ & GBPM_ADC_PED,
+ & GBPM_RAW_ADC,
+ & GBPM_ADC,
+ & GBPM_XPRIME,
+ & GBPM_YPRIME,
+ & GBPM_X,
+ & GBPM_Y
+*
+*
+* Decoded data from ADC's encoding fast/slow raster position (FR/SR).
+* The raw data comes from the 'hmisc' detector.
+* The CBEAM variables are final beam positions from raster and bpm signals.
+*
+*
+* CTPTYPE=event
+*
+ REAL*4 GFRX_ADC_PED,GFRY_ADC_PED
+ REAL*4 GFRX_RAW_ADC,GFRY_RAW_ADC
+ REAL*4 GFRX_ADC,GFRY_ADC
+ REAL*4 GFRX_SYNC,GFRY_SYNC
+ REAL*4 GFRX_SYNC_MEAN,GFRY_SYNC_MEAN
+ REAL*4 GFRX,GFRY
+ REAL*4 GSRX_ADC_PED,GSRY_ADC_PED
+ REAL*4 GSRX_RAW_ADC,GSRY_RAW_ADC
+ REAL*4 GSRX_ADC,GSRY_ADC
+ REAL*4 GSRX_SYNC,GSRY_SYNC
+ REAL*4 GSRX_SYNC_MEAN,GSRY_SYNC_MEAN
+ REAL*4 GSRX,GSRY
+
+ COMMON/COIN_DEC_RASTER/
+ & GFRX_ADC_PED,GFRY_ADC_PED,
+ & GFRX_RAW_ADC,GFRY_RAW_ADC,
+ & GFRX_ADC,GFRY_ADC,
+ & GFRX,GFRY,
+ & GFRX_SYNC,GFRY_SYNC,
+ & GFRX_SYNC_MEAN,GFRY_SYNC_MEAN,
+ & GSRX_ADC_PED,GSRY_ADC_PED,
+ & GSRX_RAW_ADC,GSRY_RAW_ADC,
+ & GSRX_ADC,GSRY_ADC,
+ & GSRX,GSRY,
+ & GSRX_SYNC,GSRY_SYNC,
+ & GSRX_SYNC_MEAN,GSRY_SYNC_MEAN
+
+*
+* Misc. signals read out for hms AND sos events. Mostly
+* beamline information: BPMs, BLMs, Fast Raster, slow raster, ...
+*
+*
+* CTPTYPE=parm
+*
+ INTEGER GMAX_MISC_HITS
+*later? PARAMETER(GMAX_MISC_HITS=500)
+ PARAMETER(GMAX_MISC_HITS=100)
+ INTEGER*4 GNUM_MISC_PLANES
+*later? PARAMETER(GNUM_MISC_PLANES=3)
+ PARAMETER(GNUM_MISC_PLANES=2)
+*
+* CTPTYPE=event
+*
+ INTEGER*4 GMISC_TOT_HITS
+ INTEGER*4 GMISC_RAW_ADDR1 ! "Plane" (1=HRTDC,2=ADC,3=MHTDC)
+ INTEGER*4 GMISC_RAW_ADDR2 ! "Counter" or signal description
+ INTEGER*4 GMISC_RAW_DATA
+ INTEGER*4 GMISC_DEC_DATA
+
+ COMMON/G_RAW_MISC/
+ & GMISC_TOT_HITS,
+ & GMISC_RAW_ADDR1(GMAX_MISC_HITS),
+ & GMISC_RAW_ADDR2(GMAX_MISC_HITS),
+ & GMISC_RAW_DATA(GMAX_MISC_HITS),
+ & GMISC_DEC_DATA(GMAX_MISC_HITS,GNUM_MISC_PLANES)
+*
+*
+* MISC. PEDESTALS
+*
+*
+* CTPTYPE=event
+*
+ integer*4 gmisc_ped_sum2(gmax_misc_hits,gnum_misc_planes)
+ integer*4 gmisc_ped_sum(gmax_misc_hits,gnum_misc_planes)
+ integer*4 gmisc_ped_num(gmax_misc_hits,gnum_misc_planes)
+ integer*4 gmisc_num_ped_changes
+ integer*4 gmisc_changed_tube(gmax_misc_hits)
+ real*4 gmisc_ped_change(gmax_misc_hits)
+ real*4 gmisc_ped(gmax_misc_hits,gnum_misc_planes)
+ real*4 gmisc_ped_rms(gmax_misc_hits,gnum_misc_planes)
+ real*4 gmisc_new_ped(gmax_misc_hits,gnum_misc_planes)
+ real*4 gmisc_new_rms(gmax_misc_hits,gnum_misc_planes)
+ real*4 gmisc_new_adc_threshold(gmax_misc_hits,gnum_misc_planes)
+ real*4 gmisc_dum_adc_threshold(gmax_misc_hits,gnum_misc_planes)
+*
+* CTPTYPE=parm
+*
+ integer*4 gmisc_min_peds
+ integer*4 gusefr, guse_frdefault, guse_frphase
+ real*4 gfry_defcalib, gfry_vperch
+ real*4 gfry_adcmax, gfry_maxsize
+ real*4 gfry_dphase, gfry_synccut
+ real*4 gbeam_yoff
+*
+ common/gen_misc_pedestals/
+ & gmisc_ped,
+ & gmisc_ped_sum2, !sum of squares
+ & gmisc_ped_sum, !sum of peds
+ & gmisc_ped_num, !number of peds
+ & gmisc_min_peds, !# of peds required to override default pedestal
+ & gmisc_ped_rms,
+ & gmisc_new_ped,
+ & gmisc_new_rms,
+ & gmisc_num_ped_changes,!# of peds with 2 sigma changes from param file
+ & gmisc_changed_tube, !list of changed tubes
+ & gmisc_ped_change, !change in pedestal
+ & gmisc_new_adc_threshold,
+ & gmisc_dum_adc_threshold,
+ & gusefr,
+ & guse_frdefault,
+ & guse_frphase,
+ & gfry_defcalib,
+ & gfry_vperch,
+ & gfry_adcmax,
+ & gfry_maxsize,
+ & gfry_dphase,
+ & gfry_synccut,
+ & gbeam_yoff
+*
+*
+*******************end: gen_data_structures.cmn*************************
+* Local Variables:
+* mode: fortran
+* fortran-continuation-string: "&"
+* comment-column: 35
+* End:
+
+
diff --git a/T20/gen_misc.cmn b/T20/gen_misc.cmn
new file mode 100755
index 0000000..b01da49
--- /dev/null
+++ b/T20/gen_misc.cmn
@@ -0,0 +1,59 @@
+* file name: gen_misc.cmn
+*
+* $Log: gen_misc.cmn,v $
+* Revision 1.1 1998/12/01 21:03:34 saw
+* Initial revision
+*
+* purpose: define varibles for
+* - scaler histograms
+* - coincidence TDCs (coin between HMS and Polder)
+*
+*
+*--------------------------------------------------------------------------
+* for display of scalers or test values in histograms
+*
+* CTPTYPE=parm
+ integer*4 g_maxscal_h
+ parameter (g_maxscal_h=50) !max number of scalers per histogram
+ integer*4
+ 2 g_scal_his1, g_scal_his2, g_scal_his3, g_scal_his4,
+ 2 g_scal_his5, g_scal_his6, g_scal_his7, g_scal_his8
+*
+* CTPTYPE=event
+*
+ real*4
+ 1 g_scaler_h1(g_maxscal_h), g_scaler_h_old1(g_maxscal_h),
+ 1 g_scaler_h2(g_maxscal_h), g_scaler_h_old2(g_maxscal_h),
+ 1 g_scaler_h3(g_maxscal_h), g_scaler_h_old3(g_maxscal_h),
+ 1 g_scaler_h4(g_maxscal_h), g_scaler_h_old4(g_maxscal_h),
+ 1 g_scaler_h5(g_maxscal_h), g_scaler_h_old5(g_maxscal_h),
+ 1 g_scaler_h6(g_maxscal_h), g_scaler_h_old6(g_maxscal_h),
+ 1 g_scaler_h7(g_maxscal_h), g_scaler_h_old7(g_maxscal_h),
+ 1 g_scaler_h8(g_maxscal_h), g_scaler_h_old8(g_maxscal_h)
+
+ common /g_scaler_hist/
+ 1 g_scaler_h1, g_scaler_h_old1,
+ 1 g_scaler_h2, g_scaler_h_old2,
+ 1 g_scaler_h3, g_scaler_h_old3,
+ 1 g_scaler_h4, g_scaler_h_old4,
+ 1 g_scaler_h5, g_scaler_h_old5,
+ 1 g_scaler_h6, g_scaler_h_old6,
+ 1 g_scaler_h7, g_scaler_h_old7,
+ 1 g_scaler_h8, g_scaler_h_old8,
+ 2 g_scal_his1, g_scal_his2, g_scal_his3, g_scal_his4,
+ 2 g_scal_his5, g_scal_his6, g_scal_his7, g_scal_his8
+
+*--------------------------------------------------------------------------
+*
+* CTPTYPE=event
+*
+ integer*4
+ 1 c_hrtdc_s22,
+ 3 c_hrtdc_hms,
+ 6 c_mhtdc_hms
+*
+ common/gcoin_misc/
+ 1 c_hrtdc_s22,
+ 3 c_hrtdc_hms,
+ 6 c_mhtdc_hms
+*
diff --git a/T20/gen_run_info.cmn b/T20/gen_run_info.cmn
new file mode 100644
index 0000000..f165aca
--- /dev/null
+++ b/T20/gen_run_info.cmn
@@ -0,0 +1,93 @@
+**************************begin: gen_run_info.cmn ***********************
+*-
+*- Created 22-Apr-1994 Kevin B. Beard, Hampton Univ.
+* $Log: gen_run_info.cmn,v $
+* Revision 1.2 1998/12/01 21:04:07 saw
+* (SAW) Checkin
+*
+* Revision 1.1 1997/05/01 13:41:24 saw
+* Initial revision
+*
+* Revision 1.7 1996/09/04 15:46:13 saw
+* (JRA) Add prescale factors and some a debugging flag
+*
+* Revision 1.6 1996/01/17 15:57:28 cdaq
+* (JRA) Add some short equivalences for CTP convenience
+*
+* Revision 1.5 1995/03/13 19:01:03 cdaq
+* (SAW) Change gen_run_enable from logical to integer
+*
+* Revision 1.4 1995/01/31 15:52:04 cdaq
+* (SAW) Add gen_run_hist_dump_interval for in run hist dumping
+*
+* Revision 1.3 1994/10/20 14:19:12 cdaq
+* (SAW) Add accumulators for analyzed event counts ("May process")
+*
+* Revision 1.2 1994/08/03 20:11:50 cdaq
+* (SAW) Add "CTPTYPE=parm" directive for auto generation of CTP reg calls
+*
+* Revision 1.1 1994/05/27 15:12:47 cdaq
+* Initial revision
+*
+*........................................................................
+*- Misc. info. about a run
+*
+* CTPTYPE=parm
+*
+ INTEGER gen_run_number,gen_run_type
+ INTEGER gen_run_total_events !reported by CODA
+ INTEGER gen_run_UTC_start,gen_run_UTC_stop,gen_run_UTC_last
+ CHARACTER*80 gen_run_date_start,gen_run_date_stop
+ CHARACTER*80 gen_run_date_last
+ CHARACTER*800 gen_run_comment
+*
+ COMMON /gen_run_info/ gen_run_number,gen_run_type,
+ & gen_run_total_events,gen_run_UTC_start,gen_run_UTC_stop,
+ & gen_run_UTC_last,gen_run_date_start,gen_run_date_stop,
+ & gen_run_date_last,gen_run_comment
+*
+*
+* CTPTYPE=parm
+*
+ INTEGER gen_MAX_trigger_types
+ PARAMETER (gen_MAX_trigger_types= 15)
+ INTEGER gen_run_enable(0:gen_MAX_trigger_types) !1=process, 0=ignore
+ INTEGER gen_run_triggered(0:gen_MAX_trigger_types) !triggers found
+ INTEGER gen_run_analyzed(0:gen_MAX_trigger_types) ! NOT USED ANYWHERE
+ INTEGER gen_run_hist_dump_interval
+ INTEGER gen_run_starting_event,gen_run_stopping_event
+*
+ COMMON /gen_run_cntrl/ gen_run_starting_event,
+ & gen_run_stopping_event,
+ & gen_run_enable,
+ & gen_run_triggered,
+ & gen_run_analyzed,
+ & gen_run_hist_dump_interval
+*
+*-shorter names for command line input
+ integer grun,gstart,gstop,gdump,gtrig1,gtrig2,gtrig3,gtrig4,gtrig5 ! aliases
+ equivalence (grun,gen_run_number)
+ equivalence (gstart,gen_run_starting_event)
+ equivalence (gstop,gen_run_stopping_event)
+ equivalence (gdump,gen_run_hist_dump_interval)
+ equivalence (gtrig1,gen_run_enable(0))
+ equivalence (gtrig2,gen_run_enable(1))
+ equivalence (gtrig3,gen_run_enable(2))
+ equivalence (gtrig4,gen_run_enable(3))
+ equivalence (gtrig5,gen_run_enable(4))
+
+*
+* CTPTYPE=parm
+*
+ real*4 gps1,gps2,gps3,gps4,gps5 !prescale factors (1-hms,2-sos,3-coin)
+* ! 4-ped,5-ed
+ common/gen_prescales/ gps1,gps2,gps3,gps4,gps5
+
+*
+* CTPTYPE=parm
+*
+ integer gdebugdumpepics
+*
+ common/gen_debuggingstuff/ gdebugdumpepics
+
+****************************end: gen_run_info.cmn ***********************
diff --git a/T20/h_ntuple_init.f b/T20/h_ntuple_init.f
new file mode 100644
index 0000000..774887a
--- /dev/null
+++ b/T20/h_ntuple_init.f
@@ -0,0 +1,239 @@
+ subroutine h_Ntuple_init(ABORT,err)
+*----------------------------------------------------------------------
+*
+* Creates an HMS Ntuple
+*
+* Purpose : Books an HMS Ntuple; defines structure of it
+*
+* Output: ABORT - success or failure
+* : err - reason for failure, if any
+*
+* Created: 8-Apr-1994 K.B.Beard, Hampton Univ.
+* $Log: h_ntuple_init.f,v $
+* Revision 1.1 1998/12/01 20:58:08 saw
+* Initial revision
+*
+* Revision 1.9 1996/09/04 14:42:44 saw
+* (JRA) Some changes to ntuple contents
+*
+* Revision 1.8 1996/01/16 17:03:52 cdaq
+* (JRA) Modify ntuple contents
+*
+* Revision 1.7 1995/09/01 13:38:05 cdaq
+* (JRA) Add Cerenkov photoelectron count to ntuple
+*
+* Revision 1.6 1995/07/27 19:00:17 cdaq
+* (SAW) Relocate data statements for f2c compatibility
+*
+* Revision 1.5 1995/05/22 20:50:46 cdaq
+* (SAW) Split gen_data_data_structures into gen, hms, sos, and coin parts"
+*
+* Revision 1.4 1995/05/11 17:17:38 cdaq
+* (SAW) Allow %d for run number in filenames
+*
+* Revision 1.3 1995/01/27 20:09:59 cdaq
+* (JRA) Add Gas cerenkov to ntuple
+*
+* Revision 1.2 1994/06/17 02:34:12 cdaq
+* (KBB) Upgrade
+*
+* Revision 1.1 1994/04/12 16:15:02 cdaq
+* Initial revision
+*
+*
+*----------------------------------------------------------------------
+ implicit none
+ save
+*
+ character*13 here
+ parameter (here='h_Ntuple_init')
+*
+ logical ABORT
+ character*(*) err
+*
+ INCLUDE 'h_ntuple.cmn'
+ INCLUDE 'gen_routines.dec'
+ include 'hms_data_structures.cmn'
+ include 'gen_run_info.cmn'
+*
+ character*80 default_name
+ parameter (default_name= 'HMSntuple')
+ integer default_bank,default_recL
+ parameter (default_bank= 8000) !4 bytes/word
+ parameter (default_recL= 1024) !record length
+ character*80 title,file
+ character*80 directory,name
+ character*1000 pat,msg
+ integer status,size,io,id,bank,recL,iv(10),m
+ real rv(10)
+*
+ logical HEXIST !CERNLIB function
+*
+ INCLUDE 'h_ntuple.dte'
+*
+*--------------------------------------------------------
+ err= ' '
+ ABORT = .FALSE.
+*
+ IF(h_Ntuple_exists) THEN
+ call h_Ntuple_shutdown(ABORT,err)
+ If(ABORT) Then
+ call G_add_path(here,err)
+ RETURN
+ EndIf
+ ENDIF
+*
+ call NO_nulls(h_Ntuple_file) !replace null characters with blanks
+*
+*-if name blank, just forget it
+ IF(h_Ntuple_file.EQ.' ') RETURN !do nothing
+*
+*- get any free IO channel
+*
+ call g_IO_control(io,'ANY',ABORT,err)
+ h_Ntuple_exists= .NOT.ABORT
+ IF(ABORT) THEN
+ call G_add_path(here,err)
+ RETURN
+ ENDIF
+ h_Ntuple_IOchannel= io
+*
+ h_Ntuple_ID= default_h_Ntuple_ID
+ id= h_Ntuple_ID
+*
+ ABORT= HEXIST(id)
+ IF(ABORT) THEN
+ call g_IO_control(h_Ntuple_IOchannel,'FREE',ABORT,err)
+ call G_build_note(':HBOOK id#$ already in use',
+ & '$',id,' ',rv,' ',err)
+ call G_add_path(here,err)
+ RETURN
+ ENDIF
+*
+ CALL HCDIR(directory,'R') !CERNLIB read current directory
+*
+ h_Ntuple_name= default_name
+*
+ id= h_Ntuple_ID
+ name= h_Ntuple_name
+
+ file= h_Ntuple_file
+ call g_sub_run_number(file,gen_run_number)
+
+ recL= default_recL
+ io= h_Ntuple_IOchannel
+*
+*-open New *.rzdat file-
+ call HROPEN(io,name,file,'N',recL,status) !CERNLIB
+* !directory set to "//TUPLE"
+ io= h_Ntuple_IOchannel
+ ABORT= status.NE.0
+ IF(ABORT) THEN
+ call g_IO_control(h_Ntuple_IOchannel,'FREE',ABORT,err)
+ iv(1)= status
+ iv(2)= io
+ pat= ':HROPEN error#$ opening IO#$ "'//file//'"'
+ call G_build_note(pat,'$',iv,' ',rv,' ',err)
+ call G_add_path(here,err)
+ RETURN
+ ENDIF
+ h_Ntuple_file= file
+*
+ m= 0
+ m= m+1
+ h_Ntuple_tag(m)= 'hcer_npe' ! cerenkov photoelectron spectrum
+ m= m+1
+ h_Ntuple_tag(m)= 'hsp' ! Lab momentum of chosen track in GeV/c
+ m= m+1
+ h_Ntuple_tag(m)= 'hse' ! Lab total energy of chosen track in GeV
+ m= m+1
+ h_Ntuple_tag(m)= 'charge' ! charge
+ m= m+1
+ h_Ntuple_tag(m)= 'hsdelta' ! Spectrometer delta of chosen track
+ m= m+1
+ h_Ntuple_tag(m)= 'hstheta' ! Lab Scattering angle in radians
+ m= m+1
+ h_Ntuple_tag(m)= 'hsphi' ! Lab Azymuthal angle in radians
+ m= m+1
+ h_Ntuple_tag(m)= 'w' ! Invariant Mass of remaing hadronic system
+ m= m+1
+ h_Ntuple_tag(m)= 'hszbeam'! Lab Z coordinate of intersection of beam
+ ! track with spectrometer ray
+ m= m+1
+ h_Ntuple_tag(m)= 'hsdedx1' ! DEDX of chosen track in 1st scin plane
+ m= m+1
+ h_Ntuple_tag(m)= 'hsbeta' ! BETA of chosen track
+ m= m+1
+ h_Ntuple_tag(m)= 'hsshtrk' ! 'HSTRACK_ET' ! Total shower energy of chosen track
+ m= m+1
+ h_Ntuple_tag(m)= 'hsprtrk' !'HSTRACK_PRESHOWER_E' ! preshower of chosen track
+ m= m+1
+ h_Ntuple_tag(m)= 'hsxfp' ! X focal plane position
+ m= m+1
+ h_Ntuple_tag(m)= 'hsyfp'
+ m= m+1
+ h_Ntuple_tag(m)= 'hsxpfp'
+ m= m+1
+ h_Ntuple_tag(m)= 'hsypfp'
+ m= m+1
+ h_Ntuple_tag(m)= 'hsytar'
+ m= m+1
+ h_Ntuple_tag(m)= 'hsxptar'
+ m= m+1
+ h_Ntuple_tag(m)= 'hsyptar'
+ m= m+1
+ h_Ntuple_tag(m)= 'hstart'
+ m= m+1
+ h_Ntuple_tag(m)= 'rt_hit'
+ m= m+1
+ h_Ntuple_tag(m)= 'eventID'
+
+* Experiment dependent entries start here.
+
+
+* Open ntuple
+*
+ h_Ntuple_size= m !total size
+*
+ title= h_Ntuple_title
+ IF(title.EQ.' ') THEN
+ msg= name//' '//h_Ntuple_file
+ call only_one_blank(msg)
+ title= msg
+ h_Ntuple_title= title
+ ENDIF
+*
+ id= h_Ntuple_ID
+ io= h_Ntuple_IOchannel
+ name= h_Ntuple_name
+ title= h_Ntuple_title
+ size= h_Ntuple_size
+ file= h_Ntuple_file
+ bank= default_bank
+ call HBOOKN(id,title,size,name,bank,h_Ntuple_tag) !create Ntuple
+*
+ call HCDIR(h_Ntuple_directory,'R') !record Ntuple directory
+*
+ CALL HCDIR(directory,' ') !reset CERNLIB directory
+*
+ h_Ntuple_exists= HEXIST(h_Ntuple_ID)
+ ABORT= .NOT.h_Ntuple_exists
+*
+ iv(1)= id
+ iv(2)= io
+ pat= 'Ntuple id#$ [' // h_Ntuple_directory // '/]' //
+ & name // ' IO#$ "' // file // '"'
+ call G_build_note(pat,'$',iv,' ',rv,' ',msg)
+ call sub_string(msg,' /]','/]')
+*
+ IF(ABORT) THEN
+ err= ':unable to create '//msg
+ call G_add_path(here,err)
+c ELSE
+c pat= ':created '//msg
+c call G_add_path(here,pat)
+c call G_log_message('INFO: '//pat)
+ ENDIF
+*
+ RETURN
+ END
diff --git a/T20/h_ntuple_keep.f b/T20/h_ntuple_keep.f
new file mode 100644
index 0000000..1e14a4b
--- /dev/null
+++ b/T20/h_ntuple_keep.f
@@ -0,0 +1,136 @@
+ subroutine h_Ntuple_keep(ABORT,err)
+*----------------------------------------------------------------------
+*
+* Purpose : Add entry to the HMS Ntuple
+*
+* Output: ABORT - success or failure
+* : err - reason for failure, if any
+*
+* Created: 11-Apr-1994 K.B.Beard, Hampton U.
+* $Log: h_ntuple_keep.f,v $
+* Revision 1.1 1998/12/01 20:58:13 saw
+* Initial revision
+*
+* Revision 1.8 1996/09/04 14:43:17 saw
+* (JRA) Modify ntuple contents
+*
+* Revision 1.7 1996/01/16 17:01:55 cdaq
+* (JRA) Modify ntuple contents
+*
+* Revision 1.6 1995/09/01 13:38:28 cdaq
+* (JRA) Add Cerenkov photoelectron count to ntuple
+*
+* Revision 1.5 1995/05/22 20:50:46 cdaq
+* (SAW) Split gen_data_data_structures into gen, hms, sos, and coin parts"
+*
+* Revision 1.4 1995/05/11 17:37:13 cdaq
+* (SAW) Change HSDEDXn vars to an array.
+*
+* Revision 1.3 1995/01/27 20:10:27 cdaq
+* (JRA) Add Gas cerenkov to ntuple
+*
+* Revision 1.2 1994/06/17 02:44:38 cdaq
+* (KBB) Upgrade
+*
+* Revision 1.1 1994/04/12 16:15:21 cdaq
+* Initial revision
+*
+*
+*----------------------------------------------------------------------
+ implicit none
+ save
+*
+ character*13 here
+ parameter (here='h_Ntuple_keep')
+*
+ logical ABORT
+ character*(*) err
+*
+ INCLUDE 'h_ntuple.cmn'
+ INCLUDE 'hms_data_structures.cmn'
+ INCLUDE 'gen_event_info.cmn'
+ INCLUDE 'hms_tracking.cmn'
+ INCLUDE 'hms_physics_sing.cmn'
+ INCLUDE 'hms_scin_tof.cmn'
+ INCLUDE 'gen_scalers.cmn'
+ include 'hms_track_histid.cmn' !temp junk.
+*
+ logical HEXIST !CERNLIB function
+*
+ integer m
+
+ real proton_mass
+ parameter ( proton_mass = 0.93827247 ) ! [GeV/c^2]
+*
+*--------------------------------------------------------
+ err= ' '
+ ABORT = .FALSE.
+*
+ IF(.NOT.h_Ntuple_exists) RETURN !nothing to do
+*
+************************************************
+ m= 0
+*
+ m= m+1
+ h_Ntuple_contents(m)= HCER_NPE_SUM ! cerenkov photoelectron spectrum
+ m= m+1
+ h_Ntuple_contents(m)= HSP ! Lab momentum of chosen track in GeV/c
+ m= m+1
+ h_Ntuple_contents(m)= HSENERGY ! Lab total energy of chosen track in GeV
+ m= m+1
+ h_Ntuple_contents(m)= gbcm1_charge ! Charge of last scaler event
+ m= m+1
+ h_Ntuple_contents(m)= HSDELTA ! Spectrometer delta of chosen track
+ m= m+1
+ h_Ntuple_contents(m)= HSTHETA ! Lab Scattering angle in radians
+ m= m+1
+ h_Ntuple_contents(m)= HSPHI ! Lab Azymuthal angle in radians
+ m= m+1
+ h_Ntuple_contents(m)= HINVMASS ! Invariant Mass of remaing hadronic system
+ m= m+1
+ h_Ntuple_contents(m)= HSZBEAM! Lab Z coordinate of intersection of beam
+c ! track with spectrometer ray
+ m= m+1
+ h_Ntuple_contents(m)= HSDEDX(1) ! DEDX of chosen track in 1st scin plane
+ m= m+1
+ h_Ntuple_contents(m)= HSBETA ! BETA of chosen track
+ m= m+1
+ h_Ntuple_contents(m)= HSTRACK_ET ! Total shower energy of chosen track
+ m= m+1
+ h_Ntuple_contents(m)= HSTRACK_PRESHOWER_E ! preshower of chosen track
+ m= m+1
+ h_Ntuple_contents(m)= HSX_FP ! X focal plane position
+ m= m+1
+ h_Ntuple_contents(m)= HSY_FP
+ m= m+1
+ h_Ntuple_contents(m)= HSXP_FP
+ m= m+1
+ h_Ntuple_contents(m)= HSYP_FP
+ m= m+1
+ h_Ntuple_contents(m)= HSY_TAR
+ m= m+1
+ h_Ntuple_contents(m)= HSXP_TAR
+ m= m+1
+ h_Ntuple_contents(m)= HSYP_TAR
+ m= m+1
+ h_Ntuple_contents(m)= hstart_time
+ m= m+1
+ h_Ntuple_contents(m)= HDC_RAW_TOT_HITS
+ m= m+1
+ h_Ntuple_contents(m)= float(gen_event_ID_number)
+
+* Experiment dependent entries start here.
+
+
+* Fill ntuple for this event
+ ABORT= .NOT.HEXIST(h_Ntuple_ID)
+ IF(ABORT) THEN
+ call G_build_note(':Ntuple ID#$ does not exist',
+ & '$',h_Ntuple_ID,' ',0.,' ',err)
+ call G_add_path(here,err)
+ ELSE
+ call HFN(h_Ntuple_ID,h_Ntuple_contents)
+ ENDIF
+*
+ RETURN
+ END
diff --git a/T20/t20_bypass_switches.cmn b/T20/t20_bypass_switches.cmn
new file mode 100644
index 0000000..d9a9339
--- /dev/null
+++ b/T20/t20_bypass_switches.cmn
@@ -0,0 +1,19 @@
+* sos_bypass_switches.cmn
+*
+* common blocks of CTP switches to bypass reconstruction code
+* elements.
+*
+* Created: S.A. Wood 22 Jan 1997
+* $Log: t20_bypass_switches.cmn,v $
+* Revision 1.1 1998/12/01 21:02:48 saw
+* Initial revision
+*
+*
+* CTPTYPE=parm
+*
+ integer*4 tbypass_test
+ integer*4 tbypass_polder
+*
+ common/t20_bypass_switches/
+ $ tbypass_test,
+ $ tbypass_polder
diff --git a/T20/t20_data_structures.cmn b/T20/t20_data_structures.cmn
new file mode 100644
index 0000000..e9950b8
--- /dev/null
+++ b/T20/t20_data_structures.cmn
@@ -0,0 +1,177 @@
+********************* begin: t20_data_structures.cmn*****************************
+*
+* include file t20_data_structures
+*
+* Author: Glenn S. Collins 1/16/97
+*
+* $Log: t20_data_structures.cmn,v $
+* Revision 1.2 1997/05/20 19:32:50 saw
+* (many) Updates
+*
+* Revision 1.1 1997/05/20 19:31:25 saw
+* Initial revision
+*
+******************************************************************************
+*
+* CTPTYPE=parm
+*
+* TTHETA_LAB T20 LAB ANGLE THETA (RADIANS)
+* TPHI_LAB T20 LAB ANGLE PHI
+* TPCENTRAL T20 CENTRAL MOMENUTM (GEV)
+* TBFIELD T20 B FIELD INCLUDING SIGN
+*
+ REAL*4 TTHETA_LAB ! T20 LAB ANGLE THETA (RADIANS)
+ REAL*4 TPHI_LAB ! T20 LAB ANGLE PHI
+ REAL*4 TPCENTRAL ! T20 CENTRAL MOMENUTM (GEV)
+ REAL*4 TBFIELD ! T20 B FIELD INCLUDING SIGN
+ REAL*4 TPARTMASS ! EXPECTED MASS OF DETECTED PARTICLE IN T20
+*
+ COMMON/T20_SPECTROMETER/
+ & TTHETA_LAB,
+ & TPHI_LAB,
+ & TPCENTRAL,
+ & TBFIELD,
+ & TPARTMASS
+**********************************************************************************
+**
+* POLDER DECODED RAW DATA FROM THE FASTBUS DAQ SYSTEM
+**
+**********************************************************************************
+*
+* RAW MWPC DATA FILLED BY g_decode_event_by_banks
+*
+* POLDER MWPC HITS
+* EACH CHAMBER HIT (TDC VALUE) HAS A
+* PLANE NUMBER
+* WIRE NUMBER
+* TDC VALUE
+*
+* THE TOTAL NUMBER OF HITS IS GIVEN IN TMWPC_RAW_TOT_HITS
+*
+* CTPTYPE=parm
+
+ INTEGER*4 TMAX_MWPC_HITS ! MAX NUMBER OF MWPC HITS
+ INTEGER*4 TMAX_NUM_MWPC_PLANES ! MAX NUMBER OF MWPC PLANES
+ INTEGER*4 TMAX_NUM_CHAMBERS ! MAX NUMBER OF POLDER MWPC CHANBERS
+ PARAMETER(TMAX_MWPC_HITS=3600)
+ PARAMETER(TMAX_NUM_MWPC_PLANES=9)
+ PARAMETER(TMAX_NUM_CHAMBERS=3)
+
+* CTPTYPE=event
+
+ INTEGER*4 TMWPC_RAW_PLANE_NUM
+ INTEGER*4 TMWPC_RAW_WIRE_NUM
+ INTEGER*4 TMWPC_RAW_TDC
+ INTEGER*4 TMWPC_RAW_TOT_HITS
+
+ COMMON/POLDER_RAW_MWPC/
+ & TMWPC_RAW_PLANE_NUM(TMAX_MWPC_HITS),
+ & TMWPC_RAW_WIRE_NUM(TMAX_MWPC_HITS),
+ & TMWPC_RAW_TDC(TMAX_MWPC_HITS),
+ & TMWPC_RAW_TOT_HITS
+*
+* NOTE: MWPC3 IS ACCOUNTED FOR HERE AND IN THE MAP: IT IS DISTINGUISHED BY
+* BY HAVING PLANE NUMBERS BETWEEN 7 AND 9. ITS "WIRE NUMBERS" ARE
+* EITHER 1 (RIGHT READOUT) OR 2 (LEFT READOUT). TMWPC3_RAW_TDC HAS
+* ITS STANDARD MEANING.
+*
+**********************************************************************************
+*
+* RAW MWPC3 DATA
+*
+* CTPTYPE=parm
+*
+* INTEGER*4 TMAX_DELAY_MWPC ! MAX NUMBER OF HITS ON MWPC 3's DELAY LINES
+* PARAMETER(TMAX_DELAY_MWPC=96) ! PER EVENT
+*
+* CTPTYPE=event
+*
+* INTEGER*4 T_MWPC3_TOT_HITS ! TOTAL NUMBER OF HITS IN MWPC3
+* INTEGER*4 T_MWPC3_PLANE_NUM(TMAX_DELAY_MWPC) ! MWPC3 PLANE NUMBER (7-9)
+* INTEGER*4 T_MWPC3_DIRECTION(TMAX_DELAY_MWPC) ! READ OUT DIRECTION - RIGHT OR LEFT
+* INTEGER*4 T_MWPC3_RAW_DATA(TMAX_DELAY_MWPC) ! RAW DATA
+*
+* COMMON/T20_MWPC3/
+* & T_MWPC3_TOT_HITS,
+* & T_MWPC3_PLANE_NUM,
+* & T_MWPC3_DIRECTION,
+* & T_MWPC3_RAW_DAT
+*
+***************************************************************************************
+*
+* RAW POLDER HODOSCOPE HIT DATA FILLED BY g_decode_by_banks.f
+*
+* EACH HODOSCOPE HIT IS DESCRIBED BY:
+* HODOSCOPE PLANE NUMBER
+* HODOSCOPE BAR NUMBER
+* HODOSCOPE TDC VALUE (LECROY 1877 MULTIHIT IN COMMON STOP MODE
+* FROM ONE END OF THE HODOSCOPE BAR.
+* THE TOTAL NUMBER OF HITS IN AN EVENT IS GIVIEN BY THODO_TOT_HITS
+*
+* CTPTYPE=parm
+*
+ INTEGER*4 TMAX_HODO_HITS ! MAX TOT NUMBER OF HODO HITS
+ PARAMETER(TMAX_HODO_HITS=500)
+ INTEGER*4 TNUM_HODO_PLANES ! TOTAL NUMBER OF HODO PLANES
+ PARAMETER(TNUM_HODO_PLANES=4)
+*
+* CTPTYPE=event
+*
+ INTEGER*4 THODO_PLANE_NUM ! HIT LIST OF HODOSCOPE PLANE NUMBER
+ INTEGER*4 THODO_BAR_NUM ! HIT LIST OF HODOSCOPE BAR NUMBERS (IN A GIVEN PLANE)
+ INTEGER*4 THODO_TDC_VAL ! HIT LIST OF HODOSCOPE TDC VALUES (RAW)
+ INTEGER*4 THODO_TOT_HITS
+*
+ COMMON/POLDER_RAW_HODO/
+ & THODO_PLANE_NUM(TMAX_HODO_HITS),
+ & THODO_BAR_NUM(TMAX_HODO_HITS),
+ & THODO_TDC_VAL(TMAX_HODO_HITS),
+ & THODO_TOT_HITS
+*
+*****************************************************************************************
+*
+* RAW POLDER "MISCELANEOUS" DETECTOR DATA FILLED BY g_decode_by_banks.f
+*
+* CTPTYPE=parm
+*
+ INTEGER*4 TMAX_MISC_HITS
+ PARAMETER(TMAX_MISC_HITS=500)
+ INTEGER*4 TNUM_MISC_ADDR1
+ PARAMETER(TNUM_MISC_ADDR1=3)
+*
+* CTPTYPE=event
+*
+ INTEGER*4 TMISC_TOT_HITS
+ INTEGER*4 TMISC_RAW_ADDR1 !
+ INTEGER*4 TMISC_RAW_ADDR2 ! "Counter"
+ INTEGER*4 TMISC_RAW_DATA ! Raw Data
+
+ COMMON/T_RAW_MISC/
+ & TMISC_RAW_ADDR1(TMAX_MISC_HITS),
+ & TMISC_RAW_ADDR2(TMAX_MISC_HITS),
+ & TMISC_RAW_DATA(TMAX_MISC_HITS),
+ & TMISC_TOT_HITS
+*
+*****************************************************************************************
+*
+* RAW POLDER Test detector Straw Chamber hit data
+* FILLED BY g_decode_event_by_banks
+* EACH Straw detector HIT IS DESCRIBED BY:
+* STRAW DETECTOR PLANE NUMBER
+* STRAW DETECTOR WIRE GROUPNUMBER
+* STRAW DETECTOR TDC VALUE (LECROY 1877 MULTIHIT IN COMMON STOP MODE)
+* THE TOTAL NUMBER OF HITS IS GIVIEN BY TTST_RAW_TOT_HITS
+
+ INTEGER*4 TTSTMAX_STRAW_HITS
+ PARAMETER(TTSTMAX_STRAW_HITS=500)
+ INTEGER*4 TTST_RAW_PLANE_NUM
+ INTEGER*4 TTST_RAW_GROUP_NUM
+ INTEGER*4 TTST_RAW_TDC
+ INTEGER*4 TTST_RAW_TOT_HITS
+ COMMON/TEST_RAW_STRAW/
+ & TTST_RAW_PLANE_NUM(TTSTMAX_STRAW_HITS),
+ & TTST_RAW_GROUP_NUM(TTSTMAX_STRAW_HITS),
+ & TTST_RAW_TDC(TTSTMAX_STRAW_HITS),
+ & TTST_RAW_TOT_HITS
+*
+
diff --git a/T20/t20_filenames.cmn b/T20/t20_filenames.cmn
new file mode 100644
index 0000000..5ba0cbf
--- /dev/null
+++ b/T20/t20_filenames.cmn
@@ -0,0 +1,25 @@
+******************* begin: t20_filenames.cmn ***********************
+*
+*-Common block with filenames
+* $Log: t20_filenames.cmn,v $
+* Revision 1.1 1998/12/01 21:04:18 saw
+* Initial revision
+*
+*
+* CTPTYPE=parm
+*
+ character*80 t_recon_coeff_filename
+ character*80 t_report_template_filename ! CTP file with sos report
+ character*80 t_report_blockname ! Name of block for sos report template
+ character*80 t_report_output_filename
+ character*80 t_threshold_output_filename
+ character*80 t_pedestal_output_filename
+*
+ common /t20_filenames/
+ $ t_recon_coeff_filename,
+ $ t_report_template_filename,
+ $ t_report_blockname,
+ $ t_report_output_filename,
+ $ t_threshold_output_filename,
+ $ t_pedestal_output_filename
+*
diff --git a/T20/t20_geometry.cmn b/T20/t20_geometry.cmn
new file mode 100644
index 0000000..b137788
--- /dev/null
+++ b/T20/t20_geometry.cmn
@@ -0,0 +1,33 @@
+* t20_geometry.cmn
+*
+* $Log: t20_geometry.cmn,v $
+* Revision 1.1 1998/12/01 21:04:30 saw
+* Initial revision
+*
+* This include file has all the geometrical coefficients for the
+* Polder
+*
+*%% include 't20_data_structures.cmn'
+*
+* CTPTYPE=parm
+*
+ real*4 tmwpc_pitch
+ real*4 tmwpc_central_wire
+ real*4 tmwpc_center
+ integer*4 tmwpc_nrwire
+ real*4 tmwpc_zcoord
+ common/T20_PLANE_PARAMETERS/
+ $ tmwpc_pitch(TMAX_NUM_MWPC_PLANES),
+ $ tmwpc_central_wire(TMAX_NUM_MWPC_PLANES),
+ $ tmwpc_center(TMAX_NUM_MWPC_PLANES),
+ $ tmwpc_nrwire(TMAX_NUM_MWPC_PLANES),
+ $ tmwpc_zcoord(TMAX_NUM_MWPC_PLANES)
+
+ integer*4 tmwpc_wire_counting
+ integer*4 tdmytst
+
+ common/T20_CHAMBER_READOUT_INT/
+ $ tmwpc_wire_counting(TMAX_NUM_MWPC_PLANES),
+ $ tdmytst
+
+
diff --git a/T20/t20_hms.cmn b/T20/t20_hms.cmn
new file mode 100755
index 0000000..f1c317b
--- /dev/null
+++ b/T20/t20_hms.cmn
@@ -0,0 +1,19 @@
+* file name: t20_hms.cmn
+
+* CTPTYPE=event
+
+ REAL*4 tsinhtheta ! Sin half lab Scattering angle
+ REAL*4 te_v ! Beam energy in GEV
+ REAL*4 thms_td1 ! Deuteron energy from electron energy
+ REAL*4 thms_td2 ! Deuteron energy from electron angle
+ REAL*4 tq2 ! Q**2
+ INTEGER*4 hr_start_hms
+*
+ COMMON/T20_Ed/
+ & tsinhtheta,
+ & te_v,
+ & thms_td1,
+ & thms_td2,
+ & tq2,
+ & hr_start_hms
+*
diff --git a/T20/t20_hodo.cmn b/T20/t20_hodo.cmn
new file mode 100644
index 0000000..c5d0f61
--- /dev/null
+++ b/T20/t20_hodo.cmn
@@ -0,0 +1,73 @@
+* t20_hodo.cmn
+*
+* $Log: t20_hodo.cmn,v $
+* Revision 1.1 1998/12/01 21:03:15 saw
+* Initial revision
+*
+*
+* CTPTYPE=parm
+
+ integer*4 tidhodo_tdc_min,tidhodo_tdc_max
+
+*
+* CTPTYPE=event
+*
+ integer*4
+ 1 th1p1_tdc_i, tidh1p1_tdc_all,
+ 1 th1p2_tdc_i, tidh1p2_tdc_all,
+ 1 th2p1_tdc_i, tidh2p1_tdc_all,
+ 1 th2p2_tdc_i, tidh2p2_tdc_all,
+ 1 tidhod_allbars_vs_tdc
+*
+ common/t_hodo/
+ & tidhodo_tdc_min,tidhodo_tdc_max,
+ 1 th1p1_tdc_i(60), tidh1p1_tdc_all,
+ 1 th1p2_tdc_i(60), tidh1p2_tdc_all,
+ 1 th2p1_tdc_i(60), tidh2p1_tdc_all,
+ 1 th2p2_tdc_i(60), tidh2p2_tdc_all,
+ 1 tidhod_allbars_vs_tdc
+*
+ integer*4
+ 2 tMwpc_pl1(158),tMwpc_pl2(158),tMwpc_pl3(158),
+ 2 tMwpc_pl4(158),tMwpc_pl5(158),tMwpc_pl6(158),
+ 4 tidmwpl1,tidmwpl2,tidmwpl3,tidmwpl4,tidmwpl5,tidmwpl6,
+ 5 tidmwpl1_anytdc,tidmwpl2_anytdc,tidmwpl3_anytdc,
+ 5 tidmwpl4_anytdc,tidmwpl5_anytdc,tidmwpl6_anytdc,
+ 5 tidmwpl1_tdc_vs_wire,tidmwpl2_tdc_vs_wire,tidmwpl3_tdc_vs_wire,
+ 5 tidmwpl4_tdc_vs_wire,tidmwpl5_tdc_vs_wire,tidmwpl6_tdc_vs_wire,
+ 6 tmwpl1_wire_mult,tmwpl2_wire_mult,tmwpl3_wire_mult,
+ 6 tmwpl4_wire_mult,tmwpl5_wire_mult,tmwpl6_wire_mult,
+ 7 tidmwpl1_multperwire,tidmwpl2_multperwire,tidmwpl3_multperwire,
+ 7 tidmwpl4_multperwire,tidmwpl5_multperwire,tidmwpl6_multperwire,
+ & t_rwirepl7,t_lwirepl7,
+ & t_rwirepl8,t_lwirepl8,
+ & t_rwirepl9,t_lwirepl9,
+ & tmwpc3sumpl7,tmwpc3diffpl7,
+ & tmwpc3sumpl8,tmwpc3diffpl8,
+ & tmwpc3sumpl9,tmwpc3diffpl9,
+ & t_r_wire_pl7,t_l_wire_pl7,
+ & t_r_wire_pl8,t_l_wire_pl8,
+ & t_r_wire_pl9,t_l_wire_pl9
+*
+ common/t_mwpc_cmn/
+ 2 tMwpc_pl1,tMwpc_pl2,tMwpc_pl3,
+ 2 tMwpc_pl4,tMwpc_pl5,tMwpc_pl6,
+ 4 tidmwpl1,tidmwpl2,tidmwpl3,tidmwpl4,tidmwpl5,tidmwpl6,
+ 5 tidmwpl1_anytdc,tidmwpl2_anytdc,tidmwpl3_anytdc,
+ 5 tidmwpl4_anytdc,tidmwpl5_anytdc,tidmwpl6_anytdc,
+ 5 tidmwpl1_tdc_vs_wire,tidmwpl2_tdc_vs_wire,tidmwpl3_tdc_vs_wire,
+ 5 tidmwpl4_tdc_vs_wire,tidmwpl5_tdc_vs_wire,tidmwpl6_tdc_vs_wire,
+ 6 tmwpl1_wire_mult,tmwpl2_wire_mult,tmwpl3_wire_mult,
+ 6 tmwpl4_wire_mult,tmwpl5_wire_mult,tmwpl6_wire_mult,
+ 7 tidmwpl1_multperwire,tidmwpl2_multperwire,tidmwpl3_multperwire,
+ 7 tidmwpl4_multperwire,tidmwpl5_multperwire,tidmwpl6_multperwire,
+ & t_rwirepl7,t_lwirepl7,
+ & t_rwirepl8,t_lwirepl8,
+ & t_rwirepl9,t_lwirepl9,
+ & tmwpc3sumpl7,tmwpc3diffpl7,
+ & tmwpc3sumpl8,tmwpc3diffpl8,
+ & tmwpc3sumpl9,tmwpc3diffpl9,
+ & t_r_wire_pl7,t_l_wire_pl7,
+ & t_r_wire_pl8,t_l_wire_pl8,
+ & t_r_wire_pl9,t_l_wire_pl9
+*
diff --git a/T20/t20_hodo_parms.cmn b/T20/t20_hodo_parms.cmn
new file mode 100644
index 0000000..e64dc6e
--- /dev/null
+++ b/T20/t20_hodo_parms.cmn
@@ -0,0 +1,22 @@
+* t20_hodo_parms.cmn - two common blocks:
+*
+* $Log: t20_hodo_parms.cmn,v $
+* Revision 1.1 1998/12/01 21:04:41 saw
+* Initial revision
+*
+* hms_hodo_parms - variables from the t20_positions.parm file
+* hms_tof_parms - tof correction parameters and position parameters
+* converted to arrays over plane,counter by h_init_scin.
+*
+c* NOTE: Variables whose names start with hHODO are arrays over
+c* plane and counter. hSCIN is used for parameters from the
+c* .parm files and for arrays over hits.
+c*
+*
+* CTPTYPE=parm
+*
+ integer*4 tdebugprinthodoraw !
+
+ common/t20_hodo_parms/
+ $ tdebugprinthodoraw
+
diff --git a/T20/t20_misc.cmn b/T20/t20_misc.cmn
new file mode 100755
index 0000000..1c16871
--- /dev/null
+++ b/T20/t20_misc.cmn
@@ -0,0 +1,82 @@
+* file name: t20_misc.cmn
+*
+* $Log: t20_misc.cmn,v $
+* Revision 1.1 1998/12/01 21:04:53 saw
+* Initial revision
+*
+* purpose: defines variables for
+* - start and veto scintillators of Polder
+*
+* CTPTYPE=event
+*
+ integer*4 traw_adc(7:32)
+ integer*4 traw_mhtdc(6:32)
+ integer*4 traw_hrtdc(1:16)
+
+ integer*4 traw_adc_s11
+ integer*4 traw_adc_s12
+ integer*4 traw_adc_s21
+ integer*4 traw_adc_s22
+ integer*4 traw_adc_veto1
+ integer*4 traw_adc_veto2
+
+ integer*4 traw_mhtdc_s11
+ integer*4 traw_mhtdc_s12
+ integer*4 traw_mhtdc_s21
+ integer*4 traw_mhtdc_s22
+ integer*4 traw_mhtdc_veto
+ integer*4 traw_adc_s1sum
+ integer*4 traw_adc_s2sum
+ integer*4 traw_adc_s1s2sum
+ integer*4 traw_adc_vetosum
+
+ integer*4 !test detector setup
+ 3 traw_adc_tts1l, traw_adc_tts1r, traw_adc_tts2l, traw_adc_tts2r,
+ 3 traw_mhtdc_s1, traw_mhtdc_s2
+
+ integer*4 !tdc's used for flagging of event type
+ 2 tfl_mhtdc_dc, tfl_mhtdc_hms, tfl_mhtdc_hms_dc, tfl_mhtdc_big1,
+ 2 tfl_mhtdc_ce, tfl_mhtdc_polder, tfl_mhtdc_h1m3, tfl_mhtdc_h2m3
+
+ integer*4 ! POLDER Upstairs HRTDC
+ 4 traw_hrtdc_hms,
+ 4 traw_hrtdc_dc,
+ 4 traw_hrtdc_hms_dc,
+ 4 traw_hrtdc_polder,
+ 4 traw_hrtdc_hms_nb,
+ 4 traw_hrtdc_pldr_nb,
+ 4 traw_hrtdc_ce
+
+*
+*
+ common/t_miscellaneous/
+ & traw_adc,
+ & traw_mhtdc,
+ & traw_hrtdc,
+ & traw_adc_s11,
+ & traw_adc_s12,
+ & traw_adc_s21,
+ & traw_adc_s22,
+ & traw_adc_veto1,
+ & traw_adc_veto2,
+ & traw_mhtdc_s11,
+ & traw_mhtdc_s12,
+ & traw_mhtdc_s21,
+ & traw_mhtdc_s22,
+ & traw_mhtdc_veto,
+ 1 traw_adc_s1sum,
+ 1 traw_adc_s2sum,
+ 1 traw_adc_s1s2sum,
+ 1 traw_adc_vetosum,
+ 2 tfl_mhtdc_dc, tfl_mhtdc_hms, tfl_mhtdc_hms_dc, tfl_mhtdc_big1,
+ 2 tfl_mhtdc_ce, tfl_mhtdc_polder, tfl_mhtdc_h1m3, tfl_mhtdc_h2m3,
+ 3 traw_adc_tts1l, traw_adc_tts1r, traw_adc_tts2l, traw_adc_tts2r,
+ 3 traw_mhtdc_s1, traw_mhtdc_s2,
+ 4 traw_hrtdc_hms,
+ 4 traw_hrtdc_dc,
+ 4 traw_hrtdc_hms_dc,
+ 4 traw_hrtdc_polder,
+ 4 traw_hrtdc_hms_nb,
+ 4 traw_hrtdc_pldr_nb,
+ 4 traw_hrtdc_ce
+*
diff --git a/T20/t20_pedestals.cmn b/T20/t20_pedestals.cmn
new file mode 100644
index 0000000..415bccf
--- /dev/null
+++ b/T20/t20_pedestals.cmn
@@ -0,0 +1,16 @@
+*
+* Refer to sos_pedestals.cmn or hms_pedestals.cmn for examples of
+* what to put here.
+*
+* t20_pedestals.cmn - counters used for calculating pedestals from the set
+* of pedestal events at the beginning of each run.
+*
+* $Log: t20_pedestals.cmn,v $
+* Revision 1.1 1998/12/01 21:02:30 saw
+* Initial revision
+*
+*
+*%% include 't20_data_structures.cmn'
+*
+* CTPTYPE=event
+*
diff --git a/T20/t20_reg_polder_structures.cmn b/T20/t20_reg_polder_structures.cmn
new file mode 100644
index 0000000..a0c55bf
--- /dev/null
+++ b/T20/t20_reg_polder_structures.cmn
@@ -0,0 +1,406 @@
+c***** definition common POLDER variables
+c***** --> used to fill the polder structures
+c***** <-- filled after analysis by polder structures
+c***** j.s. real 14 feb 1997
+c***** DO NOT CHANGE THIS FILE BY HAND!
+c***** This file is generate from def_polder_structures.h (1)
+c***** using exp_structures translation software.
+c***** The following definitions and the order of commons block
+c***** are very sensitive and should be the same as in (1)
+c
+* $Log: t20_reg_polder_structures.cmn,v $
+* Revision 1.1 1998/12/01 21:05:04 saw
+* Initial revision
+*
+
+
+* CTPTYPE=parm
+
+c structure /file/ ! 22 + 544 + 43 + 120 int*4 =
+ logical*4 tfile_open
+ integer*4 tfile_iunit
+ character*8 tfile_name
+ integer*4 tfile_record
+ integer*4 tfile_runnb
+ character*20 tfile_device
+ integer*4 tfile_position
+ character*4 tfile_sort
+ real*4 tfile_Ed
+ integer*4 tfile_divNinci
+ integer*4 tfile_posHod
+ real*4 tfile_cur_HMS
+ real*4 tfile_ang_HMS
+ integer*4 tfile_q2_point
+ integer*4 tfile_tailleBuf
+ integer*4 tfile_longBufRead
+ integer*4 tfile_numBuf
+ integer*4 tfile_NBevent
+ integer*4 tfile_NbCEevent
+ integer*4 tfile_nbevtreste
+ integer*4 tfile_nbposfinDeBurst
+ integer*4 tfile_cuts_tdc_shift ! value of shift for raw tdc cuts (spectra random)
+ integer*4 tfile_cuts_diftdcinf(4) ! Lower (inferior) cut on the difference in time betwee
+ integer*4 tfile_cuts_diftdcsup(4) ! Upper (superior) cut on the difference in time betwee
+ real*4 tfile_cuts_mwpcxinf(3) ! Lower cut on the x position of a hit in a MWPC
+ real*4 tfile_cuts_mwpcyinf(3) ! Lower cut on the y position of a hit in a MWPC
+ real*4 tfile_cuts_mwpcxsup(3) ! Upper cut on the x position of a hit in a MWPC
+ real*4 tfile_cuts_mwpcysup(3) ! Upper cut on the y position of a hit in a MWPC
+ integer*4 tfile_cuts_fenmin(3,2) ! Lower cut on the wire hit-time in MWPC 1 and 2
+ integer*4 tfile_cuts_fenmax(3,2) ! Upper cut on the wire hit-time in MWPC 1 and 2
+ integer*4 tfile_cuts_adcmin(3) ! Lower cut on the QDC spectra deuteron
+ integer*4 tfile_cuts_adcmax(3) ! Upper cut on the QDC spectra deuteron
+ integer*4 tfile_cuts_adcminp(3) ! Lower cut on the QDC spectra proton
+ integer*4 tfile_cuts_adcmaxp(3) ! Upper cut on the QDC spectra proton
+ integer*4 tfile_cuts_tofmin(1:6) ! Lower cut on the time coincidence
+ integer*4 tfile_cuts_tofmax(1:6) ! Upper cut on the time coincidence
+ integer*4 tfile_cuts_RpLmin(3) ! Lower cut on the right plus left spectra for the planes
+ integer*4 tfile_cuts_RpLmax(3) ! Upper cut on the right plus left spectra for the planes
+ integer*4 tfile_cuts_tbbi(0:29,4) ! Lower cuts on the raw TDC spectra for the individual
+ integer*4 tfile_cuts_tbbs(0:29,4) ! Upper cuts on the raw TDC spectra for the individual
+ integer*4 tfile_cuts_tcbi(0:29,4) ! Lower cuts on the corrected TDC spectra for the indiv
+ integer*4 tfile_cuts_tcbs(0:29,4) ! Upper cuts on the corrected TDC spectra for the indiv
+ real*4 tfile_cuts_raypmax ! Exterior cone cut for PH
+ real*4 tfile_cuts_raygmax ! Exterior cone cut for GH
+ real*4 tfile_cuts_raypmin ! inner cone cut for PH
+ real*4 tfile_cuts_raypmin33 ! inner cone cut for PH mul. 3 x 3
+ real*4 tfile_cuts_raygmin ! inner cone cut for GH
+ real*4 tfile_cuts_raygmin33 ! iner cone cut for GH mul. 3 x 3
+ real*4 tfile_cuts_rayopt ! optique ray for tuning d channel
+ character*80 tfile_param_dirdata
+ character*80 tfile_param_dirzero
+ character*80 tfile_param_dircumul
+ character*80 tfile_param_dirresult
+ integer*4 tfile_param_user_cuts
+ integer*4 tfile_param_nPC
+ integer*4 tfile_param_nConf
+ integer*4 tfile_param_refgene(3)
+ integer*4 tfile_param_paramEvent(0:20)
+ real*4 tfile_param_dph
+ real*4 tfile_param_dgh
+ real*4 tfile_param_dispg
+ real*4 tfile_param_dispg2
+ real*4 tfile_param_dph2
+ real*4 tfile_param_dgh2
+ real*4 tfile_param_dis2c
+ real*4 tfile_param_dghch1
+ real*4 tfile_param_dphch1
+ real*4 tfile_param_convtq
+ real*4 tfile_param_cexch1
+ real*4 tfile_param_ceych1
+ real*4 tfile_param_xpme
+ real*4 tfile_param_ypme
+ real*4 tfile_param_xgme
+ real*4 tfile_param_ygme
+ real*4 tfile_param_beta
+ real*4 tfile_corre_abstdc(0:29,4) ! Correction to bring the center of each each hodoscope
+c end structure
+
+ common/polder_file/
+ &tfile_open,
+ &tfile_iunit,
+ &tfile_name,
+ &tfile_record,
+ &tfile_runnb,
+ &tfile_device,
+ &tfile_position,
+ &tfile_sort,
+ &tfile_Ed,
+ &tfile_divNinci,
+ &tfile_posHod,
+ &tfile_cur_HMS,
+ &tfile_ang_HMS,
+ &tfile_q2_point,
+ &tfile_tailleBuf,
+ &tfile_longBufRead,
+ &tfile_numBuf,
+ &tfile_NBevent,
+ &tfile_NbCEevent,
+ &tfile_nbevtreste,
+ &tfile_nbposfinDeBurst,
+ &tfile_cuts_tdc_shift,
+ &tfile_cuts_diftdcinf,
+ &tfile_cuts_diftdcsup,
+ &tfile_cuts_mwpcxinf,
+ &tfile_cuts_mwpcyinf,
+ &tfile_cuts_mwpcxsup,
+ &tfile_cuts_mwpcysup,
+ &tfile_cuts_fenmin,
+ &tfile_cuts_fenmax,
+ &tfile_cuts_adcmin,
+ &tfile_cuts_adcmax,
+ &tfile_cuts_adcminp,
+ &tfile_cuts_adcmaxp,
+ &tfile_cuts_tofmin,
+ &tfile_cuts_tofmax,
+ &tfile_cuts_RpLmin,
+ &tfile_cuts_RpLmax,
+ &tfile_cuts_tbbi,
+ &tfile_cuts_tbbs,
+ &tfile_cuts_tcbi,
+ &tfile_cuts_tcbs,
+ &tfile_cuts_raypmax,
+ &tfile_cuts_raygmax,
+ &tfile_cuts_raypmin,
+ &tfile_cuts_raypmin33,
+ &tfile_cuts_raygmin,
+ &tfile_cuts_raygmin33,
+ &tfile_cuts_rayopt,
+ &tfile_param_dirdata,
+ &tfile_param_dirzero,
+ &tfile_param_dircumul,
+ &tfile_param_dirresult,
+ &tfile_param_user_cuts,
+ &tfile_param_nPC,
+ &tfile_param_nConf,
+ &tfile_param_refgene,
+ &tfile_param_paramEvent,
+ &tfile_param_dph,
+ &tfile_param_dgh,
+ &tfile_param_dispg,
+ &tfile_param_dispg2,
+ &tfile_param_dph2,
+ &tfile_param_dgh2,
+ &tfile_param_dis2c,
+ &tfile_param_dghch1,
+ &tfile_param_dphch1,
+ &tfile_param_convtq,
+ &tfile_param_cexch1,
+ &tfile_param_ceych1,
+ &tfile_param_xpme,
+ &tfile_param_ypme,
+ &tfile_param_xgme,
+ &tfile_param_ygme,
+ &tfile_param_beta,
+ &tfile_corre_abstdc
+
+
+* CTPTYPE=event
+
+c structure /event/
+ logical*4 tfinDeBurst
+ logical*4 tVeto
+ logical*4 tBeamSampl
+ logical*4 tGeneCh3
+ logical*4 tCE
+ logical*4 tT3
+ logical*4 tmwpc_ok
+ logical*4 tgood_event
+ logical*4 ttc_tof_ok
+ logical*4 ttc_adc_ok
+ logical*4 ttc_mwpc_ok
+ integer*4 tnbpartch
+ integer*4 tTdc_Veto
+ integer*4 tadc_Veto1
+ integer*4 tadc_Veto2
+ integer*4 tadc_Vetosum
+ integer*4 tspin
+ integer*4 ttof(1:6)
+ integer*4 tadc_s11
+ integer*4 tadc_s12
+ integer*4 tadc_s1sum
+ integer*4 tadc_s21
+ integer*4 tadc_s22
+ integer*4 tadc_s2sum
+ integer*4 ttdc_s11
+ integer*4 ttdc_s12
+ integer*4 ttdc_s21
+ integer*4 ttdc_s22
+ integer*4 tnumburst
+ integer*4 tparamEvent(0:20)
+ integer*4 tmwpc1_nbp(3)
+ integer*4 tmwpc1_fil(40,3)
+ integer*4 tmwpc1_temps(0:158,3)
+ logical*4 tmwpc1_mwpc_ok(0:3)
+ integer*4 tmwpc1_nbpart(3)
+ integer*4 tmwpc2_nbp(3)
+ integer*4 tmwpc2_fil(40,3)
+ integer*4 tmwpc2_temps(0:158,3)
+ logical*4 tmwpc2_mwpc_ok(0:3)
+ integer*4 tmwpc2_nbpart(3)
+ integer*4 tmwpc3_R(3)
+ integer*4 tmwpc3_L(3)
+ integer*4 tmwpc3_RmL(3)
+ integer*4 tmwpc3_RpL(3)
+ logical*4 tmwpc3_mwpc_ok(0:3)
+ integer*4 tmwpc3_nbpart(3)
+ integer*4 thod1_nbp
+ integer*4 thod1_barre(100)
+ integer*4 thod1_tdcb(100)
+ integer*4 thod1_tdc(100)
+ integer*4 thod2_nbp
+ integer*4 thod2_barre(100)
+ integer*4 thod2_tdcb(100)
+ integer*4 thod2_tdc(100)
+ integer*4 thod3_nbp
+ integer*4 thod3_barre(100)
+ integer*4 thod3_tdcb(100)
+ integer*4 thod3_tdc(100)
+ integer*4 thod4_nbp
+ integer*4 thod4_barre(100)
+ integer*4 thod4_tdcb(100)
+ integer*4 thod4_tdc(100)
+ integer*4 thod5_nbp
+ integer*4 thod5_barre(100)
+ integer*4 thod5_tdcb(100)
+ integer*4 thod5_tdc(100)
+ integer*4 thod6_nbp
+ integer*4 thod6_barre(100)
+ integer*4 thod6_tdcb(100)
+ integer*4 thod6_tdc(100)
+ integer*4 tdeuton1_type ! 1=deutce, 2=prot, 3=deutbruit
+ real*4 tdeuton1_dir(4) ! x, y, z, norm
+ real*4 tdeuton1_x(6) ! ch1, ch2, cible, ho1, ho2, ch3
+ real*4 tdeuton1_y(6)
+ real*4 tdeuton1_z(6)
+ real*4 tdeuton1_raypmieu
+ real*4 tdeuton1_rayp
+ real*4 tdeuton1_raygmieu
+ real*4 tdeuton1_rayg
+ integer*4 tdeuton1_tof
+ integer*4 tdeuton1_hms_tof
+ integer*4 tdeuton1_mh_tof(16)
+ integer*4 tdeuton1_mh_hms_tof(16)
+ integer*4 tdeuton2_type ! 1=deutce, 2=prot, 3=deutbruit
+ real*4 tdeuton2_dir(4) ! x, y, z, norm
+ real*4 tdeuton2_x(6) ! ch1, ch2, cible, ho1, ho2, ch3
+ real*4 tdeuton2_y(6)
+ real*4 tdeuton2_z(6)
+ real*4 tdeuton2_raypmieu
+ real*4 tdeuton2_rayp
+ real*4 tdeuton2_raygmieu
+ real*4 tdeuton2_rayg
+ integer*4 tdeuton2_tof
+ integer*4 tdeuton2_hms_tof
+ integer*4 tdeuton2_mh_tof(16)
+ integer*4 tdeuton2_mh_hms_tof(16)
+ real*4 tproton1_dir(4) ! x, y, z, norm
+ real*4 tproton1_x(4) ! cible, ho1, ho2, ch3
+ real*4 tproton1_y(4)
+ real*4 tproton1_z(4)
+ real*4 tproton1_rayp
+ real*4 tproton1_rayg
+ real*4 tproton1_tdcbrut(4) ! ho1x, ho1y, ho2x, ho2y
+ real*4 tproton1_tdccorr(4)
+ real*4 tproton1_barhod(4)
+ real*4 tproton2_dir(4) ! x, y, z, norm
+ real*4 tproton2_x(4) ! cible, ho1, ho2, ch3
+ real*4 tproton2_y(4)
+ real*4 tproton2_z(4)
+ real*4 tproton2_rayp
+ real*4 tproton2_rayg
+ real*4 tproton2_tdcbrut(4) ! ho1x, ho1y, ho2x, ho2y
+ real*4 tproton2_tdccorr(4)
+ real*4 tproton2_barhod(4)
+ real*4 tcpp_dir(4) ! x, y, z, norm
+ real*4 tcpp_x(4) ! cible, ho1, ho2, ch3
+ real*4 tcpp_y(4)
+ real*4 tcpp_z(4)
+ real*4 tcpp_diftdc(4) ! ho1x, ho1y, ho2x, ho2y
+ real*4 tcpp_tetaqk
+ real*4 tcpp_tetaerl
+ real*4 tcpp_erl
+ real*4 tcpp_teta
+ real*4 tcpp_q
+ real*4 tcpp_phi
+c end structure
+
+ common/polder_event/
+ &tfinDeBurst, tVeto, tBeamSampl, tGeneCh3, tCE, tT3,
+ &tmwpc_ok, tgood_event, ttc_tof_ok, ttc_adc_ok, ttc_mwpc_ok,
+ &tnbpartch, tTdc_Veto,
+ &tadc_Veto1, tadc_Veto2, tadc_Vetosum, tspin,
+ &ttof,
+ &tadc_s11, tadc_s12, tadc_s1sum, tadc_s21, tadc_s22, tadc_s2sum,
+ &ttdc_s11, ttdc_s12, ttdc_s21, ttdc_s22,
+ &tnumburst, tparamEvent,
+ &tmwpc1_nbp, tmwpc1_fil, tmwpc1_temps, tmwpc1_mwpc_ok, tmwpc1_nbpart,
+ &tmwpc2_nbp,
+ &tmwpc2_fil,
+ &tmwpc2_temps,
+ &tmwpc2_mwpc_ok,
+ &tmwpc2_nbpart,
+ &tmwpc3_R,
+ &tmwpc3_L,
+ &tmwpc3_RmL,
+ &tmwpc3_RpL,
+ &tmwpc3_mwpc_ok,
+ &tmwpc3_nbpart,
+ &thod1_nbp,
+ &thod1_barre,
+ &thod1_tdcb,
+ &thod1_tdc,
+ &thod2_nbp,
+ &thod2_barre,
+ &thod2_tdcb,
+ &thod2_tdc,
+ &thod3_nbp,
+ &thod3_barre,
+ &thod3_tdcb,
+ &thod3_tdc,
+ &thod4_nbp,
+ &thod4_barre,
+ &thod4_tdcb,
+ &thod4_tdc,
+ &thod5_nbp,
+ &thod5_barre,
+ &thod5_tdcb,
+ &thod5_tdc,
+ &thod6_nbp,
+ &thod6_barre,
+ &thod6_tdcb,
+ &thod6_tdc,
+ &tdeuton1_type,
+ &tdeuton1_dir,
+ &tdeuton1_x,
+ &tdeuton1_y,
+ &tdeuton1_z,
+ &tdeuton1_raypmieu,
+ &tdeuton1_rayp,
+ &tdeuton1_raygmieu,
+ &tdeuton1_rayg,
+ &tdeuton1_tof,
+ &tdeuton1_hms_tof,
+ &tdeuton1_mh_tof,
+ &tdeuton1_mh_hms_tof,
+ &tdeuton2_type,
+ &tdeuton2_dir,
+ &tdeuton2_x,
+ &tdeuton2_y,
+ &tdeuton2_z,
+ &tdeuton2_raypmieu,
+ &tdeuton2_rayp,
+ &tdeuton2_raygmieu,
+ &tdeuton2_rayg,
+ &tdeuton2_tof,
+ &tdeuton2_hms_tof,
+ &tdeuton2_mh_tof,
+ &tdeuton2_mh_hms_tof,
+ &tproton1_dir,
+ &tproton1_x,
+ &tproton1_y,
+ &tproton1_z,
+ &tproton1_rayp,
+ &tproton1_rayg,
+ &tproton1_tdcbrut,
+ &tproton1_tdccorr,
+ &tproton1_barhod,
+ &tproton2_dir,
+ &tproton2_x,
+ &tproton2_y,
+ &tproton2_z,
+ &tproton2_rayp,
+ &tproton2_rayg,
+ &tproton2_tdcbrut,
+ &tproton2_tdccorr,
+ &tproton2_barhod,
+ &tcpp_dir,
+ &tcpp_x,
+ &tcpp_y,
+ &tcpp_z,
+ &tcpp_diftdc,
+ &tcpp_tetaqk,
+ &tcpp_tetaerl,
+ &tcpp_erl,
+ &tcpp_teta,
+ &tcpp_q,
+ &tcpp_phi
diff --git a/T20/t20_test_detectors.cmn b/T20/t20_test_detectors.cmn
new file mode 100644
index 0000000..bb46bff
--- /dev/null
+++ b/T20/t20_test_detectors.cmn
@@ -0,0 +1,359 @@
+* t20_test_detectors.cmn
+* include file for t20 tracking intermediate results
+* R. Gilman December 1996, loosely based on HMS tracking code, ...
+*
+* $Log: t20_test_detectors.cmn,v $
+* Revision 1.2 1998/12/01 21:02:25 saw
+* (SAW) Checkin
+*
+* Revision 1.1 1997/05/20 19:09:01 saw
+* Initial revision
+*
+* The following include statments must precede the inclusion of this
+* file in each routine that uses it. The *%% syntax is also a
+* directive to makereg to tell it to include the code in the program
+* that it generates.
+*
+*%% include 't20_data_structures.cmn'
+
+*----------------------------------------------------------------------
+* PARAMETERS TO DEFINE STRAW CHAMBERS GEOMETRY, NUMBER STRAWS
+*
+* CTPTYPE=parm
+*
+ integer*4 ttst_n_straw_planes
+ parameter (ttst_n_straw_planes=8)
+ integer*4 ttst_n_straw_wgs
+ parameter (ttst_n_straw_wgs=40)
+
+ integer*4 ttst_plane_group(ttst_n_straw_planes)
+ integer*4 ttst_plane_of_group(ttst_n_straw_wgs)
+
+ real*8 ttst_straw_z(ttst_n_straw_planes)
+ real*8 ttst_straw_z0
+ real*8 ttst_straw_x1(ttst_n_straw_planes)
+ real*8 ttst_straw_x2(ttst_n_straw_planes)
+ real*8 ttst_straw_xoff(2)
+ real*8 ttst_rotate_ang(3)
+ real*8 ttst_rotate_xz
+ real*8 ttst_rotate_yz
+ real*8 ttst_rotate_xy
+ equivalence (ttst_rotate_ang(1), ttst_rotate_xz)
+ equivalence (ttst_rotate_ang(2), ttst_rotate_yz)
+ equivalence (ttst_rotate_ang(3), ttst_rotate_xy)
+ real*8 ttst_rotate_xyplane(8)
+ real*8 ttst_straw_sctr(ttst_n_straw_planes)
+ integer*4 ttst_straw_nst(ttst_n_straw_planes)
+
+ real*8 ttst_scin_z(2)
+ real*8 ttst_straw_zchmbr
+ real*8 ttst_straw_zscint
+ real*8 ttst_scin_x(2)
+ real*8 ttst_scin_y(2)
+ real*8 ttst_scin_xwid(2)
+ real*8 ttst_scin_ywid(2)
+
+ integer*4 ttst_scin_peds(4)
+ real*8 ttst_scin_v_corr
+ real*8 ttst_straw_v_corr
+
+ integer*4 ttst_straw_type(ttst_n_straw_planes)
+ integer*4 ttst_type_order(ttst_n_straw_planes,2)
+ integer*4 ttst_straw_plane_group_off(ttst_n_straw_planes)
+
+ integer*4 ttst_dmx(9,ttst_n_straw_wgs)
+
+ integer*4 ttst_TDC_min
+ integer*4 ttst_TDC_max
+ integer*4 ttst_t0(ttst_n_straw_wgs)
+
+ real*8 ttst_straw_spacing
+ real*8 ttst_drift_max
+ real*8 ttst_drift_v
+ real*8 ttst_drift_t0
+ real*8 ttst_drift_table(400)
+ real*8 ttst_track_distcut
+ real*8 ttst_track_chisqcut
+
+ common /ttst_parms/
+ $ ttst_straw_z, ! Real*4
+ $ ttst_straw_z0,
+ $ ttst_straw_zchmbr,
+ $ ttst_straw_zscint,
+ $ ttst_straw_x1,
+ $ ttst_straw_x2,
+ $ ttst_straw_xoff,
+ $ ttst_rotate_ang,
+ $ ttst_rotate_xyplane,
+ $ ttst_straw_sctr,
+ $ ttst_straw_nst,
+ $ ttst_scin_z,
+ $ ttst_scin_x,
+ $ ttst_scin_y,
+ $ ttst_scin_xwid,
+ $ ttst_scin_ywid,
+ $ ttst_scin_peds,
+ $ ttst_scin_v_corr,
+ $ ttst_straw_v_corr,
+ $ ttst_plane_group,
+ $ ttst_plane_of_group,
+ $ ttst_straw_type,
+ $ ttst_type_order,
+ $ ttst_straw_plane_group_off,
+ $ ttst_dmx,
+ $ ttst_TDC_min,
+ $ ttst_TDC_max,
+ $ ttst_t0,
+ $ ttst_straw_spacing,
+ $ ttst_drift_max,
+ $ ttst_drift_v,
+ $ ttst_drift_t0,
+ $ ttst_drift_table,
+ $ ttst_track_distcut,
+ $ ttst_track_chisqcut
+
+
+*----------------------------------------------------------------------
+* Scintillator Event variables
+*
+* CTPTYPE=event
+*
+ integer*4 ttst_scin_rawadc(4)
+ integer*4 ttst_scin_adc1l
+ integer*4 ttst_scin_adc1r
+ integer*4 ttst_scin_adc2l
+ integer*4 ttst_scin_adc2r
+ equivalence (ttst_scin_rawadc(1), ttst_scin_adc1l)
+ equivalence (ttst_scin_rawadc(2), ttst_scin_adc2l)
+ equivalence (ttst_scin_rawadc(3), ttst_scin_adc1r)
+ equivalence (ttst_scin_rawadc(4), ttst_scin_adc2r)
+ integer*4 ttst_scin_psadc(4)
+ integer*4 ttst_scin_psadc1l
+ integer*4 ttst_scin_psadc1r
+ integer*4 ttst_scin_psadc2l
+ integer*4 ttst_scin_psadc2r
+ equivalence (ttst_scin_psadc(1), ttst_scin_psadc1l)
+ equivalence (ttst_scin_psadc(2), ttst_scin_psadc2l)
+ equivalence (ttst_scin_psadc(3), ttst_scin_psadc1r)
+ equivalence (ttst_scin_psadc(4), ttst_scin_psadc2r)
+ integer*4 ttst_scin_gmean_adc
+ integer*4 ttst_scin_amean_adc
+ integer*4 ttst_scin_nzadcs
+ integer*4 ttst_scin_adc1m
+ integer*4 ttst_scin_adc2m
+* integer*4 ttst_scin_tdc(4)
+* integer*4 ttst_scin_tdc1l
+* integer*4 ttst_scin_tdc1r
+* integer*4 ttst_scin_tdc2l
+* integer*4 ttst_scin_tdc2r
+* equivalence (ttst_scin_tdc(1), ttst_scin_tdc1l)
+* equivalence (ttst_scin_tdc(2), ttst_scin_tdc1r)
+* equivalence (ttst_scin_tdc(3), ttst_scin_tdc2l)
+* equivalence (ttst_scin_tdc(4), ttst_scin_tdc2r)
+* integer*4 ttst_scin_timeoff(4)
+* integer*4 ttst_scin_tdccor(4)
+* integer*4 ttst_scin_pos1
+* integer*4 ttst_scin_pos2
+* integer*4 ttst_scin_pos
+* integer*4 ttst_scin_time1
+* integer*4 ttst_scin_time2
+* integer*4 ttst_scin_time
+* integer*4 ttst_scin_timecor1
+* integer*4 ttst_scin_timecor2
+* integer*4 ttst_scin_timecor
+* integer*4 ttst_t0_correction
+ common /ttst_scin/
+ $ ttst_scin_rawadc,
+ $ ttst_scin_psadc,
+ $ ttst_scin_gmean_adc,
+ $ ttst_scin_amean_adc,
+ $ ttst_scin_nzadcs,
+ $ ttst_scin_adc1m,
+ $ ttst_scin_adc2m
+* $ ttst_scin_tdc,
+* $ ttst_scin_timeoff,
+* $ ttst_scin_tdccor,
+* $ ttst_scin_pos1,
+* $ ttst_scin_pos2,
+* $ ttst_scin_pos,
+* $ ttst_scin_time1,
+* $ ttst_scin_time2,
+* $ ttst_scin_time,
+* $ ttst_scin_timecor1,
+* $ ttst_scin_timecor2,
+* $ ttst_scin_timecor,
+* $ ttst_t0_correction
+
+
+*----------------------------------------------------------------------
+* Chamber Event variables
+*
+* CTPTYPE=event
+*
+ integer*4 ttst_straw_tdc(8,ttst_n_straw_wgs)
+ integer*4 ttst_straw_wid(8,ttst_n_straw_wgs)
+ integer*4 ttst_straw_num(8,ttst_n_straw_wgs)
+ integer*4 ttst_straw_hits(ttst_n_straw_wgs)
+c integer*4 ttst_straw_goodedge
+c integer*4 ttst_straw_plane
+ integer*4 ttst_straw_goodhit
+ integer*4 ttst_straw_gooddemux
+ integer*4 ttst_straw_xygddmx(2)
+ integer*4 ttst_straw_xgddmx
+ integer*4 ttst_straw_ygddmx
+ equivalence (ttst_straw_xygddmx(1), ttst_straw_xgddmx)
+ equivalence (ttst_straw_xygddmx(2), ttst_straw_ygddmx)
+ integer*4 ttst_straw_xyplnsht(2)
+ integer*4 ttst_straw_xplnsht
+ integer*4 ttst_straw_yplnsht
+ equivalence (ttst_straw_xyplnsht(1), ttst_straw_xplnsht)
+ equivalence (ttst_straw_xyplnsht(2), ttst_straw_yplnsht)
+ integer*4 ttst_straw_planes_hit(ttst_n_straw_planes)
+ integer*4 ttst_straw_plane1_hit
+ integer*4 ttst_straw_plane2_hit
+ integer*4 ttst_straw_plane3_hit
+ integer*4 ttst_straw_plane4_hit
+ integer*4 ttst_straw_plane5_hit
+ integer*4 ttst_straw_plane6_hit
+ integer*4 ttst_straw_plane7_hit
+ integer*4 ttst_straw_plane8_hit
+ equivalence (ttst_straw_planes_hit(1), ttst_straw_plane1_hit)
+ equivalence (ttst_straw_planes_hit(2), ttst_straw_plane2_hit)
+ equivalence (ttst_straw_planes_hit(3), ttst_straw_plane3_hit)
+ equivalence (ttst_straw_planes_hit(4), ttst_straw_plane4_hit)
+ equivalence (ttst_straw_planes_hit(5), ttst_straw_plane5_hit)
+ equivalence (ttst_straw_planes_hit(6), ttst_straw_plane6_hit)
+ equivalence (ttst_straw_planes_hit(7), ttst_straw_plane7_hit)
+ equivalence (ttst_straw_planes_hit(8), ttst_straw_plane8_hit)
+ integer*4 ttst_num_oot(2)
+ integer*4 ttst_num_oot1
+ integer*4 ttst_num_oot2
+ equivalence (ttst_num_oot1,ttst_num_oot(1))
+ equivalence (ttst_num_oot2,ttst_num_oot(2))
+ integer*4 ttst_avetim_oot(2)
+ integer*4 ttst_wg_oot(10,2)
+ integer*4 ttst_tim_oot(10,2)
+ integer*4 ttst_wid_oot(10,2)
+ integer*4 ttst_str_oot(10,2)
+ integer*4 ttst_pln_oot(10,2)
+ common /ttst_straw/
+ $ ttst_straw_tdc,
+ $ ttst_straw_wid,
+ $ ttst_straw_num,
+ $ ttst_straw_hits,
+c $ ttst_straw_goodedge,
+c $ ttst_straw_plane,
+ $ ttst_straw_goodhit,
+ $ ttst_straw_gooddemux,
+ $ ttst_straw_xygddmx,
+ $ ttst_straw_xyplnsht,
+ $ ttst_straw_planes_hit
+ common/ttst_oot/
+ $ ttst_num_oot,
+ $ ttst_avetim_oot,
+ $ ttst_wg_oot,
+ $ ttst_tim_oot,
+ $ ttst_wid_oot,
+ $ ttst_str_oot,
+ $ ttst_pln_oot
+
+*----------------------------------------------------------------------
+* Straw Chamber Tracking variables
+*
+* CTPTYPE=event
+*
+ integer*4 max_track_hit
+ parameter (max_track_hit=8)
+
+ real*4 ttst_track_pos_est(2)
+ real*4 ttst_track_pos_estx
+ real*4 ttst_track_pos_esty
+ equivalence (ttst_track_pos_est(1),ttst_track_pos_estx)
+ equivalence (ttst_track_pos_est(2),ttst_track_pos_esty)
+ real*4 ttst_track_xpos(max_track_hit,ttst_n_straw_planes)
+ real*4 ttst_track_dxpos(max_track_hit,ttst_n_straw_planes)
+ real*4 ttst_track_dxpos2(max_track_hit,ttst_n_straw_planes)
+ integer*4 ttst_track_straw(max_track_hit,ttst_n_straw_planes)
+c info type, hit_on_plane, plane#
+ real*4 ttst_track_hitarray(4,10,8)
+ integer*4 ttst_track_ntracks
+ real*4 ttst_track_params(3,2)
+ real*4 ttst_track_bxint
+ real*4 ttst_track_byint
+ equivalence (ttst_track_params(2,1),ttst_track_bxint)
+ equivalence (ttst_track_params(2,2),ttst_track_byint)
+ real*4 ttst_track_xchisq
+ real*4 ttst_track_ychisq
+ equivalence (ttst_track_params(3,1),ttst_track_xchisq)
+ equivalence (ttst_track_params(3,2),ttst_track_ychisq)
+ real*4 ttst_track_angle(2)
+ real*4 ttst_track_theta
+ real*4 ttst_track_phi
+ equivalence (ttst_track_angle(1),ttst_track_theta)
+ equivalence (ttst_track_angle(2),ttst_track_phi)
+ real*4 ttst_track_chmbrpos(2)
+ real*4 ttst_track_chmbrx
+ real*4 ttst_track_chmbry
+ equivalence (ttst_track_chmbrpos(1),ttst_track_chmbrx)
+ equivalence (ttst_track_chmbrpos(2),ttst_track_chmbry)
+ real*4 ttst_track_scintpos(2)
+ real*4 ttst_track_scintx
+ real*4 ttst_track_scinty
+ equivalence (ttst_track_scintpos(1),ttst_track_scintx)
+ equivalence (ttst_track_scintpos(2),ttst_track_scinty)
+ real*4 ttst_track_code
+ integer*4 ttst_nxytracktried(2)
+ integer*4 ttst_nxytrack(2)
+ integer*4 ttst_xtrack
+ integer*4 ttst_ytrack
+ equivalence (ttst_nxytrack(1),ttst_xtrack)
+ equivalence (ttst_nxytrack(2),ttst_ytrack)
+c define some variables for difference between straws and front POLDER
+c chambers
+ real*4 ttst_stpld_xposdiff
+ real*4 ttst_stpld_yposdiff
+ real*4 ttst_stpld_thposdiff
+ real*4 ttst_stpld_phposdiff
+ integer*4 ttst_good_comp
+
+ common /ttst_track_strawchamber/
+ $ ttst_track_pos_est,
+ $ ttst_track_xpos,
+ $ ttst_track_dxpos,
+ $ ttst_track_dxpos2,
+ $ ttst_track_straw,
+ $ ttst_track_hitarray,
+ $ ttst_track_ntracks,
+ $ ttst_track_params,
+ $ ttst_track_angle,
+ $ ttst_track_chmbrpos,
+ $ ttst_track_scintpos,
+ $ ttst_track_code,
+ $ ttst_nxytracktried,
+ $ ttst_nxytrack,
+ $ ttst_stpld_xposdiff,
+ $ ttst_stpld_yposdiff,
+ $ ttst_stpld_thposdiff,
+ $ ttst_stpld_phposdiff,
+ $ ttst_good_comp
+*----------------------------------------------------------------------
+*
+* CTPTYPE=param
+*
+* How many ntuple should written out. May go away when ENGINE
+* standard ntuples are used.
+*
+ integer*4 ttst_raw_ntuples_out
+ integer*4 ttst_reallyraw_out
+ integer*4 ttst_track_ntuples_out
+ integer*4 raw_ntuples_written
+ integer*4 reallyraw_written
+ integer*4 track_ntuples_written
+ common /ttst_stuff/
+ $ ttst_raw_ntuples_out,
+ $ ttst_reallyraw_out,
+ $ ttst_track_ntuples_out,
+ $ raw_ntuples_written,
+ $ reallyraw_written,
+ $ track_ntuples_written
+
diff --git a/T20/t20_test_histid.cmn b/T20/t20_test_histid.cmn
new file mode 100644
index 0000000..ab5e154
--- /dev/null
+++ b/T20/t20_test_histid.cmn
@@ -0,0 +1,78 @@
+*
+* Look at sos_id_histid.cmn and hms_id_histid.cmn for examples
+*
+*_______________________________________________________________________
+* t20_id_histid.cmn
+*
+* This common block contains the HBOOK histogram id numbers
+* for all sos particle id histograms in which direct hfill
+* calls are made.
+*
+* It also contains the paramter flags to turn on and off histograming
+* of each of the hard coded blocks.
+*
+* Created 23 Jan 1997 Stephen A. Wood
+*
+* $Log: t20_test_histid.cmn,v $
+* Revision 1.1 1998/12/01 21:05:10 saw
+* Initial revision
+*
+*%% include 't20_data_structures.cmn'
+*
+* CTPTYPE=parm
+
+ integer*4 ttst_hid_straw_wletdc
+ integer*4 ttst_hid_straw_letdc
+ integer*4 ttst_hid_straw_width
+ integer*4 ttst_hid_dmxchck
+ integer*4 ttst_hid_wg
+ integer*4 ttst_hid_strawmap
+ integer*4 ttst_hid_numhitsonplanes
+ integer*4 ttst_hid_driftdist
+ integer*4 ttst_hid_driftdistv0
+ integer*4 ttst_hid_drifttime
+ integer*4 ttst_hid_drifttimet0
+ integer*4 ttst_hid_xoryhits
+ integer*4 ttst_hid_evtstrcked
+ integer*4 ttst_hid_strawres
+ integer*4 ttst_hid_strawhitgd
+ integer*4 ttst_hid_strawhitbd
+ integer*4 ttst_hid_strawhitms
+ integer*4 ttst_hid_planeoffs(8)
+ integer*4 ttst_hid_linoff(8)
+ integer*4 ttst_hid_trackcode
+ integer*4 ttst_hid_trackcodet
+ integer*4 ttst_hid_oot_thvx
+ integer*4 ttst_hid_oot_phvy
+ integer*4 ttst_hid_oot_yvx
+
+ common/ttst_straw_histids/
+ + ttst_hid_straw_wletdc,
+ + ttst_hid_straw_letdc,
+ + ttst_hid_straw_width,
+ + ttst_hid_dmxchck,
+ + ttst_hid_wg,
+ + ttst_hid_strawmap,
+ + ttst_hid_numhitsonplanes,
+ + ttst_hid_driftdist,
+ + ttst_hid_driftdistv0,
+ + ttst_hid_drifttime,
+ + ttst_hid_drifttimet0,
+ + ttst_hid_xoryhits,
+ + ttst_hid_evtstrcked,
+ + ttst_hid_strawres,
+ + ttst_hid_strawhitgd,
+ + ttst_hid_strawhitbd,
+ + ttst_hid_strawhitms,
+ + ttst_hid_planeoffs,
+ + ttst_hid_linoff,
+ + ttst_hid_trackcode,
+ + ttst_hid_trackcodet,
+ + ttst_hid_oot_thvx,
+ + ttst_hid_oot_phvy,
+ + ttst_hid_oot_yvx
+
+
+
+
+
diff --git a/T20/t20_track_histid.cmn b/T20/t20_track_histid.cmn
new file mode 100644
index 0000000..72de979
--- /dev/null
+++ b/T20/t20_track_histid.cmn
@@ -0,0 +1,24 @@
+*_______________________________________________________________________
+* t20_track_histid.cmn
+*
+* This common block contains the HBOOK histogram id numbers
+* for all t20 histograms in which direct hfill calls are made.
+* Note (HB): actually, most histograms are in other t20_*.cmn files
+*
+* It also contains the parameter flags to turn on and off histograming
+* of each of the hard coded blocks.
+*
+* Created 30 January 1997 S.A. Wood
+* $Log: t20_track_histid.cmn,v $
+* Revision 1.1 1998/12/01 21:02:09 saw
+* Initial revision
+*
+*%% include 't20_data_structures.cmn'
+*
+* CTPTYPE=parm ! The following probably should not be registered
+*
+ integer*4 tidrawtdc
+
+ common/t20_tracking_histid/
+ $ tidrawtdc
+
diff --git a/T20/t20_tracking.cmn b/T20/t20_tracking.cmn
new file mode 100644
index 0000000..2f28c8e
--- /dev/null
+++ b/T20/t20_tracking.cmn
@@ -0,0 +1,73 @@
+* t20_tracking.cmn
+* include file for t20 tracking intermediate results
+* S.A. Wood 22 Jan 97
+
+* $Log: t20_tracking.cmn,v $
+* Revision 1.2 1998/12/01 21:02:01 saw
+* (SAW) Checkin
+*
+* Revision 1.1 1997/05/23 19:07:39 saw
+* Initial revision
+*
+* The following include statments must precede the inclusion of this
+* file in each routine that uses it. The *%% syntax is also a
+* directive to makereg to tell it to include the code in the program
+* that it generates.
+*
+*%% include 't20_data_structures.cmn'
+
+
+
+*------------------------------Csoft/SRC/HTRACKING/----------------------------------------
+* INFORMATION ABOUT PLANE GEOMETRY AND TRACKING PARAMETERS
+*
+* CTPTYPE=parm
+*
+ integer*4 tmwpc_max_wires_per_plane
+ parameter (tmwpc_max_wires_per_plane=158)
+
+ integer*4 tmwpc_num_planes ! Actual number of mwpc planes - set in CTP
+ integer*4 tmwpc_num_chambers ! Actual number of mwpc chambers - set in CTP
+ integer*4 tmwpc_tdc_min_win ! mwpc tdc min value for good hit
+ integer*4 tmwpc_tdc_max_win ! mwpc tdc max value for good hit
+ common/T20_TRACKING/
+ $ tmwpc_num_planes,
+ $ tmwpc_num_chambers,
+ $ tmwpc_tdc_min_win(tmax_num_mwpc_planes),
+ $ tmwpc_tdc_max_win(tmax_num_mwpc_planes)
+
+*
+*
+* MWPC CHAMBER DEBUGGING FLAGS/INFO.
+*
+* CTPTYPE=parm
+*
+ integer*4 tdebugcalcpeds ! calc peds from physics events.
+ integer*4 tdebugprintmwpcraw !
+ integer*4 tluno ! logical unit number for debugging output
+
+ common/T20_TRACKFLAGS/
+ & tdebugcalcpeds,
+ $ tdebugprintmwpcraw,
+ $ tluno
+
+*----------------------------------------------------------------------
+* WIRE CHAMBER EFFICIENCY MEASUREMENTS.
+*
+* CTPTYPE=parm
+*
+* warning levels for efficiency
+c real*4 hdc_min_plane_eff(hmax_num_dc_planes)
+c real*4 hdc_min_wire_eff
+*
+* CTPTYPE=event
+*
+* multiple hits per wire statistics.
+
+ integer*4 twire_mult(tmwpc_max_wires_per_plane,tmax_num_mwpc_planes)
+ integer*4 twire_early_mult(tmwpc_max_wires_per_plane,tmax_num_mwpc_planes)
+ integer*4 twire_late_mult(tmwpc_max_wires_per_plane,tmax_num_mwpc_planes)
+ integer*4 twire_extra_mult(tmwpc_max_wires_per_plane,tmax_num_mwpc_planes)
+
+ common/t20_mwpc_stats/
+ & twire_mult,twire_early_mult,twire_late_mult,twire_extra_mult
diff --git a/T20/t_analyze_pedestal.f b/T20/t_analyze_pedestal.f
new file mode 100644
index 0000000..b361285
--- /dev/null
+++ b/T20/t_analyze_pedestal.f
@@ -0,0 +1,24 @@
+ subroutine t_analyze_pedestal(ABORT,err)
+*
+* Refer to s_analyze_pedestal or h_analyze_pedestal for examples
+* of what to put here.
+*
+* $Log: t_analyze_pedestal.f,v $
+* Revision 1.1 1998/12/01 20:56:24 saw
+* Initial revision
+*
+*
+ implicit none
+ save
+*
+ character*18 here
+ parameter (here='t_analyze_pedestal')
+*
+ logical ABORT
+ character*(*) err
+*
+ INCLUDE 't20_data_structures.cmn'
+ INCLUDE 't20_pedestals.cmn'
+
+ return
+ end
diff --git a/T20/t_calc_pedestal.f b/T20/t_calc_pedestal.f
new file mode 100644
index 0000000..0fb05a1
--- /dev/null
+++ b/T20/t_calc_pedestal.f
@@ -0,0 +1,30 @@
+ subroutine t_calc_pedestal(ABORT,err)
+*
+* See s_calc_pedestal or h_calc_pedestal for examples of what to put here
+*
+*
+* $Log: t_calc_pedestal.f,v $
+* Revision 1.1 1998/12/01 20:56:28 saw
+* Initial revision
+*
+*
+ implicit none
+ save
+*
+ character*18 here
+ parameter (here='t_calc_pedestal')
+*
+ logical ABORT
+ character*(*) err
+*
+ INCLUDE 't20_data_structures.cmn'
+ INCLUDE 't20_pedestals.cmn'
+ INCLUDE 't20_filenames.cmn'
+ INCLUDE 'gen_run_info.cmn'
+*
+ integer SPAREID
+ parameter (SPAREID=67)
+*
+
+ return
+ end
diff --git a/T20/t_clear_event.f b/T20/t_clear_event.f
new file mode 100644
index 0000000..25313a8
--- /dev/null
+++ b/T20/t_clear_event.f
@@ -0,0 +1,53 @@
+ SUBROUTINE T_clear_event(ABORT,err)
+*--------------------------------------------------------
+*-
+*- Purpose and Methods : clears all T20 quantities before event is processed.
+*-
+*-
+*- Output: ABORT - success or failure
+*- : err - reason for failure, if any
+*-
+*- Created 22-Jan-1997 Stephen A. Wood
+*
+* $Log: t_clear_event.f,v $
+* Revision 1.1 1998/12/01 20:57:37 saw
+* Initial revision
+*
+*-
+*--------------------------------------------------------
+ IMPLICIT NONE
+ SAVE
+*
+ character*13 here
+ parameter (here= 'T_clear_event')
+*
+ logical ABORT
+ character*(*) err
+*
+ INCLUDE 't20_data_structures.cmn'
+* INCLUDE 'hms_tracking.cmn'
+* INCLUDE 'hms_statistics.cmn'
+* INCLUDE 'hms_scin_parms.cmn'
+* INCLUDE 'hms_scin_tof.cmn'
+* INCLUDE 'hms_cer_parms.cmn'
+* INCLUDE 'hms_calorimeter.cmn'
+
+*
+c INTEGER plane,tube
+*
+*--------------------------------------------------------
+*
+ TMWPC_RAW_TOT_HITS = 0
+
+ THODO_TOT_HITS = 0
+
+ TMISC_TOT_HITS = 0
+
+ TTST_RAW_TOT_HITS = 0
+
+
+ ABORT= .FALSE.
+ err= ' '
+ RETURN
+ END
+
diff --git a/T20/t_dump_peds.f b/T20/t_dump_peds.f
new file mode 100644
index 0000000..f614244
--- /dev/null
+++ b/T20/t_dump_peds.f
@@ -0,0 +1,44 @@
+ subroutine t_dump_peds(ABORT,err)
+*
+* Look in h_dump_peds and s_dump_peds for examples
+*
+*
+* $Log: t_dump_peds.f,v $
+* Revision 1.1 1998/12/01 20:57:41 saw
+* Initial revision
+*
+ implicit none
+ save
+*
+ character*11 here
+ parameter (here='t_dump_peds')
+*
+ logical ABORT
+ character*(*) err
+*
+ character*132 file
+
+ integer*4 SPAREID
+ parameter (SPAREID=67)
+*
+ INCLUDE 't20_data_structures.cmn'
+ INCLUDE 't20_pedestals.cmn'
+ INCLUDE 't20_filenames.cmn'
+ INCLUDE 'gen_run_info.cmn'
+
+ if (t_pedestal_output_filename.ne.' ') then
+ file=t_pedestal_output_filename
+ call g_sub_run_number(file, gen_run_number)
+ open(unit=SPAREID,file=file,status='unknown')
+ else
+ return
+ endif
+
+ write(SPAREID,*) 'These are the values that were used for the analysis'
+ write(SPAREID,*) ' (from the param file or pedestal events)'
+ write(SPAREID,*)
+*
+ close(SPAREID)
+
+ return
+ end
diff --git a/T20/t_hms.f b/T20/t_hms.f
new file mode 100644
index 0000000..f1e479f
--- /dev/null
+++ b/T20/t_hms.f
@@ -0,0 +1,55 @@
+ SUBROUTINE t_hms(ABORT,err)
+*--------------------------------------------------------
+* $Log: t_hms.f,v $
+* Revision 1.1 1997/05/23 20:51:35 saw
+* Initial revision
+*
+*
+ IMPLICIT NONE
+ SAVE
+
+ character*(*) here
+ parameter (here= 't_hms')
+
+ logical ABORT
+ character*(*) err
+
+
+ INCLUDE 'gen_data_structures.cmn'
+ INCLUDE 'hms_data_structures.cmn'
+ INCLUDE 't20_data_structures.cmn'
+ INCLUDE 'gen_constants.par'
+ INCLUDE 't20_hms.cmn'
+ include 'hms_tracking.cmn'
+ include 'gen_event_info.cmn'
+ include 't20_misc.cmn'
+ integer*4 ihit
+
+* GPBEAM : beam momentun (GEV/C)
+* HSENERGY : Lab total energy of chosen track in GeV
+* HSDELTA : Spectrometer delta of chosen track
+* HSYP_TAR : hstheta = htheta_lab*pi/180. - hsyp_tar
+* HSTHETA : Lab Scattering angle in radians
+
+ if (hntracks_fp.gt.0) then !need at least one HMS track
+ tsinhtheta = sin(hstheta/2.)
+ te_v = sqrt(Gpbeam*Gpbeam + mass_electron*mass_electron)
+ thms_td1 = te_v - hsenergy
+ thms_td2 = te_v*(1. - 1./(1. + 2.*te_v*tsinhtheta**2/tpartmass))
+ tq2 = 2.*tpartmass*thms_td1
+ else
+ tsinhtheta = 0.
+ te_v = 0.
+ thms_td1 = 0.
+ thms_td2 = 0.
+ tq2 = 0.
+ endif
+ do ihit=1,HMISC_TOT_HITS
+ if(HMISC_RAW_ADDR1(ihit).eq.1) then ! hight precision tdc
+ if(HMISC_RAW_ADDR2(ihit).eq.10) hr_start_hms=HMISC_RAW_DATA(ihit)
+ endif
+ enddo
+
+
+ return
+ end
diff --git a/T20/t_hodos.f b/T20/t_hodos.f
new file mode 100644
index 0000000..def02e3
--- /dev/null
+++ b/T20/t_hodos.f
@@ -0,0 +1,84 @@
+ subroutine t_hodos(ABORT,err)
+*
+* $Log: t_hodos.f,v $
+* Revision 1.1 1998/12/01 20:56:31 saw
+* Initial revision
+*
+*--------------------------------------------------------
+ IMPLICIT NONE
+ SAVE
+*
+ character*12 here
+ parameter (here= '')
+*
+ logical ABORT
+ character*(*) err
+*
+ include 't20_data_structures.cmn'
+ include 't20_tracking.cmn'
+ include 't20_geometry.cmn'
+ include 't20_track_histid.cmn'
+ include 't20_bypass_switches.cmn'
+ include 't20_hodo.cmn'
+*--------------------------------------------------------
+c
+ integer*4 ibar, ihit, iplane
+ real*4 ribar, rch, rtdc
+* integer th_hodmaxbar(4) /30,30,24,24/
+c integer th_hodmaxbar(4) /60,60,60,60/ !temporary
+ integer th_hodmaxbar(4)
+ data th_hodmaxbar /60,60,60,60/ !temporary
+
+ ABORT= .FALSE.
+ err= ' '
+
+c----------------------------------------
+c ** fill th*pl*_tdc_i(ibar): most recent TDC value for each bar, each plane
+c ** fill th*pl*_tdc_all: for each plane, fill all tdc values into one hosto.
+
+ do ibar=1,60
+ th1p1_tdc_i(ibar)=0
+ th1p2_tdc_i(ibar)=0
+ th2p1_tdc_i(ibar)=0
+ th2p2_tdc_i(ibar)=0
+ enddo
+
+ do ihit=1,thodo_tot_hits
+ ibar=thodo_bar_num(ihit)
+ ribar=float(ibar)
+ iplane = thodo_plane_num(ihit)
+ if (ibar.le.0.or.ibar.gt.th_hodmaxbar(iplane)) then
+ write(6,*) 'shpl1 ibar=',ibar
+ else
+ rtdc= float(thodo_tdc_val(ihit))
+ rch = float((iplane-1)*30+ibar) !all 4 planes, offset by 30
+ call hf2(tidhod_allbars_vs_tdc,rch,rtdc,1.)!tdc vs bar for all 4 planes
+ if(iplane.eq.1)then
+ th1p1_tdc_i(ibar)=thodo_tdc_val(ihit)
+ call hf1(tidh1p1_tdc_all,ribar,1.)
+ endif
+ if(iplane.eq.2)then
+ th1p2_tdc_i(ibar)=thodo_tdc_val(ihit)
+ call hf1(tidh1p2_tdc_all,ribar,1.)
+ endif
+ if(iplane.eq.3)then
+ th2p1_tdc_i(ibar)=thodo_tdc_val(ihit)
+ call hf1(tidh2p1_tdc_all,ribar,1.)
+ endif
+ if(iplane.eq.4)then
+ th2p2_tdc_i(ibar)=thodo_tdc_val(ihit)
+ call hf1(tidh2p2_tdc_all,ribar,1.)
+ endif
+ endif
+ enddo
+c----------------------------------------
+
+ RETURN
+ END
+*********
+* Local Variables:
+* mode: fortran
+* fortran-if-indent: 2
+* fortran-do-indent: 2
+* End:
+
diff --git a/T20/t_init_histid.f b/T20/t_init_histid.f
new file mode 100644
index 0000000..4e2e3bb
--- /dev/null
+++ b/T20/t_init_histid.f
@@ -0,0 +1,200 @@
+ subroutine t_init_histid(abort,err)
+*
+* routine to get HBOOK histogram ID numbers for all hard coded
+* histograms.
+*
+* Author: S.A. Wood
+* Date: 23 Jan 1997
+*
+* $Log: t_init_histid.f,v $
+* Revision 1.1 1998/12/01 20:56:35 saw
+* Initial revision
+*
+*-
+*--------------------------------------------------------
+ IMPLICIT NONE
+*
+ character*13 here
+ parameter (here= 't_init_histid')
+*
+ logical ABORT
+ character*(*) err
+ external thgetid
+ integer*4 thgetid
+c integer*4 plane,counter
+*
+ include 't20_data_structures.cmn'
+ include 't20_hodo.cmn'
+ include 't20_tracking.cmn'
+c include 't20_track_histid.cmn'
+c include 't20_scin_parms.cmn'
+ include 't20_test_histid.cmn'
+ include 't20_misc.cmn'
+ include 'gen_misc.cmn'
+
+c character*32 histname
+c character*8 wiremap
+c character*10 drifttime
+c character*9 driftdis
+c character*9 wirecent
+c character*9 residual
+c character*9 singres
+c character*6 posadc,negadc,postdc,negtdc
+c character*6 sdcplanename(smax_num_dc_planes)
+c character*1 sscinplanenum(SNUM_SCIN_PLANES)
+c character*10 sscinplane
+c character*7 sposadc,snegadc,spostdc,snegtdc
+c character*7 sscinplanename(SNUM_SCIN_PLANES)
+c
+c data wiremap/'_wiremap'/
+c data drifttime/'_drifttime'/
+c data driftdis /'_driftdis'/
+c data wirecent/'_wirecent'/
+c data residual/'_residual'/
+c data singres/'_sing_res'/
+c data posadc /'posadc'/
+c data negadc /'negadc'/
+c data postdc /'postdc'/
+c data negtdc /'negtdc'/
+c data sdcplanename/'sdc1u1','sdc1u2','sdc1x1','sdc1x2','sdc1v1'
+c $ ,'sdc1v2','sdc2u1','sdc2u2','sdc2x1','sdc2x2','sdc2v1','sdc2v2'/
+c data sscinplanenum/'1','2','3','4'/
+c data sscinplane /'sscinplane'/
+c data sposadc /'sposadc'/
+c data snegadc /'snegadc'/
+c data spostdc /'spostdc'/
+c data snegtdc /'snegtdc'/
+c data sscinplanename/'sscin1x','sscin1y','sscin2x','sscin2y'/
+*
+ SAVE
+*--------------------------------------------------------
+*
+ ABORT= .FALSE.
+ err= ' '
+
+ ttst_hid_straw_wletdc = thgetid('ttst_letdc_wide')
+ ttst_hid_straw_letdc = thgetid('ttst_letdc')
+ ttst_hid_straw_width = thgetid('ttst_strawwidth')
+ ttst_hid_wg = thgetid('ttst_wg')
+
+c ttst_hid_strawmap(1) = thgetid('ttstwiremapx1')
+c ttst_hid_strawmap(2) = thgetid('ttstwiremapx2')
+c ttst_hid_strawmap(3) = thgetid('ttstwiremapx3')
+c ttst_hid_strawmap(4) = thgetid('ttstwiremapx4')
+c ttst_hid_strawmap(5) = thgetid('ttstwiremapy1')
+c ttst_hid_strawmap(6) = thgetid('ttstwiremapy2')
+c ttst_hid_strawmap(7) = thgetid('ttstwiremapy3')
+c ttst_hid_strawmap(8) = thgetid('ttstwiremapy4')
+ ttst_hid_strawmap = thgetid('ttst_straw_wiremaps')
+ ttst_hid_numhitsonplanes = thgetid('num_hits_on_all_planes')
+ ttst_hid_dmxchck = thgetid('ttst_demux_check')
+ ttst_hid_driftdist = thgetid('ttstdriftdist')
+ ttst_hid_driftdistv0 = thgetid('ttstdriftdistv0')
+ ttst_hid_drifttime = thgetid('ttstdrifttime')
+ ttst_hid_drifttimet0 = thgetid('ttstdrifttimet0')
+
+ ttst_hid_xoryhits =
+ + thgetid('ttststrawhitsinxory')
+ ttst_hid_evtstrcked =
+ + thgetid('ttststrawtrckd_vs_hits')
+c ttst_hid_strawres = thgetid('ttststrawres')
+ ttst_hid_strawres = thgetid('ttsttrackchisq')
+ ttst_hid_strawhitgd = thgetid('ttststrawgoodhit')
+ ttst_hid_strawhitbd = thgetid('ttststrawbadhit')
+ ttst_hid_strawhitms = thgetid('ttststrawmisshit')
+
+c ttst_hid_planeoffs(1) = thgetid('ttststrawoffpl1')
+c ttst_hid_planeoffs(2) = thgetid('ttststrawoffpl2')
+c ttst_hid_planeoffs(3) = thgetid('ttststrawoffpl3')
+c ttst_hid_planeoffs(4) = thgetid('ttststrawoffpl4')
+c ttst_hid_planeoffs(5) = thgetid('ttststrawoffpl5')
+c ttst_hid_planeoffs(6) = thgetid('ttststrawoffpl6')
+c ttst_hid_planeoffs(7) = thgetid('ttststrawoffpl7')
+c ttst_hid_planeoffs(8) = thgetid('ttststrawoffpl8')
+
+ ttst_hid_linoff(3) = thgetid('ttststrlinoffpl3')
+ ttst_hid_linoff(4) = thgetid('ttststrlinoffpl4')
+ ttst_hid_linoff(7) = thgetid('ttststrlinoffpl7')
+ ttst_hid_linoff(8) = thgetid('ttststrlinoffpl8')
+
+ ttst_hid_trackcode = thgetid('ttsttrackcode')
+ ttst_hid_trackcodet = thgetid('ttsttrackcodet')
+ ttst_hid_oot_thvx = thgetid('ttstoot-thvx-ch')
+ ttst_hid_oot_phvy = thgetid('ttstoot-phvy-ch')
+ ttst_hid_oot_yvx = thgetid('ttstoot-yvx-han')
+*
+c ** POLDER hodoscope information
+c * last tdc for each hodoscope in each plane
+c tidh1p1_tdc_i = thgetid('th1p1_tdc_i')
+c tidh1p2_tdc_i = thgetid('th1p2_tdc_i')
+c tidh2p1_tdc_i = thgetid('th2p1_tdc_i')
+c tidh2p2_tdc_i = thgetid('th2p2_tdc_i')
+c * all tdc values for all hodoscopes in one plane
+ tidh1p1_tdc_all = thgetid('th1p1_tdc_all')
+ tidh1p2_tdc_all = thgetid('th1p2_tdc_all')
+ tidh2p1_tdc_all = thgetid('th2p1_tdc_all')
+ tidh2p2_tdc_all = thgetid('th2p2_tdc_all')
+c * 2dim: all tdc vs all bars (any plane)
+ tidhod_allbars_vs_tdc = thgetid('tidhod_allbars_vs_tdc')
+c
+ tidmwpl1 = thgetid('tmwpl1')
+ tidmwpl2 = thgetid('tmwpl2')
+ tidmwpl3 = thgetid('tmwpl3')
+ tidmwpl4 = thgetid('tmwpl4')
+ tidmwpl5 = thgetid('tmwpl5')
+ tidmwpl6 = thgetid('tmwpl6')
+c
+ tidmwpl1_anytdc = thgetid('tmwpl1_anytdc')
+ tidmwpl2_anytdc = thgetid('tmwpl2_anytdc')
+ tidmwpl3_anytdc = thgetid('tmwpl3_anytdc')
+ tidmwpl4_anytdc = thgetid('tmwpl4_anytdc')
+ tidmwpl5_anytdc = thgetid('tmwpl5_anytdc')
+ tidmwpl6_anytdc = thgetid('tmwpl6_anytdc')
+c
+ tidmwpl1_tdc_vs_wire = thgetid('tmwpl1_tdc_vs_wire')
+ tidmwpl2_tdc_vs_wire = thgetid('tmwpl2_tdc_vs_wire')
+ tidmwpl3_tdc_vs_wire = thgetid('tmwpl3_tdc_vs_wire')
+ tidmwpl4_tdc_vs_wire = thgetid('tmwpl4_tdc_vs_wire')
+ tidmwpl5_tdc_vs_wire = thgetid('tmwpl5_tdc_vs_wire')
+ tidmwpl6_tdc_vs_wire = thgetid('tmwpl6_tdc_vs_wire')
+c
+cc tmwpl1_wire_mult = thgetid('tmwpl1_wire_mult')
+cc tmwpl2_wire_mult = thgetid('tmwpl2_wire_mult')
+cc tmwpl3_wire_mult = thgetid('tmwpl3_wire_mult')
+cc tmwpl4_wire_mult = thgetid('tmwpl4_wire_mult')
+cc tmwpl5_wire_mult = thgetid('tmwpl5_wire_mult')
+cc tmwpl6_wire_mult = thgetid('tmwpl6_wire_mult')
+c
+ tidmwpl1_multperwire = thgetid('tmwpl1_multperwire')
+ tidmwpl2_multperwire = thgetid('tmwpl2_multperwire')
+ tidmwpl3_multperwire = thgetid('tmwpl3_multperwire')
+ tidmwpl4_multperwire = thgetid('tmwpl4_multperwire')
+ tidmwpl5_multperwire = thgetid('tmwpl5_multperwire')
+ tidmwpl6_multperwire = thgetid('tmwpl6_multperwire')
+
+c t_rwirepl7 = thgetid('t_rwirepl7')
+c t_rwirepl8 = thgetid('t_rwirepl8')
+c t_rwirepl9 = thgetid('t_rwirepl9')
+c t_lwirepl7 = thgetid('t_lwirepl7')
+c t_lwirepl8 = thgetid('t_lwirepl8')
+c t_lwirepl9 = thgetid('t_lwirepl9')
+
+c tmwpc3sumpl7 = thgetid('tmwpc3sumpl7')
+c tmwpc3sumpl8 = thgetid('tmwpc3sumpl8')
+c tmwpc3sumpl9 = thgetid('tmwpc3sumpl9')
+c tmwpc3diffpl7 = thgetid('tmwpc3diffpl7')
+c tmwpc3diffpl8 = thgetid('tmwpc3diffpl8')
+c tmwpc3diffpl9 = thgetid('tmwpc3diffpl9')
+
+ g_scal_his1 = thgetid('g_scal_his1')
+ g_scal_his2 = thgetid('g_scal_his2')
+ g_scal_his3 = thgetid('g_scal_his3')
+ g_scal_his4 = thgetid('g_scal_his4')
+ g_scal_his5 = thgetid('g_scal_his5')
+ g_scal_his6 = thgetid('g_scal_his6')
+ g_scal_his7 = thgetid('g_scal_his7')
+ g_scal_his8 = thgetid('g_scal_his8')
+c
+ RETURN
+ END
+
diff --git a/T20/t_init_physics.f b/T20/t_init_physics.f
new file mode 100644
index 0000000..a04da2d
--- /dev/null
+++ b/T20/t_init_physics.f
@@ -0,0 +1,69 @@
+ SUBROUTINE t_init_physics(ABORT,err)
+*--------------------------------------------------------
+*-
+*- Purpose and Methods : Initialize constants for s_physics
+*-
+*-
+*- Output: ABORT - success or failure
+*- : err - reason for failure, if any
+*-
+*- Created 6-6-94 D. F. Geesaman
+* $Log: t_init_physics.f,v $
+* Revision 1.1 1998/12/01 20:56:44 saw
+* Initial revision
+*
+* Revision 1.5 1996/09/05 19:54:16 saw
+* (JRA) avoid setting p=0??
+*
+* Revision 1.4 1996/01/24 16:07:34 saw
+* (JRA) Change upper case to lower case, cebeam to gebeam
+*
+* Revision 1.3 1995/05/22 19:45:41 cdaq
+* (SAW) Split gen_data_data_structures into gen, hms, sos, and coin parts"
+*
+* Revision 1.2 1995/05/11 17:07:14 cdaq
+* (SAW) Fix SOS to be in plane, beam left
+*
+* Revision 1.1 1994/06/14 04:09:12 cdaq
+* Initial revision
+*
+*--------------------------------------------------------
+ IMPLICIT NONE
+ SAVE
+*
+ character*14 here
+ parameter (here= 't_init_physics')
+*
+ logical ABORT
+ character*(*) err
+*
+ INCLUDE 'gen_data_structures.cmn'
+ INCLUDE 't20_data_structures.cmn'
+ INCLUDE 'gen_constants.par'
+ INCLUDE 'gen_units.par'
+c INCLUDE 't20_physics_sing.cmn'
+*
+* local variables
+*--------------------------------------------------------
+*
+ ABORT= .FALSE.
+ err= ' '
+*
+* Fix SOS to be in plane, beam left
+*
+c sphi_lab = tt/2
+c*
+c if (smomentum_factor .gt. 0.1) then !avoid setting p=0
+c spcentral = spcentral * smomentum_factor
+c endif
+c*
+c cossthetas = cos(stheta_lab)
+c sinsthetas = sin(stheta_lab)
+c* Constants for elastic kinematics calcultion
+c sphysicsa = 2.*gebeam*gtarg_mass(gtarg_num) -
+c $ mass_electron**2 - spartmass**2
+c sphysicsb = 2. * (gtarg_mass(gtarg_num) - gebeam)
+c sphysicab2 = sphysicsa**2 * sphysicsb**2
+c sphysicsm3b = spartmass**2 * sphysicsb**2
+ return
+ end
diff --git a/T20/t_initialize.f b/T20/t_initialize.f
new file mode 100644
index 0000000..bc9c93a
--- /dev/null
+++ b/T20/t_initialize.f
@@ -0,0 +1,94 @@
+ SUBROUTINE t_initialize(ABORT,err)
+*--------------------------------------------------------
+*- Prototype C analysis routine
+*-
+*-
+*- Purpose and Methods : Initializes T20 quantities
+*-
+*- Output: ABORT - success or failure
+*- : err - reason for failure, if any
+*-
+*- Created 22-Jan-1997 Stephen A. Wood
+* $Log: t_initialize.f,v $
+* Revision 1.1 1998/12/01 20:56:51 saw
+* Initial revision
+*
+*-
+*- All standards are from "Proposal for Hall C Analysis Software
+*- Vade Mecum, Draft 1.0" by D.F.Geesamn and S.Wood, 7 May 1993
+*-
+*--------------------------------------------------------
+ IMPLICIT NONE
+ SAVE
+*
+ character*12 here
+ parameter (here= 't_initialize')
+*
+ include 't20_bypass_switches.cmn'
+*
+
+ logical ABORT
+ character*(*) err
+c character*20 err1
+c integer*4 istat
+*
+ logical FAIL
+ character*1000 why
+*SDISPLAY*
+*SDISPLAY include 'one_ev_io.cmn'
+*
+*--------------------------------------------------------
+ ABORT = .FALSE.
+ err= ' '
+*
+*-calculate physics singles constants
+ call t_init_physics(FAIL,why)
+ if(err.NE.' ' .and. why.NE.' ') then
+ call G_append(err,' & '//why)
+ elseif(why.NE.' ') then
+ err= why
+ endif
+ ABORT= ABORT .or. FAIL
+
+ if (tbypass_polder.ge.0 .and. tbypass_polder.lt.4) then
+ call t_polder_initialize(FAIL,why)
+ if(why.NE.' ') then
+ err= why
+ endif
+ ABORT= ABORT .or. FAIL
+ endif
+
+*
+*
+c call s_generate_geometry ! Tracking routine
+*
+c call s_initialize_fitting ! Minuit initialization
+*
+*-calculate secondary scintillator and time of flight parameters
+c call s_init_scin(FAIL,why)
+c if(why.NE.' ') then
+c err= why
+c endif
+c ABORT= ABORT .or. FAIL
+*
+*SDISPLAY* If one_ev flag on, initialize the event display package
+* if(one_ev.ne.0) call one_ev_init !One event display unit
+*
+*
+*-read in Optical matrix elements
+c call s_targ_trans_init(FAIL,why,istat)
+c if(FAIL) then
+c write(err1,'(":istat=",i2)') istat
+c call G_prepend(err1,why)
+c endif
+c if(err.NE.' ' .and. why.NE.' ') then !keep warnings
+c call G_append(err,' & '//why)
+c elseif(why.NE.' ') then
+c err= why
+c endif
+c ABORT= ABORT .or. FAIL
+*
+ if(ABORT .or. err.NE.' ') call g_add_path(here,err)
+*
+ return
+ end
diff --git a/T20/t_misc.f b/T20/t_misc.f
new file mode 100644
index 0000000..430d855
--- /dev/null
+++ b/T20/t_misc.f
@@ -0,0 +1,160 @@
+ subroutine T_MISC(ABORT,err)
+*
+* $Log: t_misc.f,v $
+* Revision 1.1 1998/12/01 20:57:23 saw
+* Initial revision
+*
+*--------------------------------------------------------
+ IMPLICIT NONE
+ SAVE
+*
+ character*12 here
+ parameter (here= '')
+*
+ logical ABORT
+ character*(*) err
+*
+ include 't20_data_structures.cmn'
+ include 't20_tracking.cmn'
+ include 't20_geometry.cmn'
+ include 't20_track_histid.cmn'
+ include 't20_bypass_switches.cmn'
+ include 't20_misc.cmn'
+C include 't20_reg_polder_structures.cmn'
+C==============================================================================
+C THIS ROUTINE TAKES CARE OF THE POLDER "MISCELANEOUS" DETECTOR PACKAGE:
+C THE PARTS OF THE E-POLDER EVENTS READ OUTUPSTAIRS INTO THE
+C ADCs and TDCs OF ROC (WHAT STEVE SAYS IT IS)
+
+
+ integer*4 ihit,iaddr1,iaddr2
+
+ traw_adc_s11 = 0.
+ traw_adc_s12 = 0.
+ traw_adc_s21 = 0.
+ traw_adc_s22 = 0.
+ traw_adc_veto1 = 0.
+ traw_adc_veto2 = 0.
+ traw_adc_tts1l = 0.
+ traw_adc_tts1r = 0.
+ traw_adc_tts2l = 0.
+ traw_adc_tts2r = 0.
+c
+ tfl_mhtdc_dc = 0.
+ tfl_mhtdc_hms = 0.
+ tfl_mhtdc_hms_dc = 0.
+ tfl_mhtdc_big1 = 0.
+ tfl_mhtdc_ce = 0.
+ tfl_mhtdc_polder = 0.
+ tfl_mhtdc_h1m3 = 0.
+ tfl_mhtdc_h2m3 = 0.
+ traw_mhtdc_s11 = 0.
+ traw_mhtdc_s12 = 0.
+ traw_mhtdc_s21 = 0.
+ traw_mhtdc_s22 = 0.
+ traw_mhtdc_s1 = 0.
+ traw_mhtdc_s2 = 0.
+ traw_mhtdc_veto = 0.
+c
+ traw_hrtdc_hms = 0.
+ traw_hrtdc_dc = 0.
+ traw_hrtdc_hms_dc = 0.
+ traw_hrtdc_polder = 0.
+ traw_hrtdc_hms_nb = 0.
+ traw_hrtdc_pldr_nb = 0.
+ traw_hrtdc_ce = 0.
+
+ do ihit=1,tmisc_tot_hits
+ iaddr1=tmisc_raw_addr1(ihit) ! iaddr1=1 for ADC, =2 for MHTDCs, and =3 for HRTDC
+ iaddr2=tmisc_raw_addr2(ihit)
+c
+ if((iaddr1.ne.1).and.(iaddr1.ne.2).and.(iaddr1.ne.3))then
+ write(6,*)'There is a problem in t_misc: iaddr1 = ',iaddr1
+ goto 100
+ endif
+C-------------------------------------------------------------------------------------
+C***** THE ADC (LECROY 1881M - UPSTAIRS)
+ if (iaddr1.eq.1) then
+ if ((iaddr2.lt.1).or.(iaddr2.gt.32)) then
+ write(6,*)'There is a problem in t_misc: for iaddr1=1, iaddr2=',iaddr2
+ goto 25
+ else
+C THE START AND VETO DETECTORS
+ if (iaddr2.eq.1) traw_adc_s11=tmisc_raw_data(ihit)
+ if (iaddr2.eq.2) traw_adc_s12=tmisc_raw_data(ihit)
+ if (iaddr2.eq.3) traw_adc_s21=tmisc_raw_data(ihit)
+ if (iaddr2.eq.4) traw_adc_s22=tmisc_raw_data(ihit)
+ if (iaddr2.eq.5) traw_adc_veto1=tmisc_raw_data(ihit)
+ if (iaddr2.eq.6) traw_adc_veto2=tmisc_raw_data(ihit)
+ if (iaddr2.eq.7) traw_adc_tts1l=tmisc_raw_data(ihit)
+ if (iaddr2.eq.8) traw_adc_tts1r=tmisc_raw_data(ihit)
+ if (iaddr2.eq.9) traw_adc_tts2l=tmisc_raw_data(ihit)
+ if (iaddr2.eq.10) traw_adc_tts2r=tmisc_raw_data(ihit)
+C THERE ARE 6 "SPARE" CHANNELS AVAILABLE IN THE ADC (LECROY 1881M),
+ if ((iaddr2.gt.10).and.(iaddr2.le.32)) then
+ traw_adc(iaddr2)=tmisc_raw_data(ihit)
+ endif
+ endif
+ endif
+C--------------------------------------------------------------------------------------
+C***** THE MULTIHIT TDCs (LECROY 1877S - UPSTAIRS AND DOWNSTAIRS)
+25 continue
+ if (iaddr1.eq.2) then
+ if ((iaddr2.lt.1).or.(iaddr2.gt.32))then
+ write(6,*)'There is a problem in t_misc: for iaddr1=2, iaddr2=',iaddr2
+ goto 50
+ else
+ if (iaddr2.eq.1) tfl_mhtdc_dc = tmisc_raw_data(ihit)
+ if (iaddr2.eq.2) tfl_mhtdc_hms = tmisc_raw_data(ihit)
+ if (iaddr2.eq.3) tfl_mhtdc_hms_dc = tmisc_raw_data(ihit)
+ if (iaddr2.eq.4) tfl_mhtdc_big1 = tmisc_raw_data(ihit)
+ if (iaddr2.eq.5) tfl_mhtdc_ce = tmisc_raw_data(ihit)
+ if (iaddr2.eq.6) tfl_mhtdc_polder = tmisc_raw_data(ihit)
+ if (iaddr2.eq.7) tfl_mhtdc_h1m3 = tmisc_raw_data(ihit)
+ if (iaddr2.eq.8) tfl_mhtdc_h2m3 = tmisc_raw_data(ihit)
+ if (iaddr2.eq.9) traw_mhtdc_s11 = tmisc_raw_data(ihit)
+ if (iaddr2.eq.10) traw_mhtdc_s12 = tmisc_raw_data(ihit)
+ if (iaddr2.eq.11) traw_mhtdc_s21 = tmisc_raw_data(ihit)
+ if (iaddr2.eq.12) traw_mhtdc_s22 = tmisc_raw_data(ihit)
+ if (iaddr2.eq.13) traw_mhtdc_s1 = tmisc_raw_data(ihit)
+ if (iaddr2.eq.14) traw_mhtdc_s2 = tmisc_raw_data(ihit)
+ if (iaddr2.eq.15) traw_mhtdc_veto = tmisc_raw_data(ihit)
+ endif
+ endif
+C--------------------------------------------------------------------------------------
+C***** THE HIGH RESOLUTION TDC (I CHOSE 16 CHANNEL FOR NOW) UPSTAIRS
+50 if (iaddr1.eq.3) then
+ if ((iaddr2.lt.1).or.(iaddr2.gt.8)) then
+c write(6,*)'There is a problem in t_misc: for iaddr1=3, iaddr2=',iaddr2
+ goto 100
+ endif
+ if((iaddr2.ne.2).and.(iaddr2.ne.4).and.(iaddr2.ne.6)) then
+c write(6,*)'t_misc: in the mhtdc part. iaddr2 = ',iaddr2,ihit ,tmisc_raw_data(ihit)
+ endif
+ if(iaddr2.eq.1)traw_hrtdc_hms = tmisc_raw_data(ihit)
+ if(iaddr2.eq.2)traw_hrtdc_dc = tmisc_raw_data(ihit)
+ if(iaddr2.eq.3)traw_hrtdc_hms_dc = tmisc_raw_data(ihit)
+ if(iaddr2.eq.4)traw_hrtdc_polder = tmisc_raw_data(ihit)
+ if(iaddr2.eq.5)traw_hrtdc_hms_nb = tmisc_raw_data(ihit)
+ if(iaddr2.eq.6)traw_hrtdc_pldr_nb = tmisc_raw_data(ihit)
+ if(iaddr2.eq.7)traw_hrtdc_ce = tmisc_raw_data(ihit)
+ endif
+C-------------------------------------------------------------------------------------
+100 continue
+ enddo
+c
+C***** now do a few combinations of ADCs and TDCs
+ traw_adc_s1sum = traw_adc_s11 + traw_adc_s12
+ traw_adc_s2sum = traw_adc_s21 + traw_adc_s22
+ traw_adc_s1s2sum = traw_adc_s2sum + traw_adc_s1sum
+ traw_adc_vetosum = traw_adc_veto1 + traw_adc_veto2
+c
+ RETURN
+ END
+*********
+* Local Variables:
+* mode: fortran
+* fortran-if-indent: 2
+* fortran-do-indent: 2
+* End:
+
diff --git a/T20/t_mwpc.f b/T20/t_mwpc.f
new file mode 100644
index 0000000..becae07
--- /dev/null
+++ b/T20/t_mwpc.f
@@ -0,0 +1,190 @@
+ subroutine t_mwpc(ABORT,err)
+*
+* $Log: t_mwpc.f,v $
+* Revision 1.1 1998/12/01 20:55:18 saw
+* Initial revision
+*
+*--------------------------------------------------------
+ IMPLICIT NONE
+ SAVE
+*
+ character*12 here
+ parameter (here= 't_trans_mwpc')
+*
+ logical ABORT
+ character*(*) err
+*
+ include 't20_data_structures.cmn'
+ include 't20_tracking.cmn'
+ include 't20_geometry.cmn'
+ include 't20_track_histid.cmn'
+ include 't20_bypass_switches.cmn'
+ include 't20_hodo.cmn'
+*--------------------------------------------------------
+
+ integer*4 hitperw(158,9)
+ integer*4 iwire, iplane, ihit
+ integer*4 itdc
+ real*4 rwire, rhit
+ real*4 rtdc
+
+ ABORT= .FALSE.
+ err= ' '
+
+c----------------
+c ** fill user histograms: tPl1_anytdc, tPl1_tdc_vs_wire
+c and CTP variables tMwpc_pl* with last TDC value for each wire
+ do iwire=1,158
+ do iplane = 1,9
+ hitperw(iwire,iplane) = 0
+ enddo
+ tMwpc_pl1(iwire)=0
+ tMwpc_pl2(iwire)=0
+ tMwpc_pl3(iwire)=0
+ tMwpc_pl4(iwire)=0
+ tMwpc_pl5(iwire)=0
+ tMwpc_pl6(iwire)=0
+ enddo
+ tmwpl1_wire_mult=0
+ tmwpl2_wire_mult=0
+ tmwpl3_wire_mult=0
+ tmwpl4_wire_mult=0
+ tmwpl5_wire_mult=0
+ tmwpl6_wire_mult=0
+
+ if (tmwpc_raw_tot_hits.gt.300) then
+ write (6,*) 't_mwpc: total hits:', tmwpc_raw_tot_hits
+ endif
+ do ihit=1,tmwpc_raw_tot_hits
+ iplane = tmwpc_raw_plane_num(ihit)
+ iwire=tmwpc_raw_wire_num(ihit)
+ rwire=float(iwire)
+ itdc=tmwpc_raw_tdc(ihit)
+ rtdc=float(itdc)
+C
+CC Some tests
+ if(iplane.lt.1.or.iplane.gt.9)then
+ write(6,*)'t_mwpc: You have a bad plane number: ',iplane
+ endif
+ if(iwire.lt.1.or.iwire.gt.158)then
+ write(6,*)'t_mwpc: You have a bad wire number: ',iwire,'in plane: ',iplane
+ else
+cc
+ if (itdc.ne.0) hitperw(iwire,iplane)=hitperw(iwire,iplane)+1
+ if(iplane.eq.1)then
+ if (tMwpc_pl1(iwire).eq.0) then !only fill once a wire
+ tmwpl1_wire_mult=tmwpl1_wire_mult+1
+ endif
+ tMwpc_pl1(iwire)=itdc
+ call hf1(tidmwpl1_anytdc,rtdc,1.)
+ call hf2(tidmwpl1_tdc_vs_wire,rwire,rtdc,1.)
+ call hf1(tidmwpl1,rwire,1.)
+ endif
+ if(iplane.eq.2)then
+ if (tMwpc_pl2(iwire).eq.0) then !only fill once a wire
+ tmwpl2_wire_mult=tmwpl2_wire_mult+1
+ endif
+ tMwpc_pl2(iwire)=itdc
+ call hf1(tidmwpl2_anytdc,rtdc,1.)
+ call hf2(tidmwpl2_tdc_vs_wire,rwire,rtdc,1.)
+ call hf1(tidmwpl2,rwire,1.)
+ endif
+ if(iplane.eq.3)then
+ if (tMwpc_pl3(iwire).eq.0) then !only fill once a wire
+ tmwpl3_wire_mult=tmwpl3_wire_mult+1
+ endif
+ tMwpc_pl3(iwire)=itdc
+ call hf1(tidmwpl3_anytdc,rtdc,1.)
+ call hf2(tidmwpl3_tdc_vs_wire,rwire,rtdc,1.)
+ call hf1(tidmwpl3,rwire,1.)
+ endif
+ if(iplane.eq.4)then
+ if (tMwpc_pl4(iwire).eq.0) then !only fill once a wire
+ tmwpl4_wire_mult=tmwpl4_wire_mult+1
+ endif
+ tMwpc_pl4(iwire)=itdc
+ call hf1(tidmwpl4_anytdc,rtdc,1.)
+ call hf2(tidmwpl4_tdc_vs_wire,rwire,rtdc,1.)
+ call hf1(tidmwpl4,rwire,1.)
+ endif
+ if(iplane.eq.5)then
+ if (tMwpc_pl5(iwire).eq.0) then !only fill once a wire
+ tmwpl5_wire_mult=tmwpl5_wire_mult+1
+ endif
+ tMwpc_pl5(iwire)=itdc
+ call hf1(tidmwpl5_anytdc,rtdc,1.)
+ call hf2(tidmwpl5_tdc_vs_wire,rwire,rtdc,1.)
+ call hf1(tidmwpl5,rwire,1.)
+ endif
+ if(iplane.eq.6)then
+ if (tMwpc_pl6(iwire).eq.0) then !only fill once a wire
+ tmwpl6_wire_mult=tmwpl6_wire_mult+1
+ endif
+ tMwpc_pl6(iwire)=itdc
+ call hf1(tidmwpl6_anytdc,rtdc,1.)
+ call hf2(tidmwpl6_tdc_vs_wire,rwire,rtdc,1.)
+ call hf1(tidmwpl6,rwire,1.)
+ endif
+
+C******** mwpc3
+
+ if(iplane.ge.1.and.iplane.le.6)goto 100
+ if(iwire.ne.1.and.iwire.ne.2)then
+ write(6,*)'t_mwpc: You have a bad wire number in chamber3: ',iwire,'in plane: ',iplane
+ endif
+ if(iplane.eq.7)then
+ if(iwire.eq.1)then
+ t_r_wire_pl7=rtdc
+ call hf1(t_rwirepl7,rtdc,1.)
+ else
+ t_l_wire_pl7=rtdc
+ call hf1(t_lwirepl7,rtdc,1.)
+ endif
+ endif
+ if(iplane.eq.8)then
+ if(iwire.eq.1)then
+ t_r_wire_pl8=rtdc
+ call hf1(t_rwirepl8,rtdc,1.)
+ else
+ t_l_wire_pl8=rtdc
+ call hf1(t_lwirepl8,rtdc,1.)
+ endif
+ endif
+ if(iplane.eq.9)then
+ if(iwire.eq.1)then
+ t_r_wire_pl9=rtdc
+ call hf1(t_rwirepl9,rtdc,1.)
+ else
+ t_l_wire_pl9=rtdc
+ call hf1(t_lwirepl9,rtdc,1.)
+ endif
+ endif
+C Some tmwpc3 sums and differences
+ tmwpc3sumpl7=t_r_wire_pl7+t_l_wire_pl7
+ tmwpc3diffpl7=t_r_wire_pl7-t_l_wire_pl7
+ tmwpc3sumpl8=t_r_wire_pl8+t_l_wire_pl8
+ tmwpc3diffpl8=t_r_wire_pl8-t_l_wire_pl8
+ tmwpc3sumpl9=t_r_wire_pl9+t_l_wire_pl9
+ tmwpc3diffpl9=t_r_wire_pl9-t_l_wire_pl9
+
+
+100 endif
+ enddo
+c ** copy hits per wire into user array
+ do iwire = 1,158
+ rhit = float(hitperw(iwire,1))
+ call hf1(tidmwpl1_MultPerWire,rhit,1.)
+ rhit = float(hitperw(iwire,2))
+ call hf1(tidmwpl2_MultPerWire,rhit,1.)
+ rhit = float(hitperw(iwire,3))
+ call hf1(tidmwpl3_MultPerWire,rhit,1.)
+ rhit = float(hitperw(iwire,4))
+ call hf1(tidmwpl4_MultPerWire,rhit,1.)
+ rhit = float(hitperw(iwire,5))
+ call hf1(tidmwpl5_MultPerWire,rhit,1.)
+ rhit = float(hitperw(iwire,6))
+ call hf1(tidmwpl6_MultPerWire,rhit,1.)
+ enddo
+*
+ RETURN
+ END
diff --git a/T20/t_ntuple.cmn b/T20/t_ntuple.cmn
new file mode 100644
index 0000000..371219d
--- /dev/null
+++ b/T20/t_ntuple.cmn
@@ -0,0 +1,38 @@
+**************************begin: s_Ntuple.cmn ***********************
+*-
+*- Created 22-Jan-1997 Stephen A. Wood
+*........................................................................
+*- Misc. info. required for T20 Ntuple
+* $Log: t_ntuple.cmn,v $
+* Revision 1.1 1998/12/01 21:01:41 saw
+* Initial revision
+*
+*
+ integer TMAX_Ntuple_size
+ parameter (TMAX_Ntuple_size= 100)
+ integer default_t_Ntuple_ID
+ parameter (default_t_Ntuple_ID= 9030)
+*
+* CTPTYPE=parm
+*
+ logical t_Ntuple_exists
+ integer t_Ntuple_ID
+ integer t_Ntuple_size
+ integer t_Ntuple_IOchannel
+ character*80 t_Ntuple_name
+ character*80 t_Ntuple_title
+ character*132 t_Ntuple_directory
+ character*256 t_Ntuple_file
+ character*8 t_Ntuple_tag(TMAX_Ntuple_size)
+*
+* CTPTYPE=event
+*
+ real t_Ntuple_contents(TMAX_Ntuple_size)
+*
+ COMMON /T20_Ntuple/ t_Ntuple_exists,t_Ntuple_ID,
+ & t_Ntuple_size,t_Ntuple_IOchannel,
+ & t_Ntuple_name,t_Ntuple_title,
+ & t_Ntuple_directory,t_Ntuple_file,
+ & t_Ntuple_tag,t_Ntuple_contents
+*
+****************************end: t_ntuple.cmn ***********************
diff --git a/T20/t_ntuple_register.f b/T20/t_ntuple_register.f
new file mode 100644
index 0000000..851b340
--- /dev/null
+++ b/T20/t_ntuple_register.f
@@ -0,0 +1,43 @@
+ subroutine t_Ntuple_register(ABORT,err)
+*----------------------------------------------------------------------
+*
+* CTP variable registration routine for the SOS Ntuples
+*
+* Purpose : Register output filename for SOS Ntuple; temporary
+* implementation to be superceeded by CTP Ntuples
+*
+* Output: ABORT - success or failure
+* : err - reason for failure, if any
+*
+* Created: 8-Apr-1994 K.B.Beard, HU: added Ntuples
+* $Log: t_ntuple_register.f,v $
+* Revision 1.1 1998/12/01 20:56:56 saw
+* Initial revision
+*
+*----------------------------------------------------------------------
+ implicit none
+ save
+*
+ character*17 here
+ parameter (here='t_Ntuple_register')
+*
+ logical ABORT
+ character*(*) err
+*
+ INCLUDE 't_ntuple.cmn'
+ INCLUDE 'gen_routines.dec'
+*
+ integer ierr
+*--------------------------------------------------------
+ err= ' '
+ ABORT = .FALSE.
+*
+ call G_reg_C('T20_Ntuple',t_Ntuple_file,ABORT,err)
+*
+ IF(ABORT) THEN
+ call G_prepend(':unable to register-',err)
+ call G_add_path(here,err)
+ ENDIF
+*
+ return
+ end
diff --git a/T20/t_proper_shutdown.f b/T20/t_proper_shutdown.f
new file mode 100644
index 0000000..f7828f5
--- /dev/null
+++ b/T20/t_proper_shutdown.f
@@ -0,0 +1,81 @@
+ SUBROUTINE T_proper_shutdown(lunout,ABORT,err)
+*--------------------------------------------------------
+*- T20 end of run analysis
+*-
+*-
+*- Purpose and Methods : Closes files properly, flushes, etc.
+*-
+*- Output: ABORT - success or failure
+*- : err - reason for failure, if any
+*-
+*- Created 23-Jan-1997 Stephen A. Wood
+* $Log: t_proper_shutdown.f,v $
+* Revision 1.1 1998/12/01 20:57:27 saw
+* Initial revision
+*
+*- All standards are from "Proposal for Hall C Analysis Software
+*- Vade Mecum, Draft 1.0" by D.F.Geesamn and S.Wood, 7 May 1993
+*-
+*--------------------------------------------------------
+ IMPLICIT NONE
+ SAVE
+*
+ include 'gen_routines.dec'
+ include 'gen_filenames.cmn'
+ include 'gen_run_info.cmn'
+ include 't20_filenames.cmn'
+ include 't20_bypass_switches.cmn'
+*
+ character*17 here
+ parameter (here= 't_proper_shutdown')
+*
+ logical ABORT, report_abort
+ character*(*) err
+*
+ integer ierr
+ character*132 file
+ integer lunout
+*--------------------------------------------------------
+*- chance to flush any statistics, etc.
+*
+*
+ ABORT= .FALSE.
+ err= ' '
+
+ call t_polder_shutdown(ABORT,err)
+*
+c if (tbypass_dc_eff.eq.0) then
+c call t_dc_eff_shutdown(lunout,ABORT,err)
+c call t_dc_trk_eff_shutdown(lunout,ABORT,err)
+c endif
+c*
+c if (tbypass_scin_eff.eq.0) call tscin_eff_shutdown(lunout,ABORT,err)
+c*
+c if (tbypass_cer_eff.eq.0) call t_eff_shutdown(lunout,ABORT,err)
+c*
+c if (tbypass_cal_eff.eq.0) call t_cal_eff_shutdown(ABORT,err)
+c*
+c call t_report_bad_data(lunout,ABORT,err)
+c*
+ if(t_report_blockname.ne.' '.and.
+ $ t_report_output_filename.ne.' ') then
+
+ file = t_report_output_filename
+ call g_sub_run_number(file, gen_run_number)
+
+ ierr = threp(t_report_blockname, file)
+ if(ierr.ne.0) then
+ call g_append(err,'& threp failed to create report in file'//file)
+ report_abort = .true.
+ endif
+ endif
+*
+ IF(ABORT.or.report_abort) THEN
+ call G_add_path(here,err)
+ ELSE
+ err= ' '
+ ENDIF
+*
+ RETURN
+ END
+
diff --git a/T20/t_prt_raw_hodo.f b/T20/t_prt_raw_hodo.f
new file mode 100644
index 0000000..1ea0fb0
--- /dev/null
+++ b/T20/t_prt_raw_hodo.f
@@ -0,0 +1,45 @@
+ SUBROUTINE t_prt_raw_hodo(ABORT,err)
+*--------------------------------------------------------
+*-
+*- Purpose and Methods : Dump POLDER_RAW_HODO BANKS
+*-
+*- Required Input BANKS POLDER_RAW_HODO
+*-
+*- Output: ABORT - success or failure
+*- : err - reason for failure, if any
+*-
+*- Created 25-JAN-1997 S. A. Wood
+* $Log: t_prt_raw_hodo.f,v $
+* Revision 1.1 1998/12/01 20:57:05 saw
+* Initial revision
+*
+*--------------------------------------------------------
+ IMPLICIT NONE
+ SAVE
+*
+ character*14 here
+ parameter (here= 't_prt_raw_hodo')
+*
+ logical ABORT
+ character*(*) err
+*
+ integer*4 j
+ include 't20_data_structures.cmn'
+ include 'gen_constants.par'
+ include 'gen_units.par'
+ include 't20_tracking.cmn'
+ include 't20_hodo_parms.cmn'
+*
+*--------------------------------------------------------
+ ABORT = .FALSE.
+ err = ' '
+ write(tluno,'('' POLDER_RAW_HODO BANKS'')')
+ write(tluno,'('' THODO_TOT_HITS='',I4)') THODO_TOT_HITS
+ if(THODO_TOT_HITS.GT.0) then
+ write(tluno,'('' Num Plane Bar TDC'')')
+ write(tluno,'(1x,i2,2x,i3,7x,i4,8x,i10)')
+ & (j,THODO_PLANE_NUM(j),THODO_BAR_NUM(j),
+ $ THODO_TDC_VAL(j),j=1,THODO_TOT_HITS )
+ endif
+ RETURN
+ END
diff --git a/T20/t_prt_raw_mwpc.f b/T20/t_prt_raw_mwpc.f
new file mode 100644
index 0000000..4cac6a2
--- /dev/null
+++ b/T20/t_prt_raw_mwpc.f
@@ -0,0 +1,45 @@
+ SUBROUTINE t_prt_raw_mwpc(ABORT,err)
+*--------------------------------------------------------
+*-
+*- Purpose and Methods : Dump POLDER_RAW_MWPC BANKS
+*-
+*- Required Input BANKS POLDER_RAW_MWPC
+*-
+*- Output: ABORT - success or failure
+*- : err - reason for failure, if any
+*-
+*- Created 25-Jan-1997 S. A. Wood
+* $Log: t_prt_raw_mwpc.f,v $
+* Revision 1.1 1998/12/01 20:57:33 saw
+* Initial revision
+*
+*--------------------------------------------------------
+ IMPLICIT NONE
+ SAVE
+*
+ character*14 here
+ parameter (here= 't_prt_raw_mwpc')
+*
+ logical ABORT
+ character*(*) err
+*
+ integer*4 j
+ include 't20_data_structures.cmn'
+ include 'gen_constants.par'
+ include 'gen_units.par'
+ include 't20_tracking.cmn'
+c include 'hms_geometry.cmn'
+*
+*--------------------------------------------------------
+ ABORT = .FALSE.
+ err = ' '
+ write(tluno,'('' POLDER_RAW_MWPC BANKS'')')
+ write(tluno,'('' TMWPC_RAW_TOT_HITS='',I4)') TMWPC_RAW_TOT_HITS
+ if(TMWPC_RAW_TOT_HITS.GT.0) then
+ write(tluno,'('' Num Plane Wire TDC Value'')')
+ write(tluno,'(1x,i2,2x,i3,7x,i4,5x,i10)')
+ & (j,TMWPC_RAW_PLANE_NUM(j),TMWPC_RAW_WIRE_NUM(j),
+ & TMWPC_RAW_TDC(j),j=1,TMWPC_RAW_TOT_HITS)
+ endif
+ RETURN
+ END
diff --git a/T20/t_raw_dump_all.f b/T20/t_raw_dump_all.f
new file mode 100644
index 0000000..49d9675
--- /dev/null
+++ b/T20/t_raw_dump_all.f
@@ -0,0 +1,44 @@
+ SUBROUTINE t_raw_dump_all(ABORT,err)
+*--------------------------------------------------------
+*-
+*- Purpose and Methods : Dump all raw T20 banks
+*-
+*- Required Input BANKS SOS_RAW_SCIN,SOS_RAW_CAL,SOS_RAW_DC
+*-
+*- Output: ABORT - success or failure
+*- : err - reason for failure, if any
+*-
+*- Created 25-Jan-1997 S. A. Wood
+* $Log: t_raw_dump_all.f,v $
+* Revision 1.1 1998/12/01 20:57:09 saw
+* Initial revision
+*
+*--------------------------------------------------------
+ IMPLICIT NONE
+ SAVE
+*
+ character*14 here
+ parameter (here= 't_raw_dump_all')
+*
+ logical ABORT
+ character*(*) err
+*
+ include 't20_data_structures.cmn'
+ include 't20_hodo_parms.cmn'
+ include 't20_tracking.cmn'
+c include 'sos_calorimeter.cmn'
+*
+*--------------------------------------------------------
+ ABORT = .FALSE.
+ err = ' '
+* Dump raw bank if tdebugprinthodoraw is set
+ if( tdebugprinthodoraw .ne. 0) then
+ call t_prt_raw_hodo(ABORT,err)
+ endif
+*
+* Dump raw bank if debug flag set
+ if(tdebugprintmwpcraw.ne.0) then
+ call t_prt_raw_mwpc(ABORT,err)
+ endif
+ RETURN
+ END
diff --git a/T20/t_reconstruction.f b/T20/t_reconstruction.f
new file mode 100644
index 0000000..c65900a
--- /dev/null
+++ b/T20/t_reconstruction.f
@@ -0,0 +1,99 @@
+ SUBROUTINE T_reconstruction(ABORT,err)
+*--------------------------------------------------------
+*- Prototype C analysis routine
+*-
+*- Purpose and Methods : reconstruction of T20 quantities
+*-
+*- Output: ABORT - success or failure
+*- : err - reason for failure, if any
+*-
+* $Log: t_reconstruction.f,v $
+* Revision 1.1 1998/12/01 20:54:23 saw
+* Initial revision
+*
+*--------------------------------------------------------
+ IMPLICIT NONE
+ SAVE
+*
+ character*16 here
+ parameter (here= 'T_reconstruction')
+*
+ logical ABORT
+ character*(*) err
+*
+ INCLUDE 't20_data_structures.cmn'
+ INCLUDE 'gen_constants.par'
+ INCLUDE 'gen_units.par'
+ include 't20_bypass_switches.cmn'
+*
+* local variables
+* integer*4 istat
+*--------------------------------------------------------
+*
+ccc ABORT= .TRUE.
+ccc err= ':no events analyzed!'
+* increment reconstructed number
+ err = ' '
+c t_recon_num= t_recon_num + 1
+*
+* dump all raw data
+ call t_raw_dump_all(ABORT,err)
+ if(ABORT) then
+ call g_add_path(here,err)
+ return
+ endif
+*
+* TRANSLATE SCINTILATORS AND CALCULATE START TIME
+* SOS_RAW_SCIN ====> SOS_DECODED_SCIN
+*
+c If(sbypass_trans_scin.eq.0) then
+c call S_TRANS_SCIN(ABORT,err)
+c if(ABORT) then
+c call G_add_path(here,err)
+c* return
+c endif ! end test on SCIN ABORT
+c endif ! end test on sbypass_trans_scin
+*
+* TRANSLATE SMISC TDC HITS.
+* S_RAW_MISC ====> SOS_DECODED_MISC
+*
+c If(sbypass_trans_scin.eq.0) then
+c call S_TRANS_MISC(ABORT,err)
+c if(ABORT) then
+c call G_add_path(here,err)
+c* return
+c endif ! end test on SCIN ABORT
+c endif ! end test on hbypass_trans_scin
+*
+ if(tbypass_test.eq.0) then ! Analyze test detector straw tubes
+ call t_test_straw_analyze
+ endif
+*
+* The next two routines are not needed by the t_polder_* routines
+ call t_hodos(ABORT,err) !raw data transfer to CTP & user hist.
+ call t_mwpc(ABORT,err) !raw data transfer to CTP & user hist.
+ call t_misc(ABORT,err) !raw data transfer to CTP & user hist.
+* The next routine is needed by the t_polder_* routines
+* not any more 3/31/97
+
+ call t_hms(ABORT,err)
+
+ if(tbypass_polder.eq.0) then
+ call t_polder_analyse(ABORT,err)
+ else if(tbypass_polder.eq.1) then
+ call t_polder_cuts(ABORT,err)
+ else if(tbypass_polder.eq.2) then
+ call t_polder_alignement(ABORT,err)
+ else if(tbypass_polder.eq.3) then
+ call t_polder_calmwpc3(ABORT,err)
+ endif
+
+ if(tbypass_test.eq.0) then ! Analyze test detector straw tubes
+ call t_test_stpld_comp
+ endif
+
+c
+* Successful return
+ ABORT=.FALSE.
+ RETURN
+ END
diff --git a/T20/t_register_param.f b/T20/t_register_param.f
new file mode 100644
index 0000000..063ce95
--- /dev/null
+++ b/T20/t_register_param.f
@@ -0,0 +1,49 @@
+ SUBROUTINE t_register_param(ABORT,err)
+*--------------------------------------------------------
+*-
+*- Purpose and Methods : Initializes T20 quantities
+*-
+*- Output: ABORT - success or failure
+*- : err - reason for failure, if any
+*-
+*- Created 22-Jan-1997 Stephen A. Wood
+*-
+*- All standards are from "Proposal for Hall C Analysis Software
+*- Vade Mecum, Draft 1.0" by D.F.Geesamn and S.Wood, 7 May 1993
+* $Log: t_register_param.f,v $
+* Revision 1.1 1998/12/01 20:57:13 saw
+* Initial revision
+*
+*-
+*--------------------------------------------------------
+ IMPLICIT NONE
+ SAVE
+*
+ character*16 here
+ parameter (here= 't_register_param')
+*
+ logical ABORT
+ character*(*) err
+*
+*--------------------------------------------------------
+ err= ' '
+ ABORT = .false.
+*
+* Register t20 parameters
+*
+ call r_t20_tracking
+ call r_t20_test_histid
+*
+* register bypass switches
+*
+ call r_t20_bypass_switches
+
+*
+* register sos statistics
+*
+
+c call r_sos_statistics
+c call r_sos_pedestals
+*
+ return
+ end
diff --git a/T20/t_register_variables.f b/T20/t_register_variables.f
new file mode 100644
index 0000000..aa51c3b
--- /dev/null
+++ b/T20/t_register_variables.f
@@ -0,0 +1,72 @@
+ subroutine t_register_variables(ABORT,err)
+*----------------------------------------------------------------------
+*
+* CTP variable registration routine for T20
+*
+* Purpose : Register all variables that are to be used by CTP, that are
+* connected with the SOS. This includes externally configured
+* parameters/contants, event data that can be a histogram source, and
+* possible test results and scalers.
+*
+* Output: ABORT - success or failure
+* : err - reason for failure, if any
+*
+* Created: 22-Jan-1997 Stephen A. Wood
+*
+* $Log: t_register_variables.f,v $
+* Revision 1.1 1998/12/01 20:57:17 saw
+* Initial revision
+*
+*----------------------------------------------------------------------
+ implicit none
+ save
+*
+ character*20 here
+ parameter (here='t_register_variables')
+*
+ logical ABORT
+ character*(*) err
+*
+ logical FAIL
+ character*1000 why
+*
+*--------------------------------------------------------
+ err= ' '
+ ABORT = .FALSE.
+*
+ call r_t20_data_structures
+
+ call r_t20_filenames
+
+ call r_t20_test_detectors
+
+ call r_t20_hodo
+
+ call r_t20_reg_polder_structures
+
+ call r_t20_misc
+
+ call r_t20_hms
+
+ call r_t_ntuple
+
+ call t_register_param(FAIL,why) ! TRACKING ROUTINE
+ IF(err.NE.' ' .and. why.NE.' ') THEN !keep warnings
+ call G_append(err,' & '//why)
+ ELSEIF(why.NE.' ') THEN
+ err= why
+ ENDIF
+ ABORT= ABORT .or. FAIL
+*
+ call t_ntuple_register(FAIL,why) ! Remove this when ctp files fixed
+ IF(err.NE.' ' .and. why.NE.' ') THEN !keep warnings
+ call G_append(err,' & '//why)
+ ELSEIF(why.NE.' ') THEN
+ err= why
+ ENDIF
+ ABORT= ABORT .or. FAIL
+*
+ if(ABORT .or. err.NE.' ') call G_add_path(here,err)
+*
+ return
+ end
diff --git a/T20/t_reset_event.f b/T20/t_reset_event.f
new file mode 100644
index 0000000..fbb3511
--- /dev/null
+++ b/T20/t_reset_event.f
@@ -0,0 +1,91 @@
+ SUBROUTINE T_reset_event(ABORT,err)
+*--------------------------------------------------------
+*- Prototype C analysis routine
+*-
+*-
+*- Purpose and Methods : Resets all T20 quantities at the beginning of the run
+*-
+*-
+*- Output: ABORT - success or failure
+*- : err - reason for failure, if any
+*-
+*- Created 22-Jan-1997 Stephen A. Wood
+
+*- All standards are from "Proposal for Hall C Analysis Software
+*- Vade Mecum, Draft 1.0" by D.F.Geesamn and S.Wood, 7 May 1993
+* $Log: t_reset_event.f,v $
+* Revision 1.1 1998/12/01 20:54:42 saw
+* Initial revision
+*
+*-
+*--------------------------------------------------------
+ IMPLICIT NONE
+ SAVE
+*
+ character*13 here
+ parameter (here= 'T_reset_event')
+*
+ logical ABORT
+ character*(*) err
+*
+ INCLUDE 't20_data_structures.cmn'
+ include 't20_misc.cmn'
+ include 't20_hms.cmn'
+ INCLUDE 'gen_data_structures.cmn'
+ INCLUDE 'hms_data_structures.cmn'
+c include 'gen_misc.cmn'
+ include 'hms_tracking.cmn'
+c include 'hms_pedestals.cmn'
+c include 'hms_scin_parms.cmn'
+*
+ INTEGER hit
+*
+*--------------------------------------------------------
+*
+ DO hit= 1,TMAX_MWPC_HITS
+ TMWPC_RAW_PLANE_NUM(hit) = 0
+ TMWPC_RAW_WIRE_NUM(hit) = 0
+ TMWPC_RAW_TDC(hit) = 0
+ ENDDO
+ TMWPC_RAW_TOT_HITS = 0
+*
+ DO hit= 1,TMAX_HODO_HITS
+ THODO_PLANE_NUM(hit) = 0
+ THODO_BAR_NUM(hit) = 0
+ THODO_TDC_VAL(hit) = 0
+ ENDDO
+ THODO_TOT_HITS = 0
+*
+ DO hit= 1,TMAX_MISC_HITS
+ TMISC_RAW_ADDR1(hit) = 0
+ TMISC_RAW_ADDR2(hit) = 0
+ TMISC_RAW_DATA(hit) = 0
+ ENDDO
+ TMISC_TOT_HITS = 0
+
+ DO hit= 1,TTSTMAX_STRAW_HITS
+ TTST_RAW_PLANE_NUM(hit) = 0
+ TTST_RAW_GROUP_NUM(hit) = 0
+ TTST_RAW_TDC(hit) = 0
+ ENDDO
+ TTST_RAW_TOT_HITS = 0
+
+c reset variables calculated in t_hms.f
+ tsinhtheta = -2.
+ te_v = 0.
+ thms_td1 = 0.
+ thms_td2 = 0.
+ tq2 = 0.
+c
+c Note: These don't really belong here (saw)
+c
+ hstheta = 0.
+ hsenergy = 0.
+ hfoundtrack = .false.
+ hcleantrack = .false.
+ hntracks_fp = 0
+
+ ABORT= .FALSE.
+ err= ' '
+ RETURN
+ END
diff --git a/T20/t_test_straw_analyze.f b/T20/t_test_straw_analyze.f
new file mode 100644
index 0000000..3f6f34e
--- /dev/null
+++ b/T20/t_test_straw_analyze.f
@@ -0,0 +1,1471 @@
+ subroutine t_test_straw_analyze
+ implicit none
+ save
+
+* File: t_test_straw_analyze.f
+* Author: R. Gilman, 20 Dec 1996
+* Modified: 21 Jan 1997 (saw). Edit for inclusion in Hall C analyzer
+*
+* Purpose: decode straw chamber data, prepare for histogramming raw quantites,
+* setup for tracking...
+* Based on simple FPP analysis routines for Hall A
+* $Log: t_test_straw_analyze.f,v $
+* Revision 1.3 1998/12/01 20:55:11 saw
+* (SAW) Checkin
+*
+* Revision 1.2 1997/05/20 18:30:36 saw
+* (Ron Gilman) Code update
+*
+* Revision 1.1 1997/05/20 18:28:49 saw
+* Initial revision
+*
+*
+* include files...
+ include 't20_test_detectors.cmn'
+ include 't20_test_histid.cmn'
+ include 't20_reg_polder_structures.cmn'
+ include 't20_data_structures.cmn'
+
+ integer*4 lun_calib ! Set this somewhere else
+ parameter (lun_calib=62)
+
+* local variables
+ integer*4 nplane, idiff
+ integer*4 i, j, n, kk, ihit, noff, iok
+ real*4 pos
+* real*4 slope, bint, pos1, pos2, dpos
+
+* most intializations have been moved into ctp file
+* terplay/PARAM/t20_test_detectors.param
+
+* first get hits out of input array and group into local plane hit
+* structures the TDC appears to be LIFO (info from Glen Collins) but the
+* SAW decoder reverses the order into FIFO. Thus, leading edges should
+* always precede the trailing edges. This is assumed,to simplify the
+* decoding...
+*
+* IF THIS IS NOT THE CASE, JUST GET ELEMENTS OUT OF THE INPUT ARRAYS
+* FROM LAST TO FIRST!
+*
+* The time scale is in 1/2 ns! and is left in those units...
+* positions will be in cm and angles will be in radians
+
+* look through the raw data to associate the edges into hits,
+* the way the decoder works, should get le hit immediately followed by
+* te hit - the decoder reverses the readout order
+
+ call t_test_scint_analyze
+ call t_test_straw_initialize
+ call t_test_straw_gethits
+ if(ttst_raw_tot_hits.le.0)then
+ return
+ endif
+ call t_test_setup_track_input
+c call t_test_throwout_hits
+ call t_test_set_trackcode
+
+* if hits distributed okay, get track and do things with it...
+
+ noff = -3
+ do i = 1, 2
+ ttst_track_ntracks = 0
+ noff = noff + 4
+ ttst_nxytrack(i) = 0
+ ttst_nxytracktried(i) = 0
+
+ if(ttst_straw_xygddmx(i).gt.2 .and.
+ + ttst_straw_xygddmx(i).lt.6 .and.
+ + ttst_straw_xyplnsht(i).gt.2) then
+
+ ttst_nxytracktried(i) = 1
+ call trk4(ttst_straw_planes_hit(noff),
+ + ttst_track_hitarray(1,1,noff),
+ + ttst_track_ntracks,
+ + ttst_track_params(1,i) )
+ ttst_nxytrack(i) = ttst_track_ntracks
+ if(ttst_track_ntracks.eq.1)then
+c increment a single chisq (resolution) histogram
+ call hf1(ttst_hid_strawres,ttst_track_params(3,i),1.)
+c work out the good,bad,missing wire hists
+ do j = 1, 4
+ nplane = j + noff - 1
+ pos = ttst_track_params(2,i) +
+ + ttst_track_params(1,i) *
+ + (ttst_straw_z0+ttst_straw_z(nplane))
+ pos = pos - ttst_straw_x1(nplane)
+ idiff = nint(pos/ttst_straw_spacing +
+ + ttst_straw_sctr(nplane))
+ if(i.eq.1)kk = 56*(j-1)
+ if(i.eq.2)kk = 224 + 24*(j-1)
+ if(ttst_straw_planes_hit(nplane).eq.0)then
+ call hf1(ttst_hid_strawhitms,float(kk+idiff),1.)
+ else
+ iok = 0
+ do ihit = 1, ttst_straw_planes_hit(nplane)
+ n = ttst_track_hitarray(1,ihit,nplane)
+c if(n.eq.idiff)then
+ if(n.le.idiff+1 .and. n.ge.idiff-1)then
+ iok = 1
+ call hf1(ttst_hid_strawhitgd,float(kk+n),1.)
+c call hf1(ttst_hid_planeoffs(nplane),0.,1.)
+ else
+ call hf1(ttst_hid_strawhitbd,float(kk+n),1.)
+ n = n-idiff
+c call hf1(ttst_hid_planeoffs(nplane),
+c + float(n),1.)
+ endif !if there are hits on planes
+ enddo !loop over hits in plane
+ if(iok.eq.0)then
+ call hf1(ttst_hid_strawhitms,float(kk+idiff),1.)
+ endif !if no hit where expected
+ endif !if there are hits in plane
+ enddo !loop over planes
+ endif !if there is track
+ endif !if okay #hits to try to track
+ enddo !loop over two coordinates
+
+c rotate track if needed
+ call t_test_project_track
+
+c work out the track codes from the arrays...
+ call hf1(ttst_hid_trackcode, 0., 1.)
+ do i = 1, 2
+ j = 2*i - 1
+ if(ttst_nxytracktried(i).eq.1)then
+ call hf1(ttst_hid_trackcode, float(j), 1.)
+c type *, i, ttst_track_chisqcut, ttst_track_params(3,i)
+ if(ttst_nxytrack(i).gt.0 .and.
+ + ttst_track_params(3,i).le.0.2)
+ + call hf1(ttst_hid_trackcode, float(j+1), 1.)
+ endif
+ enddo
+ if(ttst_nxytracktried(1).eq.1 .and.
+ + ttst_nxytracktried(2).eq.1) then
+ call hf1(ttst_hid_trackcode, float(5), 1.)
+ if(ttst_nxytrack(1).eq.1 .and. ttst_nxytrack(2).eq.1.and.
+ + ttst_track_params(3,1).le.0.2 .and.
+ + ttst_track_params(3,2).le.0.2 )
+ + call hf1(ttst_hid_trackcode, float(6), 1.)
+ endif
+
+ return
+ end
+c ----------------------------------------------------------------------
+ subroutine t_test_straw_initialize
+ implicit none
+ save
+ include 't20_test_detectors.cmn'
+ integer*4 i, j
+
+c ttst_straw_goodedge = 0
+ ttst_straw_goodhit = 0
+ ttst_straw_gooddemux = 0
+ ttst_straw_xgddmx = 0
+ ttst_straw_ygddmx = 0
+ ttst_straw_xplnsht = 0
+ ttst_straw_yplnsht = 0
+ do i = 1, ttst_n_straw_planes
+ ttst_straw_planes_hit(i) = 0
+ enddo
+ do i = 1, ttst_n_straw_wgs
+ ttst_straw_hits(i) = 0
+ enddo
+
+ do i = 1, 2
+ ttst_num_oot(i) = 0
+ do j = 1, 3
+ ttst_track_params(j,i) = -9999.
+ enddo
+ ttst_track_pos_est(i) = 0.
+ ttst_track_angle(i) = -9999.
+ ttst_nxytrack(i) = 0
+ ttst_num_oot(i) = 0
+ ttst_avetim_oot(i) = 0
+ enddo
+ ttst_track_ntracks = 0
+
+ ttst_stpld_xposdiff = -9999.
+ ttst_stpld_yposdiff = -9999.
+ ttst_stpld_thposdiff = -9999.
+ ttst_stpld_phposdiff = -9999.
+
+ return
+ end
+
+c ----------------------------------------------------------------------
+ subroutine t_test_straw_gethits
+ implicit none
+ save
+ include 't20_data_structures.cmn'
+ include 't20_test_histid.cmn'
+ include 't20_test_detectors.cmn'
+ integer*4 lun_calib ! Set this somewhere else
+ parameter (lun_calib=62)
+ integer*4 str_group,str_plane,str_ggroup
+ integer*4 i,n,oldwg,tim,ilete,oldtim
+ integer*4 wgs(50),times(50),wids(50),straws(50),planes(50)
+ integer*4 ioot1, nfp, idiff, kk, itype
+ integer*4 jiand
+
+ if(
+ + ttst_reallyraw_out.gt.0 .and.
+ + ttst_reallyraw_out.gt.reallyraw_written ) then
+ print *, 't_test_straw_analyze called, tot_hits=',
+ + ttst_raw_tot_hits
+ reallyraw_written = reallyraw_written + 1
+ endif
+ if(ttst_raw_tot_hits.le.0)then
+ return
+ endif
+
+ if(
+ + ttst_raw_ntuples_out.gt.0 .and.
+ + raw_ntuples_written.eq.0 .and.
+ + ttst_raw_tot_hits.gt.0 ) then
+ open(unit=lun_calib,file='t20_test_hits.ntuple',status='new')
+ endif
+
+c combine edges into pairs of le/te edges...
+
+ nfp = 0
+ oldwg = 0
+ do i = ttst_raw_tot_hits, 1, -1
+ str_plane = ttst_raw_plane_num(i)
+ str_group = ttst_raw_group_num(i)
+ str_ggroup = str_group + ttst_straw_plane_group_off(str_plane)
+ tim = ttst_raw_tdc(i)
+ ilete = jiand(tim,'10000'X)
+ if(ilete.ne.0)ilete=1
+ tim = jiand(tim,'FFFF'X)
+c iand generic, jiand 4 byte, iiand 2 byte
+ if(
+ + ttst_reallyraw_out.gt.0 .and.
+ + ttst_reallyraw_out.gt.reallyraw_written ) then
+ print *,i,ttst_raw_plane_num(i),ttst_raw_group_num(i),
+ + str_group,ilete,tim
+ endif
+ if(ilete.eq.0)then
+ oldwg = str_ggroup
+ oldtim = tim
+ else
+c only get trailing edge immediately after a LE
+ if(str_ggroup.eq.oldwg)then !same group :)
+ nfp = nfp + 1
+ if(nfp.gt.50)nfp = 50
+ planes(nfp) = str_plane
+ wgs(nfp) = oldwg
+ times(nfp) = oldtim
+ wids(nfp) = oldtim - tim
+c demux here and now!
+ idiff = 0
+ do kk = 1, 9
+ if(wids(nfp).gt.ttst_dmx(kk,str_ggroup)) idiff=kk
+ enddo
+ if(idiff.gt.0.and.idiff.le.8) then
+ itype = ttst_straw_type(str_plane)
+ idiff = ttst_type_order(idiff,itype)
+ straws(nfp) = 8*(str_group-1) + idiff
+ else
+ nfp = nfp - 1
+ endif
+c done demux!
+ if(
+ + ttst_raw_ntuples_out.gt.0 .and.
+ + raw_ntuples_written.lt.ttst_raw_ntuples_out ) then
+ raw_ntuples_written = raw_ntuples_written + 1
+ write(lun_calib,'(3f6.0)') float(oldwg),
+ + float(oldtim),float(wids(nfp))
+ if(raw_ntuples_written.eq.ttst_raw_ntuples_out)then
+ write(6,*)' t_test_straw_analyze wrote',
+ + raw_ntuples_written,' ntuples'
+ raw_ntuples_written = raw_ntuples_written + 1
+ endif
+ endif
+ call hf1(ttst_hid_straw_wletdc,float(oldtim),1.)
+ call hf1(ttst_hid_straw_letdc,float(oldtim),1.)
+ endif
+ endif
+ enddo
+
+c have found all le/te pairs, save good and bad (oot=out of time) hits
+
+ do i = 1, nfp
+ if(times(i).ge.ttst_TDC_min .and. times(i).le.ttst_TDC_max)then
+ n = ttst_straw_hits(wgs(i)) + 1
+ if(n.gt.8)n = 8
+ ttst_straw_hits(wgs(i)) = n
+ ttst_straw_tdc(n,wgs(i)) = times(i)
+ ttst_straw_wid(n,wgs(i)) = wids(i)
+ ttst_straw_num(n,wgs(i)) = straws(i)
+ ttst_straw_goodhit = ttst_straw_goodhit + 1
+ call hf2(ttst_hid_dmxchck,float(wgs(i)),float(wids(i)),1.)
+ call hf1(ttst_hid_straw_width,float(wids(i)),1.)
+ call hf1(ttst_hid_wg,float(wgs(i)),1.)
+ n = 8*ttst_straw_plane_group_off(planes(i)) + straws(i)
+ call hf1(ttst_hid_strawmap,float(n),1.)
+ else
+ ioot1 = 0
+ do n = 1, 2
+ if(ioot1.eq.0)then
+ if(ttst_num_oot(n).eq.0)then
+ ttst_num_oot(n) = 1
+ ttst_avetim_oot(n) = times(i)
+ ttst_wg_oot(1,n) = wgs(i)
+ ttst_tim_oot(1,n) = times(i)
+ ttst_wid_oot(1,n) = wids(i)
+ ttst_str_oot(1,n) = straws(i)
+ ttst_pln_oot(1,n) = planes(i)
+ ioot1 = 1
+ else
+ if(times(i).gt.ttst_avetim_oot(n)-200 .and.
+ + times(i).lt.ttst_avetim_oot(n)+200) then
+ ttst_num_oot(n) = ttst_num_oot(n) + 1
+ if(ttst_num_oot(n).lt.11)then
+ ttst_wg_oot(ttst_num_oot(n),n) = wgs(i)
+ ttst_tim_oot(ttst_num_oot(n),n) = times(i)
+ ttst_wid_oot(ttst_num_oot(n),n) = wids(i)
+ ttst_str_oot(ttst_num_oot(n),n) = straws(i)
+ ttst_pln_oot(ttst_num_oot(n),n) = planes(i)
+ endif
+ ioot1 = 1
+ endif
+ endif
+ endif
+ enddo
+ endif
+ enddo
+
+ call t_test_oot_track
+
+ return
+ end
+c ----------------------------------------------------------------------
+ subroutine t_test_oot_track
+ implicit none
+ save
+ include 't20_test_detectors.cmn'
+ include 't20_test_histid.cmn'
+ integer*4 i, j, k, np
+ integer*4 nxy(8), nxyt(2), ntf
+ real*4 z(8), xy(8), t, avexy(2)
+ real*4 rcept(2), slope(2)
+ real*4 xbar, ybar, xsqbar, xybar, diff
+
+* this routine attempts to track 1-2 oot tracks using wire positions only
+* try to track oot hits if a likely-to-be-trackable number of them
+* cannot get hits out quite like do for usual tracking...
+
+
+ do i = 1, 2
+ if(ttst_num_oot(i).gt.10)ttst_num_oot(i)=10
+ if(ttst_num_oot(i).gt.6)then
+ do j = 1, 8
+ nxy(j) = 0
+ xy(j) = 0.
+ enddo
+ do j = 1, ttst_num_oot(i)
+ np = ttst_pln_oot(j,i)
+ if(nxy(np).eq.0)then
+ nxy(np) = 1
+ z(np) = ttst_straw_z(np) + ttst_straw_z0
+ xy(np) =
+ + (ttst_str_oot(j,i)-ttst_straw_sctr(np)) *
+ + ttst_straw_spacing + ttst_straw_x1(np)
+ else !boot, 1 hit/plane unless close
+ t = (ttst_str_oot(j,i)-ttst_straw_sctr(np)) *
+ + ttst_straw_spacing + ttst_straw_x1(np)
+ if(abs(t-xy(np)).gt.2.5) then
+ if(nxy(np).eq.1) nxy(np) = 0
+ else
+ xy(np) = xy(np)*nxy(np) + t
+ nxy(np) = nxy(np)+1
+ xy(np) = xy(np) / nxy(np)
+ endif
+ endif
+ enddo
+c have accumulated all of the x and y hits... make sure all
+co hits close together, and if enough try to track...
+c type *,'accumulated all oots into tracking arrays...'
+c type *,'num_oots=',ttst_num_oot(i)
+c type *,(nxy(j),j=1,8)
+c type *,(z(j),j=1,8)
+c type *,(xy(j),j=1,8)
+ ntf = 0
+ do j = 1, 2
+ slope(j) = -999.
+ rcept(j) = -99999999.
+ avexy(j) = 0.
+ nxyt(j) = 0
+ do k = 4*j-3, 4*j
+ if(nxy(k).gt.0)then
+ avexy(j) = avexy(j) + xy(k)
+ nxyt(j) = nxyt(j) + 1
+ endif
+ enddo
+ if(nxyt(j).gt.0)avexy(j) = avexy(j)/nxyt(j)
+ nxyt(j) = 0
+ do k = 4*j-3, 4*j
+ if(abs(xy(k)-avexy(j)).gt.2.0)nxy(k) = 0
+ if(nxy(k).gt.0)nxyt(j) = nxyt(j) + 1
+ enddo
+c type *,'nxyt=',nxyt(j)
+ if(nxyt(j).gt.2)then
+ xbar = 0
+ ybar = 0
+ xsqbar = 0
+ xybar = 0
+ do k = 4*j-3, 4*j
+ if(nxy(k).gt.0)then
+ xbar = xbar + z(k)
+ xsqbar = xsqbar + z(k)**2
+ ybar = ybar + xy(k)
+ xybar = xybar + z(k)*xy(k)
+ endif
+ enddo
+ diff = nxyt(j)*xsqbar - xbar**2
+ if(diff.ne.0.)then
+ slope(j) = (nxyt(j)*xybar - xbar*ybar) / diff
+ rcept(j) = -1.*(xybar*xbar-xsqbar*ybar) / diff
+ ntf = ntf + 1
+c histogram x, y here!
+ xbar = rcept(j) + slope(j)*
+ + (ttst_straw_z0+ttst_straw_zchmbr)
+ if(j.eq.1)then
+ call hf2(ttst_hid_oot_thvx,xbar,slope(j),1.)
+ else
+ call hf2(ttst_hid_oot_phvy,xbar,slope(j),1.)
+ endif
+ endif
+ endif
+ enddo
+ if(ntf.eq.2)then
+c histogram x_vs_y here
+ call hf2(ttst_hid_oot_yvx,rcept(1),rcept(2),1.)
+ endif
+ endif
+ enddo
+
+ return
+ end
+c ----------------------------------------------------------------------
+ subroutine t_test_setup_track_input
+ implicit none
+ save
+ include 't20_test_detectors.cmn'
+ include 't20_test_histid.cmn'
+ integer*4 i, j, k, ihit, drift_time
+ integer*4 ngroup, nplane, noff, itype
+ real*8 avepos(8), ave, driftdistance
+
+* now have captured into the arrays the pairs of hits...
+* count up planes hit, also work out demultiplex and straws hit...
+* increment the arrays that will be used for tracking
+* have also ordered everything by global wiregroup, and thus
+* by plane number
+
+ do i = 1, 8
+ avepos(i) = 0.
+ enddo
+ do ngroup=1, ttst_n_straw_wgs
+ if(ttst_straw_hits(ngroup).gt.0)then
+ nplane = ttst_plane_of_group(ngroup)
+ noff = 8*(ngroup-ttst_straw_plane_group_off(nplane)-1)
+ itype = ttst_straw_type(nplane)
+ do i = 1, ttst_straw_hits(ngroup)
+ ttst_straw_planes_hit(nplane) =
+ + ttst_straw_planes_hit(nplane) + 1
+ ihit = ttst_straw_planes_hit(nplane)
+ if(ihit.gt.max_track_hit) ihit=max_track_hit
+ ttst_straw_gooddemux = ttst_straw_gooddemux + 1
+c have a good hit and a good demux, so store it for tracking!
+c hitarray 1=straw #, 2=drift distance 3=z of plane 4=x/y of straw wire
+ ttst_track_hitarray(1,ihit,nplane) =
+ + ttst_straw_num(i,ngroup)
+ ttst_track_hitarray(3,ihit,nplane) =
+ + ttst_straw_z(nplane) + ttst_straw_z0
+ ttst_track_hitarray(4,ihit,nplane) =
+ + (ttst_straw_num(i,ngroup)-ttst_straw_sctr(nplane))
+ + * ttst_straw_spacing + ttst_straw_x1(nplane)
+ avepos(nplane) = avepos(nplane) +
+ + ttst_track_hitarray(4,ihit,nplane)
+* readjust tim with tim offset...
+* do not do above, affects writing raw ntuples
+* the readjustment could move us out of the drift table range, so ensure
+* it does not!
+ ttst_straw_tdc(i,ngroup) = ttst_straw_tdc(i,ngroup)
+ + - ttst_t0(ngroup)
+ drift_time = ttst_straw_tdc(i,ngroup)-ttst_TDC_min
+ if(drift_time.lt.1)drift_time = 1
+ if(drift_time.gt.400)drift_time = 400
+ driftdistance =
+ + ttst_drift_max * ttst_drift_table(drift_time)
+ ttst_track_hitarray(2,ihit,nplane) = driftdistance
+ call hf1(ttst_hid_driftdist,
+ + ttst_track_hitarray(2,ihit,nplane),1.)
+ call hf1(ttst_hid_drifttime,float(drift_time),1.)
+* find ``real'' drift time, and use simple constant velocity, for
+* comparison to better table algoithym
+ drift_time = ttst_drift_t0-ttst_straw_tdc(i,ngroup)
+ ttst_track_dxpos2(ihit,nplane) =
+ + ttst_drift_v * drift_time
+ if(ttst_track_dxpos2(ihit,nplane).gt.ttst_drift_max)
+ + ttst_track_dxpos2(ihit,nplane) = ttst_drift_max
+ if(ttst_track_dxpos2(ihit,nplane).lt. 0.)
+ + ttst_track_dxpos2(ihit,nplane) = 0.
+ call hf1(ttst_hid_driftdistv0,
+ + ttst_track_dxpos2(ihit,nplane),1.)
+ call hf1(ttst_hid_drifttimet0,float(drift_time),1.)
+* last chance to remove hit if drift time/distance not sufficiently
+* good... keep it in center 99% of te drift range... or remove
+ if(driftdistance.lt.0.005*ttst_drift_max .or.
+ + driftdistance.gt.0.995*ttst_drift_max) then
+ ttst_straw_planes_hit(nplane) =
+ + ttst_straw_planes_hit(nplane) - 1
+ ttst_straw_gooddemux = ttst_straw_gooddemux - 1
+ endif
+ enddo ! loop over # hits
+ endif ! if any straws in group hit
+ enddo ! loop over wiregroups in plane
+
+* work out average position in x, y, and
+* make new summary plot of hits on planes...
+* add up # of x, y hits, xyplaneshit, total # of hits: for later use
+
+ do i = 1, 2
+ ave = 0
+ j = 0
+ do nplane = 4*i-3, 4*i
+ j = j + ttst_straw_planes_hit(nplane)
+ ave = ave + avepos(nplane)
+ k = 10*(nplane-1)+ ttst_straw_planes_hit(nplane)
+ call hf1(ttst_hid_numhitsonplanes,float(k),1.)
+ ttst_straw_xygddmx(i) = ttst_straw_xygddmx(i) +
+ + ttst_straw_planes_hit(nplane)
+ if(ttst_straw_planes_hit(nplane).gt.0)
+ + ttst_straw_xyplnsht(i) = ttst_straw_xyplnsht(i) + 1
+ enddo
+ if(j.ne.0)ttst_track_pos_est(i) = ave/j
+ call hf1(ttst_hid_xoryhits,float(ttst_straw_xygddmx(i)),1.)
+ enddo
+
+* adjust positions os x,y's to account for plane to plane rotations...
+* assume small angle ==> theta = sin(theta) = tan(theta)
+* (correction good to 0.3% even for 100 mr)
+
+ do i = 1, 2
+ do nplane = 4*i-3, 4*i
+ if(ttst_straw_planes_hit(nplane).gt.0)then
+ do ihit = 1, ttst_straw_planes_hit(nplane)
+ ave = 0.001 * ttst_rotate_xyplane(nplane) *
+ + ttst_track_pos_est(3-i)
+c if(ttst_straw_xygddmx(i).le.5)
+c + type *,nplane,ttst_track_hitarray(4,ihit,nplane),ave
+ ttst_track_hitarray(4,ihit,nplane) =
+ + ttst_track_hitarray(4,ihit,nplane) + ave
+ enddo
+ endif
+ enddo
+ enddo
+
+ return
+ end
+
+c ----------------------------------------------------------------------
+ subroutine t_test_set_trackcode
+ implicit none
+ save
+ include 't20_test_detectors.cmn'
+ include 't20_test_histid.cmn'
+c integer*4 i
+
+c do i = 1, 2
+
+c ttst_track_code = 0
+c if(ttst_straw_xygddmx(i).lt.3)ttst_track_code = 1
+c if(ttst_straw_xygddmx(i).eq.3)then
+c if(ttst_straw_xyplnsht(i).lt.3)then
+c ttst_track_code = 2
+c else
+c ttst_track_code = 3
+c endif
+c endif
+
+c if(ttst_straw_xygddmx(i).eq.4)then
+c if(ttst_straw_xyplnsht(i).lt.4)then
+c ttst_track_code = 4
+c else
+c ttst_track_code = 5
+c endif
+c endif
+
+c if(ttst_straw_xygddmx(i).eq.5)then
+c if(ttst_straw_xyplnsht(i).lt.4)then
+c ttst_track_code = 6
+c else
+c ttst_track_code = 7
+c endif
+c endif
+
+c if(ttst_track_code.eq.0)ttst_track_code = 8
+c ttst_track_code = ttst_track_code + 10*(i-1)
+c call hf1(ttst_hid_trackcode, float(ttst_track_code), 1.)
+c enddo
+
+ return
+ end
+c ----------------------------------------------------------------------
+c rotate / offset chamber track into polder coordinate system...
+ subroutine t_test_project_track
+ implicit none
+ save
+ include 't20_test_detectors.cmn'
+ integer*4 i
+ real*8 xych(2)
+
+ do i = 1, 2
+ ttst_track_angle(i) = atan(ttst_track_params(1,i))
+ + + ttst_rotate_ang(i)
+ ttst_track_chmbrpos(i) = ttst_track_params(2,i) +
+ + ttst_track_params(1,i) *
+ + (ttst_straw_zchmbr+ttst_straw_z0) +
+ + ttst_straw_xoff(i)
+ enddo
+ xych(1) = cos(ttst_rotate_ang(3)) * ttst_track_chmbrpos(1) +
+ + sin(ttst_rotate_ang(3)) * ttst_track_chmbrpos(2)
+ xych(2) = cos(ttst_rotate_ang(3)) * ttst_track_chmbrpos(2) -
+ + sin(ttst_rotate_ang(3)) * ttst_track_chmbrpos(1)
+ do i = 1, 2
+ ttst_track_chmbrpos(i) = xych(i)
+ ttst_track_params(1,i) = tan(ttst_track_angle(i))
+ ttst_track_params(2,i) = ttst_track_chmbrpos(i) -
+ + ttst_track_params(1,i) *
+ + (ttst_straw_zchmbr+ttst_straw_z0)
+ ttst_track_scintpos(i) = ttst_track_params(2,i) +
+ + ttst_track_params(1,i) * ttst_straw_zscint
+ enddo
+
+c note that chamber pos is measured in z relative to the _z0 parameter,
+c but scintillator position (POLDER start scntillator that is) is measured
+c relative to the origin of the coordinate system, the POLDER target
+
+ return
+ end
+
+c ----------------------------------------------------------------------
+
+ subroutine t_test_stpld_comp
+ implicit none
+ save
+ include 't20_data_structures.cmn'
+ include 't20_test_detectors.cmn'
+ include 't20_test_histid.cmn'
+ include 't20_reg_polder_structures.cmn'
+
+ integer*4 opened
+ integer*4 lun_calib ! Set this somewhere else
+ parameter (lun_calib=63)
+ data opened/0/
+
+c need to compare tracks to polder tracks....
+ ttst_good_comp = 0
+ ttst_stpld_xposdiff = ttst_track_params(2,1) - tdeuton1_x(3)
+ ttst_stpld_yposdiff = ttst_track_params(2,2) - tdeuton1_y(3)
+ ttst_stpld_thposdiff = ttst_track_angle(1) - atan(tdeuton1_dir(1))
+ ttst_stpld_phposdiff = ttst_track_angle(2) - atan(tdeuton1_dir(2))
+
+* write out track nutples only for 4x + 4y = 8 hit events?
+c type *,'nt trk write:',ttst_straw_xgddmx,ttst_straw_ygddmx
+c type *,ttst_straw_xplnsht,ttst_straw_yplnsht
+c type *,tdeuton1_x(1),tdeuton1_dir(1)
+c type *,tdeuton1_y(1),tdeuton1_dir(2)
+ if(ttst_straw_xgddmx.lt.4)return
+ if(ttst_straw_ygddmx.lt.4)return
+ if(ttst_straw_xplnsht.lt.4)return
+ if(ttst_straw_yplnsht.lt.4)return
+c if the polder chambers do not track, they will give positions of 0.,0.
+c so let's make sure as first step that neither chamber gives 0's in
+c both x and y...
+c the way the algorithym appears to work, an angle is calculated even if
+c a chamber does not track
+ if(tdeuton1_x(1).eq.0. .and. tdeuton1_y(1).eq.0.)return
+ if(tdeuton1_x(2).eq.0. .and. tdeuton1_y(2).eq.0.)return
+ if(tnbpartch.ge.2)return !looks like >= 2 particles in polder mwpcs
+ if(abs(tdeuton1_x(1)).gt.10.)return
+ if(abs(tdeuton1_x(2)).gt.10.)return
+
+ ttst_good_comp = 1
+
+ if( ttst_track_ntuples_out.le.0) return
+ if( track_ntuples_written.gt.ttst_track_ntuples_out) return
+ if( track_ntuples_written.eq.ttst_track_ntuples_out) then
+ write(6,*)' t_test_straw_analyze wrote',
+ + track_ntuples_written,'track ntuples'
+ track_ntuples_written = track_ntuples_written + 1
+ endif
+ if( opened.eq.0 ) then
+ opened = 1
+ open(unit=lun_calib,file='t20_test_track.ntuple',status='new')
+ endif
+
+ track_ntuples_written = track_ntuples_written + 1
+c type *,track_ntuples_written,' trks written'
+ write(lun_calib,'(4(f7.2,f7.4))')
+ + tdeuton1_x(1),tdeuton1_dir(1),tdeuton1_y(1),tdeuton1_dir(2),
+ + ttst_track_chmbrpos(1),ttst_track_params(1,1),
+ + ttst_track_chmbrpos(2),ttst_track_params(1,2)
+
+ return
+ end
+ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c following is the tracking routine, copied over and slightly modified
+c from the Rutgers / LA analysis... all variables in this routine will
+c be left as local variables, all histogramming, etc., will be done above
+c
+c the following subroutine trk4 is taken from LA analysis code by RG
+c modified by RG 1/30/97 to use for t20 analysis
+c note that this routine assumes the hits come in ordered, all hits
+c on a plane are together, and wire number is monotonic
+c
+ subroutine trk4(nhit,hit,ntrack,track)
+c input:
+ integer*4 nhit(*) !number of hits(plane)
+ real*4 hit(4,10,4) !hit info(info type, hit on plane, plane)
+c hit(1,x,y)=wire#
+c (2,x,y)=drift distance
+c (3,x,y)=z position
+c (4,x,y)=x position
+c (5,x,y)=residual, track to (pos+/-dpos)?
+c hit(5,x,y)=group (for residual histing) - not used here
+c output:
+ integer*4 ntrack !# of tracks
+ real*4 track(3) !track information
+c track(1,i)=parameter a in az+b
+c (2,i)=parameter b in az+b
+c (3,i)=chi2 (actually just a rms)
+c (4,i)=hit channel in x1 0. if not used,
+c (5,i)=hit channel in x2 positive if L-side hit
+c (6,i)=hit channel in x3 negative if R-side hit
+c (7,i)=hit channel in x4
+c the second index above was to handle multiple tracks, removing
+ common /effarray/nhgood(80,4), nhbad(80,4), sigbad(80,4)
+c local variables:
+ integer*4 lrfit(10)
+ integer*4 iok3, iok43, iok4, utra(10), nwtra(10), nptra(10)
+ integer*4 ufnd(10,3), lrfnd(10,3), lrf3(10)
+ real*4 chfnd(3), sfnd(3), xfnd(3)
+ real*4 ztra(10), xtra(10), dxtra(10), dxfit(10)
+ real*4 chi0, chif, chf3(10)
+ real*4 xmin, xmax
+ integer*4 nhitx
+c
+c initialize
+ iok3 = -1
+ iok4 = -1
+ iok43 = -1
+ chif = -1.
+ xat0 = -1000.
+ slope = -1000.
+ track(1) = slope
+ track(2) = xat0
+ track(3) = chif
+c
+c start analysis
+ ntrack = 0
+ nhitx = nhit(1)+nhit(2)+nhit(3)+nhit(4)
+ nhitx0 = nhitx
+ nplane = 0
+ do i = 1, 4
+ if(nhit(i).gt.0)nplane = nplane + 1
+ enddo
+c
+c bag out if too few hits / too few planes
+ if(nhitx.lt.3 .or. nplane.lt.3)return
+c
+c fill arrays
+ k = 0
+ xmin = 99.
+ xmax = -99.
+ do i=1, 4
+ if(nhit(i).gt.0)then
+ do j = 1, nhit(i)
+ k = k + 1
+ ztra(k) = hit(3,j,i)
+ xtra(k) = hit(4,j,i)
+ dxtra(k) = hit(2,j,i)
+ utra(k) = 1
+ dxfit(k) = 0.
+ nwtra(k) = hit(1,j,i)
+c nptra(k) = 1 + nint( 0.33333*(ztra(k)-zoff) )
+ nptra(k) = i
+ if(nptra(k).gt.4 .or. nptra(k).lt.1)nptra(k) = 0
+ if(xtra(k).lt.xmin)xmin = xtra(k)
+ if(xtra(k).gt.xmax)xmax = xtra(k)
+ enddo
+ endif
+ enddo
+c
+1 continue !come here if remove hits
+c
+c analyze 3 hit events, require 3 planes to be hit
+ if(nhitx.eq.3)then
+ chi0 = 0.0
+ chif = 0.0
+ call trackit
+ + (nhitx,ztra,xtra,dxtra,utra,dxfit,lrfit,xat0,slope,chi0,chif)
+ if(chif.gt.0.)then
+ chif = sqrt(chif/3.)
+ else
+ chif = 0.
+ endif
+ if(chi0.gt.0.)then
+ chi0 = sqrt(chi0/3.)
+ else
+ chi0 = 0.
+ endif
+ endif
+c analyze tracks with 4 hits on 3 planes - straight line + arc
+ if(nhitx.eq.4 .and. nplane.eq.3)then
+ do i = 1, 3
+ if(ztra(i).eq.ztra(i+1))j = i
+ enddo
+c if two hits on adjacent wires, fit as if 4 planes
+ if( abs(xtra(j)-xtra(j+1)) .lt. 1.1 )then !adjacent wires
+ iok4 = 3
+ call trackit
+ + (nhitx,ztra,xtra,dxtra,utra,dxfit,lrfit,xat0,slope,chi0,chif)
+ if(chif.gt.0.)then
+ chif = sqrt(chif/4.)
+ else
+ chif = 0.
+ endif
+ if(chi0.gt.0.)then
+ chi0 = sqrt(chi0/4.)
+ else
+ chi0 = 0.
+ endif
+ go to 2
+ endif
+c try to delete worse of two hits -- one that gives worse straight
+c line fit
+ nhitx = 3
+ utra(j) = -1
+ call trackit
+ + (nhitx,ztra,xtra,dxtra,utra,dxfit,lrfit,xat0,slope,chi0,chif)
+ chisave = chi0
+ utra(j) = 1
+ utra(j+1) = -1
+ call trackit
+ + (nhitx,ztra,xtra,dxtra,utra,dxfit,lrfit,xat0,slope,chi0,chif)
+ if(chisave.lt.chi0)then
+ utra(j) = -1
+ utra(j+1) = 1
+ endif
+ iok43 = 1
+ go to 1
+ endif
+
+2 continue
+
+c analyze 4 hit / 4 plane events
+ if(nhitx.eq.4 .and. nplane.eq.4)then
+ call trackit
+ + (nhitx,ztra,xtra,dxtra,utra,dxfit,lrfit,xat0,slope,chi0,chif)
+ if(chif.gt.0.)then
+ chif = sqrt(chif/4.)
+ else
+ chif = 0.
+ endif
+ if(chi0.gt.0.)then
+ chi0 = sqrt(chi0/4.)
+ else
+ chi0 = 0.
+ endif
+c if chisq large, see if should eliminate one of the hits
+ if(chif.gt.0.15)then !more than four x's nominal chisq
+ nhitx = 3
+ chmin = 9999999.
+ nmin = 0
+ do i = 1, 4
+ utra(i) = -1
+ call trackit
+ + (nhitx,ztra,xtra,dxtra,utra,dxf3,lrf3,x03,slop3,ch03,chf3(i))
+ chf3(i) = sqrt(chf3(i)/3.)
+ utra(i) = 1
+ if(chf3(i).lt.chmin)then
+ chmin = chf3(i)
+ nmin = i
+ endif
+ enddo
+ if(nmin.ne.0.)then
+ iok3 = 1
+ do i = 1, 4
+ if(i.ne.nmin .and. chf3(i).lt.1.5*chmin)iok3 = -1
+ enddo
+ if(iok3.eq.1)then
+ utra(nmin) = -1
+ iok3 = -1
+ iok43 = 1
+ go to 1
+ endif
+ endif
+ nhitx = 4
+ endif
+ endif
+
+c
+c 5 or 6 hit events: require track to have nhits, nhits-1, or nhits-2
+c ==> no 3+3 two tracks found for nhitx=6
+c 1 track w/ double on one plane
+c 1 track w/ 2 accidentals (3 or 4 planes)
+c 2 tracks sharing 1 hit (3 or 4 planes)
+c increase and let it consider 7,8 hit events...
+ if(nhitx.ge.5 .and. nhitx.le.10)then
+ do i = 1, nhitx-1
+ if(ztra(i).eq.ztra(i+1) .and.
+ + abs(xtra(i)-xtra(i+1)) .gt. 1.1) go to 5
+ enddo
+c try for nhitx hit track if same plane hits adjacent
+ call trackit
+ + (nhitx,ztra,xtra,dxtra,utra,dxfit,lrfit,xat0,slope,chi0,chif)
+ if(chif.gt.0.)then
+ chif = sqrt(chif/nhitx)
+ else
+ chif = 0.
+ endif
+ if(chi0.gt.0.)then
+ chi0 = sqrt(chi0/nhitx)
+ else
+ chi0 = 0.
+ endif
+ if(chif.lt.0.15)go to 3
+c try for 4 hit track otherwise, or if 5 hit chisq bad
+5 nhitx = nhitx - 1
+ chmin = 1.5
+ nmin = 0
+ do i = 1, nhitx0
+ utra(i) = -1
+ call trackit
+ + (nhitx,ztra,xtra,dxtra,utra,dxf3,lrf3,x03,slop3,ch03,chf3(i))
+ chf3(i) = sqrt(chf3(i)/nhitx)
+ if(chf3(i).lt.chmin)then
+ chmin = chf3(i)
+ nmin = i
+ chfnd(1) = chf3(nmin)
+ do l = 1, nhitx0
+ ufnd(l,1) = utra(l)
+ lrfnd(l,1) = lrf3(l)
+ enddo
+ xfnd(1) = x03
+ sfnd(1) = slop3
+ endif
+ utra(i) = 1
+ enddo
+ if(nmin.ne.0.)then
+ chif = chfnd(1)
+ do l = 1, nhitx0
+ utra(l) = ufnd(l,1)
+ lrfit(l) = lrfnd(l,1)
+ enddo
+ xat0 = xfnd(1)
+ slope = sfnd(1)
+ go to 3
+ endif
+c do following analysis for 5,6 hits only. For more hits, have
+c to get good fit from all or all - 1
+ if(nhitx0.gt.6)return
+c if no good 4/5 hit tracks, try for good 3 hit track
+c require each hit to be on different plane
+c if 2 good 3 hit tracks, keep only one with better chisq
+c above comments similar for nhitx0 = 6
+c loop over 2 hits to remove...
+ nhitx = nhitx - 1
+ chmin = 1.5
+ nmin = 0
+ do i = 1, nhitx0-1
+ do j = i+1, nhitx0
+ do k = 1, nhitx0-1
+ do l = k+1, nhitx0
+ if(k.ne.i .and. k.ne.j .and. l.ne.i .and. l.ne.j)then
+ if(ztra(k).eq.ztra(l))go to 4
+ endif
+ enddo
+ enddo
+ do l = 1, nhitx0
+ if(l.eq.i .or. l.eq.j)then
+ utra(l) = -1
+ else
+ utra(l) = 1
+ endif
+ enddo
+ call trackit
+ + (nhitx,ztra,xtra,dxtra,utra,dxf3,lrf3,x03,slop3,ch03,chf3(1))
+ chf3(1) = sqrt(chf3(1)/nhitx)
+ if(chf3(1).lt.chmin .and. nmin.le.1)then
+ nmin = nmin + 1
+ chfnd(nmin) = chf3(1)
+ do l = 1, nhitx0
+ ufnd(l,nmin) = utra(l)
+ lrfnd(l,nmin) = lrf3(l)
+ enddo
+ xfnd(nmin) = x03
+ sfnd(nmin) = slop3
+ endif
+4 continue
+ enddo
+ enddo
+ if(nmin.eq.0)then
+ return
+ endif
+ if(nmin.eq.2)then !select better of 2 tracks
+ if(chfnd(1).lt.chfnd(2))nmin = 1
+ endif
+ xat0 = xfnd(nmin)
+ slope = sfnd(nmin)
+ chif = chfnd(nmin)
+ do l = 1, nhitx0
+ utra(l) = ufnd(l,nmin)
+ lrfit(l) = lrfnd(l,nmin)
+ enddo
+ endif
+3 continue
+
+c can have 2 tracks if 6 or more hits
+c bag out for now if more than 4
+ if(nhitx.gt.10)then
+ return
+ endif
+
+c following was setup for topdrawer plot, remove it
+c put positions at each plane into array
+c do i = 1, 4
+c z(i) = zoff + zplane(i)
+c x(i) = xat0 + slope*z(i)
+c enddo
+
+c work out good / bad statistics
+c do i = 1, nhitx0
+c if(nptra(i).ne.0)then
+c if(utra(i).eq.1)then
+c nhgood(nwtra(i),nptra(i)) =
+c + nhgood(nwtra(i),nptra(i)) + 1
+c else
+c if(x(nptra(i)).gt.-50.)then
+c nhbad(nwtra(i),nptra(i)) =
+c + nhbad(nwtra(i),nptra(i)) + 1
+c if(x(nptra(i)).gt.xtra(i))then
+c sigbad(nwtra(i),nptra(i)) =
+c + sigbad(nwtra(i),nptra(i)) +
+c + x(nptra(i)) - xtra(i) - dxtra(i)
+c else
+c sigbad(nwtra(i),nptra(i)) =
+c + sigbad(nwtra(i),nptra(i)) +
+c + x(nptra(i)) - xtra(i) + dxtra(i)
+c endif
+c endif
+c endif
+c endif
+c enddo
+
+c hist chi sq -- actually sigma in units of mm....
+c call hf1(653, chi0, 1.)
+c call hf1(655, chif, 1.)
+
+
+c histogram the residuals...on 4hit tracks only
+c see sigbad stuff above for times when not hit
+c k = 0
+c do i = 1, 4
+c if(nhit(i).gt.0)then
+c do j=1, nhit(i)
+c k = k + 1
+c if(utra(k).eq.1)then
+c call hf1(612+i, dxfit(k), 1.)
+c igr = hit(5,j,i)
+c call hf1(616+igr, dxfit(k), 1.)
+c endif
+c enddo
+c endif
+c enddo
+
+c store results of one track fit in track(*,*) array
+ ntrack = 1
+ track(1) = slope
+ track(2) = xat0
+ track(3) = chif
+
+c k = 0
+c do i = 1, 4
+c track(3+i) = 0.
+c if(nhit(i).eq.1)then
+c k = k + 1
+c if(lrfit(k).ne.0)track(3+i) = hit(1,1,i) * lrfit(k)
+c endif
+c if(nhit(i).gt.1)then
+c do j = 1, nhit(i)
+c k = k + 1
+c if(lrfit(k).ne.0 .and. track(3+i).eq.0.)
+c + track(3+i) = hit(1,1,i) * lrfit(k)
+c enddo
+c endif
+c enddo
+c
+ return
+c
+c all tracks need to have >=3 hits
+c
+c accpt varies across chamber, but is generally only a little
+c larger than 45 degrees - set 60 degrees to maximum, ==> ~+/-6cm
+c from one plane to the next to determine which hits are in road
+c
+c technique is to find set of 3 hits
+c see if can include more as part of track
+c try to put track to remaining hits
+c -avoid repeating set of hits
+c -find best fit set of tracks in some sense
+c
+ end
+
+ subroutine trackit(nt,zt,xt,dxt,ut,dxf,lrf,x0,tht,chi0,chif)
+ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c subroutine track(ntr,ztra,xtra,dxtra,dxfit,lr,x0,thtx,chibest)
+c
+c fits hits nominal positions z, x, xdrift to a straight line
+c x = mz + b
+c
+c ntr number of hits
+c ztra z positions of track hits (cm)
+c xtra x positions of track hits (cm)
+c dxtra drift distances for track (cm)
+c dxfit (fit distance from wire - drift distance from wire) (cm)
+c lr ``left/right'' of track at each wire
+c x0 b of the fit (cm)
+c thtx arctan(m) from the fit (mr)
+c chibest best fit chi square, assuming sigma = 0.1 (cm, if all else is)
+c
+c first find best fit using wire positions only, to get starting estimate
+c of track
+c then loop over each combination of l/r's wth drift distances, to get
+c best fit for each combination, leading to best fit
+c iterate using previous theta values to start another fit to improve
+c theta; it appears wires + 2 iterations with drift distances
+c are quite enough.
+c
+c subroutine track(nt,zt,xt,dxt,dxf,lrf,x0,tht,chi0,chif)
+ implicit none
+ real zt(10), xt(10), dxt(10), dxf(10), x0, tht, chi0, chif
+ integer nt, lrf(10), nlrin
+ integer lr(10), i, j, ibetin, ibetter
+ integer nloop, iloop(10)
+ integer nlr, ju(10), ut(10), ninput
+ real xx(10), zz(10), dxx(10), del(10)
+ real driftfit(10)
+ real xbar, ybar, xsqbar, xybar
+ real slope, ctg, stg, rcept
+ real chisq, dx2, chibest
+ real chiterm(10), diff
+ real sigma, pi
+ data sigma, pi /1.0, 3.1415926/
+
+c first move input data into local arrays
+ j = 0
+ do i = 1, nt
+900 j = j + 1
+ if(j.gt.10)then
+ write(*,*)' err in trackit -- found',i-1,' of',nt,
+ + ' hits w/',j-1,' inputs'
+ chi0 = 9999999.
+ chif = 9999999.
+ return
+ endif
+ if(ut(j).ne.1)go to 900
+ lr(i) = 0
+ ju(i) = j
+ enddo
+ ninput = j
+ nlr = nt
+ nlrin = nlr
+ chi0 = 0.
+c other setup
+1 ibetin = 2
+ chibest = 999998.
+c first estimate theta from wire positions only
+ xbar = 0
+ ybar = 0
+ xsqbar = 0
+ xybar = 0
+ do i = 1, nt
+ dxx(i) = dxt(ju(i))
+ xx(i) = xt(ju(i))
+ zz(i) = zt(ju(i))
+ xbar = xbar + zz(i)
+ xsqbar = xsqbar + zz(i)**2
+ ybar = ybar + xx(i)
+ xybar = xybar + zz(i)*xx(i)
+ enddo
+ xbar = xbar / nlr
+ xsqbar = xsqbar / nlr
+ ybar = ybar / nlr
+ xybar = xybar / nlr
+ diff = xsqbar - xbar**2
+ if(diff.ne.0.)then
+ slope = (xybar - xbar*ybar) / diff
+ ctg = 1./sqrt(1.+slope**2)
+ stg = slope*ctg
+ else
+ ctg = 0.
+ stg = 1.
+ endif
+c
+ nloop = 2**nlr
+ do i = 1, nloop
+c set up all +/- combinations to loop over
+ call seti(nlr,i,iloop)
+ ibetter = 1
+100 xbar = 0
+ ybar = 0
+ xsqbar = 0
+ xybar = 0
+ do j = 1, nlr
+ xx(j) = xt(ju(j)) + iloop(j)*dxx(j)*ctg
+ zz(j) = zt(ju(j)) - iloop(j)*dxx(j)*stg
+c calculate best track for this combination
+c y=f(x) <---> x=f(z)
+ xbar = xbar + zz(j)
+ xsqbar = xsqbar + zz(j)**2
+ ybar = ybar + xx(j)
+ xybar = xybar + zz(j)*xx(j)
+ enddo
+ xbar = xbar / nlr
+ xsqbar = xsqbar / nlr
+ ybar = ybar / nlr
+ xybar = xybar / nlr
+ diff = xsqbar - xbar**2
+ if(diff.ne.0.)then
+ slope = (xybar - xbar*ybar) / diff
+ ctg = 1./sqrt(1.+slope**2)
+ stg = slope*ctg
+ rcept = -1.*(xybar*xbar-xsqbar*ybar) / diff
+ else
+ ctg = 0.
+ stg = 1.
+ rcept = -999999.
+ slope = 999999.
+ endif
+c iterate a few times to converge
+ if(ibetter.le.ibetin)then
+ ibetter = ibetter + 1
+ go to 100
+ endif
+c calculate chisq
+ chisq = 0.
+ do j = 1, nlr
+ dx2 = slope * zt(ju(j)) + rcept - xt(ju(j))
+ driftfit(j) = dx2 * ctg
+c adjust dxfit sign if track on opposite side of wire from drift distance
+c dx2>0 --> track on + side of wire, dx2<0 --> track on - side of wire
+c lr = 1--> track on + side of wire, lr=-1 --> track on - side of wire
+c use iloop if lr = 0... note dx always +
+c... note: lr always 0 in Los Alamos case, but do not change code below
+ if(driftfit(j).gt.0) then !track on + side of wire
+ if(lr(j).eq.1 .or. (lr(j).eq.0.and.iloop(j).eq.1)) then
+ del(j) = driftfit(j) - dxx(j) !track +, drift +
+ else
+ del(j) = driftfit(j) + dxx(j) !track +, drift -
+ endif
+ else !track on - side of wire
+ if(lr(j).eq.-1 .or. (lr(j).eq.0.and.iloop(j).eq.-1))then
+ del(j) = driftfit(j) + dxx(j) !track -, drift -
+ else
+ del(j) = driftfit(j) - dxx(j) !track -, drift +
+ endif
+ endif
+ chiterm(j) = (del(j)/sigma)**2
+ chisq = chisq + chiterm(j)
+ enddo
+c save if best fit so far
+ if(chisq.lt.chibest)then
+c save lr input to fit, not side of wire of fit
+ do j = 1, ninput
+ dxf(j) = 0.
+ lrf(j) = 0
+ enddo
+ do j = 1, nlr
+ dxf(ju(j)) = del(j)
+ if(iloop(j).lt.0)then
+ lrf(ju(j)) = -1
+ else
+ lrf(ju(j)) = 1
+ endif
+ enddo
+ tht = slope
+ x0 = rcept
+ chibest = chisq
+ endif
+ enddo
+ if(chi0.le.0)chi0 = chibest
+ chif = chibest
+
+c do not refit... leaving out worse chisq point if chisq too large
+c only do once
+c with sigma = 0.1 cm, and want point off by 3+ cm, require
+c chi > 30**2 ==> 1000
+c if(nlrin.eq.nlr .and. chibest.gt.(1000.) .and. nlr.gt.3)then
+c dx2 = chiterm(1)
+c i1 = 1
+c do j = 1, nlr
+c lrf(ju(j)) = 0
+c enddo
+c do j = 2, nlr
+c if(chiterm(j).gt.dx2)then
+c dx2 = chiterm(j)
+c i1 = j
+c endif
+c enddo
+c nlr = nlr - 1
+c if(i1.le.nlr)then
+c do j = i1, nlr-1
+c ju(j) = ju(j+1)
+c enddo
+c endif
+c lrf(i1) = -99
+c go to 1
+c endif
+
+ return
+ end
+ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+ subroutine seti(ntr,i,iloop)
+c subroutine to set phases for loop combinations
+ implicit none
+ integer*4 ntr, i, iloop(10)
+ integer*4 j, k, jn, jrem
+c
+
+ j = i-1
+ do k = 1, ntr
+ jn = j/2
+ jrem = j - 2*jn
+ if(jrem.eq.0)then
+ iloop(k) = 1
+ else
+ iloop(k) = -1
+ endif
+ j = jn
+ enddo
+ return
+ end
+
+ccccccccccccc put scintillator analysis here....
+ subroutine t_test_scint_analyze
+ implicit none
+
+
+* subroutine: t_test_scint_analyze.f
+* written: R. Gilman, Dec 20 1996
+* purpose: Use raw scintillator times to get positions in scintillators,
+* recalibrate scintillators, and get time offsets to improve
+* chamber resolution.
+* The 4th phototube is assumed to be the self timing one.
+***************************************************************************
+* Local Variables
+
+ include 't20_test_detectors.cmn'
+ include 't20_data_structures.cmn'
+ include 't20_misc.cmn'
+
+ integer*4 i,j
+ real*4 t,f
+
+c the test scintillators are plugged into adcs 7 - 10 of the polder
+c strat adc, thus the addr1 is 1 and the addr2 is 7 - 10...
+c by initializing all the values to -10000, any valu not found will cause
+c a negative mean value, making it clear the event is not a proper
+c average
+c at some point the histograms should be used to determine pedestal
+c values, but we need to look at the pedestals or hope this is auto-done
+c by hall c software...
+
+ do j = 1, 4
+ ttst_scin_rawadc(j) = -10000
+ ttst_scin_psadc(j) = -10000
+ enddo
+
+ i = 1
+ do i = 1, tmisc_tot_hits
+ if(tmisc_raw_addr1(i).eq.1)then
+ if(tmisc_raw_addr2(i).gt.6 .and. tmisc_raw_addr2(i).lt.11)then
+ j = tmisc_raw_addr2(i) - 6
+ ttst_scin_rawadc(j) = tmisc_raw_data(i)
+ ttst_scin_psadc(j) = tmisc_raw_data(i)
+ + - ttst_scin_peds(j)
+ endif
+ endif
+ enddo
+
+* work out geo and arith means for sintillators
+ ttst_scin_amean_adc = 0
+ ttst_scin_nzadcs = 0
+ f = 1.
+ do j = 1, 4
+ if(ttst_scin_psadc(j).gt.0.)then
+ ttst_scin_nzadcs = ttst_scin_nzadcs + 1
+ ttst_scin_amean_adc = ttst_scin_amean_adc +
+ + ttst_scin_psadc(j)
+ f = f * ttst_scin_psadc(j)
+ endif
+ enddo
+ t = ttst_scin_nzadcs
+ if(ttst_scin_nzadcs.gt.0)then
+ ttst_scin_amean_adc = ttst_scin_amean_adc / ttst_scin_nzadcs
+ ttst_scin_gmean_adc = nint(f ** (1./t))
+ else
+ ttst_scin_amean_adc = -1
+ ttst_scin_gmean_adc = -1
+ endif
+
+* work out means of two signals for scint 1 and for scint 2
+ ttst_scin_adc1m = (ttst_scin_psadc(1) + ttst_scin_psadc(3))/2
+ ttst_scin_adc2m = (ttst_scin_psadc(2) + ttst_scin_psadc(4))/2
+
+* work out scintillator times
+* call ttst_scinadccor
+* do i = 1, 4
+* ttst_scin_tdccor(i) = ttst_scin_tdc(i) + ttst_scin_timeoff(i)
+* if(ttst_scin_off_parm.eq.1)
+* ttst_scin_tdccor(i) = ttst_scin_tdccor(i) + ttst_scin_adccor(i)
+* enddo
+*
+* ttst_scin_time1 = 0.5*(ttst_scint_tdc(1) + ttst_scint_tdc(2))
+* ttst_scin_time2 = 0.5*(ttst_scint_tdc(3) + ttst_scint_tdc(4))
+* ttst_scin_tim = 0.5*(ttst_scin_time1 + ttst_scin_time2)
+* ttst_scin_timecor1 =
+* + 0.5*(ttst_scint_tdccor(1) + ttst_scint_tdccor(2))
+* ttst_scin_timecor2 =
+* + 0.5*(ttst_scint_tdccor(3) + ttst_scint_tdccor(4))
+* ttst_scin_timcor =
+* + 0.5*(ttst_scin_timecor1 + ttst_scin_timecor2)
+
+* work out scintillator positions
+* The factor of 1/2 corrects for the fact
+* that one tube is earlier and the other is later, due to position offset.
+* The sign of the subtraction in the following equation must be checked.
+* ttst_scin_pos1 = ttst_scin_v_corr * 0.5 *
+* + (ttst_scint_tdccor(1) - ttst_scint_tdccor(2))
+* ttst_scin_pos2 = ttst_scin_v_corr * 0.5 *
+* + (ttst_scint_tdccor(3) - ttst_scint_tdccor(4))
+* ttst_scin_pos = 0.5*(ttst_scin_pos1 + ttst_scin_pos2)
+
+* calculate t0 offset correction for this event...
+* t0 is the time the particle actually passes through the chamber,
+* relative to the trigger time, this varies from event to event due
+* to positions, ...
+* in this routine calculate the time the p[article passes through the
+* scintilator, based on the scintillator measure of position... a
+* 0th order track from the chamber wires would probably give a better
+* measure, so leave as 0 for now...
+* ttst_t0_correction = 0.
+
+ return
+ end
+
+
diff --git a/T20/tengine.f b/T20/tengine.f
new file mode 100644
index 0000000..7bf2953
--- /dev/null
+++ b/T20/tengine.f
@@ -0,0 +1,711 @@
+* PROGRAM Engine
+*--------------------------------------------------------
+*- Prototype C analysis routine
+*-
+*- This is the analysis shell for CEBAF hall C.
+* It gets all of its instructions via the CTP package
+*- Loops through data until it encounters an error.
+*-
+*- Created 18-Nov-1993 Kevin B. Beard, Hampton Univ.
+* $Log: tengine.f,v $
+* Revision 1.1 1998/12/01 20:55:32 saw
+* Initial revision
+*
+* Revision 1.23 1996/11/08 15:40:09 saw
+* (JRA) Add analysis of epics events.
+*
+* Revision 1.22 1996/09/04 15:33:43 saw
+* (JRA) Assorted changes and diagnostics
+*
+* Revision 1.21 1996/04/29 19:19:04 saw
+* (JRA) Corrections
+*
+* Revision 1.20 1996/01/24 16:11:10 saw
+* (JRA) Change evtype to registered gen_event_type. Refresh statistics
+* file at a time interval rather than event interval
+*
+* Revision 1.19 1996/01/16 21:12:41 cdaq
+* (JRA) Add tcl run statistics display
+*
+* Revision 1.18 1995/10/09 19:59:00 cdaq
+* (JRA) Improve event counting for periodic dumping. Dump pedestal data
+* at end of run.
+*
+* Revision 1.17 1995/09/22 19:39:13 cdaq
+* (SAW) Move g_ctp_database from g_init_filenames to here. Process all
+* CTP command line vars after every ctp file read so that command line
+* overrides everything.
+*
+* Revision 1.16 1995/07/27 19:45:40 cdaq
+* (SAW) f2c compatibility changes. Only shutdown ntuples at very end.
+* ctp command line variables override at every oportunity
+*-
+* Revision 1.15 1995/05/11 19:02:23 cdaq
+* (SAW) Add ability to set CTP variables from the command line
+*
+* Revision 1.14 1995/04/01 20:12:58 cdaq
+* (SAW) Call g_proper_shutdown instead of dump_hists for periodic hist dumps
+*
+* Revision 1.13 1995/03/13 18:11:05 cdaq
+* (JRA) Write scaler report when histograms are dumped at intervals
+*
+* Revision 1.12 1995/01/31 21:12:17 cdaq
+* (SAW) Add gen_run_hist_dump_interval for in run hist dumping. Add commented
+* out code to query user for # of event and hist dump interval.
+*
+* Revision 1.11 1994/11/22 20:12:01 cdaq
+* (SAW) Change "" to " " so this would compile under ultrix.
+*
+* Revision 1.10 1994/10/19 20:40:29 cdaq
+* (SAW) Add handling of RPC requests
+*
+* Revision 1.9 1994/07/07 15:28:29 cdaq
+* (SAW) Move check for scaler event to proper place
+*
+* Revision 1.8 1994/06/26 02:07:03 cdaq
+* (KBB) Add ability to analyze selected subset of events. Add evcount stats.
+* (SAW) Add call to scaler analysis
+*
+* Revision 1.7 1994/06/17 03:35:00 cdaq
+* (KBB) Upgrade error reporting
+*
+* Revision 1.6 1994/06/15 14:27:30 cdaq
+* (SAW) Actually add call to g_examine_physics_event
+*
+* Revision 1.5 1994/06/07 18:22:58 cdaq
+* (SAW) Add calls to g_examine_physics_event and g_examine_control_event
+*
+* Revision 1.4 1994/04/15 20:31:25 cdaq
+* (SAW) Changes for ONLINE use
+*
+* Revision 1.3 1994/03/24 22:02:12 cdaq
+* Reorganize for online compatibility
+*
+* Revision 1.2 1994/02/11 18:32:06 cdaq
+* Split off CTP variables registration from initialize routines
+*
+* Revision 1.1 1994/02/04 21:04:59 cdaq
+* Initial revision
+*
+*-
+*--------------------------------------------------------
+ IMPLICIT NONE
+ SAVE
+*
+ character*6 here
+ parameter (here= 'Engine')
+*
+ logical ABORT,EoF
+ character*800 err,mss
+*
+ include 'gen_filenames.cmn'
+ include 'gen_craw.cmn'
+ include 'gen_run_info.cmn'
+ include 'gen_event_info.cmn'
+ include 'gen_run_pref.cmn'
+ include 'gen_routines.dec'
+ include 'gen_scalers.cmn'
+ include 'gen_data_structures.cmn'
+ include 'hms_data_structures.cmn'
+ include 't20_data_structures.cmn'
+*
+ logical problems, finished_extracting
+ integer total_event_count
+ integer physics_events
+ integer analyzed_events(0:gen_max_trigger_types)
+ integer sum_analyzed
+ integer recorded_events(0:gen_max_trigger_types)
+ integer sum_recorded
+ integer num_events_skipped
+ integer i,since_cnt,lastdump
+ integer rpc_pend ! # Pending asynchronous RPC requests
+*
+ character*80 g_config_environmental_var
+ parameter (g_config_environmental_var= 'ENGINE_CONFIG_FILE')
+*
+ integer*4 jishft,jiand
+*
+ integer ierr
+ integer*4 status
+ integer*4 evclose
+ character*132 file
+ character*20 groupname
+ character*132 system_string
+*
+* real*4 ebeam,phms,thms,psos,tsos,ntarg
+ real*4 ebeam,phms,thms,pt20,tt20,ntarg
+*
+ integer start_time,lasttime
+ integer time
+ integer*4 preprocessor_keep_event
+ external time
+*
+*
+*--------------------------------------------------------
+*
+ print *
+ print *,' Hall C Proudly Presents: PHYSICS Analysis Engine - Spring 1996'
+*
+ print *
+*
+ total_event_count= 0 ! Need to register this
+ lastdump=0
+ do i=0,gen_max_trigger_types
+ analyzed_events(i)=0
+ recorded_events(i)=0
+ enddo
+ sum_analyzed=0
+ sum_recorded=0
+ num_events_skipped=0
+*
+ rpc_on=0 ! RPC servicing off by default
+ rpc_control=-1 ! If RPC on, don't block by default
+*
+ call g_register_variables(ABORT,err)
+ if(ABORT.or.err.ne.' ') then
+ call G_add_path(here,err)
+ call G_rep_err(ABORT,err)
+ If(ABORT) STOP
+ err= ' '
+ ENDIF
+*
+ g_config_filename = ' '
+*
+ call engine_command_line(.false.) ! Set CTP vars from command line
+*
+ call G_init_filenames(ABORT,err,g_config_environmental_var)
+ if(ABORT.or.err.ne.' ') then
+ call G_add_path(here,err)
+ call G_rep_err(ABORT,err)
+ If(ABORT) STOP
+ err= ' '
+ ENDIF
+*
+ call engine_command_line(.false.) ! Set CTP vars from command line
+*
+* If there is a g_ctp_database_filename set, pass the run number
+* to it to set CTP variables
+*
+ if(.not.ABORT.and.g_ctp_database_filename.ne.' ') then
+ call g_ctp_database(ABORT, err
+ $ ,gen_run_number, g_ctp_database_filename)
+ IF(ABORT) THEN
+ call G_add_path(here,err)
+ endif
+ ENDIF
+*
+ call engine_command_line(.false.) ! Set CTP vars from command line
+*
+ call G_decode_init(ABORT,err)
+ if(ABORT.or.err.ne.' ') then
+ call G_add_path(here,err)
+ call G_rep_err(ABORT,err)
+ If(ABORT) STOP
+ err= ' '
+ endif
+*
+
+
+ g_data_source_opened = .false. !not opened yet
+ g_data_source_in_hndl= 0 !none
+ call G_open_source(ABORT,err)
+ if(ABORT.or.err.ne.' ') then
+ call G_add_path(here,err)
+ call G_rep_err(ABORT,err)
+ If(ABORT) STOP
+ err= ' '
+ endif
+*
+* if preprocessor on, open event file
+*
+ if(g_preproc_on.ne.0)then
+ g_preproc_opened=.false. !not opened yet
+ g_preproc_in_hndl=0 !none IO opened
+ call g_preproc_open(ABORT,err)
+ if (ABORT.or.err.ne.' ')then
+ call G_add_path(here,err)
+ call G_rep_err(ABORT,err)
+ if (ABORT) STOP
+ err=' '
+ endif
+ write(6,*)'Opened CODA event file for preprocessor output'
+ endif
+
+ finished_extracting = .false.
+ finished_extracting = .true. ! For t20 EEL detector tests
+c The above line causes the following DO WHILE loop to be skipped for now.
+ DO WHILE(.NOT.problems .and. .NOT.ABORT .and. .NOT.EoF .and.
+ & .NOT.finished_extracting)
+ mss= ' '
+ g_replay_time=time()-start_time
+*
+ call G_clear_event(ABORT,err) !clear out old data
+ problems= problems .OR. ABORT
+*
+ if(mss.NE.' ' .and. err.NE.' ') then
+ call G_append(mss,' & '//err)
+ elseif(err.NE.' ') then
+ mss= err
+ endif
+*
+ If(.NOT.problems) Then
+ call G_get_next_event(ABORT,err) !get and store 1 event
+ problems= problems .OR. ABORT
+ if(.NOT.ABORT) total_event_count= total_event_count+1
+*
+ EndIf
+*
+ if(mss.NE.' ' .and. err.NE.' ') then
+ call G_append(mss,' & '//err)
+ elseif(err.NE.' ') then
+ mss= err
+ endif
+*
+* Check if this is a physics event or a CODA control event.
+*
+ if(.not.problems) then
+ gen_event_type = jishft(craw(2),-16)
+ if(gen_event_type.eq.1) gen_event_type = 2 ! T20 temporary hack for EEL runs
+ if(gen_event_type.le.gen_MAX_trigger_types) then
+ recorded_events(gen_event_type)=recorded_events(gen_event_type)+1
+ sum_recorded=sum_recorded+1
+ print *,gen_event_type
+ write(6,*) "AAAAAAAAAAHHHHHHHHHHHHHHHHHHHHHHHHHHH!!!!!!!!!!"
+ write(6,*) "Whew, I feel much bettter now"
+ write(6,*) "However, you might want to know that I've hit a physics event"
+ write(6,*) "In my run info event loop and THAT SHOULD NEVER HAPPEN!!!"
+ write(6,*) "KILL ME!!! KILL ME NOW!!!!!"
+ endif
+*
+* if preprocessor is on write all events of trig type > 16
+* (i.e. all non-physics events)
+*
+ if(gen_event_type.ge.(gen_max_trigger_types-1) .and.
+ $ g_preproc_on.ne.0) then
+ call g_write_event(ABORT,err)
+ endif
+
+ if (gen_event_type.eq.130) then !run info event (get e,p,theta)
+ finished_extracting=.true.
+ write(6,'(a)') 'COMMENTS FROM RUN INFO EVENT'
+ call g_extract_kinematics(ebeam,phms,thms,pt20,tt20,ntarg)
+ write(6,'(a)') 'KINEMATICS FROM RUN INFO EVENT'
+c beam energy no longer in runinfo event.
+c if (ebeam.gt.10.) ebeam=ebeam/1000. !usually in MeV
+c write(6,*) ' gpbeam =',abs(ebeam),' GeV'
+c gpbeam=abs(ebeam)
+ write(6,*) ' hpcentral =',abs(phms),' GeV/c'
+ hpcentral=abs(phms)
+ write(6,*) ' htheta_lab =',abs(thms),' deg.'
+ htheta_lab=abs(thms)
+ write(6,*) ' tpcentral =',abs(pt20),' GeV/c'
+ tpcentral=abs(pt20)
+ write(6,*) ' ttheta_lab =',abs(tt20),' deg.'
+ ttheta_lab=abs(tt20)
+ write(6,*) ' gtarg_num =',abs(ntarg)
+ gtarg_num=ntarg
+ endif
+
+ if (gen_event_type.eq.131.or.gen_event_type.eq.133) then !past run info event. must be missing
+ write(6,*) "no run information event found"
+ finished_extracting=.true.
+ endif
+
+ endif !if .not.problems
+ enddo !do while .not.finished_extracting
+
+ call G_initialize(ABORT,err) !includes a total reset
+ IF(ABORT.or.err.NE.' ') THEN
+ call G_add_path(here,err)
+ call G_rep_err(ABORT,err)
+ If(ABORT) STOP
+ err= ' '
+ ENDIF
+*
+*-attempt to open FASTBUS-CODA file
+*
+c g_data_source_opened = .false. !not opened yet
+c g_data_source_in_hndl= 0 !none
+c call G_open_source(ABORT,err)
+c if(ABORT.or.err.ne.' ') then
+c call G_add_path(here,err)
+c call G_rep_err(ABORT,err)
+c If(ABORT) STOP
+c err= ' '
+c endif
+*
+ call engine_command_line(.false.) ! Set CTP vars from command line
+*
+* Print out the statistics report once...
+ if(g_stats_blockname.ne.' '.and.
+ $ g_stats_output_filename.ne.' ') then
+ file = g_stats_output_filename
+ call g_sub_run_number(file, gen_run_number)
+ ierr = threp(g_stats_blockname,file)
+ endif
+*
+* Comment out the following three lines if they cause trouble or
+* if wish is unavailable.
+*
+ write(system_string,*) 'runstats ',file(1:index(file,' ')-1), ' ',
+ $ gen_run_number, '> /dev/null 2>&1 &'
+ call system(system_string)
+*
+*-zero entire event buffer
+*
+ DO i=1,LENGTH_CRAW
+ CRAW(i)= 0
+ ENDDO
+*
+ since_cnt= 0
+ problems= .false.
+ EoF = .false.
+*
+ if(rpc_on.ne.0) then
+ print *,"*****************************************************"
+ print *," "
+ print *,"ENGINE is enabled to receive RPC requests"
+ if(rpc_control.eq.0) then
+ print *," "
+ print *,"ENGINE will HANG waiting for RPC requests"
+ else if(rpc_control.gt.0) then
+ print *,"ENGINE will HANG to waitfor RPC requests after "
+ $ ,rpc_control," events"
+ endif
+ if(rpc_control.ge.0) then
+ print *,"If you don't want this to happen, put one of the"
+ print *,"following in your CTP setup file"
+ print *," rpc_on = 0 ; Turns off RPC handling"
+ print *," rpc_control = -1 ; No Hanging, but RPC handled"
+ endif
+ print *," "
+ print *,"*****************************************************"
+
+ call thservset(0,0) !prepare for RPC requests
+
+ endif
+ rpc_pend = 0
+*
+ start_time=time()
+ lasttime=0.
+*
+ DO WHILE(.NOT.problems .and. .NOT.ABORT .and. .NOT.EoF)
+ mss= ' '
+ g_replay_time=time()-start_time
+*
+ call G_clear_event(ABORT,err) !clear out old data
+ problems= problems .OR. ABORT
+*
+ if(mss.NE.' ' .and. err.NE.' ') then
+ call G_append(mss,' & '//err)
+ elseif(err.NE.' ') then
+ mss= err
+ endif
+*
+ If(.NOT.problems) Then
+ call G_get_next_event(ABORT,err) !get and store 1 event
+ problems= problems .OR. ABORT
+ if(.NOT.ABORT) total_event_count= total_event_count+1
+*
+ EndIf
+*
+ if(mss.NE.' ' .and. err.NE.' ') then
+ call G_append(mss,' & '//err)
+ elseif(err.NE.' ') then
+ mss= err
+ endif
+*
+* Check if this is a physics event or a CODA control event.
+*
+ if(.not.problems) then
+ gen_event_type = jishft(craw(2),-16)
+ if(gen_event_type.eq.1) gen_event_type = 2 ! T20 temporary hack for EEL runs
+ if(gen_event_type.le.gen_MAX_trigger_types) then
+ recorded_events(gen_event_type)=recorded_events(gen_event_type)+1
+ sum_recorded=sum_recorded+1
+ endif
+*
+*if preprocessor is on write all events of trig type > 16
+* (i.e. all non-physics events)
+*
+ if(gen_event_type.ge.(gen_max_trigger_types-1) .and.
+ & g_preproc_on.ne.0)then
+ call g_write_event(ABORT,err)
+ endif
+
+ if (gen_event_type.eq.130) then !run info event (get e,p,theta)
+c call g_extract_kinematics(ebeam,phms,thms,psos,tsos)
+c if (gpbeam .ge. 7. .and. ebeam.le.7.) then !sometimes ebeam in MeV
+c gpbeam=abs(ebeam)
+c write(6,*) 'gpbeam=',abs(ebeam),' GeV'
+c endif
+c if (hpcentral .ge. 7.) then
+c write(6,*) 'hpcentral=',abs(phms),' GeV/c'
+c hpcentral=abs(phms)
+c endif
+c if (htheta_lab .le. 0.) then
+c write(6,*) 'htheta_lab=',abs(thms),' deg.'
+c htheta_lab=abs(thms)*3.14159265/180.
+c endif
+c if (spcentral .ge. 7.) then
+c write(6,*) 'spcentral=',abs(psos),' GeV/c'
+c spcentral=abs(psos)
+c endif
+c if (stheta_lab .le. 0.) then
+c write(6,*) 'stheta_lab=',abs(tsos),' deg.'
+c stheta_lab=abs(tsos)*3.14159265/180.
+c endif
+ endif
+
+
+ if(jiand(CRAW(2),'FFFF'x).eq.'10CC'x) then ! Physics event
+*
+ if(gen_event_type.le.gen_MAX_trigger_types .and.
+ $ gen_run_enable(gen_event_type-1).ne.0) then
+
+ call g_examine_physics_event(CRAW,ABORT,err)
+ if(gen_event_type.eq.1) gen_event_type = 2 ! T20 temporary hack for EEL runs
+ problems = problems .or.ABORT
+*
+ if(mss.NE.' ' .and. err.NE.' ') then
+ call G_append(mss,' & '//err)
+ elseif(err.NE.' ') then
+ mss= err
+ endif
+*
+*
+ IF(num_events_skipped.lt.gen_run_starting_event .and.
+ $ gen_event_type.ne.4) THEN ! always analyze peds.
+ num_events_skipped = num_events_skipped + 1
+ ELSE
+ if(gen_run_starting_event.eq.gen_event_id_number)
+ & start_time=time() !reset start time for analysis rate
+ if(.NOT.problems) then
+ call G_reconstruction(CRAW,ABORT,err) !COMMONs
+ physics_events = physics_events + 1
+ analyzed_events(gen_event_type)=analyzed_events(gen_event_type)+1
+ sum_analyzed=sum_analyzed+1
+ problems= problems .OR. ABORT
+ endif
+*
+ if(mss.NE.' ' .and. err.NE.' ') then
+ call G_append(mss,' & '//err)
+ elseif(err.NE.' ') then
+ mss= err
+ endif
+*
+ groupname=' '
+ if (gen_event_type.eq.1) then
+ groupname='hms'
+ else if (gen_event_type.eq.2) then
+ groupname='t20'
+ else if (gen_event_type.eq.3) then
+ groupname='both'
+ else if (gen_event_type.eq.4) then
+ start_time=time() !reset start time for analysis rate
+ groupname='ped'
+ else
+ write(6,*) 'gen_event_type= ',gen_event_type,' for call to g_keep_results'
+ endif
+*
+ If(.NOT.problems .and. groupname.ne.' ') Then
+ call G_keep_results(groupname,ABORT,err) !file away results as
+ problems= problems .OR. ABORT !specified by interface
+ EndIf
+*
+ if(mss.NE.' ' .and. err.NE.' ') then
+ call G_append(mss,' & '//err)
+ elseif(err.NE.' ') then
+ mss= err
+ endif
+
+*
+* if preprocessor is on check event for write criteria
+*
+ if(g_preproc_on.ne.0)then
+ if(.NOT.problems)then
+ call g_preproc_event(preprocessor_keep_event)
+ if(preprocessor_keep_event.eq.1)then
+ call g_write_event(ABORT,err)
+ endif
+ endif
+ endif
+
+*
+*- Here is where we insert a check for an Remote Proceedure Call (RPC)
+*- from another process for CTP to interpret
+*
+ if(rpc_on.ne.0) then
+ if(rpc_pend.eq.0.and.rpc_control.eq.0) then
+ do while(rpc_pend.eq.0.and.rpc_control.eq.0)
+ ierr = thservone(-1) !block until one RPC request serviced
+ rpc_pend = thcallback()
+ enddo
+ else
+ ierr = thservone(0) !service one RPC requests
+ rpc_pend = thcallback()
+ endif
+ if(rpc_pend.lt.0) rpc_pend = 0 ! Last thcallback took care of all
+ ! outstanding requests
+ if(rpc_control.gt.0) rpc_control = rpc_control - 1
+ endif
+
+ endif
+ else if (gen_event_type.eq.131) then ! EPICS event
+ call g_examine_epics_event
+ endif
+
+ Else
+ if(gen_event_type.eq.129) then
+ call g_analyze_scalers(CRAW,ABORT,err)
+* Dump report at first scaler event AFTER hist_dump_interval to keep hardware
+* and software scalers in sync.
+ if((physics_events-lastdump).ge.gen_run_hist_dump_interval.and.
+ & gen_run_hist_dump_interval.gt.0) then
+ lastdump=physics_events ! Wait for next interval of dump_int.
+ call g_proper_shutdown(ABORT,err)
+ print 112,"Finished dumping histograms/scalers for first"
+ & ,physics_events," events"
+ 112 format (a,i8,a)
+ endif
+ else if (gen_event_type.eq.133) then !SAW's new go_info events
+ call g_examine_go_info(CRAW,ABORT,err)
+ else
+ call g_examine_control_event(CRAW,ABORT,err)
+ endif
+ mss = err
+ EndIf
+ endif
+*
+*Now write the statistics report every 2 sec...
+*
+ if (g_replay_time-lasttime.ge.2) then !dump every 2 seconds
+ lasttime=g_replay_time
+ if(g_stats_blockname.ne.' '.and.
+ $ g_stats_output_filename.ne.' ') then
+ file = g_stats_output_filename
+ call g_sub_run_number(file, gen_run_number)
+ ierr = threp(g_stats_blockname,file)
+ endif
+ endif
+*
+ since_cnt= since_cnt+1
+ if(since_cnt.GE.5000) then
+ print *,' event#',total_event_count
+ since_cnt= 0
+ endif
+*
+ If(ABORT .or. mss.NE.' ') Then
+ call G_add_path(here,mss) !only if problems
+ call G_rep_err(ABORT,mss)
+ EndIf
+*
+ EoF= gen_event_type.EQ.20
+*
+ If(gen_run_stopping_event.GT.0 .and.
+ & gen_event_ID_number.GT.0) Then
+ EoF= EoF .or. gen_run_stopping_event.LE.sum_analyzed-
+ $ analyzed_events(4)
+ EndIf
+*
+*- Here is where we insert a check for an Remote Proceedure Call (RPC)
+*- from another process for CTP to interpret
+*
+ ENDDO !found a problem or end of run
+*
+ print *,' -------------------------------------'
+*
+ IF(ABORT .or. mss.NE.' ') THEN
+ call G_rep_err(ABORT,mss) !report any errors or warnings
+ err= ' '
+ ENDIF
+*
+ if(rpc_on.ne.0) call thservunset(0,0)
+*
+ print *,' -------------------------------------'
+*
+* Print out the statistics report one last time...
+ if(g_stats_blockname.ne.' '.and.
+ $ g_stats_output_filename.ne.' ') then
+ file = g_stats_output_filename
+ call g_sub_run_number(file, gen_run_number)
+ ierr = threp(g_stats_blockname,file)
+ endif
+*
+ call G_proper_shutdown(ABORT,err) !save files, etc.
+ If(ABORT .or. err.NE.' ') Then
+ call G_add_path(here,err) !report any errors or warnings
+ call G_rep_err(ABORT,err)
+ err= ' '
+ EndIf
+*
+ call g_ntuple_shutdown(ABORT,err)
+ If(ABORT .or. err.NE.' ') Then
+ call G_add_path(here,err) !report any errors or warnings
+ call G_rep_err(ABORT,err)
+ err= ' '
+ EndIf
+*
+* close charge scalers output file.
+ if (g_charge_scaler_filename.ne.' ') close(unit=G_LUN_CHARGE_SCALER)
+*
+* close epics output file.
+ if (g_epics_output_filename.ne.' ') close(unit=G_LUN_EPICS_OUTPUT)
+*
+ if (g_preproc_opened) then
+ status= evclose(g_preproc_in_hndl)
+ if (status.ne.0) write(6,*) 'status for evclose=',status
+ endif
+*
+ call g_dump_peds
+ call h_dump_peds
+ call t_dump_peds
+*
+ print *,'Processed:'
+ DO i=0,gen_MAX_trigger_types
+ If(recorded_events(i).GT.0) Then
+ write(mss,'(4x,i12," / ",i8," events of type",i3)')
+ & analyzed_events(i),recorded_events(i),i
+ call G_log_message(mss)
+ EndIf
+ ENDDO
+ write(mss,'(i12," / ",i8," total")') sum_analyzed,sum_recorded
+ call G_log_message(mss)
+ print *,' for run#',gen_run_number
+*
+* Comment out the following two lines if they cause trouble
+ call system
+ & ("kill `ps | grep runstats | awk '{ print $1}'` > /dev/null 2>&1")
+*
+ END
+
+ subroutine engine_command_line(outputflag)
+*
+ implicit none
+ integer iarg
+ character*132 arg
+ integer iargc
+ external iargc
+ logical outputflag
+*
+* Process command line args that set CTP variables
+*
+ do iarg=1,iargc()
+ call getarg(iarg,arg)
+ if(index(arg,'=').gt.0) then
+ call thpset(arg)
+ if (outputflag) write(6,'(4x,a70)') arg(1:70)
+ endif
+ enddo
+*
+ return
+ end
+
+ subroutine force
+c
+c Force the linker to pull the following routines out of the first
+c library (libt20) on the link line.
+c
+ call g_decode_fb_bank
+ return
+ end
diff --git a/TRACKING/.cvsignore b/TRACKING/.cvsignore
new file mode 100644
index 0000000..92aeffc
--- /dev/null
+++ b/TRACKING/.cvsignore
@@ -0,0 +1 @@
+O.*
diff --git a/TRACKING/CVS/Entries b/TRACKING/CVS/Entries
new file mode 100644
index 0000000..76b2401
--- /dev/null
+++ b/TRACKING/CVS/Entries
@@ -0,0 +1,8 @@
+/.cvsignore/1.1/Thu Jul 8 18:42:10 2004//Tsane
+/Makefile/1.1/Mon Dec 7 22:11:33 1998//Tsane
+/Makefile.Unix/1.14.24.1/Mon Sep 10 20:08:03 2007//Tsane
+/find_space_points.f/1.6/Wed Jan 17 19:20:25 1996//Tsane
+/select_space_points.f/1.3/Wed Jan 17 19:20:48 1996//Tsane
+/solve_four_by_four.f/1.1/Mon Feb 21 16:44:35 1994//Tsane
+/total_eloss.f/1.8.20.5/Thu Nov 29 18:32:13 2007//Tsane
+D
diff --git a/TRACKING/CVS/Repository b/TRACKING/CVS/Repository
new file mode 100644
index 0000000..08e94b9
--- /dev/null
+++ b/TRACKING/CVS/Repository
@@ -0,0 +1 @@
+Analyzer/TRACKING
diff --git a/TRACKING/CVS/Root b/TRACKING/CVS/Root
new file mode 100644
index 0000000..6288c3f
--- /dev/null
+++ b/TRACKING/CVS/Root
@@ -0,0 +1 @@
+whit@cvs.jlab.org:/group/hallc/cvsroot
diff --git a/TRACKING/CVS/Tag b/TRACKING/CVS/Tag
new file mode 100644
index 0000000..25d73f7
--- /dev/null
+++ b/TRACKING/CVS/Tag
@@ -0,0 +1 @@
+Tsane
diff --git a/TRACKING/Makefile b/TRACKING/Makefile
new file mode 100644
index 0000000..779a395
--- /dev/null
+++ b/TRACKING/Makefile
@@ -0,0 +1,8 @@
+#
+# $Log: Makefile,v $
+# Revision 1.1 1998/12/07 22:11:33 saw
+# Initial setup
+#
+ETC=../etc
+
+include $(ETC)/Makefile.NEW
diff --git a/TRACKING/Makefile.Unix b/TRACKING/Makefile.Unix
new file mode 100644
index 0000000..56c2035
--- /dev/null
+++ b/TRACKING/Makefile.Unix
@@ -0,0 +1,82 @@
+#
+# $Log: Makefile.Unix,v $
+# Revision 1.14.24.1 2007/09/10 20:08:03 pcarter
+# Implemented changes to allow compilation on RHEL 3,4,5 and MacOSX
+#
+# Revision 1.14 1999/02/24 15:43:52 saw
+# Add rule for getting .par files from INCLUDE
+#
+# Revision 1.13 1999/01/21 21:42:04 saw
+# Clean up Include file rules
+#
+# Revision 1.12 1998/12/09 16:31:17 saw
+# Remove dependence on Csoft environment variable
+#
+# Revision 1.11 1996/09/05 20:19:23 saw
+# (SAW) Linux compatibility fixes
+#
+# Revision 1.10 1996/04/29 18:29:50 saw
+# (SAW) New makefile style
+#
+# Revision 1.9 1996/01/17 19:11:00 cdaq
+# (SAW) Add total_eloss
+#
+# Revision 1.8 1995/07/28 15:17:32 cdaq
+# (SAW) Add NFSDIRECTORY stuff
+#
+# Revision 1.7 1995/05/24 13:24:13 cdaq
+# (SAW) Remove g_init_histid
+#
+# Revision 1.6 1995/03/13 20:01:57 cdaq
+# (SAW) Add -f switch on include file copy commands
+#
+# Revision 1.5 1995/01/27 21:10:12 cdaq
+# (SAW) Remove RCS from include file rules
+#
+# Revision 1.4 1994/11/23 15:37:02 cdaq
+# (SAW) Remove solve_3by3_hdc.f
+#
+# Revision 1.3 1994/10/12 18:44:22 cdaq
+# (SAW) Change solve_three_by_three.f to solve_3by3_hdc.f
+#
+# Revision 1.2 1994/07/07 15:18:09 cdaq
+# (SAW) Fix a bug so that all sources not get compiled
+#
+# Revision 1.1 1994/04/15 20:27:51 cdaq
+# Initial revision
+#
+NEWSTYLE=1
+include ../../etc/Makefile
+include ../../etc/Makefile.flags
+
+sources = find_space_points.f select_space_points.f solve_four_by_four.f \
+ total_eloss.f
+
+libsources = $(sources)
+
+lib_targets := $(patsubst %.f, libtracking.a(%.o), $(libsources))
+
+install-dirs := lib
+bin_targets =
+
+#default:
+# @echo "nothing to make"
+
+ifdef NFSDIRECTORY
+../%.f : $(NFSDIRECTORY)/TRACKING/%.f
+ ln -s $< $@
+
+.PRECIOUS: ../%.f
+endif
+
+#
+# Get include files from ENGINE directory
+#
+
+%.cmn ../%.cmn:: ../../INCLUDE/%.cmn
+ $(CP) $< $@
+
+%.par ../%.par:: ../../INCLUDE/%.par
+ $(CP) $< $@
+
+include $(sources:.f=.d)
diff --git a/TRACKING/find_space_points.f b/TRACKING/find_space_points.f
new file mode 100644
index 0000000..7a7ccfa
--- /dev/null
+++ b/TRACKING/find_space_points.f
@@ -0,0 +1,222 @@
+ subroutine find_space_points(ncham_hits,
+ & hit_number, wire_center, plane_number,space_point_criterion,
+ & xsp,ysp,nspace_point_len,
+ & nspace_points,space_points,space_point_hits)
+* Created D.F. Geesaman Sept 1993
+* $Log: find_space_points.f,v $
+* Revision 1.6 1996/01/17 19:20:25 cdaq
+* (JRA) Misc. fixes, reindent
+*
+* Revision 1.5 1995/07/28 15:18:35 cdaq
+* (SAW) Change print to type for f2c
+*
+* Revision 1.4 1994/10/11 20:00:44 cdaq
+* (JRA) Remove bug that allowed double counting of hits
+*
+* Revision 1.3 1994/04/12 20:23:53 cdaq
+* (DFG) Change dim of combos from max_number_pairs to max_number_comb
+*
+* Revision 1.2 1994/02/23 13:34:09 cdaq
+* (SAW) Change 2nd arg of space_points_hits declaration from 1 to *
+*
+* Revision 1.1 1994/02/19 06:12:06 cdaq
+* Initial revision
+*
+*
+* This algorithm finds space points in a wire chamber by finding the
+* intersection of each pair of hits in non-parallel planes,
+* then combining all two-hit space points that are within a squared
+* distance space_point_criterion.
+ implicit none
+* input
+ integer*4 ncham_hits ! total number of hits in chamber
+ integer*4 hit_number(*) ! array of hit numbers
+ integer*4 plane_number(*) ! array of plane numbers for each hit
+ real*4 wire_center(*) ! array of wire coordinates for hits
+ real*4 xsp(*),ysp(*) ! arrays of geometrical factors
+ ! see pattern recognition writeup
+ real*4 space_point_criterion ! squared distance limit for points
+ integer*4 nspace_point_len ! dimension of space point arrays
+*
+* outputs
+ integer*4 nspace_points ! number of space points in chamber
+ real*4 space_points(nspace_point_len,2) ! xt, yt of each space point
+ integer*4 space_point_hits(nspace_point_len,*)
+* ! hit numbers for each space point
+ ! (,1) number of hits
+ ! (,2) number of combanations attached
+ ! to the point
+ ! (,3).. hits associated with space point
+*
+*
+* internal variables
+ integer*4 ipair1,ipair2,icombo,i,j ! do loop variables
+ integer*4 loopsp,loop,hit(4),hit_point
+ integer*4 add_flag,iflag(4)
+ integer*4 max_number_pairs ! max number of pairs of points
+ parameter (max_number_pairs=1000)
+ integer*4 pair(max_number_pairs,2) ! hit1 hit2
+ integer*4 ntest_points ! number of valid combinations
+ integer*4 plane1,plane2
+ real*4 test_points(max_number_pairs,2) ! x and y of each test point
+ real*4 determinate,xt,yt
+ integer*4 max_number_comb
+ parameter (max_number_comb=10*max_number_pairs)
+ integer*4 ncombo
+ integer*4 combos(max_number_comb,2) ! pair1 and pair2 of each combo
+ real*4 sqdistance_test
+*
+ nspace_points=0
+ ntest_points=0
+*
+* loop over all pairs of intersecting wires and calculate position
+ do ipair1=1,ncham_hits-1
+ do ipair2=ipair1+1,ncham_hits
+ if(ntest_points.lt.max_number_pairs) then
+ plane1=plane_number(ipair1)
+ plane2=plane_number(ipair2)
+ determinate=xsp(plane1)*ysp(plane2)-ysp(plane1)*xsp(plane2)
+ if(abs(determinate) .gt. 0.3 ) then !0.3 is sin(alpha1-alpha2)=sin(17.5)
+ ntest_points=ntest_points+1
+ pair(ntest_points,1)=hit_number(ipair1)
+ pair(ntest_points,2)=hit_number(ipair2)
+ test_points(ntest_points,1)=
+ & (wire_center(ipair1)*ysp(plane2)-wire_center(ipair2)
+ $ *ysp(plane1))/ determinate
+ test_points(ntest_points,2)=
+ & (wire_center(ipair2)*xsp(plane1)-wire_center(ipair1)
+ $ *xsp(plane2))/ determinate
+ endif ! end if for indeterminate planes
+ endif ! end test on too many pairs
+ enddo ! end loop over pair2
+ enddo ! end loop over pair1
+*
+* loop over all test_points and calculate squared distance
+* for each combination
+*
+ ncombo=0
+ do ipair1=1,ntest_points-1
+ do ipair2=ipair1+1,ntest_points
+ if(ncombo.lt.max_number_comb) then
+ sqdistance_test=
+ & (test_points(ipair1,1)-test_points(ipair2,1))**2 +
+ & (test_points(ipair1,2)-test_points(ipair2,2))**2
+ if(sqdistance_test.le.space_point_criterion) then
+ ncombo=ncombo+1
+ combos(ncombo,1)=ipair1
+ combos(ncombo,2)=ipair2
+ endif
+ endif ! end test on too many combos
+ enddo ! end loop over pair2
+ enddo ! end loop over pair1
+*
+* loop over all valid combinations and build space points
+ if(ncombo.gt.0) then
+ do icombo=1,ncombo
+* get hits in combo
+ hit(1)=pair(combos(icombo,1),1)
+ hit(2)=pair(combos(icombo,1),2)
+ hit(3)=pair(combos(icombo,2),1)
+ hit(4)=pair(combos(icombo,2),2)
+* get average space point xt, yt
+ xt=(test_points(combos(icombo,1),1)
+ $ +test_points(combos(icombo,2),1))/2
+ yt=(test_points(combos(icombo,1),2)
+ $ +test_points(combos(icombo,2),2))/2
+*
+* loop over space_points
+ if(nspace_points.gt.0) then
+ loopsp=1
+ add_flag=1
+ do while (loopsp .le. nspace_points)
+ if(space_point_hits(loopsp,1).gt.0) then
+ sqdistance_test=(xt-space_points(loopsp,1))**2 +
+ & (yt-space_points(loopsp,2))**2
+* I want to be careful if sqdistance is between 1 and
+* 3 space_point_criterion. Let me ignore not add a new point then
+ if(sqdistance_test.lt. (3.*space_point_criterion)) then
+ add_flag=0 ! do not add new space point
+ endif
+ if(sqdistance_test.lt.space_point_criterion) then
+* This is a real match.
+* Add the new hits to existing space point
+ iflag(1)=0
+ iflag(2)=0
+ iflag(3)=0
+ iflag(4)=0
+ do loop=1,space_point_hits(loopsp,1)
+ do i=1,4
+ if(space_point_hits(loopsp,loop+2).eq.hit(i)) then
+ iflag(i)=1
+ endif
+ enddo ! end loop on i
+ enddo ! end loop over hits in space point
+* if 2 hits in the combo are identicle, both might get in. Remove all but one
+ do i=1,3
+ do j=i+1,4
+ if (hit(j).eq.hit(i)) iflag(j)=1
+ enddo
+ enddo
+ do i=1,4
+ if(iflag(i).eq.0) then
+ hit_point=space_point_hits(loopsp,1)+1
+ space_point_hits(loopsp,1)=hit_point
+ space_point_hits(loopsp,hit_point+2)=hit(i)
+ endif
+ enddo ! end loop over 4 hits
+* increment number of combos contributing to this space point
+ space_point_hits(loopsp,2)=space_point_hits(loopsp,2)+1
+* terminate loop since this combo can only belong to one
+* space point
+ loopsp=nspace_points+1
+ endif
+ endif ! end check on number of hits
+ loopsp=loopsp+1 ! increment loop counter on return
+ enddo ! end do while loop over space points
+* create a new space point if more than 2*space_point_criteria
+ if(nspace_points.lt.nspace_point_len) then
+ if(add_flag.gt.0) then
+ nspace_points=nspace_points+1
+ space_point_hits(nspace_points,1)=2
+ space_point_hits(nspace_points,2)=1
+ space_point_hits(nspace_points,3)=hit(1)
+ space_point_hits(nspace_points,4)=hit(2)
+ space_points(nspace_points,1)=xt
+ space_points(nspace_points,2)=yt
+ if(hit(1).ne.hit(3) .and. hit(2) .ne. hit(3)) then
+ hit_point=space_point_hits(nspace_points,1)+1
+ space_point_hits(nspace_points,1)=hit_point
+ space_point_hits(nspace_points,hit_point+2)=hit(3)
+ endif !
+ if(hit(1).ne.hit(4) .and. hit(2) .ne. hit(4)) then
+ hit_point=space_point_hits(nspace_points,1)+1
+ space_point_hits(nspace_points,1)= hit_point
+ space_point_hits(nspace_points,hit_point+2)=hit(4)
+ endif
+ endif ! endif on check if too many space points
+ endif ! endif to add point on add_flag
+ else
+* create first space point
+ nspace_points=1
+ space_point_hits(nspace_points,1)=2
+ space_point_hits(nspace_points,2)=1
+ space_point_hits(nspace_points,3)=hit(1)
+ space_point_hits(nspace_points,4)=hit(2)
+ space_points(nspace_points,1)=xt
+ space_points(nspace_points,2)=yt
+ if(hit(1).ne.hit(3) .and. hit(2) .ne. hit(3)) then
+ hit_point=space_point_hits(nspace_points,1)+1
+ space_point_hits(nspace_points,1)=hit_point
+ space_point_hits(nspace_points,hit_point+2)=hit(3)
+ endif !
+ if(hit(1).ne.hit(4) .and. hit(2) .ne. hit(4)) then
+ hit_point=space_point_hits(nspace_points,1)+1
+ space_point_hits(nspace_points,1)= hit_point
+ space_point_hits(nspace_points,hit_point+2)=hit(4)
+ endif
+ endif ! end check on 0 space points
+ enddo ! end loop over combos
+ endif ! end check if no valid combos
+
+ return
+ end
diff --git a/TRACKING/select_space_points.f b/TRACKING/select_space_points.f
new file mode 100644
index 0000000..79485c6
--- /dev/null
+++ b/TRACKING/select_space_points.f
@@ -0,0 +1,55 @@
+ subroutine select_space_points(nspace_point_len,
+ & nspace_points,space_points,space_point_hits,min_hits,min_combos,
+ & easy_space_point)
+* This routine goes through the list of space_points and space_point_hits
+* found by find_space_points and only accepts those with
+* number of hits > min_hits
+* number of combinations > min_combos
+* dfg 30 august 1993
+* $Log: select_space_points.f,v $
+* Revision 1.3 1996/01/17 19:20:48 cdaq
+* (JRA) Add eash_space_point argument
+*
+* Revision 1.2 1994/02/23 13:52:40 cdaq
+* (SAW) Change 2nd arg of space_points_hits declaration from 1 to *
+*
+* Revision 1.1 1994/02/21 16:44:23 cdaq
+* Initial revision
+*
+ implicit none
+* inputs
+ integer*4 nspace_point_len ! dimension variable for two-d arrays
+ integer*4 nspace_points ! number of input points
+ ! on return it is the number of valid
+ ! space points
+ integer*4 space_points(nspace_point_len,2)
+ integer*4 space_point_hits(nspace_point_len,*)
+ integer*4 min_hits ! minimum number of hits in valid point
+ integer*4 min_combos ! minimum number of combos
+ logical easy_space_point ! flag for having found easy space pt.
+*
+* outputs
+* note nspace_points, space_points, and space_point_hits are all
+* modified by the action of this routine
+* local variables
+ integer*4 space_point_count,ploop,hloop
+*
+ space_point_count=0
+ do ploop=1,nspace_points
+* if easy_space_point, then the number of combos is not filled.
+ if(space_point_hits(ploop,2).ge.min_combos.or.easy_space_point) then
+ if(space_point_hits(ploop,1).ge.min_hits) then
+ space_point_count=space_point_count+1
+ space_points(space_point_count,1)=space_points(ploop,1)
+ space_points(space_point_count,2)=space_points(ploop,2)
+ do hloop=1,space_point_hits(ploop,1)+2
+ space_point_hits(space_point_count,hloop)=
+ & space_point_hits(ploop,hloop)
+ enddo
+ endif
+ endif
+ enddo
+ nspace_points=space_point_count
+
+ return
+ end
diff --git a/TRACKING/solve_four_by_four.f b/TRACKING/solve_four_by_four.f
new file mode 100644
index 0000000..980afbb
--- /dev/null
+++ b/TRACKING/solve_four_by_four.f
@@ -0,0 +1,67 @@
+ subroutine solve_four_by_four(TT,AA,stub,ierr)
+* Explicit solution of a symmetric four by four equation TT = AA * STUB
+* Remember AA must be a symmetrix matrix
+* Used in find_best_stub.f and h_track_fit
+* d.f. geesaman 1 september 1993
+* $Log: solve_four_by_four.f,v $
+* Revision 1.1 1994/02/21 16:44:35 cdaq
+* Initial revision
+*
+*
+ implicit none
+* input quantities
+ real*8 TT(4),AA(4,4)
+*
+* output quantities
+ real*8 stub(4)
+ integer*4 ierr ! ierr = 0 means valid solution
+*
+* local quantities
+ real*8 T1,T2,T3,T4,T5,T6,T7,T8,T10,T11,T12,T13,T14,T15,T16,T17,T18
+ real*8 B11,B12,B13,B14,B22,B23,B24,B33,B34,B44,DET
+ ierr=1
+*
+ T1=AA(3,3)*AA(4,4)-AA(3,4)*AA(3,4)
+ T2=AA(2,3)*AA(4,4)-AA(2,4)*AA(3,4)
+ T3=AA(2,3)*AA(3,4)-AA(2,4)*AA(3,3)
+ T4=AA(1,3)*AA(2,4)-AA(1,4)*AA(2,3)
+ T5=AA(1,2)*AA(2,4)-AA(1,4)*AA(2,2)
+ T6=AA(1,2)*AA(2,3)-AA(1,3)*AA(2,2)
+ T7=AA(1,3)*AA(4,4)-AA(1,4)*AA(3,4)
+ T8=AA(1,3)*AA(3,4)-AA(1,4)*AA(3,3)
+ T10=AA(1,2)*AA(4,4)-AA(1,4)*AA(2,4)
+ T11=AA(1,2)*AA(3,4)-AA(1,4)*AA(2,3)
+ T13=AA(1,2)*AA(3,4)-AA(1,3)*AA(2,4)
+ T14=AA(1,2)*AA(3,3)-AA(1,3)*AA(2,3)
+ T15=AA(2,2)*AA(4,4)-AA(2,4)*AA(2,4)
+ T16=AA(2,2)*AA(3,4)-AA(2,4)*AA(2,3)
+ T17=AA(1,2)*AA(2,3)-AA(1,3)*AA(2,2)
+ T18=AA(2,2)*AA(3,3)-AA(2,3)*AA(2,3)
+ B11=AA(2,2)*T1-AA(2,3)*T2+AA(2,4)*T3
+ B12= -(AA(1,2)*T1-AA(1,3)*T2+AA(1,4)*T3)
+ B13= AA(2,4)*T4-AA(3,4)*T5+AA(4,4)*T6
+ B14= -(AA(2,3)*T4-AA(3,3)*T5+AA(3,4)*T6)
+ DET= AA(1,1)*B11+AA(1,2)*B12+AA(1,3)*B13+AA(1,4)*B14
+
+* if determinant is finite then continue, otherwise quit
+ if(abs(DET).gt. 1e-20) then
+ ierr=0
+ B11=B11/DET
+ B12=B12/DET
+ B13=B13/DET
+ B14=B14/DET
+ B22=(AA(1,1)*T1-AA(1,3)*T7+AA(1,4)*T8)/DET
+ B23= -(AA(1,1)*T2-AA(1,3)*T10+AA(1,4)*T11)/DET
+ B24=(AA(1,1)*T3-AA(1,3)*T13+AA(1,4)*T14)/DET
+ B33=(AA(1,1)*T15-AA(1,2)*T10+AA(1,4)*T5)/DET
+ B34= -(AA(1,1)*T16-AA(1,2)*T13+AA(1,4)*T17)/DET
+ B44= (AA(1,1)*T18-AA(1,2)*T14+AA(1,3)*T17)/DET
+* Calculate results
+ stub(3)=B13*TT(1)+B23*TT(2)+B33*TT(3)+B34*TT(4)
+ stub(1)=B11*TT(1)+B12*TT(2)+B13*TT(3)+B14*TT(4)
+ stub(4)=B14*TT(1)+B24*TT(2)+B34*TT(3)+B44*TT(4)
+ stub(2)=B12*TT(1)+B22*TT(2)+B23*TT(3)+B24*TT(4)
+ endif ! end check on determinant
+*
+ return
+ end
diff --git a/TRACKING/total_eloss.f b/TRACKING/total_eloss.f
new file mode 100644
index 0000000..3400ce8
--- /dev/null
+++ b/TRACKING/total_eloss.f
@@ -0,0 +1,781 @@
+ subroutine total_eloss(arm,prt,angle,beta,e_loss)
+
+*------------------------------------------------------------------------------
+*- Prototype C routine
+*-
+*-
+*- Purpose and Method : In separate calls, calculate the energy loss for
+*- the incident electron in the target OR the energy
+*- loss for exiting particles in the target and
+*- other materials like windows. Cryogenic targets
+*- must be beer-can cells. Solid targets are okay too.
+*- Ytarget information is NOT used; all calculations
+*- assume the reaction vertex is at the target center.
+*-
+*- Output: loss - energy loss for the arm requested
+*- Created 1-Dec-1995 Rolf Ent
+*
+* $Log: total_eloss.f,v $
+* Revision 1.8.20.5 2007/11/29 18:32:13 cdaq
+* commented out "eloss > 1e-2" error message
+*
+* Revision 1.8.20.4 2007/10/24 17:00:42 cdaq
+* some modifications for BigCal
+*
+* Revision 1.8.20.3 2007/10/23 17:04:04 cdaq
+* Added eloss calculation for materials in front of BigCal
+*
+* Revision 1.8.20.2 2007/08/07 19:12:46 puckett
+* *** empty log message ***
+*
+* Revision 1.8 2003/09/05 20:06:07 jones
+* Merge in online03 changes (mkj)
+*
+* Revision 1.7.2.1 2003/04/09 02:59:10 cdaq
+* Changed gtarg_type from a scaler to an array: gtarg_type(gtarg_num)
+*
+* Revision 1.7 2002/12/27 22:21:55 jones
+* a. Ioana Niculescu made major changes in the subroutine call variables.
+* b. Code now expects to get target info from parameter files.
+* c. include gen_run_info.cmn
+* d. Many more checks that nonzero parameter values are present.
+* Corrects problem with checking variable 'angle' instead of 'tgangle'
+* e. Has either beer can or tuna can.
+* f. Use gtarg_type = 1 tuna can,2 beer can, >=21 solid and assume
+* gtarg_type <=20 is liquid rather than based on target z.
+*
+*
+* Wed Aug 16 14:25:55 EDT 2000
+* replaced switch old_tgeom with with run number check B.Z
+*
+* Revision 1.6 1999/09/03 13:22:51 meod
+* Added tuna-can geometry. Added switch, old_tgeom, to enable
+* old beer can geometry
+*
+* Revision 1.6 1999/09/03 13:22:51 saw
+* Explicitely type 0.1 constand in max as double
+*
+* Revision 1.5 1999/06/10 16:59:37 csa
+* (CSA) Removed debugging statement
+*
+* Revision 1.4 1999/02/10 17:34:41 csa
+* Numerous corrections and improvements (D. Mack, K. Vansyoc, J. Volmer)
+*
+* Revision 1.2 1996/01/24 16:31:35 saw
+* (JRA) Cleanup
+*
+* Revision 1.1 1996/01/17 19:12:32 cdaq
+* Initial revision
+*
+*------------------------------------------------------------------------------
+**********************
+* LH2 and LD2 targets
+**********************
+*
+* Incoming beam sees the following materials to target center:
+* 1. a 3.0 mil Al-foil (upstream endcap of target) J. Dunne Dec 96
+* 2. half the target thickness
+*
+* Any particle exiting target center sees the following materials:
+* 3. Particle leaves thru side-walls:1.325 inch of target material corrected
+* for the spectrometer angle, OR
+* Particle leaves thru downstream window: half the target length, correc-
+* ted for the spectrometer angle.
+*
+* 4. A 5.0 mil Al-foil target wall thickness (J. Dunne Dec 96), corrected
+* for spectrometer angle.
+*
+******************
+* Solid targets:
+******************
+*
+* Incoming beam sees the following materials to target center:
+* 1. half the target thickness, corrected for the spectrometer angle.
+*
+* Any particle exiting target center sees the following materials:
+* 2. half the target thickness, corrected for the spectrometer angle
+*
+***************************************************
+* Additional materials (irregardless of target):
+***************************************************
+* * effective density for kevlar is 0.74
+* * effective z for CH2 is 2.67, effective a is 4.67
+* (values confirmed by T. Keppel Mar. 98)
+*
+* HMS particles only:
+* 1. 16 mil Aluminum scattering chamber window (J. Mitchell Feb. 98)
+* 2. 15 cm of air between chamber window and HMS entrance window.
+* *effective a for air is 14.68, effective z is 7.32, dens is .00121
+* 3. HMS entrance window, 17 mil kevlar and 5 mil mylar.
+* (values confirmed by T. Keppel Mar. 98)
+*
+* SOS particles only:
+* 1. 8.0 mil Al-foil scattering chamber window (J.Mitchell Feb 98)
+* 2. 15 cm of air between chamber window and HMS entrance window.
+* *effective a for air is 14.68, effective z is 7.32, dens is .00121
+* 2. SOS entrance window, 6 mil kevlar and 1.5 mil mylar.
+* (values confirmed by T. Keppel Mar. 98)
+
+ IMPLICIT NONE
+ SAVE
+*
+ include 'gen_data_structures.cmn'
+ include 'hms_data_structures.cmn'
+ include 'sos_data_structures.cmn'
+ include 'bigcal_data_structures.cmn'
+ include 'gen_run_info.cmn'
+ include 'gen_constants.par'
+
+*
+
+*
+ INTEGER arm ! 0 : incident beam
+ ! 1 : HMS
+ ! 2 : SOS
+ LOGICAL prt ! .true. : electron
+ ! .false. : non-electron (beta .lt. 1)
+ LOGICAL liquid
+
+ REAL*4 crit_angle,tg_spect_angle
+ REAL*4 z,a,tgthick,dens,angle,tgangle,beta,type
+ REAL*4 thick,thick_side,thick_front,e_loss,total_loss
+ REAL*4 targ_win_loss,front_loss,back_loss,cell_wall_loss
+ REAL*4 scat_win_loss,air_loss,h_win_loss,s_win_loss,b_abs_loss
+ REAL*4 b_luc_loss,b_fpl_loss
+ REAL*4 electron
+ REAL*8 beta_temp,gamma_temp,X_temp,frac_temp,p_temp
+ REAL*4 velocity
+
+********************INITIALIZE ENERGY LOSS VARIABLES*****************
+ e_loss = 0.0
+ total_loss = 0.0
+ targ_win_loss = 0.0
+ front_loss = 0.0
+ back_loss = 0.0
+ cell_wall_loss = 0.0
+ scat_win_loss = 0.0
+ air_loss = 0.0
+ h_win_loss = 0.0
+ s_win_loss = 0.0
+ liquid =.FALSE.
+*********************ENABLE SWITCH***********************************
+ if (gen_eloss_enable.eq.0.) goto 100 !if 0 don't do eloss correction.
+***********************SETUP OF PARAMETERS****************************
+* Parameters should be accessed via the various common blocks
+* No more hardwired #s in the code!!! (I.N. 2001)
+*
+*
+* z,a,tgthick,dens come via a common block
+*
+ z=gtarg_z(gtarg_num)
+ a=gtarg_a(gtarg_num)
+ tgthick=gtarg_thick(gtarg_num)
+ dens=gtarg_dens(gtarg_num)
+ tgangle=gtarg_theta
+ type=gtarg_type(gtarg_num)
+*******DIVIDE BY ZERO CHECK**************************************
+ if ((gcell_radius.eq.0.0).or.(gz_cell.eq.0.0).or.(ga_cell.eq.0.0)
+ & .or.(gcell_den.eq.0.0).or.(gwall_thk.eq.0.0).or.(gend_thk.eq.0.0)
+ & .or.(gfront_thk.eq.0.0)) then
+ write(6,*)'Total_eloss: Uninitialized target variable(s)!!!'
+ write(6,*)'gcell_radius = ',gcell_radius
+ write(6,*)'gz_cell = ',gz_cell
+ write(6,*)'ga_cell = ',ga_cell
+ write(6,*)'gcell_den = ',gcell_den
+ write(6,*)'gwall_thk = ',gwall_thk
+ write(6,*)'gend_thk = ',gend_thk
+ write(6,*)'gfront_thk = ',gfront_thk
+ stop
+ elseif ((arm.eq.1).and.((hscat_win_den.eq.0.0).or.
+ & (hscat_win_thk.eq.0.0).or.(hscat_win_z.eq.0.0).or.
+ & (hscat_win_a.eq.0.0).or.(hdet_ent_z.eq.0.0).or.
+ & (hdet_ent_a.eq.0.0))) then
+ write(6,*)'Total_eloss: Uninitialized HMS window specs!!!'
+ stop
+ elseif ((arm.eq.2).and.((sscat_win_den.eq.0.0).or.
+ & (sscat_win_thk.eq.0.0).or.(sscat_win_z.eq.0.0).or.
+ & (sscat_win_a.eq.0.0).or.(sdet_ent_z.eq.0.0).or.
+ & (sdet_ent_a.eq.0.0))) then
+ write(6,*)'Total_eloss: Uninitialized SOS window specs!!!'
+ stop
+ else if((arm.eq.3).and.((bscat_win_den.eq.0.0).or.
+ $ (bscat_win_thk.eq.0.0).or.(bscat_win_z.eq.0).or.
+ $ (bscat_win_a.eq.0.0))) then
+ write(6,*)
+ $ 'Total_eloss: Uninitialized BigCal window specs!!!'
+ stop
+ endif
+
+ if ((z*a*tgthick*dens*tgangle).eq.0.0) then
+ write(6,*)'Total_eloss: Uninitialized target material!!!'
+ write(6,*)
+ write(6,*)'target angle = ',gtarg_theta
+ write(6,*)'target type = ',type
+ write(6,*)'thickness = ',tgthick
+ write(6,*)'Z = ',z
+ write(6,*)'A = ',A
+ write(6,*)'density = ',dens
+
+ stop
+ else
+ endif
+*
+* If an angle is provided, use it, otherwise use the central
+* spectrometer angle
+*
+ if((angle.eq.0.0).and.(arm.ne.0)) then
+ write(6,*)'total_eloss: angle = 0.0, using centr spectr angle (VT)'
+ if (arm.eq.1) angle=htheta_lab*3.14159/180.
+ if (arm.eq.2) angle=stheta_lab*3.14159/180.
+ endif
+ if((arm.ne.0).and.(abs(angle-3.14159/2.).lt.0.0001)) then
+ write(6,*) 'total_eloss: angle = 90 degrees, using centr spectr angle(VT)'
+ if (arm.eq.1) angle=htheta_lab*3.14159/180.
+ if (arm.eq.2) angle=stheta_lab*3.14159/180.
+ if (arm.eq.3) angle=bigcal_theta_rad
+ endif
+
+ 10 format(7(2x,A10))
+ 20 format(12x,6(2x,f10.9))
+ 30 format(5(2x,A10))
+ 40 format(12x,4(2x,f10.9))
+ 50 format(12x,3(2x,f10.9))
+ 60 format(4(A12))
+ 70 format(10(A11))
+ 80 format(2x,I9,9(2x,f9.6))
+ 90 format(7(2x,A10))
+ 92 format(9(2x,A10))
+ 134 format(12x,6(2x,f10.9))
+ 136 format(12x,8(2x,f10.9))
+***********************END SETUP******************************
+
+*******************************************************************************
+* With the adoption of a new, beta-dependent energy loss correction formula
+* for electrons, it became necessary to give the velocity of electrons in terms
+* of log_10(beta*gamma), since REAL*4 was not good enough to distinguish the
+* beta of electrons from 1. For hadrons, nothing will change.
+*******************************************************************************
+
+ velocity=0.
+ if(gelossdebug.ne.0) then
+ write(6,'(3A10)') 'gpbeam','hsp','ssp'
+ write(6,'(3(2x,f8.5))') gpbeam,hsp,ssp
+ endif
+
+ if (prt) then
+ if (arm.eq.0) then
+ p_temp=gpbeam
+ elseif (arm.eq.1) then
+ p_temp=hsp
+ elseif (arm.eq.2) then
+ p_temp=ssp
+ elseif (arm.eq.3) then
+ p_temp=gpbeam
+ else
+ write(6,*)
+ $ 'total_eloss: no arm specified for electron velocity'
+ endif
+
+ p_temp=max(p_temp,.1D0)
+ frac_temp=mass_electron/p_temp
+
+ if(gelossdebug.ne.0) then
+ write(6,*) 'total_eloss: p_temp=',p_temp
+ write(6,*) 'total_eloss: frac_temp=',frac_temp
+ endif
+
+ beta_temp=1./sqrt(1.+frac_temp**2)
+ gamma_temp=sqrt(1.+frac_temp**2)/frac_temp
+ X_temp=log(beta_temp*gamma_temp)/log(10.)
+ velocity=X_temp
+ if(arm.eq.3) then
+ velocity = beta
+ endif
+ else
+ velocity=beta
+ endif
+
+**************************************************************************
+* Calculate the angle at which the ejectile passes through the side of the
+* target cell rather than the end.
+**************************************************************************
+
+ if ((type.eq.2).and.(tgthick.ne.0.).and.(dens.ne.0.)) then
+ crit_angle= atan(gcell_radius/(tgthick/dens/2.))
+ else
+ crit_angle= 0.45
+ endif
+
+**************************************************************************
+* Define hydrogen, deuterium and 3,4He as liquid targets: z<=2
+**************************************************************************
+
+ if (type.le.20) liquid =.TRUE.
+
+**************************************************************************
+* For debugging purposes, print out the variables that have been given
+* over to the subroutine
+**************************************************************************
+
+ if (gelossdebug.ne.0) then
+ electron=0.0
+ if (prt) electron=1.0
+ write(6,70) 'arm','electron?','ztgt','atgt','tgtdens','spec_angle'
+ & ,'tgangle','velocity','e_loss'
+ write(6,80) arm,electron,z,a,dens,angle,tgangle,velocity,e_loss
+ write(6,*) ' '
+ endif
+
+********************************************************************
+* Calculate the electron beam energy loss before the target center.
+********************************************************************
+
+ if(arm.eq.0) then
+ if (liquid) then ! cryo target !
+ call loss(.true.,gz_cell,ga_cell,gfront_thk,gcell_den !aluminum
+ > ,velocity,targ_win_loss)
+ total_loss = total_loss + targ_win_loss
+
+ if(type.eq.2) then
+ thick = tgthick/2. !!! beer-can !!!
+ else if (type.eq.1) then
+ thick = gcell_radius*dens !!! tuna-can !!!
+ else
+ write(6,*)'Unknown liquid target specified ',type
+ stop
+ endif
+ call loss(.true.,z,a,thick,dens,velocity,front_loss) !liquid
+ total_loss = total_loss + front_loss
+ else
+*
+* Assume that tgangle = 90 deg
+* corresponds to a target normal to the beam direction
+*
+ if (abs(sin(tgangle)).ge.0.01) then
+ thick = tgthick/2./abs(sin(tgangle))
+ else
+ thick = tgthick/2./0.01
+ endif
+ call loss(.true.,z,a,thick,dens,velocity,front_loss) !liquid
+ total_loss = total_loss + front_loss
+ endif
+* debug output for electron beam loss
+ if(gelossdebug.ne.0)then
+ write(6,60) 'Ebeam loss:','window','front','total'
+ write(6,50) targ_win_loss,front_loss,total_loss
+ write(6,*) ' '
+ endif
+ e_loss = total_loss
+ goto 100
+ endif
+
+ if(gen_bigcal_mc.ne.0) then
+ goto 101
+ endif
+
+*********************************************************************
+*Calculate the energy loss of ejectile after the target center.
+*********************************************************************
+ if (liquid .and. arm.ne.0) then
+* Liquid target*********
+ if (type.eq.1) then
+ call loss(prt,z,a,thick,dens,velocity,back_loss) !liquid
+ total_loss = total_loss + back_loss
+ call loss(prt,gz_cell,ga_cell,gfront_thk,gcell_den !aluminum
+ > ,velocity,cell_wall_loss)
+ total_loss = total_loss + cell_wall_loss
+
+ else
+* write(6,*)'********************I am HERE*****************(VT)'
+ thick=0.0
+ thick_front=0.0
+ thick_side=0.0
+* Through the end of the cell.
+ if (angle.le.crit_angle) then
+ if (cos(angle).ge.0.01) then
+ thick = abs(gend_thk/cos(angle))
+ thick_front= abs(tgthick/2./cos(angle))
+ else
+ thick = abs(gend_thk/0.01)
+ thick_front= abs(tgthick/2./0.01)
+ endif
+ call loss(prt,z,a,thick_front,dens,velocity,back_loss) !liquid
+ total_loss = total_loss + back_loss
+ call loss(prt,gz_cell,ga_cell,thick,gcell_den,velocity !aluminum
+ > ,cell_wall_loss)
+ total_loss = total_loss + cell_wall_loss
+* Through the side of the cell.
+ else
+ if (abs(sin(angle)).ge.0.01) then
+ thick = abs(gwall_thk/abs(sin(angle)))
+ thick_side = abs(gcell_radius*dens/abs(sin(angle)))
+ else
+ thick = abs(gwall_thk/0.01)
+ thick_side = abs(gcell_radius*dens/0.01)
+ endif
+ call loss(prt,z,a,thick_side,dens,velocity,back_loss) !liquid
+ total_loss = total_loss + back_loss
+ call loss(prt,gz_cell,ga_cell,thick,gcell_den,velocity !aluminum
+ > ,cell_wall_loss)
+ total_loss = total_loss + cell_wall_loss
+ endif
+c$$$ if(total_loss.GE.1e-2)
+c$$$ & write(*,*) arm, velocity,
+c$$$ & " total_loss ", total_loss, " back_loss ",back_loss," angle ",
+c$$$ $ angle
+
+ endif
+*Solid target************
+ else
+
+* In any ordinary case, the solid target has angle of 90 degrees
+* with respect to the beam direction: tgangle=90.*degrad
+
+* csa 1/5/99 -- Here I define tgangle > 90 deg to mean that the
+* solid target is facing the SOS.
+
+ if (arm.eq.1) then ! HMS
+ tg_spect_angle = angle + tgangle
+ elseif (arm.eq.2) then ! SOS
+ tg_spect_angle = angle - tgangle
+ elseif(arm.eq.3) then ! BigCal
+ tg_spect_angle = angle - tgangle
+ else
+ write(6,*)' '
+ write(6,*)' bad ''arm'' in total_eloss.f'
+ write(6,*)' '
+ endif
+ if (abs(sin(tg_spect_angle)).ge.0.01) then
+ thick = abs((tgthick/2.)/abs(sin(tg_spect_angle)))
+ else
+ thick = abs((tgthick/2.)/0.01)
+ endif
+ call loss(prt,z,a,thick,dens,velocity,back_loss) !generic solid target
+ total_loss = total_loss + back_loss
+ endif
+
+************************************
+* Now calculate the HMS energy loss.
+************************************
+
+ 101 continue
+
+ if (arm.eq.1) then ! HMS
+
+c write(*,*) "In HMS"
+
+* 16 mil aluminum scattering chamber window on HMS side
+ call loss(prt,hscat_win_z,hscat_win_a,hscat_win_thk,
+ & hscat_win_den,velocity,scat_win_loss) !aluminum
+ total_loss = total_loss + scat_win_loss
+
+* ENERGY LOSS IN AIR GAP BEWTEEN THE CHAMBER AND THE ENTRANCE WINDOW
+ call loss(prt,gair_z,gair_a,gair_thk,gair_dens,velocity,air_loss)
+ total_loss = total_loss + air_loss
+
+* HMS Det. entrance window loss
+ call loss(prt,hdet_ent_z,hdet_ent_a,hdet_ent_thk,
+ & hdet_ent_den,velocity,h_win_loss) !HMS window
+ total_loss = total_loss + h_win_loss
+
+ e_loss = total_loss
+
+*eloss debug HMS
+ if(gelossdebug.ne.0)then
+ if(liquid) then
+ write(6,10)'liquid',
+ & 'back','cell_wall','scat_win','air','HMS_win',
+ & 'total'
+ write(6,20) back_loss,cell_wall_loss,scat_win_loss,air_loss,
+ & h_win_loss,total_loss
+ else
+ write(6,30)'solid', 'scat_win','air','HMS_win','total'
+ write(6,40) scat_win_loss,air_loss,h_win_loss,total_loss
+ endif
+ write(6,*)
+ endif
+
+ endif
+
+*************************************
+* Now calculate the SOS energy loss.
+*************************************
+
+ if (arm.eq.2) then ! SOS
+* 8 mil aluminum scattering chamber window on SOS side
+ call loss(prt,sscat_win_z,sscat_win_a,sscat_win_thk,
+ & sscat_win_den,velocity,scat_win_loss) !aluminum
+ total_loss = total_loss + scat_win_loss
+*ENERGY LOSS IN AIR GAP BEWTEEN THE CHAMBER AND THE ENTRANCE WINDOW
+ call loss(prt,gair_z,gair_a,gair_thk,gair_dens,velocity,air_loss)
+ total_loss = total_loss + air_loss
+
+*
+* SOS Det. entrance window loss
+ call loss(prt,sdet_ent_z,sdet_ent_a,sdet_ent_thk,
+ & sdet_ent_den,velocity,s_win_loss) !SOS window
+ total_loss = total_loss + s_win_loss
+
+ e_loss = total_loss
+
+*eloss debug SOS
+ if(gelossdebug.ne.0)then
+ if(liquid) then
+ write(6,10)'liquid',
+ & 'back','cell_wall','scat_win','air','SOS_win',
+ & 'total'
+ write(6,20) back_loss,cell_wall_loss,scat_win_loss,air_loss,
+ & s_win_loss,total_loss
+ else
+ write(6,30)'solid',
+ & 'scat_win','air','SOS_win','total'
+ write(6,40) scat_win_loss,air_loss,s_win_loss,total_loss
+ endif
+ write(6,*) ' '
+ endif
+
+ endif
+
+****************************************
+* Now calculate the BigCal energy loss *
+****************************************
+ if(arm.eq.3) then
+c scattering window on bigcal side!!!!
+ call loss(prt,bscat_win_z,bscat_win_a,bscat_win_thk,
+ $ bscat_win_den,velocity,scat_win_loss) !aluminum
+ total_loss = total_loss + scat_win_loss
+c air gap between the chamber and the entrance window!
+ call loss(prt,gair_z,gair_a,gair_thk,gair_dens,velocity,air_loss) ! air
+ total_loss = total_loss + air_loss
+c BigCal Al absorber loss (most significant)
+ call loss(prt,babs_z,babs_a,babs_thk,babs_den,velocity,b_abs_loss) ! absorber
+ total_loss = total_loss + b_abs_loss
+
+c BigCal lucite plate loss
+ call loss(prt,bluc_z,bluc_a,bluc_thk,bluc_den,velocity,b_luc_loss) ! lucite
+ total_loss = total_loss + b_luc_loss
+c BigCal front plate(plates) loss:
+ call loss(prt,bfpl_z,bfpl_a,bfpl_thk,bfpl_den,velocity,b_fpl_loss) ! front plate(s)
+ total_loss = total_loss + b_fpl_loss
+
+ e_loss = total_loss
+
+ if(gelossdebug.ne.0)then
+ if(liquid) then
+ write(6,92)'liquid',
+ & 'back','cell_wall','scat_win','air','BigCal_abs',
+ & 'BigCal_luc','BigCal_fpl','total'
+ write(6,136) back_loss,cell_wall_loss,scat_win_loss,air_loss,
+ & b_abs_loss,b_luc_loss,b_fpl_loss,total_loss
+ else
+ write(6,90)'solid',
+ & 'scat_win','air','BigCal_abs','Bigcal_luc','BigCal fpl',
+ $ 'total'
+ write(6,134) scat_win_loss,air_loss,b_abs_loss,b_luc_loss,b_fpl_loss,
+ $ total_loss
+ endif
+ write(6,*) ' '
+ endif
+ endif
+ 100 continue
+
+ RETURN
+ END
+
+*-------------------------------------------------------------
+ subroutine loss(electron,z,a,thick,dens,velocity,e_loss)
+*-------------------------------------------------------------
+*- Prototype C function
+*-
+*-
+*- Purpose and Method : Calculate energy loss
+*-
+*- Output: -
+*- Created 1-Dec-1995 Rolf Ent
+*-
+*- Verification: The non-electron portion on this subr. is Bethe_Bloch
+*- equation (Physial Review D vol.50 (1994) 1251 with full
+*- calculation of Tmax and the density correction. The electron
+*- part has been switched from O'Brien, Phys. Rev. C9(1974)1418,
+*- to Bethe-Bloch with relativistic corrections and density
+*- density correction, Leo, Techniques for Nuclear and Particle
+*- Physics Experiments
+*- J. Volmer 8/2/98 16:50
+*------------------------------------------------------------------------------*
+ IMPLICIT NONE
+ SAVE
+*
+ include 'gen_data_structures.cmn'
+ include 'hms_data_structures.cmn'
+ include 'sos_data_structures.cmn'
+*
+ LOGICAL electron
+ REAL*4 eloss,z,a,thick,dens,beta,e_loss
+ REAL*4 icon_ev,me_ev
+ REAL*4 icon_gev,me_gev
+ REAL*4 particle
+ REAL*4 denscorr,hnup,c0,log10bg,pmass,tmax,gamma,velocity
+ REAL*4 tau,betagamma
+ parameter (me_ev = 510999.)
+ parameter (me_gev = 0.000510999)
+*
+
+ 91 format(7(A10))
+ 90 format(7(2x,f8.5))
+ e_loss = 0.0
+ eloss = 0.0
+
+*************************************************************************
+* for debugging print out all variables that have been passed on tol loss
+*************************************************************************
+
+*****************************************************************************
+* calculate the mean excitation potential I in a newer parametrization
+* given in W.R. Leo's Techniques for Nuclear and Particle Physics Experiments
+*****************************************************************************
+
+* csa 1/99 -- Note that this code calculates the mean energy loss,
+* not the most probable. This is appropriate for the case (as in
+* Hall C) where the resolution of the measurement is significantly
+* greater than the energy loss.
+
+ if (z.lt.1.5) then
+ icon_ev = 21.8
+ elseif (z.lt.13) then
+ icon_ev = 12.*z+7.
+ elseif (z.ge.13) then
+ icon_ev = z*(9.76+58.8*z**(-1.19))
+ endif
+ icon_gev = icon_ev*1.0e-9
+
+**********************************************
+* extract the velocity of the particle:
+* hadrons: velocity = beta
+* electrons: velocity = log_10(beta*gamma)
+**********************************************
+
+ if (electron) then
+ log10bg=velocity
+ betagamma=exp(velocity*log(10.))
+ beta=betagamma/(sqrt(1.+betagamma**2))
+ gamma=sqrt(1.+betagamma**2)
+ tau=gamma-1.
+ elseif (.not.electron) then
+ beta=abs(velocity)
+
+* we still need some protection from nonsense values for beta
+
+ if (beta.ge.1.) beta=.9995
+ if (beta.le..1) beta=.1
+
+ gamma=1./sqrt(1.-beta**2)
+ betagamma=beta*gamma
+ log10bg=log(betagamma)/log(10.)
+ tau=gamma-1.
+ endif
+
+******************************************************
+* calculate the density correction, as given in Leo,
+* with Sternheimer's parametrization
+* I is the mean excitation potential of the material
+* hnup= h*nu_p is the plasma frequency of the material
+******************************************************
+
+ denscorr=0.
+ if(A.gt.0.) then
+ HNUP=28.816E-9*sqrt(abs(DENS*Z/A))
+ else
+ HNUP=28.816E-9*sqrt(abs(DENS*Z/1.))
+ endif
+
+* log(icon_gev/hnup)=log(icon_gev)-log(hnup)
+ C0=-2*(log(icon_gev)-log(hnup)+.5)
+
+ if(log10bg.lt.0.) then
+ denscorr=0.
+ elseif(log10bg.lt.3.) then
+ denscorr=C0+2*log(10.)*log10bg+abs(C0/27.)*(3.-log10bg)**3
+ elseif(log10bg.lt.4.7) then
+ denscorr=C0+2*log(10.)*log10bg
+ else
+ denscorr=C0+2*log(10.)*4.7
+ endif
+
+*******************************************************************
+* for hadrons: calculate the maximum possible energy transfer to an
+* orbital electron, find out what the hadron mass is
+*******************************************************************
+
+ pmass=me_gev
+ if (.not.electron) then
+ pmass=max(hpartmass,spartmass)
+ if (pmass.lt.2*me_gev) pmass=0.5
+ tmax=abs(2*me_gev*beta**2*gamma**2/
+ > (1+2*abs(gamma)*me_gev/pmass+(me_gev/pmass)**2))
+ endif
+
+**********************************************************************
+* now calculate the energy loss for electrons
+**********************************************************************
+* electron
+ if (electron) then
+ if((thick.gt.0.0).and.(dens.gt.0.0).and.(a.gt.0.).and.(beta.gt.0.)
+ > .and.(tau.gt.0).and.(betagamma.gt.0))then
+*jv eloss=0.1535e-03*z/a*thick/beta**2*(
+*jv > log(tau**2*(tau+2.)/2./(icon_gev/me_gev)**2)
+*jv > +1-beta**2+(tau**2/8-(2*tau+1)*log(2.))/(tau+1)**2
+*jv > -(-(2*log(icon_gev/hnup)+1)+2*log(betagamma)))
+ eloss=0.1535e-03*z/a*thick/beta**2*(
+ > 2*log(tau)+log((tau+2.)/2.)-2*(log(icon_gev)-log(me_gev))
+ > +1-beta**2+(tau**2/8-(2*tau+1)*log(2.))/(tau+1)**2
+ > -(-(2*(log(icon_gev)-log(hnup))+1)+2*log(betagamma)))
+ endif
+
+*jv if(thick.gt.0.0.and.dens.gt.0.0)then
+*jv eloss = 0.1536e-03*z/a*thick*(19.26 + log(thick/dens))
+*jv endif
+
+ endif
+
+********************************************************************
+* now calculate the energy loss for hadrons
+********************************************************************
+* proton
+ if(.not.electron) then
+
+*jv icon_ev = 16.*z**0.9
+*jv if (z.lt.1.5) icon_ev = 21.8
+
+ if((thick.gt.0.0).and.(beta.gt.0.0).and.(beta.lt.1.0).and.(a.gt.0.))then
+
+*jv eloss = 2.*0.1535e-3*Z/A*thick/beta**2*(
+*jv > .5*log(2*me_gev*beta**2*gamma**2*tmax/icon_gev**2)
+*jv > -beta**2-denscorr/2.)
+ eloss = abs(2.*0.1535e-3*Z/A*thick/beta**2)*(
+ > .5*(log(2*me_gev)+2*log(beta)+2*log(gamma)+log(tmax)-2*log(icon_gev))
+ > -beta**2-denscorr/2.)
+
+*jv eloss = log(2.*me_ev*beta*beta/icon_ev/(1.-beta*beta))
+*jv & - beta*beta
+*jv eloss = 2.*0.1536e-03*z/a*thick/beta/beta * eloss
+
+ endif
+ endif
+
+ if (eloss.le.0.) write(6,*)'loss: eloss<=0!'
+* units should be in GeV
+ e_loss = eloss
+
+ if ((gelossdebug.ne.0).or.(eloss.le.0)) then
+ particle=0.0
+ if (electron) particle=1.0
+ write(6,91) 'electron?','ztgt','atgt','thick','dens','velocity','e_loss'
+ write(6,90) particle,z,a,thick,dens,velocity,e_loss
+ write(6,'(4A10)') 'velocity','beta','pmass','denscorr'
+ write(6,'(6(2x,f8.5))') velocity,beta,pmass,denscorr
+ write(6,'(6A10)') 'betagamma','log10bg','tau','gamma','icon_ev','hnup (eV)'
+ write(6,'(6(2x,F8.3))') betagamma,log10bg,tau,gamma,icon_ev,hnup*1e9
+ endif
+
+ RETURN
+ END
diff --git a/UTILSUBS/.cvsignore b/UTILSUBS/.cvsignore
new file mode 100644
index 0000000..92aeffc
--- /dev/null
+++ b/UTILSUBS/.cvsignore
@@ -0,0 +1 @@
+O.*
diff --git a/UTILSUBS/CVS/Entries b/UTILSUBS/CVS/Entries
new file mode 100644
index 0000000..182cb6a
--- /dev/null
+++ b/UTILSUBS/CVS/Entries
@@ -0,0 +1,40 @@
+/.cvsignore/1.1/Thu Jul 8 18:42:36 2004//Tsane
+/Makefile/1.1/Tue Dec 8 14:30:49 1998//Tsane
+/Makefile.Unix/1.14.8.1/Mon Sep 10 20:08:03 2007//Tsane
+/clear_after_null.f/1.1/Thu May 16 17:48:45 1996//Tsane
+/data_row.f/1.3/Wed Feb 2 18:45:17 1994//Tsane
+/g_add_path.f/1.1/Wed Feb 9 14:13:19 1994//Tsane
+/g_append.f/1.1/Fri May 27 16:11:41 1994//Tsane
+/g_build_note.f/1.3/Wed Jun 8 17:40:56 1994//Tsane
+/g_important_length.f/1.1/Wed Feb 9 14:16:13 1994//Tsane
+/g_int_sort.f/1.1/Wed Feb 9 14:16:05 1994//Tsane
+/g_io_control.f/1.4/Fri Nov 22 17:07:02 1996//Tsane
+/g_log_message.f/1.1/Wed Feb 9 14:15:58 1994//Tsane
+/g_normalize.f/1.1/Wed Feb 9 14:16:38 1994//Tsane
+/g_prepend.f/1.1/Wed Feb 9 14:17:14 1994//Tsane
+/g_reg_c.f/1.2/Fri Jun 17 02:51:45 1994//Tsane
+/g_rep_err.f/1.4/Fri Nov 22 17:08:00 1996//Tsane
+/g_rep_where.f/1.2/Tue Mar 21 15:35:00 1995//Tsane
+/g_shift_len.f/1.2/Thu Sep 5 21:06:17 1996//Tsane
+/g_sort.f/1.1/Wed Feb 9 14:18:04 1994//Tsane
+/g_sph_xyz.f/1.1/Wed Feb 9 14:18:28 1994//Tsane
+/g_sub_run_number.f/1.4/Thu Sep 5 21:06:54 1996//Tsane
+/g_utc_date.f/1.2/Tue Mar 21 15:35:10 1995//Tsane
+/g_wrap_note.f/1.4/Thu Sep 5 21:07:18 1996//Tsane
+/g_xyz_sph.f/1.1/Wed Feb 9 14:18:59 1994//Tsane
+/get_values.f/1.1/Tue Feb 22 20:00:24 1994//Tsane
+/match.f/1.1/Tue Feb 22 20:01:00 1994//Tsane
+/no_blanks.f/1.1/Tue Feb 22 20:01:14 1994//Tsane
+/no_comments.f/1.3/Fri May 24 16:01:47 1996//Tsane
+/no_leading_blanks.f/1.2/Fri May 24 16:02:54 1996//Tsane
+/no_nulls.f/1.1/Tue Feb 22 20:01:49 1994//Tsane
+/no_tabs.f/1.1/Tue Feb 22 20:05:11 1994//Tsane
+/only_one_blank.f/1.1/Tue Feb 22 20:02:18 1994//Tsane
+/regparmstringarray.f/1.1/Thu Aug 18 03:50:34 1994//Tsane
+/shiftall.f/1.1/Tue Feb 22 20:02:34 1994//Tsane
+/squeeze.f/1.2/Fri May 24 16:03:33 1996//Tsane
+/string_length.f/1.1/Tue Feb 22 20:03:04 1994//Tsane
+/sub_string.f/1.1/Fri Apr 15 18:12:37 1994//Tsane
+/up_case.f/1.1/Tue Feb 22 20:03:16 1994//Tsane
+/up_shift.f/1.1/Tue Feb 22 20:03:26 1994//Tsane
+D
diff --git a/UTILSUBS/CVS/Repository b/UTILSUBS/CVS/Repository
new file mode 100644
index 0000000..562e9f2
--- /dev/null
+++ b/UTILSUBS/CVS/Repository
@@ -0,0 +1 @@
+Analyzer/UTILSUBS
diff --git a/UTILSUBS/CVS/Root b/UTILSUBS/CVS/Root
new file mode 100644
index 0000000..6288c3f
--- /dev/null
+++ b/UTILSUBS/CVS/Root
@@ -0,0 +1 @@
+whit@cvs.jlab.org:/group/hallc/cvsroot
diff --git a/UTILSUBS/CVS/Tag b/UTILSUBS/CVS/Tag
new file mode 100644
index 0000000..25d73f7
--- /dev/null
+++ b/UTILSUBS/CVS/Tag
@@ -0,0 +1 @@
+Tsane
diff --git a/UTILSUBS/Makefile b/UTILSUBS/Makefile
new file mode 100644
index 0000000..f0c0680
--- /dev/null
+++ b/UTILSUBS/Makefile
@@ -0,0 +1,8 @@
+#
+# $Log: Makefile,v $
+# Revision 1.1 1998/12/08 14:30:49 saw
+# Initial Setup
+#
+ETC=../etc
+
+include $(ETC)/Makefile.NEW
diff --git a/UTILSUBS/Makefile.Unix b/UTILSUBS/Makefile.Unix
new file mode 100644
index 0000000..000433d
--- /dev/null
+++ b/UTILSUBS/Makefile.Unix
@@ -0,0 +1,91 @@
+#
+# $Log: Makefile.Unix,v $
+# Revision 1.14.8.1 2007/09/10 20:08:03 pcarter
+# Implemented changes to allow compilation on RHEL 3,4,5 and MacOSX
+#
+# Revision 1.14 2004/07/08 20:01:17 saw
+# Make include file rules like other directories. Avoids leaving copies around.
+#
+# Revision 1.13 1998/12/07 22:11:35 saw
+# Initial setup
+#
+# Revision 1.12 1998/12/01 21:19:55 saw
+# (SAW) Remove g_sort
+#
+# Revision 1.11 1996/09/05 20:44:53 saw
+# (SAW) Fixes for linux compatibility
+#
+# Revision 1.10 1996/04/29 18:30:19 saw
+# (SAW) New makefile style
+#
+# Revision 1.9 1996/01/17 19:25:01 cdaq
+# (SAW) Change cp -f to $(CP)
+#
+# Revision 1.8 1995/07/28 15:23:51 cdaq
+# (SAW) Add NFSDIRECTORY stuff
+#
+# Revision 1.7 1995/04/06 20:37:18 cdaq
+# (SAW) Add g_sub_run_number
+#
+# Revision 1.6 1995/03/14 21:04:40 cdaq
+# # (SAW) Add -f switch on include file copy commands
+#
+# Revision 1.5 1995/01/27 21:11:04 cdaq
+# (SAW) Remove RCS from include file rules
+#
+# Revision 1.4 1994/08/18 04:36:28 cdaq
+# (SAW) Add regparmstringarray
+#
+# Revision 1.3 1994/07/08 18:46:08 cdaq
+# (SAW) Add g_rep_where
+#
+# Revision 1.2 1994/06/18 02:57:07 cdaq
+# (SAW) Add g_reg_c.f
+#
+# Revision 1.1 1994/06/07 18:52:21 cdaq
+# Initial revision
+#
+NEWSTYLE = 1
+include ../../etc/Makefile
+include ../../etc/Makefile.flags
+
+gsources = g_add_path.f g_build_note.f g_important_length.f g_int_sort.f \
+ g_log_message.f g_normalize.f g_prepend.f g_rep_err.f \
+ g_sph_xyz.f g_wrap_note.f g_xyz_sph.f g_shift_len.f \
+ g_io_control.f g_append.f g_utc_date.f g_reg_c.f g_rep_where.f \
+ regparmstringarray.f g_sub_run_number.f
+
+kbutils = get_values.f only_one_blank.f shiftall.f match.f no_tabs.f \
+ no_blanks.f no_comments.f no_leading_blanks.f squeeze.f sub_string.f \
+ up_case.f up_shift.f no_nulls.f string_length.f data_row.f \
+ clear_after_null.f
+
+unused =
+
+libsources = $(gsources) $(kbutils)
+sources = $(libsources)
+lib_targets := $(patsubst %.f, libutils.a(%.o), $(libsources))
+
+install-dirs := lib
+bin_targets =
+
+#default:
+# @echo "nothing to make"
+
+ifdef NFSDIRECTORY
+../%.f : $(NFSDIRECTORY)/UTILSUBS/%.f
+ ln -s $< $@
+
+.PRECIOUS: ../%.f
+endif
+
+%.cmn ../%.cmn:: ../../INCLUDE/%.cmn
+ $(CP) $< $@
+
+%.dec ../%.dec:: ../../INCLUDE/%.dec
+ $(CP) $< $@
+
+%.par ../%.par:: ../../INCLUDE/%.par
+ $(CP) $< $@
+
+include $(sources:.f=.d)
diff --git a/UTILSUBS/clear_after_null.f b/UTILSUBS/clear_after_null.f
new file mode 100644
index 0000000..d5908ad
--- /dev/null
+++ b/UTILSUBS/clear_after_null.f
@@ -0,0 +1,19 @@
+ SUBROUTINE clear_after_null(string)
+*
+* $Log: clear_after_null.f,v $
+* Revision 1.1 1996/05/16 17:48:45 saw
+* Initial revision
+*
+ IMPLICIT NONE
+ CHARACTER*(*) string
+ CHARACTER*1024 line
+ INTEGER i
+ CHARACTER*1 null
+
+C clear out the string after the first null character.
+ null=char(0) !null character.
+ i= INDEX(string,null) !2 blanks
+ if (i.ne.0) string(i:)=' '
+
+ RETURN
+ END
diff --git a/UTILSUBS/data_row.f b/UTILSUBS/data_row.f
new file mode 100644
index 0000000..56e2129
--- /dev/null
+++ b/UTILSUBS/data_row.f
@@ -0,0 +1,58 @@
+c++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+c
+c Handy & general string manipulations.
+c
+c $Log: data_row.f,v $
+c Revision 1.3 1994/02/02 18:45:17 cdaq
+c Add Log keyword
+c
+c========================================================================
+ SUBROUTINE data_row(string)
+ IMPLICIT NONE
+ SAVE
+ character*(*) string
+ character*1024 pad
+ integer out,imp,i,m,LENGTH
+ logical last_blank,last_comma
+ integer string_length !FUNCTION
+ integer g_important_length !FUNCTION
+c
+c eliminates adjacent blanks, comments, packs with ","s
+c ex: "1 2, 3" => "1,2,3,,,,,,,,,,,,,,,,,,,,"
+c
+ LENGTH= string_length(string) !total length
+ pad= string
+ call NO_nulls(pad) !remove nulls
+ call NO_tabs(pad) !remove tabs
+ call NO_comments(pad) !remove comments
+ call NO_leading_blanks(pad) !remove leading blanks
+ call only_one_blank(pad) !remove redundant blanks
+ imp= g_important_length(pad) !only nonblank length
+c
+ m= INDEX(pad,', ')
+ DO WHILE(m.LT.imp .and. m.GT.0)
+ string= pad(m+2:)
+ pad(m+1:)= string
+ m= INDEX(pad,', ')
+ ENDDO
+*
+ m= INDEX(pad,' ,')
+ DO WHILE(m.LT.imp .and. m.GT.0)
+ string= pad(m+1:)
+ pad(m:)= string
+ m= INDEX(pad,' ,')
+ ENDDO
+*
+ m= INDEX(pad,' ')
+ DO WHILE(m.LT.imp .and. m.GT.0)
+ pad(m:m)= ','
+ m= INDEX(pad,' ')
+ ENDDO
+*
+ imp= g_important_length(pad)
+ string= pad(1:imp)
+ DO i= imp+1,LENGTH
+ string(i:i)= ','
+ ENDDO
+ RETURN
+ END
diff --git a/UTILSUBS/g_add_path.f b/UTILSUBS/g_add_path.f
new file mode 100644
index 0000000..c102fd1
--- /dev/null
+++ b/UTILSUBS/g_add_path.f
@@ -0,0 +1,52 @@
+ SUBROUTINE G_add_path(where,mss)
+*----------------------------------------------------------------------
+*-
+*- Purpose and Methods : Put "where" as a prefix on the message
+*-
+*- Inputs : where - location (subroutine name usually)
+*- : mss - error message
+*- Outputs : mss - prpended error message
+*-
+*- Created 20-Nov-1993 Kevin B. Beard, Hampton U.
+*- $Log: g_add_path.f,v $
+*- Revision 1.1 1994/02/09 14:13:19 cdaq
+*- Initial revision
+*-
+*-
+*-note: Taken from hall B package.
+*----------------------------------------------------------------------
+ IMPLICIT NONE
+ SAVE
+ character*(*) where,mss
+*
+ integer m
+ character*1 first,last
+ character*1024 msg
+ logical marker
+*
+ INCLUDE 'gen_routines.dec'
+*
+*----------------------------------------------------------------------
+*
+ msg= where
+ call no_leading_blanks(msg)
+ call no_leading_blanks(mss)
+ m= G_important_length(msg)
+*
+ first= mss(1:1)
+ last= msg(m:m)
+*
+ marker= last.EQ.'>' .or. last.EQ.':' .or.
+ & last.EQ.'<' .or. first.EQ.':' .or.
+ & first.EQ.'>' .or. first.EQ.'<'
+*
+ If(marker) Then
+ msg(m:)= last//mss
+ Else
+ msg(m:)= last//'>'//mss
+ EndIf
+*
+ mss= msg
+*
+ RETURN
+ END
diff --git a/UTILSUBS/g_append.f b/UTILSUBS/g_append.f
new file mode 100644
index 0000000..0a2dbf6
--- /dev/null
+++ b/UTILSUBS/g_append.f
@@ -0,0 +1,38 @@
+ SUBROUTINE G_append(prefix,suffix)
+*----------------------------------------------------------------------
+*-
+*- Purpose and Methods : Put "suffix" as a suffix on the message
+*-
+*- Inputs : prefix - prefix to add onto suffix
+*- : suffix - suffix to be prepended
+*- Outputs : prefix - suffixed prefix
+*-
+*- Created 17-May-1994 Kevin B. Beard, Hampton U.
+* $Log: g_append.f,v $
+* Revision 1.1 1994/05/27 16:11:41 cdaq
+* Initial revision
+*
+*----------------------------------------------------------------------
+ IMPLICIT NONE
+ SAVE
+ character*(*) prefix,suffix
+*
+ integer m
+*
+ INCLUDE 'gen_routines.dec'
+*
+*----------------------------------------------------------------------
+*
+ IF(prefix.EQ.' ') THEN
+ prefix= suffix
+ RETURN
+ ELSEIF(suffix.EQ.' ') THEN
+ RETURN
+ ENDIF
+*
+ call no_leading_blanks(prefix)
+ m= G_important_length(prefix)
+ IF(LEN(prefix).GT.m) prefix(m+1:)= suffix
+*
+ RETURN
+ END
diff --git a/UTILSUBS/g_build_note.f b/UTILSUBS/g_build_note.f
new file mode 100644
index 0000000..ca54c62
--- /dev/null
+++ b/UTILSUBS/g_build_note.f
@@ -0,0 +1,162 @@
+ SUBROUTINE G_build_note(pat,wildI,Ival,wildR,Rval,fmt,note)
+*----------------------------------------------------------------------
+*-
+*- Purpose and Methods : Insert integer and real values into a message.
+*-
+*- Inputs : pat - string to copy before substitution
+*- : wildI - character to replace with real values
+*- : Ival - integer values to insert
+*- : wildR - character to replace with real values
+*- : Rval - real values to insert
+*- : fmt - character string format for real values
+*- : note - new message
+*-
+*- Created 20-Nov-1993 Kevin B. Beard, Hampton U.
+*- Modified 18-Jan-1994 K.B.Beard, HU, so wild=" " gets skipped
+* $Log: g_build_note.f,v $
+* Revision 1.3 1994/06/08 17:40:56 cdaq
+* (KBB) new version
+*
+* Revision 1.2 1994/02/17 20:56:34 cdaq
+* Fmt also for integers
+* fmt control words: "X" "Z" "HEX" hexadecimal
+* "B" "BIN" binary
+* fmt decided on basis of F or E present, "()" added if needed
+*
+* Revision 1.1 1994/02/09 14:15:01 cdaq
+* Initial revision
+*
+*-
+*- example:
+*- Ival(1)= 8
+*- Ival(2)= 3
+*- call G_build_note('message#@ is #@','@',Ival,' ',Rval,' ',msg)
+*- => msg= 'message#8 is #3'
+*-
+*----------------------------------------------------------------------
+ IMPLICIT NONE
+ SAVE
+*
+ character*(*) pat,wildI,wildR,fmt,note
+ integer Ival(*)
+ real Rval(*)
+*
+ integer N,i,m
+ character*1024 msg,tmp
+ character*1 w
+ character*20 fmtR,fmtI,FT
+ character*40 pad,new
+ logical wldI,wldR,binary,real_fmt,int_fmt
+ character*8 dflt_fmtR,dflt_fmtI,dflt_fmtZ
+ parameter (dflt_fmtR= '(f20.3)')
+ parameter (dflt_fmtI= '(i20)')
+ parameter (dflt_fmtZ= '(z10)')
+*
+*----------------------------------------------------------------------
+*
+ wldI= wildI.NE.' '
+ wldR= wildR.NE.' '
+*
+ IF(.NOT.wldI .and. .NOT.wldI) THEN
+ note= pat !do nothing
+ call only_one_blank(note) !leave only 1 consecutive blank
+ RETURN
+ ENDIF
+*
+ msg= pat
+ call only_one_blank(msg) !leave only 1 consecutive blank
+*
+ binary= .FALSE. !assume not a binary dump
+ fmtI= dflt_fmtI
+ fmtR= dflt_fmtR
+ call ShiftAll(fmt,FT)
+ call NO_leading_blanks(FT)
+ IF(FT.EQ.'Z' .or. FT.EQ.'X' .or. FT(1:3).EQ.'HEX') THEN !hexadecimal
+ fmtI= dflt_fmtZ
+ fmtR= dflt_fmtR
+ FT= ' '
+ ELSEIF(FT.EQ.'B' .or. FT(1:3).EQ.'BIN') THEN !binary
+ fmtI= dflt_fmtZ
+ fmtR= dflt_fmtR
+ binary= .TRUE.
+ FT= ' '
+ ELSEIF(FT.NE.' ' .and. FT(1:1).NE.'(') THEN !add "()"
+ pad= '('//FT//')'
+ FT= pad
+ call only_one_blank(FT)
+ ENDIF
+*
+ real_fmt= (.NOT.wldI .and. FT.NE.' ') .or.
+ & INDEX(FT,'F')+INDEX(FT,'E').GT.0
+ int_fmt= (.NOT.wldR .and. FT.NE.' ') .or.
+ & INDEX(FT,'I')+INDEX(FT,'Z').GT.0
+ IF(real_fmt) THEN
+ fmtR= FT
+ ELSEIF(int_fmt) THEN
+ fmtI= FT
+ EndIf
+*
+ N= 0
+ w= wildI
+ i= INDEX(msg,w)
+ DO WHILE (w.NE.' ' .and. i.GT.0)
+ N= N+1
+ new= '****<'//fmtI//'>****' !in case of write error
+ call NO_blanks(new)
+ write(pad,fmtI,err=666) Ival(N)
+ new= pad
+ If(binary) Then !substitue binary symbols for hex symbols
+ call sub_string(new,'0','0000')
+ call sub_string(new,'1','0001')
+ call sub_string(new,'2','0010')
+ call sub_string(new,'3','0011')
+ call sub_string(new,'4','0100')
+ call sub_string(new,'5','0101')
+ call sub_string(new,'6','0110')
+ call sub_string(new,'7','0111')
+ call sub_string(new,'8','1000')
+ call sub_string(new,'9','1001')
+ call sub_string(new,'A','1010')
+ call sub_string(new,'B','1011')
+ call sub_string(new,'C','1100')
+ call sub_string(new,'D','1101')
+ call sub_string(new,'E','1110')
+ call sub_string(new,'F','1111')
+ EndIf
+666 call squeeze(new,m) !squeeze
+ If(i.EQ.1) Then
+ tmp= new(1:m)//msg(2:)
+ msg= tmp
+ Else
+ tmp= msg(1:i-1)//new(1:m)//msg(i+1:)
+ msg= tmp
+ EndIf
+ call only_one_blank(msg) !leave only 1 consecutive blank
+ i= INDEX(msg,w)
+ ENDDO
+*
+ N= 0
+ w= wildR
+ i= INDEX(msg,w)
+ DO WHILE (w.NE.' ' .and. i.GT.0)
+ N= N+1
+ new= '****<'//fmtR//'>****' !in case of write error
+ call NO_blanks(new)
+ write(pad,fmtR,err=777) Rval(N)
+ new= pad
+777 call squeeze(new,m) !squeeze
+ If(i.EQ.1) Then
+ tmp= new(1:m)//msg(i+1:)
+ msg= tmp
+ ElseIf(i.GT.1) Then
+ tmp= msg(1:i-1)//new(1:m)//msg(i+1:)
+ msg= tmp
+ EndIf
+ call only_one_blank(msg) !leave only 1 consecutive blank
+ i= INDEX(msg,w)
+ ENDDO
+*
+ note= msg
+*
+ RETURN
+ END
diff --git a/UTILSUBS/g_important_length.f b/UTILSUBS/g_important_length.f
new file mode 100644
index 0000000..0023ce4
--- /dev/null
+++ b/UTILSUBS/g_important_length.f
@@ -0,0 +1,40 @@
+ INTEGER FUNCTION G_important_length(string)
+*----------------------------------------------------------------------
+*-
+*- Purpose and Methods : return last nonblank,nonnull character position
+*- always return at least 1
+*-
+*- Inputs : string - character string of any length
+*-
+*- Created 24-MAR-1992 Kevin B. Beard
+*- Modified 9/1/93 for hall C: KBB
+* $Log: g_important_length.f,v $
+* Revision 1.1 1994/02/09 14:16:13 cdaq
+* Initial revision
+*
+*-
+*----------------------------------------------------------------------
+ IMPLICIT NONE
+ character*(*) string
+ integer m,length
+ integer LEN !FUNCTION
+ logical one_character,more,nonblank_last,all_blank
+*----------------------------------------------------------------------
+*
+ length= LEN(string)
+ one_character= length.EQ.1
+ nonblank_last= string(length:length).NE.' '
+ all_blank= string.EQ.' '
+*
+ IF(all_blank) THEN
+ G_important_length= 1
+ ELSEIF(one_character .or. nonblank_last) THEN
+ G_important_length= length
+ ELSE !longer than 1 character and last is blank
+ Do G_important_length= 1,length-1
+ IF(string(G_important_length+1:).EQ.' ') RETURN
+ EndDo
+ G_important_length= 1
+ ENDIF
+ RETURN
+ END
diff --git a/UTILSUBS/g_int_sort.f b/UTILSUBS/g_int_sort.f
new file mode 100644
index 0000000..0221477
--- /dev/null
+++ b/UTILSUBS/g_int_sort.f
@@ -0,0 +1,55 @@
+
+ SUBROUTINE G_int_sort(N,list,idx)
+*----------------------------------------------------------------------
+*-
+*- Purpose and Methods : Sort list by increasing value
+*-
+*- Inputs : N - number of input quantities
+*- : list(*) - input lists in numerical order (not reorderd)
+*- : threshold- minimum list to consider
+*- Outputs : idx(*) - ordered index pointers
+*-
+*- Created 17-Jul-1993 K.B.Beard
+*- Modified for hall C 9/1/93: KBB
+* $Log: g_int_sort.f,v $
+* Revision 1.1 1994/02/09 14:16:05 cdaq
+* Initial revision
+*
+*-
+*----------------------------------------------------------------------
+ IMPLICIT NONE
+ integer N,list(*),idx(*)
+ integer m,m1,temp_ID
+ logical ordered_OK,swap
+*----------------------------------------------------------------------
+*
+ IF(N.LE.0) THEN !ignore if no elements
+ RETURN
+ ELSEIF(N.EQ.1) THEN !simple
+ idx(1)= 1
+ RETURN
+ ENDIF
+*
+*- pick out those above threshold
+ DO m= 1,N
+ idx(m)= m
+ ENDDO
+*
+*- use a bubble sort to order by increasing list
+ ordered_OK= .FALSE.
+ DO WHILE (.not.ordered_OK)
+ ordered_OK= .TRUE.
+ Do m=1,N-1 !1st element
+ m1= m+1 !next element
+ swap= list(idx(m)).GT.list(idx(m1))
+ if(swap) then !swap pair
+ temp_ID= idx(m)
+ idx(m)= idx(m1)
+ idx(m1)= temp_ID
+ ordered_OK= .FALSE. !swapped at least one pair
+ endif
+ EndDo
+ ENDDO
+*
+ RETURN
+ END
diff --git a/UTILSUBS/g_io_control.f b/UTILSUBS/g_io_control.f
new file mode 100644
index 0000000..f0273d7
--- /dev/null
+++ b/UTILSUBS/g_io_control.f
@@ -0,0 +1,151 @@
+ SUBROUTINE G_IO_control(IO,command,ABORT,err)
+*--------------------------------------------------------
+*-
+*- Purpose : Serve as a clearing house for all FORTRAN IO channels
+*-
+*- Input: IO - FORTRAN IO channel [command="RESERVE","FREE"]
+*- command - "R","C","A","?"
+*- Output: IO - FORTRAN IO channel [command="ANY","?"]
+*- ABORT - success or failure
+*- err - reason for failure, if any
+*-
+*- Created 8-Apr-1994 Kevin B. Beard, Hampton U.
+*- Modified 11-Apr-1994 KBB; added FREE, removed CLOSE,
+*- more efficient parsing
+* $Log: g_io_control.f,v $
+* Revision 1.4 1996/11/22 17:07:02 saw
+* (SAW) Change .eq. to .eqv. for AIX compatibility
+*
+* Revision 1.3 1996/09/05 21:05:48 saw
+* (SAW) Reduce max lun from 100 to 99 for linux compatibility
+*
+* Revision 1.2 1996/05/24 16:04:33 saw
+* (SAW) Relocate data statements for f2c compatibility
+*
+* Revision 1.1 1994/04/12 16:06:00 cdaq
+* Initial revision
+*
+*-
+*-commands: FREE -given channel IO, mark IDLE, but don't FORTRAN CLOSE it
+*- RESERVE -given channel IO, see if it's free and if so
+*- mark it .NOT.IDLE; if already IDLE, report error
+*- ANY or ? -put the next free channel into IO and mark it .NOT.IDLE
+*-
+*- All standards are from "Proposal for Hall C Analysis Software
+*- Vade Mecum, Draft 1.3" by D.F.Geesamn and S.Wood, Csoft-NOTE-94-001
+*-
+*--------------------------------------------------------
+ IMPLICIT NONE
+ SAVE
+*
+ character*12 here
+ parameter (here= 'G_IO_control')
+*
+ integer IO
+ logical ABORT
+ character*(*) command,err
+*
+ LOGICAL MATCH !UTILSUBS FUNCTION
+*
+ integer gMAX_IO_channels_allowed
+ parameter (gMAX_IO_channels_allowed= 99)
+ logical IDLE
+ parameter (IDLE= .FALSE.)
+ logical request,OK
+ character*20 cmd
+ character*80 pat
+ real rv
+ integer m
+ logical LUN_channel(gMAX_IO_channels_allowed)
+ data LUN_channel/gMAX_IO_channels_allowed*IDLE/
+*
+*--------------------------------------------------------
+ err= ' '
+*
+ LUN_channel(5)= .NOT.IDLE !always in use
+ LUN_channel(6)= .NOT.IDLE !always in use
+*
+ cmd= command
+*-most common command forms-
+ IF(cmd.EQ.'FREE' .or. cmd.EQ.'FINISHED') THEN
+ cmd= 'F'
+ ELSEIF(cmd.EQ.'ANY' .or. cmd.EQ.'ASK') THEN
+ cmd= 'A'
+ ELSEIF(cmd.EQ.'RESERVE' .or. cmd.EQ.'REQUEST') THEN
+ cmd= 'R'
+ ELSE !mixed case & VMS-like abbreviations allowed
+ If(MATCH(cmd,'F*ree') .or. MATCH(cmd,'F*inished')) Then
+ cmd='F'
+ ElseIf(MATCH(cmd,'A*ny') .or. MATCH(cmd,'A*sk')) Then
+ cmd='A'
+ ElseIf(MATCH(cmd,'R*eserve') .or. MATCH(cmd,'R*equest')) Then
+ cmd='R'
+ Else
+ call g_Shift_len(command,cmd,m) !shift it to upper case
+ EndIf
+ ENDIF
+*
+ IF(cmd.eq.'F') Then !FREE up a channel
+*
+ ABORT= 1.GT.IO .and. IO.GT.gMAX_IO_channels_allowed
+ If(ABORT) Then
+ pat= ':illegal FORTRAN IO channel#$ cannot be freed'
+ call G_build_note(pat,'$',IO,' ',rv,' ',err)
+ Else
+ ABORT= IO.eq.5 .or. IO.eq.6
+ if(ABORT) then
+ pat= ':FORTRAN IO channel#$ special; cannot be freed'
+ call G_build_note(pat,'$',IO,' ',rv,' ',err)
+ else
+ ABORT= LUN_channel(IO).EQV.IDLE !already idle
+ IF(ABORT) THEN
+ pat= ':FORTRAN IO channel#$ already IDLE'
+ call G_build_note(pat,'$',IO,' ',rv,' ',err)
+ ENDIF
+ LUN_channel(IO)= IDLE
+ endif
+ EndIf
+*
+ ELSEIF(cmd.EQ.'A') Then !get ANY channel
+*
+ DO IO=gMAX_IO_channels_allowed,1,-1 !for max compat.; start at top
+ If(LUN_channel(IO) .eqv. IDLE) Then
+ LUN_channel(IO)= .NOT.IDLE
+ ABORT= .FALSE.
+ RETURN
+ EndIf
+ ENDDO
+ ABORT= .TRUE.
+ IO= gMAX_IO_channels_allowed
+ err= ':no FORTRAN IO channels IDLE from 1-#?'
+ call G_build_note(pat,'$',IO,' ',rv,' ',err)
+ IO= 0
+*
+ ELSEIF(cmd.EQ.'R') THEN !RESERVE a channel
+*
+ ABORT= 1.GT.IO .and. IO.GT.gMAX_IO_channels_allowed
+ If(ABORT) Then
+ pat= ':illegal FORTRAN IO channel#$ cannot be reserved'
+ call G_build_note(pat,'$',IO,' ',rv,' ',err)
+ call G_add_path(here,err)
+ Else
+ ABORT= LUN_channel(IO) .neqv. IDLE
+ if(ABORT) then
+ pat= ':FORTRAN IO channel#$ not IDLE-'//
+ & 'cannot be reserved'
+ call G_build_note(pat,'$',IO,' ',rv,' ',err)
+ else
+ LUN_channel(IO)= .NOT.IDLE
+ endif
+ EndIf
+*
+ ELSE
+*
+ ABORT= .TRUE.
+ err= ':command "'//cmd(1:m)//'" not supported'
+*
+ ENDIF
+*
+ IF(ABORT) call G_add_path(here,err)
+ RETURN
+ END
diff --git a/UTILSUBS/g_log_message.f b/UTILSUBS/g_log_message.f
new file mode 100644
index 0000000..1f6ce1f
--- /dev/null
+++ b/UTILSUBS/g_log_message.f
@@ -0,0 +1,32 @@
+ SUBROUTINE G_log_message(note)
+*----------------------------------------------------------------------
+*-
+*- Purpose and Methods : Output "note"; allow future steering etc.
+*-
+*- Inputs : note - error message
+*-
+*- Created 20-NOV-1993 Kevin B. Beard, Hampton U.
+*- Modified 7-Dec-1993 KBB; updated for new include file
+* $Log: g_log_message.f,v $
+* Revision 1.1 1994/02/09 14:15:58 cdaq
+* Initial revision
+*
+*-
+*----------------------------------------------------------------------
+ IMPLICIT NONE
+ SAVE
+ character*(*) note
+*
+ INCLUDE 'gen_output_info.cmn'
+*
+ DATA G_OUTPUT_OK/.FALSE./
+ DATA G_OUTPUT_tty/6/
+*
+*----------------------------------------------------------------------
+*
+ IF(g_OUTPUT_OK) call G_wrap_note(g_OUTPUT_channel,note)
+*
+ call G_wrap_note(G_OUTPUT_tty,note)
+*
+ RETURN
+ END
diff --git a/UTILSUBS/g_normalize.f b/UTILSUBS/g_normalize.f
new file mode 100644
index 0000000..f66787e
--- /dev/null
+++ b/UTILSUBS/g_normalize.f
@@ -0,0 +1,43 @@
+
+ SUBROUTINE G_normalize(x,y,z)
+*----------------------------------------------------------------------
+*-
+*- Purpose and Methods : normalizes a vector
+*-
+*- Inputs : x - X coord. (conventional right handed system)
+*- y - Y
+*- z - Z
+*- Outputs : x - X coord. (conventional right handed system)
+*- y - Y
+*- z - Z
+*-
+*- Created 24-MAR-1992 Kevin B. Beard
+*- Modified for hall C 9/1/93: KBB
+* $Log: g_normalize.f,v $
+* Revision 1.1 1994/02/09 14:16:38 cdaq
+* Initial revision
+*
+*-
+*----------------------------------------------------------------------
+ IMPLICIT NONE
+ real x,y,z,r
+ logical normalizable
+ real nothing
+ parameter (nothing= 1.E-25)
+ real r2
+*----------------------------------------------------------------------
+*
+ r2= x**2 + y**2 + z**2
+ normalizable= r2.GT.nothing
+ IF(normalizable) THEN
+ r= SQRT(r2)
+ x= x/r
+ y= y/r
+ z= z/r
+ ELSE
+ x= 0.
+ y= 0.
+ z= 0.
+ ENDIF
+ RETURN
+ end
diff --git a/UTILSUBS/g_prepend.f b/UTILSUBS/g_prepend.f
new file mode 100644
index 0000000..1d3b48c
--- /dev/null
+++ b/UTILSUBS/g_prepend.f
@@ -0,0 +1,47 @@
+ SUBROUTINE G_prepend(prefix,suffix)
+*----------------------------------------------------------------------
+*-
+*- Purpose and Methods : Put "prefix" as a prefix on the message
+*-
+*- Inputs : prefix - prefix to add onto suffix
+*- : suffix - suffix to be prepended
+*- Outputs : suffix - prepended suffix
+*-
+*- Created 7-Dec-1993 Kevin B. Beard, Hampton U.
+* $Log: g_prepend.f,v $
+* Revision 1.1 1994/02/09 14:17:14 cdaq
+* Initial revision
+*
+*-
+*-note: Taken from hall B package.
+*----------------------------------------------------------------------
+ IMPLICIT NONE
+ SAVE
+ character*(*) prefix,suffix
+*
+ integer m
+ character*5000 msg
+ character*1 last
+*
+ INCLUDE 'gen_routines.dec'
+*
+*----------------------------------------------------------------------
+*
+ IF(prefix.EQ.' ') THEN
+ RETURN !no change to suffix
+ ELSEIF(suffix.EQ.' ') THEN
+ suffix= prefix !just copy
+ RETURN
+ ENDIF
+*
+ msg= prefix
+ call no_leading_blanks(msg)
+ m= G_important_length(msg)
+ last= msg(m:m)
+*
+ call no_leading_blanks(suffix)
+ msg(m:)= last//suffix !prevents illegal access
+ suffix= msg !in case
+*
+ RETURN
+ END
diff --git a/UTILSUBS/g_reg_c.f b/UTILSUBS/g_reg_c.f
new file mode 100644
index 0000000..672b6fe
--- /dev/null
+++ b/UTILSUBS/g_reg_c.f
@@ -0,0 +1,50 @@
+ SUBROUTINE G_reg_C(name,var,any_FAIL,err)
+*--------------------------------------------------------
+* routine to register CTP I4 variables; nice error handling
+*
+* Created 7-Jun-1994 K.B.Beard; separate HMS, SOS routines
+* Input: name - name for CTP to give variable
+* var - variable
+* any_FAIL - success or failure of previous attempts
+* err - current error message
+* Output: any_FAIL - OR of previous failure or current
+* err - appended error message
+* $Log: g_reg_c.f,v $
+* Revision 1.2 1994/06/17 02:51:45 cdaq
+* (SAW) Fix typo in here
+*
+* Revision 1.1 1994/06/17 02:49:58 cdaq
+* Initial revision
+*
+*--------------------------------------------------------
+ IMPLICIT NONE
+ SAVE
+*
+ character*8 here
+ parameter (here= 'G_reg_C')
+*
+ character*(*) name
+ character*(*) var
+ logical any_FAIL
+ character*(*) err
+*
+ INCLUDE 'gen_routines.dec'
+*
+ logical FAIL
+ integer ierr,m
+ character*256 sanitized
+*
+*--------------------------------------------------------
+*
+ sanitized= name !copy name, truncate at 256 characters
+ call squeeze(sanitized,m) !remove blanks,tabs,&nulls, get nonblank length
+*
+ ierr= regparmstring(sanitized(1:m),var,0) !only give CTP nonblank length
+*
+ FAIL= ierr.NE.0
+ IF(FAIL) call G_append(err,','//sanitized(1:m))
+*
+ any_FAIL= any_FAIL .OR. FAIL
+*
+ RETURN
+ END
diff --git a/UTILSUBS/g_rep_err.f b/UTILSUBS/g_rep_err.f
new file mode 100644
index 0000000..7ab1b24
--- /dev/null
+++ b/UTILSUBS/g_rep_err.f
@@ -0,0 +1,88 @@
+ SUBROUTINE G_rep_err(ABORT,note)
+*----------------------------------------------------------------------
+*-
+*- Purpose and Methods : if status ABORT (.NOT.OK) output the "note"
+*-
+*- Inputs : OK - status
+*- : note - error message
+*-
+*- Created 26-MAR-1992 Kevin B. Beard
+*- Modified for hall C 9/1/93: KBB
+*- Modified 11/19/93 for warning: KBB
+* $Log: g_rep_err.f,v $
+* Revision 1.4 1996/11/22 17:08:00 saw
+* (SAW) Cleanup
+*
+* Revision 1.3 1995/03/21 15:35:48 cdaq
+* (SAW) Replace variable min with minute
+*
+* Revision 1.2 1994/06/06 13:30:35 cdaq
+* (KBB) Add date/time info. Return on warning's.
+*
+* Revision 1.1 1994/02/09 14:17:33 cdaq
+* Initial revision
+*
+*-
+*----------------------------------------------------------------------
+ IMPLICIT NONE
+ SAVE
+ logical ABORT
+ character*(*) note
+*
+ INCLUDE 'gen_output_info.cmn'
+ INCLUDE 'gen_run_info.cmn'
+ INCLUDE 'gen_event_info.cmn'
+ INCLUDE 'gen_routines.dec'
+*
+ logical warning,valid_run_info
+ character*80 msg,time
+ integer iv(10),dy,mth,yr,hr,minute,sec
+ real rv(10)
+ integer lentemp
+*
+*----------------------------------------------------------------------
+*
+ warning= note.NE.' '
+*
+ IF(.NOT.ABORT .and. .NOT.warning) RETURN !do nothing
+*
+ valid_run_info= gen_run_number.GT.0 .or.
+ & gen_event_ID_number.GT.0
+*
+ IF(valid_run_info) THEN
+*
+ iv(1)= gen_run_number
+ iv(2)= gen_event_ID_number
+ iv(3)= gen_event_type
+ iv(4)= gen_event_class
+*
+ If(gen_run_UTC_last.NE.0) Then
+ call g_UTC_date(gen_run_UTC_last,gen_run_date_last,
+ & dy,mth,yr,hr,minute,sec)
+ time= gen_run_date_last
+ Else
+ time= ' '
+ EndIf
+*
+ call G_build_note('>>> Run#$ Event#$ Type#$ Class#$ '//
+ & time,'$',iv,' ',rv,' ',msg)
+*
+ call G_wrap_note(G_OUTPUT_tty,msg)
+*
+ ENDIF
+*
+ lentemp = g_important_length(note)
+ IF(ABORT) THEN
+*
+ call g_prepend('ERROR: ',note)
+ call G_wrap_note(G_OUTPUT_tty,note)
+*
+ ELSE
+*
+ call g_prepend('WARNING: ',note)
+ call G_wrap_note(G_OUTPUT_tty,note)
+*
+ ENDIF
+*
+ RETURN
+ END
diff --git a/UTILSUBS/g_rep_where.f b/UTILSUBS/g_rep_where.f
new file mode 100644
index 0000000..c2ca0d3
--- /dev/null
+++ b/UTILSUBS/g_rep_where.f
@@ -0,0 +1,62 @@
+ SUBROUTINE G_rep_where(note)
+*----------------------------------------------------------------------
+*-
+*- Purpose and Methods : report current location&time in run
+*-
+*- Outputs : note - current location & time
+*-
+*- Created 8Jun1994 Kevin B. Beard, Hampton U.
+*-
+*- form:
+* Run#[i] Event sequence#[j] ID#[k] Type#[m] Class#[n] date time zone
+*- example:
+* Run#332 Event sequence#55 ID#51 Type#1 Class#4 8-Jun-1994 14:11:33 GMT
+*
+* $Log: g_rep_where.f,v $
+* Revision 1.2 1995/03/21 15:35:00 cdaq
+* (SAW) Replace variable min with minute
+*
+c Revision 1.1 1994/07/08 18:45:43 cdaq
+c Initial revision
+c
+*----------------------------------------------------------------------
+ IMPLICIT NONE
+ SAVE
+*
+ CHARACTER*(*) note
+*
+ INCLUDE 'gen_output_info.cmn'
+ INCLUDE 'gen_run_info.cmn'
+ INCLUDE 'gen_event_info.cmn'
+*
+ character*80 time
+ character*160 msg
+ integer iv(10),dy,mth,yr,hr,minute,sec
+ real rv(10)
+*
+ character*50 pttrn
+ parameter (pttrn= 'Run#$ Event sequence#$ id#$ Type#$ Class#$')
+*
+*----------------------------------------------------------------------
+*
+ iv(1)= gen_run_number !current run ID number
+ iv(2)= gen_event_sequence_N !total number of events (control&physics)
+ iv(3)= gen_event_ID_number !current, unique physics event ID
+ iv(4)= gen_event_type !current trigger type
+ iv(5)= gen_event_class !current classification
+*
+ If(gen_run_UTC_last.NE.0) Then !update date
+ call g_UTC_date(gen_run_UTC_last,gen_run_date_last,
+ & dy,mth,yr,hr,minute,sec)
+ time= gen_run_date_last
+ Else !ignore date
+ time= ' '
+ EndIf
+*
+ call G_build_note(pttrn//' '//time,
+ & '$',iv,' ',rv,' ',msg) !fill in "$"s
+*
+ note= msg !copy
+*
+ RETURN
+ END
diff --git a/UTILSUBS/g_shift_len.f b/UTILSUBS/g_shift_len.f
new file mode 100644
index 0000000..4413441
--- /dev/null
+++ b/UTILSUBS/g_shift_len.f
@@ -0,0 +1,33 @@
+ subroutine G_shift_len(in,out,length)
+*----------------------------------------------------------------------
+*-
+*- Purpose and Methods : copy "in" to "out", upshift "out" and
+*- return important length of "out"
+*-
+*- Inputs : in - character string of any length
+*- Outputs : out - character string of any length
+*- : length - important length of out
+*-
+*- Created 8-Jul-1993 Kevin B. Beard
+*- Modified 9/1/93 for hall C: KBB
+* $Log: g_shift_len.f,v $
+* Revision 1.2 1996/09/05 21:06:17 saw
+* (SAW) Change from function to subroutine
+*
+* Revision 1.1 1994/02/09 14:17:47 cdaq
+* Initial revision
+*
+*-
+*----------------------------------------------------------------------
+ IMPLICIT NONE
+ character*(*) in,out
+ integer length
+*
+ integer G_important_length !FUNCTION
+*
+*----------------------------------------------------------------------
+*
+ call ShiftAll(in,out) !copy, upshift, remove leading blanks&tabs
+ length= G_important_length(out)
+ RETURN
+ END
diff --git a/UTILSUBS/g_sort.f b/UTILSUBS/g_sort.f
new file mode 100644
index 0000000..4374178
--- /dev/null
+++ b/UTILSUBS/g_sort.f
@@ -0,0 +1,69 @@
+
+ SUBROUTINE G_sort(N,size,threshold,ID)
+*----------------------------------------------------------------------
+*-
+*- Purpose and Methods : Sort numerically ordered input by decreasing size
+*-
+*- Inputs : N - number of input quantities
+*- : size(*) - input sizes in numerical order (not reorderd)
+*- : threshold- minimum size to consider
+*- Outputs : N - number of input quantities (above threshold)
+*- : ID(*) - ordered id numbers (above threshold)
+*-
+*- Created 8-Apr-1992 Kevin B. Beard
+*- Modified for hall C 9/1/93: KBB
+* $Log: g_sort.f,v $
+* Revision 1.1 1994/02/09 14:18:04 cdaq
+* Initial revision
+*
+*-
+*----------------------------------------------------------------------
+ IMPLICIT NONE
+ integer N,ID(*)
+ real size(*),threshold
+ integer Nin,m,m1,temp_ID
+ logical significant,ordered_OK,swap
+*----------------------------------------------------------------------
+ Nin= N !orig. number of inputs
+*
+ IF(N.LE.0) THEN !ignore if no elements
+ N= 0
+ RETURN
+ ELSEIF(N.EQ.1) THEN !simple
+ significant= size(1).GE.threshold
+ If(significant) Then
+ id(1)= 1
+ Else
+ N= 0
+ EndIf
+ RETURN
+ ENDIF
+*
+*- pick out those above threshold
+ N= 0
+ DO m=1,Nin
+ significant= size(m).GE.threshold
+ If(significant) Then !above threshold
+ N= N+1 !#
+ ID(N)= m !ID's above thresh. in sequence
+ EndIf
+ ENDDO
+*
+*- use a bubble sort to order by decreasing size
+ ordered_OK= .FALSE.
+ DO WHILE (.not.ordered_OK)
+ ordered_OK= .TRUE.
+ Do m=1,N-1 !1st element
+ m1= m+1 !next element
+ swap= size(ID(m)).LT.size(ID(m1))
+ if(swap) then !swap pair
+ temp_ID= ID(m)
+ ID(m)= ID(m1)
+ ID(m1)= temp_ID
+ ordered_OK= .FALSE. !swapped at least one pair
+ endif
+ EndDo
+ ENDDO
+*
+ RETURN
+ END
diff --git a/UTILSUBS/g_sph_xyz.f b/UTILSUBS/g_sph_xyz.f
new file mode 100644
index 0000000..d7a32af
--- /dev/null
+++ b/UTILSUBS/g_sph_xyz.f
@@ -0,0 +1,31 @@
+
+ SUBROUTINE G_sph_XYZ(r,theta,phi,x,y,z)
+*----------------------------------------------------------------------
+*-
+*- Purpose and Methods : convert spherical coord.s to cartesian
+*-
+*- Inputs : r - conventional radial coord.
+*- theta - theta angle (radians)
+*- phi - phi
+*- Outputs : x - X coord. (conventional right handed system)
+*- y - Y
+*- z - Z
+*-
+*- Created 27-MAR-1992 Kevin B. Beard
+*- Modified for hall C 9/1/93: KBB
+* $Log: g_sph_xyz.f,v $
+* Revision 1.1 1994/02/09 14:18:28 cdaq
+* Initial revision
+*
+*-
+*----------------------------------------------------------------------
+ IMPLICIT NONE
+ real r,theta,phi,x,y,z
+*----------------------------------------------------------------------
+*
+ x= r*SIN(theta)*COS(phi)
+ y= r*SIN(theta)*SIN(phi)
+ z= r*COS(theta)
+*
+ RETURN
+ end
diff --git a/UTILSUBS/g_sub_run_number.f b/UTILSUBS/g_sub_run_number.f
new file mode 100644
index 0000000..bd21be5
--- /dev/null
+++ b/UTILSUBS/g_sub_run_number.f
@@ -0,0 +1,73 @@
+ subroutine g_sub_run_number(string,number)
+*
+* $Log: g_sub_run_number.f,v $
+* Revision 1.4 1996/09/05 21:06:54 saw
+* (SAW) fix a bug
+*
+* Revision 1.3 1996/01/17 19:26:27 cdaq
+* (SAW) Fix so it works on more platforms
+*
+* Revision 1.2 1995/07/20 19:08:00 cdaq
+* (SAW) Build result into temporary string, then copy back to string.
+*
+* Revision 1.1 1995/07/14 16:31:30 cdaq
+* Initial revision
+*
+ implicit none
+ character*(*) string
+ integer number
+*
+* If a %d is found in the string, replace it with the number.
+*
+* We should probably return an error if the new string wont fit. For
+* now we just don't do the substitution.
+*
+* This is not very fancy, it should really do something like replace
+* <runnumber> by the run number, but replace %d by the run number is
+* what run control does for log file names, so we do the same as CODA
+* for now.
+*
+*
+ integer iper
+ character*10 snum ! String to hold the run number
+ character*132 stemp
+ integer inum,reallen
+
+ iper = index(string,'%')
+
+ if(iper.eq.0) return
+
+ if(string(iper+1:iper+1).ne.'d') return ! %d not found
+
+ write(snum,'(i10)') number
+ inum = 1
+ do while(snum(inum:inum).eq.' ')
+ inum = inum + 1
+ enddo
+
+ reallen = iper+2
+ do while(string(reallen:reallen).ne.' ')
+ reallen = reallen + 1
+ enddo
+ reallen = reallen-1
+
+ if(reallen+(10-inum+1)-2.gt.len(string)) return ! Would be too long
+ if(reallen+(10-inum+1)-2.gt.len(stemp)) return ! Would be too long
+ if(iper+2.gt.reallen) then ! Line ends with %d
+ stemp = string(1:iper-1)//snum(inum:10)
+ else if (iper.eq.1) then
+ stemp = snum(inum:10)//string(iper+2:reallen)
+ else
+ stemp = string(1:iper-1)//snum(inum:10)//string(iper+2:reallen)
+ endif
+ string = stemp
+
+c print *,number
+c print *,snum
+c print *,string
+
+ return
+ end
+
+
+
diff --git a/UTILSUBS/g_utc_date.f b/UTILSUBS/g_utc_date.f
new file mode 100644
index 0000000..6dbf925
--- /dev/null
+++ b/UTILSUBS/g_utc_date.f
@@ -0,0 +1,157 @@
+ SUBROUTINE G_UTC_date(UTC_time,date,dy,mth,yr,hr,minute,sec)
+*----------------------------------------------------------------------
+*-
+*- Purpose and Methods : Convert UTC time (seconds since 1 Jan 1970)
+*- into GMT time & date
+*-
+*- Inputs : UTC_time - UTC time in seconds
+*- Outputs : date - time&date string
+*- dy - day (1-31)
+*- mth - month (1-12)
+*- yr - year (1970-)
+*- hr - hr (0-23)
+*- minute - minute. (0-59)
+*- sec - sec. (0-59)
+*-
+*- Created 27-Apr-1992 Kevin B. Beard
+* $Log: g_utc_date.f,v $
+* Revision 1.2 1995/03/21 15:35:10 cdaq
+* (SAW) Replace variable min with minute
+*
+* Revision 1.1 1994/05/27 16:45:09 cdaq
+* Initial revision
+*
+*----------------------------------------------------------------------
+ IMPLICIT NONE
+ SAVE
+ INTEGER UTC_time,dy,mth,yr,hr,minute,sec
+ CHARACTER*(*) date
+*
+ integer hr_per_day,min_per_hr,sec_per_min,sec_per_day
+ parameter (hr_per_day= 24)
+ parameter (min_per_hr= 60)
+ parameter (sec_per_min= 60)
+ parameter (sec_per_day= hr_per_day*min_per_hr*sec_per_min)
+*
+ integer JAN,FEB,MAR,APR,MAY,JUN,JUL,AUG,SEP,OCT,NOV,DEC
+ parameter (JAN= 1)
+ parameter (FEB= 2)
+ parameter (MAR= 3)
+ parameter (APR= 4)
+ parameter (MAY= 5)
+ parameter (JUN= 6)
+ parameter (JUL= 7)
+ parameter (AUG= 8)
+ parameter (SEP= 9)
+ parameter (OCT= 10)
+ parameter (NOV= 11)
+ parameter (DEC= 12)
+ character*3 month(JAN:DEC)
+ integer days_per_month(JAN:DEC)
+*
+ integer mon,time
+ integer sec_year,sec_mon,sec_nonleap,sec_leap,iv(6)
+ real rv
+ logical first_call,leap_year
+ data first_call/.TRUE./
+*
+*----------------------------------------------------------------------
+*
+ IF(first_call) THEN
+ first_call= .FALSE.
+ month(JAN)= 'Jan'
+ month(FEB)= 'Feb'
+ month(MAR)= 'Mar'
+ month(APR)= 'Apr'
+ month(MAY)= 'May'
+ month(JUN)= 'Jun'
+ month(JUL)= 'Jul'
+ month(AUG)= 'Aug'
+ month(SEP)= 'Sep'
+ month(OCT)= 'Oct'
+ month(NOV)= 'Nov'
+ month(DEC)= 'Dec'
+ days_per_month(JAN)= 31
+ days_per_month(FEB)= 28
+ days_per_month(MAR)= 31
+ days_per_month(APR)= 30
+ days_per_month(MAY)= 31
+ days_per_month(JUN)= 30
+ days_per_month(JUL)= 31
+ days_per_month(AUG)= 31
+ days_per_month(SEP)= 30
+ days_per_month(OCT)= 31
+ days_per_month(NOV)= 30
+ days_per_month(DEC)= 31
+ sec= 0
+ do mon= JAN,DEC
+ sec= sec +
+ & days_per_month(mon)*sec_per_day
+ enddo
+ sec_nonleap= sec
+ sec_leap= sec_nonleap + sec_per_day
+ ENDIF
+*
+*-year
+ time= UTC_time
+ leap_year= .FALSE.
+ yr= 1970
+ IF(time.GE.0) THEN
+ sec_year= sec_nonleap
+ Do while(time.GE.sec_year)
+ time= time-sec_year
+ yr= yr+1
+ leap_year= MOD(yr,4).EQ.0
+ if(leap_year) then
+ sec_year= sec_leap
+ else
+ sec_year= sec_nonleap
+ endif
+ EndDo
+ ELSE
+ Do while(time.LT.0)
+ yr= yr-1
+ leap_year= MOD(yr,4).EQ.0
+ if(leap_year) then
+ sec_year= sec_leap
+ else
+ sec_year= sec_nonleap
+ endif
+ time= time+sec_year
+ EndDo
+ ENDIF
+*
+*-month
+ mth= JAN !determine the month
+ sec_mon= days_per_month(mth)*sec_per_day
+ DO WHILE(time.GE.sec_mon .AND. mth.LT.DEC)
+ time= time - sec_mon
+ mth= mth+1
+ sec_mon= days_per_month(mth)*sec_per_day
+ If(mth.EQ.FEB .and. leap_year) Then
+ sec_mon= sec_mon + sec_per_day
+ EndIf
+ ENDDO
+*
+*-day
+ dy= INT(time/sec_per_day)+1
+ time= time - (dy-1)*sec_per_day
+*-hr
+ hr= INT(time/(min_per_hr*sec_per_min))
+ time= time - hr*min_per_hr*sec_per_min
+*-minute
+ minute= INT(time/sec_per_min)
+ time= time - minute*sec_per_min
+*-sec
+ sec= time
+*
+ iv(1)= dy
+ iv(2)= yr
+ iv(3)= hr
+ iv(4)= minute
+ iv(5)= sec
+ call G_build_note('#-'//month(mth)//'-# #:#:# GMT',
+ & '#',iv,' ',rv,' ',date)
+*
+ RETURN
+ END
diff --git a/UTILSUBS/g_wrap_note.f b/UTILSUBS/g_wrap_note.f
new file mode 100644
index 0000000..1f5aa12
--- /dev/null
+++ b/UTILSUBS/g_wrap_note.f
@@ -0,0 +1,84 @@
+ SUBROUTINE G_wrap_note(IOchannel,note)
+*----------------------------------------------------------------------
+*-
+*- Purpose and Methods : send to output a (possibly) long message
+*- with wrapping if necc.
+*-
+*- Inputs : IOchannel - FORTRAN IO channel used for errors
+*- : note - message
+*-
+*- Created 2-Dec-1992 Kevin B. Beard
+*- Modified for hall C 9/1/93: KBB
+* $Log: g_wrap_note.f,v $
+* Revision 1.4 1996/09/05 21:07:18 saw
+* (SAW) Watch for Null's
+*
+* Revision 1.3 1994/06/17 03:05:37 cdaq
+* (SAW) Get correct copy of improved line wrapping from KBB
+*
+* Revision 1.2 1994/06/06 02:57:10 cdaq
+* (KBB) Improve line wrapping by looking for good breakpoints
+*
+* Revision 1.1 1994/02/09 14:18:43 cdaq
+* Initial revision
+*
+*-
+*----------------------------------------------------------------------
+ IMPLICIT NONE
+ SAVE
+ integer IOchannel
+ character*(*) note
+*
+ integer m,max_len,pref
+ character*1024 msg
+ logical break,indent
+ character*1 blank
+ parameter (blank=' ') !blank character
+*
+ INCLUDE 'gen_routines.dec'
+*
+ character*20 breakpt(3) !acceptable break points in order of
+ !decreasing preference
+ data breakpt/ ' >]}),;:!&|?', '<[{(+-?=*#', '$^`"''_/.~%@'/
+
+*----------------------------------------------------------------------
+*
+ msg= note !truncate after 1024 characters
+ call clear_after_null(msg) !clear out string after a null character.
+ call NO_tabs(msg) !replace tabs w/ blanks (if any)
+ call NO_leading_blanks(msg) !remove leading blanks (if any)
+ call only_one_blank(msg) !leave only 1 consecutive blank
+ m= G_important_length(msg) !return usefull length
+ max_len= 78 !less than max char./line
+ indent= .FALSE. !don't indent 1st line
+*
+ DO WHILE(msg.NE.blank) !keep cycling until message gone
+*
+ break= m.LE.max_len !look for a break (ok if short enough)
+*
+ If(.not.break) Then
+ m= max_len !start at end-of-line down
+ do pref=1,3 !three tries
+ DO while(.not.break .and. m.GT.2) !look for good break
+ m= m-1 !but quit if too short
+ break= INDEX(breakpt(pref),msg(m:m)).NE.0 !seek in order
+ ENDDO
+ enddo
+ if(.NOT.break) m= max_len !break in the middle of a word
+ EndIf
+*
+ If(indent) then
+ write(IOchannel,'(6x,a)',err=1) msg(1:m) !indent 5 extra spaces
+ Else
+ write(IOchannel,'(1x,a)',err=1) msg(1:m) !do not indent
+ max_len= max_len - 5 !decrease # significant char./line
+ indent= .TRUE. !indent from now on
+ EndIf
+*
+ msg(1:m)= blank !erase what's been just output
+ call NO_leading_blanks(msg) !shift
+ m= G_important_length(msg) !get new length
+*
+ ENDDO
+ 1 RETURN !if unable to write, just give up
+ END
diff --git a/UTILSUBS/g_xyz_sph.f b/UTILSUBS/g_xyz_sph.f
new file mode 100644
index 0000000..e8529ee
--- /dev/null
+++ b/UTILSUBS/g_xyz_sph.f
@@ -0,0 +1,48 @@
+
+ SUBROUTINE G_XYZ_sph(Tx,Ty,Tz,Tr,Ttheta,Tphi)
+*----------------------------------------------------------------------
+*-
+*- Purpose and Methods : convert cartesian coord.s to spherical
+*-
+*- Inputs : Tx - X coord. (conventional right handed system)
+*- Ty - Y
+*- Tz - Z
+*- Outputs : Tr - conventional radial coord.
+*- Ttheta - theta angle (radians 0-TT)
+*- Tphi - phi angle (radians 0-2*TT)
+*-
+*- Created 25-MAR-1992 Kevin B. Beard
+*- Modified 19-OCT-1992 KBB (fix phi)
+*- Modified for hall C 9/1/93: KBB
+* $Log: g_xyz_sph.f,v $
+* Revision 1.1 1994/02/09 14:18:59 cdaq
+* Initial revision
+*
+*-
+*----------------------------------------------------------------------
+ IMPLICIT NONE
+ real Tx,Ty,Tz,Tr,Ttheta,Tphi
+ real xyprj
+ logical off_orig,off_z_axis
+ INCLUDE 'gen_constants.par'
+*----------------------------------------------------------------------
+*
+ Tr= SQRT(Tx**2 + Ty**2 + Tz**2)
+ off_orig= Tr .GT. 0. !not at origin
+ IF(off_orig) THEN
+ Ttheta= ATAN2( SQRT(Tx**2 + Ty**2), Tz )
+ off_z_axis= ABS(Tx).GT.0. .or. ABS(Ty).GT.0.
+ If(off_z_axis) Then
+ Tphi= ATAN2( Ty, Tx ) !defined from -TT to +TT
+ if(Tphi.LT.0.) Tphi= Tphi + 2*TT
+ Else
+ Tphi= 0.
+ EndIf
+ ELSE
+ Tr= 0.
+ Ttheta= 0.
+ Tphi= 0.
+ ENDIF
+*
+ RETURN
+ end
diff --git a/UTILSUBS/get_values.f b/UTILSUBS/get_values.f
new file mode 100644
index 0000000..b7ba588
--- /dev/null
+++ b/UTILSUBS/get_values.f
@@ -0,0 +1,137 @@
+ SUBROUTINE get_values(string,n,values,ok)
+*
+* $Log: get_values.f,v $
+* Revision 1.1 1994/02/22 20:00:24 cdaq
+* Initial revision
+*
+*
+ IMPLICIT NONE
+ CHARACTER*(*) string
+ INTEGER*4 n,values(*),v(2),divider
+ INTEGER*4 i,j,k,m,value4,cycle,step
+ INTEGER*2 last_binary,last_oct,last_hex,dummy2
+ LOGICAL*2 ok,hex,oct,bin
+ CHARACTER*132 orig,line,this
+ INTEGER*4 important_length !FUNCTION
+ INTEGER*4 INDEX !FUNCTION
+ CHARACTER*1 quote
+ PARAMETER (quote='''')
+c................................................................
+ n=0
+ orig= string
+ CALL no_tabs(orig) !remove tabs
+ DO WHILE (INDEX(orig,quote).ne.0) !remove quote marks
+ i=INDEX(orig,quote)
+ orig(i:i)=' '
+ ENDDO
+ DO WHILE (INDEX(orig,'::').ne.0) !replace sequence marks
+ i=INDEX(orig,'::')
+ orig(i:i+1)='^ '
+ ENDDO
+ DO WHILE (INDEX(orig,':').ne.0) !replace seperator marks
+ i=INDEX(orig,':')
+ orig(i:i)=','
+ ENDDO
+ CALL NO_blanks(orig) !remove blanks
+ CALL UP_case(ORIG) !shift to upper case
+ IF(orig.EQ.' ') THEN
+ ok=.false. !nothing to read
+ RETURN
+ ENDIF
+c
+ line= orig
+ j= INDEX(line,',')
+ IF(j.gt.0) line(j:)=' ' !get first line
+c
+ DO WHILE (orig.NE.' ')
+c
+ divider= INDEX(line,'*') !duplicate
+ If(divider.eq.0) divider= INDEX(line,'^') !sequence
+c
+ If(divider.eq.0) Then
+ cycle=1
+ this= line
+ ElseIf(divider.eq.1) Then
+ GOTO 2222 !illegal
+ Else
+ cycle=2
+ this= line(1:divider-1)
+ EndIf
+c
+ Do j=1,cycle
+c
+ last_binary= INDEX(this,'B')
+ bin= last_binary.ne.0
+ last_hex= INDEX(this,'H')
+ If(last_hex.EQ.0) last_hex= INDEX(this,'X')
+ hex= last_hex.ne.0
+ last_oct= INDEX(this,'O')
+ oct= last_oct.ne.0
+c
+ if(hex) then
+ this(last_hex:)=' '
+ CALL squeeze(this,i)
+ IF(this.eq.' ') goto 2222
+ READ(this(1:i),'(z)',err=2222) v(j)
+ elseif(oct) then
+ this(last_oct:)=' '
+ CALL squeeze(this,i)
+ IF(this.eq.' ') goto 2222
+ READ(this(1:i),'(o)',err=2222) v(j)
+ elseif(bin) then
+ this(last_binary:)=' '
+ CALL squeeze(this,i)
+ IF(this.eq.' ') goto 2222
+ value4= 0
+ DO k=1,i
+ value4= 2*value4
+ If(this(k:k).EQ.'1') Then
+ value4= value4+1
+ ElseIf(this(k:k).NE.'0') Then
+ GOTO 2222
+ EndIf
+ ENDDO
+ v(j)= value4 !only take lowest bits
+ else
+ CALL squeeze(this,i)
+ IF(this.eq.' ') goto 2222
+ READ(this(1:i),'(i)',err=2222) v(j)
+ endif
+c
+ this= line(divider+1:)
+ EndDo
+c
+ ok=.true.
+ If(cycle.eq.2) Then
+ if(line(divider:divider).eq.'^') then !sequence "^"
+ DO k=v(1),v(2),MAX(MIN(v(2)-v(1),1),-1)
+ n= n+1
+ values(n)= k
+ ENDDO
+ else !duplicate "*"
+ DO k=1,v(1)
+ n=n+1
+ values(n)= v(2)
+ ENDDO
+ endif
+ Else !just single value
+ n=n+1
+ values(n)= v(1)
+ EndIf
+c
+ m= INDEX(orig,',') !find next line
+ If(m.EQ.0) Then !done
+ orig=' '
+ Else !another line
+ orig(1:m)=' '
+ CALL no_leading_blanks(orig)
+ line= orig
+ m= INDEX(line,',')
+ if(m.ne.0) line(m:)=' '
+ EndIf
+ ENDDO
+ RETURN
+c
+ 2222 ok=.false.
+ RETURN
+ END
diff --git a/UTILSUBS/match.f b/UTILSUBS/match.f
new file mode 100644
index 0000000..bdbca15
--- /dev/null
+++ b/UTILSUBS/match.f
@@ -0,0 +1,47 @@
+ LOGICAL FUNCTION match(test,pattern)
+*
+* $Log: match.f,v $
+* Revision 1.1 1994/02/22 20:01:00 cdaq
+* Initial revision
+*
+*
+ IMPLICIT NONE
+ CHARACTER*(*) test,pattern
+ CHARACTER*132 a,b,b_
+ INTEGER*4 i,j,k,m,n,star,B_min,A_min,j_
+ LOGICAL*2 ok
+c.................................................................
+c
+c require all of "test" match "pattern", require at least up to "*"
+C EX: test="cl" matches pattern="CL*EAR" but not pattern="CLEAR"
+C test="clx" does not match- [case insensitive]
+c
+ a= test
+ b= pattern
+ If(a.eq.' '.or.b.eq.' ') Then
+ match=.FALSE.
+ RETURN
+ EndIf
+ i= INDEX(a,':')
+ IF(i.GT.0) a(i:)=' '
+ i= INDEX(a,'=')
+ IF(i.GT.0) a(i:)=' '
+ i= INDEX(a,'*')
+ IF(i.GT.0) a(i:)=' '
+ CALL shiftall(a,a)
+ CALL shiftall(b,b)
+ CALL squeeze(a,i)
+ CALL squeeze(b,j)
+ star= INDEX(b,'*')
+ IF(star.GT.0) THEN
+ b_= b(1:star-1)//b(star+1:)
+ ok= a(1:star-1).EQ.b_(1:star-1)
+ if(i.ge.star) ok= ok .AND. a(1:i).EQ.b_(1:i)
+ ELSEIF(star.eq.1) THEN
+ ok= .TRUE.
+ ELSE
+ ok= a.EQ.b
+ ENDIF
+ match= ok
+ RETURN
+ END
diff --git a/UTILSUBS/no_blanks.f b/UTILSUBS/no_blanks.f
new file mode 100644
index 0000000..7d66714
--- /dev/null
+++ b/UTILSUBS/no_blanks.f
@@ -0,0 +1,16 @@
+ SUBROUTINE NO_blanks(string)
+*
+* $Log: no_blanks.f,v $
+* Revision 1.1 1994/02/22 20:01:14 cdaq
+* Initial revision
+*
+*
+ character*(*) string
+ integer nonblank_length
+c
+c strips out blanks and tabs
+c
+ if(string.eq.' ') RETURN
+ call squeeze(string,nonblank_length)
+ return
+ end
diff --git a/UTILSUBS/no_comments.f b/UTILSUBS/no_comments.f
new file mode 100644
index 0000000..a5773fb
--- /dev/null
+++ b/UTILSUBS/no_comments.f
@@ -0,0 +1,30 @@
+ SUBROUTINE NO_Comments(string)
+*
+* $Log: no_comments.f,v $
+* Revision 1.3 1996/05/24 16:01:47 saw
+* (SAW) Relocate data statements for f2c compatibility
+*
+* Revision 1.2 1994/06/06 04:39:27 cdaq
+* (KBB) Speedup
+*
+* Revision 1.1 1994/02/22 20:01:25 cdaq
+* Initial revision
+*
+*
+ character*(*) string
+ integer string_length !FUNCTION
+ character*23 flag
+ data flag/'!@#$%^&*<>[]{}*;?:"()~/'/
+c
+c strips out comments [including "quotes"]
+c
+ do i=1,string_length(string)
+ if(INDEX(flag,string(i:i)).ne.0) then
+ string(i:)=' '
+ return
+ elseif(string(i:).EQ.' ') then
+ return
+ endif
+ enddo
+ return
+ end
diff --git a/UTILSUBS/no_leading_blanks.f b/UTILSUBS/no_leading_blanks.f
new file mode 100644
index 0000000..5ad92ab
--- /dev/null
+++ b/UTILSUBS/no_leading_blanks.f
@@ -0,0 +1,36 @@
+ SUBROUTINE NO_leading_blanks(string)
+*
+* $Log: no_leading_blanks.f,v $
+* Revision 1.2 1996/05/24 16:02:54 saw
+* (SAW) Relocate data statements for f2c compatibility
+*
+* Revision 1.1 1994/02/22 20:01:36 cdaq
+* Initial revision
+*
+*
+ character*(*) string
+ integer skip
+ integer string_length !FUNCTION
+ character*1 tab
+ data tab/' '/
+c
+c strips out leading blanks and tabs
+c
+ if(string.eq.' ') RETURN
+ skip=0
+ LEN_string= string_length(string)
+ DO i=1,LEN_string
+ if(string(i:i).eq.' ' .or. string(i:i).eq.tab) then
+ skip=skip+1
+ else !not a tab or blank
+ if(skip.eq.0) RETURN
+ do k=skip+1,LEN_string
+ string(k-skip:k-skip)=string(k:k)
+ enddo
+ string(LEN_string-skip+1:)=' '
+ RETURN
+ endif
+ ENDDO
+ string=' ' !only tabs and blanks
+ RETURN
+ end
diff --git a/UTILSUBS/no_nulls.f b/UTILSUBS/no_nulls.f
new file mode 100644
index 0000000..09e73ce
--- /dev/null
+++ b/UTILSUBS/no_nulls.f
@@ -0,0 +1,22 @@
+ SUBROUTINE NO_nulls(line)
+*
+* $Log: no_nulls.f,v $
+* Revision 1.1 1994/02/22 20:01:49 cdaq
+* Initial revision
+*
+*
+ character*(*) line
+ character*1 null
+ integer i
+ character*1 CHAR !FUNCTION
+c
+c replaces nulls with blanks
+c
+ null= CHAR(0) !ASCII zero
+ i= INDEX(line,null)
+ DO WHILE (i.NE.0)
+ line(i:i)= ' ' !blank
+ i= INDEX(line,null)
+ ENDDO
+ RETURN
+ END
diff --git a/UTILSUBS/no_tabs.f b/UTILSUBS/no_tabs.f
new file mode 100644
index 0000000..9ae50e5
--- /dev/null
+++ b/UTILSUBS/no_tabs.f
@@ -0,0 +1,22 @@
+ SUBROUTINE NO_tabs(line)
+*
+* $Log: no_tabs.f,v $
+* Revision 1.1 1994/02/22 20:05:11 cdaq
+* Initial revision
+*
+*
+ character*(*) line
+ character*1 tab
+ integer i
+ character*1 CHAR !FUNCTION
+c
+c replaces tabs with blanks
+c
+ tab= CHAR(9) !ASCII nine
+ i= INDEX(line,tab)
+ DO WHILE (i.NE.0)
+ line(i:i)= ' ' !blank
+ i= INDEX(line,tab)
+ ENDDO
+ RETURN
+ END
diff --git a/UTILSUBS/only_one_blank.f b/UTILSUBS/only_one_blank.f
new file mode 100644
index 0000000..d85179c
--- /dev/null
+++ b/UTILSUBS/only_one_blank.f
@@ -0,0 +1,22 @@
+ SUBROUTINE only_one_blank(string)
+*
+* $Log: only_one_blank.f,v $
+* Revision 1.1 1994/02/22 20:02:18 cdaq
+* Initial revision
+*
+*
+ IMPLICIT NONE
+ CHARACTER*(*) string
+ CHARACTER*1024 line
+ INTEGER i
+C eliminate tabs,leading blanks, multiple blanks
+ CALL NO_tabs(string)
+ CALL NO_leading_blanks(string)
+ i= INDEX(string,' ') !2 blanks
+ DO WHILE (i.NE.0 .AND. string(max(i,1):).ne.' ')
+ line= string(i+1:) !skip 1st blank
+ string(i:)= line !shift left
+ i= INDEX(string,' ') !look again
+ ENDDO
+ RETURN
+ END
diff --git a/UTILSUBS/regparmstringarray.f b/UTILSUBS/regparmstringarray.f
new file mode 100644
index 0000000..1819beb
--- /dev/null
+++ b/UTILSUBS/regparmstringarray.f
@@ -0,0 +1,12 @@
+ integer function regparmstringarray(name, strings, size)
+*
+* $Log: regparmstringarray.f,v $
+* Revision 1.1 1994/08/18 03:50:34 cdaq
+* Initial revision
+*
+ character*(*) name, strings(*)
+ integer*4 size
+
+ regparmstringarray = 0
+ return
+ end
diff --git a/UTILSUBS/shiftall.f b/UTILSUBS/shiftall.f
new file mode 100644
index 0000000..8d4bd68
--- /dev/null
+++ b/UTILSUBS/shiftall.f
@@ -0,0 +1,16 @@
+ SUBROUTINE SHIFTall(InPut,OUTPUT)
+*
+* $Log: shiftall.f,v $
+* Revision 1.1 1994/02/22 20:02:34 cdaq
+* Initial revision
+*
+*
+ character*(*) InPut,OUTPUT
+c
+c shifts strings to upper case, removes all tabs,nulls & leading blanks
+c
+ OutPut=InPut
+ call UP_shift(OutPut)
+ call NO_leading_blanks(OUTPUT)
+ return
+ end
diff --git a/UTILSUBS/squeeze.f b/UTILSUBS/squeeze.f
new file mode 100644
index 0000000..6fb9ef0
--- /dev/null
+++ b/UTILSUBS/squeeze.f
@@ -0,0 +1,34 @@
+ SUBROUTINE squeeze(line,nonblank)
+*
+* $Log: squeeze.f,v $
+* Revision 1.2 1996/05/24 16:03:33 saw
+* (SAW) Relocate data statements for f2c compatibility
+*
+* Revision 1.1 1994/02/22 20:02:45 cdaq
+* Initial revision
+*
+*
+ character*(*) line
+ integer nonblank
+ integer string_length !FUNCTION
+ character*1 tab
+ data tab/' '/
+c
+c removes all blanks and tabs from a string
+c and return nonblank length
+c
+ call NO_nulls(line) !nulls=>' '
+ nonblank=0
+ LEN_line= string_length(line)
+ DO i=1,LEN_line
+ if(line(i:i).ne.' '.and.line(i:i).ne.tab) then
+ nonblank=nonblank+1 !skip blanks&tabs
+ line(nonblank:nonblank)=line(i:i)
+ elseif(line(i:).eq.' ') then !nonblank < LEN_line
+ line(nonblank+1:)=' ' !quick check
+ return
+ endif
+ ENDDO
+ if(nonblank.lt.LEN_line) line(nonblank+1:)=' '
+ return
+ end
diff --git a/UTILSUBS/string_length.f b/UTILSUBS/string_length.f
new file mode 100644
index 0000000..97ad8cc
--- /dev/null
+++ b/UTILSUBS/string_length.f
@@ -0,0 +1,15 @@
+c......................................................character operations
+ integer FUNCTION string_length(string)
+*
+* $Log: string_length.f,v $
+* Revision 1.1 1994/02/22 20:03:04 cdaq
+* Initial revision
+*
+*
+ character*(*) string
+c
+c returns the declared length of the string
+c
+ string_length= LEN(string)
+ RETURN
+ end
diff --git a/UTILSUBS/sub_string.f b/UTILSUBS/sub_string.f
new file mode 100644
index 0000000..fd3ac57
--- /dev/null
+++ b/UTILSUBS/sub_string.f
@@ -0,0 +1,29 @@
+ subroutine sub_string(string,old,new)
+********************* substitute new char. for old char. in string
+* $Log: sub_string.f,v $
+* Revision 1.1 1994/04/15 18:12:37 cdaq
+* Initial revision
+*
+ IMPLICIT NONE
+ character*(*) string,old,new
+ integer i,j,len_old,len_new,len_string
+ character*1024 temp
+ integer string_length !FUNCTION
+ if(old.EQ.new) RETURN
+ len_string= string_length(string)
+ len_old= string_length(old)
+ len_new= string_length(new)
+ j= 0
+ i= INDEX(string,old)
+ do while (i.NE.0 .and. j.LE.2*len_string+1)
+ j= j+1
+ if(len_old.EQ.len_new) then
+ string(i:i+len_new-1)= new
+ else
+ temp= string(i+len_old:)
+ string(i:)= new//temp
+ endif
+ i= INDEX(string,old)
+ enddo
+ RETURN
+ end
diff --git a/UTILSUBS/up_case.f b/UTILSUBS/up_case.f
new file mode 100644
index 0000000..cb650c2
--- /dev/null
+++ b/UTILSUBS/up_case.f
@@ -0,0 +1,26 @@
+ SUBROUTINE UP_case(string)
+*
+* $Log: up_case.f,v $
+* Revision 1.1 1994/02/22 20:03:16 cdaq
+* Initial revision
+*
+*
+ IMPLICIT NONE
+ character*(*) string
+ integer len_string,char,m,j
+ integer string_length !FUNCTION
+ character*26 lo,HI
+ data lo/'abcdefghijklmnopqrstuvwxyz'/
+ data HI/'ABCDEFGHIJKLMNOPQRSTUVWXYZ'/
+*
+* shifts string to upper case
+*
+ len_string= string_length(string)
+ m=1 !stop looking when only blanks remain
+ DO WHILE(m.LE.len_string .and. string(m:).NE.' ')
+ j= INDEX(lo,string(m:m))
+ if(j.NE.0) string(m:m)= HI(j:j)
+ m= m+1
+ ENDDO
+ RETURN
+ END
diff --git a/UTILSUBS/up_shift.f b/UTILSUBS/up_shift.f
new file mode 100644
index 0000000..ced7e4a
--- /dev/null
+++ b/UTILSUBS/up_shift.f
@@ -0,0 +1,18 @@
+ SUBROUTINE UP_shift(InPut)
+*
+* $Log: up_shift.f,v $
+* Revision 1.1 1994/02/22 20:03:26 cdaq
+* Initial revision
+*
+*
+ character*(*) InPut
+ integer tab
+c
+c shifts strings to upper case, replaces nulls&tabs with spaces
+c
+ if(InPut.eq.' ') return
+ call NO_nulls(INPUT)
+ call NO_tabs(INPUT)
+ call UP_case(InPut)
+ RETURN
+ END
diff --git a/etc/CVS/Entries b/etc/CVS/Entries
new file mode 100644
index 0000000..4c28ceb
--- /dev/null
+++ b/etc/CVS/Entries
@@ -0,0 +1,6 @@
+/Makefile/1.5.24.1/Mon Sep 10 20:08:03 2007//Tsane
+/Makefile.NEW/1.3.24.5/Wed Sep 12 16:43:31 2007//Tsane
+/Makefile.flags/1.1.2.1/Mon Sep 10 20:11:30 2007//Tsane
+/Makefile.variables/1.1.2.3.2.1/Wed Sep 2 14:02:10 2009//Tsane
+/makefile.site.in/1.6.14.2/Mon Sep 10 20:08:03 2007//Tsane
+D
diff --git a/etc/CVS/Repository b/etc/CVS/Repository
new file mode 100644
index 0000000..429fbeb
--- /dev/null
+++ b/etc/CVS/Repository
@@ -0,0 +1 @@
+Analyzer/etc
diff --git a/etc/CVS/Root b/etc/CVS/Root
new file mode 100644
index 0000000..6288c3f
--- /dev/null
+++ b/etc/CVS/Root
@@ -0,0 +1 @@
+whit@cvs.jlab.org:/group/hallc/cvsroot
diff --git a/etc/CVS/Tag b/etc/CVS/Tag
new file mode 100644
index 0000000..25d73f7
--- /dev/null
+++ b/etc/CVS/Tag
@@ -0,0 +1 @@
+Tsane
diff --git a/etc/Makefile b/etc/Makefile
new file mode 100644
index 0000000..5b7d1fa
--- /dev/null
+++ b/etc/Makefile
@@ -0,0 +1,207 @@
+#----------------------------------------------------------------------------*
+# Copyright (c) 1991, 1992 Southeastern Universities Research Association, *
+# Continuous Electron Beam Accelerator Facility *
+# *
+# This software was developed under a United States Government license *
+# described in the NOTICE file included as part of this distribution. *
+# *
+#CEBAF Data Acquisition Group, 12000 Jefferson Ave., Newport News, VA 23606 *
+# heyescebaf.gov Tel: (804) 249-7030 Fax: (804) 249-7363 *
+#----------------------------------------------------------------------------*
+#Description: follows this header.
+#
+#Author:
+# Graham Heyes
+# CEBAF Data Acquisition Group
+#
+# Revision History:
+# $Log: Makefile,v $
+# Revision 1.5.24.1 2007/09/10 20:08:03 pcarter
+# Implemented changes to allow compilation on RHEL 3,4,5 and MacOSX
+#
+# Revision 1.5 2002/12/20 21:58:57 jones
+# reduce output echoing
+#
+# Revision 1.4 1999/11/04 20:37:27 saw
+# Linux/G77 compatibility fixes
+#
+# Revision 1.3 1998/12/07 22:09:50 saw
+# Remove dependency on $Csoft
+#
+# Revision 1.1 1996/02/02 14:14:46 saw
+# Initial revision
+#
+#
+# 93/12/14 saw Copied from $(Csoft)/etc
+#
+#----------------------------------------------------------------------------
+# Generic Makefile add more directories here
+
+.DELETE_ON_ERROR: ;
+AR = ar
+PW := $(shell pwd)
+MAKEREG=$(PW)/../../../$(MYOS)$(OSEXT)/bin/makereg
+
+include $(sources:.f=.d)
+include $(sources:.c=.d)
+
+#EVGENLIB = ../../../$(MYOS)$(OSEXT)/lib/libevgen.a
+LIBROOT = ../../../$(MYOS)$(OSEXT)/lib
+#INCROOT = $(Csoft)/$(MYOS)/include
+#OS := $(shell echo $(MYOS) | tr "[A-Z]" "[a-z]")
+
+#MAKEDIRS:=$(addprefix $(shell pwd)/,$(shell find . -type d -print | sed -e '/RCS/d'|xargs echo))
+
+
+#TIMESTAMP := "\"$(shell date +%h\ %d\ %Y)\""
+#CSOFT_VERSION := "\"$(shell grep define $(Csoft)/.version.h | sed -e 's|.*CSOFTVERSION ||')\""
+#CSOFT_VERSION := "Version 0"
+
+# OS dependent declarations of library and include directories etc...
+
+.PRECIOUS: %.d
+#.PRECIOUS: %.cmn ../%.cmn %.par ../%.par %.dte ../%.dte %.dec ../%.dec
+
+.PHONY : default depend CLEAN clean ALL_CLEAN all_clean directory csoft ALL_CSOFT all_csoft
+
+ifdef NFSDIRECTORY
+DEPENDS_RULE.c = $(CC) -MM $(CFLAGS) $< |\
+ (sed -e 's|$*.o|& $@|g' -e 's|:|: .os$(MYOS) Makefile |' ;\
+ cat $< | sed -n -e \ "s|\#include \"|$@: ../|p" |\
+ sed -e "s|\".*$$||" | sed -e 's|.d:|.o:|') >$@
+else
+DEPENDS_RULE.c = $(CC) -MM $(CFLAGS) $< |\
+ sed -e 's|$*.o|& $@|g' -e 's|:|: .os$(MYOS) Makefile |' > $@
+endif
+DEPENDS_RULE.f = ( cat $< | sed -n -e \
+ "s|^[ ]*[Ii][Nn][Cc][Ll][Uu][Dd][Ee][ ]*['\"]|$@: |p" | \
+ sed -e "s|['\"].*$$||" | sed -e 's|.d:|.o:|' ; \
+ echo $*.o: .os$(MYOS) ) > $@
+COMPILE_RULE.f = $(FC) $(FFLAGS) -c $< -o $@
+COMPILE_RULE.c = $(CC) $(CFLAGS) -c $< -o $@
+# Don't "Makefile" to .d files anymore
+
+ifdef NEWSTYLE
+%.d: ../%.c
+# @echo remaking $@
+ $(DEPENDS_RULE.c)
+
+%.d: ../%.cpp
+# @echo remaking $@
+ $(DEPENDS_RULE.c)
+
+#r_%.d:
+# @echo r_$*.o: r_$*.f > $@
+
+%.d: ../%.f
+ @echo remaking $@
+ $(DEPENDS_RULE.f)
+
+%.o: ../%.f
+ $(COMPILE_RULE.f)
+
+%.o: ../%.c
+ $(COMPILE_RULE.c)
+
+else
+%.d: %.c
+# @echo remaking $@
+ $(DEPENDS_RULE.c)
+
+%.d: %.cpp
+# @echo remaking $@
+ $(DEPENDS_RULE.c)
+
+#%.d: %.f .os$(MYOS)
+%.d: %.f
+ @echo remaking $@
+ $(DEPENDS_RULE.f)
+# ( cat $< | sed -n -e \
+# "s/^[ ]*[Ii][Nn][Cc][Ll][Uu][Dd][Ee][ ]*['\"]/$<: /p" | \
+# sed -e "s/['\"].*$$//" | sed -e 's/.f:/.o:/' ; \
+# @echo $*.o: .os$(MYOS) ) > $@
+
+%.o: %.f
+ $(COMPILE_RULE.f)
+endif
+
+#%.f : %.F
+# $(FC) -F $<
+
+(%.o): %.o
+# @echo Adding $*.o to $@
+ $(AR) $(ARFLAGS) $@ $*.o
+ifdef RANLIB
+ $(RANLIB) $@
+endif
+
+TARGET_PATH := ../../../$(OSPREFIX)$(SUBDIR)/
+# Phil: the quot variable is used to keep from confusing my syntax highligher
+# I put it twice because the syntax highlighter likes to see two quotes
+# You could replace $(quot) with a literal " below, but it looks wierd
+# and doubly so with VIM's syntax highlighting
+quot = "
+quot = "
+FILES = $(addsuffix $(quot),$(addprefix $(quot)$(TARGET_PATH),$($(SUBDIR)_targets)))
+
+ifdef TARGET_PATH
+$(TARGET_PATH)%: %
+ @echo "Making $@ from $< "
+ $(RM) -r $@
+ $(CP) $< $@
+ $(RM) $<
+endif
+
+.os$(MYOS):
+ $(RM) *.d .os*
+ @echo $(MYOS) > .os$(MYOS)
+ @echo remade marker .os$(MYOS)
+
+csoft: $(REGSOURCES)
+# @echo "CSOFT - Arch. $(MYOS) sys.vers $(MYOS)$(OSEXT)"
+# @echo "`pwd` $(REGSOURCES)"
+# if ! ( $(MAKE) ... ) exits the for loop if there's an error. Otherwise the for loop will only return
+# an error if the last make command fails. This follows the default behavior of make but breaks the
+# -p option. This section could use a rewrite.
+ @echo "Considering $(shell pwd) ... "
+ @if test -z "$(install-dirs)"; then \
+ echo Nothing to do for $(MYOS)$(OSEXT); \
+ else \
+ for subdir in $(install-dirs) dummy; do \
+ if test $$subdir != dummy; then \
+ echo $(MAKE) SUBDIR=$$subdir OSPREFIX=$(MYOS)$(OSEXT)/ directory;\
+ if ! ( $(MAKE) SUBDIR=$$subdir OSPREFIX=$(MYOS)$(OSEXT)/ directory ); then exit 1; fi; \
+ fi \
+ done \
+ fi
+ @echo "Done $(shell pwd)"
+
+depend: .os$(MYOS)
+ @ echo depending...
+ @$(MAKE) $(sources:.f=.d)
+ @$(MAKE) $(sources:.c=.d)
+
+CLEAN clean::
+ @ echo Cleaning `pwd`
+ $(RM) -f *.o *.d .os*
+ @ echo Done.
+
+ALL_CLEAN all_clean:
+ @ for makefile in `find . -name Makefile -print | sed -e '/Eiffel/d' -e '/pre_/d'`; do \
+ echo ; \
+ echo Considering `dirname $$makefile` ... ; \
+ $(MAKE) -C `dirname $$makefile` clean ; \
+ done
+
+directory:
+ @echo Doing directory SUBDIR=$(SUBDIR) OSPREFIX=$(OSPREFIX)
+# @echo 'FILES=$(FILES)'
+ mkdir -p $(TARGET_PATH)
+ $(MAKE) SUBDIR=$(SUBDIR) OSPREFIX=$(OSPREFIX) $(FILES)
+
+ALL_CSOFT all_csoft:
+ @ for makefile in `find . -name Makefile -print | sed -e '/Eiffel/d' -e '/pre_/d' -e '/dev_/d`; do \
+ echo ; \
+ $(MAKE) -C `dirname $$makefile` csoft ; \
+ done
+ @ echo Made csoft for $(MYOS)
diff --git a/etc/Makefile.NEW b/etc/Makefile.NEW
new file mode 100644
index 0000000..327eb9a
--- /dev/null
+++ b/etc/Makefile.NEW
@@ -0,0 +1,82 @@
+.DELETE_ON_ERROR: ;
+
+include ../etc/Makefile.variables
+
+MAKEFILENAME = Makefile.Unix
+
+ifeq ($(MYOS),HPUX)
+
+ ifneq (,$(findstring 09,$(shell uname -r)))
+ HPUXVERSION := 09
+ else
+ HPUXVERSION := 10
+ endif
+ SUBDIRNAME = O.hpux$(HPUXVERSION)
+ OSEXT = $(HPUXVERSION)
+endif
+
+ifeq ($(MYOS),HPUXTEST)
+ MYOS = HPUX
+ SUBDIRNAME = O.hpuxtest
+ OSEXT = TEST
+endif
+
+ifeq ($(MYOS),ULTRIX)
+ SUBDIRNAME = O.ultrix
+ OSEXT =
+endif
+
+#Alpha port known to work on a
+# DEC Alphastation 200 4/166 with DEC Unix V4.0B (Rev 564)
+ifeq ($(MYOS),OSF1)
+ SUBDIRNAME = O.OSF1
+ OSEXT =
+endif
+
+ifeq ($(MYOS),Linux)
+ SUBDIRNAME = O.Linux
+ OSEXT =
+endif
+
+ifeq ($(MYOS),LinuxTEST)
+ MYOS = Linux
+ SUBDIRNAME = O.LinuxTEST
+ OSEXT = TEST
+endif
+
+ifeq ($(MYOS),SunOS)
+ ifeq ($(MYOS),SunOS4)
+ OSVERSION=4
+ else
+ OSVERSION=5
+ endif
+ SUBDIRNAME = O.$(MYOS)
+ OSEXT =
+endif
+
+ifeq ($(MYOS),AIX)
+ SUBDIRNAME = O.aix
+ OSEXT =
+endif
+
+# OSEXT is either TEST or empty
+# If you want to use LinuxTEST as shown above, just pass OSEXT=TEST
+# after 'make' on the command line, and leave MYOS as the default (Linux)
+# we don't need to do anything with OSEXT here
+#export OSEXT #either TEST or empty
+#export OSVERSION #not used since we probably can't compile on SunOS anyway
+
+.PHONY: all
+all: $(SUBDIRNAME) $(SUBDIRNAME)/Makefile
+ $(MAKE) -C $(SUBDIRNAME)
+
+$(MAKEFILENAME):
+ @echo change in $(CURDIR)/$(MAKEFILENAME)
+ (cd $(SUBDIRNAME) ; ln -f -s ../$(MAKEFILENAME) Makefile)
+
+$(SUBDIRNAME)/Makefile: $(MAKEFILENAME)
+ @echo copy $(CURDIR)/$(MAKEFILENAME)
+ (cd $(SUBDIRNAME) ; ln -f -s ../$(MAKEFILENAME) Makefile)
+
+$(SUBDIRNAME):
+ mkdir $(SUBDIRNAME)
diff --git a/etc/Makefile.flags b/etc/Makefile.flags
new file mode 100644
index 0000000..861cbf6
--- /dev/null
+++ b/etc/Makefile.flags
@@ -0,0 +1,15 @@
+# We don't want to keep appending these options to FFLAGS, so only
+# do it the first time through
+ifeq ($(MAKELEVEL),2)
+ ifeq ($(MYOS),Linux)
+ override FFLAGS += -I. -fno-automatic
+ ifeq ($(GCCVERSION),3)
+ override FFLAGS += -finit-local-zero
+ else
+# $(warning Warning: Cant use -finit-local-zero with gfortran.)
+ endif
+ endif
+
+# None of $(INCS) $(DEFS) $(EXTRA) are set, and no programs read the macros defined below
+# override CFLAGS += $(INCS) $(DEFS) $(EXTRA) -D$(MYOS) -DOSTYPE="\"$(MYOS)\"" -DVERSION=$(CSOFT_VERSION) -DDAYTIME=$(TIMESTAMP)
+endif
diff --git a/etc/Makefile.variables b/etc/Makefile.variables
new file mode 100644
index 0000000..d50e8eb
--- /dev/null
+++ b/etc/Makefile.variables
@@ -0,0 +1,86 @@
+# If you're not using GCC version 3 or 4 and Linux or Mac OS X, you'll proably
+# need to make some changes to the makefiles and possibly the source code.
+
+# New gcc version grab assumes a string like
+# gcc (GCC) 4.1.3 20070929 (prerelease) (Ubuntu 4.1.2-16ubuntu2)
+# where the version is at position 10
+gccversionstring = $(shell gcc --version | head -1)
+gccversion = ${gccversionstring:10:1}
+
+#getversion = --version | head -1 | sed 's/.*) //' | sed 's/\..*//'
+#gccversion = $(shell gcc $(getversion))
+
+g77flags = -Wimplicit
+
+export #export all variables
+unexport getversion gccversion g77flags message #except these ones
+
+CFLAGS = -Wall -W -O #-ggdb #-pg #-pedantic
+#CFLAGS = -Wall -W
+CXXFLAGS := $(CFLAGS)
+#FFLAGS = -O -ffixed-line-length-132 -ggdb -Wall -W -fbounds-check #-pg #-pedantic
+FFLAGS = -O -ffixed-line-length-132 -Wall -W #-pg #-pedantic
+CC = gcc
+CXX = g++
+
+
+ifeq ($(gccversion),4)
+ ifeq ($(gccversion),4)
+# ifeq ($(shell gfortran $(getversion)),4)
+ FC = gfortran
+ # cfortran.h wants gFortran to be defined
+ # We have two versions of cfortran.h: one from NetCDF and one from Debian
+ # Both versions support GCC 4, whereas the official version does not
+ # We use NetCDF's cfortran.h at the moment
+ # The other version is in CTP/cfortran.h.debian
+ CFLAGS += -DgFortran
+ CXXFLAGS += -DgFortran
+ else
+ # this happens if you're using a JLab RHEL3 system and have typed "use gcc/4.1.1"
+ # JLab RHEL3 systems currently have GCC 4 but no gfortran.
+ define message
+
+ +--------------------------------------------------------------------------+
+ | Warning: Using GNU C compiler version 4 but gfortran not found. Falling |
+ | back to g77 + GCC 3 for Fortran but still using GCC 4 for C and C++. |
+ +--------------------------------------------------------------------------+
+ endef
+ $(warning $(message))
+ FC = g77
+ FFLAGS += $(g77flags)
+ endif
+else
+ FC = gfortran
+ FFLAGS += $(g77flags)
+endif
+
+SHELL = /bin/sh
+CP = cp -f
+RM = rm -f
+
+# This program has only been tested under Linux and Mac OS X lately
+# For either Mac or Linux, this variable should be set to Linux
+MYOS = Linux
+#
+# There are a couple places in the Makefiles where libraries are chosen for linking.
+# It is helpful to know in these situations what the real OS is - i.e. Linux vs. MacOSX(Darwin)
+#
+MYREALOS := $(subst -,,$(shell uname))
+
+# Once upon a time, there were variables named $(MYOS), $(OSTYPE), and $(ARCH)
+# but they all tended to be set to the same value. We only use MYOS now, and
+# it's always set to Linux.
+#MYOS := $(subst -,,$(shell uname))
+#ifeq ($(MYOS),SunOS)
+# OSTYPE = $(MYOS)
+#else
+# ifeq ($(MYOS),HPUX)
+# OSTYPE = hpux10
+# else
+# ifeq ($(MYOS),AIX)
+# OSTYPE = aix
+# else
+# OSTYPE = $(MYOS)
+# endif
+# endif
+#endif
diff --git a/etc/makefile.site.in b/etc/makefile.site.in
new file mode 100644
index 0000000..966064f
--- /dev/null
+++ b/etc/makefile.site.in
@@ -0,0 +1,129 @@
+# This file isn't used anymore
+# this file sets AR, FFLAGS, PW, and MAKEREG
+AR = ar
+
+ifeq ($(MYOS),HPUX)
+ EXTRA = -D_HPUX_SOURCE -Dhpux
+ ifeq ($(OSEXT),TEST)
+ FFLAGS=+ppu -C +es -O -G +Obb1000 +FPVZOU
+ else
+ ifeq ($(OSEXT),09)
+ FFLAGS=+ppu -C +es -O +Obb1000 +FPVZOU
+ else
+ FFLAGS=+ppu -C +es -O +Onolimit +FPVZOU
+ AR=/usr/bin/ar
+ endif
+ endif
+
+ ARFLAGS=frv
+ CC = gcc
+ RPCGEN = rpcgen
+ FC = f77
+ CP=cp -f
+ RM = rm -f
+endif
+
+ifeq ($(MYOS),ULTRIX)
+ EXTRA =
+ FFLAGS=-check_bounds -extend_source -g2 -I.
+ CC = gcc
+ RPC_ROOT = /usr/site1/rpc/usr/lib
+ RPCGEN = rpcgen
+ FC = f77
+ ##CODA=/usr/site2/coda/1.3b
+ CP=cp -f
+ RM = rm -f
+ RANLIB = ranlib
+endif
+
+ifeq ($(MYOS),IRIX)
+ EXTRA =
+ FFLAGS=-check_bounds -extend_source -g2
+ LDFLAGS=
+ CC = gcc
+ RPCGEN = rpcgen
+ FC = f77
+ CP=cp
+ RM = rm -f
+endif
+
+#Alpha port known to work on a
+# DEC Alphastation 200 4/166 with DEC Unix V4.0B (Rev 564)
+ifeq ($(MYOS),OSF1)
+ EXTRA =
+ FFLAGS=-extend_source -align dcommons -I.
+ LDFLAGS=
+ CC = gcc
+ RPCGEN = rpcgen
+ FC = f77
+ CP=cp -f
+ RM = rm
+endif
+
+ifeq ($(MYOS),Linux)
+ override FFLAGS += -I. -ffixed-line-length-132 -finit-local-zero -fno-automatic
+endif
+
+#this doesn't run anymore
+ifeq ($(MYOS),LinuxOLD)
+ CC = gcc
+ CP=cp -f
+ G77:=$(filter no,$(shell which g77))
+ ifneq ($(G77),no)
+ FC=g77
+ FFLAGS= -I. -ffixed-line-length-132 -finit-local-zero -fno-automatic
+ else
+ NOFORT77:=$(filter no,$(shell which fort77))
+ ifneq ($(NOFORT77),no)
+ FC=fort77
+ FFLAGS=-Wf,-f -Nn1604
+ else
+ FC = f77
+ ifeq ($(F77COMPILER),Absoft)
+ ifndef CERN_ROOT
+ CERN_ROOT = /usr/local/cernlib/96a_absoft
+ endif
+ FFLAGS=-f -W
+ EXTRA=-DNOF77extname -DAbsoftUNIXFortran
+ else
+ ifndef CERN_ROOT
+ CERN_ROOT = /usr/local/cernlib/96a
+ endif
+ ifeq ($(F77COMPILER),fort77)
+ FC = fort77
+ FFLAGS=-Wf,-f -Nn1604
+ else
+ ifeq ($(OSEXT),TEST)
+ FFLAGS=-Nn1604 -O -f -g -pg
+ else
+ FFLAGS=-Nn1604 -O -f -g
+ endif
+ endif
+ endif
+ endif
+ endif
+ RM = rm -f
+endif
+
+ifeq ($(MYOS),SunOS)
+CC = gcc
+CP=cp -f
+FC = f77
+FFLAGS=-e -O
+RM = rm -f
+ifeq ($(OSVERSION),4)
+ RANLIB = ranlib
+endif
+endif
+
+ifeq ($(MYOS),AIX)
+CC = gcc
+CP=cp -f
+FC =f77
+FFLAGS=-qfixed=132 -qextname -O
+RM = rm -f
+endif
+
+PW := $(shell pwd)
+#MAKEREG=/group/hallc/saw/$(MYOS)$(OSEXT)/bin/makereg
+MAKEREG=$(PW)/../../../$(MYOS)$(OSEXT)/bin/makereg
diff --git a/modified.txt b/modified.txt
new file mode 100644
index 0000000..fefc0fa
--- /dev/null
+++ b/modified.txt
@@ -0,0 +1,39 @@
+Changes were made to the following files:
+
+etc/Makefile.variables :
+Made it use gfortran NOT g77
+
+SANE/sane_ntup_init.f :
+Added new ntuple (3)
+Around line 160
+
+SANE/sane_ntup_open.f :
+Added ntuple definition
+around line 417
+
+SANE/sane_ntuple_keep.f :
+Used old version ....
+
+ENGINE/g_analyze_scalers_by_banks.f :
+Added some extra includes and added scaler dump to a text file
+at the very end of the subroutine.
+
+ENGINE/g_initialize.f :
+Opened output file for scalers
+
+INCLUDE/insane_scalers.cmn
+Added file for scaler output
+
+INCLUDE/gen_scalers_cmn
+Added new scaler stuff at line 104
+
+ENGINE/g_reconstruction.f
+Commented out lines around 158 which do pedestal stuff
+in order to leave the pedestal events in the data.
+
+SANE/sane_keep_results.f :
+Commented out line to keep event type 4 (pedestal)
+
+SANE/sane_ntup_open.f :
+Added common block GEN_BEAM
+
--
GitLab