c -------------------------------
c Version 1.6 - April 16, 2003                   MUM = MUons + Medium
c -------------------------------
c                                               MUM1_6.F - the main code
c ======================================================================
c  MUM IS A FREE PRODUCT BUT EVERYBODY WHO USES IT AND PUBLISHES RESULTS
c                IS ASKED KINDLY TO CITE MUM AS FOLLOWS:
c
c  I.A.Sokalski, E.V.Bugaev, S.I.Klimushin, "MUM: FLEXIBLE PRECISE MONTE
c  CARLO ALGORITHM FOR MUON PROPAGATION THROUGH THICK LAYERS OF MATTER",
c             Phys. Rev. D64:074015 (2001) [hep-ph/0010322]
c
c I would be grateful if you inform me by e-mail about problems (if any)
c ======================================================================
c
c
c               UPGRADES comparing to V1.2 (May 17, 2000)
c               -----------------------------------------
c
c  1. Kokoulin's bremsstrahlung is included (optionally). So, INIT_MU
c     routine has got a new parameter IBRE.
c
c  2. Corrections DELTA due to nuclear form-factor for bremsstrahlung on
c     hydrogen are assigned to zero. (no remarkable influence on the
c     result).
c
c  3. Subroutine  testfinal is added (comparison input model for the
c     muon cross-section and SIMULATED energy loss (not commented yet).
c
c  4. Subroutine ENEW has been extended down to start muon energy 0.16
c     GeV (the former value - 10 GeV), which automatically leads to the
c     same extension for SIMULDE)
c
c  5. Corrections for Hartrey-Fock model at e+e- pair productions are
c     slightly improved (no remarkable influence on the result for
c     water, ice and st. rock).
c
c  6. Algorithms has been extended for 2 media (new routine INIT_MUS
c     (see comments below).
c
c  7. The seawater (Pacific Ocean, DUMAND) has been added (imed=4)
c
c          UPGRADES comparing to V1.3 (September 7, 2001)
c          ----------------------------------------------
c
c  1. The seawater (Mediterranean Sea, ANTARES place) has been added for
c     shallow depth D < 2126 m (imed=5) and for large depth D > 2126 m
c     (imed=6)
c
c  2. Gran Sasso rock has been added (imed=7)
c
c  3. 4 kinds of the Baikal lake rocks/grounds have been added
c     (imed=8-11)
c
c  4. Frejus rock has been added (imed=12 for "single medium model" and
c     imed=13 for "composed medium model")
c
c  5. Tau propagation has been included (accounting for tau-lepton decay
c      which which dominate in tau ranges below appr. 10 PeV.
c
c  6. The QCD corrections for PN interaction has been accounted according
c     to recent work of E.Bugaev&Yu.Schlepin. It can be accounted
c     optionally both for muons and taus.
c
c          UPGRADES comparing to V1.4 (December 13, 2001)
c          ----------------------------------------------
c
c  1. The random REAL*4 generator RNDM that is not supported by CERN
c     library anymore, has been changed for RANLUX. The first generated
c     number (at initiation) both in RANLUX and in REAL*8 RM48 generators
c     is now composed from current date (down to seconds) that is taken
c     by calling the routine GETSEED (see below). NOTE THAT IN INITIATION
c     ROUTINES NEW INPUT VARIABLE LUX APPEARS !
c
c  2. Extention for 4 medium: now after the only initiation it is
c     possible to simulate propagation through 4 media consequently or
c     propagation of muons and tau-leptons through 2 media. It was done
c     to simulate tau-lepton propagation and decay (that in 17% decays
c     in muon) and then muon propagation both through rock and water.
c
c  3. Improvements in processing the tau-lepton life time (note that new
c     input variable has been added in ENEW(S,3,4) routine). One can
c     choose either propagation of tau-lepton from the vertex of CC
c     neutrino interaction or from any other point accounting for time
c     that has passed since tau was born to simulate point of tau-decay
c     correctly. See description of ENEW routine for more details.
c     NOTE THAT IN ROUTINE ENEW NEW ITIME VARIABLE APPEARS !
c
c  4. FORTRAN source has been divided into 4 parts. This program unit
c     is the main one. Other 3 (which is essentially identical) contain
c     routines for 3 other sets "lepton/medium".
c
c  5. A demo code demo.f is provided with package. It propagates 10^5
c     muons through 1 km of standard rock and then through 100 meters of
c     sea water and fiils histogram with final muon spectrum that can be
c     seen then in mum1_5.hbook file. When working properly the demo code
c     produces a histogram with appr.13000 muons, mean = appr.1.2 and RMS
c     = appr.0.5. A simple Makefile is provided with package to run with
c     demo code but one has to write ones own Makefile to work with the
c     MUM package  making sure to link CERN library and sources
c
c                         mum1_5.f
c                         mum1_5_2.f
c                         mum1_5_3.f
c                         mum1_5_4.f
c
c
c  6. Some amount of minor improvements.
c
c          UPGRADES comparing to V1.5 (February 11, 2003)
c          ----------------------------------------------
c
c  1. The corrections for PN cross-section ("soft GVDM part", BB formula
c     have been incorporated. It does not change results for muon, but
c     increase cross-sectin and energy losses for tau-lepton (+ ~20% for
c     all energies).
c
c  2. Improved QCD corrections for PN interaction have been incorporated
c     as published in [E.V.Bugaev, Yu.V.Shlepin, Phys.Rev.D67, 034027,
c     2003 (hep-ph/0203096)]. They are essentially higher compared to
c     ones used in MUM1.5 that were based on preliminary results from
c     E.Bugaev and Yu.Shlepin.
c
c  3. Possibility to propagate leptons using propagation depth expressed
c     in [g**(-1) cm**2] is provided. For this at initialization one needs
c     to use IMED variable with negative sign. In this case the same medium
c     will be treated but wityh density = 1.0 g/cm**3
c
c  4. Tau-lepton decay mode is generated in ENEW routine along with tau
c     life time. The rest of life time and decay mode are kept in a common
c     block and may be processed (if neccessary) by TAUOLA package
c     [S.Jadach et al., Comput.Phys.Commun. 64, 275 (1991)] (generation
c     of tau decay, energy of decay products, etc.
c
c          UPGRADES comparing to V1.6 (********, 20**)
c          ----------------------------------------------
c
c  1. Option to set definite seed for single- and double- precision random
c     generators is added (the INIT_MU routine has got a new parameter
c     ISEED).
c
c  2. Random numbers from files.
c
c  3. Some additional service routines.
c
c  4. MUM run card added
c
c  5. Adopted for Python (PyMUM)
c
c  6. EARRAY1 - Depth range increased from 2 km up to 50 km
c
c  7. Bremssstralung cross-sections from Sandrock are incorporated
c     (ibrem-2)
c
c***********************************************************************
c                      ================= CODE MUM1_6.F =================
c        _.o.g
c      .^   \ ^.          The code calculates cross-sections, free paths
c    _//     !  \._         and energy losses for muon interactions and
c  <__(______)_.^__,>          can simulate both muons' propagation
c     ((((|   __|    (_)         through large distances in medium
c     (((C   (@,\    ()             and  muon's behavior within
c      ((     ) _)    O              an underwater or ice array
c   .-^|  (   __|     o       In December 2001 the part for tau-lepton
c .<_  \    ___/^-,  j-j               propagation was added
c    ^-.\    )     \(_/                Written by I.Sokalski
c        ^---                 E-mails: sokalski@pcbai10.inr.ruhep.ru
c                                      Igor.Sokalski@ba.infn.it
c                                 Web: http://www.ba.infn.it/~sokalski
c
c                                  July 1999, IfH-DESY/Zeuthen
c                             November 1999 - July 2000, INR/Moscow
c                           August - October 2001, CEA/Saclay, DAPNIA
c                        December 2001 & February-April 2003,  INFN/Bari
c ......................................................................
c ATTN : CERN libraries KERNLIB, MATHLIB, PACKLIB, GRAFLIB, GRAFX11
c              should be linked to execute this code
c ......................................................................
c
c                       H O W    T O   U S E :
c                       ====================
c
c First of all, the subroutine INIT_MU should be executed:
c
c            call init_mu(imed,ipn,ibre,em,vm,ilep,iqcd,lux,iseed)
c
c NB. If more than 1 medium are needed one has also to execute
c
c            call init_muS(imed,ipn,ibre,em,vm,ilep,iqcd,lux)
c            call init_mu3(imed,ipn,ibre,em,vm,ilep,iqcd,lux)
c            call init_mu4(imed,ipn,ibre,em,vm,ilep,iqcd,lux)
c
c     to activate 2nd, 3rd, and 4th media, correspondingly with other
c     parameters for media and kind of lepton. It provides with
c     opportunity to simulate propagation through a combined medium
c     for both kind of leptons. For instance, after calling INIT_MU
c     for for muon and standard rock, INIT_MUS for muon and sea water,
c     INIT_MU3 for tau and standard rock, and INIT_MU4 for tau and sea
c     water one can simulate propagation of tau-lepton through rock
c     and water below an underwater detector and then propagation of
c     muon that appears in tau decay through rock and water up to the
c     detector sensitive volume (decay mode is generated in MUM but
c     not decay product energies) calling routines ENEW3, ENEW4, ENEW
c     and ENEWS, correspondingly (see description of these routines
c     below).
c
c **********************************************************************
c **********************************************************************
c *******     IMPORTANT -> init_mu must be executed BEFORE the   *******
c *******       1st call to init_muS, init_mu3 and init_mu4      *******
c **********************************************************************
c **********************************************************************
c
c                   VARIABLES FOR INITIATION ROUTINES:
c                   =================================
c
c   INTEGER  imed = 1 -> water
c            imed = 2 -> standard rock
c            imed = 3 -> Antarctic ice
c            imed = 4 -> seawater (Pacific Ocean)
c            imed = 5 -> seawater (Mediterranean Sea, ANTARES place,
c                        D < 2126 m)
c            imed = 6 -> seawater (Mediterranean Sea, ANTARES place,
c                        D > 2126 m)
c            imed = 7 -> Gran Sasso rock
c            imed = 8-11 -> Different kinds of the Baikal rocks/grounds
c            imed = 12-13 -> Frejus rock ("single medium" and "composed
c                            medium" models)
c
c   NB. One can also set imed to a negative value in a range -13 - -1.
c       In this case propagation distance at the input of propagation
c       routines should be expessed in cm w.e. (not in cm as it takes
c       place with positive IMEDs). For instance imed = -1 means pure
c       water with density 1 g/cm**3.
c
c   INTEGER  ipn  = 1 -> Sigma_gamma_p for photonuclear interaction is
c                        calculated by Bezrukov_Bugaev (squared LN
c                        dependence) (L.B.Bezrukov, E.V.Bugaev,
c                        Yad.Fiz., V. 33, 5, 1981 (1195) (in Russian)
c            ipn.ne.1 -> It is calculated by ZEUS parameterization
c                        (J.Breitweg et al., Eur.Phys.J. C7 (1999) 609)
c
c   INTEGER ibre = 1  -> Bremsstrahlung is treated according to
c                        Bezrukov-Bugaev-Andreev (L.B.Bezrukov,
c                        E.V.Bugaev, Proc. of 17th ICRC (1981), v.7, p.
c                        102; Yu.M.Andreev,L.B.Bezrukov, E.V.Bugaev,
c                        Yad.Fiz. 57, 2146 (1994) [Phys.Atom.Nucl. 57,
c                        2066 (1994)].
c           ibre = 2 ->  It is computed according Sandrock
c           ibre.ne.1 -> It is computed according to Kokoulin-Kelner-
c                        Petrukhin (GEANT4).
c
c   REAL*4   em (GeV) -> lower threshold for energy transfers to
c                        simulate muon passage through a detector
c                        (below it all energy losses will be considered
c                        as "continuous" ones
c
c   REAL*4   vm       -> lower threshold for relative energy transfer
c                        to simulate muon propagation through large
c                        distances in given medium (below it all energy
c                        losses will be considered as "continuous" ones.
c                        See discussion on choice VM in Phys.Rev.D64,
c                        074015 (2001) [hep-ph/0010322]
c
c   INTEGER  ilep  = 1 -> the algorithm treats the muon propagation
c            ilep.NE.1 -> the algorithm treats the tau-lepton
c                         propagation
c
c   INTEGER  iqcd.NE.1 -> The "QCD-corrections" for PN interaction are
c                         not accounted for
c            iqcd = 1 -> The "QCD-corrections" for PN interaction are
c                        taken into account according to [E.V.Bugaev,
c                        Yu.V.Shlepin, Phys.Rev.D67, 034027, 2003
c                        (hep-ph/0203096)]
c
c   INTEGER LUX -> sets luxirity level for real*4 random generator. It
c                  may be from 0 to 4 (the higher is value the higher
c                  is quality), approximate relative time that is
c                  needed to generate random numbers is
c
c                                1.0    for LUX=0
c                                1.5    for LUX=1
c                                2.0    for LUX=2
c                                3.0    for LUX=3
c                                5.0    for LUX=4
c
c                  The recommended value is LUX=2 that is described in
c                  CERN manual as "passes all known tests, but
c                  theoretically still defective"
c
c    INTEGER ISEED.LT.0 -> Seeds for both random number generators
c                          (real*4 and real*8) are set 'quasi-randomly'
c                          using information on time and  date  and
c                          are not under user's  control.
c
c            ISEED.GT.0 -> Seeds for both random number generators
c                          (real*4 and real*8) are set equal to ISEED.
c
c            ISEED.EQ.0 -> Random numbers will be taken from two arrays
c                          (rndm4 and rndm8) both  of which contains
c                          15 000 000 in-advance-generated random
c                          numbers. The process ic cyclyc: if generated
c                          number No. 15000000 is taken, the couner is
c                          set to zero and after the next call number
c                          No. 1 will be taken.
c
c      PLEASE NOTE THAT ISEED VARIABLE IS ABSENT IN INIT_MUS, INIT_MU2
c      AND INIT_MU3 ROUTINES!
c
c   +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
c
c         ATTENTION: EM SHOULD BE IN A RANGE OF 0.01 -- 0.5 GeV
c                    VM SHOULD BE IN A RANGE OF 10^-4 - 0.2
c
c If one would like to study array response for showers with E > E_s >
c 0.5 GeV it is possible by setting EM = 0.5 GeV and just ignore
c interactions with E_tr > E_s.  Setting EM directly to > 0.5 GeV may
c lead to essential errors, MUM is protected against such attempts.
c
c   +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
c
c Calls to initiation routines must be done before any other routines
c called. In principle, one may change medium within one code executing,
c i.e. call INIT_MU, INIT_MUS, INIT_MU3 and INIT_MU4  more than once.
c
c N.B. Any medium consisting of any elements for muon/tau propagation
c      can be prepared by editing subroutine MED_CONS (use examples
c      there) but in this case one needs also to make corrections in
c      ENEW(S,3,4) routines adding line(s) with 'IF' operator in 3
c      places.
c
c N.B.2 One can exclude catastrophic losses for knock-on electrons (all
c       ionization losses and e-diagrams for bremsstrahlung will be
c       continuous losses for simulation with threshold VMIN only,
c       simulations with threshold EMIN will include catastrophic losses
c       for ionization, anyway). For that one should set variable NOCA
c       in routine MED_CONS (MED_CONSS, MED_CONS3, MEDCONS4 for other
c       media) to 0. See discussion on delta-electrons in Phys.Rev.D64,
c       074015 (2001) [hep-ph/0010322]
c
c N.B.3 For investigation purposes one can multiply all dif. cross
c       sections and Bethe-Bloch formula by a factor FA which is set to
c       be equal to 1 in basic version (subroutines MED_CONS, MED_CONSS,
c       MED_CONS3, MEDCONS4). Note that nobody used FA less than FA=0.9
c       and larger than FA=1.1. So, one needs be careful playing with
c       this.
c
c N.B.4 Almost all routines described below are also available for kind
c       of lepton and media that are activate with INIT_MUS, INIT_MU3,
c       and INIT_MU4 routines but with a suffix "S", "3", "4" at the end.
c       E.g., getlbrem(x) -> getlbremS(x). All these routines are
c       ABSOLUTELY independent on the set of 1st-medium ones and are
c       placed in separate FORTRAN sources MUM_1_5_2.f, MUM_1_5_3.f, and
c       MUM_1_5_4.f. Comments have been removed because all these routines
c       are ABSOLUTELY identical to ones described below. Several routines
c       are unavailable for 2nd, 3rd and 4th media: EARRAY1, EARRAY2,
c       BKNS, GAIS, SPECDEPT, TESTCOM, TESTFINAL, TESTBREM, TESTPAIR,
c       TESTPHNU, TESTELEC.
c
c **********************************************************************
c                  SPECIAL NOTES ON TAU PROPAGATION
c                  ================================
c
c 1. Some procedures in current version of the code can not be used for
c    TAU leptons. Be sure to read carefully descriptions of all
c    procedures below.
c
c 2. In current version for the tau propagation the range of V_cut is
c    restricted by an upper limit which depends on medium. If one
c    attempts to set V_cut above this limit it will be reduced
c    automatically by initiation routine. Sorry for inconvenience. One
c    can not do everything at once. Please be patient. The table with
c    upper limits for V_cut is enclosed below:
c
c            Nb. of medium              Upper limit for V_cut
c
c                1                             5.3e-3
c                2                             1.5e-2
c                3                             4.9e-3
c                4                             5.6e-3
c                5                             5.7e-3
c                6                             5.7e-3
c                7                             2.0e-2
c                8                             2.3e-2
c                9                             1.8e-2
c               10                             1.4e-2
c               11                             1.1e-2
c               12                             2.0e-2
c               13                             2.0e-2
c            -13 - -1                          4.0e-3
c
c **********************************************************************
c
c After initiation you are welcome to use the following routines:
c
c                    1. MUON/TAU BREMSSTRAHLUNG
c                       -----------------------
c------
c 1a/ real*4 function getlbrem(X)
c
c gives the average free path (in cm if IMED is positive and in cm w.e.
c if IMED is negative) for muon bremsstrahlung with energy transfers >
c EMIN.  X is muon energy X (expressed in GeV) and should be within a
c range of 10 -- 10^9 GeV. E-diagrams are not taken into account. They
c are joint with ionization losses (see part for knock-on electrons).
c Can not be applied for TAU-case in this version.
c------
c 1b/ real*4 function glbremv(X)
c
c gives the average free path (in cm if IMED is positive and in cm w.e.
c if IMED is negative) for muon bremsstrahlung with energy transfers >
c VMIN.  X is muon energy X (expressed in GeV) and should be within a
c range of 10 -- 10^9 GeV. E-diagrams are not taken into account. They
c are joint with ionization losses (see part for knock-on electrons).
c------
c 1c/ real*4 function getctbr(X)
c
c gives the total cross-section (in cm^2) for muon bremsstrahlung with
c energy transfers > EMIN. X is muon energy X (expressed in GeV) and
c should be within a range of 10 -- 10^9 GeV. The cross-section is
c averaged over all atoms of given medium:
c
c               sigma(E_mu) = SUM (w_i * sigma_i(E_mu)),
c
c where w_i = N_i/N_tot, N_i - number of type i atoms in molecule,
c N_tot - total number of atoms in molecule, sigma_i(E_mu) is a
c cross-section for atom number i. So, it is calculated for an
c "effective nucleus" with atomic weight
c
c                  A_eff = SUM(N_i*A_i) / N_tot
c
c E-diagrams are not taken into account. They are joint with
c ionization losses (see part for knock-on electrons). Can not be
c applied for TAU-case in this version!
c------
c 1d/ real*4 function gctbrv(X)
c
c gives the total cross-section (in cm^2) for muon bremsstrahlung with
c energy transfers > VMIN. X is muon energy X (expressed in GeV) and
c should be within a range of 10 -- 10^9 GeV. The cross-section is
c averaged over all atoms of given medium:
c
c               sigma(E_mu) = SUM (w_i * sigma_i(E_mu)),
c
c where w_i = N_i/N_tot, N_i - number of type i atoms in molecule,
c N_tot - total number of atoms in molecule, sigma_i(E_mu) is a
c cross-section for atom number i. So, it is calculated for an
c "effective nucleus" with atomic weight
c
c                  A_eff = SUM(N_i*A_i) / N_tot
c
c E-diagrams are not taken into account. They are joint with
c ionization losses (see part for knock-on electrons).
c------
c 1e/ real*4 function getcdbr(X,Y,lo)
c
c  gives the differential cross-section d_Sigma/d_v for muon brem-
c  strahlung for given energy X (in GeV, should be within a range of 10
c  -- 10^9 GeV) and  relative energy transfer Y which should be within
c  a range of -11 < log(Y) < 0. If lo=0, natural units are used for Y,
c  otherwise (lo=1) LOG10(Y) should be used at the input. Cross-section
c  values are expressed in cm^2 and is averaged over all atoms of given
c  medium (see (1c)). E-diagrams are not taken into account. They are
c  joint with ionization losses (see part for knock-on electrons).
c------
c 1f/ real*4 function getdedbr(X)
c
c  gives the energy losses (expressed in MeV/cm if IMED is positive and
c  in MeV g**-1 cm**2 if IMED is negative) for muon brem-strahlung
c  for interactions with relative energy transfers > EMIN. X is muon
c  energy expressed in GeV and should be within a range of 10 -- 10^9
c  GeV. E-diagrams are not taken into account. They are joint with
c  ionization losses (see part for knock-on electrons). Can not be
c  applied for TAU-case in this version!
c------
c 1g/ real*4 function gdedbrv(X)
c
c  gives the energy losses (expressed in MeV/cm if IMED is positive and
c  in MeV g**-1 cm**2 if IMED is negative) for muon bremsstrahlung
c  for interactions with relative energy transfers > VMIN. X is muon
c  energy expressed in GeV and should be within a range of 10 -- 10^9
c  GeV. E-diagrams are not taken into account. They are joint with
c  ionization losses (see part for knock-on electrons).
c------
c 1h/ real*4 function gdedbrt(X)
c
c  gives the total energy losses (expressed in MeV/cm if IMED is
c  positive and in MeV g**-1 cm**2 if IMED is negative) due to  muon
c  bremsstrahlung. X is muon energy expressed in GeV and should be
c  within a range of 10 -- 10^9 GeV. E-diagrams are not taken into
c  account.They are joint with ionization losses (see part for knock-on
c  electrons).
c------
c 1i/ subroutine getvbrem(X,Y,itr)
c
c  simulates the relative energy transfer Y for muon bremsstrahlung
c  within a range of EMIN -- 1 (if itr=0) or VMIN -- 1 (itr=1). X is
c  muon energy expressed in GeV and should be within a range of
c  10 GeV < X < 1000.000.000 GeV. E-diagrams are not taken into
c  account.They are joint with ionization losses (see part for knock-
c  on-electrons).
c------
c 1j/ subroutine testbrem(lo)
c
c  performs some test with filling number of histograms and .dat files.
c  The test is short if lo=0. Otherwise it takes more time but gives more
c  statistics. HAS NOT BEEN TESTED COMPLETELY WITH TAU, BE CAREFUL !
c
c                 2. E+E- PAIR PRODUCTION BY MUON/TAU
c                    --------------------------------
c------
c 2a/ real*4 function getlpair(X)
c
c gives the average free path (in cm if IMED is positive and in cm w.e.
c if IMED is negative) for e+e- pair production with energy transfers >
c EMIN.  X is muon energy X (expressed in GeV) and should be within a
c range of 10 -- 10^9 GeV. Can not be applied for TAU-case in this
c version.
c------
c 2b/ real*4 function glpairv(X)
c
c gives the average free path (in cm if IMED is positive and in cm w.e.
c if IMED is negative) for e+e- pair production with energy transfers >
c VMIN.  X is muon energy X (expressed in GeV) and should be within a
c range of 10 -- 10^9 GeV.
c------
c 2c/ real*4 function getctpa(X)
c
c gives the total cross-section (in cm^2) for e+e- pair production with
c energy transfers > EMIN. X is muon energy X (expressed in GeV) and
c should be within a range of 10 -- 10^9 GeV. The cross-section is
c averaged over all atoms of given medium (see 1c). Can not be
c applied for TAU-case in this version!
c------
c 2d/ real*4 function gctpav(X)
c
c gives the total cross-section (in cm^2) for e+e- pair production with
c energy transfers > VMIN. X is muon energy X (expressed in GeV) and
c should be within a range of 10 -- 10^9 GeV. The cross-section is
c averaged over all atoms of given medium (see 1c).
c------
c 2e/ real*4 function getcdp(X,Y,lo)
c
c  gives the differential cross-section d_Sigma/d_v for e+e- pair
c  production for given energy X (in GeV, should be within a range of 10
c  -- 10^9 GeV) and  relative energy transfer Y which should be within a
c  range of -11 < log(Y) < 0. If lo=0, natural units are used for Y,
c  otherwise (lo=1) LOG10(Y) should be used at the input. Cross-section
c  values are expressed in cm^2 and is averaged over all atoms of given
c  medium (see (1c)).
c------
c 2f/ real*4 function getdedpa(X)
c
c  gives the energy losses (expressed in MeV/cm if IMED is positive and
c  in MeV g**-1 cm**2 if IMED is negative) for e+e- pair production
c  for interactions with relative energy transfers > EMIN. X is muon
c  energy expressed in GeV and should be within a range of 10 -- 10^9
c  GeV. Can not be applied for TAU-case in this version!
c------
c 2g/ real*4 function gdedpav(X)
c
c  gives the energy losses (expressed in MeV/cm if IMED is positive and
c  in MeV g**-1 cm**2 if IMED is negative) for e+e- pair production
c  for interactions with relative energy transfers > VMIN. X is muon
c  energy expressed in GeV and should be within a range of 10 -- 10^9
c  GeV.
c------
c 2h/ real*4 function gdedpat(X)
c
c  gives the total energy losses (expressed in MeV/cm if IMED is positive
c  and in MeV g**-1 cm**2 if IMED is negative) for e+e- pair production.
c  X is muon energy expressed in GeV and should be within a range of
c  10 -- 10^9 GeV.
c------
c 2i/ subroutine getvpa(X,Y,itr)
c
c  simulates the relative energy transfer Y for e+e- pair production
c  within a range of EMIN -- 1 (if itr = 0) or VMIN -- 1 (otherwise).
c  X is muon energy expressed in GeV and should be within a range of
c  10 GeV < X < 1 EeV.
c------
c 2j/ subroutine testpair(lo)
c
c  performs some test with filling number of histograms and .dat files.
c  The test is short if lo=0. Otherwise it takes more time but gives
c  more statistics. HAS NOT BEEN TESTED COMPLETELY WITH TAU, BE CAREFUL!
c
c                  3. MUON/TAU PHOTONUCLEAR INTERACTION
c                     ---------------------------------
c------
c 3a/ real*4 function getlphnu(X)
c
c gives the average free path (in cm if IMED is positive and in cm w.e.
c if IMED is negative) for photonuclear interaction with energy
c transfers > EMIN.  X is muon energy X (expressed in GeV) and should
c be within a range of 10 -- 10^9 GeV. Can not be applied for TAU-case
c in this version.
c------
c 3b/ real*4 function glphnuv(X)
c
c gives the average free path (in cm if IMED is positive and in cm w.e.
c if IMED is negative) for photonuclear interaction with energy transfers
c > VMIN.  X is muon energy X (expressed in GeV) and should be within a
c range of 10 -- 10^9 GeV.
c------
c 3c/ real*4 function getctph(X)
c
c gives the total cross-section (in cm^2) for photonuc. interaction with
c energy transfers > EMIN. X is muon energy X (expressed in GeV) and
c should be within a range of 10 -- 10^9 GeV. The cross-section is
c averaged over all atoms of given medium (see 1c). Can not be
c applied for TAU-case in this version!
c------
c 3d/ real*4 function gctphv(X)
c
c gives the total cross-section (in cm^2) for photonuc. interaction with
c energy transfers > VMIN. X is muon energy X (expressed in GeV) and
c should be within a range of 10 -- 10^9 GeV. The cross-section is
c averaged over all atoms of given medium (see 1c).
c------
c 3e/ real*4 function getcdn(X,Y,lo)
c
c  gives the differential cross-section d_Sigma/d_v for photonuclear
c  interaction for given energy X (in GeV, should be within a range of 10
c  -- 10^9 GeV) and  relative energy transfer Y which should be within a
c  range of -11 < log(Y) < 0. If lo=0, natural units are used for Y,
c  otherwise (lo=1) LOG10(Y) should be used at the input. Cross-section
c  values are expressed in cm^2 and is averaged over all atoms of given
c  medium (see (1c)).
c  ATTENTION: GETCDN computes diff. cross-sections for all relative ener-
c  gy transfers > 10**(-11). In reality photonuclear cross-section is eq-
c  ual to 0 for transferred energies < 0.5 - 1 GeV. It is taken into ac-
c  count in the frame of MUM code but one should put ones attention on
c  this fact using GETCDN for other purposes.
c------
c 3f/ real*4 function getdedph(X)
c
c  gives the energy losses (expressed in MeV/cm if IMED is positive
c  and in MeV g**-1 cm**2 if IMED is negative) for photonuclear
c  interactions with relative energy transfers > EMIN. X is muon
c  energy expressed in GeV and should be within a range of 10 -- 10^9
c  GeV. Can not be applied for TAU-case in this version!
c------
c 3g/ real*4 function gdedphv(X)
c
c  gives the energy losses (expressed in MeV/cm if IMED is positive
c  and in MeV g**-1 cm**2 if IMED is negative) for photonuclear
c  interactions with relative energy transfers > VMIN. X is muon
c  energy expressed in GeV and should be within a range of 10 -- 10^9
c  GeV.
c------
c 3h/ real*4 function gdedpht(X)
c
c  gives the total energy losses (expressed in MeV/cm if IMED is
c  positive and in MeV g**-1 cm**2 if IMED is negative) for
c  photonuclear interactions. X is muon energy expressed in GeV and
c  should be within a range of 10 -- 10^9 GeV.
c------
c 3i/ subroutine getvph(X,Y,itr)
c
c  simulates the relative energy transfer Y for photonuc. interaction
c  within a range of EMIN -- 1 (if itr=0) or VMIN -- 1 (otherwise).
c  X is muon energy expressed in GeV and should be within a range of
c  10 GeV < X < 1 EeV.
c------
c 3j/ subroutine testphnu(lo)
c
c  performs some test with filling number of histograms and .dat files.
c  The test is relatively short if lo=0. Otherwise it takes more time
c  but gives more statistics. HAS NOT BEEN TESTED COMPLETELY WITH TAU,
c  BE CAREFUL!
c
c                    4. KNOCK-ON ELECTRONS PRODUCTION
c                       ------------------------------
c------
c 4a/ real*4 function getlelec(X)
c
c gives the average free path (in cm if IMED is positive and in cm w.e.
c if IMED is negative) for knock-on electrons production (including
c e-diagrams for bremsstrahlung) with energy transfers > EMIN.  X is
c muon energy X (expressed in GeV) and should be within a range of
c 10 -- 10^9 GeV. Can not be applied for TAU-case in this version.
c------
c 4b/ real*4 function glelecv(X)
c
c gives the average free path (in cm if IMED is positive and in cm w.e.
c if IMED is negative) for knock-on electrons production (including
c e-diagrams for bremsstrahlung) with energy transfers > VMIN.  X is
c muon energy X (expressed in GeV) and should be within a range of
c 10 -- 10^9 GeV.
c------
c 4c/ real*4 function getctel(X)
c
c gives the total cross-section (in cm^2) for knock-on electrons
c production (including e-diagrams for bremsstrahlung) with energy
c transfers > EMIN. X is muon energy X (expressed in GeV) and should be
c within a range of 10 -- 10^9 GeV. The cross-section is  averaged over
c all atoms of given medium (see 1c). Can not be applied for TAU-case in
c this version!
c------
c 4d/ real*4 function gctelv(X)
c
c gives the total cross-section (in cm^2) for knock-on electrons
c production (including e-diagrams for bremsstrahlung) with energy
c transfers > VMIN. X is muon energy X (expressed in GeV) and should be
c within a range of 10 -- 10^9 GeV. The cross-section is  averaged over
c all atoms of given medium (see 1c)
c------
c 4e/ real*4 function getcde(X,Y)
c
c  gives the differential cross-section d_Sigma/d_v for knock-on
c  electrons production (including e-diagrams for bremsstrahlung) for
c  given energy X (in GeV, should be within a range of 10 -- 10^9 GeV)
c  and  relative energy transfer Y which should be within a  range of
c  -11 < log(Y) < 0. Cross-section values values are expressed in cm^2
c  and is averaged over all atoms of given medium (see (1c)).
c------
c 4f/ real*4 function getdedel(X)
c
c  gives the energy losses (expressed in MeV/cm if IMED is positive and
c  in MeV g**-1 cm**2 if IMED is negative) for knock-on electrons
c  production (including e-diagrams for bremsstrahlung) with relative
c  energy transfers > EMIN. X is muon energy expressed in GeV and should
c  be within a range of 10 -- 10^9 GeV. Can not be applied for TAU-case
c  in this version!
c------
c 4g/ real*4 function gdedelv(X)
c
c  gives the energy losses (expressed in MeV/cm if IMED is positive and
c  in MeV g**-1 cm**2 if IMED is negative) for knock-on electrons
c  production (including e-diagrams for bremsstrahlung) with relative
c  energy transfers > VMIN. X is muon energy expressed in GeV and should
c  be within a range of 10 -- 10^9 GeV.
c------
c 4h/ real*4 function gdedelbb(X)
c
c  gives the energy losses (expressed in MeV/cm if IMED is positive and
c  in MeV g**-1 cm**2 if IMED is negative) for ionization (without
c  e-diagrams for bremsstrahlung, only Bethe-Bloch formula) X is muon
c  energy expressed in GeV and should be within a range of 10 -- 10^9 GeV.
c------
c 4i/ real*4 function bebl(X)
c
c  gives the energy losses (expressed in MeV/cm if IMED is positive and
c  in MeV g**-1 cm**2 if IMED is negative) for ionization (without
c  e-diagrams for bremsstrahlung, only Bethe-Bloch formula) X is muon
c  energy expressed in GeV and should be within a range of 0.01 -- 10^9
c  GeV. Works more slow comparing to GDEDELBB function.
c------
c 4j/ real*4 function edbrt(X)
c
c  gives the energy losses (expressed in MeV/cm if IMED is positive and
c  in MeV g**-1 cm**2 if IMED is negative) due to e-diagrams for
c  bremsstrahlung calculated with R.Kokoulin code. X is muon energy
c  expressed in GeV and should be within a range of 0.01 -- 10^9 GeV.
c------
c 4k/ real*4 function gdeion(X)
c
c  gives total energy losses (expressed in MeV/cm if IMED is positive
c  and in MeV g**-1 cm**2 if IMED is negative) for knock-on electrons
c  production (including e-diagrams for bremsstrahlung). X is muon energy
c  expressed in GeV and should be within a range of 160 MeV -- 1 EeV.
c------
c 4l/ subroutine getvel(X,Y,itr)
c
c  simulates the relative energy transfer Y for knock-on electrons
c  production (including e-diagrams for bremsstrahlung) within a
c  range of EMIN -- 1 (itr = 0) or VMIN -- 1 (otherwise). X is muon
c  energy expressed in GeV and should be within a range of 10 GeV < X
c  < 1 EeV.
c------
c 4m/ subroutine testelec(lo)
c
c  performs some test with filling number of histograms and .dat files.
c  The test is short if lo=0. Otherwise it takes more time but gives more
c  statistics. HAS NOT BEEN TESTED COMPLETELY WITH TAU, BE CAREFUL!
c
c                         5. OTHER SUBROUTINES
c                            -----------------
c
c------
c 5a/ subroutine oppaw
c
c  opens HBOOK for filling histograms.
c------
c 5b/ subroutine clpaw
c
c  closes HBOOK and saves histograms.
c------
c 5c/ real*4 function cone(X)
c
c  gives the value for "continuous" energy losses (expressed in MeV/cm
c  if IMED is positive and in MeV g**-1 cm**2 if IMED is negative)
c  for energy transfers below EMIN.  X is muon energy expressed in GeV
c  and should be within a range of 10 GeV -- 1 EeV. Can not be applied
c  for TAU-case in this version.
c------
c 5d/ real*4 function conv(X)
c
c  gives the value for "continuous" energy losses (expressed in MeV/cm
c  if IMED is positive and in MeV g**-1 cm**2 if IMED is negative) for
c  energy transfers below VMIN.  X is muon energy expressed in GeV and
c  should be within a range of 10 GeV -- 1 EeV.
c------
c 5e/ real*4 function gemleng(X)
c
c  gives the value for muon's free path between two interactions with
c  energy transfers > EMIN (in cm if IMED is positive and in cm w.e.
c  if IMED is negative). X is muon energy expressed in GeV and should
c  be within a range of 10 GeV -- 1 EeV. Can not be applied for
c  TAU-case in this version.
c------
c 5f/ real*4 function getlarnv(X,Y)
c
c  gives the real free path (in cm if IMED is positive and in cm w.e.
c  if IMED is negative) of muon without interactions with energy
c  transfers > VMIN if muon energy at the beginning of free path is
c  equal to Y (in GeV, should be within a range of 10 GeV -- 1 EeV)
c  and random Poisson number is X (= -ln(RNDM), where RNDM is a random
c  number uniformly distributed on an interval 0. -- 1.). It takes
c  into account that the value for mean free path is a function of
c  energy and is not equal to a value in a starting point L_mean(Y).
c  The "continuous" energy losses within given free path are calculated
c  by conv(Y) routine (see above), the dependence of these losses of
c  energy is also taken into account. X should be within a range
c  0.0001 - 1000. To be used along with function geteranv(X,Y) in
c  enew[S,3,4](X,Y,iti,itime) subroutines. If final energy after given
c  "free segment" less than 10 GeV, the output means the free path till
c  the point whore muon energy is equal to 10 GeV.
c
c------
c 5g/ real*4 function geteranv(X,Y)
c
c  gives the muon energy (in GeV) at the finish point of real muon
c  free path without interactions with energy transfers > VMIN if
c  muon energy at the beginning of free path is equal to Y (in GeV,
c  should be within a range of 10 GeV -- 1 EeV) and random Poisson
c  number is X (= -ln(RNDM), where RNDM is a random number uniformly
c  distributed on an interval 0. -- 1.). It takes into account that
c  the value for mean free path is a function of energy and is not
c  equal to a value in a starting point L_mean(Y). The "continuous"
c  energy losses within given free path are calculated by conv(Y)
c  routine (see above), the dependence of these losses of energy is
c  also taken into account. X should be within a range 0.0001 - 1000.
c  To be used along with function getlarnv(X,Y) in enew(X,Y,iti,itime)
c  subroutine. If output is less than 10 GeV, it means that the
c  corresponding value of getlarnv(X,Y) with the same X,Y as an
c  input is a free path from starting point till muon energy 10 GeV.
c------
c 5h/ real*4 function geteback(Y,X)
c
c gives the starting muon energy (GeV) if its current energy is equal
c to Y (GeV, should be in a range of 10 GeV -- 1 EeV), the distance
c between current point and starting one is equal to X (cm, should be
c in a range of 1 -- 10^7 cm  if IMED is positive and in cm w.e.,
c should be in a range of 1 -- 10^7 cm w.e. if IMED is negative), and
c there were no interactions with relative energy transfers more than
c VMIN between starting and current points. To be used in
c enew[S,3,4](X,Y,iti,itime) subroutines.
c------
c 5i/ real*4 function enew(e,depth,iti,itime)
c
c Simulates the final energy of muon which started with energy E (GeV,
c should be within a range of 0.16 GeV -- 1 EeV) and has passed distance
c DEPTH (cm, should be in a range of 1 -- 10^7 cm if IMED is positive and
c cm w.e., 1 - 10^7 cmw.e., if IMED is negative) in the given medium.
c If the final energy is less than 0.16 GeV (muon/tau stopped before
c passing DEPTH) the output is equal to 0.01 GeV. The procedure gives
c also some "history" of simulation which is kept by arrays ityp(10000),
c eleng(10000), ener1(10000),ener2(10000) and constant NUMB. All this is
c passed via common/VHISTORY/ and may be used after the simulation for
c given muon is completed. Normally INTEGER ITI variable is equal to 0.
c At the muon propagation it is dummy variable and its value does not
c play any role. When propagating tau leptons ITI = 1 leads to
c neglecting tau energy losses (only decay process is taken into account).
c INTEGER variable ITIME is a dummy variable in case of muon. For tau-
c leptons its meaning is as follows: ITIME < 0 means that propagation
c of tau is simulated from the neutrino CC interaction vertex where tau
c was born. Its time of life is counted from this moment. If ITIME > 0
c time is counted from a non-zero moment which is determined by REAL*8
c variable TTAUIN (common /TIMETAU/). If tau-lepton reaches the level
c of observation (DEPTH) and has not decayed the rest of life time
c TTAUOUT (common /TIMETAU/) can be used to propagate tau-lepton through
c other medium (if tau has decayed before reaching the level of
c observation TTAUOUT=-1.). Inside the code generated or incoming life
c time is multiplied by density of medium if IMED is negative (e.g., by
c 2.65 g/cm**3 if IMED=-2) and TTIMEOUT variable is divided by density in
c this case. Integer variable MODE in COMMON /TAU_DECAY/ can be used to
c generate tau-lepton decay (energy and momenta of secondaries) using
c TAUOLA package [S.Jadach et al., Comput.Phys.Commun. 64, 275 (1991)]
c after execution of ENEW routine. MODE means tau-lepton decay mode
c (see subroutine PREPARE_DECAY for more details) as it is used inside
c TAUOLA library v2.6 (22 possible modes in total) and is kept both in
c case when tau-lepton decays before reaching the level of observation
c and in case when tau reaches level of observation without decay. Below
c one can find a simple example of code to simulate tau-lepton
c propagation with initial energy of 10^7 GeV consequently through 1 km
c of standard rock and 0.1 km of water:
c
***********************************************************************
*      real*8 ttauin,ttauout
*      real*8 ttauinS,ttauoutS
*      real*8 TIME_L_T
*      integer MODE
*      common /timetau/ ttauin,ttauout    ! <- common from ENEW routine
*      common /timetauS/ ttauinS,ttauoutS ! <- common from ENEWS routine
*      COMMON /TAU_DECAY/ TIME_L_T,MODE
*
*             DEFINITION OF INPUT PARAMETERS FOR INITIATION
*                      AND INITIATION OF 2 MEDIA:
*
*      iti = 0
*      ipn = 1
*      ibre = 1
*      em = 0.01
*      vm = 0.01
*      iqcd = 1
*      lux = 2
*      imed = 2
*      ilep = 2
*      iseed = -1
*      call init_mu(imed,ipn,ibre,em,vm,ilep,iqcd,lux, iseed)
*      imed = 6
*      call init_muS(imed,ipn,ibre,em,vm,ilep,iqcd,lux)
*
*   INITIAL TAU-LEPTON ENERGY AND THICKNESS OF ROCK AND WATER:
*
*      en = 1.e+7
*      depth1 = 1.e+5
*      depth2 = 1.e+4
*
*   SIMULATION OF PROPAGATION OF NUMBER_OF_TAUS TAU-LEPTONS, FOR EACH
*               TAU THE FINAL ENERGY IS EQUAL TO E2:
*
*      do i=1,NUMBER_OF_TAUS
*        itime = -1
*        e1 = enew(en,depth1,iti,itime)
*          if(e1.ge.0.1) then
*            itime = 1
*            ttauinS = ttauout
*            e2 = enewS(e1,depth1,iti,itime)
*          else
*            e2 = e1
*          endif
*      enddo
*
*   PRINTING THE REST OF TAU-LEPTON LIFE TIME AND DECAY MODE:
*
*      print*,'Rest of time (s): ',ttauoutS,' Decay mode: ',MODE
*
*      stop
*      end
***********************************************************************
c         PLEASE NOTE THAT IN ROUTINES WHICH CALL ENEW
c       (SIMULDE(S,3,4), SPECDEPT, TESTCOM AND TESTFINAL)
c                 ITIME IS ALWAYS SET TO -1
c       *************************************************
c
c                DESCRIPTION OF COMMON /VHISTORY/:
c
c NUMB (integer*4) is equal to number of interaction which occurred
c                  during simulation for given muon
c
c ITYP(i) (integer*4) gives the type of interaction nb. i which may
c                     be as follows:
c
c 0 - start of simulation
c 1 - muon has reached the DEPTH (which is input variable for ENEW)
c 2 - muon has stopped (its energy became less than 0.16 GeV)
c 3 - muon energy has decreased down to 10 GeV
c 4 - bremsstrahlung interactions occurred
c 5 - e+e- pair has been born
c 6 - photonuclear interaction occurred
c 7 - knock-on electron has been born (or bremsstrahlung interaction
c     with emmiting gamma by electron occurred)
c 8 - at this point lepton has decayed (for tau-lepton only)
c
c ELENG(i) (real*4) - distance (cm if IMED is positive and cmw.e. if
c                     IMED is negative) from the beginning of simulation
c                     till interaction nb. i
c
c ENER1(i) (real*4) - energy (GeV) before interaction nb. i ! For ityp=
c                                                           !  0,1,2,3
c ENER2(i) (real*4) - energy (GeV) after interaction nb. i  ! it is the
c                                                           !    same
c
c NB. Be sure to provide with separate commons /vhistoryS/ (/vhistory3/,
c     /vhistory4/), /TIMETAUS/, /TIMETAU3/, /TIMETAU4/, /TAU_DECAYS/,
c     /TAU_DECAY3/, /TAU_DECAY4/, and variables numbS (numb3, numb4),
c     itypS(10000), (ityp3(10000), ityp4(10000)), elengS(10000)
c     (eleng3(10000), eleng4(10000)), ener1S(10000) (ener13(10000),
c     ener14(10000)), ener2S(10000) (ener23(10000), ener24(10000)),
c     ttauinS (ttauin3, ttauin4), ttauoutS (ttauout3, ttauout4),
c     MODES (MODE3,MODE4) when initiating and using the 2nd (3rd, 4th)
c     medium. This routine is called, respectively, enewS, enew3, enew4
c     for other media.
c
c------
c 5j/ subroutine simulde(ndepths,emu0)
c
c The subroutine gives the muon/tau energy at a set of depths consisting
* of NDEPTHS levels of observation if its level at the DEPTH=0 is equal
* to EMU0 (GeV). EMU0 should be in a range of 0.16 GeV - 1 EeV. The
c subroutine uses function ENEW which gives a "muon history" during its
c travel through a media (see comments to ENEW routine). User has to:
c
c  1. Give lines
c                  ...
c       common /frouser1/ horison(1000)
c       common /touser1/ emuon(1000)
c                  ...
c
c    in a program unit from which SIMULDE is called.
c
c  2. Define integer variable 0 < NDEPTHS <= 1000 in that program unit.
c
c  3. Prepare there a real*4 array HORISON(1000) which contains up to
c     1000 levels of observation. The rules for HORISON are as follows:
c
c     - levels of observation should be expressed in cm if IMED is
c       positive and in cm w.e. if IMED is negative;
c     - they should be more than 0. and not greater than 10^7;
c     - they should follow in increasing order along array.
c
c    SIMULDE references only first NDEPTHS elements of HORISON(1000), so
c    one should take care about them, it does not a matter what will be
c    HORISON(NDEPTHS+1),HORISON(NDEPTHS+2),HORISON(NDEPTHS+3), etc.
c
c   INPUT: EMU0    - energy (GeV) at the depth = 0. !-> subroutine
c          NDEPTHS - number of observation levels   !   parameters
c          -----------------------------------------
c          HORISON(1000) - an array containing      !-> prepared
c                          levels of observation  ! by user and passed
c                                              ! to SIMULDE via common
c                                            !      /frouser1/
c
c   OUTPUT: array EMUON(1000) whose first NDEPTHS elements are muon/tau
c           energies (GeV) at given level of observation as a result of
c           MC simulation which is performed by ENEW routine. Array is
c           returned to user by common /touser1/.
c
c NB1. Be sure to provide with separate common blocks and variables
c      whose names are terminated by an additional "S", "3", and "4"
c      (e.g., horisonS, horison3, horison4) when initiating and using
c      the 2nd, 3rd and 4th  media (see NB to routine ENEW above. This
c      routine is called "simuldeS", "simulde3", "simulde4" for other
c      media.
c
c NB2. ENEW routine is used as a basis of SIMULDE. When working with
c      tau-leptons ITI variables is always set to 0 (processing both
c      tau interactions and tau decay).
c------
c 5k/  subroutine earray1(e,depth)
c
c   Simulates the passage of muon through an array at the distance
c   DEPTH (cm) if initial muon energy is equal to E (GeV). Uses a model
c   in which energy losses are divided into 2 part: "continuous" losses
c   with energy transfers < EMIN and "catastrophic" losses with energy
c   transfers > EMIN.
c
c                             OUTPUT:
c                             =======
c
c The procedure provides with "history" of simulation which is kept by
c arrays ityp_e(20000), eleng_e(20000), ener1_e(20000),ener2_e(20000)
c and constant NUMB_E. All this is passed via common/EHISTORY/ to program
c block from which EARRAY1 was called. This block must contain the
c following lines:
c
c                             .....
c       real*8 ener1_e(20000), ener2_e(20000)
c       dimension ityp_e(20000),eleng_e(20000),etr(20000)
c       common /ehistory/ eleng_e,ener1_e,ener2_e,etr,numb_e,ityp_e
c                            .....
c
c
c         DESCRIPTION OF CONSTANTS AND ARRAYS OF COMMON /EHISTORY/ :
c
c NUMB_E (integer*4) is equal to number of interaction which occurred
c                    during simulation for given muon
c
c ITYP_E(i) (integer*4) gives the type of interaction nb. i which may
c                       be as follows:
c
c  0 - start of simulation
c  1 - muon has reached the DEPTH
c  2 - muon has stopped (its energy became less than 0.16 GeV)
c  4 - bremsstrahlung interactions occurred
c  5 - e+e- pair has been born
c  6 - photonuclear interaction occurred
c  7 - knock-on electron has been born (or bremsstrahlung interaction
c      with emmiting gamma by electron occurred)
c
c  ELENG_E(i) (real*4) - distance (cm) from the beginning of simulation
c                        till interaction nb. i
c
c  ENER1_E(i) (real*8) - energy (GeV) before interaction nb. i ! For ityp=
c                                                              !  0,1,2,3
c  ENER2_E(i) (real*8) - energy (GeV) after interaction nb. i  ! it is the
c                                                              !    same
c  ETR(i) (real*4) - energy transfer due to interaction nb.i (GeV), is
c                    assigned by 0. if ITYP_E < 4
c
c     DEPTH should not be more than 50 km, E should be within a range
c                          10 GeV - 1 EeV.
c
c
c  NB: It is not recommended to use this routine when initialization has
c      been done with negative IMED. So, DEPTH variable is always
c      expressed in [cm].
c
c         ************************************************
c         Can not be applied for TAU-case in this version
c         ************************************************
c------
c 5l/ subroutine earray2(e,en,etr,path,jtyp)
c
c Simulates "the next" interaction for a muon which passes an array if
c muon energy is equal to E (GeV). Uses a model in which  energy losses
c are divided into 2 part: "continuous" losses with energy transfers <
c EMIN and  "catastrophic" losses with energy transfers > EMIN.
c
c                             INPUT:
c                             ======
c  E which is muon energy expressed in Gev (it should be less than 1 EeV)
c
c                             OUTPUT:
c                             =======
c
c  EN - the muon energy after the next interaction (including   !-> REAL*8
c       "continuous losses" till the point of interaction)      !
c  ETR - energy transfer (GeV) due to "next" interaction           ! REAL*4
c  PATH - distance from initial point to the next interaction (cm) !
c  INTEGER*4 JTYP - type of interaction which may be as follows:
c
c  2 - muon has stopped (its energy became 0.16 GeV)
c  4 - bremsstrahlung interactions occurred
c  5 - e+e- pair has been born
c  6 - photonuclear interaction occurred
c  7 - knock-on electron has been born (or bremsstrahlung interaction
c      with emmiting gamma by electron occurred)
c
c If initial energy is less than 0.16 GeV, EN is assigned by a value of
c                             0.01 GeV
c
c  NB: It is not recommended to use this routine when initialization has
c      been done with negative IMED. So, DEPTH variable is always
c      expressed in [cm].
c
c         ************************************************
c         Can not be applied for TAU-case in this version
c         ************************************************
c------
c 5m/ subroutine bkns(empow,e1)
c
c Simulates the vertical muon spectrum at the see level according to
c BUGAEV-KLIMUSHIN fit of NAUMOV-SINEGOVSKY spectrum. Input: empow = lower
c cut energy for muon (lower energy for simulated spectrum), GeV. Output:
c e1 = simulated muon energy, GeV. EMPOW must be in a range of 100 GeV
c -- 50 TeV to obtain a reasonable output. Can not be applied for TAU-case.
c------
c 5n/ subroutine gais(empow,e1)
c
c Simulates the vertical muon spectrum at the see level according to
c Gaisser spectrum. Input: empow = lower cut energy for muon (lower energy
c for simulated spectrum), GeV. Output: e1 = simulated muon energy, GeV.
c EMPOW must be in a range of 100 GeV -- 50 TeV to obtain a reasonable
c output. Can not be applied for TAU-case.
c------
c 5o/ subroutine specdept(depth,is,ihist,numb)
c
c This subroutine simulates muon vertical spectrum at the depth = DEPTH
c starting with Bugaev-Klimushin-Naumov-Sinegovski (IS=1) or Gaisser
c (IS=2) vertical spectrum at see level. The DEPTH should be expressed
c in cm and corresponds to not less than 600 m.w.e. and not more than
c 20000 m.w.e. For 11 threshold energies (array ETH(11)) the absolute
c values for vertical flux I(E_mu > ETH) (array FLUX(11),
c sm^-2 sr^-1 sec^-1) and mean energy (EMEAN(11), GeV) are computed.
c Arrays SRFLUX(11) and EMERR(11) contain values of statistical errors
c (in corresponding units, at 1-sigma level) for FLUX(11) and EMEAN(11).
c The number of muons in depth spectrum which should be simulated is given
c by variable NUMB. That means that simulation will continue until NUMB
c muons have been detected with energy > ETH(11) at given depth.
c Histograms are filled if variable IHIST=1. If IHIST=0 histograms are not
c filled (it saves ~10% of time but gives much less information).
c Subroutine informs user by a screen output after every (0.05*NUMB)nd
c muon has reached the depth.
c
c User does not need to think about lower cut for muon energy at surface,
c SPECDEPT computes it itself quite reliable for each given depth and
c medium.
c
c                            User has to:
c
c  1. Give lines
c
c                  ...
c        common /frouser2/ eth(11)
c        common /touser2/ emean(11),emerr(11),flux(11),erflux(11)
c                  ...
c
c    in a program unit from which SPECDEPT is called.
c
c  2. Define real*4 array ETH(11) with threshold energies (in GeV) in
c     that program unit. Note that in the frame of MUM code muon is
c     considered as stopped if its energy becomes less than 0.16 GeV.
c     In this case its energy is assigned by "fake" value of 0.01 GeV
c     (see comments to ENEW routine). So, the lowest threshold should
c     not be less than 0.01 GeV. It is recommended to set it to 0.02
c     GeV to obtain integrated flux and mean energy for the whole depth
c     spectrum E_mu > 0. ETH(i) should be in a reasonable range 0.02 -
c     100 GeV.
c
c INPUT: real*4 DEPTH - depth (cm) at which depth spectrum !-> subroutine
c                       is simulated and fluxes + mean     !   parameters
c                       energies are computed              !
c       integer IS - type of vertical muon spectrum at sea !
c                    level (IS = 1 - Bugaev-Klimushin-Na-  !
c                    umov-Sinegovsky ; IS = 2 - Gaisser)   !
c       integer IHIST - Histograms are filled if IHIST=1   !
c                       and are not filled if IHIST=0      !
c       integer NUMB - desirable number of muons with      !
c                      energy > ETH(11) at given depth     !
c       ....................................................
c       real*4 ETH(11) - set of energy thresholds (GeV)    !-> should be
c                        above which fluxes and mean       ! prepared by
c                        energies are computed at given    ! user and pas-
c                        depth                             ! sed to SPECDEPT
c                                                          ! via common
c                                                          ! /frouser2/
c ----------------------------------------------------------
c OUTPUT: real*4 FLUX(11) - set of integrated fluxes at    !-> returned to
c                           given depth with thresholds    ! user as a result
c                           from ETH(11), cm^-2sr^-1s^-1   ! of SPECDEPT via
c         real*4 ERFLUX(11) - set of statistical errors for!  common block
c                             FLUX(11) (in the same units, !   /touser2/
c                             1-sigma level)               !
c         real*4 EMEAN(11) - set of mean energies for muons!
c                            with energies > ETH(xx) which !
c                            are detected at given depth,  !
c                            GeV                           !
c         real*4 EMERR(11) - statistical errors (GeV,      !
c                            1-sigma level) for EMEAN(11)  !
c ----------------------------------------------------------
c         LIST OF HISTOGRAMS (WHICH ARE FILLED IF IHIST=1) :
c
c           ID                                 DESCRIPTION
c
c  INT(depth*0.0001) + 10000   Simulated muon spectrum at see level
c
c  INT(depth*0.0001) + 11000   Simulated muon spectrum at the depth=DEPTH
c
c  INT(depth*0.0001) + 11000 + Simulated muon spectrum to which surface
c     + 100000*(depth*k/10)     spectrum transforms for 10 intermediate
c          where k=1,10                         depths
c
c NOTES: IF ONE CALLS SPECDEPT SEVERAL TIMES THE DIFFERENCE BETWEEN
c        DEPTH variables should exceed 10 meters, otherwise some part of
c        histograms will be rewritten and lost
c
c        User should watch oneself for ID of ones own HBOOK histograms,
c        ID should not crossed
c
c        In principle this routine may be called after initialization
c        with negative IMED. In this case input variable DEPTH must be
c        expressed in cm w.e. But it makes no sense and this way has
c        not been tested.
c
c                    Can not be applied for TAU-case.
c------
c 5p/ subroutine testcom - some general tests (see comments there).
c     Produces some histograms and .dat files. Has not been tested
c     completely for TAU-case.
c
c------
c 5q/ subroutine testfinal - the comparison between incoming model for
c     the muon energy loss and SIMULATED muon energy loss (unfortunately,
c     is not commented enough - see hep-ph/0010322 for the details).
c     CAN NOT BE USED FOR TAU CASE IN THIS VERSION.
c
c------
c 5r/ function rndm_mum(IFAKE) - gives the REAL*4 random number (has been
c     written on the base of RANLUX - a random generator from the CERN
c     library). INTEGER IFAKE is a dummy parameter, it does not matter
c     what to put there.
c
c------
c 5s/ SUBROUTINE GETSEED(IRANSEED1,IRANSEED2) - gives initial 32 bit
c     integers IRANSEED1 and IRANSEED2  for REAL*4 and REAL*8 random
c     generators. Routine has been written on the base of DATIME routine
c     (CERN library) which gives current date. After transformation it
c     produces 2 integer numbers that are always different.
c
**************************************************************************
c           =================================================
c           =             The code (version 1.2)            =
c           =       has been successfully tested under:     =
c           =                                               =
c           =   LINUX (pcbai2.inr.ruhep.ru)                 =
c           =   HP-UX (paris.ifh.de and hpbai1.ifh.de)      =
c           =   IRIX64 (hydra.ifh.de)                       =
c           =   SunOS (proton.jinr.ru)                      =
c           =                                               =
c           = Version 1.3 has been tested under LINUX only  =
c           = Version 1.4 has been tested under LINUX only  =
c           = Version 1.5 has been tested under LINUX only  =
c           = Version 1.6 has been tested under LINUX only  =
c           =================================================
c
************************************************************************
********    F U N C T I O N S   A N D   S U B R O U T I N E S   ********
************************************************************************
*                                                                      *
************************************************************************
************************** COMMON SUBROUTINES : ************************
************************************************************************
* C.1
          SUBROUTINE init_mu(imed,ipn,ibre,em,vm,ilep,iqcd,lux,iseed)
*
* It initializes some routines which produce the splain coefficients for
* further simulations of muon energy losses by different processes. For
* more details see comments to subroutines which referenced below in the
* body of routine.
*.......................................................................
      real*8 rvec(1)
      real*8 rreal8(15000000)
c
      real*4 rreal4(15000000)
      real*4 v(13)
      real*4 em,vm,em1,vm1
      real*4 TLIM,T
c
      integer imed,imed1,ipn,ibre,ilep,iqcd,lux,iseed
      integer iseed_r,index_rndm4,index_rndm8
      integer ISL(40),ID,IH
      integer i_stat(6)
      integer ist(4)
c
      character*10 chm
      character *38 mum_card_name
      character *4 yyyy
      character *2 mm
      character *2 dd
      character *2 hh
      character *2 mi
      character *2 ss
c
      data v /5.3e-3,1.5e-2,4.9e-3,5.6e-3,5.7e-3,5.7e-3,2.0e-2,
     +        2.3e-2,1.8e-2,1.4e-2,1.1e-2,2.0e-2,2.0e-2/
c
      common /r48/ rvec
      COMMON /SLATE/ ISL
      COMMON /VERSION/ iver
      COMMON /RNDM1/ iseed_r,index_rndm4,index_rndm8
      COMMON /RNDM2/ rreal8
      COMMON /RNDM3/ rreal4
      common /card_name/ mum_card_name
      common /statistic/ i_stat
      common /init_calls/ ist
c
      TLIM = 3.0e+8
      CALL TIMEST(TLIM)
c
      CALL TIMEX(T)
      if(T.le.0.1) then
         do i=1,6
            i_stat(i) = 0
         enddo
         do i=1,4
            ist(i) = 0
         enddo
      endif
      ist(1) = ist(1) + 1
c
c Asking for data and time, making the card file name:
c
      if (ist(1).eq.1) then
         CALL DATIME(ID,IH)
         call ST4_INT_CHAR(isl(1),yyyy)
         call ST2_INT_CHAR(isl(2),mm)
         call ST2_INT_CHAR(isl(3),dd)
         call ST2_INT_CHAR(isl(4),hh)
         call ST2_INT_CHAR(isl(5),mi)
         call ST2_INT_CHAR(isl(6),ss)
c
         chm='0123456789'
         if(ISL(2).eq.1)  chm='  January '
         if(ISL(2).eq.2)  chm=' February '
         if(ISL(2).eq.3)  chm='    March '
         if(ISL(2).eq.4)  chm='    April '
         if(ISL(2).eq.5)  chm='      May '
         if(ISL(2).eq.6)  chm='     June '
         if(ISL(2).eq.7)  chm='     July '
         if(ISL(2).eq.8)  chm='   August '
         if(ISL(2).eq.9)  chm='September '
         if(ISL(2).eq.10) chm='  October '
         if(ISL(2).eq.11) chm=' November '
         if(ISL(2).eq.12) chm=' December '
c
      mum_card_name='cards/mum_run_'//yyyy//'_'//mm//'-'//dd//'_'//hh//
     +'-'//mi//'-'//ss//'.card'
      endif
c
c Opening card file for writing, making the first record (data and time):
c
      open(23,file=mum_card_name, status='unknown', access='append',
     +form='formatted')
c
      if (ist(1).eq.1) then
         write(23,503) chm,ISL(3),ISL(1),ISL(4),ISL(5),ISL(6)
         write(23,*) ' '
      endif
c
      iver = 6
      len = 1
c
c Some screen output:
c
      write(23,*) 'Module initialized             : INIT_MU'
c
      if (ist(1).eq.1) then
         write(*,*) ' '
         write(*,*) '=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-='
         write(*,501) chm,ISL(3),ISL(1),ISL(4),ISL(5),ISL(6)
         write(*,*) ' '
         write(*,*) '        Code MUM (MUons + Medium)'
         write(*,*) ' '
         write(*,*) '      Version 1.6  (April 16, 2003)'
         write(*,*) '=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-='
         write(*,*) ' '
      endif
      write(*,*) 'Initialization: INIT_MU...'
c
c Checking (and changing if needed) the LUX variable for
c real*4 RN generator:
c
      if(iseed.ne.0) then
      if((lux.lt.0).or.(lux.gt.4)) then
        lux = 2
        write(*,508) lux
        write(*,*) ' '
      endif
      endif
c
c Initializing RN generators:
c
       iseed_r = iseed
       if (iseed_r.lt.0) then
         CALL GETSEED(IRANSEED1,IRANSEED2)
         write(23,509) iseed_r
         write(23,510) IRANSEED2
         write(23,511) IRANSEED1
         call rm48in(IRANSEED1,0,0)
         call RLUXGO(LUX,IRANSEED2,0,0)
       else
         if (iseed_r.gt.0) then
           write(23,512) iseed_r
           write(23,510) iseed_r
           write(23,511) iseed_r
           call rm48in(iseed,0,0)
           call RLUXGO(LUX,iseed,0,0)
         else
           write(23,513) iseed_r
           open(13,file='../../rndm_data/rndm4.dat',
     *             status='old',form='formatted')
           open(14,file='../../rndm_data/rndm8.dat',
     *             status='old',form='formatted')
           do i=1,15000000
           read(13,333) rreal4(i)
           read(14,444) rreal8(i)
           enddo
           index_rndm4 = 0
           index_rndm8 = 0
           close (14)
           close (13)
         endif
       endif
c
c Checking (and changing if needed) variables IMED, EM AND VM:
c
c     IMED:
c
      if(imed.eq.0) then
         imed1 = 1
         write(*,505)  imed1
         write(*,*) ' '
      else
         if(imed.gt.0) then
            if(imed.gt.13) then
               imed1 = 1
               write(*,505)  imed1
               write(*,*) ' '
            else
               imed1 = imed
            endif
         else
            if(imed.lt.-13) then
               imed1 = -1
               write(*,505)  imed1
               write(*,*) ' '
            else
               imed1 = imed
            endif
         endif
      endif
c
c     EM:
c
      if(em.gt.0.5) then
         em1 = 0.5
         write(*,504)  em1
         write(*,*) ' '
      else
         if(em.lt.0.01) then
            em1 = 0.01
            write(*,504) em1
            write(*,*) ' '
         else
            em1 = em
         endif
      endif
c
c     VM:
c
      if(ilep.eq.1) then
         if(vm.lt.0.0001) then
             vm1 = 0.0001
             write(*,502)  vm1
             write(*,*) ' '
         else
             if(vm.gt.0.2) then
                vm1 = 0.2
                write(*,502)  vm1
                write(*,*) ' '
             else
                vm1 = vm
             endif
         endif
      else
         if(imed1.gt.0) then
            if(vm.ge.v(imed1)) then
               vm1 = v(imed1)
               write(*,502)  vm1
               write(*,*) ' '
            else
               if(vm.lt.0.0001) then
                  vm1 = 0.0001
                  write(*,502)  vm1
                  write(*,*) ' '
               else
                  vm1 = vm
               endif
            endif
         else
            if(vm.ge.4.e-3) then
               vm1 = 4.e-3
               write(*,502)  vm1
               write(*,*) ' '
            else
               if(vm.lt.0.0001) then
                  vm1 = 0.0001
                  write(*,502)  vm1
                  write(*,*) ' '
               else
                  vm1 = vm
               endif
            endif
         endif
      endif
c
c Making media, setting parameters:
c
      call med_cons(imed1,ipn,ibre,em1,vm1,ilep,iqcd)
      CALL PREPARE_DECAY
c
c Computing bremsstrahlung: energy losses, cross-sections,
c constants for comparison function etc.:
c
      call gamma1
c
c Computing e+e- pair production: energy losses, cross-sections,
c comparison function and its integral etc:
c
      call pair1
c
c Computing photonuclear interaction: energy losses, cross-sections,
c etc.:
c
      if(iqcd.eq.1) call QCD_CORR
      call phnu1
c
c Computing D-electrons production: energy losses, cross-sections, etc.:
c
      call elec1
c
c Computing continuous energy losses:
c
      call enlos
c
c Cooking 1-dimensional real*4 splines with equidistant grid:
c
      call spl1
c
c Ccooking 1-dimensional real*8 splines with equidistant grid:
c
      call dspl1
c
c Cooking 1-dimensional real*8 splines with non-equidistant grid:
c
      call dsplq1
c
c Cooking 2-dimensional real*4 splines with equidistant grid:
c
      call spl2
c
c Cooking different kinds of splines:
c
      call frepathv
      call spl2_2
c
c Recording to the MUM run card:
c
      call prinfo(imed1,ipn,ibre,em1,vm1,ilep,iqcd)
c
      close (23)
c
      return
c
  333 format (e14.8)
  444 format (d23.17)
  501 format ('      ',A11,I3,',',I5,',',I3,':',I2,':',I2)
  503 format
     + (' Starting to run on',A11,I3,',',I5,' at',I3,':',I2,':',I2)
  502 format (' !!! Variable Vcut out of range, has been changed for Vcu
     +t = ',f6.4,' !!!')
  504 format (' !!! Variable Ecut out of range, has been changed for Ecu
     +t = ',f6.4,' !!!')
  505 format (' !!! Variable IMED out of range, has been changed for IME
     +D = ',I3,' !!!')
  508 format (' !!! Variable LUX for random generator out of range, has
     +been changed for ',i1, ' !!!')
  509 format (' RN generators initialization   : with quasi-random seeds
     + (iseed = ',i8,')')
  510 format (' Seed for REAL*4 RN generator   : ',i30)
  511 format (' Seed for REAL*8 RN generator   : ',i30)
  512 format (' RN generators initialization   : seeds provided by user
     +(iseed =  ',i8,')')
  513 format (' Pseudorandom numbers           : taken from files (iseed
     + =  ',i2,')')
c
      end
c---------------------------------------------------------------------------
* C.1a
      subroutine prinfo(imed,ipn,ibre,em,vm,ilep,iqcd)
*
*        MAKING MUM RUN CARD
*
      real*8 alfa,rm_e,rm_mu,r_e,z1(10),w(10),aw(10),n(10)
      real*8 a_ef,avog,ro
      real*8 z_a,ri_z,x_0,x_1,a,rm
      real*4 em,vm
      integer imed,ipn,ibre,ilep,iqcd
      integer nsub
      character *38 mum_card_name
c
      common /const/ alfa,rm_e,rm_mu,r_e,avog
      common /media/ z1,w,aw,a_ef,ro,nsub
      common /med_ion/ z_a,ri_z,x_0,x_1,a,rm
      common /toprint/ n
      common /exer1/ fa
      common /exer2/ noca
      common /card_name/ mum_card_name
c
      open(23,file=mum_card_name, status='unknown', access='append',
     +form='formatted')
c
      if (ilep.eq.1) then
         write(23,501) ilep
      else
         write(23,502) ilep
      endif
c
      if (abs(imed).eq.1) write(23,601) imed
      if (abs(imed).eq.2) write(23,602) imed
      if (abs(imed).eq.3) write(23,603) imed
      if (abs(imed).eq.4) write(23,604) imed
      if (abs(imed).eq.5) write(23,605) imed
      if (abs(imed).eq.6) write(23,606) imed
      if (abs(imed).eq.7) write(23,607) imed
      if (abs(imed).eq.8) write(23,608) imed
      if (abs(imed).eq.9) write(23,609) imed
      if (abs(imed).eq.10) write(23,610) imed
      if (abs(imed).eq.11) write(23,611) imed
      if (abs(imed).eq.12) write(23,612) imed
      if (abs(imed).eq.13) write(23,613) imed
c
      if(imed.gt.0) then
      write(23,*)
     + 'Distance expressed in          : cm (IMED is positive)'
      else
      write(23,*)
     + 'Distance expressed in          : g/cm**3 (IMED is negative)'
      endif
c
      write(23,503) em
      write(23,504) vm
c
      write(23,*) 'Cross-section for absorption'
      if (ipn.eq.1) then
          write(23,505) ipn
      else
          write(23,506) ipn
      endif
c
      write(23,*) 'QCD corrections by'
      if (iqcd.eq.1) then
         write(23,507) iqcd
      else
         write(23,508) iqcd
      endif
c
      if(ibre.eq.1) then
         write(23,509) ibre
      endif
      if(ibre.eq.2) then
         write(23,514) ibre
      endif
      if((ibre.ne.1).AND.(ibre.ne.2)) then
         write(23,510) ibre
      endif
c
      write(23,*)
     + 'Knock-on electrons are'
      write(23,*)
     + 'included in catastrophic'
      if (noca.ne.0) then
         write(23,512) noca
      else
         write(23,513) noca
      endif
c
      if ((fa.lt..99999).or.(fa.gt.1.0001)) then
      write(23,*)
     + 'ATTENTION! RUNNING IN SPECIAL'
      write(23,*)
     + 'MODE: ALL CROSSSECTIONS ARE'
      write(23,511) fa
      endif
c
      write(23,*) '====='
      write(23,*) ' '
c
      close (23)
c
      return
c
  501 format (' Particle                       : MUON (ILEP = ',i1,')')
  502 format (' Particle                       : TAU (ILEP = ',i4,')')
  503 format (' Ecut                           : ',f8.6,' GeV')
  504 format (' Vcut                           : ',f8.6)
  505 format (' of a real photon               : by Bugaev-Bezrukov (ipn
     + = ',i4,')')
  506 format (' of a real photon               : by ZEUS (ipn = ',
     +i4,')')
  507 format (' Bugaev-Shlepin                 : YES (iqcd = ',i1,')')
  508 format (' Bugaev-Shlepin                 : NO (iqcd = ',i4,')')
  509 format (' Bremsstrahlung cross-sections  : by Andreev-Bezrukov-Bug
     +aev (ibre = ',i1,')')
  510 format (' Bremsstrahlung cross-sections  : by Kelner-Kokoulin (GEA
     +NT4.0) (ibre = ',i1,')')
  514 format (' Bremsstrahlung cross-sections  : by Sandrock (ibre = ',
     + i1,')')
  511 format (' MULTIPLIED BY FACTOR           : ',f8.6)
  512 format (' losses (recommended)           : YES (noca = ',i5,')')
  513 format (' losses                         : NO (noca = ',i5,')')
  601 format (' Medium                         : PURE WATER (imed = ',
     +i2,')')
  602 format (' Medium                         : STANDARD ROCK (imed = '
     +,i2,')')
  603 format (' Medium                         : ANTARCTIC ICE (imed = '
     +,i2,')')
  604 format  (' Medium                         : SEAWATER PACIFIC (imed
     + = ',i2,')')
  605 format (' Medium                         : SEAWATER ANTARES D<2126
     +m (imed = ',i2,')')
  606 format (' Medium                         : SEAWATER ANTARES D>2126
     +m (imed = ',i2,')')
  607 format    (' Medium                         : GRAN SASSO ROCK (ime
     +d = ',i2,')')
  608 format  (' Medium                         : BAIKAL BASIS ROCK (ime
     +d = ',i2,')')
  609 format (' Medium                         : BAIKAL TANKHOY ROCK (im
     +ed = ',i2,')')
  610 format   (' Medium                         : BAIKAL ANOS ROCK (ime
     +d = ',i3,')')
  611 format (' Medium                         : BAIKAL GROUND (SILT) (i
     +med = ',i3,')')
  612 format (' Medium                         : FREJUS ROCK (SINGLE MED
     +IUM) (imed = ',i3,')')
  613 format (' Medium                         : FREJUS ROCK (COMPOSED M
     +EDIUM) (imed = ',i3,')')
c
      end
****************************************************************************
* C.2
       subroutine med_cons(imed,ipn,ibre,em,vm,ilep,iqcd)
*
*      This subroutine sets the universal constants and prepares a medium
*                           for further computing
*  .........................................................................
       real*8 alfa,rm_e,rm_mu,r_e,z1(10),w(10),aw(10),n(10)
       real*8 ntot,a_ef,avog,ro,zmean
       real*8 z_a,ri_z,x_0,x_1,a,rm
       real*8 tlife
       real*4 em,vm
       integer imed,ipn,ibre,ilep,iqcd
       integer nsub
       integer iqcd1
       common /qcd/ iqcd1
       common /const/ alfa,rm_e,rm_mu,r_e,avog
       common /what_lep/ kindlept
       common /const_t/ tlife
       common /media/ z1,w,aw,a_ef,ro,nsub
       common /med_ion/ z_a,ri_z,x_0,x_1,a,rm
       common /general/ emin,vmin,emph
       common /mcef/ mcb1,mcb2,mcp1,mcp2,mcn1,mcn2,mce1,mce2
       common /zav/ zm
       common /pnsig/ ibb
       common /bremind/ ibrem
       common /toprint/ n
       common /exer1/ fa
       common /exer2/ noca
       COMMON /MATTER/ MEDIUM
c.........................................................................
       MEDIUM = imed
c ........................................................................
        mcb1 = 0  !
        mcb2 = 0  !
        mcp1 = 0  ! CONSTANTS TO CALCULATE
        mcp2 = 0  !      SIMULATION
        mcn1 = 0  !      EFFICIENCY
        mcn2 = 0  !
        mce1 = 0  !
        mce2 = 0  !
c ........................................................................
        iqcd1 = iqcd !---> accounting for QCD part in PN or not...
c ........................................................................
        kindlept = ilep !---> what kind of leptons do we deal with?
c ........................................................................
c                           BASIC CONSTANTS:
c                           ***************
       avog = 6.022045d+23         !--> Avogadro number
       alfa =  7.297353053019d-3   !--> fine structure constant
       rm_e = 5.110034d-1          !--> electron mass (in MeV)
       if(ilep.eq.1) then          !
       rm_mu = 1.0565932d+2        !--> muon mass (in MeV)
       else                        !
       rm_mu = 1.77699d+3          !--> tau mass (in MeV)
       endif                       !
       r_e = 2.8179409d-13         !--> classical electron radii (in cm)
       tlife = 2.906d-13           !--> life time (sec) for tau-lepton
c ........................................................................
c               THRESHOLD ENERGY AND RELATIVE ENERGY TRANSFER:
c               ***********************************************
         emin = em      !---> threshold energy in Gev
         vmin = vm      !---> threshold relative energy transfer
         emph = 8.e-1   !---> threshold en. for photonucl. interaction, GeV
         fa = 1.e+0     !---> factor to multiply all diff. cros-sections and
c                       !     Bethe-Bloch formula
         noca = 1       !---> if noca=0, there are no catastrophic losses
c                             for knock-on electrons
c ........................................................................
        ibb = ipn ! if ibb=1 Sigma_gamma_p for photonuclear interaction is
c                 ! calculated by Bezrukov_Bugaev (squared LN dependence),
c                 ! otherwise it is calculated by ZEUS parameterization
c                 ! (J.Breitweg et al., Eur.Phys.J. C7 (1999) 609)
       ibrem=ibre ! if ibrem=1 diff. cross-section for bremsstrahlung is
c                 ! computed according to Andreev-Bugaev-Bezrukov, otherwise
c                 ! it is done according to Kelner-Kokouluin (Geant 4.)
c ........................................................................
c                          MEDIUM PREPARATION:
c                          ******************
        if (imed.eq.1) then
        ro=1.d+0      !
        nsub=2        ! IT IS WATER. It consists of nsub=2 elements:
        n(1)=2.d+0    ! n(1) = 2 H atoms and n(2) = 1 O atom with atomic
        n(2)=1.d+0    ! weights and electric charges are equal to
        aw(1)=1.008   ! aw(1) = 1.008, aw(2) = 15.999, z1(1) = 1 and
        aw(2)=15.999  ! z1(2) = 8, correspondingly
        z1(1)=1.d+0   ! Its density is ro = 1.0 g/cubic cm
        z1(2)=8.d+0   !
c                     !
        z_a = 5.551d-1! Z/A                      !
        ri_z = 7.5d-05! Min. Ion. Potential, MeV !
        x_0 = 2.4d-1  !--------------------      !--> It is constants
        x_1 = 2.8d+0  !-- 4 constants for        !--> for Bethe-Bloch
        a = 9.1d-2    !-- density effect         !-->     formula
        rm = 3.477d+0 !--------------------      !
        endif
c
        if (imed.eq.2) then
        ro=2.65d+0       !
        nsub=1           !
        n(1)=1.d+0       !
        aw(1)=22.        !
        z1(1)=1.1d+1     !
c                        ! ALL THE SAME FOR STANDARD ROCK
        z_a = 5.d-1      !
        ri_z = 1.364d-04 !
        x_0 = 4.9d-2     !
        x_1 = 3.055d+0   !
        a = 8.3d-2       !
        rm = 3.412d+0    !
        endif
c
        if (imed.eq.3) then
        ro=.92d+0       !
        nsub=2          !
        n(1)=2.d+0      !
        n(2)=1.d+0      ! The same for Antarctic ice
        aw(1)=1.008     ! (all constants are exactly as
        aw(2)=15.999    ! for water but ro = 0.92 g/cm^3 )
        z1(1)=1.d+0     !
        z1(2)=8.d+0     !
c                       !
        z_a = 5.551d-1  !
        ri_z = 7.5d-05  !
        x_0 = 2.4d-1    !
        x_1 = 2.8d+0    !
        a = 9.1d-2      !
        rm = 3.477d+0   !
        endif
c
c                         Sea water (Pacific Ocean):
c                         ------------------------
        if (imed.eq.4) then
        ro = 1.027d+0   ! J.Babson et al, Phys.Rev.D 42 (1990) 3613;
                        ! V.M.Goldschmidt. Geochemistry (Clarendon,
                        ! Oxford, 1954), p. 49.
        nsub = 8          !
        n(1) = 2.d+0      ! -> H
        n(2) = 1.00884d+0 ! -> O
        n(3) = 8.59d-3    ! -> Na
        n(4) = 1.9d-4     ! -> K
        n(5) = 9.9d-4     ! -> Mg
        n(6) = 1.9d-4     ! -> Ca
        n(7) = 1.007d-2   ! -> Cl
        n(8) = 5.3d-3     ! -> S
        aw(1) = 1.008d+0  !
        aw(2) = 15.999d+0 !
        aw(3) = 22.99d+0  ! Chemical composition of the seawater
        aw(4) = 39.10d+0  !           according to
        aw(5) = 24.31d+0  ! A.Okada, Astropart. Phys. 2 (1994) 393
        aw(6) = 40.08d+0  !        and references therein
        aw(7) = 35.45d+0  !
        aw(8) = 32.07d+0  !
        z1(1) = 1.0d+0    !
        z1(2) = 8.0d+0    !
        z1(3) = 11.0d+0   !
        z1(4) = 19.0d+0   !
        z1(5) = 12.0d+0   !
        z1(6) = 20.0d+0   !
        z1(7) = 17.0d+0   !
        z1(8) = 16.0d+0   !
c                        !
        z_a = 5.5525d-1  ! All the same as for pure water except for
        ri_z = 7.5d-05  !        z_a which is taken from
        x_0 = 2.4d-1    ! [J.Babson et al, Phys.Rev.D 42 (1990) 3613;
        x_1 = 2.8d+0    !  V.M.Goldschmidt. Geochemistry (Clarendon,
        a = 9.1d-2      !  Oxford, 1954), p. 49.] and differs from
        rm = 3.477d+0   ! z_a according to Lohman et al. by 0.027%.
        endif
c
c==========================================================================
c  THERE ARE TWO WATER FOR THE ANTARES PLACE SINCE WATER DENSITY CHANGES
c WITH THE DEPTH FROM 1.0291 g/cm^3 AT SURFACE UP TO 1.0404 g/cm^3 AT THE
c           SEA BED (ANTARES-Site/2000-001 and references therein)
c
c       So, one should use imed = 5 when simulating down-coming muons
c  (e.g., atmospheric ones) and imed = 6 when simulating muons which come
c                        from the bottom of detector)
c The error which is caused by this simplified approach (average value for
c density) does not exceed 0.5% (much less, in fact) that is comparable with
c  an error which comes from uncertainties with the muon cross-sections.
c==========================================================================
c
c           Sea water (Mediterranean Sea, ANTARES place, D < 2126 m):
c           --------------------------------------------------------
c
        if (imed.eq.5) then
        ro = 1.0341d+0  ! J.Brunner, ANTARES-Site/2000-001, the mean value
                        ! for sea water density at the ANTARES place between
                        ! surface D = 0 m (1.0291 g/cm^3) and middle of
                        ! detector D = 2126 m (1.0391 g/cm^3)
        nsub = 8          !
        n(1) = 2.d+0      ! -> H
        n(2) = 1.00884d+0 ! -> O
        n(3) = 9.43d-3    ! -> Na
        n(4) = 2.09d-4    ! -> K
        n(5) = 10.87d-4   ! -> Mg
        n(6) = 2.09d-4    ! -> Ca
        n(7) = 1.106d-2   ! -> Cl
        n(8) = 5.82d-3    ! -> S
        aw(1) = 1.008d+0  !
        aw(2) = 15.999d+0 !
        aw(3) = 22.99d+0  !    Chemical composition of the seawater
        aw(4) = 39.10d+0  !                  according to
        aw(5) = 24.31d+0  !     A.Okada, Astropart. Phys. 2 (1994) 393
        aw(6) = 40.08d+0  !              and references therein
        aw(7) = 35.45d+0  !  corrected for Mediterranean Sea, ANTARES place
        aw(8) = 32.07d+0  !     according to salinity  38.44+-0.02 g/kg,
        z1(1) = 1.0d+0    !   as cited in J.Brunner, ANTARES-Site/2000-001
        z1(2) = 8.0d+0    !  instead of 35.0 g/kg as cited in A.Okada, ...
        z1(3) = 11.0d+0   ! (so, n(3-8) have been just multiplied by 1.098)
        z1(4) = 19.0d+0   !
        z1(5) = 12.0d+0   !
        z1(6) = 20.0d+0   !
        z1(7) = 17.0d+0   !
        z1(8) = 16.0d+0   !
c                        !
        z_a = 5.5525d-1  ! All the same as for pure water except for
        ri_z = 7.5d-05  !        z_a which is taken from
        x_0 = 2.4d-1    ! [J.Babson et al, Phys.Rev.D 42 (1990) 3613;
        x_1 = 2.8d+0    !  V.M.Goldschmidt. Geochemistry (Clarendon,
        a = 9.1d-2      !  Oxford, 1954), p. 49.] and differs from
        rm = 3.477d+0   ! z_a according to Lohman et al. by 0.027%.
        endif
c
c
c           Sea water (Mediterranean Sea, ANTARES place, D > 2126 m):
c           --------------------------------------------------------
c
        if (imed.eq.6) then
        ro = 1.03975d+0 ! J.Brunner, ANTARES-Site/2000-001, the mean value
                        ! for sea water density at the ANTARES place between
                        ! sea bed D = 2400 m (1.0404 g/cm^3) and middle of
                        ! detector D = 2126 m (1.0391 g/cm^3)
        nsub = 8          !
        n(1) = 2.d+0      ! -> H
        n(2) = 1.00884d+0 ! -> O
        n(3) = 9.43d-3    ! -> Na
        n(4) = 2.09d-4    ! -> K
        n(5) = 10.87d-4   ! -> Mg
        n(6) = 2.09d-4    ! -> Ca
        n(7) = 1.106d-2   ! -> Cl
        n(8) = 5.82d-3    ! -> S
        aw(1) = 1.008d+0  !
        aw(2) = 15.999d+0 !
        aw(3) = 22.99d+0  !    Chemical composition of the seawater
        aw(4) = 39.10d+0  !                  according to
        aw(5) = 24.31d+0  !     A.Okada, Astropart. Phys. 2 (1994) 393
        aw(6) = 40.08d+0  !              and references therein
        aw(7) = 35.45d+0  !  corrected for Mediterranean Sea, ANTARES place
        aw(8) = 32.07d+0  !     according to salinity  38.44+-0.02 g/kg,
        z1(1) = 1.0d+0    !   as cited in J.Brunner, ANTARES-Site/2000-001
        z1(2) = 8.0d+0    !  instead of 35.0 g/kg as cited in A.Okada, ...
        z1(3) = 11.0d+0   ! (so, n(3-8) have been just multiplied by 1.098)
        z1(4) = 19.0d+0   !
        z1(5) = 12.0d+0   !
        z1(6) = 20.0d+0   !
        z1(7) = 17.0d+0   !
        z1(8) = 16.0d+0   !
c                        !
        z_a = 5.5525d-1  ! All the same as for pure water except for
        ri_z = 7.5d-05  !        z_a which is taken from
        x_0 = 2.4d-1    ! [J.Babson et al, Phys.Rev.D 42 (1990) 3613;
        x_1 = 2.8d+0    !  V.M.Goldschmidt. Geochemistry (Clarendon,
        a = 9.1d-2      !  Oxford, 1954), p. 49.] and differs from
        rm = 3.477d+0   ! z_a according to Lohman et al. by 0.027%.
        endif
c
c      Gran Sasso rock (M.Ambrosio et al., Phys. Rev. D52, (1995) 3793)
c      ----------------------------------------------------------------
c
        if (imed.eq.7) then
        ro = 2.71d+0
        nsub = 8            !
        n(1) = 2.9762d-2    ! -> H
        n(2) = 1.0132379d+0 ! -> C
        n(3) = 3.175109d+0  ! -> O
        n(4) = 3.423164d-1  ! -> Mg
        n(5) = 2.3349764d-2 ! -> Al
        n(6) = 3.73865d-2   ! -> Si
        n(7) = 2.557676d-3  ! -> K
        n(8) = 6.7094166d-1 ! -> Ca
        aw(1) = 1.008d+0
        aw(2) = 12.011d+0
        aw(3) = 15.99d+0
        aw(4) = 24.305d+0
        aw(5) = 26.981d+0
        aw(6) = 28.085d+0
        aw(7) = 39.098d+0
        aw(8) = 40.078d+0
        z1(1) = 1.0d+0
        z1(2) = 6.0d+0
        z1(3) = 8.0d+0
        z1(4) = 12.0d+0
        z1(5) = 13.0d+0
        z1(6) = 14.0d+0
        z1(7) = 19.0d+0
        z1(8) = 20.0d+0
c                        !
        z_a = 5.d-1      ! The same as for Standard Rock
        ri_z = 1.364d-04 !
        x_0 = 4.9d-2     !
        x_1 = 3.055d+0   !
        a = 8.3d-2       !
        rm = 3.412d+0    !
        endif
c
c   Baikal rock (basis, shore rocks and rocks 2 km below the Baikal bed)
c   --------------------------------------------------------------------
c        (as given at A.I.Panfilov, Baikal internal note 22/06/00)
c                         panfilov@inr.ruhep.ru
c
        if (imed.eq.8) then
        ro = 2.9d+0
        nsub = 10            !
        n(1) = 2.7251d-2     ! -> O
        n(2) = 8.15367d-3    ! -> Si
        n(3) = 1.670844d-4   ! -> Ti
        n(4) = 2.89087d-3    ! -> Al
        n(5) = 1.8443247d-3  ! -> Fe
        n(6) = 3.640467d-5   ! -> Mn
        n(7) = 1.810327d-3   ! -> Mg
        n(8) = 1.946205d-3   ! -> Ca
        n(9) = 7.3945837d-4  ! -> Na
        n(10) = 1.278828d-4  ! -> K
        aw(1) = 15.9994d+0
        aw(2) = 28.0855d+0
        aw(3) = 47.88d+0
        aw(4) = 26.9815d+0
        aw(5) = 55.847d+0
        aw(6) = 54.938d+0
        aw(7) = 24.305d+0
        aw(8) = 40.078d+0
        aw(9) = 22.9898d+0
        aw(10) = 39.0983d+0
        z1(1) = 8.0d+0
        z1(2) = 14.0d+0
        z1(3) = 22.0d+0
        z1(4) = 13.0d+0
        z1(5) = 26.0d+0
        z1(6) = 25.0d+0
        z1(7) = 12.0d+0
        z1(8) = 20.0d+0
        z1(9) = 11.0d+0
        z1(10) = 19.0d+0
c                        !
        z_a = 4.96d-1    ! The same as for Standard Rock (what to do?!)
        ri_z = 1.364d-04 !     except for z_a which was measured
        x_0 = 4.9d-2     !          to be equal to 0.496
        x_1 = 3.055d+0   !
        a = 8.3d-2       !
        rm = 3.412d+0    !
        endif
c
c     Baikal rock ("tankhoy layer", up to 2000 m below the Baikal bed)
c      There are data concerning 6 depths which differ each other by
c   ~10% in terms of density, Z, A, and composition. One had to choose
c      the data for 800 m below the Baikal bed which seem to be close
c                                to "average"
c   --------------------------------------------------------------------
c        (as given at A.I.Panfilov, Baikal internal note 22/06/00)
c                         panfilov@inr.ruhep.ru
c
        if (imed.eq.9) then
        ro = 2.481d+0
        nsub = 10            !
        n(1) = 0.588d+0      ! -> O
        n(2) = 0.166d+0      ! -> Si
        n(3) = 0.002d+0      ! -> Ti
        n(4) = 0.093d+0      ! -> Al
        n(5) = 0.033d+0      ! -> Fe
        n(6) = 0.101d+0      ! -> H
        n(7) = 0.009d+0      ! -> Mg
        n(8) = 0.003d+0      ! -> Ca
        n(9) = 0.002d+0      ! -> Na
        n(10) = 0.003d+0     ! -> K
        aw(1) = 15.9994d+0
        aw(2) = 28.0855d+0
        aw(3) = 47.88d+0
        aw(4) = 26.9815d+0
        aw(5) = 55.847d+0
        aw(6) = 1.00794d+0
        aw(7) = 24.305d+0
        aw(8) = 40.078d+0
        aw(9) = 22.9898d+0
        aw(10) = 39.0983d+0
        z1(1) = 8.0d+0
        z1(2) = 14.0d+0
        z1(3) = 22.0d+0
        z1(4) = 13.0d+0
        z1(5) = 26.0d+0
        z1(6) = 1.0d+0
        z1(7) = 12.0d+0
        z1(8) = 20.0d+0
        z1(9) = 11.0d+0
        z1(10) = 19.0d+0
c                        !
        z_a = 5.47d-1     ! The same as for Standard Rock (what to do?!)
        ri_z = 1.364d-04 !     except for z_a which was measured
        x_0 = 4.9d-2     !          to be equal to 0.547
        x_1 = 3.055d+0   !
        a = 8.3d-2       !
        rm = 3.412d+0    !
        endif
c
c      Baikal rock ("anos layer", 100 -- 500 m below the Baikal bed)
c      There are data concerning 6 depths which differ each other by
c   ~10% in terms of density, Z, A, and composition. One had to choose
c      the data for 300 m below the Baikal bed which seem to be close
c                                to "average"
c   --------------------------------------------------------------------
c        (as given at A.I.Panfilov, Baikal internal note 22/06/00)
c                         panfilov@inr.ruhep.ru
c
        if (imed.eq.10) then
        ro = 2.103d+0
        nsub = 10            !
        n(1) = 0.519d+0      ! -> O
        n(2) = 0.149d+0      ! -> Si
        n(3) = 0.002d+0      ! -> Ti
        n(4) = 0.044d+0      ! -> Al
        n(5) = 0.006d+0      ! -> Fe
        n(6) = 0.268d+0      ! -> H
        n(7) = 0.004d+0      ! -> Mg
        n(8) = 0.001d+0      ! -> Ca
        n(9) = 0.001d+0      ! -> Na
        n(10) = 0.006d+0     ! -> K
        aw(1) = 15.9994d+0
        aw(2) = 28.0855d+0
        aw(3) = 47.88d+0
        aw(4) = 26.9815d+0
        aw(5) = 55.847d+0
        aw(6) = 1.00794d+0
        aw(7) = 24.305d+0
        aw(8) = 40.078d+0
        aw(9) = 22.9898d+0
        aw(10) = 39.0983d+0
        z1(1) = 8.0d+0
        z1(2) = 14.0d+0
        z1(3) = 22.0d+0
        z1(4) = 13.0d+0
        z1(5) = 26.0d+0
        z1(6) = 1.0d+0
        z1(7) = 12.0d+0
        z1(8) = 20.0d+0
        z1(9) = 11.0d+0
        z1(10) = 19.0d+0
c                        !
        z_a = 6.3d-1     ! The same as for Standard Rock (what to do?!)
        ri_z = 1.364d-04 !     except for z_a which was measured
        x_0 = 4.9d-2     !          to be equal to 0.630
        x_1 = 3.055d+0   !
        a = 8.3d-2       !
        rm = 3.412d+0    !
        endif
c
c     Baikal ground ("alevrit silt", 0 -- 100 m below the Baikal bed)
c      There are data concerning 6 depths which differ each other by
c   ~10% in terms of density, Z, A, and composition. One had to choose
c      the data for 50 m below the Baikal bed which seem to be close
c                               to "average"
c   --------------------------------------------------------------------
c        (as given at A.I.Panfilov, Baikal internal note 22/06/00)
c                         panfilov@inr.ruhep.ru
c
        if (imed.eq.11) then
        ro = 1.698d+0
        nsub = 10            !
        n(1) = 0.439d+0      ! -> O
        n(2) = 0.090d+0      ! -> Si NB: the little fraction of S
        n(3) = 0.001d+0      ! -> Ti     had to be added to Si (very
        n(4) = 0.018d+0      ! -> Al     close elements, within
        n(5) = 0.005d+0      ! -> Fe      systematic errors)
        n(6) = 0.431d+0      ! -> H
        n(7) = 0.003d+0      ! -> Mg
        n(8) = 0.003d+0      ! -> Ca
        n(9) = 0.005d+0      ! -> Na
        n(10) = 0.003d+0     ! -> K
        aw(1) = 15.9994d+0
        aw(2) = 28.0855d+0
        aw(3) = 47.88d+0
        aw(4) = 26.9815d+0
        aw(5) = 55.847d+0
        aw(6) = 1.00794d+0
        aw(7) = 24.305d+0
        aw(8) = 40.078d+0
        aw(9) = 22.9898d+0
        aw(10) = 39.0983d+0
        z1(1) = 8.0d+0
        z1(2) = 14.0d+0
        z1(3) = 22.0d+0
        z1(4) = 13.0d+0
        z1(5) = 26.0d+0
        z1(6) = 1.0d+0
        z1(7) = 12.0d+0
        z1(8) = 20.0d+0
        z1(9) = 11.0d+0
        z1(10) = 19.0d+0
c                        !
        z_a = 7.11d-1    ! The same as for Standard Rock (what to do?!)
        ri_z = 7.5d-05   !  except for z_a which was measured to be equal
        x_0 = 4.9d-2     ! to 0.711, ri_z had to be taken for water since
        x_1 = 3.055d+0   ! this ground is obviously closer to water than
        a = 8.3d-2       !               to rock...
        rm = 3.412d+0    !
        endif
c
c                  FREJUS ROCK ("single medium" model)
c                  ===================================
c       as described in W.Rhode, "Untersuchung der Energiespektren
c hochenergetischer Muonen im Frejusdetektor", Dissertation zur Erlangung
c  des Doktorgrades des Fachbereiches Physik der Bergischer UniversitaEt
c              Wupppertal, WUB-DIS 93-11, Oktober 1993, 232 pp.
c
        if (imed.eq.12) then
        ro=2.74d+0       !
        nsub=1           !
        n(1)=1.d+0       !
        aw(1)=20.34      !
        z1(1)=1.012d+1   !
c                        ! Everything has been taken from
        z_a = 4.975d-1   !        W.Rhode Thesis
        ri_z = 1.49d-04  !
        x_0 = 2.88d-1    !
        x_1 = 3.196d+0   !
        a = 7.8d-2       !
        rm = 3.645d+0    !
        endif
c
c   Frejus rock ("composed medium" model), as it was incorporated in
c PROPMU code by W.Rhode (W.Rhode, private communication, October 2001)
c
        if (imed.eq.13) then
        ro = 2.74d+0
        nsub = 10            !
        n(1) = 9.1800165d-3  ! -> C
        n(2) = 3.8712389d-2  ! -> O
        n(3) = 3.0446410d-4  ! -> Mg
        n(4) = 1.3342456d-3  ! -> Al
        n(5) = 3.6584715d-3  ! -> Si
        n(6) = 7.9523483d-5  ! -> S
        n(7) = 1.6650340d-4  ! -> K
        n(8) = 2.5955637d-3  ! -> Ca
        n(9) = 6.4072169d-6  ! -> Mn
        n(10) = 1.7417229d-4 ! -> Fe
        aw(1) = 12.11d+0
        aw(2) = 15.9994d+0
        aw(3) = 24.305d+0
        aw(4) = 26.981539d+0
        aw(5) = 28.0855d+0
        aw(6) = 32.066d+0
        aw(7) = 39.0983d+0
        aw(8) = 40.078d+0
        aw(9) = 54.93805d+0
        aw(10) = 55.847d+0
        z1(1) = 6.0d+0
        z1(2) = 8.0d+0
        z1(3) = 12.0d+0
        z1(4) = 13.0d+0
        z1(5) = 14.0d+0
        z1(6) = 16.0d+0
        z1(7) = 19.0d+0
        z1(8) = 20.0d+0
        z1(9) = 25.0d+0
        z1(10) = 26.0d+0
c
        z_a = 4.975d-1
        ri_z = 1.49d-04
        x_0 = 2.88d-1
        x_1 = 3.196d+0
        a = 7.8d-2
        rm = 3.645d+0
        endif
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c   BELOW THE SAME MEDIA BUT ALL DENSITIES ARE SET TO 1 g/cm**3    c
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc

        if (imed.eq.-1) then
        ro=1.d+0      !
        nsub=2        ! IT IS WATER. It consists of nsub=2 elements:
        n(1)=2.d+0    ! n(1) = 2 H atoms and n(2) = 1 O atom with atomic
        n(2)=1.d+0    ! weights and electric charges are equal to
        aw(1)=1.008   ! aw(1) = 1.008, aw(2) = 15.999, z1(1) = 1 and
        aw(2)=15.999  ! z1(2) = 8, correspondingly
        z1(1)=1.d+0   ! Its density is ro = 1.0 g/cubic cm
        z1(2)=8.d+0   !
c                     !
        z_a = 5.551d-1! Z/A                      !
        ri_z = 7.5d-05! Min. Ion. Potential, MeV !
        x_0 = 2.4d-1  !--------------------      !--> It is constants
        x_1 = 2.8d+0  !-- 4 constants for        !--> for Bethe-Bloch
        a = 9.1d-2    !-- density effect         !-->     formula
        rm = 3.477d+0 !--------------------      !
        endif
c
        if (imed.eq.-2) then
        ro=1.d+0       !
        nsub=1           !
        n(1)=1.d+0       !
        aw(1)=22.        !
        z1(1)=1.1d+1     !
c                        ! ALL THE SAME FOR STANDARD ROCK
        z_a = 5.d-1      !
        ri_z = 1.364d-04 !
        x_0 = 4.9d-2     !
        x_1 = 3.055d+0   !
        a = 8.3d-2       !
        rm = 3.412d+0    !
        endif
c
        if (imed.eq.-3) then
        ro=1.d+0       !
        nsub=2          !
        n(1)=2.d+0      !
        n(2)=1.d+0      ! The same for Antarctic ice
        aw(1)=1.008     ! (all constants are exactly as
        aw(2)=15.999    ! for water but ro = 0.92 g/cm^3 )
        z1(1)=1.d+0     !
        z1(2)=8.d+0     !
c                       !
        z_a = 5.551d-1  !
        ri_z = 7.5d-05  !
        x_0 = 2.4d-1    !
        x_1 = 2.8d+0    !
        a = 9.1d-2      !
        rm = 3.477d+0   !
        endif
c
c                         Sea water (Pacific Ocean):
c                         ------------------------
        if (imed.eq.-4) then
        ro = 1.d+0      ! J.Babson et al, Phys.Rev.D 42 (1990) 3613;
                        ! V.M.Goldschmidt. Geochemistry (Clarendon,
                        ! Oxford, 1954), p. 49.
        nsub = 8          !
        n(1) = 2.d+0      ! -> H
        n(2) = 1.00884d+0 ! -> O
        n(3) = 8.59d-3    ! -> Na
        n(4) = 1.9d-4     ! -> K
        n(5) = 9.9d-4     ! -> Mg
        n(6) = 1.9d-4     ! -> Ca
        n(7) = 1.007d-2   ! -> Cl
        n(8) = 5.3d-3     ! -> S
        aw(1) = 1.008d+0  !
        aw(2) = 15.999d+0 !
        aw(3) = 22.99d+0  ! Chemical composition of the seawater
        aw(4) = 39.10d+0  !           according to
        aw(5) = 24.31d+0  ! A.Okada, Astropart. Phys. 2 (1994) 393
        aw(6) = 40.08d+0  !        and references therein
        aw(7) = 35.45d+0  !
        aw(8) = 32.07d+0  !
        z1(1) = 1.0d+0    !
        z1(2) = 8.0d+0    !
        z1(3) = 11.0d+0   !
        z1(4) = 19.0d+0   !
        z1(5) = 12.0d+0   !
        z1(6) = 20.0d+0   !
        z1(7) = 17.0d+0   !
        z1(8) = 16.0d+0   !
c                        !
        z_a = 5.5525d-1  ! All the same as for pure water except for
        ri_z = 7.5d-05  !        z_a which is taken from
        x_0 = 2.4d-1    ! [J.Babson et al, Phys.Rev.D 42 (1990) 3613;
        x_1 = 2.8d+0    !  V.M.Goldschmidt. Geochemistry (Clarendon,
        a = 9.1d-2      !  Oxford, 1954), p. 49.] and differs from
        rm = 3.477d+0   ! z_a according to Lohman et al. by 0.027%.
        endif
c
c           Sea water (Mediterranean Sea, ANTARES place, D < 2126 m):
c           --------------------------------------------------------
c
        if (imed.eq.-5) then
        ro = 1.d+0      ! J.Brunner, ANTARES-Site/2000-001, the mean value
                        ! for sea water density at the ANTARES place between
                        ! surface D = 0 m (1.0291 g/cm^3) and middle of
                        ! detector D = 2126 m (1.0391 g/cm^3)
        nsub = 8          !
        n(1) = 2.d+0      ! -> H
        n(2) = 1.00884d+0 ! -> O
        n(3) = 9.43d-3    ! -> Na
        n(4) = 2.09d-4    ! -> K
        n(5) = 10.87d-4   ! -> Mg
        n(6) = 2.09d-4    ! -> Ca
        n(7) = 1.106d-2   ! -> Cl
        n(8) = 5.82d-3    ! -> S
        aw(1) = 1.008d+0  !
        aw(2) = 15.999d+0 !
        aw(3) = 22.99d+0  !    Chemical composition of the seawater
        aw(4) = 39.10d+0  !                  according to
        aw(5) = 24.31d+0  !     A.Okada, Astropart. Phys. 2 (1994) 393
        aw(6) = 40.08d+0  !              and references therein
        aw(7) = 35.45d+0  !  corrected for Mediterranean Sea, ANTARES place
        aw(8) = 32.07d+0  !     according to salinity  38.44+-0.02 g/kg,
        z1(1) = 1.0d+0    !   as cited in J.Brunner, ANTARES-Site/2000-001
        z1(2) = 8.0d+0    !  instead of 35.0 g/kg as cited in A.Okada, ...
        z1(3) = 11.0d+0   ! (so, n(3-8) have been just multiplied by 1.098)
        z1(4) = 19.0d+0   !
        z1(5) = 12.0d+0   !
        z1(6) = 20.0d+0   !
        z1(7) = 17.0d+0   !
        z1(8) = 16.0d+0   !
c                        !
        z_a = 5.5525d-1  ! All the same as for pure water except for
        ri_z = 7.5d-05  !        z_a which is taken from
        x_0 = 2.4d-1    ! [J.Babson et al, Phys.Rev.D 42 (1990) 3613;
        x_1 = 2.8d+0    !  V.M.Goldschmidt. Geochemistry (Clarendon,
        a = 9.1d-2      !  Oxford, 1954), p. 49.] and differs from
        rm = 3.477d+0   ! z_a according to Lohman et al. by 0.027%.
        endif
c
c
c           Sea water (Mediterranean Sea, ANTARES place, D > 2126 m):
c           --------------------------------------------------------
c
        if (imed.eq.-6) then
        ro = 1.d+0      ! J.Brunner, ANTARES-Site/2000-001, the mean value
                        ! for sea water density at the ANTARES place between
                        ! sea bed D = 2400 m (1.0404 g/cm^3) and middle of
                        ! detector D = 2126 m (1.0391 g/cm^3)
        nsub = 8          !
        n(1) = 2.d+0      ! -> H
        n(2) = 1.00884d+0 ! -> O
        n(3) = 9.43d-3    ! -> Na
        n(4) = 2.09d-4    ! -> K
        n(5) = 10.87d-4   ! -> Mg
        n(6) = 2.09d-4    ! -> Ca
        n(7) = 1.106d-2   ! -> Cl
        n(8) = 5.82d-3    ! -> S
        aw(1) = 1.008d+0  !
        aw(2) = 15.999d+0 !
        aw(3) = 22.99d+0  !    Chemical composition of the seawater
        aw(4) = 39.10d+0  !                  according to
        aw(5) = 24.31d+0  !     A.Okada, Astropart. Phys. 2 (1994) 393
        aw(6) = 40.08d+0  !              and references therein
        aw(7) = 35.45d+0  !  corrected for Mediterranean Sea, ANTARES place
        aw(8) = 32.07d+0  !     according to salinity  38.44+-0.02 g/kg,
        z1(1) = 1.0d+0    !   as cited in J.Brunner, ANTARES-Site/2000-001
        z1(2) = 8.0d+0    !  instead of 35.0 g/kg as cited in A.Okada, ...
        z1(3) = 11.0d+0   ! (so, n(3-8) have been just multiplied by 1.098)
        z1(4) = 19.0d+0   !
        z1(5) = 12.0d+0   !
        z1(6) = 20.0d+0   !
        z1(7) = 17.0d+0   !
        z1(8) = 16.0d+0   !
c                        !
        z_a = 5.5525d-1  ! All the same as for pure water except for
        ri_z = 7.5d-05  !        z_a which is taken from
        x_0 = 2.4d-1    ! [J.Babson et al, Phys.Rev.D 42 (1990) 3613;
        x_1 = 2.8d+0    !  V.M.Goldschmidt. Geochemistry (Clarendon,
        a = 9.1d-2      !  Oxford, 1954), p. 49.] and differs from
        rm = 3.477d+0   ! z_a according to Lohman et al. by 0.027%.
        endif
c
c      Gran Sasso rock (M.Ambrosio et al., Phys. Rev. D52, (1995) 3793)
c      ----------------------------------------------------------------
c
        if (imed.eq.-7) then
        ro = 1.d+0
        nsub = 8            !
        n(1) = 2.9762d-2    ! -> H
        n(2) = 1.0132379d+0 ! -> C
        n(3) = 3.175109d+0  ! -> O
        n(4) = 3.423164d-1  ! -> Mg
        n(5) = 2.3349764d-2 ! -> Al
        n(6) = 3.73865d-2   ! -> Si
        n(7) = 2.557676d-3  ! -> K
        n(8) = 6.7094166d-1 ! -> Ca
        aw(1) = 1.008d+0
        aw(2) = 12.011d+0
        aw(3) = 15.99d+0
        aw(4) = 24.305d+0
        aw(5) = 26.981d+0
        aw(6) = 28.085d+0
        aw(7) = 39.098d+0
        aw(8) = 40.078d+0
        z1(1) = 1.0d+0
        z1(2) = 6.0d+0
        z1(3) = 8.0d+0
        z1(4) = 12.0d+0
        z1(5) = 13.0d+0
        z1(6) = 14.0d+0
        z1(7) = 19.0d+0
        z1(8) = 20.0d+0
c                        !
        z_a = 5.d-1      ! The same as for Standard Rock
        ri_z = 1.364d-04 !
        x_0 = 4.9d-2     !
        x_1 = 3.055d+0   !
        a = 8.3d-2       !
        rm = 3.412d+0    !
        endif
c
c   Baikal rock (basis, shore rocks and rocks 2 km below the Baikal bed)
c   --------------------------------------------------------------------
c        (as given at A.I.Panfilov, Baikal internal note 22/06/00)
c                         panfilov@inr.ruhep.ru
c
        if (imed.eq.-8) then
        ro = 1.d+0
        nsub = 10            !
        n(1) = 2.7251d-2     ! -> O
        n(2) = 8.15367d-3    ! -> Si
        n(3) = 1.670844d-4   ! -> Ti
        n(4) = 2.89087d-3    ! -> Al
        n(5) = 1.8443247d-3  ! -> Fe
        n(6) = 3.640467d-5   ! -> Mn
        n(7) = 1.810327d-3   ! -> Mg
        n(8) = 1.946205d-3   ! -> Ca
        n(9) = 7.3945837d-4  ! -> Na
        n(10) = 1.278828d-4  ! -> K
        aw(1) = 15.9994d+0
        aw(2) = 28.0855d+0
        aw(3) = 47.88d+0
        aw(4) = 26.9815d+0
        aw(5) = 55.847d+0
        aw(6) = 54.938d+0
        aw(7) = 24.305d+0
        aw(8) = 40.078d+0
        aw(9) = 22.9898d+0
        aw(10) = 39.0983d+0
        z1(1) = 8.0d+0
        z1(2) = 14.0d+0
        z1(3) = 22.0d+0
        z1(4) = 13.0d+0
        z1(5) = 26.0d+0
        z1(6) = 25.0d+0
        z1(7) = 12.0d+0
        z1(8) = 20.0d+0
        z1(9) = 11.0d+0
        z1(10) = 19.0d+0
c                        !
        z_a = 4.96d-1    ! The same as for Standard Rock (what to do?!)
        ri_z = 1.364d-04 !     except for z_a which was measured
        x_0 = 4.9d-2     !          to be equal to 0.496
        x_1 = 3.055d+0   !
        a = 8.3d-2       !
        rm = 3.412d+0    !
        endif
c
c     Baikal rock ("tankhoy layer", up to 2000 m below the Baikal bed)
c      There are data concerning 6 depths which differ each other by
c   ~10% in terms of density, Z, A, and composition. One had to choose
c      the data for 800 m below the Baikal bed which seem to be close
c                                to "average"
c   --------------------------------------------------------------------
c        (as given at A.I.Panfilov, Baikal internal note 22/06/00)
c                         panfilov@inr.ruhep.ru
c
        if (imed.eq.-9) then
        ro = 1.d+0
        nsub = 10            !
        n(1) = 0.588d+0      ! -> O
        n(2) = 0.166d+0      ! -> Si
        n(3) = 0.002d+0      ! -> Ti
        n(4) = 0.093d+0      ! -> Al
        n(5) = 0.033d+0      ! -> Fe
        n(6) = 0.101d+0      ! -> H
        n(7) = 0.009d+0      ! -> Mg
        n(8) = 0.003d+0      ! -> Ca
        n(9) = 0.002d+0      ! -> Na
        n(10) = 0.003d+0     ! -> K
        aw(1) = 15.9994d+0
        aw(2) = 28.0855d+0
        aw(3) = 47.88d+0
        aw(4) = 26.9815d+0
        aw(5) = 55.847d+0
        aw(6) = 1.00794d+0
        aw(7) = 24.305d+0
        aw(8) = 40.078d+0
        aw(9) = 22.9898d+0
        aw(10) = 39.0983d+0
        z1(1) = 8.0d+0
        z1(2) = 14.0d+0
        z1(3) = 22.0d+0
        z1(4) = 13.0d+0
        z1(5) = 26.0d+0
        z1(6) = 1.0d+0
        z1(7) = 12.0d+0
        z1(8) = 20.0d+0
        z1(9) = 11.0d+0
        z1(10) = 19.0d+0
c                        !
        z_a = 5.47d-1     ! The same as for Standard Rock (what to do?!)
        ri_z = 1.364d-04 !     except for z_a which was measured
        x_0 = 4.9d-2     !          to be equal to 0.547
        x_1 = 3.055d+0   !
        a = 8.3d-2       !
        rm = 3.412d+0    !
        endif
c
c      Baikal rock ("anos layer", 100 -- 500 m below the Baikal bed)
c      There are data concerning 6 depths which differ each other by
c   ~10% in terms of density, Z, A, and composition. One had to choose
c      the data for 300 m below the Baikal bed which seem to be close
c                                to "average"
c   --------------------------------------------------------------------
c        (as given at A.I.Panfilov, Baikal internal note 22/06/00)
c                         panfilov@inr.ruhep.ru
c
        if (imed.eq.-10) then
        ro = 1.d+0
        nsub = 10            !
        n(1) = 0.519d+0      ! -> O
        n(2) = 0.149d+0      ! -> Si
        n(3) = 0.002d+0      ! -> Ti
        n(4) = 0.044d+0      ! -> Al
        n(5) = 0.006d+0      ! -> Fe
        n(6) = 0.268d+0      ! -> H
        n(7) = 0.004d+0      ! -> Mg
        n(8) = 0.001d+0      ! -> Ca
        n(9) = 0.001d+0      ! -> Na
        n(10) = 0.006d+0     ! -> K
        aw(1) = 15.9994d+0
        aw(2) = 28.0855d+0
        aw(3) = 47.88d+0
        aw(4) = 26.9815d+0
        aw(5) = 55.847d+0
        aw(6) = 1.00794d+0
        aw(7) = 24.305d+0
        aw(8) = 40.078d+0
        aw(9) = 22.9898d+0
        aw(10) = 39.0983d+0
        z1(1) = 8.0d+0
        z1(2) = 14.0d+0
        z1(3) = 22.0d+0
        z1(4) = 13.0d+0
        z1(5) = 26.0d+0
        z1(6) = 1.0d+0
        z1(7) = 12.0d+0
        z1(8) = 20.0d+0
        z1(9) = 11.0d+0
        z1(10) = 19.0d+0
c                        !
        z_a = 6.3d-1     ! The same as for Standard Rock (what to do?!)
        ri_z = 1.364d-04 !     except for z_a which was measured
        x_0 = 4.9d-2     !          to be equal to 0.630
        x_1 = 3.055d+0   !
        a = 8.3d-2       !
        rm = 3.412d+0    !
        endif
c
c     Baikal ground ("alevrit silt", 0 -- 100 m below the Baikal bed)
c      There are data concerning 6 depths which differ each other by
c   ~10% in terms of density, Z, A, and composition. One had to choose
c      the data for 50 m below the Baikal bed which seem to be close
c                               to "average"
c   --------------------------------------------------------------------
c        (as given at A.I.Panfilov, Baikal internal note 22/06/00)
c                         panfilov@inr.ruhep.ru
c
        if (imed.eq.-11) then
        ro = 1.d+0
        nsub = 10            !
        n(1) = 0.439d+0      ! -> O
        n(2) = 0.090d+0      ! -> Si NB: the little fraction of S
        n(3) = 0.001d+0      ! -> Ti     had to be added to Si (very
        n(4) = 0.018d+0      ! -> Al     close elements, within
        n(5) = 0.005d+0      ! -> Fe      systematic errors)
        n(6) = 0.431d+0      ! -> H
        n(7) = 0.003d+0      ! -> Mg
        n(8) = 0.003d+0      ! -> Ca
        n(9) = 0.005d+0      ! -> Na
        n(10) = 0.003d+0     ! -> K
        aw(1) = 15.9994d+0
        aw(2) = 28.0855d+0
        aw(3) = 47.88d+0
        aw(4) = 26.9815d+0
        aw(5) = 55.847d+0
        aw(6) = 1.00794d+0
        aw(7) = 24.305d+0
        aw(8) = 40.078d+0
        aw(9) = 22.9898d+0
        aw(10) = 39.0983d+0
        z1(1) = 8.0d+0
        z1(2) = 14.0d+0
        z1(3) = 22.0d+0
        z1(4) = 13.0d+0
        z1(5) = 26.0d+0
        z1(6) = 1.0d+0
        z1(7) = 12.0d+0
        z1(8) = 20.0d+0
        z1(9) = 11.0d+0
        z1(10) = 19.0d+0
c                        !
        z_a = 7.11d-1    ! The same as for Standard Rock (what to do?!)
        ri_z = 7.5d-05   !  except for z_a which was measured to be equal
        x_0 = 4.9d-2     ! to 0.711, ri_z had to be taken for water since
        x_1 = 3.055d+0   ! this ground is obviously closer to water than
        a = 8.3d-2       !               to rock...
        rm = 3.412d+0    !
        endif
c
c                  FREJUS ROCK ("single medium" model)
c                  ===================================
c       as described in W.Rhode, "Untersuchung der Energiespektren
c hochenergetischer Muonen im Frejusdetektor", Dissertation zur Erlangung
c  des Doktorgrades des Fachbereiches Physik der Bergischer UniversitaEt
c              Wupppertal, WUB-DIS 93-11, Oktober 1993, 232 pp.
c
        if (imed.eq.-12) then
        ro=1.d+0         !
        nsub=1           !
        n(1)=1.d+0       !
        aw(1)=20.34      !
        z1(1)=1.012d+1   !
c                        ! Everything has been taken from
        z_a = 4.975d-1   !        W.Rhode Thesis
        ri_z = 1.49d-04  !
        x_0 = 2.88d-1    !
        x_1 = 3.196d+0   !
        a = 7.8d-2       !
        rm = 3.645d+0    !
        endif
c
c   Frejus rock ("composed medium" model), as it was incorporated in
c PROPMU code by W.Rhode (W.Rhode, private communication, October 2001)
c
        if (imed.eq.-13) then
        ro = 1.d+0
        nsub = 10            !
        n(1) = 9.1800165d-3  ! -> C
        n(2) = 3.8712389d-2  ! -> O
        n(3) = 3.0446410d-4  ! -> Mg
        n(4) = 1.3342456d-3  ! -> Al
        n(5) = 3.6584715d-3  ! -> Si
        n(6) = 7.9523483d-5  ! -> S
        n(7) = 1.6650340d-4  ! -> K
        n(8) = 2.5955637d-3  ! -> Ca
        n(9) = 6.4072169d-6  ! -> Mn
        n(10) = 1.7417229d-4 ! -> Fe
        aw(1) = 12.11d+0
        aw(2) = 15.9994d+0
        aw(3) = 24.305d+0
        aw(4) = 26.981539d+0
        aw(5) = 28.0855d+0
        aw(6) = 32.066d+0
        aw(7) = 39.0983d+0
        aw(8) = 40.078d+0
        aw(9) = 54.93805d+0
        aw(10) = 55.847d+0
        z1(1) = 6.0d+0
        z1(2) = 8.0d+0
        z1(3) = 12.0d+0
        z1(4) = 13.0d+0
        z1(5) = 14.0d+0
        z1(6) = 16.0d+0
        z1(7) = 19.0d+0
        z1(8) = 20.0d+0
        z1(9) = 25.0d+0
        z1(10) = 26.0d+0
c
        z_a = 4.975d-1
        ri_z = 1.49d-04
        x_0 = 2.88d-1
        x_1 = 3.196d+0
        a = 7.8d-2
        rm = 3.645d+0
        endif
c
        ntot=0.d+0
        do i=1,nsub
        ntot=ntot+n(i) !----> ntot is total number of atoms in molecule
        enddo
        do i=1,nsub
        w(i)=n(i)/ntot !-----> w(i) are relative weights of different atoms
        enddo          !       w(i) = n(i) / ntot
c
        zmean=0.d+0
        do i=1,nsub
        zmean = zmean + (z1(i)*n(i))
        enddo
        zm = sngl(zmean/ntot) !-> mean charge of averaged atom (for Delec-s)
c
        a_ef = 0.d+0
        do i=1,nsub
        a_ef = a_ef + ((n(i)*aw(i))/ntot) !--> it is an effective atomic
        enddo                             !    weight for an averaged atom
c                                         !    for which diff. and total cros-
        return                            !    sections will be computed.
        end
****************************************************************************
* C.3
         SUBROUTINE spl1
*
*  THE ROUTINE USES A PART OF splain.f CODE (~/flib/splain.f) DEVELOPED AT
*                         IRKUTSK STATE UNIVERSITY
*
* SPL1 produces arrays of splain coefficients for 1-dimensional interpolation
*      and passes them via common blocks to corresponding subroutines.
*  .....................................................................
       common /con_los/ elosemin(17),elosvmin(17)
c                               !-> input from ENLOS
c  routine. Contain 17 values for muon "continuous energy losses" below
c  EMIN (elosemin(17), MeV/cm) and VMIN (elosvmin(17), MeV/cm) for 17
c  muon energies starting with 10 GeV and finishing with 1 EeV.
       common /eleng/ eminleng(17)
c                               !-> input from ENLOS routine. Contains
c  17 values for muon free path between 2 interactions with energy trans-
c  fers less than EMIN for 17 muon energies starting with 10 GeV and fini-
c  shing with 1 EeV.
       common /ctbr_in1/ FBC(17),FBC2(17)
c                               !-> input from GAMMA1 subroutine.
       common /elbr_in1/ FBL(17),FBL2(17)
c                               !   Contains 17 values of mean
c  free path (arrays FBC(17) and FBC2(17), cm) and 17 values of energy
c  losses (arrays FBL(17) and FBL2(17), LN(MeV/cm)) for muon bremsstra-
c  hlung with energy transfers > EMIN and > VMIN for 17 muon energies
c  starting with 10 GeV and finishing with 1000 PeV.
       common /elbr_in2/ FBL3(17)
c                               !-> input from GAMMA1 routine. Contains
c  17 values of total muon energy losses due to bremsstrahlung
c  (log10(MeV/cm)) for muon energies 10 GeV -- 1 EeV.
       common /ctpa_in1/ FPC(17),FPC2(17)
c                               !-> input from PAIR1 subroutine.
       common /elpa_in1/ FPL(17),FPL2(17)
c                               !   Contains 17 values of mean
c  free path (arrays FPC(17) and FPC2(17), LN(cm)) and 17 values of energy
c  losses (arrays FPL(17) and FPL2(17), LN(MeV/cm)) for e+e- pair production
c  with energy transfers > EMIN and > VMIN for 17 muon energies starting
c  with 10 GeV and finishing with 1000 PeV.
       common /elpa_in2/ FPL3(17)
c                               !-> input from PAIR1 routine. Contains
c  17 values of total muon energy losses due to e+e- pair production
c  (LN(MeV/cm)) for muon energies 10 GeV -- 1 EeV.
       common /ctph_in1/ FNC(17),FNC2(65)
c                               !-> input from PHNU1 subroutine.
       common /elph_in1/ FNL(17),FNL2(65)
c                               !   Contains 17 values of mean
c  free path (arrays FNC(17) and FNC2(17), cm) and 17 values of energy
c  losses (arrays FNL(17), FNL2(17), LN(MeV/cm)) for muon photonuclear
c  interactions with energy transfers > EMIN and > VMIN for 17 muon
c  energies starting with 10 GeV and finishing with 1000 PeV.
       common /elph_in2/ FNL3(17)
c                               !-> input from PHNU1 routine. Contains
c  17 values of total muon energy losses due to photonuclear interaction
c  (log10(MeV/cm)) for muon energies 10 GeV -- 1 EeV.
       common /ctel_in1/ FEC(17),FEC2(17)
c                               !-> input from ELEC1 subroutine.
       common /elel_in1/ FEL(17),FEL2(17)
c                               !   Contains 17 values of mean
c  free path (arrays FEC(17), FEC2(17), cm) and 17 values of energy losses
c  (arrays FEL(17), FEL2(17), log10(MeV/cm)) for knock-on-electrons produ-
c  ction with energy transfers > EMIN and >VMIN for 17 muon energies star-
c  ting with 10 GeV and finishing with 1000 PeV.
       common /elel_in2/ FELBB(17),FELBBB(17)
c                               !-> input from ELEC1 subrou-
c  tine. Contain 17 values of total energy losses for ionisation energy
c  losses (MeV/cm) computed by Bethe-Bloch formula (FELBB(17)) and  by
c  (Bethe-Bloch + e-diagram for bremsstrahlung) (FELBBB(17)).
       common /elel_in3/ FELOWTOT(101)
c                               !-> input from ELEC1 subrou-
c  tine. Contain 101 values of total energy losses for ionisation energy
c  losses (MeV/cm) computed by (Bethe-Bloch + e-diagram for bremsstrahlung)
c  for muon energies 0.14 - 14 GeV
       common /sok34/ com_pa_m(2201)
c                               !-> input from PAIR1 subroutine. Contains
c  1601 values for comparison function to simulate energy transfers due to
c  muon pair production. It is calculated for E_mu = 1000 PeV and for 2201
c  values of relative energy transfers V = 10^(-11) -- 1.
       common /sok1/ xmin1_c,st1_c,xmax1_c
c                               !-> values for the first values,
c  last values and steps of arguments for arrays FBC, FPC, FNC and FEC. Are
c  passed to corresponding subroutines along with splain coefficients to
c  perform an interpolation.
       common /eminl/ xm1,s1,xma1
c                               !-> values for the first values, last
c  values and steps of arguments for array EMINLENG. Are passed to corres-
c  ponding subroutines along with splain coefficients to perform an inter-
c  polation.
       common /sok5/ xmin1_l,st1_l,xmax1_l
c                               !-> values for the first values,
c  last values and steps of arguments for arrays FBL, FPL, FNL and FEL. Are
c  passed to corresponding subroutines along with splain coefficients to
c  perform an interpolation.
       common /sok1n/ xmin1_nc,st1_nc,xmax1_nc
c                               !-> values for the first
c  value, last value and step of arguments for array FNC2. Are passed
c  to subroutine GCTPHV along with splains to perform an interpolation.
       common /sok5n/ xmin1_nl,st1_nl,xmax1_nl
c                               !-> values for the first value,
c  value, last value and step of arguments for array FNL2. Are passed to
c  to subroutine GDEDPHV along with splains to perform an interpolation.
       common /sok5et/ xmin1_lo,st1_lo,xmax1_lo
c                               !-> values for the first value,
c  value, last value and step of arguments for array FELOWTOT. Are passed to
c  subroutine GDEDELT2 along with splains to perform an interpolation.
       common /sok55/ xmin1_p,st1_p,xmax1_p
c                               !-> values for the first value,
c  last value and step for array COM_PA_M. Are passed to subroutine COMP
c  along with splains to get values of comparison function at any relative
c  energy transfer by interpolation.
       common /sok1_b/ CBC(19)
c                               !-> resulting array with splain coefficients
c  for mean path for muon bremsstrahlung with energy transfer > EMIN. It is
c  cooked within subroutine SPL1 and passed to subroutine GETLBREM to get
c  mean free path for any muon energy 10 GeV -- 1000 PeV by interpolation.
       common /sok5_b/ CBL(19)
c                               !-> resulting array with splain coefficients
c  for muon bremsstrahlung energy losses  with energy transfer > EMIN
c  It is cooked within subroutine SPL1 and passed to subroutine GETDEDBR to
c  get energy losses for any muon energy 10 GeV -- 1000 PeV by interpolation
       common /sok1_b2/ CBC2(19)
c                               !-> resulting array with splain coefficients
c  for mean path for muon bremsstrahlung with energy transfer > VMIN. It is
c  cooked within subroutine SPL1 and passed to subroutine GLBREMV to get
c  mean free path for any muon energy 10 GeV -- 1000 PeV by interpolation.
       common /sok5_b2/ CBL2(19)
c                               !-> resulting array with splain coefficients
c  for muon bremsstrahlung energy losses  with energy transfer > VMIN
c  It is cooked within subroutine SPL1 and passed to subroutine GDEDBRV to
c  get energy losses for any muon energy 10 GeV -- 1000 PeV by interpolation
       common /sok5_b3/ CBL3(19)
c                               !-> resulting array with splain coefficients
c  fort otal muon bremsstrahlung energy losses. It is cooked within
c  subroutine SPL1 and passed to subroutine GDEDBRT to get energy losses
c  for any muon energy 10 GeV -- 1000 PeV by interpolation.
       common /sok1_p/ CPC(19)
c                               !-> resulting array with splain coefficients
c  for muon pair production total cross-section with energy transfer > EMIN
c  It is cooked within subroutine SPL1 and passed to subroutine GETCTPA to
c  get cross-section values for any muon energy 10 GeV -- 1000 PeV
c  by interpolation
       common /sok5_p/ CPL(19)
c                               !-> resulting array with splain coefficients
c  for muon energy losses for pair production with energy transfer > EMIN
c  It is cooked within subroutine SPL1 and passed to subroutine GETDEDPA to
c  get energy losses for any muon energy 10 GeV -- 1000 PeV by interpolation
       common /sok1_p2/ CPC2(19)
c                               !-> resulting array with splain coefficients
c  for mean path for E+E- pair production with energy transfer > VMIN. It is
c  cooked within subroutine SPL1 and passed to subroutine GLPAIRV to get
c  mean free path for any muon energy 10 GeV -- 1000 PeV by interpolation.
       common /sok5_p2/ CPL2(19)
c                               !-> resulting array with splain coefficients
c  for e+e- pairs production energy losses  with energy transfer > VMIN
c  It is cooked within subroutine SPL1 and passed to subroutine GDEDPAV to
c  get energy losses for any muon energy 10 GeV -- 1000 PeV by interpolation
       common /sok5_p3/ CPL3(19)
c                               !-> resulting array with splain coefficients
c  for total energy losses due to e+e- pairs production. It is cooked within
c  subroutine SPL1 and passed to subroutine GDEDPAT to get energy losses
c  for any muon energy 10 GeV -- 1000 PeV by interpolation.
       common /sok1_n/ CNC(19)
c                               !-> resulting array with splain coefficients
c  for muon photonuclear interaction total cross-section with energy
c  transfers > EMIN. It is cooked within subroutine SPL1 and passed to
c  subroutine GETCTPH to get cross-section values for any muon energy 10 GeV
c  -- 1000 PeV by interpolation
       common /sok5_n/ CNL(19)
c                               !-> resulting array with splain coefficients
c  for muon energy losses due to photonuclear interaction with energy
c  transfers > EMIN. It is cooked within subroutine SPL1 and passed to
c  subroutine GETDEDPH to get energy losses for any muon energy 10 GeV --
c  1000 PeV by interpolation
       common /sok1_n2/ CNC2(67)
c                               !-> resulting array with splain coef-s
c  for muon photonuclear interaction total cross-section with energy
c  transfers > VMIN. It is cooked within subroutine SPL1 and passed to
c  subroutine GLPHNUV to get mean free path for any muon energy 10 GeV
c  -- 1000 PeV by interpolation
       common /sok5_n2/ CNL2(67)
c                               !-> resulting array with splain coef-s
c  for muon energy losses due to photonuclear interaction with energy
c  transfers > VMIN. It is cooked within subroutine SPL1 and passed to
c  subroutine GDEDPHV to get energy losses for any muon energy 10 GeV --
c  1000 PeV by interpolation
       common /sok5_n3/ CNL3(19)
c                               !-> resulting array with splain coef-s
c  for total muon energy losses due to photonuclear interaction. It is
c  cooked within subroutine SPL1 and passed to subroutine GDEDPHT to get
c  energy losses for any muon energy 10 GeV -- 1000 PeV by interpolation.
       common /sok1_e/ CEC(19)
c                               !-> resulting array with splain coefficients
c  for delta electrons total cross-section with energy transfers > EMIN. It
c  is cooked within subroutine SPL1 and passed to subroutine GETCTEL to get
c  cross-section values for any muon energy 10 GeV -- 1000 PeV by
c  interpolation
       common /sok5_e/ CEL(19)
c                               !-> resulting array with splain coefficients
c  for muon energy losses due to delta electrons production with energy
c  transfers > EMIN. It is cooked within subroutine SPL1 and passed to
c  subroutine GETDEDEL to get energy losses for any muon energy 10 GeV --
c  1000 PeV by interpolation
       common /sok1_e2/ CEC2(19)
c                               !-> resulting array with splain coefficients
c  for delta electrons total cross-section with energy transfers > VMIN. It
c  is cooked within subroutine SPL1 and passed to subroutine GLELECV to get
c  mean free path for any muon energy 10 GeV -- 1000 PeV by interpolation.
       common /sok5_e2/ CEL2(19)
c                               !-> resulting array with splain coefficients
c  for muon energy losses due to delta electrons production with energy
c  transfers > VMIN. It is cooked within subroutine SPL1 and passed to
c  subroutine GDEDELV to get energy losses for any muon energy 10 GeV --
c  1000 PeV by interpolation
       common /sok5_e3ex/ CEBB(19)
c                               !-> resulting array with splain coefficients
c  for total muon energy losses due to ionisation calculated by Bethe-Bloch
c  formula. It is cooked within subroutine SPL1 and passed to subroutine
c  GDEDELBB to get energy losses for any muon energy 10 GeV -- 1000 PeV by
c  interpolation
       common /sok5_e4ex/ CEBBB(19)
c                               !-> resulting array with splain coef-s
c  for total muon energy losses due to ionisation calculated by Bethe-Bloch
c  formula + e-diagram for bremsstrahlung. It is cooked within subroutine SPL1
c  and passed to subroutine GDEDELT1 to get energy losses for any muon energy
c  10 GeV -- 1000 PeV by interpolation
       common /elem/ CLE(19)
c                               !-> resulting array with splain coefficients
c  for muon "continuous energy losses" below EMIN.
       common /elvm/ CLV(19)
c                               !-> resulting array with splain coefficients
c  for muon "continuous energy losses" below VMIN.
       common /eminl1/ CLE1(19)
c                               !-> resulting array with splain coefficients
c  for muon free path between 2 interactions with energy transfers > EMIN.
       common /sok5_e5/ CETOT(103)
c                               !-> resulting array with splain coef-s
c  for total muon energy losses due to ionisation calculated by Bethe-Bloch
c  formula + e-diagram for bremsstrahlung. It is cooked within subroutine SPL1
c  and passed to subroutine GDEDELT2 to get energy losses for any muon energy
c  below 10 GeV by interpolation
       common /sok55_p/ CPC1(2203)
c                               !-> resulting array with splain coefficients
c for comparison function to simulate muon energy transfers due to pair
c production. It is cooked within SPL1 subroutine and passed to COMP to get
c value of comparison function at any relative energy transfer by
c interpolation.
       dimension IJ(26)
c                !---> array which contains dimensions for input 1-di-
c  mentional arrays. Dimension of output arrays with splains should be equal
c  to (I+2), where I is dimension for corresponding input 1-dimensional array.
       dimension xmin1(26),st1(26),xmax1(26)
c                                       !-> arrays with first values,
c  steps and last values of arguments for all input arrays (see above)
       dimension F(2201),C(2203)
c                       !-> Auxiliary arrays
c
      data xmin1/1.e+0,1.e+0,1.e+0,1.e+0,1.e+0,1.e+0,1.e+0,1.e+0,1.e+0,   !
     +           1.e+0,1.e+0,1.e+0,1.e+0,1.e+0,1.e+0,1.e+0,1.e+0,1.e+0,   !
     +           1.e+0,1.e+0,1.e+0,1.e+0,1.e+0,-1.1e+1,-.853871964,       !
     +           1.e+0/                                                   !
      data xmax1/9.e+0,9.e+0,9.e+0,9.e+0,9.e+0,9.e+0,9.e+0,9.e+0,         !
     +           9.e+0,9.e+0,9.e+0,9.e+0,9.e+0,9.e+0,9.e+0,9.e+0,9.e+0,   !
     +           9.e+0,9.e+0,9.e+0,9.e+0,9.e+0,9.e+0,0.e+0,1.146128036,   !
     +           9.e+0/                                                   !
      data st1/5.e-1,5.e-1,5.e-1,5.e-1,5.e-1,5.e-1,5.e-1,5.e-1,           !
     +         5.e-1,5.e-1,5.e-1,5.e-1,1.25e-1,1.25e-1,5.e-1,5.e-1,       !
     +         5.e-1,5.e-1,5.e-1,5.e-1,5.e-1,5.e-1,5.e-1,5.e-3,2.e-2,     !
     +         5.e-1/                                                     !
c First values, last values and steps of argument for all input arrays
c                             (see above)
c
      data IJ/17,17,17,17,17,17,17,17,17,17,17,17,65,65,    !-> dimensions for
     +        17,17,17,17,17,17,17,17,17,2201,101,17/       !   all input arrays
c
      do lik=1,26  !--> A cycle along all input arrays
          N = IJ(lik)  !--> Getting dimension for given input array
c
          if (lik.eq.1) then     ! GETTING FIRST VALUE,
           xmin1_c = xmin1(lik)  !      STEP AND LAST VALUE OF ARGUMENT
           st1_c = st1(lik)      !         FOR ALL INPUT ARRAYS
           xmax1_c = xmax1(lik)  !           IN ACCORDING WITH THEIR NUMBERS
          endif                  !                     ( LIK )
          if (lik.eq.2) then     !
           xmin1_l = xmin1(lik)  !
           st1_l = st1(lik)      !
           xmax1_l = xmax1(lik)  !
          endif                  !
          if (lik.eq.13) then    !
           xmin1_nc = xmin1(lik) !
           st1_nc = st1(lik)     !
           xmax1_nc = xmax1(lik) !
          endif                  !
          if (lik.eq.14) then    !
           xmin1_nl = xmin1(lik) !
           st1_nl = st1(lik)     !
           xmax1_nl = xmax1(lik) !
          endif                  !
          if (lik.eq.24) then    !
           xmin1_p = xmin1(lik)  !
           st1_p = st1(lik)      !
           xmax1_p = xmax1(lik)  !
          endif                  !
          if (lik.eq.25) then    !
           xmin1_lo = xmin1(lik) !
           st1_lo = st1(lik)     !
           xmax1_lo = xmax1(lik) !
          endif                  !
          if (lik.eq.26) then    !
           xm1 = xmin1(lik)      !
           s1 = st1(lik)         !
           xma1 = xmax1(lik)     !
          endif                  !
c                                ---------------
          do jj=1,N                            !
            if (lik.eq.1) F(jj) = FBC(jj)      !
            if (lik.eq.2) F(jj) = FBL(jj)      !
            if (lik.eq.3) F(jj) = FBC2(jj)     ! Filling the auxiliary array
            if (lik.eq.4) F(jj) = FBL2(jj)     ! F with values of input array
            if (lik.eq.5) F(jj) = FBL3(jj)     ! number LIK for further
            if (lik.eq.6) F(jj) = FPC(jj)      !                processing.
            if (lik.eq.7) F(jj) = FPL(jj)      !
            if (lik.eq.8) F(jj) = FPC2(jj)     !
            if (lik.eq.9) F(jj) = FPL2(jj)     !
            if (lik.eq.10) F(jj) = FPL3(jj)    !
            if (lik.eq.11) F(jj) = FNC(jj)     !
            if (lik.eq.12) F(jj) = FNL(jj)     !
            if (lik.eq.13) F(jj) = FNC2(jj)    !
            if (lik.eq.14) F(jj) = FNL2(jj)    !
            if (lik.eq.15) F(jj) = FNL3(jj)    !
            if (lik.eq.16) F(jj) = FEC(jj)     !
            if (lik.eq.17) F(jj) = FEL(jj)     !
            if (lik.eq.18) F(jj) = FEC2(jj)    !
            if (lik.eq.19) F(jj) = FEL2(jj)    !
            if (lik.eq.20) F(jj) = FELBB(jj)   !
            if (lik.eq.21) F(jj) = FELBBB(jj)  !
            if (lik.eq.22) F(jj) = elosemin(jj)!
            if (lik.eq.23) F(jj) = elosvmin(jj)!
            if (lik.eq.24) F(jj) = com_pa_m(jj)!
            if (lik.eq.25) F(jj) = FELOWTOT(jj)!
            if (lik.eq.26) F(jj) = eminleng(jj)!
           enddo                               !
c----------------------------------------------!
      C(1)=1.4375*F(1)-1.3750*F(2)+0.4375*F(3)  !
      C(2)=0.4375*F(1)+0.1250*F(2)-0.0625*F(3)    !
      DO 1 K=3,N                                   ! ---> Cooking splains
1     C(K)= 0.6250*F(K-1)-0.0625*(F(K-2)+F(K))     !     and putting them into
      C(N+1)=0.4375*F(N)+0.1250*F(N-1)-0.0625*F(N-2)!     auxiliary array C
      C(N+2)=1.4375*F(N)-1.375*F(N-1)+0.4375*F(N-2) !
c----------------------------------------------------
         mo = N+2                          !
         do jj=1,mo                        ! Splain coefficients from C are
           if (lik.eq.1) CBC(jj) = C(jj)   ! put into corresponding array N LIK
           if (lik.eq.2) CBL(jj) = C(jj)   ! which is passed to corresponding
           if (lik.eq.3) CBC2(jj) = C(jj)  ! subroutine for interpolation.
           if (lik.eq.4) CBL2(jj) = C(jj)  !
           if (lik.eq.5) CBL3(jj) = C(jj)  !
           if (lik.eq.6) CPC(jj) = C(jj)   !
           if (lik.eq.7) CPL(jj) = C(jj)   !
           if (lik.eq.8) CPC2(jj) = C(jj)  !
           if (lik.eq.9) CPL2(jj) = C(jj)  !
           if (lik.eq.10) CPL3(jj) = C(jj) !
           if (lik.eq.11) CNC(jj) = C(jj)  !
           if (lik.eq.12) CNL(jj) = C(jj)  !
           if (lik.eq.13) CNC2(jj) = C(jj) !
           if (lik.eq.14) CNL2(jj) = C(jj) !
           if (lik.eq.15) CNL3(jj) = C(jj) !
           if (lik.eq.16) CEC(jj) = C(jj)  !
           if (lik.eq.17) CEL(jj) = C(jj)  !
           if (lik.eq.18) CEC2(jj) = C(jj) !
           if (lik.eq.19) CEL2(jj) = C(jj) !
           if (lik.eq.20) CEBB(jj) = C(jj) !
           if (lik.eq.21) CEBBB(jj) = C(jj)!
           if (lik.eq.22) CLE(jj) = C(jj)  !
           if (lik.eq.23) CLV(jj) = C(jj)  !
           if (lik.eq.24) CPC1(jj) = C(jj) !
           if (lik.eq.25) CETOT(jj) = C(jj)!
           if (lik.eq.26) CLE1(jj) = C(jj) !
         enddo                             !
      enddo
      RETURN
      END
****************************************************************************
* C.4
      SUBROUTINE dspl1
*
*  THE ROUTINE USES A PART OF splain.f CODE (~/flib/splain.f) DEVELOPED AT
*                         IRKUTSK STATE UNIVERSITY
*
*   DSPL1 produces arrays of REAL*8 splain coefficients for 1-dimensional
*        interpolation and passes them to corresponding subroutines.
* It is absolutely the same as SPL1 subroutine but works with REAL*8 arrays
*                          both at input at output.
*  .....................................................................
c For next 3 lines see comments below for commons /sok24/, /sok26/ and /sok25/:
      real*8 com_pa_in(1101)
      real*8 CP_1(1103)
      real*8 xmin_p1,st_p1,xmax_p1
      real*8 xmin1(1),st1(1),xmax1(1)
                                    !-> arrays with first value, step and last
c                                       value of argument for all input arrays
c                                       (see also comments to common /sok25/)
c
c     F(1101),C(1103) - Auxiliary arrays
      real*8 F(1101),C(1103)
      common /sok24/ com_pa_in
c                              !-> input from PAIR1 subroutine. Contains 1101
c values for integrated comparison function to simulate energy transfers due
c to e+e- pair production. See comments to subroutine PAIR1 for more details.
      common /sok26/ CP_1
c                     !-> resulting array with splain coefficients for
c integrated  comparison function to simulate energy transfers due to e+e-
c pair production. It is an output of DSPL1 subroutine which is passed then
c to C_PA_IN routine to get value of comparison function at any energy
c transfer by interpolation.
      common /sok25/ xmin_p1,st_p1,xmax_p1
c                                 !-> values for the first value, step
c and last value of argument for input array COM_PA_IN. Are passed along with
c output splain array CP_1 to C_PA_IN routine.
      dimension IJ(1)
                   !-> array which contains dimensions for output 1-dimensi-
c onal arrays. Dimension of output arrays with splains should be equal to
c (I+2), where I is dimension for corresponding input 1-dimensional array.
c
c     xmin1 - FIRST VALUES OF ARGUMENTS  !
c     xmax1 - LAST VALUES OF ARGUMENTS   ! for all input arrays (see above)
c     st1   - STEPS OF ARGUMENTS         !
      data xmin1/-1.1d+1/
      data xmax1/0.d+0/
      data st1/1.d-2/
      data IJ/1101/
c                 !-> dimensions for all input arrays
c
      do lik=1,1  !--> A cycle along all input arrays
          N = IJ(lik) !--> Getting dimension for given input array
c
          if (lik.eq.1) then     ! GETTING FIRST VALUE, STEP AND LAST VALUE
           xmin_p1 = xmin1(lik)  ! OF ARGUMENTS FOR ALL INPUT ARRAYS IN
           st_p1 = st1(lik)      ! ACCORDING TO THEIR NUMBERS (LIK)
           xmax_p1 = xmax1(lik)  !
          endif                  !
c
          do jj=1,N                             ! Filling the auxiliary array F
            if (lik.eq.1) F(jj) = com_pa_in(jj) ! with values of corresponding
          enddo                                 ! input array Nb. LIK
c
      C(1)=1.4375*F(1)-1.3750*F(2)+0.4375*F(3)        !
      C(2)=0.4375*F(1)+0.1250*F(2)-0.0625*F(3)        ! Cooking splain
      DO 1 K=3,N                                      ! coefficients and
1     C(K)= 0.6250*F(K-1)-0.0625*(F(K-2)+F(K))        ! putting them into
      C(N+1)=0.4375*F(N)+0.1250*F(N-1)-0.0625*F(N-2)  ! auxiliary array C
      C(N+2)=1.4375*F(N)-1.375*F(N-1)+0.4375*F(N-2)   !
c
         mo = N+2                         ! Splain coefficients from C are
         do jj=1,mo                       ! put into corresponding output
           if (lik.eq.1) CP_1(jj) = C(jj) ! array Nb. LIK which is passe to
         enddo                            ! corresponding subroutine
c                                         ! for interpolation
      enddo
      RETURN
      END
****************************************************************************
* C.5
         SUBROUTINE spl2
*
*  THE ROUTINE USES A PART OF splain.f CODE (~/flib/splain.f) DEVELOPED AT
*                         IRKUTSK STATE UNIVERSITY
*
* SPL2 produces arrays of splain coefficients for 2-dimensional interpolation
*      and passes them via common blocks to corresponding subroutines.
*  .....................................................................
       common /cdbr_in/ FB1(81,54),FB3(81,101),FB2(81,51) ! It is input from
c subroutine gamma1 with values of differential cross-sections for muon brem-
c strahlung for different energies (10 GeV -- 1000 PeV) and relative energy
c transfers (10^(-11) -- 1)
       common /cdpa_in/ FP1(81,54),FP3(81,101),FP2(81,51) ! It is input from
c subroutine pair1 with values of differential cross-sections for muon pairs
c production for different energies (10 GeV -- 1000 PeV) and relative energy
c transfers (10^(-11) -- 1)
       common /cdph_in/ FN1(81,54),FN3(81,101),FN2(81,51) ! It is input from
c subroutine phnu1 with values of differential cross-sections for muon pho-
c tonuclear interaction for different energies (10 GeV -- 1000 PeV) and rela-
c tive energy transfers (10^(-11) -- 1)
       common /sok3/ CB1(4648) ! It is resulting arrays with splain coeffici-
       common /sok6/ CB2(4399) ! cients for 2-dimensional interpolation to
       common /sok4/ CB3(8549) ! obtain differential cross-section for muon
c bremsstrahlung. These arrays are cooked out of FB1,FB2 and FB3 arrays, res-
c pectively and are passed via commons /sok3/, /sok6/ and /sok4/ to routines
c GETCDBR1, GETCDBR2 and GETCDBR_3E which perform interpolation.
       common /sok8/ CP1(4648)  ! It is resulting arrays with splain coeffici-
       common /sok9/ CP2(4399)  ! cients for 2-dimensional interpolation to
       common /sok10/ CP3(8549) ! obtain differential cross-section for muon
c pair production. These arrays are cooked out of FP1,FP2 and FP3 arrays, res-
c pectively and are passed via commons /sok8/, /sok9/ and /sok10/ to routines
c GETCDP1, GETCDP2 and GETCDP_3E which perform interpolation.
       common /mum8/ CN1(4648)  ! It is resulting arrays with splain coeffici-
       common /mum9/ CN2(4399)  ! cients for 2-dimensional interpolation to
       common /mum10/ CN3(8549) ! obtain differential cross-section for muon
c photonuclear interaction. These arrays are cooked out of FN1,FN2 and FN3
c arrays, respectively and are passed via commons /mum8/, /mum9/ and /mum10/
c to routines GETCDN1, GETCDN2 and GETCDN_3E which perform interpolation.
       common /sok_2_1/ NX_1,NY_1,X0_1,SX_1,Y0_1,SY_1 ! It is commons with va-
       common /sok_2_2/ NX_2,NY_2,X0_2,SX_2,Y0_2,SY_2 ! lues for nb. of X (1),
       common /sok_2_3/ NX_3,NY_3,X0_3,SX_3,Y0_3,SY_3 ! Y (2), initial X (3),
c                         ^    ^    ^    ^    ^    ^
c                         1    2    3    4    5    6
c
c step by X (4), initial Y (5) and step by Y (6) for input 2-dimensional ar-
c rays of which splains are prepared. All these values are assigned below
c within SPL2 routine and passed to corresponding routines via commons along
c with resulting arrays containing splains: /sok_2_1/ to getcdbr1, getcdp1
c and getcdn1 (input arrays FB1, FP1 and FN1, output arrays CB1, CP1 and
c CN1), /sok_2_2/ to getcdbr2, getcdp2 and getcdn2 (input arrays FB2, FP2
c and FN2, output arrays CB2, CP2 and CN2), /sok_2_3/ to getcdbr_3e, getcdp_3e
c and getcdn_3e (input arrays FB2, FP2 and FN2, output arrays CB2, CP2 and
c CN2).
c
      DIMENSION D(90,110),FU(81,101),CU(8549) !------->  Auxiliary arrays
c
c     FOR BELOW REFERENCED ARRAYS THE ORDER OF VALUES IS AS FOLLOWS:
c
c     1 - for FB1 and CB1
c     2 - for FB2 and CB2
c     3 - for FB3 and CB3
c     4 - for FP1 and CP1
c     5 - for FP2 and CP2
c     6 - for FP3 and CP3
c     7 - for FN1 and CN1
c     8 - for FN2 and CN2
c     9 - for FN3 and CN3
c
      DIMENSION NXG(9),NYG(9),X0G(9),SXG(9),Y0G(9),SYG(9) ! -> arrays which
c  contain values for above referenced initial values, number of values and
c  steps (see above commons /sok_2_1/, /sok_2_2/, /sok_2_3/ etc.).
      DIMENSION IJ(9) !---> array which contains dimensions for output 1-di-
c  mentional arrays with splains. Dimension of output array should be equal
c  to (I+2)*(J+2), where I and J are dimensions for corresponding input 2-di-
c  mensional array.
      data NXG/81,81,81,81,81,81,81,81,81/     ! See comments above for ex-
      data NYG/54,51,101,54,51,101,54,51,101/  ! planations of these DATAs
      data X0G/1.e+0,1.e+0,1.e+0,1.e+0,1.e+0,1.e+0,1.e+0,1.e+0,1.e+0/    !
      data SXG/1.e-1,1.e-1,1.e-1,1.e-1,1.e-1,1.e-1,1.e-1,1.e-1,1.e-1/    !
      data Y0G/-11.,-6.e-1,-1.e-1,-11.,-6.e-1,-1.e-1,-11.,-6.e-1,-1.e-1/ !
      data SYG/2.e-1,1.e-2,1.e-3,2.e-1,1.e-2,1.e-3,2.e-1,1.e-2,1.e-3/    !
      data IJ/4648,4399,8549,4648,4399,8549,4648,4399,8549/              !
c
      do li=1,9 ! A cycle along all input arrays
      NX = NXG(li)  ! assigns values from corresponding arrays for numbers of
      NY = NYG(li)  ! values, steps and initial values
      X0 = X0G(li)  !
      SX = SXG(li)  !
      Y0 = Y0G(li)  !
      SY = SYG(li)  !
c
       if (li.eq.1) then
         NX_1 = NX     !-> number of X values  !  For arrays FB1, FP1 and FN1,
         NY_1 = NY     !-> number of Y values  !  these values are passed to
         X0_1 = X0     !-> first value of X    !    GETCDBR1,  GETCDP1 and
         SX_1 = SX     !-> step by X           !  GETCDN1 via common /sok_2_1/
         Y0_1 = Y0     !-> first value of Y    !
         SY_1 = SY     !-> step by Y           !
       endif
c
       if (li.eq.2) then
         NX_2 = NX    !-> number of X values  ! For arrays FB2, FP2 and FN2,
         NY_2 = NY    !-> number of Y values  ! these values are passed to
         X0_2 = X0    !-> first value of X    !    GETCDBR2, GETCDP2  and
         SX_2 = SX    !-> step by X           ! GETCDN2 via common /sok_2_2/
         Y0_2 = Y0    !-> first value of Y    !
         SY_2 = SY    !-> step by Y           !
       endif
c
       if (li.eq.3) then
         NX_3 = NX    !-> number of X values  !  For arrays FB3, FP3 and FN3,
         NY_3 = NY    !-> number of Y values  !   these values are passed to
         X0_3 = X0    !-> first value of X    !     GETCDBR_3E, GETCDP_3E and
         SX_3 = SX    !-> step by X           ! GETCDN_3E via common  /sok_2_3/
         Y0_3 = Y0    !-> first value of Y    !
         SY_3 = SY    !-> step by Y           !
       endif
c
        do ki=1,NX                                ! Filling an auxiliary
           do kl=1,NY                             ! array FU by values
              if (li.eq.1) FU(ki,kl) = FB1(ki,kl) ! from input array
              if (li.eq.2) FU(ki,kl) = FB2(ki,kl) ! (within a cycle by LI
              if (li.eq.3) FU(ki,kl) = FB3(ki,kl) ! along all input
              if (li.eq.4) FU(ki,kl) = FP1(ki,kl) ! arrays)
              if (li.eq.5) FU(ki,kl) = FP2(ki,kl) !
              if (li.eq.6) FU(ki,kl) = FP3(ki,kl) !
              if (li.eq.7) FU(ki,kl) = FN1(ki,kl) !
              if (li.eq.8) FU(ki,kl) = FN2(ki,kl) !
              if (li.eq.9) FU(ki,kl) = FN3(ki,kl) !
           enddo                                  !
        enddo                                     !
cccccccc 2019 - ATTENTION!
      I2=1
cccccccc
c-----------------------------------
      DO 1 J=1,NY                  !
      J2=J+2                       !
      DO 1 I=1,NX                  !
      I2=I+2                       !
1     D(I2,J2)=3.90625E-3*FU(I,J)  !
      J1=NY+1                      !
      J3=J2+1                      !
      J4=J3+1                      !
      DO 2 I=3,I2                  !
      A=D(I,3)                     !
      B=D(I,4)                     !---> Cooking splain coefficients
      D(I,2)=3.*(A-B)+D(I,5)       !     out of input array Nb. LI
      D(I,1)=3.*(D(I,2)-A)+B       !     and putting these splains
      A=D(I,J1)                    !     into 1-dimensional array
      B=D(I,J2)                    !                 CU
      D(I,J3)=3.*(B-A)+D(I,NY)     !
2     D(I,J4)=3.*(D(I,J3)-B)+A     !
      I1=NX+1                      !
      I3=I2+1                      !
      I4=I3+1                      !
      DO 3 J=1,J4                  !
      A=D(3,J)                     !
      B=D(4,J)                     !
      D(2,J)=3.*(A-B)+D(5,J)       !
      D(1,J)=3.*(D(2,J)-A)+B       !
      A=D(I1,J)                    !
      B=D(I2,J)                    !
      D(I3,J)=3.*(B-A)+D(NX,J)       !
3     D(I4,J)=3.*(D(I3,J)-B)+A         !
      DO 4 J=1,J2                        !
      J3=J+1                               !
      J4=J+2                                 !
      M=(J-1)*I2                               !
      DO 4 I=1,I2                                !
      I3=I+1                                       !
      I4=I+2                                         !
4     CU(M+I)=D(I,J)+D(I,J4)+D(I4,J)+D(I4,J4)+D(I3,J3)* !
     *100.-(D(I3,J)+D(I,J3)+D(I4,J3)+D(I3,J4))*10.      !
c--------------------------------------------------------
       ko = IJ(li)
       do ki=1,ko                            !
              if (li.eq.1) CB1(ki) = CU(ki)  ! Passing the values of splain
              if (li.eq.2) CB2(ki) = CU(ki)  ! coefficients form auxiliary
              if (li.eq.3) CB3(ki) = CU(ki)  ! array CU to corresponding
              if (li.eq.4) CP1(ki) = CU(ki)  ! output array Nb. LI
              if (li.eq.5) CP2(ki) = CU(ki)  !
              if (li.eq.6) CP3(ki) = CU(ki)  !
              if (li.eq.7) CN1(ki) = CU(ki)  !
              if (li.eq.8) CN2(ki) = CU(ki)  !
              if (li.eq.9) CN3(ki) = CU(ki)  !
       enddo                                 !
      enddo
      RETURN
      END
****************************************************************************
* C.6
        SUBROUTINE enlos
*
*  The subroutine calculates the total "continuous" energy losses below the
*    threshold EMIN (ENLOSEMIN(17) array) and below VMIN (ENLOSVMIN(17)).
* It also computes the mean free path between two interactions with energy
*                      transfers > EMIN (EMINLENG(17)).
*  These arrays are passed to SPL1 subroutine to cook splains for further
*                               interpolation.
*...........................................................................
      common /elbr_in1/ elo_br1(17),elo_br2(17)
      common /elbr_in2/ elo_br3(17)
      common /elbr_in4/ elo_br4(17)
      common /ctbr_in1/ crt_br1(17),crt_br2(17)
c                     ----------------------------> From GAMMA1
      common /elpa_in1/ elo_pa1(17),elo_pa2(17)
      common /elpa_in2/ elo_pa3(17)
      common /elpa_in4/ elo_pa4(17)
      common /ctpa_in1/ crt_pa1(17),crt_pa2(17)
c                     ----------------------------> From PAIR1
      common /elph_in1/ elo_ph1(17),elo_ph2(65)
      common /elph_in2/ elo_ph3(17)
      common /elph_in4/ elo_ph4(17)
      common /ctph_in1/ crt_ph1(17),crt_ph2(65)
c                     ----------------------------> From PHNU1
      common /elel_in1/ elo_el1(17),elo_el2(17)
      common /elel_in2/ elel_bb(17),elel_bbb(17)
      common /ctel_in1/ crt_el1(17),crt_el2(17)
c                    -----------------------------> From ELEC1
      common /con_los/ elosemin(17),elosvmin(17)
      common /eleng/ eminleng(17)
c                    -----------------------------> to SPL1
      do i=1,17
       j = (4 * i) - 3
       elosemin(i) = elo_br4(i)
       elosvmin(i) = (1.e+1**elo_br3(i)) - (1.e+1**elo_br2(i))
       elosemin(i) = elosemin(i) + elo_pa4(i)
       elosvmin(i) = elosvmin(i) + exp(elo_pa3(i)) - exp(elo_pa2(i))
       elosemin(i) = elosemin(i) + elo_ph4(i)
       elosvmin(i) = elosvmin(i) + 1.e+1**elo_ph3(i) - 1.e+1**elo_ph2(j)
       elosemin(i) = elosemin(i) + elel_bbb(i) - 1.e+1**elo_el1(i)
       elosvmin(i) = elosvmin(i) + elel_bbb(i) - 1.e+1**elo_el2(i)
       elosvmin(i) = alog(elosvmin(i))
       eminleng(i) = 1./crt_br1(i) + 1./exp(crt_pa1(i)) +
     +                              1./exp(crt_ph1(i)) + 1./crt_el1(i)
       eminleng(i) = 1./eminleng(i)
      enddo
      return
      end
****************************************************************************
* C.7
             FUNCTION cone(X)
*
*  THE ROUTINE USES A PART OF splain.f CODE (~/flib/splain.f) DEVELOPED AT
*                         IRKUTSK STATE UNIVERSITY
*
*   The subroutine calculates the value for total continuous muon energy
*    losses with energy transfers below EMIN using splain coefficients
*                     prepared by spl1 subroutine.
*
*          X is a value for muon energy expressed in GeV; XMIN,
*  XMAX and STEP are assigned with some values in subroutine SPL1 (they
*               are passed here via /sok5/ common block).
*   Array with spalin coefficients C(19) is passed here from SPL1 via
*                              common /elem/
*  ......................................................................
*  ***   ATTENTION: X must be within a range of 10 GeV --- 1000 PeV   ***
*  ......................................................................
      COMMON /sok5/ XMIN,STEP,XMAX
      common /elem/ C(19)
      real*4 X
      X1 = alog10(X)
       if ((X1.lt..99999e+0).or.(X1.gt.9.0001e+0)) then
       print*,'ERROR IN FUNCTION CONE: MUON ENERGY IS OUT OF RANGE'
       endif
      Y = (X1-XMIN)/STEP
      I = INT(Y+0.5)
      IF(I.LT.0.OR.X1.GT.XMAX) PRINT 1,X1,XMIN,XMAX
      Y = Y-I
      Z = Y*Y + 0.25
      cone = (Z-Y)*C(I+1) + (2.-(Z+Z))*C(I+2) + (Z+Y)*C(I+3)
      RETURN
1     FORMAT('*MISTAKE*X1=',D23.16,'XMIN=',D23.16,'XMAX=',D23.16)
      END
****************************************************************************
* C.8
             FUNCTION conv(X)
*
*  THE ROUTINE USES A PART OF splain.f CODE (~/flib/splain.f) DEVELOPED AT
*                         IRKUTSK STATE UNIVERSITY
*
*   The subroutine calculates the value for total continuous muon energy
*    losses with energy transfers below VMIN using splain coefficients
*                     prepared by spl1 subroutine.
*
*          X is a value for muon energy expressed in GeV; XMIN,
*  XMAX and STEP are assigned with some values in subroutine SPL1 (they
*               are passed here via /sok5/ common block).
*   Array with spalin coefficients C(19) is passed here from SPL1 via
*                              common /elvm/
*  ......................................................................
*  ***   ATTENTION: X must be within a range of 10 GeV --- 1000 PeV   ***
*  ......................................................................
      COMMON /sok5/ XMIN,STEP,XMAX
      common /elvm/ C(19)
      real*4 X
      X1 = alog10(X)
       if ((X1.lt..99999e+0).or.(X1.gt.9.0001e+0)) then
       print*,'ERROR IN FUNCTION CONV: MUON ENERGY IS OUT OF RANGE'
       endif
      Y = (X1-XMIN)/STEP
      I = INT(Y+0.5)
      IF(I.LT.0.OR.X1.GT.XMAX) PRINT 1,X1,XMIN,XMAX
      Y = Y-I
      Z = Y*Y + 0.25
      conv = (Z-Y)*C(I+1) + (2.-(Z+Z))*C(I+2) + (Z+Y)*C(I+3)
      conv = exp(conv)
      RETURN
1     FORMAT('*MISTAKE*X1=',D23.16,'XMIN=',D23.16,'XMAX=',D23.16)
      END
****************************************************************************
* C.9
         FUNCTION gemleng(X)
*
*  THE ROUTINE USES A PART OF splain.f CODE (~/flib/splain.f) DEVELOPED AT
*                         IRKUTSK STATE UNIVERSITY
*
*  The subroutine calculates the value for muon free path between 2 inte-
* ractions with energy transfers > EMIN using splain coefficients prepared
*                          by spl1 subroutine.
*
*          X is a value for muon energy expressed in GeV; XMIN,
*  XMAX and STEP are assigned with some values in subroutine SPL1 (they
*               are passed here via /eminl/ common block).
*   Array with spalin coefficients C(19) is passed here from SPL1 via
*                              common /eminl1/
*  ......................................................................
*  ***   ATTENTION: X must be within a range of 10 GeV --- 1000 PeV   ***
*  ......................................................................
      COMMON /eminl/ XMIN,STEP,XMAX
      common /eminl1/ C(19)
      real*4 x
      X1 = alog10(X)
       if ((X1.lt..99999e+0).or.(X1.gt.9.0001e+0)) then
       print*,'ERROR IN FUNCTION GEMLENG: MUON ENERGY IS OUT OF RANGE'
       endif
      Y = (X1-XMIN)/STEP
      I = INT(Y+0.5)
      IF(I.LT.0.OR.X1.GT.XMAX) PRINT 1,X1,XMIN,XMAX
      Y = Y-I
      Z = Y*Y + 0.25
      gemleng= (Z-Y)*C(I+1) + (2.-(Z+Z))*C(I+2) + (Z+Y)*C(I+3)
      RETURN
1     FORMAT('*MISTAKE*X1=',D23.16,'XMIN=',D23.16,'XMAX=',D23.16)
      END
****************************************************************************
* C.10
      subroutine frepathv
*
* This subroutine prepares the arrays to simulate the muon passage through
*  thick layers of matter with a model in which energy losses are divided
*   into i/ "continuous" losses with energy transfers less than VMIN and
*     ii/ "catastrophic" losses with energy transfers more than VMIN.
*  Firstly, the energy range 10 GeV -- 1 EeV is divided in 128 subranges
*    where "continuous" losses (calculated by CONV routine) are good
*   approximated linearly - dE/dx = a*E + b - and corresponding a and b
*         for each subrange are computed (a(0:128), b(0:128)).
*  Also for each subrange values of integrals (1) and (2) are computed:
*
*            E0
*        INTEGRAL (dE / (dE/dx(E)["continuous"])   (1) -> leng(0:128)
*         10 GeV
*
*      E0
*  INTEGRAL (dE / (dE/dx(E)["continuous"] * L_mean(E))  (2) -> eta(0:128)
*    10 GeV
*
*             where E0 is an "upper" edge of each segment:
*
*
*    leng(128),eta(128)                                leng(1),eta(1)
*                                 .......
*         a,b(128)                                         a,b(1)
*            |                                               |
*            V                                               V
*      *-----------*-----------*    ...    *-----------*-----------*
*   e0(128)     e0(127)      e0(126)     e0(2)       e0(1)       e0(0)
*   10 GeV        ........           1 EeV * fk^2  1 EeV * fk    1 EeV
*
*
*         e0(i): muon energy at the end of a segment Nb. i
*                (starting from larger energy)
*
*         a(i),b(i): dE/dx(E) is pesentaed as a linear function
*                    (a(i) * E) + b(i) at segment Nb. i
*
*                 e0(i-1)
*      leng(i) = INTEGRAL (dE/(dE/dx(E))) - path which is passed by muon
*                 10 GeV                    without energy transfers > Vmin
*                                           starting with E = 10 GeV and
*                                           finishing with E = e0(i-1)
*
*                 e0(i-1)
*       eta(i) = INTEGRAL (dE / ( dE/dx(E) * L_mean(E) )
*                 10 GeV
*
*               All this is necessary in further calculations to:
*
*  - get the value of real free path between two interaction with energy
*    transfers > VMIN taking into account that mean free path is not a
*    constant but a function of muon energy L_mean(E). So, to get the
*    energy E1 at the end of free path without energy transfers > Vmin
*    if current muon energy is equal to E0 and ETA = -ln(RNDM) where
*    RNDM is a random number uniformly distributed in a range 0. -- 1.
*    one need to solve the equation
*
*                E0
*             INTEGRAL (dE / ( dE/dx(E) * L_mean(E) ) = ETA     (3)
*                E1
*
*   instead of using L_mean(E0).
*
*  - get the muon energy at the end of free path between two interaction
*    if current muon energy is E0 and random number is ETA
*
*  - get the muon energy at a distance L from current point (looking back)
*    if its current energy is equal to E1 and it is known that there were
*    not catastrophic interactions at the path L.
*
*               THE OUTPUT OF SUBROUTINE IS AS FOLLOWS:
*
*   1. Arrays e0(0:128) a(0:128), b(0:128) and leng(1:128) which are used
*      just inside this routine but also are passed via COMMON /simv1/ to
*      routine GETEBACK along with constants FK, FK1, and DLNMAX which
*      are necessary to determine the number subrange to which given
*      muon energy belongs. All this represents REAL*8 arrays and
*      constants.
*
*   2. Array VPATH(111,161) with 17871 values of real free path (cm, see
*      above) for 111 values of ETA and 161 values of E0. It is passed
*      via common /vrand1/ to SPL2_2 routine to cook splain coefficients
*      which allow to calculate the real free path in further computing.
*      If muon energy at the end of free path is less than 10 GeV, the
*      real free path is calculated as  path till the point where muon
*      energy is equal to 10 GeV. Actually, elements of array represents
*      the values of real free path divided by ETA to make interpolation
*      to be more accurate.
*
*   3. Array VENER(111,161) for energy at the end of real free path which
*      is determined at the same grid of initial energies and ETA as
*      VPATH(111,161) array. If energy at the end of real free path is
*      less than 10 GeV, the value of given VENER is assigned to 10 GeV.
*      Actually, the elements of VENER are calculated as E1/E0 where
*      E0 is muon energy at the beginning of real free path, E1 is muon
*      energy at the end of free path. Array is passed via common
*      /vrand2/ to SPL2_2 routine to cook splain coefficients which allow
*      to calculate the real free path in further computing.
*
      external glbremv,glpairv,glphnuv,glelecv,conv,dsimps,gdedelt2
      real*8 e0(0:128),a(0:128),b(0:128),eta(0:128),leng(0:128)
      real*8 fk,fk1,dlnmax,slu,e,en,delta
      real*8 low,up,step1,aux1(0:10),rest,eta_1,hd3,pat1,pat2
      real*8 ene,path
      real*8 dsimps
      common /vrand1/ vpath(111,161)
      common /vrand2/ vener(111,161)
      common /simv1/ fk,fk1,dlnmax,a,b,leng,e0
c
c   ---------------------------------------------------------------
c   1. Computing arrays e0(0:128), a(0:128), b(0:128), eta(0:128),
c           leng(0:128) and constants FK, FK1 and DLNMAX
c
      fk=dexp(-(dlog(1.d+1)/1.6d+1)) !--> a coefficient to get
      fk1 = 1.d+0 / dlog(fk)         !    e0(i)=fk*e0(i-1) and
      dlnmax = dlog(1.d+9)           !    some useful constants
c
      e0(0) = 1.d+9
        do i=1,128
        e0(i) = e0(0) * (fk**dble(i))         !-> e0(i)
        y2 = (conv(sngl(e0(i-1))) * 1.e-3)    !-> dE/dx (e0(i-1))
        y1 = (conv(sngl(e0(i))) * 1.e-3)      !-> dE/dx (e0(i))
        a(i) = dble((y2 - y1)) / (e0(i-1) - e0(i)) !-> a(i)
        b(i) = dble(y1) - a(i) * e0(i)             !-> b(i)
c
c                     Computing two integrals
c
c       ..................................................
c       .             e0(i-1)                            .
c       .   eta(i) = INTEGRAL(dE/(dE/dx(E) * L_mean(E))  .
c       .              e0(i)                             .
c       .                                                .
c       .                  e0(i-1)                       .
c       .       leng(i) = INTEGRAL (dE/(dE/dx(E)))       .
c       .                  e0(i)                         .
c       ..................................................
c
c using a formula INTEGRAL [f(x) * dx] = INTEGRAL [x * f(x) * d(ln(x))] :
c
        low = dlog(e0(i))
        up = dlog(e0(i-1))
        lim1 = 10
        step1 = (up - low) / dble(lim1)
         do j=0,lim1
         ene = low + (dble(j) * step1)
         h1 = sngl(dexp(ene))
         help = (1./glbremv(h1)) + (1./glpairv(h1)) + (1./glphnuv(h1)) +
     +           (1./glelecv(h1))
c
         aux1(j) = (1.d+0 / dble(help)) * dble(conv(h1))*1.d-3/dble(h1)
         aux1(j) = 1.d+0 / aux1(j)
         enddo
         eta(i) = dsimps(aux1,low,up,lim1)
c
         do j=0,lim1
         ene = low + (dble(j) * step1)
         h1 = sngl(dexp(ene))
         aux1(j) = dble(conv(h1)) * 1.d-3 / dble(h1)
         aux1(j) = 1.d+0 / aux1(j)
         enddo
         leng(i) = dsimps(aux1,low,up,lim1)
        enddo
c
      do i=127,1,-1
c
c              e0(i-1)
c   leng(i) = INTEGRAL (dE/(dE/dx(E))) :
c              10 GeV
c
      leng(i) = leng(i) + leng(i+1)
c
c            e0(i-1)
c  eta(i) = INTEGRAL(dE/(dE/dx(E) * L_mean(E))) :
c            10 GeV
c
      eta(i) = eta(i) + eta(i+1)
      enddo
c
c   Auxiliary arrays a(128), b(128), e0(128), eta(128), leng(128)
c                    have been prepared.
c   ---------------------------------------------------------------
c                       2. Solving the equation (3)
c
c  to get the final energy E1 for a set of E0 ("e" variable) and
c                        ETA ("slu" variable):
c
      do i=-80,30             !--> 111 values of SLU (logarithmi-
        slu = dble(i) * 5.d-2 !    cally equidistant grid with
        slu = 1.d+1**slu      !    slu_min=0.0001, slu_max=1000
        do j=180,20,-1         !-> 161 values of E (logarithmi-
          e = dble(j) * 5.d-2  !   cally equidistant grid with
          e = 1.d+1**e         !   e_min = 10 GeV, e_max = 1 EeV
            if (e.le.1.011d+1) then
            ene = 1.0000001d+1
            path = 0.d+0
            goto 444
            endif
c        vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv
          me = idint( ( dlog(e) - dlog(1.d+9) ) / dlog(fk) ) + 1
c        ME is a number of segment which contains given energy E
c        ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
c                       Rewriting the equation (3) as
c
c                   E0         E0         E1
c                INTEGRAL = INTEGRAL - INTEGRAL = ETA  (3a)
c                   E1       10 GeV     10 GeV
c
c                                 or
c
c                     E1         E0
c                  INTEGRAL = INTEGRAL - ETA = ETA_1   (3b)
c                   10 GeV     10 GeV
c
            if (me.lt.128) then
            eta_1 = eta(me+1) - slu
            else
            eta_1 = (-1.d+0) * slu
            endif
        low = dlog(e0(me))
        up = dlog(e)
        lim1 = 10
        step1 = (up - low) / dble(lim1)
         do j1=0,lim1
         en = low + (dble(j1) * step1)
         h1 = sngl(dexp(en))
         help = (1./glbremv(h1)) + (1./glpairv(h1)) + (1./glphnuv(h1)) +
     +           (1./glelecv(h1))
         aux1(j1) = (1.d+0 / dble(help)) * dble(conv(h1))*1.d-3/dble(h1)
         aux1(j1) = 1.d+0 / aux1(j1)
         enddo
         eta_1 = eta_1 + dsimps(aux1,low,up,lim1)
c---------------------------------
        if (eta_1.le.0.d+0) then !
        ene = 1.0000001d+1       !--> no interactions with energy transfers
        m1 = 128                 !              transfers > Vmin,
        goto 402                 !         the final energy is 10 GeV
        endif                    !
c---------------------------------
            m1 = 500
            do m=128,1,-1
              if (eta(m).ge.eta_1) then
              m1 = m
              goto 401
              endif
            enddo
          if (m1.ge.200) then
          hd3 = dabs((eta(1) - eta_1) / eta(1))
             if (hd3.le.1.d-6) then
             m1 = 1
             eta_1 = eta(1)*9.9999999d-1
             goto 401
             endif
          print*,'******** SUBROUTINE FREPATV:  ERROR !!!!! ********'
          goto 402
          endif
  401     continue
            if (m1.lt.128) then
            rest = eta_1 - eta(m1+1)
            else
            rest = eta_1
            endif
c
         ic = 0
         lim1 = 10
         ene = (e0(m1-1) + e0(m1)) * 5.d-1
         delta = e0(m1-1) - ene
         low = dlog(e0(m1))
 3333    up = dlog(ene)
         step1 = (up - low) / dble(lim1)
         do j1=0,lim1
         en = low + (dble(j1) * step1)
         h1 = sngl(dexp(en))
         help = (1./glbremv(h1)) + (1./glpairv(h1)) + (1./glphnuv(h1)) +
     +           (1./glelecv(h1))
         aux1(j1) = (1.d+0 / dble(help)) * dble(conv(h1))*1.d-3/dble(h1)
         aux1(j1) = 1.d+0 / aux1(j1)
         enddo
         pat1 = dsimps(aux1,low,up,lim1)
         delta = 5.d-1 * delta
         ic = ic + 1
         if (pat1.le.rest) then
         ene = ene + delta
         else
         ene = ene - delta
         endif
         if (ic.eq.20) then
         goto 402
         endif
         goto 3333
 402     continue
c
c            Equation (3) has been solved., the root is ENE
c   ---------------------------------------------------------------
c            3. Computing of real free path from E0 to ENE:
c
c                            E0
c                  PATH = INTEGRAL [ dE/(dE/dx(E)) ] =
c                            ENE
c
c          E0                          ENE
c     = INTEGRAL [ dE/(dE/dx(E)) ] - INTEGRAL [ dE/(dE/dx(E)) ]
c        10 GeV                       10 GeV
c
      if (me.lt.128) then
        low = dlog(e0(me))
        up = dlog(e)
        lim1 = 10
        step1 = (up - low) / dble(lim1)
         do j2=0,lim1
         en = low + (dble(j2) * step1)
         h1 = sngl(dexp(en))
         aux1(j2) = dble(conv(h1)) * 1.d-3 / dble(h1)
         aux1(j2) = 1.d+0 / aux1(j2)
         enddo
         pat1 = dsimps(aux1,low,up,lim1) + leng(me+1)
      else
        low = dlog(e0(me))
        up = dlog(e)
        lim1 = 10
        step1 = (up - low) / dble(lim1)
         do j2=0,lim1
         en = low + (dble(j2) * step1)
         h1 = sngl(dexp(en))
         aux1(j2) = dble(conv(h1)) * 1.d-3 / dble(h1)
         aux1(j2) = 1.d+0 / aux1(j2)
         enddo
         pat1 = dsimps(aux1,low,up,lim1)
      endif
c
      if (m1.lt.128) then
        low = dlog(e0(m1))
        up = dlog(ene)
        lim1 = 10
        step1 = (up - low) / dble(lim1)
         do j2=0,lim1
         en = low + (dble(j2) * step1)
         h1 = sngl(dexp(en))
         aux1(j2) = dble(conv(h1)) * 1.d-3 / dble(h1)
         aux1(j2) = 1.d+0 / aux1(j2)
         enddo
         pat2 = dsimps(aux1,low,up,lim1) + leng(m1+1)
      else
        low = dlog(e0(m1))
        up = dlog(ene)
        lim1 = 10
        step1 = (up - low) / dble(lim1)
         do j2=0,lim1
         en = low + (dble(j2) * step1)
         h1 = sngl(dexp(en))
         aux1(j2) = dble(conv(h1)) * 1.d-3 / dble(h1)
         aux1(j2) = 1.d+0 / aux1(j2)
         enddo
         pat2 = dsimps(aux1,low,up,lim1)
      endif
      path = pat1 - pat2
c
c          The equation is solved, the root is PATH
c
  444 continue
      if (path.le.0.d+0) path = 1.d+0
      if (ene.le.1.00001d+1) ene = 9.999d+0
      path = path/slu
      ene = ene / e
      vpath(i+81,j-19) = sngl(path)
      vener(i+81,j-19) = sngl(ene)
        enddo
      enddo
c
      return
      end
****************************************************************************
* C.11
         SUBROUTINE spl2_2
*
*  THE ROUTINE USES A PART OF splain.f CODE (~/flib/splain.f) DEVELOPED AT
*                         IRKUTSK STATE UNIVERSITY
*
*     SPL2_2 produces arrays of splain coefficients for 2-dimensional
*    interpolation and passes them via common blocks to corresponding
*                             subroutines.
*  .....................................................................
      common /vrand1/ vpath(111,161) !-> input arrays from FREPATHV
      common /vrand2/ vener(111,161) !          routine
c
      common /vrand1_o/ CPA(18419)   !-> output arrays with splain coef-
      common /vrand2_o/ CEN(18419)   !   ficients to be passed to routines
c GETERNAV and GETLANRV to perform interpolation
c
       common /vpath1/ NX_1,NY_1,X0_1,SX_1,Y0_1,SY_1 !-> constants to be
       common /vpath2/ NX_2,NY_2,X0_2,SX_2,Y0_2,SY_2 !   passed to GETERANV
c and GETLANRV along with splains to perform interpolation (for explanati-
c ons see comments to SPL2 routine).
c
      DIMENSION D(130,180),FU(111,161),CU(18419) !----->  Auxiliary arrays
c
      DIMENSION NXG(2),NYG(2),X0G(2),SXG(2),Y0G(2),SYG(2) ! -> some arrays
c which contain values for NX_1, NY_1, etc. (see comments to COMMONs
c /vpath1/ and /vpath2/ above).
c
      DIMENSION IJ(2) !---> array which contains dimensions for output 1-di-
c  mentional arrays with splains. Dimension of output array should be equal
c  to (I+2)*(J+2), where I and J are dimensions for corresponding input 2-di-
c  mensional array.
      data NXG/111,111/        ! See comments above for ex-
      data NYG/161,161/        ! pla nations of these DATAs
      data X0G/-4.,-4./        !
      data SXG/5.e-2,5.e-2/    !
      data Y0G/1.,1./          !
      data SYG/5.e-2,5.e-2/    !
      data IJ/18419,18419/     !
c
      do li=1,2     ! A cycle along all input arrays
      NX = NXG(li)  ! assigns values from corresponding arrays for numbers of
      NY = NYG(li)  ! values, steps and initial values
      X0 = X0G(li)  !
      SX = SXG(li)  !
      Y0 = Y0G(li)  !
      SY = SYG(li)  !
c
       if (li.eq.1) then
         NX_1 = NX     !-> number of X values
         NY_1 = NY     !-> number of Y values
         X0_1 = X0     !-> first value of X
         SX_1 = SX     !-> step by X
         Y0_1 = Y0     !-> first value of Y
         SY_1 = SY     !-> step by Y
       endif
c
       if (li.eq.2) then
         NX_2 = NX    !-> number of X values
         NY_2 = NY    !-> number of Y values
         X0_2 = X0    !-> first value of X
         SX_2 = SX    !-> step by X
         Y0_2 = Y0    !-> first value of Y
         SY_2 = SY    !-> step by Y
       endif
c
        do ki=1,NX                                ! Filling an auxiliary
           do kl=1,NY                              ! array FU by values
              if (li.eq.1) FU(ki,kl) = vpath(ki,kl) ! from input array
              if (li.eq.2) FU(ki,kl) = vener(ki,kl) ! (within a cycle by
c                                                  ! LI along all input
c                                                 ! arrays)
           enddo                                 !
        enddo                                   !
cccccccc 2019 - ATTENTION!
      I2=1
cccccccc
c-----------------------------------------------
      DO 1 J=1,NY                  !
      J2=J+2                       !
      DO 1 I=1,NX                  !
      I2=I+2                       !
1     D(I2,J2)=3.90625E-3*FU(I,J)  !
      J1=NY+1                      !
      J3=J2+1                      !
      J4=J3+1                      !
      DO 2 I=3,I2                  !
      A=D(I,3)                     !
      B=D(I,4)                     !---> Cooking splain coefficients
      D(I,2)=3.*(A-B)+D(I,5)       !     out of input array Nb. LI
      D(I,1)=3.*(D(I,2)-A)+B       !     and putting these splains
      A=D(I,J1)                    !     into 1-dimensional array
      B=D(I,J2)                    !                 CU
      D(I,J3)=3.*(B-A)+D(I,NY)     !
2     D(I,J4)=3.*(D(I,J3)-B)+A     !
      I1=NX+1                      !
      I3=I2+1                      !
      I4=I3+1                      !
      DO 3 J=1,J4                  !
      A=D(3,J)                     !
      B=D(4,J)                     !
      D(2,J)=3.*(A-B)+D(5,J)       !
      D(1,J)=3.*(D(2,J)-A)+B       !
      A=D(I1,J)                    !
      B=D(I2,J)                    !
      D(I3,J)=3.*(B-A)+D(NX,J)       !
3     D(I4,J)=3.*(D(I3,J)-B)+A         !
      DO 4 J=1,J2                        !
      J3=J+1                               !
      J4=J+2                                 !
      M=(J-1)*I2                               !
      DO 4 I=1,I2                                !
      I3=I+1                                       !
      I4=I+2                                         !
4     CU(M+I)=D(I,J)+D(I,J4)+D(I4,J)+D(I4,J4)+D(I3,J3)* !
     *100.-(D(I3,J)+D(I,J3)+D(I4,J3)+D(I3,J4))*10.      !
c--------------------------------------------------------
       ko = IJ(li)
       do ki=1,ko                            !
              if (li.eq.1) CPA(ki) = CU(ki)  ! Passing the values of splain
              if (li.eq.2) CEN(ki) = CU(ki)  ! coefficients form auxiliary
c                                            ! array CU to corresponding
c                                            ! output array Nb. LI
       enddo                                 !
      enddo
      RETURN
      END
****************************************************************************
* C.12
       FUNCTION getlanrv(X,Y)
*
*  THE ROUTINE USES A PART OF splain.f CODE (~/flib/splain.f) DEVELOPED AT
*                         IRKUTSK STATE UNIVERSITY
*
*    The routine performs a splain interpolation by splain coefficients
*   prepared by SPL2_2 routine. It determines a value for real free path
* without energy transfers > VMIN if initial muon energy is equal to Y (GeV)
*   and X = -ln(RNDM) (RNDM is a random number uniformly distributed in a
*     range of 0. -- 1.). Y should be within a range of 10 GeV - 1 EeV,
*                   X should be in a range 0.0001 - 31.62.
* The output GETLANRV(X,Y) represent the value for real free path (cm) for
*                               given X and Y.
*  ......................................................................
       common /vrand1_o/ C1(18419)
       common /vpath1/ NX,NY,X0,SX,Y0,SY
       real*4 X,Y
c
      X_1=alog10(X)
      if ((X_1.lt.-4.0001).or.(X_1.gt.1.5001)) then
      print*,'ERROR IN FUNCTION GETLANRV: RANDOM NB. IS OUT OF RANGE'
      endif
c
      Y_1=alog10(Y)
      if ((Y_1.lt..99999).or.(Y_1.gt.9.0001)) then
      print*,'ERROR IN FUNCTION GETLANRV: MUON ENERGY IS OUT OF RANGE'
      endif
c
      A3=(X_1-X0)/SX
      B3=(Y_1-Y0)/SY
      M1=INT(A3+.5)
      M2=INT(B3+.5)
      M3=NX+2
      IF(M1.LT.0.OR.M1.GE.NX.OR.M2.LT.0.OR.M2.GE.NY) THEN
      PRINT 1,X_1,M1,Y_1,M2
      ENDIF
      A3=A3-M1
      B3=B3-M2
      M1=M2*M3+M1+1
      M2=M1+M3
      M3=M2+M3
      A2 = A3*A3 +.25
      B2 = B3*B3 +.25
      A1=A2-A3
      B1=B2-B3
      A3=A2+A3
      B3=B2+B3
      A2=2.-(A2+A2)
      B2=2.-(B2+B2)
      getlanrv=(A1*C1(M1)+A2*C1(M1+1)+A3*C1(M1+2))*B1
     2      +(A1*C1(M2)+A2*C1(M2+1)+A3*C1(M2+2))*B2
     3      +(A1*C1(M3)+A2*C1(M3+1)+A3*C1(M3+2))*B3
      getlanrv = getlanrv * X
      RETURN
1     FORMAT('*MISTAKE*X=',D23.16,'MX=',I4,'Y=',D23.16,'MY=',I4)
      END
****************************************************************************
* C.13
       FUNCTION geteranv(X,Y)
*
*  THE ROUTINE USES A PART OF splain.f CODE (~/flib/splain.f) DEVELOPED AT
*                         IRKUTSK STATE UNIVERSITY
*
*     The routine performs a splain interpolation by splain coefficients
*  prepared by SPL2_2 routine. It determines a value for muon energy at the
*   end of real free path without energy transfers > VMIN if initial muon
*   energy is equal to Y (GeV) and X = -ln(RNDM) (RNDM is a random number
*  uniformly distributed in a range of 0. -- 1.). Y should be within a range
*      of 10 GeV - 1 EeV, X should be in a range 0.0001 - 31.62.
*  The output GETERANV(X,Y) represent the relation of muon energy at the end
*         of free path to initial energy for given X and Y.
*  ......................................................................
       common /vrand2_o/ C1(18419)
       common /vpath2/ NX,NY,X0,SX,Y0,SY
       real*4 X,Y
c
      X_1=alog10(X)
      if ((X_1.lt.-4.0001).or.(X_1.gt.1.5001)) then
      print*,'ERROR IN FUNCTION GETERANV: RANDOM NB. IS OUT OF RANGE'
      endif
c
      Y_1=alog10(Y)
      if ((Y_1.lt..99999).or.(Y_1.gt.9.0001)) then
      print*,'ERROR IN FUNCTION GETERANV: MUON ENERGY IS OUT OF RANGE'
      endif
c
      A3=(X_1-X0)/SX
      B3=(Y_1-Y0)/SY
      M1=INT(A3+.5)
      M2=INT(B3+.5)
      M3=NX+2
      IF(M1.LT.0.OR.M1.GE.NX.OR.M2.LT.0.OR.M2.GE.NY) THEN
      PRINT 1,X_1,M1,Y_1,M2
      ENDIF
      A3=A3-M1
      B3=B3-M2
      M1=M2*M3+M1+1
      M2=M1+M3
      M3=M2+M3
      A2 = A3*A3 +.25
      B2 = B3*B3 +.25
      A1=A2-A3
      B1=B2-B3
      A3=A2+A3
      B3=B2+B3
      A2=2.-(A2+A2)
      B2=2.-(B2+B2)
      geteranv=(A1*C1(M1)+A2*C1(M1+1)+A3*C1(M1+2))*B1
     2      +(A1*C1(M2)+A2*C1(M2+1)+A3*C1(M2+2))*B2
     3      +(A1*C1(M3)+A2*C1(M3+1)+A3*C1(M3+2))*B3
      RETURN
1     FORMAT('*MISTAKE*X=',D23.16,'MX=',I4,'Y=',D23.16,'MY=',I4)
      END
****************************************************************************
* C.14
      function geteback(e1,backl)
*
* The routine gives the energy ENE at the beginning of muon free path without
*   interactions with energy transfers > Vmin if its energy at the end of
*    this free path is equal to E1 (GeV) and length of free path is BACKL
*   (cm). Routine uses arrays A, B, LENG, E0, and constants FK, FK1, DLMAX
*      which were prepared during initialization by SUBROUTINE FREEPATHV.
*                  The method is to solve an equation
*
*                    ENE
*                  INTEGRAL (dE / ( dE/dx(E) ) = BACKL    (*)
*                     E1
*
*   BACKL should be in a range 1 cm -- 100 km, E1 should be in a range
*    10 GeV -- 1 EeV, the output is energy expressed in GeV. If ENE is
*       found to be more than 1 EeV it is assigned by 1.00001 EeV.
* ........................................................................
      real*8 fk,fk1,dlnmax,a(0:128),b(0:128),leng(0:128),e0(0:128)
      real*8 e,ene,rest,pat1,path
      real*4 e1,backl
      common /simv1/ fk,fk1,dlnmax,a,b,leng,e0
c
          e = dble(e1)
          path = dble(backl)
          if (e.ge.1.d+9) then  !
          ene = 1.00001+9         !-> if E = 1 EeV than let's
          goto 1402                !    ENE to be 1 EeV, too
          endif
c       vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv
        me = idint( ( dlog(e) - dlnmax ) * fk1 )  + 1
        if (me.gt.128) me = 128
c       ME is a number of segment which contains given energy E
c                (see comments to subroutine FREPATHV )
c       ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
c                       Rewriting the equation (*) as
c
c                  ENE         ENE        E1
c                INTEGRAL = INTEGRAL - INTEGRAL = PATH
c                  E1        10 GeV     10 GeV
c
c                                 or
c
c                     ENE        E1
c                  INTEGRAL = INTEGRAL + PATH = PAT1 (**)
c                   10 GeV     10 GeV
c
            if (me.lt.128) then
            pat1 = leng(me+1) + path
            else
            pat1 = path
            endif
c
c                        Computing of PAT1 as
c
c                                        a(me)*E + b(me)
c       pat1 = pat1 + (1/a(me)) * ln(---------------------)
c                                     a(me)*e0(me) + b(me)
c
c      where [a * E + b] is a linear presentation of dE/dx(E):
c
            pat1=pat1+dlog((a(me)*e+b(me))/(a(me)*e0(me)+b(me)))/a(me)
c
            m1 = 500
            do m=128,1,-1
              if (leng(m).ge.pat1) then
              m1 = m
              goto 1401
              endif
            enddo
           if (m1.ge.200) then  ! -> ENE for given PATH is more
           ene = 1.00001d+9     !    than 1 EeV (out of reason-
           goto 1402            !     able range) - let it be
           endif                !           just 1 EeV
 1401       continue
            if (m1.lt.128) then
            rest = pat1 - leng(m1+1)
            else
            rest = pat1
            endif
c
c   The only thing to do to find a root of equation (*) is now to
c           solve the following equation for variable ENE:
c
c                             a(m1)*ENE + b(m1)
c           (1/a(m1)) * ln(---------------------) = rest
c                           a(m1)*e0(m1) + b(m1)
c
c      where [a * E + b] is a linear presentation of dE/dx(E):
c
          ene = ((a(m1)*e0(m1)+b(m1))*dexp(rest*a(m1))-b(m1))/a(m1)
 1402     continue
          geteback = sngl(ene)
      return
      end
c
****************************************************************************
* C.15
       subroutine earray1(e,depth)
*
*   Simulates the passage of muon through an array at the distance = DEPTH
*   (cm) if initial muon energy is equal to E (GeV). Uses a model in which
*   energy losses are divided into 2 part: "continuous" losses with energy
*  transfers < EMIN and "catastrophic" losses with energy transfers > EMIN.
*
*                             OUTPUT:
*                             =======
*
*  The procedure gives some "history" of simulation which is kept by arrays
*  arrays ityp_e(20000), eleng_e(20000), ener1_e(20000),ener2_e(20000) and
* constant NUMB_E. All this is passed via common/EHISTORY/ to program block
* from which EARRAY1 was called. This block must contain the following lines:
*
*                             .....
*       dimension ityp_e(20000),eleng_e(20000),ener1_e(20000),
*     +           ener2_e(20000)
*       common /ehistory/ eleng_e,ener1_e,ener2_e,etr,numb_e,ityp_e
*                            .....
*
*
*         DESCRIPTION OF CONSTANTS AND ARRAYS OF COMMON /EHISTORY/ :
*
* NUMB_E (integer*4) is equal to number of interaction which occurred during
*                    simulation for given muon
*
* ITYP_E(i) (integer*4) gives the type of interaction nb. i which may be as
*                     follows:
*
*  0 - start of simulation
*  1 - muon has reached the DEPTH
*  2 - muon has stopped (its energy became less than 0.16 GeV)
*  4 - bremsstrahlung interactions occurred
*  5 - e+e- pair has been born
*  6 - photonuclear interaction occurred
*  7 - knock-on electron has been born (or bremsstrahlung interaction
*      with emmiting gamma by electron occurred)
*
*  ELENG_E(i) (real*4) - distance (cm) from the beginning of simulation
*                        till interaction nb. i
*
*  ENER1_E(i) (real*8) - energy (GeV) before interaction nb. i ! For ityp=
*                                                              !  0,1,2,3
*  ENER2_E(i) (real*8) - energy (GeV) after interaction nb. i ! it is the
*                                                              !    same
*
*  ETR(i) (real*4) - energy transfer due to interaction nb.i (GeV), is
*                    assigned by 0. if ITYP_E < 4
*
*     DEPTH should not be more than 2 km, E should be within a range
*                          10 GeV - 1 EeV.
* ........................................................................
       external getlpair,getlbrem,getlphnu,getlelec,simps,gdedelt2
       external gemleng
       real*8 e0,e1,e2,ener1_e(1000000),ener2_e(1000000)
       real*4 e,depth
       integer i_stat(6)
       dimension ityp_e(1000000),eleng_e(1000000),etr(1000000)
       dimension aux1(0:30)
ccc       integer kinlept
       common /what_lep/ kindlept
       common /ehistory/ eleng_e,ener1_e,ener2_e,etr,numb_e,ityp_e
       common /statistic/ i_stat
       parameter (itra=0)
c
      i_stat(2) = i_stat(2) + 1
      if (
     +         (i_stat(1).eq.0).AND.
     +         (i_stat(2).eq.1).AND.
     +         (i_stat(3).eq.0).AND.
     +         (i_stat(4).eq.0).AND.
     +         (i_stat(5).eq.0).AND.
     +         (i_stat(6).eq.0)
     +   ) then
            write(*,*) 'Initialization successful, running...'
      endif
c
c        Let's check if input is within allowed range;
c
ccc       if (depth.gt.2.0001e+5) then
       if (depth.gt.5.0001e+6) then
       print*,'FUNCTION EARRAY1: INPUT VALUE FOR DISTANCE ',depth,' cm'
       print*,'           IS TOO LARGE, WILL NOT WORK'
       return
       endif
       if ((e.gt.1.0001e+9).or.(e.lt.10.1)) then
       print*,'FUNCTION EARRAY1: INPUT VALUE FOR ENERGY ',e,' GeV'
       print*,'          IS OUT OF RANGE, WILL NOT WORK'
       return
       endif
       if(kindlept.ne.1) then
       print*,'Sorry, in current version EARRAY1 can not be used'
       print*,'for TAU lepton propagation. MUM has to stop'
       read*,kkk
       endif
c ----------------------------------> Tracking simulation history:
       numb_e = 1
       ityp_e(numb_e) = 0
       eleng_e(numb_e) = 0.
       ener1_e(numb_e) = dble(e)
       ener2_e(numb_e) = dble(e)
       etr(numb_e) = 0.
c----------------------------------
       pat = 0.
       e0 = dble(e)
    1  eta = -alog(rndm_mum(5))
       preal = eta * gemleng(sngl(e0))
       elos = cone(sngl(e0))
       e1 = e0 - dble(elos * preal * 1.d-3)
       if (e1.le.1.d+1) then
        e1 = 1.d+1
        pat = pat + (sngl(e0 - e1)) * 1.e+3 / elos
           if (pat.ge.depth) then
           rest = pat - depth
           e1 = e1 + dble(elos * rest * 1.e-3)
c ----------------------------------> Tracking simulation history:
           numb_e = numb_e + 1
           ityp_e(numb_e) = 1
           eleng_e(numb_e) = depth
           ener1_e(numb_e) = e1
           ener2_e(numb_e) = e1
           etr(numb_e) = 0.
c----------------------------------
           return
           endif
        el = sngl(e1)
        rest = depth - pat
        goto 4321
       else
        pat = pat + preal
           if (pat.ge.depth) then
           rest = pat - depth
           e1 = e1 + dble(elos * rest * 1.e-3)
c ----------------------------------> Tracking simulation history:
           numb_e = numb_e + 1
           ityp_e(numb_e) = 1
           eleng_e(numb_e) = depth
           ener1_e(numb_e) = e1
           ener2_e(numb_e) = e1
           etr(numb_e) = 0.
c----------------------------------
           return
           endif
        numb_e = numb_e + 1
c                         !-> Tracking simulation history
c---------------------------------->Computing of "weight" fordifferent
c                                   interactions at current muon energy.
        e11 = sngl(e1)
        pb = 1./getlbrem(e11)
        pp = pb + 1./getlpair(e11)
        pn = pp + 1./getlphnu(e11)
        pt = pn + 1./getlelec(e11)
c----------------------------------
        ranp = rndm_mum(8) * pt
c                             !---------> Simulation of interaction type
        if(ranp.le.pb) then
c                   !-> type was simulated as bremsstrahlung,
         call getvbrem(e11,v,itra)
c                               !-> simulate rel. energy transfer
         ityp_e(numb_e) = 4
c                         !-> tracking simulation history
         else
          if(ranp.le.pp) then
c                     !-> type was simulated as e+e- pair,
          call getvpa(e11,v,itra)
c                             !-> simulate rel. energy transfer
         ityp_e(numb_e) = 5
c                         !-> tracking simulation history
          else
              if (ranp.le.pn) then
c                          !-> type was simulated as photonuc.,
              call getvph(e11,v,itra)
c                                  !-> simulate rel. energy transfer
              ityp_e(numb_e) = 6
c                              !-> tracking simulation history
                else
              call getvel(e11,v,itra)
c                                  !-> type was simulated as knock-on
c                                  !  electron, simulate en. transfer
              ityp_e(numb_e) = 7
c                              !-> tracking simulation history
              endif
          endif
        endif
        e2 = e1 * ( 1.d+0 - dble(v) )
c                                ! -> The energy after interaction
c----------------------------------------> tracking simulation history:
           eleng_e(numb_e) = pat
           ener1_e(numb_e) = e1
           ener2_e(numb_e) = e2
ccc           etr(numb_e) = dble(v) * e1
           etr(numb_e) = v * sngl(e1)
c---------------------------------------
          if (e2.le.1.d+1) then
             if (e2.le.1.6d-1) then
c                           !-> the muon stops (energy is below
                            !   the Cherenkov threshold in water)
                 e2 = 1.d-2
c-----------------------------------------> tracking simulation history
                 numb_e = numb_e + 1
                 ityp_e(numb_e) = 2
                 eleng_e(numb_e) = pat
                 ener1_e(numb_e) = e2
                 ener2_e(numb_e) = e2
                 etr(numb_e) = 0.
c----------------------------------------
                 return
c                     !   Assign energy = 0.01 and return...
             else
                 rest = depth - pat
                 el=sngl(e2)
c                         !-> muon has not stopped but its energy is
                          !   less than 10 GeV. Jump to label 4321...
                 goto 4321
             endif
          else
             e0 = e2
c                  !-> muon energy is above 10 GeV. Jump to
c                  !   label 1 to repeat everything once
c                  !          again...
             goto 1
          endif
       endif
c
c  Muon energy becomes less than 10 GeV. Compute the rest of its
c          travel with continuous losses only:
c
 4321   lim1 = 30
        elow = alog(1.6e-1)
        up = alog(el)
        step1 = (up - elow) / float(lim1)
         do j1=0,lim1
         en = elow + (float(j1) * step1)
         h1 = exp(en)
         aux1(j1) = h1 * 1.e+3 / gdedelt2(h1)
         enddo
         pat1 = simps(aux1,elow,up,lim1)
         if (pat1.lt.rest) then
c                       ! Muon energy becomes < 0.16
c                       ! GeV before it reaches DEPTH
         e1 = 1.d-2
c---------------------------------------> tracking simulation history
         numb_e = numb_e + 1
         ityp_e(numb_e) = 2
         eleng_e(numb_e) = pat + pat1
         ener1_e(numb_e) = e1
         ener2_e(numb_e) = e1
         etr(numb_e) = 0.
c--------------------------------------
         return
c             ! Energy = 0.01 GeV and return...
         endif
c------------------------------------------- Iteration procedure to obtain muon
c                                            energy at the DEPTH if his start
c                                            energy is less than 10 GeV (without
c                                            "catastrophic" part):
         ic = 0
         ene = (el + 1.59999e-1) * 5.e-1
         delta = el - ene
 3333    elow = alog(ene)
         step1 = (up - elow) / float(lim1)
         do j1=0,lim1
         en = elow + (float(j1) * step1)
         h1 = exp(en)
         aux1(j1) = h1 * 1.e+3 / gdedelt2(h1)
         enddo
         pat1 = simps(aux1,elow,up,lim1)
         delta = 5.e-1 * delta
         ic = ic + 1
         if (pat1.eq.rest) then
c                       !-> it seems incredible but sometimes it occurs...
         e1 = dble(ene)
c -------------------------------- -> tracking simulation history:
         numb_e = numb_e + 1
         ityp_e(numb_e) = 1
         eleng_e(numb_e) = depth
         ener1_e(numb_e) = e1
         ener2_e(numb_e) = e1
         etr(numb_e) = 0.
c --------------------------------
         return
         endif
         if (pat1.le.rest) then
         ene = ene - delta
         else
         ene = ene + delta
         endif
         if (ic.eq.14) then
         e1 = dble(ene)
c                    ! -> We have reach DEPTH and finish...
c --------------------------------!-> tracking simulation history:
         numb_e = numb_e + 1
         ityp_e(numb_e) = 1
         eleng_e(numb_e) = depth
         ener1_e(numb_e) = e1
         ener2_e(numb_e) = e1
         etr(numb_e) = 0
c --------------------------------
         return
         endif
         goto 3333
c----------------------------
      return
      end
****************************************************************************
* C.16
       subroutine earray2(e,en,etr,path,jtyp)
*
* Simulates "the next" interaction for a muon which passes an array if muon
*   energy is equal to E (GeV). Uses a model in which  energy losses are
* divided into 2 part: "continuous" losses with energy transfers < EMIN and
*        "catastrophic" losses with energy transfers > EMIN.
*
*                             INPUT:
*                             ======
*   E which is muon energy expressed in Gev (it should be less than 1 EeV)
*
*                             OUTPUT:
*                             =======
*
*  EN - the muon energy after the next interaction (including  !-> REAL*8
*       "continuous losses" till the point of interaction)     !
*  ETR - energy transfer (GeV) due to "next" interaction            ! REAL*4
*  PATH - distance from initial point to the next interaction (cm)  !
*  INTEGER*4 JTYP - type of interaction which may be as follows:
*
*  2 - muon has stopped (its energy became 0.16 GeV)
*  4 - bremsstrahlung interactions occurred
*  5 - e+e- pair has been born
*  6 - photonuclear interaction occurred
*  7 - knock-on electron has been born (or bremsstrahlung interaction
*      with emmiting gamma by electron occurred)
*
* If initial energy is less than 0.16 GeV, EN is assigned by a value of
*                             0.01 GeV
* ........................................................................
       external getlpair,getlbrem,getlphnu,getlelec,simps,gdedelt2
       external gemleng
       real*8 en,e1
       real*4 e,etr,path
       integer jtyp
       integer i_stat(6)
       dimension aux1(0:30)
ccc       integer kinlept
       common /what_lep/ kindlept
       common /statistic/ i_stat
       parameter (itra=0)
       intent (out) en
       intent (out) etr
       intent (out) path
       intent (out) jtyp
c
       i_stat(3) = i_stat(3) + 1
      if (
     +         (i_stat(1).eq.0).AND.
     +         (i_stat(2).eq.0).AND.
     +         (i_stat(3).eq.1).AND.
     +         (i_stat(4).eq.0).AND.
     +         (i_stat(5).eq.0).AND.
     +         (i_stat(6).eq.0)
     +   ) then
            write(*,*) 'Initialization successful, running...'
      endif
c
c        Let's check if input is within allowed range;
c
       if(kindlept.ne.1) then
       print*,'Sorry, in current version EARRAY1 can not be used'
       print*,'for TAU lepton propagation. MUM has to stop'
       read*,kkk
       endif
       if (e.gt.1.0001e+9) then
       print*,'FUNCTION EARRAY2: INPUT VALUE FOR ENERGY ',e,' GeV'
       print*,'          IS OUT OF RANGE, WILL NOT WORK'
       return
       endif
       e0 = e
       if (e0.lt..16) then
       en = 1.d-2
       etr = 0.
       jtyp = 2
       path = 0.
       return
       endif
       if (e0.le.10.) then
       pat = 0.
       el = e0
       goto 4321
       endif
       eta = -alog(rndm_mum(5))
       preal = eta * gemleng(e0)
       elos = cone(e0)
       e1 = dble(e0) - dble(elos * preal * 1.e-3)
       if (e1.le.1.d+1) then
        pat = (e0 - 10.) * 1.e+3 / elos
        el = 10.
        goto 4321
       else
        e11 = sngl(e1)
c-----------------------------------> Computing of "weight" for  different
c                                     interactions at current muon energy:
        pb = 1./getlbrem(e11)
        pp = pb + 1./getlpair(e11)
        pn = pp + 1./getlphnu(e11)
        pt = pn + 1./getlelec(e11)
c-------------------------------------
        ranp = rndm_mum(8) * pt
c                             !---------> Simulation of interaction type
        if(ranp.le.pb) then
c                   !-> type was simulated as bremsstrahlung,
         call getvbrem(e11,v,itra)
c                   !   simulate rel. energy transfer
         jtyp = 4
         else
          if(ranp.le.pp) then
c                     !-> type was simulated as e+e- pair,
          call getvpa(e11,v,itra)
c                     !   simulate rel. energy transfer
          jtyp = 5
          else
              if (ranp.le.pn) then
c                         !-> type was simulated as photonuc.,
c
              call getvph(e11,v,itra)
c                         !   simulate rel. energy transfer
              jtyp = 6
                else
              call getvel(e11,v,itra)
c                                 !-> type was simulated as knock-on
              jtyp = 7
c                                 !  electron, simulate en. transfer
              endif
          endif
        endif
        etr = sngl(e1) * v
c                        !-> transferred energy
        en = e1 * (1.d+0 - dble(v))
c                               ! -> The energy after interaction
        path = preal
        return
       endif
c
c  Muon energy becomes less than 10 GeV. Compute the rest of its
c          travel with continuous losses only:
c
 4321   lim1 = 30
        elow = alog(1.6e-1)
        up = alog(el)
        step1 = (up - elow) / float(lim1)
         do j1=0,lim1
         en1 = elow + (float(j1) * step1)
         h1 = exp(en1)
         aux1(j1) = h1 * 1.e+3 / gdedelt2(h1)
         enddo
         path = pat + simps(aux1,elow,up,lim1)
         en = 1.6d-1
         jtyp = 2
         etr = 0.
      return
      end
****************************************************************************
* C.17
       function enew(e,depth,iti,itime)
*
* Simulates the energy of muon/tau at a large depth = DEPTH (cm if IMED
* is positive and cmw.e. if IMED is negative) if initial muon/tau energy
* is equal to E (GEV). See detailed description in commented lines at
* the begiining of this file.
* ........................................................................
       external getlanrv,geteranv,geteback,gdedelt2,conv
       external glpairv,glbremv,glphnuv,glelecv,simps,dsimps
       real*8 rvec_own,eta,e0,pat,ddepth,e1d,pat1,pat2
       real*8 tlife,treal,tcum,time,time1,dta,deltat
       real*8 dsimps,low3,up3,step3,edur,aux2(0:1000)
       real*8 alfa,rm_e,rm_mu,r_e,avog
       real*8 spli
       real*8 TIME_L_T
       real*8 ttauin,ttauout
       real*4 e,depth
       integer iti,itime
       integer kindlept
       integer MODE
       integer MEDIUM
       integer i_stat(6)
       dimension aux1(0:30)
       dimension ityp(10000),eleng(10000),ener1(10000),ener2(10000)
       COMMON /MATTER/ MEDIUM
       COMMON /TAU_DECAY/ TIME_L_T,MODE
       common /const/ alfa,rm_e,rm_mu,r_e,avog
       common /what_lep/ kindlept
       common /const_t/ tlife
       common /vhistory/ numb,ityp,eleng,ener1,ener2
c       common /r48/ rvec
       common /timetau/ ttauin,ttauout
       common /statistic/ i_stat
       parameter (itra=1)
c       parameter (len=1)
       parameter (spli=2.99792458d+10)
c                                   !-> light velocity, cm/sec
ccccccccccccccccccccccccccc ATTENTION^ 2019:
      i_stat(1) = i_stat(1) + 1
      if (
     +         (i_stat(1).eq.1).AND.
     +         (i_stat(2).eq.0).AND.
     +         (i_stat(3).eq.0).AND.
     +         (i_stat(4).eq.0).AND.
     +         (i_stat(5).eq.0).AND.
     +         (i_stat(6).eq.0)
     +   ) then
            write(*,*) 'Initialization successful, running...'
      endif
      enew=1.e+20
ccccccccccccccccccccccccccc
c
c        Let's check if input is within allowed range;
c
       if (depth.gt.1.0001e+7) then
       print*,'FUNCTION ENEW: INPUT VALUE FOR DEPTH ',depth,' cm'
       print*,'           IS TOO LARGE, WILL NOT WORK'
       return
       endif
c
       if ((e.gt.1.0001e+9).or.(e.lt..16)) then
       print*,'FUNCTION ENEW: INPUT VALUE FOR ENERGY ',e,' GeV'
       print*,'          IS OUT OF RANGE, WILL NOT WORK'
       return
       endif
       if(kindlept.eq.1) then
c
******************** MUON: ************************************
c
       if(e.le.1.e+1) then !-> muon energy is less than 10 GeV
c -----------------------
       numb = 1         !
       ityp(numb) = 0   !
       eleng(numb) = 0. !-> Tracking simulation history
       ener1(numb) = e  !
       ener2(numb) = e  !
c------------------------
       el = e
       rest = depth
       pat = 0.d+0
       goto 4321
       endif
c -----------------------
       numb = 1         !
       ityp(numb) = 0   !
       eleng(numb) = 0. !-> Tracking simulation history
       ener1(numb) = e  !
       ener2(numb) = e  !
c------------------------
       ddepth = dble(depth)
       e0 = dble(e)
       pat = 0.d+0
    1  call rm48_own(rvec_own)
       eta = -dlog(rvec_own)
c                       !---> Simulation of random number
       if(eta.ge.3.16d+1) eta = 3.16d+1
       slu = sngl(eta)
       e0_sn = sngl(e0)
       if (slu.ge.1.e-4) then
       preal = getlanrv(slu,e0_sn)
c                              !-> getting the real free path
       e1d = e0 * dble(geteranv(slu,e0_sn))
c                                           !-> getting muon energy
c                                               at the end of free
c                                               path
       else
        preal = 0.
        e1d = e0
c              !--> simulated free path is too small, let
c              !    it be equal to zero...
       endif
        e1 = sngl(e1d)
c
       pat = pat + dble(preal)
       rest = sngl(ddepth - pat)
         if (rest.lt.0.) then   !-> muon has passed the DEPTH,
           rest = -rest           !
           if (rest.lt.1.) rest=1.  !  Computing its "back" energy
           if (e1.lt.10.) e1 = 10.   ! at the DEPTH and return...
           enew = geteback(e1,rest)  !
c-------------------------------
           numb = numb + 1     !
           ityp(numb) = 1      !-> Tracking
           eleng(numb) = depth ! simulation
           ener1(numb) = enew  !  history
           ener2(numb) = enew  !
c------------------------------
           return
         endif
c
         if (e1.le.1.e+1) then  !-> muon energy at the end of free
           el = 10.             !   path is less than 10 GeV (MUM..
c-----------------------------------                             .
           numb = numb + 1         !-> tracking                .
           ityp(numb) = 3          ! simulation              .
           eleng(numb) = sngl(pat) !  history              .
           ener1(numb) = el        !                    .
           ener2(numb) = el        !                 .
c---------------------------------...................
           goto 4321            ! ..does not compute some "catastrophic"
         endif                  !   losses below 10 GeV, jump to the
c                               !   label 4321 to go the rest of DEPTH
c                               !   with "continuous" losses only...
c
c---------------------------------- !-> Computing of "weight" for different
c                                   !   interactions at current muon energy.
       pb = 1./glbremv(e1)
       pp = pb + 1./glpairv(e1)
       pn = pp + 1./glphnuv(e1)
       pt = pn + 1./glelecv(e1)
c----------------------------------
       ranp = rndm_mum(5) * pt  ! -> Simulation of interaction type
       numb = numb + 1 !-> tracking simulation history
       if(ranp.le.pb) then        !-> type was simulated as bremsstrahlung,
       call getvbrem(e1,v,itra)
c                            !   simulate rel. energy transfer
       ityp(numb) = 4 !-> tracking simulation history
       else
          if(ranp.le.pp) then      !-> type was simulated as e+e- pair,
          call getvpa(e1,v,itra)
c                             !   simulate rel. energy transfer
          ityp(numb) = 5 !-> tracking simulation history
          else
              if (ranp.le.pn) then   !-> type was simulated as photonuc.,
              call getvph(e1,v,itra)
c                                !   simulate rel. energy transfer
              ityp(numb) = 6 !-> tracking simulation history
              else
              call getvel(e1,v,itra)
c                              !-> type was simulated as knock-on
c                              !  electron, simulate en. transfer
              ityp(numb) = 7 !-> tracking simulation history
              endif
           endif
        endif
        e2 = e1 * ( 1. - v ) ! -> The energy after interaction
c-----------------------------------
           eleng(numb) = sngl(pat) !
           ener1(numb) = e1        !-> tracking simulation history
           ener2(numb) = e2        !
c-----------------------------------
          if (e2.le.10.) then
             if (e2.le..16) then !-> the muon stops (energy is below
                 enew = 1.e-2    !   the Cherenkov threshold in water)
c----------------------------------------
                 numb = numb + 1         !
                 ityp(numb) = 2          !-> tracking simulation history
                 eleng(numb) = sngl(pat) !
                 ener1(numb) = enew      !
                 ener2(numb) = enew      !
c---------------------------------------
                 return          !   Assign ENEW = 0.01 and return...
             else
                 el=e2     !-> muon has not stopped but its energy is
                 goto 4321 !   less than 10 GeV. Jump to label 4321...
             endif
          else
             e0 = dble(e2)  !-> muon energy is above 10 GeV. Jump to
             goto 1         !   label 1 to repeat everything once
          endif             !          again...
c
c  Muon energy becomes less than 10 GeV. Compute the rest of its
c          travel with continuous losses only:
c
 4321   lim1 = 30
        elow = alog(1.6e-1)
        up = alog(el)
        step1 = (up - elow) / float(lim1)
         do j1=0,lim1
         en = elow + (float(j1) * step1)
         h1 = exp(en)
         aux1(j1) = h1 * 1.e+3 / gdedelt2(h1)
         enddo
         pat1 = simps(aux1,elow,up,lim1)
         if (pat1.lt.rest) then            ! Muon energy becomes < 0.16
         enew = 1.e-2                      ! GeV before it reaches DEPTH
c-----------------------------------------------
         numb = numb + 1                       !
         ityp(numb) = 2                        !-> tracking simulation
         eleng(numb) = sngl(pat + dble(pat1))  !     history
         ener1(numb) = enew                    !
         ener2(numb) = enew                    !
c-----------------------------------------------
         return                            ! ENEW = 0.01 GeV and return...
         endif
c-------------------------------------------
         ic = 0                            ! Iteration procedure to
         ene = (el + 1.59999e-1) * 5.e-1   ! obtain muon energy at
         delta = el - ene                  ! the DEPTH if his start
 3333    elow = alog(ene)                   ! energy is less than
         step1 = (up - elow) / float(lim1)   ! 10 GeV (without "ca-
         do j1=0,lim1                         ! tastrophic" part)
         en = elow + (float(j1) * step1)      !
         h1 = exp(en)                         !
         aux1(j1) = h1 * 1.e+3 / gdedelt2(h1) !
         enddo                                !
         pat1 = simps(aux1,elow,up,lim1)    !
         delta = 5.e-1 * delta            !
         ic = ic + 1                    !
         if (pat1.eq.rest) then       !-> it seems incredible but
         enew = ene                   !   sometimes it occurs...
c ----------------------------              !
         numb = numb + 1     !                      !
         ityp(numb) = 1      !-> tracking simulation  !
         eleng(numb) = depth !    history            !
         ener1(numb) = enew  !                   !
         ener2(numb) = enew  !               !
c ----------------------------          !
         return                        !
         endif                        !
         if (pat1.le.rest) then      !
         ene = ene - delta            !
         else                           !
         ene = ene + delta               !
         endif                            !
         if (ic.eq.14) then                !
         enew = ene                         ! -> We found ENEW
c ----------------------------                  !     and finish...
         numb = numb + 1     !                      !
         ityp(numb) = 1      !-> tracking simulation  !
         eleng(numb) = depth !    history            !
         ener1(numb) = enew  !                   !
         ener2(numb) = enew  !               !
c ----------------------------          !
         return                     !
         endif                   !
         goto 3333            !
c----------------------------
         return
         else
c
******************** TAU: ************************************
c
       if(itime.lt.0) then
         CALL DECAY_MODE
         treal = TIME_L_T
c                       !--> Simulation of tau life time (sec)
       else
         treal = ttauin
       endif
c
c  If working in water equivalent units increase TREAL proportionally
c                           to density:
c
       IF(MEDIUM.EQ.-1)  treal = treal * 1.00000d+0
       IF(MEDIUM.EQ.-2)  treal = treal * 2.65000d+0
       IF(MEDIUM.EQ.-3)  treal = treal * 0.92000d+0
       IF(MEDIUM.EQ.-4)  treal = treal * 1.02700d+0
       IF(MEDIUM.EQ.-5)  treal = treal * 1.03410d+0
       IF(MEDIUM.EQ.-6)  treal = treal * 1.03975d+0
       IF(MEDIUM.EQ.-7)  treal = treal * 2.71000d+0
       IF(MEDIUM.EQ.-8)  treal = treal * 2.90000d+0
       IF(MEDIUM.EQ.-9)  treal = treal * 2.48100d+0
       IF(MEDIUM.EQ.-10) treal = treal * 2.10300d+0
       IF(MEDIUM.EQ.-11) treal = treal * 1.69800d+0
       IF(MEDIUM.EQ.-12) treal = treal * 2.74000d+0
       IF(MEDIUM.EQ.-13) treal = treal * 2.74000d+0
c
       if(iti.eq.1) then
c -------------------------------------> Tracking simulation history
       numb = 1                   !
       ityp(numb) = 0             ! This is the case when we neglect energy
       eleng(numb) = 0.           !<-----losses, only take care about decay
       ener1(numb) = e            !
       ener2(numb) = e            !------------------------------
       edelen = 1.e+3 * sngl( treal * (dble(e)/rm_mu) * spli )  !
       numb = 2                   !------------------------------
         if(edelen.gt.depth) then !
           ityp(numb) = 1         !
           eleng(numb) = depth    !
           enew = e               !
           ener1(numb) = e        !
           ener2(numb) = e        !-----------------------------
           ttauout = treal * dble( (edelen - depth) / edelen ) !
           IF(MEDIUM.EQ.-1)  ttauout = ttauout / 1.00000d+0    !
           IF(MEDIUM.EQ.-2)  ttauout = ttauout / 2.65000d+0    !
           IF(MEDIUM.EQ.-3)  ttauout = ttauout / 0.92000d+0    !
           IF(MEDIUM.EQ.-4)  ttauout = ttauout / 1.02700d+0    !
           IF(MEDIUM.EQ.-5)  ttauout = ttauout / 1.03410d+0    !
           IF(MEDIUM.EQ.-6)  ttauout = ttauout / 1.03975d+0    !
           IF(MEDIUM.EQ.-7)  ttauout = ttauout / 2.71000d+0    !
           IF(MEDIUM.EQ.-8)  ttauout = ttauout / 2.90000d+0    !
           IF(MEDIUM.EQ.-9)  ttauout = ttauout / 2.48100d+0    !
           IF(MEDIUM.EQ.-10) ttauout = ttauout / 2.10300d+0    !
           IF(MEDIUM.EQ.-11) ttauout = ttauout / 1.69800d+0    !
           IF(MEDIUM.EQ.-12) ttauout = ttauout / 2.74000d+0    !
           IF(MEDIUM.EQ.-13) ttauout = ttauout / 2.74000d+0    !
         else                     !-----------------------------
           ityp(numb) = 8         !
           eleng(numb) = edelen   !
           enew = 1.e-2           !
           ener1(numb) = e        !
           ener2(numb) = 1.e-2    !
           ttauout = -1.d+0       !
         endif                    !
       return                     !
       endif                      !
c----------------------------------
       tcum = 0.0d+0
       if(e.le.1.e+1) then !-> tau energy is less than 10 GeV
c --------------------------
       numb = 1            !
       ityp(numb) = 0      !
       eleng(numb) = 0.    !-> Tracking simulation history
       ener1(numb) = e     !
       ener2(numb) = e     !
       numb = 2            !
       ityp(numb) = 8      !
       eleng(numb) = 0.1   !
       ener1(numb) = e     !
       ener2(numb) = 1.e-2 !
c---------------------------
       enew = 1.e-2
       ttauout = -1.d+0
       return
       endif
c -----------------------
       numb = 1         !
       ityp(numb) = 0   !
       eleng(numb) = 0. !-> Tracking simulation history
       ener1(numb) = e  !
       ener2(numb) = e  !
c------------------------
       ddepth = dble(depth)
       e0 = dble(e)
       pat = 0.d+0
   11  call rm48_own(rvec_own)
       eta = -dlog(rvec_own)
c                       !---> Simulation of random number
       if(eta.ge.3.16d+1) eta = 3.16d+1
       slu = sngl(eta)
       e0_sn = sngl(e0)
       if (slu.ge.1.e-4) then
       preal = getlanrv(slu,e0_sn)
c                               !-> getting the real free path
       e1d = e0 * dble(geteranv(slu,e0_sn))
c                                           !-> getting tau energy
c                                               at the end of free
c                                               path
       else
        preal = 0.  !--> simulated free path is too small, let
        e1d = e0    !    it be equal to zero...
       endif
        e1 = sngl(e1d)
c
       pat1 = pat
       pat = pat + dble(preal)
       rest = sngl(ddepth - pat)
         if (rest.lt.0.) then   !-> tau has passed the DEPTH,
           rest = -rest           !
           if (rest.lt.1.) rest=1.  !  Computing its "back" energy
           if (e1.lt.10.) e1 = 10.   ! at the DEPTH and return...
           enew = geteback(e1,rest)
******************
         low3 = dlog(dble(enew))
         up3 = dlog(e0)
         qqee = (sngl(up3 - low3))*7.e+0
         lim3 = (int(qqee) + 1) * 2
         step3 = (up3 - low3) / dble(lim3)
         do j=0,lim3
         edur = low3 + (dble(j) * step3)
         h1 = sngl(dexp(edur))
         aux2(j) = rm_mu / (spli * dble(conv(h1)))
         enddo
         time = dsimps(aux2,low3,up3,lim3)
******************
         tcum = tcum + time
         if(tcum.ge.treal) then
         e1 = enew
         deltat = treal - tcum + time
         goto 98789               !---> decay before
         endif                    !  reaching DEPTH
c-------------------------------
           numb = numb + 1     !
           ityp(numb) = 1      !-> Tracking
           eleng(numb) = depth ! simulation
           ener1(numb) = enew  !  history
           ener2(numb) = enew  !
c------------------------------
           ttauout = treal - tcum
           IF(MEDIUM.EQ.-1)  ttauout = ttauout / 1.00000d+0
           IF(MEDIUM.EQ.-2)  ttauout = ttauout / 2.65000d+0
           IF(MEDIUM.EQ.-3)  ttauout = ttauout / 0.92000d+0
           IF(MEDIUM.EQ.-4)  ttauout = ttauout / 1.02700d+0
           IF(MEDIUM.EQ.-5)  ttauout = ttauout / 1.03410d+0
           IF(MEDIUM.EQ.-6)  ttauout = ttauout / 1.03975d+0
           IF(MEDIUM.EQ.-7)  ttauout = ttauout / 2.71000d+0
           IF(MEDIUM.EQ.-8)  ttauout = ttauout / 2.90000d+0
           IF(MEDIUM.EQ.-9)  ttauout = ttauout / 2.48100d+0
           IF(MEDIUM.EQ.-10) ttauout = ttauout / 2.10300d+0
           IF(MEDIUM.EQ.-11) ttauout = ttauout / 1.69800d+0
           IF(MEDIUM.EQ.-12) ttauout = ttauout / 2.74000d+0
           IF(MEDIUM.EQ.-13) ttauout = ttauout / 2.74000d+0
           return
         endif
c
         if (e1.le.1.e+1) then  !-> tau energy =< 10 GeV
******************
         e1 = 1.e+1
         pat = pat1
         low3 = dlog(dble(e1))
         up3 = dlog(e0)
         qqee = (sngl(up3 - low3))*7.e+0
         lim3 = (int(qqee) + 1) * 2
         step3 = (up3 - low3) / dble(lim3)
         do j=0,lim3
         edur = low3 + (dble(j) * step3)
         h1 = sngl(dexp(edur))
         aux2(j) = 1.d+3 * (dexp(edur) / dble(conv(h1)))
         enddo
         pat2 = dsimps(aux2,low3,up3,lim3)
******************
         pat = pat + pat2
******************
         low3 = dlog(dble(e1))
         up3 = dlog(e0)
         qqee = (sngl(up3 - low3))*7.e+0
         lim3 = (int(qqee) + 1) * 2
         step3 = (up3 - low3) / dble(lim3)
         do j=0,lim3
         edur = low3 + (dble(j) * step3)
         h1 = sngl(dexp(edur))
         aux2(j) = rm_mu / (spli * dble(conv(h1)))
         enddo
         time = dsimps(aux2,low3,up3,lim3)
******************
         tcum = tcum + time
         if(tcum.ge.treal) then
         deltat = treal - tcum + time
         goto 98789           !---> decay before
         endif                !     reaching depth
c-----------------------------------                             .
           numb = numb + 1         !-> tracking                .
           ityp(numb) = 8          ! simulation              .
           eleng(numb) = sngl(pat) !  history              .
           ener1(numb) = e1        !                    .
           ener2(numb) = 1.e-2     !                 .
c-----------------------------------...................
           enew = 1.e-2
           ttauout = -1.d+0
           return
         endif
******************
         low3 = dlog(dble(e1))
         up3 = dlog(e0)
         qqee = (sngl(up3 - low3))*7.e+0
         lim3 = (int(qqee) + 1) * 2
         step3 = (up3 - low3) / dble(lim3)
         do j=0,lim3
         edur = low3 + (dble(j) * step3)
         h1 = sngl(dexp(edur))
         aux2(j) = rm_mu / (spli * dble(conv(h1)))
         enddo
         time = dsimps(aux2,low3,up3,lim3)
******************
         tcum = tcum + time
         if(tcum.ge.treal) then
         deltat = treal - tcum + time
         goto 98789   !---> decay before
         endif
c-----------------------------------> Computing of "weight" for different
c                                     interactions at current tau energy.
       pb = 1./glbremv(e1)
       pp = pb + 1./glpairv(e1)
       pn = pp + 1./glphnuv(e1)
       pt = pn + 1./glelecv(e1)
c-------------------------------------
       ranp = rndm_mum(5) * pt  ! -> Simulation of interaction type
       numb = numb + 1 !-> tracking simulation history
       if(ranp.le.pb) then        !-> type was simulated as bremsstrahlung,
       call getvbrem(e1,v,itra)
c                            !   simulate rel. energy transfer
       ityp(numb) = 4 !-> tracking simulation history
       else
          if(ranp.le.pp) then      !-> type was simulated as e+e- pair,
          call getvpa(e1,v,itra)
c                                  !   simulate rel. energy transfer
          ityp(numb) = 5 !-> tracking simulation history
          else
              if (ranp.le.pn) then   !-> type was simulated as photonuc.,
              call getvph(e1,v,itra)
c                                    !   simulate rel. energy transfer
              ityp(numb) = 6 !-> tracking simulation history
              else
              call getvel(e1,v,itra)
c                                    !-> type was simulated as knock-on
c                                    !  electron, simulate en. transfer
              ityp(numb) = 7 !-> tracking simulation history
              endif
           endif
        endif
        e2 = e1 * ( 1. - v ) ! -> The energy after interaction
c-----------------------------------
           eleng(numb) = sngl(pat) !
           ener1(numb) = e1        !-> tracking simulation history
           ener2(numb) = e2        !
c-----------------------------------
          if (e2.le.10.) then
c----------------------------------------------
                 numb = numb + 1               !
                 ityp(numb) = 8                !-> tracking simulation history
                 eleng(numb) = sngl(pat+1.d+0) !
                 ener1(numb) = e2              !
                 ener2(numb) = 1.e-2           !
c----------------------------------------------
                 enew = 1.e-2
                 ttauout = -1.d+0
                 return
          else
             e0 = dble(e2)  !-> tau energy is above 10 GeV. Jump to
             goto 11        !   label 11 to repeat everything once
          endif             !          again...
c
98789    continue
         if(e1.le.1.e+1) e1=1.e+1
         iiik = 1
         dta = dlog(dble(e0/e1))
******************
         low3 = dlog(dble(e1))
13333    continue
         iiik = iiik + 1
         dta = dta * .5d+0
         up3 = dlog(e0)
         qqee = (sngl(up3 - low3))*7.e+0
         lim3 = (int(qqee) + 1) * 2
         step3 = (up3 - low3) / dble(lim3)
         do j=0,lim3
         edur = low3 + (dble(j) * step3)
         h1 = sngl(dexp(edur))
         aux2(j) = rm_mu / (spli * dble(conv(h1)))
         enddo
         time1 = dsimps(aux2,low3,up3,lim3)
******************
         if(time1.ge.deltat) then
           low3 = low3 + dta
         else
           low3 = low3 - dta
         endif
         if(iiik.le.27) goto 13333
         e1 = sngl(dexp(low3))
******************
         pat = pat1
         low3 = dlog(dble(e1))
         up3 = dlog(e0)
         qqee = (sngl(up3 - low3))*7.e+0
         lim3 = (int(qqee) + 1) * 2
         step3 = (up3 - low3) / dble(lim3)
         do j=0,lim3
         edur = low3 + (dble(j) * step3)
         h1 = sngl(dexp(edur))
         aux2(j) = 1.d+3 * (dexp(edur) / dble(conv(h1)))
         enddo
         pat2 = dsimps(aux2,low3,up3,lim3)
******************
         pat = pat + pat2
c-----------------------------------------
                 numb = numb + 1         !
                 ityp(numb) = 8          !-> tracking simulation
                 eleng(numb) = sngl(pat) !     history
                 ener1(numb) = e1        !
                 ener2(numb) = 1.e-2     !
c-----------------------------------------
          enew = 1.e-2
          ttauout = -1.d+0
          return
         endif
      return
      end
****************************************************************************
* C.18
      subroutine simulde(ndepths,emu0)
*
*    The subroutine gives the muon energy at a set of depths consisting of
* NDEPTHS levels of observation if its level at the DEPTH=0 is  equal to EMU0
*  (GeV). EMU0 should be in a range of 0.16 GeV - 1 EeV. The  subroutine uses
* function ENEW which gives a "muon history" during its travel through a media
*           (see comments to ENEW routine). See commented lines at the
*                     beginning of this file for manual.
*.....................................................................
       external enew,simps,gdedelt2,geteback
       dimension ityp(10000),eleng(10000),ener1(10000),ener2(10000)
       dimension aux1(0:30)
       real*4 emu0
       integer ndepths
       integer kindlept
       common /what_lep/ kindlept
       common /vhistory/ numb,ityp,eleng,ener1,ener2
       common /frouser1/ horison(1000)
       common /touser1/ emuon(1000)
c
       iti = 0
       itime = -1
       emuon(ndepths) = enew(emu0,horison(ndepths),iti,itime)
       numfirst = 2
       do i=1,ndepths-1 !--> cycle along levels of observation
c---------------------------------------------
         if (eleng(numb).lt.horison(i)) then !-> muon has died before
           emuon(i) = 1.e-2                  !   given level of
           goto 1                            !    observation...
         else                                !
c---------------------------------------------
           do j=numfirst,numb  !-> cycle along muon history
c----------------------------------------------
             if (eleng(j).ge.horison(i)) then !-> we found the first event
             numfirst = j                   ! in muon history (starting with
c                                         ! less depth) whose depth is more
c                                       ! than given level of observation
c----------------------------------------
               if ((ityp(j).ge.3).and.(ityp(j).lt.8)) then !-> the nearest
                     diffl = eleng(j) - horison(i)         ! event is either
                        if (diffl.le.1.) then              ! brem, pn, e+e-,
                        emuon(i) = ener1(j)                ! knock-on e in-
                        goto 1                             ! teraction or
                        endif                              ! 10 GeV level
                     emuon(i) = geteback(ener1(j),diffl)   !
                     goto 1                                !
                  else                                     !
c
                     if (ityp(j).eq.1) then                     !-> muon
                         if (ener1(j).ge.10.) then              ! has reached
                           diffl = eleng(j) - horison(i)        ! the maximum
                             if (diffl.le.1.) then              ! depth and
                             emuon(i) = ener1(j)                ! E_mu > 10 GeV
                             goto 1                             !
                             endif                              !
                           emuon(i) = geteback(ener1(j),diffl)  !
                           goto 1                               !
                         else
                           goto 2  !-> the nearest event is either maximum
                         endif     !    depth with E_mu < 10 GeV or death
                     else          !    of muon (E_mu < 0.16 GeV)
                         goto 2    !
                     endif         !
                  endif            !
             else
             goto 3 !-> continue to search for the first event in muon history
             endif
c
 2           continue
c
             if(kindlept.ne.1) then !---------> TAU-lepton
             diffl = eleng(j) - horison(i)
             ecucuc = ener1(j)
             if(ener1(j).le.1.e+1) ecucuc = 1.0001e+1
             emuon(i) = geteback(ecucuc,diffl)
             goto 1
             endif
c
             lim1 = 30  !-------------------------!
             rest = eleng(j) - horison(i)         !
                if (rest.le.1.) then              !
                emuon(i) = ener1(j)               !
                goto 1                            !
                endif                             !
             ic = 0                               ! Iteration procedure to
             efin = ener1(j)                      ! obtain muon energy
             if (efin.le..15) efin = .16         !  at the level of observation
             ene = (efin + ener2(j-1)) * 5.e-1  ! if its energy at the nearest
             delta = ene - efin                !  event after level of obser-
             elow = alog(efin)                  !  vation is less than 10 GeV
 3333        up = alog(ene)                      !
             step1 = (up - elow) / float(lim1)    !
               do j1=0,lim1                       !
                 en = elow + (float(j1) * step1)   !
                 h1 = exp(en)                        !
                 aux1(j1) = h1 * 1.e+3 / gdedelt2(h1) !
               enddo                               !
             pat1 = simps(aux1,elow,up,lim1)   !
             delta = 5.e-1 * delta         !
             ic = ic + 1                !
               if (pat1.eq.rest) then !-> It seems incredible but sometimes
               emuon(i) = ene         !      it occurs ...
               goto 1                 !
               endif                  !_________
               if (pat1.le.rest) then           !
                 ene = ene + delta             !
               else                           !
                 ene = ene - delta           !
               endif                        !
               if (ic.eq.14) then          !
                 emuon(i) = ene           ! -> We found EMUON(I)
                 goto 1                  !
               endif                    !
             goto 3333                 !
    3      continue  !----------------!
           enddo
         endif
    1  continue
       enddo
      return
      end
****************************************************************************
* C.26
*                   REAL*4 RANDOM GENERATOR
*
      function rndm_mum(IFAKE)
      real*8 rreal8(15000000)
      real*4 rreal4(15000000)
      real*4 rvec(1)
      integer IFAKE,K
      integer iseed_r,index_rndm4,index_rndm8
      COMMON /RNDM1/ iseed_r,index_rndm4,index_rndm8
      COMMON /RNDM2/ rreal8
      COMMON /RNDM3/ rreal4
      data len /1/
c
      NUM = 15000000
      if (iseed_r.eq.0) then
        if (index_rndm4.eq.NUM) then
          index_rndm4 = 0
        endif
          index_rndm4 = index_rndm4 + 1
          rndm_mum = rreal4(index_rndm4)
      else
         K=IFAKE
         call RANLUX(rvec,len)
         rndm_mum = rvec(1)
      endif
      return
      end
**************************************************************************
C.26a
*                   REAL*8 RANDOM GENERATOR
*
      SUBROUTINE RM48_OWN(RVEC_OWN)
c
      real*8 rvec(1),rvec_own,rreal8(15000000)
      real*4 rreal4(15000000)
      integer iseed_r,index_rndm4,index_rndm8
      COMMON /RNDM1/ iseed_r,index_rndm4,index_rndm8
      COMMON /RNDM2/ rreal8
      COMMON /RNDM3/ rreal4
      common /r48/ rvec
c
      NUM = 15000000
      if (iseed_r.ne.0) then
         call rm48(rvec,1)
         rvec_own = rvec(1)
      else
        if (index_rndm8.eq.NUM) then
          index_rndm8 = 0
        endif
          index_rndm8 = index_rndm8 + 1
          rvec_own = rreal8(index_rndm8)
      endif
c
      return
      end
**************************************************************************
* C.27
*               GETTING INITIAL RANDOM NUMBER
*
      SUBROUTINE GETSEED(IRANSEED1,IRANSEED2)
      COMMON /SLATE/ ISL(40)
      INTEGER IRANSEED1,IRANSEED2
      CALL DATIME(ID,IH)
      IRANSEED1 = 1000000*ISL(6) + 10000*ISL(5) + 100*ISL(4) + ISL(3)
      IRANSEED2 = 879321*ISL(6) + 9953*ISL(5) + 111*ISL(4) + ISL(3)
      RETURN
      END
****************************************************************************
c C.28
c
      SUBROUTINE PREPARE_DECAY
c
c   Cooking array TIMP(22) with partial life times of tau-lepton for 22
c                    the most important decay modes
c
      DOUBLE PRECISION TLIFE,XX
      DIMENSION TIMP(22)
      DIMENSION DMOD(22)
      COMMON /PARTI/ TIMP
      COMMON /CONST_T/ TLIFE
c
      DO I=1,22
      DMOD(I) = 1.00000
      ENDDO
c
      DO I = 1,22
c                            BR. RATIO         DECAY MODE            NUMBER
c                         (norm to e mode)         |       (in TAUOLA style)
c                                |                 |                     |
c                                V                 V                     V
        IF(I.EQ. 1) DMOD(I) = 1.00000 ! TAU-+  -->  E-+                  1
        IF(I.EQ. 2) DMOD(I) = 0.97980 ! TAU-+  -->  MU-+                 2
        IF(I.EQ. 3) DMOD(I) = 0.64960 ! TAU-+  -->  PI-+                 3
        IF(I.EQ. 4) DMOD(I) = 1.3405  ! TAU-+  -->  PI-+    PI0          4
        IF(I.EQ. 5) DMOD(I) = 0.7215  ! TAU-+  -->  A1-+ (two subch)     5
        IF(I.EQ. 6) DMOD(I) = 0.0397  ! TAU-+  -->  K-+                  6
        IF(I.EQ. 7) DMOD(I) = 0.0696  ! TAU-+  -->  K*-+ (two subch)     7
        IF(I.EQ. 8) DMOD(I) = 0.0835  ! TAU-+  -->  2PI-+   PI0    PI+-  8
        IF(I.EQ. 9) DMOD(I) = 0.0170  ! TAU-+  -->  3PI0    PI-+         9
        IF(I.EQ.10) DMOD(I) = 0.0641  ! TAU-+  -->  2PI-+   PI+-   2PI0  10
        IF(I.EQ.11) DMOD(I) = 0.0286  ! TAU-+  -->  3PI-+   2PI+-        11
        IF(I.EQ.12) DMOD(I) = 0.0043  ! TAU-+  -->  3PI-+   2PI+-  PI0   12
        IF(I.EQ.13) DMOD(I) = 0.0042  ! TAU-+  -->  2PI-+   PI+-   3PI0  13
        IF(I.EQ.14) DMOD(I) = 0.0061  ! TAU-+  -->  K-+     PI-+   K+-   14
        IF(I.EQ.15) DMOD(I) = 0.0056  ! TAU-+  -->  K0      PI-+   K0B   15
        IF(I.EQ.16) DMOD(I) = 0.0005  ! TAU-+  -->  K-+     K0     PI0   16
        IF(I.EQ.17) DMOD(I) = 0.0059  ! TAU-+  -->  PI0     PI0    K-+   17
        IF(I.EQ.18) DMOD(I) = 0.0321  ! TAU-+  -->  K-+     PI-+   PI+-  18
        IF(I.EQ.19) DMOD(I) = 0.0320  ! TAU-+  -->  PI-+    K0B    PI0   19
        IF(I.EQ.20) DMOD(I) = 0.0110  ! TAU-+  -->  ETA     PI-+   PI0   20
        IF(I.EQ.21) DMOD(I) = 0.0031  ! TAU-+  -->  PI-+    PI0    GAM   21
        IF(I.EQ.22) DMOD(I) = 0.0181  ! TAU-+  -->  K-+     K0           22
      ENDDO
c
      XX = 0.d+0
        DO I=1,22
          XX = XX + DBLE(DMOD(I))
        ENDDO
        DO I=1,22
          TIMP(I) = ( SNGL(XX) / DMOD(I) ) * SNGL(TLIFE)
        ENDDO
c
       RETURN
       END
****************************************************************************
c C.29
c
      SUBROUTINE DECAY_MODE
c
c Generation of tau-lepton life time (DOUBLE PRECISION TIME_L_T) and decay
c        mode (INTEGER MODE) to be passed to ENEW(S,3,4) routines.
      DOUBLE PRECISION RVEC_OWN, TREAL1, TREAL,TIME_L_T
      INTEGER MODE
      DIMENSION TIMP(22)
      COMMON /PARTI/ TIMP
      COMMON /TAU_DECAY/ TIME_L_T,MODE
c
      TREAL = 1.D+1
        DO J=1,22
          call rm48_own(rvec_own)
          TREAL1 = (-DLOG(RVEC_OWN)) * DBLE(TIMP(J))
            IF(TREAL1.LE.TREAL) THEN
              TREAL = TREAL1
              MODE = J
            ENDIF
        ENDDO
        TIME_L_T = TREAL
c
      RETURN
      END
************************************************************************
* C.30
*       THIS REAL*8 FUNCTION RETURNS VALUES FOR RADIATION LOGARITHM B
*                 COMPUTED BY KELNER - KOKOULIN - PETRUKHIN
*      [S.R. Kelner, R.P. Kokoulin, A.A. Petrukhin, Yadernaya Fizika,
*       2, (1999) pp.2042-1048, table at page 2046 (Phys. At. Nucl. 62
*                           (1999), p. 1894.)]
*
*     FOR NUCLEI WHICH ARE NOT PRESENTED IN CITED WORK VALUE B=182.7 IS
*     ASSIGNED, AS IT'S ACCEPTED IN THE PROPOSAL CODE AND ACCORDING TO
*      [M.Sc.A.Sandrock, "Higher-order corrections to the energy loss
*     cross sections of high-energy muons", Dissertation zur Erlangung
*                  des akademischen Grades eines (PhD Thesis)
*                    Technische Universitaet Dortmund, 2018]
*  (https://eldorado.tu-dortmund.de/bitstream/2003/37815/1/Sandrock.pdf)
*                            (PAGE 98, TABLE C.2)
*
*       RADIATION LOGARITHM IS NEEDED TO CALCULATE CROSS-SECTIONS FOR
*             BREMSSTRAHLUNG AND DIRECT E+E-PAIRS PRODUCTION.
*
*                                INPUT:
*                                =====
*
*                real*8 z: electric charge of nucleus
*
*                                OUTPUT:
*                                ======
*
*             real*8 rad_log_HF: dimensionless value of B
*
*  .....................................................................
      real*8 function rad_log_HF(z)
c  .....................................................................
c
c                             TABLE FROM [Phys.At.Nucl. 62 (1999) 1894]:
c
      real*8, dimension(92), parameter:: b = (/
*          1...5:
     #            202.4, 151.9, 159.9, 172.3, 177.9,
*         6...10:
     #            178.3, 176.6, 173.4, 170.0, 165.8,
*        11...15:
     #            165.8, 167.1, 169.1, 170.8, 172.2,
*        16...20:
     #            173.4, 174.3, 174.8, 175.1, 175.6,
*        21...25:
     #            176.2, 176.8, 182.7, 182.7, 182.7,
*        26...30:
     #            175.8, 182.7, 182.7, 173.1, 182.7,
*        31...35:
     #            182.7, 173.0, 182.7, 182.7, 173.5,
*        36...40:
     #            182.7, 182.7, 182.7, 182.7, 182.7,
*        41...45:
     #            182.7, 175.9, 182.7, 182.7, 182.7,
*        46...50:
     #            182.7, 182.7, 182.7, 182.7, 177.4,
*        51...55:
     #            182.7, 182.7, 178.6, 182.7, 182.7,
*        56...60:
     #            182.7, 182.7, 182.7, 182.7, 182.7,
*        61...65:
     #            182.7, 182.7, 182.7, 182.7, 182.7,
*        66...70:
     #            182.7, 182.7, 182.7, 182.7, 182.7,
*        71...75:
     #            182.7, 182.7, 182.7, 177.6, 182.7,
*        76...80:
     #            182.7, 182.7, 182.7, 182.7, 182.7,
*        81...85:
     #            182.7, 178.0, 182.7, 182.7, 182.7,
*        86...90:
     #            182.7, 182.7, 182.7, 182.7, 182.7,
*        91...92:
     #            182.7, 179.8                       /)
c                                                          DECLARATIONS:
      real*8 z
      integer i
c                                                          CALCULATIONS:
      i = idint(z + 1.d-1)
c
      if (i.GT.92) then
         rad_log_HF = 182.7d+0
      else
         rad_log_HF = b(i)
      endif
c
      return
      end
****************************************************************************
c C.31
c
c Routine returns character *2 variable AA which corresponds to the
c value of integer variable I which is in the range 1...60 (this is for
c MONTH, DAY, HOUR, MIN and SEC).
c
      SUBROUTINE ST2_INT_CHAR(i,aa)
c
      character *2 aa
      integer i
      intent (out) aa
c
      aa='XY'
c
      if(i.eq.0)  aa='00'
      if(i.eq.1)  aa='01'
      if(i.eq.2)  aa='02'
      if(i.eq.3)  aa='03'
      if(i.eq.4)  aa='04'
      if(i.eq.5)  aa='05'
      if(i.eq.6)  aa='06'
      if(i.eq.7)  aa='07'
      if(i.eq.8)  aa='08'
      if(i.eq.9)  aa='09'
      if(i.eq.10) aa='10'
      if(i.eq.11) aa='11'
      if(i.eq.12) aa='12'
      if(i.eq.13) aa='13'
      if(i.eq.14) aa='14'
      if(i.eq.15) aa='15'
      if(i.eq.16) aa='16'
      if(i.eq.17) aa='17'
      if(i.eq.18) aa='18'
      if(i.eq.19) aa='19'
      if(i.eq.20) aa='20'
      if(i.eq.21) aa='21'
      if(i.eq.22) aa='22'
      if(i.eq.23) aa='23'
      if(i.eq.24) aa='24'
      if(i.eq.25) aa='25'
      if(i.eq.26) aa='26'
      if(i.eq.27) aa='27'
      if(i.eq.28) aa='28'
      if(i.eq.29) aa='29'
      if(i.eq.30) aa='30'
      if(i.eq.31) aa='31'
      if(i.eq.32) aa='32'
      if(i.eq.33) aa='33'
      if(i.eq.34) aa='34'
      if(i.eq.35) aa='35'
      if(i.eq.36) aa='36'
      if(i.eq.37) aa='37'
      if(i.eq.38) aa='38'
      if(i.eq.39) aa='39'
      if(i.eq.40) aa='40'
      if(i.eq.41) aa='41'
      if(i.eq.42) aa='42'
      if(i.eq.43) aa='43'
      if(i.eq.44) aa='44'
      if(i.eq.45) aa='45'
      if(i.eq.46) aa='46'
      if(i.eq.47) aa='47'
      if(i.eq.48) aa='48'
      if(i.eq.49) aa='49'
      if(i.eq.50) aa='50'
      if(i.eq.51) aa='51'
      if(i.eq.52) aa='52'
      if(i.eq.53) aa='53'
      if(i.eq.54) aa='54'
      if(i.eq.55) aa='55'
      if(i.eq.56) aa='56'
      if(i.eq.57) aa='57'
      if(i.eq.58) aa='58'
      if(i.eq.59) aa='59'
      if(i.eq.60) aa='60'
c
      RETURN
      END
****************************************************************************
c C.32
c
c
c Routine returns character *4 variable AA which corresponds to the
c value of integer variable I which is in the range 2019...2050 (this is
c for YEARS).
c
      SUBROUTINE ST4_INT_CHAR(i,aa)
c
      character *4 aa
      integer i
      intent (out) aa
c
      aa='XYXY'
c
      if(i.eq.2019)  aa='2019'
      if(i.eq.2020)  aa='2020'
      if(i.eq.2021)  aa='2021'
      if(i.eq.2022)  aa='2022'
      if(i.eq.2023)  aa='2023'
      if(i.eq.2024)  aa='2024'
      if(i.eq.2025)  aa='2025'
      if(i.eq.2026)  aa='2026'
      if(i.eq.2027)  aa='2027'
      if(i.eq.2028)  aa='2028'
      if(i.eq.2029)  aa='2029'
      if(i.eq.2030)  aa='2030'
      if(i.eq.2031)  aa='2031'
      if(i.eq.2032)  aa='2032'
      if(i.eq.2033)  aa='2033'
      if(i.eq.2034)  aa='2034'
      if(i.eq.2035)  aa='2035'
      if(i.eq.2036)  aa='2036'
      if(i.eq.2037)  aa='2037'
      if(i.eq.2038)  aa='2038'
      if(i.eq.2039)  aa='2039'
      if(i.eq.2040)  aa='2040'
      if(i.eq.2041)  aa='2041'
      if(i.eq.2042)  aa='2042'
      if(i.eq.2043)  aa='2043'
      if(i.eq.2044)  aa='2044'
      if(i.eq.2045)  aa='2045'
      if(i.eq.2046)  aa='2046'
      if(i.eq.2047)  aa='2047'
      if(i.eq.2048)  aa='2048'
      if(i.eq.2049)  aa='2049'
      if(i.eq.2050)  aa='2050'
c
      RETURN
      END

****************************************************************************
c C.33
c
      SUBROUTINE final_stat
c
      real*4 T
c
      integer i_stat(6)
      integer ISL(40),ID,IH
      integer ist(4)
c
      character *38 mum_card_name
      character *10 chm
      character *4 yyyy
      character *2 mm
      character *2 dd
      character *2 hh
      character *2 mi
      character *2 ss
c
      common /statistic/ i_stat
      COMMON /SLATE/ ISL
      common /card_name/ mum_card_name
      common /init_calls/ ist
c
      open(23,file=mum_card_name, status='unknown', access='append',
     +form='formatted')
c
      CALL DATIME(ID,IH)
      call ST4_INT_CHAR(isl(1),yyyy)
      call ST2_INT_CHAR(isl(2),mm)
      call ST2_INT_CHAR(isl(3),dd)
      call ST2_INT_CHAR(isl(4),hh)
      call ST2_INT_CHAR(isl(5),mi)
      call ST2_INT_CHAR(isl(6),ss)
c
      chm='0123456789'
      if(ISL(2).eq.1)  chm='  January '
      if(ISL(2).eq.2)  chm=' February '
      if(ISL(2).eq.3)  chm='    March '
      if(ISL(2).eq.4)  chm='    April '
      if(ISL(2).eq.5)  chm='      May '
      if(ISL(2).eq.6)  chm='     June '
      if(ISL(2).eq.7)  chm='     July '
      if(ISL(2).eq.8)  chm='   August '
      if(ISL(2).eq.9)  chm='September '
      if(ISL(2).eq.10) chm='  October '
      if(ISL(2).eq.11) chm=' November '
      if(ISL(2).eq.12) chm=' December '
c
      write(23,501) chm,ISL(3),ISL(1),ISL(4),ISL(5),ISL(6)
      write(23,*) ' '
c
      CALL TIMEX(T)
      write(23,502) T
c
      write(23,601) ist(1)
      write(23,602) ist(2)
      write(23,603) ist(3)
      write(23,604) ist(4)
c
      write(23,511) i_stat(1)
      write(23,512) i_stat(2)
      write(23,513) i_stat(3)
      write(23,514) i_stat(4)
      write(23,515) i_stat(5)
      write(23,516) i_stat(6)
c
      close(23)
c
      RETURN
c
  501 format
     + (' Finishing to run on',A11,I3,',',I5,' at',I3,':',I2,':',I2)
  502 format
     + (' Execution time                 : ',F16.6,' sec')
  511 format
     + (' Calls to ENEW                  : ',i11)
  512 format
     + (' Calls to EARRAY1               : ',i11)
  513 format
     + (' Calls to EARRAY2               : ',i11)
  514 format
     + (' Calls to ENEWS                 : ',i11)
  515 format
     + (' Calls to ENEW3                 : ',i11)
  516 format
     + (' Calls to ENEW4                 : ',i11)
  601 format
     + (' Module1 (INIT_MU)  initialized : ',i3,' times')
  602 format
     + (' Module2 (INIT_MUS) initialized : ',i3,' times')
  603 format
     + (' Module3 (INIT_MU3) initialized : ',i3,' times')
  604 format
     + (' Module4 (INIT_MU4) initialized : ',i3,' times')
c
      END
****************************************************************************
************************ BREMSSTRAHLUNG SUBROUTINES : **********************
****************************************************************************
* B.1
*      THIS REAL*8 FUNCTION CALCULATES DIFFERENTIAL CROS-SECTION FOR MUON
*     BREMSSTRAHLUNG IN ACCORDING TO FORMULAE TAKEN FROM E.V.BUGAEV AT AL,
*                  E-PREPRINT hep-ph/9803488 v2 Jun 1998)
*
*                                INPUT:
*                                =====
*
*  real*8 z     : electric charge of nuclei
*  real*8 en    : muon energy (GeV)
*  real*8 rnu   : relative energy transfer = (E_transferred / E_mu)
*
*                                OUTPUT:
*                                ======
*
*  real*8 brem : d_sigma/d_v (sq. cm) for nucleus with given Z, muon energy
*                                       and relative energy transfer
*  .........................................................................
       real*8 function brem(z,en,rnu)
c
c      auxiliary real*8 functions (see below B.2 and B.3):
c
       external fu1,fu2
       real*8 fu1,fu2
       real*8 z,en,rnu,rnu1
       real*8 alfa,rm_e,rm_mu,r_e,fact,a1,a2,del1,del2,x1,x2,ulim,avog
       real*8 eln1,eln2,psi10,psi20,psi1,psi2,z13,z23,qc,dze,q_min,h1
       common /exer1/ fa
       common /const/ alfa,rm_e,rm_mu,r_e,avog
c                                  I
c                                  I------>! universal constants which are
c                                          ! provided by subroutine
c                                          ! MED_CONS and are passed here
c                                          ! by common /const/
c  .........................................................................
c       SOME CONSTANTS FOR BREMSSTRAHLUNG FORMULAE (see hep-ph/9803488):
c       ****************************************************************
      fact=((4.d+0*z*z*r_e*r_e*rm_e*rm_e)/(rm_mu*rm_mu))*alfa
      rnu1=1.d+0-rnu
      z13=z**(1.d+1/3.d+1)
      z23=z13*z13
      qc=(1.9d+0*1.0565932d+2)/z13 !---> pomenyano dlya tau,
c                                       this is not an error!
ccc      qc=(1.9d+0*rm_mu)/z13 !---> pomenyano dlya tau
      dze=sqrt(1.d+0+((4.d+0*rm_mu*rm_mu)/(qc*qc)))
      a1 = 1.117d+2/(z13*rm_e)
      a2 = 7.242d+2/(z23*rm_e)
      del1=dlog(rm_mu/qc)+((dze/2.d+0)*dlog((dze+1.d+0)/(dze-1.d+0)))
      del2=dlog(rm_mu/qc)+((2.d+0*rm_mu*rm_mu)/(qc*qc))
      del2 = del2+((dze/4.d+0)*(3.d+0-(dze*dze))*dlog((dze+1.d+0)/(dze-1
     *.d+0)))
      if (z.le.1.5d+0) then !
      del1=0.d+0            !-> there is no corrections due to nuclear
      del2=0.d+0            !   form-factor for hydrogen
      endif                 !
      q_min=((rnu/rnu1)*rm_mu*rm_mu*5.d-1)/(en*1.d+3)
      x1 = a1 * q_min
      x2 = a2 * q_min
c  .........................................................................
c    ULIM represents the upper limit for energy transfer via bremsstrahlung
c    for nucleus with given electric charge Z, muon energy EN and  relative
c                                  transfer RNU:
c
        ulim=((z)**(1.d+0/3.d+0))*1.236540953d+0*(rm_mu/(en*1.d+3))
        ulim = 1.d+0 - ulim
c  .........................................................................
        if (ulim.lt.rnu) then   !  if input energy transfer is greater than
        k1=0                    !  upper limit the diff. cross-section = 0.
        else                    !  Else it is calculated by formulae for
        k1=1                    !  bremsstrahlung.
        endif                   !
        h1=dble(k1)             !
c  .........................................................................
c      CALCULATION OF DIFFERENTIAL CROSS-SECTION FOR MUON BREMSSTRAHLUNG:
        eln1=dlog((rm_mu*rm_mu*a1*a1)/(1.d+0+x1*x1))
        eln2=dlog((rm_mu*rm_mu*a2*a2)/(1.d+0+x2*x2))
        psi10 = 5.d-1 * (1.+eln1) - fu2(x1)
        psi10 = psi10 + (1.d+0/z)*(5.d-1*(1.d+0+eln2) - fu2(x2))
        psi20=(1.d+1/3.d+1) + 5.d-1*eln1 + fu1(x1)
        psi20=psi20+(1.d+0/z)*((1.d+0/3.d+0)+5.d-1*eln2+fu1(x2))
        psi1=psi10-del1
        psi2=psi20-del2
        brem=(fact/rnu)*((rnu1*rnu1+1.d+0)*psi1-(2.d+0/3.d+0)*rnu1*psi2)
        brem = brem * h1 * dble(fa)
        return
        end
****************************************************************************
* B.2
*                   REAL*8 function fu1 calculates the term
*        2 * x^2 * (1 - x * ARCTAN (1/x) + (3/4) * LN ((x^2)/(1+x^2)))
*  in formulae for muon bremsstrahlung. It is referenced by subroutine BREM
*                       and reference FUNCTION fu2.
*  .........................................................................
       real*8 function fu1(c)
       external fu2
       real*8 c,fu2
      if (c.gt.1.d+3) then
        fu1 = -0.8333333333333d+0
      else
        if (c.lt.1.d-5) then
         ik=0
         fu1=dble(ik)
        else
         fu1=2.d+0*c*c*(1.d+0-fu2(c)+(7.5d-1)*dlog((c*c)/(1.d+0+(c*c))))
        endif
      endif
      return
      end
****************************************************************************
* B.3
*           REAL*8 function fu2 calculates the term x * arctan (1/x)
*  in formulae for muon bremsstrahlung. It is referenced by function FU1
*  .........................................................................
       real*8 function fu2(d)
       real*8 d
       if (d.gt.5.d+4) then
          ik = 1
          fu2 = dble(ik)
       else
           if (d.lt.1.d-8) then
             fu2 = d * 3.14159265359d+0 * 5.d-1
           else
             fu2 = d * datan(1.d+0/d)
           endif
       endif
       return
       end
**************************************************************************
* B.1a
C***********************************************************************
C***    crb_g4_1.inc    in comparison with crb_.inc, following
C***    changes are introduced (September 24th, 1998):
C***            1) function crb_g4 (Z,A,Tkin,EP), Tkin is kinetic energy
C***            2) special case of hydrogen (Z<1.5; b,b1,Dn_star)
C***            Numerical comparison: 5 decimal digits coincide.
C***********************************************************************
C***    Cross section for bremsstrahlung by fast muon
C***    By R.P.Kokoulin, September 1998
C***    Formulae from Kelner,Kokoulin,Petrukhin 1995, Preprint MEPhI
C***    (7,18,19,20,21,25,26); Dn (18) is modified to incorporate
C***    Bugaev's inelastic nuclear correction (28) for Z > 1.
C***********************************************************************
      function CRB_G4 (Z,A,Tkin,EP)
      external rad_log_HF
      real*8 rad_log_HF
c       ame in GeV:
      parameter       (ame=0.51099907e-3)
ccc        parameter       (amu=0.105658389)       !!!     GeV
c       re in cm:
      parameter       (re=2.81794092e-13)
      parameter       (avno=6.022137e23)
ccc        parameter       (alpha=1./137.036)
ccc        parameter       (rmass=amu/ame)         !!!     "207"
ccc        parameter       (coeff=16./3.*alpha*avno*(re/rmass)**2) !!! cm^2
c       sqrt(2.71828...):
      parameter       (sqrte=1.64872127)
      parameter       (btf=183.)
      parameter       (btf1=1429.)
      parameter       (bh=202.4)
      parameter       (bh1=446.)
      real*8 alfa,rm_e,rm_mu,r_e,avog
      real*4 Z,A,Tkin,EP
      common /const/ alfa,rm_e,rm_mu,r_e,avog
      common /exer1/ fa
c***********************************************************************
        alpha=1./137.036
        amu = 1.e-3 * sngl(rm_mu)
        rmass = amu/ame
        coeff = 16./3.*alpha*avno*(re/rmass)**2
C***********************************************************************
        if (ep.ge.tkin) then
                crb_g4=0.
                return
                end if
        e=tkin+amu
        v=ep/e
        delta=amu*amu*v/(2.*(e-ep))             !!!     qmin
        rab0=delta*sqrte
        z_13=z**(-0.3333333)                    !!!
C***            nuclear size and excitation, screening parameters
        dn=1.54*A**0.27
****************************************
****************************************
****************************************
ccc      dn_star=dn
ccc      b = sngl(rad_log_HF(dble(z)))
ccc      if (z.lt.1.5e+0) then
ccc         b1 = bh1
ccc      else
ccc         b1 = btf1
ccc         dn_star=dn**(1.-1./Z)
ccc      endif
****************************************
****************************************
****************************************
        if (z.le.1.5) then      !!!     special case for hydrogen
                b=bh
                b1=bh1
                dn_star=dn
        else
                b=btf
                b1=btf1
                dn_star=dn**(1.-1./Z)   !!! with Bugaev's correction
        end if
C***            nucleus contribution logarithm
        rab1=b*z_13
        fn=alog(rab1/(dn_star*(ame+rab0*rab1))*(amu+delta*
     *          (dn_star*sqrte-2.)))
        if (fn.lt.0.) fn=0.
C***            electron contribution logarithm
        epmax1=e/(1.+amu*rmass/(2.*e))
        if (ep.ge.epmax1) then
                fe=0.
                go to 10
                end if
        rab2=b1*z_13*z_13
        fe=alog(rab2*amu/((1.+delta*rmass/(ame*sqrte))*
     *                  (ame+rab0*rab2)))
        if (fe.lt.0.) fe=0.
C***
10      continue
*        crb_g4=coeff*(1.-v*(1.-0.75*v))*Z*(Z*fn+fe)/(A*ep)!Commented by
c                                                          ! I. Sokalski
      crb_g4=fa*coeff*e*(1.-v*(1.-0.75*v))*Z*(Z*fn+fe)/(ep*avno)!Inserted by
c                                                                Sokalski
c                                                          (factor (A/N_a)*E
c                                                              is added)
        return
        end
************************************************************************
* B.1b
*     THIS REAL*8 FUNCTION CALCULATES DIFFERENTIAL CROS-SECTION FOR MUON
*         BREMSSTRAHLUNG ACCORDING TO FORMULAE TAKEN FROM A.SANDROCK
*                                  PhD Thesis:
*       M.Sc.A.Sandrock, "Higher-order corrections to the energy loss
*     cross sections of high-energy muons", Dissertation zur Erlangung
*                   des akademischen Grades eines (PhD Thesis)
*                     Technische Universitaet Dortmund, 2018
*  (https://eldorado.tu-dortmund.de/bitstream/2003/37815/1/Sandrock.pdf)
*
*                                INPUT:
*                                =====
*
*  real*8 z     : electric charge of nucleus
*  real*8 a     : atomic weight of nucleus
*  real*8 en    : muon energy (GeV)
*  real*8 rnu   : relative energy transfer = (E_transfered / E_mu)
*
*                                OUTPUT:
*                                ======
*
*  real*8 brem_sandr : d_sigma/d_v (sq. cm) for nucleus with given Z, A,
*                      muon energy EN and relative energy transfer RNU
*  .....................................................................
      real*8 function brem_sandr(z,a,en,rnu)
c  .....................................................................
c
c                                                          DECLARATIONS:
c
c Routine to compute radiation logarithm B:
      external rad_log_HF
      real*8 rad_log_HF
c Declaration for input variables:
      real*8 z,a,en,rnu
c Declaration for constants which are prepared by MED_CONS routine and
c passed here via COMMON /const/ (electron and muon masses in MeV!!!):
      real*8 alfa,rm_e,rm_mu,r_e,avog
      common /const/ alfa,rm_e,rm_mu,r_e,avog
c M_mu and M_e in GeV:
      real*8 rm_mu_gev,rm_e_gev
c E number:
      real*8, parameter:: e = 2.7182818284590452354d+0
c M_mu (GeV) to compute q_c parameter for tau-lepton:
      real*8, parameter:: mu_m = 1.0565932d+2  !--> muon mass (MeV)
c Inelastic radiation logarithm B':
c                                           for all the nuclei with Z>1:
      real*8, parameter::       b1_all=1429.d+0
c                                                          for hydrogen:
      real*8, parameter::       b1_h=446.d+0
c Radiation logarithm and inelastic radiation logarithm (the last to be
c substituted by one of the values above:
      real*8 b,b1
c Parameters of the parametrization for the radiative corrections to the
c bremsstrahlung cross section (Table B.1 in Sandrock's Thesis):
      real*8, dimension(3), parameter:: ai = (/
     #                                             -0.00349,
     #                                            148.84,
     #                                           -987.531
     #                                                       /)
      real*8, dimension(4), parameter:: bi = (/
     #                                              0.1642,
     #                                            132.573,
     #                                           -585.361,
     #                                           1407.77
     #                                                       /)
      real*8, dimension(6), parameter:: ci = (/
     #                                             -2.8922,
     #                                            -19.0156,
     #                                             57.698,
     #                                            -63.418,
     #                                             14.1166,
     #                                              1.84206
     #                                                       /)
      real*8, dimension(6), parameter:: di = (/
     #                                           2134.19,
     #                                            581.823,
     #                                          -2708.85,
     #                                           4767.05,
     #                                              1.52918,
     #                                              0.361933
     #                                                       /)
c Different terms in formula for dif. cross-section:
      real*8 Delta1, Delta2, delta,rho,q_c,Dn,F1,F2
c Radiative corrections made by Sandrock:
      real*8 s_at, s_rad
c Auxiliary variables:
      real*8 help1, help2, ulim, fact
c Some factor to play with cross-sections (FOR EXPERTS ONLY!!!):
      real*4 fa
      common /exer1/ fa
c Loop variable:
      integer i
************************************************************************
c
c                                                          CALCULATIONS:
c
c Choosing values for radiation logarithm B and inelastic radiation
c                                     logarithm B' depending on Z value:

      b = rad_log_HF(z)
      if (z.gt.1.5d+0) then
         b1 = b1_all
      else
         b1 = b1_h
      endif
c
c                                 Computing terms of Sandrock's formula:
c
c Computing delta (in GeV!):
      rm_mu_gev = rm_mu / 1.d+3
      delta =
     &      (rm_mu_gev * rm_mu_gev * rnu) / (2.d+0 * en * (1.d+0 - rnu))
c Computing Dn (nuclear formfactor parametrization):
      Dn = 1.54d+0 * (a**0.27d+0)
c Computing q_c (in MeV!):
      q_c = (mu_m * e) / Dn
c Computing rho:
      rho = DSQRT(1.d+0 + ((4.d+0*rm_mu*rm_mu) / (q_c*q_c)))
c Computing Delta1:
      Delta1 = DLOG(rm_mu/q_c)
      Delta1 = Delta1 + (rho/2.d+0) * DLOG((rho+1.d+0)/(rho-1.d+0))
c Computing Delta2:
      Delta2 = DLOG(rm_mu/q_c)
      Delta2 = Delta2 + ( (2.d+0 * rm_mu * rm_mu) / (q_c * q_c) )
      Delta2 = Delta2 +
     &( (3.d+0*rho-rho**3.d+0) / 4.d+0) * DLOG((rho+1.d+0)/(rho-1.d+0))
c Computing F1 and F2:
      help1 = b * (z**(-1.d+0 / 3.d+0))
      help2 = help1 * (rm_mu / rm_e)
      rm_e_gev = rm_e / 1.d+3
      F1 = DLOG(help2 / (1.d+0 + (help1 * DSQRT(e) * (delta/rm_e_gev))))
      F1 = F1 - Delta1 * (1.d+0 - (1.d+0/z))
      F2 = help2 * e**(-1.d+0/6.d+0)
      F2 = DLOG(F2 /(1.d+0 + help1*(e**(1.d+0/3.d+0))*(delta/rm_e_gev)))
      F2 = F2 - Delta2  * (1.d+0 - (1.d+0/z))
c Computing s_at:
      help1 = DLOG(
     &(rm_mu_gev / delta)
     &                    /
     &  (((rm_mu_gev*delta) / (rm_e_gev*rm_e_gev)) + DSQRT(e))
     &                                                          )
      help2 = rm_e_gev / (delta * b1 * z**(-2.d+0/3.d+0) * DSQRT(e))
      help2 = DLOG(1.d+0 + help2)
      s_at = ((4.d+0/3.d+0) * (1.d+0 - rnu)) + (rnu * rnu)
      s_at = s_at * (help1 - help2)
c Computing s_rad:
      s_rad = 0.d+0
      if (rnu.lt.0.02d+0) then
         do i=1,3
            s_rad = s_rad + (ai(i) * rnu**(dble(i-1)))
         enddo
         goto 11111
      endif
c
      if ((rnu.ge.0.02d+0).AND.(rnu.lt.0.1d+0)) then
         do i=1,4
            s_rad = s_rad + (bi(i) * rnu**(dble(i-1)))
         enddo
         goto 11111
      endif
c
      if ((rnu.ge.0.1d+0).AND.(rnu.lt.0.9d+0)) then
         do i=1,3
            s_rad = s_rad + (ci(i) * rnu**(dble(i-1)))
         enddo
         s_rad = s_rad + (ci(4) * rnu * DLOG(rnu))
         s_rad = s_rad + (ci(5) * DLOG(1.d+0-rnu))
         s_rad = s_rad + (ci(6) * DLOG(1.d+0-rnu) * DLOG(1.d+0-rnu))
         goto 11111
      endif
c
      do i=1,3
         s_rad = s_rad + (di(i) * rnu**(dble(i-1)))
      enddo
      s_rad = s_rad + (di(4) * rnu * DLOG(rnu))
      s_rad = s_rad + (di(5) * DLOG(1.d+0-rnu))
      s_rad = s_rad + (di(6) * DLOG(1.d+0-rnu) * DLOG(1.d+0-rnu))
c
11111 continue
c
c      Computing dif. cross-section d_sigma / d_v by Sandrock's formula:
c
      brem_sandr = F1 * (2.d+0 - 2.d+0*rnu + rnu*rnu)
      brem_sandr = brem_sandr - (F2 * (2.d+0/3.d+0) * (1.d+0 - rnu))
      brem_sandr = brem_sandr + (s_at / z)
      brem_sandr = brem_sandr + ((alfa/4.d+0) * F1 * s_rad)
      brem_sandr = brem_sandr / rnu
      brem_sandr = brem_sandr * 4.d+0 * alfa * z * z
      brem_sandr = brem_sandr * ((rm_e/rm_mu)*r_e) * ((rm_e/rm_mu)*r_e)
c
c ULIM is the upper limit for energy transfer via bremsstrahlung for
c nucleus with given electric charge Z, atomic weight A, muon energy EN
c and  relative transfer RNU. If input energy transfer RNU is greater
c than ULIM cross-section value is set to ZERO;
c
      ulim=(z**(1.d+0/3.d+0)) * (rm_mu / (en * 1.d+3))
      ulim = ulim * DSQRT(e) * (3.d+0 / 4.d+0)
      ulim = 1.d+0 - ulim
      if (ulim.lt.rnu) then
         fact = 0.d+0
      else
         fact = 1.d+0
      endif

cc      if (brem_sandr.lt.0.d+0) fact = 0.d+0

c
c                                                            Final step:
c
      brem_sandr = brem_sandr * fact * dble(fa)
c
      return
      end
**************************************************************************
* B.4
*       THIS FUNCTION CALCULATES DIFFERENTIAL CROS-SECTION FOR MUON
*        BREMSSTRAHLUNG IN GIVEN MEDIA USING REAL*8 FUNCTION BREM
*
*                                  INPUT:
*                                  =====
*
*  real*4 ene    : muon energy (GeV)
*  real*4 v      : relative energy transfer
*
*                                  OUTPUT:
*                                  ======
*
*  real*4 brem_tot   : d_sigma/d_v (sq. cm), for given media, muon energy and
*                      relative energy transfer. Values of diff. cross-section
*                      are averaged over all nuclei which given media consists
*                      of:
*
*                      d_s/d_v = SUM (w_i * d_s/d_v_i), where w_i = N_i/N_tot
*                      N_i - number of type i atoms in molecule
*                      N_tot - total number of atoms in molecule
*
*                      So, it is calculated for an "effective nucleus" with
*                      atomic weight A_eff = SUM(N_i*A_i) / N_tot
*  .........................................................................
       function brem_tot(ene,v)
       external brem,crb_g4,brem_sandr
       real*8 brem_sandr,brem
       real*8 z1(10),w(10),aw(10),a_ef,en,rnu,h1,ro
       real*8 alfa,rm_e,rm_mu,r_e,avog
       real*4 ene,v
       integer nsub
       common /const/ alfa,rm_e,rm_mu,r_e,avog
       common /bremind/ ibrem
       common /media/ z1,w,aw,a_ef,ro,nsub ! this common determines media com-
c                                     ! position: AW (atomic weights), A_EF
c                                   ! (effective atomic weight), Z1 (charges),
c                                 ! W(relative weights), NSUB (number of media
c                               ! components), ro (cm/cubic cm) - media densi-
c                             ! ty.  All these  are prepared by subroutine
c                           ! MED_CONS and passed here via common /media/.
c
cccc       Tkin = ene - 0.105658389 ! For crb_g4
       Tkin = ene - (1.e-3*sngl(rm_mu)) ! For crb_g4
       if (v.gt..999995) v = .999995
       ep = v * ene ! For crb_g4
       en = dble(ene)
       rnu = dble(v)
c
      if (ibrem.eq.1) then
          h1 = w(1) * brem(z1(1),en,rnu)
      endif
      if (ibrem.eq.2) then
          h1 = w(1) * brem_sandr(z1(1),aw(1),en,rnu)
      endif
      if ((ibrem.ne.1).AND.(ibrem.ne.2)) then
         h1 = w(1) * dble(crb_g4(sngl(z1(1)),sngl(aw(1)),Tkin,ep))
      endif
c
      if (nsub.ge.2) then
         do l=2,nsub
            if (ibrem.eq.1) then
               h1 = h1 + (w(l) * brem(z1(l),en,rnu))
            endif
            if (ibrem.eq.2) then
               h1 = h1 + (w(l) * brem_sandr(z1(l),aw(l),en,rnu))
            endif
            if ((ibrem.ne.1).AND.(ibrem.ne.2)) then
               h1=h1+w(l)*dble(crb_g4(sngl(z1(l)),sngl(aw(l)),Tkin,ep))
            endif
         enddo
      endif
      brem_tot = sngl(h1)
      return
      end
****************************************************************************
* B.5
       subroutine gamma1
*
*                      The subroutine calculates:
*
*                                 [1]
*
*  the differential cross-sections d_Sigma/d_v for muon bremsstrahlung using
*            FUNCTION BREM_TOT. The result is put in three arrays
*      fcd1(81,54), fcd2(81,101) and fcd3(81,51) which are passed to
* subroutines SPL2 via common block /cdbr_in/. The reason to use just 3 arrays
*     is that the region of energy transfers is divided into 3 regions:
*      10^(-11) - 10^(-0.6), 10^(-0.6) - 10^(-0.1) and 10^(-0.1) - 1
*     for which different grid steps are accepted (0.2, 0.01 and 0.001,
*           correspondingly) to obtain accuracy better than 0.001.
*    Dif. cross-sections are computed for 81 values of muon energy starting
*  with E_mu = 10 GeV and finishing with E_mu = 1000 Pev with logarithmically
*                          equidistant grid.
*  SPL2 cooks splain coefficients out of these 3 arrays which are used in
*                          further computing.
*
*                                 [2]
*
*      Energy losses and mean free path  for muon bremsstrahlung with
*   energy transfers which exceed EMIN, VMIN and 0 and with en. transfers
*    < EMIN - arrays elo_br1(17), crt_br1(17); elo_br2(17), crt_br2(17);
*   elo_br3(17); elo_br4(17), correspondingly, which are computed for 17
*   values of muon energy starting with E_mu = 10 GeV and finishing with
*   E_mu = 1000 Pev with logarithmically equidistant grid. These arrays
*  are passed to subroutines SPL1 and ENLOS via common blocks /elbr_in1/,
*       /elbr_in2/, /elbr_in4/ and /ctbr_in1/ where they are used
*    to prepare splain coefficients for further computing and calculate
*           non-stochastic energy losses below EMIN and VMIN.
*
*                                 [3]
*
*    A value of CF which is a factor in a comparison function CF/V (V is
* relative energy transfer) which is used in subroutine GETVBREM to simulate
*               energy transfers due to bremsstrahlung.
*       CF is passed to subroutine getvbrem via common /br_ref/
*  .....................................................................
       external brem_tot,dsimps
       real*8 dsimps
       real*8 um,ene,u(10)
       real*8 aux1(0:2000),aux2(0:2000),h1,h2
       real*8 alfa,rm_e,rm_mu,r_e,avog,z1(10),w(10),aw(10),a_ef,ro
       common /const/ alfa,rm_e,rm_mu,r_e,avog ! from initial subroutine
       common /media/ z1,w,aw,a_ef,ro,nsub     !       MED_CONS
       common /general/ emin,vmin,emph         !
       common /cdbr_in/ fcd1(81,54),fcd2(81,101),fcd3(81,51) ! To SPL2
       common /ctbr_in1/ crt_br1(17),crt_br2(17) ! To SPL1 and ENLOS
       common /elbr_in1/ elo_br1(17),elo_br2(17) ! To SPL1 and ENLOS
       common /elbr_in2/ elo_br3(17)  ! to SPL1 and ENLOS
       common /elbr_in4/ elo_br4(17)  ! to ENLOS
       common /br_ref/ cf ! To GETVBREM
       common /help_1/ aux1,aux2
       common /bremind/ ibrem
c   ....................................................................
c      1.PREPARATION OF ARRAYS WITH DIFF. CROSS-SECTIONS FOR MUON
c                               BREMSSTRAHLUNG:
c
c                !       ..........................
      do j=1,81  !--->   j CYCLE BY ENERGIES starts
c                !       ..........................
        en = float(j)
        en = 1.e+1**(9.e-1 + (1.e-1 * en))
c                     !         ..................................
      do k=1,206      !--->     k CYCLE BY ENERGY TRANSFERS starts
c                     !         ..................................
      if (k.eq.206) then
        kk = 0
        fcd2(j,k-105) = float(kk)
        goto 975
      endif
c
      if (k.le.54) then
         k01 = k - 1
         rnu = 1.e+1**(float(k01) * 2.e-1 - 1.1e+1)
      else
         if (k.le.105) then
           k01 = k - 55
           rnu = 1.e+1**(float(k01) * 1.e-2 - 6.e-1)
         else
           k01 = k - 106
           rnu = 1.e+1**(float(k01) * 1.e-3 - 1.e-1)
         endif
      endif
c
      cr_dif=brem_tot(en,rnu)
      if (k.le.54) fcd1(j,k) = cr_dif
      if ((k.gt.54).AND.(k.lt.106)) fcd3(j,k-54) = cr_dif
      if (k.ge.106) fcd2(j,k-105) = cr_dif
c
 975  continue
c              !     .....................................
      enddo    !----> k CYCLE BY ENERGY TRANSFERS finishes
c              !     .....................................
      enddo    !----> j CYCLE BY ENERGIES finishes
c              !     ....................................
c   ....................................................................
c    2.PREPARATION OF ARRAYS WITH ENERGY LOSSES AND TOTAL CROSS-SECTIONS
c                         FOR MUON BREMSSTRAHLUNG:
c
c                    a) Energy transfers > EMIN :
      lim = 2000
      do i=1,17
      en = float(i)
      en = (1.e+1)**(5.e-1 + (5.e-1 * en))
      vmi = alog(emin / en) !------------> The lower limit for integration
c
        um = 0.d+0
        do k=1,nsub
        ene=dble(en)
        u(k)=((z1(k))**(1.d+0/3.d+0))*1.236540953d+0*(rm_mu/(ene*1.d+3))
        u(k) = 1.d+0 - u(k)
        um = dmax1(u(k),um)
        enddo
        vma=sngl(um)  !----------------> The upper limit for integration
        vma=alog(vma) !
        vst = (vma - vmi) / float(lim) !-> step for a rel. en. transfers grid
c
      do j=0,lim
      rnu = vmi + vst*(float(j))
      rnu = exp(rnu)
      aux1(j) = dble(brem_tot(en,rnu) * rnu)       !-> array to be integrated
c                                                  !   to get mean free path
      aux2(j) = aux1(j) * dble(rnu)                !-> array to be integrated
      enddo                                        !   for getting en. losses
c
      h1 = dble(vmi)
      h2 = dble(vma)
      crt_br1(i) = sngl(dsimps(aux1,h1,h2,lim))
      crt_br1(i) = sngl(a_ef / (avog * ro))/crt_br1(i)!->array with 17 values
c                                                     !   of free path
      elo_br1(i) = sngl( dsimps(aux2,h1,h2,lim) * avog * ro / a_ef )
      elo_br1(i) = elo_br1(i) * en * 1.e+3
      elo_br1(i) = alog10(elo_br1(i)) !-> array with 17 values of en. losses
      enddo
c
c                    b) Energy transfers > VMIN :
      do i=1,17
      en = float(i)
      en = (1.e+1)**(5.e-1 + (5.e-1 * en))
      vmi = alog(vmin)          !------------> The lower limit for integration
c
        um = 0.d+0
        do k=1,nsub
        ene=dble(en)
        u(k)=((z1(k))**(1.d+0/3.d+0))*1.236540953d+0*(rm_mu/(ene*1.d+3))
        u(k) = 1.d+0 - u(k)
        um = dmax1(u(k),um)
        enddo
        vma=sngl(um)  !----------------> The upper limit for integration
        vma=alog(vma) !
        vst = (vma - vmi) / float(lim) !-> step for a rel. en. transfers grid
c
      do j=0,lim
      rnu = vmi + vst*(float(j))
      rnu = exp(rnu)
      aux1(j) = dble(brem_tot(en,rnu) * rnu)       !-> array to be integrated
c                                                  !   to get mean free path
      aux2(j) = aux1(j) * dble(rnu)                !-> array to be integrated
      enddo                                        !   for getting en. losses
c
      h1 = dble(vmi)
      h2 = dble(vma)
      crt_br2(i) = sngl(dsimps(aux1,h1,h2,lim))
      crt_br2(i) = sngl(a_ef / (avog * ro))/crt_br2(i)!->array with 17 values
c                                                      !   of free path
      elo_br2(i) = sngl( dsimps(aux2,h1,h2,lim) * avog * ro / a_ef )
      elo_br2(i) = elo_br2(i) * en * 1.e+3
      if(elo_br2(i).le.0.e+0) elo_br2(i) = 1.e-8
      elo_br2(i) = alog10(elo_br2(i)) !-> array with 17 values of en. losses
      enddo
c
c                    c) Energy transfers > 0 :
      do i=1,17
      en = float(i)
      en = (1.e+1)**(5.e-1 + (5.e-1 * en))
      vmi = alog(1.e-3/en)      !------------> The lower limit for integration
c
        um = 0.d+0
        do k=1,nsub
        ene=dble(en)
        u(k)=((z1(k))**(1.d+0/3.d+0))*1.236540953d+0*(rm_mu/(ene*1.d+3))
        u(k) = 1.d+0 - u(k)
        um = dmax1(u(k),um)
        enddo
        vma=sngl(um)  !----------------> The upper limit for integration
        vma=alog(vma) !
        vst = (vma - vmi) / float(lim) !-> step for a rel. en. transfers grid
c
      do j=0,lim
      rnu = vmi + vst*(float(j))
      rnu = exp(rnu)
      aux2(j) = dble(brem_tot(en,rnu) * rnu * rnu) !-> array to be integrated
c                                                  !   to get en. losses
      enddo
c
      h1 = dble(vmi)
      h2 = dble(vma)
      elo_br3(i) = sngl( dsimps(aux2,h1,h2,lim) * avog * ro / a_ef )
      elo_br3(i) = elo_br3(i) * en * 1.e+3
      if(elo_br3(i).le.0.e+0) elo_br3(i) = 1.e-8
      elo_br3(i) = alog10(elo_br3(i)) !-> array with 17 values of en. losses
      enddo
c                    c) Energy transfers < EMIN
      do i=1,17
      en = float(i)
      en = (1.e+1)**(5.e-1 + (5.e-1 * en))
      vmi = alog(1.e-3/en)      !------------> The lower limit for integration
      vma = alog(emin/en)   !----------------> The upper limit for integration
      vst = (vma - vmi) / float(lim) !----> step for a rel. en. transfers grid
c
      do j=0,lim
      rnu = vmi + vst*(float(j))
      rnu = exp(rnu)
      aux2(j) = dble(brem_tot(en,rnu) * rnu * rnu) !-> array to be integrated
c                                                  !   to get en. losses
      enddo
c
      h1 = dble(vmi)
      h2 = dble(vma)
      elo_br4(i) = sngl( dsimps(aux2,h1,h2,lim) * avog * ro / a_ef )
      elo_br4(i) = elo_br4(i) * en * 1.e+3 !-> array with 17 values
      enddo                                !    of en. losses
c   ....................................................................
c                      3. COMPUTING OF CF FACTOR:
      if (ibrem.eq.1) then
      en = 1.e+9
      rnu = emin / en
      cf = brem_tot(en,rnu)
      cf = cf * rnu * 1.02
      endif
      if (ibrem.eq.2) then
      en = 1.e+9
      rnu = emin / en
      cf = brem_tot(en,rnu)
      cf = cf * rnu * 1.07
      endif
      if ((ibrem.ne.1).AND.(ibrem.ne.2)) then
      en = 1.e+1
      rnu = 1.e-3
      cf = brem_tot(en,rnu)
      cf = cf * rnu * 1.1
      endif
c
      return
      end
****************************************************************************
* B.6
      FUNCTION getlbrem(X)
*
*  THE ROUTINE USES A PART OF splain.f CODE (~/flib/splain.f) DEVELOPED AT
*                         IRKUTSK STATE UNIVERSITY
*
*    Function GETLBREM calculates the muon's free path for bremsstrahlung
*        with energy transfers > EMIN using splain coefficients
*                        prepared by SPL1 routine.
*          X is a value for muon energy expressed in GeV; XMIN,
*   XMAX and STEP are assigned with some values in subroutine SPL1 (they
*              are passed here via /sok1/ common block).
*   Array with splain coefficients C(19) is passed here from SPL1 via
*                              common /sok1_b/
* ..........................................................................
*        X MUST BE WITHIN THE RANGE OF 10 -- 1000,000,000 GeV
* ..........................................................................
*
      COMMON /sok1/ XMIN,STEP,XMAX
      common /sok1_b/ C(19)
      real*4 x
      X1 = alog10(X)
       if ((X1.lt..99999e+0).or.(X1.gt.9.0001e+0)) then
       print*,'ERROR IN FUNCTION GETLBREM: MUON ENERGY IS OUT OF RANGE'
       endif
      Y = (X1-XMIN)/STEP
      I = INT(Y+0.5)
      IF(I.LT.0.OR.X1.GT.XMAX) PRINT 1,X1,XMIN,XMAX
      Y = Y-I
      Z = Y*Y + 0.25
      getlbrem = (Z-Y)*C(I+1) + (2.-(Z+Z))*C(I+2) + (Z+Y)*C(I+3)
      RETURN
1     FORMAT('*MISTAKE*X1=',D23.16,'XMIN=',D23.16,'XMAX=',D23.16)
      END
****************************************************************************
* B.7
      FUNCTION glbremv(X)
*
*  THE ROUTINE USES A PART OF splain.f CODE (~/flib/splain.f) DEVELOPED AT
*                         IRKUTSK STATE UNIVERSITY
*
*    Function GLBREMV calculates the muon's free path for bremsstrahlung
*        with energy transfers > VMIN using splain coefficients
*                        prepared by SPL1 routine.
*          X is a value for muon energy expressed in GeV; XMIN,
*   XMAX and STEP are assigned with some values in subroutine SPL1 (they
*              are passed here via /sok1/ common block).
*   Array with splain coefficients C(19) is passed here from SPL1 via
*                              common /sok1_b2/
* ..........................................................................
*        X MUST BE WITHIN THE RANGE OF 10 -- 1000,000,000 GeV
* ..........................................................................
*
      COMMON /sok1/ XMIN,STEP,XMAX
      common /sok1_b2/ C(19)
      real*4 x
      X1 = alog10(X)
       if ((X1.lt..99999e+0).or.(X1.gt.9.0001e+0)) then
       print*,'ERROR IN FUNCTION GLBREMV: MUON ENERGY IS OUT OF RANGE'
       endif
      Y = (X1-XMIN)/STEP
      I = INT(Y+0.5)
      IF(I.LT.0.OR.X1.GT.XMAX) PRINT 1,X1,XMIN,XMAX
      Y = Y-I
      Z = Y*Y + 0.25
      glbremv = (Z-Y)*C(I+1) + (2.-(Z+Z))*C(I+2) + (Z+Y)*C(I+3)
      RETURN
1     FORMAT('*MISTAKE*X1=',D23.16,'XMIN=',D23.16,'XMAX=',D23.16)
      END
****************************************************************************
* B.8
       function getctbr(u)
*
*      The subroutine calculates the value for total muon bremsstrahlung
*              cros-section with energy transfers above EMIN.
*   The resulting cross-section is averaged over all atoms of given media:
*
*                      sigma(E_mu) = SUM (w_i * sigma_i(E_mu)),
*
*      where w_i = N_i/N_tot, N_i - number of type i atoms in molecule,
* N_tot - total number of atoms in molecule, sigma_i(E_mu) is a cross-section
*                               for atom number i.
*     So, it is calculated for an "effective nucleus" with atomic weight
*                         A_eff = SUM(N_i*A_i) / N_tot
*
*     It uses some media parameters prepared by subroutine MED_CONS
*                      (commons /const/ and /media/)
*                Input: u = muon energy (GeV)
*                Output: getctbr = total cross-section (cm)
* ..........................................................................
*        U MUST BE WITHIN THE RANGE OF 10 -- 1000,000,000 GeV
* ..........................................................................
      external getlbrem
      real*8 z1(10),w(10),aw(10),a_ef,alfa,rm_e,rm_mu,r_e,avog,ro
      real*4 u
      common /const/ alfa,rm_e,rm_mu,r_e,avog
      common /media/ z1,w,aw,a_ef,ro,nsub
      if ((u.gt.1.0001e+9).or.(u.lt.9.9999e+0)) then
      print*,'ERROR IN FUNCTION GETCTBR: MUON ENERGY IS OUT OF RANGE'
      endif
      aef = sngl(a_ef / (avog * ro))
      getctbr = aef / getlbrem(u)
      return
      end
************************************************************************
* B.9
       function gctbrv(u)
*
*      The subroutine calculates the value for total muon bremsstrahlung
*              cros-section with energy transfers above VMIN.
*   The resulting cross-section is averaged over all atoms of given media:
*
*                      sigma(E_mu) = SUM (w_i * sigma_i(E_mu)),
*
*      where w_i = N_i/N_tot, N_i - number of type i atoms in molecule,
* N_tot - total number of atoms in molecule, sigma_i(E_mu) is a cross-section
*                               for atom number i.
*     So, it is calculated for an "effective nucleus" with atomic weight
*                         A_eff = SUM(N_i*A_i) / N_tot
*
*     It uses some media parameters prepared by subroutine MED_CONS
*                      (commons /const/ and /media/)
*                Input: u = muon energy (GeV)
*                Output: gctbrv = total cross-section (cm)
* ..........................................................................
*        U MUST BE WITHIN THE RANGE OF 10 -- 1000,000,000 GeV
* ..........................................................................
      external glbremv
      real*8 z1(10),w(10),aw(10),a_ef,alfa,rm_e,rm_mu,r_e,avog,ro
      real*4 u
      common /const/ alfa,rm_e,rm_mu,r_e,avog
      common /media/ z1,w,aw,a_ef,ro,nsub
      if ((u.gt.1.0001e+9).or.(u.lt.9.9999e+0)) then
      print*,'ERROR IN FUNCTION GCTBRV: MUON ENERGY IS OUT OF RANGE'
      endif
      aef = sngl(a_ef / (avog * ro))
      gctbrv = aef / glbremv(u)
      return
      end
***************************************************************************
* B.10
         FUNCTION getdedbr(X)
*
*  THE ROUTINE USES A PART OF splain.f CODE (~/flib/splain.f) DEVELOPED AT
*                         IRKUTSK STATE UNIVERSITY
*
*       The subroutine calculates the value for muon energy losses for
*        bremsstrahlung with energy transfers above EMIN using splain
*                coefficients prepared by spl1 subroutine.
*
*          X is a value for muon energy expressed in GeV; XMIN,
*  XMAX and STEP are assigned with some values in subroutine SPL1 (they
*               are passed here via /sok5/ common block).
*   Array with splain coefficients C(19) is passed here from SPL1 via
*                              common /sok5_b/
*  ......................................................................
*  ***   ATTENTION: X must be within a range of 10 GeV --- 1000 PeV   ***
*  ......................................................................
      COMMON /sok5/ XMIN,STEP,XMAX
      common /sok5_b/ C(19)
      real*4 x
      X1 = alog10(X)
       if ((X1.lt..99999e+0).or.(X1.gt.9.0001e+0)) then
       print*,'ERROR IN FUNCTION GETDEDBR: MUON ENERGY IS OUT OF RANGE'
       endif
      Y = (X1-XMIN)/STEP
      I = INT(Y+0.5)
      IF(I.LT.0.OR.X1.GT.XMAX) PRINT 1,X1,XMIN,XMAX
      Y = Y-I
      Z = Y*Y + 0.25
      getdedbr = (Z-Y)*C(I+1) + (2.-(Z+Z))*C(I+2) + (Z+Y)*C(I+3)
      getdedbr = (1.e+1)**(getdedbr)
      RETURN
1     FORMAT('*MISTAKE*X1=',D23.16,'XMIN=',D23.16,'XMAX=',D23.16)
      END
****************************************************************************
* B.11
      FUNCTION gdedbrv(X)
*
*  THE ROUTINE USES A PART OF splain.f CODE (~/flib/splain.f) DEVELOPED AT
*                         IRKUTSK STATE UNIVERSITY
*
*       The subroutine calculates the value for muon energy losses for
*        bremsstrahlung with energy transfers above VMIN using splain
*                coefficients prepared by spl1 subroutine.
*
*          X is a value for muon energy expressed in GeV; XMIN,
*  XMAX and STEP are assigned with some values in subroutine SPL1 (they
*               are passed here via /sok5/ common block).
*   Array with splain coefficients C(19) is passed here from SPL1 via
*                              common /sok5_b2/
*  ......................................................................
*  ***   ATTENTION: X must be within a range of 10 GeV --- 1000 PeV   ***
*  ......................................................................
      COMMON /sok5/ XMIN,STEP,XMAX
      common /sok5_b2/ C(19)
      real*4 x
      X1 = alog10(X)
       if ((X1.lt..99999e+0).or.(X1.gt.9.0001e+0)) then
       print*,'ERROR IN FUNCTION GDEDBRV: MUON ENERGY IS OUT OF RANGE'
       endif
      Y = (X1-XMIN)/STEP
      I = INT(Y+0.5)
      IF(I.LT.0.OR.X1.GT.XMAX) PRINT 1,X1,XMIN,XMAX
      Y = Y-I
      Z = Y*Y + 0.25
      gdedbrv = (Z-Y)*C(I+1) + (2.-(Z+Z))*C(I+2) + (Z+Y)*C(I+3)
      gdedbrv = (1.e+1)**(gdedbrv)
      RETURN
1     FORMAT('*MISTAKE*X1=',D23.16,'XMIN=',D23.16,'XMAX=',D23.16)
      END
****************************************************************************
* B.12
         FUNCTION gdedbrt(X)
*
*  THE ROUTINE USES A PART OF splain.f CODE (~/flib/splain.f) DEVELOPED AT
*                         IRKUTSK STATE UNIVERSITY
*
*   The subroutine calculates the value for total muon energy losses due to
*    bremsstrahlung using splain coefficients prepared by spl1 subroutine.
*
*          X is a value for muon energy expressed in GeV; XMIN,
*  XMAX and STEP are assigned with some values in subroutine SPL1 (they
*               are passed here via /sok5/ common block).
*   Array with splain coefficients C(19) is passed here from SPL1 via
*                              common /sok5_b3/
*  ......................................................................
*  ***   ATTENTION: X must be within a range of 10 GeV --- 1000 PeV   ***
*  ......................................................................
      COMMON /sok5/ XMIN,STEP,XMAX
      common /sok5_b3/ C(19)
      real*4 x
      X1 = alog10(X)
       if ((X1.lt..99999e+0).or.(X1.gt.9.0001e+0)) then
       print*,'ERROR IN FUNCTION GDEDBRT: MUON ENERGY IS OUT OF RANGE'
       endif
      Y = (X1-XMIN)/STEP
      I = INT(Y+0.5)
      IF(I.LT.0.OR.X1.GT.XMAX) PRINT 1,X1,XMIN,XMAX
      Y = Y-I
      Z = Y*Y + 0.25
      gdedbrt = (Z-Y)*C(I+1) + (2.-(Z+Z))*C(I+2) + (Z+Y)*C(I+3)
      gdedbrt = (1.e+1)**(gdedbrt)
      RETURN
1     FORMAT('*MISTAKE*X1=',D23.16,'XMIN=',D23.16,'XMAX=',D23.16)
      END
****************************************************************************
* B.13
       FUNCTION getcdbr(X,Y,loga)
*
*  THE ROUTINE USES A PART OF splain.f CODE (~/flib/splain.f) DEVELOPED AT
*                         IRKUTSK STATE UNIVERSITY
*
*  The subroutine calculates the value for differential muon bremsstrahlung
*   cros-section d_Sigma/d_v using functions getcdbr1, getcdbr2, getcdbr_3e or
*  brem_tot depending on value of energy transfer Y. For definition of cross-
*  section for muon bremsstrahlung in given media see comments to subroutine
*                                 BREM_TOT.
* X and Y are values for muon energy expressed in GeV and for relative energy
*  transfer, respectively. If LOGA=0, then Y is expressed in natural units,
*           otherwise the input for Y is presented as LOG10(Y).
*  .....................................................................
*        ATTENTION: X must be within a range of 10 GeV -- 1000 PeV
*                   Y must be within a range of 10**(-11) -- 10**(0)
*  ......................................................................
       external getcdbr1,getcdbr2,getcdbr_3e,brem_tot
       real*4 X,Y
       integer loga
       if (loga.eq.0) then
          if (Y.le..251188643) then
            getcdbr = getcdbr1(X,Y,loga)
          else
            if (Y.le..794328234) then
               getcdbr = getcdbr2(X,Y,loga)
            else
               if (X.le.1.e+2) then
               Z = 0.97
               else
               Z = 0.992
               endif
               if (Y.le.Z) then
               getcdbr = getcdbr_3e(X,Y,loga)
               else
               getcdbr = brem_tot(X,Y)
               endif
            endif
          endif
       else
          if (Y.le.-6.e-1) then
            getcdbr = getcdbr1(X,Y,loga)
          else
            if (Y.le.-1.e-1) then
               getcdbr = getcdbr2(X,Y,loga)
            else
               if (X.le.1.e+2) then
               Z = -1.3228265e-2
               else
               Z = -3.4883278e-3
               endif
               if (Y.le.Z) then
               getcdbr = getcdbr_3e(X,Y,loga)
               else
               Y1 = (1.e+1)**Y
               getcdbr = brem_tot(X,Y1)
               endif
            endif
          endif
       endif
      return
      end
****************************************************************************
* B.14
       FUNCTION getcdbr1(X,Y,loga)
*
*  THE ROUTINE USES A PART OF splain.f CODE (~/flib/splain.f) DEVELOPED AT
*                         IRKUTSK STATE UNIVERSITY
*
*  The subroutine calculates the value for differential muon bremsstrahlung
* cros-section d_Sigma/d_v using splain coefficients prepared by SPL2 routine.
* For definition of cross-section for muon bremsstrahlung in given media see
*                    comments to subroutine BREM_TOT.
*  .....................................................................
*   X and Y in body program is a value for muon energy expressed in GeV and
*    for relative energy transfer, respectively. NX, NY, X0, SX, Y0 and SY
*   are assigned with some values in subroutine SPL2 (they are passed here
*   via /sok_2_1/ common block. Array with splain coefficients C1(4648) is
*            cooked by SPL2 and passed here via common /sok3/
*            If LOGA=0, then Y is expressed in natural units,
*           otherwise the input for Y is presented as LOG10(Y).
*  ......................................................................
*        ATTENTION: X must be within a range of 10 GeV -- 1000 PeV
*                   Y must be within a range of 10**(-11) -- 10**(-0.6)
*  ......................................................................
       common /sok3/ C1(4648)
       common /sok_2_1/ NX,NY,X0,SX,Y0,SY
       real*4 X,Y
       integer loga
c
      X_1=alog10(X)
c
      if ((X_1.lt..99999e+0).or.(X_1.gt.9.0001e+0)) then
      print*,'ERROR IN FUNCTION GETCDBR1: MUON ENERGY IS OUT OF RANGE'
      endif
c
      if (loga.eq.0) then
      Y_1=alog10(Y)
      else
      Y_1=Y
      endif
c
      if ((Y_1.lt.-11.001).or.(Y_1.gt.-5.9999e-1)) then
      print*,'ERROR IN FUNCTION GETCDBR1: EN. TRANSFER IS OUT OF RANGE'
      endif
c
      A3=(X_1-X0)/SX
      B3=(Y_1-Y0)/SY
      M1=INT(A3+.5)
      M2=INT(B3+.5)
      M3=NX+2
      IF(M1.LT.0.OR.M1.GE.NX.OR.M2.LT.0.OR.M2.GE.NY) THEN
      PRINT 1,X_1,M1,Y_1,M2
      ENDIF
      A3=A3-M1
      B3=B3-M2
      M1=M2*M3+M1+1
      M2=M1+M3
      M3=M2+M3
      A2 = A3*A3 +.25
      B2 = B3*B3 +.25
      A1=A2-A3
      B1=B2-B3
      A3=A2+A3
      B3=B2+B3
      A2=2.-(A2+A2)
      B2=2.-(B2+B2)
      getcdbr1=(A1*C1(M1)+A2*C1(M1+1)+A3*C1(M1+2))*B1
     2      +(A1*C1(M2)+A2*C1(M2+1)+A3*C1(M2+2))*B2
     3      +(A1*C1(M3)+A2*C1(M3+1)+A3*C1(M3+2))*B3
      if (getcdbr1.lt.0.e+0) getcdbr1 = 0.e+0
      RETURN
1     FORMAT('*MISTAKE*X=',D23.16,'MX=',I4,'Y=',D23.16,'MY=',I4)
      END
****************************************************************************
* B.15
       FUNCTION getcdbr2(X,Y,loga)
*
*  THE ROUTINE USES A PART OF splain.f CODE (~/flib/splain.f) DEVELOPED AT
*                         IRKUTSK STATE UNIVERSITY
*
*  The subroutine calculates the value for differential muon bremsstrahlung
* cros-section d_Sigma/d_v using splain coefficients prepared by SPL2 routine.
* For definition of cross-section for muon bremsstrahlung in given media see
*                    comments to subroutine BREM_TOT.
*  .....................................................................
*   X and Y in body program is a value for muon energy expressed in GeV and
*    for relative energy transfer, respectively. NX, NY, X0, SX, Y0 and SY
*   are assigned with some values in subroutine SPL2 (they are passed here
*   via /sok_2_2/ common block. Array with splain coefficients C1(4399) is
*            cooked by SPL2 and passed here via common /sok6/
*            If LOGA=0, then Y is expressed in natural units,
*           otherwise the input for Y is presented as LOG10(Y).
*  ......................................................................
*        ATTENTION: X must be within a range of 10 GeV -- 1000 PeV
*                   Y must be within a range of 10**(-0.6) -- 10**(-0.1)
*  ......................................................................
       common /sok6/ C1(4399)
       common /sok_2_2/ NX,NY,X0,SX,Y0,SY
        real*4 X,Y
       integer loga
c
      X_1=alog10(X)
      if ((X_1.lt..99999e+0).or.(X_1.gt.9.000001e+0)) then
      print*,'ERROR IN FUNCTION GETCDBR2: MUON ENERGY IS OUT OF RANGE'
      endif
c
      if (loga.eq.0) then
      Y_1=alog10(Y)
      else
      Y_1=Y
      endif
c
      if ((Y_1.lt.-.60001).or.(Y_1.gt.-.99999e-1)) then
      print*,'ERROR IN FUNCTION GETCDBR2: EN. TRANSFer IS OUT OF RANGE'
      endif
c
      A3=(X_1-X0)/SX
      B3=(Y_1-Y0)/SY
      M1=INT(A3+.5)
      M2=INT(B3+.5)
      M3=NX+2
      IF(M1.LT.0.OR.M1.GE.NX.OR.M2.LT.0.OR.M2.GE.NY) THEN
      PRINT 1,X_1,M1,Y_1,M2
      ENDIF
      A3=A3-M1
      B3=B3-M2
      M1=M2*M3+M1+1
      M2=M1+M3
      M3=M2+M3
      A2=A3*A3+.25
      B2=B3*B3+.25
      A1=A2-A3
      B1=B2-B3
      A3=A2+A3
      B3=B2+B3
      A2=2.-(A2+A2)
      B2=2.-(B2+B2)
      getcdbr2=(A1*C1(M1)+A2*C1(M1+1)+A3*C1(M1+2))*B1
     2      +(A1*C1(M2)+A2*C1(M2+1)+A3*C1(M2+2))*B2
     3      +(A1*C1(M3)+A2*C1(M3+1)+A3*C1(M3+2))*B3
      if (getcdbr2.lt.0.e+0) getcdbr2 = 0.e+0
      RETURN
1     FORMAT('*MISTAKE*X=',D23.16,'MX=',I4,'Y=',D23.16,'MY=',I4)
      END
****************************************************************************
* B.16
       FUNCTION getcdbr_3e(X,Y,loga)
*
*  THE ROUTINE USES A PART OF splain.f CODE (~/flib/splain.f) DEVELOPED AT
*                         IRKUTSK STATE UNIVERSITY
*
*  The subroutine calculates the value for differential muon bremsstrahlung
* cros-section d_Sigma/d_v using splain coefficients prepared by SPL2 routine.
* For definition of cross-section for muon bremsstrahlung in given media see
*                    comments to subroutine BREM_TOT.
*  .....................................................................
*   X and Y in body program is a value for muon energy expressed in GeV and
*    for relative energy transfer, respectively. NX, NY, X0, SX, Y0 and SY
*   are assigned with some values in subroutine SPL2 (they are passed here
*   via /sok_2_3/ common block. Array with splain coefficients C2(8549) is
*            cooked by SPL2 and passed here via common /sok4/
*            If LOGA=0, then Y is expressed in natural units,
*           otherwise the input for Y is presented as LOG10(Y).
*  ......................................................................
*        ATTENTION: X must be within a range of 10 GeV -- 1000 PeV
*                   Y must be within a range of 10**(-0.1) -- 1.0
*  ......................................................................
       common /sok4/ C2(8549)
       common /sok_2_3/ NX,NY,X0,SX,Y0,SY
       real*4 X,Y
       integer loga
c
      X_1=alog10(X)
      if ((X_1.lt..99999e+0).or.(X_1.gt.9.000001e+0)) then
      print*,'ERROR IN FUNCTION GETCDBR_3E: MUON ENERGY IS OUT OF RANGE'
      endif
c
      if (loga.eq.0) then
      Y_1=alog10(Y)
      else
      Y_1=Y
      endif
c
      if ((Y_1.lt.-1.00001e-1).or.(Y_1.gt.1.e-10)) then
      print*,'ERROR IN GETCDBR_3E: EN. TRANSFER IS OUT OF RANGE'
      endif
c
      A3=(X_1-X0)/SX
      B3=(Y_1-Y0)/SY
      M1=INT(A3+.5)
      M2=INT(B3+.5)
      M3=NX+2
      IF(M1.LT.0.OR.M1.GE.NX.OR.M2.LT.0.OR.M2.GE.NY) THEN
      PRINT 1,X_1,M1,Y_1,M2
      ENDIF
      A3=A3-M1
      B3=B3-M2
      M1=M2*M3+M1+1
      M2=M1+M3
      M3=M2+M3
      A2=A3*A3+.25
      B2=B3*B3+.25
      A1=A2-A3
      B1=B2-B3
      A3=A2+A3
      B3=B2+B3
      A2=2.-(A2+A2)
      B2=2.-(B2+B2)
      getcdbr_3e=(A1*C2(M1)+A2*C2(M1+1)+A3*C2(M1+2))*B1
     2      +(A1*C2(M2)+A2*C2(M2+1)+A3*C2(M2+2))*B2
     3      +(A1*C2(M3)+A2*C2(M3+1)+A3*C2(M3+2))*B3
      if (getcdbr_3e.lt.0.e+0) getcdbr_3e = 0.e+0
      RETURN
1     FORMAT('*MISTAKE*X=',D23.16,'MX=',I4,'Y=',D23.16,'MY=',I4)
      END
****************************************************************************
* B.17
*
      SUBROUTINE getvbrem(emw,vbr,itr)
*
*   It simulates the relative energy transfers for muon's bremsstrahlung with
*    energy transfers > EMIN (itr=0) or VMIN (itr=1) using function GETCDBR.
*                Input: emw = muon energy expressed in GeV,
*                Output: vbr = relative energy transfer.
*
*   The simulation is done by the "rejection method" (see W.H.Press et al.,
*  NUMERICAL RECEIPES (THE ART OF SCIENTIFIC COMPUTING), Cambridge University
*            press, Chapter 7, pp. 200-204) with comparison function
*                              f(v) = cf / v
* where cf is calculated by GAMMA1 routine and passed here via common /br_ref/
* ..........................................................................
*            EMW MUST BE WITHIN THE RANGE OF 10 -- 1000,000,000 GeV
* ..........................................................................
      external getcdbr
      parameter (lo=1)
      common /general/ emin,vmin,emph
      common /mcef/ mcb1,mcb2,mcp1,mcp2,mcn1,mcn2,mce1,mce2
      common /br_ref/ cf
      real*4 emw,vbr
      integer itr
      mcb1 = mcb1 + 1
         if (itr.eq.0) then
          algemin = alog10(emin/emw)
         else
          algemin = alog10(vmin)
         endif
  155 ax = algemin * rndm_mum(5)
      mcb2 = mcb2 + 1
      y1 = getcdbr(emw,ax,lo)
      vbr = exp(-2.3025851e+0 * ax)
      y2 = cf * vbr
      yc = y2 * rndm_mum(8)
ccccccccccccccccccccccccccccccccccccccccccccccccccccccccc!
           if (y2.lt.y1) then                            !  THIS PART  MAY BE
           print*,'* GETVBREM ERROR * f(v) < d_Sigma/d_v'!->REMOVED AFTER ALL
           endif                                         !  TESTS  ARE PASSED
ccccccccccccccccccccccccccccccccccccccccccccccccccccccccc!
        if (y1.ge.yc) then
        vbr = 1.e+0 / vbr
        else
        goto 155
        endif
      return
      end
****************************************************************************
*********************** PAIR PRODUCTION SUBROUTINES : **********************
****************************************************************************
* P.1
*      This routine was kindly provided by R.P.Kokoulin in November,1999
*  It was only a little bit changed (search for string "sokalski" to locate
*     2 places where it was done). Firstly, some correction in according
*   to Yadernaya Fizika N11 (1999) (Kokoulin et al) was inserted. Secondly,
* the units for output value were changed. In original version the differen-
*  tial cross-section for direct muon e+e- pair production was calculated for
*   element with given electric charge Z, atomic weight A, energy transfer EP
*  (GeV) and muon energy Tkin (Gev) in units cm^2/(g*GeV). In current version
*   the output value is multiplied by (A/N_a) * E_mu, so it represents diff.
*   cross-section for atom d_sigma/d_v where v is relative energy transfer.
*
*                                INPUT:
*                                =====
*
*  real*4 Z      : electric charge of nuclei
*  real*4 A      : atomic weights of nuclei
*  real*4 Tkin   : Muon kinetic energy (GeV)
*  real*4 EP     : Energy transfer due to e+e- pair production (GeV)
*
*                                OUTPUT:
*                                ======
*
*  real*4 CRP_G4 : d_sigma/d_v (sq. cm) for nucleus with given Z, A, muon
*                                       energy and energy transfer
*
*                     BELOW IS CODE FROM R.P.KOKOULIN:
*                     ===============================
*
c ************************************************************************
C ***   Cross section for electron pair production by fast muon         **
C ***   By R.P.Kokoulin, December 1997                                  **
C ***   Formulae from Kokoulin & Petrukhin 1971, Hobart, Eqs.(1,8,9,10) **
c ************************************************************************
      function CRP_G4 (Z,A,Tkin,EP)
c   ame in GeV:
      parameter (ame=0.51099907e-3)
ccc parameter   (amu=0.105658389)   !!! GeV
c   re in cm:
      parameter   (re=2.81794092e-13)
      parameter   (avno=6.022137e23)
      parameter   (pi=3.14159265)
c   parameter   (alpha=1./137.036)
ccc parameter   (rmass=amu/ame)     !!! "207"
c   parameter   (coeff=4./(3.*pi)*(alpha*re)**2*avno) !!! cm^2
c   sqrt(2.71828...):
      parameter   (sqrte=1.64872127)
ccc parameter   (c3=3.*sqrte*amu/4.)    !!! for limits
c   parameter   (c7=4.*ame)     !!! -"-
ccc parameter   (c8=6.*amu**2)      !!! -"-
        common /const/ alfa,rm_e,rm_mu,r_e,avog
        real*8 alfa,rm_e,rm_mu,r_e,avog
        real*4 Z,A,Tkin,EP
c     Gauss, N=8:
      DIMENSION XGI(8),WGI(8)
      DATA XGI /.0199,.1017,.2372,.4083,.5917,.7628,.8983,.9801/
      DATA WGI /.0506,.1112,.1569,.1813,.1813,.1569,.1112,.0506/
c   for the moment:
      data    bbbtf,bbbh /183.,202.4/
      data      g1tf,g2tf /1.95e-5,5.3e-5/
      data      g1h,g2h   / 4.4e-5,4.8e-5/
        common /exer1/ fa
c************************************************************************
        adummy=a
        alpha=1./137.036
        coeff=4./(3.*pi)*(alpha*re)**2*avno
        c7=4.*ame
c************************************************************************
        amu = 1.e-3 * sngl(rm_mu)
        rmass = amu/ame
        c3=3.*sqrte*amu/4.
        c8=6.*amu**2
c************************************************************************
      E=tkin+amu
      z13=z**0.3333333    !!!
      e1=e-ep
      crp_g4=0.
      if (e1.le.c3*z13) return  !!! ep > max
      alf=c7/ep         !!! 4m/ep
      a3=1.-alf
      if (a3.le.0.) return       !!! ep < min
C***        zeta calculation
      if (z.le.1.5) then   !!! special case of hydrogen
        bbb=bbbh
        g1=g1h
        g2=g2h
      else
        bbb=bbbtf
        g1=g1tf
        g2=g2tf
      end if
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c  INSERTED BY SOKALSKI TO TAKE INTO ACCOUNT DIFFERENT BBB for
c  DIFFERENT NUCLEI (S.P.KELNER, R.P.KOKOULIN, A.A.PETRUKHIN,
c  Yad.Fiz. 62, 2042 (1999) [Phys.Atom.Nucl. 62, 1894 (1999)]
c
       ztmp = z + 1.e-2
       itmp = int(ztmp)
       if (itmp.eq.1) bbb=202.4
       if (itmp.eq.2) bbb=151.9
       if (itmp.eq.3) bbb=159.9
       if (itmp.eq.4) bbb=172.3
       if (itmp.eq.5) bbb=177.9
       if (itmp.eq.6) bbb=178.3
       if (itmp.eq.7) bbb=176.6
       if (itmp.eq.8) bbb=173.4
       if (itmp.eq.9) bbb=170.0
       if (itmp.eq.10) bbb=165.8
       if (itmp.eq.11) bbb=165.8
       if (itmp.eq.12) bbb=167.1
       if (itmp.eq.13) bbb=169.1
       if (itmp.eq.14) bbb=170.8
       if (itmp.eq.15) bbb=172.2
       if (itmp.eq.16) bbb=173.4
       if (itmp.eq.17) bbb=174.3
       if (itmp.eq.18) bbb=174.8
       if (itmp.eq.19) bbb=175.1
       if (itmp.eq.20) bbb=175.6
       if (itmp.eq.21) bbb=176.2
       if (itmp.eq.22) bbb=176.8
       if (itmp.eq.26) bbb=175.8
       if (itmp.eq.29) bbb=173.1
       if (itmp.eq.32) bbb=173.0
       if (itmp.eq.35) bbb=173.5
       if (itmp.eq.42) bbb=175.9
       if (itmp.eq.50) bbb=177.4
       if (itmp.eq.53) bbb=178.6
       if (itmp.eq.74) bbb=177.6
       if (itmp.eq.82) bbb=178.0
       if (itmp.eq.92) bbb=179.8
cccccccccccccccccccccccccccccccccccccccccccccccccc
      zeta1=0.073*alog(e/(amu+g1*z13**2*e))-0.26
        if (zeta1.gt.0.) then
      zeta2=0.058*alog(e/(amu+g2*z13   *e))-0.14
      zeta=zeta1/zeta2
        else
      zeta=0.
        end if
      z2=z*(z+zeta)      !!!
      screen0=2.*ame*sqrte*bbb/(z13*ep) !!! be careful with "ame"
      a0=e*e1
      a1=ep*ep/a0      !!!  2*beta
      bet=0.5*a1      !!!   beta
      xi0=0.25*rmass*rmass*a1    !!!    xi0
      del=c8/a0     !!! 6mu^2/EE'
      tmn=alog((alf+2.*del*a3)/(1.+(1.-del)*sqrt(a3))) !!! log(1-rmax)
      sum=0.
      do i=1,8     !!!  integration
      a4=exp(tmn*xgi(i))     !!!    1-r
      a5=a4*(2.-a4)     !!! 1-r2
      a6=1.-a5      !!! r2
      a7=1.+a6      !!! 1+r2
      a9=3.+a6      !!! 3+r2
      xi=xi0*a5
      xii=1./xi
      xi1=1.+xi
      screen=screen0*xi1/a5
      yeu=5.-a6+4.*bet*a7
      yed=2.*(1.+3.*bet)*alog(3.+xii)-a6-a1*(2.-a6)
      ye1=1.+yeu/yed
      ale=alog(bbb/z13*sqrt(xi1*ye1)/(1.+screen*ye1))
      cre=0.5*alog(1.+(1.5/rmass*z13)**2*xi1*ye1)
       if (xi.le.1e3) then !!!
      be=((2.+a6)*(1.+bet)+xi*a9)*alog(1.+xii)+(a5-bet)/xi1-a9
       else
      be=(3.-a6+a1*a7)/(2.*xi) !!!-(6.-5.*a6+3.*bet*a6)/(6.*xi*xi)
       end if
        if(amu.le.1.e+0) then
      fe=amax1(0.,(ale-cre)*be)  !---> MUONs
        else
      fe=amax1(0.,ale*be)        !---> TAUs
        endif
      ymu=4.+a6+3.*bet*a7
      ymd=a7*(1.5+a1)*alog(3.+xi)+1.-1.5*a6
      ym1=1.+ymu/ymd
      alm_crm=alog(bbb*rmass/(1.5*z13*z13*(1.+screen*ym1)))
        if (xi.ge.1e-3) then     !!!
      a10=(1.+a1)*a5      !!!   (1+2b)(1-r2)
      bm=(a7*(1.+1.5*bet)-a10*xii)*alog(xi1)+xi*(a5-bet)/xi1+a10
        else
      bm=(5.-a6+bet*a9)*(xi/2.) !!!-(11.-5.*a6+.5*bet*(5.+a6))*(xi*xi/6.)
        end if
      fm=amax1(0.,(alm_crm)*bm)
        if(amu.le.1.e+0) then
      sum=sum+a4*(fe+fm/rmass**2)*wgi(i) !---> MUONs
        else
      sum=sum+a4*fe*wgi(i)               !---> TAUs
        endif
      end do
c   crp_g4=-tmn*sum*(z2/a)*coeff*e1/(e*ep) ! Zakommentirovano
c                                              ! Sokalskim 7.12.99
      crp_g4=fa*(-tmn*sum*z2*coeff*e1/ep)/avno  ! Vstavleno Sokalskim
c                                              ! (dobavlen mnozhitel
c                                              ! (A / N_a) * E )
      return
      end
****************************************************************************
* P.2
*
* This routine simply adopts CRP_G4 routine to the form which is uniformed
*     with corresponding functions of MUM code for other types of muon
*                        interactions (see, e.g., BREM).
*
*    THIS REAL*8 FUNCTION CALCULATES DIFFERENTIAL CROS-SECTION FOR MUON
*   E+E- PAIR PRODUCTION IN ACCORDING TO R.P.KOKOULIN ET AL. (see CRP_G4)
*
*                                INPUT:
*                                =====
*
*  real*8 z     : electric charge of nuclei
*  real*8 en    : muon energy (GeV)
*  real*8 rnu   : relative energy transfer = (E_transferred / E_mu)
*
*                                OUTPUT:
*                                ======
*
*  real*8 pair   : d_sigma/d_v (sq. cm) for nucleus with given Z, muon energy
*                                       and relative energy transfer
*
*   PUT YOUR ATTENTION THAT ATOMIC WEIGHT IS A DUMMY ARGUMENT SINCE CRP_G4
*                WAS SLIGHTLY CHANGED (SEE COMMENTS THERE)
*  .........................................................................
       real*8 function pair(z,en,rnu)
       external CRP_G4
       real*8 z,en,rnu
        common /const/ alfa,rm_e,rm_mu,r_e,avog
        real*8 alfa,rm_e,rm_mu,r_e,avog
       z0 = sngl(z)
       A = 10.
       Tkin = sngl(en) - (1.e-3 * sngl(rm_mu))
       ep = sngl(rnu * en)
       pa = CRP_G4(z0,A,Tkin,ep)
       pair = dble(pa)
       return
       end
****************************************************************************
* P.3
*       THIS FUNCTION CALCULATES DIFFERENTIAL CROS-SECTION FOR MUON
*        PAIR PRODUCTION IN GIVEN MEDIA USING REAL*8 FUNCTION PAIR
*
*                                  INPUT:
*                                  =====
*
*  real*4 ene    : muon energy (GeV)
*  real*4 v      : relative energy transfer
*
*                                  OUTPUT:
*                                  ======
*
*  real*4 pair_tot   : d_sigma/d_v (sq. cm), for given media, muon energy and
*                      relative energy transfer. Values of diff. cross-section
*                      are averaged over all nuclei which given media consists
*                      of:
*
*                      d_s/d_v = SUM (w_i * d_s/d_v_i), where w_i = N_i/N_tot
*                      N_i - number of type i atoms in molecule
*                      N_tot - total number of atoms in molecule
*
*                      So, it is calculated for an "effective nucleus" with
*                      atomic weight A_eff = SUM(N_i*A_i) / N_tot
*  .........................................................................
       function pair_tot(ene,v)
       external pair
       real*8 z1(10),w(10),aw(10),a_ef,en,rnu,h1,pair,ro
       real*4 ene,v
       integer nsub
       common /media/ z1,w,aw,a_ef,ro,nsub ! this common determines media com-
c                                     ! position: AW (atomic weights), A_EF
c                                   ! (effective atomic weight), Z1 (charges),
c                                 ! W(relative weights), NSUB (number of media
c                                ! components), ro (cm/cubic cm) - media densi-
c                                ! ty.  All these  are prepared by subroutine
c                               ! MED_CONS and passed here via common /media/.
c
       if (v.gt..999995) v = .999995
       en = dble(ene)
       rnu = dble(v)
       h1 = w(1) * pair(z1(1),en,rnu)
         if (nsub.ge.2) then
           do l=2,nsub
             h1 = h1 + (w(l) * pair(z1(l),en,rnu))
           enddo
         endif
       pair_tot = sngl(h1)
       return
       end
****************************************************************************
* P.4
       subroutine pair1
*
*                      The subroutine calculates:
*
*                                   [1]
*
* The differential cross-sections d_Sigma/d_v for e+e- production by muon which
*  passes a medi using FUNCTION PAIR_TOT. The result is put in three arrays
*       fcd1(81,54), fcd2(81,101) and fcd3(81,51) which are passed to
* subroutines SPL2 via common block /cdpa_in/. The reason to use just 3 arrays
*     is that the region of energy transfers is divided into 3 regions:
*      10^(-11) - 10^(-0.6), 10^(-0.6) - 10^(-0.1) and 10^(-0.1) - 1
*     for which different grid steps are accepted (0.2, 0.01 and 0.001,
*           correspondingly) to obtain accuracy better than 0.001.
*    Dif. cross-sections are computed for 81 values of muon energy starting
*  with E_mu = 10 GeV and finishing with E_mu = 1000 Pev with logarithmically
*                          equidistant grid.
*  SPL2 cooks splain coefficients out of these 3 arrays which are used in
*                          further computing.
*
*                                   [2]
*
*    Energy losses and mean free path for e+e- production by muon which
*    passes a media with energy transfers which exceed EMIN, VMIN and 0
*   and with en. transfers below EMIN - arrays elo_pa1(17), crt_pa1(17);
*           elo_pa2(17), crt_pa2(17); elo_pa3(17); elo_pa4(17),
*      correspondingly, which are computed for 17 values of muon energy
*    starting  with E_mu = 10 GeV and finishing with E_mu = 1000 Pev with
*  logarithmically equidistant grid. These arrays are passed to subroutines
*   SPL1 and ENLOS via common blocks /elpa_in1/, /elpa_in2/, /elpa_in4/ and
*  /ctpa_in1/ where they are used to prepare splain coefficients for further
*  computing and calculate non-stochastic al energy losses below EMIN and VMIN.
*
*                                   [3]
*
* A comparison function COM_PA_M which is used in subroutine GETVPA to simulate
*   energy transfers due to e+e- pair production. COM_PA_M is computed as a
*   differential cross-section for e+e- pair production by muon with energy
*  1000 PeV. The values of diff. cross-section are multiplied by factor 1.03
* to make sure that comparison function is exceed the diff. cross-sections for
* any muon energy in a range of 10GeV - 1000 PeV and relative energy transfers
*                     in a range of (emin/1000 PeV) -- 1):
*          COMPARISON FUNCTION = 1.12 * [d_sigma / d_v (1000 PeV)]
*   Values of computed comparison function are put into array COM_PA_M(2201)
*   which is determined on a logarithmically equidistant grid with values of
*            relative energy transfers in a range of 10^(-11) -- 1.
*     This array is passed to subroutine SPL1 to cook splain coefficients
*       which are used in further computing to get value of comparison
*     function at any value of relative energy transfer by interpolation.
*
*                                   [4]
*
*     Array COM_PA_IN with values of integrated comparison function:
*          COM_PA_IN (v1) = INT( v = 10^(-11) -- v1 ) (COM_PA_M)
*  which is used in further computing to simulate energy transfers due to
*   e+e- pair production. COM_PA_IN is determined on a logarithmically
*                                equidistant
*      grid of relative energy transfers in a range of 10^(-11) -- 1.
*  This REAL*8 array is passed to subroutine DSPL1 to cook splain coefficients
*   which are used in further computing to get value of integrated comparison
*    function at any value of relative energy transfer by interpolation.
*  Also a value of TOT_PA = COM_PA_IN (v1=1.0) is computed and passed to
*         subroutine GETVPA which simulate energy transfers.
*  .....................................................................
       external pair_tot,dsimps
       real*8 dsimps
       real*8 ai,bi,h1,h2,um,ene,u(10)
       real*8 aux1(0:2000),aux2(0:2000)
       real*8 alfa,rm_e,rm_mu,r_e,avog,z1(10),w(10),aw(10),a_ef,ro
       real*8 com1_pa(0:2200),com_pa_in(1101),com_p_h(0:2),tot_pa
       dimension com_pa_m(2201)
       common /help_1/ aux1,aux2
       common /const/ alfa,rm_e,rm_mu,r_e,avog ! from initial subroutine
       common /media/ z1,w,aw,a_ef,ro,nsub     !       MED_CONS
       common /general/ emin,vmin,emph         !
       common /cdpa_in/ fcd1(81,54),fcd2(81,101),fcd3(81,51) ! to SPL2
       common /ctpa_in1/ crt_pa1(17),crt_pa2(17) ! To SPL1 and ENLOS
       common /elpa_in1/ elo_pa1(17),elo_pa2(17) ! To SPL1 and ENLOS
       common /elpa_in2/ elo_pa3(17)   !-> to SPL1 and ENLOS
       common /elpa_in4/ elo_pa4(17)   !-> to ENLOS
       common /sok34/ com_pa_m       !
       common /sok24/ com_pa_in  ! To DSPL1
       common /sok33/ tot_pa  ! To GETVPA
       common /fac_pa/ fac ! To COMP
       fac = 1.12
c ....................................................................
c      1.PREPARATION OF ARRAYS WITH DIFF. CROSS-SEECTIONS FOR MUON
c                           E+E- PAIR PRODUCTION:
c
c                !       ..........................
      do j=1,81  !--->   j CYCLE BY ENERGIES starts
c                !       ..........................
        en = float(j)
        en = 1.e+1**(9.e-1 + (1.e-1 * en))
c                     !         ..................................
      do k=1,206      !--->     k CYCLE BY ENERGY TRANSFERS starts
c                     !         ..................................
      if (k.eq.206) then
        fcd2(j,k-105) = -37.0
        goto 975
      endif
c
      if (k.le.54) then
         k01 = k - 1
         rnu = 1.e+1**(float(k01) * 2.e-1 - 1.1e+1)
      else
         if (k.le.105) then
           k01 = k - 55
           rnu = 1.e+1**(float(k01) * 1.e-2 - 6.e-1)
         else
           k01 = k - 106
           rnu = 1.e+1**(float(k01) * 1.e-3 - 1.e-1)
         endif
      endif
c
      cr_dif=pair_tot(en,rnu)
      if (cr_dif.le.1.e-37) cr_dif = 1.e-37
      cr_dif=alog(cr_dif)
c
      if (k.le.54) fcd1(j,k) = cr_dif
      if ((k.gt.54).AND.(k.lt.106)) fcd3(j,k-54) = cr_dif
      if (k.ge.106) fcd2(j,k-105) = cr_dif
c
 975  continue
c              !     ....................................
      enddo    !---> k CYCLE BY ENERGY TRANSFERS finishes
c              !     ....................................
      enddo    !----> j CYCLE BY ENERGIES finishes
c              !     ....................................
c   ....................................................................
c      2.PREPARATION OF ARRAYS WITH ENERGY LOSSES AND MEAN FREE PATH
c                         FOR MUON BREMSSTRAHLUNG:
c
c                    a) Energy transfers > EMIN :
      lim = 2000
      do i=1,17
      en = float(i)
      en = (1.e+1)**(5.e-1 + (5.e-1 * en))
      vmi = alog(emin / en) !------------> The lower limit for integration
        um = 0.d+0
        do k=1,nsub
        ene=dble(en)
        u(k)=((z1(k))**(1.d+0/3.d+0))*1.236540953d+0*(rm_mu/(ene*1.d+3))
        u(k) = 1.d+0 - u(k)
        um = dmax1(u(k),um)
        enddo
        vma=sngl(um)  !----------------> The upper limit for integration
        vma=alog(vma) !
        vst = (vma - vmi) / float(lim) !-> step for a rel. en. transfers grid
      do j=0,lim
      rnu = vmi + vst*(float(j))
      rnu = exp(rnu)
      aux1(j) = dble(pair_tot(en,rnu) * rnu)       !-> array to be integrated
c                                                  !   to get mean free path
      aux2(j) = aux1(j) * dble(rnu)                !-> array to be integrated
      enddo                                        !   for getting en. losses
c
      h1 = dble(vmi)
      h2 = dble(vma)
      crt_pa1(i) = sngl(dsimps(aux1,h1,h2,lim))             !-> array with 17 values
      crt_pa1(i) = sngl(a_ef / (avog * ro))/crt_pa1(i)  !   of free path
      crt_pa1(i) = alog(crt_pa1(i))
      elo_pa1(i) = sngl( dsimps(aux2,h1,h2,lim) * avog * ro / a_ef )
      elo_pa1(i) = elo_pa1(i) * en * 1.e+3
      elo_pa1(i) = alog(elo_pa1(i)) !-> array with 17 values of en. losses
      enddo
c                    b) Energy transfers > VMIN :
      do i=1,17
      en = float(i)
      en = (1.e+1)**(5.e-1 + (5.e-1 * en))
      vmi = alog(vmin) !------------> The lower limit for integration
        um = 0.d+0
        do k=1,nsub
        ene=dble(en)
        u(k)=((z1(k))**(1.d+0/3.d+0))*1.236540953d+0*(rm_mu/(ene*1.d+3))
        u(k) = 1.d+0 - u(k)
        um = dmax1(u(k),um)
        enddo
        vma=sngl(um)  !----------------> The upper limit for integration
        vma=alog(vma) !
        vst = (vma - vmi) / float(lim) !-> step for a rel. en. transfers grid
c
      do j=0,lim
      rnu = vmi + vst*(float(j))
      rnu = exp(rnu)
      aux1(j) = dble(pair_tot(en,rnu) * rnu)       !-> array to be integrated
c                                                  !   to get mean free path
      aux2(j) = aux1(j) * dble(rnu)                !-> array to be integrated
      enddo                                        !   for getting en. losses
c
      h1 = dble(vmi)
      h2 = dble(vma)
      crt_pa2(i) = sngl(dsimps(aux1,h1,h2,lim))             !-> array with 17 values
      crt_pa2(i) = sngl(a_ef / (avog * ro))/crt_pa2(i)  !   of free path
      crt_pa2(i) = alog(crt_pa2(i))
      elo_pa2(i) = sngl( dsimps(aux2,h1,h2,lim) * avog * ro / a_ef )
      elo_pa2(i) = elo_pa2(i) * en * 1.e+3
      if(elo_pa2(i).le.0.e+0) elo_pa2(i) = 1.e-8
      elo_pa2(i) = alog(elo_pa2(i)) !-> array with 17 values of en. losses
      enddo
c                    c) Energy transfers > 0 :
      do i=1,17
      en = float(i)
      en = (1.e+1)**(5.e-1 + (5.e-1 * en))
      vmi = alog(2.046e-3/en) !------------> The lower limit for integration
c
        um = 0.d+0
        do k=1,nsub
        ene=dble(en)
        u(k)=((z1(k))**(1.d+0/3.d+0))*1.236540953d+0*(rm_mu/(ene*1.d+3))
        u(k) = 1.d+0 - u(k)
        um = dmax1(u(k),um)
        enddo
        vma=sngl(um)  !----------------> The upper limit for integration
        vma=alog(vma) !
        vst = (vma - vmi) / float(lim) !-> step for a rel. en. transfers grid
      do j=0,lim
      rnu = vmi + vst*(float(j))
      rnu = exp(rnu)
      aux2(j) = dble(pair_tot(en,rnu) * rnu * rnu) !-> array to be integrated
      enddo                                        !   for getting en. losses
c
      h1 = dble(vmi)
      h2 = dble(vma)
      elo_pa3(i) = sngl( dsimps(aux2,h1,h2,lim) * avog * ro / a_ef )
      elo_pa3(i) = elo_pa3(i) * en * 1.e+3
      if(elo_pa3(i).le.0.e+0) elo_pa3(i) = 1.e-8
      elo_pa3(i) = alog(elo_pa3(i)) !-> array with 17 values of en. losses
      enddo
c                    d) Energy transfers < EMIN :
      do i=1,17
      en = float(i)
      en = (1.e+1)**(5.e-1 + (5.e-1 * en))
      vmi = alog(2.046e-3/en) !------------> The lower limit for integration
      vma = alog(emin/en)  !----------------> The upper limit for integration
      vst = (vma - vmi) / float(lim) !---> step for a rel. en. transfers grid
      do j=0,lim
      rnu = vmi + vst*(float(j))
      rnu = exp(rnu)
      aux2(j) = dble(pair_tot(en,rnu) * rnu * rnu) !-> array to be integrated
      enddo                                        !   for getting en. losses
c
      h1 = dble(vmi)
      h2 = dble(vma)
      elo_pa4(i) = sngl( dsimps(aux2,h1,h2,lim) * avog * ro / a_ef )
      elo_pa4(i) = elo_pa4(i) * en * 1.e+3 !-> array with 17 values
      enddo                                !   of en. losses
c   ....................................................................
c   3. PREPARATION OF ARRAY COM_PA_M WITH VALUES OF COMPARISON FUNCTION:
         en = 1.e+9
           do i=1,2201
              i1 = i - 1
              rnu = 1.e+1**(float(i1) * 5.e-3 - 1.1e+1)
              com_pa_m(i) = fac * pair_tot(en,rnu)
              com1_pa(i-1) = dble(com_pa_m(i) * rnu)
           enddo
           do i=1,2201
              if (com_pa_m(i).le.0.e+0) com_pa_m(i) = 1.0001e-37
              com_pa_m(i)=alog(com_pa_m(i))
           enddo
c   ....................................................................
c       4. PREPARATION OF ARRAY COM_PA_IN WITH VALUES OF INTEGRATED
c                 COMPARISON FUNCTION AND VALUE OF TOT_PA:
        com_pa_in(1) = 0.d+0
        h1 = 0.d+0
        m = 2
          do i=2,1101
             i1 = 2 * i
               com_p_h(0) = com1_pa(i1-4)
               com_p_h(1) = com1_pa(i1-3)
               com_p_h(2) = com1_pa(i1-2)
             ai = -((dble(1102 - i)) * 1.d-2)
             bi = ai + 1.d-2
             ai = 2.302585093 * ai
             bi = 2.302585093 * bi
             h2 = dsimps(com_p_h,ai,bi,m)
             h1 = h1 + h2
             com_pa_in(i) = h1
          enddo
        tot_pa = com_pa_in(1101)
       return
       end
****************************************************************************
* P.5
      FUNCTION getlpair(X)
*
*  THE ROUTINE USES A PART OF splain.f CODE (~/flib/splain.f) DEVELOPED AT
*                         IRKUTSK STATE UNIVERSITY
*
*  Function GETLPAIR calculates the muon's free path for e+e- pair production
*   with energy transfers > EMIN using splain coefficients prepared by spl1
*                                subroutine.
*          X is a value for muon energy expressed in GeV; XMIN,
*   XMAX and STEP are assigned with some values in subroutine SPL1 (they
*              are passed here via /sok1/ common block).
*   Array with splain coefficients C(19) is passed here from SPL1 via
*                              common /sok1_p/
* ..........................................................................
*        X MUST BE WITHIN THE RANGE OF 10 -- 1000,000,000 GeV
* ..........................................................................
      COMMON /sok1/ XMIN,STEP,XMAX
      common /sok1_p/ C(19)
      real*4 x
      X1 = alog10(X)
       if ((X1.lt..99999e+0).or.(X1.gt.9.0001e+0)) then
       print*,'ERROR IN FUNCTION GETLPAIR: MUON ENERGY IS OUT OF RANGE'
       endif
      Y = (X1-XMIN)/STEP
      I = INT(Y+0.5)
      IF(I.LT.0.OR.X1.GT.XMAX) PRINT 1,X1,XMIN,XMAX
      Y = Y-I
      Z = Y*Y + 0.25
      getlpair = (Z-Y)*C(I+1) + (2.-(Z+Z))*C(I+2) + (Z+Y)*C(I+3)
      getlpair = exp(getlpair)
      RETURN
1     FORMAT('*MISTAKE*X1=',D23.16,'XMIN=',D23.16,'XMAX=',D23.16)
      END
****************************************************************************
* P.6
      FUNCTION glpairv(X)
*
*  THE ROUTINE USES A PART OF splain.f CODE (~/flib/splain.f) DEVELOPED AT
*                         IRKUTSK STATE UNIVERSITY
*
*  Function GLPAIRV calculates the muon's free path for e+e- pair production
*   with energy transfers > VMIN using splain coefficients prepared by spl1
*                                subroutine.
*          X is a value for muon energy expressed in GeV; XMIN,
*   XMAX and STEP are assigned with some values in subroutine SPL1 (they
*              are passed here via /sok1/ common block).
*   Array with splain coefficients C(19) is passed here from SPL1 via
*                              common /sok1_p2/
* ..........................................................................
*        X MUST BE WITHIN THE RANGE OF 10 -- 1000,000,000 GeV
* ..........................................................................
      COMMON /sok1/ XMIN,STEP,XMAX
      common /sok1_p2/ C(19)
      real*4 x
      X1 = alog10(X)
       if ((X1.lt..99999e+0).or.(X1.gt.9.0001e+0)) then
       print*,'ERROR IN FUNCTION GLPAIRV: MUON ENERGY IS OUT OF RANGE'
       endif
      Y = (X1-XMIN)/STEP
      I = INT(Y+0.5)
      IF(I.LT.0.OR.X1.GT.XMAX) PRINT 1,X1,XMIN,XMAX
      Y = Y-I
      Z = Y*Y + 0.25
      glpairv = (Z-Y)*C(I+1) + (2.-(Z+Z))*C(I+2) + (Z+Y)*C(I+3)
      glpairv = exp(glpairv)
      RETURN
1     FORMAT('*MISTAKE*X1=',D23.16,'XMIN=',D23.16,'XMAX=',D23.16)
      END
****************************************************************************
* P.7
       function getctpa(u)
*
*      The subroutine calculates the value for total cross-section for e+e-
*    pair production with energy transfers above EMIN using getlpair routine.
*     It also uses some media parameters prepared by subroutine MED_CONS
*                       (commons /const/ and /media/)
*   The resulting cross-section is averaged over all atoms of given media:
*
*                      sigma(E_mu) = SUM (w_i * sigma_i(E_mu)),
*
*      where w_i = N_i/N_tot, N_i - number of type i atoms in molecule,
* N_tot - total number of atoms in molecule, sigma_i(E_mu) is a cross-section
*                               for atom number i.
*     So, it is calculated for an "effective nucleus" with atomic weight
*                         A_eff = SUM(N_i*A_i) / N_tot
*
*           U is a value for muon energy expressed in GeV
*  ......................................................................
*  ***   ATTENTION: U must be within a range of 10 GeV -- 1000 PeV   ***
*  ......................................................................
       external getlpair
       real*8 z1(10),w(10),aw(10),a_ef,alfa,rm_e,rm_mu,r_e,avog,ro
       real*4 u
       common /const/ alfa,rm_e,rm_mu,r_e,avog
       common /media/ z1,w,aw,a_ef,ro,nsub
      if ((u.gt.1.0001e+9).or.(u.lt.9.9999e+0)) then
      print*,'ERROR IN FUNCTION GETCTPA: MUON ENERGY IS OUT OF RANGE'
      endif
      aef = sngl(a_ef / (avog * ro))
      getctpa = aef / getlpair(u)
      return
      end
*************************************************************************
* P.8
       function gctpav(u)
*
*      The subroutine calculates the value for total cross-section for e+e-
*    pair production with energy transfers above VMIN using glpairv routine.
*     It also uses some media parameters prepared by subroutine MED_CONS
*                       (commons /const/ and /media/)
*   The resulting cross-section is averaged over all atoms of given media:
*
*                      sigma(E_mu) = SUM (w_i * sigma_i(E_mu)),
*
*      where w_i = N_i/N_tot, N_i - number of type i atoms in molecule,
* N_tot - total number of atoms in molecule, sigma_i(E_mu) is a cross-section
*                               for atom number i.
*     So, it is calculated for an "effective nucleus" with atomic weight
*                         A_eff = SUM(N_i*A_i) / N_tot
*
*           U is a value for muon energy expressed in GeV
*  ......................................................................
*  ***   ATTENTION: U must be within a range of 10 GeV -- 1000 PeV   ***
*  ......................................................................
       external glpairv
       real*8 z1(10),w(10),aw(10),a_ef,alfa,rm_e,rm_mu,r_e,avog,ro
       real*4 u
       common /const/ alfa,rm_e,rm_mu,r_e,avog
       common /media/ z1,w,aw,a_ef,ro,nsub
      if ((u.gt.1.0001e+9).or.(u.lt.9.9999e+0)) then
      print*,'ERROR IN FUNCTION GCTPAV: MUON ENERGY IS OUT OF RANGE'
      endif
      aef = sngl(a_ef / (avog * ro))
      gctpav = aef / glpairv(u)
      return
      end
************************************************************************
* P.9
       FUNCTION getdedpa(X)
*
*  THE ROUTINE USES A PART OF splain.f CODE (~/flib/splain.f) DEVELOPED AT
*                         IRKUTSK STATE UNIVERSITY
*
*       The subroutine calculates the value for muon energy losses for
*     e+e- pair production with energy transfers above EMIN using splain
*                coefficients prepared by spl1 subroutine.
*
*          X is a value for muon energy expressed in GeV; XMIN,
*  XMAX and STEP are assigned with some values in subroutine SPL1 (they
*               are passed here via /sok5/ common block).
*   Array with splain coefficients C(19) is passed here from SPL1 via
*                              common /sok5_p/
*  ......................................................................
*  ***   ATTENTION: X must be within a range of 10 GeV --- 1000 PeV   ***
*  ......................................................................
      COMMON /sok5/ XMIN,STEP,XMAX
      common /sok5_p/ C(19)
      real*4 x
      X1 = alog10(X)
       if ((X1.lt..99999e+0).or.(X1.gt.9.0001e+0)) then
       print*,'ERROR IN FUNCTION GETDEDPA: MUON ENERGY IS OUT OF RANGE'
       endif
      Y = (X1-XMIN)/STEP
      I = INT(Y+0.5)
      IF(I.LT.0.OR.X1.GT.XMAX) PRINT 1,X1,XMIN,XMAX
      Y = Y-I
      Z = Y*Y + 0.25
      getdedpa = (Z-Y)*C(I+1) + (2.-(Z+Z))*C(I+2) + (Z+Y)*C(I+3)
      getdedpa = exp(getdedpa)
      RETURN
1     FORMAT('*MISTAKE*X1=',D23.16,'XMIN=',D23.16,'XMAX=',D23.16)
      END
****************************************************************************
* P.10
      FUNCTION gdedpav(X)
*
*  THE ROUTINE USES A PART OF splain.f CODE (~/flib/splain.f) DEVELOPED AT
*                         IRKUTSK STATE UNIVERSITY
*
*       The subroutine calculates the value for muon energy losses for
*     e+e- pair production with energy transfers above VMIN using splain
*                coefficients prepared by spl1 subroutine.
*
*          X is a value for muon energy expressed in GeV; XMIN,
*  XMAX and STEP are assigned with some values in subroutine SPL1 (they
*               are passed here via /sok5/ common block).
*   Array with splain coefficients C(19) is passed here from SPL1 via
*                              common /sok5_p2/
*  ......................................................................
*  ***   ATTENTION: X must be within a range of 10 GeV --- 1000 PeV   ***
*  ......................................................................
      COMMON /sok5/ XMIN,STEP,XMAX
      common /sok5_p2/ C(19)
      real*4 x
      X1 = alog10(X)
       if ((X1.lt..99999e+0).or.(X1.gt.9.0001e+0)) then
       print*,'ERROR IN FUNCTION GDEDPAV: MUON ENERGY IS OUT OF RANGE'
       endif
      Y = (X1-XMIN)/STEP
      I = INT(Y+0.5)
      IF(I.LT.0.OR.X1.GT.XMAX) PRINT 1,X1,XMIN,XMAX
      Y = Y-I
      Z = Y*Y + 0.25
      gdedpav = (Z-Y)*C(I+1) + (2.-(Z+Z))*C(I+2) + (Z+Y)*C(I+3)
      gdedpav = exp(gdedpav)
      RETURN
1     FORMAT('*MISTAKE*X1=',D23.16,'XMIN=',D23.16,'XMAX=',D23.16)
      END
****************************************************************************
* P.11
       FUNCTION gdedpat(X)
*
*  THE ROUTINE USES A PART OF splain.f CODE (~/flib/splain.f) DEVELOPED AT
*                         IRKUTSK STATE UNIVERSITY
*
*  The subroutine calculates the value for total muon energy losses due to
*     e+e- pair production using splain coefficients prepared by spl1
*                                   subroutine.
*
*          X is a value for muon energy expressed in GeV; XMIN,
*  XMAX and STEP are assigned with some values in subroutine SPL1 (they
*               are passed here via /sok5/ common block).
*   Array with splain coefficients C(19) is passed here from SPL1 via
*                              common /sok5_p3/
*  ......................................................................
*  ***   ATTENTION: X must be within a range of 10 GeV --- 1000 PeV   ***
*  ......................................................................
      COMMON /sok5/ XMIN,STEP,XMAX
      common /sok5_p3/ C(19)
      real*4 x
      X1 = alog10(X)
       if ((X1.lt..99999e+0).or.(X1.gt.9.0001e+0)) then
       print*,'ERROR IN FUNCTION GDEDPAT: MUON ENERGY IS OUT OF RANGE'
       endif
      Y = (X1-XMIN)/STEP
      I = INT(Y+0.5)
      IF(I.LT.0.OR.X1.GT.XMAX) PRINT 1,X1,XMIN,XMAX
      Y = Y-I
      Z = Y*Y + 0.25
      gdedpat = (Z-Y)*C(I+1) + (2.-(Z+Z))*C(I+2) + (Z+Y)*C(I+3)
      gdedpat = exp(gdedpat)
      RETURN
1     FORMAT('*MISTAKE*X1=',D23.16,'XMIN=',D23.16,'XMAX=',D23.16)
      END
****************************************************************************
* P.12
        FUNCTION getcdp(X,Y,lo)
*
*  THE ROUTINE USES A PART OF splain.f CODE (~/flib/splain.f) DEVELOPED AT
*                         IRKUTSK STATE UNIVERSITY
*
* The subroutine calculates the value for differential cross-section for muon
* muon pair production d_Sigma/d_v using functions getcdp1, getcdp2, getcdp_3e
*   or pair_tot depending on value of energy transfer Y. For definition of
* cross-section for muon e+e- pair production in given media see comments to
*                            subroutine PAIR_TOT.
* X and Y are values for muon energy expressed in GeV and for relative energy
*   transfer, respectively. If LO=0, then Y is expressed in natural units,
*           otherwise the input for Y is presented as LOG10(Y).
*  .....................................................................
*        ATTENTION: X must be within a range of 10 GeV -- 1000 PeV
*                   Y must be within a range of 10**(-11) -- 10**(0)
*  ......................................................................
       external getcdp1,getcdp2,getcdp_3e,pair_tot
       real*4 X,Y
       integer lo
       if (lo.eq.0) then
          if (Y.le..251188643) then
                getcdp = getcdp1(X,Y,lo)
               getcdp = exp(getcdp)
          else
               if (Y.le..794328234) then
                  getcdp = getcdp2(X,Y,lo)
                  getcdp = exp(getcdp)
               else
                 if (Y.le..965) then
                    getcdp = getcdp_3e(X,Y,lo)
                    getcdp = exp(getcdp)
                 else
                    getcdp = pair_tot(X,Y)
                 endif
               endif
          endif
       else
          if (Y.le.-6.e-1) then
                getcdp = getcdp1(X,Y,lo)
                getcdp = exp(getcdp)
          else
                if (Y.le.-1.e-1) then
                   getcdp = getcdp2(X,Y,lo)
                   getcdp = exp(getcdp)
                else
                   if (Y.le.-1.547272686e-2) then
                     getcdp = getcdp_3e(X,Y,lo)
                     getcdp = exp(getcdp)
                   else
                     Y1 = (1.e+1)**Y
                     getcdp = pair_tot(X,Y1)
                   endif
                endif
          endif
       endif
      if (getcdp.lt.0.e+0) getcdp = 0.e+0
      return
      end
****************************************************************************
* P.13
        FUNCTION getcdp1(X,Y,loga)
*
*  THE ROUTINE USES A PART OF splain.f CODE (~/flib/splain.f) DEVELOPED AT
*                         IRKUTSK STATE UNIVERSITY
*
* The subroutine calculates the value for differential cross-section for muon
*   pair production d_Sigma/d_v using splain coefficients prepared by SPL2
*                                     routine.
*  For definition of cross-section for e+e- pair production in given media see
*                    comments to subroutine PAIR_TOT.
*  .....................................................................
*   X and Y in body program is a value for muon energy expressed in GeV and
*    for relative energy transfer, respectively. NX, NY, X0, SX, Y0 and SY
*   are assigned with some values in subroutine SPL2 (they are passed here
*   via /sok_2_1/ common block. Array with splain coefficients C1(4648) is
*            cooked by SPL2 and passed here via common /sok8/
*            If LOGA=0, then Y is expressed in natural units,
*           otherwise the input for Y is presented as LOG10(Y).
*                  Output is presented as LN (d_sigma/d_v)
*  ......................................................................
*        ATTENTION: X must be within a range of 10 GeV -- 1000 PeV
*                   Y must be within a range of 10**(-11) -- 10**(-0.6)
*  ......................................................................
      common /sok8/ C1(4648)
      common /sok_2_1/ NX,NY,X0,SX,Y0,SY
       real*4 X,Y
       integer loga
      X_1=alog10(X)
      if ((X_1.lt..99999e+0).or.(X_1.gt.9.0001e+0)) then
      print*,'ERROR IN FUNCTION GETCDP1: MUON ENERGY IS OUT OF RANGE'
      endif
c
      if (loga.eq.0) then
      Y_1=alog10(Y)
      else
      Y_1=Y
      endif
      if ((Y_1.lt.-11.001).or.(Y_1.gt.-5.9999e-1)) then
      print*,'ERROR IN FUNCTION GETCDP1: EN. TRANSFER IS OUT OF RANGE'
      endif
c
      A3=(X_1-X0)/SX
      B3=(Y_1-Y0)/SY
      M1=INT(A3+.5)
      M2=INT(B3+.5)
      M3=NX+2
      IF(M1.LT.0.OR.M1.GE.NX.OR.M2.LT.0.OR.M2.GE.NY) THEN
      PRINT 1,X_1,M1,Y_1,M2
      ENDIF
      A3=A3-M1
      B3=B3-M2
      M1=M2*M3+M1+1
      M2=M1+M3
      M3=M2+M3
      A2=A3*A3+.25
      B2=B3*B3+.25
      A1=A2-A3
      B1=B2-B3
      A3=A2+A3
      B3=B2+B3
      A2=2.-(A2+A2)
      B2=2.-(B2+B2)
      getcdp1=(A1*C1(M1)+A2*C1(M1+1)+A3*C1(M1+2))*B1
     2      +(A1*C1(M2)+A2*C1(M2+1)+A3*C1(M2+2))*B2
     3      +(A1*C1(M3)+A2*C1(M3+1)+A3*C1(M3+2))*B3
      RETURN
1     FORMAT('GETCDP1: *MISTAKE*X= ',D23.16,' MX= ',I4,' Y= ',D23.16,' M
     *Y= ',I4)
      END
****************************************************************************
* P.14
       FUNCTION getcdp2(X,Y,loga)
*
*  THE ROUTINE USES A PART OF splain.f CODE (~/flib/splain.f) DEVELOPED AT
*                         IRKUTSK STATE UNIVERSITY
*
* The subroutine calculates the value for differential cross-section for muon
*      pair production d_Sigma/d_v using splain coefficients prepared by
*                               SPL2 routine.
*  For definition of cross-section for e+e- pair production in given media see
*                    comments to subroutine PAIR_TOT.
*  .....................................................................
*   X and Y in body program is a value for muon energy expressed in GeV and
*    for relative energy transfer, respectively. NX, NY, X0, SX, Y0 and SY
*   are assigned with some values in subroutine SPL2 (they are passed here
*   via /sok_2_2/ common block. Array with splain coefficients C1(4399) is
*            cooked by SPL2 and passed here via common /sok9/
*            If LOGA=0, then Y is expressed in natural units,
*           otherwise the input for Y is presented as LOG10(Y).
*                  Output is presented as LN (d_sigma/d_v)
*  ......................................................................
*        ATTENTION: X must be within a range of 10 GeV -- 1000 PeV
*                   Y must be within a range of 10**(-0.6) -- 10**(-0.1)
*  ......................................................................
       common /sok9/ C1(4399)
       common /sok_2_2/ NX,NY,X0,SX,Y0,SY
       real*4 X,Y
       integer loga
      X_1=alog10(X)
      if ((X_1.lt..99999e+0).or.(X_1.gt.9.0001e+0)) then
      print*,'ERROR IN FUNCTION GETCDP2: MUON ENERGY IS OUT OF RANGE'
      endif
      if (loga.eq.0) then
      Y_1=alog10(Y)
      else
      Y_1=Y
      endif
      if ((Y_1.lt.-.60001).or.(Y_1.gt.-.99999e-1)) then
      print*,'ERROR IN FUNCTION GETCDP2: EN. TRANSFer IS OUT OF RANGE'
      endif
      A3=(X_1-X0)/SX
      B3=(Y_1-Y0)/SY
      M1=INT(A3+.5)
      M2=INT(B3+.5)
      M3=NX+2
      IF(M1.LT.0.OR.M1.GE.NX.OR.M2.LT.0.OR.M2.GE.NY) THEN
      PRINT 1,X_1,M1,Y_1,M2
      ENDIF
      A3=A3-M1
      B3=B3-M2
      M1=M2*M3+M1+1
      M2=M1+M3
      M3=M2+M3
      A2=A3*A3+.25
      B2=B3*B3+.25
      A1=A2-A3
      B1=B2-B3
      A3=A2+A3
      B3=B2+B3
      A2=2.-(A2+A2)
      B2=2.-(B2+B2)
      getcdp2=(A1*C1(M1)+A2*C1(M1+1)+A3*C1(M1+2))*B1
     2      +(A1*C1(M2)+A2*C1(M2+1)+A3*C1(M2+2))*B2
     3      +(A1*C1(M3)+A2*C1(M3+1)+A3*C1(M3+2))*B3
      RETURN
1     FORMAT('GCDP2:*MISTAKE*X=',D23.16,'MX=',I4,'Y=',D23.16,'MY=',I4)
      END
****************************************************************************
* P.15
       FUNCTION getcdp_3e(X,Y,loga)
*
*  THE ROUTINE USES A PART OF splain.f CODE (~/flib/splain.f) DEVELOPED AT
*                         IRKUTSK STATE UNIVERSITY
*
* The subroutine calculates the value for differential cross-section for muon
*      pair production d_Sigma/d_v using splain coefficients prepared by
*                                  SPL2 routine.
*  For definition of cross-section for e+e- pair production in given media see
*                    comments to subroutine PAIR_TOT.
*  .....................................................................
*   X and Y in body program is a value for muon energy expressed in GeV and
*    for relative energy transfer, respectively. NX, NY, X0, SX, Y0 and SY
*   are assigned with some values in subroutine SPL2 (they are passed here
*   via /sok_2_3/ common block. Array with splain coefficients C2(8549) is
*            cooked by SPL2 and passed here via common /sok10/
*            If LOGA=0, then Y is expressed in natural units,
*           otherwise the input for Y is presented as LOG10(Y).
*                  Output is presented as LN (d_sigma/d_v)
*  ......................................................................
*        ATTENTION: X must be within a range of 10 GeV -- 1000 PeV
*                   Y must be within a range of 10**(-0.1) -- 1
*  ......................................................................
       common /sok10/ C2(8549)
       common /sok_2_3/ NX,NY,X0,SX,Y0,SY
       real*4 X,Y
       integer loga
      X_1=alog10(X)
      if ((X_1.lt..99999e+0).or.(X_1.gt.9.0001e+0)) then
      print*,'ERROR IN FUNCTION GETCDP_3E: MUON ENERGY IS OUT OF RANGE'
      endif
      if (loga.eq.0) then
      Y_1=alog10(Y)
      else
      Y_1=Y
      endif
      if ((Y_1.lt.-1.0001e-1).or.(Y_1.gt.1.e-6)) then
      print*,'ERROR IN FUNCTION GETCDP_3E: EN. TRANSFER IS OUT OF RANGE'
      endif
      A3=(X_1-X0)/SX
      B3=(Y_1-Y0)/SY
      M1=INT(A3+.5)
      M2=INT(B3+.5)
      M3=NX+2
      IF(M1.LT.0.OR.M1.GE.NX.OR.M2.LT.0.OR.M2.GE.NY) THEN
      PRINT 1,X_1,M1,Y_1,M2
      ENDIF
      A3=A3-M1
      B3=B3-M2
      M1=M2*M3+M1+1
      M2=M1+M3
      M3=M2+M3
      A2=A3*A3+.25
      B2=B3*B3+.25
      A1=A2-A3
      B1=B2-B3
      A3=A2+A3
      B3=B2+B3
      A2=2.-(A2+A2)
      B2=2.-(B2+B2)
      getcdp_3e=(A1*C2(M1)+A2*C2(M1+1)+A3*C2(M1+2))*B1
     2      +(A1*C2(M2)+A2*C2(M2+1)+A3*C2(M2+2))*B2
     3      +(A1*C2(M3)+A2*C2(M3+1)+A3*C2(M3+2))*B3
      RETURN
1     FORMAT('*MISTAKE*X=',D23.16,'MX=',I4,'Y=',D23.16,'MY=',I4)
      END
****************************************************************************
* P.16
      FUNCTION comp(X)
*
*  THE ROUTINE USES A PART OF splain.f CODE (~/flib/splain.f) DEVELOPED AT
*                         IRKUTSK STATE UNIVERSITY
*
*       The subroutine calculates the values for comparison function
*  to simulate energy transfers due to e+e- pair production by muon in media.
*  The input values for comparison function are calculated by subroutine PAIR1.
* Then subroutine SPL1 cooks an array with splains which is passed here to COMP
*    by common /sok55_p/. COMP gives the value of comparison function basing
*   on these splains for any relative energy transfers which are in a range of
*                                10^(-11) -- 1.
*           Input: LOG10(V) where V is relative energy transfer
*           Output: Value for comparison function
*  ......................................................................
*  Comparison function is calculated in subroutine PAIR1 as d_sigma/d_v
*        for e+e- pair production for muon energy E_mu = 1000 PeV
*   Splains are prepared by SPL1 for LN of comp. function values, so here
*  in COMP one takes EXP from final value obtained by splain interpolations.
*  ......................................................................
*         ***   ATTENTION: X must be within a range of -11 -- 0 ***
*  ......................................................................
      external pair_tot
      common /sok55/ XMIN,STEP,XMAX
      common /sok55_p/ C(2203)
      common /fac_pa/ fac
      parameter (en = 1.e+9)
      real*4 x
      X1 = X
      if (X1.lt.-1.5472686e-2) then
       if ((X1.lt.-11.001e+0).or.(X1.gt.1.e-5)) then
       print*,'ERROR IN FUNCTION COMP: ENERGY transfer IS OUT OF RANGE'
       endif
      Y = (X1-XMIN)/STEP
      I = INT(Y+0.5)
      IF(I.LT.0.OR.X1.GT.XMAX) PRINT 1,X1,XMIN,XMAX
      Y = Y-I
      Z = Y*Y + 0.25
      comp = exp((Z-Y)*C(I+1) + (2.-(Z+Z))*C(I+2) + (Z+Y)*C(I+3))
      else
      rnu = 1.e+1**X1
      comp = fac * pair_tot(en,rnu)
      endif
      RETURN
1     FORMAT('*MISTAKE* X1=',D23.16,'  XMIN=',D23.16,'  XMAX=',D23.16)
      END
****************************************************************************
* P.17
      real*8 FUNCTION c_pa_in(X)
*
*  THE ROUTINE USES A PART OF splain.f CODE (~/flib/splain.f) DEVELOPED AT
*                         IRKUTSK STATE UNIVERSITY
*
* The subroutine calculates the value of integrated comparison function which
* is necessary for simulation of energy transfers due to e+e- pairs production.
*           using splain coefficients prepared by dspl1 subroutine.
*
*      X is a value for relative energy transfer; XMIN, XMAX and STEP are
*   assigned with some values in subroutine DSPL1 (they are passed here via
*                           /sok25/ common block).
*    Array with splain coefficients C(1103) is passed here from DSPL1 via
*                               common /sok26/
*  ......................................................................
*     ***   ATTENTION: X must be within a range of 10^(-11) -- 1   ***
*  ......................................................................
      real*8 XMIN,STEP,XMAX
      real*8 C(1103)
      real*8 X,X1,Y,Z
      COMMON /sok25/ XMIN,STEP,XMAX
      common /sok26/ C
       X1 = dlog10(X)
       if ((X1.lt.-11.0001d+0).or.(X1.gt.1.d-6)) then
       print*,'ERROR IN FUNCTION C_PA_IN: TRANSFER IS OUT OF RANGE'
       endif
      Y = (X1-XMIN)/STEP
      I = INT(Y+0.5)
      IF(I.LT.0.OR.X1.GT.XMAX) PRINT 1,X1,XMIN,XMAX
      Y = Y-I
      Z = Y*Y + 0.25
      c_pa_in = (Z-Y)*C(I+1) + (2.-(Z+Z))*C(I+2) + (Z+Y)*C(I+3)
      RETURN
1     FORMAT('*MISTAKE*X1=',D23.16,'XMIN=',D23.16,'XMAX=',D23.16)
      END
****************************************************************************
* P.18
        SUBROUTINE DSPLQ1
*
*    It is based on SUBROUTINE SPLINE (W.H.Press et al., Numerical Recipes,
*  Chapter 3, section 3.3) which is tuned to NATURAL CUBIC SPLINE and adopted
*                           for purpose of MUM.
*
*   The routine prepares cubic splain coefficients (array Y2) to get value of
*  LOG10(relative energy transfer) by interpolation with a value of integrated
*   comparison function (X array) as an argument. It is necessary to simulate
*            relative energy transfers due to e+e- pair production.
*
*   BOTH INPUT ARRAYS (Y and X) and output array Y2 are of real*8 precision.
*  ......................................................................
      PARAMETER (N=1101)
      real*8 x(N),y(N),Y2(N),U(N),P,SIG,QN,UN
      common /sok24/ X
c                    !->input array with values of integrated comparison
c                       function (is passed from PAIR1 routine)
c
      common /pa_in_s2/ Y
c                       !->array with rel.energy transfers (to DSPLIN1)
c
      common /pa_in_s3/ Y2
c                        !->output array with splain
c                           coefficients (to DSPLIN1)
ccc
      do i=1,N                              ! Preparation of array Y(1101):
        Y(i) = -1.1d+1 + dble(i-1) * 1.d-2  !   log10(rel. en. transfer)
      enddo   !-----------------------------!       from -11.0 to 0.
      Y(N) = 0.d+0                          !------ with step 0.01
      Y2(1)=0.d+0
      U(1)=0.d+0
      DO 11 I=2,N-1 !------------------------------------------!
        SIG=(X(I)-X(I-1))/(X(I+1)-X(I-1))                      !  Cooking of
        P=SIG*Y2(I-1)+2.d+0                                    !    splain
        Y2(I)=(SIG-1.d+0)/P                                    ! coefficients
        U(I)=(6.d+0*((Y(I+1)-Y(I))/(X(I+1)-X(I))-(Y(I)-Y(I-1)) ! and putting
     *      /(X(I)-X(I-1)))/(X(I+1)-X(I-1))-SIG*U(I-1))/P      !  them into
11    CONTINUE                                                 !   output
c                                                              !  Y2(1101)
      QN=0.d+0                                                 !  array to
      UN=0.d+0                                                 !  be passed
c                                                              ! to routine
      Y2(N)=(UN-QN*U(N-1))/(QN*Y2(N-1)+1.d+0)                  !  DSPLIN1
      DO 12 K=N-1,1,-1                                         !
        Y2(K)=Y2(K)*Y2(K+1)+U(K)                               !
12    CONTINUE  !----------------------------------------------!
      RETURN
      END
***********************************************************************
* P.19
      real*8 FUNCTION DSPLIN1(X1)
*
*   It is based on SUBROUTINE SPLINT (W.H.Press et al., Numerical Recipes,
*       Chapter 3, section 3.3) which is adopted for purpose of MUM.
*
*    The routine performs an interpolation using splains prepared by DSPLQ1.
*      The value of integrated comparison function for simulation of energy
*   transfers due to e+e- pair production  (see comments to routines PAIR1 and
*    DSPLQ1) X1 is an input, the value of LOG10(relative energy transfer) (Y1,
*            DSPLIN1) is an output to be used in routine GETVPA.
*
*   BOTH INPUT AND OUTPUT VARIABLES (X1 and DSPLIN1) are of real*8 precision.
c............................................................................
      PARAMETER (N=1101)
      real*8 X1,Y1
      real*8 XA(N),YA(N),Y2A(N),X,Y,H,A,B
      common /sok24/ XA
c                     !---------------> values of integrated comparison
c                                       function (from PAIR1)
c
      common /pa_in_s2/ YA
c                        !->array with log10(rel. en. transf.) (from DSPLQ1)
c
      common /pa_in_s3/ Y2A
c                        !-> array with cubic splains from DSPLQ1
      X=X1
      KLO=1
      KHI=N
1     IF (KHI-KLO.GT.1) THEN
        K=(KHI+KLO)/2
        IF(XA(K).GT.X)THEN
          KHI=K
        ELSE
          KLO=K
        ENDIF
      GOTO 1
      ENDIF
      H=XA(KHI)-XA(KLO)
c
c     This 'IF' line was commented in July, 2019:
c
ccc      IF (H.EQ.0.d+0) PAUSE 'Bad XA input at function DSPLIN1...'
c
c     This 3 lines with 'IF' are instead of old line (see just above):
c
      IF (H.EQ.0.d+0) THEN
      PRINT*,'Bad XA input at function DSPLIN1...'
      ENDIF
c
      A=(XA(KHI)-X)/H
      B=(X-XA(KLO))/H
      Y=A*YA(KLO)+B*YA(KHI)+
     *      ((A*A*A-A)*Y2A(KLO)+(B*B*B-B)*Y2A(KHI))*(H*H)/6.d+0
      Y1 = Y
      DSPLIN1 = Y1
                      if ((Y1.ge.1.d-10).OR.(Y1.lt.-1.1001d+1)) then
      print*,'DSPLIN1 ERR: IN =',X1,'(MAX=',XA(N),'), OUT=',Y1
                       endif
      RETURN
      END
****************************************************************************
* P.20
      SUBROUTINE getvpa(emw,vbr,itr)
*
* It simulates the relative energy transfers for e+e- pair production by muon
*       with energy transfers > EMIN (if itr=0) or > VMIN (otherwise).
*                Input: emw = muon energy expressed in GeV,
*               Output: vbr = relative energy transfer.
*
*   The simulation is done by the "rejection method" (see W.H.Press et al.,
*  NUMERICAL RECEIPES (THE ART OF SCIENTIFIC COMPUTING), Cambridge University
*   press, Chapter 7, pp. 200-204). Comparison function is computed within
*  routine PAIR1 as a differential cross-section for e+e- pair production by
* muon with energy 1000 PeV. The values of diff. cross-section are multiplied
*   by factor 1.03 to make sure that comparison function is exceed the diff.
*   cross-sections for any muon energy in a range of 10GeV - 1000 PeV and
*      relative energy transfers in a range of (emin/1000 PeV) -- 1):
*          COMPARISON FUNCTION = 1.03 * [d_sigma / d_v (1000 PeV)]
* ..........................................................................
*            EMW MUST BE WITHIN THE RANGE OF 10 -- 1000,000 GeV
* ..........................................................................
       external c_pa_in,dsplin1,getcdp,comp
       parameter (lo=1)
       parameter (len=1)
       real*8 c_pa_in,tot_pa,ai1,dsplin1,ax,algemin,arn
       real*4 emw,vbr
       integer itr
       common /general/ emin,vmin,emph
       common/sok33/ tot_pa
       common /mcef/ mcb1,mcb2,mcp1,mcp2,mcn1,mcn2,mce1,mce2
        mcp1 = mcp1 + 1
          if (itr.eq.0) then
          algemin = dble(emin/emw)
          else
          algemin = dble(amax1(vmin,2.044e-3/emw))
          endif
        ai1 = c_pa_in(algemin)
        algemin = tot_pa - ai1
  155   arn = dble(rndm_mum(5))
        mcp2 = mcp2 + 1
        ax = (algemin * arn) + ai1
          if (ax.gt.tot_pa) ax = tot_pa
        ax = dsplin1(ax)
          if (ax.ge.-1.d-5) ax = -1.d-5
        ay = sngl(ax)
c
        if (vmin.le.8.e-4) then
        az = (1.e+1)**ay
        echeck = az * emw
        if (echeck.ge.6.5e-3) then
        y1 = getcdp(emw,ay,lo)
        else
        y1 = pair_tot(emw,az)
        endif
        else
        y1 = getcdp(emw,ay,lo)
        endif
c
        vbr = sngl(ax)
        y2 = comp(vbr)
        arn = rndm_mum(8)
        yc = y2 * sngl(arn)
cccccccccccccccccccccccccccccccccccccccccccccccccccccccc!
           if (y2.lt.y1) then                           !    THIS PART  MAY BE
           print*,'* GETVPA ERROR * f(v) < d_Sigma/d_v' !--> REMOVED AFTER ALL
           endif                                        !    TESTS  ARE PASSED
cccccccccccccccccccccccccccccccccccccccccccccccccccccccc!
        if (y1.ge.yc) then
        vbr = (1.e+1)**ay
        else
        goto 155
        endif
      return
      end
****************************************************************************
************************* PHOTONUCLEAR SUBROUTINES : ***********************
****************************************************************************
* N.1
*     THIS REAL*8 FUNCTION CALCULATES DIFFERENTIAL CROS-SECTION FOR MUON
*       PHOTONUCLEAR INTERACTION ACCORDING TO EITHER BUGAEV-BEZRUKOV OR
*                           ZEUS PARAMETRIZATION
*
*                                  INPUT:
*                                  =====
*
*  real*8 z     : electric charge of nuclei
*  real*8 en    : muon energy (GeV)
*  real*8 rnu   : relative energy transfer = (E_transferred / E_mu)
*  real*8 a     : atomic weight of nucleus
*
*                                 OUTPUT:
*                                 ======
*
*  real*8 phnu   : d_sigma/d_v (sq. cm) for nucleus with given Z, muon
*                  energy, relative energy transfer and A
*  .........................................................................
      real*8 function phnu(z,en,rnu,a)
      external QCD_C
      real*8 z,en,rnu,a,rnu1
      real*8 alfa,rm_e,rm_mu,r_e,fact,avog,m1,m2,mn,s,sigma,t,hv,zet
      real*8 te1,te2,te3,g,etr
      integer iqcd
      common /qcd/ iqcd
c     From MED_CONS, indicates Sigma_gamma_p:
      common /pnsig/ ibb
      common /exer1/ fa
      common /const/ alfa,rm_e,rm_mu,r_e,avog
c                             I
c                             I-------------->! universal constants which are
c                                             ! provided by subroutine
c                                             ! MED_CONS and are passed here
c                                             ! by common /const/
c     m1 and m2 - GeV squared:
      parameter (m1 = 5.4d-1)
      parameter (m2 = 1.8d+0)
c     mn - nucleon mass (Gev) = (Mp + Mn) / 2:
      parameter (mn = .939d+0)
c     fact = alfa / (8 * pi):
      parameter (fact = 2.903524525d-4)
      rnu1 = 1.d+0 - rnu
      etr = rnu * en
      s = etr * 2.d+0 * mn
       if (ibb.eq.1) then
        sigma = 1.143d+2 + 1.647d+0 * ((dlog(2.13d-2 * etr))**2.d+0)
c       it is Sigma_gamma_p parametrization from Bezrukov-Bugaev
       else
        sigma = (6.35d+1 * (s**9.7d-2)) + (1.45d+2 / (s**5.d-1))
c       it is Sigma_gamm_p parametrization from ZEUS (J.Breitweg
c       et al., hep-ex/9809005, Eur.Phys.J., C7 (1999) 609)
       endif
      sigma = sigma * 1.d-30
      t = (rm_mu * rm_mu * 1.d-6 * rnu * rnu) / rnu1
      hv = 1.d+0 - (2.d+0 / rnu) + (2.d+0 / (rnu * rnu))
      zet = 2.82d-3 * sigma * 1.d+30 * (a**(1.d+0 / 3.d+0))
c upgrade BB formula: =========>
c      te1 = hv * dlog(1.d+0 + (m2/t))
      te1 = (hv + ((2.d-6*rm_mu*rm_mu)/(m2))) * dlog(1.d+0 + (m2/t))
c =============================>
      if(t.gt.1.d-7) then
        te2 = 1.d+0 - ((.25d+0 * m2/t) * dlog(1.d+0 + (t/m2)))
        te2 = te2 * 2.d+0 * rm_mu * rm_mu * 1.d-6 / t
      else
        te2 = (1.5d+0 / t) * rm_mu * rm_mu * 1.d-6
      endif
      te3 = (dlog(1.d+0 + (m1/t)) - (m1/(m1 + t))) * hv
c upgrade BB formula: =========>
c      te3=te3-((2.d+0*rm_mu*rm_mu*1.d-6/t)*(1.d+0-((.25d+0*m1)/(m1+t))))
      te3=te3-((2.d+0*rm_mu*rm_mu*1.d-6/t)*
     &                            (1.d+0-((.25d+0*m1-t)/(m1+t))))
      te3=te3+(((4.d-6*rm_mu*rm_mu)/(m1))*dlog(1.d+0+((m1)/t)))
c =============================>
      g = ( (1.d+0 + zet) * dexp(-zet) ) - 1.d+0
      g = ( ( g / (zet * zet) ) + 5.d-1 ) * ( 9.d+0 / zet )
      if(z.lt.1.5d+0) g = 3.d+0  !---------> Special case for hydrogen
      phnu = te1 - te2 + (g * te3)
      phnu = phnu * fact * rnu * sigma * a * dble(fa)
c=================> QCD-corrections:
      IF(iqcd.EQ.1) THEN
        dops = QCD_C(SNGL(rnu),SNGL(en)) * fa * SNGL(a)
        IF(dops.GE.0.) phnu = phnu + ((1.D-30 * DBLE(dops)) / rnu)
      ENDIF
c=================>
      IF (phnu.LT.0.D+0) phnu = 0.D+0
      return
      end
************************************************************************
* N.1a
*
      SUBROUTINE QCD_CORR
*
* Computes QCD corrections for photonuclear interaction as was developed
* by E.Bugaev & Yu.Shlepin, put them in arrays COR_MU and COR_TAU, then
*    computes splain coefficients (array C(730) in common /qcd_new/ )
*
      DOUBLE PRECISION A_MU(8,7),A_TAU(8,7),COR_MU(71,8),COR_TAU(71,8)
      DOUBLE PRECISION V, V1, CORR_MU, CORR_TAU, SL_MU, SL_TAU
      DIMENSION F(71,8),D(90,27),C(730)
      COMMON /what_lep/ ilep
      COMMON /qcd_new/ C
      DATA NX /71/
      DATA NY /8/
c
c Coefficients for MU (from Bugaev-Shlepin, October 2002 & March 2003):
c                 computed for standard rock (A=22)
c
c     muon, 10^3 GeV
c
      A_MU(1, 1) = 0.0157837D+0
      A_MU(2, 1) = -5.3593D+0
      A_MU(3, 1) = -6.47286D+0
      A_MU(4, 1) = -3.64846D+0
      A_MU(5, 1) = -1.1501D+0
      A_MU(6, 1) = -0.205223D+0
      A_MU(7, 1) = -0.0192542D+0
      A_MU(8, 1) = -0.000735492D+0
c
c     muon, 10^4 GeV
c
      A_MU(1, 2) = 0.0376904D+0
      A_MU(2, 2) = -12.6647D+0
      A_MU(3, 2) = -15.0953D+0
      A_MU(4, 2) = -8.41549D+0
      A_MU(5, 2) = -2.63226D+0
      A_MU(6, 2) = -0.467407D+0
      A_MU(7, 2) = -0.0437325D+0
      A_MU(8, 2) = -0.00166849D+0
c
c     muon, 10^5 GeV
c
      A_MU(1, 3) = 0.0898107D+0
      A_MU(2, 3) = -34.1874D+0
      A_MU(3, 3) = -44.0928D+0
      A_MU(4, 3) = -26.5711D+0
      A_MU(5, 3) = -8.87342D+0
      A_MU(6, 3) = -1.66224D+0
      A_MU(7, 3) = -0.162793D+0
      A_MU(8, 3) = -0.00647547D+0
c
c     muon, 10^6 GeV
c
      A_MU(1, 4) = 0.189826D+0
      A_MU(2, 4) = -71.5287D+0
      A_MU(3, 4) = -87.9917D+0
      A_MU(4, 4) = -51.2985D+0
      A_MU(5, 4) = -16.7509D+0
      A_MU(6, 4) = -3.08549D+0
      A_MU(7, 4) = -0.297893D+0
      A_MU(8, 4) = -0.0116941D+0
c
c     muon, 10^7 GeV
c
      A_MU(1, 5) = 0.273715D+0
      A_MU(2, 5) = -131.49D+0
      A_MU(3, 5) = -150.811D+0
      A_MU(4, 5) = -85.5305D+0
      A_MU(5, 5) = -27.9549D+0
      A_MU(6, 5) = -5.21569D+0
      A_MU(7, 5) = -0.511526D+0
      A_MU(8, 5) = -0.0203833D+0
c
c     muon, 10^8 GeV
c
      A_MU(1, 6) = 0.48501D+0
      A_MU(2, 6) = -208.904D+0
      A_MU(3, 6) = -221.255D+0
      A_MU(4, 6) = -124.006D+0
      A_MU(5, 6) = -41.4446D+0
      A_MU(6, 6) = -7.95112D+0
      A_MU(7, 6) = -0.798525D+0
      A_MU(8, 6) = -0.0324086D+0
c
c     muon, 10^9 GeV
c
      A_MU(1, 7) = 0.710326D+0
      A_MU(2, 7) = -306.442D+0
      A_MU(3, 7) = -316.191D+0
      A_MU(4, 7) = -185.205D+0
      A_MU(5, 7) = -64.8621D+0
      A_MU(6, 7) = -12.8027D+0
      A_MU(7, 7) = -1.30405D+0
      A_MU(8, 7) = -0.0532388D+0
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c      DATA (A_MU(J, 1),J=1,8) /  !        muon, 10^3 GeV
c     & 0.0157837D+0, -5.3593D+0, -6.47286D+0, -3.64846D+0,  -1.1501D+0,
c     & -0.205223D+0, -0.0192542D+0, -0.000735492D+0 /
c
c      DATA (A_MU(J, 2),J=1,8) /  !        muon, 10^4 GeV
c     & 0.0376904D+0, -12.6647D+0, -15.0953D+0, -8.41549D+0, -2.63226D+0,
c     & -0.467407D+0, -0.0437325D+0, -0.00166849D+0 /
c
c      DATA (A_MU(J, 3),J=1,8) /  !        muon, 10^5 GeV
c     & 0.0898107D+0, -34.1874D+0, -44.0928D+0, -26.5711D+0, -8.87342D+0,
c     & -1.66224D+0, -0.162793D+0, -0.00647547D+0 /
c
c      DATA (A_MU(J, 4),J=1,8) /  !        muon, 10^6 GeV
c     & 0.189826D+0, -71.5287D+0, -87.9917D+0, -51.2985D+0, -16.7509D+0,
c     & -3.08549D+0, -0.297893D+0, -0.0116941D+0 /
c
c      DATA (A_MU(J, 5),J=1,8) /  !        muon, 10^7 GeV
c     & 0.273715D+0, -131.49D+0, -150.811D+0, -85.5305D+0, -27.9549D+0,
c     & -5.21569D+0, -0.511526D+0, -0.0203833D+0 /
c
c      DATA (A_MU(J, 6),J=1,8) /  !        muon, 10^8 GeV
c     & 0.48501D+0, -208.904D+0, -221.255D+0, -124.006D+0, -41.4446D+0,
c     & -7.95112D+0, -0.798525D+0, -0.0324086D+0 /
c
c      DATA (A_MU(J, 7),J=1,8) /  !        muon, 10^9 GeV
c     & 0.710326D+0, -306.442D+0, -316.191D+0, -185.205D+0, -64.8621D+0,
c     & -12.8027D+0, -1.30405D+0, -0.0532388D+0 /
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c Coefficients for TAU (from Bugaev-Shlepin, October 2002 & March 2003):
c                 computed for standard rock (A=22)
c
c
c     tau, 10^3 GeV
c
      A_TAU(1, 1) = -0.00279225D+0
      A_TAU(2, 1) = -0.343867D+0
      A_TAU(3, 1) = 1.03267D+0
      A_TAU(4, 1) = 1.17448D+0
      A_TAU(5, 1) = 0.492829D+0
      A_TAU(6, 1) = 0.102496D+0
      A_TAU(7, 1) = 0.0106092D+0
      A_TAU(8, 1) = 0.000436414D+0
c
c     tau, 10^4 GeV
c
      A_TAU(1, 2) = -0.00625653D+0
      A_TAU(2, 2) = -0.789706D+0
      A_TAU(3, 2) = 2.55848D+0
      A_TAU(4, 2) = 2.88145D+0
      A_TAU(5, 2) = 1.20912D+0
      A_TAU(6, 2) = 0.252265D+0
      A_TAU(7, 2) = 0.0262464D+0
      A_TAU(8, 2) = 0.00108684D+0
c
c     tau, 10^5 GeV
c
      A_TAU(1, 3) = -0.0126754
      A_TAU(2, 3) = -1.70908
      A_TAU(3, 3) = 6.74136
      A_TAU(4, 3) = 7.50275
      A_TAU(5, 3) = 3.18879
      A_TAU(6, 3) = 0.679863
      A_TAU(7, 3) = 0.072661
      A_TAU(8, 3) = 0.00310106
c
c     tau, 10^6 GeV
c
      A_TAU(1, 4) = -0.0262998D+0
      A_TAU(2, 4) = -3.46225D+0
      A_TAU(3, 4) = 15.4908D+0
      A_TAU(4, 4) = 16.5646D+0
      A_TAU(5, 4) = 6.86187D+0
      A_TAU(6, 4) = 1.43318D+0
      A_TAU(7, 4) = 0.150554D+0
      A_TAU(8, 4) = 0.0063314D+0
c
c     tau, 10^7 GeV
c
      A_TAU(1, 5) = -0.0289825D+0
      A_TAU(2, 5) = -5.98402D+0
      A_TAU(3, 5) = 31.6914D+0
      A_TAU(4, 5) = 31.3704D+0
      A_TAU(5, 5) = 12.2688D+0
      A_TAU(6, 5) = 2.44171D+0
      A_TAU(7, 5) = 0.246202D+0
      A_TAU(8, 5) = 0.00999873D+0
c
c     tau, 10^8 GeV
c
      A_TAU(1, 6) = -2.13163D-13
      A_TAU(2, 6) = -9.2095D+0
      A_TAU(3, 6) = 55.7338D+0
      A_TAU(4, 6) = 50.2693D+0
      A_TAU(5, 6) = 18.3936D+0
      A_TAU(6, 6) = 3.49729D+0
      A_TAU(7, 6) = 0.343508D+0
      A_TAU(8, 6) = 0.0138178D+0
c
c     tau, 10^9 GeV
c
      A_TAU(1, 7) = -1.42109D-13
      A_TAU(2, 7) = -17.6991D+0
      A_TAU(3, 7) = 70.7923D+0
      A_TAU(4, 7) = 56.0714D+0
      A_TAU(5, 7) = 17.7885D+0
      A_TAU(6, 7) = 2.95729D+0
      A_TAU(7, 7) = 0.258242D+0
      A_TAU(8, 7) = 0.00942025D+0
ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c      DATA (A_TAU(J, 1),J=1,8) / !        tau, 10^3 GeV
c     & -0.00279225D+0, -0.343867D+0, 1.03267D+0, 1.17448D+0,
c     &  0.492829D+0, 0.102496D+0, 0.0106092D+0, 0.000436414D+0 /
c
c      DATA (A_TAU(J, 2),J=1,8) / !        tau, 10^4 GeV
c     & -0.00625653D+0, -0.789706D+0, 2.55848D+0, 2.88145D+0,
c     &  1.20912D+0, 0.252265D+0, 0.0262464D+0, 0.00108684D+0 /
c
c      DATA (A_TAU(J, 3),J=1,8) / !        tau, 10^5 GeV
c     & -0.0126754, -1.70908, 6.74136, 7.50275, 3.18879,
c     & 0.679863, 0.072661, 0.00310106 /
c
c      DATA (A_TAU(J, 4),J=1,8) / !        tau, 10^6 GeV
c     & -0.0262998D+0, -3.46225D+0, 15.4908D+0, 16.5646D+0, 6.86187D+0,
c     & 1.43318D+0, 0.150554D+0, 0.0063314D+0 /
c
c      DATA (A_TAU(J, 5),J=1,8) / !        tau, 10^7 GeV
c     & -0.0289825D+0, -5.98402D+0, 31.6914D+0, 31.3704D+0, 12.2688D+0,
c     &  2.44171D+0, 0.246202D+0, 0.00999873D+0 /
c
c      DATA (A_TAU(J, 6),J=1,8) / !        tau, 10^8 GeV
c     & -2.13163D-13, -9.2095D+0, 55.7338D+0, 50.2693D+0, 18.3936D+0,
c     &  3.49729D+0, 0.343508D+0, 0.0138178D+0 /
c
c      DATA (A_TAU(J, 7),J=1,8) / !        tau, 10^9 GeV
c     & -1.42109D-13, -17.6991D+0, 70.7923D+0, 56.0714D+0, 17.7885D+0,
c     &  2.95729D+0, 0.258242D+0, 0.00942025D+0 /
ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c       Bugaev's data are down to 10^3 GeV. We artifically assign
c   "correction=0" for 10^2 GeV to enlarge interpolation energy range:
c
      DO I=1,71
        COR_MU(I,1)  = 0.D+0
        COR_TAU(I,1) = 0.D+0
      ENDDO
c
c   Bugaev's corrections work for v > 10^(-6). We artifically assign
c   "correction = 0" for V = 10^-7 to enlarge interpolation V range.
c       To make sure we also set to zero corrections for V = 1 :
c
      DO I=1,8
        COR_MU(1,I)   = 0.D+0
        COR_TAU(1,I)  = 0.D+0
        COR_MU(71,I)  = 0.D+0
        COR_TAU(71,I) = 0.D+0
      ENDDO
c
c  We compute corrections for 7 energies (10^3 GeV - 10^9 GeV) and
c        10^(-6) =< V < 1 using Bugaev-Shlepin formula
c
c                                 7
c           v (d_sigma / d_v) = S U M (a_k * (alog10(v))**k)
c                                k=0
c
c with coefficients for mu and tau as given in DATA for A_MU and A_TAU:
c
      DO I=2,8
        M = I - 1
          DO J=11,70
            V = 1.D-1 * DBLE(J - 71)
            V1 = 1.D+1**V
            CORR_MU  = 0.D+0
            CORR_TAU = 0.D+0
              DO J1=1,8
              CORR_MU=CORR_MU+(A_MU(J1,M)*(DLOG10(V1))**(DBLE(J1-1)))
              CORR_TAU=CORR_TAU+(A_TAU(J1,M)*(DLOG10(V1))**(DBLE(J1-1)))
              ENDDO
            COR_MU(J,I)  = CORR_MU
            COR_TAU(J,I) = CORR_TAU
          ENDDO
      ENDDO
c
c For v range 10^(-7) -- 10^(-6) we are making a linear interpolation
c    (below V = 10^(-7) all the corrections will be equal to zero):
c
      DO I=2,8
        SL_MU  = COR_MU(11,I) / 1.D+1
        SL_TAU = COR_TAU(11,I) / 1.D+1
          DO K=2,10
            COR_MU(K,I)  = SL_MU * DBLE(K-1)
            COR_TAU(K,I) = SL_TAU * DBLE(K-1)
          ENDDO
      ENDDO
c
c NOW ALL THE CORRECTIONS EXPRESSED IN [ub] for v (d_sigma / d_v)
c     FOR A=22  ARE IN ARRAYS COR_MU(71,8) AND COR_TAU(71,8)
c
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c FILLING ARRAY F(71,8) EITHER BY MU OR TAU CORRECTIONS TO COOK SPLAINS
c      TRANSFORMING TO LOG10 TO GET BETTER INTERPOLATION QUALITY
c         AND DIVIDING BY 22 TO GET CORRECTIONS FOR 1 NUCLEON:
c
      DO I=1,71
        DO J=1,8
          IF(ilep.EQ.1) THEN
            F(I,J) = SNGL(COR_MU(I,J)) / 22.
          ELSE
            F(I,J) = SNGL(COR_TAU(I,J)) / 22.
          ENDIF
        ENDDO
      ENDDO
c
c                        COOKING SPLAINS:
c
      DO 1 J=1,NY
      J2=J+2
      DO 1 I=1,NX
      I2=I+2
1     D(I2,J2)=3.90625E-3*F(I,J)
      J1=NY+1
      J3=J2+1
      J4=J3+1
      DO 2 I=3,I2
      A=D(I,3)
      B=D(I,4)
      D(I,2)=3.*(A-B)+D(I,5)
      D(I,1)=3.*(D(I,2)-A)+B
      A=D(I,J1)
      B=D(I,J2)
      D(I,J3)=3.*(B-A)+D(I,NY)
2     D(I,J4)=3.*(D(I,J3)-B)+A
      I1=NX+1
      I3=I2+1
      I4=I3+1
      DO 3 J=1,J4
      A=D(3,J)
      B=D(4,J)
      D(2,J)=3.*(A-B)+D(5,J)
      D(1,J)=3.*(D(2,J)-A)+B
      A=D(I1,J)
      B=D(I2,J)
      D(I3,J)=3.*(B-A)+D(NX,J)
3     D(I4,J)=3.*(D(I3,J)-B)+A
      DO 4 J=1,J2
      J3=J+1
      J4=J+2
      M=(J-1)*I2
      DO 4 I=1,I2
      I3=I+1
      I4=I+2
4     C(M+I)=D(I,J)+D(I,J4)+D(I4,J)+D(I4,J4)+D(I3,J3)*
     *100.-(D(I3,J)+D(I,J3)+D(I4,J3)+D(I3,J4))*10.
c
      RETURN
      END
************************************************************************
* N.1b
*
      FUNCTION QCD_C(X1,Y1)
*
* Returns QCD correction for PN according to Bugaev & Shlepin by
*    interpolation using splains prepared by QCD_CORR routine.
*
* INPUT: X1 -> relative energy transfer 10^(-10) < V < 1.
*        Y1 -> lepton energy [GeV]       1. < E < 1.E+9
*
*
* OUTPUT QCD_C  -> QCD-correction for PN crosssection [ub] for
*                  v * (d_sigma / d_v) per 1 nucleon
*
      DIMENSION C(730)
      COMMON /qcd_new/ C
      DATA NX /71/
      DATA NY /8/
      DATA X0 /-7./
      DATA SX /.1/
      DATA Y0 /2./
      DATA SY /1./
      REAL*4 X1,Y1
c
      IF(Y1.LT.1.E+2) THEN
        QCD_C = 0.E+0
        RETURN
      ENDIF
      IF(X1.LT.1.E-7) THEN
        QCD_C = 0.E+0
        RETURN
      ENDIF
c
      X = ALOG10(X1)
      Y = ALOG10(Y1)
c
      A3=(X-X0)/SX
      B3=(Y-Y0)/SY
      M1=INT(A3+.5)
      M2=INT(B3+.5)
      M3=NX+2
      IF(M1.LT.0.OR.M1.GE.NX.OR.M2.LT.0.OR.M2.GE.NY) PRINT 1,X,M1,Y,M2
      A3=A3-M1
      B3=B3-M2
      M1=M2*M3+M1+1
      M2=M1+M3
      M3=M2+M3
      A2=A3**2+.25
      B2=B3**2+.25
      A1=A2-A3
      B1=B2-B3
      A3=A2+A3
      B3=B2+B3
      A2=2.-(A2+A2)
      B2=2.-(B2+B2)
      QCD_C=(A1*C(M1)+A2*C(M1+1)+A3*C(M1+2))*B1
     2      +(A1*C(M2)+A2*C(M2+1)+A3*C(M2+2))*B2
     3      +(A1*C(M3)+A2*C(M3+1)+A3*C(M3+2))*B3
c
      RETURN
1     FORMAT('*MISTAKE IN QCD* X=',D23.16,'MX=',I4,'Y=',D23.16,'MY=',I4)
      END
************************************************************************
* N.2
*        THIS FUNCTION CALCULATES DIFFERENTIAL CROSS-SECTION FOR MUON
*     PHOTONUCLEAR INTERACTION IN GIVEN MEDIA USING REAL*8 FUNCTION PHNU
*
*                                  INPUT:
*                                  =====
*
*  real*4 ene    : muon energy (GeV)
*  real*4 v      : relative energy transfer
*
*                                  OUTPUT:
*                                  ======
*
*  real*4 phnu_tot   : d_sigma/d_v (sq. cm), for given media, muon energy and
*                      relative energy transfer. Values of diff. cross-section
*                      are averaged over all nuclei which given media consists
*                      of:
*
*                      d_s/d_v = SUM (w_i * d_s/d_v_i), where w_i = N_i/N_tot
*                      N_i - number of type i atoms in molecule
*                      N_tot - total number of atoms in molecule
*
*                      So, it is calculated for an "effective nucleus" with
*                      atomic weight A_eff = SUM(N_i*A_i) / N_tot
*  .........................................................................
       function phnu_tot(ene,v)
       external phnu
       real*8 z1(10),w(10),aw(10),a_ef,en,rnu,h1,phnu,ro
       real*4 ene,v
       integer nsub
       common /media/ z1,w,aw,a_ef,ro,nsub ! this common determines media com-
c                                     ! position: AW (atomic weights), A_EF
c                                   ! (effective atomic weight), Z1 (charges),
c                                 ! W(relative weights), NSUB (number of media
c                                ! components), ro (cm/qubic cm) - media densi-
c                                ! ty.  All these  are prepared by subroutine
c                               ! MED_CONS and passed here via common /media/.
c
       if (v.gt..999998) v = .999998
       en = dble(ene)
       rnu = dble(v)
           h1 = w(1) * phnu(z1(1),en,rnu,aw(1))
         if (nsub.ge.2) then
           do l=2,nsub
             h1 = h1 + (w(l) * phnu(z1(l),en,rnu,aw(l)))
           enddo
         endif
       phnu_tot = sngl(h1)
       return
       end
****************************************************************************
* N.3
       subroutine phnu1
*                         The subroutine calculates:
*
*                                    [1]
*
*     the differential cross-sections d_Sigma/d_v for muon photonuclear
*                                interaction
*        using FUNCTION PHNU_TOT. The result is put in three arrays
*      fcd1(81,54), fcd2(81,101) and fcd3(81,51) which are passed to
* subroutines SPL2 via common block /cdph_in/. The reason to use just 3 arrays
*     is that the region of energy transfers is divided into 3 regions:
*      10^(-11) - 10^(-0.6), 10^(-0.6) - 10^(-0.1) and 10^(-0.1) - 1
*     for which different grid steps are accepted (0.2, 0.01 and 0.001,
*           correspondingly) to obtain accuracy better than 0.001.
*    Dif. cross-sections are computed for 81 values of muon energy starting
*  with E_mu = 10 GeV and finishing with E_mu = 1000 Pev with logarithmically
*                          equidistant grid.
*  SPL2 cooks splain coefficients out of these 3 arrays which are used in
*                          further computing.
*
*                                    [2]
*
*  Energy losses and mean free path for muon photonuclear interaction with
*   energy transfers which exceed EMIN, VMIN and 0 and en. transfers below
*     EMIN - arrays elo_ph1(17), crt_ph1(17); elo_ph2(65), crt_ph2(65);
*  elo_ph3(17); elo_ph3(17), correspondingly, which are computed for 17 or
*  65 values of muon energy starting  with E_mu = 10 GeV and finishing with
* E_mu = 1 Eev with logarithmically equidistant grid. These arrays are passed
* to subroutine SPL1 via common blocks /elph_in1/, /elph_in2/, /elph_in4/ and
*  /ctph_in1/ where they are used to prepare splain coefficients for further
*                                 computing.
*
*                                    [3]
*
*      A values for variables AT and BT which are necessary to compute a
*  comparison function AT / (V**(BT)) (V is relative energy transfer) which is
*  used in subroutine GETVPH to simulate energy transfers due to photonuclear
*                             interaction.
*    Also several constants composed of AT and BT (us2, us2_1,us3, us4) are
*     computed to be passed along with AT and BT to subroutine getvph via
*                             common /ph_ref/.
*     If comparison function is found during simulation to be less than diff.
* cross-section calculated by splains, at is increased without a stop. If total
*          increase exceed 50%, a message appears on the screen.
*  .....................................................................
       external phnu_tot,dsimps
       real*8 dsimps
       real*8 aux1(0:2000),aux2(0:2000),h1,h2
       real*8 alfa,rm_e,rm_mu,r_e,avog,z1(10),w(10),aw(10),a_ef,ro
       common /const/ alfa,rm_e,rm_mu,r_e,avog ! from initial subroutine
       common /media/ z1,w,aw,a_ef,ro,nsub     !       MED_CONS
       common /general/ emin,vmin,emph         !
       common /cdph_in/ fcd1(81,54),fcd2(81,101),fcd3(81,51) ! To SPL2
       common /ctph_in1/ crt_ph1(17),crt_ph2(65) ! To SPL1 and ENLOS
       common /elph_in1/ elo_ph1(17),elo_ph2(65) ! To SPL1 and ENLOS
       common /elph_in2/ elo_ph3(17)   ! To SPL1 and ENLOS
       common /elph_in4/ elo_ph4(17)   ! To ENLOS
       common /ph_ref/ at,bt,us2,us2_1,us3,us4,at0  ! To GETVPH
       common /pnsig/ ibb  ! From MED_CONS, indicates Sigma_gamma_p
       common /help_1/ aux1,aux2
c   ....................................................................
c      1.PREPARATION OF ARRAYS WITH DIFF. CROSS-SEECTIONS FOR MUON
c                         PHOTONUCLEAR INTERACTION:
c
c                !       ..........................
      do j=1,81  !--->   j CYCLE BY ENERGIES starts
c                !       ..........................
        en = float(j)
        en = 1.e+1**(9.e-1 + (1.e-1 * en))
c                     !         ..................................
      do k=1,206      !--->     k CYCLE BY ENERGY TRANSFERS starts
c                     !         ..................................
      if (k.eq.206) then
        rnu = 1.e+0
        fcd2(j,101) = phnu_tot(en,rnu)
        if (fcd2(j,101).le.1.e-37) fcd2(j,101) = 1.e-37
        fcd2(j,101) = alog(fcd2(j,101))
        goto 975
      endif
c
      if (k.le.54) then
         k01 = k - 1
         rnu = 1.e+1**(float(k01) * 2.e-1 - 1.1e+1)
      else
         if (k.le.105) then
           k01 = k - 55
           rnu = 1.e+1**(float(k01) * 1.e-2 - 6.e-1)
         else
           k01 = k - 106
           rnu = 1.e+1**(float(k01) * 1.e-3 - 1.e-1)
         endif
      endif
c
      cr_dif=phnu_tot(en,rnu)
      if (cr_dif.le.1.e-37) cr_dif = 1.e-37
      cr_dif=alog(cr_dif)
c
      if (k.le.54) fcd1(j,k) = cr_dif
      if ((k.gt.54).AND.(k.lt.106)) fcd3(j,k-54) = cr_dif
      if (k.ge.106) fcd2(j,k-105) = cr_dif
c
 975  continue
c              !     .....................................
      enddo    !----> k CYCLE BY ENERGY TRANSFERS finishes
c              !     .....................................
      enddo    !----> j CYCLE BY ENERGIES finishes
c              !     ....................................
c   ....................................................................
c      2.PREPARATION OF ARRAYS WITH ENERGY LOSSES AND MEAN FREE PATH
c                     FOR MUON PHOTONUCLEAR INTERACTION:
c
c                       a) Energy transfers > EMIN :
      lim = 2000
      do i=1,17
      en = float(i)
      en = (1.e+1)**(5.e-1 + (5.e-1 * en))
      vmi1 = alog(emin / en)
      vmi2 = alog(emph / en)
      vmi = amax1(vmi1,vmi2) !------------> The lower limit for integration
      vma = 0.e+0            !------------> The upper limit for integration
      vst = (vma - vmi) / float(lim) !----> Step for a rel. en. transfers grid
c
      do j=0,lim
      rnu = vmi + vst*(float(j))
      rnu = exp(rnu)
      aux1(j) = dble(phnu_tot(en,rnu) * rnu)       !-> array to be integrated
c                                                  !   to get mean free path
      aux2(j) = aux1(j) * dble(rnu)                !-> array to be integrated
      enddo                                        !   for getting en. losses
c
      h1 = dble(vmi)
      h2 = dble(vma)
      crt_ph1(i) = sngl(dsimps(aux1,h1,h2,lim))       !->array with 17 values
      crt_ph1(i) = sngl(a_ef / (avog * ro))/crt_ph1(i)!  of mean free path
      crt_ph1(i) = alog(crt_ph1(i))                   !
      elo_ph1(i) = sngl( dsimps(aux2,h1,h2,lim) * avog * ro / a_ef )
      elo_ph1(i) = elo_ph1(i) * en * 1.e+3
      elo_ph1(i) = alog10(elo_ph1(i)) !-> array with 17 values of en. losses
      enddo
c                       b) Energy transfers > VMIN :
      do i=1,65
      en = float(i)
      en = (1.e+1)**(8.75e-1 + (1.25e-1 * en))
      vmi1 = alog(vmin)
      vmi2 = alog(emph / en)
      vmi = amax1(vmi1,vmi2) !------------> The lower limit for integration
      vma = 0.e+0            !------------> The upper limit for integration
      vst = (vma - vmi) / float(lim) !----> Step for a rel. en. transfers grid
c
      do j=0,lim
      rnu = vmi + vst*(float(j))
      rnu = exp(rnu)
      aux1(j) = dble(phnu_tot(en,rnu) * rnu)       !-> array to be integrated
c                                                  !   to get mean free path
      aux2(j) = aux1(j) * dble(rnu)                !-> array to be integrated
      enddo                                        !   for getting en. losses
c
      h1 = dble(vmi)
      h2 = dble(vma)
      crt_ph2(i) = sngl(dsimps(aux1,h1,h2,lim))        !->array with 17 values
      crt_ph2(i) = sngl(a_ef / (avog * ro))/crt_ph2(i)!   of mean free path
      elo_ph2(i) = sngl( dsimps(aux2,h1,h2,lim) * avog * ro / a_ef )
      elo_ph2(i) = elo_ph2(i) * en * 1.e+3
      if(elo_ph2(i).le.0.e+0) elo_ph2(i) = 1.e-8
      elo_ph2(i) = alog10(elo_ph2(i)) !-> array with 17 values of en. losses
      enddo
c                       c) Energy transfers > 0 :
      do i=1,17
      en = float(i)
      en = (1.e+1)**(5.e-1 + (5.e-1 * en))
      vmi = alog(emph / en)  !------------> The lower limit for integration
      vma = 0.e+0            !------------> The upper limit for integration
      vst = (vma - vmi) / float(lim) !----> Step for a rel. en. transfers grid
c
      do j=0,lim
      rnu = vmi + vst*(float(j))
      rnu = exp(rnu)
      aux2(j) = dble(phnu_tot(en,rnu) * rnu * rnu) !-> array to be integrated
c                                                  !   to get en. losses
      enddo
c
      h1 = dble(vmi)
      h2 = dble(vma)
      elo_ph3(i) = sngl( dsimps(aux2,h1,h2,lim) * avog * ro / a_ef )
      elo_ph3(i) = elo_ph3(i) * en * 1.e+3
      if(elo_ph3(i).le.0.e+0) elo_ph3(i) = 1.e-8
      elo_ph3(i) = alog10(elo_ph3(i)) !-> array with 17 values of en. losses
      enddo
c                       d) Energy transfers < EMIN :
      do i=1,17
      en = float(i)
      en = (1.e+1)**(5.e-1 + (5.e-1 * en))
      vmi = alog(emph / en)  !------------> The lower limit for integration
      vma = alog(emin / en)  !-----------> The upper limit for integration
      vst = (vma - vmi) / float(lim) !---> Step for a rel. en. transfers grid
      if (vma.le.vmi) then
      elo_ph4(i) = 0.
      goto 1234
      endif
c
      do j=0,lim
      rnu = vmi + vst*(float(j))
      rnu = exp(rnu)
      aux2(j) = dble(phnu_tot(en,rnu) * rnu * rnu) !-> array to be integrated
c                                                  !   to get en. losses
      enddo
c
      h1 = dble(vmi)
      h2 = dble(vma)
      elo_ph4(i) = sngl( dsimps(aux2,h1,h2,lim) * avog * ro / a_ef )
      elo_ph4(i) = elo_ph4(i) * en * 1.e+3 !-> array with 17 values
 1234 continue                             !   of en. losses
      enddo
c   ....................................................................
c          3. COMPUTING OF CONSTANTS FOR COMPARISON FUNCTION:
c
       if(ibb.eq.1) then
         en1 = 1.e+9
         en2 = 10.
         v1 = 1.78e-2
         v2 = 1.e-10
         bt = alog10(phnu_tot(en2,v2)) - alog10(phnu_tot(en1,v1))
         bt = bt / (alog10(v1/v2))
       else
         en1 = 1000.
         en2 = 100.
         v1 = 2.e-4
         v2 = 2.e-3
         bt = alog10(phnu_tot(en1,v1)) - alog10(phnu_tot(en2,v2))
       endif
      if(rm_mu.le.1.e+3) then
      at = 1.05 * (v2**bt) * phnu_tot(en2,v2)
      else
      at = 1.25 * (v2**bt) * phnu_tot(en2,v2)
      endif
      at0 = at
      us2 = at / (1.-bt)
      us2_1 = 1. / us2
      us3 = .434294481 / (1. - bt)
      us4 = 2.302585093 * (-bt)
      return
      end
****************************************************************************
* N.4
            FUNCTION getlphnu(X)
*
*  THE ROUTINE USES A PART OF splain.f CODE (~/flib/splain.f) DEVELOPED AT
*                         IRKUTSK STATE UNIVERSITY
*
*    Function GETLPHNU calculates the muon's free path for photonuclear
*    interaction with energy transfers > EMIN using splain coefficients
*                       prepared by spl1 subroutine.
*
*          X is a value for muon energy expressed in GeV; XMIN,
*   XMAX and STEP are assigned with some values in subroutine SPL1 (they
*              are passed here via /sok1/ common block).
*   Array with splain coefficients C(19) is passed here from SPL1 via
*                              common /sok1_n/
*  ......................................................................
*  ***   ATTENTION: X must be within a range of 10 GeV -- 1000 PeV   ***
*  ......................................................................
      COMMON /sok1/ XMIN,STEP,XMAX
      common /sok1_n/ C(19)
      real*4 x
      X1 = alog10(X)
      if ((X1.lt..99999e+0).or.(X1.gt.9.0001e+0)) then
      print*,'ERROR IN FUNCTION GETLPHNU: MUON ENERGY IS OUT OF RANGE'
      endif
      Y = (X1-XMIN)/STEP
      I = INT(Y+0.5)
      IF(I.LT.0.OR.X1.GT.XMAX) PRINT 1,X1,XMIN,XMAX
      Y = Y-I
      Z = Y*Y + 0.25
      getlphnu = (Z-Y)*C(I+1) + (2.-(Z+Z))*C(I+2) + (Z+Y)*C(I+3)
      getlphnu = exp(getlphnu)
      RETURN
1     FORMAT('*MISTAKE*X1=',D23.16,'XMIN=',D23.16,'XMAX=',D23.16)
      END
****************************************************************************
* N.5
            FUNCTION glphnuv(X)
*
*  THE ROUTINE USES A PART OF splain.f CODE (~/flib/splain.f) DEVELOPED AT
*                         IRKUTSK STATE UNIVERSITY
*
*    Function GLPHNUV calculates the muon's free path for photonuclear
*    interaction with energy transfers > VMIN using splain coefficients
*                       prepared by spl1 subroutine.
*
*          X is a value for muon energy expressed in GeV; XMIN,
*   XMAX and STEP are assigned with some values in subroutine SPL1 (they
*              are passed here via /sok1n/ common block).
*   Array with splain coefficients C(19) is passed here from SPL1 via
*                              common /sok1_n2/
*  ......................................................................
*  ***   ATTENTION: X must be within a range of 10 GeV -- 1000 PeV   ***
*  ......................................................................
      COMMON /sok1n/ XMIN,STEP,XMAX
      common /sok1_n2/ C(67)
      real*4 x
      X1 = alog10(X)
      if ((X1.lt..99999e+0).or.(X1.gt.9.0001e+0)) then
      print*,'ERROR IN FUNCTION GLPHNUV: MUON ENERGY IS OUT OF RANGE'
      endif
      Y = (X1-XMIN)/STEP
      I = INT(Y+0.5)
      IF(I.LT.0.OR.X1.GT.XMAX) PRINT 1,X1,XMIN,XMAX
      Y = Y-I
      Z = Y*Y + 0.25
      glphnuv = (Z-Y)*C(I+1) + (2.-(Z+Z))*C(I+2) + (Z+Y)*C(I+3)
      RETURN
1     FORMAT('*MISTAKE*X1=',D23.16,'XMIN=',D23.16,'XMAX=',D23.16)
      END
****************************************************************************
* N.6
         function getctph(u)
*
*     The subroutine calculates the value for total cross-section for muon
*      photonuclear interaction with energy transfers > EMIN using getphnu
*     subroutine. It also uses some media parameters prepared by subroutine
*                      MED_CONS (commons /const/ and /media/)
*   The resulting cross-section is averaged over all atoms of given media:
*
*                      sigma(E_mu) = SUM (w_i * sigma_i(E_mu)),
*
*       where w_i = N_i/N_tot, N_i - number of type i atoms in molecule,
* N_tot - total number of atoms in molecule, sigma_i(E_mu) is a cross-section
*                               for atom number i.
*     So, it is calculated for an "effective nucleus" with atomic weight
*                         A_eff = SUM(N_i*A_i) / N_tot
*
*                 Input: u = muon energy (GeV)
*                 Output: getctph = total cross-section (sq. cm)
* ..........................................................................
*        U MUST BE WITHIN THE RANGE OF 10 -- 1000,000,000 GeV
* ..........................................................................
      external getlphnu
      real*8 z1(10),w(10),aw(10),a_ef,alfa,rm_e,rm_mu,r_e,avog,ro
      real*4 u
      common /const/ alfa,rm_e,rm_mu,r_e,avog
      common /media/ z1,w,aw,a_ef,ro,nsub
      if ((u.gt.1.0001e+9).or.(u.lt.9.9999e+0)) then
      print*,'ERROR IN FUNCTION GETCTPH: MUON ENERGY IS OUT OF RANGE'
      endif
      aef = sngl(a_ef / (avog * ro))
      getctph = aef / getlphnu(u)
      return
      end
****************************************************************************
* N.7
         function gctphv(u)
*
*     The subroutine calculates the value for total cross-section for muon
*      photonuclear interaction with energy transfers > VMIN using getphnu
*     subroutine. It also uses some media parameters prepared by subroutine
*                      MED_CONS (commons /const/ and /media/)
*   The resulting cross-section is averaged over all atoms of given media:
*
*                      sigma(E_mu) = SUM (w_i * sigma_i(E_mu)),
*
*       where w_i = N_i/N_tot, N_i - number of type i atoms in molecule,
* N_tot - total number of atoms in molecule, sigma_i(E_mu) is a cross-section
*                               for atom number i.
*     So, it is calculated for an "effective nucleus" with atomic weight
*                         A_eff = SUM(N_i*A_i) / N_tot
*
*                 Input: u = muon energy (GeV)
*                 Output: getctph = total cross-section (sq. cm)
* ..........................................................................
*        U MUST BE WITHIN THE RANGE OF 10 -- 1000,000,000 GeV
* ..........................................................................
      external glphnuv
      real*8 z1(10),w(10),aw(10),a_ef,alfa,rm_e,rm_mu,r_e,avog,ro
      real*4 u
      common /const/ alfa,rm_e,rm_mu,r_e,avog
      common /media/ z1,w,aw,a_ef,ro,nsub
      if ((u.gt.1.0001e+9).or.(u.lt.9.9999e+0)) then
      print*,'ERROR IN FUNCTION GCTPHV: MUON ENERGY IS OUT OF RANGE'
      endif
      aef = sngl(a_ef / (avog * ro))
      gctphv = aef / glphnuv(u)
      return
      end
************************************************************************
* N.8
              FUNCTION getdedph(X)
*
*  THE ROUTINE USES A PART OF splain.f CODE (~/flib/splain.f) DEVELOPED AT
*                         IRKUTSK STATE UNIVERSITY
*
*       The subroutine calculates the value for muon energy losses for
*  photonuclear interaction with energy transfers above EMIN using splain
*                coefficients prepared by spl1 subroutine.
*
*          X is a value for muon energy expressed in GeV; XMIN,
*  XMAX and STEP are assigned with some values in subroutine SPL1 (they
*               are passed here via /sok5/ common block).
*   Array with splain coefficients C(19) is passed here from SPL1 via
*                              common /sok5_n/
*  ......................................................................
*  ***   ATTENTION: X must be within a range of 10 GeV --- 1000 PeV   ***
*  ......................................................................
      COMMON /sok5/ XMIN,STEP,XMAX
      common /sok5_n/ C(19)
      real*4 x
      X1 = alog10(X)
       if ((X1.lt..99999e+0).or.(X1.gt.9.0001e+0)) then
       print*,'ERROR IN FUNCTION GETDEDPH: MUON ENERGY IS OUT OF RANGE'
       endif
      Y = (X1-XMIN)/STEP
      I = INT(Y+0.5)
      IF(I.LT.0.OR.X1.GT.XMAX) PRINT 1,X1,XMIN,XMAX
      Y = Y-I
      Z = Y*Y + 0.25
      getdedph = (Z-Y)*C(I+1) + (2.-(Z+Z))*C(I+2) + (Z+Y)*C(I+3)
      getdedph = (1.e+1)**(getdedph)
      RETURN
1     FORMAT('*MISTAKE*X1=',D23.16,'XMIN=',D23.16,'XMAX=',D23.16)
      END
************************************************************************
* N.9
              FUNCTION gdedphv(X)
*
*  THE ROUTINE USES A PART OF splain.f CODE (~/flib/splain.f) DEVELOPED AT
*                         IRKUTSK STATE UNIVERSITY
*
*       The subroutine calculates the value for muon energy losses for
*  photonuclear interaction with energy transfers above VMIN using splain
*                coefficients prepared by spl1 subroutine.
*
*          X is a value for muon energy expressed in GeV; XMIN,
*  XMAX and STEP are assigned with some values in subroutine SPL1 (they
*               are passed here via /sok5n/ common block).
*   Array with splain coefficients C(19) is passed here from SPL1 via
*                              common /sok5_n2/
*  ......................................................................
*  ***   ATTENTION: X must be within a range of 10 GeV --- 1000 PeV   ***
*  ......................................................................
      COMMON /sok5n/ XMIN,STEP,XMAX
      common /sok5_n2/ C(67)
      real*4 x
      X1 = alog10(X)
       if ((X1.lt..99999e+0).or.(X1.gt.9.0001e+0)) then
       print*,'ERROR IN FUNCTION GDEDPHV: MUON ENERGY IS OUT OF RANGE'
       endif
      Y = (X1-XMIN)/STEP
      I = INT(Y+0.5)
      IF(I.LT.0.OR.X1.GT.XMAX) PRINT 1,X1,XMIN,XMAX
      Y = Y-I
      Z = Y*Y + 0.25
      gdedphv = (Z-Y)*C(I+1) + (2.-(Z+Z))*C(I+2) + (Z+Y)*C(I+3)
      gdedphv = (1.e+1)**(gdedphv)
      RETURN
1     FORMAT('*MISTAKE*X1=',D23.16,'XMIN=',D23.16,'XMAX=',D23.16)
      END
************************************************************************
* N.10
              FUNCTION gdedpht(X)
*
*  THE ROUTINE USES A PART OF splain.f CODE (~/flib/splain.f) DEVELOPED AT
*                         IRKUTSK STATE UNIVERSITY
*
* The subroutine calculates the value for total muon energy losses due to
*  photonuclear interaction using splain coefficients prepared by spl1
*                                subroutine.
*
*          X is a value for muon energy expressed in GeV; XMIN,
*  XMAX and STEP are assigned with some values in subroutine SPL1 (they
*               are passed here via /sok5/ common block).
*   Array with splain coefficients C(19) is passed here from SPL1 via
*                              common /sok5_n3/
*  ......................................................................
*  ***   ATTENTION: X must be within a range of 10 GeV --- 1000 PeV   ***
*  ......................................................................
      COMMON /sok5/ XMIN,STEP,XMAX
      common /sok5_n3/ C(19)
      real*4 x
      X1 = alog10(X)
       if ((X1.lt..99999e+0).or.(X1.gt.9.0001e+0)) then
       print*,'ERROR IN FUNCTION GDEDPHT: MUON ENERGY IS OUT OF RANGE'
       endif
      Y = (X1-XMIN)/STEP
      I = INT(Y+0.5)
      IF(I.LT.0.OR.X1.GT.XMAX) PRINT 1,X1,XMIN,XMAX
      Y = Y-I
      Z = Y*Y + 0.25
      gdedpht = (Z-Y)*C(I+1) + (2.-(Z+Z))*C(I+2) + (Z+Y)*C(I+3)
      gdedpht = (1.e+1)**(gdedpht)
      RETURN
1     FORMAT('*MISTAKE*X1=',D23.16,'XMIN=',D23.16,'XMAX=',D23.16)
      END
****************************************************************************
* N.11
       FUNCTION getcdn(X,Y,lo)
*
*  THE ROUTINE USES A PART OF splain.f CODE (~/flib/splain.f) DEVELOPED AT
*                         IRKUTSK STATE UNIVERSITY
*
* The subroutine calculates the value for differential cross-section for muon
*    photonuclear interaction d_Sigma/d_v using functions getcdn1, getcdn2,
*getcdn_3e or phnu_tot depending on value of energy transfer Y. For definition
* of cross-section for muon e+e- pair production in given media see comments to
*                            subroutine PHNU_TOT.
* X and Y are values for muon energy expressed in GeV and for relative energy
*   transfer, respectively. If LO=0, then Y is expressed in natural units,
*           otherwise the input for Y is presented as LOG10(Y).
*  .....................................................................
*        ATTENTION: X must be within a range of 10 GeV -- 1000 PeV
*                   Y must be within a range of 10**(-11) -- 10**(0)
*  ......................................................................
*    ATTENTION: GETCDN computes diff. cross-sections for all relative
*  energy transfers > 10**(-11). In reality photonuclear cross-section
*   is equal to 0 for transferred energies < 0.5 - 1 GeV. It is taken
*    into account in the frame of MUM code but one should put ones
*      attention on this fact using GETCDN for other purposes.
*  ......................................................................
       external getcdn1,getcdn2,getcdn_3e,phnu_tot
       real*4 X,Y
       integer lo
       if (lo.eq.0) then
          if (Y.le..251188643) then
                getcdn = getcdn1(X,Y,lo)
               getcdn = exp(getcdn)
          else
               if (Y.le..794328234) then
                  getcdn = getcdn2(X,Y,lo)
                  getcdn = exp(getcdn)
               else
                 if (Y.le..965) then
                    getcdn = getcdn_3e(X,Y,lo)
                    getcdn = exp(getcdn)
                 else
                    getcdn = phnu_tot(X,Y)
                 endif
               endif
          endif
       else
          if (Y.le.-6.e-1) then
                getcdn = getcdn1(X,Y,lo)
                getcdn = exp(getcdn)
          else
                if (Y.le.-1.e-1) then
                   getcdn = getcdn2(X,Y,lo)
                   getcdn = exp(getcdn)
                else
                   if (Y.le.-1.54727e-2) then
                     getcdn = getcdn_3e(X,Y,lo)
                     getcdn = exp(getcdn)
                   else
                     Y1 = (1.e+1)**Y
                     getcdn = phnu_tot(X,Y1)
                   endif
                endif
          endif
       endif
      if (getcdn.lt.0.e+0) getcdn = 0.e+0
      return
      end
****************************************************************************
* N.12
       FUNCTION getcdn1(X,Y,loga)
*
*  THE ROUTINE USES A PART OF splain.f CODE (~/flib/splain.f) DEVELOPED AT
*                         IRKUTSK STATE UNIVERSITY
*
*   The subroutine calculates the value for differential cross-section for muon
*   photonuclear interaction d_Sigma/d_v using splain coefficients prepared by
*    SPL2 routine. For definition of cross-section for e+e- pair production in
*               given media see comments to subroutine PHNU_TOT.
*  .....................................................................
*   X and Y in body program is a value for muon energy expressed in GeV and
*    for relative energy transfer, respectively. NX, NY, X0, SX, Y0 and SY
*   are assigned with some values in subroutine SPL2 (they are passed here
*   via /sok_2_1/ common block. Array with splain coefficients C1(4648) is
*            cooked by SPL2 and passed here via common /mum8/
*            If LOGA=0, then Y is expressed in natural units,
*           otherwise the input for Y is presented as LOG10(Y).
*                  Output is presented as LN (d_sigma/d_v)
*  ......................................................................
*        ATTENTION: X must be within a range of 10 GeV -- 1000 PeV
*                   Y must be within a range of 10**(-11) -- 10**(-0.6)
*  ......................................................................
       common /mum8/ C1(4648)
       common /sok_2_1/ NX,NY,X0,SX,Y0,SY
       real*4 X,Y
       integer loga
      X_1=alog10(X)
      if ((X_1.lt..99999e+0).or.(X_1.gt.9.0001e+0)) then
      print*,'ERROR IN FUNCTION GETCDN1: MUON ENERGY IS OUT OF RANGE'
      endif
      if (loga.eq.0) then
      Y_1=alog10(Y)
      else
      Y_1=Y
      endif
      if ((Y_1.lt.-11.001).or.(Y_1.gt.-5.9999e-1)) then
      print*,'ERROR IN FUNCTION GETCDN1: EN. TRANSFER IS OUT OF RANGE'
      endif
      A3=(X_1-X0)/SX
      B3=(Y_1-Y0)/SY
      M1=INT(A3+.5)
      M2=INT(B3+.5)
      M3=NX+2
      IF(M1.LT.0.OR.M1.GE.NX.OR.M2.LT.0.OR.M2.GE.NY) THEN
      PRINT 1,X_1,M1,Y_1,M2
      ENDIF
      A3=A3-M1
      B3=B3-M2
      M1=M2*M3+M1+1
      M2=M1+M3
      M3=M2+M3
      A2=A3*A3+.25
      B2=B3*B3+.25
      A1=A2-A3
      B1=B2-B3
      A3=A2+A3
      B3=B2+B3
      A2=2.-(A2+A2)
      B2=2.-(B2+B2)
      getcdn1=(A1*C1(M1)+A2*C1(M1+1)+A3*C1(M1+2))*B1
     2      +(A1*C1(M2)+A2*C1(M2+1)+A3*C1(M2+2))*B2
     3      +(A1*C1(M3)+A2*C1(M3+1)+A3*C1(M3+2))*B3
      RETURN
1     FORMAT('GETCDN1: *MISTAKE*X= ',D23.16,' MX= ',I4,' Y= ',D23.16,' M
     *Y= ',I4)
      END
****************************************************************************
* N.13
       FUNCTION getcdn2(X,Y,loga)
*
*  THE ROUTINE USES A PART OF splain.f CODE (~/flib/splain.f) DEVELOPED AT
*                         IRKUTSK STATE UNIVERSITY
*
*   The subroutine calculates the value for differential cross-section for muon
*   photonuclear interaction d_Sigma/d_v using splain coefficients prepared by
*    SPL2 routine. For definition of cross-section for e+e- pair production
*              in given media see comments to subroutine PHNU_TOT.
*  .....................................................................
*   X and Y in body program is a value for muon energy expressed in GeV and
*    for relative energy transfer, respectively. NX, NY, X0, SX, Y0 and SY
*   are assigned with some values in subroutine SPL2 (they are passed here
*   via /sok_2_2/ common block. Array with splain coefficients C1(4399) is
*            cooked by SPL2 and passed here via common /mum9/
*            If LOGA=0, then Y is expressed in natural units,
*           otherwise the input for Y is presented as LOG10(Y).
*                  Output is presented as LN (d_sigma/d_v)
*  ......................................................................
*        ATTENTION: X must be within a range of 10 GeV -- 1000 PeV
*                   Y must be within a range of 10**(-0.6) -- 10**(-0.1)
*  ......................................................................
       common /mum9/ C1(4399)
       common /sok_2_2/ NX,NY,X0,SX,Y0,SY
       real*4 X,Y
       integer loga
      X_1=alog10(X)
      if ((X_1.lt..99999e+0).or.(X_1.gt.9.0001e+0)) then
      print*,'ERROR IN FUNCTION GETCDN2: MUON ENERGY IS OUT OF RANGE'
      endif
      if (loga.eq.0) then
      Y_1=alog10(Y)
      else
      Y_1=Y
      endif
      if ((Y_1.lt.-.60001).or.(Y_1.gt.-.99999e-1)) then
      print*,'ERROR IN FUNCTION GETCDN2: EN. TRANSFer IS OUT OF RANGE'
      endif
      A3=(X_1-X0)/SX
      B3=(Y_1-Y0)/SY
      M1=INT(A3+.5)
      M2=INT(B3+.5)
      M3=NX+2
      IF(M1.LT.0.OR.M1.GE.NX.OR.M2.LT.0.OR.M2.GE.NY) THEN
      PRINT 1,X_1,M1,Y_1,M2
      ENDIF
      A3=A3-M1
      B3=B3-M2
      M1=M2*M3+M1+1
      M2=M1+M3
      M3=M2+M3
      A2=A3*A3+.25
      B2=B3*B3+.25
      A1=A2-A3
      B1=B2-B3
      A3=A2+A3
      B3=B2+B3
      A2=2.-(A2+A2)
      B2=2.-(B2+B2)
      getcdn2=(A1*C1(M1)+A2*C1(M1+1)+A3*C1(M1+2))*B1
     2      +(A1*C1(M2)+A2*C1(M2+1)+A3*C1(M2+2))*B2
     3      +(A1*C1(M3)+A2*C1(M3+1)+A3*C1(M3+2))*B3
      RETURN
1     FORMAT('GCDN2:*MISTAKE*X=',D23.16,'MX=',I4,'Y=',D23.16,'MY=',I4)
      END
****************************************************************************
* N.14
       FUNCTION getcdn_3e(X,Y,loga)
*
*  THE ROUTINE USES A PART OF splain.f CODE (~/flib/splain.f) DEVELOPED AT
*                         IRKUTSK STATE UNIVERSITY
*
*   The subroutine calculates the value for differential cross-section for muon
*   photonuclear interaction d_Sigma/d_v using splain coefficients prepared by
*    SPL2 routine. For definition of cross-section for e+e- pair production
*              in given media see comments to subroutine PHNU_TOT.
*  .....................................................................
*   X and Y in body program is a value for muon energy expressed in GeV and
*    for relative energy transfer, respectively. NX, NY, X0, SX, Y0 and SY
*   are assigned with some values in subroutine SPL2 (they are passed here
*   via /sok_2_3/ common block. Array with splain coefficients C2(8549) is
*            cooked by SPL2 and passed here via common /mum10/
*            If LOGA=0, then Y is expressed in natural units,
*           otherwise the input for Y is presented as LOG10(Y).
*                  Output is presented as LN (d_sigma/d_v)
*  ......................................................................
*        ATTENTION: X must be within a range of 10 GeV -- 1000 PeV
*                   Y must be within a range of 10**(-0.1) -- 1
*  ......................................................................
       common /mum10/ C2(8549)
       common /sok_2_3/ NX,NY,X0,SX,Y0,SY
       real*4 X,Y
       integer loga
      X_1=alog10(X)
      if ((X_1.lt..99999e+0).or.(X_1.gt.9.0001e+0)) then
      print*,'ERROR IN FUNCTION GETCDN_3E: MUON ENERGY IS OUT OF RANGE'
      endif
      if (loga.eq.0) then
      Y_1=alog10(Y)
      else
      Y_1=Y
      endif
      if ((Y_1.lt.-1.0001e-1).or.(Y_1.gt.1.e-6)) then
      print*,'ERROR IN FUNCTION GETCDN_3E: EN. TRANSFER IS OUT OF RANGE'
      endif
      A3=(X_1-X0)/SX
      B3=(Y_1-Y0)/SY
      M1=INT(A3+.5)
      M2=INT(B3+.5)
      M3=NX+2
      IF(M1.LT.0.OR.M1.GE.NX.OR.M2.LT.0.OR.M2.GE.NY) THEN
      PRINT 1,X_1,M1,Y_1,M2
      ENDIF
      A3=A3-M1
      B3=B3-M2
      M1=M2*M3+M1+1
      M2=M1+M3
      M3=M2+M3
      A2=A3*A3+.25
      B2=B3*B3+.25
      A1=A2-A3
      B1=B2-B3
      A3=A2+A3
      B3=B2+B3
      A2=2.-(A2+A2)
      B2=2.-(B2+B2)
      getcdn_3e=(A1*C2(M1)+A2*C2(M1+1)+A3*C2(M1+2))*B1
     2      +(A1*C2(M2)+A2*C2(M2+1)+A3*C2(M2+2))*B2
     3      +(A1*C2(M3)+A2*C2(M3+1)+A3*C2(M3+2))*B3
      RETURN
1     FORMAT('*MISTAKE*X=',D23.16,'MX=',I4,'Y=',D23.16,'MY=',I4)
      END
****************************************************************************
* N.15
          SUBROUTINE getvph(emw,vbr,itr)
*
*      It simulates the relative energy transfers for muon's photonuclear
* interaction with energy transfers > EMIN (if itr=0) or > VMIN (otherwise)
*                 Input: emw = muon energy expressed in GeV,
*                 Output: vbr = relative energy transfer.
*
*   The simulation is done by the "rejection method" (see W.H.Press et al.,
*  NUMERICAL RECEIPES (THE ART OF SCIENTIFIC COMPUTING), Cambridge University
*            press, Chapter 7, pp. 200-204) with comparison function
*                              f(v) = at / v**bt
*  where at and bt are constants  calculated by PHNU1 routine and passed here
*                             via common /ph_ref/
* ..........................................................................
*            EMW MUST BE WITHIN THE RANGE OF 10 -- 1000,000,000 GeV
* ..........................................................................
      external getcdn
      parameter (lo=1)
      common /general/ emin,vmin,emph
      common /mcef/ mcb1,mcb2,mcp1,mcp2,mcn1,mcn2,mce1,mce2
      common /ph_ref/ at,bt,us2,us2_1,us3,us4,at0
      real*4 emw,vbr
      integer itr
      mcn1 = mcn1 + 1
        if (itr.eq.0) then
          vtr=amax1((emin/emw),(emph/emw))
        else
          vtr=amax1(vmin,(emph/emw))
        endif
      us1 = vtr**(1. - bt)
      algemin = us2 * (1. - us1)
  155 ax = algemin * rndm_mum(5)
      vbr = (alog(us1 + (ax * us2_1))) * us3
      mcn2 = mcn2 + 1
      y1 = getcdn(emw,vbr,lo)
      y2 = at * exp(vbr * us4)
      yc = y2 * rndm_mum(8)
ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
           if (y2.lt.y1) then
           fnew = y1 / y2
           at = at * (fnew)
           fnew1 = at / at0
           us2 = at / (1.-bt)
           us2_1 = 1. / us2
           us3 = .434294481 / (1. - bt)
           us4 = 2.302585093 * (-bt)
       print*,'***** COMPARISON FUNCTION FOR PH.NUC. SIMULATION: *****'
           print*,'Variable  AT has been increased with factor',fnew
           print*,'Now it differs from init. value with factor',fnew1
       print*,'   No reasons to trouble, it is for information only'
             if (fnew1.gt.1.5) then
       print*,'************ ERROR (1)********* f(v) < d_Sigma/d_v ****'
       print*,'**** VARIABLE  AT  HAS BEEN INCREASED TOO MUCH !!! ****'
             endif
       print*,'*******************************************************'
           endif
ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
        if (y1.ge.yc) then
        vbr = 1.e+1**vbr
        else
        goto 155
        endif
      return
      end
****************************************************************************
*********************** DELTA-ELECTRONS SUBROUTINES : **********************
****************************************************************************
* E.1
*
*     This routine was kindly provided by R.P.Kokoulin in November,1999.
*    It has been essentially (but carefully!) changed to adopt it for MUM
*  purposes. All changes were tested, they do not result in some changes in
*                                     output.
*
*  In current version it computes a differential cross-section for knock-on
*    electrons d_sigma/d_v (sq. cm) (including bremsstrahlung e-diagram)
*    for an "averaged" atom with Z = sum( (Z_i)/N_tot ), where N_tot is the
*  total numbers of atoms in molecule of medium, Z_i are an electric charge
*    of atom nb. "i". Z is prepared in advance in subroutine MED_CONS and
*                            passed here via common
*                                     /zav/.
*
*                                    INPUT:
*                                    =====
*
*            real*4 e : Muon energy (GeV)
*            real*4 v : Relative energy transfer for knock-on electron
*
*                  BELOW IS CHANGED CODE FROM R.P.KOKOULIN:
****************************************************************************
C***    Cross section for knock-on electron production by fast muons
C***    (including bremsstrahlung e-diagrams and rad. correction).
C***    Units: cm^2/(g*GeV); Tkin, ep - GeV.
C***    By R.P.Kokoulin, October 1998
C***    Formulae from Kelner,Kokoulin,Petrukhin, Phys.Atom.Nuclei, 1997
C***    (a bit simplified Kelner's version of Eq.30 - with 2 logarithms).
C***
      function getcde(e,v)
        common /zav/ z
      parameter (ame=0.51099907e-3)
c                              !    GeV
ccc parameter (amu=0.105658389)   ! GeV
      parameter (re=2.81794092e-13)
c                              !    cm
c   parameter (alpha=1./137.036)
      parameter (pi=3.141592654)
ccc parameter (bmu=amu**2/(2.*ame))
c   parameter (coeff0=2.*pi*ame*re**2)
c   parameter (coeff1=alpha/(2.*pi))
c        parameter (sok1=2./ame)
ccc        parameter (sok2=5.88138263)
        real*8 alfa,rm_e,rm_mu,r_e,avog
        real*4 e,v
        common /const/ alfa,rm_e,rm_mu,r_e,avog
        common /exer1/ fa
cccccccccccccccccccccccccccccccccccc
      alpha=1./137.036
      coeff0=2.*pi*ame*re**2
      coeff1=alpha/(2.*pi)
      sok1=2./ame
cccccccccccccccccccccccccccccccccccc
***
        amu = 1.e-3 * sngl(rm_mu)
        bmu = amu**2/(2.*ame)
        sok2 = alog(4./(amu*amu))
***
      vpmax=e/(e+bmu)
      ep=v*e
           if (v.ge.vpmax) then
           getcde=0.
           return
       endif
      sigma0=coeff0*z*(1.-v/vpmax+.5*v*v)/(v*ep)
      a1=alog(1.+sok1*ep)
      a3=sok2+alog(e*(e-ep))
      getcde=sigma0*(1.+coeff1*a1*(a3-a1))*fa
      return
      end
****************************************************************************
* E.2
*     This routine was written on the base on a routine from R.P.Kokoulin.
*   It computes energy losses for muon due to knock-on electron production
*                   by bremsstrahlung with e-diagrams.
*
*       Formulae from Kelner,Kokoulin,Petrukhin, Phys.Atom.Nuclei, 1997
*     (a bit simplified Kelner's version of Eq.30 - with 2 logarithms).
*
*                 INPUT:   real*4 e : Muon energy (GeV)
*                 OUTPUT:  real*4 edbrt: Energy losses (MeV/cm)
*..........................................................................
      function edbrt(e)
      external simps
      real*8 alfa,rm_e,rm_mu,r_e,avog,z1(10),w(10),aw(10),a_ef,ro
      real*4 e
c 2 next lines - from initial subroutine MED_CONS:
      common /const/ alfa,rm_e,rm_mu,r_e,avog
      common /media/ z1,w,aw,a_ef,ro,nsub
c
      common /zav/ z
      common /exer1/ fa
      parameter (ame=0.51099907e-3)
c                               !-> in GeV
ccc      parameter (amu=0.105658389)   !    GeV
      parameter (re=2.81794092e-13)
c                               !-> in cm
c      parameter (alpha=1./137.036)
      parameter (pi=3.141592654)
ccc      parameter (bmu=amu**2/(2.*ame))
c      parameter (coeff0=2.*pi*ame*re**2)
c      parameter (coeff1=alpha/(2.*pi))
c      parameter (sok1=2./ame)
ccc      parameter (sok2=5.88138263)
      parameter (lim=2000)
      dimension aux(0:2000)
cccccccccccccccccccccccccc
      alpha=1./137.036
      coeff0=2.*pi*ame*re**2
      coeff1=alpha/(2.*pi)
      sok1=2./ame
cccccccccccccccccccccccccc
***
        amu = 1.e-3 * sngl(rm_mu)
        bmu = amu**2/(2.*ame)
        sok2 = alog(4./(amu*amu))
***
      vpmin = alog(7.5e-8 / e)
      vpmax = e / (e + bmu)
      vpmax1 = alog(vpmax)
      st = (vpmax1 - vpmin) * 5.e-4
      do i=0,lim
        v = exp(vpmin + st * float(i))
        ep = v * e
        if (v.ge.vpmax) then
         aux(i) = 0.
        else
         sigma0 = coeff0 * z * v * (1. - v/vpmax + .5 * v * v) / ep
         a1 = alog(1. + sok1 * ep)
         a3 = sok2 + alog(e * (e - ep))
         aux(i) = sigma0 * coeff1 * a1 * (a3 - a1)
        endif
      enddo
      edbrt = simps(aux,vpmin,vpmax1,lim) * e * 1.e+3
      edbrt = fa * edbrt * sngl(avog * ro / a_ef)
      return
      end
****************************************************************************
* E.3
        function bebl(ene)
*
*  The routine calculates the ionization Losses of muons using Bethe-Bloch
*        formula taken from /E.V.Bugaev et al., hep-ph/9803488/.
*
*           Input  :  real*4 ene  -------> Muon Energy (GeV)
*           Output :  real*4 bebl -------> energy losses (MeV/cm)
*...........................................................................
      real*8 c_0,z_a,ri_z,x_0,x_1,a,rm,con1,con2,hnu,c,e
      real*8 beta,p,w_max,x,theta1,theta2,delta,difx1_x,e_loss
      real*8 alfa,rm_e,rm_mu,r_e,avog,z1(10),w(10),aw(10),a_ef,ro
      real*4 ene
      common /const/ alfa,rm_e,rm_mu,r_e,avog ! from initial subroutine
      common /media/ z1,w,aw,a_ef,ro,nsub     !       MED_CONS
      common /med_ion/ z_a,ri_z,x_0,x_1,a,rm  !
      common /exer1/ fa
      parameter (c_0=1.535d-1)
c
      e = dble(ene) * 1.d+3
      con1 = c_0 * z_a * ro
      con2 = (2.d+0 * rm_e)/(rm_mu * rm_mu * ri_z * ri_z)
      hnu = 2.8816d+1 * dsqrt(ro*z_a)/1.d+6
      c = (2.d+0 * dlog(ri_z/hnu)) + 1.d+0
c
      beta = dsqrt(1.d+0 - ((rm_mu * rm_mu)/(e * e)))
      p = beta * e
      w_max=(2.d+0*rm_e*p*p)/((rm_mu*rm_mu)+(rm_e*rm_e)+(2.d+0*rm_e*e))
      x = dlog10(p/rm_mu)
             if(x.gt.x_0) then
             theta1 = 1.d+0
             else
             theta1 = 0.d+0
             delta = 0.d+0
             goto 1
             endif
                if(x_1.gt.x) then
                theta2 = 1.d+0
                else
                theta2 = 0.d+0
                difx1_x=0.d+0
                goto 2
                endif
       difx1_x = (x_1 - x)**rm
 2     delta = theta1 * ((4.6052d+0 * x) + (a * theta2 * difx1_x) - c)
 1     e_loss=(con1/(beta*beta))*((dlog(con2*p*p*w_max))+((w_max*w_max)/
     +(4.d+0*e*e))-(2.d+0*beta*beta)-delta)
       bebl=sngl(e_loss) * fa
       return
       end
****************************************************************************
* E.4
       subroutine elec1
*
*                      The subroutine calculates:
*
*   Energy losses and averaged free path for knock-on-electrons production
*                (including e-diagram for bremsstrahlung) by
*     muon which passes a media with energy transfers which exceed EMIN -
*   arrays elo_el1(17) and crt_el1(17), correspondingly, or VMIN - arrays
*  elo_el2(17) and crt_el2(17). Total energy losses for knock-on electrons
*    production are calculated, as well by ordinary Bethe-Bloch formula
*   (array elel_bb(17) and by Bethe-Bloch + e-diagram for bremsstrahlung
*       (elel_bbb(17)). These arrays are computed for 17 values of
*  muon energy starting with E_mu = 10 GeV and finishing with E_mu = 1 EeV
*  with logarithmically equidistant grid and passed to subroutine SPL1 via
*  common blocks /elel_in1/ and /ctel_in1/ where they are used to prepare
*              splain coefficients for further computing.
*  Also an array ELEL_TOT(101) is computed for total muon energy losses
* below muon energy 10 GeV. It is calculated as Bethe-Bloch + e-diagrams
*  for bremsstrahlung for 101 muon energy from 0.14 GeV to 14 GeV with
*   logarithmically equidestant grid and passed to SPL1 to cook splain
*                               coefficients.
*  .....................................................................
       external getcde,dsimps
       real*8 dsimps
       real*8 um
       real*8 aux1(0:2000),aux2(0:2000),h1,h2
       real*8 alfa,rm_e,rm_mu,r_e,avog,z1(10),w(10),aw(10),a_ef,ro
       common /const/ alfa,rm_e,rm_mu,r_e,avog ! from initial subroutine
       common /media/ z1,w,aw,a_ef,ro,nsub     !       MED_CONS
       common /general/ emin,vmin,emph         !
       common /ctel_in1/ crt_el1(17),crt_el2(17) ! To SPL1 and ENLOS
       common /elel_in1/ elo_el1(17),elo_el2(17) ! To SPL1 and ENLOS
       common /elel_in2/ elel_bb(17),elel_bbb(17)  ! To SPL1 and ENLOS
       common /elel_in3/ elel_tot(101) ! To SPL1
       common /help_1/ aux1,aux2
       common /exer2/ noca !-> if noca=0 there are no catastrophic losses
c                              for knock-on electrons
c ....................................................................
c     PREPARATION OF ARRAYS WITH ENERGY LOSSES AND AVERAGED FREE PATH
c                        FOR KNOCK-ON-ELECTRONS:
c
c                     a) energy transfers > EMIN
c
      lim = 2000
      do i=1,17
      en = float(i)
      en = (1.e+1)**(5.e-1 + (5.e-1 * en))
      vmi = alog(emin / en) !--------------> The lower limit for integration
      um = (rm_mu * rm_mu * 1.d-3) / (2.d+0 * rm_e)
      vma = sngl(um)
      vma = 1. / ( 1.e+0 + (vma / en) )
      vma = alog(vma)       !--------------> The upper limit for integration
      vst = (vma - vmi) / float(lim) !--> step for a rel. en. transfers grid
c
      do j=0,lim
      rnu = vmi + vst*(float(j))
      rnu = exp(rnu)
      aux1(j) = dble(getcde(en,rnu) * rnu)        !-> array to be integrated
c                                                 !   to get mean free path
      aux2(j) = aux1(j) * rnu                     !-> array to be integrated
      enddo                                       !   for getting en. losses
c
      h1 = dble(vmi)
      h2 = dble(vma)
      crt_el1(i) = sngl(dsimps(aux1,h1,h2,lim))
      if(crt_el1(i).le.0.e+0) then
      crt_el1(i) = 1.e+10
      goto 84765
      endif
      crt_el1(i) = (sngl(a_ef/(avog*ro)))/crt_el1(i) !-> array with 17 values
c                                                    !   of free path
84765 continue
ccc      print*,i,'  crt_el1(i) = ',crt_el1(i)
      elo_el1(i) = sngl( dsimps(aux2,h1,h2,lim) * avog * ro / a_ef )
      elo_el1(i) = elo_el1(i) * en * 1.e+3
ccc      print*,i,'  ',elo_el1(i)
      elo_el1(i) = alog10(elo_el1(i)) !-> array with 17 values of en. losses
      enddo
c                     b) energy transfers > VMIN
      do i=1,17
      en = float(i)
      en = (1.e+1)**(5.e-1 + (5.e-1 * en))
      vmi = alog(vmin)      !--------------> The lower limit for integration
      um = (rm_mu * rm_mu * 1.d-3) / (2.d+0 * rm_e)
      vma = sngl(um)
      vma = 1. / ( 1.e+0 + (vma / en) )
      vma = alog(vma)       !--------------> The upper limit for integration
      vst = (vma - vmi) / float(lim) !--> step for a rel. en. transfers grid
c
      do j=0,lim
      rnu = vmi + vst*(float(j))
      rnu = exp(rnu)
      aux1(j) = dble(getcde(en,rnu) * rnu)        !-> array to be integrated
c                                                 !   to get mean free path
      aux2(j) = aux1(j) * rnu                     !-> array to be integrated
      enddo                                       !   for getting en. losses
c
      h1 = dble(vmi)
      h2 = dble(vma)
      crt_el2(i) = sngl(dsimps(aux1,h1,h2,lim))
      if(crt_el2(i).le.0.e+0) then
      crt_el2(i) = 1.e+10
      goto 84767
      endif
      crt_el2(i) = (sngl(a_ef/(avog*ro)))/crt_el2(i) !-> array with 17 values
84767 continue
ccc      print*,i,'  crt_el2(i) = ',crt_el2(i)
      crt_el2(i) = alog(crt_el2(i))                  !   of free path
      if (noca.eq.0) crt_el2(i)=45. !-> no cat. losses for knock-on electrons
c
      elo_el2(i) = sngl( dsimps(aux2,h1,h2,lim) * avog * ro / a_ef )
      elo_el2(i) = elo_el2(i) * en * 1.e+3
      if(elo_el2(i).le.0.e+0) elo_el2(i) = 1.e-8
      if (noca.eq.0) elo_el2(i)=1.e-30 !->no cat.losses for knock-on electrons
ccc      print*,i,'  ',elo_el2(i)
      elo_el2(i) = alog10(elo_el2(i)) !-> array with 17 values of en. losses
      enddo
ccc      read*,kkk
c                     c) energy transfers > 0
      do i=1,17
      en = float(i)
      en = (1.e+1)**(5.e-1 + (5.e-1 * en))
      elel_bb(i) = bebl(en)                 !--> Ion. en. losses (Bethe-Bloch)
      elel_bbb(i) = edbrt(en) + elel_bb(i)  !--> BB + bremsstrahlung e-diagram
      enddo
c                     d) total energy losses below 10 GeV
c                 (Bethe-Bloch + e-diagrams for bremsstrahlung)
      do i=1,101
      en = float(i)
      en = (1.e+1)**(alog10(0.14) - .02 + (.02 * en))
      elel_tot(i) = edbrt(en) + bebl(en)
      enddo
c
      return
      end
****************************************************************************
* E.5
           FUNCTION getlelec(X)
*
*  THE ROUTINE USES A PART OF splain.f CODE (~/flib/splain.f) DEVELOPED AT
*                         IRKUTSK STATE UNIVERSITY
*
*     The subroutine calculates the value for mean free path for knock-on
*       electron production with energy transfers > EMIN using splain
*                 coefficients prepared by spl1 subroutine.
*
*          X is a value for muon energy expressed in GeV; XMIN,
*   XMAX and STEP are assigned with some values in subroutine SPL1 (they
*              are passed here via /sok1/ common block).
*   Array with splain coefficients C(19) is passed here from SPL1 via
*                             common /sok1_e/
*  ......................................................................
*  ***   ATTENTION: X must be within a range of 10 GeV -- 1000 PeV   ***
*  ......................................................................
      COMMON /sok1/ XMIN,STEP,XMAX
      common /sok1_e/ C(19)
      real*4 x
      X1 = alog10(X)
       if ((X1.lt..99999e+0).or.(X1.gt.9.0001e+0)) then
       print*,'ERROR IN FUNCTION GETLELEC: MUON ENERGY IS OUT OF RANGE'
       endif
      Y = (X1-XMIN)/STEP
      I = INT(Y+0.5)
      IF(I.LT.0.OR.X1.GT.XMAX) PRINT 1,X1,XMIN,XMAX
      Y = Y-I
      Z = Y*Y + 0.25
      getlelec = (Z-Y)*C(I+1) + (2.-(Z+Z))*C(I+2) + (Z+Y)*C(I+3)
      RETURN
1     FORMAT('*MISTAKE*X1=',D23.16,'XMIN=',D23.16,'XMAX=',D23.16)
      END
****************************************************************************
* E.6
           FUNCTION glelecv(X)
*
*  THE ROUTINE USES A PART OF splain.f CODE (~/flib/splain.f) DEVELOPED AT
*                         IRKUTSK STATE UNIVERSITY
*
*     The subroutine calculates the value for mean free path for knock-on
*       electron production with energy transfers > VMIN using splain
*                 coefficients prepared by spl1 subroutine.
*
*          X is a value for muon energy expressed in GeV; XMIN,
*   XMAX and STEP are assigned with some values in subroutine SPL1 (they
*              are passed here via /sok1/ common block).
*   Array with splain coefficients C(19) is passed here from SPL1 via
*                             common /sok1_e2/
*  ......................................................................
*  ***   ATTENTION: X must be within a range of 10 GeV -- 1000 PeV   ***
*  ......................................................................
      COMMON /sok1/ XMIN,STEP,XMAX
      common /sok1_e2/ C(19)
      common /exer2/ noca
      real*4 x
      if (noca.eq.0) then
      glelecv = 1.e+34
      return
      endif
      X1 = alog10(X)
       if ((X1.lt..99999e+0).or.(X1.gt.9.0001e+0)) then
       print*,'ERROR IN FUNCTION GLELECV: MUON ENERGY IS OUT OF RANGE'
       endif
      Y = (X1-XMIN)/STEP
      I = INT(Y+0.5)
      IF(I.LT.0.OR.X1.GT.XMAX) PRINT 1,X1,XMIN,XMAX
      Y = Y-I
      Z = Y*Y + 0.25
      glelecv = (Z-Y)*C(I+1) + (2.-(Z+Z))*C(I+2) + (Z+Y)*C(I+3)
      glelecv = exp(glelecv)
      RETURN
1     FORMAT('*MISTAKE*X1=',D23.16,'XMIN=',D23.16,'XMAX=',D23.16)
      END
****************************************************************************
* E.7
           function getctel(u)
*
* Function GETCTEL calculates the total cross-section for knock-on electrons
*      production with energy transfers > EMIN using function GETLELEC.
*   The resulting cross-section is averaged over all atoms of given medium:
*
*                      sigma(E_mu) = SUM (w_i * sigma_i(E_mu)),
*
*       where w_i = N_i/N_tot, N_i - number of type i atoms in molecule,
* N_tot - total number of atoms in molecule, sigma_i(E_mu) is a cross-section
*                               for atom number i.
*      So, it is calculated for an "effective atoms" with atomic weight
*   A_eff = SUM(N_i*A_i) / N_tot and electric charge Z_eff = SUM(Z_i)/N_tot
*   It also uses some media parameters prepared by subroutine MED_CONS
*                      (commons /const/ and /media/)
*                   Input: u = muon energy (GeV)
*                   Output: getlelec = free length (cm)
* ..........................................................................
*        U MUST BE WITHIN THE RANGE OF 10 -- 1000,000,000 GeV
* ..........................................................................
*
      external getlelec
      real*8 z1(10),w(10),aw(10),a_ef,alfa,rm_e,rm_mu,r_e,avog,ro
      real*4 u
      common /const/ alfa,rm_e,rm_mu,r_e,avog
      common /media/ z1,w,aw,a_ef,ro,nsub
      if ((u.gt.1.0001e+9).or.(u.lt.9.9999e+0)) then
      print*,'ERROR IN FUNCTION GETCTEL: MUON ENERGY IS OUT OF RANGE'
      endif
      aef = sngl(a_ef / (avog * ro))
      getctel = aef / getlelec(u)
      return
      end
****************************************************************************
* E.8
           function gctelv(u)
*
*    Function calculates the total cross-section for knock-on electrons
*      production with energy transfers > VMIN using function GLELECV.
*   The resulting cross-section is averaged over all atoms of given medium:
*
*                      sigma(E_mu) = SUM (w_i * sigma_i(E_mu)),
*
*       where w_i = N_i/N_tot, N_i - number of type i atoms in molecule,
* N_tot - total number of atoms in molecule, sigma_i(E_mu) is a cross-section
*                               for atom number i.
*      So, it is calculated for an "effective atoms" with atomic weight
*   A_eff = SUM(N_i*A_i) / N_tot and electric charge Z_eff = SUM(Z_i)/N_tot
*   It also uses some media parameters prepared by subroutine MED_CONS
*                      (commons /const/ and /media/)
*                   Input: u = muon energy (GeV)
*                   Output: getlelec = free length (cm)
* ..........................................................................
*        U MUST BE WITHIN THE RANGE OF 10 -- 1000,000,000 GeV
* ..........................................................................
*
      external glelecv
      real*8 z1(10),w(10),aw(10),a_ef,alfa,rm_e,rm_mu,r_e,avog,ro
      real*4 u
      common /const/ alfa,rm_e,rm_mu,r_e,avog
      common /media/ z1,w,aw,a_ef,ro,nsub
      common /exer2/ noca
      if (noca.eq.0) then
      gctelv = 1.e-37
      return
      endif
      if ((u.gt.1.0001e+9).or.(u.lt.9.9999e+0)) then
      print*,'ERROR IN FUNCTION GCTELV: MUON ENERGY IS OUT OF RANGE'
      endif
      aef = sngl(a_ef / (avog * ro))
      gctelv = aef / glelecv(u)
      return
      end
************************************************************************
* E.9
             FUNCTION getdedel(X)
*
*  THE ROUTINE USES A PART OF splain.f CODE (~/flib/splain.f) DEVELOPED AT
*                         IRKUTSK STATE UNIVERSITY
*
*       The subroutine calculates the value for muon energy losses for
* knock-on electrons production with energy transfers above EMIN using splain
*                coefficients prepared by spl1 subroutine.
*
*          X is a value for muon energy expressed in GeV; XMIN,
*  XMAX and STEP are assigned with some values in subroutine SPL1 (they
*               are passed here via /sok5/ common block).
*   Array with splain coefficients C(19) is passed here from SPL1 via
*                              common /sok5_e/
*  ......................................................................
*  ***   ATTENTION: X must be within a range of 10 GeV --- 1000 PeV   ***
*  ......................................................................
      COMMON /sok5/ XMIN,STEP,XMAX
      common /sok5_e/ C(19)
      real*4 x
      X1 = alog10(X)
       if ((X1.lt..99999e+0).or.(X1.gt.9.0001e+0)) then
       print*,'ERROR IN FUNCTION GETDEDEL: MUON ENERGY IS OUT OF RANGE'
       endif
      Y = (X1-XMIN)/STEP
      I = INT(Y+0.5)
      IF(I.LT.0.OR.X1.GT.XMAX) PRINT 1,X1,XMIN,XMAX
      Y = Y-I
      Z = Y*Y + 0.25
      getdedel = (Z-Y)*C(I+1) + (2.-(Z+Z))*C(I+2) + (Z+Y)*C(I+3)
      getdedel = (1.e+1)**(getdedel)
      RETURN
1     FORMAT('*MISTAKE*X1=',D23.16,'XMIN=',D23.16,'XMAX=',D23.16)
      END
************************************************************************
* E.10
             FUNCTION gdedelv(X)
*
*  THE ROUTINE USES A PART OF splain.f CODE (~/flib/splain.f) DEVELOPED AT
*                         IRKUTSK STATE UNIVERSITY
*
*       The subroutine calculates the value for muon energy losses for
* knock-on electrons production with energy transfers above VMIN using splain
*                coefficients prepared by spl1 subroutine.
*
*          X is a value for muon energy expressed in GeV; XMIN,
*  XMAX and STEP are assigned with some values in subroutine SPL1 (they
*               are passed here via /sok5/ common block).
*   Array with splain coefficients C(19) is passed here from SPL1 via
*                              common /sok5_e2/
*  ......................................................................
*  ***   ATTENTION: X must be within a range of 10 GeV --- 1000 PeV   ***
*  ......................................................................
      COMMON /sok5/ XMIN,STEP,XMAX
      common /sok5_e2/ C(19)
      common /exer2/ noca
      real*4 x
      if (noca.eq.0) then
      gdedelv = 1.e-36
      return
      endif
      X1 = alog10(X)
       if ((X1.lt..99999e+0).or.(X1.gt.9.0001e+0)) then
       print*,'ERROR IN FUNCTION GDEDELV: MUON ENERGY IS OUT OF RANGE'
       endif
      Y = (X1-XMIN)/STEP
      I = INT(Y+0.5)
      IF(I.LT.0.OR.X1.GT.XMAX) PRINT 1,X1,XMIN,XMAX
      Y = Y-I
      Z = Y*Y + 0.25
      gdedelv = (Z-Y)*C(I+1) + (2.-(Z+Z))*C(I+2) + (Z+Y)*C(I+3)
      gdedelv = (1.e+1)**(gdedelv)
      RETURN
1     FORMAT('*MISTAKE*X1=',D23.16,'XMIN=',D23.16,'XMAX=',D23.16)
      END
****************************************************************************
* E.11
             FUNCTION gdedelt1(X)
*
*  THE ROUTINE USES A PART OF splain.f CODE (~/flib/splain.f) DEVELOPED AT
*                         IRKUTSK STATE UNIVERSITY
*
*    The subroutine calculates the value for total muon energy losses for
*    ionization (Berthe-Bloch + e-diagram for bremsstrahlung) using splain
*                 coefficients prepared by spl1 subroutine.
*
*          X is a value for muon energy expressed in GeV; XMIN,
*  XMAX and STEP are assigned with some values in subroutine SPL1 (they
*               are passed here via /sok5/ common block).
*   Array with splain coefficients C(19) is passed here from SPL1 via
*                              common /sok5_e4ex/
*  ......................................................................
*  ***   ATTENTION: X must be within a range of 10 GeV --- 1000 PeV   ***
*  ......................................................................
      COMMON /sok5/ XMIN,STEP,XMAX
      common /sok5_e4ex/ C(19)
      real*4 x
      X1 = alog10(X)
       if ((X1.lt..99999e+0).or.(X1.gt.9.0001e+0)) then
       print*,'ERROR IN FUNCTION GDEDELT1: MUON ENERGY IS OUT OF RANGE'
       endif
      Y = (X1-XMIN)/STEP
      I = INT(Y+0.5)
      IF(I.LT.0.OR.X1.GT.XMAX) PRINT 1,X1,XMIN,XMAX
      Y = Y-I
      Z = Y*Y + 0.25
      gdedelt1 = (Z-Y)*C(I+1) + (2.-(Z+Z))*C(I+2) + (Z+Y)*C(I+3)
      RETURN
1     FORMAT('*MISTAKE*X1=',D23.16,'XMIN=',D23.16,'XMAX=',D23.16)
      END
****************************************************************************
* E.12
             FUNCTION gdedelt2(X)
*
*  THE ROUTINE USES A PART OF splain.f CODE (~/flib/splain.f) DEVELOPED AT
*                         IRKUTSK STATE UNIVERSITY
*
*    The subroutine calculates the value for total muon energy losses for
*    ionization (Berthe-Bloch + e-diagram for bremsstrahlung) for low muon
* energies ( < 10 GeV) using splain coefficients prepared by spl1 subroutine.
*
*          X is a value for muon energy expressed in GeV; XMIN,
*  XMAX and STEP are assigned with some values in subroutine SPL1 (they
*               are passed here via /sok5et/ common block).
*   Array with splain coefficients C(103) is passed here from SPL1 via
*                              common /sok5_e5/
*  ......................................................................
*  ***   ATTENTION: X must be within a range of 0.16 GeV --- 12 GeV   ***
*  ......................................................................
      COMMON /sok5et/ XMIN,STEP,XMAX
      common /sok5_e5/ C(103)
      real*4 x
      X1 = alog10(X)
       if ((X1.lt.-.8e+0).or.(X1.gt.1.08e+0)) then
       print*,'ERROR IN FUNCTION GDEDELT2: MUON ENERGY IS OUT OF RANGE'
       endif
      Y = (X1-XMIN)/STEP
      I = INT(Y+0.5)
      IF(I.LT.0.OR.X1.GT.XMAX) PRINT 1,X1,XMIN,XMAX
      Y = Y-I
      Z = Y*Y + 0.25
      gdedelt2 = (Z-Y)*C(I+1) + (2.-(Z+Z))*C(I+2) + (Z+Y)*C(I+3)
      RETURN
1     FORMAT('*MISTAKE*X1=',D23.16,'XMIN=',D23.16,'XMAX=',D23.16)
      END
****************************************************************************
* E.13
             FUNCTION gdeion(X)
*
*    The subroutine calculates the value for total muon energy losses for
*    ionization (Berthe-Bloch + e-diagram for bremsstrahlung) for all muon
* energies ( 0.16 GeV < E_Mu < 10^9 GeV) using either gdedlt1 or gdedlt2
*                      depending on muon energy
*
*            X is a value for muon energy expressed in GeV.
*  ......................................................................
*  ***   ATTENTION: X must be within a range of 0.16 GeV --- 1 EeV   ***
*  ......................................................................
      external gdedelt1,gdedelt2
      real*4 x
       if ((X.lt..159).or.(X.gt.1.0001e+9)) then
       print*,'ERROR IN FUNCTION GDEDION: MUON ENERGY IS OUT OF RANGE'
       endif
      if(x.le.10.) then
      gdeion = gdedelt2(x)
      else
      gdeion = gdedelt1(x)
      endif
      return
      end
****************************************************************************
* E.14
             FUNCTION gdedelbb(X)
*
*  THE ROUTINE USES A PART OF splain.f CODE (~/flib/splain.f) DEVELOPED AT
*                         IRKUTSK STATE UNIVERSITY
*
*   The subroutine calculates the value for total muon energy losses for
*        ionization computed by Berthe-Bloch formula using splain
*                coefficients prepared by spl1 subroutine.
*
*          X is a value for muon energy expressed in GeV; XMIN,
*  XMAX and STEP are assigned with some values in subroutine SPL1 (they
*               are passed here via /sok5/ common block).
*   Array with splain coefficients C(19) is passed here from SPL1 via
*                              common /sok5_e3ex/
*  ......................................................................
*  ***   ATTENTION: X must be within a range of 10 GeV --- 1000 PeV   ***
*  ......................................................................
      COMMON /sok5/ XMIN,STEP,XMAX
      common /sok5_e3ex/ C(19)
      real*4 x
      X1 = alog10(X)
       if ((X1.lt..99999e+0).or.(X1.gt.9.0001e+0)) then
       print*,'ERROR IN FUNCTION GDEDELBB: MUON ENERGY IS OUT OF RANGE'
       endif
      Y = (X1-XMIN)/STEP
      I = INT(Y+0.5)
      IF(I.LT.0.OR.X1.GT.XMAX) PRINT 1,X1,XMIN,XMAX
      Y = Y-I
      Z = Y*Y + 0.25
      gdedelbb = (Z-Y)*C(I+1) + (2.-(Z+Z))*C(I+2) + (Z+Y)*C(I+3)
      RETURN
1     FORMAT('*MISTAKE*X1=',D23.16,'XMIN=',D23.16,'XMAX=',D23.16)
      END
****************************************************************************
* E.15
         SUBROUTINE getvel(emw,vbr1,itr)
*
*      It simulates the relative energy transfers for knock-on electrons
*  (including bremsstrahlung e-diagram) with energy transfers > EMIN (itr=0)
*                          or > VMIN (otherwise).
*                 Input: emw = muon energy expressed in GeV,
*                 Output: vbr = relative energy transfer.
*
*   The simulation is done by the "rejection method" (see W.H.Press et al.,
*  NUMERICAL RECEIPES (THE ART OF SCIENTIFIC COMPUTING), Cambridge University
*            press, Chapter 7, pp. 200-204) with comparison function
*             f(v)=2*pi*r_e*r_e*z*(m_e/E_mu)(1+0.032*lnE_mu)*(1/v^2)
* ..........................................................................
*            EMW MUST BE WITHIN THE RANGE OF 10 -- 1000,000,000 GeV
* ..........................................................................
      external getcde
      real*8 vbr,rmd,vtr,vtr1,rvec_own
ccc      real*8 emind,vmind,emwd
      real*4 emw,vbr1
      integer itr
      parameter (c2=2.549551e-28)
c      parameter (len=1)
c     common /r48/ rvec
      common /zav/ zm
      common /general/ emin,vmin,emph
      common /mcef/ mcb1,mcb2,mcp1,mcp2,mcn1,mcn2,mce1,mce2
      mce1 = mce1 + 1
ccc      emind = dble(emin)
ccc      vmind = dble(vmin)
ccc      emwd = dble(emw)
        if(itr.eq.0) then
         vtr = dble(emin/emw)
        else
         vtr = dble(vmin)
        endif
      vtr1 = 1.d+0 - vtr
      coef2 = c2 * zm *  ( 1. + ( 3.2e-2 * alog(emw) ) )
  155 call rm48_own(rvec_own)
      rmd=rvec_own
      mce2 = mce2 + 1
      vbr = vtr / (vtr + (vtr1 * rmd))
      if(vbr.ge.1.d+0) vbr=.999999999999d+0
      vbr1=sngl(vbr)
      y1 = getcde(emw,vbr1)
      y2 = coef2 / ( emw * vbr1 * vbr1)
      yc = y2 * rndm_mum(8)
           if(y2.lt.y1) then
           print*,'*** ERROR IN GETVEL: COMP.FUNCTION IS TOO SMALL ***'
           endif
                if (y1.ge.yc) then
                  goto 154
                else
                  goto 155
                endif
  154 return
      end
c -----------------------------
c  Version 1.6 - April 16, 2003                     MUM = MUons + Medium
c -----------------------------
c
c                    MUM1_6_2.F - sets of routines for the second medium
************************************************************************
c                THIS IS THE PART OF THE MUM PACKAGE FOR
c   THE 2ND MEDIUM. PLEASE READ MANUAL AT THE FIRST LINES OF MUM1_6.F
c      AND COMMENTS TO ALL THE ROUTINES (WHICH ARE IDENTICAL) THERE
************************************************************************
* C.1S
*
          SUBROUTINE init_muS(imed,ipn,ibre,em,vm,ilep,iqcd,lux)
c
      real*4 em,vm,em1,vm1
      real*4 v(13)
c
      integer imed,imed1,ipn,ibre,ilep,iqcd,lux
      integer ist(4)
c
      character *38 mum_card_name
c
      data v /5.3e-3,1.5e-2,4.9e-3,5.6e-3,5.7e-3,5.7e-3,2.0e-2,
     +        2.3e-2,1.8e-2,1.4e-2,1.1e-2,2.0e-2,2.0e-2/
c
      common /card_name/ mum_card_name
      common /init_calls/ ist
c
      ist(2) = ist(2) + 1
      lux = 2
c
c
c Opening card file for writing, making record and some screen output:
c
      open(23,file=mum_card_name, status='unknown', access='append',
     +form='formatted')
c
      write(23,*) 'Module initialized             : INIT_MUS'
c
      write(*,*) 'Initialization: INIT_MUS...'
c
c
c Checking (and changing if needed) variables IMED, EM AND VM:
c
c     IMED:
c
      if(imed.eq.0) then
         imed1 = 1
         write(*,505)  imed1
         write(*,*) ' '
      else
         if(imed.gt.0) then
            if(imed.gt.13) then
               imed1 = 1
               write(*,505)  imed1
               write(*,*) ' '
            else
               imed1 = imed
            endif
         else
            if(imed.lt.-13) then
               imed1 = -1
               write(*,505)  imed1
               write(*,*) ' '
            else
               imed1 = imed
            endif
         endif
      endif
c
c     EM:
c
      if(em.gt.0.5) then
         em1 = 0.5
         write(*,504)  em1
         write(*,*) ' '
      else
         if(em.lt.0.01) then
            em1 = 0.01
            write(*,504) em1
            write(*,*) ' '
         else
            em1 = em
         endif
      endif
c
c     VM:
c
      if(ilep.eq.1) then
         if(vm.lt.0.0001) then
             vm1 = 0.0001
             write(*,502)  vm1
             write(*,*) ' '
         else
             if(vm.gt.0.2) then
                vm1 = 0.2
                write(*,502)  vm1
                write(*,*) ' '
             else
                vm1 = vm
             endif
         endif
      else
         if(imed1.gt.0) then
            if(vm.ge.v(imed1)) then
               vm1 = v(imed1)
               write(*,502)  vm1
               write(*,*) ' '
            else
               if(vm.lt.0.0001) then
                  vm1 = 0.0001
                  write(*,502)  vm1
                  write(*,*) ' '
               else
                  vm1 = vm
               endif
            endif
         else
            if(vm.ge.4.e-3) then
               vm1 = 4.e-3
               write(*,502)  vm1
               write(*,*) ' '
            else
               if(vm.lt.0.0001) then
                  vm1 = 0.0001
                  write(*,502)  vm1
                  write(*,*) ' '
               else
                  vm1 = vm
               endif
            endif
         endif
      endif
c
c Making media, setting parameters:
c
      call med_consS(imed1,ipn,ibre,em1,vm1,ilep,iqcd)
      CALL PREPARE_DECAYS
c
c Computing bremsstrahlung: energy losses, cross-sections,
c constants for comparison function etc.:
c
      call gamma1S
c
c Computing e+e- pair production: energy losses, cross-sections,
c comparison function and its integral etc:
c
      call pair1S
c
c Computing photonuclear interaction: energy losses, cross-sections,
c etc.:
c
      if(iqcd.eq.1) call QCD_CORRS
      call phnu1S
c
c Computing D-electrons production: energy losses, cross-sections, etc.:
c
      call elec1S
c
c Computing continuous energy losses:
c
      call enlosS
c
c Cooking 1-dimensional real*4 splines with equidistant grid:
c
      call spl1S
c
c Ccooking 1-dimensional real*8 splines with equidistant grid:
c
      call dspl1S
c
c Cooking 1-dimensional real*8 splines with non-equidistant grid:
c
      call dsplq1S
c
c Cooking 2-dimensional real*4 splines with equidistant grid:
c
      call spl2S
c
c Cooking different kinds of splines:
c
      call frepathvS
      call spl2_2S
c
c Recording to the MUM run card:
c
      call prinfoS(imed1,ipn,ibre,em1,vm1,ilep,iqcd)
c
      close (23)
      return
  502 format (' !!! Variable Vcut out of range, has been changed for Vcu
     +t = ',f6.4,' !!!')
  504 format (' !!! Variable Ecut out of range, has been changed for Ecu
     +t = ',f6.4,' !!!')
  505 format (' !!! Variable IMED out of range, has been changed for IME
     +D = ',I3,' !!!')
      end
c----------------------------------------------------------------------
* C.1aS
*
      subroutine prinfoS(imed,ipn,ibre,em,vm,ilep,iqcd)
*
      real*8 alfa,rm_e,rm_mu,r_e,z1(10),w(10),aw(10),n(10)
      real*8 a_ef,avog,ro
      real*8 z_a,ri_z,x_0,x_1,a,rm
      real*4 em,vm
      integer imed,ipn,ibre,ilep,iqcd
      integer nsub
      character *38 mum_card_name
c
      common /constS/ alfa,rm_e,rm_mu,r_e,avog
      common /mediaS/ z1,w,aw,a_ef,ro,nsub
      common /med_ionS/ z_a,ri_z,x_0,x_1,a,rm
      common /toprintS/ n
      common /exer1S/ fa
      common /exer2S/ noca
      common /card_name/ mum_card_name
c
      open(23,file=mum_card_name, status='unknown', access='append',
     +form='formatted')
c
      if (ilep.eq.1) then
         write(23,501) ilep
      else
         write(23,502) ilep
      endif
c
      if (abs(imed).eq.1) write(23,601) imed
      if (abs(imed).eq.2) write(23,602) imed
      if (abs(imed).eq.3) write(23,603) imed
      if (abs(imed).eq.4) write(23,604) imed
      if (abs(imed).eq.5) write(23,605) imed
      if (abs(imed).eq.6) write(23,606) imed
      if (abs(imed).eq.7) write(23,607) imed
      if (abs(imed).eq.8) write(23,608) imed
      if (abs(imed).eq.9) write(23,609) imed
      if (abs(imed).eq.10) write(23,610) imed
      if (abs(imed).eq.11) write(23,611) imed
      if (abs(imed).eq.12) write(23,612) imed
      if (abs(imed).eq.13) write(23,613) imed
c
      if(imed.gt.0) then
      write(23,*)
     + 'Distance expressed in          : cm (IMED is positive)'
      else
      write(23,*)
     + 'Distance expressed in          : g/cm**3 (IMED is negative)'
      endif
c
      write(23,503) em
      write(23,504) vm
c
      write(23,*) 'Cross-section for absorption'
      if (ipn.eq.1) then
          write(23,505) ipn
      else
          write(23,506) ipn
      endif
c
      write(23,*) 'QCD corrections by'
      if (iqcd.eq.1) then
         write(23,507) iqcd
      else
         write(23,508) iqcd
      endif
c
      if(ibre.eq.1) then
         write(23,509) ibre
      endif
      if(ibre.eq.2) then
         write(23,514) ibre
      endif
      if((ibre.ne.1).AND.(ibre.ne.2)) then
         write(23,510) ibre
      endif
c
      write(23,*)
     + 'Knock-on electrons are'
      write(23,*)
     + 'included in catastrophic'
      if (noca.ne.0) then
         write(23,512) noca
      else
         write(23,513) noca
      endif
c
      if ((fa.lt..99999).or.(fa.gt.1.0001)) then
      write(23,*)
     + 'ATTENTION! RUNNING IN SPECIAL'
      write(23,*)
     + 'MODE: ALL CROSSSECTIONS ARE'
      write(23,511) fa
      endif
c
      write(23,*) '====='
      write(23,*) ' '
c
      close (23)
c
      return
c
  501 format (' Particle                       : MUON (ILEP = ',i1,')')
  502 format (' Particle                       : TAU (ILEP = ',i4,')')
  503 format (' Ecut                           : ',f8.6,' GeV')
  504 format (' Vcut                           : ',f8.6)
  505 format (' of a real photon               : by Bugaev-Bezrukov (ipn
     + = ',i4,')')
  506 format (' of a real photon               : by ZEUS (ipn = ',
     +i4,')')
  507 format (' Bugaev-Shlepin                 : YES (iqcd = ',i1,')')
  508 format (' Bugaev-Shlepin                 : NO (iqcd = ',i4,')')
  509 format (' Bremsstrahlung cross-sections  : by Andreev-Bezrukov-Bug
     +aev (ibre = ',i1,')')
  510 format (' Bremsstrahlung cross-sections  : by Kelner-Kokoulin (GEA
     +NT4.0) (ibre = ',i1,')')
  514 format (' Bremsstrahlung cross-sections  : by Sandrock (ibre = ',
     + i1,')')
  511 format (' MULTIPLIED BY FACTOR           : ',f8.6)
  512 format (' losses (recommended)           : YES (noca = ',i5,')')
  513 format (' losses                         : NO (noca = ',i5,')')
  601 format (' Medium                         : PURE WATER (imed = ',
     +i2,')')
  602 format (' Medium                         : STANDARD ROCK (imed = '
     +,i2,')')
  603 format (' Medium                         : ANTARCTIC ICE (imed = '
     +,i2,')')
  604 format  (' Medium                         : SEAWATER PACIFIC (imed
     + = ',i2,')')
  605 format (' Medium                         : SEAWATER ANTARES D<2126
     +m (imed = ',i2,')')
  606 format (' Medium                         : SEAWATER ANTARES D>2126
     +m (imed = ',i2,')')
  607 format    (' Medium                         : GRAN SASSO ROCK (ime
     +d = ',i2,')')
  608 format  (' Medium                         : BAIKAL BASIS ROCK (ime
     +d = ',i2,')')
  609 format (' Medium                         : BAIKAL TANKHOY ROCK (im
     +ed = ',i2,')')
  610 format   (' Medium                         : BAIKAL ANOS ROCK (ime
     +d = ',i3,')')
  611 format (' Medium                         : BAIKAL GROUND (SILT) (i
     +med = ',i3,')')
  612 format (' Medium                         : FREJUS ROCK (SINGLE MED
     +IUM) (imed = ',i3,')')
  613 format (' Medium                         : FREJUS ROCK (COMPOSED M
     +EDIUM) (imed = ',i3,')')
c
      end
***********************************************************************
* C.2S
       subroutine med_consS(imed,ipn,ibre,em,vm,ilep,iqcd)
*  ....................................................................
       real*8 alfa,rm_e,rm_mu,r_e,z1(10),w(10),aw(10),n(10)
       real*8 ntot,a_ef,avog,ro,zmean
       real*8 z_a,ri_z,x_0,x_1,a,rm
       real*8 tlife
       real*4 em,vm
       integer imed,ipn,ibre,ilep,iqcd
       integer nsub,iqcd1
       common /qcdS/ iqcd1
       common /const_tS/ tlife
       common /constS/ alfa,rm_e,rm_mu,r_e,avog
       common /mediaS/ z1,w,aw,a_ef,ro,nsub
       common /med_ionS/ z_a,ri_z,x_0,x_1,a,rm
       common /generalS/ emin,vmin,emph
       common /mcefS/ mcb1,mcb2,mcp1,mcp2,mcn1,mcn2,mce1,mce2
       common /zavS/ zm
       common /pnsigS/ ibb
       common /bremindS/ ibrem
       common /toprintS/ n
       common /exer1S/ fa
       common /exer2S/ noca
       common /what_lepS/ kindlept
       COMMON /MATTERS/ MEDIUM
       MEDIUM = imed
c ........................................................................

c ........................................................................
        iqcd1 = iqcd !---> accounting for QCD part in PN or not...
c ........................................................................
        tlife = 2.906d-13 !--> Tau-lepton mean time life (seconds)
c ........................................................................
        kindlept = ilep   !--> 1 if muons, any other value means taus
c ........................................................................
        mcb1 = 0  !
        mcb2 = 0  !
        mcp1 = 0  ! CONSTANTS TO CALCULATE
        mcp2 = 0  !      SIMULATION
        mcn1 = 0  !      EFFICIENCY
        mcn2 = 0  !
        mce1 = 0  !
        mce2 = 0  !
c ........................................................................
c                           BASIC CONSTANTS:
c                           ***************
       avog = 6.022045d+23         !--> Avogadro number
       alfa =  7.297353053019d-3   !--> fine structure constant
       rm_e = 5.110034d-1          !--> electron mass (in MeV)
       if(ilep.eq.1) then
       rm_mu = 1.0565932d+2        !--> muon mass (in MeV)
       else
       rm_mu = 1.77699d+3          !--> tau mass (in MeV)
       endif
       r_e = 2.8179409d-13         !--> classical electron radii (in cm)
c ........................................................................
c               THRESHOLD ENERGIE AND RELATIVE ENERGY TRANSFER:
c               ***********************************************
         emin = em      !---> threshold energy in Gev
         vmin = vm      !---> threshold relative energy transfer
         emph = 8.e-1   !---> threshold en. for photonucl. interaction, GeV
         fa = 1.e+0     !---> factor to multiply all diff. cros-sections and
c                       !     Bethe-Bloch formula
         noca = 1       !---> if noca=0, there are no catastrophic losses
c                             for knock-on electrons
c ........................................................................
        ibb = ipn ! if ibb=1 Sigma_gamma_p for photonuclear interaction is
c                 ! calculated by Bezrukov_Bugaev (squared LN dependence),
c                 ! otherwise it is calculated by ZEUS parametrization
c                 ! (J.Breitweg et al., Eur.Phys.J. C7 (1999) 609)
       ibrem=ibre ! if ibrem=1 diff. cross-section for bremsstrahlung is
c                 ! computed according to Andreev-Bugaev-Bezrukov, otherwise
c                 ! it is done according to Kelner-Kokouluin (Geant 4.)
c ........................................................................
c                          MEDIUM PREPARATION:
c                          ******************
        if (imed.eq.1) then
        ro=1.d+0      !
        nsub=2        ! IT IS WATER. It consists of nsub=2 elements:
        n(1)=2.d+0    ! n(1) = 2 H atoms and n(2) = 1 O atom with atomic
        n(2)=1.d+0    ! weights and electric charges are equal to
        aw(1)=1.008   ! aw(1) = 1.008, aw(2) = 15.999, z1(1) = 1 and
        aw(2)=15.999  ! z1(2) = 8, correspondingly
        z1(1)=1.d+0   ! Its density is ro = 1.0 g/qubic cm
        z1(2)=8.d+0   !
c                     !
        z_a = 5.551d-1! Z/A                      !
        ri_z = 7.5d-05! Min. Ion. Potential, MeV !
        x_0 = 2.4d-1  !--------------------      !--> It is constants
        x_1 = 2.8d+0  !-- 4 constants for        !--> for Bethe-Bloch
        a = 9.1d-2    !-- dencity effect         !-->     formula
        rm = 3.477d+0 !--------------------      !
        endif
c
        if (imed.eq.2) then
        ro=2.65d+0       !
        nsub=1           !
        n(1)=1.d+0       !
        aw(1)=22.        !
        z1(1)=1.1d+1     !
c                        ! ALL THE SAME FOR STANDARD ROCK
        z_a = 5.d-1      !
        ri_z = 1.364d-04 !
        x_0 = 4.9d-2     !
        x_1 = 3.055d+0   !
        a = 8.3d-2       !
        rm = 3.412d+0    !
        endif
c
        if (imed.eq.3) then
        ro=.92d+0       !
        nsub=2          !
        n(1)=2.d+0      !
        n(2)=1.d+0      ! The same for Antarctic ice
        aw(1)=1.008     ! (all constants are exactly as
        aw(2)=15.999    ! for water but ro = 0.92 g/cm^3 )
        z1(1)=1.d+0     !
        z1(2)=8.d+0     !
c                       !
        z_a = 5.551d-1  !
        ri_z = 7.5d-05  !
        x_0 = 2.4d-1    !
        x_1 = 2.8d+0    !
        a = 9.1d-2      !
        rm = 3.477d+0   !
        endif
c
c                         Sea water (Pacific Ocean):
c                         ------------------------
        if (imed.eq.4) then
        ro = 1.027d+0   ! J.Babson et al, Phys.Rev.D 42 (1990) 3613;
                        ! V.M.Goldschmidt. Geochemistry (Clarendon,
                        ! Oxford, 1954), p. 49.
        nsub = 8          !
        n(1) = 2.d+0      ! -> H
        n(2) = 1.00884d+0 ! -> O
        n(3) = 8.59d-3    ! -> Na
        n(4) = 1.9d-4     ! -> K
        n(5) = 9.9d-4     ! -> Mg
        n(6) = 1.9d-4     ! -> Ca
        n(7) = 1.007d-2   ! -> Cl
        n(8) = 5.3d-3     ! -> S
        aw(1) = 1.008d+0  !
        aw(2) = 15.999d+0 !
        aw(3) = 22.99d+0  ! Chemical composition of the seawater
        aw(4) = 39.10d+0  !           according to
        aw(5) = 24.31d+0  ! A.Okada, Astropart. Phys. 2 (1994) 393
        aw(6) = 40.08d+0  !        and references therein
        aw(7) = 35.45d+0  !
        aw(8) = 32.07d+0  !
        z1(1) = 1.0d+0    !
        z1(2) = 8.0d+0    !
        z1(3) = 11.0d+0   !
        z1(4) = 19.0d+0   !
        z1(5) = 12.0d+0   !
        z1(6) = 20.0d+0   !
        z1(7) = 17.0d+0   !
        z1(8) = 16.0d+0   !
c                        !
        z_a = 5.5525d-1  ! All the same as for pure water except for
        ri_z = 7.5d-05  !        z_a which is taken from
        x_0 = 2.4d-1    ! [J.Babson et al, Phys.Rev.D 42 (1990) 3613;
        x_1 = 2.8d+0    !  V.M.Goldschmidt. Geochemistry (Clarendon,
        a = 9.1d-2      !  Oxford, 1954), p. 49.] and differs from
        rm = 3.477d+0   ! z_a according to Lohman et al. by 0.027%.
        endif
c
c==========================================================================
c  THERE ARE TWO WATER FOR THE ANTARES PLACE SINCE WATER DENSITY CHANGES
c WITH THE DEPTH FROM 1.0291 g/cm^3 AT SURFACE UP TO 1.0404 g/cm^3 AT THE
c           SEA BED (ANTARES-Site/2000-001 and references therein)
c
c       So, one should use imed = 5 when simulating downcoming muons
c  (e.g., atmospheric ones) and imed = 6 when simulating muons which come
c                        from the bottom of detector)
c The error which is caused by thid simplyfied approach (average value for
c density) does not exceed 0.5% (much less, in fact) that is comparable with
c  an error which comes from uncerntainties with the muon cross-sections.
c==========================================================================
c
c           Sea water (Mediterranean Sea, ANTARES place, D < 2126 m):
c           --------------------------------------------------------
c
        if (imed.eq.5) then
        ro = 1.0341d+0  ! J.Brunner, ANTARES-Site/2000-001, the mean value
                        ! for sea water density at the ANTARES place between
                        ! surface D = 0 m (1.0291 g/cm^3) and middle of
                        ! detector D = 2126 m (1.0391 g/cm^3)
        nsub = 8          !
        n(1) = 2.d+0      ! -> H
        n(2) = 1.00884d+0 ! -> O
        n(3) = 9.43d-3    ! -> Na
        n(4) = 2.09d-4    ! -> K
        n(5) = 10.87d-4   ! -> Mg
        n(6) = 2.09d-4    ! -> Ca
        n(7) = 1.106d-2   ! -> Cl
        n(8) = 5.82d-3    ! -> S
        aw(1) = 1.008d+0  !
        aw(2) = 15.999d+0 !
        aw(3) = 22.99d+0  !    Chemical composition of the seawater
        aw(4) = 39.10d+0  !                  according to
        aw(5) = 24.31d+0  !     A.Okada, Astropart. Phys. 2 (1994) 393
        aw(6) = 40.08d+0  !              and references therein
        aw(7) = 35.45d+0  !  corrected for Mediterranean Sea, ANTARES place
        aw(8) = 32.07d+0  !     according to salinity  38.44+-0.02 g/kg,
        z1(1) = 1.0d+0    !   as cited in J.Brunner, ANTARES-Site/2000-001
        z1(2) = 8.0d+0    !  instead of 35.0 g/kg as cited in A.Okada, ...
        z1(3) = 11.0d+0   ! (so, n(3-8) have been just multiplied by 1.098)
        z1(4) = 19.0d+0   !
        z1(5) = 12.0d+0   !
        z1(6) = 20.0d+0   !
        z1(7) = 17.0d+0   !
        z1(8) = 16.0d+0   !
c                        !
        z_a = 5.5525d-1  ! All the same as for pure water except for
        ri_z = 7.5d-05  !        z_a which is taken from
        x_0 = 2.4d-1    ! [J.Babson et al, Phys.Rev.D 42 (1990) 3613;
        x_1 = 2.8d+0    !  V.M.Goldschmidt. Geochemistry (Clarendon,
        a = 9.1d-2      !  Oxford, 1954), p. 49.] and differs from
        rm = 3.477d+0   ! z_a according to Lohman et al. by 0.027%.
        endif
c
c
c           Sea water (Mediterranean Sea, ANTARES place, D > 2126 m):
c           --------------------------------------------------------
c
        if (imed.eq.6) then
        ro = 1.03975d+0 ! J.Brunner, ANTARES-Site/2000-001, the mean value
                        ! for sea water density at the ANTARES place between
                        ! sea bed D = 2400 m (1.0404 g/cm^3) and middle of
                        ! detector D = 2126 m (1.0391 g/cm^3)
        nsub = 8          !
        n(1) = 2.d+0      ! -> H
        n(2) = 1.00884d+0 ! -> O
        n(3) = 9.43d-3    ! -> Na
        n(4) = 2.09d-4    ! -> K
        n(5) = 10.87d-4   ! -> Mg
        n(6) = 2.09d-4    ! -> Ca
        n(7) = 1.106d-2   ! -> Cl
        n(8) = 5.82d-3    ! -> S
        aw(1) = 1.008d+0  !
        aw(2) = 15.999d+0 !
        aw(3) = 22.99d+0  !    Chemical composition of the seawater
        aw(4) = 39.10d+0  !                  according to
        aw(5) = 24.31d+0  !     A.Okada, Astropart. Phys. 2 (1994) 393
        aw(6) = 40.08d+0  !              and references therein
        aw(7) = 35.45d+0  !  corrected for Mediterranean Sea, ANTARES place
        aw(8) = 32.07d+0  !     according to salinity  38.44+-0.02 g/kg,
        z1(1) = 1.0d+0    !   as cited in J.Brunner, ANTARES-Site/2000-001
        z1(2) = 8.0d+0    !  instead of 35.0 g/kg as cited in A.Okada, ...
        z1(3) = 11.0d+0   ! (so, n(3-8) have been just multiplied by 1.098)
        z1(4) = 19.0d+0   !
        z1(5) = 12.0d+0   !
        z1(6) = 20.0d+0   !
        z1(7) = 17.0d+0   !
        z1(8) = 16.0d+0   !
c                        !
        z_a = 5.5525d-1  ! All the same as for pure water except for
        ri_z = 7.5d-05  !        z_a which is taken from
        x_0 = 2.4d-1    ! [J.Babson et al, Phys.Rev.D 42 (1990) 3613;
        x_1 = 2.8d+0    !  V.M.Goldschmidt. Geochemistry (Clarendon,
        a = 9.1d-2      !  Oxford, 1954), p. 49.] and differs from
        rm = 3.477d+0   ! z_a according to Lohman et al. by 0.027%.
        endif
c
c
c      Gran Sasso rock (M.Ambrosio et al., Phys. Rev. D52, (1995) 3793)
c      ----------------------------------------------------------------
c
        if (imed.eq.7) then
        ro = 2.71d+0
        nsub = 8            !
        n(1) = 2.9762d-2    ! -> H
        n(2) = 1.0132379d+0 ! -> C
        n(3) = 3.175109d+0  ! -> O
        n(4) = 3.423164d-1  ! -> Mg
        n(5) = 2.3349764d-2 ! -> Al
        n(6) = 3.73865d-2   ! -> Si
        n(7) = 2.557676d-3  ! -> K
        n(8) = 6.7094166d-1 ! -> Ca
        aw(1) = 1.008d+0
        aw(2) = 12.011d+0
        aw(3) = 15.99d+0
        aw(4) = 24.305d+0
        aw(5) = 26.981d+0
        aw(6) = 28.085d+0
        aw(7) = 39.098d+0
        aw(8) = 40.078d+0
        z1(1) = 1.0d+0
        z1(2) = 6.0d+0
        z1(3) = 8.0d+0
        z1(4) = 12.0d+0
        z1(5) = 13.0d+0
        z1(6) = 14.0d+0
        z1(7) = 19.0d+0
        z1(8) = 20.0d+0
c                        !
        z_a = 5.d-1      ! The same as for Standard Rock
        ri_z = 1.364d-04 !
        x_0 = 4.9d-2     !
        x_1 = 3.055d+0   !
        a = 8.3d-2       !
        rm = 3.412d+0    !
        endif
c
c
c   Baikal rock (basis, shore rocks and rocks 2 km below the Baikal bed)
c   --------------------------------------------------------------------
c        (as given at A.I.Panfilov, Baikal internal note 22/06/00)
c                         panfilov@inr.ruhep.ru
c
        if (imed.eq.8) then
        ro = 2.9d+0
        nsub = 10            !
        n(1) = 2.7251d-2     ! -> O
        n(2) = 8.15367d-3    ! -> Si
        n(3) = 1.670844d-4   ! -> Ti
        n(4) = 2.89087d-3    ! -> Al
        n(5) = 1.8443247d-3  ! -> Fe
        n(6) = 3.640467d-5   ! -> Mn
        n(7) = 1.810327d-3   ! -> Mg
        n(8) = 1.946205d-3   ! -> Ca
        n(9) = 7.3945837d-4  ! -> Na
        n(10) = 1.278828d-4  ! -> K
        aw(1) = 15.9994d+0
        aw(2) = 28.0855d+0
        aw(3) = 47.88d+0
        aw(4) = 26.9815d+0
        aw(5) = 55.847d+0
        aw(6) = 54.938d+0
        aw(7) = 24.305d+0
        aw(8) = 40.078d+0
        aw(9) = 22.9898d+0
        aw(10) = 39.0983d+0
        z1(1) = 8.0d+0
        z1(2) = 14.0d+0
        z1(3) = 22.0d+0
        z1(4) = 13.0d+0
        z1(5) = 26.0d+0
        z1(6) = 25.0d+0
        z1(7) = 12.0d+0
        z1(8) = 20.0d+0
        z1(9) = 11.0d+0
        z1(10) = 19.0d+0
c                        !
        z_a = 4.96d-1    ! The same as for Standard Rock (what to do?!)
        ri_z = 1.364d-04 !     except for z_a which was meaured
        x_0 = 4.9d-2     !          to be equal to 0.496
        x_1 = 3.055d+0   !
        a = 8.3d-2       !
        rm = 3.412d+0    !
        endif
c
c     Baikal rock ("tankhoy layer", up to 2000 m below the Baikal bed)
c      There are data concerning 6 depths which differ each other by
c   ~10% in terms of density, Z, A, and composition. One had to choose
c      the data for 800 m below the Baikal bed which seem to be close
c                                to "average"
c   --------------------------------------------------------------------
c        (as given at A.I.Panfilov, Baikal internal note 22/06/00)
c                         panfilov@inr.ruhep.ru
c
        if (imed.eq.9) then
        ro = 2.481d+0
        nsub = 10            !
        n(1) = 0.588d+0      ! -> O
        n(2) = 0.166d+0      ! -> Si
        n(3) = 0.002d+0      ! -> Ti
        n(4) = 0.093d+0      ! -> Al
        n(5) = 0.033d+0      ! -> Fe
        n(6) = 0.101d+0      ! -> H
        n(7) = 0.009d+0      ! -> Mg
        n(8) = 0.003d+0      ! -> Ca
        n(9) = 0.002d+0      ! -> Na
        n(10) = 0.003d+0     ! -> K
        aw(1) = 15.9994d+0
        aw(2) = 28.0855d+0
        aw(3) = 47.88d+0
        aw(4) = 26.9815d+0
        aw(5) = 55.847d+0
        aw(6) = 1.00794d+0
        aw(7) = 24.305d+0
        aw(8) = 40.078d+0
        aw(9) = 22.9898d+0
        aw(10) = 39.0983d+0
        z1(1) = 8.0d+0
        z1(2) = 14.0d+0
        z1(3) = 22.0d+0
        z1(4) = 13.0d+0
        z1(5) = 26.0d+0
        z1(6) = 1.0d+0
        z1(7) = 12.0d+0
        z1(8) = 20.0d+0
        z1(9) = 11.0d+0
        z1(10) = 19.0d+0
c                        !
        z_a = 5.47d-1     ! The same as for Standard Rock (what to do?!)
        ri_z = 1.364d-04 !     except for z_a which was meaured
        x_0 = 4.9d-2     !          to be equal to 0.547
        x_1 = 3.055d+0   !
        a = 8.3d-2       !
        rm = 3.412d+0    !
        endif
c
c      Baikal rock ("anos layer", 100 -- 500 m below the Baikal bed)
c      There are data concerning 6 depths which differ each other by
c   ~10% in terms of density, Z, A, and composition. One had to choose
c      the data for 300 m below the Baikal bed which seem to be close
c                                to "average"
c   --------------------------------------------------------------------
c        (as given at A.I.Panfilov, Baikal internal note 22/06/00)
c                         panfilov@inr.ruhep.ru
c
        if (imed.eq.10) then
        ro = 2.103d+0
        nsub = 10            !
        n(1) = 0.519d+0      ! -> O
        n(2) = 0.149d+0      ! -> Si
        n(3) = 0.002d+0      ! -> Ti
        n(4) = 0.044d+0      ! -> Al
        n(5) = 0.006d+0      ! -> Fe
        n(6) = 0.268d+0      ! -> H
        n(7) = 0.004d+0      ! -> Mg
        n(8) = 0.001d+0      ! -> Ca
        n(9) = 0.001d+0      ! -> Na
        n(10) = 0.006d+0     ! -> K
        aw(1) = 15.9994d+0
        aw(2) = 28.0855d+0
        aw(3) = 47.88d+0
        aw(4) = 26.9815d+0
        aw(5) = 55.847d+0
        aw(6) = 1.00794d+0
        aw(7) = 24.305d+0
        aw(8) = 40.078d+0
        aw(9) = 22.9898d+0
        aw(10) = 39.0983d+0
        z1(1) = 8.0d+0
        z1(2) = 14.0d+0
        z1(3) = 22.0d+0
        z1(4) = 13.0d+0
        z1(5) = 26.0d+0
        z1(6) = 1.0d+0
        z1(7) = 12.0d+0
        z1(8) = 20.0d+0
        z1(9) = 11.0d+0
        z1(10) = 19.0d+0
c                        !
        z_a = 6.3d-1     ! The same as for Standard Rock (what to do?!)
        ri_z = 1.364d-04 !     except for z_a which was meaured
        x_0 = 4.9d-2     !          to be equal to 0.630
        x_1 = 3.055d+0   !
        a = 8.3d-2       !
        rm = 3.412d+0    !
        endif
c
c     Baikal ground ("alevrit silt", 0 -- 100 m below the Baikal bed)
c      There are data concerning 6 depths which differ each other by
c   ~10% in terms of density, Z, A, and composition. One had to choose
c      the data for 50 m below the Baikal bed which seem to be close
c                               to "average"
c   --------------------------------------------------------------------
c        (as given at A.I.Panfilov, Baikal internal note 22/06/00)
c                         panfilov@inr.ruhep.ru
c
        if (imed.eq.11) then
        ro = 1.698d+0
        nsub = 10            !
        n(1) = 0.439d+0      ! -> O
        n(2) = 0.090d+0      ! -> Si NB: the litle fraction of S
        n(3) = 0.001d+0      ! -> Ti     had to be added to Si (very
        n(4) = 0.018d+0      ! -> Al     close elements, within
        n(5) = 0.005d+0      ! -> Fe      systematic errors)
        n(6) = 0.431d+0      ! -> H
        n(7) = 0.003d+0      ! -> Mg
        n(8) = 0.003d+0      ! -> Ca
        n(9) = 0.005d+0      ! -> Na
        n(10) = 0.003d+0     ! -> K
        aw(1) = 15.9994d+0
        aw(2) = 28.0855d+0
        aw(3) = 47.88d+0
        aw(4) = 26.9815d+0
        aw(5) = 55.847d+0
        aw(6) = 1.00794d+0
        aw(7) = 24.305d+0
        aw(8) = 40.078d+0
        aw(9) = 22.9898d+0
        aw(10) = 39.0983d+0
        z1(1) = 8.0d+0
        z1(2) = 14.0d+0
        z1(3) = 22.0d+0
        z1(4) = 13.0d+0
        z1(5) = 26.0d+0
        z1(6) = 1.0d+0
        z1(7) = 12.0d+0
        z1(8) = 20.0d+0
        z1(9) = 11.0d+0
        z1(10) = 19.0d+0
c                        !
        z_a = 7.11d-1    ! The same as for Standard Rock (what to do?!)
        ri_z = 7.5d-05   !  except for z_a which was meaured to be equal
        x_0 = 4.9d-2     ! to 0.711, ri_z had to be taken for water since
        x_1 = 3.055d+0   ! this ground is obviously closer to water than
        a = 8.3d-2       !               to rock...
        rm = 3.412d+0    !
        endif
c
c
c                  FREJUS ROCK ("single medium" model)
c                  ===================================
c       as described in W.Rhode, "Untersuchung der Energiespektren
c hochenergetischer Muonen im Frejusdetektor", Dissertation zur Erlangung
c  des Doktorgrades des Fachbereiches Physik der Bergischer UniversitaEt
c              Wupppertal, WUB-DIS 93-11, Oktober 1993, 232 pp.
c
        if (imed.eq.12) then
        ro=2.74d+0       !
        nsub=1           !
        n(1)=1.d+0       !
        aw(1)=20.34      !
        z1(1)=1.012d+1   !
c                        ! Everything has been taken from
        z_a = 4.975d-1   !        W.Rhode Thesis
        ri_z = 1.49d-04  !
        x_0 = 2.88d-1    !
        x_1 = 3.196d+0   !
        a = 7.8d-2       !
        rm = 3.645d+0    !
        endif
c
c   Frejus rock ("composed medium" model), as it was incorporated in
c PROPMU code by W.Rhode (W.Rhode, private communication, October 2001)
c
        if (imed.eq.13) then
        ro = 2.74d+0
        nsub = 10            !
        n(1) = 9.1800165d-3  ! -> C
        n(2) = 3.8712389d-2  ! -> O
        n(3) = 3.0446410d-4  ! -> Mg
        n(4) = 1.3342456d-3  ! -> Al
        n(5) = 3.6584715d-3  ! -> Si
        n(6) = 7.9523483d-5  ! -> S
        n(7) = 1.6650340d-4  ! -> K
        n(8) = 2.5955637d-3  ! -> Ca
        n(9) = 6.4072169d-6  ! -> Mn
        n(10) = 1.7417229d-4 ! -> Fe
        aw(1) = 12.11d+0
        aw(2) = 15.9994d+0
        aw(3) = 24.305d+0
        aw(4) = 26.981539d+0
        aw(5) = 28.0855d+0
        aw(6) = 32.066d+0
        aw(7) = 39.0983d+0
        aw(8) = 40.078d+0
        aw(9) = 54.93805d+0
        aw(10) = 55.847d+0
        z1(1) = 6.0d+0
        z1(2) = 8.0d+0
        z1(3) = 12.0d+0
        z1(4) = 13.0d+0
        z1(5) = 14.0d+0
        z1(6) = 16.0d+0
        z1(7) = 19.0d+0
        z1(8) = 20.0d+0
        z1(9) = 25.0d+0
        z1(10) = 26.0d+0
c
        z_a = 4.975d-1
        ri_z = 1.49d-04
        x_0 = 2.88d-1
        x_1 = 3.196d+0
        a = 7.8d-2
        rm = 3.645d+0
        endif
c
        if (imed.eq.-1) then
        ro=1.d+0      !
        nsub=2        ! IT IS WATER. It consists of nsub=2 elements:
        n(1)=2.d+0    ! n(1) = 2 H atoms and n(2) = 1 O atom with atomic
        n(2)=1.d+0    ! weights and electric charges are equal to
        aw(1)=1.008   ! aw(1) = 1.008, aw(2) = 15.999, z1(1) = 1 and
        aw(2)=15.999  ! z1(2) = 8, correspondingly
        z1(1)=1.d+0   ! Its density is ro = 1.0 g/qubic cm
        z1(2)=8.d+0   !
c                     !
        z_a = 5.551d-1! Z/A                      !
        ri_z = 7.5d-05! Min. Ion. Potential, MeV !
        x_0 = 2.4d-1  !--------------------      !--> It is constants
        x_1 = 2.8d+0  !-- 4 constants for        !--> for Bethe-Bloch
        a = 9.1d-2    !-- dencity effect         !-->     formula
        rm = 3.477d+0 !--------------------      !
        endif
c
        if (imed.eq.-2) then
        ro=1.0d+0        !
        nsub=1           !
        n(1)=1.d+0       !
        aw(1)=22.        !
        z1(1)=1.1d+1     !
c                        ! ALL THE SAME FOR STANDARD ROCK
        z_a = 5.d-1      !
        ri_z = 1.364d-04 !
        x_0 = 4.9d-2     !
        x_1 = 3.055d+0   !
        a = 8.3d-2       !
        rm = 3.412d+0    !
        endif
c
        if (imed.eq.-3) then
        ro=1.0d+0       !
        nsub=2          !
        n(1)=2.d+0      !
        n(2)=1.d+0      ! The same for Antarctic ice
        aw(1)=1.008     ! (all constants are exactly as
        aw(2)=15.999    ! for water but ro = 0.92 g/cm^3 )
        z1(1)=1.d+0     !
        z1(2)=8.d+0     !
c                       !
        z_a = 5.551d-1  !
        ri_z = 7.5d-05  !
        x_0 = 2.4d-1    !
        x_1 = 2.8d+0    !
        a = 9.1d-2      !
        rm = 3.477d+0   !
        endif
c
c                         Sea water (Pacific Ocean):
c                         ------------------------
        if (imed.eq.-4) then
        ro = 1.0d+0     ! J.Babson et al, Phys.Rev.D 42 (1990) 3613;
                        ! V.M.Goldschmidt. Geochemistry (Clarendon,
                        ! Oxford, 1954), p. 49.
        nsub = 8          !
        n(1) = 2.d+0      ! -> H
        n(2) = 1.00884d+0 ! -> O
        n(3) = 8.59d-3    ! -> Na
        n(4) = 1.9d-4     ! -> K
        n(5) = 9.9d-4     ! -> Mg
        n(6) = 1.9d-4     ! -> Ca
        n(7) = 1.007d-2   ! -> Cl
        n(8) = 5.3d-3     ! -> S
        aw(1) = 1.008d+0  !
        aw(2) = 15.999d+0 !
        aw(3) = 22.99d+0  ! Chemical composition of the seawater
        aw(4) = 39.10d+0  !           according to
        aw(5) = 24.31d+0  ! A.Okada, Astropart. Phys. 2 (1994) 393
        aw(6) = 40.08d+0  !        and references therein
        aw(7) = 35.45d+0  !
        aw(8) = 32.07d+0  !
        z1(1) = 1.0d+0    !
        z1(2) = 8.0d+0    !
        z1(3) = 11.0d+0   !
        z1(4) = 19.0d+0   !
        z1(5) = 12.0d+0   !
        z1(6) = 20.0d+0   !
        z1(7) = 17.0d+0   !
        z1(8) = 16.0d+0   !
c                        !
        z_a = 5.5525d-1  ! All the same as for pure water except for
        ri_z = 7.5d-05  !        z_a which is taken from
        x_0 = 2.4d-1    ! [J.Babson et al, Phys.Rev.D 42 (1990) 3613;
        x_1 = 2.8d+0    !  V.M.Goldschmidt. Geochemistry (Clarendon,
        a = 9.1d-2      !  Oxford, 1954), p. 49.] and differs from
        rm = 3.477d+0   ! z_a according to Lohman et al. by 0.027%.
        endif
c
c           Sea water (Mediterranean Sea, ANTARES place, D < 2126 m):
c           --------------------------------------------------------
c
        if (imed.eq.-5) then
        ro = 1.0d+0     ! J.Brunner, ANTARES-Site/2000-001, the mean value
                        ! for sea water density at the ANTARES place between
                        ! surface D = 0 m (1.0291 g/cm^3) and middle of
                        ! detector D = 2126 m (1.0391 g/cm^3)
        nsub = 8          !
        n(1) = 2.d+0      ! -> H
        n(2) = 1.00884d+0 ! -> O
        n(3) = 9.43d-3    ! -> Na
        n(4) = 2.09d-4    ! -> K
        n(5) = 10.87d-4   ! -> Mg
        n(6) = 2.09d-4    ! -> Ca
        n(7) = 1.106d-2   ! -> Cl
        n(8) = 5.82d-3    ! -> S
        aw(1) = 1.008d+0  !
        aw(2) = 15.999d+0 !
        aw(3) = 22.99d+0  !    Chemical composition of the seawater
        aw(4) = 39.10d+0  !                  according to
        aw(5) = 24.31d+0  !     A.Okada, Astropart. Phys. 2 (1994) 393
        aw(6) = 40.08d+0  !              and references therein
        aw(7) = 35.45d+0  !  corrected for Mediterranean Sea, ANTARES place
        aw(8) = 32.07d+0  !     according to salinity  38.44+-0.02 g/kg,
        z1(1) = 1.0d+0    !   as cited in J.Brunner, ANTARES-Site/2000-001
        z1(2) = 8.0d+0    !  instead of 35.0 g/kg as cited in A.Okada, ...
        z1(3) = 11.0d+0   ! (so, n(3-8) have been just multiplied by 1.098)
        z1(4) = 19.0d+0   !
        z1(5) = 12.0d+0   !
        z1(6) = 20.0d+0   !
        z1(7) = 17.0d+0   !
        z1(8) = 16.0d+0   !
c                        !
        z_a = 5.5525d-1  ! All the same as for pure water except for
        ri_z = 7.5d-05  !        z_a which is taken from
        x_0 = 2.4d-1    ! [J.Babson et al, Phys.Rev.D 42 (1990) 3613;
        x_1 = 2.8d+0    !  V.M.Goldschmidt. Geochemistry (Clarendon,
        a = 9.1d-2      !  Oxford, 1954), p. 49.] and differs from
        rm = 3.477d+0   ! z_a according to Lohman et al. by 0.027%.
        endif
c
c
c           Sea water (Mediterranean Sea, ANTARES place, D > 2126 m):
c           --------------------------------------------------------
c
        if (imed.eq.-6) then
        ro = 1.0d+0     ! J.Brunner, ANTARES-Site/2000-001, the mean value
                        ! for sea water density at the ANTARES place between
                        ! sea bed D = 2400 m (1.0404 g/cm^3) and middle of
                        ! detector D = 2126 m (1.0391 g/cm^3)
        nsub = 8          !
        n(1) = 2.d+0      ! -> H
        n(2) = 1.00884d+0 ! -> O
        n(3) = 9.43d-3    ! -> Na
        n(4) = 2.09d-4    ! -> K
        n(5) = 10.87d-4   ! -> Mg
        n(6) = 2.09d-4    ! -> Ca
        n(7) = 1.106d-2   ! -> Cl
        n(8) = 5.82d-3    ! -> S
        aw(1) = 1.008d+0  !
        aw(2) = 15.999d+0 !
        aw(3) = 22.99d+0  !    Chemical composition of the seawater
        aw(4) = 39.10d+0  !                  according to
        aw(5) = 24.31d+0  !     A.Okada, Astropart. Phys. 2 (1994) 393
        aw(6) = 40.08d+0  !              and references therein
        aw(7) = 35.45d+0  !  corrected for Mediterranean Sea, ANTARES place
        aw(8) = 32.07d+0  !     according to salinity  38.44+-0.02 g/kg,
        z1(1) = 1.0d+0    !   as cited in J.Brunner, ANTARES-Site/2000-001
        z1(2) = 8.0d+0    !  instead of 35.0 g/kg as cited in A.Okada, ...
        z1(3) = 11.0d+0   ! (so, n(3-8) have been just multiplied by 1.098)
        z1(4) = 19.0d+0   !
        z1(5) = 12.0d+0   !
        z1(6) = 20.0d+0   !
        z1(7) = 17.0d+0   !
        z1(8) = 16.0d+0   !
c                        !
        z_a = 5.5525d-1  ! All the same as for pure water except for
        ri_z = 7.5d-05  !        z_a which is taken from
        x_0 = 2.4d-1    ! [J.Babson et al, Phys.Rev.D 42 (1990) 3613;
        x_1 = 2.8d+0    !  V.M.Goldschmidt. Geochemistry (Clarendon,
        a = 9.1d-2      !  Oxford, 1954), p. 49.] and differs from
        rm = 3.477d+0   ! z_a according to Lohman et al. by 0.027%.
        endif
c
c
c      Gran Sasso rock (M.Ambrosio et al., Phys. Rev. D52, (1995) 3793)
c      ----------------------------------------------------------------
c
        if (imed.eq.-7) then
        ro = 1.0d+0
        nsub = 8            !
        n(1) = 2.9762d-2    ! -> H
        n(2) = 1.0132379d+0 ! -> C
        n(3) = 3.175109d+0  ! -> O
        n(4) = 3.423164d-1  ! -> Mg
        n(5) = 2.3349764d-2 ! -> Al
        n(6) = 3.73865d-2   ! -> Si
        n(7) = 2.557676d-3  ! -> K
        n(8) = 6.7094166d-1 ! -> Ca
        aw(1) = 1.008d+0
        aw(2) = 12.011d+0
        aw(3) = 15.99d+0
        aw(4) = 24.305d+0
        aw(5) = 26.981d+0
        aw(6) = 28.085d+0
        aw(7) = 39.098d+0
        aw(8) = 40.078d+0
        z1(1) = 1.0d+0
        z1(2) = 6.0d+0
        z1(3) = 8.0d+0
        z1(4) = 12.0d+0
        z1(5) = 13.0d+0
        z1(6) = 14.0d+0
        z1(7) = 19.0d+0
        z1(8) = 20.0d+0
c                        !
        z_a = 5.d-1      ! The same as for Standard Rock
        ri_z = 1.364d-04 !
        x_0 = 4.9d-2     !
        x_1 = 3.055d+0   !
        a = 8.3d-2       !
        rm = 3.412d+0    !
        endif
c
c
c   Baikal rock (basis, shore rocks and rocks 2 km below the Baikal bed)
c   --------------------------------------------------------------------
c        (as given at A.I.Panfilov, Baikal internal note 22/06/00)
c                         panfilov@inr.ruhep.ru
c
        if (imed.eq.-8) then
        ro = 1.0d+0
        nsub = 10            !
        n(1) = 2.7251d-2     ! -> O
        n(2) = 8.15367d-3    ! -> Si
        n(3) = 1.670844d-4   ! -> Ti
        n(4) = 2.89087d-3    ! -> Al
        n(5) = 1.8443247d-3  ! -> Fe
        n(6) = 3.640467d-5   ! -> Mn
        n(7) = 1.810327d-3   ! -> Mg
        n(8) = 1.946205d-3   ! -> Ca
        n(9) = 7.3945837d-4  ! -> Na
        n(10) = 1.278828d-4  ! -> K
        aw(1) = 15.9994d+0
        aw(2) = 28.0855d+0
        aw(3) = 47.88d+0
        aw(4) = 26.9815d+0
        aw(5) = 55.847d+0
        aw(6) = 54.938d+0
        aw(7) = 24.305d+0
        aw(8) = 40.078d+0
        aw(9) = 22.9898d+0
        aw(10) = 39.0983d+0
        z1(1) = 8.0d+0
        z1(2) = 14.0d+0
        z1(3) = 22.0d+0
        z1(4) = 13.0d+0
        z1(5) = 26.0d+0
        z1(6) = 25.0d+0
        z1(7) = 12.0d+0
        z1(8) = 20.0d+0
        z1(9) = 11.0d+0
        z1(10) = 19.0d+0
c                        !
        z_a = 4.96d-1    ! The same as for Standard Rock (what to do?!)
        ri_z = 1.364d-04 !     except for z_a which was meaured
        x_0 = 4.9d-2     !          to be equal to 0.496
        x_1 = 3.055d+0   !
        a = 8.3d-2       !
        rm = 3.412d+0    !
        endif
c
c     Baikal rock ("tankhoy layer", up to 2000 m below the Baikal bed)
c      There are data concerning 6 depths which differ each other by
c   ~10% in terms of density, Z, A, and composition. One had to choose
c      the data for 800 m below the Baikal bed which seem to be close
c                                to "average"
c   --------------------------------------------------------------------
c        (as given at A.I.Panfilov, Baikal internal note 22/06/00)
c                         panfilov@inr.ruhep.ru
c
        if (imed.eq.-9) then
        ro = 1.0d+0
        nsub = 10            !
        n(1) = 0.588d+0      ! -> O
        n(2) = 0.166d+0      ! -> Si
        n(3) = 0.002d+0      ! -> Ti
        n(4) = 0.093d+0      ! -> Al
        n(5) = 0.033d+0      ! -> Fe
        n(6) = 0.101d+0      ! -> H
        n(7) = 0.009d+0      ! -> Mg
        n(8) = 0.003d+0      ! -> Ca
        n(9) = 0.002d+0      ! -> Na
        n(10) = 0.003d+0     ! -> K
        aw(1) = 15.9994d+0
        aw(2) = 28.0855d+0
        aw(3) = 47.88d+0
        aw(4) = 26.9815d+0
        aw(5) = 55.847d+0
        aw(6) = 1.00794d+0
        aw(7) = 24.305d+0
        aw(8) = 40.078d+0
        aw(9) = 22.9898d+0
        aw(10) = 39.0983d+0
        z1(1) = 8.0d+0
        z1(2) = 14.0d+0
        z1(3) = 22.0d+0
        z1(4) = 13.0d+0
        z1(5) = 26.0d+0
        z1(6) = 1.0d+0
        z1(7) = 12.0d+0
        z1(8) = 20.0d+0
        z1(9) = 11.0d+0
        z1(10) = 19.0d+0
c                        !
        z_a = 5.47d-1     ! The same as for Standard Rock (what to do?!)
        ri_z = 1.364d-04 !     except for z_a which was meaured
        x_0 = 4.9d-2     !          to be equal to 0.547
        x_1 = 3.055d+0   !
        a = 8.3d-2       !
        rm = 3.412d+0    !
        endif
c
c      Baikal rock ("anos layer", 100 -- 500 m below the Baikal bed)
c      There are data concerning 6 depths which differ each other by
c   ~10% in terms of density, Z, A, and composition. One had to choose
c      the data for 300 m below the Baikal bed which seem to be close
c                                to "average"
c   --------------------------------------------------------------------
c        (as given at A.I.Panfilov, Baikal internal note 22/06/00)
c                         panfilov@inr.ruhep.ru
c
        if (imed.eq.-10) then
        ro = 1.0d+0
        nsub = 10            !
        n(1) = 0.519d+0      ! -> O
        n(2) = 0.149d+0      ! -> Si
        n(3) = 0.002d+0      ! -> Ti
        n(4) = 0.044d+0      ! -> Al
        n(5) = 0.006d+0      ! -> Fe
        n(6) = 0.268d+0      ! -> H
        n(7) = 0.004d+0      ! -> Mg
        n(8) = 0.001d+0      ! -> Ca
        n(9) = 0.001d+0      ! -> Na
        n(10) = 0.006d+0     ! -> K
        aw(1) = 15.9994d+0
        aw(2) = 28.0855d+0
        aw(3) = 47.88d+0
        aw(4) = 26.9815d+0
        aw(5) = 55.847d+0
        aw(6) = 1.00794d+0
        aw(7) = 24.305d+0
        aw(8) = 40.078d+0
        aw(9) = 22.9898d+0
        aw(10) = 39.0983d+0
        z1(1) = 8.0d+0
        z1(2) = 14.0d+0
        z1(3) = 22.0d+0
        z1(4) = 13.0d+0
        z1(5) = 26.0d+0
        z1(6) = 1.0d+0
        z1(7) = 12.0d+0
        z1(8) = 20.0d+0
        z1(9) = 11.0d+0
        z1(10) = 19.0d+0
c                        !
        z_a = 6.3d-1     ! The same as for Standard Rock (what to do?!)
        ri_z = 1.364d-04 !     except for z_a which was meaured
        x_0 = 4.9d-2     !          to be equal to 0.630
        x_1 = 3.055d+0   !
        a = 8.3d-2       !
        rm = 3.412d+0    !
        endif
c
c     Baikal ground ("alevrit silt", 0 -- 100 m below the Baikal bed)
c      There are data concerning 6 depths which differ each other by
c   ~10% in terms of density, Z, A, and composition. One had to choose
c      the data for 50 m below the Baikal bed which seem to be close
c                               to "average"
c   --------------------------------------------------------------------
c        (as given at A.I.Panfilov, Baikal internal note 22/06/00)
c                         panfilov@inr.ruhep.ru
c
        if (imed.eq.-11) then
        ro = 1.0d+0
        nsub = 10            !
        n(1) = 0.439d+0      ! -> O
        n(2) = 0.090d+0      ! -> Si NB: the litle fraction of S
        n(3) = 0.001d+0      ! -> Ti     had to be added to Si (very
        n(4) = 0.018d+0      ! -> Al     close elements, within
        n(5) = 0.005d+0      ! -> Fe      systematic errors)
        n(6) = 0.431d+0      ! -> H
        n(7) = 0.003d+0      ! -> Mg
        n(8) = 0.003d+0      ! -> Ca
        n(9) = 0.005d+0      ! -> Na
        n(10) = 0.003d+0     ! -> K
        aw(1) = 15.9994d+0
        aw(2) = 28.0855d+0
        aw(3) = 47.88d+0
        aw(4) = 26.9815d+0
        aw(5) = 55.847d+0
        aw(6) = 1.00794d+0
        aw(7) = 24.305d+0
        aw(8) = 40.078d+0
        aw(9) = 22.9898d+0
        aw(10) = 39.0983d+0
        z1(1) = 8.0d+0
        z1(2) = 14.0d+0
        z1(3) = 22.0d+0
        z1(4) = 13.0d+0
        z1(5) = 26.0d+0
        z1(6) = 1.0d+0
        z1(7) = 12.0d+0
        z1(8) = 20.0d+0
        z1(9) = 11.0d+0
        z1(10) = 19.0d+0
c                        !
        z_a = 7.11d-1    ! The same as for Standard Rock (what to do?!)
        ri_z = 7.5d-05   !  except for z_a which was meaured to be equal
        x_0 = 4.9d-2     ! to 0.711, ri_z had to be taken for water since
        x_1 = 3.055d+0   ! this ground is obviously closer to water than
        a = 8.3d-2       !               to rock...
        rm = 3.412d+0    !
        endif
c
c
c                  FREJUS ROCK ("single medium" model)
c                  ===================================
c       as described in W.Rhode, "Untersuchung der Energiespektren
c hochenergetischer Muonen im Frejusdetektor", Dissertation zur Erlangung
c  des Doktorgrades des Fachbereiches Physik der Bergischer UniversitaEt
c              Wupppertal, WUB-DIS 93-11, Oktober 1993, 232 pp.
c
        if (imed.eq.-12) then
        ro=1.0d+0        !
        nsub=1           !
        n(1)=1.d+0       !
        aw(1)=20.34      !
        z1(1)=1.012d+1   !
c                        ! Everything has been taken from
        z_a = 4.975d-1   !        W.Rhode Thesis
        ri_z = 1.49d-04  !
        x_0 = 2.88d-1    !
        x_1 = 3.196d+0   !
        a = 7.8d-2       !
        rm = 3.645d+0    !
        endif
c
c   Frejus rock ("composed medium" model), as it was incorporated in
c PROPMU code by W.Rhode (W.Rhode, private communication, October 2001)
c
        if (imed.eq.-13) then
        ro = 1.0d+0
        nsub = 10            !
        n(1) = 9.1800165d-3  ! -> C
        n(2) = 3.8712389d-2  ! -> O
        n(3) = 3.0446410d-4  ! -> Mg
        n(4) = 1.3342456d-3  ! -> Al
        n(5) = 3.6584715d-3  ! -> Si
        n(6) = 7.9523483d-5  ! -> S
        n(7) = 1.6650340d-4  ! -> K
        n(8) = 2.5955637d-3  ! -> Ca
        n(9) = 6.4072169d-6  ! -> Mn
        n(10) = 1.7417229d-4 ! -> Fe
        aw(1) = 12.11d+0
        aw(2) = 15.9994d+0
        aw(3) = 24.305d+0
        aw(4) = 26.981539d+0
        aw(5) = 28.0855d+0
        aw(6) = 32.066d+0
        aw(7) = 39.0983d+0
        aw(8) = 40.078d+0
        aw(9) = 54.93805d+0
        aw(10) = 55.847d+0
        z1(1) = 6.0d+0
        z1(2) = 8.0d+0
        z1(3) = 12.0d+0
        z1(4) = 13.0d+0
        z1(5) = 14.0d+0
        z1(6) = 16.0d+0
        z1(7) = 19.0d+0
        z1(8) = 20.0d+0
        z1(9) = 25.0d+0
        z1(10) = 26.0d+0
c
        z_a = 4.975d-1
        ri_z = 1.49d-04
        x_0 = 2.88d-1
        x_1 = 3.196d+0
        a = 7.8d-2
        rm = 3.645d+0
        endif
c
        ntot=0.d+0
        do i=1,nsub
        ntot=ntot+n(i) !----> ntot is total number of atoms in molecula
        enddo
        do i=1,nsub
        w(i)=n(i)/ntot !-----> w(i) are relative weights of different atoms
        enddo          !       w(i) = n(i) / ntot
c
        zmean=0.d+0
        do i=1,nsub
        zmean = zmean + (z1(i)*n(i))
        enddo
        zm = sngl(zmean/ntot) !-> mean charge of averaged atom (for Delec-s)
c
        a_ef = 0.d+0
        do i=1,nsub
        a_ef = a_ef + ((n(i)*aw(i))/ntot) !--> it is an effective atomic
        enddo                             !    weight for an averaged atom
c                                         !    for which diff. and total cros-
        return                            !    csections will be computed.
        end
****************************************************************************
* C.3S
         SUBROUTINE spl1S
*
       common /con_losS/ elosemin(17),elosvmin(17)
       common /elengS/ eminleng(17)
       common /ctbr_in1S/ FBC(17),FBC2(17)
       common /elbr_in1S/ FBL(17),FBL2(17)
       common /elbr_in2S/ FBL3(17)
       common /ctpa_in1S/ FPC(17),FPC2(17)
       common /elpa_in1S/ FPL(17),FPL2(17)
       common /elpa_in2S/ FPL3(17)
       common /ctph_in1S/ FNC(17),FNC2(65)
       common /elph_in1S/ FNL(17),FNL2(65)
       common /elph_in2S/ FNL3(17)
       common /ctel_in1S/ FEC(17),FEC2(17)
       common /elel_in1S/ FEL(17),FEL2(17)
       common /elel_in2S/ FELBB(17),FELBBB(17)
       common /elel_in3S/ FELOWTOT(101)
       common /sok34S/ com_pa_m(2201)
       common /sok1S/ xmin1_c,st1_c,xmax1_c
       common /eminlS/ xm1,s1,xma1
       common /sok5S/ xmin1_l,st1_l,xmax1_l
       common /sok1nS/ xmin1_nc,st1_nc,xmax1_nc
       common /sok5nS/ xmin1_nl,st1_nl,xmax1_nl
       common /sok5etS/ xmin1_lo,st1_lo,xmax1_lo
       common /sok55S/ xmin1_p,st1_p,xmax1_p
       common /sok1_bS/ CBC(19)
       common /sok5_bS/ CBL(19)
       common /sok1_b2S/ CBC2(19)
       common /sok5_b2S/ CBL2(19)
       common /sok5_b3S/ CBL3(19)
       common /sok1_pS/ CPC(19)
       common /sok5_pS/ CPL(19)
       common /sok1_p2S/ CPC2(19)
       common /sok5_p2S/ CPL2(19)
       common /sok5_p3S/ CPL3(19)
       common /sok1_nS/ CNC(19)
       common /sok5_nS/ CNL(19)
       common /sok1_n2S/ CNC2(67)
       common /sok5_n2S/ CNL2(67)
       common /sok5_n3S/ CNL3(19)
       common /sok1_eS/ CEC(19)
       common /sok5_eS/ CEL(19)
       common /sok1_e2S/ CEC2(19)
       common /sok5_e2S/ CEL2(19)
       common /sok5_e3S/ CEBB(19)
       common /sok5_e4S/ CEBBB(19)
       common /elemS/ CLE(19)
       common /elvmS/ CLV(19)
       common /eminl1S/ CLE1(19)
       common /sok5_e5S/ CETOT(103)
       common /sok55_pS/ CPC1(2203)
       dimension IJ(26)
       dimension xmin1(26),st1(26),xmax1(26)
       dimension F(2201),C(2203)
      data xmin1/1.e+0,1.e+0,1.e+0,1.e+0,1.e+0,1.e+0,1.e+0,1.e+0,1.e+0,
     +           1.e+0,1.e+0,1.e+0,1.e+0,1.e+0,1.e+0,1.e+0,1.e+0,1.e+0,
     +           1.e+0,1.e+0,1.e+0,1.e+0,1.e+0,-1.1e+1,-.853871964,
     +           1.e+0/
      data xmax1/9.e+0,9.e+0,9.e+0,9.e+0,9.e+0,9.e+0,9.e+0,9.e+0,
     +           9.e+0,9.e+0,9.e+0,9.e+0,9.e+0,9.e+0,9.e+0,9.e+0,9.e+0,
     +           9.e+0,9.e+0,9.e+0,9.e+0,9.e+0,9.e+0,0.e+0,1.146128036,
     +           9.e+0/
      data st1/5.e-1,5.e-1,5.e-1,5.e-1,5.e-1,5.e-1,5.e-1,5.e-1,
     +         5.e-1,5.e-1,5.e-1,5.e-1,1.25e-1,1.25e-1,5.e-1,5.e-1,
     +         5.e-1,5.e-1,5.e-1,5.e-1,5.e-1,5.e-1,5.e-1,5.e-3,2.e-2,
     +         5.e-1/
      data IJ/17,17,17,17,17,17,17,17,17,17,17,17,65,65,
     +        17,17,17,17,17,17,17,17,17,2201,101,17/
c
      do lik=1,26  !--> A cycle along all input arrays
          N = IJ(lik)  !--> Getting dimension for given inpiut array
c
          if (lik.eq.1) then     ! GETTING FIRST VALUE,
           xmin1_c = xmin1(lik)  !      STEP AND LAST VALUE OF ARGUMENT
           st1_c = st1(lik)      !         FOR ALL INPUT ARRAYS
           xmax1_c = xmax1(lik)  !           IN ACCORING WITH THEIR NUMBERS
          endif                  !                     ( LIK )
          if (lik.eq.2) then     !
           xmin1_l = xmin1(lik)  !
           st1_l = st1(lik)      !
           xmax1_l = xmax1(lik)  !
          endif                  !
          if (lik.eq.13) then    !
           xmin1_nc = xmin1(lik) !
           st1_nc = st1(lik)     !
           xmax1_nc = xmax1(lik) !
          endif                  !
          if (lik.eq.14) then    !
           xmin1_nl = xmin1(lik) !
           st1_nl = st1(lik)     !
           xmax1_nl = xmax1(lik) !
          endif                  !
          if (lik.eq.24) then    !
           xmin1_p = xmin1(lik)  !
           st1_p = st1(lik)      !
           xmax1_p = xmax1(lik)  !
          endif                  !
          if (lik.eq.25) then    !
           xmin1_lo = xmin1(lik) !
           st1_lo = st1(lik)     !
           xmax1_lo = xmax1(lik) !
          endif                  !
          if (lik.eq.26) then    !
           xm1 = xmin1(lik)      !
           s1 = st1(lik)         !
           xma1 = xmax1(lik)     !
          endif                  !
c                                ---------------
          do jj=1,N                            !
            if (lik.eq.1) F(jj) = FBC(jj)      !
            if (lik.eq.2) F(jj) = FBL(jj)      !
            if (lik.eq.3) F(jj) = FBC2(jj)     ! Filling the auxiliary array
            if (lik.eq.4) F(jj) = FBL2(jj)     ! F with values of input array
            if (lik.eq.5) F(jj) = FBL3(jj)     ! number LIK for further
            if (lik.eq.6) F(jj) = FPC(jj)      !                processing.
            if (lik.eq.7) F(jj) = FPL(jj)      !
            if (lik.eq.8) F(jj) = FPC2(jj)     !
            if (lik.eq.9) F(jj) = FPL2(jj)     !
            if (lik.eq.10) F(jj) = FPL3(jj)    !
            if (lik.eq.11) F(jj) = FNC(jj)     !
            if (lik.eq.12) F(jj) = FNL(jj)     !
            if (lik.eq.13) F(jj) = FNC2(jj)    !
            if (lik.eq.14) F(jj) = FNL2(jj)    !
            if (lik.eq.15) F(jj) = FNL3(jj)    !
            if (lik.eq.16) F(jj) = FEC(jj)     !
            if (lik.eq.17) F(jj) = FEL(jj)     !
            if (lik.eq.18) F(jj) = FEC2(jj)    !
            if (lik.eq.19) F(jj) = FEL2(jj)    !
            if (lik.eq.20) F(jj) = FELBB(jj)   !
            if (lik.eq.21) F(jj) = FELBBB(jj)  !
            if (lik.eq.22) F(jj) = elosemin(jj)!
            if (lik.eq.23) F(jj) = elosvmin(jj)!
            if (lik.eq.24) F(jj) = com_pa_m(jj)!
            if (lik.eq.25) F(jj) = FELOWTOT(jj)!
            if (lik.eq.26) F(jj) = eminleng(jj)!
           enddo                               !
c----------------------------------------------!
      C(1)=1.4375*F(1)-1.3750*F(2)+0.4375*F(3)  !
      C(2)=0.4375*F(1)+0.1250*F(2)-0.0625*F(3)    !
      DO 1 K=3,N                                    ! ---> Cooking splayns
1     C(K)= 0.6250*F(K-1)-0.0625*(F(K-2)+F(K))       ! and putting them into
      C(N+1)=0.4375*F(N)+0.1250*F(N-1)-0.0625*F(N-2) !  auxiliary array C
      C(N+2)=1.4375*F(N)-1.375*F(N-1)+0.4375*F(N-2)  !
c----------------------------------------------------
         mo = N+2                          !
         do jj=1,mo                        ! Splain coefficients from C are
           if (lik.eq.1) CBC(jj) = C(jj)   ! put into corresponding array N LIK
           if (lik.eq.2) CBL(jj) = C(jj)   ! which is passed to corresponding
           if (lik.eq.3) CBC2(jj) = C(jj)  ! subroutine for interpolation.
           if (lik.eq.4) CBL2(jj) = C(jj)  !
           if (lik.eq.5) CBL3(jj) = C(jj)  !
           if (lik.eq.6) CPC(jj) = C(jj)   !
           if (lik.eq.7) CPL(jj) = C(jj)   !
           if (lik.eq.8) CPC2(jj) = C(jj)  !
           if (lik.eq.9) CPL2(jj) = C(jj)  !
           if (lik.eq.10) CPL3(jj) = C(jj) !
           if (lik.eq.11) CNC(jj) = C(jj)  !
           if (lik.eq.12) CNL(jj) = C(jj)  !
           if (lik.eq.13) CNC2(jj) = C(jj) !
           if (lik.eq.14) CNL2(jj) = C(jj) !
           if (lik.eq.15) CNL3(jj) = C(jj) !
           if (lik.eq.16) CEC(jj) = C(jj)  !
           if (lik.eq.17) CEL(jj) = C(jj)  !
           if (lik.eq.18) CEC2(jj) = C(jj) !
           if (lik.eq.19) CEL2(jj) = C(jj) !
           if (lik.eq.20) CEBB(jj) = C(jj) !
           if (lik.eq.21) CEBBB(jj) = C(jj)!
           if (lik.eq.22) CLE(jj) = C(jj)  !
           if (lik.eq.23) CLV(jj) = C(jj)  !
           if (lik.eq.24) CPC1(jj) = C(jj) !
           if (lik.eq.25) CETOT(jj) = C(jj)!
           if (lik.eq.26) CLE1(jj) = C(jj) !
         enddo                             !
      enddo
      RETURN
      END
****************************************************************************
* C.4S
      SUBROUTINE dspl1S
*
      real*8 com_pa_in(1101)
      real*8 CP_1(1103)
      real*8 xmin_p1,st_p1,xmax_p1
      real*8 xmin1(1),st1(1),xmax1(1)
      real*8 F(1101),C(1103)
      common /sok24S/ com_pa_in
      common /sok26S/ CP_1
      common /sok25S/ xmin_p1,st_p1,xmax_p1
      dimension IJ(1)
      data xmin1/-1.1d+1/
      data xmax1/0.d+0/
      data st1/1.d-2/
      data IJ/1101/
c
      do lik=1,1  !--> A cycle along all input arrays
          N = IJ(lik) !--> Getting dimension for given input array
c
          if (lik.eq.1) then     ! GETTING FIRST VALUE, STEP AND LAST VALUE
           xmin_p1 = xmin1(lik)  ! OF ARGUMENTS FOR ALL INPUT ARRAYS IN
           st_p1 = st1(lik)      ! ACCORDING TO THEIR NUMBERS (LIK)
           xmax_p1 = xmax1(lik)  !
          endif                  !
c
          do jj=1,N                             ! Filling the auxiliary array F
            if (lik.eq.1) F(jj) = com_pa_in(jj) ! with values of corresponding
          enddo                                 ! input array Nb. LIK
c
      C(1)=1.4375*F(1)-1.3750*F(2)+0.4375*F(3)        !
      C(2)=0.4375*F(1)+0.1250*F(2)-0.0625*F(3)        ! Cookiing splain
      DO 1 K=3,N                                      ! coefficients and
1     C(K)= 0.6250*F(K-1)-0.0625*(F(K-2)+F(K))        ! putting them into
      C(N+1)=0.4375*F(N)+0.1250*F(N-1)-0.0625*F(N-2)  ! auxiliary array C
      C(N+2)=1.4375*F(N)-1.375*F(N-1)+0.4375*F(N-2)   !
c
         mo = N+2                         ! Splain coefficients from C are
         do jj=1,mo                       ! put into corresponding output
           if (lik.eq.1) CP_1(jj) = C(jj) ! array Nb. LIK whic is passe to
         enddo                            ! corresponding subroutine
c                                         ! for interpolation
      enddo
      RETURN
      END
****************************************************************************
* C.5
         SUBROUTINE spl2S
*
      common /cdbr_inS/ FB1(81,54),FB3(81,101),FB2(81,51)
      common /cdpa_inS/ FP1(81,54),FP3(81,101),FP2(81,51)
      common /cdph_inS/ FN1(81,54),FN3(81,101),FN2(81,51)
      common /sok3S/ CB1(4648)
      common /sok6S/ CB2(4399)
      common /sok4S/ CB3(8549)
      common /sok8S/ CP1(4648)
      common /sok9S/ CP2(4399)
      common /sok10S/ CP3(8549)
      common /mum8S/ CN1(4648)
      common /mum9S/ CN2(4399)
      common /mum10S/ CN3(8549)
      common /sok_2_1S/ NX_1,NY_1,X0_1,SX_1,Y0_1,SY_1
      common /sok_2_2S/ NX_2,NY_2,X0_2,SX_2,Y0_2,SY_2
      common /sok_2_3S/ NX_3,NY_3,X0_3,SX_3,Y0_3,SY_3
      DIMENSION D(90,110),FU(81,101),CU(8549)
      DIMENSION NXG(9),NYG(9),X0G(9),SXG(9),Y0G(9),SYG(9)
      DIMENSION IJ(9)
      data NXG/81,81,81,81,81,81,81,81,81/
      data NYG/54,51,101,54,51,101,54,51,101/
      data X0G/1.e+0,1.e+0,1.e+0,1.e+0,1.e+0,1.e+0,1.e+0,1.e+0,1.e+0/
      data SXG/1.e-1,1.e-1,1.e-1,1.e-1,1.e-1,1.e-1,1.e-1,1.e-1,1.e-1/
      data Y0G/-11.,-6.e-1,-1.e-1,-11.,-6.e-1,-1.e-1,-11.,-6.e-1,-1.e-1/
      data SYG/2.e-1,1.e-2,1.e-3,2.e-1,1.e-2,1.e-3,2.e-1,1.e-2,1.e-3/
      data IJ/4648,4399,8549,4648,4399,8549,4648,4399,8549/
c
      do li=1,9
      NX = NXG(li)
      NY = NYG(li)
      X0 = X0G(li)
      SX = SXG(li)
      Y0 = Y0G(li)
      SY = SYG(li)
c
       if (li.eq.1) then
         NX_1 = NX
         NY_1 = NY
         X0_1 = X0
         SX_1 = SX
         Y0_1 = Y0
         SY_1 = SY
       endif
c
       if (li.eq.2) then
         NX_2 = NX
         NY_2 = NY
         X0_2 = X0
         SX_2 = SX
         Y0_2 = Y0
         SY_2 = SY
       endif
c
       if (li.eq.3) then
         NX_3 = NX
         NY_3 = NY
         X0_3 = X0
         SX_3 = SX
         Y0_3 = Y0
         SY_3 = SY
       endif
c
        do ki=1,NX
           do kl=1,NY
              if (li.eq.1) FU(ki,kl) = FB1(ki,kl)
              if (li.eq.2) FU(ki,kl) = FB2(ki,kl)
              if (li.eq.3) FU(ki,kl) = FB3(ki,kl)
              if (li.eq.4) FU(ki,kl) = FP1(ki,kl)
              if (li.eq.5) FU(ki,kl) = FP2(ki,kl)
              if (li.eq.6) FU(ki,kl) = FP3(ki,kl)
              if (li.eq.7) FU(ki,kl) = FN1(ki,kl)
              if (li.eq.8) FU(ki,kl) = FN2(ki,kl)
              if (li.eq.9) FU(ki,kl) = FN3(ki,kl)
           enddo
        enddo
cccccccc 2019 - ATTENTION!
      I2=1
cccccccc
      DO 1 J=1,NY
      J2=J+2
      DO 1 I=1,NX
      I2=I+2
1     D(I2,J2)=3.90625E-3*FU(I,J)
      J1=NY+1
      J3=J2+1
      J4=J3+1
      DO 2 I=3,I2
      A=D(I,3)
      B=D(I,4)
      D(I,2)=3.*(A-B)+D(I,5)
      D(I,1)=3.*(D(I,2)-A)+B
      A=D(I,J1)
      B=D(I,J2)
      D(I,J3)=3.*(B-A)+D(I,NY)
2     D(I,J4)=3.*(D(I,J3)-B)+A
      I1=NX+1
      I3=I2+1
      I4=I3+1
      DO 3 J=1,J4
      A=D(3,J)
      B=D(4,J)
      D(2,J)=3.*(A-B)+D(5,J)
      D(1,J)=3.*(D(2,J)-A)+B
      A=D(I1,J)
      B=D(I2,J)
      D(I3,J)=3.*(B-A)+D(NX,J)
3     D(I4,J)=3.*(D(I3,J)-B)+A
      DO 4 J=1,J2
      J3=J+1
      J4=J+2
      M=(J-1)*I2
      DO 4 I=1,I2
      I3=I+1
      I4=I+2
4     CU(M+I)=D(I,J)+D(I,J4)+D(I4,J)+D(I4,J4)+D(I3,J3)* !
     *100.-(D(I3,J)+D(I,J3)+D(I4,J3)+D(I3,J4))*10.      !
c
       ko = IJ(li)
       do ki=1,ko
              if (li.eq.1) CB1(ki) = CU(ki)
              if (li.eq.2) CB2(ki) = CU(ki)
              if (li.eq.3) CB3(ki) = CU(ki)
              if (li.eq.4) CP1(ki) = CU(ki)
              if (li.eq.5) CP2(ki) = CU(ki)
              if (li.eq.6) CP3(ki) = CU(ki)
              if (li.eq.7) CN1(ki) = CU(ki)
              if (li.eq.8) CN2(ki) = CU(ki)
              if (li.eq.9) CN3(ki) = CU(ki)
       enddo
      enddo
      RETURN
      END
****************************************************************************
* C.6S
        SUBROUTINE enlosS
*
c
c     From GAMMA1S:
c
      common /elbr_in1S/ elo_br1(17),elo_br2(17)
      common /elbr_in2S/ elo_br3(17)
      common /elbr_in4S/ elo_br4(17)
      common /ctbr_in1S/ crt_br1(17),crt_br2(17)
c
c     From PAIR1S:
c
      common /elpa_in1S/ elo_pa1(17),elo_pa2(17)
      common /elpa_in2S/ elo_pa3(17)
      common /elpa_in4S/ elo_pa4(17)
      common /ctpa_in1S/ crt_pa1(17),crt_pa2(17)
c
c     From PHNU1S:
c
      common /elph_in1S/ elo_ph1(17),elo_ph2(65)
      common /elph_in2S/ elo_ph3(17)
      common /elph_in4S/ elo_ph4(17)
      common /ctph_in1S/ crt_ph1(17),crt_ph2(65)
c
c     From ELEC1S:
c
      common /elel_in1S/ elo_el1(17),elo_el2(17)
      common /elel_in2S/ elel_bb(17),elel_bbb(17)
      common /ctel_in1S/ crt_el1(17),crt_el2(17)
c
c     To SPL1S:
c
      common /con_losS/ elosemin(17),elosvmin(17)
      common /elengS/ eminleng(17)
c
      do i=1,17
       j = (4 * i) - 3
       elosemin(i) = elo_br4(i)
       elosvmin(i) = (1.e+1**elo_br3(i)) - (1.e+1**elo_br2(i))
       elosemin(i) = elosemin(i) + elo_pa4(i)
       elosvmin(i) = elosvmin(i) + exp(elo_pa3(i)) - exp(elo_pa2(i))
       elosemin(i) = elosemin(i) + elo_ph4(i)
       elosvmin(i) = elosvmin(i) + 1.e+1**elo_ph3(i) - 1.e+1**elo_ph2(j)
       elosemin(i) = elosemin(i) + elel_bbb(i) - 1.e+1**elo_el1(i)
       elosvmin(i) = elosvmin(i) + elel_bbb(i) - 1.e+1**elo_el2(i)
       elosvmin(i) = alog(elosvmin(i))
       eminleng(i) = 1./crt_br1(i) + 1./exp(crt_pa1(i)) +
     +                              1./exp(crt_ph1(i)) + 1./crt_el1(i)
       eminleng(i) = 1./eminleng(i)
      enddo
      return
      end
****************************************************************************
* C.7S
             FUNCTION coneS(X)
*
      real*4 X
      COMMON /sok5S/ XMIN,STEP,XMAX
      common /elemS/ C(19)
      X1 = alog10(X)
       if ((X1.lt..99999e+0).or.(X1.gt.9.0001e+0)) then
       print*,'ERROR IN FUNCTION CONES: LEPTON ENERGY IS OUT OF RANGE'
       endif
      Y = (X1-XMIN)/STEP
      I = INT(Y+0.5)
      IF(I.LT.0.OR.X1.GT.XMAX) PRINT 1,X1,XMIN,XMAX
      Y = Y-I
      Z = Y*Y + 0.25
      coneS = (Z-Y)*C(I+1) + (2.-(Z+Z))*C(I+2) + (Z+Y)*C(I+3)
      RETURN
1     FORMAT('*MISTAKE*X1=',D23.16,'XMIN=',D23.16,'XMAX=',D23.16)
      END
****************************************************************************
* C.8S
             FUNCTION convS(X)
*
      real*4 X
      COMMON /sok5S/ XMIN,STEP,XMAX
      common /elvmS/ C(19)
      X1 = alog10(X)
       if ((X1.lt..99999e+0).or.(X1.gt.9.0001e+0)) then
       print*,'ERROR IN FUNCTION CONVS: LEPTON ENERGY IS OUT OF RANGE'
       endif
      Y = (X1-XMIN)/STEP
      I = INT(Y+0.5)
      IF(I.LT.0.OR.X1.GT.XMAX) PRINT 1,X1,XMIN,XMAX
      Y = Y-I
      Z = Y*Y + 0.25
      convS = (Z-Y)*C(I+1) + (2.-(Z+Z))*C(I+2) + (Z+Y)*C(I+3)
      convS = exp(convS)
      RETURN
1     FORMAT('*MISTAKE*X1=',D23.16,'XMIN=',D23.16,'XMAX=',D23.16)
      END
****************************************************************************
* C.9S
         FUNCTION gemlengS(X)
*
      real*4 X
      COMMON /eminlS/ XMIN,STEP,XMAX
      common /eminl1S/ C(19)
      X1 = alog10(X)
       if ((X1.lt..99999e+0).or.(X1.gt.9.0001e+0)) then
       print*,'ERROR IN FUNCTION GEMLENGS: MUON ENERGY IS OUT OF RANGE'
       endif
      Y = (X1-XMIN)/STEP
      I = INT(Y+0.5)
      IF(I.LT.0.OR.X1.GT.XMAX) PRINT 1,X1,XMIN,XMAX
      Y = Y-I
      Z = Y*Y + 0.25
      gemlengS= (Z-Y)*C(I+1) + (2.-(Z+Z))*C(I+2) + (Z+Y)*C(I+3)
      RETURN
1     FORMAT('*MISTAKE*X1=',D23.16,'XMIN=',D23.16,'XMAX=',D23.16)
      END
************************************************************************
* C.10S
      subroutine frepathvS
*
      external glbremvS,glpairvS,glphnuvS,glelecvS,convS
      external dsimps,gdedelt2S
      real*8 e0(0:128),a(0:128),b(0:128),eta(0:128),leng(0:128)
      real*8 fk,fk1,dlnmax,slu,e,en,delta
      real*8 low,up,step1,aux1(0:10),rest,eta_1,hd3,pat1,pat2
      real*8 ene,path
      real*8 dsimps
      common /vrand1S/ vpath(111,161)
      common /vrand2S/ vener(111,161)
      common /simv1S/ fk,fk1,dlnmax,a,b,leng,e0
c
c   ---------------------------------------------------------------
c   1. Computing arrays e0(0:128), a(0:128), b(0:128), eta(0:128),
c           leng(0:128) and constants FK, FK1 and DLNMAX
c
      fk=dexp(-(dlog(1.d+1)/1.6d+1)) !--> a coefficient to get
      fk1 = 1.d+0 / dlog(fk)         !    e0(i)=fk*e0(i-1) and
      dlnmax = dlog(1.d+9)           !    some useful constants
c
      e0(0) = 1.d+9
        do i=1,128
        e0(i) = e0(0) * (fk**dble(i))         !-> e0(i)
        y2 = (convS(sngl(e0(i-1))) * 1.e-3)    !-> dE/dx (e0(i-1))
        y1 = (convS(sngl(e0(i))) * 1.e-3)      !-> dE/dx (e0(i))
        a(i) = dble((y2 - y1)) / (e0(i-1) - e0(i)) !-> a(i)
        b(i) = dble(y1) - a(i) * e0(i)             !-> b(i)
c
c                     Computing two integrals
c
c       ..................................................
c       .             e0(i-1)                            .
c       .   eta(i) = INTEGRAL(dE/(dE/dx(E) * L_mean(E))  .
c       .              e0(i)                             .
c       .                                                .
c       .                  e0(i-1)                       .
c       .       leng(i) = INTEGRAL (dE/(dE/dx(E)))       .
c       .                  e0(i)                         .
c       ..................................................
c
c using a formula INTEGRAL [f(x) * dx] = INTEGRAL [x * f(x) * d(ln(x))] :
c
        low = dlog(e0(i))
        up = dlog(e0(i-1))
        lim1 = 10
        step1 = (up - low) / dble(lim1)
         do j=0,lim1
         ene = low + (dble(j) * step1)
         h1 = sngl(dexp(ene))
         help=(1./glbremvS(h1))+(1./glpairvS(h1))+(1./glphnuvS(h1)) +
     +           (1./glelecvS(h1))
         aux1(j) = (1.d+0 / dble(help))*dble(convS(h1))*1.d-3/dble(h1)
         aux1(j) = 1.d+0 / aux1(j)
         enddo
         eta(i) = dsimps(aux1,low,up,lim1)
c
         do j=0,lim1
         ene = low + (dble(j) * step1)
         h1 = sngl(dexp(ene))
         aux1(j) = dble(convS(h1)) * 1.d-3 / dble(h1)
         aux1(j) = 1.d+0 / aux1(j)
         enddo
         leng(i) = dsimps(aux1,low,up,lim1)
        enddo
c
      do i=127,1,-1
c
c              e0(i-1)
c   leng(i) = INTEGRAL (dE/(dE/dx(E))) :
c              10 GeV
c
      leng(i) = leng(i) + leng(i+1)
c
c            e0(i-1)
c  eta(i) = INTEGRAL(dE/(dE/dx(E) * L_mean(E))) :
c            10 GeV
c
      eta(i) = eta(i) + eta(i+1)
      enddo
c
c   Auxiliary arrays a(128), b(128), e0(128), eta(128), leng(128)
c                    have been prepared.
c   ---------------------------------------------------------------
c                       2. Solving the equation (3)
c
c  to get the final energy E1 for a set of E0 ("e" variable) and
c                        ETA ("slu" variable):
c
      do i=-80,30             !--> 111 values of SLU (logarithmi-
        slu = dble(i) * 5.d-2 !    cally equidestant grid with
        slu = 1.d+1**slu      !    slu_min=0.0001, slu_max=1000
        do j=180,20,-1         !-> 161 values of E (logarithmi-
          e = dble(j) * 5.d-2  !   cally equidestant grid with
          e = 1.d+1**e         !   e_min = 10 GeV, e_max = 1 EeV
            if (e.le.1.011d+1) then
            ene = 1.0000001d+1
            path = 0.d+0
            goto 444
            endif
c        vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv
          me = idint( ( dlog(e) - dlog(1.d+9) ) / dlog(fk) ) + 1
c        ME is a number of segment which contains given energy E
c        ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
c                       Rewriting the equation (3) as
c
c                   E0         E0         E1
c                INTEGRAL = INTEGRAL - INTEGRAL = ETA  (3a)
c                   E1       10 GeV     10 GeV
c
c                                 or
c
c                     E1         E0
c                  INTEGRAL = INTEGRAL - ETA = ETA_1   (3b)
c                   10 GeV     10 GeV
c
            if (me.lt.128) then
            eta_1 = eta(me+1) - slu
            else
            eta_1 = (-1.d+0) * slu
            endif
        low = dlog(e0(me))
        up = dlog(e)
        lim1 = 10
        step1 = (up - low) / dble(lim1)
         do j1=0,lim1
         en = low + (dble(j1) * step1)
         h1 = sngl(dexp(en))
         help =(1./glbremvS(h1))+(1./glpairvS(h1))+(1./glphnuvS(h1)) +
     +           (1./glelecvS(h1))
         aux1(j1)=(1.d+0 / dble(help))*dble(convS(h1))*1.d-3/dble(h1)
         aux1(j1) = 1.d+0 / aux1(j1)
         enddo
         eta_1 = eta_1 + dsimps(aux1,low,up,lim1)
c---------------------------------
        if (eta_1.le.0.d+0) then !
        ene = 1.0000001d+1       !--> no interactions with energy transfers
        m1 = 128                 !              transfers > Vmin,
        goto 402                 !         the final energy is 10 GeV
        endif                    !
c---------------------------------
            m1 = 500
            do m=128,1,-1
              if (eta(m).ge.eta_1) then
              m1 = m
              goto 401
              endif
            enddo
          if (m1.ge.200) then
          hd3 = dabs((eta(1) - eta_1) / eta(1))
             if (hd3.le.1.d-6) then
             m1 = 1
             eta_1 = eta(1)*9.9999999d-1
             goto 401
             endif
          print*,'******** SUBROUTINE FREPATV:  ERROR !!!!! ********'
          goto 402
          endif
  401     continue
            if (m1.lt.128) then
            rest = eta_1 - eta(m1+1)
            else
            rest = eta_1
            endif
c
         ic = 0
         lim1 = 10
         ene = (e0(m1-1) + e0(m1)) * 5.d-1
         delta = e0(m1-1) - ene
         low = dlog(e0(m1))
 3333    up = dlog(ene)
         step1 = (up - low) / dble(lim1)
         do j1=0,lim1
         en = low + (dble(j1) * step1)
         h1 = sngl(dexp(en))
         help=(1./glbremvS(h1))+(1./glpairvS(h1))+(1./glphnuvS(h1)) +
     +           (1./glelecvS(h1))
         aux1(j1)=(1.d+0 / dble(help))*dble(convS(h1))*1.d-3/dble(h1)
         aux1(j1) = 1.d+0 / aux1(j1)
         enddo
         pat1 = dsimps(aux1,low,up,lim1)
         delta = 5.d-1 * delta
         ic = ic + 1
         if (pat1.le.rest) then
         ene = ene + delta
         else
         ene = ene - delta
         endif
         if (ic.eq.20) then
         goto 402
         endif
         goto 3333
 402     continue
c
c            Equation (3) has been solved., the root is ENE
c   ---------------------------------------------------------------
c            3. Computing of real free path from E0 to ENE:
c
c                            E0
c                  PATH = INTEGRAL [ dE/(dE/dx(E)) ] =
c                            ENE
c
c          E0                          ENE
c     = INTEGRAL [ dE/(dE/dx(E)) ] - INTEGRAL [ dE/(dE/dx(E)) ]
c        10 GeV                       10 GeV
c
      if (me.lt.128) then
        low = dlog(e0(me))
        up = dlog(e)
        lim1 = 10
        step1 = (up - low) / dble(lim1)
         do j2=0,lim1
         en = low + (dble(j2) * step1)
         h1 = sngl(dexp(en))
         aux1(j2) = dble(convS(h1)) * 1.d-3 / dble(h1)
         aux1(j2) = 1.d+0 / aux1(j2)
         enddo
         pat1 = dsimps(aux1,low,up,lim1) + leng(me+1)
      else
        low = dlog(e0(me))
        up = dlog(e)
        lim1 = 10
        step1 = (up - low) / dble(lim1)
         do j2=0,lim1
         en = low + (dble(j2) * step1)
         h1 = sngl(dexp(en))
         aux1(j2) = dble(convS(h1)) * 1.d-3 / dble(h1)
         aux1(j2) = 1.d+0 / aux1(j2)
         enddo
         pat1 = dsimps(aux1,low,up,lim1)
      endif
c
      if (m1.lt.128) then
        low = dlog(e0(m1))
        up = dlog(ene)
        lim1 = 10
        step1 = (up - low) / dble(lim1)
         do j2=0,lim1
         en = low + (dble(j2) * step1)
         h1 = sngl(dexp(en))
         aux1(j2) = dble(convS(h1)) * 1.d-3 / dble(h1)
         aux1(j2) = 1.d+0 / aux1(j2)
         enddo
         pat2 = dsimps(aux1,low,up,lim1) + leng(m1+1)
      else
        low = dlog(e0(m1))
        up = dlog(ene)
        lim1 = 10
        step1 = (up - low) / dble(lim1)
         do j2=0,lim1
         en = low + (dble(j2) * step1)
         h1 = sngl(dexp(en))
         aux1(j2) = dble(convS(h1)) * 1.d-3 / dble(h1)
         aux1(j2) = 1.d+0 / aux1(j2)
         enddo
         pat2 = dsimps(aux1,low,up,lim1)
      endif
      path = pat1 - pat2
c
c          The equation is solved, the root is PATH
c
  444 continue
      if (path.le.0.d+0) path = 1.d+0
      if (ene.le.1.00001d+1) ene = 9.999d+0
      path = path/slu
      ene = ene / e
      vpath(i+81,j-19) = sngl(path)
      vener(i+81,j-19) = sngl(ene)
        enddo
      enddo
c
      return
      end
****************************************************************************
* C.11S
         SUBROUTINE spl2_2S
*
      common /vrand1S/ vpath(111,161)
      common /vrand2S/ vener(111,161)
      common /vrand1_oS/ CPA(18419)
      common /vrand2_oS/ CEN(18419)
      common /vpath1S/ NX_1,NY_1,X0_1,SX_1,Y0_1,SY_1
      common /vpath2S/ NX_2,NY_2,X0_2,SX_2,Y0_2,SY_2
      DIMENSION D(130,180),FU(111,161),CU(18419)
      DIMENSION NXG(2),NYG(2),X0G(2),SXG(2),Y0G(2),SYG(2)
      DIMENSION IJ(2)
c
      data NXG/111,111/
      data NYG/161,161/
      data X0G/-4.,-4./
      data SXG/5.e-2,5.e-2/
      data Y0G/1.,1./
      data SYG/5.e-2,5.e-2/
      data IJ/18419,18419/
c
      do li=1,2     ! A cycle along all input arrays
      NX = NXG(li)  ! assigns values from corresonding arrais for numbers of
      NY = NYG(li)  ! values, steps and initial values
      X0 = X0G(li)  !
      SX = SXG(li)  !
      Y0 = Y0G(li)  !
      SY = SYG(li)  !
c
       if (li.eq.1) then
         NX_1 = NX     !-> number of X values
         NY_1 = NY     !-> number of Y values
         X0_1 = X0     !-> first value of X
         SX_1 = SX     !-> step by X
         Y0_1 = Y0     !-> first value of Y
         SY_1 = SY     !-> step by Y
       endif
c
       if (li.eq.2) then
         NX_2 = NX    !-> number of X values
         NY_2 = NY    !-> number of Y values
         X0_2 = X0    !-> first value of X
         SX_2 = SX    !-> step by X
         Y0_2 = Y0    !-> first value of Y
         SY_2 = SY    !-> step by Y
       endif
c
        do ki=1,NX                                ! Filling an auxiliary
           do kl=1,NY                              ! array FU by values
              if (li.eq.1) FU(ki,kl) = vpath(ki,kl) ! from input array
              if (li.eq.2) FU(ki,kl) = vener(ki,kl) ! (within a cycle by
c                                                  ! LI along all input
c                                                 ! arrays)
           enddo                                 !
        enddo                                   !
cccccccc 2019 - ATTENTION!
      I2=1
cccccccc
c-----------------------------------------------
      DO 1 J=1,NY                  !
      J2=J+2                       !
      DO 1 I=1,NX                  !
      I2=I+2                       !
1     D(I2,J2)=3.90625E-3*FU(I,J)  !
      J1=NY+1                      !
      J3=J2+1                      !
      J4=J3+1                      !
      DO 2 I=3,I2                  !
      A=D(I,3)                     !
      B=D(I,4)                     !---> Cooking splain coefficients
      D(I,2)=3.*(A-B)+D(I,5)       !     out of input array Nb. LI
      D(I,1)=3.*(D(I,2)-A)+B       !     and putting these splains
      A=D(I,J1)                    !     into 1-dimensional array
      B=D(I,J2)                    !                 CU
      D(I,J3)=3.*(B-A)+D(I,NY)     !
2     D(I,J4)=3.*(D(I,J3)-B)+A     !
      I1=NX+1                      !
      I3=I2+1                      !
      I4=I3+1                      !
      DO 3 J=1,J4                  !
      A=D(3,J)                     !
      B=D(4,J)                     !
      D(2,J)=3.*(A-B)+D(5,J)       !
      D(1,J)=3.*(D(2,J)-A)+B       !
      A=D(I1,J)                    !
      B=D(I2,J)                    !
      D(I3,J)=3.*(B-A)+D(NX,J)       !
3     D(I4,J)=3.*(D(I3,J)-B)+A         !
      DO 4 J=1,J2                        !
      J3=J+1                               !
      J4=J+2                                 !
      M=(J-1)*I2                               !
      DO 4 I=1,I2                                !
      I3=I+1                                       !
      I4=I+2                                         !
4     CU(M+I)=D(I,J)+D(I,J4)+D(I4,J)+D(I4,J4)+D(I3,J3)* !
     *100.-(D(I3,J)+D(I,J3)+D(I4,J3)+D(I3,J4))*10.      !
c--------------------------------------------------------
       ko = IJ(li)
       do ki=1,ko                            !
              if (li.eq.1) CPA(ki) = CU(ki)  ! Passing the values of splain
              if (li.eq.2) CEN(ki) = CU(ki)  ! coefficients form auxiliary
c                                            ! array CU to corresponding
c                                            ! output array Nb. LI
       enddo                                 !
      enddo
      RETURN
      END
****************************************************************************
* C.12S
       FUNCTION getlanrvS(X,Y)
*
       real*4 X,Y
       common /vrand1_oS/ C1(18419)
       common /vpath1S/ NX,NY,X0,SX,Y0,SY
c
      X_1=alog10(X)
      if ((X_1.lt.-4.0001).or.(X_1.gt.1.5001)) then
      print*,'ERROR IN FUNCTION GETLANRVS: RANDOM NB. IS OUT OF RANGE'
      endif
c
      Y_1=alog10(Y)
      if ((Y_1.lt..99999).or.(Y_1.gt.9.0001)) then
      print*,'ERROR IN FUNCTION GETLANRVS: MUON ENERGY IS OUT OF RANGE'
      endif
c
      A3=(X_1-X0)/SX
      B3=(Y_1-Y0)/SY
      M1=INT(A3+.5)
      M2=INT(B3+.5)
      M3=NX+2
      IF(M1.LT.0.OR.M1.GE.NX.OR.M2.LT.0.OR.M2.GE.NY) THEN
      PRINT 1,X_1,M1,Y_1,M2
      ENDIF
      A3=A3-M1
      B3=B3-M2
      M1=M2*M3+M1+1
      M2=M1+M3
      M3=M2+M3
      A2 = A3*A3 +.25
      B2 = B3*B3 +.25
      A1=A2-A3
      B1=B2-B3
      A3=A2+A3
      B3=B2+B3
      A2=2.-(A2+A2)
      B2=2.-(B2+B2)
      getlanrvS=(A1*C1(M1)+A2*C1(M1+1)+A3*C1(M1+2))*B1
     2      +(A1*C1(M2)+A2*C1(M2+1)+A3*C1(M2+2))*B2
     3      +(A1*C1(M3)+A2*C1(M3+1)+A3*C1(M3+2))*B3
      getlanrvS = getlanrvS * X
      RETURN
1     FORMAT('*MISTAKE*X=',D23.16,'MX=',I4,'Y=',D23.16,'MY=',I4)
      END
****************************************************************************
* C.13S
       FUNCTION geteranvS(X,Y)
*
       real*4 X,Y
       common /vrand2_oS/ C1(18419)
       common /vpath2S/ NX,NY,X0,SX,Y0,SY
c
      X_1=alog10(X)
      if ((X_1.lt.-4.0001).or.(X_1.gt.1.5001)) then
      print*,'ERROR IN FUNCTION GETERANVS: RANDOM NB. IS OUT OF RANGE'
      endif
c
      Y_1=alog10(Y)
      if ((Y_1.lt..99999).or.(Y_1.gt.9.0001)) then
      print*,'ERROR IN FUNCTION GETERANVS: MUON ENERGY IS OUT OF RANGE'
      endif
c
      A3=(X_1-X0)/SX
      B3=(Y_1-Y0)/SY
      M1=INT(A3+.5)
      M2=INT(B3+.5)
      M3=NX+2
      IF(M1.LT.0.OR.M1.GE.NX.OR.M2.LT.0.OR.M2.GE.NY) THEN
      PRINT 1,X_1,M1,Y_1,M2
      ENDIF
      A3=A3-M1
      B3=B3-M2
      M1=M2*M3+M1+1
      M2=M1+M3
      M3=M2+M3
      A2 = A3*A3 +.25
      B2 = B3*B3 +.25
      A1=A2-A3
      B1=B2-B3
      A3=A2+A3
      B3=B2+B3
      A2=2.-(A2+A2)
      B2=2.-(B2+B2)
      geteranvS=(A1*C1(M1)+A2*C1(M1+1)+A3*C1(M1+2))*B1
     2      +(A1*C1(M2)+A2*C1(M2+1)+A3*C1(M2+2))*B2
     3      +(A1*C1(M3)+A2*C1(M3+1)+A3*C1(M3+2))*B3
      RETURN
1     FORMAT('*MISTAKE*X=',D23.16,'MX=',I4,'Y=',D23.16,'MY=',I4)
      END
****************************************************************************
* C.14S
      function getebackS(e1,backl)
*
      real*8 fk,fk1,dlnmax,a(0:128),b(0:128),leng(0:128),e0(0:128)
      real*8 e,ene,rest,pat1,path
      real*4 e1,backl
      common /simv1S/ fk,fk1,dlnmax,a,b,leng,e0
c
          e = dble(e1)
          path = dble(backl)
          if (e.ge.1.d+9) then
          ene = 1.00001+9
          goto 1402
          endif
        me = idint( ( dlog(e) - dlnmax ) * fk1 )  + 1
        if (me.gt.128) me = 128
            if (me.lt.128) then
            pat1 = leng(me+1) + path
            else
            pat1 = path
            endif
c
            pat1=pat1+dlog((a(me)*e+b(me))/(a(me)*e0(me)+b(me)))/a(me)
c
            m1 = 500
            do m=128,1,-1
              if (leng(m).ge.pat1) then
              m1 = m
              goto 1401
              endif
            enddo
           if (m1.ge.200) then  ! -> ENE for given PATH is more
           ene = 1.00001d+9     !    than 1 EeV (out of reason-
           goto 1402            !     able range) - let it be
           endif                !           just 1 EeV
 1401       continue
            if (m1.lt.128) then
            rest = pat1 - leng(m1+1)
            else
            rest = pat1
            endif
c
          ene = ((a(m1)*e0(m1)+b(m1))*dexp(rest*a(m1))-b(m1))/a(m1)
 1402     continue
          getebackS = sngl(ene)
      return
      end
c
****************************************************************************
* C.17S
       function enewS(e,depth,iti,itime)
*
       external getlanrvS,geteranvS,getebackS,gdedelt2S,convS
       external glpairvS,glbremvS,glphnuvS,glelecvS,simps,dsimpS
       real*8 rvec_own,eta,e0,pat,ddepth,e1d,pat1,pat2
       real*8 tlife,treal,tcum,time,time1,dta,deltat
       real*8 dsimps,low3,up3,step3,edur,aux2(0:1000)
       real*8 alfa,rm_e,rm_mu,r_e,avog
       real*8 spli
       real*8 TIME_L_T
       real*8 ttauin,ttauout
       real*4 e,depth
       integer iti,itime
       integer kindlept
       integer MODE
       integer MEDIUM
       integer i_stat(6)
       dimension aux1(0:30)
       dimension ityp(10000),eleng(10000),ener1(10000),ener2(10000)
       COMMON /MATTERS/ MEDIUM
       COMMON /TAU_DECAYS/ TIME_L_T,MODE
       common /constS/ alfa,rm_e,rm_mu,r_e,avog
       common /what_lepS/ kindlept
       common /const_tS/ tlife
       common /vhistoryS/ numb,ityp,eleng,ener1,ener2
c       common /r48/ rvec
       common /timetauS/ ttauin,ttauout
       common /statistic/ i_stat
       parameter (itra=1)
c       parameter (len=1)
c                     light velocity, cm/sec:
       parameter (spli=2.99792458d+10)
c
       i_stat(4) = i_stat(4) + 1
      if (
     +         (i_stat(1).eq.0).AND.
     +         (i_stat(2).eq.0).AND.
     +         (i_stat(3).eq.0).AND.
     +         (i_stat(4).eq.1).AND.
     +         (i_stat(5).eq.0).AND.
     +         (i_stat(6).eq.0)
     +   ) then
            write(*,*) 'Initialization successful, running...'
      endif
      enewS=1.e+20
c
c        Let's check if input is within alowed range;
c
       if (depth.gt.1.0001e+7) then
       print*,'FUNCTION ENEWS: INPUT VALUE FOR DEPTH ',depth,' cm'
       print*,'           IS TOO LARGE, WILL NOT WORK'
       return
       endif
c
       if ((e.gt.1.0001e+9).or.(e.lt..16)) then
       print*,'FUNCTION ENEWS: INPUT VALUE FOR ENERGY ',e,' GeV'
       print*,'          IS OUT OF RANGE, WILL NOT WORK'
       return
       endif
c
       if(kindlept.eq.1) then
c
******************** MUON: ************************************
c
       if(e.le.1.e+1) then !-> muon energy is less than 10 GeV
c -----------------------
       numb = 1         !
       ityp(numb) = 0   !
       eleng(numb) = 0. !-> Tracking simulation history
       ener1(numb) = e  !
       ener2(numb) = e  !
c------------------------
       el = e
       rest = depth
       pat = 0.d+0
       goto 4321
       endif
c -----------------------
       numb = 1         !
       ityp(numb) = 0   !
       eleng(numb) = 0. !-> Tracking simulation history
       ener1(numb) = e  !
       ener2(numb) = e  !
c------------------------
       ddepth = dble(depth)
       e0 = dble(e)
       pat = 0.d+0
    1  call rm48_own(rvec_own)
       eta = -dlog(rvec_own)   !---> Simulation of random number
       if(eta.ge.3.16d+1) eta = 3.16d+1
       slu = sngl(eta)
       e0_sn = sngl(e0)
       if (slu.ge.1.e-4) then
       preal = getlanrvS(slu,e0_sn)  !-> getting the real free path
       e1d = e0 * dble(geteranvS(slu,e0_sn)) !-> getting muon energy
c                                               at the end of free
c                                               path
       else
        preal = 0.  !--> simulated free path is too small, let
        e1d = e0    !    it be equal to zero...
       endif
        e1 = sngl(e1d)
c
       pat = pat + dble(preal)
       rest = sngl(ddepth - pat)
         if (rest.lt.0.) then   !-> muon has passed the DEPTH,
           rest = -rest           !
           if (rest.lt.1.) rest=1.  !  Computing its "back" energy
           if (e1.lt.10.) e1 = 10.   ! at the DEPTH and return...
           enewS = getebackS(e1,rest)  !
c-------------------------------
           numb = numb + 1     !
           ityp(numb) = 1      !-> Tracking
           eleng(numb) = depth ! simulation
           ener1(numb) = enewS  !  history
           ener2(numb) = enewS  !
c------------------------------
           return
         endif
c
         if (e1.le.1.e+1) then  !-> muon energy at the end of free
           el = 10.             !   path is less than 10 GeV (MUM..
c-----------------------------------                             .
           numb = numb + 1         !-> tracking                .
           ityp(numb) = 3          ! simulation              .
           eleng(numb) = sngl(pat) !  history              .
           ener1(numb) = el        !                    .
           ener2(numb) = el        !                 .
c---------------------------------...................
           goto 4321            ! ..does not compute some "catastrophic"
         endif                  !   losses below 10 GeV, jump to the
c                               !   label 4321 to go the rest of DEPTH
c                               !   with "continuous" losses only...
c
       pb = 1./glbremvS(e1)        !-> Computing of "weight" for different
       pp = pb + 1./glpairvS(e1)   !   interactions at current muon energy.
       pn = pp + 1./glphnuvS(e1)   !
       pt = pn + 1./glelecvS(e1)   !
       ranp = rndm_mum(5) * pt  ! -> Simulation of interaction type
       numb = numb + 1 !-> tracking simulation history
       if(ranp.le.pb) then        !-> type was simulated as bremsstrahlung,
       call getvbremS(e1,v,itra)
c                              !_>   simulate rel. energy transfer
       ityp(numb) = 4 !-> tracking simulation history
       else
          if(ranp.le.pp) then      !-> type was simulated as e+e- pair,
          call getvpaS(e1,v,itra)
c                               !_>  simulate rel. energy transfer
          ityp(numb) = 5 !-> tracking simulation history
          else
              if (ranp.le.pn) then   !-> type was simulated as photonuc.,
              call getvphS(e1,v,itra)
c                                   !_>  simulate rel. energy transfer
              ityp(numb) = 6 !-> tracking simulation history
              else
              call getvelS(e1,v,itra)
c                                   !_> type was simulated as knock-on
c                                   !  electron, simulate en. transfer
              ityp(numb) = 7 !-> tracking simulation history
              endif
           endif
        endif
        e2 = e1 * ( 1. - v ) ! -> The energy after interaction
c-----------------------------------
           eleng(numb) = sngl(pat) !
           ener1(numb) = e1        !-> tracking simulation history
           ener2(numb) = e2        !
c-----------------------------------
          if (e2.le.10.) then
             if (e2.le..16) then !-> the muon stops (energy is below
                 enewS = 1.e-2    !   the Cherenkov threshold in water)
c----------------------------------------
                 numb = numb + 1         !
                 ityp(numb) = 2          !-> tracking simulation history
                 eleng(numb) = sngl(pat) !
                 ener1(numb) = enewS      !
                 ener2(numb) = enewS      !
c---------------------------------------
                 return          !   Assigne ENEWS = 0.01 and return...
             else
                 el=e2     !-> muon has not stopped but its energy is
                 goto 4321 !   less than 10 GeV. Jump to label 4321...
             endif
          else
             e0 = dble(e2)  !-> muon enrgy is above 10 GeV. Jump to
             goto 1         !   label 1 to repeat everything once
          endif             !          again...
c
c  Muon energy becomes less than 10 GeV. Compute the rest of its
c          travel with continuous losses only:
c
 4321   lim1 = 30
        elow = alog(1.6e-1)
        up = alog(el)
        step1 = (up - elow) / float(lim1)
         do j1=0,lim1
         en = elow + (float(j1) * step1)
         h1 = exp(en)
         aux1(j1) = h1 * 1.e+3 / gdedelt2S(h1)
         enddo
         pat1 = simps(aux1,elow,up,lim1)
         if (pat1.lt.rest) then            ! Muon energy becomes < 0.16
         enewS = 1.e-2                      ! GeV before it reaches DEPTH
c-----------------------------------------------
         numb = numb + 1                       !
         ityp(numb) = 2                        !-> tracking simulation
         eleng(numb) = sngl(pat + dble(pat1))  !     history
         ener1(numb) = enewS                    !
         ener2(numb) = enewS                    !
c-----------------------------------------------
         return                            ! ENEWS = 0.01 GeV and return...
         endif
c-------------------------------------------
         ic = 0                            ! Iteration procedure to
         ene = (el + 1.59999e-1) * 5.e-1   ! obtain muon energy at
         delta = el - ene                  ! the DEPTH if his start
 3333    elow = alog(ene)                   ! energy is less than
         step1 = (up - elow) / float(lim1)   ! 10 GeV (without "ca-
         do j1=0,lim1                         ! tastrophic" part)
         en = elow + (float(j1) * step1)      !
         h1 = exp(en)                         !
         aux1(j1) = h1 * 1.e+3 / gdedelt2S(h1) !
         enddo                                !
         pat1 = simps(aux1,elow,up,lim1)    !
         delta = 5.e-1 * delta            !
         ic = ic + 1                    !
         if (pat1.eq.rest) then       !-> it seems incredible but
         enewS = ene                   !   sometimes it occures...
c ----------------------------              !
         numb = numb + 1     !                      !
         ityp(numb) = 1      !-> tracking simulation  !
         eleng(numb) = depth !    history            !
         ener1(numb) = enewS  !                   !
         ener2(numb) = enewS  !               !
c ----------------------------          !
         return                        !
         endif                        !
         if (pat1.le.rest) then      !
         ene = ene - delta            !
         else                           !
         ene = ene + delta               !
         endif                            !
         if (ic.eq.14) then                !
         enewS = ene                         ! -> We found ENEWS
c ----------------------------                  !     and finish...
         numb = numb + 1     !                      !
         ityp(numb) = 1      !-> tracking simulation  !
         eleng(numb) = depth !    history            !
         ener1(numb) = enewS  !                   !
         ener2(numb) = enewS  !               !
c ----------------------------          !
         return                     !
         endif                   !
         goto 3333            !
c----------------------------
       else
******************** TAU: ************************************
c
       if(itime.lt.0) then
         CALL DECAY_MODES
c                       !__> Simulation of tau life time (sec)
         treal = TIME_L_T
       else
         treal = ttauin
       endif
c
c  If working in water equivalent units increase TREAL proportionally
c                           to density:
c
       IF(MEDIUM.EQ.-1)  treal = treal * 1.00000d+0
       IF(MEDIUM.EQ.-2)  treal = treal * 2.65000d+0
       IF(MEDIUM.EQ.-3)  treal = treal * 0.92000d+0
       IF(MEDIUM.EQ.-4)  treal = treal * 1.02700d+0
       IF(MEDIUM.EQ.-5)  treal = treal * 1.03410d+0
       IF(MEDIUM.EQ.-6)  treal = treal * 1.03975d+0
       IF(MEDIUM.EQ.-7)  treal = treal * 2.71000d+0
       IF(MEDIUM.EQ.-8)  treal = treal * 2.90000d+0
       IF(MEDIUM.EQ.-9)  treal = treal * 2.48100d+0
       IF(MEDIUM.EQ.-10) treal = treal * 2.10300d+0
       IF(MEDIUM.EQ.-11) treal = treal * 1.69800d+0
       IF(MEDIUM.EQ.-12) treal = treal * 2.74000d+0
       IF(MEDIUM.EQ.-13) treal = treal * 2.74000d+0
c
       if(iti.eq.1) then
c --------------------------
       numb = 1            !
       ityp(numb) = 0      !
       eleng(numb) = 0.    !-> Tracking simulation history
       ener1(numb) = e     !
       ener2(numb) = e     !
       edelen = 1.e+3 * sngl( treal * (dble(e)/rm_mu) * spli )  !
       numb = 2                   !------------------------------
         if(edelen.gt.depth) then !
           ityp(numb) = 1         !
           eleng(numb) = depth    !
           enewS = e              !
           ener1(numb) = e        !
           ener2(numb) = e        !-----------------------------
           ttauout = treal * dble( (edelen - depth) / edelen ) !
           IF(MEDIUM.EQ.-1)  ttauout = ttauout / 1.00000d+0    !
           IF(MEDIUM.EQ.-2)  ttauout = ttauout / 2.65000d+0    !
           IF(MEDIUM.EQ.-3)  ttauout = ttauout / 0.92000d+0    !
           IF(MEDIUM.EQ.-4)  ttauout = ttauout / 1.02700d+0    !
           IF(MEDIUM.EQ.-5)  ttauout = ttauout / 1.03410d+0    !
           IF(MEDIUM.EQ.-6)  ttauout = ttauout / 1.03975d+0    !
           IF(MEDIUM.EQ.-7)  ttauout = ttauout / 2.71000d+0    !
           IF(MEDIUM.EQ.-8)  ttauout = ttauout / 2.90000d+0    !
           IF(MEDIUM.EQ.-9)  ttauout = ttauout / 2.48100d+0    !
           IF(MEDIUM.EQ.-10) ttauout = ttauout / 2.10300d+0    !
           IF(MEDIUM.EQ.-11) ttauout = ttauout / 1.69800d+0    !
           IF(MEDIUM.EQ.-12) ttauout = ttauout / 2.74000d+0    !
           IF(MEDIUM.EQ.-13) ttauout = ttauout / 2.74000d+0    !
         else                     !-----------------------------
           ityp(numb) = 8         !
           eleng(numb) = edelen   !
           enewS = 1.e-2          !
           ener1(numb) = e        !
           ener2(numb) = 1.e-2    !
           ttauout = -1.d+0       !
         endif             !------
       return              !
       endif               !
c--------------------------
       tcum = 0.0d+0
       if(e.le.1.e+1) then !-> tau energy is less than 10 GeV
c --------------------------
       numb = 1            !
       ityp(numb) = 0      !
       eleng(numb) = 0.    !-> Tracking simulation history
       ener1(numb) = e     !
       ener2(numb) = e     !
       numb = 2            !
       ityp(numb) = 8      !
       eleng(numb) = 0.1   !
       ener1(numb) = e     !
       ener2(numb) = 1.e-2 !
c---------------------------
       enewS= 1.e-2
       ttauout = -1.d+0
       return
       endif
c -----------------------
       numb = 1         !
       ityp(numb) = 0   !
       eleng(numb) = 0. !-> Tracking simulation history
       ener1(numb) = e  !
       ener2(numb) = e  !
c------------------------
       ddepth = dble(depth)
       e0 = dble(e)
       pat = 0.d+0
   11  call rm48_own(rvec_own)
       eta = -dlog(rvec_own)   !---> Simulation of random number
       if(eta.ge.3.16d+1) eta = 3.16d+1
       slu = sngl(eta)
       e0_sn = sngl(e0)
       if (slu.ge.1.e-4) then
       preal = getlanrvS(slu,e0_sn)  !-> getting the real free path
       e1d = e0 * dble(geteranvS(slu,e0_sn)) !-> getting tau energy
c                                               at the end of free
c                                               path
       else
        preal = 0.  !--> simulated free path is too small, let
        e1d = e0    !    it be equal to zero...
       endif
        e1 = sngl(e1d)
c
       pat1 = pat
       pat = pat + dble(preal)
       rest = sngl(ddepth - pat)
         if (rest.lt.0.) then   !-> tau has passed the DEPTH,
           rest = -rest           !
           if (rest.lt.1.) rest=1.  !  Computing its "back" energy
           if (e1.lt.10.) e1 = 10.   ! at the DEPTH and return...
           enewS= getebackS(e1,rest)  !
******************
         low3 = dlog(dble(enewS))
         up3 = dlog(e0)
         qqee = (sngl(up3 - low3))*7.e+0
         lim3 = (int(qqee) + 1) * 2
         step3 = (up3 - low3) / dble(lim3)
         do j=0,lim3
         edur = low3 + (dble(j) * step3)
         h1 = sngl(dexp(edur))
         aux2(j) = rm_mu / (spli * dble(convS(h1)))
         enddo
         time = dsimps(aux2,low3,up3,lim3)
******************
         tcum = tcum + time
         if(tcum.ge.treal) then
         e1 = enewS
         deltat = treal - tcum + time
         goto 98789               !---> decay before
         endif                    !  reaching DEPTH
c-------------------------------
           numb = numb + 1     !
           ityp(numb) = 1      !-> Tracking
           eleng(numb) = depth ! simulation
           ener1(numb) = enewS !  history
           ener2(numb) = enewS !
c------------------------------
           ttauout = treal - tcum
           IF(MEDIUM.EQ.-1)  ttauout = ttauout / 1.00000d+0
           IF(MEDIUM.EQ.-2)  ttauout = ttauout / 2.65000d+0
           IF(MEDIUM.EQ.-3)  ttauout = ttauout / 0.92000d+0
           IF(MEDIUM.EQ.-4)  ttauout = ttauout / 1.02700d+0
           IF(MEDIUM.EQ.-5)  ttauout = ttauout / 1.03410d+0
           IF(MEDIUM.EQ.-6)  ttauout = ttauout / 1.03975d+0
           IF(MEDIUM.EQ.-7)  ttauout = ttauout / 2.71000d+0
           IF(MEDIUM.EQ.-8)  ttauout = ttauout / 2.90000d+0
           IF(MEDIUM.EQ.-9)  ttauout = ttauout / 2.48100d+0
           IF(MEDIUM.EQ.-10) ttauout = ttauout / 2.10300d+0
           IF(MEDIUM.EQ.-11) ttauout = ttauout / 1.69800d+0
           IF(MEDIUM.EQ.-12) ttauout = ttauout / 2.74000d+0
           IF(MEDIUM.EQ.-13) ttauout = ttauout / 2.74000d+0
           return
         endif
c
         if (e1.le.1.e+1) then  !-> tau energy =< 10 GeV
******************
         e1 = 1.e+1
         pat = pat1
         low3 = dlog(dble(e1))
         up3 = dlog(e0)
         qqee = (sngl(up3 - low3))*7.e+0
         lim3 = (int(qqee) + 1) * 2
         step3 = (up3 - low3) / dble(lim3)
         do j=0,lim3
         edur = low3 + (dble(j) * step3)
         h1 = sngl(dexp(edur))
         aux2(j) = 1.d+3 * (dexp(edur) / dble(convS(h1)))
         enddo
         pat2 = dsimps(aux2,low3,up3,lim3)
******************
         pat = pat + pat2
******************
         low3 = dlog(dble(e1))
         up3 = dlog(e0)
         qqee = (sngl(up3 - low3))*7.e+0
         lim3 = (int(qqee) + 1) * 2
         step3 = (up3 - low3) / dble(lim3)
         do j=0,lim3
         edur = low3 + (dble(j) * step3)
         h1 = sngl(dexp(edur))
         aux2(j) = rm_mu / (spli * dble(convS(h1)))
         enddo
         time = dsimps(aux2,low3,up3,lim3)
******************
         tcum = tcum + time
         if(tcum.ge.treal) then
         deltat = treal - tcum + time
         goto 98789           !---> decay before
         endif                !     reaching depth
c-----------------------------------                             .
           numb = numb + 1         !-> tracking                .
           ityp(numb) = 8          ! simulation              .
           eleng(numb) = sngl(pat) !  history              .
           ener1(numb) = e1        !                    .
           ener2(numb) = 1.e-2     !                 .
c-----------------------------------...................
           enewS= 1.e-2
           ttauout = -1.d+0
           return
         endif
******************
         low3 = dlog(dble(e1))
         up3 = dlog(e0)
         qqee = (sngl(up3 - low3))*7.e+0
         lim3 = (int(qqee) + 1) * 2
         step3 = (up3 - low3) / dble(lim3)
         do j=0,lim3
         edur = low3 + (dble(j) * step3)
         h1 = sngl(dexp(edur))
         aux2(j) = rm_mu / (spli * dble(convS(h1)))
         enddo
         time = dsimps(aux2,low3,up3,lim3)
******************
         tcum = tcum + time
         if(tcum.ge.treal) then
         deltat = treal - tcum + time
         goto 98789 !---> decay before
         endif
c
       pb = 1./glbremvS(e1)        !-> Computing of "weight" for different
       pp = pb + 1./glpairvS(e1)   !   interactions at current tau energy.
       pn = pp + 1./glphnuvS(e1)   !
       pt = pn + 1./glelecvS(e1)   !
       ranp = rndm_mum(5) * pt  ! -> Simulation of interaction type
       numb = numb + 1 !-> tracking simulation history
       if(ranp.le.pb) then        !-> type was simulated as bremsstrahlung,
       call getvbremS(e1,v,itra)
c                              !_>  simulate rel. energy transfer
       ityp(numb) = 4 !-> tracking simulation history
       else
          if(ranp.le.pp) then      !-> type was simulated as e+e- pair,
          call getvpaS(e1,v,itra)
c                               !_> simulate rel. energy transfer
          ityp(numb) = 5 !-> tracking simulation history
          else
              if (ranp.le.pn) then   !-> type was simulated as photonuc.,
              call getvphS(e1,v,itra)
c                                   !_>  simulate rel. energy transfer
              ityp(numb) = 6 !-> tracking simulation history
              else
              call getvelS(e1,v,itra)
c                                   !_> type was simulated as knock-on
c                                   !  electron, simulate en. transfer
              ityp(numb) = 7 !-> tracking simulation history
              endif
           endif
        endif
        e2 = e1 * ( 1. - v ) ! -> The energy after interaction
c-----------------------------------
           eleng(numb) = sngl(pat) !
           ener1(numb) = e1        !-> tracking simulation history
           ener2(numb) = e2        !
c-----------------------------------
          if (e2.le.10.) then
c----------------------------------------------
                 numb = numb + 1               !
                 ityp(numb) = 8                !-> tracking simulation history
                 eleng(numb) = sngl(pat+1.d+0) !
                 ener1(numb) = e2              !
                 ener2(numb) = 1.e-2           !
c----------------------------------------------
                 enewS= 1.e-2
                 ttauout = -1.d+0
                 return
          else
             e0 = dble(e2)  !-> tau energy is above 10 GeV. Jump to
             goto 11        !   label 11 to repeat everything once
          endif             !          again...
c
98789    continue
         if(e1.le.1.e+1) e1=1.e+1
         iiik = 1
         dta = dlog(dble(e0/e1))
******************
         low3 = dlog(dble(e1))
13333    continue
         iiik = iiik + 1
         dta = dta * .5d+0
         up3 = dlog(e0)
         qqee = (sngl(up3 - low3))*7.e+0
         lim3 = (int(qqee) + 1) * 2
         step3 = (up3 - low3) / dble(lim3)
         do j=0,lim3
         edur = low3 + (dble(j) * step3)
         h1 = sngl(dexp(edur))
         aux2(j) = rm_mu / (spli * dble(convS(h1)))
         enddo
         time1 = dsimps(aux2,low3,up3,lim3)
******************
         if(time1.ge.deltat) then
           low3 = low3 + dta
         else
           low3 = low3 - dta
         endif
         if(iiik.le.27) goto 13333
         e1 = sngl(dexp(low3))
******************
         pat = pat1
         low3 = dlog(dble(e1))
         up3 = dlog(e0)
         qqee = (sngl(up3 - low3))*7.e+0
         lim3 = (int(qqee) + 1) * 2
         step3 = (up3 - low3) / dble(lim3)
         do j=0,lim3
         edur = low3 + (dble(j) * step3)
         h1 = sngl(dexp(edur))
         aux2(j) = 1.d+3 * (dexp(edur) / dble(convS(h1)))
         enddo
         pat2 = dsimps(aux2,low3,up3,lim3)
******************
         pat = pat + pat2
c-----------------------------------------
                 numb = numb + 1         !
                 ityp(numb) = 8          !-> tracking simulation
                 eleng(numb) = sngl(pat) !     history
                 ener1(numb) = e1        !
                 ener2(numb) = 1.e-2     !
c-----------------------------------------
          enewS= 1.e-2
          ttauout = -1.d+0
          return
         endif
      return
      end
****************************************************************************
* C.18S
      subroutine simuldeS(ndepths,emu0)
*
       external enewS,simps,gdedelt2S,getebackS
       dimension ityp(10000),eleng(10000),ener1(10000),ener2(10000)
       dimension aux1(0:30)
       real*4 emu0
       integer ndepths
       integer kindlept
       common /vhistoryS/ numb,ityp,eleng,ener1,ener2
       common /frouser1S/ horison(1000)
       common /touser1S/ emuon(1000)
       common /what_lepS/ kindlept
c
       iti = 0
       itime = -1
       emuon(ndepths) = enewS(emu0,horison(ndepths),iti,itime)
       numfirst = 2
       do i=1,ndepths-1 !--> cicle along levels of observation
c---------------------------------------------
         if (eleng(numb).lt.horison(i)) then !-> muon has died before
           emuon(i) = 1.e-2                  !   given level of
           goto 1                            !    observation...
         else                                !
c---------------------------------------------
           do j=numfirst,numb  !-> cicle along muon history
c----------------------------------------------
             if (eleng(j).ge.horison(i)) then !-> we found the first event
             numfirst = j                   ! in muon history (starting with
c                                         ! less depth) whose depth is more
c                                       ! than given level of observation
c----------------------------------------
              if((ityp(j).ge.3).and.(ityp(j).lt.8)) then !-> the nearest
                     diffl = eleng(j) - horison(i)       ! event is either
                        if (diffl.le.1.) then            ! brem, pn, e+e-,
                        emuon(i) = ener1(j)              ! knock-on e in-
                        goto 1                           ! teraction or
                        endif                            ! 10 GeV level
                     emuon(i) = getebackS(ener1(j),diffl)!
                     goto 1                              !
                  else                                   !
c
                     if (ityp(j).eq.1) then                     !-> muon
                         if (ener1(j).ge.10.) then              ! has reached
                           diffl = eleng(j) - horison(i)        ! the maximum
                             if (diffl.le.1.) then              ! depth and
                             emuon(i) = ener1(j)                ! E_mu > 10 GeV
                             goto 1                             !
                             endif                              !
                           emuon(i) = getebackS(ener1(j),diffl) !
                           goto 1                               !
                         else
                           goto 2  !-> the nearest event is either maximum
                         endif     !    depth with E_mu < 10 GeV or death
                     else          !    of muon (E_mu < 0.16 GeV)
                         goto 2    !
                     endif         !
                  endif            !
             else
             goto 3 !-> continue to search for the first event in muon history
             endif
c
 2           continue
c
             if(kindlept.ne.1) then !---------> TAU-lepton
             diffl = eleng(j) - horison(i)
             ecucuc = ener1(j)
             if(ener1(j).le.1.e+1) ecucuc = 1.0001e+1
             emuon(i) = getebackS(ecucuc,diffl)
             goto 1
             endif
c
             lim1 = 30  !-------------------------!
             rest = eleng(j) - horison(i)         !
                if (rest.le.1.) then              !
                emuon(i) = ener1(j)               !
                goto 1                            !
                endif                             !
             ic = 0                               ! Iteration procedure to
             efin = ener1(j)                      ! obtain muon energy
             if (efin.le..15) efin = .16         !  at the level of observation
             ene = (efin + ener2(j-1)) * 5.e-1  !  if its energy at the nearest
             delta = ene - efin                !    event after level of obser-
             elow = alog(efin)                  !   vation is less than 10 GeV
 3333        up = alog(ene)                      !
             step1 = (up - elow) / float(lim1)    !
               do j1=0,lim1                       !
                 en = elow + (float(j1) * step1)   !
                 h1 = exp(en)                        !
                 aux1(j1) = h1 * 1.e+3 / gdedelt2S(h1) !
               enddo                               !
             pat1 = simps(aux1,elow,up,lim1)   !
             delta = 5.e-1 * delta         !
             ic = ic + 1                !
               if (pat1.eq.rest) then !-> It seems incredible but sometimes
               emuon(i) = ene         !      it occures ...
               goto 1                 !
               endif                  !_________
               if (pat1.le.rest) then           !
                 ene = ene + delta             !
               else                           !
                 ene = ene - delta           !
               endif                        !
               if (ic.eq.14) then          !
                 emuon(i) = ene           ! -> We found EMUON(I)
                 goto 1                  !
               endif                    !
             goto 3333                 !
    3      continue  !----------------!
           enddo
         endif
    1  continue
       enddo
      return
      end
****************************************************************************
c C.28S
c
      SUBROUTINE PREPARE_DECAYS
c
c   Cooking array TIMP(22) with partial life times of tau-lepton for 22
c                    the most important decay modes
c
      DOUBLE PRECISION TLIFE,XX
      DIMENSION TIMP(22)
      DIMENSION DMOD(22)
      COMMON /PARTIS/ TIMP
      COMMON /CONST_TS/ TLIFE
c
      DO I=1,22
      DMOD(I) = 1.00000
      ENDDO
c
      DO I = 1,22
c                            BR. RATIO         DECAY MODE            NUMBER
c                         (norm to e mode)         |       (in TAUOLA style)
c                                |                 |                     |
c                                V                 V                     V
        IF(I.EQ. 1) DMOD(I) = 1.00000 ! TAU-+  -->  E-+                  1
        IF(I.EQ. 2) DMOD(I) = 0.97980 ! TAU-+  -->  MU-+                 2
        IF(I.EQ. 3) DMOD(I) = 0.64960 ! TAU-+  -->  PI-+                 3
        IF(I.EQ. 4) DMOD(I) = 1.3405  ! TAU-+  -->  PI-+    PI0          4
        IF(I.EQ. 5) DMOD(I) = 0.7215  ! TAU-+  -->  A1-+ (two subch)     5
        IF(I.EQ. 6) DMOD(I) = 0.0397  ! TAU-+  -->  K-+                  6
        IF(I.EQ. 7) DMOD(I) = 0.0696  ! TAU-+  -->  K*-+ (two subch)     7
        IF(I.EQ. 8) DMOD(I) = 0.0835  ! TAU-+  -->  2PI-+   PI0    PI+-  8
        IF(I.EQ. 9) DMOD(I) = 0.0170  ! TAU-+  -->  3PI0    PI-+         9
        IF(I.EQ.10) DMOD(I) = 0.0641  ! TAU-+  -->  2PI-+   PI+-   2PI0  10
        IF(I.EQ.11) DMOD(I) = 0.0286  ! TAU-+  -->  3PI-+   2PI+-        11
        IF(I.EQ.12) DMOD(I) = 0.0043  ! TAU-+  -->  3PI-+   2PI+-  PI0   12
        IF(I.EQ.13) DMOD(I) = 0.0042  ! TAU-+  -->  2PI-+   PI+-   3PI0  13
        IF(I.EQ.14) DMOD(I) = 0.0061  ! TAU-+  -->  K-+     PI-+   K+-   14
        IF(I.EQ.15) DMOD(I) = 0.0056  ! TAU-+  -->  K0      PI-+   K0B   15
        IF(I.EQ.16) DMOD(I) = 0.0005  ! TAU-+  -->  K-+     K0     PI0   16
        IF(I.EQ.17) DMOD(I) = 0.0059  ! TAU-+  -->  PI0     PI0    K-+   17
        IF(I.EQ.18) DMOD(I) = 0.0321  ! TAU-+  -->  K-+     PI-+   PI+-  18
        IF(I.EQ.19) DMOD(I) = 0.0320  ! TAU-+  -->  PI-+    K0B    PI0   19
        IF(I.EQ.20) DMOD(I) = 0.0110  ! TAU-+  -->  ETA     PI-+   PI0   20
        IF(I.EQ.21) DMOD(I) = 0.0031  ! TAU-+  -->  PI-+    PI0    GAM   21
        IF(I.EQ.22) DMOD(I) = 0.0181  ! TAU-+  -->  K-+     K0           22
      ENDDO
c
      XX = 0.d+0
        DO I=1,22
          XX = XX + DBLE(DMOD(I))
        ENDDO
        DO I=1,22
          TIMP(I) = ( SNGL(XX) / DMOD(I) ) * SNGL(TLIFE)
        ENDDO
c
       RETURN
       END
****************************************************************************
c C.29
c
      SUBROUTINE DECAY_MODES
c
c Generation of tau-lepton life time (DOUBLE PRECISION TIME_L_T) and decay
c        mode (INTEGER MODE) to be passed to ENEW(S,3,4) routines.
      DOUBLE PRECISION RVEC_OWN,TREAL1, TREAL,TIME_L_T
      INTEGER MODE
      DIMENSION TIMP(22)
      COMMON /PARTIS/ TIMP
      COMMON /TAU_DECAYS/ TIME_L_T,MODE
c
      TREAL = 1.D+1
        DO J=1,22
          CALL rm48_own(rvec_own)
          TREAL1 = (-DLOG(RVEC_OWN)) * DBLE(TIMP(J))
            IF(TREAL1.LE.TREAL) THEN
              TREAL = TREAL1
              MODE = J
            ENDIF
        ENDDO
        TIME_L_T = TREAL
c
      RETURN
      END
****************************************************************************
************************ BREMSSTRAHLUNG SUBROUTINES : **********************
****************************************************************************
* B.1S
*
       real*8 function bremS(z,en,rnu)
       external fu1S,fu2S
       real*8 fu1S,fu2S
       real*8 z,en,rnu,rnu1
       real*8 alfa,rm_e,rm_mu,r_e,fact,a1,a2,del1,del2,x1,x2,ulim,avog
       real*8 eln1,eln2,psi10,psi20,psi1,psi2,z13,z23,qc,dze,q_min,h1
       common /exer1S/ fa
       common /constS/ alfa,rm_e,rm_mu,r_e,avog
c
      fact=((4.d+0*z*z*r_e*r_e*rm_e*rm_e)/(rm_mu*rm_mu))*alfa
      rnu1=1.d+0-rnu
      z13=z**(1.d+1/3.d+1)
      z23=z13*z13
ccc      qc=(1.9d+0*rm_mu)/z13
      qc=(1.9d+0*1.0565932d+2)/z13
      dze=sqrt(1.d+0+((4.d+0*rm_mu*rm_mu)/(qc*qc)))
      a1 = 1.117d+2/(z13*rm_e)
      a2 = 7.242d+2/(z23*rm_e)
      del1=dlog(rm_mu/qc)+((dze/2.d+0)*dlog((dze+1.d+0)/(dze-1.d+0)))
      del2=dlog(rm_mu/qc)+((2.d+0*rm_mu*rm_mu)/(qc*qc))
      del2 = del2+((dze/4.d+0)*(3.d+0-(dze*dze))*dlog((dze+1.d+0)/(dze-1
     *.d+0)))
      if (z.le.1.5d+0) then !
      del1=0.d+0            !-> there is no corrections due to nuclear
      del2=0.d+0            !   form-factor for hydrogen
      endif                 !
      q_min=((rnu/rnu1)*rm_mu*rm_mu*5.d-1)/(en*1.d+3)
      x1 = a1 * q_min
      x2 = a2 * q_min
c
        ulim=((z)**(1.d+0/3.d+0))*1.236540953d+0*(rm_mu/(en*1.d+3))
        ulim = 1.d+0 - ulim
c
        if (ulim.lt.rnu) then   !  if input energy transfer is greater than
        k1=0                    !  upper limit the diff. cross-section = 0.
        else                    !  Else it is calculated by fornmulae for
        k1=1                    !  bremstrahlung.
        endif                   !
        h1=dble(k1)             !
c
        eln1=dlog((rm_mu*rm_mu*a1*a1)/(1.d+0+x1*x1))
        eln2=dlog((rm_mu*rm_mu*a2*a2)/(1.d+0+x2*x2))
        psi10 = 5.d-1 * (1.+eln1) - fu2S(x1)
        psi10 = psi10 + (1.d+0/z)*(5.d-1*(1.d+0+eln2) - fu2S(x2))
        psi20=(1.d+1/3.d+1) + 5.d-1*eln1 + fu1S(x1)
        psi20=psi20+(1.d+0/z)*((1.d+0/3.d+0)+5.d-1*eln2+fu1S(x2))
        psi1=psi10-del1
        psi2=psi20-del2
        bremS=(fact/rnu)*
     &        ((rnu1*rnu1+1.d+0)*psi1-(2.d+0/3.d+0)*rnu1*psi2)
        bremS = bremS * h1 * dble(fa)
        return
        end
****************************************************************************
* B.2S
*
       real*8 function fu1S(c)
       external fu2S
       real*8 c,fu2S
      if (c.gt.1.d+3) then
        fu1S = -0.8333333333333d+0
      else
        if (c.lt.1.d-5) then
         ik=0
         fu1S=dble(ik)
        else
         fu1S=2.d+0*c*c*
     &        (1.d+0-fu2S(c)+(7.5d-1)*dlog((c*c)/(1.d+0+(c*c))))
        endif
      endif
      return
      end
****************************************************************************
* B.3S
*
       real*8 function fu2S(d)
       real*8 d
       if (d.gt.5.d+4) then
          ik = 1
          fu2S = dble(ik)
       else
           if (d.lt.1.d-8) then
             fu2S = d * 3.14159265359d+0 * 5.d-1
           else
             fu2S = d * datan(1.d+0/d)
           endif
       endif
       return
       end
**************************************************************************
* B.1aS
*
        function CRB_G4S (Z,A,Tkin,EP)
c       GeV:
        parameter       (ame=0.51099907e-3)
c        parameter       (amu=0.105658389)
c       cm:
        parameter       (re=2.81794092e-13)
        parameter       (avno=6.022137e23)
ccc        parameter       (alpha=1./137.036)
c        parameter       (rmass=amu/ame)         !!!     "207"
c        parameter       (coeff=16./3.*alpha*avno*(re/rmass)**2) !!! cm^2
c       sqrt(2.71828...):
        parameter       (sqrte=1.64872127)
        parameter       (btf=183.)
        parameter       (btf1=1429.)
        parameter       (bh=202.4)
        parameter       (bh1=446.)
        real*8 alfa,rm_e,rm_mu,r_e,avog
        real*4 Z,A,Tkin,EP
        common /constS/ alfa,rm_e,rm_mu,r_e,avog
        common /exer1S/ fa
c
        alpha = 1./137.036
        amu = sngl(rm_mu) * 1.e-3
        rmass = amu/ame
        coeff=16./3.*alpha*avno*(re/rmass)**2
C
        if (ep.ge.tkin) then
                crb_g4S=0.
                return
                end if
        e=tkin+amu
        v=ep/e
        delta=amu*amu*v/(2.*(e-ep))             !!!     qmin
        rab0=delta*sqrte
        z_13=z**(-0.3333333)                    !!!
C
        dn=1.54*A**0.27
        if (z.le.1.5) then      !!!     special case for hydrogen
                b=bh
                b1=bh1
                dn_star=dn
        else
                b=btf
                b1=btf1
                dn_star=dn**(1.-1./Z)   !!! with Bugaev's correction
        end if
C***            nucleus contribution logarithm
        rab1=b*z_13
        fn=alog(rab1/(dn_star*(ame+rab0*rab1))*(amu+delta*
     *          (dn_star*sqrte-2.)))
        if (fn.lt.0.) fn=0.
C***            electron contribution logarithm
        epmax1=e/(1.+amu*rmass/(2.*e))
        if (ep.ge.epmax1) then
                fe=0.
                go to 10
                end if
        rab2=b1*z_13*z_13
        fe=alog(rab2*amu/((1.+delta*rmass/(ame*sqrte))*
     *                  (ame+rab0*rab2)))
        if (fe.lt.0.) fe=0.
C***
10      continue
        crb_g4S=fa*coeff*e*(1.-v*(1.-0.75*v))*Z*(Z*fn+fe)/(ep*avno)
        return
        end
************************************************************************
* B.1bS
*     THIS REAL*8 FUNCTION CALCULATES DIFFERENTIAL CROS-SECTION FOR MUON
*         BREMSSTRAHLUNG ACCORDING TO FORMULAE TAKEN FROM A.SANDROCK
*                                  PhD Thesis:
*       M.Sc.A.Sandrock, "Higher-order corrections to the energy loss
*     cross sections of high-energy muons", Dissertation zur Erlangung
*                   des akademischen Grades eines (PhD Thesis)
*                     Technische Universitaet Dortmund, 2018
*  (https://eldorado.tu-dortmund.de/bitstream/2003/37815/1/Sandrock.pdf)
*
*                                INPUT:
*                                =====
*
* real*8 z     : electric charge of nucleus
* real*8 a     : atomic weight of nucleus
* real*8 en    : muon energy (GeV)
* real*8 rnu   : relative energy transfer = (E_transfered / E_mu)
*
*                                OUTPUT:
*                                ======
*
* real*8 brem_sandrS : d_sigma/d_v (sq. cm) for nucleus with given Z, A,
*                      muon energy EN and relative energy transfer RNU
*  .....................................................................
      real*8 function brem_sandrS(z,a,en,rnu)
c  .....................................................................
c
c                                                          DECLARATIONS:
c
c Routine to compute radiation logarithm B:
      external rad_log_HF
      real*8 rad_log_HF
c Declaration for input variables:
      real*8 z,a,en,rnu
c Declaration for constants which are prepared by MED_CONS routine and
c passed here via COMMON /const/ (electron and muon masses in MeV!!!):
      real*8 alfa,rm_e,rm_mu,r_e,avog
      common /constS/ alfa,rm_e,rm_mu,r_e,avog
c M_mu and M_e in GeV:
      real*8 rm_mu_gev,rm_e_gev
c E number:
      real*8, parameter:: e = 2.7182818284590452354d+0
c M_mu (GeV) to compute q_c parameter for tau-lepton:
      real*8, parameter:: mu_m = 1.0565932d+2  !--> muon mass (MeV)
c Inelastic radiation logarithm B':
c                                           for all the nuclei with Z>1:
      real*8, parameter::       b1_all=1429.d+0
c                                                          for hydrogen:
      real*8, parameter::       b1_h=446.d+0
c Radiation logarithm and inelastic radiation logarithm (the last to be
c substituted by one of the values above:
      real*8 b,b1
c Parameters of the parametrization for the radiative corrections to the
c bremsstrahlung cross section (Table B.1 in Sandrock's Thesis):
      real*8, dimension(3), parameter:: ai = (/
     #                                             -0.00349,
     #                                            148.84,
     #                                           -987.531
     #                                                       /)
      real*8, dimension(4), parameter:: bi = (/
     #                                              0.1642,
     #                                            132.573,
     #                                           -585.361,
     #                                           1407.77
     #                                                       /)
      real*8, dimension(6), parameter:: ci = (/
     #                                             -2.8922,
     #                                            -19.0156,
     #                                             57.698,
     #                                            -63.418,
     #                                             14.1166,
     #                                              1.84206
     #                                                       /)
      real*8, dimension(6), parameter:: di = (/
     #                                           2134.19,
     #                                            581.823,
     #                                          -2708.85,
     #                                           4767.05,
     #                                              1.52918,
     #                                              0.361933
     #                                                       /)
c Different terms in formula for dif. cross-section:
      real*8 Delta1, Delta2, delta,rho,q_c,Dn,F1,F2
c Radiative corrections made by Sandrock:
      real*8 s_at, s_rad
c Auxiliary variables:
      real*8 help1, help2, ulim, fact
c Some factor to play with cross-sections (FOR EXPERTS ONLY!!!):
      real*4 fa
      common /exer1S/ fa
c Loop variable:
      integer i
************************************************************************
c
c                                                          CALCULATIONS:
c
c
c Choosing values for radiation logarithm B and inelastic radiation
c                                     logarithm B' depending on Z value:

      b = rad_log_HF(z)
      if (z.gt.1.5d+0) then
         b1 = b1_all
      else
         b1 = b1_h
      endif
c
c                                 Computing terms of Sandrock's formula:
c
c Computing delta (in GeV!):
      rm_mu_gev = rm_mu / 1.d+3
      delta =
     &      (rm_mu_gev * rm_mu_gev * rnu) / (2.d+0 * en * (1.d+0 - rnu))
c Computing Dn (nuclear formfactor parametrization):
      Dn = 1.54d+0 * (a**0.27d+0)
c Computing q_c (in MeV!):
      q_c = (mu_m * e) / Dn
c Computing rho:
      rho = DSQRT(1.d+0 + ((4.d+0*rm_mu*rm_mu) / (q_c*q_c)))
c Computing Delta1:
      Delta1 = DLOG(rm_mu/q_c)
      Delta1 = Delta1 + (rho/2.d+0) * DLOG((rho+1.d+0)/(rho-1.d+0))
c Computing Delta2:
      Delta2 = DLOG(rm_mu/q_c)
      Delta2 = Delta2 + ( (2.d+0 * rm_mu * rm_mu) / (q_c * q_c) )
      Delta2 = Delta2 +
     &( (3.d+0*rho-rho**3.d+0) / 4.d+0) * DLOG((rho+1.d+0)/(rho-1.d+0))
c Computing F1 and F2:
      help1 = b * (z**(-1.d+0 / 3.d+0))
      help2 = help1 * (rm_mu / rm_e)
      rm_e_gev = rm_e / 1.d+3
      F1 = DLOG(help2 / (1.d+0 + (help1 * DSQRT(e) * (delta/rm_e_gev))))
      F1 = F1 - Delta1 * (1.d+0 - (1.d+0/z))
      F2 = help2 * e**(-1.d+0/6.d+0)
      F2 = DLOG(F2 /(1.d+0 + help1*(e**(1.d+0/3.d+0))*(delta/rm_e_gev)))
      F2 = F2 - Delta2  * (1.d+0 - (1.d+0/z))
c Computing s_at:
      help1 = DLOG(
     &(rm_mu_gev / delta)
     &                    /
     &  (((rm_mu_gev*delta) / (rm_e_gev*rm_e_gev)) + DSQRT(e))
     &                                                          )
      help2 = rm_e_gev / (delta * b1 * z**(-2.d+0/3.d+0) * DSQRT(e))
      help2 = DLOG(1.d+0 + help2)
      s_at = ((4.d+0/3.d+0) * (1.d+0 - rnu)) + (rnu * rnu)
      s_at = s_at * (help1 - help2)
c Computing s_rad:
      s_rad = 0.d+0
      if (rnu.lt.0.02d+0) then
         do i=1,3
            s_rad = s_rad + (ai(i) * rnu**(dble(i-1)))
         enddo
         goto 11111
      endif
c
      if ((rnu.ge.0.02d+0).AND.(rnu.lt.0.1d+0)) then
         do i=1,4
            s_rad = s_rad + (bi(i) * rnu**(dble(i-1)))
         enddo
         goto 11111
      endif
c
      if ((rnu.ge.0.1d+0).AND.(rnu.lt.0.9d+0)) then
         do i=1,3
            s_rad = s_rad + (ci(i) * rnu**(dble(i-1)))
         enddo
         s_rad = s_rad + (ci(4) * rnu * DLOG(rnu))
         s_rad = s_rad + (ci(5) * DLOG(1.d+0-rnu))
         s_rad = s_rad + (ci(6) * DLOG(1.d+0-rnu) * DLOG(1.d+0-rnu))
         goto 11111
      endif
c
      do i=1,3
         s_rad = s_rad + (di(i) * rnu**(dble(i-1)))
      enddo
      s_rad = s_rad + (di(4) * rnu * DLOG(rnu))
      s_rad = s_rad + (di(5) * DLOG(1.d+0-rnu))
      s_rad = s_rad + (di(6) * DLOG(1.d+0-rnu) * DLOG(1.d+0-rnu))
c
11111 continue
c
c      Computing dif. cross-section d_sigma / d_v by Sandrock's formula:
c
      brem_sandrS = F1 * (2.d+0 - 2.d+0*rnu + rnu*rnu)
      brem_sandrS = brem_sandrS - (F2 * (2.d+0/3.d+0) * (1.d+0 - rnu))
      brem_sandrS = brem_sandrS + (s_at / z)
      brem_sandrS = brem_sandrS + ((alfa/4.d+0) * F1 * s_rad)
      brem_sandrS = brem_sandrS / rnu
      brem_sandrS = brem_sandrS * 4.d+0 * alfa * z * z
      brem_sandrS = brem_sandrS * ((rm_e/rm_mu)*r_e)*((rm_e/rm_mu)*r_e)
c
c ULIM is the upper limit for energy transfer via bremsstrahlung for
c nucleus with given electric charge Z, atomic weight A, muon energy EN
c and  relative transfer RNU. If input energy transfer RNU is greater
c than ULIM cross-section value is set to ZERO;
c
      ulim=(z**(1.d+0/3.d+0)) * (rm_mu / (en * 1.d+3))
      ulim = ulim * DSQRT(e) * (3.d+0 / 4.d+0)
      ulim = 1.d+0 - ulim
      if (ulim.lt.rnu) then
         fact = 0.d+0
      else
         fact = 1.d+0
      endif
c
c                                                            Final step:
c
      brem_sandrS = brem_sandrS * fact * dble(fa)
c
      return
      end
**************************************************************************
* B.4S
*
       function brem_totS(ene,v)
       external bremS,crb_g4S,brem_sandrS
       real*8 brem_sandrS,bremS
       real*8 z1(10),w(10),aw(10),a_ef,en,rnu,h1,ro
       integer nsub
       real*8 alfa,rm_e,rm_mu,r_e,avog
       real*4 ene,v
       common /constS/ alfa,rm_e,rm_mu,r_e,avog
       common /bremindS/ ibrem
       common /mediaS/ z1,w,aw,a_ef,ro,nsub
c
c       Tkin = ene - 0.105658389 ! For crb_g4S
       Tkin = ene - (1.e-3 * sngl(rm_mu))
       if (v.gt..999995) v = .999995
       ep = v * ene ! For crb_g4S
       en = dble(ene)
       rnu = dble(v)
c
      if (ibrem.eq.1) then
         h1 = w(1) * bremS(z1(1),en,rnu)
      endif
      if (ibrem.eq.2) then
         h1 = w(1) * brem_sandrS(z1(1),aw(1),en,rnu)
      endif
      if ((ibrem.ne.1).AND.(ibrem.ne.2)) then
         h1 = w(1) * dble(crb_g4S(sngl(z1(1)),sngl(aw(1)),Tkin,ep))
      endif
c
      if (nsub.ge.2) then
         do l=2,nsub
            if (ibrem.eq.1) then
               h1 = h1 + (w(l) * bremS(z1(l),en,rnu))
            endif
            if (ibrem.eq.2) then
               h1 = h1 + (w(l) * brem_sandrS(z1(l),aw(l),en,rnu))
            endif
            if ((ibrem.ne.1).AND.(ibrem.ne.2)) then
               h1=h1+w(l)*dble(crb_g4S(sngl(z1(l)),sngl(aw(l)),Tkin,ep))
            endif
         enddo
      endif
      brem_totS = sngl(h1)
      return
      end
****************************************************************************
* B.5S
       subroutine gamma1S
*
       external brem_totS,dsimps
       real*8 dsimps
       real*8 um,ene,u(10)
       real*8 aux1(0:2000),aux2(0:2000),h1,h2
       real*8 alfa,rm_e,rm_mu,r_e,avog,z1(10),w(10),aw(10),a_ef,ro
       common /constS/ alfa,rm_e,rm_mu,r_e,avog ! from initial subroutine
       common /mediaS/ z1,w,aw,a_ef,ro,nsub     !       MED_CONSS
       common /generalS/ emin,vmin,emph         !
       common /cdbr_inS/ fcd1(81,54),fcd2(81,101),fcd3(81,51)
       common /ctbr_in1S/ crt_br1(17),crt_br2(17)
       common /elbr_in1S/ elo_br1(17),elo_br2(17)
       common /elbr_in2S/ elo_br3(17)
       common /elbr_in4S/ elo_br4(17)
       common /br_refS/ cf
       common /help_1S/ aux1,aux2
       common /bremindS/ ibrem
c   ....................................................................
c      1.PREPARATION OF ARRAYS WITH DIFF. CROSS-SEECTIONS FOR MUON
c                               BREMSSTRAHLUNG:
c
c                !       ..........................
      do j=1,81  !--->   j CYCLE BY ENERGIES starts
c                !       ..........................
        en = float(j)
        en = 1.e+1**(9.e-1 + (1.e-1 * en))
c                     !         ..................................
      do k=1,206      !--->     k CYCLE BY ENERGY TRANSFERS starts
c                     !         ..................................
      if (k.eq.206) then
        kk = 0
        fcd2(j,k-105) = float(kk)
        goto 975
      endif
c
      if (k.le.54) then
         k01 = k - 1
         rnu = 1.e+1**(float(k01) * 2.e-1 - 1.1e+1)
      else
         if (k.le.105) then
           k01 = k - 55
           rnu = 1.e+1**(float(k01) * 1.e-2 - 6.e-1)
         else
           k01 = k - 106
           rnu = 1.e+1**(float(k01) * 1.e-3 - 1.e-1)
         endif
      endif
c
      cr_dif=brem_totS(en,rnu)
      if (k.le.54) fcd1(j,k) = cr_dif
      if ((k.gt.54).AND.(k.lt.106)) fcd3(j,k-54) = cr_dif
      if (k.ge.106) fcd2(j,k-105) = cr_dif
c
 975  continue
c              !     .....................................
      enddo    !----> k CYCLE BY ENERGY TRANSFERS finishes
c              !     .....................................
      enddo    !----> j CYCLE BY ENERGIES finishes
c              !     ....................................
c   ....................................................................
c    2.PREPARATION OF ARRAYS WITH ENERGY LOSSES AND TOTAL CROSS-SECTIONS
c                         FOR MUON BREMSSTRAHLUNG:
c
c                    a) Energy transfers > EMIN :
      lim = 2000
      do i=1,17
      en = float(i)
      en = (1.e+1)**(5.e-1 + (5.e-1 * en))
      vmi = alog(emin / en) !------------> The lower limit for integration
c
        um = 0.d+0
        do k=1,nsub
        ene=dble(en)
        u(k)=((z1(k))**(1.d+0/3.d+0))*1.236540953d+0*(rm_mu/(ene*1.d+3))
        u(k) = 1.d+0 - u(k)
        um = dmax1(u(k),um)
        enddo
        vma=sngl(um)  !----------------> The upper limit for integration
        vma=alog(vma) !
        vst = (vma - vmi) / float(lim) !-> step for a rel. en. transfers grid
c
      do j=0,lim
      rnu = vmi + vst*(float(j))
      rnu = exp(rnu)
      aux1(j) = dble(brem_totS(en,rnu) * rnu)       !-> array to be integrated
c                                                  !   to get mean free path
      aux2(j) = aux1(j) * dble(rnu)                !-> array to be integrated
      enddo                                        !   for getting en. losses
c
      h1 = dble(vmi)
      h2 = dble(vma)
      crt_br1(i) = sngl(dsimps(aux1,h1,h2,lim))
      crt_br1(i) = sngl(a_ef / (avog * ro))/crt_br1(i)!->array with 17 values
c                                                     !  of free path
      elo_br1(i) = sngl( dsimps(aux2,h1,h2,lim) * avog * ro / a_ef )
      elo_br1(i) = elo_br1(i) * en * 1.e+3
      elo_br1(i) = alog10(elo_br1(i)) !-> array with 17 values of en. losses
      enddo
c
c                    b) Energy transfers > VMIN :
      do i=1,17
      en = float(i)
      en = (1.e+1)**(5.e-1 + (5.e-1 * en))
      vmi = alog(vmin)          !------------> The lower limit for integration
c
        um = 0.d+0
        do k=1,nsub
        ene=dble(en)
        u(k)=((z1(k))**(1.d+0/3.d+0))*1.236540953d+0*(rm_mu/(ene*1.d+3))
        u(k) = 1.d+0 - u(k)
        um = dmax1(u(k),um)
        enddo
        vma=sngl(um)  !----------------> The upper limit for integration
        vma=alog(vma) !
        vst = (vma - vmi) / float(lim) !-> step for a rel. en. transfers grid
c
      do j=0,lim
      rnu = vmi + vst*(float(j))
      rnu = exp(rnu)
      aux1(j) = dble(brem_totS(en,rnu) * rnu)       !-> array to be integrated
c                                                  !   to get mean free path
      aux2(j) = aux1(j) * dble(rnu)                !-> array to be integrated
      enddo                                        !   for getting en. losses
c
      h1 = dble(vmi)
      h2 = dble(vma)
      crt_br2(i) = sngl(dsimps(aux1,h1,h2,lim))
      crt_br2(i) = sngl(a_ef / (avog * ro))/crt_br2(i)!-> array with 17 values
c                                                     !   of free path
      elo_br2(i) = sngl( dsimps(aux2,h1,h2,lim) * avog * ro / a_ef )
      elo_br2(i) = elo_br2(i) * en * 1.e+3
      if(elo_br2(i).le.0.e+0) elo_br2(i) = 1.e-8
      elo_br2(i) = alog10(elo_br2(i)) !-> array with 17 values of en. losses
      enddo
c
c                    c) Energy transfers > 0 :
      do i=1,17
      en = float(i)
      en = (1.e+1)**(5.e-1 + (5.e-1 * en))
      vmi = alog(1.e-3/en)      !------------> The lower limit for integration
c
        um = 0.d+0
        do k=1,nsub
        ene=dble(en)
        u(k)=((z1(k))**(1.d+0/3.d+0))*1.236540953d+0*(rm_mu/(ene*1.d+3))
        u(k) = 1.d+0 - u(k)
        um = dmax1(u(k),um)
        enddo
        vma=sngl(um)  !----------------> The upper limit for integration
        vma=alog(vma) !
        vst = (vma - vmi) / float(lim) !-> step for a rel. en. transfers grid
c
      do j=0,lim
      rnu = vmi + vst*(float(j))
      rnu = exp(rnu)
      aux2(j) = dble(brem_totS(en,rnu) * rnu * rnu) !-> array to be integrated
c                                                  !   to get en. losses
      enddo
c
      h1 = dble(vmi)
      h2 = dble(vma)
      elo_br3(i) = sngl( dsimps(aux2,h1,h2,lim) * avog * ro / a_ef )
      elo_br3(i) = elo_br3(i) * en * 1.e+3
      if(elo_br3(i).le.0.e+0) elo_br3(i) = 1.e-8
      elo_br3(i) = alog10(elo_br3(i)) !-> array with 17 values of en. losses
      enddo
c                    c) Energy transfers < EMIN
      do i=1,17
      en = float(i)
      en = (1.e+1)**(5.e-1 + (5.e-1 * en))
      vmi = alog(1.e-3/en)      !------------> The lower limit for integration
      vma = alog(emin/en)   !----------------> The upper limit for integration
      vst = (vma - vmi) / float(lim) !----> step for a rel. en. transfers grid
c
      do j=0,lim
      rnu = vmi + vst*(float(j))
      rnu = exp(rnu)
      aux2(j) = dble(brem_totS(en,rnu) * rnu * rnu) !-> array to be integrated
c                                                  !   to get en. losses
      enddo
c
      h1 = dble(vmi)
      h2 = dble(vma)
      elo_br4(i) = sngl( dsimps(aux2,h1,h2,lim) * avog * ro / a_ef )
      elo_br4(i) = elo_br4(i) * en * 1.e+3 !-> array with 17 values
      enddo                                !    of en. losses
c   ....................................................................
c                      3. COMPUTING OF CF FACTOR:
      if (ibrem.eq.1) then
      en = 1.e+9
      rnu = emin / en
      cf = brem_totS(en,rnu)
      cf = cf * rnu * 1.02
      endif
      if (ibrem.eq.2) then
      en = 1.e+9
      rnu = emin / en
      cf = brem_totS(en,rnu)
      cf = cf * rnu * 1.07
      endif
      if ((ibrem.ne.1).AND.(ibrem.ne.2)) then
      en = 1.e+1
      rnu = 1.e-3
      cf = brem_totS(en,rnu)
      cf = cf * rnu * 1.1
      endif
c
      return
      end
****************************************************************************
* B.6S
      FUNCTION getlbremS(X)
*
      real*4 X
      COMMON /sok1S/ XMIN,STEP,XMAX
      common /sok1_bS/ C(19)
      X1 = alog10(X)
       if ((X1.lt..99999e+0).or.(X1.gt.9.0001e+0)) then
       print*,'ERROR IN FUNCTION GETLBREMS: MUON ENERGY IS OUT OF RANGE'
       endif
      Y = (X1-XMIN)/STEP
      I = INT(Y+0.5)
      IF(I.LT.0.OR.X1.GT.XMAX) PRINT 1,X1,XMIN,XMAX
      Y = Y-I
      Z = Y*Y + 0.25
      getlbremS = (Z-Y)*C(I+1) + (2.-(Z+Z))*C(I+2) + (Z+Y)*C(I+3)
      RETURN
1     FORMAT('*MISTAKE*X1=',D23.16,'XMIN=',D23.16,'XMAX=',D23.16)
      END
****************************************************************************
* B.7S
*
      FUNCTION glbremvS(X)
*
      real*4 X
      COMMON /sok1S/ XMIN,STEP,XMAX
      common /sok1_b2S/ C(19)
      X1 = alog10(X)
       if ((X1.lt..99999e+0).or.(X1.gt.9.0001e+0)) then
       print*,'ERROR IN FUNCTION GLBREMVS: MUON ENERGY IS OUT OF RANGE'
       endif
      Y = (X1-XMIN)/STEP
      I = INT(Y+0.5)
      IF(I.LT.0.OR.X1.GT.XMAX) PRINT 1,X1,XMIN,XMAX
      Y = Y-I
      Z = Y*Y + 0.25
      glbremvS = (Z-Y)*C(I+1) + (2.-(Z+Z))*C(I+2) + (Z+Y)*C(I+3)
      RETURN
1     FORMAT('*MISTAKE*X1=',D23.16,'XMIN=',D23.16,'XMAX=',D23.16)
      END
****************************************************************************
* B.8S
       function getctbrS(u)
*
      external getlbremS
      real*8 z1(10),w(10),aw(10),a_ef,alfa,rm_e,rm_mu,r_e,avog,ro
      real*4 u
      common /constS/ alfa,rm_e,rm_mu,r_e,avog
      common /mediaS/ z1,w,aw,a_ef,ro,nsub
      if ((u.gt.1.0001e+9).or.(u.lt.9.9999e+0)) then
      print*,'ERROR IN FUNCTION GETCTBRS: MUON ENERGY IS OUT OF RANGE'
      endif
      aef = sngl(a_ef / (avog * ro))
      getctbrS = aef / getlbremS(u)
      return
      end
************************************************************************
* B.9S
       function gctbrvS(u)
*
      external glbremvS
      real*8 z1(10),w(10),aw(10),a_ef,alfa,rm_e,rm_mu,r_e,avog,ro
      real*4 u
      common /constS/ alfa,rm_e,rm_mu,r_e,avog
      common /mediaS/ z1,w,aw,a_ef,ro,nsub
      if ((u.gt.1.0001e+9).or.(u.lt.9.9999e+0)) then
      print*,'ERROR IN FUNCTION GCTBRVS: MUON ENERGY IS OUT OF RANGE'
      endif
      aef = sngl(a_ef / (avog * ro))
      gctbrvS = aef / glbremvS(u)
      return
      end
***************************************************************************
* B.10S
         FUNCTION getdedbrS(X)
*
      real*4 X
      COMMON /sok5S/ XMIN,STEP,XMAX
      common /sok5_bS/ C(19)
      X1 = alog10(X)
       if ((X1.lt..99999e+0).or.(X1.gt.9.0001e+0)) then
       print*,'ERROR IN FUNCTION GETDEDBRS: MUON ENERGY IS OUT OF RANGE'
       endif
      Y = (X1-XMIN)/STEP
      I = INT(Y+0.5)
      IF(I.LT.0.OR.X1.GT.XMAX) PRINT 1,X1,XMIN,XMAX
      Y = Y-I
      Z = Y*Y + 0.25
      getdedbrS = (Z-Y)*C(I+1) + (2.-(Z+Z))*C(I+2) + (Z+Y)*C(I+3)
      getdedbrS = (1.e+1)**(getdedbrS)
      RETURN
1     FORMAT('*MISTAKE*X1=',D23.16,'XMIN=',D23.16,'XMAX=',D23.16)
      END
****************************************************************************
* B.11S
      FUNCTION gdedbrvS(X)
*
      real*4 X
      COMMON /sok5S/ XMIN,STEP,XMAX
      common /sok5_b2S/ C(19)
      X1 = alog10(X)
       if ((X1.lt..99999e+0).or.(X1.gt.9.0001e+0)) then
       print*,'ERROR IN FUNCTION GDEDBRVS: MUON ENERGY IS OUT OF RANGE'
       endif
      Y = (X1-XMIN)/STEP
      I = INT(Y+0.5)
      IF(I.LT.0.OR.X1.GT.XMAX) PRINT 1,X1,XMIN,XMAX
      Y = Y-I
      Z = Y*Y + 0.25
      gdedbrvS = (Z-Y)*C(I+1) + (2.-(Z+Z))*C(I+2) + (Z+Y)*C(I+3)
      gdedbrvS = (1.e+1)**(gdedbrvS)
      RETURN
1     FORMAT('*MISTAKE*X1=',D23.16,'XMIN=',D23.16,'XMAX=',D23.16)
      END
****************************************************************************
* B.12S
         FUNCTION gdedbrtS(X)
*
      real*4 X
      COMMON /sok5S/ XMIN,STEP,XMAX
      common /sok5_b3S/ C(19)
      X1 = alog10(X)
       if ((X1.lt..99999e+0).or.(X1.gt.9.0001e+0)) then
       print*,'ERROR IN FUNCTION GDEDBRTS: MUON ENERGY IS OUT OF RANGE'
       endif
      Y = (X1-XMIN)/STEP
      I = INT(Y+0.5)
      IF(I.LT.0.OR.X1.GT.XMAX) PRINT 1,X1,XMIN,XMAX
      Y = Y-I
      Z = Y*Y + 0.25
      gdedbrtS = (Z-Y)*C(I+1) + (2.-(Z+Z))*C(I+2) + (Z+Y)*C(I+3)
      gdedbrtS = (1.e+1)**(gdedbrtS)
      RETURN
1     FORMAT('*MISTAKE*X1=',D23.16,'XMIN=',D23.16,'XMAX=',D23.16)
      END
****************************************************************************
* B.13S
       FUNCTION getcdbrS(X,Y,loga)
*
      real*4 X,Y
      integer loga
      external getcdbr1S,getcdbr2S,getcdbr3S,brem_totS
       if (loga.eq.0) then
          if (Y.le..251188643) then
            getcdbrS = getcdbr1S(X,Y,loga)
          else
            if (Y.le..794328234) then
               getcdbrS = getcdbr2S(X,Y,loga)
            else
               if (X.le.1.e+2) then
               Z = 0.97
               else
               Z = 0.992
               endif
               if (Y.le.Z) then
               getcdbrS = getcdbr3S(X,Y,loga)
               else
               getcdbrS = brem_totS(X,Y)
               endif
            endif
          endif
       else
          if (Y.le.-6.e-1) then
            getcdbrS = getcdbr1S(X,Y,loga)
          else
            if (Y.le.-1.e-1) then
               getcdbrS = getcdbr2S(X,Y,loga)
            else
               if (X.le.1.e+2) then
               Z = -1.3228265e-2
               else
               Z = -3.4883278e-3
               endif
               if (Y.le.Z) then
               getcdbrS = getcdbr3S(X,Y,loga)
               else
               Y1 = (1.e+1)**Y
               getcdbrS = brem_totS(X,Y1)
               endif
            endif
          endif
       endif
      return
      end
****************************************************************************
* B.14S
       FUNCTION getcdbr1S(X,Y,loga)
*
      real*4 X,Y
      integer loga
      common /sok3S/ C1(4648)
      common /sok_2_1S/ NX,NY,X0,SX,Y0,SY
c
      X_1=alog10(X)
c
      if ((X_1.lt..99999e+0).or.(X_1.gt.9.0001e+0)) then
      print*,'ERROR IN FUNCTION GETCDBR1S: MUON ENERGY IS OUT OF RANGE'
      endif
c
      if (loga.eq.0) then
      Y_1=alog10(Y)
      else
      Y_1=Y
      endif
c
      if ((Y_1.lt.-11.001).or.(Y_1.gt.-5.9999e-1)) then
      print*,'ERROR IN FUNCTION GETCDBR1S: EN. TRANSFER IS OUT OF RANGE'
      endif
c
      A3=(X_1-X0)/SX
      B3=(Y_1-Y0)/SY
      M1=INT(A3+.5)
      M2=INT(B3+.5)
      M3=NX+2
      IF(M1.LT.0.OR.M1.GE.NX.OR.M2.LT.0.OR.M2.GE.NY) THEN
      PRINT 1,X_1,M1,Y_1,M2
      ENDIF
      A3=A3-M1
      B3=B3-M2
      M1=M2*M3+M1+1
      M2=M1+M3
      M3=M2+M3
      A2 = A3*A3 +.25
      B2 = B3*B3 +.25
      A1=A2-A3
      B1=B2-B3
      A3=A2+A3
      B3=B2+B3
      A2=2.-(A2+A2)
      B2=2.-(B2+B2)
      getcdbr1S=(A1*C1(M1)+A2*C1(M1+1)+A3*C1(M1+2))*B1
     2      +(A1*C1(M2)+A2*C1(M2+1)+A3*C1(M2+2))*B2
     3      +(A1*C1(M3)+A2*C1(M3+1)+A3*C1(M3+2))*B3
      if (getcdbr1S.lt.0.e+0) getcdbr1S = 0.e+0
      RETURN
1     FORMAT('*MISTAKE*X=',D23.16,'MX=',I4,'Y=',D23.16,'MY=',I4)
      END
****************************************************************************
* B.15S
       FUNCTION getcdbr2S(X,Y,loga)
*
      real*4 X,Y
      integer loga
      common /sok6S/ C1(4399)
      common /sok_2_2S/ NX,NY,X0,SX,Y0,SY
c
      X_1=alog10(X)
      if ((X_1.lt..99999e+0).or.(X_1.gt.9.000001e+0)) then
      print*,'ERROR IN FUNCTION GETCDBR2S: MUON ENERGY IS OUT OF RANGE'
      endif
c
      if (loga.eq.0) then
      Y_1=alog10(Y)
      else
      Y_1=Y
      endif
c
      if ((Y_1.lt.-.60001).or.(Y_1.gt.-.99999e-1)) then
      print*,'ERROR IN FUNCTION GETCDBR2S: EN. TRANSFer IS OUT OF RANGE'
      endif
c
      A3=(X_1-X0)/SX
      B3=(Y_1-Y0)/SY
      M1=INT(A3+.5)
      M2=INT(B3+.5)
      M3=NX+2
      IF(M1.LT.0.OR.M1.GE.NX.OR.M2.LT.0.OR.M2.GE.NY) THEN
      PRINT 1,X_1,M1,Y_1,M2
      ENDIF
      A3=A3-M1
      B3=B3-M2
      M1=M2*M3+M1+1
      M2=M1+M3
      M3=M2+M3
      A2=A3*A3+.25
      B2=B3*B3+.25
      A1=A2-A3
      B1=B2-B3
      A3=A2+A3
      B3=B2+B3
      A2=2.-(A2+A2)
      B2=2.-(B2+B2)
      getcdbr2S=(A1*C1(M1)+A2*C1(M1+1)+A3*C1(M1+2))*B1
     2      +(A1*C1(M2)+A2*C1(M2+1)+A3*C1(M2+2))*B2
     3      +(A1*C1(M3)+A2*C1(M3+1)+A3*C1(M3+2))*B3
      if (getcdbr2S.lt.0.e+0) getcdbr2S = 0.e+0
      RETURN
1     FORMAT('*MISTAKE*X=',D23.16,'MX=',I4,'Y=',D23.16,'MY=',I4)
      END
****************************************************************************
* B.16S
       FUNCTION getcdbr3S(X,Y,loga)
*
      real*4 X,Y
      integer loga
      common /sok4S/ C2(8549)
      common /sok_2_3S/ NX,NY,X0,SX,Y0,SY
c
      X_1=alog10(X)
      if ((X_1.lt..99999e+0).or.(X_1.gt.9.000001e+0)) then
      print*,'ERROR IN FUNCTION GETCDBR3S: MUON ENERGY IS OUT OF RANGE'
      endif
c
      if (loga.eq.0) then
      Y_1=alog10(Y)
      else
      Y_1=Y
      endif
c
      if ((Y_1.lt.-1.00001e-1).or.(Y_1.gt.1.e-10)) then
      print*,'ERROR IN FUNCTION GETCDBR3S: EN. TRANSFER IS OUT OF RANGE'
      endif
c
      A3=(X_1-X0)/SX
      B3=(Y_1-Y0)/SY
      M1=INT(A3+.5)
      M2=INT(B3+.5)
      M3=NX+2
      IF(M1.LT.0.OR.M1.GE.NX.OR.M2.LT.0.OR.M2.GE.NY) THEN
      PRINT 1,X_1,M1,Y_1,M2
      ENDIF
      A3=A3-M1
      B3=B3-M2
      M1=M2*M3+M1+1
      M2=M1+M3
      M3=M2+M3
      A2=A3*A3+.25
      B2=B3*B3+.25
      A1=A2-A3
      B1=B2-B3
      A3=A2+A3
      B3=B2+B3
      A2=2.-(A2+A2)
      B2=2.-(B2+B2)
      getcdbr3S=(A1*C2(M1)+A2*C2(M1+1)+A3*C2(M1+2))*B1
     2      +(A1*C2(M2)+A2*C2(M2+1)+A3*C2(M2+2))*B2
     3      +(A1*C2(M3)+A2*C2(M3+1)+A3*C2(M3+2))*B3
      if (getcdbr3S.lt.0.e+0) getcdbr3S = 0.e+0
      RETURN
1     FORMAT('*MISTAKE*X=',D23.16,'MX=',I4,'Y=',D23.16,'MY=',I4)
      END
****************************************************************************
* B.17S
*
      SUBROUTINE getvbremS(emw,vbr,itr)
*
      real*4 emw,vbr
      integer itr
      external getcdbrS
      parameter (lo=1)
      common /generalS/ emin,vmin,emph
      common /mcefS/ mcb1,mcb2,mcp1,mcp2,mcn1,mcn2,mce1,mce2
      common /br_refS/ cf
      mcb1 = mcb1 + 1
         if (itr.eq.0) then
          algemin = alog10(emin/emw)
         else
          algemin = alog10(vmin)
         endif
  155 ax = algemin * rndm_mum(5)
      mcb2 = mcb2 + 1
      y1 = getcdbrS(emw,ax,lo)
      vbr = exp(-2.3025851e+0 * ax)
      y2 = cf * vbr
      yc = y2 * rndm_mum(8)
        if (y1.ge.yc) then
        vbr = 1.e+0 / vbr
        else
        goto 155
        endif
      return
      end
****************************************************************************
*********************** PAIR PRODUCTION SUBROUTINES : **********************
****************************************************************************
* P.1S
*
      function CRP_G4S (Z,A,Tkin,EP)
c   ame in GeV:
       parameter    (ame=0.51099907e-3)
ccc parameter   (amu=0.105658389)   !!! GeV
c   re in cm:
      parameter (re=2.81794092e-13)
      parameter (avno=6.022137e23)
      parameter (pi=3.14159265)
c   parameter   (alpha=1./137.036)
ccc parameter   (rmass=amu/ame)     !!! "207"
c   parameter   (coeff=4./(3.*pi)*(alpha*re)**2*avno) !!! cm^2
c   sqrt(2.71828...):
      parameter (sqrte=1.64872127)
ccc parameter   (c3=3.*sqrte*amu/4.)    !!! for limits
c   parameter   (c7=4.*ame)     !!! -"-
ccc parameter   (c8=6.*amu**2)      !!! -"-
        common /const/ alfa,rm_e,rm_mu,r_e,avog
        real*8 alfa,rm_e,rm_mu,r_e,avog
        real*4 Z,A,Tkin,EP
c     Gauss, N=8:
      DIMENSION XGI(8),WGI(8)
      DATA XGI /.0199,.1017,.2372,.4083,.5917,.7628,.8983,.9801/
      DATA WGI /.0506,.1112,.1569,.1813,.1813,.1569,.1112,.0506/
c   for the moment:
      data  bbbtf,bbbh /183.,202.4/
      data  g1tf,g2tf /1.95e-5,5.3e-5/
      data  g1h,g2h   / 4.4e-5,4.8e-5/
        common /exer1/ fa
c************************************************************************
        adummy=a
        alpha=1./137.036
        coeff=4./(3.*pi)*(alpha*re)**2*avno
        c7=4.*ame
c************************************************************************
        amu = 1.e-3 * sngl(rm_mu)
        rmass = amu/ame
        c3=3.*sqrte*amu/4.
        c8=6.*amu**2
c************************************************************************
        E=tkin+amu
      z13=z**0.3333333
      e1=e-ep
      crp_g4S=0.
      if (e1.le.c3*z13) return  !!! ep > max
      alf=c7/ep         !!! 4m/ep
      a3=1.-alf
      if (a3.le.0.) return      !!! ep < min
C***        zeta calculation
      if (z.le.1.5) then    !!! special case of hidrogen
        bbb=bbbh
        g1=g1h
        g2=g2h
      else
        bbb=bbbtf
        g1=g1tf
        g2=g2tf
      endif
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c  INSERTED BY SOKALSKI TO TAKE INTO ACCOUNT DIFFERENT BBB for
c  DIFFERENT NUCLEI (S.P.KELNER, R.P.KOKOULIN, A.A.PETRUKHIN,
c  Yad.Fiz. 62, 2042 (1999) [Phys.Atom.Nucl. 62, 1894 (1999)]
c
       ztmp = z + 1.e-2
       itmp = int(ztmp)
       if (itmp.eq.1) bbb=202.4
       if (itmp.eq.2) bbb=151.9
       if (itmp.eq.3) bbb=159.9
       if (itmp.eq.4) bbb=172.3
       if (itmp.eq.5) bbb=177.9
       if (itmp.eq.6) bbb=178.3
       if (itmp.eq.7) bbb=176.6
       if (itmp.eq.8) bbb=173.4
       if (itmp.eq.9) bbb=170.0
       if (itmp.eq.10) bbb=165.8
       if (itmp.eq.11) bbb=165.8
       if (itmp.eq.12) bbb=167.1
       if (itmp.eq.13) bbb=169.1
       if (itmp.eq.14) bbb=170.8
       if (itmp.eq.15) bbb=172.2
       if (itmp.eq.16) bbb=173.4
       if (itmp.eq.17) bbb=174.3
       if (itmp.eq.18) bbb=174.8
       if (itmp.eq.19) bbb=175.1
       if (itmp.eq.20) bbb=175.6
       if (itmp.eq.21) bbb=176.2
       if (itmp.eq.22) bbb=176.8
       if (itmp.eq.26) bbb=175.8
       if (itmp.eq.29) bbb=173.1
       if (itmp.eq.32) bbb=173.0
       if (itmp.eq.35) bbb=173.5
       if (itmp.eq.42) bbb=175.9
       if (itmp.eq.50) bbb=177.4
       if (itmp.eq.53) bbb=178.6
       if (itmp.eq.74) bbb=177.6
       if (itmp.eq.82) bbb=178.0
       if (itmp.eq.92) bbb=179.8
cccccccccccccccccccccccccccccccccccccccccccccccccc
      zeta1=0.073*alog(e/(amu+g1*z13**2*e))-0.26
        if (zeta1.gt.0.) then
      zeta2=0.058*alog(e/(amu+g2*z13   *e))-0.14
      zeta=zeta1/zeta2
        else
      zeta=0.
        endif
      z2=z*(z+zeta)             !!!
      screen0=2.*ame*sqrte*bbb/(z13*ep) !!! be careful with "ame"
      a0=e*e1
      a1=ep*ep/a0           !!! 2*beta
      bet=0.5*a1            !!! beta
      xi0=0.25*rmass*rmass*a1       !!! xi0
      del=c8/a0         !!! 6mu^2/EE'
      tmn=alog((alf+2.*del*a3)/(1.+(1.-del)*sqrt(a3))) !!! log(1-rmax)
      sum=0.
      do i=1,8      !!! integration
      a4=exp(tmn*xgi(i))    !!! 1-r
      a5=a4*(2.-a4)     !!! 1-r2
      a6=1.-a5      !!! r2
      a7=1.+a6      !!! 1+r2
      a9=3.+a6      !!! 3+r2
      xi=xi0*a5
      xii=1./xi
      xi1=1.+xi
      screen=screen0*xi1/a5
      yeu=5.-a6+4.*bet*a7
      yed=2.*(1.+3.*bet)*alog(3.+xii)-a6-a1*(2.-a6)
      ye1=1.+yeu/yed
      ale=alog(bbb/z13*sqrt(xi1*ye1)/(1.+screen*ye1))
      cre=0.5*alog(1.+(1.5/rmass*z13)**2*xi1*ye1)
        if (xi.le.1e3) then !!!
      be=((2.+a6)*(1.+bet)+xi*a9)*alog(1.+xii)+(a5-bet)/xi1-a9
        else
      be=(3.-a6+a1*a7)/(2.*xi) !!!-(6.-5.*a6+3.*bet*a6)/(6.*xi*xi)
        end if
        if(rm_mu.le.1.d+3) then
      fe=amax1(0.,(ale-cre)*be)
        else
      fe=amax1(0.,ale*be)
        endif
      ymu=4.+a6+3.*bet*a7
      ymd=a7*(1.5+a1)*alog(3.+xi)+1.-1.5*a6
      ym1=1.+ymu/ymd
      alm_crm=alog(bbb*rmass/(1.5*z13*z13*(1.+screen*ym1)))
        if (xi.ge.1e-3) then    !!!
      a10=(1.+a1)*a5        !!! (1+2b)(1-r2)
      bm=(a7*(1.+1.5*bet)-a10*xii)*alog(xi1)+xi*(a5-bet)/xi1+a10
        else
      bm=(5.-a6+bet*a9)*(xi/2.) !!!-(11.-5.*a6+.5*bet*(5.+a6))*(xi*xi/6.)
        endif
      fm=amax1(0.,(alm_crm)*bm)
        if(rm_mu.le.1.d+3) then
      sum=sum+a4*(fe+fm/rmass**2)*wgi(i)
        else
      sum=sum+a4*fe*wgi(i)
        endif
      end do
      crp_g4S=fa*(-tmn*sum*z2*coeff*e1/ep)/avno  ! Vstavleno Sokalskim
c                                              ! (dobavlen mnozhitel
c                                              ! (A / N_a) * E )
      return
      end
****************************************************************************
* P.2S
*
       real*8 function pairS(z,en,rnu)
       external CRP_G4S
       real*8 z,en,rnu
       real*8 alfa,rm_e,rm_mu,r_e,avog
       common /constS/ alfa,rm_e,rm_mu,r_e,avog
       z0 = sngl(z)
       A = 10.
c       Tkin = sngl(en - 1.05658389d-1)
       Tkin = sngl(en) - (1.e-3 * sngl(rm_mu))
       ep = sngl(rnu * en)
       pa = CRP_G4S(z0,A,Tkin,ep)
       pairS = dble(pa)
       return
       end
****************************************************************************
* P.3S
*
       function pair_totS(ene,v)
       external pairS
       real*8 z1(10),w(10),aw(10),a_ef,en,rnu,h1,pairS,ro
       real*4 ene,v
       integer nsub
       common /mediaS/ z1,w,aw,a_ef,ro,nsub
c
       if (v.gt..999995) v = .999995
       en = dble(ene)
       rnu = dble(v)
       h1 = w(1) * pairS(z1(1),en,rnu)
         if (nsub.ge.2) then
           do l=2,nsub
             h1 = h1 + (w(l) * pairS(z1(l),en,rnu))
           enddo
         endif
       pair_totS = sngl(h1)
       return
       end
****************************************************************************
* P.4S
       subroutine pair1S
*
       external pair_totS,dsimps
       real*8 dsimps
       real*8 ai,bi,h1,h2,um,ene,u(10)
       real*8 aux1(0:2000),aux2(0:2000)
       real*8 alfa,rm_e,rm_mu,r_e,avog,z1(10),w(10),aw(10),a_ef,ro
       real*8 com1_pa(0:2200),com_pa_in(1101),com_p_h(0:2),tot_pa
       dimension com_pa_m(2201)
       common /help_1S/ aux1,aux2
       common /constS/ alfa,rm_e,rm_mu,r_e,avog ! from initial subroutine
       common /mediaS/ z1,w,aw,a_ef,ro,nsub     !       MED_CONSS
       common /generalS/ emin,vmin,emph         !
       common /cdpa_inS/ fcd1(81,54),fcd2(81,101),fcd3(81,51)
       common /ctpa_in1S/ crt_pa1(17),crt_pa2(17)
       common /elpa_in1S/ elo_pa1(17),elo_pa2(17)
       common /elpa_in2S/ elo_pa3(17)
       common /elpa_in4S/ elo_pa4(17)
       common /sok34S/ com_pa_m
       common /sok24S/ com_pa_in
       common /sok33S/ tot_pa
       common /fac_paS/ fac
       fac = 1.12
c ....................................................................
c      1.PREPARATION OF ARRAYS WITH DIFF. CROSS-SEECTIONS FOR MUON
c                           E+E- PAIR PRODUCTION:
c
c                !       ..........................
      do j=1,81  !--->   j CYCLE BY ENERGIES starts
c                !       ..........................
        en = float(j)
        en = 1.e+1**(9.e-1 + (1.e-1 * en))
c                     !         ..................................
      do k=1,206      !--->     k CYCLE BY ENERGY TRANSFERS starts
c                     !         ..................................
      if (k.eq.206) then
        fcd2(j,k-105) = -37.0
        goto 975
      endif
c
      if (k.le.54) then
         k01 = k - 1
         rnu = 1.e+1**(float(k01) * 2.e-1 - 1.1e+1)
      else
         if (k.le.105) then
           k01 = k - 55
           rnu = 1.e+1**(float(k01) * 1.e-2 - 6.e-1)
         else
           k01 = k - 106
           rnu = 1.e+1**(float(k01) * 1.e-3 - 1.e-1)
         endif
      endif
c
      cr_dif=pair_totS(en,rnu)
      if (cr_dif.le.1.e-37) cr_dif = 1.e-37
      cr_dif=alog(cr_dif)
c
      if (k.le.54) fcd1(j,k) = cr_dif
      if ((k.gt.54).AND.(k.lt.106)) fcd3(j,k-54) = cr_dif
      if (k.ge.106) fcd2(j,k-105) = cr_dif
c
 975  continue
c              !     ....................................
      enddo    !---> k CYCLE BY ENERGY TRANSFERS finishes
c              !     ....................................
      enddo    !----> j CYCLE BY ENERGIES finishes
c              !     ....................................
c   ....................................................................
c      2.PREPARATION OF ARRAYS WITH ENERGY LOSSES AND MEAN FREE PATH
c                         FOR MUON BREMSSTRAHLUNG:
c
c                    a) Energy transfers > EMIN :
      lim = 2000
      do i=1,17
      en = float(i)
      en = (1.e+1)**(5.e-1 + (5.e-1 * en))
      vmi = alog(emin / en) !------------> The lower limit for integration
        um = 0.d+0
        do k=1,nsub
        ene=dble(en)
        u(k)=((z1(k))**(1.d+0/3.d+0))*1.236540953d+0*(rm_mu/(ene*1.d+3))
        u(k) = 1.d+0 - u(k)
        um = dmax1(u(k),um)
        enddo
        vma=sngl(um)  !----------------> The upper limit for integration
        vma=alog(vma) !
        vst = (vma - vmi) / float(lim) !-> step for a rel. en. transfers grid
      do j=0,lim
      rnu = vmi + vst*(float(j))
      rnu = exp(rnu)
      aux1(j) = dble(pair_totS(en,rnu) * rnu)       !-> array to be integrated
c                                                  !   to get mean free path
      aux2(j) = aux1(j) * dble(rnu)                !-> array to be integrated
      enddo                                        !   for getting en. losses
c
      h1 = dble(vmi)
      h2 = dble(vma)
      crt_pa1(i) = sngl(dsimps(aux1,h1,h2,lim))         !-> array with 17 values
      crt_pa1(i) = sngl(a_ef / (avog * ro))/crt_pa1(i)  !   of free path
      crt_pa1(i) = alog(crt_pa1(i))
      elo_pa1(i) = sngl( dsimps(aux2,h1,h2,lim) * avog * ro / a_ef )
      elo_pa1(i) = elo_pa1(i) * en * 1.e+3
      elo_pa1(i) = alog(elo_pa1(i)) !-> array with 17 values of en. losses
      enddo
c                    b) Energy transfers > VMIN :
      do i=1,17
      en = float(i)
      en = (1.e+1)**(5.e-1 + (5.e-1 * en))
      vmi = alog(vmin) !------------> The lower limit for integration
        um = 0.d+0
        do k=1,nsub
        ene=dble(en)
        u(k)=((z1(k))**(1.d+0/3.d+0))*1.236540953d+0*(rm_mu/(ene*1.d+3))
        u(k) = 1.d+0 - u(k)
        um = dmax1(u(k),um)
        enddo
        vma=sngl(um)  !----------------> The upper limit for integration
        vma=alog(vma) !
        vst = (vma - vmi) / float(lim) !-> step for a rel. en. transfers grid
c
      do j=0,lim
      rnu = vmi + vst*(float(j))
      rnu = exp(rnu)
      aux1(j) = dble(pair_totS(en,rnu) * rnu)       !-> array to be integrated
c                                                  !   to get mean free path
      aux2(j) = aux1(j) * dble(rnu)                !-> array to be integrated
      enddo                                        !   for getting en. losses
c
      h1 = dble(vmi)
      h2 = dble(vma)
      crt_pa2(i) = sngl(dsimps(aux1,h1,h2,lim))         !-> array with 17 values
      crt_pa2(i) = sngl(a_ef / (avog * ro))/crt_pa2(i)  !   of free path
      crt_pa2(i) = alog(crt_pa2(i))
      elo_pa2(i) = sngl( dsimps(aux2,h1,h2,lim) * avog * ro / a_ef )
      elo_pa2(i) = elo_pa2(i) * en * 1.e+3
      if(elo_pa2(i).le.0.e+0) elo_pa2(i) = 1.e-8
      elo_pa2(i) = alog(elo_pa2(i)) !-> array with 17 values of en. losses
      enddo
c                    c) Energy transfers > 0 :
      do i=1,17
      en = float(i)
      en = (1.e+1)**(5.e-1 + (5.e-1 * en))
      vmi = alog(2.046e-3/en) !------------> The lower limit for integration
c
        um = 0.d+0
        do k=1,nsub
        ene=dble(en)
        u(k)=((z1(k))**(1.d+0/3.d+0))*1.236540953d+0*(rm_mu/(ene*1.d+3))
        u(k) = 1.d+0 - u(k)
        um = dmax1(u(k),um)
        enddo
        vma=sngl(um)  !----------------> The upper limit for integration
        vma=alog(vma) !
        vst = (vma - vmi) / float(lim) !-> step for a rel. en. transfers grid
      do j=0,lim
      rnu = vmi + vst*(float(j))
      rnu = exp(rnu)
      aux2(j) = dble(pair_totS(en,rnu) * rnu * rnu) !-> array to be integrated
      enddo                                        !   for getting en. losses
c
      h1 = dble(vmi)
      h2 = dble(vma)
      elo_pa3(i) = sngl( dsimps(aux2,h1,h2,lim) * avog * ro / a_ef )
      elo_pa3(i) = elo_pa3(i) * en * 1.e+3
      if(elo_pa3(i).le.0.e+0) elo_pa3(i) = 1.e-8
      elo_pa3(i) = alog(elo_pa3(i)) !-> array with 17 values of en. losses
      enddo
c                    d) Energy transfers < EMIN :
      do i=1,17
      en = float(i)
      en = (1.e+1)**(5.e-1 + (5.e-1 * en))
      vmi = alog(2.046e-3/en) !------------> The lower limit for integration
      vma = alog(emin/en)  !----------------> The upper limit for integration
      vst = (vma - vmi) / float(lim) !---> step for a rel. en. transfers grid
      do j=0,lim
      rnu = vmi + vst*(float(j))
      rnu = exp(rnu)
      aux2(j) = dble(pair_totS(en,rnu) * rnu * rnu) !-> array to be integrated
      enddo                                        !   for getting en. losses
c
      h1 = dble(vmi)
      h2 = dble(vma)
      elo_pa4(i) = sngl( dsimps(aux2,h1,h2,lim) * avog * ro / a_ef )
      elo_pa4(i) = elo_pa4(i) * en * 1.e+3 !-> array with 17 values
      enddo                                !   of en. losses
c   ....................................................................
c   3. PREPARATION OF ARRAY COM_PA_M WITH VALUES OF COMPARISON FUNCTION:
         en = 1.e+9
           do i=1,2201
              i1 = i - 1
              rnu = 1.e+1**(float(i1) * 5.e-3 - 1.1e+1)
              com_pa_m(i) = fac * pair_totS(en,rnu)
              com1_pa(i-1) = dble(com_pa_m(i) * rnu)
           enddo
           do i=1,2201
              if (com_pa_m(i).le.0.e+0) com_pa_m(i) = 1.0001e-37
              com_pa_m(i)=alog(com_pa_m(i))
           enddo
c   ....................................................................
c       4. PREPARATION OF ARRAY COM_PA_IN WITH VALUES OF INTEGRATED
c                 COMPARISON FUNCTION AND VALUE OF TOT_PA:
        com_pa_in(1) = 0.d+0
        h1 = 0.d+0
        m = 2
          do i=2,1101
             i1 = 2 * i
               com_p_h(0) = com1_pa(i1-4)
               com_p_h(1) = com1_pa(i1-3)
               com_p_h(2) = com1_pa(i1-2)
             ai = -((dble(1102 - i)) * 1.d-2)
             bi = ai + 1.d-2
             ai = 2.302585093 * ai
             bi = 2.302585093 * bi
             h2 = dsimps(com_p_h,ai,bi,m)
             h1 = h1 + h2
             com_pa_in(i) = h1
          enddo
        tot_pa = com_pa_in(1101)
       return
       end
****************************************************************************
* P.5S
      FUNCTION getlpairS(X)
*
      real*4 X
      COMMON /sok1S/ XMIN,STEP,XMAX
      common /sok1_pS/ C(19)
      X1 = alog10(X)
       if ((X1.lt..99999e+0).or.(X1.gt.9.0001e+0)) then
       print*,'ERROR IN FUNCTION GETLPAIRS: MUON ENERGY IS OUT OF RANGE'
       endif
      Y = (X1-XMIN)/STEP
      I = INT(Y+0.5)
      IF(I.LT.0.OR.X1.GT.XMAX) PRINT 1,X1,XMIN,XMAX
      Y = Y-I
      Z = Y*Y + 0.25
      getlpairS = (Z-Y)*C(I+1) + (2.-(Z+Z))*C(I+2) + (Z+Y)*C(I+3)
      getlpairS = exp(getlpairS)
      RETURN
1     FORMAT('*MISTAKE*X1=',D23.16,'XMIN=',D23.16,'XMAX=',D23.16)
      END
****************************************************************************
* P.6S
      FUNCTION glpairvS(X)
*
      real*4 X
      COMMON /sok1S/ XMIN,STEP,XMAX
      common /sok1_p2S/ C(19)
      X1 = alog10(X)
       if ((X1.lt..99999e+0).or.(X1.gt.9.0001e+0)) then
       print*,'ERROR IN FUNCTION GLPAIRVS: MUON ENERGY IS OUT OF RANGE'
       endif
      Y = (X1-XMIN)/STEP
      I = INT(Y+0.5)
      IF(I.LT.0.OR.X1.GT.XMAX) PRINT 1,X1,XMIN,XMAX
      Y = Y-I
      Z = Y*Y + 0.25
      glpairvS = (Z-Y)*C(I+1) + (2.-(Z+Z))*C(I+2) + (Z+Y)*C(I+3)
      glpairvS = exp(glpairvS)
      RETURN
1     FORMAT('*MISTAKE*X1=',D23.16,'XMIN=',D23.16,'XMAX=',D23.16)
      END
****************************************************************************
* P.7S
       function getctpaS(u)
*
       external getlpairS
       real*8 z1(10),w(10),aw(10),a_ef,alfa,rm_e,rm_mu,r_e,avog,ro
       real*4 u
       common /constS/ alfa,rm_e,rm_mu,r_e,avog
       common /mediaS/ z1,w,aw,a_ef,ro,nsub
      if ((u.gt.1.0001e+9).or.(u.lt.9.9999e+0)) then
      print*,'ERROR IN FUNCTION GETCTPAS: MUON ENERGY IS OUT OF RANGE'
      endif
      aef = sngl(a_ef / (avog * ro))
      getctpaS = aef / getlpairS(u)
      return
      end
*************************************************************************
* P.8S
       function gctpavS(u)
*

       external glpairvS
       real*8 z1(10),w(10),aw(10),a_ef,alfa,rm_e,rm_mu,r_e,avog,ro
       real*4 u
       common /constS/ alfa,rm_e,rm_mu,r_e,avog
       common /mediaS/ z1,w,aw,a_ef,ro,nsub
      if ((u.gt.1.0001e+9).or.(u.lt.9.9999e+0)) then
      print*,'ERROR IN FUNCTION GCTPAVS: MUON ENERGY IS OUT OF RANGE'
      endif
      aef = sngl(a_ef / (avog * ro))
      gctpavS = aef / glpairvS(u)
      return
      end
************************************************************************
* P.9S
       FUNCTION getdedpaS(X)
*
      real*4 X
      COMMON /sok5S/ XMIN,STEP,XMAX
      common /sok5_pS/ C(19)
      X1 = alog10(X)
       if ((X1.lt..99999e+0).or.(X1.gt.9.0001e+0)) then
       print*,'ERROR IN FUNCTION GETDEDPAS: MUON ENERGY IS OUT OF RANGE'
       endif
      Y = (X1-XMIN)/STEP
      I = INT(Y+0.5)
      IF(I.LT.0.OR.X1.GT.XMAX) PRINT 1,X1,XMIN,XMAX
      Y = Y-I
      Z = Y*Y + 0.25
      getdedpaS = (Z-Y)*C(I+1) + (2.-(Z+Z))*C(I+2) + (Z+Y)*C(I+3)
      getdedpaS = exp(getdedpaS)
      RETURN
1     FORMAT('*MISTAKE*X1=',D23.16,'XMIN=',D23.16,'XMAX=',D23.16)
      END
****************************************************************************
* P.10S
      FUNCTION gdedpavS(X)
*
      real*4 X
      COMMON /sok5S/ XMIN,STEP,XMAX
      common /sok5_p2S/ C(19)
      X1 = alog10(X)
       if ((X1.lt..99999e+0).or.(X1.gt.9.0001e+0)) then
       print*,'ERROR IN FUNCTION GDEDPAVS: MUON ENERGY IS OUT OF RANGE'
       endif
      Y = (X1-XMIN)/STEP
      I = INT(Y+0.5)
      IF(I.LT.0.OR.X1.GT.XMAX) PRINT 1,X1,XMIN,XMAX
      Y = Y-I
      Z = Y*Y + 0.25
      gdedpavS = (Z-Y)*C(I+1) + (2.-(Z+Z))*C(I+2) + (Z+Y)*C(I+3)
      gdedpavS = exp(gdedpavS)
      RETURN
1     FORMAT('*MISTAKE*X1=',D23.16,'XMIN=',D23.16,'XMAX=',D23.16)
      END
****************************************************************************
* P.11S
       FUNCTION gdedpatS(X)
*
      real*4 X
      COMMON /sok5S/ XMIN,STEP,XMAX
      common /sok5_p3S/ C(19)
      X1 = alog10(X)
       if ((X1.lt..99999e+0).or.(X1.gt.9.0001e+0)) then
       print*,'ERROR IN FUNCTION GDEDPATS: MUON ENERGY IS OUT OF RANGE'
       endif
      Y = (X1-XMIN)/STEP
      I = INT(Y+0.5)
      IF(I.LT.0.OR.X1.GT.XMAX) PRINT 1,X1,XMIN,XMAX
      Y = Y-I
      Z = Y*Y + 0.25
      gdedpatS = (Z-Y)*C(I+1) + (2.-(Z+Z))*C(I+2) + (Z+Y)*C(I+3)
      gdedpatS = exp(gdedpatS)
      RETURN
1     FORMAT('*MISTAKE*X1=',D23.16,'XMIN=',D23.16,'XMAX=',D23.16)
      END
****************************************************************************
* P.12S
        FUNCTION getcdpS(X,Y,lo)
*
      real*4 X,Y
      integer lo
       external getcdp1S,getcdp2S,getcdp3S,pair_totS
       if (lo.eq.0) then
          if (Y.le..251188643) then
                getcdpS = getcdp1S(X,Y,lo)
               getcdpS = exp(getcdpS)
          else
               if (Y.le..794328234) then
                  getcdpS = getcdp2S(X,Y,lo)
                  getcdpS = exp(getcdpS)
               else
                 if (Y.le..965) then
                    getcdpS = getcdp3S(X,Y,lo)
                    getcdpS = exp(getcdpS)
                 else
                    getcdpS = pair_totS(X,Y)
                 endif
               endif
          endif
       else
          if (Y.le.-6.e-1) then
                getcdpS = getcdp1S(X,Y,lo)
                getcdpS = exp(getcdpS)
          else
                if (Y.le.-1.e-1) then
                   getcdpS = getcdp2S(X,Y,lo)
                   getcdpS = exp(getcdpS)
                else
                   if (Y.le.-1.547272686e-2) then
                     getcdpS = getcdp3S(X,Y,lo)
                     getcdpS = exp(getcdpS)
                   else
                     Y1 = (1.e+1)**Y
                     getcdpS = pair_totS(X,Y1)
                   endif
                endif
          endif
       endif
      if (getcdpS.lt.0.e+0) getcdpS = 0.e+0
      return
      end
****************************************************************************
* P.13S
        FUNCTION getcdp1S(X,Y,loga)
*
      real*4 X,Y
      integer loga
      common /sok8S/ C1(4648)
      common /sok_2_1S/ NX,NY,X0,SX,Y0,SY
      X_1=alog10(X)
      if ((X_1.lt..99999e+0).or.(X_1.gt.9.0001e+0)) then
      print*,'ERROR IN FUNCTION GETCDP1S: MUON ENERGY IS OUT OF RANGE'
      endif
c
      if (loga.eq.0) then
      Y_1=alog10(Y)
      else
      Y_1=Y
      endif
      if ((Y_1.lt.-11.001).or.(Y_1.gt.-5.9999e-1)) then
      print*,'ERROR IN FUNCTION GETCDP1: EN. TRANSFER IS OUT OF RANGE'
      endif
c
      A3=(X_1-X0)/SX
      B3=(Y_1-Y0)/SY
      M1=INT(A3+.5)
      M2=INT(B3+.5)
      M3=NX+2
      IF(M1.LT.0.OR.M1.GE.NX.OR.M2.LT.0.OR.M2.GE.NY) THEN
      PRINT 1,X_1,M1,Y_1,M2
      ENDIF
      A3=A3-M1
      B3=B3-M2
      M1=M2*M3+M1+1
      M2=M1+M3
      M3=M2+M3
      A2=A3*A3+.25
      B2=B3*B3+.25
      A1=A2-A3
      B1=B2-B3
      A3=A2+A3
      B3=B2+B3
      A2=2.-(A2+A2)
      B2=2.-(B2+B2)
      getcdp1S=(A1*C1(M1)+A2*C1(M1+1)+A3*C1(M1+2))*B1
     2      +(A1*C1(M2)+A2*C1(M2+1)+A3*C1(M2+2))*B2
     3      +(A1*C1(M3)+A2*C1(M3+1)+A3*C1(M3+2))*B3
      RETURN
1     FORMAT('GETCDP1: *MISTAKE*X= ',D23.16,' MX= ',I4,' Y= ',D23.16,' M
     *Y= ',I4)
      END
****************************************************************************
* P.14S
       FUNCTION getcdp2S(X,Y,loga)
*
      real*4 X,Y
      integer loga
       common /sok9S/ C1(4399)
       common /sok_2_2S/ NX,NY,X0,SX,Y0,SY
      X_1=alog10(X)
      if ((X_1.lt..99999e+0).or.(X_1.gt.9.0001e+0)) then
      print*,'ERROR IN FUNCTION GETCDP2S: MUON ENERGY IS OUT OF RANGE'
      endif
      if (loga.eq.0) then
      Y_1=alog10(Y)
      else
      Y_1=Y
      endif
      if ((Y_1.lt.-.60001).or.(Y_1.gt.-.99999e-1)) then
      print*,'ERROR IN FUNCTION GETCDP2S: EN. TRANSFer IS OUT OF RANGE'
      endif
      A3=(X_1-X0)/SX
      B3=(Y_1-Y0)/SY
      M1=INT(A3+.5)
      M2=INT(B3+.5)
      M3=NX+2
      IF(M1.LT.0.OR.M1.GE.NX.OR.M2.LT.0.OR.M2.GE.NY) THEN
      PRINT 1,X_1,M1,Y_1,M2
      ENDIF
      A3=A3-M1
      B3=B3-M2
      M1=M2*M3+M1+1
      M2=M1+M3
      M3=M2+M3
      A2=A3*A3+.25
      B2=B3*B3+.25
      A1=A2-A3
      B1=B2-B3
      A3=A2+A3
      B3=B2+B3
      A2=2.-(A2+A2)
      B2=2.-(B2+B2)
      getcdp2S=(A1*C1(M1)+A2*C1(M1+1)+A3*C1(M1+2))*B1
     2      +(A1*C1(M2)+A2*C1(M2+1)+A3*C1(M2+2))*B2
     3      +(A1*C1(M3)+A2*C1(M3+1)+A3*C1(M3+2))*B3
      RETURN
1     FORMAT('GCDP2S:*MISTAKE*X=',D23.16,'MX=',I4,'Y=',D23.16,'MY=',I4)
      END
****************************************************************************
* P.15S
       FUNCTION getcdp3S(X,Y,loga)
*
      real*4 X,Y
      integer loga
       common /sok10S/ C2(8549)
       common /sok_2_3S/ NX,NY,X0,SX,Y0,SY
      X_1=alog10(X)
      if ((X_1.lt..99999e+0).or.(X_1.gt.9.0001e+0)) then
      print*,'ERROR IN FUNCTION GETCDP3S: MUON ENERGY IS OUT OF RANGE'
      endif
      if (loga.eq.0) then
      Y_1=alog10(Y)
      else
      Y_1=Y
      endif
      if ((Y_1.lt.-1.0001e-1).or.(Y_1.gt.1.e-6)) then
      print*,'ERROR IN FUNCTION GETCDP3S: EN. TRANSFER IS OUT OF RANGE'
      endif
      A3=(X_1-X0)/SX
      B3=(Y_1-Y0)/SY
      M1=INT(A3+.5)
      M2=INT(B3+.5)
      M3=NX+2
      IF(M1.LT.0.OR.M1.GE.NX.OR.M2.LT.0.OR.M2.GE.NY) THEN
      PRINT 1,X_1,M1,Y_1,M2
      ENDIF
      A3=A3-M1
      B3=B3-M2
      M1=M2*M3+M1+1
      M2=M1+M3
      M3=M2+M3
      A2=A3*A3+.25
      B2=B3*B3+.25
      A1=A2-A3
      B1=B2-B3
      A3=A2+A3
      B3=B2+B3
      A2=2.-(A2+A2)
      B2=2.-(B2+B2)
      getcdp3S=(A1*C2(M1)+A2*C2(M1+1)+A3*C2(M1+2))*B1
     2      +(A1*C2(M2)+A2*C2(M2+1)+A3*C2(M2+2))*B2
     3      +(A1*C2(M3)+A2*C2(M3+1)+A3*C2(M3+2))*B3
      RETURN
1     FORMAT('*MISTAKE*X=',D23.16,'MX=',I4,'Y=',D23.16,'MY=',I4)
      END
****************************************************************************
* P.16S
      FUNCTION compS(X)
*
      external pair_totS
      real*4 X
      common /sok55S/ XMIN,STEP,XMAX
      common /sok55_pS/ C(2203)
      common /fac_paS/ fac
      parameter (en = 1.e+9)
      X1 = X
      if (X1.lt.-1.5472686e-2) then
       if ((X1.lt.-11.001e+0).or.(X1.gt.1.e-5)) then
       print*,'ERROR IN FUNCTION COMPS: ENERGY transfer IS OUT OF RANGE'
       endif
      Y = (X1-XMIN)/STEP
      I = INT(Y+0.5)
      IF(I.LT.0.OR.X1.GT.XMAX) PRINT 1,X1,XMIN,XMAX
      Y = Y-I
      Z = Y*Y + 0.25
      compS = exp((Z-Y)*C(I+1) + (2.-(Z+Z))*C(I+2) + (Z+Y)*C(I+3))
      else
      rnu = 1.e+1**X1
      compS = fac * pair_totS(en,rnu)
      endif
      RETURN
1     FORMAT('*MISTAKE* X1=',D23.16,'  XMIN=',D23.16,'  XMAX=',D23.16)
      END
****************************************************************************
* P.17S
      real*8 FUNCTION c_pa_inS(X)
*
      real*8 XMIN,STEP,XMAX
      real*8 C(1103)
      real*8 X,X1,Y,Z
      COMMON /sok25S/ XMIN,STEP,XMAX
      common /sok26S/ C
       X1 = dlog10(X)
       if ((X1.lt.-11.0001d+0).or.(X1.gt.1.d-6)) then
       print*,'ERROR IN FUNCTION C_PA_INS: TRANSFER IS OUT OF RANGE'
       endif
      Y = (X1-XMIN)/STEP
      I = INT(Y+0.5)
      IF(I.LT.0.OR.X1.GT.XMAX) PRINT 1,X1,XMIN,XMAX
      Y = Y-I
      Z = Y*Y + 0.25
      c_pa_inS = (Z-Y)*C(I+1) + (2.-(Z+Z))*C(I+2) + (Z+Y)*C(I+3)
      RETURN
1     FORMAT('*MISTAKE*X1=',D23.16,'XMIN=',D23.16,'XMAX=',D23.16)
      END
****************************************************************************
* P.18S
        SUBROUTINE DSPLQ1S
*
      PARAMETER (N=1101)
      real*8 x(N),y(N),Y2(N),U(N),P,SIG,QN,UN
      common /sok24S/ X
      common /pa_in_s2S/ Y
      common /pa_in_s3S/ Y2
      do i=1,N                              ! Preparation of array Y(1101):
        Y(i) = -1.1d+1 + dble(i-1) * 1.d-2  !   log10(rel. en. transfer)
      enddo   !-----------------------------!       from -11.0 to 0.
      Y(N) = 0.d+0                          !------ with step 0.01
      Y2(1)=0.d+0
      U(1)=0.d+0
      DO 11 I=2,N-1 !------------------------------------------!
        SIG=(X(I)-X(I-1))/(X(I+1)-X(I-1))                      !  Cooking of
        P=SIG*Y2(I-1)+2.d+0                                    !    splain
        Y2(I)=(SIG-1.d+0)/P                                    ! coefficients
        U(I)=(6.d+0*((Y(I+1)-Y(I))/(X(I+1)-X(I))-(Y(I)-Y(I-1)) ! and putting
     *      /(X(I)-X(I-1)))/(X(I+1)-X(I-1))-SIG*U(I-1))/P      !  them into
11    CONTINUE                                                 !   output
c                                                              !  Y2(1101)
      QN=0.d+0                                                 !  array to
      UN=0.d+0                                                 !  be passed
c                                                              ! to routine
      Y2(N)=(UN-QN*U(N-1))/(QN*Y2(N-1)+1.d+0)                  !  DSPLIN1S
      DO 12 K=N-1,1,-1                                         !
        Y2(K)=Y2(K)*Y2(K+1)+U(K)                               !
12    CONTINUE  !----------------------------------------------!
      RETURN
      END
***********************************************************************
* P.19S
      real*8 FUNCTION DSPLIN1S(X1)
*
      PARAMETER (N=1101)
      real*8 X1,Y1
      real*8 XA(N),YA(N),Y2A(N),X,Y,H,A,B
      common /sok24S/ XA
      common /pa_in_s2S/ YA
      common /pa_in_s3S/ Y2A
      X=X1
      KLO=1
      KHI=N
1     IF (KHI-KLO.GT.1) THEN
        K=(KHI+KLO)/2
        IF(XA(K).GT.X)THEN
          KHI=K
        ELSE
          KLO=K
        ENDIF
      GOTO 1
      ENDIF
      H=XA(KHI)-XA(KLO)
c
c     This 'IF' line was commented in July, 2019:
c
ccc      IF (H.EQ.0.d+0) PAUSE 'Bad XA input at function DSPLIN1S...'
c
c     This 3 lines with 'IF' are instead of old line (see just above):
c
      IF (H.EQ.0.d+0) THEN
      PRINT*,'Bad XA input at function DSPLIN1S...'
      ENDIF
c
      A=(XA(KHI)-X)/H
      B=(X-XA(KLO))/H
      Y=A*YA(KLO)+B*YA(KHI)+
     *      ((A*A*A-A)*Y2A(KLO)+(B*B*B-B)*Y2A(KHI))*(H*H)/6.d+0
      Y1 = Y
      DSPLIN1S = Y1
                      if ((Y1.ge.1.d-10).OR.(Y1.lt.-1.1001d+1)) then
      print*,'DSPLIN1S ERR: IN =',X1,'(MAX=',XA(N),'), OUT=',Y1
                       endif
      RETURN
      END
****************************************************************************
* P.20S
      SUBROUTINE getvpaS(emw,vbr,itr)
*
       external c_pa_inS,dsplin1S,getcdpS,compS
       parameter (lo=1)
       parameter (len=1)
       real*8 c_pa_inS,tot_pa,ai1,dsplin1S,ax,algemin,arn
       real*4 emw,vbr
       integer itr
       common /generalS/ emin,vmin,emph
       common/sok33S/ tot_pa
       common /mcefS/ mcb1,mcb2,mcp1,mcp2,mcn1,mcn2,mce1,mce2
        mcp1 = mcp1 + 1
          if (itr.eq.0) then
          algemin = dble(emin/emw)
          else
          algemin = dble(amax1(vmin,2.044e-3/emw))
          endif
        ai1 = c_pa_inS(algemin)
        algemin = tot_pa - ai1
  155   arn = dble(rndm_mum(5))
        mcp2 = mcp2 + 1
        ax = (algemin * arn) + ai1
          if (ax.gt.tot_pa) ax = tot_pa
        ax = dsplin1S(ax)
          if (ax.ge.-1.d-5) ax = -1.d-5
        ay = sngl(ax)
c
        if (vmin.le.8.e-4) then
        az = (1.e+1)**ay
        echeck = az * emw
        if (echeck.ge.6.5e-3) then
        y1 = getcdpS(emw,ay,lo)
        else
        y1 = pair_totS(emw,az)
        endif
        else
        y1 = getcdpS(emw,ay,lo)
        endif
c
        vbr = sngl(ax)
        y2 = compS(vbr)
        arn = rndm_mum(8)
        yc = y2 * sngl(arn)
        if (y1.ge.yc) then
        vbr = (1.e+1)**ay
        else
        goto 155
        endif
      return
      end
****************************************************************************
************************* PHOTONUCLEAR SUBROUTINES : ***********************
****************************************************************************
* N.1S
*
      real*8 function phnuS(z,en,rnu,a)
      real*8 z,en,rnu,a,rnu1
      real*8 alfa,rm_e,rm_mu,r_e,fact,avog,m1,m2,mn,s,sigma,t,hv,zet
      real*8 te1,te2,te3,g,etr
      integer iqcd,ilep
      common /qcdS/ iqcd
      common /what_lepS/ ilep
      common /pnsigS/ ibb
      common /exer1S/ fa
      common /constS/ alfa,rm_e,rm_mu,r_e,avog
c     GeV squared:
      parameter (m1 = 5.4d-1)
      parameter (m2 = 1.8d+0)
c     Nucleon mass (Gev) = (Mp + Mn) / 2:
      parameter (mn = .939d+0)
c     fact = alfa / (8 * pi)
      parameter (fact = 2.903524525d-4)
      rnu1 = 1.d+0 - rnu
      etr = rnu * en
      s = etr * 2.d+0 * mn
       if (ibb.eq.1) then
        sigma = 1.143d+2 + 1.647d+0 * ((dlog(2.13d-2 * etr))**2.d+0)
c       it is Sigma_gamma_p parametrization from Bezrukov-Bugaev
       else
        sigma = (6.35d+1 * (s**9.7d-2)) + (1.45d+2 / (s**5.d-1))
c       it is Sigma_gamm_p parametrization from ZEUS (J.Breitweg
c       et al., hep-ex/9809005, Eur.Phys.J., C7 (1999) 609)
       endif
      sigma = sigma * 1.d-30
      t = (rm_mu * rm_mu * 1.d-6 * rnu * rnu) / rnu1
      hv = 1.d+0 - (2.d+0 / rnu) + (2.d+0 / (rnu * rnu))
      zet = 2.82d-3 * sigma * 1.d+30 * (a**(1.d+0 / 3.d+0))
c upgrade BB formula: =========>
c      te1 = hv * dlog(1.d+0 + (m2/t))
      te1 = (hv + ((2.d-6*rm_mu*rm_mu)/(m2))) * dlog(1.d+0 + (m2/t))
c =============================>
      if(t.gt.1.d-7) then
        te2 = 1.d+0 - ((.25d+0 * m2/t) * dlog(1.d+0 + (t/m2)))
        te2 = te2 * 2.d+0 * rm_mu * rm_mu * 1.d-6 / t
      else
        te2 = (1.5d+0 / t) * rm_mu * rm_mu * 1.d-6
      endif
      te3 = (dlog(1.d+0 + (m1/t)) - (m1/(m1 + t))) * hv
c upgrade BB formula: =========>
c      te3=te3-((2.d+0*rm_mu*rm_mu*1.d-6/t)*(1.d+0-((.25d+0*m1)/(m1+t))))
      te3=te3-((2.d+0*rm_mu*rm_mu*1.d-6/t)*
     &                            (1.d+0-((.25d+0*m1-t)/(m1+t))))
      te3=te3+(((4.d-6*rm_mu*rm_mu)/(m1))*dlog(1.d+0+((m1)/t)))
c =============================>
      g = ( (1.d+0 + zet) * dexp(-zet) ) - 1.d+0
      g = ( ( g / (zet * zet) ) + 5.d-1 ) * ( 9.d+0 / zet )
      if(z.lt.1.5d+0) g = 3.d+0  !---------------> Special case for hydrogen
      phnuS = te1 - te2 + (g * te3)
      phnuS = phnuS * fact * rnu * sigma * a * dble(fa)
c=================> QCD-corrections:
      IF(iqcd.EQ.1) THEN
        dops = QCD_CS(SNGL(rnu),SNGL(en)) * fa * SNGL(a)
        IF(dops.GE.0.) phnuS = phnuS + ((1.D-30 * DBLE(dops)) / rnu)
      ENDIF
c=================>
      IF (phnuS.LT.0.D+0) phnuS = 0.D+0
      return
      end
****************************************************************************
* N.1aS
*
      SUBROUTINE QCD_CORRS
*
* Computes QCD corrections for photonuclear interaction as was developed
* by E.Bugaev & Yu.Shlepin, put them in arrays COR_MU and COR_TAU, then
*    computes splain coefficients (array C(730) in common /qcd_new/ )
*
      DOUBLE PRECISION A_MU(8,7),A_TAU(8,7),COR_MU(71,8),COR_TAU(71,8)
      DOUBLE PRECISION V, V1, CORR_MU, CORR_TAU, SL_MU, SL_TAU
      DIMENSION F(71,8),D(90,27),C(730)
      COMMON /what_lepS/ ilep
      COMMON /qcd_newS/ C
      DATA NX /71/
      DATA NY /8/
c
c Coefficients for MU (from Bugaev-Shlepin, October 2002 & March 2003):
c                 computed for standard rock (A=22)
c
c     muon, 10^3 GeV
c
      A_MU(1, 1) = 0.0157837D+0
      A_MU(2, 1) = -5.3593D+0
      A_MU(3, 1) = -6.47286D+0
      A_MU(4, 1) = -3.64846D+0
      A_MU(5, 1) = -1.1501D+0
      A_MU(6, 1) = -0.205223D+0
      A_MU(7, 1) = -0.0192542D+0
      A_MU(8, 1) = -0.000735492D+0
c
c     muon, 10^4 GeV
c
      A_MU(1, 2) = 0.0376904D+0
      A_MU(2, 2) = -12.6647D+0
      A_MU(3, 2) = -15.0953D+0
      A_MU(4, 2) = -8.41549D+0
      A_MU(5, 2) = -2.63226D+0
      A_MU(6, 2) = -0.467407D+0
      A_MU(7, 2) = -0.0437325D+0
      A_MU(8, 2) = -0.00166849D+0
c
c     muon, 10^5 GeV
c
      A_MU(1, 3) = 0.0898107D+0
      A_MU(2, 3) = -34.1874D+0
      A_MU(3, 3) = -44.0928D+0
      A_MU(4, 3) = -26.5711D+0
      A_MU(5, 3) = -8.87342D+0
      A_MU(6, 3) = -1.66224D+0
      A_MU(7, 3) = -0.162793D+0
      A_MU(8, 3) = -0.00647547D+0
c
c     muon, 10^6 GeV
c
      A_MU(1, 4) = 0.189826D+0
      A_MU(2, 4) = -71.5287D+0
      A_MU(3, 4) = -87.9917D+0
      A_MU(4, 4) = -51.2985D+0
      A_MU(5, 4) = -16.7509D+0
      A_MU(6, 4) = -3.08549D+0
      A_MU(7, 4) = -0.297893D+0
      A_MU(8, 4) = -0.0116941D+0
c
c     muon, 10^7 GeV
c
      A_MU(1, 5) = 0.273715D+0
      A_MU(2, 5) = -131.49D+0
      A_MU(3, 5) = -150.811D+0
      A_MU(4, 5) = -85.5305D+0
      A_MU(5, 5) = -27.9549D+0
      A_MU(6, 5) = -5.21569D+0
      A_MU(7, 5) = -0.511526D+0
      A_MU(8, 5) = -0.0203833D+0
c
c     muon, 10^8 GeV
c
      A_MU(1, 6) = 0.48501D+0
      A_MU(2, 6) = -208.904D+0
      A_MU(3, 6) = -221.255D+0
      A_MU(4, 6) = -124.006D+0
      A_MU(5, 6) = -41.4446D+0
      A_MU(6, 6) = -7.95112D+0
      A_MU(7, 6) = -0.798525D+0
      A_MU(8, 6) = -0.0324086D+0
c
c     muon, 10^9 GeV
c
      A_MU(1, 7) = 0.710326D+0
      A_MU(2, 7) = -306.442D+0
      A_MU(3, 7) = -316.191D+0
      A_MU(4, 7) = -185.205D+0
      A_MU(5, 7) = -64.8621D+0
      A_MU(6, 7) = -12.8027D+0
      A_MU(7, 7) = -1.30405D+0
      A_MU(8, 7) = -0.0532388D+0
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c      DATA (A_MU(J, 1),J=1,8) /  !        muon, 10^3 GeV
c     & 0.0157837D+0, -5.3593D+0, -6.47286D+0, -3.64846D+0,  -1.1501D+0,
c     & -0.205223D+0, -0.0192542D+0, -0.000735492D+0 /
c
c      DATA (A_MU(J, 2),J=1,8) /  !        muon, 10^4 GeV
c     & 0.0376904D+0, -12.6647D+0, -15.0953D+0, -8.41549D+0, -2.63226D+0,
c     & -0.467407D+0, -0.0437325D+0, -0.00166849D+0 /
c
c      DATA (A_MU(J, 3),J=1,8) /  !        muon, 10^5 GeV
c     & 0.0898107D+0, -34.1874D+0, -44.0928D+0, -26.5711D+0, -8.87342D+0,
c     & -1.66224D+0, -0.162793D+0, -0.00647547D+0 /
c
c      DATA (A_MU(J, 4),J=1,8) /  !        muon, 10^6 GeV
c     & 0.189826D+0, -71.5287D+0, -87.9917D+0, -51.2985D+0, -16.7509D+0,
c     & -3.08549D+0, -0.297893D+0, -0.0116941D+0 /
c
c      DATA (A_MU(J, 5),J=1,8) /  !        muon, 10^7 GeV
c     & 0.273715D+0, -131.49D+0, -150.811D+0, -85.5305D+0, -27.9549D+0,
c     & -5.21569D+0, -0.511526D+0, -0.0203833D+0 /
c
c      DATA (A_MU(J, 6),J=1,8) /  !        muon, 10^8 GeV
c     & 0.48501D+0, -208.904D+0, -221.255D+0, -124.006D+0, -41.4446D+0,
c     & -7.95112D+0, -0.798525D+0, -0.0324086D+0 /
c
c      DATA (A_MU(J, 7),J=1,8) /  !        muon, 10^9 GeV
c     & 0.710326D+0, -306.442D+0, -316.191D+0, -185.205D+0, -64.8621D+0,
c     & -12.8027D+0, -1.30405D+0, -0.0532388D+0 /
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c Coefficients for TAU (from Bugaev-Shlepin, October 2002 & March 2003):
c                 computed for standard rock (A=22)
c
c
c     tau, 10^3 GeV
c
      A_TAU(1, 1) = -0.00279225D+0
      A_TAU(2, 1) = -0.343867D+0
      A_TAU(3, 1) = 1.03267D+0
      A_TAU(4, 1) = 1.17448D+0
      A_TAU(5, 1) = 0.492829D+0
      A_TAU(6, 1) = 0.102496D+0
      A_TAU(7, 1) = 0.0106092D+0
      A_TAU(8, 1) = 0.000436414D+0
c
c     tau, 10^4 GeV
c
      A_TAU(1, 2) = -0.00625653D+0
      A_TAU(2, 2) = -0.789706D+0
      A_TAU(3, 2) = 2.55848D+0
      A_TAU(4, 2) = 2.88145D+0
      A_TAU(5, 2) = 1.20912D+0
      A_TAU(6, 2) = 0.252265D+0
      A_TAU(7, 2) = 0.0262464D+0
      A_TAU(8, 2) = 0.00108684D+0
c
c     tau, 10^5 GeV
c
      A_TAU(1, 3) = -0.0126754
      A_TAU(2, 3) = -1.70908
      A_TAU(3, 3) = 6.74136
      A_TAU(4, 3) = 7.50275
      A_TAU(5, 3) = 3.18879
      A_TAU(6, 3) = 0.679863
      A_TAU(7, 3) = 0.072661
      A_TAU(8, 3) = 0.00310106
c
c     tau, 10^6 GeV
c
      A_TAU(1, 4) = -0.0262998D+0
      A_TAU(2, 4) = -3.46225D+0
      A_TAU(3, 4) = 15.4908D+0
      A_TAU(4, 4) = 16.5646D+0
      A_TAU(5, 4) = 6.86187D+0
      A_TAU(6, 4) = 1.43318D+0
      A_TAU(7, 4) = 0.150554D+0
      A_TAU(8, 4) = 0.0063314D+0
c
c     tau, 10^7 GeV
c
      A_TAU(1, 5) = -0.0289825D+0
      A_TAU(2, 5) = -5.98402D+0
      A_TAU(3, 5) = 31.6914D+0
      A_TAU(4, 5) = 31.3704D+0
      A_TAU(5, 5) = 12.2688D+0
      A_TAU(6, 5) = 2.44171D+0
      A_TAU(7, 5) = 0.246202D+0
      A_TAU(8, 5) = 0.00999873D+0
c
c     tau, 10^8 GeV
c
      A_TAU(1, 6) = -2.13163D-13
      A_TAU(2, 6) = -9.2095D+0
      A_TAU(3, 6) = 55.7338D+0
      A_TAU(4, 6) = 50.2693D+0
      A_TAU(5, 6) = 18.3936D+0
      A_TAU(6, 6) = 3.49729D+0
      A_TAU(7, 6) = 0.343508D+0
      A_TAU(8, 6) = 0.0138178D+0
c
c     tau, 10^9 GeV
c
      A_TAU(1, 7) = -1.42109D-13
      A_TAU(2, 7) = -17.6991D+0
      A_TAU(3, 7) = 70.7923D+0
      A_TAU(4, 7) = 56.0714D+0
      A_TAU(5, 7) = 17.7885D+0
      A_TAU(6, 7) = 2.95729D+0
      A_TAU(7, 7) = 0.258242D+0
      A_TAU(8, 7) = 0.00942025D+0
ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c      DATA (A_TAU(J, 1),J=1,8) / !        tau, 10^3 GeV
c     & -0.00279225D+0, -0.343867D+0, 1.03267D+0, 1.17448D+0,
c     &  0.492829D+0, 0.102496D+0, 0.0106092D+0, 0.000436414D+0 /
c
c      DATA (A_TAU(J, 2),J=1,8) / !        tau, 10^4 GeV
c     & -0.00625653D+0, -0.789706D+0, 2.55848D+0, 2.88145D+0,
c     &  1.20912D+0, 0.252265D+0, 0.0262464D+0, 0.00108684D+0 /
c
c      DATA (A_TAU(J, 3),J=1,8) / !        tau, 10^5 GeV
c     & -0.0126754, -1.70908, 6.74136, 7.50275, 3.18879,
c     & 0.679863, 0.072661, 0.00310106 /
c
c      DATA (A_TAU(J, 4),J=1,8) / !        tau, 10^6 GeV
c     & -0.0262998D+0, -3.46225D+0, 15.4908D+0, 16.5646D+0, 6.86187D+0,
c     & 1.43318D+0, 0.150554D+0, 0.0063314D+0 /
c
c      DATA (A_TAU(J, 5),J=1,8) / !        tau, 10^7 GeV
c     & -0.0289825D+0, -5.98402D+0, 31.6914D+0, 31.3704D+0, 12.2688D+0,
c     &  2.44171D+0, 0.246202D+0, 0.00999873D+0 /
c
c      DATA (A_TAU(J, 6),J=1,8) / !        tau, 10^8 GeV
c     & -2.13163D-13, -9.2095D+0, 55.7338D+0, 50.2693D+0, 18.3936D+0,
c     &  3.49729D+0, 0.343508D+0, 0.0138178D+0 /
c
c      DATA (A_TAU(J, 7),J=1,8) / !        tau, 10^9 GeV
c     & -1.42109D-13, -17.6991D+0, 70.7923D+0, 56.0714D+0, 17.7885D+0,
c     &  2.95729D+0, 0.258242D+0, 0.00942025D+0 /
ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c       Bugaev's data are down to 10^3 GeV. We artifically assign
c   "correction=0" for 10^2 GeV to enlarge interpolation energy range:
c
      DO I=1,71
        COR_MU(I,1)  = 0.D+0
        COR_TAU(I,1) = 0.D+0
      ENDDO
c
c   Bugaev's corrections work for v > 10^(-6). We artifically assign
c   "correction = 0" for V = 10^-7 to enlarge interpolation V range.
c       To make sure we also set to zero corrections for V = 1 :
c
      DO I=1,8
        COR_MU(1,I)   = 0.D+0
        COR_TAU(1,I)  = 0.D+0
        COR_MU(71,I)  = 0.D+0
        COR_TAU(71,I) = 0.D+0
      ENDDO
c
c  We compute corrections for 7 energies (10^3 GeV - 10^9 GeV) and
c        10^(-6) =< V < 1 using Bugaev-Shlepin formula
c
c                                 7
c           v (d_sigma / d_v) = S U M (a_k * (alog10(v))**k)
c                                k=0
c
c with coefficients for mu and tau as given in DATA for A_MU and A_TAU:
c
      DO I=2,8
        M = I - 1
          DO J=11,70
            V = 1.D-1 * DBLE(J - 71)
            V1 = 1.D+1**V
            CORR_MU  = 0.D+0
            CORR_TAU = 0.D+0
              DO J1=1,8
              CORR_MU=CORR_MU+(A_MU(J1,M)*(DLOG10(V1))**(DBLE(J1-1)))
              CORR_TAU=CORR_TAU+(A_TAU(J1,M)*(DLOG10(V1))**(DBLE(J1-1)))
              ENDDO
            COR_MU(J,I)  = CORR_MU
            COR_TAU(J,I) = CORR_TAU
          ENDDO
      ENDDO
c
c For v range 10^(-7) -- 10^(-6) we are making a linear interpolation
c    (below V = 10^(-7) all the corrections will be equal to zero):
c
      DO I=2,8
        SL_MU  = COR_MU(11,I) / 1.D+1
        SL_TAU = COR_TAU(11,I) / 1.D+1
          DO K=2,10
            COR_MU(K,I)  = SL_MU * DBLE(K-1)
            COR_TAU(K,I) = SL_TAU * DBLE(K-1)
          ENDDO
      ENDDO
c
c NOW ALL THE CORRECTIONS EXPRESSED IN [ub] for v (d_sigma / d_v)
c     FOR A=22  ARE IN ARRAYS COR_MU(71,8) AND COR_TAU(71,8)
c
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c FILLING ARRAY F(71,8) EITHER BY MU OR TAU CORRECTIONS TO COOK SPLAINS
c      TRANSFORMING TO LOG10 TO GET BETTER INTERPOLATION QUALITY
c         AND DIVIDING BY 22 TO GET CORRECTIONS FOR 1 NUCLEON:
c
      DO I=1,71
        DO J=1,8
          IF(ilep.EQ.1) THEN
            F(I,J) = SNGL(COR_MU(I,J)) / 22.
          ELSE
            F(I,J) = SNGL(COR_TAU(I,J)) / 22.
          ENDIF
        ENDDO
      ENDDO
c
c                        COOKING SPLAINS:
c
      DO 1 J=1,NY
      J2=J+2
      DO 1 I=1,NX
      I2=I+2
1     D(I2,J2)=3.90625E-3*F(I,J)
      J1=NY+1
      J3=J2+1
      J4=J3+1
      DO 2 I=3,I2
      A=D(I,3)
      B=D(I,4)
      D(I,2)=3.*(A-B)+D(I,5)
      D(I,1)=3.*(D(I,2)-A)+B
      A=D(I,J1)
      B=D(I,J2)
      D(I,J3)=3.*(B-A)+D(I,NY)
2     D(I,J4)=3.*(D(I,J3)-B)+A
      I1=NX+1
      I3=I2+1
      I4=I3+1
      DO 3 J=1,J4
      A=D(3,J)
      B=D(4,J)
      D(2,J)=3.*(A-B)+D(5,J)
      D(1,J)=3.*(D(2,J)-A)+B
      A=D(I1,J)
      B=D(I2,J)
      D(I3,J)=3.*(B-A)+D(NX,J)
3     D(I4,J)=3.*(D(I3,J)-B)+A
      DO 4 J=1,J2
      J3=J+1
      J4=J+2
      M=(J-1)*I2
      DO 4 I=1,I2
      I3=I+1
      I4=I+2
4     C(M+I)=D(I,J)+D(I,J4)+D(I4,J)+D(I4,J4)+D(I3,J3)*
     *100.-(D(I3,J)+D(I,J3)+D(I4,J3)+D(I3,J4))*10.
c
      RETURN
      END
************************************************************************
* N.1bS
*
      FUNCTION QCD_CS(X1,Y1)
*
* Returns QCD correction for PN according to Bugaev & Shlepin by
*    interpolation using splains prepared by QCD_CORR routine.
*
* INPUT: X1 -> relative energy transfer 10^(-10) < V < 1.
*        Y1 -> lepton energy [GeV]       1. < E < 1.E+9
*
*
* OUTPUT QCD_C  -> QCD-correction for PN crosssection [ub] for
*                  v * (d_sigma / d_v) per 1 nucleon
*
      REAL*4 X1,Y1
      DIMENSION C(730)
      COMMON /qcd_newS/ C
      DATA NX /71/
      DATA NY /8/
      DATA X0 /-7./
      DATA SX /.1/
      DATA Y0 /2./
      DATA SY /1./
c
      IF(Y1.LT.1.E+2) THEN
        QCD_CS = 0.E+0
        RETURN
      ENDIF
      IF(X1.LT.1.E-7) THEN
        QCD_CS = 0.E+0
        RETURN
      ENDIF
c
      X = ALOG10(X1)
      Y = ALOG10(Y1)
c
      A3=(X-X0)/SX
      B3=(Y-Y0)/SY
      M1=INT(A3+.5)
      M2=INT(B3+.5)
      M3=NX+2
      IF(M1.LT.0.OR.M1.GE.NX.OR.M2.LT.0.OR.M2.GE.NY) PRINT 1,X,M1,Y,M2
      A3=A3-M1
      B3=B3-M2
      M1=M2*M3+M1+1
      M2=M1+M3
      M3=M2+M3
      A2=A3**2+.25
      B2=B3**2+.25
      A1=A2-A3
      B1=B2-B3
      A3=A2+A3
      B3=B2+B3
      A2=2.-(A2+A2)
      B2=2.-(B2+B2)
      QCD_CS=(A1*C(M1)+A2*C(M1+1)+A3*C(M1+2))*B1
     2      +(A1*C(M2)+A2*C(M2+1)+A3*C(M2+2))*B2
     3      +(A1*C(M3)+A2*C(M3+1)+A3*C(M3+2))*B3
c
      RETURN
1     FORMAT('*MISTAKE IN QCD* X=',D23.16,'MX=',I4,'Y=',D23.16,'MY=',I4)
      END
****************************************************************************
* N.2S
*
       function phnu_totS(ene,v)
       external phnuS
       real*8 z1(10),w(10),aw(10),a_ef,en,rnu,h1,phnuS,ro
       real*4 ene,v
       integer nsub
       common /mediaS/ z1,w,aw,a_ef,ro,nsub
       if (v.gt..999998) v = .999998
       en = dble(ene)
       rnu = dble(v)
           h1 = w(1) * phnuS(z1(1),en,rnu,aw(1))
         if (nsub.ge.2) then
           do l=2,nsub
             h1 = h1 + (w(l) * phnuS(z1(l),en,rnu,aw(l)))
           enddo
         endif
       phnu_totS = sngl(h1)
       return
       end
****************************************************************************
* N.3S
*
       subroutine phnu1S
*
       external phnu_totS,dsimps
       real*8 dsimps
       real*8 aux1(0:2000),aux2(0:2000),h1,h2
       real*8 alfa,rm_e,rm_mu,r_e,avog,z1(10),w(10),aw(10),a_ef,ro
       common /constS/ alfa,rm_e,rm_mu,r_e,avog ! from initial subroutine
       common /mediaS/ z1,w,aw,a_ef,ro,nsub     !       MED_CONSS
       common /generalS/ emin,vmin,emph         !
       common /cdph_inS/ fcd1(81,54),fcd2(81,101),fcd3(81,51)
       common /ctph_in1S/ crt_ph1(17),crt_ph2(65)
       common /elph_in1S/ elo_ph1(17),elo_ph2(65)
       common /elph_in2S/ elo_ph3(17)
       common /elph_in4S/ elo_ph4(17)
       common /ph_refS/ at,bt,us2,us2_1,us3,us4,at0
       common /pnsigS/ ibb
       common /help_1S/ aux1,aux2
c   ....................................................................
c      1.PREPARATION OF ARRAYS WITH DIFF. CROSS-SEECTIONS FOR MUON
c                         PHOTONUCLEAR INTERACTION:
c
c                !       ..........................
      do j=1,81  !--->   j CYCLE BY ENERGIES starts
c                !       ..........................
        en = float(j)
        en = 1.e+1**(9.e-1 + (1.e-1 * en))
c                     !         ..................................
      do k=1,206      !--->     k CYCLE BY ENERGY TRANSFERS starts
c                     !         ..................................
      if (k.eq.206) then
        rnu = 1.e+0
        fcd2(j,101) = phnu_totS(en,rnu)
        if (fcd2(j,101).le.1.e-37) fcd2(j,101) = 1.e-37
        fcd2(j,101) = alog(fcd2(j,101))
        goto 975
      endif
c
      if (k.le.54) then
         k01 = k - 1
         rnu = 1.e+1**(float(k01) * 2.e-1 - 1.1e+1)
      else
         if (k.le.105) then
           k01 = k - 55
           rnu = 1.e+1**(float(k01) * 1.e-2 - 6.e-1)
         else
           k01 = k - 106
           rnu = 1.e+1**(float(k01) * 1.e-3 - 1.e-1)
         endif
      endif
c
      cr_dif=phnu_totS(en,rnu)
      if (cr_dif.le.1.e-37) cr_dif = 1.e-37
      cr_dif=alog(cr_dif)
c
      if (k.le.54) fcd1(j,k) = cr_dif
      if ((k.gt.54).AND.(k.lt.106)) fcd3(j,k-54) = cr_dif
      if (k.ge.106) fcd2(j,k-105) = cr_dif
c
 975  continue
c              !     .....................................
      enddo    !----> k CYCLE BY ENERGY TRANSFERS finishes
c              !     .....................................
      enddo    !----> j CYCLE BY ENERGIES finishes
c              !     ....................................
c   ....................................................................
c      2.PREPARATION OF ARRAYS WITH ENERGY LOSSES AND MEAN FREE PATH
c                     FOR MUON PHOTONUCLEAR INTERACTION:
c
c                       a) Energy transfers > EMIN :
      lim = 2000
      do i=1,17
      en = float(i)
      en = (1.e+1)**(5.e-1 + (5.e-1 * en))
      vmi1 = alog(emin / en)
      vmi2 = alog(emph / en)
      vmi = amax1(vmi1,vmi2) !-----------> The lower limit for integration
      vma = 0.e+0            !-----------> The upper limit for integration
      vst = (vma - vmi) / float(lim) !---> Step for a rel. en. transfers grid
c
      do j=0,lim
      rnu = vmi + vst*(float(j))
      rnu = exp(rnu)
      aux1(j) = dble(phnu_totS(en,rnu) * rnu)       !-> array to be integrated
c                                                  !   to get mean free path
      aux2(j) = aux1(j) * dble(rnu)                !-> array to be integrated
      enddo                                        !   for getting en. losses
c
      h1 = dble(vmi)
      h2 = dble(vma)
      crt_ph1(i) = sngl(dsimps(aux1,h1,h2,lim))       !-> array with 17 values
      crt_ph1(i) = sngl(a_ef / (avog * ro))/crt_ph1(i)! of mean free path
      crt_ph1(i) = alog(crt_ph1(i))                    !
      elo_ph1(i) = sngl( dsimps(aux2,h1,h2,lim) * avog * ro / a_ef )
      elo_ph1(i) = elo_ph1(i) * en * 1.e+3
      elo_ph1(i) = alog10(elo_ph1(i)) !-> array with 17 values of en. losses
      enddo
c                       b) Energy transfers > VMIN :
      do i=1,65
      en = float(i)
      en = (1.e+1)**(8.75e-1 + (1.25e-1 * en))
      vmi1 = alog(vmin)
      vmi2 = alog(emph / en)
      vmi = amax1(vmi1,vmi2) !------------> The lower limit for integration
      vma = 0.e+0            !------------> The upper limit for integration
      vst = (vma - vmi) / float(lim) !----> Step for a rel. en. transfers grid
c
      do j=0,lim
      rnu = vmi + vst*(float(j))
      rnu = exp(rnu)
      aux1(j) = dble(phnu_totS(en,rnu) * rnu)       !-> array to be integrated
c                                                  !   to get mean free path
      aux2(j) = aux1(j) * dble(rnu)                !-> array to be integrated
      enddo                                        !   for getting en. losses
c
      h1 = dble(vmi)
      h2 = dble(vma)
      crt_ph2(i) = sngl(dsimps(aux1,h1,h2,lim))       !-> array with 17 values
      crt_ph2(i) = sngl(a_ef / (avog * ro))/crt_ph2(i)!   of mean free path
      elo_ph2(i) = sngl( dsimps(aux2,h1,h2,lim) * avog * ro / a_ef )
      elo_ph2(i) = elo_ph2(i) * en * 1.e+3
      if(elo_ph2(i).le.0.e+0) elo_ph2(i) = 1.e-8
      elo_ph2(i) = alog10(elo_ph2(i)) !-> array with 17 values of en. losses
      enddo
c                       c) Energy transfers > 0 :
      do i=1,17
      en = float(i)
      en = (1.e+1)**(5.e-1 + (5.e-1 * en))
      vmi = alog(emph / en)  !-----------> The lower limit for integration
      vma = 0.e+0            !-----------> The upper limit for integration
      vst = (vma - vmi) / float(lim) !---> Step for a rel. en. transfers grid
c
      do j=0,lim
      rnu = vmi + vst*(float(j))
      rnu = exp(rnu)
      aux2(j) = dble(phnu_totS(en,rnu) * rnu * rnu) !-> array to be integrated
c                                                  !   to get en. losses
      enddo
c
      h1 = dble(vmi)
      h2 = dble(vma)
      elo_ph3(i) = sngl( dsimps(aux2,h1,h2,lim) * avog * ro / a_ef )
      elo_ph3(i) = elo_ph3(i) * en * 1.e+3
      if(elo_ph3(i).le.0.e+0) elo_ph3(i) = 1.e-8
      elo_ph3(i) = alog10(elo_ph3(i)) !-> array with 17 values of en. losses
      enddo
c                       d) Energy transfers < EMIN :
      do i=1,17
      en = float(i)
      en = (1.e+1)**(5.e-1 + (5.e-1 * en))
      vmi = alog(emph / en)  !---------> The lower limit for integration
      vma = alog(emin / en)          !----> The upper limit for integration
      vst = (vma - vmi) / float(lim) !----> Step for a rel. en. transfers grid
      if (vma.le.vmi) then
      elo_ph4(i) = 0.
      goto 1234
      endif
c
      do j=0,lim
      rnu = vmi + vst*(float(j))
      rnu = exp(rnu)
      aux2(j) = dble(phnu_totS(en,rnu) * rnu * rnu) !-> array to be integrated
c                                                  !   to get en. losses
      enddo
c
      h1 = dble(vmi)
      h2 = dble(vma)
      elo_ph4(i) = sngl( dsimps(aux2,h1,h2,lim) * avog * ro / a_ef )
      elo_ph4(i) = elo_ph4(i) * en * 1.e+3 !-> array with 17 values
 1234 continue                             !   of en. losses
      enddo
c   ....................................................................
c          3. COMPUTING OF CONSTANTS FOR COMPARISON FUNCTION:
c
       if(ibb.eq.1) then
         en1 = 1.e+9
         en2 = 10.
         v1 = 1.78e-2
         v2 = 1.e-10
         bt = alog10(phnu_totS(en2,v2)) - alog10(phnu_totS(en1,v1))
         bt = bt / (alog10(v1/v2))
       else
         en1 = 1000.
         en2 = 100.
         v1 = 2.e-4
         v2 = 2.e-3
         bt = alog10(phnu_totS(en1,v1)) - alog10(phnu_totS(en2,v2))
       endif
      if(rm_mu.le.1.d+3) then
      at = 1.05 * (v2**bt) * phnu_totS(en2,v2)
      else
      at = 1.25 * (v2**bt) * phnu_totS(en2,v2)
      endif
      at0 = at
      us2 = at / (1.-bt)
      us2_1 = 1. / us2
      us3 = .434294481 / (1. - bt)
      us4 = 2.302585093 * (-bt)
      return
      end
****************************************************************************
* N.4S
            FUNCTION getlphnuS(X)
*
      real*4 X
      COMMON /sok1S/ XMIN,STEP,XMAX
      common /sok1_nS/ C(19)
      X1 = alog10(X)
      if ((X1.lt..99999e+0).or.(X1.gt.9.0001e+0)) then
      print*,'ERROR IN FUNCTION GETLPHNUS: MUON ENERGY IS OUT OF RANGE'
      endif
      Y = (X1-XMIN)/STEP
      I = INT(Y+0.5)
      IF(I.LT.0.OR.X1.GT.XMAX) PRINT 1,X1,XMIN,XMAX
      Y = Y-I
      Z = Y*Y + 0.25
      getlphnuS = (Z-Y)*C(I+1) + (2.-(Z+Z))*C(I+2) + (Z+Y)*C(I+3)
      getlphnuS = exp(getlphnuS)
      RETURN
1     FORMAT('*MISTAKE*X1=',D23.16,'XMIN=',D23.16,'XMAX=',D23.16)
      END
****************************************************************************
* N.5S
            FUNCTION glphnuvS(X)
*
      real*4 X
      COMMON /sok1nS/ XMIN,STEP,XMAX
      common /sok1_n2S/ C(67)
      X1 = alog10(X)
      if ((X1.lt..99999e+0).or.(X1.gt.9.0001e+0)) then
      print*,'ERROR IN FUNCTION GLPHNUVS: MUON ENERGY IS OUT OF RANGE'
      endif
      Y = (X1-XMIN)/STEP
      I = INT(Y+0.5)
      IF(I.LT.0.OR.X1.GT.XMAX) PRINT 1,X1,XMIN,XMAX
      Y = Y-I
      Z = Y*Y + 0.25
      glphnuvS = (Z-Y)*C(I+1) + (2.-(Z+Z))*C(I+2) + (Z+Y)*C(I+3)
      RETURN
1     FORMAT('*MISTAKE*X1=',D23.16,'XMIN=',D23.16,'XMAX=',D23.16)
      END
****************************************************************************
* N.6S
         function getctphS(u)
*
      external getlphnuS
      real*8 z1(10),w(10),aw(10),a_ef,alfa,rm_e,rm_mu,r_e,avog,ro
      real*4 u
      common /constS/ alfa,rm_e,rm_mu,r_e,avog
      common /mediaS/ z1,w,aw,a_ef,ro,nsub
      if ((u.gt.1.0001e+9).or.(u.lt.9.9999e+0)) then
      print*,'ERROR IN FUNCTION GETCTPHS: MUON ENERGY IS OUT OF RANGE'
      endif
      aef = sngl(a_ef / (avog * ro))
      getctphS = aef / getlphnuS(u)
      return
      end
****************************************************************************
* N.7S
         function gctphvS(u)
*
      external glphnuvS
      real*8 z1(10),w(10),aw(10),a_ef,alfa,rm_e,rm_mu,r_e,avog,ro
      real*4 u
      common /constS/ alfa,rm_e,rm_mu,r_e,avog
      common /mediaS/ z1,w,aw,a_ef,ro,nsub
      if ((u.gt.1.0001e+9).or.(u.lt.9.9999e+0)) then
      print*,'ERROR IN FUNCTION GCTPHVS: MUON ENERGY IS OUT OF RANGE'
      endif
      aef = sngl(a_ef / (avog * ro))
      gctphvS = aef / glphnuvS(u)
      return
      end
************************************************************************
* N.8S
              FUNCTION getdedphS(X)
*
      real*4 X
      COMMON /sok5S/ XMIN,STEP,XMAX
      common /sok5_nS/ C(19)
      X1 = alog10(X)
       if ((X1.lt..99999e+0).or.(X1.gt.9.0001e+0)) then
       print*,'ERROR IN FUNCTION GETDEDPH: MUON ENERGY IS OUT OF RANGE'
       endif
      Y = (X1-XMIN)/STEP
      I = INT(Y+0.5)
      IF(I.LT.0.OR.X1.GT.XMAX) PRINT 1,X1,XMIN,XMAX
      Y = Y-I
      Z = Y*Y + 0.25
      getdedphS = (Z-Y)*C(I+1) + (2.-(Z+Z))*C(I+2) + (Z+Y)*C(I+3)
      getdedphS = (1.e+1)**(getdedphS)
      RETURN
1     FORMAT('*MISTAKE*X1=',D23.16,'XMIN=',D23.16,'XMAX=',D23.16)
      END
************************************************************************
* N.9S
              FUNCTION gdedphvS(X)
*
      real*4 X
      COMMON /sok5nS/ XMIN,STEP,XMAX
      common /sok5_n2S/ C(67)
      X1 = alog10(X)
       if ((X1.lt..99999e+0).or.(X1.gt.9.0001e+0)) then
       print*,'ERROR IN FUNCTION GDEDPHVS: MUON ENERGY IS OUT OF RANGE'
       endif
      Y = (X1-XMIN)/STEP
      I = INT(Y+0.5)
      IF(I.LT.0.OR.X1.GT.XMAX) PRINT 1,X1,XMIN,XMAX
      Y = Y-I
      Z = Y*Y + 0.25
      gdedphvS = (Z-Y)*C(I+1) + (2.-(Z+Z))*C(I+2) + (Z+Y)*C(I+3)
      gdedphvS = (1.e+1)**(gdedphvS)
      RETURN
1     FORMAT('*MISTAKE*X1=',D23.16,'XMIN=',D23.16,'XMAX=',D23.16)
      END
************************************************************************
* N.10S
              FUNCTION gdedphtS(X)
*
      real*4 X
      COMMON /sok5S/ XMIN,STEP,XMAX
      common /sok5_n3S/ C(19)
      X1 = alog10(X)
       if ((X1.lt..99999e+0).or.(X1.gt.9.0001e+0)) then
       print*,'ERROR IN FUNCTION GDEDPHTS: MUON ENERGY IS OUT OF RANGE'
       endif
      Y = (X1-XMIN)/STEP
      I = INT(Y+0.5)
      IF(I.LT.0.OR.X1.GT.XMAX) PRINT 1,X1,XMIN,XMAX
      Y = Y-I
      Z = Y*Y + 0.25
      gdedphtS = (Z-Y)*C(I+1) + (2.-(Z+Z))*C(I+2) + (Z+Y)*C(I+3)
      gdedphtS = (1.e+1)**(gdedphtS)
      RETURN
1     FORMAT('*MISTAKE*X1=',D23.16,'XMIN=',D23.16,'XMAX=',D23.16)
      END
****************************************************************************
* N.11S
       FUNCTION getcdnS(X,Y,lo)
*
      real*4 X,Y
      integer lo
       external getcdn1S,getcdn2S,getcdn3S,phnu_totS
       if (lo.eq.0) then
          if (Y.le..251188643) then
                getcdnS = getcdn1S(X,Y,lo)
               getcdnS = exp(getcdnS)
          else
               if (Y.le..794328234) then
                  getcdnS = getcdn2S(X,Y,lo)
                  getcdnS = exp(getcdnS)
               else
                 if (Y.le..965) then
                    getcdnS = getcdn3S(X,Y,lo)
                    getcdnS = exp(getcdnS)
                 else
                    getcdnS = phnu_totS(X,Y)
                 endif
               endif
          endif
       else
          if (Y.le.-6.e-1) then
                getcdnS = getcdn1S(X,Y,lo)
                getcdnS = exp(getcdnS)
          else
                if (Y.le.-1.e-1) then
                   getcdnS = getcdn2S(X,Y,lo)
                   getcdnS = exp(getcdnS)
                else
                   if (Y.le.-1.54727e-2) then
                     getcdnS = getcdn3S(X,Y,lo)
                     getcdnS = exp(getcdnS)
                   else
                     Y1 = (1.e+1)**Y
                     getcdnS = phnu_totS(X,Y1)
                   endif
                endif
          endif
       endif
      if (getcdnS.lt.0.e+0) getcdnS = 0.e+0
      return
      end
****************************************************************************
* N.12S
       FUNCTION getcdn1S(X,Y,loga)
*
      real*4 X,Y
      integer loga
      common /mum8S/ C1(4648)
      common /sok_2_1S/ NX,NY,X0,SX,Y0,SY
      X_1=alog10(X)
      if ((X_1.lt..99999e+0).or.(X_1.gt.9.0001e+0)) then
      print*,'ERROR IN FUNCTION GETCDN1S: MUON ENERGY IS OUT OF RANGE'
      endif
      if (loga.eq.0) then
      Y_1=alog10(Y)
      else
      Y_1=Y
      endif
      if ((Y_1.lt.-11.001).or.(Y_1.gt.-5.9999e-1)) then
      print*,'ERROR IN FUNCTION GETCDN1S: EN. TRANSFER IS OUT OF RANGE'
      endif
      A3=(X_1-X0)/SX
      B3=(Y_1-Y0)/SY
      M1=INT(A3+.5)
      M2=INT(B3+.5)
      M3=NX+2
      IF(M1.LT.0.OR.M1.GE.NX.OR.M2.LT.0.OR.M2.GE.NY) THEN
      PRINT 1,X_1,M1,Y_1,M2
      ENDIF
      A3=A3-M1
      B3=B3-M2
      M1=M2*M3+M1+1
      M2=M1+M3
      M3=M2+M3
      A2=A3*A3+.25
      B2=B3*B3+.25
      A1=A2-A3
      B1=B2-B3
      A3=A2+A3
      B3=B2+B3
      A2=2.-(A2+A2)
      B2=2.-(B2+B2)
      getcdn1S=(A1*C1(M1)+A2*C1(M1+1)+A3*C1(M1+2))*B1
     2      +(A1*C1(M2)+A2*C1(M2+1)+A3*C1(M2+2))*B2
     3      +(A1*C1(M3)+A2*C1(M3+1)+A3*C1(M3+2))*B3
      RETURN
1     FORMAT('GETCDN1S: *MISTAKE*X= ',D23.16,' MX= ',I4,' Y= ',D23.16,
     +' MY= ',I4)
      END
****************************************************************************
* N.13S
*
       FUNCTION getcdn2S(X,Y,loga)
*
      real*4 X,Y
      integer loga
      common /mum9S/ C1(4399)
      common /sok_2_2S/ NX,NY,X0,SX,Y0,SY
      X_1=alog10(X)
      if ((X_1.lt..99999e+0).or.(X_1.gt.9.0001e+0)) then
      print*,'ERROR IN FUNCTION GETCDN2S: MUON ENERGY IS OUT OF RANGE'
      endif
      if (loga.eq.0) then
      Y_1=alog10(Y)
      else
      Y_1=Y
      endif
      if ((Y_1.lt.-.60001).or.(Y_1.gt.-.99999e-1)) then
      print*,'ERROR IN FUNCTION GETCDN2S: EN. TRANSFer IS OUT OF RANGE'
      endif
      A3=(X_1-X0)/SX
      B3=(Y_1-Y0)/SY
      M1=INT(A3+.5)
      M2=INT(B3+.5)
      M3=NX+2
      IF(M1.LT.0.OR.M1.GE.NX.OR.M2.LT.0.OR.M2.GE.NY) THEN
      PRINT 1,X_1,M1,Y_1,M2
      ENDIF
      A3=A3-M1
      B3=B3-M2
      M1=M2*M3+M1+1
      M2=M1+M3
      M3=M2+M3
      A2=A3*A3+.25
      B2=B3*B3+.25
      A1=A2-A3
      B1=B2-B3
      A3=A2+A3
      B3=B2+B3
      A2=2.-(A2+A2)
      B2=2.-(B2+B2)
      getcdn2S=(A1*C1(M1)+A2*C1(M1+1)+A3*C1(M1+2))*B1
     2      +(A1*C1(M2)+A2*C1(M2+1)+A3*C1(M2+2))*B2
     3      +(A1*C1(M3)+A2*C1(M3+1)+A3*C1(M3+2))*B3
      RETURN
1     FORMAT('GCDN2S:*MISTAKE*X=',D23.16,'MX=',I4,'Y=',D23.16,'MY=',I4)
      END
****************************************************************************
* N.14S
*
       FUNCTION getcdn3S(X,Y,loga)
*
      real*4 X,Y
      integer loga
      common /mum10S/ C2(8549)
      common /sok_2_3S/ NX,NY,X0,SX,Y0,SY
      X_1=alog10(X)
      if ((X_1.lt..99999e+0).or.(X_1.gt.9.0001e+0)) then
      print*,'ERROR IN FUNCTION GETCDN3S: MUON ENERGY IS OUT OF RANGE'
      endif
      if (loga.eq.0) then
      Y_1=alog10(Y)
      else
      Y_1=Y
      endif
      if ((Y_1.lt.-1.0001e-1).or.(Y_1.gt.1.e-6)) then
      print*,'ERROR IN FUNCTION GETCDN3S: EN. TRANSFER IS OUT OF RANGE'
      endif
      A3=(X_1-X0)/SX
      B3=(Y_1-Y0)/SY
      M1=INT(A3+.5)
      M2=INT(B3+.5)
      M3=NX+2
      IF(M1.LT.0.OR.M1.GE.NX.OR.M2.LT.0.OR.M2.GE.NY) THEN
      PRINT 1,X_1,M1,Y_1,M2
      ENDIF
      A3=A3-M1
      B3=B3-M2
      M1=M2*M3+M1+1
      M2=M1+M3
      M3=M2+M3
      A2=A3*A3+.25
      B2=B3*B3+.25
      A1=A2-A3
      B1=B2-B3
      A3=A2+A3
      B3=B2+B3
      A2=2.-(A2+A2)
      B2=2.-(B2+B2)
      getcdn3S=(A1*C2(M1)+A2*C2(M1+1)+A3*C2(M1+2))*B1
     2      +(A1*C2(M2)+A2*C2(M2+1)+A3*C2(M2+2))*B2
     3      +(A1*C2(M3)+A2*C2(M3+1)+A3*C2(M3+2))*B3
      RETURN
1     FORMAT('*MISTAKE*X=',D23.16,'MX=',I4,'Y=',D23.16,'MY=',I4)
      END
****************************************************************************
* N.15S
          SUBROUTINE getvphS(emw,vbr,itr)
*
      real*4 emw,vbr
      integer itr
      external getcdnS
      parameter (lo=1)
      common /generalS/ emin,vmin,emph
      common /mcefS/ mcb1,mcb2,mcp1,mcp2,mcn1,mcn2,mce1,mce2
      common /ph_refS/ at,bt,us2,us2_1,us3,us4,at0
      mcn1 = mcn1 + 1
        if (itr.eq.0) then
          vtr=amax1((emin/emw),(emph/emw))
        else
          vtr=amax1(vmin,(emph/emw))
        endif
      us1 = vtr**(1. - bt)
      algemin = us2 * (1. - us1)
  155 ax = algemin * rndm_mum(5)
      vbr = (alog(us1 + (ax * us2_1))) * us3
      mcn2 = mcn2 + 1
      y1 = getcdnS(emw,vbr,lo)
      y2 = at * exp(vbr * us4)
      yc = y2 * rndm_mum(8)
           if (y2.lt.y1) then
           fnew = y1 / y2
           at = at * (fnew)
           fnew1 = at / at0
           us2 = at / (1.-bt)
           us2_1 = 1. / us2
           us3 = .434294481 / (1. - bt)
           us4 = 2.302585093 * (-bt)
       print*,'***** COMPARISON FUNCTION FOR PH.NUC. SIMULATION: *****'
           print*,'Variable  AT has been increased with factor',fnew
           print*,'Now it differs from init. value with factor',fnew1
       print*,'   No reasons to trouble, it is for information only'
             if (fnew1.gt.1.5) then
       print*,'************ ERROR ************ f(v) < d_Sigma/d_v ****'
       print*,'**** VARIABLE  AT  HAS BEEN INCREASED TOO MUCH !!! ****'
             endif
       print*,'*******************************************************'
           endif
        if (y1.ge.yc) then
        vbr = 1.e+1**vbr
        else
        goto 155
        endif
      return
      end
****************************************************************************
*********************** DELTA-ELECTRONS SUBROUTINES : **********************
****************************************************************************
* E.1S
*
      function getcdeS(e,v)
      real*4 e,v
      common /zavS/ z
c     GeV:
      parameter (ame=0.51099907e-3)
c   parameter (amu=0.105658389)   ! GeV
c     cm:
      parameter (re=2.81794092e-13)
      parameter (alpha=1./137.036)
      parameter (pi=3.141592654)
c   parameter (bmu=amu**2/(2.*ame))
      parameter (coeff0=2.*pi*ame*re**2)
      parameter (coeff1=alpha/(2.*pi))
        parameter (sok1=2./ame)
c       parameter (sok2=5.88138263)
        real*8 alfa,rm_e,rm_mu,r_e,avog
        common /constS/ alfa,rm_e,rm_mu,r_e,avog
        common /exer1S/ fa
c
        amu = 1.e-3 * sngl(rm_mu)
        bmu=amu**2/(2.*ame)
        sok2 = alog(4. / (amu * amu) )
c
      vpmax=e/(e+bmu)
      ep=v*e
           if (v.ge.vpmax) then
             getcdeS=0.
             return
           endif
      sigma0=coeff0*z*(1.-v/vpmax+.5*v*v)/(v*ep)
      a1=alog(1.+sok1*ep)
      a3=sok2+alog(e*(e-ep))
      getcdeS=sigma0*(1.+coeff1*a1*(a3-a1))*fa
      return
      end
****************************************************************************
* E.2S
*
      function edbrtS(e)
      external simps
      real*8 alfa,rm_e,rm_mu,r_e,avog,z1(10),w(10),aw(10),a_ef,ro
      real*4 e
c
c  From initial subroutine MED_CONSS:
c
      common /constS/ alfa,rm_e,rm_mu,r_e,avog
      common /mediaS/ z1,w,aw,a_ef,ro,nsub
      common /zavS/ z
      common /exer1S/ fa
c     GeV:
      parameter (ame=0.51099907e-3)
c      parameter (amu=0.105658389)   !  GeV
c     cm:
      parameter (re=2.81794092e-13)
      parameter (alpha=1./137.036)
      parameter (pi=3.141592654)
c      parameter (bmu=amu**2/(2.*ame))
      parameter (coeff0=2.*pi*ame*re**2)
      parameter (coeff1=alpha/(2.*pi))
      parameter (sok1=2./ame)
c      parameter (sok2=5.88138263)
      parameter (lim=2000)
      dimension aux(0:2000)
c
      amu = 1.e-3 * sngl(rm_mu)
      bmu=amu**2/(2.*ame)
      sok2 = alog(4. / (amu * amu) )
c
      vpmin = alog(7.5e-8 / e)
      vpmax = e / (e + bmu)
      vpmax1 = alog(vpmax)
      st = (vpmax1 - vpmin) * 5.e-4
      do i=0,lim
        v = exp(vpmin + st * float(i))
        ep = v * e
        if (v.ge.vpmax) then
         aux(i) = 0.
        else
         sigma0 = coeff0 * z * v * (1. - v/vpmax + .5 * v * v) / ep
         a1 = alog(1. + sok1 * ep)
         a3 = sok2 + alog(e * (e - ep))
         aux(i) = sigma0 * coeff1 * a1 * (a3 - a1)
        endif
      enddo
      edbrtS = simps(aux,vpmin,vpmax1,lim) * e * 1.e+3
      edbrtS = fa * edbrtS * sngl(avog * ro / a_ef)
      return
      end
****************************************************************************
* E.3S
*
        function beblS(ene)
*
      real*8 c_0,z_a,ri_z,x_0,x_1,a,rm,con1,con2,hnu,c,e
      real*8 beta,p,w_max,x,theta1,theta2,delta,difx1_x,e_loss
      real*8 alfa,rm_e,rm_mu,r_e,avog,z1(10),w(10),aw(10),a_ef,ro
      real*4 ene
      common /constS/ alfa,rm_e,rm_mu,r_e,avog ! from initial subroutine
      common /mediaS/ z1,w,aw,a_ef,ro,nsub     !       MED_CONSS
      common /med_ionS/ z_a,ri_z,x_0,x_1,a,rm  !
      common /exer1S/ fa
      parameter (c_0=1.535d-1)
c
      e = dble(ene) * 1.d+3
      con1 = c_0 * z_a * ro
      con2 = (2.d+0 * rm_e)/(rm_mu * rm_mu * ri_z * ri_z)
      hnu = 2.8816d+1 * dsqrt(ro*z_a)/1.d+6
      c = (2.d+0 * dlog(ri_z/hnu)) + 1.d+0
c
      beta = dsqrt(1.d+0 - ((rm_mu * rm_mu)/(e * e)))
      p = beta * e
      w_max=(2.d+0*rm_e*p*p)/((rm_mu*rm_mu)+(rm_e*rm_e)+(2.d+0*rm_e*e))
      x = dlog10(p/rm_mu)
             if(x.gt.x_0) then
             theta1 = 1.d+0
             else
             theta1 = 0.d+0
             delta = 0.d+0
             goto 1
             endif
                if(x_1.gt.x) then
                theta2 = 1.d+0
                else
                theta2 = 0.d+0
                difx1_x=0.d+0
                goto 2
                endif
       difx1_x = (x_1 - x)**rm
 2     delta = theta1 * ((4.6052d+0 * x) + (a * theta2 * difx1_x) - c)
 1     e_loss=(con1/(beta*beta))*((dlog(con2*p*p*w_max))+((w_max*w_max)/
     +(4.d+0*e*e))-(2.d+0*beta*beta)-delta)
       beblS=sngl(e_loss) * fa
       return
       end
****************************************************************************
* E.4S
*
       subroutine elec1S
*
       external getcdeS,dsimps
       real*8 dsimps
       real*8 um
       real*8 aux1(0:2000),aux2(0:2000),h1,h2
       real*8 alfa,rm_e,rm_mu,r_e,avog,z1(10),w(10),aw(10),a_ef,ro
       common /constS/ alfa,rm_e,rm_mu,r_e,avog ! from initial subroutine
       common /mediaS/ z1,w,aw,a_ef,ro,nsub     !       MED_CONSS
       common /generalS/ emin,vmin,emph         !
       common /ctel_in1S/ crt_el1(17),crt_el2(17)
       common /elel_in1S/ elo_el1(17),elo_el2(17)
       common /elel_in2S/ elel_bb(17),elel_bbb(17)
       common /elel_in3S/ elel_tot(101)
       common /help_1S/ aux1,aux2
       common /exer2S/ noca
c ....................................................................
c     PREPARATION OF ARRAYS WITH ENERGY LOSSES AND AVERAGED FREE PATH
c                        FOR KNOCK-ON-ELECTRONS:
c
c                     a) energy transfers > EMIN
c
      lim = 2000
      do i=1,17
      en = float(i)
      en = (1.e+1)**(5.e-1 + (5.e-1 * en))
      vmi = alog(emin / en) !--------------> The lower limit for integration
      um = (rm_mu * rm_mu * 1.d-3) / (2.d+0 * rm_e)
      vma = sngl(um)
      vma = 1. / ( 1.e+0 + (vma / en) )
      vma = alog(vma)       !--------------> The upper limit for integration
      vst = (vma - vmi) / float(lim) !--> step for a rel. en. transfers grid
c
      do j=0,lim
      rnu = vmi + vst*(float(j))
      rnu = exp(rnu)
      aux1(j) = dble(getcdeS(en,rnu) * rnu)        !-> array to be integrated
c                                                 !   to get mean free path
      aux2(j) = aux1(j) * rnu                     !-> array to be integrated
      enddo                                       !   for getting en. losses
c
      h1 = dble(vmi)
      h2 = dble(vma)
      crt_el1(i) = sngl(dsimps(aux1,h1,h2,lim))
      if(crt_el1(i).le.0.e+0) then
      crt_el1(i) = 1.e+10
      goto 94765
      endif
      crt_el1(i) = (sngl(a_ef/(avog*ro)))/crt_el1(i) !-> array with 17 values
c                                                    !   of free path
94765 continue
      elo_el1(i) = sngl( dsimps(aux2,h1,h2,lim) * avog * ro / a_ef )
      elo_el1(i) = elo_el1(i) * en * 1.e+3
      elo_el1(i) = alog10(elo_el1(i)) !-> array with 17 values of en. losses
      enddo
c                     b) energy transfers > VMIN
      do i=1,17
      en = float(i)
      en = (1.e+1)**(5.e-1 + (5.e-1 * en))
      vmi = alog(vmin)      !--------------> The lower limit for integration
      um = (rm_mu * rm_mu * 1.d-3) / (2.d+0 * rm_e)
      vma = sngl(um)
      vma = 1. / ( 1.e+0 + (vma / en) )
      vma = alog(vma)       !--------------> The upper limit for integration
      vst = (vma - vmi) / float(lim) !--> step for a rel. en. transfers grid
c
      do j=0,lim
      rnu = vmi + vst*(float(j))
      rnu = exp(rnu)
      aux1(j) = dble(getcdeS(en,rnu) * rnu)        !-> array to be integrated
c                                                 !   to get mean free path
      aux2(j) = aux1(j) * rnu                     !-> array to be integrated
      enddo                                       !   for getting en. losses
c
      h1 = dble(vmi)
      h2 = dble(vma)
      crt_el2(i) = sngl(dsimps(aux1,h1,h2,lim))
      if(crt_el2(i).le.0.e+0) then
      crt_el2(i) = 1.e+10
      goto 94766
      endif
      crt_el2(i) = (sngl(a_ef/(avog*ro)))/crt_el2(i) !-> array with 17 values
94766 continue
      crt_el2(i) = alog(crt_el2(i))                  !   of free path
      if (noca.eq.0) crt_el2(i)=45. !-> no cat. losses for knock-on electrons
c
      elo_el2(i) = sngl( dsimps(aux2,h1,h2,lim) * avog * ro / a_ef )
      elo_el2(i) = elo_el2(i) * en * 1.e+3
      if(elo_el2(i).le.0.e+0) elo_el2(i) = 1.e-8
      if (noca.eq.0) elo_el2(i)=1.e-30!->no cat. losses for knock-on electrons
      elo_el2(i) = alog10(elo_el2(i)) !-> array with 17 values of en. losses
      enddo
c                     c) energy transfers > 0
      do i=1,17
      en = float(i)
      en = (1.e+1)**(5.e-1 + (5.e-1 * en))
      elel_bb(i) = beblS(en)                !--> Ion. en. losses (Bethe-Bloch)
      elel_bbb(i) = edbrtS(en) + elel_bb(i)  !--> BB + bremsstahlung e-diagram
      enddo
c                     d) total energy losses below 10 GeV
c                 (Bethe-Bloch + e-diagrams for bremsstrahlung)
      do i=1,101
      en = float(i)
      en = (1.e+1)**(alog10(0.14) - .02 + (.02 * en))
      elel_tot(i) = edbrtS(en) + beblS(en)
      enddo
c
      return
      end
****************************************************************************
* E.5S
           FUNCTION getlelecS(X)
*
      real*4 X
      COMMON /sok1S/ XMIN,STEP,XMAX
      common /sok1_eS/ C(19)
      X1 = alog10(X)
       if ((X1.lt..99999e+0).or.(X1.gt.9.0001e+0)) then
       print*,'ERROR IN FUNCTION GETLELECS: MUON ENERGY IS OUT OF RANGE'
       endif
      Y = (X1-XMIN)/STEP
      I = INT(Y+0.5)
      IF(I.LT.0.OR.X1.GT.XMAX) PRINT 1,X1,XMIN,XMAX
      Y = Y-I
      Z = Y*Y + 0.25
      getlelecS = (Z-Y)*C(I+1) + (2.-(Z+Z))*C(I+2) + (Z+Y)*C(I+3)
      RETURN
1     FORMAT('*MISTAKE*X1=',D23.16,'XMIN=',D23.16,'XMAX=',D23.16)
      END
****************************************************************************
* E.6S
           FUNCTION glelecvS(X)
*
      real*4 X
      COMMON /sok1S/ XMIN,STEP,XMAX
      common /sok1_e2S/ C(19)
      common /exer2S/ noca
      if (noca.eq.0) then
      glelecvS = 1.e+34
      return
      endif
      X1 = alog10(X)
       if ((X1.lt..99999e+0).or.(X1.gt.9.0001e+0)) then
       print*,'ERROR IN FUNCTION GLELECVS: MUON ENERGY IS OUT OF RANGE'
       endif
      Y = (X1-XMIN)/STEP
      I = INT(Y+0.5)
      IF(I.LT.0.OR.X1.GT.XMAX) PRINT 1,X1,XMIN,XMAX
      Y = Y-I
      Z = Y*Y + 0.25
      glelecvS = (Z-Y)*C(I+1) + (2.-(Z+Z))*C(I+2) + (Z+Y)*C(I+3)
      glelecvS = exp(glelecvS)
      RETURN
1     FORMAT('*MISTAKE*X1=',D23.16,'XMIN=',D23.16,'XMAX=',D23.16)
      END
****************************************************************************
* E.7S
           function getctelS(u)
*
      external getlelecS
      real*8 z1(10),w(10),aw(10),a_ef,alfa,rm_e,rm_mu,r_e,avog,ro
      real*4 u
      common /constS/ alfa,rm_e,rm_mu,r_e,avog
      common /mediaS/ z1,w,aw,a_ef,ro,nsub
      if ((u.gt.1.0001e+9).or.(u.lt.9.9999e+0)) then
      print*,'ERROR IN FUNCTION GETCTELS: MUON ENERGY IS OUT OF RANGE'
      endif
      aef = sngl(a_ef / (avog * ro))
      getctelS = aef / getlelecS(u)
      return
      end
****************************************************************************
* E.8S
           function gctelvS(u)
*
      external glelecvS
      real*8 z1(10),w(10),aw(10),a_ef,alfa,rm_e,rm_mu,r_e,avog,ro
      real*4 u
      common /constS/ alfa,rm_e,rm_mu,r_e,avog
      common /mediaS/ z1,w,aw,a_ef,ro,nsub
      common /exer2S/ noca
      if (noca.eq.0) then
      gctelvS = 1.e-37
      return
      endif
      if ((u.gt.1.0001e+9).or.(u.lt.9.9999e+0)) then
      print*,'ERROR IN FUNCTION GCTELVS: MUON ENERGY IS OUT OF RANGE'
      endif
      aef = sngl(a_ef / (avog * ro))
      gctelvS = aef / glelecvS(u)
      return
      end
************************************************************************
* E.9S
             FUNCTION getdedelS(X)
*
      real*4 X
      COMMON /sok5S/ XMIN,STEP,XMAX
      common /sok5_eS/ C(19)
      X1 = alog10(X)
       if ((X1.lt..99999e+0).or.(X1.gt.9.0001e+0)) then
       print*,'ERROR IN FUNCTION GETDEDELS: MUON ENERGY IS OUT OF RANGE'
       endif
      Y = (X1-XMIN)/STEP
      I = INT(Y+0.5)
      IF(I.LT.0.OR.X1.GT.XMAX) PRINT 1,X1,XMIN,XMAX
      Y = Y-I
      Z = Y*Y + 0.25
      getdedelS = (Z-Y)*C(I+1) + (2.-(Z+Z))*C(I+2) + (Z+Y)*C(I+3)
      getdedelS = (1.e+1)**(getdedelS)
      RETURN
1     FORMAT('*MISTAKE*X1=',D23.16,'XMIN=',D23.16,'XMAX=',D23.16)
      END
************************************************************************
* E.10S
             FUNCTION gdedelvS(X)
*
      real*4 X
      COMMON /sok5S/ XMIN,STEP,XMAX
      common /sok5_e2S/ C(19)
      common /exer2S/ noca
      if (noca.eq.0) then
      gdedelvS = 1.e-36
      return
      endif
      X1 = alog10(X)
       if ((X1.lt..99999e+0).or.(X1.gt.9.0001e+0)) then
       print*,'ERROR IN FUNCTION GDEDELVS: MUON ENERGY IS OUT OF RANGE'
       endif
      Y = (X1-XMIN)/STEP
      I = INT(Y+0.5)
      IF(I.LT.0.OR.X1.GT.XMAX) PRINT 1,X1,XMIN,XMAX
      Y = Y-I
      Z = Y*Y + 0.25
      gdedelvS = (Z-Y)*C(I+1) + (2.-(Z+Z))*C(I+2) + (Z+Y)*C(I+3)
      gdedelvS = (1.e+1)**(gdedelvS)
      RETURN
1     FORMAT('*MISTAKE*X1=',D23.16,'XMIN=',D23.16,'XMAX=',D23.16)
      END
****************************************************************************
* E.11S
             FUNCTION gdedelt1S(X)
*
      real*4 X
      COMMON /sok5S/ XMIN,STEP,XMAX
      common /sok5_e4S/ C(19)
      X1 = alog10(X)
       if ((X1.lt..99999e+0).or.(X1.gt.9.0001e+0)) then
       print*,'ERROR IN FUNCTION GDEDELT1S: MUON ENERGY IS OUT OF RANGE'
       endif
      Y = (X1-XMIN)/STEP
      I = INT(Y+0.5)
      IF(I.LT.0.OR.X1.GT.XMAX) PRINT 1,X1,XMIN,XMAX
      Y = Y-I
      Z = Y*Y + 0.25
      gdedelt1S = (Z-Y)*C(I+1) + (2.-(Z+Z))*C(I+2) + (Z+Y)*C(I+3)
      RETURN
1     FORMAT('*MISTAKE*X1=',D23.16,'XMIN=',D23.16,'XMAX=',D23.16)
      END
****************************************************************************
* E.12S
             FUNCTION gdedelt2S(X)
*
      real*4 X
      COMMON /sok5etS/ XMIN,STEP,XMAX
      common /sok5_e5S/ C(103)
      X1 = alog10(X)
       if ((X1.lt.-.8e+0).or.(X1.gt.1.08e+0)) then
       print*,'ERROR IN FUNCTION GDEDELT2S: MUON ENERGY IS OUT OF RANGE'
       endif
      Y = (X1-XMIN)/STEP
      I = INT(Y+0.5)
      IF(I.LT.0.OR.X1.GT.XMAX) PRINT 1,X1,XMIN,XMAX
      Y = Y-I
      Z = Y*Y + 0.25
      gdedelt2S = (Z-Y)*C(I+1) + (2.-(Z+Z))*C(I+2) + (Z+Y)*C(I+3)
      RETURN
1     FORMAT('*MISTAKE*X1=',D23.16,'XMIN=',D23.16,'XMAX=',D23.16)
      END
****************************************************************************
* E.13S
             FUNCTION gdeionS(X)
*
      real*4 X
      external gdedelt1S,gdedelt2S
       if ((X.lt..159).or.(X.gt.1.0001e+9)) then
       print*,'ERROR IN FUNCTION GDEDIONS: MUON ENERGY IS OUT OF RANGE'
       endif
      if(x.le.10.) then
      gdeionS = gdedelt2S(x)
      else
      gdeionS = gdedelt1S(x)
      endif
      return
      end
****************************************************************************
* E.14S
             FUNCTION gdedelbbS(X)
*
      real*4 X
      COMMON /sok5S/ XMIN,STEP,XMAX
      common /sok5_e3S/ C(19)
      X1 = alog10(X)
       if ((X1.lt..99999e+0).or.(X1.gt.9.0001e+0)) then
       print*,'ERROR IN FUNCTION GDEDELBBS: MUON ENERGY IS OUT OF RANGE'
       endif
      Y = (X1-XMIN)/STEP
      I = INT(Y+0.5)
      IF(I.LT.0.OR.X1.GT.XMAX) PRINT 1,X1,XMIN,XMAX
      Y = Y-I
      Z = Y*Y + 0.25
      gdedelbbS = (Z-Y)*C(I+1) + (2.-(Z+Z))*C(I+2) + (Z+Y)*C(I+3)
      RETURN
1     FORMAT('*MISTAKE*X1=',D23.16,'XMIN=',D23.16,'XMAX=',D23.16)
      END
****************************************************************************
* E.15S
         SUBROUTINE getvelS(emw,vbr1,itr)
*
      external getcdeS
      real*8 vbr,rmd,vtr,vtr1,rvec_own
c      real*8 emind,vmind,emwd
      real*4 emw,vbr1
      integer itr
      parameter (c2=2.549551e-28)
c      parameter (len=1)
c      common /r48/ rvec
      common /zavS/ zm
      common /generalS/ emin,vmin,emph
      common /mcefS/ mcb1,mcb2,mcp1,mcp2,mcn1,mcn2,mce1,mce2
      mce1 = mce1 + 1
c      emind = dble(emin)
c      vmind = dble(vmin)
c      emwd = dble(emw)
        if(itr.eq.0) then
         vtr = dble(emin/emw)
        else
         vtr = dble(vmin)
        endif
      vtr1 = 1.d+0 - vtr
      coef2 = c2 * zm *  ( 1. + ( 3.2e-2 * alog(emw) ) )
  155 call rm48_own(rvec_own)
      rmd=rvec_own
      mce2 = mce2 + 1
      vbr = vtr / (vtr + (vtr1 * rmd))
      if(vbr.ge.1.d+0) vbr=.999999999999d+0
      vbr1=sngl(vbr)
      y1 = getcdeS(emw,vbr1)
      y2 = coef2 / ( emw * vbr1 * vbr1)
      yc = y2 * rndm_mum(8)
           if(y2.lt.y1) then
           print*,'*** ERROR IN GETVELS: COMP.FUNCTION IS TOO SMALL ***'
           endif
                if (y1.ge.yc) then
                  goto 154
                else
                  goto 155
                endif
  154 return
      end
****************************************************************************
c -----------------------------
c  Version 1.6 - April 16, 2003                     MUM = MUons + Medium
c -----------------------------
c
c                    MUM1_6_3.F - sets of routines for the second medium
************************************************************************
c                THIS IS THE PART OF THE MUM PACKAGE FOR
c   THE 3RD MEDIUM. PLEASE READ MANUAL AT THE FIRST LINES OF MUM1_6.F
c      AND COMMENTS TO ALL THE ROUTINES (WHICH ARE IDENTICAL) THERE
************************************************************************
* C.1_3
*
          SUBROUTINE init_mu3(imed,ipn,ibre,em,vm,ilep,iqcd,lux)
c
      real*4 em,vm,em1,vm1
      real*4 v(13)
c
      integer imed,imed1,ipn,ibre,ilep,iqcd,lux
      integer ist(4)
c
      character *38 mum_card_name
c
      data v /5.3e-3,1.5e-2,4.9e-3,5.6e-3,5.7e-3,5.7e-3,2.0e-2,
     +        2.3e-2,1.8e-2,1.4e-2,1.1e-2,2.0e-2,2.0e-2/
c
      common /card_name/ mum_card_name
      common /init_calls/ ist
c
      ist(3) = ist(3) + 1
      lux = 2
c
c
c Opening card file for writing, making record and some screen output:
c
      open(23,file=mum_card_name, status='unknown', access='append',
     +form='formatted')
c
      write(23,*) 'Module initialized             : INIT_MU3'
c
      write(*,*) 'Initialization: INIT_MU3...'
c
c
c Checking (and changing if needed) variables IMED, EM AND VM:
c
c     IMED:
c
      if(imed.eq.0) then
         imed1 = 1
         write(*,505)  imed1
         write(*,*) ' '
      else
         if(imed.gt.0) then
            if(imed.gt.13) then
               imed1 = 1
               write(*,505)  imed1
               write(*,*) ' '
            else
               imed1 = imed
            endif
         else
            if(imed.lt.-13) then
               imed1 = -1
               write(*,505)  imed1
               write(*,*) ' '
            else
               imed1 = imed
            endif
         endif
      endif
c
c     EM:
c
      if(em.gt.0.5) then
         em1 = 0.5
         write(*,504)  em1
         write(*,*) ' '
      else
         if(em.lt.0.01) then
            em1 = 0.01
            write(*,504) em1
            write(*,*) ' '
         else
            em1 = em
         endif
      endif
c
c     VM:
c
      if(ilep.eq.1) then
         if(vm.lt.0.0001) then
             vm1 = 0.0001
             write(*,502)  vm1
             write(*,*) ' '
         else
             if(vm.gt.0.2) then
                vm1 = 0.2
                write(*,502)  vm1
                write(*,*) ' '
             else
                vm1 = vm
             endif
         endif
      else
         if(imed1.gt.0) then
            if(vm.ge.v(imed1)) then
               vm1 = v(imed1)
               write(*,502)  vm1
               write(*,*) ' '
            else
               if(vm.lt.0.0001) then
                  vm1 = 0.0001
                  write(*,502)  vm1
                  write(*,*) ' '
               else
                  vm1 = vm
               endif
            endif
         else
            if(vm.ge.4.e-3) then
               vm1 = 4.e-3
               write(*,502)  vm1
               write(*,*) ' '
            else
               if(vm.lt.0.0001) then
                  vm1 = 0.0001
                  write(*,502)  vm1
                  write(*,*) ' '
               else
                  vm1 = vm
               endif
            endif
         endif
      endif
c
c Making media, setting parameters:
c
      call med_cons3(imed1,ipn,ibre,em1,vm1,ilep,iqcd)
      CALL PREPARE_DECAY3
c
c Computing bremsstrahlung: energy losses, cross-sections,
c constants for comparison function etc.:
c
      call gamma13
c
c Computing e+e- pair production: energy losses, cross-sections,
c comparison function and its integral etc:
c
      call pair13
c
c Computing photonuclear interaction: energy losses, cross-sections,
c etc.:
c
      if(iqcd.eq.1) call QCD_CORR3
      call phnu13
c
c Computing D-electrons production: energy losses, cross-sections, etc.:
c
      call elec13
c
c Computing continuous energy losses:
c
      call enlos3
c
c Cooking 1-dimensional real*4 splines with equidistant grid:
c
      call spl13
c
c Ccooking 1-dimensional real*8 splines with equidistant grid:
c
      call dspl13
c
c Cooking 1-dimensional real*8 splines with non-equidistant grid:
c
      call dsplq13
c
c Cooking 2-dimensional real*4 splines with equidistant grid:
c
      call spl23
c
c Cooking different kinds of splines:
c
      call frepathv3
      call spl2_23
c
c Recording to the MUM run card:
c
      call prinfo3(imed1,ipn,ibre,em1,vm1,ilep,iqcd)
c
      close (23)
      return
  502 format (' !!! Variable Vcut out of range, has been changed for Vcu
     +t = ',f6.4,' !!!')
  504 format (' !!! Variable Ecut out of range, has been changed for Ecu
     +t = ',f6.4,' !!!')
  505 format (' !!! Variable IMED out of range, has been changed for IME
     +D = ',I3,' !!!')
      end
c----------------------------------------------------------------------
* C.1a_3
*
      subroutine prinfo3(imed,ipn,ibre,em,vm,ilep,iqcd)
*
      real*8 alfa,rm_e,rm_mu,r_e,z1(10),w(10),aw(10),n(10)
      real*8 a_ef,avog,ro
      real*8 z_a,ri_z,x_0,x_1,a,rm
      real*4 em,vm
      integer imed,ipn,ibre,ilep,iqcd
      integer nsub
      character *38 mum_card_name
c
      common /const3/ alfa,rm_e,rm_mu,r_e,avog
      common /media3/ z1,w,aw,a_ef,ro,nsub
      common /med_ion3/ z_a,ri_z,x_0,x_1,a,rm
      common /toprint3/ n
      common /exer13/ fa
      common /exer23/ noca
      common /card_name/ mum_card_name
c
      open(23,file=mum_card_name, status='unknown', access='append',
     +form='formatted')
c
      if (ilep.eq.1) then
         write(23,501) ilep
      else
         write(23,502) ilep
      endif
c
      if (abs(imed).eq.1) write(23,601) imed
      if (abs(imed).eq.2) write(23,602) imed
      if (abs(imed).eq.3) write(23,603) imed
      if (abs(imed).eq.4) write(23,604) imed
      if (abs(imed).eq.5) write(23,605) imed
      if (abs(imed).eq.6) write(23,606) imed
      if (abs(imed).eq.7) write(23,607) imed
      if (abs(imed).eq.8) write(23,608) imed
      if (abs(imed).eq.9) write(23,609) imed
      if (abs(imed).eq.10) write(23,610) imed
      if (abs(imed).eq.11) write(23,611) imed
      if (abs(imed).eq.12) write(23,612) imed
      if (abs(imed).eq.13) write(23,613) imed
c
      if(imed.gt.0) then
      write(23,*)
     + 'Distance expressed in          : cm (IMED is positive)'
      else
      write(23,*)
     + 'Distance expressed in          : g/cm**3 (IMED is negative)'
      endif
c
      write(23,503) em
      write(23,504) vm
c
      write(23,*) 'Cross-section for absorption'
      if (ipn.eq.1) then
          write(23,505) ipn
      else
          write(23,506) ipn
      endif
c
      write(23,*) 'QCD corrections by'
      if (iqcd.eq.1) then
         write(23,507) iqcd
      else
         write(23,508) iqcd
      endif
c
      if(ibre.eq.1) then
         write(23,509) ibre
      endif
      if(ibre.eq.2) then
         write(23,514) ibre
      endif
      if((ibre.ne.1).AND.(ibre.ne.2)) then
         write(23,510) ibre
      endif
c
      write(23,*)
     + 'Knock-on electrons are'
      write(23,*)
     + 'included in catastrophic'
      if (noca.ne.0) then
         write(23,512) noca
      else
         write(23,513) noca
      endif
c
      if ((fa.lt..99999).or.(fa.gt.1.0001)) then
      write(23,*)
     + 'ATTENTION! RUNNING IN SPECIAL'
      write(23,*)
     + 'MODE: ALL CROSSSECTIONS ARE'
      write(23,511) fa
      endif
c
      write(23,*) '====='
      write(23,*) ' '
c
      close (23)
c
      return
c
  501 format (' Particle                       : MUON (ILEP = ',i1,')')
  502 format (' Particle                       : TAU (ILEP = ',i4,')')
  503 format (' Ecut                           : ',f8.6,' GeV')
  504 format (' Vcut                           : ',f8.6)
  505 format (' of a real photon               : by Bugaev-Bezrukov (ipn
     + = ',i4,')')
  506 format (' of a real photon               : by ZEUS (ipn = ',
     +i4,')')
  507 format (' Bugaev-Shlepin                 : YES (iqcd = ',i1,')')
  508 format (' Bugaev-Shlepin                 : NO (iqcd = ',i4,')')
  509 format (' Bremsstrahlung cross-sections  : by Andreev-Bezrukov-Bug
     +aev (ibre = ',i1,')')
  510 format (' Bremsstrahlung cross-sections  : by Kelner-Kokoulin (GEA
     +NT4.0) (ibre = ',i1,')')
  514 format (' Bremsstrahlung cross-sections  : by Sandrock (ibre = ',
     + i1,')')
  511 format (' MULTIPLIED BY FACTOR           : ',f8.6)
  512 format (' losses (recommended)           : YES (noca = ',i5,')')
  513 format (' losses                         : NO (noca = ',i5,')')
  601 format (' Medium                         : PURE WATER (imed = ',
     +i2,')')
  602 format (' Medium                         : STANDARD ROCK (imed = '
     +,i2,')')
  603 format (' Medium                         : ANTARCTIC ICE (imed = '
     +,i2,')')
  604 format  (' Medium                         : SEAWATER PACIFIC (imed
     + = ',i2,')')
  605 format (' Medium                         : SEAWATER ANTARES D<2126
     +m (imed = ',i2,')')
  606 format (' Medium                         : SEAWATER ANTARES D>2126
     +m (imed = ',i2,')')
  607 format    (' Medium                         : GRAN SASSO ROCK (ime
     +d = ',i2,')')
  608 format  (' Medium                         : BAIKAL BASIS ROCK (ime
     +d = ',i2,')')
  609 format (' Medium                         : BAIKAL TANKHOY ROCK (im
     +ed = ',i2,')')
  610 format   (' Medium                         : BAIKAL ANOS ROCK (ime
     +d = ',i3,')')
  611 format (' Medium                         : BAIKAL GROUND (SILT) (i
     +med = ',i3,')')
  612 format (' Medium                         : FREJUS ROCK (SINGLE MED
     +IUM) (imed = ',i3,')')
  613 format (' Medium                         : FREJUS ROCK (COMPOSED M
     +EDIUM) (imed = ',i3,')')
c
      end
***********************************************************************
* C.2_3
       subroutine med_cons3(imed,ipn,ibre,em,vm,ilep,iqcd)
*  .........................................................................
       real*8 alfa,rm_e,rm_mu,r_e,z1(10),w(10),aw(10),n(10)
       real*8 ntot,a_ef,avog,ro,zmean
       real*8 z_a,ri_z,x_0,x_1,a,rm
       real*8 tlife
       real*4 em,vm
       integer imed,ipn,ibre,ilep,iqcd
       integer nsub,iqcd1
       common /qcd3/ iqcd1
       common /const_t3/ tlife
       common /const3/ alfa,rm_e,rm_mu,r_e,avog
       common /media3/ z1,w,aw,a_ef,ro,nsub
       common /med_ion3/ z_a,ri_z,x_0,x_1,a,rm
       common /general3/ emin,vmin,emph
       common /mcef3/ mcb1,mcb2,mcp1,mcp2,mcn1,mcn2,mce1,mce2
       common /zav3/ zm
       common /pnsig3/ ibb
       common /bremind3/ ibrem
       common /toprint3/ n
       common /exer13/ fa
       common /exer23/ noca
       common /what_lep3/ kindlept
       COMMON /MATTER3/ MEDIUM
       MEDIUM = imed
cc ........................................................................
        iqcd1 = iqcd !---> accounting for QCD part in PN or not...
c ........................................................................
        tlife = 2.906d-13 !--> Tau-lepton mean time life (seconds)
c ........................................................................
        kindlept = ilep   !--> 1 if muons, any other value means taus
c ........................................................................
        mcb1 = 0  !
        mcb2 = 0  !
        mcp1 = 0  ! CONSTANTS TO CALCULATE
        mcp2 = 0  !      SIMULATION
        mcn1 = 0  !      EFFICIENCY
        mcn2 = 0  !
        mce1 = 0  !
        mce2 = 0  !
c ........................................................................
c                           BASIC CONSTANTS:
c                           ***************
       avog = 6.022045d+23         !--> Avogadro number
       alfa =  7.297353053019d-3   !--> fine structure constant
       rm_e = 5.110034d-1          !--> electron mass (in MeV)
       if(ilep.eq.1) then
       rm_mu = 1.0565932d+2        !--> muon mass (in MeV)
       else
       rm_mu = 1.77699d+3          !--> tau mass (in MeV)
       endif
       r_e = 2.8179409d-13         !--> classical electron radii (in cm)
c ........................................................................
c               THRESHOLD ENERGIE AND RELATIVE ENERGY TRANSFER:
c               ***********************************************
         emin = em      !---> threshold energy in Gev
         vmin = vm      !---> threshold relative energy transfer
         emph = 8.e-1   !---> threshold en. for photonucl. interaction, GeV
         fa = 1.e+0     !---> factor to multiply all diff. cros-sections and
c                       !     Bethe-Bloch formula
         noca = 1       !---> if noca=0, there are no catastrophic losses
c                             for knock-on electrons
c ........................................................................
        ibb = ipn ! if ibb=1 Sigma_gamma_p for photonuclear interaction is
c                 ! calculated by Bezrukov_Bugaev (squared LN dependence),
c                 ! otherwise it is calculated by ZEUS parametrization
c                 ! (J.Breitweg et al., Eur.Phys.J. C7 (1999) 609)
       ibrem=ibre ! if ibrem=1 diff. cross-section for bremsstrahlung is
c                 ! computed according to Andreev-Bugaev-Bezrukov, otherwise
c                 ! it is done according to Kelner-Kokouluin (Geant 4.)
c ........................................................................
c                          MEDIUM PREPARATION:
c                          ******************
        if (imed.eq.1) then
        ro=1.d+0      !
        nsub=2        ! IT IS WATER. It consists of nsub=2 elements:
        n(1)=2.d+0    ! n(1) = 2 H atoms and n(2) = 1 O atom with atomic
        n(2)=1.d+0    ! weights and electric charges are equal to
        aw(1)=1.008   ! aw(1) = 1.008, aw(2) = 15.999, z1(1) = 1 and
        aw(2)=15.999  ! z1(2) = 8, correspondingly
        z1(1)=1.d+0   ! Its density is ro = 1.0 g/qubic cm
        z1(2)=8.d+0   !
c                     !
        z_a = 5.551d-1! Z/A                      !
        ri_z = 7.5d-05! Min. Ion. Potential, MeV !
        x_0 = 2.4d-1  !--------------------      !--> It is constants
        x_1 = 2.8d+0  !-- 4 constants for        !--> for Bethe-Bloch
        a = 9.1d-2    !-- dencity effect         !-->     formula
        rm = 3.477d+0 !--------------------      !
        endif
c
        if (imed.eq.2) then
        ro=2.65d+0       !
        nsub=1           !
        n(1)=1.d+0       !
        aw(1)=22.        !
        z1(1)=1.1d+1     !
c                        ! ALL THE SAME FOR STANDARD ROCK
        z_a = 5.d-1      !
        ri_z = 1.364d-04 !
        x_0 = 4.9d-2     !
        x_1 = 3.055d+0   !
        a = 8.3d-2       !
        rm = 3.412d+0    !
        endif
c
        if (imed.eq.3) then
        ro=.92d+0       !
        nsub=2          !
        n(1)=2.d+0      !
        n(2)=1.d+0      ! The same for Antarctic ice
        aw(1)=1.008     ! (all constants are exactly as
        aw(2)=15.999    ! for water but ro = 0.92 g/cm^3 )
        z1(1)=1.d+0     !
        z1(2)=8.d+0     !
c                       !
        z_a = 5.551d-1  !
        ri_z = 7.5d-05  !
        x_0 = 2.4d-1    !
        x_1 = 2.8d+0    !
        a = 9.1d-2      !
        rm = 3.477d+0   !
        endif
c
c                         Sea water (Pacific Ocean):
c                         ------------------------
        if (imed.eq.4) then
        ro = 1.027d+0   ! J.Babson et al, Phys.Rev.D 42 (1990) 3613;
                        ! V.M.Goldschmidt. Geochemistry (Clarendon,
                        ! Oxford, 1954), p. 49.
        nsub = 8          !
        n(1) = 2.d+0      ! -> H
        n(2) = 1.00884d+0 ! -> O
        n(3) = 8.59d-3    ! -> Na
        n(4) = 1.9d-4     ! -> K
        n(5) = 9.9d-4     ! -> Mg
        n(6) = 1.9d-4     ! -> Ca
        n(7) = 1.007d-2   ! -> Cl
        n(8) = 5.3d-3     ! -> S
        aw(1) = 1.008d+0  !
        aw(2) = 15.999d+0 !
        aw(3) = 22.99d+0  ! Chemical composition of the seawater
        aw(4) = 39.10d+0  !           according to
        aw(5) = 24.31d+0  ! A.Okada, Astropart. Phys. 2 (1994) 393
        aw(6) = 40.08d+0  !        and references therein
        aw(7) = 35.45d+0  !
        aw(8) = 32.07d+0  !
        z1(1) = 1.0d+0    !
        z1(2) = 8.0d+0    !
        z1(3) = 11.0d+0   !
        z1(4) = 19.0d+0   !
        z1(5) = 12.0d+0   !
        z1(6) = 20.0d+0   !
        z1(7) = 17.0d+0   !
        z1(8) = 16.0d+0   !
c                        !
        z_a = 5.5525d-1  ! All the same as for pure water except for
        ri_z = 7.5d-05  !        z_a which is taken from
        x_0 = 2.4d-1    ! [J.Babson et al, Phys.Rev.D 42 (1990) 3613;
        x_1 = 2.8d+0    !  V.M.Goldschmidt. Geochemistry (Clarendon,
        a = 9.1d-2      !  Oxford, 1954), p. 49.] and differs from
        rm = 3.477d+0   ! z_a according to Lohman et al. by 0.027%.
        endif
c
c==========================================================================
c  THERE ARE TWO WATER FOR THE ANTARES PLACE SINCE WATER DENSITY CHANGES
c WITH THE DEPTH FROM 1.0291 g/cm^3 AT SURFACE UP TO 1.0404 g/cm^3 AT THE
c           SEA BED (ANTARES-Site/2000-001 and references therein)
c
c       So, one should use imed = 5 when simulating downcoming muons
c  (e.g., atmospheric ones) and imed = 6 when simulating muons which come
c                        from the bottom of detector)
c The error which is caused by thid simplyfied approach (average value for
c density) does not exceed 0.5% (much less, in fact) that is comparable with
c  an error which comes from uncerntainties with the muon cross-sections.
c==========================================================================
c
c           Sea water (Mediterranean Sea, ANTARES place, D < 2126 m):
c           --------------------------------------------------------
c
        if (imed.eq.5) then
        ro = 1.0341d+0  ! J.Brunner, ANTARES-Site/2000-001, the mean value
                        ! for sea water density at the ANTARES place between
                        ! surface D = 0 m (1.0291 g/cm^3) and middle of
                        ! detector D = 2126 m (1.0391 g/cm^3)
        nsub = 8          !
        n(1) = 2.d+0      ! -> H
        n(2) = 1.00884d+0 ! -> O
        n(3) = 9.43d-3    ! -> Na
        n(4) = 2.09d-4    ! -> K
        n(5) = 10.87d-4   ! -> Mg
        n(6) = 2.09d-4    ! -> Ca
        n(7) = 1.106d-2   ! -> Cl
        n(8) = 5.82d-3    ! -> S
        aw(1) = 1.008d+0  !
        aw(2) = 15.999d+0 !
        aw(3) = 22.99d+0  !    Chemical composition of the seawater
        aw(4) = 39.10d+0  !                  according to
        aw(5) = 24.31d+0  !     A.Okada, Astropart. Phys. 2 (1994) 393
        aw(6) = 40.08d+0  !              and references therein
        aw(7) = 35.45d+0  !  corrected for Mediterranean Sea, ANTARES place
        aw(8) = 32.07d+0  !     according to salinity  38.44+-0.02 g/kg,
        z1(1) = 1.0d+0    !   as cited in J.Brunner, ANTARES-Site/2000-001
        z1(2) = 8.0d+0    !  instead of 35.0 g/kg as cited in A.Okada, ...
        z1(3) = 11.0d+0   ! (so, n(3-8) have been just multiplied by 1.098)
        z1(4) = 19.0d+0   !
        z1(5) = 12.0d+0   !
        z1(6) = 20.0d+0   !
        z1(7) = 17.0d+0   !
        z1(8) = 16.0d+0   !
c                        !
        z_a = 5.5525d-1  ! All the same as for pure water except for
        ri_z = 7.5d-05  !        z_a which is taken from
        x_0 = 2.4d-1    ! [J.Babson et al, Phys.Rev.D 42 (1990) 3613;
        x_1 = 2.8d+0    !  V.M.Goldschmidt. Geochemistry (Clarendon,
        a = 9.1d-2      !  Oxford, 1954), p. 49.] and differs from
        rm = 3.477d+0   ! z_a according to Lohman et al. by 0.027%.
        endif
c
c
c           Sea water (Mediterranean Sea, ANTARES place, D > 2126 m):
c           --------------------------------------------------------
c
        if (imed.eq.6) then
        ro = 1.03975d+0 ! J.Brunner, ANTARES-Site/2000-001, the mean value
                        ! for sea water density at the ANTARES place between
                        ! sea bed D = 2400 m (1.0404 g/cm^3) and middle of
                        ! detector D = 2126 m (1.0391 g/cm^3)
        nsub = 8          !
        n(1) = 2.d+0      ! -> H
        n(2) = 1.00884d+0 ! -> O
        n(3) = 9.43d-3    ! -> Na
        n(4) = 2.09d-4    ! -> K
        n(5) = 10.87d-4   ! -> Mg
        n(6) = 2.09d-4    ! -> Ca
        n(7) = 1.106d-2   ! -> Cl
        n(8) = 5.82d-3    ! -> S
        aw(1) = 1.008d+0  !
        aw(2) = 15.999d+0 !
        aw(3) = 22.99d+0  !    Chemical composition of the seawater
        aw(4) = 39.10d+0  !                  according to
        aw(5) = 24.31d+0  !     A.Okada, Astropart. Phys. 2 (1994) 393
        aw(6) = 40.08d+0  !              and references therein
        aw(7) = 35.45d+0  !  corrected for Mediterranean Sea, ANTARES place
        aw(8) = 32.07d+0  !     according to salinity  38.44+-0.02 g/kg,
        z1(1) = 1.0d+0    !   as cited in J.Brunner, ANTARES-Site/2000-001
        z1(2) = 8.0d+0    !  instead of 35.0 g/kg as cited in A.Okada, ...
        z1(3) = 11.0d+0   ! (so, n(3-8) have been just multiplied by 1.098)
        z1(4) = 19.0d+0   !
        z1(5) = 12.0d+0   !
        z1(6) = 20.0d+0   !
        z1(7) = 17.0d+0   !
        z1(8) = 16.0d+0   !
c                        !
        z_a = 5.5525d-1  ! All the same as for pure water except for
        ri_z = 7.5d-05  !        z_a which is taken from
        x_0 = 2.4d-1    ! [J.Babson et al, Phys.Rev.D 42 (1990) 3613;
        x_1 = 2.8d+0    !  V.M.Goldschmidt. Geochemistry (Clarendon,
        a = 9.1d-2      !  Oxford, 1954), p. 49.] and differs from
        rm = 3.477d+0   ! z_a according to Lohman et al. by 0.027%.
        endif
c
c
c      Gran Sasso rock (M.Ambrosio et al., Phys. Rev. D52, (1995) 3793)
c      ----------------------------------------------------------------
c
        if (imed.eq.7) then
        ro = 2.71d+0
        nsub = 8            !
        n(1) = 2.9762d-2    ! -> H
        n(2) = 1.0132379d+0 ! -> C
        n(3) = 3.175109d+0  ! -> O
        n(4) = 3.423164d-1  ! -> Mg
        n(5) = 2.3349764d-2 ! -> Al
        n(6) = 3.73865d-2   ! -> Si
        n(7) = 2.557676d-3  ! -> K
        n(8) = 6.7094166d-1 ! -> Ca
        aw(1) = 1.008d+0
        aw(2) = 12.011d+0
        aw(3) = 15.99d+0
        aw(4) = 24.305d+0
        aw(5) = 26.981d+0
        aw(6) = 28.085d+0
        aw(7) = 39.098d+0
        aw(8) = 40.078d+0
        z1(1) = 1.0d+0
        z1(2) = 6.0d+0
        z1(3) = 8.0d+0
        z1(4) = 12.0d+0
        z1(5) = 13.0d+0
        z1(6) = 14.0d+0
        z1(7) = 19.0d+0
        z1(8) = 20.0d+0
c                        !
        z_a = 5.d-1      ! The same as for Standard Rock
        ri_z = 1.364d-04 !
        x_0 = 4.9d-2     !
        x_1 = 3.055d+0   !
        a = 8.3d-2       !
        rm = 3.412d+0    !
        endif
c
c
c   Baikal rock (basis, shore rocks and rocks 2 km below the Baikal bed)
c   --------------------------------------------------------------------
c        (as given at A.I.Panfilov, Baikal internal note 22/06/00)
c                         panfilov@inr.ruhep.ru
c
        if (imed.eq.8) then
        ro = 2.9d+0
        nsub = 10            !
        n(1) = 2.7251d-2     ! -> O
        n(2) = 8.15367d-3    ! -> Si
        n(3) = 1.670844d-4   ! -> Ti
        n(4) = 2.89087d-3    ! -> Al
        n(5) = 1.8443247d-3  ! -> Fe
        n(6) = 3.640467d-5   ! -> Mn
        n(7) = 1.810327d-3   ! -> Mg
        n(8) = 1.946205d-3   ! -> Ca
        n(9) = 7.3945837d-4  ! -> Na
        n(10) = 1.278828d-4  ! -> K
        aw(1) = 15.9994d+0
        aw(2) = 28.0855d+0
        aw(3) = 47.88d+0
        aw(4) = 26.9815d+0
        aw(5) = 55.847d+0
        aw(6) = 54.938d+0
        aw(7) = 24.305d+0
        aw(8) = 40.078d+0
        aw(9) = 22.9898d+0
        aw(10) = 39.0983d+0
        z1(1) = 8.0d+0
        z1(2) = 14.0d+0
        z1(3) = 22.0d+0
        z1(4) = 13.0d+0
        z1(5) = 26.0d+0
        z1(6) = 25.0d+0
        z1(7) = 12.0d+0
        z1(8) = 20.0d+0
        z1(9) = 11.0d+0
        z1(10) = 19.0d+0
c                        !
        z_a = 4.96d-1    ! The same as for Standard Rock (what to do?!)
        ri_z = 1.364d-04 !     except for z_a which was meaured
        x_0 = 4.9d-2     !          to be equal to 0.496
        x_1 = 3.055d+0   !
        a = 8.3d-2       !
        rm = 3.412d+0    !
        endif
c
c     Baikal rock ("tankhoy layer", up to 2000 m below the Baikal bed)
c      There are data concerning 6 depths which differ each other by
c   ~10% in terms of density, Z, A, and composition. One had to choose
c      the data for 800 m below the Baikal bed which seem to be close
c                                to "average"
c   --------------------------------------------------------------------
c        (as given at A.I.Panfilov, Baikal internal note 22/06/00)
c                         panfilov@inr.ruhep.ru
c
        if (imed.eq.9) then
        ro = 2.481d+0
        nsub = 10            !
        n(1) = 0.588d+0      ! -> O
        n(2) = 0.166d+0      ! -> Si
        n(3) = 0.002d+0      ! -> Ti
        n(4) = 0.093d+0      ! -> Al
        n(5) = 0.033d+0      ! -> Fe
        n(6) = 0.101d+0      ! -> H
        n(7) = 0.009d+0      ! -> Mg
        n(8) = 0.003d+0      ! -> Ca
        n(9) = 0.002d+0      ! -> Na
        n(10) = 0.003d+0     ! -> K
        aw(1) = 15.9994d+0
        aw(2) = 28.0855d+0
        aw(3) = 47.88d+0
        aw(4) = 26.9815d+0
        aw(5) = 55.847d+0
        aw(6) = 1.00794d+0
        aw(7) = 24.305d+0
        aw(8) = 40.078d+0
        aw(9) = 22.9898d+0
        aw(10) = 39.0983d+0
        z1(1) = 8.0d+0
        z1(2) = 14.0d+0
        z1(3) = 22.0d+0
        z1(4) = 13.0d+0
        z1(5) = 26.0d+0
        z1(6) = 1.0d+0
        z1(7) = 12.0d+0
        z1(8) = 20.0d+0
        z1(9) = 11.0d+0
        z1(10) = 19.0d+0
c                        !
        z_a = 5.47d-1     ! The same as for Standard Rock (what to do?!)
        ri_z = 1.364d-04 !     except for z_a which was meaured
        x_0 = 4.9d-2     !          to be equal to 0.547
        x_1 = 3.055d+0   !
        a = 8.3d-2       !
        rm = 3.412d+0    !
        endif
c
c      Baikal rock ("anos layer", 100 -- 500 m below the Baikal bed)
c      There are data concerning 6 depths which differ each other by
c   ~10% in terms of density, Z, A, and composition. One had to choose
c      the data for 300 m below the Baikal bed which seem to be close
c                                to "average"
c   --------------------------------------------------------------------
c        (as given at A.I.Panfilov, Baikal internal note 22/06/00)
c                         panfilov@inr.ruhep.ru
c
        if (imed.eq.10) then
        ro = 2.103d+0
        nsub = 10            !
        n(1) = 0.519d+0      ! -> O
        n(2) = 0.149d+0      ! -> Si
        n(3) = 0.002d+0      ! -> Ti
        n(4) = 0.044d+0      ! -> Al
        n(5) = 0.006d+0      ! -> Fe
        n(6) = 0.268d+0      ! -> H
        n(7) = 0.004d+0      ! -> Mg
        n(8) = 0.001d+0      ! -> Ca
        n(9) = 0.001d+0      ! -> Na
        n(10) = 0.006d+0     ! -> K
        aw(1) = 15.9994d+0
        aw(2) = 28.0855d+0
        aw(3) = 47.88d+0
        aw(4) = 26.9815d+0
        aw(5) = 55.847d+0
        aw(6) = 1.00794d+0
        aw(7) = 24.305d+0
        aw(8) = 40.078d+0
        aw(9) = 22.9898d+0
        aw(10) = 39.0983d+0
        z1(1) = 8.0d+0
        z1(2) = 14.0d+0
        z1(3) = 22.0d+0
        z1(4) = 13.0d+0
        z1(5) = 26.0d+0
        z1(6) = 1.0d+0
        z1(7) = 12.0d+0
        z1(8) = 20.0d+0
        z1(9) = 11.0d+0
        z1(10) = 19.0d+0
c                        !
        z_a = 6.3d-1     ! The same as for Standard Rock (what to do?!)
        ri_z = 1.364d-04 !     except for z_a which was meaured
        x_0 = 4.9d-2     !          to be equal to 0.630
        x_1 = 3.055d+0   !
        a = 8.3d-2       !
        rm = 3.412d+0    !
        endif
c
c     Baikal ground ("alevrit silt", 0 -- 100 m below the Baikal bed)
c      There are data concerning 6 depths which differ each other by
c   ~10% in terms of density, Z, A, and composition. One had to choose
c      the data for 50 m below the Baikal bed which seem to be close
c                               to "average"
c   --------------------------------------------------------------------
c        (as given at A.I.Panfilov, Baikal internal note 22/06/00)
c                         panfilov@inr.ruhep.ru
c
        if (imed.eq.11) then
        ro = 1.698d+0
        nsub = 10            !
        n(1) = 0.439d+0      ! -> O
        n(2) = 0.090d+0      ! -> Si NB: the litle fraction of S
        n(3) = 0.001d+0      ! -> Ti     had to be added to Si (very
        n(4) = 0.018d+0      ! -> Al     close elements, within
        n(5) = 0.005d+0      ! -> Fe      systematic errors)
        n(6) = 0.431d+0      ! -> H
        n(7) = 0.003d+0      ! -> Mg
        n(8) = 0.003d+0      ! -> Ca
        n(9) = 0.005d+0      ! -> Na
        n(10) = 0.003d+0     ! -> K
        aw(1) = 15.9994d+0
        aw(2) = 28.0855d+0
        aw(3) = 47.88d+0
        aw(4) = 26.9815d+0
        aw(5) = 55.847d+0
        aw(6) = 1.00794d+0
        aw(7) = 24.305d+0
        aw(8) = 40.078d+0
        aw(9) = 22.9898d+0
        aw(10) = 39.0983d+0
        z1(1) = 8.0d+0
        z1(2) = 14.0d+0
        z1(3) = 22.0d+0
        z1(4) = 13.0d+0
        z1(5) = 26.0d+0
        z1(6) = 1.0d+0
        z1(7) = 12.0d+0
        z1(8) = 20.0d+0
        z1(9) = 11.0d+0
        z1(10) = 19.0d+0
c                        !
        z_a = 7.11d-1    ! The same as for Standard Rock (what to do?!)
        ri_z = 7.5d-05   !  except for z_a which was meaured to be equal
        x_0 = 4.9d-2     ! to 0.711, ri_z had to be taken for water since
        x_1 = 3.055d+0   ! this ground is obviously closer to water than
        a = 8.3d-2       !               to rock...
        rm = 3.412d+0    !
        endif
c
c
c                  FREJUS ROCK ("single medium" model)
c                  ===================================
c       as described in W.Rhode, "Untersuchung der Energiespektren
c hochenergetischer Muonen im Frejusdetektor", Dissertation zur Erlangung
c  des Doktorgrades des Fachbereiches Physik der Bergischer UniversitaEt
c              Wupppertal, WUB-DIS 93-11, Oktober 1993, 232 pp.
c
        if (imed.eq.12) then
        ro=2.74d+0       !
        nsub=1           !
        n(1)=1.d+0       !
        aw(1)=20.34      !
        z1(1)=1.012d+1   !
c                        ! Everything has been taken from
        z_a = 4.975d-1   !        W.Rhode Thesis
        ri_z = 1.49d-04  !
        x_0 = 2.88d-1    !
        x_1 = 3.196d+0   !
        a = 7.8d-2       !
        rm = 3.645d+0    !
        endif
c
c   Frejus rock ("composed medium" model), as it was incorporated in
c PROPMU code by W.Rhode (W.Rhode, private communication, October 2001)
c
        if (imed.eq.13) then
        ro = 2.74d+0
        nsub = 10            !
        n(1) = 9.1800165d-3  ! -> C
        n(2) = 3.8712389d-2  ! -> O
        n(3) = 3.0446410d-4  ! -> Mg
        n(4) = 1.3342456d-3  ! -> Al
        n(5) = 3.6584715d-3  ! -> Si
        n(6) = 7.9523483d-5  ! -> S
        n(7) = 1.6650340d-4  ! -> K
        n(8) = 2.5955637d-3  ! -> Ca
        n(9) = 6.4072169d-6  ! -> Mn
        n(10) = 1.7417229d-4 ! -> Fe
        aw(1) = 12.11d+0
        aw(2) = 15.9994d+0
        aw(3) = 24.305d+0
        aw(4) = 26.981539d+0
        aw(5) = 28.0855d+0
        aw(6) = 32.066d+0
        aw(7) = 39.0983d+0
        aw(8) = 40.078d+0
        aw(9) = 54.93805d+0
        aw(10) = 55.847d+0
        z1(1) = 6.0d+0
        z1(2) = 8.0d+0
        z1(3) = 12.0d+0
        z1(4) = 13.0d+0
        z1(5) = 14.0d+0
        z1(6) = 16.0d+0
        z1(7) = 19.0d+0
        z1(8) = 20.0d+0
        z1(9) = 25.0d+0
        z1(10) = 26.0d+0
c
        z_a = 4.975d-1
        ri_z = 1.49d-04
        x_0 = 2.88d-1
        x_1 = 3.196d+0
        a = 7.8d-2
        rm = 3.645d+0
        endif
c
        if (imed.eq.-1) then
        ro=1.d+0      !
        nsub=2        ! IT IS WATER. It consists of nsub=2 elements:
        n(1)=2.d+0    ! n(1) = 2 H atoms and n(2) = 1 O atom with atomic
        n(2)=1.d+0    ! weights and electric charges are equal to
        aw(1)=1.008   ! aw(1) = 1.008, aw(2) = 15.999, z1(1) = 1 and
        aw(2)=15.999  ! z1(2) = 8, correspondingly
        z1(1)=1.d+0   ! Its density is ro = 1.0 g/qubic cm
        z1(2)=8.d+0   !
c                     !
        z_a = 5.551d-1! Z/A                      !
        ri_z = 7.5d-05! Min. Ion. Potential, MeV !
        x_0 = 2.4d-1  !--------------------      !--> It is constants
        x_1 = 2.8d+0  !-- 4 constants for        !--> for Bethe-Bloch
        a = 9.1d-2    !-- dencity effect         !-->     formula
        rm = 3.477d+0 !--------------------      !
        endif
c
        if (imed.eq.-2) then
        ro=1.0d+0        !
        nsub=1           !
        n(1)=1.d+0       !
        aw(1)=22.        !
        z1(1)=1.1d+1     !
c                        ! ALL THE SAME FOR STANDARD ROCK
        z_a = 5.d-1      !
        ri_z = 1.364d-04 !
        x_0 = 4.9d-2     !
        x_1 = 3.055d+0   !
        a = 8.3d-2       !
        rm = 3.412d+0    !
        endif
c
        if (imed.eq.-3) then
        ro=1.0d+0       !
        nsub=2          !
        n(1)=2.d+0      !
        n(2)=1.d+0      ! The same for Antarctic ice
        aw(1)=1.008     ! (all constants are exactly as
        aw(2)=15.999    ! for water but ro = 0.92 g/cm^3 )
        z1(1)=1.d+0     !
        z1(2)=8.d+0     !
c                       !
        z_a = 5.551d-1  !
        ri_z = 7.5d-05  !
        x_0 = 2.4d-1    !
        x_1 = 2.8d+0    !
        a = 9.1d-2      !
        rm = 3.477d+0   !
        endif
c
c                         Sea water (Pacific Ocean):
c                         ------------------------
        if (imed.eq.-4) then
        ro = 1.0d+0     ! J.Babson et al, Phys.Rev.D 42 (1990) 3613;
                        ! V.M.Goldschmidt. Geochemistry (Clarendon,
                        ! Oxford, 1954), p. 49.
        nsub = 8          !
        n(1) = 2.d+0      ! -> H
        n(2) = 1.00884d+0 ! -> O
        n(3) = 8.59d-3    ! -> Na
        n(4) = 1.9d-4     ! -> K
        n(5) = 9.9d-4     ! -> Mg
        n(6) = 1.9d-4     ! -> Ca
        n(7) = 1.007d-2   ! -> Cl
        n(8) = 5.3d-3     ! -> S
        aw(1) = 1.008d+0  !
        aw(2) = 15.999d+0 !
        aw(3) = 22.99d+0  ! Chemical composition of the seawater
        aw(4) = 39.10d+0  !           according to
        aw(5) = 24.31d+0  ! A.Okada, Astropart. Phys. 2 (1994) 393
        aw(6) = 40.08d+0  !        and references therein
        aw(7) = 35.45d+0  !
        aw(8) = 32.07d+0  !
        z1(1) = 1.0d+0    !
        z1(2) = 8.0d+0    !
        z1(3) = 11.0d+0   !
        z1(4) = 19.0d+0   !
        z1(5) = 12.0d+0   !
        z1(6) = 20.0d+0   !
        z1(7) = 17.0d+0   !
        z1(8) = 16.0d+0   !
c                        !
        z_a = 5.5525d-1  ! All the same as for pure water except for
        ri_z = 7.5d-05  !        z_a which is taken from
        x_0 = 2.4d-1    ! [J.Babson et al, Phys.Rev.D 42 (1990) 3613;
        x_1 = 2.8d+0    !  V.M.Goldschmidt. Geochemistry (Clarendon,
        a = 9.1d-2      !  Oxford, 1954), p. 49.] and differs from
        rm = 3.477d+0   ! z_a according to Lohman et al. by 0.027%.
        endif
c
c           Sea water (Mediterranean Sea, ANTARES place, D < 2126 m):
c           --------------------------------------------------------
c
        if (imed.eq.-5) then
        ro = 1.0d+0     ! J.Brunner, ANTARES-Site/2000-001, the mean value
                        ! for sea water density at the ANTARES place between
                        ! surface D = 0 m (1.0291 g/cm^3) and middle of
                        ! detector D = 2126 m (1.0391 g/cm^3)
        nsub = 8          !
        n(1) = 2.d+0      ! -> H
        n(2) = 1.00884d+0 ! -> O
        n(3) = 9.43d-3    ! -> Na
        n(4) = 2.09d-4    ! -> K
        n(5) = 10.87d-4   ! -> Mg
        n(6) = 2.09d-4    ! -> Ca
        n(7) = 1.106d-2   ! -> Cl
        n(8) = 5.82d-3    ! -> S
        aw(1) = 1.008d+0  !
        aw(2) = 15.999d+0 !
        aw(3) = 22.99d+0  !    Chemical composition of the seawater
        aw(4) = 39.10d+0  !                  according to
        aw(5) = 24.31d+0  !     A.Okada, Astropart. Phys. 2 (1994) 393
        aw(6) = 40.08d+0  !              and references therein
        aw(7) = 35.45d+0  !  corrected for Mediterranean Sea, ANTARES place
        aw(8) = 32.07d+0  !     according to salinity  38.44+-0.02 g/kg,
        z1(1) = 1.0d+0    !   as cited in J.Brunner, ANTARES-Site/2000-001
        z1(2) = 8.0d+0    !  instead of 35.0 g/kg as cited in A.Okada, ...
        z1(3) = 11.0d+0   ! (so, n(3-8) have been just multiplied by 1.098)
        z1(4) = 19.0d+0   !
        z1(5) = 12.0d+0   !
        z1(6) = 20.0d+0   !
        z1(7) = 17.0d+0   !
        z1(8) = 16.0d+0   !
c                        !
        z_a = 5.5525d-1  ! All the same as for pure water except for
        ri_z = 7.5d-05  !        z_a which is taken from
        x_0 = 2.4d-1    ! [J.Babson et al, Phys.Rev.D 42 (1990) 3613;
        x_1 = 2.8d+0    !  V.M.Goldschmidt. Geochemistry (Clarendon,
        a = 9.1d-2      !  Oxford, 1954), p. 49.] and differs from
        rm = 3.477d+0   ! z_a according to Lohman et al. by 0.027%.
        endif
c
c
c           Sea water (Mediterranean Sea, ANTARES place, D > 2126 m):
c           --------------------------------------------------------
c
        if (imed.eq.-6) then
        ro = 1.0d+0     ! J.Brunner, ANTARES-Site/2000-001, the mean value
                        ! for sea water density at the ANTARES place between
                        ! sea bed D = 2400 m (1.0404 g/cm^3) and middle of
                        ! detector D = 2126 m (1.0391 g/cm^3)
        nsub = 8          !
        n(1) = 2.d+0      ! -> H
        n(2) = 1.00884d+0 ! -> O
        n(3) = 9.43d-3    ! -> Na
        n(4) = 2.09d-4    ! -> K
        n(5) = 10.87d-4   ! -> Mg
        n(6) = 2.09d-4    ! -> Ca
        n(7) = 1.106d-2   ! -> Cl
        n(8) = 5.82d-3    ! -> S
        aw(1) = 1.008d+0  !
        aw(2) = 15.999d+0 !
        aw(3) = 22.99d+0  !    Chemical composition of the seawater
        aw(4) = 39.10d+0  !                  according to
        aw(5) = 24.31d+0  !     A.Okada, Astropart. Phys. 2 (1994) 393
        aw(6) = 40.08d+0  !              and references therein
        aw(7) = 35.45d+0  !  corrected for Mediterranean Sea, ANTARES place
        aw(8) = 32.07d+0  !     according to salinity  38.44+-0.02 g/kg,
        z1(1) = 1.0d+0    !   as cited in J.Brunner, ANTARES-Site/2000-001
        z1(2) = 8.0d+0    !  instead of 35.0 g/kg as cited in A.Okada, ...
        z1(3) = 11.0d+0   ! (so, n(3-8) have been just multiplied by 1.098)
        z1(4) = 19.0d+0   !
        z1(5) = 12.0d+0   !
        z1(6) = 20.0d+0   !
        z1(7) = 17.0d+0   !
        z1(8) = 16.0d+0   !
c                        !
        z_a = 5.5525d-1  ! All the same as for pure water except for
        ri_z = 7.5d-05  !        z_a which is taken from
        x_0 = 2.4d-1    ! [J.Babson et al, Phys.Rev.D 42 (1990) 3613;
        x_1 = 2.8d+0    !  V.M.Goldschmidt. Geochemistry (Clarendon,
        a = 9.1d-2      !  Oxford, 1954), p. 49.] and differs from
        rm = 3.477d+0   ! z_a according to Lohman et al. by 0.027%.
        endif
c
c
c      Gran Sasso rock (M.Ambrosio et al., Phys. Rev. D52, (1995) 3793)
c      ----------------------------------------------------------------
c
        if (imed.eq.-7) then
        ro = 1.0d+0
        nsub = 8            !
        n(1) = 2.9762d-2    ! -> H
        n(2) = 1.0132379d+0 ! -> C
        n(3) = 3.175109d+0  ! -> O
        n(4) = 3.423164d-1  ! -> Mg
        n(5) = 2.3349764d-2 ! -> Al
        n(6) = 3.73865d-2   ! -> Si
        n(7) = 2.557676d-3  ! -> K
        n(8) = 6.7094166d-1 ! -> Ca
        aw(1) = 1.008d+0
        aw(2) = 12.011d+0
        aw(3) = 15.99d+0
        aw(4) = 24.305d+0
        aw(5) = 26.981d+0
        aw(6) = 28.085d+0
        aw(7) = 39.098d+0
        aw(8) = 40.078d+0
        z1(1) = 1.0d+0
        z1(2) = 6.0d+0
        z1(3) = 8.0d+0
        z1(4) = 12.0d+0
        z1(5) = 13.0d+0
        z1(6) = 14.0d+0
        z1(7) = 19.0d+0
        z1(8) = 20.0d+0
c                        !
        z_a = 5.d-1      ! The same as for Standard Rock
        ri_z = 1.364d-04 !
        x_0 = 4.9d-2     !
        x_1 = 3.055d+0   !
        a = 8.3d-2       !
        rm = 3.412d+0    !
        endif
c
c
c   Baikal rock (basis, shore rocks and rocks 2 km below the Baikal bed)
c   --------------------------------------------------------------------
c        (as given at A.I.Panfilov, Baikal internal note 22/06/00)
c                         panfilov@inr.ruhep.ru
c
        if (imed.eq.-8) then
        ro = 1.0d+0
        nsub = 10            !
        n(1) = 2.7251d-2     ! -> O
        n(2) = 8.15367d-3    ! -> Si
        n(3) = 1.670844d-4   ! -> Ti
        n(4) = 2.89087d-3    ! -> Al
        n(5) = 1.8443247d-3  ! -> Fe
        n(6) = 3.640467d-5   ! -> Mn
        n(7) = 1.810327d-3   ! -> Mg
        n(8) = 1.946205d-3   ! -> Ca
        n(9) = 7.3945837d-4  ! -> Na
        n(10) = 1.278828d-4  ! -> K
        aw(1) = 15.9994d+0
        aw(2) = 28.0855d+0
        aw(3) = 47.88d+0
        aw(4) = 26.9815d+0
        aw(5) = 55.847d+0
        aw(6) = 54.938d+0
        aw(7) = 24.305d+0
        aw(8) = 40.078d+0
        aw(9) = 22.9898d+0
        aw(10) = 39.0983d+0
        z1(1) = 8.0d+0
        z1(2) = 14.0d+0
        z1(3) = 22.0d+0
        z1(4) = 13.0d+0
        z1(5) = 26.0d+0
        z1(6) = 25.0d+0
        z1(7) = 12.0d+0
        z1(8) = 20.0d+0
        z1(9) = 11.0d+0
        z1(10) = 19.0d+0
c                        !
        z_a = 4.96d-1    ! The same as for Standard Rock (what to do?!)
        ri_z = 1.364d-04 !     except for z_a which was meaured
        x_0 = 4.9d-2     !          to be equal to 0.496
        x_1 = 3.055d+0   !
        a = 8.3d-2       !
        rm = 3.412d+0    !
        endif
c
c     Baikal rock ("tankhoy layer", up to 2000 m below the Baikal bed)
c      There are data concerning 6 depths which differ each other by
c   ~10% in terms of density, Z, A, and composition. One had to choose
c      the data for 800 m below the Baikal bed which seem to be close
c                                to "average"
c   --------------------------------------------------------------------
c        (as given at A.I.Panfilov, Baikal internal note 22/06/00)
c                         panfilov@inr.ruhep.ru
c
        if (imed.eq.-9) then
        ro = 1.0d+0
        nsub = 10            !
        n(1) = 0.588d+0      ! -> O
        n(2) = 0.166d+0      ! -> Si
        n(3) = 0.002d+0      ! -> Ti
        n(4) = 0.093d+0      ! -> Al
        n(5) = 0.033d+0      ! -> Fe
        n(6) = 0.101d+0      ! -> H
        n(7) = 0.009d+0      ! -> Mg
        n(8) = 0.003d+0      ! -> Ca
        n(9) = 0.002d+0      ! -> Na
        n(10) = 0.003d+0     ! -> K
        aw(1) = 15.9994d+0
        aw(2) = 28.0855d+0
        aw(3) = 47.88d+0
        aw(4) = 26.9815d+0
        aw(5) = 55.847d+0
        aw(6) = 1.00794d+0
        aw(7) = 24.305d+0
        aw(8) = 40.078d+0
        aw(9) = 22.9898d+0
        aw(10) = 39.0983d+0
        z1(1) = 8.0d+0
        z1(2) = 14.0d+0
        z1(3) = 22.0d+0
        z1(4) = 13.0d+0
        z1(5) = 26.0d+0
        z1(6) = 1.0d+0
        z1(7) = 12.0d+0
        z1(8) = 20.0d+0
        z1(9) = 11.0d+0
        z1(10) = 19.0d+0
c                        !
        z_a = 5.47d-1    ! The same as for Standard Rock (what to do?!)
        ri_z = 1.364d-04 !     except for z_a which was meaured
        x_0 = 4.9d-2     !          to be equal to 0.547
        x_1 = 3.055d+0   !
        a = 8.3d-2       !
        rm = 3.412d+0    !
        endif
c
c      Baikal rock ("anos layer", 100 -- 500 m below the Baikal bed)
c      There are data concerning 6 depths which differ each other by
c   ~10% in terms of density, Z, A, and composition. One had to choose
c      the data for 300 m below the Baikal bed which seem to be close
c                                to "average"
c   --------------------------------------------------------------------
c        (as given at A.I.Panfilov, Baikal internal note 22/06/00)
c                         panfilov@inr.ruhep.ru
c
        if (imed.eq.-10) then
        ro = 1.0d+0
        nsub = 10            !
        n(1) = 0.519d+0      ! -> O
        n(2) = 0.149d+0      ! -> Si
        n(3) = 0.002d+0      ! -> Ti
        n(4) = 0.044d+0      ! -> Al
        n(5) = 0.006d+0      ! -> Fe
        n(6) = 0.268d+0      ! -> H
        n(7) = 0.004d+0      ! -> Mg
        n(8) = 0.001d+0      ! -> Ca
        n(9) = 0.001d+0      ! -> Na
        n(10) = 0.006d+0     ! -> K
        aw(1) = 15.9994d+0
        aw(2) = 28.0855d+0
        aw(3) = 47.88d+0
        aw(4) = 26.9815d+0
        aw(5) = 55.847d+0
        aw(6) = 1.00794d+0
        aw(7) = 24.305d+0
        aw(8) = 40.078d+0
        aw(9) = 22.9898d+0
        aw(10) = 39.0983d+0
        z1(1) = 8.0d+0
        z1(2) = 14.0d+0
        z1(3) = 22.0d+0
        z1(4) = 13.0d+0
        z1(5) = 26.0d+0
        z1(6) = 1.0d+0
        z1(7) = 12.0d+0
        z1(8) = 20.0d+0
        z1(9) = 11.0d+0
        z1(10) = 19.0d+0
c                        !
        z_a = 6.3d-1     ! The same as for Standard Rock (what to do?!)
        ri_z = 1.364d-04 !     except for z_a which was meaured
        x_0 = 4.9d-2     !          to be equal to 0.630
        x_1 = 3.055d+0   !
        a = 8.3d-2       !
        rm = 3.412d+0    !
        endif
c
c     Baikal ground ("alevrit silt", 0 -- 100 m below the Baikal bed)
c      There are data concerning 6 depths which differ each other by
c   ~10% in terms of density, Z, A, and composition. One had to choose
c      the data for 50 m below the Baikal bed which seem to be close
c                               to "average"
c   --------------------------------------------------------------------
c        (as given at A.I.Panfilov, Baikal internal note 22/06/00)
c                         panfilov@inr.ruhep.ru
c
        if (imed.eq.-11) then
        ro = 1.0d+0
        nsub = 10            !
        n(1) = 0.439d+0      ! -> O
        n(2) = 0.090d+0      ! -> Si NB: the litle fraction of S
        n(3) = 0.001d+0      ! -> Ti     had to be added to Si (very
        n(4) = 0.018d+0      ! -> Al     close elements, within
        n(5) = 0.005d+0      ! -> Fe      systematic errors)
        n(6) = 0.431d+0      ! -> H
        n(7) = 0.003d+0      ! -> Mg
        n(8) = 0.003d+0      ! -> Ca
        n(9) = 0.005d+0      ! -> Na
        n(10) = 0.003d+0     ! -> K
        aw(1) = 15.9994d+0
        aw(2) = 28.0855d+0
        aw(3) = 47.88d+0
        aw(4) = 26.9815d+0
        aw(5) = 55.847d+0
        aw(6) = 1.00794d+0
        aw(7) = 24.305d+0
        aw(8) = 40.078d+0
        aw(9) = 22.9898d+0
        aw(10) = 39.0983d+0
        z1(1) = 8.0d+0
        z1(2) = 14.0d+0
        z1(3) = 22.0d+0
        z1(4) = 13.0d+0
        z1(5) = 26.0d+0
        z1(6) = 1.0d+0
        z1(7) = 12.0d+0
        z1(8) = 20.0d+0
        z1(9) = 11.0d+0
        z1(10) = 19.0d+0
c                        !
        z_a = 7.11d-1    ! The same as for Standard Rock (what to do?!)
        ri_z = 7.5d-05   !  except for z_a which was meaured to be equal
        x_0 = 4.9d-2     ! to 0.711, ri_z had to be taken for water since
        x_1 = 3.055d+0   ! this ground is obviously closer to water than
        a = 8.3d-2       !               to rock...
        rm = 3.412d+0    !
        endif
c
c
c                  FREJUS ROCK ("single medium" model)
c                  ===================================
c       as described in W.Rhode, "Untersuchung der Energiespektren
c hochenergetischer Muonen im Frejusdetektor", Dissertation zur Erlangung
c  des Doktorgrades des Fachbereiches Physik der Bergischer UniversitaEt
c              Wupppertal, WUB-DIS 93-11, Oktober 1993, 232 pp.
c
        if (imed.eq.-12) then
        ro=1.0d+0        !
        nsub=1           !
        n(1)=1.d+0       !
        aw(1)=20.34      !
        z1(1)=1.012d+1   !
c                        ! Everything has been taken from
        z_a = 4.975d-1   !        W.Rhode Thesis
        ri_z = 1.49d-04  !
        x_0 = 2.88d-1    !
        x_1 = 3.196d+0   !
        a = 7.8d-2       !
        rm = 3.645d+0    !
        endif
c
c   Frejus rock ("composed medium" model), as it was incorporated in
c PROPMU code by W.Rhode (W.Rhode, private communication, October 2001)
c
        if (imed.eq.-13) then
        ro = 1.0d+0
        nsub = 10            !
        n(1) = 9.1800165d-3  ! -> C
        n(2) = 3.8712389d-2  ! -> O
        n(3) = 3.0446410d-4  ! -> Mg
        n(4) = 1.3342456d-3  ! -> Al
        n(5) = 3.6584715d-3  ! -> Si
        n(6) = 7.9523483d-5  ! -> S
        n(7) = 1.6650340d-4  ! -> K
        n(8) = 2.5955637d-3  ! -> Ca
        n(9) = 6.4072169d-6  ! -> Mn
        n(10) = 1.7417229d-4 ! -> Fe
        aw(1) = 12.11d+0
        aw(2) = 15.9994d+0
        aw(3) = 24.305d+0
        aw(4) = 26.981539d+0
        aw(5) = 28.0855d+0
        aw(6) = 32.066d+0
        aw(7) = 39.0983d+0
        aw(8) = 40.078d+0
        aw(9) = 54.93805d+0
        aw(10) = 55.847d+0
        z1(1) = 6.0d+0
        z1(2) = 8.0d+0
        z1(3) = 12.0d+0
        z1(4) = 13.0d+0
        z1(5) = 14.0d+0
        z1(6) = 16.0d+0
        z1(7) = 19.0d+0
        z1(8) = 20.0d+0
        z1(9) = 25.0d+0
        z1(10) = 26.0d+0
c
        z_a = 4.975d-1
        ri_z = 1.49d-04
        x_0 = 2.88d-1
        x_1 = 3.196d+0
        a = 7.8d-2
        rm = 3.645d+0
        endif
c
        ntot=0.d+0
        do i=1,nsub
        ntot=ntot+n(i) !----> ntot is total number of atoms in molecula
        enddo
        do i=1,nsub
        w(i)=n(i)/ntot !-----> w(i) are relative weights of different atoms
        enddo          !       w(i) = n(i) / ntot
c
        zmean=0.d+0
        do i=1,nsub
        zmean = zmean + (z1(i)*n(i))
        enddo
        zm = sngl(zmean/ntot) !-> mean charge of averaged atom (for Delec-s)
c
        a_ef = 0.d+0
        do i=1,nsub
        a_ef = a_ef + ((n(i)*aw(i))/ntot) !--> it is an effective atomic
        enddo                             !    weight for an averaged atom
c                                         !    for which diff. and total cros-
        return                            !    csections will be computed.
        end
****************************************************************************
* C.3_3
         SUBROUTINE spl13
*
       common /con_los3/ elosemin(17),elosvmin(17)
       common /eleng3/ eminleng(17)
       common /ctbr_in13/ FBC(17),FBC2(17)
       common /elbr_in13/ FBL(17),FBL2(17)
       common /elbr_in23/ FBL3(17)
       common /ctpa_in13/ FPC(17),FPC2(17)
       common /elpa_in13/ FPL(17),FPL2(17)
       common /elpa_in23/ FPL3(17)
       common /ctph_in13/ FNC(17),FNC2(65)
       common /elph_in13/ FNL(17),FNL2(65)
       common /elph_in23/ FNL3(17)
       common /ctel_in13/ FEC(17),FEC2(17)
       common /elel_in13/ FEL(17),FEL2(17)
       common /elel_in23/ FELBB(17),FELBBB(17)
       common /elel_in33/ FELOWTOT(101)
       common /sok343/ com_pa_m(2201)
       common /sok13/ xmin1_c,st1_c,xmax1_c
       common /eminl3/ xm1,s1,xma1
       common /sok53/ xmin1_l,st1_l,xmax1_l
       common /sok1n3/ xmin1_nc,st1_nc,xmax1_nc
       common /sok5n3/ xmin1_nl,st1_nl,xmax1_nl
       common /sok5et3/ xmin1_lo,st1_lo,xmax1_lo
       common /sok553/ xmin1_p,st1_p,xmax1_p
       common /sok1_b3/ CBC(19)
       common /sok5_b3TTT/ CBL(19)
       common /sok1_b23/ CBC2(19)
       common /sok5_b23/ CBL2(19)
       common /sok5_b33/ CBL3(19)
       common /sok1_p3/ CPC(19)
       common /sok5_p3TTT/ CPL(19)
       common /sok1_p23/ CPC2(19)
       common /sok5_p23/ CPL2(19)
       common /sok5_p33/ CPL3(19)
       common /sok1_n3/ CNC(19)
       common /sok5_n3TTT/ CNL(19)
       common /sok1_n23/ CNC2(67)
       common /sok5_n23/ CNL2(67)
       common /sok5_n33/ CNL3(19)
       common /sok1_e3/ CEC(19)
       common /sok5_e3/ CEL(19)
       common /sok1_e23/ CEC2(19)
       common /sok5_e23/ CEL2(19)
       common /sok5_e33/ CEBB(19)
       common /sok5_e43/ CEBBB(19)
       common /elem3/ CLE(19)
       common /elvm3/ CLV(19)
       common /eminl13/ CLE1(19)
       common /sok5_e53/ CETOT(103)
       common /sok55_p3/ CPC1(2203)
       dimension IJ(26)
       dimension xmin1(26),st1(26),xmax1(26)
       dimension F(2201),C(2203)
      data xmin1/1.e+0,1.e+0,1.e+0,1.e+0,1.e+0,1.e+0,1.e+0,1.e+0,1.e+0,
     +           1.e+0,1.e+0,1.e+0,1.e+0,1.e+0,1.e+0,1.e+0,1.e+0,1.e+0,
     +           1.e+0,1.e+0,1.e+0,1.e+0,1.e+0,-1.1e+1,-.853871964,
     +           1.e+0/
      data xmax1/9.e+0,9.e+0,9.e+0,9.e+0,9.e+0,9.e+0,9.e+0,9.e+0,
     +           9.e+0,9.e+0,9.e+0,9.e+0,9.e+0,9.e+0,9.e+0,9.e+0,9.e+0,
     +           9.e+0,9.e+0,9.e+0,9.e+0,9.e+0,9.e+0,0.e+0,1.146128036,
     +           9.e+0/
      data st1/5.e-1,5.e-1,5.e-1,5.e-1,5.e-1,5.e-1,5.e-1,5.e-1,
     +         5.e-1,5.e-1,5.e-1,5.e-1,1.25e-1,1.25e-1,5.e-1,5.e-1,
     +         5.e-1,5.e-1,5.e-1,5.e-1,5.e-1,5.e-1,5.e-1,5.e-3,2.e-2,
     +         5.e-1/
      data IJ/17,17,17,17,17,17,17,17,17,17,17,17,65,65,
     +        17,17,17,17,17,17,17,17,17,2201,101,17/
c
      do lik=1,26  !--> A cycle along all input arrays
          N = IJ(lik)  !--> Getting dimension for given inpiut array
c
          if (lik.eq.1) then     ! GETTING FIRST VALUE,
           xmin1_c = xmin1(lik)  !      STEP AND LAST VALUE OF ARGUMENT
           st1_c = st1(lik)      !         FOR ALL INPUT ARRAYS
           xmax1_c = xmax1(lik)  !           IN ACCORING WITH THEIR NUMBERS
          endif                  !                     ( LIK )
          if (lik.eq.2) then     !
           xmin1_l = xmin1(lik)  !
           st1_l = st1(lik)      !
           xmax1_l = xmax1(lik)  !
          endif                  !
          if (lik.eq.13) then    !
           xmin1_nc = xmin1(lik) !
           st1_nc = st1(lik)     !
           xmax1_nc = xmax1(lik) !
          endif                  !
          if (lik.eq.14) then    !
           xmin1_nl = xmin1(lik) !
           st1_nl = st1(lik)     !
           xmax1_nl = xmax1(lik) !
          endif                  !
          if (lik.eq.24) then    !
           xmin1_p = xmin1(lik)  !
           st1_p = st1(lik)      !
           xmax1_p = xmax1(lik)  !
          endif                  !
          if (lik.eq.25) then    !
           xmin1_lo = xmin1(lik) !
           st1_lo = st1(lik)     !
           xmax1_lo = xmax1(lik) !
          endif                  !
          if (lik.eq.26) then    !
           xm1 = xmin1(lik)      !
           s1 = st1(lik)         !
           xma1 = xmax1(lik)     !
          endif                  !
c                                ---------------
          do jj=1,N                            !
            if (lik.eq.1) F(jj) = FBC(jj)      !
            if (lik.eq.2) F(jj) = FBL(jj)      !
            if (lik.eq.3) F(jj) = FBC2(jj)     ! Filling the auxiliary array
            if (lik.eq.4) F(jj) = FBL2(jj)     ! F with values of input array
            if (lik.eq.5) F(jj) = FBL3(jj)     ! number LIK for further
            if (lik.eq.6) F(jj) = FPC(jj)      !                processing.
            if (lik.eq.7) F(jj) = FPL(jj)      !
            if (lik.eq.8) F(jj) = FPC2(jj)     !
            if (lik.eq.9) F(jj) = FPL2(jj)     !
            if (lik.eq.10) F(jj) = FPL3(jj)    !
            if (lik.eq.11) F(jj) = FNC(jj)     !
            if (lik.eq.12) F(jj) = FNL(jj)     !
            if (lik.eq.13) F(jj) = FNC2(jj)    !
            if (lik.eq.14) F(jj) = FNL2(jj)    !
            if (lik.eq.15) F(jj) = FNL3(jj)    !
            if (lik.eq.16) F(jj) = FEC(jj)     !
            if (lik.eq.17) F(jj) = FEL(jj)     !
            if (lik.eq.18) F(jj) = FEC2(jj)    !
            if (lik.eq.19) F(jj) = FEL2(jj)    !
            if (lik.eq.20) F(jj) = FELBB(jj)   !
            if (lik.eq.21) F(jj) = FELBBB(jj)  !
            if (lik.eq.22) F(jj) = elosemin(jj)!
            if (lik.eq.23) F(jj) = elosvmin(jj)!
            if (lik.eq.24) F(jj) = com_pa_m(jj)!
            if (lik.eq.25) F(jj) = FELOWTOT(jj)!
            if (lik.eq.26) F(jj) = eminleng(jj)!
           enddo                               !
c----------------------------------------------!
      C(1)=1.4375*F(1)-1.3750*F(2)+0.4375*F(3)  !
      C(2)=0.4375*F(1)+0.1250*F(2)-0.0625*F(3)    !
      DO 1 K=3,N                                    ! ---> Cooking splayns
1     C(K)= 0.6250*F(K-1)-0.0625*(F(K-2)+F(K))       ! and putting them into
      C(N+1)=0.4375*F(N)+0.1250*F(N-1)-0.0625*F(N-2) !  auxiliary array C
      C(N+2)=1.4375*F(N)-1.375*F(N-1)+0.4375*F(N-2)  !
c----------------------------------------------------
         mo = N+2                          !
         do jj=1,mo                        ! Splain coefficients from C are
           if (lik.eq.1) CBC(jj) = C(jj)   ! put into corresponding array N LIK
           if (lik.eq.2) CBL(jj) = C(jj)   ! which is passed to corresponding
           if (lik.eq.3) CBC2(jj) = C(jj)  ! subroutine for interpolation.
           if (lik.eq.4) CBL2(jj) = C(jj)  !
           if (lik.eq.5) CBL3(jj) = C(jj)  !
           if (lik.eq.6) CPC(jj) = C(jj)   !
           if (lik.eq.7) CPL(jj) = C(jj)   !
           if (lik.eq.8) CPC2(jj) = C(jj)  !
           if (lik.eq.9) CPL2(jj) = C(jj)  !
           if (lik.eq.10) CPL3(jj) = C(jj) !
           if (lik.eq.11) CNC(jj) = C(jj)  !
           if (lik.eq.12) CNL(jj) = C(jj)  !
           if (lik.eq.13) CNC2(jj) = C(jj) !
           if (lik.eq.14) CNL2(jj) = C(jj) !
           if (lik.eq.15) CNL3(jj) = C(jj) !
           if (lik.eq.16) CEC(jj) = C(jj)  !
           if (lik.eq.17) CEL(jj) = C(jj)  !
           if (lik.eq.18) CEC2(jj) = C(jj) !
           if (lik.eq.19) CEL2(jj) = C(jj) !
           if (lik.eq.20) CEBB(jj) = C(jj) !
           if (lik.eq.21) CEBBB(jj) = C(jj)!
           if (lik.eq.22) CLE(jj) = C(jj)  !
           if (lik.eq.23) CLV(jj) = C(jj)  !
           if (lik.eq.24) CPC1(jj) = C(jj) !
           if (lik.eq.25) CETOT(jj) = C(jj)!
           if (lik.eq.26) CLE1(jj) = C(jj) !
         enddo                             !
      enddo
      RETURN
      END
****************************************************************************
* C.4_3
      SUBROUTINE dspl13
*
      real*8 com_pa_in(1101)
      real*8 CP_1(1103)
      real*8 xmin_p1,st_p1,xmax_p1
      real*8 xmin1(1),st1(1),xmax1(1)
      real*8 F(1101),C(1103)
      common /sok243/ com_pa_in
      common /sok263/ CP_1
      common /sok253/ xmin_p1,st_p1,xmax_p1
      dimension IJ(1)
      data xmin1/-1.1d+1/
      data xmax1/0.d+0/
      data st1/1.d-2/
      data IJ/1101/
c
      do lik=1,1  !--> A cycle along all input arrays
          N = IJ(lik) !--> Getting dimension for given input array
c
          if (lik.eq.1) then     ! GETTING FIRST VALUE, STEP AND LAST VALUE
           xmin_p1 = xmin1(lik)  ! OF ARGUMENTS FOR ALL INPUT ARRAYS IN
           st_p1 = st1(lik)      ! ACCORDING TO THEIR NUMBERS (LIK)
           xmax_p1 = xmax1(lik)  !
          endif                  !
c
          do jj=1,N                             ! Filling the auxiliary array F
            if (lik.eq.1) F(jj) = com_pa_in(jj) ! with values of corresponding
          enddo                                 ! input array Nb. LIK
c
      C(1)=1.4375*F(1)-1.3750*F(2)+0.4375*F(3)        !
      C(2)=0.4375*F(1)+0.1250*F(2)-0.0625*F(3)        ! Cookiing splain
      DO 1 K=3,N                                      ! coefficients and
1     C(K)= 0.6250*F(K-1)-0.0625*(F(K-2)+F(K))        ! putting them into
      C(N+1)=0.4375*F(N)+0.1250*F(N-1)-0.0625*F(N-2)  ! auxiliary array C
      C(N+2)=1.4375*F(N)-1.375*F(N-1)+0.4375*F(N-2)   !
c
         mo = N+2                         ! Splain coefficients from C are
         do jj=1,mo                       ! put into corresponding output
           if (lik.eq.1) CP_1(jj) = C(jj) ! array Nb. LIK whic is passe to
         enddo                            ! corresponding subroutine
c                                         ! for interpolation
      enddo
      RETURN
      END
****************************************************************************
* C.5_3
         SUBROUTINE spl23
*
      common /cdbr_in3/ FB1(81,54),FB3(81,101),FB2(81,51)
      common /cdpa_in3/ FP1(81,54),FP3(81,101),FP2(81,51)
      common /cdph_in3/ FN1(81,54),FN3(81,101),FN2(81,51)
      common /sok3_3/ CB1(4648)
      common /sok63/ CB2(4399)
      common /sok43/ CB3(8549)
      common /sok83/ CP1(4648)
      common /sok93/ CP2(4399)
      common /sok103/ CP3(8549)
      common /mum83/ CN1(4648)
      common /mum93/ CN2(4399)
      common /mum103/ CN3(8549)
      common /sok_2_13/ NX_1,NY_1,X0_1,SX_1,Y0_1,SY_1
      common /sok_2_23/ NX_2,NY_2,X0_2,SX_2,Y0_2,SY_2
      common /sok_2_33/ NX_3,NY_3,X0_3,SX_3,Y0_3,SY_3
      DIMENSION D(90,110),FU(81,101),CU(8549)
      DIMENSION NXG(9),NYG(9),X0G(9),SXG(9),Y0G(9),SYG(9)
      DIMENSION IJ(9)
      data NXG/81,81,81,81,81,81,81,81,81/
      data NYG/54,51,101,54,51,101,54,51,101/
      data X0G/1.e+0,1.e+0,1.e+0,1.e+0,1.e+0,1.e+0,1.e+0,1.e+0,1.e+0/
      data SXG/1.e-1,1.e-1,1.e-1,1.e-1,1.e-1,1.e-1,1.e-1,1.e-1,1.e-1/
      data Y0G/-11.,-6.e-1,-1.e-1,-11.,-6.e-1,-1.e-1,-11.,-6.e-1,-1.e-1/
      data SYG/2.e-1,1.e-2,1.e-3,2.e-1,1.e-2,1.e-3,2.e-1,1.e-2,1.e-3/
      data IJ/4648,4399,8549,4648,4399,8549,4648,4399,8549/
c
      do li=1,9
      NX = NXG(li)
      NY = NYG(li)
      X0 = X0G(li)
      SX = SXG(li)
      Y0 = Y0G(li)
      SY = SYG(li)
c
       if (li.eq.1) then
         NX_1 = NX
         NY_1 = NY
         X0_1 = X0
         SX_1 = SX
         Y0_1 = Y0
         SY_1 = SY
       endif
c
       if (li.eq.2) then
         NX_2 = NX
         NY_2 = NY
         X0_2 = X0
         SX_2 = SX
         Y0_2 = Y0
         SY_2 = SY
       endif
c
       if (li.eq.3) then
         NX_3 = NX
         NY_3 = NY
         X0_3 = X0
         SX_3 = SX
         Y0_3 = Y0
         SY_3 = SY
       endif
c
        do ki=1,NX
           do kl=1,NY
              if (li.eq.1) FU(ki,kl) = FB1(ki,kl)
              if (li.eq.2) FU(ki,kl) = FB2(ki,kl)
              if (li.eq.3) FU(ki,kl) = FB3(ki,kl)
              if (li.eq.4) FU(ki,kl) = FP1(ki,kl)
              if (li.eq.5) FU(ki,kl) = FP2(ki,kl)
              if (li.eq.6) FU(ki,kl) = FP3(ki,kl)
              if (li.eq.7) FU(ki,kl) = FN1(ki,kl)
              if (li.eq.8) FU(ki,kl) = FN2(ki,kl)
              if (li.eq.9) FU(ki,kl) = FN3(ki,kl)
           enddo
        enddo
cccccccc 2019 - ATTENTION!
      I2=1
cccccccc
      DO 1 J=1,NY
      J2=J+2
      DO 1 I=1,NX
      I2=I+2
1     D(I2,J2)=3.90625E-3*FU(I,J)
      J1=NY+1
      J3=J2+1
      J4=J3+1
      DO 2 I=3,I2
      A=D(I,3)
      B=D(I,4)
      D(I,2)=3.*(A-B)+D(I,5)
      D(I,1)=3.*(D(I,2)-A)+B
      A=D(I,J1)
      B=D(I,J2)
      D(I,J3)=3.*(B-A)+D(I,NY)
2     D(I,J4)=3.*(D(I,J3)-B)+A
      I1=NX+1
      I3=I2+1
      I4=I3+1
      DO 3 J=1,J4
      A=D(3,J)
      B=D(4,J)
      D(2,J)=3.*(A-B)+D(5,J)
      D(1,J)=3.*(D(2,J)-A)+B
      A=D(I1,J)
      B=D(I2,J)
      D(I3,J)=3.*(B-A)+D(NX,J)
3     D(I4,J)=3.*(D(I3,J)-B)+A
      DO 4 J=1,J2
      J3=J+1
      J4=J+2
      M=(J-1)*I2
      DO 4 I=1,I2
      I3=I+1
      I4=I+2
4     CU(M+I)=D(I,J)+D(I,J4)+D(I4,J)+D(I4,J4)+D(I3,J3)* !
     *100.-(D(I3,J)+D(I,J3)+D(I4,J3)+D(I3,J4))*10.      !
c
       ko = IJ(li)
       do ki=1,ko
              if (li.eq.1) CB1(ki) = CU(ki)
              if (li.eq.2) CB2(ki) = CU(ki)
              if (li.eq.3) CB3(ki) = CU(ki)
              if (li.eq.4) CP1(ki) = CU(ki)
              if (li.eq.5) CP2(ki) = CU(ki)
              if (li.eq.6) CP3(ki) = CU(ki)
              if (li.eq.7) CN1(ki) = CU(ki)
              if (li.eq.8) CN2(ki) = CU(ki)
              if (li.eq.9) CN3(ki) = CU(ki)
       enddo
      enddo
      RETURN
      END
****************************************************************************
* C.6_3
        SUBROUTINE enlos3
*
c     From GAMMA13:
      common /elbr_in13/ elo_br1(17),elo_br2(17)
      common /elbr_in23/ elo_br3(17)
      common /elbr_in43/ elo_br4(17)
      common /ctbr_in13/ crt_br1(17),crt_br2(17)
c     From PAIR13
      common /elpa_in13/ elo_pa1(17),elo_pa2(17)
      common /elpa_in23/ elo_pa3(17)
      common /elpa_in43/ elo_pa4(17)
      common /ctpa_in13/ crt_pa1(17),crt_pa2(17)
c     From PHNU13:
      common /elph_in13/ elo_ph1(17),elo_ph2(65)
      common /elph_in23/ elo_ph3(17)
      common /elph_in43/ elo_ph4(17)
      common /ctph_in13/ crt_ph1(17),crt_ph2(65)
c     From ELEC13:
      common /elel_in13/ elo_el1(17),elo_el2(17)
      common /elel_in23/ elel_bb(17),elel_bbb(17)
      common /ctel_in13/ crt_el1(17),crt_el2(17)
c     To SPL13:
      common /con_los3/ elosemin(17),elosvmin(17)
      common /eleng3/ eminleng(17)
c
      do i=1,17
       j = (4 * i) - 3
       elosemin(i) = elo_br4(i)
       elosvmin(i) = (1.e+1**elo_br3(i)) - (1.e+1**elo_br2(i))
       elosemin(i) = elosemin(i) + elo_pa4(i)
       elosvmin(i) = elosvmin(i) + exp(elo_pa3(i)) - exp(elo_pa2(i))
       elosemin(i) = elosemin(i) + elo_ph4(i)
       elosvmin(i) = elosvmin(i) + 1.e+1**elo_ph3(i) - 1.e+1**elo_ph2(j)
       elosemin(i) = elosemin(i) + elel_bbb(i) - 1.e+1**elo_el1(i)
       elosvmin(i) = elosvmin(i) + elel_bbb(i) - 1.e+1**elo_el2(i)
       elosvmin(i) = alog(elosvmin(i))
       eminleng(i) = 1./crt_br1(i) + 1./exp(crt_pa1(i)) +
     +                              1./exp(crt_ph1(i)) + 1./crt_el1(i)
       eminleng(i) = 1./eminleng(i)
      enddo
      return
      end
****************************************************************************
* C.7_3
             FUNCTION cone3(X)
*
      real*4 X
      COMMON /sok53/ XMIN,STEP,XMAX
      common /elem3/ C(19)
      X1 = alog10(X)
       if ((X1.lt..99999e+0).or.(X1.gt.9.0001e+0)) then
       print*,'ERROR IN FUNCTION CONES: MUON ENERGY IS OUT OF RANGE'
       endif
      Y = (X1-XMIN)/STEP
      I = INT(Y+0.5)
      IF(I.LT.0.OR.X1.GT.XMAX) PRINT 1,X1,XMIN,XMAX
      Y = Y-I
      Z = Y*Y + 0.25
      cone3 = (Z-Y)*C(I+1) + (2.-(Z+Z))*C(I+2) + (Z+Y)*C(I+3)
      RETURN
1     FORMAT('*MISTAKE*X1=',D23.16,'XMIN=',D23.16,'XMAX=',D23.16)
      END
****************************************************************************
* C.8_3
             FUNCTION conv3(X)
*
      real*4 X
      COMMON /sok53/ XMIN,STEP,XMAX
      common /elvm3/ C(19)
      X1 = alog10(X)
       if ((X1.lt..99999e+0).or.(X1.gt.9.0001e+0)) then
       print*,'ERROR IN FUNCTION CONVS: MUON ENERGY IS OUT OF RANGE'
       endif
      Y = (X1-XMIN)/STEP
      I = INT(Y+0.5)
      IF(I.LT.0.OR.X1.GT.XMAX) PRINT 1,X1,XMIN,XMAX
      Y = Y-I
      Z = Y*Y + 0.25
      conv3 = (Z-Y)*C(I+1) + (2.-(Z+Z))*C(I+2) + (Z+Y)*C(I+3)
      conv3 = exp(conv3)
      RETURN
1     FORMAT('*MISTAKE*X1=',D23.16,'XMIN=',D23.16,'XMAX=',D23.16)
      END
****************************************************************************
* C.9_3
         FUNCTION gemleng3(X)
*
      real*4 X
      COMMON /eminl3/ XMIN,STEP,XMAX
      common /eminl13/ C(19)
      X1 = alog10(X)
       if ((X1.lt..99999e+0).or.(X1.gt.9.0001e+0)) then
       print*,'ERROR IN FUNCTION GEMLENGS: MUON ENERGY IS OUT OF RANGE'
       endif
      Y = (X1-XMIN)/STEP
      I = INT(Y+0.5)
      IF(I.LT.0.OR.X1.GT.XMAX) PRINT 1,X1,XMIN,XMAX
      Y = Y-I
      Z = Y*Y + 0.25
      gemleng3= (Z-Y)*C(I+1) + (2.-(Z+Z))*C(I+2) + (Z+Y)*C(I+3)
      RETURN
1     FORMAT('*MISTAKE*X1=',D23.16,'XMIN=',D23.16,'XMAX=',D23.16)
      END
************************************************************************
* C.10_3
      subroutine frepathv3
*
      external glbremv3,glpairv3,glphnuv3,glelecv3,conv3
      external dsimps,gdedelt23
      real*8 e0(0:128),a(0:128),b(0:128),eta(0:128),leng(0:128)
      real*8 fk,fk1,dlnmax,slu,e,en,delta
      real*8 low,up,step1,aux1(0:10),rest,eta_1,hd3,pat1,pat2
      real*8 ene,path
      real*8 dsimps
      common /vrand13/ vpath(111,161)
      common /vrand23/ vener(111,161)
      common /simv13/ fk,fk1,dlnmax,a,b,leng,e0
c
c   ---------------------------------------------------------------
c   1. Computing arrays e0(0:128), a(0:128), b(0:128), eta(0:128),
c           leng(0:128) and constants FK, FK1 and DLNMAX
c
      fk=dexp(-(dlog(1.d+1)/1.6d+1)) !--> a coefficient to get
      fk1 = 1.d+0 / dlog(fk)         !    e0(i)=fk*e0(i-1) and
      dlnmax = dlog(1.d+9)           !    some useful constants
c
      e0(0) = 1.d+9
        do i=1,128
        e0(i) = e0(0) * (fk**dble(i))         !-> e0(i)
        y2 = (conv3(sngl(e0(i-1))) * 1.e-3)    !-> dE/dx (e0(i-1))
        y1 = (conv3(sngl(e0(i))) * 1.e-3)      !-> dE/dx (e0(i))
        a(i) = dble((y2 - y1)) / (e0(i-1) - e0(i)) !-> a(i)
        b(i) = dble(y1) - a(i) * e0(i)             !-> b(i)
c
c                     Computing two integrals
c
c       ..................................................
c       .             e0(i-1)                            .
c       .   eta(i) = INTEGRAL(dE/(dE/dx(E) * L_mean(E))  .
c       .              e0(i)                             .
c       .                                                .
c       .                  e0(i-1)                       .
c       .       leng(i) = INTEGRAL (dE/(dE/dx(E)))       .
c       .                  e0(i)                         .
c       ..................................................
c
c using a formula INTEGRAL [f(x) * dx] = INTEGRAL [x * f(x) * d(ln(x))] :
c
        low = dlog(e0(i))
        up = dlog(e0(i-1))
        lim1 = 10
        step1 = (up - low) / dble(lim1)
         do j=0,lim1
         ene = low + (dble(j) * step1)
         h1 = sngl(dexp(ene))
         help=(1./glbremv3(h1))+(1./glpairv3(h1))+(1./glphnuv3(h1)) +
     +           (1./glelecv3(h1))
         aux1(j) = (1.d+0 / dble(help))*dble(conv3(h1))*1.d-3/dble(h1)
         aux1(j) = 1.d+0 / aux1(j)
         enddo
         eta(i) = dsimps(aux1,low,up,lim1)
c
         do j=0,lim1
         ene = low + (dble(j) * step1)
         h1 = sngl(dexp(ene))
         aux1(j) = dble(conv3(h1)) * 1.d-3 / dble(h1)
         aux1(j) = 1.d+0 / aux1(j)
         enddo
         leng(i) = dsimps(aux1,low,up,lim1)
        enddo
c
      do i=127,1,-1
c
c              e0(i-1)
c   leng(i) = INTEGRAL (dE/(dE/dx(E))) :
c              10 GeV
c
      leng(i) = leng(i) + leng(i+1)
c
c            e0(i-1)
c  eta(i) = INTEGRAL(dE/(dE/dx(E) * L_mean(E))) :
c            10 GeV
c
      eta(i) = eta(i) + eta(i+1)
      enddo
c
c   Auxiliary arrays a(128), b(128), e0(128), eta(128), leng(128)
c                    have been prepared.
c   ---------------------------------------------------------------
c                       2. Solving the equation (3)
c
c  to get the final energy E1 for a set of E0 ("e" variable) and
c                        ETA ("slu" variable):
c
      do i=-80,30             !--> 111 values of SLU (logarithmi-
        slu = dble(i) * 5.d-2 !    cally equidestant grid with
        slu = 1.d+1**slu      !    slu_min=0.0001, slu_max=1000
        do j=180,20,-1         !-> 161 values of E (logarithmi-
          e = dble(j) * 5.d-2  !   cally equidestant grid with
          e = 1.d+1**e         !   e_min = 10 GeV, e_max = 1 EeV
            if (e.le.1.011d+1) then
            ene = 1.0000001d+1
            path = 0.d+0
            goto 444
            endif
c        vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv
          me = idint( ( dlog(e) - dlog(1.d+9) ) / dlog(fk) ) + 1
c        ME is a number of segment which contains given energy E
c        ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
c                       Rewriting the equation (3) as
c
c                   E0         E0         E1
c                INTEGRAL = INTEGRAL - INTEGRAL = ETA  (3a)
c                   E1       10 GeV     10 GeV
c
c                                 or
c
c                     E1         E0
c                  INTEGRAL = INTEGRAL - ETA = ETA_1   (3b)
c                   10 GeV     10 GeV
c
            if (me.lt.128) then
            eta_1 = eta(me+1) - slu
            else
            eta_1 = (-1.d+0) * slu
            endif
        low = dlog(e0(me))
        up = dlog(e)
        lim1 = 10
        step1 = (up - low) / dble(lim1)
         do j1=0,lim1
         en = low + (dble(j1) * step1)
         h1 = sngl(dexp(en))
         help =(1./glbremv3(h1))+(1./glpairv3(h1))+(1./glphnuv3(h1)) +
     +           (1./glelecv3(h1))
         aux1(j1)=(1.d+0 / dble(help))*dble(conv3(h1))*1.d-3/dble(h1)
         aux1(j1) = 1.d+0 / aux1(j1)
         enddo
         eta_1 = eta_1 + dsimps(aux1,low,up,lim1)
c---------------------------------
        if (eta_1.le.0.d+0) then !
        ene = 1.0000001d+1       !--> no interactions with energy transfers
        m1 = 128                 !              transfers > Vmin,
        goto 402                 !         the final energy is 10 GeV
        endif                    !
c---------------------------------
            m1 = 500
            do m=128,1,-1
              if (eta(m).ge.eta_1) then
              m1 = m
              goto 401
              endif
            enddo
          if (m1.ge.200) then
          hd3 = dabs((eta(1) - eta_1) / eta(1))
             if (hd3.le.1.d-6) then
             m1 = 1
             eta_1 = eta(1)*9.9999999d-1
             goto 401
             endif
          print*,'******** SUBROUTINE FREPATV:  ERROR !!!!! ********'
          goto 402
          endif
  401     continue
            if (m1.lt.128) then
            rest = eta_1 - eta(m1+1)
            else
            rest = eta_1
            endif
c
         ic = 0
         lim1 = 10
         ene = (e0(m1-1) + e0(m1)) * 5.d-1
         delta = e0(m1-1) - ene
         low = dlog(e0(m1))
 3333    up = dlog(ene)
         step1 = (up - low) / dble(lim1)
         do j1=0,lim1
         en = low + (dble(j1) * step1)
         h1 = sngl(dexp(en))
         help=(1./glbremv3(h1))+(1./glpairv3(h1))+(1./glphnuv3(h1)) +
     +           (1./glelecv3(h1))
         aux1(j1)=(1.d+0 / dble(help))*dble(conv3(h1))*1.d-3/dble(h1)
         aux1(j1) = 1.d+0 / aux1(j1)
         enddo
         pat1 = dsimps(aux1,low,up,lim1)
         delta = 5.d-1 * delta
         ic = ic + 1
         if (pat1.le.rest) then
         ene = ene + delta
         else
         ene = ene - delta
         endif
         if (ic.eq.20) then
         goto 402
         endif
         goto 3333
 402     continue
c
c            Equation (3) has been solved., the root is ENE
c   ---------------------------------------------------------------
c            3. Computing of real free path from E0 to ENE:
c
c                            E0
c                  PATH = INTEGRAL [ dE/(dE/dx(E)) ] =
c                            ENE
c
c          E0                          ENE
c     = INTEGRAL [ dE/(dE/dx(E)) ] - INTEGRAL [ dE/(dE/dx(E)) ]
c        10 GeV                       10 GeV
c
      if (me.lt.128) then
        low = dlog(e0(me))
        up = dlog(e)
        lim1 = 10
        step1 = (up - low) / dble(lim1)
         do j2=0,lim1
         en = low + (dble(j2) * step1)
         h1 = sngl(dexp(en))
         aux1(j2) = dble(conv3(h1)) * 1.d-3 / dble(h1)
         aux1(j2) = 1.d+0 / aux1(j2)
         enddo
         pat1 = dsimps(aux1,low,up,lim1) + leng(me+1)
      else
        low = dlog(e0(me))
        up = dlog(e)
        lim1 = 10
        step1 = (up - low) / dble(lim1)
         do j2=0,lim1
         en = low + (dble(j2) * step1)
         h1 = sngl(dexp(en))
         aux1(j2) = dble(conv3(h1)) * 1.d-3 / dble(h1)
         aux1(j2) = 1.d+0 / aux1(j2)
         enddo
         pat1 = dsimps(aux1,low,up,lim1)
      endif
c
      if (m1.lt.128) then
        low = dlog(e0(m1))
        up = dlog(ene)
        lim1 = 10
        step1 = (up - low) / dble(lim1)
         do j2=0,lim1
         en = low + (dble(j2) * step1)
         h1 = sngl(dexp(en))
         aux1(j2) = dble(conv3(h1)) * 1.d-3 / dble(h1)
         aux1(j2) = 1.d+0 / aux1(j2)
         enddo
         pat2 = dsimps(aux1,low,up,lim1) + leng(m1+1)
      else
        low = dlog(e0(m1))
        up = dlog(ene)
        lim1 = 10
        step1 = (up - low) / dble(lim1)
         do j2=0,lim1
         en = low + (dble(j2) * step1)
         h1 = sngl(dexp(en))
         aux1(j2) = dble(conv3(h1)) * 1.d-3 / dble(h1)
         aux1(j2) = 1.d+0 / aux1(j2)
         enddo
         pat2 = dsimps(aux1,low,up,lim1)
      endif
      path = pat1 - pat2
c
c          The equation is solved, the root is PATH
c
  444 continue
      if (path.le.0.d+0) path = 1.d+0
      if (ene.le.1.00001d+1) ene = 9.999d+0
      path = path/slu
      ene = ene / e
      vpath(i+81,j-19) = sngl(path)
      vener(i+81,j-19) = sngl(ene)
        enddo
      enddo
c
      return
      end
****************************************************************************
* C.11_3
         SUBROUTINE spl2_23
*
      common /vrand13/ vpath(111,161)
      common /vrand23/ vener(111,161)
      common /vrand1_o3/ CPA(18419)
      common /vrand2_o3/ CEN(18419)
      common /vpath13/ NX_1,NY_1,X0_1,SX_1,Y0_1,SY_1
      common /vpath23/ NX_2,NY_2,X0_2,SX_2,Y0_2,SY_2
      DIMENSION D(130,180),FU(111,161),CU(18419)
      DIMENSION NXG(2),NYG(2),X0G(2),SXG(2),Y0G(2),SYG(2)
      DIMENSION IJ(2)
c
      data NXG/111,111/
      data NYG/161,161/
      data X0G/-4.,-4./
      data SXG/5.e-2,5.e-2/
      data Y0G/1.,1./
      data SYG/5.e-2,5.e-2/
      data IJ/18419,18419/
c
      do li=1,2     ! A cycle along all input arrays
      NX = NXG(li)  ! assigns values from corresonding arrais for numbers of
      NY = NYG(li)  ! values, steps and initial values
      X0 = X0G(li)  !
      SX = SXG(li)  !
      Y0 = Y0G(li)  !
      SY = SYG(li)  !
c
       if (li.eq.1) then
         NX_1 = NX     !-> number of X values
         NY_1 = NY     !-> number of Y values
         X0_1 = X0     !-> first value of X
         SX_1 = SX     !-> step by X
         Y0_1 = Y0     !-> first value of Y
         SY_1 = SY     !-> step by Y
       endif
c
       if (li.eq.2) then
         NX_2 = NX    !-> number of X values
         NY_2 = NY    !-> number of Y values
         X0_2 = X0    !-> first value of X
         SX_2 = SX    !-> step by X
         Y0_2 = Y0    !-> first value of Y
         SY_2 = SY    !-> step by Y
       endif
c
        do ki=1,NX                                ! Filling an auxiliary
           do kl=1,NY                              ! array FU by values
              if (li.eq.1) FU(ki,kl) = vpath(ki,kl) ! from input array
              if (li.eq.2) FU(ki,kl) = vener(ki,kl) ! (within a cycle by
c                                                  ! LI along all input
c                                                 ! arrays)
           enddo                                 !
        enddo                                   !
cccccccc 2019 - ATTENTION!
      I2=1
cccccccc
c-----------------------------------------------
      DO 1 J=1,NY                  !
      J2=J+2                       !
      DO 1 I=1,NX                  !
      I2=I+2                       !
1     D(I2,J2)=3.90625E-3*FU(I,J)  !
      J1=NY+1                      !
      J3=J2+1                      !
      J4=J3+1                      !
      DO 2 I=3,I2                  !
      A=D(I,3)                     !
      B=D(I,4)                     !---> Cooking splain coefficients
      D(I,2)=3.*(A-B)+D(I,5)       !     out of input array Nb. LI
      D(I,1)=3.*(D(I,2)-A)+B       !     and putting these splains
      A=D(I,J1)                    !     into 1-dimensional array
      B=D(I,J2)                    !                 CU
      D(I,J3)=3.*(B-A)+D(I,NY)     !
2     D(I,J4)=3.*(D(I,J3)-B)+A     !
      I1=NX+1                      !
      I3=I2+1                      !
      I4=I3+1                      !
      DO 3 J=1,J4                  !
      A=D(3,J)                     !
      B=D(4,J)                     !
      D(2,J)=3.*(A-B)+D(5,J)       !
      D(1,J)=3.*(D(2,J)-A)+B       !
      A=D(I1,J)                    !
      B=D(I2,J)                    !
      D(I3,J)=3.*(B-A)+D(NX,J)       !
3     D(I4,J)=3.*(D(I3,J)-B)+A         !
      DO 4 J=1,J2                        !
      J3=J+1                               !
      J4=J+2                                 !
      M=(J-1)*I2                               !
      DO 4 I=1,I2                                !
      I3=I+1                                       !
      I4=I+2                                         !
4     CU(M+I)=D(I,J)+D(I,J4)+D(I4,J)+D(I4,J4)+D(I3,J3)* !
     *100.-(D(I3,J)+D(I,J3)+D(I4,J3)+D(I3,J4))*10.      !
c--------------------------------------------------------
       ko = IJ(li)
       do ki=1,ko                            !
              if (li.eq.1) CPA(ki) = CU(ki)  ! Passing the values of splain
              if (li.eq.2) CEN(ki) = CU(ki)  ! coefficients form auxiliary
c                                            ! array CU to corresponding
c                                            ! output array Nb. LI
       enddo                                 !
      enddo
      RETURN
      END
****************************************************************************
* C.12_3
       FUNCTION getlanrv3(X,Y)
*
       real*4 X,Y
       common /vrand1_o3/ C1(18419)
       common /vpath13/ NX,NY,X0,SX,Y0,SY
c
      X_1=alog10(X)
      if ((X_1.lt.-4.0001).or.(X_1.gt.1.5001)) then
      print*,'ERROR IN FUNCTION GETLANRVS: RANDOM NB. IS OUT OF RANGE'
      endif
c
      Y_1=alog10(Y)
      if ((Y_1.lt..99999).or.(Y_1.gt.9.0001)) then
      print*,'ERROR IN FUNCTION GETLANRVS: MUON ENERGY IS OUT OF RANGE'
      endif
c
      A3=(X_1-X0)/SX
      B3=(Y_1-Y0)/SY
      M1=INT(A3+.5)
      M2=INT(B3+.5)
      M3=NX+2
      IF(M1.LT.0.OR.M1.GE.NX.OR.M2.LT.0.OR.M2.GE.NY) THEN
      PRINT 1,X_1,M1,Y_1,M2
      ENDIF
      A3=A3-M1
      B3=B3-M2
      M1=M2*M3+M1+1
      M2=M1+M3
      M3=M2+M3
      A2 = A3*A3 +.25
      B2 = B3*B3 +.25
      A1=A2-A3
      B1=B2-B3
      A3=A2+A3
      B3=B2+B3
      A2=2.-(A2+A2)
      B2=2.-(B2+B2)
      getlanrv3=(A1*C1(M1)+A2*C1(M1+1)+A3*C1(M1+2))*B1
     2      +(A1*C1(M2)+A2*C1(M2+1)+A3*C1(M2+2))*B2
     3      +(A1*C1(M3)+A2*C1(M3+1)+A3*C1(M3+2))*B3
      getlanrv3 = getlanrv3 * X
      RETURN
1     FORMAT('*MISTAKE*X=',D23.16,'MX=',I4,'Y=',D23.16,'MY=',I4)
      END
****************************************************************************
* C.13_3
       FUNCTION geteranv3(X,Y)
*
       real*4 X,Y
       common /vrand2_o3/ C1(18419)
       common /vpath23/ NX,NY,X0,SX,Y0,SY
c
      X_1=alog10(X)
      if ((X_1.lt.-4.0001).or.(X_1.gt.1.5001)) then
      print*,'ERROR IN FUNCTION GETERANVS: RANDOM NB. IS OUT OF RANGE'
      endif
c
      Y_1=alog10(Y)
      if ((Y_1.lt..99999).or.(Y_1.gt.9.0001)) then
      print*,'ERROR IN FUNCTION GETERANVS: MUON ENERGY IS OUT OF RANGE'
      endif
c
      A3=(X_1-X0)/SX
      B3=(Y_1-Y0)/SY
      M1=INT(A3+.5)
      M2=INT(B3+.5)
      M3=NX+2
      IF(M1.LT.0.OR.M1.GE.NX.OR.M2.LT.0.OR.M2.GE.NY) THEN
      PRINT 1,X_1,M1,Y_1,M2
      ENDIF
      A3=A3-M1
      B3=B3-M2
      M1=M2*M3+M1+1
      M2=M1+M3
      M3=M2+M3
      A2 = A3*A3 +.25
      B2 = B3*B3 +.25
      A1=A2-A3
      B1=B2-B3
      A3=A2+A3
      B3=B2+B3
      A2=2.-(A2+A2)
      B2=2.-(B2+B2)
      geteranv3=(A1*C1(M1)+A2*C1(M1+1)+A3*C1(M1+2))*B1
     2      +(A1*C1(M2)+A2*C1(M2+1)+A3*C1(M2+2))*B2
     3      +(A1*C1(M3)+A2*C1(M3+1)+A3*C1(M3+2))*B3
      RETURN
1     FORMAT('*MISTAKE*X=',D23.16,'MX=',I4,'Y=',D23.16,'MY=',I4)
      END
****************************************************************************
* C.14_3
      function geteback3(e1,backl)
*
      real*8 fk,fk1,dlnmax,a(0:128),b(0:128),leng(0:128),e0(0:128)
      real*8 e,ene,rest,pat1,path
      real*4 e1,backl
      common /simv13/ fk,fk1,dlnmax,a,b,leng,e0
c
          e = dble(e1)
          path = dble(backl)
          if (e.ge.1.d+9) then
          ene = 1.00001+9
          goto 1402
          endif
        me = idint( ( dlog(e) - dlnmax ) * fk1 )  + 1
        if (me.gt.128) me = 128
            if (me.lt.128) then
            pat1 = leng(me+1) + path
            else
            pat1 = path
            endif
c
            pat1=pat1+dlog((a(me)*e+b(me))/(a(me)*e0(me)+b(me)))/a(me)
c
            m1 = 500
            do m=128,1,-1
              if (leng(m).ge.pat1) then
              m1 = m
              goto 1401
              endif
            enddo
           if (m1.ge.200) then  ! -> ENE for given PATH is more
           ene = 1.00001d+9     !    than 1 EeV (out of reason-
           goto 1402            !     able range) - let it be
           endif                !           just 1 EeV
 1401       continue
            if (m1.lt.128) then
            rest = pat1 - leng(m1+1)
            else
            rest = pat1
            endif
c
          ene = ((a(m1)*e0(m1)+b(m1))*dexp(rest*a(m1))-b(m1))/a(m1)
 1402     continue
          geteback3 = sngl(ene)
      return
      end
c
****************************************************************************
* C.17_3
       function enew3(e,depth,iti,itime)
*
       external getlanrv3,geteranv3,geteback3,gdedelt23,conv3
       external glpairv3,glbremv3,glphnuv3,glelecv3,simps,dsimpS
       real*8 rvec_own,eta,e0,pat,ddepth,e1d,pat1,pat2
       real*8 tlife,treal,tcum,time,time1,dta,deltat
       real*8 dsimps,low3,up3,step3,edur,aux2(0:1000)
       real*8 alfa,rm_e,rm_mu,r_e,avog
       real*8 spli
       real*8 TIME_L_T
       real*8 ttauin,ttauout
       real*4 e,depth
       integer iti,itime
       integer kindlept
       integer MODE
       integer MEDIUM
       integer i_stat(6)
       dimension aux1(0:30)
       dimension ityp(10000),eleng(10000),ener1(10000),ener2(10000)
       COMMON /MATTER3/ MEDIUM
       COMMON /TAU_DECAY3/ TIME_L_T,MODE
       common /const3/ alfa,rm_e,rm_mu,r_e,avog
       common /what_lep3/ kindlept
       common /const_t3/ tlife
       common /vhistory3/ numb,ityp,eleng,ener1,ener2
c       common /r48/ rvec
       common /timetau3/ ttauin,ttauout
       common /statistic/ i_stat
       parameter (itra=1)
c       parameter (len=1)
c                            Light velocity, cm/sec:
       parameter (spli=2.99792458d+10)
c
       i_stat(5) = i_stat(5) + 1
      if (
     +         (i_stat(1).eq.0).AND.
     +         (i_stat(2).eq.0).AND.
     +         (i_stat(3).eq.0).AND.
     +         (i_stat(4).eq.0).AND.
     +         (i_stat(5).eq.1).AND.
     +         (i_stat(6).eq.0)
     +   ) then
            write(*,*) 'Initialization successful, running...'
      endif
      enew3=1.e+20
c
c        Let's check if input is within alowed range;
c
       if (depth.gt.1.0001e+7) then
       print*,'FUNCTION ENEW3: INPUT VALUE FOR DEPTH ',depth,' cm'
       print*,'           IS TOO LARGE, WILL NOT WORK'
       return
       endif
c
       if ((e.gt.1.0001e+9).or.(e.lt..16)) then
       print*,'FUNCTION ENEW3: INPUT VALUE FOR ENERGY ',e,' GeV'
       print*,'          IS OUT OF RANGE, WILL NOT WORK'
       return
       endif
c
       if(kindlept.eq.1) then
c
******************** MUON: ************************************
c
       if(e.le.1.e+1) then !-> muon energy is less than 10 GeV
c -----------------------
       numb = 1         !
       ityp(numb) = 0   !
       eleng(numb) = 0. !-> Tracking simulation history
       ener1(numb) = e  !
       ener2(numb) = e  !
c------------------------
       el = e
       rest = depth
       pat = 0.d+0
       goto 4321
       endif
c -----------------------
       numb = 1         !
       ityp(numb) = 0   !
       eleng(numb) = 0. !-> Tracking simulation history
       ener1(numb) = e  !
       ener2(numb) = e  !
c------------------------
       ddepth = dble(depth)
       e0 = dble(e)
       pat = 0.d+0
    1  call rm48_own(rvec_own)
       eta = -dlog(rvec_own)   !---> Simulation of random number
       if(eta.ge.3.16d+1) eta = 3.16d+1
       slu = sngl(eta)
       e0_sn = sngl(e0)
       if (slu.ge.1.e-4) then
       preal = getlanrv3(slu,e0_sn)  !-> getting the real free path
       e1d = e0 * dble(geteranv3(slu,e0_sn)) !-> getting muon energy
c                                               at the end of free
c                                               path
       else
        preal = 0.  !--> simulated free path is too small, let
        e1d = e0    !    it be equal to zero...
       endif
        e1 = sngl(e1d)
c
       pat = pat + dble(preal)
       rest = sngl(ddepth - pat)
         if (rest.lt.0.) then   !-> muon has passed the DEPTH,
           rest = -rest           !
           if (rest.lt.1.) rest=1.  !  Computing its "back" energy
           if (e1.lt.10.) e1 = 10.   ! at the DEPTH and return...
           enew3 = geteback3(e1,rest)  !
c-------------------------------
           numb = numb + 1     !
           ityp(numb) = 1      !-> Tracking
           eleng(numb) = depth ! simulation
           ener1(numb) = enew3  !  history
           ener2(numb) = enew3  !
c------------------------------
           return
         endif
c
         if (e1.le.1.e+1) then  !-> muon energy at the end of free
           el = 10.             !   path is less than 10 GeV (MUM..
c-----------------------------------                             .
           numb = numb + 1         !-> tracking                .
           ityp(numb) = 3          ! simulation              .
           eleng(numb) = sngl(pat) !  history              .
           ener1(numb) = el        !                    .
           ener2(numb) = el        !                 .
c---------------------------------...................
           goto 4321            ! ..does not compute some "catastrophic"
         endif                  !   losses below 10 GeV, jump to the
c                               !   label 4321 to go the rest of DEPTH
c                               !   with "continuous" losses only...
c
       pb = 1./glbremv3(e1)        !-> Computing of "weight" for different
       pp = pb + 1./glpairv3(e1)   !   interactions at current muon energy.
       pn = pp + 1./glphnuv3(e1)   !
       pt = pn + 1./glelecv3(e1)   !
       ranp = rndm_mum(5) * pt  ! -> Simulation of interaction type
       numb = numb + 1 !-> tracking simulation history
       if(ranp.le.pb) then        !-> type was simulated as bremsstrahlung,
       call getvbrem3(e1,v,itra)
c                         !   simulate rel. energy transfer
       ityp(numb) = 4 !-> tracking simulation history
       else
          if(ranp.le.pp) then      !-> type was simulated as e+e- pair,
          call getvpa3(e1,v,itra)
c                               !   simulate rel. energy transfer
          ityp(numb) = 5 !-> tracking simulation history
          else
              if (ranp.le.pn) then   !-> type was simulated as photonuc.,
              call getvph3(e1,v,itra)
c                                   !   simulate rel. energy transfer
              ityp(numb) = 6 !-> tracking simulation history
              else
              call getvel3(e1,v,itra)
c                                   !-> type was simulated as knock-on
c                                   !  electron, simulate en. transfer
              ityp(numb) = 7 !-> tracking simulation history
              endif
           endif
        endif
        e2 = e1 * ( 1. - v ) ! -> The energy after interaction
c-----------------------------------
           eleng(numb) = sngl(pat) !
           ener1(numb) = e1        !-> tracking simulation history
           ener2(numb) = e2        !
c-----------------------------------
          if (e2.le.10.) then
             if (e2.le..16) then !-> the muon stops (energy is below
                 enew3 = 1.e-2    !   the Cherenkov threshold in water)
c----------------------------------------
                 numb = numb + 1         !
                 ityp(numb) = 2          !-> tracking simulation history
                 eleng(numb) = sngl(pat) !
                 ener1(numb) = enew3      !
                 ener2(numb) = enew3      !
c---------------------------------------
                 return          !   Assigne ENEWS = 0.01 and return...
             else
                 el=e2     !-> muon has not stopped but its energy is
                 goto 4321 !   less than 10 GeV. Jump to label 4321...
             endif
          else
             e0 = dble(e2)  !-> muon enrgy is above 10 GeV. Jump to
             goto 1         !   label 1 to repeat everything once
          endif             !          again...
c
c  Muon energy becomes less than 10 GeV. Compute the rest of its
c          travel with continuous losses only:
c
 4321   lim1 = 30
        elow = alog(1.6e-1)
        up = alog(el)
        step1 = (up - elow) / float(lim1)
         do j1=0,lim1
         en = elow + (float(j1) * step1)
         h1 = exp(en)
         aux1(j1) = h1 * 1.e+3 / gdedelt23(h1)
         enddo
         pat1 = simps(aux1,elow,up,lim1)
         if (pat1.lt.rest) then            ! Muon energy becomes < 0.16
         enew3 = 1.e-2                      ! GeV before it reaches DEPTH
c-----------------------------------------------
         numb = numb + 1                       !
         ityp(numb) = 2                        !-> tracking simulation
         eleng(numb) = sngl(pat + dble(pat1))  !     history
         ener1(numb) = enew3                    !
         ener2(numb) = enew3                    !
c-----------------------------------------------
         return                            ! ENEWS = 0.01 GeV and return...
         endif
c-------------------------------------------
         ic = 0                            ! Iteration procedure to
         ene = (el + 1.59999e-1) * 5.e-1   ! obtain muon energy at
         delta = el - ene                  ! the DEPTH if his start
 3333    elow = alog(ene)                   ! energy is less than
         step1 = (up - elow) / float(lim1)   ! 10 GeV (without "ca-
         do j1=0,lim1                         ! tastrophic" part)
         en = elow + (float(j1) * step1)      !
         h1 = exp(en)                         !
         aux1(j1) = h1 * 1.e+3 / gdedelt23(h1) !
         enddo                                !
         pat1 = simps(aux1,elow,up,lim1)    !
         delta = 5.e-1 * delta            !
         ic = ic + 1                    !
         if (pat1.eq.rest) then       !-> it seems incredible but
         enew3 = ene                   !   sometimes it occures...
c ----------------------------              !
         numb = numb + 1     !                      !
         ityp(numb) = 1      !-> tracking simulation  !
         eleng(numb) = depth !    history            !
         ener1(numb) = enew3  !                   !
         ener2(numb) = enew3  !               !
c ----------------------------          !
         return                        !
         endif                        !
         if (pat1.le.rest) then      !
         ene = ene - delta            !
         else                           !
         ene = ene + delta               !
         endif                            !
         if (ic.eq.14) then                !
         enew3 = ene                         ! -> We found ENEWS
c ----------------------------                  !     and finish...
         numb = numb + 1     !                      !
         ityp(numb) = 1      !-> tracking simulation  !
         eleng(numb) = depth !    history            !
         ener1(numb) = enew3  !                   !
         ener2(numb) = enew3  !               !
c ----------------------------          !
         return                     !
         endif                   !
         goto 3333            !
c----------------------------
       else
******************** TAU: ************************************
c
       if(itime.lt.0) then
c
c Simulation of tau life time (sec):
c
         CALL DECAY_MODE3
         treal = TIME_L_T
       else
         treal = ttauin
       endif
c
c  If working in water equivalent units increase TREAL proportionally
c                           to density:
c
       IF(MEDIUM.EQ.-1)  treal = treal * 1.00000d+0
       IF(MEDIUM.EQ.-2)  treal = treal * 2.65000d+0
       IF(MEDIUM.EQ.-3)  treal = treal * 0.92000d+0
       IF(MEDIUM.EQ.-4)  treal = treal * 1.02700d+0
       IF(MEDIUM.EQ.-5)  treal = treal * 1.03410d+0
       IF(MEDIUM.EQ.-6)  treal = treal * 1.03975d+0
       IF(MEDIUM.EQ.-7)  treal = treal * 2.71000d+0
       IF(MEDIUM.EQ.-8)  treal = treal * 2.90000d+0
       IF(MEDIUM.EQ.-9)  treal = treal * 2.48100d+0
       IF(MEDIUM.EQ.-10) treal = treal * 2.10300d+0
       IF(MEDIUM.EQ.-11) treal = treal * 1.69800d+0
       IF(MEDIUM.EQ.-12) treal = treal * 2.74000d+0
       IF(MEDIUM.EQ.-13) treal = treal * 2.74000d+0
c
       if(iti.eq.1) then
c --------------------------
       numb = 1            !
       ityp(numb) = 0      !
       eleng(numb) = 0.    !-> Tracking simulation history
       ener1(numb) = e     !
       ener2(numb) = e     !
       edelen = 1.e+3 * sngl( treal * (dble(e)/rm_mu) * spli )  !
       numb = 2                   !------------------------------
         if(edelen.gt.depth) then !
           ityp(numb) = 1         !
           eleng(numb) = depth    !
           enewS = e              !
           ener1(numb) = e        !
           ener2(numb) = e        !-----------------------------
           ttauout = treal * dble( (edelen - depth) / edelen ) !
           IF(MEDIUM.EQ.-1)  ttauout = ttauout / 1.00000d+0    !
           IF(MEDIUM.EQ.-2)  ttauout = ttauout / 2.65000d+0    !
           IF(MEDIUM.EQ.-3)  ttauout = ttauout / 0.92000d+0    !
           IF(MEDIUM.EQ.-4)  ttauout = ttauout / 1.02700d+0    !
           IF(MEDIUM.EQ.-5)  ttauout = ttauout / 1.03410d+0    !
           IF(MEDIUM.EQ.-6)  ttauout = ttauout / 1.03975d+0    !
           IF(MEDIUM.EQ.-7)  ttauout = ttauout / 2.71000d+0    !
           IF(MEDIUM.EQ.-8)  ttauout = ttauout / 2.90000d+0    !
           IF(MEDIUM.EQ.-9)  ttauout = ttauout / 2.48100d+0    !
           IF(MEDIUM.EQ.-10) ttauout = ttauout / 2.10300d+0    !
           IF(MEDIUM.EQ.-11) ttauout = ttauout / 1.69800d+0    !
           IF(MEDIUM.EQ.-12) ttauout = ttauout / 2.74000d+0    !
           IF(MEDIUM.EQ.-13) ttauout = ttauout / 2.74000d+0    !
         else                     !-----------------------------
           ityp(numb) = 8         !
           eleng(numb) = edelen   !
           enewS = 1.e-2          !
           ener1(numb) = e        !
           ener2(numb) = 1.e-2    !
           ttauout = -1.d+0       !
         endif
       return              !
       endif               !
c--------------------------
       tcum = 0.0d+0
       if(e.le.1.e+1) then !-> tau energy is less than 10 GeV
c --------------------------
       numb = 1            !
       ityp(numb) = 0      !
       eleng(numb) = 0.    !-> Tracking simulation history
       ener1(numb) = e     !
       ener2(numb) = e     !
       numb = 2            !
       ityp(numb) = 8      !
       eleng(numb) = 0.1   !
       ener1(numb) = e     !
       ener2(numb) = 1.e-2 !
c---------------------------
       enew3= 1.e-2
       ttauout = -1.d+0
       return
       endif
c -----------------------
       numb = 1         !
       ityp(numb) = 0   !
       eleng(numb) = 0. !-> Tracking simulation history
       ener1(numb) = e  !
       ener2(numb) = e  !
c------------------------
       ddepth = dble(depth)
       e0 = dble(e)
       pat = 0.d+0
   11  call rm48_own(rvec_own)
       eta = -dlog(rvec_own)   !---> Simulation of random number
       if(eta.ge.3.16d+1) eta = 3.16d+1
       slu = sngl(eta)
       e0_sn = sngl(e0)
       if (slu.ge.1.e-4) then
       preal = getlanrv3(slu,e0_sn)  !-> getting the real free path
       e1d = e0 * dble(geteranv3(slu,e0_sn)) !-> getting tau energy
c                                               at the end of free
c                                               path
       else
        preal = 0.  !--> simulated free path is too small, let
        e1d = e0    !    it be equal to zero...
       endif
        e1 = sngl(e1d)
c
       pat1 = pat
       pat = pat + dble(preal)
       rest = sngl(ddepth - pat)
         if (rest.lt.0.) then   !-> tau has passed the DEPTH,
           rest = -rest           !
           if (rest.lt.1.) rest=1.  !  Computing its "back" energy
           if (e1.lt.10.) e1 = 10.   ! at the DEPTH and return...
           enew3= geteback3(e1,rest)  !
******************
         low3 = dlog(dble(enew3))
         up3 = dlog(e0)
         qqee = (sngl(up3 - low3))*7.e+0
         lim3 = (int(qqee) + 1) * 2
         step3 = (up3 - low3) / dble(lim3)
         do j=0,lim3
         edur = low3 + (dble(j) * step3)
         h1 = sngl(dexp(edur))
         aux2(j) = rm_mu / (spli * dble(conv3(h1)))
         enddo
         time = dsimps(aux2,low3,up3,lim3)
******************
         tcum = tcum + time
         if(tcum.ge.treal) then
         e1 = enew3
         deltat = treal - tcum + time
         goto 98789               !---> decay before
         endif                    !  reaching DEPTH
c-------------------------------
           numb = numb + 1     !
           ityp(numb) = 1      !-> Tracking
           eleng(numb) = depth ! simulation
           ener1(numb) = enew3 !  history
           ener2(numb) = enew3 !
c------------------------------
           ttauout = treal - tcum
           IF(MEDIUM.EQ.-1)  ttauout = ttauout / 1.00000d+0
           IF(MEDIUM.EQ.-2)  ttauout = ttauout / 2.65000d+0
           IF(MEDIUM.EQ.-3)  ttauout = ttauout / 0.92000d+0
           IF(MEDIUM.EQ.-4)  ttauout = ttauout / 1.02700d+0
           IF(MEDIUM.EQ.-5)  ttauout = ttauout / 1.03410d+0
           IF(MEDIUM.EQ.-6)  ttauout = ttauout / 1.03975d+0
           IF(MEDIUM.EQ.-7)  ttauout = ttauout / 2.71000d+0
           IF(MEDIUM.EQ.-8)  ttauout = ttauout / 2.90000d+0
           IF(MEDIUM.EQ.-9)  ttauout = ttauout / 2.48100d+0
           IF(MEDIUM.EQ.-10) ttauout = ttauout / 2.10300d+0
           IF(MEDIUM.EQ.-11) ttauout = ttauout / 1.69800d+0
           IF(MEDIUM.EQ.-12) ttauout = ttauout / 2.74000d+0
           IF(MEDIUM.EQ.-13) ttauout = ttauout / 2.74000d+0
           return
         endif
c
         if (e1.le.1.e+1) then  !-> tau energy =< 10 GeV
******************
         e1 = 1.e+1
         pat = pat1
         low3 = dlog(dble(e1))
         up3 = dlog(e0)
         qqee = (sngl(up3 - low3))*7.e+0
         lim3 = (int(qqee) + 1) * 2
         step3 = (up3 - low3) / dble(lim3)
         do j=0,lim3
         edur = low3 + (dble(j) * step3)
         h1 = sngl(dexp(edur))
         aux2(j) = 1.d+3 * (dexp(edur) / dble(conv3(h1)))
         enddo
         pat2 = dsimps(aux2,low3,up3,lim3)
******************
         pat = pat + pat2
******************
         low3 = dlog(dble(e1))
         up3 = dlog(e0)
         qqee = (sngl(up3 - low3))*7.e+0
         lim3 = (int(qqee) + 1) * 2
         step3 = (up3 - low3) / dble(lim3)
         do j=0,lim3
         edur = low3 + (dble(j) * step3)
         h1 = sngl(dexp(edur))
         aux2(j) = rm_mu / (spli * dble(conv3(h1)))
         enddo
         time = dsimps(aux2,low3,up3,lim3)
******************
         tcum = tcum + time
         if(tcum.ge.treal) then
         deltat = treal - tcum + time
         goto 98789           !---> decay before
         endif                !     reaching depth
c-----------------------------------                             .
           numb = numb + 1         !-> tracking                .
           ityp(numb) = 8          ! simulation              .
           eleng(numb) = sngl(pat) !  history              .
           ener1(numb) = e1        !                    .
           ener2(numb) = 1.e-2     !                 .
c-----------------------------------...................
           enew3= 1.e-2
           ttauout = -1.d+0
           return
         endif
******************
         low3 = dlog(dble(e1))
         up3 = dlog(e0)
         qqee = (sngl(up3 - low3))*7.e+0
         lim3 = (int(qqee) + 1) * 2
         step3 = (up3 - low3) / dble(lim3)
         do j=0,lim3
         edur = low3 + (dble(j) * step3)
         h1 = sngl(dexp(edur))
         aux2(j) = rm_mu / (spli * dble(conv3(h1)))
         enddo
         time = dsimps(aux2,low3,up3,lim3)
******************
         tcum = tcum + time
         if(tcum.ge.treal) then
         deltat = treal - tcum + time
         goto 98789 !---> decay before
         endif
c
       pb = 1./glbremv3(e1)        !-> Computing of "weight" for different
       pp = pb + 1./glpairv3(e1)   !   interactions at current tau energy.
       pn = pp + 1./glphnuv3(e1)   !
       pt = pn + 1./glelecv3(e1)   !
       ranp = rndm_mum(5) * pt  ! -> Simulation of interaction type
       numb = numb + 1 !-> tracking simulation history
       if(ranp.le.pb) then     !-> type was simulated as bremsstrahlung,
       call getvbrem3(e1,v,itra)
c                              !   simulate rel. energy transfer
       ityp(numb) = 4 !-> tracking simulation history
       else
          if(ranp.le.pp) then   !-> type was simulated as e+e- pair,
          call getvpa3(e1,v,itra)
c                               !   simulate rel. energy transfer
          ityp(numb) = 5 !-> tracking simulation history
          else
              if (ranp.le.pn) then !-> type was simulated as photonuc.,
              call getvph3(e1,v,itra)
c                                  !   simulate rel. energy transfer
              ityp(numb) = 6 !-> tracking simulation history
              else
              call getvel3(e1,v,itra)
c                                    !-> type was simulated as knock-on
c                                    !  electron, simulate en. transfer
              ityp(numb) = 7 !-> tracking simulation history
              endif
           endif
        endif
        e2 = e1 * ( 1. - v ) ! -> The energy after interaction
c-----------------------------------
           eleng(numb) = sngl(pat) !
           ener1(numb) = e1        !-> tracking simulation history
           ener2(numb) = e2        !
c-----------------------------------
          if (e2.le.10.) then
c----------------------------------------------
                 numb = numb + 1               !
                 ityp(numb) = 8                !-> tracking simulation history
                 eleng(numb) = sngl(pat+1.d+0) !
                 ener1(numb) = e2              !
                 ener2(numb) = 1.e-2           !
c----------------------------------------------
                 enew3= 1.e-2
                 ttauout = -1.d+0
                 return
          else
             e0 = dble(e2)  !-> tau energy is above 10 GeV. Jump to
             goto 11        !   label 11 to repeat everything once
          endif             !          again...
c
98789    continue
         if(e1.le.1.e+1) e1=1.e+1
         iiik = 1
         dta = dlog(dble(e0/e1))
******************
         low3 = dlog(dble(e1))
13333    continue
         iiik = iiik + 1
         dta = dta * .5d+0
         up3 = dlog(e0)
         qqee = (sngl(up3 - low3))*7.e+0
         lim3 = (int(qqee) + 1) * 2
         step3 = (up3 - low3) / dble(lim3)
         do j=0,lim3
         edur = low3 + (dble(j) * step3)
         h1 = sngl(dexp(edur))
         aux2(j) = rm_mu / (spli * dble(conv3(h1)))
         enddo
         time1 = dsimps(aux2,low3,up3,lim3)
******************
         if(time1.ge.deltat) then
           low3 = low3 + dta
         else
           low3 = low3 - dta
         endif
         if(iiik.le.27) goto 13333
         e1 = sngl(dexp(low3))
******************
         pat = pat1
         low3 = dlog(dble(e1))
         up3 = dlog(e0)
         qqee = (sngl(up3 - low3))*7.e+0
         lim3 = (int(qqee) + 1) * 2
         step3 = (up3 - low3) / dble(lim3)
         do j=0,lim3
         edur = low3 + (dble(j) * step3)
         h1 = sngl(dexp(edur))
         aux2(j) = 1.d+3 * (dexp(edur) / dble(conv3(h1)))
         enddo
         pat2 = dsimps(aux2,low3,up3,lim3)
******************
         pat = pat + pat2
c-----------------------------------------
                 numb = numb + 1         !
                 ityp(numb) = 8          !-> tracking simulation
                 eleng(numb) = sngl(pat) !     history
                 ener1(numb) = e1        !
                 ener2(numb) = 1.e-2     !
c-----------------------------------------
          enew3= 1.e-2
          ttauout = -1.d+0
          return
         endif
      return
      end
****************************************************************************
* C.18_3
      subroutine simulde3(ndepths,emu0)
*
       external enew3,simps,gdedelt23,geteback3
       dimension ityp(10000),eleng(10000),ener1(10000),ener2(10000)
       dimension aux1(0:30)
       real*4 emu0
       integer ndepths
       integer kindlept
       common /vhistory3/ numb,ityp,eleng,ener1,ener2
       common /frouser13/ horison(1000)
       common /touser13/ emuon(1000)
       common /what_lep3/ kindlept
c
       iti = 0
       itime = -1
       emuon(ndepths) = enew3(emu0,horison(ndepths),iti,itime)
       numfirst = 2
       do i=1,ndepths-1 !--> cicle along levels of observation
c---------------------------------------------
         if (eleng(numb).lt.horison(i)) then !-> muon has died before
           emuon(i) = 1.e-2                  !   given level of
           goto 1                            !    observation...
         else                                !
c---------------------------------------------
           do j=numfirst,numb  !-> cicle along muon history
c----------------------------------------------
             if (eleng(j).ge.horison(i)) then !-> we found the first event
             numfirst = j                   ! in muon history (starting with
c                                         ! less depth) whose depth is more
c                                       ! than given level of observation
c----------------------------------------
              if((ityp(j).ge.3).and.(ityp(j).lt.8)) then !-> the nearest
                     diffl = eleng(j) - horison(i)       ! event is either
                        if (diffl.le.1.) then            ! brem, pn, e+e-,
                        emuon(i) = ener1(j)              ! knock-on e in-
                        goto 1                           ! teraction or
                        endif                            ! 10 GeV level
                     emuon(i) = geteback3(ener1(j),diffl)!
                     goto 1                              !
                  else                                   !
c
                     if (ityp(j).eq.1) then                     !-> muon
                         if (ener1(j).ge.10.) then              ! has reached
                           diffl = eleng(j) - horison(i)        ! the maximum
                             if (diffl.le.1.) then              ! depth and
                             emuon(i) = ener1(j)                ! E_mu > 10 GeV
                             goto 1                             !
                             endif                              !
                           emuon(i) = geteback3(ener1(j),diffl) !
                           goto 1                               !
                         else
                           goto 2  !-> the nearest event is either maximum
                         endif     !    depth with E_mu < 10 GeV or death
                     else          !    of muon (E_mu < 0.16 GeV)
                         goto 2    !
                     endif         !
                  endif            !
             else
             goto 3 !-> continue to search for the first event in muon history
             endif
c
 2           continue
c
             if(kindlept.ne.1) then !---------> TAU-lepton
             diffl = eleng(j) - horison(i)
             ecucuc = ener1(j)
             if(ener1(j).le.1.e+1) ecucuc = 1.0001e+1
             emuon(i) = geteback3(ecucuc,diffl)
             goto 1
             endif
c
             lim1 = 30  !-------------------------!
             rest = eleng(j) - horison(i)         !
                if (rest.le.1.) then              !
                emuon(i) = ener1(j)               !
                goto 1                            !
                endif                             !
             ic = 0                               ! Iteration procedure to
             efin = ener1(j)                      ! obtain muon energy
             if (efin.le..15) efin = .16         !  at the level of observation
             ene = (efin + ener2(j-1)) * 5.e-1  !  if its energy at the nearest
             delta = ene - efin                !    event after level of obser-
             elow = alog(efin)                  !   vation is less than 10 GeV
 3333        up = alog(ene)                      !
             step1 = (up - elow) / float(lim1)    !
               do j1=0,lim1                       !
                 en = elow + (float(j1) * step1)   !
                 h1 = exp(en)                        !
                 aux1(j1) = h1 * 1.e+3 / gdedelt23(h1) !
               enddo                               !
             pat1 = simps(aux1,elow,up,lim1)   !
             delta = 5.e-1 * delta         !
             ic = ic + 1                !
               if (pat1.eq.rest) then !-> It seems incredible but sometimes
               emuon(i) = ene         !      it occures ...
               goto 1                 !
               endif                  !_________
               if (pat1.le.rest) then           !
                 ene = ene + delta             !
               else                           !
                 ene = ene - delta           !
               endif                        !
               if (ic.eq.14) then          !
                 emuon(i) = ene           ! -> We found EMUON(I)
                 goto 1                  !
               endif                    !
             goto 3333                 !
    3      continue  !----------------!
           enddo
         endif
    1  continue
       enddo
      return
      end
****************************************************************************
c C.28_3
c
      SUBROUTINE PREPARE_DECAY3
c
c   Cooking array TIMP(22) with partial life times of tau-lepton for 22
c                    the most important decay modes
c
      DOUBLE PRECISION TLIFE,XX
      DIMENSION TIMP(22)
      DIMENSION DMOD(22)
      COMMON /PARTI3/ TIMP
      COMMON /CONST_T3/ TLIFE
c
      DO I=1,22
      DMOD(I) = 1.00000
      ENDDO
c
      DO I = 1,22
c                            BR. RATIO         DECAY MODE            NUMBER
c                         (norm to e mode)         |       (in TAUOLA style)
c                                |                 |                     |
c                                V                 V                     V
        IF(I.EQ. 1) DMOD(I) = 1.00000 ! TAU-+  -->  E-+                  1
        IF(I.EQ. 2) DMOD(I) = 0.97980 ! TAU-+  -->  MU-+                 2
        IF(I.EQ. 3) DMOD(I) = 0.64960 ! TAU-+  -->  PI-+                 3
        IF(I.EQ. 4) DMOD(I) = 1.3405  ! TAU-+  -->  PI-+    PI0          4
        IF(I.EQ. 5) DMOD(I) = 0.7215  ! TAU-+  -->  A1-+ (two subch)     5
        IF(I.EQ. 6) DMOD(I) = 0.0397  ! TAU-+  -->  K-+                  6
        IF(I.EQ. 7) DMOD(I) = 0.0696  ! TAU-+  -->  K*-+ (two subch)     7
        IF(I.EQ. 8) DMOD(I) = 0.0835  ! TAU-+  -->  2PI-+   PI0    PI+-  8
        IF(I.EQ. 9) DMOD(I) = 0.0170  ! TAU-+  -->  3PI0    PI-+         9
        IF(I.EQ.10) DMOD(I) = 0.0641  ! TAU-+  -->  2PI-+   PI+-   2PI0  10
        IF(I.EQ.11) DMOD(I) = 0.0286  ! TAU-+  -->  3PI-+   2PI+-        11
        IF(I.EQ.12) DMOD(I) = 0.0043  ! TAU-+  -->  3PI-+   2PI+-  PI0   12
        IF(I.EQ.13) DMOD(I) = 0.0042  ! TAU-+  -->  2PI-+   PI+-   3PI0  13
        IF(I.EQ.14) DMOD(I) = 0.0061  ! TAU-+  -->  K-+     PI-+   K+-   14
        IF(I.EQ.15) DMOD(I) = 0.0056  ! TAU-+  -->  K0      PI-+   K0B   15
        IF(I.EQ.16) DMOD(I) = 0.0005  ! TAU-+  -->  K-+     K0     PI0   16
        IF(I.EQ.17) DMOD(I) = 0.0059  ! TAU-+  -->  PI0     PI0    K-+   17
        IF(I.EQ.18) DMOD(I) = 0.0321  ! TAU-+  -->  K-+     PI-+   PI+-  18
        IF(I.EQ.19) DMOD(I) = 0.0320  ! TAU-+  -->  PI-+    K0B    PI0   19
        IF(I.EQ.20) DMOD(I) = 0.0110  ! TAU-+  -->  ETA     PI-+   PI0   20
        IF(I.EQ.21) DMOD(I) = 0.0031  ! TAU-+  -->  PI-+    PI0    GAM   21
        IF(I.EQ.22) DMOD(I) = 0.0181  ! TAU-+  -->  K-+     K0           22
      ENDDO
c
      XX = 0.d+0
        DO I=1,22
          XX = XX + DBLE(DMOD(I))
        ENDDO
        DO I=1,22
          TIMP(I) = ( SNGL(XX) / DMOD(I) ) * SNGL(TLIFE)
        ENDDO
c
       RETURN
       END
****************************************************************************
c C.29_3
c
      SUBROUTINE DECAY_MODE3
c
c Generation of tau-lepton life time (DOUBLE PRECISION TIME_L_T) and decay
c        mode (INTEGER MODE) to be passed to ENEW(S,3,4) routines.
      DOUBLE PRECISION RVEC_OWN,TREAL1, TREAL,TIME_L_T
      INTEGER MODE
      DIMENSION TIMP(22)
      COMMON /PARTI3/ TIMP
      COMMON /TAU_DECAY3/ TIME_L_T,MODE
c
      TREAL = 1.D+1
        DO J=1,22
          CALL rm48_own(rvec_own)
          TREAL1 = (-DLOG(RVEC_OWN)) * DBLE(TIMP(J))
            IF(TREAL1.LE.TREAL) THEN
              TREAL = TREAL1
              MODE = J
            ENDIF
        ENDDO
        TIME_L_T = TREAL
c
      RETURN
      END
****************************************************************************
************************ BREMSSTRAHLUNG SUBROUTINES : **********************
****************************************************************************
* B.1_3
*
       real*8 function brem3(z,en,rnu)
       external fu13,fu23
       real*8 fu13,fu23
       real*8 z,en,rnu,rnu1
       real*8 alfa,rm_e,rm_mu,r_e,fact,a1,a2,del1,del2,x1,x2,ulim,avog
       real*8 eln1,eln2,psi10,psi20,psi1,psi2,z13,z23,qc,dze,q_min,h1
       common /exer13/ fa
       common /const3/ alfa,rm_e,rm_mu,r_e,avog
c
      fact=((4.d+0*z*z*r_e*r_e*rm_e*rm_e)/(rm_mu*rm_mu))*alfa
      rnu1=1.d+0-rnu
      z13=z**(1.d+1/3.d+1)
      z23=z13*z13
ccc      qc=(1.9d+0*rm_mu)/z13
      qc=(1.9d+0*1.0565932d+2)/z13
      dze=sqrt(1.d+0+((4.d+0*rm_mu*rm_mu)/(qc*qc)))
      a1 = 1.117d+2/(z13*rm_e)
      a2 = 7.242d+2/(z23*rm_e)
      del1=dlog(rm_mu/qc)+((dze/2.d+0)*dlog((dze+1.d+0)/(dze-1.d+0)))
      del2=dlog(rm_mu/qc)+((2.d+0*rm_mu*rm_mu)/(qc*qc))
      del2 = del2+((dze/4.d+0)*(3.d+0-(dze*dze))*dlog((dze+1.d+0)/(dze-1
     *.d+0)))
      if (z.le.1.5d+0) then !
      del1=0.d+0            !-> there is no corrections due to nuclear
      del2=0.d+0            !   form-factor for hydrogen
      endif                 !
      q_min=((rnu/rnu1)*rm_mu*rm_mu*5.d-1)/(en*1.d+3)
      x1 = a1 * q_min
      x2 = a2 * q_min
c
        ulim=((z)**(1.d+0/3.d+0))*1.236540953d+0*(rm_mu/(en*1.d+3))
        ulim = 1.d+0 - ulim
c
        if (ulim.lt.rnu) then   !  if input energy transfer is greater than
        k1=0                    !  upper limit the diff. cross-section = 0.
        else                    !  Else it is calculated by fornmulae for
        k1=1                    !  bremstrahlung.
        endif                   !
        h1=dble(k1)             !
c
        eln1=dlog((rm_mu*rm_mu*a1*a1)/(1.d+0+x1*x1))
        eln2=dlog((rm_mu*rm_mu*a2*a2)/(1.d+0+x2*x2))
        psi10 = 5.d-1 * (1.+eln1) - fu23(x1)
        psi10 = psi10 + (1.d+0/z)*(5.d-1*(1.d+0+eln2) - fu23(x2))
        psi20=(1.d+1/3.d+1) + 5.d-1*eln1 + fu13(x1)
        psi20=psi20+(1.d+0/z)*((1.d+0/3.d+0)+5.d-1*eln2+fu13(x2))
        psi1=psi10-del1
        psi2=psi20-del2
        brem3=(fact/rnu)*
     &        ((rnu1*rnu1+1.d+0)*psi1-(2.d+0/3.d+0)*rnu1*psi2)
        brem3 = brem3 * h1 * dble(fa)
        return
        end
****************************************************************************
* B.2_3
*
       real*8 function fu13(c)
       external fu23
       real*8 c,fu23
      if (c.gt.1.d+3) then
        fu13 = -0.8333333333333d+0
      else
        if (c.lt.1.d-5) then
         ik=0
         fu13=dble(ik)
        else
         fu13=2.d+0*c*c*
     &        (1.d+0-fu23(c)+(7.5d-1)*dlog((c*c)/(1.d+0+(c*c))))
        endif
      endif
      return
      end
****************************************************************************
* B.3_3
*
       real*8 function fu23(d)
       real*8 d
       if (d.gt.5.d+4) then
          ik = 1
          fu23 = dble(ik)
       else
           if (d.lt.1.d-8) then
             fu23 = d * 3.14159265359d+0 * 5.d-1
           else
             fu23 = d * datan(1.d+0/d)
           endif
       endif
       return
       end
**************************************************************************
* B.1a_3
*
        function CRB_G43 (Z,A,Tkin,EP)
c       GeV:
        parameter       (ame=0.51099907e-3)
c        parameter       (amu=0.105658389)       !!!     GeV
c       cm:
        parameter       (re=2.81794092e-13)
        parameter       (avno=6.022137e23)
cccc        parameter       (alpha=1./137.036)
c        parameter       (rmass=amu/ame)         !!!     "207"
c        parameter       (coeff=16./3.*alpha*avno*(re/rmass)**2) !!! cm^2
c       sqrt(2.71828...):
        parameter       (sqrte=1.64872127)
        parameter       (btf=183.)
        parameter       (btf1=1429.)
        parameter       (bh=202.4)
        parameter       (bh1=446.)
        real*8 alfa,rm_e,rm_mu,r_e,avog
        real*4 Z,A,Tkin,EP
        common /const3/ alfa,rm_e,rm_mu,r_e,avog
        common /exer13/ fa
c
        alpha = 1./137.036
        amu = sngl(rm_mu) * 1.e-3
        rmass = amu/ame
        coeff=16./3.*alpha*avno*(re/rmass)**2
C
        if (ep.ge.tkin) then
                crb_g43=0.
                return
                end if
        e=tkin+amu
        v=ep/e
        delta=amu*amu*v/(2.*(e-ep))             !!!     qmin
        rab0=delta*sqrte
        z_13=z**(-0.3333333)
C
        dn=1.54*A**0.27
        if (z.le.1.5) then      !!!     special case for hydrogen
                b=bh
                b1=bh1
                dn_star=dn
        else
                b=btf
                b1=btf1
                dn_star=dn**(1.-1./Z)   !!! with Bugaev's correction
        end if
C***            nucleus contribution logarithm
        rab1=b*z_13
        fn=alog(rab1/(dn_star*(ame+rab0*rab1))*(amu+delta*
     *          (dn_star*sqrte-2.)))
        if (fn.lt.0.) fn=0.
C***            electron contribution logarithm
        epmax1=e/(1.+amu*rmass/(2.*e))
        if (ep.ge.epmax1) then
                fe=0.
                go to 10
                end if
        rab2=b1*z_13*z_13
        fe=alog(rab2*amu/((1.+delta*rmass/(ame*sqrte))*
     *                  (ame+rab0*rab2)))
        if (fe.lt.0.) fe=0.
C***
10      continue
        crb_g43=fa*coeff*e*(1.-v*(1.-0.75*v))*Z*(Z*fn+fe)/(ep*avno)
        return
        end
************************************************************************
* B.1b_3
*     THIS REAL*8 FUNCTION CALCULATES DIFFERENTIAL CROS-SECTION FOR MUON
*         BREMSSTRAHLUNG ACCORDING TO FORMULAE TAKEN FROM A.SANDROCK
*                                  PhD Thesis:
*       M.Sc.A.Sandrock, "Higher-order corrections to the energy loss
*     cross sections of high-energy muons", Dissertation zur Erlangung
*                   des akademischen Grades eines (PhD Thesis)
*                     Technische Universitaet Dortmund, 2018
*  (https://eldorado.tu-dortmund.de/bitstream/2003/37815/1/Sandrock.pdf)
*
*                                INPUT:
*                                =====
*
* real*8 z     : electric charge of nucleus
* real*8 a     : atomic weight of nucleus
* real*8 en    : muon energy (GeV)
* real*8 rnu   : relative energy transfer = (E_transfered / E_mu)
*
*                                OUTPUT:
*                                ======
*
* real*8 brem_sandr3 : d_sigma/d_v (sq. cm) for nucleus with given Z, A,
*                      muon energy EN and relative energy transfer RNU
*  .....................................................................
      real*8 function brem_sandr3(z,a,en,rnu)
c  .....................................................................
c
c                                                          DECLARATIONS:
c
c Routine to compute radiation logarithm B:
      external rad_log_HF
      real*8 rad_log_HF
c Declaration for input variables:
      real*8 z,a,en,rnu
c Declaration for constants which are prepared by MED_CONS routine and
c passed here via COMMON /const/ (electron and muon masses in MeV!!!):
      real*8 alfa,rm_e,rm_mu,r_e,avog
      common /const3/ alfa,rm_e,rm_mu,r_e,avog
c M_mu and M_e in GeV:
      real*8 rm_mu_gev,rm_e_gev
c E number:
      real*8, parameter:: e = 2.7182818284590452354d+0
c M_mu (GeV) to compute q_c parameter for tau-lepton:
      real*8, parameter:: mu_m = 1.0565932d+2  !--> muon mass (MeV)
c Inelastic radiation logarithm B':
c                                           for all the nuclei with Z>1:
      real*8, parameter::       b1_all=1429.d+0
c                                                          for hydrogen:
      real*8, parameter::       b1_h=446.d+0
c Radiation logarithm and inelastic radiation logarithm (the last to be
c substituted by one of the values above:
      real*8 b,b1
c Parameters of the parametrization for the radiative corrections to the
c bremsstrahlung cross section (Table B.1 in Sandrock's Thesis):
      real*8, dimension(3), parameter:: ai = (/
     #                                             -0.00349,
     #                                            148.84,
     #                                           -987.531
     #                                                       /)
      real*8, dimension(4), parameter:: bi = (/
     #                                              0.1642,
     #                                            132.573,
     #                                           -585.361,
     #                                           1407.77
     #                                                       /)
      real*8, dimension(6), parameter:: ci = (/
     #                                             -2.8922,
     #                                            -19.0156,
     #                                             57.698,
     #                                            -63.418,
     #                                             14.1166,
     #                                              1.84206
     #                                                       /)
      real*8, dimension(6), parameter:: di = (/
     #                                           2134.19,
     #                                            581.823,
     #                                          -2708.85,
     #                                           4767.05,
     #                                              1.52918,
     #                                              0.361933
     #                                                       /)
c Different terms in formula for dif. cross-section:
      real*8 Delta1, Delta2, delta,rho,q_c,Dn,F1,F2
c Radiative corrections made by Sandrock:
      real*8 s_at, s_rad
c Auxiliary variables:
      real*8 help1, help2, ulim, fact
c Some factor to play with cross-sections (FOR EXPERTS ONLY!!!):
      real*4 fa
      common /exer13/ fa
c Loop variable:
      integer i
************************************************************************
c
c                                                          CALCULATIONS:
c
c
c Choosing values for radiation logarithm B and inelastic radiation
c                                     logarithm B' depending on Z value:

      b = rad_log_HF(z)
      if (z.gt.1.5d+0) then
         b1 = b1_all
      else
         b1 = b1_h
      endif
c
c                                 Computing terms of Sandrock's formula:
c
c Computing delta (in GeV!):
      rm_mu_gev = rm_mu / 1.d+3
      delta =
     &      (rm_mu_gev * rm_mu_gev * rnu) / (2.d+0 * en * (1.d+0 - rnu))
c Computing Dn (nuclear formfactor parametrization):
      Dn = 1.54d+0 * (a**0.27d+0)
c Computing q_c (in MeV!):
      q_c = (mu_m * e) / Dn
c Computing rho:
      rho = DSQRT(1.d+0 + ((4.d+0*rm_mu*rm_mu) / (q_c*q_c)))
c Computing Delta1:
      Delta1 = DLOG(rm_mu/q_c)
      Delta1 = Delta1 + (rho/2.d+0) * DLOG((rho+1.d+0)/(rho-1.d+0))
c Computing Delta2:
      Delta2 = DLOG(rm_mu/q_c)
      Delta2 = Delta2 + ( (2.d+0 * rm_mu * rm_mu) / (q_c * q_c) )
      Delta2 = Delta2 +
     &( (3.d+0*rho-rho**3.d+0) / 4.d+0) * DLOG((rho+1.d+0)/(rho-1.d+0))
c Computing F1 and F2:
      help1 = b * (z**(-1.d+0 / 3.d+0))
      help2 = help1 * (rm_mu / rm_e)
      rm_e_gev = rm_e / 1.d+3
      F1 = DLOG(help2 / (1.d+0 + (help1 * DSQRT(e) * (delta/rm_e_gev))))
      F1 = F1 - Delta1 * (1.d+0 - (1.d+0/z))
      F2 = help2 * e**(-1.d+0/6.d+0)
      F2 = DLOG(F2 /(1.d+0 + help1*(e**(1.d+0/3.d+0))*(delta/rm_e_gev)))
      F2 = F2 - Delta2  * (1.d+0 - (1.d+0/z))
c Computing s_at:
      help1 = DLOG(
     &(rm_mu_gev / delta)
     &                    /
     &  (((rm_mu_gev*delta) / (rm_e_gev*rm_e_gev)) + DSQRT(e))
     &                                                          )
      help2 = rm_e_gev / (delta * b1 * z**(-2.d+0/3.d+0) * DSQRT(e))
      help2 = DLOG(1.d+0 + help2)
      s_at = ((4.d+0/3.d+0) * (1.d+0 - rnu)) + (rnu * rnu)
      s_at = s_at * (help1 - help2)
c Computing s_rad:
      s_rad = 0.d+0
      if (rnu.lt.0.02d+0) then
         do i=1,3
            s_rad = s_rad + (ai(i) * rnu**(dble(i-1)))
         enddo
         goto 11111
      endif
c
      if ((rnu.ge.0.02d+0).AND.(rnu.lt.0.1d+0)) then
         do i=1,4
            s_rad = s_rad + (bi(i) * rnu**(dble(i-1)))
         enddo
         goto 11111
      endif
c
      if ((rnu.ge.0.1d+0).AND.(rnu.lt.0.9d+0)) then
         do i=1,3
            s_rad = s_rad + (ci(i) * rnu**(dble(i-1)))
         enddo
         s_rad = s_rad + (ci(4) * rnu * DLOG(rnu))
         s_rad = s_rad + (ci(5) * DLOG(1.d+0-rnu))
         s_rad = s_rad + (ci(6) * DLOG(1.d+0-rnu) * DLOG(1.d+0-rnu))
         goto 11111
      endif
c
      do i=1,3
         s_rad = s_rad + (di(i) * rnu**(dble(i-1)))
      enddo
      s_rad = s_rad + (di(4) * rnu * DLOG(rnu))
      s_rad = s_rad + (di(5) * DLOG(1.d+0-rnu))
      s_rad = s_rad + (di(6) * DLOG(1.d+0-rnu) * DLOG(1.d+0-rnu))
c
11111 continue
c
c      Computing dif. cross-section d_sigma / d_v by Sandrock's formula:
c
      brem_sandr3 = F1 * (2.d+0 - 2.d+0*rnu + rnu*rnu)
      brem_sandr3 = brem_sandr3 - (F2 * (2.d+0/3.d+0) * (1.d+0 - rnu))
      brem_sandr3 = brem_sandr3 + (s_at / z)
      brem_sandr3 = brem_sandr3 + ((alfa/4.d+0) * F1 * s_rad)
      brem_sandr3 = brem_sandr3 / rnu
      brem_sandr3 = brem_sandr3 * 4.d+0 * alfa * z * z
      brem_sandr3 = brem_sandr3 * ((rm_e/rm_mu)*r_e)*((rm_e/rm_mu)*r_e)
c
c ULIM is the upper limit for energy transfer via bremsstrahlung for
c nucleus with given electric charge Z, atomic weight A, muon energy EN
c and  relative transfer RNU. If input energy transfer RNU is greater
c than ULIM cross-section value is set to ZERO;
c
      ulim=(z**(1.d+0/3.d+0)) * (rm_mu / (en * 1.d+3))
      ulim = ulim * DSQRT(e) * (3.d+0 / 4.d+0)
      ulim = 1.d+0 - ulim
      if (ulim.lt.rnu) then
         fact = 0.d+0
      else
         fact = 1.d+0
      endif
c
c                                                            Final step:
c
      brem_sandr3 = brem_sandr3 * fact * dble(fa)
c
      return
      end
**************************************************************************
* B.4_3
*
       function brem_tot3(ene,v)
       external brem3,crb_g43,brem_sandr3
       real*8 brem_sandr3,brem3
       real*8 z1(10),w(10),aw(10),a_ef,en,rnu,h1,ro
       real*8 alfa,rm_e,rm_mu,r_e,avog
       real*4 ene,v
       integer nsub
       common /const3/ alfa,rm_e,rm_mu,r_e,avog
       common /bremind3/ ibrem
       common /media3/ z1,w,aw,a_ef,ro,nsub
c
c       Tkin = ene - 0.105658389 ! For crb_g43
       Tkin = ene - (1.e-3 * sngl(rm_mu))
       if (v.gt..999995) v = .999995
       ep = v * ene ! For crb_g43
       en = dble(ene)
       rnu = dble(v)
c
      if (ibrem.eq.1) then
         h1 = w(1) * brem3(z1(1),en,rnu)
      endif
      if (ibrem.eq.2) then
         h1 = w(1) * brem_sandr3(z1(1),aw(1),en,rnu)
      endif
      if ((ibrem.ne.1).AND.(ibrem.ne.2)) then
         h1 = w(1) * dble(crb_g43(sngl(z1(1)),sngl(aw(1)),Tkin,ep))
      endif
c
      if (nsub.ge.2) then
         do l=2,nsub
            if (ibrem.eq.1) then
               h1 = h1 + (w(l) * brem3(z1(l),en,rnu))
            endif
            if (ibrem.eq.2) then
               h1 = h1 + (w(l) * brem_sandr3(z1(l),aw(l),en,rnu))
            endif
            if ((ibrem.ne.1).AND.(ibrem.ne.2)) then
               h1=h1+w(l)*dble(crb_g43(sngl(z1(l)),sngl(aw(l)),Tkin,ep))
            endif
         enddo
      endif
      brem_tot3 = sngl(h1)
      return
      end
****************************************************************************
* B.5_3
       subroutine gamma13
*
       external brem_tot3,dsimps
       real*8 dsimps
       real*8 um,ene,u(10)
       real*8 aux1(0:2000),aux2(0:2000),h1,h2
       real*8 alfa,rm_e,rm_mu,r_e,avog,z1(10),w(10),aw(10),a_ef,ro
       common /const3/ alfa,rm_e,rm_mu,r_e,avog ! from initial subroutine
       common /media3/ z1,w,aw,a_ef,ro,nsub     !       MED_CONSS
       common /general3/ emin,vmin,emph         !
       common /cdbr_in3/ fcd1(81,54),fcd2(81,101),fcd3(81,51)
       common /ctbr_in13/ crt_br1(17),crt_br2(17)
       common /elbr_in13/ elo_br1(17),elo_br2(17)
       common /elbr_in23/ elo_br3(17)
       common /elbr_in43/ elo_br4(17)
       common /br_ref3/ cf
       common /help_13/ aux1,aux2
       common /bremind3/ ibrem
c   ....................................................................
c      1.PREPARATION OF ARRAYS WITH DIFF. CROSS-SEECTIONS FOR MUON
c                               BREMSSTRAHLUNG:
c
c                !       ..........................
      do j=1,81  !--->   j CYCLE BY ENERGIES starts
c                !       ..........................
        en = float(j)
        en = 1.e+1**(9.e-1 + (1.e-1 * en))
c                     !         ..................................
      do k=1,206      !--->     k CYCLE BY ENERGY TRANSFERS starts
c                     !         ..................................
      if (k.eq.206) then
        kk = 0
        fcd2(j,k-105) = float(kk)
        goto 975
      endif
c
      if (k.le.54) then
         k01 = k - 1
         rnu = 1.e+1**(float(k01) * 2.e-1 - 1.1e+1)
      else
         if (k.le.105) then
           k01 = k - 55
           rnu = 1.e+1**(float(k01) * 1.e-2 - 6.e-1)
         else
           k01 = k - 106
           rnu = 1.e+1**(float(k01) * 1.e-3 - 1.e-1)
         endif
      endif
c
      cr_dif=brem_tot3(en,rnu)
      if (k.le.54) fcd1(j,k) = cr_dif
      if ((k.gt.54).AND.(k.lt.106)) fcd3(j,k-54) = cr_dif
      if (k.ge.106) fcd2(j,k-105) = cr_dif
c
 975  continue
c              !     .....................................
      enddo    !----> k CYCLE BY ENERGY TRANSFERS finishes
c              !     .....................................
      enddo    !----> j CYCLE BY ENERGIES finishes
c              !     ....................................
c   ....................................................................
c    2.PREPARATION OF ARRAYS WITH ENERGY LOSSES AND TOTAL CROSS-SECTIONS
c                         FOR MUON BREMSSTRAHLUNG:
c
c                    a) Energy transfers > EMIN :
      lim = 2000
      do i=1,17
      en = float(i)
      en = (1.e+1)**(5.e-1 + (5.e-1 * en))
      vmi = alog(emin / en) !------------> The lower limit for integration
c
        um = 0.d+0
        do k=1,nsub
        ene=dble(en)
        u(k)=((z1(k))**(1.d+0/3.d+0))*1.236540953d+0*(rm_mu/(ene*1.d+3))
        u(k) = 1.d+0 - u(k)
        um = dmax1(u(k),um)
        enddo
        vma=sngl(um)  !----------------> The upper limit for integration
        vma=alog(vma) !
        vst = (vma - vmi) / float(lim) !-> step for a rel. en. transfers grid
c
      do j=0,lim
      rnu = vmi + vst*(float(j))
      rnu = exp(rnu)
      aux1(j) = dble(brem_tot3(en,rnu) * rnu)       !-> array to be integrated
c                                                  !   to get mean free path
      aux2(j) = aux1(j) * dble(rnu)                !-> array to be integrated
      enddo                                        !   for getting en. losses
c
      h1 = dble(vmi)
      h2 = dble(vma)
      crt_br1(i) = sngl(dsimps(aux1,h1,h2,lim))
      crt_br1(i) = sngl(a_ef / (avog * ro))/crt_br1(i)!->array with 17 values
c                                                     !  of free path
      elo_br1(i) = sngl( dsimps(aux2,h1,h2,lim) * avog * ro / a_ef )
      elo_br1(i) = elo_br1(i) * en * 1.e+3
      elo_br1(i) = alog10(elo_br1(i)) !-> array with 17 values of en. losses
      enddo
c
c                    b) Energy transfers > VMIN :
      do i=1,17
      en = float(i)
      en = (1.e+1)**(5.e-1 + (5.e-1 * en))
      vmi = alog(vmin)          !------------> The lower limit for integration
c
        um = 0.d+0
        do k=1,nsub
        ene=dble(en)
        u(k)=((z1(k))**(1.d+0/3.d+0))*1.236540953d+0*(rm_mu/(ene*1.d+3))
        u(k) = 1.d+0 - u(k)
        um = dmax1(u(k),um)
        enddo
        vma=sngl(um)  !----------------> The upper limit for integration
        vma=alog(vma) !
        vst = (vma - vmi) / float(lim) !-> step for a rel. en. transfers grid
c
      do j=0,lim
      rnu = vmi + vst*(float(j))
      rnu = exp(rnu)
      aux1(j) = dble(brem_tot3(en,rnu) * rnu)       !-> array to be integrated
c                                                  !   to get mean free path
      aux2(j) = aux1(j) * dble(rnu)                !-> array to be integrated
      enddo                                        !   for getting en. losses
c
      h1 = dble(vmi)
      h2 = dble(vma)
      crt_br2(i) = sngl(dsimps(aux1,h1,h2,lim))
      crt_br2(i) = sngl(a_ef / (avog * ro))/crt_br2(i)!-> array with 17 values
c                                                     !   of free path
      elo_br2(i) = sngl( dsimps(aux2,h1,h2,lim) * avog * ro / a_ef )
      elo_br2(i) = elo_br2(i) * en * 1.e+3
      if(elo_br2(i).le.0.e+0) elo_br2(i) = 1.e-8
      elo_br2(i) = alog10(elo_br2(i)) !-> array with 17 values of en. losses
      enddo
c
c                    c) Energy transfers > 0 :
      do i=1,17
      en = float(i)
      en = (1.e+1)**(5.e-1 + (5.e-1 * en))
      vmi = alog(1.e-3/en)      !------------> The lower limit for integration
c
        um = 0.d+0
        do k=1,nsub
        ene=dble(en)
        u(k)=((z1(k))**(1.d+0/3.d+0))*1.236540953d+0*(rm_mu/(ene*1.d+3))
        u(k) = 1.d+0 - u(k)
        um = dmax1(u(k),um)
        enddo
        vma=sngl(um)  !----------------> The upper limit for integration
        vma=alog(vma) !
        vst = (vma - vmi) / float(lim) !-> step for a rel. en. transfers grid
c
      do j=0,lim
      rnu = vmi + vst*(float(j))
      rnu = exp(rnu)
      aux2(j) = dble(brem_tot3(en,rnu) * rnu * rnu) !-> array to be integrated
c                                                  !   to get en. losses
      enddo
c
      h1 = dble(vmi)
      h2 = dble(vma)
      elo_br3(i) = sngl( dsimps(aux2,h1,h2,lim) * avog * ro / a_ef )
      elo_br3(i) = elo_br3(i) * en * 1.e+3
      if(elo_br3(i).le.0.e+0) elo_br3(i) = 1.e-8
      elo_br3(i) = alog10(elo_br3(i)) !-> array with 17 values of en. losses
      enddo
c                    c) Energy transfers < EMIN
      do i=1,17
      en = float(i)
      en = (1.e+1)**(5.e-1 + (5.e-1 * en))
      vmi = alog(1.e-3/en)      !------------> The lower limit for integration
      vma = alog(emin/en)   !----------------> The upper limit for integration
      vst = (vma - vmi) / float(lim) !----> step for a rel. en. transfers grid
c
      do j=0,lim
      rnu = vmi + vst*(float(j))
      rnu = exp(rnu)
      aux2(j) = dble(brem_tot3(en,rnu) * rnu * rnu) !-> array to be integrated
c                                                  !   to get en. losses
      enddo
c
      h1 = dble(vmi)
      h2 = dble(vma)
      elo_br4(i) = sngl( dsimps(aux2,h1,h2,lim) * avog * ro / a_ef )
      elo_br4(i) = elo_br4(i) * en * 1.e+3 !-> array with 17 values
      enddo                                !    of en. losses
c   ....................................................................
c                      3. COMPUTING OF CF FACTOR:
      if (ibrem.eq.1) then
      en = 1.e+9
      rnu = emin / en
      cf = brem_tot3(en,rnu)
      cf = cf * rnu * 1.02
      endif
      if (ibrem.eq.2) then
      en = 1.e+9
      rnu = emin / en
      cf = brem_tot3(en,rnu)
      cf = cf * rnu * 1.07
      endif
      if ((ibrem.ne.1).AND.(ibrem.ne.2)) then
      en = 1.e+1
      rnu = 1.e-3
      cf = brem_tot3(en,rnu)
      cf = cf * rnu * 1.1
      endif
c
      return
      end
****************************************************************************
* B.6_3
      FUNCTION getlbrem3(X)
*
      real*4 X
      COMMON /sok13/ XMIN,STEP,XMAX
      common /sok1_b3/ C(19)
      X1 = alog10(X)
       if ((X1.lt..99999e+0).or.(X1.gt.9.0001e+0)) then
       print*,'ERROR IN FUNCTION GETLBREMS: MUON ENERGY IS OUT OF RANGE'
       endif
      Y = (X1-XMIN)/STEP
      I = INT(Y+0.5)
      IF(I.LT.0.OR.X1.GT.XMAX) PRINT 1,X1,XMIN,XMAX
      Y = Y-I
      Z = Y*Y + 0.25
      getlbrem3 = (Z-Y)*C(I+1) + (2.-(Z+Z))*C(I+2) + (Z+Y)*C(I+3)
      RETURN
1     FORMAT('*MISTAKE*X1=',D23.16,'XMIN=',D23.16,'XMAX=',D23.16)
      END
****************************************************************************
* B.7_3
*
      FUNCTION glbremv3(X)
*
      real*4 X
      COMMON /sok13/ XMIN,STEP,XMAX
      common /sok1_b23/ C(19)
      X1 = alog10(X)
       if ((X1.lt..99999e+0).or.(X1.gt.9.0001e+0)) then
       print*,'ERROR IN FUNCTION GLBREMVS: MUON ENERGY IS OUT OF RANGE'
       endif
      Y = (X1-XMIN)/STEP
      I = INT(Y+0.5)
      IF(I.LT.0.OR.X1.GT.XMAX) PRINT 1,X1,XMIN,XMAX
      Y = Y-I
      Z = Y*Y + 0.25
      glbremv3 = (Z-Y)*C(I+1) + (2.-(Z+Z))*C(I+2) + (Z+Y)*C(I+3)
      RETURN
1     FORMAT('*MISTAKE*X1=',D23.16,'XMIN=',D23.16,'XMAX=',D23.16)
      END
****************************************************************************
* B.8_3
       function getctbr3(u)
*
      external getlbrem3
      real*8 z1(10),w(10),aw(10),a_ef,alfa,rm_e,rm_mu,r_e,avog,ro
      real*4 u
      common /const3/ alfa,rm_e,rm_mu,r_e,avog
      common /media3/ z1,w,aw,a_ef,ro,nsub
      if ((u.gt.1.0001e+9).or.(u.lt.9.9999e+0)) then
      print*,'ERROR IN FUNCTION GETCTBRS: MUON ENERGY IS OUT OF RANGE'
      endif
      aef = sngl(a_ef / (avog * ro))
      getctbr3 = aef / getlbrem3(u)
      return
      end
************************************************************************
* B.9_3
       function gctbrv3(u)
*
      external glbremv3
      real*8 z1(10),w(10),aw(10),a_ef,alfa,rm_e,rm_mu,r_e,avog,ro
      real*4 u
      common /const3/ alfa,rm_e,rm_mu,r_e,avog
      common /media3/ z1,w,aw,a_ef,ro,nsub
      if ((u.gt.1.0001e+9).or.(u.lt.9.9999e+0)) then
      print*,'ERROR IN FUNCTION GCTBRVS: MUON ENERGY IS OUT OF RANGE'
      endif
      aef = sngl(a_ef / (avog * ro))
      gctbrv3 = aef / glbremv3(u)
      return
      end
***************************************************************************
* B.10_3
         FUNCTION getdedbr3(X)
*
      real*4 X
      COMMON /sok53/ XMIN,STEP,XMAX
      common /sok5_b3TTT/ C(19)
      X1 = alog10(X)
       if ((X1.lt..99999e+0).or.(X1.gt.9.0001e+0)) then
       print*,'ERROR IN FUNCTION GETDEDBRS: MUON ENERGY IS OUT OF RANGE'
       endif
      Y = (X1-XMIN)/STEP
      I = INT(Y+0.5)
      IF(I.LT.0.OR.X1.GT.XMAX) PRINT 1,X1,XMIN,XMAX
      Y = Y-I
      Z = Y*Y + 0.25
      getdedbr3 = (Z-Y)*C(I+1) + (2.-(Z+Z))*C(I+2) + (Z+Y)*C(I+3)
      getdedbr3 = (1.e+1)**(getdedbr3)
      RETURN
1     FORMAT('*MISTAKE*X1=',D23.16,'XMIN=',D23.16,'XMAX=',D23.16)
      END
****************************************************************************
* B.11_3
      FUNCTION gdedbrv3(X)
*
      real*4 X
      COMMON /sok53/ XMIN,STEP,XMAX
      common /sok5_b23/ C(19)
      X1 = alog10(X)
       if ((X1.lt..99999e+0).or.(X1.gt.9.0001e+0)) then
       print*,'ERROR IN FUNCTION GDEDBRVS: MUON ENERGY IS OUT OF RANGE'
       endif
      Y = (X1-XMIN)/STEP
      I = INT(Y+0.5)
      IF(I.LT.0.OR.X1.GT.XMAX) PRINT 1,X1,XMIN,XMAX
      Y = Y-I
      Z = Y*Y + 0.25
      gdedbrv3 = (Z-Y)*C(I+1) + (2.-(Z+Z))*C(I+2) + (Z+Y)*C(I+3)
      gdedbrv3 = (1.e+1)**(gdedbrv3)
      RETURN
1     FORMAT('*MISTAKE*X1=',D23.16,'XMIN=',D23.16,'XMAX=',D23.16)
      END
****************************************************************************
* B.12_3
         FUNCTION gdedbrt3(X)
*
      real*4 X
      COMMON /sok53/ XMIN,STEP,XMAX
      common /sok5_b33/ C(19)
      X1 = alog10(X)
       if ((X1.lt..99999e+0).or.(X1.gt.9.0001e+0)) then
       print*,'ERROR IN FUNCTION GDEDBRTS: MUON ENERGY IS OUT OF RANGE'
       endif
      Y = (X1-XMIN)/STEP
      I = INT(Y+0.5)
      IF(I.LT.0.OR.X1.GT.XMAX) PRINT 1,X1,XMIN,XMAX
      Y = Y-I
      Z = Y*Y + 0.25
      gdedbrt3 = (Z-Y)*C(I+1) + (2.-(Z+Z))*C(I+2) + (Z+Y)*C(I+3)
      gdedbrt3 = (1.e+1)**(gdedbrt3)
      RETURN
1     FORMAT('*MISTAKE*X1=',D23.16,'XMIN=',D23.16,'XMAX=',D23.16)
      END
****************************************************************************
* B.13_3
       FUNCTION getcdbr3(X,Y,loga)
*
       real*4 X,Y
       integer loga
       external getcdbr13,getcdbr23,getcdbr33,brem_tot3
       if (loga.eq.0) then
          if (Y.le..251188643) then
            getcdbr3 = getcdbr13(X,Y,loga)
          else
            if (Y.le..794328234) then
               getcdbr3 = getcdbr23(X,Y,loga)
            else
               if (X.le.1.e+2) then
               Z = 0.97
               else
               Z = 0.992
               endif
               if (Y.le.Z) then
               getcdbr3 = getcdbr33(X,Y,loga)
               else
               getcdbr3 = brem_tot3(X,Y)
               endif
            endif
          endif
       else
          if (Y.le.-6.e-1) then
            getcdbr3 = getcdbr13(X,Y,loga)
          else
            if (Y.le.-1.e-1) then
               getcdbr3 = getcdbr23(X,Y,loga)
            else
               if (X.le.1.e+2) then
               Z = -1.3228265e-2
               else
               Z = -3.4883278e-3
               endif
               if (Y.le.Z) then
               getcdbr3 = getcdbr33(X,Y,loga)
               else
               Y1 = (1.e+1)**Y
               getcdbr3 = brem_tot3(X,Y1)
               endif
            endif
          endif
       endif
      return
      end
****************************************************************************
* B.14_3
       FUNCTION getcdbr13(X,Y,loga)
*
       real*4 X,Y
       integer loga
       common /sok3_3/ C1(4648)
       common /sok_2_13/ NX,NY,X0,SX,Y0,SY
c
      X_1=alog10(X)
c
      if ((X_1.lt..99999e+0).or.(X_1.gt.9.0001e+0)) then
      print*,'ERROR IN FUNCTION GETCDBR1S: MUON ENERGY IS OUT OF RANGE'
      endif
c
      if (loga.eq.0) then
      Y_1=alog10(Y)
      else
      Y_1=Y
      endif
c
      if ((Y_1.lt.-11.001).or.(Y_1.gt.-5.9999e-1)) then
      print*,'ERROR IN FUNCTION GETCDBR1S: EN. TRANSFER IS OUT OF RANGE'
      endif
c
      A3=(X_1-X0)/SX
      B3=(Y_1-Y0)/SY
      M1=INT(A3+.5)
      M2=INT(B3+.5)
      M3=NX+2
      IF(M1.LT.0.OR.M1.GE.NX.OR.M2.LT.0.OR.M2.GE.NY) THEN
      PRINT 1,X_1,M1,Y_1,M2
      ENDIF
      A3=A3-M1
      B3=B3-M2
      M1=M2*M3+M1+1
      M2=M1+M3
      M3=M2+M3
      A2 = A3*A3 +.25
      B2 = B3*B3 +.25
      A1=A2-A3
      B1=B2-B3
      A3=A2+A3
      B3=B2+B3
      A2=2.-(A2+A2)
      B2=2.-(B2+B2)
      getcdbr13=(A1*C1(M1)+A2*C1(M1+1)+A3*C1(M1+2))*B1
     2      +(A1*C1(M2)+A2*C1(M2+1)+A3*C1(M2+2))*B2
     3      +(A1*C1(M3)+A2*C1(M3+1)+A3*C1(M3+2))*B3
      if (getcdbr13.lt.0.e+0) getcdbr13 = 0.e+0
      RETURN
1     FORMAT('*MISTAKE*X=',D23.16,'MX=',I4,'Y=',D23.16,'MY=',I4)
      END
****************************************************************************
* B.15_3
       FUNCTION getcdbr23(X,Y,loga)
*
       real*4 X,Y
       integer loga
       common /sok63/ C1(4399)
       common /sok_2_23/ NX,NY,X0,SX,Y0,SY
c
      X_1=alog10(X)
      if ((X_1.lt..99999e+0).or.(X_1.gt.9.000001e+0)) then
      print*,'ERROR IN FUNCTION GETCDBR2S: MUON ENERGY IS OUT OF RANGE'
      endif
c
      if (loga.eq.0) then
      Y_1=alog10(Y)
      else
      Y_1=Y
      endif
c
      if ((Y_1.lt.-.60001).or.(Y_1.gt.-.99999e-1)) then
      print*,'ERROR IN FUNCTION GETCDBR2S: EN. TRANSFer IS OUT OF RANGE'
      endif
c
      A3=(X_1-X0)/SX
      B3=(Y_1-Y0)/SY
      M1=INT(A3+.5)
      M2=INT(B3+.5)
      M3=NX+2
      IF(M1.LT.0.OR.M1.GE.NX.OR.M2.LT.0.OR.M2.GE.NY) THEN
      PRINT 1,X_1,M1,Y_1,M2
      ENDIF
      A3=A3-M1
      B3=B3-M2
      M1=M2*M3+M1+1
      M2=M1+M3
      M3=M2+M3
      A2=A3*A3+.25
      B2=B3*B3+.25
      A1=A2-A3
      B1=B2-B3
      A3=A2+A3
      B3=B2+B3
      A2=2.-(A2+A2)
      B2=2.-(B2+B2)
      getcdbr23=(A1*C1(M1)+A2*C1(M1+1)+A3*C1(M1+2))*B1
     2      +(A1*C1(M2)+A2*C1(M2+1)+A3*C1(M2+2))*B2
     3      +(A1*C1(M3)+A2*C1(M3+1)+A3*C1(M3+2))*B3
      if (getcdbr23.lt.0.e+0) getcdbr23 = 0.e+0
      RETURN
1     FORMAT('*MISTAKE*X=',D23.16,'MX=',I4,'Y=',D23.16,'MY=',I4)
      END
****************************************************************************
* B.16_3
       FUNCTION getcdbr33(X,Y,loga)
*
       real*4 X,Y
       integer loga
       common /sok43/ C2(8549)
       common /sok_2_33/ NX,NY,X0,SX,Y0,SY
c
      X_1=alog10(X)
      if ((X_1.lt..99999e+0).or.(X_1.gt.9.000001e+0)) then
      print*,'ERROR IN FUNCTION GETCDBR3S: MUON ENERGY IS OUT OF RANGE'
      endif
c
      if (loga.eq.0) then
      Y_1=alog10(Y)
      else
      Y_1=Y
      endif
c
      if ((Y_1.lt.-1.00001e-1).or.(Y_1.gt.1.e-10)) then
      print*,'ERROR IN FUNCTION GETCDBR3S: EN. TRANSFER IS OUT OF RANGE'
      endif
c
      A3=(X_1-X0)/SX
      B3=(Y_1-Y0)/SY
      M1=INT(A3+.5)
      M2=INT(B3+.5)
      M3=NX+2
      IF(M1.LT.0.OR.M1.GE.NX.OR.M2.LT.0.OR.M2.GE.NY) THEN
      PRINT 1,X_1,M1,Y_1,M2
      ENDIF
      A3=A3-M1
      B3=B3-M2
      M1=M2*M3+M1+1
      M2=M1+M3
      M3=M2+M3
      A2=A3*A3+.25
      B2=B3*B3+.25
      A1=A2-A3
      B1=B2-B3
      A3=A2+A3
      B3=B2+B3
      A2=2.-(A2+A2)
      B2=2.-(B2+B2)
      getcdbr33=(A1*C2(M1)+A2*C2(M1+1)+A3*C2(M1+2))*B1
     2      +(A1*C2(M2)+A2*C2(M2+1)+A3*C2(M2+2))*B2
     3      +(A1*C2(M3)+A2*C2(M3+1)+A3*C2(M3+2))*B3
      if (getcdbr33.lt.0.e+0) getcdbr33 = 0.e+0
      RETURN
1     FORMAT('*MISTAKE*X=',D23.16,'MX=',I4,'Y=',D23.16,'MY=',I4)
      END
****************************************************************************
* B.17_3
*
      SUBROUTINE getvbrem3(emw,vbr,itr)
*
      real*4 emw,vbr
      integer itr
      external getcdbr3
      parameter (lo=1)
      common /general3/ emin,vmin,emph
      common /mcef3/ mcb1,mcb2,mcp1,mcp2,mcn1,mcn2,mce1,mce2
      common /br_ref3/ cf
      mcb1 = mcb1 + 1
         if (itr.eq.0) then
          algemin = alog10(emin/emw)
         else
          algemin = alog10(vmin)
         endif
  155 ax = algemin * rndm_mum(5)
      mcb2 = mcb2 + 1
      y1 = getcdbr3(emw,ax,lo)
      vbr = exp(-2.3025851e+0 * ax)
      y2 = cf * vbr
      yc = y2 * rndm_mum(8)
        if (y1.ge.yc) then
        vbr = 1.e+0 / vbr
        else
        goto 155
        endif
      return
      end
****************************************************************************
*********************** PAIR PRODUCTION SUBROUTINES : **********************
****************************************************************************
* P.1_3
*
      function CRP_G43 (Z,A,Tkin,EP)
c   ame in GeV:
       parameter    (ame=0.51099907e-3)
ccc parameter   (amu=0.105658389)   !!! GeV
c   re in cm:
      parameter (re=2.81794092e-13)
      parameter (avno=6.022137e23)
      parameter (pi=3.14159265)
c   parameter   (alpha=1./137.036)
ccc parameter   (rmass=amu/ame)     !!! "207"
c   parameter   (coeff=4./(3.*pi)*(alpha*re)**2*avno) !!! cm^2
c   sqrt(2.71828...):
      parameter (sqrte=1.64872127)
ccc parameter   (c3=3.*sqrte*amu/4.)    !!! for limits
c   parameter   (c7=4.*ame)     !!! -"-
ccc parameter   (c8=6.*amu**2)      !!! -"-
        common /const/ alfa,rm_e,rm_mu,r_e,avog
        real*8 alfa,rm_e,rm_mu,r_e,avog
        real*4 Z,A,Tkin,EP
c     Gauss, N=8:
      DIMENSION XGI(8),WGI(8)
      DATA XGI /.0199,.1017,.2372,.4083,.5917,.7628,.8983,.9801/
      DATA WGI /.0506,.1112,.1569,.1813,.1813,.1569,.1112,.0506/
c   for the moment:
      data  bbbtf,bbbh /183.,202.4/
      data  g1tf,g2tf /1.95e-5,5.3e-5/
      data  g1h,g2h   / 4.4e-5,4.8e-5/
        common /exer1/ fa
c************************************************************************
        adummy=a
        alpha=1./137.036
        coeff=4./(3.*pi)*(alpha*re)**2*avno
        c7=4.*ame
c************************************************************************
        amu = 1.e-3 * sngl(rm_mu)
        rmass = amu/ame
        c3=3.*sqrte*amu/4.
        c8=6.*amu**2
c************************************************************************
        E=tkin+amu
      z13=z**0.3333333
      e1=e-ep
      crp_g43=0.
      if (e1.le.c3*z13) return  !!! ep > max
      alf=c7/ep         !!! 4m/ep
      a3=1.-alf
      if (a3.le.0.) return      !!! ep < min
C***        zeta calculation
      if (z.le.1.5) then    !!! special case of hidrogen
        bbb=bbbh
        g1=g1h
        g2=g2h
      else
        bbb=bbbtf
        g1=g1tf
        g2=g2tf
      end if
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c  INSERTED BY SOKALSKI TO TAKE INTO ACCOUNT DIFFERENT BBB for
c  DIFFERENT NUCLEI (S.P.KELNER, R.P.KOKOULIN, A.A.PETRUKHIN,
c  Yad.Fiz. 62, 2042 (1999) [Phys.Atom.Nucl. 62, 1894 (1999)]
c
       ztmp = z + 1.e-2
       itmp = int(ztmp)
       if (itmp.eq.1) bbb=202.4
       if (itmp.eq.2) bbb=151.9
       if (itmp.eq.3) bbb=159.9
       if (itmp.eq.4) bbb=172.3
       if (itmp.eq.5) bbb=177.9
       if (itmp.eq.6) bbb=178.3
       if (itmp.eq.7) bbb=176.6
       if (itmp.eq.8) bbb=173.4
       if (itmp.eq.9) bbb=170.0
       if (itmp.eq.10) bbb=165.8
       if (itmp.eq.11) bbb=165.8
       if (itmp.eq.12) bbb=167.1
       if (itmp.eq.13) bbb=169.1
       if (itmp.eq.14) bbb=170.8
       if (itmp.eq.15) bbb=172.2
       if (itmp.eq.16) bbb=173.4
       if (itmp.eq.17) bbb=174.3
       if (itmp.eq.18) bbb=174.8
       if (itmp.eq.19) bbb=175.1
       if (itmp.eq.20) bbb=175.6
       if (itmp.eq.21) bbb=176.2
       if (itmp.eq.22) bbb=176.8
       if (itmp.eq.26) bbb=175.8
       if (itmp.eq.29) bbb=173.1
       if (itmp.eq.32) bbb=173.0
       if (itmp.eq.35) bbb=173.5
       if (itmp.eq.42) bbb=175.9
       if (itmp.eq.50) bbb=177.4
       if (itmp.eq.53) bbb=178.6
       if (itmp.eq.74) bbb=177.6
       if (itmp.eq.82) bbb=178.0
       if (itmp.eq.92) bbb=179.8
cccccccccccccccccccccccccccccccccccccccccccccccccc
      zeta1=0.073*alog(e/(amu+g1*z13**2*e))-0.26
        if (zeta1.gt.0.) then
          zeta2=0.058*alog(e/(amu+g2*z13   *e))-0.14
          zeta=zeta1/zeta2
        else
          zeta=0.
        end if
      z2=z*(z+zeta)             !!!
      screen0=2.*ame*sqrte*bbb/(z13*ep) !!! be careful with "ame"
      a0=e*e1
      a1=ep*ep/a0           !!! 2*beta
      bet=0.5*a1            !!! beta
      xi0=0.25*rmass*rmass*a1       !!! xi0
      del=c8/a0         !!! 6mu^2/EE'
      tmn=alog((alf+2.*del*a3)/(1.+(1.-del)*sqrt(a3))) !!! log(1-rmax)
      sum=0.
      do i=1,8      !!! integration
      a4=exp(tmn*xgi(i))    !!! 1-r
      a5=a4*(2.-a4)     !!! 1-r2
      a6=1.-a5      !!! r2
      a7=1.+a6      !!! 1+r2
      a9=3.+a6      !!! 3+r2
      xi=xi0*a5
      xii=1./xi
      xi1=1.+xi
      screen=screen0*xi1/a5
      yeu=5.-a6+4.*bet*a7
      yed=2.*(1.+3.*bet)*alog(3.+xii)-a6-a1*(2.-a6)
      ye1=1.+yeu/yed
      ale=alog(bbb/z13*sqrt(xi1*ye1)/(1.+screen*ye1))
      cre=0.5*alog(1.+(1.5/rmass*z13)**2*xi1*ye1)
      if (xi.le.1e3) then
        be=((2.+a6)*(1.+bet)+xi*a9)*alog(1.+xii)+(a5-bet)/xi1-a9
      else
        be=(3.-a6+a1*a7)/(2.*xi) !!!-(6.-5.*a6+3.*bet*a6)/(6.*xi*xi)
      end if
      if(rm_mu.le.1.d+3) then
        fe=amax1(0.,(ale-cre)*be)
      else
        fe=amax1(0.,ale*be)
      endif
      ymu=4.+a6+3.*bet*a7
      ymd=a7*(1.5+a1)*alog(3.+xi)+1.-1.5*a6
      ym1=1.+ymu/ymd
      alm_crm=alog(bbb*rmass/(1.5*z13*z13*(1.+screen*ym1)))
      if (xi.ge.1e-3) then  !!!
        a10=(1.+a1)*a5      !!! (1+2b)(1-r2)
        bm=(a7*(1.+1.5*bet)-a10*xii)*alog(xi1)+xi*(a5-bet)/xi1+a10
      else
        bm=(5.-a6+bet*a9)*(xi/2.) !!!-(11.-5.*a6+.5*bet*(5.+a6))*(xi*xi/6.)
      end if
      fm=amax1(0.,(alm_crm)*bm)
      if(rm_mu.le.1.d+3) then
        sum=sum+a4*(fe+fm/rmass**2)*wgi(i)
      else
        sum=sum+a4*fe*wgi(i)
      endif
      end do
      crp_g43=fa*(-tmn*sum*z2*coeff*e1/ep)/avno  ! Vstavleno Sokalskim
c                                                ! (dobavlen mnozhitel
c                                                ! (A / N_a) * E )
      return
      end
****************************************************************************
* P.2_3
*
       real*8 function pair3(z,en,rnu)
       external CRP_G43
       real*8 z,en,rnu
       real*8 alfa,rm_e,rm_mu,r_e,avog
       common /const3/ alfa,rm_e,rm_mu,r_e,avog
       z0 = sngl(z)
       A = 10.
c       Tkin = sngl(en - 1.05658389d-1)
       Tkin = sngl(en) - (1.e-3 * sngl(rm_mu))
       ep = sngl(rnu * en)
       pa = CRP_G43(z0,A,Tkin,ep)
       pair3 = dble(pa)
       return
       end
****************************************************************************
* P.3_3
*
       function pair_tot3(ene,v)
       external pair3
       real*8 z1(10),w(10),aw(10),a_ef,en,rnu,h1,pair3,ro
       real*4 ene,v
       integer nsub
       common /media3/ z1,w,aw,a_ef,ro,nsub
c
       if (v.gt..999995) v = .999995
       en = dble(ene)
       rnu = dble(v)
       h1 = w(1) * pair3(z1(1),en,rnu)
         if (nsub.ge.2) then
           do l=2,nsub
             h1 = h1 + (w(l) * pair3(z1(l),en,rnu))
           enddo
         endif
       pair_tot3 = sngl(h1)
       return
       end
****************************************************************************
* P.4_3
       subroutine pair13
*
       external pair_tot3,dsimps
       real*8 dsimps
       real*8 ai,bi,h1,h2,um,ene,u(10)
       real*8 aux1(0:2000),aux2(0:2000)
       real*8 alfa,rm_e,rm_mu,r_e,avog,z1(10),w(10),aw(10),a_ef,ro
       real*8 com1_pa(0:2200),com_pa_in(1101),com_p_h(0:2),tot_pa
       dimension com_pa_m(2201)
       common /help_13/ aux1,aux2
       common /const3/ alfa,rm_e,rm_mu,r_e,avog ! from initial subroutine
       common /media3/ z1,w,aw,a_ef,ro,nsub     !       MED_CONSS
       common /general3/ emin,vmin,emph         !
       common /cdpa_in3/ fcd1(81,54),fcd2(81,101),fcd3(81,51)
       common /ctpa_in13/ crt_pa1(17),crt_pa2(17)
       common /elpa_in13/ elo_pa1(17),elo_pa2(17)
       common /elpa_in23/ elo_pa3(17)
       common /elpa_in43/ elo_pa4(17)
       common /sok343/ com_pa_m
       common /sok243/ com_pa_in
       common /sok333/ tot_pa
       common /fac_pa3/ fac
       fac = 1.12
c ....................................................................
c      1.PREPARATION OF ARRAYS WITH DIFF. CROSS-SEECTIONS FOR MUON
c                           E+E- PAIR PRODUCTION:
c
c                !       ..........................
      do j=1,81  !--->   j CYCLE BY ENERGIES starts
c                !       ..........................
        en = float(j)
        en = 1.e+1**(9.e-1 + (1.e-1 * en))
c                     !         ..................................
      do k=1,206      !--->     k CYCLE BY ENERGY TRANSFERS starts
c                     !         ..................................
      if (k.eq.206) then
        fcd2(j,k-105) = -37.0
        goto 975
      endif
c
      if (k.le.54) then
         k01 = k - 1
         rnu = 1.e+1**(float(k01) * 2.e-1 - 1.1e+1)
      else
         if (k.le.105) then
           k01 = k - 55
           rnu = 1.e+1**(float(k01) * 1.e-2 - 6.e-1)
         else
           k01 = k - 106
           rnu = 1.e+1**(float(k01) * 1.e-3 - 1.e-1)
         endif
      endif
c
      cr_dif=pair_tot3(en,rnu)
      if (cr_dif.le.1.e-37) cr_dif = 1.e-37
      cr_dif=alog(cr_dif)
c
      if (k.le.54) fcd1(j,k) = cr_dif
      if ((k.gt.54).AND.(k.lt.106)) fcd3(j,k-54) = cr_dif
      if (k.ge.106) fcd2(j,k-105) = cr_dif
c
 975  continue
c              !     ....................................
      enddo    !---> k CYCLE BY ENERGY TRANSFERS finishes
c              !     ....................................
      enddo    !----> j CYCLE BY ENERGIES finishes
c              !     ....................................
c   ....................................................................
c      2.PREPARATION OF ARRAYS WITH ENERGY LOSSES AND MEAN FREE PATH
c                         FOR MUON BREMSSTRAHLUNG:
c
c                    a) Energy transfers > EMIN :
      lim = 2000
      do i=1,17
      en = float(i)
      en = (1.e+1)**(5.e-1 + (5.e-1 * en))
      vmi = alog(emin / en) !------------> The lower limit for integration
        um = 0.d+0
        do k=1,nsub
        ene=dble(en)
        u(k)=((z1(k))**(1.d+0/3.d+0))*1.236540953d+0*(rm_mu/(ene*1.d+3))
        u(k) = 1.d+0 - u(k)
        um = dmax1(u(k),um)
        enddo
        vma=sngl(um)  !----------------> The upper limit for integration
        vma=alog(vma) !
        vst = (vma - vmi) / float(lim) !-> step for a rel. en. transfers grid
      do j=0,lim
      rnu = vmi + vst*(float(j))
      rnu = exp(rnu)
      aux1(j) = dble(pair_tot3(en,rnu) * rnu)       !-> array to be integrated
c                                                  !   to get mean free path
      aux2(j) = aux1(j) * dble(rnu)                !-> array to be integrated
      enddo                                        !   for getting en. losses
c
      h1 = dble(vmi)
      h2 = dble(vma)
      crt_pa1(i) = sngl(dsimps(aux1,h1,h2,lim))         !-> array with 17 values
      crt_pa1(i) = sngl(a_ef / (avog * ro))/crt_pa1(i)  !   of free path
      crt_pa1(i) = alog(crt_pa1(i))
      elo_pa1(i) = sngl( dsimps(aux2,h1,h2,lim) * avog * ro / a_ef )
      elo_pa1(i) = elo_pa1(i) * en * 1.e+3
      elo_pa1(i) = alog(elo_pa1(i)) !-> array with 17 values of en. losses
      enddo
c                    b) Energy transfers > VMIN :
      do i=1,17
      en = float(i)
      en = (1.e+1)**(5.e-1 + (5.e-1 * en))
      vmi = alog(vmin) !------------> The lower limit for integration
        um = 0.d+0
        do k=1,nsub
        ene=dble(en)
        u(k)=((z1(k))**(1.d+0/3.d+0))*1.236540953d+0*(rm_mu/(ene*1.d+3))
        u(k) = 1.d+0 - u(k)
        um = dmax1(u(k),um)
        enddo
        vma=sngl(um)  !----------------> The upper limit for integration
        vma=alog(vma) !
        vst = (vma - vmi) / float(lim) !-> step for a rel. en. transfers grid
c
      do j=0,lim
      rnu = vmi + vst*(float(j))
      rnu = exp(rnu)
      aux1(j) = dble(pair_tot3(en,rnu) * rnu)       !-> array to be integrated
c                                                  !   to get mean free path
      aux2(j) = aux1(j) * dble(rnu)                !-> array to be integrated
      enddo                                        !   for getting en. losses
c
      h1 = dble(vmi)
      h2 = dble(vma)
      crt_pa2(i) = sngl(dsimps(aux1,h1,h2,lim))         !-> array with 17 values
      crt_pa2(i) = sngl(a_ef / (avog * ro))/crt_pa2(i)  !   of free path
      crt_pa2(i) = alog(crt_pa2(i))
      elo_pa2(i) = sngl( dsimps(aux2,h1,h2,lim) * avog * ro / a_ef )
      elo_pa2(i) = elo_pa2(i) * en * 1.e+3
      if(elo_pa2(i).le.0.e+0) elo_pa2(i) = 1.e-8
      elo_pa2(i) = alog(elo_pa2(i)) !-> array with 17 values of en. losses
      enddo
c                    c) Energy transfers > 0 :
      do i=1,17
      en = float(i)
      en = (1.e+1)**(5.e-1 + (5.e-1 * en))
      vmi = alog(2.046e-3/en) !------------> The lower limit for integration
c
        um = 0.d+0
        do k=1,nsub
        ene=dble(en)
        u(k)=((z1(k))**(1.d+0/3.d+0))*1.236540953d+0*(rm_mu/(ene*1.d+3))
        u(k) = 1.d+0 - u(k)
        um = dmax1(u(k),um)
        enddo
        vma=sngl(um)  !----------------> The upper limit for integration
        vma=alog(vma) !
        vst = (vma - vmi) / float(lim) !-> step for a rel. en. transfers grid
      do j=0,lim
      rnu = vmi + vst*(float(j))
      rnu = exp(rnu)
      aux2(j) = dble(pair_tot3(en,rnu) * rnu * rnu) !-> array to be integrated
      enddo                                        !   for getting en. losses
c
      h1 = dble(vmi)
      h2 = dble(vma)
      elo_pa3(i) = sngl( dsimps(aux2,h1,h2,lim) * avog * ro / a_ef )
      elo_pa3(i) = elo_pa3(i) * en * 1.e+3
      if(elo_pa3(i).le.0.e+0) elo_pa3(i) = 1.e-8
      elo_pa3(i) = alog(elo_pa3(i)) !-> array with 17 values of en. losses
      enddo
c                    d) Energy transfers < EMIN :
      do i=1,17
      en = float(i)
      en = (1.e+1)**(5.e-1 + (5.e-1 * en))
      vmi = alog(2.046e-3/en) !------------> The lower limit for integration
      vma = alog(emin/en)  !----------------> The upper limit for integration
      vst = (vma - vmi) / float(lim) !---> step for a rel. en. transfers grid
      do j=0,lim
      rnu = vmi + vst*(float(j))
      rnu = exp(rnu)
      aux2(j) = dble(pair_tot3(en,rnu) * rnu * rnu) !-> array to be integrated
      enddo                                        !   for getting en. losses
c
      h1 = dble(vmi)
      h2 = dble(vma)
      elo_pa4(i) = sngl( dsimps(aux2,h1,h2,lim) * avog * ro / a_ef )
      elo_pa4(i) = elo_pa4(i) * en * 1.e+3 !-> array with 17 values
      enddo                                !   of en. losses
c   ....................................................................
c   3. PREPARATION OF ARRAY COM_PA_M WITH VALUES OF COMPARISON FUNCTION:
         en = 1.e+9
           do i=1,2201
              i1 = i - 1
              rnu = 1.e+1**(float(i1) * 5.e-3 - 1.1e+1)
              com_pa_m(i) = fac * pair_tot3(en,rnu)
              com1_pa(i-1) = dble(com_pa_m(i) * rnu)
           enddo
           do i=1,2201
              if (com_pa_m(i).le.0.e+0) com_pa_m(i) = 1.0001e-37
              com_pa_m(i)=alog(com_pa_m(i))
           enddo
c   ....................................................................
c       4. PREPARATION OF ARRAY COM_PA_IN WITH VALUES OF INTEGRATED
c                 COMPARISON FUNCTION AND VALUE OF TOT_PA:
        com_pa_in(1) = 0.d+0
        h1 = 0.d+0
        m = 2
          do i=2,1101
             i1 = 2 * i
               com_p_h(0) = com1_pa(i1-4)
               com_p_h(1) = com1_pa(i1-3)
               com_p_h(2) = com1_pa(i1-2)
             ai = -((dble(1102 - i)) * 1.d-2)
             bi = ai + 1.d-2
             ai = 2.302585093 * ai
             bi = 2.302585093 * bi
             h2 = dsimps(com_p_h,ai,bi,m)
             h1 = h1 + h2
             com_pa_in(i) = h1
          enddo
        tot_pa = com_pa_in(1101)
       return
       end
****************************************************************************
* P.5_3
      FUNCTION getlpair3(X)
*
      real*4 X
      COMMON /sok13/ XMIN,STEP,XMAX
      common /sok1_p3/ C(19)
      X1 = alog10(X)
       if ((X1.lt..99999e+0).or.(X1.gt.9.0001e+0)) then
       print*,'ERROR IN FUNCTION GETLPAIRS: MUON ENERGY IS OUT OF RANGE'
       endif
      Y = (X1-XMIN)/STEP
      I = INT(Y+0.5)
      IF(I.LT.0.OR.X1.GT.XMAX) PRINT 1,X1,XMIN,XMAX
      Y = Y-I
      Z = Y*Y + 0.25
      getlpair3 = (Z-Y)*C(I+1) + (2.-(Z+Z))*C(I+2) + (Z+Y)*C(I+3)
      getlpair3 = exp(getlpair3)
      RETURN
1     FORMAT('*MISTAKE*X1=',D23.16,'XMIN=',D23.16,'XMAX=',D23.16)
      END
****************************************************************************
* P.6_3
      FUNCTION glpairv3(X)
*
      real*4 X
      COMMON /sok13/ XMIN,STEP,XMAX
      common /sok1_p23/ C(19)
      X1 = alog10(X)
       if ((X1.lt..99999e+0).or.(X1.gt.9.0001e+0)) then
       print*,'ERROR IN FUNCTION GLPAIRVS: MUON ENERGY IS OUT OF RANGE'
       endif
      Y = (X1-XMIN)/STEP
      I = INT(Y+0.5)
      IF(I.LT.0.OR.X1.GT.XMAX) PRINT 1,X1,XMIN,XMAX
      Y = Y-I
      Z = Y*Y + 0.25
      glpairv3 = (Z-Y)*C(I+1) + (2.-(Z+Z))*C(I+2) + (Z+Y)*C(I+3)
      glpairv3 = exp(glpairv3)
      RETURN
1     FORMAT('*MISTAKE*X1=',D23.16,'XMIN=',D23.16,'XMAX=',D23.16)
      END
****************************************************************************
* P.7_3
       function getctpa3(u)
*
       external getlpair3
       real*8 z1(10),w(10),aw(10),a_ef,alfa,rm_e,rm_mu,r_e,avog,ro
       real*4 u
       common /const3/ alfa,rm_e,rm_mu,r_e,avog
       common /media3/ z1,w,aw,a_ef,ro,nsub
      if ((u.gt.1.0001e+9).or.(u.lt.9.9999e+0)) then
      print*,'ERROR IN FUNCTION GETCTPAS: MUON ENERGY IS OUT OF RANGE'
      endif
      aef = sngl(a_ef / (avog * ro))
      getctpa3 = aef / getlpair3(u)
      return
      end
*************************************************************************
* P.8_3
       function gctpav3(u)
*
      external glpairv3
      real*8 z1(10),w(10),aw(10),a_ef,alfa,rm_e,rm_mu,r_e,avog,ro
      real*4 u
      common /const3/ alfa,rm_e,rm_mu,r_e,avog
      common /media3/ z1,w,aw,a_ef,ro,nsub
      if ((u.gt.1.0001e+9).or.(u.lt.9.9999e+0)) then
      print*,'ERROR IN FUNCTION GCTPAVS: MUON ENERGY IS OUT OF RANGE'
      endif
      aef = sngl(a_ef / (avog * ro))
      gctpav3 = aef / glpairv3(u)
      return
      end
************************************************************************
* P.9_3
       FUNCTION getdedpa3(X)
*
      real*4 X
      COMMON /sok53/ XMIN,STEP,XMAX
      common /sok5_p3TTT/ C(19)
      X1 = alog10(X)
       if ((X1.lt..99999e+0).or.(X1.gt.9.0001e+0)) then
       print*,'ERROR IN FUNCTION GETDEDPAS: MUON ENERGY IS OUT OF RANGE'
       endif
      Y = (X1-XMIN)/STEP
      I = INT(Y+0.5)
      IF(I.LT.0.OR.X1.GT.XMAX) PRINT 1,X1,XMIN,XMAX
      Y = Y-I
      Z = Y*Y + 0.25
      getdedpa3 = (Z-Y)*C(I+1) + (2.-(Z+Z))*C(I+2) + (Z+Y)*C(I+3)
      getdedpa3 = exp(getdedpa3)
      RETURN
1     FORMAT('*MISTAKE*X1=',D23.16,'XMIN=',D23.16,'XMAX=',D23.16)
      END
****************************************************************************
* P.10_3
      FUNCTION gdedpav3(X)
*
      real*4 X
      COMMON /sok53/ XMIN,STEP,XMAX
      common /sok5_p23/ C(19)
      X1 = alog10(X)
       if ((X1.lt..99999e+0).or.(X1.gt.9.0001e+0)) then
       print*,'ERROR IN FUNCTION GDEDPAVS: MUON ENERGY IS OUT OF RANGE'
       endif
      Y = (X1-XMIN)/STEP
      I = INT(Y+0.5)
      IF(I.LT.0.OR.X1.GT.XMAX) PRINT 1,X1,XMIN,XMAX
      Y = Y-I
      Z = Y*Y + 0.25
      gdedpav3 = (Z-Y)*C(I+1) + (2.-(Z+Z))*C(I+2) + (Z+Y)*C(I+3)
      gdedpav3 = exp(gdedpav3)
      RETURN
1     FORMAT('*MISTAKE*X1=',D23.16,'XMIN=',D23.16,'XMAX=',D23.16)
      END
****************************************************************************
* P.11_3
       FUNCTION gdedpat3(X)
*
      real*4 X
      COMMON /sok53/ XMIN,STEP,XMAX
      common /sok5_p33/ C(19)
      X1 = alog10(X)
       if ((X1.lt..99999e+0).or.(X1.gt.9.0001e+0)) then
       print*,'ERROR IN FUNCTION GDEDPATS: MUON ENERGY IS OUT OF RANGE'
       endif
      Y = (X1-XMIN)/STEP
      I = INT(Y+0.5)
      IF(I.LT.0.OR.X1.GT.XMAX) PRINT 1,X1,XMIN,XMAX
      Y = Y-I
      Z = Y*Y + 0.25
      gdedpat3 = (Z-Y)*C(I+1) + (2.-(Z+Z))*C(I+2) + (Z+Y)*C(I+3)
      gdedpat3 = exp(gdedpat3)
      RETURN
1     FORMAT('*MISTAKE*X1=',D23.16,'XMIN=',D23.16,'XMAX=',D23.16)
      END
****************************************************************************
* P.12_3
        FUNCTION getcdp3(X,Y,lo)
*
       real*4 X,Y
       integer lo
       external getcdp13,getcdp23,getcdp33,pair_tot3
       if (lo.eq.0) then
          if (Y.le..251188643) then
                getcdp3 = getcdp13(X,Y,lo)
               getcdp3 = exp(getcdp3)
          else
               if (Y.le..794328234) then
                  getcdp3 = getcdp23(X,Y,lo)
                  getcdp3 = exp(getcdp3)
               else
                 if (Y.le..965) then
                    getcdp3 = getcdp33(X,Y,lo)
                    getcdp3 = exp(getcdp3)
                 else
                    getcdp3 = pair_tot3(X,Y)
                 endif
               endif
          endif
       else
          if (Y.le.-6.e-1) then
                getcdp3 = getcdp13(X,Y,lo)
                getcdp3 = exp(getcdp3)
          else
                if (Y.le.-1.e-1) then
                   getcdp3 = getcdp23(X,Y,lo)
                   getcdp3 = exp(getcdp3)
                else
                   if (Y.le.-1.547272686e-2) then
                     getcdp3 = getcdp33(X,Y,lo)
                     getcdp3 = exp(getcdp3)
                   else
                     Y1 = (1.e+1)**Y
                     getcdp3 = pair_tot3(X,Y1)
                   endif
                endif
          endif
       endif
      if (getcdp3.lt.0.e+0) getcdp3 = 0.e+0
      return
      end
****************************************************************************
* P.13_3
        FUNCTION getcdp13(X,Y,loga)
*
      real*4 X,Y
      integer loga
      common /sok83/ C1(4648)
      common /sok_2_13/ NX,NY,X0,SX,Y0,SY
      X_1=alog10(X)
      if ((X_1.lt..99999e+0).or.(X_1.gt.9.0001e+0)) then
      print*,'ERROR IN FUNCTION GETCDP1S: MUON ENERGY IS OUT OF RANGE'
      endif
c
      if (loga.eq.0) then
      Y_1=alog10(Y)
      else
      Y_1=Y
      endif
      if ((Y_1.lt.-11.001).or.(Y_1.gt.-5.9999e-1)) then
      print*,'ERROR IN FUNCTION GETCDP1: EN. TRANSFER IS OUT OF RANGE'
      endif
c
      A3=(X_1-X0)/SX
      B3=(Y_1-Y0)/SY
      M1=INT(A3+.5)
      M2=INT(B3+.5)
      M3=NX+2
      IF(M1.LT.0.OR.M1.GE.NX.OR.M2.LT.0.OR.M2.GE.NY) THEN
      PRINT 1,X_1,M1,Y_1,M2
      ENDIF
      A3=A3-M1
      B3=B3-M2
      M1=M2*M3+M1+1
      M2=M1+M3
      M3=M2+M3
      A2=A3*A3+.25
      B2=B3*B3+.25
      A1=A2-A3
      B1=B2-B3
      A3=A2+A3
      B3=B2+B3
      A2=2.-(A2+A2)
      B2=2.-(B2+B2)
      getcdp13=(A1*C1(M1)+A2*C1(M1+1)+A3*C1(M1+2))*B1
     2      +(A1*C1(M2)+A2*C1(M2+1)+A3*C1(M2+2))*B2
     3      +(A1*C1(M3)+A2*C1(M3+1)+A3*C1(M3+2))*B3
      RETURN
1     FORMAT('GETCDP1: *MISTAKE*X= ',D23.16,' MX= ',I4,' Y= ',D23.16,' M
     *Y= ',I4)
      END
****************************************************************************
* P.14_3
       FUNCTION getcdp23(X,Y,loga)
*
       real*4 X,Y
       integer loga
       common /sok93/ C1(4399)
       common /sok_2_23/ NX,NY,X0,SX,Y0,SY
      X_1=alog10(X)
      if ((X_1.lt..99999e+0).or.(X_1.gt.9.0001e+0)) then
      print*,'ERROR IN FUNCTION GETCDP2S: MUON ENERGY IS OUT OF RANGE'
      endif
      if (loga.eq.0) then
      Y_1=alog10(Y)
      else
      Y_1=Y
      endif
      if ((Y_1.lt.-.60001).or.(Y_1.gt.-.99999e-1)) then
      print*,'ERROR IN FUNCTION GETCDP2S: EN. TRANSFer IS OUT OF RANGE'
      endif
      A3=(X_1-X0)/SX
      B3=(Y_1-Y0)/SY
      M1=INT(A3+.5)
      M2=INT(B3+.5)
      M3=NX+2
      IF(M1.LT.0.OR.M1.GE.NX.OR.M2.LT.0.OR.M2.GE.NY) THEN
      PRINT 1,X_1,M1,Y_1,M2
      ENDIF
      A3=A3-M1
      B3=B3-M2
      M1=M2*M3+M1+1
      M2=M1+M3
      M3=M2+M3
      A2=A3*A3+.25
      B2=B3*B3+.25
      A1=A2-A3
      B1=B2-B3
      A3=A2+A3
      B3=B2+B3
      A2=2.-(A2+A2)
      B2=2.-(B2+B2)
      getcdp23=(A1*C1(M1)+A2*C1(M1+1)+A3*C1(M1+2))*B1
     2      +(A1*C1(M2)+A2*C1(M2+1)+A3*C1(M2+2))*B2
     3      +(A1*C1(M3)+A2*C1(M3+1)+A3*C1(M3+2))*B3
      RETURN
1     FORMAT('GCDP2S:*MISTAKE*X=',D23.16,'MX=',I4,'Y=',D23.16,'MY=',I4)
      END
****************************************************************************
* P.15_3
       FUNCTION getcdp33(X,Y,loga)
*
       real*4 X,Y
       integer loga
       common /sok103/ C2(8549)
       common /sok_2_33/ NX,NY,X0,SX,Y0,SY
      X_1=alog10(X)
      if ((X_1.lt..99999e+0).or.(X_1.gt.9.0001e+0)) then
      print*,'ERROR IN FUNCTION GETCDP3S: MUON ENERGY IS OUT OF RANGE'
      endif
      if (loga.eq.0) then
      Y_1=alog10(Y)
      else
      Y_1=Y
      endif
      if ((Y_1.lt.-1.0001e-1).or.(Y_1.gt.1.e-6)) then
      print*,'ERROR IN FUNCTION GETCDP3S: EN. TRANSFER IS OUT OF RANGE'
      endif
      A3=(X_1-X0)/SX
      B3=(Y_1-Y0)/SY
      M1=INT(A3+.5)
      M2=INT(B3+.5)
      M3=NX+2
      IF(M1.LT.0.OR.M1.GE.NX.OR.M2.LT.0.OR.M2.GE.NY) THEN
      PRINT 1,X_1,M1,Y_1,M2
      ENDIF
      A3=A3-M1
      B3=B3-M2
      M1=M2*M3+M1+1
      M2=M1+M3
      M3=M2+M3
      A2=A3*A3+.25
      B2=B3*B3+.25
      A1=A2-A3
      B1=B2-B3
      A3=A2+A3
      B3=B2+B3
      A2=2.-(A2+A2)
      B2=2.-(B2+B2)
      getcdp33=(A1*C2(M1)+A2*C2(M1+1)+A3*C2(M1+2))*B1
     2      +(A1*C2(M2)+A2*C2(M2+1)+A3*C2(M2+2))*B2
     3      +(A1*C2(M3)+A2*C2(M3+1)+A3*C2(M3+2))*B3
      RETURN
1     FORMAT('*MISTAKE*X=',D23.16,'MX=',I4,'Y=',D23.16,'MY=',I4)
      END
****************************************************************************
* P.16_3
      FUNCTION comp3(X)
*
      real*4 X
      external pair_tot3
      common /sok553/ XMIN,STEP,XMAX
      common /sok55_p3/ C(2203)
      common /fac_pa3/ fac
      parameter (en = 1.e+9)
      X1 = X
      if (X1.lt.-1.5472686e-2) then
       if ((X1.lt.-11.001e+0).or.(X1.gt.1.e-5)) then
       print*,'ERROR IN FUNCTION COMPS: ENERGY transfer IS OUT OF RANGE'
       endif
      Y = (X1-XMIN)/STEP
      I = INT(Y+0.5)
      IF(I.LT.0.OR.X1.GT.XMAX) PRINT 1,X1,XMIN,XMAX
      Y = Y-I
      Z = Y*Y + 0.25
      comp3 = exp((Z-Y)*C(I+1) + (2.-(Z+Z))*C(I+2) + (Z+Y)*C(I+3))
      else
      rnu = 1.e+1**X1
      comp3 = fac * pair_tot3(en,rnu)
      endif
      RETURN
1     FORMAT('*MISTAKE* X1=',D23.16,'  XMIN=',D23.16,'  XMAX=',D23.16)
      END
****************************************************************************
* P.17_3
      real*8 FUNCTION c_pa_in3(X)
*
      real*8 XMIN,STEP,XMAX
      real*8 C(1103)
      real*8 X,X1,Y,Z
      COMMON /sok253/ XMIN,STEP,XMAX
      common /sok263/ C
       X1 = dlog10(X)
       if ((X1.lt.-11.0001d+0).or.(X1.gt.1.d-6)) then
       print*,'ERROR IN FUNCTION C_PA_INS: TRANSFER IS OUT OF RANGE'
       endif
      Y = (X1-XMIN)/STEP
      I = INT(Y+0.5)
      IF(I.LT.0.OR.X1.GT.XMAX) PRINT 1,X1,XMIN,XMAX
      Y = Y-I
      Z = Y*Y + 0.25
      c_pa_in3 = (Z-Y)*C(I+1) + (2.-(Z+Z))*C(I+2) + (Z+Y)*C(I+3)
      RETURN
1     FORMAT('*MISTAKE*X1=',D23.16,'XMIN=',D23.16,'XMAX=',D23.16)
      END
****************************************************************************
* P.18_3
        SUBROUTINE DSPLQ13
*
      PARAMETER (N=1101)
      real*8 x(N),y(N),Y2(N),U(N),P,SIG,QN,UN
      common /sok243/ X
      common /pa_in_s23/ Y
      common /pa_in_s33/ Y2
      do i=1,N                              ! Preparation of array Y(1101):
        Y(i) = -1.1d+1 + dble(i-1) * 1.d-2  !   log10(rel. en. transfer)
      enddo   !-----------------------------!       from -11.0 to 0.
      Y(N) = 0.d+0                          !------ with step 0.01
      Y2(1)=0.d+0
      U(1)=0.d+0
      DO 11 I=2,N-1 !------------------------------------------!
        SIG=(X(I)-X(I-1))/(X(I+1)-X(I-1))                      !  Cooking of
        P=SIG*Y2(I-1)+2.d+0                                    !    splain
        Y2(I)=(SIG-1.d+0)/P                                    ! coefficients
        U(I)=(6.d+0*((Y(I+1)-Y(I))/(X(I+1)-X(I))-(Y(I)-Y(I-1)) ! and putting
     *      /(X(I)-X(I-1)))/(X(I+1)-X(I-1))-SIG*U(I-1))/P      !  them into
11    CONTINUE                                                 !   output
c                                                              !  Y2(1101)
      QN=0.d+0                                                 !  array to
      UN=0.d+0                                                 !  be passed
c                                                              ! to routine
      Y2(N)=(UN-QN*U(N-1))/(QN*Y2(N-1)+1.d+0)                  !  DSPLIN13
      DO 12 K=N-1,1,-1                                         !
        Y2(K)=Y2(K)*Y2(K+1)+U(K)                               !
12    CONTINUE  !----------------------------------------------!
      RETURN
      END
***********************************************************************
* P.19_3
      real*8 FUNCTION DSPLIN13(X1)
*
      PARAMETER (N=1101)
      real*8 X1,Y1
      real*8 XA(N),YA(N),Y2A(N),X,Y,H,A,B
      common /sok243/ XA
      common /pa_in_s23/ YA
      common /pa_in_s33/ Y2A
      X=X1
      KLO=1
      KHI=N
1     IF (KHI-KLO.GT.1) THEN
        K=(KHI+KLO)/2
        IF(XA(K).GT.X)THEN
          KHI=K
        ELSE
          KLO=K
        ENDIF
      GOTO 1
      ENDIF
      H=XA(KHI)-XA(KLO)
c
c     This 'IF' line was commented in July, 2019:
c
ccc      IF (H.EQ.0.d+0) PAUSE 'Bad XA input at function DSPLIN13...'
c
c     This 3 lines with 'IF' are instead of old line (see just above):
c
      IF (H.EQ.0.d+0) THEN
      PRINT*,'Bad XA input at function DSPLIN13...'
      ENDIF
c
      A=(XA(KHI)-X)/H
      B=(X-XA(KLO))/H
      Y=A*YA(KLO)+B*YA(KHI)+
     *      ((A*A*A-A)*Y2A(KLO)+(B*B*B-B)*Y2A(KHI))*(H*H)/6.d+0
      Y1 = Y
      DSPLIN13 = Y1
                      if ((Y1.ge.1.d-10).OR.(Y1.lt.-1.1001d+1)) then
      print*,'DSPLIN13 ERR: IN =',X1,'(MAX=',XA(N),'), OUT=',Y1
                       endif
      RETURN
      END
****************************************************************************
* P.20_3
      SUBROUTINE getvpa3(emw,vbr,itr)
*
       external c_pa_in3,dsplin13,getcdp3,comp3
       parameter (lo=1)
       parameter (len=1)
       real*8 c_pa_in3,tot_pa,ai1,dsplin13,ax,algemin,arn
       real*4 emw,vbr
       integer itr
       common /general3/ emin,vmin,emph
       common/sok333/ tot_pa
       common /mcef3/ mcb1,mcb2,mcp1,mcp2,mcn1,mcn2,mce1,mce2
        mcp1 = mcp1 + 1
          if (itr.eq.0) then
          algemin = dble(emin/emw)
          else
          algemin = dble(amax1(vmin,2.044e-3/emw))
          endif
        ai1 = c_pa_in3(algemin)
        algemin = tot_pa - ai1
  155   arn = rndm_mum(5)
        mcp2 = mcp2 + 1
        ax = (algemin * arn) + ai1
          if (ax.gt.tot_pa) ax = tot_pa
        ax = dsplin13(ax)
          if (ax.ge.-1.d-5) ax = -1.d-5
        ay = sngl(ax)
c
        if (vmin.le.8.e-4) then
        az = (1.e+1)**ay
        echeck = az * emw
        if (echeck.ge.6.5e-3) then
        y1 = getcdp3(emw,ay,lo)
        else
        y1 = pair_tot3(emw,az)
        endif
        else
        y1 = getcdp3(emw,ay,lo)
        endif
c
        vbr = sngl(ax)
        y2 = comp3(vbr)
        arn = rndm_mum(8)
        yc = y2 * sngl(arn)
        if (y1.ge.yc) then
        vbr = (1.e+1)**ay
        else
        goto 155
        endif
      return
      end
****************************************************************************
************************* PHOTONUCLEAR SUBROUTINES : ***********************
****************************************************************************
* N.1_3
*
      real*8 function phnu3(z,en,rnu,a)
      real*8 z,en,rnu,a,rnu1
      real*8 alfa,rm_e,rm_mu,r_e,fact,avog,m1,m2,mn,s,sigma,t,hv,zet
      real*8 te1,te2,te3,g,etr
      integer iqcd,ilep
      common /qcd3/ iqcd
      common /what_lep3/ ilep
      common /pnsig3/ ibb
      common /exer13/ fa
      common /const3/ alfa,rm_e,rm_mu,r_e,avog
c GeV^2:
      parameter (m1 = 5.4d-1)
c GeV^2:
      parameter (m2 = 1.8d+0)
c Nucleon mass (Gev) = (Mp + Mn) / 2:
      parameter (mn = .939d+0)
c fact = alfa / (8 * pi):
      parameter (fact = 2.903524525d-4)
      rnu1 = 1.d+0 - rnu
      etr = rnu * en
      s = etr * 2.d+0 * mn
       if (ibb.eq.1) then
        sigma = 1.143d+2 + 1.647d+0 * ((dlog(2.13d-2 * etr))**2.d+0)
c       it is Sigma_gamma_p parametrization from Bezrukov-Bugaev
       else
        sigma = (6.35d+1 * (s**9.7d-2)) + (1.45d+2 / (s**5.d-1))
c       it is Sigma_gamm_p parametrization from ZEUS (J.Breitweg
c       et al., hep-ex/9809005, Eur.Phys.J., C7 (1999) 609)
       endif
      sigma = sigma * 1.d-30
      t = (rm_mu * rm_mu * 1.d-6 * rnu * rnu) / rnu1
      hv = 1.d+0 - (2.d+0 / rnu) + (2.d+0 / (rnu * rnu))
      zet = 2.82d-3 * sigma * 1.d+30 * (a**(1.d+0 / 3.d+0))
c upgrade BB formula: =========>
c      te1 = hv * dlog(1.d+0 + (m2/t))
      te1 = (hv + ((2.d-6*rm_mu*rm_mu)/(m2))) * dlog(1.d+0 + (m2/t))
c =============================>
      if(t.gt.1.d-7) then
      te2 = 1.d+0 - ((.25d+0 * m2/t) * dlog(1.d+0 + (t/m2)))
      te2 = te2 * 2.d+0 * rm_mu * rm_mu * 1.d-6 / t
      else
      te2 = (1.5d+0 / t) * rm_mu * rm_mu * 1.d-6
      endif
      te3 = (dlog(1.d+0 + (m1/t)) - (m1/(m1 + t))) * hv
c upgrade BB formula: =========>
c      te3=te3-((2.d+0*rm_mu*rm_mu*1.d-6/t)*(1.d+0-((.25d+0*m1)/(m1+t))))
      te3=te3-((2.d+0*rm_mu*rm_mu*1.d-6/t)*
     &                            (1.d+0-((.25d+0*m1-t)/(m1+t))))
      te3=te3+(((4.d-6*rm_mu*rm_mu)/(m1))*dlog(1.d+0+((m1)/t)))
c =============================>
      g = ( (1.d+0 + zet) * dexp(-zet) ) - 1.d+0
      g = ( ( g / (zet * zet) ) + 5.d-1 ) * ( 9.d+0 / zet )
      if(z.lt.1.5d+0) g = 3.d+0  !-------------> Special case for hydrogen
      phnu3 = te1 - te2 + (g * te3)
      phnu3 = phnu3 * fact * rnu * sigma * a * dble(fa)
c=================> QCD-corrections:
      IF(iqcd.EQ.1) THEN
        dops = QCD_C3(SNGL(rnu),SNGL(en)) * fa * SNGL(a)
        IF(dops.GE.0.) phnu3 = phnu3 + ((1.D-30 * DBLE(dops)) / rnu)
      ENDIF
c=================>
      IF (phnu3.LT.0.D+0) phnu3 = 0.D+0
      return
      end
****************************************************************************
* N.1a3
*
      SUBROUTINE QCD_CORR3
*
* Computes QCD corrections for photonuclear interaction as was developed
* by E.Bugaev & Yu.Shlepin, put them in arrays COR_MU and COR_TAU, then
*    computes splain coefficients (array C(730) in common /qcd_new/ )
*
      DOUBLE PRECISION A_MU(8,7),A_TAU(8,7),COR_MU(71,8),COR_TAU(71,8)
      DOUBLE PRECISION V, V1, CORR_MU, CORR_TAU, SL_MU, SL_TAU
      DIMENSION F(71,8),D(90,27),C(730)
      COMMON /what_lep3/ ilep
      COMMON /qcd_new3/ C
      DATA NX /71/
      DATA NY /8/
c
c Coefficients for MU (from Bugaev-Shlepin, October 2002 & March 2003):
c                 computed for standard rock (A=22)
c
c     muon, 10^3 GeV
c
      A_MU(1, 1) = 0.0157837D+0
      A_MU(2, 1) = -5.3593D+0
      A_MU(3, 1) = -6.47286D+0
      A_MU(4, 1) = -3.64846D+0
      A_MU(5, 1) = -1.1501D+0
      A_MU(6, 1) = -0.205223D+0
      A_MU(7, 1) = -0.0192542D+0
      A_MU(8, 1) = -0.000735492D+0
c
c     muon, 10^4 GeV
c
      A_MU(1, 2) = 0.0376904D+0
      A_MU(2, 2) = -12.6647D+0
      A_MU(3, 2) = -15.0953D+0
      A_MU(4, 2) = -8.41549D+0
      A_MU(5, 2) = -2.63226D+0
      A_MU(6, 2) = -0.467407D+0
      A_MU(7, 2) = -0.0437325D+0
      A_MU(8, 2) = -0.00166849D+0
c
c     muon, 10^5 GeV
c
      A_MU(1, 3) = 0.0898107D+0
      A_MU(2, 3) = -34.1874D+0
      A_MU(3, 3) = -44.0928D+0
      A_MU(4, 3) = -26.5711D+0
      A_MU(5, 3) = -8.87342D+0
      A_MU(6, 3) = -1.66224D+0
      A_MU(7, 3) = -0.162793D+0
      A_MU(8, 3) = -0.00647547D+0
c
c     muon, 10^6 GeV
c
      A_MU(1, 4) = 0.189826D+0
      A_MU(2, 4) = -71.5287D+0
      A_MU(3, 4) = -87.9917D+0
      A_MU(4, 4) = -51.2985D+0
      A_MU(5, 4) = -16.7509D+0
      A_MU(6, 4) = -3.08549D+0
      A_MU(7, 4) = -0.297893D+0
      A_MU(8, 4) = -0.0116941D+0
c
c     muon, 10^7 GeV
c
      A_MU(1, 5) = 0.273715D+0
      A_MU(2, 5) = -131.49D+0
      A_MU(3, 5) = -150.811D+0
      A_MU(4, 5) = -85.5305D+0
      A_MU(5, 5) = -27.9549D+0
      A_MU(6, 5) = -5.21569D+0
      A_MU(7, 5) = -0.511526D+0
      A_MU(8, 5) = -0.0203833D+0
c
c     muon, 10^8 GeV
c
      A_MU(1, 6) = 0.48501D+0
      A_MU(2, 6) = -208.904D+0
      A_MU(3, 6) = -221.255D+0
      A_MU(4, 6) = -124.006D+0
      A_MU(5, 6) = -41.4446D+0
      A_MU(6, 6) = -7.95112D+0
      A_MU(7, 6) = -0.798525D+0
      A_MU(8, 6) = -0.0324086D+0
c
c     muon, 10^9 GeV
c
      A_MU(1, 7) = 0.710326D+0
      A_MU(2, 7) = -306.442D+0
      A_MU(3, 7) = -316.191D+0
      A_MU(4, 7) = -185.205D+0
      A_MU(5, 7) = -64.8621D+0
      A_MU(6, 7) = -12.8027D+0
      A_MU(7, 7) = -1.30405D+0
      A_MU(8, 7) = -0.0532388D+0
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c      DATA (A_MU(J, 1),J=1,8) /  !        muon, 10^3 GeV
c     & 0.0157837D+0, -5.3593D+0, -6.47286D+0, -3.64846D+0,  -1.1501D+0,
c     & -0.205223D+0, -0.0192542D+0, -0.000735492D+0 /
c
c      DATA (A_MU(J, 2),J=1,8) /  !        muon, 10^4 GeV
c     & 0.0376904D+0, -12.6647D+0, -15.0953D+0, -8.41549D+0, -2.63226D+0,
c     & -0.467407D+0, -0.0437325D+0, -0.00166849D+0 /
c
c      DATA (A_MU(J, 3),J=1,8) /  !        muon, 10^5 GeV
c     & 0.0898107D+0, -34.1874D+0, -44.0928D+0, -26.5711D+0, -8.87342D+0,
c     & -1.66224D+0, -0.162793D+0, -0.00647547D+0 /
c
c      DATA (A_MU(J, 4),J=1,8) /  !        muon, 10^6 GeV
c     & 0.189826D+0, -71.5287D+0, -87.9917D+0, -51.2985D+0, -16.7509D+0,
c     & -3.08549D+0, -0.297893D+0, -0.0116941D+0 /
c
c      DATA (A_MU(J, 5),J=1,8) /  !        muon, 10^7 GeV
c     & 0.273715D+0, -131.49D+0, -150.811D+0, -85.5305D+0, -27.9549D+0,
c     & -5.21569D+0, -0.511526D+0, -0.0203833D+0 /
c
c      DATA (A_MU(J, 6),J=1,8) /  !        muon, 10^8 GeV
c     & 0.48501D+0, -208.904D+0, -221.255D+0, -124.006D+0, -41.4446D+0,
c     & -7.95112D+0, -0.798525D+0, -0.0324086D+0 /
c
c      DATA (A_MU(J, 7),J=1,8) /  !        muon, 10^9 GeV
c     & 0.710326D+0, -306.442D+0, -316.191D+0, -185.205D+0, -64.8621D+0,
c     & -12.8027D+0, -1.30405D+0, -0.0532388D+0 /
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c Coefficients for TAU (from Bugaev-Shlepin, October 2002 & March 2003):
c                 computed for standard rock (A=22)
c
c
c     tau, 10^3 GeV
c
      A_TAU(1, 1) = -0.00279225D+0
      A_TAU(2, 1) = -0.343867D+0
      A_TAU(3, 1) = 1.03267D+0
      A_TAU(4, 1) = 1.17448D+0
      A_TAU(5, 1) = 0.492829D+0
      A_TAU(6, 1) = 0.102496D+0
      A_TAU(7, 1) = 0.0106092D+0
      A_TAU(8, 1) = 0.000436414D+0
c
c     tau, 10^4 GeV
c
      A_TAU(1, 2) = -0.00625653D+0
      A_TAU(2, 2) = -0.789706D+0
      A_TAU(3, 2) = 2.55848D+0
      A_TAU(4, 2) = 2.88145D+0
      A_TAU(5, 2) = 1.20912D+0
      A_TAU(6, 2) = 0.252265D+0
      A_TAU(7, 2) = 0.0262464D+0
      A_TAU(8, 2) = 0.00108684D+0
c
c     tau, 10^5 GeV
c
      A_TAU(1, 3) = -0.0126754
      A_TAU(2, 3) = -1.70908
      A_TAU(3, 3) = 6.74136
      A_TAU(4, 3) = 7.50275
      A_TAU(5, 3) = 3.18879
      A_TAU(6, 3) = 0.679863
      A_TAU(7, 3) = 0.072661
      A_TAU(8, 3) = 0.00310106
c
c     tau, 10^6 GeV
c
      A_TAU(1, 4) = -0.0262998D+0
      A_TAU(2, 4) = -3.46225D+0
      A_TAU(3, 4) = 15.4908D+0
      A_TAU(4, 4) = 16.5646D+0
      A_TAU(5, 4) = 6.86187D+0
      A_TAU(6, 4) = 1.43318D+0
      A_TAU(7, 4) = 0.150554D+0
      A_TAU(8, 4) = 0.0063314D+0
c
c     tau, 10^7 GeV
c
      A_TAU(1, 5) = -0.0289825D+0
      A_TAU(2, 5) = -5.98402D+0
      A_TAU(3, 5) = 31.6914D+0
      A_TAU(4, 5) = 31.3704D+0
      A_TAU(5, 5) = 12.2688D+0
      A_TAU(6, 5) = 2.44171D+0
      A_TAU(7, 5) = 0.246202D+0
      A_TAU(8, 5) = 0.00999873D+0
c
c     tau, 10^8 GeV
c
      A_TAU(1, 6) = -2.13163D-13
      A_TAU(2, 6) = -9.2095D+0
      A_TAU(3, 6) = 55.7338D+0
      A_TAU(4, 6) = 50.2693D+0
      A_TAU(5, 6) = 18.3936D+0
      A_TAU(6, 6) = 3.49729D+0
      A_TAU(7, 6) = 0.343508D+0
      A_TAU(8, 6) = 0.0138178D+0
c
c     tau, 10^9 GeV
c
      A_TAU(1, 7) = -1.42109D-13
      A_TAU(2, 7) = -17.6991D+0
      A_TAU(3, 7) = 70.7923D+0
      A_TAU(4, 7) = 56.0714D+0
      A_TAU(5, 7) = 17.7885D+0
      A_TAU(6, 7) = 2.95729D+0
      A_TAU(7, 7) = 0.258242D+0
      A_TAU(8, 7) = 0.00942025D+0
ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c      DATA (A_TAU(J, 1),J=1,8) / !        tau, 10^3 GeV
c     & -0.00279225D+0, -0.343867D+0, 1.03267D+0, 1.17448D+0,
c     &  0.492829D+0, 0.102496D+0, 0.0106092D+0, 0.000436414D+0 /
c
c      DATA (A_TAU(J, 2),J=1,8) / !        tau, 10^4 GeV
c     & -0.00625653D+0, -0.789706D+0, 2.55848D+0, 2.88145D+0,
c     &  1.20912D+0, 0.252265D+0, 0.0262464D+0, 0.00108684D+0 /
c
c      DATA (A_TAU(J, 3),J=1,8) / !        tau, 10^5 GeV
c     & -0.0126754, -1.70908, 6.74136, 7.50275, 3.18879,
c     & 0.679863, 0.072661, 0.00310106 /
c
c      DATA (A_TAU(J, 4),J=1,8) / !        tau, 10^6 GeV
c     & -0.0262998D+0, -3.46225D+0, 15.4908D+0, 16.5646D+0, 6.86187D+0,
c     & 1.43318D+0, 0.150554D+0, 0.0063314D+0 /
c
c      DATA (A_TAU(J, 5),J=1,8) / !        tau, 10^7 GeV
c     & -0.0289825D+0, -5.98402D+0, 31.6914D+0, 31.3704D+0, 12.2688D+0,
c     &  2.44171D+0, 0.246202D+0, 0.00999873D+0 /
c
c      DATA (A_TAU(J, 6),J=1,8) / !        tau, 10^8 GeV
c     & -2.13163D-13, -9.2095D+0, 55.7338D+0, 50.2693D+0, 18.3936D+0,
c     &  3.49729D+0, 0.343508D+0, 0.0138178D+0 /
c
c      DATA (A_TAU(J, 7),J=1,8) / !        tau, 10^9 GeV
c     & -1.42109D-13, -17.6991D+0, 70.7923D+0, 56.0714D+0, 17.7885D+0,
c     &  2.95729D+0, 0.258242D+0, 0.00942025D+0 /
ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c       Bugaev's data are down to 10^3 GeV. We artifically assign
c   "correction=0" for 10^2 GeV to enlarge interpolation energy range:
c
      DO I=1,71
        COR_MU(I,1)  = 0.D+0
        COR_TAU(I,1) = 0.D+0
      ENDDO
c
c   Bugaev's corrections work for v > 10^(-6). We artifically assign
c   "correction = 0" for V = 10^-7 to enlarge interpolation V range.
c       To make sure we also set to zero corrections for V = 1 :
c
      DO I=1,8
        COR_MU(1,I)   = 0.D+0
        COR_TAU(1,I)  = 0.D+0
        COR_MU(71,I)  = 0.D+0
        COR_TAU(71,I) = 0.D+0
      ENDDO
c
c  We compute corrections for 7 energies (10^3 GeV - 10^9 GeV) and
c        10^(-6) =< V < 1 using Bugaev-Shlepin formula
c
c                                 7
c           v (d_sigma / d_v) = S U M (a_k * (alog10(v))**k)
c                                k=0
c
c with coefficients for mu and tau as given in DATA for A_MU and A_TAU:
c
      DO I=2,8
        M = I - 1
          DO J=11,70
            V = 1.D-1 * DBLE(J - 71)
            V1 = 1.D+1**V
            CORR_MU  = 0.D+0
            CORR_TAU = 0.D+0
              DO J1=1,8
              CORR_MU=CORR_MU+(A_MU(J1,M)*(DLOG10(V1))**(DBLE(J1-1)))
              CORR_TAU=CORR_TAU+(A_TAU(J1,M)*(DLOG10(V1))**(DBLE(J1-1)))
              ENDDO
            COR_MU(J,I)  = CORR_MU
            COR_TAU(J,I) = CORR_TAU
          ENDDO
      ENDDO
c
c For v range 10^(-7) -- 10^(-6) we are making a linear interpolation
c    (below V = 10^(-7) all the corrections will be equal to zero):
c
      DO I=2,8
        SL_MU  = COR_MU(11,I) / 1.D+1
        SL_TAU = COR_TAU(11,I) / 1.D+1
          DO K=2,10
            COR_MU(K,I)  = SL_MU * DBLE(K-1)
            COR_TAU(K,I) = SL_TAU * DBLE(K-1)
          ENDDO
      ENDDO
c
c NOW ALL THE CORRECTIONS EXPRESSED IN [ub] for v (d_sigma / d_v)
c     FOR A=22  ARE IN ARRAYS COR_MU(71,8) AND COR_TAU(71,8)
c
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c FILLING ARRAY F(71,8) EITHER BY MU OR TAU CORRECTIONS TO COOK SPLAINS
c      TRANSFORMING TO LOG10 TO GET BETTER INTERPOLATION QUALITY
c         AND DIVIDING BY 22 TO GET CORRECTIONS FOR 1 NUCLEON:
c
      DO I=1,71
        DO J=1,8
          IF(ilep.EQ.1) THEN
            F(I,J) = SNGL(COR_MU(I,J)) / 22.
          ELSE
            F(I,J) = SNGL(COR_TAU(I,J)) / 22.
          ENDIF
        ENDDO
      ENDDO
c
c                        COOKING SPLAINS:
c
      DO 1 J=1,NY
      J2=J+2
      DO 1 I=1,NX
      I2=I+2
1     D(I2,J2)=3.90625E-3*F(I,J)
      J1=NY+1
      J3=J2+1
      J4=J3+1
      DO 2 I=3,I2
      A=D(I,3)
      B=D(I,4)
      D(I,2)=3.*(A-B)+D(I,5)
      D(I,1)=3.*(D(I,2)-A)+B
      A=D(I,J1)
      B=D(I,J2)
      D(I,J3)=3.*(B-A)+D(I,NY)
2     D(I,J4)=3.*(D(I,J3)-B)+A
      I1=NX+1
      I3=I2+1
      I4=I3+1
      DO 3 J=1,J4
      A=D(3,J)
      B=D(4,J)
      D(2,J)=3.*(A-B)+D(5,J)
      D(1,J)=3.*(D(2,J)-A)+B
      A=D(I1,J)
      B=D(I2,J)
      D(I3,J)=3.*(B-A)+D(NX,J)
3     D(I4,J)=3.*(D(I3,J)-B)+A
      DO 4 J=1,J2
      J3=J+1
      J4=J+2
      M=(J-1)*I2
      DO 4 I=1,I2
      I3=I+1
      I4=I+2
4     C(M+I)=D(I,J)+D(I,J4)+D(I4,J)+D(I4,J4)+D(I3,J3)*
     *100.-(D(I3,J)+D(I,J3)+D(I4,J3)+D(I3,J4))*10.
c
      RETURN
      END
************************************************************************
* N.1b3
*
      FUNCTION QCD_C3(X1,Y1)
*
* Returns QCD correction for PN according to Bugaev & Shlepin by
*    interpolation using splains prepared by QCD_CORR routine.
*
* INPUT: X1 -> relative energy transfer 10^(-10) < V < 1.
*        Y1 -> lepton energy [GeV]       1. < E < 1.E+9
*
*
* OUTPUT QCD_C  -> QCD-correction for PN crosssection [ub] for
*                  v * (d_sigma / d_v) per 1 nucleon
*
      REAL*4 X1,Y1
      DIMENSION C(730)
      COMMON /qcd_new3/ C
      DATA NX /71/
      DATA NY /8/
      DATA X0 /-7./
      DATA SX /.1/
      DATA Y0 /2./
      DATA SY /1./
c
      IF(Y1.LT.1.E+2) THEN
        QCD_C3 = 0.E+0
        RETURN
      ENDIF
      IF(X1.LT.1.E-7) THEN
        QCD_C3 = 0.E+0
        RETURN
      ENDIF
c
      X = ALOG10(X1)
      Y = ALOG10(Y1)
c
      A3=(X-X0)/SX
      B3=(Y-Y0)/SY
      M1=INT(A3+.5)
      M2=INT(B3+.5)
      M3=NX+2
      IF(M1.LT.0.OR.M1.GE.NX.OR.M2.LT.0.OR.M2.GE.NY) PRINT 1,X,M1,Y,M2
      A3=A3-M1
      B3=B3-M2
      M1=M2*M3+M1+1
      M2=M1+M3
      M3=M2+M3
      A2=A3**2+.25
      B2=B3**2+.25
      A1=A2-A3
      B1=B2-B3
      A3=A2+A3
      B3=B2+B3
      A2=2.-(A2+A2)
      B2=2.-(B2+B2)
      QCD_C3=(A1*C(M1)+A2*C(M1+1)+A3*C(M1+2))*B1
     2      +(A1*C(M2)+A2*C(M2+1)+A3*C(M2+2))*B2
     3      +(A1*C(M3)+A2*C(M3+1)+A3*C(M3+2))*B3
c
      RETURN
1     FORMAT('*MISTAKE IN QCD* X=',D23.16,'MX=',I4,'Y=',D23.16,'MY=',I4)
      END
****************************************************************************
* N.2_3
*
       function phnu_tot3(ene,v)
       external phnu3
       real*8 z1(10),w(10),aw(10),a_ef,en,rnu,h1,phnu3,ro
       real*4 ene,v
       integer nsub
       common /media3/ z1,w,aw,a_ef,ro,nsub
       if (v.gt..999998) v = .999998
       en = dble(ene)
       rnu = dble(v)
           h1 = w(1) * phnu3(z1(1),en,rnu,aw(1))
         if (nsub.ge.2) then
           do l=2,nsub
             h1 = h1 + (w(l) * phnu3(z1(l),en,rnu,aw(l)))
           enddo
         endif
       phnu_tot3 = sngl(h1)
       return
       end
****************************************************************************
* N.3_3
*
       subroutine phnu13
*
       external phnu_tot3,dsimps
       real*8 dsimps
       real*8 aux1(0:2000),aux2(0:2000),h1,h2
       real*8 alfa,rm_e,rm_mu,r_e,avog,z1(10),w(10),aw(10),a_ef,ro
       common /const3/ alfa,rm_e,rm_mu,r_e,avog ! from initial subroutine
       common /media3/ z1,w,aw,a_ef,ro,nsub     !       MED_CONSS
       common /general3/ emin,vmin,emph         !
       common /cdph_in3/ fcd1(81,54),fcd2(81,101),fcd3(81,51)
       common /ctph_in13/ crt_ph1(17),crt_ph2(65)
       common /elph_in13/ elo_ph1(17),elo_ph2(65)
       common /elph_in23/ elo_ph3(17)
       common /elph_in43/ elo_ph4(17)
       common /ph_ref3/ at,bt,us2,us2_1,us3,us4,at0
       common /pnsig3/ ibb
       common /help_13/ aux1,aux2
c   ....................................................................
c      1.PREPARATION OF ARRAYS WITH DIFF. CROSS-SEECTIONS FOR MUON
c                         PHOTONUCLEAR INTERACTION:
c
c                !       ..........................
      do j=1,81  !--->   j CYCLE BY ENERGIES starts
c                !       ..........................
        en = float(j)
        en = 1.e+1**(9.e-1 + (1.e-1 * en))
c                     !         ..................................
      do k=1,206      !--->     k CYCLE BY ENERGY TRANSFERS starts
c                     !         ..................................
      if (k.eq.206) then
        rnu = 1.e+0
        fcd2(j,101) = phnu_tot3(en,rnu)
        if (fcd2(j,101).le.1.e-37) fcd2(j,101) = 1.e-37
        fcd2(j,101) = alog(fcd2(j,101))
        goto 975
      endif
c
      if (k.le.54) then
         k01 = k - 1
         rnu = 1.e+1**(float(k01) * 2.e-1 - 1.1e+1)
      else
         if (k.le.105) then
           k01 = k - 55
           rnu = 1.e+1**(float(k01) * 1.e-2 - 6.e-1)
         else
           k01 = k - 106
           rnu = 1.e+1**(float(k01) * 1.e-3 - 1.e-1)
         endif
      endif
c
      cr_dif=phnu_tot3(en,rnu)
      if (cr_dif.le.1.e-37) cr_dif = 1.e-37
      cr_dif=alog(cr_dif)
c
      if (k.le.54) fcd1(j,k) = cr_dif
      if ((k.gt.54).AND.(k.lt.106)) fcd3(j,k-54) = cr_dif
      if (k.ge.106) fcd2(j,k-105) = cr_dif
c
 975  continue
c              !     .....................................
      enddo    !----> k CYCLE BY ENERGY TRANSFERS finishes
c              !     .....................................
      enddo    !----> j CYCLE BY ENERGIES finishes
c              !     ....................................
c   ....................................................................
c      2.PREPARATION OF ARRAYS WITH ENERGY LOSSES AND MEAN FREE PATH
c                     FOR MUON PHOTONUCLEAR INTERACTION:
c
c                       a) Energy transfers > EMIN :
      lim = 2000
      do i=1,17
      en = float(i)
      en = (1.e+1)**(5.e-1 + (5.e-1 * en))
      vmi1 = alog(emin / en)
      vmi2 = alog(emph / en)
      vmi = amax1(vmi1,vmi2) !-----------> The lower limit for integration
      vma = 0.e+0            !-----------> The upper limit for integration
      vst = (vma - vmi) / float(lim) !---> Step for a rel. en. transfers grid
c
      do j=0,lim
      rnu = vmi + vst*(float(j))
      rnu = exp(rnu)
      aux1(j) = dble(phnu_tot3(en,rnu) * rnu)      !-> array to be integrated
c                                                  !   to get mean free path
      aux2(j) = aux1(j) * dble(rnu)                !-> array to be integrated
      enddo                                        !   for getting en. losses
c
      h1 = dble(vmi)
      h2 = dble(vma)
      crt_ph1(i) = sngl(dsimps(aux1,h1,h2,lim))        !-> array with 17 values
      crt_ph1(i) = sngl(a_ef / (avog * ro))/crt_ph1(i) ! of mean free path
      crt_ph1(i) = alog(crt_ph1(i))                    !
      elo_ph1(i) = sngl( dsimps(aux2,h1,h2,lim) * avog * ro / a_ef )
      elo_ph1(i) = elo_ph1(i) * en * 1.e+3
      elo_ph1(i) = alog10(elo_ph1(i)) !-> array with 17 values of en. losses
      enddo
c                       b) Energy transfers > VMIN :
      do i=1,65
      en = float(i)
      en = (1.e+1)**(8.75e-1 + (1.25e-1 * en))
      vmi1 = alog(vmin)
      vmi2 = alog(emph / en)
      vmi = amax1(vmi1,vmi2) !---------> The lower limit for integration
      vma = 0.e+0            !---------> The upper limit for integration
      vst = (vma - vmi) / float(lim) !-> Step for a rel. en. transfers grid
c
      do j=0,lim
      rnu = vmi + vst*(float(j))
      rnu = exp(rnu)
      aux1(j) = dble(phnu_tot3(en,rnu) * rnu)   !-> array to be integrated
c                                               !   to get mean free path
      aux2(j) = aux1(j) * dble(rnu)             !-> array to be integrated
      enddo                                     !   for getting en. losses
c
      h1 = dble(vmi)
      h2 = dble(vma)
      crt_ph2(i) = sngl(dsimps(aux1,h1,h2,lim))       !->array with 17 values
      crt_ph2(i) = sngl(a_ef / (avog * ro))/crt_ph2(i)! of mean free path
      elo_ph2(i) = sngl( dsimps(aux2,h1,h2,lim) * avog * ro / a_ef )
      elo_ph2(i) = elo_ph2(i) * en * 1.e+3
      if(elo_ph2(i).le.0.e+0) elo_ph2(i) = 1.e-8
      elo_ph2(i) = alog10(elo_ph2(i)) !-> array with 17 values of en. losses
      enddo
c                       c) Energy transfers > 0 :
      do i=1,17
      en = float(i)
      en = (1.e+1)**(5.e-1 + (5.e-1 * en))
      vmi = alog(emph / en)  !-----------> The lower limit for integration
      vma = 0.e+0            !-----------> The upper limit for integration
      vst = (vma - vmi) / float(lim) !---> Step for a rel. en. transfers grid
c
      do j=0,lim
      rnu = vmi + vst*(float(j))
      rnu = exp(rnu)
      aux2(j) = dble(phnu_tot3(en,rnu) * rnu * rnu) !-> array to be integrated
c                                                  !   to get en. losses
      enddo
c
      h1 = dble(vmi)
      h2 = dble(vma)
      elo_ph3(i) = sngl( dsimps(aux2,h1,h2,lim) * avog * ro / a_ef )
      elo_ph3(i) = elo_ph3(i) * en * 1.e+3
      if(elo_ph3(i).le.0.e+0) elo_ph3(i) = 1.e-8
      elo_ph3(i) = alog10(elo_ph3(i)) !-> array with 17 values of en. losses
      enddo
c                       d) Energy transfers < EMIN :
      do i=1,17
      en = float(i)
      en = (1.e+1)**(5.e-1 + (5.e-1 * en))
      vmi = alog(emph / en)  !-----------> The lower limit for integration
      vma = alog(emin / en)          !---> The upper limit for integration
      vst = (vma - vmi) / float(lim) !---> Step for a rel. en. transfers grid
      if (vma.le.vmi) then
      elo_ph4(i) = 0.
      goto 1234
      endif
c
      do j=0,lim
      rnu = vmi + vst*(float(j))
      rnu = exp(rnu)
      aux2(j) = dble(phnu_tot3(en,rnu) * rnu * rnu) !-> array to be integrated
c                                                  !   to get en. losses
      enddo
c
      h1 = dble(vmi)
      h2 = dble(vma)
      elo_ph4(i) = sngl( dsimps(aux2,h1,h2,lim) * avog * ro / a_ef )
      elo_ph4(i) = elo_ph4(i) * en * 1.e+3 !-> array with 17 values
 1234 continue                             !   of en. losses
      enddo
c   ....................................................................
c          3. COMPUTING OF CONSTANTS FOR COMPARISON FUNCTION:
c
       if(ibb.eq.1) then
         en1 = 1.e+9
         en2 = 10.
         v1 = 1.78e-2
         v2 = 1.e-10
         bt = alog10(phnu_tot3(en2,v2)) - alog10(phnu_tot3(en1,v1))
         bt = bt / (alog10(v1/v2))
       else
         en1 = 1000.
         en2 = 100.
         v1 = 2.e-4
         v2 = 2.e-3
         bt = alog10(phnu_tot3(en1,v1)) - alog10(phnu_tot3(en2,v2))
       endif
      if(rm_mu.le.1.d+3) then
      at = 1.05 * (v2**bt) * phnu_tot3(en2,v2)
      else
      at = 1.25 * (v2**bt) * phnu_tot3(en2,v2)
      endif
      at0 = at
      us2 = at / (1.-bt)
      us2_1 = 1. / us2
      us3 = .434294481 / (1. - bt)
      us4 = 2.302585093 * (-bt)
      return
      end
****************************************************************************
* N.4_3
            FUNCTION getlphnu3(X)
*
      real*4 X
      COMMON /sok13/ XMIN,STEP,XMAX
      common /sok1_n3/ C(19)
      X1 = alog10(X)
      if ((X1.lt..99999e+0).or.(X1.gt.9.0001e+0)) then
      print*,'ERROR IN FUNCTION GETLPHNUS: MUON ENERGY IS OUT OF RANGE'
      endif
      Y = (X1-XMIN)/STEP
      I = INT(Y+0.5)
      IF(I.LT.0.OR.X1.GT.XMAX) PRINT 1,X1,XMIN,XMAX
      Y = Y-I
      Z = Y*Y + 0.25
      getlphnu3 = (Z-Y)*C(I+1) + (2.-(Z+Z))*C(I+2) + (Z+Y)*C(I+3)
      getlphnu3 = exp(getlphnu3)
      RETURN
1     FORMAT('*MISTAKE*X1=',D23.16,'XMIN=',D23.16,'XMAX=',D23.16)
      END
****************************************************************************
* N.5_3
            FUNCTION glphnuv3(X)
*
      real*4 X
      COMMON /sok1n3/ XMIN,STEP,XMAX
      common /sok1_n23/ C(67)
      X1 = alog10(X)
      if ((X1.lt..99999e+0).or.(X1.gt.9.0001e+0)) then
      print*,'ERROR IN FUNCTION GLPHNUVS: MUON ENERGY IS OUT OF RANGE'
      endif
      Y = (X1-XMIN)/STEP
      I = INT(Y+0.5)
      IF(I.LT.0.OR.X1.GT.XMAX) PRINT 1,X1,XMIN,XMAX
      Y = Y-I
      Z = Y*Y + 0.25
      glphnuv3 = (Z-Y)*C(I+1) + (2.-(Z+Z))*C(I+2) + (Z+Y)*C(I+3)
      RETURN
1     FORMAT('*MISTAKE*X1=',D23.16,'XMIN=',D23.16,'XMAX=',D23.16)
      END
****************************************************************************
* N.6_3
         function getctph3(u)
*
      external getlphnu3
      real*8 z1(10),w(10),aw(10),a_ef,alfa,rm_e,rm_mu,r_e,avog,ro
      real*4 u
      common /const3/ alfa,rm_e,rm_mu,r_e,avog
      common /media3/ z1,w,aw,a_ef,ro,nsub
      if ((u.gt.1.0001e+9).or.(u.lt.9.9999e+0)) then
      print*,'ERROR IN FUNCTION GETCTPHS: MUON ENERGY IS OUT OF RANGE'
      endif
      aef = sngl(a_ef / (avog * ro))
      getctph3 = aef / getlphnu3(u)
      return
      end
****************************************************************************
* N.7_3
         function gctphv3(u)
*
      external glphnuv3
      real*8 z1(10),w(10),aw(10),a_ef,alfa,rm_e,rm_mu,r_e,avog,ro
      real*4 u
      common /const3/ alfa,rm_e,rm_mu,r_e,avog
      common /media3/ z1,w,aw,a_ef,ro,nsub
      if ((u.gt.1.0001e+9).or.(u.lt.9.9999e+0)) then
      print*,'ERROR IN FUNCTION GCTPHVS: MUON ENERGY IS OUT OF RANGE'
      endif
      aef = sngl(a_ef / (avog * ro))
      gctphv3 = aef / glphnuv3(u)
      return
      end
************************************************************************
* N.8_3
              FUNCTION getdedph3(X)
*
      real*4 X
      COMMON /sok53/ XMIN,STEP,XMAX
      common /sok5_n3TTT/ C(19)
      X1 = alog10(X)
       if ((X1.lt..99999e+0).or.(X1.gt.9.0001e+0)) then
       print*,'ERROR IN FUNCTION GETDEDPH: MUON ENERGY IS OUT OF RANGE'
       endif
      Y = (X1-XMIN)/STEP
      I = INT(Y+0.5)
      IF(I.LT.0.OR.X1.GT.XMAX) PRINT 1,X1,XMIN,XMAX
      Y = Y-I
      Z = Y*Y + 0.25
      getdedph3 = (Z-Y)*C(I+1) + (2.-(Z+Z))*C(I+2) + (Z+Y)*C(I+3)
      getdedph3 = (1.e+1)**(getdedph3)
      RETURN
1     FORMAT('*MISTAKE*X1=',D23.16,'XMIN=',D23.16,'XMAX=',D23.16)
      END
************************************************************************
* N.9_3
              FUNCTION gdedphv3(X)
*
      real*4 X
      COMMON /sok5n3/ XMIN,STEP,XMAX
      common /sok5_n23/ C(67)
      X1 = alog10(X)
       if ((X1.lt..99999e+0).or.(X1.gt.9.0001e+0)) then
       print*,'ERROR IN FUNCTION GDEDPHVS: MUON ENERGY IS OUT OF RANGE'
       endif
      Y = (X1-XMIN)/STEP
      I = INT(Y+0.5)
      IF(I.LT.0.OR.X1.GT.XMAX) PRINT 1,X1,XMIN,XMAX
      Y = Y-I
      Z = Y*Y + 0.25
      gdedphv3 = (Z-Y)*C(I+1) + (2.-(Z+Z))*C(I+2) + (Z+Y)*C(I+3)
      gdedphv3 = (1.e+1)**(gdedphv3)
      RETURN
1     FORMAT('*MISTAKE*X1=',D23.16,'XMIN=',D23.16,'XMAX=',D23.16)
      END
************************************************************************
* N.10_3
              FUNCTION gdedpht3(X)
*
      real*4 X
      COMMON /sok53/ XMIN,STEP,XMAX
      common /sok5_n33/ C(19)
      X1 = alog10(X)
       if ((X1.lt..99999e+0).or.(X1.gt.9.0001e+0)) then
       print*,'ERROR IN FUNCTION GDEDPHTS: MUON ENERGY IS OUT OF RANGE'
       endif
      Y = (X1-XMIN)/STEP
      I = INT(Y+0.5)
      IF(I.LT.0.OR.X1.GT.XMAX) PRINT 1,X1,XMIN,XMAX
      Y = Y-I
      Z = Y*Y + 0.25
      gdedpht3 = (Z-Y)*C(I+1) + (2.-(Z+Z))*C(I+2) + (Z+Y)*C(I+3)
      gdedpht3 = (1.e+1)**(gdedpht3)
      RETURN
1     FORMAT('*MISTAKE*X1=',D23.16,'XMIN=',D23.16,'XMAX=',D23.16)
      END
****************************************************************************
* N.11_3
       FUNCTION getcdn3(X,Y,lo)
*
       real*4 X,Y
       integer lo
       external getcdn13,getcdn23,getcdn33,phnu_tot3
       if (lo.eq.0) then
          if (Y.le..251188643) then
                getcdn3 = getcdn13(X,Y,lo)
               getcdn3 = exp(getcdn3)
          else
               if (Y.le..794328234) then
                  getcdn3 = getcdn23(X,Y,lo)
                  getcdn3 = exp(getcdn3)
               else
                 if (Y.le..965) then
                    getcdn3 = getcdn33(X,Y,lo)
                    getcdn3 = exp(getcdn3)
                 else
                    getcdn3 = phnu_tot3(X,Y)
                 endif
               endif
          endif
       else
          if (Y.le.-6.e-1) then
                getcdn3 = getcdn13(X,Y,lo)
                getcdn3 = exp(getcdn3)
          else
                if (Y.le.-1.e-1) then
                   getcdn3 = getcdn23(X,Y,lo)
                   getcdn3 = exp(getcdn3)
                else
                   if (Y.le.-1.54727e-2) then
                     getcdn3 = getcdn33(X,Y,lo)
                     getcdn3 = exp(getcdn3)
                   else
                     Y1 = (1.e+1)**Y
                     getcdn3 = phnu_tot3(X,Y1)
                   endif
                endif
          endif
       endif
      if (getcdn3.lt.0.e+0) getcdn3 = 0.e+0
      return
      end
****************************************************************************
* N.12_3
       FUNCTION getcdn13(X,Y,loga)
*
          real*4 X,Y
          integer loga
      common /mum83/ C1(4648)
      common /sok_2_13/ NX,NY,X0,SX,Y0,SY
      X_1=alog10(X)
      if ((X_1.lt..99999e+0).or.(X_1.gt.9.0001e+0)) then
      print*,'ERROR IN FUNCTION GETCDN1S: MUON ENERGY IS OUT OF RANGE'
      endif
      if (loga.eq.0) then
      Y_1=alog10(Y)
      else
      Y_1=Y
      endif
      if ((Y_1.lt.-11.001).or.(Y_1.gt.-5.9999e-1)) then
      print*,'ERROR IN FUNCTION GETCDN1S: EN. TRANSFER IS OUT OF RANGE'
      endif
      A3=(X_1-X0)/SX
      B3=(Y_1-Y0)/SY
      M1=INT(A3+.5)
      M2=INT(B3+.5)
      M3=NX+2
      IF(M1.LT.0.OR.M1.GE.NX.OR.M2.LT.0.OR.M2.GE.NY) THEN
      PRINT 1,X_1,M1,Y_1,M2
      ENDIF
      A3=A3-M1
      B3=B3-M2
      M1=M2*M3+M1+1
      M2=M1+M3
      M3=M2+M3
      A2=A3*A3+.25
      B2=B3*B3+.25
      A1=A2-A3
      B1=B2-B3
      A3=A2+A3
      B3=B2+B3
      A2=2.-(A2+A2)
      B2=2.-(B2+B2)
      getcdn13=(A1*C1(M1)+A2*C1(M1+1)+A3*C1(M1+2))*B1
     2      +(A1*C1(M2)+A2*C1(M2+1)+A3*C1(M2+2))*B2
     3      +(A1*C1(M3)+A2*C1(M3+1)+A3*C1(M3+2))*B3
      RETURN
1     FORMAT('GETCDN1S: *MISTAKE*X= ',D23.16,' MX= ',I4,' Y= ',D23.16,
     +' MY= ',I4)
      END
****************************************************************************
* N.13_3
*
       FUNCTION getcdn23(X,Y,loga)
*
      real*4 X,Y
      integer loga
      common /mum93/ C1(4399)
      common /sok_2_23/ NX,NY,X0,SX,Y0,SY
      X_1=alog10(X)
      if ((X_1.lt..99999e+0).or.(X_1.gt.9.0001e+0)) then
      print*,'ERROR IN FUNCTION GETCDN2S: MUON ENERGY IS OUT OF RANGE'
      endif
      if (loga.eq.0) then
      Y_1=alog10(Y)
      else
      Y_1=Y
      endif
      if ((Y_1.lt.-.60001).or.(Y_1.gt.-.99999e-1)) then
      print*,'ERROR IN FUNCTION GETCDN2S: EN. TRANSFer IS OUT OF RANGE'
      endif
      A3=(X_1-X0)/SX
      B3=(Y_1-Y0)/SY
      M1=INT(A3+.5)
      M2=INT(B3+.5)
      M3=NX+2
      IF(M1.LT.0.OR.M1.GE.NX.OR.M2.LT.0.OR.M2.GE.NY) THEN
      PRINT 1,X_1,M1,Y_1,M2
      ENDIF
      A3=A3-M1
      B3=B3-M2
      M1=M2*M3+M1+1
      M2=M1+M3
      M3=M2+M3
      A2=A3*A3+.25
      B2=B3*B3+.25
      A1=A2-A3
      B1=B2-B3
      A3=A2+A3
      B3=B2+B3
      A2=2.-(A2+A2)
      B2=2.-(B2+B2)
      getcdn23=(A1*C1(M1)+A2*C1(M1+1)+A3*C1(M1+2))*B1
     2      +(A1*C1(M2)+A2*C1(M2+1)+A3*C1(M2+2))*B2
     3      +(A1*C1(M3)+A2*C1(M3+1)+A3*C1(M3+2))*B3
      RETURN
1     FORMAT('GCDN2S:*MISTAKE*X=',D23.16,'MX=',I4,'Y=',D23.16,'MY=',I4)
      END
****************************************************************************
* N.14_3
*
       FUNCTION getcdn33(X,Y,loga)
*
      real*4 X,Y
      integer loga
      common /mum103/ C2(8549)
      common /sok_2_33/ NX,NY,X0,SX,Y0,SY
      X_1=alog10(X)
      if ((X_1.lt..99999e+0).or.(X_1.gt.9.0001e+0)) then
      print*,'ERROR IN FUNCTION GETCDN3S: MUON ENERGY IS OUT OF RANGE'
      endif
      if (loga.eq.0) then
      Y_1=alog10(Y)
      else
      Y_1=Y
      endif
      if ((Y_1.lt.-1.0001e-1).or.(Y_1.gt.1.e-6)) then
      print*,'ERROR IN FUNCTION GETCDN3S: EN. TRANSFER IS OUT OF RANGE'
      endif
      A3=(X_1-X0)/SX
      B3=(Y_1-Y0)/SY
      M1=INT(A3+.5)
      M2=INT(B3+.5)
      M3=NX+2
      IF(M1.LT.0.OR.M1.GE.NX.OR.M2.LT.0.OR.M2.GE.NY) THEN
      PRINT 1,X_1,M1,Y_1,M2
      ENDIF
      A3=A3-M1
      B3=B3-M2
      M1=M2*M3+M1+1
      M2=M1+M3
      M3=M2+M3
      A2=A3*A3+.25
      B2=B3*B3+.25
      A1=A2-A3
      B1=B2-B3
      A3=A2+A3
      B3=B2+B3
      A2=2.-(A2+A2)
      B2=2.-(B2+B2)
      getcdn33=(A1*C2(M1)+A2*C2(M1+1)+A3*C2(M1+2))*B1
     2      +(A1*C2(M2)+A2*C2(M2+1)+A3*C2(M2+2))*B2
     3      +(A1*C2(M3)+A2*C2(M3+1)+A3*C2(M3+2))*B3
      RETURN
1     FORMAT('*MISTAKE*X=',D23.16,'MX=',I4,'Y=',D23.16,'MY=',I4)
      END
****************************************************************************
* N.15_3
          SUBROUTINE getvph3(emw,vbr,itr)
*
      external getcdn3
      real*4 emw,vbr
      integer itr
      parameter (lo=1)
      common /general3/ emin,vmin,emph
      common /mcef3/ mcb1,mcb2,mcp1,mcp2,mcn1,mcn2,mce1,mce2
      common /ph_ref3/ at,bt,us2,us2_1,us3,us4,at0
      mcn1 = mcn1 + 1
        if (itr.eq.0) then
          vtr=amax1((emin/emw),(emph/emw))
        else
          vtr=amax1(vmin,(emph/emw))
        endif
      us1 = vtr**(1. - bt)
      algemin = us2 * (1. - us1)
  155 ax = algemin * rndm_mum(5)
      vbr = (alog(us1 + (ax * us2_1))) * us3
      mcn2 = mcn2 + 1
      y1 = getcdn3(emw,vbr,lo)
      y2 = at * exp(vbr * us4)
      yc = y2 * rndm_mum(8)
           if (y2.lt.y1) then
           fnew = y1 / y2
           at = at * (fnew)
           fnew1 = at / at0
           us2 = at / (1.-bt)
           us2_1 = 1. / us2
           us3 = .434294481 / (1. - bt)
           us4 = 2.302585093 * (-bt)
       print*,'***** COMPARISON FUNCTION FOR PH.NUC. SIMULATION: *****'
           print*,'Variable  AT has been increased with factor',fnew
           print*,'Now it differs from init. value with factor',fnew1
       print*,'   No reasons to trouble, it is for information only'
             if (fnew1.gt.1.5) then
       print*,'************ ERROR (3)********* f(v) < d_Sigma/d_v ****'
       print*,'**** VARIABLE  AT  HAS BEEN INCREASED TOO MUCH !!! ****'
             endif
       print*,'*******************************************************'
           endif
        if (y1.ge.yc) then
        vbr = 1.e+1**vbr
        else
        goto 155
        endif
      return
      end
****************************************************************************
*********************** DELTA-ELECTRONS SUBROUTINES : **********************
****************************************************************************
* E.1_3
*
      function getcde3(e,v)
      real*4 e,v
      common /zav3/ z
c     GeV:
      parameter (ame=0.51099907e-3)
c   parameter (amu=0.105658389)   ! GeV
c     cm:
      parameter (re=2.81794092e-13)
      parameter (alpha=1./137.036)
      parameter (pi=3.141592654)
c   parameter (bmu=amu**2/(2.*ame))
      parameter (coeff0=2.*pi*ame*re**2)
      parameter (coeff1=alpha/(2.*pi))
      parameter (sok1=2./ame)
c   parameter (sok2=5.88138263)
      real*8 alfa,rm_e,rm_mu,r_e,avog
      common /const3/ alfa,rm_e,rm_mu,r_e,avog
      common /exer13/ fa
c
        amu = 1.e-3 * sngl(rm_mu)
        bmu=amu**2/(2.*ame)
        sok2 = alog(4. / (amu * amu) )
c
      vpmax=e/(e+bmu)
      ep=v*e
      if (v.ge.vpmax) then
         getcde3=0.
         return
      endif
      sigma0=coeff0*z*(1.-v/vpmax+.5*v*v)/(v*ep)
      a1=alog(1.+sok1*ep)
      a3=sok2+alog(e*(e-ep))
      getcde3=sigma0*(1.+coeff1*a1*(a3-a1))*fa
      return
      end
****************************************************************************
* E.2_3
*
      function edbrt3(e)
      external simps
      real*8 alfa,rm_e,rm_mu,r_e,avog,z1(10),w(10),aw(10),a_ef,ro
      real*4 e
c From initial subroutine MED_CONSS:
      common /const3/ alfa,rm_e,rm_mu,r_e,avog
      common /media3/ z1,w,aw,a_ef,ro,nsub
c-----------
      common /zav3/ z
      common /exer13/ fa
c GeV:
      parameter (ame=0.51099907e-3)
c      parameter (amu=0.105658389)   !  GeV
c cm:
      parameter (re=2.81794092e-13)
      parameter (alpha=1./137.036)
      parameter (pi=3.141592654)
c      parameter (bmu=amu**2/(2.*ame))
      parameter (coeff0=2.*pi*ame*re**2)
      parameter (coeff1=alpha/(2.*pi))
      parameter (sok1=2./ame)
c      parameter (sok2=5.88138263)
      parameter (lim=2000)
      dimension aux(0:2000)
c
      amu = 1.e-3 * sngl(rm_mu)
      bmu=amu**2/(2.*ame)
      sok2 = alog(4. / (amu * amu) )
c
      vpmin = alog(7.5e-8 / e)
      vpmax = e / (e + bmu)
      vpmax1 = alog(vpmax)
      st = (vpmax1 - vpmin) * 5.e-4
      do i=0,lim
        v = exp(vpmin + st * float(i))
        ep = v * e
        if (v.ge.vpmax) then
         aux(i) = 0.
        else
         sigma0 = coeff0 * z * v * (1. - v/vpmax + .5 * v * v) / ep
         a1 = alog(1. + sok1 * ep)
         a3 = sok2 + alog(e * (e - ep))
         aux(i) = sigma0 * coeff1 * a1 * (a3 - a1)
        endif
      enddo
      edbrt3 = simps(aux,vpmin,vpmax1,lim) * e * 1.e+3
      edbrt3 = fa * edbrt3 * sngl(avog * ro / a_ef)
      return
      end
****************************************************************************
* E.3_3
*
        function bebl3(ene)
*
      real*8 c_0,z_a,ri_z,x_0,x_1,a,rm,con1,con2,hnu,c,e
      real*8 beta,p,w_max,x,theta1,theta2,delta,difx1_x,e_loss
      real*8 alfa,rm_e,rm_mu,r_e,avog,z1(10),w(10),aw(10),a_ef,ro
      real*4 ene
      common /const3/ alfa,rm_e,rm_mu,r_e,avog ! from initial subroutine
      common /media3/ z1,w,aw,a_ef,ro,nsub     !       MED_CONSS
      common /med_ion3/ z_a,ri_z,x_0,x_1,a,rm  !
      common /exer13/ fa
      parameter (c_0=1.535d-1)
c
      e = dble(ene) * 1.d+3
      con1 = c_0 * z_a * ro
      con2 = (2.d+0 * rm_e)/(rm_mu * rm_mu * ri_z * ri_z)
      hnu = 2.8816d+1 * dsqrt(ro*z_a)/1.d+6
      c = (2.d+0 * dlog(ri_z/hnu)) + 1.d+0
c
      beta = dsqrt(1.d+0 - ((rm_mu * rm_mu)/(e * e)))
      p = beta * e
      w_max=(2.d+0*rm_e*p*p)/((rm_mu*rm_mu)+(rm_e*rm_e)+(2.d+0*rm_e*e))
      x = dlog10(p/rm_mu)
             if(x.gt.x_0) then
             theta1 = 1.d+0
             else
             theta1 = 0.d+0
             delta = 0.d+0
             goto 1
             endif
                if(x_1.gt.x) then
                theta2 = 1.d+0
                else
                theta2 = 0.d+0
                difx1_x=0.d+0
                goto 2
                endif
       difx1_x = (x_1 - x)**rm
 2     delta = theta1 * ((4.6052d+0 * x) + (a * theta2 * difx1_x) - c)
 1     e_loss=(con1/(beta*beta))*((dlog(con2*p*p*w_max))+((w_max*w_max)/
     +(4.d+0*e*e))-(2.d+0*beta*beta)-delta)
       bebl3=sngl(e_loss) * fa
       return
       end
****************************************************************************
* E.4_3
*
       subroutine elec13
*
       external getcde3,dsimps
       real*8 dsimps
       real*8 um
       real*8 aux1(0:2000),aux2(0:2000),h1,h2
       real*8 alfa,rm_e,rm_mu,r_e,avog,z1(10),w(10),aw(10),a_ef,ro
       common /const3/ alfa,rm_e,rm_mu,r_e,avog ! from initial subroutine
       common /media3/ z1,w,aw,a_ef,ro,nsub     !       MED_CONSS
       common /general3/ emin,vmin,emph         !
       common /ctel_in13/ crt_el1(17),crt_el2(17)
       common /elel_in13/ elo_el1(17),elo_el2(17)
       common /elel_in23/ elel_bb(17),elel_bbb(17)
       common /elel_in33/ elel_tot(101)
       common /help_13/ aux1,aux2
       common /exer23/ noca
c ....................................................................
c     PREPARATION OF ARRAYS WITH ENERGY LOSSES AND AVERAGED FREE PATH
c                        FOR KNOCK-ON-ELECTRONS:
c
c                     a) energy transfers > EMIN
c
      lim = 2000
      do i=1,17
      en = float(i)
      en = (1.e+1)**(5.e-1 + (5.e-1 * en))
      vmi = alog(emin / en) !--------------> The lower limit for integration
      um = (rm_mu * rm_mu * 1.d-3) / (2.d+0 * rm_e)
      vma = sngl(um)
      vma = 1. / ( 1.e+0 + (vma / en) )
      vma = alog(vma)       !--------------> The upper limit for integration
      vst = (vma - vmi) / float(lim) !--> step for a rel. en. transfers grid
c
      do j=0,lim
      rnu = vmi + vst*(float(j))
      rnu = exp(rnu)
      aux1(j) = dble(getcde3(en,rnu) * rnu)        !-> array to be integrated
c                                                 !   to get mean free path
      aux2(j) = aux1(j) * rnu                     !-> array to be integrated
      enddo                                       !   for getting en. losses
c
      h1 = dble(vmi)
      h2 = dble(vma)
      crt_el1(i) = sngl(dsimps(aux1,h1,h2,lim))
      if(crt_el1(i).le.0.e+0) then
      crt_el1(i) = 1.e+10
      goto 94765
      endif
      crt_el1(i) = (sngl(a_ef/(avog*ro)))/crt_el1(i) !-> array with 17 values
c                                                    !   of free path
94765 continue
      elo_el1(i) = sngl( dsimps(aux2,h1,h2,lim) * avog * ro / a_ef )
      elo_el1(i) = elo_el1(i) * en * 1.e+3
      elo_el1(i) = alog10(elo_el1(i)) !-> array with 17 values of en. losses
      enddo
c                     b) energy transfers > VMIN
      do i=1,17
      en = float(i)
      en = (1.e+1)**(5.e-1 + (5.e-1 * en))
      vmi = alog(vmin)      !--------------> The lower limit for integration
      um = (rm_mu * rm_mu * 1.d-3) / (2.d+0 * rm_e)
      vma = sngl(um)
      vma = 1. / ( 1.e+0 + (vma / en) )
      vma = alog(vma)       !--------------> The upper limit for integration
      vst = (vma - vmi) / float(lim) !--> step for a rel. en. transfers grid
c
      do j=0,lim
      rnu = vmi + vst*(float(j))
      rnu = exp(rnu)
      aux1(j) = dble(getcde3(en,rnu) * rnu)        !-> array to be integrated
c                                                 !   to get mean free path
      aux2(j) = aux1(j) * rnu                     !-> array to be integrated
      enddo                                       !   for getting en. losses
c
      h1 = dble(vmi)
      h2 = dble(vma)
      crt_el2(i) = sngl(dsimps(aux1,h1,h2,lim))
      if(crt_el2(i).le.0.e+0) then
      crt_el2(i) = 1.e+10
      goto 94766
      endif
      crt_el2(i) = (sngl(a_ef/(avog*ro)))/crt_el2(i) !-> array with 17 values
94766 continue
      crt_el2(i) = alog(crt_el2(i))                  !   of free path
      if (noca.eq.0) crt_el2(i)=45. !-> no cat. losses for knock-on electrons
c
      elo_el2(i) = sngl( dsimps(aux2,h1,h2,lim) * avog * ro / a_ef )
      elo_el2(i) = elo_el2(i) * en * 1.e+3
      if(elo_el2(i).le.0.e+0) elo_el2(i) = 1.e-8
      if (noca.eq.0) elo_el2(i)=1.e-30!->no cat. losses for knock-on electrons
      elo_el2(i) = alog10(elo_el2(i)) !-> array with 17 values of en. losses
      enddo
c                     c) energy transfers > 0
      do i=1,17
      en = float(i)
      en = (1.e+1)**(5.e-1 + (5.e-1 * en))
      elel_bb(i) = bebl3(en)                !--> Ion. en. losses (Bethe-Bloch)
      elel_bbb(i) = edbrt3(en) + elel_bb(i)  !--> BB + bremsstahlung e-diagram
      enddo
c                     d) total energy losses below 10 GeV
c                 (Bethe-Bloch + e-diagrams for bremsstrahlung)
      do i=1,101
      en = float(i)
      en = (1.e+1)**(alog10(0.14) - .02 + (.02 * en))
      elel_tot(i) = edbrt3(en) + bebl3(en)
      enddo
c
      return
      end
****************************************************************************
* E.5_3
           FUNCTION getlelec3(X)
*
      real*4 X
      COMMON /sok13/ XMIN,STEP,XMAX
      common /sok1_e3/ C(19)
      X1 = alog10(X)
       if ((X1.lt..99999e+0).or.(X1.gt.9.0001e+0)) then
       print*,'ERROR IN FUNCTION GETLELECS: MUON ENERGY IS OUT OF RANGE'
       endif
      Y = (X1-XMIN)/STEP
      I = INT(Y+0.5)
      IF(I.LT.0.OR.X1.GT.XMAX) PRINT 1,X1,XMIN,XMAX
      Y = Y-I
      Z = Y*Y + 0.25
      getlelec3 = (Z-Y)*C(I+1) + (2.-(Z+Z))*C(I+2) + (Z+Y)*C(I+3)
      RETURN
1     FORMAT('*MISTAKE*X1=',D23.16,'XMIN=',D23.16,'XMAX=',D23.16)
      END
****************************************************************************
* E.6_3
           FUNCTION glelecv3(X)
*
      real*4 X
      COMMON /sok13/ XMIN,STEP,XMAX
      common /sok1_e23/ C(19)
      common /exer23/ noca
      if (noca.eq.0) then
      glelecv3 = 1.e+34
      return
      endif
      X1 = alog10(X)
       if ((X1.lt..99999e+0).or.(X1.gt.9.0001e+0)) then
       print*,'ERROR IN FUNCTION GLELECVS: MUON ENERGY IS OUT OF RANGE'
       endif
      Y = (X1-XMIN)/STEP
      I = INT(Y+0.5)
      IF(I.LT.0.OR.X1.GT.XMAX) PRINT 1,X1,XMIN,XMAX
      Y = Y-I
      Z = Y*Y + 0.25
      glelecv3 = (Z-Y)*C(I+1) + (2.-(Z+Z))*C(I+2) + (Z+Y)*C(I+3)
      glelecv3 = exp(glelecv3)
      RETURN
1     FORMAT('*MISTAKE*X1=',D23.16,'XMIN=',D23.16,'XMAX=',D23.16)
      END
****************************************************************************
* E.7_3
           function getctel3(u)
*
      external getlelec3
      real*8 z1(10),w(10),aw(10),a_ef,alfa,rm_e,rm_mu,r_e,avog,ro
      real*4 u
      common /const3/ alfa,rm_e,rm_mu,r_e,avog
      common /media3/ z1,w,aw,a_ef,ro,nsub
      if ((u.gt.1.0001e+9).or.(u.lt.9.9999e+0)) then
      print*,'ERROR IN FUNCTION GETCTELS: MUON ENERGY IS OUT OF RANGE'
      endif
      aef = sngl(a_ef / (avog * ro))
      getctel3 = aef / getlelec3(u)
      return
      end
****************************************************************************
* E.8_3
           function gctelv3(u)
*
      external glelecv3
      real*8 z1(10),w(10),aw(10),a_ef,alfa,rm_e,rm_mu,r_e,avog,ro
      real*4 u
      common /const3/ alfa,rm_e,rm_mu,r_e,avog
      common /media3/ z1,w,aw,a_ef,ro,nsub
      common /exer23/ noca
      if (noca.eq.0) then
      gctelv3 = 1.e-37
      return
      endif
      if ((u.gt.1.0001e+9).or.(u.lt.9.9999e+0)) then
      print*,'ERROR IN FUNCTION GCTELVS: MUON ENERGY IS OUT OF RANGE'
      endif
      aef = sngl(a_ef / (avog * ro))
      gctelv3 = aef / glelecv3(u)
      return
      end
************************************************************************
* E.9_3
             FUNCTION getdedel3(X)
*
      real*4 X
      COMMON /sok53/ XMIN,STEP,XMAX
      common /sok5_e3/ C(19)
      X1 = alog10(X)
       if ((X1.lt..99999e+0).or.(X1.gt.9.0001e+0)) then
       print*,'ERROR IN FUNCTION GETDEDELS: MUON ENERGY IS OUT OF RANGE'
       endif
      Y = (X1-XMIN)/STEP
      I = INT(Y+0.5)
      IF(I.LT.0.OR.X1.GT.XMAX) PRINT 1,X1,XMIN,XMAX
      Y = Y-I
      Z = Y*Y + 0.25
      getdedel3 = (Z-Y)*C(I+1) + (2.-(Z+Z))*C(I+2) + (Z+Y)*C(I+3)
      getdedel3 = (1.e+1)**(getdedel3)
      RETURN
1     FORMAT('*MISTAKE*X1=',D23.16,'XMIN=',D23.16,'XMAX=',D23.16)
      END
************************************************************************
* E.10_3
             FUNCTION gdedelv3(X)
*
      real*4 X
      COMMON /sok53/ XMIN,STEP,XMAX
      common /sok5_e23/ C(19)
      common /exer23/ noca
      if (noca.eq.0) then
      gdedelv3 = 1.e-36
      return
      endif
      X1 = alog10(X)
       if ((X1.lt..99999e+0).or.(X1.gt.9.0001e+0)) then
       print*,'ERROR IN FUNCTION GDEDELVS: MUON ENERGY IS OUT OF RANGE'
       endif
      Y = (X1-XMIN)/STEP
      I = INT(Y+0.5)
      IF(I.LT.0.OR.X1.GT.XMAX) PRINT 1,X1,XMIN,XMAX
      Y = Y-I
      Z = Y*Y + 0.25
      gdedelv3 = (Z-Y)*C(I+1) + (2.-(Z+Z))*C(I+2) + (Z+Y)*C(I+3)
      gdedelv3 = (1.e+1)**(gdedelv3)
      RETURN
1     FORMAT('*MISTAKE*X1=',D23.16,'XMIN=',D23.16,'XMAX=',D23.16)
      END
****************************************************************************
* E.11_3
             FUNCTION gdedelt13(X)
*
      real*4 X
      COMMON /sok53/ XMIN,STEP,XMAX
      common /sok5_e43/ C(19)
      X1 = alog10(X)
       if ((X1.lt..99999e+0).or.(X1.gt.9.0001e+0)) then
       print*,'ERROR IN FUNCTION GDEDELT1S: MUON ENERGY IS OUT OF RANGE'
       endif
      Y = (X1-XMIN)/STEP
      I = INT(Y+0.5)
      IF(I.LT.0.OR.X1.GT.XMAX) PRINT 1,X1,XMIN,XMAX
      Y = Y-I
      Z = Y*Y + 0.25
      gdedelt13 = (Z-Y)*C(I+1) + (2.-(Z+Z))*C(I+2) + (Z+Y)*C(I+3)
      RETURN
1     FORMAT('*MISTAKE*X1=',D23.16,'XMIN=',D23.16,'XMAX=',D23.16)
      END
****************************************************************************
* E.12_3
             FUNCTION gdedelt23(X)
*
      real*4 X
      COMMON /sok5et3/ XMIN,STEP,XMAX
      common /sok5_e53/ C(103)
      X1 = alog10(X)
       if ((X1.lt.-.8e+0).or.(X1.gt.1.08e+0)) then
       print*,'ERROR IN FUNCTION GDEDELT2S: MUON ENERGY IS OUT OF RANGE'
       endif
      Y = (X1-XMIN)/STEP
      I = INT(Y+0.5)
      IF(I.LT.0.OR.X1.GT.XMAX) PRINT 1,X1,XMIN,XMAX
      Y = Y-I
      Z = Y*Y + 0.25
      gdedelt23 = (Z-Y)*C(I+1) + (2.-(Z+Z))*C(I+2) + (Z+Y)*C(I+3)
      RETURN
1     FORMAT('*MISTAKE*X1=',D23.16,'XMIN=',D23.16,'XMAX=',D23.16)
      END
****************************************************************************
* E.13_3
             FUNCTION gdeion3(X)
*
      real*4 X
      external gdedelt13,gdedelt23
       if ((X.lt..159).or.(X.gt.1.0001e+9)) then
       print*,'ERROR IN FUNCTION GDEDIONS: MUON ENERGY IS OUT OF RANGE'
       endif
      if(x.le.10.) then
      gdeion3 = gdedelt23(x)
      else
      gdeion3 = gdedelt13(x)
      endif
      return
      end
****************************************************************************
* E.14_3
             FUNCTION gdedelbb3(X)
*
      real*4 X
      COMMON /sok53/ XMIN,STEP,XMAX
      common /sok5_e33/ C(19)
      X1 = alog10(X)
       if ((X1.lt..99999e+0).or.(X1.gt.9.0001e+0)) then
       print*,'ERROR IN FUNCTION GDEDELBBS: MUON ENERGY IS OUT OF RANGE'
       endif
      Y = (X1-XMIN)/STEP
      I = INT(Y+0.5)
      IF(I.LT.0.OR.X1.GT.XMAX) PRINT 1,X1,XMIN,XMAX
      Y = Y-I
      Z = Y*Y + 0.25
      gdedelbb3 = (Z-Y)*C(I+1) + (2.-(Z+Z))*C(I+2) + (Z+Y)*C(I+3)
      RETURN
1     FORMAT('*MISTAKE*X1=',D23.16,'XMIN=',D23.16,'XMAX=',D23.16)
      END
****************************************************************************
* E.15_3
         SUBROUTINE getvel3(emw,vbr1,itr)
*
      external getcde3
      real*8 vbr,rmd,vtr,vtr1,rvec_own
      real*4 emw,vbr1
      integer itr
      parameter (c2=2.549551e-28)
c      parameter (len=1)
c      common /r48/ rvec
      common /zav3/ zm
      common /general3/ emin,vmin,emph
      common /mcef3/ mcb1,mcb2,mcp1,mcp2,mcn1,mcn2,mce1,mce2
      mce1 = mce1 + 1
ccc      emind = dble(emin)
ccc      vmind = dble(vmin)
ccc      emwd = dble(emw)
        if(itr.eq.0) then
         vtr = dble(emin/emw)
        else
         vtr = dble(vmin)
        endif
      vtr1 = 1.d+0 - vtr
      coef2 = c2 * zm *  ( 1. + ( 3.2e-2 * alog(emw) ) )
  155 call rm48_own(rvec_own)
      rmd=rvec_own
      mce2 = mce2 + 1
      vbr = vtr / (vtr + (vtr1 * rmd))
      if(vbr.ge.1.d+0) vbr=.999999999999d+0
      vbr1=sngl(vbr)
      y1 = getcde3(emw,vbr1)
      y2 = coef2 / ( emw * vbr1 * vbr1)
      yc = y2 * rndm_mum(8)
           if(y2.lt.y1) then
           print*,'*** ERROR IN GETVELS: COMP.FUNCTION IS TOO SMALL ***'
           endif
                if (y1.ge.yc) then
                  goto 154
                else
                  goto 155
                endif
  154 return
      end
****************************************************************************
c -----------------------------
c  Version 1.6 - April 16, 2003                     MUM = MUons + Medium
c -----------------------------
c
c                    MUM1_6_4.F - sets of routines for the second medium
************************************************************************
c                THIS IS THE PART OF THE MUM PACKAGE FOR
c   THE 4TH MEDIUM. PLEASE READ MANUAL AT THE FIRST LINES OF MUM1_6.F
c      AND COMMENTS TO ALL THE ROUTINES (WHICH ARE IDENTICAL) THERE
************************************************************************
* C.1_4
*
          SUBROUTINE init_mu4(imed,ipn,ibre,em,vm,ilep,iqcd,lux)
c
c
      real*4 em,vm,em1,vm1
      real*4 v(13)
c
      integer imed,imed1,ipn,ibre,ilep,iqcd,lux
      integer ist(4)
c
      character *38 mum_card_name
c
      data v /5.3e-3,1.5e-2,4.9e-3,5.6e-3,5.7e-3,5.7e-3,2.0e-2,
     +        2.3e-2,1.8e-2,1.4e-2,1.1e-2,2.0e-2,2.0e-2/
c
      common /card_name/ mum_card_name
      common /init_calls/ ist
c
      ist(4) = ist(4) + 1
      lux = 2
c
c
c Opening card file for writing, making record and some screen output:
c
      open(23,file=mum_card_name, status='unknown', access='append',
     +form='formatted')
c
      write(23,*) 'Module initialized             : INIT_MU4'
c
      write(*,*) 'Initialization: INIT_MU4...'
c
c
c Checking (and changing if needed) variables IMED, EM AND VM:
c
c     IMED:
c
      if(imed.eq.0) then
         imed1 = 1
         write(*,505)  imed1
         write(*,*) ' '
      else
         if(imed.gt.0) then
            if(imed.gt.13) then
               imed1 = 1
               write(*,505)  imed1
               write(*,*) ' '
            else
               imed1 = imed
            endif
         else
            if(imed.lt.-13) then
               imed1 = -1
               write(*,505)  imed1
               write(*,*) ' '
            else
               imed1 = imed
            endif
         endif
      endif
c
c     EM:
c
      if(em.gt.0.5) then
         em1 = 0.5
         write(*,504)  em1
         write(*,*) ' '
      else
         if(em.lt.0.01) then
            em1 = 0.01
            write(*,504) em1
            write(*,*) ' '
         else
            em1 = em
         endif
      endif
c
c     VM:
c
      if(ilep.eq.1) then
         if(vm.lt.0.0001) then
             vm1 = 0.0001
             write(*,502)  vm1
             write(*,*) ' '
         else
             if(vm.gt.0.2) then
                vm1 = 0.2
                write(*,502)  vm1
                write(*,*) ' '
             else
                vm1 = vm
             endif
         endif
      else
         if(imed1.gt.0) then
            if(vm.ge.v(imed1)) then
               vm1 = v(imed1)
               write(*,502)  vm1
               write(*,*) ' '
            else
               if(vm.lt.0.0001) then
                  vm1 = 0.0001
                  write(*,502)  vm1
                  write(*,*) ' '
               else
                  vm1 = vm
               endif
            endif
         else
            if(vm.ge.4.e-3) then
               vm1 = 4.e-3
               write(*,502)  vm1
               write(*,*) ' '
            else
               if(vm.lt.0.0001) then
                  vm1 = 0.0001
                  write(*,502)  vm1
                  write(*,*) ' '
               else
                  vm1 = vm
               endif
            endif
         endif
      endif
c
c Making media, setting parameters:
c
      call med_cons4(imed1,ipn,ibre,em1,vm1,ilep,iqcd)
      CALL PREPARE_DECAY4
c
c Computing bremsstrahlung: energy losses, cross-sections,
c constants for comparison function etc.:
c
      call gamma14
c
c Computing e+e- pair production: energy losses, cross-sections,
c comparison function and its integral etc:
c
      call pair14
c
c Computing photonuclear interaction: energy losses, cross-sections,
c etc.:
c
      if(iqcd.eq.1) call QCD_CORR4
      call phnu14
c
c Computing D-electrons production: energy losses, cross-sections, etc.:
c
      call elec14
c
c Computing continuous energy losses:
c
      call enlos4
c
c Cooking 1-dimensional real*4 splines with equidistant grid:
c
      call spl14
c
c Ccooking 1-dimensional real*8 splines with equidistant grid:
c
      call dspl14
c
c Cooking 1-dimensional real*8 splines with non-equidistant grid:
c
      call dsplq14
c
c Cooking 2-dimensional real*4 splines with equidistant grid:
c
      call spl24
c
c Cooking different kinds of splines:
c
      call frepathv4
      call spl2_24
c
c Recording to the MUM run card:
c
      call prinfo4(imed1,ipn,ibre,em1,vm1,ilep,iqcd)
c
      close (23)
      return
  502 format (' !!! Variable Vcut out of range, has been changed for Vcu
     +t = ',f6.4,' !!!')
  504 format (' !!! Variable Ecut out of range, has been changed for Ecu
     +t = ',f6.4,' !!!')
  505 format (' !!! Variable IMED out of range, has been changed for IME
     +D = ',I3,' !!!')
      end
c----------------------------------------------------------------------
* C.1a_4
*
      subroutine prinfo4(imed,ipn,ibre,em,vm,ilep,iqcd)
*
      real*8 alfa,rm_e,rm_mu,r_e,z1(10),w(10),aw(10),n(10)
      real*8 a_ef,avog,ro
      real*8 z_a,ri_z,x_0,x_1,a,rm
      real*4 em,vm
      integer imed,ipn,ibre,ilep,iqcd
      integer nsub
      character *38 mum_card_name
c
      common /const4/ alfa,rm_e,rm_mu,r_e,avog
      common /media4/ z1,w,aw,a_ef,ro,nsub
      common /med_ion4/ z_a,ri_z,x_0,x_1,a,rm
      common /toprint4/ n
      common /exer14/ fa
      common /exer24/ noca
      common /card_name/ mum_card_name
c
      open(23,file=mum_card_name, status='unknown', access='append',
     +form='formatted')
c
      if (ilep.eq.1) then
         write(23,501) ilep
      else
         write(23,502) ilep
      endif
c
      if (abs(imed).eq.1) write(23,601) imed
      if (abs(imed).eq.2) write(23,602) imed
      if (abs(imed).eq.3) write(23,603) imed
      if (abs(imed).eq.4) write(23,604) imed
      if (abs(imed).eq.5) write(23,605) imed
      if (abs(imed).eq.6) write(23,606) imed
      if (abs(imed).eq.7) write(23,607) imed
      if (abs(imed).eq.8) write(23,608) imed
      if (abs(imed).eq.9) write(23,609) imed
      if (abs(imed).eq.10) write(23,610) imed
      if (abs(imed).eq.11) write(23,611) imed
      if (abs(imed).eq.12) write(23,612) imed
      if (abs(imed).eq.13) write(23,613) imed
c
      if(imed.gt.0) then
      write(23,*)
     + 'Distance expressed in          : cm (IMED is positive)'
      else
      write(23,*)
     + 'Distance expressed in          : g/cm**3 (IMED is negative)'
      endif
c
      write(23,503) em
      write(23,504) vm
c
      write(23,*) 'Cross-section for absorption'
      if (ipn.eq.1) then
          write(23,505) ipn
      else
          write(23,506) ipn
      endif
c
      write(23,*) 'QCD corrections by'
      if (iqcd.eq.1) then
         write(23,507) iqcd
      else
         write(23,508) iqcd
      endif
c
      if(ibre.eq.1) then
         write(23,509) ibre
      endif
      if(ibre.eq.2) then
         write(23,514) ibre
      endif
      if((ibre.ne.1).AND.(ibre.ne.2)) then
         write(23,510) ibre
      endif
c
      write(23,*)
     + 'Knock-on electrons are'
      write(23,*)
     + 'included in catastrophic'
      if (noca.ne.0) then
         write(23,512) noca
      else
         write(23,513) noca
      endif
c
      if ((fa.lt..99999).or.(fa.gt.1.0001)) then
      write(23,*)
     + 'ATTENTION! RUNNING IN SPECIAL'
      write(23,*)
     + 'MODE: ALL CROSSSECTIONS ARE'
      write(23,511) fa
      endif
c
      write(23,*) '====='
      write(23,*) ' '
c
      close (23)
c
      return
c
  501 format (' Particle                       : MUON (ILEP = ',i1,')')
  502 format (' Particle                       : TAU (ILEP = ',i4,')')
  503 format (' Ecut                           : ',f8.6,' GeV')
  504 format (' Vcut                           : ',f8.6)
  505 format (' of a real photon               : by Bugaev-Bezrukov (ipn
     + = ',i4,')')
  506 format (' of a real photon               : by ZEUS (ipn = ',
     +i4,')')
  507 format (' Bugaev-Shlepin                 : YES (iqcd = ',i1,')')
  508 format (' Bugaev-Shlepin                 : NO (iqcd = ',i4,')')
  509 format (' Bremsstrahlung cross-sections  : by Andreev-Bezrukov-Bug
     +aev (ibre = ',i1,')')
  510 format (' Bremsstrahlung cross-sections  : by Kelner-Kokoulin (GEA
     +NT4.0) (ibre = ',i1,')')
  514 format (' Bremsstrahlung cross-sections  : by Sandrock (ibre = ',
     + i1,')')
  511 format (' MULTIPLIED BY FACTOR           : ',f8.6)
  512 format (' losses (recommended)           : YES (noca = ',i5,')')
  513 format (' losses                         : NO (noca = ',i5,')')
  601 format (' Medium                         : PURE WATER (imed = ',
     +i2,')')
  602 format (' Medium                         : STANDARD ROCK (imed = '
     +,i2,')')
  603 format (' Medium                         : ANTARCTIC ICE (imed = '
     +,i2,')')
  604 format  (' Medium                         : SEAWATER PACIFIC (imed
     + = ',i2,')')
  605 format (' Medium                         : SEAWATER ANTARES D<2126
     +m (imed = ',i2,')')
  606 format (' Medium                         : SEAWATER ANTARES D>2126
     +m (imed = ',i2,')')
  607 format    (' Medium                         : GRAN SASSO ROCK (ime
     +d = ',i2,')')
  608 format  (' Medium                         : BAIKAL BASIS ROCK (ime
     +d = ',i2,')')
  609 format (' Medium                         : BAIKAL TANKHOY ROCK (im
     +ed = ',i2,')')
  610 format   (' Medium                         : BAIKAL ANOS ROCK (ime
     +d = ',i3,')')
  611 format (' Medium                         : BAIKAL GROUND (SILT) (i
     +med = ',i3,')')
  612 format (' Medium                         : FREJUS ROCK (SINGLE MED
     +IUM) (imed = ',i3,')')
  613 format (' Medium                         : FREJUS ROCK (COMPOSED M
     +EDIUM) (imed = ',i3,')')
c
      end
***********************************************************************
* C.2_4
*
       subroutine med_cons4(imed,ipn,ibre,em,vm,ilep,iqcd)
*  ......................................................................
       real*8 alfa,rm_e,rm_mu,r_e,z1(10),w(10),aw(10),n(10)
       real*8 ntot,a_ef,avog,ro,zmean
       real*8 z_a,ri_z,x_0,x_1,a,rm
       real*8 tlife
       real*4 em,vm
       integer imed,ipn,ibre,ilep,iqcd
       integer nsub,iqcd1
       common /qcd4/ iqcd1
       common /const_t4/ tlife
       common /const4/ alfa,rm_e,rm_mu,r_e,avog
       common /media4/ z1,w,aw,a_ef,ro,nsub
       common /med_ion4/ z_a,ri_z,x_0,x_1,a,rm
       common /general4/ emin,vmin,emph
       common /mcef4/ mcb1,mcb2,mcp1,mcp2,mcn1,mcn2,mce1,mce2
       common /zav4/ zm
       common /pnsig4/ ibb
       common /bremind4/ ibrem
       common /toprint4/ n
       common /exer14/ fa
       common /exer24/ noca
       common /what_lep4/ kindlept
       COMMON /MATTER4/ MEDIUM
       MEDIUM = imed
c ........................................................................
        iqcd1 = iqcd !---> accounting for QCD part in PN or not...
c ........................................................................
        tlife = 2.906d-13 !--> Tau-lepton mean time life (seconds)
c ........................................................................
        kindlept = ilep   !--> 1 if muons, any other value means taus
c ........................................................................
        mcb1 = 0  !
        mcb2 = 0  !
        mcp1 = 0  ! CONSTANTS TO CALCULATE
        mcp2 = 0  !      SIMULATION
        mcn1 = 0  !      EFFICIENCY
        mcn2 = 0  !
        mce1 = 0  !
        mce2 = 0  !
c ........................................................................
c                           BASIC CONSTANTS:
c                           ***************
       avog = 6.022045d+23         !--> Avogadro number
       alfa =  7.297353053019d-3   !--> fine structure constant
       rm_e = 5.110034d-1          !--> electron mass (in MeV)
       if(ilep.eq.1) then
       rm_mu = 1.0565932d+2        !--> muon mass (in MeV)
       else
       rm_mu = 1.77699d+3          !--> tau mass (in MeV)
       endif
       r_e = 2.8179409d-13         !--> classical electron radii (in cm)
c ........................................................................
c               THRESHOLD ENERGIE AND RELATIVE ENERGY TRANSFER:
c               ***********************************************
         emin = em      !---> threshold energy in Gev
         vmin = vm      !---> threshold relative energy transfer
         emph = 8.e-1   !---> threshold en. for photonucl. interaction, GeV
         fa = 1.e+0     !---> factor to multiply all diff. cros-sections and
c                       !     Bethe-Bloch formula
         noca = 1       !---> if noca=0, there are no catastrophic losses
c                             for knock-on electrons
c ........................................................................
        ibb = ipn ! if ibb=1 Sigma_gamma_p for photonuclear interaction is
c                 ! calculated by Bezrukov_Bugaev (squared LN dependence),
c                 ! otherwise it is calculated by ZEUS parametrization
c                 ! (J.Breitweg et al., Eur.Phys.J. C7 (1999) 609)
       ibrem=ibre ! if ibrem=1 diff. cross-section for bremsstrahlung is
c                 ! computed according to Andreev-Bugaev-Bezrukov, otherwise
c                 ! it is done according to Kelner-Kokouluin (Geant 4.)
c ........................................................................
c                          MEDIUM PREPARATION:
c                          ******************
        if (imed.eq.1) then
        ro=1.d+0      !
        nsub=2        ! IT IS WATER. It consists of nsub=2 elements:
        n(1)=2.d+0    ! n(1) = 2 H atoms and n(2) = 1 O atom with atomic
        n(2)=1.d+0    ! weights and electric charges are equal to
        aw(1)=1.008   ! aw(1) = 1.008, aw(2) = 15.999, z1(1) = 1 and
        aw(2)=15.999  ! z1(2) = 8, correspondingly
        z1(1)=1.d+0   ! Its density is ro = 1.0 g/qubic cm
        z1(2)=8.d+0   !
c                     !
        z_a = 5.551d-1! Z/A                      !
        ri_z = 7.5d-05! Min. Ion. Potential, MeV !
        x_0 = 2.4d-1  !--------------------      !--> It is constants
        x_1 = 2.8d+0  !-- 4 constants for        !--> for Bethe-Bloch
        a = 9.1d-2    !-- dencity effect         !-->     formula
        rm = 3.477d+0 !--------------------      !
        endif
c
        if (imed.eq.2) then
        ro=2.65d+0       !
        nsub=1           !
        n(1)=1.d+0       !
        aw(1)=22.        !
        z1(1)=1.1d+1     !
c                        ! ALL THE SAME FOR STANDARD ROCK
        z_a = 5.d-1      !
        ri_z = 1.364d-04 !
        x_0 = 4.9d-2     !
        x_1 = 3.055d+0   !
        a = 8.3d-2       !
        rm = 3.412d+0    !
        endif
c
        if (imed.eq.3) then
        ro=.92d+0       !
        nsub=2          !
        n(1)=2.d+0      !
        n(2)=1.d+0      ! The same for Antarctic ice
        aw(1)=1.008     ! (all constants are exactly as
        aw(2)=15.999    ! for water but ro = 0.92 g/cm^3 )
        z1(1)=1.d+0     !
        z1(2)=8.d+0     !
c                       !
        z_a = 5.551d-1  !
        ri_z = 7.5d-05  !
        x_0 = 2.4d-1    !
        x_1 = 2.8d+0    !
        a = 9.1d-2      !
        rm = 3.477d+0   !
        endif
c
c                         Sea water (Pacific Ocean):
c                         ------------------------
        if (imed.eq.4) then
        ro = 1.027d+0   ! J.Babson et al, Phys.Rev.D 42 (1990) 3613;
                        ! V.M.Goldschmidt. Geochemistry (Clarendon,
                        ! Oxford, 1954), p. 49.
        nsub = 8          !
        n(1) = 2.d+0      ! -> H
        n(2) = 1.00884d+0 ! -> O
        n(3) = 8.59d-3    ! -> Na
        n(4) = 1.9d-4     ! -> K
        n(5) = 9.9d-4     ! -> Mg
        n(6) = 1.9d-4     ! -> Ca
        n(7) = 1.007d-2   ! -> Cl
        n(8) = 5.3d-3     ! -> S
        aw(1) = 1.008d+0  !
        aw(2) = 15.999d+0 !
        aw(3) = 22.99d+0  ! Chemical composition of the seawater
        aw(4) = 39.10d+0  !           according to
        aw(5) = 24.31d+0  ! A.Okada, Astropart. Phys. 2 (1994) 393
        aw(6) = 40.08d+0  !        and references therein
        aw(7) = 35.45d+0  !
        aw(8) = 32.07d+0  !
        z1(1) = 1.0d+0    !
        z1(2) = 8.0d+0    !
        z1(3) = 11.0d+0   !
        z1(4) = 19.0d+0   !
        z1(5) = 12.0d+0   !
        z1(6) = 20.0d+0   !
        z1(7) = 17.0d+0   !
        z1(8) = 16.0d+0   !
c                        !
        z_a = 5.5525d-1  ! All the same as for pure water except for
        ri_z = 7.5d-05  !        z_a which is taken from
        x_0 = 2.4d-1    ! [J.Babson et al, Phys.Rev.D 42 (1990) 3613;
        x_1 = 2.8d+0    !  V.M.Goldschmidt. Geochemistry (Clarendon,
        a = 9.1d-2      !  Oxford, 1954), p. 49.] and differs from
        rm = 3.477d+0   ! z_a according to Lohman et al. by 0.027%.
        endif
c
c==========================================================================
c  THERE ARE TWO WATER FOR THE ANTARES PLACE SINCE WATER DENSITY CHANGES
c WITH THE DEPTH FROM 1.0291 g/cm^3 AT SURFACE UP TO 1.0404 g/cm^3 AT THE
c           SEA BED (ANTARES-Site/2000-001 and references therein)
c
c       So, one should use imed = 5 when simulating downcoming muons
c  (e.g., atmospheric ones) and imed = 6 when simulating muons which come
c                        from the bottom of detector)
c The error which is caused by thid simplyfied approach (average value for
c density) does not exceed 0.5% (much less, in fact) that is comparable with
c  an error which comes from uncerntainties with the muon cross-sections.
c==========================================================================
c
c           Sea water (Mediterranean Sea, ANTARES place, D < 2126 m):
c           --------------------------------------------------------
c
        if (imed.eq.5) then
        ro = 1.0341d+0  ! J.Brunner, ANTARES-Site/2000-001, the mean value
                        ! for sea water density at the ANTARES place between
                        ! surface D = 0 m (1.0291 g/cm^3) and middle of
                        ! detector D = 2126 m (1.0391 g/cm^3)
        nsub = 8          !
        n(1) = 2.d+0      ! -> H
        n(2) = 1.00884d+0 ! -> O
        n(3) = 9.43d-3    ! -> Na
        n(4) = 2.09d-4    ! -> K
        n(5) = 10.87d-4   ! -> Mg
        n(6) = 2.09d-4    ! -> Ca
        n(7) = 1.106d-2   ! -> Cl
        n(8) = 5.82d-3    ! -> S
        aw(1) = 1.008d+0  !
        aw(2) = 15.999d+0 !
        aw(3) = 22.99d+0  !    Chemical composition of the seawater
        aw(4) = 39.10d+0  !                  according to
        aw(5) = 24.31d+0  !     A.Okada, Astropart. Phys. 2 (1994) 393
        aw(6) = 40.08d+0  !              and references therein
        aw(7) = 35.45d+0  !  corrected for Mediterranean Sea, ANTARES place
        aw(8) = 32.07d+0  !     according to salinity  38.44+-0.02 g/kg,
        z1(1) = 1.0d+0    !   as cited in J.Brunner, ANTARES-Site/2000-001
        z1(2) = 8.0d+0    !  instead of 35.0 g/kg as cited in A.Okada, ...
        z1(3) = 11.0d+0   ! (so, n(3-8) have been just multiplied by 1.098)
        z1(4) = 19.0d+0   !
        z1(5) = 12.0d+0   !
        z1(6) = 20.0d+0   !
        z1(7) = 17.0d+0   !
        z1(8) = 16.0d+0   !
c                        !
        z_a = 5.5525d-1  ! All the same as for pure water except for
        ri_z = 7.5d-05  !        z_a which is taken from
        x_0 = 2.4d-1    ! [J.Babson et al, Phys.Rev.D 42 (1990) 3613;
        x_1 = 2.8d+0    !  V.M.Goldschmidt. Geochemistry (Clarendon,
        a = 9.1d-2      !  Oxford, 1954), p. 49.] and differs from
        rm = 3.477d+0   ! z_a according to Lohman et al. by 0.027%.
        endif
c
c
c           Sea water (Mediterranean Sea, ANTARES place, D > 2126 m):
c           --------------------------------------------------------
c
        if (imed.eq.6) then
        ro = 1.03975d+0 ! J.Brunner, ANTARES-Site/2000-001, the mean value
                        ! for sea water density at the ANTARES place between
                        ! sea bed D = 2400 m (1.0404 g/cm^3) and middle of
                        ! detector D = 2126 m (1.0391 g/cm^3)
        nsub = 8          !
        n(1) = 2.d+0      ! -> H
        n(2) = 1.00884d+0 ! -> O
        n(3) = 9.43d-3    ! -> Na
        n(4) = 2.09d-4    ! -> K
        n(5) = 10.87d-4   ! -> Mg
        n(6) = 2.09d-4    ! -> Ca
        n(7) = 1.106d-2   ! -> Cl
        n(8) = 5.82d-3    ! -> S
        aw(1) = 1.008d+0  !
        aw(2) = 15.999d+0 !
        aw(3) = 22.99d+0  !    Chemical composition of the seawater
        aw(4) = 39.10d+0  !                  according to
        aw(5) = 24.31d+0  !     A.Okada, Astropart. Phys. 2 (1994) 393
        aw(6) = 40.08d+0  !              and references therein
        aw(7) = 35.45d+0  !  corrected for Mediterranean Sea, ANTARES place
        aw(8) = 32.07d+0  !     according to salinity  38.44+-0.02 g/kg,
        z1(1) = 1.0d+0    !   as cited in J.Brunner, ANTARES-Site/2000-001
        z1(2) = 8.0d+0    !  instead of 35.0 g/kg as cited in A.Okada, ...
        z1(3) = 11.0d+0   ! (so, n(3-8) have been just multiplied by 1.098)
        z1(4) = 19.0d+0   !
        z1(5) = 12.0d+0   !
        z1(6) = 20.0d+0   !
        z1(7) = 17.0d+0   !
        z1(8) = 16.0d+0   !
c                        !
        z_a = 5.5525d-1  ! All the same as for pure water except for
        ri_z = 7.5d-05  !        z_a which is taken from
        x_0 = 2.4d-1    ! [J.Babson et al, Phys.Rev.D 42 (1990) 3613;
        x_1 = 2.8d+0    !  V.M.Goldschmidt. Geochemistry (Clarendon,
        a = 9.1d-2      !  Oxford, 1954), p. 49.] and differs from
        rm = 3.477d+0   ! z_a according to Lohman et al. by 0.027%.
        endif
c
c
c      Gran Sasso rock (M.Ambrosio et al., Phys. Rev. D52, (1995) 3793)
c      ----------------------------------------------------------------
c
        if (imed.eq.7) then
        ro = 2.71d+0
        nsub = 8            !
        n(1) = 2.9762d-2    ! -> H
        n(2) = 1.0132379d+0 ! -> C
        n(3) = 3.175109d+0  ! -> O
        n(4) = 3.423164d-1  ! -> Mg
        n(5) = 2.3349764d-2 ! -> Al
        n(6) = 3.73865d-2   ! -> Si
        n(7) = 2.557676d-3  ! -> K
        n(8) = 6.7094166d-1 ! -> Ca
        aw(1) = 1.008d+0
        aw(2) = 12.011d+0
        aw(3) = 15.99d+0
        aw(4) = 24.305d+0
        aw(5) = 26.981d+0
        aw(6) = 28.085d+0
        aw(7) = 39.098d+0
        aw(8) = 40.078d+0
        z1(1) = 1.0d+0
        z1(2) = 6.0d+0
        z1(3) = 8.0d+0
        z1(4) = 12.0d+0
        z1(5) = 13.0d+0
        z1(6) = 14.0d+0
        z1(7) = 19.0d+0
        z1(8) = 20.0d+0
c                        !
        z_a = 5.d-1      ! The same as for Standard Rock
        ri_z = 1.364d-04 !
        x_0 = 4.9d-2     !
        x_1 = 3.055d+0   !
        a = 8.3d-2       !
        rm = 3.412d+0    !
        endif
c
c
c   Baikal rock (basis, shore rocks and rocks 2 km below the Baikal bed)
c   --------------------------------------------------------------------
c        (as given at A.I.Panfilov, Baikal internal note 22/06/00)
c                         panfilov@inr.ruhep.ru
c
        if (imed.eq.8) then
        ro = 2.9d+0
        nsub = 10            !
        n(1) = 2.7251d-2     ! -> O
        n(2) = 8.15367d-3    ! -> Si
        n(3) = 1.670844d-4   ! -> Ti
        n(4) = 2.89087d-3    ! -> Al
        n(5) = 1.8443247d-3  ! -> Fe
        n(6) = 3.640467d-5   ! -> Mn
        n(7) = 1.810327d-3   ! -> Mg
        n(8) = 1.946205d-3   ! -> Ca
        n(9) = 7.3945837d-4  ! -> Na
        n(10) = 1.278828d-4  ! -> K
        aw(1) = 15.9994d+0
        aw(2) = 28.0855d+0
        aw(3) = 47.88d+0
        aw(4) = 26.9815d+0
        aw(5) = 55.847d+0
        aw(6) = 54.938d+0
        aw(7) = 24.305d+0
        aw(8) = 40.078d+0
        aw(9) = 22.9898d+0
        aw(10) = 39.0983d+0
        z1(1) = 8.0d+0
        z1(2) = 14.0d+0
        z1(3) = 22.0d+0
        z1(4) = 13.0d+0
        z1(5) = 26.0d+0
        z1(6) = 25.0d+0
        z1(7) = 12.0d+0
        z1(8) = 20.0d+0
        z1(9) = 11.0d+0
        z1(10) = 19.0d+0
c                        !
        z_a = 4.96d-1    ! The same as for Standard Rock (what to do?!)
        ri_z = 1.364d-04 !     except for z_a which was meaured
        x_0 = 4.9d-2     !          to be equal to 0.496
        x_1 = 3.055d+0   !
        a = 8.3d-2       !
        rm = 3.412d+0    !
        endif
c
c     Baikal rock ("tankhoy layer", up to 2000 m below the Baikal bed)
c      There are data concerning 6 depths which differ each other by
c   ~10% in terms of density, Z, A, and composition. One had to choose
c      the data for 800 m below the Baikal bed which seem to be close
c                                to "average"
c   --------------------------------------------------------------------
c        (as given at A.I.Panfilov, Baikal internal note 22/06/00)
c                         panfilov@inr.ruhep.ru
c
        if (imed.eq.9) then
        ro = 2.481d+0
        nsub = 10            !
        n(1) = 0.588d+0      ! -> O
        n(2) = 0.166d+0      ! -> Si
        n(3) = 0.002d+0      ! -> Ti
        n(4) = 0.093d+0      ! -> Al
        n(5) = 0.033d+0      ! -> Fe
        n(6) = 0.101d+0      ! -> H
        n(7) = 0.009d+0      ! -> Mg
        n(8) = 0.003d+0      ! -> Ca
        n(9) = 0.002d+0      ! -> Na
        n(10) = 0.003d+0     ! -> K
        aw(1) = 15.9994d+0
        aw(2) = 28.0855d+0
        aw(3) = 47.88d+0
        aw(4) = 26.9815d+0
        aw(5) = 55.847d+0
        aw(6) = 1.00794d+0
        aw(7) = 24.305d+0
        aw(8) = 40.078d+0
        aw(9) = 22.9898d+0
        aw(10) = 39.0983d+0
        z1(1) = 8.0d+0
        z1(2) = 14.0d+0
        z1(3) = 22.0d+0
        z1(4) = 13.0d+0
        z1(5) = 26.0d+0
        z1(6) = 1.0d+0
        z1(7) = 12.0d+0
        z1(8) = 20.0d+0
        z1(9) = 11.0d+0
        z1(10) = 19.0d+0
c                        !
        z_a = 5.47d-1     ! The same as for Standard Rock (what to do?!)
        ri_z = 1.364d-04 !     except for z_a which was meaured
        x_0 = 4.9d-2     !          to be equal to 0.547
        x_1 = 3.055d+0   !
        a = 8.3d-2       !
        rm = 3.412d+0    !
        endif
c
c      Baikal rock ("anos layer", 100 -- 500 m below the Baikal bed)
c      There are data concerning 6 depths which differ each other by
c   ~10% in terms of density, Z, A, and composition. One had to choose
c      the data for 300 m below the Baikal bed which seem to be close
c                                to "average"
c   --------------------------------------------------------------------
c        (as given at A.I.Panfilov, Baikal internal note 22/06/00)
c                         panfilov@inr.ruhep.ru
c
        if (imed.eq.10) then
        ro = 2.103d+0
        nsub = 10            !
        n(1) = 0.519d+0      ! -> O
        n(2) = 0.149d+0      ! -> Si
        n(3) = 0.002d+0      ! -> Ti
        n(4) = 0.044d+0      ! -> Al
        n(5) = 0.006d+0      ! -> Fe
        n(6) = 0.268d+0      ! -> H
        n(7) = 0.004d+0      ! -> Mg
        n(8) = 0.001d+0      ! -> Ca
        n(9) = 0.001d+0      ! -> Na
        n(10) = 0.006d+0     ! -> K
        aw(1) = 15.9994d+0
        aw(2) = 28.0855d+0
        aw(3) = 47.88d+0
        aw(4) = 26.9815d+0
        aw(5) = 55.847d+0
        aw(6) = 1.00794d+0
        aw(7) = 24.305d+0
        aw(8) = 40.078d+0
        aw(9) = 22.9898d+0
        aw(10) = 39.0983d+0
        z1(1) = 8.0d+0
        z1(2) = 14.0d+0
        z1(3) = 22.0d+0
        z1(4) = 13.0d+0
        z1(5) = 26.0d+0
        z1(6) = 1.0d+0
        z1(7) = 12.0d+0
        z1(8) = 20.0d+0
        z1(9) = 11.0d+0
        z1(10) = 19.0d+0
c                        !
        z_a = 6.3d-1     ! The same as for Standard Rock (what to do?!)
        ri_z = 1.364d-04 !     except for z_a which was meaured
        x_0 = 4.9d-2     !          to be equal to 0.630
        x_1 = 3.055d+0   !
        a = 8.3d-2       !
        rm = 3.412d+0    !
        endif
c
c     Baikal ground ("alevrit silt", 0 -- 100 m below the Baikal bed)
c      There are data concerning 6 depths which differ each other by
c   ~10% in terms of density, Z, A, and composition. One had to choose
c      the data for 50 m below the Baikal bed which seem to be close
c                               to "average"
c   --------------------------------------------------------------------
c        (as given at A.I.Panfilov, Baikal internal note 22/06/00)
c                         panfilov@inr.ruhep.ru
c
        if (imed.eq.11) then
        ro = 1.698d+0
        nsub = 10            !
        n(1) = 0.439d+0      ! -> O
        n(2) = 0.090d+0      ! -> Si NB: the litle fraction of S
        n(3) = 0.001d+0      ! -> Ti     had to be added to Si (very
        n(4) = 0.018d+0      ! -> Al     close elements, within
        n(5) = 0.005d+0      ! -> Fe      systematic errors)
        n(6) = 0.431d+0      ! -> H
        n(7) = 0.003d+0      ! -> Mg
        n(8) = 0.003d+0      ! -> Ca
        n(9) = 0.005d+0      ! -> Na
        n(10) = 0.003d+0     ! -> K
        aw(1) = 15.9994d+0
        aw(2) = 28.0855d+0
        aw(3) = 47.88d+0
        aw(4) = 26.9815d+0
        aw(5) = 55.847d+0
        aw(6) = 1.00794d+0
        aw(7) = 24.305d+0
        aw(8) = 40.078d+0
        aw(9) = 22.9898d+0
        aw(10) = 39.0983d+0
        z1(1) = 8.0d+0
        z1(2) = 14.0d+0
        z1(3) = 22.0d+0
        z1(4) = 13.0d+0
        z1(5) = 26.0d+0
        z1(6) = 1.0d+0
        z1(7) = 12.0d+0
        z1(8) = 20.0d+0
        z1(9) = 11.0d+0
        z1(10) = 19.0d+0
c                        !
        z_a = 7.11d-1    ! The same as for Standard Rock (what to do?!)
        ri_z = 7.5d-05   !  except for z_a which was meaured to be equal
        x_0 = 4.9d-2     ! to 0.711, ri_z had to be taken for water since
        x_1 = 3.055d+0   ! this ground is obviously closer to water than
        a = 8.3d-2       !               to rock...
        rm = 3.412d+0    !
        endif
c
c
c                  FREJUS ROCK ("single medium" model)
c                  ===================================
c       as described in W.Rhode, "Untersuchung der Energiespektren
c hochenergetischer Muonen im Frejusdetektor", Dissertation zur Erlangung
c  des Doktorgrades des Fachbereiches Physik der Bergischer UniversitaEt
c              Wupppertal, WUB-DIS 93-11, Oktober 1993, 232 pp.
c
        if (imed.eq.12) then
        ro=2.74d+0       !
        nsub=1           !
        n(1)=1.d+0       !
        aw(1)=20.34      !
        z1(1)=1.012d+1   !
c                        ! Everything has been taken from
        z_a = 4.975d-1   !        W.Rhode Thesis
        ri_z = 1.49d-04  !
        x_0 = 2.88d-1    !
        x_1 = 3.196d+0   !
        a = 7.8d-2       !
        rm = 3.645d+0    !
        endif
c
c   Frejus rock ("composed medium" model), as it was incorporated in
c PROPMU code by W.Rhode (W.Rhode, private communication, October 2001)
c
        if (imed.eq.13) then
        ro = 2.74d+0
        nsub = 10            !
        n(1) = 9.1800165d-3  ! -> C
        n(2) = 3.8712389d-2  ! -> O
        n(3) = 3.0446410d-4  ! -> Mg
        n(4) = 1.3342456d-3  ! -> Al
        n(5) = 3.6584715d-3  ! -> Si
        n(6) = 7.9523483d-5  ! -> S
        n(7) = 1.6650340d-4  ! -> K
        n(8) = 2.5955637d-3  ! -> Ca
        n(9) = 6.4072169d-6  ! -> Mn
        n(10) = 1.7417229d-4 ! -> Fe
        aw(1) = 12.11d+0
        aw(2) = 15.9994d+0
        aw(3) = 24.305d+0
        aw(4) = 26.981539d+0
        aw(5) = 28.0855d+0
        aw(6) = 32.066d+0
        aw(7) = 39.0983d+0
        aw(8) = 40.078d+0
        aw(9) = 54.93805d+0
        aw(10) = 55.847d+0
        z1(1) = 6.0d+0
        z1(2) = 8.0d+0
        z1(3) = 12.0d+0
        z1(4) = 13.0d+0
        z1(5) = 14.0d+0
        z1(6) = 16.0d+0
        z1(7) = 19.0d+0
        z1(8) = 20.0d+0
        z1(9) = 25.0d+0
        z1(10) = 26.0d+0
c
        z_a = 4.975d-1
        ri_z = 1.49d-04
        x_0 = 2.88d-1
        x_1 = 3.196d+0
        a = 7.8d-2
        rm = 3.645d+0
        endif
c
        if (imed.eq.-1) then
        ro=1.d+0      !
        nsub=2        ! IT IS WATER. It consists of nsub=2 elements:
        n(1)=2.d+0    ! n(1) = 2 H atoms and n(2) = 1 O atom with atomic
        n(2)=1.d+0    ! weights and electric charges are equal to
        aw(1)=1.008   ! aw(1) = 1.008, aw(2) = 15.999, z1(1) = 1 and
        aw(2)=15.999  ! z1(2) = 8, correspondingly
        z1(1)=1.d+0   ! Its density is ro = 1.0 g/qubic cm
        z1(2)=8.d+0   !
c                     !
        z_a = 5.551d-1! Z/A                      !
        ri_z = 7.5d-05! Min. Ion. Potential, MeV !
        x_0 = 2.4d-1  !--------------------      !--> It is constants
        x_1 = 2.8d+0  !-- 4 constants for        !--> for Bethe-Bloch
        a = 9.1d-2    !-- dencity effect         !-->     formula
        rm = 3.477d+0 !--------------------      !
        endif
c
        if (imed.eq.-2) then
        ro=1.0d+0        !
        nsub=1           !
        n(1)=1.d+0       !
        aw(1)=22.        !
        z1(1)=1.1d+1     !
c                        ! ALL THE SAME FOR STANDARD ROCK
        z_a = 5.d-1      !
        ri_z = 1.364d-04 !
        x_0 = 4.9d-2     !
        x_1 = 3.055d+0   !
        a = 8.3d-2       !
        rm = 3.412d+0    !
        endif
c
        if (imed.eq.-3) then
        ro=1.0d+0       !
        nsub=2          !
        n(1)=2.d+0      !
        n(2)=1.d+0      ! The same for Antarctic ice
        aw(1)=1.008     ! (all constants are exactly as
        aw(2)=15.999    ! for water but ro = 0.92 g/cm^3 )
        z1(1)=1.d+0     !
        z1(2)=8.d+0     !
c                       !
        z_a = 5.551d-1  !
        ri_z = 7.5d-05  !
        x_0 = 2.4d-1    !
        x_1 = 2.8d+0    !
        a = 9.1d-2      !
        rm = 3.477d+0   !
        endif
c
c                         Sea water (Pacific Ocean):
c                         ------------------------
        if (imed.eq.-4) then
        ro = 1.0d+0     ! J.Babson et al, Phys.Rev.D 42 (1990) 3613;
                        ! V.M.Goldschmidt. Geochemistry (Clarendon,
                        ! Oxford, 1954), p. 49.
        nsub = 8          !
        n(1) = 2.d+0      ! -> H
        n(2) = 1.00884d+0 ! -> O
        n(3) = 8.59d-3    ! -> Na
        n(4) = 1.9d-4     ! -> K
        n(5) = 9.9d-4     ! -> Mg
        n(6) = 1.9d-4     ! -> Ca
        n(7) = 1.007d-2   ! -> Cl
        n(8) = 5.3d-3     ! -> S
        aw(1) = 1.008d+0  !
        aw(2) = 15.999d+0 !
        aw(3) = 22.99d+0  ! Chemical composition of the seawater
        aw(4) = 39.10d+0  !           according to
        aw(5) = 24.31d+0  ! A.Okada, Astropart. Phys. 2 (1994) 393
        aw(6) = 40.08d+0  !        and references therein
        aw(7) = 35.45d+0  !
        aw(8) = 32.07d+0  !
        z1(1) = 1.0d+0    !
        z1(2) = 8.0d+0    !
        z1(3) = 11.0d+0   !
        z1(4) = 19.0d+0   !
        z1(5) = 12.0d+0   !
        z1(6) = 20.0d+0   !
        z1(7) = 17.0d+0   !
        z1(8) = 16.0d+0   !
c                        !
        z_a = 5.5525d-1  ! All the same as for pure water except for
        ri_z = 7.5d-05  !        z_a which is taken from
        x_0 = 2.4d-1    ! [J.Babson et al, Phys.Rev.D 42 (1990) 3613;
        x_1 = 2.8d+0    !  V.M.Goldschmidt. Geochemistry (Clarendon,
        a = 9.1d-2      !  Oxford, 1954), p. 49.] and differs from
        rm = 3.477d+0   ! z_a according to Lohman et al. by 0.027%.
        endif
c
c           Sea water (Mediterranean Sea, ANTARES place, D < 2126 m):
c           --------------------------------------------------------
c
        if (imed.eq.-5) then
        ro = 1.0d+0     ! J.Brunner, ANTARES-Site/2000-001, the mean value
                        ! for sea water density at the ANTARES place between
                        ! surface D = 0 m (1.0291 g/cm^3) and middle of
                        ! detector D = 2126 m (1.0391 g/cm^3)
        nsub = 8          !
        n(1) = 2.d+0      ! -> H
        n(2) = 1.00884d+0 ! -> O
        n(3) = 9.43d-3    ! -> Na
        n(4) = 2.09d-4    ! -> K
        n(5) = 10.87d-4   ! -> Mg
        n(6) = 2.09d-4    ! -> Ca
        n(7) = 1.106d-2   ! -> Cl
        n(8) = 5.82d-3    ! -> S
        aw(1) = 1.008d+0  !
        aw(2) = 15.999d+0 !
        aw(3) = 22.99d+0  !    Chemical composition of the seawater
        aw(4) = 39.10d+0  !                  according to
        aw(5) = 24.31d+0  !     A.Okada, Astropart. Phys. 2 (1994) 393
        aw(6) = 40.08d+0  !              and references therein
        aw(7) = 35.45d+0  !  corrected for Mediterranean Sea, ANTARES place
        aw(8) = 32.07d+0  !     according to salinity  38.44+-0.02 g/kg,
        z1(1) = 1.0d+0    !   as cited in J.Brunner, ANTARES-Site/2000-001
        z1(2) = 8.0d+0    !  instead of 35.0 g/kg as cited in A.Okada, ...
        z1(3) = 11.0d+0   ! (so, n(3-8) have been just multiplied by 1.098)
        z1(4) = 19.0d+0   !
        z1(5) = 12.0d+0   !
        z1(6) = 20.0d+0   !
        z1(7) = 17.0d+0   !
        z1(8) = 16.0d+0   !
c                        !
        z_a = 5.5525d-1  ! All the same as for pure water except for
        ri_z = 7.5d-05  !        z_a which is taken from
        x_0 = 2.4d-1    ! [J.Babson et al, Phys.Rev.D 42 (1990) 3613;
        x_1 = 2.8d+0    !  V.M.Goldschmidt. Geochemistry (Clarendon,
        a = 9.1d-2      !  Oxford, 1954), p. 49.] and differs from
        rm = 3.477d+0   ! z_a according to Lohman et al. by 0.027%.
        endif
c
c
c           Sea water (Mediterranean Sea, ANTARES place, D > 2126 m):
c           --------------------------------------------------------
c
        if (imed.eq.-6) then
        ro = 1.0d+0     ! J.Brunner, ANTARES-Site/2000-001, the mean value
                        ! for sea water density at the ANTARES place between
                        ! sea bed D = 2400 m (1.0404 g/cm^3) and middle of
                        ! detector D = 2126 m (1.0391 g/cm^3)
        nsub = 8          !
        n(1) = 2.d+0      ! -> H
        n(2) = 1.00884d+0 ! -> O
        n(3) = 9.43d-3    ! -> Na
        n(4) = 2.09d-4    ! -> K
        n(5) = 10.87d-4   ! -> Mg
        n(6) = 2.09d-4    ! -> Ca
        n(7) = 1.106d-2   ! -> Cl
        n(8) = 5.82d-3    ! -> S
        aw(1) = 1.008d+0  !
        aw(2) = 15.999d+0 !
        aw(3) = 22.99d+0  !    Chemical composition of the seawater
        aw(4) = 39.10d+0  !                  according to
        aw(5) = 24.31d+0  !     A.Okada, Astropart. Phys. 2 (1994) 393
        aw(6) = 40.08d+0  !              and references therein
        aw(7) = 35.45d+0  !  corrected for Mediterranean Sea, ANTARES place
        aw(8) = 32.07d+0  !     according to salinity  38.44+-0.02 g/kg,
        z1(1) = 1.0d+0    !   as cited in J.Brunner, ANTARES-Site/2000-001
        z1(2) = 8.0d+0    !  instead of 35.0 g/kg as cited in A.Okada, ...
        z1(3) = 11.0d+0   ! (so, n(3-8) have been just multiplied by 1.098)
        z1(4) = 19.0d+0   !
        z1(5) = 12.0d+0   !
        z1(6) = 20.0d+0   !
        z1(7) = 17.0d+0   !
        z1(8) = 16.0d+0   !
c                        !
        z_a = 5.5525d-1  ! All the same as for pure water except for
        ri_z = 7.5d-05  !        z_a which is taken from
        x_0 = 2.4d-1    ! [J.Babson et al, Phys.Rev.D 42 (1990) 3613;
        x_1 = 2.8d+0    !  V.M.Goldschmidt. Geochemistry (Clarendon,
        a = 9.1d-2      !  Oxford, 1954), p. 49.] and differs from
        rm = 3.477d+0   ! z_a according to Lohman et al. by 0.027%.
        endif
c
c
c      Gran Sasso rock (M.Ambrosio et al., Phys. Rev. D52, (1995) 3793)
c      ----------------------------------------------------------------
c
        if (imed.eq.-7) then
        ro = 1.0d+0
        nsub = 8            !
        n(1) = 2.9762d-2    ! -> H
        n(2) = 1.0132379d+0 ! -> C
        n(3) = 3.175109d+0  ! -> O
        n(4) = 3.423164d-1  ! -> Mg
        n(5) = 2.3349764d-2 ! -> Al
        n(6) = 3.73865d-2   ! -> Si
        n(7) = 2.557676d-3  ! -> K
        n(8) = 6.7094166d-1 ! -> Ca
        aw(1) = 1.008d+0
        aw(2) = 12.011d+0
        aw(3) = 15.99d+0
        aw(4) = 24.305d+0
        aw(5) = 26.981d+0
        aw(6) = 28.085d+0
        aw(7) = 39.098d+0
        aw(8) = 40.078d+0
        z1(1) = 1.0d+0
        z1(2) = 6.0d+0
        z1(3) = 8.0d+0
        z1(4) = 12.0d+0
        z1(5) = 13.0d+0
        z1(6) = 14.0d+0
        z1(7) = 19.0d+0
        z1(8) = 20.0d+0
c                        !
        z_a = 5.d-1      ! The same as for Standard Rock
        ri_z = 1.364d-04 !
        x_0 = 4.9d-2     !
        x_1 = 3.055d+0   !
        a = 8.3d-2       !
        rm = 3.412d+0    !
        endif
c
c
c   Baikal rock (basis, shore rocks and rocks 2 km below the Baikal bed)
c   --------------------------------------------------------------------
c        (as given at A.I.Panfilov, Baikal internal note 22/06/00)
c                         panfilov@inr.ruhep.ru
c
        if (imed.eq.-8) then
        ro = 1.0d+0
        nsub = 10            !
        n(1) = 2.7251d-2     ! -> O
        n(2) = 8.15367d-3    ! -> Si
        n(3) = 1.670844d-4   ! -> Ti
        n(4) = 2.89087d-3    ! -> Al
        n(5) = 1.8443247d-3  ! -> Fe
        n(6) = 3.640467d-5   ! -> Mn
        n(7) = 1.810327d-3   ! -> Mg
        n(8) = 1.946205d-3   ! -> Ca
        n(9) = 7.3945837d-4  ! -> Na
        n(10) = 1.278828d-4  ! -> K
        aw(1) = 15.9994d+0
        aw(2) = 28.0855d+0
        aw(3) = 47.88d+0
        aw(4) = 26.9815d+0
        aw(5) = 55.847d+0
        aw(6) = 54.938d+0
        aw(7) = 24.305d+0
        aw(8) = 40.078d+0
        aw(9) = 22.9898d+0
        aw(10) = 39.0983d+0
        z1(1) = 8.0d+0
        z1(2) = 14.0d+0
        z1(3) = 22.0d+0
        z1(4) = 13.0d+0
        z1(5) = 26.0d+0
        z1(6) = 25.0d+0
        z1(7) = 12.0d+0
        z1(8) = 20.0d+0
        z1(9) = 11.0d+0
        z1(10) = 19.0d+0
c                        !
        z_a = 4.96d-1    ! The same as for Standard Rock (what to do?!)
        ri_z = 1.364d-04 !     except for z_a which was meaured
        x_0 = 4.9d-2     !          to be equal to 0.496
        x_1 = 3.055d+0   !
        a = 8.3d-2       !
        rm = 3.412d+0    !
        endif
c
c     Baikal rock ("tankhoy layer", up to 2000 m below the Baikal bed)
c      There are data concerning 6 depths which differ each other by
c   ~10% in terms of density, Z, A, and composition. One had to choose
c      the data for 800 m below the Baikal bed which seem to be close
c                                to "average"
c   --------------------------------------------------------------------
c        (as given at A.I.Panfilov, Baikal internal note 22/06/00)
c                         panfilov@inr.ruhep.ru
c
        if (imed.eq.-9) then
        ro = 1.0d+0
        nsub = 10            !
        n(1) = 0.588d+0      ! -> O
        n(2) = 0.166d+0      ! -> Si
        n(3) = 0.002d+0      ! -> Ti
        n(4) = 0.093d+0      ! -> Al
        n(5) = 0.033d+0      ! -> Fe
        n(6) = 0.101d+0      ! -> H
        n(7) = 0.009d+0      ! -> Mg
        n(8) = 0.003d+0      ! -> Ca
        n(9) = 0.002d+0      ! -> Na
        n(10) = 0.003d+0     ! -> K
        aw(1) = 15.9994d+0
        aw(2) = 28.0855d+0
        aw(3) = 47.88d+0
        aw(4) = 26.9815d+0
        aw(5) = 55.847d+0
        aw(6) = 1.00794d+0
        aw(7) = 24.305d+0
        aw(8) = 40.078d+0
        aw(9) = 22.9898d+0
        aw(10) = 39.0983d+0
        z1(1) = 8.0d+0
        z1(2) = 14.0d+0
        z1(3) = 22.0d+0
        z1(4) = 13.0d+0
        z1(5) = 26.0d+0
        z1(6) = 1.0d+0
        z1(7) = 12.0d+0
        z1(8) = 20.0d+0
        z1(9) = 11.0d+0
        z1(10) = 19.0d+0
c                        !
        z_a = 5.47d-1     ! The same as for Standard Rock (what to do?!)
        ri_z = 1.364d-04 !     except for z_a which was meaured
        x_0 = 4.9d-2     !          to be equal to 0.547
        x_1 = 3.055d+0   !
        a = 8.3d-2       !
        rm = 3.412d+0    !
        endif
c
c      Baikal rock ("anos layer", 100 -- 500 m below the Baikal bed)
c      There are data concerning 6 depths which differ each other by
c   ~10% in terms of density, Z, A, and composition. One had to choose
c      the data for 300 m below the Baikal bed which seem to be close
c                                to "average"
c   --------------------------------------------------------------------
c        (as given at A.I.Panfilov, Baikal internal note 22/06/00)
c                         panfilov@inr.ruhep.ru
c
        if (imed.eq.-10) then
        ro = 1.0d+0
        nsub = 10            !
        n(1) = 0.519d+0      ! -> O
        n(2) = 0.149d+0      ! -> Si
        n(3) = 0.002d+0      ! -> Ti
        n(4) = 0.044d+0      ! -> Al
        n(5) = 0.006d+0      ! -> Fe
        n(6) = 0.268d+0      ! -> H
        n(7) = 0.004d+0      ! -> Mg
        n(8) = 0.001d+0      ! -> Ca
        n(9) = 0.001d+0      ! -> Na
        n(10) = 0.006d+0     ! -> K
        aw(1) = 15.9994d+0
        aw(2) = 28.0855d+0
        aw(3) = 47.88d+0
        aw(4) = 26.9815d+0
        aw(5) = 55.847d+0
        aw(6) = 1.00794d+0
        aw(7) = 24.305d+0
        aw(8) = 40.078d+0
        aw(9) = 22.9898d+0
        aw(10) = 39.0983d+0
        z1(1) = 8.0d+0
        z1(2) = 14.0d+0
        z1(3) = 22.0d+0
        z1(4) = 13.0d+0
        z1(5) = 26.0d+0
        z1(6) = 1.0d+0
        z1(7) = 12.0d+0
        z1(8) = 20.0d+0
        z1(9) = 11.0d+0
        z1(10) = 19.0d+0
c                        !
        z_a = 6.3d-1     ! The same as for Standard Rock (what to do?!)
        ri_z = 1.364d-04 !     except for z_a which was meaured
        x_0 = 4.9d-2     !          to be equal to 0.630
        x_1 = 3.055d+0   !
        a = 8.3d-2       !
        rm = 3.412d+0    !
        endif
c
c     Baikal ground ("alevrit silt", 0 -- 100 m below the Baikal bed)
c      There are data concerning 6 depths which differ each other by
c   ~10% in terms of density, Z, A, and composition. One had to choose
c      the data for 50 m below the Baikal bed which seem to be close
c                               to "average"
c   --------------------------------------------------------------------
c        (as given at A.I.Panfilov, Baikal internal note 22/06/00)
c                         panfilov@inr.ruhep.ru
c
        if (imed.eq.-11) then
        ro = 1.0d+0
        nsub = 10            !
        n(1) = 0.439d+0      ! -> O
        n(2) = 0.090d+0      ! -> Si NB: the litle fraction of S
        n(3) = 0.001d+0      ! -> Ti     had to be added to Si (very
        n(4) = 0.018d+0      ! -> Al     close elements, within
        n(5) = 0.005d+0      ! -> Fe      systematic errors)
        n(6) = 0.431d+0      ! -> H
        n(7) = 0.003d+0      ! -> Mg
        n(8) = 0.003d+0      ! -> Ca
        n(9) = 0.005d+0      ! -> Na
        n(10) = 0.003d+0     ! -> K
        aw(1) = 15.9994d+0
        aw(2) = 28.0855d+0
        aw(3) = 47.88d+0
        aw(4) = 26.9815d+0
        aw(5) = 55.847d+0
        aw(6) = 1.00794d+0
        aw(7) = 24.305d+0
        aw(8) = 40.078d+0
        aw(9) = 22.9898d+0
        aw(10) = 39.0983d+0
        z1(1) = 8.0d+0
        z1(2) = 14.0d+0
        z1(3) = 22.0d+0
        z1(4) = 13.0d+0
        z1(5) = 26.0d+0
        z1(6) = 1.0d+0
        z1(7) = 12.0d+0
        z1(8) = 20.0d+0
        z1(9) = 11.0d+0
        z1(10) = 19.0d+0
c                        !
        z_a = 7.11d-1    ! The same as for Standard Rock (what to do?!)
        ri_z = 7.5d-05   !  except for z_a which was meaured to be equal
        x_0 = 4.9d-2     ! to 0.711, ri_z had to be taken for water since
        x_1 = 3.055d+0   ! this ground is obviously closer to water than
        a = 8.3d-2       !               to rock...
        rm = 3.412d+0    !
        endif
c
c
c                  FREJUS ROCK ("single medium" model)
c                  ===================================
c       as described in W.Rhode, "Untersuchung der Energiespektren
c hochenergetischer Muonen im Frejusdetektor", Dissertation zur Erlangung
c  des Doktorgrades des Fachbereiches Physik der Bergischer UniversitaEt
c              Wupppertal, WUB-DIS 93-11, Oktober 1993, 232 pp.
c
        if (imed.eq.-12) then
        ro=1.0d+0        !
        nsub=1           !
        n(1)=1.d+0       !
        aw(1)=20.34      !
        z1(1)=1.012d+1   !
c                        ! Everything has been taken from
        z_a = 4.975d-1   !        W.Rhode Thesis
        ri_z = 1.49d-04  !
        x_0 = 2.88d-1    !
        x_1 = 3.196d+0   !
        a = 7.8d-2       !
        rm = 3.645d+0    !
        endif
c
c   Frejus rock ("composed medium" model), as it was incorporated in
c PROPMU code by W.Rhode (W.Rhode, private communication, October 2001)
c
        if (imed.eq.-13) then
        ro = 1.0d+0
        nsub = 10            !
        n(1) = 9.1800165d-3  ! -> C
        n(2) = 3.8712389d-2  ! -> O
        n(3) = 3.0446410d-4  ! -> Mg
        n(4) = 1.3342456d-3  ! -> Al
        n(5) = 3.6584715d-3  ! -> Si
        n(6) = 7.9523483d-5  ! -> S
        n(7) = 1.6650340d-4  ! -> K
        n(8) = 2.5955637d-3  ! -> Ca
        n(9) = 6.4072169d-6  ! -> Mn
        n(10) = 1.7417229d-4 ! -> Fe
        aw(1) = 12.11d+0
        aw(2) = 15.9994d+0
        aw(3) = 24.305d+0
        aw(4) = 26.981539d+0
        aw(5) = 28.0855d+0
        aw(6) = 32.066d+0
        aw(7) = 39.0983d+0
        aw(8) = 40.078d+0
        aw(9) = 54.93805d+0
        aw(10) = 55.847d+0
        z1(1) = 6.0d+0
        z1(2) = 8.0d+0
        z1(3) = 12.0d+0
        z1(4) = 13.0d+0
        z1(5) = 14.0d+0
        z1(6) = 16.0d+0
        z1(7) = 19.0d+0
        z1(8) = 20.0d+0
        z1(9) = 25.0d+0
        z1(10) = 26.0d+0
c
        z_a = 4.975d-1
        ri_z = 1.49d-04
        x_0 = 2.88d-1
        x_1 = 3.196d+0
        a = 7.8d-2
        rm = 3.645d+0
        endif
c
        ntot=0.d+0
        do i=1,nsub
        ntot=ntot+n(i) !----> ntot is total number of atoms in molecula
        enddo
        do i=1,nsub
        w(i)=n(i)/ntot !-----> w(i) are relative weights of different atoms
        enddo          !       w(i) = n(i) / ntot
c
        zmean=0.d+0
        do i=1,nsub
        zmean = zmean + (z1(i)*n(i))
        enddo
        zm = sngl(zmean/ntot) !-> mean charge of averaged atom (for Delec-s)
c
        a_ef = 0.d+0
        do i=1,nsub
        a_ef = a_ef + ((n(i)*aw(i))/ntot) !--> it is an effective atomic
        enddo                             !    weight for an averaged atom
c                                         !    for which diff. and total cros-
        return                            !    csections will be computed.
        end
****************************************************************************
* C.3_4
         SUBROUTINE spl14
*
       common /con_los4/ elosemin(17),elosvmin(17)
       common /eleng4/ eminleng(17)
       common /ctbr_in14/ FBC(17),FBC2(17)
       common /elbr_in14/ FBL(17),FBL2(17)
       common /elbr_in24/ FBL3(17)
       common /ctpa_in14/ FPC(17),FPC2(17)
       common /elpa_in14/ FPL(17),FPL2(17)
       common /elpa_in24/ FPL3(17)
       common /ctph_in14/ FNC(17),FNC2(65)
       common /elph_in14/ FNL(17),FNL2(65)
       common /elph_in24/ FNL3(17)
       common /ctel_in14/ FEC(17),FEC2(17)
       common /elel_in14/ FEL(17),FEL2(17)
       common /elel_in24/ FELBB(17),FELBBB(17)
       common /elel_in34/ FELOWTOT(101)
       common /sok344/ com_pa_m(2201)
       common /sok14/ xmin1_c,st1_c,xmax1_c
       common /eminl4/ xm1,s1,xma1
       common /sok54/ xmin1_l,st1_l,xmax1_l
       common /sok1n4/ xmin1_nc,st1_nc,xmax1_nc
       common /sok5n4/ xmin1_nl,st1_nl,xmax1_nl
       common /sok5et4/ xmin1_lo,st1_lo,xmax1_lo
       common /sok554/ xmin1_p,st1_p,xmax1_p
       common /sok1_b4/ CBC(19)
       common /sok5_b4/ CBL(19)
       common /sok1_b24/ CBC2(19)
       common /sok5_b24/ CBL2(19)
       common /sok5_b34/ CBL3(19)
       common /sok1_p4/ CPC(19)
       common /sok5_p4/ CPL(19)
       common /sok1_p24/ CPC2(19)
       common /sok5_p24/ CPL2(19)
       common /sok5_p34/ CPL3(19)
       common /sok1_n4/ CNC(19)
       common /sok5_n4/ CNL(19)
       common /sok1_n24/ CNC2(67)
       common /sok5_n24/ CNL2(67)
       common /sok5_n34/ CNL3(19)
       common /sok1_e4/ CEC(19)
       common /sok5_e4/ CEL(19)
       common /sok1_e24/ CEC2(19)
       common /sok5_e24/ CEL2(19)
       common /sok5_e34/ CEBB(19)
       common /sok5_e44/ CEBBB(19)
       common /elem4/ CLE(19)
       common /elvm4/ CLV(19)
       common /eminl14/ CLE1(19)
       common /sok5_e54/ CETOT(103)
       common /sok55_p4/ CPC1(2203)
       dimension IJ(26)
       dimension xmin1(26),st1(26),xmax1(26)
       dimension F(2201),C(2203)
      data xmin1/1.e+0,1.e+0,1.e+0,1.e+0,1.e+0,1.e+0,1.e+0,1.e+0,1.e+0,
     +           1.e+0,1.e+0,1.e+0,1.e+0,1.e+0,1.e+0,1.e+0,1.e+0,1.e+0,
     +           1.e+0,1.e+0,1.e+0,1.e+0,1.e+0,-1.1e+1,-.853871964,
     +           1.e+0/
      data xmax1/9.e+0,9.e+0,9.e+0,9.e+0,9.e+0,9.e+0,9.e+0,9.e+0,
     +           9.e+0,9.e+0,9.e+0,9.e+0,9.e+0,9.e+0,9.e+0,9.e+0,9.e+0,
     +           9.e+0,9.e+0,9.e+0,9.e+0,9.e+0,9.e+0,0.e+0,1.146128036,
     +           9.e+0/
      data st1/5.e-1,5.e-1,5.e-1,5.e-1,5.e-1,5.e-1,5.e-1,5.e-1,
     +         5.e-1,5.e-1,5.e-1,5.e-1,1.25e-1,1.25e-1,5.e-1,5.e-1,
     +         5.e-1,5.e-1,5.e-1,5.e-1,5.e-1,5.e-1,5.e-1,5.e-3,2.e-2,
     +         5.e-1/
      data IJ/17,17,17,17,17,17,17,17,17,17,17,17,65,65,
     +        17,17,17,17,17,17,17,17,17,2201,101,17/
c
      do lik=1,26  !--> A cycle along all input arrays
          N = IJ(lik)  !--> Getting dimension for given inpiut array
c
          if (lik.eq.1) then     ! GETTING FIRST VALUE,
           xmin1_c = xmin1(lik)  !      STEP AND LAST VALUE OF ARGUMENT
           st1_c = st1(lik)      !         FOR ALL INPUT ARRAYS
           xmax1_c = xmax1(lik)  !           IN ACCORING WITH THEIR NUMBERS
          endif                  !                     ( LIK )
          if (lik.eq.2) then     !
           xmin1_l = xmin1(lik)  !
           st1_l = st1(lik)      !
           xmax1_l = xmax1(lik)  !
          endif                  !
          if (lik.eq.13) then    !
           xmin1_nc = xmin1(lik) !
           st1_nc = st1(lik)     !
           xmax1_nc = xmax1(lik) !
          endif                  !
          if (lik.eq.14) then    !
           xmin1_nl = xmin1(lik) !
           st1_nl = st1(lik)     !
           xmax1_nl = xmax1(lik) !
          endif                  !
          if (lik.eq.24) then    !
           xmin1_p = xmin1(lik)  !
           st1_p = st1(lik)      !
           xmax1_p = xmax1(lik)  !
          endif                  !
          if (lik.eq.25) then    !
           xmin1_lo = xmin1(lik) !
           st1_lo = st1(lik)     !
           xmax1_lo = xmax1(lik) !
          endif                  !
          if (lik.eq.26) then    !
           xm1 = xmin1(lik)      !
           s1 = st1(lik)         !
           xma1 = xmax1(lik)     !
          endif                  !
c                                ---------------
          do jj=1,N                            !
            if (lik.eq.1) F(jj) = FBC(jj)      !
            if (lik.eq.2) F(jj) = FBL(jj)      !
            if (lik.eq.3) F(jj) = FBC2(jj)     ! Filling the auxiliary array
            if (lik.eq.4) F(jj) = FBL2(jj)     ! F with values of input array
            if (lik.eq.5) F(jj) = FBL3(jj)     ! number LIK for further
            if (lik.eq.6) F(jj) = FPC(jj)      !                processing.
            if (lik.eq.7) F(jj) = FPL(jj)      !
            if (lik.eq.8) F(jj) = FPC2(jj)     !
            if (lik.eq.9) F(jj) = FPL2(jj)     !
            if (lik.eq.10) F(jj) = FPL3(jj)    !
            if (lik.eq.11) F(jj) = FNC(jj)     !
            if (lik.eq.12) F(jj) = FNL(jj)     !
            if (lik.eq.13) F(jj) = FNC2(jj)    !
            if (lik.eq.14) F(jj) = FNL2(jj)    !
            if (lik.eq.15) F(jj) = FNL3(jj)    !
            if (lik.eq.16) F(jj) = FEC(jj)     !
            if (lik.eq.17) F(jj) = FEL(jj)     !
            if (lik.eq.18) F(jj) = FEC2(jj)    !
            if (lik.eq.19) F(jj) = FEL2(jj)    !
            if (lik.eq.20) F(jj) = FELBB(jj)   !
            if (lik.eq.21) F(jj) = FELBBB(jj)  !
            if (lik.eq.22) F(jj) = elosemin(jj)!
            if (lik.eq.23) F(jj) = elosvmin(jj)!
            if (lik.eq.24) F(jj) = com_pa_m(jj)!
            if (lik.eq.25) F(jj) = FELOWTOT(jj)!
            if (lik.eq.26) F(jj) = eminleng(jj)!
           enddo                               !
c----------------------------------------------!
      C(1)=1.4375*F(1)-1.3750*F(2)+0.4375*F(3)  !
      C(2)=0.4375*F(1)+0.1250*F(2)-0.0625*F(3)    !
      DO 1 K=3,N                                    ! ---> Cooking splayns
1     C(K)= 0.6250*F(K-1)-0.0625*(F(K-2)+F(K))       ! and putting them into
      C(N+1)=0.4375*F(N)+0.1250*F(N-1)-0.0625*F(N-2) !  auxiliary array C
      C(N+2)=1.4375*F(N)-1.375*F(N-1)+0.4375*F(N-2)  !
c----------------------------------------------------
         mo = N+2                          !
         do jj=1,mo                        ! Splain coefficients from C are
           if (lik.eq.1) CBC(jj) = C(jj)   ! put into corresponding array N LIK
           if (lik.eq.2) CBL(jj) = C(jj)   ! which is passed to corresponding
           if (lik.eq.3) CBC2(jj) = C(jj)  ! subroutine for interpolation.
           if (lik.eq.4) CBL2(jj) = C(jj)  !
           if (lik.eq.5) CBL3(jj) = C(jj)  !
           if (lik.eq.6) CPC(jj) = C(jj)   !
           if (lik.eq.7) CPL(jj) = C(jj)   !
           if (lik.eq.8) CPC2(jj) = C(jj)  !
           if (lik.eq.9) CPL2(jj) = C(jj)  !
           if (lik.eq.10) CPL3(jj) = C(jj) !
           if (lik.eq.11) CNC(jj) = C(jj)  !
           if (lik.eq.12) CNL(jj) = C(jj)  !
           if (lik.eq.13) CNC2(jj) = C(jj) !
           if (lik.eq.14) CNL2(jj) = C(jj) !
           if (lik.eq.15) CNL3(jj) = C(jj) !
           if (lik.eq.16) CEC(jj) = C(jj)  !
           if (lik.eq.17) CEL(jj) = C(jj)  !
           if (lik.eq.18) CEC2(jj) = C(jj) !
           if (lik.eq.19) CEL2(jj) = C(jj) !
           if (lik.eq.20) CEBB(jj) = C(jj) !
           if (lik.eq.21) CEBBB(jj) = C(jj)!
           if (lik.eq.22) CLE(jj) = C(jj)  !
           if (lik.eq.23) CLV(jj) = C(jj)  !
           if (lik.eq.24) CPC1(jj) = C(jj) !
           if (lik.eq.25) CETOT(jj) = C(jj)!
           if (lik.eq.26) CLE1(jj) = C(jj) !
         enddo                             !
      enddo
      RETURN
      END
****************************************************************************
* C.4_4
      SUBROUTINE dspl14
*
      real*8 com_pa_in(1101)
      real*8 CP_1(1103)
      real*8 xmin_p1,st_p1,xmax_p1
      real*8 xmin1(1),st1(1),xmax1(1)
      real*8 F(1101),C(1103)
      common /sok244/ com_pa_in
      common /sok264/ CP_1
      common /sok254/ xmin_p1,st_p1,xmax_p1
      dimension IJ(1)
      data xmin1/-1.1d+1/
      data xmax1/0.d+0/
      data st1/1.d-2/
      data IJ/1101/
c
      do lik=1,1  !--> A cycle along all input arrays
          N = IJ(lik) !--> Getting dimension for given input array
c
          if (lik.eq.1) then     ! GETTING FIRST VALUE, STEP AND LAST VALUE
           xmin_p1 = xmin1(lik)  ! OF ARGUMENTS FOR ALL INPUT ARRAYS IN
           st_p1 = st1(lik)      ! ACCORDING TO THEIR NUMBERS (LIK)
           xmax_p1 = xmax1(lik)  !
          endif                  !
c
          do jj=1,N                             ! Filling the auxiliary array F
            if (lik.eq.1) F(jj) = com_pa_in(jj) ! with values of corresponding
          enddo                                 ! input array Nb. LIK
c
      C(1)=1.4375*F(1)-1.3750*F(2)+0.4375*F(3)        !
      C(2)=0.4375*F(1)+0.1250*F(2)-0.0625*F(3)        ! Cookiing splain
      DO 1 K=3,N                                      ! coefficients and
1     C(K)= 0.6250*F(K-1)-0.0625*(F(K-2)+F(K))        ! putting them into
      C(N+1)=0.4375*F(N)+0.1250*F(N-1)-0.0625*F(N-2)  ! auxiliary array C
      C(N+2)=1.4375*F(N)-1.375*F(N-1)+0.4375*F(N-2)   !
c
         mo = N+2                         ! Splain coefficients from C are
         do jj=1,mo                       ! put into corresponding output
           if (lik.eq.1) CP_1(jj) = C(jj) ! array Nb. LIK whic is passe to
         enddo                            ! corresponding subroutine
c                                         ! for interpolation
      enddo
      RETURN
      END
****************************************************************************
* C.5_4
         SUBROUTINE spl24
*
      common /cdbr_in4/ FB1(81,54),FB3(81,101),FB2(81,51)
      common /cdpa_in4/ FP1(81,54),FP3(81,101),FP2(81,51)
      common /cdph_in4/ FN1(81,54),FN3(81,101),FN2(81,51)
      common /sok3_4/ CB1(4648)
      common /sok64/ CB2(4399)
      common /sok44/ CB3(8549)
      common /sok84/ CP1(4648)
      common /sok94/ CP2(4399)
      common /sok104/ CP3(8549)
      common /mum84/ CN1(4648)
      common /mum94/ CN2(4399)
      common /mum104/ CN3(8549)
      common /sok_2_14/ NX_1,NY_1,X0_1,SX_1,Y0_1,SY_1
      common /sok_2_24/ NX_2,NY_2,X0_2,SX_2,Y0_2,SY_2
      common /sok_2_34/ NX_3,NY_3,X0_3,SX_3,Y0_3,SY_3
      DIMENSION D(90,110),FU(81,101),CU(8549)
      DIMENSION NXG(9),NYG(9),X0G(9),SXG(9),Y0G(9),SYG(9)
      DIMENSION IJ(9)
      data NXG/81,81,81,81,81,81,81,81,81/
      data NYG/54,51,101,54,51,101,54,51,101/
      data X0G/1.e+0,1.e+0,1.e+0,1.e+0,1.e+0,1.e+0,1.e+0,1.e+0,1.e+0/
      data SXG/1.e-1,1.e-1,1.e-1,1.e-1,1.e-1,1.e-1,1.e-1,1.e-1,1.e-1/
      data Y0G/-11.,-6.e-1,-1.e-1,-11.,-6.e-1,-1.e-1,-11.,-6.e-1,-1.e-1/
      data SYG/2.e-1,1.e-2,1.e-3,2.e-1,1.e-2,1.e-3,2.e-1,1.e-2,1.e-3/
      data IJ/4648,4399,8549,4648,4399,8549,4648,4399,8549/
c
      do li=1,9
      NX = NXG(li)
      NY = NYG(li)
      X0 = X0G(li)
      SX = SXG(li)
      Y0 = Y0G(li)
      SY = SYG(li)
c
       if (li.eq.1) then
         NX_1 = NX
         NY_1 = NY
         X0_1 = X0
         SX_1 = SX
         Y0_1 = Y0
         SY_1 = SY
       endif
c
       if (li.eq.2) then
         NX_2 = NX
         NY_2 = NY
         X0_2 = X0
         SX_2 = SX
         Y0_2 = Y0
         SY_2 = SY
       endif
c
       if (li.eq.3) then
         NX_3 = NX
         NY_3 = NY
         X0_3 = X0
         SX_3 = SX
         Y0_3 = Y0
         SY_3 = SY
       endif
c
        do ki=1,NX
           do kl=1,NY
              if (li.eq.1) FU(ki,kl) = FB1(ki,kl)
              if (li.eq.2) FU(ki,kl) = FB2(ki,kl)
              if (li.eq.3) FU(ki,kl) = FB3(ki,kl)
              if (li.eq.4) FU(ki,kl) = FP1(ki,kl)
              if (li.eq.5) FU(ki,kl) = FP2(ki,kl)
              if (li.eq.6) FU(ki,kl) = FP3(ki,kl)
              if (li.eq.7) FU(ki,kl) = FN1(ki,kl)
              if (li.eq.8) FU(ki,kl) = FN2(ki,kl)
              if (li.eq.9) FU(ki,kl) = FN3(ki,kl)
           enddo
        enddo
cccccccc 2019 - ATTENTION!
      I2=1
cccccccc
      DO 1 J=1,NY
      J2=J+2
      DO 1 I=1,NX
      I2=I+2
1     D(I2,J2)=3.90625E-3*FU(I,J)
      J1=NY+1
      J3=J2+1
      J4=J3+1
      DO 2 I=3,I2
      A=D(I,3)
      B=D(I,4)
      D(I,2)=3.*(A-B)+D(I,5)
      D(I,1)=3.*(D(I,2)-A)+B
      A=D(I,J1)
      B=D(I,J2)
      D(I,J3)=3.*(B-A)+D(I,NY)
2     D(I,J4)=3.*(D(I,J3)-B)+A
      I1=NX+1
      I3=I2+1
      I4=I3+1
      DO 3 J=1,J4
      A=D(3,J)
      B=D(4,J)
      D(2,J)=3.*(A-B)+D(5,J)
      D(1,J)=3.*(D(2,J)-A)+B
      A=D(I1,J)
      B=D(I2,J)
      D(I3,J)=3.*(B-A)+D(NX,J)
3     D(I4,J)=3.*(D(I3,J)-B)+A
      DO 4 J=1,J2
      J3=J+1
      J4=J+2
      M=(J-1)*I2
      DO 4 I=1,I2
      I3=I+1
      I4=I+2
4     CU(M+I)=D(I,J)+D(I,J4)+D(I4,J)+D(I4,J4)+D(I3,J3)* !
     *100.-(D(I3,J)+D(I,J3)+D(I4,J3)+D(I3,J4))*10.      !
c
       ko = IJ(li)
       do ki=1,ko
              if (li.eq.1) CB1(ki) = CU(ki)
              if (li.eq.2) CB2(ki) = CU(ki)
              if (li.eq.3) CB3(ki) = CU(ki)
              if (li.eq.4) CP1(ki) = CU(ki)
              if (li.eq.5) CP2(ki) = CU(ki)
              if (li.eq.6) CP3(ki) = CU(ki)
              if (li.eq.7) CN1(ki) = CU(ki)
              if (li.eq.8) CN2(ki) = CU(ki)
              if (li.eq.9) CN3(ki) = CU(ki)
       enddo
      enddo
      RETURN
      END
****************************************************************************
* C.6_4
        SUBROUTINE enlos4
*
c FROM GAMMA14:
      common /elbr_in14/ elo_br1(17),elo_br2(17)
      common /elbr_in24/ elo_br3(17)
      common /elbr_in44/ elo_br4(17)
      common /ctbr_in14/ crt_br1(17),crt_br2(17)
c FROM PAIR14
      common /elpa_in14/ elo_pa1(17),elo_pa2(17)
      common /elpa_in24/ elo_pa3(17)
      common /elpa_in44/ elo_pa4(17)
      common /ctpa_in14/ crt_pa1(17),crt_pa2(17)
c FROM PHNU14:
      common /elph_in14/ elo_ph1(17),elo_ph2(65)
      common /elph_in24/ elo_ph3(17)
      common /elph_in44/ elo_ph4(17)
      common /ctph_in14/ crt_ph1(17),crt_ph2(65)
c FROM ELEC14:
      common /elel_in14/ elo_el1(17),elo_el2(17)
      common /elel_in24/ elel_bb(17),elel_bbb(17)
      common /ctel_in14/ crt_el1(17),crt_el2(17)
c TO SPL14:
      common /con_los4/ elosemin(17),elosvmin(17)
      common /eleng4/ eminleng(17)
c                    ----------------------------
      do i=1,17
       j = (4 * i) - 3
       elosemin(i) = elo_br4(i)
       elosvmin(i) = (1.e+1**elo_br3(i)) - (1.e+1**elo_br2(i))
       elosemin(i) = elosemin(i) + elo_pa4(i)
       elosvmin(i) = elosvmin(i) + exp(elo_pa3(i)) - exp(elo_pa2(i))
       elosemin(i) = elosemin(i) + elo_ph4(i)
       elosvmin(i) = elosvmin(i) + 1.e+1**elo_ph3(i) - 1.e+1**elo_ph2(j)
       elosemin(i) = elosemin(i) + elel_bbb(i) - 1.e+1**elo_el1(i)
       elosvmin(i) = elosvmin(i) + elel_bbb(i) - 1.e+1**elo_el2(i)
       elosvmin(i) = alog(elosvmin(i))
       eminleng(i) = 1./crt_br1(i) + 1./exp(crt_pa1(i)) +
     +                              1./exp(crt_ph1(i)) + 1./crt_el1(i)
       eminleng(i) = 1./eminleng(i)
      enddo
      return
      end
****************************************************************************
* C.7_4
             FUNCTION cone4(X)
*
      real*4 X
      COMMON /sok54/ XMIN,STEP,XMAX
      common /elem4/ C(19)
      X1 = alog10(X)
       if ((X1.lt..99999e+0).or.(X1.gt.9.0001e+0)) then
       print*,'ERROR IN FUNCTION CONES: MUON ENERGY IS OUT OF RANGE'
       endif
      Y = (X1-XMIN)/STEP
      I = INT(Y+0.5)
      IF(I.LT.0.OR.X1.GT.XMAX) PRINT 1,X1,XMIN,XMAX
      Y = Y-I
      Z = Y*Y + 0.25
      cone4 = (Z-Y)*C(I+1) + (2.-(Z+Z))*C(I+2) + (Z+Y)*C(I+3)
      RETURN
1     FORMAT('*MISTAKE*X1=',D23.16,'XMIN=',D23.16,'XMAX=',D23.16)
      END
****************************************************************************
* C.8_4
             FUNCTION conv4(X)
*
      real*4 X
      COMMON /sok54/ XMIN,STEP,XMAX
      common /elvm4/ C(19)
      X1 = alog10(X)
       if ((X1.lt..99999e+0).or.(X1.gt.9.0001e+0)) then
       print*,'ERROR IN FUNCTION CONVS: MUON ENERGY IS OUT OF RANGE'
       endif
      Y = (X1-XMIN)/STEP
      I = INT(Y+0.5)
      IF(I.LT.0.OR.X1.GT.XMAX) PRINT 1,X1,XMIN,XMAX
      Y = Y-I
      Z = Y*Y + 0.25
      conv4 = (Z-Y)*C(I+1) + (2.-(Z+Z))*C(I+2) + (Z+Y)*C(I+3)
      conv4 = exp(conv4)
      RETURN
1     FORMAT('*MISTAKE*X1=',D23.16,'XMIN=',D23.16,'XMAX=',D23.16)
      END
****************************************************************************
* C.9_4
         FUNCTION gemleng4(X)
*
      real*4 X
      COMMON /eminl4/ XMIN,STEP,XMAX
      common /eminl14/ C(19)
      X1 = alog10(X)
       if ((X1.lt..99999e+0).or.(X1.gt.9.0001e+0)) then
       print*,'ERROR IN FUNCTION GEMLENGS: MUON ENERGY IS OUT OF RANGE'
       endif
      Y = (X1-XMIN)/STEP
      I = INT(Y+0.5)
      IF(I.LT.0.OR.X1.GT.XMAX) PRINT 1,X1,XMIN,XMAX
      Y = Y-I
      Z = Y*Y + 0.25
      gemleng4= (Z-Y)*C(I+1) + (2.-(Z+Z))*C(I+2) + (Z+Y)*C(I+3)
      RETURN
1     FORMAT('*MISTAKE*X1=',D23.16,'XMIN=',D23.16,'XMAX=',D23.16)
      END
************************************************************************
* C.10_4
      subroutine frepathv4
*
      external glbremv4,glpairv4,glphnuv4,glelecv4,conv4
      external dsimps,gdedelt24
      real*8 e0(0:128),a(0:128),b(0:128),eta(0:128),leng(0:128)
      real*8 fk,fk1,dlnmax,slu,e,en,delta
      real*8 low,up,step1,aux1(0:10),rest,eta_1,hd3,pat1,pat2
      real*8 ene,path
      real*8 dsimps
      common /vrand14/ vpath(111,161)
      common /vrand24/ vener(111,161)
      common /simv14/ fk,fk1,dlnmax,a,b,leng,e0
c
c   ---------------------------------------------------------------
c   1. Computing arrays e0(0:128), a(0:128), b(0:128), eta(0:128),
c           leng(0:128) and constants FK, FK1 and DLNMAX
c
      fk=dexp(-(dlog(1.d+1)/1.6d+1)) !--> a coefficient to get
      fk1 = 1.d+0 / dlog(fk)         !    e0(i)=fk*e0(i-1) and
      dlnmax = dlog(1.d+9)           !    some useful constants
c
      e0(0) = 1.d+9
        do i=1,128
        e0(i) = e0(0) * (fk**dble(i))         !-> e0(i)
        y2 = (conv4(sngl(e0(i-1))) * 1.e-3)    !-> dE/dx (e0(i-1))
        y1 = (conv4(sngl(e0(i))) * 1.e-3)      !-> dE/dx (e0(i))
        a(i) = dble((y2 - y1)) / (e0(i-1) - e0(i)) !-> a(i)
        b(i) = dble(y1) - a(i) * e0(i)             !-> b(i)
c
c                     Computing two integrals
c
c       ..................................................
c       .             e0(i-1)                            .
c       .   eta(i) = INTEGRAL(dE/(dE/dx(E) * L_mean(E))  .
c       .              e0(i)                             .
c       .                                                .
c       .                  e0(i-1)                       .
c       .       leng(i) = INTEGRAL (dE/(dE/dx(E)))       .
c       .                  e0(i)                         .
c       ..................................................
c
c using a formula INTEGRAL [f(x) * dx] = INTEGRAL [x * f(x) * d(ln(x))] :
c
        low = dlog(e0(i))
        up = dlog(e0(i-1))
        lim1 = 10
        step1 = (up - low) / dble(lim1)
         do j=0,lim1
         ene = low + (dble(j) * step1)
         h1 = sngl(dexp(ene))
         help=(1./glbremv4(h1))+(1./glpairv4(h1))+(1./glphnuv4(h1)) +
     +           (1./glelecv4(h1))
         aux1(j) = (1.d+0 / dble(help))*dble(conv4(h1))*1.d-3/dble(h1)
         aux1(j) = 1.d+0 / aux1(j)
         enddo
         eta(i) = dsimps(aux1,low,up,lim1)
c
         do j=0,lim1
         ene = low + (dble(j) * step1)
         h1 = sngl(dexp(ene))
         aux1(j) = dble(conv4(h1)) * 1.d-3 / dble(h1)
         aux1(j) = 1.d+0 / aux1(j)
         enddo
         leng(i) = dsimps(aux1,low,up,lim1)
        enddo
c
      do i=127,1,-1
c
c              e0(i-1)
c   leng(i) = INTEGRAL (dE/(dE/dx(E))) :
c              10 GeV
c
      leng(i) = leng(i) + leng(i+1)
c
c            e0(i-1)
c  eta(i) = INTEGRAL(dE/(dE/dx(E) * L_mean(E))) :
c            10 GeV
c
      eta(i) = eta(i) + eta(i+1)
      enddo
c
c   Auxiliary arrays a(128), b(128), e0(128), eta(128), leng(128)
c                    have been prepared.
c   ---------------------------------------------------------------
c                       2. Solving the equation (3)
c
c  to get the final energy E1 for a set of E0 ("e" variable) and
c                        ETA ("slu" variable):
c
      do i=-80,30             !--> 111 values of SLU (logarithmi-
        slu = dble(i) * 5.d-2 !    cally equidestant grid with
        slu = 1.d+1**slu      !    slu_min=0.0001, slu_max=1000
        do j=180,20,-1         !-> 161 values of E (logarithmi-
          e = dble(j) * 5.d-2  !   cally equidestant grid with
          e = 1.d+1**e         !   e_min = 10 GeV, e_max = 1 EeV
            if (e.le.1.011d+1) then
            ene = 1.0000001d+1
            path = 0.d+0
            goto 444
            endif
c        vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv
          me = idint( ( dlog(e) - dlog(1.d+9) ) / dlog(fk) ) + 1
c        ME is a number of segment which contains given energy E
c        ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
c                       Rewriting the equation (3) as
c
c                   E0         E0         E1
c                INTEGRAL = INTEGRAL - INTEGRAL = ETA  (3a)
c                   E1       10 GeV     10 GeV
c
c                                 or
c
c                     E1         E0
c                  INTEGRAL = INTEGRAL - ETA = ETA_1   (3b)
c                   10 GeV     10 GeV
c
            if (me.lt.128) then
            eta_1 = eta(me+1) - slu
            else
            eta_1 = (-1.d+0) * slu
            endif
        low = dlog(e0(me))
        up = dlog(e)
        lim1 = 10
        step1 = (up - low) / dble(lim1)
         do j1=0,lim1
         en = low + (dble(j1) * step1)
         h1 = sngl(dexp(en))
         help =(1./glbremv4(h1))+(1./glpairv4(h1))+(1./glphnuv4(h1)) +
     +           (1./glelecv4(h1))
         aux1(j1)=(1.d+0 / dble(help))*dble(conv4(h1))*1.d-3/dble(h1)
         aux1(j1) = 1.d+0 / aux1(j1)
         enddo
         eta_1 = eta_1 + dsimps(aux1,low,up,lim1)
c---------------------------------
        if (eta_1.le.0.d+0) then !
        ene = 1.0000001d+1       !--> no interactions with energy transfers
        m1 = 128                 !              transfers > Vmin,
        goto 402                 !         the final energy is 10 GeV
        endif                    !
c---------------------------------
            m1 = 500
            do m=128,1,-1
              if (eta(m).ge.eta_1) then
              m1 = m
              goto 401
              endif
            enddo
          if (m1.ge.200) then
          hd3 = dabs((eta(1) - eta_1) / eta(1))
             if (hd3.le.1.d-6) then
             m1 = 1
             eta_1 = eta(1)*9.9999999d-1
             goto 401
             endif
          print*,'******** SUBROUTINE FREPATV:  ERROR !!!!! ********'
          goto 402
          endif
  401     continue
            if (m1.lt.128) then
            rest = eta_1 - eta(m1+1)
            else
            rest = eta_1
            endif
c
         ic = 0
         lim1 = 10
         ene = (e0(m1-1) + e0(m1)) * 5.d-1
         delta = e0(m1-1) - ene
         low = dlog(e0(m1))
 3333    up = dlog(ene)
         step1 = (up - low) / dble(lim1)
         do j1=0,lim1
         en = low + (dble(j1) * step1)
         h1 = sngl(dexp(en))
         help=(1./glbremv4(h1))+(1./glpairv4(h1))+(1./glphnuv4(h1)) +
     +           (1./glelecv4(h1))
         aux1(j1)=(1.d+0 / dble(help))*dble(conv4(h1))*1.d-3/dble(h1)
         aux1(j1) = 1.d+0 / aux1(j1)
         enddo
         pat1 = dsimps(aux1,low,up,lim1)
         delta = 5.d-1 * delta
         ic = ic + 1
         if (pat1.le.rest) then
         ene = ene + delta
         else
         ene = ene - delta
         endif
         if (ic.eq.20) then
         goto 402
         endif
         goto 3333
 402     continue
c
c            Equation (3) has been solved., the root is ENE
c   ---------------------------------------------------------------
c            3. Computing of real free path from E0 to ENE:
c
c                            E0
c                  PATH = INTEGRAL [ dE/(dE/dx(E)) ] =
c                            ENE
c
c          E0                          ENE
c     = INTEGRAL [ dE/(dE/dx(E)) ] - INTEGRAL [ dE/(dE/dx(E)) ]
c        10 GeV                       10 GeV
c
      if (me.lt.128) then
        low = dlog(e0(me))
        up = dlog(e)
        lim1 = 10
        step1 = (up - low) / dble(lim1)
         do j2=0,lim1
         en = low + (dble(j2) * step1)
         h1 = sngl(dexp(en))
         aux1(j2) = dble(conv4(h1)) * 1.d-3 / dble(h1)
         aux1(j2) = 1.d+0 / aux1(j2)
         enddo
         pat1 = dsimps(aux1,low,up,lim1) + leng(me+1)
      else
        low = dlog(e0(me))
        up = dlog(e)
        lim1 = 10
        step1 = (up - low) / dble(lim1)
         do j2=0,lim1
         en = low + (dble(j2) * step1)
         h1 = sngl(dexp(en))
         aux1(j2) = dble(conv4(h1)) * 1.d-3 / dble(h1)
         aux1(j2) = 1.d+0 / aux1(j2)
         enddo
         pat1 = dsimps(aux1,low,up,lim1)
      endif
c
      if (m1.lt.128) then
        low = dlog(e0(m1))
        up = dlog(ene)
        lim1 = 10
        step1 = (up - low) / dble(lim1)
         do j2=0,lim1
         en = low + (dble(j2) * step1)
         h1 = sngl(dexp(en))
         aux1(j2) = dble(conv4(h1)) * 1.d-3 / dble(h1)
         aux1(j2) = 1.d+0 / aux1(j2)
         enddo
         pat2 = dsimps(aux1,low,up,lim1) + leng(m1+1)
      else
        low = dlog(e0(m1))
        up = dlog(ene)
        lim1 = 10
        step1 = (up - low) / dble(lim1)
         do j2=0,lim1
         en = low + (dble(j2) * step1)
         h1 = sngl(dexp(en))
         aux1(j2) = dble(conv4(h1)) * 1.d-3 / dble(h1)
         aux1(j2) = 1.d+0 / aux1(j2)
         enddo
         pat2 = dsimps(aux1,low,up,lim1)
      endif
      path = pat1 - pat2
c
c          The equation is solved, the root is PATH
c
  444 continue
      if (path.le.0.d+0) path = 1.d+0
      if (ene.le.1.00001d+1) ene = 9.999d+0
      path = path/slu
      ene = ene / e
      vpath(i+81,j-19) = sngl(path)
      vener(i+81,j-19) = sngl(ene)
        enddo
      enddo
c
      return
      end
****************************************************************************
* C.11_4
         SUBROUTINE spl2_24
*
      common /vrand14/ vpath(111,161)
      common /vrand24/ vener(111,161)
      common /vrand1_o4/ CPA(18419)
      common /vrand2_o4/ CEN(18419)
      common /vpath14/ NX_1,NY_1,X0_1,SX_1,Y0_1,SY_1
      common /vpath24/ NX_2,NY_2,X0_2,SX_2,Y0_2,SY_2
      DIMENSION D(130,180),FU(111,161),CU(18419)
      DIMENSION NXG(2),NYG(2),X0G(2),SXG(2),Y0G(2),SYG(2)
      DIMENSION IJ(2)
c
      data NXG/111,111/
      data NYG/161,161/
      data X0G/-4.,-4./
      data SXG/5.e-2,5.e-2/
      data Y0G/1.,1./
      data SYG/5.e-2,5.e-2/
      data IJ/18419,18419/
c
      do li=1,2     ! A cycle along all input arrays
      NX = NXG(li)  ! assigns values from corresonding arrais for numbers of
      NY = NYG(li)  ! values, steps and initial values
      X0 = X0G(li)  !
      SX = SXG(li)  !
      Y0 = Y0G(li)  !
      SY = SYG(li)  !
c
       if (li.eq.1) then
         NX_1 = NX     !-> number of X values
         NY_1 = NY     !-> number of Y values
         X0_1 = X0     !-> first value of X
         SX_1 = SX     !-> step by X
         Y0_1 = Y0     !-> first value of Y
         SY_1 = SY     !-> step by Y
       endif
c
       if (li.eq.2) then
         NX_2 = NX    !-> number of X values
         NY_2 = NY    !-> number of Y values
         X0_2 = X0    !-> first value of X
         SX_2 = SX    !-> step by X
         Y0_2 = Y0    !-> first value of Y
         SY_2 = SY    !-> step by Y
       endif
c
        do ki=1,NX                                ! Filling an auxiliary
           do kl=1,NY                              ! array FU by values
              if (li.eq.1) FU(ki,kl) = vpath(ki,kl) ! from input array
              if (li.eq.2) FU(ki,kl) = vener(ki,kl) ! (within a cycle by
c                                                  ! LI along all input
c                                                 ! arrays)
           enddo                                 !
        enddo                                   !
cccccccc 2019 - ATTENTION!
      I2=1
cccccccc
c-----------------------------------------------
      DO 1 J=1,NY                  !
      J2=J+2                       !
      DO 1 I=1,NX                  !
      I2=I+2                       !
1     D(I2,J2)=3.90625E-3*FU(I,J)  !
      J1=NY+1                      !
      J3=J2+1                      !
      J4=J3+1                      !
      DO 2 I=3,I2                  !
      A=D(I,3)                     !
      B=D(I,4)                     !---> Cooking splain coefficients
      D(I,2)=3.*(A-B)+D(I,5)       !     out of input array Nb. LI
      D(I,1)=3.*(D(I,2)-A)+B       !     and putting these splains
      A=D(I,J1)                    !     into 1-dimensional array
      B=D(I,J2)                    !                 CU
      D(I,J3)=3.*(B-A)+D(I,NY)     !
2     D(I,J4)=3.*(D(I,J3)-B)+A     !
      I1=NX+1                      !
      I3=I2+1                      !
      I4=I3+1                      !
      DO 3 J=1,J4                  !
      A=D(3,J)                     !
      B=D(4,J)                     !
      D(2,J)=3.*(A-B)+D(5,J)       !
      D(1,J)=3.*(D(2,J)-A)+B       !
      A=D(I1,J)                    !
      B=D(I2,J)                    !
      D(I3,J)=3.*(B-A)+D(NX,J)       !
3     D(I4,J)=3.*(D(I3,J)-B)+A         !
      DO 4 J=1,J2                        !
      J3=J+1                               !
      J4=J+2                                 !
      M=(J-1)*I2                               !
      DO 4 I=1,I2                                !
      I3=I+1                                       !
      I4=I+2                                         !
4     CU(M+I)=D(I,J)+D(I,J4)+D(I4,J)+D(I4,J4)+D(I3,J3)* !
     *100.-(D(I3,J)+D(I,J3)+D(I4,J3)+D(I3,J4))*10.      !
c--------------------------------------------------------
       ko = IJ(li)
       do ki=1,ko                            !
              if (li.eq.1) CPA(ki) = CU(ki)  ! Passing the values of splain
              if (li.eq.2) CEN(ki) = CU(ki)  ! coefficients form auxiliary
c                                            ! array CU to corresponding
c                                            ! output array Nb. LI
       enddo                                 !
      enddo
      RETURN
      END
****************************************************************************
* C.12_4
       FUNCTION getlanrv4(X,Y)
*
       real*4 X,Y
       common /vrand1_o4/ C1(18419)
       common /vpath14/ NX,NY,X0,SX,Y0,SY
c
      X_1=alog10(X)
      if ((X_1.lt.-4.0001).or.(X_1.gt.1.5001)) then
      print*,'ERROR IN FUNCTION GETLANRVS: RANDOM NB. IS OUT OF RANGE'
      endif
c
      Y_1=alog10(Y)
      if ((Y_1.lt..99999).or.(Y_1.gt.9.0001)) then
      print*,'ERROR IN FUNCTION GETLANRVS: MUON ENERGY IS OUT OF RANGE'
      endif
c
      A3=(X_1-X0)/SX
      B3=(Y_1-Y0)/SY
      M1=INT(A3+.5)
      M2=INT(B3+.5)
      M3=NX+2
      IF(M1.LT.0.OR.M1.GE.NX.OR.M2.LT.0.OR.M2.GE.NY) THEN
      PRINT 1,X_1,M1,Y_1,M2
      ENDIF
      A3=A3-M1
      B3=B3-M2
      M1=M2*M3+M1+1
      M2=M1+M3
      M3=M2+M3
      A2 = A3*A3 +.25
      B2 = B3*B3 +.25
      A1=A2-A3
      B1=B2-B3
      A3=A2+A3
      B3=B2+B3
      A2=2.-(A2+A2)
      B2=2.-(B2+B2)
      getlanrv4=(A1*C1(M1)+A2*C1(M1+1)+A3*C1(M1+2))*B1
     2      +(A1*C1(M2)+A2*C1(M2+1)+A3*C1(M2+2))*B2
     3      +(A1*C1(M3)+A2*C1(M3+1)+A3*C1(M3+2))*B3
      getlanrv4 = getlanrv4 * X
      RETURN
1     FORMAT('*MISTAKE*X=',D23.16,'MX=',I4,'Y=',D23.16,'MY=',I4)
      END
****************************************************************************
* C.13_4
       FUNCTION geteranv4(X,Y)
*
       real*4 X,Y
       common /vrand2_o4/ C1(18419)
       common /vpath24/ NX,NY,X0,SX,Y0,SY
c
      X_1=alog10(X)
      if ((X_1.lt.-4.0001).or.(X_1.gt.1.5001)) then
      print*,'ERROR IN FUNCTION GETERANVS: RANDOM NB. IS OUT OF RANGE'
      endif
c
      Y_1=alog10(Y)
      if ((Y_1.lt..99999).or.(Y_1.gt.9.0001)) then
      print*,'ERROR IN FUNCTION GETERANVS: MUON ENERGY IS OUT OF RANGE'
      endif
c
      A3=(X_1-X0)/SX
      B3=(Y_1-Y0)/SY
      M1=INT(A3+.5)
      M2=INT(B3+.5)
      M3=NX+2
      IF(M1.LT.0.OR.M1.GE.NX.OR.M2.LT.0.OR.M2.GE.NY) THEN
      PRINT 1,X_1,M1,Y_1,M2
      ENDIF
      A3=A3-M1
      B3=B3-M2
      M1=M2*M3+M1+1
      M2=M1+M3
      M3=M2+M3
      A2 = A3*A3 +.25
      B2 = B3*B3 +.25
      A1=A2-A3
      B1=B2-B3
      A3=A2+A3
      B3=B2+B3
      A2=2.-(A2+A2)
      B2=2.-(B2+B2)
      geteranv4=(A1*C1(M1)+A2*C1(M1+1)+A3*C1(M1+2))*B1
     2      +(A1*C1(M2)+A2*C1(M2+1)+A3*C1(M2+2))*B2
     3      +(A1*C1(M3)+A2*C1(M3+1)+A3*C1(M3+2))*B3
      RETURN
1     FORMAT('*MISTAKE*X=',D23.16,'MX=',I4,'Y=',D23.16,'MY=',I4)
      END
****************************************************************************
* C.14_4
      function geteback4(e1,backl)
*
      real*8 fk,fk1,dlnmax,a(0:128),b(0:128),leng(0:128),e0(0:128)
      real*8 e,ene,rest,pat1,path
      real*4 e1,backl
      common /simv14/ fk,fk1,dlnmax,a,b,leng,e0
c
          e = dble(e1)
          path = dble(backl)
          if (e.ge.1.d+9) then
          ene = 1.00001+9
          goto 1402
          endif
        me = idint( ( dlog(e) - dlnmax ) * fk1 )  + 1
        if (me.gt.128) me = 128
            if (me.lt.128) then
            pat1 = leng(me+1) + path
            else
            pat1 = path
            endif
c
            pat1=pat1+dlog((a(me)*e+b(me))/(a(me)*e0(me)+b(me)))/a(me)
c
            m1 = 500
            do m=128,1,-1
              if (leng(m).ge.pat1) then
              m1 = m
              goto 1401
              endif
            enddo
           if (m1.ge.200) then  ! -> ENE for given PATH is more
           ene = 1.00001d+9     !    than 1 EeV (out of reason-
           goto 1402            !     able range) - let it be
           endif                !           just 1 EeV
 1401       continue
            if (m1.lt.128) then
            rest = pat1 - leng(m1+1)
            else
            rest = pat1
            endif
c
          ene = ((a(m1)*e0(m1)+b(m1))*dexp(rest*a(m1))-b(m1))/a(m1)
 1402     continue
          geteback4 = sngl(ene)
      return
      end
c
****************************************************************************
* C.17_4
       function enew4(e,depth,iti,itime)
*
       external getlanrv4,geteranv4,geteback4,gdedelt24,conv4
       external glpairv4,glbremv4,glphnuv4,glelecv4,simps,dsimpS
       real*8 rvec_own,eta,e0,pat,ddepth,e1d,pat1,pat2
       real*8 tlife,treal,tcum,time,time1,dta,deltat
       real*8 dsimps,low3,up3,step3,edur,aux2(0:1000)
       real*8 alfa,rm_e,rm_mu,r_e,avog
       real*8 spli
       real*8 TIME_L_T
       real*8 ttauin,ttauout
       real*4 e,depth
       integer iti,itime
       integer kindlept
       integer MODE
       integer MEDIUM
       integer i_stat(6)
       dimension aux1(0:30)
       dimension ityp(10000),eleng(10000),ener1(10000),ener2(10000)
       COMMON /MATTER4/ MEDIUM
       COMMON /TAU_DECAY4/ TIME_L_T,MODE
       common /const4/ alfa,rm_e,rm_mu,r_e,avog
       common /what_lep4/ kindlept
       common /const_t4/ tlife
       common /vhistory4/ numb,ityp,eleng,ener1,ener2
c       common /r48/ rvec
       common /timetau4/ ttauin,ttauout
       common /statistic/ i_stat
       parameter (itra=1)
c       parameter (len=1)
       parameter (spli=2.99792458d+10)
c                              !_________light velocity, cm/sec
c
      i_stat(6) = i_stat(6) + 1
      if (
     +         (i_stat(1).eq.0).AND.
     +         (i_stat(2).eq.0).AND.
     +         (i_stat(3).eq.0).AND.
     +         (i_stat(4).eq.0).AND.
     +         (i_stat(5).eq.0).AND.
     +         (i_stat(6).eq.6)
     +   ) then
            write(*,*) 'Initialization successful, running...'
      endif
      enew4=1.e+20
c
c        Let's check if input is within alowed range;
c
       if (depth.gt.1.0001e+7) then
       print*,'FUNCTION ENEW4: INPUT VALUE FOR DEPTH ',depth,' cm'
       print*,'           IS TOO LARGE, WILL NOT WORK'
       return
       endif
c
       if ((e.gt.1.0001e+9).or.(e.lt..16)) then
       print*,'FUNCTION ENEW4: INPUT VALUE FOR ENERGY ',e,' GeV'
       print*,'          IS OUT OF RANGE, WILL NOT WORK'
       return
       endif
c
       if(kindlept.eq.1) then
c
******************** MUON: ************************************
c
       if(e.le.1.e+1) then !-> muon energy is less than 10 GeV
c -----------------------
       numb = 1         !
       ityp(numb) = 0   !
       eleng(numb) = 0. !-> Tracking simulation history
       ener1(numb) = e  !
       ener2(numb) = e  !
c------------------------
       el = e
       rest = depth
       pat = 0.d+0
       goto 4321
       endif
c -----------------------
       numb = 1         !
       ityp(numb) = 0   !
       eleng(numb) = 0. !-> Tracking simulation history
       ener1(numb) = e  !
       ener2(numb) = e  !
c------------------------
       ddepth = dble(depth)
       e0 = dble(e)
       pat = 0.d+0
    1  call rm48_own(rvec_own)
       eta = -dlog(rvec_own)
c                       ^
c                       !________Simulation of random number
       if(eta.ge.3.16d+1) eta = 3.16d+1
       slu = sngl(eta)
       e0_sn = sngl(e0)
       if (slu.ge.1.e-4) then
       preal = getlanrv4(slu,e0_sn)  !-> getting the real free path
       e1d = e0 * dble(geteranv4(slu,e0_sn)) !-> getting muon energy
c                                               at the end of free
c                                               path
       else
        preal = 0.  !--> simulated free path is too small, let
        e1d = e0    !    it be equal to zero...
       endif
        e1 = sngl(e1d)
c
       pat = pat + dble(preal)
       rest = sngl(ddepth - pat)
         if (rest.lt.0.) then   !-> muon has passed the DEPTH,
           rest = -rest           !
           if (rest.lt.1.) rest=1.  !  Computing its "back" energy
           if (e1.lt.10.) e1 = 10.   ! at the DEPTH and return...
           enew4 = geteback4(e1,rest)  !
c-------------------------------
           numb = numb + 1     !
           ityp(numb) = 1      !-> Tracking
           eleng(numb) = depth ! simulation
           ener1(numb) = enew4  !  history
           ener2(numb) = enew4  !
c------------------------------
           return
         endif
c
         if (e1.le.1.e+1) then  !-> muon energy at the end of free
           el = 10.             !   path is less than 10 GeV (MUM..
c-----------------------------------                             .
           numb = numb + 1         !-> tracking                .
           ityp(numb) = 3          ! simulation              .
           eleng(numb) = sngl(pat) !  history              .
           ener1(numb) = el        !                    .
           ener2(numb) = el        !                 .
c---------------------------------...................
           goto 4321            ! ..does not compute some "catastrophic"
         endif                  !   losses below 10 GeV, jump to the
c                               !   label 4321 to go the rest of DEPTH
c                               !   with "continuous" losses only...
c
       pb = 1./glbremv4(e1)        !-> Computing of "weight" for different
       pp = pb + 1./glpairv4(e1)   !   interactions at current muon energy.
       pn = pp + 1./glphnuv4(e1)   !
       pt = pn + 1./glelecv4(e1)   !
       ranp = rndm_mum(5) * pt  ! -> Simulation of interaction type
       numb = numb + 1 !-> tracking simulation history
       if(ranp.le.pb) then        !-> type was simulated as bremsstrahlung,
       call getvbrem4(e1,v,itra)
c                          !__simulate rel. energy transfer
       ityp(numb) = 4 !-> tracking simulation history
       else
          if(ranp.le.pp) then      !-> type was simulated as e+e- pair,
          call getvpa4(e1,v,itra)
c                           !__simulate rel. energy transfer
          ityp(numb) = 5 !-> tracking simulation history
          else
              if (ranp.le.pn) then   !-> type was simulated as photonuc.,
              call getvph4(e1,v,itra)
c                               !__simulate rel. energy transfer
              ityp(numb) = 6 !-> tracking simulation history
              else
              call getvel4(e1,v,itra)
c                               !__type was simulated as knock-on
c                                    !  electron, simulate en. transfer
              ityp(numb) = 7 !-> tracking simulation history
              endif
           endif
        endif
        e2 = e1 * ( 1. - v ) ! -> The energy after interaction
c-----------------------------------
           eleng(numb) = sngl(pat) !
           ener1(numb) = e1        !-> tracking simulation history
           ener2(numb) = e2        !
c-----------------------------------
          if (e2.le.10.) then
             if (e2.le..16) then !-> the muon stops (energy is below
                 enew4 = 1.e-2    !   the Cherenkov threshold in water)
c----------------------------------------
                 numb = numb + 1         !
                 ityp(numb) = 2          !-> tracking simulation history
                 eleng(numb) = sngl(pat) !
                 ener1(numb) = enew4      !
                 ener2(numb) = enew4      !
c---------------------------------------
                 return          !   Assigne ENEWS = 0.01 and return...
             else
                 el=e2     !-> muon has not stopped but its energy is
                 goto 4321 !   less than 10 GeV. Jump to label 4321...
             endif
          else
             e0 = dble(e2)  !-> muon enrgy is above 10 GeV. Jump to
             goto 1         !   label 1 to repeat everything once
          endif             !          again...
c
c  Muon energy becomes less than 10 GeV. Compute the rest of its
c          travel with continuous losses only:
c
 4321   lim1 = 30
        elow = alog(1.6e-1)
        up = alog(el)
        step1 = (up - elow) / float(lim1)
         do j1=0,lim1
         en = elow + (float(j1) * step1)
         h1 = exp(en)
         aux1(j1) = h1 * 1.e+3 / gdedelt24(h1)
         enddo
         pat1 = simps(aux1,elow,up,lim1)
         if (pat1.lt.rest) then            ! Muon energy becomes < 0.16
         enew4 = 1.e-2                      ! GeV before it reaches DEPTH
c-----------------------------------------------
         numb = numb + 1                       !
         ityp(numb) = 2                        !-> tracking simulation
         eleng(numb) = sngl(pat + dble(pat1))  !     history
         ener1(numb) = enew4                    !
         ener2(numb) = enew4                    !
c-----------------------------------------------
         return                            ! ENEWS = 0.01 GeV and return...
         endif
c-------------------------------------------
         ic = 0                            ! Iteration procedure to
         ene = (el + 1.59999e-1) * 5.e-1   ! obtain muon energy at
         delta = el - ene                  ! the DEPTH if his start
 3333    elow = alog(ene)                   ! energy is less than
         step1 = (up - elow) / float(lim1)   ! 10 GeV (without "ca-
         do j1=0,lim1                         ! tastrophic" part)
         en = elow + (float(j1) * step1)      !
         h1 = exp(en)                         !
         aux1(j1) = h1 * 1.e+3 / gdedelt24(h1) !
         enddo                                !
         pat1 = simps(aux1,elow,up,lim1)    !
         delta = 5.e-1 * delta            !
         ic = ic + 1                    !
         if (pat1.eq.rest) then       !-> it seems incredible but
         enew4 = ene                   !   sometimes it occures...
c ----------------------------              !
         numb = numb + 1     !                      !
         ityp(numb) = 1      !-> tracking simulation  !
         eleng(numb) = depth !    history            !
         ener1(numb) = enew4  !                   !
         ener2(numb) = enew4  !               !
c ----------------------------          !
         return                        !
         endif                        !
         if (pat1.le.rest) then      !
         ene = ene - delta            !
         else                           !
         ene = ene + delta               !
         endif                            !
         if (ic.eq.14) then                !
         enew4 = ene                         ! -> We found ENEWS
c ----------------------------                  !     and finish...
         numb = numb + 1     !                      !
         ityp(numb) = 1      !-> tracking simulation  !
         eleng(numb) = depth !    history            !
         ener1(numb) = enew4  !                   !
         ener2(numb) = enew4  !               !
c ----------------------------          !
         return                     !
         endif                   !
         goto 3333            !
c----------------------------
       else
******************** TAU: ************************************
c
       if(itime.lt.0) then
         CALL DECAY_MODE4
c                   !__> Simulation of tau life time (sec)
         treal = TIME_L_T
       else
         treal = ttauin
       endif
c
c  If working in water equivalent units increase TREAL proportionally
c                           to density:
c
       IF(MEDIUM.EQ.-1)  treal = treal * 1.00000d+0
       IF(MEDIUM.EQ.-2)  treal = treal * 2.65000d+0
       IF(MEDIUM.EQ.-3)  treal = treal * 0.92000d+0
       IF(MEDIUM.EQ.-4)  treal = treal * 1.02700d+0
       IF(MEDIUM.EQ.-5)  treal = treal * 1.03410d+0
       IF(MEDIUM.EQ.-6)  treal = treal * 1.03975d+0
       IF(MEDIUM.EQ.-7)  treal = treal * 2.71000d+0
       IF(MEDIUM.EQ.-8)  treal = treal * 2.90000d+0
       IF(MEDIUM.EQ.-9)  treal = treal * 2.48100d+0
       IF(MEDIUM.EQ.-10) treal = treal * 2.10300d+0
       IF(MEDIUM.EQ.-11) treal = treal * 1.69800d+0
       IF(MEDIUM.EQ.-12) treal = treal * 2.74000d+0
       IF(MEDIUM.EQ.-13) treal = treal * 2.74000d+0
c
       if(iti.eq.1) then
c --------------------------
       numb = 1            !
       ityp(numb) = 0      !
       eleng(numb) = 0.    !-> Tracking simulation history
       ener1(numb) = e     !
       ener2(numb) = e     !
       edelen = 1.e+3 * sngl( treal * (dble(e)/rm_mu) * spli )  !
       numb = 2                   !------------------------------
         if(edelen.gt.depth) then !
           ityp(numb) = 1         !
           eleng(numb) = depth    !
           enewS = e              !
           ener1(numb) = e        !
           ener2(numb) = e        !-----------------------------
           ttauout = treal * dble( (edelen - depth) / edelen ) !
           IF(MEDIUM.EQ.-1)  ttauout = ttauout / 1.00000d+0    !
           IF(MEDIUM.EQ.-2)  ttauout = ttauout / 2.65000d+0    !
           IF(MEDIUM.EQ.-3)  ttauout = ttauout / 0.92000d+0    !
           IF(MEDIUM.EQ.-4)  ttauout = ttauout / 1.02700d+0    !
           IF(MEDIUM.EQ.-5)  ttauout = ttauout / 1.03410d+0    !
           IF(MEDIUM.EQ.-6)  ttauout = ttauout / 1.03975d+0    !
           IF(MEDIUM.EQ.-7)  ttauout = ttauout / 2.71000d+0    !
           IF(MEDIUM.EQ.-8)  ttauout = ttauout / 2.90000d+0    !
           IF(MEDIUM.EQ.-9)  ttauout = ttauout / 2.48100d+0    !
           IF(MEDIUM.EQ.-10) ttauout = ttauout / 2.10300d+0    !
           IF(MEDIUM.EQ.-11) ttauout = ttauout / 1.69800d+0    !
           IF(MEDIUM.EQ.-12) ttauout = ttauout / 2.74000d+0    !
           IF(MEDIUM.EQ.-13) ttauout = ttauout / 2.74000d+0    !
         else                     !-----------------------------
           ityp(numb) = 8         !
           eleng(numb) = edelen   !
           enewS = 1.e-2          !
           ener1(numb) = e        !
           ener2(numb) = 1.e-2    !
           ttauout = -1.d+0       !
         endif
       return              !
       endif               !
c--------------------------
       tcum = 0.0d+0
       if(e.le.1.e+1) then !-> tau energy is less than 10 GeV
c --------------------------
       numb = 1            !
       ityp(numb) = 0      !
       eleng(numb) = 0.    !-> Tracking simulation history
       ener1(numb) = e     !
       ener2(numb) = e     !
       numb = 2            !
       ityp(numb) = 8      !
       eleng(numb) = 0.1   !
       ener1(numb) = e     !
       ener2(numb) = 1.e-2 !
c---------------------------
       enew4= 1.e-2
       ttauout = -1.d+0
       return
       endif
c -----------------------
       numb = 1         !
       ityp(numb) = 0   !
       eleng(numb) = 0. !-> Tracking simulation history
       ener1(numb) = e  !
       ener2(numb) = e  !
c------------------------
       ddepth = dble(depth)
       e0 = dble(e)
       pat = 0.d+0
   11  call rm48_own(rvec_own)
       eta = -dlog(rvec_own)   !---> Simulation of random number
       if(eta.ge.3.16d+1) eta = 3.16d+1
       slu = sngl(eta)
       e0_sn = sngl(e0)
       if (slu.ge.1.e-4) then
       preal = getlanrv4(slu,e0_sn)  !-> getting the real free path
       e1d = e0 * dble(geteranv4(slu,e0_sn)) !-> getting tau energy
c                                               at the end of free
c                                               path
       else
        preal = 0.  !--> simulated free path is too small, let
        e1d = e0    !    it be equal to zero...
       endif
        e1 = sngl(e1d)
c
       pat1 = pat
       pat = pat + dble(preal)
       rest = sngl(ddepth - pat)
         if (rest.lt.0.) then   !-> tau has passed the DEPTH,
           rest = -rest           !
           if (rest.lt.1.) rest=1.  !  Computing its "back" energy
           if (e1.lt.10.) e1 = 10.   ! at the DEPTH and return...
           enew4= geteback4(e1,rest)  !
******************
         low3 = dlog(dble(enew4))
         up3 = dlog(e0)
         qqee = (sngl(up3 - low3))*7.e+0
         lim3 = (int(qqee) + 1) * 2
         step3 = (up3 - low3) / dble(lim3)
         do j=0,lim3
         edur = low3 + (dble(j) * step3)
         h1 = sngl(dexp(edur))
         aux2(j) = rm_mu / (spli * dble(conv4(h1)))
         enddo
         time = dsimps(aux2,low3,up3,lim3)
******************
         tcum = tcum + time
         if(tcum.ge.treal) then
         e1 = enew4
         deltat = treal - tcum + time
         goto 98789               !---> decay before
         endif                    !  reaching DEPTH
c-------------------------------
           numb = numb + 1     !
           ityp(numb) = 1      !-> Tracking
           eleng(numb) = depth ! simulation
           ener1(numb) = enew4 !  history
           ener2(numb) = enew4 !
c------------------------------
           ttauout = treal - tcum
           IF(MEDIUM.EQ.-1)  ttauout = ttauout / 1.00000d+0
           IF(MEDIUM.EQ.-2)  ttauout = ttauout / 2.65000d+0
           IF(MEDIUM.EQ.-3)  ttauout = ttauout / 0.92000d+0
           IF(MEDIUM.EQ.-4)  ttauout = ttauout / 1.02700d+0
           IF(MEDIUM.EQ.-5)  ttauout = ttauout / 1.03410d+0
           IF(MEDIUM.EQ.-6)  ttauout = ttauout / 1.03975d+0
           IF(MEDIUM.EQ.-7)  ttauout = ttauout / 2.71000d+0
           IF(MEDIUM.EQ.-8)  ttauout = ttauout / 2.90000d+0
           IF(MEDIUM.EQ.-9)  ttauout = ttauout / 2.48100d+0
           IF(MEDIUM.EQ.-10) ttauout = ttauout / 2.10300d+0
           IF(MEDIUM.EQ.-11) ttauout = ttauout / 1.69800d+0
           IF(MEDIUM.EQ.-12) ttauout = ttauout / 2.74000d+0
           IF(MEDIUM.EQ.-13) ttauout = ttauout / 2.74000d+0
           return
         endif
c
         if (e1.le.1.e+1) then  !-> tau energy =< 10 GeV
******************
         e1 = 1.e+1
         pat = pat1
         low3 = dlog(dble(e1))
         up3 = dlog(e0)
         qqee = (sngl(up3 - low3))*7.e+0
         lim3 = (int(qqee) + 1) * 2
         step3 = (up3 - low3) / dble(lim3)
         do j=0,lim3
         edur = low3 + (dble(j) * step3)
         h1 = sngl(dexp(edur))
         aux2(j) = 1.d+3 * (dexp(edur) / dble(conv4(h1)))
         enddo
         pat2 = dsimps(aux2,low3,up3,lim3)
******************
         pat = pat + pat2
******************
         low3 = dlog(dble(e1))
         up3 = dlog(e0)
         qqee = (sngl(up3 - low3))*7.e+0
         lim3 = (int(qqee) + 1) * 2
         step3 = (up3 - low3) / dble(lim3)
         do j=0,lim3
         edur = low3 + (dble(j) * step3)
         h1 = sngl(dexp(edur))
         aux2(j) = rm_mu / (spli * dble(conv4(h1)))
         enddo
         time = dsimps(aux2,low3,up3,lim3)
******************
         tcum = tcum + time
         if(tcum.ge.treal) then
         deltat = treal - tcum + time
         goto 98789           !---> decay before
         endif                !     reaching depth
c-----------------------------------                             .
           numb = numb + 1         !-> tracking                .
           ityp(numb) = 8          ! simulation              .
           eleng(numb) = sngl(pat) !  history              .
           ener1(numb) = e1        !                    .
           ener2(numb) = 1.e-2     !                 .
c-----------------------------------...................
           enew4= 1.e-2
           ttauout = -1.d+0
           return
         endif
******************
         low3 = dlog(dble(e1))
         up3 = dlog(e0)
         qqee = (sngl(up3 - low3))*7.e+0
         lim3 = (int(qqee) + 1) * 2
         step3 = (up3 - low3) / dble(lim3)
         do j=0,lim3
         edur = low3 + (dble(j) * step3)
         h1 = sngl(dexp(edur))
         aux2(j) = rm_mu / (spli * dble(conv4(h1)))
         enddo
         time = dsimps(aux2,low3,up3,lim3)
******************
         tcum = tcum + time
         if(tcum.ge.treal) then
         deltat = treal - tcum + time
         goto 98789 !---> decay before
         endif
c
       pb = 1./glbremv4(e1)        !-> Computing of "weight" for different
       pp = pb + 1./glpairv4(e1)   !   interactions at current tau energy.
       pn = pp + 1./glphnuv4(e1)   !
       pt = pn + 1./glelecv4(e1)   !
       ranp = rndm_mum(5) * pt  ! -> Simulation of interaction type
       numb = numb + 1 !-> tracking simulation history
       if(ranp.le.pb) then        !-> type was simulated as bremsstrahlung,
       call getvbrem4(e1,v,itra)
c                          !__simulate rel. energy transfer
       ityp(numb) = 4 !-> tracking simulation history
       else
          if(ranp.le.pp) then      !-> type was simulated as e+e- pair,
          call getvpa4(e1,v,itra)
c                           !__simulate rel. energy transfer
          ityp(numb) = 5 !-> tracking simulation history
          else
              if (ranp.le.pn) then   !-> type was simulated as photonuc.,
              call getvph4(e1,v,itra)
c                               !__simulate rel. energy transfer
              ityp(numb) = 6 !-> tracking simulation history
              else
              call getvel4(e1,v,itra)
c                               !__type was simulated as knock-on
c                                  electron, simulate en. transfer
              ityp(numb) = 7 !-> tracking simulation history
              endif
           endif
        endif
        e2 = e1 * ( 1. - v ) ! -> The energy after interaction
c-----------------------------------
           eleng(numb) = sngl(pat) !
           ener1(numb) = e1        !-> tracking simulation history
           ener2(numb) = e2        !
c-----------------------------------
          if (e2.le.10.) then
c----------------------------------------------
                 numb = numb + 1               !
                 ityp(numb) = 8                !-> tracking simulation history
                 eleng(numb) = sngl(pat+1.d+0) !
                 ener1(numb) = e2              !
                 ener2(numb) = 1.e-2           !
c----------------------------------------------
                 enew4= 1.e-2
                 ttauout = -1.d+0
                 return
          else
             e0 = dble(e2)  !-> tau energy is above 10 GeV. Jump to
             goto 11        !   label 11 to repeat everything once
          endif             !          again...
c
98789    continue
         if(e1.le.1.e+1) e1=1.e+1
         iiik = 1
         dta = dlog(dble(e0/e1))
******************
         low3 = dlog(dble(e1))
13333    continue
         iiik = iiik + 1
         dta = dta * .5d+0
         up3 = dlog(e0)
         qqee = (sngl(up3 - low3))*7.e+0
         lim3 = (int(qqee) + 1) * 2
         step3 = (up3 - low3) / dble(lim3)
         do j=0,lim3
         edur = low3 + (dble(j) * step3)
         h1 = sngl(dexp(edur))
         aux2(j) = rm_mu / (spli * dble(conv4(h1)))
         enddo
         time1 = dsimps(aux2,low3,up3,lim3)
******************
         if(time1.ge.deltat) then
           low3 = low3 + dta
         else
           low3 = low3 - dta
         endif
         if(iiik.le.27) goto 13333
         e1 = sngl(dexp(low3))
******************
         pat = pat1
         low3 = dlog(dble(e1))
         up3 = dlog(e0)
         qqee = (sngl(up3 - low3))*7.e+0
         lim3 = (int(qqee) + 1) * 2
         step3 = (up3 - low3) / dble(lim3)
         do j=0,lim3
         edur = low3 + (dble(j) * step3)
         h1 = sngl(dexp(edur))
         aux2(j) = 1.d+3 * (dexp(edur) / dble(conv4(h1)))
         enddo
         pat2 = dsimps(aux2,low3,up3,lim3)
******************
         pat = pat + pat2
c-----------------------------------------
                 numb = numb + 1         !
                 ityp(numb) = 8          !-> tracking simulation
                 eleng(numb) = sngl(pat) !     history
                 ener1(numb) = e1        !
                 ener2(numb) = 1.e-2     !
c-----------------------------------------
          enew4= 1.e-2
          return
         endif
          ttauout = -1.d+0
      return
      end
****************************************************************************
* C.18_4
      subroutine simulde4(ndepths,emu0)
*
       external enew4,simps,gdedelt24,geteback4
       dimension ityp(10000),eleng(10000),ener1(10000),ener2(10000)
       dimension aux1(0:30)
       real*4 emu0
       integer ndepths
       integer kindlept
       common /vhistory4/ numb,ityp,eleng,ener1,ener2
       common /frouser14/ horison(1000)
       common /touser14/ emuon(1000)
       common /what_lep4/ kindlept
c
       iti = 0
       itime = -1
       emuon(ndepths) = enew4(emu0,horison(ndepths),iti,itime)
       numfirst = 2
       do i=1,ndepths-1 !--> cicle along levels of observation
c---------------------------------------------
         if (eleng(numb).lt.horison(i)) then !-> muon has died before
           emuon(i) = 1.e-2                  !   given level of
           goto 1                            !    observation...
         else                                !
c---------------------------------------------
           do j=numfirst,numb  !-> cicle along muon history
c----------------------------------------------
             if (eleng(j).ge.horison(i)) then !-> we found the first event
             numfirst = j                   ! in muon history (starting with
c                                         ! less depth) whose depth is more
c                                       ! than given level of observation
c----------------------------------------
              if((ityp(j).ge.3).and.(ityp(j).lt.8)) then !-> the nearest
                     diffl = eleng(j) - horison(i)       ! event is either
                        if (diffl.le.1.) then            ! brem, pn, e+e-,
                        emuon(i) = ener1(j)              ! knock-on e in-
                        goto 1                           ! teraction or
                        endif                            ! 10 GeV level
                     emuon(i) = geteback4(ener1(j),diffl)!
                     goto 1                              !
                  else                                   !
c
                     if (ityp(j).eq.1) then                     !-> muon
                         if (ener1(j).ge.10.) then              ! has reached
                           diffl = eleng(j) - horison(i)        ! the maximum
                             if (diffl.le.1.) then              ! depth and
                             emuon(i) = ener1(j)                ! E_mu > 10 GeV
                             goto 1                             !
                             endif                              !
                           emuon(i) = geteback4(ener1(j),diffl) !
                           goto 1                               !
                         else
                           goto 2  !-> the nearest event is either maximum
                         endif     !    depth with E_mu < 10 GeV or death
                     else          !    of muon (E_mu < 0.16 GeV)
                         goto 2    !
                     endif         !
                  endif            !
             else
             goto 3 !-> continue to search for the first event in muon history
             endif
c
 2           continue
c
             if(kindlept.ne.1) then !---------> TAU-lepton
             diffl = eleng(j) - horison(i)
             ecucuc = ener1(j)
             if(ener1(j).le.1.e+1) ecucuc = 1.0001e+1
             emuon(i) = geteback4(ecucuc,diffl)
             goto 1
             endif
c
             lim1 = 30  !-------------------------!
             rest = eleng(j) - horison(i)         !
                if (rest.le.1.) then              !
                emuon(i) = ener1(j)               !
                goto 1                            !
                endif                             !
             ic = 0                               ! Iteration procedure to
             efin = ener1(j)                      ! obtain muon energy
             if (efin.le..15) efin = .16         !  at the level of observation
             ene = (efin + ener2(j-1)) * 5.e-1  !  if its energy at the nearest
             delta = ene - efin                !    event after level of obser-
             elow = alog(efin)                  !   vation is less than 10 GeV
 3333        up = alog(ene)                      !
             step1 = (up - elow) / float(lim1)    !
               do j1=0,lim1                       !
                 en = elow + (float(j1) * step1)   !
                 h1 = exp(en)                        !
                 aux1(j1) = h1 * 1.e+3 / gdedelt24(h1) !
               enddo                               !
             pat1 = simps(aux1,elow,up,lim1)   !
             delta = 5.e-1 * delta         !
             ic = ic + 1                !
               if (pat1.eq.rest) then !-> It seems incredible but sometimes
               emuon(i) = ene         !      it occures ...
               goto 1                 !
               endif                  !_________
               if (pat1.le.rest) then           !
                 ene = ene + delta             !
               else                           !
                 ene = ene - delta           !
               endif                        !
               if (ic.eq.14) then          !
                 emuon(i) = ene           ! -> We found EMUON(I)
                 goto 1                  !
               endif                    !
             goto 3333                 !
    3      continue  !----------------!
           enddo
         endif
    1  continue
       enddo
      return
      end
****************************************************************************
c C.28_4
c
      SUBROUTINE PREPARE_DECAY4
c
c   Cooking array TIMP(22) with partial life times of tau-lepton for 22
c                    the most important decay modes
c
      DOUBLE PRECISION TLIFE,XX
      DIMENSION TIMP(22)
      DIMENSION DMOD(22)
      COMMON /PARTI4/ TIMP
      COMMON /CONST_T4/ TLIFE
c
      DO I=1,22
      DMOD(I) = 1.00000
      ENDDO
c
      DO I = 1,22
c                            BR. RATIO         DECAY MODE            NUMBER
c                         (norm to e mode)         |       (in TAUOLA style)
c                                |                 |                     |
c                                V                 V                     V
        IF(I.EQ. 1) DMOD(I) = 1.00000 ! TAU-+  -->  E-+                  1
        IF(I.EQ. 2) DMOD(I) = 0.97980 ! TAU-+  -->  MU-+                 2
        IF(I.EQ. 3) DMOD(I) = 0.64960 ! TAU-+  -->  PI-+                 3
        IF(I.EQ. 4) DMOD(I) = 1.3405  ! TAU-+  -->  PI-+    PI0          4
        IF(I.EQ. 5) DMOD(I) = 0.7215  ! TAU-+  -->  A1-+ (two subch)     5
        IF(I.EQ. 6) DMOD(I) = 0.0397  ! TAU-+  -->  K-+                  6
        IF(I.EQ. 7) DMOD(I) = 0.0696  ! TAU-+  -->  K*-+ (two subch)     7
        IF(I.EQ. 8) DMOD(I) = 0.0835  ! TAU-+  -->  2PI-+   PI0    PI+-  8
        IF(I.EQ. 9) DMOD(I) = 0.0170  ! TAU-+  -->  3PI0    PI-+         9
        IF(I.EQ.10) DMOD(I) = 0.0641  ! TAU-+  -->  2PI-+   PI+-   2PI0  10
        IF(I.EQ.11) DMOD(I) = 0.0286  ! TAU-+  -->  3PI-+   2PI+-        11
        IF(I.EQ.12) DMOD(I) = 0.0043  ! TAU-+  -->  3PI-+   2PI+-  PI0   12
        IF(I.EQ.13) DMOD(I) = 0.0042  ! TAU-+  -->  2PI-+   PI+-   3PI0  13
        IF(I.EQ.14) DMOD(I) = 0.0061  ! TAU-+  -->  K-+     PI-+   K+-   14
        IF(I.EQ.15) DMOD(I) = 0.0056  ! TAU-+  -->  K0      PI-+   K0B   15
        IF(I.EQ.16) DMOD(I) = 0.0005  ! TAU-+  -->  K-+     K0     PI0   16
        IF(I.EQ.17) DMOD(I) = 0.0059  ! TAU-+  -->  PI0     PI0    K-+   17
        IF(I.EQ.18) DMOD(I) = 0.0321  ! TAU-+  -->  K-+     PI-+   PI+-  18
        IF(I.EQ.19) DMOD(I) = 0.0320  ! TAU-+  -->  PI-+    K0B    PI0   19
        IF(I.EQ.20) DMOD(I) = 0.0110  ! TAU-+  -->  ETA     PI-+   PI0   20
        IF(I.EQ.21) DMOD(I) = 0.0031  ! TAU-+  -->  PI-+    PI0    GAM   21
        IF(I.EQ.22) DMOD(I) = 0.0181  ! TAU-+  -->  K-+     K0           22
      ENDDO
c
      XX = 0.d+0
        DO I=1,22
          XX = XX + DBLE(DMOD(I))
        ENDDO
        DO I=1,22
          TIMP(I) = ( SNGL(XX) / DMOD(I) ) * SNGL(TLIFE)
        ENDDO
c
       RETURN
       END
****************************************************************************
c C.29_4
c
      SUBROUTINE DECAY_MODE4
c
c Generation of tau-lepton life time (DOUBLE PRECISION TIME_L_T) and decay
c        mode (INTEGER MODE) to be passed to ENEW(S,3,4) routines.
      DOUBLE PRECISION RVEC_OWN, TREAL1, TREAL,TIME_L_T
      INTEGER MODE
      DIMENSION TIMP(22)
      COMMON /PARTI4/ TIMP
      COMMON /TAU_DECAY4/ TIME_L_T,MODE
c
      TREAL = 1.D+1
        DO J=1,22
          CALL rm48_own(rvec_own)
          TREAL1 = (-DLOG(RVEC_OWN)) * DBLE(TIMP(J))
            IF(TREAL1.LE.TREAL) THEN
              TREAL = TREAL1
              MODE = J
            ENDIF
        ENDDO
        TIME_L_T = TREAL
c
      RETURN
      END
****************************************************************************
************************ BREMSSTRAHLUNG SUBROUTINES : **********************
****************************************************************************
* B.1_4
*
       real*8 function brem4(z,en,rnu)
       external fu14,fu24
       real*8 fu14,fu24
       real*8 z,en,rnu,rnu1
       real*8 alfa,rm_e,rm_mu,r_e,fact,a1,a2,del1,del2,x1,x2,ulim,avog
       real*8 eln1,eln2,psi10,psi20,psi1,psi2,z13,z23,qc,dze,q_min,h1
       common /exer14/ fa
       common /const4/ alfa,rm_e,rm_mu,r_e,avog
c
      fact=((4.d+0*z*z*r_e*r_e*rm_e*rm_e)/(rm_mu*rm_mu))*alfa
      rnu1=1.d+0-rnu
      z13=z**(1.d+1/3.d+1)
      z23=z13*z13
ccc      qc=(1.9d+0*rm_mu)/z13
      qc=(1.9d+0*1.0565932d+2)/z13
      dze=sqrt(1.d+0+((4.d+0*rm_mu*rm_mu)/(qc*qc)))
      a1 = 1.117d+2/(z13*rm_e)
      a2 = 7.242d+2/(z23*rm_e)
      del1=dlog(rm_mu/qc)+((dze/2.d+0)*dlog((dze+1.d+0)/(dze-1.d+0)))
      del2=dlog(rm_mu/qc)+((2.d+0*rm_mu*rm_mu)/(qc*qc))
      del2 = del2+((dze/4.d+0)*(3.d+0-(dze*dze))*dlog((dze+1.d+0)/(dze-1
     *.d+0)))
      if (z.le.1.5d+0) then !
      del1=0.d+0            !-> there is no corrections due to nuclear
      del2=0.d+0            !   form-factor for hydrogen
      endif                 !
      q_min=((rnu/rnu1)*rm_mu*rm_mu*5.d-1)/(en*1.d+3)
      x1 = a1 * q_min
      x2 = a2 * q_min
c
        ulim=((z)**(1.d+0/3.d+0))*1.236540953d+0*(rm_mu/(en*1.d+3))
        ulim = 1.d+0 - ulim
c
        if (ulim.lt.rnu) then   !  if input energy transfer is greater than
        k1=0                    !  upper limit the diff. cross-section = 0.
        else                    !  Else it is calculated by fornmulae for
        k1=1                    !  bremstrahlung.
        endif                   !
        h1=dble(k1)             !
c
        eln1=dlog((rm_mu*rm_mu*a1*a1)/(1.d+0+x1*x1))
        eln2=dlog((rm_mu*rm_mu*a2*a2)/(1.d+0+x2*x2))
        psi10 = 5.d-1 * (1.+eln1) - fu24(x1)
        psi10 = psi10 + (1.d+0/z)*(5.d-1*(1.d+0+eln2) - fu24(x2))
        psi20=(1.d+1/3.d+1) + 5.d-1*eln1 + fu14(x1)
        psi20=psi20+(1.d+0/z)*((1.d+0/3.d+0)+5.d-1*eln2+fu14(x2))
        psi1=psi10-del1
        psi2=psi20-del2
        brem4=(fact/rnu)*
     &        ((rnu1*rnu1+1.d+0)*psi1-(2.d+0/3.d+0)*rnu1*psi2)
        brem4 = brem4 * h1 * dble(fa)
        return
        end
****************************************************************************
* B.2_4
*
       real*8 function fu14(c)
       external fu24
       real*8 c,fu24
      if (c.gt.1.d+3) then
        fu14 = -0.8333333333333d+0
      else
        if (c.lt.1.d-5) then
         ik=0
         fu14=dble(ik)
        else
         fu14=2.d+0*c*c*
     &        (1.d+0-fu24(c)+(7.5d-1)*dlog((c*c)/(1.d+0+(c*c))))
        endif
      endif
      return
      end
****************************************************************************
* B.3_4
*
       real*8 function fu24(d)
       real*8 d
       if (d.gt.5.d+4) then
          ik = 1
          fu24 = dble(ik)
       else
           if (d.lt.1.d-8) then
             fu24 = d * 3.14159265359d+0 * 5.d-1
           else
             fu24 = d * datan(1.d+0/d)
           endif
       endif
       return
       end
**************************************************************************
* B.1a_4
*
        function CRB_G44 (Z,A,Tkin,EP)
c GeV:
        parameter       (ame=0.51099907e-3)
c        parameter       (amu=0.105658389)       !!!     GeV
c cm:
        parameter       (re=2.81794092e-13)
        parameter       (avno=6.022137e23)
cccc        parameter       (alpha=1./137.036)
c        parameter       (rmass=amu/ame)         !!!     "207"
c        parameter       (coeff=16./3.*alpha*avno*(re/rmass)**2) !!! cm^2
c sqrt(2.71828...):
        parameter       (sqrte=1.64872127)
        parameter       (btf=183.)
        parameter       (btf1=1429.)
        parameter       (bh=202.4)
        parameter       (bh1=446.)
        real*8 alfa,rm_e,rm_mu,r_e,avog
        real*4 Z,A,Tkin,EP
        common /const4/ alfa,rm_e,rm_mu,r_e,avog
        common /exer14/ fa
c
        alpha = 1./137.036
        amu = sngl(rm_mu) * 1.e-3
        rmass = amu/ame
        coeff=16./3.*alpha*avno*(re/rmass)**2
C
        if (ep.ge.tkin) then
                crb_g44=0.
                return
                end if
        e=tkin+amu
        v=ep/e
        delta=amu*amu*v/(2.*(e-ep))             !!!     qmin
        rab0=delta*sqrte
        z_13=z**(-0.3333333)
C
        dn=1.54*A**0.27
        if (z.le.1.5) then      !!!     special case for hydrogen
                b=bh
                b1=bh1
                dn_star=dn
        else
                b=btf
                b1=btf1
                dn_star=dn**(1.-1./Z)   !!! with Bugaev's correction
        end if
C***            nucleus contribution logarithm
        rab1=b*z_13
        fn=alog(rab1/(dn_star*(ame+rab0*rab1))*(amu+delta*
     *          (dn_star*sqrte-2.)))
        if (fn.lt.0.) fn=0.
C***            electron contribution logarithm
        epmax1=e/(1.+amu*rmass/(2.*e))
        if (ep.ge.epmax1) then
                fe=0.
                go to 10
                end if
        rab2=b1*z_13*z_13
        fe=alog(rab2*amu/((1.+delta*rmass/(ame*sqrte))*
     *                  (ame+rab0*rab2)))
        if (fe.lt.0.) fe=0.
C***
10      continue
        crb_g44=fa*coeff*e*(1.-v*(1.-0.75*v))*Z*(Z*fn+fe)/(ep*avno)
        return
        end
************************************************************************
* B.1b_4
*     THIS REAL*8 FUNCTION CALCULATES DIFFERENTIAL CROS-SECTION FOR MUON
*         BREMSSTRAHLUNG ACCORDING TO FORMULAE TAKEN FROM A.SANDROCK
*                                  PhD Thesis:
*       M.Sc.A.Sandrock, "Higher-order corrections to the energy loss
*     cross sections of high-energy muons", Dissertation zur Erlangung
*                   des akademischen Grades eines (PhD Thesis)
*                     Technische Universitaet Dortmund, 2018
*  (https://eldorado.tu-dortmund.de/bitstream/2003/37815/1/Sandrock.pdf)
*
*                                INPUT:
*                                =====
*
* real*8 z     : electric charge of nucleus
* real*8 a     : atomic weight of nucleus
* real*8 en    : muon energy (GeV)
* real*8 rnu   : relative energy transfer = (E_transfered / E_mu)
*
*                                OUTPUT:
*                                ======
*
* real*8 brem_sandr4 : d_sigma/d_v (sq. cm) for nucleus with given Z, A,
*                      muon energy EN and relative energy transfer RNU
*  .....................................................................
      real*8 function brem_sandr4(z,a,en,rnu)
c  .....................................................................
c
c                                                          DECLARATIONS:
c
c Routine to compute radiation logarithm B:
      external rad_log_HF
      real*8 rad_log_HF
c Declaration for input variables:
      real*8 z,a,en,rnu
c Declaration for constants which are prepared by MED_CONS routine and
c passed here via COMMON /const/ (electron and muon masses in MeV!!!):
      real*8 alfa,rm_e,rm_mu,r_e,avog
      common /const4/ alfa,rm_e,rm_mu,r_e,avog
c M_mu and M_e in GeV:
      real*8 rm_mu_gev,rm_e_gev
c E number:
      real*8, parameter:: e = 2.7182818284590452354d+0
c M_mu (GeV) to compute q_c parameter for tau-lepton:
      real*8, parameter:: mu_m = 1.0565932d+2  !--> muon mass (MeV)
c Inelastic radiation logarithm B':
c                                           for all the nuclei with Z>1:
      real*8, parameter::       b1_all=1429.d+0
c                                                          for hydrogen:
      real*8, parameter::       b1_h=446.d+0
c Radiation logarithm and inelastic radiation logarithm (the last to be
c substituted by one of the values above:
      real*8 b,b1
c Parameters of the parametrization for the radiative corrections to the
c bremsstrahlung cross section (Table B.1 in Sandrock's Thesis):
      real*8, dimension(3), parameter:: ai = (/
     #                                             -0.00349,
     #                                            148.84,
     #                                           -987.531
     #                                                       /)
      real*8, dimension(4), parameter:: bi = (/
     #                                              0.1642,
     #                                            132.573,
     #                                           -585.361,
     #                                           1407.77
     #                                                       /)
      real*8, dimension(6), parameter:: ci = (/
     #                                             -2.8922,
     #                                            -19.0156,
     #                                             57.698,
     #                                            -63.418,
     #                                             14.1166,
     #                                              1.84206
     #                                                       /)
      real*8, dimension(6), parameter:: di = (/
     #                                           2134.19,
     #                                            581.823,
     #                                          -2708.85,
     #                                           4767.05,
     #                                              1.52918,
     #                                              0.361933
     #                                                       /)
c Different terms in formula for dif. cross-section:
      real*8 Delta1, Delta2, delta,rho,q_c,Dn,F1,F2
c Radiative corrections made by Sandrock:
      real*8 s_at, s_rad
c Auxiliary variables:
      real*8 help1, help2, ulim, fact
c Some factor to play with cross-sections (FOR EXPERTS ONLY!!!):
      real*4 fa
      common /exer14/ fa
c Loop variable:
      integer i
************************************************************************
c
c                                                          CALCULATIONS:
c
c
c Choosing values for radiation logarithm B and inelastic radiation
c                                     logarithm B' depending on Z value:

      b = rad_log_HF(z)
      if (z.gt.1.5d+0) then
         b1 = b1_all
      else
         b1 = b1_h
      endif
c
c                                 Computing terms of Sandrock's formula:
c
c Computing delta (in GeV!):
      rm_mu_gev = rm_mu / 1.d+3
      delta =
     &      (rm_mu_gev * rm_mu_gev * rnu) / (2.d+0 * en * (1.d+0 - rnu))
c Computing Dn (nuclear formfactor parametrization):
      Dn = 1.54d+0 * (a**0.27d+0)
c Computing q_c (in MeV!):
      q_c = (mu_m * e) / Dn
c Computing rho:
      rho = DSQRT(1.d+0 + ((4.d+0*rm_mu*rm_mu) / (q_c*q_c)))
c Computing Delta1:
      Delta1 = DLOG(rm_mu/q_c)
      Delta1 = Delta1 + (rho/2.d+0) * DLOG((rho+1.d+0)/(rho-1.d+0))
c Computing Delta2:
      Delta2 = DLOG(rm_mu/q_c)
      Delta2 = Delta2 + ( (2.d+0 * rm_mu * rm_mu) / (q_c * q_c) )
      Delta2 = Delta2 +
     &( (3.d+0*rho-rho**3.d+0) / 4.d+0) * DLOG((rho+1.d+0)/(rho-1.d+0))
c Computing F1 and F2:
      help1 = b * (z**(-1.d+0 / 3.d+0))
      help2 = help1 * (rm_mu / rm_e)
      rm_e_gev = rm_e / 1.d+3
      F1 = DLOG(help2 / (1.d+0 + (help1 * DSQRT(e) * (delta/rm_e_gev))))
      F1 = F1 - Delta1 * (1.d+0 - (1.d+0/z))
      F2 = help2 * e**(-1.d+0/6.d+0)
      F2 = DLOG(F2 /(1.d+0 + help1*(e**(1.d+0/3.d+0))*(delta/rm_e_gev)))
      F2 = F2 - Delta2  * (1.d+0 - (1.d+0/z))
c Computing s_at:
      help1 = DLOG(
     &(rm_mu_gev / delta)
     &                    /
     &  (((rm_mu_gev*delta) / (rm_e_gev*rm_e_gev)) + DSQRT(e))
     &                                                          )
      help2 = rm_e_gev / (delta * b1 * z**(-2.d+0/3.d+0) * DSQRT(e))
      help2 = DLOG(1.d+0 + help2)
      s_at = ((4.d+0/3.d+0) * (1.d+0 - rnu)) + (rnu * rnu)
      s_at = s_at * (help1 - help2)
c Computing s_rad:
      s_rad = 0.d+0
      if (rnu.lt.0.02d+0) then
         do i=1,3
            s_rad = s_rad + (ai(i) * rnu**(dble(i-1)))
         enddo
         goto 11111
      endif
c
      if ((rnu.ge.0.02d+0).AND.(rnu.lt.0.1d+0)) then
         do i=1,4
            s_rad = s_rad + (bi(i) * rnu**(dble(i-1)))
         enddo
         goto 11111
      endif
c
      if ((rnu.ge.0.1d+0).AND.(rnu.lt.0.9d+0)) then
         do i=1,3
            s_rad = s_rad + (ci(i) * rnu**(dble(i-1)))
         enddo
         s_rad = s_rad + (ci(4) * rnu * DLOG(rnu))
         s_rad = s_rad + (ci(5) * DLOG(1.d+0-rnu))
         s_rad = s_rad + (ci(6) * DLOG(1.d+0-rnu) * DLOG(1.d+0-rnu))
         goto 11111
      endif
c
      do i=1,3
         s_rad = s_rad + (di(i) * rnu**(dble(i-1)))
      enddo
      s_rad = s_rad + (di(4) * rnu * DLOG(rnu))
      s_rad = s_rad + (di(5) * DLOG(1.d+0-rnu))
      s_rad = s_rad + (di(6) * DLOG(1.d+0-rnu) * DLOG(1.d+0-rnu))
c
11111 continue
c
c      Computing dif. cross-section d_sigma / d_v by Sandrock's formula:
c
      brem_sandr4 = F1 * (2.d+0 - 2.d+0*rnu + rnu*rnu)
      brem_sandr4 = brem_sandr4 - (F2 * (2.d+0/3.d+0) * (1.d+0 - rnu))
      brem_sandr4 = brem_sandr4 + (s_at / z)
      brem_sandr4 = brem_sandr4 + ((alfa/4.d+0) * F1 * s_rad)
      brem_sandr4 = brem_sandr4 / rnu
      brem_sandr4 = brem_sandr4 * 4.d+0 * alfa * z * z
      brem_sandr4 = brem_sandr4*((rm_e/rm_mu)*r_e) * ((rm_e/rm_mu)*r_e)
c
c ULIM is the upper limit for energy transfer via bremsstrahlung for
c nucleus with given electric charge Z, atomic weight A, muon energy EN
c and  relative transfer RNU. If input energy transfer RNU is greater
c than ULIM cross-section value is set to ZERO;
c
      ulim=(z**(1.d+0/3.d+0)) * (rm_mu / (en * 1.d+3))
      ulim = ulim * DSQRT(e) * (3.d+0 / 4.d+0)
      ulim = 1.d+0 - ulim
      if (ulim.lt.rnu) then
         fact = 0.d+0
      else
         fact = 1.d+0
      endif
c
c                                                            Final step:
c
      brem_sandr4 = brem_sandr4 * fact * dble(fa)
c
      return
      end
**************************************************************************
* B.4_4
*
       function brem_tot4(ene,v)
       external brem4,crb_g44,brem_sandr4
       real*8 brem_sandr4,brem4
       real*8 z1(10),w(10),aw(10),a_ef,en,rnu,h1,ro
       real*8 alfa,rm_e,rm_mu,r_e,avog
       real*4 ene,v
       integer nsub
       common /const4/ alfa,rm_e,rm_mu,r_e,avog
       common /bremind4/ ibrem
       common /media4/ z1,w,aw,a_ef,ro,nsub
c
c       Tkin = ene - 0.105658389 ! For crb_g44
       Tkin = ene - (1.e-3 * sngl(rm_mu))
       if (v.gt..999995) v = .999995
       ep = v * ene ! For crb_g44
       en = dble(ene)
       rnu = dble(v)
c
      if (ibrem.eq.1) then
         h1 = w(1) * brem4(z1(1),en,rnu)
      endif
      if (ibrem.eq.2) then
         h1 = w(1) * brem_sandr4(z1(1),aw(1),en,rnu)
      endif
      if ((ibrem.ne.1).AND.(ibrem.ne.2)) then
         h1 = w(1) * dble(crb_g44(sngl(z1(1)),sngl(aw(1)),Tkin,ep))
      endif
c
      if (nsub.ge.2) then
         do l=2,nsub
            if (ibrem.eq.1) then
               h1 = h1 + (w(l) * brem4(z1(l),en,rnu))
            endif
            if (ibrem.eq.2) then
               h1 = h1 + (w(l) * brem_sandr4(z1(l),aw(l),en,rnu))
            endif
            if ((ibrem.ne.1).AND.(ibrem.ne.2)) then
               h1=h1+w(l)*dble(crb_g44(sngl(z1(l)),sngl(aw(l)),Tkin,ep))
            endif
         enddo
      endif
      brem_tot4 = sngl(h1)
      return
      end
****************************************************************************
* B.5_4
       subroutine gamma14
*
       external brem_tot4,dsimps
       real*8 dsimps
       real*8 um,ene,u(10)
       real*8 aux1(0:2000),aux2(0:2000),h1,h2
       real*8 alfa,rm_e,rm_mu,r_e,avog,z1(10),w(10),aw(10),a_ef,ro
       common /const4/ alfa,rm_e,rm_mu,r_e,avog ! from initial subroutine
       common /media4/ z1,w,aw,a_ef,ro,nsub     !       MED_CONSS
       common /general4/ emin,vmin,emph         !
       common /cdbr_in4/ fcd1(81,54),fcd2(81,101),fcd3(81,51)
       common /ctbr_in14/ crt_br1(17),crt_br2(17)
       common /elbr_in14/ elo_br1(17),elo_br2(17)
       common /elbr_in24/ elo_br3(17)
       common /elbr_in44/ elo_br4(17)
       common /br_ref4/ cf
       common /help_14/ aux1,aux2
       common /bremind4/ ibrem
c   ....................................................................
c      1.PREPARATION OF ARRAYS WITH DIFF. CROSS-SEECTIONS FOR MUON
c                               BREMSSTRAHLUNG:
c
c                !       ..........................
      do j=1,81  !--->   j CYCLE BY ENERGIES starts
c                !       ..........................
        en = float(j)
        en = 1.e+1**(9.e-1 + (1.e-1 * en))
c                     !         ..................................
      do k=1,206      !--->     k CYCLE BY ENERGY TRANSFERS starts
c                     !         ..................................
      if (k.eq.206) then
        kk = 0
        fcd2(j,k-105) = float(kk)
        goto 975
      endif
c
      if (k.le.54) then
         k01 = k - 1
         rnu = 1.e+1**(float(k01) * 2.e-1 - 1.1e+1)
      else
         if (k.le.105) then
           k01 = k - 55
           rnu = 1.e+1**(float(k01) * 1.e-2 - 6.e-1)
         else
           k01 = k - 106
           rnu = 1.e+1**(float(k01) * 1.e-3 - 1.e-1)
         endif
      endif
c
      cr_dif=brem_tot4(en,rnu)
      if (k.le.54) fcd1(j,k) = cr_dif
      if ((k.gt.54).AND.(k.lt.106)) fcd3(j,k-54) = cr_dif
      if (k.ge.106) fcd2(j,k-105) = cr_dif
c
 975  continue
c              !     .....................................
      enddo    !----> k CYCLE BY ENERGY TRANSFERS finishes
c              !     .....................................
      enddo    !----> j CYCLE BY ENERGIES finishes
c              !     ....................................
c   ....................................................................
c    2.PREPARATION OF ARRAYS WITH ENERGY LOSSES AND TOTAL CROSS-SECTIONS
c                         FOR MUON BREMSSTRAHLUNG:
c
c                    a) Energy transfers > EMIN :
      lim = 2000
      do i=1,17
      en = float(i)
      en = (1.e+1)**(5.e-1 + (5.e-1 * en))
      vmi = alog(emin / en) !------------> The lower limit for integration
c
        um = 0.d+0
        do k=1,nsub
        ene=dble(en)
        u(k)=((z1(k))**(1.d+0/3.d+0))*1.236540953d+0*(rm_mu/(ene*1.d+3))
        u(k) = 1.d+0 - u(k)
        um = dmax1(u(k),um)
        enddo
        vma=sngl(um)  !----------------> The upper limit for integration
        vma=alog(vma) !
        vst = (vma - vmi) / float(lim) !-> step for a rel. en. transfers grid
c
      do j=0,lim
      rnu = vmi + vst*(float(j))
      rnu = exp(rnu)
      aux1(j) = dble(brem_tot4(en,rnu) * rnu)       !-> array to be integrated
c                                                  !   to get mean free path
      aux2(j) = aux1(j) * dble(rnu)                !-> array to be integrated
      enddo                                        !   for getting en. losses
c
      h1 = dble(vmi)
      h2 = dble(vma)
      crt_br1(i) = sngl(dsimps(aux1,h1,h2,lim))
      crt_br1(i) = sngl(a_ef / (avog * ro))/crt_br1(i)!->array with 17 values
c                                                     !  of free path
      elo_br1(i) = sngl( dsimps(aux2,h1,h2,lim) * avog * ro / a_ef )
      elo_br1(i) = elo_br1(i) * en * 1.e+3
      elo_br1(i) = alog10(elo_br1(i)) !-> array with 17 values of en. losses
      enddo
c
c                    b) Energy transfers > VMIN :
      do i=1,17
      en = float(i)
      en = (1.e+1)**(5.e-1 + (5.e-1 * en))
      vmi = alog(vmin)          !------------> The lower limit for integration
c
        um = 0.d+0
        do k=1,nsub
        ene=dble(en)
        u(k)=((z1(k))**(1.d+0/3.d+0))*1.236540953d+0*(rm_mu/(ene*1.d+3))
        u(k) = 1.d+0 - u(k)
        um = dmax1(u(k),um)
        enddo
        vma=sngl(um)  !----------------> The upper limit for integration
        vma=alog(vma) !
        vst = (vma - vmi) / float(lim) !-> step for a rel. en. transfers grid
c
      do j=0,lim
      rnu = vmi + vst*(float(j))
      rnu = exp(rnu)
      aux1(j) = dble(brem_tot4(en,rnu) * rnu)       !-> array to be integrated
c                                                  !   to get mean free path
      aux2(j) = aux1(j) * dble(rnu)                !-> array to be integrated
      enddo                                        !   for getting en. losses
c
      h1 = dble(vmi)
      h2 = dble(vma)
      crt_br2(i) = sngl(dsimps(aux1,h1,h2,lim))
      crt_br2(i) = sngl(a_ef / (avog * ro))/crt_br2(i)!-> array with 17 values
c                                                     !   of free path
      elo_br2(i) = sngl( dsimps(aux2,h1,h2,lim) * avog * ro / a_ef )
      elo_br2(i) = elo_br2(i) * en * 1.e+3
      if(elo_br2(i).le.0.e+0) elo_br2(i) = 1.e-8
      elo_br2(i) = alog10(elo_br2(i)) !-> array with 17 values of en. losses
      enddo
c
c                    c) Energy transfers > 0 :
      do i=1,17
      en = float(i)
      en = (1.e+1)**(5.e-1 + (5.e-1 * en))
      vmi = alog(1.e-3/en)      !------------> The lower limit for integration
c
        um = 0.d+0
        do k=1,nsub
        ene=dble(en)
        u(k)=((z1(k))**(1.d+0/3.d+0))*1.236540953d+0*(rm_mu/(ene*1.d+3))
        u(k) = 1.d+0 - u(k)
        um = dmax1(u(k),um)
        enddo
        vma=sngl(um)  !----------------> The upper limit for integration
        vma=alog(vma) !
        vst = (vma - vmi) / float(lim) !-> step for a rel. en. transfers grid
c
      do j=0,lim
      rnu = vmi + vst*(float(j))
      rnu = exp(rnu)
      aux2(j) = dble(brem_tot4(en,rnu) * rnu * rnu) !-> array to be integrated
c                                                  !   to get en. losses
      enddo
c
      h1 = dble(vmi)
      h2 = dble(vma)
      elo_br3(i) = sngl( dsimps(aux2,h1,h2,lim) * avog * ro / a_ef )
      elo_br3(i) = elo_br3(i) * en * 1.e+3
      if(elo_br3(i).le.0.e+0) elo_br3(i) = 1.e-8
      elo_br3(i) = alog10(elo_br3(i)) !-> array with 17 values of en. losses
      enddo
c                    c) Energy transfers < EMIN
      do i=1,17
      en = float(i)
      en = (1.e+1)**(5.e-1 + (5.e-1 * en))
      vmi = alog(1.e-3/en)      !------------> The lower limit for integration
      vma = alog(emin/en)   !----------------> The upper limit for integration
      vst = (vma - vmi) / float(lim) !----> step for a rel. en. transfers grid
c
      do j=0,lim
      rnu = vmi + vst*(float(j))
      rnu = exp(rnu)
      aux2(j) = dble(brem_tot4(en,rnu) * rnu * rnu) !-> array to be integrated
c                                                  !   to get en. losses
      enddo
c
      h1 = dble(vmi)
      h2 = dble(vma)
      elo_br4(i) = sngl( dsimps(aux2,h1,h2,lim) * avog * ro / a_ef )
      elo_br4(i) = elo_br4(i) * en * 1.e+3 !-> array with 17 values
      enddo                                !    of en. losses
c   ....................................................................
c                      3. COMPUTING OF CF FACTOR:
      if (ibrem.eq.1) then
      en = 1.e+9
      rnu = emin / en
      cf = brem_tot4(en,rnu)
      cf = cf * rnu * 1.02
      endif
      if (ibrem.eq.2) then
      en = 1.e+9
      rnu = emin / en
      cf = brem_tot4(en,rnu)
      cf = cf * rnu * 1.07
      endif
      if ((ibrem.ne.1).AND.(ibrem.ne.2)) then
      en = 1.e+1
      rnu = 1.e-3
      cf = brem_tot4(en,rnu)
      cf = cf * rnu * 1.1
      endif
c
      return
      end
****************************************************************************
* B.6_4
      FUNCTION getlbrem4(X)
*
      real*4 X
      COMMON /sok14/ XMIN,STEP,XMAX
      common /sok1_b4/ C(19)
      X1 = alog10(X)
       if ((X1.lt..99999e+0).or.(X1.gt.9.0001e+0)) then
       print*,'ERROR IN FUNCTION GETLBREMS: MUON ENERGY IS OUT OF RANGE'
       endif
      Y = (X1-XMIN)/STEP
      I = INT(Y+0.5)
      IF(I.LT.0.OR.X1.GT.XMAX) PRINT 1,X1,XMIN,XMAX
      Y = Y-I
      Z = Y*Y + 0.25
      getlbrem4 = (Z-Y)*C(I+1) + (2.-(Z+Z))*C(I+2) + (Z+Y)*C(I+3)
      RETURN
1     FORMAT('*MISTAKE*X1=',D23.16,'XMIN=',D23.16,'XMAX=',D23.16)
      END
****************************************************************************
* B.7_4
*
      FUNCTION glbremv4(X)
*
      real*4 X
      COMMON /sok14/ XMIN,STEP,XMAX
      common /sok1_b24/ C(19)
      X1 = alog10(X)
       if ((X1.lt..99999e+0).or.(X1.gt.9.0001e+0)) then
       print*,'ERROR IN FUNCTION GLBREMVS: MUON ENERGY IS OUT OF RANGE'
       endif
      Y = (X1-XMIN)/STEP
      I = INT(Y+0.5)
      IF(I.LT.0.OR.X1.GT.XMAX) PRINT 1,X1,XMIN,XMAX
      Y = Y-I
      Z = Y*Y + 0.25
      glbremv4 = (Z-Y)*C(I+1) + (2.-(Z+Z))*C(I+2) + (Z+Y)*C(I+3)
      RETURN
1     FORMAT('*MISTAKE*X1=',D23.16,'XMIN=',D23.16,'XMAX=',D23.16)
      END
****************************************************************************
* B.8_4
       function getctbr4(u)
*
      external getlbrem4
      real*8 z1(10),w(10),aw(10),a_ef,alfa,rm_e,rm_mu,r_e,avog,ro
      real*4 u
      common /const4/ alfa,rm_e,rm_mu,r_e,avog
      common /media4/ z1,w,aw,a_ef,ro,nsub
      if ((u.gt.1.0001e+9).or.(u.lt.9.9999e+0)) then
      print*,'ERROR IN FUNCTION GETCTBRS: MUON ENERGY IS OUT OF RANGE'
      endif
      aef = sngl(a_ef / (avog * ro))
      getctbr4 = aef / getlbrem4(u)
      return
      end
************************************************************************
* B.9_4
       function gctbrv4(u)
*
      external glbremv4
      real*8 z1(10),w(10),aw(10),a_ef,alfa,rm_e,rm_mu,r_e,avog,ro
      real*4 u
      common /const4/ alfa,rm_e,rm_mu,r_e,avog
      common /media4/ z1,w,aw,a_ef,ro,nsub
      if ((u.gt.1.0001e+9).or.(u.lt.9.9999e+0)) then
      print*,'ERROR IN FUNCTION GCTBRVS: MUON ENERGY IS OUT OF RANGE'
      endif
      aef = sngl(a_ef / (avog * ro))
      gctbrv4 = aef / glbremv4(u)
      return
      end
***************************************************************************
* B.10_4
         FUNCTION getdedbr4(X)
*
      real*4 X
      COMMON /sok54/ XMIN,STEP,XMAX
      common /sok5_b4/ C(19)
      X1 = alog10(X)
       if ((X1.lt..99999e+0).or.(X1.gt.9.0001e+0)) then
       print*,'ERROR IN FUNCTION GETDEDBRS: MUON ENERGY IS OUT OF RANGE'
       endif
      Y = (X1-XMIN)/STEP
      I = INT(Y+0.5)
      IF(I.LT.0.OR.X1.GT.XMAX) PRINT 1,X1,XMIN,XMAX
      Y = Y-I
      Z = Y*Y + 0.25
      getdedbr4 = (Z-Y)*C(I+1) + (2.-(Z+Z))*C(I+2) + (Z+Y)*C(I+3)
      getdedbr4 = (1.e+1)**(getdedbr4)
      RETURN
1     FORMAT('*MISTAKE*X1=',D23.16,'XMIN=',D23.16,'XMAX=',D23.16)
      END
****************************************************************************
* B.11_4
      FUNCTION gdedbrv4(X)
*
      real*4 X
      COMMON /sok54/ XMIN,STEP,XMAX
      common /sok5_b24/ C(19)
      X1 = alog10(X)
       if ((X1.lt..99999e+0).or.(X1.gt.9.0001e+0)) then
       print*,'ERROR IN FUNCTION GDEDBRVS: MUON ENERGY IS OUT OF RANGE'
       endif
      Y = (X1-XMIN)/STEP
      I = INT(Y+0.5)
      IF(I.LT.0.OR.X1.GT.XMAX) PRINT 1,X1,XMIN,XMAX
      Y = Y-I
      Z = Y*Y + 0.25
      gdedbrv4 = (Z-Y)*C(I+1) + (2.-(Z+Z))*C(I+2) + (Z+Y)*C(I+3)
      gdedbrv4 = (1.e+1)**(gdedbrv4)
      RETURN
1     FORMAT('*MISTAKE*X1=',D23.16,'XMIN=',D23.16,'XMAX=',D23.16)
      END
****************************************************************************
* B.12_4
         FUNCTION gdedbrt4(X)
*
      real*4 X
      COMMON /sok54/ XMIN,STEP,XMAX
      common /sok5_b34/ C(19)
      X1 = alog10(X)
       if ((X1.lt..99999e+0).or.(X1.gt.9.0001e+0)) then
       print*,'ERROR IN FUNCTION GDEDBRTS: MUON ENERGY IS OUT OF RANGE'
       endif
      Y = (X1-XMIN)/STEP
      I = INT(Y+0.5)
      IF(I.LT.0.OR.X1.GT.XMAX) PRINT 1,X1,XMIN,XMAX
      Y = Y-I
      Z = Y*Y + 0.25
      gdedbrt4 = (Z-Y)*C(I+1) + (2.-(Z+Z))*C(I+2) + (Z+Y)*C(I+3)
      gdedbrt4 = (1.e+1)**(gdedbrt4)
      RETURN
1     FORMAT('*MISTAKE*X1=',D23.16,'XMIN=',D23.16,'XMAX=',D23.16)
      END
****************************************************************************
* B.13_4
       FUNCTION getcdbr4(X,Y,loga)
*
       real*4 X,Y
       integer loga
       external getcdbr14,getcdbr24,getcdbr34,brem_tot4
       if (loga.eq.0) then
          if (Y.le..251188643) then
            getcdbr4 = getcdbr14(X,Y,loga)
          else
            if (Y.le..794328234) then
               getcdbr4 = getcdbr24(X,Y,loga)
            else
               if (X.le.1.e+2) then
               Z = 0.97
               else
               Z = 0.992
               endif
               if (Y.le.Z) then
               getcdbr4 = getcdbr34(X,Y,loga)
               else
               getcdbr4 = brem_tot4(X,Y)
               endif
            endif
          endif
       else
          if (Y.le.-6.e-1) then
            getcdbr4 = getcdbr14(X,Y,loga)
          else
            if (Y.le.-1.e-1) then
               getcdbr4 = getcdbr24(X,Y,loga)
            else
               if (X.le.1.e+2) then
               Z = -1.3228265e-2
               else
               Z = -3.4883278e-3
               endif
               if (Y.le.Z) then
               getcdbr4 = getcdbr34(X,Y,loga)
               else
               Y1 = (1.e+1)**Y
               getcdbr4 = brem_tot4(X,Y1)
               endif
            endif
          endif
       endif
      return
      end
****************************************************************************
* B.14_4
       FUNCTION getcdbr14(X,Y,loga)
*
       real*4 X,Y
       integer loga
       common /sok3_4/ C1(4648)
       common /sok_2_14/ NX,NY,X0,SX,Y0,SY
c
      X_1=alog10(X)
c
      if ((X_1.lt..99999e+0).or.(X_1.gt.9.0001e+0)) then
      print*,'ERROR IN FUNCTION GETCDBR1S: MUON ENERGY IS OUT OF RANGE'
      endif
c
      if (loga.eq.0) then
      Y_1=alog10(Y)
      else
      Y_1=Y
      endif
c
      if ((Y_1.lt.-11.001).or.(Y_1.gt.-5.9999e-1)) then
      print*,'ERROR IN FUNCTION GETCDBR1S: EN. TRANSFER IS OUT OF RANGE'
      endif
c
      A3=(X_1-X0)/SX
      B3=(Y_1-Y0)/SY
      M1=INT(A3+.5)
      M2=INT(B3+.5)
      M3=NX+2
      IF(M1.LT.0.OR.M1.GE.NX.OR.M2.LT.0.OR.M2.GE.NY) THEN
      PRINT 1,X_1,M1,Y_1,M2
      ENDIF
      A3=A3-M1
      B3=B3-M2
      M1=M2*M3+M1+1
      M2=M1+M3
      M3=M2+M3
      A2 = A3*A3 +.25
      B2 = B3*B3 +.25
      A1=A2-A3
      B1=B2-B3
      A3=A2+A3
      B3=B2+B3
      A2=2.-(A2+A2)
      B2=2.-(B2+B2)
      getcdbr14=(A1*C1(M1)+A2*C1(M1+1)+A3*C1(M1+2))*B1
     2      +(A1*C1(M2)+A2*C1(M2+1)+A3*C1(M2+2))*B2
     3      +(A1*C1(M3)+A2*C1(M3+1)+A3*C1(M3+2))*B3
      if (getcdbr14.lt.0.e+0) getcdbr14 = 0.e+0
      RETURN
1     FORMAT('*MISTAKE*X=',D23.16,'MX=',I4,'Y=',D23.16,'MY=',I4)
      END
****************************************************************************
* B.15_4
       FUNCTION getcdbr24(X,Y,loga)
*
       real*4 X,Y
       integer loga
       common /sok64/ C1(4399)
       common /sok_2_24/ NX,NY,X0,SX,Y0,SY
c
      X_1=alog10(X)
      if ((X_1.lt..99999e+0).or.(X_1.gt.9.000001e+0)) then
      print*,'ERROR IN FUNCTION GETCDBR2S: MUON ENERGY IS OUT OF RANGE'
      endif
c
      if (loga.eq.0) then
      Y_1=alog10(Y)
      else
      Y_1=Y
      endif
c
      if ((Y_1.lt.-.60001).or.(Y_1.gt.-.99999e-1)) then
      print*,'ERROR IN FUNCTION GETCDBR2S: EN. TRANSFer IS OUT OF RANGE'
      endif
c
      A3=(X_1-X0)/SX
      B3=(Y_1-Y0)/SY
      M1=INT(A3+.5)
      M2=INT(B3+.5)
      M3=NX+2
      IF(M1.LT.0.OR.M1.GE.NX.OR.M2.LT.0.OR.M2.GE.NY) THEN
      PRINT 1,X_1,M1,Y_1,M2
      ENDIF
      A3=A3-M1
      B3=B3-M2
      M1=M2*M3+M1+1
      M2=M1+M3
      M3=M2+M3
      A2=A3*A3+.25
      B2=B3*B3+.25
      A1=A2-A3
      B1=B2-B3
      A3=A2+A3
      B3=B2+B3
      A2=2.-(A2+A2)
      B2=2.-(B2+B2)
      getcdbr24=(A1*C1(M1)+A2*C1(M1+1)+A3*C1(M1+2))*B1
     2      +(A1*C1(M2)+A2*C1(M2+1)+A3*C1(M2+2))*B2
     3      +(A1*C1(M3)+A2*C1(M3+1)+A3*C1(M3+2))*B3
      if (getcdbr24.lt.0.e+0) getcdbr24 = 0.e+0
      RETURN
1     FORMAT('*MISTAKE*X=',D23.16,'MX=',I4,'Y=',D23.16,'MY=',I4)
      END
****************************************************************************
* B.16_4
       FUNCTION getcdbr34(X,Y,loga)
*
       real*4 X,Y
       integer loga
       common /sok44/ C2(8549)
       common /sok_2_34/ NX,NY,X0,SX,Y0,SY
c
      X_1=alog10(X)
      if ((X_1.lt..99999e+0).or.(X_1.gt.9.000001e+0)) then
      print*,'ERROR IN FUNCTION GETCDBR3S: MUON ENERGY IS OUT OF RANGE'
      endif
c
      if (loga.eq.0) then
      Y_1=alog10(Y)
      else
      Y_1=Y
      endif
c
      if ((Y_1.lt.-1.00001e-1).or.(Y_1.gt.1.e-10)) then
      print*,'ERROR IN FUNCTION GETCDBR3S: EN. TRANSFER IS OUT OF RANGE'
      endif
c
      A3=(X_1-X0)/SX
      B3=(Y_1-Y0)/SY
      M1=INT(A3+.5)
      M2=INT(B3+.5)
      M3=NX+2
      IF(M1.LT.0.OR.M1.GE.NX.OR.M2.LT.0.OR.M2.GE.NY) THEN
      PRINT 1,X_1,M1,Y_1,M2
      ENDIF
      A3=A3-M1
      B3=B3-M2
      M1=M2*M3+M1+1
      M2=M1+M3
      M3=M2+M3
      A2=A3*A3+.25
      B2=B3*B3+.25
      A1=A2-A3
      B1=B2-B3
      A3=A2+A3
      B3=B2+B3
      A2=2.-(A2+A2)
      B2=2.-(B2+B2)
      getcdbr34=(A1*C2(M1)+A2*C2(M1+1)+A3*C2(M1+2))*B1
     2      +(A1*C2(M2)+A2*C2(M2+1)+A3*C2(M2+2))*B2
     3      +(A1*C2(M3)+A2*C2(M3+1)+A3*C2(M3+2))*B3
      if (getcdbr34.lt.0.e+0) getcdbr34 = 0.e+0
      RETURN
1     FORMAT('*MISTAKE*X=',D23.16,'MX=',I4,'Y=',D23.16,'MY=',I4)
      END
****************************************************************************
* B.17_4
*
      SUBROUTINE getvbrem4(emw,vbr,itr)
*
      real*4 emw,vbr
      integer itr
      external getcdbr4
      parameter (lo=1)
      common /general4/ emin,vmin,emph
      common /mcef4/ mcb1,mcb2,mcp1,mcp2,mcn1,mcn2,mce1,mce2
      common /br_ref4/ cf
      mcb1 = mcb1 + 1
         if (itr.eq.0) then
          algemin = alog10(emin/emw)
         else
          algemin = alog10(vmin)
         endif
  155 ax = algemin * rndm_mum(5)
      mcb2 = mcb2 + 1
      y1 = getcdbr4(emw,ax,lo)
      vbr = exp(-2.3025851e+0 * ax)
      y2 = cf * vbr
      yc = y2 * rndm_mum(8)
        if (y1.ge.yc) then
        vbr = 1.e+0 / vbr
        else
        goto 155
        endif
      return
      end
****************************************************************************
*********************** PAIR PRODUCTION SUBROUTINES : **********************
****************************************************************************
* P.1_4
*
      function CRP_G44 (Z,A,Tkin,EP)
c   ame in GeV:
       parameter    (ame=0.51099907e-3)
ccc parameter   (amu=0.105658389)   !!! GeV
c   re in cm:
      parameter (re=2.81794092e-13)
      parameter (avno=6.022137e23)
      parameter (pi=3.14159265)
c   parameter   (alpha=1./137.036)
ccc parameter   (rmass=amu/ame)     !!! "207"
c   parameter   (coeff=4./(3.*pi)*(alpha*re)**2*avno) !!! cm^2
c   sqrt(2.71828...):
      parameter (sqrte=1.64872127)
ccc parameter   (c3=3.*sqrte*amu/4.)    !!! for limits
c   parameter   (c7=4.*ame)     !!! -"-
ccc parameter   (c8=6.*amu**2)      !!! -"-
        common /const/ alfa,rm_e,rm_mu,r_e,avog
        real*8 alfa,rm_e,rm_mu,r_e,avog
        real*4 Z,A,Tkin,EP
c     Gauss, N=8:
      DIMENSION XGI(8),WGI(8)
      DATA XGI /.0199,.1017,.2372,.4083,.5917,.7628,.8983,.9801/
      DATA WGI /.0506,.1112,.1569,.1813,.1813,.1569,.1112,.0506/
c   for the moment:
      data  bbbtf,bbbh /183.,202.4/
      data  g1tf,g2tf /1.95e-5,5.3e-5/
      data  g1h,g2h   / 4.4e-5,4.8e-5/
        common /exer1/ fa
c************************************************************************
        adummy=a
        alpha=1./137.036
        coeff=4./(3.*pi)*(alpha*re)**2*avno
        c7=4.*ame
c************************************************************************
        amu = 1.e-3 * sngl(rm_mu)
        rmass = amu/ame
        c3=3.*sqrte*amu/4.
        c8=6.*amu**2
c************************************************************************
        E=tkin+amu
        z13=z**0.3333333
        e1=e-ep
        crp_g44=0.
        if (e1.le.c3*z13) return    !!! ep > max
        alf=c7/ep           !!! 4m/ep
        a3=1.-alf
        if (a3.le.0.) return        !!! ep < min
C***        zeta calculation
        if (z.le.1.5) then  !!! special case of hidrogen
           bbb=bbbh
           g1=g1h
           g2=g2h
        else
           bbb=bbbtf
           g1=g1tf
           g2=g2tf
        end if
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c  INSERTED BY SOKALSKI TO TAKE INTO ACCOUNT DIFFERENT BBB for
c  DIFFERENT NUCLEI (S.P.KELNER, R.P.KOKOULIN, A.A.PETRUKHIN,
c  Yad.Fiz. 62, 2042 (1999) [Phys.Atom.Nucl. 62, 1894 (1999)]
c
       ztmp = z + 1.e-2
       itmp = int(ztmp)
       if (itmp.eq.1) bbb=202.4
       if (itmp.eq.2) bbb=151.9
       if (itmp.eq.3) bbb=159.9
       if (itmp.eq.4) bbb=172.3
       if (itmp.eq.5) bbb=177.9
       if (itmp.eq.6) bbb=178.3
       if (itmp.eq.7) bbb=176.6
       if (itmp.eq.8) bbb=173.4
       if (itmp.eq.9) bbb=170.0
       if (itmp.eq.10) bbb=165.8
       if (itmp.eq.11) bbb=165.8
       if (itmp.eq.12) bbb=167.1
       if (itmp.eq.13) bbb=169.1
       if (itmp.eq.14) bbb=170.8
       if (itmp.eq.15) bbb=172.2
       if (itmp.eq.16) bbb=173.4
       if (itmp.eq.17) bbb=174.3
       if (itmp.eq.18) bbb=174.8
       if (itmp.eq.19) bbb=175.1
       if (itmp.eq.20) bbb=175.6
       if (itmp.eq.21) bbb=176.2
       if (itmp.eq.22) bbb=176.8
       if (itmp.eq.26) bbb=175.8
       if (itmp.eq.29) bbb=173.1
       if (itmp.eq.32) bbb=173.0
       if (itmp.eq.35) bbb=173.5
       if (itmp.eq.42) bbb=175.9
       if (itmp.eq.50) bbb=177.4
       if (itmp.eq.53) bbb=178.6
       if (itmp.eq.74) bbb=177.6
       if (itmp.eq.82) bbb=178.0
       if (itmp.eq.92) bbb=179.8
cccccccccccccccccccccccccccccccccccccccccccccccccc
      zeta1=0.073*alog(e/(amu+g1*z13**2*e))-0.26
      if (zeta1.gt.0.) then
         zeta2=0.058*alog(e/(amu+g2*z13   *e))-0.14
         zeta=zeta1/zeta2
      else
         zeta=0.
      end if
      z2=z*(z+zeta)             !!!
      screen0=2.*ame*sqrte*bbb/(z13*ep) !!! be careful with "ame"
      a0=e*e1
      a1=ep*ep/a0           !!! 2*beta
      bet=0.5*a1            !!! beta
      xi0=0.25*rmass*rmass*a1       !!! xi0
      del=c8/a0         !!! 6mu^2/EE'
      tmn=alog((alf+2.*del*a3)/(1.+(1.-del)*sqrt(a3))) !!! log(1-rmax)
      sum=0.
      do i=1,8      !!! integration
         a4=exp(tmn*xgi(i)) !!! 1-r
         a5=a4*(2.-a4)      !!! 1-r2
         a6=1.-a5       !!! r2
         a7=1.+a6       !!! 1+r2
         a9=3.+a6       !!! 3+r2
         xi=xi0*a5
         xii=1./xi
         xi1=1.+xi
         screen=screen0*xi1/a5
         yeu=5.-a6+4.*bet*a7
         yed=2.*(1.+3.*bet)*alog(3.+xii)-a6-a1*(2.-a6)
         ye1=1.+yeu/yed
         ale=alog(bbb/z13*sqrt(xi1*ye1)/(1.+screen*ye1))
         cre=0.5*alog(1.+(1.5/rmass*z13)**2*xi1*ye1)
         if (xi.le.1e3) then    !!!
            be=((2.+a6)*(1.+bet)+xi*a9)*alog(1.+xii)+(a5-bet)/xi1-a9
         else
            be=(3.-a6+a1*a7)/(2.*xi) !!!-(6.-5.*a6+3.*bet*a6)/(6.*xi*xi)
         end if
         if(rm_mu.le.1.d+3) then
            fe=amax1(0.,(ale-cre)*be)
         else
            fe=amax1(0.,ale*be)
         endif
         ymu=4.+a6+3.*bet*a7
         ymd=a7*(1.5+a1)*alog(3.+xi)+1.-1.5*a6
         ym1=1.+ymu/ymd
         alm_crm=alog(bbb*rmass/(1.5*z13*z13*(1.+screen*ym1)))
         if (xi.ge.1e-3) then   !!!
            a10=(1.+a1)*a5      !!! (1+2b)(1-r2)
            bm=(a7*(1.+1.5*bet)-a10*xii)*alog(xi1)+xi*(a5-bet)/xi1+a10
         else
            bm=(5.-a6+bet*a9)*(xi/2.) !!!-(11.-5.*a6+.5*bet*(5.+a6))*(xi*xi/6.)
         end if
         fm=amax1(0.,(alm_crm)*bm)
         if(rm_mu.le.1.d+3) then
            sum=sum+a4*(fe+fm/rmass**2)*wgi(i)
         else
            sum=sum+a4*fe*wgi(i)
         endif
      end do
      crp_g44=fa*(-tmn*sum*z2*coeff*e1/ep)/avno
                                     ! Vstavleno Sokalskim
c                                    ! (dobavlen mnozhitel
c                                    ! (A / N_a) * E )
      return
      end
****************************************************************************
* P.2_4
*
       real*8 function pair4(z,en,rnu)
       external CRP_G44
       real*8 z,en,rnu
       real*8 alfa,rm_e,rm_mu,r_e,avog
       common /const4/ alfa,rm_e,rm_mu,r_e,avog
       z0 = sngl(z)
       A = 10.
c       Tkin = sngl(en - 1.05658389d-1)
       Tkin = sngl(en) - (1.e-3 * sngl(rm_mu))
       ep = sngl(rnu * en)
       pa = CRP_G44(z0,A,Tkin,ep)
       pair4 = dble(pa)
       return
       end
****************************************************************************
* P.3_4
*
       function pair_tot4(ene,v)
       external pair4
       real*8 z1(10),w(10),aw(10),a_ef,en,rnu,h1,pair4,ro
       real*4 ene,v
       integer nsub
       common /media4/ z1,w,aw,a_ef,ro,nsub
c
       if (v.gt..999995) v = .999995
       en = dble(ene)
       rnu = dble(v)
       h1 = w(1) * pair4(z1(1),en,rnu)
         if (nsub.ge.2) then
           do l=2,nsub
             h1 = h1 + (w(l) * pair4(z1(l),en,rnu))
           enddo
         endif
       pair_tot4 = sngl(h1)
       return
       end
****************************************************************************
* P.4_4
       subroutine pair14
*
       external pair_tot4,dsimps
       real*8 dsimps
       real*8 ai,bi,h1,h2,um,ene,u(10)
       real*8 aux1(0:2000),aux2(0:2000)
       real*8 alfa,rm_e,rm_mu,r_e,avog,z1(10),w(10),aw(10),a_ef,ro
       real*8 com1_pa(0:2200),com_pa_in(1101),com_p_h(0:2),tot_pa
       dimension com_pa_m(2201)
       common /help_14/ aux1,aux2
       common /const4/ alfa,rm_e,rm_mu,r_e,avog ! from initial subroutine
       common /media4/ z1,w,aw,a_ef,ro,nsub     !       MED_CONSS
       common /general4/ emin,vmin,emph         !
       common /cdpa_in4/ fcd1(81,54),fcd2(81,101),fcd3(81,51)
       common /ctpa_in14/ crt_pa1(17),crt_pa2(17)
       common /elpa_in14/ elo_pa1(17),elo_pa2(17)
       common /elpa_in24/ elo_pa3(17)
       common /elpa_in44/ elo_pa4(17)
       common /sok344/ com_pa_m
       common /sok244/ com_pa_in
       common /sok334/ tot_pa
       common /fac_pa4/ fac
       fac = 1.12
c ....................................................................
c      1.PREPARATION OF ARRAYS WITH DIFF. CROSS-SEECTIONS FOR MUON
c                           E+E- PAIR PRODUCTION:
c
c                !       ..........................
      do j=1,81  !--->   j CYCLE BY ENERGIES starts
c                !       ..........................
        en = float(j)
        en = 1.e+1**(9.e-1 + (1.e-1 * en))
c                     !         ..................................
      do k=1,206      !--->     k CYCLE BY ENERGY TRANSFERS starts
c                     !         ..................................
      if (k.eq.206) then
        fcd2(j,k-105) = -37.0
        goto 975
      endif
c
      if (k.le.54) then
         k01 = k - 1
         rnu = 1.e+1**(float(k01) * 2.e-1 - 1.1e+1)
      else
         if (k.le.105) then
           k01 = k - 55
           rnu = 1.e+1**(float(k01) * 1.e-2 - 6.e-1)
         else
           k01 = k - 106
           rnu = 1.e+1**(float(k01) * 1.e-3 - 1.e-1)
         endif
      endif
c
      cr_dif=pair_tot4(en,rnu)
      if (cr_dif.le.1.e-37) cr_dif = 1.e-37
      cr_dif=alog(cr_dif)
c
      if (k.le.54) fcd1(j,k) = cr_dif
      if ((k.gt.54).AND.(k.lt.106)) fcd3(j,k-54) = cr_dif
      if (k.ge.106) fcd2(j,k-105) = cr_dif
c
 975  continue
c              !     ....................................
      enddo    !---> k CYCLE BY ENERGY TRANSFERS finishes
c              !     ....................................
      enddo    !----> j CYCLE BY ENERGIES finishes
c              !     ....................................
c   ....................................................................
c      2.PREPARATION OF ARRAYS WITH ENERGY LOSSES AND MEAN FREE PATH
c                         FOR MUON BREMSSTRAHLUNG:
c
c                    a) Energy transfers > EMIN :
      lim = 2000
      do i=1,17
      en = float(i)
      en = (1.e+1)**(5.e-1 + (5.e-1 * en))
      vmi = alog(emin / en) !------------> The lower limit for integration
        um = 0.d+0
        do k=1,nsub
        ene=dble(en)
        u(k)=((z1(k))**(1.d+0/3.d+0))*1.236540953d+0*(rm_mu/(ene*1.d+3))
        u(k) = 1.d+0 - u(k)
        um = dmax1(u(k),um)
        enddo
        vma=sngl(um)  !----------------> The upper limit for integration
        vma=alog(vma) !
        vst = (vma - vmi) / float(lim) !-> step for a rel. en. transfers grid
      do j=0,lim
      rnu = vmi + vst*(float(j))
      rnu = exp(rnu)
      aux1(j) = dble(pair_tot4(en,rnu) * rnu)       !-> array to be integrated
c                                                  !   to get mean free path
      aux2(j) = aux1(j) * dble(rnu)                !-> array to be integrated
      enddo                                        !   for getting en. losses
c
      h1 = dble(vmi)
      h2 = dble(vma)
      crt_pa1(i) = sngl(dsimps(aux1,h1,h2,lim))        !-> array with 17 values
      crt_pa1(i) = sngl(a_ef / (avog * ro))/crt_pa1(i) !   of free path
      crt_pa1(i) = alog(crt_pa1(i))
      elo_pa1(i) = sngl( dsimps(aux2,h1,h2,lim) * avog * ro / a_ef )
      elo_pa1(i) = elo_pa1(i) * en * 1.e+3
      elo_pa1(i) = alog(elo_pa1(i)) !-> array with 17 values of en. losses
      enddo
c                    b) Energy transfers > VMIN :
      do i=1,17
      en = float(i)
      en = (1.e+1)**(5.e-1 + (5.e-1 * en))
      vmi = alog(vmin) !------------> The lower limit for integration
        um = 0.d+0
        do k=1,nsub
        ene=dble(en)
        u(k)=((z1(k))**(1.d+0/3.d+0))*1.236540953d+0*(rm_mu/(ene*1.d+3))
        u(k) = 1.d+0 - u(k)
        um = dmax1(u(k),um)
        enddo
        vma=sngl(um)  !----------------> The upper limit for integration
        vma=alog(vma) !
        vst = (vma - vmi) / float(lim) !-> step for a rel. en. transfers grid
c
      do j=0,lim
      rnu = vmi + vst*(float(j))
      rnu = exp(rnu)
      aux1(j) = dble(pair_tot4(en,rnu) * rnu)       !-> array to be integrated
c                                                  !   to get mean free path
      aux2(j) = aux1(j) * dble(rnu)                !-> array to be integrated
      enddo                                        !   for getting en. losses
c
      h1 = dble(vmi)
      h2 = dble(vma)
      crt_pa2(i) = sngl(dsimps(aux1,h1,h2,lim))         !-> array with 17 values
      crt_pa2(i) = sngl(a_ef / (avog * ro))/crt_pa2(i)  !   of free path
      crt_pa2(i) = alog(crt_pa2(i))
      elo_pa2(i) = sngl( dsimps(aux2,h1,h2,lim) * avog * ro / a_ef )
      elo_pa2(i) = elo_pa2(i) * en * 1.e+3
      if(elo_pa2(i).le.0.e+0) elo_pa2(i) = 1.e-8
      elo_pa2(i) = alog(elo_pa2(i)) !-> array with 17 values of en. losses
      enddo
c                    c) Energy transfers > 0 :
      do i=1,17
      en = float(i)
      en = (1.e+1)**(5.e-1 + (5.e-1 * en))
      vmi = alog(2.046e-3/en) !------------> The lower limit for integration
c
        um = 0.d+0
        do k=1,nsub
        ene=dble(en)
        u(k)=((z1(k))**(1.d+0/3.d+0))*1.236540953d+0*(rm_mu/(ene*1.d+3))
        u(k) = 1.d+0 - u(k)
        um = dmax1(u(k),um)
        enddo
        vma=sngl(um)  !----------------> The upper limit for integration
        vma=alog(vma) !
        vst = (vma - vmi) / float(lim) !-> step for a rel. en. transfers grid
      do j=0,lim
      rnu = vmi + vst*(float(j))
      rnu = exp(rnu)
      aux2(j) = dble(pair_tot4(en,rnu) * rnu * rnu) !-> array to be integrated
      enddo                                        !   for getting en. losses
c
      h1 = dble(vmi)
      h2 = dble(vma)
      elo_pa3(i) = sngl( dsimps(aux2,h1,h2,lim) * avog * ro / a_ef )
      elo_pa3(i) = elo_pa3(i) * en * 1.e+3
      if(elo_pa3(i).le.0.e+0) elo_pa3(i) = 1.e-8
      elo_pa3(i) = alog(elo_pa3(i)) !-> array with 17 values of en. losses
      enddo
c                    d) Energy transfers < EMIN :
      do i=1,17
      en = float(i)
      en = (1.e+1)**(5.e-1 + (5.e-1 * en))
      vmi = alog(2.046e-3/en) !------------> The lower limit for integration
      vma = alog(emin/en)  !----------------> The upper limit for integration
      vst = (vma - vmi) / float(lim) !---> step for a rel. en. transfers grid
      do j=0,lim
      rnu = vmi + vst*(float(j))
      rnu = exp(rnu)
      aux2(j) = dble(pair_tot4(en,rnu) * rnu * rnu) !-> array to be integrated
      enddo                                        !   for getting en. losses
c
      h1 = dble(vmi)
      h2 = dble(vma)
      elo_pa4(i) = sngl( dsimps(aux2,h1,h2,lim) * avog * ro / a_ef )
      elo_pa4(i) = elo_pa4(i) * en * 1.e+3 !-> array with 17 values
      enddo                                !   of en. losses
c   ....................................................................
c   3. PREPARATION OF ARRAY COM_PA_M WITH VALUES OF COMPARISON FUNCTION:
         en = 1.e+9
           do i=1,2201
              i1 = i - 1
              rnu = 1.e+1**(float(i1) * 5.e-3 - 1.1e+1)
              com_pa_m(i) = fac * pair_tot4(en,rnu)
              com1_pa(i-1) = dble(com_pa_m(i) * rnu)
           enddo
           do i=1,2201
              if (com_pa_m(i).le.0.e+0) com_pa_m(i) = 1.0001e-37
              com_pa_m(i)=alog(com_pa_m(i))
           enddo
c   ....................................................................
c       4. PREPARATION OF ARRAY COM_PA_IN WITH VALUES OF INTEGRATED
c                 COMPARISON FUNCTION AND VALUE OF TOT_PA:
        com_pa_in(1) = 0.d+0
        h1 = 0.d+0
        m = 2
          do i=2,1101
             i1 = 2 * i
               com_p_h(0) = com1_pa(i1-4)
               com_p_h(1) = com1_pa(i1-3)
               com_p_h(2) = com1_pa(i1-2)
             ai = -((dble(1102 - i)) * 1.d-2)
             bi = ai + 1.d-2
             ai = 2.302585093 * ai
             bi = 2.302585093 * bi
             h2 = dsimps(com_p_h,ai,bi,m)
             h1 = h1 + h2
             com_pa_in(i) = h1
          enddo
        tot_pa = com_pa_in(1101)
       return
       end
****************************************************************************
* P.5_4
      FUNCTION getlpair4(X)
*
      real*4 X
      COMMON /sok14/ XMIN,STEP,XMAX
      common /sok1_p4/ C(19)
      X1 = alog10(X)
       if ((X1.lt..99999e+0).or.(X1.gt.9.0001e+0)) then
       print*,'ERROR IN FUNCTION GETLPAIRS: MUON ENERGY IS OUT OF RANGE'
       endif
      Y = (X1-XMIN)/STEP
      I = INT(Y+0.5)
      IF(I.LT.0.OR.X1.GT.XMAX) PRINT 1,X1,XMIN,XMAX
      Y = Y-I
      Z = Y*Y + 0.25
      getlpair4 = (Z-Y)*C(I+1) + (2.-(Z+Z))*C(I+2) + (Z+Y)*C(I+3)
      getlpair4 = exp(getlpair4)
      RETURN
1     FORMAT('*MISTAKE*X1=',D23.16,'XMIN=',D23.16,'XMAX=',D23.16)
      END
****************************************************************************
* P.6_4
      FUNCTION glpairv4(X)
*
      real*4 X
      COMMON /sok14/ XMIN,STEP,XMAX
      common /sok1_p24/ C(19)
      X1 = alog10(X)
       if ((X1.lt..99999e+0).or.(X1.gt.9.0001e+0)) then
       print*,'ERROR IN FUNCTION GLPAIRVS: MUON ENERGY IS OUT OF RANGE'
       endif
      Y = (X1-XMIN)/STEP
      I = INT(Y+0.5)
      IF(I.LT.0.OR.X1.GT.XMAX) PRINT 1,X1,XMIN,XMAX
      Y = Y-I
      Z = Y*Y + 0.25
      glpairv4 = (Z-Y)*C(I+1) + (2.-(Z+Z))*C(I+2) + (Z+Y)*C(I+3)
      glpairv4 = exp(glpairv4)
      RETURN
1     FORMAT('*MISTAKE*X1=',D23.16,'XMIN=',D23.16,'XMAX=',D23.16)
      END
****************************************************************************
* P.7_4
       function getctpa4(u)
*
       external getlpair4
       real*8 z1(10),w(10),aw(10),a_ef,alfa,rm_e,rm_mu,r_e,avog,ro
       real*4 u
       common /const4/ alfa,rm_e,rm_mu,r_e,avog
       common /media4/ z1,w,aw,a_ef,ro,nsub
      if ((u.gt.1.0001e+9).or.(u.lt.9.9999e+0)) then
      print*,'ERROR IN FUNCTION GETCTPAS: MUON ENERGY IS OUT OF RANGE'
      endif
      aef = sngl(a_ef / (avog * ro))
      getctpa4 = aef / getlpair4(u)
      return
      end
*************************************************************************
* P.8_4
       function gctpav4(u)
*
       real*4 u
       external glpairv4
       real*8 z1(10),w(10),aw(10),a_ef,alfa,rm_e,rm_mu,r_e,avog,ro
       common /const4/ alfa,rm_e,rm_mu,r_e,avog
       common /media4/ z1,w,aw,a_ef,ro,nsub
      if ((u.gt.1.0001e+9).or.(u.lt.9.9999e+0)) then
      print*,'ERROR IN FUNCTION GCTPAVS: MUON ENERGY IS OUT OF RANGE'
      endif
      aef = sngl(a_ef / (avog * ro))
      gctpav4 = aef / glpairv4(u)
      return
      end
************************************************************************
* P.9_4
       FUNCTION getdedpa4(X)
*
      real*4 X
      COMMON /sok54/ XMIN,STEP,XMAX
      common /sok5_p4/ C(19)
      X1 = alog10(X)
       if ((X1.lt..99999e+0).or.(X1.gt.9.0001e+0)) then
       print*,'ERROR IN FUNCTION GETDEDPAS: MUON ENERGY IS OUT OF RANGE'
       endif
      Y = (X1-XMIN)/STEP
      I = INT(Y+0.5)
      IF(I.LT.0.OR.X1.GT.XMAX) PRINT 1,X1,XMIN,XMAX
      Y = Y-I
      Z = Y*Y + 0.25
      getdedpa4 = (Z-Y)*C(I+1) + (2.-(Z+Z))*C(I+2) + (Z+Y)*C(I+3)
      getdedpa4 = exp(getdedpa4)
      RETURN
1     FORMAT('*MISTAKE*X1=',D23.16,'XMIN=',D23.16,'XMAX=',D23.16)
      END
****************************************************************************
* P.10_4
      FUNCTION gdedpav4(X)
*
      real*4 X
      COMMON /sok54/ XMIN,STEP,XMAX
      common /sok5_p24/ C(19)
      X1 = alog10(X)
       if ((X1.lt..99999e+0).or.(X1.gt.9.0001e+0)) then
       print*,'ERROR IN FUNCTION GDEDPAVS: MUON ENERGY IS OUT OF RANGE'
       endif
      Y = (X1-XMIN)/STEP
      I = INT(Y+0.5)
      IF(I.LT.0.OR.X1.GT.XMAX) PRINT 1,X1,XMIN,XMAX
      Y = Y-I
      Z = Y*Y + 0.25
      gdedpav4 = (Z-Y)*C(I+1) + (2.-(Z+Z))*C(I+2) + (Z+Y)*C(I+3)
      gdedpav4 = exp(gdedpav4)
      RETURN
1     FORMAT('*MISTAKE*X1=',D23.16,'XMIN=',D23.16,'XMAX=',D23.16)
      END
****************************************************************************
* P.11_4
       FUNCTION gdedpat4(X)
*
      real*4 X
      COMMON /sok54/ XMIN,STEP,XMAX
      common /sok5_p34/ C(19)
      X1 = alog10(X)
       if ((X1.lt..99999e+0).or.(X1.gt.9.0001e+0)) then
       print*,'ERROR IN FUNCTION GDEDPATS: MUON ENERGY IS OUT OF RANGE'
       endif
      Y = (X1-XMIN)/STEP
      I = INT(Y+0.5)
      IF(I.LT.0.OR.X1.GT.XMAX) PRINT 1,X1,XMIN,XMAX
      Y = Y-I
      Z = Y*Y + 0.25
      gdedpat4 = (Z-Y)*C(I+1) + (2.-(Z+Z))*C(I+2) + (Z+Y)*C(I+3)
      gdedpat4 = exp(gdedpat4)
      RETURN
1     FORMAT('*MISTAKE*X1=',D23.16,'XMIN=',D23.16,'XMAX=',D23.16)
      END
****************************************************************************
* P.12_4
        FUNCTION getcdp4(X,Y,lo)
*
       real*4 X,Y
       integer lo
       external getcdp14,getcdp24,getcdp34,pair_tot4
       if (lo.eq.0) then
          if (Y.le..251188643) then
                getcdp4 = getcdp14(X,Y,lo)
               getcdp4 = exp(getcdp4)
          else
               if (Y.le..794328234) then
                  getcdp4 = getcdp24(X,Y,lo)
                  getcdp4 = exp(getcdp4)
               else
                 if (Y.le..965) then
                    getcdp4 = getcdp34(X,Y,lo)
                    getcdp4 = exp(getcdp4)
                 else
                    getcdp4 = pair_tot4(X,Y)
                 endif
               endif
          endif
       else
          if (Y.le.-6.e-1) then
                getcdp4 = getcdp14(X,Y,lo)
                getcdp4 = exp(getcdp4)
          else
                if (Y.le.-1.e-1) then
                   getcdp4 = getcdp24(X,Y,lo)
                   getcdp4 = exp(getcdp4)
                else
                   if (Y.le.-1.547272686e-2) then
                     getcdp4 = getcdp34(X,Y,lo)
                     getcdp4 = exp(getcdp4)
                   else
                     Y1 = (1.e+1)**Y
                     getcdp4 = pair_tot4(X,Y1)
                   endif
                endif
          endif
       endif
      if (getcdp4.lt.0.e+0) getcdp4 = 0.e+0
      return
      end
****************************************************************************
* P.13_4
        FUNCTION getcdp14(X,Y,loga)
*
      real*4 X,Y
      integer loga
      common /sok84/ C1(4648)
      common /sok_2_14/ NX,NY,X0,SX,Y0,SY
      X_1=alog10(X)
      if ((X_1.lt..99999e+0).or.(X_1.gt.9.0001e+0)) then
      print*,'ERROR IN FUNCTION GETCDP1S: MUON ENERGY IS OUT OF RANGE'
      endif
c
      if (loga.eq.0) then
      Y_1=alog10(Y)
      else
      Y_1=Y
      endif
      if ((Y_1.lt.-11.001).or.(Y_1.gt.-5.9999e-1)) then
      print*,'ERROR IN FUNCTION GETCDP1: EN. TRANSFER IS OUT OF RANGE'
      endif
c
      A3=(X_1-X0)/SX
      B3=(Y_1-Y0)/SY
      M1=INT(A3+.5)
      M2=INT(B3+.5)
      M3=NX+2
      IF(M1.LT.0.OR.M1.GE.NX.OR.M2.LT.0.OR.M2.GE.NY) THEN
      PRINT 1,X_1,M1,Y_1,M2
      ENDIF
      A3=A3-M1
      B3=B3-M2
      M1=M2*M3+M1+1
      M2=M1+M3
      M3=M2+M3
      A2=A3*A3+.25
      B2=B3*B3+.25
      A1=A2-A3
      B1=B2-B3
      A3=A2+A3
      B3=B2+B3
      A2=2.-(A2+A2)
      B2=2.-(B2+B2)
      getcdp14=(A1*C1(M1)+A2*C1(M1+1)+A3*C1(M1+2))*B1
     2      +(A1*C1(M2)+A2*C1(M2+1)+A3*C1(M2+2))*B2
     3      +(A1*C1(M3)+A2*C1(M3+1)+A3*C1(M3+2))*B3
      RETURN
1     FORMAT('GETCDP1: *MISTAKE*X= ',D23.16,' MX= ',I4,' Y= ',D23.16,' M
     *Y= ',I4)
      END
****************************************************************************
* P.14_4
       FUNCTION getcdp24(X,Y,loga)
*
       real*4 X,Y
       integer loga
       common /sok94/ C1(4399)
       common /sok_2_24/ NX,NY,X0,SX,Y0,SY
      X_1=alog10(X)
      if ((X_1.lt..99999e+0).or.(X_1.gt.9.0001e+0)) then
      print*,'ERROR IN FUNCTION GETCDP2S: MUON ENERGY IS OUT OF RANGE'
      endif
      if (loga.eq.0) then
      Y_1=alog10(Y)
      else
      Y_1=Y
      endif
      if ((Y_1.lt.-.60001).or.(Y_1.gt.-.99999e-1)) then
      print*,'ERROR IN FUNCTION GETCDP2S: EN. TRANSFer IS OUT OF RANGE'
      endif
      A3=(X_1-X0)/SX
      B3=(Y_1-Y0)/SY
      M1=INT(A3+.5)
      M2=INT(B3+.5)
      M3=NX+2
      IF(M1.LT.0.OR.M1.GE.NX.OR.M2.LT.0.OR.M2.GE.NY) THEN
      PRINT 1,X_1,M1,Y_1,M2
      ENDIF
      A3=A3-M1
      B3=B3-M2
      M1=M2*M3+M1+1
      M2=M1+M3
      M3=M2+M3
      A2=A3*A3+.25
      B2=B3*B3+.25
      A1=A2-A3
      B1=B2-B3
      A3=A2+A3
      B3=B2+B3
      A2=2.-(A2+A2)
      B2=2.-(B2+B2)
      getcdp24=(A1*C1(M1)+A2*C1(M1+1)+A3*C1(M1+2))*B1
     2      +(A1*C1(M2)+A2*C1(M2+1)+A3*C1(M2+2))*B2
     3      +(A1*C1(M3)+A2*C1(M3+1)+A3*C1(M3+2))*B3
      RETURN
1     FORMAT('GCDP2S:*MISTAKE*X=',D23.16,'MX=',I4,'Y=',D23.16,'MY=',I4)
      END
****************************************************************************
* P.15_4
       FUNCTION getcdp34(X,Y,loga)
*
       real*4 X,Y
       integer loga
       common /sok104/ C2(8549)
       common /sok_2_34/ NX,NY,X0,SX,Y0,SY
      X_1=alog10(X)
      if ((X_1.lt..99999e+0).or.(X_1.gt.9.0001e+0)) then
      print*,'ERROR IN FUNCTION GETCDP3S: MUON ENERGY IS OUT OF RANGE'
      endif
      if (loga.eq.0) then
      Y_1=alog10(Y)
      else
      Y_1=Y
      endif
      if ((Y_1.lt.-1.0001e-1).or.(Y_1.gt.1.e-6)) then
      print*,'ERROR IN FUNCTION GETCDP3S: EN. TRANSFER IS OUT OF RANGE'
      endif
      A3=(X_1-X0)/SX
      B3=(Y_1-Y0)/SY
      M1=INT(A3+.5)
      M2=INT(B3+.5)
      M3=NX+2
      IF(M1.LT.0.OR.M1.GE.NX.OR.M2.LT.0.OR.M2.GE.NY) THEN
      PRINT 1,X_1,M1,Y_1,M2
      ENDIF
      A3=A3-M1
      B3=B3-M2
      M1=M2*M3+M1+1
      M2=M1+M3
      M3=M2+M3
      A2=A3*A3+.25
      B2=B3*B3+.25
      A1=A2-A3
      B1=B2-B3
      A3=A2+A3
      B3=B2+B3
      A2=2.-(A2+A2)
      B2=2.-(B2+B2)
      getcdp34=(A1*C2(M1)+A2*C2(M1+1)+A3*C2(M1+2))*B1
     2      +(A1*C2(M2)+A2*C2(M2+1)+A3*C2(M2+2))*B2
     3      +(A1*C2(M3)+A2*C2(M3+1)+A3*C2(M3+2))*B3
      RETURN
1     FORMAT('*MISTAKE*X=',D23.16,'MX=',I4,'Y=',D23.16,'MY=',I4)
      END
****************************************************************************
* P.16_4
      FUNCTION comp4(X)
*
      real*4 X
      external pair_tot4
      common /sok554/ XMIN,STEP,XMAX
      common /sok55_p4/ C(2203)
      common /fac_pa4/ fac
      parameter (en = 1.e+9)
      X1 = X
      if (X1.lt.-1.5472686e-2) then
       if ((X1.lt.-11.001e+0).or.(X1.gt.1.e-5)) then
       print*,'ERROR IN FUNCTION COMPS: ENERGY transfer IS OUT OF RANGE'
       endif
      Y = (X1-XMIN)/STEP
      I = INT(Y+0.5)
      IF(I.LT.0.OR.X1.GT.XMAX) PRINT 1,X1,XMIN,XMAX
      Y = Y-I
      Z = Y*Y + 0.25
      comp4 = exp((Z-Y)*C(I+1) + (2.-(Z+Z))*C(I+2) + (Z+Y)*C(I+3))
      else
      rnu = 1.e+1**X1
      comp4 = fac * pair_tot4(en,rnu)
      endif
      RETURN
1     FORMAT('*MISTAKE* X1=',D23.16,'  XMIN=',D23.16,'  XMAX=',D23.16)
      END
****************************************************************************
* P.17_4
      real*8 FUNCTION c_pa_in4(X)
*
      real*8 XMIN,STEP,XMAX
      real*8 C(1103)
      real*8 X,X1,Y,Z
      COMMON /sok254/ XMIN,STEP,XMAX
      common /sok264/ C
       X1 = dlog10(X)
       if ((X1.lt.-11.0001d+0).or.(X1.gt.1.d-6)) then
       print*,'ERROR IN FUNCTION C_PA_INS: TRANSFER IS OUT OF RANGE'
       endif
      Y = (X1-XMIN)/STEP
      I = INT(Y+0.5)
      IF(I.LT.0.OR.X1.GT.XMAX) PRINT 1,X1,XMIN,XMAX
      Y = Y-I
      Z = Y*Y + 0.25
      c_pa_in4 = (Z-Y)*C(I+1) + (2.-(Z+Z))*C(I+2) + (Z+Y)*C(I+3)
      RETURN
1     FORMAT('*MISTAKE*X1=',D23.16,'XMIN=',D23.16,'XMAX=',D23.16)
      END
****************************************************************************
* P.18_4
        SUBROUTINE DSPLQ14
*
      PARAMETER (N=1101)
      real*8 x(N),y(N),Y2(N),U(N),P,SIG,QN,UN
      common /sok244/ X
      common /pa_in_s24/ Y
      common /pa_in_s34/ Y2
      do i=1,N                              ! Preparation of array Y(1101):
        Y(i) = -1.1d+1 + dble(i-1) * 1.d-2  !   log10(rel. en. transfer)
      enddo   !-----------------------------!       from -11.0 to 0.
      Y(N) = 0.d+0                          !------ with step 0.01
      Y2(1)=0.d+0
      U(1)=0.d+0
      DO 11 I=2,N-1 !------------------------------------------!
        SIG=(X(I)-X(I-1))/(X(I+1)-X(I-1))                      !  Cooking of
        P=SIG*Y2(I-1)+2.d+0                                    !    splain
        Y2(I)=(SIG-1.d+0)/P                                    ! coefficients
        U(I)=(6.d+0*((Y(I+1)-Y(I))/(X(I+1)-X(I))-(Y(I)-Y(I-1)) ! and putting
     *      /(X(I)-X(I-1)))/(X(I+1)-X(I-1))-SIG*U(I-1))/P      !  them into
11    CONTINUE                                                 !   output
c                                                              !  Y2(1101)
      QN=0.d+0                                                 !  array to
      UN=0.d+0                                                 !  be passed
c                                                              ! to routine
      Y2(N)=(UN-QN*U(N-1))/(QN*Y2(N-1)+1.d+0)                  !  DSPLIN14
      DO 12 K=N-1,1,-1                                         !
        Y2(K)=Y2(K)*Y2(K+1)+U(K)                               !
12    CONTINUE  !----------------------------------------------!
      RETURN
      END
***********************************************************************
* P.19_4
      real*8 FUNCTION DSPLIN14(X1)
*
      PARAMETER (N=1101)
      real*8 X1,Y1
      real*8 XA(N),YA(N),Y2A(N),X,Y,H,A,B
      common /sok244/ XA
      common /pa_in_s24/ YA
      common /pa_in_s34/ Y2A
      X=X1
      KLO=1
      KHI=N
1     IF (KHI-KLO.GT.1) THEN
        K=(KHI+KLO)/2
        IF(XA(K).GT.X)THEN
          KHI=K
        ELSE
          KLO=K
        ENDIF
      GOTO 1
      ENDIF
      H=XA(KHI)-XA(KLO)
c
c     This 'IF' line was commented in July, 2019:
c
ccc      IF (H.EQ.0.d+0) PAUSE 'Bad XA input at function DSPLIN14...'
c
c     This 3 lines with 'IF' are instead of old line (see just above):
c
      IF (H.EQ.0.d+0) THEN
      PRINT*,'Bad XA input at function DSPLIN14...'
      ENDIF
c
      A=(XA(KHI)-X)/H
      B=(X-XA(KLO))/H
      Y=A*YA(KLO)+B*YA(KHI)+
     *      ((A*A*A-A)*Y2A(KLO)+(B*B*B-B)*Y2A(KHI))*(H*H)/6.d+0
      Y1 = Y
      DSPLIN14 = Y1
                      if ((Y1.ge.1.d-10).OR.(Y1.lt.-1.1001d+1)) then
      print*,'DSPLIN14 ERR: IN =',X1,'(MAX=',XA(N),'), OUT=',Y1
                       endif
      RETURN
      END
****************************************************************************
* P.20_4
      SUBROUTINE getvpa4(emw,vbr,itr)
*
       external c_pa_in4,dsplin14,getcdp4,comp4
       parameter (lo=1)
       parameter (len=1)
       real*8 c_pa_in4,tot_pa,ai1,dsplin14,ax,algemin,arn
       real*4 emw,vbr
       integer itr
       common /general4/ emin,vmin,emph
       common/sok334/ tot_pa
       common /mcef4/ mcb1,mcb2,mcp1,mcp2,mcn1,mcn2,mce1,mce2
        mcp1 = mcp1 + 1
          if (itr.eq.0) then
          algemin = dble(emin/emw)
          else
          algemin = dble(amax1(vmin,2.044e-3/emw))
          endif
        ai1 = c_pa_in4(algemin)
        algemin = tot_pa - ai1
  155   arn = rndm_mum(5)
        mcp2 = mcp2 + 1
        ax = (algemin * arn) + ai1
          if (ax.gt.tot_pa) ax = tot_pa
        ax = dsplin14(ax)
          if (ax.ge.-1.d-5) ax = -1.d-5
        ay = sngl(ax)
c
        if (vmin.le.8.e-4) then
        az = (1.e+1)**ay
        echeck = az * emw
        if (echeck.ge.6.5e-3) then
        y1 = getcdp4(emw,ay,lo)
        else
        y1 = pair_tot4(emw,az)
        endif
        else
        y1 = getcdp4(emw,ay,lo)
        endif
c
        vbr = sngl(ax)
        y2 = comp4(vbr)
        arn = rndm_mum(8)
        yc = y2 * sngl(arn)
        if (y1.ge.yc) then
        vbr = (1.e+1)**ay
        else
        goto 155
        endif
      return
      end
****************************************************************************
************************* PHOTONUCLEAR SUBROUTINES : ***********************
****************************************************************************
* N.1_4
*
      real*8 function phnu4(z,en,rnu,a)
      real*8 z,en,rnu,a,rnu1
      real*8 alfa,rm_e,rm_mu,r_e,fact,avog,m1,m2,mn,s,sigma,t,hv,zet
      real*8 te1,te2,te3,g,etr
      integer iqcd,ilep
      common /qcd4/ iqcd
      common /what_lep4/ ilep
      common /pnsig4/ ibb
      common /exer14/ fa
      common /const4/ alfa,rm_e,rm_mu,r_e,avog
      parameter (m1 = 5.4d-1)
c                         !_______ GeV squared
      parameter (m2 = 1.8d+0)
c                         !______ GeV squared
      parameter (mn = .939d+0)
c                         !______nucleon mass (Gev) = (Mp + Mn) / 2
      parameter (fact = 2.903524525d-4)
c                         !__fact = alfa / (8 * pi)
      rnu1 = 1.d+0 - rnu
      etr = rnu * en
      s = etr * 2.d+0 * mn
       if (ibb.eq.1) then
        sigma = 1.143d+2 + 1.647d+0 * ((dlog(2.13d-2 * etr))**2.d+0)
c       it is Sigma_gamma_p parametrization from Bezrukov-Bugaev
       else
        sigma = (6.35d+1 * (s**9.7d-2)) + (1.45d+2 / (s**5.d-1))
c       it is Sigma_gamm_p parametrization from ZEUS (J.Breitweg
c       et al., hep-ex/9809005, Eur.Phys.J., C7 (1999) 609)
       endif
      sigma = sigma * 1.d-30
      t = (rm_mu * rm_mu * 1.d-6 * rnu * rnu) / rnu1
      hv = 1.d+0 - (2.d+0 / rnu) + (2.d+0 / (rnu * rnu))
      zet = 2.82d-3 * sigma * 1.d+30 * (a**(1.d+0 / 3.d+0))
c upgrade BB formula: =========>
c      te1 = hv * dlog(1.d+0 + (m2/t))
      te1 = (hv + ((2.d-6*rm_mu*rm_mu)/(m2))) * dlog(1.d+0 + (m2/t))
c =============================>
      if(t.gt.1.d-7) then
      te2 = 1.d+0 - ((.25d+0 * m2/t) * dlog(1.d+0 + (t/m2)))
      te2 = te2 * 2.d+0 * rm_mu * rm_mu * 1.d-6 / t
      else
      te2 = (1.5d+0 / t) * rm_mu * rm_mu * 1.d-6
      endif
      te3 = (dlog(1.d+0 + (m1/t)) - (m1/(m1 + t))) * hv
c upgrade BB formula: =========>
c      te3=te3-((2.d+0*rm_mu*rm_mu*1.d-6/t)*(1.d+0-((.25d+0*m1)/(m1+t))))
      te3=te3-((2.d+0*rm_mu*rm_mu*1.d-6/t)*
     &                            (1.d+0-((.25d+0*m1-t)/(m1+t))))
      te3=te3+(((4.d-6*rm_mu*rm_mu)/(m1))*dlog(1.d+0+((m1)/t)))
c =============================>
      g = ( (1.d+0 + zet) * dexp(-zet) ) - 1.d+0
      g = ( ( g / (zet * zet) ) + 5.d-1 ) * ( 9.d+0 / zet )
      if(z.lt.1.5d+0) g = 3.d+0  !-----------> Special case for hydrogen
      phnu4 = te1 - te2 + (g * te3)
      phnu4 = phnu4 * fact * rnu * sigma * a * dble(fa)
c=================> QCD-corrections:
      IF(iqcd.EQ.1) THEN
        dops = QCD_C4(SNGL(rnu),SNGL(en)) * fa * SNGL(a)
        IF(dops.GE.0.) phnu4 = phnu4 + ((1.D-30 * DBLE(dops)) / rnu)
      ENDIF
c=================>
      IF (phnu4.LT.0.D+0) phnu4 = 0.D+0
      return
      end
****************************************************************************
* N.1a4
*
      SUBROUTINE QCD_CORR4
*
* Computes QCD corrections for photonuclear interaction as was developed
* by E.Bugaev & Yu.Shlepin, put them in arrays COR_MU and COR_TAU, then
*    computes splain coefficients (array C(730) in common /qcd_new/ )
*
      DOUBLE PRECISION A_MU(8,7),A_TAU(8,7),COR_MU(71,8),COR_TAU(71,8)
      DOUBLE PRECISION V, V1, CORR_MU, CORR_TAU, SL_MU, SL_TAU
      DIMENSION F(71,8),D(90,27),C(730)
      COMMON /what_lep4/ ilep
      COMMON /qcd_new4/ C
      DATA NX /71/
      DATA NY /8/
c
c Coefficients for MU (from Bugaev-Shlepin, October 2002 & March 2003):
c                 computed for standard rock (A=22)
c
c     muon, 10^3 GeV
c
      A_MU(1, 1) = 0.0157837D+0
      A_MU(2, 1) = -5.3593D+0
      A_MU(3, 1) = -6.47286D+0
      A_MU(4, 1) = -3.64846D+0
      A_MU(5, 1) = -1.1501D+0
      A_MU(6, 1) = -0.205223D+0
      A_MU(7, 1) = -0.0192542D+0
      A_MU(8, 1) = -0.000735492D+0
c
c     muon, 10^4 GeV
c
      A_MU(1, 2) = 0.0376904D+0
      A_MU(2, 2) = -12.6647D+0
      A_MU(3, 2) = -15.0953D+0
      A_MU(4, 2) = -8.41549D+0
      A_MU(5, 2) = -2.63226D+0
      A_MU(6, 2) = -0.467407D+0
      A_MU(7, 2) = -0.0437325D+0
      A_MU(8, 2) = -0.00166849D+0
c
c     muon, 10^5 GeV
c
      A_MU(1, 3) = 0.0898107D+0
      A_MU(2, 3) = -34.1874D+0
      A_MU(3, 3) = -44.0928D+0
      A_MU(4, 3) = -26.5711D+0
      A_MU(5, 3) = -8.87342D+0
      A_MU(6, 3) = -1.66224D+0
      A_MU(7, 3) = -0.162793D+0
      A_MU(8, 3) = -0.00647547D+0
c
c     muon, 10^6 GeV
c
      A_MU(1, 4) = 0.189826D+0
      A_MU(2, 4) = -71.5287D+0
      A_MU(3, 4) = -87.9917D+0
      A_MU(4, 4) = -51.2985D+0
      A_MU(5, 4) = -16.7509D+0
      A_MU(6, 4) = -3.08549D+0
      A_MU(7, 4) = -0.297893D+0
      A_MU(8, 4) = -0.0116941D+0
c
c     muon, 10^7 GeV
c
      A_MU(1, 5) = 0.273715D+0
      A_MU(2, 5) = -131.49D+0
      A_MU(3, 5) = -150.811D+0
      A_MU(4, 5) = -85.5305D+0
      A_MU(5, 5) = -27.9549D+0
      A_MU(6, 5) = -5.21569D+0
      A_MU(7, 5) = -0.511526D+0
      A_MU(8, 5) = -0.0203833D+0
c
c     muon, 10^8 GeV
c
      A_MU(1, 6) = 0.48501D+0
      A_MU(2, 6) = -208.904D+0
      A_MU(3, 6) = -221.255D+0
      A_MU(4, 6) = -124.006D+0
      A_MU(5, 6) = -41.4446D+0
      A_MU(6, 6) = -7.95112D+0
      A_MU(7, 6) = -0.798525D+0
      A_MU(8, 6) = -0.0324086D+0
c
c     muon, 10^9 GeV
c
      A_MU(1, 7) = 0.710326D+0
      A_MU(2, 7) = -306.442D+0
      A_MU(3, 7) = -316.191D+0
      A_MU(4, 7) = -185.205D+0
      A_MU(5, 7) = -64.8621D+0
      A_MU(6, 7) = -12.8027D+0
      A_MU(7, 7) = -1.30405D+0
      A_MU(8, 7) = -0.0532388D+0
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c      DATA (A_MU(J, 1),J=1,8) /  !        muon, 10^3 GeV
c     & 0.0157837D+0, -5.3593D+0, -6.47286D+0, -3.64846D+0,  -1.1501D+0,
c     & -0.205223D+0, -0.0192542D+0, -0.000735492D+0 /
c
c      DATA (A_MU(J, 2),J=1,8) /  !        muon, 10^4 GeV
c     & 0.0376904D+0, -12.6647D+0, -15.0953D+0, -8.41549D+0, -2.63226D+0,
c     & -0.467407D+0, -0.0437325D+0, -0.00166849D+0 /
c
c      DATA (A_MU(J, 3),J=1,8) /  !        muon, 10^5 GeV
c     & 0.0898107D+0, -34.1874D+0, -44.0928D+0, -26.5711D+0, -8.87342D+0,
c     & -1.66224D+0, -0.162793D+0, -0.00647547D+0 /
c
c      DATA (A_MU(J, 4),J=1,8) /  !        muon, 10^6 GeV
c     & 0.189826D+0, -71.5287D+0, -87.9917D+0, -51.2985D+0, -16.7509D+0,
c     & -3.08549D+0, -0.297893D+0, -0.0116941D+0 /
c
c      DATA (A_MU(J, 5),J=1,8) /  !        muon, 10^7 GeV
c     & 0.273715D+0, -131.49D+0, -150.811D+0, -85.5305D+0, -27.9549D+0,
c     & -5.21569D+0, -0.511526D+0, -0.0203833D+0 /
c
c      DATA (A_MU(J, 6),J=1,8) /  !        muon, 10^8 GeV
c     & 0.48501D+0, -208.904D+0, -221.255D+0, -124.006D+0, -41.4446D+0,
c     & -7.95112D+0, -0.798525D+0, -0.0324086D+0 /
c
c      DATA (A_MU(J, 7),J=1,8) /  !        muon, 10^9 GeV
c     & 0.710326D+0, -306.442D+0, -316.191D+0, -185.205D+0, -64.8621D+0,
c     & -12.8027D+0, -1.30405D+0, -0.0532388D+0 /
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c Coefficients for TAU (from Bugaev-Shlepin, October 2002 & March 2003):
c                 computed for standard rock (A=22)
c
c
c     tau, 10^3 GeV
c
      A_TAU(1, 1) = -0.00279225D+0
      A_TAU(2, 1) = -0.343867D+0
      A_TAU(3, 1) = 1.03267D+0
      A_TAU(4, 1) = 1.17448D+0
      A_TAU(5, 1) = 0.492829D+0
      A_TAU(6, 1) = 0.102496D+0
      A_TAU(7, 1) = 0.0106092D+0
      A_TAU(8, 1) = 0.000436414D+0
c
c     tau, 10^4 GeV
c
      A_TAU(1, 2) = -0.00625653D+0
      A_TAU(2, 2) = -0.789706D+0
      A_TAU(3, 2) = 2.55848D+0
      A_TAU(4, 2) = 2.88145D+0
      A_TAU(5, 2) = 1.20912D+0
      A_TAU(6, 2) = 0.252265D+0
      A_TAU(7, 2) = 0.0262464D+0
      A_TAU(8, 2) = 0.00108684D+0
c
c     tau, 10^5 GeV
c
      A_TAU(1, 3) = -0.0126754
      A_TAU(2, 3) = -1.70908
      A_TAU(3, 3) = 6.74136
      A_TAU(4, 3) = 7.50275
      A_TAU(5, 3) = 3.18879
      A_TAU(6, 3) = 0.679863
      A_TAU(7, 3) = 0.072661
      A_TAU(8, 3) = 0.00310106
c
c     tau, 10^6 GeV
c
      A_TAU(1, 4) = -0.0262998D+0
      A_TAU(2, 4) = -3.46225D+0
      A_TAU(3, 4) = 15.4908D+0
      A_TAU(4, 4) = 16.5646D+0
      A_TAU(5, 4) = 6.86187D+0
      A_TAU(6, 4) = 1.43318D+0
      A_TAU(7, 4) = 0.150554D+0
      A_TAU(8, 4) = 0.0063314D+0
c
c     tau, 10^7 GeV
c
      A_TAU(1, 5) = -0.0289825D+0
      A_TAU(2, 5) = -5.98402D+0
      A_TAU(3, 5) = 31.6914D+0
      A_TAU(4, 5) = 31.3704D+0
      A_TAU(5, 5) = 12.2688D+0
      A_TAU(6, 5) = 2.44171D+0
      A_TAU(7, 5) = 0.246202D+0
      A_TAU(8, 5) = 0.00999873D+0
c
c     tau, 10^8 GeV
c
      A_TAU(1, 6) = -2.13163D-13
      A_TAU(2, 6) = -9.2095D+0
      A_TAU(3, 6) = 55.7338D+0
      A_TAU(4, 6) = 50.2693D+0
      A_TAU(5, 6) = 18.3936D+0
      A_TAU(6, 6) = 3.49729D+0
      A_TAU(7, 6) = 0.343508D+0
      A_TAU(8, 6) = 0.0138178D+0
c
c     tau, 10^9 GeV
c
      A_TAU(1, 7) = -1.42109D-13
      A_TAU(2, 7) = -17.6991D+0
      A_TAU(3, 7) = 70.7923D+0
      A_TAU(4, 7) = 56.0714D+0
      A_TAU(5, 7) = 17.7885D+0
      A_TAU(6, 7) = 2.95729D+0
      A_TAU(7, 7) = 0.258242D+0
      A_TAU(8, 7) = 0.00942025D+0
ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c      DATA (A_TAU(J, 1),J=1,8) / !        tau, 10^3 GeV
c     & -0.00279225D+0, -0.343867D+0, 1.03267D+0, 1.17448D+0,
c     &  0.492829D+0, 0.102496D+0, 0.0106092D+0, 0.000436414D+0 /
c
c      DATA (A_TAU(J, 2),J=1,8) / !        tau, 10^4 GeV
c     & -0.00625653D+0, -0.789706D+0, 2.55848D+0, 2.88145D+0,
c     &  1.20912D+0, 0.252265D+0, 0.0262464D+0, 0.00108684D+0 /
c
c      DATA (A_TAU(J, 3),J=1,8) / !        tau, 10^5 GeV
c     & -0.0126754, -1.70908, 6.74136, 7.50275, 3.18879,
c     & 0.679863, 0.072661, 0.00310106 /
c
c      DATA (A_TAU(J, 4),J=1,8) / !        tau, 10^6 GeV
c     & -0.0262998D+0, -3.46225D+0, 15.4908D+0, 16.5646D+0, 6.86187D+0,
c     & 1.43318D+0, 0.150554D+0, 0.0063314D+0 /
c
c      DATA (A_TAU(J, 5),J=1,8) / !        tau, 10^7 GeV
c     & -0.0289825D+0, -5.98402D+0, 31.6914D+0, 31.3704D+0, 12.2688D+0,
c     &  2.44171D+0, 0.246202D+0, 0.00999873D+0 /
c
c      DATA (A_TAU(J, 6),J=1,8) / !        tau, 10^8 GeV
c     & -2.13163D-13, -9.2095D+0, 55.7338D+0, 50.2693D+0, 18.3936D+0,
c     &  3.49729D+0, 0.343508D+0, 0.0138178D+0 /
c
c      DATA (A_TAU(J, 7),J=1,8) / !        tau, 10^9 GeV
c     & -1.42109D-13, -17.6991D+0, 70.7923D+0, 56.0714D+0, 17.7885D+0,
c     &  2.95729D+0, 0.258242D+0, 0.00942025D+0 /
ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c       Bugaev's data are down to 10^3 GeV. We artifically assign
c   "correction=0" for 10^2 GeV to enlarge interpolation energy range:
c
      DO I=1,71
        COR_MU(I,1)  = 0.D+0
        COR_TAU(I,1) = 0.D+0
      ENDDO
c
c   Bugaev's corrections work for v > 10^(-6). We artifically assign
c   "correction = 0" for V = 10^-7 to enlarge interpolation V range.
c       To make sure we also set to zero corrections for V = 1 :
c
      DO I=1,8
        COR_MU(1,I)   = 0.D+0
        COR_TAU(1,I)  = 0.D+0
        COR_MU(71,I)  = 0.D+0
        COR_TAU(71,I) = 0.D+0
      ENDDO
c
c  We compute corrections for 7 energies (10^3 GeV - 10^9 GeV) and
c        10^(-6) =< V < 1 using Bugaev-Shlepin formula
c
c                                 7
c           v (d_sigma / d_v) = S U M (a_k * (alog10(v))**k)
c                                k=0
c
c with coefficients for mu and tau as given in DATA for A_MU and A_TAU:
c
      DO I=2,8
        M = I - 1
          DO J=11,70
            V = 1.D-1 * DBLE(J - 71)
            V1 = 1.D+1**V
            CORR_MU  = 0.D+0
            CORR_TAU = 0.D+0
              DO J1=1,8
              CORR_MU=CORR_MU+(A_MU(J1,M)*(DLOG10(V1))**(DBLE(J1-1)))
              CORR_TAU=CORR_TAU+(A_TAU(J1,M)*(DLOG10(V1))**(DBLE(J1-1)))
              ENDDO
            COR_MU(J,I)  = CORR_MU
            COR_TAU(J,I) = CORR_TAU
          ENDDO
      ENDDO
c
c For v range 10^(-7) -- 10^(-6) we are making a linear interpolation
c    (below V = 10^(-7) all the corrections will be equal to zero):
c
      DO I=2,8
        SL_MU  = COR_MU(11,I) / 1.D+1
        SL_TAU = COR_TAU(11,I) / 1.D+1
          DO K=2,10
            COR_MU(K,I)  = SL_MU * DBLE(K-1)
            COR_TAU(K,I) = SL_TAU * DBLE(K-1)
          ENDDO
      ENDDO
c
c NOW ALL THE CORRECTIONS EXPRESSED IN [ub] for v (d_sigma / d_v)
c     FOR A=22  ARE IN ARRAYS COR_MU(71,8) AND COR_TAU(71,8)
c
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c FILLING ARRAY F(71,8) EITHER BY MU OR TAU CORRECTIONS TO COOK SPLAINS
c      TRANSFORMING TO LOG10 TO GET BETTER INTERPOLATION QUALITY
c         AND DIVIDING BY 22 TO GET CORRECTIONS FOR 1 NUCLEON:
c
      DO I=1,71
        DO J=1,8
          IF(ilep.EQ.1) THEN
            F(I,J) = SNGL(COR_MU(I,J)) / 22.
          ELSE
            F(I,J) = SNGL(COR_TAU(I,J)) / 22.
          ENDIF
        ENDDO
      ENDDO
c
c                        COOKING SPLAINS:
c
      DO 1 J=1,NY
      J2=J+2
      DO 1 I=1,NX
      I2=I+2
1     D(I2,J2)=3.90625E-3*F(I,J)
      J1=NY+1
      J3=J2+1
      J4=J3+1
      DO 2 I=3,I2
      A=D(I,3)
      B=D(I,4)
      D(I,2)=3.*(A-B)+D(I,5)
      D(I,1)=3.*(D(I,2)-A)+B
      A=D(I,J1)
      B=D(I,J2)
      D(I,J3)=3.*(B-A)+D(I,NY)
2     D(I,J4)=3.*(D(I,J3)-B)+A
      I1=NX+1
      I3=I2+1
      I4=I3+1
      DO 3 J=1,J4
      A=D(3,J)
      B=D(4,J)
      D(2,J)=3.*(A-B)+D(5,J)
      D(1,J)=3.*(D(2,J)-A)+B
      A=D(I1,J)
      B=D(I2,J)
      D(I3,J)=3.*(B-A)+D(NX,J)
3     D(I4,J)=3.*(D(I3,J)-B)+A
      DO 4 J=1,J2
      J3=J+1
      J4=J+2
      M=(J-1)*I2
      DO 4 I=1,I2
      I3=I+1
      I4=I+2
4     C(M+I)=D(I,J)+D(I,J4)+D(I4,J)+D(I4,J4)+D(I3,J3)*
     *100.-(D(I3,J)+D(I,J3)+D(I4,J3)+D(I3,J4))*10.
c
      RETURN
      END
************************************************************************
* N.1b4
*
      FUNCTION QCD_C4(X1,Y1)
*
* Returns QCD correction for PN according to Bugaev & Shlepin by
*    interpolation using splains prepared by QCD_CORR routine.
*
* INPUT: X1 -> relative energy transfer 10^(-10) < V < 1.
*        Y1 -> lepton energy [GeV]       1. < E < 1.E+9
*
*
* OUTPUT QCD_C  -> QCD-correction for PN crosssection [ub] for
*                  v * (d_sigma / d_v) per 1 nucleon
*
      REAL*4 X1,Y1
      DIMENSION C(730)
      COMMON /qcd_new4/ C
      DATA NX /71/
      DATA NY /8/
      DATA X0 /-7./
      DATA SX /.1/
      DATA Y0 /2./
      DATA SY /1./
c
      IF(Y1.LT.1.E+2) THEN
        QCD_C4 = 0.E+0
        RETURN
      ENDIF
      IF(X1.LT.1.E-7) THEN
        QCD_C4 = 0.E+0
        RETURN
      ENDIF
c
      X = ALOG10(X1)
      Y = ALOG10(Y1)
c
      A3=(X-X0)/SX
      B3=(Y-Y0)/SY
      M1=INT(A3+.5)
      M2=INT(B3+.5)
      M3=NX+2
      IF(M1.LT.0.OR.M1.GE.NX.OR.M2.LT.0.OR.M2.GE.NY) PRINT 1,X,M1,Y,M2
      A3=A3-M1
      B3=B3-M2
      M1=M2*M3+M1+1
      M2=M1+M3
      M3=M2+M3
      A2=A3**2+.25
      B2=B3**2+.25
      A1=A2-A3
      B1=B2-B3
      A3=A2+A3
      B3=B2+B3
      A2=2.-(A2+A2)
      B2=2.-(B2+B2)
      QCD_C4=(A1*C(M1)+A2*C(M1+1)+A3*C(M1+2))*B1
     2      +(A1*C(M2)+A2*C(M2+1)+A3*C(M2+2))*B2
     3      +(A1*C(M3)+A2*C(M3+1)+A3*C(M3+2))*B3
c
      RETURN
1     FORMAT('*MISTAKE IN QCD* X=',D23.16,'MX=',I4,'Y=',D23.16,'MY=',I4)
      END
****************************************************************************
* N.2_4
*
       function phnu_tot4(ene,v)
       external phnu4
       real*8 z1(10),w(10),aw(10),a_ef,en,rnu,h1,phnu4,ro
       real*4 ene,v
       integer nsub
       common /media4/ z1,w,aw,a_ef,ro,nsub
       if (v.gt..999998) v = .999998
       en = dble(ene)
       rnu = dble(v)
           h1 = w(1) * phnu4(z1(1),en,rnu,aw(1))
         if (nsub.ge.2) then
           do l=2,nsub
             h1 = h1 + (w(l) * phnu4(z1(l),en,rnu,aw(l)))
           enddo
         endif
       phnu_tot4 = sngl(h1)
       return
       end
****************************************************************************
* N.3_4
*
       subroutine phnu14
*
       external phnu_tot4,dsimps
       real*8 dsimps
       real*8 aux1(0:2000),aux2(0:2000),h1,h2
       real*8 alfa,rm_e,rm_mu,r_e,avog,z1(10),w(10),aw(10),a_ef,ro
       common /const4/ alfa,rm_e,rm_mu,r_e,avog ! from initial subroutine
       common /media4/ z1,w,aw,a_ef,ro,nsub     !       MED_CONSS
       common /general4/ emin,vmin,emph         !
       common /cdph_in4/ fcd1(81,54),fcd2(81,101),fcd3(81,51)
       common /ctph_in14/ crt_ph1(17),crt_ph2(65)
       common /elph_in14/ elo_ph1(17),elo_ph2(65)
       common /elph_in24/ elo_ph3(17)
       common /elph_in44/ elo_ph4(17)
       common /ph_ref4/ at,bt,us2,us2_1,us3,us4,at0
       common /pnsig4/ ibb
       common /help_14/ aux1,aux2
c   ....................................................................
c      1.PREPARATION OF ARRAYS WITH DIFF. CROSS-SEECTIONS FOR MUON
c                         PHOTONUCLEAR INTERACTION:
c
c                !       ..........................
      do j=1,81  !--->   j CYCLE BY ENERGIES starts
c                !       ..........................
        en = float(j)
        en = 1.e+1**(9.e-1 + (1.e-1 * en))
c                     !         ..................................
      do k=1,206      !--->     k CYCLE BY ENERGY TRANSFERS starts
c                     !         ..................................
      if (k.eq.206) then
        rnu = 1.e+0
        fcd2(j,101) = phnu_tot4(en,rnu)
        if (fcd2(j,101).le.1.e-37) fcd2(j,101) = 1.e-37
        fcd2(j,101) = alog(fcd2(j,101))
        goto 975
      endif
c
      if (k.le.54) then
         k01 = k - 1
         rnu = 1.e+1**(float(k01) * 2.e-1 - 1.1e+1)
      else
         if (k.le.105) then
           k01 = k - 55
           rnu = 1.e+1**(float(k01) * 1.e-2 - 6.e-1)
         else
           k01 = k - 106
           rnu = 1.e+1**(float(k01) * 1.e-3 - 1.e-1)
         endif
      endif
c
      cr_dif=phnu_tot4(en,rnu)
      if (cr_dif.le.1.e-37) cr_dif = 1.e-37
      cr_dif=alog(cr_dif)
c
      if (k.le.54) fcd1(j,k) = cr_dif
      if ((k.gt.54).AND.(k.lt.106)) fcd3(j,k-54) = cr_dif
      if (k.ge.106) fcd2(j,k-105) = cr_dif
c
 975  continue
c              !     .....................................
      enddo    !----> k CYCLE BY ENERGY TRANSFERS finishes
c              !     .....................................
      enddo    !----> j CYCLE BY ENERGIES finishes
c              !     ....................................
c   ....................................................................
c      2.PREPARATION OF ARRAYS WITH ENERGY LOSSES AND MEAN FREE PATH
c                     FOR MUON PHOTONUCLEAR INTERACTION:
c
c                       a) Energy transfers > EMIN :
      lim = 2000
      do i=1,17
      en = float(i)
      en = (1.e+1)**(5.e-1 + (5.e-1 * en))
      vmi1 = alog(emin / en)
      vmi2 = alog(emph / en)
      vmi = amax1(vmi1,vmi2) !-----------> The lower limit for integration
      vma = 0.e+0            !-----------> The upper limit for integration
      vst = (vma - vmi) / float(lim) !---> Step for a rel. en. transfers grid
c
      do j=0,lim
      rnu = vmi + vst*(float(j))
      rnu = exp(rnu)
      aux1(j) = dble(phnu_tot4(en,rnu) * rnu)       !-> array to be integrated
c                                                  !   to get mean free path
      aux2(j) = aux1(j) * dble(rnu)                !-> array to be integrated
      enddo                                        !   for getting en. losses
c
      h1 = dble(vmi)
      h2 = dble(vma)
      crt_ph1(i) = sngl(dsimps(aux1,h1,h2,lim))        !-> array with 17 values
      crt_ph1(i) = sngl(a_ef / (avog * ro))/crt_ph1(i) ! of mean free path
      crt_ph1(i) = alog(crt_ph1(i))                    !
      elo_ph1(i) = sngl( dsimps(aux2,h1,h2,lim) * avog * ro / a_ef )
      elo_ph1(i) = elo_ph1(i) * en * 1.e+3
      elo_ph1(i) = alog10(elo_ph1(i)) !-> array with 17 values of en. losses
      enddo
c                       b) Energy transfers > VMIN :
      do i=1,65
      en = float(i)
      en = (1.e+1)**(8.75e-1 + (1.25e-1 * en))
      vmi1 = alog(vmin)
      vmi2 = alog(emph / en)
      vmi = amax1(vmi1,vmi2) !-----------> The lower limit for integration
      vma = 0.e+0            !-----------> The upper limit for integration
      vst = (vma - vmi) / float(lim) !---> Step for a rel. en. transfers grid
c
      do j=0,lim
      rnu = vmi + vst*(float(j))
      rnu = exp(rnu)
      aux1(j) = dble(phnu_tot4(en,rnu) * rnu)      !-> array to be integrated
c                                                  !   to get mean free path
      aux2(j) = aux1(j) * dble(rnu)                !-> array to be integrated
      enddo                                        !   for getting en. losses
c
      h1 = dble(vmi)
      h2 = dble(vma)
      crt_ph2(i) = sngl(dsimps(aux1,h1,h2,lim))       !->array with 17 values
      crt_ph2(i) = sngl(a_ef / (avog * ro))/crt_ph2(i)! of mean free path
      elo_ph2(i) = sngl( dsimps(aux2,h1,h2,lim) * avog * ro / a_ef )
      elo_ph2(i) = elo_ph2(i) * en * 1.e+3
      if(elo_ph2(i).le.0.e+0) elo_ph2(i) = 1.e-8
      elo_ph2(i) = alog10(elo_ph2(i)) !-> array with 17 values of en. losses
      enddo
c                       c) Energy transfers > 0 :
      do i=1,17
      en = float(i)
      en = (1.e+1)**(5.e-1 + (5.e-1 * en))
      vmi = alog(emph / en)  !-----------> The lower limit for integration
      vma = 0.e+0            !-----------> The upper limit for integration
      vst = (vma - vmi) / float(lim) !---> Step for a rel. en. transfers grid
c
      do j=0,lim
      rnu = vmi + vst*(float(j))
      rnu = exp(rnu)
      aux2(j) = dble(phnu_tot4(en,rnu) * rnu * rnu) !-> array to be integrated
c                                                  !   to get en. losses
      enddo
c
      h1 = dble(vmi)
      h2 = dble(vma)
      elo_ph3(i) = sngl( dsimps(aux2,h1,h2,lim) * avog * ro / a_ef )
      elo_ph3(i) = elo_ph3(i) * en * 1.e+3
      if(elo_ph3(i).le.0.e+0) elo_ph3(i) = 1.e-8
      elo_ph3(i) = alog10(elo_ph3(i)) !-> array with 17 values of en. losses
      enddo
c                       d) Energy transfers < EMIN :
      do i=1,17
      en = float(i)
      en = (1.e+1)**(5.e-1 + (5.e-1 * en))
      vmi = alog(emph / en)  !----------> The lower limit for integration
      vma = alog(emin / en)      !------> The upper limit for integration
      vst = (vma - vmi) / float(lim) !--> Step for a rel. en. transfers grid
      if (vma.le.vmi) then
      elo_ph4(i) = 0.
      goto 1234
      endif
c
      do j=0,lim
      rnu = vmi + vst*(float(j))
      rnu = exp(rnu)
      aux2(j) = dble(phnu_tot4(en,rnu) * rnu * rnu) !-> array to be integrated
c                                                  !   to get en. losses
      enddo
c
      h1 = dble(vmi)
      h2 = dble(vma)
      elo_ph4(i) = sngl( dsimps(aux2,h1,h2,lim) * avog * ro / a_ef )
      elo_ph4(i) = elo_ph4(i) * en * 1.e+3 !-> array with 17 values
 1234 continue                             !   of en. losses
      enddo
c   ....................................................................
c          3. COMPUTING OF CONSTANTS FOR COMPARISON FUNCTION:
c
       if(ibb.eq.1) then
         en1 = 1.e+9
         en2 = 10.
         v1 = 1.78e-2
         v2 = 1.e-10
         bt = alog10(phnu_tot4(en2,v2)) - alog10(phnu_tot4(en1,v1))
         bt = bt / (alog10(v1/v2))
       else
         en1 = 1000.
         en2 = 100.
         v1 = 2.e-4
         v2 = 2.e-3
         bt = alog10(phnu_tot4(en1,v1)) - alog10(phnu_tot4(en2,v2))
       endif
      if(rm_mu.le.1.d+3) then
      at = 1.05 * (v2**bt) * phnu_tot4(en2,v2)
      else
      at = 1.25 * (v2**bt) * phnu_tot4(en2,v2)
      endif
      at0 = at
      us2 = at / (1.-bt)
      us2_1 = 1. / us2
      us3 = .434294481 / (1. - bt)
      us4 = 2.302585093 * (-bt)
      return
      end
****************************************************************************
* N.4_4
            FUNCTION getlphnu4(X)
*
      real*4 X
      COMMON /sok14/ XMIN,STEP,XMAX
      common /sok1_n4/ C(19)
      X1 = alog10(X)
      if ((X1.lt..99999e+0).or.(X1.gt.9.0001e+0)) then
      print*,'ERROR IN FUNCTION GETLPHNUS: MUON ENERGY IS OUT OF RANGE'
      endif
      Y = (X1-XMIN)/STEP
      I = INT(Y+0.5)
      IF(I.LT.0.OR.X1.GT.XMAX) PRINT 1,X1,XMIN,XMAX
      Y = Y-I
      Z = Y*Y + 0.25
      getlphnu4 = (Z-Y)*C(I+1) + (2.-(Z+Z))*C(I+2) + (Z+Y)*C(I+3)
      getlphnu4 = exp(getlphnu4)
      RETURN
1     FORMAT('*MISTAKE*X1=',D23.16,'XMIN=',D23.16,'XMAX=',D23.16)
      END
****************************************************************************
* N.5_4
            FUNCTION glphnuv4(X)
*
      real*4 X
      COMMON /sok1n4/ XMIN,STEP,XMAX
      common /sok1_n24/ C(67)
      X1 = alog10(X)
      if ((X1.lt..99999e+0).or.(X1.gt.9.0001e+0)) then
      print*,'ERROR IN FUNCTION GLPHNUVS: MUON ENERGY IS OUT OF RANGE'
      endif
      Y = (X1-XMIN)/STEP
      I = INT(Y+0.5)
      IF(I.LT.0.OR.X1.GT.XMAX) PRINT 1,X1,XMIN,XMAX
      Y = Y-I
      Z = Y*Y + 0.25
      glphnuv4 = (Z-Y)*C(I+1) + (2.-(Z+Z))*C(I+2) + (Z+Y)*C(I+3)
      RETURN
1     FORMAT('*MISTAKE*X1=',D23.16,'XMIN=',D23.16,'XMAX=',D23.16)
      END
****************************************************************************
* N.6_4
         function getctph4(u)
*
      external getlphnu4
      real*8 z1(10),w(10),aw(10),a_ef,alfa,rm_e,rm_mu,r_e,avog,ro
      real*4 u
      common /const4/ alfa,rm_e,rm_mu,r_e,avog
      common /media4/ z1,w,aw,a_ef,ro,nsub
      if ((u.gt.1.0001e+9).or.(u.lt.9.9999e+0)) then
      print*,'ERROR IN FUNCTION GETCTPHS: MUON ENERGY IS OUT OF RANGE'
      endif
      aef = sngl(a_ef / (avog * ro))
      getctph4 = aef / getlphnu4(u)
      return
      end
****************************************************************************
* N.7_4
         function gctphv4(u)
*
      external glphnuv4
      real*8 z1(10),w(10),aw(10),a_ef,alfa,rm_e,rm_mu,r_e,avog,ro
      real*4 u
      common /const4/ alfa,rm_e,rm_mu,r_e,avog
      common /media4/ z1,w,aw,a_ef,ro,nsub
      if ((u.gt.1.0001e+9).or.(u.lt.9.9999e+0)) then
      print*,'ERROR IN FUNCTION GCTPHVS: MUON ENERGY IS OUT OF RANGE'
      endif
      aef = sngl(a_ef / (avog * ro))
      gctphv4 = aef / glphnuv4(u)
      return
      end
************************************************************************
* N.8_4
              FUNCTION getdedph4(X)
*
      real*4 X
      COMMON /sok54/ XMIN,STEP,XMAX
      common /sok5_n4/ C(19)
      X1 = alog10(X)
       if ((X1.lt..99999e+0).or.(X1.gt.9.0001e+0)) then
       print*,'ERROR IN FUNCTION GETDEDPH: MUON ENERGY IS OUT OF RANGE'
       endif
      Y = (X1-XMIN)/STEP
      I = INT(Y+0.5)
      IF(I.LT.0.OR.X1.GT.XMAX) PRINT 1,X1,XMIN,XMAX
      Y = Y-I
      Z = Y*Y + 0.25
      getdedph4 = (Z-Y)*C(I+1) + (2.-(Z+Z))*C(I+2) + (Z+Y)*C(I+3)
      getdedph4 = (1.e+1)**(getdedph4)
      RETURN
1     FORMAT('*MISTAKE*X1=',D23.16,'XMIN=',D23.16,'XMAX=',D23.16)
      END
************************************************************************
* N.9_4
              FUNCTION gdedphv4(X)
*
      real*4 X
      COMMON /sok5n4/ XMIN,STEP,XMAX
      common /sok5_n24/ C(67)
      X1 = alog10(X)
       if ((X1.lt..99999e+0).or.(X1.gt.9.0001e+0)) then
       print*,'ERROR IN FUNCTION GDEDPHVS: MUON ENERGY IS OUT OF RANGE'
       endif
      Y = (X1-XMIN)/STEP
      I = INT(Y+0.5)
      IF(I.LT.0.OR.X1.GT.XMAX) PRINT 1,X1,XMIN,XMAX
      Y = Y-I
      Z = Y*Y + 0.25
      gdedphv4 = (Z-Y)*C(I+1) + (2.-(Z+Z))*C(I+2) + (Z+Y)*C(I+3)
      gdedphv4 = (1.e+1)**(gdedphv4)
      RETURN
1     FORMAT('*MISTAKE*X1=',D23.16,'XMIN=',D23.16,'XMAX=',D23.16)
      END
************************************************************************
* N.10_4
              FUNCTION gdedpht4(X)
*
      real*4 X
      COMMON /sok54/ XMIN,STEP,XMAX
      common /sok5_n34/ C(19)
      X1 = alog10(X)
       if ((X1.lt..99999e+0).or.(X1.gt.9.0001e+0)) then
       print*,'ERROR IN FUNCTION GDEDPHTS: MUON ENERGY IS OUT OF RANGE'
       endif
      Y = (X1-XMIN)/STEP
      I = INT(Y+0.5)
      IF(I.LT.0.OR.X1.GT.XMAX) PRINT 1,X1,XMIN,XMAX
      Y = Y-I
      Z = Y*Y + 0.25
      gdedpht4 = (Z-Y)*C(I+1) + (2.-(Z+Z))*C(I+2) + (Z+Y)*C(I+3)
      gdedpht4 = (1.e+1)**(gdedpht4)
      RETURN
1     FORMAT('*MISTAKE*X1=',D23.16,'XMIN=',D23.16,'XMAX=',D23.16)
      END
****************************************************************************
* N.11_4
       FUNCTION getcdn4(X,Y,lo)
*
       real*4 X,Y
       integer lo
       external getcdn14,getcdn24,getcdn34,phnu_tot4
       if (lo.eq.0) then
          if (Y.le..251188643) then
                getcdn4 = getcdn14(X,Y,lo)
               getcdn4 = exp(getcdn4)
          else
               if (Y.le..794328234) then
                  getcdn4 = getcdn24(X,Y,lo)
                  getcdn4 = exp(getcdn4)
               else
                 if (Y.le..965) then
                    getcdn4 = getcdn34(X,Y,lo)
                    getcdn4 = exp(getcdn4)
                 else
                    getcdn4 = phnu_tot4(X,Y)
                 endif
               endif
          endif
       else
          if (Y.le.-6.e-1) then
                getcdn4 = getcdn14(X,Y,lo)
                getcdn4 = exp(getcdn4)
          else
                if (Y.le.-1.e-1) then
                   getcdn4 = getcdn24(X,Y,lo)
                   getcdn4 = exp(getcdn4)
                else
                   if (Y.le.-1.54727e-2) then
                     getcdn4 = getcdn34(X,Y,lo)
                     getcdn4 = exp(getcdn4)
                   else
                     Y1 = (1.e+1)**Y
                     getcdn4 = phnu_tot4(X,Y1)
                   endif
                endif
          endif
       endif
      if (getcdn4.lt.0.e+0) getcdn4 = 0.e+0
      return
      end
****************************************************************************
* N.12_4
       FUNCTION getcdn14(X,Y,loga)
*
      real*4 X,Y
      integer loga
      common /mum84/ C1(4648)
      common /sok_2_14/ NX,NY,X0,SX,Y0,SY
      X_1=alog10(X)
      if ((X_1.lt..99999e+0).or.(X_1.gt.9.0001e+0)) then
      print*,'ERROR IN FUNCTION GETCDN1S: MUON ENERGY IS OUT OF RANGE'
      endif
      if (loga.eq.0) then
      Y_1=alog10(Y)
      else
      Y_1=Y
      endif
      if ((Y_1.lt.-11.001).or.(Y_1.gt.-5.9999e-1)) then
      print*,'ERROR IN FUNCTION GETCDN1S: EN. TRANSFER IS OUT OF RANGE'
      endif
      A3=(X_1-X0)/SX
      B3=(Y_1-Y0)/SY
      M1=INT(A3+.5)
      M2=INT(B3+.5)
      M3=NX+2
      IF(M1.LT.0.OR.M1.GE.NX.OR.M2.LT.0.OR.M2.GE.NY) THEN
      PRINT 1,X_1,M1,Y_1,M2
      ENDIF
      A3=A3-M1
      B3=B3-M2
      M1=M2*M3+M1+1
      M2=M1+M3
      M3=M2+M3
      A2=A3*A3+.25
      B2=B3*B3+.25
      A1=A2-A3
      B1=B2-B3
      A3=A2+A3
      B3=B2+B3
      A2=2.-(A2+A2)
      B2=2.-(B2+B2)
      getcdn14=(A1*C1(M1)+A2*C1(M1+1)+A3*C1(M1+2))*B1
     2      +(A1*C1(M2)+A2*C1(M2+1)+A3*C1(M2+2))*B2
     3      +(A1*C1(M3)+A2*C1(M3+1)+A3*C1(M3+2))*B3
      RETURN
1     FORMAT('GETCDN1S: *MISTAKE*X= ',D23.16,' MX= ',I4,' Y= ',D23.16,
     +' MY= ',I4)
      END
****************************************************************************
* N.13_4
*
       FUNCTION getcdn24(X,Y,loga)
*
      real*4 X,Y
      integer loga
      common /mum94/ C1(4399)
      common /sok_2_24/ NX,NY,X0,SX,Y0,SY
      X_1=alog10(X)
      if ((X_1.lt..99999e+0).or.(X_1.gt.9.0001e+0)) then
      print*,'ERROR IN FUNCTION GETCDN2S: MUON ENERGY IS OUT OF RANGE'
      endif
      if (loga.eq.0) then
      Y_1=alog10(Y)
      else
      Y_1=Y
      endif
      if ((Y_1.lt.-.60001).or.(Y_1.gt.-.99999e-1)) then
      print*,'ERROR IN FUNCTION GETCDN2S: EN. TRANSFer IS OUT OF RANGE'
      endif
      A3=(X_1-X0)/SX
      B3=(Y_1-Y0)/SY
      M1=INT(A3+.5)
      M2=INT(B3+.5)
      M3=NX+2
      IF(M1.LT.0.OR.M1.GE.NX.OR.M2.LT.0.OR.M2.GE.NY) THEN
      PRINT 1,X_1,M1,Y_1,M2
      ENDIF
      A3=A3-M1
      B3=B3-M2
      M1=M2*M3+M1+1
      M2=M1+M3
      M3=M2+M3
      A2=A3*A3+.25
      B2=B3*B3+.25
      A1=A2-A3
      B1=B2-B3
      A3=A2+A3
      B3=B2+B3
      A2=2.-(A2+A2)
      B2=2.-(B2+B2)
      getcdn24=(A1*C1(M1)+A2*C1(M1+1)+A3*C1(M1+2))*B1
     2      +(A1*C1(M2)+A2*C1(M2+1)+A3*C1(M2+2))*B2
     3      +(A1*C1(M3)+A2*C1(M3+1)+A3*C1(M3+2))*B3
      RETURN
1     FORMAT('GCDN2S:*MISTAKE*X=',D23.16,'MX=',I4,'Y=',D23.16,'MY=',I4)
      END
****************************************************************************
* N.14_4
*
       FUNCTION getcdn34(X,Y,loga)
*
      real*4 X,Y
      integer loga
      common /mum104/ C2(8549)
      common /sok_2_34/ NX,NY,X0,SX,Y0,SY
      X_1=alog10(X)
      if ((X_1.lt..99999e+0).or.(X_1.gt.9.0001e+0)) then
      print*,'ERROR IN FUNCTION GETCDN3S: MUON ENERGY IS OUT OF RANGE'
      endif
      if (loga.eq.0) then
      Y_1=alog10(Y)
      else
      Y_1=Y
      endif
      if ((Y_1.lt.-1.0001e-1).or.(Y_1.gt.1.e-6)) then
      print*,'ERROR IN FUNCTION GETCDN3S: EN. TRANSFER IS OUT OF RANGE'
      endif
      A3=(X_1-X0)/SX
      B3=(Y_1-Y0)/SY
      M1=INT(A3+.5)
      M2=INT(B3+.5)
      M3=NX+2
      IF(M1.LT.0.OR.M1.GE.NX.OR.M2.LT.0.OR.M2.GE.NY) THEN
      PRINT 1,X_1,M1,Y_1,M2
      ENDIF
      A3=A3-M1
      B3=B3-M2
      M1=M2*M3+M1+1
      M2=M1+M3
      M3=M2+M3
      A2=A3*A3+.25
      B2=B3*B3+.25
      A1=A2-A3
      B1=B2-B3
      A3=A2+A3
      B3=B2+B3
      A2=2.-(A2+A2)
      B2=2.-(B2+B2)
      getcdn34=(A1*C2(M1)+A2*C2(M1+1)+A3*C2(M1+2))*B1
     2      +(A1*C2(M2)+A2*C2(M2+1)+A3*C2(M2+2))*B2
     3      +(A1*C2(M3)+A2*C2(M3+1)+A3*C2(M3+2))*B3
      RETURN
1     FORMAT('*MISTAKE*X=',D23.16,'MX=',I4,'Y=',D23.16,'MY=',I4)
      END
****************************************************************************
* N.15_4
          SUBROUTINE getvph4(emw,vbr,itr)
*
      external getcdn4
      real*4 emw,vbr
      integer itr
      parameter (lo=1)
      common /general4/ emin,vmin,emph
      common /mcef4/ mcb1,mcb2,mcp1,mcp2,mcn1,mcn2,mce1,mce2
      common /ph_ref4/ at,bt,us2,us2_1,us3,us4,at0
      mcn1 = mcn1 + 1
        if (itr.eq.0) then
          vtr=amax1((emin/emw),(emph/emw))
        else
          vtr=amax1(vmin,(emph/emw))
        endif
      us1 = vtr**(1. - bt)
      algemin = us2 * (1. - us1)
  155 ax = algemin * rndm_mum(5)
      vbr = (alog(us1 + (ax * us2_1))) * us3
      mcn2 = mcn2 + 1
      y1 = getcdn4(emw,vbr,lo)
      y2 = at * exp(vbr * us4)
      yc = y2 * rndm_mum(8)
           if (y2.lt.y1) then
           fnew = y1 / y2
           at = at * (fnew)
           fnew1 = at / at0
           us2 = at / (1.-bt)
           us2_1 = 1. / us2
           us3 = .434294481 / (1. - bt)
           us4 = 2.302585093 * (-bt)
       print*,'***** COMPARISON FUNCTION FOR PH.NUC. SIMULATION: *****'
           print*,'Variable  AT has been increased with factor',fnew
           print*,'Now it differs from init. value with factor',fnew1
       print*,'   No reasons to trouble, it is for information only'
             if (fnew1.gt.1.5) then
       print*,'************ ERROR (4)********* f(v) < d_Sigma/d_v ****'
       print*,'**** VARIABLE  AT  HAS BEEN INCREASED TOO MUCH !!! ****'
             endif
       print*,'*******************************************************'
           endif
        if (y1.ge.yc) then
        vbr = 1.e+1**vbr
        else
        goto 155
        endif
      return
      end
****************************************************************************
*********************** DELTA-ELECTRONS SUBROUTINES : **********************
****************************************************************************
* E.1_4
*
      function getcde4(e,v)
      common /zav4/ z
c GeV:
      parameter (ame=0.51099907e-3)
c   parameter (amu=0.105658389)   ! GeV
c cm:
      parameter (re=2.81794092e-13)
      parameter (alpha=1./137.036)
      parameter (pi=3.141592654)
c   parameter (bmu=amu**2/(2.*ame))
      parameter (coeff0=2.*pi*ame*re**2)
      parameter (coeff1=alpha/(2.*pi))
      parameter (sok1=2./ame)
c       parameter (sok2=5.88138263)
      real*8 alfa,rm_e,rm_mu,r_e,avog
      common /const4/ alfa,rm_e,rm_mu,r_e,avog
      real*4 e,v
      common /exer14/ fa
c
        amu = 1.e-3 * sngl(rm_mu)
        bmu=amu**2/(2.*ame)
        sok2 = alog(4. / (amu * amu) )
c
        vpmax=e/(e+bmu)
        ep=v*e
           if (v.ge.vpmax) then
              getcde4=0.
              return
           endif
        sigma0=coeff0*z*(1.-v/vpmax+.5*v*v)/(v*ep)
        a1=alog(1.+sok1*ep)
        a3=sok2+alog(e*(e-ep))
        getcde4=sigma0*(1.+coeff1*a1*(a3-a1))*fa
        return
        end
****************************************************************************
* E.2_4
*
      function edbrt4(e)
      external simps
      real*8 alfa,rm_e,rm_mu,r_e,avog,z1(10),w(10),aw(10),a_ef,ro
      real*4 e
c from initial subroutine MED_CONS4:
      common /const4/ alfa,rm_e,rm_mu,r_e,avog
      common /media4/ z1,w,aw,a_ef,ro,nsub
c-----------
      common /zav4/ z
      common /exer14/ fa
c GeV:
      parameter (ame=0.51099907e-3)
c      parameter (amu=0.105658389)   !  GeV
c cm:
      parameter (re=2.81794092e-13)
      parameter (alpha=1./137.036)
      parameter (pi=3.141592654)
c      parameter (bmu=amu**2/(2.*ame))
      parameter (coeff0=2.*pi*ame*re**2)
      parameter (coeff1=alpha/(2.*pi))
      parameter (sok1=2./ame)
c      parameter (sok2=5.88138263)
      parameter (lim=2000)
      dimension aux(0:2000)
c
      amu = 1.e-3 * sngl(rm_mu)
      bmu=amu**2/(2.*ame)
      sok2 = alog(4. / (amu * amu) )
c
      vpmin = alog(7.5e-8 / e)
      vpmax = e / (e + bmu)
      vpmax1 = alog(vpmax)
      st = (vpmax1 - vpmin) * 5.e-4
      do i=0,lim
        v = exp(vpmin + st * float(i))
        ep = v * e
        if (v.ge.vpmax) then
         aux(i) = 0.
        else
         sigma0 = coeff0 * z * v * (1. - v/vpmax + .5 * v * v) / ep
         a1 = alog(1. + sok1 * ep)
         a3 = sok2 + alog(e * (e - ep))
         aux(i) = sigma0 * coeff1 * a1 * (a3 - a1)
        endif
      enddo
      edbrt4 = simps(aux,vpmin,vpmax1,lim) * e * 1.e+3
      edbrt4 = fa * edbrt4 * sngl(avog * ro / a_ef)
      return
      end
****************************************************************************
* E.3_4
*
        function bebl4(ene)
*
      real*8 c_0,z_a,ri_z,x_0,x_1,a,rm,con1,con2,hnu,c,e
      real*8 beta,p,w_max,x,theta1,theta2,delta,difx1_x,e_loss
      real*8 alfa,rm_e,rm_mu,r_e,avog,z1(10),w(10),aw(10),a_ef,ro
      real*4 ene
c
c from initial subroutine MED_CONS4:
c
      common /const4/ alfa,rm_e,rm_mu,r_e,avog
      common /media4/ z1,w,aw,a_ef,ro,nsub
      common /med_ion4/ z_a,ri_z,x_0,x_1,a,rm
c------------------------
      common /exer14/ fa
      parameter (c_0=1.535d-1)
c
      e = dble(ene) * 1.d+3
      con1 = c_0 * z_a * ro
      con2 = (2.d+0 * rm_e)/(rm_mu * rm_mu * ri_z * ri_z)
      hnu = 2.8816d+1 * dsqrt(ro*z_a)/1.d+6
      c = (2.d+0 * dlog(ri_z/hnu)) + 1.d+0
c
      beta = dsqrt(1.d+0 - ((rm_mu * rm_mu)/(e * e)))
      p = beta * e
      w_max=(2.d+0*rm_e*p*p)/((rm_mu*rm_mu)+(rm_e*rm_e)+(2.d+0*rm_e*e))
      x = dlog10(p/rm_mu)
             if(x.gt.x_0) then
             theta1 = 1.d+0
             else
             theta1 = 0.d+0
             delta = 0.d+0
             goto 1
             endif
                if(x_1.gt.x) then
                theta2 = 1.d+0
                else
                theta2 = 0.d+0
                difx1_x=0.d+0
                goto 2
                endif
       difx1_x = (x_1 - x)**rm
 2     delta = theta1 * ((4.6052d+0 * x) + (a * theta2 * difx1_x) - c)
 1     e_loss=(con1/(beta*beta))*((dlog(con2*p*p*w_max))+((w_max*w_max)/
     +(4.d+0*e*e))-(2.d+0*beta*beta)-delta)
       bebl4=sngl(e_loss) * fa
       return
       end
****************************************************************************
* E.4_4
*
       subroutine elec14
*
       external getcde4,dsimps
       real*8 dsimps
       real*8 um
       real*8 aux1(0:2000),aux2(0:2000),h1,h2
       real*8 alfa,rm_e,rm_mu,r_e,avog,z1(10),w(10),aw(10),a_ef,ro
       common /const4/ alfa,rm_e,rm_mu,r_e,avog ! from initial subroutine
       common /media4/ z1,w,aw,a_ef,ro,nsub     !       MED_CONSS
       common /general4/ emin,vmin,emph         !
       common /ctel_in14/ crt_el1(17),crt_el2(17)
       common /elel_in14/ elo_el1(17),elo_el2(17)
       common /elel_in24/ elel_bb(17),elel_bbb(17)
       common /elel_in34/ elel_tot(101)
       common /help_14/ aux1,aux2
       common /exer24/ noca
c ....................................................................
c     PREPARATION OF ARRAYS WITH ENERGY LOSSES AND AVERAGED FREE PATH
c                        FOR KNOCK-ON-ELECTRONS:
c
c                     a) energy transfers > EMIN
c
      lim = 2000
      do i=1,17
      en = float(i)
      en = (1.e+1)**(5.e-1 + (5.e-1 * en))
      vmi = alog(emin / en) !--------------> The lower limit for integration
      um = (rm_mu * rm_mu * 1.d-3) / (2.d+0 * rm_e)
      vma = sngl(um)
      vma = 1. / ( 1.e+0 + (vma / en) )
      vma = alog(vma)       !--------------> The upper limit for integration
      vst = (vma - vmi) / float(lim) !--> step for a rel. en. transfers grid
c
      do j=0,lim
      rnu = vmi + vst*(float(j))
      rnu = exp(rnu)
      aux1(j) = dble(getcde4(en,rnu) * rnu)        !-> array to be integrated
c                                                 !   to get mean free path
      aux2(j) = aux1(j) * rnu                     !-> array to be integrated
      enddo                                       !   for getting en. losses
c
      h1 = dble(vmi)
      h2 = dble(vma)
      crt_el1(i) = sngl(dsimps(aux1,h1,h2,lim))
      if(crt_el1(i).le.0.e+0) then
      crt_el1(i) = 1.e+10
      goto 94765
      endif
      crt_el1(i) = (sngl(a_ef/(avog*ro)))/crt_el1(i) !-> array with 17 values
c                                                    !   of free path
94765 continue
      elo_el1(i) = sngl( dsimps(aux2,h1,h2,lim) * avog * ro / a_ef )
      elo_el1(i) = elo_el1(i) * en * 1.e+3
      elo_el1(i) = alog10(elo_el1(i)) !-> array with 17 values of en. losses
      enddo
c                     b) energy transfers > VMIN
      do i=1,17
      en = float(i)
      en = (1.e+1)**(5.e-1 + (5.e-1 * en))
      vmi = alog(vmin)      !--------------> The lower limit for integration
      um = (rm_mu * rm_mu * 1.d-3) / (2.d+0 * rm_e)
      vma = sngl(um)
      vma = 1. / ( 1.e+0 + (vma / en) )
      vma = alog(vma)       !--------------> The upper limit for integration
      vst = (vma - vmi) / float(lim) !--> step for a rel. en. transfers grid
c
      do j=0,lim
      rnu = vmi + vst*(float(j))
      rnu = exp(rnu)
      aux1(j) = dble(getcde4(en,rnu) * rnu)        !-> array to be integrated
c                                                 !   to get mean free path
      aux2(j) = aux1(j) * rnu                     !-> array to be integrated
      enddo                                       !   for getting en. losses
c
      h1 = dble(vmi)
      h2 = dble(vma)
      crt_el2(i) = sngl(dsimps(aux1,h1,h2,lim))
      if(crt_el2(i).le.0.e+0) then
      crt_el2(i) = 1.e+10
      goto 94766
      endif
      crt_el2(i) = (sngl(a_ef/(avog*ro)))/crt_el2(i) !-> array with 17 values
94766 continue
      crt_el2(i) = alog(crt_el2(i))                  !   of free path
      if (noca.eq.0) crt_el2(i)=45. !-> no cat. losses for knock-on electrons
c
      elo_el2(i) = sngl( dsimps(aux2,h1,h2,lim) * avog * ro / a_ef )
      elo_el2(i) = elo_el2(i) * en * 1.e+3
      if(elo_el2(i).le.0.e+0) elo_el2(i) = 1.e-8
      if (noca.eq.0) elo_el2(i)=1.e-30!->no cat. losses for knock-on electrons
      elo_el2(i) = alog10(elo_el2(i)) !-> array with 17 values of en. losses
      enddo
c                     c) energy transfers > 0
      do i=1,17
      en = float(i)
      en = (1.e+1)**(5.e-1 + (5.e-1 * en))
      elel_bb(i) = bebl4(en)                !--> Ion. en. losses (Bethe-Bloch)
      elel_bbb(i) = edbrt4(en) + elel_bb(i)  !--> BB + bremsstahlung e-diagram
      enddo
c                     d) total energy losses below 10 GeV
c                 (Bethe-Bloch + e-diagrams for bremsstrahlung)
      do i=1,101
      en = float(i)
      en = (1.e+1)**(alog10(0.14) - .02 + (.02 * en))
      elel_tot(i) = edbrt4(en) + bebl4(en)
      enddo
c
      return
      end
****************************************************************************
* E.5_4
           FUNCTION getlelec4(X)
*
      real*4 X
      COMMON /sok14/ XMIN,STEP,XMAX
      common /sok1_e4/ C(19)
      X1 = alog10(X)
       if ((X1.lt..99999e+0).or.(X1.gt.9.0001e+0)) then
       print*,'ERROR IN FUNCTION GETLELECS: MUON ENERGY IS OUT OF RANGE'
       endif
      Y = (X1-XMIN)/STEP
      I = INT(Y+0.5)
      IF(I.LT.0.OR.X1.GT.XMAX) PRINT 1,X1,XMIN,XMAX
      Y = Y-I
      Z = Y*Y + 0.25
      getlelec4 = (Z-Y)*C(I+1) + (2.-(Z+Z))*C(I+2) + (Z+Y)*C(I+3)
      RETURN
1     FORMAT('*MISTAKE*X1=',D23.16,'XMIN=',D23.16,'XMAX=',D23.16)
      END
****************************************************************************
* E.6_4
           FUNCTION glelecv4(X)
*
      real*4 X
      COMMON /sok14/ XMIN,STEP,XMAX
      common /sok1_e24/ C(19)
      common /exer24/ noca
      if (noca.eq.0) then
      glelecv4 = 1.e+34
      return
      endif
      X1 = alog10(X)
       if ((X1.lt..99999e+0).or.(X1.gt.9.0001e+0)) then
       print*,'ERROR IN FUNCTION GLELECVS: MUON ENERGY IS OUT OF RANGE'
       endif
      Y = (X1-XMIN)/STEP
      I = INT(Y+0.5)
      IF(I.LT.0.OR.X1.GT.XMAX) PRINT 1,X1,XMIN,XMAX
      Y = Y-I
      Z = Y*Y + 0.25
      glelecv4 = (Z-Y)*C(I+1) + (2.-(Z+Z))*C(I+2) + (Z+Y)*C(I+3)
      glelecv4 = exp(glelecv4)
      RETURN
1     FORMAT('*MISTAKE*X1=',D23.16,'XMIN=',D23.16,'XMAX=',D23.16)
      END
****************************************************************************
* E.7_4
           function getctel4(u)
*
      external getlelec4
      real*8 z1(10),w(10),aw(10),a_ef,alfa,rm_e,rm_mu,r_e,avog,ro
      real*4 u
      common /const4/ alfa,rm_e,rm_mu,r_e,avog
      common /media4/ z1,w,aw,a_ef,ro,nsub
      if ((u.gt.1.0001e+9).or.(u.lt.9.9999e+0)) then
      print*,'ERROR IN FUNCTION GETCTELS: MUON ENERGY IS OUT OF RANGE'
      endif
      aef = sngl(a_ef / (avog * ro))
      getctel4 = aef / getlelec4(u)
      return
      end
****************************************************************************
* E.8_4
           function gctelv4(u)
*
      external glelecv4
      real*8 z1(10),w(10),aw(10),a_ef,alfa,rm_e,rm_mu,r_e,avog,ro
      real*4 u
      common /const4/ alfa,rm_e,rm_mu,r_e,avog
      common /media4/ z1,w,aw,a_ef,ro,nsub
      common /exer24/ noca
      if (noca.eq.0) then
      gctelv4 = 1.e-37
      return
      endif
      if ((u.gt.1.0001e+9).or.(u.lt.9.9999e+0)) then
      print*,'ERROR IN FUNCTION GCTELVS: MUON ENERGY IS OUT OF RANGE'
      endif
      aef = sngl(a_ef / (avog * ro))
      gctelv4 = aef / glelecv4(u)
      return
      end
************************************************************************
* E.9_4
             FUNCTION getdedel4(X)
*
      real*4 X
      COMMON /sok54/ XMIN,STEP,XMAX
      common /sok5_e4/ C(19)
      X1 = alog10(X)
       if ((X1.lt..99999e+0).or.(X1.gt.9.0001e+0)) then
       print*,'ERROR IN FUNCTION GETDEDELS: MUON ENERGY IS OUT OF RANGE'
       endif
      Y = (X1-XMIN)/STEP
      I = INT(Y+0.5)
      IF(I.LT.0.OR.X1.GT.XMAX) PRINT 1,X1,XMIN,XMAX
      Y = Y-I
      Z = Y*Y + 0.25
      getdedel4 = (Z-Y)*C(I+1) + (2.-(Z+Z))*C(I+2) + (Z+Y)*C(I+3)
      getdedel4 = (1.e+1)**(getdedel4)
      RETURN
1     FORMAT('*MISTAKE*X1=',D23.16,'XMIN=',D23.16,'XMAX=',D23.16)
      END
************************************************************************
* E.10_4
             FUNCTION gdedelv4(X)
*
      real*4 X
      COMMON /sok54/ XMIN,STEP,XMAX
      common /sok5_e24/ C(19)
      common /exer24/ noca
      if (noca.eq.0) then
      gdedelv4 = 1.e-36
      return
      endif
      X1 = alog10(X)
       if ((X1.lt..99999e+0).or.(X1.gt.9.0001e+0)) then
       print*,'ERROR IN FUNCTION GDEDELVS: MUON ENERGY IS OUT OF RANGE'
       endif
      Y = (X1-XMIN)/STEP
      I = INT(Y+0.5)
      IF(I.LT.0.OR.X1.GT.XMAX) PRINT 1,X1,XMIN,XMAX
      Y = Y-I
      Z = Y*Y + 0.25
      gdedelv4 = (Z-Y)*C(I+1) + (2.-(Z+Z))*C(I+2) + (Z+Y)*C(I+3)
      gdedelv4 = (1.e+1)**(gdedelv4)
      RETURN
1     FORMAT('*MISTAKE*X1=',D23.16,'XMIN=',D23.16,'XMAX=',D23.16)
      END
****************************************************************************
* E.11_4
             FUNCTION gdedelt14(X)
*
      real*4 X
      COMMON /sok54/ XMIN,STEP,XMAX
      common /sok5_e44/ C(19)
      X1 = alog10(X)
       if ((X1.lt..99999e+0).or.(X1.gt.9.0001e+0)) then
       print*,'ERROR IN FUNCTION GDEDELT1S: MUON ENERGY IS OUT OF RANGE'
       endif
      Y = (X1-XMIN)/STEP
      I = INT(Y+0.5)
      IF(I.LT.0.OR.X1.GT.XMAX) PRINT 1,X1,XMIN,XMAX
      Y = Y-I
      Z = Y*Y + 0.25
      gdedelt14 = (Z-Y)*C(I+1) + (2.-(Z+Z))*C(I+2) + (Z+Y)*C(I+3)
      RETURN
1     FORMAT('*MISTAKE*X1=',D23.16,'XMIN=',D23.16,'XMAX=',D23.16)
      END
****************************************************************************
* E.12_4
             FUNCTION gdedelt24(X)
*
      real*4 X
      COMMON /sok5et4/ XMIN,STEP,XMAX
      common /sok5_e54/ C(103)
      X1 = alog10(X)
       if ((X1.lt.-.8e+0).or.(X1.gt.1.08e+0)) then
       print*,'ERROR IN FUNCTION GDEDELT2S: MUON ENERGY IS OUT OF RANGE'
       endif
      Y = (X1-XMIN)/STEP
      I = INT(Y+0.5)
      IF(I.LT.0.OR.X1.GT.XMAX) PRINT 1,X1,XMIN,XMAX
      Y = Y-I
      Z = Y*Y + 0.25
      gdedelt24 = (Z-Y)*C(I+1) + (2.-(Z+Z))*C(I+2) + (Z+Y)*C(I+3)
      RETURN
1     FORMAT('*MISTAKE*X1=',D23.16,'XMIN=',D23.16,'XMAX=',D23.16)
      END
****************************************************************************
* E.13_4
             FUNCTION gdeion4(X)
*
      real*4 X
      external gdedelt14,gdedelt24
       if ((X.lt..159).or.(X.gt.1.0001e+9)) then
       print*,'ERROR IN FUNCTION GDEDIONS: MUON ENERGY IS OUT OF RANGE'
       endif
      if(x.le.10.) then
      gdeion4 = gdedelt24(x)
      else
      gdeion4 = gdedelt14(x)
      endif
      return
      end
****************************************************************************
* E.14_4
             FUNCTION gdedelbb4(X)
*
      real*4 X
      COMMON /sok54/ XMIN,STEP,XMAX
      common /sok5_e34/ C(19)
      X1 = alog10(X)
       if ((X1.lt..99999e+0).or.(X1.gt.9.0001e+0)) then
       print*,'ERROR IN FUNCTION GDEDELBBS: MUON ENERGY IS OUT OF RANGE'
       endif
      Y = (X1-XMIN)/STEP
      I = INT(Y+0.5)
      IF(I.LT.0.OR.X1.GT.XMAX) PRINT 1,X1,XMIN,XMAX
      Y = Y-I
      Z = Y*Y + 0.25
      gdedelbb4 = (Z-Y)*C(I+1) + (2.-(Z+Z))*C(I+2) + (Z+Y)*C(I+3)
      RETURN
1     FORMAT('*MISTAKE*X1=',D23.16,'XMIN=',D23.16,'XMAX=',D23.16)
      END
****************************************************************************
* E.15_4
         SUBROUTINE getvel4(emw,vbr1,itr)
*
      external getcde4
      real*8 vbr,rmd,vtr,vtr1,rvec_own
      real*4 emw,vbr1
      integer itr
      parameter (c2=2.549551e-28)
c      parameter (len=1)
c      common /r48/ rvec
      common /zav4/ zm
      common /general4/ emin,vmin,emph
      common /mcef4/ mcb1,mcb2,mcp1,mcp2,mcn1,mcn2,mce1,mce2
      mce1 = mce1 + 1
ccc      emind = dble(emin)
ccc      vmind = dble(vmin)
ccc      emwd = dble(emw)
        if(itr.eq.0) then
         vtr = dble(emin/emw)
        else
         vtr = dble(vmin)
        endif
      vtr1 = 1.d+0 - vtr
      coef2 = c2 * zm *  ( 1. + ( 3.2e-2 * alog(emw) ) )
  155 call rm48_own(rvec_own)
      rmd=rvec_own
      mce2 = mce2 + 1
      vbr = vtr / (vtr + (vtr1 * rmd))
      if(vbr.ge.1.d+0) vbr=.999999999999d+0
      vbr1=sngl(vbr)
      y1 = getcde4(emw,vbr1)
      y2 = coef2 / ( emw * vbr1 * vbr1)
      yc = y2 * rndm_mum(8)
           if(y2.lt.y1) then
           print*,'*** ERROR IN GETVELS: COMP.FUNCTION IS TOO SMALL ***'
           endif
                if (y1.ge.yc) then
                  goto 154
                else
                  goto 155
                endif
  154 return
      end
****************************************************************************
************************************************************************
************************************************************************
**                                                                    **
**    FORTRAN FILES FROM CERN LIBRARY TAKEN FROM                      **
**    http://cernlib.web.cern.ch/cernlib/download/2006_source/tar/    **
**    and adopted for the MUM package to avoid usage of               **
**    compiled CERNLIBRARIES                                          **
**                                                                    **
************************************************************************
************************************************************************
*
************************************************************************
*                                                                      *
* CERNlib, D101, MATHLIB, SIMPS: integration by Simpson's Rule,        *
* single precision (real*4).                                           *
*                                                                      *
* Located: cernlib\mathlib32_src\mathlib\gen\d\simps.f                 *
*                                                                      *
************************************************************************
*
* $Id: simps.F,v 1.1.1.1 1996/04/01 15:02:13 mclareni Exp $
*
* $Log: simps.F,v $
* Revision 1.1.1.1  1996/04/01 15:02:13  mclareni
* Mathlib gen
*
*
C This will be SIMPS,IF=DOUBLE and SIMPS64,IF=-DOUBLE
      FUNCTION SIMPS(F,A,B,N2)
ccccc commented by ISOKALSKI      CHARACTER NAME*(*)
ccccc commented by ISOKALSKI      CHARACTER*80 ERRTXT
ccccc commented by ISOKALSKI      PARAMETER (NAME = 'SIMPS')
*
* $Id: simpscod.inc,v 1.1.1.1 1996/04/01 15:02:13 mclareni Exp $
*
* $Log: simpscod.inc,v $
* Revision 1.1.1.1  1996/04/01 15:02:13  mclareni
* Mathlib gen
*
* simpscod.inc
*
      DIMENSION F(0:*)
      IF(N2 .LE. 0 .OR. 2*(N2/2) .NE. N2) THEN
       H=0
       WRITE(*,101) N2+1
ccccc commented by ISOKALSKI       WRITE(ERRTXT,101) N2+1
ccccc commented by ISOKALSKI       CALL MTLPRT(NAME,'D101.1',ERRTXT)
      ELSE
*      S1=0
       S1=F(N2-1)
       S2=0
*      DO 1 N = 1,N2-1,2
*   1  S1=S1+F(N)
*      DO 2 N = 2,N2-2,2
*   2  S2=S2+F(N)
       DO 1 N = 1,N2-3,2
         S1=S1+F(N)
         S2=S2+F(N+1)
    1  CONTINUE
*      S1=S1+F(N2-1)
       S1=S1+S1+S2
       H=(F(0)+F(N2)+S1+S1)*(B-A)/(3*N2)
      ENDIF
      SIMPS=H
      RETURN
  101 FORMAT('NON-POSITIVE OR EVEN NUMBER OF FUNCTION VALUES =',I6)
      END
************************************************************************
*                                                                      *
* CERNlib, D101, MATHLIB, DSIMPS: integration by Simpson's Rule,       *
* double precision (real*8).                                           *
*                                                                      *
* Located: cernlib\mathlib32_src\mathlib\gen\d\simps64.f               *
*                                                                      *
************************************************************************
*
* $Id: simps64.F,v 1.1.1.1 1996/04/01 15:02:13 mclareni Exp $
*
* $Log: simps64.F,v $
* Revision 1.1.1.1  1996/04/01 15:02:13  mclareni
* Mathlib gen
*
*
      FUNCTION DSIMPS(F,A,B,N2)
*
* $Id: imp64.inc,v 1.1.1.1 1996/04/01 15:02:59 mclareni Exp $
*
* $Log: imp64.inc,v $
* Revision 1.1.1.1  1996/04/01 15:02:59  mclareni
* Mathlib gen
*
*
* imp64.inc
*
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
ccccc commented by ISOKALSKI      CHARACTER NAME*(*)
ccccc commented by ISOKALSKI      CHARACTER*80 ERRTXT
ccccc commented by ISOKALSKI      PARAMETER (NAME = 'DSIMPS')
*
* $Id: simpscod.inc,v 1.1.1.1 1996/04/01 15:02:13 mclareni Exp $
*
* $Log: simpscod.inc,v $
* Revision 1.1.1.1  1996/04/01 15:02:13  mclareni
* Mathlib gen
*
* simpscod.inc
*
      DIMENSION F(0:*)
      IF(N2 .LE. 0 .OR. 2*(N2/2) .NE. N2) THEN
       H=0
       WRITE(*,101) N2+1
ccccc commented by ISOKALSKI       WRITE(ERRTXT,101) N2+1
ccccc commented by ISOKALSKI       CALL MTLPRT(NAME,'D101.1',ERRTXT)
      ELSE
*      S1=0
       S1=F(N2-1)
       S2=0
*      DO 1 N = 1,N2-1,2
*   1  S1=S1+F(N)
*      DO 2 N = 2,N2-2,2
*   2  S2=S2+F(N)
       DO 1 N = 1,N2-3,2
         S1=S1+F(N)
         S2=S2+F(N+1)
    1  CONTINUE
*      S1=S1+F(N2-1)
       S1=S1+S1+S2
       H=(F(0)+F(N2)+S1+S1)*(B-A)/(3*N2)
      ENDIF
      DSIMPS=H
      RETURN
  101 FORMAT('NON-POSITIVE OR EVEN NUMBER OF FUNCTION VALUES =',I6)
      END
************************************************************************
*                                                                      *
* CERNlib, V115, MATHLIB, RANLUX: eneration of single precision        *
* (real*4) random number                                               *
*                                                                      *
* Located: cernlib\mathlib32_src\mathlib\gen\v\ranlux.f                *
*                                                                      *
************************************************************************
*
* $Id: ranlux.F,v 1.2 1997/09/22 13:45:47 mclareni Exp $
*
* $Log: ranlux.F,v $
* Revision 1.2  1997/09/22 13:45:47  mclareni
* Correct error in initializing RANLUX by using RLUXIN with the output of
* RLUXUT from a previous run.
*
* Revision 1.1.1.1  1996/04/01 15:02:55  mclareni
* Mathlib gen
*
*
      SUBROUTINE RANLUX(RVEC,LENV)
C         Subtract-and-borrow random number generator proposed by
C         Marsaglia and Zaman, implemented by F. James with the name
C         RCARRY in 1991, and later improved by Martin Luescher
C         in 1993 to produce "Luxury Pseudorandom Numbers".
C     Fortran 77 coded by F. James, 1993
C
C   LUXURY LEVELS.
C   ------ ------      The available luxury levels are:
C
C  level 0  (p=24): equivalent to the original RCARRY of Marsaglia
C           and Zaman, very long period, but fails many tests.
C  level 1  (p=48): considerable improvement in quality over level 0,
C           now passes the gap test, but still fails spectral test.
C  level 2  (p=97): passes all known tests, but theoretically still
C           defective.
C  level 3  (p=223): DEFAULT VALUE.  Any theoretically possible
C           correlations have very small chance of being observed.
C  level 4  (p=389): highest possible luxury, all 24 bits chaotic.
C
C!!! ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C!!!  Calling sequences for RANLUX:                                  ++
C!!!      CALL RANLUX (RVEC, LEN)   returns a vector RVEC of LEN     ++
C!!!                   32-bit random floating point numbers between  ++
C!!!                   zero (not included) and one (also not incl.). ++
C!!!      CALL RLUXGO(LUX,INT,K1,K2) initializes the generator from  ++
C!!!               one 32-bit integer INT and sets Luxury Level LUX  ++
C!!!               which is integer between zero and MAXLEV, or if   ++
C!!!               LUX .GT. 24, it sets p=LUX directly.  K1 and K2   ++
C!!!               should be set to zero unless restarting at a break++
C!!!               point given by output of RLUXAT (see RLUXAT).     ++
C!!!      CALL RLUXAT(LUX,INT,K1,K2) gets the values of four integers++
C!!!               which can be used to restart the RANLUX generator ++
C!!!               at the current point by calling RLUXGO.  K1 and K2++
C!!!               specify how many numbers were generated since the ++
C!!!               initialization with LUX and INT.  The restarting  ++
C!!!               skips over  K1+K2*E9   numbers, so it can be long.++
C!!!   A more efficient but less convenient way of restarting is by: ++
C!!!      CALL RLUXIN(ISVEC)    restarts the generator from vector   ++
C!!!                   ISVEC of 25 32-bit integers (see RLUXUT)      ++
C!!!      CALL RLUXUT(ISVEC)    outputs the current values of the 25 ++
C!!!                 32-bit integer seeds, to be used for restarting ++
C!!!      ISVEC must be dimensioned 25 in the calling program        ++
C!!! ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
      DIMENSION RVEC(LENV)
      DIMENSION SEEDS(24), ISEEDS(24), ISDEXT(25)
      PARAMETER (MAXLEV=4, LXDFLT=3)
      DIMENSION NDSKIP(0:MAXLEV)
      DIMENSION NEXT(24)
      PARAMETER (TWOP12=4096., IGIGA=1000000000,JSDFLT=314159265)
      PARAMETER (ITWO24=2**24, ICONS=2147483563)
      SAVE NOTYET, I24, J24, CARRY, SEEDS, TWOM24, TWOM12, LUXLEV
      SAVE NSKIP, NDSKIP, IN24, NEXT, KOUNT, MKOUNT, INSEED
      INTEGER LUXLEV
      LOGICAL NOTYET
      DATA NOTYET, LUXLEV, IN24, KOUNT, MKOUNT /.TRUE., LXDFLT, 0,0,0/
      DATA I24,J24,CARRY/24,10,0./
C                               default
C  Luxury Level   0     1     2   *3*    4
      DATA NDSKIP/0,   24,   73,  199,  365 /
Corresponds to p=24    48    97   223   389
C     time factor 1     2     3     6    10   on slow workstation
C                 1    1.5    2     3     5   on fast mainframe
C
C  NOTYET is .TRUE. if no initialization has been performed yet.
C              Default Initialization by Multiplicative Congruential
      IF (NOTYET) THEN
         NOTYET = .FALSE.
         JSEED = JSDFLT
         INSEED = JSEED
         WRITE(6,'(A,I12)') ' RANLUX DEFAULT INITIALIZATION: ',JSEED
         LUXLEV = LXDFLT
         NSKIP = NDSKIP(LUXLEV)
         LP = NSKIP + 24
         IN24 = 0
         KOUNT = 0
         MKOUNT = 0
         WRITE(6,'(A,I2,A,I4)')  ' RANLUX DEFAULT LUXURY LEVEL =  ',
     +        LUXLEV,'      p =',LP
            TWOM24 = 1.
         DO 25 I= 1, 24
            TWOM24 = TWOM24 * 0.5
         K = JSEED/53668
         JSEED = 40014*(JSEED-K*53668) -K*12211
         IF (JSEED .LT. 0)  JSEED = JSEED+ICONS
         ISEEDS(I) = MOD(JSEED,ITWO24)
   25    CONTINUE
         TWOM12 = TWOM24 * 4096.
         DO 50 I= 1,24
         SEEDS(I) = REAL(ISEEDS(I))*TWOM24
         NEXT(I) = I-1
   50    CONTINUE
         NEXT(1) = 24
         I24 = 24
         J24 = 10
         CARRY = 0.
         IF (SEEDS(24) .EQ. 0.) CARRY = TWOM24
      ENDIF
C
C          The Generator proper: "Subtract-with-borrow",
C          as proposed by Marsaglia and Zaman,
C          Florida State University, March, 1989
C
      DO 100 IVEC= 1, LENV
      UNI = SEEDS(J24) - SEEDS(I24) - CARRY
      IF (UNI .LT. 0.)  THEN
         UNI = UNI + 1.0
         CARRY = TWOM24
      ELSE
         CARRY = 0.
      ENDIF
      SEEDS(I24) = UNI
      I24 = NEXT(I24)
      J24 = NEXT(J24)
      RVEC(IVEC) = UNI
C  small numbers (with less than 12 "significant" bits) are "padded".
      IF (UNI .LT. TWOM12)  THEN
         RVEC(IVEC) = RVEC(IVEC) + TWOM24*SEEDS(J24)
C        and zero is forbidden in case someone takes a logarithm
         IF (RVEC(IVEC) .EQ. 0.)  RVEC(IVEC) = TWOM24*TWOM24
      ENDIF
C        Skipping to luxury.  As proposed by Martin Luscher.
      IN24 = IN24 + 1
      IF (IN24 .EQ. 24)  THEN
         IN24 = 0
         KOUNT = KOUNT + NSKIP
         DO 90 ISK= 1, NSKIP
         UNI = SEEDS(J24) - SEEDS(I24) - CARRY
         IF (UNI .LT. 0.)  THEN
            UNI = UNI + 1.0
            CARRY = TWOM24
         ELSE
            CARRY = 0.
         ENDIF
         SEEDS(I24) = UNI
         I24 = NEXT(I24)
         J24 = NEXT(J24)
   90    CONTINUE
      ENDIF
  100 CONTINUE
      KOUNT = KOUNT + LENV
      IF (KOUNT .GE. IGIGA)  THEN
         MKOUNT = MKOUNT + 1
         KOUNT = KOUNT - IGIGA
      ENDIF
      RETURN
C
C           Entry to input and float integer seeds from previous run
      ENTRY RLUXIN(ISDEXT)
         NOTYET = .FALSE.
         TWOM24 = 1.
         DO 195 I= 1, 24
         NEXT(I) = I-1
  195    TWOM24 = TWOM24 * 0.5
         NEXT(1) = 24
         TWOM12 = TWOM24 * 4096.
      WRITE(6,'(A)') ' FULL INITIALIZATION OF RANLUX WITH 25 INTEGERS:'
      WRITE(6,'(5X,5I12)') ISDEXT
      DO 200 I= 1, 24
      SEEDS(I) = REAL(ISDEXT(I))*TWOM24
  200 CONTINUE
      CARRY = 0.
      IF (ISDEXT(25) .LT. 0)  CARRY = TWOM24
      ISD = IABS(ISDEXT(25))
      I24 = MOD(ISD,100)
      ISD = ISD/100
      J24 = MOD(ISD,100)
      ISD = ISD/100
      IN24 = MOD(ISD,100)
      ISD = ISD/100
      LUXLEV = ISD
        IF (LUXLEV .LE. MAXLEV) THEN
          NSKIP = NDSKIP(LUXLEV)
          WRITE (6,'(A,I2)') ' RANLUX LUXURY LEVEL SET BY RLUXIN TO: ',
     +                         LUXLEV
        ELSE  IF (LUXLEV .GE. 24) THEN
          NSKIP = LUXLEV - 24
          WRITE (6,'(A,I5)') ' RANLUX P-VALUE SET BY RLUXIN TO:',LUXLEV
        ELSE
          NSKIP = NDSKIP(MAXLEV)
          WRITE (6,'(A,I5)') ' RANLUX ILLEGAL LUXURY RLUXIN: ',LUXLEV
          LUXLEV = MAXLEV
        ENDIF
      INSEED = -1
      RETURN
C
C                    Entry to ouput seeds as integers
      ENTRY RLUXUT(ISDEXT)
      DO 300 I= 1, 24
         ISDEXT(I) = INT(SEEDS(I)*TWOP12*TWOP12)
  300 CONTINUE
      ISDEXT(25) = I24 + 100*J24 + 10000*IN24 + 1000000*LUXLEV
      IF (CARRY .GT. 0.)  ISDEXT(25) = -ISDEXT(25)
      RETURN
C
C                    Entry to output the "convenient" restart point
      ENTRY RLUXAT(LOUT,INOUT,K1,K2)
      LOUT = LUXLEV
      INOUT = INSEED
      K1 = KOUNT
      K2 = MKOUNT
      RETURN
C
C                    Entry to initialize from one or three integers
      ENTRY RLUXGO(LUX,INS,K1,K2)
         IF (LUX .LT. 0) THEN
            LUXLEV = LXDFLT
         ELSE IF (LUX .LE. MAXLEV) THEN
            LUXLEV = LUX
         ELSE IF (LUX .LT. 24 .OR. LUX .GT. 2000) THEN
            LUXLEV = MAXLEV
            WRITE (6,'(A,I7)') ' RANLUX ILLEGAL LUXURY RLUXGO: ',LUX
         ELSE
            LUXLEV = LUX
            DO 310 ILX= 0, MAXLEV
              IF (LUX .EQ. NDSKIP(ILX)+24)  LUXLEV = ILX
  310       CONTINUE
         ENDIF
      IF (LUXLEV .LE. MAXLEV)  THEN
         NSKIP = NDSKIP(LUXLEV)
         WRITE(6,'(A,I2,A,I4)') ' RANLUX LUXURY LEVEL SET BY RLUXGO :',
     +        LUXLEV,'     P=', NSKIP+24
      ELSE
          NSKIP = LUXLEV - 24
          WRITE (6,'(A,I5)') ' RANLUX P-VALUE SET BY RLUXGO TO:',LUXLEV
      ENDIF
      IN24 = 0
      IF (INS .LT. 0)  WRITE (6,'(A)')
     +   ' Illegal initialization by RLUXGO, negative input seed'
      IF (INS .GT. 0)  THEN
        JSEED = INS
        WRITE(6,'(A,3I12)') ' RANLUX INITIALIZED BY RLUXGO FROM SEEDS',
     +      JSEED, K1,K2
      ELSE
        JSEED = JSDFLT
        WRITE(6,'(A)')' RANLUX INITIALIZED BY RLUXGO FROM DEFAULT SEED'
      ENDIF
      INSEED = JSEED
      NOTYET = .FALSE.
      TWOM24 = 1.
         DO 325 I= 1, 24
           TWOM24 = TWOM24 * 0.5
         K = JSEED/53668
         JSEED = 40014*(JSEED-K*53668) -K*12211
         IF (JSEED .LT. 0)  JSEED = JSEED+ICONS
         ISEEDS(I) = MOD(JSEED,ITWO24)
  325    CONTINUE
      TWOM12 = TWOM24 * 4096.
         DO 350 I= 1,24
         SEEDS(I) = REAL(ISEEDS(I))*TWOM24
         NEXT(I) = I-1
  350    CONTINUE
      NEXT(1) = 24
      I24 = 24
      J24 = 10
      CARRY = 0.
      IF (SEEDS(24) .EQ. 0.) CARRY = TWOM24
C        If restarting at a break point, skip K1 + IGIGA*K2
C        Note that this is the number of numbers delivered to
C        the user PLUS the number skipped (if luxury .GT. 0).
      KOUNT = K1
      MKOUNT = K2
      IF (K1+K2 .NE. 0)  THEN
        DO 500 IOUTER= 1, K2+1
          INNER = IGIGA
          IF (IOUTER .EQ. K2+1)  INNER = K1
          DO 450 ISK= 1, INNER
            UNI = SEEDS(J24) - SEEDS(I24) - CARRY
            IF (UNI .LT. 0.)  THEN
               UNI = UNI + 1.0
               CARRY = TWOM24
            ELSE
               CARRY = 0.
            ENDIF
            SEEDS(I24) = UNI
            I24 = NEXT(I24)
            J24 = NEXT(J24)
  450     CONTINUE
  500   CONTINUE
C         Get the right value of IN24 by direct calculation
        IN24 = MOD(KOUNT, NSKIP+24)
        IF (MKOUNT .GT. 0)  THEN
           IZIP = MOD(IGIGA, NSKIP+24)
           IZIP2 = MKOUNT*IZIP + IN24
           IN24 = MOD(IZIP2, NSKIP+24)
        ENDIF
C       Now IN24 had better be between zero and 23 inclusive
        IF (IN24 .GT. 23) THEN
           WRITE (6,'(A/A,3I11,A,I5)')
     +    '  Error in RESTARTING with RLUXGO:','  The values', INS,
     +     K1, K2, ' cannot occur at luxury level', LUXLEV
           IN24 = 0
        ENDIF
      ENDIF
      RETURN
      END
************************************************************************
*                                                                      *
* CERNlib, V116, MATHLIB, RM48: eneration of double precision          *
* (real*8) random number                                               *
*                                                                      *
* Located: cernlib\mathlib32_src\mathlib\gen\v\rm48.f                  *
*                                                                      *
************************************************************************
*
* $Id: rm48.F,v 1.2 1996/12/12 16:32:06 cernlib Exp $
*
* $Log: rm48.F,v $
* Revision 1.2  1996/12/12 16:32:06  cernlib
* Variables ONE and ZERO added to SAVE statement, courtesy R.Veenhof
*
* Revision 1.1.1.1  1996/04/01 15:02:55  mclareni
* Mathlib gen
*
*
      SUBROUTINE RM48(RVEC,LENV)
C     Double-precision version of
C Universal random number generator proposed by Marsaglia and Zaman
C in report FSU-SCRI-87-50
C        based on RANMAR, modified by F. James, to generate vectors
C        of pseudorandom numbers RVEC of length LENV, where the numbers
C        in RVEC are numbers with at least 48-bit mantissas.
C   Input and output entry points: RM48IN, RM48UT.
C!!! ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C!!!  Calling sequences for RM48:                                    ++
C!!!      CALL RM48 (RVEC, LEN)     returns a vector RVEC of LEN     ++
C!!!                   64-bit random floating point numbers between  ++
C!!!                   zero and one.                                 ++
C!!!      CALL RM48IN(I1,N1,N2)   initializes the generator from one ++
C!!!                   64-bit integer I1, and number counts N1,N2    ++
C!!!                  (for initializing, set N1=N2=0, but to restart ++
C!!!                    a previously generated sequence, use values  ++
C!!!                    output by RM48UT)                            ++
C!!!      CALL RM48UT(I1,N1,N2)   outputs the value of the original  ++
C!!!                  seed and the two number counts, to be used     ++
C!!!                  for restarting by initializing to I1 and       ++
C!!!                  skipping N2*100000000+N1 numbers.              ++
C!!! ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C for 32-bit machines, use IMPLICIT DOUBLE PRECISION
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DIMENSION RVEC(*)
      COMMON/R48ST1/U(97),C,I97,J97
      PARAMETER (MODCNS=1000000000)
      SAVE CD, CM, TWOM24, NTOT, NTOT2, IJKL,TWOM49, ONE, ZERO
      DATA NTOT,NTOT2,IJKL/-1,0,0/
C
      IF (NTOT .GE. 0)  GO TO 50
C
C        Default initialization. User has called RM48 without RM48IN.
      IJKL = 54217137
      NTOT = 0
      NTOT2 = 0
      KALLED = 0
      GO TO 1
C
      ENTRY      RM48IN(IJKLIN, NTOTIN,NTOT2N)
C         Initializing routine for RM48, may be called before
C         generating pseudorandom numbers with RM48.   The input
C         values should be in the ranges:  0<=IJKLIN<=900 OOO OOO
C                                          0<=NTOTIN<=999 999 999
C                                          0<=NTOT2N<<999 999 999!
C To get the standard values in Marsaglia's paper, IJKLIN=54217137
C                                            NTOTIN,NTOT2N=0
      IJKL = IJKLIN
      NTOT = MAX(NTOTIN,0)
      NTOT2= MAX(NTOT2N,0)
      KALLED = 1
C          always come here to initialize
    1 CONTINUE
      IJ = IJKL/30082
      KL = IJKL - 30082*IJ
      I = MOD(IJ/177, 177) + 2
      J = MOD(IJ, 177)     + 2
      K = MOD(KL/169, 178) + 1
      L = MOD(KL, 169)
      WRITE(6,'(A,I10,2X,2I10)') ' RM48 INITIALIZED:',IJKL,NTOT,NTOT2
CCC      PRINT '(A,4I10)', '   I,J,K,L= ',I,J,K,L
      ONE = 1.
      HALF = 0.5
      ZERO = 0.
      DO 2 II= 1, 97
      S = 0.
      T = HALF
      DO 3 JJ= 1, 48
         M = MOD(MOD(I*J,179)*K, 179)
         I = J
         J = K
         K = M
         L = MOD(53*L+1, 169)
         IF (MOD(L*M,64) .GE. 32)  S = S+T
    3    T = HALF*T
    2 U(II) = S
      TWOM49 = T
      TWOM24 = ONE
      DO 4 I24= 1, 24
    4 TWOM24 = HALF*TWOM24
      C  =   362436.*TWOM24
      CD =  7654321.*TWOM24
      CM = 16777213.*TWOM24
      I97 = 97
      J97 = 33
C       Complete initialization by skipping
C            (NTOT2*MODCNS + NTOT) random numbers
      DO 45 LOOP2= 1, NTOT2+1
      NOW = MODCNS
      IF (LOOP2 .EQ. NTOT2+1)  NOW=NTOT
      IF (NOW .GT. 0)  THEN
      WRITE(6,'(A,I15)') ' RM48IN SKIPPING OVER ',NOW
          DO 40 IDUM = 1, NTOT
          UNI = U(I97)-U(J97)
          IF (UNI .LT. ZERO)  UNI=UNI+ONE
          U(I97) = UNI
          I97 = I97-1
          IF (I97 .EQ. 0)  I97=97
          J97 = J97-1
          IF (J97 .EQ. 0)  J97=97
          C = C - CD
          IF (C .LT. ZERO)  C=C+CM
   40     CONTINUE
      ENDIF
   45 CONTINUE
      IF (KALLED .EQ. 1)  RETURN
C
C          Normal entry to generate LENV random numbers
   50 CONTINUE
      DO 100 IVEC= 1, LENV
      UNI = U(I97)-U(J97)
      IF (UNI .LT. ZERO)  UNI=UNI+ONE
      U(I97) = UNI
      I97 = I97-1
      IF (I97 .EQ. 0)  I97=97
      J97 = J97-1
      IF (J97 .EQ. 0)  J97=97
      C = C - CD
      IF (C .LT. ZERO)  C=C+CM
      UNI = UNI-C
      IF (UNI .LT. ZERO) UNI=UNI+ONE
      RVEC(IVEC) = UNI
C             Replace exact zeros by 2**-49
         IF (UNI .EQ. ZERO)  THEN
            RVEC(IVEC) = TWOM49
         ENDIF
  100 CONTINUE
      NTOT = NTOT + LENV
         IF (NTOT .GE. MODCNS)  THEN
         NTOT2 = NTOT2 + 1
         NTOT = NTOT - MODCNS
         ENDIF
      RETURN
C           Entry to output current status
      ENTRY RM48UT(IJKLUT,NTOTUT,NTOT2T)
      IJKLUT = IJKL
      NTOTUT = NTOT
      NTOT2T = NTOT2
      RETURN
      END
************************************************************************
*                                                                      *
* CERNlib, M103 KERNLIB, FLPSOR: sorts array by acscending order into  *
* itself                                                               *
*                                                                      *
* Located: 2006/src/packlib/kernlib/kerngen/tcgen/flpsor.F             *
*                                                                      *
************************************************************************
*
* $Id: flpsor.F,v 1.1.1.1 1996/02/15 17:49:44 mclareni Exp $
*
* $Log: flpsor.F,v $
* Revision 1.1.1.1  1996/02/15 17:49:44  mclareni
* Kernlib
*
ccccc commented by ISOKALSKI    #include "kerngen/pilot.h"
      SUBROUTINE FLPSOR(A,N)
C
C CERN PROGLIB# M103              .VERSION KERNFOR  3.15  820113
C ORIG. 29/04/78
C
C   SORT THE ONE-DIMENSIONAL FLOATING POINT ARRAY A(1),...,A(N) BY
C   INCREASING VALUES
C
C-    PROGRAM  M103  TAKEN FROM CERN PROGRAM LIBRARY,  29-APR-78
C
      DIMENSION A(N)
ccccc commented by ISOKALSKI      COMMON /SLATE/ LT(20),RT(20)
ccccc commented by ISOKALSKI      INTEGER R,RT
cccccccccccccccccccccccccccccccccccccccccccccccc INSERTED BY I.SOKALSKI:
      INTEGER R, RT(20), LT(20)
C
      LEVEL=1
      LT(1)=1
      RT(1)=N
   10 L=LT(LEVEL)
      R=RT(LEVEL)
      LEVEL=LEVEL-1
   20 IF(R.GT.L) GO TO 200
      IF(LEVEL) 50,50,10
C
C   SUBDIVIDE THE INTERVAL L,R
C     L : LOWER LIMIT OF THE INTERVAL (INPUT)
C     R : UPPER LIMIT OF THE INTERVAL (INPUT)
C     J : UPPER LIMIT OF LOWER SUB-INTERVAL (OUTPUT)
C     I : LOWER LIMIT OF UPPER SUB-INTERVAL (OUTPUT)
C
  200 I=L
      J=R
      M=(L+R)/2
      X=A(M)
  220 IF(A(I).GE.X) GO TO 230
      I=I+1
      GO TO 220
  230 IF(A(J).LE.X) GO TO 231
      J=J-1
      GO TO 230
C
  231 IF(I.GT.J) GO TO 232
      W=A(I)
      A(I)=A(J)
      A(J)=W
      I=I+1
      J=J-1
      IF(I.LE.J) GO TO 220
C
  232 LEVEL=LEVEL+1
      IF((R-I).GE.(J-L)) GO TO 30
      LT(LEVEL)=L
      RT(LEVEL)=J
      L=I
      GO TO 20
   30 LT(LEVEL)=I
      RT(LEVEL)=R
      R=J
      GO TO 20
   50 RETURN
      END
************************************************************************
*                                                                      *
* CERNlib, Y201 KERNLIB, IUCHAN: to find a histogram channel           *
*                                                                      *
* Located: 2006/src/packlib/kernlib/kerngen/tcgen/iuchan.F             *
*                                                                      *
************************************************************************
*
* $Id: iuchan.F,v 1.1.1.1 1996/02/15 17:49:48 mclareni Exp $
*
* $Log: iuchan.F,v $
* Revision 1.1.1.1  1996/02/15 17:49:48  mclareni
* Kernlib
*
*
ccccc commented by ISOKALSKI    #include "kerngen/pilot.h"
      FUNCTION IUCHAN (X,XL,DX,NX)
C
C CERN PROGLIB# Y201    IUCHAN          .VERSION KERNFOR  3.15  820113
C ORIG. 01/01/66 JZ
C
ccccc commented by ISOKALSKI    #if defined(CERNLIB_B36M)
ccccc commented by ISOKALSKI     AN= (X-XL)/DX + 1.000001
ccccc commented by ISOKALSKI    #endif
ccccc commented by ISOKALSKI    #if !defined(CERNLIB_B36M)
      AN= (X-XL)/DX + 1.00001
ccccc commented by ISOKALSKI    #endif
      AN= MAX(AN,0.)
      AN= MIN(AN, FLOAT(NX+1))
      N=AN
      IF (N.LT.0) N=NX+1
      IUCHAN=N
      RETURN
      END
************************************************************************
*                                                                      *
* CERNlib, C332 MATHLIB, DDILOG: calculate the dilogarithm function    *
*                                (double precision - real*8)           *
*                                                                      *
* Located:  cernlib\mathlib32_src\mathlib\gen\c\dilog64.f              *
*                                                                      *
************************************************************************
*
* $Id: dilog64.F,v 1.1.1.1 1996/04/01 15:02:05 mclareni Exp $
*
* $Log: dilog64.F,v $
* Revision 1.1.1.1  1996/04/01 15:02:05  mclareni
* Mathlib gen
*
      FUNCTION DDILOG(X)
*
* $Id: imp64.inc,v 1.1.1.1 1996/04/01 15:02:59 mclareni Exp $
*
* $Log: imp64.inc,v $
* Revision 1.1.1.1  1996/04/01 15:02:59  mclareni
* Mathlib gen
*
* imp64.inc
*
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DIMENSION C(0:19)
      PARAMETER (Z1 = 1, HF = Z1/2)
      PARAMETER (PI = 3.14159 26535 89793 24D0)
      PARAMETER (PI3 = PI**2/3, PI6 = PI**2/6, PI12 = PI**2/12)
      DATA C( 0) / 0.42996 69356 08136 97D0/
      DATA C( 1) / 0.40975 98753 30771 05D0/
      DATA C( 2) /-0.01858 84366 50145 92D0/
      DATA C( 3) / 0.00145 75108 40622 68D0/
      DATA C( 4) /-0.00014 30418 44423 40D0/
      DATA C( 5) / 0.00001 58841 55418 80D0/
      DATA C( 6) /-0.00000 19078 49593 87D0/
      DATA C( 7) / 0.00000 02419 51808 54D0/
      DATA C( 8) /-0.00000 00319 33412 74D0/
      DATA C( 9) / 0.00000 00043 45450 63D0/
      DATA C(10) /-0.00000 00006 05784 80D0/
      DATA C(11) / 0.00000 00000 86120 98D0/
      DATA C(12) /-0.00000 00000 12443 32D0/
      DATA C(13) / 0.00000 00000 01822 56D0/
      DATA C(14) /-0.00000 00000 00270 07D0/
      DATA C(15) / 0.00000 00000 00040 42D0/
      DATA C(16) /-0.00000 00000 00006 10D0/
      DATA C(17) / 0.00000 00000 00000 93D0/
      DATA C(18) /-0.00000 00000 00000 14D0/
      DATA C(19) /+0.00000 00000 00000 02D0/
      IF(X .EQ. 1) THEN
       H=PI6
      ELSEIF(X .EQ. -1) THEN
       H=-PI12
      ELSE
       T=-X
       IF(T .LE. -2) THEN
        Y=-1/(1+T)
        S=1
        A=-PI3+HF*(LOG(-T)**2-LOG(1+1/T)**2)
       ELSEIF(T .LT. -1) THEN
        Y=-1-T
        S=-1
        A=LOG(-T)
        A=-PI6+A*(A+LOG(1+1/T))
       ELSE IF(T .LE. -HF) THEN
        Y=-(1+T)/T
        S=1
        A=LOG(-T)
        A=-PI6+A*(-HF*A+LOG(1+T))
       ELSE IF(T .LT. 0) THEN
        Y=-T/(1+T)
        S=-1
        A=HF*LOG(1+T)**2
       ELSE IF(T .LE. 1) THEN
        Y=T
        S=1
        A=0
       ELSE
        Y=1/T
        S=-1
        A=PI6+HF*LOG(T)**2
       ENDIF
       H=Y+Y-1
       ALFA=H+H
       B1=0
       B2=0
       DO 1 I = 19,0,-1
       B0=C(I)+ALFA*B1-B2
       B2=B1
    1  B1=B0
       H=-(S*(B0-H*B2)+A)
      ENDIF
      DDILOG=H
      RETURN
      END
************************************************************************
*                                                                      *
* CERNlib, G100 MATHLIB, PROB: Upper Tail Probability of Chi-Squared   *
*                              Distribution                            *
*                                                                      *
* Located: cernlib\mathlib32_src\mathlib\gen\g\prob.f                  *
*                                                                      *
************************************************************************
*
* $Id: prob.F,v 1.1.1.1 1996/04/01 15:02:41 mclareni Exp $
*
* $Log: prob.F,v $
* Revision 1.1.1.1  1996/04/01 15:02:41  mclareni
* Mathlib gen
*
      FUNCTION PROB(X,N)
*
* $Id: imp64.inc,v 1.1.1.1 1996/04/01 15:02:59 mclareni Exp $
*
* $Log: imp64.inc,v $
* Revision 1.1.1.1  1996/04/01 15:02:59  mclareni
* Mathlib gen
*
* imp64.inc
*
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      REAL PROB,X
ccccccccccccccccccccccccccccccccccccccccccccccccccc ADDED BY I/SOKALSKI:
      INTEGER N
      EXTERNAL DERF
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      CHARACTER NAME*(*)
      CHARACTER*80 ERRTXT
      PARAMETER (NAME = 'PROB')
      PARAMETER (R1 = 1, HF = R1/2, TH = R1/3, F1 = 2*R1/9)
      PARAMETER (C1 = 1.12837 91670 95513D0)
      PARAMETER (NMAX = 300)
*                maximum chi2 per df for df >= 2., if chi2/df > chipdf prob=0.
      PARAMETER (CHIPDF = 100.)
      PARAMETER (XMAX = 174.673, XMAX2 = 2*XMAX)
      PARAMETER (XLIM = 24.)
      PARAMETER (EPS = 1D-30)
      GERFC(V)=DERFC(V)

      Y=X
      U=HF*Y
      IF(N .LE. 0) THEN
       H=0
cccccccc commented by Sokalski       WRITE(ERRTXT,101) N
cccccccc commented by Sokalski       CALL MTLPRT(NAME,'G100.1',ERRTXT)
cccccccc ADDED BY SOKALSKI:
       write(*,101) N
      ELSEIF(Y .LT. 0) THEN
       H=0
cccccccc commented by Sokalski        WRITE(ERRTXT,102) X
cccccccc commented by Sokalski       CALL MTLPRT(NAME,'G100.2',ERRTXT)
cccccccc ADDED BY SOKALSKI:
      ELSEIF(Y .EQ. 0 .OR. N/20 .GT. Y) THEN
       H=1
      ELSEIF(N .EQ. 1) THEN
       W=SQRT(U)
       IF(W .LT. XLIM) THEN
        H=GERFC(W)
       ELSE
        H=0
       ENDIF
      ELSEIF(N .GT. NMAX) THEN
       S=R1/N
       T=F1*S
       W=((Y*S)**TH-(1-T))/SQRT(2*T)
       IF(W .LT. -XLIM) THEN
        H=1
       ELSEIF(W .LT. XLIM) THEN
        H=HF*GERFC(W)
       ELSE
        H=0
       ENDIF
      ELSE
       M=N/2
       IF(U .LT. XMAX2 .AND. (Y/N).LE.CHIPDF ) THEN
        S=EXP(-HF*U)
        T=S
        E=S
        IF(2*M .EQ. N) THEN
         FI=0
         DO 1 I = 1,M-1
         FI=FI+1
         T=U*T/FI
    1    S=S+T
         H=S*E
        ELSE
         FI=1
         DO 2 I=1,M-1
         FI=FI+2
         T=T*Y/FI
    2    S=S+T
         W=SQRT(U)
         IF(W.LT.XLIM) THEN
          H=C1*W*S*E+GERFC(W)
         ELSE
          H=0.
         ENDIF
        ENDIF
       ELSE
        H=0
       ENDIF
      ENDIF
      IF ( H.GT. EPS ) THEN
         PROB=H
      ELSE
         PROB=0.
      ENDIF
      RETURN
  101 FORMAT('N = ',I6,' < 1')
  102 FORMAT('X = ',1P,E20.10,' < 0')
      END
************************************************************************
*                                                                      *
*    SUBROUTINE WAS WRITTEN BY IGOR SOKALSKI IN MAY 2020 TO REPLACE    *
*      ROUTINE ---DATIME--- (Z007, KERNLIB)  - JOB TIME AND DATE       *
*                         FROM THE CERN LIBRARY                        *
*                                                                      *
* Returns INTEGER ID=yymmdd and IH=hhmm. Also stores the components    *
* into /SLATE/ as small integers:                                      *
*                                   ISL(1) = 20yy   (year)             *
*                                   ISL(2) = mm     (month)            *
*                                   ISL(3) = dd     (day)              *
*                                   ISL(4) = hh     (hours)            *
*                                   ISL(5) = mm     (minutes)          *
*                                   ISL(6) = ss     (seconde)          *
*                                   ISL(7) = ms     (microseconds)     *
*                                                                      *
************************************************************************
*
      SUBROUTINE DATIME(ID,IH)
*
      integer ISL(40),ID,IH
      character(8)  :: date
      character(10) :: time
      character(5)  :: zone
      integer,dimension(8) :: values
*
      common /SLATE/ ISL
*
      ISL = 0
      call date_and_time(date,time,zone,values)
*
*                         YEAR:
      ISL(1) = values(1)
*                         MONTH:
      ISL(2) = values(2)
*                         DAY:
      ISL(3) = values(3)
*                         HOUR:
      ISL(4) = values(5)
*                         MINUTES:
      ISL(5) = values(6)
*                         SECONDS:
      ISL(6) = values(7)
*                         MILLISECONDS:
      ISL(7) = values(8)
*
      ID = (ISL(1)-2000)*10000 + ISL(2)*100 + ISL(3)
      IH = ISL(4)*100 + ISL(5)
*
      RETURN
      END SUBROUTINE
************************************************************************
*                                                                      *
*        TO REPLACE PART OF DATIME PACKAGE FROM CERNLIB LIBRARY        *
*                              (Z007, KERNLIB)                         *
*                                                                      *
* This routine initialises the timing operations. It must be called    *
* ONLY ONCE and  BEFORE any calls to TIMEX, TIMED and TIMEL (see       *
* below). Before this routine is called TIMEX, TIMED and TIMEL will    *
* return non correct values of output variables. TLIM is an input      *
* floating point real*4 value which will be used inside TIMEL as if it *
* were the job time-limit. The first call to TIMEST also establishes   *
* the time origin for subsequent calls to TIMEX, TIMED and TIMEL.      *
*                                                                      *
************************************************************************
*
      SUBROUTINE TIMEST(tlim)
*
      real*8 start_time_d, tlim_d
      real*4 start_time, tlim
      integer i_time_count
*
      common /dat_time/ start_time_d, tlim_d
      common /time_count/ i_time_count
*
      i_time_count = 1
      CALL cpu_time(start_time)
      start_time_d = dble(start_time)
      tlim_d = dble(tlim)
*
      RETURN
      END SUBROUTINE
************************************************************************
*                                                                      *
*        TO REPLACE PART OF DATIME PACKAGE FROM CERNLIB LIBRARY        *
*                              (Z007, KERNLIB)                         *
*                                                                      *
* The routine returns the execution time used by the job so far; TIME  *
* is the central processor time in seconds, a REAL*4 number. In        *
* supported interactive systems the time returned is that relative to  *
* the first call to TIMEST (see above).                                *
*                                                                      *
*                !!! ATTENTION!!! TIMEST must be called                *
*                   before first call to this routine                  *
*                                                                      *
************************************************************************
*
      SUBROUTINE TIMEX(time)
*
      real*8 start_time_d, tlim_d, current_time_d
      real*4 current_time,time
      common /dat_time/ start_time_d, tlim_d
*
      CALL cpu_time(current_time)
      current_time_d = dble(current_time)
      time = sngl(current_time_d - start_time_d)
*
      RETURN
      END SUBROUTINE
************************************************************************
*                                                                      *
*        TO REPLACE PART OF DATIME PACKAGE FROM CERNLIB LIBRARY        *
*                              (Z007, KERNLIB)                         *
*                                                                      *
* The routine returns the execution time interval since the last call  *
* to TIMED. TIME is expressed in seconds.                              *
*                                                                      *
*                !!! ATTENTION!!! TIMEST must be called                *
*                   before first call to this routine                  *
*                                                                      *
************************************************************************
*
      SUBROUTINE TIMED(time)
*
      real*8 current_time_d, current_time_last_d
      real*4 current_time,time
      integer i_time_count
      common  /timed_t/ current_time_last_d
      common /time_count/ i_time_count
*
      CALL cpu_time(current_time)
      current_time_d = dble(current_time)
      if (i_time_count.eq.1) then
         time = 0.e+0
      else
         time = sngl(current_time_d - current_time_last_d)
      endif
      current_time_last_d = current_time_d
      i_time_count = i_time_count + 1
*
      RETURN
      END SUBROUTINE
************************************************************************
*                                                                      *
*        TO REPLACE PART OF DATIME PACKAGE FROM CERNLIB LIBRARY        *
*                              (Z007, KERNLIB)                         *
*                                                                      *
* The returns the execution time remaining until time-limit; TIME_LEFT *
* in seconds. In supported interactive systems the time returned is    *
* the time left until the time-limit set by the first call to TIMEST   *
* (see above).                                                         *
*                                                                      *
*                !!! ATTENTION!!! TIMEST must be called                *
*                   before first call to this routine                  *
*                                                                      *
************************************************************************
*
      SUBROUTINE TIMEL(time_left)
*
      real*8 start_time_d, tlim_d, time_passed_d
      real*4 time_passed,time_left
*
      common /dat_time/ start_time_d, tlim_d
*
      CALL TIMEX(time_passed)
      time_passed_d = time_passed
      time_left = sngl(tlim_d - time_passed_d)
*
      RETURN
      END SUBROUTINE
************************************************************************
