Help:Sandkasten: Difference between revisions

From BlueM
Jump to navigation Jump to search
No edit summary
(GeSHi Highlight Test)
Line 1: Line 1:
{{file|pdf|Ostrowski 1992 Universeller Baustein.pdf|My pdf document}}
<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>

Revision as of 07:02, 18 October 2006

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

Retrieved from "https://wiki.bluemodel.org/index.php?title=Help:Sandkasten&oldid=2335"