musrsim/accel/src/SUB_INTEGR_3.FOR

554 lines
16 KiB
Fortran

OPTIONS /EXTEND_SOURCE
SUBROUTINE READ_INFO_3
c ======================
IMPLICIT NONE
character*1 Nr
parameter (Nr='3')
INCLUDE 'accel$sourcedirectory:MAP_DEF_3.INC'
INCLUDE 'accel$sourcedirectory:READ_INFO.INC'
END
c===============================================================================
OPTIONS /EXTEND_SOURCE
SUBROUTINE READ_MAP_3
c =====================
IMPLICIT NONE
character*1 Nr
parameter (Nr='3')
INCLUDE 'accel$sourcedirectory:MAP_DEF_3.INC'
INCLUDE 'accel$sourcedirectory:READ_MAP.INC'
END
c===============================================================================
OPTIONS /EXTEND_SOURCE
SUBROUTINE ADD_MAP_3
c ====================
IMPLICIT NONE
character*1 Nr
parameter (Nr='3')
INCLUDE 'accel$sourcedirectory:MAP_DEF_3.INC'
INCLUDE 'accel$sourcedirectory:ADD_MAP.INC'
END
c===============================================================================
OPTIONS /EXTEND_SOURCE
SUBROUTINE INTEGRATIONSSTEP_RUNGE_KUTTA_3(dt)
c =============================================
IMPLICIT NONE
SAVE
character*1 Nr
parameter (Nr='3')
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_3.INC'
real help
real dt_save
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 x_1 ! Hilfsvariable fuer testweises x(1)
real a ! Beschleunigung
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.
logical found_lower_upp ! obere und untere Grenze fuer dt um
logical found_upper_upp ! Uebergabebereich zu treffen
logical found_lower_low ! obere und untere Grenze fuer dt um
logical found_upper_low ! Uebergabebereich zu treffen
real dtlower,dtupper
integer returnCode_EFeld
COMMON /returnCode_EFeld/ returnCode_EFeld
! 1: Testort hinter der Mappe
! 2: Testort neben der Mappe
! 3: Testort vor der Mappe
c - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
flag_dtSmall = .false. ! flag resetten
found_lower_upp = .false.
found_upper_upp = .false.
found_lower_low = .false.
found_upper_low = .false.
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_3(x,EFeld0,*998)
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_3(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_3(x1,EFeld1,*999)
c mache zweiten dt/2 - Schritt:
call SINGLESTEP_RUNGE_KUTTA_3(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_3(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):
INCLUDE 'accel$sourcedirectory:RUNGE_KUTTA.INC'
RETURN
c Einsprungposition fuer den Fall, dass x(1) jetzt im Bereich einer halben
c Stuetzstelle vor dem Mappenende liegt und die momentane Geschwindigkeit
c in positiver x-Richtung geht.
c -> Berechne naeherungsweise den Schnittpunkt der Trajektorie mit dem Mappen-
c ende (x=xmax) unter der Annahme eines konstanten mittleren EFeldes.
c Beruecksichtige dabei die Moeglichkeit, dass das Teilchen noch vor dem
c Mappenende reflektiert werden koennte:
7766 continue
call EFeld_3(x,EFeld0,*997) ! Efeld am aktuellen Ort
! a == Beschleunigung bei x in x-Richtung
a = EFeld0(1)*Beschl_Faktor
! help == Radiant in entsprechender 'Mitternachtsformel'
help = v(1)*v(1) + 2.*a*(xmax-x(1))
if (help.LT.0) then ! noch vor Mappenende reflektiert
reachedEndOfMap = .false.
dt = dt_save ! dt restaurieren
goto 3454 ! Festlegen des neuen dt, RETURN
else
! dt == Zeit bis Mappenende
if (a.NE.0) then
dt = (sqrt(help) - v(1))/a
else
dt = (xmax-x(1))/v(1)
endif
if (dt.lt.0) write(*,*) 'warning 1: dt<0: dt = ',dt
endif
d x1(1) = x(1)+v(1)*dt+.5*a*dt*dt
d if (x1(1).NE.xmax) then
d write(*,*)' x1(1),x1(1)-xmax = ',x1(1),x1(1)-xmax
x1(1) = xmax
d endif
x1(2) = x(2)+v(2)*dt+.5*Efeld0(2)*Beschl_Faktor*dt*dt
x1(3) = x(3)+v(3)*dt+.5*Efeld0(3)*Beschl_Faktor*dt*dt
call EFeld_3(x1,EFeld1,*997) ! Efeld am naeherungsweisen Schnittpunkt
EFeld0(1) = (EFeld0(1)+EFeld1(1))/2. ! Mittelwert berechnen
EFeld0(2) = (EFeld0(2)+EFeld1(2))/2.
EFeld0(3) = (EFeld0(3)+EFeld1(3))/2.
! wiederhole Berechnung mit mittlerem EFeld:
! a == Beschleunigung mit mittlerem EFeld in x-Richtung
a = EFeld0(1)*Beschl_Faktor
! help == Radiant in entsprechender 'Mitternachtsformel'
help = v(1)*v(1) + 2.*a*(xmax-x(1))
if (help.LT.0) then ! noch vor Mappenende reflektiert
reachedEndOfMap = .false.
dt = dt_save ! dt restaurieren
goto 3454 ! Festlegen des neuen dt, RETURN
else
! dt == Zeit bis Mappenende
if (a.NE.0) then
dt = (sqrt(help) - v(1))/a
else
dt = (xmax-x(1))/v(1)
endif
if (dt.lt.0) write(*,*) 'warning 2: dt<0: dt = ',dt
endif
! Berechnen des neuen Ortes:
d x(1) = x(1)+v(1)*dt+.5*a*dt*dt
d if (x(1).NE.xmax) then
d write(*,*)' x(1),x(1)-xmax = ',x(1),x(1)-xmax
x(1) = xmax
d endif
x(2) = x(2)+v(2)*dt+.5*EFeld0(2)*Beschl_Faktor*dt*dt
x(3) = x(3)+v(3)*dt+.5*Efeld0(3)*Beschl_Faktor*dt*dt
! Berechnen der neuen Geschwindigkeit:
v(1) = v(1)+a*dt
v(2) = v(2)+Efeld0(2)*Beschl_Faktor*dt
v(3) = v(3)+Efeld0(3)*Beschl_Faktor*dt
! Berechnen der neuen Zeit:
t = t + dt
dt = dt_save ! Zeitschritt fuer Start in neue Mappe restaurieren
RETURN
c Einsprungposition fuer den Fall, dass x(1) jetzt im Bereich einer halben
c Stuetzstelle hinter dem Mappenanfang liegt und die momentane Geschwindigkeit
c in negativer x-Richtung geht.
c -> Berechne naeherungsweise den Schnittpunkt der Trajektorie mit dem Mappen-
c anfang (x=xmin) unter der Annahme eines konstanten mittleren EFeldes.
c Beruecksichtige dabei die Moeglichkeit, dass das Teilchen noch vor dem
c Mappenanfang reflektiert werden koennte:
7767 continue
call EFeld_3(x,EFeld0,*997) ! Efeld am aktuellen Ort
! a == Beschleunigung bei x in x-Richtung
a = EFeld0(1)*Beschl_Faktor
! help == Radiant in entsprechender 'Mitternachtsformel'
help = v(1)*v(1) + 2.*a*(xmin-x(1))
if (help.LT.0) then ! noch vor Mappenanfang reflektiert
reachedEndOfMap = .false.
dt = dt_save ! dt restaurieren
goto 3454 ! Festlegen des neuen dt, RETURN
else
! dt == Zeit bis Mappenanfang
if (a.NE.0) then
dt = (-sqrt(help) - v(1))/a
else
dt = (xmin-x(1))/v(1)
endif
if (dt.lt.0) write(*,*) 'warning 3: dt<0: dt = ',dt
endif
d x1(1) = x(1)+v(1)*dt+.5*a*dt*dt
d if (x1(1).NE.xmin) then
d write(*,*)' x1(1),x1(1)-xmin = ',x1(1),x1(1)-xmin
x1(1) = xmin
d endif
x1(2) = x(2)+v(2)*dt+.5*Efeld0(2)*Beschl_Faktor*dt*dt
x1(3) = x(3)+v(3)*dt+.5*Efeld0(3)*Beschl_Faktor*dt*dt
call EFeld_3(x1,EFeld1,*997) ! Efeld am naeherungsweisen Schnittpunkt
EFeld0(1) = (EFeld0(1)+EFeld1(1))/2. ! Mittelwert berechnen
EFeld0(2) = (EFeld0(2)+EFeld1(2))/2.
EFeld0(3) = (EFeld0(3)+EFeld1(3))/2.
! wiederhole Berechnung mit mittlerem EFeld:
! a == Beschleunigung mit mittlerem EFeld in x-Richtung
a = EFeld0(1)*Beschl_Faktor
! help == Radiant in entsprechender 'Mitternachtsformel'
help = v(1)*v(1) + 2.*a*(xmin-x(1))
if (help.LT.0) then ! noch vor Mappenanfang reflektiert
reachedEndOfMap = .false.
dt = dt_save ! dt restaurieren
goto 3454 ! Festlegen des neuen dt, RETURN
else
! dt == Zeit bis Mappenanfang
if (a.NE.0) then
dt = (-sqrt(help) - v(1))/a
else
dt = (xmin-x(1))/v(1)
endif
if (dt.lt.0) write(*,*) 'warning 4: dt<0: dt = ',dt
endif
! Berechnen des neuen Ortes:
d x(1) = x(1)+v(1)*dt+.5*a*dt*dt
d if (x(1).NE.xmin) then
d write(*,*)' x(1),x(1)-xmin = ',x(1),x(1)-xmin
x(1) = xmin
d endif
x(2) = x(2)+v(2)*dt+.5*EFeld0(2)*Beschl_Faktor*dt*dt
x(3) = x(3)+v(3)*dt+.5*Efeld0(3)*Beschl_Faktor*dt*dt
! Berechnen der neuen Geschwindigkeit:
v(1) = v(1)+a*dt
v(2) = v(2)+Efeld0(2)*Beschl_Faktor*dt
v(3) = v(3)+Efeld0(3)*Beschl_Faktor*dt
! Berechnen der neuen Zeit:
t = t + dt
dt = dt_save ! Zeitschritt fuer Start in neue Mappe restaurieren
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:
998 if (returnCode_EFeld.EQ.1) then
write(*,*) 'Mappe '//Nr//':'
write(*,*)' aktueller Teilchenort (nicht Testort!) hinter Potentialmappe!'
write(*,*)' -> STOP'
write(*,*)
STOP
endif
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:
999 if (returnCode_EFeld.EQ.1) then
if (.NOT.found_upper_upp) dt_save = dt
dtupper = dt
found_upper_upp = .true.
if (.NOT.found_lower_upp) then
dt = 0.5*dt
else
dt = (dtlower+dtupper)/2.
endif
goto 10
elseif (returnCode_EFeld.EQ.2) then
destiny = code_neben_Mappe
elseif (returnCode_EFeld.EQ.3) then
if (.NOT.found_upper_low) dt_save = dt
dtupper = dt
found_upper_low = .true.
if (.NOT.found_lower_low) then
dt = 0.5*dt
else
dt = (dtlower+dtupper)/2.
endif
goto 10
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
RETURN
c - Fehler trat auf im Zusammenhang von Berechnungen des Schnittpunktes der
c Trajektorie mit einer Mappenbegrenzung:
997 if (returnCode_EFeld.EQ.2) then
destiny = code_neben_Mappe
else
write(*,*) 'SINGLESTEP_RUNGE_KUTTA_'//Nr//': '
write(*,*) 'alternate Return from EFELD_'//Nr//' while calculating intersection'
write(*,*) 'of trajectory and x equals xmax line.'
write(*,*)
write(*,*)' returnCode_EFeld = ',returnCode_EFeld
write(*,*)' t = ',t
write(*,*)' x0 = ',x0
write(*,*)' v0 = ',v0
write(*,*)' E0 = ',E0
write(*,*)' theta0 = ',theta0
write(*,*)' phi0 = ',phi0
write(*,*)' x = ',x
write(*,*)' v = ',v
write(*,*)' Teilchen-Nr = ',Start_Nr
write(*,*)
write(*,*) '-> STOP'
write(*,*)
STOP
endif
END
c===============================================================================
OPTIONS /EXTEND_SOURCE
SUBROUTINE SINGLESTEP_RUNGE_KUTTA_3(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_3(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_3(xTest,E2,*999)
do i = 1, 3
xTest(i) = x0(i) + v2(i) * dt
v3(i) = v0(i) + E2(i) * help
enddo
call EFeld_3(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_3(x,E,*)
c =========================
IMPLICIT NONE
INCLUDE 'accel$sourcedirectory:MAP_DEF_3.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:
INCLUDE 'accel$sourcedirectory:CALC_FIELD_2.INC'
END
c===============================================================================