Help:Sandkasten
<fortran>
MODULE MODBF
CXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX c c MODUL: BODENFEUCHTEBERECHNUNG c ============================= c Systemzustände: [letzter Zeitschritt wird gespeichert] c Extern: c Intern: - c Attribute: CXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
USE MODCON
IMPLICIT none
! ------------------------------------------------------------- ! ----------------------- Oeffentlicher Teil ------------------ ! -------------------------------------------------------------
! --- Konstanten -> const.for ! --- Datentypen -> types.for ! --- Variablen ---
LOGICAL :: BF_error
LOGICAL :: BF_warn
! ------------------------------------------------------------- ! ----------------------- Privater Teil ----------------------- ! -------------------------------------------------------------
! --- Konstanten -> const.for
REAL, PARAMETER, PRIVATE :: BF_MODUL_VERSION = 1.0
c Berechnungskonstanten
REAL, PARAMETER, PRIVATE :: BF_MAX_BILERR = 0.01
REAL, PARAMETER, PRIVATE :: BF_DELTARATE = 0.001
REAL, PARAMETER, PRIVATE :: BF_DELTAX = 0.5
REAL, PARAMETER, PRIVATE :: BF_XMAX_FAKTOR = 1.0 + BF_DELTAX
REAL, PARAMETER, PRIVATE :: BF_YMAX_FAKTOR = FKT_MGRENZ *
+ BF_DELTAX
c Prozessfunktionen, Funktionsverläufe:
INTEGER, PARAMETER, PRIVATE :: BF_MAXSTZ = MAXSTZ !maximale Stuetzstellenzahl einer Funktion
INTEGER, PARAMETER, PRIVATE :: BF_STZ_START = 2 !Beginn der richtigen Funktionsverläufe
INTEGER, PARAMETER, PRIVATE :: BF_STZ_REST = 2 !Restliche Stützstellen nach Ende der richtigen Funktionsverläufe
INTEGER, PARAMETER, PRIVATE :: BF_FKTSTZ = BF_MAXSTZ !Anzahl Stützstellen für Funktionsverläufe
+ - BF_STZ_START+1
+ - BF_STZ_REST
REAL(KIND=8), PARAMETER, PRIVATE :: BF_LAST_YWERT = 0.0 !letzter (normierter) Y-Wert aller Funktionen
c Bodenaufbau / -Schichten: Anzahl, ID, Mindestdicken
INTEGER, PARAMETER, PRIVATE :: BF_MAX_SCHICHTEN = 6
INTEGER, PARAMETER, PRIVATE :: BOD_InfSchichtID = 1
INTEGER, PARAMETER, PRIVATE :: BOD_WESchichtID = 2
INTEGER, PARAMETER, PRIVATE :: BOD_TRSSchichtID = 3
REAL, PARAMETER, PRIVATE :: BOD_dInfSchicht = 0.2
REAL, PARAMETER, PRIVATE :: BOD_minD_WESchicht = 0.05
REAL, PARAMETER, PRIVATE :: BOD_minD_TRSSchicht = 0.05
REAL, PARAMETER, PRIVATE :: BOD_minDicke = BOD_dInfSchicht +
+ BOD_mind_WESchicht +
+ BOD_mind_TRSSchicht
! Bodenarten
INTEGER, PARAMETER, PRIVATE :: BF_ANZ_BOART = 3
INTEGER, PARAMETER, PRIVATE :: BF_TypSand = 1
INTEGER, PARAMETER, PRIVATE :: BF_TypSchluff = 2
INTEGER, PARAMETER, PRIVATE :: BF_TypTon = 3
! Bodenphysikalische Prozesse: Anzahl, ID, Bezeichnung, Vorzeichen, Berechnungskonstanten
INTEGER, PARAMETER, PRIVATE :: BF_ANZ_FKT = 6 + 1 !6 Bodenprozesse + 1 Funktion fuer Überlauf = Oberflächenabfluss oder Rückstau
INTEGER, PARAMETER, PRIVATE :: BF_ANZ_DGL = 5
INTEGER, PARAMETER, PRIVATE :: BF_LEN_FKTNAME = 6
! Bezug zu WP, FK, nFK, GPV ...
INTEGER, PARAMETER, PRIVATE :: BF_ANZ_BEZUG = 5
INTEGER, PARAMETER, PRIVATE :: wpBF = 1
INTEGER, PARAMETER, PRIVATE :: fkBF = 2
INTEGER, PARAMETER, PRIVATE :: nfkBF = 3
INTEGER, PARAMETER, PRIVATE :: gpvBF = 4
INTEGER, PARAMETER, PRIVATE :: lkBF = 5
! ID der Prozesse
INTEGER, PARAMETER, PRIVATE :: BF_ConstID = 0 !Konstanter Funktionsverlauf
INTEGER, PARAMETER, PRIVATE :: BF_InfID = 1 !Infiltration
INTEGER, PARAMETER, PRIVATE :: BF_ExxID = 2 !Exfiltration / Perkolation
INTEGER, PARAMETER, PRIVATE :: BF_IntID = 3 !Interflow
INTEGER, PARAMETER, PRIVATE :: BF_KapID = 4 !Kapillar Aufstieg
INTEGER, PARAMETER, PRIVATE :: BF_EvaID = 5 !Evaporation
INTEGER, PARAMETER, PRIVATE :: BF_EtaID = 6 !Transpiration
INTEGER, PARAMETER, PRIVATE :: BF_MaxID = 7 !Überlauffunktion wenn Bodenschicht voll ist
INTEGER, PARAMETER, PRIVATE :: BF_ZInID = 7 !Zufluss Interflow (wird nicht benutzt, nur bei RASTER)
! Vorzeichen
REAL, PARAMETER, PRIVATE :: BF_InfVorz = 1.0
REAL, PARAMETER, PRIVATE :: BF_ExxVorz = -1.0
REAL, PARAMETER, PRIVATE :: BF_IntVorz = -1.0
REAL, PARAMETER, PRIVATE :: BF_KapVorz = 1.0
REAL, PARAMETER, PRIVATE :: BF_EvaVorz = -1.0
REAL, PARAMETER, PRIVATE :: BF_EtaVorz = -1.0
REAL, PARAMETER, PRIVATE :: BF_MaxVorz = -1.0
REAL, PARAMETER, PRIVATE :: BF_ZInVorz = -1.0
! Verdunstungsansätze
REAL, PARAMETER, PRIVATE :: LNZ_HAUDEFAK_CONST = 0.135 !Faktor für unbewachsenen Boden
INTEGER, PARAMETER, PRIVATE :: EVA_HaudeID = 1
INTEGER, PARAMETER, PRIVATE :: EVA_BelmansID = 2
INTEGER, PARAMETER, PRIVATE :: EVA_PotentiellID = 3
INTEGER, PARAMETER, PRIVATE :: ETP_LinearID = 1
INTEGER, PARAMETER, PRIVATE :: ETP_AlbertID = 2
! --- Datentypen --- c Bodenart
TYPE BOA_type
REAL WP,
+ FK,
+ GPV,
+ KF,
+ MAXINF,
+ MAXKAP
INTEGER BOAID,
+ BOART
END TYPE
TYPE BOA_ptr_type
TYPE (BOA_type), POINTER :: ptrboa
END TYPE
TYPE (BOA_ptr_type),DIMENSION(:),ALLOCATABLE,PRIVATE :: BOACONT
c Bodentyp
TYPE BOD_type
REAL Dicke(BF_MAX_SCHICHTEN)
INTEGER BODID,
+ NBOA,
+ BoaID(BF_MAX_SCHICHTEN)
END TYPE
TYPE BOD_ptr_type
TYPE (BOD_type), POINTER :: ptrbod
END TYPE
TYPE (BOD_ptr_type),DIMENSION(:),ALLOCATABLE,PRIVATE :: BODCONT
c Landnutzung
TYPE LNZ_type
REAL HaudeFak(ANZMONATE),
+ WE,
+ BG,
+ BFI,
+ VG,
+ KST
INTEGER LNZID,
+ BGJGG,
+ BFIJGG,
+ HaudeFakJGG
END TYPE
TYPE LNZ_ptr_type
TYPE (LNZ_type), POINTER :: ptrlnz
END TYPE
TYPE (LNZ_ptr_type),DIMENSION(:),ALLOCATABLE,PRIVATE :: LNZCONT
! --- Variablen ---
LOGICAL, PRIVATE :: DLL_MODE
LOGICAL, PRIVATE :: BF_INIT
INTEGER, PRIVATE :: BOD_anz
INTEGER, PRIVATE :: BOD_aktanz
INTEGER, DIMENSION(:), ALLOCATABLE, PRIVATE :: BOD_ID
INTEGER, PRIVATE :: BOA_anz
INTEGER, PRIVATE :: BOA_aktanz
INTEGER, DIMENSION(:), ALLOCATABLE, PRIVATE :: BOA_ID
INTEGER, PRIVATE :: LNZ_anz
INTEGER, PRIVATE :: LNZ_aktanz
INTEGER, DIMENSION(:), ALLOCATABLE, PRIVATE :: LNZ_ID
!Start- Endepositionen Funktionsverläufe, Prozessnamen
REAL, DIMENSION(BF_ANZ_FKT),PRIVATE :: BF_VORZEICHEN
REAL, DIMENSION(BF_ANZ_FKT, BF_ANZ_BOART),
+ PRIVATE :: BF_FKT_StartX
REAL, DIMENSION(BF_ANZ_FKT, BF_ANZ_BOART),
+ PRIVATE :: BF_FKT_StartY
REAL, DIMENSION(BF_ANZ_FKT, BF_ANZ_BOART),
+ PRIVATE :: BF_FKT_EndeX
REAL, DIMENSION(BF_ANZ_FKT, BF_ANZ_BOART),
+ PRIVATE :: BF_FKT_EndeY
REAL, DIMENSION(BF_ANZ_FKT, BF_ANZ_BOART),
+ PRIVATE :: BF_FKT_EXPO
INTEGER, DIMENSION(BF_ANZ_FKT, BF_ANZ_BOART),
+ PRIVATE :: BF_FKT_StartBezug
INTEGER, DIMENSION(BF_ANZ_FKT, BF_ANZ_BOART),
+ PRIVATE :: BF_FKT_EndeBezug
CHARACTER(LEN=BF_LEN_FKTNAME), DIMENSION(BF_ANZ_FKT),
+ PRIVATE :: BF_FKTNAME
c Verdunstunsfaktoren
REAL, DIMENSION (ANZMONATE) :: LNZ_HAUDEFAK_GRAS
! --- Inits ---
DATA BF_error / .FALSE. /
DATA BF_warn / .FALSE. /
DATA DLL_MODE / .FALSE. /
DATA BF_INIT / .FALSE. /
DATA BOD_anz / 0 /
DATA BOD_aktanz / 0 /
DATA BOA_anz / 0 /
DATA BOA_aktanz / 0 /
DATA LNZ_anz / 0 /
DATA LNZ_aktanz / 0 /
! ------------------------------------------------------------- ! ----------------------- Methoden ---------------------------- ! -------------------------------------------------------------
CONTAINS
CXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX c Festlegen des Modus: DLL_MODE=false => Aufruf unter DOS c DLL_MODE=true => Aufruf unter WinNT c DLL - Statement
SUBROUTINE BF_MODE (MODE)
c .................................................................
LOGICAL :: MODE
c .................................................................
DLL_MODE = MODE
c ................................................................. 10000 RETURN
END SUBROUTINE BF_MODE
cxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
CXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX c Initialisiere die Funktionswerte fuer die Bodenfeuchtesimulation c DLL - Statement
SUBROUTINE BF_FKT_INI (LWRITE)
c .................................................................
LOGICAL :: LWRITE
c ................................................................. C -- Parameter fuer Funktionsermittlung sind wie folgende Matrix zu lesen C -- (negative Zahl deutet an: Eintrag wird nicht benutzt) C | infil, exfil, inter, kapauf, evap, transp, Überlauf c -----|--------------------------------------------------- C Sand | C Lehm | C Ton | c .................................................................
BF_INIT = .TRUE.
c Startwerte der einzelnen Prozesse in Bezug auf Bodenfeuchte c Änderung (HL, 11.03.2000): Wegen zu geringer Verdunstung aus Infil-Schicht c Original: evap = 1.0 wpBF fuer alle Zeilen
BF_FKT_StartX =
+ RESHAPE (
+ (/0.1, 0.40, 0.40, 1.0, 0.9, 0.01, 1.0,
+ 0.1, 0.70, 0.70, 1.0, 0.9, 0.01, 1.0,
+ 0.1, 0.75, 0.75, 1.0, 0.9, 0.01, 1.0 /),
+ (/BF_ANZ_FKT, BF_ANZ_BOART/))
c Bezug für die Startwerte der einzelnen Prozesse
BF_FKT_StartBezug =
+ RESHAPE (
+ (/ nfkBF, nfkBF, nfkBF, wpBF, wpBF, nfkBF, gpvBF,
+ nfkBF, nfkBF, nfkBF, wpBF, wpBF, nfkBF, gpvBF,
+ nfkBF, nfkBF, nfkBF, wpBF, wpBF, nfkBF, gpvBF /),
+ (/BF_ANZ_FKT, BF_ANZ_BOART/))
c Endwerte der einzelnen Prozesse in Bezug auf Bodenfeuchte c Änderung (HL, 11.03.2000): Wegen zu geringer Verdunstung aus Infil-Schicht c Original: evap = 0.9 nfkBF fuer alle Zeilen
BF_FKT_EndeX =
+ RESHAPE (
+ (/ 1.0, 0.70, 0.70, 0.40, 1.0, 1.0, BF_XMAX_FAKTOR,
+ 1.0, 0.83, 0.90, 0.70, 1.0, 1.0, BF_XMAX_FAKTOR,
+ 1.0, 0.85, 0.90, 0.75, 1.0, 1.0, BF_XMAX_FAKTOR /),
+ (/BF_ANZ_FKT, BF_ANZ_BOART/))
c Bezug der Endwerte der einzelnen Prozesse
BF_FKT_EndeBezug =
+ RESHAPE (
+ (/ gpvBF, nfkBF, nfkBF, nfkBF, wpBF, fkBF, gpvBF,
+ gpvBF, nfkBF, nfkBF, nfkBF, wpBF, fkBF, gpvBF,
+ gpvBF, nfkBF, nfkBF, nfkBF, wpBF, fkBF, gpvBF /),
+ (/BF_ANZ_FKT, BF_ANZ_BOART/))
c Funktionswerte der einzelnen Prozesse
BF_FKT_StartY =
+ RESHAPE (
+ (/1.0, 0.0, 0.0, 1.0, 0.0, 0.0, 0.0,
+ 1.0, 0.0, 0.0, 1.0, 0.0, 0.0, 0.0,
+ 1.0, 0.0, 0.0, 1.0, 0.0, 0.0, 0.0 /),
+ (/BF_ANZ_FKT, BF_ANZ_BOART/))
c Funktionswerte der einzelnen Prozesse
BF_FKT_EndeY =
+ RESHAPE (
+ (/0.0, 1.0, 1.0, 0.0, 1.0, 1.0, 1.0,
+ 0.0, 1.0, 1.0, 0.0, 1.0, 1.0, 1.0,
+ 0.0, 1.0, 1.0, 0.0, 1.0, 1.0, 1.0 /),
+ (/BF_ANZ_FKT, BF_ANZ_BOART/))
BF_FKT_Expo =
+ RESHAPE (
+ (/ 1.4, 3.0, 2.0, -1.0, 1.0, 1.0, 1.0,
+ 1.4, 7.0, 7.0, -1.0, 1.0, 1.0, 1.0,
+ 1.4, 9.0, 7.0, -1.0, 1.0, 1.0, 1.0 /),
+ (/BF_ANZ_FKT, BF_ANZ_BOART/))
BF_FKTNAME =
+ RESHAPE (
+ (/ ' Infil', ' Exfil', ' Inter', 'KapAuf', ' Evap',
+ 'Transp', 'Overfl' /),
+ (/ BF_ANZ_FKT /) )
LNZ_HAUDEFAK_GRAS =
+ RESHAPE (
+ (/ 0.2025, 0.2025, 0.21, 0.2925, 0.2925, 0.2775,
+ 0.2625, 0.2475, 0.2325, 0.2175, 0.2025, 0.2025 /),
+ (/ANZMONATE/) )
BF_VORZEICHEN =
+ RESHAPE (
+ (/ BF_InfVorz, BF_ExxVorz, BF_IntVorz, BF_KapVorz,
+ BF_EvaVorz, BF_EtaVorz, BF_MaxVorz /),
+ (/BF_ANZ_FKT/) )
c Testausgabe fuer Bodenfeuchteberechnung vorbereiten 100 FORMAT(1X, A3, A5, 100(A15))
LBFOUT = LWRITE
IF (LBFOUT) CALL BF_OPENFILE(datTSTBF)
GOTO 10000
c ................................................................. c ................................................................. 10000 RETURN
END SUBROUTINE BF_FKT_INI
cxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
CXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX c Initialisiere das Modul fuer die Bodenarten c DLL - Statement
FUNCTION BOA_INI (ANZAHL) RESULT (LOK)
c .................................................................
USE MODERR
INTEGER :: ANZAHL, i, alloc
LOGICAL :: LOK
c .................................................................
LOK = .FALSE.
BOA_anz = ANZAHL
c Speicherallokierung und Fehlercheck
ALLOCATE (BOACONT(BOA_anz), STAT=alloc)
IF (alloc > 0) GOTO 9999
ALLOCATE (BOA_ID(BOA_anz), STAT=alloc)
IF (alloc > 0) GOTO 9999
c Kennzeichne vor dem Einlesen alle Eintraege als "unbesetzt"
DO i = 1, BOA_anz
NULLIFY (BOACONT(i) % ptrboa)
BOA_ID (i) = 0
END DO
LOK = .TRUE.
GOTO 10000
c ................................................................. c Fehlerbehandlung 9999 If (.NOT. DLL_MODE) BF_error = FEHLER(50, 'BOA ', ' ', 0)
Goto 10000
c ................................................................. 10000 RETURN
END FUNCTION BOA_INI
cxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
CXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX c Initialisiere das Modul fuer die Bodentypen c DLL - Statement
FUNCTION BOD_INI (ANZAHL) RESULT (LOK)
c .................................................................
USE MODERR
INTEGER :: ANZAHL, i, alloc
LOGICAL :: LOK
c .................................................................
LOK = .FALSE.
BOD_anz = ANZAHL
c Speicherallokierung und Fehlercheck
ALLOCATE (BODCONT(BOD_anz), STAT=alloc)
IF (alloc > 0) GOTO 9999
ALLOCATE (BOD_ID(BOD_anz), STAT=alloc)
IF (alloc > 0) GOTO 9999
c Kennzeichne vor dem Einlesen alle Eintraege als "unbesetzt"
DO i = 1, BOD_anz
NULLIFY (BODCONT(i) % ptrbod)
BOD_ID (i) = 0
END DO
LOK = .TRUE.
GOTO 10000
c ................................................................. c Fehlerbehandlung 9999 If (.NOT. DLL_MODE) BF_error = FEHLER(50, 'BOD ', ' ', 0)
Goto 10000
c ................................................................. 10000 RETURN
END FUNCTION BOD_INI
cxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
CXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX c Initialisiere das Modul fuer die Landnutzungen c DLL - Statement
FUNCTION LNZ_INI (ANZAHL) RESULT (LOK)
c .................................................................
USE MODERR
INTEGER :: ANZAHL, i, alloc
LOGICAL :: LOK
c .................................................................
LOK = .FALSE.
LNZ_anz = ANZAHL
c Speicherallokierung und Fehlercheck
ALLOCATE (LNZCONT(LNZ_anz), STAT=alloc)
IF (alloc > 0) GOTO 9999
ALLOCATE (LNZ_ID(LNZ_anz), STAT=alloc)
IF (alloc > 0) GOTO 9999
c Kennzeichne vor dem Einlesen alle Eintraege als "unbesetzt"
DO i = 1, LNZ_anz
NULLIFY (LNZCONT(i) % ptrlnz)
LNZ_ID (i) = 0
END DO
LOK = .TRUE.
GOTO 10000
c ................................................................. c Fehlerbehandlung 9999 If (.NOT. DLL_MODE) BF_error = FEHLER(50, 'LNZ ', ' ', 0)
Goto 10000
c ................................................................. 10000 RETURN
END FUNCTION LNZ_INI
cxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
CXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX c Die naechste freie ID ermitteln c DLL - Statement
FUNCTION BOA_CREATE() RESULT (ID)
c .................................................................
USE MODERR
INTEGER :: ID, i, itmp
c .................................................................
ID = 0
DO i = 1, BOA_anz
IF (BOA_ID(i).EQ.0) THEN
itmp = i
GOTO 80
END IF
END DO
If (.NOT. DLL_MODE)
+ BF_error = FEHLER (50, 'BOA ', ' ', BOA_anz)
GOTO 10000
80 BOA_ID(itmp) = itmp
ID = itmp
GOTO 10000
c ................................................................. 10000 RETURN
END FUNCTION BOA_CREATE
cxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
CXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX c Die naechste freie ID ermitteln c DLL - Statement
FUNCTION BOD_CREATE() RESULT (ID)
c .................................................................
USE MODERR
INTEGER :: ID, i, itmp
c .................................................................
ID = 0
DO i = 1, BOD_anz
IF (BOD_ID(i).EQ.0) THEN
itmp = i
GOTO 80
END IF
END DO
If (.NOT. DLL_MODE)
+ BF_error = FEHLER (50, 'BOD ', ' ', BOD_anz)
GOTO 10000
80 BOD_ID(itmp) = itmp
ID = itmp
GOTO 10000
c ................................................................. 10000 RETURN
END FUNCTION BOD_CREATE
cxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
CXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX c Die naechste freie ID ermitteln c DLL - Statement
FUNCTION LNZ_CREATE() RESULT (ID)
c .................................................................
USE MODERR
INTEGER :: ID, i, itmp
c .................................................................
ID = 0
DO i = 1, LNZ_anz
IF (LNZ_ID(i).EQ.0) THEN
itmp = i
GOTO 80
END IF
END DO
If (.NOT. DLL_MODE)
+ BF_error = FEHLER (50, 'LNZ ', ' ', LNZ_anz)
GOTO 10000
80 LNZ_ID(itmp) = itmp
ID = itmp
GOTO 10000
c ................................................................. 10000 RETURN
END FUNCTION LNZ_CREATE
cxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
CXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX C Neue Bodenart einrichten c DLL - Statement
FUNCTION BOA_NEU (ID, BOAID, BodenArt, WP, FK, GPV, KF,
+ MAXINF, MAXKAP)
+RESULT (LOK)
c .................................................................
USE MODERR
TYPE (BOA_type), POINTER :: objptr
REAL :: WP, FK, GPV, KF, MAXINF, MAXKAP
INTEGER :: ID, BOAID, BodenArt, alloc
LOGICAL :: LOK
c .................................................................
LOK = .FALSE.
C Neue Bodenart einrichten
ALLOCATE (objptr, STAT=alloc)
IF (alloc > 0) THEN
If (.NOT. DLL_MODE) BF_error = FEHLER (50, 'BOA ', ' ', 0)
GOTO 10000
END IF
BOACONT(ID) % ptrboa => objptr
BOA_aktanz = BOA_aktanz + 1
objptr % BOAID = BOAID
objptr % BOART = BodenArt
objptr % WP = WP
objptr % FK = FK
objptr % GPV = GPV
objptr % KF = KF
objptr % MAXINF = MAXINF
objptr % MAXKAP = MAXKAP
LOK = .TRUE.
Goto 10000
c ................................................................. 10000 RETURN
END FUNCTION BOA_NEU
cxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
CXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX C Neuer Bodentyp einrichten c DLL - Statement
FUNCTION BOD_NEU (ID, BODID, NBOA, D, BoaID) RESULT (LOK)
c .................................................................
USE MODERR
TYPE (BOD_type), POINTER :: objptr
INTEGER :: ID, BODID, NBOA, i, alloc
INTEGER :: BoaID(NBOA)
REAL :: D(NBOA)
LOGICAL :: LOK
c .................................................................
LOK = .FALSE.
C Neuer Bodentyp einrichten
ALLOCATE (objptr, STAT=alloc)
IF (alloc > 0) THEN
If (.NOT. DLL_MODE) BF_error = FEHLER (50, 'BOD ', ' ', 0)
GOTO 10000
END IF
BODCONT(ID) % ptrbod => objptr
BOD_aktanz = BOD_aktanz + 1
objptr % BODID = BODID
objptr % NBOA = NBOA
DO i=1,NBOA
objptr % Dicke(i) = D(i)
objptr % BoaID(i) = BoaID(i)
END DO
DO i=NBOA+1,BF_MAX_SCHICHTEN
objptr % Dicke(i) = 0.0
objptr % BoaID(i) = 0
END DO
LOK = .TRUE.
Goto 10000
c ................................................................. 10000 RETURN
END FUNCTION BOD_NEU
cxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
CXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX C Neue Landnutzung einrichten c DLL - Statement
FUNCTION LNZ_NEU (ID, LNZID, WE, BG, BGJGG, BFI, BFIJGG,
+ VG, Kst, HaudeFakJGG, HaudeFak)
+RESULT (LOK)
c .................................................................
USE MODERR
USE MODGGL
TYPE (LNZ_type), POINTER :: objptr
REAL :: WE, BG, BFI, VG, Kst, HaudeFak(ANZMONATE)
INTEGER :: ID, LNZID, BGJGG, BFIJGG, HaudeFakJGG, i, alloc
LOGICAL :: LOK
c .................................................................
LOK = .FALSE.
C Neue Landnutzung einrichten
ALLOCATE (objptr, STAT=alloc)
IF (alloc > 0) THEN
If (.NOT. DLL_MODE) BF_error = FEHLER (50, 'LNZ ', ' ', 0)
GOTO 10000
END IF
LNZCONT(ID) % ptrlnz => objptr
LNZ_aktanz = LNZ_aktanz + 1
objptr % LNZID = LNZID
objptr % WE = WE
objptr % BG = BG
objptr % BGJGG = BGJGG
objptr % BFI = BFI
objptr % BFIJGG = BFIJGG
objptr % VG = VG
IF (Kst.LE.0.0) THEN
objptr % Kst = 7.
ELSE
objptr % Kst = Kst
END IF
objptr % HaudeFakJGG = HaudeFakJGG
DO i=1,ANZMONATE
objptr % HaudeFak(i) = HaudeFak(i)
END DO
c Die Haudefaktoren sind optional, setze die Faktoren von Gras, falls Blank oder 0:
IF (ALL(HaudeFak .LE. 0.0)) THEN
objptr % HaudeFak = LNZ_HAUDEFAK_GRAS
ELSE
objptr % HaudeFak = HaudeFak
END IF
LOK = .TRUE.
Goto 10000
c ................................................................. 10000 RETURN
END FUNCTION LNZ_NEU
cxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
CXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX C Anzahl der Bodenarten lesen
FUNCTION BOA_ANZAHL (datnr) RESULT (N)
c .................................................................
INTEGER :: datnr, BoaID, N
CHARACTER (LEN=1) :: c
c .................................................................
N = 0
c ================================================================= C Anzahl der BOA-Elemente c =================================================================
100 FORMAT(A1, 2X, I4)
50 READ(datnr, 100, ERR=50, END=10000) c, BoaID
IF (c.EQ.cKOMMENTAR) GOTO 50
IF (BoaID.EQ.0) GOTO 50
N = N + 1
GOTO 50
c ................................................................. 10000 REWIND(datnr)
RETURN
END FUNCTION BOA_ANZAHL
cxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
CXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX C Anzahl der Bodentypen lesen
FUNCTION BOD_ANZAHL (datnr) RESULT (N)
c .................................................................
INTEGER :: datnr, BodID, N
CHARACTER (LEN=1) :: c
c .................................................................
N = 0
c ================================================================= C Anzahl der BOD-Elemente c =================================================================
100 FORMAT(A1, 2X, I4)
50 READ(datnr, 100, ERR=50, END=10000) c, BodID
IF (c.EQ.cKOMMENTAR) GOTO 50
IF (BodID.EQ.0) GOTO 50
N = N + 1
GOTO 50
c ................................................................. 10000 REWIND(datnr)
RETURN
END FUNCTION BOD_ANZAHL
cxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
CXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX C Anzahl der Landnutzungen lesen
FUNCTION LNZ_ANZAHL (datnr) RESULT (N)
c .................................................................
INTEGER :: datnr, LnzID, N
CHARACTER (LEN=1) :: c
c .................................................................
N = 0
c ================================================================= C Anzahl der LNZ-Elemente c =================================================================
100 FORMAT(A1, 2X, I4)
50 READ(datnr, 100, ERR=50, END=10000) c, LnzID
IF (c.EQ.cKOMMENTAR) GOTO 50
IF (LnzID.EQ.0) GOTO 50
N = N + 1
GOTO 50
c ................................................................. 10000 REWIND(datnr)
RETURN
END FUNCTION LNZ_ANZAHL
cxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
CXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX c Bodenarten lesen
FUNCTION BOA_SYS (datnr, KNTRLL, LWARN)
+RESULT (LOK)
c .................................................................
USE MODERR
REAL :: WP, FK, GPV, KF, MAXINF, MAXKAP
INTEGER :: ID, datnr, BoaID, BodTyp
LOGICAL :: LOK, LTMP, KNTRLL, LWARN
CHARACTER (LEN = 1) :: ctmp
c .................................................................
LOK = .FALSE.
c ================================================================= C Lesen des aktuellen Zeile c =================================================================
100 FORMAT(A1, 2X, I4, 3X, I1, 6(1X,F6.0))
50 READ(datnr, 100, ERR=50, END=9000) ctmp,
+ BoaID, BodTyp, WP, FK, GPV, KF, MAXINF, MAXKAP
IF (ctmp.EQ.cKOMMENTAR) GOTO 50
c ================================================================= C Pruefung der Kenngroessen c ================================================================= c ID-Kontrolle c ============
IF (BoaID.LT.1) KNTRLL = FEHLER (3300, 'BOA ', 'BOA ', BoaID)
C Bodenart-Typ-Kontrolle C ======================
IF (BodTyp.LT.BF_TypSand .OR. BodTyp.GT.BF_TypTon)
+ KNTRLL = FEHLER (3301, 'BOA ', 'BOA ', BoaID)
C Zulässige Werte C ===============
IF (WP.LE.NULL)
+ KNTRLL = FEHLER (3302, 'WP ', ' ', BoaID)
IF (FK.LE.NULL)
+ KNTRLL = FEHLER (3302, 'FK ', ' ', BoaID)
IF (GPV.LE.NULL)
+ KNTRLL = FEHLER (3302, 'GPV ', ' ', BoaID)
IF (KF.LE.NULL)
+ KNTRLL = FEHLER (3302, 'KF ', ' ', BoaID)
IF (MAXINF.LE.NULL)
+ KNTRLL = FEHLER (3302, 'INF ', ' ', BoaID)
c IF (MAXKAP.LT.NULL) c + KNTRLL = FEHLER (3302, 'KAP ', ' ', BoaID)
C Richtige Groessen C =================
IF (WP.GE.FK)
+ KNTRLL = FEHLER (3303, 'WP ', 'FK ', BoaID)
IF (FK.GE.GPV)
+ KNTRLL = FEHLER (3303, 'FK ', 'GPV ', BoaID)
IF (KF.GE.MAXINF)
+ KNTRLL = FEHLER (3303, 'KF ', 'INF ', BoaID)
IF (KNTRLL) GOTO 10000
c ================================================================== C Neue Bodenart einrichten c ================================================================== c DLL - Statement
ID = BOA_CREATE()
IF (ID.EQ.0) GOTO 10000
c DLL - Statement
LTMP = BOA_NEU (ID, BOAID, BodTyp, WP, FK, GPV, KF,
+ MAXINF, MAXKAP)
IF (.NOT.LTMP) GOTO 10000
IF (KNTRLL) GOTO 10000
GOTO 50
9000 LOK = .TRUE.
Goto 10000
c ................................................................. 10000 REWIND datnr
RETURN
END FUNCTION BOA_SYS
cxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
CXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX c Bodentypen lesen
FUNCTION BOD_SYS (datnr, KNTRLL, LWARN)
+RESULT (LOK)
c .................................................................
USE MODERR
REAL :: D(BF_MAX_SCHICHTEN), SummeD
INTEGER :: ID, datnr, BodID, NBOA,
+ BoaID(BF_MAX_SCHICHTEN), i
LOGICAL :: LOK, LTMP, KNTRLL, LWARN
CHARACTER (LEN = 1) :: ctmp
c .................................................................
LOK = .FALSE.
c ================================================================= C Lesen des aktuellen Zeile c =================================================================
100 FORMAT(A1, 2X, I4, 3X, I3, 1X, 6(1X,F4.0,1X,I4))
50 READ(datnr, 100, ERR=50, END=9000) ctmp,
+ BodID, NBoa, (D(i), BoaID(i), i=1,BF_MAX_SCHICHTEN)
IF (ctmp.EQ.cKOMMENTAR) GOTO 50
c ================================================================= C Pruefung der Kenngroessen c ================================================================= c ID-Kontrolle c ============
IF (BodID.LT.1) KNTRLL = FEHLER (3310, 'BOD ', ' ', BodID)
C Zulässige Werte C ===============
SummeD = 0.
IF (NBOA.LT.1 .OR. NBOA.GT.BF_MAX_SCHICHTEN)
+ KNTRLL = FEHLER (3311, 'BOD ', ' ', BodID)
DO i=1,NBOA
IF (D(i).LE.NULL)
+ KNTRLL = FEHLER (3312, 'D ', ' ', BodID)
LTMP = BOA_CHECK_ID(BoaID(i))
IF (.NOT.LTMP)
+ KNTRLL = FEHLER (3313, ' ', ' ', BodID)
SummeD = SummeD + D(i)
END DO
C Bodendicke c ==========
IF (SummeD.LE.BOD_minDicke)
+ KNTRLL = FEHLER (3314, ' ', ' ', BodID)
IF (KNTRLL) GOTO 10000
c ================================================================== C Neuer Bodentyp einrichten c ================================================================== c DLL - Statement
ID = BOD_CREATE()
IF (ID.EQ.0) GOTO 10000
c DLL - Statement
LTMP = BOD_NEU (ID, BODID, NBOA, D, BoaID)
IF (.NOT.LTMP) GOTO 10000
IF (KNTRLL) GOTO 10000
GOTO 50
9000 LOK = .TRUE.
Goto 10000
c ................................................................. 10000 REWIND datnr
RETURN
END FUNCTION BOD_SYS
cxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
CXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX c Landnutzungen lesen
FUNCTION LNZ_SYS (datnr, KNTRLL, LWARN, LJGANG)
+RESULT (LOK)
c .................................................................
USE MODERR
REAL :: WE, BG, BFI, VG, Kst,
+ HaudeFak(ANZMONATE)
INTEGER :: ID, datnr, LnzID, BGJGG, BFIJGG,
+ HaudeFakJGG
LOGICAL :: LOK, LTMP, KNTRLL, LWARN, LJGANG
CHARACTER (LEN = 1) :: ctmp
c .................................................................
LOK = .FALSE.
c ================================================================= C Lesen der aktuellen Zeile c =================================================================
100 FORMAT(A1, 2X, I4, 2X, F5.0, 2(1X,F5.0,1X,I3), 1X, I3, 1X,
+ F3.0, 1X, F5.0)
50 READ(datnr, 100, ERR=50, END=9000) ctmp,
+ LnzID, WE, BG, BGJGG, BFI, BFIJGG, HaudeFakJGG, VG, Kst
IF (ctmp.EQ.cKOMMENTAR) GOTO 50
c ================================================================= C Pruefung der Kenngroessen c ================================================================= c ID-Kontrolle c ============
IF (LnzID.LT.1) KNTRLL = FEHLER (3320, 'LNZ ', 'LNZ ', LnzID)
C Ganglinienkontrolle C ===================
IF (BGJGG.GT.0 .AND. .NOT. LJGANG)
+ KNTRLL = FEHLER (157, 'BOD ', 'JGG ', 0)
IF (BFIJGG.GT.0 .AND. .NOT. LJGANG)
+ KNTRLL = FEHLER (157, 'BOD ', 'JGG ', 0)
IF (HaudeFakJGG.GT.0 .AND. .NOT. LJGANG)
+ KNTRLL = FEHLER (157, 'BOD ', 'JGG ', 0)
C Zulässige Werte C ===============
IF (WE.LE.NULL)
+ KNTRLL = FEHLER (3322, 'WE ', ' ', LnzID)
IF (BG.LE.NULL .OR. BG.GT.100.)
+ KNTRLL = FEHLER (3322, 'BG ', ' ', LnzID)
IF (BFI.LE.NULL)
+ KNTRLL = FEHLER (3322, 'BFI ', ' ', LnzID)
IF (VG.LT.0. .OR. VG.GT.100.)
+ KNTRLL = FEHLER (3322, 'VG ', ' ', LnzID)
IF (Kst.LT.0.)
+ KNTRLL = FEHLER (3322, 'Kst ', ' ', LnzID)
IF (KNTRLL) GOTO 10000
c ================================================================== C Neue Landnutzung einrichten c ================================================================== c DLL - Statement
ID = LNZ_CREATE()
IF (ID.EQ.0) GOTO 10000
c DLL - Statement
LTMP = LNZ_NEU (ID, LNZID, WE, BG, BGJGG, BFI, BFIJGG,
+ VG, Kst, HaudeFakJGG, HaudeFak)
IF (.NOT.LTMP) GOTO 10000
IF (KNTRLL) GOTO 10000
GOTO 50
9000 LOK = .TRUE.
Goto 10000
c ................................................................. 10000 REWIND datnr
RETURN
END FUNCTION LNZ_SYS
cxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
CXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX C Anfangsbedingungen der Bodenarten setzen
FUNCTION BOD_START (ID) RESULT (LOK)
c ................................................................. c TYPE (BOA_type), POINTER :: objptr
INTEGER :: ID
LOGICAL :: LOK
c .................................................................
LOK = .FALSE.
LOK = .TRUE.
GOTO 10000
c ................................................................. 10000 RETURN
END FUNCTION BOD_START
cxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
CXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX C Berechnung einer Bodensäule: Bodenfeuchtesimulation c 1) Bodenwerte werden in 1/100mm umgerechnet aufgrund mathematischer Probleme bei c kleinen Zahlen !!! (HL: 15. Juli 2001) c 2) Bodenwerte werden in 1/1000mm umgerechnet aufgrund mathematischer Probleme bei c kleinen Zahlen !!! (HL: 11. November 2002) c Dicke wird nicht mit dem Skalierungsfaktor belegt (HL: 11. November 2002) c Haude-Faktoren <= Null abgefangen (HL: 11. November 2002) c INPUT: c ------ c Aktdatum = aktuelles Datum [jjjjmmtt hh:mm] c imon = aktueller Monat [1..12] c izschr = Zeitschritt [sek] c KENSYS = in Bearbeitung befindliches Element [A100, ...] c EFLID = ID der Elementarfläche c EvaKng = Kennung, Ansatz zur Berechnung der Evaporation c EtpKng = Kennung, Ansatz zur Berechnung der Transpiration c VerdFak = Monatsfaktor der Verdunstung bei Haude-Verdunstung c NSCH = Anzahl der Schichten c Gef = Gefälle [-] c Dicke = Schichtdicken [m] c WP = Welkepunkt [mm/m] c FK = Feldkapazität [mm/m] c GPV = Gesamtporenvolumen [mm/m] c BF = aktuelle Bodenfeuchte der n-Schichten [mm/m] c Nied = Niederschlag [mm/dt] c ETp = Potentielle Verdunstung [mm/dt] c LAI = Blattflächenindex [mm/d] c MaxInf = Max. Infiltrationsrate [mm/h] c kf = Durchlässigkeit [mm/h] c MaxKap = Max. Kapillaraufstieg [mm/h] c OUTPUT: c ------- c Runoff = Oberflächenabfluss [mm/dt] c ETa = aktuelle Verdunstung [mm/dt] c Infil = Infiltration (oberste Schicht) [mm/dt] c Interflow = Zwischenabfluss (oberste Schicht) [mm/dt] c Baseflow = Perkolation (Grundwasserneubildung, unterste Schicht) [mm/dt] c *****************************************************************
FUNCTION BF_WEL (LWRITE, Aktdatum, imon, izschr,
+ KENSYS, EFLID, EvaKng, EtpKng, HaudeFak,
+ NSCH, Gef, inDicke, BOART, inWP, inFK, inGPV, BF,
+ inNied, inETp, LAI, inMaxInf, inkf, inMaxKap,
+ Runoff, ETa, Infil, Interflow, Baseflow)
+RESULT (LOK)
c .................................................................
USE MODMISC
REAL, PARAMETER :: BFFak = 1000 !Umrechnung von mm/s auf [(1/1000 mm)/s]
INTEGER :: EFLID, imon, izschr, NSCH, EvaKng, ETpKng,
+ anzzr, anzfun, anzstz(BF_ANZ_FKT),
+ isch, iProzess, iproz, NSTZ, tmpNSTZ
REAL (KIND=8) :: SkalX(SPE_MAXZR+BF_ANZ_FKT),
+ SkalY(SPE_MAXZR+BF_ANZ_FKT),
+ X(BF_MAXSTZ,BF_ANZ_FKT),
+ Y(BF_MAXSTZ,BF_ANZ_FKT),
+ m(BF_MAXSTZ,BF_ANZ_FKT),
+ ProzRate(BF_ANZ_FKT,NSCH),
+ Proz(BF_ANZ_FKT), BFakt(NSCH), BFtmp(NSCH),
+ dRate,
+ BFMax, tmpEva, tmpETa
REAL (KIND=4) :: inDicke(NSCH), inWP(NSCH), inFK(NSCH),
+ inGPV(NSCH), Dicke(NSCH), BF(NSCH),
+ WP(NSCH), FK(NSCH), GPV(NSCH),
+ inkf(NSCH), kf(NSCH),
+ inMaxKap(NSCH), MaxKap(NSCH),
+ inNied, Nied, inETp, ETp, inMaxInf, MaxInf,
+ Gef, LAI, fak, HaudeFak,
+ Runoff, Infil, Interflow, Baseflow, ETa
INTEGER :: BOART(NSCH), iProzKng
LOGICAL :: LOK, LTMP, LWRITE, LBILANZ
CHARACTER (LEN=*) :: Aktdatum
CHARACTER (LEN=*) :: KENSYS
c .................................................................
LOK = .FALSE.
Runoff = 0.0
ETa = 0.0
Infil = 0.0
Interflow = 0.0
Baseflow = 0.0
LBILANZ = .TRUE.
!Variable, die eine Testausgabe bestimmt
IF (LBFOUT) THEN
CALL BF_OPENFILE(datTSTBF)
END IF
c ----------------------------------------------------------------- c Verdunstung (Umrechnung in ((1/1000mm)/s) mm/s) c -----------------------------------------------------------------
fak = (86400.0 / REAL(izschr)) !von [mm/dt] auf [mm/d]
c Evaporation
IF (EvaKng.EQ.EVA_HaudeID) THEN
IF (ABS(HaudeFak).GT.NULL) THEN
tmpEva = DBLE(inETp * (LNZ_HAUDEFAK_CONST / HaudeFak)) !Bodenverdunstung wird auf unbewachsenen Boden bezogen
ELSE
tmpEva = DBLE(inETp) !HaudFak = 0 : Keine Pflanzen, alles steht für die Bodenevaporation zur Verfügung
END IF
ELSEIF (EvaKng.EQ.EVA_BelmansID) THEN
tmpEva = DBLE((inETp*fak) * EXP(-0.6*LAI)) ![mm/d]
tmpEva = tmpEva / fak ![mm/dt]
ELSEIF (EvaKng.EQ.EVA_PotentiellID) THEN
tmpEva = inETp
END IF
tmpEva = (tmpEva / REAL(izschr)) * BfFak ![1/1000mm / s] [mm/s]
c ----------------------------------------------------------------- c Anpassung der Belastung und Bodenkennwerte auf [1/1000 mm/s] [mm/s] c -----------------------------------------------------------------
Nied = BfFak * inNied / REAL(izschr) !von [mm/dt] auf [1/1000 mm/s] [mm/s]
ETp = BfFak * (inETp) / REAL(izschr) !von [mm/dt] auf [1/1000 mm/s] [mm/s]
DO isch = 1,NSCH
kf(isch) = BfFak * inkf(isch) / 3600.0 !von [mm/h] auf [1/1000 mm/s] [mm/s]
MaxInf = BfFak * inMaxInf / 3600.0 !von [mm/h] auf [1/1000 mm/s] [mm/s]
MaxKap(isch) = BfFak * inMaxKap(isch) / 3600.0 !von [mm/h] auf [1/1000 mm/s] [mm/s]
END DO
c ----------------------------------------------------------------- c Initialisierung c ----------------------------------------------------------------- c Zuerst ist nur der Niederschlag als konstanter Input vorhanden
anzzr = 1
c Anzahl der Bodenprozesse
anzfun = BF_ANZ_FKT
c Übergabe der letzten Bodenfeuchtewerte [mm/m] und Umrechnung in [1/100 mm] [mm]
DO isch = 1,NSCH
WP(isch) = BfFak * inWP(isch)
FK(isch) = BfFak * inFK(isch)
GPV(isch) = BfFak * inGPV(isch)
Dicke(isch) = inDicke(isch)
BFakt(isch) = BfFak * DBLE(BF(isch) * inDicke(isch))
BFtmp(isch) = BFakt(isch)
END DO
c Skalierung auf Null setzen
DO iproz = 1,anzzr
SkalY(iproz) = 0.0
END DO
c ----------------------------------------------------------------- c Alle Schichten von oben nach unten berechnen c -----------------------------------------------------------------
DO isch = 1,NSCH
BFMax = 0.0
SkalY(anzzr) = 0.0
NSTZ = 1
iProzKng = BF_ExxID !Annahme: Exfiltration dominiert Kapillaraufstieg
c ======================================== c Funktionsverläufe + Skalierung ermitteln c ========================================
DO iproz = 1,anzfun
iProzess = iproz
c ---------------- c Funktionsverlauf c ----------------
!Infiltration nur bei InfiltrationsSchicht als Funktion wirksam,
!ansonsten konstanter Funktionsverlauf
IF (iproz.EQ.BF_InfID .AND. isch.NE.BOD_InfSchichtID) THEN
iProzess = BF_ConstID
END IF
c Funktionsverlauf: X-Werte der Funktion
tmpNSTZ = BF_FKT_X (BOART(isch), iProzess, inDicke(isch),
+ WP(isch), FK(isch), GPV(isch),
+ X(1,iproz))
IF (tmpNSTZ.EQ.0) THEN
ERR_KENNUNG = ERR_BOD_FKT
GOTO 10000
END IF
c Funktionsverlauf: Y-Werte der Funktion
anzstz(iproz) = BF_FKT_Y (isch, BOART(isch), iProzess,
+ ETpKng, MaxInf, kf(isch), MaxKap(isch),
+ tmpNSTZ, X(1,iproz), Y(1,iproz),
+ SkalY(anzzr+iproz))
c Steigungen der Funktion
LTMP = CALC_STEIGUNG(anzstz(iproz), x(1,iproz), y(1,iproz),
+ m(1,iproz))
IF (.NOT.LTMP) GOTO 10000
c Maximale Anzahl an Stützstellen
IF (anzstz(iproz).GT.NSTZ) NSTZ = anzstz(iproz)
c Maximale Bodenfeuchte (Speicherinhalt)
SkalX(anzzr+iproz) = 1.0
IF (X(anzstz(iproz),iproz).GT.BFMax)
+ BFMax = X(anzstz(iproz),iproz)
c ------------ c Y-Skalierung (Nur anwenden, wenn aus dem Funktionsverlauf der Skal-Faktor > 0) c ------------
IF (ABS(SkalY(anzzr+iproz)).GT.0.) THEN
SELECT CASE (iproz)
!Infiltration:
!in Infiltrationsschicht: Funktion nach Holtan -> Skalierung in der Y-Fkt enthalten
!alle anderen Schichten : konstante Funktion; mit aktueller Schicht (i) gilt:
! wenn Exx*(i-1) < kf(i) -> Skalierung ist Exx(i-1)
! wenn Exx*(i-1) >= kf(i) -> Skalierung ist kf(i) [STAUEFFEKT !!!]
! Exx* = Exx - Kap
CASE (BF_InfID)
!für alle Schichten ausser Infiltrationsschicht gilt:
IF (isch.NE.BOD_InfSchichtID) THEN
!Infiltration zu Null gesetzt, Unabhängiger Input übernimmt
SkalY(anzzr+iproz) = 0.0
dRate = ABS(ProzRate(BF_ExxID,isch-1)) -
+ ABS(ProzRate(BF_KapID,isch-1))
!maßgebender Prozess? (Default: Perkolation)
iProzKng = BF_ExxID
IF (dRate.LT.0.) THEN
iProzKng = BF_KapID
END IF
IF (dRate.LT.kf(isch)) THEN
SkalY(anzzr) = dRate
!Staueffekt
ELSE
SkalY(anzzr) = kf(isch)
END IF
END IF
!Interflow (nur Infiltrationsschicht)
CASE (BF_IntID)
SkalY(anzzr+iproz) = SkalY(anzzr+iproz) *
+ DBLE(Gef/(SQRT(1.+Gef**2.)))
!Evaporation (nur Infiltrationsschicht)
CASE (BF_EvaID)
SkalY(anzzr+iproz) = tmpEva
!Transpiration (nur WE-Schicht)
CASE (BF_EtaID)
tmpETa = ETp -
+ ABS(ProzRate(BF_EvaID,BOD_InfSchichtID))
tmpETa = MAX(0.0, tmpETa)
SkalY(anzzr+iproz) = tmpETa
END SELECT
END IF
c Wenn Funktionsausgabe gesetzt: Funktionen in Datei schreiben c ------------------------------------------------------------
IF (LBFFKT) THEN
LTMP = BF_FKT_WRITE (datBFFKT, izschr, iProz,
+ KENSYS, EFLID, isch,
+ inWP(isch), inFK(isch), inGPV(isch),
+ Dicke(isch), BFFak,
+ anzstz(iproz),
+ X(1,iproz), Y(1,iproz),
+ SkalY(anzzr+iproz),
+ BF_VORZEICHEN(iproz))
END IF
END DO
c ================= c Schicht berechnen c =================
!Schichtberechnung
LTMP = BF_CALC_SCHICHT (KENSYS, EFLID, isch,
+ Aktdatum, izschr,
+ anzzr, anzfun, BF_MAXSTZ, anzstz, X, Y, m,
+ BFMax, BFtmp(isch), BFakt(isch),
+ SkalX, SkalY, Proz)
IF (.NOT.LTMP) GOTO 10000
!Zuweisen des Inputs an die Infiltration
IF (isch.NE.BOD_InfSchichtID) THEN !Vorsicht, wenn KapAufstieg dominiert ist SkalY(anzzr) < 0
Proz(BF_InfID) = SkalY(anzzr) ! * BF_VORZEICHEN(BF_InfID)
END IF
c ========= c Kontrolle c =========
SELECT CASE (isch)
CASE (BOD_InfSchichtID)
c Infiltrationsschicht - Kontrolle: Niederschlag < pot. Infiltration ?
IF (Nied.LT.ABS(Proz(BF_InfID))) THEN
BFakt(isch) = BFtmp(isch)
SkalY(anzzr) = Nied
SkalY(anzzr+BF_InfID) = 0.0
LTMP = BF_CALC_SCHICHT (KENSYS, EFLID, isch,
+ Aktdatum, izschr,
+ anzzr, anzfun, BF_MAXSTZ,
+ anzstz, X, Y, m,
+ BFMax, BFtmp(isch), BFakt(isch),
+ SkalX, SkalY, Proz)
IF (.NOT.LTMP) GOTO 10000
Proz(BF_InfID) = DBLE(Nied) * BF_VORZEICHEN(BF_InfID)
END IF
END SELECT
!Korrektur der untersten Schicht, wenn Überlauf > 0 ist
!------------------------------------------------------
IF (isch.EQ.NSCH .AND. ABS(Proz(BF_MaxID)).GT.0.) THEN
CALL BF_BILANZ_SCHICHT (izschr, BFtmp(isch), BFakt(isch),
+ anzfun, Proz)
END IF
c Übergabe der Prozessraten !Vorsicht, wenn KapAufstieg dominiert ist Proz(BF_InID) < 0 c -------------------------
DO iproz = 1,anzfun
ProzRate(iproz,isch) = ABS(Proz(iproz)) *
+ DBLE(BF_VORZEICHEN(iproz))
IF (iproz.EQ.BF_InfID) THEN
IF ( isch.NE.BOD_InfSchichtID
+ .AND. iProzKng.EQ.BF_KapID) THEN
ProzRate(iproz,isch) = Proz(iproz)
END IF
END IF
END DO
c Neue Bodenfeuchte mit Kontigleichung berechnen (Ausgleich von Bilanzfehlern) c ----------------------------------------------
CALL BF_KONTI_SCHICHT (izschr,
+ BFtmp(isch), BFakt(isch),
+ anzfun, ProzRate(1,isch))
c Wenn Bodenausgabe gesetzt: Bodenfeuchte u. Prozessraten in Datei schreiben c --------------------------------------------------------------------------
IF (LBFOUT) THEN
LTMP = BF_PROZ_WRITE (datTSTBF, Kensys, EFLID,
+ 'o_u', izschr, isch, BfFak,
+ DBLE(Dicke(isch)),
+ BFtmp(isch), BFakt(isch),
+ anzfun, ProzRate(1,isch), Nied,
+ Runoff, ETa, Interflow, Baseflow)
IF (.NOT.LTMP) GOTO 10000
END IF
END DO
c --------------------------------------------------------------------- c Korrekturrechnung: Schichten von unten nach oben berechnen (Abgleich) c ---------------------------------------------------------------------
DO isch = NSCH-1,1,-1
!Maßgebender Prozess
!-------------------
!Perkolation aus der aktuellen Schicht
dRate = (ABS(ProzRate(BF_ExxID,isch)) -
+ ABS(ProzRate(BF_KapID,isch)))
!maßgebender Prozess? (Default: Perkolation)
iProzKng = BF_ExxID
IF (dRate.LT.0.) iProzKng = BF_KapID
!Korrekturrechnung wenn Verbindungsraten ungleich oder Überlauf > 0
!------------------------------------------------------------------
!Kontrolle: Sind die Wasserströme zwischen den Schichten gleich ?
LTMP = .FALSE.
IF ((ABS(ProzRate(BF_InfID,isch+1)-dRate)*REAL(izschr))
+ .GT.BF_DELTARATE)
+ LTMP = .TRUE.
!Kontrolle: Liegt ein Überlauf in dieser Schicht vor ?
IF (ABS(ProzRate(BF_MaxID,isch)).GT.0.) LTMP = .TRUE.
!Korrekturrechnung erforderlich (Staueffekt oder Überlauf liegt vor)
IF (LTMP) THEN
BFakt(isch) = BFtmp(isch)
BFMax = 0.0
SkalY(anzzr) = 0.0
NSTZ = 1
c ======================================== c Funktionsverläufe + Skalierung ermitteln c ========================================
DO iproz = 1,anzfun
iProzess = iproz
c ---------------- c Funktionsverlauf c ----------------
!Infiltration nur bei Infiltrationsschicht als Funktion wirksam
!Ansonsten konstanter Funktionsverlauf, Skalierung mit Exx/Kap aus darüberliegender Schicht
IF (iproz.EQ.BF_InfID.AND.isch.NE.BOD_InfSchichtID) THEN
iProzess = BF_ConstID
END IF
!Bei Korrekturberechnung sind Perkolation bzw. kapillarer Aufstieg konstante Funktionen
!Exfiltration ist die Infiltrationskapazität der darunterliegenden Schicht
IF (iproz.EQ.BF_ExxID) iProzess = BF_ConstID
IF (iproz.EQ.BF_KapID) iProzess = BF_ConstID
c Funktionsverlauf: X-Werte der Funktion
tmpNSTZ = BF_FKT_X (BOART(isch), iProzess, inDicke(isch),
+ WP(isch), FK(isch), GPV(isch),
+ X(1,iproz))
IF (tmpNSTZ.EQ.0) THEN
ERR_KENNUNG = ERR_BOD_FKT
GOTO 10000
END IF
c Funktionsverlauf: Y-Werte der Funktion
anzstz(iproz) = BF_FKT_Y (isch, BOART(isch), iProzess,
+ ETpKng, MaxInf, kf(isch), MaxKap(isch),
+ tmpNSTZ, X(1,iproz), Y(1,iproz),
+ SkalY(anzzr+iproz))
c Steigungen der Funktion
LTMP = CALC_STEIGUNG(anzstz(iproz), x(1,iproz),
+ y(1,iproz), m(1,iproz))
IF (.NOT.LTMP) GOTO 10000
c Maximale Anzahl an Stützstellen
IF (anzstz(iproz).GT.NSTZ) NSTZ = anzstz(iproz)
c Maximale Bodenfeuchte (Speicherinhalt)
SkalX(anzzr+iproz) = 1.0
IF (X(anzstz(iproz),iproz).GT.BFMax)
+ BFMax = X(anzstz(iproz),iproz)
c ------------ c Y-Skalierung (Nur, wenn aus dem Funktionsverlauf der Skal-Faktor > 0) c ------------
IF (ABS(SkalY(anzzr+iproz)).GT.0.) THEN
SELECT CASE (iproz)
!Infiltration:
!in Infiltrationsschicht: Funktion nach Holtan -> Skalierung in der Y-Fkt enthalten
!alle anderen Schichten : konstante Funktion; mit aktueller Schicht (i) gilt:
! wenn Exx*(i-1) < kf(i) -> Skalierung ist Exx(i-1)
! wenn Exx*(i-1) >= kf(i) -> Skalierung ist kf(i) [STAUEFFEKT !!!]
! Exx* = Exx - Kap
CASE (BF_InfID)
!für alle Schichten ausser Infiltrationsschicht gilt:
IF (isch.NE.BOD_InfSchichtID) THEN
!Infiltration zu Null gesetzt, Unabhängiger Input übernimmt
SkalY(anzzr+iproz) = 0.0
dRate = ABS(ProzRate(BF_ExxID,isch-1)) -
+ ABS(ProzRate(BF_KapID,isch-1))
IF (dRate.LT.kf(isch)) THEN
SkalY(anzzr) = dRate
!Staueffekt
ELSE
SkalY(anzzr) = kf(isch)
END IF
END IF
!Perkolation
CASE (BF_ExxID)
IF (iProzKng.EQ.BF_ExxID) THEN
SkalY(anzzr+iproz)=
+ ABS(ProzRate(BF_InfID,isch+1))
ELSE
SkalY(anzzr+iproz) = 0.0
END IF
!Kappilarer Aufstieg
CASE (BF_KapID)
IF (iProzKng.EQ.BF_KapID) THEN
SkalY(anzzr+iproz)=ProzRate(BF_InfID,isch+1)
ELSE
SkalY(anzzr+iproz) = 0.0
END IF
!Interflow (nur Infiltrationsschicht)
CASE (BF_IntID)
SkalY(anzzr+iproz) = SkalY(anzzr+iproz) *
+ DBLE(Gef/(SQRT(1.+Gef**2.)))
!Evaporation (nur Infiltrationsschicht)
CASE (BF_EvaID)
dRate = ETp-ProzRate(BF_EtaID,BOD_WESchichtID)
SkalY(anzzr+iproz) = SkalY(anzzr+iproz) *
+ MAX(0.0, dRate)
!Transpiration (nur WE-Schicht)
CASE (BF_EtaID)
SkalY(anzzr+iproz) = tmpETa
END SELECT
END IF
c Wenn Funktionsausgabe gesetzt: Funktionen in Datei schreiben c ------------------------------------------------------------
IF (LBFFKT) THEN
LTMP = BF_FKT_WRITE (datBFFKT, izschr, iProz,
+ KENSYS, EFLID, isch,
+ inWP(isch), inFK(isch), inGPV(isch),
+ Dicke(isch), BFFak,
+ anzstz(iproz),
+ X(1,iproz), Y(1,iproz),
+ SkalY(anzzr+iproz),
+ BF_VORZEICHEN(iproz))
END IF
END DO
c ================= c Schicht berechnen c ================= c Infiltrationbetrag plus Überschuss aus unterhalb liegender Schicht ist unabhängiger Input
SkalY(anzzr) = SkalY(anzzr) + ProzRate(BF_MaxID,isch+1)
LTMP = BF_CALC_SCHICHT (KENSYS, EFLID, isch,
+ Aktdatum, izschr,
+ anzzr, anzfun, BF_MAXSTZ, anzstz, X, Y, m,
+ BFMax, BFtmp(isch), BFakt(isch),
+ SkalX, SkalY, Proz)
IF (.NOT.LTMP) GOTO 10000
!Zuweisen des Inputs an die Infiltration !Vorsicht, wenn KapAufstieg dominiert ist SkalY(anzzr) < 0
IF (isch.NE.BOD_InfSchichtID) THEN
Proz(BF_InfID) = (SkalY(anzzr)-ProzRate(BF_MaxID,isch+1))
c + * BF_VORZEICHEN(BF_InfID)
END IF
c ========= c Kontrolle c =========
SELECT CASE (isch)
CASE (BOD_InfSchichtID)
c Infiltrationsschicht - Kontrolle: Niederschlag < pot. Infiltration ?
IF (Nied.LT.ABS(Proz(BF_InfID))) THEN
BFakt(isch) = BFtmp(isch)
c Niederschlag plus Überschuss aus unterhalb liegender Schicht ist unabhängiger Input
SkalY(anzzr) = Nied + ProzRate(BF_MaxID,isch+1)
SkalY(anzzr+BF_InfID) = 0.0
LTMP = BF_CALC_SCHICHT (KENSYS, EFLID, isch,
+ Aktdatum, izschr,
+ anzzr, anzfun, BF_MAXSTZ,
+ anzstz, X, Y, m,
+ BFMax, BFtmp(isch), BFakt(isch),
+ SkalX, SkalY, Proz)
IF (.NOT.LTMP) GOTO 10000
Proz(BF_InfID) = DBLE(Nied) * BF_VORZEICHEN(BF_InfID)
END IF
END SELECT
!Korrektur der Schicht, wenn Überlauf > 0 ist
!--------------------------------------------
IF (ABS(Proz(BF_MaxID)).GT.0.) THEN
CALL BF_BILANZ_SCHICHT (izschr, BFtmp(isch), BFakt(isch),
+ anzfun, Proz)
END IF
c Übergabe der Prozessraten !Vorsicht, wenn KapAufstieg dominiert ist Proz(BF_InID) < 0 c -------------------------
DO iproz = 1,anzfun
ProzRate(iproz,isch) = ABS(Proz(iproz)) *
+ DBLE(BF_VORZEICHEN(iproz))
IF (iproz.EQ.BF_InfID) THEN
IF ( isch.NE.BOD_InfSchichtID
+ .AND. iProzKng.EQ.BF_KapID) THEN
ProzRate(iproz,isch) = Proz(iproz)
END IF
END IF
END DO
c Neue Bodenfeuchte mit Kontigleichung berechnen (Ausgleich von Bilanzfehlern) c ----------------------------------------------
CALL BF_KONTI_SCHICHT (izschr, BFtmp(isch), BFakt(isch),
+ anzfun, ProzRate(1,isch))
c Prozessraten in Testergebnisdatei schreiben c -------------------------------------------
IF (LBFOUT) THEN
LTMP = BF_PROZ_WRITE (datTSTBF, Kensys, EFLID,
+ 'u_o', izschr, isch, BfFak,
+ DBLE(Dicke(isch)),
+ BFtmp(isch), BFakt(isch),
+ anzfun, ProzRate(1,isch), inNied,
+ Runoff, ETa, Interflow, Baseflow)
IF (.NOT.LTMP) GOTO 10000
END IF
END IF
END DO
c ----------------------------------------------------------------- c Übergabe der letzten Bodenfeuchtewerte [mm/m] c -----------------------------------------------------------------
DO isch = 1,NSCH
BF(isch) = SNGL(BFakt(isch) / DBLE(Dicke(isch)))
END DO
c IF (LWRITE) WRITE(datTSTBF,*)
c ----------------------------------------------------------------- c Übergabe der Abflussbildung [mm/dt] c -----------------------------------------------------------------
dRate = (Nied - ABS(ProzRate(BF_InfID,BOD_InfSchichtID)))
c + + ProzRate(BF_MaxID,BOD_InfSchichtID)
Runoff = MAX(0.0, dRate)
Runoff = (Runoff * REAL(izschr)) / BfFak
Baseflow = (ABS(ProzRate(BF_ExxID,BOD_TRSSchichtID)) -
+ ABS(ProzRate(BF_KapID,BOD_TRSSchichtID))) *
+ REAL(izschr)
Baseflow = Baseflow / BfFak
ETa = 0.0
Interflow = 0.0
DO isch = 1,NSCH
ETa = ETa + ABS(ProzRate(BF_EvaID,isch)) +
+ ABS(ProzRate(BF_EtaID,isch))
Interflow = Interflow + ABS(ProzRate(BF_IntID,isch))
END DO
ETa = ETa * REAL(izschr) / BfFak
Infil = (ABS(ProzRate(BF_InfID, BOD_InfSchichtID)) * REAL(izschr))
+ / BfFak
Interflow = (Interflow * REAL(izschr)) / BfFak
c ----------------------------------------------------------------- c Schreiben der Ergebnisse c -----------------------------------------------------------------
IF (LBFOUT) THEN
WRITE(datTSTBF, '(1X,A,I5)', ERR=9999) KENSYS, EFLID
WRITE(datTSTBF, '(A4, 1X, I3, 1X, 5(A10))') Kensys, EFLID,
+ 'HN [mm]', 'HNeff[mm]', ' ETa [mm]', 'Int [mm]', 'Base [mm]'
WRITE(datTSTBF, '(A4, 1X, I3, 1X, 8(F10.3))') KENSYS, EFLID,
+ inNied, Runoff, ETa, Interflow, Baseflow,
+ (BF(isch), isch=1,NSCH)
DO isch = 1,NSCH
LTMP = BF_PROZ_WRITE (datTSTBF, Kensys, EFLID,
+ 'erg', izschr, isch, BfFak,
+ DBLE(Dicke(isch)),
+ BFtmp(isch), BFakt(isch),
+ anzfun, ProzRate(1,isch), inNied,
+ Runoff, ETa, Interflow, Baseflow)
IF (.NOT.LTMP) GOTO 10000
END DO
END IF
IF (LBILANZ) THEN
c !Summe der Bodenfeuchte über alle Schichten c SumBFalt = 0.0 c SumBFneu = 0.0 c DO isch=1,NSCH c SumBFalt = SumBFalt + BFtmp(isch) c SumBFneu = SumBFneu + BFakt(isch) c END DO c dRate = SumBFneu - SumBFalt c !
END IF
LOK = .TRUE.
GOTO 10000
c ................................................................. 9999 ERR_KENNUNG = datTSTBF
GOTO 10000
10000 RETURN
END FUNCTION BF_WEL
cxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
CXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX C Berechnung einer Bodensäule: Bodenfeuchtesimulation c izschr = Zeitschritt [sek] c NSCH = Anzahl der Schichten c Gef = Gefälle [-] c Dicke = Schichtdicken [m] c WP = Welkepunkt [mm/m] c FK = Feldkapazität [mm/m] c GPV = Gesamtporenvolumen [mm/m] c BF = aktuelle Bodenfeuchte der n-Schichten [mm/m] c Nied = Niederschlag [mm/dt] c ETp = Potentielle Verdunstung [mm/dt] c LAI = Blattflächenindex [mm/d] c MaxInf = Max. Infiltrationsrate [mm/h] c kf = Durchlässigkeit [mm/h] c MaxKap = Max. Kapillaraufstieg [mm/h] c *****************************************************************
FUNCTION BF_WELOK (LWRITE, Aktdatum, imon, izschr, EvaKng, EtpKng,
+ NSCH, Gef, Dicke, BOART, WP, FK, GPV, BF,
+ inNied, inETp, LAI, inMaxInf, inkf, inMaxKap,
+ Runoff, ETa, Interflow, Baseflow)
+RESULT (LOK)
c .................................................................
USE MODMISC
INTEGER :: imon, izschr, NSCH, EvaKng, ETpKng,
+ anzzr, anzfun, anzstz(BF_ANZ_FKT),
+ isch, iProzess, iproz, NSTZ, tmpNSTZ
REAL (KIND=8) :: SkalX(SPE_MAXZR+BF_ANZ_FKT),
+ SkalY(SPE_MAXZR+BF_ANZ_FKT),
+ X(BF_MAXSTZ,BF_ANZ_FKT),
+ Y(BF_MAXSTZ,BF_ANZ_FKT),
+ m(BF_MAXSTZ,BF_ANZ_FKT),
+ ProzRate(BF_ANZ_FKT,NSCH),
+ Proz(BF_ANZ_FKT), BFakt(NSCH), BFtmp(NSCH),
+ BFMax, tmpEva, tmpETa
REAL (KIND=4) :: Dicke(NSCH), WP(NSCH), FK(NSCH),
+ GPV(NSCH), BF(NSCH),
+ inkf(NSCH), kf(NSCH),
+ inMaxKap(NSCH), MaxKap(NSCH),
+ inNied, Nied, inETp, ETp, inMaxInf, MaxInf,
+ Gef, LAI, kfExx, fak,
+ Runoff, Interflow, Baseflow, ETa
INTEGER :: BOART(NSCH)
LOGICAL :: LOK, LTMP, LWRITE
CHARACTER (LEN=*) :: Aktdatum
c .................................................................
LOK = .FALSE.
Runoff = 0.0
ETa = 0.0
Interflow = 0.0
Baseflow = 0.0
c ----------------------------------------------------------------- c Verdunstung (Umrechnung in mm/s) c -----------------------------------------------------------------
fak = 86400.0 / REAL(izschr) !von [mm/dt] auf [mm/d]
c Evaporation
IF (EvaKng.EQ.EVA_HaudeID) THEN
tmpEva = DBLE((inETp / LNZ_HAUDEFAK_GRAS(imon)) *
+ LNZ_HAUDEFAK_CONST)
ELSEIF (EvaKng.EQ.EVA_BelmansID) THEN
tmpEva = DBLE((inETp*fak) * EXP(-0.6*LAI)) ![mm/d]
tmpEva = tmpEva / fak ![mm/dt]
END IF
tmpEva = tmpEva / REAL(izschr) ![mm/s]
c ----------------------------------------------------------------- c Anpassung der Belastung und Bodenkennwerte auf [mm/s] c -----------------------------------------------------------------
Nied = inNied / REAL(izschr) !von [mm/dt] auf [mm/s]
ETp = inETp / REAL(izschr) !von [mm/dt] auf [mm/s]
MaxInf = inMaxInf / REAL(izschr) !von [mm/dt] auf [mm/s]
DO isch = 1,NSCH
kf(isch) = inkf(isch) / 3600.0 !von [mm/h] auf [mm/s]
MaxKap(isch) = inMaxKap(isch) / 3600.0 !von [mm/h] auf [mm/s]
END DO
c ----------------------------------------------------------------- c Initialisierung c ----------------------------------------------------------------- c Zuerst ist nur der Niederschlag als konstanter Input vorhanden
anzzr = 1
anzfun = BF_ANZ_FKT
c Übergabe der letzten Bodenfeuchtewerte [mm/m]
DO isch = 1,NSCH
BFakt(isch) = DBLE(BF(isch) * Dicke(isch))
BFtmp(isch) = BFakt(isch)
END DO
DO iproz = 1,anzzr
SkalY(iproz) = 1.0
END DO
c ----------------------------------------------------------------- c Alle Schichten von oben nach unten berechnen c -----------------------------------------------------------------
DO isch = 1,NSCH
BFMax = 0.0
NSTZ = 1
c ======================================== c Funktionsverläufe + Skalierung ermitteln c ========================================
DO iproz = 1,anzfun
iProzess = iproz
!Infiltration nur bei InfiltrationsSchicht als Funktion wirksam
!Ansonsten konstanter Funktionsverlauf, Skalierung mit Exx aus darüberliegender Schicht
IF (iproz.EQ.BF_InfID .AND. isch.NE.BOD_InfSchichtID) THEN
iProzess = BF_ConstID
END IF
c Funktionsverlauf c ---------------- c X-Werte der Funktion
tmpNSTZ = BF_FKT_X (BOART(isch), iProzess, Dicke(isch),
+ WP(isch), FK(isch), GPV(isch),
+ X(1,iproz))
IF (tmpNSTZ.EQ.0) THEN
ERR_KENNUNG = ERR_BOD_FKT
GOTO 10000
END IF
c Y-Werte der Funktion
kfExx = kf(isch)
IF (isch.LT.NSCH) kfExx = kf(isch+1)
anzstz(iproz) = BF_FKT_Y(isch, BOART(isch), iProzess,
+ ETpKng, MaxInf, kf(isch),
+ MaxKap(isch),
+ tmpNSTZ, X(1,iproz),
+ Y(1,iproz), SkalY(anzzr+iproz))
c Steigungen der Funktion
LTMP = CALC_STEIGUNG(anzstz(iproz), x(1,iproz), y(1,iproz),
+ m(1,iproz))
IF (.NOT.LTMP) GOTO 10000
c Maximale Anzahl an Stützstellen
IF (anzstz(iproz).GT.NSTZ) NSTZ = anzstz(iproz)
c Maximale Bodenfeuchte (Speicherinhalt)
SkalX(anzzr+iproz) = 1.0
IF (X(anzstz(iproz),iproz).GT.BFMax)
+ BFMax = X(anzstz(iproz),iproz)
c Y-Skalierungsfaktoren: Nur, wenn aus dem Funktionsverlauf der Skal-Faktor > 0 c -----------------------------------------------------------------------------
IF (ABS(SkalY(anzzr+iproz)).GT.0.) THEN
SELECT CASE (iProzess)
!Interflow (nur Infiltrationsschicht)
CASE (BF_IntID)
SkalY(anzzr+iproz) = SkalY(anzzr+iproz) *
+ DBLE(Gef/(SQRT(1.+Gef**2.)))
!Evaporation (nur Infiltrationsschicht)
CASE (BF_EvaID)
SkalY(anzzr+iproz) = tmpEva
!Transpiration (nur WE-Schicht)
CASE (BF_EtaID)
tmpETa = MAX(0.0, ETp -
+ ProzRate(BF_EvaID,BOD_InfSchichtID))
SkalY(anzzr+iproz) = tmpETa
END SELECT
END IF
c IF (LTSTOUT) THEN c LTMP = BF_FKT_WRITE (datTST, izschr, iProz, c + anzstz(iproz), c + X(1,iproz), Y(1,iproz), c + SkalY(anzzr+iproz), c + BF_VORZEICHEN(iproz)) c END IF
END DO
c ======================================= c Schichten von oben nach unten berechnen c =======================================
SkalY(anzzr) = 0.0
If (isch.NE.BOD_InfSchichtID) THEN
!Skalierung zur Infiltration ist Exfiltration aus darüberliegender Schicht
SkalY(anzzr+BF_InfID) = ABS(ProzRate(BF_ExxID,isch-1))
END IF
c LTMP = BF_CALC_SCHICHT (Aktdatum, izschr, c + anzzr, anzfun, NSTZ, anzstz, X, Y, m, c + BFMax, BFtmp(isch), BFakt(isch), c + SkalX, SkalY, Proz)
IF (.NOT.LTMP) GOTO 10000
SELECT CASE (isch)
c Infiltrationsschicht
CASE (BOD_InfSchichtID)
c Kontrolle: Niederschlag < pot. Infiltration
IF (Nied.LT.ABS(Proz(BF_InfID))) THEN
BFakt(isch) = BFtmp(isch)
SkalY(anzzr) = Nied
SkalY(anzzr+BF_InfID) = 0.0
c LTMP = BF_CALC_SCHICHT (Aktdatum, izschr, c + anzzr, anzfun, NSTZ, anzstz, X, Y, m, c + BFMax, BFtmp(isch), BFakt(isch), c + SkalX, SkalY, Proz)
IF (.NOT.LTMP) GOTO 10000
Proz(BF_InfID) = DBLE(Nied) * BF_VORZEICHEN(BF_InfID)
END IF
END SELECT
!Bei Überlauf: Bodenschicht übergesättigt, Überlauf wird von BF abgezogen
LTMP = BF_CORRECT_SCHICHT (.FALSE., izschr, Nied,
+ BFtmp(isch), BFakt(isch), anzfun, Proz)
c Übergabe der Prozessraten c -------------------------
DO iproz = 1,anzfun
ProzRate(iproz,isch) = ABS(Proz(iproz))
END DO
c IF (LWRITE) THEN c LTMP = BF_PROZ_WRITE (datTSTBF, 'o_u', izschr, isch, c + DBLE(Dicke(isch)), c + BFtmp(isch), BFakt(isch), c + anzfun, ProzRate(1,isch), inNied, c + Runoff, ETa, Interflow, Baseflow) c IF (.NOT.LTMP) GOTO 10000 c END IF
END DO
c ----------------------------------------------------------------- c Korrekturrechnung: Schichten von unten nach oben berechnen als Abgleich c -----------------------------------------------------------------
DO isch = NSCH-1,1,-1
!Staueffekt: Exfiltration(isch) ist groesser als Infiltration(isch+1)
IF (ProzRate(BF_ExxID,isch).GT.ProzRate(BF_InfID,isch+1)) THEN
BFakt(isch) = BFtmp(isch)
BFMax = 0.0
NSTZ = 1
c ======================================== c Funktionsverläufe + Skalierung ermitteln c ========================================
DO iproz = 1,anzfun
iProzess = iproz
!Infiltration nur bei InfiltrationsSchicht als Funktion wirksam
!Ansonsten konstanter Funktionsverlauf, Skalierung mit Exx aus darüberliegender Schicht
IF (iproz.EQ.BF_InfID.AND.isch.NE.BOD_InfSchichtID) THEN
iProzess = BF_ConstID
END IF
!Exfiltration ist die Infiltrationskapazität der darunterliegenden Schicht
!bei konstantem Funktionsverlauf
IF (iproz.EQ.BF_ExxID.AND.isch.NE.BOD_TRSSchichtID) THEN
iProzess = BF_ConstID
END IF
c Funktionsverlauf c ---------------- c X-Werte der Funktion
tmpNSTZ = BF_FKT_X (BOART(isch), iProzess, Dicke(isch),
+ WP(isch), FK(isch), GPV(isch),
+ X(1,iproz))
IF (tmpNSTZ.EQ.0) THEN
ERR_KENNUNG = ERR_BOD_FKT
GOTO 10000
END IF
c Y-Werte der Funktion
kfExx = kf(isch)
IF (isch.LT.NSCH) kfExx = kf(isch+1)
anzstz(iproz) = BF_FKT_Y(isch, BOART(isch), iProzess,
+ ETpKng, MaxInf, kf(isch),
+ MaxKap(isch),
+ tmpNSTZ, X(1,iproz),
+ Y(1,iproz), SkalY(anzzr+iproz))
c Steigungen der Funktion
LTMP = CALC_STEIGUNG(anzstz(iproz), x(1,iproz),
+ y(1,iproz), m(1,iproz))
IF (.NOT.LTMP) GOTO 10000
c Maximale Anzahl an Stützstellen
IF (anzstz(iproz).GT.NSTZ) NSTZ = anzstz(iproz)
c Maximale Bodenfeuchte (Speicherinhalt)
SkalX(anzzr+iproz) = 1.0
IF (X(anzstz(iproz),iproz).GT.BFMax)
+ BFMax = X(anzstz(iproz),iproz)
c Y-Skalierungsfaktoren: Nur, wenn aus dem Funktionsverlauf der Skal-Faktor > 0 c -----------------------------------------------------------------------------
IF (ABS(SkalY(anzzr+iproz)).GT.0.) THEN
SELECT CASE (iProzess)
!Interflow (nur Infiltrationsschicht)
CASE (BF_IntID)
SkalY(anzzr+iproz) = SkalY(anzzr+iproz) *
+ DBLE(Gef/(SQRT(1.+Gef**2.)))
!Evaporation (nur Infiltrationsschicht)
CASE (BF_EvaID)
SkalY(anzzr+iproz) = SkalY(anzzr+iproz) *
+ MAX(0.0, ETp -
+ ProzRate(BF_EtaID,BOD_WESchichtID))
!Transpiration (nur WE-Schicht)
CASE (BF_EtaID)
SkalY(anzzr+iproz) = tmpETa
END SELECT
END IF
c IF (LWRITE) THEN c LTMP = BF_FKT_WRITE (datTSTBF, izschr, iProz, c + anzstz(iproz), c + X(1,iproz), Y(1,iproz), c + SkalY(anzzr+iproz), c + BF_VORZEICHEN(iproz)) c END IF
END DO
c ======================================= c Schichten von unten nach oben berechnen c =======================================
SkalY(anzzr) = 0.0
!Exfiltration ist Infiltration aus darunterliegender Schicht
SkalY(anzzr+BF_ExxID) = ABS(ProzRate(BF_InfID,isch+1))
c LTMP = BF_CALC_SCHICHT (Aktdatum, izschr, c + anzzr, anzfun, NSTZ, anzstz, X, Y, m, c + BFMax, BFtmp(isch), BFakt(isch), c + SkalX, SkalY, Proz)
IF (.NOT.LTMP) GOTO 10000
!Falls jetzt Exx(isch) < Inf(isch+1) dann setze:
!a) Inf(isch) = Exx(isch-1) b) Inf(isch) = Niederschlag bei Infiltrationsschicht
If ( ABS(Proz(BF_ExxID))
+ .LT. ABS(ProzRate(BF_InfID,isch+1))) THEN
!Inf und Exx werden nicht über Funktionen berechnet, sondern als fester Input
!Exfiltration:
SkalY(anzzr+BF_ExxID) = 0.0
SkalY(anzzr) = ProzRate(BF_InfID,isch+1) *
+ BF_VORZEICHEN(BF_ExxID)
!Infiltration
SELECT CASE (isch)
CASE (BOD_InfSchichtID)
IF (ABS(Proz(BF_InfID)) .GT. DBLE(Nied)) THEN
SkalY(anzzr+BF_InfID) = 0.0
SkalY(anzzr) = SkalY(anzzr) + Nied
END IF
CASE DEFAULT
IF ( ABS(Proz(BF_InfID))
+ .GT. ProzRate(BF_ExxID,isch-1)) THEN
SkalY(anzzr+BF_InfID) = 0.0
SkalY(anzzr) = SkalY(anzzr) +
+ ProzRate(BF_ExxID,isch-1)
END IF
END SELECT
!auf letzte Bodenfeuchte zurücksetzen
BFakt(isch) = BFtmp(isch)
c LTMP = BF_CALC_SCHICHT (Aktdatum, izschr, c + anzzr, anzfun, NSTZ, anzstz, X, Y, m, c + BFMax, BFtmp(isch), BFakt(isch), c + SkalX, SkalY, Proz)
IF (.NOT.LTMP) GOTO 10000
!Infiltration zuweisen
SELECT CASE (isch)
CASE (BOD_InfSchichtID)
Proz(BF_InfID) = DBLE(Nied) *
+ BF_VORZEICHEN(BF_InfID)
CASE DEFAULT
Proz(BF_InfID) = ProzRate(BF_ExxID,isch-1) *
+ BF_VORZEICHEN(BF_InfID)
END SELECT
!Exfiltration zuweisen
Proz(BF_ExxID) = ProzRate(BF_InfID,isch+1) *
+ BF_VORZEICHEN(BF_ExxID)
END IF
!Bei Überlauf: Bodenschicht übergesättigt, Überlauf wird von BF abgezogen
LTMP = BF_CORRECT_SCHICHT (.FALSE., izschr, Nied,
+ BFtmp(isch), BFakt(isch), anzfun, Proz)
SELECT CASE (isch)
c Infiltrationsschicht
CASE (BOD_InfSchichtID)
c Kontrolle: Niederschlag < pot. Infiltration
IF (Nied.LT.ABS(Proz(BF_InfID))) THEN
BFakt(isch) = BFtmp(isch)
SkalY(anzzr+BF_InfID) = 0.0
SkalY(anzzr+BF_ExxID) = 0.0
SkalY(anzzr) = Nied + ProzRate(BF_InfID,isch+1) *
+ BF_VORZEICHEN(BF_ExxID)
c LTMP = BF_CALC_SCHICHT (Aktdatum, izschr, c + anzzr, anzfun, NSTZ, anzstz, X, Y, m, c + BFMax, BFtmp(isch), BFakt(isch), c + SkalX, SkalY, Proz)
IF (.NOT.LTMP) GOTO 10000
Proz(BF_InfID) = DBLE(Nied)*BF_VORZEICHEN(BF_InfID)
Proz(BF_ExxID) = ProzRate(BF_InfID,isch+1) *
+ BF_VORZEICHEN(BF_ExxID)
END IF
END SELECT
!Bei Überlauf: Bodenschicht übergesättigt, Überlauf wird von BF abgezogen
LTMP = BF_CORRECT_SCHICHT (.FALSE., izschr, Nied,
+ BFtmp(isch), BFakt(isch), anzfun, Proz)
c Übergabe der Prozessraten c -------------------------
DO iproz = 1,anzfun
ProzRate(iproz,isch) = ABS(Proz(iproz))
END DO
c Prozessraten in Testergebnisdatei schreiben c -------------------------------------------
IF (LWRITE) THEN
c LTMP = BF_PROZ_WRITE (datTSTBF, 'u_o', izschr, isch, c + DBLE(Dicke(isch)), c + BFtmp(isch), BFakt(isch), c + anzfun, ProzRate(1,isch), inNied, c + Runoff, ETa, Interflow, Baseflow) c IF (.NOT.LTMP) GOTO 10000
END IF
END IF
END DO
c ----------------------------------------------------------------- c Übergabe der letzten Bodenfeuchtewerte [mm/m] c -----------------------------------------------------------------
DO isch = 1,NSCH
BF(isch) = SNGL(BFakt(isch) / DBLE(Dicke(isch)))
END DO
IF (LWRITE) WRITE(datTSTBF,*)
c ----------------------------------------------------------------- c Übergabe der Abflussbildung [mm/dt] c -----------------------------------------------------------------
Runoff = MAX(0.0, Nied - ProzRate(BF_InfID,BOD_InfSchichtID))
+ * REAL(izschr)
Baseflow = ProzRate(BF_ExxID,BOD_TRSSchichtID) * REAL(izschr)
ETa = 0.0
Interflow = 0.0
DO isch = 1,NSCH
ETa = ETa + ProzRate(BF_EvaID,isch) + ProzRate(BF_EtaID,isch)
Interflow = Interflow + ProzRate(BF_IntID,isch)
END DO
ETa = ETa * REAL(izschr)
Interflow = Interflow * REAL(izschr)
c ----------------------------------------------------------------- c Schreiben der Ergebnisse c -----------------------------------------------------------------
IF (LWRITE) THEN
DO isch = 1,NSCH
c LTMP = BF_PROZ_WRITE (datTSTBF, 'erg', izschr, isch, c + DBLE(Dicke(isch)), c + BFtmp(isch), BFakt(isch), c + anzfun, ProzRate(1,isch), inNied, c + Runoff, ETa, Interflow, Baseflow) c IF (.NOT.LTMP) GOTO 10000
END DO
END IF
LOK = .TRUE.
c ................................................................. 10000 RETURN
END FUNCTION BF_WELOK
cxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
CXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX C Eine Schicht berechnen
FUNCTION BF_CALC_SCHICHT (KENSYS, EFLID, isch, Aktdatum, izschr,
+ anzzr, anzfun, NSTZ, anzstz, X, Y, m,
+ BFMax, BFalt, BFneu, SkalX, SkalY,
+ Prozmit)
+RESULT (LOK)
c .................................................................
USE MODMISC
INTEGER :: EFLID, isch, anzzr, anzfun, NSTZ, izschr, i,
+ imyKng
REAL (KIND=8) :: X(NSTZ, anzfun),
+ Y(NSTZ, anzfun),
+ m(NSTZ, anzfun),
+ SkalX(anzzr + anzfun),
+ SkalY(anzzr + anzfun), BFMax, BFalt, BFneu,
+ S1, S2, Prozmit(anzfun),
+ volfunge, volzrge, Bilanz
INTEGER, DIMENSION(anzfun) :: anzstz, vorzfun
INTEGER, DIMENSION(anzzr) :: vorzzrei
LOGICAL :: LOK, LERROR, zrevor, unstimm
CHARACTER (LEN=*) :: Aktdatum
CHARACTER (LEN=*) :: KENSYS
c .................................................................
LOK = .FALSE.
c Input vorhanden
zrevor = .FALSE.
IF (anzzr.GT.0) zrevor = .TRUE.
c Vorzeichen des Inputs
DO i=1,anzzr
vorzzrei(i) = 1
END DO
c Vorzeichen der Abgaben
DO i=1,anzfun
vorzfun(i) = INT(BF_VORZEICHEN(i))
END DO
c Inhalt
S1 = BFalt
S2 = S1
c Berechnung: nicht-linearer Speicher
imyKng = KNGBF
LERROR = SPEIBELI(imyKng, Aktdatum, izschr,
+ BFMax, S1, S2,
+ zrevor, anzzr, vorzzrei,
+ anzfun, anzstz, vorzfun,
+ X, Y, m, SkalY, SkalX,
+ unstimm, prozmit,
+ volfunge, volzrge, Bilanz)
IF (LERROR) GOTO 10000
c Inhaltszuordnung
BFneu = S2
LOK = .TRUE.
GOTO 10000
c ................................................................. 10000 RETURN
END FUNCTION BF_CALC_SCHICHT
cxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
CXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX c Deallokieren
SUBROUTINE BF_DELETE()
c .................................................................
INTEGER :: i
c ................................................................. c Bodenarten
DO i=1,BOA_aktanz
NULLIFY (BOACONT(i) % ptrboa)
END DO
IF (BOA_anz.GT.0) THEN
DEALLOCATE (BOACONT)
DEALLOCATE (BOA_ID)
END IF
BOA_anz = 0
BOA_aktanz = 0
c Bodentypen
DO i=1,BOD_aktanz
NULLIFY (BODCONT(i) % ptrbod)
END DO
IF (BOD_anz.GT.0) THEN
DEALLOCATE (BODCONT)
DEALLOCATE (BOD_ID)
END IF
BOD_anz = 0
BOD_aktanz = 0
c Landnutzung
DO i=1,LNZ_aktanz
NULLIFY (LNZCONT(i) % ptrlnz)
END DO
IF (LNZ_anz.GT.0) THEN
DEALLOCATE (LNZCONT)
DEALLOCATE (LNZ_ID)
END IF
LNZ_anz = 0
LNZ_aktanz = 0
IF (BF_INIT) THEN
BF_INIT = .FALSE.
c DEALLOCATE (BF_FKT_StartX) c DEALLOCATE (BF_FKT_StartBezug) c DEALLOCATE (BF_FKT_EndeX) c DEALLOCATE (BF_FKT_EndeBezug) c DEALLOCATE (BF_FKT_StartY) c DEALLOCATE (BF_FKT_EndeY) c DEALLOCATE (BF_FKT_Expo) c DEALLOCATE (BF_FKTNAME) c DEALLOCATE (LNZ_HAUDEFAK_GRAS) c DEALLOCATE (BF_VORZEICHEN)
END IF
c ................................................................. 10000 RETURN
END SUBROUTINE BF_DELETE
cxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
CXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX C Eine Schicht nach Überlauf korrigieren c LKORR = .FALSE. : Korrektur nur bei Überlauf c LKORR = .TRUE. : Bilanzausgleich
FUNCTION BF_CORRECT_SCHICHT (LKORR, izschr, Nied, BFalt, BFakt,
+ N, Proz)
+RESULT (LOK)
c .................................................................
INTEGER :: izschr, iproz, N
REAL (KIND=8) :: Proz(N), BFalt, BFakt, SumProz, Fehler
REAL (KIND=4) :: Nied
LOGICAL :: LOK, LKORR
c .................................................................
LOK = .FALSE.
IF (ABS(Proz(BF_MaxID)).GT.0.0 .OR. LKORR) THEN
IF (.NOT.LKORR) THEN
c Infiltration zurücknehmen
Proz(BF_InfID) = MAX(0.0, BF_VORZEICHEN(BF_InfID) *
+ (ABS(Proz(BF_InfID)) - ABS(Proz(BF_MaxID))))
c Overflow aus Null zurücknehmen
Proz(BF_MaxID) = 0.0
END IF
c Bilanz prüfen
SumProz = 0.0
DO iproz = 1,N
SumProz = SumProz + ABS(Proz(iproz)) *
+ REAL(BF_VORZEICHEN(iproz))
END DO
Fehler = BFalt - BFakt + SumProz * REAL(izschr)
IF (Fehler.NE.0.0) THEN
Proz(BF_InfID) = Proz(BF_InfID) - Fehler / REAL(izschr)
IF (ABS(Proz(BF_InfID)).GT.DBLE(Nied)) THEN
Proz(BF_InfID) = DBLE(Nied) * BF_VORZEICHEN(BF_InfID)
ELSEIF (ABS(Proz(BF_InfID)).LT.0.0) THEN
Proz(BF_InfID) = 0.0
END IF
END IF
END IF
LOK = .TRUE.
GOTO 10000
c ................................................................. 10000 RETURN
END FUNCTION BF_CORRECT_SCHICHT
cxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
CXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX C Bei einem Überlauf einer Bodenschicht wird die Infiltration um c den Betrag des Überlaufes reduziert, soweit wie möglich. c Überlauf bleibt erhalten als zusätzlicher Input für die c darüberliegende Schicht
SUBROUTINE BF_BILANZ_SCHICHT (izschr, BFalt, BFakt, N, Proz)
c .................................................................
INTEGER :: izschr, N
REAL (KIND=8) :: Proz(N), BFalt, BFakt
c ................................................................. c Infiltration um den Betrag des Überlaufs zurücknehmen
IF (ABS(Proz(BF_MaxID)).GT.0. .AND. Proz(BF_InfID).GT.0.) THEN
Proz(BF_InfID) = ABS(Proz(BF_InfID)) - ABS(Proz(BF_MaxID))
IF (Proz(BF_InfID).LT.0.) Proz(BF_InfID) = 0.0
END IF
c ................................................................. 10000 RETURN
END SUBROUTINE BF_BILANZ_SCHICHT
cxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
CXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX c neue Bodenfeuchte aus den Bodenprozessen mit einfacher c Kontigleichung berechnen
SUBROUTINE BF_KONTI_SCHICHT (izschr, BFalt, BFakt,
+ N, Proz)
c .................................................................
INTEGER :: izschr, iproz, N
REAL (KIND=8) :: Proz(N), BFalt, BFakt, SumProz
c .................................................................
SumProz = 0.0
DO iproz=1,N
IF (iproz.NE.BF_MaxID) THEN
SumProz = SumProz + Proz(iproz) * REAL(izschr)
END IF
END DO
BFakt = BFalt + SumProz
c ................................................................. 10000 RETURN
END SUBROUTINE BF_KONTI_SCHICHT
cxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
cxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
FUNCTION BOA_CHECK_ID (ID) RESULT (LOK)
c .................................................................
INTEGER :: ID, i
LOGICAL :: LOK
c .................................................................
LOK = .FALSE.
DO i=1,BOA_aktanz
IF (BOACONT(i) % ptrboa % BOAID.EQ.ID) THEN
LOK = .TRUE.
GOTO 10000
END IF
END DO
c ................................................................. 10000 RETURN
END FUNCTION BOA_CHECK_ID
cxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
cxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
FUNCTION BOD_CHECK_ID (ID) RESULT (LOK)
c .................................................................
INTEGER :: ID, i
LOGICAL :: LOK
c .................................................................
LOK = .FALSE.
DO i=1,BOD_aktanz
IF (BODCONT(i) % ptrbod % BODID.EQ.ID) THEN
LOK = .TRUE.
GOTO 10000
END IF
END DO
c ................................................................. 10000 RETURN
END FUNCTION BOD_CHECK_ID
cxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
cxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
FUNCTION LNZ_CHECK_ID (ID) RESULT (LOK)
c .................................................................
INTEGER :: ID, i
LOGICAL :: LOK
c .................................................................
LOK = .FALSE.
DO i=1,LNZ_aktanz
IF (LNZCONT(i) % ptrlnz % LNZID.EQ.ID) THEN
LOK = .TRUE.
GOTO 10000
END IF
END DO
c ................................................................. 10000 RETURN
END FUNCTION LNZ_CHECK_ID
cxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
cxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
FUNCTION BOA_GET_ATTRIB (BOAID, BoArt, WP, FK, GPV, kf,
+ MaxInf, MaxKap)
+RESULT (LOK)
c .................................................................
TYPE (BOA_type), POINTER :: objptr
REAL :: WP, FK, GPV, kf, MaxInf, MaxKap
INTEGER :: ID, BOAID, BoArt
LOGICAL :: LOK
c .................................................................
LOK = .FALSE.
WP = 0.0
FK = 0.0
GPV = 0.0
kf = 0.0
MaxInf = 0.0
MaxKap = 0.0
BoArt = 0
ID = BOA_GET_ID (BOAID)
IF (ID.GT.0) THEN
objptr => BOA_IDObj (ID)
WP = objptr % WP
FK = objptr % FK
GPV = objptr % GPV
kf = objptr % kf
MaxInf = objptr % MaxInf
MaxKap = objptr % MaxKap
BoArt = objptr % BOART
LOK = .TRUE.
END IF
c ................................................................. 10000 RETURN
END FUNCTION BOA_GET_ATTRIB
cxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
cxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
FUNCTION LNZ_GET_WE (LNZID) RESULT (WE)
c .................................................................
TYPE (LNZ_type), POINTER :: objptr
REAL :: WE
INTEGER :: LNZID, ID
c .................................................................
WE = 0.0
ID = LNZ_GET_ID(LNZID)
IF (ID.GT.0) THEN
objptr => LNZ_IDObj (ID)
WE = objptr % WE
END IF
c ................................................................. 10000 RETURN
END FUNCTION LNZ_GET_WE
cxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
cxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
FUNCTION LNZ_GET_HAUDEFAK (LNZID, imon) RESULT (FAK)
c .................................................................
USE MODGGL
TYPE (LNZ_type), POINTER :: objptr
REAL :: FAK, tmp
INTEGER :: LNZID, ID, imon
c .................................................................
FAK = LNZ_HAUDEFAK_CONST
ID = LNZ_GET_ID(LNZID)
IF (ID.GT.0) THEN
objptr => LNZ_IDObj (ID)
If (objptr % HaudeFakJGG.GT.0) THEN
tmp = GGL_WERT (1.0, imon, 1, 1, 1,
+ objptr % HaudeFakJGG, 0, 0)
IF (tmp.LT.NULL) THEN
FAK = 1.0 !Haudefaktor = 0: Es darf keine Veränderung an der pot. Verdunstung geben
ELSE
FAK = tmp / LNZ_HAUDEFAK_GRAS(imon) !Haudefaktor > 0: Pot. Verdunstung erfährt Veränderung
END IF
ELSE
FAK = LNZ_HAUDEFAK_CONST / LNZ_HAUDEFAK_GRAS(imon)
ENDIF
END IF
c ................................................................. 10000 RETURN
END FUNCTION LNZ_GET_HAUDEFAK
cxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
cxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
FUNCTION LNZ_ETP_ADJUST (EvaKng, ETpIn, HaudeVerdFak)
+RESULT (ETpOut)
c .................................................................
REAL :: ETpIn, ETpOut, HaudeVerdFak
INTEGER :: EvaKng
c .................................................................
IF (EvaKng.EQ.EVA_HaudeID) THEN
ETpOut = DBLE(ETpIn * HaudeVerdFak)
ELSEIF (EvaKng.EQ.EVA_BelmansID) THEN
ETpOut = ETpIn
ELSEIF (EvaKng.EQ.EVA_PotentiellID) THEN
ETpOut = ETpIn
END IF
c ................................................................. 10000 RETURN
END FUNCTION LNZ_ETP_ADJUST
cxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
cxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
FUNCTION LNZ_GET_PARA (LNZID, imon, MaxINTC, LAI, BedGrad,
+ HaudeFak)
+RESULT(LOK)
c .................................................................
USE MODGGL
TYPE (LNZ_type), POINTER :: objptr
REAL :: LAI, MaxINTC, BedGrad, HaudeFak
INTEGER :: ID, LNZID, imon
LOGICAL :: LOK
c .................................................................
LOK = .FALSE.
ID = LNZ_GET_ID(LNZID)
IF (ID.GT.0) THEN
objptr => LNZ_IDObj(ID)
LAI = GGL_WERT (objptr % BFI, imon, 1, 1, 1,
+ objptr % BFIJGG, 0, 0)
MAXINTC = 0.935 + 0.498 * LAI - 0.00575 * LAI * LAI
BedGrad = GGL_WERT (objptr % BG, imon, 1, 1, 1,
+ objptr % BGJGG, 0, 0)
If (objptr % HaudeFakJGG.GT.0) THEN
HaudeFak = GGL_WERT (1.0, imon, 1, 1, 1,
+ objptr % HaudeFakJGG, 0, 0)
ELSE
HaudeFak = LNZ_HAUDEFAK_GRAS(imon)
ENDIF
LOK = .TRUE.
END IF
c ................................................................. 10000 RETURN
END FUNCTION LNZ_GET_PARA
cxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
cxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
SUBROUTINE BF_GET_ETPANSATZ (EvaKng, ETpKng)
c .................................................................
INTEGER :: EvaKng, ETpKng
c .................................................................
EvaKng = EVA_HaudeID
c EVA_BelmansID c EvaKng = EVA_PotentiellID
ETpKng = ETP_LinearID
c ................................................................. 10000 RETURN
END SUBROUTINE BF_GET_ETPANSATZ
cxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
cxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx c Aggregation des Simulationsbodens aus den Eingangsdaten
FUNCTION BF_BODEN_PREPARE (BODID, WE, Dicke,
+ SimBOART, SimWP, SimFK, SimGPV,
+ SimKF, SimMaxInf, SimMaxKap)
+RESULT(iKNG)
c .................................................................
TYPE (BOD_type), POINTER :: objptr
REAL :: Gewicht(BF_MAX_SCHICHTEN, BF_SIM_SCHICHTEN),
+ SimWP(BF_SIM_SCHICHTEN), SimFK(BF_SIM_SCHICHTEN),
+ SimGPV(BF_SIM_SCHICHTEN), Simkf(BF_SIM_SCHICHTEN),
+ SimMaxInf(BF_SIM_SCHICHTEN),
+ SimMaxKap(BF_SIM_SCHICHTEN),
+ Dicke(BF_SIM_SCHICHTEN),
+ WE
INTEGER :: SimBOART(BF_SIM_SCHICHTEN), BODID, ID, iKNG, iTMP
c .................................................................
iKNG = ERR_BOD_PARAMETER
iTMP = 0
ID = BOD_GET_ID (BODID)
IF (ID.GT.0) THEN
objptr => BOD_IDObj (ID)
iTMP = BF_SCHICHT_PARA (objptr, WE, Dicke(1), Gewicht(1,1))
IF (iTMP.LT.0) GOTO 9999
iTMP = BF_BODEN_PARA (objptr, Gewicht(1,1), SimBOART(1),
+ SimWP(1), SimFK(1), SimGPV(1), SimKF(1),
+ SimMaxInf(1), SimMaxKap(1))
IF (iTMP.LT.0) GOTO 9999
iKNG = 0
END IF
IF (LBFOUT) THEN
CALL BF_BODEN_WRITE(ID, datTSTBF,
+ BF_SIM_SCHICHTEN, SimBOART,
+ Dicke, SimWP, SimFK, SimGPV,
+ SimKF, SimMaxInf, SimMaxKap)
END IF
GOTO 10000
c ................................................................. 9999 iKNG = iTMP
GOTO 10000
c ................................................................. 10000 RETURN
END FUNCTION BF_BODEN_PREPARE
cxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
cxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx c Berechnung der Bodendicken und Wichtungsfaktoren zur Simulation c (nach Marcus Lempert + Stefan Bente), modifiziert (HL)
FUNCTION BF_SCHICHT_PARA (objptr, WE, SimDicke, Gewicht)
+RESULT(iKNG)
c .................................................................
USE MODERR
TYPE (BOD_type), POINTER :: objptr
INTEGER :: iKng, i, j, istart
REAL :: Gewicht(BF_MAX_SCHICHTEN, BF_SIM_SCHICHTEN),
+ SimDicke(BF_SIM_SCHICHTEN),
+ dA(BF_MAX_SCHICHTEN), dE(BF_MAX_SCHICHTEN),
+ dASim(BF_SIM_SCHICHTEN), dESim(BF_SIM_SCHICHTEN),
+ WE, dAnf, dEnd, dD, GesDicke, Summe
LOGICAL :: LTMP
c .................................................................
iKng = ERR_BOD_PARAMETER
c Gesamtdicke des original Bodens
GesDicke = objptr % Dicke(1)
dA(1) = 0
DO i=2,objptr % NBOA
dE(i-1) = GesDicke
dA(i) = dE(i-1)
GesDicke = GesDicke + objptr % Dicke(i)
END DO
dE(objptr % NBOA) = GesDicke
c Schichtdicken des Simulationsbodens c Wurzeltiefe ausreichend!
IF (WE.LT.(BOD_dInfSchicht + BOD_minD_WESchicht)) THEN
Err_Kennung = ERR_LNZ_PARAMETER
If (.NOT.DLL_MODE) THEN
LTMP = FEHLER(3323, 'WE ', ' ', objptr % BodID)
GOTO 9999
END IF
END IF
c Wurzeltiefe zu gross
IF (WE.GT.GesDicke) WE = GesDicke
c Gesamtdicke ausreichend!
IF (GesDicke.LT.(BOD_dInfSchicht +
+ BOD_minD_WESchicht +
+ BOD_minD_TRSSchicht)) THEN
Err_Kennung = ERR_LNZ_PARAMETER
GOTO 9999
END IF
c Berechnungsschichtdicken zuweisen
SimDicke(BOD_InfSchichtID) = BOD_dInfSchicht
SimDicke(BOD_WESchichtID) = WE - SimDicke(BOD_InfSchichtID)
SimDicke(BOD_TRSSchichtID) = GesDicke -
+ (SimDicke(BOD_InfSchichtID) +
+ SimDicke(BOD_WESchichtID))
c Berechnungsschichtdicke TRS-Schicht prüfen
IF (SimDicke(BOD_TRSSchichtID).LT.BOD_minD_TRSSchicht) THEN
SimDicke(BOD_WESchichtID) = SimDicke(BOD_WESchichtID) -
+ BOD_minD_TRSSchicht
SimDicke(BOD_TRSSchichtID) = BOD_minD_TRSSchicht
END IF
c Gesamtdicke des Simulationsbodens
DO j=1,objptr % NBOA
Gewicht(j,1) = 0.0
END DO
GesDicke = SimDicke(1)
dASim(1) = 0
DO i=2,BF_SIM_SCHICHTEN
dESim(i-1) = Gesdicke
dASim(i) = dESim(i-1)
GesDicke = GesDicke + SimDicke(i)
DO j=1,objptr % NBOA
Gewicht(j,i) = 0.0
END DO
END DO
dESim(BF_SIM_SCHICHTEN) = GesDicke
c Berechnung der Anteile der jeweiligen Bodenschicht an der Simulationsschicht
istart = 1
DO i=1,BF_SIM_SCHICHTEN
j = istart
DO WHILE (dE(j).LE.dASim(i))
j = j + 1
IF (j.GT.objptr % NBOA) EXIT
END DO
IF (j.GT.objptr % NBOA) j = j - 1
DO WHILE (dA(j).LT.dESim(i))
dAnf = MAX(0.,dASim(i) - dA(j))
dD = dE(j) - dA(j)
dEnd = MAX(0.,dE(j) - dESim(i))
Gewicht(j,i) = (dD - dAnf - dEnd) / (dESim(i) - dASim(i))
j = j + 1
IF (j.GT.objptr % NBOA) EXIT
END DO
istart = j - 1
END DO
c Wichtungsfaktoren müssen in der Summe 1 ergeben
DO i=1,BF_SIM_SCHICHTEN
Summe = 0.
DO j = 1, objptr % NBOA
Summe = Summe + Gewicht(j, i)
END DO
IF (ABS (1.-Summe) .GT. NULL) THEN
ERR_KENNUNG = ERR_BOD_PARAMETER
GOTO 9999
END IF
END DO
iKng = 0
GOTO 10000
c ................................................................. 9999 iKng = Err_Kennung
GOTO 10000
c ................................................................. 10000 RETURN
END FUNCTION BF_SCHICHT_PARA
cxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
cxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx c Berechnung der Bodengroessen aus Wichtungsfaktoren zur Simulation c (nach Marcus Lempert + Stefan Bente)
FUNCTION BF_BODEN_PARA (objptr, Gewicht, SimBOART,
+ SimWP, SimFK, SimGPV, SimKF,
+ SimMaxInf, SimMaxKap)
+RESULT(iKNG)
c .................................................................
TYPE (BOD_type), POINTER :: objptr
INTEGER :: SimBOART(BF_SIM_SCHICHTEN), BodenArt, i, j, iKNG
REAL :: Gewicht(BF_MAX_SCHICHTEN, BF_SIM_SCHICHTEN),
+ SimWP(BF_SIM_SCHICHTEN), SimFK(BF_SIM_SCHICHTEN),
+ SimGPV(BF_SIM_SCHICHTEN), Simkf(BF_SIM_SCHICHTEN),
+ SimMaxKap(BF_SIM_SCHICHTEN),
+ SimMaxInf(BF_SIM_SCHICHTEN),
+ WP, FK, GPV, kf, MaxInf, MaxKap, tmpBoart
LOGICAL :: LTMP
c .................................................................
iKNG = ERR_BOD_PARAMETER
DO i=1,BF_SIM_SCHICHTEN
tmpBoart = 0.0
SimWP(i) = 0.0
SimFK(i) = 0.0
SimGPV(i) = 0.0
SimKf(i) = 0.0
SimMaxInf(i) = 0.0
SimMaxKap(i) = 0.0
DO j=1,objptr % NBOA
LTMP = BOA_GET_ATTRIB (objptr % BOAID(j), BodenArt,
+ WP, FK, GPV, kf, MaxInf, MaxKap)
IF (.NOT.LTMP) GOTO 9999
SimWP(i) = SimWP(i) + WP * Gewicht(j,i)
SimFK(i) = SimFK(i) + FK * Gewicht(j,i)
SimGPV(i) = SimGPV(i) + GPV * Gewicht(j,i)
tmpBoart = tmpBoart + REAL(BodenArt) * Gewicht(j,i)
SimBOART(i) = MIN(SimBOART(i),BF_ANZ_BOART)
SimBOART(i) = MAX(SimBOART(i),1)
IF (kf.GT.GLOBAL_NULL) THEN
SimKf(i) = SimKf(i) + Gewicht(j,i) / kf
END IF
IF (MaxKap.GT.GLOBAL_NULL) THEN
SimMaxKap(i) = SimMaxKap(i) + Gewicht(j,i) / MaxKap
END IF
!Nur die SimInfSchicht erhält die MaxInf aus der obersten Schicht
If (i.EQ.BOD_InfSchichtID) SimMaxInf(i) = MaxInf
END DO
tmpBoart = MAX(1.0,(tmpBoart/REAL(objptr % NBOA)))
SimBOART(i) = NINT(MIN(REAL(BF_ANZ_BOART), tmpBOART))
c kf-Wert Aggregation nach Prinzip Erhaltung der Kontinuität der Strömung /H.Lohr (1993), Vertieferarbeit, S. 73/
If (SimKf(i).GT.GLOBAL_NULL) THEN
SimKf(i) = 1.0 / SimKf(i)
ELSE
ERR_KENNUNG = ERR_BOD_PARAMETER
GOTO 9999
END IF
c MaxKap-Wert Aggregation nach Prinzip Erhaltung der Kontinuität der Strömung /H.Lohr (1993), Vertieferarbeit, S. 73/
If (SimMaxKap(i).GT.GLOBAL_NULL) THEN
SimMaxKap(i) = 1.0 / SimMaxKap(i)
ELSE
SimMaxKap(i) = 0.0
END IF
END DO
iKNG = 0
GOTO 10000
c ................................................................. 9999 iKNG = ERR_KENNUNG
GOTO 10000
c ................................................................. 10000 RETURN
END FUNCTION BF_BODEN_PARA
cxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
CXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX C Funktionsverlauf fuer Bodenart/Prozess bestimmen
FUNCTION BF_FKT_X (BOART, iProzess, XSkal, WP, FK, GPV, X)
+RESULT (NSTZ)
c .................................................................
REAL (KIND=8) :: X(BF_MAXSTZ), BFWert(BF_ANZ_BEZUG),
+ dX, BFMax1, BFMax2, nFK, BFStart, BFEnd, xEnd
REAL (KIND=4) :: XSkal, WP, FK, GPV
INTEGER :: BOART, iProzess, istz, istart, NSTZ
c .................................................................
NSTZ = 0
BFWert(wpBF) = DBLE(WP)
BFWert(fkBF) = DBLE(FK)
BFWert(nfkBF) = DBLE(FK - WP)
BFWert(gpvBF) = DBLE(GPV)
c Maximalen X-Wert festlegen
BFMax1 = DBLE(BF_XMAX_FAKTOR * GPV)
BFMax2 = DBLE(GPV) * DBLE(BF_XMAX_FAKTOR**2.)
nFK = DBLE(FK - WP)
c Stützstellen festlegen, die für alle gültig sind
istz = 1
X(istz) = 0.0
c Konstanter Funktionsverlauf
IF (iProzess.EQ.BF_ConstID) THEN
istz = istz + 1
X(istz) = 0.001
istz = istz + 1
X(istz) = BFWert(gpvBF) / 1.01
GOTO 9000
END IF
c Stützstellen festlegen: X-Werte sind zwischen 0 und BFMax definiert
BFStart = BF_FKT_StartX(iProzess,BOART) *
+ BFWert(BF_FKT_StartBezug(iProzess,BOART))
!X-Werte zählen von BF=0 bis FK, obwohl nFk steht
IF (BF_FKT_StartBezug(iProzess,BOART).EQ.nfkBF)
+ BFStart = BFStart + BFWert(wpBF)
!Startwert
istart = BF_STZ_START
X(istart) = BFStart
!Endwert
BFEnd = BF_FKT_EndeX(iProzess,BOART) *
+ BFWert(BF_FKT_EndeBezug(iProzess,BOART))
!X-Werte zählen von BF=0 bis FK, obwohl nFk steht
IF (BF_FKT_EndeBezug(iProzess,BOART).EQ.nfkBF)
+ BFEnd = BFEnd + BFWert(wpBF)
!Fuer kap. Aufstieg gilt: Ende ist gleich Anfang von Exfil
IF (iProzess.EQ.BF_KapID) THEN
BFEnd = BF_FKT_StartX(BF_ExxID,BOART) *
+ BFWert(BF_FKT_StartBezug(BF_ExxID,BOART))
!X-Werte zählen von BF=0 bis FK, obwohl nFk steht
IF (BF_FKT_StartBezug(BF_ExxID,BOART).EQ.nfkBF) THEN
BFEnd = BFEnd + BFWert(wpBF)
END IF
END IF
IF (iProzess.NE.BF_MaxID) THEN
xEnd = BFEnd
IF (xEnd.GE.BFWert(gpvBF)) xEnd = BFWert(gpvBF) / 1.01
!X-Schrittweite als Verhältniszahl berechnen
dX = (xEnd - BFStart) / DBLE(BF_FKTSTZ-BF_STZ_REST)
istz = BF_STZ_START
DO WHILE (X(istz).LT.xEnd)
istz = istz + 1
X(istz) = X(istz-1) + dX
X(istz) = X(istz)
END DO
!Endwert des Funktionsverlaufes
istz = istz - 1
X(istz) = xEnd
istz = istz + 1
X(istz) = BFWert(gpvBF)
ELSEIF (iProzess.EQ.BF_MaxID) THEN
istz = istart
END IF
c letzte Stützstellen ist immer groesser als GPV 9000 istz = istz + 1
X(istz) = BFMax1
istz = istz + 1
X(istz) = BFMax2
NSTZ = istz
DO istz=1,NSTZ
X(istz) = X(istz) * DBLE(XSkal)
END DO
c ................................................................. 10000 RETURN
END FUNCTION BF_FKT_X
cxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
CXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX C Funktionsverlauf fuer Bodenart/Prozess bestimmen
FUNCTION BF_FKT_Y(SchichtID, BOART, iProzess, EtpKng,
+ MaxInf, kf, MaxKap, ANZ, X, Y, SkalY)
+RESULT (NSTZ)
c .................................................................
INTEGER :: SchichtID, BOART, iProzess, EtpKng,
+ NSTZ, ANZ, istz, istart, iend
REAL (KIND=8) :: X(ANZ), Y(ANZ), SkalY, EndWert, LastFktWert
REAL (KIND=4) :: MaxInf, kf, MaxKap
c .................................................................
NSTZ = 0
c Letzter Funktionswert ist immer Null
LastFktWert = BF_LAST_YWERT
EndWert = BF_LAST_YWERT
istart = BF_STZ_START
iend = ANZ - BF_STZ_REST - 1
c Erster Funktionswert ist immer Null
istz = 1
Y(istz) = 0.0
SELECT CASE (iProzess)
CASE (BF_ConstID)
!konstante Funktion
DO istz=2,ANZ
Y(istz) = 1.0
END DO
SkalY = 1.0
CASE (BF_InfID)
!Ansatz nach Holtan: Inf = MaxInf * ((Xend-X)/Xend-Xstart)^expo + kf ; Skalierung = MaxInf+kf
!X = 0; Y = ?
Y(istz) = BF_FKT_StartY(iProzess,BOART)
!Ester Wert des Funktionsverlaufes
Y(istart) = BF_FKT_StartY(iProzess,BOART)
DO istz = istart + 1, iend
Y(istz) = ((X(iend)-X(istz))/(X(iend)-X(istart)))**
+ BF_FKT_EXPO(iProzess,BOART)
Y(istz) = DBLE(MaxInf) * Y(istz)
Y(istz) = Y(istz) + DBLE(kf)
!Skalierung zwischen 0 und 1
IF ((MaxInf+kf).GT.GLOBAL_NULL) THEN
Y(istz) = Y(istz) / DBLE(MaxInf+kf)
ELSE
Y(istz) = 0.
END IF
END DO
SkalY = DBLE(MaxInf+kf)
CASE (BF_ExxID)
!Ansatz nach Irmay/Bear: Exx = kf*(X-Xstart)/Xend-Xstart)^expo ; Skalierung = kf
!X = 0; Y = ?
Y(istz) = 0.0
!Ester Wert des Funktionsverlaufes
Y(istart) = BF_FKT_StartY(iProzess,BOART)
DO istz = istart + 1, iend
!Y-Werte sind bereits zwischen 0 und 1 skaliert
Y(istz) = (X(istz)-X(istart)) / (X(iend)-X(istart))
Y(istz) = Y(istz) ** BF_FKT_EXPO(iProzess,BOART)
END DO
SkalY = DBLE(kf)
CASE (BF_IntID)
!X = 0; Y = ?
Y(istz) = 0.0
!Ester Wert des Funktionsverlaufes
Y(istart) = BF_FKT_StartY(iProzess,BOART)
DO istz = istart + 1, iend
!Y-Werte sind bereits zwischen 0 und 1 skaliert
Y(istz) = (X(istz)-X(istart)) / (X(iend)-X(istart))
Y(istz) = Y(istz) ** BF_FKT_EXPO(iProzess,BOART)
END DO
!Interflow nur in der Infiltrationsschicht:
IF (SchichtID.EQ.BOD_InfSchichtID) THEN
SkalY = DBLE(kf)
ELSE
SkalY = 0.0
END IF
CASE (BF_KapID)
! kap. Aufstieg geht linear auf 0 am Punkt, wo Exfil anfaengt!
!X = 0; Y = ?
Y(istz) = BF_FKT_StartY(iProzess,BOART)
!Ester Wert des Funktionsverlaufes
Y(istart) = BF_FKT_StartY(iProzess,BOART)
DO istz = istart + 1, iend
!Y-Werte sind bereits zwischen 0 und 1 skaliert
Y(istz) = 1.0-(X(istz)-X(istart))/(X(iend)-X(istart))
END DO
!Kapauf nicht in der Infiltrationsschicht:
IF (SchichtID.EQ.BOD_InfSchichtID) THEN
SkalY = 0.0
ELSE
SkalY = DBLE(MaxKap)
END IF
CASE (BF_EvaID)
! Evaporation geht linear von 0.0 bei WP bis 1.0 bei FK; Skalierung in BF_WEL
!X = 0; Y = ?
Y(istz) = 0.0
!Ester Wert des Funktionsverlaufes
Y(istart) = BF_FKT_StartY(iProzess,BOART)
DO istz = istart + 1, iend
Y(istz) = (X(istz)-X(istart)) / (X(iend)-X(istart))
END DO
!Evaporation nur in der Inf-Schicht:
IF (SchichtID.EQ.BOD_InfSchichtID) THEN
SkalY = 1.0
ELSE
SkalY = 0.0
END IF
CASE (BF_EtaID)
!X = 0; Y = ?; Skalierung in BF_WEL
Y(istz) = 0.0
!Ester Wert des Funktionsverlaufes
Y(istart) = BF_FKT_StartY(iProzess,BOART)
! Evapotranspiration geht linear von 0.0 bei WP bis 1.0
IF (EtpKng.EQ.ETP_LinearID) THEN
DO istz = istart + 1, iend
Y(istz) = (X(istz)-X(istart)) / (X(iend)-X(istart))
END DO
ELSEIF (EtpKng.EQ.ETP_AlbertID) THEN
DO istz = istart + 1, iend
Y(istz) = (X(istz)-X(istart)) / (X(iend)-X(istart))
END DO
END IF
!Evapotranspiration nur in der Wurzelschicht:
IF (SchichtID.EQ.BOD_WESchichtID) THEN
SkalY = 1.0
ELSE
SkalY = 0.0
END IF
CASE (BF_MaxID)
Y(istz) = 0.0
!Ester Wert des Funktionsverlaufes
Y(istart) = BF_FKT_StartY(iProzess,BOART)
!Letzter Wert des Funktionsverlaufes
LastFktWert = 1.0
EndWert = 1.0
SkalY = BF_YMAX_FAKTOR
END SELECT
Y(ANZ-2) = Y(iend)
c vorletzte Stützstelle ist bereits auf BF_LAST_YWERT abgedreht
Y(ANZ-1) = LastFktWert
c letzte Stützstellen ist immer BF_LAST_YWERT nach GPV: Abbrehen der Funktionen
Y(ANZ) = EndWert
NSTZ = ANZ
Goto 10000
c ................................................................. 10000 RETURN
END FUNCTION BF_FKT_Y
cxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
CXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX C Funktionsverlauf fuer Bodenart/Prozess in Datei schreiben
FUNCTION BF_FKT_WRITE (datnr, izschr, iProzess,
+ KENSYS, EFLID, isch,
+ WP, FK, GPV,
+ Dicke, BFFak,
+ N, X, Y, SkalY, Vorz)
+RESULT (LOK)
c .................................................................
INTEGER :: datnr, izschr, N, iProzess, EFLID, isch, i
REAL (KIND=8) :: X(N), Y(N), SkalY, tmpSkal, myX
REAL (KIND=4) :: WP, FK, GPV, Dicke, BFFak, Vorz
LOGICAL :: LOK
CHARACTER (LEN=*) :: KENSYS
c ................................................................. 100 FORMAT(1X, 2(1X, F35.10))
LOK = .FALSE.
c tmpSkal = SkalY * REAL(izschr)
tmpSkal = SkalY
OPEN (UNIT=datnr, FILE=TRIM(BF_FKTNAME(iProzess))//'.FKT',
+ STATUS='UNKNOWN', POSITION='APPEND', ERR=10000)
c WRITE(datnr, '(A)') '*FKT'
WRITE(datnr, '(A,1X,A,I4,1X,I4,3(1X,F8.3))')
+ TRIM(BF_FKTNAME(iProzess)), KENSYS, EFLID, isch,
+ WP, FK, GPV
DO i=1,N
myX = X(i) / (Dicke * BFFak)
WRITE(datnr, 100) myX, Y(i) * tmpSkal * Vorz
END DO
LOK = .TRUE.
c .................................................................
CLOSE(datnr)
10000 RETURN
END FUNCTION BF_FKT_WRITE
cxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
CXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX C Bodenprozesse in Datei schreiben
FUNCTION BF_PROZ_WRITE (datnr, Kensys, EFLID, cKng, izschr, isch,
+ BfFak,
+ Dicke, BFalt, BF, N, Proz,
+ Nied, Runoff, ETa, Interflow, Baseflow)
+RESULT (LOK)
c .................................................................
INTEGER :: datnr, izschr, EFLID, isch, N, i
REAL (KIND=8) :: Proz(N), tmpProz(N),
+ Dicke, BF, BFalt, SumProz, Fehler
REAL (KIND=4) :: Nied, Runoff, ETa, Interflow, Baseflow, BfFak
LOGICAL :: LOK
CHARACTER (LEN=*) :: Kensys
CHARACTER (LEN=*) :: cKng
c ................................................................. 100 FORMAT(1X, A4, I5, A3, I5, 100(F15.3))
LOK = .FALSE.
DO i=1,N
tmpProz(i) = Proz(i) / BfFak
END DO
SumProz = 0.0
c Summe der Prozesse ohne Überlauf, da der in der Infiltration berücksichtigt wurde
DO i=1,N
IF (i.NE.BF_MaxID) THEN
SumProz = SumProz + tmpProz(i)
END IF
END DO
Fehler = Bfalt/BfFak - BF/BfFak + SumProz * DBLE(izschr)
WRITE(datnr, 100) Kensys, EFLID, cKng, isch,
+ BF/Dicke, BFalt/BfFak, BF/BfFak,
+ (tmpProz(i)*REAL(izschr),i=1,N), Fehler
c IF (cKng.EQ.'erg' .AND. isch.EQ.BF_SIM_SCHICHTEN) THEN c WRITE(datnr, '(5(A10))') 'HN [mm]', 'HNeff[mm]', c + ' ETa [mm]', 'Int [mm]', 'Base [mm]' c WRITE(datnr, '(5(F10.3))') Nied, Runoff, ETa, c + Interflow, Baseflow c END IF
LOK = .TRUE.
c ................................................................. 1000 RETURN
END FUNCTION BF_PROZ_WRITE
cxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
CXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX C Bodenschichtung in Datei schreiben
SUBROUTINE BF_BODEN_WRITE (ID, datnr, N, BOART, DICKE,
+ WP, FK, GPV, KF, MaxInf, MaxKap)
c .................................................................
INTEGER :: ID, datnr, N, i
INTEGER :: BOART(N)
REAL (KIND=4) :: Dicke(N), WP(N), FK(N), GPV(N),
+ KF(N), MaxInf(N), MaxKap(N)
c ................................................................. 100 FORMAT(1X, 3(I3), 7(F10.5))
CALL BF_OPENFILE(datnr)
DO i=1,N
WRITE(datnr, 100) ID, i, BOART(i), Dicke(i),
+ WP(i), FK(i), GPV(i), KF(i),
+ MaxInf(i), maxKap(i)
END DO
WRITE(datnr, *)
c ................................................................. 1000 RETURN
END SUBROUTINE BF_BODEN_WRITE
cxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
CXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX C Mindestwurzeltiefe
FUNCTION BF_LNZ_MINWE () RESULT (MinWE)
c .................................................................
REAL :: MinWE
c .................................................................
MinWE = BOD_minDicke
c ................................................................. 10000 RETURN
END FUNCTION BF_LNZ_MINWE
cxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
CXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX C Versionsnummer des Moduls
FUNCTION BF_VERSION () RESULT (VERSION)
c .................................................................
REAL :: VERSION
c .................................................................
VERSION = BF_MODUL_VERSION
c ................................................................. 10000 RETURN
END FUNCTION BF_VERSION
cxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
CXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX C ID zu einer BOAID
FUNCTION BOA_GET_ID (BOAID) RESULT (ID)
c .................................................................
INTEGER :: ID, BOAID, i
c .................................................................
ID = 0
DO i=1,BOA_aktanz
IF (BOACONT(i) % ptrboa % BOAID.EQ.BOAID) THEN
ID = i
EXIT
END IF
END DO
c ................................................................. 10000 RETURN
END FUNCTION BOA_GET_ID
cxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
CXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX C ID zu einer BODID
FUNCTION BOD_GET_ID (BODID) RESULT (ID)
c .................................................................
INTEGER :: ID, BODID, i
c .................................................................
ID = 0
DO i=1,BOD_aktanz
IF (BODCONT(i) % ptrbod % BODID.EQ.BODID) THEN
ID = i
EXIT
END IF
END DO
c ................................................................. 10000 RETURN
END FUNCTION BOD_GET_ID
cxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
CXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX C ID zu einer LNZID
FUNCTION LNZ_GET_ID (LNZID) RESULT (ID)
c .................................................................
INTEGER :: ID, LNZID, i
c .................................................................
ID = 0
DO i=1,LNZ_aktanz
IF (LNZCONT(i) % ptrlnz % LNZID.EQ.LNZID) THEN
ID = i
EXIT
END IF
END DO
c ................................................................. 10000 RETURN
END FUNCTION LNZ_GET_ID
cxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
CXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX C Objekt zu einer ID
FUNCTION BOA_IDObj(ID) RESULT (objptr)
c .................................................................
TYPE (BOA_type), POINTER :: objptr
INTEGER :: ID
c .................................................................
IF (ID.GE.1 .AND. ID.LE.BOA_aktanz) THEN
objptr => BOACONT(ID) % ptrboa
GOTO 10000
END IF
NULLIFY (objptr)
GOTO 10000
c Fehlermeldungen c ................................................................. 10000 RETURN
END FUNCTION BOA_IDObj
cxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
CXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX C Objekt zu einer ID
FUNCTION BOD_IDObj(ID) RESULT (objptr)
c .................................................................
TYPE (BOD_type), POINTER :: objptr
INTEGER :: ID
c .................................................................
IF (ID.GE.1 .AND. ID.LE.BOD_aktanz) THEN
objptr => BODCONT(ID) % ptrbod
GOTO 10000
END IF
NULLIFY (objptr)
GOTO 10000
c Fehlermeldungen c ................................................................. 10000 RETURN
END FUNCTION BOD_IDObj
cxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
CXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX C Objekt zu einer ID
FUNCTION LNZ_IDObj(ID) RESULT (objptr)
c .................................................................
TYPE (LNZ_type), POINTER :: objptr
INTEGER :: ID
c .................................................................
IF (ID.GE.1 .AND. ID.LE.LNZ_aktanz) THEN
objptr => LNZCONT(ID) % ptrlnz
GOTO 10000
END IF
NULLIFY (objptr)
GOTO 10000
c ................................................................. 10000 RETURN
END FUNCTION LNZ_IDObj
cxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
CXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX c Bodenfeuchtetestausgabe
SUBROUTINE BF_OPENFILE (datnr)
c .................................................................
INTEGER :: i, datnr
LOGICAL :: LTMP
c ................................................................. 100 FORMAT(1X, A4, A5, A3, A5, 100(A15))
INQUIRE (UNIT = datnr, OPENED = LTMP)
IF (.NOT.LTMP) THEN
OPEN(UNIT=datnr, FILE=TST_FILENAMEBF,
+ STATUS='unknown', ERR=10000)
c WRITE(datTSTBF, '(9X, 8(A10))') c + 'HN [mm]', 'HNeff[mm]', ' ETa [mm]', 'Int [mm]', c + ' Base [mm]', ' BF1 [mm]', ' BF2 [mm]', ' BF3 [mm]'
END IF
WRITE(datnr, 100) 'NAME', 'EFLID', 'Kng',' Sch ',
+ ' BF [mm/m]', ' BFStart [mm]',
+ ' BFEnd [mm]',
+ (BF_FKTNAME(i)//'[mm]',i=1,BF_ANZ_FKT),
+ ' Error [mm]'
c ................................................................. 10000 RETURN
END SUBROUTINE BF_OPENFILE
cxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
END MODULE
</fortran>