+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.
