
	OPTIONS /EXTEND_SOURCE

	SUBROUTINE READ_INFOS
c	=====================

	logical map_error  /.false./
	COMMON /map_error/ map_error

	CALL READ_INFO_6	! Die Reihenfolge der 'READ_INFO_x'-calls
	CALL READ_INFO_5	! ist wichtig (wegen Uebermittlung der
	CALL READ_INFO_4	! Uebergabebereiche)
	CALL READ_INFO_3
	CALL READ_INFO_2
	CALL READ_INFO_1

	if (map_error) then
	    write(*,*) '-----------------------------------------------------------'
	    write(*,*)
	    write(*,*) ' => Files ''MAP_DEF_x.INC'' (x == Nr. der Mappe) im Directory'
	    write(*,*) '    ''accel$sourcedirectory:'' angleichen und anschliessend' 
	    write(*,*) '    das Programm mit ''LINKACV'' am DCL Prompt neu kompilieren'
	    write(*,*) '    und linken.'
	    write(*,*)
	    write(*,*) '-----------------------------------------------------------'
	    write(*,*)
	    STOP
	endif


	END


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


	OPTIONS /EXTEND_SOURCE

	SUBROUTINE READ_INFO_6
c	======================

        IMPLICIT NONE

	character*1 Nr
	parameter (Nr='6')

	INCLUDE 'accel$sourcedirectory:COM_GEO.INC'
	INCLUDE 'accel$sourcedirectory:COM_HVs.INC'
	INCLUDE 'accel$sourcedirectory:COM_ACCEL.INC'
	INCLUDE 'accel$sourcedirectory:COM_DIRS.INC'
	INCLUDE 'accel$sourcedirectory:MAP_DEF_6.INC'

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

c nur um Mappeninfos fuer Runs vor Run 10 weiterhin lesen zu koennen
c (wurden ab Version 1.2.1 ersetzt durch outerDy_TgtHolder, outerDz_TgtHolder):

	real Dy_TgtHolder, Dz_TgtHolder

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

	namelist /voltages/ UTgt, UGua, UGrid1, UG1, UG2, zero

	namelist /geometry/
     +  Dy_Foil,Dz_Foil,xEnd_TgtHolder,Dy_TgtHolder,Dz_TgtHolder,
     +  outerDy_TgtHolder,outerDz_TgtHolder,
     +  innerDy1_TgtHolder,innerDz1_TgtHolder,innerDy2_TgtHolder,innerDz2_TgtHolder,
     +  xStart_Guardring,xEnd_Guardring,innerDy_Guardring,outerDy_Guardring,
     +  innerDz_Guardring,outerDz_Guardring,
     +  xPosition_Grid1,distance_wires1,dWires1,y_Pos_firstWire1,y_Pos_lastWire1,
     +  xStart_Balken,xEnd_Balken,Dy_Balken,
     +  innerDz_Balken,outerDz_Balken,
     +  xStart_Gridframe1,xEnd_Gridframe1,innerDy_Gridframe1,outerDy_Gridframe1,
     +  innerDz_Gridframe1,outerDz_Gridframe1,
     +  xPosition_Grid2,distance_wires2,dWires2,y_Pos_firstWire2,y_Pos_lastWire2,
     +  xStart_Gridframe2,xEnd_Gridframe2,innerDy_Gridframe2,outerDy_Gridframe2,
     +  innerDz_Gridframe2,outerDz_Gridframe2,
     +  xHeShield,rHeShield    
 
c - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

	logical map_error
	COMMON /map_error/ map_error


c the grid characteristics (as read from the INFO-file):

	real	Dx,Dy,Dz
	real	x_iEQ1, ymax,zmax	! xmax wird in MAP_DEF_6.INC definiert

	namelist /grid_info/
     +	Dx,Dy,Dz, imax,jmax,kmax, x_iEQ1, xmin,xmax,ymax,zmax


	integer iostat

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

