Help:Sandkasten: Difference between revisions

From BlueM
Jump to navigation Jump to search
(GeSHi Highlight Test)
(→‎Syntax highlighting: add WVP test)
 
(23 intermediate revisions by 2 users not shown)
Line 1: Line 1:
<fortran>
__NOTOC__
      MODULE MODBF
==Funktionstests==
CXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
===Math===
c
<math>x+y=8^{22}</math>
c    MODUL: BODENFEUCHTEBERECHNUNG
c    =============================
c    Systemzustände: [letzter Zeitschritt wird gespeichert]
c      Extern:
c      Intern: -
c    Attribute:
CXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
      USE MODCON
      IMPLICIT none


! -------------------------------------------------------------
===Syntax highlighting===
! ----------------------- Oeffentlicher Teil ------------------
====VB.NET====
! -------------------------------------------------------------
<source lang="vbnet">
' Foo
Public Sub Foo(ByValue Bar As Integer)
  Return Bar
End Sub
</source>


! --- Konstanten -> const.for
====Fortran====
! --- Datentypen -> types.for
<source lang="fortran">
! --- Variablen ---
! Foo
      LOGICAL  :: BF_error
FUNCTION Foo(INT bar)
      LOGICAL  :: BF_warn
  RETURN bar
END FUNCTION
</source>


! -------------------------------------------------------------
====BlueM====
! ----------------------- Privater Teil -----------------------
<bluem>
! -------------------------------------------------------------
*Talsperren (*.TAL)
*==================
*
*|------|------------|------------|-----|----------|-----------------------|-----------------------|
*| Bez  |  Anfangs-  |  Maximal  | Ge- |  Sohle  |      HW-Entlastung    |      Krone            |
*|      |  volumen  |  volumen  |wicht|          |  Kante      S-Vol  |  Kante      S-Vol  |
*|------|------------|------------|-----|----------|-----------------------|-----------------------|
*|      | [Tsd.cbm]  | [Tsd.cbm]  |  -  |  [mNN]  |  [mNN]  | [Tsd.cbm]  |  [mNN]  | [Tsd.cbm]  |
*|-<-->-|-<-------->-|-<-------->-|-<->-|-<------>-|-<------>-|-<-------->-|-<------>-|-<-------->-|
| T170 |        600 |      3650 |  1  |    114.9 |  118.25 |      2650 |  119.25 |      3650 |
| THRB |        500 |      2800 |  1  |      116 |      121 |      2500 |      122 |      2800 |
*|------|------------|------------|-----|----------|-----------------------|-----------------------|
*
</bluem>


! --- Konstanten -> const.for
====Wave project file====
      REAL, PARAMETER, PRIVATE    :: BF_MODUL_VERSION = 1.0
<source lang="wvp">
# Import multiple series from multiple files
#-------------------------------------------
file=..\UVF\42960.0_q_28.uvf
file=..\WEL\DEMONA_PSI.wel
series=S3  _1AB: S3 outflow
series=S3  _1ZU: S3 inflow
file=..\ZRE\Zufl_gem.zre
file=..\BIN\abfluss_1.bin
series=abfluss_1.bin: title="Discharge", unit="m3/s", interpretation=Instantaneous, color=Red, linewidth=4, linestyle=Dash, showPoints=True
file=myrandom.csv
# custom import settings
isColumnSeparated=True
separator=;
dateformat=dd.MM.yyyy HH:mm:ss
decimalSeparator=,
iLineHeadings=1
iLineUnits=8
iLineData=12
useUnits=True
columnWidth=
dateTimeColumnIndex=0
# series to import
series=myseries1
series=myseries2
</source>


c    Berechnungskonstanten
== CSS ==
      REAL,    PARAMETER, PRIVATE :: BF_MAX_BILERR  = 0.01
<div class="info_versionen">
      REAL,    PARAMETER, PRIVATE :: BF_DELTARATE  = 0.001
Versionen
      REAL,    PARAMETER, PRIVATE :: BF_DELTAX      = 0.5
<pre><nowiki><div class="info_versionen"></nowiki></pre>
      REAL,    PARAMETER, PRIVATE :: BF_XMAX_FAKTOR = 1.0 + BF_DELTAX
</div>
      REAL,    PARAMETER, PRIVATE :: BF_YMAX_FAKTOR = FKT_MGRENZ *
    +                                                BF_DELTAX


c    Prozessfunktionen, Funktionsverläufe:
<div class="achtung">
      INTEGER, PARAMETER, PRIVATE :: BF_MAXSTZ    = MAXSTZ        !maximale Stuetzstellenzahl einer Funktion
