garfield/src/heed101garf.car

+TITLE.
HEED       1.01 /00  960118  00.00
*
* HEED, written by Igor Smirnov (St Petersburg) with an
* interface for use with Garfield.
*
+PATCH,*HEEDGARF.     Pilot patch
+USE,HEEDCOM.
+USE,HEEDINT.
+USE,HEEDSUB.
+USE,EHEED.
+PATCH,DOC,IF=DOC.
+DECK,DOC,IF=DOC.


            --------------------------------------------------
                HEED, an ionization loss simulation program                 
                           User's guide
                           Version 1.01 (preliminary)
            --------------------------------------------------

                       Igor Smirnov

                        06.02.97
        

                Introduction
                ------------


        The program HEED is intended for detailed calculations of the
ionization energy loss of fast charged particles in gases. The program
works for solids also, but with less accuracy.
        The program can also simulate the absorption of the photons in the
detector.
        The program can be applied to simulations of the detectors of the
high energy charged particles which register ionization produced by
particles in the gases.
        The algorithm is based on a Monte-Carlo simulation of the energy
transfers from the incident particle to atomic electrons. After knocking
out of a primary delta-electron a vacancy remains in the atomic shell. The
number of shell with vacancy and the type of atom in the gas mixture are
specified for every energy transfer.  It allows to calculate the
delta-electron energy and generate a cascade of secondary particles
emitted by the excited atom (the Auger electrons and the fluorescence
photons). The calculations include simulation of both absorption of them
in the matter and creation of conduction electrons. 

        The program is written in fortran-77. It is tested on several UNIX
platforms. 

        The program can be run as a stand-alone program and as subroutines
There are two variants: subroutine calculating an average ionization 
and a cluster-sizes distribution and subroutine for generation of the
track, i.e. electron positions. In the both subroutine-forms the program 
is restricted in choice of geometry and others. Interface to the subroutines 
is much simpler, therefore we begin from explanation of how to call them, all 
the following text being almost unnecessary for that users who exploit only 
the subroutines. The user's guide followes by two additional chapters 
expounding how to build the executable program from CMZ source text, 
and giving a test results. 

--------------------------------------------------------
                Copyright notice
                ----------------

Copyright Igor Smirnov, 1995, all rights reserved.

HEED, an ionization loss simulation program.

Copyright and any other appropriate legal protection of this computer
program and associated documentation reserved in all countries of the
world. 

This program or documentation may not be reproduced and/or redistributed
by any method without prior written consent of the author. 

Permission for the scientific usage of the program described herein is
granted apriori to all institution of Russian Academy of Scienses and to
those scientific institutes associated with the CERN experimental program
or with whom CERN has concluded a scientific collaboration agreement. 

Commercial utilisation requires explicit a priory permission from the author
and will be subjected to payment of a license fee.


------------------------------------------------------

        The author can not warrant correct functioning of any part of the
program, it is the duty of the user to check that the accuracy of the
results is adequate for his/her purposes.
        Any messages about errors, inaccuracies, and any other problems
are welcome.  Suggestions for improvement are welcome.
        Author are looking for any data on photoabsorption cross section,
especially for molecules and will be appreciate for sending him any such
data or references to them.
        Author greatly appreciate receiving a copy of any note or
publication for which this program has been used. 

Author's e-mails:

Igor.Smirnov@cern.ch  
ismirnov@hep486.pnpi.spb.ru

Igor Smirnov,
High Energy Physics Division, 
Petersburg Nuclear Physics Institute.
Gatchina, 188350
St.-Petersburg 
Russia


--------------------------------------------------------

                Installation and compilation of CMZ-version
                -------------------------------------------

        For CMZ the HEED program is placed into a car-file, 
a CMZ Ascii Readable file. For installation we recommend the following
sequence of steps. First run the CMZ. Then type the next commands:
create heed
import/arc heed.car
seq -O //heed/PROGRAM

        There are seven possible ways of using the program HEED.
1. Run it as a stand-alone program with users 
   subroutines IniHeed, UBegEvent, UEndEvent.
2. Run the example of stand-alone program HEED.
3. Calling the subroutine SHEED.
4. Run the program PSHEED which is designed as an example of call of SHEED
   and serves for testing of SHEED.
5. Calling the HEED from another user's program. The HEED is called as 
   subroutines
6. Run the program PEHEED which is designed as an example of call of HEED
   in the form of subroutines and serves for testing of HEED.
7. Somebody can want to extract text documentation.
To ensure this possibilities some of the decks were equipped with
select control options, which allow to extract, compile and link only that
decks which is relevant for given task without explicit enumerating of
their names. The next options have to be swiched on for each mentioned 
above case:
1. E
2. E,E1
3. SHEED
4. PSHEED, SHEED
5. EHEED
6. PEHEED, EHEED
7. DOC
This can be done by the command 
select option_name

        The compilation is executed by commands 
cc * 
,after that all the necessary object files are in a temporary file, 
and the link can be executed by usual command depening on operating system. 
For example, on our computer IBM RISC with operating system AIX
the temporary files is cmfor.f and cmfor.o, the program is linked by command
xlf -O -g -C -o HEED.e cmfor.o -L$CRNLIB  -lpacklib -lkernlib
where the environment variable CRNLIB points to libraries.
 

                Test results: average ionization loss
                -------------------------------------

        Although the calculation of mean ionization loss (KeV and number
of pairs) and number of clusters does not involve all the routines of this
package, it uses a range of very important routines, results are numbers
and all these numbers can be compared with another calculation and
experimental values. This allows partially to check the program both from
principal and from technical point of view.
        Below are the table listing for all predefined gases another
calculation by simular model [U.A.Budagov et al. Ionization effects in
high energy physics, Energoatomizdat, Moscow, 1988, Russian.](the first
line in each item), some experimental data (the second line in each item),
and our results (the third line in each item) calculated by subroutine
SHEED. The table illustrates the extent of exactness of the program and
can serve as a pattern of its results when testing proper execution of the
program on another computer. 

------------------------------------------
Molecule        dE/dx   Npairs  Nclusters
                (KeV)
------------------------------------------
He              0.322   7.6     3.3             calc. of U.A.Budagov et al
                -       -       3.57 - 5.02     experimental data
                0.2847  6.943   3.38            our calculation

Ne              1.452   39.9    10.9            so on
                -       -       11.7 - 12.4
                1.446   40.84   11.7

Ar              2.541   96.6    24.8
                -       -       22 - 28
                2.517   96.81   26.1

Kr              4.750   197.5   33.0
                -       -       34.65
                4.611   192.1   24.5

Xe              6.862   313.3   44.8
                -       -       48.41
                6.947   315.8   52.3

H2              0.342   9.4     4.7
                -       -       4.7
                0.3362  9.087   7.85

N2              2.097   60.5    20.8
                -       -       -
                2.004   57.25   27.4

O2              2.360   76.5    23.2
                -       -       -
                2.285   73.7    24.3

NH3             1.586   59.8    -
                -       -       -
                1.518   57.08   30.1

N2O             3.275   100.6   -
                -       -       -
                3.146   96.5    39.8

CO2             3.280   100.0   33.6
                -       -       33
                3.133   94.95   34.7

CF4             -       -       -
                -       -       51
                6.049   176.4   59.7

CH4             1.608   59.3    24.8
                -       -       25 - 26
                1.537   56.3    31.6

C2H2            2.339   90.8    31.5
                -       -       -
                2.046   79.3    33

C2H4            2.696   104.5   40.4
                -       -       -
                2.388   92.58   42.9

C2H6            2.870   117.7   40.5
                -       -       41 - 51
                2.731   109.2   53

C3H8            4.138   176.5   67.6
                -       -       63 - 74
                3.925   163.5   75

i-C4H10         5.402   232.8   83.6
                -       -       84 - 93
                5.119   218.8   96
----------------------------------------


                The subroutine SHEED
                --------------------

        The subroutine SHEED is created on the base of the program HEED
for solution of one particular but very important task: calculation of
cluster size distribution, and so as to do it in the form of a subroutine
calling from another program and receiving all the entering data in the
form of subroutine parameters.
        Therefore the main program MainHEED, and the subroutine IniHeed was
converted into the subroutine SHEED. There is no need for user to provide
any additional subroutines as it must be done in the case of standart
applications of program HEED.
        The form of calling is:
        call SHEED
     +  (qmol, nmol, wmol, pres, temp,
     +  tkener, mas, maxnum, soo, oo, debug,
     +  density,dedx, ntotal, nclust, clprob, ierror)

        Input parameters:
        integer qmol            ! Quantity of different molecules
                                ! in the gas mixture.
        integer nmol(pqMol)     ! Their numbers from molecules.inc.
                                ! Use only the named constants
                                ! for compartibility with future versions.
        real wmol(pqMol)        ! Their weights
                                ! (relative quantities of molecules).
        real pres               ! Pressure in Torr.
        real temp               ! Temperature in K.
        real tkener             ! Kinetic energy of incident particle (MeV)
        real mas                ! Mass of incident particle(MeV)
        integer maxnum          ! Maximum size of cluster(not used now).
        integer soo             ! Flag allowing to write.
        integer oo              ! Output stream number.
        integer debug           ! Flag allowing to write
                                ! more amount of information.

        Output parameters:
        real density            ! Density of the gas.
                                ! It calculates for ideal gas.
        real dedx               ! Mean dE/dx, mean energy loss, KeV/cm.
        real ntotal             ! Average  total number of 
                                ! liberated conduction electrons.
        real nclust             ! number of clusters per cm.
        real clprob(msize)      ! Probability of the clusters,
                                ! Size=index.
        integer ierror          ! Sign of error( 0 -- no error ).
         
        For pointing to molecules the user is suggested to use the named
constants (only in symbolic form) defined in the file molecules.inc The
named constant pqMol is defined into the file molecules.inc.
        The weights may not be nolmalized. The subroutine does this
itself. Some of the weights may be zero. The subroutine excludes such
items.
        If pres=0, the standart atmosferic pressure, 760 Torr is substituted.
        If temp=0, the standart atmosferic temperature, 293 K is substituted.
        If pmas=0, the proton mass, 938 MeV is substituted
        If tkener=0, the 'mip' is generated, gamma=4, tkener=pmas*3. 

        The named constant msize is defined into file hs.inc, now it is
10000, that is the maximum cluster size, for which the probability is
calculated. This is just a formal approach, in real life such a big cluster
either will be like to a big cloud of ionization, or to a track going to
outside of the gas volume. 
        The probabilities for the clusters up to 20 electrons are calculated
by method Monte-Carlo with 1000 events. The probabilities for more large
clusters is calculated by an analitical approach, taking into account only
the cross section of energy transfers and dividing the transferred energy
on the mean work per pair production. The mean energy loss and total
electron number are computed analitically from integral of cross section.
The number of clusters is restored from Monte-Carlo and it may be affected by
a little statistical fluctuations, as soon as probabilities of the first
20 clusters. Note, all of this is related only to SHEED subroutine, solving
the partial problem.
        The output parameter ierror is 1 if error is detected. All the
other output results is to be eliminated in this case. Any error messages
are printed to stream 'oo' regardless of value of the flag 'soo'. The
usual HEED listing is printed to the same stream provided that soo=1. A
little listing is printed if debug=0 or 1 and a very big listing useful
only for developers is printed if debug>=2.
        The subroutine can be called several times from one program.


                Calling HEED in the form of subroutines
                ---------------------------------------

        The program was developed for using as a stand-alone program. 
However, generating initial ionization it can not watch for its drift 
to electrodes, and it may be necessary to combine it with another 
chamber-simulation package. There are three ways of doing this: 
to link a drift-simulation subroutine to HEED, 
to link the HEED in the form of subroutines to a drift-simulation program, 
or to connect two separate programs through intermediate file or stream.
The first and the last way are opened for user, while the second requires
some little changes in the program. Moreover, the process of initialization
may seem not enough simple for a user who wants to solve a simplest task with
one-layer geometry. To make the second way available and simple we 
developed some interface subroutines, which get all setup information as
simple parameters. The generated ionization can be taken from well 
discribed common blocks.
        Unfortunately, it is difficult to return the output information 
through the parameters, becouse of large amount of it. 
The user has to extract what he needs from common blocks. 
Therefore he may need to get familiar with the following general manual. 
        Only one gas can be initialized when using HEED by this way.
        The work is naturally divided into initialization stage and event
processing stage. So as to reduce the number of the parameters of the
initializating subroutine, we split the subroutine into several ones.

        Initialization of the matter:
        call IMHEED
     +  (qmol, nmol, wmol, pres, temp, soo, oo, debug,
     +  density, ierror)
All these parameters have the same type and sense as for SHEED:
        Input parameters:
        integer qmol            ! Quantity of different molecules
                                ! in the gas mixture.
        integer nmol(pqMol)     ! Their numbers from molecules.inc.
                                ! Use only the named constants
                                ! for compartibility with future versions.
        real wmol(pqMol)        ! Their weights
                                ! (relative quantities of molecules).
        real pres               ! Pressure in Torr.
        real temp               ! Temperature in K.
        integer soo             ! Flag allowing to write to stream oo.
        integer oo              ! Output stream number.
        integer debug           ! Flag allowing to write
                                ! more amount of information.

        Output parameters:
        real density            ! Density of the gas.
                                ! It calculates for ideal gas.
        integer ierror          ! Sign of error( 0 -- no error ).

        For pointing to molecules user is sugested to use the named
constants (only in symbolic form) defined in the file molecules.inc The
named constant pqMol is defined into the file molecules.inc.
        The weights may not be nolmalized. The subroutine does this
itself. Some of the weights may be zero. The subroutine excludes such
items.
        If pres=0, the standart atmosferic pressure, 760 Torr is substituted.
        If temp=0, the standart atmosferic temperature, 293 K is substituted.

         
        Initialization of the volume:
        It is doing by standart routines from HEED. User can build any number
of volumes, but since only one gas can be initalized, usually only
one volume can be necessary (there is no any restrictions in stand-alone
form). It is initialized by:
        call IniFVolume(0, 1, 1, 1, left_borber, width )
        where left_borber and widt are real amd measured in cm. 


        Initialization of the particle:
        call IPHEED
     +  (tkener, mas, debug,
     +  ierror)

        real tkener             ! Kinetic energy of incident particle (MeV)
        real mas                ! Mass of incident particle(MeV)
        If pmas=0, the proton mass, 938 MeV is substituted
        If tkener=0, the 'mip' is generated, gamma=4, tkener=pmas*3. 
        This subroutine defines the parameters of the particle which is
automatically generated later at the begin of simulation of each event.


        Initialization of the track:
        The track can be initialized by the program IniRTrack.
        call IniRTrack(ystart1, ystart2, pang, pphiang)
        real ystart1 and ystart2 - bounds of interval on y-axis,
                where the start point can be. The start point
                is randomly placed inside these bounds.
                They can be equal and the point will be fixed.
        real pang - theta angle between the traectory and the z - axis
        real pphiang - phi angle (turn around z-axis relativaly x-axis)
 The track can be initialised one or more times. The next track
initialization deletes the old track. 


        The output parameter ierror is 1 if error is detected. All the
other output results is to be eliminated in this case. Any error messages
are printed to stream 'oo' regardless of value of the flag 'soo'. The
usual HEED listing is printed to the same stream provided that soo=1. A
little listing is printed if debug=0 or 1 and a very big listing useful
only for developers is printed if debug>=2.
        The subroutines can be called several times from one program.

        The simulation of the events is done by 
        call GoEventn(nevt,qevt)        ! Simulation of one event
        Here nevt is number of the current event and qevt is the number
of the events ordered. In principal the standart GoEvent can be called,
if to include into user's program GoEvent.inc
The GoEvent must know the number of the current event
and the total ordered event number. If there was an overflow
of any controlled array - arrays with delta-electrons,
conduction electrons, real photons, virtual photons,
the GoEvent prints the wornings and auxiliary information
to the 'oo' after the last event generated. Therefore it must know which 
event is last. So as to avoid including of GoEvent.inc , 
where the event number nevt and quantity of events qevt are stored, 
user can call GoEventn ,that takes nevt and qevt as arguments and 
simulates ONE event.

        So as to reduce the required memory, it is sensible to
reduce the maximal numbers of volumes of every kind (see volume.inc)
to 1. To have a possibility to treat volume woth more width,
the number of the conduction electrons (pqcel in cel.inc) can be increased.
The major comsumer of the memory is cel.inc.

This is the end of the manual of calling of HEED in the form of subroutines.


                Geometry
                --------

        The detector is represented by a structure of geometrical volumes.
The volumes is filled with different materials. Each volume represents a
part of the detector. Having considered the practical applications we
formulated a simple geometrical model, ensuring simple and fast tracking.
The allowed geometrical configuration is a 3-dimensional space divided by
a parallel planes into a sequence of volumes. The widths and the number of
the volumes are arbitrary. Their dimensions along the planes are infinite.
The first and the last plane are the borders of the detector.
        For example, the detector may consist of one or several multiwire
proportional chambers with insensitive solid plates and a sensitive gas
between them.
        The coordinate system is oriented by such a way that z-axis is
perpendicular to the planes. Thus the volumes are considered to be
infinite along x- and y-directions.
        The angle between z-axis and the direction of moving of the
incident particle is denoted theta. The polar angle is measured relatively
x-axis (around z-axis) and denoted phi. The theta angle must be less than pi/2. The
phi-angle is arbitrary. Thus the incoming particle comes from z=-infinity
and traverses the layers consequently from left to right.
        The incident particle can move by a straight trajectory or by a
broken line determined by the multiple scattering. The photons (primary or
secondary) and all the secondary particles are thoroughly tracked through
the multi-layer structure. 


                Structure of the program
                ------------------------

        Logically, there are three phases of the algorithm:
    -Initialization
    -Event processing
    -Termination
        The initialization phase consists of computing and storing of some
auxiliary data, which are necessary during event processing. The source
text of the program does not imply a concrete geometry, materials and any
other conditions related to particular problems. These data must be
allocated in common blocks during the initialization phase. To do this the
program calls the subroutine IniHeed. This subroutine has to be provided
by the user. It has to consist of the following steps, most of them
performed through calls to another HEED subroutines: 
    - set general parameters
    - parameters for HBOOK
    - output
    - energy mesh
    - atoms
    - molecules
    - materials
    - incident particle
    - cross sections
    - track 
All the data recorded to the common blocks during this phase
are kept there till end of run.
        The processing of every event is also divided into three simular
phases: 
    - Event initialization
    - Event processing
    - Termination 
During the event initialisation phase the information
about the previous event is deleted and the memory is prepared to record
the new event. The standart event initialisation does not require user
interventions. For non-standart cases the subroutine UBegEvent is called
after the standart initialisation have been done.  This subroutine has to
be provided by the user. For example, it can initialize another user's
common blocks or generate an external photons or delta-electrons. For
trivial applications this subroutine may be empty. Having simulated each
event the program fills the predefined histograms and calls the subroutine
UEndEvent. This subroutine has to be provided by the user. Any treatment
of the information about the event can be carried out in it, all the
information being accessible here. The user defined histograms are to be
filled in this subroutine. For trivial applications this subroutine may
also be empty.
        During the program termination phase all the histograms are
written into disk file. 
        Thus, the user has to prepare 3 subroutines: IniHeed, UBegEvent,
UEndEvent. The last two ones may be empty.
        The program makes use two output streams and no input stream. The
text data, wornings, messages about errors and debug information are
directed to stream with logical number denoted 'oo', which has to be
determined by the user. There is possibility to ban all the output except
the messages about errors. Another output stream has the number 34 and it
is used only for saving of the histograms. This number is determined via
the parameter statament and it can be changed by the user. The filling and
saving of the histograms can be forbiden.
        In case of errors the program prints a message and either
continues working or stops through the STOP operator.
        The program is linked with the program libraries packlib and
kernlib.
        

                Allocation of data
                ------------------

        All the important information is stored in common blocks. Data
base systems are not used. Dimensions of arrays is usually specified as
named constants, i.e. by names which are given to constants by the
PARAMETER statements. In the case of problems the values of these
constants can be changed by the user.
        Each common block together with declarations of types of variables
is decribed in an only place. Before beginning of the compilation they
have to be included in the subroutines by a text processor. At the
developing phase, the INCLUDE compiler directive is used, it makes the
fortran compiler include the external file into the source text. This
directive is provided in majority of contemporary fortran compilers,
although it is not provided by the standart. The common blocks are placed
in separate files and included in relevant places of the text. To ensure a
maximum mobility, the program is converted into CMZ car-file, and in that
form it is presented for applications. The convertion is executed by
specially developed utulite, that provides copying every source file into
CMZ-deck with changing INCLUDE compiler directives to +SEQ
CMZ-directives and every included file is copying into a sequence. However
we continue to use the terms 'source file' and 'included file' in this
manual and in comments in program. Working with CMS-version it need to
remember that instead of included file, for example, 'myfilename.inc' one
should operate with sequence with the same, no more than 8-characters name
without extension '.inc': 'myfilena'. Analogously, 'myfilename.f' would
turn to deck 'myfilena'.
        The IMPLICIT NONE statament is used in every routine. The types of
names are determined explicitly. There are some rules we attempt to follow
choosing the names. Two of them need to be mentioned here, since they
differ from conventional ones and they are used throughout the program:
        -Variables with first character 'q' mean usially quantity(number)
of somethings and they are integer.
        -Variables with first characters 'pq' mean usially maximum allowed
quantity of something, they are names of integer constant, their values
are determined by the PARAMETER statements, they are usually used as the
dimensions of the arrays.
        The sense of common blocks variables and arrays is explaned in
comments placed near the type declarations. Values of all these variables
can be printed out in a readable form by special subroutines, each common
block being printed by separate subroutine. Also there are separate
subroutines for initialization of common blocks. 


                The Dimensional Units
                ---------------------

        Unless otherwise specified, the following units are used throughout 
the program:
        GRAMM, CENTIMETER, MEV, MEV/C, RADIAN, TORR, K 
 

                The included files
                ------------------
        
        The included files contain the text of the definitions of the
common blocks followed by the specifications of the types of the incoming
variables and the specifications of types and values of the named
constants. Usually all these variables are kept in one common block,
rarely in two, the named constants do not allocated in common blocks at
all. Since the common block names are not mentioned in the source text of
the program, they are only of technical importance (they must not coincide
one with another and so on). Therefore speaking about the common blocks we
will mean rather groups of defined in one include file variables and
constants, and we will denote them by the names of the included files,
where they are defined. If such a file is included in subroutine, all the
variables, arrays and constants discribed there become accessible, and no
matter where and how they are allocated.
        The following table contains the included file names and the their
destination. The character 'i' means that the contents are changed
(initialized) during initialisation phase. The character 'e' means that
the program recordes data there during the event processing. The character
'w' means that the user have to assing values to some variables from this
included file using the assignment statement (=). 

-----------------------------------------------------------------
The included files
-----------------------------------------------------------------
w i e r | GoEvent.inc   Main control variables                     
        | LibAtMat.inc  Numbers of atoms                            
    e   | abs.inc       Photons which is ready to absorb          
  i     | atoms.inc     Atomic data                               
  i e   | bdel.inc      information about delta electrons tracking  
        | cbdeldat.inc  fit of elastic electron cross sections
        | cconst.inc    world constants                                         
    e r | cel.inc       conduction electrons information
  i     | crosec.inc    cross sections of energy transfer of ionization loss
    e   | del.inc       delta-electrons information
  i     | ener.inc      energy mesh for ionization loss and photon absorbtion
w i     | hist.inc      histograms
    e   | lsgvga.inc    ionization energy transfers
        |               (used only for filling of histograms)
w i     | matters.inc   matters data
  i     | molecdef.inc  molecular information
      r | molecules.inc list of molecular numbers
  i   r | part.inc      primary particle data
    e   | raffle.inc    auxiliary common for the ionization loss simulation
w i e   | random.inc    auxiliary data for random number generator
    e   | rga.inc       real photons
  i     | shellfi.inc   auxiliary, for communication Iniatom with shellfi
  i     | shl.inc       shell information - probability of channels and
        |               energies of secondary particles
        |
  i     | tpasc.inc     auxiliary, for communication Iniatom with tpasc.f
  i e   | track.inc     primary particle track information
  i   r | volume.inc    information about volumes
------------------------------------------------------------------

        There are four included files with several variables needed to be
asigned and this required only at initialisation of the program. 

---------------------------------------------------------------------
GoEvent.inc:
        integer soo                ! Flag, allowing to print
                                   !  to stream 'oo'
                                   ! If it is 0, no print will be at all,
                                   ! except the case of serious problems.
        integer oo                 ! The output stream logical number. 
        integer qevt               ! Quantity of events to produce.
        integer ssimioni           ! Sign to simulate ionization loss,
                                   ! 0 - no ionization,
                                   ! 1 - normal ionization.

hist.inc:
        integer sHist              ! Sign to fill histograms
        character*100 HistFile     ! File name for file
                                   ! with histograms.
        real maxhisampl            ! maximum amplitude for histograms
        real maxhisampl2           ! reduced maximum amplitude for histograms
        real maxhisample           ! maximum amplitude for histograms
                                   ! in units of numbers of the electrons.
        integer pqhisampl          ! quantity for histograms with amplitude.
        integer shfillrang         ! sign to fill special histogram nh2_rd
                                   ! with practical range of delta electron
                                   ! It takes some computer time.
random.inc:
        integer sseed              ! Sign to start first event
                                   ! from seed point of random number generator.
        integer seed(2)            ! Form for writting and inputting
                                   ! without modification during
                                   ! binary to demical transformation.
matters.inc:
        real Cur_Pressure       ! Current pressure for initializing medium.
                                ! During gas initialization
                                ! subroutine gasdens uses it for
                                ! calculating of density.
        real Cur_Temper         ! Current temperature for initializing medium.
                                ! During gas initialization
                                ! subroutine gasdens uses it for
                                ! calculating of density.
-----------------------------------------------------------------------


All the other common blocks are filled automatically and allowed for
reading only. There are two reasons why user may need to be familiar with
them: 
    - to check the initialisation and working of the program
    - to obtain the results of calculations. 
However, so as to avoid updating the manual after each little 
modification in them, we do not want to include their listings into this 
manual so far. Users are invited to print the common blocks marked with 
character 'r' from his/her current version, they are of the first interest, 
all the variables being thoroughly explained in the comments. 


                Simplified Program Flow Chart
                -----------------------------

        program MainHEED

                call IniHeed            ! User's subroutine,
                                        ! initialization of the detector.

                do nevt=1,qevt          ! Loop over events.

                        call GoEvent    ! Simulation of one event.

                enddo

        end

        subroutine GoEvent

                call UBegEvent          ! User's subroutine.

                ...                     ! Simulation of event.

                call UEndEvent          ! User's subroutine,
                                        ! any treatment of 
                                        ! the event information.

        end
        
                
                The main program
                ----------------

------------------------------------------------------------------------
Listing  . The main program, file MainHEED.f
------------------------------------------------------------------------
 

        program HEED
c
c       The main program for HEED package
c
        implicit none

        integer NPW
        PARAMETER (NPW = 2000000)
        real H
        COMMON /PAWC/ H(NPW)

        include 'GoEvent.inc'
        include 'volume.inc'
        include 'hist.inc'


        CALL HLIMIT(NPW)

        call Iniranfl           ! Initialization of the counter of
                                ! random number generator calls
        call IniHeed            ! User's subroutine,
                                ! Initialization of the detector

        if(sHist.eq.1)then
                call IniHist    ! Initialization of inbilt histograms
        endif


        do nevt=1,qevt          ! Loop over events

                call GoEvent    ! Simulation of one event

        enddo


        if(sHist.eq.1)then
                call WHist      ! Writting of histograms
        endif


        call Priranfl           ! Print the number of calls of
                                ! random number generator
        end

-----------------------------------------------------------------------


                The event processor
                -------------------

-----------------------------------------------------------------------
Listing 2. The event processor, file GoEvent.f
-----------------------------------------------------------------------
 

        subroutine GoEvent
c
c       Event processor. It is called from MainHEED.
c
        implicit none

        include 'GoEvent.inc'
        include 'abs.inc'
        include 'rga.inc'
        include 'volume.inc'
        include 'hist.inc'
        include 'random.inc'

        integer iempty


c       if(nevt.le.ninfo)then
        if(soo.eq.1)then
        write(oo,*)
        write(oo,*)' Event number ',nevt
        endif
        if(nevt.eq.1.and.sseed.eq.1)then
                call randset            ! Set the start point of
        endif                           ! the random number generator.
        if(soo.eq.1)then
                call randget
                call randpri(oo)        ! Print the current point of
        endif                           ! the random number generator.
c       endif

        call IniNTrack                  ! Generate the next track.
        if(nevt.le.ninfo)then
                call PriMTrack(0)       ! Print debug information
                call PriMTrack(1)
                call PriMTrack(2)
                call PriMTrack(3)
                call PriMTrack(4)
        endif           

        call IniLsgvga                  ! Initialize gvga.inc
        call Iniabs                     ! Initialize abs.inc
        call Inirga                     ! Initialize rga.inc
        call Inidel                     ! Initialize del.inc
        call Inicel                     ! Initialize cel.inc

        call UBegEvent                  ! User's subroutine

        if(ssimioni.eq.1)call rafflev   ! Generate the primary energy transfers
                                        ! from incoming particle

        if(soo.eq.1)then
        if(nevt.le.ninfo)then
                write(oo,*)
                call PriLsgvga          ! Print debug information
        endif
        endif

        do iempty=1,10000

                if(soo.eq.1)then
                if(nevt.le.ninfo)then
                        write(oo,*)
                        write(oo,*)' before absorption of virtual photons:'     
                        call Priabs     ! Print debug information

                endif
                endif

                call AbsGam             ! Absorb the virtual photons

                if(soo.eq.1)then
                if(nevt.le.ninfo)then   ! Print debug information
                        write(oo,*)             
                        write(oo,*)' after absorption of virtual photons:'
         
c                       call Priabs
                        call Prirga
                        call Pridel

                endif
                endif
        
                call GoGam              ! Absorb the photons

                if(soo.eq.1)then
                if(nevt.le.ninfo)then   ! Print debug information
                        write(oo,*)
                        write(oo,*)' after absorption of photons:'

                        call Priabs
c                       call Prirga
                        call PrirgaF

                endif
                endif

                if(ctagam.gt.qtagam.and.crga.gt.qrga)then
                                        ! There are neither real no
                                        ! virtual photons to trace.
                        goto 50         ! Exit the loop.
                endif
        
        enddo

50      continue


        call treatdel                   ! Track the delta-electrons
                                        ! and generate the conduction electrons.
        call treatcel                   ! Treat the cel.inc
        if(soo.eq.1)then
        if(nevt.le.ninfo)then   ! since there are calculation of ranges
                                ! which in wroute to del inside treatdel
                write(oo,*)
                call Pridel
        endif
        endif

        if(sHist.eq.1)then
                call Fhist      ! Fill predetermined histograms
        endif

        call UEndEvent          ! User's subroutine

        if(soo.eq.1)then
        if(nevt.eq.qevt)then
                write(oo,*)
                write(oo,*)nevt,' events is done'
                                ! Printing the wornings about overful
                call WorPrirga
                call WorPriabs
                call WorPridel
                call WorPricel

        endif
        endif


        end
        

                Initialization
                --------------

        As was said above the duty to provide the initialization
subroutine is imposed upon the user. We can present here only an example
of such subroutine and we hope that it is enough clear for understanding
and the user will not meet troubles making use it as a 'fish' for
preparation of his own analogous subroutine. 

---------------------------------------------------------------------------
listing 1 Example of IniHeed
---------------------------------------------------------------------------
 

        subroutine IniHeed
c           
c

        implicit none

        include 'GoEvent.inc'
        include 'hist.inc'

        include 'ener.inc'
        include 'atoms.inc'
        include 'matters.inc'

        include 'cconst.inc'
        include 'volume.inc'
        include 'part.inc'
        include 'h31.inc'
        include 'random.inc'

        real tkener,mas,momentum

        integer i
        integer j


        real  wid   

        real amc
        integer na
        

        soo=1           ! To allow (1) or to ban (0) printing to stream oo.
        oo=10           ! set logical number of output stream.
        open(oo,FILE='heed.out') ! open output disk file.

        sret_err = 0    ! Stop if error is detected

c       Auxiliary variables for histograms (from hist.inc) 
        sHist=1         ! To allow (1) or to ban (0) dealing with histograms.
        HistFile='heed.hist'    ! File name, where they are written to.
        maxhisampl=40.0e-3      ! Maximum aplitude.
        maxhisampl2=20.0e-3     ! Reduced maximum aplitude.
        maxhisample=150         ! Maximum aplitude in unit of number of elect.
        pqhisampl=100           ! Number of bins.
        shfillrang=1    ! To allow (1) or to ban (0) filling histogram nh2_rd.


c       Random number genarator
        sseed=0         ! To make the generator start from seed point (1)
                        ! or from default point (0).
        seed(1)=1121517854      ! this is example for sseed=1
        seed(2)=612958528


        qevt=1000       ! Quantity of events to generate

        ssimioni=1      ! To allow ionization loss (1) or to ban it (0) 
        ninfo=0         ! Number of first events with output listing


        call Inishl                     ! Cascade from excited atom

        call IniEner(150,3e-6,0.2)      ! Energy mesh
c       call PriEner

        call AtomsByDefault             ! Library of atoms
c       call PriAtoms(0)

        Cur_Pressure=Atm_Pressure
        Cur_Temper=Atm_Temper

        call CO250CF420Ar30(1)          ! Material from LibAtMat

c       call PriMatter(0)

        wid=0.5


        call IniFVolume(1, 1, 1, 0, 0.0, wid  ) ! Volume

c       call PriVolume


        mas=105.0       !  muon 
        momentum=100000.0
        tkener=sqrt(mas*mas+momentum*momentum)-mas

        call IniPart(tkener,mas)        ! Particle
        call PriPart


        call IniRTrack(0.0, 0.0, 0.0, 0.0)      ! Track
        call PriTrack

        call IniCrosec                  ! Cross sections
c       call PriCrosec(1,4)


        call InisBdel                   ! Data for tracking of delta-electrons

        call PriBdel(0)


        end

---------------------------------------------------------------------------

        This example is so simple that subroutins UBegEvent and UEndEvent
do not need to do anything. They can be just empty. Therefore they are not
printed here.  The results of calculations are histograms contained in the
file 'heed.hist'. 
 

        The program is using some information about the secondary
radiation from exited atom. It is saved in the common block from "shl.inc".
This information has a difficulte structure, which is initialized by
special program "Inishl".  One should just call the subroutine "Inishl"
before any others. Users are strongly recommended to begin their
simulation with the parameters as stored by Inishl. Users who want to
modify any of these parameters must be sure they understand their function
in the program and the implications of a change. 


        The subroutine IniEne initializes the energy mesh for internal
calculations. It is used in calculations of ionization loss and photon
absorption. The points are equally spaced on a logarifmic scale.
        call IniEne(q,emin,emax)
        int q - quantity of the points. 100-200 is recomended.
        real emin - the minimum energy. It must be less than minimum for
                photo absorbtion cross section. 5 eV is recomended.
        real emax - the maximum energy. It must be several times more than
                maximum of the shell energies. 200 KeV is recomended.
This subroutine initializes the common block from file "ener.inc" .

Almost all the arrays with atomic, matters, cross-section information
corresponds to the centers of the energy intervals, each value being the
overage of a parameter on this interval. 


                Initialisation of the atoms
                ---------------------------

        The atomic information is allocated in the file atom.inc. The
atoms are assigned numbers. The numbers are indexes of array elements,
where the atomic information is saved. These numbers are used as the
pointers to the atoms throughout the program. The atoms can be initialized
in arbitrary order. The empty places are allowed. The program uses the
variable Zat (charge of atomic nucleus) as a sign of whethere the atom is
initialized, the atom being initialized if it is positive, nonzero. An
attempt to refere to an empty place or to initialize the atom twice
usually causes the program stop immediately, the error message being
printed. 
 

        There is a list of the predetermined atoms, it contains all the
most often used atoms, see LibAtMat.inc. It is initialized by
        call AtomsByDefault . 
If the necessary atom is not included in
this list, it need to increase parameter pQAt (atoms.inc) and initialize
the new atoms in free places, calling the subroutine IniAtom. (The IniAtom
knows the atom numbers from LibAtMat.inc and it carried out a special
algorithms for some of them. Thus, even if AtomsByDefault is not called,
the new atoms have to be initializaed on different places.) The subroutine
IniAtom initializes the atomic data.
        call IniAtom(num,z,a)
        int num - internal number of the atom. It can not be
                less than zero and larger than pQAt-maximun
                quantity of the atoms. 
                pQAt is set in  atoms.inc and can be changed.
                There are no possibility to define atom with
                the same number second time. The program terminates if
                one of these errors are occured. 
        int z - charge
        real a - atomic weight
 The information is writting to the 'atoms.inc'. Use subroutine PriAtoms
so as to print all the atoms to the standart unit 'oo'. 


                Initialisation of the materials
                --------------------------------

        The information about materials is allocated in the file
matters.inc. The matters are assigned numbers by the user. 
The numbers have the same meaning as the atom numbers. 
These numbers are used as the pointers to the matters throughout the program. 
The matters can be initialized in arbitrary order. 
The empty places are allowed. The program uses the variable QAtMat
as a sign of whethere the matter is initialized, the matter being
initialized if it is positive. An attempt to refere to an empty place or
to initialize the atom twice usually causes the program stop immediately,
the error message being printed. 

        There is a library of subroutines initializing various matters,
mainly gases. They are placed in the file LibAtMat.f. The only argument of
these subroutines is matter number. They use the atoms initialized by call
AtomsByDefault. 

        There is a special package intended for initialisation of an
arbitrary gas mixture. There are a list of predeterminated molecules in
file molecules.inc. This list will be increased in the future. The gas
mixture can be arbitrary mixture of these molecules. The subroutine
molecdef initializes these molecules. The information is allocated in
molecdef.inc and can be printed by call Primolec. The subroutine Inigas
initializes a gas mixture: 
        subroutine Inigas( nmat, qmol, nmol, pwmol, pres, temp)
        integer nmat            ! Number of material
        integer qmol            ! Quantity of different molecules
                                ! in the gas mixture.
        integer nmol(pqMol)     ! Their numbers in molecdef.inc
                                ! accordingly with molecules.inc
        real pwmol(pqMol)       ! Their weights
                                ! (relative quantities of molecules).
        real pres               ! Pressure in Torr.
        real temp               ! Temperature in K.


        Finnally there is a basical subroutine IniMatter, capable to
create any solid or gas.
        The subroutine IniMatter initializes the material.
        call IniMatter(num,Atom,Weight,q,dens)
        int num - internal number of the matter. It can not be
                less than zero and larger than pQMat-maximun
                quantity of the matters.
                pQMat is set in  matters.inc and can be changed.
                There are no possibility to define matter with
                the same number second time. The program terminates if
                one of these error are occured.         
        int Atom(*) - array of the atomic numbers(internal-see above).
        real Weight(*) - quantity of the atoms in the mixture.
                The sum may be not equal to one. 
        int q - quantity of atoms.
        real dens - density of the matter.
        The information is writting to the 'matters.inc'.
 Use subr. PriMatter so as to print all the matters to the standart unit
oo. The weights of atoms stored in matters.inc are corrected by the subr.
IniMatter so as their sum is equal to 1. 


        The function gasdens calculates the density of the gas. Pressure
and temperature is taken from variables Cur_Pressure and Cur_Temper placed
in matters.inc. The density is calculated by law of ideal gas.
        dens=gasdens(A,Weight,q)
        real dens - density in g/sm**3
        real A(*) - array of the molecular weights
        real Weight(*) - quantity of the molecules in the gase mixture
                The sum may be not equal to one.
        int q - quantity of the molecules


                Initialization of the Geometry
                ------------------------------

        The geometrical model and the coordinate system is defined in
section geometry at the begin of this document.
        The volumes is initialised consequently from right to left.
        There are three types of volumes here. There are two  keys
to define it, one combination is not allowed.
They are:
sSens - sign that it is sensitive volume i.e. proportional chamber.
sIon  - sign that the ionization loss must be here.
Some of these sorts of volumes could refer to 0 as number of the matter.
The following combinations are allowed:
    ---------------------------------
     matter number    sSens     sIon
    ---------------------------------
        0,any          0         0   
        not 0          0         1  
        not 0          1         1   
    ---------------------------------
 Ionization loss may not be calculated anywhere since it can be too long.
It is sensible to calculate them only in chamber gas and in special cases
in the poliethilene or mylar around it.  Zero matter number in all cases
except last means vacuum. Therefore ionization or sensitive volume can not
include vacuum. 

        The subroutine IniVolume initializes the first or the next volume
on the right of the previous. The next two subroutins are more convinient.
        call IniVolume(nmat,sSens,sIon,sTran,cwall1,cwall2,wide)
        int nmat - number of the material
        int sSens - sign of the sesitivity. 
        int sIon - sign of ionization loss.
        int sTran - sign of the transition radiator. Not using in LSG.
        real cwall1 - z-coordinate of the left side of the volume.
                It using only for the first volume.
        real cwall2 - z-coordinate of the right side of the volume.
        real wide - wide. Not using now.

        Initialization of the first volume:
        call IniFVolume(nmat,sSens,sIon,sTran,cwall1,wide)

        Initialization of the next volume:
        call IniNVolume(nmat,sSens,sIon,sTran,wide)
        
        The quantity of the volumes can't be more than pqvol - max.
quantity of the volumes.  pqvol is defined in volume.inc and can be
changed. All the volume parameters are saved in the volume.inc. You can
print all the volume parameters by the program PriVolume.
        The convinuent possibility to calculate of the total radiation
lenght is take a look into output listing. But for LST output must be done
after IniLst so as to take into account radiator. 


                Other Initializations
                ---------------------

        The particle is initialized by
        call IniPart(tkener,mas)
        real tkener - kinetic energy (MeV)
        real mas - mass (MeV)
Particle can be initialized one or more times. After each initialization 
the call IniCrosec is needed.   


        The calculations of the energy transfer cross sections are made by
subr. IniCrosec.
        call IniCrosec
 It calculates the cross section only for those matter, which are contined
in the sensitive volumes and only for initialized particle. If you
initialize the new particle you must call IniCrosec again. 


        The initializations of data for delta-electrons tracing must be
done by call InisBdel. 


        The track can be initialized by the program IniRTrack.
        call IniRTrack(ystart1, ystart2, pang, pphiang)
        real ystart1 and ystart2 - bounds of interval on y-axis,
                where the start point can be. The start point
                is randomly placed inside these bounds.
                They can be equal and the point will be fixed.
        real pang - theta angle between the traectory and the z - axis
        real pphiang - phi angle (turn around z-axis relativaly x-axis)
 The track can be initialised one or more times. The next track
initialization deletes the old track. Call IniCrosec is not need again.


                Initialization of the Histograms
                --------------------------------

        There are several predefined histograms, described in files
hist.inc and hist.f. They are treated automatically. The user program can
define and fill any additional histograms, calling relevant HBOOK
subroutines. 


                Random Numbers Generators
                -------------------------

        The only uniform random number generator is called throughout the
program: function ranfl. It is just intermediate function intended for
connection with one of the standart random number generators and allows to
change it in case of need. But one ought to be careful, the correlations
between the current and the next rundom numbers are found to worse the
results. To pass from current generator to another one it need only to
change the call of it inside the body of the function ranfl and to change
three auxiliary functions in the same file: 
 randset - set start point
 randget - get current point
 randpri - print current point.
        Since all the generators of the non-uniform numbers use uniform
random number generator as well, we extracted all the necessary routines
from CERNLIB and modified them inserting the call of ranfl: 
 lranor - random numbers following Gauss distribution
         (modified rannor) 
 lspois - Poisson distribution 
         (modified poissn),(also a little error is corrected)
 hisran - random numbers following histogram
         (the same name as in CERNLIB)
All of them is contined in file random.inc.
        Thus there is the only random number sequence used in all the
program. Therefore the program can repeat the simulations starting from
any event. For this purpose, at the begin of each event the program prints
the seed numbers. 


                Files With Text of Program
                --------------------------

  
PSHEED.f        # check of SHEED 
SHEED.f         # the main subroutine instead of program, 
                # cluster size distibution 
UEventS.f      # subroutine for SHEED   
MainHEED.f      # main program
GoEvent.f      # generate one event
IniHeed1.f     # users routine for setup initialization
UEvent1.f      # users routine for work with event      
IniEner.f      # energy net initialization
logscale.f     # function for logariphmic scale generation
Inishl.f       # atomic channels genaration
LibAtMat.f     # library of some atoms and matters
molecdef.f
Inigas.f
IniAtom.f      # atomic data initialization
tpasc.f
shellfi.f      # subroutines for atomic data files reading
line.f         # auxiliary functions for straight line integration
               # and steps integration
IniMatter.f    # matter data initialization
gasdens.f      # gas density calculation
IniVolume.f    # volumes initialization
IniTrack.f     # track initializatin
IniPart.f      # particle initialization
IniCrosec.f    # ionization cross section initialization
IniLsgvga.f    # common lsgvga.inc initialization
Inirga.f       # common rga.inc initialization
Iniabs.f       # common abs.inc initialization
raffle.f       # ionization loss generator, filling abs.inc and lsgvga.inc
GoGam.f        # photons tracing till absorbtion, fills abs.inc
AbsGam.f       # photons absorbtion, fills del.inc and rga.inc
IniBdel5.f      # common bdel.inc initialization
lstrel1.f
Inidel.f       # common del.inc initialization
treatdel.f     # treat delta-electrons and fill cel.inc
Inicel.f       # common cel.inc initialization
treatcel.f     # treat current electrons
SourcePhot.f   # auxiliary source of photons
SourceDelEl.f  # auxiliary source of delta-electrons
vectors.f      # vector algebra subroutins
random.f       # random number generators
hist.f         # histogram initialization and fill


+PATCH,HEEDCOM.
+KEEP,molecule.
        integer    pqMol           ! Quantity of sorts of molecules.
        parameter (pqMol=25)

        integer          numm_He
        parameter       (numm_He= 1)    

        integer          numm_Ne
        parameter       (numm_Ne= 2)    

        integer          numm_Ar
        parameter       (numm_Ar= 3)    

        integer          numm_Kr
        parameter       (numm_Kr= 4)    

        integer          numm_Xe
        parameter       (numm_Xe= 5)    

        integer          numm_H2
        parameter       (numm_H2= 6)    

        integer          numm_N2
        parameter       (numm_N2= 7)    

        integer          numm_O2
        parameter       (numm_O2= 8)    

        integer          numm_NH3
        parameter       (numm_NH3= 9)

        integer          numm_N2O
        parameter       (numm_N2O= 10)

        integer          numm_CO2
        parameter       (numm_CO2= 11)  

        integer          numm_CF4
        parameter       (numm_CF4= 12)  

        integer          numm_CH4
        parameter       (numm_CH4= 13)

        integer          numm_C2H2
        parameter       (numm_C2H2= 14)

        integer          numm_C2H4
        parameter       (numm_C2H4= 15)

        integer          numm_C2H6
        parameter       (numm_C2H6= 16)

        integer          numm_C3H8
        parameter       (numm_C3H8= 17)

        integer          numm_iC4H10
        parameter       (numm_iC4H10= 18)

        integer          numm_C                 ! for debug
        parameter       (numm_C = 19)
*** Additions (RV 4/9/98).
        integer          numm_DME
        parameter       (numm_DME= 20)

        integer          numm_H2O
        parameter       (numm_H2O= 21)
*** Additions (RV 20/9/99).
        integer          numm_SF6
        parameter       (numm_SF6= 22)

        integer          numm_C2F4H2
        parameter       (numm_C2F4H2= 23)

*** Addition (RV 14/1/00).
        integer          numm_C5H12
        parameter       (numm_C5H12= 24)

*** Addition (RV 25/2/00).
        integer          numm_C2F5H
        parameter       (numm_C2F5H= 25)
*** End of additions.

c       integer          numm_CClF3
c       parameter       (numm_CClF3= 19)

c       integer          numm_CClF2
c       parameter       (numm_CClF2= 20)

c       integer          numm_CBrF3
c       parameter       (numm_CBrF3= 21)

c       integer          numm_SF6
c       parameter       (numm_SF6= 22)
+KEEP,molecdef.
        integer pqSAtMol        ! Max. allowed quantity of sorts of atoms
                                ! in a molecule.
        parameter (pqSAtMol=3)
        integer qSAtMol         ! Quantity of sorts of atoms in a molecules.
        integer nAtMol          ! Number of atom in atoms.inc, 
                                ! see LibAtMat.inc.
        integer qAtMol          ! Quantity of atoms of given sort in molecule
        real weiMol             ! Molecular weight
        real WWWMol             ! Mean work for pair production
        real FFFMol             ! Parammeter Fano
        common / cmodef /
     +  qSAtMol(pqMol),
     +  nAtMol(pqSAtMol,pqMol),
     +  qAtMol(pqSAtMol,pqMol),
     +  weiMol(pqMol),
     +  WWWMol(pqMol),
     +  FFFMol(pqMol)
        save / cmodef /
+KEEP,hs.
        integer msize
        parameter (msize=10000)

        real prob,meanprob,meanvga,meanvgal
        real prob1
        integer qe
        common / h31 /
     +  prob(msize),meanprob,meanvga,meanvgal,
     +  prob1(msize)
+KEEP,GoEvent.
c      Main control variables
 
           
        integer soo                ! Flag, allowing to print
                                   !  to stream 'oo'
                                   ! If it is 0, no print will be at all,
                                   ! except the case of serious problems.
        integer oo                 ! The output stream logical number.
        integer qevt               ! Quantity of events to produce.
        integer nevt               ! Current number of the event. 
        integer ninfo              ! Quantity of the first events
                                   ! to print debug info.
        integer ssimioni           ! Flag to simulate ionization loss,
                                   ! 0 - no ionization,
                                   ! 1 - to simulate ionization.
                                   !
                                   !
                                   !
        integer srandoff           ! Flag to swich off the randomization
                                   ! in function treatdel.
                                   ! It is for debug and without guarantee.
        parameter (srandoff=0)     ! Normal regim with randommization.

        integer pqup               ! dimensions of arrays of auxiliary
                                   ! parameters in abs.inc, rga.inc, 
                                   ! del.inc
        parameter (pqup=1)


        integer sret_err        ! Sign to return the control from current
                ! subroutine to which is called it if error is occured.
                ! 1 - to return, 0 - to stop.
                ! It is intended for handling with subroutine SHEED.
                ! In the case of error it can return the control instead of 
                ! stop. But not for every possible errors return is done.
                ! Some of the most original errors could lead to stop.
                ! When working with HEED program, sret_err must be zero.
        integer s_err   ! Sign of error.
                ! 1 - error, 0 - no error

        character*9  TaskName      ! Name of task, using for generating
                                   ! file names.
        character*40 OutputFile    ! Name of file with output listing.
                                   ! Using only in IniHeed. 
        common / cGoEve /
     +  soo, oo,
     +  qevt,nevt,ninfo,
     +  ssimioni,
     +  sret_err, s_err,
     +  TaskName,
     +  OutputFile

        save / cGoEve /

+KEEP,ener.
c       Energy mesh

      integer pqener,qener      ! Max. quantity and quantity of bins.
                                ! Quantity must not be more than pqener - 1.
      PARAMETER (pqener=501)
      real ener,enerc           ! The left edges and the centers 
                                ! of the energy intervals.
                                ! ener(qener+1) is the right edge 
                                ! of the last interval.
C
      COMMON / coEner /
     +       qener, ener(pqener), enerc(pqener)
        save / coEner /
+KEEP,atoms.
 

        integer pQAt            ! Max. quantity of atoms.
        parameter (pQAt=19)
        integer KeyTeor         ! Key to use only theor. photo-absorbtion
                                ! cross section with thresholds and 
                                ! weights from the subroutine shteor. 
                                ! If 0 then they are used only for
                                ! the atoms which are absent  
                                ! in the subroutine readPas and  
                                ! in the subroutine shellfi.
        integer Zat             ! Atomic number (charge of atomic nucleus).
        real Aat                ! Atomic weight.
        integer pQShellAt       ! Max. quantity of atomic shells.
        parameter (pQShellAt=17)
        integer QShellAt        ! Quantity of atomic shells.
        real cphoAt             ! Integral of photo-absorbtion
                                ! cross secton for one atom.
        real    ThresholdAt     ! Threshold and
        real    WeightShAt      ! Weight of atomic shells for the
                                ! photo-absorbtion cross secton
                                ! relatively cphoAt.
        real PWeightShAt        ! Initial integral of 
                                ! photo-absorbtion cross secton.
        real  PhotAt            ! Photo-absorbtion cross secton.
        real  PhotIonAt         ! Photo-ionization cross secton.
c       The physical definition of two previous arrays of values:
c       mean values of cross sections for each energy interval.
        real  RLenAt            ! Radiation lengt*density for dens=1
        real  RuthAt            ! Const for Rutherford cross cection
                                ! (dimensionless).
c       integer num_at_mol      ! Number for atoms in several special
c                               ! molecules, now obsolete.
        real ISPhotBAt          ! Shell integral of cs before normalization
        real IAPhotBAt          ! Atomic integral of cs before normalization
        real ISPhotAt           ! Shell integral of cs
        real IAPhotAt           ! Atomic integral of cs
        real ISPhotIonAt        ! Shell integral of cs
        real IAPhotIonAt        ! Atomic integral of cs
        real MinThresholdAt     ! Minimal ionization potential of atom.
        integer NshMinThresholdAt ! Number of shell with minimal energy,
                        ! it must be the last shell ( see AbsGam.f)
        integer Min_ind_E_At, Max_ind_E_At ! Indexes of energy intervals
                        ! where program adds excitation to cs
                        ! They placed in common only to print and check.
        integer nseqAt  ! Sequensed pointer in order of increasing Zat
                        ! atom number nsAt(1) is least charged.
        integer QseqAt  ! Quantity of initialized atoms

        common / catoms /
     +          KeyTeor, 
     +          Zat(pQAt), Aat(pQAt),    
     +          QShellAt(pQAt), cphoAt(pQAt),
     +          ThresholdAt(pQShellAt,pQAt), WeightShAt(pQShellAt,pQAt),
     +          PWeightShAt(pQShellAt,pQAt),
     +          PhotAt(pqener,pQShellAt,pQAt),
     +          PhotIonAt(pqener,pQShellAt,pQAt),
     +          ISPhotBAt(pQShellAt,pQAt),
     +          IAPhotBAt(pQAt),
     +          ISPhotAt(pQShellAt,pQAt),
     +          IAPhotAt(pQAt),
     +          ISPhotIonAt(pQShellAt,pQAt),
     +          IAPhotIonAt(pQAt),
     +          MinThresholdAt(pQAt),
     +          NshMinThresholdAt(pQAt),
     +          Min_ind_E_At(pQAt), Max_ind_E_At(pQAt),
     +          RLenAt(pQAt),
     +          RuthAt(pQAt),
     +          nseqAt(pQAt),
     +          QseqAt
        save / catoms /
+KEEP,matters.
        integer pQMat           ! Max. quantity of matters.
        parameter (pQMat=10)
        integer QAtMat          ! Quantity of atoms in matter.
        integer AtMAt           ! Number of atom in matter 
                                ! (the pointer to atoms.inc).
        real WeightAtMat        ! Weight of atom in matter.
        real A_Mean             ! Average A.
        real Z_Mean             ! Average Z.
        real DensMat            ! Density (g/cm3).
        real DensMatDL          ! Density (g/cm3) for energy loss of deltaelect.
        real DensMatDS          ! Density (g/cm3) for mult. scat. of deltaelect.
        real ElDensMat          ! Electron density(MeV3).
        real XElDensMat         ! Longitud. Electron Dens. for x=1cm(MeV2/cm)
        real wplaMat            ! Plasm frequancy.
        real RLenMat            ! Radiation Lengt.
        real RuthMat            ! Const for Rutherford cross section (1/cm3).
        real PhotMat            ! Photoabsirbtion cross section per one atom.
        real PhotIonMat         ! Photoionization cross section per one atom.
        real epsip              ! plasm dielectric constant.
        real epsi1              ! real part of dielectric constant.
        real epsi2              ! imaginary part of dielectric constant.
        real min_ioniz_pot      ! Minimum ionization potential,
                                ! it is using only for switching off 
                                ! the Cherenkov radiation below it.
        real Atm_Pressure       ! Standart atmosferic pressure.
        parameter (Atm_Pressure=760.0)
        real Cur_Pressure       ! Current pressure for initialized medium.
                                ! During gas initialization
                                ! the subroutine gasdens uses it for
                                ! calculating of density.
        real Pressure           ! Pressure for given medium.    
        real Atm_Temper         ! Standart atmosferic temperature.
        parameter (Atm_Temper=293.0)
        real Cur_Temper         ! Current temperature for initialized medium.
                                ! During gas initialization
                                ! the subroutine gasdens uses it for
                                ! calculating of density.
        real Temper             ! Temperature for given medium. 
        real WWW                ! The mean work per pair production.
        real FFF                ! Fano parameter.
        common / cmatte /
     +          QAtMat(pQMat),
     +          AtMat(pQAt,pQMat),
     +          WeightAtMat(pQAt,pQMat),
     +          A_Mean(pQMat),Z_Mean(pQMat),
     +          DensMat(pQMat),ElDensMat(pQMat),XElDensMat(pQMat),
     +          DensMatDL(pQMat),DensMatDS(pQMat),
     +          wplaMat(pQMat),
     +          RLenMat(pQMat),
     +          RuthMat(pQMat),
     +          PhotMat(pqener,pQMat),
     +          PhotIonMat(pqener,pQMat),
     +          epsip(pqener,pQMat),
     +          epsi1(pqener,pQMat),
     +          epsi2(pqener,pQMat),
     +          min_ioniz_pot(pQMat),
     +          Cur_Pressure,Pressure(pQMat),
     +          Cur_Temper,Temper(pQMat),
     +          WWW(pQMat),FFF(pQMat)
        save / cmatte /
+KEEP,crosec.
        integer pQShellC        ! Max quantity of shells for all atoms
                                ! in one material 
        parameter (pQShellC=20)
c       integer MatC            ! Matter number
        integer sMatC           ! Sign to calculate sross section
                                ! for this matter
        integer QShellC         ! Quantity of shells for all atoms
                                ! in this matter
c       real ksi                ! Help Landau constant
c                               ! (it seems it is't used) 
        real log1C              ! first log
        real log2C              ! second log
        real chereC             
        real chereCangle
        real addaC              ! energy tranfer cross section
        real quanC              ! it's integral, 
                                ! or quantity of energy transfers,
                                ! or primary cluster number. 
        real meanC              ! first moment,
                                ! or restricted mean energy loss, Mev.
        real meanC1             ! first moment with whole additional tail
                                ! to emax - kinematically allowed transition.
                                ! Now it is calculated only for heavy particles
                                ! because the integral for electrons is not
                                ! trivial,
                                ! or mean energy loss, Mev.
        real meaneleC           ! expected restricted quantity of 
                                ! secondary ionization.
        real meaneleC1          ! expected quantity of secondary ionization.
        integer NAtMC           ! number of atom in the matter
                                ! for shell with corr. index
        integer NAtAC           ! number of atom
        integer NSheC           ! number of shell

        real flog1
        real flog2
        real cher
        real rezer
        real frezer
        real adda
        real fadda
        real quan
        real mean

        complex*16 pocaz        ! it is help 
                                ! coefficient at y
                                ! the value of imajinary part
                                ! corresponsd to with of wave front
        
        common / ccrosec /
     +  pocaz(pqener,pQMat),
     +  sMatC(pQMat),
     +  QShellC(pQMat),
c    +  ksi(pQMat),
     +  log1C(pqener,pQMat),
     +  log2C(pqener,pQMat),
     +  chereC(pqener,pQMat),
     +  chereCangle(pqener,pQMat),
     +  addaC(pqener,pQMat),
     +  quanC(pQMat),
     +  meanC(pQMat),
     +  meanC1(pQMat),
     +  meaneleC(pQMat),
     +  meaneleC1(pQMat),
c
     +  NAtMC(pQShellC,pQMat),
     +  NAtAC(pQShellC,pQMat),
     +  NSheC(pQShellC,pQMat),
c
     +  flog1(pqener,pQShellC,pQMat),
     +  flog2(pqener,pQShellC,pQMat),
     +  cher(pqener,pQShellC,pQMat),
     +  rezer(pqener,pQShellC,pQMat),
     +  frezer(pqener,pQShellC,pQMat),
     +  adda(pqener,pQShellC,pQMat),
     +  fadda(pqener,pQShellC,pQMat),
     +  quan(pQShellC,pQMat),
     +  mean(pQShellC,pQMat)
        save / ccrosec /
        
+KEEP,cconst.
        real*8 ELMAS            ! Electron mass (MeV)
        parameter (ELMAS=0.51099906)
        real*8 FSCON            ! Fine ctructure constant
        parameter (FSCON=137.0359895)
        real*8 ELRAD            ! Electron radius (1/MeV)
        parameter (ELRAD=1.0/(FSCON*ELMAS))
        real*8 PI               
        parameter (PI=3.14159265358979323846)
        real*8 PI2
        parameter (PI2=PI*PI)
        real*8 AVOGADRO
        parameter (AVOGADRO=6.0221367e23)
        real*8 PLANK            ! Plank constant (J*sec)
        parameter (PLANK=6.6260755e-34)
        real*8 ELCHARGE         ! Electron charge (C) 
        parameter (ELCHARGE=1.60217733e-19)
        real*8 CLIGHT           ! Light vel.(sm/sec)
        parameter (CLIGHT=2.99792458e10)
c       real pionener
c       parameter (pionener=0.000026)

+KEEP,volume.
c       descriptions of the geometry of the setup
 
        integer pqvol           ! Max. quantity of volumes
        parameter (pqvol=150)   
        integer pQSVol          ! Max. quantity of sensitive volumes
        parameter (pQSVol=130)
        integer pQIVol          ! Max. quantity of ionization volumes
        parameter (pQIVol=130)
        integer QSVol
        integer QIVol
        integer qvol            ! quantity of volumes
        integer upVol           ! user's volume parameter
        integer nMatVol         ! Material number for volume
        integer sSensit         ! Sign of sensitivity
        integer sIonizat        ! Sign of ionization
        real*8 wall1,wall2,wide ! Left, right side and wide of volume
        integer numSensVol,numVolSens   ! pass from Volume number
                                        ! to Sensitive volume number
        integer numIoniVol,numVolIoni   ! The same for ionization
        real RLenRVol, RLenRAVol        ! Radiation lengt for each volumes
                                        ! and for whole detector.
        integer xxxVol          ! dummy, for efficient alignment
        common / cvolum /
     +          qvol, 
     +          QSVol,QIVol, xxxVol,
     +          upVol(pqvol), nMatVol(pqvol), sSensit(pqvol),
     +          sIonizat(pqvol),
     +          wall1(pqvol),wall2(pqvol),wide(pqvol),
     +          numSensVol(pqvol),numVolSens(pQSVol),
     +          numIoniVol(pqvol),numVolIoni(pQIVol),
     +          RLenRVol(pqvol),RLenRAVol
        save / cvolum /
+KEEP,part.
c               The incoming particle.
c               After changing the particle you have
c               to recalculate crossec
        real tkin,mass          ! Kin.energy
        real*8 beta2,beta12     ! Beta**2 and 1.0-Beta**2
        real emax               ! Max. energy of delta electron
        real bem                ! beta2/emax
        real coefPa             ! help const
c               It is in energy transfer cross sections:
c                         Alpha
c                       ----------
c                       beta2 * pi
        real partgamma          ! gamma factor
        real partmom,partmom2   ! momentum and momentum**2
        integer s_pri_elec      ! Sign  that primary particle is electron.
                                ! It is recognized by mass near to 0.511
                                ! In some parts of program the direct condition
                                ! like mass < 0.512 is used.
        common / cpart /
     +  tkin,mass,     
     +  beta2,beta12,
     +  partgamma,
     +  partmom,partmom2,  
     +  emax,          
c     + ecut,          
     +  bem ,          
     +  coefPa,
     +  s_pri_elec
        save / cpart /
+KEEP,hist.
 

        integer sHist              ! Sign to fill histograms 
        character*100 HistFile     ! File name for file
                                   ! with histograms.
        integer HistLun            ! Logical number of stream to write
                                   ! this file.
        parameter (HistLun=34)

        real maxhisampl            ! maximum amplitude for histograms
        real maxhisample           ! maximum amplitude for histograms
                                   ! in units of electrons
        real maxhisampl2           ! reduced maximum amplitude for histograms
        integer pqhisampl          ! quantity for histograms with amplitude.
        integer pqh
        parameter (pqh=100)     ! usual number of divisions
        integer pqh2
        parameter (pqh2=200)     ! increased number of divisions
 
        integer shfillrang         ! sign to fill special histogram nh2_rd
                                   ! with practical range of delta electron
                                   ! It spends some computer time.
        integer MaxHistQSVol
        parameter (MaxHistQSVol=50) ! Maximum number of volumes,
                                ! used at initilisation of histograms.
                                ! If the number of the sensitive volumes 
                                ! is more,
                                ! only MaxHistQSVol histograms will be created
                                ! and they will represent 
                                ! the first MaxHistQSVol volumes
        integer hQSVol          ! working number -- minimum of 
                                ! MaxHistQSVol end QSVol
                                ! Defined in Inihist

c       Determination of histogram numbers:
 
c       Notation nh1 is number of 1-dimension histogram 
c       Notation nh2 is number of 2-dimension histogram 


        integer nh1_ampK
        parameter (nh1_ampK=100)        ! amplitude (KeV)
                                ! Some fluctuations may be here if
                                ! each single  bin of this histogram corresponds
                                ! to differrent numbers of bins of
                                ! nh1_ampN histogram.
        integer nh1_ampKR       
        parameter (nh1_ampKR=150)       ! amplitude (KeV)
                                ! Special treatment is applyed to smooth 
                                ! the fluctuations mentioned above.
                                ! It increases the mean square dispersion
                                ! on a little value sqrt(1/12)* w .
        integer nh1_ampN        
        parameter (nh1_ampN=200)! amplitude in numbers of conduction electrons.

        integer nh1_cdx         ! charge distribution along x
        parameter (nh1_cdx=300)
        integer nh1_cdy         ! charge distribution along y
        parameter (nh1_cdy=500)
        integer nh1_cdz         ! charge distribution along z
        parameter (nh1_cdz=700)

        integer nh2_ard         ! Actual range of delta-electron(cm) 
        parameter (nh2_ard=900) ! vs energy(MeV).
        integer nh2_rd          ! Range along initial direction of 
        parameter (nh2_rd=901)  ! delta-electron vs energy.
        integer nh1_rd          ! Range along initial direction of 
        parameter (nh1_rd=902)  ! delta-electron (cm).

        common / chist /
     +  sHist,
     +  maxhisampl,
     +  maxhisample,
     +  maxhisampl2,
     +  pqhisampl, 
     +  shfillrang,
     +  hQSVol
        save / chist /
        common / chhist /
     +  HistFile
        save / chhist /

+KEEP,random.
        real*8 iranfl

        integer sseed              ! Flag to start first event
                                   ! from seed point of random number generator.
        real*8 rseed               ! Place for seed.
        integer seed(2)            ! Form for writting and inputting
                                   ! without modification during
                                   ! binary to demical transformation.
        equivalence (rseed,seed(1))

        common / comran / 
     +  iranfl,
     +  rseed, sseed

        save / comran /
        
+KEEP,del.
c               Delta electrons
 
        integer pqdel           ! Max. q. of electrons
        parameter (pqdel=120000)        
        integer qdel    ! Q. of electrons
C       integer cdel    ! Current electron (not used, RV 27/2/97)
                        ! number of el. which must be treated next
        real veldel     ! direction of the velocity 
        real*8 pntdel   ! point   
        
        real zdel, edel         ! charge of current electrons
                        ! which must be produced and energy of Delta
        integer Stdel   ! Generation number
        integer Ptdel   ! pointer to parent virtual photon
        integer updel   ! additional parameters
        integer SOdel           ! 1 for ouger electrons 0 for other
        integer nVoldel         ! Number of volume
        real*8 rangedel         ! range
        real*8 rangepdel                ! practical range
        integer qstepdel        ! quantity of steps of simulation
                                ! of stopping
        integer sOverflowDel    ! sign of overflow in the current event
        integer qsOverflowDel   ! quantity of the overflows in all events
        integer qOverflowDel    ! quantity of the lossed electrons
                                ! in all events
        integer ii1del          ! not used. only for alingment.
        common / comdel / 
     +  qdel, ii1del, 
     +  pntdel(3,pqdel), veldel(3,pqdel), 
     +  rangedel(pqdel),rangepdel(pqdel), qstepdel(pqdel),
     +  zdel(pqdel), edel(pqdel), nVoldel(pqdel),
     +  Stdel(pqdel), Ptdel(pqdel), updel(pqup,pqdel), SOdel(pqdel),
     +  sOverflowDel, qsOverflowDel,qOverflowDel
        save / comdel /

+KEEP,cel.
c               Conductin electrons in sensitive volumes
c               Currently each the electron is considered as cluster
 
        integer pqcel           ! Max. q of clusters
        parameter (pqcel=5000)
c       parameter (pqcel=1000000)       ! If this, reduce numbers of volumes
c       parameter (pqcel=100000)        ! If this, reduce numbers of volumes
        integer qcel            ! Q. of clusters
        real*8 pntcel           ! point of cluster
        real zcel               ! charge in unit of quantity of electron
                                ! in this cluster (now it is always 1)
        real szcel      ! sum quantity of charge in the volume
        integer Ndelcel ! number of parent delta electron
        integer sOverflowCel    ! sign of overflow in the current event
        integer qsOverflowCel   ! quantity of the overflows in all events
        integer qOverflowCel    ! quantity of the lossed electrons
                                ! in all events
        integer sactcel         ! auxiliary sing.
                        ! It set to one if the delta-electron either
                        ! was born in an insensitive lawer or 
                        ! after it had flied through an insensitive lawer.
        common / comcel / 
     +  pntcel(3,pqcel,pQSVol),  
     +  qcel(pQSVol), 
     +  zcel(pqcel,pQSVol),
     +  szcel(pQSVol),
     +  Ndelcel(pqcel,pQSVol),
     +  sactcel(pqcel,pQSVol),
     +  sOverflowCel(pQSVol), qsOverflowCel(pQSVol),qOverflowCel(pQSVol)
        save / comcel /
+KEEP,lsgvga.
c               Results of ionization loss calculations
c               It is used only for hist filling 
 
        integer pqgvga
        parameter (pqgvga=1000)
        integer qgvga,ganumat,ganumshl
        real esgvga,egvga,velgvga
        real*8 pntgvga
        common / clsgva / 
     +  qgvga(pQIVol), 
     +  esgvga(pQIVol),
     +  egvga(pqgvga,pQIVol),
     +  pntgvga(3,pqgvga,pQIVol),  
     +  velgvga(3,pqgvga,pQIVol),
     +  ganumat(pqgvga,pQIVol), 
     +  ganumshl(pqgvga,pQIVol) 
        save / clsgva /
+KEEP,abs.
 
c               Gamma which is ready to absorb
c               There are two sorts of gamma
c               Real gamma after their absorbtion points are known and
c               virtual gamma from ionization loss
        integer pqtagam          ! Max quantity of absorbtion gamma
        parameter (pqtagam=100000) 
        integer qtagam, ctagam   ! Full quantity and current number
                                 ! of gamma which will be treat next.
                                 ! If ctagam>qtagam then
                                 ! there is no gamma to treat.
        real etagam,  vtagam ! Energy,  and velocity
                                 ! direction of absorbtion gamma
        real*8 rtagam            ! position of absorbtion gamma
        integer nVolagam         ! Volume number for this point
        integer nAtagam,nshlagam ! Number of atom and shell 
                                 ! which  absorbe this photon
        integer Stagam           ! Generation number
        integer upagam           ! additional parameters
        integer sOverflowagam    ! sign of overflow in the current event
        integer qsOverflowagam   ! quantity of the overflows in all events
        integer qOverflowagam    ! quantity of the lossed electrons
                                ! in all events

        common / comabs / 
     +  qtagam, ctagam, etagam(pqtagam), 
     +  rtagam(3,pqtagam), vtagam(3,pqtagam), 
     +  nVolagam(pqtagam),nAtagam(pqtagam),nShlagam(pqtagam),
     +  Stagam(pqtagam), upagam(pqup,pqtagam),
     +  sOverflowagam, qsOverflowagam,qOverflowagam
        save / comabs /
+KEEP,rga.
c               Real photons
 
        integer pqrga   
        parameter (pqrga=1000)
        integer qrga, crga 
        real velrga, erga
        real*8 pntrga
        integer Strga   ! generation 
        integer Ptrga   ! pointer to parent
        integer uprga   ! number of trans vol
        integer SFrga   ! sign of fly out
        integer nVolrga
        integer sOverflowrga    ! sign of overflow in the current event
        integer qsOverflowrga   ! quantity of the overflows in all events
        integer qOverflowrga    ! quantity of the lossed photons
                                ! in all events

        common / comrga / 
     +  qrga, crga,
     +  pntrga(3,pqrga), velrga(3,pqrga), erga(pqrga), 
     +  nVolrga(pqrga), Strga(pqrga), Ptrga(pqrga), uprga(pqup,pqrga), 
     +  SFrga(pqrga),
     +  sOverflowrga, qsOverflowrga,qOverflowrga
        save / comrga /
+KEEP,h1.
        integer qhis            ! Quantity of the divisions in 
                                ! the additional histograms
                                ! with numbers started from 30000
        parameter (qhis=500)
        real hhis               ! step by coordinate
        real mhis               ! maximal coordinate shift
        parameter (mhis=200.0)
        integer pqamp           ! maximal quantity of the amplitude cuts
        parameter (pqamp=11)
        integer qamp            ! real quantity of the amplitude cuts
        real amp
        real ampc       ! values of the amplitude cuts
        integer npp     ! number of events passed through cuts
        
                        ! The following two arrays:
                        ! During event processing
                        ! pp1 - sum of the coordinates of the centers
                        ! pp2 - sum of the square of 
                        !              the coordinates of the centers
                        ! After the last event processed
                        ! they become:
                        ! pp1 - mean coordinate
                        ! pp2 - mean square deviation
        real*8 pp1      
        real*8 pp2
                        ! The following two arrays are filled after
                        ! the last event processed and they have the same
                        ! meaning, but different type.
                        ! They are intended for filling of histograms
        real rpp1
        real rpp2
        real prob       ! probability of the clusters
        real meanprob   ! mean number of ionization
        real meanvga    ! mean number of the energy transfers
        real meanvgal   ! mean energy loss, KeV
        integer qe
        common / h31 /
     +  pp1(1000,2,pqamp), pp2(1000,2,pqamp),hhis, npp(1000,2,pqamp),
     +  rpp1(1000,2,pqamp), rpp2(1000,2,pqamp),
     +  amp(pqamp),ampc(pqamp),qamp,
     +  prob(1000),meanprob,meanvga,meanvgal,
     +  qe
+KEEP,shl.
        integer pqschl,pqshl,pqatm,pqsel,pqsga
        parameter (pqschl=3)    ! Max. q. of channels
        parameter (pqshl=7)     ! Max. q. of shells
        parameter (pqatm=20)    ! Max. q. of atoms
        parameter (pqsel=3)     ! Max. q. of secondary electrons in
                                ! one channel
        parameter (pqsga=3)     ! Max. q. of secondary photons in
                                ! one channel
        integer qschl,qshl,qatm,qsel,qsga
        real charge     ! charge of atom
        real eshell     ! energy of shells
                        ! The distanse must be bigger the 
                        ! threshold in the atom.inc
                        ! if secondary photons is generated 
        real secprobch  ! Probubility function for channels
                        ! Attention!!! - Probubility function
                        ! i.e. last channel prob must be 1
        real secenel    ! Energies of secondary electrons
        real secenga    ! Energies of secondary photons
        common / comshl /
     +  charge(pqatm),
     +  qschl(pqshl,pqatm),qshl(pqatm),qatm,
     +  qsel(pqschl,pqshl,pqatm),qsga(pqschl,pqshl,pqatm),
     +  eshell(pqshl,pqatm),secprobch(pqschl,pqshl,pqatm),
     +  secenel(pqsel,pqschl,pqshl,pqatm),
     +  secenga(pqsga,pqschl,pqshl,pqatm)
        save / comshl /
+KEEP,LibAtMat.
c       Numbers(pointers) of atoms in atom.inc.

c       Since for some of them a special treatment is provided
c       in subroutine Iniatom and this subroutine recognize them by number, 
c       the user must not initialize another atoms on these places,
c       even if subroutine AtomsByDefault is not called.
c       Another atoms can be initialized on free places.

        integer num_H
        integer num_H3
        integer num_H4
        integer num_He
        integer num_Li
        integer num_C
        integer num_C1
        integer num_C2
        integer num_C3
c       integer num_C4
        integer num_N
        integer num_O
        integer num_F
        integer num_Ne
        integer num_Al
        integer num_Si
        integer num_Ar
        integer num_Kr
        integer num_Xe
        parameter (num_H  = 1  )
        parameter (num_H3 = 2  )
        parameter (num_H4 = 3  )
        parameter (num_He = 4  )
        parameter (num_Li = 5  )
        parameter (num_C  = 6  )
        parameter (num_N  = 7  )
        parameter (num_O  = 8  )
        parameter (num_F  = 9  )
        parameter (num_Ne  =10 )
        parameter (num_Al = 11 )
        parameter (num_Si = 12 )
        parameter (num_Ar = 13 )
        parameter (num_Kr = 14 )
        parameter (num_Xe = 15 )
        parameter (num_C1  = 16 )       ! C in CO2
        parameter (num_C2  = 17 )       ! C in CF4
        parameter (num_C3  = 18 )       ! C in CH4
*** Additions (RV 20/9/99).
        integer num_S
        parameter (num_S = 19)
*** End of additions.
+KEEP,shellfi.
        integer pqash           ! Max. q. of shells
        parameter (pqash=7)
        integer zato            ! Z of atom
        integer qash            ! quantity of shells
        real athreshold,aweight ! threshold and weight of shells
        integer pqaener,qaener  ! Max. and just q. of shell energy
        parameter (pqaener=500)
        real aener              ! Energy
        real aphot              ! Photoabsorbtion crossection
                        ! for this point of energy
        common / cshellfi /
     +          zato,
     +          qash,
     +          athreshold(pqash),aweight(pqash),
     +          qaener(pqash),
     +          aener(pqaener,pqash),aphot(pqaener,pqash)
        save / cshellfi /
+KEEP,tpasc.
        integer pqshPas
        parameter (pqshPas=5)
        integer qshPas
        integer lPas
        real E0Pas,EthPas,ywPas,yaPas,PPas,sigma0Pas
        common / Pascom /
     +  qshPas(pQAt),
     +  lPas(pqshPas,pQAt),
     +  E0Pas(pqshPas,pQAt),EthPas(pqshPas,pQAt),ywPas(pqshPas,pQAt),
     +  yaPas(pqshPas,pQAt),PPas(pqshPas,pQAt),sigma0Pas(pqshPas,pQAt)
        save / Pascom /


+KEEP,henke6.
        qash=2

        qaener(1)=10
        athreshold(1)=291
        aener(1,1)=311.7
        aphot(1,1)=0.839895
        aener(2,1)=392.4
        aphot(2,1)=0.49875
        aener(3,1)=452.2
        aphot(3,1)=0.35112
        aener(4,1)=676.8
        aphot(4,1)=0.127082
        aener(5,1)=776.2
        aphot(5,1)=0.0887775
        aener(6,1)=1011.7
        aphot(6,1)=0.0428925
        aener(7,1)=2984.3
        aphot(7,1)=0.00183341
        aener(8,1)=5414.7
        aphot(8,1)=0.000293265
        aener(9,1)=9886.4
        aphot(9,1)=4.2693e-05
        aener(10,1)=29779
        aphot(10,1)=1.04339e-06

        qaener(2)=13
        athreshold(2)=8.9
        aener(1,2)=10.2
        aphot(1,2)=5.9052
        aener(2,2)=13
        aphot(2,2)=11.97
        aener(3,2)=15
        aphot(3,2)=13.965
        aener(4,2)=21.2
        aphot(4,2)=12.0299
        aener(5,2)=30.5
        aphot(5,2)=6.00495
        aener(6,2)=49.3
        aphot(6,2)=2.0349
        aener(7,2)=72.4
        aphot(7,2)=0.96558
        aener(8,2)=108.5
        aphot(8,2)=0.408975
        aener(9,2)=114
        aphot(9,2)=0.369075
        aener(10,2)=132.8
        aphot(10,2)=0.265335
        aener(11,2)=192.6
        aphot(11,2)=0.112119
        aener(12,2)=220.1
        aphot(12,2)=0.0776055
        aener(13,2)=277
        aphot(13,2)=0.039102
+KEEP,track.
c       The track information about the primary particle
 
        integer sign_ang        ! sign to run the part. with effective angle
        real ang                ! teta
        real phiang             ! phi
        real ystart             ! start Y coordinate
        integer srandtrack      ! sign to randomize the Y coordinate
                                ! between ystart1 and  ystart2
                                ! It is done by call IniNTrack from GoEvent
                                ! if the track initialization was done by
                                ! call IniRTrack
        real ystart1
        real ystart2
        real sigmaang           ! sigma of begin angle distribution
                        !Currently, if sigmaang>0, the rundomization
                        ! is doing around the 0 angle.
                        ! So the values of pang and pphiang are ignored
                        ! It can be changed by modernization
                        ! of IniNTrack
        real e1ang,e2ang,e3ang  ! coordinates of new orts in the old
        integer sigmtk          ! sign of multiple scatering
        integer pQmtk           ! max. quantity of the break point of the track
                                ! plus one
        parameter (pQmtk=10000)
        integer Qmtk            ! actual quantity for current event
        real*8 pntmtk           ! break point coordinates
        real velmtk             ! directions of velocity
        real*8 lenmtk           ! lengt of way for straight till next break
        real Tetamtk            ! turn angle
        integer nVolmtk         ! number of volume for given point,
                                ! the point on the frantier is correspond
                                ! to next volume of zero for end.
        real*8 vlenmtk          ! lengt of way inside the volume
        integer nmtkvol1,nmtkvol2 ! numbers of first point in volume
                        ! and the previous for end point
        real*8 xdvmtk,ydvmtk    ! deviations from strate line
                        ! using only for histograms

        ! service data. They are using at initialization of the track.
        integer sruthmtk        ! key to use Rutherford cross section
        integer nmtk            ! current number of point.
                        ! After initialization it must be equal to Qmtk+1
        integer sgnmtk          ! sign to go to next volume
        integer sturnmtk        ! sign to turn
        real*8 lammtk           ! mean free path
        real mlammtk            ! minimum mean lengt of range
                        ! multiplied by density. sm*gr/sm**3 = gr/sm**2
        real mTetacmtk          ! minimum threshold turn angle
        real Tetacmtk           ! threshold turn angle
        real rTetacmtk          ! restiction due to atomic shell
        real*8 CosTetac12mtk    ! cos(tetac/2)
        real*8 SinTetac12mtk    ! sin(tetac/2)
c       real CosTetac12mtk      ! cos(tetac/2)
c       real SinTetac12mtk      ! sin(tetac/2)
        real msigmtk            ! msig without sqrt(x)
        real e1mtk,e2mtk,e3mtk
        common / ctrack /
     +  sign_ang, ang, phiang, ystart, srandtrack, ystart1, ystart2,
     +  e1ang(3),e2ang(3),e3ang(3),
     +  sigmtk, 
     +  sruthmtk,
     +  Qmtk, nmtk,
     +  pntmtk(3,pQmtk), velmtk(3,pQmtk), lenmtk(pQmtk), Tetamtk(pQmtk),
     +  nVolmtk(pQmtk), vlenmtk(pQVol), 
     +  nmtkvol1(pQVol), nmtkvol2(pQVol),
     +  xdvmtk(pQSVol),ydvmtk(pQSVol),
     +  sgnmtk, sturnmtk,
     +  lammtk(pQMat), mlammtk, mTetacmtk,
     +  Tetacmtk(pQMat),
     +  rTetacmtk(pQMat),
     +  CosTetac12mtk(pQMat), SinTetac12mtk(pQMat), msigmtk,
     +  e1mtk(3,pQmtk),e2mtk(3,pQmtk),e3mtk(3,pQmtk),
     +  sigmaang
        save / ctrack /
+KEEP,raffle.
        integer pQGRaf          ! Max. quantity of energy transfer
        parameter (pQGRaf=10000)
        integer QGRaf           ! Quantity of energy transfers
        integer NAtGRaf,NShAtGRaf ! Numbers of atom and shell
        real ESGRaf,EGRaf       ! Cumulative energy and just energy
        real pntraf,velraf
        
        common / craffle / 
     +  QGRaf, 
     +  ESGRaf,
     +  EGRaf(pQGRaf),
     +  NAtGRaf(pQGRaf), 
     +  NShAtGRaf(pQGRaf) ,
     +  pntraf(3,pQGRaf), velraf(3,pQGRaf)


        save / craffle /
+KEEP,bdel.
c               Information about tracing of current delta-electron
c

        real eMinBdel                   ! some condition step by energy
                        ! (the name is obsolete)
                        ! If step is larger than eMinBdel and 0.1*eBdel
                        ! the step is equate to 0.1*eBdel
                        ! In this case step can not be less than eMinBdel
                        ! and larger than eBdel
        integer iMinBdel                ! not using now
        real eLossBdel                  ! array with energy loss for
                                        ! all the matters
        real betaBdel
        real beta2Bdel
        real momentumBdel
        real momentum2Bdel
        real*8 lamaBdel
        real msigBdel
        integer nBdel                   ! number of the delta-electron
                                        ! in the del.inc, which is
                                        ! traced now
        real eBdel                      ! the current energy
        real*8 pntBdel,npntBdel         ! current point and next point
                                        ! Next is calc. in 
                                        ! subroutine SstepBdel 
                                        ! and moved to current in 
                                        ! subroutine treatdel
        real*8 stepBdel                 ! step - sm
        real estepBdel                  !            and MeV  
        real velBdel                    ! direction of the velocity
        real e1Bdel, e2Bdel, e3Bdel     ! coordinate axises,
                                ! e3Bdel is along to velocity
                                ! e2Bdel is perpend. to e3Bdel and x
                                ! e1Bdel is perpend to e2Bdel and e3Bdel
        integer nVolBdel,sgonextBdel    ! number of current volume
                                        ! and sign to go to next volume
        integer sturnBdel               ! sign of turn
        real TetacBdel,TetaBdel         ! threshold turn angle and
                                        ! actual angle
        real CosTetac12Bdel,SinTetac12Bdel
        real rTetacBdel                 ! restiction due to atomic shell
        real*8 lamBdel                  ! mean lengt of range
        real mlamBdel                   ! minimum mean lengt of range
                        ! multiplied by density. sm*gr/sm**3 = gr/sm**2
        real mTetacBdel                 ! minimum threshold turn angle
                        !       For Rutherford:
                        ! The interactions with less angle will not take
                        ! into account. The actual threshold angle can be
                        ! larger. The second restriction is going
                        ! from restriction of atomic shell.
                        ! The third one is from mlamBdel.
                        !       For usial multiple scatering:
                        ! Assuming that sigma = mTetacBdel
                        ! the paht lengt is calculating.
                        ! If mlamBdel/density is less then the last is using.
        integer iBdel                   ! index of current energy
                                        ! in the enerc array
        integer StBdel                  ! Origin and generation sign
                        ! <10000 - origin is ionization loss
                        ! >=10000 - origin is transition radiation
                        ! 1 or 10000 first generation
                        ! 2 or 10001 second generation
                        ! 3 or 10002 third,  et al.
        integer NtvBdel                ! Only for transition gammas:
                        ! number of transition volume, where it was born
        integer SOBdel          ! 1 for ouger electrons 0 for other

        real*8 rangBdel         ! whole delta-electron range 
        real*8 rangpBdel                ! mean projection of delta-electron range
                                ! The maximum projection lengt of 
                                ! current electron point on the 
                                ! primary velocity.
        integer sruthBdel       ! sign of use 
                                ! 1 - Rutherford cross-section
                                ! 0 - usial multiple scatering formula
        integer sisferBdel      ! sign that the mean or the cut turn angle
                        ! is so big that there are no sense to turn 
                        ! the particle. Insterd that the sferical simmetric
                        ! velocity is genegating. It is much more faster.
        integer sisferaBdel
        real cuteneBdel
        integer nstepBdel
        parameter (cuteneBdel=1.0e-3)
        common / cbdel /
     +          lamaBdel(pqener,pQMat),
     +          pntBdel(3),npntBdel(3),
     +          stepBdel, lamBdel,
     +          rangBdel,rangpBdel,
     +          eMinBdel, iMinBdel,
     +          eLossBdel(pqener,pQMat),
     +          betaBdel(pqener), beta2Bdel(pqener),
     +          momentumBdel(pqener), momentum2Bdel(pqener),
     +           msigBdel(pqener),
     +          rTetacBdel(pqener,pQMat),
     +          nBdel,eBdel,
     +          estepBdel,
     +          velBdel(3),
     +          e1Bdel(3),e2Bdel(3),e3Bdel(3),
     +          nVolBdel,sgonextBdel,sturnBdel,
     +          TetacBdel(pqener,pQMat),
     +          CosTetac12Bdel(pqener,pQMat), 
     +          SinTetac12Bdel(pqener,pQMat),
     +          TetaBdel,
     +          mlamBdel,mTetacBdel,
     +          iBdel,
     +          StBdel,NtvBdel,SOBdel,
     +          sruthBdel,
     +          sisferBdel,
     +          sisferaBdel(pqener,pQMat),
     +          nstepBdel
        save / cbdel /

c                       below there are the values for exact elastic 
c                                               scatering
        integer pqanCBdel
        parameter (pqanCBdel=31)
        integer qanCBdel
        parameter (qanCBdel=30)
        real anCBdel
        real ancCBdel
        
        integer pqeaCBdel
        parameter (pqeaCBdel=10)
        integer qeaCBdel
        parameter (qeaCBdel=9)
        real enerCBdel, enercCBdel
        real sign_ACBdel        ! sign that the parameters are read
        real ACBdel             ! parameters
        real CCBdel
        real BCBdel
        real sCBdel             ! cross section, Angstrem**2 / strd
        real sRCBdel            ! Rutherford cross section for comparison
        real sRmCBdel           ! maximum of Rutherford die to cut
        real sRcmCBdel          ! the cut angle again
        real smaCBdel           ! cross section for material per one av. atom,
                                ! in MeV**-2/rad
        real smatCBdel          ! cross section for material per one av. atom,
                                ! in MeV**-2/rad, for working energy mesh
        real ismatCBdel         ! normalized integral
        real tsmatCBdel         ! integral
        real gammaCBdel
        real beta2CBdel
        real momentum2CBdel
        real rrCBdel            ! range by usual formula
        real koefredCBdel       ! koef for derivation of step
                                ! from usual formula
        parameter (koefredCBdel=0.02)
        common / cbdel1 /
     +          anCBdel(pqanCBdel), ancCBdel(pqanCBdel),
     +          enerCBdel(pqeaCBdel), enercCBdel(pqeaCBdel),
     +          sign_ACBdel(pqAt),
     +          ACBdel(4,pqeaCBdel,pqAt), CCBdel(0:6,pqeaCBdel,pqAt), 
     +          BCBdel(pqeaCBdel,pqAt),
     +          sCBdel(pqanCBdel,pqeaCBdel,pqAt), 
     +          sRCBdel(pqanCBdel,pqeaCBdel,pqAt), 
     +          sRmCBdel(pqeaCBdel,pqAt), 
     +          sRcmCBdel(pqeaCBdel,pqAt), 
     +          smaCBdel(pqanCBdel,pqeaCBdel,pQMat), 
     +          smatCBdel(pqanCBdel,pqener,pQMat), 
     +          ismatCBdel(pqanCBdel,pqener,pQMat),
     +          tsmatCBdel(pqener,pQMat),
     +          gammaCBdel(pqeaCBdel), beta2CBdel(pqeaCBdel),
     +          momentum2CBdel(pqeaCBdel),
     +          rrCBdel(pqener,pQMat)
        save / cbdel1 /

        real MagForFBdel
        real EleForFBdel
        real veloBdel
        common / cbdel2 /
     +  MagForFBdel(3), EleForFBdel(3),
     +  veloBdel(3)
        save / cbdel2 /


+KEEP,cbdeldat.
      data ZsCBdel(1)/ 1 /
      data (AsCBdel( 1 , i, 1 ),i=1,9)/
     + -0.9007, -0.6539, -0.3655, -0.5499, -0.0196,
     + 0.04526, -0.658, 0.008393, -0.3739   /
      data (AsCBdel( 2 , i, 1 ),i=1,9)/
     + 0.3975, 0.338, 0.2884, 0.3151, 0.2809,
     + 0.2774, 0.3126, 0.2787, 0.2928   /
      data (AsCBdel( 3 , i, 1 ),i=1,9)/
     + 0.002344, 0.003208, 0.00294, 0.001429, 0.0009329,
     + 0.00041, 3.017e-05, 0.0001038, 1.757e-05   /
      data (AsCBdel( 4 , i, 1 ),i=1,9)/
     + -3.534e-05, -1.59e-05, -5.392e-06, 9.522e-06, 8.538e-07,
     + -4.278e-08, 7.506e-07, 4.492e-09, 3.551e-08   /
      data (CsCBdel( 0 , i, 1 ),i=1,9)/
     + 1.105, 0.8986, 0.6487, 0.8062, 0.01901,
     + -0.09682, 0.9669, -0.1011, 0.4769   /
      data (CsCBdel( 1 , i, 1 ),i=1,9)/
     + 1.172, 1.05, 0.9256, 0.9955, 0.02643,
     + -0.1263, 1.229, -0.141, 0.6287   /
      data (CsCBdel( 2 , i, 1 ),i=1,9)/
     + 0.7611, 0.7519, 0.8045, 0.751, 0.02258,
     + -0.1017, 0.9513, -0.1224, 0.5042   /
      data (CsCBdel( 3 , i, 1 ),i=1,9)/
     + 0.4001, 0.4377, 0.5676, 0.4597, 0.01605,
     + -0.06736, 0.5969, -0.08834, 0.3282   /
      data (CsCBdel( 4 , i, 1 ),i=1,9)/
     + 0.1718, 0.2092, 0.3277, 0.2304, 0.009861,
     + -0.03748, 0.3072, -0.05421, 0.176   /
      data (CsCBdel( 5 , i, 1 ),i=1,9)/
     + 0.05558, 0.07568, 0.1426, 0.08723, 0.004891,
     + -0.0164, 0.1202, -0.02652, 0.07261   /
      data (CsCBdel( 6 , i, 1 ),i=1,9)/
     + 0.01031, 0.01571, 0.03491, 0.01878, 0.00171,
     + -0.004697, 0.02774, -0.008267, 0.0182   /
      data (BsCBdel( i, 1 ),i=1,9)/
     + 0.008057, 0.004506, 0.002592, 0.001872, 0.0008431,
     + 0.0003444, 0.0003049, 8.926e-05, 6.648e-05   /
      data ZsCBdel(2)/ 2 /
      data (AsCBdel( 1 , i, 2 ),i=1,9)/
     + 0.0327, -0.4242, -0.6746, -0.6343, -0.2289,
     + -0.3277, -0.2001, -1.227, -0.3022   /
      data (AsCBdel( 2 , i, 2 ),i=1,9)/
     + 0.3427, 0.3746, 0.363, 0.3388, 0.2998,
     + 0.298, 0.2891, 0.3407, 0.2914   /
      data (AsCBdel( 3 , i, 2 ),i=1,9)/
     + -0.00727, -0.002397, -0.001851, -0.0009558, 0.001271,
     + 0.0006719, 0.000343, -9.27e-05, 7.883e-05   /
      data (AsCBdel( 4 , i, 2 ),i=1,9)/
     + 5.556e-05, 2.941e-06, 3.477e-06, 9.459e-07, 1.384e-11,
     + 1.73e-07, -7.566e-14, 6.887e-07, 4.899e-08   /
      data (CsCBdel( 0 , i, 2 ),i=1,9)/
     + -0.09725, 0.4519, 0.8681, 0.8734, 0.3088,
     + 0.4817, 0.2759, 1.81, 0.3546   /
      data (CsCBdel( 1 , i, 2 ),i=1,9)/
     + -0.1434, 0.4205, 0.9635, 1.028, 0.3654,
     + 0.6172, 0.3678, 2.294, 0.4574   /
      data (CsCBdel( 2 , i, 2 ),i=1,9)/
     + -0.1141, 0.2335, 0.6551, 0.7411, 0.2638,
     + 0.4836, 0.3015, 1.763, 0.3535   /
      data (CsCBdel( 3 , i, 2 ),i=1,9)/
     + -0.06887, 0.1, 0.3606, 0.4342, 0.1544,
     + 0.3089, 0.2039, 1.09, 0.2158   /
      data (CsCBdel( 4 , i, 2 ),i=1,9)/
     + -0.03233, 0.03143, 0.1606, 0.2074, 0.07401,
     + 0.1633, 0.1164, 0.5456, 0.1024   /
      data (CsCBdel( 5 , i, 2 ),i=1,9)/
     + -0.01082, 0.00537, 0.05227, 0.0725, 0.0269,
     + 0.0664, 0.05306, 0.2027, 0.0328   /
      data (CsCBdel( 6 , i, 2 ),i=1,9)/
     + -0.00182, -0.000404, 0.008547, 0.01166, 0.005736,
     + 0.01634, 0.01557, 0.04167, 0.006162   /
      data (BsCBdel( i, 2 ),i=1,9)/
     + 0.01206, 0.007727, 0.00318, 0.001359, 0.001657,
     + 0.0008551, 0.0004051, 0.0003179, 0.0001234   /
      data ZsCBdel(3)/ 3 /
      data (AsCBdel( 1 , i, 3 ),i=1,9)/
     + 1.427, 1.875, 1.99, 1.699, 1.07,
     + 0.6406, -0.4004, -0.3638, -1.191   /
      data (AsCBdel( 2 , i, 3 ),i=1,9)/
     + 0.05527, 0.09522, 0.1452, 0.1939, 0.2375,
     + 0.2604, 0.3007, 0.2984, 0.3292   /
      data (AsCBdel( 3 , i, 3 ),i=1,9)/
     + -0.0002502, -0.0006965, -0.0008232, -0.000703, -0.0005227,
     + -0.0003072, -0.0002339, -0.0001217, -0.0001381   /
      data (AsCBdel( 4 , i, 3 ),i=1,9)/
     + 2.705e-05, 1.05e-05, 4.396e-06, 1.701e-06, 6.296e-07,
     + 1.826e-07, 7.576e-08, 2.354e-08, 3.617e-08   /
      data (CsCBdel( 0 , i, 3 ),i=1,9)/
     + -1.541, -2.386, -2.805, -2.555, -1.683,
     + -1.062, 0.5774, 0.4788, 1.77   /
      data (CsCBdel( 1 , i, 3 ),i=1,9)/
     + -1.472, -2.601, -3.317, -3.176, -2.153,
     + -1.397, 0.7406, 0.6022, 2.303   /
      data (CsCBdel( 2 , i, 3 ),i=1,9)/
     + -0.8666, -1.737, -2.391, -2.401, -1.672,
     + -1.115, 0.5758, 0.4548, 1.815   /
      data (CsCBdel( 3 , i, 3 ),i=1,9)/
     + -0.4155, -0.9407, -1.395, -1.469, -1.047,
     + -0.718, 0.3605, 0.2727, 1.152   /
      data (CsCBdel( 4 , i, 3 ),i=1,9)/
     + -0.1638, -0.4176, -0.6643, -0.7343, -0.5343,
     + -0.3768, 0.1825, 0.1288, 0.5931   /
      data (CsCBdel( 5 , i, 3 ),i=1,9)/
     + -0.04905, -0.1403, -0.2385, -0.2776, -0.2048,
     + -0.1487, 0.06829, 0.04247, 0.2284   /
      data (CsCBdel( 6 , i, 3 ),i=1,9)/
     + -0.00851, -0.02708, -0.04885, -0.06059, -0.04461,
     + -0.03362, 0.01358, 0.006216, 0.05031   /
      data (BsCBdel( i, 3 ),i=1,9)/
     + 0.004125, 0.002188, 0.001189, 0.0006433, 0.000348,
     + 0.0001781, 9.893e-05, 5.406e-05, 5.406e-05   /
      data ZsCBdel(4)/ 6 /
      data (AsCBdel( 1 , i, 4 ),i=1,9)/
     + -0.2288, -0.158, -0.002296, 0.1188, -0.113,
     + -0.1099, -0.2114, -0.321, -0.3712   /
      data (AsCBdel( 2 , i, 4 ),i=1,9)/
     + 0.1755, 0.1774, 0.1813, 0.1927, 0.2573,
     + 0.2617, 0.2751, 0.2829, 0.286   /
      data (AsCBdel( 3 , i, 4 ),i=1,9)/
     + -0.000567, 0.001007, 0.0005522, -0.0002222, -0.0006304,
     + -0.0003796, -0.0002618, -0.0001435, -7.271e-05   /
      data (AsCBdel( 4 , i, 4 ),i=1,9)/
     + -2.822e-06, -6.323e-06, -1.751e-06, 8.23e-08, 7.391e-06,
     + 2.077e-06, 6.244e-07, 1.488e-07, 3.304e-08   /
      data (CsCBdel( 0 , i, 4 ),i=1,9)/
     + 0.5481, 0.5514, 0.4277, 0.2874, 0.4173,
     + 0.4084, 0.4764, 0.5723, 0.5971   /
      data (CsCBdel( 1 , i, 4 ),i=1,9)/
     + 0.7001, 0.8468, 0.8727, 0.8116, 0.7996,
     + 0.8204, 0.8368, 0.9077, 0.9267   /
      data (CsCBdel( 2 , i, 4 ),i=1,9)/
     + 0.5164, 0.6987, 0.8691, 0.9514, 0.8364,
     + 0.9003, 0.8566, 0.8596, 0.8603   /
      data (CsCBdel( 3 , i, 4 ),i=1,9)/
     + 0.3055, 0.4423, 0.6429, 0.7965, 0.6723,
     + 0.7587, 0.695, 0.6525, 0.6395   /
      data (CsCBdel( 4 , i, 4 ),i=1,9)/
     + 0.1493, 0.2224, 0.3722, 0.5125, 0.4275,
     + 0.5034, 0.4532, 0.3989, 0.381   /
      data (CsCBdel( 5 , i, 4 ),i=1,9)/
     + 0.05661, 0.08288, 0.1587, 0.2398, 0.2002,
     + 0.2435, 0.2194, 0.1783, 0.1645   /
      data (CsCBdel( 6 , i, 4 ),i=1,9)/
     + 0.01273, 0.01736, 0.03764, 0.06171, 0.05196,
     + 0.06335, 0.05949, 0.04171, 0.0395   /
      data (BsCBdel( i, 4 ),i=1,9)/
     + 0.005592, 0.003821, 0.0019, 0.0004467, 0.00118,
     + 0.0005983, 0.0003049, 0.0001453, 6.647e-05   /
      data ZsCBdel(5)/ 7 /
      data (AsCBdel( 1 , i, 5 ),i=1,9)/
     + -0.2683, -0.1095, -0.2076, 1.155, 1.192,
     + 1.083, 0.6177, 0.6945, 0.1072   /
      data (AsCBdel( 2 , i, 5 ),i=1,9)/
     + 0.1794, 0.1917, 0.2207, 0.1476, 0.1849,
     + 0.2177, 0.2517, 0.2517, 0.2784   /
      data (AsCBdel( 3 , i, 5 ),i=1,9)/
     + -0.002106, -0.001189, 0.001094, 0.001768, 0.0006366,
     + 0.0001047, -0.0001064, -1.845e-05, -5.791e-05   /
      data (AsCBdel( 4 , i, 5 ),i=1,9)/
     + 8.363e-06, 2.424e-06, 6.217e-05, 4.937e-07, 3.26e-06,
     + 1.638e-06, 7.072e-07, 8.12e-08, 4.488e-08   /
      data (CsCBdel( 0 , i, 5 ),i=1,9)/
     + 0.587, 0.3883, 0.5649, -1.409, -1.614,
     + -1.596, -0.9572, -1.143, -0.2718   /
      data (CsCBdel( 1 , i, 5 ),i=1,9)/
     + 0.7239, 0.5554, 0.865, -1.48, -1.836,
     + -1.934, -1.17, -1.441, -0.327   /
      data (CsCBdel( 2 , i, 5 ),i=1,9)/
     + 0.5231, 0.4279, 0.73, -0.9541, -1.274,
     + -1.429, -0.8647, -1.105, -0.2408   /
      data (CsCBdel( 3 , i, 5 ),i=1,9)/
     + 0.2991, 0.2539, 0.4765, -0.4998, -0.7137,
     + -0.8552, -0.5104, -0.6825, -0.1421   /
      data (CsCBdel( 4 , i, 5 ),i=1,9)/
     + 0.1378, 0.1199, 0.2486, -0.2148, -0.3255,
     + -0.419, -0.2401, -0.3423, -0.06744   /
      data (CsCBdel( 5 , i, 5 ),i=1,9)/
     + 0.0478, 0.04201, 0.09691, -0.06986, -0.1112,
     + -0.1557, -0.08076, -0.1293, -0.02457   /
      data (CsCBdel( 6 , i, 5 ),i=1,9)/
     + 0.00979, 0.008339, 0.02151, -0.01307, -0.02128,
     + -0.03377, -0.01323, -0.02937, -0.006507   /
      data (BsCBdel( i, 5 ),i=1,9)/
     + 0.005535, 0.002575, 0.005228, 0.002104, 0.00129,
     + 0.0007012, 0.0003761, 0.0001529, 8.43e-05   /
      data ZsCBdel(6)/ 8 /
      data (AsCBdel( 1 , i, 6 ),i=1,9)/
     + -0.3151, -0.4143, -0.3378, 0.775, 1.151,
     + 1.043, 0.8495, 0.6484, 0.6268   /
      data (AsCBdel( 2 , i, 6 ),i=1,9)/
     + 0.1565, 0.2123, 0.228, 0.1668, 0.1769,
     + 0.2119, 0.2388, 0.2526, 0.2555   /
      data (AsCBdel( 3 , i, 6 ),i=1,9)/
     + 0.005179, 0.0008074, 0.002091, 0.00213, 0.001118,
     + 0.0003669, 5.394e-05, 5.051e-06, 1.052e-05   /
      data (AsCBdel( 4 , i, 6 ),i=1,9)/
     + -7.102e-05, -1.079e-05, 5.928e-05, 6.685e-12, 7.192e-07,
     + 1.642e-06, 7.253e-07, 1.528e-07, 1.002e-08   /
      data (CsCBdel( 0 , i, 6 ),i=1,9)/
     + 0.6907, 0.8183, 0.7333, -0.8508, -1.514,
     + -1.489, -1.311, -1.053, -1.081   /
      data (CsCBdel( 1 , i, 6 ),i=1,9)/
     + 0.8607, 1.068, 1.04, -0.8104, -1.685,
     + -1.755, -1.622, -1.305, -1.363   /
      data (CsCBdel( 2 , i, 6 ),i=1,9)/
     + 0.6281, 0.8144, 0.8428, -0.4708, -1.148,
     + -1.259, -1.224, -0.9807, -1.045   /
      data (CsCBdel( 3 , i, 6 ),i=1,9)/
     + 0.3597, 0.4966, 0.5392, -0.2198, -0.6336,
     + -0.728, -0.7484, -0.5893, -0.6437   /
      data (CsCBdel( 4 , i, 6 ),i=1,9)/
     + 0.1652, 0.2472, 0.28, -0.08269, -0.2864,
     + -0.3417, -0.3747, -0.2827, -0.3206   /
      data (CsCBdel( 5 , i, 6 ),i=1,9)/
     + 0.05686, 0.09356, 0.11, -0.02291, -0.09803,
     + -0.1195, -0.1422, -0.09731, -0.1192   /
      data (CsCBdel( 6 , i, 6 ),i=1,9)/
     + 0.01108, 0.02049, 0.02459, -0.003431, -0.01939,
     + -0.02313, -0.03158, -0.01668, -0.02626   /
      data (BsCBdel( i, 6 ),i=1,9)/
     + 0.01527, 0.006677, 0.006234, 0.002632, 0.001398,
     + 0.0008426, 0.0004476, 0.0002062, 7.411e-05   /
      data ZsCBdel(7)/ 9 /
      data (AsCBdel( 1 , i, 7 ),i=1,9)/
     + -0.271, -0.1705, -0.4203, -0.08103, 0.847,
     + 1.032, 0.9064, 0.737, 0.7296   /
      data (AsCBdel( 2 , i, 7 ),i=1,9)/
     + 0.06297, 0.1982, 0.2525, 0.2293, 0.1892,
     + 0.2059, 0.2323, 0.247, 0.251   /
      data (AsCBdel( 3 , i, 7 ),i=1,9)/
     + 0.0192, -0.001907, 0.001649, -0.0005853, 0.001314,
     + 0.0006477, 0.0002021, 6.899e-05, 2.812e-05   /
      data (AsCBdel( 4 , i, 7 ),i=1,9)/
     + -1.458e-05, 6.353e-06, 0.0001059, 4.938e-07, 1.198e-13,
     + 1e-06, 7.184e-07, 1.568e-07, 3.663e-09   /
      data (CsCBdel( 0 , i, 7 ),i=1,9)/
     + 0.8256, 0.4602, 0.7589, 0.3443, -1.043,
     + -1.44, -1.373, -1.174, -1.261   /
      data (CsCBdel( 1 , i, 7 ),i=1,9)/
     + 1.154, 0.6192, 0.9765, 0.5852, -1.093,
     + -1.665, -1.676, -1.445, -1.601   /
      data (CsCBdel( 2 , i, 7 ),i=1,9)/
     + 0.92, 0.4733, 0.7312, 0.5192, -0.6998,
     + -1.174, -1.249, -1.08, -1.243   /
      data (CsCBdel( 3 , i, 7 ),i=1,9)/
     + 0.5763, 0.2837, 0.4353, 0.3475, -0.3624,
     + -0.6677, -0.7544, -0.6459, -0.7811   /
      data (CsCBdel( 4 , i, 7 ),i=1,9)/
     + 0.2949, 0.1363, 0.2107, 0.1826, -0.1537,
     + -0.3085, -0.3728, -0.309, -0.3993   /
      data (CsCBdel( 5 , i, 7 ),i=1,9)/
     + 0.1166, 0.04879, 0.07714, 0.07063, -0.04901,
     + -0.1063, -0.1396, -0.1066, -0.1488   /
      data (CsCBdel( 6 , i, 7 ),i=1,9)/
     + 0.0272, 0.009832, 0.01628, 0.01543, -0.009001,
     + -0.02032, -0.0305, -0.01865, -0.03074   /
      data (BsCBdel( i, 7 ),i=1,9)/
     + 0.02583, 0.004772, 0.007849, 0.001104, 0.001634,
     + 0.0009459, 0.0005241, 0.0002429, 7.913e-05   /
      data ZsCBdel(8)/ 13 /
      data (AsCBdel( 1 , i, 8 ),i=1,9)/
     + -0.4378, -0.3167, -0.2708, -0.212, -0.2487,
     + -0.2509, -0.234, -0.265, -0.2887   /
      data (AsCBdel( 2 , i, 8 ),i=1,9)/
     + 0.0923, 0.1454, 0.1968, 0.2238, 0.244,
     + 0.2547, 0.2598, 0.2632, 0.2677   /
      data (AsCBdel( 3 , i, 8 ),i=1,9)/
     + -0.001988, -0.003033, -0.00252, -0.001545, -0.0008717,
     + -0.0004561, -0.0002297, -0.0001108, -5.184e-05   /
      data (AsCBdel( 4 , i, 8 ),i=1,9)/
     + 3.912e-05, 3.749e-05, 1.642e-05, 5.325e-06, 1.526e-06,
     + 3.975e-07, 9.745e-08, 2.235e-08, 4.724e-09   /
      data (CsCBdel( 0 , i, 8 ),i=1,9)/
     + 0.9154, 0.7984, 0.7195, 0.6202, 0.6319,
     + 0.6121, 0.571, 0.5794, 0.5696   /
      data (CsCBdel( 1 , i, 8 ),i=1,9)/
     + 1.089, 1.079, 1.064, 1.001, 1.008,
     + 0.9975, 0.9718, 0.9775, 0.9695   /
      data (CsCBdel( 2 , i, 8 ),i=1,9)/
     + 0.8455, 0.8439, 0.8883, 0.9071, 0.9025,
     + 0.9105, 0.9213, 0.9188, 0.9192   /
      data (CsCBdel( 3 , i, 8 ),i=1,9)/
     + 0.5493, 0.5267, 0.5759, 0.645, 0.6283,
     + 0.6424, 0.6721, 0.6653, 0.6698   /
      data (CsCBdel( 4 , i, 8 ),i=1,9)/
     + 0.3033, 0.2718, 0.2962, 0.3698, 0.3493,
     + 0.3588, 0.3856, 0.3802, 0.3813   /
      data (CsCBdel( 5 , i, 8 ),i=1,9)/
     + 0.1342, 0.1092, 0.1121, 0.1589, 0.1442,
     + 0.1474, 0.1612, 0.1593, 0.1552   /
      data (CsCBdel( 6 , i, 8 ),i=1,9)/
     + 0.03585, 0.02589, 0.02376, 0.03845, 0.03347,
     + 0.03359, 0.0368, 0.03715, 0.03315   /
      data (BsCBdel( i, 8 ),i=1,9)/
     + 0.006753, 0.004403, 0.002434, 0.001282, 0.0006546,
     + 0.0003271, 0.0001599, 7.58e-05, 3.417e-05   /
      data ZsCBdel(9)/ 14 /
      data (AsCBdel( 1 , i, 9 ),i=1,9)/
     + -0.482, -0.3436, 1.032, 1.099, -0.2834,
     + 0.7271, 0.4975, -0.3009, -0.3203   /
      data (AsCBdel( 2 , i, 9 ),i=1,9)/
     + 0.1315, 0.1377, 0.1022, 0.1591, 0.2496,
     + 0.2229, 0.2438, 0.2875, 0.2946   /
      data (AsCBdel( 3 , i, 9 ),i=1,9)/
     + -0.005324, -0.002923, -0.0008502, -0.000928, -0.001066,
     + -0.0003526, -0.000212, -0.0002344, -0.0001483   /
      data (AsCBdel( 4 , i, 9 ),i=1,9)/
     + 0.0001555, 4.879e-05, 9.499e-06, 4.498e-06, 2.597e-06,
     + 3.532e-07, 1.095e-07, 1.34e-07, 5.275e-08   /
      data (CsCBdel( 0 , i, 9 ),i=1,9)/
     + 0.7947, 0.8286, -1.163, -1.429, 0.6795,
     + -1.002, -0.6834, 0.5116, 0.4764   /
      data (CsCBdel( 1 , i, 9 ),i=1,9)/
     + 0.7724, 1.09, -1.231, -1.651, 1.068,
     + -1.165, -0.7525, 0.7734, 0.7112   /
      data (CsCBdel( 2 , i, 9 ),i=1,9)/
     + 0.5181, 0.8414, -0.8242, -1.192, 0.9573,
     + -0.8474, -0.5102, 0.6779, 0.6173   /
      data (CsCBdel( 3 , i, 9 ),i=1,9)/
     + 0.2907, 0.5252, -0.4605, -0.7067, 0.6767,
     + -0.5094, -0.2811, 0.4676, 0.4236   /
      data (CsCBdel( 4 , i, 9 ),i=1,9)/
     + 0.1401, 0.2746, -0.2163, -0.3463, 0.3866,
     + -0.2545, -0.1267, 0.257, 0.2332   /
      data (CsCBdel( 5 , i, 9 ),i=1,9)/
     + 0.05502, 0.1131, -0.0786, -0.1295, 0.1657,
     + -0.09712, -0.04289, 0.1034, 0.09503   /
      data (CsCBdel( 6 , i, 9 ),i=1,9)/
     + 0.01353, 0.02768, -0.01661, -0.02797, 0.03978,
     + -0.02127, -0.008133, 0.02257, 0.02181   /
      data (BsCBdel( i, 9 ),i=1,9)/
     + 0.009832, 0.005141, 0.002487, 0.001379, 0.0008077,
     + 0.0003422, 0.0001768, 0.0001453, 8.163e-05   /
      data ZsCBdel(10)/ 18 /
      data (AsCBdel( 1 , i, 10 ),i=1,9)/
     + 0.07435, -0.5446, -0.4682, 0.7745, 0.7001,
     + 0.3434, 0.5462, 0.5349, 0.7525   /
      data (AsCBdel( 2 , i, 10 ),i=1,9)/
     + 0.1468, 0.2051, 0.1962, 0.1519, 0.2065,
     + 0.2461, 0.244, 0.2528, 0.2519   /
      data (AsCBdel( 3 , i, 10 ),i=1,9)/
     + -0.0171, -0.009645, -0.004136, -0.001032, -0.001017,
     + -0.0007181, -0.0002647, -0.0001264, -4.787e-05   /
      data (AsCBdel( 4 , i, 10 ),i=1,9)/
     + 0.001165, 0.0003634, 9.998e-05, 2.092e-05, 8.324e-06,
     + 2.704e-06, 4.327e-07, 8.662e-08, 1.365e-08   /
      data (CsCBdel( 0 , i, 10 ),i=1,9)/
     + -0.1127, 0.7818, 0.9303, -0.8353, -0.8852,
     + -0.4207, -0.7605, -0.7908, -1.209   /
      data (CsCBdel( 1 , i, 10 ),i=1,9)/
     + -0.3553, 0.6983, 1.183, -0.8358, -0.9938,
     + -0.4465, -0.8634, -0.901, -1.464   /
      data (CsCBdel( 2 , i, 10 ),i=1,9)/
     + -0.2223, 0.3838, 0.8746, -0.525, -0.7013,
     + -0.3085, -0.6144, -0.6357, -1.093   /
      data (CsCBdel( 3 , i, 10 ),i=1,9)/
     + -0.1378, 0.1706, 0.515, -0.2731, -0.4069,
     + -0.1814, -0.3613, -0.365, -0.661   /
      data (CsCBdel( 4 , i, 10 ),i=1,9)/
     + -0.06122, 0.06301, 0.2496, -0.1187, -0.1946,
     + -0.0904, -0.1764, -0.171, -0.3252   /
      data (CsCBdel( 5 , i, 10 ),i=1,9)/
     + -0.02011, 0.01852, 0.09367, -0.03974, -0.07045,
     + -0.03483, -0.0657, -0.05986, -0.1192   /
      data (CsCBdel( 6 , i, 10 ),i=1,9)/
     + -0.003889, 0.003374, 0.02073, -0.00764, -0.0145,
     + -0.007855, -0.01405, -0.01164, -0.02465   /
      data (BsCBdel( i, 10 ),i=1,9)/
     + 0.02169, 0.01125, 0.005761, 0.002826, 0.001516,
     + 0.0007845, 0.0003452, 0.0001566, 6.648e-05   /
      data ZsCBdel(11)/ 54 /
      data (AsCBdel( 1 , i, 11 ),i=1,9)/
     + 0.2544, 0.004937, 0.4132, 0.6066, 1.275,
     + 1.901, 2.456, 2.576, 2.764   /
      data (AsCBdel( 2 , i, 11 ),i=1,9)/
     + -0.01013, 0.01016, 0.007881, 0.03123, 0.03961,
     + 0.06741, 0.1035, 0.1455, 0.1742   /
      data (AsCBdel( 3 , i, 11 ),i=1,9)/
     + 0.0004744, -3.434e-05, 0.0001231, -5.982e-05, -2.316e-05,
     + -3.843e-05, -4.707e-05, -4.937e-05, -2.956e-05   /
      data (AsCBdel( 4 , i, 11 ),i=1,9)/
     + 8.157e-07, 4.271e-08, 6.323e-08, 8.043e-07, 1.212e-08,
     + 1.6e-08, 1.522e-08, 1.106e-08, 2.676e-09   /
      data (CsCBdel( 0 , i, 11 ),i=1,9)/
     + -0.299, 0.1747, -0.3684, -0.5942, -1.543,
     + -2.5, -3.457, -3.721, -4.118   /
      data (CsCBdel( 1 , i, 11 ),i=1,9)/
     + -0.4626, 0.1589, -0.5238, -0.7772, -1.885,
     + -3.017, -4.248, -4.562, -5.088   /
      data (CsCBdel( 2 , i, 11 ),i=1,9)/
     + -0.2444, 0.3334, -0.2262, -0.5135, -1.412,
     + -2.28, -3.275, -3.508, -3.943   /
      data (CsCBdel( 3 , i, 11 ),i=1,9)/
     + -0.3055, 0.08116, -0.1946, -0.3306, -0.8995,
     + -1.426, -2.084, -2.212, -2.495   /
      data (CsCBdel( 4 , i, 11 ),i=1,9)/
     + -0.04217, 0.1795, -0.07936, -0.178, -0.4912,
     + -0.7426, -1.099, -1.146, -1.288   /
      data (CsCBdel( 5 , i, 11 ),i=1,9)/
     + -0.154, 0.05137, -0.02414, -0.07568, -0.2145,
     + -0.2989, -0.4425, -0.4457, -0.4933   /
      data (CsCBdel( 6 , i, 11 ),i=1,9)/
     + -0.01718, 0.02234, -0.004597, -0.01957, -0.05626,
     + -0.07006, -0.1017, -0.09934, -0.1057   /
      data (BsCBdel( i, 11 ),i=1,9)/
     + 0.009027, 0.001564, 0.002333, 0.001623, 0.0004254,
     + 0.0002607, 0.000166, 0.0001006, 4.482e-05   /
+PATCH,HEEDINT.
+DECK,GASHEE.
       SUBROUTINE GASHEE(IFAIL)
*-----------------------------------------------------------------------
*   GASHEE - Sets the gas composition for HEED
*   (Last changed on 14/ 1/00.)
*-----------------------------------------------------------------------
      implicit none
+SEQ,DIMENSIONS.
+SEQ,GASDATA.
+SEQ,PRINTPLOT.
+SEQ,molecule.
+SEQ,goevent.
       REAL pwmol(pqmol),FRTOT,AUX
       INTEGER qmol,nmol(pqmol),IFAIL,INPTYP,INPCMP,IFAIL1,IERROR,
     -      INEXT,NWORD,I,IOS
       LOGICAL USED(pqmol)
       EXTERNAL INPTYP,INPCMP
+SELF,IF=SAVE.
       SAVE qmol,nmol,pwmol
+SELF.
*** Identify.
       IF(LIDENT)PRINT *,' /// ROUTINE GASHEE ///'
       PRINT *,' ------ GASHEE MESSAGE : Heed version 1.01,'//
     -      ' interface last changed on 14/1/00.'
*** Assume the routine will fail.
       IFAIL=1
*** Initialise the gas mix.
       DO 20 I=1,pqmol
       USED(I)=.FALSE.
20     CONTINUE
       qmol=0
*** Determine number of words.
       CALL INPNUM(NWORD)
*** Loop over the input.
       INEXT=2
       DO 10 I=2,NWORD
       IF(I.LT.INEXT)GOTO 10
*** Fractions, first Argon.
       IF(INPCMP(I,'AR#GON').NE.0)THEN
            IF(INPTYP(I+1).NE.1.AND.INPTYP(I+1).NE.2.OR.I.GE.NWORD)THEN
                 CALL INPMSG(I,'Argument invalid or missing.  ')
            ELSEIF(USED(numm_Ar))THEN
                 CALL INPMSG(I,'Gas already referenced.')
            ELSE
                 CALL INPCHK(I+1,2,IFAIL1)
                 CALL INPRDR(I+1,AUX,0.0)
                 qmol=qmol+1
                 nmol(qmol)=numm_Ar
                 pwmol(qmol)=AUX
                 USED(numm_Ar)=.TRUE.
            ENDIF
            INEXT=I+2
*   Methane.
       ELSEIF(INPCMP(I,'METHA#NE')+INPCMP(I,'CH4').NE.0)THEN
            IF(INPTYP(I+1).NE.1.AND.INPTYP(I+1).NE.2.OR.I.GE.NWORD)THEN
                 CALL INPMSG(I,'Argument invalid or missing.  ')
            ELSEIF(USED(numm_CH4))THEN
                 CALL INPMSG(I,'Gas already referenced.')
            ELSE
                 CALL INPCHK(I+1,2,IFAIL1)
                 CALL INPRDR(I+1,AUX,0.0)
                 qmol=qmol+1
                 nmol(qmol)=numm_CH4
                 pwmol(qmol)=AUX
                 USED(numm_CH4)=.TRUE.
            ENDIF
            INEXT=I+2
*   Nitrogen.
       ELSEIF(INPCMP(I,'NI#TROGEN')+INPCMP(I,'N2').NE.0)THEN
            IF(INPTYP(I+1).NE.1.AND.INPTYP(I+1).NE.2.OR.I.GE.NWORD)THEN
                 CALL INPMSG(I,'Argument invalid or missing.  ')
            ELSEIF(USED(numm_N2))THEN
                 CALL INPMSG(I,'Gas already referenced.')
            ELSE
                 CALL INPCHK(I+1,2,IFAIL1)
                 CALL INPRDR(I+1,AUX,0.0)
                 qmol=qmol+1
                 nmol(qmol)=numm_N2
                 pwmol(qmol)=AUX
                 USED(numm_N2)=.TRUE.
            ENDIF
            INEXT=I+2
*   CO2.
       ELSEIF(INPCMP(I,'CO2')+
     -      INPCMP(I,'CARB#ON-DIOX#IDE').NE.0)THEN
            IF(INPTYP(I+1).NE.1.AND.INPTYP(I+1).NE.2.OR.I.GE.NWORD)THEN
                 CALL INPMSG(I,'Argument invalid or missing.  ')
            ELSEIF(USED(numm_CO2))THEN
                 CALL INPMSG(I,'Gas already referenced.')
            ELSE
                 CALL INPCHK(I+1,2,IFAIL1)
                 CALL INPRDR(I+1,AUX,0.0)
                 qmol=qmol+1
                 nmol(qmol)=numm_CO2
                 pwmol(qmol)=AUX
                 USED(numm_CO2)=.TRUE.
            ENDIF
            INEXT=I+2
*   Helium 4.
       ELSEIF(INPCMP(I,'HE#LIUM-#4').NE.0)THEN
            IF(INPTYP(I+1).NE.1.AND.INPTYP(I+1).NE.2.OR.I.GE.NWORD)THEN
                 CALL INPMSG(I,'Argument invalid or missing.  ')
            ELSEIF(USED(numm_He))THEN
                 CALL INPMSG(I,'Gas already referenced.')
            ELSE
                 CALL INPCHK(I+1,2,IFAIL1)
                 CALL INPRDR(I+1,AUX,0.0)
                 qmol=qmol+1
                 nmol(qmol)=numm_He
                 pwmol(qmol)=AUX
                 USED(numm_He)=.TRUE.
            ENDIF
            INEXT=I+2
*   Helium 3.
       ELSEIF(INPCMP(I,'HE#LIUM-3').NE.0)THEN
            CALL INPMSG(I,'Not yet in HEED.')
            INEXT=I+2
*   Neon.
       ELSEIF(INPCMP(I,'NEON').NE.0)THEN
            IF(INPTYP(I+1).NE.1.AND.INPTYP(I+1).NE.2.OR.I.GE.NWORD)THEN
                 CALL INPMSG(I,'Argument invalid or missing.  ')
            ELSEIF(USED(numm_Ne))THEN
                 CALL INPMSG(I,'Gas already referenced.')
            ELSE
                 CALL INPCHK(I+1,2,IFAIL1)
                 CALL INPRDR(I+1,AUX,0.0)
                 qmol=qmol+1
                 nmol(qmol)=numm_Ne
                 pwmol(qmol)=AUX
                 USED(numm_Ne)=.TRUE.
            ENDIF
            INEXT=I+2
*   Ethane.
       ELSEIF(INPCMP(I,'ETHA#NE')+INPCMP(I,'C2H6').NE.0)THEN
            IF(INPTYP(I+1).NE.1.AND.INPTYP(I+1).NE.2.OR.I.GE.NWORD)THEN
                 CALL INPMSG(I,'Argument invalid or missing.  ')
            ELSEIF(USED(numm_C2H6))THEN
                 CALL INPMSG(I,'Gas already referenced.')
            ELSE
                 CALL INPCHK(I+1,2,IFAIL1)
                 CALL INPRDR(I+1,AUX,0.0)
                 qmol=qmol+1
                 nmol(qmol)=numm_C2H6
                 pwmol(qmol)=AUX
                 USED(numm_C2H6)=.TRUE.
            ENDIF
            INEXT=I+2
*   Propane.
       ELSEIF(INPCMP(I,'PROPA#NE')+INPCMP(I,'C3H8').NE.0)THEN
            IF(INPTYP(I+1).NE.1.AND.INPTYP(I+1).NE.2.OR.I.GE.NWORD)THEN
                 CALL INPMSG(I,'Argument invalid or missing.  ')
            ELSEIF(USED(numm_C3H8))THEN
                 CALL INPMSG(I,'Gas already referenced.')
            ELSE
                 CALL INPCHK(I+1,2,IFAIL1)
                 CALL INPRDR(I+1,AUX,0.0)
                 qmol=qmol+1
                 nmol(qmol)=numm_C3H8
                 pwmol(qmol)=AUX
                 USED(numm_C3H8)=.TRUE.
            ENDIF
            INEXT=I+2
*   Isobutane.
       ELSEIF(INPCMP(I,'ISO#BUTANE')+INPCMP(I,'C4H10').NE.0)THEN
            IF(INPTYP(I+1).NE.1.AND.INPTYP(I+1).NE.2.OR.I.GE.NWORD)THEN
                 CALL INPMSG(I,'Argument invalid or missing.  ')
            ELSEIF(USED(numm_iC4H10))THEN
                 CALL INPMSG(I,'Gas already referenced.')
            ELSE
                 CALL INPCHK(I+1,2,IFAIL1)
                 CALL INPRDR(I+1,AUX,0.0)
                 qmol=qmol+1
                 nmol(qmol)=numm_iC4H10
                 pwmol(qmol)=AUX
                 USED(numm_iC4H10)=.TRUE.
            ENDIF
            INEXT=I+2
*   Pentane.
       ELSEIF(INPCMP(I,'PENT#ANE')+INPCMP(I,'C5H12')+
     -      INPCMP(I,'N#EO-PENT#ANE')+INPCMP(I,'N#EO-C5H12').NE.0)THEN
            IF(INPTYP(I+1).NE.1.AND.INPTYP(I+1).NE.2.OR.I.GE.NWORD)THEN
                 CALL INPMSG(I,'Argument invalid or missing.  ')
            ELSEIF(USED(numm_C5H12))THEN
                 CALL INPMSG(I,'Gas already referenced.')
            ELSE
                 CALL INPCHK(I+1,2,IFAIL1)
                 CALL INPRDR(I+1,AUX,0.0)
                 qmol=qmol+1
                 nmol(qmol)=numm_C5H12
                 pwmol(qmol)=AUX
                 USED(numm_C5H12)=.TRUE.
            ENDIF
            INEXT=I+2
*   Methylal.
       ELSEIF(INPCMP(I,'METHY#LAL')+INPCMP(I,'C3H8O2').NE.0)THEN
            CALL INPMSG(I,'Not yet in HEED.')
            INEXT=I+2
*   Xenon.
       ELSEIF(INPCMP(I,'XE#NON').NE.0)THEN
            IF(INPTYP(I+1).NE.1.AND.INPTYP(I+1).NE.2.OR.I.GE.NWORD)THEN
                 CALL INPMSG(I,'Argument invalid or missing.  ')
            ELSEIF(USED(numm_Xe))THEN
                 CALL INPMSG(I,'Gas already referenced.')
            ELSE
                 CALL INPCHK(I+1,2,IFAIL1)
                 CALL INPRDR(I+1,AUX,0.0)
                 qmol=qmol+1
                 nmol(qmol)=numm_Xe
                 pwmol(qmol)=AUX
                 USED(numm_Xe)=.TRUE.
            ENDIF
            INEXT=I+2
*   Krypton.
       ELSEIF(INPCMP(I,'KR#YPTON').NE.0)THEN
            IF(INPTYP(I+1).NE.1.AND.INPTYP(I+1).NE.2.OR.I.GE.NWORD)THEN
                 CALL INPMSG(I,'Argument invalid or missing.  ')
            ELSEIF(USED(numm_Kr))THEN
                 CALL INPMSG(I,'Gas already referenced.')
            ELSE
                 CALL INPCHK(I+1,2,IFAIL1)
                 CALL INPRDR(I+1,AUX,0.0)
                 qmol=qmol+1
                 nmol(qmol)=numm_Kr
                 pwmol(qmol)=AUX
                 USED(numm_Kr)=.TRUE.
            ENDIF
            INEXT=I+2
*   CF4.
       ELSEIF(INPCMP(I,'CF4').NE.0)THEN
            IF(INPTYP(I+1).NE.1.AND.INPTYP(I+1).NE.2.OR.I.GE.NWORD)THEN
                 CALL INPMSG(I,'Argument invalid or missing.  ')
            ELSEIF(USED(numm_CF4))THEN
                 CALL INPMSG(I,'Gas already referenced.')
            ELSE
                 CALL INPCHK(I+1,2,IFAIL1)
                 CALL INPRDR(I+1,AUX,0.0)
                 qmol=qmol+1
                 nmol(qmol)=numm_CF4
                 pwmol(qmol)=AUX
                 USED(numm_CF4)=.TRUE.
            ENDIF
            INEXT=I+2
*   Oxygen.
       ELSEIF(INPCMP(I,'OX#YGEN')+INPCMP(I,'O2').NE.0)THEN
            IF(INPTYP(I+1).NE.1.AND.INPTYP(I+1).NE.2.OR.I.GE.NWORD)THEN
                 CALL INPMSG(I,'Argument invalid or missing.  ')
            ELSEIF(USED(numm_O2))THEN
                 CALL INPMSG(I,'Gas already referenced.')
            ELSE
                 CALL INPCHK(I+1,2,IFAIL1)
                 CALL INPRDR(I+1,AUX,0.0)
                 qmol=qmol+1
                 nmol(qmol)=numm_O2
                 pwmol(qmol)=AUX
                 USED(numm_O2)=.TRUE.
            ENDIF
            INEXT=I+2
*   DME.
       ELSEIF(INPCMP(I,'DME').NE.0)THEN
            IF(INPTYP(I+1).NE.1.AND.INPTYP(I+1).NE.2.OR.I.GE.NWORD)THEN
                 CALL INPMSG(I,'Argument invalid or missing.  ')
            ELSEIF(USED(numm_DME))THEN
                 CALL INPMSG(I,'Gas already referenced.')
            ELSE
                 CALL INPCHK(I+1,2,IFAIL1)
                 CALL INPRDR(I+1,AUX,0.0)
                 qmol=qmol+1
                 nmol(qmol)=numm_DME
                 pwmol(qmol)=AUX
                 USED(numm_DME)=.TRUE.
            ENDIF
            INEXT=I+2
*   Ethene.
       ELSEIF(INPCMP(I,'ETHE#NE')+INPCMP(I,'C2H4').NE.0)THEN
            IF(INPTYP(I+1).NE.1.AND.INPTYP(I+1).NE.2.OR.I.GE.NWORD)THEN
                 CALL INPMSG(I,'Argument invalid or missing.  ')
            ELSEIF(USED(numm_C2H4))THEN
                 CALL INPMSG(I,'Gas already referenced.')
            ELSE
                 CALL INPCHK(I+1,2,IFAIL1)
                 CALL INPRDR(I+1,AUX,0.0)
                 qmol=qmol+1
                 nmol(qmol)=numm_C2H4
                 pwmol(qmol)=AUX
                 USED(numm_C2H4)=.TRUE.
            ENDIF
            INEXT=I+2
*   Acetylene.
       ELSEIF(INPCMP(I,'ACETYL#ENE')+INPCMP(I,'C2H2').NE.0)THEN
            IF(INPTYP(I+1).NE.1.AND.INPTYP(I+1).NE.2.OR.I.GE.NWORD)THEN
                 CALL INPMSG(I,'Argument invalid or missing.  ')
            ELSEIF(USED(numm_C2H2))THEN
                 CALL INPMSG(I,'Gas already referenced.')
            ELSE
                 CALL INPCHK(I+1,2,IFAIL1)
                 CALL INPRDR(I+1,AUX,0.0)
                 qmol=qmol+1
                 nmol(qmol)=numm_C2H2
                 pwmol(qmol)=AUX
                 USED(numm_C2H2)=.TRUE.
            ENDIF
            INEXT=I+2
*   Nitric oxide (NO).
       ELSEIF(INPCMP(I,'NITRI#C-OX#IDE')+INPCMP(I,'NO').NE.0)THEN
            CALL INPMSG(I,'Not yet in HEED.')
            INEXT=I+2
*   Nitrous oxide (N2O).
       ELSEIF(INPCMP(I,'NITRO#US-OX#IDE')+INPCMP(I,'N2O').NE.0)THEN
            IF(INPTYP(I+1).NE.1.AND.INPTYP(I+1).NE.2.OR.I.GE.NWORD)THEN
                 CALL INPMSG(I,'Argument invalid or missing.  ')
            ELSEIF(USED(numm_N2O))THEN
                 CALL INPMSG(I,'Gas already referenced.')
            ELSE
                 CALL INPCHK(I+1,2,IFAIL1)
                 CALL INPRDR(I+1,AUX,0.0)
                 qmol=qmol+1
                 nmol(qmol)=numm_N2O
                 pwmol(qmol)=AUX
                 USED(numm_N2O)=.TRUE.
            ENDIF
            INEXT=I+2
*   Hydrogen gas.
       ELSEIF(INPCMP(I,'HYDR#OGEN')+INPCMP(I,'H2').NE.0)THEN
            IF(INPTYP(I+1).NE.1.AND.INPTYP(I+1).NE.2.OR.I.GE.NWORD)THEN
                 CALL INPMSG(I,'Argument invalid or missing.  ')
            ELSEIF(USED(numm_H2))THEN
                 CALL INPMSG(I,'Gas already referenced.')
            ELSE
                 CALL INPCHK(I+1,2,IFAIL1)
                 CALL INPRDR(I+1,AUX,0.0)
                 qmol=qmol+1
                 nmol(qmol)=numm_H2
                 pwmol(qmol)=AUX
                 USED(numm_H2)=.TRUE.
            ENDIF
            INEXT=I+2
*   Ammonia gas.
       ELSEIF(INPCMP(I,'AMMO#NIA')+INPCMP(I,'NH3').NE.0)THEN
            IF(INPTYP(I+1).NE.1.AND.INPTYP(I+1).NE.2.OR.I.GE.NWORD)THEN
                 CALL INPMSG(I,'Argument invalid or missing.  ')
            ELSEIF(USED(numm_NH3))THEN
                 CALL INPMSG(I,'Gas already referenced.')
            ELSE
                 CALL INPCHK(I+1,2,IFAIL1)
                 CALL INPRDR(I+1,AUX,0.0)
                 qmol=qmol+1
                 nmol(qmol)=numm_NH3
                 pwmol(qmol)=AUX
                 USED(numm_NH3)=.TRUE.
            ENDIF
            INEXT=I+2
*   Water vapour.
       ELSEIF(INPCMP(I,'H2O')+INPCMP(I,'WAT#ER').NE.0)THEN
            IF(INPTYP(I+1).NE.1.AND.INPTYP(I+1).NE.2.OR.I.GE.NWORD)THEN
                 CALL INPMSG(I,'Argument invalid or missing.  ')
            ELSEIF(USED(numm_H2O))THEN
                 CALL INPMSG(I,'Gas already referenced.')
            ELSE
                 CALL INPCHK(I+1,2,IFAIL1)
                 CALL INPRDR(I+1,AUX,0.0)
                 qmol=qmol+1
                 nmol(qmol)=numm_H2O
                 pwmol(qmol)=AUX
                 USED(numm_H2O)=.TRUE.
            ENDIF
            INEXT=I+2
*   SF6.
       ELSEIF(INPCMP(I,'SF6').NE.0)THEN
            IF(INPTYP(I+1).NE.1.AND.INPTYP(I+1).NE.2.OR.I.GE.NWORD)THEN
                 CALL INPMSG(I,'Argument invalid or missing.  ')
            ELSEIF(USED(numm_SF6))THEN
                 CALL INPMSG(I,'Gas already referenced.')
            ELSE
                 CALL INPCHK(I+1,2,IFAIL1)
                 CALL INPRDR(I+1,AUX,0.0)
                 qmol=qmol+1
                 nmol(qmol)=numm_SF6
                 pwmol(qmol)=AUX
                 USED(numm_SF6)=.TRUE.
            ENDIF
            INEXT=I+2
*   C2F4H2 (1,1,1,2 tetrafluoroethane, HFC-134a).
       ELSEIF(INPCMP(I,'C2F4H2')+INPCMP(I,'C2H2F4')+
     -      INPCMP(I,'CH2FCF3')+
     -      INPCMP(I,'HFC-134A').NE.0)THEN
            IF(INPTYP(I+1).NE.1.AND.INPTYP(I+1).NE.2.OR.I.GE.NWORD)THEN
                 CALL INPMSG(I,'Argument invalid or missing.  ')
            ELSEIF(USED(numm_C2F4H2))THEN
                 CALL INPMSG(I,'Gas already referenced.')
            ELSE
                 CALL INPCHK(I+1,2,IFAIL1)
                 CALL INPRDR(I+1,AUX,0.0)
                 qmol=qmol+1
                 nmol(qmol)=numm_C2F4H2
                 pwmol(qmol)=AUX
                 USED(numm_C2F4H2)=.TRUE.
            ENDIF
            INEXT=I+2
*   C2F5H (?).
       ELSEIF(INPCMP(I,'C2F5H')+INPCMP(I,'C2HF5').NE.0)THEN
            IF(INPTYP(I+1).NE.1.AND.INPTYP(I+1).NE.2.OR.I.GE.NWORD)THEN
                 CALL INPMSG(I,'Argument invalid or missing.  ')
            ELSEIF(USED(numm_C2F5H))THEN
                 CALL INPMSG(I,'Gas already referenced.')
            ELSE
                 CALL INPCHK(I+1,2,IFAIL1)
                 CALL INPRDR(I+1,AUX,0.0)
                 qmol=qmol+1
                 nmol(qmol)=numm_C2F5H
                 pwmol(qmol)=AUX
                 USED(numm_C2F5H)=.TRUE.
            ENDIF
            INEXT=I+2
*   All the rest is not known.
       ELSE
            CALL INPMSG(I,'Not a known keyword.')
       ENDIF
10     CONTINUE
*** Print the error messages accumulated sofar.
       CALL INPERR
*** Renormalise the fractions.
       FRTOT=0.0
       DO 120 I=1,qmol
       IF(pwmol(I).LT.0)pwmol(I)=0.0
       FRTOT=FRTOT+pwmol(I)
120    CONTINUE
       IF(FRTOT.LE.0.0)THEN
            PRINT *,' !!!!!! GASHEE WARNING : Please have at least'//
     -           ' one gas in your mixture; nothing done.'
            IFAIL=1
            RETURN
       ELSE
            DO 130 I=1,qmol
            pwmol(I)=pwmol(I)/FRTOT
130         CONTINUE
       ENDIF
*** Debugging information.
       IF(LDEBUG)THEN
            WRITE(LUNOUT,'(''  ++++++ GASHEE DEBUG   : Gas mix'',
     -           '' composed as follows:'')')
            DO 30 I=1,qmol
            IF(nmol(i).eq.numm_He)THEN
                 WRITE(LUNOUT,'(26X,''Helium       '',F10.3,'' %'')')
     -                100*pwmol(I)
            ELSEIF(nmol(i).eq.numm_Ne)THEN
                 WRITE(LUNOUT,'(26X,''Neon         '',F10.3,'' %'')')
     -                100*pwmol(I)
            ELSEIF(nmol(i).eq.numm_Ar)THEN 
                 WRITE(LUNOUT,'(26X,''Argon        '',F10.3,'' %'')')
     -                100*pwmol(I)
            ELSEIF(nmol(i).eq.numm_Kr)THEN
                 WRITE(LUNOUT,'(26X,''Krypton      '',F10.3,'' %'')')
     -                100*pwmol(I)
            ELSEIF(nmol(i).eq.numm_Xe)THEN
                 WRITE(LUNOUT,'(26X,''Xenon        '',F10.3,'' %'')')
     -                100*pwmol(I)
            ELSEIF(nmol(i).eq.numm_H2)THEN
                 WRITE(LUNOUT,'(26X,''H2           '',F10.3,'' %'')')
     -                100*pwmol(I)
            ELSEIF(nmol(i).eq.numm_N2)THEN
                 WRITE(LUNOUT,'(26X,''N2           '',F10.3,'' %'')')
     -                100*pwmol(I)
            ELSEIF(nmol(i).eq.numm_O2)THEN
                 WRITE(LUNOUT,'(26X,''O2           '',F10.3,'' %'')')
     -                100*pwmol(I)
            ELSEIF(nmol(i).eq.numm_NH3)THEN
                 WRITE(LUNOUT,'(26X,''NH3          '',F10.3,'' %'')')
     -                100*pwmol(I)
            ELSEIF(nmol(i).eq.numm_N2O)THEN
                 WRITE(LUNOUT,'(26X,''N2O          '',F10.3,'' %'')')
     -                100*pwmol(I)
            ELSEIF(nmol(i).eq.numm_CO2)THEN
                 WRITE(LUNOUT,'(26X,''CO2          '',F10.3,'' %'')')
     -                100*pwmol(I)
            ELSEIF(nmol(i).eq.numm_CF4)THEN
                 WRITE(LUNOUT,'(26X,''CF4          '',F10.3,'' %'')')
     -                100*pwmol(I)
            ELSEIF(nmol(i).eq.numm_CH4)THEN
                 WRITE(LUNOUT,'(26X,''CH4          '',F10.3,'' %'')')
     -                100*pwmol(I)
            ELSEIF(nmol(i).eq.numm_C2H2)THEN
                 WRITE(LUNOUT,'(26X,''C2H2         '',F10.3,'' %'')')
     -                100*pwmol(I)
            ELSEIF(nmol(i).eq.numm_C2H4)THEN
                 WRITE(LUNOUT,'(26X,''C2H4         '',F10.3,'' %'')')
     -                100*pwmol(I)
            ELSEIF(nmol(i).eq.numm_C2H6)THEN
                 WRITE(LUNOUT,'(26X,''C2H6         '',F10.3,'' %'')')
     -                100*pwmol(I)
            ELSEIF(nmol(i).eq.numm_C3H8)THEN
                 WRITE(LUNOUT,'(26X,''C3H8         '',F10.3,'' %'')')
     -                100*pwmol(I)
            ELSEIF(nmol(i).eq.numm_iC4H10)THEN
                 WRITE(LUNOUT,'(26X,''iC4H10       '',F10.3,'' %'')')
     -                100*pwmol(I)
            ELSEIF(nmol(i).eq.numm_C5H12)THEN
                 WRITE(LUNOUT,'(26X,''C5H12        '',F10.3,'' %'')')
     -                100*pwmol(I)
            ELSEIF(nmol(i).eq.numm_DME)THEN
                 WRITE(LUNOUT,'(26X,''DME          '',F10.3,'' %'')')
     -                100*pwmol(I)
            ELSEIF(nmol(i).eq.numm_H2O)THEN
                 WRITE(LUNOUT,'(26X,''H2O          '',F10.3,'' %'')')
     -                100*pwmol(I)
            ELSEIF(nmol(i).eq.numm_SF6)THEN
                 WRITE(LUNOUT,'(26X,''SF6          '',F10.3,'' %'')')
     -                100*pwmol(I)
            ELSEIF(nmol(i).eq.numm_C2F4H2)THEN
                 WRITE(LUNOUT,'(26X,''C2F4H2       '',F10.3,'' %'')')
     -                100*pwmol(I)
            ELSEIF(nmol(i).eq.numm_C2F5H)THEN
                 WRITE(LUNOUT,'(26X,''C2F5H        '',F10.3,'' %'')')
     -                100*pwmol(I)
            ELSE
                 WRITE(LUNOUT,'(26X,''# Unknown #  '',F10.3,'' %'')') 
     -                100*pwmol(I)
            ENDIF
30          CONTINUE
            WRITE(LUNOUT,'(26X,''Pressure:    '',F10.3,'' torr''/
     -           26X,''Temperature: '',F10.3,'' K'')') PGAS,TGAS
       ENDIF
*** Set HEED printing and error monitoring flags.
       IF(LDEBUG)THEN
            soo=1
       ELSE
            soo=0
       ENDIF
       oo=LUNOUT
       s_err=0
*** Call the HEED gas routine.
       ierror=0
       CALL imheed(
     -      qmol,       ! Different gas components
     -      nmol,       ! Names of gasses present in mixture
     -      pwmol,      ! Gas fractions  
     -      PGAS,       ! Pressure [torr]
     -      TGAS,       ! Temperature [K]
     -      1,          ! 0 or 1: Do/don't  generate output
     -      6,          ! Output logical unit
     -      1,          ! 1/2 Short/Medium listing
     -      GASDEN,     ! (Output) computed density
     -      ierror)     ! Error indicator.
       IF(LDEBUG)WRITE(LUNOUT,'(''  ++++++ GASHEE DEBUG   :'',
     -      '' HEED density: '',F10.3,'' g/l, error code: '',I3)')
     -      1000*GASDEN,ierror
*** Return error code.
       IF(ierror.NE.0)THEN
            PRINT *,' !!!!!! GASHEE WARNING : Gas preparation by'//
     -           ' HEED failed ; tracks can not be generated.'
            IFAIL=1
            HEEDOK=.FALSE.
       ELSE
            IFAIL=0
            HEEDOK=.TRUE.
       ENDIF
       RETURN
*** Write the tables.
       ENTRY GASHWR(IFAIL)
*   Assume for the moment that writing will work.
       IFAIL=0
*   See whether iniialisation has been performed.
       WRITE(12,'(''  Heed initialisation done: '',L1)',ERR=2010,
     -      IOSTAT=IOS) HEEDOK
       IF(HEEDOK)THEN
*   Write the composition.
            WRITE(12,'(''  Gas components: '',I5)',ERR=2010,
     -           IOSTAT=IOS) qmol
            DO 200 I=1,qmol
            WRITE(12,'(2X,I10,E15.8)',ERR=2010,IOSTAT=IOS) 
     -           nmol(I),pwmol(I)
200         CONTINUE
       ENDIF
       RETURN
*   Errors during I/O.
2010   CONTINUE
       PRINT *,' !!!!!! GASHWR WARNING : I/O error occurred while'//
     -      ' writing Heed initialisation data.'
       CALL INPIOS(IOS)
       IFAIL=1
       RETURN
*** Retrieve initialisation data.
       ENTRY GASHGT(IFAIL)
*   Assume for the moment that reading will work.
       IFAIL=0
*   See whether initialisation should be performed.
       READ(12,'(28X,L1)',ERR=2015,IOSTAT=IOS) HEEDOK
       IF(HEEDOK)THEN
*   Read the composition.
            READ(12,'(18X,I5)',ERR=2015,IOSTAT=IOS) qmol
            IF(qmol.LT.0.OR.qmol.GT.pqmol)THEN
                 PRINT *,' !!!!!! GASHGT WARNING : Number of gas'//
     -                ' components < 0 or > current maximum; Heed'//
     -                ' initialisation not performed.'
                 RETURN
            ENDIF
            DO 210 I=1,qmol
            READ(12,'(2X,I10,E15.8)',ERR=2015,IOSTAT=IOS) 
     -           nmol(I),pwmol(I)
210         CONTINUE
*   Perform the initialisation.
            ierror=0
            CALL imheed(
     -           qmol,       ! Different gas components
     -           nmol,       ! Names of gasses present in mixture
     -           pwmol,      ! Gas fractions  
     -           PGAS,       ! Pressure [torr]
     -           TGAS,       ! Temperature [K]
     -           1,          ! 0 or 1: Do/don't  generate output
     -           6,          ! Output logical unit
     -           1,          ! 1/2 Short/Medium listing
     -           GASDEN,     ! (Output) computed density
     -           ierror)     ! Error indicator.
            IF(LDEBUG)WRITE(LUNOUT,'(''  ++++++ GASHEE DEBUG   :'',
     -           '' HEED density: '',F10.3,'' g/l, error code: '',I3)')
     -           1000*GASDEN,ierror
*   Return error code.
            IF(ierror.NE.0)THEN
                 PRINT *,' !!!!!! GASHGT WARNING : Gas preparation by'//
     -                ' HEED failed ; tracks can not be generated.'
                 IFAIL=1
                 HEEDOK=.FALSE.
            ELSE
                 IFAIL=0
                 HEEDOK=.TRUE.
            ENDIF
       ENDIF
       RETURN
*   Errors during I/O.
2015   CONTINUE
       PRINT *,' !!!!!! GASHGT WARNING : I/O error occurred while'//
     -      ' retrieving Heed initialisation data.'
       CALL INPIOS(IOS)
       IFAIL=1
       END
+DECK,TRAINT
       SUBROUTINE TRAINT
*-----------------------------------------------------------------------
*   TRAINT - Initialises the track.
*   (Last changed on 14/ 5/99.)
*-----------------------------------------------------------------------
      implicit none
+SEQ,DIMENSIONS.
+SEQ,PARAMETERS.
       INTEGER I
*** Reset all the track flags.
       DO 10 I=1,10
       TRFLAG(I)=.FALSE.
10     CONTINUE
*** Set the track type (fixed number of points).
       ITRTYP=0
*** Set default number of lines.
       NTRLIN=20
       TRFLAG(3)=.TRUE.
*** Default number of samples.
       NTRSAM=100
       TRFLAG(5)=.TRUE.
*** Default number of flux lines.
       NTRFLX=20
       TRFLAG(6)=.TRUE.
*** Default flux interval.
       TRFLUX=10
       TRFLAG(7)=.TRUE.
*** Set some track.
       XT0=0.0
       YT0=0.0
       ZT0=0.0
       XT1=0.0
       YT1=0.0
       ZT1=0.0
       TRTH=0
       TRPHI=0
*** Reset the options.
       LTRMS =.FALSE.
       LTRDEL=.TRUE.
       LTRINT=.FALSE.
       LTREXB=.TRUE.
*** Reset the track interpolation table.
       CALL DLCTRR
*** Set a default particle type and energy (a 1 GeV mu-)
       TRMASS=105.658389
       TRCHAR=-1.0
       TRENER=1000.0
*** Particle identifier.
       PARTID='Unknown'
       PNAME='Unknown'
       NCPNAM=7
       END
+DECK,TRACLS.
       SUBROUTINE TRACLS(XCLS,YCLS,ZCLS,ECLS,NPAIR,DONE,IFAIL)
*-----------------------------------------------------------------------
*   TRACLS - Generates new clusters along the track.
*   TRACLI - Initialisation.
*   (Last changed on 24/ 9/00.)
*-----------------------------------------------------------------------
      implicit none
+SEQ,DIMENSIONS.
+SEQ,GASDATA.
+SEQ,PARAMETERS.
+SEQ,PRINTPLOT.
+SEQ,CONSTANTS.
+SEQ,volume.
+SEQ,goevent.
+SEQ,del.
+SEQ,cel.
+SEQ,abs.
+SEQ,rga.
+SEQ,lsgvga.
       REAL XCLS,YCLS,ZCLS,ECLS,TRALEN,DIST,RNDEXP,RNDM,XAUX,YAUX,ZAUX,
     -      DISVGA(pqgvga),EDELTA,ETOT,XP,YP,ZP,Q,FLXSUM,FLXCOO(MXLIST),
     -      FLXTAB(MXLIST),DIVDIF,XL,XL0FLX,XL1FLX
       DOUBLE PRECISION XRAN
       INTEGER NPAIR,NTOT,NDELTA,IVGA,ICEL,I,J,IERROR,IFAIL,IPRINT,
     -      NCAUX,NV,ISIGN,JPRINT
       LOGICAL DONE,OK
       CHARACTER*20 AUX
       EXTERNAL RNDEXP,RNDM
+SELF,IF=SAVE.
       SAVE NTOT,TRALEN,DIST,OK,IVGA,ICEL,ETOT,FLXCOO,FLXTAB,FLXSUM,
     -      XL0FLX,XL1FLX
+SELF.
       DATA OK/.FALSE./
*** Identify the routine if requested.
       IF(LIDENT)PRINT *,' /// ROUTINE TRACLS ///'
*** Initial settings.
       XCLS=0
       YCLS=0
       ZCLS=0
       ECLS=0
       NPAIR=0
       DONE=.TRUE.
       IFAIL=1
*** Make sure the routine is in the proper state.
       IF(.NOT.OK)THEN
            PRINT *,' !!!!!! TRACLS WARNING : Track initialisation'//
     -           ' not done or track complete; no clusters.'
            RETURN
*** Verify that track parameters are available.
       ELSEIF(.NOT.TRFLAG(1))THEN
            PRINT *,' !!!!!! TRACLS WARNING : Track location is not'//
     -           ' set; no clusters.'
            RETURN
       ENDIF
*** Handle the case of a fixed number of clusters.
       IF(ITRTYP.EQ.1)THEN
*   Ensure that the number is reasonable.
            IF(.NOT.TRFLAG(3))THEN
                 PRINT *,' !!!!!! TRACLS WARNING : Number of points'//
     -                ' on the track not defined; no clusters.'
                 RETURN
            ENDIF
*   Increment cluster counter.
            NTOT=NTOT+1
*   Compute new cluster position.
            IF(NTRLIN.GT.1)THEN
                 XCLS=XT0+REAL(NTOT-1)*(XT1-XT0)/REAL(NTRLIN-1)
                 YCLS=YT0+REAL(NTOT-1)*(YT1-YT0)/REAL(NTRLIN-1)
                 ZCLS=ZT0+REAL(NTOT-1)*(ZT1-ZT0)/REAL(NTRLIN-1)
            ELSE
                 XCLS=0.5*(XT0+XT1)
                 YCLS=0.5*(YT0+YT1)
                 ZCLS=0.5*(ZT0+ZT1)
            ENDIF
*   Set cluster size and energy.
            NPAIR=1
            ECLS=-1
*   See whether we were already done.
            IF(NTOT.GT.NTRLIN)THEN
                 DONE=.TRUE.
                 OK=.FALSE.
            ELSE
                 DONE=.FALSE.
            ENDIF
*** Fixed number of clusters at weighted positions.
       ELSEIF(ITRTYP.EQ.5)THEN
*   Ensure that the number is reasonable.
            IF(.NOT.TRFLAG(4))THEN
                 PRINT *,' !!!!!! TRACLS WARNING : Weighting function'//
     -                ' on the track not defined; no clusters.'
                 RETURN
            ELSEIF(.NOT.TRFLAG(5))THEN
                 PRINT *,' !!!!!! TRACLS WARNING : Number of points'//
     -                ' on the track not defined; no clusters.'
                 RETURN
            ENDIF
*   Increment cluster counter.
            NTOT=NTOT+1
*   Compute new cluster position.
            CALL HISRAD(WGT,MXLIST,0.0D0,1.0D0/MXLIST,XRAN)
            XCLS=XT0+REAL(XRAN)*(XT1-XT0)
            YCLS=YT0+REAL(XRAN)*(YT1-YT0)
            ZCLS=ZT0+REAL(XRAN)*(ZT1-ZT0)
*   Set cluster size and energy.
            NPAIR=1
            ECLS=-1
*   See whether we were already done.
            IF(NTOT.GT.NTRSAM)THEN
                 DONE=.TRUE.
                 OK=.FALSE.
            ELSE
                 DONE=.FALSE.
            ENDIF
*** One cluster at a random location.
       ELSEIF(ITRTYP.EQ.6)THEN
*   Increment cluster counter.
            NTOT=NTOT+1
*   Compute new cluster position.
            XRAN=DBLE(RNDM(NTOT))
            XCLS=XT0+REAL(XRAN)*(XT1-XT0)
            YCLS=YT0+REAL(XRAN)*(YT1-YT0)
            ZCLS=ZT0+REAL(XRAN)*(ZT1-ZT0)
*   Set the cluster size and energy.
            IF(GASOK(5))THEN
                 CALL HISRAD(CLSDIS,NCLS,0.0D0,1.0D0,XRAN)
                 NPAIR=INT(XRAN)
                 ECLS=NPAIR*EPAIR
            ELSE
                 NPAIR=1
                 ECLS=0
            ENDIF
*   See whether we were already done.
            IF(NTOT.GT.1)THEN
                 DONE=.TRUE.
                 OK=.FALSE.
            ELSE
                 DONE=.FALSE.
            ENDIF
*** Handle the case of equally spaced clusters according to CMEAN.
       ELSEIF(ITRTYP.EQ.2)THEN
*   Ensure that the appropriate gas data is present.
            IF(.NOT.GASOK(5))THEN
                 PRINT *,' !!!!!! TRACLS WARNING : Clustering data'//
     -                ' from gas section missing; track not set.'
                 RETURN
            ENDIF
*   Store track length.
            IF(NTOT.EQ.0)
     -           TRALEN=SQRT((XT1-XT0)**2+(YT1-YT0)**2+(ZT1-ZT0)**2)
*   Increment cluster counter.
            NTOT=NTOT+1
*   Generate new cluster position.
            IF(TRALEN.GT.0)THEN
                 XCLS=XT0+(REAL(NTOT-1)/CMEAN)*(XT1-XT0)/TRALEN
                 YCLS=YT0+(REAL(NTOT-1)/CMEAN)*(YT1-YT0)/TRALEN
                 ZCLS=ZT0+(REAL(NTOT-1)/CMEAN)*(ZT1-ZT0)/TRALEN
            ELSE
                 XCLS=0.5*(XT0+XT1)
                 YCLS=0.5*(YT0+YT1)
                 ZCLS=0.5*(ZT0+ZT1)
            ENDIF
*   See whether we're ready.
            IF((XT0-XCLS)*(XCLS-XT1).LT.0.OR.
     -          (YT0-YCLS)*(YCLS-YT1).LT.0.OR.
     -          (ZT0-ZCLS)*(ZCLS-ZT1).LT.0.OR.
     -          (TRALEN.LE.0.AND.NTOT.GT.1))THEN
                DONE=.TRUE.
                OK=.FALSE.
            ELSE
                DONE=.FALSE.
            ENDIF
*   Set the cluster size and energy.
            CALL HISRAD(CLSDIS,NCLS,0.0D0,1.0D0,XRAN)
            NPAIR=INT(XRAN)
            ECLS=NPAIR*EPAIR
*** Handle the case of exponentially spaced clusters.
       ELSEIF(ITRTYP.EQ.3)THEN
*   Ensure that the appropriate gas data is present.
            IF(.NOT.GASOK(5))THEN
                 PRINT *,' !!!!!! TRACLS WARNING : Clustering data'//
     -                ' from gas section missing; track not set.'
                 RETURN
            ENDIF
*   Store track length.
            IF(NTOT.EQ.0)THEN
                 TRALEN=SQRT((XT1-XT0)**2+(YT1-YT0)**2+(ZT1-ZT0)**2)
                 DIST=0
            ENDIF
*   Increment cluster counter.
            NTOT=NTOT+1
*   Generate new cluster position.
            IF(TRALEN.GT.0)THEN
                 DIST=DIST+RNDEXP(1.0/CMEAN)
                 XCLS=XT0+DIST*(XT1-XT0)/TRALEN
                 YCLS=YT0+DIST*(YT1-YT0)/TRALEN
                 ZCLS=ZT0+DIST*(ZT1-ZT0)/TRALEN
            ELSE
                 XCLS=0.5*(XT0+XT1)
                 YCLS=0.5*(YT0+YT1)
                 ZCLS=0.5*(ZT0+ZT1)
            ENDIF
*   See whether we're ready.
            IF((XT0-XCLS)*(XCLS-XT1).LT.0.OR.
     -          (YT0-YCLS)*(YCLS-YT1).LT.0.OR.
     -          (ZT0-ZCLS)*(ZCLS-ZT1).LT.0.OR.
     -          (TRALEN.LE.0.AND.NTOT.GT.1))THEN
                DONE=.TRUE.
                OK=.FALSE.
            ELSE
                DONE=.FALSE.
            ENDIF
*   Set the cluster size and energy.
            CALL HISRAD(CLSDIS,NCLS,0.0D0,1.0D0,XRAN)
            NPAIR=INT(XRAN)
            ECLS=EPAIR*NPAIR
*** And finally deal with the case of HEED generated clusters.
       ELSEIF(ITRTYP.EQ.4)THEN
**  Check for zero charge tracks.
            IF(TRCHAR.EQ.0)THEN
                 DONE=.TRUE.
                 XCLS=0
                 YCLS=0
                 ZCLS=0
                 ECLS=0
                 NPAIR=0
                 OK=.FALSE.
                 IFAIL=0
                 RETURN
            ENDIF
**  If this is a request for the first cluster ...
            IF(IVGA.EQ.0)THEN
*   Ensure that proper data is available.
                 IF(.NOT.HEEDOK)THEN
                      PRINT *,' !!!!!! TRACLS WARNING : HEED gas'//
     -                     ' mix not defined; track not set.'
                      RETURN
                 ELSEIF(.NOT.TRFLAG(2))THEN
                      PRINT *,' !!!!!! TRACLS WARNING : Particle'//
     -                     ' properties not present; no clusters.'
                      RETURN
                 ENDIF
*   Store track length and rotation angles.
                 IF((XT1-XT0)**2+(ZT1-ZT0)**2.LE.0)THEN
                      IF(YT1-YT0.LT.0)THEN
                           TRTH=-PI/2
                      ELSEIF(YT1-YT0.GT.0)THEN
                           TRTH=+PI/2
                      ELSE
                           TRTH=0
                      ENDIF
                      TRPHI=0
                 ELSE
                      TRPHI=ATAN2(XT1-XT0,ZT1-ZT0)
                      TRTH=ATAN2(YT1-YT0,SQRT((XT1-XT0)**2+
     -                     (ZT1-ZT0)**2))
                 ENDIF
                 TRALEN=SQRT((XT1-XT0)**2+(YT1-YT0)**2+(ZT1-ZT0)**2)
                 IF(TRALEN.LE.0)THEN
                      PRINT *,' !!!!!! TRACLS WARNING : Track length'//
     -                     ' 0 not compatible with HEED; no clusters.'
                      RETURN
                 ENDIF
                 IF(LDEBUG)THEN
                      WRITE(LUNOUT,'(''  ++++++ TRACLS DEBUG   :'',
     -                     '' Transformation matrix:'',3(/26X,3F10.3)/
     -                     26X,''Track length: '',E15.8,'' cm.'')')
     -                     COS(TRPHI),-SIN(TRPHI)*SIN(TRTH),
     -                     +SIN(TRPHI)*COS(TRTH),0,COS(TRTH),
     -                     +SIN(TRTH),-SIN(TRPHI),-COS(TRPHI)*SIN(TRTH),
     -                     +COS(TRPHI)*COS(TRTH),TRALEN
                 ENDIF
*   Set the HEED error flag to false.
                 IF(LDEBUG)THEN
                      soo=1
                 ELSE
                      soo=0
                 ENDIF
                 oo=LUNOUT
                 s_err=0
*   Set the tracking volume.
                 CALL IniFVolume(0,1,1,1,0.0,TRALEN)
*   Set the particle type.
                 IF(LDEBUG)THEN
                      IPRINT=2
                 ELSE
                      IPRINT=1
                 ENDIF
                 IERROR=0
                 CALL ipheed( 
     -                TRENER,       ! Particle kinetic energy [MeV]
     -                TRMASS,       ! Particle mass [MeV]
     -                IPRINT,       ! 1/2 Short/Medium listing
     -                IERROR)       ! Error indicator.
                 IF(IERROR.NE.0)THEN
                      PRINT *,' !!!!!! TRACLS WARNING : Setting the'//
     -                     ' particle properties in HEED failed.'
                      RETURN
                 ENDIF
*   Set the track.
                 CALL IniRTrack(
     -                0.0,0.0,      ! Starting interval, HEED y [cm]
     -                0.0,0.0)      ! Track orientation
*   Optionally add multiple scattering.
                 IF(LTRMS)CALL IniMTrack(
     -                1,            ! Sign of Rutherford angle
     -                0.01*GASDEN,  ! Step 
     -                0.001)        ! Minimum angle
*   Generate a track.
                 CALL GoEventn(1,1)
*   Check for overflow.
                 IF(qsOverflowagam.GT.0)
     -                PRINT *,' !!!!!! TRACLS WARNING : Overflow of'//
     -                ' energy deposition buffer in HEED; no clusters.'
                 IF(qsOverflowrga.GT.0)
     -                PRINT *,' !!!!!! TRACLS WARNING : Overflow of'//
     -                ' real photon buffer in HEED; no clusters.'
                 IF(qsOverflowDel.GT.0)
     -                PRINT *,' !!!!!! TRACLS WARNING : Overflow of'//
     -                ' delta electron buffer in HEED; no clusters.'
                 IF(qsOverflowCel(1).GT.0)
     -                PRINT *,' !!!!!! TRACLS WARNING : Overflow of'//
     -                ' deposited electron buffer in HEED; no clusters.'
                 IF(qsOverflowagam.GT.0.OR.qsOverflowrga.GT.0.OR.
     -                qsOverflowDel.GT.0.OR.qsOverflowagam.GT.0)THEN
                      OK=.FALSE.
                      DONE=.TRUE.
                      RETURN
                 ENDIF
*   Sort the virtual gamma's by location.
                 DO 50 I=1,qgvga(1)
                 DISVGA(I)=pntgvga(3,I,1)
50               CONTINUE
                 CALL SORTZV(DISVGA,INDPOS,qgvga(1),1,0,0)
*   If debugging is on, print the Virtual GAmma's.
                 IF(LDEBUG)THEN
                      WRITE(LUNOUT,'(''  ++++++ TRACLS DEBUG   :'',
     -                     '' Virtual gammas: '',I5,'' total dE='',
     -                     E15.8,'' MeV:''/''  Index'',
     -                     ''          x [cm]          y [cm]'',
     -                     ''          z [cm]        dE [MeV]'',
     -                     '' order'')')
     -                     qgvga(1),esgvga(1)
                      DO 10 I=1,qgvga(1)
                      JPRINT=0
                      DO 80 J=1,qgvga(1)
                      IF(INDPOS(J).EQ.I)JPRINT=J
80                    CONTINUE
                      WRITE(LUNOUT,'(2X,I5,4(1X,E15.8),I6)')
     -                     I,(pntgvga(J,I,1),J=1,3),egvga(I,1),JPRINT
10                    CONTINUE
*   Same for the delta's.
                      WRITE(LUNOUT,'(''  ++++++ TRACLS DEBUG   :'',
     -                     '' Delta + Auger electrons: '',I5/
     -                     ''  Index'',
     -                     ''          x [cm]          y [cm]'',
     -                     ''          z [cm]    energy [MeV]'',
     -                     '' charge gamma type'')') qdel
                      DO 20 I=1,qdel
                      IF(SOdel(I).EQ.0)THEN
                           WRITE(LUNOUT,'(2X,I5,4(1X,E15.8),F7.1,I6,
     -                          '' delta'')') I,(pntdel(j,i),j=1,3),
     -                          edel(i),zdel(i),ptdel(i)
                      ELSE
                           WRITE(LUNOUT,'(2X,I5,4(1X,E15.8),F7.1,I6,
     -                          '' Auger'')') I,(pntdel(j,i),j=1,3),
     -                          edel(i),zdel(i),ptdel(i)
                      ENDIF
20                    CONTINUE
*   Same for the real photons.
                      WRITE(LUNOUT,'(''  ++++++ TRACLS DEBUG   :'',
     -                     '' Real photons: '',I5/''  Index'',
     -                     ''          x [cm]          y [cm]'',
     -                     ''          z [cm]    energy [MeV]'',
     -                     '' gamma'')') qrga
                      DO 30 I=1,qrga
                      WRITE(LUNOUT,'(2X,I5,4(1X,E15.8),I6)')
     -                     I,(pntrga(j,i),j=1,3),erga(i),
     -                     ptrga(i)
30                    CONTINUE
*   And finally also the electrons.
                      WRITE(LUNOUT,'(''  ++++++ TRACLS DEBUG   :'',
     -                     '' Electrons: '',I5/''  Index'',
     -                     ''          x [cm]          y [cm]'',
     -                     ''          z [cm]'',
     -                     '' charge delta'')') qcel(1)
                      DO 40 I=1,qcel(1)
                      WRITE(LUNOUT,'(2X,I5,3(1X,E15.8),F7.1,I6)')
     -                     I,(pntcel(j,i,1),j=1,3),zcel(i,1),
     -                     ndelcel(i,1)
40                    CONTINUE
                 ENDIF
*   Store first virtual gamma and electron to deal with.
                 IVGA=1
                 ICEL=0
*   Reset total energy.
                 ETOT=0
            ENDIF
**  If delta's have to be taken into account.
            IF(LTRDEL)THEN
70               CONTINUE
*   Increment the electron counter.
                 ICEL=ICEL+1
*   Check whether we've reached the last electron.
                 IF(ICEL.GT.qcel(1))THEN
*   If so, increment the virtual gamma counter.
                      IVGA=IVGA+1
                      ICEL=1
*   Check whether we've reached the last virtual gamma.
                      IF(IVGA.GT.qgvga(1))THEN
                           DONE=.TRUE.
                           XCLS=0
                           YCLS=0
                           ZCLS=0
                           ECLS=0
                           NPAIR=0
                           OK=.FALSE.
                           IFAIL=0
                           RETURN
                      ELSE
                           DONE=.FALSE.
                      ENDIF
                 ELSE
                      DONE=.FALSE.
                 ENDIF
*   See whether this electron belongs to the right gamma.
                 IF(ptdel(ndelcel(ICEL,1)).NE.INDPOS(IVGA))GOTO 70
*   Fetch the location of this electron.
                 XAUX=pntcel(1,ICEL,1)
                 YAUX=pntcel(2,ICEL,1)
                 ZAUX=pntcel(3,ICEL,1)
C        print *,' Taking electron ',icel,' from gamma ',ivga
*   Compute the energy deposited in this electron.
                 EDELTA=edel(ndelcel(ICEL,1))
                 NDELTA=0
                 DO 60 I=1,qcel(1)
                 IF(ndelcel(I,1).EQ.ndelcel(ICEL,1))NDELTA=NDELTA+1
60               CONTINUE
                 IF(NDELTA.LE.0)THEN
                      ECLS=-1
                 ELSE
                      ECLS=EDELTA/NDELTA
                 ENDIF
*   Check whether we exceeded the total energy.
                 ETOT=ETOT+ECLS
                 IF(ETOT.GT.TRENER)THEN
                      PRINT *,' ------ TRACLS MESSAGE : Track'//
     -                     ' truncated because the deposited'//
     -                     ' energy exceeds the particle energy.'
                      DONE=.TRUE.
                      XCLS=0
                      YCLS=0
                      ZCLS=0
                      ECLS=0
                      NPAIR=0
                      OK=.FALSE.
                      IFAIL=0
                      RETURN
                 ENDIF
*   There is only 1 electron in this case.
                 NPAIR=1
**  If we don't want deltas ...
            ELSE
*   Check whether we've already had all energy deposits.
                 IF(IVGA.GT.qgvga(1))THEN
                      DONE=.TRUE.
                      XCLS=0
                      YCLS=0
                      ZCLS=0
                      ECLS=0
                      NPAIR=0
                      OK=.FALSE.
                      IFAIL=0
                      RETURN
                 ELSE
                      DONE=.FALSE.
                 ENDIF
*   Fetch the location of this deposit.
                 XAUX=pntgvga(1,INDPOS(IVGA),1)
                 YAUX=pntgvga(2,INDPOS(IVGA),1)
                 ZAUX=pntgvga(3,INDPOS(IVGA),1)
*   Count the number of electrons associated with it.
                 NPAIR=0
                 DO 100 I=1,qcel(1)
                 IF(ptdel(ndelcel(I,1)).EQ.INDPOS(IVGA))NPAIR=NPAIR+1
100              CONTINUE
*   Store energy, checking the total energy.
                 IF(ETOT+egvga(INDPOS(IVGA),1).GT.TRENER)THEN
                      ECLS=TRENER-ETOT
                      IVGA=qgvga(1)+1
                 ELSE
                      ECLS=egvga(INDPOS(IVGA),1)
                 ENDIF
                 ETOT=ETOT+ECLS
*   Increment the cluster counter.
                 IVGA=IVGA+1
            ENDIF
**  Rotate the cluster position so that it matches the track.
            XCLS=XT0+COS(TRPHI)*XAUX-SIN(TRPHI)*SIN(TRTH)*YAUX+
     -           SIN(TRPHI)*COS(TRTH)*ZAUX
            YCLS=YT0+COS(TRTH)*YAUX+SIN(TRTH)*ZAUX
            ZCLS=ZT0-SIN(TRPHI)*XAUX-COS(TRPHI)*SIN(TRTH)*YAUX+
     -           COS(TRPHI)*COS(TRTH)*ZAUX
*** Fixed number of flux intervals.
       ELSEIF(ITRTYP.EQ.7)THEN
*   Verify that the number of flux lines has been set.
            IF(.NOT.TRFLAG(6))THEN
                 PRINT *,' !!!!!! TRACLS WARNING : Number of flux'//
     -                ' lines has not been set; no clusters.'
                 RETURN
            ENDIF
**  On first call, compute the flux intervals.
            IF(NTOT.EQ.0)THEN
*   Set integration intervals.
                 NV=5
*   Compute the inplane vector normal to the track.
                 XP=(YT1-YT0)*FPROJC-(ZT1-ZT0)*FPROJB
                 YP=(ZT1-ZT0)*FPROJA-(XT1-XT0)*FPROJC
                 ZP=(XT1-XT0)*FPROJB-(YT1-YT0)*FPROJA
*   Compute the total flux, accepting positive and negative parts.
                 CALL FLDIN5(XT0,YT0,ZT1,XT1,YT1,ZT1,XP,YP,ZP,Q,
     -                20*NV,0)
                 IF(Q.GT.0)THEN
                      ISIGN=+1
                 ELSE
                      ISIGN=-1
                 ENDIF
                 IF(LDEBUG)WRITE(LUNOUT,'(''  ++++++ TRACLS DEBUG   :'',
     -                '' Total flux: '',E15.8,'', selected sign '',I1)')
     -                Q,ISIGN
*   Compute the 1-sided flux in a number of steps.
                 FLXSUM=0
                 IERROR=0
                 XL0FLX=-1
                 XL1FLX=-1
                 DO 110 I=1,MXLIST
                 CALL FLDIN5(
     -                XT0+REAL(I-1)*(XT1-XT0)/REAL(MXLIST),
     -                YT0+REAL(I-1)*(YT1-YT0)/REAL(MXLIST),
     -                ZT0+REAL(I-1)*(ZT1-ZT0)/REAL(MXLIST),
     -                XT0+REAL(I)*(XT1-XT0)/REAL(MXLIST),
     -                YT0+REAL(I)*(YT1-YT0)/REAL(MXLIST),
     -                ZT0+REAL(I)*(ZT1-ZT0)/REAL(MXLIST),
     -                XP,YP,ZP,Q,NV,ISIGN)
                 FLXCOO(I)=REAL(I)/REAL(MXLIST)
                 IF(Q.GT.0)THEN
                      FLXSUM=FLXSUM+Q
                      IF(XL0FLX.LT.-0.5)XL0FLX=REAL(I-1)/REAL(MXLIST)
                      XL1FLX=REAL(I)/REAL(MXLIST)
                 ENDIF
                 IF(Q.LT.0)IERROR=IERROR+1
                 FLXTAB(I)=FLXSUM
110              CONTINUE
*   Make sure that the sum is positive.
                 IF(LDEBUG)WRITE(LUNOUT,'(''  ++++++ TRACLS DEBUG   :'',
     -                '' Used flux: '',E15.8,'' V''/26X,''Start: '',
     -                F10.3,'' End: '',F10.3)') FLXSUM,XL0FLX,XL1FLX
                 IF(FLXSUM.LE.0)THEN
                      PRINT *,' !!!!!! TRACLS WARNING : 1-Sided flux'//
     -                     ' integral is not > 0; no clusters.'
                      RETURN
                 ELSEIF(XL0FLX.LT.-0.5.OR.XL1FLX.LT.-0.5.OR.
     -                XL1FLX.LE.XL0FLX)THEN
                      PRINT *,' !!!!!! TRACLS WARNING : No flux'//
     -                     ' interval without sign change found.'
                      RETURN
                 ELSEIF(IERROR.NE.0)THEN
                      PRINT *,' ------ TRACLS MESSAGE : The flux'//
     -                     ' changes sign over the track; part of'//
     -                     ' the track not used.'
                 ENDIF
*   Normalise the flux.
                 DO 120 I=1,MXLIST
                 FLXTAB(I)=REAL(NTRFLX-1)*FLXTAB(I)/FLXSUM
120              CONTINUE
            ENDIF
**  Increment cluster counter.
            NTOT=NTOT+1
*   Compute new cluster position.
            IF(NTOT.EQ.1)THEN
                 XL=XL0FLX
            ELSEIF(NTOT.GE.1.AND.NTOT.LT.NTRFLX)THEN
                 XL=MIN(XL1FLX,MAX(XL0FLX,
     -                DIVDIF(FLXCOO,FLXTAB,MXLIST,REAL(NTOT-1),1)))
            ELSEIF(NTOT.EQ.NTRFLX)THEN
                 XL=XL1FLX
            ELSE
                 XL=0.5*(XL1FLX-XL0FLX)
            ENDIF
            XCLS=XT0+XL*(XT1-XT0)
            YCLS=YT0+XL*(YT1-YT0)
            ZCLS=ZT0+XL*(ZT1-ZT0)
*   Set the cluster size and energy.
            NPAIR=1
            ECLS=0
*   See whether we were already done.
            IF(NTOT.GT.NTRFLX)THEN
                 DONE=.TRUE.
                 OK=.FALSE.
            ELSE
                 DONE=.FALSE.
            ENDIF
*** Fixed flux interval.
       ELSEIF(ITRTYP.EQ.8)THEN
*   Verify that the number of flux lines has been set.
            IF(.NOT.TRFLAG(7))THEN
                 PRINT *,' !!!!!! TRACLS WARNING : The flux interval'//
     -                ' has not been set; no clusters.'
                 RETURN
            ENDIF
**  On first call, compute the flux intervals.
            IF(NTOT.EQ.0)THEN
*   Set integration intervals.
                 NV=5
*   Compute the inplane vector normal to the track.
                 XP=(YT1-YT0)*FPROJC-(ZT1-ZT0)*FPROJB
                 YP=(ZT1-ZT0)*FPROJA-(XT1-XT0)*FPROJC
                 ZP=(XT1-XT0)*FPROJB-(YT1-YT0)*FPROJA
*   Compute the total flux, accepting positive and negative parts.
                 CALL FLDIN5(XT0,YT0,ZT1,XT1,YT1,ZT1,XP,YP,ZP,Q,
     -                NTRFLX*NV,0)
                 IF(Q.GT.0)THEN
                      ISIGN=+1
                 ELSE
                      ISIGN=-1
                 ENDIF
                 IF(LDEBUG)WRITE(LUNOUT,'(''  ++++++ TRACLS DEBUG   :'',
     -                '' Total flux: '',E15.8,'' V, sign '',I1)')
     -                Q,ISIGN
*   Compute the 1-sided flux in a number of steps.
                 FLXSUM=0
                 IERROR=0
                 XL0FLX=-1
                 DO 130 I=1,MXLIST
                 CALL FLDIN5(
     -                XT0+REAL(I-1)*(XT1-XT0)/REAL(MXLIST),
     -                YT0+REAL(I-1)*(YT1-YT0)/REAL(MXLIST),
     -                ZT0+REAL(I-1)*(ZT1-ZT0)/REAL(MXLIST),
     -                XT0+REAL(I)*(XT1-XT0)/REAL(MXLIST),
     -                YT0+REAL(I)*(YT1-YT0)/REAL(MXLIST),
     -                ZT0+REAL(I)*(ZT1-ZT0)/REAL(MXLIST),
     -                XP,YP,ZP,Q,NV,ISIGN)
                 FLXCOO(I)=REAL(I)/REAL(MXLIST)
                 IF(Q.GT.0)THEN
                      FLXSUM=FLXSUM+Q
                      IF(XL0FLX.LT.-0.5)XL0FLX=REAL(I-1)/REAL(MXLIST)
                 ENDIF
                 IF(Q.LT.0)IERROR=IERROR+1
                 FLXTAB(I)=FLXSUM
130              CONTINUE
*   Make sure that the sum is positive.
                 IF(LDEBUG)WRITE(LUNOUT,'(''  ++++++ TRACLS DEBUG   :'',
     -                '' Used flux: '',E15.8,'' V ''/26X,
     -                ''Start offset: '',F10.3)') FLXSUM,XL0FLX
                 IF(FLXSUM.LE.0)THEN
                      PRINT *,' !!!!!! TRACLS WARNING : 1-Sided flux'//
     -                     ' integral is not > 0; no clusters.'
                      RETURN
                 ELSEIF(XL0FLX.LT.-0.5)THEN
                      PRINT *,' !!!!!! TRACLS WARNING : No flux'//
     -                     ' interval without sign change found.'
                      RETURN
                 ELSEIF(IERROR.NE.0)THEN
                      PRINT *,' ------ TRACLS MESSAGE : The flux'//
     -                     ' changes sign over the track; part of'//
     -                     ' the track not used.'
                 ENDIF
            ENDIF
**  Increment cluster counter.
            NTOT=NTOT+1
*   Compute new cluster position.
            IF(NTOT.EQ.1)THEN
                 XL=XL0FLX
                 DONE=.FALSE.
            ELSEIF((NTOT-1)*TRFLUX.LE.FLXSUM)THEN
                 XL=DIVDIF(FLXCOO,FLXTAB,MXLIST,REAL(NTOT-1)*TRFLUX,1)
                 DONE=.FALSE.
            ELSE
                 XL=XL0FLX
                 DONE=.TRUE.
                 OK=.FALSE.
            ENDIF
            XCLS=XT0+XL*(XT1-XT0)
            YCLS=YT0+XL*(YT1-YT0)
            ZCLS=ZT0+XL*(ZT1-ZT0)
*   Set the cluster size and energy.
            NPAIR=1
            ECLS=0
*** Other track types.
       ELSE
            PRINT *,' !!!!!! TRACLS WARNING : Unknown track type'//
     -           ' requested; no clusters'
            XCLS=0
            YCLS=0
            ZCLS=0
            ECLS=0
            NPAIR=0
            DONE=.TRUE.
            OK=.FALSE.
            IFAIL=1
            RETURN
       ENDIF
*** Seems to have worked, set the IFAIL flag.
       IFAIL=0
       RETURN
*** Entry point for initialisation.
       ENTRY TRACLI
       IF(LIDENT)PRINT *,' /// ENTRY TRACLI ///'
*   Reset the number of clusters generated sofar.
       NTOT=0
       IVGA=0
       ETOT=0
*   Set flag that clustering can proceed.
       OK=.TRUE.
*** Set the particle identifier, fixed number.
       IF(ITRTYP.EQ.1)THEN
            CALL OUTFMT(REAL(NTRLIN),2,AUX,NCAUX,'LEFT')
            PARTID=AUX(1:NCAUX)//' equally spaced points'
*   Equal.
       ELSEIF(ITRTYP.EQ.2)THEN
            PARTID='Equally spaced clusters'
*   Exponential.
       ELSEIF(ITRTYP.EQ.3)THEN
            PARTID='Exponentially spaced clusters'
*   Heed.
       ELSEIF(ITRTYP.EQ.4)THEN
            IF(TRENER.LT.0.001)THEN
                 CALL OUTFMT(TRENER*1000000,2,AUX,NCAUX,'LEFT')
                 PARTID=PNAME(1:NCPNAM)//', Ekin='//AUX(1:NCAUX)//' eV'
            ELSEIF(TRENER.LT.1)THEN
                 CALL OUTFMT(TRENER*1000,2,AUX,NCAUX,'LEFT')
                 PARTID=PNAME(1:NCPNAM)//', Ekin='//AUX(1:NCAUX)//' keV'
            ELSEIF(TRENER.LT.1000)THEN
                 CALL OUTFMT(TRENER,2,AUX,NCAUX,'LEFT')
                 PARTID=PNAME(1:NCPNAM)//', Ekin='//AUX(1:NCAUX)//' MeV'
            ELSEIF(TRENER.LT.1000000)THEN
                 CALL OUTFMT(TRENER/1000,2,AUX,NCAUX,'LEFT')
                 PARTID=PNAME(1:NCPNAM)//', Ekin='//AUX(1:NCAUX)//' GeV'
            ELSE
                 CALL OUTFMT(TRENER/1000000,2,AUX,NCAUX,'LEFT')
                 PARTID=PNAME(1:NCPNAM)//', Ekin='//AUX(1:NCAUX)//' TeV'
            ENDIF
            qgvga(1)=0
            qdel=0
            qcel(1)=0
            qrga=0
*   Weighted.
       ELSEIF(ITRTYP.EQ.5)THEN
            CALL OUTFMT(REAL(NTRSAM),2,AUX,NCAUX,'LEFT')
            PARTID=AUX(1:NCAUX)//' samples of '//FCNTRW(1:NCTRW)
*   Single cluster.
       ELSEIF(ITRTYP.EQ.6)THEN
            PARTID='Single cluster'
*   Fixed number of flux lines.
       ELSEIF(ITRTYP.EQ.7)THEN
            CALL OUTFMT(REAL(NTRFLX),2,AUX,NCAUX,'LEFT')
            PARTID=AUX(1:NCAUX)//' flux lines'
*   Constant flux intervals.
       ELSEIF(ITRTYP.EQ.8)THEN
            CALL OUTFMT(TRFLUX,2,AUX,NCAUX,'LEFT')
            PARTID='Flux intervals of '//AUX(1:NCAUX)//' V'
*   Anything else.
       ELSE
            PARTID='Unknown'
       ENDIF
       END
+DECK,TRAPLT.
       SUBROUTINE TRAPLT
*-----------------------------------------------------------------------
*   TRAPLT - Plots the track with the delta electrons.
*   (Last changed on  3/10/98.)
*-----------------------------------------------------------------------
      implicit none
+SEQ,DIMENSIONS.
+SEQ,PARAMETERS.
+SEQ,GASDATA.
+SEQ,CELLDATA.
+SEQ,volume.
+SEQ,goevent.
+SEQ,del.
+SEQ,cel.
+SEQ,abs.
+SEQ,rga.
+SEQ,lsgvga.
       REAL XCLS,YCLS,ZCLS
       DOUBLE PRECISION XPLDEL(pqcel),YPLDEL(pqcel),ZPLDEL(pqcel),
     -      XPLVGA(pqgvga),YPLVGA(pqgvga),ZPLVGA(pqgvga),
     -      XPL(2),YPL(2),ZPL(2),ETOT
       INTEGER NELEC,I,J,K,NPL
*** Apparently a HEED generated track.
       IF(HEEDOK.AND.ITRTYP.EQ.4)THEN
**  Pick up relevant portion of the virtual gamma's.
            ETOT=0
            NPL=0
            DO 20 I=1,qgvga(1)
            XCLS=XT0+COS(TRPHI)*pntgvga(1,INDPOS(I),1)-
     -           SIN(TRPHI)*SIN(TRTH)*pntgvga(2,INDPOS(I),1)+
     -           SIN(TRPHI)*COS(TRTH)*pntgvga(3,INDPOS(I),1)
            YCLS=YT0+COS(TRTH)*pntgvga(2,INDPOS(I),1)+
     -           SIN(TRTH)*pntgvga(3,INDPOS(I),1)
            ZCLS=ZT0-SIN(TRPHI)*pntgvga(1,INDPOS(I),1)-
     -           COS(TRPHI)*SIN(TRTH)*pntgvga(2,INDPOS(I),1)+
     -           COS(TRPHI)*COS(TRTH)*pntgvga(3,INDPOS(I),1)
            ETOT=ETOT+egvga(INDPOS(I),1)
            NPL=NPL+1
            XPLVGA(NPL)=XCLS
            YPLVGA(NPL)=YCLS
            ZPLVGA(NPL)=ZCLS
            IF(ETOT.GE.TRENER)GOTO 25
20          CONTINUE
*   All relevant virtual photons taken.
25          CONTINUE
*   Set the appropriate representations.
            CALL GRATTS('TRACK','POLYLINE')
            CALL GRATTS('TRACK','POLYMARKER')
*   Plot the particle trajectory.
            IF(POLAR)CALL CF2CTR(XPLVGA,YPLVGA,XPLVGA,YPLVGA,NPL)
            IF(NPL.GT.1)THEN
                 CALL PLAGPL(NPL,XPLVGA,YPLVGA,ZPLVGA)
            ELSEIF(NPL.EQ.1)THEN
                 CALL PLAGPM(NPL,XPLVGA,YPLVGA,ZPLVGA)
            ENDIF
**  Next plot each of the deltas and Auger electrons.
            ETOT=0
*   Loop over the virtual photons.
            DO 50 K=1,qgvga(1)
*   Loop over the associated delta's.
            DO 30 I=1,qdel
            IF(ptdel(I).NE.INDPOS(K).OR.edel(I).LE.0)GOTO 30
*   Set the attributes depending on the type.
            IF(sodel(I).EQ.0)THEN
                 CALL GRATTS('DELTA-ELECTRON','POLYLINE')
                 CALL GRATTS('DELTA-ELECTRON','POLYMARKER')
            ELSE
                 CALL GRATTS('AUGER-ELECTRON','POLYLINE')
                 CALL GRATTS('AUGER-ELECTRON','POLYMARKER')
            ENDIF
*   Store the starting point.
            XCLS=XT0+COS(TRPHI)*pntgvga(1,INDPOS(K),1)-
     -           SIN(TRPHI)*SIN(TRTH)*pntgvga(2,INDPOS(K),1)+
     -           SIN(TRPHI)*COS(TRTH)*pntgvga(3,INDPOS(K),1)
            YCLS=YT0+COS(TRTH)*pntgvga(2,INDPOS(K),1)+
     -           SIN(TRTH)*pntgvga(3,INDPOS(K),1)
            ZCLS=ZT0-SIN(TRPHI)*pntgvga(1,INDPOS(K),1)-
     -           COS(TRPHI)*SIN(TRTH)*pntgvga(2,INDPOS(K),1)+
     -           COS(TRPHI)*COS(TRTH)*pntgvga(3,INDPOS(K),1)
            NELEC=1
            XPLDEL(NELEC)=XCLS
            YPLDEL(NELEC)=YCLS
            ZPLDEL(NELEC)=ZCLS
           nelec=0
*   Find the associated electrons.
            DO 40 J=1,qcel(1)
            IF(ndelcel(J,1).EQ.I)THEN
                 NELEC=NELEC+1
                 XCLS=XT0+COS(TRPHI)*pntcel(1,J,1)-
     -                SIN(TRPHI)*SIN(TRTH)*pntcel(2,J,1)+
     -                SIN(TRPHI)*COS(TRTH)*pntcel(3,J,1)
                 YCLS=YT0+COS(TRTH)*pntcel(2,J,1)+
     -                SIN(TRTH)*pntcel(3,J,1)
                 ZCLS=ZT0-SIN(TRPHI)*pntcel(1,J,1)-
     -                COS(TRPHI)*SIN(TRTH)*pntcel(2,J,1)+
     -                COS(TRPHI)*COS(TRTH)*pntcel(3,J,1)
                 XPLDEL(NELEC)=XCLS
                 YPLDEL(NELEC)=YCLS
                 ZPLDEL(NELEC)=ZCLS
            ENDIF
40          CONTINUE
*   Keep track of total energy.
            IF(ETOT+edel(I).GT.TRENER)THEN
                 NELEC=NELEC*(TRENER-ETOT)/edel(I)
                 ETOT=TRENER+1
            ELSE
                 ETOT=ETOT+edel(I)
            ENDIF
*   Plot the particle trajectory.
            IF(POLAR)CALL CF2CTR(XPLDEL,YPLDEL,XPLDEL,YPLDEL,NELEC)
            IF(NELEC.GT.1)THEN
                 CALL PLAGPL(NELEC,XPLDEL,YPLDEL,ZPLDEL)
            ELSEIF(NELEC.EQ.1)THEN
                 CALL PLAGPM(NELEC,XPLDEL,YPLDEL,ZPLDEL)
            ENDIF
*   Quit if energy limit reached.
            IF(ETOT.GE.TRENER)GOTO 60
*   Next delta.
30          CONTINUE
*   Next virtual gamma.
50          CONTINUE
*   Energy limit.
60          CONTINUE
**  Next plot the real photons.
            ETOT=0
*   Set attributes.
            CALL GRATTS('PHOTON','POLYLINE')
            CALL GRATTS('PHOTON','POLYMARKER')
*   Loop over virtual gamma's.
            DO 150 K=1,qgvga(1)
            XCLS=XT0+COS(TRPHI)*pntgvga(1,INDPOS(K),1)-
     -           SIN(TRPHI)*SIN(TRTH)*pntgvga(2,INDPOS(K),1)+
     -           SIN(TRPHI)*COS(TRTH)*pntgvga(3,INDPOS(K),1)
            YCLS=YT0+COS(TRTH)*pntgvga(2,INDPOS(K),1)+
     -           SIN(TRTH)*pntgvga(3,INDPOS(K),1)
            ZCLS=ZT0-SIN(TRPHI)*pntgvga(1,INDPOS(K),1)-
     -           COS(TRPHI)*SIN(TRTH)*pntgvga(2,INDPOS(K),1)+
     -           COS(TRPHI)*COS(TRTH)*pntgvga(3,INDPOS(K),1)
            XPL(1)=XCLS
            YPL(1)=YCLS
            ZPL(1)=ZCLS
*   Find the corresponding real photons and plot them.
            DO 130 I=1,qrga
            IF(ptrga(I).NE.INDPOS(K))GOTO 130
            XCLS=XT0+COS(TRPHI)*pntrga(1,I)-
     -           SIN(TRPHI)*SIN(TRTH)*pntrga(2,I)+
     -           SIN(TRPHI)*COS(TRTH)*pntrga(3,I)
            YCLS=YT0+COS(TRTH)*pntrga(2,I)+
     -           SIN(TRTH)*pntrga(3,I)
            ZCLS=ZT0-SIN(TRPHI)*pntrga(1,I)-
     -           COS(TRPHI)*SIN(TRTH)*pntrga(2,I)+
     -           COS(TRPHI)*COS(TRTH)*pntrga(3,I)
            XPL(2)=XCLS
            YPL(2)=YCLS
            ZPL(2)=ZCLS
            IF(POLAR)CALL CF2CTR(XPL,YPL,XPL,YPL,2)
            CALL PLAGPL(2,XPL,YPL,ZPL)
*   Keep track of total energy.
            ETOT=ETOT+erga(I)
*   Quit if energy limit reached.
            IF(ETOT.GE.TRENER)GOTO 160
*   Next real photon.
130         CONTINUE
*   Next virtual gamma.
150         CONTINUE
*   Energy limit.
160         CONTINUE
*** Any other kind of track.
       ELSE
*   Set the appropriate representations.
            CALL GRATTS('TRACK','POLYLINE')
            CALL GRATTS('TRACK','POLYMARKER')
*   And plot the track as a straight line.
            XPL(1)=XT0
            YPL(1)=YT0
            ZPL(1)=ZT0
            XPL(2)=XT1
            YPL(2)=YT1
            ZPL(2)=ZT1
            IF(POLAR)CALL CF2CTR(XPL,YPL,XPL,YPL,2)
            CALL PLAGPL(2,XPL,YPL,ZPL)
       ENDIF
       END
+DECK,TRAREA.
       SUBROUTINE TRAREA
*-----------------------------------------------------------------------
*   TRAREA - Reads a track definition
*   (Last changed on 14/ 5/99.)
*-----------------------------------------------------------------------
      implicit none
+SEQ,DIMENSIONS.
+SEQ,PARAMETERS.
+SEQ,PRINTPLOT.
+SEQ,CELLDATA.
+SEQ,GASDATA.
+SEQ,GLOBALS.
       INTEGER NWORD,INPCMP,INPTYP,IFAIL1,IFAIL2,IFAIL3,IFAIL4,IFAIL5,
     -      IFAIL6,NLINR,I,J,INEXT,NCAUX,NRES,NVAR,IENWGT,NCNAME,
     -      MODVAR(1),NREXP,MODRES(1),NSAMR,IRCOOR,IRWGT,ISCOOR,ISWGT,
     -      MATSLT,IORD,NC1,NC2,NC3,NC4,NC5,NC6,NFLXR
       REAL XMASS,XENER,XDIST,XCHAR,XNORM,XT0D,XT1D,YT0D,YT1D,ZT0D,ZT1D,
     -      FACT,XDIR,YDIR,ZDIR,RES(1),VAR(1),WGTSUM,FLXR
       LOGICAL START,END,DIST,DIR,ENER,MASS,CHARGE,USE(1),OK
       EXTERNAL INPCMP,INPTYP,MATSLT
       CHARACTER*10 VARLIS(1),NAME
       CHARACTER*13 AUX1,AUX2,AUX3,AUX4,AUX5,AUX6
       CHARACTER*20 AUX
*** Identify the procedure if requested.
       IF(LIDENT)PRINT *,' /// ROUTINE TRAREA ///'
*** Count words.
       CALL INPNUM(NWORD)
*** Perhaps only printing has been requested.
       IF(NWORD.EQ.1)THEN
*   Track location.
            IF(TRFLAG(1))THEN
                 XT0D=XT0
                 YT0D=YT0
                 ZT0D=ZT0
                 XT1D=XT1
                 YT1D=YT1
                 ZT1D=ZT1
                 IF(POLAR)THEN
                      CALL CFMCTP(XT0D,YT0D,XT0D,YT0D,1)
                      CALL CFMCTP(XT1D,YT1D,XT1D,YT1D,1)
                 ENDIF
                 CALL OUTFMT(XT0D,2,AUX1,NC1,'LEFT')
                 CALL OUTFMT(YT0D,2,AUX2,NC2,'LEFT')
                 CALL OUTFMT(ZT0D,2,AUX3,NC3,'LEFT')
                 CALL OUTFMT(XT1D,2,AUX4,NC4,'LEFT')
                 CALL OUTFMT(YT1D,2,AUX5,NC5,'LEFT')
                 CALL OUTFMT(ZT1D,2,AUX6,NC6,'LEFT')
                 WRITE(LUNOUT,'(''  The current track runs from '',
     -                ''('',A,'','',A,'','',A,'') to '',
     -                ''('',A,'','',A,'','',A,'').'')')
     -                AUX1(1:NC1),AUX2(1:NC2),AUX3(1:NC3),
     -                AUX4(1:NC4),AUX5(1:NC5),AUX6(1:NC6)
            ELSE
                 WRITE(LUNOUT,'(''  The location of the track is'',
     -                '' not yet defined.'')')
            ENDIF
*   Particle type.
            IF(TRFLAG(2))THEN
                 CALL OUTFMT(TRMASS,2,AUX1,NC1,'LEFT')
                 CALL OUTFMT(TRENER,2,AUX2,NC2,'LEFT')
                 CALL OUTFMT(TRCHAR,2,AUX3,NC3,'LEFT')
                 WRITE(LUNOUT,'(''  The particle is a '',A,'' with a'',
     -                '' mass of '',A,'' MeV,''/''  an energy of '',A,
     -                '' MeV and a charge of '',A,
     -                '' proton charges.'')') PNAME(1:NCPNAM),
     -                AUX1(1:NC1),AUX2(1:NC2),AUX3(1:NC3)
            ENDIF
*   Clustering type: fixed.
            IF(ITRTYP.EQ.1.AND.TRFLAG(3))THEN
                 CALL OUTFMT(REAL(NTRLIN),2,AUX1,NC1,'LEFT')
                 WRITE(LUNOUT,'(''  There will be '',A,'' equally'',
     -                '' spaced clusters on the track.'')') AUX1(1:NC1)
            ELSEIF(ITRTYP.EQ.1.AND..NOT.TRFLAG(3))THEN
                 WRITE(LUNOUT,'(''  There will be equally'',
     -                '' spaced clusters on the track.'')')
*   Clustering type: equal spacing.
            ELSEIF(ITRTYP.EQ.2)THEN
                 WRITE(LUNOUT,'(''  Clusters will be equally spaced'',
     -                '' respecting the mean from the gas section.'')')
*   Clustering type: exponential spacing.
            ELSEIF(ITRTYP.EQ.3)THEN
                 WRITE(LUNOUT,'(''  Clusters will be exponentially'',
     -                '' spaced with a mean distance as entered'',
     -                '' in the gas section.'')')
*   Clustering type: processing by HEED.
            ELSEIF(ITRTYP.EQ.4)THEN
                 WRITE(LUNOUT,'(''  Clusters will be generated by'',
     -                '' HEED,'')')
                 IF(LTRMS)THEN
                      WRITE(LUNOUT,'(''  the incoming particle'',
     -                     '' undergoes multiple scattering,'')')
                 ELSE
                      WRITE(LUNOUT,'(''  the incoming particle does'',
     -                     '' not undergo multiple scattering,'')')
                 ENDIF
                 IF(LTRDEL)THEN
                      WRITE(LUNOUT,'(''  delta electrons have a'',
     -                '' spatial extent.'')')
                 ELSE
                      WRITE(LUNOUT,'(''  delta electrons are'',
     -                '' compactified onto the main track.'')')
                 ENDIF
*   Weighted cluster location distribution.
            ELSEIF(ITRTYP.EQ.5)THEN
                 CALL OUTFMT(REAL(NTRSAM),2,AUX1,NC1,'LEFT')
                 WRITE(LUNOUT,'(''  There will be '',A,'' clusters'',
     -                '' at positions weighted according to '',A)')
     -                AUX1(1:NC1),FCNTRW(1:NCTRW)
*   Single cluster.
            ELSEIF(ITRTYP.EQ.6)THEN
                 WRITE(LUNOUT,'(''  There will be a single cluster'',
     -                '' at a random position.'')')
*   Equal flux lines.
            ELSEIF(ITRTYP.EQ.7)THEN
                 CALL OUTFMT(REAL(NTRFLX),2,AUX1,NC1,'LEFT')
                 WRITE(LUNOUT,'(''  There will be '',A,'' clusters'',
     -                '' at equal flux intervals.'')') AUX1(1:NC1)
*   Flux intervals.
            ELSEIF(ITRTYP.EQ.8)THEN
                 CALL OUTFMT(TRFLUX,2,AUX1,NC1,'LEFT')
                 WRITE(LUNOUT,'(''  Clusters will be spaced by a'',
     -                '' flux of '',A,'' V.'')') AUX1(1:NC1)
            ENDIF
            RETURN
       ENDIF
*** Preset flags.
       START =.FALSE.
       END   =.FALSE.
       DIST  =.FALSE.
       DIR   =.FALSE.
       ENER  =.FALSE.
       MASS  =.FALSE.
       CHARGE=.FALSE.
*** Compute default track parameters.
       XT0D=XT0
       YT0D=YT0
       ZT0D=ZT0
       XT1D=XT1
       YT1D=YT1
       ZT1D=ZT1
       IF(POLAR)THEN
            CALL CFMCTP(XT0D,YT0D,XT0D,YT0D,1)
            CALL CFMCTP(XT1D,YT1D,XT1D,YT1D,1)
       ENDIF
*** Format: (x0,y0,z0) (x1,y1,z1)
       IF(NWORD.GE.7.AND.INPTYP(2).GE.1.AND.INPTYP(3).GE.1.AND.
     -      INPTYP(4).GE.1.AND.INPTYP(5).GE.1.AND.
     -      INPTYP(6).GE.1.AND.INPTYP(7).GE.1)THEN
            CALL INPCHK(2,2,IFAIL1)
            CALL INPCHK(3,2,IFAIL2)
            CALL INPCHK(4,2,IFAIL3)
            CALL INPCHK(5,2,IFAIL4)
            CALL INPCHK(6,2,IFAIL5)
            CALL INPCHK(7,2,IFAIL6)
            CALL INPRDR(2,XT0D,XT0D)
            CALL INPRDR(3,YT0D,YT0D)
            CALL INPRDR(4,ZT0D,ZT0D)
            CALL INPRDR(5,XT1D,XT1D)
            CALL INPRDR(6,YT1D,YT1D)
            CALL INPRDR(7,ZT1D,ZT1D)
            START=.TRUE.
            END=.TRUE.
            INEXT=8
*** Format: (x0,y0) (x1,y1)
       ELSEIF(NWORD.GE.5.AND.INPTYP(2).GE.1.AND.INPTYP(3).GE.1.AND.
     -      INPTYP(4).GE.1.AND.INPTYP(5).GE.1)THEN
            CALL INPCHK(2,2,IFAIL1)
            CALL INPCHK(3,2,IFAIL2)
            CALL INPCHK(4,2,IFAIL3)
            CALL INPCHK(5,2,IFAIL4)
            CALL INPRDR(2,XT0D,XT0D)
            CALL INPRDR(3,YT0D,YT0D)
            ZT0D=0
            CALL INPRDR(4,XT1D,XT1D)
            CALL INPRDR(5,YT1D,YT1D)
            ZT1D=0
            START=.TRUE.
            END=.TRUE.
            INEXT=6
*** Format: (x0,y0,z0)
       ELSEIF(NWORD.GE.4.AND.INPTYP(2).GE.1.AND.INPTYP(3).GE.1.AND.
     -      INPTYP(4).GE.1)THEN
            CALL INPCHK(2,2,IFAIL1)
            CALL INPCHK(3,2,IFAIL2)
            CALL INPCHK(4,2,IFAIL3)
            CALL INPRDR(2,XT0D,XT0D)
            CALL INPRDR(3,YT0D,YT0D)
            CALL INPRDR(4,ZT0D,ZT0D)
            START=.TRUE.
            INEXT=5
*** Format: (x0,y0)
       ELSEIF(NWORD.GE.3.AND.INPTYP(2).GE.1.AND.INPTYP(3).GE.1)THEN
            CALL INPCHK(2,2,IFAIL1)
            CALL INPCHK(3,2,IFAIL2)
            CALL INPRDR(2,XT0D,XT0D)
            CALL INPRDR(3,YT0D,YT0D)
            ZT0D=0
            START=.TRUE.
            INEXT=4
       ELSE
            INEXT=2
       ENDIF
*** Now scan from here on for further arguments.
       DO 10 I=1,NWORD
       IF(I.LT.INEXT)GOTO 10
*   Could be a starting point.
       IF(INPCMP(I,'FR#OM')+INPCMP(I,'START#ING-#POINT').NE.0)THEN
            IF(NWORD.LT.I+2.OR.
     -           INPTYP(I+1).LE.0.OR.INPTYP(I+2).LE.0)THEN
                 CALL INPMSG(I,'Has 2 or 3 real arguments.')
            ELSEIF(INPTYP(I+3).LE.0)THEN
                 CALL INPCHK(I+1,2,IFAIL1)
                 CALL INPCHK(I+2,2,IFAIL2)
                 CALL INPRDR(I+1,XT0D,XT0D)
                 CALL INPRDR(I+2,YT0D,YT0D)
                 ZT0D=0
                 START=.TRUE.
                 INEXT=I+3
            ELSE
                 CALL INPCHK(I+1,2,IFAIL1)
                 CALL INPCHK(I+2,2,IFAIL2)
                 CALL INPCHK(I+3,2,IFAIL3)
                 CALL INPRDR(I+1,XT0D,XT0D)
                 CALL INPRDR(I+2,YT0D,YT0D)
                 CALL INPRDR(I+3,ZT0D,ZT0D)
                 START=.TRUE.
                 INEXT=I+4
            ENDIF
*   Could be an end point.
       ELSEIF(INPCMP(I,'TO')+INPCMP(I,'END-#POINT').NE.0)THEN
            IF(NWORD.LT.I+2.OR.
     -           INPTYP(I+1).LE.0.OR.INPTYP(I+2).LE.0)THEN
                 CALL INPMSG(I,'Has 2 or 3 real arguments.')
            ELSEIF(INPTYP(I+3).LE.0)THEN
                 CALL INPCHK(I+1,2,IFAIL1)
                 CALL INPCHK(I+2,2,IFAIL2)
                 CALL INPRDR(I+1,XT1D,XT1D)
                 CALL INPRDR(I+2,YT1D,YT1D)
                 ZT1D=0
                 END=.TRUE.
                 INEXT=I+3
            ELSE
                 CALL INPCHK(I+1,2,IFAIL1)
                 CALL INPCHK(I+2,2,IFAIL2)
                 CALL INPCHK(I+3,2,IFAIL3)
                 CALL INPRDR(I+1,XT1D,XT1D)
                 CALL INPRDR(I+2,YT1D,YT1D)
                 CALL INPRDR(I+3,ZT1D,ZT1D)
                 END=.TRUE.
                 INEXT=I+4
            ENDIF
*   Could be a direction vector.
       ELSEIF(INPCMP(I,'DIR#ECTION').NE.0)THEN
            IF(INPCMP(I+1,'X')+INPCMP(I+1,'POS#ITIVE-X').NE.0)THEN
                 TRXDIR=+1
                 TRYDIR= 0
                 TRZDIR= 0
                 DIR=.TRUE.
                 INEXT=I+2
            ELSEIF(INPCMP(I+1,'NEG#ATIVE-X').NE.0)THEN
                 TRXDIR=-1
                 TRYDIR= 0
                 TRZDIR= 0
                 DIR=.TRUE.
                 INEXT=I+2
            ELSEIF(INPCMP(I+1,'Y')+INPCMP(I+1,'POS#ITIVE-Y').NE.0)THEN
                 TRXDIR= 0
                 TRYDIR=+1
                 TRZDIR= 0
                 DIR=.TRUE.
                 INEXT=I+2
            ELSEIF(INPCMP(I+1,'NEG#ATIVE-Y').NE.0)THEN
                 TRXDIR= 0
                 TRYDIR=-1
                 TRZDIR= 0
                 DIR=.TRUE.
                 INEXT=I+2
            ELSEIF(INPCMP(I+1,'Z')+INPCMP(I+1,'POS#ITIVE-Z').NE.0)THEN
                 TRXDIR= 0
                 TRYDIR= 0
                 TRZDIR=+1
                 DIR=.TRUE.
                 INEXT=I+2
            ELSEIF(INPCMP(I+1,'NEG#ATIVE-Z').NE.0)THEN
                 TRXDIR= 0
                 TRYDIR= 0
                 TRZDIR=-1
                 DIR=.TRUE.
                 INEXT=I+2
            ELSEIF(NWORD.LT.I+2.OR.
     -           INPTYP(I+1).LE.0.OR.INPTYP(I+2).LE.0)THEN
                 CALL INPMSG(I,'Has 2 or 3 real arguments.')
            ELSEIF(INPTYP(I+3).LE.0)THEN
                 CALL INPCHK(I+1,2,IFAIL1)
                 CALL INPCHK(I+2,2,IFAIL2)
                 CALL INPRDR(I+1,XDIR,0.0)
                 CALL INPRDR(I+2,YDIR,0.0)
                 ZDIR=0.0
                 DIR=.TRUE.
                 INEXT=I+3
            ELSE
                 CALL INPCHK(I+1,2,IFAIL1)
                 CALL INPCHK(I+2,2,IFAIL2)
                 CALL INPCHK(I+3,2,IFAIL3)
                 CALL INPRDR(I+1,XDIR,0.0)
                 CALL INPRDR(I+2,YDIR,0.0)
                 CALL INPRDR(I+3,ZDIR,0.0)
                 DIR=.TRUE.
                 INEXT=I+4
            ENDIF
            IF(DIR)THEN
                 XNORM=SQRT(XDIR**2+YDIR**2+ZDIR**2)
                 IF(XNORM.LE.0)THEN
                      CALL INPMSG(I,'Vector has norm 0')
                      DIR=.FALSE.
                 ELSE
                      XDIR=XDIR/XNORM
                      YDIR=YDIR/XNORM
                      ZDIR=ZDIR/XNORM
                 ENDIF
            ENDIF
*   Could be a range.
       ELSEIF(INPCMP(I,'DIST#ANCE').NE.0.OR.
     -      INPCMP(I,'RANGE').NE.0)THEN
            IF(NWORD.LT.I+1.OR.INPTYP(I+1).LE.0)THEN
                 CALL INPMSG(I,'Has 1 real argument.')
            ELSE
                 CALL INPCHK(I+1,2,IFAIL1)
                 CALL INPRDR(I+1,XDIST,-1.0)
                 IF(XDIST.LT.0)THEN
                      CALL INPMSG(I+1,'Range is not >= 0.')
                 ELSE
                      TRDIST=XDIST
                      DIST=.TRUE.
                 ENDIF
                 INEXT=I+2
            ENDIF
*   Could be a particle identifier [PDG, Phys Rev D 54 (1996)]
       ELSEIF(INPCMP(I,'ELE#CTRON')+INPCMP(I,'E-M#INUS').NE.0)THEN
            TRMASS=0.51099907
            TRCHAR=-1
            MASS=.TRUE.
            CHARGE=.TRUE.
            PNAME='electron-'
            NCPNAM=9
            ITRTYP=4
       ELSEIF(INPCMP(I,'POS#ITRON')+INPCMP(I,'E-P#LUS')+
     -      INPCMP(I,'E+').NE.0)THEN
            TRMASS=0.51099907
            TRCHAR=+1
            MASS=.TRUE.
            CHARGE=.TRUE.
            PNAME='electron+'
            NCPNAM=9
            ITRTYP=4
       ELSEIF(INPCMP(I,'MU#ON-#MINUS').NE.0)THEN
            TRMASS=105.658389
            TRCHAR=-1
            MASS=.TRUE.
            CHARGE=.TRUE.
            PNAME='mu-'
            NCPNAM=3
            ITRTYP=4
       ELSEIF(INPCMP(I,'MU#ON-P#LUS')+INPCMP(I,'MU+').NE.0)THEN
            TRMASS=105.658389
            TRCHAR=+1
            MASS=.TRUE.
            CHARGE=.TRUE.
            PNAME='mu+'
            NCPNAM=3
            ITRTYP=4
       ELSEIF(INPCMP(I,'TAU-#MINUS').NE.0)THEN
            TRMASS=1777.00
            TRCHAR=-1
            MASS=.TRUE.
            CHARGE=.TRUE.
            PNAME='tau-'
            NCPNAM=4
            ITRTYP=4
       ELSEIF(INPCMP(I,'TAU-P#LUS')+INPCMP(I,'TAU+').NE.0)THEN
            TRMASS=1777.00
            TRCHAR=+1
            MASS=.TRUE.
            CHARGE=.TRUE.
            PNAME='tau+'
            NCPNAM=4
            ITRTYP=4 
       ELSEIF(INPCMP(I,'GAMMA')+INPCMP(I,'PHOTON').NE.0)THEN
            CALL INPMSG(I,'Photons not yet available.')
       ELSEIF(INPCMP(I,'PI#ON-#MINUS').NE.0)THEN
            TRMASS=139.56995
            TRCHAR=-1
            MASS=.TRUE.
            CHARGE=.TRUE.
            PNAME='pi-'
            NCPNAM=3
            ITRTYP=4
       ELSEIF(INPCMP(I,'PI#ON-0')+INPCMP(I,'PI#ON-Z#ERO')+
     -      INPCMP(I,'PI0').NE.0)THEN
            TRMASS=134.9764
            TRCHAR= 0
            MASS=.TRUE.
            CHARGE=.TRUE.
            PNAME='pi0'
            NCPNAM=3
            ITRTYP=4
       ELSEIF(INPCMP(I,'PI#ON-PLUS')+INPCMP(I,'PI+').NE.0)THEN
            TRMASS=139.56995
            TRCHAR=+1
            MASS=.TRUE.
            CHARGE=.TRUE.
            PNAME='pi+'
            NCPNAM=3
            ITRTYP=4
       ELSEIF(INPCMP(I,'K#AON-#MINUS').NE.0)THEN
            TRMASS=493.677
            TRCHAR=-1
            MASS=.TRUE.
            CHARGE=.TRUE.
            PNAME='K-'
            NCPNAM=2
            ITRTYP=4
       ELSEIF(INPCMP(I,'K#AON-0-#SHORT')+INPCMP(I,'K#AON-0-#LONG')+
     -      INPCMP(I,'K0-#SHORT')+INPCMP(I,'K0-#LONG')+
     -      INPCMP(I,'K#AON-Z#ERO-#SHORT')+
     -      INPCMP(I,'K#AON-Z#ERO-#LONG')+
     -      INPCMP(I,'K0-#SHORT')+INPCMP(I,'K0-#LONG').NE.0)THEN
            TRMASS=497.672
            TRCHAR= 0
            MASS=.TRUE.
            CHARGE=.TRUE.
            PNAME='K0'
            NCPNAM=2
            ITRTYP=4
       ELSEIF(INPCMP(I,'K#AON-P#LUS')+INPCMP(I,'K+').NE.0)THEN
            TRMASS=493.677
            TRCHAR=-1
            MASS=.TRUE.
            CHARGE=.TRUE.
            PNAME='K+'
            NCPNAM=2
            ITRTYP=4
       ELSEIF(INPCMP(I,'PR#OTON').NE.0)THEN
            TRMASS=938.27231
            TRCHAR=+1
            MASS=.TRUE.
            CHARGE=.TRUE.
            PNAME='proton'
            NCPNAM=6
            ITRTYP=4
       ELSEIF(INPCMP(I,'ANTI-PR#OTON').NE.0)THEN
            TRMASS=938.27231
            TRCHAR=-1
            MASS=.TRUE.
            CHARGE=.TRUE.
            PNAME='antiproton'
            NCPNAM=10
            ITRTYP=4
       ELSEIF(INPCMP(I,'N#EUTRON')+INPCMP(I,'ANTI-N#EUTRON').NE.0)THEN
            TRMASS=939.56563
            TRCHAR= 0
            MASS=.TRUE.
            CHARGE=.TRUE.
            PNAME='neutron'
            NCPNAM=7
            ITRTYP=4
*   Manually described particle, first mass.
       ELSEIF(INPCMP(I,'MASS').NE.0)THEN
            IF(NWORD.LT.I+1.OR.INPTYP(I+1).LE.0)THEN
                 CALL INPMSG(I,'Must have 1 real argument')
            ELSE
                 CALL INPCHK(I+1,2,IFAIL1)
                 CALL INPRDR(I+1,XMASS,TRMASS)
                 IF(I+2.LE.NWORD.AND.INPCMP(I+2,'EV').NE.0)THEN
                      FACT=1E-6
                      INEXT=I+3
                 ELSEIF(I+2.LE.NWORD.AND.INPCMP(I+2,'KEV').NE.0)THEN
                      FACT=1E-3
                      INEXT=I+3
                 ELSEIF(I+2.LE.NWORD.AND.INPCMP(I+2,'MEV').NE.0)THEN
                      FACT=1
                      INEXT=I+3
                 ELSEIF(I+2.LE.NWORD.AND.INPCMP(I+2,'GEV').NE.0)THEN
                      FACT=1E+3
                      INEXT=I+3
                 ELSEIF(I+2.LE.NWORD.AND.INPCMP(I+2,'TEV').NE.0)THEN
                      FACT=1E+6
                      INEXT=I+3
                 ELSE
                      FACT=1
                      INEXT=I+2
                 ENDIF
                 IF(XMASS.LT.0)THEN
                      CALL INPMSG(I+1,'Mass is not >= 0.')
                 ELSE
                      TRMASS=FACT*XMASS
                      MASS=.TRUE.
                      ITRTYP=4
                      IF(TRMASS.LE.1)THEN
                           CALL OUTFMT(ANINT(TRMASS*1000)/1000,2,
     -                          AUX,NCAUX,'LEFT')
                      ELSE
                           CALL OUTFMT(ANINT(TRMASS),2,
     -                          AUX,NCAUX,'LEFT')
                      ENDIF
                      PNAME='m('//AUX(1:NCAUX)//')'
                      NCPNAM=MIN(LEN(PNAME),NCAUX+3)
                 ENDIF
            ENDIF
*   Charge.
       ELSEIF(INPCMP(I,'CH#ARGE').NE.0)THEN
            IF(NWORD.LT.I+1.OR.INPTYP(I+1).LE.0)THEN
                 CALL INPMSG(I,'Must have 1 real argument')
            ELSE
                 CALL INPCHK(I+1,2,IFAIL1)
                 CALL INPRDR(I+1,XCHAR,TRCHAR)
                 IF(ABS(XCHAR).LT.0.99.OR.ABS(XCHAR).GT.1.01)THEN
                      CALL INPMSG(I,'Currently only +1 or -1.')
                 ELSE
                      TRCHAR=XCHAR
                      CHARGE=.TRUE.
                      ITRTYP=4
                 ENDIF
                 INEXT=I+2
            ENDIF
*   Energy of the particle.
       ELSEIF(INPCMP(I,'ENE#RGY').NE.0)THEN
            IF(NWORD.LT.I+1.OR.INPTYP(I+1).LE.0)THEN
                 CALL INPMSG(I,'Must have 1 real argument')
            ELSE
                 CALL INPCHK(I+1,2,IFAIL1)
                 CALL INPRDR(I+1,XENER,TRENER)
                 IF(I+2.LE.NWORD.AND.INPCMP(I+2,'EV').NE.0)THEN
                      FACT=1E-6
                      INEXT=I+3
                 ELSEIF(I+2.LE.NWORD.AND.INPCMP(I+2,'KEV').NE.0)THEN
                      FACT=1E-3
                      INEXT=I+3
                 ELSEIF(I+2.LE.NWORD.AND.INPCMP(I+2,'MEV').NE.0)THEN
                      FACT=1
                      INEXT=I+3
                 ELSEIF(I+2.LE.NWORD.AND.INPCMP(I+2,'GEV').NE.0)THEN
                      FACT=1E+3
                      INEXT=I+3
                 ELSEIF(I+2.LE.NWORD.AND.INPCMP(I+2,'TEV').NE.0)THEN
                      FACT=1E+6
                      INEXT=I+3
                 ELSE
                      FACT=1
                      INEXT=I+2
                 ENDIF
                 IF(XENER.LE.0)THEN
                      CALL INPMSG(I+1,'Energy is not > 0.')
                 ELSE
                      TRENER=FACT*XENER
                      ENER=.TRUE.
                      ITRTYP=4
                 ENDIF
            ENDIF
*   Delta electrons or not.
       ELSEIF(INPCMP(I,'DELTA-#ELECTRONS').NE.0)THEN
            LTRDEL=.TRUE.
            ITRTYP=4
       ELSEIF(INPCMP(I,'NODELTA-#ELECTRONS').NE.0)THEN
            LTRDEL=.FALSE.
*   Trace delta electrons or not.
       ELSEIF(INPCMP(I,'TR#ACE-DELTA-#ELECTRONS').NE.0)THEN
            LTREXB=.TRUE.
            ITRTYP=4
       ELSEIF(INPCMP(I,'NOTR#ACE-DELTA-#ELECTRONS').NE.0)THEN
            LTREXB=.FALSE.
*   Multiple scattering or not.
       ELSEIF(INPCMP(I,'MULT#IPLE-SC#ATTERING').NE.0)THEN
            LTRMS=.TRUE.
            ITRTYP=4
       ELSEIF(INPCMP(I,'NOMULT#IPLE-SC#ATTERING').NE.0)THEN
            LTRMS=.FALSE.
*   Track interpolation or not.
       ELSEIF(INPCMP(I,'INT#ERPOLATE-TR#ACK').NE.0)THEN
            LTRINT=.TRUE.
       ELSEIF(INPCMP(I,'NOINT#ERPOLATE-TR#ACK').NE.0)THEN
            LTRINT=.FALSE.
*   Number of points on the track.
       ELSEIF(INPCMP(I,'LINE#S')+INPCMP(I,'POINT#S').NE.0)THEN
            IF(NWORD.LT.I+1.OR.INPTYP(I+1).LE.0)THEN
                 CALL INPMSG(I,'Must have 1 integer argument')
            ELSE
                 CALL INPCHK(I+1,1,IFAIL1)
                 CALL INPRDI(I+1,NLINR,NTRLIN)
                 IF(NLINR.LT.0)THEN
                      CALL INPMSG(I+1,'Number is not > 0.')
                 ELSE
                      NTRLIN=NLINR
                      TRFLAG(3)=.TRUE.
                      ITRTYP=1
                 ENDIF
                 INEXT=I+2
            ENDIF
*   Number of sampling points on the track.
       ELSEIF(INPCMP(I,'SAMP#LING')+INPCMP(I,'SAMP#LES').NE.0)THEN
            IF(NWORD.LT.I+1.OR.INPTYP(I+1).LE.0)THEN
                 CALL INPMSG(I,'Must have 1 integer argument')
            ELSE
                 CALL INPCHK(I+1,1,IFAIL1)
                 CALL INPRDI(I+1,NSAMR,NTRSAM)
                 IF(NLINR.LT.0)THEN
                      CALL INPMSG(I+1,'Number is not > 0.')
                 ELSE
                      NTRSAM=NSAMR
                      TRFLAG(5)=.TRUE.
                      ITRTYP=5
                 ENDIF
                 INEXT=I+2
            ENDIF
**  Weighting function.
       ELSEIF(INPCMP(I,'WEIGHT#ING-F#UNCTION').NE.0)THEN
            IF(NWORD.LT.I+1)THEN
                 CALL INPMSG(I,'Should have an argument')
*   In the form of matrices.
            ELSEIF(INPCMP(I+2,'VS').NE.0.AND.I+3.LE.NWORD)THEN
*   Locate the matrices.
                 IRCOOR=0
                 IRWGT=0
                 CALL INPSTR(I+1,I+1,NAME,NCNAME)
                 DO 110 J=1,NGLB
                 IF(GLBMOD(J).EQ.5.AND.GLBVAR(J).EQ.NAME(1:NCNAME))
     -                IRWGT=NINT(GLBVAL(J))
110              CONTINUE
                 ISWGT=MATSLT(IRWGT)
                 CALL INPSTR(I+3,I+3,NAME,NCNAME)
                 DO 120 J=1,NGLB
                 IF(GLBMOD(J).EQ.5.AND.GLBVAR(J).EQ.NAME(1:NCNAME))
     -                IRCOOR=NINT(GLBVAL(J))
120              CONTINUE
                 ISCOOR=MATSLT(IRCOOR)
                 IF(ISWGT.EQ.0)CALL INPMSG(I+1,'Not a known matrix.')
                 IF(ISCOOR.EQ.0)CALL INPMSG(I+3,'Not a known matrix.')
*   Carry out interpolation.
                 IF(ISCOOR.NE.0.AND.ISWGT.NE.0)THEN
                      IORD=2
                      WGTSUM=0
                      OK=.TRUE.
                      DO 130 J=1,MXLIST
                      VAR(1)=REAL(J-1)/REAL(MXLIST-1)
                      CALL MATIN1(IRCOOR,IRWGT,1,VAR(1),RES(1),
     -                     ISCOOR,ISWGT,IORD,IFAIL1)
                      WGT(J)=MAX(0.0,RES(1))
                      IF(RES(1).LT.0)OK=.FALSE.
                      WGTSUM=WGTSUM+WGT(J)
130                   CONTINUE
                      IF(WGTSUM.GT.0.AND.OK)THEN
                           CALL HISPRD(WGT,MXLIST)
                           ITRTYP=5
                           CALL INPSTR(I+1,I+3,FCNTRW,NCTRW)
                           TRFLAG(4)=.TRUE.
                      ELSEIF(.NOT.OK)THEN
                           CALL INPMSG(I+1,'Sometimes < 0.')
                      ELSE
                           CALL INPMSG(I+1,'Has a zero norm.')
                      ENDIF
                 ENDIF
                 INEXT=I+4
*   In the form of a function.
            ELSE
                 CALL INPSTR(I+1,I+1,FCNTRW,NCTRW)
                 VARLIS(1)='T'
                 NVAR=1
                 CALL ALGPRE(FCNTRW(1:NCTRW),NCTRW,VARLIS,NVAR,
     -                NRES,USE,IENWGT,IFAIL1)
                 IF(IFAIL1.NE.0)THEN
                      CALL INPMSG(I+1,'Not a valid function.')
                 ELSE
                      WGTSUM=0
                      OK=.TRUE.
                      DO 30 J=1,MXLIST
                      VAR(1)=REAL(J-1)/REAL(MXLIST-1)
                      MODVAR(1)=2
                      NVAR=1
                      NREXP=1
                      CALL ALGEXE(IENWGT,VAR,MODVAR,NVAR,RES,
     -                     MODRES,NREXP,IFAIL1)
                      WGT(J)=MAX(0.0,RES(1))
                      IF(RES(1).LT.0)OK=.FALSE.
                      WGTSUM=WGTSUM+WGT(J)
30                    CONTINUE
                      CALL ALGCLR(IENWGT)
                      CALL ALGERR
                      IF(WGTSUM.GT.0.AND.OK)THEN
                           CALL HISPRD(WGT,MXLIST)
                           ITRTYP=5
                           TRFLAG(4)=.TRUE.
                      ELSEIF(.NOT.OK)THEN
                           CALL INPMSG(I+1,'Sometimes < 0.')
                      ELSE
                           CALL INPMSG(I+1,'Has a zero norm.')
                      ENDIF
                 ENDIF
                 INEXT=I+2
            ENDIF
*   Number of sampling points on the track.
       ELSEIF(INPCMP(I,'FL#UX-L#INES').NE.0)THEN
            IF(NWORD.LT.I+1.OR.INPTYP(I+1).LE.0)THEN
                 CALL INPMSG(I,'Must have 1 integer argument')
            ELSE
                 CALL INPCHK(I+1,1,IFAIL1)
                 CALL INPRDI(I+1,NFLXR,NTRFLX)
                 IF(NFLXR.LT.2)THEN
                      CALL INPMSG(I+1,'Number is not > 1.')
                 ELSE
                      NTRFLX=NFLXR
                      TRFLAG(6)=.TRUE.
                      ITRTYP=7
                 ENDIF
                 INEXT=I+2
            ENDIF
*   Number of sampling points on the track.
       ELSEIF(INPCMP(I,'FL#UX-INT#ERVALS').NE.0)THEN
            IF(NWORD.LT.I+1.OR.INPTYP(I+1).LE.0)THEN
                 CALL INPMSG(I,'Must have 1 real argument')
            ELSE
                 CALL INPCHK(I+1,2,IFAIL1)
                 CALL INPRDR(I+1,FLXR,TRFLUX)
                 IF(FLXR.LE.0)THEN
                      CALL INPMSG(I+1,'Interval is not > 0.')
                 ELSE
                      TRFLUX=FLXR
                      TRFLAG(7)=.TRUE.
                      ITRTYP=8
                 ENDIF
                 INEXT=I+2
            ENDIF
*   Kind of cluster generation.
       ELSEIF(INPCMP(I,'FIX#ED-#NUMBER').NE.0)THEN
            ITRTYP=1
       ELSEIF(INPCMP(I,'EQ#UAL-SP#ACING').NE.0)THEN
            ITRTYP=2
       ELSEIF(INPCMP(I,'EXP#ONENTIAL-#SPACING').NE.0)THEN
            ITRTYP=3
       ELSEIF(INPCMP(I,'HEED').NE.0)THEN
            ITRTYP=4
       ELSEIF(INPCMP(I,'WEIGHT#ED-D#ISTRIBUTION').NE.0)THEN
            ITRTYP=5
       ELSEIF(INPCMP(I,'SIN#GLE-#CLUSTER').NE.0)THEN
            ITRTYP=6
            IF(.NOT.GASOK(5))PRINT *,' ------ TRAREA MESSAGE :'//
     -           ' No cluster size distribution; cluster will'//
     -           ' have size 1.'
       ELSEIF(INPCMP(I,'EQ#UAL-FL#UX-#INTERVALS').NE.0)THEN
            ITRTYP=7
       ELSEIF(INPCMP(I,'CONS#TANT-FL#UX-#INTERVALS').NE.0)THEN
            ITRTYP=8
*   Not a known keyword.
       ELSE
            CALL INPMSG(I,'Not a known keyword.')
       ENDIF
10     CONTINUE
*   Print the error messages.
       CALL INPERR
*** If the cell is polar, then reconvert coordinates.
       IF(POLAR)THEN
            CALL CFMPTC(XT0D,YT0D,XT0,YT0,1)
            CALL CFMPTC(XT1D,YT1D,XT1,YT1,1)
            ZT0=ZT0D
            ZT1=ZT1D
       ELSE
            XT0=XT0D
            XT1=XT1D
            YT0=YT0D
            YT1=YT1D
            ZT0=ZT0D
            ZT1=ZT1D
       ENDIF
*** Check completeness, first geometry.
       IF(START.AND.END.AND.DIST)THEN
            PRINT *,' ------ TRAREA MESSAGE : Both end point'//
     -           ' and range specified; ignoring range.'
            XDIR=XT1-XT0
            YDIR=YT1-YT0
            ZDIR=ZT1-ZT0
            TRDIST=SQRT(XDIR**2+YDIR**2+ZDIR**2)
            IF(TRDIST.GT.0)THEN
                 XDIR=XDIR/TRDIST
                 YDIR=YDIR/TRDIST
                 ZDIR=ZDIR/TRDIST
            ELSE
                 XDIR=0
                 YDIR=0
                 ZDIR=0
            ENDIF
*   If neither end point nor direction and distance: assume point.
       ELSEIF(START.AND.(.NOT.END).AND.(.NOT.(DIST.AND.DIR)))THEN
            PRINT *,' ------ TRAREA MESSAGE : Only start point'//
     -           ' specified; assuming single point track.'
            XT1=XT0
            YT1=YT0
            ZT1=ZT0
            XDIR=0
            YDIR=0
            ZDIR=0
            TRDIST=0
*   If end point missing, compute from direction and range.
       ELSEIF(START.AND..NOT.END)THEN
            XT1=XT0+XDIR*TRDIST
            YT1=YT0+YDIR*TRDIST
            ZT1=ZT0+ZDIR*TRDIST
*   If direction and range missing, compute from end point.
       ELSEIF(START)THEN
            XDIR=XT1-XT0
            YDIR=YT1-YT0
            ZDIR=ZT1-ZT0
            TRDIST=SQRT(XDIR**2+YDIR**2+ZDIR**2)
            IF(TRDIST.GT.0)THEN
                 XDIR=XDIR/TRDIST
                 YDIR=YDIR/TRDIST
                 ZDIR=ZDIR/TRDIST
            ELSE
                 XDIR=0
                 YDIR=0
                 ZDIR=0
            ENDIF
       ENDIF
*   Set the track location flag if appropriate, reset preparation.
       IF(START)THEN
            TRFLAG(1)=.TRUE.
            CALL DLCTRR
       ENDIF
*   Check mass etc.
       IF(MASS.OR.CHARGE.OR.ENER)THEN
            IF(.NOT.CHARGE)THEN
                 TRCHAR=-1.0
                 PRINT *,' ------ TRAREA MESSAGE : Charge not'//
     -                ' specified; assuming negative charge.'
            ENDIF
            IF(.NOT.MASS)THEN
                 TRMASS=105.658389
                 IF(TRCHAR.LT.0)THEN
                      PNAME='mu-'
                 ELSE
                      PNAME='mu-'
                 ENDIF
                 NCPNAM=3
                 PRINT *,' ------ TRAREA MESSAGE : Mass not'//
     -                ' specified; assuming a muon.'
            ENDIF
            IF(.NOT.ENER)THEN
                 TRENER=1000.0
                 PRINT *,' ------ TRAREA MESSAGE : Energy not'//
     -                ' specified; assuming 1 GeV.'
            ENDIF
            TRFLAG(2)=.TRUE.
       ENDIF
*** Debugging output.
       IF(LDEBUG)WRITE(LUNOUT,'(''  ++++++ TRAREA DEBUG   : '',
     -      ''Start     ('',E15.8,'','',E15.8,'','',E15.8,'')''/26X,
     -      ''To        ('',E15.8,'','',E15.8,'','',E15.8,'')''/26X,
     -      ''Direction ('',E15.8,'','',E15.8,'','',E15.8,'')''/26X,
     -      ''Range     ='',E15.8,'' cm''/26X,
     -      ''Mass      ='',E15.8,'' MeV''/26X,
     -      ''Energy    ='',E15.8,'' MeV''/26X,
     -      ''Charge    ='',E15.8,'' electron charges''/26X,
     -      ''Lines     ='',I5/26X,
     -      ''Type      ='',I5,'' (1=fixed, 2=equal, 3=exp, 4=HEED,'',
     -      '' 5=weighted, 6=single, 7=flux)''/26X,
     -      ''Location '',L1,'', particle '',L1,'', lines '',L1/26X,
     -      ''weighting function '',L1,'', samples '',L1/26X,
     -      ''flux lines '',L1/26X,
     -      ''MS '',L1,'', delta '',L1,'', trace delta '',L1,
     -      '', interpolate '',L1)')
     -      XT0,YT0,ZT0,XT1,YT1,ZT1,XDIR,YDIR,ZDIR,
     -      TRDIST,TRMASS,TRENER,TRCHAR,NTRLIN,ITRTYP,
     -      (TRFLAG(I),I=1,5),LTRMS,LTRDEL,LTREXB,LTRINT
       END
+DECK,TRAEXB.
       SUBROUTINE TRAEXB(XIN,VIN,XOUT,VOUT,ENERGY,STEP,IFAIL)
*-----------------------------------------------------------------------
*   TRAEXB - Traces an electron through an E and B field.
*   (Last changed on 10/ 2/97.)
*-----------------------------------------------------------------------
      implicit none
+SEQ,DIMENSIONS.
+SEQ,CONSTANTS.
+SEQ,PRINTPLOT.
+SEQ,PARAMETERS.
       DOUBLE PRECISION XIN(3),XOUT(3),VEL(3),
     -      DT,T,WORK(18),SPEED,VNORM,STEP,RADIUS,GAMMA
       REAL BX,BY,BZ,BTOT,XPOS,YPOS,ZPOS,VIN(3),VOUT(3),ENERGY
       INTEGER I,IFAIL,NSTEP
       EXTERNAL TRASUB
       COMMON /EXBCOM/ GAMMA
*** For now, assume that the routine will fail.
       IFAIL=1
*** Ensure that the energy is larger than 0.
       IF(ENERGY.LE.0)THEN
            PRINT *,' !!!!!! TRAEXB WARNING : Energy is not > 0;'//
     -           ' not traced.'
            RETURN
       ENDIF
*** Compute particle's speed (eV gives m/sec, need MeV to cm/microsec)
       SPEED=CLIGHT*SQRT(1-1/(1+(ECHARG*ENERGY)/
     -      (100*EMASS*CLIGHT**2))**2)
*** Compute gamma factor which we'll need for the trajectory.
       GAMMA=1/SQRT(1-(SPEED/CLIGHT)**2)
*** Debugging output.
       IF(LDEBUG)WRITE(LUNOUT,'(''  ++++++ TRAEXB DEBUG   : Energy: '',
     -      E15.8,'' MeV''/26X,''Speed:  '',E15.8,'' cm/microsec''/
     -      26X,''Gamma:  '',E15.8)') ENERGY,SPEED,GAMMA
*** Establish the speed vector.
       VNORM=SQRT(VIN(1)**2+VIN(2)**2+VIN(3)**2)
       IF(VNORM.LE.0)THEN
            PRINT *,' !!!!!! TRAEXB WARNING : Speed vector has norm'//
     -           ' 0; not traced.'
            RETURN
       ENDIF
       VEL(1)=SPEED*VIN(1)/VNORM
       VEL(2)=SPEED*VIN(2)/VNORM
       VEL(3)=SPEED*VIN(3)/VNORM
*** First estimate of the step size to be taken.
       NSTEP=10
       DT=STEP/(10*SPEED)
*** Estimate bending radius so as to get the scale for integration.
       XPOS=XT0+COS(TRPHI)*XIN(1)-
     -      SIN(TRPHI)*SIN(TRTH)*XIN(2)+
     -      SIN(TRPHI)*COS(TRTH)*XIN(3)
       YPOS=YT0+COS(TRTH)*XIN(2)+
     -      SIN(TRTH)*XIN(3)
       ZPOS=ZT0-SIN(TRPHI)*XIN(1)-
     -      COS(TRPHI)*SIN(TRTH)*XIN(2)+
     -      COS(TRPHI)*COS(TRTH)*XIN(3)
       CALL BFIELD(XPOS,YPOS,ZPOS,BX,BY,BZ,BTOT)
       IF(BTOT.GT.0)THEN
            RADIUS=1.0D8*(EMASS*SPEED)/(ECHARG*BTOT)
            IF(LDEBUG)WRITE(LUNOUT,'(''  ++++++ TRAEXB DEBUG   :'',
     -           '' Bending radius: '',E15.8,'' cm.'')') RADIUS
            IF(RADIUS.LT.STEP)THEN
                 NSTEP=NSTEP*2*NINT(STEP/RADIUS)
                 DT=DT/(2*NINT(STEP/RADIUS))
            ENDIF
       ENDIF
*** Starting conditions.
       T=0
*** Make steps.
       XOUT(1)=XIN(1)
       XOUT(2)=XIN(2)
       XOUT(3)=XIN(3)
       DO 10 I=1,NSTEP
       CALL DRKNYS(3,DT,T,XOUT,VEL,TRASUB,WORK)
10     CONTINUE
*** At the end, return the new velocity vector.
       VNORM=SQRT(VEL(1)**2+VEL(2)**2+VEL(3)**2)
       VOUT(1)=VEL(1)/VNORM
       VOUT(2)=VEL(2)/VNORM
       VOUT(3)=VEL(3)/VNORM
*** Things seem to have worked properly.
       IFAIL=0
       END
+DECK,TRASUB.
       SUBROUTINE TRASUB(T,X,V,F)
*-----------------------------------------------------------------------
*   TRASUB - Called when integrating the orbit of an electron.
*   (Last changed on 11/ 2/97.)
*-----------------------------------------------------------------------
      implicit none
+SEQ,DIMENSIONS.
+SEQ,CONSTANTS.
+SEQ,PARAMETERS.
       DOUBLE PRECISION T,X(3),V(3),F(3),GAMMA
       REAL EX,EY,EZ,ETOT,VOLT,BX,BY,BZ,BTOT,XPOS,YPOS,ZPOS,
     -      EHX,EHY,EHZ,BHX,BHY,BHZ
       INTEGER ILOC
       COMMON /EXBCOM/ GAMMA
*** Transform from Heed to Garfield coordinates.
       XPOS=XT0+COS(TRPHI)*X(1)-
     -      SIN(TRPHI)*SIN(TRTH)*X(2)+
     -      SIN(TRPHI)*COS(TRTH)*X(3)
       YPOS=YT0+COS(TRTH)*X(2)+SIN(TRTH)*X(3)
       ZPOS=ZT0-SIN(TRPHI)*X(1)-
     -      COS(TRPHI)*SIN(TRTH)*X(2)+
     -      COS(TRPHI)*COS(TRTH)*X(3)
*** Compute the E and B field at the current position.
       CALL EFIELD(XPOS,YPOS,ZPOS,EX,EY,EZ,ETOT,VOLT,0,ILOC)
       CALL BFIELD(XPOS,YPOS,ZPOS,BX,BY,BZ,BTOT)
*** Transform the E and B field to Heed coordinates.
       EHX= COS(TRPHI)*          EX             -SIN(TRPHI)*          EZ
       EHY=-SIN(TRPHI)*SIN(TRTH)*EX+COS(TRTH)*EY-COS(TRPHI)*SIN(TRTH)*EZ
       EHZ= SIN(TRPHI)*COS(TRTH)*EX+SIN(TRTH)*EY+COS(TRPHI)*COS(TRTH)*EZ
       BHX= COS(TRPHI)*          BX             -SIN(TRPHI)*          BZ
       BHY=-SIN(TRPHI)*SIN(TRTH)*BX+COS(TRTH)*BY-COS(TRPHI)*SIN(TRTH)*BZ
       BHZ= SIN(TRPHI)*COS(TRTH)*BX+SIN(TRTH)*BY+COS(TRPHI)*COS(TRTH)*BZ
*** Compute the force/mass [from C*V/cm to cm/microsec**2]
       F(1)=-1.0D-8*ECHARG*(EHX+V(2)*BHZ-V(3)*BHY)/(EMASS*GAMMA)
       F(2)=-1.0D-8*ECHARG*(EHY+V(3)*BHX-V(1)*BHZ)/(EMASS*GAMMA)
       F(3)=-1.0D-8*ECHARG*(EHZ+V(1)*BHY-V(2)*BHX)/(EMASS*GAMMA)
       END
+PATCH,HEEDSUB.
+DECK,PSHEED,IF=PSHEED.
        program PSHEED

        implicit none

c         include 'molecules.inc'
+SEQ,molecule.
c         include 'molecdef.inc'
+SEQ,molecdef.
c         include 'hs.inc'
+SEQ,hs.


        integer qmol            ! Quantity of different molecules
                                ! in the gas mixture.
        integer nmol(pqMol)     ! Their numbers from molecules.inc.
                                ! Use only the named constants
                                ! for compartibility with future versions.
        real wmol(pqMol)        ! Their weights
                                ! (relative quantities of molecules).
        real pres               ! Pressure in Torr.
        real temp               ! Temperature in K.
        real tkener             ! Kinetic energy of incident particle(MeV).
        real mas                ! Mass of incident particle(MeV)
        integer maxnum          ! Maximum size of cluster(not used now).
        integer soo             ! Flag allowed for writting.
        integer oo              ! Output stream number.
        integer debug           ! Flag allowed for writting of
                                ! more amount of information.

c       Output parameters:
        real density            ! Density, calculated as for ideal gas, gr/cm3
        real dedx               ! Mean dE/dx, mean energy loss, KeV/cm.
        real ntotal             ! Average  total number.
        real nclust              ! number of clusters per cm.
        real clprob(msize)      ! Probability of the clusters,
                                ! Size=index.
        integer ierror          ! Sign of error( 0 -- no error ).

        integer n

c       qmol=1

c       nmol(1)=numm_Ar
c       wmol(1)=1.0
c       nmol(1)=numm_CF4
c       wmol(1)=1.0

        qmol=3
        nmol(1)=numm_Ar
        wmol(1)=0.30
        nmol(2)=numm_CO2
        wmol(2)=0.50
        nmol(3)=numm_CF4
        wmol(3)=0.20

        pres=0.0
        temp=0.0
        tkener=0.0
        mas=0.0
        maxnum=0.0

        soo=0
        oo=10
        open(oo,FILE='Heed.out')

        debug=0
        
        
        call SHEED
     +  (qmol, nmol, wmol, pres, temp,
     +  tkener, mas, maxnum, soo, oo, debug,
     +  dedx, ntotal, nclust, clprob, ierror)

        write(oo,*)' mean energy loss(KeV/cm)=',dedx
        write(oo,*)' total electron-ion pair number=',ntotal
        write(oo,*)' mean cluster number=',nclust
        do n=1,msize
        write(oo,*)n,clprob(n)
        enddo

        end


+DECK,SHEED,IF=SHEED.

        subroutine SHEED
     +  (qmol, nmol, pwmol, ppres, ptemp, 
     +  ptkener, pmas, maxnum, psoo, poo, debug,
     +  density, dedx, ntotal, nclust, clprob, ierror) 
c
c       The subroutine for calculation of cluster size table by HEED package
c
        implicit none

c       include 'GoEvent.inc'
+SEQ,GoEvent.
c         include 'molecules.inc'
+SEQ,molecule.
c         include 'molecdef.inc'
+SEQ,molecdef.


c         include 'ener.inc'
+SEQ,ener.
c         include 'atoms.inc'
+SEQ,atoms.
c         include 'matters.inc'
+SEQ,matters.
c       include 'crosec.inc'
+SEQ,crosec.

c         include 'cconst.inc'
+SEQ,cconst.
c         include 'volume.inc'
+SEQ,volume.
c         include 'part.inc'
+SEQ,part.
c         include 'hist.inc'
+SEQ,hist.
        

c         include 'random.inc'
+SEQ,random.

c         include 'hs.inc'
+SEQ,hs.


        integer qmol            ! Quantity of different molecules 
                                ! in the gas mixture.
        integer nmol(pqMol)     ! Their numbers from molecules.inc.
                                ! Use only the named constants
                                ! for compartibility with the future versions
        real pwmol(pqMol)       ! Their weights 
                                ! (relative quantities of molecules).
        real ppres              ! Pressure in Torr.
        real ptemp              ! Temperature in K.
        real ptkener            ! Kinetic energy of incident particle(MeV)
        real pmas               ! Mass of incident particle(MeV)
        integer maxnum          ! Maximum size of cluster(not used now).
        integer psoo            ! Flag allowing to write.
        integer poo             ! Output stream number.
        integer debug           ! Flag allowing to write  
                                ! more amount of information.

c       Output parameters:
        real density            ! Density, calculated as for ideal gas, gr/cm3
        real dedx               ! Mean dE/dx, mean energy loss, KeV/cm.
        real ntotal             ! Average  total number.
        real nclust             ! number of clusters per cm.
        real clprob(msize)      ! Probability of the clusters,
                                ! Size=index.
        integer ierror          ! Sign of error( 0 -- no error ).

        real wmol(pqMol)

        integer n,nc,i
        real s

        real pres               ! Pressure in Torr.
        real temp               ! Temperature in K.
        real tkener             ! Kinetic energy of incident particle.
        real mas                ! Mass of incident particle.
        
        real step_integ_ar
        integer tresh
        parameter (tresh=20)
        real e1,e2

        integer nmat
        integer nat

c       restore after previous run

        do nat=1,pQAt
                Zat(nat)=0
        enddo

        nmat=1

        QAtMat(nmat)=0


c       go ahead

        s=0.0
        do n=1,qmol
          s=s+pwmol(n)
        enddo
        do n=1,qmol
          wmol(n)=pwmol(n)/s
        enddo


        call Iniranfl

        soo=psoo
        oo=poo
        sret_err=1

        sHist=0                 ! To ban operating with historgams
        HistFile='heed.hist'    ! To make sure. Histograms must not be filled
                                ! and written here.
        maxhisampl=40.0e-3
        maxhisampl2=20.0e-3
        pqhisampl=100
        shfillrang=0

c       Random number genarator
        sseed=0
        seed(1)=1121517854      ! this is example
        seed(2)=612958528


        qevt=1000       ! Quantity of events to generate

        ssimioni=1              ! Simulate ionization loss
        ninfo=3                 ! Number of first events with output listing

        call Inishl                     ! Cascade from excited atom

        call IniEner(150,3e-6,0.2)      ! Energy mesh
        if(debug.ge.2)call PriEner

        call AtomsByDefault             ! Library of atoms
*** Added argument to PriAtoms (RV 13/4/99)
        if(debug.ge.2)call PriAtoms(0)
*** End of modification.

        if(ppres.eq.0)then
                pres=Atm_Pressure
        else
                pres=ppres
        endif

        if(ptemp.eq.0)then
                temp=Atm_Temper
        else
                temp=ptemp
        endif

        call molecdef
        if(debug.ge.2)call Primolec

        call Inigas(nmat, qmol, nmol, wmol, pres, temp)
*** Added argument to PriMatter (RV 13/4/99).
        if(debug.ge.2)call PriMatter(0)
*** End of modification.
        if(s_err.eq.1)then
                ierror=1
                return
        endif
        density=DensMat(nmat)

        call IniFVolume(0, nmat, 1, 1, 0.0, 1.0  )
        if(debug.ge.2)call PriVolume
                
        if(pmas.eq.0)then
                mas=938
        else
                mas=pmas
        endif

        if(ptkener.eq.0)then
                tkener=mas*(4-1)        ! 'mip'
        else
                tkener=ptkener
        endif

        call IniPart(tkener,mas)        ! Particle
        if(debug.ge.2)call Pripart
        if(s_err.eq.1)then
                ierror=1
                return
        endif

        call IniRTrack(0.0, 0.0, 0.0, 0.0)

        call IniCrosec                  ! Cross sections
        if(debug.ge.2)call PriCrosec(1,1)
                
        call InisBdel                   ! Data for tracing of delta-electrons

        meanprob=0.0
        meanvga=0.0
        meanvgal=0.0
        do i=1,msize
                prob(i)=0.0
        enddo


        do nevt=1,qevt

                call GoEvent

        enddo


        s=step_integ_ar
     +    (ener,addaC(1,nmat),qener,0.0,ener(qener+1))
        s=s*XElDensMat(nmat)

        do nc=1,msize
        
          e1=WWW(nmat)*(nc-0.5)
          e2=WWW(nmat)*(nc+0.5)
          prob1(nc)=step_integ_ar
     +    (ener,addaC(1,nmat),qener,e1,e2)
          prob1(nc)=prob1(nc)*XElDensMat(nmat)/s

        enddo

        dedx=meanC1(1)*1000.0
        ntotal=meaneleC1(1)
        nclust=meanvga
        do nc=1,tresh
          clprob(nc)=prob(nc)
        enddo
        do nc=tresh+1,msize
          clprob(nc)=prob1(nc)
        enddo

        end

+DECK,UEventS,IF=SHEED.
        subroutine UBegEvent

        implicit none

c       include 'GoEvent.inc'
+SEQ,GoEvent.
c       include 'volume.inc'
+SEQ,volume.


        end

        subroutine UEndEvent

        implicit none

c       include 'GoEvent.inc'
+SEQ,GoEvent.
c         include 'ener.inc'
+SEQ,ener.
c         include 'atoms.inc'
+SEQ,atoms.
c         include 'matters.inc'
+SEQ,matters.
c       include 'volume.inc'
+SEQ,volume.
c       include 'del.inc'
+SEQ,del.
c       include 'cel.inc'
+SEQ,cel.
c       include 'hs.inc'
+SEQ,hs.
c       include 'lsgvga.inc'
+SEQ,lsgvga.

        integer i,j,k,n,nb
        integer nc,na,nq
        real s
        

        n=0
        if(qcel(1).eq.0)then
                goto 10
        endif
        nb=Ptdel(Ndelcel(1,1))
        k=0
        do nc=1,qcel(1)+1
                k=0
                if(nc.eq.qcel(1)+1)then
                        k=1
                else
                if(nc.gt.1.and.Ptdel(Ndelcel(nc,1)).ne.nb)then
                        k=1
                endif
                endif
                if(k.eq.1)then
                        if(n.le.0)then
                            write(oo,*)' n=',n
                            n=1
                        endif
                        if(n.ge.msize+1)then
                            write(oo,*)' n=',n
                            n=msize
                        endif
                        prob(n)=prob(n)+1
                        n=1
                        if(nc.le.qcel(1))then
                            nb=Ptdel(Ndelcel(nc,1))
                        endif
                else
                        n=n+1
                endif
        enddo
        meanprob=meanprob+qcel(1)
        meanvga=meanvga+qgvga(1)
        meanvgal=meanvgal+esgvga(1)

c       write(oo,*)
c     + ' mean quantity of energy transfers from inc. part.= ',meanvga
c       write(oo,*)
c     + ' mean energy loss, Kev                            = ',
c     +         meanvgal*1000.0
c       write(oo,*)
c     + ' mean number of conduction electrons              = ',meanprob

10      continue

        if(nevt.eq.qevt)then
        meanprob=meanprob/qevt
        meanvga=meanvga/qevt
        meanvgal=meanvgal/qevt
        s=0.0
        do n=1,msize
                s = s + prob(n)
        enddo
        do n=1,msize
                prob(n) = prob(n) / s
        enddo
        
c       write(oo,*)
c     + ' mean quantity of energy transfers from inc. part.= ',meanvga
c       write(oo,*)
c     + ' mean energy loss, Kev                            = ',
c     +         meanvgal*1000.0
c       write(oo,*)
c     + ' mean number of conduction electrons              = ',meanprob
c       write(oo,*)
c     + '    number of conduction electrons in cluster vs probability:'
c       do n=1,200
c       write(oo,*)n,prob(n)
c       enddo


        endif


        end
+DECK,PEHEED,IF=PEHEED.
        program PEHEED

c       Checking the package EHEED

        implicit none

c         include 'molecules.inc'
+SEQ,molecule.
c         include 'molecdef.inc'
+SEQ,molecdef.


        integer qmol            ! Quantity of different molecules
                                ! in the gas mixture.
        integer nmol(pqMol)     ! Their numbers from molecules.inc.
                                ! Use only the named constants
                                ! for compartibility with future versions.
        real wmol(pqMol)        ! Their weights
                                ! (relative quantities of molecules).
        real pres               ! Pressure in Torr.
        real temp               ! Temperature in K.
        real tkener             ! Kinetic energy of incident particle(MeV).
        real mas                ! Mass of incident particle(MeV)
        integer soo             ! Flag allowed for writting.
        integer oo              ! Output stream number.
        integer debug           ! Flag allowed for writting of
                                ! more amount of information.

        integer qevt            ! quantity of events to generate
        integer nevt            ! current number of events 
                                ! (see comment in EHEED before GoEventn)
c       Output parameters:
        real density            ! Density, calculated as for ideal gas, gr/cm3
        integer ierror          ! Sign of error( 0 -- no error ).

        integer n

        write(6,*)' PEHEED started'

c       qmol=1

c       nmol(1)=numm_Ar
c       wmol(1)=1.0
c       nmol(1)=numm_CF4
c       wmol(1)=1.0

        qmol=3
        nmol(1)=numm_Ar
        wmol(1)=0.30
        nmol(2)=numm_CO2
        wmol(2)=0.50
        nmol(3)=numm_CF4
        wmol(3)=0.20

        pres=0.0
        temp=0.0
        tkener=0.0
        mas=0.0

        soo=0
        oo=10
        open(oo,FILE='heed.out')

        debug=2
        
        
        call IMHEED
     +  (qmol, nmol, wmol, pres, temp, soo, oo, debug,
     +  density, ierror)
        if(ierror.ne.0)then
                write(oo,*)' Error in IMHEED'
                stop
        endif

        call IniFVolume(0, 1, 1, 1, 0.0, 1.0  ) ! Volume


        call IPHEED
     +  (tkener, mas, debug,
     +  ierror)
        if(ierror.ne.0)then
                write(oo,*)' Error in IMHEED'
                stop
        endif

        call IniRTrack(0.0, 0.0, 0.0, 0.0)      ! Track

        write(oo,*)' density=',density

        qevt=10

c       End of initialization
c       Now the GoEvent subroutine can be called 
c       from any place of user's program.
c       For example we just run several events and print ionization positions.

        do nevt=1,qevt          ! Loop over events

                call GoEventn(nevt,qevt)        ! Simulation of one event
                call PriCel                     ! Print to 'oo' device

        enddo

        end


+DECK,EHEED,IF=EHEED.
c       Initialization of HEED for simulation event by event
c       with calls of HEED from another program.
c       Volumes and tracks are to be initialized by usual HEED routines:
c       IniFVolume, IniNVolume, and IniRTrack


        subroutine IMHEED
     +  (qmol, nmol, pwmol, ppres, ptemp, psoo, poo, debug,
     +  density, ierror) 
c
c       The subroutine for initialization of the medium.
c       Required are only information about matter.
c       Cross sections are to be initialized later, when the particle
c       velosity is fixed.
c
        implicit none

c       include 'GoEvent.inc'
+SEQ,GoEvent.
c         include 'molecules.inc'
+SEQ,molecule.
c         include 'molecdef.inc'
+SEQ,molecdef.


c         include 'ener.inc'
+SEQ,ener.
c         include 'atoms.inc'
+SEQ,atoms.
c         include 'matters.inc'
+SEQ,matters.
c       include 'crosec.inc'
+SEQ,crosec.

c         include 'cconst.inc'
+SEQ,cconst.
c         include 'volume.inc'
+SEQ,volume.
c         include 'part.inc'
+SEQ,part.
c         include 'hist.inc'
+SEQ,hist.
        

c         include 'random.inc'
+SEQ,random.
+SEQ,PRINTPLOT.


        integer qmol            ! Quantity of different molecules 
                                ! in the gas mixture.
        integer nmol(pqMol)     ! Their numbers from molecules.inc.
                                ! Use only the named constants
                                ! for compartibility with the future versions
        real pwmol(pqMol)       ! Their weights 
                                ! (relative quantities of molecules).
        real ppres              ! Pressure in Torr.
        real ptemp              ! Temperature in K.
        integer psoo            ! Flag allowing to write.
        integer poo             ! Output stream number.
        integer debug           ! Flag allowing to write  
                                ! more amount of information.

c       Output parameters:
        real density            ! Density, calculated as for ideal gas, gr/cm3
        integer ierror          ! Sign of error( 0 -- no error ).

        real wmol(pqMol)

C       integer nc
        integer n,i
        real s

        real pres               ! Pressure in Torr.
        real temp               ! Temperature in K.
        
c       real step_integ_ar
        integer tresh
        parameter (tresh=20)
c       real e1,e2

        integer nmat
        integer nat
*** Additional debug output (RV 13/8/98).
        IF(LDEBUG)THEN
             WRITE(LUNOUT,'(''  ++++++ IMHEED DEBUG   : '',
     -            ''Pressure:       '',F10.3,'' Torr''/26X,
     -            ''Temperature:    '',F10.3,'' K''/26X,
     -            ''Gas components: '',I5/26X,
     -            ''Identifier    Fraction'')') ppres,ptemp,qmol
             DO I=1,qmol
             WRITE(LUNOUT,'(26X,I10,F12.4)') nmol(i),pwmol(i)
             ENDDO
        ENDIF
*** End of modification.

c       restore after previous run

        do nat=1,pQAt
                Zat(nat)=0
        enddo

        nmat=1

        QAtMat(nmat)=0

c       go ahead

        s=0.0
        do n=1,qmol
          s=s+pwmol(n)
        enddo
        do n=1,qmol
          wmol(n)=pwmol(n)/s
        enddo


        call Iniranfl

        soo=psoo
        oo=poo
        sret_err=1

        sHist=0                 ! To ban operating with historgams
        HistFile='heed.hist'    ! To make sure. Histograms must not be filled
                                ! and written here.
        maxhisampl=40.0e-3
        maxhisampl2=20.0e-3
        maxhisample=200
        pqhisampl=100
        shfillrang=0

c       Random number genarator
        sseed=0
        seed(1)=1121517854      ! this is example
        seed(2)=612958528


        qevt=1       ! Quantity of events to generate

        ssimioni=1              ! Simulate ionization loss
        ninfo=0                 ! Number of first events with output listing

        call Inishl                     ! Cascade from excited atom

        call IniEner(150,3e-6,0.2)      ! Energy mesh
        if(debug.ge.2)call PriEner

        call AtomsByDefault             ! Library of atoms
*** Added argument to PriAtoms (RV 13/4/99)
        if(debug.ge.2)call PriAtoms(0)
*** End of modification.

        if(ppres.eq.0)then
                pres=Atm_Pressure
        else
                pres=ppres
        endif

        if(ptemp.eq.0)then
                temp=Atm_Temper
        else
                temp=ptemp
        endif

        call molecdef
        if(debug.ge.2)call Primolec

        call Inigas(nmat, qmol, nmol, wmol, pres, temp)
*** Added argument to PriMatter (RV 13/4/99).
        if(debug.ge.2)call PriMatter(0)
*** End of modification.
        if(s_err.eq.1)then
                ierror=1
                return
        endif
        density=DensMat(nmat)

        end


        subroutine IPHEED
     +  (ptkener, pmas, debug,
     +  ierror) 

c       Initialization of particle, cross sections, 
c       and tracing of delta-electrons.
c       The volume(s) have to be initialized before!

        implicit none

c       include 'GoEvent.inc'
+SEQ,GoEvent.

        real ptkener            ! Kinetic energy of incident particle.
        real pmas               ! Mass of incident particle.
                ! In the case of zero in two above var. the following
                ! two ones will be sensible (see text).
        real tkener             ! Kinetic energy of incident particle.
        real mas                ! Mass of incident particle.

        integer debug           ! Flag allowing to write  
                                ! more amount of information.

c       Output parameters:
        integer ierror          ! Sign of error( 0 -- no error ).


        if(pmas.eq.0)then
                mas=938
        else
                mas=pmas
        endif

        if(ptkener.eq.0)then
                tkener=mas*(4-1)        ! 'mip'
        else
                tkener=ptkener
        endif

        call IniPart(tkener,mas)        ! Particle
        if(debug.ge.2)call Pripart
        if(s_err.eq.1)then
                ierror=1
                return
        endif

        call IniCrosec                  ! Cross sections
        if(debug.ge.2)call PriCrosec(1,1)
                
        call InisBdel                   ! Data for tracing of delta-electrons

        end

c       After that the track must still be initialized by IniRTrack.

c       The UBegEvent end UEndEvent subroutine can be empty in this case.

        subroutine UBegEvent

        end

        subroutine UEndEvent

        end

c       The GoEvent must know the number of the current event
c       and the total ordered event number. If there was an overflow
c       of any controlled array - arrays with delta-electrons,
c       conduction electrons, real photons, virtual photons,
c       the GoEvent prints the wornings and auxiliary information
c       to the 'oo' after the last event generated.
c       So as avoid of including of GoEvent.inc , where the event number
c       nevt and quantity of events qevt are stored, user can call GoEventn , 
c       that takes nevt and qevt as arguments and simulates ONE event.

        subroutine GoEventn(pnevt, pqevt)

        implicit none

c         include 'GoEvent.inc'
+SEQ,GoEvent.
        integer pnevt, pqevt

        nevt = pnevt    
        qevt = pqevt

        call GoEvent

        end
+DECK,MainHEED,IF=E.
 

        program HEED
c
c       The main program for HEED package
c
        implicit none

        integer NPW
        PARAMETER (NPW = 2000000)
        real H
        COMMON /PAWC/ H(NPW)

c       include 'GoEvent.inc'
+SEQ,GoEvent.
c       include 'volume.inc'
+SEQ,volume.
c       include 'hist.inc'
+SEQ,hist.


        CALL HLIMIT(NPW)

        call Iniranfl           ! Initialization of the counter of
                                ! random number generator calls
        call IniHeed            ! User's subroutine,
                                ! Initialization of the detector

        if(sHist.eq.1)then
                call IniHist    ! Initialization of inbilt histograms
        endif


        do nevt=1,qevt          ! Loop over events

                call GoEvent    ! Simulation of one event

        enddo


        if(sHist.eq.1)then
                call WHist      ! Writting of histograms
        endif


        call Priranfl           ! Print the number of calls of
                                ! random number generator
        end
+DECK,GoEvent.
 

        subroutine GoEvent
c
c       Event processor. It is called from MainHEED.
c
        implicit none

c       include 'GoEvent.inc'
+SEQ,GoEvent.
c       include 'abs.inc'
+SEQ,abs.
c       include 'rga.inc'
+SEQ,rga.
c       include 'volume.inc'
+SEQ,volume.
c       include 'hist.inc'
+SEQ,hist.
c       include 'random.inc'
+SEQ,random.

        integer iempty


c       if(nevt.le.ninfo)then
        if(soo.eq.1)then
        write(oo,*)
        write(oo,*)' Event number ',nevt
        endif
        if(nevt.eq.1.and.sseed.eq.1)then
                call randset            ! Set the start point of
        endif                           ! the random number generator.
        if(soo.eq.1)then
                call randget
                call randpri(oo)        ! Print the current point of
        endif                           ! the random number generator.
c       endif

        call IniNTrack                  ! Generate the next track.
        if(nevt.le.ninfo)then
                call PriMTrack(0)       ! Print debug information
                call PriMTrack(1)
                call PriMTrack(2)
                call PriMTrack(3)
                call PriMTrack(4)
        endif           

        call IniLsgvga                  ! Initialize gvga.inc
        call Iniabs                     ! Initialize abs.inc
        call Inirga                     ! Initialize rga.inc
        call Inidel                     ! Initialize del.inc
        call Inicel                     ! Initialize cel.inc

        call UBegEvent                  ! User's subroutine

        if(ssimioni.eq.1)call rafflev   ! Generate the primary energy transfers
                                        ! from incoming particle

        if(soo.eq.1)then
        if(nevt.le.ninfo)then
                write(oo,*)
                call PriLsgvga          ! Print debug information
        endif
        endif

        do iempty=1,10000

                if(soo.eq.1)then
                if(nevt.le.ninfo)then
                        write(oo,*)
                        write(oo,*)' before absorption of virtual photons:'   
                        call Priabs     ! Print debug information

                endif
                endif

                call AbsGam             ! Absorb the virtual photons

                if(soo.eq.1)then
                if(nevt.le.ninfo)then   ! Print debug information
                        write(oo,*)             
                        write(oo,*)' after absorption of virtual photons:'
         
c                       call Priabs
                        call Prirga
                        call Pridel

                endif
                endif
        
                call GoGam              ! Absorb the photons

                if(soo.eq.1)then
                if(nevt.le.ninfo)then   ! Print debug information
                        write(oo,*)
                        write(oo,*)' after absorption of photons:'

                        call Priabs
c                       call Prirga
                        call PrirgaF

                endif
                endif

                if(ctagam.gt.qtagam.and.crga.gt.qrga)then
                                        ! There are neither real no
                                        ! virtual photons to trace.
                        goto 50         ! Exit the loop.
                endif
        
        enddo

50      continue


        call treatdel                   ! Trace the delta-electrons
                                        ! and generate the conduction electrons.
        call treatcel                   ! Treat the cel.inc
        if(soo.eq.1)then
        if(nevt.le.ninfo)then   ! since there are calculation of ranges
                                ! which in wroute to del inside treatdel
                write(oo,*)
                call Pridel
c               call Pricel
        endif
        endif

        if(sHist.eq.1)then
                call Fhist      ! Fill predetermined histograms
        endif

        call UEndEvent          ! User's routine

        if(soo.eq.1)then
        if(nevt.eq.qevt)then
                write(oo,*)
                write(oo,*)nevt,' events is done'
                                ! Printing the wornings about overful
                call WorPrirga
                call WorPriabs
                call WorPridel
                call WorPricel

        endif
        endif


        end
+DECK,IniHeed1,IF=E1.
 

        subroutine IniHeed
c           
c       The program for estimation of the
c       ultimate coordinate resolution of the proportional chamber      
c
c       Also the table of clusters number distribution  may be generated.
c

        implicit none

c         include 'GoEvent.inc'
+SEQ,GoEvent.
c         include 'hist.inc'
+SEQ,hist.

c         include 'ener.inc'
+SEQ,ener.
c         include 'atoms.inc'
+SEQ,atoms.
c         include 'matters.inc'
+SEQ,matters.
        
c       include 'molecules.inc'
+SEQ,molecule.

c       include 'cconst.inc'
+SEQ,cconst.
c         include 'volume.inc'
+SEQ,volume.
c         include 'part.inc'
+SEQ,part.
c         include 'h1.inc'
+SEQ,h1.
c       include 'random.inc'
+SEQ,random.

        real tkener,mas,momentum
        integer qmol,nmol(3)
        real wmol(3)

        integer i
        integer j


        real ystart, an, wid   ! the last is widht of the chamber
                     ! the angle
             ! it is calculated from two next values so as
             ! the middle was on zero

        real amc
        integer na
        

        write(6,*)' Initialization started'
        soo=1           ! To allow (1) or to ban (0) printing to stream oo.
        oo=10           ! set logical number of output stream.
        TaskName='heed01_2.'
        OutputFile=TaskName//'out'
        open(oo,FILE=OutputFile)  ! open output disk file.

        sret_err = 0    ! Stop if error is detected

c       Auxiliary variables for histograms (from hist.inc) 
        sHist=1         ! To allow (1) or to ban (0) dealing with histograms.
        HistFile=TaskName//'hist'       ! File name, where they are written to.
        maxhisampl=40.0e-3      ! Maximum aplitude.
        maxhisampl2=20.0e-3     ! Reduced maximum aplitude.
        maxhisample=150         ! Maximum aplitude in unit of number of elect.
        pqhisampl=100           ! Number of bins.
        shfillrang=1    ! To allow (1) or to ban (0) filling histogram nh2_rd.  


c       Random number genarator
        sseed=0         ! To make the generator start from seed point (1)
                        ! or from default point (0).
        seed(1)=1121517854      ! this is example for sseed=1
        seed(2)=612958528


        qevt=1000               ! Quantity of events to generate

        ssimioni=1      ! To allow ionization loss (1) or to ban it (0)
        ninfo=0         ! Number of first events with output listing


        call Inishl                     ! Cascade from excited atom

        call IniEner(150,3e-6,0.2)      ! Energy mesh

c       call PriEner

        call AtomsByDefault             ! Library of atoms
c       call PriAtoms(0)

        Cur_Pressure=Atm_Pressure
        Cur_Temper=Atm_Temper

c       call Xenon_dens_Ar (1)          ! Materials from LibAtMat
c       call Textolite   (2)
c       call CF4        (1)
c       call CF4_without_cor    (1)
c       call lCO2       (1)
c       call CO2_without_cor    (1)
c       call CO250CF420Ar30(1)
c       call  Ar80C2H620(1)
c       call lArgon      (1)
c       call Ar93CH407   (1)
c       call Oxigen     (1)
c       call Kripton    (1)

        call molecdef
c       call Primolec


        qmol=3
        nmol(1)=numm_Ar
        wmol(1)=0.30
        nmol(2)=numm_CO2
        wmol(2)=0.50
        nmol(3)=numm_CF4
        wmol(3)=0.20

        call Inigas( 1, qmol, nmol, wmol, Cur_Pressure, Cur_Temper)

c        call PriMatter(0)


        wid=1.0         ! width of layer.

        call IniFVolume(0, 1, 1, 1, 0.0, wid  ) 

        call PriVolume


c       mas=105.0       !  muon 
        mas=938         ! proton
c       momentum=100000.0
c       tkener=sqrt(mas*mas+momentum*momentum)-mas
        tkener = mas * (4-1)    ! 'mip'

        call IniPart(tkener,mas)        ! Particle
        call PriPart

c       The special iinitialization for track

c       an=30.0
        an=0.0
        an=an * 2.0 * PI / 360.0     ! go from grad to radians
        ystart = wid*tan(an)/2

        call IniRTrack(-ystart, -ystart, an, real(PI/2.0))      ! Track
c       call PriTrack

        call IniCrosec                  ! Cross sections
        call PriCrosec(1,1)


        call InisBdel                   ! Data for tracing of delta-electrons


c       Additional histograms

        hhis=mhis/qhis

        qamp=5
c       ampc(1)=10.0
c       ampc(2)=30.0
c       ampc(3)=100.0
c       ampc(4)=300.0
c       ampc(5)=10000000.0
c       amc=19.82
        amc=22.29
c       amc=49.32
c       amc=49.32 * 2
        ampc(1)=amc
        ampc(2)=2*amc
        ampc(3)=3*amc
        ampc(4)=5*amc
        ampc(5)=10000000.0
        
        write(oo,*)' ampc=',ampc


        qe=0

        do na=1,qamp
        do j=1,qhis
            do i=1,2
                npp(j,i,na)=0
                pp1(j,i,na)=0.0 
                pp2(j,i,na)=0.0 
            enddo
        enddo
        enddo

        do na=1,qamp
        do i=1,2        ! distribution of the centers of gravity
                        ! of ionization along x (1) and y (2)
        call hbook1(30000+10*na+(i-1)+1,'  $',
     +          2*qhis,-mhis,mhis,0.0)
        enddo
        do i=3,6
        call hbook1(30000+10*na+(i-1)+1,'  $',
     +          qhis,0.0,mhis,0.0)
        enddo
        enddo
        meanprob=0.0
        meanvga=0.0
        meanvgal=0.0
        do i=1,1000
                prob(i)=0.0
        enddo


        write(6,*)' Initialization finished'

        end


+DECK,UEvent1,IF=E1.
 
     
        subroutine UBegEvent

        implicit none

c       include 'GoEvent.inc'
+SEQ,GoEvent.


        end

        subroutine UEndEvent

        implicit none

c       include 'GoEvent.inc'
+SEQ,GoEvent.
c         include 'ener.inc'
+SEQ,ener.
c         include 'atoms.inc'
+SEQ,atoms.
c         include 'matters.inc'
+SEQ,matters.
c       include 'volume.inc'
+SEQ,volume.
c       include 'del.inc'
+SEQ,del.
c       include 'cel.inc'
+SEQ,cel.
c       include 'h1.inc'
+SEQ,h1.
c       include 'lsgvga.inc'
+SEQ,lsgvga.

        integer i,j,k,n,nb
        integer nc,na,nq
        real s,sz
        real*8 p(2)             ! coordinates of center of gravity
                                ! along x and y for current event.
        real x
        

        do i=1,2
                p(i)=0.0
        enddo
        nq=0
        sz=0.0
        do nc=1,qcel(1)

        nq=nq+1
        sz=sz+1
        do i=1,2
                p(i)=p(i)+pntcel(i,nc,1)*10000.0
        enddo

        enddo

        if(nq.gt.0)then

        qe=qe+1

        do i=1,2
                p(i)=p(i)/nq
        enddo
        do na=1,qamp
        if(sz.le.ampc(na))then
        call hfill(30000+10*na+1,real(p(1)),0.0,1.0)
        call hfill(30000+10*na+2,real(p(2)),0.0,1.0)
        endif
        enddo
        do na=1,qamp
        if(sz.le.ampc(na))then                  ! amplitude cut
        do j=1,qhis
            x=hhis*j
            do i=1,2    
                if(abs(p(i)).le.x)then          ! coordinate cut
                    npp(j,i,na)=npp(j,i,na)+1
                    pp1(j,i,na)=pp1(j,i,na)+p(i)
                    pp2(j,i,na)=pp2(j,i,na)+p(i)*p(i)
                endif
            enddo
        enddo
        endif
        enddo

        endif

        n=0
        if(qcel(1).eq.0)then
                goto 10
        endif
        nb=Ptdel(Ndelcel(1,1))
        k=0
        do nc=1,qcel(1)+1
                k=0
                if(nc.eq.qcel(1)+1)then
                        k=1
                else
                if(nc.gt.1.and.Ptdel(Ndelcel(nc,1)).ne.nb)then
                        k=1
                endif
                endif
                if(k.eq.1)then
                        if(n.le.0)then
                            write(oo,*)' n=',n
                            n=1
                        endif
                        if(n.ge.1001)then
                            write(oo,*)' n=',n
                            n=1000
                        endif
                        prob(n)=prob(n)+1
                        n=1
                        if(nc.le.qcel(1))then
                            nb=Ptdel(Ndelcel(nc,1))
                        endif
                else
                        n=n+1
                endif
        enddo
        meanprob=meanprob+qcel(1)
        meanvga=meanvga+qgvga(1)
        meanvgal=meanvgal+esgvga(1)

10      continue

        if(nevt.eq.qevt)then
        meanprob=meanprob/qevt
        meanvga=meanvga/qevt
        meanvgal=meanvgal/qevt
        s=0.0
        do n=1,1000
                s = s + prob(n)
        enddo
        do n=1,1000
                prob(n) = prob(n) / s
        enddo
        
        write(oo,*)
     +  ' mean quantity of energy transfers from inc. part.= ',meanvga
        write(oo,*)
     +  ' mean energy loss, Kev                            = ',
     +          meanvgal*1000.0
        write(oo,*)
     +  ' mean number of conduction electrons              = ',meanprob
        write(oo,*)
     +  '    number of conduction electrons in cluster vs probability:'
        do n=1,200
        write(oo,*)n,prob(n)
        enddo

c       do na=1,qamp
c       do j=1,qhis
c           do i=1,2    
c       write(oo,*)' pp:',j,i,na,npp(j,i,na),pp1(j,i,na),pp2(j,i,na)
c            enddo
c       enddo
c       enddo

        do na=1,qamp
        do j=1,qhis
            do i=1,2
            if(npp(j,i,na).gt.0)then
                pp1(j,i,na)=pp1(j,i,na)/npp(j,i,na)
                pp2(j,i,na)=pp2(j,i,na)/npp(j,i,na)
                pp1(j,i,na)=sqrt(pp2(j,i,na)-pp1(j,i,na)*pp1(j,i,na))
            else
                pp1(j,i,na)=0.0
            endif
            enddo
        enddo
        enddo

        do na=1,qamp    
        do j=1,qhis
            do i=1,2    
                rpp1(j,i,na)=pp1(j,i,na)
             enddo
        enddo
        enddo

        do na=1,qamp
        do i=1,2
                call hpak(30002+10*na+i,rpp1(1,i,na))
        enddo           
        enddo

        do na=1,qamp
        do j=1,qhis
            do i=1,2
                rpp2(j,i,na)=qe-npp(j,i,na)
            enddo
        enddo
        enddo

        do na=1,qamp
        do i=1,2
                call hpak(30004+10*na+i,rpp2(1,i,na))
        enddo           
        enddo    
        
        write(6,*)' The program finished'

        endif


        end
+DECK,IniEner.
        SUBROUTINE IniEner(q,emin,emax)
C
c       define the energy mesh for ionization loss
c       and photoabsorbtion     
c
        implicit none

c       include 'ener.inc'
+SEQ,ener.
C
        integer q
        real emin,emax


        qener=q
        call logscale(q,emin,emax,ener,enerc)

        END

        subroutine PriEner

c         include 'GoEvent.inc'
+SEQ,GoEvent.
c       include 'ener.inc'
+SEQ,ener.

        integer i

        if(soo.eq.0)return
        write(oo,*)
        write(oo,*)' PriEner: Energy mesh'
        write(oo,*)' qener=',qener
        write(oo,*)' ener, left edges     enerc, the centers (MeV)'
        do i=1,qener
        write(oo,*)ener(i),enerc(i)
        enddo

        end
+DECK,logscale.
        subroutine logscale(q,xmin,xmax,x,xc)
c
c       Make a logariphmic mesh.
c
        implicit none
        integer q
        real xmin,xmax
        real x(*),xc(*)

        real rk,xr
        integer i
        rk=(xmax/xmin)**(1.0/q)
        xr=xmin
        x(1)=xr

        do i=2,q+1
                x(i)=xr*rk
                xc(i-1)=(x(i-1)+x(i))*0.5
                xr=x(i)
        enddo

        end

        subroutine logscale0(q,xmin,xmax,x,xc)
c
c       Make a logariphmic mesh with linear begin.
c       First, the logariohmic scale is calculated.
c       Second, the program tries to prolong it to zero
c       with the same number of points.
c       So several points of begin of logariphmic scale will be recalculeted.
c
        implicit none
        integer q
        real xmin,xmax
        real x(*),xc(*)
        integer i,j
        real r,h

        call logscale(q,xmin,xmax,x,xc)

        if(q.ge.2)then

        do i=2,q
          r = x(i) / ( x(i+1) - x(i) )
          if( r .le. i-1 )then
            h = x(i) / ( i - 1 )
            x(1) =  0.0
            do j = 2,i
              x(j) = h * ( j - 1 )
              xc(j-1) = (x(j) + x(j-1))*0.5
            enddo
            go to 10
          endif
        enddo
        write(6,*)' error in logscale0'
        stop

        else

          write(6,*)' error in logscale0'
          stop

        endif

10      end
+DECK,Inishl.
 

        subroutine Inishl

c       Initialize common comshl
c       It will be very difficult
c       Modifying is the best way to loss your temper 
c       Description of channels of getting exiting from atom
c        after photoabsorbtion and electron emission

        implicit none

c       include 'shl.inc'
+SEQ,shl.

        integer n

c       qatm=0          !nahui!
        qatm=2

c       Argon
        charge(1)=18
        qshl(1)=5
        eshell(1,1)=.3178E-2
        eshell(2,1)=.3135E-3
        eshell(3,1)=.2479E-3
        eshell(4,1)=.2892E-4
        eshell(5,1)=.1449E-4
        qschl(1,1)=2
        qschl(2,1)=2
        qschl(3,1)=2
        qschl(4,1)=0
        qschl(5,1)=0
        secprobch(1,1,1)=0.878
        secprobch(2,1,1)=1.0
        secprobch(1,2,1)=0.999
        secprobch(2,2,1)=1.0
        secprobch(1,3,1)=0.999
        secprobch(2,3,1)=1.0
        qsel(1,1,1)=1
        qsga(1,1,1)=0
        qsel(2,1,1)=0
        qsga(2,1,1)=1
        qsel(1,2,1)=1
        qsga(1,2,1)=0
        qsel(2,2,1)=0
        qsga(2,2,1)=1
        qsel(1,3,1)=1
        qsga(1,3,1)=0
        qsel(2,3,1)=0
        qsga(2,3,1)=1
        secenel(1,1,1,1)=eshell(1,1)-2.0*eshell(5,1)
        secenga(1,2,1,1)=eshell(1,1)-eshell(5,1)
        secenel(1,1,2,1)=eshell(2,1)-2.0*eshell(5,1)
        secenga(1,2,2,1)=eshell(2,1)-eshell(5,1)
        secenel(1,1,3,1)=eshell(3,1)-2.0*eshell(5,1)
        secenga(1,2,3,1)=eshell(3,1)-eshell(5,1)

c       Xenon
        n=2
        charge(n)=54
        qshl(n)=6
        eshell(1,n)=0.041328
c       eshell(2,n)=0.006199
        eshell(2,n)=0.0041
        eshell(3,n)=0.000827
        eshell(4,n)=0.00031
        eshell(5,n)=8.265694e-05
        eshell(6,n)=1.239854e-05
        qschl(1,n)=2
        qschl(2,n)=2
        qschl(3,n)=0
        qschl(4,n)=0
        qschl(5,n)=0
        qschl(6,n)=0
        secprobch(1,1,n)=0.106
        secprobch(2,1,n)=1.0
        secprobch(1,2,n)=0.897
        secprobch(2,2,n)=1.0
        qsel(1,1,n)=1
        qsga(1,1,n)=0
        qsel(2,1,n)=0
        qsga(2,1,n)=1
        qsel(1,2,n)=1
        qsga(1,2,n)=0
        qsel(2,2,n)=0
        qsga(2,2,n)=1
        secenel(1,1,1,n)=eshell(1,n)-2.0*eshell(6,n)
        secenga(1,2,1,n)=eshell(1,n)-eshell(6,n)
        secenel(1,1,2,n)=eshell(2,n)-2.0*eshell(6,n)
        secenga(1,2,2,n)=eshell(2,n)-eshell(6,n)


        end


        subroutine Prishl

c       print the featcher of the mater

        implicit none

c         include 'GoEvent.inc'
+SEQ,GoEvent.
c       include 'shl.inc'
+SEQ,shl.

        integer iatm, ishl, ischl, isel, isga

        if(soo.eq.0)return
        write(oo,*)
        write(oo,*)' Prishl: print materials '
        write(oo,*)' qatm=',qatm
        do iatm=1,qatm
        write(oo,*)' ****atom=',iatm
        write(oo,*)' charge()=',charge(iatm),
     +          ' qshl(iatm)= ',qshl(iatm)
        do ishl=1,qshl(iatm)
        write(oo,*)' ----number of shell=',ishl
        write(oo,*)' eshell(ishl,iatm)=',eshell(ishl,iatm),
     +  ' qschl(ishl,iatm)=',qschl(ishl,iatm)
        do ischl=1,qschl(ishl,iatm)
        write(oo,*)' ------number of channel=',ischl
        write(oo,*)' qsel(ischl,ishl,iatm)=',qsel(ischl,ishl,iatm),
     +  ' qsga(ischl,ishl,iatm)=',qsga(ischl,ishl,iatm)
        do isel=1,qsel(ischl,ishl,iatm)
        write(oo,*)' -------- electron number ',isel
        write(oo,*)' secenel(isel,ischl,ishl,iatm)=',
     +          secenel(isel,ischl,ishl,iatm)
        enddo
        do isga=1,qsga(ischl,ishl,iatm)
        write(oo,*)' -------- photon   number ',isga
        write(oo,*)' secenga(isga,ischl,ishl,iatm)=',
     +          secenga(isga,ischl,ishl,iatm)
        enddo
        enddo
        enddo
        enddo
        

        end
+DECK,LibAtMat.
        subroutine AtomsByDefault
c
c       Initializations of several atoms
c
        implicit none

c         include 'ener.inc'
+SEQ,ener.
c         include 'atoms.inc'
+SEQ,atoms.
c         include 'LibAtMat.inc'
+SEQ,LibAtMat.

c       integer na

        KeyTeor=0
        QseqAt=0                ! It is necessary before run IniAtom
                                ! ( if memory is not cleaned automatically).
c       do na=1,pQAt
c               num_at_mol(na)=0
c       enddo


        call IniAtom(num_H  ,  1,   1.0 )       ! H
        call IniAtom(num_H3 ,  1,   1.0 )       ! H in CH4
        call IniAtom(num_H4 ,  1,   1.0 )       ! H in NH3
        call IniAtom(num_He ,  2,   4.0 )       ! He
        call IniAtom(num_Li ,  3,   6.94)       ! Li
        call IniAtom(num_C  ,  6,  12.01)       ! C
c       num_at_mol(num_C1)=1    
        call IniAtom(num_C1  ,  6,  12.01)      ! C in CO2
c       num_at_mol(num_C2)=2    
        call IniAtom(num_C2  ,  6,  12.01)      ! C in CF4
        call IniAtom(num_C3  ,  6,  12.01)      ! C in CH4
        call IniAtom(num_N  ,  7,  14.01)       ! N
        call IniAtom(num_O  ,  8,  16.0 )       ! O
        call IniAtom(num_F  ,  9,  19.0 )       ! F
        call IniAtom(num_Ne , 10,  20.2 )       ! Ne
        call IniAtom(num_Al , 13,  26.98)       ! Al
        call IniAtom(num_Si , 14,  28.09)       ! Si
        call IniAtom(num_Ar , 18,  40.0 )       ! Ar
        call IniAtom(num_Kr , 36,  84.0 )       ! Kr
        call IniAtom(num_Xe , 54, 131.3 )       ! Xe    
*** Additions (RV, 20/9/99).
        call IniAtom(num_S  , 16,  32.066)      ! S

        end
+DECK,HELIUM,IF=NEVER.
        subroutine Helium(nm)
c
c       Initialization of Matter
c
        implicit none

        integer nm
c         include 'LibAtMat.inc'
+SEQ,LibAtMat.

        integer A(10)
        real AW(10)
        integer q
        real Ad(10),AWd(10)
        integer qd
        real dens
        real gasdens

        q=1                             ! Helium
        A(1)=num_He
        AW(1)=1

        qd=1
        Ad(1)=4.0
        AWd(1)=1
        dens=gasdens(Ad,AWd,qd)
        call IniMatter(nm,A,AW,q,dens,30.0e-6,0.19)

        end
+DECK,AIR,IF=NEVER.
        subroutine Air(nm)
c
c       Initialization of Matter
c
        implicit none

        integer nm
c         include 'LibAtMat.inc'
+SEQ,LibAtMat.

        integer A(10)
        real AW(10)
        integer q
        real Ad(10),AWd(10)
        integer qd
        real dens
        real gasdens

        q=2                             ! Air
        A(1)=num_N  ! N
        AW(1)=0.7
        A(2)=num_O  ! O
        AW(1)=0.3

        qd=2
        Ad(1)=28.02
        AWd(1)=0.7
        Ad(2)=32
        AWd(2)=0.3
        dens=gasdens(Ad,AWd,qd)
        call IniMatter(nm,A,AW,q,dens,30.0e-6,0.19)

        end
+DECK,LDME,IF=NEVER.
        SUBROUTINE LDME(NM)
*-----------------------------------------------------------------------
*   LDME   - Initialises DME data
*   (Last changed on 18/ 2/97.)
*-----------------------------------------------------------------------
        implicit none
+SEQ,LibAtMat.
        INTEGER A(10),Q,NM
        REAL AW(10),WORK,FANO,DENS
*** Composition.
        Q=3
        A(1)=num_H
        AW(1)=6
        A(2)=num_O
        AW(2)=1
        A(3)=num_C3
        AW(3)=2
*** Density.
        DENS=0.00191
*** Work for a pair [MeV].
        WORK=30E-6
*** Fano factor.
        FANO=0.19
*** Initialise.
        CALL IniMatter(NM,A,AW,Q,DENS,WORK,FANO)
        END
+DECK,N2O69,IF=NEVER.
        subroutine N2_0_69Torr(nm)
c
c               N2 with presure 0.69 Torr
c       Initialization of Matter
c
        implicit none

        integer nm
c         include 'LibAtMat.inc'
+SEQ,LibAtMat.

        integer A(10)
        real AW(10)
        integer q
        real Ad(10),AWd(10)
        integer qd
        real dens
        real gasdens

        q=1                             ! N
        A(1)=num_N  ! N2
        AW(1)=1
        qd=1
        Ad(1)=2*14.0
        AWd(1)=1.0
        dens = gasdens(Ad,AWd,qd)
        dens = dens * (0.69/760.0)
c       dens = dens * (2.8/760.0)
        call IniMatter(nm,A,AW,q,dens,30.0e-6,0.19)

        end
+DECK,OXIGEN,IF=NEVER.
        subroutine Oxigen(nm)
c
c       Initialization of Matter
c
        implicit none

        integer nm
c         include 'LibAtMat.inc'
+SEQ,LibAtMat.

        integer A(10)
        real AW(10)
        integer q
        real Ad(10),AWd(10)
        integer qd
        real dens
        real gasdens

        q=1                             ! O 
        A(1)=num_O  ! O2
        AW(1)=1
        qd=1
        Ad(1)=2*16.0
        AWd(1)=1.0
        dens=gasdens(Ad,AWd,qd)
        call IniMatter(nm,A,AW,q,dens,30.0e-6,0.19)

        end
+DECK,LCO2,IF=NEVER.
        subroutine lCO2(nm)
c
c       Initialization of Matter
c
        implicit none

        integer nm
c         include 'LibAtMat.inc'
+SEQ,LibAtMat.

        integer A(10)
        real AW(10)
        integer q
        real Ad(10),AWd(10)
        integer qd
        real dens
        real gasdens

        q=2                             ! CO2
        A(1)=num_C1  ! C
        AW(1)=0.30
        A(2)=num_O  ! O2
        AW(2)=0.60
        qd=1
        Ad(1) = 12.01 + 2*16.0
        AWd(1)= 1
        dens=gasdens(Ad,AWd,qd)
        call IniMatter(nm,A,AW,q,dens,33.0e-6,0.19)

        end
+DECK,CO2WITHOUT,IF=NEVER.
        subroutine CO2_without_cor(nm)
c
c       Initialization of Matter
c
        implicit none

        integer nm
c         include 'LibAtMat.inc'
+SEQ,LibAtMat.

        integer A(10)
        real AW(10)
        integer q
        real Ad(10),AWd(10)
        integer qd
        real dens
        real gasdens

        q=2                             ! CO2
        A(1)=num_C  ! C
        AW(1)=0.30
        A(2)=num_O  ! O2
        AW(2)=0.60
        qd=1
        Ad(1) = 12.01 + 2*16.0
        AWd(1)= 1
        dens=gasdens(Ad,AWd,qd)
        call IniMatter(nm,A,AW,q,dens,33.0e-6,0.19)

        end
+DECK,CF4,IF=NEVER.
        subroutine CF4(nm)
c
c       Initialization of Matter
c
        implicit none

        integer nm
c         include 'LibAtMat.inc'
+SEQ,LibAtMat.

        integer A(10)
        real AW(10)
        integer q
        real Ad(10),AWd(10)
        integer qd
        real dens
        real gasdens

        q=2                             ! CF4
        A(1)=num_C2  ! C
        AW(1)=0.30
        A(2)=num_F  ! F
        AW(2)=1.20
        qd=1
        Ad(1) = 12.01 + 4*19.0
        AWd(1)= 1
        dens=gasdens(Ad,AWd,qd)
        call IniMatter(nm,A,AW,q,dens,34.3e-6,0.19)

        end
+DECK,CF4WITHOUT,IF=NEVER.
        subroutine CF4_without_cor(nm)
c
c       Initialization of Matter
c
        implicit none

        integer nm
c         include 'LibAtMat.inc'
+SEQ,LibAtMat.

        integer A(10)
        real AW(10)
        integer q
        real Ad(10),AWd(10)
        integer qd
        real dens
        real gasdens

        q=2                             ! CF4
        A(1)=num_C  ! C
        AW(1)=0.30
        A(2)=num_F  ! F
        AW(2)=1.20
        qd=1
        Ad(1) = 12.01 + 4*19.0
        AWd(1)= 1
        dens=gasdens(Ad,AWd,qd)
        call IniMatter(nm,A,AW,q,dens,34.3e-6,0.19)

        end
+DECK,CO250CF420,IF=NEVER.
        subroutine CO250CF420Ar30(nm)
c
c       Initialization of Matter
c
        implicit none

        integer nm
c         include 'LibAtMat.inc'
+SEQ,LibAtMat.

        integer A(10)
        real AW(10)
        integer q
        real Ad(10),AWd(10)
        integer qd
        real dens
        real gasdens
        real w

        q=4                             ! CO2 50% CF4 20% Ar 30%
        A(1)=num_C1  ! C
        AW(1)=0.50
        A(2)=num_O  ! O
        AW(2)=1.00
        A(1)=num_C2  ! C
        AW(1)=0.20
        A(3)=num_F  ! F
        AW(3)=0.8
        A(4)=num_Ar  ! Ar
        AW(4)=0.30
        qd=3
        Ad(1)=12.0+2*16.0       ! CO2
        AWd(1)=0.50
        Ad(2)=12.0+4*19.0       ! CF4
        AWd(2)=0.20
        Ad(3)=40.0              ! Ar
        AWd(3)=0.30
        dens=gasdens(Ad,AWd,qd)
        w=AWd(1)*33.0e-6 + AWd(2)*34.3e-6 + AWd(3)*26.4e-6
        
        call IniMatter(nm,A,AW,q,dens,w,0.19)

        end
+DECK,LARGON,IF=NEVER.
        subroutine lArgon(nm)
c
c       Initialization of Matter
c
        implicit none

        integer nm
c         include 'LibAtMat.inc'
+SEQ,LibAtMat.

        integer A(10)
        real AW(10)
        integer q
        real Ad(10),AWd(10)
        integer qd
        real dens
        real gasdens

        q=1                             !  Ar
        A(1)=num_Ar ! Ar
        AW(1)=1.0
        qd=1
        Ad(1)=40.0
        AWd(1)=1.0
        dens=gasdens(Ad,AWd,qd)
        call IniMatter(nm,A,AW,q,dens,26.4e-6,0.19)

        end
+DECK,AR95CH405,IF=NEVER.
        subroutine Ar95CH405(nm)
c
c       Initialization of Matter
c
        implicit none

        integer nm
c         include 'LibAtMat.inc'
+SEQ,LibAtMat.

        integer A(10)
        real AW(10)
        integer q
        real Ad(10),AWd(10)
        integer qd
        real dens
        real gasdens

        q=3                             !  Ar
        A(1)=num_Ar ! Ar
        AW(1)=0.95
        A(2)=num_C ! C
        AW(2)=0.05
        A(3)=num_H ! H
        AW(3)=0.20
        qd=2
        Ad(1)=40.0
        AWd(1)=0.95
        Ad(2)=12+4*1
        AWd(2)=0.05

        dens=gasdens(Ad,AWd,qd)
        call IniMatter(nm,A,AW,q,dens,26.4e-6,0.19)

        end
+DECK,AR93CH407,IF=NEVER.
        subroutine Ar93CH407(nm)
c
c       Initialization of Matter
c
        implicit none

        integer nm
c         include 'LibAtMat.inc'
+SEQ,LibAtMat.

        integer A(10)
        real AW(10)
        integer q
        real Ad(10),AWd(10)
        integer qd
        real dens
        real gasdens

        q=3                             !  Ar
        A(1)=num_Ar ! Ar
        AW(1)=0.93
        A(2)=num_C ! C
        AW(2)=0.07
        A(3)=num_H ! H
        AW(3)=0.28
        qd=2
        Ad(1)=40.0
        AWd(1)=0.93
        Ad(2)=12+4*1
        AWd(2)=0.07

        dens=gasdens(Ad,AWd,qd)
        call IniMatter(nm,A,AW,q,dens,26.4e-6,0.19)

        end
+DECK,AR90CH410,IF=NEVER.
        subroutine Ar90CH410(nm)
c
c       Initialization of Matter
c
        implicit none

        integer nm
c         include 'LibAtMat.inc'
+SEQ,LibAtMat.

        integer A(10)
        real AW(10)
        integer q
        real Ad(10),AWd(10)
        integer qd
        real dens
        real gasdens

        q=3                             !  Ar
        A(1)=num_Ar ! Ar
        AW(1)=0.90
        A(2)=num_C ! C
        AW(2)=0.10
        A(3)=num_H ! H
        AW(3)=0.40
        qd=2
        Ad(1)=40.0
        AWd(1)=0.90
        Ad(2)=12+4*1
        AWd(2)=0.10

        dens=gasdens(Ad,AWd,qd)
        call IniMatter(nm,A,AW,q,dens,26.4e-6,0.19)

        end
+DECK,AR80C2H620,IF=NEVER.
        subroutine Ar80C2H620(nm)
c
c       Initialization of Matter
c
        implicit none

        integer nm
c         include 'LibAtMat.inc'
+SEQ,LibAtMat.

        integer A(10)
        real AW(10)
        integer q
        real Ad(10),AWd(10)
        integer qd
        real dens
        real gasdens

        q=3                             !  Ar
        A(1)=num_Ar ! Ar
        AW(1)=0.80
        A(2)=num_C ! C
        AW(2)=0.20*2
        A(3)=num_H ! H
        AW(3)=0.20*6
        qd=2
        Ad(1)=40.0
        AWd(1)=0.80
        Ad(2)=2*12.0+6*1.0
        AWd(2)=0.20

        dens=gasdens(Ad,AWd,qd)
        call IniMatter(nm,A,AW,q,dens,26.4e-6,0.19)

        end
+DECK,KRIPTON,IF=NEVER.
        subroutine Kripton(nm)
c
c       Initialization of Matter
c
        implicit none

        integer nm
c         include 'LibAtMat.inc'
+SEQ,LibAtMat.

        integer A(10)
        real AW(10)
        integer q
        real Ad(10),AWd(10)
        integer qd
        real dens
        real gasdens

        q=1                             !  Kr
        A(1)=num_Kr ! Kr
        AW(1)=1.0
        qd=1
        Ad(1)=84.0
        AWd(1)=1.0
        dens=gasdens(Ad,AWd,qd)
        call IniMatter(nm,A,AW,q,dens,24.4e-6,0.19)

        end
+DECK,XENON,IF=NEVER.
        subroutine Xenon(nm)
c
c       Initialization of Matter
c
        implicit none

        integer nm
c         include 'LibAtMat.inc'
+SEQ,LibAtMat.

        integer A(10)
        real AW(10)
        integer q
        real Ad(10),AWd(10)
        integer qd
        real dens
        real gasdens

        q=1                             !  Xe
        A(1)=num_Xe ! Xe
        AW(1)=1.0
        qd=1
        Ad(1)=131.3
        AWd(1)=1.0
        dens=gasdens(Ad,AWd,qd)
        call IniMatter(nm,A,AW,q,dens,21.9e-6,0.19)

        end
+DECK,XE90CH410,IF=NEVER.
        subroutine Xe90CH410(nm)
c
c       Initialization of Matter
c
        implicit none

        integer nm
c         include 'LibAtMat.inc'
+SEQ,LibAtMat.

        integer A(10)
        real AW(10)
        integer q
        real Ad(10),AWd(10)
        integer qd
        real dens
        real gasdens

        q=3                             ! 90% Xe + 10% CH4
        A(1)=num_Xe ! Xe
        AW(1)=0.90
        A(2)=num_C  ! C
        AW(2)=0.10
        A(3)=num_H  ! H4
        AW(3)=0.40
        qd=2
        Ad(1)=131.3
        AWd(1)=0.90
        Ad(2) = 12.01 + 4*1.0
        AWd(2)= 0.10
        dens=gasdens(Ad,AWd,qd)
        call IniMatter(nm,A,AW,q,dens,21.9e-6,0.19)

        end
+DECK,XE95CH405,IF=NEVER.
        subroutine Xe95CH405(nm)
c
c       Initialization of Matter
c
        implicit none

        integer nm
c         include 'LibAtMat.inc'
+SEQ,LibAtMat.

        integer A(10)
        real AW(10)
        integer q
        real Ad(10),AWd(10)
        integer qd
        real dens
        real gasdens

        q=3                             ! 95% Xe + 05% CH4
        A(1)=num_Xe ! Xe
        AW(1)=0.95
        A(2)=num_C  ! C
        AW(2)=0.05
        A(3)=num_H  ! H4
        AW(3)=0.20
        qd=2
        Ad(1)=131.3
        AWd(1)=0.95
        Ad(2) = 12.01 + 4*1.0
        AWd(2)= 0.05
        dens=gasdens(Ad,AWd,qd)
        call IniMatter(nm,A,AW,q,dens,21.9e-6,0.19)

        end
+DECK,XE70,CH430,IF=NEVER.
        subroutine Xe70CH430(nm)
c
c       Initialization of Matter
c
        implicit none

        integer nm
c         include 'LibAtMat.inc'
+SEQ,LibAtMat.

        integer A(10)
        real AW(10)
        integer q
        real Ad(10),AWd(10)
        integer qd
        real dens
        real gasdens

        q=3                             ! 70% Xe + 30% CH4
        A(1)=num_Xe ! Xe
        AW(1)=0.70
        A(2)=num_C  ! C
        AW(2)=0.30
        A(3)=num_H  ! H4
        AW(3)=1.2
        qd=2
        Ad(1)=131.3
        AWd(1)=0.70
        Ad(2) = 12.01 + 4*1.0
        AWd(2)= 0.30
        dens=gasdens(Ad,AWd,qd)
        call IniMatter(nm,A,AW,q,dens,21.9e-6,0.19)

        end
+DECK,XE875CH4,IF=NEVER.
        subroutine Xe875CH4075C3H805(nm)
c
c       Initialization of Matter
c
        implicit none

        integer nm
c         include 'LibAtMat.inc'
+SEQ,LibAtMat.

        integer A(10)
        real AW(10)
        integer q
        real Ad(10),AWd(10)
        integer qd
        real dens
        real gasdens

        q=3                             ! 87.5% Xe + 7.5% CH4 + 5% C3H8
        A(1)=num_Xe ! Xe
        AW(1)=0.875
        A(2)=num_C  ! C
        AW(2)=0.05*3 + 0.075
        A(3)=num_H  ! H
        AW(3)=0.05*8 + 0.075*4
        qd=3
        Ad(1)=131.3
        AWd(1)=0.875
        Ad(2) = 12.01 + 4*1.0
        AWd(2)= 0.075
        Ad(3) = 3*12.01 + 8*1.0
        AWd(3)= 0.05
        dens=gasdens(Ad,AWd,qd)
        call IniMatter(nm,A,AW,q,dens,21.9e-6,0.19)

        end
+DECK,XE70CO2230,IF=NEVER.
        subroutine Xe70CO230(nm)
c
c       Initialization of Matter
c
        implicit none

        integer nm
c         include 'LibAtMat.inc'
+SEQ,LibAtMat.

        integer A(10)
        real AW(10)
        integer q
        real Ad(10),AWd(10)
        integer qd
        real dens
        real gasdens
        real w


        q=3                             ! 70% Xe + 30% CO2
        A(1)=num_Xe ! Xe
        AW(1)=0.70
        A(2)=num_C1  ! C
        AW(2)=0.30
        A(3)=num_O  ! O2
        AW(3)=0.60
        qd=2
        Ad(1)=131.3
        AWd(1)=0.70
        Ad(2) = 12.01 + 2*16.0
        AWd(2)= 0.30
        dens=gasdens(Ad,AWd,qd)
        w=AWd(1)*21.9e-6 + 0.30*33.0e-6
        call IniMatter(nm,A,AW,q,dens,w,0.19)

        end
+DECK,XENONAR,IF=NEVER.
        subroutine Xenon_dens_Ar(nm)
c
c       Initialization of Matter
c
        implicit none

        integer nm
c         include 'LibAtMat.inc'
+SEQ,LibAtMat.

        integer A(10)
        real AW(10)
        integer q
        real Ad(10),AWd(10)
        integer qd
        real dens
        real gasdens

        q=1                             !  Xe with density of Ar
        A(1)=num_Xe ! Xe
        AW(1)=1.0
        qd=1
        Ad(1)=40.0
        AWd(1)=1.0
        dens=gasdens(Ad,AWd,qd)
c        qd=1
c        Ad(1)=131.3
c        AWd(1)=1.0
c        dens=gasdens(Ad,AWd,qd)
        call IniMatter(nm,A,AW,q,dens,21.9e-6,0.19)

        end
+DECK,LITHIUM,IF=NEVER.
        subroutine Lithium(nm)
c
c       Initialization of Matter
c
        implicit none

        integer nm
c         include 'LibAtMat.inc'
+SEQ,LibAtMat.

        integer A(10)
        real AW(10)
        integer q
        real Ad(10),AWd(10)
        integer qd
        real dens
        real gasdens

        q=1                             ! Lithium
        A(1)=num_Li
        AW(1)=1
        dens=0.53
        call IniMatter(nm,A,AW,q,dens,30.0e-6,0.19)
*** Added argument to PriMatter (RV 13/4/99).
c       call PriMatter(0)
*** End of modification.

        end
+DECK,POLYETHYL,IF=NEVER.
        subroutine Polyethylene(nm)
c
c       Initialization of Matter
c
        implicit none

        integer nm
c         include 'LibAtMat.inc'
+SEQ,LibAtMat.

        integer A(10)
        real AW(10)
        integer q
        real Ad(10),AWd(10)
        integer qd
        real dens
        real gasdens

        q=2                             ! Polyethylene CH2
        A(1)=num_H  ! H2
        AW(1)=2
        A(2)=num_C  ! C
        AW(2)=1
        dens=0.925
        call IniMatter(nm,A,AW,q,dens,30.0e-6,0.19)

        end
+DECK,MYLAR,IF=NEVER.
        subroutine Mylar(nm)
c
c       Initialization of Matter
c
        implicit none

        integer nm
c         include 'LibAtMat.inc'
+SEQ,LibAtMat.

        integer A(10)
        real AW(10)
        integer q
        real Ad(10),AWd(10)
        integer qd
        real dens
        real gasdens

        q=3                             ! mylar C5H4O2
        A(1)=num_C  ! C5
        AW(1)=5
        A(2)=num_H  ! H4
        AW(2)=4
        A(3)=num_O  ! O2
        AW(3)=2
        dens=1.38
        call IniMatter(nm,A,AW,q,dens,30.0e-6,0.19)

        end
+DECK,ALUMINIUM,IF=NEVER.
        subroutine Aluminium(nm)
c
c       Initialization of Matter
c
        implicit none

        integer nm
c         include 'LibAtMat.inc'
+SEQ,LibAtMat.

        integer A(10)
        real AW(10)
        integer q
        real Ad(10),AWd(10)
        integer qd
        real dens
        real gasdens

        q=1                             ! aluminium
        A(1)=num_Al  ! Al
        AW(1)=1
        dens=2.7
        call IniMatter(nm,A,AW,q,dens,30.0e-6,0.19)

        end
+DECK,TEXTOLITE,IF=NEVER.
        subroutine Textolite(nm)
c
c       Initialization of Matter
c
        implicit none

        integer nm
c         include 'LibAtMat.inc'
+SEQ,LibAtMat.

        integer A(10)
        real AW(10)
        integer q
        real dens
c       textolite is SiO2 + epoxidka. The density is 1.7 g/sm**3.
c       We know also the density of SiO2 - 2.5 g/sm**3 and the typical
c       density of the carbone polimers is 1 g/sm**3. 
c       "epoxidka"( I don not know its right english name) is
c       a class of polimers. One of them is O-3, C-18, H-20.
c       We did't know
c       the ratio of the components in textolite, but knowing data above
c       we can calculate it.            
c      DATA WTEX/12., 27.0, 18. ,20./             
c       later comments
c       05.04.95
c       If Wi is weight coef. by volume and Di is density than
c       W1*D1+(1-W1)*D2=D => W1=(D-D2)/(D1-D2)=0.466
c                            W2=(D1-D)/(D1-D2)=0.534
c       If WKi is weight coef. by volume than
c       WK1=D1/A1 * W1=2.5/60 * 0.466 = 0.0194
c       WK2=D2/A2 * W2=1.0/284 * 0.534 = 0.00188
c       WK1/WK2 = 10.3
c      DATA WTEX/10.3, 23.6, 18. ,20./            


        q=4                             ! textolite
        A(1)=num_Si
        AW(1)=10.3
        A(2)=num_O
        AW(2)=23.6
        A(3)=num_C
        AW(3)=18.
        A(4)=num_H
        AW(4)=20.
        dens=1.7
        call IniMatter(nm,A,AW,q,dens,30.0e-6,0.19)

        end
+DECK,molecdef.
        subroutine molecdef

        implicit none

c         include 'ener.inc'
+SEQ,ener.
c         include 'atoms.inc'
+SEQ,atoms.

c       include 'molecules.inc'
+SEQ,molecule.
c       include 'molecdef.inc'
+SEQ,molecdef.
c       include 'LibAtMat.inc'
+SEQ,LibAtMat.
        
        integer n,na
        real s

c       Mean work per pair production is accordingly with
c       ICRU REPORT 31, Average Energy Required To Produce An Ion Pair, 1979.
        

        qSAtMol( numm_He)=1
        nAtMol(1,numm_He)=num_He
        qAtMol(1,numm_He)=1
        WWWMol(  numm_He)=41.0e-6
        FFFMol(  numm_He)=0.19

        qSAtMol( numm_Ne)=1
        nAtMol(1,numm_Ne)=num_Ne
        qAtMol(1,numm_Ne)=1
        WWWMol(  numm_Ne)=35.4e-6
        FFFMol(  numm_Ne)=0.19

        qSAtMol( numm_Ar)=1
        nAtMol(1,numm_Ar)=num_Ar
        qAtMol(1,numm_Ar)=1
        WWWMol(  numm_Ar)=26.0e-6
        FFFMol(  numm_Ar)=0.19

        qSAtMol( numm_Kr)=1
        nAtMol(1,numm_Kr)=num_Kr
        qAtMol(1,numm_Kr)=1
        WWWMol(  numm_Kr)=24.0e-6
        FFFMol(  numm_Kr)=0.19

        qSAtMol( numm_Xe)=1
        nAtMol(1,numm_Xe)=num_Xe
        qAtMol(1,numm_Xe)=1
        WWWMol(  numm_Xe)=22.0e-6
        FFFMol(  numm_Xe)=0.19

        qSAtMol( numm_H2)=1
        nAtMol(1,numm_H2)=num_H
        qAtMol(1,numm_H2)=2
        WWWMol(  numm_H2)=37.0e-6
        FFFMol(  numm_H2)=0.19

        qSAtMol( numm_N2)=1
        nAtMol(1,numm_N2)=num_N
        qAtMol(1,numm_N2)=2
        WWWMol(  numm_N2)=35.0e-6
        FFFMol(  numm_N2)=0.19

        qSAtMol( numm_O2)=1
        nAtMol(1,numm_O2)=num_O
        qAtMol(1,numm_O2)=2
        WWWMol(  numm_O2)=31.0e-6
        FFFMol(  numm_O2)=0.19

        qSAtMol( numm_NH3)=2
        nAtMol(1,numm_NH3)=num_N
        qAtMol(1,numm_NH3)=1
        nAtMol(2,numm_NH3)=num_H4
        qAtMol(2,numm_NH3)=3
        WWWMol(  numm_NH3)=26.6e-6
        FFFMol(  numm_NH3)=0.19

        qSAtMol( numm_N2O)=2
        nAtMol(1,numm_N2O)=num_N
        qAtMol(1,numm_N2O)=2
        nAtMol(2,numm_N2O)=num_O
        qAtMol(2,numm_N2O)=1
        WWWMol(  numm_N2O)=32.6e-6
        FFFMol(  numm_N2O)=0.19

        qSAtMol( numm_CO2)=2
        nAtMol(1,numm_CO2)=num_C1
        qAtMol(1,numm_CO2)=1
        nAtMol(2,numm_CO2)=num_O
        qAtMol(2,numm_CO2)=2
        WWWMol(  numm_CO2)=33.0e-6
        FFFMol(  numm_CO2)=0.19

        qSAtMol( numm_CF4)=2
        nAtMol(1,numm_CF4)=num_C2
        qAtMol(1,numm_CF4)=1
        nAtMol(2,numm_CF4)=num_F
        qAtMol(2,numm_CF4)=4
        WWWMol(  numm_CF4)=34.3e-6
        FFFMol(  numm_CF4)=0.19

        qSAtMol( numm_CH4)=2
        nAtMol(1,numm_CH4)=num_C3
        qAtMol(1,numm_CH4)=1
        nAtMol(2,numm_CH4)=num_H3
        qAtMol(2,numm_CH4)=4
        WWWMol(  numm_CH4)=27.3e-6
        FFFMol(  numm_CH4)=0.19

        qSAtMol( numm_C2H2)=2
        nAtMol(1,numm_C2H2)=num_C3
        qAtMol(1,numm_C2H2)=2
        nAtMol(2,numm_C2H2)=num_H3
        qAtMol(2,numm_C2H2)=2
        WWWMol(  numm_C2H2)=25.8e-6
        FFFMol(  numm_C2H2)=0.19

        qSAtMol( numm_C2H4)=2
        nAtMol(1,numm_C2H4)=num_C3
        qAtMol(1,numm_C2H4)=2
        nAtMol(2,numm_C2H4)=num_H3
        qAtMol(2,numm_C2H4)=4
        WWWMol(  numm_C2H4)=25.8e-6
        FFFMol(  numm_C2H4)=0.19

        qSAtMol( numm_C2H6)=2
        nAtMol(1,numm_C2H6)=num_C3
        qAtMol(1,numm_C2H6)=2
        nAtMol(2,numm_C2H6)=num_H3
        qAtMol(2,numm_C2H6)=6
        WWWMol(  numm_C2H6)=25.0e-6
        FFFMol(  numm_C2H6)=0.19

        qSAtMol( numm_C3H8)=2
        nAtMol(1,numm_C3H8)=num_C3
        qAtMol(1,numm_C3H8)=3
        nAtMol(2,numm_C3H8)=num_H3
        qAtMol(2,numm_C3H8)=8
        WWWMol(  numm_C3H8)=24.0e-6
        FFFMol(  numm_C3H8)=0.19

        qSAtMol( numm_iC4H10)=2
        nAtMol(1,numm_iC4H10)=num_C3
        qAtMol(1,numm_iC4H10)=4
        nAtMol(2,numm_iC4H10)=num_H3
        qAtMol(2,numm_iC4H10)=10
        WWWMol(  numm_iC4H10)=23.4e-6
        FFFMol(  numm_iC4H10)=0.19

*** Addition (RV 14/1/00).
        qSAtMol( numm_C5H12)=2
        nAtMol(1,numm_C5H12)=num_C3
        qAtMol(1,numm_C5H12)=5
        nAtMol(2,numm_C5H12)=num_H3
        qAtMol(2,numm_C5H12)=12
        WWWMol(  numm_C5H12)=23.2e-6    ! ICRU report 31
        FFFMol(  numm_C5H12)=0.19
*** End of addition.

        qSAtMol( numm_C)=1              ! for debug
        nAtMol(1,numm_C)=num_C
        qAtMol(1,numm_C)=1
        WWWMol(  numm_C)=31.0e-6
        FFFMol(  numm_C)=0.19

*** Additions (RV 4/9/98).
        qSAtMol( numm_DME)=3
        nAtMol(1,numm_DME)=num_C3
        qAtMol(1,numm_DME)=2
        nAtMol(2,numm_DME)=num_H
        qAtMol(2,numm_DME)=6
        nAtMol(3,numm_DME)=num_O
        qAtMol(3,numm_DME)=1
        WWWMol(  numm_DME)=45.4e-6
        FFFMol(  numm_DME)=0.19

        qSAtMol( numm_H2O)=2
        nAtMol(1,numm_H2O)=num_H
        qAtMol(1,numm_H2O)=2
        nAtMol(2,numm_H2O)=num_O
        qAtMol(2,numm_H2O)=1
        WWWMol(  numm_H2O)=29.6e-6    !  ICRU 31 (1/5/79)
        FFFMol(  numm_H2O)=0.19

*** Additions (RV 20/9/99).
        qSAtMol( numm_SF6)=2
        nAtMol(1,numm_SF6)=num_S
        qAtMol(1,numm_SF6)=1
        nAtMol(2,numm_SF6)=num_F
        qAtMol(2,numm_SF6)=6
        WWWMol(  numm_SF6)=35.75e-6   ! ICRU 31 (1/5/79)
        FFFMol(  numm_SF6)=0.19

        qSAtMol( numm_C2F4H2)=3
        nAtMol(1,numm_C2F4H2)=num_C3
        qAtMol(1,numm_C2F4H2)=2
        nAtMol(2,numm_C2F4H2)=num_F
        qAtMol(2,numm_C2F4H2)=4
        nAtMol(3,numm_C2F4H2)=num_H
        qAtMol(3,numm_C2F4H2)=2
        WWWMol(  numm_C2F4H2)=24.0e-6 ! Guess
        FFFMol(  numm_C2F4H2)=0.19

        qSAtMol( numm_C2F5H)=3
        nAtMol(1,numm_C2F5H)=num_C3
        qAtMol(1,numm_C2F5H)=2
        nAtMol(2,numm_C2F5H)=num_F
        qAtMol(2,numm_C2F5H)=5
        nAtMol(3,numm_C2F5H)=num_H
        qAtMol(3,numm_C2F5H)=1
        WWWMol(  numm_C2F5H)=24.0e-6 ! Guess
        FFFMol(  numm_C2F5H)=0.19

*** End of additions.

c       qSAtMol( numm_CClF3)=2
c       nAtMol(1,numm_CClF3)=num_C3
c       qAtMol(1,numm_CClF3)=1
c       nAtMol(1,numm_CClF3)=num_Cl
c       qAtMol(1,numm_CClF3)=1
c       nAtMol(2,numm_CClF3)=num_F
c       qAtMol(2,numm_CClF3)=3
c       WWWMol(  numm_CClF3)=24.0e-6
c       FFFMol(  numm_CClF3)=0.19


        do n=1,pqMol
          s=0.0
          do na=1,qSAtMol(n)
            s=s+Aat(nAtMol(na,n))*qAtMol(na,n)
          enddo
          weiMol(n)=s  
        enddo

        
        end


        subroutine Primolec

        implicit none

c       include 'GoEvent.inc'
+SEQ,GoEvent.
c       include 'molecules.inc'
+SEQ,molecule.
c       include 'molecdef.inc'
+SEQ,molecdef.
c       include 'LibAtMat.inc'
+SEQ,LibAtMat.
        
        integer n,na

        if(soo.eq.0)return

        write(oo,*)
        write(oo,*)' Primolec'
        write(oo,*)' pqMol=',pqMol
        do n=1,pqMol
        write(oo,*)' n=',n,' qSAtMol(n)=',qSAtMol(n)
        write(oo,*)' weiMol=',weiMol(n)
        write(oo,*)' WWWMol=',WWWMol(n)
        write(oo,*)' FFFMol=',FFFMol(n)
        do na=1,qSAtMol(n)
        write(oo,*)' nAtMol=',nAtMol(na,n),' qAtMol=',qAtMol(na,n)
        enddo
        enddo

        end     
        
+DECK,Inigas.
        subroutine Inigas( nmat, pqmole, pnmole, pwmole, pres, temp) 

c
c       initialization of the gas
c
        implicit none

c         include 'GoEvent.inc'
+SEQ,GoEvent.
c         include 'ener.inc'
+SEQ,ener.
c         include 'atoms.inc'
+SEQ,atoms.
c         include 'matters.inc'
+SEQ,matters.
c         include 'volume.inc'
+SEQ,volume.
c         include 'molecules.inc'
+SEQ,molecule.
c         include 'molecdef.inc'
+SEQ,molecdef.


        integer nmat            ! Number of material    
        integer pqmole            ! Quantity of different molecules
                                ! in the gas mixture.
        integer pnmole(pqMol)     ! Their numbers in molecdef.inc
                                ! accordingly with molecules.inc
        real pwmole(pqMol)       ! Their weights
                                ! (relative quantities of molecules).
        real pres               ! Pressure in Torr.
        real temp               ! Temperature in K.

        integer qmol, qold
        integer nmol(pqMol)
        real wmol(pqMol)

        integer n
        real s
        integer na,nm,i


        integer A(pqAt)
        real AW(pqAt)
        integer q
        real Ad(pqMol)
        real dens
        real gasdens
        real w
        real f

c       write(oo,*)' nmat=',nmat
c       write(oo,*)' qmol=',qmol
c       do n=1,qmol
c       write(oo,*)nmol(n),pwmol(n)
c       enddo
c       write(oo,*)' temp=',temp
c       write(oo,*)' pres=',pres


c               Copy everything         
        qmol=pqmole
        do n=1,qmol
          nmol(n)=pnmole(n)
          wmol(n)=pwmole(n)
        enddo
        do n=1,qmol     ! Check for negative weights
          if(wmol(n).lt.0)then
            write(oo,*)' error in Inigas: negative weight: wmol=',
     -           wmol(n)
            if(sret_err.eq.0) stop
            s_err=1
            return
          endif
        enddo
        s=0.0           ! Compute the sun of weights
        do n=1,qmol
          s=s+wmol(n)
        enddo
        if(s.eq.0)then  ! Check zero sum
          write(oo,*)' error in Inigas: all weights are zero'
          if(sret_err.eq.0) stop
          s_err=1
          return
        endif
        do n=1,qmol     ! Normalize the weights
          wmol(n)=wmol(n)/s
        enddo
*** Remove components with zero weight, rewritten (RV 9/6/99).
       qold=qmol
       qmol=0
       do n=1,qold
       if(wmol(n).gt.0)then
            qmol=qmol+1
            nmol(qmol)=nmol(n)
            wmol(qmol)=wmol(n)
       endif
       enddo
       if(qmol.le.0)then
            print *,' !!!!!! INIGAS WARNING : No non-zero weight'//
     -           ' gas components found; mixture rejected.'
            if(sret_err.eq.0) stop
            s_err=1
            return
       endif
*** End of modification.

        
c       fill material
        q=0
        do n=1,qmol     ! Take the next molecule
          nm=nmol(n)    ! Its number in molecdef.inc
c         write(oo,*)' nm=',nm,' qSAtMol(nm)=',qSAtMol(nm)
c               Check that this molecule exists in list.
          if(nm.le.0.or.nm.gt.pqMol)then
            write(oo,*)' error in Inigas: the wrong molecule number'
            if(sret_err.eq.0) stop
            s_err=1
            return
          endif
          do na=1,qSAtMol(nm)   ! Loop over atoms of current molecule
            do i=1,q    ! Loop over enrolled atoms
                        ! Check if the atom is already enrolled
              if(A(i).eq.nAtMol(na,nm))then
                goto 10
              endif
            enddo
            q=q+1       ! To enroll it
            A(q)=nAtMol(na,nm)
            AW(q)=qAtMol(na,nm) * wmol(n)       ! The weight of the atom
c           write(oo,*)' q=',q,' A(q)=',A(q),' AW(q)=',AW(q)
            goto 20
10          continue
            AW(i)=AW(i) + qAtMol(na,nm) * wmol(n)
c           write(oo,*)' q=',q,' A(q)=',A(q),' AW(q)=',AW(q)
20          continue
          enddo
        enddo   

        do n=1,qmol
          nm=nmol(n)
          Ad(n)=weiMol(nm)
        enddo

c       pressure, temperature

        Cur_Pressure=pres
        Cur_Temper=temp

c       density of the ideal gas        
        dens = gasdens(Ad,  wmol, qmol)
        if(s_err.eq.1) return

        w=0.0
        f=0.0
        do n=1,qmol
          nm=nmol(n)
          w = w + WWWMol(nm) * wmol(n)
          f = f + FFFMol(nm) * wmol(n)
        enddo

        call IniMatter(nmat,A,AW,q,dens,w,f)
        if(s_err.eq.1) return

*** Added argument to PriMatter (RV 13/4/99).
c       call PriMatter(0)

        
        end
        
                
+DECK,IniAtom.
 

        subroutine IniAtom(num,z,a)
c
c       The special cases incorporated by fortran code:
c       Ar and O : with including exp. data 
c       and change of part of 3p and 2p shell corespondently.
c       C for CO2 (C1) : 2p sift from 8.9 to 13.79
c       C for CF4 (C2) : 2p sift from 8.9 to 16.23
c       C for CH4 : 2p sift
c       c for C2H10 : 2p sift
c
        implicit none

        save

c         include 'GoEvent.inc'
+SEQ,GoEvent.
c       include 'ener.inc'
+SEQ,ener.
c       include 'shellfi.inc'
+SEQ,shellfi.
c       include 'atoms.inc'
+SEQ,atoms.
c       include 'cconst.inc'
+SEQ,cconst.
c       include 'shl.inc'
+SEQ,shl.
c       include 'tpasc.inc'
+SEQ,tpasc.
c       include 'LibAtMat.inc'
+SEQ,LibAtMat.

        integer num     !number of atom in the bank
        integer z       !charge
        real a          !atomic weight

        real w,sw,s

        integer qbener
        parameter (qbener=138)
        real aenerc(qbener),epa(qbener)
        integer qbener1
        parameter (qbener1=5)
        real aenerc1(qbener1),epa1(qbener1)
        real e
c       integer num_at_mol
c       parameter (num_at_mol=2)
        real interp_linep_arr

c       include 'shellescar.inc'

        data aenerc(1) / 15.83 /
        data epa(1) / 29.2 /
        data aenerc(2) / 15.89 /
        data epa(2) / 29.5 /
        data aenerc(3) / 16.1 /
        data epa(3) / 30.3 /
        data aenerc(4) / 16.31 /
        data epa(4) / 31.1 /
        data aenerc(5) / 16.53 /
        data epa(5) / 31.8 /
        data aenerc(6) / 16.75 /
        data epa(6) / 32.5 /
        data aenerc(7) / 16.98 /
        data epa(7) / 33.1 /
        data aenerc(8) / 17.22 /
        data epa(8) / 33.7 /
        data aenerc(9) / 17.46 /
        data epa(9) / 34.2 /
        data aenerc(10) / 17.71 /
        data epa(10) / 34.7 /
        data aenerc(11) / 17.97 /
        data epa(11) / 35.1 /
        data aenerc(12) / 18.23 /
        data epa(12) / 35.5 /
        data aenerc(13) / 18.5 /
        data epa(13) / 35.8 /
        data aenerc(14) / 18.78 /
        data epa(14) / 36.1 /
        data aenerc(15) / 19.07 /
        data epa(15) / 36.3 /
        data aenerc(16) / 19.37 /
        data epa(16) / 36.5 /
        data aenerc(17) / 19.68 /
        data epa(17) / 36.3 /
        data aenerc(18) / 20 /
        data epa(18) / 36.7 /
        data aenerc(19) / 20.32 /
        data epa(19) / 36.8 /
        data aenerc(20) / 20.66 /
        data epa(20) / 36.7 /
        data aenerc(21) / 21.01 /
        data epa(21) / 36.7 /
        data aenerc(22) / 21.38 /
        data epa(22) / 36.5 /
        data aenerc(23) / 21.75 /
        data epa(23) / 36.3 /
        data aenerc(24) / 22.14 /
        data epa(24) / 36.1 /
        data aenerc(25) / 22.54 /
        data epa(25) / 35.7 /
        data aenerc(26) / 22.96 /
        data epa(26) / 35.4 /
        data aenerc(27) / 23.39 /
        data epa(27) / 34.9 /
        data aenerc(28) / 23.84 /
        data epa(28) / 34.4 /
        data aenerc(29) / 24.31 /
        data epa(29) / 33.8 /
        data aenerc(30) / 24.8 /
        data epa(30) / 33.1 /
        data aenerc(31) / 25.3 /
        data epa(31) / 32.3 /
        data aenerc(32) / 25.83 /
        data epa(32) / 31.4 /
        data aenerc(33) / 26.38 /
        data epa(33) / 30.5 /
        data aenerc(34) / 26.95 /
        data epa(34) / 29.5 /
        data aenerc(35) / 27.55 /
        data epa(35) / 28.3 /
        data aenerc(36) / 28.18 /
        data epa(36) / 27.1 /
        data aenerc(37) / 28.83 /
        data epa(37) / 25.7 /
        data aenerc(38) / 29.52 /
        data epa(38) / 24.3 /
        data aenerc(39) / 30.24 /
        data epa(39) / 22.7 /
        data aenerc(40) / 30.99 /
        data epa(40) / 21 /
        data aenerc(41) / 31.79 /
        data epa(41) / 19.1 /
        data aenerc(42) / 32.63 /
        data epa(42) / 17.1 /
        data aenerc(43) / 33.51 /
        data epa(43) / 15 /
        data aenerc(44) / 34.44 /
        data epa(44) / 12.8 /
        data aenerc(45) / 35.42 /
        data epa(45) / 10.3 /
        data aenerc(46) / 36.46 /
        data epa(46) / 7.77 /
        data aenerc(47) / 37.57 /
        data epa(47) / 6.1 /
        data aenerc(48) / 38.74 /
        data epa(48) / 4.62 /
        data aenerc(49) / 39.99 /
        data epa(49) / 3.41 /
        data aenerc(50) / 41.33 /
        data epa(50) / 2.47 /
        data aenerc(51) / 42.75 /
        data epa(51) / 1.77 /
        data aenerc(52) / 44.28 /
        data epa(52) / 1.3 /
        data aenerc(53) / 45.92 /
        data epa(53) / 1.03 /
        data aenerc(54) / 47.68 /
        data epa(54) / 0.914 /
        data aenerc(55) / 49.59 /
        data epa(55) / 0.916 /
        data aenerc(56) / 51.66 /
        data epa(56) / 1 /
        data aenerc(57) / 53.9 /
        data epa(57) / 1.13 /
        data aenerc(58) / 56.35 /
        data epa(58) / 1.28 /
        data aenerc(59) / 59.04 /
        data epa(59) / 1.36 /
        data aenerc(60) / 61.99 /
        data epa(60) / 1.42 /
        data aenerc(61) / 65.25 /
        data epa(61) / 1.45 /
        data aenerc(62) / 68.88 /
        data epa(62) / 1.48 /
        data aenerc(63) / 72.93 /
        data epa(63) / 1.48 /
        data aenerc(64) / 77.49 /
        data epa(64) / 1.47 /
        data aenerc(65) / 82.65 /
        data epa(65) / 1.45 /
        data aenerc(66) / 88.56 /
        data epa(66) / 1.41 /
        data aenerc(67) / 95.37 /
        data epa(67) / 1.36 /
        data aenerc(68) / 103.3 /
        data epa(68) / 1.29 /
        data aenerc(69) / 112.7 /
        data epa(69) / 1.2 /
        data aenerc(70) / 124 /
        data epa(70) / 1.1 /
        data aenerc(71) / 130.5 /
        data epa(71) / 1.05 /
        data aenerc(72) / 137.8 /
        data epa(72) / 0.987 /
        data aenerc(73) / 145.9 /
        data epa(73) / 0.923 /
        data aenerc(74) / 155 /
        data epa(74) / 0.856 /
        data aenerc(75) / 165.3 /
        data epa(75) / 0.785 /
        data aenerc(76) / 177.1 /
        data epa(76) / 0.709 /
        data aenerc(77) / 190.7 /
        data epa(77) / 0.63 /
        data aenerc(78) / 206.6 /
        data epa(78) / 0.547 /
        data aenerc(79) / 225.4 /
        data epa(79) / 0.461 /
        data aenerc(80) / 245 /
        data epa(80) / 0.381 /
        data aenerc(81) / 248 /
        data epa(81) / 4.66 /
        data aenerc(82) / 258.3 /
        data epa(82) / 4.23 /
        data aenerc(83) / 269.5 /
        data epa(83) / 3.83 /
        data aenerc(84) / 281.8 /
        data epa(84) / 3.45 /
        data aenerc(85) / 295.2 /
        data epa(85) / 3.1 /
        data aenerc(86) / 310 /
        data epa(86) / 2.76 /
        data aenerc(87) / 326.3 /
        data epa(87) / 2.45 /
        data aenerc(88) / 344.4 /
        data epa(88) / 2.16 /
        data aenerc(89) / 364.7 /
        data epa(89) / 1.89 /
        data aenerc(90) / 387.4 /
        data epa(90) / 1.64 /
        data aenerc(91) / 413.3 /
        data epa(91) / 1.41 /
        data aenerc(92) / 442.8 /
        data epa(92) / 1.2 /
        data aenerc(93) / 476.9 /
        data epa(93) / 1.01 /
        data aenerc(94) / 516.6 /
        data epa(94) / 0.836 /
        data aenerc(95) / 563.6 /
        data epa(95) / 0.682 /
        data aenerc(96) / 619.9 /
        data epa(96) / 0.546 /
        data aenerc(97) / 652.5 /
        data epa(97) / 0.484 /
        data aenerc(98) / 688.8 /
        data epa(98) / 0.426 /
        data aenerc(99) / 729.3 /
        data epa(99) / 0.373 /
        data aenerc(100) / 774.9 /
        data epa(100) / 0.324 /
        data aenerc(101) / 826.5 /
        data epa(101) / 0.278 /
        data aenerc(102) / 885.6 /
        data epa(102) / 0.237 /
        data aenerc(103) / 953.7 /
        data epa(103) / 0.199 /
        data aenerc(104) / 1044 /
        data epa(104) / 0.165 /
        data aenerc(105) / 1127 /
        data epa(105) / 0.135 /
        data aenerc(106) / 1240 /
        data epa(106) / 0.108 /
        data aenerc(107) / 1305 /
        data epa(107) / 0.0955 /
        data aenerc(108) / 1378 /
        data epa(108) / 0.0842 /
        data aenerc(109) / 1459 /
        data epa(109) / 0.0736 /
        data aenerc(110) / 1550 /
        data epa(110) / 0.0639 /
        data aenerc(111) / 1653 /
        data epa(111) / 0.0549 /
        data aenerc(112) / 1771 /
        data epa(112) / 0.0467 /
        data aenerc(113) / 1907 /
        data epa(113) / 0.0393 /
        data aenerc(114) / 2066 /
        data epa(114) / 0.0326 /
        data aenerc(115) / 2254 /
        data epa(115) / 0.0266 /
        data aenerc(116) / 2480 /
        data epa(116) / 0.0213 /
        data aenerc(117) / 2755 /
        data epa(117) / 0.0166 /
        data aenerc(118) / 3100 /
        data epa(118) / 0.0126 /
        data aenerc(119) / 3204 /
        data epa(119) / 0.0117 /
        data aenerc(120) / 3263 /
        data epa(120) / 0.0959 /
        data aenerc(121) / 3444 /
        data epa(121) / 0.0827 /
        data aenerc(122) / 3646 /
        data epa(122) / 0.0706 /
        data aenerc(123) / 3874 /
        data epa(123) / 0.0598 /
        data aenerc(124) / 4133 /
        data epa(124) / 0.0501 /
        data aenerc(125) / 4428 /
        data epa(125) / 0.0414 /
        data aenerc(126) / 4768 /
        data epa(126) / 0.0338 /
        data aenerc(127) / 5166 /
        data epa(127) / 0.0271 /
        data aenerc(128) / 5635 /
        data epa(128) / 0.0213 /
        data aenerc(129) / 6199 /
        data epa(129) / 0.0164 /
        data aenerc(130) / 6888 /
        data epa(130) / 0.0123 /
        data aenerc(131) / 7749 /
        data epa(131) / 0.00889 /
        data aenerc(132) / 8856 /
        data epa(132) / 0.00616 /
        data aenerc(133) / 10330 /
        data epa(133) / 0.00403 /
        data aenerc(134) / 12400 /
        data epa(134) / 0.00244 /
        data aenerc(135) / 15500 /
        data epa(135) / 0.00132 /
        data aenerc(136) / 20660 /
        data epa(136) / 0.000599 /
        data aenerc(137) / 31000 /
        data epa(137) / 0.000196 /
        data aenerc(138) / 61990 /
        data epa(138) / 2.9e-05 /


c       include 'shellesco.inc'

        data aenerc1(1) / 14.2 /
        data epa1(1) / 2.51 /
        data aenerc1(2) / 16.2 /
        data epa1(2) / 3.98 /
        data aenerc1(3) / 17.4 /
        data epa1(3) / 12.59 /
        data aenerc1(4) / 25.1 /
        data epa1(4) / 10.72 /
        data aenerc1(5) / 31.6 /
        data epa1(5) / 10 /

        integer pqnpasc
        parameter(pqnpasc=20)
        integer nnpasc
        integer pqnene
        parameter(pqnene=100)
        integer nnene
        real Tresh_npasc
        real nene,npasc

        common / comasc /
     +          nnpasc,Tresh_npasc(pqnpasc),nnene(pqnpasc),
     +          nene(pqnene,pqnpasc),npasc(pqnene,pqnpasc)
        save / comasc /
        

        integer i,iener,n,ne,j,ns,k,nn
c       integer ios
        real glin_integ_ar, step_integ_ar, sigma_nl
c       real lin_integ_ar
c       real interp_line_arr
c       real alog,sqrt

        if(num.le.0.or.num.gt.pQAt)then
                write(oo,*)' Error in IniAtom: Wrong Atom number ',num
                stop
        endif
        if(Zat(num).ne.0)then
                write(oo,*)' Error in IniAtom: Atom number ',num,
     +          'is initialized already'
                stop
        endif
        do n=1,QseqAt                   ! fill sequensed number
          if(Zat(n).gt.z)then
            do nn=QseqAt,n,-1
              nseqAt(nn+1)=nseqAt(nn)
            enddo
            nseqAt(n)=num
            QseqAt=QseqAt+1
            go to 4
          endif
        enddo
        QseqAt=QseqAt+1
        nseqAt(QseqAt)=num
4       continue
        Zat(num)=z
        Aat(num)=a
        cphoAt(num)=2.0*PI2*Zat(num)/(FSCON*ELMAS)              
        RLenAt(num)=716.4*Aat(num)/
     +          (Zat(num)*(Zat(num)+1)*alog(287/sqrt(float(Zat(num)))))
        RuthAt(num)=4.0*PI*Zat(num)*Zat(num)*ELRAD*ELRAD*ELMAS*ELMAS
        zato=zat(num)
        if(KeyTeor.eq.0)then

            if(Zat(num).eq.1)then       ! H

        QShellAt(num)=1
        ThresholdAt(1,num)=16.4e-6      ! ionization potential of H2
c               accordingly with At.Data.Nucl.Data.Tables 24,323-371(1979)
        if(num.eq.num_H3)then   ! for CH4
c               ThresholdAt(1,num)=15.2e-06
                ThresholdAt(1,num)=12.0e-06
        endif
        if(num.eq.num_H4)then   ! for NH4
                ThresholdAt(1,num)=10.0e-06
        endif
        do ne=1,qener
            if(ener(ne+1).gt.ThresholdAt(1,num))then
c               PhotAt(ne,1,num)=1.51*0.0535*
                PhotAt(ne,1,num)=0.0535*
     +          ((100.0e-6/
     +          (enerc(ne) + 16.4e-6 - ThresholdAt(1,num)))**3.228)
                if(ener(ne).lt.ThresholdAt(1,num))then
                    PhotAt(ne,1,num)=PhotAt(ne,1,num)*
     +                  (ThresholdAt(1,num)-ener(ne))/
     +                  (ener(ne+1)-ener(ne))
                endif   
            endif
        enddo

c       Now the cross section is generated in Mega-barns.
c       Calc. coef for going from 10**-18 sm**2 to Mev-2
        s=1.e-18 * 5.07e10 * 5.07e10

        do ne=1,qener
        do ns=1,QShellAt(num)
                PhotAt(ne,ns,num)=PhotAt(ne,ns,num)*s
        enddo
        enddo

        do ns=1,QShellAt(num)
        WeightShAt(ns,num)=step_integ_ar(ener,PhotAt(1,ns,num),qener,
     +          ener(1),ener(qener+1))/cphoAt(num)
        enddo


        go to 100

            endif

            if(Zat(num).eq.6)then

        call henke

        QShellAt(num)=qash
        do ns=1,QShellAt(num)
            ThresholdAt(ns,num)=athreshold(ns)
            if(ns.eq.QShellAt(num))then
                if(num.eq.num_C1)then
                    ThresholdAt(ns,num)=13.79e-6        ! CO2
                endif
                if(num.eq.num_C2)then
                    ThresholdAt(ns,num)=16.23e-6        ! CF4
                endif
                if(num.eq.num_C3)then
c                   ThresholdAt(ns,num)=15.2e-6         ! CH4
                    ThresholdAt(ns,num)=12.0e-6         ! CH4 and so on
                endif
            endif       
            do ne=1,qener
                PhotAt(ne,ns,num)=
     +          interp_linep_arr(aener(1,ns),aphot(1,ns),qaener(ns),
     +          athreshold(ns),
     +          (enerc(ne) - (ThresholdAt(ns,num) - athreshold(ns))) )
            enddo
        enddo   

c       Now the cross section is generated in Mega-barns.
c       Calc. coef for going from 10**-18 sm**2 to Mev-2
        s=1.e-18 * 5.07e10 * 5.07e10

        do ne=1,qener
        do ns=1,QShellAt(num)
                PhotAt(ne,ns,num)=PhotAt(ne,ns,num)*s
        enddo
        enddo

        do ns=1,QShellAt(num)
        WeightShAt(ns,num)=step_integ_ar(ener,PhotAt(1,ns,num),qener,
     +          ener(1),ener(qener+1))/cphoAt(num)
        enddo


        go to 100

            endif

                
            qshPas(num)=0
            call readPas(num)
            if(qshPas(num).gt.0)then


        QShellAt(num)=qshPas(num)
        do ns=1,qshPas(num)
                ThresholdAt(ns,num)=EthPas(ns,num)*1.e-6
                if(Zat(num).eq.6.and.ns.eq.3.and.
     +          num.eq.num_C1)then
c     +         num_at_mol(num).eq.1)then
                ThresholdAt(ns,num)=13.79*1.e-6         ! for CO2
                endif           
                if(Zat(num).eq.6.and.ns.eq.3.and.
     +          num.eq.num_C2)then
c     +         num_at_mol(num).eq.2)then
                ThresholdAt(ns,num)=16.23*1.e-6         ! for CF4
                endif
                if(Zat(num).eq.6.and.ns.eq.3.and.
     +          num.eq.num_C3)then
                ThresholdAt(ns,num)=15.2*1.e-6          ! for CH4
                endif
                if(ThresholdAt(ns,num).lt.ener(1))then
                        write(oo,*)' error in IniAtom:'
                        write(oo,*)' too high ener(1)=',ener(1)
                        write(oo,*)' ThresholdAt(ns,num)=',
     +                          ThresholdAt(ns,num)
                        stop
                endif
                        
        enddo


        do ne=1,qener
        do i=1,qshPas(num)
        s=0.0
c       do i=5,5
        if(Zat(num).eq.18.and.
     +  i.eq.5.and.
     +  enerc(ne)*1.e6.gt.EthPas(i,num).and.enerc(ne)*1.e6.le.40)then
        j=qbener
        do k=2,qbener
                if(aenerc(k).ge.enerc(ne)*1.e6)then
                        j=k-1
                        go to 5
                endif
        enddo
5       s=s+ epa(j)+(enerc(ne)*1.e6-aenerc(j))*
     + (epa(j+1)-epa(j))/(aenerc(j+1)-aenerc(j))
 
        elseif(Zat(num).eq.8.and.
     +  i.eq.3.and.
     +  enerc(ne)*1.e6.gt.EthPas(i,num).and.enerc(ne)*1.e6.le.25.1)then
        j=qbener1
        do k=2,qbener1
                if(aenerc1(k).ge.enerc(ne)*1.e6)then
                        j=k-1
                        go to 6
                endif
        enddo
6       s=s+ epa1(j)+(enerc(ne)*1.e6-aenerc1(j))*
     + (epa1(j+1)-epa1(j))/(aenerc1(j+1)-aenerc1(j))
 
        else
        if(Zat(num).eq.6.and.i.eq.3)then
c       if(num.eq.num_C1)then
cc      if(num_at_mol(num).eq.1)then
c               e=enerc(ne)*1.e6-(13.79-.8987E+01)
c       elseif(num.eq.num_C2)then
cc      elseif(num_at_mol(num).eq.2)then
c               e=enerc(ne)*1.e6-(16.23-.8987E+01)
c       else
c               e=enerc(ne)*1.e6
c       endif
        e=enerc(ne) - ThresholdAt(i,num) + .8987E+01*1.0e-6
        e=e*1.e6
        else
                e=enerc(ne)*1.e6
        endif

        s=s + sigma_nl
     +  (e , E0Pas(i,num),EthPas(i,num),
     +          ywPas(i,num),lPas(i,num),
     +          yaPas(i,num),PPas(i,num),sigma0Pas(i,num))


        endif

        PhotAt(ne,i,num)=s

        enddo   
        enddo   

c       Now the cross section is generated in Mega-barns.
c       Calc. coef for going from 10**-18 sm**2 to Mev-2
        s=1.e-18 * 5.07e10 * 5.07e10

        do ne=1,qener
        do i=1,qshPas(num)
                PhotAt(ne,i,num)=PhotAt(ne,i,num)*s
        enddo
        enddo

        do ns=1,qshPas(num)
        WeightShAt(ns,num)=step_integ_ar(ener,PhotAt(1,ns,num),qener,
     +          ener(1),ener(qener+1))/cphoAt(num)
        enddo

        
        go to 100

                endif     ! continuing of old algorithm
                    
        
                call shellfi
c               call prishellfi       
        endif
        if(qash.eq.0.or.KeyTeor.ne.0)then
                call shteor(num)
                if(qash.eq.0)then
                        write(oo,*)' Error in IniAtom:',
     +          'can not find atom with z=',z
                        stop
                endif
                call GenTheorPhot
c               call prishellfi       
        endif

        call shellfico
c               call prishellfi       
        
        QShellAt(num)=qash
        do i=1,qatm
                if(ZAt(num).eq.charge(i))then
                        if(QShellAt(num).ne.qshl(i))then
        write(oo,*)' Worning of IniAtom:'
        write(oo,*)' Quantity of shell is different for shl'
        write(oo,*)' In may lead to error'
                        endif
                        goto 10 
                endif
        enddo
10      continue
        do i=1,QShellAt(num)
            ThresholdAt(i,num)=athreshold(i)
                if(ThresholdAt(i,num).lt.ener(1))then
                        write(oo,*)' error in IniAtom:'
                        write(oo,*)' too high ener(1)=',ener(1)
                        write(oo,*)' ThresholdAt(ns,num)=',
     +                          ThresholdAt(i,num)
                        stop
                endif
            WeightShAt(i,num)=aweight(i)

            do iener=1,qener

                PhotAt(iener,i,num)=
     +          glin_integ_ar(aener(1,i),aphot(1,i),qaener(i),
     +          ener(iener),ener(iener+1),ThresholdAt(i,num))/
     +                          (ener(iener+1)-ener(iener))

            enddo

        enddo

*** Added argument to PriAtoms (RV 13/4/99)
c       call PriAtoms(0)
*** End of modification.
        
        w=0.0
        do i=1,QShellAt(num)
                w=w+WeightShAt(i,num)                   
        enddo
        do i=1,QShellAt(num)
                WeightShAt(i,num)=WeightShAt(i,num)/w                   
        enddo
        sw=0.0
        do i=1,QShellAt(num)
            w=step_integ_ar(ener,PhotAt(1,i,num),qener,
     +          ener(1),ener(qener+1))
            PWeightShAt(i,num)=w
            sw=sw+w
            if(w.lt.0.0)then
                do n=1,qener
                    PhotAt(n,i,num)=0.0
                enddo
            else
                do n=1,qener
                    PhotAt(n,i,num)=PhotAt(n,i,num)*cphoAt(num)*
     +                  WeightShAt(i,num)/w
                enddo
*******         write(oo,*)' koef=',cphoAt(num)*WeightShAt(i,num)/w
            endif
        enddo
        do i=1,QShellAt(num)
                PWeightShAt(i,num)=PWeightShAt(i,num)/sw
        enddo
                        
100     continue

        do i=1,qatm
                if(ZAt(num).eq.charge(i))then
                        if(QShellAt(num).ne.qshl(i))then
        write(oo,*)' Worning of IniAtom:'
        write(oo,*)' Quantity of shell is different for shl'
        write(oo,*)' In may lead to error'
                        endif
                        goto 20 
                endif
        enddo
20      continue

        s=0.0
        do ns=1,QShellAt(num)
c       write(oo,*)' start integration'
                ISPhotBAt(ns,num)=step_integ_ar
     +          (ener,PhotAt(1,ns,num),qener,ener(1),ener(qener+1))
                s=s+ISPhotBAt(ns,num)
        enddo
        IAPhotBAt(num)=s
        MinThresholdAt(num)=ThresholdAt(QShellAt(num),num)
        NshMinThresholdAt(num)=QShellAt(num)
        Min_ind_E_At(num)=0
        Max_ind_E_At(num)=0

        if(IAPhotBAt(num).gt.cphoAt(num))then
c               reduce all shells
                s=cphoAt(num)/IAPhotBAt(num)
                do ne=1,qener
                do ns=1,QShellAt(num)
                        PhotAt(ne,ns,num)=PhotAt(ne,ns,num)*s
                enddo
                enddo
c               copy absorbtion to ionization
                do ne=1,qener
                do ns=1,QShellAt(num)
                        PhotIonAt(ne,ns,num)=PhotAt(ne,ns,num)
                enddo
                enddo
c               reduce weights
                do ns=1,QShellAt(num)
                        WeightShAt(ns,num)=WeightShAt(ns,num)*s 
                enddo           

        elseif(IAPhotBAt(num).lt.cphoAt(num))then
c               copy absorbtion to ionzation    
                do ne=1,qener
                do ns=1,QShellAt(num)
                        PhotIonAt(ne,ns,num)=PhotAt(ne,ns,num)
                enddo
                enddo
c               add excitation part to absorption
                

                j=qener
                do ne=3,qener
                    if(ener(ne).gt.MinThresholdAt(num))then
                        j=ne-1          ! ener(j) in the last point
                                ! So the last interval has number j-1
                        go to 25
                    endif
                enddo
25              continue
                if(j.le.2)then
                        write(oo,*)' Error in IniAtom:'
                        write(oo,*)' cannot insert excitation'
                        write(oo,*)' too large ener(1)=',ener(1)
                        write(oo,*)' MinThresholdAt(num)=',
     +                                  MinThresholdAt(num)
                        stop
                endif
                nn=1
                do ne=j-1,1,-1
                    if(enerc(ne).lt. 0.7*MinThresholdAt(num))then
                        nn=ne
                        go to 30
                    endif
                enddo
30              continue
                s=(-IAPhotBAt(num)+cphoAt(num))/
     +                  (ener(j) - ener(nn))

                do ne=nn,j-1
                        PhotAt(ne,NshMinThresholdAt(num),num)=
     +                  PhotAt(ne,NshMinThresholdAt(num),num)+s
                enddo
                Min_ind_E_At(num)=nn
                Max_ind_E_At(num)=j-1

                
        else
c               copy absorbtion to ionzation    
                do ne=1,qener
                do ns=1,QShellAt(num)
                        PhotIonAt(ne,ns,num)=PhotAt(ne,ns,num)
                enddo
                enddo
c               add excitation part to absorption
        
        endif

        s=0.0
        do ns=1,QShellAt(num)
                ISPhotAt(ns,num)=step_integ_ar
     +          (ener,PhotAt(1,ns,num),qener,ener(1),ener(qener+1))
                s=s+ISPhotAt(ns,num)
        enddo
        IAPhotAt(num)=s

        s=0.0
        do ns=1,QShellAt(num)
                ISPhotIonAt(ns,num)=step_integ_ar
     +          (ener,PhotIonAt(1,ns,num),qener,
     +          ener(1),ener(qener+1))
                s=s+ISPhotIonAt(ns,num)
        enddo
        IAPhotIonAt(num)=s


        end
        

        subroutine GenTheorPhot

        implicit none

c       include 'ener.inc'
+SEQ,ener.
c       include 'shellfi.inc'
+SEQ,shellfi.
        
        integer nsh,nen

        do nsh=1,qash

            qaener(nsh)=qener
            do nen=1,qener
                aener(nen,nsh)=enerc(nen)
                if(athreshold(nsh).lt.ener(nen+1))then
                    aphot(nen,nsh)=1.0/(enerc(nen)**2.5)
                    if(athreshold(nsh).gt.ener(nen))then
                        aphot(nen,nsh)=aphot(nen,nsh)*
     +                  (ener(nen+1)-athreshold(nsh))/
     +                  (ener(nen+1)-ener(nen))
                    endif
                else
                    aphot(nen,nsh)=0.0
                endif
            enddo
        enddo

        end


        subroutine shellfico

        implicit none

c       include 'ener.inc'
+SEQ,ener.
c       include 'shellfi.inc'
+SEQ,shellfi.

        integer is,iaen,iaens,ien,iens
        real np
        np=2.5
c       the prolongation is needed only for first shell

        do is=1,qash

        
c       is=1

                do iaen=qaener(is),1,-1
                        if(aphot(iaen,is).gt.0)then
                                iaens=iaen
                                go to 10
                        endif
                enddo
10              continue

                if(is.ne.1)then
                        if(aener(iaens,is).eq.aener(1,is-1))then
                                go to 30
                        endif
                endif

c               same strange empty place in file in some atoms
                        
                if(aener(iaens,is).lt.enerc(qener))then
                        do ien=1,qener
                                if(enerc(ien).gt.aener(iaens,is))then
                                        iens=ien
                                        goto 20
                                endif
                        enddo
20                      continue
                        iaen=iaens
                        do ien=iens,qener
                                iaen=iaen+1
                                aener(iaen,is)=enerc(ien)
                                aphot(iaen,is)=aphot(iaens,is)*
     +                          (aener(iaens,is)/enerc(ien))**np
                        enddo
                        qaener(is)=iaen
                endif

30      continue        

        enddo

c       if(zato.eq.18)then
c       call prishellfi
c       endif   
        
        end


        subroutine priatoms(n)

        implicit none

        integer n               ! n = 0,1 short output
                                ! n >= 2 long output
c         include 'GoEvent.inc'
+SEQ,GoEvent.
c       include 'ener.inc'
+SEQ,ener.
c       include 'atoms.inc'
+SEQ,atoms.

        integer nat, nsh, nen, nat1

        if(soo.eq.0)return

        write(oo,*)
        write(oo,*)' priatoms: Atomic data'
        write(oo,*)' KeyTeor=',KeyTeor
        do nat=1,pQAt
            if(Zat(nat).gt.0)then
        write(oo,*)
        write(oo,*)' nat=',nat,' Zat=',Zat(nat),' Aat=',Aat(nat),
     +  ' QShellAt=',QShellAt(nat)
c       write(oo,*)' num_at_mol=',num_at_mol(nat)
        write(oo,*)' cphoAt=',cphoAt(nat)
        write(oo,*)' RLenAt=',RLenAt(nat)
        write(oo,*)' RuthAt=',RuthAt(nat)
                do nsh=1,QShellAt(nat)
        write(oo,*)' ThresholdAt=',ThresholdAt(nsh,nat),
     +  ' WeightShAt=',WeightShAt(nsh,nat)
        write(oo,*)' PWeightShAt=',PWeightShAt(nsh,nat)
                enddo
        write(oo,*)' IAPhotBAt     IAPhotAt   IAPhotIonAt '
        write(oo,*)IAPhotBAt(nat), IAPhotAt(nat), IAPhotIonAt(nat)
                do nsh=1,QShellAt(nat)
        write(oo,*)nsh,
     +  ISPhotBAt(nsh,nat), ISPhotAt(nsh,nat), ISPhotIonAt(nsh,nat)
                enddo
        write(oo,*)' MinThresholdAt=',MinThresholdAt(nat)
        write(oo,*)' NshMinThresholdAt=',NshMinThresholdAt(nat)
        write(oo,*)' Min_ind_E_At=',Min_ind_E_At(nat),
     +          ' Max_ind_E_At=',Max_ind_E_At(nat)
                if(n.ge.2)then
                write(oo,*)' energy and photoabs cross sections'
c               do nen=1,qener
c       write(oo,'(10e12.3)')
c     + enerc(nen),(PhotAt(nen,nsh,nat),nsh=1,QShellAt(nat))
c               enddo
                do nsh=1,QShellAt(nat)
        write(oo,*)' shell number=',nsh
        write(oo,*)' enerc,   PhotAt,   PhotIonAt'
                do nen=1,qener
        write(oo,'(3e10.3)')
     +  enerc(nen),PhotAt(nen,nsh,nat),PhotIonAt(nen,nsh,nat)
                enddo   ! nen=1,qener
                enddo   ! nsh=1,QShellAt(nat)
                endif   ! if(n.ge.2)
            endif       ! if(Zat(nat).gt.0)
        enddo           ! nat=1,pQAt

        write(oo,*)' Sequenced numbers:'
        write(oo,*)'          nat    Zat(nat)   nseqAt(nat)'
        do nat=1,QseqAt
        write(oo,*) nat, Zat(nat), nseqAt(nat)
        enddo
        write(oo,*)
     +          '         nat1        nat    Zat(nat)'
        do nat1=1,QseqAt
        nat=nseqAt(nat1)
        write(oo,*) nat1, nat, Zat(nat)
        enddo

        end


+DECK,henke.
        subroutine henke
c
c       include Henke's data

        implicit none

c         include 'GoEvent.inc'
+SEQ,GoEvent.
c       include 'shellfi.inc'
+SEQ,shellfi.

        integer nae,ns


        qash=0          !sign of absence


c       The next code is generated by a computer program
c       on the basis of data file 'henke.dat'.


        if(zato.eq.6)then
        
c       include 'henke6.inc'
+SEQ,henke6.

        endif


c       end of computer code


        do ns=1,qash
                athreshold(ns)=athreshold(ns)*1.e-6
                do nae=1,qaener(ns)     
                        aener(nae,ns)=aener(nae,ns)*1.e-6
                enddo
        enddo


        if(soo.eq.1)then
        if(qash.eq.0)then
        write(oo,*)' Worning of henke: atom z=',zato,' is not found.'
        write(oo,*)
     +  '  The data will be seached by readPAS, accuracy will be lower.'

        endif
        endif

c       call prishellfi

        end

+DECK,tpasc.
        
        subroutine readPas(na)

        implicit none

        integer na

c         include 'GoEvent.inc'
+SEQ,GoEvent.
c         include 'ener.inc'
+SEQ,ener.
c         include 'atoms.inc'
+SEQ,atoms.
c       include 'tpasc.inc'
+SEQ,tpasc.

        integer Za,npas

        integer i

c       include 'shelltsc.inc'
        integer pq
        parameter (pq=10)
        integer z(pq)
        integer n(pq)
        integer pmaxn
        parameter (pmaxn=5)
        integer l(pq,pmaxn)
        real p(pq,pmaxn,6)
        data z(1) / 2 /
        data n(1) / 1 /
        data l(1,1) / 0 /
        data p(1,1,1) / 23.42 /
        data p(1,1,2) / 2.024 /
        data p(1,1,3) / 2578 /
        data p(1,1,4) / 9.648 /
        data p(1,1,5) / 6.218 /
        data p(1,1,6) / 0 /
        data z(2) / 3 /
        data n(2) / 2 /
        data l(2,1) / 0 /
        data p(2,1,1) / 59.85 /
        data p(2,1,2) / 29.51 /
        data p(2,1,3) / 125.2 /
        data p(2,1,4) / 73020 /
        data p(2,1,5) / 0.9438 /
        data p(2,1,6) / 0 /
        data l(2,2) / 0 /
        data p(2,2,1) / 5.495 /
        data p(2,2,2) / 3.466 /
        data p(2,2,3) / 47.74 /
        data p(2,2,4) / 20.35 /
        data p(2,2,5) / 4.423 /
        data p(2,2,6) / 0 /
        data z(3) / 6 /
        data n(3) / 3 /
        data l(3,1) / 0 /
        data p(3,1,1) / 291 /
        data p(3,1,2) / 86.55 /
        data p(3,1,3) / 74.21 /
        data p(3,1,4) / 54.98 /
        data p(3,1,5) / 1.503 /
        data p(3,1,6) / 0 /
        data l(3,2) / 0 /
        data p(3,2,1) / 17.55 /
        data p(3,2,2) / 10.26 /
        data p(3,2,3) / 4564 /
        data p(3,2,4) / 1.568 /
        data p(3,2,5) / 10.85 /
        data p(3,2,6) / 0 /
        data l(3,3) / 1 /
        data p(3,3,1) / 8.987 /
        data p(3,3,2) / 9.435 /
        data p(3,3,3) / 1152 /
        data p(3,3,4) / 5.687 /
        data p(3,3,5) / 6.336 /
        data p(3,3,6) / 0.4474 /
        data z(4) / 7 /
        data n(4) / 3 /
        data l(4,1) / 0 /
        data p(4,1,1) / 404.8 /
        data p(4,1,2) / 127 /
        data p(4,1,3) / 47.48 /
        data p(4,1,4) / 138 /
        data p(4,1,5) / 1.252 /
        data p(4,1,6) / 0 /
        data l(4,2) / 0 /
        data p(4,2,1) / 23.1 /
        data p(4,2,2) / 14.82 /
        data p(4,2,3) / 772.2 /
        data p(4,2,4) / 2.306 /
        data p(4,2,5) / 9.139 /
        data p(4,2,6) / 0 /
        data l(4,3) / 1 /
        data p(4,3,1) / 11.49 /
        data p(4,3,2) / 11.64 /
        data p(4,3,3) / 10290 /
        data p(4,3,4) / 2.361 /
        data p(4,3,5) / 8.821 /
        data p(4,3,6) / 0.4239 /
        data z(5) / 8 /
        data n(5) / 3 /
        data l(5,1) / 0 /
        data p(5,1,1) / 537.3 /
        data p(5,1,2) / 177.4 /
        data p(5,1,3) / 32.37 /
        data p(5,1,4) / 381.2 /
        data p(5,1,5) / 1.083 /
        data p(5,1,6) / 0 /
        data l(5,2) / 0 /
        data p(5,2,1) / 29.22 /
        data p(5,2,2) / 19.94 /
        data p(5,2,3) / 241.5 /
        data p(5,2,4) / 3.241 /
        data p(5,2,5) / 8.037 /
        data p(5,2,6) / 0 /
        data l(5,3) / 1 /
        data p(5,3,1) / 14.16 /
        data p(5,3,2) / 13.91 /
        data p(5,3,3) / 122000 /
        data p(5,3,4) / 1.364 /
        data p(5,3,5) / 11.4 /
        data p(5,3,6) / 0.4103 /
        data z(6) / 9 /
        data n(6) / 3 /
        data l(6,1) / 0 /
        data p(6,1,1) / 688.3 /
        data p(6,1,2) / 239 /
        data p(6,1,3) / 22.95 /
        data p(6,1,4) / 1257 /
        data p(6,1,5) / 0.9638 /
        data p(6,1,6) / 0 /
        data l(6,2) / 0 /
        data p(6,2,1) / 35.93 /
        data p(6,2,2) / 25.68 /
        data p(6,2,3) / 109.7 /
        data p(6,2,4) / 4.297 /
        data p(6,2,5) / 7.303 /
        data p(6,2,6) / 0 /
        data l(6,3) / 1 /
        data p(6,3,1) / 17 /
        data p(6,3,2) / 16.58 /
        data p(6,3,3) / 277500 /
        data p(6,3,4) / 1.242 /
        data p(6,3,5) / 12.49 /
        data p(6,3,6) / 0.3857 /
        data z(7) / 10 /
        data n(7) / 3 /
        data l(7,1) / 0 /
        data p(7,1,1) / 858.2 /
        data p(7,1,2) / 314.4 /
        data p(7,1,3) / 16.64 /
        data p(7,1,4) / 204200 /
        data p(7,1,5) / 0.845 /
        data p(7,1,6) / 0 /
        data l(7,2) / 0 /
        data p(7,2,1) / 43.24 /
        data p(7,2,2) / 32.04 /
        data p(7,2,3) / 56.15 /
        data p(7,2,4) / 5.808 /
        data p(7,2,5) / 6.678 /
        data p(7,2,6) / 0 /
        data l(7,3) / 1 /
        data p(7,3,1) / 20 /
        data p(7,3,2) / 20 /
        data p(7,3,3) / 16910 /
        data p(7,3,4) / 2.442 /
        data p(7,3,5) / 10.43 /
        data p(7,3,6) / 0.3345 /
        data z(8) / 13 /
        data n(8) / 5 /
        data l(8,1) / 0 /
        data p(8,1,1) / 1550 /
        data p(8,1,2) / 367 /
        data p(8,1,3) / 22.06 /
        data p(8,1,4) / 44.05 /
        data p(8,1,5) / 1.588 /
        data p(8,1,6) / 0 /
        data l(8,2) / 0 /
        data p(8,2,1) / 119 /
        data p(8,2,2) / 55.94 /
        data p(8,2,3) / 14.25 /
        data p(8,2,4) / 30.94 /
        data p(8,2,5) / 4.399 /
        data p(8,2,6) / 0 /
        data l(8,3) / 1 /
        data p(8,3,1) / 80.87 /
        data p(8,3,2) / 64.45 /
        data p(8,3,3) / 173.5 /
        data p(8,3,4) / 11310 /
        data p(8,3,5) / 2.762 /
        data p(8,3,6) / 0.02337 /
        data l(8,4) / 0 /
        data p(8,4,1) / 10.16 /
        data p(8,4,2) / 12.04 /
        data p(8,4,3) / 5.384 /
        data p(8,4,4) / 434.1 /
        data p(8,4,5) / 4.088 /
        data p(8,4,6) / 0 /
        data l(8,5) / 1 /
        data p(8,5,1) / 4.878 /
        data p(8,5,2) / 18.6 /
        data p(8,5,3) / 182.8 /
        data p(8,5,4) / 2.797 /
        data p(8,5,5) / 10.84 /
        data p(8,5,6) / 0.3076 /
        data z(9) / 14 /
        data n(9) / 5 /
        data l(9,1) / 0 /
        data p(9,1,1) / 1828 /
        data p(9,1,2) / 532.2 /
        data p(9,1,3) / 11.84 /
        data p(9,1,4) / 258 /
        data p(9,1,5) / 1.102 /
        data p(9,1,6) / 0 /
        data l(9,2) / 0 /
        data p(9,2,1) / 151.5 /
        data p(9,2,2) / 70.17 /
        data p(9,2,3) / 11.66 /
        data p(9,2,4) / 47.42 /
        data p(9,2,5) / 3.933 /
        data p(9,2,6) / 0 /
        data l(9,3) / 1 /
        data p(9,3,1) / 108.2 /
        data p(9,3,2) / 78.08 /
        data p(9,3,3) / 153.2 /
        data p(9,3,4) / 5.765e+06 /
        data p(9,3,5) / 2.639 /
        data p(9,3,6) / 0.0002774 /
        data l(9,4) / 0 /
        data p(9,4,1) / 13.61 /
        data p(9,4,2) / 14.13 /
        data p(9,4,3) / 11.66 /
        data p(9,4,4) / 22.88 /
        data p(9,4,5) / 5.334 /
        data p(9,4,6) / 0 /
        data l(9,5) / 1 /
        data p(9,5,1) / 6.542 /
        data p(9,5,2) / 22.12 /
        data p(9,5,3) / 184.5 /
        data p(9,5,4) / 3.849 /
        data p(9,5,5) / 9.721 /
        data p(9,5,6) / 0.2921 /
        data z(10) / 18 /
        data n(10) / 5 /
        data l(10,1) / 0 /
        data p(10,1,1) / 3178 /
        data p(10,1,2) / 1135 /
        data p(10,1,3) / 4.28 /
        data p(10,1,4) / 3.285e+07 /
        data p(10,1,5) / 0.7631 /
        data p(10,1,6) / 0 /
        data l(10,2) / 0 /
        data p(10,2,1) / 313.5 /
        data p(10,2,2) / 130.2 /
        data p(10,2,3) / 9.185 /
        data p(10,2,4) / 26.93 /
        data p(10,2,5) / 4.021 /
        data p(10,2,6) / 0 /
        data l(10,3) / 1 /
        data p(10,3,1) / 247.9 /
        data p(10,3,2) / 164.7 /
        data p(10,3,3) / 83.72 /
        data p(10,3,4) / 54.52 /
        data p(10,3,5) / 3.328 /
        data p(10,3,6) / 0.627 /
        data l(10,4) / 0 /
        data p(10,4,1) / 28.92 /
        data p(10,4,2) / 25.25 /
        data p(10,4,3) / 6.394 /
        data p(10,4,4) / 170 /
        data p(10,4,5) / 4.223 /
        data p(10,4,6) / 0 /
        data l(10,5) / 1 /
        data p(10,5,1) / 14.49 /
        data p(10,5,2) / 38.54 /
        data p(10,5,3) / 48.72 /
        data p(10,5,4) / 26.4 /
        data p(10,5,5) / 6.662 /
        data p(10,5,6) / 0.2355 /


        Za=Zat(na)


        do i=1,pq

        if(z(i).eq.Za)then

                qshPas(na)=n(i)
                do npas=1,qshPas(na)
        lPas(npas,na)=l(i,npas)
        EthPas(npas,na)=p(i,npas,1)
        E0Pas(npas,na)=p(i,npas,2)
        sigma0Pas(npas,na)=p(i,npas,3)
        yaPas(npas,na)=p(i,npas,4)
        PPas(npas,na)=p(i,npas,5)
        ywPas(npas,na)=p(i,npas,6)
                enddo
                go to 110

        endif
        enddo
*** Warning message commented out (RV 29/6/98).
C        if(soo.eq.1)then
C        write(oo,*)
C     + ' Worning of readPas: atom z=',Za,' is not found.'
C       write(oo,*)
C     + '  The data will be seached by shellfi, accuracy will be lower.'
C       endif
*** End of modification.
110     continue

                    
        end
        

        function sigma_nl(E,E0,Eth,yw,l,ya,P,sigma0)

        implicit none

        real sigma_nl,Fpasc
        real E,E0,Eth,yw,ya,P,sigma0
        integer l

        real Q,y

        if(E.ge.Eth)then
        
        Q=5.5+l-0.5*P
        y=E/E0
        Fpasc=((y-1)*(y-1) + yw*yw) * y**(-Q) * (1.0 + sqrt(y/ya))**(-P)
        Fpasc=Fpasc*sigma0

        else

        Fpasc=0.0

        endif

        sigma_nl=Fpasc

        end

        subroutine Pripasc

        implicit none

c         include 'GoEvent.inc'
+SEQ,GoEvent.
c         include 'ener.inc'
+SEQ,ener.
c         include 'atoms.inc'
+SEQ,atoms.
c       include 'tpasc.inc'
+SEQ,tpasc.

        integer na,ns

        if(soo.eq.0)return
        write(oo,*)
        write(oo,*)' Pripasc:'
        do na=1,PQat
        if(Zat(na).gt.0)then
        write(oo,*)' qshPas(na)=',qshPas(na)
        write(oo,*)' l,E0,Eth,yw, ya,P,sigma0:'
        do ns=1,qshPas(na)
        write(oo,'(1X,i3,6e10.3)')lPas(ns,na),E0Pas(ns,na),
     +  EthPas(ns,na),ywPas(ns,na),yaPas(ns,na),PPas(ns,na),
     +  sigma0Pas(ns,na)
        enddo
        endif

        enddo

        end
+DECK,shellfi.
        subroutine shellfi
c
c       read shellfi.dat

        implicit none

c         include 'GoEvent.inc'
+SEQ,GoEvent.
c       include 'shellfi.inc'
+SEQ,shellfi.

c       integer i,z,n,k,j
        integer k1,l
c       character*1 a
c       integer ios

        qash=0          !sign of absence


c       The next code is generated by a computer program
c       on the basis of data file 'shellfi.dat'.


        if(zato.eq.3)then
        qash=2
        athreshold(1)=5.44515e-05
        aweight(1)=0.666667
        qaener(1)=36
        aener(1,1)=45.9
        aphot(1,1)=0
        aener(2,1)=50.4
        aphot(2,1)=809
        aener(3,1)=55.4
        aphot(3,1)=6080
        aener(4,1)=60.9
        aphot(4,1)=8810
        aener(5,1)=66.9
        aphot(5,1)=8700
        aener(6,1)=73.5
        aphot(6,1)=7210
        aener(7,1)=80.8
        aphot(7,1)=5530
        aener(8,1)=88.8
        aphot(8,1)=4420
        aener(9,1)=97.6
        aphot(9,1)=3840
        aener(10,1)=107
        aphot(10,1)=3090
        aener(11,1)=118
        aphot(11,1)=2520
        aener(12,1)=129
        aphot(12,1)=2040
        aener(13,1)=142
        aphot(13,1)=1820
        aener(14,1)=156
        aphot(14,1)=1460
        aener(15,1)=172
        aphot(15,1)=1050
        aener(16,1)=189
        aphot(16,1)=866
        aener(17,1)=207
        aphot(17,1)=717
        aener(18,1)=228
        aphot(18,1)=594
        aener(19,1)=275
        aphot(19,1)=407
        aener(20,1)=303
        aphot(20,1)=337
        aener(21,1)=500
        aphot(21,1)=25.0178
        aener(22,1)=700
        aphot(22,1)=10.0856
        aener(23,1)=900
        aphot(23,1)=5.11698
        aener(24,1)=1100
        aphot(24,1)=2.97651
        aener(25,1)=1300
        aphot(25,1)=1.89593
        aener(26,1)=1600
        aphot(26,1)=1.08229
        aener(27,1)=2000
        aphot(27,1)=0.592498
        aener(28,1)=4000
        aphot(28,1)=0.0888748
        aener(29,1)=6000
        aphot(29,1)=0.0296249
        aener(30,1)=8000
        aphot(30,1)=0.0148125
        aener(31,1)=10000
        aphot(31,1)=0.00888748
        aener(32,1)=20000
        aphot(32,1)=0.00503624
        aener(33,1)=30000
        aphot(33,1)=0.00444374
        aener(34,1)=40000
        aphot(34,1)=0.00414749
        aener(35,1)=50000
        aphot(35,1)=0.00399937
        aener(36,1)=80000
        aphot(36,1)=0.00355499
        athreshold(2)=1e-05
        aweight(2)=0.333333
        qaener(2)=29
        aener(1,2)=8.4
        aphot(1,2)=0
        aener(2,2)=9.23
        aphot(2,2)=2100
        aener(3,2)=10.1
        aphot(3,2)=16900
        aener(4,2)=11.1
        aphot(4,2)=25500
        aener(5,2)=12.2
        aphot(5,2)=22900
        aener(6,2)=13.5
        aphot(6,2)=17600
        aener(7,2)=14.8
        aphot(7,2)=15000
        aener(8,2)=16.2
        aphot(8,2)=10700
        aener(9,2)=17.9
        aphot(9,2)=8880
        aener(10,2)=19.6
        aphot(10,2)=7360
        aener(11,2)=21.6
        aphot(11,2)=6090
        aener(12,2)=23.7
        aphot(12,2)=5040
        aener(13,2)=26
        aphot(13,2)=4180
        aener(14,2)=28.6
        aphot(14,2)=3460
        aener(15,2)=31.5
        aphot(15,2)=2860
        aener(16,2)=34.6
        aphot(16,2)=2370
        aener(17,2)=38
        aphot(17,2)=1960
        aener(18,2)=41.7
        aphot(18,2)=1630
        aener(19,2)=45.9
        aphot(19,2)=1350
        aener(20,2)=50.4
        aphot(20,2)=1110
        aener(21,2)=55.4
        aphot(21,2)=923
        aener(22,2)=60.9
        aphot(22,2)=764
        aener(23,2)=66.9
        aphot(23,2)=633
        aener(24,2)=73.5
        aphot(24,2)=524
        aener(25,2)=80.8
        aphot(25,2)=434
        aener(26,2)=88.8
        aphot(26,2)=359
        aener(27,2)=97.6
        aphot(27,2)=0.298
        aener(28,2)=107
        aphot(28,2)=0.00246
        aener(29,2)=118
        aphot(29,2)=0.000204
        endif
        if(zato.eq.6)then
        qash=2
        athreshold(1)=0.000309
        aweight(1)=0.423871
        qaener(1)=24
        aener(1,1)=228
        aphot(1,1)=16900
        aener(2,1)=251
        aphot(2,1)=23300
        aener(3,1)=275
        aphot(3,1)=30700
        aener(4,1)=303
        aphot(4,1)=38600
        aener(5,1)=333
        aphot(5,1)=37200
        aener(6,1)=365
        aphot(6,1)=31200
        aener(7,1)=402
        aphot(7,1)=24900
        aener(8,1)=441
        aphot(8,1)=20900
        aener(9,1)=485
        aphot(9,1)=18000
        aener(10,1)=533
        aphot(10,1)=14800
        aener(11,1)=586
        aphot(11,1)=11400
        aener(12,1)=644
        aphot(12,1)=8620
        aener(13,1)=707
        aphot(13,1)=7090
        aener(14,1)=777
        aphot(14,1)=5440
        aener(15,1)=854
        aphot(15,1)=3960
        aener(16,1)=939
        aphot(16,1)=3080
        aener(17,1)=1030
        aphot(17,1)=2400
        aener(18,1)=3500
        aphot(18,1)=60
        aener(19,1)=4000
        aphot(19,1)=33
        aener(20,1)=10000
        aphot(20,1)=2
        aener(21,1)=20000
        aphot(21,1)=0.4
        aener(22,1)=30000
        aphot(22,1)=0.27
        aener(23,1)=50000
        aphot(23,1)=0.2
        aener(24,1)=100000
        aphot(24,1)=0.17
        athreshold(2)=1.03321e-05
        aweight(2)=0.576129
        qaener(2)=14
        aener(1,2)=6.19927
        aphot(1,2)=0
        aener(2,2)=8.26569
        aphot(2,2)=0
        aener(3,2)=10.3321
        aphot(3,2)=12.6
        aener(4,2)=12.3985
        aphot(4,2)=11.2
        aener(5,2)=15.4982
        aphot(5,2)=9.1
        aener(6,2)=20.6642
        aphot(6,2)=7.3
        aener(7,2)=30.9964
        aphot(7,2)=4.4
        aener(8,2)=41.3285
        aphot(8,2)=2.9
        aener(9,2)=61.9927
        aphot(9,2)=1.45
        aener(10,2)=82.6569
        aphot(10,2)=0.88
        aener(11,2)=103.321
        aphot(11,2)=0.59
        aener(12,2)=123.985
        aphot(12,2)=0.4
        aener(13,2)=154.982
        aphot(13,2)=0.24
        aener(14,2)=206.642
        aphot(14,2)=0.108
        endif
        if(zato.eq.7)then
        qash=2
        athreshold(1)=0.000413
        aweight(1)=0.318257
        qaener(1)=8
        aener(1,1)=309.964
        aphot(1,1)=0.07
        aener(2,1)=413.285
        aphot(2,1)=0.68
        aener(3,1)=619.927
        aphot(3,1)=0.255
        aener(4,1)=826.569
        aphot(4,1)=0.125
        aener(5,1)=1033.21
        aphot(5,1)=0.075
        aener(6,1)=1239.85
        aphot(6,1)=0.047
        aener(7,1)=1549.82
        aphot(7,1)=0.026
        aener(8,1)=2066.42
        aphot(8,1)=0.012
        athreshold(2)=1.23985e-05
        aweight(2)=0.681743
        qaener(2)=15
        aener(1,2)=6.19927
        aphot(1,2)=0
        aener(2,2)=8.26569
        aphot(2,2)=0
        aener(3,2)=10.3321
        aphot(3,2)=0
        aener(4,2)=12.3985
        aphot(4,2)=11.95
        aener(5,2)=15.4982
        aphot(5,2)=11.9
        aener(6,2)=20.6642
        aphot(6,2)=9.65
        aener(7,2)=30.9964
        aphot(7,2)=7.8
        aener(8,2)=41.3285
        aphot(8,2)=5.4
        aener(9,2)=61.9927
        aphot(9,2)=2.9
        aener(10,2)=82.6569
        aphot(10,2)=1.75
        aener(11,2)=103.321
        aphot(11,2)=1.1
        aener(12,2)=123.985
        aphot(12,2)=0.65
        aener(13,2)=154.982
        aphot(13,2)=0.39
        aener(14,2)=206.642
        aphot(14,2)=0.208
        aener(15,2)=309.964
        aphot(15,2)=0.07
        endif
        if(zato.eq.8)then
        qash=2
        athreshold(1)=0.00062
        aweight(1)=0.240404
        qaener(1)=20
        aener(1,1)=586
        aphot(1,1)=13300
        aener(2,1)=644
        aphot(2,1)=14200
        aener(3,1)=707
        aphot(3,1)=11800
        aener(4,1)=777
        aphot(4,1)=9270
        aener(5,1)=854
        aphot(5,1)=7100
        aener(6,1)=939
        aphot(6,1)=5880
        aener(7,1)=1030
        aphot(7,1)=4660
        aener(8,1)=1130
        aphot(8,1)=3690
        aener(9,1)=1250
        aphot(9,1)=2790
        aener(10,1)=1370
        aphot(10,1)=2260
        aener(11,1)=1500
        aphot(11,1)=1740
        aener(12,1)=1650
        aphot(12,1)=1340
        aener(13,1)=1820
        aphot(13,1)=1060
        aener(14,1)=3500
        aphot(14,1)=187.5
        aener(15,1)=4000
        aphot(15,1)=118.125
        aener(16,1)=10000
        aphot(16,1)=6.75
        aener(17,1)=20000
        aphot(17,1)=0.9
        aener(18,1)=30000
        aphot(18,1)=0.39375
        aener(19,1)=50000
        aphot(19,1)=0.255
        aener(20,1)=100000
        aphot(20,1)=0.19875
        athreshold(2)=2.06642e-05
        aweight(2)=0.759596
        qaener(2)=16
        aener(1,2)=6.19927
        aphot(1,2)=0
        aener(2,2)=8.26569
        aphot(2,2)=0
        aener(3,2)=10.3321
        aphot(3,2)=0
        aener(4,2)=12.3985
        aphot(4,2)=0
        aener(5,2)=15.4982
        aphot(5,2)=9
        aener(6,2)=20.6642
        aphot(6,2)=9.65
        aener(7,2)=30.9964
        aphot(7,2)=8.75
        aener(8,2)=41.3285
        aphot(8,2)=7.42
        aener(9,2)=61.9927
        aphot(9,2)=4.65
        aener(10,2)=82.6569
        aphot(10,2)=2.7
        aener(11,2)=103.321
        aphot(11,2)=1.77
        aener(12,2)=123.985
        aphot(12,2)=1.12
        aener(13,2)=154.982
        aphot(13,2)=0.7
        aener(14,2)=206.642
        aphot(14,2)=0.385
        aener(15,2)=309.964
        aphot(15,2)=0.16
        aener(16,2)=413.285
        aphot(16,2)=0.065
        endif
        if(zato.eq.9)then
        qash=2
        athreshold(1)=0.000827
        aweight(1)=0.185727
        qaener(1)=6
        aener(1,1)=619.927
        aphot(1,1)=0.05
        aener(2,1)=826.569
        aphot(2,1)=0.305
        aener(3,1)=1033.21
        aphot(3,1)=0.17
        aener(4,1)=1239.85
        aphot(4,1)=0.115
        aener(5,1)=1549.82
        aphot(5,1)=0.067
        aener(6,1)=2066.42
        aphot(6,1)=0.03
        athreshold(2)=3.09964e-05
        aweight(2)=0.814273
        qaener(2)=17
        aener(1,2)=6.19927
        aphot(1,2)=0
        aener(2,2)=8.26569
        aphot(2,2)=0
        aener(3,2)=10.3321
        aphot(3,2)=0
        aener(4,2)=12.3985
        aphot(4,2)=0
        aener(5,2)=15.4982
        aphot(5,2)=0
        aener(6,2)=20.6642
        aphot(6,2)=0
        aener(7,2)=30.9964
        aphot(7,2)=10.6
        aener(8,2)=41.3285
        aphot(8,2)=10.1
        aener(9,2)=61.9927
        aphot(9,2)=6.7
        aener(10,2)=82.6569
        aphot(10,2)=4.1
        aener(11,2)=103.321
        aphot(11,2)=2.6
        aener(12,2)=123.985
        aphot(12,2)=1.8
        aener(13,2)=154.982
        aphot(13,2)=1.3
        aener(14,2)=206.642
        aphot(14,2)=0.59
        aener(15,2)=309.964
        aphot(15,2)=0.245
        aener(16,2)=413.285
        aphot(16,2)=0.124
        aener(17,2)=619.927
        aphot(17,2)=0.05
        endif
        if(zato.eq.10)then
        qash=2
        athreshold(1)=0.001033
        aweight(1)=0.117826
        qaener(1)=5
        aener(1,1)=826.569
        aphot(1,1)=0.03
        aener(2,1)=1033.21
        aphot(2,1)=0.205
        aener(3,1)=1239.85
        aphot(3,1)=0.135
        aener(4,1)=1549.82
        aphot(4,1)=0.077
        aener(5,1)=2066.42
        aphot(5,1)=0.039
        athreshold(2)=3.09964e-05
        aweight(2)=0.882174
        qaener(2)=18
        aener(1,2)=6.19927
        aphot(1,2)=0
        aener(2,2)=8.26569
        aphot(2,2)=0
        aener(3,2)=10.3321
        aphot(3,2)=0
        aener(4,2)=12.3985
        aphot(4,2)=0
        aener(5,2)=15.4982
        aphot(5,2)=0
        aener(6,2)=20.6642
        aphot(6,2)=5.85
        aener(7,2)=30.9964
        aphot(7,2)=8.8
        aener(8,2)=41.3285
        aphot(8,2)=8.7
        aener(9,2)=61.9927
        aphot(9,2)=7.3
        aener(10,2)=82.6569
        aphot(10,2)=5.6
        aener(11,2)=103.321
        aphot(11,2)=4
        aener(12,2)=123.985
        aphot(12,2)=2.8
        aener(13,2)=154.982
        aphot(13,2)=1.75
        aener(14,2)=206.642
        aphot(14,2)=0.91
        aener(15,2)=309.964
        aphot(15,2)=0.36
        aener(16,2)=413.285
        aphot(16,2)=0.17
        aener(17,2)=619.927
        aphot(17,2)=0.063
        aener(18,2)=826.569
        aphot(18,2)=0.03
        endif
        if(zato.eq.17)then
        qash=4
        athreshold(1)=0.003485
        aweight(1)=0.117088
        qaener(1)=69
        aener(1,1)=3365.37
        aphot(1,1)=0
        aener(2,1)=3536.21
        aphot(2,1)=0.050227
        aener(3,1)=3715.72
        aphot(3,1)=0.0574
        aener(4,1)=3904.35
        aphot(4,1)=0.051988
        aener(5,1)=4102.55
        aphot(5,1)=0.047086
        aener(6,1)=4310.81
        aphot(6,1)=0.042647
        aener(7,1)=4529.65
        aphot(7,1)=0.038625
        aener(8,1)=4759.59
        aphot(8,1)=0.034983
        aener(9,1)=5001.2
        aphot(9,1)=0.031685
        aener(10,1)=5255.08
        aphot(10,1)=0.028697
        aener(11,1)=5521.85
        aphot(11,1)=0.025992
        aener(12,1)=5802.16
        aphot(12,1)=0.023541
        aener(13,1)=6096.71
        aphot(13,1)=0.021321
        aener(14,1)=6406.2
        aphot(14,1)=0.019311
        aener(15,1)=6731.4
        aphot(15,1)=0.01749
        aener(16,1)=7073.12
        aphot(16,1)=0.015841
        aener(17,1)=7432.17
        aphot(17,1)=0.014347
        aener(18,1)=7809.46
        aphot(18,1)=0.012995
        aener(19,1)=8205.9
        aphot(19,1)=0.011769
        aener(20,1)=8622.46
        aphot(20,1)=0.01066
        aener(21,1)=9060.17
        aphot(21,1)=0.009654
        aener(22,1)=9520.11
        aphot(22,1)=0.008744
        aener(23,1)=10003.4
        aphot(23,1)=0.00792
        aener(24,1)=10511.2
        aphot(24,1)=0.007173
        aener(25,1)=11044.8
        aphot(25,1)=0.006497
        aener(26,1)=11605.5
        aphot(26,1)=0.005884
        aener(27,1)=12194.6
        aphot(27,1)=0.005329
        aener(28,1)=12813.6
        aphot(28,1)=0.004827
        aener(29,1)=13464.1
        aphot(29,1)=0.004372
        aener(30,1)=14147.6
        aphot(30,1)=0.003959
        aener(31,1)=14865.8
        aphot(31,1)=0.003586
        aener(32,1)=15620.4
        aphot(32,1)=0.003248
        aener(33,1)=16413.4
        aphot(33,1)=0.002942
        aener(34,1)=17246.6
        aphot(34,1)=0.002664
        aener(35,1)=18122.1
        aphot(35,1)=0.002413
        aener(36,1)=19042.1
        aphot(36,1)=0.002186
        aener(37,1)=20008.7
        aphot(37,1)=0.00198
        aener(38,1)=21024.4
        aphot(38,1)=0.001793
        aener(39,1)=22091.7
        aphot(39,1)=0.001624
        aener(40,1)=23213.2
        aphot(40,1)=0.001471
        aener(41,1)=24391.6
        aphot(41,1)=0.001332
        aener(42,1)=25629.8
        aphot(42,1)=0.001206
        aener(43,1)=26930.9
        aphot(43,1)=0.001093
        aener(44,1)=28298
        aphot(44,1)=0.00099
        aener(45,1)=29734.5
        aphot(45,1)=0.000896
        aener(46,1)=31243.9
        aphot(46,1)=0.000812
        aener(47,1)=32830
        aphot(47,1)=0.000735
        aener(48,1)=34496.6
        aphot(48,1)=0.000666
        aener(49,1)=36247.8
        aphot(49,1)=0.000603
        aener(50,1)=38087.9
        aphot(50,1)=0.000546
        aener(51,1)=40021.3
        aphot(51,1)=0.000495
        aener(52,1)=42053
        aphot(52,1)=0.000448
        aener(53,1)=44187.8
        aphot(53,1)=0.000406
        aener(54,1)=46430.9
        aphot(54,1)=0.000368
        aener(55,1)=48787.9
        aphot(55,1)=0.000333
        aener(56,1)=51264.6
        aphot(56,1)=0.000302
        aener(57,1)=53867
        aphot(57,1)=0.000273
        aener(58,1)=56601.5
        aphot(58,1)=0.000247
        aener(59,1)=59474.8
        aphot(59,1)=0.000224
        aener(60,1)=62494
        aphot(60,1)=0.000203
        aener(61,1)=65666.4
        aphot(61,1)=0.000184
        aener(62,1)=68999.9
        aphot(62,1)=0.000166
        aener(63,1)=72502.6
        aphot(63,1)=0.000151
        aener(64,1)=76183.1
        aphot(64,1)=0.000137
        aener(65,1)=80050.5
        aphot(65,1)=0.000124
        aener(66,1)=84114.2
        aphot(66,1)=0.000112
        aener(67,1)=88384.1
        aphot(67,1)=0.000101
        aener(68,1)=92870.9
        aphot(68,1)=9.18846e-05
        aener(69,1)=97585.4
        aphot(69,1)=8.32209e-05
        athreshold(2)=0.000207
        aweight(2)=0.635323
        qaener(2)=10
        aener(1,2)=154.982
        aphot(1,2)=0.6
        aener(2,2)=206.642
        aphot(2,2)=6.4
        aener(3,2)=309.964
        aphot(3,2)=2.45
        aener(4,2)=413.285
        aphot(4,2)=1.4
        aener(5,2)=619.927
        aphot(5,2)=0.45
        aener(6,2)=826.569
        aphot(6,2)=0.22
        aener(7,2)=1033.21
        aphot(7,2)=0.123
        aener(8,2)=1239.85
        aphot(8,2)=0.079
        aener(9,2)=1549.82
        aphot(9,2)=0.047
        aener(10,2)=2066.42
        aphot(10,2)=0.0195
        athreshold(3)=6.19927e-05
        aweight(3)=0.061546
        qaener(3)=6
        aener(1,3)=41.3285
        aphot(1,3)=1.07
        aener(2,3)=61.9927
        aphot(2,3)=1.35
        aener(3,3)=82.6569
        aphot(3,3)=1.22
        aener(4,3)=103.321
        aphot(4,3)=1
        aener(5,3)=123.985
        aphot(5,3)=0.82
        aener(6,3)=154.982
        aphot(6,3)=0.6
        athreshold(4)=1.54982e-05
        aweight(4)=0.186043
        qaener(4)=8
        aener(1,4)=6.19927
        aphot(1,4)=0
        aener(2,4)=8.26569
        aphot(2,4)=0
        aener(3,4)=10.3321
        aphot(3,4)=0
        aener(4,4)=12.3985
        aphot(4,4)=0
        aener(5,4)=15.4982
        aphot(5,4)=59
        aener(6,4)=20.6642
        aphot(6,4)=11
        aener(7,4)=30.9964
        aphot(7,4)=1.35
        aener(8,4)=41.3285
        aphot(8,4)=1.07
        endif
        if(zato.eq.18)then
        qash=4
        athreshold(1)=0.003934
        aweight(1)=0.114211
        qaener(1)=67
        aener(1,1)=3715.72
        aphot(1,1)=0
        aener(2,1)=3904.35
        aphot(2,1)=0.020435
        aener(3,1)=4102.55
        aphot(3,1)=0.053399
        aener(4,1)=4310.81
        aphot(4,1)=0.048364
        aener(5,1)=4529.65
        aphot(5,1)=0.043804
        aener(6,1)=4759.59
        aphot(6,1)=0.039674
        aener(7,1)=5001.2
        aphot(7,1)=0.035933
        aener(8,1)=5255.08
        aphot(8,1)=0.032545
        aener(9,1)=5521.85
        aphot(9,1)=0.029476
        aener(10,1)=5802.16
        aphot(10,1)=0.026697
        aener(11,1)=6096.71
        aphot(11,1)=0.02418
        aener(12,1)=6406.2
        aphot(12,1)=0.0219
        aener(13,1)=6731.4
        aphot(13,1)=0.019835
        aener(14,1)=7073.12
        aphot(14,1)=0.017965
        aener(15,1)=7432.17
        aphot(15,1)=0.016271
        aener(16,1)=7809.46
        aphot(16,1)=0.014737
        aener(17,1)=8205.9
        aphot(17,1)=0.013347
        aener(18,1)=8622.46
        aphot(18,1)=0.012089
        aener(19,1)=9060.17
        aphot(19,1)=0.010949
        aener(20,1)=9520.11
        aphot(20,1)=0.009917
        aener(21,1)=10003.4
        aphot(21,1)=0.008982
        aener(22,1)=10511.2
        aphot(22,1)=0.008135
        aener(23,1)=11044.8
        aphot(23,1)=0.007368
        aener(24,1)=11605.5
        aphot(24,1)=0.006673
        aener(25,1)=12194.6
        aphot(25,1)=0.006044
        aener(26,1)=12813.6
        aphot(26,1)=0.005474
        aener(27,1)=13464.1
        aphot(27,1)=0.004958
        aener(28,1)=14147.6
        aphot(28,1)=0.00449
        aener(29,1)=14865.8
        aphot(29,1)=0.004067
        aener(30,1)=15620.4
        aphot(30,1)=0.003683
        aener(31,1)=16413.4
        aphot(31,1)=0.003336
        aener(32,1)=17246.6
        aphot(32,1)=0.003022
        aener(33,1)=18122.1
        aphot(33,1)=0.002737
        aener(34,1)=19042.1
        aphot(34,1)=0.002479
        aener(35,1)=20008.7
        aphot(35,1)=0.002245
        aener(36,1)=21024.4
        aphot(36,1)=0.002033
        aener(37,1)=22091.7
        aphot(37,1)=0.001842
        aener(38,1)=23213.2
        aphot(38,1)=0.001668
        aener(39,1)=24391.6
        aphot(39,1)=0.001511
        aener(40,1)=25629.8
        aphot(40,1)=0.001368
        aener(41,1)=26930.9
        aphot(41,1)=0.001239
        aener(42,1)=28298
        aphot(42,1)=0.001122
        aener(43,1)=29734.5
        aphot(43,1)=0.001017
        aener(44,1)=31243.9
        aphot(44,1)=0.000921
        aener(45,1)=32830
        aphot(45,1)=0.000834
        aener(46,1)=34496.6
        aphot(46,1)=0.000755
        aener(47,1)=36247.8
        aphot(47,1)=0.000684
        aener(48,1)=38087.9
        aphot(48,1)=0.00062
        aener(49,1)=40021.3
        aphot(49,1)=0.000561
        aener(50,1)=42053
        aphot(50,1)=0.000508
        aener(51,1)=44187.8
        aphot(51,1)=0.00046
        aener(52,1)=46430.9
        aphot(52,1)=0.000417
        aener(53,1)=48787.9
        aphot(53,1)=0.000378
        aener(54,1)=51264.6
        aphot(54,1)=0.000342
        aener(55,1)=53867
        aphot(55,1)=0.00031
        aener(56,1)=56601.5
        aphot(56,1)=0.000281
        aener(57,1)=59474.8
        aphot(57,1)=0.000254
        aener(58,1)=62494
        aphot(58,1)=0.00023
        aener(59,1)=65666.4
        aphot(59,1)=0.000208
        aener(60,1)=68999.9
        aphot(60,1)=0.000189
        aener(61,1)=72502.6
        aphot(61,1)=0.000171
        aener(62,1)=76183.1
        aphot(62,1)=0.000155
        aener(63,1)=80050.5
        aphot(63,1)=0.00014
        aener(64,1)=84114.2
        aphot(64,1)=0.000127
        aener(65,1)=88384.1
        aphot(65,1)=0.000115
        aener(66,1)=92870.9
        aphot(66,1)=0.000104
        aener(67,1)=97585.4
        aphot(67,1)=9.43788e-05
        athreshold(2)=0.00031
        aweight(2)=0.438551
        qaener(2)=10
        aener(1,2)=206.642
        aphot(1,2)=0.55
        aener(2,2)=309.964
        aphot(2,2)=2.52
        aener(3,2)=413.285
        aphot(3,2)=1.66
        aener(4,2)=619.927
        aphot(4,2)=0.62
        aener(5,2)=826.569
        aphot(5,2)=0.29
        aener(6,2)=1033.21
        aphot(6,2)=0.16
        aener(7,2)=1239.85
        aphot(7,2)=0.1
        aener(8,2)=1549.82
        aphot(8,2)=0.06
        aener(9,2)=2066.42
        aphot(9,2)=0.026
        aener(10,2)=3099.64
        aphot(10,2)=0.0085
        athreshold(3)=6.19927e-05
        aweight(3)=0.092874
        qaener(3)=7
        aener(1,3)=41.3285
        aphot(1,3)=1
        aener(2,3)=61.9927
        aphot(2,3)=1.52
        aener(3,3)=82.6569
        aphot(3,3)=1.52
        aener(4,3)=103.321
        aphot(4,3)=1.33
        aener(5,3)=123.985
        aphot(5,3)=1.1
        aener(6,3)=154.982
        aphot(6,3)=0.85
        aener(7,3)=206.642
        aphot(7,3)=0.55
        athreshold(4)=1.54982e-05
        aweight(4)=0.354364
        qaener(4)=8
        aener(1,4)=6.19927
        aphot(1,4)=0
        aener(2,4)=8.26569
        aphot(2,4)=0
        aener(3,4)=10.3321
        aphot(3,4)=0
        aener(4,4)=12.3985
        aphot(4,4)=0
        aener(5,4)=15.4982
        aphot(5,4)=60
        aener(6,4)=20.6642
        aphot(6,4)=52.5
        aener(7,4)=30.9964
        aphot(7,4)=2
        aener(8,4)=41.3285
        aphot(8,4)=1
        endif
        if(zato.eq.36)then
        qash=4
        athreshold(1)=0.015498
        aweight(1)=0.04453
        qaener(1)=4
        aener(1,1)=12398.5
        aphot(1,1)=0.0032
        aener(2,1)=15498.2
        aphot(2,1)=0.0205
        aener(3,1)=20664.2
        aphot(3,1)=0.0079
        aener(4,1)=30996.4
        aphot(4,1)=0.0022
        athreshold(2)=0.00155
        aweight(2)=0.262277
        qaener(2)=9
        aener(1,2)=1239.85
        aphot(1,2)=0.22
        aener(2,2)=1549.82
        aphot(2,2)=0.7
        aener(3,2)=2066.42
        aphot(3,2)=0.41
        aener(4,2)=3099.64
        aphot(4,2)=0.14
        aener(5,2)=4132.85
        aphot(5,2)=0.061
        aener(6,2)=6199.27
        aphot(6,2)=0.02
        aener(7,2)=8265.69
        aphot(7,2)=0.0096
        aener(8,2)=10332.1
        aphot(8,2)=0.0053
        aener(9,2)=12398.5
        aphot(9,2)=0.0032
        athreshold(3)=0.000207
        aweight(3)=0.594165
        qaener(3)=11
        aener(1,3)=82.6569
        aphot(1,3)=0.7
        aener(2,3)=103.321
        aphot(2,3)=1.2
        aener(3,3)=123.985
        aphot(3,3)=3.4
        aener(4,3)=154.982
        aphot(4,3)=6.1
        aener(5,3)=206.642
        aphot(5,3)=6.8
        aener(6,3)=309.964
        aphot(6,3)=4.4
        aener(7,3)=413.285
        aphot(7,3)=2.65
        aener(8,3)=619.927
        aphot(8,3)=0.95
        aener(9,3)=826.569
        aphot(9,3)=0.54
        aener(10,3)=1033.21
        aphot(10,3)=0.34
        aener(11,3)=1239.85
        aphot(11,3)=0.22
        athreshold(4)=1.54982e-05
        aweight(4)=0.099027
        qaener(4)=10
        aener(1,4)=6.19927
        aphot(1,4)=0
        aener(2,4)=8.26569
        aphot(2,4)=0
        aener(3,4)=10.3321
        aphot(3,4)=0
        aener(4,4)=12.3985
        aphot(4,4)=0
        aener(5,4)=15.4982
        aphot(5,4)=60
        aener(6,4)=20.6642
        aphot(6,4)=7.2
        aener(7,4)=30.9964
        aphot(7,4)=1.75
        aener(8,4)=41.3285
        aphot(8,4)=1.05
        aener(9,4)=61.9927
        aphot(9,4)=0.75
        aener(10,4)=82.6569
        aphot(10,4)=0.7
        endif
        if(zato.eq.54)then
        qash=6
        athreshold(1)=0.041328
        aweight(1)=0.017971
        qaener(1)=3
        aener(1,1)=30996.4
        aphot(1,1)=0.0013
        aener(2,1)=41328.5
        aphot(2,1)=0.0046
        aener(3,1)=61992.7
        aphot(3,1)=0.0015
        athreshold(2)=0.006199
        aweight(2)=0.114379
        qaener(2)=7
        aener(1,2)=4132.85
        aphot(1,2)=0.071
        aener(2,2)=6199.27
        aphot(2,2)=0.11
        aener(3,2)=8265.69
        aphot(3,2)=0.051
        aener(4,2)=12398.5
        aphot(4,2)=0.017
        aener(5,2)=15498.2
        aphot(5,2)=0.009
        aener(6,2)=20664.2
        aphot(6,2)=0.004
        aener(7,2)=30996.4
        aphot(7,2)=0.0013
        athreshold(3)=0.000827
        aweight(3)=0.411049
        qaener(3)=8
        aener(1,3)=619.927
        aphot(1,3)=0.63
        aener(2,3)=826.569
        aphot(2,3)=2.3
        aener(3,3)=1033.21
        aphot(3,3)=1.8
        aener(4,3)=1239.85
        aphot(4,3)=1.37
        aener(5,3)=1549.82
        aphot(5,3)=0.86
        aener(6,3)=2066.42
        aphot(6,3)=0.42
        aener(7,3)=3099.64
        aphot(7,3)=0.15
        aener(8,3)=4132.85
        aphot(8,3)=0.071
        athreshold(4)=0.00031
        aweight(4)=0.075061
        qaener(4)=4
        aener(1,4)=206.642
        aphot(1,4)=1
        aener(2,4)=309.964
        aphot(2,4)=1.15
        aener(3,4)=413.285
        aphot(3,4)=1
        aener(4,4)=619.927
        aphot(4,4)=0.63
        athreshold(5)=8.26569e-05
        aweight(5)=0.273675
        qaener(5)=6
        aener(1,5)=61.9927
        aphot(1,5)=0.67
        aener(2,5)=82.6569
        aphot(2,5)=48
        aener(3,5)=103.321
        aphot(3,5)=14
        aener(4,5)=123.985
        aphot(4,5)=2.5
        aener(5,5)=154.982
        aphot(5,5)=1.1
        aener(6,5)=206.642
        aphot(6,5)=1
        athreshold(6)=1.23985e-05
        aweight(6)=0.107866
        qaener(6)=9
        aener(1,6)=6.19927
        aphot(1,6)=0
        aener(2,6)=8.26569
        aphot(2,6)=0
        aener(3,6)=10.3321
        aphot(3,6)=0
        aener(4,6)=12.3985
        aphot(4,6)=110
        aener(5,6)=15.4982
        aphot(5,6)=37
        aener(6,6)=20.6642
        aphot(6,6)=10
        aener(7,6)=30.9964
        aphot(7,6)=2.2
        aener(8,6)=41.3285
        aphot(8,6)=1.1
        aener(9,6)=61.9927
        aphot(9,6)=0.67
        endif

c       end of computer code


        do k1=1,qash
        do l=1,qaener(k1)       


        aener(l,k1)=aener(l,k1)*1.e-6

        enddo
        enddo


        if(soo.eq.1)then
        if(qash.eq.0)then
        write(oo,*)' Worning of shellfi: atom z=',zato,' is not found.'
        write(oo,*)
     +  '  The data will be seached by shteor, accuracy will be lower.'

        endif
        endif

c       call prishellfi

        end


        subroutine shteor(num)

c       read shteor.dat

        implicit none

c       include 'shellfi.inc'
+SEQ,shellfi.
c       include 'LibAtMat.inc'
+SEQ,LibAtMat.

        integer num

c       character*1 a
c       integer i,z,n,k

        qash=0


c       The next code is generated
c       by a computer program
c       using a readable data file


        if(zato.eq.1)then
c               if(num.eq.num_H)then
                        qash=1
                        athreshold(1)=1e-05
                        aweight(1)=1
c               endif
                if(num.eq.num_H3)then   ! for CH4
                        qash=1
                        athreshold(1)=15.2e-06
                        aweight(1)=1
                endif
        endif
        if(zato.eq.2)then
        qash=1
        athreshold(1)=1.36129e-05
        aweight(1)=1
        endif
        if(zato.eq.3)then
        qash=2
        athreshold(1)=5.44515e-05
        aweight(1)=0.666667
        athreshold(2)=1e-05
        aweight(2)=0.333333
        endif
        if(zato.eq.4)then
        qash=2
        athreshold(1)=0.000123
        aweight(1)=0.5
        athreshold(2)=1e-05
        aweight(2)=0.5
        endif
        if(zato.eq.5)then
        qash=2
        athreshold(1)=0.000218
        aweight(1)=0.4
        athreshold(2)=1e-05
        aweight(2)=0.6
        endif
        if(zato.eq.6)then
        qash=2
        athreshold(1)=0.00034
        aweight(1)=0.333333
        athreshold(2)=1.36129e-05
        aweight(2)=0.666667
        endif
        if(zato.eq.7)then
        qash=2
        athreshold(1)=0.00049
        aweight(1)=0.285714
        athreshold(2)=2.12701e-05
        aweight(2)=0.714286
        endif
        if(zato.eq.8)then
        qash=2
        athreshold(1)=0.000667
        aweight(1)=0.25
        athreshold(2)=3.0629e-05
        aweight(2)=0.75
        endif
        if(zato.eq.9)then
        qash=2
        athreshold(1)=0.000871
        aweight(1)=0.222222
        athreshold(2)=4.16894e-05
        aweight(2)=0.777778
        endif
        if(zato.eq.10)then
        qash=2
        athreshold(1)=0.001103
        aweight(1)=0.2
        athreshold(2)=5.44515e-05
        aweight(2)=0.8
        endif
        if(zato.eq.11)then
        qash=3
        athreshold(1)=0.001361
        aweight(1)=0.181818
        athreshold(2)=8.50804e-05
        aweight(2)=0.727273
        athreshold(3)=1e-05
        aweight(3)=0.090909
        endif
        if(zato.eq.12)then
        qash=3
        athreshold(1)=0.001647
        aweight(1)=0.166667
        athreshold(2)=0.000123
        aweight(2)=0.666667
        athreshold(3)=1e-05
        aweight(3)=0.166667
        endif
        if(zato.eq.13)then
        qash=3
        athreshold(1)=0.00196
        aweight(1)=0.153846
        athreshold(2)=0.000167
        aweight(2)=0.615385
        athreshold(3)=1e-05
        aweight(3)=0.230769
        endif
        if(zato.eq.14)then
        qash=3
        athreshold(1)=0.002301
        aweight(1)=0.142857
        athreshold(2)=0.000218
        aweight(2)=0.571429
        athreshold(3)=1e-05
        aweight(3)=0.285714
        endif
        if(zato.eq.15)then
        qash=3
        athreshold(1)=0.002668
        aweight(1)=0.133333
        athreshold(2)=0.000276
        aweight(2)=0.533333
        athreshold(3)=1e-05
        aweight(3)=0.333333
        endif
        if(zato.eq.16)then
        qash=3
        athreshold(1)=0.003063
        aweight(1)=0.125
        athreshold(2)=0.00034
        aweight(2)=0.5
        athreshold(3)=1.36129e-05
        aweight(3)=0.375
        endif
        if(zato.eq.17)then
        qash=3
        athreshold(1)=0.003485
        aweight(1)=0.117647
        athreshold(2)=0.000412
        aweight(2)=0.470588
        athreshold(3)=1.85286e-05
        aweight(3)=0.411765
        endif
        if(zato.eq.18)then
        qash=3
        athreshold(1)=0.003934
        aweight(1)=0.111111
        athreshold(2)=0.00049
        aweight(2)=0.444444
        athreshold(3)=2.42007e-05
        aweight(3)=0.444444
        endif
        if(zato.eq.19)then
        qash=4
        athreshold(1)=0.004411
        aweight(1)=0.105263
        athreshold(2)=0.000575
        aweight(2)=0.421053
        athreshold(3)=3.78135e-05
        aweight(3)=0.421053
        athreshold(4)=1e-05
        aweight(4)=0.052632
        endif
        if(zato.eq.20)then
        qash=4
        athreshold(1)=0.004914
        aweight(1)=0.1
        athreshold(2)=0.000667
        aweight(2)=0.4
        athreshold(3)=5.44515e-05
        aweight(3)=0.4
        athreshold(4)=1e-05
        aweight(4)=0.1
        endif
        if(zato.eq.21)then
        qash=4
        athreshold(1)=0.005445
        aweight(1)=0.095238
        athreshold(2)=0.000766
        aweight(2)=0.380952
        athreshold(3)=7.41145e-05
        aweight(3)=0.380952
        athreshold(4)=1e-05
        aweight(4)=0.142857
        endif
        if(zato.eq.22)then
        qash=4
        athreshold(1)=0.006003
        aweight(1)=0.090909
        athreshold(2)=0.000871
        aweight(2)=0.363636
        athreshold(3)=9.68026e-05
        aweight(3)=0.363636
        athreshold(4)=1e-05
        aweight(4)=0.181818
        endif
        if(zato.eq.23)then
        qash=4
        athreshold(1)=0.006589
        aweight(1)=0.086957
        athreshold(2)=0.000984
        aweight(2)=0.347826
        athreshold(3)=0.000123
        aweight(3)=0.347826
        athreshold(4)=1e-05
        aweight(4)=0.217391
        endif
        if(zato.eq.24)then
        qash=4
        athreshold(1)=0.007201
        aweight(1)=0.083333
        athreshold(2)=0.001103
        aweight(2)=0.333333
        athreshold(3)=0.000151
        aweight(3)=0.333333
        athreshold(4)=1e-05
        aweight(4)=0.25
        endif
        if(zato.eq.25)then
        qash=4
        athreshold(1)=0.007841
        aweight(1)=0.08
        athreshold(2)=0.001229
        aweight(2)=0.32
        athreshold(3)=0.000183
        aweight(3)=0.32
        athreshold(4)=1.04224e-05
        aweight(4)=0.28
        endif
        if(zato.eq.26)then
        qash=4
        athreshold(1)=0.008508
        aweight(1)=0.076923
        athreshold(2)=0.001361
        aweight(2)=0.307692
        athreshold(3)=0.000218
        aweight(3)=0.307692
        athreshold(4)=1.36129e-05
        aweight(4)=0.307692
        endif
        if(zato.eq.27)then
        qash=4
        athreshold(1)=0.009202
        aweight(1)=0.074074
        athreshold(2)=0.001501
        aweight(2)=0.296296
        athreshold(3)=0.000256
        aweight(3)=0.296296
        athreshold(4)=1.72288e-05
        aweight(4)=0.333333
        endif
        if(zato.eq.28)then
        qash=4
        athreshold(1)=0.009924
        aweight(1)=0.071429
        athreshold(2)=0.001647
        aweight(2)=0.285714
        athreshold(3)=0.000296
        aweight(3)=0.285714
        athreshold(4)=2.12701e-05
        aweight(4)=0.357143
        endif
        if(zato.eq.29)then
        qash=4
        athreshold(1)=0.010672
        aweight(1)=0.068966
        athreshold(2)=0.0018
        aweight(2)=0.275862
        athreshold(3)=0.00034
        aweight(3)=0.275862
        athreshold(4)=2.57368e-05
        aweight(4)=0.37931
        endif
        if(zato.eq.30)then
        qash=4
        athreshold(1)=0.011448
        aweight(1)=0.066667
        athreshold(2)=0.00196
        aweight(2)=0.266667
        athreshold(3)=0.000387
        aweight(3)=0.266667
        athreshold(4)=3.0629e-05
        aweight(4)=0.4
        endif
        if(zato.eq.31)then
        qash=4
        athreshold(1)=0.012252
        aweight(1)=0.064516
        athreshold(2)=0.002127
        aweight(2)=0.258065
        athreshold(3)=0.000437
        aweight(3)=0.258065
        athreshold(4)=3.59465e-05
        aweight(4)=0.419355
        endif
        if(zato.eq.32)then
        qash=4
        athreshold(1)=0.013082
        aweight(1)=0.0625
        athreshold(2)=0.002301
        aweight(2)=0.25
        athreshold(3)=0.00049
        aweight(3)=0.25
        athreshold(4)=4.16894e-05
        aweight(4)=0.4375
        endif
        if(zato.eq.33)then
        qash=4
        athreshold(1)=0.01394
        aweight(1)=0.060606
        athreshold(2)=0.002481
        aweight(2)=0.242424
        athreshold(3)=0.000546
        aweight(3)=0.242424
        athreshold(4)=4.78577e-05
        aweight(4)=0.454545
        endif
        if(zato.eq.34)then
        qash=4
        athreshold(1)=0.014824
        aweight(1)=0.058824
        athreshold(2)=0.002668
        aweight(2)=0.235294
        athreshold(3)=0.000605
        aweight(3)=0.235294
        athreshold(4)=5.44515e-05
        aweight(4)=0.470588
        endif
        if(zato.eq.35)then
        qash=4
        athreshold(1)=0.015736
        aweight(1)=0.057143
        athreshold(2)=0.002862
        aweight(2)=0.228571
        athreshold(3)=0.000667
        aweight(3)=0.228571
        athreshold(4)=6.14706e-05
        aweight(4)=0.485714
        endif
        if(zato.eq.36)then
        qash=4
        athreshold(1)=0.016676
        aweight(1)=0.055556
        athreshold(2)=0.003063
        aweight(2)=0.222222
        athreshold(3)=0.000732
        aweight(3)=0.222222
        athreshold(4)=6.89152e-05
        aweight(4)=0.5
        endif
        if(zato.eq.37)then
        qash=5
        athreshold(1)=0.017642
        aweight(1)=0.054054
        athreshold(2)=0.00327
        aweight(2)=0.216216
        athreshold(3)=0.0008
        aweight(3)=0.216216
        athreshold(4)=8.50804e-05
        aweight(4)=0.486486
        athreshold(5)=1e-05
        aweight(5)=0.027027
        endif
        if(zato.eq.38)then
        qash=5
        athreshold(1)=0.018636
        aweight(1)=0.052632
        athreshold(2)=0.003485
        aweight(2)=0.210526
        athreshold(3)=0.000871
        aweight(3)=0.210526
        athreshold(4)=0.000103
        aweight(4)=0.473684
        athreshold(5)=1e-05
        aweight(5)=0.052632
        endif
        if(zato.eq.39)then
        qash=5
        athreshold(1)=0.019657
        aweight(1)=0.051282
        athreshold(2)=0.003706
        aweight(2)=0.205128
        athreshold(3)=0.000945
        aweight(3)=0.205128
        athreshold(4)=0.000123
        aweight(4)=0.461538
        athreshold(5)=1e-05
        aweight(5)=0.076923
        endif
        if(zato.eq.40)then
        qash=5
        athreshold(1)=0.020705
        aweight(1)=0.05
        athreshold(2)=0.003934
        aweight(2)=0.2
        athreshold(3)=0.001022
        aweight(3)=0.2
        athreshold(4)=0.000144
        aweight(4)=0.45
        athreshold(5)=1e-05
        aweight(5)=0.1
        endif
        if(zato.eq.41)then
        qash=5
        athreshold(1)=0.021781
        aweight(1)=0.04878
        athreshold(2)=0.004169
        aweight(2)=0.195122
        athreshold(3)=0.001103
        aweight(3)=0.195122
        athreshold(4)=0.000167
        aweight(4)=0.439024
        athreshold(5)=1e-05
        aweight(5)=0.121951
        endif
        if(zato.eq.42)then
        qash=5
        athreshold(1)=0.022883
        aweight(1)=0.047619
        athreshold(2)=0.004411
        aweight(2)=0.190476
        athreshold(3)=0.001186
        aweight(3)=0.190476
        athreshold(4)=0.000191
        aweight(4)=0.428571
        athreshold(5)=1e-05
        aweight(5)=0.142857
        endif
        if(zato.eq.43)then
        qash=5
        athreshold(1)=0.024013
        aweight(1)=0.046512
        athreshold(2)=0.004659
        aweight(2)=0.186047
        athreshold(3)=0.001272
        aweight(3)=0.186047
        athreshold(4)=0.000218
        aweight(4)=0.418605
        athreshold(5)=1e-05
        aweight(5)=0.162791
        endif
        if(zato.eq.44)then
        qash=5
        athreshold(1)=0.02517
        aweight(1)=0.045455
        athreshold(2)=0.004914
        aweight(2)=0.181818
        athreshold(3)=0.001361
        aweight(3)=0.181818
        athreshold(4)=0.000246
        aweight(4)=0.409091
        athreshold(5)=1e-05
        aweight(5)=0.181818
        endif
        if(zato.eq.45)then
        qash=5
        athreshold(1)=0.026355
        aweight(1)=0.044444
        athreshold(2)=0.005176
        aweight(2)=0.177778
        athreshold(3)=0.001454
        aweight(3)=0.177778
        athreshold(4)=0.000276
        aweight(4)=0.4
        athreshold(5)=1.10264e-05
        aweight(5)=0.2
        endif
        if(zato.eq.46)then
        qash=5
        athreshold(1)=0.027566
        aweight(1)=0.043478
        athreshold(2)=0.005445
        aweight(2)=0.173913
        athreshold(3)=0.001549
        aweight(3)=0.173913
        athreshold(4)=0.000307
        aweight(4)=0.391304
        athreshold(5)=1.36129e-05
        aweight(5)=0.217391
        endif
        if(zato.eq.47)then
        qash=5
        athreshold(1)=0.028805
        aweight(1)=0.042553
        athreshold(2)=0.005721
        aweight(2)=0.170213
        athreshold(3)=0.001647
        aweight(3)=0.170213
        athreshold(4)=0.00034
        aweight(4)=0.382979
        athreshold(5)=1.64716e-05
        aweight(5)=0.234043
        endif
        if(zato.eq.48)then
        qash=5
        athreshold(1)=0.030071
        aweight(1)=0.041667
        athreshold(2)=0.006003
        aweight(2)=0.166667
        athreshold(3)=0.001748
        aweight(3)=0.166667
        athreshold(4)=0.000375
        aweight(4)=0.375
        athreshold(5)=1.96025e-05
        aweight(5)=0.25
        endif
        if(zato.eq.49)then
        qash=5
        athreshold(1)=0.031364
        aweight(1)=0.040816
        athreshold(2)=0.006293
        aweight(2)=0.163265
        athreshold(3)=0.001853
        aweight(3)=0.163265
        athreshold(4)=0.000412
        aweight(4)=0.367347
        athreshold(5)=2.30058e-05
        aweight(5)=0.265306
        endif
        if(zato.eq.50)then
        qash=5
        athreshold(1)=0.032685
        aweight(1)=0.04
        athreshold(2)=0.006589
        aweight(2)=0.16
        athreshold(3)=0.00196
        aweight(3)=0.16
        athreshold(4)=0.00045
        aweight(4)=0.36
        athreshold(5)=2.66812e-05
        aweight(5)=0.28
        endif
        if(zato.eq.51)then
        qash=5
        athreshold(1)=0.034032
        aweight(1)=0.039216
        athreshold(2)=0.006892
        aweight(2)=0.156863
        athreshold(3)=0.002071
        aweight(3)=0.156863
        athreshold(4)=0.00049
        aweight(4)=0.352941
        athreshold(5)=3.0629e-05
        aweight(5)=0.294118
        endif
        if(zato.eq.52)then
        qash=5
        athreshold(1)=0.035407
        aweight(1)=0.038462
        athreshold(2)=0.007201
        aweight(2)=0.153846
        athreshold(3)=0.002184
        aweight(3)=0.153846
        athreshold(4)=0.000532
        aweight(4)=0.346154
        athreshold(5)=3.48489e-05
        aweight(5)=0.307692
        endif
        if(zato.eq.53)then
        qash=5
        athreshold(1)=0.036809
        aweight(1)=0.037736
        athreshold(2)=0.007518
        aweight(2)=0.150943
        athreshold(3)=0.002301
        aweight(3)=0.150943
        athreshold(4)=0.000575
        aweight(4)=0.339623
        athreshold(5)=3.93412e-05
        aweight(5)=0.320755
        endif
        if(zato.eq.54)then
        qash=5
        athreshold(1)=0.038239
        aweight(1)=0.037037
        athreshold(2)=0.007841
        aweight(2)=0.148148
        athreshold(3)=0.00242
        aweight(3)=0.148148
        athreshold(4)=0.00062
        aweight(4)=0.333333
        athreshold(5)=4.41057e-05
        aweight(5)=0.333333
        endif
        if(zato.eq.55)then
        qash=5
        athreshold(1)=0.039695
        aweight(1)=0.036364
        athreshold(2)=0.008171
        aweight(2)=0.145455
        athreshold(3)=0.002543
        aweight(3)=0.145455
        athreshold(4)=0.000667
        aweight(4)=0.327273
        athreshold(5)=4.91425e-05
        aweight(5)=0.345455
        endif
        if(zato.eq.56)then
        qash=5
        athreshold(1)=0.041179
        aweight(1)=0.035714
        athreshold(2)=0.008508
        aweight(2)=0.142857
        athreshold(3)=0.002668
        aweight(3)=0.142857
        athreshold(4)=0.000716
        aweight(4)=0.321429
        athreshold(5)=5.44515e-05
        aweight(5)=0.357143
        endif
        if(zato.eq.57)then
        qash=5
        athreshold(1)=0.04269
        aweight(1)=0.035088
        athreshold(2)=0.008852
        aweight(2)=0.140351
        athreshold(3)=0.002797
        aweight(3)=0.140351
        athreshold(4)=0.000766
        aweight(4)=0.315789
        athreshold(5)=6.00328e-05
        aweight(5)=0.368421
        endif
        if(zato.eq.58)then
        qash=5
        athreshold(1)=0.044228
        aweight(1)=0.034483
        athreshold(2)=0.009202
        aweight(2)=0.137931
        athreshold(3)=0.002928
        aweight(3)=0.137931
        athreshold(4)=0.000818
        aweight(4)=0.310345
        athreshold(5)=6.58863e-05
        aweight(5)=0.37931
        endif
        if(zato.eq.59)then
        qash=6
        athreshold(1)=0.045794
        aweight(1)=0.033898
        athreshold(2)=0.00956
        aweight(2)=0.135593
        athreshold(3)=0.003063
        aweight(3)=0.135593
        athreshold(4)=0.000871
        aweight(4)=0.305085
        athreshold(5)=7.84101e-05
        aweight(5)=0.372881
        athreshold(6)=1e-05
        aweight(6)=0.016949
        endif
        if(zato.eq.60)then
        qash=6
        athreshold(1)=0.047386
        aweight(1)=0.033333
        athreshold(2)=0.009924
        aweight(2)=0.133333
        athreshold(3)=0.003201
        aweight(3)=0.133333
        athreshold(4)=0.000927
        aweight(4)=0.3
        athreshold(5)=9.2023e-05
        aweight(5)=0.366667
        athreshold(6)=1e-05
        aweight(6)=0.033333
        endif
        if(zato.eq.61)then
        qash=6
        athreshold(1)=0.049006
        aweight(1)=0.032787
        athreshold(2)=0.010295
        aweight(2)=0.131148
        athreshold(3)=0.003341
        aweight(3)=0.131148
        athreshold(4)=0.000984
        aweight(4)=0.295082
        athreshold(5)=0.000107
        aweight(5)=0.360656
        athreshold(6)=1e-05
        aweight(6)=0.04918
        endif
        if(zato.eq.62)then
        qash=6
        athreshold(1)=0.050653
        aweight(1)=0.032258
        athreshold(2)=0.010672
        aweight(2)=0.129032
        athreshold(3)=0.003485
        aweight(3)=0.129032
        athreshold(4)=0.001042
        aweight(4)=0.290323
        athreshold(5)=0.000123
        aweight(5)=0.354839
        athreshold(6)=1e-05
        aweight(6)=0.064516
        endif
        if(zato.eq.63)then
        qash=6
        athreshold(1)=0.052328
        aweight(1)=0.031746
        athreshold(2)=0.011057
        aweight(2)=0.126984
        athreshold(3)=0.003632
        aweight(3)=0.126984
        athreshold(4)=0.001103
        aweight(4)=0.285714
        athreshold(5)=0.000139
        aweight(5)=0.349206
        athreshold(6)=1e-05
        aweight(6)=0.079365
        endif
        if(zato.eq.64)then
        qash=6
        athreshold(1)=0.054029
        aweight(1)=0.03125
        athreshold(2)=0.011448
        aweight(2)=0.125
        athreshold(3)=0.003781
        aweight(3)=0.125
        athreshold(4)=0.001165
        aweight(4)=0.28125
        athreshold(5)=0.000157
        aweight(5)=0.34375
        athreshold(6)=1e-05
        aweight(6)=0.09375
        endif
        if(zato.eq.65)then
        qash=6
        athreshold(1)=0.055758
        aweight(1)=0.030769
        athreshold(2)=0.011847
        aweight(2)=0.123077
        athreshold(3)=0.003934
        aweight(3)=0.123077
        athreshold(4)=0.001229
        aweight(4)=0.276923
        athreshold(5)=0.000176
        aweight(5)=0.338462
        athreshold(6)=1e-05
        aweight(6)=0.107692
        endif
        if(zato.eq.66)then
        qash=6
        athreshold(1)=0.057514
        aweight(1)=0.030303
        athreshold(2)=0.012252
        aweight(2)=0.121212
        athreshold(3)=0.00409
        aweight(3)=0.121212
        athreshold(4)=0.001294
        aweight(4)=0.272727
        athreshold(5)=0.000197
        aweight(5)=0.333333
        athreshold(6)=1e-05
        aweight(6)=0.121212
        endif
        if(zato.eq.67)then
        qash=6
        athreshold(1)=0.059298
        aweight(1)=0.029851
        athreshold(2)=0.012663
        aweight(2)=0.119403
        athreshold(3)=0.004249
        aweight(3)=0.119403
        athreshold(4)=0.001361
        aweight(4)=0.268657
        athreshold(5)=0.000218
        aweight(5)=0.328358
        athreshold(6)=1e-05
        aweight(6)=0.134328
        endif
        if(zato.eq.68)then
        qash=6
        athreshold(1)=0.061108
        aweight(1)=0.029412
        athreshold(2)=0.013082
        aweight(2)=0.117647
        athreshold(3)=0.004411
        aweight(3)=0.117647
        athreshold(4)=0.00143
        aweight(4)=0.264706
        athreshold(5)=0.00024
        aweight(5)=0.323529
        athreshold(6)=1e-05
        aweight(6)=0.147059
        endif
        if(zato.eq.69)then
        qash=6
        athreshold(1)=0.062946
        aweight(1)=0.028986
        athreshold(2)=0.013507
        aweight(2)=0.115942
        athreshold(3)=0.004575
        aweight(3)=0.115942
        athreshold(4)=0.001501
        aweight(4)=0.26087
        athreshold(5)=0.000264
        aweight(5)=0.318841
        athreshold(6)=1.14386e-05
        aweight(6)=0.15942
        endif
        if(zato.eq.70)then
        qash=6
        athreshold(1)=0.064811
        aweight(1)=0.028571
        athreshold(2)=0.01394
        aweight(2)=0.114286
        athreshold(3)=0.004743
        aweight(3)=0.114286
        athreshold(4)=0.001573
        aweight(4)=0.257143
        athreshold(5)=0.000288
        aweight(5)=0.314286
        athreshold(6)=1.36129e-05
        aweight(6)=0.171429
        endif
        if(zato.eq.71)then
        qash=6
        athreshold(1)=0.066703
        aweight(1)=0.028169
        athreshold(2)=0.014379
        aweight(2)=0.112676
        athreshold(3)=0.004914
        aweight(3)=0.112676
        athreshold(4)=0.001647
        aweight(4)=0.253521
        athreshold(5)=0.000314
        aweight(5)=0.309859
        athreshold(6)=1.59762e-05
        aweight(6)=0.183099
        endif
        if(zato.eq.72)then
        qash=6
        athreshold(1)=0.068622
        aweight(1)=0.027778
        athreshold(2)=0.014824
        aweight(2)=0.111111
        athreshold(3)=0.005088
        aweight(3)=0.111111
        athreshold(4)=0.001723
        aweight(4)=0.25
        athreshold(5)=0.00034
        aweight(5)=0.305556
        athreshold(6)=1.85286e-05
        aweight(6)=0.194444
        endif
        if(zato.eq.73)then
        qash=6
        athreshold(1)=0.070569
        aweight(1)=0.027397
        athreshold(2)=0.015277
        aweight(2)=0.109589
        athreshold(3)=0.005265
        aweight(3)=0.109589
        athreshold(4)=0.0018
        aweight(4)=0.246575
        athreshold(5)=0.000368
        aweight(5)=0.30137
        athreshold(6)=2.12701e-05
        aweight(6)=0.205479
        endif
        if(zato.eq.74)then
        qash=6
        athreshold(1)=0.072543
        aweight(1)=0.027027
        athreshold(2)=0.015736
        aweight(2)=0.108108
        athreshold(3)=0.005445
        aweight(3)=0.108108
        athreshold(4)=0.001879
        aweight(4)=0.243243
        athreshold(5)=0.000397
        aweight(5)=0.297297
        athreshold(6)=2.42007e-05
        aweight(6)=0.216216
        endif
        if(zato.eq.75)then
        qash=6
        athreshold(1)=0.074544
        aweight(1)=0.026667
        athreshold(2)=0.016203
        aweight(2)=0.106667
        athreshold(3)=0.005628
        aweight(3)=0.106667
        athreshold(4)=0.00196
        aweight(4)=0.24
        athreshold(5)=0.000427
        aweight(5)=0.293333
        athreshold(6)=2.73203e-05
        aweight(6)=0.226667
        endif
        if(zato.eq.76)then
        qash=6
        athreshold(1)=0.076572
        aweight(1)=0.026316
        athreshold(2)=0.016676
        aweight(2)=0.105263
        athreshold(3)=0.005814
        aweight(3)=0.105263
        athreshold(4)=0.002043
        aweight(4)=0.236842
        athreshold(5)=0.000458
        aweight(5)=0.289474
        athreshold(6)=3.0629e-05
        aweight(6)=0.236842
        endif
        if(zato.eq.77)then
        qash=6
        athreshold(1)=0.078628
        aweight(1)=0.025974
        athreshold(2)=0.017156
        aweight(2)=0.103896
        athreshold(3)=0.006003
        aweight(3)=0.103896
        athreshold(4)=0.002127
        aweight(4)=0.233766
        athreshold(5)=0.00049
        aweight(5)=0.285714
        athreshold(6)=3.41267e-05
        aweight(6)=0.246753
        endif
        if(zato.eq.78)then
        qash=6
        athreshold(1)=0.080711
        aweight(1)=0.025641
        athreshold(2)=0.017642
        aweight(2)=0.102564
        athreshold(3)=0.006195
        aweight(3)=0.102564
        athreshold(4)=0.002213
        aweight(4)=0.230769
        athreshold(5)=0.000523
        aweight(5)=0.282051
        athreshold(6)=3.78135e-05
        aweight(6)=0.25641
        endif
        if(zato.eq.79)then
        qash=6
        athreshold(1)=0.082821
        aweight(1)=0.025316
        athreshold(2)=0.018136
        aweight(2)=0.101266
        athreshold(3)=0.00639
        aweight(3)=0.101266
        athreshold(4)=0.002301
        aweight(4)=0.227848
        athreshold(5)=0.000558
        aweight(5)=0.278481
        athreshold(6)=4.16894e-05
        aweight(6)=0.265823
        endif
        if(zato.eq.80)then
        qash=6
        athreshold(1)=0.084958
        aweight(1)=0.025
        athreshold(2)=0.018636
        aweight(2)=0.1
        athreshold(3)=0.006589
        aweight(3)=0.1
        athreshold(4)=0.00239
        aweight(4)=0.225
        athreshold(5)=0.000593
        aweight(5)=0.275
        athreshold(6)=4.57544e-05
        aweight(6)=0.275
        endif
        if(zato.eq.81)then
        qash=6
        athreshold(1)=0.087122
        aweight(1)=0.024691
        athreshold(2)=0.019143
        aweight(2)=0.098765
        athreshold(3)=0.00679
        aweight(3)=0.098765
        athreshold(4)=0.002481
        aweight(4)=0.222222
        athreshold(5)=0.000629
        aweight(5)=0.271605
        athreshold(6)=5.00084e-05
        aweight(6)=0.283951
        endif
        if(zato.eq.82)then
        qash=6
        athreshold(1)=0.089314
        aweight(1)=0.02439
        athreshold(2)=0.019657
        aweight(2)=0.097561
        athreshold(3)=0.006994
        aweight(3)=0.097561
        athreshold(4)=0.002574
        aweight(4)=0.219512
        athreshold(5)=0.000667
        aweight(5)=0.268293
        athreshold(6)=5.44515e-05
        aweight(6)=0.292683
        endif
        if(zato.eq.83)then
        qash=6
        athreshold(1)=0.091533
        aweight(1)=0.024096
        athreshold(2)=0.020178
        aweight(2)=0.096386
        athreshold(3)=0.007201
        aweight(3)=0.096386
        athreshold(4)=0.002668
        aweight(4)=0.216867
        athreshold(5)=0.000706
        aweight(5)=0.26506
        athreshold(6)=5.90836e-05
        aweight(6)=0.301205
        endif
        if(zato.eq.84)then
        qash=6
        athreshold(1)=0.093779
        aweight(1)=0.02381
        athreshold(2)=0.020705
        aweight(2)=0.095238
        athreshold(3)=0.007411
        aweight(3)=0.095238
        athreshold(4)=0.002764
        aweight(4)=0.214286
        athreshold(5)=0.000745
        aweight(5)=0.261905
        athreshold(6)=6.39049e-05
        aweight(6)=0.309524
        endif
        if(zato.eq.85)then
        qash=6
        athreshold(1)=0.096052
        aweight(1)=0.023529
        athreshold(2)=0.021239
        aweight(2)=0.094118
        athreshold(3)=0.007625
        aweight(3)=0.094118
        athreshold(4)=0.002862
        aweight(4)=0.211765
        athreshold(5)=0.000786
        aweight(5)=0.258824
        athreshold(6)=6.89152e-05
        aweight(6)=0.317647
        endif
        if(zato.eq.86)then
        qash=6
        athreshold(1)=0.098353
        aweight(1)=0.023256
        athreshold(2)=0.021781
        aweight(2)=0.093023
        athreshold(3)=0.007841
        aweight(3)=0.093023
        athreshold(4)=0.002962
        aweight(4)=0.209302
        athreshold(5)=0.000828
        aweight(5)=0.255814
        athreshold(6)=7.41145e-05
        aweight(6)=0.325581
        endif
        if(zato.eq.87)then
        qash=6
        athreshold(1)=0.100681
        aweight(1)=0.022989
        athreshold(2)=0.022329
        aweight(2)=0.091954
        athreshold(3)=0.00806
        aweight(3)=0.091954
        athreshold(4)=0.003063
        aweight(4)=0.206897
        athreshold(5)=0.000871
        aweight(5)=0.252874
        athreshold(6)=7.9503e-05
        aweight(6)=0.333333
        endif
        if(zato.eq.88)then
        qash=6
        athreshold(1)=0.103036
        aweight(1)=0.022727
        athreshold(2)=0.022883
        aweight(2)=0.090909
        athreshold(3)=0.008283
        aweight(3)=0.090909
        athreshold(4)=0.003166
        aweight(4)=0.204545
        athreshold(5)=0.000915
        aweight(5)=0.25
        athreshold(6)=8.50804e-05
        aweight(6)=0.340909
        endif
        if(zato.eq.89)then
        qash=6
        athreshold(1)=0.105418
        aweight(1)=0.022472
        athreshold(2)=0.023445
        aweight(2)=0.089888
        athreshold(3)=0.008508
        aweight(3)=0.089888
        athreshold(4)=0.00327
        aweight(4)=0.202247
        athreshold(5)=0.000961
        aweight(5)=0.247191
        athreshold(6)=9.0847e-05
        aweight(6)=0.348315
        endif
        if(zato.eq.90)then
        qash=6
        athreshold(1)=0.107828
        aweight(1)=0.022222
        athreshold(2)=0.024013
        aweight(2)=0.088889
        athreshold(3)=0.008736
        aweight(3)=0.088889
        athreshold(4)=0.003377
        aweight(4)=0.2
        athreshold(5)=0.001007
        aweight(5)=0.244444
        athreshold(6)=9.68026e-05
        aweight(6)=0.355556
        endif
        if(zato.eq.91)then
        qash=7
        athreshold(1)=0.110264
        aweight(1)=0.021978
        athreshold(2)=0.024588
        aweight(2)=0.087912
        athreshold(3)=0.008968
        aweight(3)=0.087912
        athreshold(4)=0.003485
        aweight(4)=0.197802
        athreshold(5)=0.001054
        aweight(5)=0.241758
        athreshold(6)=0.000109
        aweight(6)=0.351648
        athreshold(7)=1e-05
        aweight(7)=0.010989
        endif
        if(zato.eq.92)then
        qash=7
        athreshold(1)=0.112728
        aweight(1)=0.021739
        athreshold(2)=0.02517
        aweight(2)=0.086957
        athreshold(3)=0.009202
        aweight(3)=0.086957
        athreshold(4)=0.003595
        aweight(4)=0.195652
        athreshold(5)=0.001103
        aweight(5)=0.23913
        athreshold(6)=0.000123
        aweight(6)=0.347826
        athreshold(7)=1e-05
        aweight(7)=0.021739
        endif
        if(zato.eq.93)then
        qash=7
        athreshold(1)=0.115219
        aweight(1)=0.021505
        athreshold(2)=0.025759
        aweight(2)=0.086022
        athreshold(3)=0.00944
        aweight(3)=0.086022
        athreshold(4)=0.003706
        aweight(4)=0.193548
        athreshold(5)=0.001152
        aweight(5)=0.236559
        athreshold(6)=0.000137
        aweight(6)=0.344086
        athreshold(7)=1e-05
        aweight(7)=0.032258
        endif
        if(zato.eq.94)then
        qash=7
        athreshold(1)=0.117738
        aweight(1)=0.021277
        athreshold(2)=0.026355
        aweight(2)=0.085106
        athreshold(3)=0.00968
        aweight(3)=0.085106
        athreshold(4)=0.003819
        aweight(4)=0.191489
        athreshold(5)=0.001203
        aweight(5)=0.234043
        athreshold(6)=0.000151
        aweight(6)=0.340426
        athreshold(7)=1e-05
        aweight(7)=0.042553
        endif
        if(zato.eq.95)then
        qash=7
        athreshold(1)=0.120283
        aweight(1)=0.021053
        athreshold(2)=0.026957
        aweight(2)=0.084211
        athreshold(3)=0.009924
        aweight(3)=0.084211
        athreshold(4)=0.003934
        aweight(4)=0.189474
        athreshold(5)=0.001255
        aweight(5)=0.231579
        athreshold(6)=0.000167
        aweight(6)=0.336842
        athreshold(7)=1e-05
        aweight(7)=0.052632
        endif
        if(zato.eq.96)then
        qash=7
        athreshold(1)=0.122856
        aweight(1)=0.020833
        athreshold(2)=0.027566
        aweight(2)=0.083333
        athreshold(3)=0.01017
        aweight(3)=0.083333
        athreshold(4)=0.004051
        aweight(4)=0.1875
        athreshold(5)=0.001307
        aweight(5)=0.229167
        athreshold(6)=0.000183
        aweight(6)=0.333333
        athreshold(7)=1e-05
        aweight(7)=0.0625
        endif
        if(zato.eq.97)then
        qash=7
        athreshold(1)=0.125456
        aweight(1)=0.020619
        athreshold(2)=0.028182
        aweight(2)=0.082474
        athreshold(3)=0.01042
        aweight(3)=0.082474
        athreshold(4)=0.004169
        aweight(4)=0.185567
        athreshold(5)=0.001361
        aweight(5)=0.226804
        athreshold(6)=0.0002
        aweight(6)=0.329897
        athreshold(7)=1e-05
        aweight(7)=0.072165
        endif
        if(zato.eq.98)then
        qash=7
        athreshold(1)=0.128084
        aweight(1)=0.020408
        athreshold(2)=0.028805
        aweight(2)=0.081633
        athreshold(3)=0.010672
        aweight(3)=0.081633
        athreshold(4)=0.004289
        aweight(4)=0.183673
        athreshold(5)=0.001416
        aweight(5)=0.22449
        athreshold(6)=0.000218
        aweight(6)=0.326531
        athreshold(7)=1e-05
        aweight(7)=0.081633
        endif
        if(zato.eq.99)then
        qash=7
        athreshold(1)=0.130738
        aweight(1)=0.020202
        athreshold(2)=0.029434
        aweight(2)=0.080808
        athreshold(3)=0.010928
        aweight(3)=0.080808
        athreshold(4)=0.004411
        aweight(4)=0.181818
        athreshold(5)=0.001472
        aweight(5)=0.222222
        athreshold(6)=0.000236
        aweight(6)=0.323232
        athreshold(7)=1e-05
        aweight(7)=0.090909
        endif
        if(zato.eq.100)then
        qash=7
        athreshold(1)=0.13342
        aweight(1)=0.02
        athreshold(2)=0.030071
        aweight(2)=0.08
        athreshold(3)=0.011187
        aweight(3)=0.08
        athreshold(4)=0.004534
        aweight(4)=0.18
        athreshold(5)=0.00153
        aweight(5)=0.22
        athreshold(6)=0.000256
        aweight(6)=0.32
        athreshold(7)=1e-05
        aweight(7)=0.1
        endif


c       end of genetared code


c       call prishellfi

        end


        subroutine prishellfi

        implicit none

c         include 'GoEvent.inc'
+SEQ,GoEvent.
c       include 'shellfi.inc'
+SEQ,shellfi.

        integer i,j

        if(soo.eq.0)return
        write(oo,*)
        write(oo,*)' prishellfi:'
        write(oo,*)' zato=',zato,' qash=',qash
        do i=1,qash
        write(oo,*)' number of shell=',i
        write(oo,*)' aweight=',aweight(i),' athreshold=',athreshold(i),
     +          ' qaener=',qaener(i)
        write(oo,*)'   aener           aphot'
        do j=1,qaener(i)
                write(oo,*)aener(j,i),aphot(j,i)
        enddo
        enddo

        end
                                
+DECK,line.
c       Package for integration and interpolation
c       of a function, defined by array.


        function glin_integ_ar(x,y,q,x1,x2,thresh)
c
c       It makes the same work as lin_integ_ar
c       but at some conditions it interpolates no the line
c       but power function.
c

        implicit none
        real glin_integ_ar
        real x(*),y(*),x1,x2,thresh
        integer q
        
        integer nr,nrr,n1,i
        real xt1,xt2
        real xr1,xr2
        real a,b
        real k,p
        real s
        s=0
        glin_integ_ar=0.0
        if(q.le.0)return
        if(x2.lt.x1 .or. x2.lt.x(1) .or. x1.gt.x(q))return

        if(x1.lt.x(1))then
                xt1=x(1)
        else
                xt1=x1
        endif
        do i=2,q
                if(x(i).gt.xt1)then
                        n1=i
                        goto 10
                endif
        enddo
10      continue
        nr=n1-1 
        if(x2.gt.x(q))then      ! it is not necessary
                xt2=x(q)
        else
                xt2=x2
        endif
        xr2=xt1
c       write(6,*)' x1=',x1,' x2=',x2,' xt1=',xt1,' xt2=',xt2
c       write(6,*)' n1=',n1,' n2=',n2,' n1=',n1,' nr=',nr
        do nrr=nr,q-1
                if(x(nrr).gt.x2)go to 20
                xr1=xr2
                if(xt2.lt.x(nrr+1))then
                        xr2=xt2
                else
                        xr2=x(nrr+1)
                endif
                if(x(nrr).gt.500.0e-6.and.x(nrr).gt.2*thresh.and.
     +          y(nrr+1).lt.y(nrr).and.y(nrr+1).gt.0.0)then
                        p=dlog(dble(y(nrr))/y(nrr+1))/
     +                    dlog(dble(x(nrr+1))/x(nrr))
                        k=y(nrr)*x(nrr)**p
                        s=s+
     +                  k/(1-p)*(1.0/xr2**(p-1)-1.0/xr1**(p-1))
c               write(6,*)' nrr=',nrr,' p=',p,' k=',k,' s=',s   
                else    
                a = (y(nrr+1) - y(nrr))/(x(nrr+1) - x(nrr))             
                b = y(nrr)                                                    
                s = s+ 
     +          0.5*a*(xr2*xr2 - xr1*xr1) + (b - a*x(nrr))*(xr2 - xr1)    
                endif
c               write(6,*)' nrr=',nrr
c               write(6,*)' y(nrr)=',y(nrr),' y(nrr+1)=',y(nrr+1)
c               write(6,*)' xr1=',xr1,' xr2=',xr2
c               write(6,*)' x(nrr)=',x(nrr),' x(nrr+1)=',x(nrr+1)
c               write(6,*)' s=',s
        enddo

20      glin_integ_ar=s

        end

        function lin_integ_ar(x,y,q,x1,x2)

        implicit none
        real lin_integ_ar
        real x(*),y(*),x1,x2
        integer q
        
        integer nr,nrr,n1,i
        real xt1,xt2
        real xr1,xr2
        real a,b
        real s
        s=0
        lin_integ_ar=0.0
        if(q.le.0)return
        if(x2.lt.x1 .or. x2.lt.x(1) .or. x1.gt.x(q))return

        if(x1.lt.x(1))then
                xt1=x(1)
        else
                xt1=x1
        endif
        do i=2,q
                if(x(i).gt.xt1)then
                        n1=i
                        goto 10
                endif
        enddo
10      continue
        nr=n1-1
        if(x2.gt.x(q))then      ! it is not necessary
                xt2=x(q)
        else
                xt2=x2
        endif
        xr2=xt1
c       write(6,*)' x1=',x1,' x2=',x2,' xt1=',xt1,' xt2=',xt2
c       write(6,*)' n1=',n1,' n2=',n2,' n1=',n1,' nr=',nr
        do nrr=nr,q-1
                if(x(nrr).gt.x2)go to 20
                xr1=xr2
                if(xt2.lt.x(nrr+1))then
                        xr2=xt2
                else
                        xr2=x(nrr+1)
                endif
                a = (y(nrr+1) - y(nrr))/(x(nrr+1) - x(nrr))               
                b = y(nrr)                                                    
                s = s+ 
     +          0.5*a*(xr2*xr2 - xr1*xr1) + (b - a*x(nrr))*(xr2 - xr1)    
c               write(6,*)' nrr=',nrr
c               write(6,*)' y(nrr)=',y(nrr),' y(nrr+1)=',y(nrr+1)
c               write(6,*)' xr1=',xr1,' xr2=',xr2
c               write(6,*)' x(nrr)=',x(nrr),' x(nrr+1)=',x(nrr+1)
c               write(6,*)' s=',s
        enddo

20      lin_integ_ar=s

        end


        function step_integ_ar(x,y,q,x1,x2)
c       
c       dimension of y must be q
c       dimension of x must be q+1
c       the last point means the end of last interval.
c
        implicit none
        real step_integ_ar
        real x(*),y(*),x1,x2
        integer q
        
        integer nr,nrr,n1,i
        real xt1,xt2
        real xr1,xr2
c       real a,b
        real s
        s=0
        step_integ_ar=0.0
c       write(6,*)' step:',q,x1,x2,x(1),x(q+1)
        if(q.le.0)return
        if(x2.lt.x1 .or. x2.lt.x(1) .or. x1.gt.x(q+1))return

        if(x1.lt.x(1))then
                xt1=x(1)
        else
                xt1=x1
        endif
        do i=2,q+1
                if(x(i).gt.xt1)then
                        n1=i
                        goto 10
                endif
        enddo
10      continue
        nr=n1-1
        if(x2.gt.x(q+1))then      ! it is not necessary
                xt2=x(q+1)
        else
                xt2=x2
        endif
        xr2=xt1


        do nrr=nr,q
                if(x(nrr).gt.x2)go to 20

                xr1=xr2
                if(xt2.lt.x(nrr+1))then
                        xr2=xt2
                else
                        xr2=x(nrr+1)
                endif
                s = s+ y(nrr)*(xr2-xr1)    

c       write(6,*)' nrr=',nrr,' xr=',xr1,xr2
c       write(6,*)' y(nrr)=',y(nrr),' s=',s

        enddo

20      step_integ_ar=s


        end

        function interp_line_arr(x,y,q,tr,x0)
c       
c       special code 
c       If x0<tr => 0
c       If tr<x0<x(1) linear interp.
c       If x0>x(q)  exponential interp., if it go down   
c       

        implicit none

        real interp_line_arr
        integer q       ! quantity of elements
        real x(*)       ! abscissa
        real y(*)       ! ordin.
        real tr         ! low treshold
        real x0         ! point

        integer n,n1,n2
        real p,k
        real s

        if(x0.lt.tr)then
                interp_line_arr=0.0     
                return
        endif

        if(x0.gt.x(q))then
            if(y(q-1).le.y(q))then
                interp_line_arr=0.0
                return
            endif
            p = alog(y(q-1)/y(q)) / alog(x(q-1)/x(q))
            k = y(q) / (x(q)**p)
            s = k * (x0 ** p)
            interp_line_arr = s
            return
        endif                   
        
        do n=2,q
                if(x0.le.x(n))then
                        n1=n-1
                        go to 10
                endif
        enddo
10      n2=n1+1

        k = (y(n2)-y(n1)) / (x(n2)-x(n1))
        s = y(n1) + k * ( x0-x(n1))
        interp_line_arr = s
c       write(6,*)' n1,n2=',n1,n2
c       write(6,*)' x=',x(n1),x(n2)
c       write(6,*)' y=',y(n1),y(n2)
c       write(6,*)' k,s=',k,s
c       stop
        return

        end 

        function interp_linep_arr(x,y,q,tr,x0)
c       
c       special code 
c       If x0<tr => 0
c       If tr<x0<x(1) linear interp.
c       If x0>x(q)  exponential interp., if it go down
c       If x(i+1).lt.x(i) then power line   
c       

        implicit none

        real interp_linep_arr
        integer q       ! quantity of elements
        real x(*)       ! abscissa
        real y(*)       ! ordin.
        real tr         ! low treshold
        real x0         ! point

        integer n,n1,n2
        real p,k
        real s

        if(x0.lt.tr)then
                interp_linep_arr=0.0    
                return
        endif

        if(x0.gt.x(q))then
*           if(y(q-1).le.y(q))then
*                interp_linep_arr=0.0
*                return
*            endif
*           p = alog(y(q-1)/y(q)) / alog(x(q-1)/x(q))
            p=-3.22
            k = y(q) / (x(q)**p)
            s = k * (x0 ** p)
            interp_linep_arr = s
            return
        endif                   
        
        do n=2,q
                if(x0.le.x(n))then
                        n1=n-1
                        go to 10
                endif
        enddo
10      n2=n1+1

        if(y(n2).ge.y(n1))then
            k = (y(n2)-y(n1)) / (x(n2)-x(n1))
            s = y(n1) + k * ( x0-x(n1))
        else
            p = alog(y(n1)/y(n2)) / alog(x(n1)/x(n2))
            k = y(n1) / (x(n1)**p)
            s = k * (x0 ** p)
        endif
        interp_linep_arr = s
c       write(6,*)' n1,n2=',n1,n2
c       write(6,*)' x=',x(n1),x(n2)
c       write(6,*)' y=',y(n1),y(n2)
c       write(6,*)' p,k,s=',p,k,s
c       stop
        return

        end 
+DECK,IniMatte.
 
        subroutine IniMatter(num,Atom,Weight,q,dens,pw,pf)
c
c       Initialization of the Matter 
c
        implicit none
        
c         include 'GoEvent.inc'
+SEQ,GoEvent.
c       include 'cconst.inc'
+SEQ,cconst.
c       include 'ener.inc'
+SEQ,ener.
c       include 'atoms.inc'
+SEQ,atoms.
c       include 'matters.inc'
+SEQ,matters.

        integer num,Atom(*),q
        real Weight(*),dens,pw,pf

        integer nat,nsh,nen,i,j
        real rms,rm(pQAt)
        real sw,ph,ph1
        real E,E2,S,EE1,EE2,EP1,EP2


        if(num.le.0.or.num.gt.pQMat)then
                write(oo,*)' Error in IniMatter: Wrong matter number',num
                if(sret_err.eq.0) stop
                s_err=1
                return
        endif
        if(QAtMat(num).gt.0)then
                write(oo,*)' Error in IniMatter: matter number',num,
     +          ' is initialized already'
                if(sret_err.eq.0) stop
                s_err=1
                return
        endif
        if(q.le.0)then
                write(oo,*)' Error in IniMatter: empty list of atoms',
     +          ' for matter number ',num
                if(sret_err.eq.0) stop
                s_err=1
                return
        endif
        QAtMat(num)=q
        sw=0.0
        if(q.eq.1)then
                Weight(1)=1.0
        endif
        do nat=1,q

            if(Zat(Atom(nat)).le.0)then
                write(oo,*)' Error in IniMatter: Atom number',
     +          nat,' is not initialized'
                if(sret_err.eq.0) stop
                s_err=1
                return
            endif
            if(Weight(nat).lt.0.0)then
                write(oo,*)' Error in IniMatter: Weight is negative'
                if(sret_err.eq.0) stop
                s_err=1
                return
            endif

            AtMat(nat,num)=Atom(nat)
            WeightAtMat(nat,num)=Weight(nat)
            sw=sw+Weight(nat)
        enddo
        
        
        do nat=1,q
            WeightAtMat(nat,num)=WeightAtMat(nat,num)/sw
        enddo
        A_Mean(num)=0.0
        Z_Mean(num)=0.0
        do nat=1,q
            A_Mean(num)=A_Mean(num)+Aat(Atom(nat))*WeightAtMat(nat,num)
            Z_Mean(num)=Z_Mean(num)+Zat(Atom(nat))*WeightAtMat(nat,num)
        enddo

        DensMat(num)=dens

        DensMatDL(num)=DensMat(num)
        DensMatDS(num)=DensMat(num)     ! if it is not equal
                                ! than the multiple scatering of the
                                ! insident particle will be calculated wrongly
c       DensMatDS(num)=0.2*DensMat(num)

        Pressure(num)=Cur_Pressure      ! It is never used, only for printing

        WWW(num)=pw
        FFF(num)=pf


        do nen=1,qener
            ph=0.0
            do nat=1,q
                ph1=0.0
                do nsh=1,QShellAt(Atom(nat))
                    ph1=ph1+PhotAt(nen,nsh,Atom(nat))
                enddo
                ph=ph+ph1*WeightAtMat(nat,num)
            enddo
            PhotMat(nen,num)=ph 
        enddo

        do nen=1,qener          ! the same but with ionization potential
            ph=0.0
            do nat=1,q
                ph1=0.0
                do nsh=1,QShellAt(Atom(nat))
                    ph1=ph1+PhotIonAt(nen,nsh,Atom(nat))
                enddo
                ph=ph+ph1*WeightAtMat(nat,num)
            enddo
            PhotIonMat(nen,num)=ph      
        enddo

        ElDensMat(num)=Z_Mean(num)/A_Mean(num)*AVOGADRO*DensMat(num)/
     +          ((5.07**3)*1.0e30)
        XElDensMat(num)=ElDensMat(num)*5.07e10
        wplaMat(num)=ElDensMat(num)*4.0*PI/(ELMAS*FSCON)                                
            
        RLenMat(num)=0.0
        rms=0.0
        do nat=1,QAtMat(num)
                rms=rms+Aat(AtMat(nat,num))*WeightAtMat(nat,num)
        enddo
        do nat=1,QAtMat(num)
                rm(nat)=Aat(AtMat(nat,num))*WeightAtMat(nat,num)/rms
        enddo
c       write(oo,*)' rm(1)=',rm(1)
        do nat=1,QAtMat(num)
                RLenMat(num)=RLenMat(num)+rm(nat)/RLenAt(AtMat(nat,num))
        enddo
        RLenMat(num)=1.0/(DensMatDS(num)*RLenMat(num))
c       RLenMat(num)=1.0/RLenMat(num)

        RuthMat(num)=0.0
        do nat=1,QAtMat(num)
                RuthMat(num)=RuthMat(num)+
     +          WeightAtMat(nat,num)*RuthAt(AtMat(nat,num))
        enddo
        RuthMat(num)=RuthMat(num)*DensMatDS(num)*AVOGADRO/A_Mean(num)


        DO nen=1,qener                                    
         epsi2(nen,num)=
     +  (PhotMat(nen,num)/enerc(nen))*ElDensMat(num)/Z_Mean(num)            
        enddo

        min_ioniz_pot(num)=1.0e30
        do nat=1,QAtMat(num)
            do nsh=1,QShellAt(Atom(nat))
                if(min_ioniz_pot(num).gt.ThresholdAt(nsh,Atom(nat)))then
                    min_ioniz_pot(num)=ThresholdAt(nsh,Atom(nat))
                endif
             enddo
        enddo

        do i=1,qener
            E=ENERC(I)                       
            E2=E*E                           
            EPSIP(I,num)=-WPLAMat(num)/E2 
            S=0.0               
            do j=1,qener

          IF(J.NE.I)THEN                                          
            S=S+EPSI2(J,num)*ENERC(J)*(ENER(J+1)-ENER(J))/            
     +          (ENERC(J)*ENERC(J)-E2)                            
          ELSE                                                    
            EE1=(ENER(J)+ENERC(J))/2.0                            
            EE2=(ENER(J+1)+ENERC(J))/2.0                          
            IF(J.GT.1)THEN                                        
            EP1=EPSI2(J-1,num)+(EE1-ENERC(J-1))*                      
     +          (EPSI2(J,num)-EPSI2(J-1,num))/
     +          (ENERC(J)-ENERC(J-1))       
            ELSE                                                  
            EP1=EPSI2(J,num)+(EE1-ENERC(J))*                          
     +          (EPSI2(J+1,num)-EPSI2(J,num))/
     +          (ENERC(J+1)-ENERC(J))       
            END IF                                                
            IF(J.LT.qener)THEN                                    
            EP2=EPSI2(J,num)+(EE2-ENERC(J))*                          
     +          (EPSI2(J+1,num)-EPSI2(J,num))/
     +          (ENERC(J+1)-ENERC(J))       
            ELSE                                                  
            EP2=EPSI2(J,num)+(EE2-ENERC(J))*                          
     +          (EPSI2(J,num)-EPSI2(J-1,num))/
     +          (ENERC(J)-ENERC(J-1))       
            END IF                                                
            S=S+EP1*EE1*(ENERC(J)-ENER(J))/                       
     +          (EE1*EE1-E2)                                      
            S=S+EP2*EE2*(ENER(J+1)-ENERC(J))/                     
     +          (EE2*EE2-E2)                                      
          END IF                                                                
            epsi1(i,num)=(2.0/PI)*S
        enddo
       enddo

        end
+DECK,PRIMATT.
        subroutine PriMatter(p)

        
        implicit none
        
        integer p               ! p = 0,1 short output
                                ! p >= 2 long output

c         include 'GoEvent.inc'
+SEQ,GoEvent.
c       include 'ener.inc'
+SEQ,ener.
c       include 'atoms.inc'
+SEQ,atoms.
c       include 'matters.inc'
+SEQ,matters.

        integer nat

        integer nmat,nen

        if(soo.eq.0)return
        write(oo,*)
        write(oo,*)' PriMatter:'
        do nmat=1,pQMat
            if(qAtMat(nmat).gt.0)then
        write(oo,*)' matter number ',nmat, ' qAtMat=',qAtMat(nmat)
                do nat=1,qAtMat(nmat)
        write(oo,*)' number of atom is ',AtMat(nat,nmat),
     +          ' weight=', WeightAtMat(nat,nmat)
                enddo
        write(oo,*)' A_Mean=',A_Mean(nmat),' Z_mean=',Z_Mean(nmat)
        write(oo,*)' DensMat=',DensMat(nmat),
     +          ' ElDensMat=',ElDensMat(nmat),
     +          ' XElDensMat=',XElDensMat(nmat)
        write(oo,*)' wplaMat=',wplaMat(nmat)
        write(oo,*)' plasm energy(sqrt(wplaMat))=',sqrt(wplaMat(nmat))
        write(oo,*)' RLenMat=',RLenMat(nmat)
        write(oo,*)' RuthMat=',RuthMat(nmat)
        write(oo,*)' min_ioniz_pot=',min_ioniz_pot(nmat)
        write(oo,*)' Pressure=',Pressure(nmat)
        write(oo,*)' WWW=',WWW(nmat),' FFF=',FFF(nmat)
                if(p.ge.2)then
        write(oo,*)'  enerc    PhotMat   PhotIonMat epsip   ',
     +          '   epsi1       epsi2'
                do nen=1,qener
        write(oo,'(6E10.3)')enerc(nen),
     +          PhotMat(nen,nmat),PhotIonMat(nen,nmat),epsip(nen,nmat),
     +          epsi1(nen,nmat),epsi2(nen,nmat)
                enddo   ! nen=1,qener
                endif
            endif       ! if(qAtMat(nmat).gt.0)
        enddo           ! nmat=1,pQMat

        end
+DECK,GRAPHMAT,IF=NEVER.
        subroutine GraphMatter(num)
c
c       input the data for showing the graphic by PAW
c
        implicit none
        
c         include 'GoEvent.inc'
+SEQ,GoEvent.
c       include 'cconst.inc'
+SEQ,cconst.
c       include 'ener.inc'
+SEQ,ener.
c       include 'atoms.inc'
+SEQ,atoms.
c       include 'matters.inc'
+SEQ,matters.

        integer num
        integer k,n
        real r
        real s
c       Calc. coef for going from 10**-18 sm**2 to Mev-2
        s=1.e-18 * 5.07e10 * 5.07e10
        
        n=0
        open(2,file='matter.grp')
        do k=1,qener
        if(PhotMat(k,num).gt.0.0)then
c       write(2,'(E10.3)')enerc(k)
        n=n+1
        endif
        enddo
        do k=1,qener
        if(PhotMat(k,num).gt.0.0)then
c       r=PhotMat(k,num)*ElDensMat(num)/Z_Mean(num)*5.07E10
c       r=1/r
c       r=r/DensMat(num)
c        write(2,'(2E10.3)')r
c        write(2,'(2E10.3)')enerc(k)*1.e6,r
c        write(2,'(2E10.3)')enerc(k),alog(r)
        write(2,*)enerc(k)*1.0e6, PhotMat(k,num)/s
        endif
        enddo
        close(2)
        write(oo,*)' GraphMatter: ',
     +          'file matter.grp is writen,n=',n

        end
+DECK,gasdens.
        function gasdens(A,Weight,q)
c
c       Calc. gas density
c
        implicit none

c       include 'GoEvent.inc'
+SEQ,GoEvent.
c         include 'ener.inc'
+SEQ,ener.
c         include 'atoms.inc'
+SEQ,atoms.
c       include 'matters.inc'
+SEQ,matters.

        real gasdens,A(*),Weight(*)
        integer q
        real powat
        real temp
        real ridberg
        real d,s
        integer i
c       powat=101325.0
c       powat=Cur_Pressure
*** Ensure that an initial value is set (RV 12/2/97)
        gasdens=-1
*** End of modification.
        if(Cur_Pressure.le.0 .or. Cur_Temper.le.0)then
                write(oo,*) ' error in gasdens: negative or',
     +                  ' zero Cur_Pressure or Cur_Temper'
                write(oo,*)' Cur_Pressure=',Cur_Pressure
                write(oo,*)' Cur_Temper=',Cur_Temper
                if(sret_err.eq.0) stop
                s_err=1
                return
        endif
        if(q.le.0)then
                write(oo,*)' error in gasdens: q<=0'
                write(oo,*)' q=',q
                if(sret_err.eq.0) stop
                s_err=1
                return
        endif
        do i=1,q
        if(A(i).le.0 .or. Weight(i).le.0)then
                write(oo,*) ' error in gasdens: negative or',
     +                  ' zero A or Weight'
                write(oo,*)' i=',i
                write(oo,*)' A(i)=',A(i)
                write(oo,*)' Weight(i)=',Weight(i)
                if(sret_err.eq.0) stop
                s_err=1
                return
        endif
        enddo
        

        powat=101325.0/760 * Cur_Pressure
c       temp=293
        temp=Cur_Temper
        ridberg=8.314
        d=0
        do i=1,q
                d=d+Weight(i)
        enddo
        s=0
        do i=1,q
                s=s+A(i)*Weight(i)
        enddo
        s=s*powat/(ridberg*temp*d)
        s=s*1.e-3*1.e-3
        gasdens=s
        return
        end
+DECK,IniVolum.
        subroutine IniFVolume(up,nmat,sSens,sIon,cwall1,cwide)
c
c       Init. first volume
c
        implicit none
        integer up,nmat,sSens,sIon
c       integer sTran
        real cwall1,cwide
c         include 'volume.inc'
+SEQ,volume.

        qvol=0
        RLenRAVol=0.0
        call IniVolume(up,nmat,sSens,sIon,cwall1,cwall1+cwide,cwide)

        end

        subroutine IniNVolume(up,nmat,sSens,sIon,cwide)
c
c       Init. next (not the first) volume
c
        implicit none
        integer up,nmat,sSens,sIon
c       integer sTran
        real cwall1,cwide

c         include 'volume.inc'
+SEQ,volume.

        cwall1=wall2(qvol)

        call IniVolume(up,nmat,sSens,sIon,cwall1,cwall1+cwide,cwide)

        end


        subroutine IniVolume(up,nmat,sSens,sIoni,cwall1,cwall2,cwide)
c
c       Init. any volume
c
        implicit none

c         include 'GoEvent.inc'
+SEQ,GoEvent.
c               include 'volume.inc'
+SEQ,volume.
c       include 'ener.inc'
+SEQ,ener.
c       include 'atoms.inc'
+SEQ,atoms.
c       include 'matters.inc'
+SEQ,matters.

        integer up,nmat,sSens,sIoni
c       integer sTran
        real cwall1,cwall2,cwide


        if(qvol.ge.pqvol)then
                write(oo,*)' Error in IniVolume: memory is over'
                stop
        endif
        if(qvol.eq.0)then
                QSVol=0
                QIVol=0
        endif
        qvol=qvol+1
        if(nmat.eq.0.and.sSens.eq.1)then
                write(oo,*)' Error in IniVolume: nmat=0 and sSens =1',
     +  '  simultaniously'
                stop
        endif
        if(sIoni.eq.0.and.sSens.eq.1)then
                write(oo,*)' Error in IniVolume: sIoni=0 and sSens =1',
     +  '  simultaniously'
                stop
        endif
        if(nmat.ne.0)then
                if(qAtMat(nmat).eq.0)then
                write(oo,*)' Error in IniVolume: matter number',nmat,
     +          ' is not initialized yet'
                stop
                endif
        endif

        upVol(qvol)=up
        nMatVol(qvol)=nmat
        sSensit(qvol)=sSens
        sIonizat(qvol)=sIoni
        if(sSens.ne.0)then
                QSVol=QSVol+1
                if(QSVol.gt.pQSVol)then
                write(oo,*)' Error in IniVolume: too much sens. volumes'
                stop
                endif
                numVolSens(QSVol)=qvol
                numSensVol(qvol)=QSVol
        else
                numSensVol(qvol)=0
        endif
        if(sIoni.ne.0)then
                QIVol=QIVol+1
                if(QIVol.gt.pQIVol)then
                write(oo,*)' Error in IniVolume: too much ioniz. volumes'
                stop
                endif
                numVolIoni(QIVol)=qvol
                numIoniVol(qvol)=QIVol
        else
                numIoniVol(qvol)=0
        endif

        if(qvol.eq.1)then
                wall1(qvol)=cwall1
        else
                wall1(qvol)=wall2(qvol-1)
        endif
        wide(qvol)=cwide
        if(wide(qvol).le.0.0)then
                write(oo,*)' Error in IniVolume: wide is negative or zero'
                stop
        endif
        wall2(qvol)=wall1(qvol)+wide(qvol)
        
c       wall2(qvol)=cwall2
c       if(qvol.eq.1)then
c               wall1(qvol)=cwall1
c       else
c               wall1(qvol)=wall2(qvol-1)
c       endif
c       wide(qvol)=wall2(qvol)-wall1(qvol)
c       if(wide(qvol).le.0.0)then
c               write(oo,*)' Error in IniVolume: wide is negative or zero'
c               stop
c       endif

        if(nmat.gt.0)then
                RLenRVol(qvol)=wide(qvol)/RLenMat(nmat)
                RLenRAVol=RLenRAVol+RLenRVol(qvol)
        endif

        end
+DECK,VOLPATHL.
        subroutine VolPathLeng(zcoor,veloc, num, mleng)

c       Find path leng in the current mat
c       zcoor - z coordinate
c       num - number of volume
c       veloc - velocity(cosine)

        implicit none

c         include 'volume.inc'
+SEQ,volume.

        real veloc(3)
        real*8 zcoor,mleng
        real*8 z
        integer num

c       write(oo,*)' zcoor=',zcoor
c       write(oo,*)' veloc=',veloc
c       write(oo,*)' num=',num
        z=zcoor
        if(veloc(3).eq.0.0)then
                mleng=1.e30
        else if(veloc(3).gt.0.0)then
                mleng=(wall2(num)-z)/veloc(3)
        else
                mleng=(wall1(num)-z)/veloc(3)
        endif

        end
+DECK,VOLNUMZC.
        subroutine VolNumZcoor(zcoor,veloc,num)

c       Find number of material for this coor.
c       zcoor - z coordinate
c       veloc - z velocity
c       num - number of volume
c               if(num.ne.0) particle go to next lay
c               correspodently with its velocity
c       if without of vol, returns 0
c       if num!=0 at call, go to next mat.

        implicit none

c         include 'volume.inc'
+SEQ,volume.

        real veloc
        real*8 zcoor
        integer num
        integer i

        if(num.ne.0)then
                if(veloc.gt.0)then
                        if(num.lt.qvol)then
                                num=num+1
                                return
                        else
                                num=0
                                return
                        endif
                else
                        if(num.gt.1)then
                                num=num-1
                                return
                        else
                                num=0
                                return
                        endif
                endif
        endif

        num=0
        if(zcoor.lt.wall1(1))then
            return
        else
            if(zcoor.eq.wall1(1))then
                if(veloc.gt.0)then
                        num=1
                else
                        num=0
                endif
                return
            endif
        endif
        do i=1,qvol
                if(zcoor.lt.wall2(i))then
                        num=i
                        return
                elseif(zcoor.eq.wall2(i))then
                        if(veloc.gt.0)then
                                if(i.lt.qvol)then
                                        num=i
                                        return
                                else                                            
                                        num=0
                                        return
                                endif
                        else
                                if(i.gt.1)then
                                        num=i-1
                                        return
                                else
                                        num=0
                                        return
                                endif
                        endif
                endif
        enddo
        return
        end
+DECK,PRIVOLUM.
        subroutine PriVolume

        implicit none

c         include 'GoEvent.inc'
+SEQ,GoEvent.
c       include 'volume.inc'
+SEQ,volume.
        integer i

        if(soo.eq.0)return
        write(oo,*)
        write(oo,*)' PriVolume: qvol=',qvol
        write(oo,*)
     +  ' nvol upVol  nMatVol sSensit sIonizat ',
     +          'wall1     wall2      wide   RLenRVol'
        do i=1,qvol
        write(oo,'(I4,4I8,3F10.4,F10.6)')i, upVol(i),nMatVol(i),
     +          sSensit(i),
     +          sIonizat(i),
     +          wall1(i),wall2(i),wide(i),RLenRVol(i)
        if(sSensit(i).ne.0)then
        write(oo,*)'          numSensVol(i)=',numSensVol(i)
        write(oo,*)'          numVolSens(numSensVol(i))=',
     +  numVolSens(numSensVol(i))
        endif
        if(sIonizat(i).ne.0)then
        write(oo,*)'          numIoniVol(i)=',numIoniVol(i)
        write(oo,*)'          numVolIoni(numIoniVol(i))=',
     +  numVolIoni(numIoniVol(i))
        endif
        enddo   ! qvol
        write(oo,*)
     +  '                                                ',
     +  ' RLenRAVol=',RLenRAVol

        end
+DECK,IniTrack.
c       This package deals with tracks of incident charged particles.
c       The particle goes from left plane of the detector to
c       the right plane.
c       It starts from some starting point and goes to some direction.
c       The energy of the particle is constant.

        subroutine IniRATrack(pystart1, pystart2,  
     +          psigmaang)

c       Randomization of the origin point 
c       with uniform distribution with y-coordinate between 
c       pystart1 and pystart2 , x=0.0
c       and initial direction around theta = 0.0 
c       with Gauss distribution with sigma = psigmaang 


        implicit none

        real pystart1, pystart2, pang, pphiang, psigmaang
c         include 'ener.inc'
+SEQ,ener.
c         include 'atoms.inc'
+SEQ,atoms.
c         include 'matters.inc'
+SEQ,matters.
c         include 'volume.inc'
+SEQ,volume.
c       include 'track.inc'
+SEQ,track.

        ystart1=pystart1
        ystart2=pystart2
        sigmaang=psigmaang
        ystart=0.0
        pang=0.0
        pphiang=0.0
        call IniTrack(ystart, pang, pphiang)
        sign_ang=1
        srandtrack=1
        sigmtk = 0

        end     
+DECK,INIRTRAC.
        subroutine IniRTrack(pystart1, pystart2,  pang, pphiang)

c       Randomization of the origin point
c       with uniform distribution with y-coordinate between
c       pystart1 and pystart2 , x=0.0.
c       Initial direction is defined by theta = pang, phi = pphiang


        implicit none

        real pystart1, pystart2, pang, pphiang
c         include 'ener.inc'
+SEQ,ener.
c         include 'atoms.inc'
+SEQ,atoms.
c         include 'matters.inc'
+SEQ,matters.
c         include 'volume.inc'
+SEQ,volume.
c       include 'track.inc'
+SEQ,track.

        ystart1=pystart1
        ystart2=pystart2
        sigmaang=0.0
        ystart=0.0
        call IniTrack(ystart, pang, pphiang)
        sign_ang=1
        srandtrack=1
        sigmtk = 0

        end     
+DECK,ININTRAC.
        subroutine IniNTrack

c
c       Generate the next track
c       It calls from GoEvent
c       If there are no randomization of the track requried
c       and the are no multiple scattering, it does nothing
c       except filling of some data structure.

        implicit none
c         include 'ener.inc'
+SEQ,ener.
c         include 'atoms.inc'
+SEQ,atoms.
c         include 'matters.inc'
+SEQ,matters.
c         include 'volume.inc'
+SEQ,volume.
c       include 'track.inc'
+SEQ,track.
c       include 'cconst.inc'
+SEQ,cconst.
        real r
        real ranfl
        real pang,pphiang,pystart
        real yy,dimmy

        integer n,nv,i

         if(srandtrack.eq.1)then
                r=ranfl()
                ystart=ystart1+(ystart2-ystart1)*r
                if(sigmaang.gt.0.0)then
10                      call lranor(yy,dimmy)
                        if(yy.lt.0.0) yy=-yy
                        yy=yy*sigmaang
                        if(yy.gt.1.0)goto 10
                        ang=yy
                        yy=ranfl()
                        phiang=yy*2.0*PI
                        pang=ang
                        pphiang=phiang
                        pystart=ystart
                        call IniTrack(pystart, pang, pphiang)
                        srandtrack=1 ! it falled in IniTrack
                endif
        endif

        if(sigmtk.eq.1)then
                call TTrack
        else
          do nv=1,QVol
            pntmtk(3,nv)=wall1(nv)
            pntmtk(1,nv)=(wall1(nv)-wall1(1))*e3ang(1)/e3ang(3)
            pntmtk(2,nv)=(wall1(nv)-wall1(1))*e3ang(2)/e3ang(3)+ystart
            velmtk(1,nv)=e3ang(1)
            velmtk(2,nv)=e3ang(2)
            velmtk(3,nv)=e3ang(3)
            do i=1,3
              e1mtk(i,nv)=e1ang(i)
              e2mtk(i,nv)=e2ang(i)
              e3mtk(i,nv)=e3ang(i)
            enddo
          enddo
          pntmtk(3,qVol+1)=wall2(qVol)
          pntmtk(1,qVol+1)=(wall2(qVol)-wall1(1))*e3ang(1)/e3ang(3)
          pntmtk(2,qVol+1)=(wall2(qVol)-wall1(1))
     +                     *e3ang(2)/e3ang(3)+ystart
          velmtk(1,qVol+1)=e3ang(1)
          velmtk(2,qVol+1)=e3ang(2)
          velmtk(3,qVol+1)=e3ang(3)
          do i=1,3
            e1mtk(i,qVol+1)=e1ang(i)
            e2mtk(i,qVol+1)=e2ang(i)
            e3mtk(i,qVol+1)=e3ang(i)
          enddo
                
          Qmtk=qVol
          nmtk=Qmtk+1
          do n=1,Qmtk
            lenmtk(n)=sqrt((pntmtk(1,n+1)-pntmtk(1,n))**2+
     +          (pntmtk(2,n+1)-pntmtk(2,n))**2+
     +          (pntmtk(3,n+1)-pntmtk(3,n))**2 )
          enddo
          do n=1,Qmtk
            Tetamtk(n)=0.0
          enddo
          do n=1,Qmtk
            nVolmtk(n)=n
          enddo
          nVolmtk(Qmtk+1)=qVol
          do n=1,Qmtk
            vlenmtk(n)=lenmtk(n)
            nmtkvol1(n)=n
            nmtkvol2(n)=n
            xdvmtk(n)=0.0
            ydvmtk(n)=0.0
          enddo
                                 
        endif

        end
+DECK,INITRACK.
        subroutine IniTrack(pystart, pang, pphiang)

c
c       Simple initialization of the track 
c

        implicit none

        real pystart, pang, pphiang
c         include 'ener.inc'
+SEQ,ener.
c         include 'atoms.inc'
+SEQ,atoms.
c         include 'matters.inc'
+SEQ,matters.
c         include 'volume.inc'
+SEQ,volume.
c       include 'track.inc'
+SEQ,track.

        ystart=pystart
        srandtrack=0
        if(pystart.eq.0.and.pang.eq.0.and.pphiang.eq.0)then
                sign_ang=0
                e1ang(1)=1
                e1ang(2)=0
                e1ang(3)=0
                e2ang(1)=0
                e2ang(2)=1
                e2ang(3)=0
                e3ang(1)=0
                e3ang(2)=0
                e3ang(3)=1              
        else
                sign_ang=1
                ang=pang
                phiang=pphiang
c               xstart=pxstart
c               this is for geometry without angle phi 
c               e1ang(1)=cos(ang)
c               e1ang(2)=0
c               e1ang(3)=-sin(ang)
c               e2ang(1)=0
c               e2ang(2)=1
c               e2ang(3)=0
c               e3ang(1)=sin(ang)
c               e3ang(2)=0
c               e3ang(3)=cos(ang)
c               this is for complete geometry
                e1ang(1)=cos(ang)*cos(phiang)
                e1ang(2)=cos(ang)*sin(phiang)
                e1ang(3)=-sin(ang)
                e2ang(1)=-sin(phiang)
                e2ang(2)=cos(phiang)
                e2ang(3)=0
                e3ang(1)=sin(ang)*cos(phiang)
                e3ang(2)=sin(ang)*sin(phiang)
                e3ang(3)=cos(ang)
        endif

        end
+DECK,INIMTRAC.
        subroutine IniMTrack(psruthmtk, pmlammtk, pmTetacmtk)
c
c       initialization of the axiliary variables for multiple
c       scatering of the incident particle.
c       It have to be called after each initialization of the 
c       new particle if the multiple scatering is desirable.
c       If it is not needed, the subroutine must not be called at all.

c       psruthmtk - sign of Rutherford scattering (1)
c               1 is recomended
c       pmlammtk - minimum mean lengt of range
c                  multiplied by density. sm*gr/sm**3 = gr/sm**2
c       pmTetacmtk - minimum threshold turn angle
c       The program find the maximum of pmTetacmtk and
c       the same angle calculated from pmlammtk, and then,
c       the program recalculates mlammtk.
c       For psruthmtk = 0 there is another algorithm.
c       To have right results pmlammtk have to be
c       10-100 times lower than widht of the detector.
c       The pmTetacmtk have to correspont detector resolution.

c
        implicit none

c         include 'GoEvent.inc'
+SEQ,GoEvent.
c         include 'ener.inc'
+SEQ,ener.
c         include 'atoms.inc'
+SEQ,atoms.
c         include 'matters.inc'
+SEQ,matters.
c         include 'crosec.inc'
+SEQ,crosec.
c         include 'volume.inc'
+SEQ,volume.
c         include 'cconst.inc'
+SEQ,cconst.
c       include 'track.inc'
+SEQ,track.
c       include 'part.inc'
+SEQ,part.

        integer psruthmtk
        real pmlammtk, pmTetacmtk

        integer nm
        real lam,mT,A
        real*8 B
        real msig,x
        real*8 r

        sigmtk=1
        sruthmtk=psruthmtk
        mlammtk=pmlammtk
        mTetacmtk=pmTetacmtk

        do nm=1,pQMat
        if(qAtMat(nm).gt.0)then

        if(sruthmtk.eq.1)then

        lam=mlammtk/DensMat(nm)

*       write(oo,*)' lam=',lam
c               Calculate the minimum angle for restriction of field by
c               atomic shell
        mT=2.0*asin(1.0/
     +          (2.0*partmom*Z_Mean(nm)*5.07e2))
        rTetacmtk(nm)=mT
*        write(oo,*)' mT=',mT
        if(mT.lt.mTetacmtk)then
                mT=mTetacmtk   ! Throw out too slow interaction. They
                                ! do not influent to anything
        endif
c               Calculate the cut angle due to mean free part
        A=RuthMat(nm)/(partmom2*beta2)/(5.07e10)**2
*        B=1.0/(lam*A)  ! B is double precision
        B=(lam*A)       ! B is double precision
*        Tetacmtk(nm)=acos( (B-1.0) / (B+1.0) )
*       B = sqrt( 1.0 / (B+1.0) )
        B = sqrt( B / (B+1.0) )
        Tetacmtk(nm)=2.0 * asin(B)
c               If it too little, reset it. It will lead to increasing
c               of lamBdel and decriasing of calculation time.
*       write(oo,*)' A=',A,' B=',B,' Tetacmtk(nm)=',Tetacmtk(nm)
        if(Tetacmtk(nm).lt.mT)then
                Tetacmtk(nm)=mT
                B=mT    ! B is double precision
c                r=cos(B)       ! r is double precision
c                lam=A*(1.0+r)/(1.0-r)
c                lam=1.0/lam
                r=sin(B/2.0)
                lam=1/A * 2.0 * r*r / ( 1 + cos(B) )
c               lam=(partmom2*beta2*sin(Tetacmtk(nm)/2.0)**2) / A
        endif
*       write(oo,*)' lam=',lam
        
        lammtk(nm)=lam
        B=Tetacmtk(nm)
        CosTetac12mtk(nm)=cos(B/2.0)
        SinTetac12mtk(nm)=sin(B/2.0)

        else
c       gauss formula

        msig=mTetacmtk
        x=msig/(sqrt(2.0)*13.6/(sqrt(beta2)*partmom))
        x=x*x

c       x=x/DensMat(nm)
        x=x*RLenMat(nm)
        lam=mlammtk/DensMat(nm)
c       write(oo,*)' x=',x,' rleng=',rleng
c               reset if it is too large
        if(lam.lt.x)lam=x
        
        lammtk(nm)=lam
        msigmtk=sqrt(2.0)*13.6/(sqrt(beta2)*partmom)
        
        endif

        endif
        enddo

        nmtk=1
        Qmtk=0
        nVolmtk(1)=0


        end
+DECK,TTRACK.
        subroutine TTrack

        implicit none
c         include 'GoEvent.inc'
+SEQ,GoEvent.
c         include 'ener.inc'
+SEQ,ener.
c         include 'atoms.inc'
+SEQ,atoms.
c         include 'matters.inc'
+SEQ,matters.
c         include 'volume.inc'
+SEQ,volume.
c       include 'track.inc'
+SEQ,track.

        real*8 mleng,rleng
        integer nsv
        real*8 rst(3),rl
        integer j

        if(qVol.le.0)then
                write(oo,*)' error in TTrack: there are not volumes'
                stop
        endif   

1       nmtk=1
        pntmtk(1,1)=0.0
        pntmtk(2,1)=ystart
        pntmtk(3,1)=wall1(1)
        velmtk(1,1)=e3ang(1)
        velmtk(2,1)=e3ang(2)
        velmtk(3,1)=e3ang(3)
        sgnmtk=1
        sturnmtk=0
        nmtkvol1(1)=1
        vlenmtk(1)=0.0
        nVolmtk(nmtk)=0

10      if(sgnmtk.eq.1)then
            call VolNumZcoor(pntmtk(3,nmtk),velmtk(3,nmtk),nVolmtk(nmtk))
            sgnmtk=0
            if(nVolmtk(nmtk).ne.0)then
                vlenmtk(nVolmtk(nmtk))=0.0
            endif
        endif
        if(nVolmtk(nmtk).eq.0)then
                go to 100
        endif

        call MakeNewSys
     +  (e1mtk(1,nmtk),e2mtk(1,nmtk),e3mtk(1,nmtk),velmtk(1,nmtk))

        if(sturnmtk.eq.1)then
                call TurnTrack
                sturnmtk=0
                if(velmtk(3,nmtk).le.0.0)then
                    write(oo,*)' worning in TTrack: particle goes back'
                    go to 1
                endif
        endif
        call VolPathLeng
     +          (pntmtk(3,nmtk),velmtk(1,nmtk),nVolmtk(nmtk),mleng)
        if(nMatVol(nVolmtk(nmtk)).eq.0)then  ! empty volume: no interaction
                lenmtk(nmtk)=mleng
                sgnmtk=1
                sturnmtk=0
        else
            if(sruthmtk.eq.1)then  !lengt to coulomb interaction
                call SRLengmtk(rleng)
            else
                call SMLengmtk(rleng)
            endif
            if(rleng.le.mleng)then
                lenmtk(nmtk)=rleng
                sturnmtk=1
                sgnmtk=0
            else
                lenmtk(nmtk)=mleng
                sgnmtk=1
                if(sruthmtk.eq.1)then
                    sturnmtk=0
                else
                    sturnmtk=1
                endif
            endif
        endif
        do j=1,3
            pntmtk(j,nmtk+1)=
     +          pntmtk(j,nmtk)+lenmtk(nmtk)*velmtk(j,nmtk)
            velmtk(j,nmtk+1)=velmtk(j,nmtk)
        enddo
        vlenmtk(nVolmtk(nmtk))=vlenmtk(nVolmtk(nmtk))+lenmtk(nmtk)
        nVolmtk(nmtk+1)=nVolmtk(nmtk)
        if(sgnmtk.eq.1)then
            nmtkvol2(nVolmtk(nmtk))=nmtk
            nmtkvol1(nVolmtk(nmtk)+1)=nmtk+1
            if(sSensit(nVolmtk(nmtk)).eq.1)then
                nsv=numSensVol(nVolmtk(nmtk))
                rst(3)=(wall2(nVolmtk(nmtk))-wall1(1))     ! it was error here
                rl=rst(3)/e3ang(3)
                rst(1)=e3ang(1)*rl
                rst(2)=e3ang(2)*rl
                xdvmtk(nsv)=pntmtk(1,nmtk+1)-rst(1)
                ydvmtk(nsv)=pntmtk(2,nmtk+1)-rst(2)
            endif
        endif   
        if(nmtk.ge.pQmtk-2)then
                write(oo,*)' worning of TTrack: '
                write(oo,*)
     +          ' Overflow of mtk. You have increase the common blok'
                go to 1
        endif
        nmtk=nmtk+1
        go to 10


100     Qmtk=nmtk-1

        end     
+DECK,SRLENGMT. 
        subroutine SRLengmtk(rleng)
c
c       Step lenght limit due to multiple scatering
c       The method with Rutherford cross section
c
        implicit none

        real ranfl
        real*8 rleng

c         include 'GoEvent.inc'
+SEQ,GoEvent.
c         include 'ener.inc'
+SEQ,ener.
c         include 'atoms.inc'
+SEQ,atoms.
c         include 'matters.inc'
+SEQ,matters.
c        include 'crosec.inc'
c         include 'volume.inc'
+SEQ,volume.
c       include 'track.inc'
+SEQ,track.

        real r

        r=ranfl()
        if(r.gt.0.99999)then
                rleng=1.0e30
                return
        endif
        rleng=-lammtk(nMatVol(nVolmtk(nmtk)))*alog(1.0-r)
c       write(oo,*)'  SRLengBdel'
c       write(oo,*)' r,lamBdel,rleng',r,lamBdel,rleng

        end

        subroutine SMLengmtk(rleng)
c
c       Step lenght limit due to multiple scatering
c       The method with mean multiple scatering angle form
c
        implicit none

        real*8 rleng

c         include 'GoEvent.inc'
+SEQ,GoEvent.
c         include 'ener.inc'
+SEQ,ener.
c         include 'atoms.inc'
+SEQ,atoms.
c         include 'matters.inc'
+SEQ,matters.
c         include 'volume.inc'
+SEQ,volume.
c       include 'track.inc'
+SEQ,track.

        rleng=lammtk(nMatVol(nVolmtk(nmtk)))

        end
+DECK,TURNTRAC.
        subroutine TurnTrack

        implicit none

c         include 'GoEvent.inc'
+SEQ,GoEvent.
c         include 'ener.inc'
+SEQ,ener.
c         include 'atoms.inc'
+SEQ,atoms.
c         include 'matters.inc'
+SEQ,matters.
c        include 'crosec.inc'
c         include 'volume.inc'
+SEQ,volume.
c       include 'part.inc'
+SEQ,part.
c       include 'track.inc'
+SEQ,track.
c       include 'cconst.inc'
+SEQ,cconst.

        real ranfl
        real*8 r,rs,rsin12,rcos12
        real*8 x,msig
        real rra,rrb

        if(sruthmtk.eq.1)then

                r=ranfl()
c               rs=cos(Tetacmtk(nMatVol(nVolmtk(nmtk-1))))
c               rs=CosTetacmtk(nMatVol(nVolmtk(nmtk-1)))
c               rs=1.0-(1.0-rs)/(1.0-r*0.5*(1.0+rs))
                rsin12=SinTetac12mtk(nMatVol(nVolmtk(nmtk-1)))
                rcos12=CosTetac12mtk(nMatVol(nVolmtk(nmtk-1)))
                rs = 1.0 - r * rcos12 * rcos12
                if(rs.eq.0.0)then
                        Tetamtk(nmtk-1)=PI
                else
                        rs=rsin12 / sqrt( rs )
                        rs=2.0 * asin(rs)
                        Tetamtk(nmtk-1)=rs
                endif

        else

                x=lenmtk(nmtk-1)/RLenMat(nMatVol(nVolmtk(nmtk-1)))
c                            it can not be called for first step
c               msig=sqrt(2.0)*13.6/(sqrt(beta2)*partmom)*
c     +                 sqrt(x)
                msig=msigmtk*
     +                  sqrt(x)
                call lranor(rra,rrb)
                Tetamtk(nmtk-1)=rra*msig
c               write(oo,*)' msig,TetaBdel,rra=',msig,TetaBdel,rra
                
        endif

        call turnvec
     +  (e1mtk(1,nmtk-1),e2mtk(1,nmtk-1),e3mtk(1,nmtk-1),Tetamtk(nmtk-1),
     +  velmtk(1,nmtk))
        
        end
+DECK,PRITRACK.
        subroutine PriTrack

        implicit none
c         include 'GoEvent.inc'
+SEQ,GoEvent.
c         include 'ener.inc'
+SEQ,ener.
c         include 'atoms.inc'
+SEQ,atoms.
c         include 'matters.inc'
+SEQ,matters.
c         include 'volume.inc'
+SEQ,volume.
c       include 'track.inc'
+SEQ,track.

        
        if(soo.eq.0)return
        write(oo,*)
        write(oo,*)' PriTrack:'
        write(oo,*)' ystart1,2, ystart=',ystart1,ystart2,ystart
        write(oo,*)' srandtrack=',srandtrack
        if(sign_ang.eq.0)then
                write(oo,*)' parallel track'
        else
                write(oo,*)' ang=',ang,' phiang=',phiang,
     +                  ' sigmaang=',sigmaang
                write(oo,*)' e1ang()=',e1ang(1),e1ang(2),e1ang(3)
                write(oo,*)' e2ang()=',e2ang(1),e2ang(2),e2ang(3)
                write(oo,*)' e3ang()=',e3ang(1),e3ang(2),e3ang(3)
        endif
        end
+DECK,PRIMTRAC.
        subroutine PriMTrack(k)
c
c       k can be equal to 0,1,2,3,4
c

        implicit none

        integer k

c         include 'GoEvent.inc'
+SEQ,GoEvent.
c         include 'ener.inc'
+SEQ,ener.
c         include 'atoms.inc'
+SEQ,atoms.
c         include 'matters.inc'
+SEQ,matters.
c         include 'volume.inc'
+SEQ,volume.
c       include 'track.inc'
+SEQ,track.

        integer nm,n,i,j,nv,nsv

        if(soo.eq.0)return
        write(oo,*)
        write(oo,*)' PriMTrack: k=',k
        write(oo,*)' sigmtk=',sigmtk
c       if(sigmtk.eq.1)then
        if(sigmtk.eq.1)then
        write(oo,*)' sruthmtk=',sruthmtk
        write(oo,*)' mlammtk=',mlammtk,'  mTetacmtk=',mTetacmtk
        endif
        write(oo,*)' qmtk=',qmtk,' nmtk=',nmtk

        if(k.eq.1)then
        write(oo,*)' way of particle'
        do n=1,nmtk
        write(oo,*)' n=',n
        write(oo,*)' pntmtk(1,2,3                            ',
     +  ' velmtk(1,2,3'
        write(oo,'(6(1X,e12.6))')(pntmtk(j,n),j=1,3),(velmtk(j,n),j=1,3)        
        write(oo,*)' lenmtk,       Tetamtk,       nVolmtk'
        write(oo,'(1X,e12.6,1X,e12.6,1X,i7)')
     +          lenmtk(n),Tetamtk(n),nVolmtk(n)
        write(oo,*)' e1mtk=',(e1mtk(i,n),i=1,3)
        write(oo,*)' e2mtk=',(e2mtk(i,n),i=1,3)
        write(oo,*)' e3mtk=',(e3mtk(i,n),i=1,3)
        enddo
        endif

        if(sigmtk.eq.1)then
        if(k.eq.2)then
        write(oo,*)' material constants:'
        write(oo,*)' msigmtk=',msigmtk
        write(oo,*)'          nm, lammtk(nmat),   Tetacmtk(nmat)',
     +  '    CosTetac12mtk(nmat),   SinTetac12mtk(nmat)'
        do nm=1,pQMat
        if(qAtMat(nm).gt.0)then
        write(oo,*)nm,lammtk(nm),Tetacmtk(nm),rTetacmtk(nm),
     +  CosTetac12mtk(nm),SinTetac12mtk(nm)
        endif
        enddo
        endif
        endif

        if(sigmtk.eq.1)then
        if(k.eq.3)then
        if(nVolmtk(nmtk).ne.0)then
        write(oo,*)' given point:'
        write(oo,*)' pntmtk(1,2,3,                    ',
     +  '       velmtk(1,2,3'
        write(oo,'(6(1X,e12.6))')
     +          (pntmtk(j,nmtk),j=1,3),(velmtk(j,nmtk),j=1,3)
        write(oo,*)' lenmtk,       Tetamtk,       nVolmtk'
        write(oo,'(1X,e12.6,1X,e12.6,1X,i7)')
     +          lenmtk(nmtk),Tetamtk(nmtk),nVolmtk(nmtk)
        write(oo,*)' e1mtk=',(e1mtk(i,nmtk),i=1,3)
        write(oo,*)' e2mtk=',(e2mtk(i,nmtk),i=1,3)
        write(oo,*)' e3mtk=',(e3mtk(i,nmtk),i=1,3)
        endif
        endif
        endif

        if(k.eq.4)then
        if(qmtk.ge.1)then
        write(oo,*)' volimes info:'
        write(oo,*)
     +  '         nv, ',
     +  ' vlenmtk(pQVol),   nmtkvol1(pQVol),   nmtkvol2(pQVol)'
c       write(oo,*)' if sensitive, nsv,xdvmtk(nsv),ydvmtk(nsv)'
        do nv=1,qVol
        write(oo,*)nv, vlenmtk(nv), nmtkvol1(nv), nmtkvol2(nv)
            if(sSensit(nv).eq.1)then
            write(oo,*)' sensitive: nsv,xdvmtk(nsv),ydvmtk(nsv)'
                nsv=numSensVol(nv)
                write(oo,*)'     ',nsv,xdvmtk(nsv),ydvmtk(nsv)
            endif
        enddo
        endif
        endif

c       endif

        end
+DECK,IniPart.
        subroutine IniPart(ptkin,pmass)
c
c       Initialize the incident particle
c
        implicit none

c         include 'GoEvent.inc'
+SEQ,GoEvent.
c       include 'cconst.inc'
+SEQ,cconst.
c       include 'part.inc'
+SEQ,part.

        real ptkin,pmass
        real*8 gamma,r,rm2,rme
        if(ptkin.le.0.0.or.pmass.le.0.0.or.ptkin.lt.1e-3*pmass)then
                write(oo,*)' error in IniPart: wrong parameters:'
                write(oo,*)' ptkin=',ptkin,' pmass=',pmass
                if(sret_err.eq.0) stop
                s_err=1
                return
        endif
        tkin=ptkin
        mass=pmass
        gamma=tkin/mass+1.0
        partgamma=gamma
        beta2=1.0-1.0/(gamma*gamma)
        r=mass/(tkin+mass)      
        beta12=r*r
        partmom2=tkin*tkin+2.0*tkin*mass
        partmom=sqrt(partmom2)
        if(mass.ge.0.500.and.mass.le.0.515)then
            emax=tkin
            s_pri_elec=1
        else
            s_pri_elec=0
            rm2=mass*mass
            rme=ELMAS
            if(1.0-beta2 .gt. 1.0e-10)then
                emax=2.0*rm2*ELMAS*beta2/
     +          ((rm2+rme*rme+2.0*rme*gamma*mass)*(1.0-beta2))
                if(emax.gt.tkin)emax=tkin
            else
                emax=tkin
            endif
        endif
        bem=beta2/emax
        coefPa=1.0/(FSCON*beta2*PI)

        end                                     
+DECK,PRIPART.
        subroutine PriPart

        implicit none

c         include 'GoEvent.inc'
+SEQ,GoEvent.
c       include 'part.inc'
+SEQ,part.

        if(soo.eq.0)return

        write(oo,*)
        write(oo,*)' Particle: tkin=',tkin,' mass=',mass
        write(oo,*)' beta2=',beta2,' beta12=',beta12
        write(oo,*)' emax=',emax,' bem=',bem,' coefPa=',coefPa

        end
+DECK,IniCrose.
        Subroutine IniCrosec
c
c       Initialization of ionization cross section for all the
c       matters which are in "ionization" volumes
c
        implicit none

c         include 'GoEvent.inc'
+SEQ,GoEvent.
c       include 'ener.inc'
+SEQ,ener.
c       include 'atoms.inc'
+SEQ,atoms.
c       include 'matters.inc'
+SEQ,matters.
c       include 'crosec.inc'
+SEQ,crosec.
c       include 'volume.inc'
+SEQ,volume.
        
        integer nv,nm

        if(qvol.le.0)then
                write(oo,*)' You forgot to initialize volumes'
                stop
        endif
        if(QIVol.le.0)then
                write(oo,*)' You forgot to initialize ioniz. volumes'
                stop
        endif

        do nm=1,pQMat
                sMatC(nm)=0
        enddo

        do nv=1,QIVol
                sMatC(nMatVol(numVolIoni(nv)))=1
        enddo

        do nm=1,pQMat
                if(sMatC(nm).eq.1)then
                        call IniCrosecm(nm)
                endif
        enddo

        end
+DECK,INICROSM. 
        Subroutine IniCrosecm(nmat)
c
c       Initialization of ionization cross section for given matter
c
        implicit none

c         include 'GoEvent.inc'
+SEQ,GoEvent.
c       include 'ener.inc'
+SEQ,ener.
c       include 'atoms.inc'
+SEQ,atoms.
c       include 'matters.inc'
+SEQ,matters.
c       include 'part.inc'
+SEQ,part.
c       include 'crosec.inc'
+SEQ,crosec.
c       include 'cconst.inc'
+SEQ,cconst.

        integer nmat

c       real spa,sio

        integer i
        real*8 r,R0,R1,R2,R3,RR12,RR22
        real*8 s,sa
        integer k

c       real ALOG,SQRT,ATAN
        real fquan,fmean,fmean1
        integer nen,nat,nsh,nshc,ne
c       integer nat0,nat1,iat

c       real spa(pqener)                ! sum of photoabsorption
c                       ! It is luzy to put it to matter.

        real*8 delta,pg,pg2

        complex*16 eeee
        real*8 eee(2)
        equivalence (eeee,eee(1))

c       MatC=nmat

c       ksi=0.1534*DensMat(nmat)*Z_Mean(nmat)/(beta2*A_Mean(nmat))

      DO 100 I=1,qener
        R=-EPSI1(I,nmat)+(1.0+EPSI1(I,nmat))*BETA12
        R=R*R+beta2*beta2*EPSI2(I,nmat)*EPSI2(I,nmat)
        R=1.0/SQRT(R)
        R=DLOG(R)
        LOG1C(I,nmat)=R
100   CONTINUE
C
      DO 200 I=1,qener
        R=2.0*0.511*beta2/ENERC(I)
        if(R.gt.1.0)then
          R=DLOG(R)
        else
          R=0.0
        endif
        LOG2C(I,nmat)=R
200   continue
c

        
      DO 300 I=1,qener
        R0=1.0+EPSI1(I,nmat)
        R=-EPSI1(I,nmat)+R0*BETA12
        RR12=R0*R0
        RR22=EPSI2(I,nmat)*EPSI2(I,nmat)
        R1=(-R0*R+beta2*RR22)/(RR12+RR22)
        R2=EPSI2(I,nmat)*Beta2/R
        R3=ATAN(R2)
        IF(R.LT.0.0) R3=3.14159+R3

c       R2=R/(EPSI2(I,nmat)*Beta2)      ! it is the same as
c                               previous three lines but less exactly
c                               if EPSI2 --> 0
c       R3=PI/2.0 - ATAN(R2)
        
        chereCangle(I,nmat)=R3
        CHEREC(I,nmat)=(COEFPa/ElDENSMat(nmat))*R1*R3

c       spa=0.0
c       sio=0.0
c
c       do nat=1,QAtMat(nmat)
c           do nsh=1,QShellAt(AtMat(nat,nmat))
c
c               spa=spa+PhotAt(I,nsh,nat)
c               sio=sio+PhotIonAt(I,nsh,nat)
c
c           enddo
c       enddo
c       if(spa.gt.0.0)then
c           CHEREC(I,nmat)=CHEREC(I,nmat)*sio/spa
c       endif
300   continue

c               debug:
c       write(oo,*)' probb'
c       do nen=1,qener
c
c       R=log1C(nen,nmat)*coefPa*PhotIonMat(nen,nmat)
c     +         /(enerc(nen)*Z_Mean(nmat))
c       if(PhotMat(nen,nmat).gt.0.0)then
c       R1= R + PhotIonMat(nen,nmat)/PhotMat(nen,nmat)*CHEREC(nen,nmat)
c       endif
c       r2=r1+log2C(nen,nmat)*coefPa*PhotIonMat(nen,nmat)
c     +          /(enerc(nen)*Z_Mean(nmat))
c       write(oo,'(5E10.3)')enerc(nen),R,CHEREC(nen,nmat),R1,r2
c
c       enddo
c               end debug


        nshc=0
        do 800 nat=1,QAtMat(nmat)
            
            do 700 nsh=1,QShellAt(AtMat(nat,nmat))

                nshc=nshc+1

                NAtMC(nshc,nmat)=nat
                NAtAC(nshc,nmat)=AtMat(nat,nmat)
                NSheC(nshc,nmat)=nsh    

                do 400 nen=1,qener

                    flog1(nen,nshc,nmat)=
     +              WeightAtMat(nat,nmat)*log1C(nen,nmat)*coefPa*
     +              PhotIonAt(nen,nsh,AtMat(nat,nmat))/
     +              (enerc(nen)*Z_Mean(nmat))

                    flog2(nen,nshc,nmat)=
     +              WeightAtMat(nat,nmat)*log2C(nen,nmat)*coefPa*
     +              PhotIonAt(nen,nsh,AtMat(nat,nmat))/
     +              (enerc(nen)*Z_Mean(nmat))

                    if(PhotMat(nen,nmat).gt.0.0)then

                    cher(nen,nshc,nmat)= chereC(nen,nmat)*
     +                  WeightAtMat(nat,nmat)*
     +                  PhotIonAt(nen,nsh,AtMat(nat,nmat))/
     +                  PhotMat(nen,nmat)
c     +             WeightAtMat(nat,nmat)*chereC(nen,nmat)*
c     +             WeightShAt(nsh,AtMat(nat,nmat))

                    else

                    cher(nen,nshc,nmat)=0.0

                    endif

400             continue

                s=0

                do 500 nen=1,qener

                    r=PhotAt(nen,nsh,AtMat(nat,nmat))*WeightAtMat(nat,nmat)*
     +              (ener(nen+1)-ener(nen))
                    rezer(nen,nshc,nmat)=s+0.5*r
                    if(enerc(nen).gt.MinThresholdAt(AtMat(nat,nmat))
     +                  .and.
     +                  enerc(nen).lt.emax)then         ! kinematical limit
                      if(s_pri_elec.eq.0)then
                        frezer(nen,nshc,nmat)=(s+0.5*r)*coefPa/
     +                  (enerc(nen)*enerc(nen)*Z_Mean(nmat))*
     +                  (1.0-beta2*enerc(nen)/emax + 
     +                  enerc(nen)*enerc(nen)/
     +                  (2.0*(tkin+mass)*(tkin+mass)))
                      else
                        delta=enerc(nen)/mass
                        pg=partgamma
                        pg2=pg*pg
                        frezer(nen,nshc,nmat)=(s+0.5*r)*coefPa/
     +                  Z_Mean(nmat) * beta2/mass *
     +                  1.0/(pg2-1) *
     +                  ((pg-1)**2 * pg2 / ((delta*(pg-1-delta))**2)
     +                  -
     +                  (2*pg2 + 2*pg - 1)/
     +                  (delta*(pg-1-delta))
     +                  + 1 )
                        
                      endif
                    else
                        frezer(nen,nshc,nmat)=0.0
                    endif
                    s=s+r

500             continue

700         continue

800     continue

        QShellC(nmat)=nshc
        r=0.0

c       add cherenkov radiation to lowest energy level shell
c       nat0=NAtAC(1)
c       iat=1
c       nat1=nat0
c       nsh=NSheC(1)
c       i=1
c850    do nshc=1,QShellC
c         if(NAtAC(nshc).eq.nat0)then
c           if(NSheC(nshc).gt.nsh)then
c             nsh=NSheC(nshc)
c             i=nshc
c           endif
c         else
c           if(nshc.gt.iat.and.nat1.eq.nat0)then
c             iat=nshc
c             nat1=NAtAC(nshc)
c           endif
c         endif
c       enddo
c       write(oo,*)' crosec: i,nat0,nat1,nmat,iat='
c       write(oo,*)i,nat0,nat1,nmat,iat
c       if(nat1.gt.nat0)then
c               nat=nat1
c               go to 850
c       endif

c       The cherenkov is added to last shell
c       i=0
c       do nat=1,QAtMat(nmat)
c       i=i+QShellAt(AtMat(nat,nmat))
c       do nen=1,qener
c                   cher(nen,i,nmat)=
c     +             WeightAtMat(nat,nmat)*chereC(nen,nmat)
cc                  write(oo,*)cher(nen,i),WeightAtMat(nat,nmat),
cc     +                        chereC(nen)
c       enddo
c       enddo

                  
        do 1000 nen=1,qener

            s=0.0
            sa=0.0
            k=0.0

        DO  nshc=1,QShellC(nmat)        
            ADDA(nen,nshc,nmat)=FLOG1(nen,nshc,nmat)+
     +      FLOG2(nen,nshc,nmat)+FREZER(nen,nshc,nmat)
c           ADDA(nen,nshc,nmat)=FLOG1(nen,nshc,nmat)+
c     +     FLOG2(nen,nshc,nmat)
            s=s+ADDA(nen,nshc,nmat)
        
        if(enerc(nen).gt.min_ioniz_pot(nmat))then
                ADDA(nen,nshc,nmat)=ADDA(nen,nshc,nmat)+
     +          cher(nen,nshc,nmat)
                if(ADDA(nen,nshc,nmat).lt.0.0)then
                    write(oo,*)' worning of IniCrosec: negative ADDA'
                    write(oo,*)' nmat=',nmat,' nshc=',nshc,' nen=',nen
                    ADDA(nen,nshc,nmat)=0.0
                endif
        endif
                   
        enddo

c       if(enerc(nen).gt.min_ioniz_pot(nmat))then
c           if(s.lt.-chereC(nen,nmat))then
c               DO  nshc=1,QShellC(nmat)
c                   ADDA(nen,nshc,nmat)=0.0
c               enddo
c           else
c               s=1.0+chereC(nen,nmat)/s
c               DO  nshc=1,QShellC(nmat)
c                   ADDA(nen,nshc,nmat)=ADDA(nen,nshc,nmat)*s
c               enddo
c           endif
c       endif
                
        s=0.0
        DO  nshc=1,QShellC(nmat)
            s=s+ADDA(nen,nshc,nmat)
        enddo
        ADDAC(nen,nmat)=s

            
c       DO 900 nshc=1,QShellC(nmat)
c          R=FLOG1(nen,nshc,nmat)+FLOG2(nen,nshc,nmat)+
c     +         FREZER(nen,nshc,nmat)
cc         IF(CHER(nen,nshc).LT.0.0)THEN
c            R=R+CHER(nen,nshc,nmat)
cc         END IF
c          IF(R.LT.0.0)THEN
c            K=1
c            SA=SA+R
c          ELSE
c            S=S+R
c         ENDIF
c          ADDA(nen,nshc,nmat)=R
c900    ADDAC(nen,nmat)=ADDAC(nen,nmat)+ADDA(nen,nshc,nmat)
c
c        IF(K.EQ.1)THEN
c          IF(ABS(SA).LT.S)THEN
c            DO 906 nshc=1,QShellC(nmat)
c              IF(ADDA(nen,nshc,nmat).GT.0.0)THEN
c                ADDA(nen,nshc,nmat)=ADDA(nen,nshc,nmat)*(1.0+SA/S)
c              ELSE
c                ADDA(nen,nshc,nmat)=0.0
c              END IF
c906         CONTINUE
c          ELSE
c            DO 907 nshc=1,QShellC(nmat)
c                ADDA(nen,nshc,nmat)=0.0 
c907         CONTINUE
c            ADDAC(nen,nmat)=0.0
c          END IF
c        END IF

1000    continue

       DO  nshc=1,QShellC(nmat)

            do nen=1,qener
                fadda(nen,nshc,nmat)=adda(nen,nshc,nmat)*
     +                  (ener(nen+1)-ener(nen))
            enddo

            call lhispre(fadda(1,nshc,nmat),qener)

        enddo

        quanC(nmat)=fquan(addaC(1,nmat),1.0,nmat)
        meanC(nmat)=fmean(addaC(1,nmat),1.0,nmat)

        if(s_pri_elec.eq.0)then
        meanC1(nmat)=fmean1(addaC(1,nmat),1.0,nmat)
        else
        meanC1(nmat)=0.0        ! for electrons it is not calculated
        endif

        meaneleC(nmat)=meanC(nmat)/WWW(nmat)
        meaneleC1(nmat)=meanC1(nmat)/WWW(nmat)

        do nshc=1,QShellC(nmat)
c           quan(nshc)=fquan(adda(1,nshc,nmat),
c     +         WeightAtMat(NAtMC(nshc),nmat),nmat)
c           mean(nshc)=fmean(adda(1,nshc,nmat),
c     +WeightAtMat(NAtMC(nshc),nmat),nmat)
            quan(nshc,nmat)=fquan(adda(1,nshc,nmat),1.0,nmat)
            mean(nshc,nmat)=fmean(adda(1,nshc,nmat),1.0,nmat)
        enddo

        do ne=1,qener
        eee(1)=dble(1.)+dble(epsi1(ne,nmat))
        eee(2)=dble(epsi2(ne,nmat))
c       write(oo,*)enerc(ne),eeee
        eeee=beta2*eeee - 1.0
c       write(oo,*)enerc(ne),eeee
        eeee=sqrt(eeee)
c       write(oo,*)enerc(ne),eeee
        eeee=enerc(ne)/sqrt(beta2) * eeee
c       write(oo,*)enerc(ne),eeee
        pocaz(ne,nmat)=eeee * 5.07e10
c       write(oo,*)enerc(ne),pocaz(ne,nmat)
        enddo


        end
+DECK,FQUAN.
        function fquan(ad,weig,nmat)
c
c       Calc. mean quantity of energy transfer for 1 sm
c
        implicit none

c       include 'ener.inc'
+SEQ,ener.
c       include 'atoms.inc'
+SEQ,atoms.
c       include 'matters.inc'
+SEQ,matters.

        real fquan,ad(*),weig
        integer nmat
        real step_integ_ar

        fquan=step_integ_ar(ener,ad,qener,ener(1),ener(qener+1))
        fquan=fquan*weig*XElDensMat(nmat)

        end
+DECK,FMEAN.
        function fmean(ad,weig,nmat)
c
c       Calc. mean energy loss for 1 sm
c
        implicit none

c       include 'ener.inc'
+SEQ,ener.
c       include 'atoms.inc'
+SEQ,atoms.
c       include 'matters.inc'
+SEQ,matters.

        real fmean,ad(*),weig
        integer nmat
        real step_integ_ar
        real addd(pqener)

        integer nen

        do nen=1,qener
                addd(nen)=ad(nen)*enerc(nen)
        enddo
        fmean=step_integ_ar(ener,addd,qener,ener(1),ener(qener+1))
        fmean=fmean*weig*XElDensMat(nmat)

        end
+DECK,FMEAN1.
        function fmean1(ad,weig,nmat)
c
c       Calc. mean energy loss for 1 sm
c
        implicit none

c       include 'ener.inc'
+SEQ,ener.
c       include 'atoms.inc'
+SEQ,atoms.
c       include 'matters.inc'
+SEQ,matters.
c       include 'part.inc'
+SEQ,part.
c       include 'cconst.inc'
+SEQ,cconst.

        real fmean1,ad(*),weig
        integer nmat
        real step_integ_ar
        real addd(pqener)
        real e1,e2

        integer nen

        do nen=1,qener
                addd(nen)=ad(nen)*enerc(nen)
        enddo
        fmean1=step_integ_ar(ener,addd,qener,ener(1),ener(qener+1))
        fmean1=fmean1*weig*XElDensMat(nmat)
        if(emax.gt.ener(qener+1))then
                e1=ener(qener+1)
                e2=emax
                
        fmean1 = fmean1 +
     +  2.0 * PI / (FSCON**2 * ELMAS * beta2) 
     +  * weig * XElDensMat(nmat) * 
     +  ( log(e2/e1) - bem * (e2-e1) +
     +  (e2*e2-e1*e1)/(4.0 * (tkin+mass) * (tkin+mass) ) )

        endif  

        end
+DECK,PRICROSE.
        subroutine PriCrosec(nmat,lev)

        implicit none

c         include 'GoEvent.inc'
+SEQ,GoEvent.
c       include 'ener.inc'
+SEQ,ener.
c       include 'atoms.inc'
+SEQ,atoms.
c       include 'matters.inc'
+SEQ,matters.
c       include 'part.inc'
c       include 'crosec.inc'
+SEQ,crosec.
        integer nmat
        integer lev
        integer nen
        integer nshc

        if(soo.eq.0)return

        if(lev.ge.1)then
        write(oo,*)
        write(oo,*)' PriCrosec:'
        write(oo,*)' material number ',nmat,
     +  ' Quantity of shells is',QShellC(nmat)
        if(sMatC(nmat).ne.1)then
        write(oo,*)' This cross sect. was not initialized'
        return
        endif
c       write(oo,*)' ksi=',ksi
        write(oo,*)' quanC=',quanC(nmat)
        write(oo,*)' meanC=',meanC(nmat),' meaneleC=',meaneleC(nmat)
        write(oo,*)' meanC1=',meanC1(nmat),' meaneleC1=',meaneleC1(nmat)
        do nshc=1,QShellC(nmat)
        write(oo,*)' NAtMC=',NAtMC(nshc,nmat),' NAtAC=',NAtAC(nshc,nmat),
     +  ' NSheC=',NSheC(nshc,nmat)
        write(oo,*)'      quan=',quan(nshc,nmat),' mean=',mean(nshc,nmat)
        enddo
        
c       write(oo,*)' ener,pocaz'
c       do nen=1,qener
c       write(oo,*)enerc(nen),pocaz(nen,nmat)
c       enddo   
        if(lev.ge.2)then
        write(oo,*)'  enerc,    log1C,    log2C',
     +          '    chereC,   addaC, chereCangle'
        do nen=1,qener
        write(oo,'(6e10.3)')enerc(nen),log1C(nen,nmat),log2C(nen,nmat),
     +          chereC(nen,nmat),addaC(nen,nmat),chereCangle(nen,nmat)
        enddo
        if(lev.ge.3)then
        do nshc=1,QShellC(nmat)
        write(oo,*)'  enerc,   flog1,    flog2,     cher,  ',
     +  ' rezer,    frezer,     adda,    fadda'
        do nen=1,qener
        write(oo,'(8e10.3)')enerc(nen),flog1(nen,nshc,nmat),
     +          flog2(nen,nshc,nmat),
     +          cher(nen,nshc,nmat),rezer(nen,nshc,nmat),
     +          frezer(nen,nshc,nmat),
     +          adda(nen,nshc,nmat),fadda(nen,nshc,nmat)
        enddo
        enddo
        endif
        endif
        endif

        end
+DECK,IniLsgvg.
        subroutine IniLsgvga

c       Initialize  the virt. ioniz.  photons

        implicit none


c         include 'volume.inc'
+SEQ,volume.
c       include 'lsgvga.inc'
+SEQ,lsgvga.

        integer n

        do n=1,QSVol
                qgvga(n)=0
        enddo

        end
+DECK,PRILSGVG.
        subroutine PriLsgvga

c       print the virt. ioniz.  photons

        implicit none

c         include 'GoEvent.inc'
+SEQ,GoEvent.
c       include 'volume.inc'
+SEQ,volume.
c       include 'lsgvga.inc'
+SEQ,lsgvga.

        integer k,i,j

        if(soo.eq.0)return

        write(oo,*)
        write(oo,*)' PriLsgvga: virtual ionization  photons'
        do k=1,QSVol
        write(oo,*)' number of lay =',k
        write(oo,*)' qgvga()= ',qgvga(k),' esgvga()=',esgvga(k) 
        if(qgvga(k).gt.0)then
        write(oo,*)'  egvga(i,k)  ganumat(i,k)  ganumshl(i.k)'
        write(oo,*)
     +  ' pntgvga(1,i,k)  pntgvga(2,i,k)  pntgvga(3,i,k) ',
     +  ' velgvga(1,i,k)  velgvga(2,i,k)  velgvga(3,i,k)  '
        do i=1,qgvga(k)
                write(oo,'(1X,e12.5,2(i12))')
     +          egvga(i,k),ganumat(i,k),ganumshl(i,k)
                write(oo,'(6(1X,e12.5))')(pntgvga(j,i,k),j=1,3),
     +          (velgvga(j,i,k),j=1,3)
        enddo
        endif
        enddo

        end
+DECK,Inirga.
        subroutine Inirga
c
c       Init. common with real photons
c
        implicit none

c         include 'GoEvent.inc'
+SEQ,GoEvent.
c       include 'rga.inc'
+SEQ,rga.

        qrga=0
        crga=1
        sOverflowrga=0
        if(nevt.eq.qevt)then
                qOverflowrga=0
                qsOverflowrga=0
        endif


        end
+DECK,WORPRIRG.
        subroutine WorPrirga

        implicit none

c         include 'GoEvent.inc'
+SEQ,GoEvent.
c         include 'rga.inc'
+SEQ,rga.

c        integer i,j

        if(nevt.eq.qevt)then

        if(qOverflowrga.gt.0)then
        write(oo,*)
        write(oo,*)' WorPrirga: overflow of real photons  arrays '
        write(oo,*)' sOverflowrga   qsOverflowrga   qOverflowrga'
        write(oo,*)sOverflowrga,qsOverflowrga,qOverflowrga
        endif

        endif

        end
+DECK,PRIRGA.
        subroutine Prirga

c       print the real photons

        implicit none

c         include 'GoEvent.inc'
+SEQ,GoEvent.
c       include 'rga.inc'
+SEQ,rga.

        integer i,j

        if(soo.eq.0)return
        write(oo,*)
        write(oo,*)' Prirga: real photons'
        write(oo,*)' sOverflowrga   qsOverflowrga   qOverflowrga'
        write(oo,*)sOverflowrga,qsOverflowrga,qOverflowrga

        write(oo,*)' qrga= ',qrga,' crga=',crga 
        if(crga.le.qrga)then
        write(oo,*)'  erga()    nVolrga     Strga  uprga(1)  Ptrga'
        write(oo,*)
     +  ' pntrga(1,i)  pntrga(2,i)  pntrga(3,i) ',
     +  ' velrga(1,i)  velrga(2,i)  velrga(3,i)  '
        do i=crga,qrga
                write(oo,'(1X,e12.5,4(1X,I5))')
     +          erga(i),nVolrga(i),Strga(i),uprga(1,i),Ptrga(i)
                write(oo,'(6(1X,e12.5))')(pntrga(j,i),j=1,3),
     +          (velrga(j,i),j=1,3)
        enddo
        endif

        end
+DECK,PRIRGAF.
        subroutine PrirgaF

c       print the real photons which fly out

        implicit none

c         include 'GoEvent.inc'
+SEQ,GoEvent.
c       include 'rga.inc'
+SEQ,rga.

        integer i,j

        if(soo.eq.0)return
        write(oo,*)
        write(oo,*)' Prirga: real photons which go out'
        write(oo,*)' qrga= ',qrga,' crga=',crga 
c       if(crga.le.qrga)then
        write(oo,*)'  erga()    nVolrga     Strga   Ptrga'
        write(oo,*)
     +  ' pntrga(1,i)  pntrga(2,i)  pntrga(3,i) ',
     +  ' velrga(1,i)  velrga(2,i)  velrga(3,i)  '
        do i=1,qrga
                if(SFrga(i).eq.1)then
                write(oo,'(1X,e12.5,3(1X,I5))')
     +          erga(i),nVolrga(i),Strga(i),Ptrga(i)
                write(oo,'(6(1X,e12.5))')(pntrga(j,i),j=1,3),
     +          (velrga(j,i),j=1,3)
                endif
        enddo
c       endif

        end
+DECK,Iniabs.
        subroutine Iniabs
c
c       Initialize absorbed photons
c
        implicit none

c         include 'GoEvent.inc'
+SEQ,GoEvent.
c       include 'ener.inc'
+SEQ,ener.
c       include 'abs.inc'
+SEQ,abs.

        qtagam=0
        ctagam=1
        sOverflowagam=0
        if(nevt.eq.1)then
                qOverflowagam=0
                qsOverflowagam=0
        endif

        end
+DECK,WORPRIAB.
        subroutine WorPriabs


        implicit none

c         include 'GoEvent.inc'
+SEQ,GoEvent.
c         include 'abs.inc'
+SEQ,abs.

c        integer i,j

        if(nevt.eq.qevt)then

        if(qOverflowagam.gt.0)then
        write(oo,*)
        write(oo,*)' WorPriabs: overflow of absorbtion photons  arrays '
        write(oo,*)' sOverflowagam   qsOverflowagam   qOverflowagam'
        write(oo,*)sOverflowagam,qsOverflowagam,qOverflowagam
        endif

        endif

        end
+DECK,PRIABS.
        subroutine Priabs

        implicit none

c         include 'GoEvent.inc'
+SEQ,GoEvent.
c       include 'ener.inc'
+SEQ,ener.
c       include 'abs.inc'
+SEQ,abs.

        integer i,j

        if(soo.eq.0)return
        write(oo,*)
        write(oo,*)' Priabs: virtual photons'
        write(oo,*)' sOverflowagam   qsOverflowagam   qOverflowagam'
        write(oo,*)sOverflowagam,qsOverflowagam,qOverflowagam

        write(oo,*)' qtagam= ',qtagam,' ctagam=',ctagam
        if(ctagam.le.qtagam)then
        write(oo,*)'  etagam()  nVolagam()  nAtagam()   ', 
     +          'nShlagam()  stagam()  upagam()'
        write(oo,*)
     +  ' rtagam(1,i)  rtagam(2,i)  rtagam(3,i) ',
     +  ' vtagam(1,i)  vtagam(2,i)  vtagam(3,i)  '
        do i=ctagam,qtagam
                write(oo,'(1(1X,e12.5),10(1X,i5))')
     +          etagam(i), nVolagam(i),nAtagam(i),
     +          nShlagam(i),Stagam(i),(upagam(j,i),j=1,pqup)
                write(oo,'(6(1X,e12.5))')(rtagam(j,i),j=1,3),
     +          (vtagam(j,i),j=1,3)
        enddo
        endif

        end
+DECK,rafflev.
        subroutine rafflev
c
c       The main subroutine of ionization loss generator
c       
        implicit none

c       include 'ener.inc'
+SEQ,ener.
c       include 'atoms.inc'
+SEQ,atoms.
c       include 'matters.inc'
+SEQ,matters.
c       include 'crosec.inc'
+SEQ,crosec.
c       include 'raffle.inc'
+SEQ,raffle.
c       include 'volume.inc'
+SEQ,volume.
c       include 'track.inc'
+SEQ,track.
c       include 'lsgvga.inc'
c         include 'GoEvent.inc'                                                   
+SEQ,GoEvent.

        integer nv,niv,nm
        real e

        do niv=1,QIVol
        
                nv=numVolIoni(niv)
                nm=nMatVol(nv)

                if(sign_ang.eq.0)then

                        call raffle(nm,real(wide(nv)),e)
                        call rafflevirt(nv,niv)

                else            

c                   if(sigmtk.eq.0)then
c                       call raffle(nm,real(wide(nv)/e3ang(3)),e)
c                       call rafflevirt1(nv,niv)
c                   else
                        call raffle(nm,real(vlenmtk(nv)),e)
                        call rafflevirt2(nv,niv)
c                   endif

                endif


        enddo

        end
+DECK,RAFFLEVI.
        subroutine rafflevirt(nv,niv)
        
        implicit none

        integer nv,niv

c       include 'GoEvent.inc'
+SEQ,GoEvent.
c       include 'ener.inc'
+SEQ,ener.
c       include 'atoms.inc'
+SEQ,atoms.
c       include 'matters.inc'
+SEQ,matters.
c       include 'crosec.inc'
+SEQ,crosec.
c       include 'raffle.inc'
+SEQ,raffle.
c       include 'volume.inc'
+SEQ,volume.
c       include 'lsgvga.inc'
+SEQ,lsgvga.
c       include 'abs.inc'
+SEQ,abs.

        integer i,j
        real ranfl
        real F,rr

       esgvga(niv)=ESGRaf
       do i=1,QGRaf
                egvga(i,niv)=EGRaf(i)
                pntraf(1,i)=0.0
                pntraf(2,i)=0.0
                rr=ranfl()
                pntraf(3,i)=wall1(nv)+rr*wide(nv)
                F=3.14159*2.0*ranfl()
                velraf(1,i)=cos(F)
                velraf(2,i)=sin(F)
                velraf(3,i)=0.0
            if(i.le.pqgvga)then
                egvga(i,niv)=EGRaf(i)
                do j=1,3
                        pntgvga(j,i,niv)=pntraf(j,i)
                        velgvga(j,i,niv)=velraf(j,i)
                enddo
                ganumat(i,niv)=NAtGRaf(i)
                ganumshl(i,niv)=NShAtGRaf(i)
            endif

            if(qtagam .eq. pqtagam)then
                qOverflowagam=qOverflowagam+1
                if(sOverflowagam.eq.0)then
                   qsOverflowagam=qsOverflowagam+1
                   sOverflowagam=1
                endif
            else
                qtagam=qtagam+1
                etagam(qtagam)=EGRaf(i)
                do j=1,3                                 
                        rtagam(j,qtagam)=pntraf(j,i)
                        vtagam(j,qtagam)=velraf(j,i)
                enddo
                nVolagam(qtagam)=nv
                nAtagam(qtagam)=NAtGRaf(i)
                nShlagam(qtagam)=NShAtGRaf(i)
                Stagam(qtagam)=1
            endif
        enddo

        end
+DECK,RAFFLEV2.
        subroutine rafflevirt2(nv,niv)
        
        implicit none

        integer nv,niv

c         include 'GoEvent.inc'
+SEQ,GoEvent.
c       include 'ener.inc'
+SEQ,ener.
c       include 'atoms.inc'
+SEQ,atoms.
c       include 'matters.inc'
+SEQ,matters.
c       include 'crosec.inc'
+SEQ,crosec.
c       include 'raffle.inc'
+SEQ,raffle.
c       include 'volume.inc'
+SEQ,volume.
c       include 'track.inc'
+SEQ,track.
c       include 'lsgvga.inc'
+SEQ,lsgvga.
c       include 'abs.inc'
+SEQ,abs.

        integer i,j,nmt,nmta
        real ranfl
        real*8 rr
        real*8 rrr

       esgvga(niv)=ESGRaf
        if(QGRaf.le.pqgvga)then
                qgvga(niv)=QGRaf
        else
                qgvga(niv)=pqgvga
        endif
       do i=1,QGRaf
                rr=ranfl()
                rr=rr*vlenmtk(nv)
                rrr=rr
                do nmt=nmtkvol1(nv),nmtkvol2(nv)
                    if(rrr.le.lenmtk(nmt))then
                        do j=1,3
                        pntraf(j,i)=pntmtk(j,nmt)+rrr*velmtk(j,nmt)
                        enddo
                        nmta=nmt
                        go to 10
                    else
                        rrr=rrr-lenmtk(nmt)
                    endif
                enddo
                write(oo,*)' worning in rafflevirt2: strange step'
                        nmta=nmtkvol2(nv)
                        do j=1,3
                        pntraf(j,i)=pntmtk(j,nmta)+
     +                          vlenmtk(nv)*velmtk(j,nmta)
                        enddo

10              continue

                call Ncirclesim(
     +          e1mtk(1,nmta),e2mtk(1,nmta),e3mtk(1,nmta),
     +          velraf(1,i))

            if(i.le.pqgvga)then
                egvga(i,niv)=EGRaf(i)
                do j=1,3
                        pntgvga(j,i,niv)=pntraf(j,i)
                        velgvga(j,i,niv)=velraf(j,i)
                enddo
                ganumat(i,niv)=NAtGRaf(i)
                ganumshl(i,niv)=NShAtGRaf(i)
            endif

c               write(oo,*)' rafflevirt1:'
c               write(oo,*)(rst(j),j=1,3)
c               write(oo,*)(wid(j),j=1,3)
c               write(oo,*)(pntgvga(j,i,nsv),j=1,3)
c               write(oo,*)(vel(j),j=1,3)
c               write(oo,*)(velgvga(j,i,nsv),j=1,3)
c                ganumat(i,niv)=NAtGRaf(i)
c                ganumshl(i,niv)=NShAtGRaf(i)

            if(qtagam .eq. pqtagam)then
                qOverflowagam=qOverflowagam+1
                if(sOverflowagam.eq.0)then
                   qsOverflowagam=qsOverflowagam+1
                   sOverflowagam=1
                endif
            else
                qtagam=qtagam+1
                etagam(qtagam)=EGRaf(i)
                do j=1,3
                        rtagam(j,qtagam)=pntraf(j,i)
                        vtagam(j,qtagam)=velraf(j,i)
                enddo
                nVolagam(qtagam)=nv
                nAtagam(qtagam)=NAtGRaf(i)
                nShlagam(qtagam)=NShAtGRaf(i)
                Stagam(qtagam)=1
            endif
        enddo   !i=1,QGRaf

        end
+DECK,RAFFLE.
        subroutine raffle(nm,x,e)
        
        implicit none

c         include 'GoEvent.inc'
+SEQ,GoEvent.
c       include 'ener.inc'
+SEQ,ener.
c       include 'atoms.inc'
+SEQ,atoms.
c       include 'matters.inc'
+SEQ,matters.
c       include 'crosec.inc'
+SEQ,crosec.
c       include 'raffle.inc'
+SEQ,raffle.

        integer nm
        real x
        real e


        integer nshc,n,ierror
        real eran
        real xran,dran
        integer iran
        integer rquan

        QGRaf=0
        e=0.0

        do nshc=1,QShellC(nm)

            call lspois(quan(nshc,nm)*x,rquan,ierror)
            if(ierror.ne.0)then
                write(oo,*)' error in raffle: lspois returned ',
     +          'sign of error,'
                write(oo,*)' quan(nshc,nm)*x=',quan(nshc,nm)*x
                write(oo,*)' quan(nshc,nm)=',quan(nshc,nm)
                write(oo,*)' x=',x
                write(oo,*)' nshc=',nshc,' nm=',nm 
                stop 'error in poisson'
            endif

            do n=1,rquan

                if(QGRaf.eq.pQGRaf)then
                    write(oo,*)' Worning og raffle: too much ',
     +              ' photons: QGRaf=',QGRaf
                    write(oo,*)' other wiil be ignored'
                    go to 10
                endif

                QGRaf=QGRaf+1

        
                call lhisran(fadda(1,nshc,nm),qener,1.0,1.0,xran)       
        
                iran=xran
                if(iran.lt.1.or.iran.gt.qener)then
                    write(oo,*)' Worning of raffle: iran=',iran,
     +                  ' xran=',xran
                    if(iran.lt.1)then
                        iran=1
                    else
                        iran=qener
                    endif
                endif
                dran=xran-iran
                eran=ener(iran)+(ener(iran+1)-ener(iran))*dran
c               if(nshc.eq.1)then
c               write(oo,*)' xran,iran,dran=',xran,iran,dran
c               write(oo,*)' ener(iran),ener(iran+1),eran=',
c    +                  ener(iran),ener(iran+1),eran
c               endif
                e=e+eran
                EGRaf(QGRaf)=eran
                NAtGRaf(QGRaf)=NAtAC(nshc,nm)
                NShAtGRaf(QGRaf)=NSheC(nshc,nm)

            enddo

        enddo

10      continue

        ESGraf=e

        end
+DECK,PRIRAFFL.
        subroutine PriRaffle

c       print the virt. ioniz.  photons

        implicit none

c         include 'GoEvent.inc'
+SEQ,GoEvent.
c         include 'raffle.inc'
+SEQ,raffle.

        integer i

        if(soo.eq.0)return
        write(oo,*)
        write(oo,*)' PriRaffle: virt. ioniz.  photons'
        write(oo,*)' QGRaf= ',QGRaf,' ESGRaf=',ESGRaf
        if(QGRaf.gt.0)then
        write(oo,*)'  EGRaf(i)  NAtGRaf(i)  NShAtGRaf(i)'
        do i=1,QGRaf
                write(oo,'(1X,e12.5,2(i12))')
     +          EGRaf(i),  NAtGRaf(i),  NShAtGRaf(i)
        enddo                                                                   
        endif

        end
+DECK,GoGam.
        subroutine GOGam

c       make absorption of the real photon 
c        and pass it to the virt photon 

        implicit none

c       include 'GoEvent.inc'
+SEQ,GoEvent.
c       include 'abs.inc'
+SEQ,abs.
c       include 'rga.inc'
+SEQ,rga.
        integer i,j
        integer isabs,nmat,nmshl
c       real*8 curpnt(3)
c       real dnst
        integer num

        do i=crga,qrga
c               do j=1,3
c                       curpnt(j)=pntrga(j,i)
c               enddo
                num=nVolrga(i)
                call lsta_abs1
     +          (erga(i),i,pntrga(1,i),velrga(1,i),num,
     +          isabs,nmat,nmshl)
                if(isabs.eq.1)then
                   if(qtagam .eq. pqtagam)then
                        qOverflowagam=qOverflowagam+1
                        if(sOverflowagam.eq.0)then
                            qsOverflowagam=qsOverflowagam+1
                            sOverflowagam=1
                        endif
                   else
                        qtagam=qtagam+1
                        etagam(qtagam)=erga(i)
                        do j=1,3
c                               rtagam(j,qtagam)=curpnt(j)
                                rtagam(j,qtagam)=pntrga(j,i)
                                vtagam(j,qtagam)=velrga(j,i)
                        enddo
                        nVolagam(qtagam)=num
                        nAtagam(qtagam)=nmat
                        nShlagam(qtagam)=nmshl
                        Stagam(qtagam)=Strga(i)
c                       densi(qtagam)=dnst
                    endif
                else
                        SFrga(i)=1
                endif
        enddo
        crga=qrga+1
        end             
+DECK,LSTAABS1.
        subroutine lsta_abs1(eg,nrga,curpnt,veloc,num,isabs,nmat,nmshl)

c       make step to end of matter or to absorption point
c       curpnt - current point of photon
c       veloc - cosine
c       num - number of volume
c       isabs - sign of absorbtion
 
        implicit none

c       include 'GoEvent.inc'
+SEQ,GoEvent.
c       include 'abs.inc'
+SEQ,abs.

        real eg,veloc(3)
        real*8 curpnt(3)
        integer num
        integer nrga,isabs,nmat,nmshl
c       real dnst
        integer i
        real*8 mleng,xleng


        do i=1,1000     ! number of mat is about 10
        
        isabs=0
        if(i.eq.1.and.num.ne.0)goto 10
        call VolNumZcoor(curpnt(3),veloc(3),num)
10      if(num.eq.0)return
        call VolPathLeng(curpnt(3),veloc,num,mleng)
c       write(oo,*)' num=',num,' mleng=',mleng
        call lsta_abs(eg,nrga,num,mleng,isabs,xleng,nmat,nmshl)
        curpnt(1)=curpnt(1)+xleng*veloc(1)
        curpnt(2)=curpnt(2)+xleng*veloc(2)
        curpnt(3)=curpnt(3)+xleng*veloc(3)

        if(isabs.eq.1)return

        enddo

        end


        subroutine lsta_abs(eg,nrga,nvol,mleng,
     +          isabs,xleng,nm_at,nmshl)

c       Raffle the absorbtion in volume number nvol
c       eg - energy of the photon
c       isabs - sign of absorbtion
c       xleng - coord of point of absorbtion
c       nm_at and nmshl - numbes of the atom and the shell  
        implicit none

c       include 'GoEvent.inc'
+SEQ,GoEvent.
c       include 'ener.inc'
+SEQ,ener.
c       include 'atoms.inc'
+SEQ,atoms.
c       include 'matters.inc'
+SEQ,matters.
c       include 'volume.inc'
+SEQ,volume.
c       include 'rga.inc'
+SEQ,rga.
c       include 'shl.inc'
+SEQ,shl.

        real eg
        real*8 xleng,mleng
        integer nrga,nvol,isabs,nm_at,nmshl
        integer nmat
c       real dnst
        real rrr(100)
        integer iarrr(100),isrrr(100)
        integer ia,is
        real r,s
        real ranfl
        integer i,j,k
c       integer n
        real thr
        integer iatm,natm

                nmat=nMatVol(nvol)      

        if(nmat.eq.0)then
                isabs=0
                xleng=mleng
                return
        endif

        r=ranfl()
        if(r.gt.0.99999)then
                isabs=0
                xleng=mleng
                return
        endif
        j=qener+1
        do i=2,qener+1
                if(eg.lt.ener(i))then
                        j=i-1
                        go to 10
                endif
        enddo
        if(j.eq.qener+1)then
                isabs=0
                xleng=mleng
                return
        endif
10      k=0
        s=0
        do ia=1,QAtMat(nmat)
        do iatm=1,qatm
                if(Zat(AtMat(ia,nmat)).eq.charge(iatm))then
                        natm=iatm
                        go to 15
                endif
        enddo
        natm=0
15      do is=1,QShellAt(AtMat(ia,nmat))
c               write(oo,*)
c     +         ' ia,AtMat(ia,nmat),is,ThresholdAt(is,AtMat(ia,nmat))='
c               write(oo,*)
c     +         ia,AtMat(ia,nmat),is,ThresholdAt(is,AtMat(ia,nmat))
                if(natm.eq.0)then
                        thr=ThresholdAt(is,AtMat(ia,nmat))
                else
                        thr=eshell(natm,is)
                endif
                if(eg.gt.thr)then
                        k=k+1
                        rrr(k)=PhotAt(j,is,AtMat(ia,nmat))
     +                  *WeightAtMat(ia,nmat)

                        iarrr(k)=ia
                        isrrr(k)=is
                        s=s+rrr(k)
c                       write(oo,*)' PhotAt(j,is,AtMat(ia,nmat))=',
c     +                             PhotAt(j,is,AtMat(ia,nmat))
c                       write(oo,*)' WeightAtMat(ia,nmat)=',
c     +                             WeightAtMat(ia,nmat)
c                       write(oo,*)' s=',s
                endif
        enddo
        enddo
c       write(oo,*)(rrr(i),i=1,3)
        if(k.eq.0)then
                isabs=0
                xleng=mleng
                return
        endif   
        s=s* ElDensMat(nmat)/Z_Mean(nmat) *5.07E10
        xleng=-alog(1.0-r)/s
                
c       write(oo,*)' xleng=',xleng,' r=',r,' j=',j,' nmat=',nmat
c       write(oo,*)' k=',k,' eg=',eg,' s=',s
        if(xleng.gt.mleng)then
                isabs=0
                xleng=mleng
        else
                isabs=1
c               r=ranfl()
                call lhispre(rrr,k)
c               write(oo,*)(rrr(i),i=1,3)
                call lhisran(rrr,k,1.0,1.0,r)
c               write(oo,*)'  r=',r
                i=r
                if(i.lt.1) i=1
                if(i.gt.k)i=k
                nm_at=AtMat(iarrr(i),nmat)
                nmshl=isrrr(i)
c               write(oo,*)'  i=',i

c               write(oo,*)' nm_at=',nm_at,' nmshl=',nmshl  
c               dnst=densit(nmat)  

        endif

        end

+DECK,AbsGam.
 

        subroutine AbsGam

c       make absorption in the knowing point 
c               of the all photons in the abs.inc
c       All of them are transferred to the real photons rga.inc
c               and to the delta electrons del.inc
        implicit none

c       include 'GoEvent.inc'
+SEQ,GoEvent.
c       include 'abs.inc'
+SEQ,abs.

c       real eg,veloc(3),abspnt(3)
c       integer numat,numshl
        integer i
        do i=ctagam,100000
                if(i.gt.qtagam)go to 10
                call lsta_abs3
     +          (i,etagam(i),rtagam(1,i),vtagam(1,i),
     +          nVolagam(i),nAtagam(i),nShlagam(i),Stagam(i),upagam(1,i))

        enddo
10      ctagam=qtagam+1
        end


        subroutine lsta_abs3(iagam,eg,abspnt,veloc,
     +          nVolagam,nAtagam,nShlagam,Stagam,upagam)

c       make absorption in the knowing point 
c       and generate secondaries photons and delta electrons
c       eg - enegy of photon
c       abspnt - point of absorbtion
c       nVolagam - number of  matter
c       nAtagam - number of  atom
c       nShlagam - number of shell
c       Stagam - sign of source of this photon
c       veloc - direction of veloc.

        implicit none

c         include 'GoEvent.inc'
+SEQ,GoEvent.
c       include 'rga.inc'
+SEQ,rga.
c       include 'del.inc'
+SEQ,del.
c       include 'shl.inc'
+SEQ,shl.

        integer iagam
        real eg,veloc(3)
        real*8 abspnt(3)
        integer nVolagam,nAtagam,nShlagam,Stagam,upagam(pqup)
        real eedel(pqsel),velocdel(3,pqsel)
        real eedga(pqsga),velocdga(3,pqsga)
        integer nndel,nndga
        
        integer i,j
        real s

        call lsta_abs2(eg,abspnt,veloc,nVolagam,nAtagam,nShlagam,
     +          nndel,eedel,velocdel,nndga,eedga,velocdga)

        if(nndga.gt.0.and.Stagam.eq.9999)then
                write(oo,*)' Worning of lsta_abs3:'
                write(oo,*)' too many generetion of secondary ',
     +          ' photons, Stagam=',Stagam,' nndga=',nndga
                write(oo,*)' Others will be ignored'
                go to 10
        endif

        s=0.0
        do i=1,nndel
                s=s+eedel(i)
        enddo
        do i=1,nndga
                s=s+eedga(i)
        enddo
c       if(s.gt.eg)then
        if( (s-eg) .gt. 1.0e-6 * (s+eg) )then
                write(oo,*)'worning of lsta_abs3:',
     +          ' break of energy preservation'
                write(oo,*)' eg=',eg,' s=',s
                write(oo,*)' nAtagam=',nAtagam,' nShlagam',nShlagam
                write(oo,*)' nndel=',nndel
                do i=1,nndel
                        write(oo,*)' eedel(i)=',eedel(i)
                enddo
                do i=1,nndga
                        write(oo,*)' eedga(i)=',eedga(i)
                enddo
        endif
        

        do i=1,nndga

            if(qrga .eq. pqrga)then
                qOverflowrga=qOverflowrga+1
                if(sOverflowrga.eq.0)then
                    qsOverflowrga=qsOverflowrga+1
                    sOverflowrga=1
                endif
            else

                qrga=qrga+1

c               if(qrga.eq.pqrga)then
c                   write(oo,*)' wroning lsta_abs3:',
c     +                 ' too much of real photons'
c                   write(oo,*)' other will  be ignored'                        
c                   go to 10
c               endif
                
                Strga(qrga)=Stagam+1
                Ptrga(qrga)=iagam
                do j=1,pqup
                        uprga(j,qrga)=upagam(j)
                enddo
                SFrga(qrga)=0
                do j=1,3
                        pntrga(j,qrga)=abspnt(j)
                enddo
                do j=1,3
                        velrga(j,qrga)=velocdga(j,i)
                enddo
                erga(qrga)=eedga(i)
                nVolrga(qrga)=nVolagam
            endif
        enddo
10      continue
c       write(oo,*)' nndel=',nndel
        do i=1,nndel
            if(qdel .eq. pqdel)then
                qOverflowDel=qOverflowDel+1
                if(sOverflowDel.eq.0)then
                    qsOverflowDel=qsOverflowDel+1
                    sOverflowDel=1
                endif
            else

c               if(qdel.eq.pqdel)then
c                   write(oo,*)' wroning lsta_abs3:',
c     +                 ' too much of delta electr.'
c                   write(oo,*)' other will not be taken into account'
c                   go to 20
c               endif
                qdel=qdel+1
                Stdel(qdel)=Stagam
                Ptdel(qdel)=iagam
                do j=1,pqup
                        updel(j,qdel)=upagam(j)
                enddo
                if(i.eq.1)then
                        SOdel(qdel)=0
                else
                        SOdel(qdel)=1
                endif
                do j=1,3
                        pntdel(j,qdel)=abspnt(j)
                enddo
                do j=1,3
                        veldel(j,qdel)=velocdel(j,i)
                enddo
                edel(qdel)=eedel(i)
                nVoldel(qdel)=nVolagam
                rangepdel(qdel)=0.0
                rangedel(qdel)=0.0
            endif
        enddo


20      end

        
        subroutine lsta_abs2(eg,abspnt,veloc,nVolagam,nAtagam,nShlagam,
     +          nndel,eedel,velocdel,nndga,eedga,velocdga)


c       make absorption in the knowing point 
c       and generate secondaries photons and delta electrons
c       eg - enegy of photon
c       abspnt - point of absorbtion
c       veloc - direction of veloc.
c       nVolagam - number of  matter
c       nAtagam - number of  atom
c       nShlagam - number of shell
c       output:
c       nndel - quantity of delta-electrons
c       eedel - enegies of the delta-electrons 
c       velocdel - enegies of the delta-electrons 
c       nndga,eedga,velocdga - the same for secondary photons
 
        implicit none

c       include 'shl.inc'
+SEQ,shl.
c       include 'ener.inc'
+SEQ,ener.
c       include 'atoms.inc'
+SEQ,atoms.

        real eg,veloc(3)
        real*8 abspnt(3)
        integer nVolagam,nAtagam,nShlagam
        real eedel(pqsel),velocdel(3,pqsel)
        real eedga(pqsga),velocdga(3,pqsga)
        integer nndel,nndga

        integer num
        integer numat,numshl
        integer i,j
        real r
        real hdist
        
        real ranfl

        hdist=0.0
c       if(numat.lt.0.or.numat.gt.qatm)then
c               stop 'wrong numat'
c       endif
c       if(numat.gt.0)then
c               if(numshl.lt.1.or.numshl.gt.qshl(numat))then
c                       stop 'wrong numshl'
c               endif
c       endif


        num=0
c       call lsta_fmat(abspnt(3),veloc(3),num)
        nndel=0
        nndga=0
c       write(oo,*)' num=',num
        if(nVolagam.eq.0)then
                return
        endif
        
        nndel=1
        do i=1,3
                velocdel(i,nndel)=veloc(i)
        enddo
        do i=1,qatm
c               write(oo,*)' Zat(nAtagam)',Zat(nAtagam)
c               write(oo,*)' charge(i)',charge(i)
                if(Zat(nAtagam).eq.charge(i))then
                        numat=i
                        go to 5
                endif
        enddo
c               The place of question
c               Several lines was commented
                eedel(nndel)=eg-ThresholdAt(nShlagam,nAtagam)
                if(eedel(nndel).le.0.0)then
                        hdist=-eedel(nndel)
                        eedel(nndel)=0.0
                endif
c
c       write(oo,*)' nShlagam=',nShlagam,
c     + ' QShellAt(nAtagam)=',QShellAt(nAtagam)
        if(nShlagam.lt.QShellAt(nAtagam))then
                nndel=nndel+1
                eedel(nndel)=ThresholdAt(nShlagam,nAtagam)-hdist-
     +          2.0*ThresholdAt(QShellAt(nAtagam),nAtagam)
c               eedel(nndel)=ThresholdAt(nShlagam,nAtagam)-hdist
                if(eedel(nndel).le.0.0)then
                                nndel=nndel-1
                                goto 2
                endif
                call sfersim(velocdel(1,nndel))
        endif
2       continue
        return

5       continue

c               asumed that the last shell is zero energy or 1 eV
c       if(nAtagam.ne.0)then
                eedel(nndel)=eg-eshell(nShlagam,numat)
c       write(oo,*)' eg=',eg,' nShlagam=',nShlagam,' numat=',numat
c       write(oo,*)' eedel(nndel)=',eedel(nndel)
c       else
c               eedel(nndel)=eg-20.0e-6 !avarege energy of last shell
c       endif

        if(eedel(nndel).le.0.0)then
                hdist=-eedel(nndel)
                eedel(nndel)=0.0
        endif
        
c       if(numat.gt.0)then
        numshl=nShlagam
        if(qschl(numshl,numat).gt.0)then


                r=ranfl()
                j=qschl(numshl,numat)

                if(j.gt.0)then
                        j=qschl(numshl,numat)
                        do i=1, qschl(numshl,numat)
                                if(r.lt.secprobch(i,numshl,numat))then
                                        j=i
                                        go to 10
                                endif
                        enddo
10                      continue
c                       write(oo,*)' prob: r=',r,' j=',j

                        do i=1,qsel(j,numshl,numat)
                                nndel=nndel+1
                                eedel(nndel)=secenel(i,j,numshl,numat)
     +                          -hdist
                                if(eedel(nndel).lt.0)then
                                        hdist=-eedel(nndel)
                                        eedel(nndel)=0.0
                                else
                                        hdist=0.0
                                endif
                                call sfersim(velocdel(1,nndel))
                        enddo
                        do i=1,qsga(j,numshl,numat)
                                nndga=nndga+1
                                eedga(nndga)=secenga(i,j,numshl,numat)
     +                          -hdist
                                if(eedga(nndga).lt.0)then
                                        hdist=-eedga(nndga)
                                        eedga(nndga)=0.0
                                else
                                        hdist=0.0
                                endif
                                call sfersim(velocdga(1,nndga))
                        enddo

                endif
        else
                if(nShlagam.lt.QShellAt(nAtagam))then
                        nndel=nndel+1
                        eedel(nndel)=eshell(nShlagam,numat)-hdist-
     +                  2.0*eshell(qshl(numat),numat)
                        if(eedel(nndel).le.0.0)then
                                nndel=nndel-1
                                goto 20
                        endif
                        call sfersim(velocdel(1,nndel))
                endif
20              continue

        endif           
        
c       endif
        
        end
+DECK,IniBdel5.
 

c
c       Package for tracing of delta-electrons.
c


        subroutine InisBdel

c
c       This is routine for standart initialization.
c       It is strictly recommended.
c
c        call IniBdel(1,0.0001, 0.00005*4.0e-3, 0.1)
        call IniBdel(2,0.0001, 0.001*4.0e-3, 0.1)

        end


        subroutine IniBdel(psruthBdel,peMinBdel,pmlamBdel,pmTetacBdel)
c
c       Initialization of the delta-eleectron tracing package
c
        implicit none

c         include 'GoEvent.inc'
+SEQ,GoEvent.
c       include 'ener.inc'
+SEQ,ener.
c       include 'atoms.inc'
+SEQ,atoms.
c       include 'matters.inc'
+SEQ,matters.
c       include 'crosec.inc'
+SEQ,crosec.
c       include 'volume.inc'
+SEQ,volume.
c       include 'bdel.inc'
+SEQ,bdel.
c       include 'cconst.inc'
+SEQ,cconst.

        integer psruthBdel
        real peMinBdel,pmlamBdel,pmTetacBdel
        integer n,nm,na,na1,nen
        real dedx1,sde,sde2
c       real dedx,dedx2
        real rms,rm(pQAt),adens
        real mT,A
        real*8 B,r
        real msig,x
        integer sienred
        real rr,ek,cor
        real fcalcsCBdel
c       real s
        integer nang
        integer nprev, nnext, qempt
        integer nempt(pqAt),nqe
        real*8 k,c
        real*8 f1,f2,z1,z2
        integer nam
        real*8 sd,st,st1
        integer n1,n2,nener


        sruthBdel=psruthBdel
        eMinBdel=peMinBdel
        mlamBdel=pmlamBdel
        mTetacBdel=pmTetacBdel
        if(eMinBdel.lt.ener(1))then
                write(oo,*)' eMinBdel is too small, eMinBdel=',eMinBdel
                stop
        endif
c       do n=2,qener
c               if(eMinBdel.lt.ener(n))then
c                       iMinBdel=n-1
c                       go to 10
c               endif
c       enddo
c       write(oo,*)' worning: eMinBdel is too hige, eMinBdel=',eMinBdel
c       iMinBdel=qener+1
c10     continue
        do n=1,3
                e1Bdel(n)=0.0
                e2Bdel(n)=0.0
                e3Bdel(n)=0.0
        enddo
        sturnBdel=0.0
        do nm=1,pQMat
                do nen=1,qener
                        TetacBdel(nen,nm)=0.0
                enddo
        enddo
        TetaBdel=0.0
c       do n=iMinBdel,qener
c               call IniPart(enerc(n),0.511)
c               call IniCrosec
        do nm=1,pQMat
          if(qAtMat(nm).gt.0)then
c           if(sMatC(nm).gt.0)then
              rms=0.0
              do na=1,QAtMat(nm)
                rms=rms+Aat(AtMat(na,nm))*WeightAtMat(na,nm)
              enddo
              do na=1,QAtMat(nm)
                rm(na)=Aat(AtMat(na,nm))*WeightAtMat(na,nm)/rms
              enddo
              sienred=0
              do n=qener+1,1,-1
                if(sienred.eq.0)then
                  sde=0.0
                  sde2=0.0
                  do na=1,QAtMat(nm)
                    adens=DensMat(nm)*rm(na)
c                   write(oo,*)' adens=',adens
*                   call lsrelp(
*     +             Aat(AtMat(na,nm)),float(Zat(AtMat(na,nm))),adens,
*     +             2000.0*ener(n)/1000.0,dedx)
*                   if(dedx.lt.0.0)dedx=0.0

*                   call lsrelm(
*     +             Aat(AtMat(na,nm)),float(Zat(AtMat(na,nm))),adens,
*     +             105.65/0.511*ener(n)/1000.0,dedx2)
*                   if(dedx2.lt.0.0)dedx2=0.0

*                   sde=sde+dedx*adens
*                   sde2=sde2+dedx2*adens

                  enddo
*                 sde=sde*1000.0
*                 sde2=sde2*1000.0
                                                            

c                           call lsrelp(
c     +                     A_Mean(nm),Z_Mean(nm),DensMat(nm),
c     +                     2000.0*enerc(n)/1000.0,dedx)
c                           dedx=dedx*DensMat(nm)*1000.0
c                 eLossBdel(n,nm)=sde
                  call lstREL1(ener(n)/1000.0, -1.0, nm, dedx1)
                  dedx1=dedx1*1000.0
                  eLossBdel(n,nm)=dedx1
c                 write(oo,*)' n=',n,' nm=',nm,' ener(n)=',ener(n)
c                 write(oo,*)' sde=',sde,
c     +                         ' dedx1=',dedx1 ,' sde2=',sde2    
                  if(n.lt.qener)then
                    if(eLossBdel(n,nm).lt.0.5*eLossBdel(n+1,nm))then
                      sienred=1
                      eLossBdel(n,nm)=0.5*eLossBdel(n+1,nm)
                    endif
                  endif
                else
                  eLossBdel(n,nm)=eLossBdel(n+1,nm)
                endif
              enddo
c           endif
          endif
        enddo
c       stop    

        do nen=1,qener
        beta2Bdel(nen)=
     +  (2.0*ELMAS*enerc(nen) + enerc(nen)*enerc(nen)) /
     +  ((ELMAS + enerc(nen)) * (ELMAS + enerc(nen)))
        betaBdel(nen) = sqrt(beta2Bdel(nen))
        momentum2Bdel(nen)= enerc(nen)*enerc(nen) + 2.0*ELMAS*enerc(nen)
        momentumBdel(nen) = sqrt(momentum2Bdel(nen))
        enddo
            
        if(sruthBdel.ne.2)then

        do nm=1,pQMat
        if(qAtMat(nm).gt.0)then
        do nen=1,qener

        ek=enerc(nen)*1000.0
        if(ek.le.10.0)then
        rr=1.0e-3 * A_Mean(nm)/Z_Mean(nm) * 3.872e-3 * ek ** 1.492
        rr=rr/DensMat(nm)
        else
        rr=1.0e-3 * 6.97e-3 * ek ** 1.6
        rr=rr/DensMat(nm)
        endif
        rr=rr*0.1
        call correctBdel(enerc(nen),cor)

        if(sruthBdel.eq.1)then
        
        lamBdel=mlamBdel/DensMatDS(nm)
        if(lamBdel.lt.rr) lamBdel=rr
        lamBdel=lamBdel*cor

c       if(sisferBdel.eq.1)then
c               go to 10
c       endif
c               Calculate the minimum angle for restriction of field by
c               atomic shell
        mT=2.0*asin(1.0/
     +          (2.0*momentumBdel(nen)*Z_Mean(nm)*5.07e2))
        rTetacBdel(nen,nm)=mT
c       write(oo,*)' mT=',mT
        if(mT.lt.mTetacBdel)then
                mT=mTetacBdel   ! Throw out too slow interaction. They
                                ! do not influent to anything
        endif
c               Calculate the cut angle due to mean free part
        A = RuthMat(nm)/cor/
     +          (momentum2Bdel(nen)*beta2Bdel(nen))/(5.07e10)**2
        B = (lamBdel*A)
        B = sqrt( B / (B+1.0) )
        TetacBdel(nen,nm) = 2.0 * asin(B)
c       TetacBdel = acos( (B-1.0) / (B+1.0) )
c       TetacBdel=2.0*asin(sqrt(lamBdel*A))
c       if(TetacBdel.lt.0.2)then
c               TetacBdel=0.2

c               If it too little, reset it. It will lead to increasing
c               of lamBdel and decriasing of calculation time.
        if(TetacBdel(nen,nm) .lt. mT)then
                TetacBdel(nen,nm)=mT
                B=mT    ! B is double precision
                r=sin(B/2.0)
                lamBdel=1/A * 2.0 * r*r / ( 1 + cos(B) )
*               r=cos(TetacBdel(nen,nm))
*               lamBdel=A*(1.0+r)/(1.0-r)
*               lamBdel=1.0/lamBdel
c               lamBdel=(p2*bet2*sin(TetacBdel/2.0)**2) / A
        endif

        lamaBdel(nen,nm)=lamBdel
        B=TetacBdel(nen,nm)
        CosTetac12Bdel(nen,nm)=cos(B/2.0)
        SinTetac12Bdel(nen,nm)=sin(B/2.0)
        if(TetacBdel(nen,nm).gt.1.5)then
                sisferaBdel(nen,nm)=1
        else
                sisferaBdel(nen,nm)=0
        endif
                
c       debug mode:
c        lamaBdel(nen,nm)=2.0*lamaBdel(nen,nm)

        elseif( sruthBdel.eq.0)then             ! gaus formula

c               calculate paht lengt from mTetacBdel
        msig=mTetacBdel
        x=msig / ( sqrt(2.0) * 13.6/(betaBdel(nen)*momentumBdel(nen)))
        x=x*x

c       x=x/DensMatDS(nMatVol(nVolBdel))
        x=x*RLenMat(nm)*cor
        lamBdel = mlamBdel/DensMatDS(nm)
        if(lamBdel.lt.rr) lamBdel=rr
        lamBdel=lamBdel*cor
c       write(oo,*)' x=',x,' rleng=',rleng
c               reset if it is too large
        if(lamBdel.lt.x)lamBdel=x
        lamaBdel(nen,nm)=lamBdel
        msigBdel(nen)=sqrt(2.0)*13.6/
     +          (betaBdel(nen)*momentumBdel(nen))

c       debug mode:
c       lamaBdel(nen,nm)=2.0*lamaBdel(nen,nm)
c       msigBdel(nen)=0.5*msigBdel(nen)
        endif   

        enddo   ! end of nen
        endif   ! end of if(qAtMat(nm).gt.0)then
        enddo   ! end of nm
        endif   ! if(sruthBdel.ne.2)

        if(sruthBdel.eq.2)then  


        call logscale0(qanCBdel,0.03,real(PI),anCBdel,ancCBdel)

c       call readCBdel
        call read1CBdel

        enerCBdel( 1) = 0.5E-3   
        enerCBdel( 2) = 1.5E-3
        enerCBdel( 3) = 2.5E-3
        enerCBdel( 4) = 5.5E-3
        enerCBdel( 5) = 10.5E-3
        enerCBdel( 6) = 21.5E-3
        enerCBdel( 7) = 42.5E-3
        enerCBdel( 8) = 85.5E-3
        enerCBdel( 9) = 170.5E-3
        enerCBdel(10) = 341.1E-3
        enercCBdel( 1) = 1 E-3
        enercCBdel( 2) = 2E-3
        enercCBdel( 3) = 4E-3
        enercCBdel( 4) = 8E-3
        enercCBdel( 5) = 16E-3
        enercCBdel( 6) = 32E-3
        enercCBdel( 7) = 64E-3
        enercCBdel( 8) = 128E-3
        enercCBdel( 9) = 256E-3

        do nen=1,qeaCBdel
                gammaCBdel(nen) = 1.0 + enercCBdel(nen)/ELMAS
                beta2CBdel(nen) = ( 2.0 * enercCBdel(nen)/ELMAS
     +                          + (enercCBdel(nen)/ELMAS)**2 ) /
     +                          gammaCBdel(nen)**2
                momentum2CBdel(nen) = 
     +                  enercCBdel(nen)*enercCBdel(nen) + 
     +                  2.0*ELMAS*enercCBdel(nen)
        enddo


        do na=1,pqAt
        
          if(Zat(na).gt.0)then  ! atom is meant initialized

            do nen=1,qeaCBdel
                mT=1.0/
     +          (2.0*sqrt(momentum2CBdel(nen))*Zat(na)*5.07e2)
                sRcmCBdel(nen,nm)=2.0*asin(mT)
                sRmCBdel(nen,na)= 1/4. *
     +          Zat(na)*Zat(na)*ELRAD*ELRAD*ELMAS*ELMAS/
     +          ( momentum2CBdel(nen) * beta2CBdel(nen) * mT**4 ) /
     +          ( 5.07E10 ** 2 ) * 1.E16
                
              do nang=1,qanCBdel

                sRCBdel(nang,nen,na)= 1/4. *
     +          Zat(na)*Zat(na)*ELRAD*ELRAD*ELMAS*ELMAS/
     +          ( momentum2CBdel(nen) * beta2CBdel(nen) * 
     +            sin(ancCBdel(nang)/2.0)**4 ) /
     +          ( 5.07E10 ** 2 ) * 1.E16

              enddo
 
            enddo
                        

            if(sign_ACBdel(na).eq.1)then

              do nen=1,qeaCBdel
                do nang=1,qanCBdel
                  sCBdel(nang,nen,na)=fcalcsCBdel(nang,nen,na)
                enddo
              enddo

            endif

          endif

        enddo

                        ! Fill an empty places
        nnext = 0
        qempt = 0       ! quantity of the empty places is zero

            
        do na1=1,QseqAt
            na=nseqAt(na1)
            if(Zat(na).eq.0)then        ! atom is meant not initialized
              write(oo,*)' error in IniBdel'
              stop
            endif

            if(sign_ACBdel(na).eq.1)then
              nprev=nnext
              nnext=na
            endif
            if(sign_ACBdel(na).eq.0)then
              qempt=qempt+1     ! add pointer of empty place
              nempt(qempt)=na
            endif

            if(sign_ACBdel(na).eq.1 .and. qempt.ne.0)then
              if(nprev.eq.0)then        ! first filled atom
                                        ! fit by k*Z**2
                do nen=1,qeaCBdel
                  do nang=1,qanCBdel
                    k=sCBdel(nang,nen,nnext) / Zat(nnext)**2
                    do nqe=1,qempt
                      sCBdel(nang,nen,nempt(nqe)) = 
     +                  k *Zat(nempt(nqe))**2
                    enddo       ! nqe=1,qempt
                  enddo         ! nang=1,qanCBdel       
                enddo           ! nen=1,qeaCBdel
                qempt=0

              else                      ! fit by previous and this filled atom
                                        ! f = k*Z*(Z+c)
                do nen=1,qeaCBdel
                  do nang=1,qanCBdel
                    f1=sCBdel(nang,nen,nprev)
                    f2=sCBdel(nang,nen,nnext)
                    z1=Zat(nprev)
                    z2=Zat(nnext)
                    c = (f1 * z2**2 - f2 * z1**2 ) /
     +                  (f2 * z1    - f1 * z2    )
                    k = f1 / (z1 * ( z1 + c ) )
                    do nqe=1,qempt
                      sCBdel(nang,nen,nempt(nqe)) = 
     +                  k*Zat(nempt(nqe))*(Zat(nempt(nqe)) + c)
                      if(sCBdel(nang,nen,nempt(nqe)).lt.0.)
     +                   sCBdel(nang,nen,nempt(nqe)) = 0.
                    enddo
                  enddo
                enddo
                qempt=0

              endif
            endif
          

        enddo

        if(qempt.ne.0)then
          if(nprev.eq.0)then
            write(oo,*)' error in IniBdel: wrong nprev'
            stop
          endif
                nnext=nprev             ! so as to use the same lines as above  
                do nen=1,qeaCBdel
                  do nang=1,qanCBdel
                    k=sCBdel(nang,nen,nnext) / Zat(nnext)**2
                    do nqe=1,qempt
                      sCBdel(nang,nen,nempt(nqe)) = 
     +                  k *Zat(nempt(nqe))**2
                    enddo       ! nqe=1,qempt
                  enddo         ! nang=1,qanCBdel       
                enddo           ! nen=1,qeaCBdel
                qempt=0
        endif
        
c       On this point all the atomic cross sections are generated.
c       Now it is a high time to generate cross sections 
c       for initialized materials.

        do nm=1,pQMat
          if(qAtMat(nm).gt.0)then

            lamBdel=mlamBdel/DensMat(nm)

c           write(oo,*)' lamBdel=',lamBdel,' mlamBdel=',mlamBdel

            do nen=1,qeaCBdel
              do nang=1,qanCBdel
                sd=0.
                do nam=1,qAtMat(nm)    
                  na=AtMAt(nam,nm)
                  sd = sd + sCBdel(nang,nen,na) * WeightAtMat(nam,nm)
                enddo
                sd = sd * 1.0E-16 * 5.07E10 * 5.07E10
c                         Angstrem**2 -> sm**2
c                                   sm**2 -> MeV**-2
                sd=sd * 2.0 * PI * sin(ancCBdel(nang))
                smaCBdel(nang,nen,nm)=sd 

              enddo             ! nang=1,qanCBdel
            enddo               ! nen=1,qeaCBdel
        
            do nener=1,qener    ! go to working mesh
                                ! ( The enercCBdel is to rare )
              if(enerc(nener).lt.500.0e-6)then
                do nang=1,qanCBdel
                  smatCBdel(nang,nener,nm)=0.0
                enddo
                lamaBdel(nener,nm)=0.0
                tsmatCBdel(nener,nm)=0.0
              else

                ek=enerc(nener)*1000.0  ! Calculate step lenght by usual formula
                if(ek.le.10.0)then
                  rr = 1.0e-3 * A_Mean(nm)/Z_Mean(nm) * 
     +                  3.872e-3 * ek ** 1.492
                  rr=rr/DensMat(nm)
                else
                  rr=1.0e-3 * 6.97e-3 * ek ** 1.6
                  rr=rr/DensMat(nm)
                endif
                rrCBdel(nener,nm)=rr
                rr=rr*koefredCBdel
                if(rr.lt.lamBdel) rr=lamBdel
                do nen=2,qeaCBdel
                  if(enercCBdel(nen).gt.enerc(nener))then
                    n2=nen
                    goto 100
                  endif
                enddo
                n2=qeaCBdel
100             continue
                n1=n2-1
                do nang=1,qanCBdel
                                ! Linear interpolation
                  smatCBdel(nang,nener,nm)=smaCBdel(nang,n1,nm) + 
     +            (smaCBdel(nang,n2,nm) - smaCBdel(nang,n1,nm)) * 
     +            (enerc(nener) - enercCBdel(n1))       /   
     +            (enercCBdel(n2) - enercCBdel(n1))
                  ismatCBdel(nang,nener,nm)=
     +                  smatCBdel(nang,nener,nm) 
     +                  * (anCBdel(nang+1) - anCBdel(nang))
                enddo           ! nang=1,qanCBdel
                rr=1.0/
     +          (rr*(AVOGADRO/(5.07E10 * 5.07E10))
     +                  *DensMat(nm)/A_mean(nm))
                st=0.0          ! restrict low angles
                st1=0.0
                do nang=qanCBdel,1,-1
                  st = st + ismatCBdel(nang,nener,nm)
                  if(st.gt.rr)then
                    goto 110
                  else
                    st1=st
                  endif
                enddo   ! nang=qanCBdel,1,-1
                nang=0  
110             continue
                nang=nang+1
                TetacBdel(nener,nm)=anCBdel(nang)
                tsmatCBdel(nener,nm)=st1
                lamaBdel(nener,nm)=1.0/
     +          (tsmatCBdel(nener,nm)*(AVOGADRO/(5.07E10 * 5.07E10))
     +                  *DensMat(nm)/A_mean(nm))
                do n=1,nang-1
                  ismatCBdel(n,nener,nm)=0.0
                enddo
                call lhispre(ismatCBdel(1,nener,nm),qanCBdel)
                if(TetacBdel(nener,nm).gt.1.0)then
                  sisferaBdel(nener,nm)=1
                endif
              endif
            enddo       ! nener=1,qener

                                
          endif
        enddo


c       All done !

        endif           ! if(sruthBdel.eq.2)
                

        end     

        subroutine readCBdel

        implicit none

c         include 'GoEvent.inc'
+SEQ,GoEvent.
c       include 'ener.inc'
+SEQ,ener.
c       include 'atoms.inc'
+SEQ,atoms.
c       include 'matters.inc'
+SEQ,matters.
c       include 'crosec.inc'
+SEQ,crosec.
c       include 'volume.inc'
+SEQ,volume.
c       include 'bdel.inc'
+SEQ,bdel.

        character*1 a
        integer ios
        integer na,z,i,n,j

        open(1,FILE='cbdel.dat',IOSTAT=ios,STATUS='OLD')
        if(ios.ne.0)then
                write(oo,*)' readCBdel: can not open file readCBdel.dat'
                stop
        endif
        
        do na=1,pqAt
        
            if(Zat(na).gt.0)then        ! atom is meant initialized

                sign_ACBdel(na)=0       ! cleaning

        do n=1,100000
            read(1,'(A1)',END=100)a
c           write (6,*)a
            if(a.eq.'$')then
                backspace (1)
                read(1,'(A1,I3)')a,z
                if(z.eq.Zat(na))then
                    write(oo,*)a,z
                    do i=1,4
                        read(1,*)(ACBdel(i,j,na),j=1,qeaCBdel)
                    enddo
                    do i=0,6
                        read(1,*)(CCBdel(i,j,na),j=1,qeaCBdel)
                    enddo
                        read(1,*)(BCBdel(j,na),j=1,qeaCBdel)
                    sign_ACBdel(na)=1   ! sign of reading
                    go to 100
                endif   
            endif
        enddo
100     rewind(1)

            endif

        enddo

        close(1)

        end

        subroutine read1CBdel
c
c       This subroutine must copy data not from external file
c       but from internal data arrays (so as to avoid input which
c       is often machine-dependent)
c
        implicit none

c         include 'GoEvent.inc'
+SEQ,GoEvent.
c       include 'ener.inc'
+SEQ,ener.
c       include 'atoms.inc'
+SEQ,atoms.
c       include 'matters.inc'
+SEQ,matters.
c       include 'crosec.inc'
+SEQ,crosec.
c       include 'volume.inc'
+SEQ,volume.
c       include 'bdel.inc'
+SEQ,bdel.

c        character*1 a
c        integer ios
        integer na,i,n,j
c        integer z

        integer psqAt
        parameter (psqAt=11)    ! Now only 11 atoms included
        integer ZsCBdel(psqAt)  ! atomic charge
        real AsCBdel(4,pqeaCBdel,psqAt)
        real CsCBdel(0:6,pqeaCBdel,psqAt)
        real BsCBdel(pqeaCBdel,psqAt)
*** Modified on 6/2/97 RV
C        save /ZsCBdel/,/AsCBdel/,/CsCBdel/,/BsCBdel/
        save ZsCBdel,AsCBdel,CsCBdel,BsCBdel
*** End of modification.

c       include 'cbdeldat.inc'
+SEQ,cbdeldat.

        
        do na=1,pqAt
        
            if(Zat(na).gt.0)then        ! atom is meant initialized

                sign_ACBdel(na)=0       ! cleaning

        do n=1,psqAt
                if(ZsCBdel(n).eq.Zat(na))then
c                    write(oo,*)a,z
                    do i=1,4
                      do j=1,qeaCBdel
                        ACBdel(i,j,na)=AsCBdel(i,j,n)
                      enddo
                    enddo
                    do i=0,6
                      do j=1,qeaCBdel
                        CCBdel(i,j,na)=CsCBdel(i,j,n)
                      enddo
                    enddo
                      do j=1,qeaCBdel
                        BCBdel(j,na)=BsCBdel(j,n)
                      enddo
                    sign_ACBdel(na)=1   ! sign of reading
                    go to 100
                endif   
        enddo
100     continue

            endif

        enddo

        end

        function fcalcsCBdel(nang,nen,na)
c
c       calculates elastic cross section per one atom by fit formula
c       in Angstrem**2/Srad. (10**-16 sm2 /Srad)
c

        implicit none

        real fcalcsCBdel
        integer nang,nen,na

c         include 'GoEvent.inc'
+SEQ,GoEvent.
c       include 'cconst.inc'
+SEQ,cconst.
c       include 'ener.inc'
+SEQ,ener.
c       include 'atoms.inc'
+SEQ,atoms.
c       include 'matters.inc'
+SEQ,matters.
c       include 'volume.inc'
+SEQ,volume.
c       include 'part.inc'
+SEQ,part.
c       include 'bdel.inc'
+SEQ,bdel.

        real*8 ang,cang,cang2,cang3,cang4,cang5,cang6,s,r
        real*8 coe
c       integer n
        integer i

        ang=ancCBdel(nang)
c       ang=0.0
        cang=cos(ang)
        cang2=cang *cang
        cang3=cang2*cang
        cang4=cang3*cang
        cang5=cang4*cang
        cang6=cang5*cang
           
c       write(oo,*)' A=',(ACBdel(i,nen,na),i=1,4)
c       write(oo,*)' C=',(CCBdel(i,nen,na),i=0,6)
c       write(oo,*)' B=',BCBdel(nen,na)

            r=0.0
            do i=1,4
                r=r+ACBdel(i,nen,na) / 
     +          (1.0-cang+2.0*dble(BCBdel(nen,na)))**i
c           write(oo,*)' r=',r
            enddo
            
            r=r+dble(CCBdel(0,nen,na))*
     +          1.0
c           write(oo,*)' r=',r
            r=r+dble(CCBdel(1,nen,na))*
     +          cang
c           write(oo,*)' r=',r
            r=r+dble(CCBdel(2,nen,na))*
     +          0.5*(3.0*cang2-1.0)
c           write(oo,*)' r=',r
            r=r+dble(CCBdel(3,nen,na))*
     +          0.5*(5.0*cang3 - 3*cang)
c           write(oo,*)' r=',r
            r=r+dble(CCBdel(4,nen,na))*
     +          1.0/8.0 * (35.0*cang4 - 30.0*cang2 + 3.0)
c           write(oo,*)' r=',r
            r=r+dble(CCBdel(5,nen,na))*
     +          1.0/8.0 * (63.0*cang5 - 70.0*cang3 + 15.0*cang)
c           write(oo,*)' r=',r
            r=r+dble(CCBdel(6,nen,na))*
     +          1.0/16.0 * (231.0*cang6 - 315.0*cang4 + 105.0*cang2 -5.0)
c           write(oo,*)' r=',r

            s=r

c       beneath is coefficient from erratum.    
        coe=Zat(na)/(FSCON*FSCON)/(gammaCBdel(nen)*beta2CBdel(nen))

        s=s*coe*coe 

        fcalcsCBdel=s   
        
        end

        function fcalcsmCBdel(nang,nen,nm)

        implicit none

        real fcalcsmCBdel
        integer nang,nen,nm

c         include 'GoEvent.inc'
+SEQ,GoEvent.
c       include 'cconst.inc'
+SEQ,cconst.
c       include 'ener.inc'
+SEQ,ener.
c       include 'atoms.inc'
+SEQ,atoms.
c       include 'matters.inc'
+SEQ,matters.
c       include 'volume.inc'
+SEQ,volume.
c       include 'part.inc'
+SEQ,part.
c       include 'bdel.inc'
+SEQ,bdel.

        real*8 ang,cang,cang2,cang3,cang4,cang5,cang6,s,r
        real*8 coe
        integer n,na,i

        ang=ancCBdel(nang)
c       ang=0.0
        cang=cos(ang)
        cang2=cang *cang
        cang3=cang2*cang
        cang4=cang3*cang
        cang5=cang4*cang
        cang6=cang5*cang
        s=0.0
        do n=1,QAtMat(nm)
            na=AtMat(n,nm)
c       write(oo,*)' A=',(ACBdel(i,nen,na),i=1,4)
c       write(oo,*)' C=',(CCBdel(i,nen,na),i=0,6)
c       write(oo,*)' B=',BCBdel(nen,na)

            r=0.0
            do i=1,4
                r=r+ACBdel(i,nen,na) / 
     +          (1.0-cang+2.0*dble(BCBdel(nen,na)))**i
            write(oo,*)' r=',r
            enddo
            
            r=r+dble(CCBdel(0,nen,na))*
     +          1.0
            write(oo,*)' r=',r
            r=r+dble(CCBdel(1,nen,na))*
     +          cang
            write(oo,*)' r=',r
            r=r+dble(CCBdel(2,nen,na))*
     +          0.5*(3.0*cang2-1.0)
            write(oo,*)' r=',r
            r=r+dble(CCBdel(3,nen,na))*
     +          0.5*(5.0*cang3 - 3*cang)
            write(oo,*)' r=',r
            r=r+dble(CCBdel(4,nen,na))*
     +          1.0/8.0 * (35.0*cang4 - 30.0*cang2 + 3.0)
            write(oo,*)' r=',r
            r=r+dble(CCBdel(5,nen,na))*
     +          1.0/8.0 * (63.0*cang5 - 70.0*cang3 + 15.0*cang)
            write(oo,*)' r=',r
            r=r+dble(CCBdel(6,nen,na))*
     +          1.0/16.0 * (231.0*cang6 - 315.0*cang4 + 105.0*cang2 -5.0)
            write(oo,*)' r=',r

            r=r*WeightAtMat(n,nm)
            write(oo,*)' r=',r
            s=s+r

        enddo

        coe=Z_Mean(nm)/(FSCON*FSCON)/(gammaCBdel(nen)*beta2CBdel(nen))

        s=s*coe*coe 

        fcalcsmCBdel=s  
        
        end

        
        subroutine SeLossBdel(nm,e,i,el)
c
c       Calculation of the energy loss in 1 sm
c
        implicit none

c       include 'ener.inc'
+SEQ,ener.
c       include 'atoms.inc'
+SEQ,atoms.
c       include 'matters.inc'
+SEQ,matters.
c       include 'volume.inc'
+SEQ,volume.
c       include 'bdel.inc'
+SEQ,bdel.

        integer nm
        real e,el
        integer i,i1    ! i is start index i1 is new
        integer n

c       if(e.lt.eMinBdel)then
c               el=0.0
c               i1=0
c               return
c       endif
        if(i.le.0.or.i.gt.qener)then
                i=qener
        endif
c       do n=i,iMinBdel,-1
        do n=i,1,-1
                if(e.ge.ener(n))then
                        i1=n
                        go to 10
                endif
        enddo
c       write(oo,*)' Error in FeLossBdel'
c       stop
        el=eLossBdel(1,nm)
        i=1
        return
10      continue
        i=i1
        el=eLossBdel(i,nm)+(e-ener(i))*
     +  (eLossBdel(i+1,nm)-eLossBdel(i,nm))/(ener(i+1)-ener(i))
c       write(oo,*)' nm,e,i,el=',nm,e,i,el

        end


        subroutine SstepBdel
c
c       Calc. of step lenght
c
        implicit none

c         include 'GoEvent.inc'
+SEQ,GoEvent.
c       include 'ener.inc'
+SEQ,ener.
c       include 'atoms.inc'
+SEQ,atoms.
c       include 'matters.inc'
+SEQ,matters.
c       include 'crosec.inc'
+SEQ,crosec.
c       include 'volume.inc'
+SEQ,volume.
c       include 'bdel.inc'
+SEQ,bdel.

c       real pntBdel(3),velBdel(3),step
c       integer nv,sgonext
        integer i
        real*8 mleng
        real lossmean
        real*8 rleng

        real rr,ek,r,ranfl
        integer nm

        if(nVolBdel.eq.0.or.sgonextBdel.eq.1)then       !first find the volume
c               sisferBdel=0    ! obsolete
                call VolNumZcoor(pntBdel(3),velBdel(3),nVolBdel)
                if(nVolBdel.eq.0)return         !out of geometry
c               if(sMatC(nMatVol(nVolBdel)).eq.0)return
        endif
c       write(oo,*)' pntBdel(3)=',pntBdel(3)
c       write(oo,*)' velBdel=',velBdel
c       write(oo,*)' nVolBdel=',nVolBdel
c       write(oo,*)' mleng=',mleng
        call VolPathLeng(pntBdel(3),velBdel,nVolBdel,mleng)
        if(nMatVol(nVolBdel).eq.0)then  ! empty volume: no interaction
                estepBdel=0.0
                stepBdel=mleng
                sgonextBdel=1
                sturnBdel=0
                go to 10
        endif

        if(eBdel.le.cuteneBdel)then     ! the same number in treatdel.f

        nm=nMatVol(nVolBdel)
        ek=eBdel*1000.0
        if(ek.le.10.0)then
        rr=1.0e-3 * A_Mean(nm)/Z_Mean(nm) * 3.872e-3 * ek ** 1.492
        rr=rr/DensMat(nm)
        else
        rr=1.0e-3 * 6.97e-3 * ek ** 1.6
        rr=rr/DensMat(nm)
        endif
c       rr=rr*0.6
        r=ranfl()
c       rr = rr * (0.3 + 0.8*r) 
c       rr = rr * (0.4 + 1.0*r) 
        rr = rr * (0.3 + 0.8*r) 
                stepBdel=rr
                if(stepBdel.lt.mleng)then
                        estepBdel=eBdel
                        sgonextBdel=0
                else
                        estepBdel=eBdel*mleng/stepBdel
                        sgonextBdel=1
                endif
                sturnBdel=0
                go to 10
        endif

        call SeLossBdel(nMatVol(nVolBdel),eBdel,iBdel,lossmean)
c       if(nevt.eq.1.and.(nBdel.eq.8.or.nBdel.eq.9))then
c       write(oo,*)' mleng,lossmean=',mleng,lossmean
c       endif
        estepBdel=mleng*lossmean
        stepBdel=mleng
        sgonextBdel=1
        sturnBdel=0
c       if(srandoff.ne.1)then
        if(sruthBdel.eq.1.or.sruthBdel.eq.2)then        !lengt to coulomb interaction
                call SRLengBdel(rleng)
        else
                call SMLengBdel(rleng)
c               rleng=mlamBdel/DensMatDS(nMatVol(nVolBdel))
        endif
        if(stepBdel.gt.rleng)then       !reduce step to point of turn
                stepBdel=rleng
                estepBdel=rleng*lossmean
                sgonextBdel=0
                sturnBdel=1
        endif
c       endif
c       if(nevt.eq.1.and.(nBdel.eq.8.or.nBdel.eq.9))then
c       write(oo,*)' rleng,estepBdel=',rleng,estepBdel
c       endif
        if(estepBdel.gt.eMinBdel)then
            if(estepBdel.gt.0.1*eBdel)then
                        ! reduce the step ...
                estepBdel=0.1*eBdel             ! Maximum
                        !                 but not too much:
                if(estepBdel.lt.eMinBdel)estepBdel=eMinBdel
                        ! For the case when eBdel<eMinBdel 
                if(estepBdel.gt.eBdel)estepBdel=eBdel
                stepBdel=estepBdel/lossmean
                sgonextBdel=0
                if(sruthBdel.eq.1.or.sruthBdel.eq.2)then
                                !since step must be reduced
                        sturnBdel=0
                else
                        sturnBdel=1
                endif
            endif
        endif
c       if(nevt.eq.1.and.(nBdel.eq.8.or.nBdel.eq.9))then
c       write(oo,*)' estepBdel=',estepBdel
c       endif

c       if(estepBdel.gt.0.1*eBdel)then
c               estepBdel=0.1*eBdel
c               stepBdel=estepBdel/lossmean
c               sgonextBdel=0
c               if(sruthBdel.eq.1)then
c                       sturnBdel=0
c               else
c                       sturnBdel=1
c               endif
c       endif

10      do i=1,3
                npntBdel(i)=pntBdel(i)+stepBdel*velBdel(i)
        enddo

        if(estepBdel.lt.0.0)then
                write(oo,*)' error in SstepBdel: estepBdel is negative'
                call PriBdel(1)
                write(oo,*)' lossmean=',lossmean
                write(oo,*)' mleng=',mleng,' rleng=',rleng
                stop
        endif

        end
                
        
        subroutine SRLengBdel(rleng)
c
c       Step lenght limit due to multiple scatering
c       The method with Rutherford cross section
c
        implicit none

c         include 'GoEvent.inc'
+SEQ,GoEvent.
c       include 'ener.inc'
+SEQ,ener.
c       include 'atoms.inc'
+SEQ,atoms.
c       include 'matters.inc'
+SEQ,matters.
c       include 'crosec.inc'
+SEQ,crosec.
c       include 'volume.inc'
+SEQ,volume.
c       include 'bdel.inc'
+SEQ,bdel.
c       include 'cconst.inc'
+SEQ,cconst.

        real*8 rleng
c       real bet2,p2,A,B

c       real asin,acos,sqrt,alog,ranfl
        real ranfl
        real r
c       real mT

        r=ranfl()
        if(r.gt.0.99999)then
                rleng=1.0e30
                return
        endif
        rleng=-lamaBdel(iBdel,nMatVol(nVolBdel))*alog(1.0-r)
        lamBdel=lamaBdel(iBdel,nMatVol(nVolBdel))


        end
        
        
        subroutine SMLengBdel(rleng)
c
c       Step lenght limit due to multiple scatering
c       The method with mean multiple scatering angle form
c

        implicit none

c         include 'GoEvent.inc'
+SEQ,GoEvent.
c       include 'ener.inc'
+SEQ,ener.
c       include 'atoms.inc'
+SEQ,atoms.
c       include 'matters.inc'
+SEQ,matters.
c       include 'crosec.inc'
+SEQ,crosec.
c       include 'volume.inc'
+SEQ,volume.
c       include 'bdel.inc'
+SEQ,bdel.
c       include 'cconst.inc'
+SEQ,cconst.

        real*8 rleng
c       real bet,p,x
c       real sqrt
c       real msig
c
        rleng=lamaBdel(iBdel,nMatVol(nVolBdel))
*       go to 100
*c              calculate paht lengt from mTetacBdel
*        bet=1.0-ELMAS*ELMAS/((ELMAS+eBdel)*(ELMAS+eBdel))
*        bet=sqrt(bet)
*        p=eBdel*eBdel+2.0*ELMAS*eBdel
*        p=sqrt(p)
*       msig=mTetacBdel
*       x=msig/(sqrt(2.0)*13.6/(bet*p))
*       x=x*x
*
*c      x=x/DensMat(nMatVol(nVolBdel))
*       x=x*RLenMat(nMatVol(nVolBdel))
*       rleng=mlamBdel/DensMat(nMatVol(nVolBdel))
*c      write(oo,*)' x=',x,' rleng=',rleng
*c              reset if it is too large
*       if(rleng.lt.x)rleng=x
*
        end


        subroutine TurnBdel

c       Turn the vector of velocity of the delta electron

        implicit none

c       include 'GoEvent.inc'
+SEQ,GoEvent.
c       include 'del.inc'
+SEQ,del.
c         include 'ener.inc'                      
+SEQ,ener.
c         include 'atoms.inc'                      
+SEQ,atoms.
c         include 'matters.inc'                      
+SEQ,matters.
c         include 'crosec.inc'                      
+SEQ,crosec.
c         include 'volume.inc'                      
+SEQ,volume.
c       include 'cel.inc'
+SEQ,cel.
c       include 'bdel.inc'
+SEQ,bdel.
c       include 'cconst.inc'
+SEQ,cconst.

        real*8 r,rs,rsin12,rcos12
        real*8 x,msig

        real ranfl
c       real ranfl,sqrt,sin,cos,acos
c       real*8 dsqrt
c       real rs,rss
c       integer n,i
        real rra,rrb

        real xran,dran
        integer iran

c       if(sisferBdel.eq.0)then

        if(sruthBdel.eq.2)then

          if(enerc(iBdel).lt.500.0e-6 .or.
     +          sisferaBdel(iBdel,nMatVol(nVolBdel)).eq.1)then
            sisferBdel=1
            TetaBdel=0.0
          else
            sisferBdel=0
            call lhisran(ismatCBdel(1,iBdel,nMatVol(nVolBdel)), 
     +          qanCBdel, 1.0, 1.0, xran)
            iran=xran   
            if(iran.lt.1.or.iran.gt.qanCBdel)then
              write(oo,*)' Worning of TurnBdel: iran=',iran,
     +                  ' xran=',xran
              if(iran.lt.1)then
                iran=1
              else
                iran=qanCBdel
              endif
            endif
            dran=xran-iran
            TetaBdel=anCBdel(iran)+(anCBdel(iran+1)-anCBdel(iran))*dran
          endif

        elseif(sruthBdel.eq.1)then

        if(sisferaBdel(iBdel,nMatVol(nVolBdel)).eq.1)then
                sisferBdel=1
                TetaBdel=0.0
        else
c       if(TetacBdel.ge.1.5)then
c               sisferBdel=1
c               TetaBdel=0.0
c       else

                r=ranfl()       
                rsin12=SinTetac12Bdel(iBdel,nMatVol(nVolBdel))
                rcos12=CosTetac12Bdel(iBdel,nMatVol(nVolBdel))
                rs = 1.0 - r * rcos12 * rcos12
                if(rs.eq.0.0)then
                        TetaBdel=PI
                else
                        rs=rsin12 / sqrt( rs )
                        rs=2.0 * asin(rs)
                        TetaBdel=rs
                endif

c       rs=sin(TetacBdel/2.0)/sqrt(1.0-r*cos(TetacBdel/2.0)**2)
c       TetaBdel=asin(rs)*2.0
*       rs=cos(TetacBdel)
*       rs=1.0-(1.0-rs)/(1.0-r*0.5*(1.0+rs))
*       TetaBdel=acos(rs)
c       write(oo,*)' TetacBdel,TetaBdel,r=',TetacBdel,TetaBdel,r

        endif

        else

        x=stepBdel/RLenMat(nMatVol(nVolBdel))
        msig=msigBdel(iBdel)*
     +                  sqrt(x)
        if(msig.ge.1.5)then
                sisferBdel=1
                TetaBdel=0.0
        else
                call lranor(rra,rrb)
                TetaBdel=rra*msig
        endif


        endif           ! sruthBdel.eq. ...

        if(sisferBdel.eq.1)then
                call sfersim(velBdel)
        else
                call MakeNewSys(e1Bdel,e2Bdel,e3Bdel,velBdel)
                call turnvec(e1Bdel,e2Bdel,e3Bdel,TetaBdel,velBdel)
        endif

        end


        subroutine correctBdel(e,r)

        implicit none

        real e,r
        real a,b,k,x
c               b-k*(x-a)**2 = 0  =>  x= a +- sqrt(b/k)
c               k = b / (x - a)**2
        a=2.5
        b=4
c       k=1.0/4.0
        x=0.0
        k=b/((x-a)*(x-a))
        x=e*1000.0
        r=b-k*(x-a)*(x-a)
        if(r.lt.0.0)then
                r=1
        else
                r=r+1
        endif

        end     


        subroutine PriBdel(i)

        implicit none

c         include 'GoEvent.inc'
+SEQ,GoEvent.
c       include 'ener.inc'
+SEQ,ener.
c       include 'atoms.inc'
+SEQ,atoms.
c       include 'matters.inc'
+SEQ,matters.
c       include 'crosec.inc'
+SEQ,crosec.
c       include 'volume.inc'
+SEQ,volume.
c       include 'bdel.inc'
+SEQ,bdel.

        integer i

        integer ne,nm
        integer nang,nen,na

        if(soo.eq.0)return

        write(oo,*)
        write(oo,*)' PriBdel(',i,'):'
        if(i.eq.0)then
c       write(oo,*)' eMinBdel=',eMinBdel,' iMinBdel=',iMinBdel
        write(oo,*)' eMinBdel=',eMinBdel

        write(oo,*)'   ne,    enerc, betaBdel,',
     +  '  beta2Bdel,momentumBdel,momentum2Bdel,msigBdel'
        do ne=1,qener
        write(oo,'(1X,i5,6(1X,E10.5))')ne,enerc(ne),betaBdel(ne),
     +  beta2Bdel(ne),
     +  momentumBdel(ne),momentum2Bdel(ne),msigBdel(ne)
        enddo

        do nm=1,pQMat
        if(qAtMat(nm).gt.0)then
c       if(sMatC(nm).gt.0)then
        write(oo,*)' matter number ',nm
        write(oo,*)' enerc elossbdel',
     +  ' lamaBdel rTetacBdel TetacBdel'
        write(oo,*)'                                   ',
     +  ' Cos12TetacBdel Sin12TetacBdel',
     +  ' sisferaBdel'

c       do ne=iMinBdel,qener
        do ne=1,qener
        write(oo,'(1X,7(1X,E9.4),1X,I3)')
     +  enerc(ne),eLossBdel(ne,nm),lamaBdel(ne,nm),
     +  rTetacBdel(ne,nm),TetacBdel(ne,nm),
     +  CosTetac12Bdel(ne,nm),SinTetac12Bdel(ne,nm),
     +  sisferaBdel(ne,nm)
        enddo

c       endif
        endif
        enddo

        elseif(i.eq.2)then

        write(oo,*)'        nang    anCBdel         ancCBdel'
        do nang=1,pqanCBdel
        write(oo,*)nang,anCBdel(nang),ancCBdel(nang)
        enddo
        write(oo,*)'         nen    enerCBdel        enercCBdel',
     +  '       gammaCBdel       beta2CBdel'
        do nen=1,pqeaCBdel
        write(oo,*)nen,enerCBdel(nen),enercCBdel(nen),
     +  gammaCBdel(nen), beta2CBdel(nen)
        enddo
        do na=1,pQAt

        if(Zat(na).gt.0)then

        write(oo,*)' atom number ',na
        if(sign_ACBdel(na).gt.0)then
        do i=1,4
        write(oo,'(1X,i1,1X,9E10.3)')i,(ACBdel(i,nen,na),nen=1,qeaCBdel)
        enddo
        do i=0,6
        write(oo,'(1X,i1,1X,9E10.3)')i,(CCBdel(i,nen,na),nen=1,qeaCBdel)
        enddo
        write(oo,'(1X,i1,1X,9E10.3)')i,(BCBdel(nen,na),nen=1,qeaCBdel)
        endif

        write(oo,*)' nang, ancCBdel, differentioal cross sections:'
        do nang=1,qanCBdel
        write(oo,'(1X,i3,1X,10E10.3)')
     +      nang,ancCBdel(nang),(sCBdel(nang,nen,na),nen=1,qeaCBdel)
        enddo   
        write(oo,*)' nang, ancCBdel, Ruth. differentioal cross sections:'
        write(oo,'(1X,3X,1X,10X,9E10.3)')
     +          (sRcmCBdel(nen,na),nen=1,qeaCBdel)
        write(oo,'(1X,3X,1X,10X,9E10.3)')
     +          (sRmCBdel(nen,na),nen=1,qeaCBdel)
        do nang=1,qanCBdel
        write(oo,'(1X,i3,1X,10E10.3)')
     +      nang,ancCBdel(nang),(sRCBdel(nang,nen,na),nen=1,qeaCBdel)
        enddo   

        endif   ! Zat(na).gt.0
        enddo   ! na=1,pQAt

        do nm=1,pQMat
        if(qAtMat(nm).gt.0)then
        write(oo,*)' matter number ',nm
        write(oo,*)' nang, ancCBdel, differentioal cross sections:'
        do nang=1,qanCBdel
        write(oo,'(1X,i3,1X,10E10.3)')
     +      nang,ancCBdel(nang),(smaCBdel(nang,nen,nm),nen=1,qeaCBdel)
        enddo   
c               smatCBdel and ismatCBdel are not printed now, they is too big.

        write(oo,*)' nen,   enerc, tsmatCBdel,  lamaBdel, ',
     +          ' usual range TetacBdel:'
        do nen=1,qener
        write(oo,'(1X,i3,1X,5E11.3)')
     +          nen,enerc(nen),tsmatCBdel(nen,nm),lamaBdel(nen,nm),
     +          rrCBdel(nen,nm),TetacBdel(nen,nm)
        enddo
        write(oo,*)' Beneth is invers order, energy along vertical'
        write(oo,*)' Angles are horizontally:'
        write(oo,'(1X,3X,1X,11X,30E11.3)')(ancCBdel(nang),
     +          nang=1,qanCBdel)
        write(oo,*)' nener,    ener, smatCBdel(nang,nen,nm)'
        do nen=1,qener                  ! next line fixed to 30 angles
        write(oo,'(1X,i3,1X,31E11.3)')
     +      nen,enerc(nen),(smatCBdel(nang,nen,nm),nang=1,qanCBdel)
        enddo   
        write(oo,*)' nener,    ener, ismatCBdel(nang,nen,nm)'
        do nen=1,qener                  ! next line fixed to 30 angles
        write(oo,'(1X,i3,1X,31E11.3)')
     +      nen,enerc(nen),(ismatCBdel(nang,nen,nm),nang=1,qanCBdel)
        enddo   
c       write(oo,'(5X,9E11.3)')
c     +         (tsmatCBdel(nen,nm),nen=1,qeaCBdel)
c       write(oo,*)' nang, ancCBdel, integrated cross sections:'
c       do nang=1,qanCBdel
c       write(oo,'(1X,i3,1X,10E11.3)')
c     +     nang,ancCBdel(nang),(ismatCBdel(nang,nen,nm),nen=1,qeaCBdel)
c       enddo   

        endif   ! qAtMat(nm).gt.0
        enddo   ! nm=1,pQMat

        else    ! i=1

        
        write(oo,*)' nBdel=',nBdel,' nstepBdel=',nstepBdel,
     +          ' eBdel=',eBdel
        write(oo,*)' pntBdel=',pntBdel
        write(oo,*)' npntBdel=',npntBdel
        write(oo,*)' velBdel=',velBdel
        write(oo,*)' stepBdel=',stepBdel,' estepBdel=',estepBdel
        write(oo,*)' e1Bdel=',e1Bdel
        write(oo,*)' e2Bdel=',e2Bdel
        write(oo,*)' e3Bdel=',e3Bdel
        if(iBdel.ge.1 .and. iBdel.le.qener .and.
     +          nVolBdel.ge.1 .and. nVolBdel.le.qVol)then
        if(nMatVol(nVolBdel).ge.1 .and. nMatVol(nVolBdel).le.pqMat)then
        write(oo,*)' TetacBdel(iBdel,.)=',
     +              TetacBdel(iBdel,nMatVol(nVolBdel)),
     +             ' TetaBdel=',TetaBdel,' -usually prev.'
        else
                write(oo,*)' cannot print TetacBdel'
                write(oo,*)' nMatVol(nVolBdel)=',nMatVol(nVolBdel)
        endif
        else
                write(oo,*)' cannot print TetacBdel'
                write(oo,*)' iBdel=',iBdel,' nVolBdel=',nVolBdel
        endif
        write(oo,*)' lamBdel=',lamBdel
        write(oo,*)' sturnBdel=',sturnBdel
        write(oo,*)' sruthBdel=',sruthBdel,' sisferBdel=',sisferBdel
        write(oo,*)' nVolBdel=',nVolBdel,' sgonextBdel=',sgonextBdel,
     +          ' iBdel=',iBdel
        endif


        end
 
        
+DECK,lstrel1.
      SUBROUTINE lstREL1(EEL,CHARGE,nmat,DEDX)
C.
        implicit none

C.    ******************************************************************
C.    *                                                                *
C.    *       Compute ion losses for electron/positron                 *
C.    *                                                                *
C.    *    ==>Called by : GDRELA                                       *
C.    *       Author    G.Patrick *********                            *
C.    *                                                                *
C.    ******************************************************************
C.
        real EEL        ! kinetic energy
        real CHARGE     ! +/-1.
c       integer JMA     ! =LQ(JMATE-I)  I-number of medium
        integer nmat    ! number of matter      
        real DEDX       ! loss

c       include 'ener.inc'
+SEQ,ener.
c       include 'atoms.inc'
+SEQ,atoms.
c       include 'matters.inc'
+SEQ,matters.
        
        integer nat
        
        real*8 PI,TWOPI, PIBY2,DEGRAD,RADDEG,CLIGHT,BIG,EMASS,
     +          EMMU,PMASS,AVO
      PARAMETER (PI=3.14159265358979324)
      PARAMETER (TWOPI=6.28318530717958648)
      PARAMETER (PIBY2=1.57079632679489662)
      PARAMETER (DEGRAD=0.0174532925199432958)
      PARAMETER (RADDEG=57.2957795130823209)
      PARAMETER (CLIGHT=29979245800.)
      PARAMETER (BIG=10000000000.)
      PARAMETER (EMASS=0.0005109990615)
      PARAMETER (EMMU=0.105658387)
      PARAMETER (PMASS=0.9382723128)
      PARAMETER (AVO=0.60221367)

c      PARAMETER (KWBANK=69000,KWWORK=5200)
c      COMMON/GCBANK/NZEBRA,GVERSN,ZVERSN,IXSTOR,IXDIV,IXCONS,FENDQ(16)
c     +             ,LMAIN,LR1,WS(KWBANK)
c      DIMENSION IQ(2),Q(2),LQ(8000),IWS(2)
c      EQUIVALENCE (Q(1),IQ(1),LQ(9)),(LQ(1),LMAIN),(IWS(1),WS(1))
c      EQUIVALENCE (JCG,JGSTAT)

c      COMMON/GCCUTS/CUTGAM,CUTELE,CUTNEU,CUTHAD,CUTMUO,BCUTE,BCUTM
c     +             ,DCUTE,DCUTM ,PPCUTM,TOFMAX,GCUTS(5)

        real DCUTE
c+SEQ,GCBANK
c+SEQ,GCCUTS
C
        real DENS
        real GAM, GAM2, T, TCME, BET2, Y, D, D2, D3, D4, F
        real POTI, POTL, FAC, C, X0, X1, AA, X, DEL, XA 
        real S1,S2
        real CON2,CON3,CON4,CON5,CON6
        real AJ,ZJ, WJ, WJJ(pQAt)
        integer IP
        real CONS
      DATA CONS/0.153536E-3/
C.
C.    ------------------------------------------------------------------
C.
        DCUTE=1.0e5
        DENS=DensMatDL(nmat)    
c      JPROB=LQ(JMA-4)
C
      GAM=EEL/EMASS + 1.
      GAM2=GAM*GAM
      T=GAM-1.
      DEDX=0.
      IF(T.LE.0.)GO TO 99
      TCME=DCUTE/EMASS
      BET2=1.-1./GAM2
C     ------------------------------
      IF(CHARGE.GT.0.) THEN
         Y=1./(1.+GAM)
         D=TCME
         IF(T.LT.TCME) D=T
         D2=D*D/2.
         D3=2.*D2*D/3.
         D4=D2*D2
         F=LOG(T*D)-BET2*(T+2.*D-Y*(3.*D2
     *    +Y*(D-D3+Y*(D2-T*D3+D4))))/T
C
      ELSE
        D=TCME
         IF(T.LT.2.*TCME) D=0.5*T
         F=-1.-BET2+LOG((T-D)*D)+T/(T-D)
     *    +(0.5*D*D+(1.+2.*T)*LOG(1.-D/T))/GAM2
      ENDIF
C
        if(QAtMat(nmat).eq.1)then
                POTI=16.E-9*ZAt(AtMat(1,nmat))**0.9
                S1=Zat(AtMat(1,nmat))/Aat(AtMat(1,nmat))
        else
                S1=0.0
                S2=0.0
                do nat=1,QAtMat(nmat)
                        AJ=Aat(AtMat(nat,nmat))
                        WJJ(nat)=WeightAtMat(nat,nmat)*AJ
                        S1=S1+WJJ(nat)
                enddo
                do nat=1,QAtMat(nmat)
                        WJJ(nat)=WJJ(nat)/S1
                enddo
                S1=0.0
                do nat=1,QAtMat(nmat)
                        ZJ=Zat(AtMat(nat,nmat))
                        AJ=Aat(AtMat(nat,nmat))
                        WJ=WJJ(nat)     
                        S1=S1+WJ*ZJ/AJ
                        S2=S2+WJ*ZJ*LOG(ZJ)/AJ
                enddo
                POTI=16.E-9*EXP(0.9*S2/S1)
        endif
                                
      POTL=LOG(POTI/EMASS)
      CON2=DENS*S1
      FAC=DENS*S1
      CON3=1.+2.*LOG(POTI/(28.8E-9*SQRT(CON2)))
        C= CON3     
C
C             Condensed material ?
C             (at present that means: DENS.GT.0.05 g/cm**3)
C
      IF(DENS.GT.0.05)THEN
         IF(POTI.LT.1.E-7)THEN
            IF(CON3.LT.3.681)THEN
               CON4=0.2
            ELSE
               CON4=0.326*CON3-1.
            ENDIF
            CON5=2.
         ELSE
            IF(CON3.LT.5.215)THEN
               CON4=0.2
            ELSE
               CON4=0.326*CON3-1.5
            ENDIF
            CON5=3.
         ENDIF
      ELSE
C
C             Gas (T=0 C, P= 1 ATM)
C             if T.NE. 0 C and/or P.NE. 1 ATM
C             you have to modify the variable X
C             X=>X+0.5*LOG((273+T C)/(273*P ATM))
C             in the function GDRELE
C             ------------------------
C
         IF(CON3.LE.12.25)THEN
            IP=INT((CON3-10.)/0.5)+1
            IF(IP.LT.0) IP=0
            IF(IP.GT.4) IP=4
            CON4=1.6+0.1*FLOAT(IP)
            CON5=4.
         ELSE
            IF(CON3.LE.13.804)THEN
               CON4=2.
               CON5=5.
            ELSE
               CON4=0.326*CON3-2.5
               CON5=5.
            ENDIF
         ENDIF
      ENDIF
C
      XA=CON3/4.606
      CON6=4.606*(XA-CON4)/(CON5-CON4)**3.

      X0=CON4
      X1=CON5
      AA=CON6
C
      X=LOG(GAM2-1.)/4.606
      DEL=0.
      IF(X.GT.X0)THEN
         DEL=4.606*X+C
         IF(X.LE.X1)DEL=DEL+AA*(X1-X)**3.
      ENDIF
C
      DEDX=CONS*FAC*(LOG(2.*T+4.)-2.*POTL+F-DEL)/BET2
      IF(DEDX.LT.0.)DEDX=0.
C
  99  RETURN
      END


+DECK,Inidel.
        subroutine Inidel
c
c       Initialize the delta eleectrons
c
        implicit none

c         include 'GoEvent.inc'
+SEQ,GoEvent.
c       include 'del.inc'
+SEQ,del.

        qdel=0
        sOverflowDel=0
        if(nevt.eq.1)then
                qOverflowDel=0
                qsOverflowDel=0
        endif

        end


        subroutine WorPridel

        implicit none

c         include 'GoEvent.inc'
+SEQ,GoEvent.
c       include 'del.inc'
+SEQ,del.

c       integer i,j

        if(nevt.eq.qevt)then

        if(qOverflowDel.gt.0)then
        write(oo,*)
        write(oo,*)' WorPridel: overflow of delta electrons arrays '
        write(oo,*)' sOverflowDel   qsOverflowDel   qOverflowDel'
        write(oo,*)sOverflowDel,qsOverflowDel,qOverflowDel
        endif

        endif

        end

        subroutine Pridel

c       print the delta electrons

        implicit none

c         include 'GoEvent.inc'
+SEQ,GoEvent.
c       include 'del.inc'
+SEQ,del.

        integer i,j

        if(soo.eq.0)return
        write(oo,*)
        write(oo,*)' Pridel: delta electron'
        write(oo,*)' sOverflowDel   qsOverflowDel   qOverflowDel'
        write(oo,*)sOverflowDel,qsOverflowDel,qOverflowDel

        write(oo,*)' qdel= ',qdel
        if(qdel.gt.0)then
        write(oo,*)
     +  ' ndel zdel   edel nVoldel Stdel ',
     +  'Ptdel updel(1) SOdel',
     +  ' rangepdel rangedel qstep'
        write(oo,*)
     +  ' pntdel(1,i)  pntdel(2,i)  pntdel(3,i) ',
     +  ' veldel(1,i)  veldel(2,i)  veldel(3,i)  '
        do i=1,qdel
        write(oo,
     + '(1X,I5,2(1X,e10.5),1(1X,I3),1(1X,I5),3(1X,I3),2(1X,E9.4),I6)')
     +          i,zdel(i),edel(i),nVoldel(i),Stdel(i),Ptdel(i),
     +          updel(1,i),
     +          SOdel(i),rangepdel(i),rangedel(i),qstepdel(i)
                write(oo,'(6(1X,e12.5))')(pntdel(j,i),j=1,3),
     +          (veldel(j,i),j=1,3)
        enddo
        endif

        end
+DECK,treatdel.
 

        subroutine treatdel
c
c       make absorbtion af delta electrons
c        write it to the cel.inc

        implicit none

c       include 'GoEvent.inc'
+SEQ,GoEvent.
c       include 'hist.inc'
+SEQ,hist.
c       include 'del.inc'
+SEQ,del.
c         include 'ener.inc'                      
+SEQ,ener.
c         include 'atoms.inc'                      
+SEQ,atoms.
c         include 'matters.inc'                      
+SEQ,matters.
c         include 'crosec.inc'                      
+SEQ,crosec.
c         include 'volume.inc'                      
+SEQ,volume.
c       include 'cel.inc'
+SEQ,cel.
c       include 'bdel.inc'
+SEQ,bdel.
c       include 'cconst.inc'
+SEQ,cconst.
c       include 'hconst.inc'
*** Added TRACK common to select tracing of delta's (RV 21/2/97).
+SEQ,DIMENSIONS.
+SEQ,PARAMETERS.
*** End of modification.
        integer id
        integer k
        integer q
        integer j
        integer ti
*** Modification for tracking delta's (RV 10/2/97)
        INTEGER IFAIL
*** End of modification.
        real*8 h
        real rra,rrb
        
c       integer cV
        integer cSV
        integer qn
c       real e,rr(4)
        integer sact
        real v3
c       integer s_change_dir, n_change_dir
*
c       data n_change_dir/1/
        real*8 s
c       real mod_add
c       real add(3)
c       real ranfl
c       real bet,p,x
        real msig
c       real alog,sqrt

        real WW,FF

        ti=0

c       if(srandoff.eq.1)then
c               n_change_dir=10000
c       endif
c       s_change_dir=n_change_dir
c               next 3 lines must be done in Inicel called from GoEvent
c       do k=1,QSVol
c               qcel(k)=0
c       enddo

        do id=1,qdel            ! main loop

c       call IniIonen
c       write(oo,*)' id=',id
c       write(oo,*)' rionener=', rionener

        nBdel=id
        ti=0


        rangBdel=0.0
        rangpBdel=0.0
        nstepBdel=0
        nVolBdel=nVoldel(id)
        if(sSensit(nVolBdel) .eq. 0)then
                sact=1
        else
                sact=0
        endif
c       if(srandoff.eq.1)then
c               nVolBdel=6
c               eBdel=esimtran
c               edel(id)=eBdel
c               pntBdel(1)=0.0
c               pntBdel(2)=0.0
cc              pntBdel(3)=wall1(nVolBdel)+
cc     +                        (wall2(nVolBdel)-wall1(nVolBdel))*0.5
c               pntBdel(3)=29.0
c               velBdel(1)=0.0
c               velBdel(2)=0.0
c               velBdel(3)=1.0
c               do j=1,3
c                   pntdel(j,id)=pntBdel(j)
c                   veldel(j,id)=velBdel(j)
c               enddo
c
c       else
                eBdel=edel(id)
                do j=1,3
                    pntBdel(j)=pntdel(j,id)
                    velBdel(j)=veldel(j,id)
                enddo
                if(eBdel.le.2.0*cuteneBdel)then

c               call PriBdel(1)

c               make the turn if the energy is too small
c               the electron must be traced by simple formula
c               for range without multiple scatering
c               so as it could be sensible
                if(eBdel.le.cuteneBdel)then
                        msig=0.4
                else
                if(eBdel.le.2.0*cuteneBdel)then
                        msig=0.2
                endif
                endif
                call lranor(rra,rrb)
                TetaBdel=rra*msig
                call MakeNewSys(e1Bdel,e2Bdel,e3Bdel,velBdel)
                call turnvec(e1Bdel,e2Bdel,e3Bdel,TetaBdel,velBdel)

c               call PriBdel(1)

                endif
c       endif
        sgonextBdel=0
        sturnBdel=0
        sisferBdel=0
        iBdel=0
        stepBdel=0.0

c       call MakeNewSys(e1Bdel,e2Bdel,e3Bdel,velBdel)

        if(nVolBdel.eq.0)then
c               call lstdelo
                go to 20
        endif
        if(eBdel.le.0.000001)then
c       if(eBdel.le.eMinBdel)then
c               call lstdelo
                go to 20
        endif
c       if(sMatC(nMatVol(nVolBdel)).eq.0)then   
c               call lstdelo
c               go to 20
c       endif

10      continue
*** Moved next statement after CALL SSTEPBDEL (RV 16/2/99)
C       nstepBdel=nstepBdel+1
*** End of modification.
c       call PriBdel(1)

*       if(s_change_dir.eq.1)then
*       if(sgonextBdel.eq.0.and.stepBdel.gt.0.0)then
**
c       e=eBdel
c       cV=nVolBdel
c               rr(1)=(1.0E-5/DensMat(nMatVol(cV)))
c     +         *1.0E4*(e*1.0E3)**1.5      
c               rr(1)=rr(1)/10000.0
c               rr(2)=0.71*(e**1.72)/DensMat(nMatVol(cV))
c               rr(3)=0.2115*(Z_Mean(nMatVol(cV))**0.26)*
c     +                 e**(1.265-0.0954*alog(e))/DensMat(nMatVol(cV))
c               
c               e=e*1000
c               rr(4)=1.225e-3*e**1.912/DensMat(nMatVol(cV))
c               e=e/1000
c               write(oo,*)' rr=',rr
c               stop

c           bet=1.0-ELMAS*ELMAS/((ELMAS+eBdel)*(ELMAS+eBdel))
c           bet=sqrt(bet)
c           p=eBdel*eBdel+2.0*ELMAS*eBdel
c           p=sqrt(p)
c           x=stepBdel/RLenMat(nMatVol(nVolBdel))
c           msig=sqrt(2.0)*13.6/(bet*p)*
c    +          sqrt(x)
*cc         msig=sqrt(2.0)*13.6/(bet*p)*
*cc     +               sqrt(x)*
*cc     +               (1.0 + 0.20*alog(x))
c           write(oo,*)' eBdel,stepBdel=',eBdel,stepBdel
c           write(oo,*)' msig=',msig
*
*c          call PriBdel(1)
*c          write(oo,*)' bet,p=',bet,p
*c          write(oo,*)' x,msig=',x,msig
*           mod_add=0.1*abs(ranfl())
*           if(srandoff.eq.1)then
*               mod_add=mod_add*0.001
*           endif
*           if(mod_add.gt.0.9)mod_add=0.9
*           call sfersim(add)
*           s=0.0
*           do j=1,3
*               velBdel(j)=velBdel(j)+mod_add*add(j)
*               s=s+velBdel(j)*velBdel(j)
*           enddo
*           s=sqrt(s)
*           do j=1,3
*               velBdel(j)=velBdel(j)/s
*           enddo
*cc         write(oo,*)' next  velBdel=',velBdel
*           s_change_dir=n_change_dir
*cc         irnc=n_change_dir
*       endif
*       else
*           s_change_dir=s_change_dir-1
*       endif
*** Modified the following line, original follows (RV 16/2/99).
C       call SstepBdel
C       if(nVolBdel.eq.0)then   ! this is current numbers
C               go to 20
C       endif
*** New lines, forcing volume search when tracing deltas.
       IF(LTREXB)NVOLBDEL=0
       CALL SSTEPBDEL
       IF(NVOLBDEL.EQ.0)THEN
            PRINT *,' !!!!!! TREATD WARNING : Delta electron'//
     -           ' has left tracking area; delta incomplete.'
            GOTO 20
       ENDIF
       NSTEPBDEL=NSTEPBDEL+1
*** End of modification.

        if(sSensit(nVolBdel) .eq. 0)then
c       if(sgonextBdel.eq.1)then
                sact=1
        endif

        if(estepBdel.gt.0)then

c       if(sMatC(nMatVol(nVolBdel)).eq.0)then   
c               call lstdelo
c               go to 20
c       endif
        if(srandoff.ne.1)then
            if(eBdel.gt.cuteneBdel)then
            if(estepBdel.lt.eBdel)then
                call lranor(rra,rrb)
                if(rra.lt.-2.0)rra=-2.0
                if(rra.gt. 2.0)rra= 2.0
                estepBdel=estepBdel+0.33333*estepBdel*rra
                if(estepBdel.gt.eBdel)estepBdel=eBdel
            endif
            endif
        endif
        if(sSensit(nVolBdel).eq.1)then
        if(nMatVol(nVolBdel).gt.0)then     ! not a vacuum
        if(WWW(nMatVol(nVolBdel)).gt.0)then
            WW=WWW(nMatVol(nVolBdel))
            FF=FFF(nMatVol(nVolBdel))   
            if(estepBdel.gt.0)then
                if(estepBdel.ne.eBdel)then
                    call lsgcele(estepBdel,WW,FF,q)
                else
                    call lsgcele1(estepBdel,WW,FF,q)
c                   call lsgcele(estepBdel,WW,FF,q)
                endif
                if(q.gt.0)then
                    h=stepBdel/q
                    cSV=numSensVol(nVolBdel)
c                   if(cSV.gt.0)then
                    if((qcel(cSV)+q) .gt. pqcel)then
                        qOverflowCel(cSV)=qOverflowCel(cSV)+q
                        if(sOverflowCel(cSV).eq.0)then
                            qsOverflowCel(cSV)=qsOverflowCel(cSV)+1
                            sOverflowCel(cSV)=1
                        endif
                    else
                    do k=1,q
                        qcel(cSV)=qcel(cSV)+1
*** Modification to trace delta's in E and B fields (RV 21/2/97).
       IF(LTREXB.AND.LTRDEL)THEN
            IF(K.EQ.1)THEN
                 CALL TRAEXB(pntBdel,velBdel,            ! Start
     -                pntcel(1,qcel(csV),csV),velBdel,   ! End
     -                eBdel,h,IFAIL)                     ! Energy, step
            ELSE
                 CALL TRAEXB(
     -                pntcel(1,qcel(csV)-1,csV),velBdel, ! Start
     -                pntcel(1,qcel(csV),csV),velBdel,   ! End
     -                eBdel-(k-1)*estepBdel/q,h,IFAIL)   ! Energy, step
            ENDIF
       ELSE
            do j=1,3
                pntcel(j,qcel(cSV),cSV)=
     +          pntBdel(j)+velBdel(j)*k*h
            enddo
       ENDIF
*** End of modification.
                        zcel(qcel(cSV),cSV)=1
                        Ndelcel(qcel(cSV),cSV)=id
                        sactcel(qcel(cSV),cSV)=sact
                    enddo
*** Addition: update the location and reference frame (RV 11/2/97)
       IF(LTREXB)THEN
            DO J=1,3
            npntBdel(j)=pntcel(j,qcel(csV),csV)
            ENDDO
            call MakeNewSys(e1Bdel,e2Bdel,e3Bdel,velBdel)
       ENDIF
*** End of addition.
                    if(shfillrang.eq.1)then
c                       make the change only for first and last electrons
                        s=0.0
                        qn=q-1
                        do j=1,3
                            s = s + 
     +                      (pntcel(j,(qcel(cSV)-qn),cSV)
     +                      - pntdel(j,nBdel)) * veldel(j,nBdel)
                        enddo
                        if(s.gt.rangpBdel)then
                            rangpBdel=s
                        endif
                        if(q.gt.1)then
                            s=0.0
                            do j=1,3
                                s = s + 
     +                          (pntcel(j,qcel(cSV),cSV)
     +                          - pntdel(j,nBdel)) * veldel(j,nBdel)
                            enddo
                            if(s.gt.rangpBdel)then
                                rangpBdel=s
                            endif
                        endif                   
                    endif                       
                    endif
c                   call Pricel
c                   if(nevt.eq.17.or.nevt.eq.18)then
c                   call PriBdel(1)
c                   write(oo,*)' q=',q,' rangpBdel=',rangpBdel
c                   endif
                endif
            endif
        endif
        endif
        endif

        endif

        do j=1,3
                pntBdel(j)=npntBdel(j)
        enddo
        eBdel=eBdel-estepBdel
        rangBdel=rangBdel+stepBdel
*       if(shfillrang.eq.1)then
c               It is enouph to do at the end of each step!
c               It was wrong algorithm becouse 
c               the electrons are created not on the each step
*           s=0.0
*           do j=1,3
*               s=s+(pntBdel(j)-pntdel(j,nBdel))*veldel(j,nBdel)
*           enddo
*           if(s.gt.rangpBdel)then
*               rangpBdel=s
*           endif
*       endif
c       if(eBdel.le.eMinBdel)then
        if(eBdel.le.0.000001)then
c               call lstdelo
                go to 20
        endif
c               The treatment of the electric and magnetic field
c               Now it will be very preliminary.
c               Calculate the actual velocity
                
        
        if(sturnBdel.eq.1)then
c               if(ti.le.1)then
                ti=ti+1
                v3=velBdel(3)
                call TurnBdel
                if(sgonextBdel.eq.1)then
                        if(v3.lt.0.and.velBdel(3).gt.0)then
                                sgonextBdel=0
                        else
                        if(v3.gt.0.and.velBdel(3).lt.0)then
                                sgonextBdel=0
                        endif
                        endif
                endif
c               endif
        endif

        go to 10

20      continue

*** Changed (RV 13/5/97).
C       call hfill(nh2_ard,rangBdel,edel(id),1.0)
        call hfill(nh2_ard,real(rangBdel),edel(id),1.0)
*** End of change.
        rangedel(nBdel)=rangBdel
        if(shfillrang.eq.1)then
                call hfill(nh2_rd,real(rangpBdel),edel(id),1.0)
                call hfill(nh1_rd,real(rangpBdel),0.0,1.0)
                rangepdel(nBdel)=rangpBdel
        endif

        qstepdel(nBdel)=nstepBdel

        enddo

        end


        subroutine lsgcele(e,WW,FF,irn)

        implicit none

c       include 'GoEvent.inc'
+SEQ,GoEvent.
c       include 'hconst.inc'
c       include 'lsmabs.inc'
        real wmabs,fmabs,e,RN,SIGMA,YY,DIMMY,w,wr
        real WW,FF      
        real r
        integer irn,i
        real ranfl
        wmabs=WW
c        wmabs=rionener
c       wmabs=0.000026
        fmabs=FF
c        fmabs=0.19
c       write(oo,*)' srandoff=',srandoff,' wmabs=',wmabs
        if(srandoff.eq.1)then
                fmabs=0.0
        endif
        if(e.gt.0.0)then
          RN=E/wmabs
          SIGMA=SQRT(fmabs*RN)
          CALL LRANOR(YY,DIMMY)
c          RN=RN+YY*SIGMA+0.4999
          r=YY*SIGMA            ! so as to prevent shift
          if(r.lt.-RN)then
                r=-RN
          elseif(r.gt.RN)then
                r=RN
          endif
c         if(r.lt.-1.0)then
c               r=-1.0
c         elseif(r.gt.1.0)then
c               r=1.0
c         endif

          RN=RN+r
          if(rn.le.0.0)then
            irn=0
            return
          endif
          i=rn
          w=1.0-(rn-i)
          wr=ranfl()            ! this is very small random.
                                ! I don't want to swich it off
c       write(oo,*)' e,rn,i,w,wr='
c       write(oo,*)e,rn,i,w,wr
          if(wr.lt.w)then
            rn=i
          else
            rn=i+1
          endif
          IF(RN.LT.0.0)RN=0.0
        else
                RN=0.0
        endif
        irn=rn
        end


        subroutine lsgcele1(e,WW,FF,irn)

        implicit none

c       include 'GoEvent.inc'
+SEQ,GoEvent.
c       include 'hconst.inc'
c       include 'lsmabs.inc'
        real wmabs,fmabs,e,RN,SIGMA,YY,DIMMY,w,wr
        real WW,FF
        real vmabs
        real r
        integer irn,i
        real ranfl
        wmabs=WW
c        wmabs=rionener
c       vmabs=0.000028
c       vmabs=wmabs*1.5
c       vmabs=wmabs
        vmabs=wmabs*0.5
c       vmabs=0.0000266
        if(e.le.vmabs)then
            irn=1
            return
        endif
c       wmabs=0.000026
        fmabs=FF
c        fmabs=0.19
c       write(oo,*)' srandoff=',srandoff
        if(srandoff.eq.1)then
                fmabs=0.0
        endif
        if(e.gt.0.0)then
          RN=(E-vmabs)/wmabs
          SIGMA=SQRT(fmabs*RN)
          CALL LRANOR(YY,DIMMY)
c          RN=RN+YY*SIGMA+0.4999
          r=YY*SIGMA            ! so as to prevent shift
          if(r.lt.-RN)then
                r=-RN
          elseif(r.gt.RN)then
                r=RN
          endif
c         if(r.lt.-1.0)then
c               r=-1.0
c         elseif(r.gt.1.0)then
c               r=1.0
c         endif

          RN=RN+r
          if(rn.le.0.0)then
            irn=1
            return
          endif
          i=rn
          w=1.0-(rn-i)
          wr=ranfl()            ! this is very small random.
                                ! I don't want to swich it off
c       write(oo,*)' e,rn,i,w,wr='
c       write(oo,*)e,rn,i,w,wr
          if(wr.lt.w)then
            rn=i
          else
            rn=i+1
          endif
          IF(RN.LT.0.0)RN=0.0
        else
                RN=0.0
        endif
c       IF(RN.LT.1.0)RN=1.0
        rn=rn+1
        irn=rn
        end

+DECK,Inicel.
        subroutine Inicel

c       Initialize the current electrons

        implicit none

c       include 'GoEvent.inc'
+SEQ,GoEvent.
c       include 'volume.inc'
+SEQ,volume.
c       include 'cel.inc'
+SEQ,cel.
        
        integer k

        do k=1,QSVol
                qcel(k)=0
                sOverflowCel(k)=0
        enddo

        if(nevt.eq.1)then
            do k=1,QSVol
                qOverflowCel(k)=0
                qsOverflowCel(k)=0
            enddo
        endif

        end

        subroutine WorPricel

c       print the current electrons

        implicit none

c       include 'GoEvent.inc'
+SEQ,GoEvent.
c       include 'volume.inc'
+SEQ,volume.
c       include 'cel.inc'
+SEQ,cel.

        integer k

        if(nevt.eq.qevt)then

        do k=1,QSVol
                if(qOverflowCel(k).gt.0)then
                        go to 10
                endif
        enddo
        return

10      continue
        
        write(oo,*)
        write(oo,*)' WorPricel: overflow of curren electrons arrays '
        write(oo,*)' QSVol=',QSVol
        do k=1,QSVol
        write(oo,*)' number of lay =',k
        write(oo,*)' sOverflowCel   qsOverflowCel   qOverflowCel'
        write(oo,*)sOverflowCel(k),qsOverflowCel(k),qOverflowCel(k)
        enddo

        endif

        end

        subroutine Pricel

c       print the current electrons

        implicit none

c         include 'GoEvent.inc'
+SEQ,GoEvent.
c       include 'volume.inc'
+SEQ,volume.
c       include 'cel.inc'
+SEQ,cel.

        integer k,i,j

        if(soo.eq.0)return
        write(oo,*)
        write(oo,*)' Pricel: curren electrons '
        write(oo,*)' QSVol=',QSVol
        do k=1,QSVol
        write(oo,*)' number of lay =',k
        write(oo,*)' sOverflowCel   qsOverflowCel   qOverflowCel'
        write(oo,*)sOverflowCel(k),qsOverflowCel(k),qOverflowCel(k)
        if(qcel(k).gt.0)then
        write(oo,*)' qcel(k)= ',qcel(k)
        write(oo,*)'  szcel(k)= ',szcel(k)
        write(oo,*)
     +  ' ncel  zcel       Ndelcel sactcel'
        write(oo,*)
     +  ' pntcel(1,i,k)  pntcel(2,i,k)  pntcel(3,i,k) '
        do i=1,qcel(k)
                write(oo,'(i5,1(1X,e12.5),5(1X,I5))')
     +          i,zcel(i,k),
     +          Ndelcel(i,k),sactcel(i,k)
                write(oo,'(3(1X,e15.8))')(pntcel(j,i,k),j=1,3)
        enddo
        endif
        enddo


        end
+DECK,treatcel.
        subroutine treatcel
c
c       Calculate the total charge 
c
        implicit none

c         include 'volume.inc'
+SEQ,volume.
c         include 'cel.inc'
+SEQ,cel.

        integer i,j
        real s
c       real r,cr

        do i=1,QSVol

                s=0
                do j=1,qcel(i)
                        s=s+zcel(j,i)
                enddo
                szcel(i)=s
        enddo

        end
+DECK,SourcePh.
 

        subroutine SourcePhot(pnt,vel,e)
c
c       Source of the photons
c
        implicit none

c         include 'GoEvent.inc'
+SEQ,GoEvent.
c         include 'rga.inc'
+SEQ,rga.
        
        real vel(3),e
        real*8 pnt(3)
        integer i,nv,nqup

        nv=0
        call VolNumZcoor(pnt(3),vel(3),nv)
        if(nv.eq.0)then
                write(oo,*)
     +  ' worning of SourcePhot: the source can not light out of set'
                return
        endif

       if(qrga .eq. pqrga)then
            qOverflowrga=qOverflowrga+1
            if(sOverflowrga.eq.0)then
                qsOverflowrga=qsOverflowrga+1
                sOverflowrga=1
            endif
        else


        qrga=qrga+1
        erga(qrga)=e
        do i=1,3
                pntrga(i,qrga)=pnt(i)
                velrga(i,qrga)=vel(i)
        enddo
        nVolrga(qrga)=nv
c        Strga(qrga)=10000      in this case it need to settle
c                               the number of transition volume
c                               It is used in lsta_abs
        Strga(qrga)=1
        Ptrga(qrga)=0
        do nqup=1,pqup
                uprga(nqup,qrga)=0
        enddo
        SFrga(qrga)=0

        endif

        end
+DECK,SourceDe.
 

        subroutine SourceDelEl(pnt,vel,e)
c
c       Auxiliary generator of delta-electron. 
c
        implicit none

c         include 'GoEvent.inc'
+SEQ,GoEvent.
c       include 'del.inc'
+SEQ,del.
        
        real e,vel(3)
        real*8 pnt(3)

        integer nv,j,nqup
c       integer i

        nv=0
        call VolNumZcoor(pnt(3),vel(3),nv)
        if(nv.eq.0)then
                write(oo,*)
     +  ' worning of SourceDelEl: the source can not light out of set'
                return
        endif
        

            if(qdel .eq. pqdel)then
                qOverflowDel=qOverflowDel+1
                if(sOverflowDel.eq.0)then
                    qsOverflowDel=qsOverflowDel+1
                    sOverflowDel=1
                endif
            else

                qdel=qdel+1
                Ptdel(qdel)=0
                Stdel(qdel)=1
                do nqup=1,pqup
                        updel(nqup,qdel)=0
                enddo
                SOdel(qdel)=0
                do j=1,3
                        pntdel(j,qdel)=pnt(j)
                enddo
                do j=1,3
                        veldel(j,qdel)=vel(j)
                enddo
                zdel(qdel)=1
                edel(qdel)=e
                nVoldel(qdel)=nv
                rangepdel(qdel)=0.0
                rangedel(qdel)=0.0

            endif

        end
+DECK,vectors.
c       several subroutines for vector algebra
c       single accuracy

        subroutine GoOldSys(e1,e2,e3,v,ov)
c
c       Go to old system
c
        implicit none

        real e1(3),e2(3),e3(3)  ! coordinates of new orts in the old
        real v(3)               ! vector in the new system
        real ov(3)              ! vector in the old system
c       real s
c       integer i

        ov(1)=v(1)*e1(1) + v(2)*e2(1) + v(3)*e3(1)
        ov(2)=v(1)*e1(2) + v(2)*e2(2) + v(3)*e3(2)
        ov(3)=v(1)*e1(3) + v(2)*e2(3) + v(3)*e3(3)

c       write(6,*)' GoOldSys'
c       write(6,*)' v=',v
c       write(6,*)' ov=',ov
c       write(6,*)' e1=',e1
c       write(6,*)' e2=',e2
c       write(6,*)' e3=',e3
c       s=0.0
c       do i=1,3
c               s=s+e1(i)*e1(i)
c       enddo
c       write(6,*)' abs(e1)=',s
c       s=0.0
c       do i=1,3
c               s=s+e2(i)*e2(i)
c       enddo
c       write(6,*)' abs(e2)=',s
c       s=0.0
c       do i=1,3
c               s=s+e3(i)*e3(i)
c       enddo
c       write(6,*)' abs(e3)=',s
c       s=0.0
c       do i=1,3
c               s=s+ov(i)*ov(i)
c       enddo
c       write(6,*)' abs(ov)=',s
        

        end

        subroutine MakeNewSys(e1,e2,e3,v)
c
c       Make new system
c
        implicit none

        real e1(3),e2(3),e3(3)  ! coordinates of new orts in the old

        real v(3)               ! vector (equal)

        real s
        integer i

        do i=1,3
                e3(i)=v(i)
        enddo
        if(e3(2).eq.0.0.and.e3(3).eq.0.0)then
                e1(1)=0.0
                e1(2)=0.0
                e1(3)=-1.0
                e2(1)=0.0
                e2(2)=1.0
                e2(3)=0.0
c       write(6,*)' v=',v
c       write(6,*)' e1=',e1
c       write(6,*)' e2=',e2
c       write(6,*)' e3=',e3
                return
        endif
        e2(1)=0.0
        e2(2)=e3(3)
        e2(3)=-e3(2)
        s=0.0
        do i=1,3
                s=s+e2(i)*e2(i)
        enddo   
        s=sqrt(s)
        do i=1,3
                e2(i)=e2(i)/s
        enddo

        e1(1)=e2(2)*e3(3)-e3(2)*e2(3)
        e1(2)=e3(1)*e2(3)-e2(1)*e3(3)
        e1(3)=e2(1)*e3(2)-e3(1)*e2(2)

        s=0.0
        do i=1,3
                s=s+e1(i)*e1(i)
        enddo   
        s=sqrt(s)
        do i=1,3
                e1(i)=e1(i)/s
        enddo

c       write(6,*)' MakeNewSys'
c       write(6,*)' v=',v
c       write(6,*)' e1=',e1
c       write(6,*)' e2=',e2
c       write(6,*)' e3=',e3
c       s=0.0
c       do i=1,3
c               s=s+e1(i)*e1(i)
c       enddo
c       write(6,*)' abs(e1)=',s
c       s=0.0
c       do i=1,3
c               s=s+e2(i)*e2(i)
c       enddo
c       write(6,*)' abs(e2)=',s
c       s=0.0
c       do i=1,3
c               s=s+e3(i)*e3(i)
c       enddo
c       write(6,*)' abs(e3)=',s
c       s=0.0
c       do i=1,3
c               s=s+e1(i)*e2(i)
c       enddo
c       write(6,*)' e1*e2=',s
c       s=0.0
c       do i=1,3
c               s=s+e2(i)*e3(i)
c       enddo
c       write(6,*)' e2*e3=',s
c       s=0.0
c       do i=1,3
c               s=s+e3(i)*e1(i)
c       enddo
c       write(6,*)' e3*e1=',s
c       s=0.0
c       do i=1,3
c               s=s+v(i)*v(i)
c       enddo
c       write(6,*)' abs(v)=',s

        end     


        subroutine Ncirclesim(e1,e2,e3,v)
c
c       generate vector with circle simmetry in the system
c               around e3 axis
        implicit none

        real e1(3),e2(3),e3(3)  ! coordinates of new orts in the old

        real v(3)               ! vector (equal)

c       real ranfl

        real r(3)
c       real s
c       integer i

        call circlesim(r)
c       write(6,*)' Ncirclesim'
c       s=0.0
c       do i=1,3
c               s=s+r(i)*r(i)
c       enddo
c       write(6,*)' s=',s
        call GoOldSys(e1,e2,e3,r,v)
c       write(6,*)' Ncirclesim'
c       s=0.0
c       do i=1,3
c               s=s+e3(i)*v(i)
c       enddo
c       write(6,*)' s=',s
c       s=0.0
c       do i=1,3
c               s=s+v(i)*v(i)
c       enddo
c       write(6,*)' s=',s
c       write(6,*)' e3=',e3
c       write(6,*)' v=',v


        end


        subroutine circlesim(v)
c
c       generate vector with circle simmetry around e3
c               around z axis

        implicit none

        real v(3)               ! vector (equal)

        real ranfl

        real F

        F=3.14159*2.0*ranfl()
        v(1)=cos(F)
        v(2)=sin(F)
        v(3)=0.0

        end


        subroutine sfersim(r)
c
c       generate vector with sferical simmetry
c
        implicit none
        real r(3)
        real costeta,sinteta,F
        real RANFL
c        real RANFL,COS,SIN,sqrt
C          SFERICAL SIMMETRY
                        costeta=1.0-2.0*RANFL()
                        sinteta=sqrt(1.0-costeta*costeta)
                        F=3.14159*2.0*RANFL()
                        r(1)=COS(F)*sinteta
                        r(2)=SIN(F)*sinteta
                        r(3)=costeta

        end


        subroutine turnvec(e1,e2,e3,teta, v)
c
c       turn the vector
c               assumed that old vector is along  e3 axis
c               the angle phi is rundom

        implicit none
c       include 'cconst.inc'
+SEQ,cconst.

        real e1(3),e2(3),e3(3)  ! coordinates of current orts in the old

        real v(3)               ! vector (equal)
        real teta
        integer n,i
        real rad(3),rss
c       real sqrt

        if(Teta.lt.0.0)Teta=-Teta
        if(Teta.gt.4.0*PI)then
                n=Teta/(4.0*PI)
                Teta=Teta-n*4.0*PI
        endif
        if(Teta.gt.2.0*PI)then
                Teta=4.0*PI-Teta
        endif
        if(Teta.eq.PI)then
                do i=1,3
                        v(i)=-e3(i)
                enddo
        elseif(Teta.eq.0.0)then
                do i=1,3
                        v(i)=e3(i)
                enddo
        else
                call Ncirclesim(e1,e2,e3,rad)
                rss=tan(Teta)
                if(rss.lt.0.0)then
                        rss=-rss
                        n=-1
                else
                        n=1
                endif
                do i=1,3
                        rad(i)=rad(i)*rss
                        v(i)=n*e3(i)+rad(i)
                enddo
                rss=0.0
                do i=1,3
                        rss=rss+v(i)*v(i)
                enddo
                rss=sqrt(rss)
                do i=1,3
                        v(i)=v(i)/rss
                enddo
        endif
c       write(6,*)' turnvec'
c       write(6,*)' teta=',teta
c       write(6,*)' e1=',e1
c       write(6,*)' e2=',e2
c       write(6,*)' e3=',e3
c       write(6,*)' v=',v
c       rss=0.0
c       do i=1,3
c               rss=rss+e3(i)*v(i)
c       enddo
c       rss=acos(rss)
c       write(6,*)' rss=',rss

        end
+DECK,random.
        subroutine Iniranfl
c
c       Initialize the random numbers generator
c       iranfl is intent for calc. of number of call of geenerator
c       It is so as it can be possible to figer out, where the
c       new circle starts, if the user knows the period.
c
        implicit none

c       include  'random.inc'
+SEQ,random.

c       real*8 iranfl
c       common / comran / iranfl
c       save / comran /

        iranfl=0

        end


        function ranfl()
c
c       Random numbers generator
c
        implicit none
        real ranfl,ranf
        real x

c         include  'random.inc'
+SEQ,random.


c       real*8 iranfl
c       common / comran / iranfl
c       save / comran /


        iranfl=iranfl+3
c       The several preliminary calls to avoid correlations
c       between the previous and the next value.
        x=ranf()
        x=ranf()
        ranfl=ranf()     ! CERNLIB

        return 

        end

        subroutine randset
c
c       set the start point
c
        implicit none

c       include  'random.inc'
+SEQ,random.

        call ranset(rseed)

        end

        subroutine randget
c
c       get the current point
c
        implicit none

c       include  'random.inc'
+SEQ,random.

        call ranget(rseed)

        end

        subroutine randpri(oo)
c
c       print the current point
c
        implicit none

        integer oo

c       include  'random.inc'
+SEQ,random.

        write(oo,*)'seed=',seed
        
        end
        

        subroutine Priranfl

c       It is called at the end of program

        implicit none

c         include 'GoEvent.inc'
+SEQ,GoEvent.
c       include  'random.inc'
+SEQ,random.

c       real*8 iranfl
c       common / comran / iranfl
c       save / comran /

        if(soo.eq.0)return
        write(oo,*)
        write(oo,*)'  Priranfl:     iranfl=',iranfl

        end


      SUBROUTINE LRANOR(A,B)
C.
c       Copy of the geant321 routine GRANOR for ranfl generator
C.    ******************************************************************
C.    *                                                                *
C.    *       To generate 2 numbers A and B following a NORMAL         *
C.    *       distribution (mean=0 sigma=1.)                           *
C.    *         Copy of the CERN Library routine RANNOR                *
C.    *                                                                *
C.    *    ==>Called by : <USER>, many GEANT routines                  *
C.    *       Author    F.Carminati *********                          *
C.    *                                                                *
C.    ******************************************************************
C.
*      DIMENSION RNDM(2)
*
*      CALL GRNDM(RNDM,2)
      Y=ranfl()
      Z=ranfl()
      X=6.283185*Z
      A1=SQRT (-2.0*LOG(Y))
      A=A1*SIN (X)
      B=A1*COS (X)
      RETURN
      END

      SUBROUTINE LSPOIS (AMU,N,IERROR)
C
c       This is modified library routine poissn.
c       One or two errors was corrected here.
c
C    POISSON GENERATOR
C    CODED FROM LOS ALAMOS REPORT      LA-5061-MS
C    PROB(N)=EXP(-AMU)*AMU**N/FACT(N)
C        WHERE FACT(N) STANDS FOR FACTORIAL OF N
C    ON RETURN IERROR.EQ.0 NORMALLY
C              IERROR.EQ.1 IF AMU.LE.0.
C
        SAVE    !my correction
      DATA AMUOL/-1./
      DATA AMAX/100./
c       write(6,*)' amu=',amu
      IERROR=0  !my correction
      IF(AMU.GT.AMAX) GO TO 500
      IF(AMU.EQ.AMUOL) GO TO 200
      IF(AMU.GT.0.) GO TO 100
C    MEAN SHOULD BE POSITIVE
      IERROR=1
      N = 0
      RETURN
C    SAVE EXPONENTIAL FOR FURTHER IDENTICAL REQUESTS
  100 IERROR=0
      AMUOL=AMU
      EXPMA=EXP(-AMU)
  200 PIR=1.
c       write(6,*)' ierror=',ierror
      N=-1
  300 N=N+1
c      PIR=PIR*RNDM(N)
      PIR=PIR*ranfl()
      IF(PIR.GT.EXPMA) GO TO 300
      RETURN
C   NORMAL APPROXIMATION FOR AMU.GT.AMAX
  500 CALL LRANOR(RAN,DUMMY)
      N=RAN*SQRT(AMU)+AMU+.5
      RETURN
C   ENTRY FOR USER TO SET AMAX, SWITCHOVER POINT TO NORMAL APPROXIMATION
      ENTRY lPOISET(AMU)
      PRINT 1001,AMU
 1001 FORMAT(77H POISSON RANDOM NUMBER GENERATOR TO SWITCH TO NORMAL APP
     CROXIMATION ABOVE AMU= ,F12.2)
      AMAX=AMU
      RETURN
      END


      SUBROUTINE lHISRAN(Y,N,XLO,XWID,XRAN)

c       corrected for working with  program HEED

C         SUBROUTINE TO GENERATE RANDOM NUMBERS
C         ACCORDING TO AN EMPIRICAL DISTRIBUTION
C         SUPPLIED BY THE USER IN THE FORM OF A HISTOGRAM
C         F. JAMES,    MAY, 1976
      DIMENSION Y(*)
      DATA IERR,NTRY,NXHRAN,NXHPRE/0,3HRAN,3HRAN,3HPRE/
      IF(Y(N).EQ.1.0) GOTO 200
      WRITE(6,1001) Y(N)
 1001 FORMAT('0SUBROUTINE HISRAN FINDS Y(N) NOT EQUAL TO 1.0     Y(N)='
     +,E15.6/' ASSUMES USER HAS SUPPLIED HISTOGRAM RATHER THAN CUMUL',
     +'ATIVE DISTRIBUTION AND HAS FORGOTTEN TO CALL lHISPRE'/)
      NTRY=NXHRAN
      GOTO 50
C         INITIALIZE HISTOGRAM TO FORM CUMULATIVE DISTRIBUTION
C+SELF,IF=CDC,IF=F4.
C      ENTRY lHISPRE
C+SELF,IF=-CDC,-F4.
      ENTRY lHISPRE(Y,N)
C+SELF.
      NTRY=NXHPRE
   50 CONTINUE
      YTOT = 0.
      DO 100 I= 1, N
      IF(Y(I).LT.0.) GOTO 900
      YTOT = YTOT + Y(I)
  100 Y(I) = YTOT
      IF(YTOT.LE.0.) GOTO 900
      YINV = 1.0/YTOT
      DO 110 I= 1, N
  110 Y(I) = Y(I) * YINV
      Y(N) = 1.0
      IF(NTRY.EQ.NXHPRE) RETURN
C         NOW GENERATE RANDOM NUMBER BETWEEN 0 AND ONE
  200 CONTINUE
c      YR = RNDM(-1)
        YR=ranfl()
C         AND TRANSFORM IT INTO THE CORRESPONDING X-VALUE
      L = LOCATF(Y,N,YR)
      IF(L.EQ.0) GOTO 240
      IF(L.GT.0) GOTO 250
C         USUALLY COME HERE.
      L = ABS(L)
      XRAN = XLO + XWID * (L +((YR-Y(L))/(Y(L+1)-Y(L))))
      RETURN
C         POINT FALLS IN FIRST BIN.  SPECIAL CASE
  240 XRAN = XLO + XWID * (YR/Y(1))
      RETURN
C         GUARD AGAINST SPECIAL CASE OF FALLING ON EMPTY BIN
  250 XRAN = XLO + L * XWID
      RETURN
  900 CONTINUE
      IERR = IERR + 1
      IF(IERR.LT.6) WRITE(6,1000)NTRY
      IF(L.GT.0) GOTO 250
      IF(NTRY.EQ.NXHPRE) RETURN
 1000 FORMAT('0ERROR IN INPUT DATA FOR HIS',A3,' VALUES NOT ALL >=0'/)
      WRITE(6,1002) (Y(K),K=1,N)
 1002 FORMAT(1X,10F13.7)
      XRAN = 0.
      RETURN
      END


+DECK,hist.
 
        subroutine IniHist

c       initialize common histograms 
c       

        implicit none

c         include 'GoEvent.inc'
+SEQ,GoEvent.
c       include 'hist.inc'
+SEQ,hist.
c       include 'volume.inc'
+SEQ,volume.


        integer nsv
        integer imaxhisample
        imaxhisample=maxhisample

        if(QSVol.le.MaxHistQSVol)then
                hQSVol=QSVol
        else
                hQSVol=MaxHistQSVol
        endif


        do nsv=1,hQSVol     ! circle over the sensitive volumes


               CALL HBOOK1(
     +          nh1_ampK + nsv,
     +          '  amplitude (KeV)$',
     +          pqhisampl, 0.0, maxhisampl*1.0e3, 0.0)
                                ! it is defined in MeV
               CALL HBOOK1(
     +          nh1_ampKR + nsv,
     +          '  amplitude (KeV)$',
     +          pqhisampl, 0.0, maxhisampl*1.0e3, 0.0)
                                ! it is defined in MeV
  
               CALL HBOOK1(
     +          nh1_ampN+nsv,
     +          '  amplitude in numbers of conduction electrons$',
     +          imaxhisample, 0.0, maxhisample, 0.0)  


               CALL HBOOK1(
     +          nh1_cdx + nsv,
     +          ' charge distribution along x$',
     +          pqh2,-0.02,0.02,0.0)  

               CALL HBOOK1(
     +          nh1_cdy + nsv,
     +          ' charge distribution along y$',
     +          pqh2,-0.02,0.02,0.0)  

               CALL HBOOK1(
     +          nh1_cdz + nsv,
     +          ' charge distribution along z$',
     +          pqh2,  
     +          real(wall1(numVolSens(nsv))),
     +          real(wall2(numVolSens(nsv))),0.0)  


        enddo


       CALL HBOOK2(
     +  nh2_ard,
     +  ' Actual range of delta-electron(cm) vs energy(MeV).$',
     +          pqh,0.0,1.0,
     +          pqh,0.0,0.002,0.0)
       CALL HBOOK2(
     +  nh2_rd,
     +  'Range along initial direction of delta-electron vs energy.$',
     +          pqh,0.0,0.01,
     +          pqh,0.0,0.002,0.0)
       CALL HBOOK1(
     +  nh1_rd,
     +  ' Range along initial direction of delta-electron (cm). $',
     +          pqh,0.0,0.01,0.0)


        end


        subroutine FHist

c       fill histograms 
c       

        implicit none

c       include 'GoEvent.inc'
+SEQ,GoEvent.
c       include 'hist.inc'
+SEQ,hist.
c       include 'volume.inc'
+SEQ,volume.
c       include 'cel.inc'
+SEQ,cel.
c       include 'del.inc'
+SEQ,del.
c       include 'rga.inc'
+SEQ,rga.
c       include 'abs.inc'
+SEQ,abs.
c       include 'lsgvga.inc'
+SEQ,lsgvga.
c         include 'ener.inc'
+SEQ,ener.
c         include 'atoms.inc'
+SEQ,atoms.
c         include 'matters.inc'
+SEQ,matters.
c       include 'track.inc'
+SEQ,track.
                        
        integer nsv,ncel,nv,nm

        real ranfl
        real r


        do nsv=1,hqSVol
        

                nv=numVolSens(nsv)
                nm=nMatVol(nv)

                call hf1(nh1_ampK + nsv,szcel(nsv)*WWW(nm)*1.0e3,1.0)

                r=ranfl()-0.5
                r=(szcel(nsv)+r)*WWW(nm)*1.0e3
                if(r.lt.0)r=0
                call hf1(nh1_ampKR + nsv, r, 1.0)

                call hf1(nh1_ampN + nsv,szcel(nsv),1.0)


            do ncel=1,qcel(nsv) ! circle on conduction electrons

                call hf1(
     +          nh1_cdx + nsv, 
     +          real(pntcel(1,ncel,nsv)), zcel(ncel,nsv))

                call hf1(
     +          nh1_cdy + nsv, 
     +          real(pntcel(2,ncel,nsv)), zcel(ncel,nsv))

                call hf1(
     +          nh1_cdz + nsv, 
     +          real(pntcel(3,ncel,nsv)), zcel(ncel,nsv))

            enddo


        enddo


        end

        SUBROUTINE WHist
C
C-----------------------------------------------------------------
C|                                                               |
C|        TERMINATION ROUTINE TO PRINT HISTOGRAMS                |
C|                                                               |
C|                                                               |
C|                                                               |
C----------------------------------------------------------------|
        implicit none

c         include 'GoEvent.inc'
+SEQ,GoEvent.
c       include 'hist.inc'
+SEQ,hist.

c        Integer*4 i,j,k,l,m,n
        Integer*4 istat,icycle
C
          call hropen(HistLun,'mybook',HistFile,'nq',1024,istat) ! rz file
          if (istat.ne.0) go to 999        ! if error
          call hcdir('//PAWC',' ')         ! root directory in memory
          call hcdir('//mybook',' ')       ! root directory on disk
         CALL HROUT(0,icycle,' ')          ! write all on disk
C
         CALL HREND('mybook')
C
        goto 1000
 999    continue
        write (oo,100)istat
 100    format(1x,//,1x,'*** UGLAST: error of writing, ISTAT= ',i6)
 1000   continue
        CLOSE(HistLun)
        RETURN
        END
+QUIT.