c Versuchen, ein Mappenfile mit fixer HV-Einstellung zu oeffnen (d.h. ein
c Mappenfile ohne Erweiterung '_Tgt' bzw. '_Gua' bzw. '_Gi1'). Gelingt dies, so
c verwende fuer die Hochspannungen an Target und 1. Gitter die Spannungen,
c fuer die die Mappe gerechnet wurde (-> 'HVs_from_map = .true.). Ansonsten
c verwende die von ACCEL.INPUT eingelesenen Vorgaben fuer die HV-Schleifen:

	open (lunREAD,file=mappenName//'_'//Nr,defaultfile=mappenDir//':.MAPPE',
     +		  readonly,status='old',iostat=iostat)
	if (iostat.EQ.0) then
	    HVs_from_map = .true.		! Default = .false.
	    close (lunREAD)
	endif


c Einlesen der Mappen-Informationen (bei Mappe 6 auch Spannungen und Geometrie
c des Targetbereiches):

	open (lunREAD,file=mappenName//'_'//Nr,defaultfile=mappenDir//':.INFO',
     +						  readonly,status='old')
	read(lunREAD,nml=grid_info)
	rewind (lunREAD)
	UGua = -1.E10
      	read(lunREAD,nml=voltages)
	if (UGua.NE.-1.E10) then
	    ! Es wurde ein Spannungswert fuer den Guardring angegeben.
	    ! => Guardring hat eigene Spannungseinstellung
	    freeGuard = .true.
	else
	    freeGuard = .false.
	    par(1,UGuard) = 0
	    par(2,UGuard) = 0
	    par(3,UGuard) = 1
	endif
	rewind (lunREAD)
	read(lunREAD,nml=geometry)
	close (lunREAD)

	if (outerDy_TgtHolder.EQ.-1.E10) outerDy_TgtHolder = Dy_TgtHolder
	if (outerDz_TgtHolder.EQ.-1.E10) outerDz_TgtHolder = Dz_TgtHolder
	if (innerDy1_TgtHolder.EQ.-1.E10) innerDy1_TgtHolder = Dy_Foil
	if (innerDz1_TgtHolder.EQ.-1.E10) innerDz1_TgtHolder = Dz_Foil
	if (innerDy2_TgtHolder.EQ.-1.E10) innerDy2_TgtHolder = Dy_Foil
	if (innerDz2_TgtHolder.EQ.-1.E10) innerDz2_TgtHolder = Dz_Foil

      	if (HVs_from_map) then
	    ! Die eingelesenen Spannungen an die Variablen fuer die
	    ! zugehoerigen Schleifen weitergeben (nur bei Mappe 6):
	    par(1,UTarget)  = UTgt
	    par(2,UTarget)  = UTgt
	    par(3,UTarget)  = 1
	    if (freeGuard) then
		par(1,UGuard)   = UGua
		par(2,UGuard)   = UGua
		par(3,UGuard)   = 1
	    endif
	    par(1,UGi1)     = UG1
	    par(2,UGi1)     = UG1
	    par(3,UGi1)     = 1
      	endif


c eingelesene imax, jmax und kmax um 1 reduzieren, da in 'ACCEL' die Feldindizes
c ab 0 laufen, bei 'RELAX3D' jedoch ab 1:

	imax = imax-1
	jmax = jmax-1
	kmax = kmax-1


c Umrechnen der Koordinaten, wie sie von 'BESCHL-INIT' ('RELAX3D') verwendet
c werden (Ursprung in Targetfolienmitte) in System mit Ursprung auf der Kryo-Achse:

	xFoil		    = -xHeShield
	xHeShield	    = 0.

	xmin		    = xmin		    + xFoil
 	xmax		    = xmax		    + xFoil

	xStartMap6 = xmin
	xEndMap6   = xmax

	xEnd_TgtHolder	    = xEnd_TgtHolder	    + xFoil
	xStart_Guardring    = xStart_Guardring	    + xFoil
	xEnd_Guardring	    = xEnd_Guardring	    + xFoil

	xPosition_Grid1	    = xPosition_Grid1	    + xFoil
	xStart_Gridframe1   = xStart_Gridframe1	    + xFoil
	xEnd_Gridframe1	    = xEnd_Gridframe1	    + xFoil
	xStart_Balken	    = xStart_Balken	    + xFoil
	xEnd_Balken	    = xEnd_Balken	    + xFoil

	xPosition_Grid2	    = xPosition_Grid2	    + xFoil
	xStart_Gridframe2   = xStart_Gridframe2	    + xFoil
	xEnd_Gridframe2	    = xEnd_Gridframe2	    + xFoil

	rWires1 = dWires1/2.
	rQuadWires1 = rWires1*rWires1
	rWires2 = dWires2/2.
	rQuadWires2 = rWires2*rWires2


C DER FOLGENDE ABSCHNITT WURDE HERAUSKOMMENTIERT, DA ES MITTLERWEILE VERSCHIEDEN
C GROSSE POTENTIALMAPPEN GIBT UND DIE MAPPENDIMENSIONEN DAHER SOWIESO VARIABEL
C GEHALTEN WERDEN MUESSEN. DIE VERWENDUNG VON PARAMETERN IST LEIDER NICHT
C MEHR MOEGLICH. ('LEIDER' WEGEN DER ERHOEHTEN RECHENZEIT):
C
Cc checken, ob die Charakteristika der einzulesenden Mappe mit den Vorgaben der
Cc Integrationsroutinen uebereinstimmen:
Cc (Die Laenge von Mappe 6 ist abhaengig von der Position des Moderators relativ
Cc zur Kryoachse.)
C
C	if (
Cc    +	    imax.NE.imax_ .OR. 
C    +	    jmax.NE.jmax_ .OR. kmax.NE.kmax_ .OR.
C    +	    Dx.NE.Dx_ .OR. Dy.NE.Dy_ .OR. Dz.NE.Dz_
Cc    +	    .OR. xmin.NE.xmin_
C    +				      ) then
C	    write(*,*) '-----------------------------------------------------------'
C	    if (.NOT.map_error) then
C		write(*,*) ' Feldgroessen der eingelesenen Mappe und des reservierten'
C		write(*,*) ' Speichers stimmen nicht ueberein:'
C		write(*,*)
C	    endif
C	    write(*,*) ' MAPPE '//Nr//':   '//mappenName(1:nameLength)//'_'//Nr//'.MAPPE'
C	    write(*,*) ' Mappe:     imax, jmax ,kmax   = ',imax ,jmax ,kmax
C	    write(*,*) '            Dx   ,Dy   ,Dz     = ',Dx   ,Dy   ,Dz  
C	    write(*,*) ' Speicher:  imax_,jmax_,kmax_  = ',imax ,jmax_,kmax_
C	    write(*,*) '            Dx_  ,Dy_  ,Dz_    = ',Dx_  ,Dy_  ,Dz_ 
C	    write(*,*)
C	    map_error = .true.
C	endif
C
C	if (map_error) RETURN	    ! kann auch in anderem 'READ_MAP_x' gesetzt worden sein


c checken, ob der reservierte Speicherplatz ausreicht:

	if ((imax+1)*(jmax+1)*(kmax+1).GT.maxmaxmem+1) then
	    write(*,*)
	    write(*,*) 'reservierter Speicher ist nicht ausreichend fuer Mappe',Nr
	    write(*,*)
	    write(*,*) '(imax+1)*(jmax+1)*(kmax+1) = ',(imax+1)*(jmax+1)*(kmax+1)
	    write(*,*) 'maxmaxmem + 1              = ',maxmaxmem + 1
	    write(*,*)
	    write(*,*) '=> ''maxmaxmem'' in accel$sourcedirectory:MAPMAP.INC angleichen'
	    write(*,*) '   und Programm mit ''LINKACV'' am DCL-Prompt neu kompilieren'
	    write(*,*) '   und linken.'
	    write(*,*)
	    call exit
	endif


	END


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


	OPTIONS /EXTEND_SOURCE

	SUBROUTINE READ_MAP_6
c	=====================

        IMPLICIT NONE

	character*1 Nr
	parameter (Nr='6')

	INCLUDE 'accel$sourcedirectory:MAP_DEF_6.INC'
	INCLUDE 'accel$sourcedirectory:COM_DIRS.INC'
	INCLUDE 'accel$sourcedirectory:COM_ACCEL.INC'

	integer   i,j,k, ihelp, iostat


c Einlesen der Potentialmappe:

	open (lunRead,file=mappenName//'_'//Nr,
     +		 defaultfile=mappenDir//':.MAPPE',status='old',
     +		 form='unformatted',recl=imax+1,readonly)
c     +           form='unformatted',recl=imax,readonly)
	write(*,*) 'reading '//mappenName(1:nameLength)//'_'//Nr//'.MAPPE  ...'
	do k = 0, kmax
      	    do j = 0, jmax
