c
c------------------------------------------------------------------------------
c
c	Changes starting on 17-Oct-2000, TP, PSI
c
c	- add position of muons at TD foil and position of
c         foil electrons when hitting MCP3 to NTuple
c	- start changes for migration to NT and Unix; avoid using
c	  logicals or environment variables; cancel OPTIONS/EXTEND_SOURCE;
c	  use lower case filenames always
c
c******************************************************************************
c* ... MUTRACK.FOR  (Stand: Februar '96)				      *
c*									      *
c* Dieses Programm integriert Teilchenbahnen in der UHV-Kammer der NEMU-      *
c* Apparatur. Startpunkte koennen zwischen der Moderatorfolie und dem MCP2    *
c* frei gewaehlt werden, Endpunkt der Berechnungen ist (sofern die Teilchen   *
c* nicht vorher schon ausscheiden) die Ebene des MCP2. Bis jetzt koennen      *
c* also nur Bewegungen in Strahlrichtung, nicht entgegen derselben berechnet  *
c* werden.								      *
c* Das Programm selbst rechnet den zweistufigen Beschleuniger als ideal,      *
c* bietet aber die Moeglichkeit Simulationen von TP oder AH (Programm 'Accel')*
c* mit realem Beschleuniger einzulesen. Die Integration der Teilchenbahnen    *
c* erstreckt sich bei diesen Simulationen bis etwa zum He-Schild, MUTRACK     *
c* rechnet dann von dort aus weiter. 					      *
c* Verschiedene Einstellungen koennen in ineinandergreifenden Schleifen in    *
c* aequidistanten Schritten variiert werden (z.B. Spannungen des Transport-   *
c* Systems, Startgroessen der Teilchen, Masse und Ladung ...). Ein Teil dieser*
c* Groessen kann aber auch alternativ nach verschiedenen frei waehlbaren      *
c* Zufallsverteilungen gewurfelt werden.				      *
c* Die Integrationsergebnisse koennen in der Form von NTupeln abgespeichert   *
c* werden, was sie der Darstellung und Auswertung mit dem CERN-Programm PAW   *
c* zugaenglich macht.							      *
c* Neben der reinen Integrationsarbeit fuehrt Mutrack Statistiken ueber       *
c* verschiedene Groessen (z.Z. verschiedene Flugzeiten und Ortsverteilungen)  *
c* die Mittelwerte und Standandartabweichungen sowie Minimal- und Maximalwerte*
c* umfassen.								      *
c* Diese Groessen koennen einfach ausgegeben oder in einem Tabellenfile abge- *
c* speichert werden, welches von PHYSICA mittels der Fortran-Routine          *
c* 'READ_DATA' eingelesen werden kann. Verschiedene PHYSICA-Makros	      *
c* (.PCM-files)	ermoeglichen dann die Darstellung dieser statistischen	      *
c* Groessen in Form von 2D- und 3D-Graphiken. (z.B. Abhaengigkeit der Trans-  *
c* mission von HV-Settings des Transportsystems).			      *
c* Die momentan vorhandenen Routinen heissen				      *
c*									      *
c*		MUINIT.PCM						      *
c*		HELP.PCM						      *
c*		MUPLOT_1DIM.PCM						      *
c*		MUPLOT_2DIM.PCM						      *
c*		TYPE_LOGHEADER.PCM					      *
c*		TYPE_PARAMS_GRAPHIC.PCM					      *
c*		TYPE_PARAMS_TEXT.PCM					      *
c*									      *
c* Nach dem Start (von dem Directory aus, in dem obige Routinen abgelegt sind)*
c* muss PHYSICA mit dem Befehl '@MUINIT' initialisiert werden. Danach koennen *
c* obige Routinen ueber Aliasse angesprochen werden. Weitere Informationen    *
c* hierzu erhaelt man, indem man in PHYSICA nach der Initialisierung 'MUHELP' *
c* eingibt.								      *
c* Der Sourcecode fuer Mutrack ist ueber verschiedene .FOR-Dateien verteilt,  *
c* die jeweils zu einem Problembereich gehoerige Subroutinen enthalten. Die   *
c* zur Zeit vorhandenen Files und die darin enthaltenen Routinen sind:
c*
c*	MUTRACK.FOR
c* 	SUB_ARTLIST.FOR
c* 	SUB_OUTPUT.FOR
c* 	SUB_INPUT.FOR
c* 	SUB_INTEGR_FO.FOR
c* 	SUB_INTEGR_L1.FOR
c* 	SUB_INTEGR_L3.FOR
c* 	SUB_INTEGR_M2.FOR
c* 	SUB_PICTURE.FOR
c* 	SUB_TRIGGER.FOR
c*
c*
c* Includefiles mit COMMON-Blöcken:
c*
c* 	COM_DIRS.INC
c* 	COM_KAMMER.INC
c* 	COM_LUNS.INC
c* 	COM_MUTRACK.INC
c* 	COM_OUTPUT.INC
c* 	COM_TD_EXT.INC
c* 	COM_TD_INT.INC
c* 	COM_WINKEL.INC
c* 	GEO_KAMMER.INPUT
c* 	GEO_TRIGGER.INC
c*
c*
c* Icludefile mit Defaultwerten fuer eine Reihe benutzerdefinierbarer und Programm-
c* interner Groessen:
c*
c* 	INITIALIZE.INC
c*
c*
c* Includefiles fuer die Potentialmappen:
c*
c* 	MAP_DEF_FO.INC
c* 	MAP_DEF_L1.INC
c* 	MAP_DEF_L3.INC
c* 	MAP_DEF_M2.INC
c*
c* 	READ_MAP.INC
c*
c*
c* Benoetigte Eingabfiles:
c*
c* 	MUTRACK.INPUT	    (fuer die Integrationen zu verwendende Einstellungen)
c*	kammer_geo.INPUT    (Spezifizierung der Kammergeometrie)
c*	mappenName.INFO	    (Dateien mit Angaben ueber zugehoerige Potentialmappen)
c*	mappenName.MAPPE    (die Potentialmappen)
c* 	MUTRACK_NR.DAT	    (zuletzt vergebene Nummern der Ausgabedateien, wird
c*			    von Mutrack verwaltet).
c*
c*
c* Fuer die Erstellung der Potentialmappen mit dem Triumf-Programm stehen folgende
c* Hilfsmittel zur Verfuegung:
c*
c* 	BESCHL-INIT.FOR
c*	LENSE-INIT.FOR
c*
c* Diese Boundary-Routinen stellen folgende Moeglichkeiten zur Verfuegung:
c*
c* Initialisierung von Scratch, von 2D und von 3D-Mappen. Kontrollmoeglichkeiten
c* ueber die Ausgabe der Potentialbereiche.
c*
c* Die Mappen koennen von PHYSICA aus mittels der FORTRAN-Routine '         '
c* und den .PCM-Makros '        ' ... angeschaut und ausgegeben werden.
c*
c*
c*
c* Liste der moeglichen Ausgabefiles:
c*
c*	MU_nnnn.LOG
c*	MU_nnnn.GEO
c*	MU_nnnn.PHYSICA
c*	MU_nnnn.NTP
c*	MU_nnnn._tab
c*
c* Diese Version von MUTRACK enthaelt nur noch rudimentaere Anteile des ursprueng-
c* lichen Programmes von Thomas Wutzke. Hauptunterschiede und Erweiterungen sind:
c* 
c*   #	Ersetzen der Euler-Integration durch ein schrittweitenkontrolliertes
c*	Runge-Kutta Verfahren. Der dieser Implementation zugrundeliegende Algo-
c*	rythmus entstammt dabei dem Buch 'NUMERICAL RECIPES, The Art of Scientific 
c*	Computing' (Fortran Version) von Press, Flannery, Teukolsky und Vetterling, 
c*	Cambridge University Press (1989).
c* 
c*   #  Verbesserter Algorythmus zur Berechnung der Feldstaerken aus den Potential-
c*	Mappen.
c*
c*   #  Implementierung des gesamten Statistikaparates. (Zuvor waren PAW-Ntupel die
c*	einzige Ausgabeform abgesehen von den Debuginformationen).
c*
c*   #  Uebersichtlichere Gestalltung der Ein- und Ausgabe, sowie der Debug-Infos.
c*
c*   #  Implementierung der Moeglichkeit, verschiedenen Parameter in Schleifen zu
c*	durchlaufen.
c*
c*   #  Implementierung der fuer die graphische Darstellung mit PHYSICA notwendigen
c*	Routinen.
c*
c*   #  Implementierung des Triggerdetektors.
c*
c*   #  Implementierung der Graphikausgabe der Teilchenbahnen (diese Routinen wurden
c*	in ihrer ersten Fassung von Michael Birke geschrieben).
c*
c*   #  Umstellen der Potentialmappen auf 'unformattiert' und Einschraenken der
c*	Mappen auf den wirklich benoetigten Bereich (d.h. z.B. Ausnutzen der
c*	Symmetrie der Linsen, wodurch die Mappengroesse bei den Linsen mehr als
c*	halbiert werden konnte.
c*
c*   #	Implementierung der Moeglichkeit, die Kammergeometrie (d.h. die Positionen
c*	der verwendeten Elemente) sowie die Potentialmappen (z.B. fuer unter-
c*	schiedliche Linsenkonfigurationen) ueber ein .INPUT-Eingabefile ohne
c*	Umschreiben des Sourcecodes aendern zu koennen.
c*
c* Das Programm verwendet fuer Graphikdarstellung und NTupel-Erzeugung Routinen der
c* zum PAW-Komplex gehoerenden CERN-Bibliotheken 'HPLOT' und 'HBOOK'.   
c*
c* Am Anfang der Deatei 'COM_MUTRACK.INC' findet sich eine Liste der wichtigsten
c* Aenderungen ueber die verschiedenen Versionen ab 1.4.1.
c*
c* Gruss, Anselm Hofer
c******************************************************************************
c

C			    ===============
			    program MUTRACK
C			    ===============

c Deklarationen:
	
        Implicit None

	INCLUDE 'com_mutrack.inc'
	INCLUDE 'com_dirs.inc'
	INCLUDE 'com_td_ext.inc'
	INCLUDE 'com_winkel.inc'
	INCLUDE 'com_kammer.inc'
	INCLUDE 'geo_trigger.inc'


c die SCHLEIFENVARIABLEN fuer die 'do 200 ...'-Schleifenund und damit
c zusammenhaengendes (Common-Bloecke werden fuer die NTupel-Ausgabe benoetigt):

c - 'virtuelle' Flugstreckenverlaengerungen:

	real delta_L1,delta_L2

c - Energieverlust in der Triggerfolie und Dicke derselben:

	real E_loss

c - Drehwinkel: 
c (alfaTgt, alfaSp, alfaTD und ihre Winkelfunktionen werden in 'COM_WINKEL.INC'
c erledigt: COMMON /ANGELS/)

	real y_intersectSP	    ! Benoetigt fuer Schnittpkt. der Trajektorie
	real yUppLeft, yLowLeft	    !    mit forderer Spiegelebene

	real x_intersectTD	    ! Benoetigt fuer Schnittpkt. der Trajektorie
				    !     mit TD-Folie
	real x_intersectTDMap	    ! ... mit TD-Mappe
	common /x_intersectTD/  x_intersectTD,x_intersectTDMap

c - Masse und Ladung:

	real m, m_		    ! Masse,  Laufvariable fuer Massen-Schleife
	real q, q_		    ! Ladung, Laufvariable fuer Ladungs-Schleife
	integer qInt
	COMMON /charge/	qInt	    ! fuer 'NTP_charge'

	integer nNeutral,nCharged	! fuer Ausgabe des gewuerfelten neutralen anteils
	COMMON /nNeutral/ nNeutral,nCharged

c - MCP2:

	real U_MCP2		    ! Spannung am MCP2


c - Triggerdetektor: U_F, U_V, U_H und U_MCP3 werden in 'COM_TD_EXT.INC'
c   		     erledigt. (COMMON /TRIGGERSETTINGS/)

c - Transportsystem:

        real U_Tgt		    ! Target-Spannung
        real U_Gua		    ! Spannung am Guardring
	real U_G1		    ! Spannung am ersten Gitter
	real U_L1		    ! Spannung an Linse 1
	real U_Sp		    ! Spiegelspannung
	real U_L2		    ! Spannung an Linse 2
	real U_L3		    ! Spannung an Linse 3

	COMMON /U_L2/ U_L2	    ! fuer die Addition der 'L2andFo'-Mappe

	real last_U_L2	/ -1.E10 /  ! fuer die Addition der 'L2andFo'-Mappe
	real last_U_F	/ -1.E10 /

c - Magnetfeldstaerken:

	real B_Helm		    ! Magnetfeld der Helmholtzspulen
	real B_TD		    ! Magnetfeld der Kompensationsspule am TD

c - Startparameter:

	integer randomloop_	    ! Laufvariable fuer zufallsverteilte Starts
	real E0_		    ! Laufvariable fuer Startenergie_Schleife
	real theta0_		    ! Laufvarialbe fuer Startwinkel-Schleife
	real Sin_theta0, Cos_theta0 ! Startwinkel gegen x-Achse
	real phi0_		    ! Laufvariable fuer Startwinkel-Schleife
	real Sin_phi0, Cos_phi0	    ! azimuthaler Startwinkel (phi0=0: y-Achse)
	real y0_		    ! Laufvariable fuer Startpositions_Schleife
	real z0_		    ! Laufvariable fuer Startpositions_Schleife
	real r0			    ! Radius beim Wuerfeln der Startposition
	real phi_r0		    ! Winkel beim Wuerfeln der Startposition

	! x0(3),v0(3),E0,theta0,phi0 werden in 'COM_MUTRACK.INC' declariert


c allgemeine Trajektoriengroessen

	real dt		     ! zeitl. Aenderung
	real v_xy	     ! Geschwindigkeit in x/y-Ebene
	real v_square, v0_Betrag, v_Betrag
	real Ekin	     ! kinetische Energie
	real a1,a2	     ! Beschleunigung in 1. bzw. 2. Beschl.Stufe
	real aFoil	     ! Beschleunigung zwischen Massegitter und Folie
	real radiusQuad	     ! RadiusQuadrat
	real radiusQuad_     ! RadiusQuadrat
	real radius

	real S1xM2	     ! Zeit vom Start bis zur MCP2-Ebene
	real S1M2	     ! Zeit vom Start bis zum MCP2 (Treffer voarausgesetzt)
	real S1Fo            ! Zeit vom Start bis zur Folie
	real S1FoOnly        ! Zeit vom Start bis zur Folie
	real FoM2            ! Zeit zwischen Folie und MCP2
	real FoM2Only	     ! wie FoM2, falls keine anderen TOFs verlangt
	real S1M3	     ! Zeit vom Start bis Eintreffen der FE auf MCP3
	real M3M2	     ! Zeit vom Eintreffen der FE auf MCP3 bis MCP2

	real alfa	     ! Bahnwinkel gegen die Triggerfolienebene
	real E_Verlust /0./  ! Energieverlust in der Folie
	real delta_E_Verlust ! Streuung des Energieverlustes in der Folie
	real thetaAufstreu   ! Ablenkung aus vorheriger Richtung in der Folie
	real phiAufstreu     ! azimuthaler Winkel der Ablenkung gegenueber Horiz. 
	COMMON /FOLIE/ E_Verlust,thetaAufstreu,phiAufstreu

	real Beschl_Faktor   ! Faktor bei Berechn. der Beschleunigung im EFeld
	COMMON /BESCHL_FAKTOR/ Beschl_Faktor

	real length1 ! =  d_Folie_Achse + MappenLaenge_FO
	real length2 ! =  xTD - d_Folie_Achse - MappenLaenge_FO  ! = xTD-length1


c Groessen der Folienelektronen ('FE'):

	integer nFE	     ! jeweilige Anzahl an FE (2 <= nFE <= 5)
	real E0FE	     ! Startenergie der Folienelektronen
	real ct0,st0,cf0,sf0 ! die Winkelfunktionen der Startwinkel der FE
	real f0		     ! 'phi0' fuer die FE
	real x0FE(3)	     ! Startort der Folienelektronen auf der TD-Folie
	real xFE(3),vFE(3)   ! Ort und Geschw. der FE
	real tFE	     ! Zeit
	real tFE_min	     ! kuerzeste gueltige FE-Flugzeit je Projektil
	integer	tFE_(5) /-1,-1,-1,-1,-1/ ! Flugzeit jedes FE in ps (fuer NTP)
c
c----------------
c
c-TP-10/2000  add variables to have position information of muons at
c             TD and FE at MCP3 in NTuple; up to 5 electrons possible
c
	real xFE_MCP(5), yFE_MCP(5), zFE_MCP(5)
	common /TrigDet/ x0FE, xFE_MCP, yFE_MCP, zFE_MCP
c
c----------------
c
	COMMON /S1xM2/ S1xM2				! fuer NTupel
	COMMON /TIMES/ S1M2,S1Fo,FoM2,S1M3,M3M2,tFE_	! fuer NTupel
	common /FoM2Only/ FoM2Only
	COMMON /S1FoOnly/ S1FoOnly

c Variablen fuer den allgemeinen Programmablauf:

	integer qIndxMu 
	common /qIndxMu/ qIndxMu

	integer ntpid(1)    ! fuer das Einlesen des NTupels von ACCEL oder von
	integer ntpnr	    ! FoilFile

	integer  firstEventNr
	external firstEventNr

	logical NTPalreadyWritten

	real Spiegel_Faktor  ! Faktor bei Berechn. der Reflektionszeit im Spiegel

	integer bis_Spiegel		    ! verschiedene Label
	integer bis_L3_Mappe, bis_MCP2_Mappe, MCP2_Mappe

	character uhrzeit*8

	integer percent_done
	logical fill_NTP

	real radiusQuad_HeShield
	real radiusQuad_LNShield
	real radiusQuad_L1
	real radiusQuad_L2
	real radiusQuad_L3
	real radiusQuad_Blende
	real radiusQuad_Rohr
	real radiusQuad_MCP2	    ! Radiusquadrat des MCP2
	real radiusQuad_MCP2active  ! Radiusquadrat der aktiven Flaeche des MCP2
        real radiusQuad_Sp	    ! Radiusquadrat der Spiegeldraehte
	real rWires_Sp		    ! Radius der Spiegeldraehte

	logical check_Blende /.false./

	real xChangeKoord	    ! legt den Ort nach dem Spiegel fest, bei
	parameter (xChangeKoord = 75.)	! dem das Koordinatensystem gewechselt wird

	integer	n_return     ! die Returnvariable fuer Aufruf von 'TD_CALC'
	integer	zaehler	     ! Zaehler fuer Monitoring der Trajektorie in den
			     ! Gebieten, in denen stepwise integriert werden
			     ! muss
	logical flag, flag_ok
	integer okStepsCounter

	integer	i, k	     ! integer-Hilfsvariablen
	real	help1, help2 ! real-Hilfsvariablen
	real	help3, help4 ! real-Hilfsvariablen

	real	YieldPlus,YieldNeutral	! Ladungsanteile nach TD-Foliendurchgang

	integer startLabel   ! das Einsprunglabel beim Teilchenstart

	character helpChar*7, ant*1
	character HistogramTitle*32 /'Schnitt bei x =        (i. Teil)'/

d	real dtmin_L1, dtmin_Sp, dtmin_L2andFo, dtmin_FO, dtmin_L3, dtmin_M2
d	real dtmax_L1, dtmax_Sp, dtmax_L2andFo, dtmax_FO, dtmax_L3, dtmax_M2
d	real x_dtmin_L1(3), x_dtmax_L1(3), x_dtmin_FO(3), x_dtmax_FO(3)
d	real x_dtmin_L2andFo(3), x_dtmax_L2andFo(3)
d	real x_dtmin_L3(3), x_dtmax_L3(3), x_dtmin_M2(3), x_dtmax_M2(3)
d	real x_dtmin_Sp(3), x_dtmax_Sp(3)
d
d	! /ntp_steps/ enthaelt auch 'steps' (ueber COM-MUTRACK.INC)
d	COMMON /ntp_steps/ dtmin_L1, x_dtmin_L1, dtmax_L1, x_dtmax_L1,
d    +			   dtmin_Sp, x_dtmin_Sp, dtmax_Sp, x_dtmax_Sp,
d    +			   dtmin_L2andFo, x_dtmin_L2andFo, dtmax_L2andFo, x_dtmax_L2andFo,
d    +			   dtmin_FO, x_dtmin_FO, dtmax_FO, x_dtmax_FO,
d    +			   dtmin_L3, x_dtmin_L3, dtmax_L3, x_dtmax_L3,
d    +			   dtmin_M2, x_dtmin_M2, dtmax_M2, x_dtmax_M2

	real x40(2:3),v40(3),t40,E40   ! Speicher fuer Trajektoriengroessen bei x=40mm
	COMMON /NTP_40mm/ x40,v40,t40,E40

cMBc    logical writeTraj2File
cMBc	common /writeTraj2File/ writeTraj2File


c Variablen fuer Test ob Draht getroffen wurde:

	real	distToWire(2)
	integer DrahtNr
	logical WireHit

	real	WireRadiusQuad_G1,WireRadiusQuad_G2
	real	WireRadiusQuad_Sp


c Variablen fuer die Graphikausgabe:

	real	xKoord(1000),xKoord_(1000)  ! Koordinatenfelder fuer die
	real	yKoord(1000),yKoord_(1000)  !    Graphikausgabe
	real	zKoord(1000),zKoord_(1000)  !
cMBc	real	tKoord(1000),tKoord_(1000)  !
	integer nKoord,nKoordSave	    ! Anzahl der Koordinaten

cMBc	COMMON /GRAPHIX/ xKoord,yKoord,zKoord,nKoord,tKoord
	COMMON /GRAPHIX/ xKoord,yKoord,zKoord,nKoord


c Variablen fuer HBOOK und PAW:

	integer   istat			    ! fuer HBOOK-Fehlermeldungen

	integer	  HB_memsize
	parameter(HB_memsize=1000000)
	real	  memory(HB_memsize)

	common /pawc/ memory		    ! Der Arbeitsbereich fuer HBOOK


c Konstanten:

	real c		     ! Lichtgeschwindigkeit in mm/ns
	real meanLifeTime    ! mittlere Myon-Lebensdauer in ns

	parameter (c = 299.7925, meanLifeTime = 2197)

c-------------------------------------------------------------------------------
c Konstanten und Variable fuer Berechnung der Winkelaufstreuung in Triggerfolie
c mittels Meyer-Formel (L.Meyer, phys.stat.sol. (b) 44, 253 (1971)):

	real g1, g2	     ! Tabellierte Funktionen der Referenz
	real effRedThick     ! effektive reduzierte Dicke ('tau' der Referenz)


c - Parameter:

	real Z1, Z2	    ! die atomaren Nummern von Projektil und Target
	real a0		    ! Bohrscher Radius in cm
	real screeningPar   ! Screeningparameter 'a' in cm fuer Teilchen der
			    ! Kernladungszahl Z1=1 in Kohlenstoff (Z2 = 6)
			    ! bei Streichung von Z1 (vgl. Referenz, S. 268)

	real r0Meyer	    ! r0(C) berechnet aus dem screeningParameter 'a'
			    ! und dem ebenfalls bei Meyer angegebenem
			    ! Verhaeltnis a/r0=0.26 (vgl. Referenz, S. 263 oben)
	real eSquare	    ! elektrische Ladung zum Quadrat in keV*cm
	real HWHM2sigma	    ! Umrechnungsfaktor von (halber!) Halbwertsbreite
			    ! nach Sigma der Gaussfunktion

	real Na		    ! die Avogadrokonstante
	real mMolC	    ! molare Masse von C in ug
	real Pi		    ! die Kreiszahl

	parameter (Z1 = 1,  Z2 = 6,  a0 = 5.29E-9,  ScreeningPar = 2.5764E-9)
	parameter (r0Meyer = 9.909E-9,  eSquare = 1.44E-10,  HWHM2sigma = 1./1.17741)
	parameter (Na = 6.022e23,  mMolC = 12.011e6,  Pi = 3.141592654)


c - Bei der Berechnung von Sigma auftretende Vorfaktoren.
c   (Meyer_faktor 1 wird benoetigt fuer Berechnung der reduzierten Dicke aus der
c   'ug/cm2'-Angabe der Foliendicke. Meyer_faktor2 und Meyer_faktor3 werden
c   direkt fuer die Berechnung von sigma aus den beiden tabellierten Funktionen
c   g1 und g2 verwendet):

	real Meyer_Faktor1, Meyer_Faktor2, Meyer_Faktor3

	parameter (Meyer_faktor1 = Pi*screeningPar*screeningPar * Na/mMolC)
						!  Na/mMolC = 1/m(C-Atom)
	parameter (Meyer_faktor2 = (2*Z1*Z2 * eSquare)/ScreeningPar * 180./Pi
     +							      * HWHM2sigma)
	parameter (Meyer_faktor3 = (screeningPar/r0Meyer) * (screeningPar/r0Meyer))


c-------------------------------------------------------------------------------
c Kommentar zur Berechnung der Winkelaufstreuung nach Meyer:
c
c Als Bedingung fuer die Gueltigkeit der Rechnung wird verlangt, dass
c
c (1) die Anzahl n der Stoesse >> 20*(a/r0)^(4/3) sein muss. Fuer Protonen auf
c     Graphit ist laut Referenz a/r0 gleich 0.26 (mit Dichte von 3.5 g/ccm habe
c     ich einen Wert von 0.29 abgeschaetzt). Fuer Myonen hat man den selben
c     Wert zu nehmen. Damit ergibt sich die Forderung, dass n >> 3.5 sein muss.
c
c (2) unabhaengig von (1) n >> 5 sein muss, was (1) also mit einschliesst.
c
c Mit  n = Pi*r0*r0*Teilchen/Flaeche  ergibt sich fuer eine Foliendicke von
c 3 ug/cm^2 als Abschaetzung fuer n ein Wert von 37. (r0 ueber r0 = 0.5 N^(1/3)
c und 3.5 g/ccm zu 8.9e-9 cm abgeschaetzt). D.h., dass die Bedingungen in
c unserem Fall gut erfuellt sind.
c In dem Paper wird eine Formel fuer Halbwertsbreiten angegeben. Ich habe nicht
c kontrolliert, in wie weit die Form der Verteilung tatsaechlich einer Gauss-
c verteilung entspricht. Zumindest im Bereich der Vorwaertsstreuung sollte
c die in diesem Programm verwendete Gaussverteilung aber eine sehr gute
c Naeherung abgeben. Abweichungen bei groesseren Winkeln koennten jedoch u. U.
c die absolute Streuintensitaet in Vorwaertsrichtung verfaelschen.

czzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzz
c	HIER GEHT DER PROGRAMMTEXT RICHTIG LOS
czzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzz

c Initialisierungen:

	INCLUDE 'initialize.inc'


c Einlesen der Parameter aus 'MUTRACK.INPUT' und Setzen der entsprechenden
c Voreinstellungen. Einlesen der Kammergeometrie sowie der INFO-files der
c Feldmappen:

	call read_inputFile


c Berechnen der RadiusQuadrate:

	radiusQuad_HeShield   = rHeShield*rHeShield
	radiusQuad_LNShield   = rLNShield*rLNShield
	radiusQuad_Rohr	      = radius_Rohr*radius_Rohr
	radiusQuad_L1         = iRadiusCyl_L1*iRadiusCyl_L1
	radiusQuad_L2         = iRadiusCyl_L2*iRadiusCyl_L2
	radiusQuad_L3         = iRadiusCyl_L3*iRadiusCyl_L3
	radiusQuad_Blende     = radius_Blende*radius_Blende
	radiusQuad_MCP2       = radius_MCP2*radius_MCP2
	radiusQuad_MCP2active = radius_MCP2active*radius_MCP2active
	WireRadiusQuad_G1     = dWires_G1/2. * dWires_G1/2.
	WireRadiusQuad_G2     = dWires_G2/2. * dWires_G2/2.
	WireRadiusQuad_Sp     = dWires_Sp/2. * dWires_Sp/2.
	rWires_Sp = dWires_Sp/2.
        radiusQuad_Sp = rWires_Sp * rWires_Sp


c Einlesen der Feldmappen:

	write(*,*)'----------------------------------------'//
     +		  '----------------------------------------'
	if (.NOT.(par(1,UL1).EQ.0. .AND. n_par(UL1).LE.1)) call READ_MAP_L1

	if (.NOT.(idealMirror .OR. (par(1,USp).EQ.0. .AND. n_par(USp).LE.1))) then
	    call read_Map_SP_1
	    call read_Map_SP_2
	    call read_Map_SP_3
	endif

	if (TriggerInBeam .AND. .NOT.lense2 .AND.
	    ! 'lense2' muss noch in sub_input richtig gesetzt werden! (-> foilfile)
     +	   .NOT.(par(1,UFolie).EQ.0. .AND. n_par(UFolie).LE.1) ) then
	    call READ_MAP_FO
	endif

	if (.NOT.(par(1,UL3).EQ.0. .AND. n_par(UL3).LE.1)) then
	    if (.NOT.(par(1,UMCP2).EQ.0. .AND. n_par(UMCP2).LE.1)) then
		if (xLeaveMap_L3.GT.xEnterMap_M2) then
		    write(*,*)
		    write(*,*)' Potentialmappen von Linse 3 und MCP2 ueberlappen!'
		    write(*,*)' Dies ist in der aktuellen Implementierung des Programmes'
		    write(*,*)' nicht vorgesehen!'
		    write(*,*)
		    write(*,*)' -> STOP'
		    write(*,*)
		    STOP
		endif
	    endif
	    call READ_MAP_L3
	endif

	if (.NOT.(par(1,UMCP2).EQ.0. .AND. n_par(UMCP2).LE.1)) call READ_MAP_M2