Achtung
      INTEGER, PARAMETER, PRIVATE :: BF_STZ_START  = 2              !Beginn der richtigen Funktionsverläufe
<pre><nowiki><div class="achtung"></nowiki></pre>
      INTEGER, PARAMETER, PRIVATE :: BF_STZ_REST  = 2              !Restliche Stützstellen nach Ende der richtigen Funktionsverläufe
</div>
      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
<div class="comment">
      INTEGER, PARAMETER, PRIVATE :: BF_MAX_SCHICHTEN = 6
Kommentar
<pre><nowiki><div class="comment"></nowiki></pre>
</div>


      INTEGER, PARAMETER, PRIVATE :: BOD_InfSchichtID  = 1
Links:
      INTEGER, PARAMETER, PRIVATE :: BOD_WESchichtID  = 2
* File types:
      INTEGER, PARAMETER, PRIVATE :: BOD_TRSSchichtID  = 3
** PDF: http://www.example.com/test.pdf
      REAL, PARAMETER, PRIVATE    :: BOD_dInfSchicht  = 0.2
** EXE: http://www.example.com/test.exe
      REAL, PARAMETER, PRIVATE    :: BOD_minD_WESchicht = 0.05
** ZIP: http://www.example.com/test.zip
      REAL, PARAMETER, PRIVATE    :: BOD_minD_TRSSchicht = 0.05
** PPT: http://www.example.com/test.ppt http://www.example.com/test.pptx http://www.example.com/test.pps
      REAL, PARAMETER, PRIVATE    :: BOD_minDicke =  BOD_dInfSchicht +
** DOC: http://www.example.com/test.doc http://www.example.com/test.doc
    +                                            BOD_mind_WESchicht +
** XLS: http://www.example.com/test.xls http://www.example.com/test.xlsx
    +                                            BOD_mind_TRSSchicht
* Sites:
 
** https://downloads.bluemodel.org
      ! Bodenarten
** GitHub: https://github.com
      INTEGER, PARAMETER, PRIVATE :: BF_ANZ_BOART  = 3
** Literature: https://tubiblio.ulb.tu-darmstadt.de/ https://dx.doi.org/
      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>

Latest revision as of 06:06, 11 November 2023

Funktionstests

Math

[math]\displaystyle{ x+y=8^{22} }[/math]

Syntax highlighting

VB.NET

' Foo
Public Sub Foo(ByValue Bar As Integer)
   Return Bar
End Sub

Fortran

! Foo
FUNCTION Foo(INT bar)
   RETURN bar
END FUNCTION

BlueM

*Talsperren (*.TAL)
*==================
*
*|------|------------|------------|-----|----------|-----------------------|-----------------------|
*| Bez  |  Anfangs-  |  Maximal   | Ge- |  Sohle   |      HW-Entlastung    |      Krone            |
*|      |  volumen   |  volumen   |wicht|          |   Kante       S-Vol   |   Kante       S-Vol   |
*|------|------------|------------|-----|----------|-----------------------|-----------------------|
*|      | [Tsd.cbm]  | [Tsd.cbm]  |  -  |   [mNN]  |   [mNN]  | [Tsd.cbm]  |   [mNN]  | [Tsd.cbm]  |
*|-<-->-|-<-------->-|-<-------->-|-<->-|-<------>-|-<------>-|-<-------->-|-<------>-|-<-------->-|
 | T170 |        600 |       3650 |  1  |    114.9 |   118.25 |       2650 |   119.25 |       3650 |
 | THRB |        500 |       2800 |  1  |      116 |      121 |       2500 |      122 |       2800 |
*|------|------------|------------|-----|----------|-----------------------|-----------------------|
*

Wave project file

# Import multiple series from multiple files
#-------------------------------------------
file=..\UVF\42960.0_q_28.uvf
file=..\WEL\DEMONA_PSI.wel
 series=S3  _1AB: S3 outflow
 series=S3  _1ZU: S3 inflow
file=..\ZRE\Zufl_gem.zre
file=..\BIN\abfluss_1.bin
 series=abfluss_1.bin: title="Discharge", unit="m3/s", interpretation=Instantaneous, color=Red, linewidth=4, linestyle=Dash, showPoints=True
file=myrandom.csv
 # custom import settings
 isColumnSeparated=True
 separator=;
 dateformat=dd.MM.yyyy HH:mm:ss
 decimalSeparator=,
 iLineHeadings=1
 iLineUnits=8
 iLineData=12
 useUnits=True
 columnWidth=
 dateTimeColumnIndex=0
 # series to import
 series=myseries1
 series=myseries2

CSS

Versionen 

<div class="info_versionen">

Achtung 

<div class="achtung">

Kommentar 

<div class="comment">

Links:

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