c      		read(lunREAD,iostat=iostat) (map(i,j,k),i=0,imax)
		ihelp = (k*(jmax+1)+j)*(imax+1)
		read(lunREAD,iostat=iostat) (map(ihelp+i),i=0,imax)
      		if (iostat.NE.0) then
		    write(*,*)
      		    write(*,999) i,j,k,iostat
		    STOP
      		endif
      	    enddo
	enddo
 	close(lunREAD)
999     format(x/'error reading grid point (i,j,k) = ('i4','i4','
     +        i4')'/'iostat = 'i4/)


c da die Anodenbereiche bei RELAX3D negativ kodiert sind, nimm die
c Absolutbetraege:

	ihelp = 0
	do k=0, kmax
	    do j=0, jmax
		do i=0, imax
c		    map(i,j,k) = abs(map(i,j,k))
		    map(ihelp) = abs(map(ihelp))
		    ihelp = ihelp + 1
		enddo
	    enddo
	enddo


	RETURN


	END


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


	OPTIONS /EXTEND_SOURCE

	SUBROUTINE ADD_MAP_6
c	====================

        IMPLICIT NONE

	character*1 Nr
	parameter (Nr='6')

	INCLUDE 'accel$sourcedirectory:MAP_DEF_6.INC'
	INCLUDE 'accel$sourcedirectory:COM_HVs.INC'
	INCLUDE 'accel$sourcedirectory:COM_DIRS.INC'
	INCLUDE 'accel$sourcedirectory:COM_ACCEL.INC'

	real	  read_memory(0:100)
	COMMON   /read_memory/ read_memory	! COMMON nur, damit nicht jede
						! Mappe extra Speicher belegt.

	integer   i,j,k, ihelp, iostat


c Einlesen der '_Tgt_Nr'-Potentialmappe:

	if (mappenName.EQ.'RUN9') then
	    open (lunRead,file='RUN6_NEW_Tgt_'//Nr,
     +		     defaultfile=mappenDir//':.MAPPE',status='old',
     +		     form='unformatted',recl=imax+1,readonly)
c     +               form='unformatted',recl=imax,readonly)
	else
	    open (lunRead,file=mappenName//'_Tgt_'//Nr,
     +		     defaultfile=mappenDir//':.MAPPE',status='old',
     +		     form='unformatted',recl=imax+1,readonly)
c     +               form='unformatted',recl=imax,readonly)
	endif
	write(*,*) 'constructing map '//Nr//' ...'
	do k = 0, kmax
      	    do j = 0, jmax
c      		read(lunREAD,iostat=iostat) (map(i,j,k),i=0,imax)
		ihelp = (k*(jmax+1)+j)*(imax+1)
      		read(lunREAD,iostat=iostat) (map(ihelp+i),i=0,imax)
      		if (iostat.NE.0) then
		    write(*,*)
      		    write(*,999) i,j,k,iostat
		    STOP
      		endif
     	    enddo
	enddo
 	close(lunREAD)