c Eingelesene Simulationsparameter auf Schirm geben und bestaetigen lassen.
c Die Ausgabefiles initialisieren:

	call initialize_output


c falls ein 'FoilFile' erstellt werden soll, schreibe das .INFO-files:

	if (createFoilFile) call make_INFOFile
	if (Use_MUTRACK) Use_ACCEL = .false.


c Defaultwert fuer 'fill_NTP' setzen (wird weiter unten ueberschrieben, falls
c fuer das Fuellen des NTupels spezielle Triggerbedingung verlangt ist):

	if (createNTP) then
	    fill_NTP = .true.
	else
	    fill_NTP = .false.
	endif


c CERN-Pakete initialisieren (Groesse des COMMONblocks PAWC uebermitteln):

	if (.NOT.fromScratch.OR.Graphics.OR.createNTP.OR.createFoilFile) call HLIMIT(HB_memsize)


c Graphikausgabe initialisieren:

	if (GRAPHICS) then
	    call masstab_setzen
	    CALL HPLSET ('VSIZ',.6)		! AXIS VALUES SIZE
	    write(HistogramTitle(17:22),'(F6.1)') schnitt_x
	    write(HistogramTitle(25:25),'(I1)') schnitt_p
	    CALL HPLSET ('TSIZ',.7)		! HISTOGRAM TITLE SIZE
	    CALL HBOOK2 (50,HistogramTitle,100,-30.,30.,100,-30.,30.,20.)
	endif


c falls fruehere Simulation fortgefuehrt werden soll, oeffne entsprechende Datei:

	if (.NOT.fromScratch) then
	    if (use_ACCEL) then
		call HROPEN(lunREAD,'ACCEL',ACCEL_Dir//':'//fileName_ACCEL//'.NTP',
     +		    ' ',1024,istat)
	    else
		call HROPEN(lunREAD,'MUread',outDir//':'//fileName_MUTRACK//'.NTP',
     +		    ' ',1024,istat)
	    endif

	    call HRIN(0,99999,0)
	    call HIDALL(ntpid,ntpNr)
	    call HDELET(ntpid(1))
	    i = NTP_read - ntpid(1)
	    call HRIN(NTP_read-i,9999,i)		! NTP_read = NTP_write+1
	    call HBNAME(NTP_read,' ',0,'$CLEAR')	! alles resetten

	    ! fuer die benoetigten Bloecke des CWN die entsprechenden Speicher-
	    ! lokalisationen uebermitteln:

	    if (random_E0) call HBNAME(NTP_read,'E0',E0,'$SET')
	    if (random_pos) call HBNAME(NTP_read,'x0',x0,'$SET')
	    if (random_angle) call HBNAME(NTP_read,'angle0',theta0,'$SET')  ! theta0,phi0
	    if (UseDecay_prevSim) call HBNAME(NTP_read,'lifetime',lifetime,'$SET')

	    if (smearS1Fo .AND. use_MUTRACK) then
		call HBNAME(NTP_read,'S1FoS',S1FoOnly,'$SET')
	    endif

      	    call HBNAME(NTP_read,'dest',gebiet,'$SET')	! gebiet,destiny
 	    call HBNAME(NTP_read,'Traj',t,'$SET')	! t,x,v

	endif


c NTP-relevante Befehle:

c BAD LUCK!!! Das Packen der Real-Variablen im folgenden hat KEINERLEI VER-
c KLEINERUNG DER FILEGROESSE bewirkt!!!! (fuer die Integers habe ich noch
c keinen Test gemacht). -> wohl besser wieder herausnehmen. Ich verliere
c u.U. nur Genauigkeit und habe nur einen eingeschraenkten Wertebereich zur
c Verfuegung!

	if (createNtp.OR.createFoilFile) then

	    !c Datei fuer NTupelausgabe oeffnen:
	    call HROPEN(lunNTP,'MUwrite',outDir//':'//filename//'.NTP',
     +		'N',1024,istat)
	    if (istat.NE.0) then
		write(*,*)
		write(*,*)'error ',istat,' opening HBOOK-file'
		write(*,*)
		STOP
	    endif

	    call HBNT(NTP_write,filename,'D')	! D: Disk resident CWN buchen

	    !c die Bloecke des CWN definieren:

	    if (.NOT.OneLoop) call HBNAME(NTP_write,'LOOP',schleifenNr,'loop[1,1000]:u')
	    if (M2_triggered .OR. Fo_triggered.AND.upToTDFoilOnly) then
		! -> Gebiet und Destiny stehen hier sowieso fest, nimm
		! diese Groessen daher erst gar nicht mehr in das NTupel auf!
	    else
		call HBNAME(NTP_write,'DEST',gebiet,'Gebiet[0,20]:u,dest[-10,10]:i')
	    endif
	    if (NTP_Start .OR. createFoilFile.AND.random_pos) then
		call HBNAME(NTP_write,'X0',x0,'x0,y0,z0')
	    endif
	    if (NTP_Start) call HBNAME(NTP_write,'V0',v0,'vx0,vy0,vz0')
	    if (NTP_Start .OR. createFoilFile.AND.random_E0) then
		call HBNAME(NTP_write,'E0',E0,'E0')
	    endif
	    if (NTP_Start .OR. createFoilFile.AND.random_angle) then
	        call HBNAME(NTP_write,'ANGLE0',theta0,'theta0,phi0')
	    endif
	    if (NTP_lifetime .OR. createFoilFile.AND.UseDecay) then
		call HBNAME(NTP_write,'LIFETIME',lifetime,'lifetime:r')
	    endif
	    if (NTP_40mm) call HBNAME(NTP_write,'X=40MM',x40,
     +			      'y40,z40,vx40,vy40,vz40,t40,E40')
	    if (NTP_S1xM2) call HBNAME(NTP_write,'S1xM2',S1xM2,'S1xM2')
	    if (NTP_Times) then
		if (TriggerInBeam) then
		    if (generate_FE) then
			call HBNAME(NTP_write,'TIMES',S1M2,
     +			  'S1M2,S1Fo,FoM2,S1M3,M3M2:r,TFE(5):i')
		    else
			call HBNAME(NTP_write,'TIMES',S1M2,
     +			  'S1M2,S1Fo,FoM2')
		    endif
		else
		    call HBNAME(NTP_write,'TIMES',S1M2,
     +			  'S1M2')
		endif
	    endif
	    if (NTP_FoM2Only) then
		call HBNAME(NTP_write,'FoM2',FoM2Only,'FoM2')
	    endif
	    if (NTP_Folie) then
		call HBNAME(NTP_write,'FOLIE',E_Verlust,
     +			  'ELoss,thetStreu,phiStreu')
c
c--------------------------
c
c-TP-10/2000     add position at foil and MCP3 (FE)
c
		call HBNAME(NTP_write, 'TrigDet', x0FE,
     +         'x0FE,y0FE,z0FE,xFE(5),yFE(5),zFE(5)')
c
c--------------------------
c
	    endif
	    if (NTP_charge) call HBNAME(NTP_write,'CHARGE',qInt,'q[-5,5]:i')
	    if (NTP_stop.OR.createFoilFile) then
		call HBNAME(NTP_write,'TRAJ',t,'t,x,y,z,vx,vy,vz')
	    endif
c	    if (createFoilFile .AND. smearS1Fo .AND. .NOT.NTP_times) then
	    if (smearS1Fo) then
		call HBNAME(NTP_write,'S1FoS',S1FoOnly,'S1FoS')
	    endif
	    if (NTP_stop) then
		call HBNAME(NTP_write,'EKIN',Ekin,'Ekin')
	    endif
d	    if (NTP_steps) then
d		call HBNAME(NTP_write,'STEP',steps,'steps[1,100000]:u,'//
d    +			  'dtminL1, xdtminL1, ydtminL1, zdtminL1,'//
d    +			  'dtmaxL1, xdtmaxL1, ydtmaxL1, zdtmaxL1,'//
d    +			  'dtminL2, xdtminL2, ydtminL2, zdtminL2,'//
d    +			  'dtmaxL2, xdtmaxL2, ydtmaxL2, zdtmaxL2,'//
d    +			  'dtminFO, xdtminFO, ydtminFO, zdtminFO,'//
d    +			  'dtmaxFO, xdtmaxFO, ydtmaxFO, zdtmaxFO,'//
d    +			  'dtminL3, xdtminL3, ydtminL3, zdtminL3,'//
d    +			  'dtmaxL3, xdtmaxL3, ydtmaxL3, zdtmaxL3,'//
d    +			  'dtminM2, xdtminM2, ydtminM2, zdtminM2,'//
d    +			  'dtmaxM2, xdtmaxM2, ydtmaxM2, zdtmaxM2')
d	    endif
	endif


c die Label definieren:

	assign    7  to bis_Spiegel
	assign   14  to bis_L3_Mappe
	assign   16  to bis_MCP2_Mappe
	assign   17  to MCP2_Mappe


c die Einsprungposition fuer den Beginn der Trajektorienberechnungen setzen:

	if (Use_MUTRACK) then
	    assign 113 to startLabel
	elseif (Use_ACCEL) then
	    assign 3 to startLabel
	elseif (Gebiet0.EQ.target .OR. Gebiet0.EQ.upToGrid1) then
	    assign 1 to startLabel
	elseif (Gebiet0.EQ.upToGrid2) then
	    assign 2 to startLabel
	elseif (Gebiet0.EQ.upToHeShield) then
	    assign 3 to startLabel
	elseif (Gebiet0.EQ.upToLNShield) then
	    assign 4 to startLabel
	elseif (Gebiet0.EQ.upToL1Map) then
	    assign 5 to startLabel
	elseif (Gebiet0.EQ.upToExL1) then
	    assign 6 to startLabel
	elseif (Gebiet0.EQ.upToEnSp) then
	    assign 7 to startLabel
	elseif (Gebiet0.EQ.upToExSp) then
	    assign 8 to startLabel
	elseif (Gebiet0.EQ.upToChKoord) then
	    assign 9 to startLabel
	elseif (Gebiet0.EQ.upToEnTD) then
	    assign 10 to startLabel
	elseif (Gebiet0.EQ.upToExTD) then
	    if (log_alpha0_KS) then
		assign 111 to startLabel
	    else
		assign 112 to startLabel
	    endif
 	elseif (Gebiet0.EQ.upToL2andFoMap) then
c	    assign 12 to startLabel
	elseif (Gebiet0.EQ.upToExL2) then
c	    assign 13 to startLabel
	elseif (Gebiet0.EQ.upToL3Map) then
	    assign 12 to startLabel
	elseif (Gebiet0.EQ.upToExL3) then
	    assign 13 to startLabel
	elseif (Gebiet0.EQ.upToM2Map) then
	    assign 14 to startLabel
	elseif (Gebiet0.EQ.upToMCP2) then
	    assign 15 to startLabel
	endif


c Abkuerzungen 'Length1' und 'length2' setzen:

	length1 =  d_Folie_Achse + MappenLaenge_FO
	length2 =  xTD - d_Folie_Achse - MappenLaenge_FO


c - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 
c ab hier beginnen die Schleifen:
c (Bemerkung: eine Laufvariable darf kein Feldelement sein!)
c
c Besonderheit der Massen- und der Ladungsschleife:
c Wurde im INPUT-File in der Variablen 'artList' eine Teilchenart spezifi-
c ziert (-> 'artList_defined'), so werden die Parameter Masse und Ladung nicht
c entsprechend den Inhalten von par(n,mass) bzw. par(n,charge) eingestellt,
c sondern entsprechend den zu den Teilchenarten gehoerenden Werten fuer diese
c Groessen. In diesem Fall besteht die Massenschleife aus genau einem (Leer-)
c Durchlauf, waehrend die Ladungsschleife fuer jede Teilchenart einen Durchlauf
c macht, in welcher dann die Einstellung von Ladung UND Masse stattfindet.
c
c Bei Aenderungen in der Abfolge der Schleifen muss die Anweisungszeile
c 'DATA reihenfolge /.../' in 'INITIALIZE.INC' entsprechend editiert werden!
c - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 

c zusaetliche Flugstrecken vor TD und MCP2 (gehen NUR in t, NICHT in x ein!!):
c ----------------------------------------------------------------------------
 
        do 200 Delta_L1 = par(1,DeltaL1),par(2,DeltaL1),par(3,DeltaL1)
            parWert(DeltaL1) = Delta_L1
        do 200 Delta_L2 = par(1,DeltaL2),par(2,DeltaL2),par(3,DeltaL2)
            parWert(DeltaL2) = Delta_L2

c Foliendicke und Energieverlust:
c -------------------------------

        do 200 E_loss = par(1,Eloss),par(2,Eloss),par(3,Eloss)	   ! Eloss
            parWert(Eloss) = E_loss
	    mean_E_Verlust = E_loss

	do 200 Thickness = par(1,Thickn),par(2,Thickn),par(3,Thickn)! Thickness
	    parWert(Thickn) = Thickness

c MCP2:
c -----

        do 200 U_MCP2 = par(1,UMCP2),par(2,UMCP2),par(3,UMCP2)	   ! U(MCP2)
            parWert(UMCP2) = U_MCP2

c Winkel:
c -------

	do 200 alfaTgt = par(1,alfTgt),par(2,alfTgt),par(3,alfTgt) ! ALPHA(TARGET)
	    parWert(alfTgt) = alfaTgt
	    Sin_alfaTgt= sind(alfaTgt)
	    Cos_alfaTgt= cosd(alfaTgt)

	do 200 alfaSp  = par(1,alfSp),par(2,alfSp),par(3,alfSp)	   ! ALPHA(SPIEGEL)
	    parWert(alfSp) = alfaSp
	    Sin_alfaSp = sind(alfaSp)
	    Cos_alfaSp = cosd(alfaSp)
	    Tan_alfaSp = tand(alfaSp)
	    help1 = dSpiegel/2.+DreharmLaenge
            ! Berechne die y-Werte der 'oberen linken' (yUppLeft) und der
            ! 'unteren linken' (yLowLeft) Spiegelecke:
	        if (idealMirror) then
                    yUppLeft = + bSpiegel/2. * Sin_alfaSp
     +              	       + help1       * Cos_alfaSp
                    yLowLeft = - bSpiegel/2. * Sin_alfaSp
     +              	       + help1       * Cos_alfaSp
		endif
            ! Berechne Schnittpunkt y_intersectSp der vorderen Spiegelebene bzw. 
            ! der vorderen Mappenkante mit der Geraden x = xSpiegel:
		if (.NOT.idealMirror) help1 = help1 + xSpGrid1
	    	y_intersectSp = help1/Cos_alfaSp

	do 200 alfaTD  = par(1,alfTD),par(2,alfTD),par(3,alfTD)	   ! ALPHA(TRIGGERDETEKTOR)
	    parWert(alfTD) = alfaTD
	    Sin_alfaTD = sind(alfaTD)
	    Cos_alfaTD = cosd(alfaTD)
	    Tan_alfaTD = tand(alfaTD)
	    ! Berechne Schnittpunkt 'x_intersectTD' der x-Achse mit der Folien-
	    ! ebene bzw im Fall von 'GridInFrontOfFoil' mit dem Gitter vor der
	    ! Triggerfolie:
	    help1 = d_Folie_Achse
	    if (gridInFrontOfFoil) help1 = help1 + d_Grid_Folie
	    x_intersectTD = xTD - help1/Cos_alfaTD
	    help1 = d_Folie_Achse + mappenLaenge_Fo
	    x_intersectTDMap = xTD - help1/Cos_alfaTD

c TriggerDetektor:
c ----------------

        do 200 U_V = par(1,UVorne),par(2,UVorne),par(3,UVorne)     ! U(VORNE)
            parWert(UVorne) = U_V
        do 200 U_H = par(1,UHinten),par(2,UHinten),par(3,UHinten)  ! U(HINTEN)
            parWert(UHinten) = U_H
        do 200 U_MCP3 = par(1,UMCP3),par(2,UMCP3),par(3,UMCP3)	   ! U(MCP3)
            parWert(UMCP3) = U_MCP3
        do 200 U_F = par(1,UFolie),par(2,UFolie),par(3,UFolie)     ! U(FOLIE)
            parWert(UFolie) = U_F

c Transportsystem:       
c ----------------

        do 200 U_L2 = par(1,UL2),par(2,UL2),par(3,UL2)		   ! U(Linse 2)
            parWert(UL2) = U_L2

c gegebenenfalls die Mappe 'L2andFo' zusammenbauen:
	if (lense2) then
 	    if ( .NOT.(par(1,UL2).EQ.0. .AND. n_par(UL2).LE.1) .OR.
     + 	         .NOT.(par(1,UFolie).EQ.0. .AND. n_par(UFolie).LE.1) ) then
		! Addiere die Mappen nur erneut, falls die jetztige Konfiguration
		! nicht mit der letzten uebereinstimmt:
		if (U_L2.NE.last_U_L2 .OR. U_F.NE.last_U_F) then
		    call ADD_MAP_L2andFo
		    last_U_L2 = U_L2
		    last_U_F  = U_F
		endif
	    endif
	endif

        do 200 U_Sp = par(1,USp),par(2,USp),par(3,USp)		   ! U(SPIEGEL)
            parWert(USp) = U_Sp

	do 200 U_L1 = par(1,UL1),par(2,UL1),par(3,UL1)		   ! U(Linse 1)
            parWert(UL1) = U_L1

	do 200 U_L3 = par(1,UL3),par(2,UL3),par(3,UL3)		   ! U(Linse 3)
            parWert(UL3) = U_L3

c die Magnetfelder:
c -----------------

        do 200 B_Helm = par(1,BHelm),par(2,BHelm),par(3,BHelm)	   ! Helmholtzsp.
            parWert(BHelm) = B_Helm

        do 200 B_TD = par(1,BTD),par(2,BTD),par(3,BTD)		   ! TD-Spule
            parWert(BTD) = B_TD

c Masse und Ladung:
c -----------------

	do 200 m_ = par(1,mass),par(2,mass),par(3,mass)		   ! MASSE
	    if (.NOT.artList_defined) then
		m = m_
		parWert(mass) = m
	    endif

	do 200 q_ = par(1,charge),par(2,charge),par(3,charge)	   ! LADUNG
	    if (.NOT.artList_defined) then
		q = q_
		parWert(charge) = q
	    else
		qIndxMu = q_	! fuer Verwendung in function firstEventNr!
		ArtNr = Art_Nr(q_)
		m = Art_Masse(ArtNr)
		q = Art_Ladung(ArtNr)
		parWert(mass)   = m
		parWert(charge) = q
	    endif
	    ! gegebenenfalls ein Flag fuer die Beruecksichtigung des Myonen-
	    ! zerfalles setzen:
	    if (useDecay) then	    ! 'useDecay' setzt 'artList_defined' voraus
		if (ArtNr.LE.4) then! es ist ein Myon involviert
		    useDecay_ = .true.
		else		    ! kein Myon involviert
		    useDecay_ = .false.
		endif
	    endif


c Beschleuniger:
c --------------

        do 200 U_Tgt = par(1,UTgt),par(2,UTgt),par(3,UTgt)	   ! U(TARGET)
            parWert(UTgt) = U_Tgt
        do 200 U_Gua = par(1,UGua),par(2,UGua),par(3,UGua)	   ! U(GUARD)
            parWert(UGua) = U_Gua
        do 200 U_G1 = par(1,UG1),par(2,UG1),par(3,UG1)		   ! U(GITTER)
            parWert(UG1) = U_G1
	    parIndx(5) = parIndx(5) + 1


c - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
c haeufig benoetigte Faktoren, die von der aktuellen Masse, Ladung und Hoch-
c spannungen abhaengen:
c (bei Linse 2 wird die Spannung direkt auf die Potentialmappe aufmultipliziert.
c Daher wird dort 'Beschl_Faktor' verwendet und kein 'Beschl_Faktor_L2' benoetigt)

	Energie_Faktor  = m / (2.*c*c)
	Beschl_Faktor   = q / m * c*c
	Beschl_Faktor_L1 = Beschl_Faktor * U_L1
	Beschl_Faktor_Sp = Beschl_Faktor * U_Sp
	Beschl_Faktor_FO = Beschl_Faktor * U_F
	Beschl_Faktor_L3 = Beschl_Faktor * U_L3
	Beschl_Faktor_M2 = Beschl_Faktor * U_MCP2

	aFoil = - Beschl_Faktor * U_F / d_Grid_Folie
	if (U_Sp.EQ.0. .OR. q.EQ.0.) then
	    Spiegel_Faktor = 0
	else
	    Spiegel_Faktor = 2.*dspiegel / (Beschl_Faktor * U_Sp) !<-- pruefen!
	endif

	! Die Beschleunigungen in den beiden (idealen) Beschleunigerstufen:
	a1 = Beschl_Faktor * (U_Tgt - U_G1) / (XGrid1 - XTarget)
	a2 = Beschl_Faktor *  U_G1          / (XGrid2 - xGrid1)

c - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
c Falls 'fromScratch':
c   Die in den ab hier beginnenden Startparameter-Schleifen gesetzten Werte
c   werden gegebenenfalls weiter unten durch zufallsverteilte Offsets modi-
c   fiziert. (-> 'Zufallschleife': 'do 100 randomloop_ = 1, n_par(0))
c Andernfalls:
c   Wurden waehrend ACCEL oder 'foilfile' fuer die Startparameter Zufalls-
c   verteilungen verwendet, so werden die entsprechenden Groessen aus dem
c   betreffenden NTupel eingelesen.
c - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

c Startparameter:
c ---------------

	do 200 E0_ = par(1,ener),par(2,ener),par(3,ener)	      ! E0
	    if (.NOT.random_E0) then
		E0 = E0_
		v0_Betrag = sqrt(E0/Energie_Faktor)
	    endif

	    if (E0InterFromFile) then
		lowerE0 = E0Low(nInt(E0_))
		upperE0 = E0Low(nint(E0_+1))
	    endif


c falls Energieverlustberechnung aus ICRU-Tabelle verlangt ist und mittlerer
c Energieverlust nicht fuer jedes Teilchen extra berechnet werden soll (sinnvoll
c wenn alle Teilchen gleiche Startenergie haben oder Streuung der Startenergien
c klein ist, so dass die Streuung des mittleren Energieverlustes vernachlaessigt
c werden kann):

	if (log_E_Verlust_ICRU .AND. .NOT.calculate_each) then
	    if (random_E0_equal) then
		Ekin = E0_ + (upperE0+lowerE0)/2.
	    else
		Ekin = E0_
	    endif
	    if (Gebiet0.EQ.target .OR. Gebiet0.EQ.upToGrid1) then
		Ekin = Ekin + q*(U_Tgt - U_F)
	    elseif (Gebiet0.EQ.upToGrid2) then
		Ekin = Ekin + q*(U_G1 - U_F)
	    endif
	    call CALC_ELOSS_ICRU(Ekin,q,m,Thickness,mean_E_Verlust)
	endif

	if (log_Meyer_F_Function) then
	    if (random_E0_equal) then
		Ekin = E0_ + (upperE0+lowerE0)/2.
	    else
		Ekin = E0_
	    endif
	    if (Gebiet0.EQ.target .OR. Gebiet0.EQ.upToGrid1) then
		Ekin = Ekin + q*(U_Tgt - U_F)
	    elseif (Gebiet0.EQ.upToGrid2) then
		Ekin = Ekin + q*(U_G1 - U_F)
	    endif
	    effRedThick = Meyer_Faktor1 * Thickness
	    call Get_F_Function_Meyer(effRedThick,Ekin)
	endif

	do 200 theta0_ = par(1,thetAng),par(2,thetAng),par(3,thetAng) ! theta0
	    if (.NOT.random_angle) then
		theta0 = theta0_
		Cos_theta0 = cosd(theta0)
		Sin_theta0 = sind(theta0)
	    endif
	do 200 phi0_  = par(1,phiAng),par(2,phiAng),par(3,phiAng)  ! phi0
	    if (.NOT.random_angle) then
		phi0 = phi0_
		Cos_phi0 = cosd(phi0)
		Sin_phi0 = sind(phi0)
	    endif

	do 200 y0_ = par(1,yPos),par(2,yPos),par(3,yPos)	      ! y0
	    if (.NOT.random_pos) then
		x0(2) = y0_
	    endif

	do 200 z0_ = par(1,zPos),par(2,zPos),par(3,zPos)	      ! z0
	    if (.NOT.random_pos) then
		x0(3) = z0_
	    endif

c die folgenden parWert(n) werden u.U. in der 'Zufallsschleife' weiter unten 
c abgeaendert. Hier werden sie in jedem Fall fuer Tabellenausgaben, Debug-
c angelegenheiten u.s.w. erst einmal mit den aktuellen Werten der
c entsprechenden Schleifen gefuellt:

	parWert(ener)    = E0_
	parWert(thetAng) = theta0_
	parWert(phiAng)  = phi0_
	parWert(yPos)    = y0_
	parWert(zPos)    = z0_


c falls fruehere Simulation fortgefuehrt wird:
c Berechne diejenige Eventnummer in NTP_read, ab welcher die relevanten
c Simulationsparameter von ACCEL bzw. des 'FoilFiles' mit den gegenwaertigen
c MUTRACK-(Schleifen)-Parametern uebereinstimmen:

	if (.NOT.fromScratch) eventNr = firstEventNr()


c - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
c Hier folgen die Befehle, die zu Beginn jeder neuen Schleife faellig sind:
c - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

	SchleifenNr = SchleifenNr + 1	! Schleifen zaehlen
	okStepsCounter = 0		! 'okStepsCounter' dient der Bestimmung
					! der mittleren Anzahl von Integrations-    
					! schritten bis zum Ziel
	nNeutral = 0			! noch wurden keine Teilchen in der TD-Folie
	nCharged = 0			! neutralisiert

c Die Statistikspeicher resetten:
c Falls nur ein Teilchenstart pro Schleife erfolgt, nimm die Statistik ueber
c alle Schleifen. (Dann erfolgt der Reset nur bei der ersten Schleife):

	flag_ok = (.NOT.(OneStartPerLoop .AND. SchleifenNr.GT.1))

	if (flag_ok) call reset_statistics


c Die Kammer zeichnen:
c Wird pro Schleife nur ein Teilchen gestartet ('OneStartPerLoop'; d.h. kein
c oder genau ein 'Zufallsstart'), so trage alle Trajektorien in die gleiche
c Graphik ein. Zeichne die Kammer dann also nur bei der ersten Schleife.
  
	if (GRAPHICS .AND. flag_ok) then
 	    CALL IZPICT ('CHAM_1','M')	    ! ERZEUGEN VON BILDERN IM PAWC-COMM-BLOCK
	    CALL IZPICT ('CHAM_2','M')
	    CALL IZPICT ('HISTO','M')
	    CALL IZPICT ('TEXT','M')	
	    call plot_chamber(schnitt_p)
	    call Graphics_Text		    ! Text fuer Textwindow erstellen
	    call text_plot		    ! Ausgabe des Textes
	endif


c Ausgabe der aktuellen Settings:
c Auch dies im Falle von 'OneStartPerLoop' nur bei der ersten Schleife:

	if ((n_outWhere.NE.0 .OR. smallLogFile) .AND. flag_ok) then
	    call output_new_loop(q_)	    ! (q_) wegen der neutral fractions
	endif


c Ausgabe der Prozentzahl schon gerechneten Trajektorien vorbereiten:

	if (log_percent) then
	    call time(uhrzeit)
	    percent_done = 0
	    write(*,1001)Uhrzeit,' %:  0'
	endif
1001	format ($,6x,A,A)


c - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
c bei 'fromScratch':
c   Hier wird gegebenenfalls bei Zufallsverteilung von Startparametern ein ent-
c   sprechend gewuerfelter Offset auf den aktuellen Wert aufgeschlagen.
c Ansonsten:
c   Lies bei Zufallsverteilungen die entsprechenden Startwerte aus dem NTupel
c   ein.
c - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

	do 100 randomloop_ = 1, n_par(0)

	if (.NOT.fromScratch) then

	    eventNr = eventNr + 1	    ! Eventnummer im NTP

	    if (smearS1Fo.AND.use_MUTRACK) call HGNTB(NTP_read,'S1FoS',eventNr,istat)
	    if (istat.NE.0) then
		write(*,*)
		write(*,*)' error executing ''call HGNTB(',NTP_read,',''S1FoS'',eventNr,istat)'''
		write(*,*)' eventNr = ',eventNr
		write(*,*)' -> STOP'
		write(*,*)
		call exit
	    endif

	    ! Einlesen von 'Gebiet' und 'destiny':
	    call HGNTB(NTP_read,'dest',eventNr,istat)
	    ! gegebenenfallsvon freuher verwendete Gebietskodierung
	    ! (ohne Linse2) aktualisieren
	    if (gebiet.GE.10 .AND. MutrackVersionIndx.LE.1) gebiet = gebiet+2

c	    if (istat.NE.0) then
c		write(*,*)
c		write(*,*)' error executing ''call HGNTB(',NTP_read,',''dest'',eventNr,istat)'''
c		write(*,*)' eventNr = ',eventNr
c		write(*,*)' -> STOP'
c		write(*,*)
c		call exit
c	    endif
	    ! Einlesen der Trajektoriendaten 't,x(3),v(3)':
	    call HGNTB(NTP_read,'Traj',eventNr,istat)
c	    if (istat.NE.0) then
c		write(*,*)
c		write(*,*)' error executing ''call HGNTB(',NTP_read,',''Traj'',eventNr,istat)'''
c		write(*,*)' eventNr = ',eventNr
c		write(*,*)' -> STOP'
c		write(*,*)
c		call exit
c	    endif

	    if (Use_Accel) then
		! Uebersetzen der von ACCEL verwendeten code_Nummern fuer die
		! moeglichen Teilchenschicksale in von MUTRACK verwendete
		! code_Nummern:
		if (destiny.EQ.-5) then
		    destiny = code_frontOfMapAc
		elseif (destiny.EQ.-4) then
		    destiny = code_leftMapAc
		elseif (destiny.EQ.-3) then
		    gebiet  = upToGrid2
		    destiny = code_grid
		elseif (destiny.EQ.-2) then
		    gebiet  = upToGrid1
		    destiny = code_grid
		elseif (destiny.EQ.-1) then
		    destiny = code_hit_TgtHolder
		elseif (destiny.EQ.code_ok) then
		    Gebiet = upToHeShield
		elseif (destiny.EQ.+1) then
		    destiny = code_decay
		elseif (destiny.EQ.+2) then
		    destiny = code_reflektiert
		elseif (destiny.EQ.+3) then
		    destiny = code_wand
		elseif (destiny.EQ.+4) then
		    destiny = code_lost
		elseif (destiny.EQ.+5) then
		    destiny = code_dtsmall
		else
		    write(*,*)'UNKNOWN ACCEL-CODE-NR:  destiny = ',destiny
		    call exit
		endif

		! Auf xGrid2 zurueckrechnen, damit unabhaengiger Test auf
		! Treffer des He-Fensters gemacht werden kann (nur, falls
		! Teilchen nicht schon anderweitig gestorben ist). Auch
		! notwendig fuer Graphikausgabe.

		if (destiny.EQ.0) then
		    dt = (xGrid2-x(1))/v(1)	    ! < 0.
		    t = t + dt
		    x(1) = xGrid2
		    x(2) = x(2)+v(2)*dt
		    x(3) = x(3)+v(3)*dt
		endif

		! falls Kryo verdreht ist, rechne in Kammerkoordinaten um:

		if (alfaTgt.NE.0.) then
		    if (alfaTgtVertically) then
			help1 = x(1)
			x(1) = help1 * Cos_alfaTgt  -  x(3) * Sin_alfaTgt
			x(3) = help1 * Sin_alfaTgt  +  x(3) * Cos_alfaTgt
			help1 = v(1)
			v(1) = help1 * Cos_alfaTgt  -  v(3) * Sin_alfaTgt
			v(3) = help1 * Sin_alfaTgt  +  v(3) * Cos_alfaTgt
		    else
			help1 = x(1)
			x(1) = help1 * Cos_alfaTgt  -  x(2) * Sin_alfaTgt
			x(2) = help1 * Sin_alfaTgt  +  x(2) * Cos_alfaTgt
			help1 = v(1)
			v(1) = help1 * Cos_alfaTgt  -  v(2) * Sin_alfaTgt
			v(2) = help1 * Sin_alfaTgt  +  v(2) * Cos_alfaTgt
		    endif
		endif

	    endif

	endif

	if (random_E0) then				! random_ENERGIE
	    if (fromScratch) then
		if (random_E0_equal) then		! -> gleichverteilt
300		    E0 = E0_ + lowerE0 + (upperE0 - lowerE0)*ran(seed)
		    if (E0.LT.0) goto 300
		elseif (random_E0_gauss) then		! -> gaussverteilt
310		    call Gauss_Verteilung(sigmaE0,help1)
		    E0 = E0_ + help1
		    if (E0.LT.0) goto 310
		endif
	    else
		! Einlesen von 'E0' aus NTP:
		call HGNTB(NTP_read,'E0',eventNr,istat)
c		if (istat.NE.0) then
c		    write(*,*)
c		    write(*,*)' error executing ''call HGNTB(NTP_read,''E0'',eventNr,istat)'''
c		    write(*,*)' eventNr = ',eventNr
c		    write(*,*)' -> STOP'
c		    write(*,*)
c		    call exit
c		endif
	    endif
	    parWert(ener) = E0
	    v0_Betrag = sqrt(E0/Energie_Faktor)
	endif

	if (random_pos) then			! random_POSITION
	    if (fromScratch) then
		if (random_y0z0_equal) then		! -> rechteckig, gleichverteilt
		    x0(2) = StartBreite * (ran(seed)-.5)
		    x0(3) = StartHoehe  * (ran(seed)-.5)
		elseif (random_y0z0_Gauss) then	! -> rechteckig, Gaussverteilt 
320		    r0    = abs(sigmaPosition*sqrt(-2.*log(1.-ran(seed))))
		    phi_r0= 360.*ran(seed)
		    x0(2) = r0 * cosd(phi_r0)
		    if (abs(x0(2)).GT.StartBreite/2.) goto 320
		    x0(3) = r0 * sind(phi_r0)
		    if (abs(x0(3)).GT.StartHoehe/2.) goto 320
		elseif (random_r0_equal) then	! -> rund, gleichverteilt
		    r0    = StartRadius * sqrt(ran(seed))
		    phi_r0= 360. * ran(seed)
		    x0(2) = r0 * cosd(phi_r0)
		    x0(3) = r0 * sind(phi_r0)
		elseif (random_r0_Gauss) then	! -> rund, Gaussverteilt
330		    r0    = abs(sigmaPosition*sqrt(-2.*log(1.-ran(seed))))
		    if (r0.GT.StartRadius) goto 330
		    phi_r0= 360.*ran(seed)
		    x0(2) = r0 * cosd(phi_r0)
		    x0(3) = r0 * sind(phi_r0)
		endif
		x0(2) = y0_ + x0(2)
		x0(3) = z0_ + x0(3)
	    else
		! Einlesen von 'x0(3)' aus NTP:
		call HGNTB(NTP_read,'x0',eventNr,istat)
c		if (istat.NE.0) then
c		    write(*,*)
c		    write(*,*)' error executing ''call HGNTB(',NTP_read,',''x0'',eventNr,istat)'''
c		    write(*,*)' eventNr = ',eventNr
c		    write(*,*)' -> STOP'
c		    write(*,*)
c		    call exit
c		endif
	    endif
	    parWert(yPos) = x0(2)
	    parWert(zPos) = x0(3)
	endif

	if (random_angle) then			! random_WINKEL
	    if (fromScratch) then
340		if (random_lambert) then		! -> Lambert-verteilt
		    call lambert_verteilung(StartLambertOrd,  
     +					     Cos_theta0,Sin_theta0)
		    theta0   = acosd(Cos_theta0)
		elseif (random_gauss) then
      		    call Gauss_Verteilung_theta(sigmaWinkel,theta0)
		    Cos_theta0 = cosd(theta0)
		    Sin_theta0 = sind(theta0)
		endif

		phi0     = 360.*ran(seed)
		Cos_phi0 = cosd(phi0)
		Sin_phi0 = sind(phi0)

		if (angle_offset) then

c -> Es soll aus gewuerfelter Startrichtung (theta0,phi0) und durch die Winkel-
c schleifen vorgegebenen Startrichtung (theta0_,phi0_) die tatsaechliche
c Startrichtung berechnet werden. Dafuer werden die gewuerfelten Winkel als
c 'Streuwinkel' betrachtet.
c Vorgehensweise:
c Es werden die Komponenten eines Geschwindigkeitsvektors mit Betrag=1 und durch
c theta0_,phi0_ bestimmter Richtung berechnet. Danach werden die Komponenten des
c mit theta0,phi0 gestreuten Geschwindigkeitsvektors und die zugehoerigen Winkel
c gewonnen, die dann als neuetheta0,phi0 als die tatsaechlichen Startwinkel
c verwendet werden. Das alles geschieht vollkommen analog zur Winkelaufstreuung
c in der Triggerfolie.
c v wird als Hilfsvariable missbraucht.

		! Berechnung der 'Geschwindigkeitskomponenten':
		    v(1)  = cosd(theta0_)
		    help1 = sind(theta0_)
		    v(2)  = help1 * cosd(phi0_)
		    v(3)  = help1 * sind(phi0_)
		! v_xy ist stets groesser 0 ausser wenn die Zentralrichtung
		! senkrecht nach oben oder unten gerichtet ist. Diese Wahl ist
		! aber sowieso wenig sinnvoll:
		    v_xy = SQRT(v(1)*v(1) + v(2)*v(2))
		    if (v_xy.EQ.0.) then
			write(*,*)
			write(*,*)' Bei Zufallsverteilung fuer Startwinkel darf die durch die Winkelschleifen'
			write(*,*)' vorgegebene Zentralrichtung nicht senkrecht nach oben oder nach unten weisen!'
			write(*,*)' -> STOP'
			STOP
		    endif
		! berechne neue 'Geschwindigkeitskomponenten':
		    help1 = v(1)
		    help2 = v(2)
		    help3 = Sin_theta0*Cos_phi0/v_xy
		    help4 = Sin_theta0*Sin_phi0
		    v(1) = Cos_theta0*help1 - help3*help2 - help4*help1*v(3)/v_xy
		    if (v(1).LT.0.) goto 340
		    v(2) = Cos_theta0*help2 + help3*help1 - help4*help2*v(3)/v_xy
		    v(3) = Cos_theta0*v(3)                + help4*v_xy
		! Berechne tatsaechlichen Startwinkel:
      		    if (v(2).EQ.0. .AND. v(3).EQ.0.) then
			if (v(1).GE.0) then
      			    theta0 = 0.
			else
      			    theta0 = 180.
			endif
      			phi0 = 0.
      		    else
      			theta0 = acosd(v(1))
      			phi0 = atan2d(v(3),v(2))
      			if (phi0.LT.0) phi0 = phi0+360.
      		    endif
		    Cos_theta0 = cosd(theta0)
		    Sin_theta0 = sind(theta0)
		    Cos_phi0 = cosd(phi0)
		    Sin_phi0 = sind(phi0)
		endif

		if (theta0.GT.90.) goto 340

	    else

		! Einlesen von 'theta0' und 'phi0' aus NTP:
		call HGNTB(NTP_read,'angle0',eventNr,istat)
c		if (istat.NE.0) then
c		    write(*,*)
c		    write(*,*)' error executing ''call HGNTB(',NTP_read,',''angle0'',eventNr,istat)'''
c		    write(*,*)' eventNr = ',eventNr
c		    write(*,*)' -> STOP'
c		    write(*,*)
c		    call exit
c		endif

	    endif

	    parWert(thetAng) = theta0
	    parWert(phiAng) = phi0

	endif

	! Berechnung der Start-Geschwindigkeitskomponenten:
	v0(1) = v0_Betrag * Cos_theta0
	v0(2) = v0_Betrag * Sin_theta0 * Cos_phi0
	v0(3) = v0_Betrag * Sin_theta0 * Sin_phi0

	if (fromScratch) then
	    ! den Zeit-Speicher resetten:
	    t = 0.
	    ! Startparameter in Koordinatenspeicher uebergeben:
	    do i = 1, 3
		x(i) = x0(i)
		v(i) = v0(i)
	    enddo
	endif


c - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 
c Hier folgen die restl. Vorbereitungen zum Start des individuellen Projektils:
c - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 

c n_dtsmall resetten:

	n_dtsmall = 0


c Aufstreuwinkel resetten:

	thetaAufstreu = 0.
	phiAufstreu = 0.


c x-Komponente der Startgeschwindigkeit ueberpruefen:

	if (v0(1).LT.0) then
	    write(*,*)
	    write(*,*) '    >>>> v(x) beim Start negativ!'
	    write(*,*)
	    call exit
	endif


c die Lebensdauer wuerfeln:
c (wird eine fruehere Simulation fortgefuehrt und wurde dort bereits der Myonen-
c zerfall beruecksichtigt, so verwende die dort gewuerfelten Lebenszeiten)

	if (UseDecay_) then
	    if (.NOT.UseDecay_prevSim) then 
350 		lifeTime = -meanlifeTime * Log(Ran(seed) + 1.0E-37)
		if (lifeTime.LE.0.) goto 350 
	    elseif (.NOT.fromScratch) then
		call HGNTB(NTP_read,'lifetime',eventNr,istat)
c		if (istat.NE.0) then
c		    write(*,*)
c		    write(*,*)' error executing ''call HGNTB(',NTP_read,',''lifetime'',eventNr,istat)'''
c		    write(*,*)' eventNr = ', eventNr
c		    write(*,*)' -> STOP'
c		    write(*,*)
c		    call exit
c		endif
	    endif
	endif


c die Ladung resetten (falls in der Folie Neutralisierung stattgefunden hat):
c ('qInt' wird fuer 'NTP_charge' benoetigt)

	q = parWert(charge)
	qInt = int(q)


c Ausgabe der Prozentzahl schon gerechneter Trajektorien:

	if (log_percent) then
	    if (100.*real(start_nr(1))/real(n_par(0))
     +					  .GE.percent_done+5) then
		percent_done = percent_done + 5
		write(*,1002) percent_done
	    endif
	endif
1002	format ($,'+',I3)


c andere Variablen auf den richtigen Stand bringen:

	if (fromScratch) then
	    destiny = code_ok  ! bis jetzt ist dem Teilchen noch nichts zugestossen
	    Gebiet = Gebiet0
	endif

	start_nr(1) = start_nr(1) + 1	    ! Projektil-Startnummer erhoehen
	steps   = 0        ! es wurden noch keine Integrationsschritte durchgefuehrt
	NTPalreadyWritten = .false.	    ! fuer 'createFoilFile'


c die DEBUG-Daten ausgeben:

	if (Debug .AND. start_Nr(1).LE.DEBUG_Anzahl) then
	    Debug_ = .true.
	    call output_new_particle
	    call Output_Debug
	else
	    Debug_ = .false.
	endif


c StartKoordinaten fuer Graphikausgabe sichern:

	if (graphics .AND. (start_Nr(1).LE.graphics_Anzahl .OR. OneStartPerLoop)) then
	    graphics_ = .true.
	    if (Use_ACCEL) then
		nKoord = 1
		xKoord(1) = x0(1)
		yKoord(1) = x0(2)
		zKoord(1) = x0(3)
	    else
		nKoord  = 0
	    endif
	    if (.NOT.(Use_MUTRACK.OR.Gebiet0.EQ.upToExTD)) call Save_Graphics_Koord
	else
	    graphics_ = .false.
	endif


c gegebenenfalls 'fill_NTP' resetten:

	if (Fo_triggered.OR.M2_triggered.OR.xM2_triggered) fill_NTP = .false.


c Falls Schrittweiteninformationen im NTupel verlangt sind: Speicher resetten
c und Startkoordinaten sichern:

d	if (NTP_steps) then
d	    dtmin_L1 = +1.e10
d	    x_dtmin_L1(1) = 0
d	    x_dtmin_L1(2) = 0
d	    x_dtmin_L1(3) = 0
d	    dtmax_L1 = -1.e10
d	    x_dtmax_L1(1) = 0
d	    x_dtmax_L1(2) = 0
d	    x_dtmax_L1(3) = 0
d
d	    dtmin_L2andFo = +1.e10
d	    x_dtmin_L2andFo(1) = 0
d	    x_dtmin_L2andFo(2) = 0
d	    x_dtmin_L2andFo(3) = 0
d	    dtmax_L2andFo = -1.e10
d	    x_dtmax_L2andFo(1) = 0
d	    x_dtmax_L2andFo(2) = 0
d	    x_dtmax_L2andFo(3) = 0
d
d	    dtmin_FO = +1.e10
d	    x_dtmin_FO(1) = 0
d	    x_dtmin_FO(2) = 0
d	    x_dtmin_FO(3) = 0
d	    dtmax_FO = -1.e10
d	    x_dtmax_FO(1) = 0
d	    x_dtmax_FO(2) = 0
d	    x_dtmax_FO(3) = 0
d
d	    dtmin_L3 = +1.e10
d	    x_dtmin_L3(1) = 0
d	    x_dtmin_L3(2) = 0
d	    x_dtmin_L3(3) = 0
d	    dtmax_L3 = -1.e10
d	    x_dtmax_L3(1) = 0
d	    x_dtmax_L3(2) = 0
d	    x_dtmax_L3(3) = 0
d
d	    dtmin_M2 = +1.e10
d	    x_dtmin_M2(1) = 0
d	    x_dtmin_M2(2) = 0
d	    x_dtmin_M2(3) = 0
d	    dtmax_M2 = -1.e10
d	    x_dtmax_M2(1) = 0
d	    x_dtmax_M2(2) = 0
d	    x_dtmax_M2(3) = 0
d	endif

	if (NTP_40mm) then
	    x40(2) = 0.
	    x40(3) = 0.
	    v40(1) = 0.
	    v40(2) = 0.
	    v40(3) = 0.
	    t40 = 0.
	    E40 = 0.
	endif


c Die Flugzeiten resetten:

	S1xM2 = 0.
	S1M2 = 0.
	S1Fo = 0.
	FoM2 = 0.
	S1M3 = 0.
	M3M2 = 0.


c Falls das Teilchen schon nicht mehr existiert, gehe gleich zur Ausgabe:

	if (destiny.NE.code_ok) goto 555    ! (nur bei '.NOT.fromScratch' moeglich)


czzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzz
c hier starten die Projektile:
czzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzz

	goto startLabel			    ! StartLabel = Gebiet0 als label

c:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
c erste Beschleunigerstufe:           (homogenes Feld)

1       Gebiet = upToGrid1
	steps = Steps + 1

	if (a1.NE.0.) then
	    help1 = v(1)*v(1) + 2.*a1*(xGrid1-x(1))
	    if (help1.LT.0) then	! Reflektion noch vor 1. Gitter
		dt = -2*v(1)/a1
      		t = t + dt
      	       !x(1) bleibt unveraendert
		x(2) = x(2) + v(2)*dt
		x(3) = x(3) + v(3)*dt
		v(1) = -v(1)
      	       !v(2) bleibt unveraendert
      	       !v(3) bleibt unveraendert
		destiny = code_reflektiert
		goto 555
	    endif
	    dt = (sqrt(help1) - v(1))/a1
	    ! (ergibt sich aus x=v*t+1/2*a*t**2 mit richtiger V.Z.-Wahl ('+'))
	    v(1) = v(1) + a1*dt
	else
	    if (v(1).EQ.0) then
		write(*,*)
		write(*,*)'ERROR:  v(x) beim Start = 0. und '//
     +			'Beschleunigung = 0'
		write(*,*)
		STOP
	    endif
	    dt = (xGrid1-xTarget) / v(1)
	endif

        t = t + dt
       !v(2) bleibt unveraendert
       !v(3) bleibt unveraendert
	x(1) = xGrid1
	x(2) = x(2) + v(2)*dt
	x(3) = x(3) + v(3)*dt

c - Aufgeschlagen?

	if (Abs(x(2)).gt.dygrid1/2. .OR.
     +			       Abs(x(3)).gt.dzgrid1/2.) then
	    flag = .true.
	    destiny = code_wand
	else
	    flag = .false.
	endif

c - Gitterstab getroffen?

	if (testOnWireHit) then
	    DrahtNr = nInt(x(2)/dist_Wires_G1)
	    distToWire(1) = 0.
	    distToWire(2) = x(2) - DrahtNr * dist_Wires_G1
	    call Test_WireHit(distToWire,WireRadiusQuad_G1,v(1),v(2),WireHit)
	    if (WireHit) then
		flag = .true.
		destiny = code_grid
	    endif
	endif

c - Koordinatentransformation in Kammersystem:

	if (alfaTgt.NE.0.) then
	    if (alfaTgtVertically) then
		help1 = x(3)
		help2 = v(1)
		help3 = v(3)
		x(1) = xgrid1 * Cos_alfaTgt  -  help1 * Sin_alfaTgt
		x(3) = xgrid1 * Sin_alfaTgt  +  help1 * Cos_alfaTgt
		v(1) =  help2 * Cos_alfaTgt  -  help3 * Sin_alfaTgt
		v(3) =  help2 * Sin_alfaTgt  +  help3 * Cos_alfaTgt
	    else
		help1 = x(2)
		help2 = v(1)
		help3 = v(2)
		x(1) = xgrid1 * Cos_alfaTgt  -  help1 * Sin_alfaTgt
		x(2) = xgrid1 * Sin_alfaTgt  +  help1 * Cos_alfaTgt
		v(1) =  help2 * Cos_alfaTgt  -  help3 * Sin_alfaTgt
		v(2) =  help2 * Sin_alfaTgt  +  help3 * Cos_alfaTgt
	    endif
	endif

c - zerfallen?          

	if (useDecay_) call Decay_Test(*555)

c - falls aufgeschlagen:

	if (flag) goto 555

c - Koordinatentransformation zurueck in Beschleunigersystem:

	if (alfaTgt.NE.0.) then
	    if (alfaTgtVertically) then
		x(1) = xGrid1
		x(3) = help1
		v(1) = help2
		v(3) = help3
	    else
		x(1) = xGrid1
		x(2) = help1
		v(1) = help2
		v(2) = help3
	    endif
	endif

c - Datenausgabe:

	if (Graphics_) call Save_Graphics_Koord
	if (Debug_)    call Output_Debug

c:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
c zweite Beschleunigerstufe:	      (homogenes Feld)

2	Gebiet = upToGrid2
	steps = Steps + 1

	if (a2.NE.0.) then
	    help1 = v(1)*v(1) + 2.*a2*(XGrid2-XGrid1)
	    if (help1.LT.0) then	! Reflektion noch vor 2. Gitter
		dt = -2*v(1)/a2
      		t = t + dt
      	       !x(1) bleibt unveraendert
		x(2) = x(2) + v(2)*dt
		x(3) = x(3) + v(3)*dt
		v(1) = -v(1)
      	       !v(2) bleibt unveraendert
      	       !v(3) bleibt unveraendert
		destiny = code_reflektiert
		goto 555
	    endif
	    dt = (sqrt(help1) - v(1))/a2
	    v(1) = v(1) + a2*dt
	else
	    if (v(1).EQ.0) then	    ! (kann nur bei Start in 2. Stufe passieren)
		write(*,*)
		write(*,*)'ERROR:  v(x) beim Start = 0. und '//
     +			'Beschleunigung = 0'
		write(*,*)
		STOP
	    endif
	    dt = (XGrid2-XGrid1) / v(1)
	endif

        t = t + dt
	x(2) = x(2) + v(2)*dt
	x(3) = x(3) + v(3)*dt

c - Aufgeschlagen?

	if (Abs(x(2)).gt.dygrid2/2. .OR.
     +			       Abs(x(3)).gt.dzgrid2/2.) then
	    flag = .true.
	    destiny = code_wand
	else
	    flag = .false.	! <- noetig, falls Start auf 1. Gitter
	endif

c - Gitterstab getroffen?

	if (testOnWireHit) then
	    DrahtNr = nInt(x(2)/dist_Wires_G2)
	    distToWire(1) = 0
	    distToWire(2) = x(2) - DrahtNr * dist_Wires_G2
	    call Test_WireHit(distToWire,WireRadiusQuad_G2,v(1),v(2),WireHit)
	    if (WireHit) then
		flag = .true.
		destiny = code_grid
	    endif
	endif

c - Koordinatentransformation in Kammersystem:

	if (alfaTgt.NE.0.) then
	    if (alfaTgtVertically) then
		x(1) = xgrid2 * Cos_alfaTgt  -  x(3) * Sin_alfaTgt
		x(3) = xgrid2 * Sin_alfaTgt  +  x(3) * Cos_alfaTgt
		help1 = v(1)
		v(1) =   help1 * Cos_alfaTgt  -  v(3) * Sin_alfaTgt
		v(3) =   help1 * Sin_alfaTgt  +  v(3) * Cos_alfaTgt
	    else
		x(1) = xgrid2 * Cos_alfaTgt  -  x(2) * Sin_alfaTgt
		x(2) = xgrid2 * Sin_alfaTgt  +  x(2) * Cos_alfaTgt
		help1 = v(1)
		v(1) =   help1 * Cos_alfaTgt  -  v(2) * Sin_alfaTgt
		v(2) =   help1 * Sin_alfaTgt  +  v(2) * Cos_alfaTgt
	    endif
	else
	    x(1) = xgrid2
	endif

c - zerfallen?          

	if (useDecay_) call Decay_Test(*555)

c - falls aufgeschlagen:

	if (flag) goto 555

c - Datenausgabe:

	if (Graphics_) call Save_Graphics_Koord
	if (Debug_)    call Output_Debug

c:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
c zwischen zweitem Gitter und He-Shield:      (feldfrei)

3	Gebiet = upToHeShield
	Steps = Steps + 1

	radiusQuad = x(1)*x(1) + x(2)*x(2)
	help1 = v(1)*v(1)+v(2)*v(2)
	help2 = x(1)*v(1)+x(2)*v(2)
	dt = (SQRT(help2*help2-help1*(radiusQuad-radiusQuad_HeShield))-help2)
     +									/help1
	t  = t + dt
	x(1) = x(1) + dt*v(1)		 ! den Ort berechnen, an dem
	x(2) = x(2) + dt*v(2)		 !   das Teilchen das Schild
	x(3) = x(3) + dt*v(3)		 !   durchquert

	if (useDecay_) call Decay_Test(*555)
	if (Abs(x(2)).gt.DYHESHIELD/2. .OR.
     +			       Abs(x(3)).gt.DZHESHIELD/2.) then
	    destiny = code_wand
	    goto 555
	endif
	if (Debug_)    call Output_Debug

c:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
c Groessen bei x=40 mm berechnen:

	if (NTP_40mm) then
	    dt = (40-x(1))/v(1)
	    x40(2) = x(2)+v(2)*dt
	    x40(3) = x(3)+v(3)*dt
	    v40(1) = v(1)
	    v40(2) = v(2)
	    v40(3) = v(3)
	    t40 = t + dt
	    ! help1 = v(1)*v(1)+v(2)*v(2) noch bekannt von 'upToHeShield'
	    v_square = help1 + v(3)*v(3)
	    E40 = v_square * Energie_Faktor
	endif

c:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
c zwischen He-Shield und LN-Shield: 	      (feldfrei)

4	Gebiet = upToLNShield
        Steps = Steps + 1

      	radiusQuad = x(1)*x(1) + x(2)*x(2)
	! help1 = v(1)*v(1)+v(2)*v(2)	 ! noch bekannt von 'upToHeShield'
	help2 = x(1)*v(1)+x(2)*v(2)
	dt = (SQRT(help2*help2-help1*(radiusQuad-radiusQuad_LNShield))-help2)
     +									/help1
	t  = t + dt
	x(1) = x(1) + dt*v(1)		 ! den Ort berechnen, an dem
	x(2) = x(2) + dt*v(2)		 !   das Teilchen das Schild
	x(3) = x(3) + dt*v(3)		 !   durchquert

	if (useDecay_) call Decay_Test(*555)
	if (abs(x(2)).gt.dyLNShield/2. .OR.
     +             Abs(x(3)).gt.dzLNShield/2.) then 
	    destiny = code_wand
	    goto 555
	endif
	if (Debug_)    call Output_Debug

c:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
c zwischen LN-Shield und Beginn der L1-Mappe: (feldfrei)

5	Gebiet = upToL1Map
        Steps = Steps + 1

        dt = (xEnterMap_L1 - x(1)) / v(1)

	t  = t + dt
	x(1) = xEnterMap_L1
	x(2) = x(2) + v(2)*dt
	x(3) = x(3) + v(3)*dt

        radiusQuad = x(2)*x(2) + x(3)*x(3)
        if (radiusQuad.GT.radiusQuad_Rohr) then
	    help1 = v(2)*v(2)+v(3)*v(3)
	    help2 = x(2)*v(2)+x(3)*v(3)
	    dt = (SQRT(help2*help2-help1*(radiusQuad-radiusQuad_Rohr))-help2)
     +									/help1
	    t  = t + dt
	    x(1) = x(1) + dt*v(1)		 ! den Ort berechnen, an dem
	    x(2) = x(2) + dt*v(2)		 !   das Teilchen auf das Rohr
	    x(3) = x(3) + dt*v(3)		 !   aufschlaegt
	    if (useDecay_) call Decay_Test(*555) ! vor Aufschlag zerfallen?
	    destiny = code_wand
	    goto 555
	endif
	if (useDecay_) call Decay_Test(*555)
	if (Graphics_) call Save_Graphics_Koord
	if (Debug_)    call Output_Debug
        if (radiusQuad.GT.radiusQuad_L1) then ! Teilchen fliegt an L1 vorbei
	    destiny = code_vorbei
	    goto 555
        endif

c:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
c innerhalb L1:				      (inhom. Felder -> Integrationen)

6	Gebiet = upToExL1		    ! GebietsNummer fuer L1 setzen

c Teste, ob das Teilchen ueberhaupt eine Beschleunigung erfaehrt (Spannung=0?,
c Ladung=0?). Falls nicht, steppe gleich bis zum Mappenende:

	if (Beschl_Faktor_L1.EQ.0) then
d	    dtmax_L1 = 0.
d	    dtmin_L1 = 0.
	    dt = (xLeaveMap_L1 - x(1)) / v(1)	     ! Zeit bis zum Mappenende
	    x(1) = xLeaveMap_L1
	    x(2) = x(2) + v(2)*dt
	    x(3) = x(3) + v(3)*dt
	    t = t + dt
	    goto 5106
	endif

c...............................................................................
c Das Teilchen spuert eine Beschleunigung, es muss also integriert werden.
c Gehe als ersten Versuch 0.5 mm in das Gebiet hinein:

	dt = .5/v(1)
	zaehler = 0

c...............................................................................
c hierher wird zurueckgesprungen, solange die Integration in der L1 bleibt

5006	call INTEGRATIONSSTEP_RUNGE_KUTTA_L1(dt)
d	if (NTP_steps) then
d	    if (dt.LT.dtmin_L1) then
d		dtmin_L1 = dt
d		x_dtmin_L1(1) = x(1)
d		x_dtmin_L1(2) = x(2)
d		x_dtmin_L1(3) = x(3)
d	    endif
d	    if (dt.GT.dtmax_L1) then
d		dtmax_L1 = dt
d		x_dtmax_L1(1) = x(1)
d		x_dtmax_L1(2) = x(2)
d		x_dtmax_L1(3) = x(3)
d	    endif
d	endif

c...............................................................................
5106	Steps = Steps + 1 ! neuer Ort, Zeit und Geschwindigkeit sind festgelegt

c do some tests:

	if (destiny.EQ.code_dtSmall) then	    ! n_dtsmall>maxBelowDtSmall
	    goto 555
	elseif (destiny.EQ.code_wand) then	    ! aufgeschlagen
	    radiusQuad = x(2)*x(2) + x(3)*x(3)	    ! -> den Ort berechnen, an
	    help1 = v(2)*v(2)+v(3)*v(3)		    !    dem das Teilchen auf-
	    help2 = x(2)*v(2)+x(3)*v(3)
	    dt = (SQRT(help2*help2-help1*(radiusQuad-radiusQuad_L1))-help2)
     +									/help1
	    t  = t + dt
	    x(1) = x(1) + dt*v(1)
	    x(2) = x(2) + dt*v(2)
	    x(3) = x(3) + dt*v(3)
	    if (useDecay_) call Decay_Test(*555)    ! vor Aufschlag zerfallen?
	    goto 555
c	elseif (destiny.NE.code_ok) then	    ! voruebergehend fuer Testzwecke
c	    write(*,*)
c	    write(*,*)'L1-1: ''destiny.NE.code_ok'' where it should  ->  STOP'
c	    write(*,*)'       destiny = ',destiny,': ',code_text(destiny)
c	    write(*,*)
c	    STOP
	elseif (useDecay_) then			    ! zerfallen?
	    call Decay_Test(*555)
	endif

	if (x(1).LT.xEnterMap_L1) then
	    if (v(1).LT.0) then			    ! reflektiert?
		destiny = code_reflektiert
		goto 555
	    else				    ! darf nicht sein!
		write(*,*)
		write(*,*)' L1: x(1).LT.xEnterMap .AND. v(1).GE.0.  -> STOP'
		write(*,*)
		STOP
	    endif
	elseif (Steps.GE.MaxStep) then		    ! Teilchen verloren
	    destiny = code_lost
	    goto 555
	elseif (x(1).GE.xLeaveMap_L1) then	    ! Verlasse L1
	    dt = (xLeaveMap_L1 - x(1))/v(1)	    ! rechne zurueck auf exaktes
	    t = t + dt				    !	  Mappenende
	    x(1) = xLeaveMap_L1
	    x(2) = x(2) + dt*v(2)
	    x(3) = x(3) + dt*v(3)
	    if (Graphics_) call Save_Graphics_Koord
	    if (Debug_)    call Output_Debug
	    goto bis_Spiegel			    ! -> Mache bei upToEnSp weiter
c	elseif (destiny.NE.code_ok) then	    ! voruebergehend fuer Testzwecke
c	    write(*,*)
c	    write(*,*)'L1-2: ''destiny.NE.code_ok'' where it should  ->  STOP'
c	    write(*,*)'       destiny = ',destiny,': ',code_text(destiny)
c	    write(*,*)
c	    STOP
	endif


c verarbeite alle 'imonitor' Schritte die Koordinaten fuer GRAPHICS und DEBUG:

	if (GRAPHICS_.or.Debug_) then
	    zaehler = zaehler + 1
	    if (zaehler.EQ.iMonitor) then
		if (Graphics_) call Save_Graphics_Koord
		if (Debug_) call Output_Debug
		zaehler = 0
	    endif
	endif

	goto 5006		    ! naechster Integrationsschritt in L1-Mappe

c:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
c zwischen Linse 1 und Spiegel:	      (feldfrei)

7	Gebiet = upToEnSp
	Steps = Steps + 1

c - berechne Schnittpunkt mit forderer Spiegelebene:

	help2 = v(2)/v(1)		    ! Steigung der Bahn in der x-y-Ebene

	if (help2.GE.Tan_alfaSp) then
	    ! Teilchen fliegt am Spiegel vorbei
	    dt = (600-x(1))/v(1)
	    t = t + dt
	    x(1) = x(1) + v(1)*dt
	    x(2) = x(2) + v(2)*dt
	    x(3) = x(3) + v(3)*dt
	    if (useDecay_) call Decay_Test(*555)
	    destiny = code_vorbei
	    goto 555
	else
	    ! help1 == neues x(1)
	    help1 = (x(2) - y_intersectSP + xSpiegel*Tan_alfaSp
     +				 - xLeaveMap_L1*help2) / (Tan_alfaSp - help2)

	    dt = (help1-x(1)) / v(1)
	    t  = t + dt
	    x(1) = help1
	    x(2) = x(2) + v(2)*dt
	    x(3) = x(3) + v(3)*dt
	endif

	if (useDecay_) call Decay_Test(*555)
	if (Debug_)    call Output_Debug


c Berechnung der Trajektorie bei idealem Spiegel:

	if (idealMirror) then				! ~~~ 40: if ~~~~~~~~~~~

c - pruefe, ob das Teilchen die ForderSEITE des Spiegels trifft:

	if ( x(2).GT.yUppLeft .OR. x(2).LT.yLowLeft .OR.
     +				      abs(x(3)).GT.HSpiegel/2.) then
	    ! -> Teilchen fliegt am Spiegel vorbei
	    dt = (600-x(1))/v(1)
	    t = t + dt
	    x(1) = x(1) + v(1)*dt
	    x(2) = x(2) + v(2)*dt
	    x(3) = x(3) + v(3)*dt
	    destiny = code_vorbei
	    goto 555
	endif


c - pruefe, ob das Teilchen einen Gitterstab des Spiegels trifft:

	if (testOnWireHit) then
	    help1 = x(2)-yLowLeft		! Abstand zum Bezugspunkt
	    DrahtNr = nInt(help1/(Sin_alfaSp*dist_Wires_Sp))
	    distToWire(2) = help1 - DrahtNr * Sin_alfaSp*dist_Wires_Sp
	    distToWire(1) = distToWire(2)/Tan_alfaSp
	    call Test_WireHit(distToWire,WireRadiusQuad_Sp,v(1),v(2),WireHit)
	    if (WireHit) then
		destiny = code_grid
		goto 555
	    endif
	endif


c:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
c im Spiegel:			      (homogenes Feld)

8	Gebiet = upToExSp
	Steps = Steps + 1

c - pruefe, ob Teilchen nicht zuviel Energie senkrecht zum Spiegel hat:

	if (Spiegel_Faktor.EQ.0.) then	! Spannung=0. oder q=0
	    dt = (600-x(1))/v(1)
	    t = t + dt
	    x(1) = x(1) + v(1)*dt
	    x(2) = x(2) + v(2)*dt
	    x(3) = x(3) + v(3)*dt
	    destiny = code_durchSpiegel
	    goto 555
	endif

	! help1 == Winkel in xy-Ebene zwischen Bewegungsrichtung und Spiegelfront

	help1 = alfaSp - atand(v(2)/v(1))

	! help2 = Geschw.Komponente senkrecht auf den Spiegel gerichtet
	! help3 = Geschw.Komponente parallel zum Spiegel, zu positiven y hin

	v_xy = sqrt( v(1)*v(1) + v(2)*v(2) )
	help2 = sind(help1) * v_xy
	help3 = cosd(help1) * v_xy

	if (help2*help2*Energie_Faktor.GE.q*U_Sp) then
	    ! Teilchen tritt durch Spiegel durch
	    dt = (600-x(1))/v(1)
	    t = t + dt
	    x(1) = x(1) + v(1)*dt
	    x(2) = x(2) + v(2)*dt
	    x(3) = x(3) + v(3)*dt
	    destiny = code_durchSpiegel
	    goto 555
	endif

	if (Graphics_) call Save_Graphics_Koord


c - berechne Zeit, bis Teilchen wieder auf Spiegelforderseite ist:

	dt = help2 * Spiegel_Faktor    ! Spiegel_Faktor == 2 / a
	t  = t + dt

c - berechne Versetzung in xy-Ebene, parallel zur Spiegelebene,
c   in 'positiver y-Richtung' (speichere in 'help1'):

	help1 = help3*dt

c . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
c falls Graphikausgabe verlangt ist:
c Um die Teilchenbahn im Innern des Spiegels anzudeuten, berechne die Orte bei
c t+dt/4, t+td/2 und t+3dt/4. Bestimme dafuer erst die jeweilige Versetzung
c senkrecht zur Spiegelebene aus dx = vx * t + 1/2 * a * t**2.
c (speichere in help4):

	if (Graphics_) then

	    help4 = help2*dt*.25 - (dt*dt*.0625)/Spiegel_faktor
	    nKoord = nKoord + 1
	    xKoord(nKoord) = x(1)+help4*Sin_alfaSp+help1*.25*Cos_alfaSp
	    yKoord(nKoord) = x(2)-help4*Cos_alfaSp+help1*.25*Sin_alfaSp
	    zKoord(nKoord) = x(3) + v(3)*dt*.25

	    help4 = help2*dt*.50 - (dt*dt*.2500)/Spiegel_faktor
	    nKoord = nKoord + 1
	    xKoord(nKoord) = x(1)+help4*Sin_alfaSp+help1*.50*Cos_alfaSp
	    yKoord(nKoord) = x(2)-help4*Cos_alfaSp+help1*.50*Sin_alfaSp
	    zKoord(nKoord) = x(3)+v(3)*dt*.50

	    help4 = help2*dt*.75 - (dt*dt*.5625)/Spiegel_faktor
	    nKoord = nKoord + 1
	    xKoord(nKoord) = x(1)+help4*Sin_alfaSp+help1*.75*Cos_alfaSp
	    yKoord(nKoord) = x(2)-help4*Cos_alfaSp+help1*.75*Sin_alfaSp
	    zKoord(nKoord) = x(3)+v(3)*dt*.75

	endif
c . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .

c - berechne Austrittsort:                    

	x(1) = x(1) + help1 * Cos_alfaSp
	x(2) = x(2) + help1 * Sin_alfaSp
	x(3) = x(3) + v(3)*dt


c - berechne Austrittsgeschwindigkeit (help2 geht bei Spiegelung in -help2 ueber):

	v(1) = help3 * Cos_alfaSp - help2 * Sin_alfaSp
	v(2) = help2 * Cos_alfaSp + help3 * Sin_alfaSp

	if (v(2).LE.0) then
	    write(*,*)
	    write(*,*)'ERROR:  nach Spiegel ist v(y) <= 0.'
	    write(*,*)
	    STOP
	endif

	if (useDecay_) call Decay_Test(*555)


c - pruefe, ob Austrittspunkt auf forderer Spiegelflaeche liegt:

	if (x(2).GT.yUppLeft .OR. x(2).LT.yLowLeft .OR.
     +					  abs(x(3)).GT.hSpiegel/2.) then
	    ! Teilchen trifft auf Spiegelwand
	    destiny = code_wand
	    goto 555
	endif


c - pruefe, ob das Teilchen einen Gitterstab des Spiegels trifft:

	if (testOnWireHit) then
	    help1 = x(2)-yLowLeft		! Abstand zum Bezugspunkt
	    DrahtNr = nInt(help1/(Sin_alfaSp*dist_Wires_Sp))
	    distToWire(2) = help1 - DrahtNr * Sin_alfaSp*dist_Wires_Sp
	    distToWire(1) = distToWire(2)/Tan_alfaSp
	    call Test_WireHit(distToWire,WireRadiusQuad_Sp,v(1),v(2),WireHit)
	    if (WireHit) then
		destiny = code_grid
		goto 555
	    endif
	endif

	if (Graphics_) call Save_Graphics_Koord
	if (Debug_)    call Output_Debug

	goto 9

	endif						    ! ~~~ 40: endif ~~~~


c:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
c innerhalb der Spiegelmappe (dx = 0.050 mm, dy = 0.050 mm)

	Gebiet = upToExSp
	nKoordSave = nKoord

c Die Anweisungen dieses Abschnitts verlaufen analog zu denen
c von Linse 1. -> Fuer Kommentare siehe dort!

	if (Beschl_Faktor_Sp.EQ.0. .OR. q.EQ.0) then
d	    dtmax_Sp = 0.    
d	    dtmin_Sp = 0.
	    dt = (600-x(1))/v(1)
	    t = t + dt
	    x(1) = x(1) + v(1)*dt
	    x(2) = x(2) + v(2)*dt
	    x(3) = x(3) + v(3)*dt
	    destiny = code_durchSpiegel
	    goto 555
	endif

	dt = 0.5/v(1)

	reachedEndOfMap = .false.
	zaehler = 0


c Rechne in Spiegelmappen-Koordinaten um:
c Im Spiegelmappensystem: x-Achse verlaueft entlang der forderen Mappenkante,
c y-Achse aus dem Spiegel heraus. (entgegen der Richtung zunehmender Mappen-
c j-indizierung!)


5008    help1=  x(1) - xSpiegel
      	x(1) =  - x(2)*Cos_alfaSp + help1*Sin_alfaSp + 
     +			        (dSpiegel/2.+DreharmLaenge+xSpGrid1)
      	x(2) =    x(2)*Sin_alfaSP + help1*Cos_alfaSP
      	help1=  v(1)
      	v(1) =  - v(2)*Cos_alfaSp + help1*Sin_alfaSp
      	v(2) =    v(2)*Sin_alfaSP + help1*Cos_alfaSP


c mache Integrationsschritt:

	call INTEGRATIONSSTEP_RUNGE_KUTTA_Sp(dt)	! setzt u.U. auch 'destiny'

        Steps = Steps + 1


c do some tests:

	if (Steps.GE.MaxStep) destiny = code_lost       ! Teilchen verloren


c - Potentialmappe nach Reflektion wieder verlasssen?

	if (x(1).LT.0) then
	    reachedEndOfMap = .true.

c - Spiegelrahmen getroffen?

	elseif (x(1).GE.xSpGrid1 .AND. 
     +	  (abs(x(2)).GT.bSpiegel/2. .OR. abs(x(3)).GT.hSpiegel/2.)) then
	    destiny = code_wand

c - Gitterstab getroffen?

	else
      	    help1 = min(abs(x(1)-xSpGrid1),abs(x(1)-xSpGrid1))
	    if (help1.LE.rWires_Sp) then
      		DrahtNr = nInt(x(2)/dist_Wires_Sp)
      		distToWire(2) = x(2) - DrahtNr * dist_Wires_Sp
		if ( (help1*help1 + distToWire(2)*distToWire(2)).LE.
     +	        radiusQuad_Sp) destiny = code_grid
	    endif

	endif

c	if (destiny.NE.code_ok) then
c	    if (x(1).LT.xSpGrid1) then
c		if (v(1).GT.0) then
c		    gebiet = UpToGrid
c		else
c		    gebiet = upToExMap
c		endif
c	    else
c		gebiet = RetToGrid		
c	    endif
c	endif


c Rechne in Kammerkoordinaten zurueck:

      	help1= x(1)-(dSpiegel/2.+DreharmLaenge+xSpGrid1)
      	x(1) =   help1*Sin_alfaSP + x(2)*Cos_alfaSP  + xSpiegel
      	x(2) = - help1*Cos_alfaSP + x(2)*Sin_alfaSP
      	help1= v(1)
      	v(1) =   help1*Sin_alfaSP + v(2)*Cos_alfaSP
      	v(2) = - help1*Cos_alfaSP + v(2)*Sin_alfaSP

d	if (NTP_steps) then
d	    if (dt.LT.dtmin_Sp) then
d		dtmin_Sp = dt
d		x_dtmin_Sp(1) = x(1)
d		x_dtmin_Sp(2) = x(2)
d		x_dtmin_Sp(3) = x(3)
d	    endif
d	    if (dt.GT.dtmax_Sp) then
d		dtmax_Sp = dt
d		x_dtmax_Sp(1) = x(1)
d		x_dtmax_Sp(2) = x(2)
d		x_dtmax_Sp(3) = x(3)
d	    endif
d	endif


c zerfallen?

	if (useDecay_) call Decay_Test(*555)


c Bahnberechnung abgebrochen?

	if (destiny.NE.code_ok) goto 555


c verarbeite alle 'imonitor' Schritte die Koordinaten fuer GRAPHICS und DEBUG:

	if (GRAPHICS_.or.Debug_) then
	    zaehler = zaehler + 1
	    if (zaehler.EQ.iMonitor) then
		if (GRAPHICS_) call Save_Graphics_Koord
		if (Debug_) call Output_Debug
		zaehler = 0
	    endif
	endif

	if (.NOT.reachedEndOfMap) goto 5008	  ! naechster Integrationsschritt

c:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
c zwischen Spiegel und Koordinatenwechsel-Ebene y=xChangeKoord:	  (feldfrei)

9	Gebiet = upToChKoord
	Steps = Steps + 1

	if (x(2).LT.xChangeKoord) then
	    ! gegebenenfalls flag fuer Graphikausgabe des Punktes setzen
	    flag = .true.
	else
	    flag = .false.
	endif
	
      	dt = (xChangeKoord - x(2)) / v(2)
	t  = t + dt
	x(1) = x(1) + v(1)*dt
	x(2) = xChangeKoord
	x(3) = x(3) + v(3)*dt

	help4 = x(1)-xSpiegel
        radiusQuad = help4*help4 + x(3)*x(3)
        if (radiusQuad.GT.radiusQuad_Rohr) then
	    help1 = v(1)*v(1)+v(3)*v(3)
	    help2 = help4*v(1)+x(3)*v(3)
	    dt = (SQRT(help2*help2-help1*(radiusQuad-radiusQuad_Rohr))-help2)
     +									/help1
	    t  = t + dt
	    x(1) = x(1) + dt*v(1)		 ! den Ort berechnen, an dem
	    x(2) = x(2) + dt*v(2)		 !   das Teilchen auf das Rohr
	    x(3) = x(3) + dt*v(3)		 !   aufschlaegt
	    if (useDecay_) call Decay_Test(*555) ! vor Aufschlag zerfallen?
	    destiny = code_wand
	    goto 555
	endif
	if (useDecay_) call Decay_Test(*555)
	if (Graphics_.AND.flag) call Save_Graphics_Koord
	if (Debug_)    call Output_Debug


c . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
c falls Graphikausgabe verlangt ist: Gib jetzt die Trajektorie im 'horizontalen'
c Teil der Kammer aus und resette nKoord:

	if (Graphics_) then

	    call plot_horizontal
	    if (schnitt_p.eq.1) call schnitt	! Schnittebene

	    ! die letzten Koordinaten fuer Plot der Trajektorie im 2. Kammerteil
	    ! uebernehmen (in neues KoordinatenSystem transformiert):

	    k = nKoord

	    if (idealMirror) then
		nKoord = 7
	    else
		if (nKoord.LT.nKoordSave) then
		    ! => ein 'turn over' fand statt waehrend das Teilchen in der
		    !    Spiegelmappe war   => x(999) -> x(1),  x(1000) -> x(2)
		    nKoord = nKoord + (999-nKoordSave)
		else
		    nKoord = nKoord - nKoordSave + 1
		endif
		nKoord = nKoord-2
	    endif

	    do i = nKoord, 1, -1
		xKoord_(i) = yKoord(k)
		yKoord_(i) = xSpiegel - xKoord(k)
		zKoord_(i) = zKoord(k)
		k = k - 1
		if (k.EQ.0) then
		    k = 998
		endif
	    enddo
	    do i = 1, nKoord
		xKoord(i) = xKoord_(i)
		yKoord(i) = yKoord_(i)
		zKoord(i) = zKoord_(i)
	    enddo
	endif


c . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
c - Vollziehe Koordinatenwechsel: neuer Ursprung in der Spiegelaufhaengung,
c   x-Richtung in bisherige y-Richtung (also wiederum entlang Strahlachse),
c   y-Richtung in bisheriger negativer x-Richtung. z-Richtung bleibt gleich.

	help1 =  x(2)
	x(2)  =  xSpiegel - x(1)
	x(1)  =  help1
	help1 =  v(1)
	v(1)  =  v(2)
	v(2)  =  - help1

	if (Debug_) then
	    write (lun(1),*) 'KOORDINATENWECHSEL:'
	    call Output_Debug
	endif


c Beruecksichtige gegebenenfalls die Flugzeit in 'delta_L1', welches 'vor dem 
c Triggerdetektor' eingeschoben werden kann:

	dt = Delta_L1 / v(1)
	x(1) = x(1)+v(1)*dt
	x(2) = x(2)+v(2)*dt
	x(3) = x(3)+v(3)*dt
	t  = t + dt


c:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::

	if (lense2) then		! ~~~~~~~~~~~~~~ ******* ~~~~~~~~~~~~~~~

c Bei 'lense2' wird fuer das Feld der Linse 2 und das Feld der TD-Folie eine
c gemeinsame Mappe verwendet. Hierbei ist allerdings der Triggerwinkel auf 0
c Grad festgelegt. Da es in Zukunft in der Praxis wohl kaum noch vorkommen wird,
c dass der Triggerdetektor verdreht wird, sollte diese Einschraenkung jedoch
c keine grossen Auswirkungen haben.
c Ist der Triggerdetektor nicht im Strahl, so wird der Anteil der Triggerfolie
c gleich Null gesetzt.

c - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 
c zwischen KOORDINATENWECHSEL und Beginn der L2andFo-Mappe:	(feldfrei)

10	Gebiet = upToL2andFoMap
        Steps = Steps + 1

        dt = (xEnterMap_L2andFo - x(1)) / v(1)
	t  = t + dt
	x(1) = xEnterMap_L2andFo
	x(2) = x(2) + v(2)*dt
	x(3) = x(3) + v(3)*dt

	radiusQuad = x(2)*x(2) + x(3)*x(3)
        if (radiusQuad.GT.radiusQuad_Rohr) then
	    help1 = v(2)*v(2)+v(3)*v(3)
	    help2 = x(2)*v(2)+x(3)*v(3)
	    dt = (SQRT(help2*help2-help1*(radiusQuad-radiusQuad_Rohr))-help2)
     +									/help1
	    t  = t + dt
	    x(1) = x(1) + dt*v(1)		 ! den Ort berechnen, an dem
	    x(2) = x(2) + dt*v(2)		 !   das Teilchen auf das Rohr
	    x(3) = x(3) + dt*v(3)		 !   aufschlaegt
	    if (useDecay_) call Decay_Test(*555) ! vor Aufschlag zerfallen?
	    destiny = code_wand
	    goto 555
	endif

	if (useDecay_) call Decay_Test(*555)
	if (Graphics_) call Save_Graphics_Koord
	if (Debug_)    call Output_Debug

	if (radiusQuad.GT.radiusQuad_L2) then	 ! Teilchen fliegt an L2 vorbei
	    destiny = code_vorbei
	    goto 555
	endif

c:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
c innerhalb der gemeinsamen Mappe von Linse 2 und dem Feld vor der Trigger-
c Detektor-Folie:

11	Gebiet = upToExL2			 ! Gebietsnummer fuer L2 setzen

c Die Anweisungen dieses Abschnitts verlaufen analog zu denen
c von Linse 1. -> Fuer Kommentare siehe dort!

	if (Beschl_Faktor.EQ.0. .OR. (U_L2.EQ.0. AND. U_F.EQ.0.)) then
c	    WRITE(*,*) 'HALLOHALLO!'
d	    dtmax_L2andFo = 0.    
d	    dtmin_L2andFo = 0.
	    dt = (xEndLense_L2 - x(1)) / v(1)	 ! Zeit bis zum Linsenende
	    x(1) = xEndLense_L2
	    x(2) = x(2) + v(2)*dt
	    x(3) = x(3) + v(3)*dt
	    t = t + dt
	    radiusQuad = x(2)*x(2) + x(3)*x(3)
      	    if (radiusQuad.GT.radiusQuad_L2) then
		destiny = code_wand
		radiusQuad_ = radiusQuad_L2
		goto 5111
	    endif
	    if (TriggerInBeam) then
		Gebiet = upToEnTD	    ! Gebietsnummer fuer upToTD setzen
		! Zeit bis zum Mappenende (falls TD im Strahl: bis Triggerfolie)
		dt = (xLeaveMap_L2andFo - xEndLense_L2) / v(1) 
		x(1) = xLeaveMap_L2andFo
		x(2) = x(2) + v(2)*dt
		x(3) = x(3) + v(3)*dt
		t = t + dt
		radiusQuad = x(2)*x(2) + x(3)*x(3)
      		if (radiusQuad.GT.radiusQuad_Rohr) then
		    destiny = code_wand
		    radiusQuad_ = radiusQuad_Rohr
		endif
	    endif
	    goto 5111
	endif

	dt = .5/v(1)
	zaehler = 0
	reachedEndOfMap = .false.


c die Integrationsroutine will x bereits relativ zum Mappenanfang geliefert
c bekommen:

5011	x(1) = x(1) - xEnterMap_L2andFo
	call INTEGRATIONSSTEP_RUNGE_KUTTA_L2(dt)
	x(1) = x(1) + xEnterMap_L2andFo

d	if (NTP_steps) then
d	    if (dt.LT.dtmin_L2andFo) then
d		dtmin_L2andFo = dt
d		x_dtmin_L2andFo(1) = x(1)
d		x_dtmin_L2andFo(2) = x(2)
d		x_dtmin_L2andFo(3) = x(3)
d	    endif
d	    if (dt.GT.dtmax_L2andFo) then
d		dtmax_L2andFo = dt
d		x_dtmax_L2andFo(1) = x(1)
d		x_dtmax_L2andFo(2) = x(2)
d		x_dtmax_L2andFo(3) = x(3)
d	    endif
d	endif

5111	Steps = Steps + 1

	if (destiny.EQ.code_dtSmall) then	    ! n_dtsmall>maxBelowDtSmall
	    goto 555
	elseif (destiny.EQ.code_wand) then	    ! aufgeschlagen
	    radiusQuad = x(2)*x(2) + x(3)*x(3)	    ! -> den Ort berechnen, an
	    help1 = v(2)*v(2)+v(3)*v(3)		    !    dem das Teilchen auf-
	    help2 = x(2)*v(2)+x(3)*v(3) 	    !	 schlaegt
	    dt = (SQRT(help2*help2-help1*(radiusQuad-radiusQuad_))-help2)/help1
	    t  = t + dt
	    x(1) = x(1) + dt*v(1)
	    x(2) = x(2) + dt*v(2)
	    x(3) = x(3) + dt*v(3)
	    if (useDecay_) call Decay_Test(*555)    ! vor Aufschlag zerfallen?
	    goto 555
	elseif (useDecay_) then			    ! zerfallen?
	    call Decay_Test(*555)
	endif

	if (Gebiet.EQ.upToExL2) then	    ! ----> noch innerhalb von Linse 2

	    radiusQuad = x(2)*x(2) + x(3)*x(3)
      	    if (radiusQuad.GT.radiusQuad_L2) then
		destiny = code_wand
		radiusQuad_ = radiusQuad_L2
		goto 5111
	    endif

	    if (x(1).LT.xEnterMap_L2andFo) then
		if (v(1).LT.0) then		    ! reflektiert
		    destiny = code_reflektiert
		    goto 555
		else				    ! darf nicht sein!
		    write(*,*)
		    write(*,*)' L2: x(1).LT.xEnterMap .AND. v(1).GE.0.  -> STOP'
		    write(*,*)
		    call exit
		endif
	    elseif (x(1).GT.xEndLense_L2) then	    ! Verlasse L2
		Gebiet = upToEnTD
	    endif

	else				    ! ----> zw. Linse 2 und TD-Folie:

c	    if (x(1).EQ.xLeaveMap_L2andFo) then	    ! Verlasse Mappe
	    if (reachedEndOfMap) then		    ! Verlasse Mappe

c		WRITE(*,*) 'HALLO: x(1).EQ.xLeaveMap_L2andFo !!'
		! ====================================================
		! muss in Integrationsroutine richtig abgestimmt sein!
		! ====================================================

		if (Graphics_) call Save_Graphics_Koord
		if (Debug_)    call Output_Debug
		if (TriggerInBeam) then
		    ! rechne in Triggerkoordinaten um (Folie == x=0)
		    x(1) = 0
		    goto 112
		else
		    goto bis_L3_Mappe
		endif
	    endif

      	    if (radiusQuad.GT.radiusQuad_Rohr) then
		destiny = code_wand
		radiusQuad_ = radiusQuad_Rohr
		goto 5111
	    endif

	endif

	if (Steps.GE.MaxStep) then		    ! Teilchen verloren
	    destiny = code_lost
	    goto 555
	endif

	if (GRAPHICS_.or.Debug_) then
	    zaehler = zaehler + 1
	    if (zaehler.EQ.iMonitor) then
		if (Graphics_) call Save_Graphics_Koord
		if (Debug_) call Output_Debug
		zaehler = 0
	    endif
	endif

	goto 5011	! naechster Integrationsschritt in gleicher Feldmappe

	endif	! if (lense2) then....		! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~


c:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::

	if (.NOT.TriggerInBeam) goto bis_L3_Mappe


c zwischen Koordinatenwechselebene und Triggerfolie:         (feldfrei)
12	Gebiet = upToEnTD

c Die Anweisungen dieses Abschnitts verlaufen in weiten Teilen parallel zu denen
c von Linse 1. -> Fuer Kommentare zu diesen Bereichen siehe dort!

	if (Beschl_Faktor_FO.EQ.0. .OR. gridInFrontOfFoil) then
	    ! => keine Integration in der Folienmappe
	    Steps = Steps + 1
	    help1 = v(2)/v(1)		! Steigung der Bahn in der x-y-Ebene
d	    dtmin_FO = 0.
d	    dtmax_FO = 0.

c - berechne Schnittpunkt der Trajektorie mit Ebene der Triggerfolie bzw. bei
c   'GridInFrontOfFoil' mit Ebene des Gitters vor der Triggerfolie:
c   Folienebene    :  y'= (x_intersectTD - x') / Tan_alfaTD
c   Trajektorie    :  y'= y + v(2)/v(1)*(x'-x) = y + help1*(x'-x)
c   => Schnittpunkt:  x'= (x_intersectTD/Tan_alfaTD - y + help1*x)/(help1 + 1/Tan_alfaTD)
c			= (x_intersectTD + Tan_alfaTD*(help1*x-y))/(1+help1*Tan_alfaTD)
c			  (erste Gleichung hat Probleme bei Tan_alfaTD = 0!)

	    if (atand(help1).EQ.alfaTD-90) then    ! ueberpruefen<<<<<<<<<<<<<<<<<<
		! Teilchen fliegt parallel zur Folie => fliegt an TD vorbei
		destiny = code_vorbei
		goto 555
	    else	    ! help2 == neues x(1)
		if (Tan_alfaTD.EQ.0) then
		    dt = (x_intersectTD-x(1)) / v(1)
		    x(1) = x_intersectTD
		else
		    help2 = (x_intersectTD+Tan_alfaTD*
     +			 (help1*xChangeKoord-x(2)))/(1+help1*Tan_alfaTD)
		    if (help2.LT.xChangeKoord) then
			! Teilchen fliegt 'steiler' als Folienebene
			! -> kein Schnittpunkt mit dt.gt.0  =>  fliegt an TD vorbei
			destiny = code_vorbei
			goto 555
		    else ! Bahntangente kreuzt Folienebene
			dt = (help2-x(1)) / v(1)
			x(1) = help2
		    endif
		endif
	    endif

c -> Teilchenort in Folienebene bzw. bei 'GridInFrontOfFoil' in Ebene des
c    geerdeten Gitters vor der Triggerfolie:

	    x(2) = x(2) + v(2)*dt
	    x(3) = x(3) + v(3)*dt
	    t  = t + dt

      	    radiusQuad = x(2)*x(2) + x(3)*x(3)
      	    if (radiusQuad.GT.radiusQuad_Rohr) then
		help1 = v(2)*v(2)+v(3)*v(3)
	        help2 = x(2)*v(2)+x(3)*v(3)
	        dt = (SQRT(help2*help2-help1*(radiusQuad-radiusQuad_Rohr))-help2)
     +								/help1
		t  = t + dt
		x(1) = x(1) + dt*v(1)		 ! den Ort berechnen, an dem
		x(2) = x(2) + dt*v(2)		 !   das Teilchen auf das Rohr
		x(3) = x(3) + dt*v(3)		 !   aufschlaegt
		if (useDecay_) call Decay_Test(*555) ! vor Aufschlag zerfallen?
		destiny = code_wand
		goto 555
	    endif

	    if (useDecay_) call Decay_Test(*555)
	    if (Graphics_) call Save_Graphics_Koord
	    if (Debug_)	   call Output_Debug


c Koordinatentransformation vom Kammersystem in das System des Triggerdetektors:
c (Ursprung in Folienmitte, x-Achse senkrecht zur Folie, y-Achse parallel zur
c Folie. Wenn der TD nicht verdreht ist, verlaufen die Achsen parallel zu
c denen des Kammersystems):

	    if (alfaTD.NE.0) then
		x(2) = (xTD-x(1))*Sin_alfaTD + x(2)*Cos_alfaTD 
		help1=  v(1) ! zur Zwischenspeicherung
		v(1) =  help1*Cos_alfaTD + v(2)*Sin_alfaTD
		v(2) = -help1*Sin_alfaTD + v(2)*Cos_alfaTD
	    endif

	    if (.NOT.GridInFrontOfFoil) then
		x(1) = 0
	    else
		! -> berechne Schnittpunkt der Trajektorie mit Folienebene unter
		!    der Annahme einer idealen Potentialrampe:

		if (aFoil.NE.0.) then
		    help1 = v(1)*v(1) + 2.*aFoil*(d_Grid_Folie)
		    if (help1.LT.0) then	! Reflektion noch vor Folie
			dt = -2*v(1)/aFoil
      			t = t + dt
			x(1) = - d_Grid_Folie
			x(2) = x(2) + v(2)*dt
			x(3) = x(3) + v(3)*dt
			v(1) = -v(1)
			destiny = code_reflektiert
			goto 555
		    endif
		    dt = (sqrt(help1) - v(1))/aFoil
		    ! (ergibt sich aus x=v*t+1/2*a*t**2 mit richtiger V.Z.-Wahl ('+'))
		    v(1) = v(1) + aFoil*dt
		else
		    dt = d_Grid_Folie / v(1)
		endif

      		t = t + dt
		x(1) = 0    ! im Triggersystem
		x(2) = x(2) + v(2)*dt
		x(3) = x(3) + v(3)*dt

	    endif   ! if (GridInFrontOfFoil) ...

	    goto 112

c...............................................................................
	else	    ! (if Beschl_Faktor_FO.EQ.0 .OR. GridInFrontOfFoil) then ...

	! => Integration in der Folienmappe:
	! alte Version: ab xChangeKoord wurde integriert, wobei das EFeld im
	! Bereich vor der Mappe als 0 zurueckgegeben wurde.
	! Ab Version 1.2.9: Bis Schnittpunkt der Trajektorie mit Beginn der
	! Potentialmappe wird extrapoliert, dann erst integriert:


c Einschub ab Version 1.2.9: ***************************************************

	Steps = Steps + 1
	help1 = v(2)/v(1)		! Steigung der Bahn in der x-y-Ebene

c - berechne Schnittpunkt der Trajektorie mit Beginn der Potentialmappe:
c   Mappenebene    :  y'= (x_intersectTDMap - x') / Tan_alfaTD
c   Trajektorie    :  y'= y + v(2)/v(1)*(x'-x) = y + help1*(x'-x)
c   => Schnittpunkt:  x'= (x_intersectTDMap/Tan_alfaTD - y + help1*x)/(help1 + 1/Tan_alfaTD)
c			= (x_intersectTDMap + Tan_alfaTD*(help1*x-y))/(1+help1*Tan_alfaTD)
c			  (erste Gleichung hat Probleme bei Tan_alfaTD = 0!)

	if (atand(help1).EQ.alfaTD-90) then    ! ueberpruefen<<<<<<<<<<<<<<<<<<
	    ! Teilchen fliegt parallel zur Mappe => fliegt an TD vorbei
	    destiny = code_vorbei
	    goto 555

	    ! stimmt so u.U. noch nicht ganz. Kommt aber eigentlich eh nie vor!
	    ! (stimmt bis jetzt wohl nur fuer positive alpha(TD)

	else
	    if (Tan_alfaTD.EQ.0) then
		dt = (x_intersectTDMap-x(1)) / v(1)
		x(1) = x_intersectTDMap
	    else
		! help2 == neues x(1):
		help2 = (x_intersectTDMap+Tan_alfaTD*
     +		     (help1*xChangeKoord-x(2)))/(1+help1*Tan_alfaTD)
		! folgendes herauskommentiert, da es teilweise passierte, dass
		! der Mappenanfang ueber xChangekoord hinausreichte und die
		! Trajektorien dann faelschlicherweise abgebrochen worden sind.

c		if (help2.LT.xChangeKoord) then
c		    ! Teilchen fliegt 'steiler' als Mappenebene
c		    ! -> kein Schnittpunkt mit dt.gt.0  =>  fliegt an TD vorbei
c		    destiny = code_vorbei
c		    goto 555
c		else ! Bahntangente kreuzt Mappenebene
		    dt = (help2-x(1)) / v(1)
		    x(1) = help2
c		endif
	    endif
	endif

c -> Teilchenort in Mappenebene:

	x(2) = x(2) + v(2)*dt
	x(3) = x(3) + v(3)*dt
	t  = t + dt

      	radiusQuad = x(2)*x(2) + x(3)*x(3)
      	if (radiusQuad.GT.radiusQuad_Rohr) then
	    help1 = v(2)*v(2)+v(3)*v(3)
	    help2 = x(2)*v(2)+x(3)*v(3)
	    dt = (SQRT(help2*help2-help1*(radiusQuad-radiusQuad_Rohr))-help2)
     +							    /help1
	    t  = t + dt
	    x(1) = x(1) + dt*v(1)		 ! den Ort berechnen, an dem
	    x(2) = x(2) + dt*v(2)		 !   das Teilchen auf das Rohr
	    x(3) = x(3) + dt*v(3)		 !   aufschlaegt
	    if (useDecay_) call Decay_Test(*555) ! vor Aufschlag zerfallen?
	    destiny = code_wand
	    goto 555
	endif

	if (useDecay_) call Decay_Test(*555)
	if (Graphics_) call Save_Graphics_Koord
	if (Debug_)	   call Output_Debug

c Ende des Einschubes ab Version 1.2.9: ****************************************
c => Jetzt erfolgt Start in die Folienmappe:

	reachedEndOfMap = .false.	! Folienebene wurde noch nicht erreicht
	dt = .5/v(1)			! 1. Testschritt 0.5 mm in x-Richtung
	zaehler = 0


c Rechne in Folienmappen-Koordinaten um:

5012	if (alfaTD.NE.0) then
	    help1=  x(1)-xTD
	    x(1) =  help1*Cos_alfaTD + x(2)*Sin_alfaTD + length1
	    x(2) = -help1*Sin_alfaTD + x(2)*Cos_alfaTD
	    help1=  v(1)
	    v(1) =  help1*Cos_alfaTD + v(2)*Sin_alfaTd
	    v(2) = -help1*Sin_alfaTD + v(2)*Cos_alfaTd
	else
	    x(1) =  x(1) - length2
	endif


c mache Integrationssschritt:

	call INTEGRATIONSSTEP_RUNGE_KUTTA_FO(dt)

d	if (NTP_steps) then
d	    if (dt.LT.dtmin_FO) then
d		dtmin_FO = dt
d		x_dtmin_FO(1) = x(1)
d		x_dtmin_FO(2) = x(2)
d		x_dtmin_FO(3) = x(3)
d	    endif
d	    if (dt.GT.dtmax_FO) then
d		dtmax_FO = dt
d		x_dtmax_FO(1) = x(1)
d		x_dtmax_FO(2) = x(2)
d		x_dtmax_FO(3) = x(3)
d	    endif
d	endif


c Rechne in Kammerkoordinaten zurueck:

	if (alfaTD.NE.0) then
	    help1= x(1)-length1
	    x(1) = help1*Cos_alfaTD - x(2)*Sin_alfaTD + xTD
	    x(2) = help1*Sin_alfaTD + x(2)*Cos_alfaTD
	    help1= v(1)
	    v(1) = help1*Cos_alfaTD - v(2)*Sin_alfaTD
	    v(2) = help1*Sin_alfaTD + v(2)*Cos_alfaTD
	else
	    x(1) =  x(1) + length2
	endif

	Steps = Steps + 1  ! neuer Ort, Zeit und Geschwindigkeit sind festgelegt

c do some tests:

	if (destiny.EQ.code_dtSmall) then	    ! n_dtSmall>maxBelowDtSmall
	    goto 555
	endif
        radiusQuad = x(2)*x(2) + x(3)*x(3)
        if (radiusQuad.GT.radiusQuad_Rohr) then	    ! aufgeschlagen
	    help1 = v(2)*v(2)+v(3)*v(3)		    ! -> den Ort berechnen, an
	    help2 = x(2)*v(2)+x(3)*v(3)
	    dt = (SQRT(help2*help2-help1*(radiusQuad-radiusQuad_Rohr))-help2)
     +									/help1
	    t  = t + dt
	    x(1) = x(1) + dt*v(1)
	    x(2) = x(2) + dt*v(2)
	    x(3) = x(3) + dt*v(3)
	    if (useDecay_) call Decay_Test(*555)    ! vor Aufschlag zerfallen?
	    destiny = code_wand
	    goto 555
	elseif (useDecay_) then			    ! zerfallen?
	    call Decay_Test(*555)
	endif

	if (destiny.EQ.code_reflektiert) then	    ! reflektiert
	    goto 555
c	elseif (destiny.NE.code_ok) then	    ! voruebergehend fuer Testzwecke
c	    write(*,*)
c	    write(*,*)'FO-1: ''destiny.NE.code_ok'' where it should  ->  STOP'
c	    write(*,*)'       destiny = ',destiny,': ',code_text(destiny)
c	    write(*,*)
c	    STOP
	elseif (Steps.GE.MaxStep) then		    ! Teilchen verloren
	    destiny = code_lost
	    goto 555
        endif
	if (reachedEndOfMap) then		    ! Folienebene erreicht
	    ! rechne in Triggerkoordinaten um (Folie == x=0)
	    if (alfaTD.NE.0) then
		x(2) = (xTD-x(1))*Sin_alfaTD + x(2)*Cos_alfaTD 
		help1=  v(1) ! zur Zwischenspeicherung
		v(1) =  help1*Cos_alfaTD + v(2)*Sin_alfaTD
		v(2) = -help1*Sin_alfaTD + v(2)*Cos_alfaTD
	    endif
	    x(1) = 0
	    goto 112
	endif

c verarbeite alle 'imonitor' Schritte die Koordinaten fuer GRAPHICS und DEBUG:

	if (GRAPHICS_.or.Debug_) then
	    zaehler = zaehler + 1
	    if (zaehler.EQ.iMonitor) then
		if (Graphics_) call Save_Graphics_Koord
		if (Debug_) call Output_Debug
		zaehler = 0
	    endif
	endif

	goto 5012	      ! naechster Integrationsschritt in FELD VOR FOLIE

c...............................................................................
	endif	! (if Beschl_Faktor_FO.EQ.0) then ...

c Einsprunglabel fuer Starts auf der Triggerfolie mit Startwinkelangaben
c im Kammersystem => transformiere Geschwindigkeitsvektor in das Triggersystem:

111	if (alfaTD.NE.0) then
	    help1=  v(1) ! zur Zwischenspeicherung
	    v(1) =  help1*Cos_alfaTD + v(2)*Sin_alfaTD
	    v(2) = -help1*Sin_alfaTD + v(2)*Cos_alfaTD
	endif


c - pruefe, ob das Projektil die Folie trifft:

112     radiusQuad = x(2)*x(2) + x(3)*x(3)
        If (radiusQuad.GT.radiusQuad_Folie) then
	    ! zurueckrechnen in das Kammersystem:
	    if (alfaTD.NE.0) then
		help1= x(1)
		x(1) = (help1-d_Folie_Achse)*Cos_alfaTD - 
     +				  x(2)*Sin_alfaTD + xTD
		x(2) = (help1-d_Folie_Achse)*Sin_alfaTD +
     +				  x(2)*Cos_alfaTD
		help1= v(1)
		v(1) =  help1*Cos_alfaTD - v(2)*Sin_alfaTD
		v(2) =  help1*Sin_alfaTD + v(2)*Cos_alfaTD
	    else
		x(1) =  x(1) + xTD - d_Folie_Achse
	    endif

	    destiny = code_vorbei
	    goto 555
	endif


c So verlangt, schreibe die aktuellen Trajektoriengroessen in das 'FoilFile':
c (hier ist sichergestellt, dass die Folie getroffen worden ist, Wechsel-
c wirkungen mit der Folie wurden aber noch nicht beruecksichtigt).
c HIER WERDEN 'X' UND 'V' IM TRIGGERSYSTEM ABGESPEICHERT!

	if (createFoilFile) then
	    ! falls die Flugzeit bis zur Triggerfolie verschmiert in das
	    ! NTupel aufgenommen werden soll:
	    if (smearS1Fo) then
		call Gauss_Verteilung(sigmaS1Fo,help4)
		S1FoOnly = t + help4
	    endif
	    if (NTP_stop) then
		Ekin=(v(1)*v(1)+v(2)*v(2)+v(3)*v(3))*Energie_Faktor
	    endif
	    call HFNT(NTP_write)
	    NTPalreadyWritten = .true.
	endif


c - Zeitpunkt bei Erreichen der Folie sichern:

113	S1Fo = t
	if (createNTP.AND.Fo_triggered) fill_NTP = .true.
	if (statNeeded(Nr_S1Fo)) call fill_statMem(S1Fo,Nr_S1Fo)



c - Speichern der Koordinaten fuer die Statistiken:

	if (statNeeded(Nr_y_Fo)) then
	    call fill_statMem( x(2),Nr_y_Fo)
	endif
	if (statNeeded(Nr_z_Fo)) then
	    call fill_statMem( x(3),Nr_z_Fo)
	endif
	if (statNeeded(Nr_r_Fo)) then 
	    radius = SQRT(x(2)*x(2) + x(3)*x(3))
	    call fill_statMem(radius,Nr_r_Fo)
	endif


c - speichere Auftreffort des Projektils fuer die Berechnung der Folienelektronen:

	if (generate_FE) then
	    x0FE(1) = x(1)
	    x0FE(2) = x(2)
	    x0FE(3) = x(3)
	endif


c - falls nur bis zur Folie gerechnet werden soll, beende hier die Integration:

	if (upToTDFoilOnly) then
	    ! zurueckrechnen in das Kammersystem:
	    if (alfaTD.NE.0) then
		help1= x(1)
		x(1) = (help1-d_Folie_Achse)*Cos_alfaTD - 
     +				  x(2)*Sin_alfaTD + xTD
		x(2) = (help1-d_Folie_Achse)*Sin_alfaTD +
     +				  x(2)*Cos_alfaTD
		help1= v(1)
		v(1) =  help1*Cos_alfaTD - v(2)*Sin_alfaTD
		v(2) =  help1*Sin_alfaTD + v(2)*Cos_alfaTD
	    else
		x(1) =  x(1) + xTD - d_Folie_Achse
	    endif
	    if (generate_FE) Gebiet = UpToExTD
	    goto 555
	endif


c - pruefe, ob das Projektil auf das Stuetzgitter aufschlaegt:

	if (testOnWireHit .AND. ran(seed).GT.TransTDFoil) then
	    destiny = code_Stuetzgitter
	    ! zurueckrechnen in das Kammersystem:
	    if (alfaTD.NE.0) then
		help1= x(1)
		x(1) = (help1-d_Folie_Achse)*Cos_alfaTD - 
     +				  x(2)*Sin_alfaTD + xTD
		x(2) = (help1-d_Folie_Achse)*Sin_alfaTD +
     +				  x(2)*Cos_alfaTD
		help1= v(1)
		v(1) =  help1*Cos_alfaTD - v(2)*Sin_alfaTD
		v(2) =  help1*Sin_alfaTD + v(2)*Cos_alfaTD
	    else
		x(1) =  x(1) + xTD - d_Folie_Achse
	    endif
	    goto 555
	endif


c - Energieverlust und Winkelaufstreuung:

	if (log_E_Verlust .OR. log_Aufstreu) then
	    if (Debug_) then
		Steps = Steps + 1
		call Output_Debug
	    endif
	    v_square = v(1)*v(1) + v(2)*v(2) + v(3)*v(3)
	    v_Betrag = SQRT(v_square)
	    Ekin = v_square * Energie_Faktor
	endif

c -- Energieverlust (vorerst nur Gaussverteilt):

	if (log_E_Verlust_defined.OR.log_Meyer_Gauss) then
	    ! Berechne Bahnwinkel relativ zur Folienebene fuer effektive Folien-
	    ! dicke:
	    alfa = atand(SQRT(v(2)*v(2)+v(3)*v(3))/v(1))
	endif

	if (log_E_Verlust) then
	    if (calculate_each) then
		call CALC_ELOSS_ICRU(Ekin,q,m,Thickness,E_Verlust)
	    else
		E_Verlust = mean_E_Verlust
	    endif
	    if (log_E_Verlust_defined) E_Verlust = E_Verlust / cosd(alfa)
	    if (debug_) write (lunLOG,*) ' mittlerer Energieverlust: ',E_Verlust

	    ! Now we have the mean energy loss. We still have to modify it
	    ! according to the distribution of energy losses, i.e.
	    ! E_Verlust  ->  E_Verlust + delta_E_Verlust:

	    delta_E_Verlust = 0.
	    if (log_E_Straggling_sigma) then
400		call Gauss_Verteilung(sigmaE,delta_E_Verlust)
		if (debug_) write (lunLOG,*) ' sigmaE,delta_E_Verlust: ',sigmaE,delta_E_Verlust
		if (E_Verlust+delta_E_Verlust.LT.0.) goto 400
	    elseif (log_E_Straggling_equal) then
410		delta_E_Verlust = lowerE + (upperE - lowerE)*ran(seed)
		if (E_Verlust+delta_E_Verlust.LT.0) goto 410
	    elseif (log_E_Straggling_Lindhard) then
		! Streuung in Abhaengigkeit von mittlerer Energie in Folie:
		call E_Straggling_Lindhard(Ekin-0.5*E_Verlust,m,sigmaE)
420		call Gauss_Verteilung(sigmaE,delta_E_Verlust)
		if (debug_) write (lunLOG,*) ' sigmaE,delta_E_Verlust: ',sigmaE,delta_E_Verlust
		if (E_Verlust+delta_E_Verlust.LT.0.) goto 420
	    elseif (log_E_Straggling_Yang) then
		! Streuung in Abhaengigkeit von mittlerer Energie in Folie!
		call E_Straggling_Yang(Ekin-0.5*E_Verlust,m,sigmaE)
430		call Gauss_Verteilung(sigmaE,delta_E_Verlust)
		if (debug_) write (lunLOG,*) ' sigmaE,delta_E_Verlust: ',sigmaE,delta_E_Verlust
		if (E_Verlust+delta_E_Verlust.LT.0.) goto 430
	    endif

	    if (E_Verlust+delta_E_Verlust.GE.Ekin) then
		destiny = code_stopped_in_foil
		goto 555
	    endif
	    E_Verlust = E_Verlust + delta_E_Verlust

	    ! help1 == Reduzierungsfaktor fuer Geschw.Betrag
	    help1 = sqrt( (Ekin - E_Verlust)/Ekin )
	    v(1) = help1 * v(1)
	    v(2) = help1 * v(2)
	    v(3) = help1 * v(3)
	    v_Betrag = help1 * v_Betrag
	    if (debug_) write (lunLOG,*) ' Energieverlust: ',E_Verlust
	endif

c -- Winkelaufstreuung (vorerst nur Gaussverteilt):

	if (log_aufstreu) then
	    if (log_Meyer_F_Function) then
		call throwMeyerAngle(thetaAufstreu)
	    else
		if (log_Meyer_Gauss) then
		    if (log_E_Verlust) Ekin = Ekin - .5 * E_Verlust	    ! mittlere Energie
		    effRedThick = Meyer_Faktor1 * Thickness / cosd(alfa)
		    call g_Functions(g1,g2,effRedThick)
		    sigmaAufstreu = Meyer_Faktor2 / Ekin * (g1 + Meyer_Faktor3*g2)
		    if (debug_) then
			write (lunLOG,*) ' effekt. red. Dicke: ',effRedThick
			write (lunLOG,*) ' Sigma(Streuwinkel): ',sigmaAufstreu
		    endif
		endif

		call Gauss_Verteilung_theta(sigmaAufstreu,thetaAufstreu)
	    endif

	    st0 = sind(thetaAufstreu)
	    ct0 = cosd(thetaAufstreu)
	    phiAufstreu = 360.*ran(seed)

	    v_xy  = SQRT(v(1)*v(1) + v(2)*v(2))	    ! v_xy  stets groesser 0
						    ! wegen v(1)>0

	    help1 = v(1)
	    help2 = v(2)
	    help3 = v_Betrag*st0*cosd(phiAufstreu)/v_xy
	    help4 = st0*sind(phiAufstreu)

	    v(1) = ct0*help1 - help3*help2 - help4*help1*v(3)/v_xy
	    v(2) = ct0*help2 + help3*help1 - help4*help2*v(3)/v_xy
	    v(3) = ct0*v(3)                + help4*v_xy
	    if (debug_) write (lunLOG,*) ' Aufstreuung: theta, phi =',
     +				  thetaAufstreu,phiAufstreu
	endif

	if (Debug_ .AND. (log_E_Verlust .OR. log_Aufstreu)) then
	    call Output_Debug
	endif


c - Neutralisierung in der Folie?

	if (log_neutralize) then
	    if (neutral_fract(q_).EQ.-1.0) then
		v_square = v(1)*v(1) + v(2)*v(2) + v(3)*v(3)
		Ekin = v_square * Energie_Faktor
		call chargeStateYields(Ekin,m,YieldPlus,YieldNeutral)
		YieldNeutral = 100. * YieldNeutral
	    else
		YieldNeutral = neutral_fract(q_)
	    endif
	    if (100.*ran(seed).LE.YieldNeutral) then
		q = 0.
		qInt = 0
		if (debug_) then
		    write (lunLOG,*) ' Teilchen wurde neutralisiert'
		endif
		nNeutral = nNeutral + 1
	    else
		nCharged = nCharged + 1
	    endif
	endif

c:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
c im TriggerDetektor:		  (homogene Felder)


13	Gebiet = upToExTD
	Steps = Steps + 1

c der Weg des Projektils innerhalb der Triggerkammer:

	call TRIGGER(m,q,t,x,v,Debug_,graphics_,n_return)


c Koordinatentransformation vom System des Triggerdetektors in das Kammersystem:
c ('d_Achse_Ground' == Abstand zwischen TD-Achse und 'Ground'-Gitter)

	if (alfaTD.NE.0) then
	    help1= x(1)
	    x(1) = (help1-d_Folie_Achse)*Cos_alfaTD - 
     +			      x(2)*Sin_alfaTD + xTD
	    x(2) = (help1-d_Folie_Achse)*Sin_alfaTD +
     +			      x(2)*Cos_alfaTD
	    help1= v(1)
	    v(1) =  help1*Cos_alfaTD - v(2)*Sin_alfaTD
	    v(2) =  help1*Sin_alfaTD + v(2)*Cos_alfaTD
	else
	    x(1) =  x(1) + xTD - d_Folie_Achse
	endif


c Was ist im TD mit dem Teilchen passiert?

	if (n_return.NE.0) then	    ! -->> das Projektil kam nicht bei GROUND an
	    if (n_return.GT.100 .AND. n_return.LE.120) then	  ! -> abgebrochen
		statTD(1,n_return-100) = statTD(1,n_return-100)+1 ! Grund notieren
		destiny = code_lostInTD				  ! im TD verloren
	    elseif (n_return.GT.0..AND.n_return.LE.75) then	  ! -> pfosten getroffen!
		pfostenHit(n_return,1) = pfostenHit(n_return,1)+1
		destiny = code_wand
	    elseif (n_return.EQ.-5) then			  ! -> im TD auf Gitterstab
		statTD(1,17) = statTD(1,17)+1			  !
		destiny = code_grid
	    elseif (n_return.EQ.-9) then			  ! -> NICHT im MCP3 registriert
		statTD(1,18) = statTD(1,18)+1			  !
		destiny = code_notRegInM3
	    elseif (n_return.EQ.-10) then			  ! -> im MCP3 registriert
		statTD(1,16) = statTD(1,16)+1			  ! '16' zaehlt MCP3-Treffer
		destiny = code_wand
	    endif
	    goto 555				    ! naechstes Projektil
	else			    ! -->> das Projektil kam bei GROUND an
	    statTD(1,15) = statTD(1,15)+1			  ! '15' zaehlt GROUND-Treffer
	endif

	if (useDecay_) call Decay_Test(*555)

c:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
c zwischen KOORDINATENWECHSEL BZW. GROUND-GITTER und Beginn der L3-Mappe:
c					      (feldfrei)

14	Gebiet = upToL3Map
        Steps = Steps + 1

        dt = (xEnterMap_L3 - x(1)) / V(1)    
	t  = t + dt
	x(1) = xEnterMap_L3
	x(2) = x(2) + v(2)*dt
	x(3) = x(3) + v(3)*dt

	radiusQuad = x(2)*x(2) + x(3)*x(3)
        if (radiusQuad.GT.radiusQuad_Rohr) then
	    help1 = v(2)*v(2)+v(3)*v(3)
	    help2 = x(2)*v(2)+x(3)*v(3)
	    dt = (SQRT(help2*help2-help1*(radiusQuad-radiusQuad_Rohr))-help2)
     +									/help1
	    t  = t + dt
	    x(1) = x(1) + dt*v(1)		 ! den Ort berechnen, an dem
	    x(2) = x(2) + dt*v(2)		 !   das Teilchen auf das Rohr
	    x(3) = x(3) + dt*v(3)		 !   aufschlaegt
	    if (useDecay_) call Decay_Test(*555) ! vor Aufschlag zerfallen?
	    destiny = code_wand
	    goto 555
	endif

	if (useDecay_) call Decay_Test(*555)
	if (Graphics_) call Save_Graphics_Koord
	if (Debug_)    call Output_Debug

	if (radiusQuad.GT.radiusQuad_L3) then	 ! Teilchen fliegt an L3 vorbei
	    destiny = code_vorbei
	    goto 555
	endif

c:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
c innerhalb L3:                           (inhom. Felder -> Integrationen)


15	Gebiet = upToExL3		    ! Gebietsnummer fuer L3 setzen

c Die Anweisungen dieses Abschnitts verlaufen analog zu denen
c von Linse 1. -> Fuer Kommentare siehe dort!

	if (Beschl_Faktor_L3.EQ.0. .OR. q.EQ.0) then ! q=0 -> in Folie neutralisiert
d	    dtmax_L3 = 0.    
d	    dtmin_L3 = 0.
	    dt = (xLeaveMap_L3 - x(1)) / v(1)	     ! Zeit bis zum Mappenende
	    x(1) = xLeaveMap_L3
	    x(2) = x(2) + v(2)*dt
	    x(3) = x(3) + v(3)*dt
	    t = t + dt
	    radiusQuad = x(2)*x(2) + x(3)*x(3)
      	    if (radiusQuad.GT.radiusQuad_L3) destiny = code_wand
	    goto 5115
	endif

	dt = .5/v(1)
	zaehler = 0

5015	call INTEGRATIONSSTEP_RUNGE_KUTTA_L3(dt)
d	if (NTP_steps) then
d	    if (dt.LT.dtmin_L3) then
d		dtmin_L3 = dt
d		x_dtmin_L3(1) = x(1)
d		x_dtmin_L3(2) = x(2)
d		x_dtmin_L3(3) = x(3)
d	    endif
d	    if (dt.GT.dtmax_L3) then
d		dtmax_L3 = dt
d		x_dtmax_L3(1) = x(1)
d		x_dtmax_L3(2) = x(2)
d		x_dtmax_L3(3) = x(3)
d	    endif
d	endif

5115	Steps = Steps + 1

	if (destiny.EQ.code_dtSmall) then	    ! n_dtsmall>maxBelowDtSmall
	    goto 555
	elseif (destiny.EQ.code_wand) then	    ! aufgeschlagen
	    radiusQuad = x(2)*x(2) + x(3)*x(3)	    ! -> den Ort berechnen, an
	    help1 = v(2)*v(2)+v(3)*v(3)		    !    dem das Teilchen auf-
	    help2 = x(2)*v(2)+x(3)*v(3) 	    !	 schlaegt
	    dt = (SQRT(help2*help2-help1*(radiusQuad-radiusQuad_L3))-help2)
     +									/help1
	    t  = t + dt
	    x(1) = x(1) + dt*v(1)
	    x(2) = x(2) + dt*v(2)
	    x(3) = x(3) + dt*v(3)
	    if (useDecay_) call Decay_Test(*555)    ! vor Aufschlag zerfallen?
	    goto 555
c	elseif (destiny.NE.code_ok) then	    ! voruebergehend fuer Testzwecke
c	    write(*,*)
c	    write(*,*)'L3-1: ''destiny.NE.code_ok'' where it should  ->  STOP'
c	    write(*,*)'       destiny = ',destiny,': ',code_text(destiny)
c	    write(*,*)
c	    STOP
	elseif (useDecay_) then			    ! zerfallen?
	    call Decay_Test(*555)
	endif

	if (x(1).LT.xEnterMap_L3) then
	    if (v(1).LT.0) then			    ! reflektiert?
		destiny = code_reflektiert
		goto 555
	    else				    ! darf nicht sein!
		write(*,*)
		write(*,*)' L3: x(1).LT.xEnterMap .AND. v(1).GE.0.  -> STOP'
		write(*,*)
		STOP
	    endif
	elseif (Steps.GE.MaxStep) then		    ! Teilchen verloren
	    destiny = code_lost
	    goto 555
	elseif (x(1).GE.xLeaveMap_L3) then	    ! Verlasse L3
	    dt = (xLeaveMap_L3 - x(1))/v(1)	    ! rechne zurueck auf exaktes
	    t = t + dt				    !	  Mappenende
	    x(1) = xLeaveMap_L3
	    x(2) = x(2) + dt*v(2)
	    x(3) = x(3) + dt*v(3)
	    if (Graphics_) call Save_Graphics_Koord
	    if (Debug_)    call Output_Debug
	    goto bis_MCP2_Mappe
c	elseif (destiny.NE.code_ok) then	    ! voruebergehend fuer Testzwecke
c	    write(*,*)
c	    write(*,*)'L3-2: ''destiny.NE.code_ok'' where it should  ->  STOP'
c	    write(*,*)'       destiny = ',destiny,': ',code_text(destiny)
c	    write(*,*)
c	    STOP
	endif

	if (GRAPHICS_.or.Debug_) then
	    zaehler = zaehler + 1
	    if (zaehler.EQ.iMonitor) then
		if (Graphics_) call Save_Graphics_Koord
		if (Debug_) call Output_Debug
		zaehler = 0
	    endif
	endif

      goto 5015	! naechster Integrationsschritt in gleicher Feldmappe


c:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
c zwischen L3-Mappe und MCP2-Mappe	      (feldfrei)


16	Gebiet = upToM2Map

	if (x(1).EQ.xEnterMap_M2) goto MCP2_Mappe
        Steps = Steps + 1

        dt = (xEnterMap_M2 - x(1)) / v(1)

	t  = t + dt
	x(1) = xEnterMap_M2
	x(2) = x(2) + v(2)*dt
	x(3) = x(3) + v(3)*dt

        radiusQuad = x(2)*x(2) + x(3)*x(3)
        if (radiusQuad.GT.radiusQuad_Rohr) then
	    help1 = v(2)*v(2)+v(3)*v(3)
	    help2 = x(2)*v(2)+x(3)*v(3)
	    dt = (SQRT(help2*help2-help1*(radiusQuad-radiusQuad_Rohr))-help2)
     +									/help1
	    t  = t + dt
	    x(1) = x(1) + dt*v(1)		 ! den Ort berechnen, an dem
	    x(2) = x(2) + dt*v(2)		 !   das Teilchen auf das Rohr
	    x(3) = x(3) + dt*v(3)		 !   aufschlaegt
	    if (useDecay_) call Decay_Test(*555) ! vor Aufschlag zerfallen?
	    destiny = code_wand
	    goto 555
	endif
	if (useDecay_) call Decay_Test(*555)
	if (Graphics_) call Save_Graphics_Koord
	if (Debug_)    call Output_Debug

c:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
c vor MCP2:	  			      (inhom. Felder -> Integrationen)

17	Gebiet = upToMCP2

c Beruecksichtige gegebenenfalls die Flugzeit in 'delta_L2', welches 'vor dem 
c MCP2' eingeschoben werden kann. Addiert wird vorerst nur die Flugzeit in
c dieser zusaetzlichen Flugstrecke. Korrekterweise muessten alle nachfolgenden
c Positionen um 'delta_L2' verschoben werden. Dies zu implementieren ist
c allerdings momentan aus Zeitgruenden nicht moeglich.

	dt = Delta_L2 / v(1)
	t  = t + dt


c Die Anweisungen dieses Abschnitts verlaufen analog zu denen
c von Linse 1. -> Fuer Kommentare siehe dort!

	if (Beschl_Faktor_M2.EQ.0. .OR. q.EQ.0) then ! q=0 -> in Folie neutralisiert
d	    dtmax_M2 = 0.    
d	    dtmin_M2 = 0.
	    if (xBlende.GT.x(1)) then
		dt = (xBlende - x(1)) / v(1)	      ! Zeit bis zur Blende
		x(1) = xBlende
		x(2) = x(2) + v(2)*dt
		x(3) = x(3) + v(3)*dt
		t = t + dt
      		radiusQuad = x(2)*x(2) + x(3)*x(3)
      		if (radiusQuad.GT.radiusQuad_Rohr) then
		    destiny = code_wand
		elseif (radiusQuad.GE.radiusQuad_Blende) then
		    if (useDecay_) call Decay_Test(*555)    ! vor Aufschlag zerfallen?
		    destiny = code_hitBlende
		    goto 555
		endif
	    endif
	    dt = (xMCP2 - x(1)) / v(1)		     ! Zeit bis MCP2
	    x(1) = xMCP2
	    x(2) = x(2) + v(2)*dt
	    x(3) = x(3) + v(3)*dt
	    t = t + dt
      	    radiusQuad = x(2)*x(2) + x(3)*x(3)
      	    if (radiusQuad.GT.radiusQuad_Rohr) destiny = code_wand
	    reachedEndOfMap = .true.
	    goto 5117
	endif

	dt = .5/v(1)

	reachedEndOfMap = .false.
	zaehler = 0
	if (xBlende.GT.0) check_Blende = .true.
	
5017	call INTEGRATIONSSTEP_RUNGE_KUTTA_M2(dt)
d	if (NTP_steps) then
d	    if (dt.LT.dtmin_M2) then
d		dtmin_M2 = dt
d		x_dtmin_M2(1) = x(1)
d		x_dtmin_M2(2) = x(2)
d		x_dtmin_M2(3) = x(3)
d	    endif
d	    if (dt.GT.dtmax_M2) then
d		dtmax_M2 = dt
d		x_dtmax_M2(1) = x(1)
d		x_dtmax_M2(2) = x(2)
d		x_dtmax_M2(3) = x(3)
d	    endif
d	endif

5117	Steps = Steps + 1

	if (destiny.EQ.code_dtSmall) then	    ! n_dtsmall>maxBelowDtSmall
	    goto 555
	elseif (check_Blende.AND.x(1).GE.xBlende) then
	    dt = (xBlende - x(1)) / v(1)	    ! zurueck zur Blende ...
	    x(1) = xBlende
	    x(2) = x(2) + v(2)*dt
	    x(3) = x(3) + v(3)*dt
	    t = t + dt
	    radiusQuad = x(2)*x(2) + x(3)*x(3)
	    if (radiusQuad.GE.radiusQuad_Blende) then
		destiny = code_hitBlende
		goto 555
	    endif
	    dt = -dt				    ! ... wieder zum aktuellen Ort
	    x(1) = xBlende + v(1)*dt
	    x(2) = x(2) + v(2)*dt
	    x(3) = x(3) + v(3)*dt
	    t = t + dt
	    check_Blende = .false.
	elseif (destiny.EQ.code_wand) then
	    radiusQuad = x(2)*x(2) + x(3)*x(3)	    ! -> den Ort berechnen, an
	    help1 = v(2)*v(2)+v(3)*v(3)		    !    dem das Teilchen auf-
	    help2 = x(2)*v(2)+x(3)*v(3) 	    !	 schlaegt
	    dt = (SQRT(help2*help2-help1*(radiusQuad-radiusQuad_Rohr))-help2)
     +									/help1
	    t  = t + dt
	    x(1) = x(1) + dt*v(1)
	    x(2) = x(2) + dt*v(2)
	    x(3) = x(3) + dt*v(3)
	    if (useDecay_) call Decay_Test(*555)    ! vor Aufschlag zerfallen?
	    goto 555
	elseif (useDecay_) then			    ! zerfallen?
	    call Decay_Test(*555)
	endif

	if (destiny.EQ.code_reflektiert) then	    ! reflektiert
	    goto 555
	elseif (reachedEndOfMap) then		    ! MCP2-Ebene erreicht
c	    if (destiny.NE.code_ok) then	    ! voruebergehend fuer Testzwecke
c		write(*,*)
c		write(*,*)'M2 ''destiny.NE.code_ok'' where it should  ->  STOP'
c		write(*,*)'    destiny = ',destiny,': ',code_text(destiny)
c		write(*,*)
c		STOP
c	    endif
	    if (createNTP.AND.xM2_triggered) fill_NTP = .true.
	    S1xM2 = t
	    if (statNeeded(Nr_S1xM2))call fill_statMem(S1xM2,Nr_S1xM2)
	    radiusQuad = x(2)*x(2) + x(3)*x(3)
	    radius = SQRT(radiusQuad)
	    if (statNeeded(Nr_y_xM2)) call fill_statMem( x(2),Nr_y_xM2)
	    if (statNeeded(Nr_z_xM2)) call fill_statMem( x(3),Nr_z_xM2)
	    if (statNeeded(Nr_r_xM2)) call fill_statMem(radius,Nr_r_xM2)
	    if (radiusQuad.LE.radiusQuad_MCP2active) then
		S1M2 = t		    ! Zeiten werden sowohl fuer Statistiken
		FoM2 = t - S1Fo		    !     als auch fuer NTupel benoetigt
		if (statNeeded(Nr_S1M2)) call fill_statMem(S1M2,Nr_S1M2)
		if (statNeeded(Nr_FoM2)) call fill_statMem(FoM2,Nr_FoM2)
		if (createNTP.AND.M2_triggered) fill_NTP = .true.
		if (statNeeded(Nr_y_M2)) call fill_statMem( x(2),Nr_y_M2)
		if (statNeeded(Nr_z_M2)) call fill_statMem( x(3),Nr_z_M2)
		if (statNeeded(Nr_r_M2)) call fill_statMem(radius,Nr_r_M2)
	    else			    ! am MCP2 vorbei
		if (radiusQuad.LE.radiusQuad_MCP2) then
		    destiny = code_hitMCP2inactive
		else
		    destiny = code_vorbei
		    if (Graphics_) then	    ! Damit diese Trajektorie 40mm ueber die
			nKoord = nKoord + 1 !   MCP2-Ebene hinausgezeichnet wird
			dt = 40./v(1)
			t = t + dt
			xKoord(nKoord) = x(1)+40.
			yKoord(nKoord) = x(2)+v(2)*dt
			zKoord(nKoord) = x(3)+v(3)*dt
			goto 556
		    endif
		endif
	    endif

	    goto 555
	elseif (Steps.GE.MaxStep) then		    ! Teilchen verloren
	    destiny = code_lost
	    goto 555
	endif

	if (GRAPHICS_.or.Debug_) then
	    zaehler = zaehler + 1
	    if (zaehler.EQ.iMonitor) then
		if (Graphics_) call Save_Graphics_Koord
		if (Debug_) call Output_Debug
		zaehler = 0
	    endif
	endif

      goto 5017	      ! naechster Integrationsschritt im Feld vor MCP2


czzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzz
c 	HIER IST DER PROGRAMMKODE FUER DIE TRAJEKTORIENBERECHNUNG
c	DER PROJEKTILE BEENDET!
czzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzz

555	if (Graphics_) call Save_Graphics_Koord
556	if (Debug_) call Output_Debug


c Gib Trajektorie in Graphikfenster aus:

	if (Graphics_) then
	    if (Gebiet.LE.upToChKoord) then	! Bahnberechnung wurde vor
		call plot_horizontal         	! Koordinatenwechsel abgebrochen
		if (schnitt_p.eq.1) call schnitt
	    else
		call plot_vertikal         
		if (schnitt_p.eq.2) call schnitt
	    endif
	    nKoord = 0
	endif


c Pruefe, ob Teilchen reflektiert wurde:

	if ((Gebiet.EQ.upToExL1 .OR. Gebiet.EQ.upToEnTD .OR.
     +	     Gebiet.EQ.upToExL3 .OR. Gebiet.EQ.upToMCP2) .AND.
     +						    v(1).LE.0.) then
	    destiny = code_reflektiert
	endif


c Zaehle mit, bei wie vielen Teilchen trotz dt<dtsmall der tolerierte Fehler
c ueberschritten wurde. Notiere auch, wieoft dies beim gleichen Teilchen maximal
c vorkam:

	if (n_dtsmall.GT.0) then
	    dtsmall_counter = dtsmall_counter + 1
	    if (n_dtsmall.gt.n_dtsmall_Max) then
		n_dtsmall_Max = n_dtsmall
	    endif
	endif


c Zaehle mit, wie viele Trajektorien wegen steps>MaxStep abgebrochen werden:

	if (destiny.EQ.code_lostInTD) then
	    lostInTD_counter = lostInTD_counter + 1
	elseif (destiny.EQ.code_lost) then
	    lost_counter = lost_counter + 1
	endif


c bei DEBUG: Ausgabe des Teilchenschicksals und des aktuellen Gebiets:

	if (debug_) then
	    indx = index(code_text(destiny),':')
	    if (indx.EQ.0) then
		write(lun(1),*) 'destiny : ',code_text(destiny)
	    else
		write(lun(1),*) 'destiny : ',code_text(destiny)(1:indx-1)
	    endif
	    indx = index(Gebiet_text(Gebiet),':')
	    if (indx.EQ.0) then
		write(lun(1),*) 'Gebiet  : ',Gebiet_text(Gebiet)
	    else
		write(lun(1),*) 'Gebiet  : ',Gebiet_text(Gebiet)(1:indx-1)
	    endif
	endif


czzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzz
c	HIER STARTEN DIE FOLIENELEKTRONEN
czzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzz

	if (generate_FE) then				! ~~~ 1: if ~~~~~~~~~~~~
	if (Gebiet.GE.UpToExTD) then			! ~~~ 2: if ~~~~~~~~~~~~

c sekundaerelektronen
	nFE = int(4.*ran(seed))+2		    ! Anzahl wuerfeln: [2,5]
	tFE_min = 0.				    ! tFE_min: kuerzeste FE-Flugzeit:
						    !    bekam noch keinen Wert zugewiesen

c - die Laufzeiten der Folienelektronen:
c
c----------------------------------------
c
c-TP-10/2000    reset of end positions of electrons
c
	do k = 1, 3
	    xFE_MCP(k) = 0.
	    yFE_MCP(k) = 0.
	    zFE_MCP(k) = 0.
	enddo
c
c----------------------------------------
c

	do 450, k = 1, nFE

	xFE(1) = x0FE(1)
	xFE(2) = x0FE(2)
	xFE(3) = x0FE(3)

	E0FE = 0.003*ran(seed)			    ! Start-Energie wuerfeln: [0,3) eV
	v_Betrag = sqrt(2.*E0FE/511.015)*c	    ! Startgeschwindigkeit 
	call Lambert_Verteilung(1.,ct0,st0)         ! Startwinkel wuerfeln
	f0  = 360.*ran(seed)
	cf0 = cosd(f0)
	sf0 = sind(f0)
	vFE(1) = v_Betrag * ct0			    ! Geschwindigkeitskomponenten
	vFE(2) = v_Betrag * st0*cf0
	vFE(3) = v_Betrag * st0*sf0

	tFE = 0.

	nKoord = 0
	start_nr(2) = start_nr(2) + 1		    ! (2): FE
	call TRIGGER(511.015,-1.,tFE,xFE,vFE,DEBUG_FE.AND.Debug_,
     +						      plot_FE,n_return)
	if (plot_FE) call plot_vertikal

	if (n_return.NE.-10) then
C - das FE kam nicht am MCP3 an ->
	    if (n_return.GT.100 .AND. n_return.LE.120) then	  ! -> abgebrochen
		statTD(2,n_return-100) = statTD(2,n_return-100)+1 ! Grund notieren
	    elseif (n_return.GT.0 .AND. n_return.LE.75) then	  ! -> pfosten getroffen!
		pfostenHit(n_return,2) = pfostenHit(n_return,2)+1
	    elseif (n_return.EQ.0) then		    ! -> GROUND getroffen
		statTD(2,15) = statTD(2,15)+1	    ! '15' zaehlt GROUND-Treffer
	    elseif (n_return.EQ.-5) then	    ! -> im TD auf Gitterstab
		statTD(2,17) = statTD(2,17)+1
	    elseif (n_return.EQ.-9) then	    ! -> NICHT im MCP3 registriert
		statTD(2,18) = statTD(2,18)+1
	    endif
	    tFE_(k) = -1			    ! -1: FE kam nicht bei MCP3 an
c
c---------------------------------------
c
c-TP-10/2000
c
	    xFE_MCP(k) = -100.
	    yFE_MCP(k) = -100.
	    zFE_MCP(k) = -100.
c
c---------------------------------------
c
	    goto 450 				    ! naechstes FE

	endif

c - das FE kam beim MCP3 an ->

	statTD(2,16) = statTD(2,16)+1		    ! '16' zaehlt MCP3-Treffer
	tFE_(k)=int(1000.*tFE)		    	    ! tFE in ps. (braucht als Integer
						    !    weniger Speicherplatz)
c
c---------------------------------------
c
c-TP-10/2000
c
            xFE_MCP(k) = xFE(1)
            yFE_MCP(k) = xFE(2)
            zFE_MCP(k) = xFE(3)
c
c---------------------------------------
c



c fuer die Statistik: die Flugzeiten saemtlicher das MCP3 erreichender FE abspeichern:

	if (statNeeded(Nr_t_FE)) call fill_statMem(tFE,Nr_t_FE)


c kuerzeste Elektronenflugzeit fuer das aktuelle Projektilteilchen notieren:

	if (tFE_min.EQ.0. .OR. tFE.LT.tFE_min) tFE_min = tFE


450	continue    ! -> naechstes Folienelektron


c die Flugzeiten der nicht gestartenen Folienelektronen (nFE+1 bis 5) auf 0. setzen:

	do while (nFE.LT.5)
	    nFE = nFE + 1
	    tFE_(nFE) = 0.
	enddo


c Jetzt sind die Folienelektronen durchgelaufen.

c Fuelle Statistiken fuer die  'gemessenen' Teilchenflugzeiten (mit Beruecksichti-
c gung der Flugzeiten der Folienelektronen). M3M2 aber nur, wenn MCP2 auch
c getroffen wurde:

	if (tFE_min.NE.0.) then
	    S1M3 = S1Fo + tFE_min		    ! +, da Stop verzoegert
	    if (statNeeded(Nr_S1M3)) then
		call fill_statMem(S1M3,Nr_S1M3)
	    endif
	    if (destiny.EQ.code_ok) then
		M3M2 = FoM2 - tFE_min		    ! -, da Start verzoegert
		if (statNeeded(Nr_M3M2)) call fill_statMem(M3M2,Nr_M3M2)
	    endif
	endif

	else						! ~~~ 2: else ~~~~~~~~~~

	do k= 1, 5
	    tFE_(k) = 0.	    ! nicht gestartet
	enddo

	endif						! ~~~ 2: endif ~~~~~~~~~
	endif						! ~~~ 1: endif~~~~~~~~~~

czzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzz
c	ES FOLGEN DATENAUSGABE, SPRUNG IN NEUE SCHLEIFE UND PROGRAMMENDE
czzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzz

c trage das NTupel ein:

c So verlangt, schreibe die aktuellen Trajektoriengroessen in das NTupel:
c (falls bei 'createFoilFile' 'NTPalreadyWritten' nicht gesetzt ist schied
c dieses Teilchen schon vor der Triggerfolie aus. Ist es dagegen gesetzt wurden
c die Trajektoriendaten mit dem Erreichen der Triggerfolie abgespeichert um sie
c in den im Triggersystem gueltigen Werten zu haben):

	if (fill_NTP .OR. createFoilFile) then
	    if (NTPalreadyWritten) then
		NTPalreadyWritten = .false.
	    else
		if (NTP_stop) then
		    Ekin=(v(1)*v(1)+v(2)*v(2)+v(3)*v(3))*Energie_Faktor
		endif
		if (smearS1Fo .AND. .NOT.use_MUTRACK) then
		    if (s1fo.NE.0) then
			call Gauss_Verteilung(sigmaS1Fo,help4)
			S1FoOnly = S1Fo + help4
		    else
			S1FoOnly = 0.
		    endif
		endif
		FoM2Only = FoM2
		call HFNT(NTP_write)
	    endif
	endif


c Nimm das Schicksal des Teilchens in den zugehoerigen Statistikspeicher auf:

	if (destiny.GT.0) destiny = destiny + (Gebiet-1)*highest_code_Nr
        statDestiny(destiny) = statDestiny(destiny) + 1

	if (destiny.EQ.code_ok) okStepsCounter = okStepsCounter + steps


c -> das naechste Projektil kann kommen
100 	continue


c - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 

c Jetzt sind alle Projektile dieser Schleife abgearbeitet!

c Mittlere Anzahl an Integrationsschritten fuer Trajektorien mit destiny =
c 'code_ok' ausgeben:

	if (statDestiny(code_ok).NE.0) then
	    write(*,'(6x,A,F7.2)')'Mittlere Anzahl an Integrationsschritten bis zum Ziel: ',
     +		  real(okStepsCounter)/real(statDestiny(code_ok))
	endif

c das Summary ausgeben und die Werte in die Tabellen schreiben:
c Falls nur ein Teilchenstart pro Schleife erfolgt, werte die Statistiken
c erst nach der letzten Schleife aus:

	NotLastLoop = .NOT.(SchleifenNr.EQ.SchleifenZahl)
	flag_ok = .NOT.(OneStartPerLoop.AND.NotLastLoop)

	if (flag_ok) then
	    call eval_statistics
	    if (n_outWhere.GT.0 .OR. smallLogFile) call Summary
	    if (createTabellen .or. createPhysTab) call output_tabellen
	endif


c das PostScript-file erstellen:

c Wird pro Schleife nur ein Teilchen gestartet ('OneStartPerLoop'; d.h. kein
c oder genau ein 'Zufallsstart'), so trage alle Trajektorien in die gleiche
c Graphik ein. Das Postskript braucht dann also erst bei der letzten Schleife
c erstellt zu werden:

	if (GRAPHICS .AND. flag_ok) then
	    call schnitt_plot	    ! Ausgabe der Graphik der Schnittebene

	    if (n_postSkript.LE.0) then
		goto 620
	    elseif (n_postSkript.EQ.1) then
		if (n_outWhere.LT.2) then
		    write(*,*)'.....................................'//      
     +		    '.........................................'
		    write(*,'(2X,A18,I3,A,I3)')'Schleife ',
     +		    SchleifenNr,' von ',SchleifenZahl
		endif
		write(*,1003)'(P) Ps-file erstellen',
     +			    '(R) Restliche ps-files erstellen'
		write(*,1003)'(N) ps-file Nicht erstellen',
     +			    '(K) Keine ps-files mehr erstellen'
		write(*,1003)'(G) Graphikausgabe beenden',
     +			    '(A) programm Abbrechen'
1003	format(T6,A,T40,A)

		helpChar = 'n'
600		write(*,1004)'    [RETURN] = (N)  ->  '
1004	format($,x,A)
		read(*,'(A)') helpChar

		do i = 1,7  ! bis zu sechs blanks werden akzeptiert
		    ant = helpChar(i:i)
		    if (ant.NE.' ') goto 610
		enddo
		ant = 'N'

610		write(*,*)'==========================='//
     +	  '====================================================='

		call str$upcase(ant,ant)
		if (ant.EQ.'N') then
		    goto 620
		elseif (ant.EQ.'R') then
			n_postSkript = 2
		elseif (ant.EQ.'K') then
		    n_postSkript = 0
		    goto 620
		elseif (ant.EQ.'G') then
		    call HPLEND
		    GRAPHICS = .false.
		    goto 200
		elseif (ant.EQ.'A') then
		    call HPLEND
		    call TERMINATE_OUTPUT
		    STOP
		elseif (ant.NE.'P') then
		    goto 600
		endif
	    endif

	    write (helpChar(1:7),'(''_'',I6)') SchleifenNr
	    if (filename.NE.' ') then
		call MAKE_PS(filename//helpChar)
	    else
		call MAKE_PS('MUTRACK'//helpChar)
	    endif


620	continue

 	    CALL IZPICT ('CHAM_1','S')	! LOESCHEN DER BILDER IM PAWC-COMMON-BLOCK
 	    CALL IZPICT ('CHAM_2','S')
	    CALL IZPICT ('HISTO','S')
	    CALL IZPICT ('TEXT','S')	

	    call iclrwk (1,flag_ok)	! CLEAREN DER WORKSTATIONS
	    call iclrwk (3,flag_ok)
	    call iclrwk (4,flag_ok)
	    call iclrwk (5,flag_ok)

	    CALL HRESET (50,' ')	! RESETTEN DES HISTOGRAMMS

	endif	

c -> das gleiche von vorne mit neuen Settings (d.h. neue Schleife)

200	continue
c - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 


c Jetzt sind alle Schleifen abgearbeitet -> fertigmachen zum Programmende:

c - HIGZ-Graphikbibliothek schliessen:

	if (Graphics) call HPLEND

c - HBOOK-Datei schliessen:

	if (.NOT.fromScratch) then
	    if (use_ACCEL) then
		call HREND('ACCEL')
	    elseif (Use_MUTRACK) then
		call HREND('MUread')
	    endif
	    close (lunRead)
	endif
 
	call TERMINATE_OUTPUT


	END


C===============================================================================


	OPTIONS /EXTEND_SOURCE

	SUBROUTINE Lambert_Verteilung(n_Lambert,cos_theta,sin_theta)
c	============================================================

	IMPLICIT NONE

	real	cos_theta,sin_theta

	real	n_Lambert			! Ordnung der Lambert-Verteilung	
	real	randomVar	
	integer seed
	common /seed/ seed

	randomVar = ran(seed)

	if (n_Lambert.EQ.0.) then
	    cos_theta = (1.-randomVar)
	    sin_theta = sqrt(1.-cos_theta*cos_theta)
	elseif (n_Lambert.EQ.1.) then
	    cos_theta = sqrt(1.-randomVar)
	    sin_theta = sqrt(randomVar)
	else
	    cos_theta = (1.-randomVar)**(1./(n_Lambert + 1))
	    sin_theta = sqrt(1.-cos_theta*cos_theta)
	endif


	END


c===============================================================================


	OPTIONS /EXTEND_SOURCE

	SUBROUTINE Gauss_Verteilung(sigma,wert)
c	=======================================

	IMPLICIT NONE

	real	sigma	    ! Breite der Gaussverteilung
	real	wert	    ! gewuerfelte Returnvariable
	real	radius,phi

	integer seed
	common /seed/ seed

	real zwoPi
	parameter (zwoPi = 2.*3.1415927)

c Da die eindimensionale Gaussfunktion nicht integrierbar ist, wird erst
c ein Punkt in der Ebene mit der entsprechenden zweidimensionalen Gaussfunktion
c gewuerfelt. Von diesem Punkt wird dann die x-Komponente zurueckgegeben, die
c eindimensional Gaussverteilt ist:

	radius = sigma*Sqrt(-2.*log(1.-ran(seed)))
	phi    = zwoPi * ran(seed)
	wert   = radius * cos(phi)


	END


c===============================================================================


	OPTIONS /EXTEND_SOURCE

	SUBROUTINE Gauss_Verteilung_theta(sigma,theta)
c	==============================================

	IMPLICIT NONE

	real	sigma,theta
	real	radius,phi,ratio

	integer i, seed
	common /seed/ seed

c Man beachte, dass hier Winkel gewuerfelt werden! D.h., dass die Variable
c 'radius' einen Radius in einer 2dimensionalen 'Winkel'-Ebene darstellt.
c Es wird angenommen, dass sigma in degree angegeben wird (daher die sind()-
c Funktion in der Zuweisung fuer 'ratio' anstelle der sin()-Fkt.).

	i = 1

1	radius = sigma*Sqrt(-2.*log(1.-ran(seed)))
	phi    = 360.*ran(seed)
	theta  = abs(radius * cosd(phi))
	! nur theta zwischen 0 und 90 deg sollen eine Chance haben:
	if (theta.GT.90) then
	    i = i + 1
	    if (i.LE.10000) then
		goto 1
	    else
		write(*,*)
		write(*,*) 'SUBROUTINE Gauss_Verteilung_theta:'
		write(*,*) '  Nach 10000 Versuchen noch keinen Winkel < 90 degree gewuerfelt.'
		write(*,*) '  Vorgegebenes Sigma der Winkelverteilung: ',sigma
		write(*,*)
		STOP
	    endif
	endif

c Zitat aus TP's 'TESTSEED.FOR', aus welchem diese Routine abgeschrieben
c ist:
c
c	Now we habe a GAUSSIAN, but we need for multiple scattering
c	GAUSSIAN*SIN(x) =: g(x). This is not integrateable analytically, but
c	we can choose the VON NEUMANN REJECTION to get what we want.
c	As auxiliary function we choose the GAUSSIAN =: f(x), because it
c	satisfies g(x) <= f(x) for all x.
c	We must build the ratio g(x)/f(x) = sin(x) and compare it to
c	another random number:

	ratio  = sind(theta)
	if (ran(seed).GT.ratio) goto 1	! Verteilung zurechtbiegen


	END


c===============================================================================


	OPTIONS /EXTEND_SOURCE

	SUBROUTINE G_Functions(G1,G2,tau)
c	=================================

c Diese Routine gibt in Abhaengigkeit von der reduzierten Dicke 'tau'
c Funktionswerte fuer g1 und g2 zurueck. g1 und g2 sind dabei die von
c Meyer angegebenen tabellierten Funktionen fuer die Berechnung von Halbwerts-
c breiten von Streuwinkelverteilungen. (L.Meyer, phys.stat.sol. (b) 44, 253
c (1971))

	IMPLICIT NONE

	real tau,g1,g2
	real tau_(26),g1_(26),g2_(26)
	real help

	integer i

	DATA tau_ /0.2, 0.4, 0.6, 0.8, 1.0, 1.2, 1.4, 1.6, 1.8, 2.0,
     +	         2.5, 3.0, 3.5, 4.0, 4.5, 5.0, 6.0, 7.0, 8.0, 9.0,
     +			     10.0, 12.0, 14.0, 16.0, 18.0, 20.0 /

	DATA g1_  /0.050,0.115,0.183,0.245,0.305,0.363,0.419,0.473,0.525,0.575,
     +	         0.689,0.799,0.905,1.010,1.100,1.190,1.370,1.540,1.700,1.850,
     +			     1.990,2.270,2.540,2.800,3.050,3.290 /
	DATA g2_  / 0.00,1.25,0.91,0.79,0.73,0.69,0.65,0.63,0.61,0.59,
     +	          0.56,0.53,0.50,0.47,0.45,0.43,0.40,0.37,0.34,0.32,
     +			      0.30,0.26,0.22,0.18,0.15,0.13 /

	if (tau.LT.tau_(1)) then
	    write(*,*)
	    write(*,*)'SUBROUTINE G_Functions:'
	    write(*,*)'  Fehler bei Berechnung der g-Funktionen fuer Winkelaufstreuung:'
	    write(*,*)'  aktuelles tau ist kleiner als kleinster Tabellenwert:'
	    write(*,*)'  tau     = ',tau
	    write(*,*)'  tau_(1) = ',tau_(1)
	    write(*,*)
	    STOP
	endif

	i = 1

10	i = i + 1
	if (i.EQ.27) then
	    write(*,*)
	    write(*,*)'SUBROUTINE G_Functions:'
	    write(*,*)'  Fehler bei Berechnung der g-Funktionen fuer Winkelaufstreuung:'
	    write(*,*)'  aktuelles tau ist groesser als groesster Tabellenwert:'
	    write(*,*)'  tau      = ',tau
	    write(*,*)'  tau_(26) = ',tau_(26)
	    write(*,*)
	    STOP
	elseif (tau.gt.tau_(i)) then
	    goto 10
	endif


c lineare Interpolation zwischen Tabellenwerten:

	help = (tau-tau_(i-1))/(tau_(i)-tau_(i-1))

	g1 = g1_(i-1) + help*(g1_(i)-g1_(i-1))
	g2 = g2_(i-1) + help*(g2_(i)-g2_(i-1))


	END


c===============================================================================

	options /extend_source

	subroutine Get_F_Function_Meyer(tau,Ekin)
c	=========================================

	implicit none

	real tau
	real Ekin

	real thetaSchlange,thetaSchlangeMax
	real theta,thetaMax,thetaStep
	real f1,f2,F


c------------------------------------
c - Parameter:

	real Z1, Z2	    ! die atomaren Nummern von Projektil und Target
c	real a0		    ! Bohrscher Radius in cm
	real screeningPar   ! Screeningparameter 'a' in cm fuer Teilchen der
			    ! Kernladungszahl Z1=1 in Kohlenstoff (Z2 = 6)
			    ! bei Streichung von Z1 (vgl. Referenz, S. 268)

	real r0Meyer	    ! r0(C) berechnet aus dem screeningParameter 'a'
			    ! und dem ebenfalls bei Meyer angegebenem
			    ! Verhaeltnis a/r0=0.26 (vgl. Referenz, S. 263 oben)
	real eSquare	    ! elektrische Ladung zum Quadrat in keV*cm

	real Pi		    ! die Kreiszahl

c	parameter (a0 = 5.29E-9)
	parameter (Z1 = 1,  Z2 = 6,  ScreeningPar = 2.5764E-9)
	parameter (r0Meyer = 9.909E-9,  eSquare = 1.44E-10)
	parameter (Pi = 3.141592654)

	real Meyer_Faktor3
	real Meyer_Faktor4
	real zzz	    ! 'Hilfsparameter'
	real Meyer_Faktor5

	parameter (Meyer_faktor3 = (screeningPar/r0Meyer) * (screeningPar/r0Meyer))
	parameter (Meyer_faktor4 = screeningPar / (2.*Z1*Z2*eSquare)  * Pi/180.)
	parameter (zzz = screeningPar / (2.*Z1*Z2*eSquare))
	parameter (Meyer_faktor5 = zzz*zzz / (8*Pi*Pi))

c------------------------------------

	integer nBin,nBinMax
	parameter (nBinMax=201)
	real value(0:nBinMax)  /0.,nBinMax*0./
	real area(nBinMax)     /   nBinMax*0./
	real integ(0:nBinMax)  /0.,nBinMax*0./
	common /MeyerTable/ value,area,integ,thetaStep,nBin

	integer i
	real rhelp

        integer   HB_memsize
        parameter(HB_memsize=500000)
        real      memory(HB_memsize)
        COMMON /PAWC/ memory


c nur noch fuer Testzwecke:

	real fValues(203)
	real fValuesFolded(203)

	integer idh
	parameter (idh = 50)

	INCLUDE 'mutrack$sourcedirectory:COM_DIRS.INC'
	character filename*20           ! Name der Ausgabe-Dateien
	COMMON /filename/ filename

c-------------------------------------------------------------------------------

c Festlegen des maximalen Theta-Wertes sowie der Schrittweite:

	if (tau.LT.0.2) then
	    write(*,*) 'Subroutine ''Get_F_Function_Meyer'':'
	    write(*,*) 'Effektive Dicke ist kleiner als 0.2 => kann ich nicht ... => STOP'
	    call exit
	elseif (tau.LE.2.) then
	    ! => Tabelle A
	    thetaSchlangeMax = 4.0
	elseif (tau.LE.8.) then
	    ! => Tabelle B
	    thetaSchlangeMax = 7.0
	elseif (tau.LE.20.) then
	    ! => Tabelle C
	    thetaSchlangeMax = 20.0
	else
	    write(*,*) 'Subroutine ''Get_F_Function_Meyer'':'
	    write(*,*) 'Effektive Dicke ist groesser als 20 => kann ich nicht ... => STOP'
	    call exit
	endif

	thetaMax = thetaSchlangeMax / Meyer_Faktor4 / Ekin
	if (thetaMax.GT.50) then
	    thetaStep = .5
	elseif (thetaMax.GT.25) then
	    thetaStep = .25
	elseif (thetaMax.GT.12.5) then
	    thetaStep = .125
	else
	    thetaStep = .0625
	endif


c Tabelle der F-Werte erstellen:

	nBin = 0
	do theta = thetaStep, thetaMax, thetaStep

	    ! Berechne aus theta das 'reduzierte' thetaSchlange (dabei gleich
	    ! noch von degree bei theta in Radiant bei thetaSchlange umrechnen):

	    thetaSchlange = Meyer_faktor4 * Ekin * theta 

	    ! Auslesen der Tabellenwerte fuer die f-Funktionen:

	    call F_Functions_Meyer(tau,thetaSchlange,f1,f2)
	    if (thetaSchlange.EQ.-1) then
		! wir sind jenseits von thetaSchlangeMax
		goto 10
	    endif

	    ! Berechnen der Streuintensitaet:
	    F = Meyer_faktor5 * Ekin*Ekin * (f1 - Meyer_faktor3*f2)

	    nBin = nBin + 1
	    if (nBin.GT.nBinMax) then
		write(*,*) 'nBin > nBinMax  =>  EXIT'
		call exit
	    endif
	    value(nBin) = sind(theta)*F

	    fValues(nBin+1) = F			     ! fuer Testzwecke
	    fValuesFolded(nBin+1) = sind(theta)*F    ! fuer Testzwecke

	enddo


c Berechnen der Flaecheninhalte der einzelnen Kanaele sowie der Integrale:

10	do i = 1, nBin
	    area(i)  = (value(i)+value(i-1))/2. * thetaStep
	    integ(i) = integ(i-1) + area(i)
	enddo


c Normiere totale Flaeche auf 1:

	rHelp = integ(nBin)
	do i = 1, nBin
	    value(i) = value(i) / rHelp
	    area(i)  = area(i)  / rHelp
	    integ(i) = integ(i) / rHelp
	enddo


c vorerst noch: gib Tabelle in Datei und Histogrammfile aus:

	! Berechne die Werte fuer theta=0:

	call F_Functions_Meyer(tau,0.,f1,f2)
	F = Meyer_faktor5 * Ekin*Ekin * (f1 - Meyer_faktor3*f2)
	fValues(1)       = F
	fValuesFolded(1) = 0.

	! Gib die Werte in das Tabellenfile aus:

c	theta = 0.
c	open (10,file=outDir//':'//filename//'.TAB',status='NEW')
c	do i = 1, nBin+1
c	    write(10,*) theta, fValues(i), fValuesFolded(i)
c	    theta = theta + thetaStep
c	enddo	
c	close (10)


	! Buchen und Fuellen der Histogramme:

	call HBOOK1(idh,'F',nBin+1,-0.5*thetaStep,(real(nBin)+0.5)*thetaStep,0.)
	call HPAK(idh,fValues)
	call HRPUT(idh,outDir//':'//filename//'.RZ','N')
	call HDELET(idh)

	call HBOOK1(idh+1,'F*sin([q])',nBin+1,-0.5*thetaStep,(real(nBin)+0.5)*thetaStep,0.)
	call HPAK(idh+1,fValuesFolded)
	call HRPUT(idh+1,outDir//':'//filename//'.RZ','U')
	call HDELET(idh+1)


	END


c===============================================================================

	options /extend_source

	subroutine throwMeyerAngle (theta)
c	==================================

	implicit none

	real lowerbound,y1,y2,f,root,radiant,fraction
	integer bin,nBin
	integer nBinMax
	parameter (nBinMax=201)

	real theta,thetaStep
	real value(0:nBinMax)  /0.,nBinMax*0./
	real area(nBinMax)     /   nBinMax*0./
	real integ(0:nBinMax)  /0.,nBinMax*0./
	common /MeyerTable/ value,area,integ,thetaStep,nBin

	real rhelp

	real random
	integer seed
	common /seed/ seed


c bin: Nummer des Bins, innerhalb dessen das Integral den Wert von 
c random erreicht oder ueberschreitet:

	random = ran(seed)

	bin = 1
	do while (random.GT.integ(bin))
	    bin = bin + 1
	    if (bin.GT.nBin) then
		write(*,*) 'error 1'
		call exit
	    endif
	enddo

	fraction = (random-integ(bin-1)) / (integ(bin)-integ(bin-1))
	y1 = value(bin-1)
	y2 = value(bin)
	f = thetaStep / (y2-y1)
	rHelp = y1*f

	radiant = rHelp*rHelp + fraction*thetaStep*(y1+y2)*f
	root = SQRT(radiant)
	lowerBound = real(bin-1)*thetaStep
	if (f.GT.0) then
	    theta = lowerBound - rHelp + root
	else
	    theta = lowerBound - rHelp - root
	endif


	END


c===============================================================================

	options /extend_source

	subroutine F_Functions_Meyer(tau,thetaSchlange,f1,f2)
c	=====================================================

	implicit none

c Diese Routine gibt in Abhaengigkeit von 'thetaSchlange' und 'tau'
c Funktionswerte fuer f1 und f2 zurueck. f1 und f2 entsprechen dabei den
c bei Meyer angegebenen Funktion gleichen Namens. Die in dieser Routine
c verwendeten Tabellen sind eben dieser Referenz entnommen:
c L.Meyer, phys.stat.sol. (b) 44, 253 (1971)

	real tau,thetaSchlange
	real f1, f2, f1_(2), f2_(2)

	integer column_,column,row

	integer iColumn
	real	weightCol, weightRow

c-------------------------------------------------------------------------------

c die Tabellendaten der Referenz (Tabellen 2 und 3):

	integer nColumn
	parameter (nColumn = 25)
	real tau_(nColumn) /
     +	  0.2, 0.4, 0.6, 0.8, 1.0, 1.2, 1.4, 1.6, 1.8, 2.0, 2.5, 3.0,
     +    3.5, 4.0, 4.5, 5.0, 6.0, 7.0, 8.0, 10., 12., 14., 16., 18., 20. /

	integer nRowA
	parameter (nRowA = 25)
	real thetaSchlangeA(nRowA) /
     +	  .00, .05, .10, .15, .20, .25, .30, .35, .40, .45, .50, .60,
     +    .70, .80, .90, 1.0, 1.2, 1.4, 1.6, 1.8, 2.0, 2.5, 3.0, 3.5, 4.0 /

	integer nRowB
	parameter (nRowB = 24)
	real thetaSchlangeB(nRowB) /
     +    0.0, 0.2, 0.4, 0.5, 0.6, 0.8, 1.0, 1.2, 1.4, 1.5, 1.6, 1.8,
     +    2.0, 2.2, 2.4, 2.6, 2.8, 3.0, 3.5, 4.0, 4.5, 5.0, 6.0, 7.0	  /

	integer nRowC
	parameter (nRowC = 24)
	real thetaSchlangeC(nRowC) /
     +    0.0, 0.5, 1.0, 1.5, 2.0, 2.5, 3.0, 3.5, 4.0, 4.5, 5.0, 6.0,
     +    7.0, 8.0, 9.0, 10., 11., 12., 13., 14., 15., 16., 18., 20.	  /


	real f1_A(9,nRowA) 
     + /1.69E+2,4.55E+1,2.11E+1,1.25E+1,8.48E+0,6.21E+0,4.80E+0,3.86E+0,3.20E+0,
     +  9.82E+1,3.72E+1,1.97E+1,1.20E+1,8.27E+0,6.11E+0,4.74E+0,3.83E+0,3.17E+0,
     +  3.96E+1,2.58E+1,1.65E+1,1.09E+1,7.73E+0,5.82E+0,4.58E+0,3.72E+0,3.10E+0,
     +  1.76E+1,1.58E+1,1.27E+1,9.26E+0,6.93E+0,5.38E+0,4.31E+0,3.55E+0,2.99E+0,
     +  8.62E+0,1.01E+1,9.45E+0,7.58E+0,6.02E+0,4.85E+0,3.98E+0,3.33E+0,2.84E+0,
     +  4.65E+0,6.55E+0,6.91E+0,6.06E+0,5.11E+0,4.28E+0,3.62E+0,3.08E+0,2.66E+0,
     +  2.74E+0,4.45E+0,5.03E+0,4.78E+0,4.27E+0,3.72E+0,3.23E+0,2.82E+0,2.47E+0,
     +  1.77E+0,3.02E+0,3.71E+0,3.76E+0,3.53E+0,3.20E+0,2.86E+0,2.55E+0,2.27E+0,
     +  1.22E+0,2.19E+0,2.78E+0,2.96E+0,2.91E+0,2.73E+0,2.51E+0,2.28E+0,2.07E+0,
     +  8.82E-1,1.59E+0,2.12E+0,2.35E+0,2.39E+0,2.32E+0,2.19E+0,2.03E+0,1.87E+0,
     +  6.55E-1,1.20E+0,1.64E+0,1.88E+0,1.97E+0,1.96E+0,1.90E+0,1.79E+0,1.68E+0,
     +  3.80E-1,7.15E-1,1.01E+0,1.22E+0,1.35E+0,1.40E+0,1.41E+0,1.39E+0,1.34E+0,
     +  2.26E-1,4.45E-1,6.44E-1,8.08E-1,9.28E-1,1.01E+0,1.05E+0,1.06E+0,1.05E+0,
     +  1.39E-1,2.80E-1,4.21E-1,5.45E-1,6.46E-1,7.22E-1,7.75E-1,8.07E-1,8.21E-1,
     +  8.22E-2,1.76E-1,2.78E-1,3.71E-1,4.53E-1,5.21E-1,5.74E-1,6.12E-1,6.37E-1,
     +  5.04E-2,1.11E-1,1.86E-1,2.57E-1,3.22E-1,3.79E-1,4.27E-1,4.65E-1,4.94E-1,
     +  2.51E-2,5.60E-2,9.24E-2,1.31E-1,1.69E-1,2.02E-1,2.40E-1,2.71E-1,2.97E-1,
     +  1.52E-2,3.20E-2,5.08E-2,7.23E-2,9.51E-2,1.18E-1,1.41E-1,1.63E-1,1.83E-1,
     +  1.03E-2,2.05E-2,3.22E-2,4.55E-2,6.01E-2,7.53E-2,9.02E-2,1.05E-1,1.19E-1,
     +  8.80E-3,1.48E-2,2.25E-2,3.13E-2,4.01E-2,5.03E-2,6.01E-2,7.01E-2,8.01E-2,
     +  6.10E-3,1.15E-2,1.71E-2,2.28E-2,2.89E-2,3.52E-2,4.18E-2,4.86E-2,5.55E-2,
     +  0.00   ,0.00   ,0.00   ,0.00   ,0.00   ,1.71E-2,1.98E-2,2.28E-2,2.58E-2,
     +  0.00   ,0.00   ,0.00   ,0.00   ,0.00   ,8.90E-3,1.02E-2,1.16E-2,1.31E-2,
     +  0.00   ,0.00   ,0.00   ,0.00   ,0.00   ,4.90E-3,5.70E-3,6.40E-3,7.20E-3,
     +  0.00   ,0.00   ,0.00   ,0.00   ,0.00   ,2.90E-3,3.40E-3,3.90E-3,4.30E-3/

	real f1_B(9,nRowB)
     + /2.71E+0,1.92E+0,1.46E+0,1.16E+0,9.52E-1,8.03E-1,6.90E-1,5.32E-1,4.28E-1,
     +  2.45E+0,1.79E+0,1.39E+0,1.12E+0,9.23E-1,7.82E-1,6.75E-1,5.23E-1,4.23E-1,
     +  1.87E+0,1.48E+0,1.20E+0,9.96E-1,8.42E-1,7.24E-1,6.32E-1,4.98E-1,4.07E-1,
     +  1.56E+0,1.30E+0,1.09E+0,9.19E-1,7.89E-1,6.86E-1,6.03E-1,4.80E-1,3.95E-1,
     +  1.28E+0,1.11E+0,9.62E-1,8.33E-1,7.27E-1,6.40E-1,5.69E-1,4.59E-1,3.81E-1,
     +  8.23E-1,7.90E-1,7.29E-1,6.64E-1,6.01E-1,5.44E-1,4.94E-1,4.12E-1,3.49E-1,
     +  5.14E-1,5.36E-1,5.29E-1,5.07E-1,4.78E-1,4.47E-1,4.16E-1,3.60E-1,3.13E-1,
     +  3.19E-1,3.58E-1,3.76E-1,3.78E-1,3.70E-1,3.57E-1,3.45E-1,3.08E-1,2.76E-1,
     +  2.02E-1,2.40E-1,2.64E-1,2.77E-1,2.82E-1,2.80E-1,2.65E-1,2.59E-1,2.39E-1,
     +  1.67E-1,1.96E-1,2.20E-1,2.36E-1,2.44E-1,2.47E-1,2.45E-1,2.35E-1,2.21E-1,
     +  1.33E-1,1.61E-1,1.85E-1,2.02E-1,2.12E-1,2.18E-1,2.18E-1,2.14E-1,2.03E-1,
     +  8.99E-2,1.12E-1,1.32E-1,1.48E-1,1.59E-1,1.67E-1,1.68E-1,1.75E-1,1.72E-1,
     +  6.24E-2,7.94E-2,9.50E-2,1.09E-1,1.20E-1,1.29E-1,1.35E-1,1.42E-1,1.43E-1,
     +  4.55E-2,5.74E-2,6.98E-2,8.11E-2,9.09E-2,9.92E-2,1.06E-1,1.15E-1,1.19E-1,
     +  3.35E-2,4.22E-2,5.19E-2,6.11E-2,6.95E-2,7.69E-2,8.33E-2,9.28E-2,9.85E-2,
     +  2.50E-2,3.16E-2,3.92E-2,4.66E-2,5.35E-2,6.00E-2,6.57E-2,7.49E-2,8.13E-2,
     +  1.90E-2,2.40E-2,2.99E-2,3.58E-2,4.16E-2,4.70E-2,5.20E-2,6.05E-2,6.70E-2,
     +  1.47E-2,1.86E-2,2.32E-2,2.79E-2,3.25E-2,3.70E-2,4.12E-2,4.89E-2,5.51E-2,
     +  8.10E-3,1.04E-2,1.30E-2,1.57E-2,1.84E-2,2.12E-2,2.40E-2,2.93E-2,3.42E-2,
     +  4.80E-3,6.20E-3,7.70E-3,9.30E-3,1.09E-2,1.26E-2,1.44E-2,1.79E-2,2.14E-2,
     +  2.80E-3,3.80E-3,4.70E-3,5.70E-3,6.70E-3,7.50E-3,8.90E-3,1.13E-2,1.36E-2,
     +  1.70E-3,2.30E-3,2.90E-3,3.60E-3,4.20E-3,4.90E-3,5.60E-3,7.20E-3,8.80E-3,
     +  0.00   ,0.00   ,0.00   ,0.00   ,0.00   ,0.00   ,2.00E-3,2.80E-3,3.50E-3,
     +  0.00   ,0.00   ,0.00   ,0.00   ,0.00   ,0.00   ,8.80E-4,1.20E-3,1.60E-3/

	real f1_C(7,nRowC)
     + /3.65E-1,2.62E-1,2.05E-1,1.67E-1,1.41E-1,1.21E-1,1.05E-1,
     +  3.33E-1,2.50E-1,1.95E-1,1.61E-1,1.36E-1,1.18E-1,1.03E-1,
     +  2.75E-1,2.18E-1,1.76E-1,1.48E-1,1.27E-1,1.11E-1,9.80E-2,
     +  2.04E-1,1.75E-1,1.50E-1,1.29E-1,1.13E-1,1.01E-1,9.00E-2,
     +  1.41E-1,1.31E-1,1.19E-1,1.08E-1,9.71E-2,8.88E-2,8.01E-2,
     +  9.32E-2,9.42E-2,9.10E-2,8.75E-2,8.00E-2,7.44E-2,6.91E-2,
     +  5.98E-2,6.52E-2,6.72E-2,6.62E-2,6.40E-2,6.12E-2,5.82E-2,
     +  3.83E-2,4.45E-2,4.80E-2,4.96E-2,4.98E-2,4.90E-2,4.77E-2,
     +  2.46E-2,3.01E-2,3.40E-2,3.65E-2,3.79E-2,3.84E-2,3.83E-2,
     +  1.59E-2,2.03E-2,2.39E-2,2.66E-2,2.85E-2,2.97E-2,3.04E-2,
     +  1.04E-2,1.37E-2,1.66E-2,1.92E-2,2.12E-2,2.27E-2,2.37E-2,
     +  4.39E-3,6.26E-3,8.26E-3,9.96E-3,1.15E-2,1.29E-2,1.41E-2,
     +  2.06E-3,3.02E-3,4.24E-3,5.28E-3,6.32E-3,7.32E-3,8.26E-3,
     +  1.21E-3,1.69E-3,2.24E-3,2.85E-3,3.50E-3,4.16E-3,4.82E-3,
     +  8.50E-4,1.10E-3,1.38E-3,1.65E-3,2.03E-3,2.45E-3,2.88E-3,
     +  5.90E-4,7.40E-4,8.50E-4,9.90E-4,1.23E-3,1.49E-3,1.71E-3,
     +  3.90E-4,4.60E-4,5.20E-4,6.30E-4,7.65E-4,9.65E-4,1.12E-3,
     +  2.40E-4,2.70E-4,3.10E-4,3.98E-4,4.97E-4,6.03E-4,7.18E-4,
     +  1.50E-4,1.70E-4,2.15E-4,2.70E-4,3.35E-4,4.35E-4,5.00E-4,
     +  1.00E-4,1.20E-4,1.46E-4,1.90E-4,2.40E-4,2.88E-4,3.43E-4,
     +  0.00   ,0.00   ,1.04E-4,1.41E-4,1.80E-4,2.10E-4,2.50E-4,
     +  0.00   ,0.00   ,8.20E-5,1.06E-4,1.38E-4,1.58E-4,1.85E-4,
     +  0.00   ,0.00   ,5.40E-5,7.00E-5,8.60E-5,1.03E-4,1.20E-4,
     +  0.00   ,0.00   ,4.20E-5,5.40E-5,6.50E-5,7.70E-5,8.80E-5/

	real f2_A(9,nRowA)
     + / 3.52E+3, 3.27E+2, 9.08E+1, 3.85E+1, 2.00E+1, 1.18E+1, 7.55E+0, 5.16E+0, 3.71E+0,
     +   2.58E+2, 1.63E+2, 7.30E+1, 3.42E+1, 1.85E+1, 1.11E+1, 7.18E+0, 4.96E+0, 3.59E+0,
     +  -1.12E+2, 4.84E+0, 3.56E+1, 2.34E+1, 1.45E+1, 9.33E+0, 6.37E+0, 4.51E+0, 3.32E+0,
     +  -5.60E+1,-1.12E+1, 9.87E+0, 1.24E+1, 9.59E+0, 7.01E+0, 5.16E+0, 3.83E+0, 2.91E+0,
     +  -2.13E+1,-1.22E+1,-2.23E+0, 3.88E+0, 5.15E+0, 4.65E+0, 3.87E+0, 3.12E+0, 2.45E+0,
     +  -8.25E+0,-9.58E+0,-5.59E+0,-1.40E+0, 1.76E+0, 2.71E+0, 2.71E+0, 2.35E+0, 1.95E+0,
     +  -3.22E+0,-6.12E+0,-5.28E+0,-2.87E+0,-1.92E-1, 1.32E+0, 1.69E+0, 1.74E+0, 1.48E+0,
     +  -1.11E+0,-3.40E+0,-4.12E+0,-3.08E+0,-6.30E-1, 3.60E-1, 9.20E-1, 1.03E+0, 1.04E+0,
     +  -2.27E-1,-2.00E+0,-2.93E+0,-2.69E+0,-1.48E+0,-3.14E-1, 2.69E-1, 5.28E-1, 6.09E-1,
     +   1.54E-1,-1.09E+0,-2.10E+0,-2.15E+0,-1.47E+0,-6.77E-1,-1.80E-1, 1.08E-1, 2.70E-1,
     +   3.28E-1,-6.30E-1,-1.50E+0,-1.68E+0,-1.34E+0,-8.43E-1,-4.60E-1,-1.85E-1,-4.67E-3,
     +   3.32E-1,-2.06E-1,-7.32E-1,-9.90E-1,-9.42E-1,-8.20E-1,-6.06E-1,-4.51E-1,-3.01E-1,
     +   2.72E-1,-3.34E-2,-3.49E-1,-5.65E-1,-6.03E-1,-5.79E-1,-5.05E-1,-4.31E-1,-3.45E-1,
     +   2.02E-1, 2.80E-2,-1.54E-1,-3.00E-1,-3.59E-1,-3.76E-1,-4.60E-1,-3.40E-1,-3.08E-1,
     +   1.38E-1, 4.84E-2,-5.56E-2,-1.44E-1,-2.04E-1,-2.39E-1,-2.54E-1,-2.49E-1,-2.48E-1,
     +   9.47E-2, 4.86E-2,-1.08E-2,-6.44E-2,-1.02E-1,-1.34E-1,-1.62E-1,-1.79E-1,-1.87E-1,
     +   5.33E-2, 3.71E-2, 1.85E-2, 1.63E-3,-1.69E-2,-3.69E-2,-5.66E-2,-7.78E-2,-9.33E-2,
     +   3.38E-2, 2.40E-2, 1.62E-2, 9.90E-3, 3.76E-3,-4.93E-3,-1.66E-2,-3.05E-2,-4.22E-2,
     +   2.12E-2, 1.56E-2, 1.05E-2, 7.80E-3, 7.92E-3, 6.30E-3, 3.20E-4,-8.50E-3,-1.66E-2,
     +   1.40E-2, 9.20E-3, 5.30E-3, 4.70E-3, 6.31E-3, 8.40E-3, 5.30E-3, 8.80E-4,-3.30E-3,
     +   9.20E-3, 4.70E-3, 1.70E-3, 2.60E-3, 4.49E-3, 6.60E-3, 6.00E-3, 4.70E-3, 2.80E-3,
     +   0.00   , 0.00   , 0.00   , 0.00   , 0.00   , 0.00   , 0.00   , 0.00   , 0.00   ,
     +   0.00   , 0.00   , 0.00   , 0.00   , 0.00   , 0.00   , 0.00   , 0.00   , 0.00   ,
     +   0.00   , 0.00   , 0.00   , 0.00   , 0.00   , 0.00   , 0.00   , 0.00   , 0.00   ,
     +   0.00   , 0.00   , 0.00   , 0.00   , 0.00   , 0.00   , 0.00   , 0.00   , 0.00   /

	real f2_B(9,nRowB)
     + / 2.75E+0, 1.94E+0, 9.13E-1, 6.06E-1, 4.26E-1, 3.14E-1, 2.40E-1, 1.51E-1, 1.03E-1,
     +   1.94E+0, 1.16E+0, 7.56E-1, 5.26E-1, 3.81E-1, 2.87E-1, 2.23E-1, 1.43E-1, 9.78E-2,
     +   5.85E-1, 5.04E-1, 4.10E-1, 3.30E-1, 2.69E-1, 2.17E-1, 1.78E-1, 1.22E-1, 8.71E-2,
     +   7.83E-2, 2.00E-1, 2.35E-1, 2.19E-1, 1.97E-1, 1.73E-1, 1.48E-1, 1.08E-1, 7.93E-2,
     +  -1.82E-1, 1.56E-2, 1.04E-1, 1.36E-1, 1.38E-1, 1.31E-1, 1.19E-1, 9.46E-2, 7.19E-2,
     +  -2.71E-1,-1.66E-1,-7.29E-2,-4.74E-3, 3.60E-2, 5.50E-2, 6.28E-2, 5.98E-2, 5.09E-2,
     +  -1.87E-1,-1.58E-1,-1.09E-1,-5.80E-2,-2.03E-2, 2.48E-3, 1.99E-2, 3.36E-2, 3.27E-2,
     +  -1.01E-1,-1.05E-1,-8.95E-2,-6.63E-2,-3.93E-2,-2.38E-2,-9.22E-3, 8.47E-3, 1.52E-2,
     +  -5.19E-2,-6.47E-2,-6.51E-2,-5.62E-2,-4.51E-2,-3.49E-2,-2.45E-2,-8.19E-3, 2.05E-3,
     +  -3.68E-2,-4.89E-2,-5.36E-2,-5.06E-2,-4.27E-2,-3.65E-2,-2.80E-2,-1.33E-2,-3.47E-3,
     +  -2.33E-2,-3.69E-2,-4.41E-2,-4.38E-2,-3.97E-2,-3.50E-2,-2.88E-2,-1.60E-2,-6.68E-3,
     +  -8.76E-3,-2.07E-2,-2.90E-2,-3.17E-2,-3.09E-2,-2.92E-2,-2.63E-2,-1.79E-2,-1.03E-2,
     +  -1.20E-3,-1.11E-2,-1.90E-2,-2.20E-2,-2.32E-2,-2.24E-2,-2.10E-2,-1.66E-2,-1.11E-2,
     +   1.72E-3,-4.82E-3,-1.02E-2,-1.42E-2,-1.65E-2,-1.66E-2,-1.60E-2,-1.39E-2,-1.09E-2,
     +   2.68E-3,-1.18E-3,-5.19E-3,-8.30E-5,-1.01E-2,-1.14E-2,-1.16E-2,-1.16E-2,-9.99E-3,
     +   2.81E-3, 8.21E-4,-1.96E-3,-3.99E-3,-5.89E-3,-7.13E-3,-8.15E-3,-9.05E-3,-8.60E-3,
     +   2.61E-3, 1.35E-3,-2.99E-4,-1.79E-3,-3.12E-3,-4.44E-3,-5.61E-3,-7.01E-3,-7.27E-3,
     +   2.06E-3, 1.45E-3, 4.64E-4,-5.97E-4,-1.71E-3,-2.79E-3,-3.84E-3,-5.29E-3,-5.90E-3,
     +   1.07E-3, 9.39E-4, 8.22E-4, 3.58E-4,-1.15E-4,-6.60E-4,-1.18E-3,-2.15E-3,-2.88E-3,
     +   4.97E-4, 5.46E-4, 6.15E-4, 5.56E-4, 3.14E-4, 9.80E-5,-1.30E-4,-5.98E-4,-1.07E-4,
     +   1.85E-4, 3.11E-4, 4.25E-4, 4.08E-4, 3.63E-4, 3.04E-4, 2.24E-4, 2.80E-5,-2.10E-4,
     +   4.80E-5, 1.48E-4, 2.44E-4, 2.80E-4, 3.01E-4, 3.11E-4, 3.13E-4, 2.40E-4, 1.10E-4,
     +   0.00   , 0.00   , 0.00   , 0.00   , 0.00   , 0.00   , 1.39E-4, 1.80E-4, 1.80E-4,
     +   0.00   , 0.00   , 0.00   , 0.00   , 0.00   , 0.00   , 4.38E-5, 7.30E-5, 8.40E-5/

	real f2_C(7,nRowC)
     + / 7.36E-2, 4.21E-2, 2.69E-2, 1.83E-2, 1.34E-2, 1.01E-2, 7.88E-3,
     +   5.79E-2, 3.61E-2, 2.34E-2, 1.64E-2, 1.21E-2, 9.26E-3, 7.28E-3,
     +   2.94E-2, 2.17E-2, 1.60E-2, 1.23E-2, 9.49E-3, 7.45E-3, 5.95E-3,
     +   2.30E-3, 7.07E-3, 7.76E-3, 7.02E-3, 6.13E-3, 5.17E-3, 4.34E-3,
     +  -7.50E-3,-2.00E-3, 9.93E-4, 2.36E-3, 2.82E-3, 2.86E-3, 2.72E-3,
     +  -8.27E-3,-5.37E-3,-2.58E-3,-7.96E-4, 3.75E-4, 9.71E-4, 1.28E-3,
     +  -5.79E-3,-5.12E-3,-3.86E-3,-2.46E-3,-1.20E-3,-3.74E-4, 1.74E-4,
     +  -3.26E-3,-3.43E-3,-3.26E-3,-2.68E-3,-1.84E-3,-1.12E-3,-4.54E-4,
     +  -1.46E-3,-1.49E-3,-2.20E-3,-2.18E-3,-1.85E-3,-1.40E-3,-8.15E-4,
     +  -4.29E-4,-9.44E-4,-1.29E-3,-1.50E-3,-1.51E-3,-1.36E-3,-9.57E-4,
     +  -3.30E-5,-3.66E-4,-6.78E-4,-9.38E-4,-1.09E-3,-1.09E-3,-9.56E-4,
     +   1.50E-4, 3.10E-5,-1.38E-4,-3.06E-4,-4.67E-4,-5.48E-4,-6.08E-4,
     +   1.00E-4, 8.50E-5, 2.30E-5,-6.60E-5,-1.58E-4,-2.40E-4,-3.05E-4,
     +   5.40E-5, 6.50E-5, 4.90E-5, 1.20E-5,-3.60E-5,-8.90E-5,-1.31E-4,
     +   2.90E-5, 4.30E-5, 4.40E-5, 2.90E-5, 5.10E-6,-2.20E-5,-4.80E-5,
     +   1.40E-5, 2.40E-5, 2.80E-5, 2.60E-5, 1.90E-5, 7.50E-6,-1.10E-5,
     +   0.00   , 0.00   , 0.00   , 0.00   , 0.00   , 0.00   , 0.00   ,
     +   0.00   , 0.00   , 0.00   , 0.00   , 0.00   , 0.00   , 0.00   ,
     +   0.00   , 0.00   , 0.00   , 0.00   , 0.00   , 0.00   , 0.00   ,
     +   0.00   , 0.00   , 0.00   , 0.00   , 0.00   , 0.00   , 0.00   ,
     +   0.00   , 0.00   , 0.00   , 0.00   , 0.00   , 0.00   , 0.00   ,
     +   0.00   , 0.00   , 0.00   , 0.00   , 0.00   , 0.00   , 0.00   ,
     +   0.00   , 0.00   , 0.00   , 0.00   , 0.00   , 0.00   , 0.00   ,
     +   0.00   , 0.00   , 0.00   , 0.00   , 0.00   , 0.00   , 0.00   /


c===============================================================================

c Bestimme, welche Reihen der Tabellen fuer Interpolation benoetigt werden:

	if (tau.LT.tau_(1)) then
	    write(*,*) 'tau is less than the lowest tabulated value:'
	    write(*,*) 'tau = ',tau
	    write(*,*) 'minimum = ',tau_(1)
	    call exit
	elseif (tau.GT.tau_(nColumn)) then
	    write(*,*) 'tau is greater than the highest tabulated value:'
	    write(*,*) 'tau = ',tau
	    write(*,*) 'maximum = ',tau_(nColumn)
	    call exit
	endif

	column_ = 2
	do while (tau.GT.tau_(column_))
	    column_ = column_ + 1
	enddo
	! Das Gewicht der Reihe zu groesserem Tau:
	weightCol = (tau-tau_(column_-1)) / (tau_(column_)-tau_(column_-1))


c Besorge fuer gegebenes 'thetaSchlange' die interpolierten f1- und f2 -Werte
c der beiden relevanten Reihen:
c iColumn = 1 => Reihe mit hoeherem Index
c iColumn = 2 => Reihe mit kleinerem Index


	iColumn = 1


5	continue

	if (column_.LE.9) then	     ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
				     ! Werte aus 1. Tabelle: 0.2 <= tau <= 1.8

	    column = column_

	    if (thetaSchlange.LT.thetaSchlangeA(1)) then
		write(*,*) 'thetaSchlange is less than the lowest tabulated value in table 1:'
		write(*,*) 'thetaSchlange = ',thetaSchlange
		write(*,*) 'minimum       = ',thetaSchlangeA(1)
		call exit
	    elseif (thetaSchlange.GT.thetaSchlangeA(nRowA)) then
c		write(*,*) 'thetaSchlange is greater than the highest tabulated value in table 1:'
c		write(*,*) 'thetaSchlange = ',thetaSchlange
c		write(*,*) 'maximum = ',thetaSchlangeA(nRowA)
c		call exit
		thetaSchlange = -1.
		RETURN
	    endif

	    row = 2
	    do while (thetaSchlange.GT.thetaSchlangeA(row))
		row = row + 1
	    enddo
	    ! Gewicht des Tabellenwertes zu groesseren ThetaSchlange:
	    weightRow = (thetaSchlange-thetaSchlangeA(row-1)) /
     +				(thetaSchlangeA(row)-thetaSchlangeA(row-1))

	    f1_(iColumn) = (1.-weightRow) * f1_A(column,row-1) +
     +			       weightRow  * f1_A(column,row)
	    f2_(iColumn) = (1.-weightRow) * f2_A(column,row-1) +
     +			       weightRow  * f2_A(column,row)


	elseif (column_.LE.18) then  ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
				     ! Werte aus 2. Tabelle: 2.0 <= tau <= 7.0

	    column = column_ - 9

	    if (thetaSchlange.LT.thetaSchlangeB(1)) then
		write(*,*) 'thetaSchlange is less than the lowest tabulated value in table 1:'
		write(*,*) 'thetaSchlange = ',thetaSchlange
		write(*,*) 'minimum       = ',thetaSchlangeB(1)
		call exit
	    elseif (thetaSchlange.GT.thetaSchlangeB(nRowB)) then
c		write(*,*) 'thetaSchlange is greater than the highest tabulated value in table 1:'
c		write(*,*) 'thetaSchlange = ',thetaSchlange
c		write(*,*) 'maximum = ',thetaSchlangeB(nRowB)
c		call exit
		thetaSchlange = -1.
		RETURN
	    endif

	    row = 2
	    do while (thetaSchlange.GT.thetaSchlangeB(row))
		row = row + 1
	    enddo
	    ! Gewicht des Tabellenwertes zu groesseren ThetaSchlange:
	    weightRow = (thetaSchlange-thetaSchlangeB(row-1)) /
     +				(thetaSchlangeB(row)-thetaSchlangeB(row-1))

	    f1_(iColumn) = (1.-weightRow) * f1_B(column,row-1) +
     +			       weightRow  * f1_B(column,row)
	    f2_(iColumn) = (1.-weightRow) * f2_B(column,row-1) +
     +			       weightRow  * f2_B(column,row)


	else			     ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
				     ! Werte aus 3. Tabelle: 8.0 <= tau <= 20.

	    column = column_ - 18

	    if (thetaSchlange.LT.thetaSchlangeC(1)) then
		write(*,*) 'thetaSchlange is less than the lowest tabulated value in table 1:'
		write(*,*) 'thetaSchlange = ',thetaSchlange
		write(*,*) 'minimum       = ',thetaSchlangeC(1)
		call exit
	    elseif (thetaSchlange.GT.thetaSchlangeC(nRowC)) then
c		write(*,*) 'thetaSchlange is greater than the highest tabulated value in table 1:'
c		write(*,*) 'thetaSchlange = ',thetaSchlange
c		write(*,*) 'maximum = ',thetaSchlangeC(nRowC)
c		call exit
		thetaSchlange = -1.
		RETURN
	    endif

	    row = 2
	    do while (thetaSchlange.GT.thetaSchlangeC(row))
		row = row + 1
	    enddo
	    ! Gewicht des Tabellenwertes zu groesseren ThetaSchlange:
	    weightRow = (thetaSchlange-thetaSchlangeC(row-1)) /
     +				(thetaSchlangeC(row)-thetaSchlangeC(row-1))

	    f1_(iColumn) = (1.-weightRow) * f1_C(column,row-1) +
     +			       weightRow  * f1_C(column,row)
	    f2_(iColumn) = (1.-weightRow) * f2_C(column,row-1) +
     +			       weightRow  * f2_C(column,row)


	endif				    ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~


	if (iColumn.EQ.1) then
	    column_ = column_ - 1
	    iColumn = 2
	    goto 5
	endif

	f1 = weightCol*f1_(1) + (1.-weightCol)*f1_(2)
	f2 = weightCol*f2_(1) + (1.-weightCol)*f2_(2)


	END


c===============================================================================

	OPTIONS /EXTEND_SOURCE

	SUBROUTINE reset_statistics
c	===========================

	IMPLICIT NONE

	integer  Nr,n,k
 
	INCLUDE 'mutrack$sourcedirectory:COM_MUTRACK.INC'

c - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
c der allgemeine Statistikspeicher:       (*) : braucht nicht resettet zu werden
c ---------------------------------
c
c	statMem(1,Nr): 1. Wert: x(1)					    (*)
c	statMem(2,Nr): Summe_ueber_i(  x(i)-x(1)      )
c	statMem(3,Nr): Summe_ueber_i( (x(i)-x(1))**2. )
c	statMem(4,Nr): kleinster Wert
c	statMem(5,Nr): groesster Wert
c	statMem(6,Nr): Mittelwert					    (*)
c	statMem(7,Nr): Varianz						    (*)
c	statMem(8,Nr): Anzahl der Werte
c	statMem(9,Nr): Anzahl der Werte in Prozent von 'StartsProSchleife'  (*)
c	('StartsProSchleife' == n_par(0))
c - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

c Ergebnis-Statistik-Speicher resetten:

	do Nr = 1, stat_Anzahl
	    statMem(2,Nr) =  0.			! Summe der Werte
	    statMem(3,Nr) =  0.			! Summe der Quadrate
	    statMem(4,Nr) =  1.e10		! Minimalwert
	    statMem(5,Nr) = -1.e10		! Maximalwert
	    statMem(8,Nr) =  0.			! Anzahl
	enddo

c die Scaler fuer den Returncode des TDs und die Pfostenhits sowie die
c StartZaehler resetten:

	do n = 1, 2		    ! (1: Projektile, 2: FolienElektronen)
	    start_nr(n) = 0
	    do k = 1, 18
		statTD(n,k) = 0.
	    enddo
	    do k = 1, 75
		pfostenHit(k,n) = 0.
	    enddo
	enddo


c der Statistikspeicher fuer das Teilchen-Schicksal:

	do k = smallest_code_Nr, Gebiete_Anzahl*highest_code_Nr
	    statDestiny(k) = 0
	enddo


	END


c===============================================================================


	OPTIONS /EXTEND_SOURCE

	SUBROUTINE fill_statMem(wert,Nr)
c	================================

	IMPLICIT NONE

	INCLUDE 'mutrack$sourcedirectory:COM_MUTRACK.INC'

	real	wert
	integer	Nr

c - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
c Wird die Varianz der Verteilung einer Groesse x gemaess der Formel
c
c	Var(x) = SQRT( <x**2> - <x>**2 )	,  < > -> Erwartungswert
c
c mit 
c	<x>    = 1/n * Summe_ueber_i( x(i)    ) 
c	<x**2> = 1/n * Summe_ueber_i( x(i)**2 ) 
c
c berechnet, so tritt manchmal aufgrund der beschraenkten Genauigkeit der
c numerischen Speicher das Problem auf, dass bei grossen Werten x(i) und
c kleiner Streuung der Ausdruck unter der Wurzel negativ wird, was erstens
c unphysikalisch ist und zweitens zum Programmabbruch fuehrt.
c
c Dieses Problem liesse sich vermeiden, wenn man die Groessen x(i) relativ
c zu ihrem Erwartungswert angeben wuerde, der aber erst im nachhinein bekannt 
c ist. 
c
c Als Naeherungsloesung verwende ich daher fuer die Berechnung der Varianz die
c x(i) relativ zu x(1), also zum ersten Wert gemessen, der gerade bei kleiner
c Streuung, bei der das numerische Problem auftritt, nahe am Erwartungswert
c liegen sollte.
c
c	statMem(1,Nr): 1. Wert: x(1)
c	statMem(2,Nr): Summe_ueber_i(  x(i)-x(1)      )
c	statMem(3,Nr): Summe_ueber_i( (x(i)-x(1))**2. )
c	statMem(4,Nr): kleinster Wert
c	statMem(5,Nr): groesster Wert
c	statMem(6,Nr): Mittelwert					    (*)
c	statMem(7,Nr): Varianz						    (*)
c	statMem(8,Nr): Anzahl der Werte
c	statMem(9,Nr): Anzahl der Werte in Prozent von 'StartsProSchleife'  (*)
c	('StartsProSchleife' == n_par(0))
c
c	(*): wird im SUB 'eval_statistics' berechnet.
c
c - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -


c Zaehle mit:

	statMem(8,Nr) = statMem(8,Nr) + 1.


c Speichere den ersten Wert:

	if (statMem(8,Nr).EQ.1) statMem(1,Nr) = wert


c Summiere die Abweichungen vom ersten Wert:

	statMem(2,Nr) = statMem(2,Nr) + (wert-statMem(1,Nr))


c Summiere die Quadratischen Abweichungen vom ersten Wert:

	statMem(3,Nr) = statMem(3,Nr) + (wert-statMem(1,Nr))**2.


c Speichere den kleinsten Wert (wurde noch kein Wert aufgenommen, so ist
c statMem(4,Nr) = 1.e10):

	if (statMem(4,Nr).GT.wert) statMem(4,Nr) = wert


c Speichere den groessten Wert (wurde noch kein Wert aufgenommen, so ist
c statMem(5,Nr) = -1.e10):

	if (statMem(5,Nr).LT.wert) statMem(5,Nr) = wert


	END


c===============================================================================


	OPTIONS /EXTEND_SOURCE

	SUBROUTINE eval_statistics
c	==========================

	IMPLICIT NONE

c	statMem(1,Nr): 1. Wert: x(1)
c	statMem(2,Nr): Summe_ueber_i(  x(i)-x(1)      )
c	statMem(3,Nr): Summe_ueber_i( (x(i)-x(1))**2. )
c	statMem(4,Nr): kleinster Wert
c	statMem(5,Nr): groesster Wert
c	statMem(6,Nr): Mittelwert
c	statMem(7,Nr): Varianz
c	statMem(8,Nr): Anzahl der Werte
c	statMem(9,Nr): Anzahl der Werte in Prozent von 'StartsProSchleife'
c	('StartsProSchleife' == n_par(0))


	INCLUDE 'mutrack$sourcedirectory:COM_MUTRACK.INC'

	real	n	    ! Anzahl der Werte, == statMem(8,Nr)
	real	radiant

        integer Nr,l


        do Nr = 1, Stat_Anzahl
            if (statNeeded(Nr)) then
                n = statMem(8,Nr)
                if (n.ne.0.) then

		    !c Berechne Mittelwert:
                    statMem(6,Nr) = statMem(2,Nr)/n + statMem(1,Nr)

		    !c Berechne Varianz:
      		    radiant = ( statMem(3,Nr) - (statMem(2,Nr)**2. )/n)/n
      		    statMem(7,Nr) = sqrt(radiant)

		    !c Berechne Anteil an allen gestarteten in Prozent
                    statMem(9,Nr) = 100.*n/real(n_par(0))

                else

		    do l = 1, 9
      		       statMem(l,Nr) = 0.
		    enddo

                endif
            endif
        enddo

 
	END


c===============================================================================


	OPTIONS /EXTEND_SOURCE

	SUBROUTINE SAVE_GRAPHICS_KOORD
c	==============================

	IMPLICIT NONE

	INCLUDE 'mutrack$sourcedirectory:COM_MUTRACK.INC'
	INCLUDE 'mutrack$sourcedirectory:COM_WINKEL.INC'
	INCLUDE 'mutrack$sourcedirectory:COM_KAMMER.INC'

c Variablen fuer die Graphikausgabe:

	real	xKoord(1000)		    ! Koordinatenfelder fuer die
	real	yKoord(1000)		    !    Graphikausgabe
	real	zKoord(1000)		    !
cMBc	real	tKoord(1000)		    !
	integer nKoord			    ! Anzahl der Koordinaten

cMBc	COMMON /GRAPHIX/ xKoord,yKoord,zKoord,nKoord,tKoord  ! fuer Graphikaufruf
	COMMON /GRAPHIX/ xKoord,yKoord,zKoord,nKoord ! fuer Graphikaufruf

c - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

	nKoord = nKoord + 1

	xKoord(nKoord) = x(1)
	yKoord(nKoord) = x(2)
	zKoord(nKoord) = x(3)
cMBc	tKoord(nKoord) = t

	if (nKoord.EQ.1000) then
	    if (Gebiet.LE.upToChKoord) then	! Bahnberechnung wurde vor
		call plot_horizontal		! Koordinatenwechsel abgebrochen
	    else
		call plot_vertikal
	    endif
	    xKoord(1) = xKoord( 999)		! die letzten beiden uebernehmen,
	    yKoord(1) = yKoord( 999)		! damit gegebenenfalls der Richtungs-
	    zKoord(1) = zKoord( 999)		! pfeil gezeichnet werden kann.
cMBc	    tKoord(1) = tKoord( 999)
	    xKoord(2) = xKoord(1000)
	    yKoord(2) = yKoord(1000)
	    zKoord(2) = zKoord(1000)
cMBc	    tKoord(2) = tKoord(1000)
	    nKoord = 2
	endif


	END


c===============================================================================


	OPTIONS /EXTEND_SOURCE

	SUBROUTINE Output_Debug
c	=======================

	IMPLICIT NONE

	INCLUDE 'mutrack$sourcedirectory:COM_MUTRACK.INC'
	INCLUDE 'mutrack$sourcedirectory:COM_WINKEL.INC'
	INCLUDE 'mutrack$sourcedirectory:COM_KAMMER.INC'

	real Ekin, temp1, temp2

        Ekin = (v(1)*v(1) + v(2)*v(2) + v(3)*v(3)) * Energie_Faktor

	if (Gebiet.EQ.1 .AND. alfaTgt.NE.0) then
	    if (alfaTgtVertically) then
		temp1 = xGrid1*Cos_alfaTgt - x(3)*Sin_alfaTgt
		temp2 = xGrid1*Sin_alfaTgt + x(3)*Cos_alfaTgt
		write(lun(1),1) steps,Gebiet,t,temp1,x(2),temp2,v,Ekin
	    else
		temp1 = xGrid1*Cos_alfaTgt - x(2)*Sin_alfaTgt
		temp2 = xGrid1*Sin_alfaTgt + x(2)*Cos_alfaTgt
		write(lun(1),1) steps,Gebiet,t,temp1,temp2,x(3),v,Ekin
	    endif
	else
	    write(lun(1),1) steps,Gebiet,t,x,v,Ekin
	endif

1	format(X,I4,X,I2,4X,F6.1,2X,F7.2,X,F6.2,X,F6.2,2X,F6.2,X,
     +		      F6.2,X,F6.2,2X,G13.6)

	END


c===============================================================================


	OPTIONS /EXTEND_SOURCE

	SUBROUTINE Decay_Test(*)
c	========================

	IMPLICIT NONE

	INCLUDE 'mutrack$sourcedirectory:COM_MUTRACK.INC'

	real dt

	if (t.GT.lifeTime) then	  ! Teilchen zerfallen
	    dt = t - lifeTime
	    t = lifeTime
	    x(1) = x(1) - dt*v(1)
	    x(2) = x(2) - dt*v(2)
	    x(3) = x(3) - dt*v(3)
	    destiny = code_decay
	    RETURN 1
	endif


	END


c===============================================================================


	OPTIONS /EXTEND_SOURCE

	SUBROUTINE chargeStateYields(E,masse,Yield_plus,Yield_zero)
c       ===========================================================

c - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 
c Die Funktion sowie die Parameter sind uebernommen aus:
c
c	M.Gonin, R.Kallenbach, P.Bochsler: 'Charge exchange of hydrogen atoms
c	in carbon foils at 0.4 - 120 keV', Rev.Sci.Instrum. 65 (3), March 1994
c
c - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 

	IMPLICIT NONE

	real E		! kinetische Energie in keV
	real masse	! in keV / c**2

	real a_zero,a_minus
	real k_Fermi,k_zero,k_minus
	real zwo_k_Fermi
	real k_Fermi_Quad,k_zero_Quad,k_minus_Quad
	real vc_minus,vc_plus,v_Bohr,v_rel

	parameter ( a_zero   = 0.953,  a_minus = 0.029 )
	parameter ( k_Fermi  = 1.178                   )	! [v_Bohr]
	parameter ( k_Fermi_Quad = k_Fermi * k_Fermi   )
	parameter ( zwo_k_fermi = 2. * k_Fermi         )
	parameter ( k_zero   = 0.991*k_Fermi           )	! [v_Bohr]
	parameter ( k_zero_Quad = k_zero * k_zero      )
	parameter ( k_minus  = 0.989*k_Fermi           )	! [v_Bohr]
	parameter ( k_minus_Quad = k_minus * k_minus   )
	parameter ( vc_minus = 0.284,  vc_plus = 0.193 )	! [v_Bohr]
	parameter ( v_Bohr   = 7.2974E-3               )	! [c]

	real Q_zero,Q_minus,D
	real Yield_minus,Yield_zero,Yield_plus

	real help1,help2,help3


c - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 

	if (E.LT.0) then
	    write(*,*)
	    write(*,*) 'error in subroutine ''chargeStateYields'':'
	    write(*,*) 'E = ',E,' < 0!'
	    write(*,*) '-> STOP'
	    write(*,*)
	    STOP
	endif


c Energie in Geschwindigkeit umrechnen (in Einheiten von v_Bohr):

c - klassisch:

	v_rel = SQRT(2.*E/masse) / v_Bohr

c - relativistisch:

c	help1 = 1. + E/masse
c	v_rel = SQRT(1. - 1./(help1*help1)) / v_Bohr


c Die geladenen Anteile berechnen (vgl. obige Referenz):

	help1 = v_rel*v_rel
	help2 = zwo_k_Fermi*v_rel
	Q_zero  = 1. + (k_zero_Quad  - k_Fermi_Quad - help1) / help2
	Q_minus = 1. + (k_minus_Quad - k_Fermi_Quad - help1) / help2


	help1 = a_zero * Q_zero
	help2 = a_minus * Q_minus
	help3 = (1.-Q_zero)*(1.-Q_minus)
	D = help1*(help2 + (1.-Q_minus)) + help3

	Yield_minus = help1*help2 / D
	Yield_plus  = help3 / D

	Yield_minus = Yield_minus * exp(-vc_minus/v_rel)
	Yield_plus  = Yield_plus  * exp(-vc_plus /v_rel)

	Yield_zero  = 1. - (Yield_minus + Yield_plus)

c	write(6,*) 'E	vrel	Neutral	    Plus	 Minus'
c	write(6,*) E, v_rel, yield_zero, yield_plus, yield_minus

	END


c===============================================================================


	OPTIONS /EXTEND_SOURCE

	SUBROUTINE test_wireHit(distToWire,WireRadiusQuad,v_x,v_y,WireHit)
c	==================================================================

c Diese Routine ueberprueft, ob bei gegebenem Abstandsvektor 'distToWire'
c zwischen Teilchen und Draht und gegebener Geschwindigkeit v eines Teilchens
c bei geradliniger Bewegung und Drahtradius 'WireRadius' ein Schnittpunkt
c von Teilchenbahn und Drahtumfang existiert, ob also der Draht getroffen wird.
c Dafuer genuegt es zu pruefen, ob der Radiant der 'Mitternachtsformel' fuer die
c entsprechende quadratische Gleichung groesser oder gleich Null ist:

        IMPLICIT NONE

	real	DistToWire(2),WireRadiusQuad,v_x,v_y
	logical WireHit

	real steigung, help, radiant

c - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 

	if (abs(v_x).GT.abs(v_y)) then
	    steigung = v_y/v_x
	    help	 = distToWire(2)  -  distToWire(1) * steigung
	    radiant  = (1+steigung*steigung)*WireRadiusQuad - help*help
	else
	    steigung = v_x/v_y
	    help	 = distToWire(1)  -  distToWire(2) * steigung
	    radiant  = (1+steigung*steigung)*WireRadiusQuad - help*help
	endif

	if (radiant.ge.0) then
	    wireHit = .true.
	else
	    wireHit = .false.
	endif


	END


c===============================================================================