999     format(x/'error reading grid point (i,j,k) = ('i4','i4','
     +        i4')'/'iostat = 'i4/)


c Angleichen der Potentialmappe an UTgt:

	ihelp = 0
	do k=0, kmax
	    do j=0, jmax
		do i=0, imax
c		    map(i,j,k) = UTgt*abs(map(i,j,k))
		    map(ihelp) = UTgt*abs(map(ihelp))
		    ihelp = ihelp + 1
 		enddo
	    enddo
	enddo


c Einlesen der '_Gua_Nr'-Potentialmappe und Angleichen an UGua:

	if (freeGuard) then
	    open (lunRead,file=mappenName//'_Gua_'//Nr,
     +		 defaultfile=mappenDir//':.MAPPE',status='old',
     +		 form='unformatted',recl=imax+1,readonly)
c     +           form='unformatted',recl=imax,readonly)
	    ihelp = 0
	    do k = 0, kmax
		do j = 0, jmax
		    read(lunRead,iostat=iostat) (read_memory(i),i=0,imax)
		    if (iostat.NE.0) then
			write(*,*) 
			write(*,999) i,j,k,iostat
			STOP
		    endif
		    do i=0, imax
			map(ihelp) = map(ihelp) + UGua*abs(read_memory(i))
			ihelp = ihelp + 1
		    enddo
		enddo
	    enddo
	    close(lunREAD)
	endif


c Einlesen der '_Gi1_Nr'-Potentialmappe und Angleichen an UG1:

	open (lunRead,file=mappenName//'_Gi1_'//Nr,
     +		 defaultfile=mappenDir//':.MAPPE',status='old',
     +		 form='unformatted',recl=imax+1,readonly)
c     +           form='unformatted',recl=imax,readonly)
	ihelp = 0
	do k = 0, kmax
      	    do j = 0, jmax
      		read(lunRead,iostat=iostat) (read_memory(i),i=0,imax)
      		if (iostat.NE.0) then
		    write(*,*)
      		    write(*,999) i,j,k,iostat
		    STOP
      		endif
		do i=0, imax
		    map(ihelp) = map(ihelp) + UG1*abs(read_memory(i))
		    ihelp = ihelp + 1
		enddo
      	    enddo
	enddo
 	close(lunREAD)


	RETURN


	END


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


	OPTIONS /EXTEND_SOURCE

	SUBROUTINE INTEGRATIONSSTEP_RUNGE_KUTTA_6(dt)
c	=============================================

        IMPLICIT NONE
	SAVE

	character*1 Nr
	parameter (Nr='6')

c Diese Subroutine berechnet zu einem vorgegebenen Zeitschritt dt den
c Integrationsschritt zweimal: einmal direkt mit dt und einmal ueber zwei
c aufeinanderfolgende Schritte mit dt/2. (die beiden dt/2-Schritte werden
c zuerst ausgefuehrt).
c
c Aus der Differenz der beiden Resultate wird eine Abschaetzung fuer den Fehler
c des dt-Schrittes gewonnen, die dazu verwendet wird zu entscheiden, ob der
c Integrationsschritt mit einem verkuerzten Zeitintervall wiederholt werden
c muss, oder ob das Zeitintervall fuer den folgenden ausgedehnt werden kann.
c
c Die beiden Einzelergebnisse aus dem dt- und den beiden dt/2-Schritten, die
c jeweils ueber Runge-Kutta-Rechnung vierter Ordnung erhalten werden, werden
c zum Schluss noch zusammengenommen, um ein Resultat mit Genauigkeit fuenfter
c Ordnung in dt zu erhalten.
c
c Der ganze Ablauf entspricht den Ausfuehrungen in Kapitel 15.2 der NUMERICAL
c RECIPIES: 'Adaptive Stepsize Control for Runge-Kutta' (vgl. Referenz im
c fileheader von 'ACCEL.FOR')


	INCLUDE 'accel$sourcedirectory:COM_ACCEL.INC'
	INCLUDE 'accel$sourcedirectory:MAP_DEF_6.INC'

	integer i			  ! Zaehlvariable

	real dt,dt_half			  ! zeitl. Aenderung, halbe zeitl. Aenderung
	real EFeld0(3), EFeld1(3)	  ! elektr. Felder
	real x1(3),Dx1(3),Dx2(3)	  ! fuer Ortsintegration
	real v1(3),Dv1(3),Dv2(3)	  ! fuer Geschw.Integration
	real xDifferenz(3), vDifferenz(3)

	real maxErr_x,maxErr_v,maxErr	  ! fuer Fehlerbetrachtung

	real errCon, safety		  ! fuer Schrittweitenkontrolle
	real pShrink, pGrow		  ! fuer Schrittweitenkontrolle

	PARAMETER (errCon  = 6.e-4, safety =  .9)   ! vgl. Referenz
	PARAMETER (pShrink = -.25,  pGrow  = -.2)
	! errCon = (4./safety)**(1/pGrow)

	logical flag_dtSmall		  ! wenn dt kleiner als dtsmall ist und
					  ! der Fehler immer noch zu gross ist.

	integer returnCode_EFeld
	COMMON /returnCode_EFeld/ returnCode_EFeld
		!   1: Testort hinter der Mappe
		!   2: Testort neben der Mappe
		!   3: Testort vor der Mappe

	logical flag_hang
	COMMON /flag_hang/ flag_hang

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

	flag_dtSmall = .false.		  ! flag resetten
	if (dt.lt.dtsmall) dt = dtsmall

c berechne EFeld am aktuellen Ort. Speichere in EFeld0, damit sie wiederverwendet
c werden kann, falls mit kuerzerem Zeitschritt wiederholt werden muss:

	call EFeld_6(x,EFeld0,*999)

c...............................................................................
10	continue    ! hier gehts wieder von vorne los, falls Zeitschritt dt
		    ! abgeaendert werden muss.

	dt_half = dt / 2.


c mache ersten dt/2 - Schritt:

	call SINGLESTEP_RUNGE_KUTTA_6(dt_half,EFeld0,x,v, Dx1,Dv1 ,*999)


c berechne EFeld bei x1:

	x1(1) = x(1) + Dx1(1)
	x1(2) = x(2) + Dx1(2)
	x1(3) = x(3) + Dx1(3)

	v1(1) = v(1) + Dv1(1)
	v1(2) = v(2) + Dv1(2)
	v1(3) = v(3) + Dv1(3)

	call EFeld_6(x1,EFeld1,*999)


c mache zweiten dt/2 - Schritt:

	call SINGLESTEP_RUNGE_KUTTA_6(dt_half,EFeld1,x1,v1, Dx2,Dv2 ,*999)


c Summiere Ergebnisse der beiden dt/2 -Schritte und speichere in Dx1, Dv1:

	Dx1(1) = Dx1(1) + Dx2(1)
	Dx1(2) = Dx1(2) + Dx2(2)
	Dx1(3) = Dx1(3) + Dx2(3)

	Dv1(1) = Dv1(1) + Dv2(1)
	Dv1(2) = Dv1(2) + Dv2(2)
	Dv1(3) = Dv1(3) + Dv2(3)


c mache dt - Schritt:

	call SINGLESTEP_RUNGE_KUTTA_6(dt,EFeld0,x,v, Dx2,Dv2 ,*999)


c . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . 

c Fehlerbetrachtung und gegebenenfalls Berechnung von neuem Ort und neuer
c Geschwindigkeit (falls der Fehler ausserhalb der Toleranz liegt wird Zeit-
c schritt dt verkuerzt und bei Label 10 erneut begonnen):

c Zaehle die Schritte:

	steps = Steps + 1


c Fehlerbetrachtung:

c der groesste (absolute bzw. relative) Fehler im Ort soll kleiner als eps_x
c sein, der groesste Fehler in der Geschwindigkeit kleiner als eps_v:
c -> Bestimme den jeweils groessten Fehler der drei Komponenten des Ortes und
c    der Geschwindigkeit (dh. die groesste Differenz der Aederungen):

	maxErr_x = 0.
	maxErr_v = 0.

	do i = 1, 3
	    xDifferenz(i) = Dx1(i)-Dx2(i)
	    vDifferenz(i) = Dv1(i)-Dv2(i)
	    if (log_relativ) then
		if (Dx1(i).NE.0.) maxErr_x = Max(maxErr_x,Abs(xDifferenz(i)/Dx1(i)))
		if (Dv1(i).NE.0.) maxErr_v = Max(maxErr_v,Abs(vDifferenz(i)/Dv1(i)))
	    else
		maxErr_x = Max(maxErr_x,Abs(xDifferenz(i)))
		maxErr_v = Max(maxErr_v,Abs(vDifferenz(i)))
	    endif
	enddo

c - Skaliere den jeweils groessten relativen Fehler auf das jeweilige Epsilon:

	maxErr_x = maxErr_x / eps_x
	maxErr_v = maxErr_v / eps_v

c . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . 

c der groessere der beiden reskalierten Fehler bestimmt, ob der Integrations-
c schritt mit kleinerem Zeitintervall wiederholt werden muss, bzw. um welchen
c Faktor das Zeitintervall fuer den naechsten Schritt vergroessert werden kann:

c Liegt der Fehler ausserhalb des Toleranzbereiches und ist dt bereits jetzt
c kleiner als dtsmall, so mache keinen neuen Versuch sondern akzeptiere als Not-
c loesung den bestehenden Naeherungswert. Setze dt in diesem Fall als Default
c fuer den kommenden Integrationsschritt auf dtsmall. Setze aber auch das flag
c 'flag_dtsmall', damit gezaehlt werden kann, wie oft dieses Prozedur fuer ein
c bestimmtes Teilchen angewendet werden muss. Ist dies zu oft der Fall, so brich
c diese Trajektorienberechnung ganz ab (-> destiny = code_dtsmall).
c (2. Teil erfolgt weiter unten)

	maxErr = Max(maxErr_x,maxErr_v)

	if (maxErr.GT.1.) then
	    if (dt.LT.dtsmall) then	! Fehler immer noch zu gross, obwohl
		flag_dtsmall = .true.	!    dtsmall schon unterschritten ist
	    else
		!c  Bestimme kuerzeren Zeitschritt fuer neuen Versuch (vgl. Referenz):
		dt = safety * dt * (maxErr**pShrink)
		goto 10
	    endif
	endif


c Nimm die Ergebnisse aus dem dt-Schritt und den beiden dt/2-Schritten und
c berechne damit den neuen Ort und die neue Geschwindigkeit mit Genauigkeit
c fuenfter Ordnung in dt:

	x(1) = x(1) + Dx1(1) + xDifferenz(1) / 15.
	x(2) = x(2) + Dx1(2) + xDifferenz(2) / 15.
	x(3) = x(3) + Dx1(3) + xDifferenz(3) / 15.

	v(1) = v(1) + Dv1(1) + vDifferenz(1) / 15.
	v(2) = v(2) + Dv1(2) + vDifferenz(2) / 15.
	v(3) = v(3) + Dv1(3) + vDifferenz(3) / 15.


c alten Zeitschritt addieren:

	t = t + dt


c neuen Zeitschritt so gross wie sinnvoller weise moeglich machen:

	if (flag_dtSmall) then
	    if (n_dtsmall.LT.maxBelowDtSmall) then
		dt = dtSmall			  ! fuer naechsten RK-Schritt
		n_dtsmall = n_dtsmall + 1
	    else
		destiny = code_dtsmall		  ! gib Teilchen verloren
		RETURN
	    endif
	else
	    if (maxErr.GT.errCon) then
		dt = safety * dt * (maxErr**pGrow) 	! vgl. Referenz
	    else
		dt = 4. * dt	! <- Vergroesserung des Zeitschritts max. um
	    endif		!    Faktor 4!
	    ! pruefen, ob Maximallaenge fuer ersten Testschritt nicht ueberschritten ist:
	    if (log_confine) dt = min(dt,dl_max/sqrt(v(1)*v(1)+v(2)*v(2)+v(3)*v(3)))
	endif


	RETURN


c hier folgt der Code fuer 'returnCode_EFeld.NE.0', also fuer den Fall, dass
c bei der Berechnung des Feldes eine Fehlersituation auftrat:

c - Fehler trat auf bei Berechnung des EFeldes am aktuellen Teilchenort oder
c   an einem Testort:

999	if (returnCode_EFeld.EQ.2) then
	    destiny = code_neben_Mappe
	elseif (returnCode_EFeld.EQ.3) then
	    destiny = code_reflektiert
	    if (v(1).GT.0) then	  ! in Vorwaertsbewegung -> sollte nicht vorkommen!!
		write(*,*)
		write(*,*) 'Mappe '//Nr//':'
		write(*,*)
		write(*,*)'   Test-x liegt vor der Mappe!'
		write(*,*)'   t                   = ',t
		write(*,*)'   x                   = ',x
		write(*,*)'   v                   = ',v
		write(*,*)'   Teilchen-Nr         = ',Start_Nr
		write(*,*)
	    endif
	elseif (returnCode_EFeld.NE.0) then
	    write(*,*)
	    write(*,*) 'SINGLESTEP_RUNGE_KUTTA_'//Nr//': '
	    write(*,*) 'unallowed value of ''returnCode_EFeld'': ',returnCode_Efeld
	    write(*,*) '-> STOP'
	    write(*,*)
	    STOP
	endif


	END


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


	OPTIONS /EXTEND_SOURCE

	SUBROUTINE SINGLESTEP_RUNGE_KUTTA_6(dt,E0,x0,v0, Dx,Dv, *)
c	==========================================================

        IMPLICIT NONE

c Diese Subroutine berechnet bei vorgegebenem Zeitschritt einen einzelnen 
c Runge-Kutta-Integrationsschritt (4. Ordnung).
c Die Vorgehensweise entspricht den Ausfuehrungen in Kapitel 15.1 der
c NUMERICAL RECIPIES: 'Runge-Kutta Method'.

c Zurueckgegeben werden die errechneten Orts- und Geschwindigkeitsaenderungen
c anstatt direkt der neuen Werte, da sonst vor allem bei den Ortskoordinaten
c Schwierigkeiten auftreten koennen, wenn in der Subroutine 'INTEGRATIONSSTEP_
c RUNGE_KUTTA' aus der Differenz der neuen Werte aus den beiden dt/2- und dem
c dt-Schritt der Fehler abgeschaetzt werden soll (kleine Differenz moeglicher-
c weise grosser Werte).


	real Beschl_Faktor
	COMMON /Beschl_Faktor/ Beschl_Faktor

	real E0(3), x0(3), v0(3)	  ! Eingangsgroessen
	real E1(3), E2(3), E3(3)	  ! E-Felder an Testorten
	real v1(3), v2(3), v3(3)	  ! Geschwindigkeiten an Testorten
	real dt,dt_half,dt_sixth	  ! zeitl. Aenderung, dt/2, dt/6
	real help, help_half, help_sixth  ! Hilfsvariable, help/2, help/6
	real xTest(3)			  ! Test-Orte
	real Dx(3), Dv(3)		  ! Ergebnisspeicher

	integer i			  ! Zaehlvariable

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

	dt_half    = dt   / 2.
	dt_sixth   = dt   / 6.
	help       = Beschl_Faktor * dt
	help_half  = help / 2.
	help_sixth = help / 6.

	do i = 1, 3
	    xTest(i) = x0(i) + v0(i) * dt_half 
	    v1(i)    = v0(i) + E0(i) * help_half
	enddo
	call EFeld_6(xTest,E1,*999)

	do i = 1, 3
	    xTest(i) = x0(i) + v1(i) * dt_half 
	    v2(i)    = v0(i) + E1(i) * help_half
	enddo
	call EFeld_6(xTest,E2,*999)

	do i = 1, 3
	    xTest(i) = x0(i) + v2(i) * dt 
	    v3(i)    = v0(i) + E2(i) * help
	enddo
	call EFeld_6(xTest,E3,*999)

	do i = 1, 3
	    Dx(i) = (v0(i) + 2.*(v1(i)+v2(i)) + v3(i)) * dt_sixth
	    Dv(i) = (E0(i) + 2.*(E1(i)+E2(i)) + E3(i)) * help_sixth
	enddo

	RETURN

999	RETURN 1


	END


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


	OPTIONS /EXTEND_SOURCE

	SUBROUTINE EFeld_6(x,E,*)
c       =========================

	IMPLICIT NONE

        INCLUDE 'accel$sourcedirectory:MAP_DEF_6.INC'
        INCLUDE 'accel$sourcedirectory:CALC_FIELD_1.INC'

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

c Rechne in Gittereinheiten um:

	real_i = (x(1)-xmin)	    / Dx_
	real_j = abs(x(2))	    / Dy_
	real_k = abs(x(3))	    / Dz_

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

c Mache die Tests und berechne die Feldstaerke:

c Teste, ob Raumpunkt innerhalb der Potentialmappe liegt:

	if (real_j.GT.jmax .OR. real_k.GT.kmax) then
	    returnCode_EFeld = 2
	    RETURN 1
	elseif (real_i.GT.imax) then
	    E(1) = 0.
	    E(2) = 0.			    ! Spezialbehandlung bei Mappe 6 !
	    E(3) = 0.
	    RETURN
	elseif (real_i.LT.0.) then
	    if (real_i.GE.-.1e-6) then
		real_i = 0.
	    else
		returnCode_EFeld = 3
		RETURN 1
	    endif
	endif


c Bestimme naechstgelegene Stuetzstellen (stuetzstelle_q(n)) und die
c Komponenten des Abstands-Gittervektors zur allernaechsten Stuetzstelle
c (Abstand_q) sowie deren Betraege:

	stuetzstelle_i(1) = nint(real_i)
        Abstand_i = real_i - stuetzstelle_i(1) ! Abstand zur naeheren Stuetzstelle
	Abstand_i_Betrag = abs(Abstand_i)
	if (Abstand_i.gt.0.) then
            stuetzstelle_i(2) = stuetzstelle_i(1) + 1
	elseif (Abstand_i.lt.0.) then
            stuetzstelle_i(2) = stuetzstelle_i(1) - 1
        else
            stuetzstelle_i(2) = stuetzstelle_i(1)
        endif

        stuetzstelle_j(1) = nint(real_j)
        Abstand_j = real_j - stuetzstelle_j(1)
	Abstand_j_Betrag = abs(Abstand_j)
        if (Abstand_j.gt.0.) then
            stuetzstelle_j(2) = stuetzstelle_j(1) + 1
	elseif (Abstand_j.lt.0.) then
            stuetzstelle_j(2) = stuetzstelle_j(1) - 1
        else
            stuetzstelle_j(2) = stuetzstelle_j(1)
        endif

        stuetzstelle_k(1) = nint(real_k)
        Abstand_k = real_k - stuetzstelle_k(1)
	Abstand_k_Betrag = abs(Abstand_k)
        if (Abstand_k.gt.0.) then
            stuetzstelle_k(2) = stuetzstelle_k(1) + 1
	elseif (Abstand_k.lt.0.) then
            stuetzstelle_k(2) = stuetzstelle_k(1) - 1
        else
            stuetzstelle_k(2) = stuetzstelle_k(1)
        endif


c...............................................................................
c Berechnen des elektrischen Feldes:
c ----------------------------------
c
c In dieser Version wird nicht mehr vorausgesetzt, dass das Potential auf den
c Mappenraendern Null ist!
c Bei der Berechnung der Feldstaerke ist angenommen, dass die xy-Ebene (k==0)
c und die xz-Ebene (j==0) Symmetrieebenen sind:
c 
c 		map(i,-j,k) == map(i,j,k).
c 		map(i,j,-k) == map(i,j,k).
c
c Entlang j=0 ist also E(2)=0, entlang k=0 ist E(3)=0.
c
c (In der vorliegenden Version ist map(i,j,k) durch 
c	map(  k*(jmax+1)*(imax+1) + j*(imax+1) + i)  =
c	map( (k*(jmax+1) + j)*(imax+1) + i)
c zu ersetzen!)
c (i,j,k laufen von 0 weg, ebenso wie die Indizierung von 'map')
c...............................................................................

c Berechne in den beiden naechstgelegenen k-Ebenen die x-Komponente der Feld-
c staerke. Danach berechne tatsaechlichen Wert aus linearer Interpolation. Um
c die Feldstaerken in den einzelnen k-Ebenen zu bekommen, interpoliere jeweils
c linear zwischen den Werten auf den beiden naechstgelegenen j-Ketten der
c jeweiligen k-Ebene:

	i = stuetzstelle_i(1)

	do m = 1, 2
	    k = stuetzstelle_k(m)
	    do n = 1, 2
		j = stuetzstelle_j(n)
		ihelp = (k*(jmax+1)+ j)*(imax+1) + i
		if (i.EQ.imax) then
c		    E__(n) =  map(imax-1,j,k) - map(imax,j,k)
		    E__(n) =  map(ihelp-1)     - map(ihelp  )
		elseif (i.GT.0) then
c		    E__(n) = (-0.5+Abstand_i)*(map(i,j,k)-map(i-1,j,k))
c     +			   + ( 0.5+Abstand_i)*(map(i,j,k)-map(i+1,j,k))
		    E__(n) = (-0.5+Abstand_i)*(map(ihelp)-map(ihelp-1))
     +			   + ( 0.5+Abstand_i)*(map(ihelp)-map(ihelp+1))
		else
c		    E__(n) =  map(0,j,k) - map(1,j,k)
		    E__(n) =  map(ihelp) - map(ihelp+1)
		endif
	    enddo
	    E_(m) = E__(1) + Abstand_j_Betrag*(E__(2)-E__(1))
	enddo
	E(1) = E_(1) + Abstand_k_Betrag*(E_(2)-E_(1))

	E(1) = E(1) / Dx_	! Reskalierung entsprechend x-Gitterkonstanten


c Berechne die y-Komponente der Feldstaerke:

	j = stuetzstelle_j(1)

	do m = 1, 2
	    k = stuetzstelle_k(m)
	    do n = 1, 2
		i = stuetzstelle_i(n)
		ihelp = (k*(jmax+1)+ j)*(imax+1) + i
		if (j.EQ.jmax) then
c		    E__(n) =  map(i,jmax-1,k) - map(i,jmax,k)
		    E__(n) =  map(ihelp-(imax+1)) - map(ihelp)
		elseif (j.GT.0) then
c		    E__(n) = (-0.5+Abstand_j)*(map(i,j,k)-map(i,j-1,k))
c     +			   + ( 0.5+Abstand_j)*(map(i,j,k)-map(i,j+1,k))
		    E__(n) = (-0.5+Abstand_j)*(map(ihelp)-map(ihelp-(imax+1)))
     +			   + ( 0.5+Abstand_j)*(map(ihelp)-map(ihelp+(imax+1)))
		else   ! j=0 -> map(i,j-1,k) = map(i,j+1,k) == map(i,1,k)
c		    E__(n) = 2.0*Abstand_j*(map(i,0,k)-map(i,1,k))
		    E__(n) = 2.0*Abstand_j*(map(ihelp)-map(ihelp+(imax+1)))
		endif
	    enddo
	    E_(m) = E__(1) + Abstand_i_Betrag*(E__(2)-E__(1))
	enddo
	E(2) = E_(1) + Abstand_k_Betrag*(E_(2)-E_(1))

	E(2) = E(2) / Dy_	! Reskalierung entsprechend y-Gitterkonstanten
	if (x(2).LT.0) E(2) = -E(2)


c Berechne die z-Komponente der Feldstaerke:

	k = stuetzstelle_k(1)

	do m = 1, 2
	    j = stuetzstelle_j(m)
	    do n = 1, 2
		i = stuetzstelle_i(n)
		ihelp = (k*(jmax+1)+ j)*(imax+1) + i
		if (k.EQ.kmax) then
c		    E__(n)=  map(i,j,kmax-1) - map(i,j,kmax)
		    E__(n) =  map(ihelp-(jmax+1)*(imax+1)) - map(ihelp)
		elseif (k.GT.0) then
c		    E__(n) = (-0.5+Abstand_k)*(map(i,j,k)-map(i,j,k-1))
c     +			   + ( 0.5+Abstand_k)*(map(i,j,k)-map(i,j,k+1))
		    E__(n) = (-0.5+Abstand_k)*(map(ihelp)-map(ihelp-(jmax+1)*(imax+1)))
     +			   + ( 0.5+Abstand_k)*(map(ihelp)-map(ihelp+(jmax+1)*(imax+1)))
		else   ! k=0 -> map(i,j,k-1) = map(i,j,k+1) == map(i,j,1)
c		    E__(n) = 2.0*Abstand_k*(map(i,j,0)-map(i,j,1))
		    E__(n) = 2.0*Abstand_k*(map(ihelp)-map(ihelp+(jmax+1)*(imax+1)))
		endif
	    enddo
	    E_(m) = E__(1) + Abstand_i_Betrag*(E__(2)-E__(1))
	enddo
	E(3) = E_(1) + Abstand_j_Betrag*(E_(2)-E_(1))

	E(3) = E(3) / Dz_	! Reskalierung entsprechend z-Gitterkonstanten
	if (x(3).LT.0) E(3) = -E(3)

cd	write(18,*)'x,E = ',x,E


 	END


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

	OPTIONS /EXTEND_SOURCE

	SUBROUTINE ERROR_MESSAGE_AND_STOP(text1,text2)
c	==============================================

	character*(*) text1,text2

	write(*,*)
	write(*,*) ' ERROR MESSAGE FROM SUBROUTINE '//text1
	write(*,*)
	write(*,*) ' >>> '//text2
	write(*,*)
	write(*,*) ' -> STOP'
	write(*,*)
	call exit

	END


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