Skip to content
Snippets Groups Projects

Compare revisions

Changes are shown as if the source revision was being merged into the target revision. Learn more about comparing revisions.

Source

Select target project
No results found

Target

Select target project
  • foresee/4C
  • gutsch/4C
2 results
Show changes
Hide whitespace changes
Inline Side-by-side
Showing
with 11454 additions and 0 deletions
source_code/version_2.3_windows/canopy.f 0 → 100644
View file @ 82df1085
!*****************************************************************!
!* *!
!* 4C (FORESEE) Simulation Model *!
!* *!
!* *!
!* Subroutine canopy for: *!
!* Calculation of canopy geometry & light absorption *!
!* with *!
!* CALC_LA *!
!* LIGHT_GROWTH *!
!* COV_AREA *!
!* Light_1 *!
!* Light_2 *!
!* Light_3 *!
!* Light_4 *!
!* L_3_COH_LOOP *!
!* L_4_COH_LOOP *!
!* LIGHT_OUT_2 *!
!* CROWN_PROJ *!
!* *!
!* Copyright (C) 1996-2018 *!
!* Potsdam Institute for Climate Impact Reserach (PIK) *!
!* Authors and contributors see AUTHOR file *!
!* This file is part of 4C and is licensed under BSD-2-Clause *!
!* See LICENSE file or under: *!
!* http://www.https://opensource.org/licenses/BSD-2-Clause *!
!* Contact: *!
!* https://gitlab.pik-potsdam.de/foresee/4C *!
!* *!
!*****************************************************************!
!**********************************!
!* SUBROUTINE CANOPY *!
!**********************************!
SUBROUTINE CANOPY
!*** Declaration part ***!
USE data_out
USE data_species
USE data_simul
USE data_stand
IMPLICIT NONE
integer i
! If no Cohorts on the patch, initialize properly
IF( anz_coh == 0 ) THEN
lowest_layer=0
highest_layer=0
vStruct%cumLAI= 0.
vStruct%Irel = 0.
vStruct%sumBG = 0.
Irelpool = 0.
BGpool = 0.
LAI = 0.
! full light on the ground (layer = 0)
! Lightroutine 1,2
vStruct(highest_layer)%Irel=1
! Lightroutine 3,4
Irelpool(highest_layer)=1
! the whole patch is availabe for recruitment
BGpool(highest_layer+1)=1
BGpool(highest_layer+2)=1
all_leaves_on=0
! Calculation of leaf area, lowest and highest layer, etc.
! for all cohorts in all respective layers
CALL CALC_LA ! leaf area etc. always calculate
RETURN
END IF
! Calculation of leaf area, lowest and highest layer, etc.
! for all cohorts in all respective layers
CALL CALC_LA
IF(flag_end.EQ.3) RETURN
IF( flag_light == 1 )THEN
CALL LIGHT_1
ELSE IF ( flag_light == 2 ) THEN
CALL LIGHT_2
ELSE IF ( flag_light == 3 ) THEN
CALL LIGHT_3
ELSE IF ( flag_light == 4 ) THEN
CALL LIGHT_4
END IF
DO i=1,anrspec
ns = nrspec(i)
IF(svar(ns)%act_sum_lai > svar(ns)%sum_lai) svar(ns)%sum_lai = svar(ns)%act_sum_lai
ENDDO
! Determine relative light in the middle of each cohort canopy, the sla
! and the totFPAR per square meter patch and the total FPAR on the patch
CALL LIGHT_GROWTH
! print relevant light parameters for the canopy for each layer and cohort
if (time_out.gt.0 .and. out_flag_light.ne.0) CALL LIGHT_OUT_2
!------------------------------------------------
!------------------- SUBROUTINES ----------------
!------------------------------------------------
CONTAINS
SUBROUTINE CALC_LA
! Calculation of leaf area, lowest and highest layer, etc.
! for all cohorts in all respective layers
!*** Declaration part ***!
USE data_species
USE data_simul
USE data_stand
IMPLICIT NONE
! variables required for technical reasons
INTEGER :: nl, i
TYPE(Coh_Obj), Pointer :: p ! pointer to cohort list
! auxiliary variable
REAL :: x ! leaf area per crown unit [m**2/cm]
vStruct%LA = 0.
! structure of the canopy is determined once at the start of the year
! initialisation
IF(iday==1) THEN
lowest_layer=250
highest_layer=0
END IF
do i = 1, anrspec
svar(nrspec(i))%act_sum_lai = 0.
enddo
p => pt%first
DO WHILE (ASSOCIATED(p))
ns = p%coh%species
! cohort loop for determination of lowest and highest canopy layer of the tree crown
! structure of the canopy must only be determined once at the start of the year
IF(iday==1) THEN
! determine bottom of the crown in terms of number of layers
p%coh%botLayer = INT( p%coh%x_hbole / dz ) + 1
! determine top of the crown in terms of number of layers
IF (MODULO(p%coh%height,dz)==0.) THEN
p%coh%topLayer = INT( p%coh%height / dz )
ELSE
p%coh%topLayer = INT( p%coh%height / dz ) + 1
END IF
! remember the highest layer
IF(p%coh%topLayer > highest_layer .AND. p%coh%toplayer < 250) THEN
highest_layer=p%coh%topLayer
ELSE IF(p%coh%toplayer >= 250) THEN
if (.not.flag_mult8910) then
CALL stop_mess(time,'FATAL EXCEPTION RAISED IN CANOPY CALC_LA')
CALL error_mess(time,'maximal tree height of 125 m reached by cohort No.',REAL(p%coh%ident))
endif
flag_end=3
RETURN
END IF
!remember the lowest layer of the stand
IF(p%coh%botLayer < lowest_layer) THEN
lowest_layer=p%coh%botLayer
END IF
END IF
p%coh%leafarea = 0.
! total leaf area of a tree in this cohort [m**2]
IF((iday >= p%coh%day_bb) .AND. (iday <= spar(ns)%end_bb)) THEN
p%coh%t_leaf = p%coh%med_sla * p%coh%x_fol
! amount of leaf area per tree in layers
IF (p%coh%topLayer-p%coh%botLayer.GE.1) THEN
! now calculate leaf area per crown unit of this tree [m**2/cm]
x = p%coh%t_leaf / ( p%coh%height - p%coh%x_hbole )
p%coh%leafArea( p%coh%botLayer ) = ( dz - MODULO( p%coh%x_hbole, dz ) ) * x
IF (MODULO(p%coh%height,dz)==0.) THEN
p%coh%leafArea( p%coh%topLayer ) = dz * x
ELSE
p%coh%leafArea( p%coh%topLayer ) = MODULO( p%coh%height, dz ) * x
END IF
DO nl = p%coh%botLayer+1, p%coh%topLayer-1
p%coh%leafArea(nl) = x * dz
END DO
ELSE
p%coh%leafArea(p%coh%botLayer) = p%coh%t_leaf
END IF
! Update vertical patch leaf area profile of the canopy
DO nl = p%coh%botLayer, p%coh%topLayer
vStruct(nl)%LA = vStruct(nl)%LA + p%coh%leafArea(nl) * p%coh%nTreeA
END DO
ELSE
p%coh%leafArea=0.
ENDIF
IF(iday<=spar(ns)%end_bb) svar(ns)%act_sum_lai = svar(ns)%act_sum_lai + p%coh%ntreea*p%coh%t_leaf/kpatchsize
p => p%next
END DO
END SUBROUTINE CALC_LA
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
SUBROUTINE LIGHT_GROWTH
! Determine relative light in the middle of each cohort canopy, the sla,
! the total FPAR on the patch
!*** Declaration part ***!
USE data_species
USE data_simul
USE data_stand
IMPLICIT NONE
integer help
TYPE(Coh_Obj), Pointer :: p ! pointer to cohort list
totFPARsum=0 ! sum of all totFPAR's
totFPARcan=0 ! sum of all totFPAR's for the canopy
p => pt%first
DO WHILE (ASSOCIATED(p))
ns=p%coh%species
! the new average specific leaf area per cohort depends
! on the light regime in the middle of the canopy
! this is the SLA which is used for the leaf area distr. in the next year
! the new average specific leaf area per cohort depends on the
! mean light regime in the middle in the canopy
! IrelCan modifies the growthfunction
IF(all_leaves_on==1) THEN
select case (flag_light)
case (1,2)
p%coh%med_sla = spar(ns)%psla_min+spar(ns)%psla_a*&
(1-(vStruct(p%coh%toplayer)%Irel+vStruct(p%coh%botlayer)%Irel)/2.)
p%coh%IrelCan = vStruct(p%coh%toplayer)%Irel
case default
p%coh%med_sla = spar(ns)%psla_min+spar(ns)%psla_a*&
(1-(p%coh%Irel(p%coh%topLayer)+p%coh%Irel(p%coh%botLayer))/2.)
select case (ns)
case (10) ! Douglas fir
help = p%coh%botLayer+2*(p%coh%toplayer - p%coh%botLayer) / 3
p%coh%IrelCan = p%coh%Irel(help)
case default
help = vStruct(p%coh%toplayer)%SumBG
if (help .gt. 0.) then
p%coh%IrelCan = p%coh%Irel(p%coh%toplayer)*MIN(kpatchsize/help, 1.)
else
p%coh%IrelCan = p%coh%Irel(p%coh%toplayer)
endif
end select ! ns
end select ! flag_light
END IF
totFPARsum = totFPARsum + p%coh%totFPAR*p%coh%nTreeA
IF (p%coh%species .le. nspec_tree .or. p%coh%species.eq.nspec_tree+2) totFPARcan = totFPARcan + p%coh%totFPAR*p%coh%nTreeA
p => p%next
END DO
END SUBROUTINE LIGHT_GROWTH
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
SUBROUTINE COV_AREA
! calculate coverage-area as fraction of the patchsize per tree and layer
!*** Declaration part ***!
USE data_climate
USE data_par
USE data_stand
USE data_site
IMPLICIT NONE
! variables required for technical reasons
INTEGER :: i
! Variables to test restriction in light model 4
REAL :: y ! potential shadow cast of the cohort [m]
REAL :: w ! effective shadow cast of the cohort [m]
REAL :: l ! side length of a coort layer [m]
REAL :: reqarea ! area of the patch required for the shadow cast for all cohorts per layer
INTEGER :: layer_flag ! remember the highest layer where first LM4 restriction occurs
TYPE(Coh_Obj), Pointer :: p ! pointer to cohort list
y = dz/100/TAN(beta)
lm3layer=0
layer_flag=0
DO i = highest_layer, lowest_layer, -1
reqarea=0.
p => pt%first
DO WHILE (ASSOCIATED(p))
p%coh%BG(i) = 0.
! only those trees that have leaves
IF((iday >= p%coh%day_bb) .AND. (iday <= spar(p%coh%species)%end_bb) .AND. &
i <= p%coh%topLayer .AND. i >= p%coh%botLayer) THEN
IF (vStruct(i)%sumBG > kpatchsize) THEN
p%coh%BG(i)=p%coh%crown_area/vStruct(i)%sumBG
ELSE
p%coh%BG(i)=p%coh%crown_area/kpatchsize
END IF
l = SQRT(p%coh%BG(i)*kpatchsize)
reqarea = reqarea + l*y*p%coh%nTreeA
END IF
p => p%next
END DO ! cohorts
IF( kpatchsize > vStruct(i)%sumBG .AND. reqarea /= 0) THEN
w = y*(kpatchsize-vStruct(i)%sumBG)/reqarea
ELSE
w = 0
END IF
p => pt%first
DO WHILE (ASSOCIATED(p) .AND. layer_flag.EQ.0)
! only those trees that have leaves
IF((iday >= p%coh%day_bb) .AND. (iday <= spar(p%coh%species)%end_bb) .AND. &
i <= p%coh%topLayer .AND. i >= p%coh%botLayer) THEN
l = SQRT(p%coh%BG(i)*kpatchsize)
! layer from that on light model 3 is used instead of light model 4
! because of LM4 restrictions
IF( y-w > w+l ) THEN
layer_flag=1
lm3layer = i
EXIT ! do loop
END IF
END IF
p => p%next
END DO
END DO ! layers
END SUBROUTINE COV_AREA
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
SUBROUTINE LIGHT_1
!*** Declaration part ***!
USE data_species
USE data_simul
USE data_stand
IMPLICIT NONE
! variables required for technical reasons
INTEGER :: i, nl
TYPE(Coh_Obj), Pointer :: p ! pointer to cohort list
! auxiliary variables
REAL :: radSum ! sum of absorbed radiation (help variable)
REAL :: pfext=0.6 ! extinction coefficient. Only for one specie.
!*** Calculation part ***!
! Intialization radiation summator
radSum = 0.
vStruct%cumLAI = 0.
vStruct%Irel = 0.
! Calculate cumulative leaf area index and absorbed radiation per layer
! using Lambert-Beer
vStruct(highest_layer)%Irel=1
DO i = highest_layer, lowest_layer, -1
vStruct(i)%cumLAI = vStruct(i)%LA/kPatchsize + vStruct(i+1)%cumLAI
vStruct( i )%radFrac = 1. - Exp(-pfext * vStruct(i)%cumLAI) - radSum
radSum = radSum + vStruct(i)%radFrac
vStruct(i-1)%Irel=vStruct(i)%Irel-vStruct(i)%radFrac
END DO
! Light intensitiy unto the ground
DO i = lowest_layer - 2, 0, -1
vStruct(i)%Irel=vStruct(i+1)%Irel
END DO
! total LAI is simply the value of cumLAI at the forest floor
LAI = vStruct(lowest_layer)%cumLAI
IF(lai>laimax) laimax=lai
! Determine layer-specific & total fraction of PAR absorbed by this tree
p => pt%first
DO WHILE (ASSOCIATED(p))
p%coh%totFPAR = 0.
p%coh%FPAR = 0.
DO nl = p%coh%botLayer, p%coh%topLayer
p%coh%FPAR(nl) = p%coh%leafArea(nl) / vStruct(nl)%LA * vStruct(nl)%radFrac
p%coh%totFPAR = p%coh%totFPAR + p%coh%FPAR(nl)
END DO
p => p%next
END DO
IF(all_leaves_on==1) THEN
p => pt%first
DO WHILE (ASSOCIATED(p))
DO i = highest_layer, lowest_layer, -1
p%coh%antFPAR(i)=p%coh%FPAR(i)/p%coh%totFPAR
p%coh%sleafarea(i)=p%coh%leafarea(i)
END DO ! end layer loop
p => p%next
END DO ! cohort loop
ENDIF
END SUBROUTINE LIGHT_1
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
SUBROUTINE LIGHT_2
!*** Declaration part ***!
USE data_species
USE data_simul
USE data_stand
IMPLICIT NONE
! variables required for technical reasons
INTEGER :: i
real :: help
TYPE(Coh_Obj), Pointer :: p ! pointer to cohort list
!*** Calculation part ***!
vStruct%cumLAI = 0.
vStruct%Irel = 0.
! cohort loop
p => pt%first
DO WHILE (ASSOCIATED(p))
p%coh%FPAR = 0.
p%coh%totFPAR = 0.
p => p%next
END DO ! cohort loop
! Now calculate crown projection per tree and layer and
! the coverage sum over all layers
CALL CROWN_PROJ
! now calculate coverage-area as fraction of the patchsize per tree and layer
CALL COV_AREA
vStruct(highest_layer)%Irel=1
DO i = highest_layer, lowest_layer, -1
p => pt%first
help=0.
vStruct(i)%cumLAI = vStruct(i)%LA/kpatchsize + vStruct(i+1)%cumLAI
DO WHILE (ASSOCIATED(p))
ns=p%coh%species
IF (p%coh%BG(i).ne.0.) THEN
! faction of absorbed light rel. to the light at the top of this layer
! the reference area is the whole patch (weighted by BG(i))!
p%coh%FPAR(i)=(1-exp(-spar(ns)%pfext*p%coh%leafArea(i)/&
kpatchsize/p%coh%BG(i)))*p%coh%BG(i)
! sum up the total absorbed fraction of this cohort,
! the total fraction of absorbed light in this layer
! is the fraction absorbed* fraction of light*BG
! the reference area is the whole patch!
p%coh%totFPAR=p%coh%totFPAR+vStruct(i)%Irel*p%coh%FPAR(i)*&
(1+(0.5-vStruct(i)%Irel)*spar(ns)%fpar_mod/0.5)
! at first sum all the absorbed light fractions over the cohorts
help=help+p%coh%FPAR(i)*p%coh%nTreeA
ELSE
p%coh%FPAR(i)=0.
END IF
p => p%next
END DO
! then calculate the fraction of light which is available for the next layer
vStruct(i-1)%Irel=vStruct(i)%Irel*(1-help)
END DO
! Light intensitiy unto the ground
DO i = lowest_layer - 2, 0, -1
vStruct(i)%Irel=vStruct(i+1)%Irel
END DO
IF(all_leaves_on==1) THEN
p => pt%first
DO WHILE (ASSOCIATED(p))
DO i = highest_layer, lowest_layer, -1
p%coh%antFPAR(i)=vStruct(i)%Irel*p%coh%FPAR(i)*(1+(0.5-vStruct(i)%Irel)*spar(ns)%fpar_mod/0.5)/p%coh%totFPAR
p%coh%sleafarea(i)=p%coh%leafarea(i)
END DO ! end layer loop
p => p%next
END DO ! cohort loop
ENDIF
! total LAI is simply the value of cumLAI at the forest floor
LAI = vStruct(lowest_layer)%cumLAI
IF(lai>laimax) laimax=lai
END SUBROUTINE LIGHT_2
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
SUBROUTINE L_3_COH_LOOP(i,j)
!*** Declaration part ***!
USE data_species
USE data_simul
USE data_stand
IMPLICIT NONE
! variables required for technical reasons
TYPE(Coh_Obj), Pointer :: p ! pointer to cohort list
INTEGER :: i, j ! i= Schicht, j= Variante
REAL :: help
p => pt%first
! cohort loop in layer i
DO WHILE (ASSOCIATED(p))
ns=p%coh%species
IF((iday < p%coh%day_bb) .OR. (iday > spar(ns)%end_bb)) GOTO 1313
IF (i<=p%coh%toplayer.AND.i>=p%coh%botlayer) THEN
p%coh%FPAR(i)=1-exp(-spar(ns)%pfext*p%coh%leafArea(i)/&
kpatchsize/p%coh%BG(i))
! FPAR is related to the projection area and has to be modified
! by the same factor by that the projection area is being modified
! in case sumBG > patchsize
p%coh%FPAR(i)=p%coh%FPAR(i)*MIN(kpatchsize/vStruct(i)%sumBG,1.)
! test wether the cohort is new, was there before or will not be
! represented in the next layer
IF (i == p%coh%toplayer) THEN
p%coh%Irel(i)=Irelpool(i)
! totFPAR per patch! Since the projection area changes totFPAR has to
! be related to the patch in each layer
p%coh%totFPAR=p%coh%totFPAR+p%coh%Irel(i)*p%coh%FPAR(i)*p%coh%BG(i)
! light available for this cohort in the next layer
p%coh%Irel(i-1)=p%coh%Irel(i)*(1-p%coh%FPAR(i))
ELSE IF (i == p%coh%botlayer) THEN
IF( j == 2 ) THEN
help=p%coh%BG(i)-p%coh%BG(i+1)
p%coh%Irel(i)=(1/(p%coh%BG(i)))*&
(p%coh%Irel(i)*p%coh%BG(i+1)+Irelpool(i)*help)
END IF
! totFPAR per patch! Since the projection area changes totFPAR has to
! be related to the patch in each layer
p%coh%totFPAR=p%coh%totFPAR+p%coh%Irel(i)*p%coh%FPAR(i)*p%coh%BG(i)
! light available for this cohort in the next layer
p%coh%Irel(i-1)=p%coh%Irel(i)*(1-p%coh%FPAR(i))
! The light which leaves the cohort is fed into the pool
! the light intensitiy is weighted by the overall BG of this cohort
Irelpool(i-1)=(1/(p%coh%BG(i)*p%coh%nTreeA+BGpool(i)))*&
(p%coh%BG(i)*p%coh%nTreeA*p%coh%Irel(i-1)+BGpool(i)*Irelpool(i-1))
! BG of the pool available for the next layer increases
BGpool(i)=BGpool(i)+p%coh%BG(i)*p%coh%nTreeA
ELSE
IF( j == 2 ) THEN
help=p%coh%BG(i)-p%coh%BG(i+1)
p%coh%Irel(i)=(1/(p%coh%BG(i)))*&
(p%coh%Irel(i)*p%coh%BG(i+1)+Irelpool(i)*help)
END IF
! totFPAR per patch! Since the projection area changes totFPAR has to
! be related to the patch in each layer
p%coh%totFPAR=p%coh%totFPAR+p%coh%Irel(i)*p%coh%FPAR(i)*p%coh%BG(i)
! light available for this cohort in the next layer
p%coh%Irel(i-1)=p%coh%Irel(i)*(1-p%coh%FPAR(i))
END IF
END IF ! Layer test
1313 CONTINUE
p => p%next
END DO ! cohort loop
END SUBROUTINE L_3_COH_LOOP
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
SUBROUTINE LIGHT_3
!*** Declaration part ***!
USE data_species
USE data_simul
USE data_stand
IMPLICIT NONE
! variables required for technical reasons
INTEGER :: i
REAL :: help
TYPE(Coh_Obj), Pointer :: p ! pointer to cohort list
!*** Calculation part ***!
vStruct%cumLAI = 0.
Irelpool = 0.
BGpool = 0.
vStruct%Irel = 0. ! test variable for the light balance in layers
vStruct%radFrac = 0. ! test variable for the light balance in layers
! cohort loop
p => pt%first
DO WHILE (ASSOCIATED(p))
p%coh%FPAR = 0.
p%coh%totFPAR = 0.
p%coh%Irel = 0.
p => p%next
END DO ! cohort loop
! Now calculate crown projection per tree and layer and
! the coverage sum over all layers
CALL CROWN_PROJ
! now calculate coverage-area as fraction of the patchsize per tree and layer
CALL COV_AREA
! -----------------------------------------------------------
! now calculate per tree and layer the effective LAI
! this gives the absorbed light per tree and layer
! this gives the total fraction absorbes light per tree
! further each tree and each layer has an individual light regime. The area
! which is not covered by trees is treated as a pool
!
! reference area for the total fracation absorbed is the patch area
! above the canopy there is 100 % rel. light
Irelpool(highest_layer)=1.
! the size of the pool is defined as the fraction of the patch
! which can potentially be used by new cohorts in the next layer.
! Therefore is is the patch-fraction which is free anyway plus the
! fraction coverd by cohorts that will not be present in the next layer
! this means, the light intensity Irelpool(i) is available on the
! area BGpool(i+1)
BGpool(highest_layer+1)=1.
DO i = highest_layer, lowest_layer, -1
vStruct(i)%cumLAI = vStruct(i)%LA/kpatchsize + vStruct(i+1)%cumLAI
! two cases:
! first case: sumBG increases in this layer or remains the same
IF (vStruct(i+1)%sumBG<=vStruct(i)%sumBG) THEN
! three subcases:
! first subcase of 'sumBG increases': sumBG stays below patchsize
! ( no BG modification) or does not change
IF ((vStruct(i+1)%sumBG.LT.kpatchsize.AND.vStruct(i)%sumBG.LE.kpatchsize).OR.&
vStruct(i+1)%sumBG == vStruct(i)%sumBG) THEN
! At the beginning the light intensity of the pool remains the same
! but it will be updated when cohorts drop out
Irelpool(i-1)=Irelpool(i)
! until there are cohorts dropping out
BGpool(i)=MAX((kpatchsize-vStruct(i)%sumBG)/kpatchsize,0.)
CALL L_3_COH_LOOP(i,1)
! second and third subcase of 'sumBG increases or remains the same'
! the BG's of the cohorts change because sumBG exceeds patchsize.
! second subcase: sumBG was < patchsize before
! third subcase: sumBG was > patchsize before
ELSE
! BG and light intensitiy of the pool for the next(!) layer
! is 0 as long as there are no cohorts dropping out
Irelpool(i-1)=0.
BGpool(i)=0.
p => pt%first
! cohort loop 1
DO WHILE (ASSOCIATED(p))
! calculate the new fraction covered by the pool
! which is the old pool plus the fractions which are lost
! by the old cohorts due to new BG's
! this also changes the light intensity of the pool
! This pool will all be used by the new cohorts
! consider only cohorts that have been there before (i<toplayer)
IF (i<p%coh%toplayer.AND.i>=p%coh%botlayer .AND.&
iday >= p%coh%day_bb .AND. iday <= spar(p%coh%species)%end_bb) THEN
help=BGpool(i+1)+(p%coh%BG(i+1)-p%coh%BG(i))*p%coh%nTreeA
Irelpool(i)=(1/help)*(Irelpool(i)*BGpool(i+1)+p%coh%Irel(i)*&
(p%coh%BG(i+1)-p%coh%BG(i))*p%coh%nTreeA)
BGpool(i+1)=help
END IF ! layer test
p => p%next
END DO ! cohort loop1
CALL L_3_COH_LOOP(i,1)
END IF ! subcases of 'sumBG increases
! second case: sumBG decreases
ELSE
! two subcases
! first subcase of 'sumBG decrease': sumBG < patchsize before and after
! i.e. BG's do not change
! i.e. all projection area requirements can be fulfilled in the next layer
IF (vStruct(i+1)%sumBG.LT.kpatchsize) THEN
! At the beginning the light intensity of the pool remains the same
! but it will be updated when cohorts drop out
Irelpool(i-1)=Irelpool(i)
! until there are cohorts dropping out
BGpool(i)=(kpatchsize-vStruct(i)%sumBG)/kpatchsize
CALL L_3_COH_LOOP(i,1)
! second subcase of 'sumBG decrease': sumBG remains > patchsize or
! sumBG was > patchsize, i.e. BG's do change
ELSE
! BG of the pool for the next layer as long as there are
! no cohorts dropping out
BGpool(i)=MAX((kpatchsize-vStruct(i)%sumBG)/kpatchsize,0.)
Irelpool(i-1)=Irelpool(i)
CALL L_3_COH_LOOP(i,2)
END IF ! subcases
END IF ! three main cases
END DO ! end layer loop
! -----------------------------------------------------------
IF(all_leaves_on==1) THEN
p => pt%first
DO WHILE (ASSOCIATED(p))
DO i = highest_layer, lowest_layer, -1
p%coh%antFPAR(i)=p%coh%Irel(i)*p%coh%FPAR(i)*p%coh%BG(i)/p%coh%totFPAR
p%coh%sleafarea(i)=p%coh%leafarea(i)
END DO ! end layer loop
p => p%next
END DO ! cohort loop
ENDIF
! total LAI is simply the value of cumLAI at the lowest layer
LAI = vStruct(lowest_layer)%cumLAI
IF(lai>laimax) laimax=lai
! light intensitiy and free patch space unto the ground
DO i = lowest_layer - 2, 0, -1
Irelpool(i)=Irelpool(i+1)
BGpool(i+1)=BGpool(i+2)
END DO
END SUBROUTINE LIGHT_3
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
SUBROUTINE L_4_COH_LOOP(i,j,beta,y)
!*** Declaration part ***!
USE data_species
USE data_simul
USE data_stand
IMPLICIT NONE
! variables required for technical reasons
TYPE(Coh_Obj), Pointer :: p ! pointer to cohort list
INTEGER :: i, j ! i= layer, j= type
REAL :: y ! potential shadow cast of a cohort layer [m]
REAL :: l ! side length of a cohort layer [m]
REAL :: w ! effective shadow cast of a cohort layer [m]
REAL :: helplai ! LAI per layer and cohort
REAL :: help
REAL :: beta ! sun inclination
REAL :: dropoutpool ! relative area covered by cohort dropping out
REAL :: f1,f2,f3,f4,f5,f6,f7,f8 ! average fraction of absorbed radiation in different
! regions of the tree layer according to the 4C description paper
REAL :: k ! extintion coefficient
REAL :: reqarea ! area of the patch required for the shadow cast for all cohorts per layer
reqarea=0.
! cohort loop
p => pt%first
DO WHILE (ASSOCIATED(p))
IF (i<=p%coh%toplayer.AND.i>=p%coh%botlayer) THEN
l = SQRT(p%coh%BG(i)*kpatchsize)
reqarea = reqarea + l*y*p%coh%nTreeA
END IF
p => p%next
END DO ! cohort loop
! the size of the pool is defined as the fraction of
! the patch which is not covered by cohorts. This is the
! area covered by the sum of the 'shadows' of the cohorts,
! i.e. y's or rather w's + the area of cohorts dropping out in the next layer +
! the are that exeeds the maximal required area by the shadow-cast.
! This is updated in each layer
! w is the width of the shadow-cast of the cohorts that is maximal y.
! This maximal y also defines the maximal required area for all shadows
! 'reqarea' = required area
! When the maximal y cannot be satisfied, then this area is reduced by the
! relative share of the available space not covered by cohorts to the
! maximal required area for shadow cast
IF( kpatchsize > vStruct(i)%sumBG ) THEN
if (reqarea .gt. 1E-08) then
w = y*(kpatchsize-vStruct(i)%sumBG)/reqarea
else
w = y*kpatchsize
endif
ELSE
w = 0
END IF
BGpool(i)=0.
dropoutpool=0
p => pt%first
! cohort loop in layer i
DO WHILE (ASSOCIATED(p))
ns=p%coh%species
IF((iday < p%coh%day_bb) .OR. (iday > spar(ns)%end_bb)) GOTO 1313
k = spar(ns)%pfext
IF (i<=p%coh%toplayer.AND.i>=p%coh%botlayer) THEN
l = SQRT(p%coh%BG(i)*kpatchsize)
if( p%coh%BG(i).ne.0) then
helplai=p%coh%leafArea(i)/kpatchsize/p%coh%BG(i)
if (helplai .le. 0.) then
continue
endif
else
helplai = 0.
end if
IF (i == p%coh%toplayer) THEN
p%coh%Irel(i)=Irelpool(i)
ELSE IF( j == 2 .AND. i /= p%coh%toplayer ) THEN
help=p%coh%BG(i)-p%coh%BG(i+1)
p%coh%Irel(i)=(1/(p%coh%BG(i)))*&
(p%coh%Irel(i)*p%coh%BG(i+1)+Irelpool(i)*help)
END IF
! two main cases:
! first case : all light from the side comes from the pool
! second case : light from the side comes partially from the cohort itself
IF( w >= y ) THEN
! subcases : 1.: light from the side of the layer
! does only leave at the bottom of the layer
! 2: light from the side does also leave on the other side
! totFPAR per patch! Since the projection area changes totFPAR has to
! be related to the patch in each layer
IF( y <= l ) THEN
f1 = 1-exp(-k*helplai/SIN(beta))
if (helplai .lt. 1.E-6) then
f2 = 0.
else
f2 = 1-SIN(beta)/(k*helplai)*f1
if (f2 .lt. 0.) then
continue
f2 = 0.
endif
endif
p%coh%totFPAR=p%coh%totFPAR+(1/kpatchsize)*&
((l-y)*l*p%coh%Irel(i)*f1+& ! max. LAI
! exits layer at the side
y*l*f2*p%coh%Irel(i)+&
! from the side to the next layer
y*l*f2*Irelpool(i))
p%coh%FPAR(i)=p%coh%totFPAR
! average light leaving the bottom of the cohort
p%coh%Irel(i-1)=(1/l)*&
! max. LAI
((l-y)*p%coh%Irel(i)*(1-f1)+&
! from the side to the next layer
y*(1-f2)*Irelpool(i))
! Light in the pool.
IF(i /= p%coh%botlayer) THEN
Irelpool(i-1)=1/(BGpool(i)*kpatchsize+y*l*p%coh%nTreeA)*&
! amount present in the pool
(BGpool(i)*kpatchsize*Irelpool(i-1)+&
! exits layer at the side
y*l*p%coh%nTreeA*(1-f2)*p%coh%Irel(i))
BGpool(i)=BGpool(i)+y*l*p%coh%nTreeA/kpatchsize
ELSE
Irelpool(i-1)=1/(BGpool(i)*kpatchsize+(y+l)*l*p%coh%nTreeA)*&
! amount present in the pool
(BGpool(i)*kpatchsize*Irelpool(i-1)+&
! exits layer at the side
y*l*p%coh%nTreeA*(1-f2)*p%coh%Irel(i)+&
! from layer onto next layer
l*l*p%coh%nTreeA*p%coh%Irel(i-1))
! BG of the pool available for the next layer increases
BGpool(i)=BGpool(i)+p%coh%nTreeA*(y*l/kpatchsize+p%coh%BG(i))
dropoutpool=dropoutpool+p%coh%nTreeA*p%coh%BG(i)
END IF
! y > l
ELSE
f3 = 1-exp(-k*helplai*l/(SIN(beta)*y))
f4 = 1-SIN(beta)*y/(l*k*helplai)*f3
p%coh%totFPAR=p%coh%totFPAR+(1/kpatchsize)*&
((y-l)*l*f3*Irelpool(i)+& ! red. max. LAI
! exits layer at the side
l*l*f4*p%coh%Irel(i)+&
! from the side to next layer
l*l*f4*Irelpool(i))
p%coh%FPAR(i)=p%coh%totFPAR
! average light leaving the cohort
p%coh%Irel(i-1)=(1-f4)*Irelpool(i)
! Light in the pool. Even when the area of the pool is
! equal to zero, there is virtual light in the pool
! which is used as light coming from the side
! the area weighted mean over all y is calculated
IF(i /= p%coh%botlayer) THEN
Irelpool(i-1)=1/(BGpool(i)*kpatchsize+y*l*p%coh%nTreeA)*&
! amount present in pool
(BGpool(i)*kpatchsize*Irelpool(i-1)+&
! red. max. LAI
(y-l)*l*p%coh%nTreeA*(1-f3)*Irelpool(i)+&
! exits layer at side
l*l*p%coh%nTreeA*(1-f4)*p%coh%Irel(i))
BGpool(i)=BGpool(i)+y*l*p%coh%nTreeA/kpatchsize
ELSE
Irelpool(i-1)=1/(BGpool(i)*kpatchsize+(l+y)*l*p%coh%nTreeA)*&
! amount present in the pool
(BGpool(i)*kpatchsize*Irelpool(i-1)+&
! red. max. LAI
(y-l)*l*p%coh%nTreeA*(1-f3)*Irelpool(i)+&
! exits layer at side
l*l*p%coh%nTreeA*(1-f4)*p%coh%Irel(i)+&
! from layer to next layer
l*l*p%coh%nTreeA*p%coh%Irel(i-1))
! BG of the pool available for the next layer increases
BGpool(i)=BGpool(i)+p%coh%nTreeA*(y*l/kpatchsize+p%coh%BG(i))
dropoutpool=dropoutpool+p%coh%nTreeA*p%coh%BG(i)
END IF ! bottom layer or not
END IF ! light entering sideways also leaving sideways or not
! second main case : light from the side comes partially from the
! cohort itself
ELSE
! Exit, when average light from the side needs itself as input
! should not happen because this is taken care for in COV_AREA
IF( y-w > w+l ) THEN
if (.not.flag_mult8910) then
CALL stop_mess(time,'FATAL EXCEPTION RAISED IN CANOPY LIGHT ROUTINE 4')
CALL error_mess(time,'Light leaving the side of cohort needs itself as input. Cohort No.',REAL(p%coh%ident))
CALL error_mess(time,'Try decreasing layer height dz or increasing average sun inclination.',0.)
endif
STOP
END IF
! subcases : 1.: light from the side of the layer
! does only leave at the bottom of the layer
! 2: light from the side does also leave on the other side but light from the top
! still goes into the pool
! 3. light from the side does also leave on the other side and light from the top
! is all used as input again
! totFPAR per patch! because the projection area changes totFPAR has to
! be related to the patch in each layer
IF( y <= l ) THEN
IF( w /= 0 ) THEN
! max LAI
f1 = 1-exp(-k*helplai/SIN(beta))
! edge piece
f5 = 1+SIN(beta)*y/((y-w)*k*helplai)*(exp(-k*helplai*(y-w)/(SIN(beta)*y))-1)
! red. LAI
f6 = 1+SIN(beta)*y/(w*k*helplai)*(1-f1-exp(-k*helplai*(y-w)/(SIN(beta)*y)))
ELSE
! max LAI
f1 = 1-exp(-k*helplai/SIN(beta))
f5 = 1+SIN(beta)*y/((y-w)*k*helplai)*(exp(-k*helplai*(y-w)/(SIN(beta)*y))-1)
f6 = 0
END IF
p%coh%totFPAR=p%coh%totFPAR+(1/kpatchsize)*&
! enters from above into the pool
(w*l*f6*p%coh%Irel(i)+&
! from above on own side
(y-w)*l*f5*p%coh%Irel(i)+&
! max. LAI
(l-y)*l*f1*p%coh%Irel(i)+&
! from pool to next layer
w*l*f6*Irelpool(i)+&
! from the side to the next layer
(y-w)*l*(1-f5)*f5*p%coh%Irel(i))
p%coh%FPAR(i)=p%coh%totFPAR
! average light leaving the bottom of the cohort
p%coh%Irel(i-1)=(1/l)*&
! max. LAI
((l-y)*(1-f1)*p%coh%Irel(i)+&
! from pool to next layer
w*(1-f6)*Irelpool(i)+&
! from the sides to the next layer
(y-w)*(1-f5)*(1-f5)*p%coh%Irel(i))
! Light in the pool.
IF(i /= p%coh%botlayer .AND. w/=0) THEN
Irelpool(i-1)=1/(BGpool(i)*kpatchsize+w*l*p%coh%nTreeA)*&
! present in the pool
(BGpool(i)*kpatchsize*Irelpool(i-1)+&
! exits layer at the side
w*l*p%coh%nTreeA*(1-f6)*p%coh%Irel(i))
BGpool(i)=BGpool(i)+w*l*p%coh%nTreeA/kpatchsize
ELSE IF(i == p%coh%botlayer) THEN
Irelpool(i-1)=1/(BGpool(i)*kpatchsize+(w+l)*l*p%coh%nTreeA)*&
! present in pool
(BGpool(i)*kpatchsize*Irelpool(i-1)+&
! exits layer to the side
w*l*p%coh%nTreeA*(1-f6)*p%coh%Irel(i)+&
! from layer to next layer
l*l*p%coh%nTreeA*p%coh%Irel(i-1))
! BG of the pool available for the next layer increases
BGpool(i)=BGpool(i)+p%coh%nTreeA*(w*l/kpatchsize+p%coh%BG(i))
dropoutpool=dropoutpool+p%coh%nTreeA*p%coh%BG(i)
END IF
! light from the top still goes into the pool.
! The case w=0 is no longer permissible
ELSE IF(y > l .AND. w >= y-l) THEN
IF( w /= y-l ) THEN
f3 = 1-exp(-k*helplai*l/(SIN(beta)*y))
f5 = 1+SIN(beta)*y/((y-w)*k*helplai)*(exp(-k*helplai*(y-w)/(SIN(beta)*y))-1)
f7 = 1+SIN(beta)*y/((l-y+w)*k*helplai)*(exp(-k*helplai*l/(SIN(beta)*y))-&
exp(-k*helplai*(y-w)/(SIN(beta)*y)))
ELSE
f3 = 1-exp(-k*helplai*l/(SIN(beta)*y))
f5 = 1+SIN(beta)*y/((y-w)*k*helplai)*(exp(-k*helplai*(y-w)/(SIN(beta)*y))-1)
f7 = 0
END IF
p%coh%totFPAR=p%coh%totFPAR+(1/kpatchsize)*&
! enters pool from above
((l-y+w)*l*f7*p%coh%Irel(i)+&
! from above into own side
(y-w)*l*f5*p%coh%Irel(i)+&
! red. max. LAI
(y-l)*l*f3*Irelpool(i)+&
! from the side into the next layer
(l-y+w)*l*f7*Irelpool(i)+&
! from the side into the next layer
(y-w)*l*f5*(1-f5)*p%coh%Irel(i))
p%coh%FPAR(i)=p%coh%totFPAR
! average light leaving the cohort
p%coh%Irel(i-1)=(1/l)*((l-y+w)*((1-f7)*Irelpool(i)+&
(y-w)*(1-f5)*(1-f5)*p%coh%Irel(i)))
! Light in the pool.
IF(i /= p%coh%botlayer) THEN
Irelpool(i-1)=1/(BGpool(i)*kpatchsize+w*l*p%coh%nTreeA)*&
! present in the pool
(BGpool(i)*kpatchsize*Irelpool(i-1)+&
! exits from top to the side
(l-y+w)*l*p%coh%nTreeA*(1-f7)*p%coh%Irel(i)+&
! from the side into the pool
(y-l)*l*p%coh%nTreeA*(1-f3)*Irelpool(i))
BGpool(i)=BGpool(i)+w*l*p%coh%nTreeA/kpatchsize
ELSE IF (i == p%coh%botlayer) THEN
Irelpool(i-1)=1/(BGpool(i)*kpatchsize+(l+w)*l*p%coh%nTreeA)*&
! present in the pool
(BGpool(i)*kpatchsize*Irelpool(i-1)+&
! exits from the sides
(l-y+w)*l*p%coh%nTreeA*(1-f7)*p%coh%Irel(i)+&
! enters from the sied into the pool
(y-l)*l*p%coh%nTreeA*(1-f3)*Irelpool(i)+&
! from layer to next layer
l*l*p%coh%nTreeA*p%coh%Irel(i-1))
! BG of the pool available for the next layer increases
BGpool(i)=BGpool(i)+p%coh%nTreeA*(w*l/kpatchsize+p%coh%BG(i))
dropoutpool=dropoutpool+p%coh%nTreeA*p%coh%BG(i)
END IF ! bottom layer or not
! light from the top still goes into the pool
ELSE IF(y > l .AND. w < y-l) THEN
f3 = 1-exp(-k*helplai*l/(SIN(beta)*y))
f4 = 1-SIN(beta)*y/(l*k*helplai)*f3
f8 = 1/(y-w)*(l*f4+(y-w-l)*f3)
p%coh%totFPAR=p%coh%totFPAR+(1/kpatchsize)*&
! from above to own side
(l*l*f4*p%coh%Irel(i)+&
! from side to the own side and into the pool
y*l*f3*Irelpool(i)+&
! from the side to the next layer and into the pool
l*f8*(1-f8)*(l*p%coh%Irel(i)+(y-w-l)*Irelpool(i)))
p%coh%FPAR(i)=p%coh%totFPAR
! average light leaving the cohort
p%coh%Irel(i-1)=(1-f4)*(1-f8)*(l*p%coh%Irel(i)+(y-w-l)*Irelpool(i))
! Light in the pool.
IF(i /= p%coh%botlayer) THEN
Irelpool(i-1)=1/(BGpool(i)*kpatchsize+w*l*p%coh%nTreeA)*&
! present in the pool
(BGpool(i)*kpatchsize*Irelpool(i-1)+&
! from the side into the pool
(2*w-y+l)*l*p%coh%nTreeA*(1-f3)*Irelpool(i)+&
(y-w-l)*l*p%coh%nTreeA*(1-f3)*(1-f8)*&
(l*p%coh%Irel(i)+(y-w-l)*Irelpool(i)))
BGpool(i)=BGpool(i)+w*l*p%coh%nTreeA/kpatchsize
ELSE IF (i == p%coh%botlayer) THEN
Irelpool(i-1)=1/(BGpool(i)*kpatchsize+(l+w)*l*p%coh%nTreeA)*&
! present in the pool
(BGpool(i)*kpatchsize*Irelpool(i-1)+&
! from the side into the pool
(2*w-y+l)*l*p%coh%nTreeA*(1-f3)*Irelpool(i)+&
(y-w-l)*l*p%coh%nTreeA*(1-f3)*(1-f8)*&
(l*p%coh%Irel(i)+(y-w-l)*Irelpool(i))+&
! from layer to next layer
l*l*p%coh%nTreeA*(1-f4)*(1-f8)*&
(l*p%coh%Irel(i)+(y-w-l)*Irelpool(i)))
! BG of the pool available for the next layer increases
BGpool(i)=BGpool(i)+p%coh%nTreeA*(w*l/kpatchsize+p%coh%BG(i))
dropoutpool=dropoutpool+p%coh%nTreeA*p%coh%BG(i)
END IF ! bottom layer or not
END IF ! light entering sideways also leaving sideways or not
END IF ! two main cases
END IF
1313 CONTINUE
if (p%coh%FPAR(i) .lt. 0. .or. p%coh%totFPAR .lt. 0.) then
continue
p%coh%FPAR(i) = 0. ! intercept negative radiation
p%coh%totFPAR = 0.
endif
p => p%next
END DO ! cohort loop
! Treelayers are distributed on the patch such that their y's
! cover the free space as good as possible
IF( w > y ) THEN
Irelpool(i-1)=1/(kpatchsize*(1+dropoutpool)-vStruct(i)%sumBG)*&
(BGpool(i)*kpatchsize*Irelpool(i-1)+&
(kpatchsize-vStruct(i)%sumBG-(BGpool(i)-dropoutpool)*kpatchsize)*Irelpool(i))
BGpool(i)=(kpatchsize-vStruct(i)%sumBG)/kpatchsize + dropoutpool
END IF
END SUBROUTINE L_4_COH_LOOP
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
SUBROUTINE LIGHT_4
!*** Declaration part ***!
USE data_climate
USE data_par
USE data_species
USE data_stand
use data_site
IMPLICIT NONE
! variables required for technical reasons
INTEGER :: i
REAL :: help
REAL :: y ! potential shadow cast of the stand [m]
TYPE(Coh_Obj), Pointer :: p ! pointer to cohort list
!*** Calculation part ***!
vStruct%cumLAI = 0.
Irelpool = 0.
BGpool = 0.
vStruct%Irel = 0. ! test variable for the balance in layers
vStruct%radFrac = 0. ! test variable for the balance in layers
y = dz/100/TAN(beta)
! cohort loop
p => pt%first
DO WHILE (ASSOCIATED(p))
p%coh%FPAR = 0.
p%coh%totFPAR = 0.
p%coh%Irel = 0.
p => p%next
END DO ! cohort loop
if (time .eq. 8 .and. iday .eq. 134) then
continue
endif
! Now calculate crown projection per tree and layer and
! the coverage sum over all layers
CALL CROWN_PROJ
! now calculate coverage-area as fraction of the patchsize per tree and layer
CALL COV_AREA
! -----------------------------------------------------------
! now calculate per tree and layer the effective LAI
! this gives the absorbed light per tree and layer
! this gives the total fraction absorbes light per tree
! further each tree and each layer has an individual light regime. The area
! which is not covered by trees is treated as a pool
! whose light is available for all new cohorts.
! reference area for the total fraction absorbed is the patch area.
! GBpool is exactly defined in subroutine L_4_COH_LOOP
BGpool(highest_layer+1)=1.
! above the canopy there is 100 % rel. light
Irelpool(highest_layer)=1.
DO i = highest_layer, lowest_layer, -1
vStruct(i)%cumLAI = vStruct(i)%LA/kpatchsize + vStruct(i+1)%cumLAI
! two cases:
! first case: sumBG increases in this layer or remains the same
IF (vStruct(i+1)%sumBG<=vStruct(i)%sumBG) THEN
! three subcases:
! first subcase of 'sumBG increases': sumBG stays below patchsize
! ( no BG modification) or does not change
IF ((vStruct(i+1)%sumBG.LT.kpatchsize.AND.vStruct(i)%sumBG.LE.kpatchsize).OR.&
vStruct(i+1)%sumBG == vStruct(i)%sumBG) THEN
!until light model 4 restriction apply
IF ( i <= lm3layer ) THEN
! At the beginning the light intensity of the pool remains the same
! but it will be updated when cohorts drop out
Irelpool(i-1)=Irelpool(i)
! until there are cohorts dropping out
BGpool(i)=MAX((kpatchsize-vStruct(i)%sumBG)/kpatchsize,0.)
CALL L_3_COH_LOOP(i,1)
! FPAR in light model 3 defined differently has
! to be redefined here to cause no conflict in crown.f
p => pt%first
DO WHILE (ASSOCIATED(p))
p%coh%FPAR(i)=p%coh%totFPAR
p => p%next
END DO ! cohort loop1
ELSE
CALL L_4_COH_LOOP(i,1,beta,y)
END IF
! second and third subcase of 'sumBG increases or remains the same'
! the BG's of the cohorts change because sumBG exceeds patchsize.
! second subcase: sumBG was < patchsize before
! third subcase: sumBG was > patchsize before
ELSE
p => pt%first
! cohort loop 1
DO WHILE (ASSOCIATED(p))
! calculate the new fraction covered by the pool
! which is the old pool plus the fractions which are lost
! by the old cohorts due to new BG's
! this also changes the light intensity of the pool
! consider only cohorts that have been there before (i<toplayer)
! consider only cohorts that have leafed out already, otherwise
! it may happen that help=0
IF (i<p%coh%toplayer.AND.i>=p%coh%botlayer .AND.&
iday >= p%coh%day_bb .AND. iday <= spar(p%coh%species)%end_bb) THEN
help=BGpool(i+1)+(p%coh%BG(i+1)-p%coh%BG(i))*p%coh%nTreeA
if( help.ne.0) then
Irelpool(i)=(1/help)*(Irelpool(i)*BGpool(i+1)+p%coh%Irel(i)*&
(p%coh%BG(i+1)-p%coh%BG(i))*p%coh%nTreeA)
BGpool(i+1)=help
end if
END IF ! layer test
p => p%next
END DO ! cohort loop1
!until light model 4 restriction apply
IF ( i <= lm3layer ) THEN
CALL L_3_COH_LOOP(i,1)
! FPAR in light model 3 defined differently has
! to be redefined here to cause no conflict in crown.f
p => pt%first
DO WHILE (ASSOCIATED(p))
p%coh%FPAR(i)=p%coh%totFPAR
p => p%next
END DO ! cohort loop1
ELSE
CALL L_4_COH_LOOP(i,1,beta,y)
END IF
END IF ! subcases of 'sumBG increases
! second case: sumBG decreases
ELSE
! two subcases
! first subcase of 'sumBG decrease': sumBG < patchsize before and after
! i.e. BG's do not change
! i.e. all projection area requirements can be fulfilled in the next layer
IF (vStruct(i+1)%sumBG.LT.kpatchsize) THEN
!until light model 4 restriction apply
IF ( i <= lm3layer ) THEN
! At the beginning the light intensity of the pool remains the same
! but it will be updated when cohorts drop out
Irelpool(i-1)=Irelpool(i)
! until there are cohorts dropping out
BGpool(i)=(kpatchsize-vStruct(i)%sumBG)/kpatchsize
CALL L_3_COH_LOOP(i,1)
! FPAR in light model 3 defined differently has
! to be redefined here to cause no conflict in crown.f
p => pt%first
DO WHILE (ASSOCIATED(p))
p%coh%FPAR(i)=p%coh%totFPAR
p => p%next
END DO ! cohort loop1
ELSE
CALL L_4_COH_LOOP(i,1,beta,y)
END IF
! second subcase of 'sumBG decrease': sumBG remains > patchsize or
! sumBG was > patchsize, i.e. BG's do increase
ELSE
!until light model 4 restriction apply
IF ( i <= lm3layer ) THEN
! BG of the pool for the next layer as long as there are
! no cohorts dropping out
BGpool(i)=MAX((kpatchsize-vStruct(i)%sumBG)/kpatchsize,0.)
Irelpool(i-1)=Irelpool(i)
CALL L_3_COH_LOOP(i,2)
! FPAR in light model 3 defined differently has
! to be redefined here to cause no conflict in crown.f
p => pt%first
DO WHILE (ASSOCIATED(p))
p%coh%FPAR(i)=p%coh%totFPAR
p => p%next
END DO ! cohort loop1
ELSE
CALL L_4_COH_LOOP(i,2,beta,y)
END IF
END IF ! subcases
END IF ! three main cases
END DO ! end layer loop
! -----------------------------------------------------------
IF(all_leaves_on==1) THEN
p => pt%first
DO WHILE (ASSOCIATED(p))
p%coh%bes = 0.
DO i = highest_layer, lowest_layer, -1
if(p%coh%totFPAR.ne.0) p%coh%antFPAR(i)=(p%coh%FPAR(i)-p%coh%FPAR(i+1))/p%coh%totFPAR
p%coh%sleafarea(i)=p%coh%leafarea(i)
! besetting here weighted with relative leaf area in layer, could also be done with nimber of layers
IF((vstruct(i)%sumBG > kpatchsize) .and. (p%coh%t_leaf .gt. zero)) p%coh%bes = p%coh%bes + p%coh%leafarea(i)/p%coh%t_leaf*(vstruct(i)%sumBG/kpatchsize)
END DO ! end layer loop
p => p%next
END DO ! cohort loop
ENDIF
! total LAI is simply the value of cumLAI at the lowest canopy layer
LAI = vStruct(lowest_layer)%cumLAI
IF(lai>laimax) laimax=lai
! light intensitiy and free patch space unto the ground
DO i = lowest_layer - 2, 0, -1
Irelpool(i)=Irelpool(i+1)
BGpool(i+1)=BGpool(i+2)
END DO
END SUBROUTINE LIGHT_4
END SUBROUTINE CANOPY
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! writes essential light paramerter into light.res1
! seperated to cohorts and layers
SUBROUTINE LIGHT_OUT_2
use data_simul
USE data_out
USE data_stand
USE data_species
INTEGER:: i=0,j=0
TYPE(Coh_Obj), Pointer :: p ! pointer to cohort list
! Header
write(unit_light,'(2A5,5A9)') 'YEAR ','layer ',' Coh1 ', &
' Coh2 ',' Coh3 ',' Coh4 ','...'
p => pt%first
WRITE(unit_light,'(i3,A)',ADVANCE='NO') time,' '
! the crown cover area for cohorts
DO WHILE (ASSOCIATED(p))
WRITE(unit_light,'(F8.2)',ADVANCE='NO') p%coh%crown_area
p => p%next
END DO
WRITE(unit_light,'(A)') ' '
WRITE(unit_light,'(A)') '-----------------------------------------------------------------------'
SELECT CASE (flag_light)
CASE(3,4)
DO i = highest_layer, lowest_layer, -1
IF(i.EQ.lm3layer) WRITE(unit_light,'(A)',ADVANCE='NO') 'ab hier LM3!'
WRITE(unit_light,'(A,i3)',ADVANCE='NO') 'IREL ',i
! relativ light intensity that hits layers and cohorts
p => pt%first
DO j=1, anz_coh
IF (p%coh%Irel(i) == 0.) THEN
WRITE(unit_light,'(F8.2)',ADVANCE='NO') -99.99
ELSE
WRITE(unit_light,'(F8.4)',ADVANCE='NO') p%coh%Irel(i)
END IF
p => p%next
END DO
WRITE(unit_light,'(A)') ' '
WRITE(unit_light,'(A,A7)',ADVANCE='NO') 'BG',' '
! cover degree per cohort and layer
p => pt%first
DO j=1, anz_coh
IF (p%coh%BG(i) == 0.) THEN
WRITE(unit_light,'(F8.2)',ADVANCE='NO') -99.99
ELSE
WRITE(unit_light,'(F8.4)',ADVANCE='NO') p%coh%BG(i)
END IF
p => p%next
END DO
WRITE(unit_light,'(A)') ' '
WRITE(unit_light,'(A,A5)',ADVANCE='NO') 'FPAR',' '
! the fraction absorbed by corhort and layer
p => pt%first
DO j=1, anz_coh
IF (p%coh%FPAR(i) == 0.) THEN
WRITE(unit_light,'(F8.2)',ADVANCE='NO') -99.99
ELSE
WRITE(unit_light,'(F8.4)',ADVANCE='NO') p%coh%FPAR(i)
END IF
p => p%next
END DO
WRITE(unit_light,'(A)') ' '
WRITE(unit_light,'(A,F8.4)') 'BGpool in dieser schicht :', BGpool(i)
WRITE(unit_light,'(A,F8.4)') 'relative Ueberdeckung in dieser Schicht :', vStruct(i)%sumBG/kpatchsize
WRITE(unit_light,'(A,F8.4)') 'Summer der Ueberdeckungen :', BGpool(i)+vStruct(i)%sumBG/kpatchsize
WRITE(unit_light,'(A)') ' '
WRITE(unit_light,'(A,F8.4)') 'Rel. Licht unter dieser schicht :', VStruct(i)%Irel
WRITE(unit_light,'(A,F8.4)') 'totFparsum bis zu dieser schicht :', VStruct(i)%radFrac
WRITE(unit_light,'(A,F8.4)') ' Lichtbilanz : ', vStruct(i)%Irel+VStruct(i)%radFrac
WRITE(unit_light,'(A)') ' '
WRITE(unit_light,'(A)') '-----------------------------------------------------------------------'
END DO ! layers loop
CASE(2)
DO i = highest_layer, lowest_layer, -1
WRITE(unit_light,'(A,i3)',ADVANCE='NO') 'Irel ',i
! relative light intensity that hits the layer and cohorts
DO j=1, anz_coh
WRITE(unit_light,'(F8.4)',ADVANCE='NO') vStruct(i)%Irel
END DO
WRITE(unit_light,'(A)') ' '
! cover degree per cohort and layers
p => pt%first
WRITE(unit_light,'(A,A7)',ADVANCE='NO') 'BG',' '
DO j=1, anz_coh
IF (p%coh%BG(i) == 0.) THEN
WRITE(unit_light,'(F8.2)',ADVANCE='NO') -99.99
ELSE
WRITE(unit_light,'(F8.4)',ADVANCE='NO') p%coh%BG(i)
END IF
p => p%next
END DO
WRITE(unit_light,'(A)') ' '
WRITE(unit_light,'(A,A5)',ADVANCE='NO') 'FPAR',' '
! fraction absorbed by cohort and layer
p => pt%first
DO j=1, anz_coh
IF (p%coh%FPAR(i) == 0.) THEN
WRITE(unit_light,'(F8.2)',ADVANCE='NO') -99.99
ELSE
WRITE(unit_light,'(F8.4)',ADVANCE='NO') p%coh%FPAR(i)
END IF
p => p%next
END DO
WRITE(unit_light,'(A)') ' '
WRITE(unit_light,'(A)') '-----------------------------------------------------------------------'
END DO
CASE(1)
DO i = highest_layer, lowest_layer, -1
WRITE(unit_light,'(A,i3)',ADVANCE='NO') 'IREL ',i
! relative light inensity that hits layers and cohorts
DO j=1, anz_coh
WRITE(unit_light,'(F8.4)',ADVANCE='NO') vStruct(i)%Irel
END DO
WRITE(unit_light,'(A)') ' '
WRITE(unit_light,'(A,A5)',ADVANCE='NO') 'FPAR',' '
! fraction absirbed by cohort and layer
p => pt%first
DO j=1, anz_coh
IF (p%coh%FPAR(i) == 0.) THEN
WRITE(unit_light,'(F8.2)',ADVANCE='NO') -99.99
ELSE
WRITE(unit_light,'(F8.4)',ADVANCE='NO') p%coh%FPAR(i)
END IF
p => p%next
END DO
WRITE(unit_light,'(A)') ' '
WRITE(unit_light,'(A)') '-----------------------------------------------------------------------'
END DO
END SELECT
WRITE(unit_light,'(A,A2)',ADVANCE='NO') 'totFPAR',' '
p => pt%first
DO j=1, anz_coh
WRITE(unit_light,'(F8.5)',ADVANCE='NO') p%coh%totFPAR
p => p%next
END DO
WRITE(unit_light,'(A)') ' '
WRITE(unit_light,'(A,F8.4)') 'Summe totFPAR : ',totFPARsum
SELECT CASE(flag_light)
CASE(3,4)
WRITE(unit_light,'(A,F8.4)') 'Irel(lowest-1) : ', Irelpool(lowest_layer-1)
WRITE(unit_light,'(A,F8.4)') ' Lichtbilanz : ', Irelpool(lowest_layer-1)+totFPARsum
CASE(1,2)
WRITE(unit_light,'(A,F8.4)') 'Irel(lowest-1) : ', vStruct(lowest_layer-1)%Irel
WRITE(unit_light,'(A,F8.4)') ' Lichtbilanz : ', vStruct(lowest_layer-1)%Irel+totFPARsum
END SELECT
WRITE(unit_light,'(A)') ' '
WRITE(unit_light,'(A)') ' '
WRITE(unit_light,'(A)') ' '
WRITE(unit_light,'(A)') ' '
WRITE(unit_light,'(A)') '------------------------------------------------------------------------------------'
WRITE(unit_light,'(A)') ' '
WRITE(unit_light,'(A)') ' '
END SUBROUTINE LIGHT_OUT_2
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
SUBROUTINE CROWN_PROJ
! Now calculate crown projection per tree and layer and
! the coverage sum over all layers
!*** Declaration part ***!
USE data_par
USE data_species
USE data_simul
USE data_stand
IMPLICIT NONE
! variables required for technical reasons
INTEGER :: i
real :: help, help1
TYPE(Coh_Obj), Pointer :: p ! pointer to cohort list
vStruct%sumBG=0.
p => pt%first
DO WHILE (ASSOCIATED(p))
ns=p%coh%species
! SMALL TREES OR GROUND VEGETATION
IF (p%coh%height.lt.thr_height .or. ns .eq. nspec_tree+1) THEN
p%coh%crown_area = p%coh%t_leaf ! small trees or ground vegetation
ELSEIF (p%coh%species.eq.nspec_tree+2) then ! Case mistletoe
p%coh%crown_area=pi*(real(p%coh%nTreeA)*0.000475)**(0.6666) ! 1 big ball: volume = sum of mistletoe standard balls (10 years, pfiz 2000)
! V=4/3*Pi*r^3 , r= (3*V/4*PI)^1/3, (set V=n*4/3*Pi*512, with r=0.08 standard ball), r=(n*5.12*10-4)^1/3,A=pi*(n*5.12*10-4)^2/3
ELSE
! Formel nach Biber 1996 S. 121, Kronenradius [dm]= a*DBH [cm]+b
help1 = MIN(spar(ns)%crown_c,spar(ns)%crown_a*(p%coh%diam)+spar(ns)%crown_b)
help=PI*(help1)**2
! adaptation of seedling crown projected area
IF(p%coh%ca_ini.GT.help) THEN
p%coh%crown_area=p%coh%ca_ini
ELSE IF (p%coh%ca_ini.LT.help.AND.p%coh%diam == 0) THEN
if(p%coh%height_ini.eq.137. .or. p%coh%height.eq.p%coh%height_ini) then
p%coh%crown_area=p%coh%ca_ini
else
p%coh%crown_area=(p%coh%height-p%coh%height_ini)/(137.-p%coh%height_ini)*&
(PI*(spar(ns)%crown_b)**2-p%coh%ca_ini)+p%coh%ca_ini
end if
ELSE
p%coh%crown_area=help
END IF
END IF
if(p%coh%crown_area.lt.0) then
p%coh%crown_area = p%coh%ca_ini
end if
DO i=p%coh%topLayer,p%coh%botLayer,-1
vStruct(i)%sumBG=vStruct(i)%sumBG+p%coh%crown_area*p%coh%nTreeA
END DO
p => p%next
END DO
END SUBROUTINE CROWN_PROJ
source_code/version_2.3_windows/crown.f 0 → 100644
View file @ 82df1085
!*****************************************************************!
!* *!
!* FORESEE Simulation Model *!
!* *!
!* *!
!* Subroutine for: *!
!* Calculation of rise of bole height *!
!* *!
!* Copyright (C) 1996-2018 *!
!* Potsdam Institute for Climate Impact Reserach (PIK) *!
!* Authors and contributors see AUTHOR file *!
!* This file is part of 4C and is licensed under BSD-2-Clause *!
!* See LICENSE file or under: *!
!* http://www.https://opensource.org/licenses/BSD-2-Clause *!
!* Contact: *!
!* https://gitlab.pik-potsdam.de/foresee/4C *!
!* *!
!*****************************************************************!
SUBROUTINE CROWN (p)
!*** Declaration part ***!
USE data_stand
USE data_species
USE data_simul
IMPLICIT NONE
REAL :: relnpp, & ! layer specific amount of npp per cohort
reldm ! layer specific dry matter to be replaced
INTEGER :: nl ! variable for crown layers
INTEGER :: i
TYPE(Coh_Obj) :: p ! pointer to cohort list
!*** Calculation part ***!
! evaluate assimilation balance vs. foliage turnover rate for the crown layers
ns = p%coh%species
DO i = p%coh%topLayer, p%coh%botLayer, -1
nl = i
relnpp = p%coh%antFPAR(i) * p%coh%netAss
reldm = 1.5*spar(ns)%psf * p%coh%sleafArea(i) / p%coh%med_sla
IF ( relnpp < reldm) THEN
nl = nl + 1
EXIT
ENDIF
END DO
p%coh%deltaB = (nl - p%coh%botLayer) * dz
IF(p%coh%deltaB.GT.0.05*(p%coh%height-p%coh%x_hbole)) p%coh%deltaB=0.05*(p%coh%height-p%coh%x_hbole)
END SUBROUTINE CROWN
source_code/version_2.3_windows/daily.f 0 → 100644
View file @ 82df1085
!*****************************************************************!
!* *!
!* 4C Simulation Model *!
!* *!
!* *!
!* Subroutines for: *!
!* Simulation of processes at subannual resolution *!
!* *!
!* *!
!* Contains subroutines: *!
!* *!
!* STAND_DAILY *!
!* SET_PS *!
!* DROUGHT : Calculation of drought stress indices *!
!* FIRE_RISK *!
!* calc_frost_index : calculation of indices for frost damage *!
!* calc_endbb : calculation of end of the vegetation period *!
!* *!
!* Copyright (C) 1996-2018 *!
!* Potsdam Institute for Climate Impact Reserach (PIK) *!
!* Authors and contributors see AUTHOR file *!
!* This file is part of 4C and is licensed under BSD-2-Clause *!
!* See LICENSE file or under: *!
!* http://www.https://opensource.org/licenses/BSD-2-Clause *!
!* Contact: *!
!* https://gitlab.pik-potsdam.de/foresee/4C *!
!* *!
!*****************************************************************!
SUBROUTINE stand_daily
!*** Declaration part ***!
USE data_stand
USE data_simul
USE data_species
USE data_climate
USE data_site
USE data_soil_cn
USE data_out
USE data_par
USE data_evapo
USE data_soil
use data_manag
IMPLICIT NONE
REAL :: aveT, & ! average of temperature for PS/NPP models
avDL, & ! average of daylength for PS/NPP model
avRD, & ! average of radiation
avPR, & ! average of pressure (hPa)
PAR ! average of PAR for PS/NPP model [mol quanta d-1]
REAL :: hdfr, hdt, hprs
INTEGER :: i, jd, k, d, week, monthday, ns_pro_help
real :: p_help, t_help
REAL :: photoper
p_help=0.
t_help=0.
irelpool_ll=0.
bgpool_ll=0.
!*** Calculation part ***!
week = 0
monthday = 0
monat = 1
woche = 1
! daily loop
DO jd = 1, recs(time)
iday = jd
monthday=monthday+1
! input of daily climate data
CALL day_ini
if(anz_coh .gt. 0) then ! if no cohort, then no phaenology necessary
IF(all_leaves_on==0) CALL pheno_begin
CALL pheno_count
IF(leaves_on) CALL pheno_shed
endif
IF(phen_flag==1 .OR. (.not.flag_tree .and. leaves_on)) THEN
! Calculate this year's crown geometry for each cohort, followed by
! leaf area and light profiles across the canopy
CALL CANOPY
if (anz_coh.eq.0) then
irelpool_ll = 1.
end if
if(all_leaves_on.eq.1) then
irelpool_ll = irelpool(0)
bgpool_ll = bgpool(2)
end if
IF(flag_end.EQ.3) RETURN
! update of stand variables (LAI, cover)
CALL standup
phen_flag=0;
END IF
!call distubance after start day
select case(flag_dis)
case(1,2)
if (dis_control(1,1) .eq. 1) then
if(all_leaves_on .eq. 1 .and. dis_start(dis_control(1,2)) .eq. iday) then
CALL disturbance_defoliator
CALL CANOPY
CALL stand_balance
CALL standup
endif
endif
if (dis_control(2,1) .eq. 1) then
if(all_leaves_on .eq. 1 .and. dis_start(dis_control(2,2)) .eq. iday) CALL disturbance_xylem
endif
if (dis_control(3,1) .eq. 1) then
if(dis_start(dis_control(3,2)) .eq. iday) CALL disturbance_phloem
endif
if (dis_control(4,1) .eq. 1) then
if(dis_start(dis_control(4,2)) .eq. iday) then
CALL disturbance_root
CALL stand_balance
CALL standup
endif
endif
if (dis_control(5,1) .eq. 1) then
if(dis_start(dis_control(5,2)) .eq. iday) CALL disturbance_stem
endif
end select
ns_pro_help = ns_pro
! set ns_pro_help to length of last photosynthesis period at end of year
IF(iday >int(recs(time)/ns_pro)*ns_pro .and. (MOD( iday, ns_pro )==1)) THEN
ns_pro_help = recs(time) - int(recs(time)/ns_pro)*ns_pro
END IF
! optimum photosynthesis submodel
IF (ns_pro==1.OR.(MOD( iday, ns_pro )==1) .or. iday.eq.1) THEN
! assign averaged input variables for PS model
aveT = 0.
avDL = 0.
avRD = 0.
avPR = 0.
hdfr = 0.
ns_day = 1
DO k = 1, ns_pro_help ! this calculates 365 or 366, but is not included as a wwek value
! ==> last week of the year is recieving this amount
d = iday-1+k
hdt = Q10_T**((tp(d,time) - 15.) / 10.)
hdfr = hdfr + hdt
dayfract(k) = hdt
aveT = aveT + tp(d,time) + deltaT
avRD = avRD + rd(d,time)
hprs = prs(d,time)
if (hprs .lt. 800.) then
hprs = 1013
endif
avPR = avPR + hprs
avDL = avDL + photoper( FLOAT(d), xLat )
END DO
aveT = aveT / ns_pro_help
avDL = avDL / ns_pro_help
avRD = avRD / ns_pro_help
avPR = avPR / ns_pro_help
! PAR that is coming in stand reflection is substracted
PAR = (1.-pfref)* GR_in_PAR * avRD
if (iday .gt. 364) then
dayfract = 1. ! at the last days of the year no temperature depending daily fraction of flux
else
dayfract = ns_pro * dayfract / hdfr ! temperature depending daily fraction of flux, calc. from sum of ns_pro days
endif
CALL OPT_PS( aveT, avDL, PAR, avPR )
ENDIF
! aggregation of stomatal conductance of the canopy
gp_can_mean = gp_can_mean + gp_can
gp_can_min = min(gp_can_min, gp_can)
gp_can_max = max(gp_can_max, gp_can)
! soil submodel
CALL SOIL
CALL drought
! NPP submodel
IF (ns_pro==1.OR.(MOD( (iday-1), ns_pro )==0) .or. iday .eq. recs(time) .or. iday.eq.1) THEN
CALL NPP( aveT, avDL, PAR, ns_pro_help )
IF(.not.flag_tree .and. leaves_on.and.flag_sprout.eq.1) CALL growth_seed_week (ns_pro_help)
! daily output every ns_pro days of dips- and gsdps-files
IF (flag_dayout .ge. 1) CALL coh_out_d(2)
ENDIF
CALL calc_fire_risk
! calculation of the start of vegetation period
if(flag_vegper.eq.0) then
if(airtemp.le.5. .and. flag_tveg .ne.0) then
flag_tveg=0
else if(airtemp.gt.5. .and. flag_tveg.eq.0) then
flag_tveg =1
else if(airtemp.gt.5. .and. flag_tveg.eq.1) then
flag_tveg =2
else if(airtemp.gt.5. .and. flag_tveg.eq.2) then
flag_tveg =3
else if(airtemp.gt.5. .and. flag_tveg.eq.3)then
flag_tveg =4
else if(airtemp.gt.5. .and. flag_tveg.eq.4) then
flag_tveg =5
end if
if(flag_tveg .eq.5) then
flag_vegper=1
iday_vegper = iday
end if
endif
! call of SR for calculation of various indices for the frost index
if(airtemp_min .gt. -90.) call calc_frost_index
! Calculation of maximal radiation (for information only)
call glob_rad(dlength, iday, lat, rad_max)
Cout%NEE(iday) = respsoil - dailyNPP_C ! g C/m²
Cout%Resp_aut(iday) = dailyautresp_C * dayfract(ns_day)
NPP_day = dailyNPP_C * dayfract(ns_day)
GPP_day = (dailyNPP_C + dailyautresp_C) * dayfract(ns_day)
TER_day = dailyautresp_C * dayfract(ns_day) + respsoil
IF (flag_dayout .ge. 1) CALL outday(1)
IF (ns_pro==1.OR.(MOD( iday, ns_pro )==0) .or. iday .eq. recs(time) ) CALL SET_PS
! Wochen- und Monatswerte berechnen
aet_mon(monat) = aet_mon(monat) + aet
aet_week(woche) = aet_week(woche) + aet
pet_mon(monat) = pet_mon(monat) + pet
pet_week(woche) = pet_week(woche) + pet
temp_mon(monat) = temp_mon(monat) + airtemp
temp_week(woche) = temp_week(woche) + airtemp
prec_mon(monat) = prec_mon(monat) + prec
prec_week(woche) = prec_week(woche) + prec
rad_mon(monat) = rad_mon(monat) + rad
hum_mon(monat) = hum_mon(monat) + hum
perc_mon(monat) = perc_mon(monat) + perc(nlay)
perc_week(woche) = perc_week(woche) + perc(nlay)
resps_mon(monat) = resps_mon(monat) + respsoil
resps_week(woche)= resps_week(woche) + respsoil
GPP_mon(monat) = GPP_mon(monat) + dailyNPP_C + dailyautresp_C
GPP_week(woche) = GPP_week(woche) + dailyNPP_C + dailyautresp_C
NEE_mon(monat) = NEE_mon(monat) + Cout%NEE(iday) ! g C/m²
NPP_mon(monat) = NPP_mon(monat) + dailyNPP_C
NPP_week(woche) = NPP_week(woche) + dailyNPP_C
TER_mon(monat) = TER_mon(monat) + dailyautresp_C + respsoil
TER_week(woche) = TER_week(woche) + dailyautresp_C + respsoil
tempmean_mo(monat) = tempmean_mo(monat) + airtemp ! long-term monthly means
! summation output with variabel time steps
photsum = photsum + phot_C
npppotsum = npppotsum + dailypotNPP_C
nppsum = nppsum + dailyNPP_C
resosum = resosum + respsoil
nee = nee + respsoil - dailyNPP_C
gppsum = gppsum + GPP_day
sumGPP = sumGPP + dailyNPP_C + dailyautresp_C
sumTER = sumTER + dailyautresp_C + respsoil
resautsum = resautsum + dailyautresp_C
precsum = precsum + prec
tempmean = tempmean + airtemp
tempmeanh = tempmeanh +airtemp
aet_sum = aet_sum + aet
pet_sum = pet_sum + pet
perc_sum = perc_sum + perc(nlay)
if(monthday==monrec(monat)) then
tempmeanh = tempmeanh/monrec(monat)
if(monat.eq.1) med_air_cm = tempmeanh
if(tempmeanh.lt.med_air_cm) med_air_cm = tempmeanh
if(tempmeanh.gt.med_air_wm) med_air_wm = tempmeanh
tempmeanh = 0.
temp_mon(monat) = temp_mon(monat) / monrec(monat)
rad_mon(monat) = rad_mon(monat) / monrec(monat)
hum_mon(monat) = hum_mon(monat) / monrec(monat)
if(temp_mon(monat).lt.med_air_cm) med_air_cm = temp_mon(monat)
if(temp_mon(monat).gt.med_air_wm) med_air_wm = temp_mon(monat)
end if
if(airtemp.ge.10.) then
t_help= t_help + airtemp
p_help= p_help + prec
end if
ns_day = ns_day + 1
! daily output
IF(flag_sum .eq. 1) THEN
write(unit_sum,'(2I5,13F10.3)') iday,time_cur,photsum,npppotsum,nppsum,resosum, &
lightsum,nee,abslightsum,precsum,tp(iday,time), &
exp(0.069*(tp(iday,time)-15.)), sumGPP, sumTER, resautsum
photsum=0.;npppotsum=0.;nppsum=0.;resosum=0.;lightsum=0.;nee=0.;abslightsum=0.; precsum=0.
sumGPP = 0.
sumTER = 0.
resautsum = 0.
ENDIF
! output with time step of photosynthesis
IF(flag_sum .eq. 2 .and. mod(iday,ns_pro)==0) THEN
week = week + 1
write(unit_sum,'(2I6,17F10.3)') week,time_cur,time_cur+(week-0.5)/52.,photsum,npppotsum,nppsum,resosum, &
lightsum,nee,abslightsum,precsum,aveT,exp(0.069*(aveT-15.)), &
aet_sum, pet_sum, perc_sum, sumGPP, sumTER, resautsum
photsum=0.;npppotsum=0.;nppsum=0.;resosum=0.;lightsum=0.;nee=0.;abslightsum=0.; precsum=0.
aet_sum = 0.; pet_sum = 0.
perc_sum = 0.
sumGPP = 0.
sumTER = 0.
resautsum = 0.
ENDIF
if(mod(iday,7) .eq. 0) then
woche = woche + 1
endif
if(monthday .eq. monrec(monat)) then
IF(flag_sum .eq. 3 ) THEN
tempmean = tempmean/monrec(monat)
if( temp_mon(monat) .le. 0.) then
ind_cout_mo = 12.* prec_mon(monat)
ind_cout_mo = 12*precsum
else
ind_cout_mo = 12.* prec_mon(monat) /(temp_mon(monat) + 10.)
ind_cout_mo = 12*precsum/(tempmean+10)
end if
if(temp_mon(monat) .le. 0.) then
ind_wiss_mo = 12.* prec_mon(monat)
ind_wiss_mo = 12*precsum
else
ind_wiss_mo = 12.* prec_mon(monat) /(temp_mon(monat) + 7.)
ind_wiss_mo = 12*precsum/(tempmean+7)
end if
if(ind_arid_mo.ne.0.) then
ind_arid_mo = prec_mon(monat)/pet_sum
else
ind_arid_mo=0.
end if
cwb_mo = prec_mon(monat) - pet_sum
ind_cout_an = ind_cout_an + ind_cout_mo
ind_wiss_an = ind_wiss_an + ind_wiss_mo
write(unit_sum,'(I7,I5,20F10.3)') monat,time_cur,time_cur+(monat-0.5)/12.,photsum,npppotsum,nppsum,resosum, &
lightsum,nee,abslightsum, precsum, tempmean, aet_sum, pet_sum, ind_cout_mo, ind_wiss_mo, &
ind_arid_mo, cwb_mo, perc_sum, sumGPP, sumTER, resautsum
photsum=0.;npppotsum=0.;nppsum=0.;resosum=0.;lightsum=0.;nee=0.;abslightsum=0.; precsum=0.; tempmean = 0.
aet_sum = 0.; pet_sum = 0.; ind_cout_mo = 0.; ind_wiss_mo=0.; ind_arid_mo=0.; cwb_mo = 0.
perc_sum = 0.
sumGPP = 0.
sumTER = 0.
resautsum = 0.
ENDIF ! flag_sum
monat = monat+1
monthday = 0
endif ! monthday
END DO ! iday daily loop
!calculate the mean stress factor for root growth
if (flag_wurz .eq. 4 .or. flag_wurz .eq. 6) then
do i=1,nlay
do k=1,nspecies
svar(k)%Smean(i)=svar(k)%Smean(i)/recs(time)
enddo
enddo
endif
ind_shc = p_help/(t_help/10)
END SUBROUTINE stand_daily
!***************************************************************
SUBROUTINE SET_PS
USE data_stand
TYPE(coh_obj), POINTER :: p
p => pt%first
DO WHILE (ASSOCIATED(p))
! reset drought index & day counter to zero for next time step
p%coh%drIndPS = 0.
p%coh%nDaysPS = 0.
p => p%next
END DO
END SUBROUTINE SET_PS
!**************************************************************
SUBROUTINE drought
! Calculation of drought stress indices
! Sum up of RedN
USE data_simul
USE data_stand
USE data_par
USE data_species
implicit none
integer i, ii
real, dimension(1:nspecies):: rhelp
rhelp = 0.
! drought index of trees
zeig => pt%first
do while (associated(zeig))
ns = zeig%coh%species
! calculation of daily drought index
if (zeig%coh%demand .gt. 10E-6) then
if (ns.eq.nspec_tree+2) then ! set drought index to 1 for mistletoe (no drought)
zeig%coh%drIndD = 1
else
zeig%coh%drIndD = zeig%coh%supply / zeig%coh%demand
endif
else
zeig%coh%drIndD = 1.
endif
select case (flag_limi)
case (4, 5, 6, 7, 8, 9)
rhelp(ns) = rhelp(ns) + zeig%coh%ntreeA * zeig%coh%RedNc ! mean annual RedN
end select
IF ((iday .ge. zeig%coh%day_bb) .AND. (iday .le. spar(zeig%coh%species)%end_bb)) THEN
zeig%coh%drIndPS = zeig%coh%drIndPS + zeig%coh%drIndD
zeig%coh%drIndAl = zeig%coh%drIndAl + zeig%coh%drIndD
drIndD = drIndD + zeig%coh%ntreeA * zeig%coh%drIndD
ENDIF
zeig => zeig%next
enddo ! zeig (cohorts)
if (flag_limi .ge. 4 .and. flag_limi .le. 9) then
do i=1,anrspec
ii = nrspec(i)
svar(ii)%RedN = rhelp(ii) * 10000. / (svar(ii)%sum_nTreeA * kpatchsize) ! durch Anz. Tree pro patchsize teilen
enddo
endif
do i=1,anrspec
ii = nrspec(i)
svar(ii)%RedNm = svar(ii)%RedNm + svar(ii)%RedN
enddo
if(anz_tree.ne.0) then
drIndD = drIndD / anz_tree
endif
END subroutine drought
!***************************************************************
SUBROUTINE calc_fire_risk
!calculation of fire risk index
USE data_biodiv
USE data_climate
USE data_simul
USE data_soil
USE data_species
USE data_stand
implicit none
integer i, ii, nshelp
real hsum, hday, Tcrit_bi, cdays
real svp_13, vp_13, vpd_13, relhum_13
real k_prec ! constant depending on precipitation
real k_phen
real hh
if (iday.eq.1) then
prec_flag1 = 0
prec_flag2 = 0
tsumrob = 0.
day_bb_rob = 0
tsumbi = 0.
day_bb_bi = -999.
cdays = 0.
Tcrit_bi = 0.
end if
! calculation of day_bb for 'Robinie'
if(day_bb_rob.lt.1) then
if(airtemp.gt.9.3) tsumrob = tsumrob + airtemp
if(tsumrob.gt.537.) then
day_bb_rob = iday
end if
end if
! calculation of day_bb for birch
nshelp = 5
! Temperature sum model Schaber 2002
if(day_bb_bi.lt.-99) then
if(airtemp > spar(nshelp)%LTbT.and. iday.gt.47) then
tsumbi = tsumbi + airtemp - spar(nshelp)%LTbT
end if
if(tsumbi > spar(nshelp)%LTcrit) then
day_bb_bi = iday
end if
end if
! if birch is simulated
zeig=>pt%first
DO
IF (.not.ASSOCIATED(zeig)) exit
if(zeig%coh%species.eq.5) day_bb_bi = zeig%coh%day_bb
zeig=>zeig%next
END DO
! fire index west
if (iday .ge. 60 .and. iday .lt. 270) then
hday = iday/30.
ii = int(hday) - 1 ! month index
hsum = SUM(clim_waterb)
i = 1
do i=1,4
if (hsum .gt. risk_class(i,ii)) then
fire_indw = i
fire(1)%index = i
exit
endif
fire_indw = 5
fire(1)%index = 5
enddo
fd_fire_indw(fire_indw)=fd_fire_indw(fire_indw)+1
fire(1)%frequ(fire(1)%index) = fire(1)%frequ(fire(1)%index) + 1
else
fire(1)%index = 0
endif
if(airtemp_max .gt. -90.) then
! fire index east
if (iday .ge. 46 .and. iday .lt. 275) then
svp_13 = 6.1078 * exp(17.62 * airtemp_max / (243.12+airtemp_max)) ! saturated vapour pressure at 13.00
! estimation actual vapour pressure derived from mean air humidity
vp_13 = svp_13*hum/100
vpd_13 = svp_13 - vp_13 ! vapour pressure deficit at 13.00
relhum_13 = 100. * vp_13 / svp_13
if ((prec .ge. 1.0 .and. prec .lt. 5.0) .or. (snow_day .eq. 1)) then
k_prec = 0.5
else if ((prec .ge. 5.0 .and. prec .lt. 10.0) .or. (snow_day .eq. 2)) then
k_prec = 0.25
else if ((prec .ge. 10.0) .or. (snow_day .gt. 2)) then
k_prec = 0.0
else
k_prec = 1.0
endif
if (iday .lt. day_bb_bi .or. day_bb_bi.eq.-999) then
k_phen = 3.
else if (prec.lt. 5 .and. iday .le. 227 .and. day_bb_rob.ne.0 .and. prec_flag1.eq.0) then
k_phen = 2.
else if (prec.ge. 5 .and. day_bb_rob.ne.0 .and. iday .gt. day_bb_rob .and. iday .lt. 227 .or. (prec_flag1.eq.1.and.iday.le.227)) then
k_phen = 1.
prec_flag1 = 1
else if( day_bb_rob.eq.0) then
k_phen = 2
else if (iday.ge. 227.and. prec.ge. 5) then
k_phen = 0.5
prec_flag2 = 1
else if(prec_flag2 .eq.1 .or. iday .gt. 243) then
k_phen = 0.5
else
k_phen = 1. ! no modification of forest fire index
endif
hh = (airtemp_max + 10)*vpd_13
fire_indi = k_prec * fire_indi + k_phen*(airtemp_max + 10)*vpd_13
if (fire_indi .gt. 4000) fire_indi_day = fire_indi_day + 1
fire_indi_max = max(fire_indi, fire_indi_max)
! fire hazard level east
if (fire_indi .le. 500.) then
fire(2)%index = 1 ! no alarm level
else if (fire_indi .le. 2000.) then
fire(2)%index = 2 ! alarm level 1
else if (fire_indi .le. 4000.) then
fire(2)%index = 3 ! alarm level 2
else if (fire_indi .le. 7000.) then
fire(2)%index = 4 ! alarm level 3
else
fire(2)%index = 5 ! alarm level 4
endif
fire(2)%frequ(fire(2)%index) = fire(2)%frequ(fire(2)%index) + 1
else
fire_indi = 0.
fire(2)%index = 0
endif
! fire index Bruschek
if (iday > 90 .AND. iday < 275) then
if(airtemp_max .ge. 25.) Ndayshot = Ndayshot + 1
Psum_FP = Psum_FP + prec
endif
! fire index Nesterov
! only calulated for vegetation and snow free period
if (iday .ge. 60 .and. iday .lt. 275 .and. snow .lt. 0.01 .and. airtemp_max .gt. 0.) then
if (prec .lt. 3.) then
day_nest = day_nest + 1
p_nest = p_nest + (airtemp_max - dptemp) * airtemp_max
else
day_nest = 0
p_nest = 0.
endif
if (p_nest .le. 300.) then
fire(3)%index = 1 ! minimal
else if (p_nest .le. 1000.) then
fire(3)%index = 2 ! moderate
else if (p_nest .le. 4000.) then
fire(3)%index = 3 ! high
else
fire(3)%index = 4 ! extreme
endif
fire(3)%frequ(fire(3)%index) = fire(3)%frequ(fire(3)%index) + 1
else
p_nest = 0.
fire(3)%index = 0
endif
else
fire(2)%index = -99.0
fire(3)%index = -99.0
endif ! airtemp_max
END subroutine calc_fire_risk
!*******************************************************************************
subroutine calc_frost_index
USE data_frost
USE data_climate
USE data_simul
USE data_stand
implicit none
integer :: day_bb, j, t, m, ii
! absolute and annual last frost day during spring/ summer
if(airtemp_min .lt. temp_frost .and. iday .lt. 200 ) then
if(iday.gt.dlfabs ) dlfabs = iday
if(iday.gt.date_lftot(time)) date_lftot(time)=iday
end if
! annual number of frost days after start of the vegetation period and annual last frost day
if(flag_vegper.eq.1. .and. iday.lt.200) then
if(airtemp_min .lt. temp_frost) then
dnlf(time) = dnlf(time) +1
! calculation of last frost day after beginning of vegetation period due to 5°C threshold for the case of needle trees
if( waldtyp.eq.10 .or. waldtyp.eq.40.or.waldtyp.eq.90 .and. iday.gt. date_lf(time)) date_lf(time)= iday
end if
end if
! calculation of the number of the actual month
j= time_cur
ii = iday
call tzinda(t,m,j,ii)
iday = ii
if(m.eq.4 .or. m.eq.5 .or. m.eq.6) then
if(airtemp_min .lt.0) then
anzdlf(time)=anzdlf(time)+1
sumtlf(time) = sumtlf(time) + airtemp_min
end if
endif
! annual minimum temperature may for year time
if(airtemp_min.lt.tminmay_ann(time).and. m.eq.5) tminmay_ann(time) = airtemp_min
! absolute minimum temperature May
if( airtemp_min .lt. tminmay .and. m.eq.5) tminmay = airtemp_min
! assuming mono species stand !!!
zeig=>pt%first
DO
IF (.not.ASSOCIATED(zeig)) exit
taxnum= zeig%coh%species
day_bb = zeig%coh%day_bb
exit
zeig=>zeig%next
END DO
! caculation not for conifer stands (pine, spruce, douglas fir)
if(waldtyp .ne. 10 .and. waldtyp .ne. 40 .and. waldtyp .ne.90)then
if(all_leaves_on.eq.1) then
if (iday.ge.day_bb .and. iday.lt.200) then
! calculation of number of frost day during vegetation period (bud burst) for year time
if(airtemp_min .lt. temp_frost ) then
dnlf_sp(time) = dnlf_sp(time) +1
! calculagtion of last frost day after beginning of vegetation period by bud burst
if(iday .gt. date_lf(time)) date_lf(time)= iday
end if
end if
end if ! all_leaves_on
end if ! waldtyp
END subroutine calc_frost_index
!*******************************************************************************
Subroutine calc_endbb
use data_climate
use data_stand
use data_species
use data_simul
implicit none
integer :: tax,fl
if(iday.gt.180) then
zeig => pt%first
do while (associated(zeig))
tax = zeig%coh%species
fl = zeig%coh%flag_vegend
if(spar(tax)%end_bb.ne.366) then
if(spar(ns)%flag_endbb.eq.0) then
if(airtemp.ge.5. .and. fl .ne.0) then
fl=0
else if(airtemp.lt.5. .and. fl.eq.0) then
fl =1
else if(airtemp.lt.5. .and. fl.eq.1) then
fl =2
else if(airtemp.lt.5. .and. fl.eq.2) then
fl =3
else if(airtemp.lt.5. .and. fl.eq.3)then
fl =4
else if(airtemp.lt.5. .and. fl.eq.4) then
fl =5
end if
zeig%coh%flag_vegend = fl
if(fl .eq.5) then
spar(tax)%flag_endbb=1
spar(tax)%end_bb = iday
write(666,*) time, iday
end if
end if
zeig => zeig%next
end if
end do
end if
end subroutine calc_endbb
source_code/version_2.3_windows/day_ini.f 0 → 100644
View file @ 82df1085
!*****************************************************************!
!* *!
!* 4C (FORESEE) Simulation Model *!
!* *!
!* *!
!* Subroutine DAY_INI for: *!
!* *!
!* allocation of daily weather variables *!
!* *!
!* Copyright (C) 1996-2018 *!
!* Potsdam Institute for Climate Impact Reserach (PIK) *!
!* Authors and contributors see AUTHOR file *!
!* This file is part of 4C and is licensed under BSD-2-Clause *!
!* See LICENSE file or under: *!
!* http://www.https://opensource.org/licenses/BSD-2-Clause *!
!* Contact: *!
!* https://gitlab.pik-potsdam.de/foresee/4C *!
!* *!
!*****************************************************************!
SUBROUTINE day_ini
USE data_biodiv
USE data_climate
USE data_depo
USE data_evapo
USE data_simul
USE data_site
USE data_stand
USE data_par
implicit none
type(Coh_Obj), pointer :: p ! pointer to cohort list
real, external :: photoper
real, external :: daylength
integer i, j
j = time
i = iday
airtemp = tp(i,j)+deltaT
airtemp_1 = tp(i-1,j)+deltaT
airtemp_2 = tp(i-2,j)+deltaT
airtemp_max = tx(i,j)
airtemp_min = tn(i,j)
prec = prc(i,j)*deltaPrec
hum = hm(i,j)
if (hum .le. 0.) then
hum = 1.
else if (hum .gt. 100.) then
hum = 100.
endif
if (press .gt. 0.) then
press = prs(i,j)
else
press = 1013.
endif
rad = rd(i,j)
wind = wd(i,j)
if (wind .lt. 0.) wind = 0.5
dlength = photoper(i+0.,xlat)
med_air = med_air + airtemp
sum_prec = sum_prec + prec
if(recs(time).eq.365) then
if(i.gt.120 .and. i.lt.274) then
med_air_ms = med_air_ms + airtemp
sum_prec_ms = sum_prec_ms + prec
end if
if(i.gt.120 .and. i .lt. 213) then
med_air_mj = med_air_mj + airtemp
sum_prec_mj = sum_prec_mj + prec
end if
else
if(i.gt.121 .and. i.lt.275) then
med_air_ms = med_air_ms + airtemp
sum_prec_ms = sum_prec_ms + prec
if(i.gt.121 .and. i .lt.214) then
med_air_mj = med_air_mj + airtemp
sum_prec_mj = sum_prec_mj + prec
end if
end if
end if
med_rad = med_rad + rad
med_wind = med_wind + wind
if (airtemp.gt. thr_gdd) then
gdday = gdday + airtemp
gdday_all = gdday_all + airtemp
end if
if (airtemp_max .ge. 25.) then
days_summer = days_summer + 1
if (airtemp_max .ge. 30.) then
days_hot = days_hot + 1
endif
endif
if( airtemp_min .gt. 0) days_wof = days_wof +1
if ((airtemp_max .lt. 0.) .and. (airtemp_max .gt. -90.)) then
days_ice = days_ice + 1
endif
if (prec .lt. 1.E-06) then
days_dry = days_dry + 1
else if (prec .gt. 10.) then
days_hrain = days_hrain + 1
else if (prec .gt. 0.1) then
days_rain = days_rain +1
if(recs(time).eq.365) then
if(i.gt.120 .and. i .lt. 213) days_rain_mj = days_rain_mj +1
else
if(i.gt.121 .and. i .lt.214) days_rain_mj = days_rain_mj +1
end if
endif
drIndd = 0.
lightsum = lightsum + rad/100 ! sum global radiation in mJ/m2
abslightsum = abslightsum + rad/100*totFPARsum ! sum absorbed global radiation in mJ/m2
! set standardised deposition data for areal application of deposition:
NO_dep = NOd(i,j)*0.001 ! mg N/m2 ==> g N/m2
NH_dep = NHd(i,j)*0.001 ! mg N/m2 ==> g N/m2
pev_sn = 0.
dew_rime = 0.
fire_indw = -99
fire_inde = -99
! water and N uptake
p => pt%first
do while (associated(p))
p%coh%supply = 0.
p%coh%Nuptc_d = 0.
p => p%next
enddo ! p (cohorts)
END SUBROUTINE day_ini
source_code/version_2.3_windows/dist_manag.f 0 → 100644
View file @ 82df1085
!*****************************************************************!
!* *!
!* 4C (FORESEE) *!
!* *!
!* *!
!* Subroutines for: *!
!* disturbance management *!
!* contains: *!
!* SR dist_ini *!
!* SR dist_manag *!
!* SR beetle_nat *!
!* SR beetle_man *!
!* SR disturbance_defoliator *!
!* SR disturbance_xylem *!
!* SR disturbance_phloem *!
!* SR disturbance_root *!
!* SR disturbance_stem *!
!* *!
!* Copyright (C) 1996-2018 *!
!* Potsdam Institute for Climate Impact Reserach (PIK) *!
!* Authors and contributors see AUTHOR file *!
!* This file is part of 4C and is licensed under BSD-2-Clause *!
!* See LICENSE file or under: *!
!* http://www.https://opensource.org/licenses/BSD-2-Clause *!
!* Contact: *!
!* https://gitlab.pik-potsdam.de/foresee/4C *!
!* *!
!*****************************************************************!
SUBROUTINE dist_ini
use data_manag
use data_simul
use data_species
use data_stand
use data_soil
implicit none
integer :: dis_unit,i,ios
character(len=150) :: filename
logical :: ex
character(3) ::text
dis_control=0
xylem_dis=1.0
phlo_feed=1.0
stem_rot=0.0
zeig=>pt%first
do
if(.not.associated(zeig)) exit
zeig%coh%x_fol_loss=0.
zeig%coh%x_frt_loss=0.
zeig%coh%biocost_all=0.
zeig=>zeig%next
end do
dis_unit=getunit()
filename = manfile(ip)
call testfile(filename,ex)
open(dis_unit,file=trim(filename))
do
read(dis_unit,*) text
if(text .eq. 'end')then
exit
endif
enddo
! read the total number of disturbance events (first line after 'end') and after this the annual events
read (dis_unit,*) dis_row_nr ! number of disturbance lines
allocate(dis_year(dis_row_nr));allocate(dis_type(dis_row_nr));
allocate(dis_spec(dis_row_nr));allocate(dis_start(dis_row_nr))
allocate(dis_rel(dis_row_nr))
do i=1,dis_row_nr
read(dis_unit,*,iostat=ios) dis_year(i),dis_type(i), dis_spec(i), dis_start(i), dis_rel(i)
if(ios<0) exit
end do
close(dis_unit)
END SUBROUTINE dist_ini
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
SUBROUTINE dis_manag
use data_manag
use data_simul
use data_stand
use data_site
use data_species
use data_soil
implicit none
integer :: i
do i= 1, dis_row_nr
if(time .eq. dis_year(i)) then
if(dis_type(i) .eq. 'D') then
dis_control(1,1) = 1
dis_control(1,2) = i
endif
if(dis_type(i) .eq. 'X') then
dis_control(2,1) = 1
dis_control(2,2) = i
endif
if(dis_type(i) .eq. 'P') then
dis_control(3,1) = 1
dis_control(3,2) = i
endif
if(dis_type(i) .eq. 'R') then
dis_control(4,1) = 1
dis_control(4,2) = i
endif
if(dis_type(i) .eq. 'S') then
dis_control(5,1) = 1
dis_control(5,2) = i
endif
if(dis_type(i) .eq. 'M') then
dis_control(6,1) = 1
dis_control(6,2) = i
endif
endif
enddo
END SUBROUTINE dis_manag
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! bark beetle infestation in unmanaged stands
SUBROUTINE beetle_nat(dis_rel_ip, rel_cra)
use data_manag
use data_simul
use data_species
use data_stand
use data_par
implicit none
real :: dis_cra, tot_cra, rel_cra, dis_rel_ip, tar_cra, tar_ba, dis_ba, tot_ba
real :: help, helpN, help1, help1N, hconvd
integer :: i, j, taxnr
dis_cra = 0
tot_cra = 0
dis_ba = 0
tot_ba = 0
help = 0
zeig=>pt%first
do
if(.not.associated(zeig)) exit
tot_cra = tot_cra + zeig%coh%crown_area*zeig%coh%ntreea
tot_ba = tot_ba + zeig%coh%ntreea*pi*zeig%coh%diam*zeig%coh%diam/4
if(zeig%coh%species.eq.2.and. zeig%coh%x_age.gt.50.and.zeig%coh%ntreea.ne.0) then
dis_cra = dis_cra + zeig%coh%crown_area*zeig%coh%ntreea
dis_ba = dis_ba + zeig%coh%ntreea*pi*zeig%coh%diam*zeig%coh%diam/4
end if
zeig=>zeig%next
end do
rel_cra = (tot_cra/dis_cra)* dis_rel_ip/100.
tar_cra = dis_cra * dis_rel_ip/100
tar_ba = dis_ba * dis_rel_ip/100
do while (help.lt.(tar_ba-0.01).and.help.lt.(dis_ba-0.01))
zeig=>pt%first
do
if(.not.associated(zeig)) exit
if(zeig%coh%species.eq.2.and. zeig%coh%x_age.gt.50.and. zeig%coh%ntreea.ne.0) then
zeig%coh%ntreea = zeig%coh%ntreea -1
zeig%coh%nta = zeig%coh%ntreea
zeig%coh%ntreem = zeig%coh%ntreem +1
help = help + pi*zeig%coh%diam*zeig%coh%diam/4
end if
if(help.ge.(dis_ba-0.01)) exit
if(help.ge.(tar_ba-0.01)) exit
zeig=>zeig%next
end do
end do
zeig=>pt%first
do
if(.not.associated(zeig)) exit
taxnr = zeig%coh%species
IF (taxnr.eq.2.and. zeig%coh%x_age.gt.50.and.zeig%coh%ntreem.ne.0) then
zeig%coh%litC_fol = zeig%coh%litC_fol + zeig%coh%ntreem*(1.-spar(taxnr)%psf)*zeig%coh%x_fol*cpart
zeig%coh%litN_fol = zeig%coh%litN_fol + zeig%coh%ntreem*((1.-spar(taxnr)%psf)*zeig%coh%x_fol*cpart)/spar(taxnr)%cnr_fol
zeig%coh%litC_frt = zeig%coh%litC_frt + zeig%coh%ntreem*zeig%coh%x_frt*cpart
zeig%coh%litN_frt = zeig%coh%litN_frt + zeig%coh%ntreem*zeig%coh%x_frt*cpart/spar(taxnr)%cnr_frt
zeig%coh%litC_crt = zeig%coh%litC_crt + zeig%coh%ntreem*zeig%coh%x_crt*cpart
zeig%coh%litN_crt = zeig%coh%litN_crt + zeig%coh%ntreem*zeig%coh%x_crt*cpart/spar(taxnr)%cnr_crt
hconvd = 1000. / kpatchsize
do i = 1,nspec_tree
! delayed litter fall from dead stems and twigs/branches
help = zeig%coh%ntreem*zeig%coh%x_tb*cpart*hconvd
helpN = zeig%coh%ntreem*zeig%coh%x_tb*cpart/spar(taxnr)%cnr_tbc*hconvd
help1 = zeig%coh%ntreem*(zeig%coh%x_sap+zeig%coh%x_hrt)*cpart*hconvd
help1N = zeig%coh%litC_stem/spar(taxnr)%cnr_stem*hconvd
do j = 1, lit_year
dead_wood(taxnr)%C_tb(j) = dead_wood(taxnr)%C_tb(j) + help/lit_year
dead_wood(taxnr)%N_tb(j) = dead_wood(taxnr)%N_tb(j) + helpN/lit_year
dead_wood(taxnr)%C_stem(j) = dead_wood(taxnr)%C_stem(j) + help1/lit_year
dead_wood(taxnr)%N_stem(j) = dead_wood(taxnr)%N_stem(j) + help1N/lit_year
enddo ! j (lit_year)
enddo ! i (nspec_tree)
end if
zeig=>zeig%next
end do
END SUBROUTINE beetle_nat
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! management of stands with bark beetle infestation
SUBROUTINE beetle_man(dis_rel_ip, rel_cra)
use data_manag
use data_simul
use data_species
use data_stand
use data_par
implicit none
real :: dis_cra, tot_cra, rel_cra, dis_rel_ip, tot_ba, dis_ba, tar_ba
real :: help
integer :: taxnr
dis_cra = 0
tot_cra = 0
help = 0
dis_ba = 0
tot_ba = 0
zeig=>pt%first
do
if(.not.associated(zeig)) exit
tot_cra = tot_cra + zeig%coh%crown_area*zeig%coh%ntreea
tot_ba = tot_ba + zeig%coh%ntreea*pi*zeig%coh%diam*zeig%coh%diam/4
if(zeig%coh%species.eq.2.and. zeig%coh%x_age.gt.50) then
dis_cra = dis_cra + zeig%coh%crown_area*zeig%coh%ntreea
dis_ba = dis_ba + zeig%coh%ntreea*pi*zeig%coh%diam*zeig%coh%diam/4
end if
zeig=>zeig%next
end do
rel_cra = (tot_cra/dis_cra)* dis_rel_ip/100.
tar_ba = dis_ba * dis_rel_ip/100.
do while (help.lt.tar_ba.and.help.ne.dis_ba)
zeig=>pt%first
do
if(.not.associated(zeig)) exit
if(zeig%coh%species.eq.2.and. zeig%coh%x_age.gt.50.and.zeig%coh%ntreea.ne.0) then
zeig%coh%ntreea = zeig%coh%ntreea -1
zeig%coh%nta = zeig%coh%ntreea
zeig%coh%ntreem = zeig%coh%ntreem +1
help = help + zeig%coh%crown_area
help = help + pi*zeig%coh%diam*zeig%coh%diam/4
if(help.eq.dis_ba) exit
if(help.gt. tar_ba) exit
end if
zeig=>zeig%next
end do
end do
zeig=>pt%first
do
if(.not.associated(zeig)) exit
taxnr = zeig%coh%species
IF (taxnr.eq.2.and. zeig%coh%x_age.gt.50.and.zeig%coh%ntreem.ne.0) then
! stems, twigs and branches are completely removed
zeig%coh%litC_fol = zeig%coh%litC_fol + zeig%coh%ntreem*(1.-spar(taxnr)%psf)*zeig%coh%x_fol*cpart
zeig%coh%litN_fol = zeig%coh%litN_fol + zeig%coh%ntreem*((1.-spar(taxnr)%psf)*zeig%coh%x_fol*cpart)/spar(taxnr)%cnr_fol
zeig%coh%litC_frt = zeig%coh%litC_frt + zeig%coh%ntreem*zeig%coh%x_frt*cpart
zeig%coh%litN_frt = zeig%coh%litN_frt + zeig%coh%ntreem*zeig%coh%x_frt*cpart/spar(taxnr)%cnr_frt
zeig%coh%litC_crt = zeig%coh%litC_crt + zeig%coh%ntreem*zeig%coh%x_crt*cpart
zeig%coh%litN_crt = zeig%coh%litN_crt + zeig%coh%ntreem*zeig%coh%x_crt*cpart/spar(taxnr)%cnr_crt
end if
zeig=>zeig%next
end do
END SUBROUTINE beetle_man
!##########################!
!! DEFOLIATOR DISTURBANCES !!
!##########################!
SUBROUTINE disturbance_defoliator
use data_manag
use data_soil_cn
use data_simul
use data_stand
use data_site
use data_species
use data_par
implicit none
real :: loss, remain, humusnew, humusneuin
character(50) :: helpout
helpout='disturbance_defoliator'
if (flag_standup .eq. 0) flag_standup = 1 ! call stand_balance later
humusnew=0.
remain=1.0
loss=dis_rel(dis_control(1,2))
if (loss .lt. 0.0) loss=0.0
if (loss .gt. 1.0) loss=1.0
remain=1.0-loss
if (remain .lt. 0.0) remain=0.0
if (remain .gt. 1.0) remain=1.0
if (loss .gt. 0.01) then
zeig=>pt%first
do
if(.not.associated(zeig)) exit
if (zeig%coh%species .le. nspec_tree) then
zeig%coh%x_fol_loss=zeig%coh%x_fol*loss
zeig%coh%x_fol=zeig%coh%x_fol*remain
endif
zeig=>zeig%next
end do
write(*,*)helpout
endif ! loss>0.01
END SUBROUTINE disturbance_defoliator
!#####################!
!! XYLEM DITURBANCES !!
!#####################!
SUBROUTINE disturbance_xylem
use data_manag
use data_simul
use data_stand
use data_site
use data_species
use data_par
use data_soil
implicit none
real :: loss, remain
character(50) :: helpout
if (flag_standup .eq. 0) flag_standup = 1 ! call stand_balance later
helpout='disturbance_xylem'
xylem_dis=1.0-dis_rel(dis_control(2,2))
if (xylem_dis .lt. 0.0) xylem_dis=0.0
if (xylem_dis .gt. 1.0) xylem_dis=1.0
write(*,*)helpout
END SUBROUTINE disturbance_xylem
!######################!
!! PHLOEM DITURBANCES !!
!######################!
SUBROUTINE disturbance_phloem
use data_manag
use data_simul
use data_stand
use data_site
use data_species
use data_par
implicit none
character(50) :: helpout
if (flag_standup .eq. 0) flag_standup = 1 ! call stand_balance later
helpout='disturbance_phloem'
phlo_feed=1.0-dis_rel(dis_control(3,2))
if (phlo_feed .lt. 0.0) phlo_feed=0.0
if (phlo_feed .gt. 1.0) phlo_feed=1.0
write(*,*)helpout
END SUBROUTINE disturbance_phloem
!####################!
!! ROOT DITURBANCES !!
!####################!
SUBROUTINE disturbance_root
use data_manag
use data_simul
use data_stand
use data_site
use data_species
use data_par
implicit none
real :: loss, remain
character(50) :: helpout
if (flag_standup .eq. 0) flag_standup = 1 ! call stand_balance later
remain=1.0
loss=dis_rel(dis_control(4,2))
if (loss .lt. 0.0) loss=0.0
if (loss .gt. 1.0) loss=1.0
remain=1.0-loss
if (remain .lt. 0.0) remain=0.0
if (remain .gt. 1.0) remain=1.0
helpout='disturbance_root'
zeig=>pt%first
do
if(.not.associated(zeig)) exit
if (zeig%coh%species .le. nspec_tree) then
zeig%coh%x_frt_loss=zeig%coh%x_frt*loss
zeig%coh%x_frt=zeig%coh%x_frt*remain
endif
zeig=>zeig%next
end do
write(*,*)helpout
END SUBROUTINE disturbance_root
!####################!
!! STEM DITURBANCES !!
!####################!
SUBROUTINE disturbance_stem
use data_manag
use data_simul
use data_stand
use data_site
use data_species
use data_par
implicit none
character(50) :: helpout
if (flag_standup .eq. 0) flag_standup = 1 ! call stand_balance later
helpout='disturbance_stem'
stem_rot=dis_rel(dis_control(5,2))
if (stem_rot .lt. 0.0) stem_rot=0.0
if (stem_rot .gt. 1.0) stem_rot=1.0
write(*,*)helpout
END SUBROUTINE disturbance_stem
!####################!
!! MISTLETOE INFECTION !!
!####################!
! mistletoe cohort is produced in prepstand.f
source_code/version_2.3_windows/evapo.f 0 → 100644
View file @ 82df1085
!*****************************************************************!
!* *!
!* 4C (FORESEE) Simulation Model *!
!* *!
!* *!
!* Subroutines for: *!
!* Soil and Water - Programs *!
!* *!
!* contains: *!
!* EVAPO calculation of potential evapotranspiration *!
!* EVAPO_INI initialisation of potential evapotranspiration *!
!* turc_ivanov *!
!* sunshine *!
!* *!
!* Copyright (C) 1996-2018 *!
!* Potsdam Institute for Climate Impact Reserach (PIK) *!
!* Authors and contributors see AUTHOR file *!
!* This file is part of 4C and is licensed under BSD-2-Clause *!
!* See LICENSE file or under: *!
!* http://www.https://opensource.org/licenses/BSD-2-Clause *!
!* Contact: *!
!* https://gitlab.pik-potsdam.de/foresee/4C *!
!* *!
!*****************************************************************!
SUBROUTINE evapo
! Potential evapotranspiration PET
use data_climate
use data_evapo
use data_inter
use data_par
use data_simul
use data_site
use data_stand
use data_soil
use data_species
implicit none
integer i
real atemp25, cf, hxx, redcof
real pet0, & ! PET Turc/Ivanov
pet1, & ! PET Priestley-Taylor
pet2, & ! PET Priestley-Taylor for each cohort
pet3, & ! PET Penman/Monteith
pet4, & ! PET Penman/Monteith for each cohort
pet5, & ! PET Haude
pev0_s, & ! soil evaporation from Turc/Ivanov
pev1_s, & ! soil evaporation from Priestley-Taylor
pev2_s, & ! soil evaporation from Priestley-Taylor for each cohort
h_klim, & ! height of reference station
gamma, & ! scheinbare Psychrometer-Konstante
svp, & ! saturated vapour pressure
vpd, & ! vapour pressure deficit
vpress, & ! vapour pressure
delta, & ! slope of vapour pressure curve against temperature
dens_air, & ! density of dry air (kg/m3) (like MONTEITH (1973))
alpha, & ! Priestley-Taylor coefficient
Rnet, & ! net radiation W/m2 of whole canopy
Rnet_s, & ! absorbed global radiation W/m2 of soil
Rnet_alb, & ! net radiation from radiation balance with intermediate calculation in J/m2
Rnet_alb1,& ! net radiation from radiation balance without reflected radiation in J/cm2
Rnet_tem, & ! net radiation from temperature and airpressure
Rnet_fed, & ! net radiation according to Federer (1968) and Feddes (1971)
Rrefl, & ! reflected long wave radiation
Srel, & ! relative sunshine duration
albedo, &
sigma, & ! Boltzmannsche constant
lamb, & ! latent heat of vaporization of water (W / (m2 mm) day value)
rc, & ! empir. plant base resistance (s/m)
v_conc, & ! concentration water vapour
hf, hln, hz, z0, tutrf, &
atmp_1
real Rnet1, Rnet2_sum, Rnet3, Rnet4_sum
real Rnet_mw, & ! net radiation (J/cm2) measured value
G_flux ! soil heat flux (J/cm2) measured value
character (10) text
real transd0, transd1, hx
! for PET according to Haude
real svp_13, vp_13, vpd_13, relhum_13, dptemph, hh
real dpta, dptb, dptc ! coefficients for calculation of dew point temperature
real, dimension(12) :: ft_haude=(/0.22,0.22,0.22,0.29,0.29,0.28,0.26,0.25,0.23,0.22,0.22,0.22/)
! read flux data
if (flag_eva .gt.10) read (unit_eva,*) text, Rnet_mw, G_flux
alpha = alpha_PT
atmp_1 = 1./(airtemp + 273.3)
svp = 6.1078 * exp(17.2694 * airtemp * atmp_1) ! saturated vapour pressure (MURRAY, 1967)
vpress = 0.01 * hum * svp
vpd = svp*(1. - hum*0.01) ! vapour pressure deficit
! dew point temperature (DVWK 1996, P. 83)
if(airtemp .lt. 0.) then
dpta = 272.2
dptb = 24.27
else
dpta = 243.12
dptb = 19.43
endif
dptc = 1.81
dptemp = dpta * (log(vpress)-dptc) / (dptb-log(vpress))
! relative Sonnenscheindauer
call sunshine(Srel, iday, lat, dlength, rad)
!! net radiation from radiation balance ( Rijtema, 1965)
! albedo = 0.35 ! adjustment to Rnet for spruce (Tharandt), beech (Hesse), pine (Loobos)
! albedo = 0.1 ! for pine from Lit.
!net radiation according to Federer (1968) and Feddes (1971)
Rnet_fed = 0.649 * (rad/8.64) - 23 ! rad: J/cm2 ==> W/m2
Rnet_fed = 8.64 * Rnet_fed ! W/m2 ==> J/cm2
Rnet_tot = Rnet_fed
Rnet = (Rnet_tot/8.64) ! J/cm2 ==> W/m2
if (((snow .gt. 0.) .or. lint_snow) .and. (airtemp .lt. 0.)) then
! snow or frost evaporation (DVWK S.73, 1996; Rachner, 1987)
albedo = 0.85
pev_sn = 0.41 * vpd - 0.22
if (pev_sn .lt. 0.) then
dew_rime = -pev_sn
pev_s = 0.1
else
pev_s = pev_sn
endif
if (Rnet_fed .lt. 0.) then
sigma = 5.67 * 10.**(-8) ! W / m2
Rrefl = sigma * (airtemp+273)**4 * (0.56 - 0.079*Sqrt(vpress))*(0.1 + 0.9*Srel) ! J/m2
Rnet_alb = (rad*10000.0 * (1.-albedo) - Rrefl) ! J/m2
Rnet_alb = Rnet_alb * 0.0001
Rnet_tot = Rnet_alb ! J/cm2
Rnet = (Rnet_tot/8.64) ! J/cm2 ==> W/m2
endif
pet = 0.
zeig => pt%first
do while (associated(zeig))
zeig%coh%demand = 0.
zeig => zeig%next
enddo ! zeig (cohorts)
else
if (Rnet_fed .lt. 0.) then
albedo = 0.2
sigma = 5.67 * 10.**(-8) ! W / m2
Rrefl = sigma * (airtemp+273)**4 * (0.56 - 0.079*Sqrt(vpress))*(0.1 + 0.9*Srel) ! J/m2
Rnet_alb = (rad*10000.0 * (1.-albedo) - Rrefl) ! J/m2
Rnet_alb = Rnet_alb * 0.0001
Rnet_tot = Rnet_alb ! J/cm2
Rnet = (Rnet_tot/8.64) ! J/cm2 ==> W/m2
endif
select case (flag_eva)
case (0,6,7)
call turc_ivanov
case (1,2,3,4,16,17,36,37)
! preparation Priestley/Taylor and Penman/Monteith calculation
gamma = psycro * press
delta = 239. * 17.4 * svp * atmp_1*atmp_1 ! slope of vapour pressure curve
lamb = (2.498 - 0.00242*airtemp) * 1E06 ! W s /(m2 mm) == J/mm / m2
lamb = lamb/86400. ! W / (m2 mm) Tageswert
if (anz_coh .le. 0) then
pet = alpha * Rnet * delta/((delta+gamma)*lamb) ! potential evapotranspiration of canopy
pev_s = 0.
else
if (all_leaves_on .eq. 0) then
pet = alpha * Rnet * delta/((delta+gamma)*lamb) ! potential evapotranspiration of canopy
! potential transpiration demand of each cohort
if (gp_can .gt. 1.E-6) then
hx = pet / gp_can
else
hx = 0.
endif
zeig => pt%first
do while (associated(zeig))
zeig%coh%demand = zeig%coh%gp * zeig%coh%ntreea * hx
if (zeig%coh%species.eq.nspec_tree+2) then !save demand of mistletoe calculated cohort-specific for later use in upt_wat (soil.f)
demand_mistletoe_cohort=zeig%coh%gp * zeig%coh%ntreea * hx
end if
zeig => zeig%next
enddo ! zeig (cohorts)
! soil evaporation
redcof = 0.4
Rnet_s = (Rnet_tot/8.64) * redcof ! J/cm2 ==> W/m2
else
Rnet = (Rnet_tot/8.64) * totFPARsum ! J/cm2 ==> W/m2
Rnet_s = (Rnet_tot/8.64) * (1.-totFPARsum) ! J/cm2 ==> W/m2
select case (flag_eva)
case (1) ! Priestley / Taylor
pet = alpha * Rnet * delta/((delta+gamma)*lamb) ! potential evapotranspiration of canopy
case (2) ! Priestley / Taylor for each cohort
pet2 = 0.
Rnet2_sum = 0
zeig => pt%first
do while (associated(zeig))
if (zeig%coh%gp .gt. 0.) then
Rnet = (Rnet_tot/8.64) * zeig%coh%totFPAR * zeig%coh%nTreeA ! J/cm2 ==> W/m2
Rnet2_sum = Rnet2_sum + Rnet
zeig%coh%demand = alpha * Rnet * delta/((delta+gamma)*lamb) ! potential evapotranspiration of cohort
if (zeig%coh%species.eq.nspec_tree+2) then !save demand of mistletoe calculated cohort-specific for later use in upt_wat (soil.f)
demand_mistletoe_cohort=alpha * Rnet * delta/((delta+gamma)*lamb)
end if
else
zeig%coh%demand = 0.
endif
pet2 = pet2 + zeig%coh%demand
zeig => zeig%next
enddo ! zeig (cohorts)
pet = pet2
case(3,36,37) ! Penman/Monteith
h_klim = 200. ! Hoehe Messstation (cm)
dens_air = 1.2917 - 0.00434*airtemp ! density of dry air (kg/m3) (like MONTEITH (1973))
dens_air = dens_air*0.001 ! kg/m3 --> g/cm3
hf = dens_air * c_karman*c_karman * wind
if (hdom .ge. 0.5) then
hz = hdom
else
hz = 0.5
endif
z0 = 10.**(0.997*alog10(hz)-0.883)
hln = alog(h_klim/z0)
tutrf = hf*rmolw / (hln*hln*press)
! canopy conductance verwenden:
v_conc = (press*100.) / (R_gas * (273.15 + airtemp)) ! pressure in hPa --> Pa
if (gp_can .gt. 1E-8) then
rc = gp_can / (8980.0 * v_conc) ! gp_can mol/m2*d --> m/s
rc = 1. / rc
Rnet = (Rnet_tot/8.64) * totFPARsum ! J/cm2/d ==> W/m2
Rnet3 = Rnet
pet3 = (delta*Rnet + vpd*hf*c_air/(hln*hln)) / &
((delta+gamma*(1+rc*tutrf))*lamb)
pet = pet3
else
call turc_ivanov
endif ! gp_can
case(4) ! Penman/Monteith for each cohort
pet4 = 0.
Rnet4_sum = 0
h_klim = 200. ! hight of measurement station (cm)
dens_air = 1.2917 - 0.00434*airtemp ! density of dry air (kg/m3) (like MONTEITH (1973))
dens_air = dens_air*0.001 ! kg/m3 --> g/cm3
hf = dens_air * c_karman*c_karman * wind
v_conc = (press*100.) / (R_gas * (273.15 + airtemp)) ! pressure hPa --> Pa
zeig => pt%first
do while (associated(zeig))
if (zeig%coh%gp .gt. 0.) then
if (zeig%coh%height .ge. 0.5) then
hz = zeig%coh%height
else
hz = 0.5
endif
z0 = 10.**(0.997*alog10(hz)-0.883)
hln = alog(h_klim/z0)
if( hln.ne.0) then
tutrf = hf*rmolw / (hln*hln*press)
! canopy conductance verwenden:
rc = zeig%coh%gp / (8980.0 * v_conc) ! gp_can mol/m2*d --> m/s
rc = 1. / rc
Rnet = (Rnet_tot/8.64) * zeig%coh%totFPAR * zeig%coh%nTreeA ! J/cm2 ==> W/m2
Rnet4_sum = Rnet4_sum + Rnet ! zum Test
zeig%coh%demand = (delta*Rnet + vpd*hf*c_air/(hln*hln)) / & ! potential evapotranspiration of cohort
((delta+gamma*(1+rc*tutrf))*lamb)
!save demand of mistletoe calculated cohort-specific for later use in upt_wat (soil.f)
if (zeig%coh%species.eq.nspec_tree+2) then
if (zeig%coh%demand.lt.0) zeig%coh%demand=0 ! avoid further calculations with neg. demands
demand_mistletoe_cohort=zeig%coh%demand
endif
endif
else
zeig%coh%demand = 0.
endif ! ...coh%gp
pet4 = pet4 + zeig%coh%demand
zeig => zeig%next
enddo ! zeig (cohorts)
pet = pet4
end select ! flag_eva (inner cycle)
endif ! all_leaves_on
! soil evaporation
pev_s = alpha * Rnet_s * delta/((delta+gamma)*lamb) ! potential soil evaporation
endif ! anz_coh
case (5) ! PET Haude
if(airtemp_min .gt. -90.) then
dptemph = airtemp_min - 4. ! dew point temperature
vp_13 = 6.1078 * exp(17.62 * dptemph / (243.12+dptemp)) ! estimated actual vapour pressure at 13.00 (DVWK)
svp_13 = 6.1078 * exp(17.62 * airtemp_max / (243.12+airtemp_max)) ! saturated vapour pressure at 13.00 (DVWK)
vpd_13 = svp_13 - vp_13 ! vapour pressure deficit at 13.00
relhum_13 = 100. * vp_13 / svp_13
hh = ft_haude(monat)
pet5 = hh* vpd_13
! without limit, because otherwise class5 wont be reached (maxwert = -35!)
! limit according to DVWK annotation (Merkblatt) is 7 mm
pev_s = pet5 * exp(-0.6*LAI) ! nach Belmans, Dekker & Bouma, 1982
pet = pet5 - pev_s
else
print *, ' >>>foresee message: Program aborted'
print *, ' >>> Minimum air temperature required but not available'
Stop
endif
end select ! flag_eva (aeusserer Zyklus)
endif ! snow
! Gesamt-PET als Summe PET-Bestand und Boden-Evaporation
pet = pet + pev_s
hx = alfm * (1. - exp(-gp_can/gpmax))
! climatic water balance of the last five days
do i= 1,4
clim_waterb(i) = clim_waterb(i+1)
enddo
clim_waterb(5) = prec - pet
pet_cum = pet_cum + pet
Rnet_cum = rnet_cum + rnet_tot
END subroutine evapo
!******************************************************************************
SUBROUTINE turc_ivanov
use data_climate
use data_evapo
use data_stand
implicit none
real atemp25, cf, hxx, pet0
! calculation after DYCK/PESCHKE, 1995, S.200
if (airtemp .gt. 5.) then
if (hum .lt. 50.) then
cf = 1. + (50. - hum) / 70.
else
cf = 1.
endif ! hum
pet0 = 0.0031 * cf * (rad+209.) * airtemp/(airtemp+15.) ! from TURC
else
atemp25 = (airtemp + 25.)
pet0 = 3.6 * 10.**(-5) * (100 - hum) * atemp25 * atemp25 ! from IVANOV (daily)
endif ! airtemp
pev_s = pet0 * exp(-0.6*LAI) ! Belmans, Dekker & Bouma, 1982
pet = pet0 - pev_s
END subroutine turc_ivanov
!******************************************************************************
SUBROUTINE sunshine (sdrel, iday, xxlat, dayl, rad)
! Estimation of sunshine duration from global radiation
! (calculation after Angstrom)
!use data_site
implicit none
! input:
integer :: iday ! actual day
real :: dayl ! daylength
real :: rad ! global radiation (J/cm2)
real :: xxlat ! latitude
! output:
real :: sdrel !, sdrel1 ! sunshine duration (h)
! internal variables
real :: rad_ex , & ! extraterrestrical radiation (MJ/m2)
dec , & ! declination of sun angle
sinld, cosld, tanld, dsinb, dsinbe, &
sc, radi, seas
real :: pi = 3.141592654
real :: solc = 1367. ! solar constant (J/(m2*s)
! according to P. Hupfer: "Klimasystem der Erde", 1991
if (rad .lt. 1.E-6) then
sdrel=0
return
end if
! change of units from degree to radians
radi = pi/180.
! term of seasonality (10 days in front of calendar)
seas = (iday+10.)/365.
! declination of sun angle
! (Spitters et al. 1986, equations transformed for use or radians)
dec = -asin(sin(23.45*radi)*cos(2.*pi*seas))
! some intermediate values
sinld = sin(xxlat*radi)*sin(dec)
cosld = cos(xxlat*radi)*cos(dec)
tanld = amax1(-1., amin1(1., sinld/cosld))
! integral of sun elevation
dsinb = 3600.*(dayl*sinld+24.*cosld*sqrt(1.-tanld*tanld)/pi)
! corrected integral of sun elevation
dsinbe = 3600.*(dayl*(sinld+0.4*(sinld*sinld+cosld*cosld*0.5)) &
+12.*cosld*(2.+3.*0.4*sinld)*sqrt(1.-tanld*tanld)/pi)
! intensity of radiation outside the atmosphere
sc = solc/(1.-0.016729*cos((360./365.)*(iday-4.)*radi))**2.
rad_ex = sc*(1.+0.033*cos(2.*pi*iday/365.))*dsinbe
! unit conversion in MJ/m2: rad_ex = rad_ex/1000000.
! unit conversion in J/cm2
rad_ex = rad_ex * 0.0001
if(rad_ex.eq.0) then
sdrel=0.
return
end if
sdrel = (rad - rad_ex*0.19) / (0.55*rad_ex) ! DVWK
if (sdrel .lt. 0.) sdrel = 0.
END SUBROUTINE sunshine
!****************************************************************************
SUBROUTINE evapo_ini
! Initialisierung Potential evapotranspiration PET
use data_evapo
use data_simul
implicit none
character text
character (150) file_eva
write (*,*)
write (*,'(A)', advance='no') 'Read flux data for evaporation, name of input file: '
read (*,'(A)') file_eva
unit_eva = getunit()
open (unit_eva, file=trim(file_eva), status='unknown')
read (unit_eva,'(A)') text
END subroutine evapo_ini
!******************************************************************************
source_code/version_2.3_windows/filesave.f90 0 → 100644
View file @ 82df1085
!*****************************************************************!
!* *!
!* 4C (FORESEE) Simulation Model *!
!* *!
!* *!
!* Subroutines for: *!
!* - windows shell - *!
!* *!
!* contains: *!
!* FileSave *!
!* Copyright (C) 1996-2018 *!
!* Potsdam Institute for Climate Impact Reserach (PIK) *!
!* Authors and contributors see AUTHOR file *!
!* This file is part of 4C and is licensed under BSD-2-Clause *!
!* See LICENSE file or under: *!
!* http://www.https://opensource.org/licenses/BSD-2-Clause *!
!* Contact: *!
!* https://gitlab.pik-potsdam.de/XXXXXXXXXXXXXXXXXXXXX *!
!* *!
!*****************************************************************!
Subroutine FileSave (file_spec, filter_spec)
! Following example of calling the Win32 API routine GetOpenFileName
use comdlg32
!use dflib ! In case QuickWin is used
implicit none
! Declare structure used to pass and receive attributes
!
type(T_OPENFILENAME) ofn
! Declare filter specification. This is a concatenation of
! pairs of null-terminated strings. The first string in each pair
! is the file type name, the second is a semicolon-separated list
! of file types for the given name. The list ends with a trailing
! null-terminated empty string.
!
character*(*) :: filter_spec
! Declare string variable to return the file specification.
! Initialize with an initial filespec, if any - null string
! otherwise
!
!character*512 :: file_spec = ""C
character*512 :: file_spec
integer status,ilen
ofn%lStructSize = SIZEOF(ofn)
ofn%hwndOwner = NULL ! For non-console applications,
! set this to the Hwnd of the
! Owner window. For QuickWin
! and Standard Graphics projects,
! use GETHWNDQQ(QWIN$FRAMEWINDOW)
!
ofn%hInstance = NULL ! For Win32 applications, you
! can set this to the appropriate
! hInstance
!
ofn%lpstrFilter = loc(filter_spec)
ofn%lpstrCustomFilter = NULL
ofn%nMaxCustFilter = 0
ofn%nFilterIndex = 1 ! Specifies initial filter value
ofn%lpstrFile = loc(file_spec)
ofn%nMaxFile = sizeof(file_spec)
ofn%nMaxFileTitle = 0
ofn%lpstrInitialDir = NULL ! Use Windows default directory
ofn%lpstrTitle = loc(""C)
ofn%Flags = OFN_PATHMUSTEXIST
ofn%lpstrDefExt = loc("txt"C)
ofn%lpfnHook = NULL
ofn%lpTemplateName = NULL
! Call GetOpenFileName and check status
!
status = GetSaveFileName(ofn)
if (status .eq. 0) then
type *,'No file name specified'
else
! Get length of file_spec by looking for trailing NUL
ilen = INDEX(file_spec,CHAR(0))
end if
end Subroutine FileSave
source_code/version_2.3_windows/finisim.f 0 → 100644
View file @ 82df1085
!*****************************************************************!
!* *!
!* 4C (FORESEE) Simulation Model *!
!* *!
!* *!
!* Subroutines for: *!
!* finishing simulation *!
!* *!
!* contains *!
!* FINISH_SIMUL: deallocation of variables, *!
!* closing files for each simulation *!
!* FINISH_ALL : Finish all processes after all simulations *!
!* DEALLOC_SOIL: deallocation of soil variables *!
!* (also used in other routines) *!
!* *!
!* Copyright (C) 1996-2018 *!
!* Potsdam Institute for Climate Impact Reserach (PIK) *!
!* Authors and contributors see AUTHOR file *!
!* This file is part of 4C and is licensed under BSD-2-Clause *!
!* See LICENSE file or under: *!
!* http://www.https://opensource.org/licenses/BSD-2-Clause *!
!* Contact: *!
!* https://gitlab.pik-potsdam.de/foresee/4C *!
!* *!
!*****************************************************************!
SUBROUTINE finish_simul
use data_climate
use data_depo
!use data_effect
use data_evapo
use data_init
use data_manag
use data_out
use data_simul
use data_soil
use data_soil_cn
use data_species
use data_stand
use data_site
use data_tsort
use data_frost
! test lambda_ts
use data_par
implicit none
integer i ,unitout
character(150) :: filename, infile
REAL :: rsap, cform
CHARACTER :: source
rsap = 0.
cform=0.
source='U'
infile='planting'
if(time_out.gt.0) then
if (flag_dis .eq. 2) then
! output of new tree.ini at the end of the simulation
! hier neue version rausschreiben zum einlesen in 4C mit NSC Speicher
! x_nsc_tb x_nsc_crt x_nsc_sap als kg C per tree
unitout=getunit()
! filename = trim(site_name(site_nr))//'_tree.ini'//trim(anh)
filename = trim(site_name(ip))//'_tree.ini'//trim(anh)
open(unitout,file=trim(dirout)//filename,status='replace')
write(unitout,'(A1,2X,I1,1F12.0,A55)')'C', flag_volfunc, kpatchsize,' ! = ini version flag_dis, volume function, patch size'
write(unitout,'(A)')'! x_fol x_frt x_sap x_hrt x_Ahb height x_hbole x_age n sp DC DBH &
& x_nsc_tb x_nsc_crt x_nsc_sap'
zeig => pt%first
do while (associated(zeig))
write(unitout,'(5f12.5,2f10.0,i7,f7.0,i7, 5f12.5)') zeig%coh%x_fol, zeig%coh%x_frt, zeig%coh%x_sap, zeig%coh%x_hrt, &
zeig%coh%x_Ahb, zeig%coh%height, zeig%coh%x_hbole, zeig%coh%x_age, zeig%coh%ntreea, &
zeig%coh%species, zeig%coh%dcrb, zeig%coh%diam, zeig%coh%x_nsc_tb, zeig%coh%x_nsc_crt, zeig%coh%x_nsc_sap
zeig => zeig%next
end do
close(unitout)
else
! output of new tree.ini at the end of the simulation
unitout=getunit()
filename = trim(site_name(ip))//'_tree.ini'//trim(anh)
open(unitout,file=trim(dirout)//filename,status='replace')
write(unitout,'(I1,1F12.0,A32)')flag_volfunc,kpatchsize,' ! = volume function, patch size'
write(unitout,'(A)')'! x_fol x_frt x_sap x_hrt x_Ahb height x_hbole x_age n sp DC DBH'
zeig => pt%first
do while (associated(zeig))
write(unitout,'(5f12.5,2f10.0,i7,f7.0,i7, 2f12.5)') zeig%coh%x_fol, zeig%coh%x_frt, zeig%coh%x_sap, zeig%coh%x_hrt, &
zeig%coh%x_Ahb, zeig%coh%height, zeig%coh%x_hbole, zeig%coh%x_age, zeig%coh%ntreea, &
zeig%coh%species, zeig%coh%dcrb, zeig%coh%diam
zeig => zeig%next
end do
close(unitout)
endif
! output of new .lit-file at the end of the simulation
if (flag_end .eq. 0) then
unitout=getunit()
filename = trim(site_name(ip))//'.lit'//trim(anh)
open(unitout,file=trim(dirout)//filename,status='replace')
write(unitout,'(A,A)')'! litter initialisation ', site_name(ip)
write(unitout,'(A)')'! fraction Fagus sylvatica Picea abies Pinus sylvestris Quercus robur Betula pendula Pinus contorta Pinus ponderosa Populus tremula ground cover'
write(unitout,'(A12, 9F18.1)') ' C_opm_fol ', (slit(i)%C_opm_fol, i=1,nspecies)
write(unitout,'(A12, 9F18.1)') ' C_opm_tb ', (slit(i)%C_opm_tb, i=1,nspecies)
write(unitout,'(A12, 9F18.1)') ' C_opm_frt ', (slit(i)%C_opm_frt(1), i=1,nspecies)
write(unitout,'(A12, 9F18.1)') ' C_opm_crt ', (slit(i)%C_opm_crt(1), i=1,nspecies)
write(unitout,'(A12, 9F18.1)') ' C_opm_stem ', (slit(i)%C_opm_stem,i=1,nspecies)
close(unitout)
endif
end if ! time_out
! deallocate cohorts
if(flag_end.ne.1 .and. associated(pt%first)) then
zeig => pt%first
do while (associated(zeig))
pt%first => zeig%next
deallocate (zeig%coh%frtrel)
deallocate(zeig%coh%frtrelc)
deallocate (zeig%coh%rooteff)
if (flag_wred .eq. 9) deallocate (zeig%coh%rld)
deallocate(zeig)
zeig => pt%first
end do
end if
if(associated(pt%first)) deallocate (pt%first)
if (flag_eva .gt.10) close (unit_eva)
if (allocated(dayfract))deallocate(dayfract)
! fields for frost index
if(allocated(dnlf)) deallocate(dnlf)
if(allocated(tminmay_ann))deallocate(tminmay_ann)
if(allocated(date_lf)) deallocate(date_lf)
if(allocated(date_lftot)) deallocate(date_lftot)
if(allocated(dnlf_sp)) deallocate(dnlf_sp)
if(allocated(anzdlf)) deallocate(anzdlf)
if (allocated(sumtlf)) deallocate(sumtlf)
if (flag_clim==1) then
if (allocated(recs))deallocate(recs)
if (allocated(dd))deallocate(dd)
if (allocated(mm))deallocate(mm);
if (allocated(yy))deallocate(yy)
if (allocated(tp))deallocate(tp);
if (allocated(hm))deallocate(hm)
if (allocated(prc))deallocate(prc);
if (allocated(prs))deallocate(prs)
if (allocated(rd))deallocate(rd)
if (allocated(wd))deallocate(wd)
if (allocated(tx))deallocate(tx)
if (allocated(tn))deallocate(tn)
if (allocated(vp))deallocate(vp)
if (allocated(sdu))deallocate(sdu)
if (allocated(sde))deallocate(sde)
if (allocated(bw))deallocate(bw)
if (allocated(tempfield))deallocate(tempfield)
if (allocated(globfield))deallocate(globfield)
if (allocated(dayfield))deallocate(dayfield)
endif
if (.not.flag_mult910) then
if (allocated(NHd))deallocate(NHd)
if (allocated(NOd))deallocate(NOd)
endif
if (allocated(diam_class))deallocate(diam_class)
if (allocated(diam_class_t))deallocate(diam_class_t)
if (allocated(diam_class_h))deallocate(diam_class_h)
if (allocated(diam_class_age))deallocate(diam_class_age)
if (allocated(diam_class_mvol))deallocate(diam_class_mvol)
if (allocated(diam_classm))deallocate(diam_classm)
if (allocated(diam_classm_h))deallocate(diam_classm_h)
if (allocated(height_class))deallocate(height_class)
if (allocated(ngroups))deallocate(ngroups)
if (allocated(dead_wood)) then
do i = 1, nspec_tree
deallocate(dead_wood(i)%C_tb)
deallocate(dead_wood(i)%N_tb)
deallocate(dead_wood(i)%C_stem)
deallocate(dead_wood(i)%N_stem)
enddo
deallocate(dead_wood)
endif
svar%sumvsdead = 0.
svar%sumvsdead_m3 = 0.
svar%daybb = 0.
if (flag_multi .eq. 1 .or. flag_multi .eq. 6 .or. flag_multi .eq. 0) then
if(allocated(spar)) deallocate(spar)
if(allocated(nrspec)) deallocate(nrspec)
! clear subfields for stress variables of svar
if (flag_wurz .eq. 4 .or. flag_wurz .eq. 6) then
do i=1,nspecies
deallocate(svar(i)%tstress)
deallocate(svar(i)%sstr)
deallocate(svar(i)%BDstr)
deallocate(svar(i)%BDmax)
deallocate(svar(i)%porcrit)
deallocate(svar(i)%airstr)
deallocate(svar(i)%phstr)
deallocate(svar(i)%Rstress)
deallocate(svar(i)%Smean)
enddo
endif
if(allocated(svar)) deallocate(svar)
endif
if(flag_multi .eq. 4 .or. flag_mult8910) then
do i=1,nspecies
svar(i)%RedN = -99.9
enddo
end if
call dealloc_soil ! soil-files immer deallok.
do i = 1,outy_n
if (outy(i)%out_flag .ne. 0) then
close (outy(i)%unit_nr)
endif
enddo
do i = 1,outd_n
if (outd(i)%out_flag .ne. 0) then
close (outd(i)%unit_nr)
endif
enddo
C_bc_tot = 0.
N_bc_tot = 0.
if (flag_bc .gt. 0) then
deallocate(C_bc)
deallocate(N_bc)
deallocate (C_bc_appl)
deallocate (N_bc_appl)
deallocate (bc_appl_lay)
deallocate (cnv_bc)
deallocate (dens_bc)
deallocate (cpart_bc)
deallocate (y_bc)
flag_decomp = flag_decomp + 100 ! flag_decomp zurcksetzen
endif
if (flag_cohout .ge. 1) then
do i = 1,outcy_n
if (outcy(i)%out_flag .ne. 0) then
close (outcy(i)%unit_nr)
endif
enddo
endif
if (flag_dayout .ge. 1) then
do i = 1,outcd_n
if (outcd(i)%out_flag .ne. 0) then
close (outcd(i)%unit_nr)
endif
enddo
endif
if(time_out .gt. 0) then
if (out_flag_light .ne. 0) close(unit_light)
if (flag_cohout .eq. 2) then
close(unit_prod)
close(unit_allo)
endif
end if
if (flag_dayout .gt. 1) then
close(unit_wat)
close(unit_soicnd);close(unit_soicna)
endif
if (.not.flag_mult910) close (unit_soil)
if (flag_sum > 0) close(unit_sum)
if (flag_mg==1) then
deallocate(thin_year);deallocate(thin_tree)
endif
if (flag_mg==3.or. flag_mg==33) then
if (allocated(thin_year)) deallocate(thin_year)
if( allocated(target_mass)) deallocate(target_mass)
if (allocated(thin_tysp))deallocate(thin_tysp)
if (allocated(thin_spec))deallocate(thin_spec)
if (allocated(rot))deallocate(rot)
if (allocated(thin_flag1))deallocate(thin_flag1)
if (allocated(thinyear))deallocate(thinyear)
if (allocated(thin_stor))deallocate(thin_stor)
endif
if (flag_mg==2.and. flag_end==0) then
if (allocated(zbnr))deallocate(zbnr)
if (allocated(tend))deallocate(tend)
if (allocated(rot))deallocate(rot)
if (allocated(regage))deallocate(regage)
if (allocated(thin_flag1))deallocate(thin_flag1)
if (allocated(thin_flag2))deallocate(thin_flag2)
if (allocated(thin_flag3))deallocate(thin_flag3)
if (allocated(thin_flag4))deallocate(thin_flag4)
if (allocated(np_mod))deallocate(np_mod)
if (allocated(specnr))deallocate(specnr)
if (allocated(age_spec))deallocate(age_spec)
if (allocated(anz_tree_spec))deallocate (anz_tree_spec)
if (allocated(thinyear))deallocate(thinyear)
end if
if (flag_mg==4. .or. flag_mg == 5) then
if (allocated(thin_flag1)) deallocate(thin_flag1)
end if
if(flag_mg == 10) then
if (allocated(thin_flag1))deallocate(thin_flag1)
if (allocated(dis_id))deallocate(dis_id)
if (allocated(dis_type))deallocate(dis_type)
if (allocated(fortype))deallocate(fortype)
if (allocated(dis_year))deallocate(dis_year)
if (allocated(dis_rel))deallocate(dis_rel)
if (allocated(sum_dis))deallocate(sum_dis)
end if
if(flag_dis == 1 .or. flag_dis == 2) then
if (allocated(dis_year))deallocate(dis_year)
if (allocated(dis_spec))deallocate(dis_spec)
if (allocated(dis_start))deallocate(dis_start)
if (allocated(dis_rel))deallocate(dis_rel)
if (allocated(dis_type))deallocate(dis_type)
end if
if(flag_mg == 9) then
if (allocated(thin_flag1))deallocate(thin_flag1)
if (allocated(yman))deallocate(yman)
if (allocated(dbh_clm))deallocate(dbh_clm)
if (allocated(rem_clm))deallocate(rem_clm)
if (allocated(spec_man))deallocate(spec_man)
if (allocated(act))deallocate(act)
if (allocated(rel_part))deallocate(rel_part)
end if
if(flag_mg == 8) then
if (allocated(thin_flag1))deallocate(thin_flag1)
if (allocated(yman))deallocate(yman)
if (allocated(rel_part))deallocate(rel_part)
end if
if(flag_wpm.ne.0) then
! free the resources
call deallocate_wpm
IF ( associated(st%first)) then
ztim => st%first
do while (associated(ztim))
st%first => ztim%next
deallocate(ztim)
ztim => st%first
end do
endif
IF ( associated(st%first)) deallocate(st%first)
if ( associated(ztim)) deallocate(ztim)
end if
! test lambda_ts
if (flag_lambda.eq.1) then
deallocate (lambda_ts)
end if
! compressed output for each simulation run
lcomp1 = .TRUE.
end subroutine finish_simul
!-----------------------------------------
SUBROUTINE finish_all
use data_simul
use data_climate
use data_depo
use data_mess
use data_out
use data_site
use data_soil
use data_soil_cn
use data_species
use data_stand
if (allocated(site_name))deallocate(site_name)
if (allocated(climfile))deallocate(climfile);
if (allocated(sitefile))deallocate(sitefile)
if (allocated(valfile))deallocate(valfile)
if (allocated(treefile))deallocate(treefile)
if (allocated(wpmfile))deallocate(wpmfile)
if (allocated(depofile))deallocate(depofile)
if (allocated(redfile))deallocate(redfile)
if (allocated(litfile))deallocate(litfile)
if (allocated(standid))deallocate(standid)
IF(ALLOCATED(thick)) CALL dealloc_soil
if(flag_multi .eq. 1 .or. flag_multi .ge. 3) then
if ( allocated(sitenum))deallocate(sitenum)
if ( allocated(clim_id))deallocate(clim_id)
if ( allocated(soilid))deallocate(soilid)
if ( allocated(gwtable))deallocate(gwtable)
if ( allocated(NOdep))deallocate(NOdep)
if ( allocated(NHdep))deallocate(NHdep)
endif
if(allocated(diam_class)) deallocate(diam_class)
if(allocated(diam_class_t)) deallocate(diam_class_t)
if(allocated(diam_class_h)) deallocate(diam_class_h)
if(allocated(diam_classm)) deallocate(diam_classm)
if(allocated(diam_classm_h)) deallocate(diam_classm_h)
if(allocated(height_class)) deallocate(height_class)
if (allocated(NHd))deallocate(NHd)
if (allocated(NOd))deallocate(NOd)
if(allocated(recs))then
deallocate(recs)
deallocate(dd);deallocate(mm);deallocate(yy)
deallocate(tp);deallocate(hm);deallocate(prc);deallocate(prs)
deallocate(rd)
if (allocated(tempfield))deallocate(tempfield)
if (allocated(globfield))deallocate(globfield)
if (allocated(dayfield))deallocate(dayfield)
endif
if(time_out .ne. -2) then
close(unit_comp1)
close(unit_comp2)
endif
if (flag_stat .gt. 0) then
close(unit_cons)
close(unit_mess)
close(unit_stat)
endif
if (flag_multi .gt.8) close (output_unit_all)
if (flag_multi .eq. 2) close(unit_ctr)
if(flag_multi.eq.7) deallocate(fl_co2)
if(flag_multi .eq. 4 .or. flag_mult8910) then
if (allocated(output_var))deallocate(output_var)
if (allocated(output_varm))deallocate(output_varm)
if (allocated(output_varw))deallocate(output_varw)
if (allocated(climszenres))deallocate(climszenres)
if (allocated(climszenyear))deallocate(climszenyear)
if (allocated(climszenmon))deallocate(climszenmon)
if (allocated(climszenweek))deallocate(climszenweek)
endif
if ((ip .eq. 1 .or. flag_multi .eq. 1 .or. flag_multi .eq. 6) .and. (time_out .ne. -2) ) close(unit_err)
end subroutine finish_all
!-----------------------------------------
SUBROUTINE dealloc_soil
use data_soil
use data_soil_cn
use data_soil_t
use data_simul
implicit none
if (allocated(thick)) deallocate(thick)
if (allocated(mid)) deallocate(mid)
if (allocated(depth)) deallocate(depth)
if (allocated(pv)) deallocate(pv)
if (allocated(pv_v)) deallocate(pv_v)
if (allocated(dens)) deallocate(dens)
if (allocated(f_cap_v)) deallocate(f_cap_v)
if (allocated(wilt_p_v)) deallocate(wilt_p_v)
if (allocated(field_cap)) deallocate(field_cap)
if (allocated(wilt_p)) deallocate(wilt_p)
if (allocated(vol)) deallocate(vol)
if (allocated(quarzv)) deallocate(quarzv)
if (allocated(sandv)) deallocate(sandv)
if (allocated(clayv)) deallocate(clayv)
if (allocated(siltv)) deallocate(siltv)
if (allocated(humusv)) deallocate(humusv)
if (allocated(dmass)) deallocate(dmass)
if (allocated(fcaph)) deallocate(fcaph)
if (allocated(wiltph)) deallocate(wiltph)
if (allocated(pvh)) deallocate(pvh)
if (allocated(skelv)) deallocate(skelv)
if (allocated(skelfact)) deallocate(skelfact)
if (allocated(spheat)) deallocate(spheat)
if (allocated(phv)) deallocate(phv)
if (allocated(wlam)) deallocate(wlam)
if (allocated(wats)) deallocate(wats)
if (allocated(watvol)) deallocate(watvol)
if (allocated(wat_res)) deallocate(wat_res)
if (allocated(perc)) deallocate(perc)
if (allocated(wupt_r)) deallocate(wupt_r)
if (allocated(wupt_ev)) deallocate(wupt_ev)
if (allocated(s_drought)) deallocate(s_drought)
if (allocated(root_fr)) deallocate(root_fr)
if (allocated(temps)) deallocate(temps)
if (allocated(BDopt)) deallocate(BDopt)
if (allocated(fr_loss)) deallocate(fr_loss)
if (allocated(redis)) deallocate(redis)
if (allocated(C_opm)) deallocate(C_opm)
if (allocated(C_hum)) deallocate(C_hum)
if (allocated(C_opmfrt)) deallocate(C_opmfrt)
if (allocated(C_opmcrt)) deallocate(C_opmcrt)
if (allocated(N_opm)) deallocate(N_opm)
if (allocated(N_hum)) deallocate(N_hum)
if (allocated(N_opmfrt)) deallocate(N_opmfrt)
if (allocated(N_opmcrt)) deallocate(N_opmcrt)
if (allocated(NH4)) deallocate(NH4)
if (allocated(NO3)) deallocate(NO3)
if (allocated(Nupt)) deallocate(Nupt)
if (allocated(Nmin)) deallocate(Nmin)
if (allocated(rmin_phv)) deallocate(rmin_phv)
if (allocated(rnit_phv)) deallocate(rnit_phv)
if (allocated(cnv_opm)) deallocate(cnv_opm)
if (allocated(cnv_hum)) deallocate(cnv_hum)
if (allocated(slit)) deallocate(slit)
if (allocated(slit_1)) deallocate(slit_1)
if (allocated(sh)) deallocate(sh)
if (allocated(sv)) deallocate(sv)
if (allocated(sb)) deallocate(sb)
if (allocated(sbt)) deallocate(sbt)
if (allocated(t_cond)) deallocate(t_cond)
if (allocated(t_cb)) deallocate(t_cb)
if (allocated(h_cap)) deallocate(h_cap)
if (allocated(sxx)) deallocate(sxx)
if (allocated(svv)) deallocate(svv)
if (allocated(svva)) deallocate(svva)
if (allocated(soh)) deallocate(soh)
if (allocated(son)) deallocate(son)
if (allocated(wat_root)) deallocate(wat_root)
if (allocated(root_lay)) deallocate(root_lay)
if (allocated(gr_depth)) deallocate(gr_depth)
if (allocated(xwatupt)) deallocate (xwatupt)
if (allocated(xNupt)) deallocate (xNupt)
if (allocated(wat_left)) deallocate (wat_left)
end subroutine dealloc_soil
!-----------------------------------------------------------------
source_code/version_2.3_windows/gasdev.f 0 → 100644
View file @ 82df1085
!*****************************************************************!
!* *!
!* 4C (FORESEE) Simulation Model *!
!* *!
!* *!
!* Subroutines for: *!
!* *!
!* random number generator: normal distribution *!
!* SR gasdev (from numerucal recipes) *!
!* SR ran1 ( --"--) *!
!* *!
!* Copyright (C) 1996-2018 *!
!* Potsdam Institute for Climate Impact Reserach (PIK) *!
!* Authors and contributors see AUTHOR file *!
!* This file is part of 4C and is licensed under BSD-2-Clause *!
!* See LICENSE file or under: *!
!* http://www.https://opensource.org/licenses/BSD-2-Clause *!
!* Contact: *!
!* https://gitlab.pik-potsdam.de/foresee/4C *!
!* *!
!*****************************************************************!
FUNCTION gasdev(idum)
INTEGER idum
REAL gasdev, ran1
INTEGER iset
REAL fac,gset,rsq,v1,v2
SAVE iset,gset
DATA iset/0/
if (iset.eq.0) then
1 v1=2.*ran1(idum)-1.
v2=2.*ran1(idum)-1.
rsq=v1**2+v2**2
if(rsq.ge.1..or.rsq.eq.0.)goto 1
fac=sqrt(-2.*log(rsq)/rsq)
gset=v1*fac
gasdev=v2*fac
iset=1
else
gasdev=gset
iset=0
endif
return
END
FUNCTION ran1(idum)
INTEGER idum,IA,IM,IQ,IR,NTAB,NDIV
REAL ran1,AM,EPS,RNMX
PARAMETER (IA=16807,IM=2147483647,AM=1./IM,IQ=127773,IR=2836, &
NTAB=32,NDIV=1+(IM-1)/NTAB,EPS=1.2e-7,RNMX=1.-EPS)
INTEGER j,k,iv(NTAB),iy
SAVE iv,iy
DATA iv /NTAB*0/, iy /0/
if (idum.le.0.or.iy.eq.0) then
idum=max(-idum,1)
do 11 j=NTAB+8,1,-1
k=idum/IQ
idum=IA*(idum-k*IQ)-IR*k
if (idum.lt.0) idum=idum+IM
if (j.le.NTAB) iv(j)=idum
11 continue
iy=iv(1)
endif
k=idum/IQ
idum=IA*(idum-k*IQ)-IR*k
if (idum.lt.0) idum=idum+IM
j=1+iy/NDIV
iy=iv(j)
iv(j)=idum
ran1=min(AM*iy,RNMX)
return
END
source_code/version_2.3_windows/gen_one_coh.f 0 → 100644
View file @ 82df1085
!*****************************************************************!
!* *!
!* 4C (FORESEE) *!
!* *!
!* SR gen_one_coh for: *!
!* planting of small trees given by *.pla *!
!* used in prep_stand *!
!* SR is called by flag_reg=20 *!
!* *!
!* Copyright (C) 1996-2018 *!
!* Potsdam Institute for Climate Impact Reserach (PIK) *!
!* Authors and contributors see AUTHOR file *!
!* This file is part of 4C and is licensed under BSD-2-Clause *!
!* See LICENSE file or under: *!
!* http://www.https://opensource.org/licenses/BSD-2-Clause *!
!* Contact: *!
!* https://gitlab.pik-potsdam.de/foresee/4C *!
!* *!
!*****************************************************************!
SUBROUTINE gen_one_coh(taxid,age,pl_height,nplant)
USE data_stand
USE data_simul
USE data_species
USE data_soil
USE data_help
USE data_plant
USE data_manag
IMPLICIT NONE
integer :: nplant, &
taxid, &
j,nr
real :: age, &
pl_height, &
hhelp,x1,x2,xacc,shelp
real :: rtflsp, sapwood
real :: troot2
TYPE(cohort) ::tree_ini
external sapwood
external rtflsp
call coh_initial (tree_ini)
max_coh = max_coh + 1
tree_ini%ident = max_coh
tree_ini%species = taxid
tree_ini%ntreea = nplant
tree_ini%nta = tree_ini%ntreea
tree_ini%x_age = age
tree_ini%height = pl_height
hhelp = tree_ini%height
IF (taxid.ne.2) tree_ini%x_sap = exp(( LOG(hhelp)-LOG(spar(taxid)%pheight1))/spar(taxid)%pheight2)/1000000.
IF (taxid.eq.2) THEN
x1 = 1.
x2 = 2.
xacc=(1.0e-10)*(x1+x2)/2
! solve equation for calculation of sapwood from height; determine root
heihelp = tree_ini%height
shelp=rtflsp(sapwood,x1,x2,xacc)
tree_ini%x_sap = (10**shelp)/1000000 ! transformation mg ---> kg
ENDIF
! leaf matter
tree_ini%x_fol = (spar(taxid)%seeda*(tree_ini%x_sap** spar(taxid)%seedb)) ![kg]
! fine root matter rough estimate
tree_ini%x_frt = tree_ini%x_fol
! cross sectional area of heartwood
tree_ini%x_crt = tree_ini%x_sap * spar(tree_ini%species)%alphac*spar(tree_ini%species)%cr_frac
tree_ini%x_tb = tree_ini%x_sap * spar(tree_ini%species)%alphac*(1.-spar(tree_ini%species)%cr_frac)
tree_ini%med_sla = spar(taxid)%psla_min + spar(taxid)%psla_a*0.5
tree_ini%t_leaf = tree_ini%med_sla* tree_ini%x_fol ! [m-2]
tree_ini%ca_ini = tree_ini%t_leaf
! initialize pheno state variables
IF(spar(tree_ini%species)%Phmodel==1) THEN
tree_ini%P=0
tree_ini%I=1
ELSE
tree_ini%P=0
tree_ini%I=0
tree_ini%Tcrit=0
END IF
IF(nplant.ne.0.) then
IF (.not. associated(pt%first)) THEN
ALLOCATE (pt%first)
pt%first%coh = tree_ini
NULLIFY(pt%first%next)
! root distribution
call root_depth (1, pt%first%coh%species, pt%first%coh%x_age, pt%first%coh%height, pt%first%coh%x_frt, pt%first%coh%x_crt, nr, troot2, pt%first%coh%x_rdpt, pt%first%coh%nroot)
pt%first%coh%nroot = nr
do j=1,nr
pt%first%coh%rooteff = 1. ! assumption for the first use
enddo
do j=nr+1, nlay
pt%first%coh%rooteff = 0. ! layers with no roots
enddo
ELSE
ALLOCATE(zeig)
zeig%coh = tree_ini
zeig%next => pt%first
pt%first => zeig
! root distribution
call root_depth (1, zeig%coh%species, zeig%coh%x_age, zeig%coh%height, zeig%coh%x_frt, zeig%coh%x_crt, nr, troot2, zeig%coh%x_rdpt, zeig%coh%nroot)
zeig%coh%nroot = nr
do j=1,nr
zeig%coh%rooteff = 1. ! assumption for the first use
enddo
do j=nr+1, nlay
zeig%coh%rooteff = 0. ! layers with no roots
enddo
END IF
anz_coh=anz_coh+1
END IF
END SUBROUTINE gen_one_coh
source_code/version_2.3_windows/getopenfilename.f90 0 → 100644
View file @ 82df1085
!*****************************************************************!
!* *!
!* 4C (FORESEE) Simulation Model *!
!* *!
!* *!
!* Subroutines for: *!
!* - windows shell - *!
!* *!
!* contains: *!
!* FileOpen *!
!* *!
!* Copyright (C) 1996-2018 *!
!* Potsdam Institute for Climate Impact Reserach (PIK) *!
!* Authors and contributors see AUTHOR file *!
!* This file is part of 4C and is licensed under BSD-2-Clause *!
!* See LICENSE file or under: *!
!* http://www.https://opensource.org/licenses/BSD-2-Clause *!
!* Contact: *!
!* https://gitlab.pik-potsdam.de/XXXXXXXXXXXXXXXXXXXXX *!
!* *!
!*****************************************************************!
Subroutine FileOpen (file_spec, filter_spec)
! Following example of calling the Win32 API routine GetOpenFileName
use comdlg32
!use dflib ! In case QuickWin is used
implicit none
! Declare structure used to pass and receive attributes
!
type(T_OPENFILENAME) ofn
! Declare filter specification. This is a concatenation of
! pairs of null-terminated strings. The first string in each pair
! is the file type name, the second is a semicolon-separated list
! of file types for the given name. The list ends with a trailing
! null-terminated empty string.
!
character*(*) :: filter_spec
! Declare string variable to return the file specification.
! Initialize with an initial filespec, if any - null string
! otherwise
character*512 :: file_spec
integer status,ilen
ofn%lStructSize = SIZEOF(ofn)
ofn%hwndOwner = NULL ! For non-console applications,
! set this to the Hwnd of the
! Owner window. For QuickWin
! and Standard Graphics projects,
! use GETHWNDQQ(QWIN$FRAMEWINDOW)
!
ofn%hInstance = NULL ! For Win32 applications, you
! can set this to the appropriate
! hInstance
!
ofn%lpstrFilter = loc(filter_spec)
ofn%lpstrCustomFilter = NULL
ofn%nMaxCustFilter = 0
ofn%nFilterIndex = 1 ! Specifies initial filter value
ofn%lpstrFile = loc(file_spec)
ofn%nMaxFile = sizeof(file_spec)
ofn%nMaxFileTitle = 0
ofn%lpstrInitialDir = NULL ! Use Windows default directory
ofn%lpstrTitle = loc(""C)
ofn%Flags = OFN_PATHMUSTEXIST
ofn%lpstrDefExt = loc("txt"C)
ofn%lpfnHook = NULL
ofn%lpTemplateName = NULL
! Call GetOpenFileName and check status
do
status = GetOpenFileName(ofn)
if (status .eq. 0) then
write(*,'(A)',advance='no') ' No file name specified'
write(*,'(A)',advance='no') ' Program aborted'
PAUSE
STOP
else
! Get length of file_spec by looking for trailing NUL
ilen = INDEX(file_spec,CHAR(0))
exit
end if
enddo
end Subroutine fileopen
source_code/version_2.3_windows/gr_seed_week.f 0 → 100644
View file @ 82df1085
!*****************************************************************!
!* *!
!* 4C (FORESEE) *!
!* *!
!* *!
!* growth_seed_week - Growth of seedling cohorts weekly *!
!* Allocation with weekly NPP *!
!* *!
!* Copyright (C) 1996-2018 *!
!* Potsdam Institute for Climate Impact Reserach (PIK) *!
!* Authors and contributors see AUTHOR file *!
!* This file is part of 4C and is licensed under BSD-2-Clause *!
!* See LICENSE file or under: *!
!* http://www.https://opensource.org/licenses/BSD-2-Clause *!
!* Contact: *!
!* https://gitlab.pik-potsdam.de/foresee/4C *!
!* *!
!*****************************************************************!
SUBROUTINE growth_seed_week (jx)
USE data_stand
USE data_species
USE data_simul
IMPLICIT NONE
REAL :: lambdaf = 0., & ! partitioning coefficients
lambdas = 0., &
lambdar = 0., &
NPP = 0., & ! NPP available for allocation
F = 0., & ! state variables: foliage,
S = 0., & ! shoot biomass,
R = 0., & ! fine roots,
H = 0., & ! total tree height
FNew, SNew, & ! new state variables
RNew, &
sigmaf = 0., & ! current leaf activity rate
ar = 0.
REAL :: Gf, & ! growth rates
Gs, &
Gr
REAL :: pab,helpdr
INTEGER :: jx
TYPE(coh_obj), POINTER :: p
p=>pt%first
DO
IF(.not.associated(p)) exit
IF( p%coh%fl_sap.eq.0) then
ns = p%coh%species
F = p%coh%x_fol
S = p%coh%x_sap
R = p%coh%x_frt
NPP = p%coh%weekNPP ! [kg]
H = p%coh%height
! only allocate if enough NPP is available and day < a fixed limit
IF (NPP>1.0E-9 .and. iday<190) THEN
p%coh%NPPpool = p%coh%NPPpool + NPP
! calculate leaf activity based on net PS and leaf mass
sigmaf = NPP/F
! calculate root activity based on drought index
helpdr= p%coh%drIndPS
! auxiliary variables for fine roots
ar = 1./helpdr
if(helpdr.lt.0.001) ar = 1.
! calculate coefficients for roots and foliage and shoot
pab = spar(ns)%seeda*spar(ns)%seedb*S**(spar(ns)%seedb-1)
! new model without senescence within the year:
lambdas=1./(1.+pab+pab*ar)
lambdaf=(1.-lambdas)/(1.+ar)
lambdar=1.-lambdas-lambdaf
IF (lambdas.lt.0.) THEN
lambdas = 0.
lambdaf = 1./(ar+1.)
lambdar = 1.-lambdaf
END IF
IF (lambdar<0) THEN
lambdar=0.
lambdas=0.
lambdaf=1.
END IF
IF (lambdaf<0) THEN
lambdar=0.
lambdas=0.
lambdaf=1.
END IF
ELSE
lambdaf = 0.
lambdas = 0.
lambdar = 0.
END IF
Gf = lambdaf*NPP
Gr = lambdar*NPP
Gs = lambdas*NPP
p%coh%gfol = Gf
p%coh%gfrt = Gr
p%coh%gsap = Gs
! update of state vector
FNew = F + Gf
SNew = S + Gs
RNew = R + Gr
p%coh%x_fol = FNew
p%coh%x_sap = SNew
p%coh%x_frt = RNew
p%coh%fol_inc_old = p%coh%fol_inc
p%coh%fol_inc = Gf
p%coh%stem_inc = Gs
! update height and shoot base diameter (regression functions from Schall 1998)
IF(ns.ne.2) p%coh%height = spar(ns)%pheight1* (snew*1000000.) **spar(ns)%pheight2
IF(ns.eq.2) p%coh%height = 10**(spar(ns)%pheight1+ spar(ns)%pheight2*LOG10(snew*1000000.)+ &
spar(ns)%pheight3*(LOG10(snew*1000000.))**2)
p%coh%height_ini = p%coh%height
! update foliage area, parameter med_sla
SELECT CASE (flag_light)
CASE (1:2)
p%coh%med_sla = spar(ns)%psla_min + spar(ns)%psla_a*(1.- vstruct(lowest_layer)%irel)
CASE(3,4)
p%coh%med_sla = spar(ns)%psla_min + spar(ns)%psla_a*(1.-irelpool(lowest_layer))!
END SELECT
! total leaf area of a tree in this cohort [m**2]as as crown area
p%coh%ca_ini = p%coh%med_sla * p%coh%x_fol
! weekNPP equal zero for next calculation
p%coh%weekNPP = 0.
END IF
p=> p%next
END DO
END SUBROUTINE growth_seed_week
\ No newline at end of file
source_code/version_2.3_windows/initia.f 0 → 100644
View file @ 82df1085
!*****************************************************************!
!* *!
!* 4C (FORESEE) Simulation Model *!
!* *!
!* *!
!* Subroutines for: *!
!* - Initialisation of cohorts = *!
!* reads cohort information and calculates missing values *!
!* which are needed for stand initialisation *!
!* initia *!
!* treeini *!
!* sapini *!
!* header *!
!* crown_base *!
!* crown_base_eg *!
!* fdfahc: function *!
!* ini_gener_sap *!
!* NEWTON: function numerical recipes *!
!* *!
!* Copyright (C) 1996-2018 *!
!* Potsdam Institute for Climate Impact Reserach (PIK) *!
!* Authors and contributors see AUTHOR file *!
!* This file is part of 4C and is licensed under BSD-2-Clause *!
!* See LICENSE file or under: *!
!* http://www.https://opensource.org/licenses/BSD-2-Clause *!
!* Contact: *!
!* https://gitlab.pik-potsdam.de/foresee/4C *!
!* *!
!*****************************************************************!
!***********************!
! SUBROUTINE INITIA !
!***********************!
SUBROUTINE INITIA
! begin declaration section
USE data_init
USE data_par
USE data_simul
USE data_species
USE data_stand
use data_help
IMPLICIT none
REAL :: area !area of database in m^2 (10000=1ha)
INTEGER :: area_factor !factor for calculation per patch (=area/kpatchsize)
REAL :: hlp_lai,share, ager
INTEGER :: taxid, & ! species number
age, & ! tree age
n, & ! number of trees
n_koh, & !
k, & ! number of tree classes
ng_locid ! ID stand
INTEGER :: inunit, parunit,outunit,tmpunit,ctrlunit,listunit !units
CHARACTER*85 zeile
CHARACTER*80 :: infile
CHARACTER :: source
INTEGER :: nlines, nlines_comp, istart, fl_num, nhelp, numstand, ihelp
INTEGER :: tax_of_BRA_id
INTEGER,DIMENSION(:),ALLOCATABLE :: locid_comp
REAL rsap, cform, dummy
REAL aux
LOGICAL :: select_lines
real standsz(10000)
CHARACTER*40, allocatable, dimension(:) ::helptmp
INTEGER :: helpz
! Stand data (model initialisation)
INTEGER baum(10),alt(10),klimid,gwa,lbanr,wgeb,lein,zei
REAL mhoe(10),dm(10),gf(10),bon(10),en(10),psi(10)
! Parameters for missing data algorithms
REAL p0(nspec_tree),p1(nspec_tree),p2(nspec_tree),p3(nspec_tree),p4(nspec_tree), &
c1(nspec_tree),c2(nspec_tree),ku_a0(nspec_tree),ku_a1(nspec_tree),ku_a2(nspec_tree),&
ku_b0(nspec_tree),ku_b1(nspec_tree),ku_b2(nspec_tree),ku_c0(nspec_tree),&
ku_c1(nspec_tree),ku_c2(nspec_tree),wei_k1(nspec_tree),wei_k2(nspec_tree)
! ------------------------------------------------------------------
! INTEGER ncl !Number of classes after classification
integer ncl1
REAL dg,dmin,dmax,g,gpatch,b,c,bhd,height,hbc,hg
REAL tot_crown_area, mixed_tot_ca, corr_la
INTEGER pass
REAL saquad, genDg, nbhd,x,gx,bhdmax,bhdmin,clwdth,Fint(0:100)
REAL ku_a,ku_b,ku_c,wei_f,thdmax,p1n,p4n
REAL, allocatable, dimension(:) :: nz
REAL, allocatable, dimension(:) :: zheigh,zbhd,zhbc
REAL xxr,xyr, &
kd, &
h_para,h_parb !parameter of the height function of level II sites
INTEGER idum,anzahl, data_flag,start,baumid,dir_flag,inwahl,bz,imax
INTEGER i,j,anzit,iz,id,icl,ios,xid,xnr,xxi,xyi, &
bhdcl, & !diameter classes level II
dclmin, & !smallest diameter class level II
ndcl, & !amount of diameter classes of level II
dcwdth, & !class wideness diameter classes of level II
n_dc(30) !stem figure of level II diameter class
LOGICAL ehkwei, wfirst, kfirst, optimi
LOGICAL, allocatable, dimension(:) :: smaldc, bigdc
CHARACTER*20 fnam2
CHARACTER*5 datasets
CHARACTER status
real nzsum
! ------------------------------------------------------------------
! ----Function----
REAL ran0
REAL crown_base
real crown_base_eg
! ------------------------------------------------------------------
REAL T
DATA T/7.0/
! ------------------------------------------------------------------
!
! end of declaration section
!******************************************************************************
!ncl1 = 60
ncl1=40
allocate (zheigh(ncl1), zbhd(ncl1), zhbc(ncl1), nz(ncl1))
allocate (smaldc(ncl1), bigdc(ncl1))
print *,' '
print *, ' *** Choice of forest stand data set: '
print *, ' 1 - Datenspeicher Waldfond'
print *, ' 2 - single tree data; classification must be performed (e.g. SILVA data)'
print *, ' 3 - Level2-data'
print *, ' 4 - already existing class file'
print *, ' 5 - FORGRA data'
print *, ' 6 - Bavarian inventory data'
WRITE(*,'(A)',advance='no') ' ***Make your choice: '
READ *, data_flag
print *,' '
clwdth=15 !set diameter class-class width
corr_la=1. !standard value for leaf area correction in stands of high sum of crown projection areas
mixed_tot_ca=0. !sum of crown projection area for mixed stands
pass = 1 !counter for number of passes through calculation loop for mixed stands
rsap=0.3 !standard value of rsap for cases where rsap is not determined dynamically
! get unit number and open units used in all of the above cases
ctrlunit=GETUNIT()
WRITE(*,*)site_name(ip)
OPEN (ctrlunit,FILE=TRIM(site_name(ip))//'.initctrl',STATUS='replace')
WRITE(ctrlunit,*)'# number of trees in cohort = n trees'
WRITE(ctrlunit,*)'# age = age'
WRITE(ctrlunit,*)'# height = H'
WRITE(ctrlunit,*)'# height to the base of crown = Hbc'
WRITE(ctrlunit,*)'# breast height diameter = bhd'
WRITE(ctrlunit,*)'# sapwood fraction of trunc cross sectional area at breast height = rsap'
WRITE(ctrlunit,*)'# trunc diameter at tree base = D'
WRITE(ctrlunit,*)'# trunc diameter at crown base = Dc'
WRITE(ctrlunit,*)'# sapwood cross sectional area inside bole = Asap'
WRITE(ctrlunit,*)'# heartwood cross sectional area at crown base = Ahc'
WRITE(ctrlunit,*)'# heartwood cross sectional area at tree base = Ahb'
WRITE(ctrlunit,*)'# Vol for no heartwood in crown space = Vmin'
WRITE(ctrlunit,*)'# Vol prescribed according to empiracal volume function = Vpre'
WRITE(ctrlunit,*)'# stem vol inherent in initialisation = Veff'
WRITE(ctrlunit,'(A150)')'# n trees age H Hbc bhd rsap D Dc Asap Ahc Ahb Vmin Vpre Veff'
outunit=GETUNIT()
OPEN (outunit,FILE=TRIM(treefile(ip)),STATUS='replace')
! ------------------------------------------------------------------
! read in parameter for the missing-data-generator:
! bhd-distribution from Nagel & Biging (1995),
! crown starting height from Nagel (1995), uni-height curve according to Weimann (1980) bzw. Kuleschis (1981)
parunit=GETUNIT()
OPEN (parunit, FILE='input/generreg.par', STATUS='old')
do i=1,nspec_tree
READ (parunit,*) p0(i),p1(i),p2(i),p3(i),p4(i),c1(i),c2(i),ku_a0(i),ku_a1(i),ku_a2(i), &
ku_b0(i),ku_b1(i),ku_b2(i),ku_c0(i),ku_c1(i),ku_c2(i),wei_k1(i),wei_k2(i)
ENDDO
CLOSE(parunit)
! ---------------------------------------------------------------------
inunit=GETUNIT()
SELECT CASE(data_flag)
! ****************************************************************************
! case(1) stand generation if data source is Datenspeicher Waldfond
CASE(1)
print *, ' Forest stand data set: Datenspeicher Waldfond'
! preliminary: here make a choice and compile
! datasets='singl' sets the choice of the old version which uses one single
! set (i.e. the first one in an input file) which contains
! the complete imformation for the stand in one single line
! datasets='multi' sets the choice of a version reading a file with line by
! line information as in the original Datenspeicher and then
! writes a *.ini file for many stands with individual stand
! information separated by lines with stand identifiers
print*, 'choose data set (multi/singl):'
read(*,*) datasets
print*, ' file name (with directory):'
read(*,'(A)') infile
source='D'
standsz = 0.
OPEN (inunit, FILE=TRIM(infile), STATUS='old')
! ------------------------------------------------------------------
! generating standard value out of data from the data storage unit
! based on estimation routine from Nagel und Biging (1995),
! Nagel (1995) und Gerold (1990).
! ------------------------------------------------------------------
!
! The following variables are read from forest inventory data:
! Species(baum),Age(alt),Quadratic Mean Diameter(dm),Height of tree with dm(mhoe),
! Basal area(gf),Yield Class(bon),"Ertragsniveau"(en)
! Additional Site variables:
! Climate station(klimid),distance of groundwater table(gwa),soil type(lbanr),
! forest region 'Wuchsgebiet'(wgeb),last management operation(lein), number of tree layers(zei)
! currently not used for initialisation: xid, klimid, gwa, lbanr, wgeb, lein, bon(i), en(i)
! lbanr (check difference to declaration!),
! check if alt and baum can be skipped as variable names and age and species directly used
! check idendity of hg and mhoe, dg and dm, gf and g
! ------------------------------------------------------------------
! input of data from a dataset, first row
IF (datasets=='singl') THEN
READ (inunit,*)xid,klimid,lbanr,gwa,wgeb,lein, &
zei,(baum(i), alt(i),mhoe(i),dm(i),gf(i),bon(i),en(i),i=1,zei)
ALLOCATE(ngroups(zei))
DO i=1,zei
IF(baum(i).EQ.8) ngroups(i)%taxid=1
IF(baum(i).EQ.10) ngroups(i)%taxid=2
IF(baum(i).EQ.11) ngroups(i)%taxid=3
IF(baum(i).EQ.15) ngroups(i)%taxid=4
if(baum(i).eq.12) ngroups(i)%taxid = 10
! Eucalyptus
IF(baum(i).EQ.30) ngroups(i)%taxid=12
IF(baum(i).EQ.31) ngroups(i)%taxid=13
IF (dm(i).eq.0) dm(i) = 0.5
IF (mhoe(i).eq.0) mhoe(i) = 1.0
IF (gf(i).eq.0) gf(i) = 0.25
ngroups(i)%locid=xid
ngroups(i)%alter=alt(i)
ngroups(i)%mhoe=mhoe(i)
ngroups(i)%gf=gf(i)
ngroups(i)%dm=dm(i)
ngroups(i)%patchsize=10000
ENDDO
CLOSE(inunit)
nlines=zei
cform=1;hlp_lai=0
! Initialisastion of stand data: area = 1ha
area=10000
area_factor=int(area/kpatchsize)
! read file head for description, write in ini-file
CALL header(outunit,infile,source,cform,rsap,flag_volfunc,kpatchsize)
ENDIF !block for reading of input data DSW 'singl' = specially prepared for FORSKA
! read in stand dataEinlesen out of data storage for many stands
IF (datasets=='multi') THEN
select_lines=.false.
fl_num=0
ALLOCATE(ngroups(10000))
numstand= 0
nlines=1
ngroups%taxid=0
ngroups%schicht=-99
DO
READ (inunit,*,END=3333)xid,klimid,lbanr,gwa,wgeb,lein, &
zei,(baum(i),alt(i), psi(i), mhoe(i),dm(i),gf(i),bon(i),en(i),i=1,zei)
numstand = numstand +1
ngroups(nlines)%standsize= 0
DO i=1,zei
IF(baum(i).EQ.5) ngroups(nlines)%taxid=5
IF(baum(i).EQ.8) ngroups(nlines)%taxid=1
IF(baum(i).EQ.10) ngroups(nlines)%taxid=2
IF(baum(i).EQ.11) ngroups(nlines)%taxid=3
IF(baum(i).EQ.15) ngroups(nlines)%taxid=4
! the following species are preliminarily assigned
IF(baum(i).EQ.1) ngroups(nlines)%taxid=2 ! Abies alba
IF(baum(i).EQ.2) ngroups(nlines)%taxid=1 ! Acer platanoides
IF(baum(i).EQ.3) ngroups(nlines)%taxid=1 ! Acer pseudoplatanus
IF(baum(i).EQ.4) ngroups(nlines)%taxid=5 ! Alnus glutinosa
IF(baum(i).EQ.6) ngroups(nlines)%taxid=1 ! Carpinus betulus
IF(baum(i).EQ.7) ngroups(nlines)%taxid=4 ! Castanea sativa
IF(baum(i).EQ.9) ngroups(nlines)%taxid=4 ! Fraxinus excelsior
IF(baum(i).EQ.12) ngroups(nlines)%taxid=5 ! Populus tremula
IF(baum(i).EQ.13) ngroups(nlines)%taxid=4 ! Quercus petraea
IF(baum(i).EQ.14) ngroups(nlines)%taxid=4 ! Quercus pubescencs
IF(baum(i).EQ.16) ngroups(nlines)%taxid=1 ! Tilia cordata
IF(baum(i).EQ.17) ngroups(nlines)%taxid=4 ! Ulmus glabra
iF(baum(i).EQ.21) ngroups(nlines)%taxid=10 ! Douglasie
iF(baum(i).EQ.22) ngroups(nlines)%taxid=6 ! Larix
iF(baum(i).EQ.23) ngroups(nlines)%taxid=7 ! Pinus strobus
iF(baum(i).EQ.24) ngroups(nlines)%taxid=10 ! Douglasie
IF (dm(i).eq.0) dm(i) = 0.5
IF (mhoe(i).eq.0) mhoe(i) = 1.0
IF (gf(i).eq.0) gf(i) = 0.25
ngroups(nlines)%locid=xid
ngroups(nlines)%alter=alt(i)
ngroups(nlines)%mhoe=mhoe(i)
ngroups(nlines)%gf=gf(i)
ngroups(nlines)%dm=dm(i)
ngroups(nlines)%patchsize=psi(i)*10000
ngroups(nlines)%standsize=psi(i)*10000
nlines=nlines+1
standsz(numstand) = standsz(numstand) + psi(i)*10000
ENDDO
ENDDO ! read loop
3333 CONTINUE
nlines=nlines-1
WRITE(*,*) nlines,'sets of data', numstand, 'sets of stands'
CLOSE(inunit)
! read in file headder for description, write into ini-file
cform=1;hlp_lai=0
! initilisation for stand data: area = stand area based on fractions of areas
area_factor=1
CALL header(outunit,infile,source,cform,rsap,flag_volfunc,-99.)
WRITE(*,*) 'number of data lines: ', nlines
write(*,*)'number of plots for calculations: ', fl_num
ENDIF ! block for reading input data DSW, many lines = 'multi'
id=1
tmpunit=getunit()
ihelp = 1
istart=-99
DO iz=1,nlines
IF(select_lines) THEN
DO i=1,nlines_comp
IF(locid_comp(i)==ngroups(iz)%locid) GOTO 2233
ENDDO ! comparison of site id to list of sites to be selected
CYCLE
ENDIF ! end of site selection
2233 CONTINUE
WRITE(*,*) iz, nlines, ngroups(iz)%locid,ngroups(iz)%schicht
IF(datasets=='multi'.AND.(istart.NE.ngroups(iz)%locid)) THEN
WRITE(outunit,*) ngroups(iz)%locid,ngroups(iz)%standsize,'stand identifier, stand area'
ihelp = ihelp +1
istart=ngroups(iz)%locid
ENDIF
IF(datasets=='multi'.AND.ngroups(iz)%taxid==0.) THEN
WRITE(*,*) 'not the right species'
GOTO 2222
ENDIF
IF(datasets=='multi'.AND.ngroups(iz)%schicht==20) THEN
! retention trees
age=ngroups(iz)%alter
taxid=ngroups(iz)%taxid
height=ngroups(iz)%mhoe
bhd=ngroups(iz)%dm
n_koh=ngroups(iz)%baumzahl
hbc=crown_base(height,c1(taxid),c2(taxid),bhd)
CALL treeini(outunit,ctrlunit,taxid,source,bhd,height,hbc,n_koh,cform,rsap,age,hlp_lai,corr_la)
GOTO 2222
ENDIF ! end special treatment of retention trees
IF(datasets=='multi'.AND.ngroups(iz)%dm==0.) THEN
WRITE(4444,*)'data insufficient for: ',ngroups(iz)%locid,' line: ',iz
GOTO 2222
ENDIF
IF(datasets=='multi'.AND.ngroups(iz)%mhoe<h_sapini*0.01 .or. ngroups(iz)%gf.eq.0.) THEN
aux = ngroups(iz)%standsize/10000.
height=ngroups(iz)%mhoe
n_koh=ngroups(iz)%baumzahl* aux
age=ngroups(iz)%alter
taxid = ngroups(iz)%taxid
WRITE(4444,*)'sapling init needed for: ',ng_locid,' line: ',iz
call ini_gener_sap(outunit, taxid,age,height,n_koh)
GOTO 2222
ENDIF
optimi=.false.
anzahl= 0;start=1
allocate(helptmp(10000000))
helptmp = ' '
! generation of single trees out of population mean values
DO
helptmp = ' '
IF((start==1).or.(.not.optimi))THEN
T =7
anzahl=0
start=0
wfirst=.true.
kfirst=.true.
WRITE(*,*)ngroups(iz)%locid,ngroups(iz)%patchsize
age=ngroups(iz)%alter
dg=ngroups(iz)%dm !quadratic mean diameter
hg=ngroups(iz)%mhoe !corresponding height to dg
taxid=ngroups(iz)%taxid !species
g=ngroups(iz)%gf !basal area/ha
gpatch=g/area_factor !basal area/patch
IF (datasets=='multi') gpatch=g*ngroups(iz)%standsize/10000.
! selection of uni-height curve: Beech, Spruce, Oak calculated according to Weimann,
! other species of tree according to Kuleschis (vergl. Gerold 1990)
IF (taxid==3.OR.taxid==5) THEN
ehkwei=.false.
ELSE
ehkwei=.true.
ENDIF
IF ((dg-T).lt. 3.0) THEN
T=dg-4.0
IF (T.lt.0.3) T=0.3
ENDIF
! Estimation of Dmax out of dg (Gerold 1990)
Dmax=8.2+1.8*dg-0.01*dg**2
IF (dg.le.2) Dmax=dg+2
! calculation for the Weibull-distribution function
! in case b or c are calcuted too small, p1 and p4 respectively have to be modified
p1n=p1(taxid)
IF (p1n.lt.((1.0001-p0(taxid))/Dg)) p1n=(1.0001-p0(taxid))/Dg
b=p0(taxid)+p1n*Dg
p4n=p4(taxid)
IF (p4n.lt.((1.0005-p2(taxid)-p3(taxid)*Dg)/Dmax)) p4n=(1.0005-p2(taxid)-p3(taxid)*Dg)/Dmax
c=p2(taxid)+p3(taxid)*Dg+p4n*Dmax
anzit=0
thdmax=5.0
ENDIF ! end of introductory calculation and repetitions without optimisation
genDg=0
nbhd=0
saquad=0
bhdmax=0
bhdmin=100
clwdth=0
gx=0
idum=1
x=0
!----------------------------
! generation of single trees
DO
IF (gx.gt.gpatch) exit
x = ran0(idum)
bhd=b*((T/b)**c-log(1.-x))**(1./c)
if ( bhd.ge. 0.5*Dg) then
IF (bhd.gt.bhdmax) bhdmax=bhd
IF (bhd.lt.bhdmin) bhdmin=bhd
IF ((.not. optimi) .and. (bhd.gt.(1.5*dmax))) bhd=1.5*dmax
!***height calculation according to uni-height curve
IF (ehkwei) THEN
! uni-height curve of Weimann (1980)
IF (wfirst) THEN
wei_f=wei_k1(taxid)+wei_k2(taxid)*hg
wfirst=.false.
ENDIF
IF (bhd.ge.(dg-hg/2.)) THEN
height=hg+wei_f*(log(hg-dg+bhd)-log(hg))
ELSE
height=(hg+wei_f*(log(hg/2.)-log(hg))-1.3)*(bhd/(dg-hg/2.))**0.5+1.3
ENDIF
ELSE
! uni-height curve of Kuleschis (1981)
IF (kfirst) THEN
ku_a=1-(ku_a0(taxid)+ku_a1(taxid)*dg+ku_a2(taxid)*dg**2)
ku_b=ku_b0(taxid)+ku_b1(taxid)*dg+ku_b2(taxid)*dg**2
ku_c=ku_c0(taxid)+ku_c1(taxid)*dg+ku_c2(taxid)*dg**2
kfirst=.false.
ENDIF
height=hg*(ku_a+(ku_b/(bhd+dg/2.))*dg+(ku_c/(bhd+dg/2.)**2)*dg**2)
ENDIF
if(taxid.eq.10) then
! height curve after Bwinpro Douglas fir
height = 1.3 +(hg-1.3)*exp(-(0.199651*dg+4.63277655)*((1/bhd) - (1/dg)))
end if
if(taxid.eq.12.or. taxid.eq.13) then
! Medhurst et al. 1999
height = 3.665629*bhd**0.541
end if
! solution for small stands; tree dimensions below 3 m = rubbish
IF (height.gt.(bhd*3.)) height=bhd*3.
IF (height.lt.1.35) height=1.35+bhd
if(taxid.eq.12.or. taxid.eq.13) then
! Eucalyptus
hbc = crown_base_eg(height, bhd)
else
hbc=crown_base(height,c1(taxid),c2(taxid),bhd)
end if
IF ((height-hbc).lt. 0.5) hbc= height - 0.5
write(helptmp(nbhd+1), '(3f7.1,2i7)') bhd,height,hbc,age,taxid
gx=gx+1E-4*pi*(bhd/2.)**2
nbhd=nbhd+1
anzahl=anzahl+1
saquad=saquad+bhd**2
end if ! BHD test
ENDDO ! single tree calculation
!---calculates the generated Dg and test deviations of Dg and Dmax of the population value.
! if deviation greater 20% a fittinf of the parameters acording to the Weibull-distribution is done
! the standard generation is repeated in several iterations.
!---the optimisation can be shut off with optimi=.false.
genDg=SQRT(saquad/nbhd)
IF((.not. optimi) .or. (Dg .lt. 7)) exit
IF(ABS(genDg-Dg).gt.(Dg/10.).or.(bhdmax-Dmax).gt. (Dmax/thdmax)) THEN
IF (ABS(genDg-Dg).gt.(Dg/10.))THEN
p1n=p1n*Dg/genDg
IF (p1n.lt.((1.0001-p0(taxid))/Dg)) p1n=(1.0001-p0(taxid))/Dg
b=p0(taxid)+p1n*Dg
ELSE
p4n=p4n*Dmax/bhdmax
IF (p4n.lt.((1.0005-p2(taxid)-p3(taxid)*Dg)/Dmax)) &
p4n=(1.0005-p2(taxid)-p3(taxid)*Dg)/Dmax
c=p2(taxid)+p3(taxid)*Dg+p4n*Dmax
ENDIF
anzahl=anzahl-Int(nbhd)
anzit=anzit+1
IF (anzit.ge.50) THEN
IF (thdmax.eq.2) THEN
print *,'id/zei: ',id,iz,' Optimization not successful. Biased STAND.INI will be generated'
optimi=.false.
ELSE
anzit=0
thdmax=2.0
b=p0(taxid)+p1(taxid)*Dg
c=p2(taxid)+p3(taxid)*Dg+p4(taxid)*Dmax
ENDIF
ENDIF
ELSE
exit
ENDIF
ENDDO
! end of generation of single trees
! classification of single values in diameter cohorts
clwdth=1+AINT((bhdmax-bhdmin)/ncl1) !calculation of class widths
! write(4444,*) 'clwdth', clwdth, bhdmax, bhdmin, ncl1
DO i=1,ncl1
nz(i)=0
zbhd(i)=0
zheigh(i)=0
zhbc(i)=0
ENDDO
DO j=1,nbhd
read(helptmp(j), *) bhd,height,hbc,age,taxid
IF(height<1.3) WRITE(4444,*)'bhd ',bhd,'height ',height,'art ',taxid
icl=INT(bhd/clwdth)+1
IF(icl.gt.ncl1) icl=ncl1
nz(icl)=nz(icl)+1 !addition stem numbre of diameter classes
zbhd(icl)=zbhd(icl)+bhd !sum of diametes of diameter calsses
zheigh(icl)=zheigh(icl)+height !sum of height value of classes
zhbc(icl)=zhbc(icl)+hbc !sum of crown starting height of classes
ENDDO
deallocate(helptmp)
tot_crown_area=0.
DO i=1,ncl1
IF (nz(i).ne.0) THEN
bhd=zbhd(i)/nz(i)
height=zheigh(i)/nz(i)
hbc=zhbc(i)/nz(i)
n_koh=NINT(nz(i)/area_factor)
tot_crown_area=tot_crown_area+n_koh*PI*(MIN(spar(taxid)%crown_a*bhd+spar(taxid)%crown_b,spar(taxid)%crown_c))**2
ENDIF
ENDDO
IF(tot_crown_area>1.1*kpatchsize) THEN
corr_la=kpatchsize/tot_crown_area
ELSE
corr_la=1.
ENDIF
DO i=1,ncl1
IF (nz(i).ne.0) THEN
bhd=zbhd(i)/nz(i)
height=zheigh(i)/nz(i)
hbc=zhbc(i)/nz(i)
n_koh=NINT(nz(i)/area_factor)
! --- 4C-specific calculations:
IF(height<1.3) WRITE(4444,*)ngroups(iz)%locid,'bhd ',bhd,'height ',height,'art ',taxid
IF(height*100<h_sapini) THEN
CALL sapini(outunit,taxid, height,hbc, n_koh,age)
WRITE(4444,*)ngroups(iz)%locid,bhd,taxid
ELSE
CALL treeini(outunit,ctrlunit,taxid,source,bhd,height,hbc,n_koh,cform,rsap,age,hlp_lai,corr_la)
ENDIF
ENDIF
ENDDO !cohort loop
2222 CONTINUE
if(datasets=='multi') then
IF (iz.ne.nlines.AND.datasets=='multi'.AND.(istart.NE.ngroups(iz+1)%locid)) WRITE(outunit,*) '-99.9'
end if
2244 CONTINUE
ENDDO !line loop
CLOSE(outunit)
CLOSE(ctrlunit)
RETURN
! ****************************************************************************
! case(6) stand generation if data source is from Bavarian inventories
CASE(6)
print *, ' Forest stand data set: Bavarian inventories'
infile='/data/safe/4C/4C_input/stand/Bayernw.dat'
source='B'
OPEN (inunit, FILE=TRIM(infile), STATUS='old')
listunit=GETUNIT()
OPEN (listunit, FILE='/home/lasch/4c/v0.99e1/input/koord.txt', STATUS='old')
! ------------------------------------------------------------------
! generated standard values of data from data storage based on
! estimation routines of Nagel and Biging (1995), Nagel (1995) and
! Gerold (1990).
! ------------------------------------------------------------------
!
! The following variables are read from forest inventory data:
! Species(baum),Age(alt),Quadratic Mean Diameter(dm),Height of tree with dm(mhoe),
! Basal area(gf),Yield Class(bon),"Ertragsniveau"(en)
!
! ------------------------------------------------------------------
! read in stad data of multiple stands out of records
select_lines=.true.
datasets='multi'
fl_num=0
IF(select_lines) THEN
READ(listunit,*)nlines_comp
ALLOCATE(locid_comp(nlines_comp))
DO i=1,nlines_comp ! reading list of sites to be initialised
READ(listunit,*) locid_comp(i)
ENDDO ! end reading list of sites to be initialised
ENDIF ! end of reading file with sites to be selected
IF(select_lines) CLOSE(listunit)
CALL assign_BAY
CALL init_plenter_param
READ (inunit,*)
READ (inunit,*)nlines
ALLOCATE(ngroups(nlines))
istart=1
READ(inunit,*) dummy, dummy, dummy, ngroups(1)%locid, dummy, &
ngroups(1)%schicht, ngroups(1)%BRAid, dummy, dummy, ngroups(1)%alter, &
dummy, dummy, ngroups(1)%dm, ngroups(1)%mhoe, ngroups(1)%baumzahl, &
ngroups(1)%gf, ngroups(1)%volume, dummy
ngroups(1)%taxid=tax_of_BRA_id(ngroups(1)%BRAid)
ngroups(1)%standsize=40000
IF(ngroups(1)%alter==0.OR.ngroups(1)%mhoe==0.OR.ngroups(1)%dm==0.OR.ngroups(1)%volume==0.OR.ngroups(1)%gf==0) CALL data_gap_fill_DSW(1)
DO i=2,nlines
READ(inunit,*) dummy, dummy, dummy, ngroups(i)%locid, dummy, &
ngroups(i)%schicht, ngroups(i)%BRAid, dummy, dummy, ngroups(i)%alter, &
dummy, dummy, ngroups(i)%dm, ngroups(i)%mhoe, ngroups(i)%baumzahl, &
ngroups(i)%gf, ngroups(i)%volume, dummy
WRITE(*,*) 'set no', i, 'read'
ngroups(i)%taxid=tax_of_BRA_id(ngroups(i)%BRAid)
ngroups(i)%standsize=40000
! preliminary solution: larches mapped to pine
IF(ngroups(i)%taxid==6) ngroups(i)%taxid=3
IF(ngroups(i)%taxid==0) THEN
ELSE
IF(ngroups(i)%alter==0.OR.ngroups(i)%mhoe==0.OR.ngroups(i)%dm==0.OR.ngroups(i)%gf==0) THEN
WRITE(7333,*)'set ',i,'not enough data or below 1.3 m height'
! CALL data_gap_fill_DSW(i)
ENDIF
ENDIF
IF(ngroups(i)%locid.NE.ngroups(istart)%locid) THEN
istart=i
fl_num=fl_num+1
ENDIF
ENDDO ! readin loop for multi data-set
CLOSE(inunit)
! read file headder for description, write in ini-file
cform=1;hlp_lai=0
! initialisation of stand records: area =
! stand area calculated according to partial areas.
area_factor=1
CALL header(outunit,infile,source,cform,rsap,flag_volfunc,-99.)
id=1
WRITE (fnam2,'(a,i1,a)') 'schicht',id,'.tmp'
tmpunit=getunit()
istart=-99
DO iz=1,nlines
ng_locid = ngroups(iz)%locid
taxid=ngroups(iz)%taxid
IF(select_lines) THEN
DO i=1,nlines_comp
IF(locid_comp(i)==ng_locid) GOTO 2255
ENDDO ! comparison of site id to list of sites to be selected
CYCLE
ENDIF ! end of site selection
2255 CONTINUE
IF(datasets=='multi'.AND.(istart.NE.ng_locid)) THEN
WRITE(outunit,*) ng_locid,ngroups(iz)%standsize,'stand identifier, stand area'
istart=ng_locid
aux = ngroups(iz)%standsize/10000.
ENDIF
IF(datasets=='multi'.AND.taxid==0.) THEN
! solution for bushes must be found
WRITE(*,*) 'not the right species'
GOTO 2277
ENDIF
IF(ngroups(iz)%baumzahl<30.AND.ngroups(iz)%baumzahl>0) ngroups(iz)%schicht=5
IF(datasets=='multi'.AND.ngroups(iz)%schicht==5) THEN
! retention trees can be directly initialized since they are not distributed onto different height cohorts
WRITE(4444,*) 'single type ',ngroups(iz)%schicht
age=ngroups(iz)%alter
height=ngroups(iz)%mhoe
bhd=ngroups(iz)%dm
n_koh=ngroups(iz)%baumzahl*aux
hbc=crown_base(height,c1(taxid),c2(taxid),bhd)
CALL treeini(outunit,ctrlunit,taxid,source,bhd,height,hbc,n_koh,cform,rsap,age,hlp_lai,corr_la)
GOTO 2277
ENDIF ! end special treatment of retention trees
IF(datasets=='multi'.AND.ngroups(iz)%dm==0.and.ngroups(iz)%mhoe>h_sapini*0.01) THEN
WRITE(4444,*)'data insufficient for: ',ng_locid,' line: ',iz
GOTO 2277
ENDIF
IF(datasets=='multi'.AND.ngroups(iz)%mhoe<h_sapini*0.01) THEN
height=ngroups(iz)%mhoe
n_koh=ngroups(iz)%baumzahl* aux
age=ngroups(iz)%alter
call ini_gener_sap(outunit, taxid,age,height,n_koh)
GOTO 2277
ENDIF
T=7
age=ngroups(iz)%alter
dg=ngroups(iz)%dm !quadratic mean diameter
hg=ngroups(iz)%mhoe !corresponding height to dg
g=ngroups(iz)%gf !basal area/ha
gpatch=g*4. !basal area/patch
bz=ngroups(iz)%baumzahl*4. !tree numbre/patch
! clwdth=dg/20.
clwdth=dg/5
! selection of uni-height curve: beech, spruce, oak calculation according to Weimann,
! other species of trees after Kuleschis (vergl. Gerold 1990)
IF (taxid==3.OR.taxid==5) THEN
ehkwei=.false.
ELSE
ehkwei=.true.
ENDIF
! zuweisen der PArameterwerte fr Einheitshhenkurve
IF (ehkwei) THEN
! uni-height curve from Weimann (1980)
wei_f=wei_k1(taxid)+wei_k2(taxid)*hg
ELSE
! uni-height curve from Kuleschis (1981)
ku_a=1-(ku_a0(taxid)+ku_a1(taxid)*dg+ku_a2(taxid)*dg**2)
ku_b=ku_b0(taxid)+ku_b1(taxid)*dg+ku_b2(taxid)*dg**2
ku_c=ku_c0(taxid)+ku_c1(taxid)*dg+ku_c2(taxid)*dg**2
ENDIF
IF ((dg-T).lt. 3.0) THEN
T=dg-4.0
IF (T.lt.0.3) T=0.3
ENDIF
! Estimation of Dmax from dg (Gerold 1990)
Dmax=8.2+1.8*dg-0.01*dg**2
IF (dg.le.2) Dmax=dg+2
! Calculation of parameter for Weibull-distribution
! in case b or c is calculated too small,
! p1 and p4 respectively have to be modified
p1n=p1(taxid)
IF (p1n.lt.((1.0001-p0(taxid))/Dg)) p1n=(1.0001-p0(taxid))/Dg
b=p0(taxid)+p1n*Dg
Dmin = 0.1*Dg
IF(Dg>70) Dmin = 2.*Dg - Dmax
p4n=p4(taxid)
IF (p4n.lt.((1.0005-p2(taxid)-p3(taxid)*Dg)/Dmax)) p4n=(1.0005-p2(taxid)-p3(taxid)*Dg)/Dmax
c=p2(taxid)+p3(taxid)*Dg+p4n*Dmax
anzit=0
thdmax=5.0
helpz=0
DO
imax=INT((Dmax-Dmin)/clwdth)
if(imax.gt.30) then
imax= 30
clwdth= (Dmax-Dmin)/30.
end if
if(helpz.gt.50) goto 2277
helpz= helpz + 1
Fint(0)=0.
gx=0.
bhd=Dmin+0.5*clwdth
DO i = 1,imax
Fint(i)=1-exp(-((bhd-Dmin)/b)**c)
gx=gx+(Fint(i)-Fint(i-1))*bhd**2
bhd=bhd+clwdth
END DO
gx=gx*PI/4*1e-4*bz
IF(ABS(gx-gpatch)>0.02*gpatch) THEN
IF(gx>gpatch) THEN
c=c*gpatch/gx
ELSE
IF(Dmin<0.8*Dg) THEN
Dmin=Dmin*1.05
ELSE
c=c*gx/gpatch
ENDIF
ENDIF
ELSE
EXIT
ENDIF
END DO
bhd=Dmin+0.5*clwdth
DO i = 1,imax
n_koh=NINT((Fint(i)-Fint(i-1))*bz)
!***calculate height according to uni-height curve
IF (ehkwei) THEN
! uni-height curve from Weimann (1980)
IF (bhd.ge.(dg-hg/2.)) THEN
height=hg+wei_f*(log(hg-dg+bhd)-log(hg))
ELSE
height=(hg+wei_f*(log(hg/2.)-log(hg))-1.3)*(bhd/(dg-hg/2.))**0.5+1.3
ENDIF
ELSE
! uni-height curve from Kuleschis (1981)
height=hg*(ku_a+(ku_b/(bhd+dg/2.))*dg+(ku_c/(bhd+dg/2.)**2)*dg**2)
ENDIF
! solution for small stands; tree dimensions below 3 m = rubbish
IF (height.gt.(bhd*3.)) height=bhd*3.
IF (height.lt.1.35) height=1.35+bhd
hbc=crown_base(height,c1(taxid),c2(taxid),bhd)
IF ((height-hbc).lt. 0.5) hbc= height - 0.5
CALL treeini(outunit,ctrlunit,taxid,source,bhd,height,hbc,n_koh,cform,rsap,age,hlp_lai,corr_la)
if(fail.eq.1) write(4444,*) 'negative root in newton', ng_locid,iz
bhd=bhd+clwdth
END DO
2277 CONTINUE
IF (iz.ne.nlines.AND. datasets=='multi'.AND.(istart.NE.ngroups(iz+1)%locid)) WRITE(outunit,*) '-99.9'
2266 CONTINUE
ENDDO !sign loop
CLOSE(outunit)
CLOSE(ctrlunit)
RETURN
CASE(2)
334 CONTINUE
CALL assign_DSW
inwahl=0
source='S'
PRINT *, 'If you want to use SILVA data, type: 1'
PRINT *, 'If you want to use levelII data from Sachsen, type: 2'
PRINT *, 'If you want to use single tree data with tree class information, type: 3'
PRINT *, ' if you want to use data like level II single tree data and generate one tree cohorts, type: 4'
READ(*,*) inwahl
IF (inwahl<1.OR.inwahl>4) THEN
WRITE(*,*) 'You should use integer 1, 2,3 or 4 for the choice of data source'
GOTO 334
ENDIF
333 CONTINUE
IF (inwahl==1) PRINT *, ' Forest stand data set: SILVA (classification must be performed)'
IF (inwahl==2) PRINT *, ' Forest stand data set: levelII Sachsen (classification must be performed)'
IF (inwahl==3) PRINT *, ' Forest stand data set: single tree data with tree type information (classification must be performed)'
IF (inwahl==4) PRINT *, ' Forest stand data set: single tree data without clissification'
WRITE(*,'(A)')
WRITE(*,'(A)')' Do you want to read the input file from '
WRITE(*,'(A)')' 1 - the Standard 4C stand directory on data/safe/4C/4C_input/stand'
WRITE(*,'(A)')' 2 - or do you want to specify another directory?'
WRITE(*,'(A)',advance='no') ' ***Make your choice: '
READ(*,*) dir_flag
IF(dir_flag.EQ.1) THEN
WRITE(*,'(A)',advance='no')' Input file: '
READ (*,'(A)') infile
ELSEIF(dir_flag.EQ.2) THEN
WRITE(*,'(A)',advance='no')' Input directory and file: '
READ (*,'(A)') infile
ELSE
WRITE(*,*) 'You should use integer 1 or 2 for the choice of the input mode. Please try again!'
GOTO 333
ENDIF
337 CONTINUE
cform=1;hlp_lai=0
IF(dir_flag.EQ.1) OPEN (inunit,FILE='/data/safe/4C/4C_input/stand/'//trim(infile),STATUS='old')
IF(dir_flag.EQ.2) OPEN (inunit,FILE=trim(infile),STATUS='old')
! initialising for stand records: area = 1ha
area=10000
IF(inwahl==2.OR.inwahl==3.OR.inwahl==4) THEN
! class width
clwdth=1 !set diameter of classes width
READ(inunit,'(a85)')zeile
READ(inunit,*) area
READ(inunit,'(a85)')zeile
ENDIF
area_factor = 1.
kpatchsize = area
! read in file headder for descriptions, write in ini-file
CALL header(outunit,infile,source,cform,rsap,flag_volfunc,kpatchsize)
! classification of single values into diameter cohorts
IF(inwahl==1) THEN
READ(inunit,'(a85)')zeile
READ(inunit,'(a85)')zeile
ENDIF
335 CONTINUE
DO i=1,ncl1
nz(i)=0
zbhd(i)=0
zheigh(i)=0
zhbc(i)=0
ENDDO
nhelp=0
DO
IF(inwahl==1) READ(inunit,*,IOSTAT=ios)xnr,baumid,bhd,height,hbc,kd,xxr,xyr,xxi,xyi
IF(inwahl==2.or.inwahl.eq.4) THEN
READ(inunit,*,IOSTAT=ios)xnr,taxid,bhd,height,hbc,age
nhelp = nhelp+1
if(bhd.le.10) bhd=11.
bhd=bhd/10.
IF(hbc>-99.99.AND.hbc<-99.8) THEN
hbc=crown_base(height,c1(taxid),c2(taxid),bhd)
IF(height-hbc<0.5) CALL error_mess(time,"crown to shallow in tree",REAL(xnr))
ENDIF
ENDIF
IF(inwahl==3) THEN
READ(inunit,*,IOSTAT=ios)xnr,taxid,bhd,height,hbc,ager,status
IF(taxid>=100) taxid=tax_of_BRA_id(taxid)
age = INT(ager)
bhd=bhd/10.
IF(hbc>-99.99.AND.hbc<-99.8) THEN
hbc=crown_base(height,c1(taxid),c2(taxid),bhd)
IF(height-hbc<0.5) CALL error_mess(time,"crown to shallow in tree",REAL(xnr))
IF((height-hbc)/height<0.5) hbc=0.5*height
IF(bhd<=3.) hbc=0.
ENDIF
ENDIF
IF (ios<0) exit
IF (xnr==-9999) exit
IF (inwahl==4) exit
icl=INT(bhd/clwdth)+1
IF(inwahl.eq.4.or.(inwahl==3.AND.status.NE.'F'.AND.status.NE.'Z'.AND.status.NE.'V'.and.status.NE.'H'.and.status.NE.'U'.and. status.NE.'B'))THEN
ELSE
IF(icl.gt.ncl1) icl=ncl1
nz(icl)=nz(icl)+1 !sum stem numbre of diameter class
zbhd(icl)=zbhd(icl)+bhd !sum up the diameters of a class
zheigh(icl)=zheigh(icl)+height !sum up height value of a class
zhbc(icl)=zhbc(icl)+hbc !sum up crown startin height of a class
ENDIF
ENDDO
nzsum=sum(nz)
IF(inwahl.ne.4) THEN
tot_crown_area=0.
DO i=1,ncl1
IF (nz(i).ne.0) THEN
bhd=zbhd(i)/nz(i)
height=zheigh(i)/nz(i)
hbc=zhbc(i)/nz(i)
if(hbc<0.025) hbc = 0.
if(hbc>=0.025.and.hbc<0.05) hbc =0.05
n_koh=NINT(nz(i)/area_factor)
IF(inwahl==1) THEN
SELECT CASE(baumid)
CASE(5)
taxid=1
CASE(1)
taxid=2
CASE(3)
taxid=3
CASE default
taxid=99
END select
ENDIF
tot_crown_area=tot_crown_area+n_koh*PI*(MIN(spar(taxid)%crown_a*bhd+spar(taxid)%crown_b,spar(taxid)%crown_c))**2
ENDIF
ENDDO
IF(tot_crown_area>1.1*kpatchsize) THEN
corr_la=kpatchsize/tot_crown_area
ELSE
corr_la=1.
ENDIF
IF(pass==1) THEN
mixed_tot_ca = mixed_tot_ca + tot_crown_area
ELSE
corr_la=kpatchsize/mixed_tot_ca
ENDIF
DO i=1,ncl1
IF (nz(i).ne.0) THEN
bhd=zbhd(i)/nz(i)
height=zheigh(i)/nz(i)
hbc=zhbc(i)/nz(i)
if(hbc<0.025) hbc = 0.
if(hbc>=0.025.and.hbc<0.05) hbc =0.05
n_koh=NINT(nz(i)/area_factor)
IF(inwahl==1) THEN
SELECT CASE(baumid)
CASE(5)
taxid=1
CASE(1)
taxid=2
CASE(3)
taxid=3
CASE default
taxid=99
END select
ENDIF
! --- 4C-specific calculation:
WRITE(*,*) 'call :', taxid,bhd,height,hbc,nz(i),n_koh
IF( height<(h_sapini/100.)) then
call sapini(outunit,taxid, height, hbc, n_koh,age)
ELSE
CALL treeini(outunit,ctrlunit,taxid,source,bhd,height,hbc,n_koh,cform,rsap,age,hlp_lai,corr_la)
ENDIF
ENDIF
ENDDO
else if(xnr.ne.-999) then
n_koh = 1
print*, 'xnr:', xnr
IF( height<(h_sapini/100.)) then
call sapini(outunit,taxid, height, hbc, n_koh,age)
ELSE
CALL treeini(outunit,ctrlunit,taxid,source,bhd,height,hbc,n_koh,cform,rsap,age,hlp_lai,corr_la)
ENDIF
end if
IF (xnr==-9999) GOTO 335
if(inwahl==4.and.xnr==-999) then
CLOSE(inunit)
CLOSE(outunit)
CLOSE(ctrlunit)
RETURN
end if
if(inwahl==4) goto 335
CLOSE(inunit)
CLOSE(outunit)
IF(mixed_tot_ca>1.1*kpatchsize .AND. pass == 1) THEN
OPEN (outunit,FILE=TRIM(treefile(ip)),STATUS='replace')
pass = 2
GOTO 337
ENDIF
CLOSE(ctrlunit)
RETURN
CASE(3)
444 print *, ' Forest stand data set: Level2-Daten'
source='L'
WRITE(*,'(A)')
WRITE(*,'(A)')' Do you want to read the input file from '
WRITE(*,'(A)')' 1 - the Standard 4C stand directory on data/safe/4C/4C_input/stand'
WRITE(*,'(A)')' 2 - or do you want to specify another directory?'
WRITE(*,'(A)',advance='no') ' ***Make your choice: '
READ(*,*) dir_flag
IF(dir_flag.EQ.1) THEN
WRITE(*,'(A)',advance='no')' Input file: '
READ (*,'(A)') infile
ELSEIF(dir_flag.EQ.2) THEN
WRITE(*,'(A)',advance='no')' Input directory and file: '
READ (*,'(A)') infile
ELSE
WRITE(*,*) 'You should use integer 1 or 2 for the choice of the input mode. Please try again!'
GOTO 444
ENDIF
cform=1;hlp_lai=0
IF(dir_flag.EQ.1) OPEN (inunit,FILE='/data/safe/4C/4C_input/stand/'//trim(infile),STATUS='old')
IF(dir_flag.EQ.2) OPEN (inunit,FILE=trim(infile),STATUS='old')
!------------------------------------------------------------------
! Read in level II data according to diamter classes
READ(inunit,'(a85)')zeile
READ(inunit,'(a85)')zeile
READ(inunit,'(a85)')zeile
READ(inunit,*)age,taxid,area, rsap, &
dclmin, & !smallest diameter of experimentation patches
ndcl, & !amount diameter class
dcwdth !class width
READ(inunit,*)h_para,h_parb, & !parameter of height function after Lockow
(n_dc(i),i=1,ndcl) !stem numbre per diameter class
close(inunit)
clwdth=dcwdth
! ---------------------------------------------------------------------
! current patch size = value specified by kpatchsize
area_factor=int(area/kpatchsize)
! read in file headder for desciption, write into ini-file
CALL header(outunit,infile,source,cform,rsap,flag_volfunc,kpatchsize)
DO i=1,ncl1
nz(i)=0
zbhd(i)=0
zheigh(i)=0
zhbc(i)=0
ENDDO
bhdcl=dclmin
DO i=1,ndcl
bhd=bhdcl
height=h_para*(0.01*bhd)**h_parb !height function after regression from Lockow
hbc=crown_base(height,c1(taxid),c2(taxid),bhd)
IF ((height-hbc).lt. 0.5) hbc= height - 0.5
icl=INT(bhd/clwdth)+1
IF(icl.gt.ncl1) icl=ncl1
nz(icl)=nz(icl)+n_dc(i) !sum stem numbre of diameter class
zbhd(icl)=zbhd(icl)+bhd*n_dc(i) !sum up diameters of a class
zheigh(icl)=zheigh(icl)+height*n_dc(i) !sum up height values of a class
zhbc(icl)=zhbc(icl)+hbc*n_dc(i) !sum up crown starting height of a class
bhdcl=bhdcl+dcwdth
ENDDO
smaldc(1)=.false.
DO i=1,ncl1
IF (smaldc(i)) THEN
IF (i<ncl1) smaldc(i+1)=.true.
ELSE
IF (i<ncl1) smaldc(i+1)=.false.
n_koh=NINT(nz(i)/area_factor)
IF (n_koh>0) THEN
IF (i<ncl1) smaldc(i+1)=.true.
ENDIF
ENDIF
ENDDO
bigdc(ncl1)=.false.
DO i=ncl1,1,-1
IF (bigdc(i)) THEN
IF (i>1) bigdc(i-1)=.true.
ELSE
IF (i>1) bigdc(i-1)=.false.
n_koh=NINT(nz(i)/area_factor)
IF (n_koh>0) THEN
IF (i>1) bigdc(i-1)=.true.
ENDIF
ENDIF
ENDDO
DO i=1,ncl1
IF (nz(i).ne.0) THEN
n_koh=NINT(nz(i)/area_factor)
IF (n_koh==0) THEN !if no trees in cohorte, shift trees to next class
zbhd(i+1)=zbhd(i+1)+zbhd(i) !add diameter to sum of next class
zheigh(i+1)=zheigh(i+1)+zheigh(i) !add height to sum of next class
zhbc(i+1)=zhbc(i+1)+zhbc(i) !add hbc to sum of next class
nz(i+1)=nz(i+1)+nz(i) !add trees to next class
nz(i)=0 !empty class
ELSE
bhd=zbhd(i)/nz(i)
height=zheigh(i)/nz(i)
hbc=zhbc(i)/nz(i)
! --- 4C-specific calculations:
CALL treeini(outunit,ctrlunit,taxid,source,bhd,height,hbc,n_koh,cform,rsap,age,hlp_lai,corr_la)
ENDIF
ENDIF
IF (.not.bigdc(i+1)) exit
ENDDO
DO j=ncl1,(i+1),-1
IF (nz(j).ne.0) THEN
n_koh=NINT(nz(j)/area_factor)
IF (n_koh==0) THEN !if no trees in cohorte, shift trees to next class
zbhd(j-1)=zbhd(j-1)+zbhd(j) !add diameter to sum of next class
zheigh(j-1)=zheigh(j-1)+zheigh(j) !add height to sum of next class
zhbc(j-1)=zhbc(j-1)+zhbc(j) !add hbc to sum of next class
nz(j-1)=nz(j-1)+nz(j) !add trees to next class
nz(j)=0 !empty class
ELSE
bhd=zbhd(j)/nz(j)
height=zheigh(j)/nz(j)
hbc=zhbc(j)/nz(j)
! --- 4C-specific calculation:
CALL treeini(outunit,ctrlunit,taxid,source,bhd,height,hbc,n_koh,cform,rsap,age,hlp_lai,corr_la)
ENDIF
ENDIF
IF (.not. smaldc(i)) exit
ENDDO
CLOSE(outunit)
CLOSE(ctrlunit)
RETURN
CASE(4)
WRITE(*,*) 'Do you want to use the standard procedure - type: S'
WRITE(*,*) 'or Manfred Lexers input format - type: L'
READ(*,*) source
WRITE(*,'(A)',advance='no')' Input file: '
READ(*,'(A)') infile
cform=1;hlp_lai=0
IF(flag_volfunc.EQ.0) THEN
WRITE(*,'(A)',advance='no')' Input form factor (Default in 4C = 1): '
READ *, cform
ENDIF
OPEN (inunit,FILE=TRIM(infile),STATUS='old')
! read in data from input-file
IF (source=='S') THEN
READ(inunit,*)source, taxid, rsap
READ(inunit,*) area
READ(inunit,*,END=10)n,k,age
area_factor = 1.
CALL header(outunit,infile,source,cform,rsap,flag_volfunc,kpatchsize)
!read in data
DO i=1,k
READ(inunit,*,END=10)bhd,height,share,hbc
IF(hbc>-99.99.AND.hbc<-99.8) THEN
hbc=crown_base(height,c1(taxid),c2(taxid),bhd)
END IF
n_koh = NINT(share*n)
CALL treeini(outunit,ctrlunit,taxid,source,bhd,height,hbc,n_koh,cform,rsap,age,hlp_lai,corr_la)
ENDDO
ELSE
READ(inunit,*) area
kpatchsize= area
CALL header(outunit,infile,source,cform,rsap,flag_volfunc,kpatchsize)
!read in data
DO
READ(inunit,*,iostat=ios)bhd,taxid,height,n_koh,age
if(ios < 0) exit
IF(height.ne.0 .AND. n_koh.ne.0) then
IF(height<h_sapini*0.01) then
CALL ini_gener_sap(outunit,taxid,age,height,n_koh)
else
hbc=crown_base(height,c1(taxid),c2(taxid),bhd)
CALL treeini(outunit,ctrlunit,taxid,source,bhd,height,hbc,n_koh,cform,rsap,age,hlp_lai,corr_la)
end if
ENDIF
ENDDO
ENDIF
10 continue
PRINT*, 'Bestandesblattflche (pro ha): ', hlp_lai*area_factor
CLOSE(inunit)
CLOSE(outunit)
CLOSE(ctrlunit)
! FORGRA data input
CASE(5)
WRITE(*,'(A)',advance='no')' Input file: '
READ(*,'(A)') infile
cform=1;hlp_lai=0
IF(flag_volfunc.EQ.0) THEN
WRITE(*,'(A)',advance='no')' Input form factor (Default in 4C = 1): '
READ *, cform
ENDIF
OPEN (inunit,FILE=TRIM(infile),STATUS='old')
! read in data from input file
READ(inunit,*)source, rsap
READ(inunit,*) area
READ(inunit,*,END=20)n,k
area_factor=int(area/kpatchsize)
CALL header(outunit,infile,source,cform,rsap,flag_volfunc,kpatchsize)
!read in data
DO i=1,k
READ(inunit,*,END=20)bhd,height,share,hbc,age,taxid
n_koh=NINT(share*n/area_factor)
IF(height<h_sapini) THEN
CALL sapini(outunit,taxid, height,hbc, n_koh,age)
ELSE
CALL treeini(outunit,ctrlunit,taxid,source,bhd,height,hbc,n_koh,cform,rsap,age,hlp_lai,corr_la)
ENDIF
ENDDO
20 CONTINUE
CLOSE(outunit)
CLOSE(ctrlunit)
CASE default
PRINT *,' False number'
RETURN
END select
WRITE(*,*) 'initialisation terminated'
deallocate (zheigh, zbhd, zhbc, nz)
deallocate (smaldc, bigdc)
if (allocated(locid_comp))deallocate(locid_comp)
END subroutine initia
!****************************!
!* SUBROUTINE TREEINI *!
!****************************!
SUBROUTINE treeini(outunit,ctrlunit,taxid,source,bhd,height,hbc,n_koh,cform,rsap,age,hlp_lai,corr_la)
! Species (taxid) must be handed over (Beech 1, Spruce 2, Pine 3, Oak 4)
! Source is specifying data source
! height and hbc are read in meter and is converted later to cm
! n_koh numbre of trees in a cohort
! -------------------------------------------------------------------------
USE data_init
USE data_par
USE data_simul
USE data_species
USE data_stand
USE data_help
IMPLICIT none
! ----VARIABLEN---
REAL :: bhd,height,hbc,hlp_lai,hfd,vd,VS,Vg,k1,k2,k3,hm,Ahc,Veff,dbc,corr_la
REAL :: swheight,stembio,afol,asap,dbase, dcbase,volratio,d1,d2,h1,h2,a1,b0, x_ges
INTEGER :: taxid, & ! species number
age, & ! tree age
n_koh
INTEGER :: outunit,ctrlunit !units
CHARACTER*85 zeile
CHARACTER(75):: infile
CHARACTER :: source
REAL rsap, cform, sicrsap, lifrac, rsapfit
INTEGER taumax, ring
! function
REAL newton
sicrsap=rsap
! since the fraction of wood which is sapwood generally is not measured at the
! plots for which the model is initialized, it needs to be approximated
! the following rsap initialisation has been fitted to a pine run at Kienhorst
rsapfit=1.-1.544e-8*age**4+4.343e-6*age**3-3.359e-4*age**2-4.557e-4*age
! estimation of rsap from average diameter increase
! attention: age of tree when first ring has been grown at 1.3 m must be estimated
! for the time being this is set to 5
! If hbc < h_breast, rsap and Asap (below) have to be calculated at lower height
hm=height
height=height*100
hbc=hbc*100
lifrac=1.-spar(taxid)%pss
IF(age>6) THEN
IF(hbc<h_breast) THEN
taumax=age-INT(hbc/h_breast*5.)
ELSE
taumax=age-5
ENDIF
rsap=0.
DO ring = 0,taumax-1
rsap=rsap+exp(ring*log(lifrac))*(2.*(taumax-ring)-1.)
END DO
rsap=rsap/taumax**2
ELSE
rsap=1.
ENDIF
rsap=rsap*corr_la
! --- calculate height of Sapwood-Pipes and stem-mass
swheight=2.*hbc/3.+height/3.
if(taxid.ne.12. .and. taxid.ne.13) then
if(taxid.eq.10) then
! after BWINpro , Bergel 1974
hfd = (-200.31914/(height*bhd*bhd))+(0.8734/bhd) - 0.0052*log(bhd*bhd) + 7.3594/(height*bhd) + 0.46155
else
k1=par_S(taxid,1)+par_S(taxid,2)*log(bhd)+par_S(taxid,3)*log(bhd)**2
k2=par_S(taxid,4)+par_S(taxid,5)*log(bhd)+par_S(taxid,6)*log(bhd)**2
k3=par_S(taxid,7)+par_S(taxid,8)*log(bhd)+par_S(taxid,9)*log(bhd)**2
hfd=exp(k1+k2*log(hm)+k3*log(hm)**2)
end if
! vd volume with SILVA equations
vd=(hfd*pi*bhd**2)/40000
else
! Eucalyptus, Binkley et al 2002
vd = 0.00005447*bhd**1.921157*(height/100)**0.950581
! Stape et. al 2010 Fkt. VER
vd = (0.027*bhd**2.221*(height/100)**0.625)/500
! Stape et al 2010 Fkt ARA
vd = (0.004*bhd**1.959*(height/100)**1.512)/500
end if
! vs volume with Eberswalde equations
if(taxid.eq.3) vs = exp(parEBW(10,1)+parEBW(10,2)*log(bhd)+parEBW(10,3)*log(hm))
IF(taxid==3) vd = vs
IF(flag_volfunc.EQ.0) THEN
IF(source.ne.'S') stembio= swheight*spar(taxid)%prhos*cform*pi*(bhd/2.)**2
IF(source.eq.'S') THEN
stembio=vd*spar(taxid)%prhos*1000000
bhd= SQRT(stembio*4/(swheight*spar(taxid)%prhos*cform*pi))
ENDIF
! --- seperation of sap wood and heartwood and sap wood cross section
x_Ahb= 0.
x_sap=rsap*stembio
x_hrt=(1-rsap)*stembio
asap=rsap*pi*(bhd/2.)**2
! --- estimation of leafe matter and leave area
x_fol=asap*spar(taxid)%pnus
afol=x_fol*(spar(taxid)%psla_min+0.5*spar(taxid)%psla_a)
hlp_lai=hlp_lai+afol*n_koh
! --- fine root matter roughly estimated
x_frt=x_fol
IF(n_koh>0) WRITE(outunit,'(5f12.5,2f10.0,3i7)')x_fol,x_frt,x_sap,x_hrt,x_Ahb,height,hbc,age,n_koh,taxid
ELSEIF(flag_volfunc.EQ.1) THEN
IF (hbc>h_breast.AND.hbc<h_breast+h_bo_br_diff) hbc=h_breast
IF (hbc==h_breast) dbc=bhd
IF (hbc<h_breast) THEN
dbc=bhd/height*(h_breast-hbc)+bhd ! dbc = diameter at base of the crown
asap=PI/4.*dbc**2.*rsap
ELSE
asap=PI/4.*bhd**2.*rsap !change Martin bhd>>dbc as written ins description and rsap weg
ENDIF
rsap = asap/((pi*bhd*bhd)/4)
x_sap=spar(taxid)%prhos*asap*swheight
! first guess for start values of Ahc
IF (hbc<=h_breast) THEN
Ahc=PI/4.*dbc**2.-asap
x_Ahb=PI/4.*(dbc*age/taumax)**2.-asap
ELSE
Ahc=PI/4.*bhd**2.*(1.-rsap)*0.04
Ahc=Newton(Ahc,asap,bhd,hbc,height,Vd)
if(fail.eq.1) return
x_Ahb=PI/4.*((bhd-(4./PI*(asap+Ahc))**0.5*h_breast/hbc)/(1.-h_breast/hbc))**2-asap
ENDIF
! Vg for test purposes = volume if no heartwood in crown space
Vg=1./3.*height*asap+2./3.*hbc*asap+1./3.*hbc*x_Ahb
! --- seperation of sap wood and heartwood and splitting of sap wood cross section
stembio=spar(taxid)%prhos*(1./3.*height*(asap+Ahc)+1./3.*hbc*(2.*asap+x_ahb+(x_ahb*ahc)**0.5))
volratio=1.0
if(infile=='input/bwi2_blmwert1.prn') then
!Spruce
if(taxid.eq.2)then
!after Wirth et al. 2002 Tree physiology
b0=-2.83958
d1=2.55203
d2=-0.14991
h1=-0.19172
h2=0.25739
a1=-0.08278
volratio=(exp(b0+d1*log(bhd)+d2*(log(bhd))**2+h1*log(height/100)+h2*(log(height/100))**2+a1*log(age+0.01)))/stembio
endif
!Pine
if(taxid.eq.3)then
!after Zianis et al. 2005 Silva Fennica EFI BEFs Europe
volratio=exp(-2.6768+7.5939*(bhd/(bhd+13))+0.0151*height/100+0.8799*log(height/100))/stembio
endif
!for douglas fir (correction after bartelink 1996, forest ecol. manag.)
if(taxid.eq.10)then
volratio=exp(-3.229+1.901*log(bhd)+0.807*log(height/100))/stembio
endif
end if
x_sap=x_sap*volratio
x_hrt=stembio*volratio-x_sap
x_ges=x_hrt+x_sap
x_Ahb=x_Ahb*volratio
asap=asap*volratio
if (x_hrt/x_ges .gt. 0.5 .and. taxid .eq. 2 .and. age .gt. 100) then !query too heigh heart wood percentage
x_hrt=0.5*stembio*volratio
x_sap=0.5*stembio*volratio
endif
if (x_hrt/x_ges .gt. 0.35 .and. taxid .eq. 3 .or. taxid .eq. 10) then !query too heigh heart wood percentage
x_hrt=0.35*stembio*volratio
x_sap=0.65*stembio*volratio
endif
Veff=(1./3.*height*(asap+Ahc)+1./3.*hbc*(2.*asap+x_ahb+(x_ahb*ahc)**0.5))*0.000001
dbase = ((x_Ahb+asap)*4./PI)**0.5
dcbase = ((Ahc+asap)*4./PI)**0.5
WRITE(ctrlunit,'(2I5, 12F12.5)') n_koh,age,height,hbc,bhd,rsap,dbase,dcbase,asap,ahc,x_ahb,Vg/1000000,Vd,Veff
! --- estimation leaf matter and leaf area
x_fol=asap*spar(taxid)%pnus*volratio
afol=x_fol*(spar(taxid)%psla_min+0.5*spar(taxid)%psla_a)
hlp_lai=hlp_lai+afol*n_koh
! --- fine root matter rough estimate
x_frt=x_fol
IF(n_koh>0) WRITE(outunit,'(5f12.5,2f10.0,3i7, 2f12.5)')x_fol,x_frt,x_sap,x_hrt,x_Ahb,height,hbc,age,n_koh,taxid, dcbase,bhd
ENDIF
END subroutine treeini
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! SUBROUTINE SAPINI !
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! initilization of seedling cohorts with given height according to relations used in growth_seed
SUBROUTINE sapini(outunit,taxid, height, hbc, n_koh,iage)
USE data_species
USE data_stand
use data_help
IMPLICIT none
REAL :: height,hbc,hhelp
INTEGER :: outunit,n_koh ,taxid,iage
REAL :: x1,x2,xacc,shelp
real :: rtflsp, sapwood
external sapwood
external rtflsp
! Shootbiomass kg from height (cm), originally x_sap [mg]
hhelp = height * 100.
IF (taxid.ne.2) x_sap = exp(( LOG(hhelp)-LOG(spar(taxid)%pheight1))/spar(taxid)%pheight2)/1000000.
IF (taxid.eq.2) THEN
x1 = 1.
x2 = 2.
xacc=(1.0e-10)*(x1+x2)/2
! solve equation for calculation of sapwood from height; determine root
heihelp = hhelp
hnspec = taxid
shelp=rtflsp(sapwood,x1,x2,xacc)
x_sap = (10**shelp)/1000000 ! transformation mg ---> kg
ENDIF
! leaf matter
x_fol = (spar(taxid)%seeda*(x_sap** spar(taxid)%seedb)) ![kg]
! fine root matter rough estimate
x_frt = x_fol
! cross sectional area of heartwood
x_ahb = 0.
x_hrt = 0.
IF(n_koh>0) WRITE(outunit,'(5f12.5,2f10.0,3i7)')x_fol,x_frt,x_sap,x_hrt,x_Ahb,hhelp,hbc,iage,n_koh,taxid
END subroutine sapini
FUNCTION ran0(idum)
INTEGER idum,IA,IM,IQ,IR,MASK
REAL ran0,AM
PARAMETER (IA=16807,IM=2147483647,AM=1./IM,IQ=127773,IR=2836,MASK=123459876)
INTEGER kran
idum=ieor(idum,MASK)
kran=idum/IQ
idum=IA*(idum-kran*IQ)-IR*kran
IF (idum.lt.0) idum=idum+IM
ran0=AM*idum
idum=ieor(idum,MASK)
RETURN
END
! (C) Copr. 1986-92 Numerical Recipes Software 0)+0143$!-.
SUBROUTINE header(outunit,infile,source,cform,rsap,flag_volfunc,patchsize)
! write file headder into ini-file
INTEGER :: outunit, flag_volfunc
REAL :: rsap, cform, patchsize
CHARACTER(75) :: infile
CHARACTER :: source
WRITE(outunit,'(I1,1F12.0,A32)')flag_volfunc,patchsize,' ! = volume function, patch size'
WRITE(outunit,'(A15,A1,A13,A80)') '! data source= ',source,' source file= ',infile
WRITE(outunit,'(A57)') '! sapwood fraction and form factor now dynamic per cohort '
WRITE(outunit,'(a37)')'! 4C Tree Initialization File (Stand)'
WRITE(outunit,'(a1)')'!'
WRITE(outunit,'(a51)')'! contains the following data (single tree values):'
WRITE(outunit,'(a1)')'!'
WRITE(outunit,'(a31)')'! x_fol: foliage biomass (kg)'
WRITE(outunit,'(a33)')'! x_frt: fine root biomass (kg)'
WRITE(outunit,'(a31)')'! x_sap: sapwood biomass (kg)'
WRITE(outunit,'(a33)')'! x_hrt: heartwood biomass (kg)'
WRITE(outunit,'(a65)')'! x_Ahb: cross sectional area of heartwood at stem base (cm**2)'
WRITE(outunit,'(a27)')'! height: tree height (cm)'
WRITE(outunit,'(a27)')'! x_hbole: bole height (cm)'
WRITE(outunit,'(a27)')'! x_age: tree age (years)'
WRITE(outunit,'(a26)')'! n: number of trees'
WRITE(outunit,'(a35)')'! sp: species (integer number)'
WRITE(outunit,'(a33)')'! DC: diameter at crown base'
WRITE(outunit,'(a37)')'! DBH: diameter at breast height'
WRITE(outunit,'(a1)')'!'
WRITE(outunit,'(a120)')'! x_fol x_frt x_sap x_hrt x_Ahb height x_hbole x_age n sp DC DBH'
END subroutine header
FUNCTION crown_base(height,c1,c2,bhd)
IMPLICIT NONE
REAL crown_base
REAL height,bhd,c1,c2
!--- estimate crown starting height according to Nagel (1995)
crown_base=height*(1.-exp(-1.*(c1+c2*height/bhd)**2))
END function crown_base
Function crown_base_eg(height,bhd)
IMPLICIT NONE
real crown_base_eg
real height, bhd
! after Nutto etal. 2006
crown_base_eg= -5.12 -0.407*bhd + 1.193*height
if ( crown_base_eg.lt. 0.) crown_base_eg = 0.
END function crown_base_eg
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
SUBROUTINE fdfahc(X,F,DF,asap,bhd,hbc,height,Vd,J)
USE data_par
USE data_simul
use data_help
IMPLICIT none
REAL X,F,DF,asap,bhd,hbc,height,Vd,C,dCdX
INTEGER J
fail=0
IF (asap+X.LE.0) THEN
WRITE(*,*) 'negative root at calculation C in fdfahc, program will stop'
STOP
ENDIF
C=(bhd-(4./PI*(asap+X))**0.5*h_breast/hbc)/(1.-h_breast/hbc)
dCdX=(-h_breast)/hbc/(1.-h_breast/hbc)/(4./PI*(asap+X))**0.5*2./PI
IF (X*(PI/4.*C**2.-asap).LE.0) THEN
fail=1
return
ENDIF
F=1./3.*height*(asap+X)+1./3.*hbc*(asap+PI/4.*C**2.+(X*(PI/4.*C**2.-asap))**0.5)-Vd*1000000.
DF=1./3.*(height+hbc*PI/2.*C*dCdX+hbc*0.5/(X*(PI/4.*C**2.-asap))**0.5*(PI/4.*C**2+X*PI/2.*C*dCdX-asap))
END subroutine fdfahc
FUNCTION NEWTON(X,asap,bhd,hbc,height,Vd)
use data_help
IMPLICIT NONE
REAL newton
REAL F,DF,X,DX,asap,bhd,hbc,height,Vd
INTEGER J,stepmax
! Newton is to be called with a start value for X
! a subroutine NEWFDF is to be included in the main program which
! calculates the value of the function and its derivative at X and
! returns them in the variables F and DF
PARAMETER (stepmax=5000)
DO 7 J=1,stepmax
CALL fdfAhc(X,F,DF,asap,bhd,hbc,height,Vd,J)
if(fail.eq.1) return
IF(DF.EQ.0.0) THEN
DX=0.01*X
ELSE
DX=F/DF
ENDIF
Newton=X
IF(DX.GT.X) DX=X/2.
X=X-DX
IF(ABS(DX).LT.0.0005) RETURN
7 END DO
END
SUBROUTINE ini_gener_sap(outunit,taxid,age,pl_height, nplant)
USE data_stand
USE data_par
USE data_species
USE data_soil
USE data_help
USE data_plant
USE data_manag
IMPLICIT NONE
integer :: nplant, &
taxid, &
nclass, &
i,nr, &
age, &
outunit
real :: pl_height, &
height, &
hhelp, &
hbc, &
sdev, &
help, &
nstot
real :: rtflsp, sapwood
real :: hmin_est ! empirical estimated minimum height
real, dimension(:), allocatable :: hei, &
nschelp
integer,dimension(:),allocatable :: nsc
external sapwood
external rtflsp
sdev = hsdev(taxid)
if (nplant.eq.0) nplant= numplant(taxid)
height = pl_height*100
if(height .lt. 100) then
hmin_est = height - height*0.2
else
hmin_est = height - height*0.1
end if
if(nplant.eq.1) hmin_est = height
nclass= nint((height+2*sdev) - hmin_est) + 1
if(nplant.eq.1) nclass =1
if(nplant.lt.200) nclass=1
allocate(hei(nclass))
allocate(nschelp(nclass))
allocate(nsc(nclass))
nstot = 0
help = (1/(sqrt(2*pi)*sdev))
do i = 1, nclass
! height per class
hei(i) = hmin_est + (i-1)
nschelp(i) = help*exp(-((hei(i)-height)**2)/(2*(sdev)**2))
nstot = nstot + nschelp (i)
end do
! scaling of plant number per cohort
do i = 1,nclass
nsc(i) = nint((nschelp(i)*nplant/nstot) + 0.5)
end do
if(nplant.eq.1) nsc(1) = nplant
do i = 1,nclass
hhelp = hei(i)*0.01
hbc=0
call sapini(outunit,taxid, hhelp, hbc,nsc(i),age)
end do
END SUBROUTINE ini_gener_sap
source_code/version_2.3_windows/interc.f 0 → 100644
View file @ 82df1085
!*****************************************************************!
!* *!
!* 4C (FORESEE) Simulation Model *!
!* *!
!* *!
!* Subroutines for: *!
!* Interception *!
!* *!
!* contains: *!
!* INTERCEP *!
!* INTERCEP_SVEG *!
!* INT_LAYER *!
!* INT_COH_LOOP1 *!
!* INT_COH_LOOP2 *!
!* INT_COH_LOOP3 *!
!* *!
!* Copyright (C) 1996-2018 *!
!* Potsdam Institute for Climate Impact Reserach (PIK) *!
!* Authors and contributors see AUTHOR file *!
!* This file is part of 4C and is licensed under BSD-2-Clause *!
!* See LICENSE file or under: *!
!* http://www.https://opensource.org/licenses/BSD-2-Clause *!
!* Contact: *!
!* https://gitlab.pik-potsdam.de/foresee/4C *!
!* *!
!*****************************************************************!
SUBROUTINE intercep
! Interception of the whole stand
! Stand variables are calculated in stand_balance
use data_climate
use data_inter
use data_evapo
use data_par
use data_simul
use data_species
use data_soil
use data_stand
implicit none
type(Coh_Obj), pointer :: p ! pointer to cohort list
real aev_c, helplai, hxx, hsum, harea, &
cepmax, cepmax_can, cepmax_sveg, &
prec_eff, & ! effective crown precipitation
R_crown, &
interc_c, & ! interception per cohort
pet_c ! pet per cohort
! effective crown precipitation like Anders et al., 2002, S. 95
prec_eff = prec * (1 + 0.13 * wind * (1-crown_area/kpatchsize))
aev_i = 0.
select case (flag_inth)
case (0) ! nach Jansson (SOIL)
! Evaporation calculated at the start (==> interception is possible to be higher)
! evaporation of intercepted water aev_i is limited by potential evaporation
aev_c = max(min(int_st_can, pet), 0.)
int_st_can = max(int_st_can - aev_c, 0.) ! interception storage from actual day
! Canopy interception
if (lai_can .gt. 0.) then
cepmax_can = ceppot_can * lai_can ! max. int. cap. of the whole stand
if (airtemp .ge. temp_snow) then ! frost conditions
lint_snow = .false.
hxx = 0.
if (cepmax_can .ge. int_st_can) hxx = cepmax_can-int_st_can
interc_can = min(hxx, prec)
else
lint_snow = .true.
hxx = 0.
if (2.*cepmax_can .ge. int_st_can) hxx = 2.*cepmax_can-int_st_can
interc_can = min(hxx, prec)
endif
else
cepmax_can = ceppot_can * LAI_can ! max. int. cap. of the whole stand, only canopy
hxx = 0.
if (cepmax_can .ge. int_st_can) hxx = cepmax_can-int_st_can
interc_can = crown_area/kpatchsize * 0.15 * prec
interc_can = min(hxx, interc_can)
aev_c = 0.
endif
int_st_can = int_st_can + interc_can
! interception of ground vegetation
if (flag_sveg .gt. 0) call intercep_sveg (aev_c)
! interception and interc.-evaporation of cohorts
call interc_coh (aev_c)
aev_i = aev_i + aev_c
!......................................
case (1) ! interception for each cohort
! with distribution of precipit. over all canopy layers
int_st_can = 0.
int_st_sveg = 0.
interc_can = 0.
interc_sveg = 0.
aev_i = 0.
hsum = 0.
if (prec .gt. 0. .and. highest_layer .gt. 0) then
call Int_layer
else
p => pt%first
do while (associated(p))
p%coh%interc = 0.
p => p%next
enddo ! p (cohorts)
endif
p => pt%first
do while (associated(p))
ns = p%coh%species
if (all_leaves_on .eq. 0) then
if((anz_tree.ne.0) .and. (pet .gt. 0.)) then
pet_c = pet * p%coh%ntreea / anz_tree
else
pet_c = 0.
end if
else
if (flag_eva .eq. 2 .or. flag_eva .eq. 4) then
pet_c = p%coh%demand
else
if((anz_tree.ne.0) .and. (pet .gt. 0.)) then
pet_c = pet * p%coh%rel_fol
else
pet_c = 0.
end if
p%coh%demand = pet_c
endif
endif
interc_c = p%coh%interc
select case (ns) ! species
case (1,12,13) ! Fagus sylvatica
p%coh%interc_st = p%coh%interc_st + interc_c
aev_c = min(p%coh%interc_st, pet_c)
p%coh%interc_st = max(p%coh%interc_st - aev_c, 0.)
interc_can = interc_can + interc_c
int_st_can = int_st_can + p%coh%interc_st
case (2,10,15) ! Picea abies ... Mistletoe
p%coh%interc_st = p%coh%interc_st + interc_c
aev_c = min(p%coh%interc_st, 2.*pet_c)
p%coh%interc_st = max(p%coh%interc_st - aev_c, 0.)
interc_can = interc_can + interc_c
int_st_can = int_st_can + p%coh%interc_st
case (3,6,7,9) ! Pinus sylvestris
p%coh%interc_st = p%coh%interc_st + interc_c
aev_c = min(p%coh%interc_st, pet_c)
p%coh%interc_st = max(p%coh%interc_st - aev_c, 0.)
interc_can = interc_can + interc_c
int_st_can = int_st_can + p%coh%interc_st
case (4,5,8,11) ! Quercus robur, Betula pendula
p%coh%interc_st = p%coh%interc_st + interc_c
aev_c = min(p%coh%interc_st, 2.*pet_c)
p%coh%interc_st = max(p%coh%interc_st - aev_c, 0.)
interc_can = interc_can + interc_c
int_st_can = int_st_can + p%coh%interc_st
case (14) ! Ground vegetation
p%coh%interc_st = p%coh%interc_st + interc_c
aev_c = min(p%coh%interc_st, pet_c)
p%coh%interc_st = max(p%coh%interc_st - aev_c, 0.)
interc_sveg = interc_sveg + interc_c
int_st_sveg = int_st_sveg + p%coh%interc_st
end select
p%coh%aev_i= aev_c
aev_i = aev_i + aev_c
p => p%next
enddo ! p (cohorts)
!......................................
case (2) ! interception for each cohort
! with relativ part of precipit. accord. to foliage
int_st_can = 0.
int_st_sveg = 0.
interc_can = 0.
interc_sveg = 0.
aev_i = 0.
hsum = 0.
stem_flow = 0.
p => pt%first
do while (associated(p))
ns = p%coh%species
if (flag_eva .eq. 2 .or. flag_eva .eq. 4) then
pet_c = p%coh%demand
else
pet_c = pet * p%coh%rel_fol
endif
select case (ns) ! species
case (1) ! Fagus sylvatica
if ((iday .ge. p%coh%day_bb) .and. (iday .le. spar(ns)%end_bb)) then
helplai = p%coh%t_leaf/p%coh%crown_area
cepmax = spar(ns)%ceppot_spec * p%coh%rel_fol * helplai
if (airtemp .ge. temp_snow) then ! frost conditions
hxx = 0.
if (cepmax .ge. p%coh%interc_st) hxx = cepmax - p%coh%interc_st
interc_c = min(hxx, prec * p%coh%rel_fol)
stem_flow = stem_flow + 0.2 * (prec * p%coh%rel_fol - interc_c)
else
interc_c = 0.35 * prec * p%coh%rel_fol
endif
else
interc_c = 0.1 * prec * p%coh%rel_fol
stem_flow = stem_flow + 0.16 * prec * p%coh%rel_fol
endif
p%coh%interc_st = p%coh%interc_st + interc_c
aev_c = min(p%coh%interc_st, 2.*pet_c)
p%coh%interc_st = max(p%coh%interc_st - aev_c, 0.)
interc_can = interc_can + interc_c
int_st_can = int_st_can + p%coh%interc_st
stem_flow = stem_flow + 0.16 * prec * p%coh%rel_fol
case (2,10,15) ! Picea abies ... Mistletoe
helplai = p%coh%t_leaf/p%coh%crown_area
cepmax = spar(ns)%ceppot_spec * p%coh%rel_fol * helplai
if (airtemp .ge. temp_snow) then ! frost conditions
hxx = 0.
if (cepmax .ge. p%coh%interc_st) hxx = p%coh%interc_st
interc_c = min(cepmax-hxx, prec * p%coh%rel_fol)
else
interc_c = 0.35 * prec * p%coh%rel_fol
endif
p%coh%interc_st = p%coh%interc_st + interc_c
aev_c = min(p%coh%interc_st, 2.*pet_c)
p%coh%interc_st = max(p%coh%interc_st - aev_c, 0.)
interc_can = interc_can + interc_c
int_st_can = int_st_can + p%coh%interc_st
case (3,6,7,9) ! Pinus sylvestris
helplai = p%coh%t_leaf/p%coh%crown_area
cepmax = spar(ns)%ceppot_spec * p%coh%rel_fol * helplai
if (airtemp .ge. temp_snow) then ! frost conditions
hxx = 0.
if (cepmax .ge. p%coh%interc_st) hxx = p%coh%interc_st
interc_c = min(cepmax-hxx, prec * p%coh%rel_fol)
else
interc_c = 0.35 * prec * p%coh%rel_fol
endif
p%coh%interc_st = p%coh%interc_st + interc_c
aev_c = min(p%coh%interc_st, pet_c)
p%coh%interc_st = max(p%coh%interc_st - aev_c, 0.)
interc_can = interc_can + interc_c
int_st_can = int_st_can + p%coh%interc_st
case (4,5,8,11) ! Quercus robur, Betula pendula
if ((iday .ge. p%coh%day_bb) .and. (iday .le. spar(ns)%end_bb)) then
helplai = p%coh%t_leaf/p%coh%crown_area
cepmax = spar(ns)%ceppot_spec * p%coh%rel_fol * helplai
if (airtemp .ge. temp_snow) then ! frost conditions
hxx = 0.
if (cepmax .ge. p%coh%interc_st) hxx = p%coh%interc_st
interc_c = min(cepmax-hxx, prec * p%coh%rel_fol)
else
interc_c = 0.35 * prec * p%coh%rel_fol
endif
else
interc_c = 0.05 * prec * p%coh%rel_fol
endif
p%coh%interc_st = p%coh%interc_st + interc_c
aev_c = min(p%coh%interc_st, 2.*pet_c)
p%coh%interc_st = max(p%coh%interc_st - aev_c, 0.)
interc_can = interc_can + interc_c
int_st_can = int_st_can + p%coh%interc_st
case (14) ! Ground vegetation
if ((iday .ge. p%coh%day_bb) .and. (iday .le. spar(ns)%end_bb)) then
helplai = p%coh%t_leaf/p%coh%crown_area
cepmax = spar(ns)%ceppot_spec * p%coh%rel_fol * helplai
if (airtemp .ge. temp_snow) then ! frost conditions
hxx = 0.
if (cepmax .ge. p%coh%interc_st) hxx = p%coh%interc_st
interc_c = min(cepmax-hxx, prec * p%coh%rel_fol)
else
interc_c = 0.35 * prec * p%coh%rel_fol
endif
else
if (iday .eq. spar(ns)%end_bb+1) then
interc_c = p%coh%interc_st
else
interc_c = 0.
endif
endif
p%coh%interc_st = p%coh%interc_st + interc_c
aev_c = min(p%coh%interc_st, pet_c)
p%coh%interc_st = max(p%coh%interc_st - aev_c, 0.)
interc_sveg = interc_sveg + interc_c
int_st_sveg = int_st_sveg + p%coh%interc_st
end select
p%coh%aev_i= aev_c
aev_i = aev_i + aev_c
p => p%next
enddo ! p (cohorts)
!......................................
case (3) ! interception pine like Anders et al., 2002, S. 95
cepmax_can = ceppot_can * lai_can ! max. int. cap. of the whole stand
cepmax_can = 2.9 ! effect. crown storage capacity of pine according to Anders
R_crown = 0.083 ! s/m aerodyn. resistance of the crown of pine (Anders)
if (cepmax_can .gt. prec_eff) then
interc_can = (crown_area/kpatchsize) * prec_eff
else
interc_can = cepmax_can + (prec_eff - cepmax_can) * wind * R_crown
interc_can = (crown_area/kpatchsize) * interc_can
endif
int_st_can = int_st_can + interc_can
aev_c = int_st_can ! imediate total evaporation
int_st_can = 0. ! interception storage from actual day
!......................................
case (4) ! from Refr.-Bez. (reference notation) (polynom.) for Level II, Brandenburg
interc_can = 0.2 * prec
int_st_can = int_st_can + interc_can
! evaporation of intercepted water aev_i is limited by potential evaporation
aev_c = min(int_st_can, pet)
int_st_can = max(int_st_can - aev_c, 0.) ! interception storage from actual day
! Interception of ground vegetation
if (flag_sveg .gt. 0) call intercep_sveg (aev_c)
! interception and interc.-evaporation of cohorts
call interc_coh (aev_c)
aev_i = aev_i + aev_c
case (5) ! 35% of precipitation (for spruce)
interc_can = 0.3 * prec
int_st_can = int_st_can + interc_can
! evaporation of intercepted water aev_i is limited by potential evaporation
aev_c = min(int_st_can, pet)
int_st_can = max(int_st_can - aev_c, 0.) ! interception storage from actual day
! interception of ground vegetation
if (flag_sveg .gt. 0) call intercep_sveg (aev_c)
! interception and interc.-evaporation of cohorts
call interc_coh (aev_c)
aev_i = aev_i + aev_c
case (6) ! no interception
interc_can = 0.
aev_c = 0.
interc_sveg = 0.
end select
if (flag_dayout .eq. 3) then
write(666,*) 'day, prec, prec_eff: ', iday, prec, prec_eff
endif
! cumul. interc.
int_cum_can = int_cum_can + interc_can
int_cum_sveg = int_cum_sveg + interc_sveg
if(flag_dayout.eq.3) write(1414,*) iday, aev_i
END subroutine intercep
!**************************************************************
SUBROUTINE Int_layer
! Interception per canopy layer
! calculation for each cohort in subroutine int_coh_loop1 (rain)
! and int_coh_loop3 (int_coh_loop2 old) for snow
!*** Declaration part ***!
USE data_climate
USE data_inter
USE data_par
USE data_simul
USE data_species
USE data_stand
IMPLICIT NONE
! variables required for technical reasons
INTEGER :: i
REAL :: intlay, itest ! interception per layer
REAL :: help
TYPE(Coh_Obj), Pointer :: p ! pointer to cohort list
!*** Calculation part ***!
precpool = 0.
itest = 0.
intlay = 0.
! cohort loop
p => pt%first
DO WHILE (ASSOCIATED(p))
p%coh%intcap = 0.
p%coh%interc = 0.
p%coh%prel = 0.
p => p%next
END DO ! cohort loop
! above the canopy there is 100 % precipitation
precpool(highest_layer) = prec
if (airtemp .ge. temp_snow) then ! frost conditions
lint_snow = .false.
do i = highest_layer, lowest_layer, -1
intlay = 0.
CALL int_coh_loop1(i,intlay)
! Assum.: all layers are above eachother, that means precip. is reduc. layer by layer due to interception.
precpool(i-1) = precpool(i) - intlay
itest = itest + intlay
enddo ! end layer loop
else
lint_snow = .true.
CALL int_coh_loop3(intlay)
endif ! airtemp
! stand precipitation unto the ground
DO i = lowest_layer - 2, 0, -1
precpool(i)=precpool(i+1)
END DO
itest = 0.
END SUBROUTINE Int_layer
!**************************************************************
SUBROUTINE int_coh_loop1(i,intlay)
! interception for each canopy layer of each cohort
!*** Declaration part ***!
USE data_simul
USE data_soil
USE data_species
USE data_stand
IMPLICIT NONE
! variables required for technical reasons
TYPE(Coh_Obj), Pointer :: p ! pointer to cohort list
INTEGER :: i, itop ! layer
REAL :: intlay ! interception per layer
REAL :: interc_c, & ! interception per cohort
cepcap ! Int.-Kapaz. fuer diese Variante reduzieren
REAL :: help, hxx
interc_c = 0.
p => pt%first
! cohort loop in layer i
DO WHILE (ASSOCIATED(p))
ns=p%coh%species
IF ((iday >= p%coh%day_bb) .AND. (iday <= spar(p%coh%species)%end_bb)) then
IF (i <= p%coh%toplayer .AND. i >= p%coh%botlayer) THEN
p%coh%prel(i) = precpool(i) * p%coh%BG(i) * p%coh%nTreeA
select case (ns) ! species
case (1) ! Fagus sylvatica
if (p%coh%t_leaf .gt. 0.) then
cepcap = spar(ns)%ceppot_spec * 0.5
p%coh%intcap(i) = cepcap * p%coh%leafArea(i) * p%coh%rel_fol / &
(kpatchsize * p%coh%BG(i))
! intcap is related to the projection area and has to be modified
! by the same factor by that the projection area is being modified
! in case sumBG > patchsize
p%coh%intcap(i)=p%coh%intcap(i) * MIN(kpatchsize/vStruct(i)%sumBG, 1.)
! interc per patch! Since the projection area changes interc has to
! be related to the patch in each layer
hxx = 0.
if (p%coh%intcap(i) .ge. p%coh%interc_st/dz) hxx = p%coh%interc_st/dz ! interc storage spead across all layers
interc_c = min(p%coh%prel(i), p%coh%intcap(i)-hxx)
else
interc_c = 0.1 * p%coh%prel(i)
endif
case (2,10,15) ! Picea abies ... mistletoe
cepcap = spar(ns)%ceppot_spec * 0.5
p%coh%intcap(i) = cepcap * p%coh%leafArea(i) * p%coh%rel_fol / &
(kpatchsize * p%coh%BG(i))
! intcap is related to the projection area and has to be modified
! by the same factor by that the projection area is being modified
! in case sumBG > patchsize
p%coh%intcap(i)=p%coh%intcap(i) * MIN(kpatchsize/vStruct(i)%sumBG, 1.)
! interc per patch! Since the projection area changes interc has to
! be related to the patch in each layer
hxx = 0.
if (p%coh%intcap(i) .ge. p%coh%interc_st/dz) hxx = p%coh%interc_st/dz ! interc storage spead across all layers
interc_c = min(p%coh%prel(i), p%coh%intcap(i)-hxx)
case (3,6,7,9) ! Pinus sylvestris
cepcap = spar(ns)%ceppot_spec * 0.5
p%coh%intcap(i) = cepcap * p%coh%leafArea(i) * p%coh%rel_fol / &
(kpatchsize * p%coh%BG(i))
! intcap is related to the projection area and has to be modified
! by the same factor by that the projection area is being modified
! in case sumBG > patchsize
p%coh%intcap(i)=p%coh%intcap(i) * MIN(kpatchsize/vStruct(i)%sumBG, 1.)
! interc per patch! Since the projection area changes interc has to
! be related to the patch in each layer
hxx = 0.
if (p%coh%intcap(i) .ge. p%coh%interc_st/dz) hxx = p%coh%interc_st/dz ! interc storage spead across all layers
interc_c = min(p%coh%prel(i), p%coh%intcap(i)-hxx)
case (4,5,8,11) ! Quercus robur, Betula pendula
if (p%coh%t_leaf .gt. 0.) then
cepcap = spar(ns)%ceppot_spec * 0.5
p%coh%intcap(i) = cepcap * p%coh%leafArea(i) * p%coh%rel_fol / &
(kpatchsize * p%coh%BG(i))
! intcap is related to the projection area and has to be modified
! by the same factor by that the projection area is being modified
! in case sumBG > patchsize
p%coh%intcap(i)=p%coh%intcap(i) * MIN(kpatchsize/vStruct(i)%sumBG, 1.)
! interc per patch! Since the projection area changes interc has to
! be related to the patch in each layer
hxx = 0.
if (p%coh%intcap(i) .ge. p%coh%interc_st/dz) hxx = p%coh%interc_st/dz ! interc storage spead across all layers
interc_c = min(p%coh%prel(i), p%coh%intcap(i)-hxx)
else
interc_c = 0.1 * p%coh%prel(i)
endif
case (14) ! Ground vegetation
if (p%coh%t_leaf .gt. 0.) then
cepcap = spar(ns)%ceppot_spec * 0.5
p%coh%intcap(i) = cepcap * p%coh%leafArea(i) * p%coh%rel_fol / &
(kpatchsize * p%coh%BG(i))
! intcap is related to the projection area and has to be modified
! by the same factor by that the projection area is being modified
! in case sumBG > patchsize
p%coh%intcap(i)=p%coh%intcap(i) * MIN(kpatchsize/vStruct(i)%sumBG, 1.)
! interc per patch! Since the projection area changes interc has to
! be related to the patch in each layer
hxx = 0.
if (p%coh%intcap(i) .ge. p%coh%interc_st/dz) hxx = p%coh%interc_st/dz ! interc storage spead across all layers
interc_c = min(p%coh%prel(i), p%coh%intcap(i)-hxx)
else
interc_c = 0.0
endif
end select
ENDIF ! i - layer
ELSE
IF (i == p%coh%toplayer) THEN
itop = i
if(cover.ne.0) p%coh%prel(itop) = precpool(i) * p%coh%nTreeA *p%coh%crown_area/crown_area
select case (ns) ! species
case (1) ! Fagus sylvatica p%coh%x_tb
interc_c = 0.2 * p%coh%prel(itop)
case (2,10,15) ! Picea abies ... Mistletoe
interc_c = 0.1 * p%coh%prel(itop)
case (3,6,7,9) ! Pinus sylvestris
interc_c = 0.1 * p%coh%prel(itop)
case (4,5,8,11) ! Quercus robur, Betula pendula
interc_c = 0.1 * p%coh%prel(itop)
case (14) ! Ground vegetation
interc_c = 0.
end select
ENDIF ! i - layer
END IF ! iday
if (interc_c .le. 1E-15) interc_c = 0.
p%coh%interc = p%coh%interc + interc_c
intlay = intlay + interc_c
interc_c = 0.
p => p%next
END DO ! cohort loop
END SUBROUTINE int_coh_loop1
!**************************************************************
SUBROUTINE int_coh_loop2(i,intlay)
! snow interception for each canopy layer of each cohort
!*** Declaration part ***!
USE data_simul
USE data_soil
USE data_species
USE data_stand
IMPLICIT NONE
! variables required for technical reasons
TYPE(Coh_Obj), Pointer :: p ! pointer to cohort list
INTEGER :: i ! layer
REAL :: intlay ! interception per layer
REAL :: interc_c, & ! interception per cohort
cepcap ! Int.-Kapaz. fuer diese Variante reduzieren
REAL :: help, hxx
interc_c = 0.
p => pt%first
! cohort loop in layer i
DO WHILE (ASSOCIATED(p))
ns=p%coh%species
IF (i <= p%coh%toplayer .AND. i >= p%coh%botlayer) THEN
select case (ns) ! species
case (1) ! Fagus sylvatica
if(cover.ne.0) p%coh%prel(i) = precpool(i) * p%coh%nTreeA *p%coh%crown_area/(kpatchsize*cover)
if (p%coh%t_leaf .gt. 0.) then
interc_c = 0.35 * p%coh%prel(i)
else
interc_c = 0.1 * p%coh%prel(i)
endif
case (2,10,15) ! Picea abies... Mistletoe
p%coh%prel(i) = precpool(i) * p%coh%BG(i) * p%coh%nTreeA
interc_c = 0.35 * p%coh%prel(i)
case (3,6,7,9) ! Pinus sylvestris
p%coh%prel(i) = precpool(i) * p%coh%BG(i) * p%coh%nTreeA
interc_c = 0.35 * p%coh%prel(i)
case (4,5,8,11) ! Quercus robur, Betula pendula
p%coh%prel(i) = precpool(i) * p%coh%nTreeA *p%coh%crown_area/kpatchsize
if (p%coh%t_leaf .gt. 0.) then
interc_c = 0.35 * p%coh%prel(i)
else
interc_c = 0.1 * p%coh%prel(i)
endif
case (14) ! Ground vegetation
if (p%coh%t_leaf .gt. 0.) then
p%coh%prel(i) = precpool(i) * p%coh%BG(i) * p%coh%nTreeA
interc_c = 0.35 * p%coh%prel(i)
else
interc_c = 0.
endif
end select
if (interc_c .le. 1E-15) interc_c = 0.
p%coh%interc = p%coh%interc + interc_c
END IF
1313 CONTINUE
intlay = intlay + interc_c
interc_c = 0.
p => p%next
END DO ! cohort loop
END SUBROUTINE int_coh_loop2
!**************************************************************
SUBROUTINE int_coh_loop3(intlay)
! snow interception for each cohort
!*** Declaration part ***!
USE data_climate
USE data_simul
USE data_soil
USE data_species
USE data_stand
IMPLICIT NONE
! variables required for technical reasons
TYPE(Coh_Obj), Pointer :: p ! pointer to cohort list
INTEGER :: itop ! toplayer
REAL :: intlay ! canopy interception
REAL :: interc_c, & ! interception per cohort
cepcap ! Int.-Kapaz. fuer diese Variante reduzieren
REAL :: help, hxx
real test_prel
test_prel = 0.
interc_c = 0.
p => pt%first
! cohort loop
DO WHILE (ASSOCIATED(p))
ns=p%coh%species
itop = p%coh%toplayer
if(cover.ne.0) p%coh%prel(itop) = prec * p%coh%nTreeA *p%coh%crown_area/crown_area
test_prel = test_prel + p%coh%prel(itop)
select case (ns) ! species
case (1) ! Fagus sylvatica p%coh%x_tb
if (p%coh%t_leaf .gt. 0.) then
interc_c = 0.35 * p%coh%prel(itop)
else
interc_c = 0.1 * p%coh%prel(itop)
endif
case (2,10,15) ! Picea abies, Douglas Fir, Mistletoe (better: nspec_tree+2)
interc_c = 0.35 * p%coh%prel(itop)
case (3,6,7,9) ! Pinus sylvestris, P. contorta, P. ponder. P. halep.
interc_c = 0.6 * p%coh%prel(itop)
case (4,5,8,11) ! Quercus robur, Betula pendula, Populus, Robinia
if (p%coh%t_leaf .gt. 0.) then
interc_c = 0.35 * p%coh%prel(itop)
else
interc_c = 0.1 * p%coh%prel(itop)
endif
case (14) ! Ground vegetation
if (p%coh%t_leaf .gt. 0.) then
interc_c = 0.35 * p%coh%prel(itop)
else
interc_c = 0.
endif
end select
if (interc_c .le. 1E-15) interc_c = 0.
p%coh%interc = p%coh%interc + interc_c
1313 CONTINUE
intlay = intlay + interc_c
interc_c = 0.
p => p%next
END DO ! cohort loop
continue
END SUBROUTINE int_coh_loop3
!**************************************************************
SUBROUTINE intercep_sveg (aev_c)
! Interception of ground vegetation
use data_climate
use data_inter
use data_evapo
use data_par
use data_species
use data_stand
implicit none
real aev_c, & ! canopy interception evaporation
hxx, &
cepmax_sveg
cepmax_sveg = ceppot_sveg * lai_sveg ! max. int. cap. of the whole stand
if (airtemp .ge. temp_snow) then ! frost conditions
hxx = 0.
if (cepmax_sveg .ge. int_st_sveg) hxx = cepmax_sveg-int_st_sveg
interc_sveg = min(hxx, prec-interc_can)
else
interc_sveg = 0.35 * (prec-interc_can)
endif
int_st_sveg = int_st_sveg + interc_sveg
! evaporation of intercepted water aev_i is limited by potential evaporation
aev_i = min(int_st_sveg, pet-aev_c)
int_st_sveg = max(int_st_sveg - aev_i, 0.) ! interception storage from actual day
END SUBROUTINE intercep_sveg
!**************************************************************
SUBROUTINE interc_coh (aev_c)
! Interception of ground vegetation
use data_climate
use data_inter
use data_evapo
use data_species
use data_stand
implicit none
type(Coh_Obj), pointer :: p ! pointer to cohort list
integer ns
real aev_c, & ! canopy interception evaporation
cepmax_sveg
p => pt%first
do while (associated(p))
ns = p%coh%species
if (ns .le. nspec_tree .OR. ns .eq. nspec_tree+2) then
! trees and mistletoe
p%coh%interc_st = int_st_can * p%coh%rel_fol
p%coh%aev_i= aev_c * p%coh%rel_fol
else
! ground vegetation
p%coh%interc_st = int_st_sveg * p%coh%rel_fol
p%coh%aev_i= aev_i * p%coh%rel_fol
endif
p => p%next
enddo ! p (cohorts)
END SUBROUTINE interc_coh
source_code/version_2.3_windows/main_4c.f 0 → 100644
View file @ 82df1085
PROGRAM foresee
! main program for 4C
! Unix Version
! 14.10.04 Su aktuelles Directory (actDir) hier bestimmen
! 16.08.04 Su Schleife ueber run_nr in UP sim_control (File simul.f)
! 24.03.03 pl Aufruf finish_simul fr flag_end>0
! 02.12.02 MF Aufruf SimEnv
! 30.07.02 MF Aufruf SIMENV
! 29.05.02 Su ip-Schleife fuer SIMENV (flag_multi=5) ueberspringen
! call simenv mit Uebergabe von ip
! 26.04.02 Su call out_var_file
! 21.11.01 Su flag_end=2 testen
! 14.05.01 FB call fixclimscen added
! 18.12.97 BE new structure/name
! 11.12.97 BE include same changes for multi_runs
! 27.8.97 BE insert SIM_INI
! 26.8.97 BE insert DO-LOOP for whole program, until choice=end program
! 20.3.97 BE Erweiterung/Umstrukturierung Protokollfile
! USE data_out
USE data_simul
! USE data_stand
! USE data_species
! IMPLICIT NONE
! INTEGER run_nr, ipp
actDir = ''
CALL prepare_global
CALL sim_control
END PROGRAM foresee
source_code/version_2.3_windows/main_4c_cons_win.f90 0 → 100644
View file @ 82df1085
!*****************************************************************!
!* *!
!* 4C (FORESEE) Simulation Model *!
!* *!
!* *!
!* Subroutines for: *!
!* - windows shell - *!
!* *!
!* contains: *!
!* main program for 4C *!
!* *!
!* Copyright (C) 1996-2018 *!
!* Potsdam Institute for Climate Impact Reserach (PIK) *!
!* Authors and contributors see AUTHOR file *!
!* This file is part of 4C and is licensed under BSD-2-Clause *!
!* See LICENSE file or under: *!
!* http://www.https://opensource.org/licenses/BSD-2-Clause *!
!* Contact: *!
!* https://gitlab.pik-potsdam.de/XXXXXXXXXXXXXXXXXXXXX *!
!* *!
!*****************************************************************!
PROGRAM foresee
USE data_simul
real time1, time2
call CPU_time (time1)
call Act_Dir(actDir)
CALL topmenu_win
call CPU_time (time2)
print *, ' 4C total run time ', time2-time1, ' sec'
END PROGRAM foresee
source_code/version_2.3_windows/man_lic.f 0 → 100644
View file @ 82df1085
!*****************************************************************!
!* 4C (FORESEE) Simulation Model *!
!* *!
!* *!
!* contains: *!
!* SR man_liocourt_ini *!
!* SR liocourt_manag *!
!* *!
!* Copyright (C) 1996-2018 *!
!* Potsdam Institute for Climate Impact Reserach (PIK) *!
!* Authors and contributors see AUTHOR file *!
!* This file is part of 4C and is licensed under BSD-2-Clause *!
!* See LICENSE file or under: *!
!* http://www.https://opensource.org/licenses/BSD-2-Clause *!
!* Contact: *!
!* https://gitlab.pik-potsdam.de/foresee/4C *!
!* *!
!*****************************************************************!
Subroutine man_liocourt_ini
USE data_manag
USE data_simul
USE data_plant
USE data_species
implicit none
integer :: manag_unit,i
character(len=150) :: filename
logical :: ex
character :: text
manag_unit=getunit()
filename = manfile(ip)
call testfile(filename,ex)
open(manag_unit,file=trim(filename))
allocate(thin_flag1(nspec_tree))
thin_flag1=-1
! read head of data-file
do
read(manag_unit,*) text
if(text .ne. '!')then
backspace(manag_unit);exit
endif
enddo
read(manag_unit,*) thin_int
read(manag_unit,*) dbh_max
read(manag_unit,*) lic_a
read(manag_unit,*) lic_b
read(manag_unit,*) spec_lic
read(manag_unit,*) thin_proc
if(flag_reg.ne.0) then
read(manag_unit,*) m_numclass
do i = 1, m_numclass
read(manag_unit,*) m_numplant(spec_lic,i), m_specpl(spec_lic,i), m_plant_height(spec_lic,i), m_plant_hmin(spec_lic,i), m_pl_age(spec_lic,i), m_hsdev(spec_lic,i)
end do
end if
close(manag_unit)
end Subroutine man_liocourt_ini
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
Subroutine liocourt_manag
USE data_manag
USE data_stand
USE data_species
USE data_simul
USE data_par
implicit none
integer :: i, ih, nspech
real :: diamh, help, stembiom, stembiom_us, stembiom_all, stembiom_re, target_help, target_biom
target_biom=0.
if(Modulo(time,thin_int).eq.0) then
! calculation of mean diameter (correspondung to med_diam) and basal area of stand
zeig => pt%first
DO
IF (.NOT. ASSOCIATED(zeig)) EXIT
! Modification for V Kint: no test for diameter
IF((zeig%coh%ntreea>0).and.zeig%coh%species.eq.spec_lic.and.zeig%coh%underst.eq.0) THEN
! forester definition
! overstorey
stembiom = stembiom + (zeig%coh%x_sap + zeig%coh%x_hrt)*zeig%coh%ntreea
! Trees with DBH = 0 for population and per species
ELSE IF( (zeig%coh%ntreea>0).and.zeig%coh%species.eq.spec_lic.and.zeig%coh%underst.eq.1) THEN
! seedings/regeneration
stembiom_re = stembiom_re + (zeig%coh%x_sap + zeig%coh%x_hrt)*zeig%coh%ntreea
ELSE if((zeig%coh%ntreea>0).and.zeig%coh%species.eq.spec_lic.and.zeig%coh%underst.eq.2) THEN
! understorey
stembiom_us = stembiom_us + (zeig%coh%x_sap + zeig%coh%x_hrt)*zeig%coh%ntreea
ENDIF
zeig => zeig%next
ENDDO
! mean diamteer for over and understorey
stembiom_all = stembiom + stembiom_us
target_help = stembiom_all*(thin_proc)
ntree_lic(1,spec_lic)=int(lic_a*exp(lic_b*2.5))
Do i=1,21
help=(dclass_w*i + dclass_w*(i+1))/2.
ntree_lic(i+1,spec_lic)= int(lic_a*exp(lic_b*help))*kpatchsize/10000.
end do
zeig=>pt%first
do while (target_biom.lt. target_help)
if(.not.associated(zeig)) exit
if(zeig%coh%diam.gt. dbh_max) then
zeig%coh%ntreem = zeig%coh%ntreea
zeig%coh%ntreea = 0
zeig%coh%nta = 0
diam_class(i,spec_lic) = diam_class(i,spec_lic) - 1
target_biom = target_biom + zeig%coh%ntreem*(zeig%coh%x_sap + zeig%coh%x_hrt)
end if
zeig => zeig%next
end do
do i = 1, num_class
zeig=>pt%first
do
if(.not.associated(zeig)) exit
if(target_help.le.target_biom) exit
nspech = zeig%coh%species
diamh = zeig%coh%diam
ih= i-1
if(diamh.le. dbh_max .and.nspech.eq.spec_lic) then
if(diamh.gt.dclass_w*ih .and. diamh.le. dclass_w*(ih+1) .and. zeig%coh%ntreea.ne.0) then
if((diam_class(i,1)-zeig%coh%ntreea).ge. ntree_lic(i,1)) then
zeig%coh%ntreem = zeig%coh%ntreea
zeig%coh%ntreea = 0
zeig%coh%nta = 0
diam_class(i,spec_lic) = diam_class(i,spec_lic) - zeig%coh%ntreem
target_biom = target_biom + zeig%coh%ntreem*(zeig%coh%x_sap + zeig%coh%x_hrt)
else if(diam_class(i,1).gt. ntree_lic(i,1)) then
zeig%coh%ntreem= diam_class(i,spec_lic) - ntree_lic(i,spec_lic)
zeig%coh%ntreea = zeig%coh%ntreea - zeig%coh%ntreem
zeig%coh%nta = zeig%coh%nta - zeig%coh%ntreem
diam_class(i,spec_lic) = diam_class(i,spec_lic) - zeig%coh%ntreem
target_biom = target_biom + zeig%coh%ntreem*(zeig%coh%x_sap + zeig%coh%x_hrt)
end if
end if
end if
zeig => zeig%next
if (target_biom.ge.target_help) exit
end do ! cohort loop
end do ! loop i for diamter classes
! litter pools
zeig=>pt%first
do
if(.not.associated(zeig)) exit
if(zeig%coh%ntreem>0.and.zeig%coh%species.eq.spec_lic) then
! all parts of trees are input for litter excepting stems
zeig%coh%litC_fol = zeig%coh%litC_fol + zeig%coh%ntreem*(1.-spar(spec_lic)%psf)*zeig%coh%x_fol*cpart
zeig%coh%litN_fol = zeig%coh%litN_fol + zeig%coh%ntreem*((1.-spar(spec_lic)%psf)*zeig%coh%x_fol*cpart)/spar(spec_lic)%cnr_fol
zeig%coh%litC_frt = zeig%coh%litC_frt + zeig%coh%ntreem*zeig%coh%x_frt*cpart
zeig%coh%litN_frt = zeig%coh%litN_frt + zeig%coh%ntreem*zeig%coh%x_frt*cpart/spar(spec_lic)%cnr_frt
zeig%coh%litC_tb = zeig%coh%litC_tb + zeig%coh%ntreem*zeig%coh%x_tb*cpart
zeig%coh%litN_tb = zeig%coh%litN_tb + zeig%coh%ntreem*zeig%coh%x_tb*cpart/spar(spec_lic)%cnr_tbc
zeig%coh%litC_crt = zeig%coh%litC_crt + zeig%coh%ntreem*zeig%coh%x_crt*cpart
zeig%coh%litN_crt = zeig%coh%litN_crt + zeig%coh%ntreem*zeig%coh%x_crt*cpart/spar(spec_lic)%cnr_crt
endif
zeig=>zeig%next
enddo
! calculation of total dry mass of all harvested trees
sumvsab = 0.
sumvsab_m3 = 0.
svar%sumvsab = 0.
zeig=>pt%first
do
if(.not.associated(zeig)) exit
nspech = zeig%coh%species
if(nspech.eq.spec_lic) then
sumvsab = sumvsab + zeig%coh%ntreem*(zeig%coh%x_sap + zeig%coh%x_hrt)
sumvsab_m3 = sumvsab_m3 + zeig%coh%ntreem*(zeig%coh%x_sap + zeig%coh%x_hrt)/(spar(nspech)%prhos*1000000)
svar(nspech)%sumvsab = svar(nspech)%sumvsab + zeig%coh%ntreem*(zeig%coh%x_sap + zeig%coh%x_hrt)
end if
zeig=>zeig%next
end do
sumvsab = sumvsab * 10000./kpatchsize ! kg/ha
sumvsab_m3 = sumvsab_m3 * 10000./kpatchsize ! kg/ha
svar(spec_lic)%sumvsab = svar(spec_lic)%sumvsab * 10000./kpatchsize ! kg/ha
cumsumvsab = cumsumvsab + sumvsab
end if ! loop management time
end Subroutine liocourt_manag
source_code/version_2.3_windows/manag_practices.f 0 → 100644
View file @ 82df1085
!*****************************************************************!
!* *!
!* 4C (FORESEE) Simulation Model *!
!* *!
!* *!
!* contains: *!
!* SR tending *!
!* SR direct_fel *!
!* SR thinning *!
!* SR felling *!
!* SR shelterwood_man *!
!* SR min_dbh *!
!* SR max_dbh *!
!* SR max_diam *!
!* SR min_dbh_overs *!
!* SR min_dbh_tar *!
!* SR target_thinning *!
!* SR calc_usp *!
!* SR calc_gfbg *!
!* SR stump *!
!* *!
!* Copyright (C) 1996-2018 *!
!* Potsdam Institute for Climate Impact Reserach (PIK) *!
!* Authors and contributors see AUTHOR file *!
!* This file is part of 4C and is licensed under BSD-2-Clause *!
!* See LICENSE file or under: *!
!* http://www.https://opensource.org/licenses/BSD-2-Clause *!
!* Contact: *!
!* https://gitlab.pik-potsdam.de/foresee/4C *!
!* *!
!*****************************************************************!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! !
! tending plantations !
! !
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
SUBROUTINE tending(actspec, i)
use data_stand
use data_manag
use data_species
use data_par
use data_simul
implicit none
integer :: tendnr, & ! number of trees to be removed
anz, &
actspec
real :: pequal
integer :: help_tree,min_ident,h1,max_ident, h2 ,cohanz
integer :: taxnr, j, i, thinflag, num_coh, nhelp,anz_actspec
integer, dimension(0:anz_coh) ::cohl
allocate (height_rank(anz_coh))
cohanz = 0
anz_actspec = 0
min_ident=1000
max_ident = 0
cohl=0.
anz=0
! number of trees to removed from the top of the stand
zeig=>pt%first
do
if(.not.associated(zeig)) exit
cohanz = cohanz +1
if(zeig%coh%species.eq.actspec.and. zeig%coh%shelter.ne.1) anz_actspec = anz_actspec + zeig%coh%ntreea
if(zeig%coh%shelter.ne.1) then
if(zeig%coh%ntreea.ne.0.and. zeig%coh%species.eq.actspec) then
h1 = zeig%coh%ident
if( h1.lt. min_ident) min_ident = h1
h2 = zeig%coh%ident
if(h2.gt.max_ident) max_ident = h2
end if
end if
zeig=>zeig%next
end do
if(thr7.ne.2.and.anz_actspec.eq.0) then
deallocate(height_rank)
return
end if
!calculation of relative proportion of stems thinned from tending only of trees which are not shelter trees
tendnr = anz_actspec * tend(actspec)/2
help_tree = tendnr
! determination of heighest tree cohort
! sorting by height of cohorts into the field height_rank containing cohort identifier
call dimsort(anz_coh, 'height',height_rank)
! removing of trees
do j= anz_coh, 1, -1
zeig=>pt%first
do
if(.not.associated(zeig)) exit
if(zeig%coh%shelter.ne.1. .and. zeig%coh%species.eq.specnr(i)) then
if(zeig%coh%ident.eq.height_rank(j)) then
if(zeig%coh%ntreea.ge.tendnr) then
zeig%coh%ntreea = zeig%coh%ntreea - help_tree
zeig%coh%ntreet = help_tree
help_tree = 0.
else
! number of trees to be left
help_tree = help_tree-zeig%coh%ntreea
! number of trees removed
zeig%coh%ntreet = zeig%coh%ntreea
zeig%coh%ntreea = 0
end if
end if
end if
zeig=> zeig%next
end do
if(help_tree.le.0 ) exit
end do
! second part of felling, equal distributed from all cohorts
! equal distribution from all cohorts with trees
nhelp = tendnr
zeig=>pt%first
do
if(.not.associated(zeig)) exit
if(zeig%coh%species.eq.actspec) then
end if
zeig=>zeig%next
end do
do
j=0
thinflag = 0
call random_number(pequal)
num_coh = min_ident + (max_ident - min_ident) * pequal
zeig=>pt%first
do
if(.not.associated(zeig)) exit
if(zeig%coh%shelter.ne.1.and. zeig%coh%species.eq.actspec) then
j = j+1
if (zeig%coh%ident.eq.num_coh) then
! check the value ntreea before
if(zeig%coh%ntreea.ge.1) then
zeig%coh%ntreea = zeig%coh%ntreea - 1
zeig%coh%nta = zeig%coh%ntreea
zeig%coh%ntreet = zeig%coh%ntreet + 1
nhelp = nhelp -1
thinflag = 1
else
exit
endif
end if
if(thinflag.eq.1) exit
end if
zeig => zeig%next
end do
if(nhelp.eq.0) exit
end do
! all biomasses are added to litter pools
zeig=>pt%first
do
if(.not.associated(zeig)) exit
taxnr=zeig%coh%species
if(zeig%coh%ntreet>0.and.taxnr.eq.specnr(i))then
! all parts of trees are input for litter
zeig%coh%litC_fol = zeig%coh%litC_fol + zeig%coh%ntreet*(1.-spar(taxnr)%psf)*zeig%coh%x_fol*cpart
zeig%coh%litN_fol = zeig%coh%litN_fol + zeig%coh%ntreet*((1.-spar(taxnr)%psf)*zeig%coh%x_fol*cpart)/spar(taxnr)%cnr_fol
zeig%coh%litC_frt = zeig%coh%litC_frt + zeig%coh%ntreet*zeig%coh%x_frt*cpart
zeig%coh%litN_frt = zeig%coh%litN_frt + zeig%coh%ntreet*zeig%coh%x_frt*cpart/spar(taxnr)%cnr_frt
zeig%coh%litC_tb = zeig%coh%litC_tb + zeig%coh%ntreet*zeig%coh%x_tb*cpart
zeig%coh%litN_tb = zeig%coh%litN_tb + zeig%coh%ntreet*zeig%coh%x_tb*cpart/spar(taxnr)%cnr_tbc
zeig%coh%litC_crt = zeig%coh%litC_crt + zeig%coh%ntreet*zeig%coh%x_crt*cpart
zeig%coh%litN_crt = zeig%coh%litN_crt + zeig%coh%ntreet*zeig%coh%x_crt*cpart/spar(taxnr)%cnr_crt
zeig%coh%litC_stem = zeig%coh%litC_stem + zeig%coh%ntreet*(zeig%coh%x_sap+zeig%coh%x_hrt)*cpart
zeig%coh%litN_stem = zeig%coh%litC_stem/spar(taxnr)%cnr_stem
zeig%coh%ntreet = 0
endif
zeig=>zeig%next
enddo
thinyear(actspec)=time
deallocate(height_rank)
END SUBROUTINE tending
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Rueckegasse directional felling
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
SUBROUTINE direct_fel(hox)
use data_manag
use data_stand
use data_simul
use data_par
use data_species
implicit none
integer :: num_felt=0, &
num_coh=0, &
i, &
thinflag, &
taxnr, &
nhelp
real :: pequal, &
hox
thinflag = 0
if(thr5.eq.1) then
if (thr6.eq.hox) then
! felling of direcfel*anz_tree trees equal distributed from all cohorts
num_felt = direcfel*anz_tree
nhelp = num_felt
do
i=0
thinflag = 0
call random_number(pequal)
num_coh = nint(pequal * anz_coh)+1
zeig=>pt%first
do
if(.not.associated(zeig)) exit
i = i+1
if (i.eq.num_coh) then
! check the value ntreea before
if(zeig%coh%ntreea.ge.1) then
zeig%coh%ntreea = zeig%coh%ntreea - 1
zeig%coh%ntreem = zeig%coh%ntreem + 1
nhelp = nhelp -1
thinflag = 1
else
exit
endif
end if
if(thinflag.eq.1) exit
zeig => zeig%next
end do
if(nhelp.eq.0) exit
end do
flag_direct=1
end if
end if
! adding biomasses to litter pools depending on stage of stand
zeig=>pt%first
do
if(.not.associated(zeig)) exit
taxnr=zeig%coh%species
if(zeig%coh%ntreem>0)then
! all parts without stems of trees are input for litter
zeig%coh%litC_fol = zeig%coh%litC_fol + zeig%coh%ntreem*(1.-spar(taxnr)%psf)*zeig%coh%x_fol*cpart
zeig%coh%litN_fol = zeig%coh%litN_fol + zeig%coh%ntreem*((1.-spar(taxnr)%psf)*zeig%coh%x_fol*cpart)/spar(taxnr)%cnr_fol
zeig%coh%litC_frt = zeig%coh%litC_frt + zeig%coh%ntreem*zeig%coh%x_frt*cpart
zeig%coh%litN_frt = zeig%coh%litN_frt + zeig%coh%ntreem*zeig%coh%x_frt*cpart/spar(taxnr)%cnr_frt
zeig%coh%litC_tb = zeig%coh%litC_tb + zeig%coh%ntreet*zeig%coh%x_tb*cpart
zeig%coh%litN_tb = zeig%coh%litN_tb + zeig%coh%ntreet*zeig%coh%x_tb*cpart/spar(taxnr)%cnr_tbc
zeig%coh%litC_crt = zeig%coh%litC_crt + zeig%coh%ntreet*zeig%coh%x_crt*cpart
zeig%coh%litN_crt = zeig%coh%litN_crt + zeig%coh%ntreet*zeig%coh%x_crt*cpart/spar(taxnr)%cnr_crt
endif
zeig=>zeig%next
enddo
END SUBROUTINE direct_fel
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! different thinning regimes (1-4) for trees with dominant height above ho2
! thinning regime 1 - moderate low-thinning / mssige Niederdurchforstung
! thinning regime 2 - strong/heavy low-thinning / starke Niederdurchforstung
! thinning regime 3 - high-thinning / Hochdurchforstung
! thinning regime 4 - selective thinning (from upper or middle thirg of thickest trees
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
SUBROUTINE thinning(c1,c2,actspec, inum)
use data_stand
use data_manag
use data_simul
use data_species
use data_par
implicit none
real :: dbhmin=0, &
wpa=0, & ! Weibull parameter
wpb=0, & ! -"-
wpc=0, & ! -"-
d63=0, &
pequal, &
tdbh=0, &
bas_help=0., &
dbh_h =0, &
db_l = 0., &
db_u = 0., &
c1, &
d_est=0., &
w_kb=0., &
c_usp
real :: help_cra, & ! actual crown area
density, & ! ratio of crown area to patch size
bas_target, & ! relative value for basal area thinning
bas_area, &
help
real :: hg, & ! hight of base area mean stem
bg, & ! degree of tillering
dfbg, & ! opt. base area
stage, & ! actual age
basha, &
stump_v, & ! volume and dry weight of stump
stump_dw
integer :: nrmin, &
flagth, &
c2, &
taxnr, &
nhelp1, &
counth, &
nhelp2, &
zbnr_pa, &
callnum, &
actspec, inum ! number of species for thinning
integer :: lowtree, agedm
! auxilarity for thinning routine 4: selective thinning
integer :: nrmax,anz,anz1,count,flagexit, flagc, num_thin,j, &
nhelp,idum ,numtr, third,anztree_ha,i
integer,dimension(0:anz_coh) :: cohl
real :: meanzb, stand,xhelp, sumdh, sumd, hh ,rel_bas
real,external :: gasdev
real,dimension(nspecies) :: cr_rel ! relative part of species specific crown area of total crown area
! target calculation for basal area reduction
bas_target = ((time-thinyear(actspec))/5)*0.05
bas_area = 0.
bas_help = 0.
help_cra = 0.
cr_rel = 1.
callnum = 0
count = 0
cohl = -1
flagth = 0
help=0.
lowtree=0
anztree_ha = nint(anz_tree_dbh*10000./kpatchsize)
third = nint(anz_tree_dbh*0.333333)
sumdh = 0.; sumd = 0.
! calculation of mean diameter (corresponding to med_diam) and basal area of stand
! calculation hg ( hight of base area mean stem)
i = inum
zeig => pt%first
DO
IF (.NOT. ASSOCIATED(zeig)) EXIT
if(zeig%coh%species.eq.actspec) then
stage = zeig%coh%x_age
help_cra = help_cra + zeig%coh%ntreea* zeig%coh%crown_area
IF((zeig%coh%ntreea>0).and.(zeig%coh%diam>0)) THEN
! foresters defenition
sumd = sumd + zeig%coh%diam*zeig%coh%diam
sumdh = sumdh + zeig%coh%diam*zeig%coh%diam* zeig%coh%height
help = help + zeig%coh%ntreea*(zeig%coh%diam**2)
bas_area = bas_area + zeig%coh%ntreea*(zeig%coh%diam**2)*pi/4.
ELSE
! trees with DBH = 0 for population and species
lowtree = lowtree + zeig%coh%ntreea
ENDIF
end if
zeig => zeig%next
ENDDO ! cohorts
hg = (sumdh/sumd)/100.
! basal area /ha
basha = bas_area/kpatchsize ! cm/patch ---> m/ha
rel_bas = bas_area/basarea_tot
if(thin_ob.eq.1) then
! calculation of optimal basal area (Brandenburg) per patchsize
call calc_gfbg(dfbg,specnr(i), stage, hg)
! correction
dfbg = dfbg* kpatchsize ! m/ha ---> cm/patchsize
if(anz_spec.eq.1) then
if(dfbg.lt.0.5*bas_area) dfbg = 0.5*bas_area
! calculation of BG (Bestockungsgrad)
else
! calculation of relative part of crown area
cr_rel(actspec) = svar(actspec)%crown_area / crown_area
end if
bg = rel_bas*bas_area/dfbg
! calculation of basale area target depending on target optb 'Bestockungsgrad'
bas_target = rel_bas*optb*dfbg
else
! calculation of density dependent target for thinning
density = help_cra/kpatchsize
call calc_usp (actspec,age_spec(i),density,c_usp)
! Modification of 'Nutzungsprozent' to avoid large number for c_usp
c_usp = c_usp*np_mod(actspec)
if(thinyear(actspec).eq.0) then
hh = c_usp*(time)/10.
if(hh.lt.0.7) then
c_usp = hh
else
c_usp = 0.5
end if
bas_target = bas_area - bas_area*c_usp
else
! Modification
if(c_usp.gt.0.4) then
c_usp =c_usp * (time -thinyear(actspec))/20.
end if
bas_target = bas_area - bas_area*c_usp
end if
end if
select case(c2)
case(1:3)
! different thinnings from below and above
select case(c2)
case(1)
! moderate low-thinning
d_est = 1.02
! change of w_kb to exclude small diameter classes
w_kb = 2.5
case(2)
! high low-thinning
d_est = 1.03
w_kb = 1.5
case(3)
! high-thinning
d_est = 1.04
w_kb = 1.2
end select
! calculation of Weibull-Parameter
if(bas_area.gt.bas_target) then
call min_dbh(nrmin,dbhmin,agedm,actspec)
bas_help = bas_area
wpa = dbhmin
d63 = svar(actspec)%med_diam * d_est
wpb = (d63 - wpa)/ w_kb
wpc = 2
! selection of trees for thinning
do
call random_number(pequal)
tdbh = wpa + wpb*(-log(1.-pequal))**(1./wpc)
callnum = callnum +1
flagth = 0
zeig => pt%first
DO
IF (.NOT. ASSOCIATED(zeig)) EXIT
if(zeig%coh%species.eq.actspec) then
if(zeig%coh%diam.gt.0.) then
dbh_h = zeig%coh%diam
db_l = dbh_h - 0.1*dbh_h
db_u = dbh_h + 0.1*dbh_h
if (tdbh.ge.db_l.and.tdbh.le.db_u.and. zeig%coh%ntreea.ne. 0) then
zeig%coh%ntreea = zeig%coh%ntreea -1
zeig%coh%nta = zeig%coh%ntreea
zeig%coh%ntreem = zeig%coh%ntreem +1
bas_help = bas_help - (zeig%coh%diam**2)*pi/4.
flagth = 1
end if
if(flagth.eq.1) exit
end if
end if
zeig=> zeig%next
END DO ! cohorts
if(bas_help .le. bas_target) exit
end do ! selection of trees
end if
case(4)
! selective thinning
! normal(or equal) distributed thinning from one third of the trees (upper or middle): n*anz_ziel or
! depending an basal area
! ho2: n=2; ho3,ho4: n=1.5 ho>ho4: n=1
! determination of the third of trees with the thickest diameter (sorting of cohorts concerning diameter
! necessary: normal distribution with 2 parameters: mean diameter of the third and standard deviation
DO i=1,anz_spec
!Calculation of number of thinning trees
IF ( c1.eq.ho2) THEN
num_thin = NINT(2* zbnr(specnr(i))*kpatchsize/10000.)
ELSE IF( c1.eq.ho3.or.c1.eq.ho4) THEN
! change of num_thin because of errors during thinning
num_thin = NINT(zbnr(specnr(i))*kpatchsize/10000.)
ELSE
num_thin = NINT(zbnr(specnr(i))*kpatchsize/10000.)
END IF
if(anztree_ha.lt.(zbnr(specnr(i))+ zbnr(specnr(i))*0.2)) return
! determine cohorts which fulfill the upper third --> selected for thinning
anz = 0
flagexit = 0
flagc = 0
if(anz_tree_dbh>1) then
do
call max_diam(nrmax,anz,cohl, specnr(i))
zeig=>pt%first
do
if(.not.associated(zeig)) exit
if(zeig%coh%diam.gt.0) then
if(zeig%coh%ident.eq.nrmax) then
count = count + zeig%coh%ntreea
if(count.ge. third) flagexit = 1
flagc = 1
end if
if (flagc.eq. 1) exit
end if
zeig=>zeig%next
end do
if(flagexit.eq.1) exit
flagc = 0
end do
end if
IF(c1.eq.0) THEN
! determine cohorts which fulfill the middle third of thickness
! if the number of one third is not definded by an even number of cohorts
! the middle third starts in the last cohort of the upper third
! some refinements are possible: the number of trees are marked in each cohort which
! are available for thinning (may be in the last cohort of the thirg only x%)
if(count.eq.third) then
anz1 = anz+1
else
anz1 = anz
anz = anz-1
end if
count = 0
flagexit = 0
flagc = 0
if(anz_tree>1) THEN
do
call max_diam(nrmax,anz,cohl, specnr(i))
zeig=>pt%first
do
if(.not.associated(zeig)) exit
if(zeig%coh%ident.eq.nrmax) then
count = count + zeig%coh%ntreea
if(count.ge. third) flagexit = 1
flagc = 1
end if
if (flagc.eq. 1) exit
zeig=>zeig%next
end do
if(flagexit.eq.1) exit
flagc = 0
end do
end if
ENDIF
! calculation on mean and standard deviation of cohorts selected for thinning
stand = 0.
if(c1.ne.0) anz1 =1
meanzb = 0.
counth = 0
do j = anz1,anz
zeig=>pt%first
do
if(.not.associated(zeig)) exit
nrmax = cohl(j-1)
if (zeig%coh%ident.eq.nrmax) then
meanzb = meanzb + zeig%coh%ntreea*zeig%coh%diam
counth = counth + zeig%coh%ntreea
end if
zeig=>zeig%next
end do
end do
! mean value
meanzb = meanzb/count
! standard deviation
do j = anz1,anz
zeig=>pt%first
do
if(.not.associated(zeig)) exit
nrmax = cohl(j-1)
if (zeig%coh%ident.eq.nrmax) then
stand = stand+ zeig%coh%ntreea*(zeig%coh%diam - meanzb)*(zeig%coh%diam - meanzb)
end if
zeig=>zeig%next
end do
end do
stand = sqrt(stand/count)
! thinning of num_thin trees from the upper third
! using normal distribution
! if ho>ho4 the selection of trees from the middle third is controlled by basal area
! a reduction of basal area by 10%
idum = -1
nhelp = num_thin
numtr = 0
bas_help=bas_area
do j=anz1,anz
zeig=>pt%first
DO
IF (.NOT. ASSOCIATED(zeig)) EXIT
if(zeig%coh%ident.eq.cohl(j-1)) numtr = numtr+zeig%coh%ntreea
zeig=>zeig%next
end do
end do
nhelp1 = anz_tree
nhelp2 = count
if(nhelp.gt.numtr) nhelp = numtr
DO
xhelp= meanzb+stand*gasdev(idum)
flagth = 0
DO j = anz1, anz
zeig => pt%first
DO
IF (.NOT. ASSOCIATED(zeig)) EXIT
if(zeig%coh%ident.eq.cohl(j-1)) then
dbh_h = zeig%coh%diam
db_l = dbh_h - 0.1*dbh_h
db_u = dbh_h + 0.1*dbh_h
if (xhelp.ge.db_l.and.xhelp.le.db_u.and. zeig%coh%ntreea.ne. 0) then
zeig%coh%ntreea = zeig%coh%ntreea -1
zeig%coh%nta = zeig%coh%ntreea
zeig%coh%ntreem = zeig%coh%ntreem +1
if(c1.eq.0) then
bas_help = bas_help - (zeig%coh%diam**2)*pi*0.25
nhelp1 = nhelp1 -1
nhelp2 = nhelp2 -1
else
nhelp= nhelp -1
endif
flagth = 1
end if
end if
if(flagth.eq.1) exit
zeig=> zeig%next
ENDDO
if(flagth.eq.1) exit
END DO
! criteria of finishing thinning
zbnr_pa = nint(zbnr(specnr(i))*kpatchsize/10000.)
if(c1.eq.0 .and.( bas_help.le.(bas_area - bas_area*bas_target).or.nhelp1.eq.zbnr_pa) ) exit
if(c1.eq.0 .and.( nhelp1.eq.0 .or. nhelp2.eq.0)) exit
if(c1.ne.0 .and. nhelp.eq.0) exit
ENDDO
END DO ! speices loop
end select
! adding biomasses to litter pools depending on stage of stand
stump_sum = 0
zeig=>pt%first
do
if(.not.associated(zeig)) exit
taxnr=zeig%coh%species
if(zeig%coh%ntreem>0)then
! all parts without stems of trees are input for litter
zeig%coh%litC_fol = zeig%coh%litC_fol + zeig%coh%ntreem*(1.-spar(taxnr)%psf)*zeig%coh%x_fol*cpart
zeig%coh%litN_fol = zeig%coh%litN_fol + zeig%coh%ntreem*((1.-spar(taxnr)%psf)*zeig%coh%x_fol*cpart)/spar(taxnr)%cnr_fol
zeig%coh%litC_frt = zeig%coh%litC_frt + zeig%coh%ntreem*zeig%coh%x_frt*cpart
zeig%coh%litN_frt = zeig%coh%litN_frt + zeig%coh%ntreem*zeig%coh%x_frt*cpart/spar(taxnr)%cnr_frt
zeig%coh%litC_tb = zeig%coh%litC_tb + zeig%coh%ntreem*zeig%coh%x_tb*cpart
zeig%coh%litN_tb = zeig%coh%litN_tb + zeig%coh%ntreem*zeig%coh%x_tb*cpart/spar(taxnr)%cnr_tbc
zeig%coh%litC_crt = zeig%coh%litC_crt + zeig%coh%ntreem*zeig%coh%x_crt*cpart
zeig%coh%litN_crt = zeig%coh%litN_crt + zeig%coh%ntreem*zeig%coh%x_crt*cpart/spar(taxnr)%cnr_crt
! stumps into stem litter
call stump( zeig%coh%x_ahb, zeig%coh%asapw,zeig%coh%dcrb,zeig%coh%x_hbole, &
zeig%coh%height, taxnr,stump_v, stump_dw)
zeig%coh%litC_stem = zeig%coh%litC_stem + zeig%coh%ntreem*stump_dw*cpart
zeig%coh%litN_stem = zeig%coh%litC_stem/spar(taxnr)%cnr_stem
stump_sum = stump_sum + zeig%coh%ntreem*stump_dw
if(maninf.eq.'brushing'.and.flag_brush.ne.0) then
zeig%coh%litC_stem =zeig%coh%litC_stem + zeig%coh%ntreem*(zeig%coh%x_sap+zeig%coh%x_hrt)*cpart
zeig%coh%litN_stem = zeig%coh%litC_stem/spar(taxnr)%cnr_stem
end if
endif
zeig=>zeig%next
enddo
END SUBROUTINE thinning
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
! SR for clear cut
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
SUBROUTINE felling(nr,i)
use data_stand
use data_manag
use data_simul
use data_species
use data_par
use data_soil_cn
implicit none
integer :: taxnr, i, nr
real :: stump_v, stump_dw, help
zeig=>pt%first
do
if(.not.associated(zeig)) exit
taxnr = zeig%coh%species
if(taxnr.le.nspec_tree) then
if(thr7.eq.2.and. taxnr.eq.nr) then
zeig%coh%ntreem = zeig%coh%ntreea
zeig%coh%ntreea = 0
zeig%coh%nta = 0.
else if(thr7.ne.2.and. taxnr.eq.nr.and. zeig%coh%x_age.eq.age_spec(i).and. zeig%coh%shelter.eq.1) then
zeig%coh%ntreem = zeig%coh%ntreea
zeig%coh%ntreea = 0
zeig%coh%nta = 0.
end if
else
! reduction of soil vegetation after felling
taxnr = zeig%coh%species
help = zeig%coh%x_fol
zeig%coh%x_fol = 0.005*help
zeig%coh%litC_fol = zeig%coh%litC_fol + 0.995*zeig%coh%ntreem*(1.-spar(taxnr)%psf)*help*cpart
zeig%coh%litN_fol = zeig%coh%litN_fol + 0.995*zeig%coh%ntreem*((1.-spar(taxnr)%psf)*help*cpart)/spar(taxnr)%cnr_fol
help = zeig%coh%x_frt
zeig%coh%x_frt = 0.005*help
zeig%coh%litC_frt = zeig%coh%litC_frt + 0.995*zeig%coh%ntreem*help*cpart
zeig%coh%litN_frt = zeig%coh%litN_frt + 0.995*zeig%coh%ntreem*help*cpart/spar(taxnr)%cnr_frt
help = zeig%coh%x_sap
zeig%coh%x_sap = 0.005*help
zeig%coh%litC_fol = zeig%coh%litC_fol + 0.995*zeig%coh%ntreem*help*cpart
zeig%coh%litN_fol = zeig%coh%litN_fol + 0.995*zeig%coh%ntreem*((1.-spar(taxnr)%psf)*help*cpart)/spar(taxnr)%cnr_fol
zeig%coh%Fmax = zeig%coh%x_fol
zeig%coh%t_leaf = zeig%coh%med_sla* zeig%coh%x_fol ! [m2]
zeig%coh%nta = zeig%coh%nTreeA
end if
zeig=>zeig%next
end do
zeig=>pt%first
do
if(.not.associated(zeig)) exit
taxnr=zeig%coh%species
if(zeig%coh%ntreem>0.and. taxnr.eq.nr)then
! all parts without stems of trees are input for litter
zeig%coh%litC_fol = zeig%coh%litC_fol + zeig%coh%ntreem*(1.-spar(taxnr)%psf)*zeig%coh%x_fol*cpart
zeig%coh%litN_fol = zeig%coh%litN_fol + zeig%coh%ntreem*((1.-spar(taxnr)%psf)*zeig%coh%x_fol*cpart)/spar(taxnr)%cnr_fol
zeig%coh%litC_frt = zeig%coh%litC_frt + zeig%coh%ntreem*zeig%coh%x_frt*cpart
zeig%coh%litN_frt = zeig%coh%litN_frt + zeig%coh%ntreem*zeig%coh%x_frt*cpart/spar(taxnr)%cnr_frt
zeig%coh%litC_tb = zeig%coh%litC_tb + zeig%coh%ntreem*zeig%coh%x_tb*cpart
zeig%coh%litN_tb = zeig%coh%litN_tb + zeig%coh%ntreem*zeig%coh%x_tb*cpart/spar(taxnr)%cnr_tbc
zeig%coh%litC_crt = zeig%coh%litC_crt + zeig%coh%ntreem*zeig%coh%x_crt*cpart
zeig%coh%litN_crt = zeig%coh%litN_crt + zeig%coh%ntreem*zeig%coh%x_crt*cpart/spar(taxnr)%cnr_crt
! stumps into stem litter
call stump( zeig%coh%x_ahb, zeig%coh%asapw,zeig%coh%dcrb,zeig%coh%x_hbole, &
zeig%coh%height, taxnr,stump_v, stump_dw)
zeig%coh%litC_stem = zeig%coh%litC_stem + zeig%coh%ntreem*stump_dw*cpart
zeig%coh%litN_stem = zeig%coh%litC_stem/spar(taxnr)%cnr_stem
stump_sum = stump_sum + zeig%coh%ntreem*stump_dw
endif
zeig=>zeig%next
enddo
END SUBROUTINE felling
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
! subroutine for shelterwood management
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
SUBROUTINE shelterwood_man(nrsh,inum,domage)
use data_stand
use data_manag
use data_simul
use data_par
use data_species
implicit none
real :: bared, & ! reduction of basal area
bas_help, &
bas_area, &
pequal, &
domage, &
help, &
stump_v, &
stump_dw
integer :: taxnr, &
flagc, &
flagexit, &
num_coh, &
thinflag, j, &
count, third,&
counth, &
anz_treesh=0, &
anz_2th, &
nrsh, &
minident, &
inum, help_shnum
integer, dimension(1:anz_coh) :: coh_2th
allocate (dbh_rank(anz_coh))
minident = 100000
bas_area = 0.
anz_treesh = 0
help_shnum = 0
! tending of trees, planted at first shelterwood treatment
help = time - shelteryear
IF(help.eq.15..and.flag_shelter.eq.1 .and.shelteryear.ne.0) THEN
call tending(nrsh,inum)
END IF
! labelling of trees for shelterwood at first shelterwood treatment
if (shelteryear.eq.0.or.shelteryear.eq.time) then
zeig=>pt%first
do
if(.not.associated(zeig)) exit
write(5432,*) zeig%coh%ntreea
if(zeig%coh%species.eq.nrsh.and.zeig%coh%x_age.gt.10) zeig%coh%shelter = 1.
zeig=> zeig%next
end do
end if
! calculation of number of shelter trees
zeig=>pt%first
do
if(.not.associated(zeig)) exit
if(zeig%coh%shelter.eq.1.and. zeig%coh%species.eq.nrsh) anz_treesh = anz_treesh +zeig%coh%ntreea
zeig=>zeig%next
end do
write(5432,*) time, 'anz_treesh', anz_treesh
count = 0
IF((time-shelteryear).eq.15 .or. shelteryear .eq. 0..or.shelteryear.eq.time) THEN
call dimsort(anz_coh, 'dbh',dbh_rank)
flag_manreal = 1
if (shelteryear.eq.0) then
maninf = 'shelterwood system1'
else
maninf = 'shelterwood system2'
end if
meas = 0
third = nint(anz_treesh*0.3333333)
taxnr = nrsh
! calculation of basal area of shelterwood
zeig => pt%first
DO
IF (.NOT. ASSOCIATED(zeig)) EXIT
if(zeig%coh%shelter.eq.1.and. zeig%coh%species.eq.taxnr) then
IF((zeig%coh%ntreea>0).and.(zeig%coh%diam>0)) THEN
bas_area = bas_area + zeig%coh%ntreea*(zeig%coh%diam**2)*pi/4.
End if
end if
zeig => zeig%next
ENDDO
! declaration of reduction coefficient of basal area
if(domage.eq.regage(domspec)) then
bared = 0.3
else
bared = 0.4
end if
! lower two thirds sorted by diameter in coh_2th
counth = 0
flagexit = 0
flagc = 0
anz_2th = 0
coh_2th = -1
if(anz_tree>1) then
do j = 1,anz_coh
zeig => pt%first
do
if(.not.associated(zeig)) exit
if(zeig%coh%ident.eq.dbh_rank(j).and.zeig%coh%shelter.eq.1.and. zeig%coh%species.eq.nrsh) then
counth = counth + zeig%coh%ntreea
anz_2th = anz_2th +1
if(counth.ge.2*third) flagexit =1
coh_2th(anz_2th) = zeig%coh%ident
if(zeig%coh%ident.lt.minident) minident =zeig%coh%ident
flagc = 1
end if
if(flagc.eq.1) exit
zeig=>zeig%next
end do
if (flagexit.eq.1) exit
flagc = 0
end do
end if
! thinning with equal distribution from cohorts listed in coh_2th
bas_help = bas_area
DO
flagexit = 0
thinflag = 0
call random_number(pequal)
num_coh = nint(pequal*anz_2th + 0.5)
zeig=> pt%first
do
if(.not.associated(zeig)) exit
if(zeig%coh%ident.eq.coh_2th(num_coh).and.zeig%coh%shelter.eq.1.and. zeig%coh%species.eq.nrsh) then
if(zeig%coh%ntreea.ge.1) then
zeig%coh%ntreea = zeig%coh%ntreea - 1
help_shnum = help_shnum +1
zeig%coh%nta = zeig%coh%nta -1.
zeig%coh%ntreem = zeig%coh%ntreem + 1
bas_help = bas_help - (zeig%coh%diam**2)*pi/4
thinflag = 1
end if
end if
if(thinflag.eq.1) exit
zeig=>zeig%next
end do
if(bas_help.le.(bas_area -bas_area*bared)) exit
if(help_shnum.eq. counth) exit
END DO
! adding biomasses to litter pools depending on stage of stand
if(anz_treesh>0) then
zeig=>pt%first
do
if(.not.associated(zeig)) exit
taxnr=zeig%coh%species
if(zeig%coh%ntreem>0..and. zeig%coh%species.eq.nrsh)then
! all parts without stems of trees are input for litter
zeig%coh%litC_fol = zeig%coh%litC_fol + zeig%coh%ntreem*(1.-spar(taxnr)%psf)*zeig%coh%x_fol*cpart
zeig%coh%litN_fol = zeig%coh%litN_fol + zeig%coh%ntreem*((1.-spar(taxnr)%psf)*zeig%coh%x_fol*cpart)/spar(taxnr)%cnr_fol
zeig%coh%litC_frt = zeig%coh%litC_frt + zeig%coh%ntreem*zeig%coh%x_frt*cpart
zeig%coh%litN_frt = zeig%coh%litN_frt + zeig%coh%ntreem*zeig%coh%x_frt*cpart/spar(taxnr)%cnr_frt
zeig%coh%litC_tb = zeig%coh%litC_tb + zeig%coh%ntreem*zeig%coh%x_tb*cpart
zeig%coh%litN_tb = zeig%coh%litN_tb + zeig%coh%ntreem*zeig%coh%x_tb*cpart/spar(taxnr)%cnr_tbc
zeig%coh%litC_crt = zeig%coh%litC_crt + zeig%coh%ntreem*zeig%coh%x_crt*cpart
zeig%coh%litN_crt = zeig%coh%litN_crt + zeig%coh%ntreem*zeig%coh%x_crt*cpart/spar(taxnr)%cnr_crt
! stumps into stem litter
call stump( zeig%coh%x_ahb, zeig%coh%asapw,zeig%coh%dcrb,zeig%coh%x_hbole, &
zeig%coh%height,taxnr, stump_v, stump_dw)
zeig%coh%litC_stem = zeig%coh%litC_stem + zeig%coh%ntreem*stump_dw*cpart
zeig%coh%litN_stem = zeig%coh%litC_stem/spar(taxnr)%cnr_stem
stump_sum = stump_sum + zeig%coh%ntreem*stump_dw
! stump biomass is added to stem litter litC_stem, litN_stem
endif
zeig=>zeig%next
enddo
END IF
end if ! anz_treesh
deallocate(dbh_rank)
END SUBROUTINE shelterwood_man
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
SUBROUTINE min_dbh(nrmin,help_h1,agedm, spnr)
use data_stand
implicit none
integer :: nrmin,spnr, agedm, agedmh
integer :: nrmin_h
integer :: testflag
real :: help_h1, help_h2
testflag=0
agedm = -1
agedmh = -1
nrmin = -1
nrmin_h = -1
help_h2=0.
help_h1=1000.
zeig=>pt%first
do
if(.not.associated(zeig)) exit
if(zeig%coh%species.eq.spnr) then
if(zeig%coh%diam.gt.0.) then
help_h2= zeig%coh%diam
nrmin_h = zeig%coh%ident
agedmh = zeig%coh%x_age
if(help_h2.lt. help_h1) then
help_h1 = help_h2
nrmin = nrmin_h
agedm = agedmh
end if
end if
end if
zeig=>zeig%next
end do
END SUBROUTINE min_dbh
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
SUBROUTINE min_dbh_tar(nrmin,help_h1,spnr,tar)
use data_stand
implicit none
integer :: nrmin,spnr
integer :: nrmin_h
integer :: testflag
real :: help_h1, help_h2
real :: tar
testflag=0
nrmin = -1
nrmin_h = -1
help_h2=0.
help_h1=1000.
zeig=>pt%first
do
if(.not.associated(zeig)) exit
if(zeig%coh%species.eq.spnr) then
if(zeig%coh%diam.gt.0..and. zeig%coh%height.gt.tar) then
help_h2= zeig%coh%diam
nrmin_h = zeig%coh%ident
if(help_h2.lt. help_h1) then
help_h1 = help_h2
nrmin = nrmin_h
end if
end if
end if
zeig=>zeig%next
end do
END SUBROUTINE min_dbh_tar
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
SUBROUTINE min_dbh_overs(nrmin,help_h1,spnr)
use data_stand
implicit none
integer :: nrmin,spnr
integer :: nrmin_h
integer :: testflag
real :: help_h1, help_h2
testflag=0
nrmin = -1
nrmin_h = -1
help_h2=0.
help_h1=1000.
zeig=>pt%first
do
if(.not.associated(zeig)) exit
if(zeig%coh%species.eq.spnr) then
if(zeig%coh%diam.gt.0..and. zeig%coh%underst.eq.0) then
help_h2= zeig%coh%diam
nrmin_h = zeig%coh%ident
if(help_h2.lt. help_h1) then
help_h1 = help_h2
nrmin = nrmin_h
end if
end if
end if
zeig=>zeig%next
end do
END SUBROUTINE min_dbh_overs
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
SUBROUTINE min_dbh_unders(nrmin,help_h1,spnr)
use data_stand
implicit none
integer :: nrmin,spnr
integer :: nrmin_h
integer :: testflag
real :: help_h1, help_h2
testflag=0
nrmin = -1
nrmin_h = -1
help_h2=0.
help_h1=1000.
zeig=>pt%first
do
if(.not.associated(zeig)) exit
if(zeig%coh%species.eq.spnr) then
if(zeig%coh%diam.gt.0..and. zeig%coh%underst.eq.2) then
help_h2= zeig%coh%diam
nrmin_h = zeig%coh%ident
if(help_h2.lt. help_h1) then
help_h1 = help_h2
nrmin = nrmin_h
end if
end if
end if
zeig=>zeig%next
end do
END SUBROUTINE min_dbh_unders
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
SUBROUTINE max_dbh(nrmax,help_h1,agedm,spnr)
use data_stand
implicit none
integer :: nrmax,spnr, agedm, agedmh
integer :: nrmax_h
integer :: testflag
real :: help_h1, help_h2
testflag=0
agedm =-1
agedmh = -1
nrmax = -1
nrmax_h = -1
help_h2=0.
help_h1=0.
zeig=>pt%first
do
if(.not.associated(zeig)) exit
if(zeig%coh%species.eq.spnr) then
if(zeig%coh%diam.gt.0.) then
help_h2= zeig%coh%diam
nrmax_h = zeig%coh%ident
agedmh = zeig%coh%x_age
if(help_h2.gt. help_h1) then
help_h1 = help_h2
nrmax = nrmax_h
agedm = agedmh
end if
end if
end if
zeig=>zeig%next
end do
END SUBROUTINE max_dbh
!
! calculation of cohort number with maximal diameter
!
SUBROUTINE max_diam(nrmax,anz,cohl, specnum)
use data_stand
implicit none
integer :: nrmax,i
integer :: nrmax_h, specnum
integer :: anz, testflag
real :: help_h1, help_h2
integer,dimension(0:anz_coh) :: cohl
testflag=0
nrmax = -1
nrmax_h = -1
help_h2=0.
help_h1=0.
zeig=>pt%first
do
if(.not.associated(zeig)) exit
do i=0,anz-1
if(cohl(i).eq.zeig%coh%ident.and. zeig%coh%species.eq.specnum) then
testflag=1
endif
end do
if (testflag.eq.0) then
help_h2= zeig%coh%diam
nrmax_h = zeig%coh%ident
if(help_h2.gt. help_h1) then
help_h1 = help_h2
nrmax = nrmax_h
end if
end if
zeig=>zeig%next
testflag = 0
end do
anz = anz +1
cohl(anz-1) = nrmax
END SUBROUTINE max_diam
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
! SR calc_usp
! calculaiton of percent of using (NUtzungsprozent)
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
subroutine calc_usp (taxnr,ages,density,c_usp)
use data_species
use data_manag
real ::density, c_usp
real,dimension(20) :: spec_den=(/0.,0.8,0.9,1.,0.8,0.9,1.,1.1,0.8,0.9,1.,1.1,0.7,0.8,0.9,1.,0.7,0.8,0.9,1./)
integer, dimension(13) :: age_den=(/15,20,25,30,35,40,45,50,60,70,80,100,120/)
integer :: j, i,help1, taxnr,ages
c_usp =0.
do i=1,3
help1=(taxnr-1)*4+i
if(density.gt.spec_den(help1).and. density.le.spec_den(help1+1)) then
do j= 1,12
if(ages.ge.age_den(j).and.ages.lt.age_den(j+1))then
c_usp = usp(help1,j)
end if
end do
end if
end do
help1=(taxnr-1)*4+4
if(c_usp.eq.0..and. density.gt.spec_den(help1)) then
do j= 1,12
if(ages.ge.age_den(j).and.ages.lt.age_den(j+1))then
c_usp = usp(help1,j)
end if
end do
else if (c_usp.eq.0..and.density .le. spec_den( help1-3)) then
do j= 1,12
if(ages.ge.age_den(j).and.ages.lt.age_den(j+1))then
c_usp = usp(help1-3,j)
end if
end do
end if
end subroutine calc_usp
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
! 4C-
! Subroutine calc_gfbg
! calculation of optimal basal area
! coresponding to functions from
! A. Degenhardt: Algorithmen und Programme zur
! waldwachstumskundlichen Auswertung von
! Versuchs- und probeflchen
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
SUBROUTINE calc_gfbg(gfbg, ntax, stage, hg)
use data_par
use data_stand
implicit none
real, dimension(12) :: p=(/5.3774914,4.3364045,1.7138966, &
0.1791894,0.6499329,0.581721, &
0.64149,1.39876,0.38106,3.48086,4.55256,1.10352/) ! parameter pinus
real, dimension(14) :: s=(/52.021649311,17.01260031,1.817338508, &
3.97091538,0.165219412,0.017015893, &
17.17273582,77.00271993,180.95845108,69.85082406, &
0.284339648,6.211490243,8.057235477,2.600807284/) ! parameter spruce
real, dimension(11) :: b=(/5.1961292,5.8518918,2.048007, &
0.1517038,0.8873933,0.9555725, &
0.845794,29.76635,9.89798,0.2033,0.092586/) ! parameter beech
real, dimension(16) :: o=(/10.937989911, 30.98059032,36.683338986,4.8203797, &
0.217782149,0.559666286,1.253027352,2.447035652, &
3.172437267,26.001075916,15.01095715,2.411330088, &
0.286619845,0.126747922,0.121360347,0.05650846/)
real, dimension(9) :: bi=(/2.304633491,5.7831992,0.057831992, &
99.89719563,4983.109428, 387539.3699, &
192.06078091,0.070580839, 0.624018136/) ! birch (Sandbirke)
real, dimension(16) :: pa=(/12.114711547,13.90837359,11.746497917, 2.963065353, &
0.298215006,0.325115413,0.46694307,0.043088114, &
5.314568374, 9.635476988, 23.20634163,9.473964111, &
0.845408671,0.187292811,0.025416101,0.050721202/)
real :: abon, &
rbon, &
h1,h2,h3,h4,alt10, alt100, nvb, dgvb,gfbg,stage,hg
integer :: ntax
alt10= 10/stage
alt100= stage/100
h1 = 0.;h2=0.;h3=0.;h4=0.
select case(ntax)
case(1) ! beech
h1 = b(1) + b(2)*alt100 - b(3)*alt100*alt100
h2 = -b(4) - b(5)*alt10 - b(6)*alt10*alt10
rbon = h1+h2*hg
abon = 36.- 4.*rbon
gfbg = b(7) + b(8)*alt100 -b(9)*alt100*alt100 +abon*(b(10) + b(11)*alt100)
case(2) ! spruce
h1 = (alog(hg)-s(4))/(-s(5)+alog(1.-exp(-s(6)*stage)))
abon = s(1)-s(2)*h1 +s(3)*h1*h1
rbon = (38.-abon)/4.
h2 = - s(7)-s(8)*alt100+s(9)*alt100*alt100-s(10)*alt100*alt100*alt100
h3 = s(11) + s(12)*alt100 -s(13)*alt100*alt100 + s(14)* alt100*alt100*alt100
gfbg = h2 + h3*abon
case(3) ! pine
h1 = p(1) + p(2)*alt100 - p(3)*alt100*alt100
h2 = -p(4) - p(5)*alt10 -p(6)*alt10*alt10
rbon = h1 + h2*hg
abon = 32.- 4.*rbon
h3 = p(7)+p(8)*alog10(stage)-p(9)*alog10(stage)*alog10(stage)
h4 = -p(10) + p(11)*alog10(stage) - p(12)*alog10(stage)*alog10(stage)
gfbg = 0.01*abon*10**h3 + 10**h4
case(4) ! oak
h1 = o(1) - o(2)*alt10 + o(3)*alt10*alt10 - o(4)*alt10*alt10*alt10
h2 =- o(5) - o(6)* alt10 + o(7)*alt10*alt10 - o(8)* alt10*alt10*alt10
rbon = h1 + h2*hg
abon = 31.3 - 3.9*rbon
h3 = o(9) + o(10)* alt100 -o(11)*alt100*alt100 + o(12)*alt100*alt100*alt100
h4 = o(13) + o(14)*alt100 - o(15)*alt10*alt100 + o(16)*alt100*alt100*alt100
gfbg = h3 + h4*abon
case(5) ! birch
rbon = 9. - 0.25*(hdom/100.)*exp(-bi(1)*(exp(-bi(2))-exp(-bi(3)*stage)))
abon = 36. - 4.*rbon
nvb = -bi(4) - bi(5)*(1./(hdom/100.)) +bi(6)*(1./(hdom/100.))*(1./(hdom/100.))
dgvb = bi(7)*(1. + bi(8)*nvb)**(-bi(9))
gfbg = pi*dgvb*dgvb*nvb/(4*10000)
case(8) ! aspen
h1= pa(1) - pa(2)*alt10+pa(3)*alt10*alt10-pa(4)*alt10*alt10*alt10
h2 = -pa(5)+pa(6)*alt10-pa(7)*alt10*alt10+pa(8)*alt10*alt10*alt10
rbon=h1+h2*hdom
abon=36.-4*rbon
h3 = -pa(9)+pa(10)*alt10-pa(11)*alt10*alt10+pa(12)*alt10*alt10*alt10
h4 = pa(13)-pa(14)*alt10 + pa(15)*alt10*alt10 -pa(16)*alt10*alt10*alt10
gfbg = h3 + h4*abon
end select
END SUBROUTINE calc_gfbg
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
SUBROUTINE stump(x1, x2, xdcrb, xhbo, xh, i, stump_v, stump_dw)
use data_tsort
use data_par
use data_species
implicit none
real :: x1, x2, xdcrb, xhbo, xh, diam_base, dbsto, v1, stump_v, stump_dw
integer :: i
diam_base= sqrt((x1+x2)*4/pi)
if(xhbo.ne.0) then
dbsto = xdcrb + (xhbo-stoh(i))*(diam_base-xdcrb)/xhbo
else if (xhbo.eq.0)then
dbsto = diam_base*(xh+stoh(i))/xh
end if
! volume of stump
v1 = pi* stoh(i)*(diam_base*diam_base + diam_base*dbsto + dbsto*dbsto)/3. ! frustum
stump_v = v1/1000000. ! m
stump_dw = v1*spar(i)%prhos ! kg DW
END SUBROUTINE stump
source_code/version_2.3_windows/management.f 0 → 100644
View file @ 82df1085
!*****************************************************************!
!* *!
!* 4C (FORESEE) *!
!* *!
!* *!
!* Subroutines for: *!
!* management *!
!* contains: *!
!* SR manag_ini *!
!* SR manag_menu *!
!* SR simple_ini *!
!* SR adap_ini *!
!* SR management *!
!* SR simple_manag *!
!* SR adap_manag *!
!* SR target_manag *!
!* SR target_ini *!
!* *!
!* Copyright (C) 1996-2018 *!
!* Potsdam Institute for Climate Impact Reserach (PIK) *!
!* Authors and contributors see AUTHOR file *!
!* This file is part of 4C and is licensed under BSD-2-Clause *!
!* See LICENSE file or under: *!
!* http://www.https://opensource.org/licenses/BSD-2-Clause *!
!* Contact: *!
!* https://gitlab.pik-potsdam.de/foresee/4C *!
!* *!
!*****************************************************************!
SUBROUTINE manag_ini
use data_manag
use data_simul
use data_stand
implicit none
!call manag_menu
select case(flag_mg)
case(1)
call simple_ini
case(2)
if(anz_spec.ne.0) call adap_ini
case(3, 33, 333)
call target_ini
case(44)
call man_liocourt_ini
case(8)
call aspman_ini
case(9)
call aust_ini
end select
contains
SUBROUTINE simple_ini
! read definition of simple thinning from file
integer :: manag_unit,i
character(len=150) :: filename
logical :: ex
manag_unit=getunit()
filename = manfile(ip)
call testfile(filename,ex)
open(manag_unit,file=trim(filename))
read(manag_unit,*) thin_nr ! number of thinning years
allocate(thin_year(thin_nr));allocate(thin_tree(thin_nr))
do i=1,thin_nr
read(manag_unit,*) thin_year(i),thin_tree(i)
end do
close(manag_unit)
end SUBROUTINE simple_ini
end SUBROUTINE manag_ini
!-------------------------------------------------
! control of management regime and call
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
SUBROUTINE management
use data_simul
use data_stand
use data_species
use data_manag
use data_out
implicit none
integer diffanz
if (flag_standup .eq. 0) flag_standup = 1
select case(flag_mg)
case(1)
call simple_manag
case(2)
call adap_manag
case(3, 33, 333)
call target_manag
case(44)
call liocourt_manag
case(8)
call asp_manag
case(9)
call aust_manag
case(10)
call dis_manag
case default
end select
contains
SUBROUTINE simple_manag
integer taxnr, cohnr
real minheight
! simple thinning with fitting to default stem number
if(anz_tree>thin_tree(act_thin_year)) then
diffanz = anz_tree - thin_tree(act_thin_year)
minheight = 100000.
do
!repeat while diffanz>0)
if(diffanz<0.1) exit
zeig=>pt%first
!search for cohort with minimal height
do
if(.not.associated(zeig)) exit
if(zeig%coh%ntreea>0.1 .and. zeig%coh%height<minheight)then
minheight=zeig%coh%height; cohnr=zeig%coh%ident
endif
zeig=>zeig%next
enddo
! delete smallest trees
zeig=>pt%first
do
if(.not.associated(zeig)) exit
if(zeig%coh%ident==cohnr)then
if(diffanz <= zeig%coh%ntreea) then
zeig%coh%ntreea = zeig%coh%ntreea - diffanz
zeig%coh%ntreem = diffanz
diffanz=0.
else
diffanz = diffanz - zeig%coh%ntreea
zeig%coh%ntreem = zeig%coh%ntreea
zeig%coh%ntreea = 0.
endif
minheight=100000.
exit
endif
zeig=>zeig%next
enddo
enddo
else
call error_mess(time,"no management possible, tree number undersized : ", REAL(anz_tree))
endif
! number of trees and litter pools of managed trees
zeig=>pt%first
anz_tree=0.
do
if(.not.associated(zeig)) exit
taxnr=zeig%coh%species
anz_tree=anz_tree+zeig%coh%ntreea
if(zeig%coh%ntreem>0 .and.zeig%coh%ntreed==0.)then
zeig%coh%litC_fol = zeig%coh%litC_fol + (1.-spar(taxnr)%psf)*zeig%coh%x_fol/2.
zeig%coh%litN_fol = zeig%coh%litN_fol + ((1.-spar(taxnr)%psf)*zeig%coh%x_fol/2.)*0.02
zeig%coh%litC_frt = zeig%coh%litC_frt + zeig%coh%x_frt/2.
zeig%coh%litN_frt = zeig%coh%litN_frt + (zeig%coh%x_frt/2.)*0.023
endif
zeig=>zeig%next
enddo
end SUBROUTINE simple_manag
end SUBROUTINE management
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! input of control parameters for adaptation management
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
SUBROUTINE adap_ini
use data_manag
use data_simul
use data_species
use data_stand
use data_out
implicit none
! read definition of adapted thinning from file
integer :: manag_unit,i,j
character(len=150) :: filename
logical :: ex
character ::text
manag_unit=getunit()
filename = manfile(ip)
allocate(zbnr(nspec_tree))
allocate(tend(nspec_tree))
allocate(rot(nspec_tree))
allocate(thin_flag1(nspec_tree))
allocate(thin_flag2(nspec_tree))
allocate(thin_flag3(nspec_tree))
allocate(thin_flag4(nspec_tree))
allocate(regage(nspec_tree))
allocate(np_mod(nspec_tree))
allocate(thinyear(nspec_tree))
allocate(specnr(nspec_tree))
allocate(age_spec(nspec_tree))
allocate(anz_tree_spec(nspec_tree))
thinyear =0
thin_flag1=0
thin_flag2=0
thin_flag3=0
thin_flag4=0
flag_manreal = 0
flag_shelter = 0
shelteryear = 0
call testfile(filename,ex)
open(manag_unit,file=trim(filename))
! read head of data-file
do
read(manag_unit,*) text
if(text .ne. '!')then
backspace(manag_unit);exit
endif
enddo
! dominant species
read(manag_unit,*) domspec
! domimant height levels
read(manag_unit,*) ho1,ho2,ho3,ho4
! thinning regimes
read (manag_unit,*) thin_flag1(1),thr1, thr2,thr3,thr4,thr5,thr6, thr7, mgreg, domspec_reg
do j=2,nspec_tree
thin_flag1(j)= thin_flag1(1)
end do
if(thin_flag1(1) <0) then
close(manag_unit)
return
end if
! limit for hight query
read (manag_unit,*) limit
!test
limit = limit + 30.
! number of years between thinning
read (manag_unit,*) thinstep
! relative thinning for young trees
read (manag_unit,*) direcfel
! control variables for thinning depending on basal area
read (manag_unit,*) thin_ob, optb
! number of 'Zielb�ume' (target trees)
read (manag_unit,*) (zbnr(i), i =1, nspec_tree)
! relative thinning value for tending of plantations
read (manag_unit,*) (tend(i), i =1, nspec_tree)
! rotation
read (manag_unit,*) (rot(i), i =1, nspec_tree)
! age of natural/planted regeneration
read (manag_unit,*) (regage(i), i =1, nspec_tree)
do j= 1,20
read (manag_unit,*) (usp(j,i), i=1,13)
end do
read (manag_unit,*) (np_mod(i), i = 1,nspec_tree)
close(manag_unit)
if (flag_reg .ne. 0) then
WRITE(unit_ctr,*) ' '
WRITE(unit_ctr,*) '***Managment parameter case flag_mg = 2 (user specified) ***'
WRITE(unit_ctr,'(A35,4F15.5)') 'height for management control(cm)', ho1,ho2,ho3,ho4
WRITE(unit_ctr,'(A35,6I15)') 'man. flags thin_flag1, thr1-thr5' , thin_flag1(1),thr1,thr2, thr3,thr4,thr5
WRITE(unit_ctr,'(A35,F15.5)') 'height for directional felling', thr6
WRITE(unit_ctr,'(A35,I15)') 'measure at rotation', thr7
WRITE(unit_ctr,'(A35,I15)') 'regeneration measure', mgreg
WRITE(unit_ctr,'(A35,F15.5)') 'lower/upper limit of height(cm)', limit
WRITE(unit_ctr,'(A35,I15)') 'number of years between thinning',thinstep
WRITE(unit_ctr,'(A35,F15.5)') 'rel. value for directional felling', direcfel
WRITE(unit_ctr,'(A35,2F15.5)') 'thinning depending on basal area function thin_ob (0,1), optb ', thin_ob, optb
WRITE(unit_ctr,'(A35,5F15.5)')'number of Zielb�ume (spec.)', (zbnr(i),i=1,nspec_tree)
WRITE(unit_ctr,'(A35,5F15.5)')'rel. value for tending of pl.',(tend(i), i =1,nspec_tree)
WRITE(unit_ctr,'(A35,5I15)')'rotation ',(rot(i), i =1,nspec_tree)
WRITE(unit_ctr,'(A35,5I15)')'age of nat./pl. regeneration',(regage(i), i =1,nspec_tree)
close(unit_ctr)
end if
end SUBROUTINE adap_ini
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! routines for adaptation management
! based on concepts from P. Mohr, P.Lasch. D. Gerold....
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
SUBROUTINE adap_manag
use data_stand
use data_manag
use data_simul
use data_par
use data_species
implicit none
real :: c1, &
helphd,helpmax, helpi, & ! hdom species specific
domage
real :: sumdh, sumd ! for calculation of HG
real :: bg ! stocking degree
real :: stage
real :: dfbg ! optimal basal area
real :: hg ! height of DG
integer :: c2, &
taxnr, &
actspec, & ! number of species for thinning
th_help, i,j ,k, &
testflag, &
nrfel, &
flag_prep, &
flag_fell, &
inum, &
domage_sh, &
domspec_sh, &
flag_reg_act
real,dimension(nspecies) :: bas_area_spec
real,dimension(nspecies) :: help
flag_reg_act = 100
domage = 0.
domspec_sh = 0
help = 0.
helpmax = 0.
helpi =0
bas_area_spec = 0.
domage_sh = 0
flag_fell = 0
stand_age=0
flag_prep = 0
anz_tree_spec = 0
anz_tree_dbh = 0
flag_adapm = 0.
specnr = 0.
age_spec = 0.
basarea_tot = 0.
sumd = 0.
sumdh = 0.
! determine number of species in cohort list
if(anz_spec.eq.0) return
if(thin_flag1(1) <0) return
IF(anz_spec.eq.1) then
! stand age as maximum age of cohorts
zeig => pt%first
DO
IF (.NOT. ASSOCIATED(zeig)) EXIT
if(zeig%coh%species.le.nspec_tree) then
taxnr = zeig%coh%species
if(zeig%coh%x_age.gt. stand_age) stand_age = zeig%coh%x_age
if(zeig%coh%ntreea.ne.0.and. zeig%coh%diam.gt.0.) then
sumd = sumd + zeig%coh%diam*zeig%coh%diam
sumdh = sumdh + zeig%coh%diam*zeig%coh%diam*zeig%coh%height
basarea_tot = basarea_tot + zeig%coh%ntreea*(zeig%coh%diam**2)*pi/4.
bas_area_spec(taxnr) = bas_area_spec(taxnr) + zeig%coh%ntreea*(zeig%coh%diam**2)*pi/4.
end if
end if
zeig=>zeig%next
END DO
ELSE if(anz_spec.gt.1) then
! age of species i as maximum age of cohorts of this species
testflag = 0
i=1
zeig => pt%first
DO
IF (.NOT. ASSOCIATED(zeig)) EXIT
taxnr = zeig%coh%species
if(zeig%coh%ntreea.ne.0.and. zeig%coh%diam.gt.0.) then
basarea_tot = basarea_tot + zeig%coh%ntreea*(zeig%coh%diam**2)*pi/4.
bas_area_spec(taxnr) = bas_area_spec(taxnr) + zeig%coh%ntreea*(zeig%coh%diam**2)*pi/4.
end if
if(i.eq.1) then
specnr(i) = zeig%coh%species
if(zeig%coh%x_age.gt. age_spec(i)) age_spec(i) = zeig%coh%x_age
i = i+1
else
do j= 1,i-1
if(specnr(j).eq. zeig%coh%species) testflag = 1
end do
if (testflag.eq.0) then
specnr(i) = zeig%coh%species
if(zeig%coh%x_age.gt. age_spec(i)) age_spec(i) = zeig%coh%x_age
i = i+1
end if
testflag=0
end if
zeig=>zeig%next
END DO
DO i =1,anz_spec
zeig => pt%first
DO
IF (.NOT. ASSOCIATED(zeig)) EXIT
if(zeig%coh%species.eq.specnr(i).and.zeig%coh%x_age.gt. age_spec(i)) age_spec(i)= zeig%coh%x_age
zeig=>zeig%next
END DO
END DO
! if domspec is -99 then domspec is calculated by basal area
if( domspec.lt. 0 ) then
DO i = 1,nspecies
if (basarea_tot.ne.0) then
help(i) = bas_area_spec(i)/basarea_tot
if(help(i).gt. helpmax) then
helpmax = help(i)
helpi = i
end if
end if
end do
domspec = helpi
end if
! re-sorting of the filed specnr (at the first place of this field is the number of the dominanat species);
! this is necessary for managemnt of mixed stands becuase this management is according to the management
! of the dominanat species
! age of domspec
zeig => pt%first
DO
IF (.NOT. ASSOCIATED(zeig)) EXIT
if(zeig%coh%species.eq.domspec) then
if(zeig%coh%x_age.gt.domage) domage = zeig%coh%x_age
end if
zeig=>zeig%next
END DO
if(specnr(1).ne.domspec) then
do k=2,anz_spec
if(specnr(k).eq.domspec) then
specnr(k)=specnr(1)
age_spec(k)=age_spec(1)
specnr(1) = domspec
age_spec(1)=domage
exit
end if
end do
end if ! re-sorting
! species for shelterwood which is oldest
zeig => pt%first
DO
IF (.NOT. ASSOCIATED(zeig)) EXIT
if(zeig%coh%shelter.eq.1.and.zeig%coh%x_age.gt.domage.and.zeig%coh%x_age.gt.domage_sh) domage_sh = zeig%coh%x_age
zeig=>zeig%next
END DO
zeig => pt%first
DO
IF (.NOT. ASSOCIATED(zeig)) EXIT
if(zeig%coh%x_age.eq.domage_sh) domspec_sh = zeig%coh%species
zeig=>zeig%next
END DO
END IF
if (anz_spec.eq.1) then
specnr(1) = taxnr
age_spec(1) = stand_age
if(domspec.lt.0) domspec = taxnr
end if
DO i=1,anz_spec
anz_tree_spec(i) = 0
! caclulation of species specific number of trees
zeig=>pt%first
do
if(.not.associated(zeig)) exit
zeig%coh%ntreem = 0.
if(zeig%coh%diam.gt.0) anz_tree_dbh = anz_tree_dbh + zeig%coh%ntreea
if(zeig%coh%species.eq.specnr(i)) anz_tree_spec(i) = anz_tree_spec(i) + zeig%coh%ntreea
zeig=> zeig%next
end do
END DO ! species loop
if(domspec.lt.0) then
if(domage_sh.gt.domage) then
domage = domage_sh
domspec = domspec_sh
end if
end if
DO i=1,anz_spec
actspec = specnr(i)
zeig => pt%first
DO
IF (.NOT. ASSOCIATED(zeig)) EXIT
if(zeig%coh%species.le.nspec_tree) then
taxnr = zeig%coh%species
if(zeig%coh%ntreea.ne.0.and. zeig%coh%diam.gt.0..and.zeig%coh%species.eq.taxnr) then
stage = zeig%coh%x_age
sumd = sumd + zeig%coh%diam*zeig%coh%diam
sumdh = sumdh + zeig%coh%diam*zeig%coh%diam*zeig%coh%height
end if
end if
zeig=>zeig%next
END DO
! calculation HG (height for DG)
if(sumdh.ne.0) then
hg = (sumdh/sumd)/100.
else
hg = 0.
end if
IF (specnr(i).ne.0..and. domspec.ne.0) THEN
select case(thr7)
case(1) ! thr7
! shelterwood management
if(domspec.eq.actspec) then
if (age_spec(i).ge.regage(specnr(i)).and. age_spec(i).lt.(rot(specnr(i))-15.).and. time.ne.1) then
if(shelteryear.eq.0.and.flag_shelter.eq.0) flag_reg = mgreg
inum = i
if (flag_sh_first.ne.2) then
call shelterwood_man(specnr(inum),inum,domage)
end if
if(shelteryear.eq.0) flag_sh_first = 1
flag_shelter = 1
if(flag_sh_first.ne.2) then
select case(flag_reg)
case(1) ! mgreg
! natural regeneration allowed
flag_reg = 1
case(4,5,6,7,8,9,10,11,12,13,14,15) ! mgreg
! artificial regeneration
if(flag_reg_act.ne.0) call planting
flag_reg = 0
flag_reg_act = 0
end select
end if
flag_prep = 1
else if (age_spec(i).ge.rot(specnr(i)).and. time.ne.1) then
! clear felling
nrfel = specnr(i)
call felling(nrfel,i)
flag_manreal = 1
flag_shelter = 0
maninf = 'felling after shelterwood s.'
meas = 0
! set back because shelterwood m. is finished, management of regenerated stand starts
shelteryear = 0.
thin_flag1 = 0
thin_flag2 = 0
thin_flag3 = 0
thin_flag4 = 0
flag_prep = 1
if(flag_plant_shw.eq.1) then
! if no first and second sherterwood management was possibele than after clear cut planting is called
select case(mgreg)
case(1) ! mgreg
! natural regeneration allowed
flag_reg = 1
case(4,5,6,7,8,9,10,11,12,13,14,15) ! mgreg
! artificial regeneration
if(flag_reg_act.ne.0) then
flag_reg = mgreg
call planting
end if
flag_reg = 0
flag_reg_act = 0
flag_plant_shw =0
end select
end if
! if initial age is grater than age for first shleterwood treatment
else if(time.eq.1.and. age_spec(i).gt.regage(specnr(i)).and. age_spec(i).gt.(rot(specnr(i))-20) ) then
! flags for planting if felling is realised
flag_plant_shw = 1
flag_reg_act = 1
! in this case: to avoid sheletrwood management until rotation time
flag_sh_first = 2
shelteryear = 99
! labelling of cohorts as sheletrwood cohorts
zeig=>pt%first
do
if(.not.associated(zeig)) exit
zeig%coh%shelter=1
zeig=> zeig%next
end do
exit
else if(time.eq.1.and. age_spec(i).gt.regage(specnr(i)).and. age_spec(i).le.(rot(specnr(i))-20.)) then
! if initial age is greater than regeneration age(first shelterwood treatm.) and not too near to rotation age
! a new rotation age is defined with delaying
rot(specnr(i)) = rot(specnr(i)) + (age_spec(i) - regage(specnr(i)))
if(shelteryear.eq.0.and.flag_shelter.eq.0) flag_reg = mgreg
inum = i
call shelterwood_man(specnr(inum),inum,domage)
if(shelteryear.eq.0) flag_sh_first = 1
flag_shelter = 1
select case(flag_reg)
case(1) ! mgreg
! natural regeneration allowed
flag_reg = 1
case(4,5,6,7,8,9,10,11,12,13,14,15) ! mgreg
! artificial regeneration
if(flag_reg_act.ne.0) call planting
flag_reg = 0
flag_reg_act = 0
end select
end if
else if(domspec.ne.actspec) then
if (domage.ge.regage(domspec).and.domage.lt.(rot(domspec)-15.)) then
if(shelteryear.eq.0) flag_reg = mgreg
inum=i
call shelterwood_man(specnr(inum),inum, domage)
flag_shelter = 1
if(shelteryear.eq.0) flag_sh_first = 1
select case(flag_reg)
case(1) ! mgreg
! natural regeneration allowed
flag_reg = 1
case(4,5,6,7,8,9,10,11,12,13,14,15) ! mgreg
! artificial regeneration
if(flag_reg_act.ne.0) call planting
flag_reg = 0
flag_reg_act = 0
end select
flag_prep = 1
else if(thr7.eq.1 .and. domage.eq.rot(domspec)) then
else if(actspec.eq.rot(actspec)) then
! clear felling
nrfel = specnr(i)
call felling(nrfel,i)
flag_manreal = 1
flag_shelter = 0
maninf = 'felling after shelterwood s.'
meas = 0
! set back because shelterwood m. is finished, management of regenerated stand starts
shelteryear = 0.
thin_flag1 = 0
thin_flag2 = 0
thin_flag3 = 0
thin_flag4 = 0
flag_prep = 1
end if
end if
case(2) ! thr7
! clear felling
if(age_spec(i).ge.(rot(specnr(i))-15).and.age_spec(i).lt.rot(specnr(i)) ) then
zeig=>pt%first
do
if(.not.associated(zeig)) exit
if(zeig%coh%species.eq.specnr(i).and. zeig%coh%x_age.eq. age_spec(i)) zeig%coh%shelter = 1
zeig=>zeig%next
end do
flag_prep = 1
else if (age_spec(i).eq.rot(specnr(i))) then
nrfel = specnr(i)
call felling (nrfel,i)
flag_manreal = 1
flag_fell = 1
thinyear(actspec) = time
thin_flag1 = 0
thin_flag2 = 0
thin_flag3 = 0
thin_flag4 = 0
maninf = 'felling'
meas =0
call input_manrec
else if(age_spec(i).gt. rot(specnr(i)).and. time.eq.1) then
nrfel = specnr(i)
call felling (nrfel,i)
flag_manreal = 1
flag_fell = 1
thinyear(actspec) = time
thin_flag1 = 0
thin_flag2 = 0
thin_flag3 = 0
thin_flag4 = 0
maninf = 'felling'
meas =0
call input_manrec
end if
case default
end select
! tending of plantations (Jungwuchspflege)
! test if rotation age is not during the next 15 years
IF (flag_prep .eq. 0. .and. flag_shelter .eq.0) then
helphd= svar(specnr(i))%dom_height
if ( thinonce.eq.1) then
c1 = ho3
c2 = thr4
CALL thinning (c1,c2,actspec,i)
flag_manreal=1
maninf = 'thinning'
meas = thr1
thinyear(actspec)=time
call input_manrec
end if
if( thinonce.eq.0) then
IF ( (helphd.ge.(ho1-60.).and. helphd.le.(ho1+60.)).and. thin_flag1(actspec).eq.0) THEN
CALL tending(actspec,i)
flag_manreal = 1
maninf = 'tending'
meas = 0
call input_manrec
thin_flag1(actspec)=1
flag_adapm = 1
! management at different dominant heights
ELSE IF( helphd.ge.(ho1-60).and.helphd.le.(ho4+limit)) then
IF((helphd.ge.(ho2-limit).and. helphd.le.(ho2+limit)).and. (thin_flag2(actspec).eq.0).or.( thin_flag2(actspec).eq.0.and. thin_flag2(domspec).eq.1))THEN
if(actspec.eq.domspec .or. thin_flag2(domspec).eq.1) then
c1= ho2
c2= thr1
thin_flag2(actspec)=1
maninf = 'brushing'
! if beech, spruce, oak then tending else thinning based on basal area
if(actspec.ne.3)then
! Mod. for Cornelia
CALL tending(actspec,i)
else
CALL thinning (c1,c2,actspec,i)
end if
flag_manreal=1
meas = thr1
thinyear(actspec)=time
call input_manrec
end if
ELSE IF((helphd.ge.(ho3-limit).and. helphd.le.(ho3+limit)).and. (thin_flag3(actspec).eq.0).or.( thin_flag3(actspec).eq.0.and. thin_flag3(domspec).eq.1)) THEN
if(actspec.eq.domspec .or. thin_flag3(domspec).eq.1) then
c1= ho3
c2= thr2
thin_flag3(actspec)= 1
CALL thinning (c1,c2,actspec,i)
flag_manreal = 1
maninf = 'thinning'
meas = thr2
thinyear(actspec)=time
call input_manrec
end if
ELSE IF( (helphd.ge.(ho4-limit).and. helphd.le.(ho4+limit)).and. (thin_flag4(actspec).eq.0).or.( thin_flag4(actspec).eq.0.and. thin_flag4(domspec).eq.1)) THEN
if(actspec.eq.domspec .or. thin_flag3(domspec).eq.1) then
c1= ho4
c2= thr3
thin_flag4(actspec)= 1
CALL thinning (c1,c2,actspec,i)
flag_manreal = 1
maninf = 'thinning'
meas = thr3
call input_manrec
thinyear(actspec) = time
end if
ENDIF
! directinal felling if not done yet
flag_adapm = 1
ELSE IF(helphd.gt. (ho4+limit)) THEN
! calculation of stocking degree
call calc_gfbg(dfbg, actspec, stage, hg)
dfbg = dfbg*kpatchsize
bg = bas_area_spec(actspec)*bas_area_spec(actspec)/(basarea_tot*dfbg)
th_help = time-thinyear(actspec)
IF(th_help.ge.thinstep.or.(bg.gt.(optb).and.time.lt.thinstep.and.thinyear(actspec).eq.0)) THEN
c1 = 0.
c2 = thr4
if( age_spec(i).lt.(rot(specnr(i))-15)) then
CALL thinning(c1,c2,actspec,i)
flag_manreal = 1
maninf = 'thinning'
meas = thr4
thinyear(actspec) = time
!wpm
call input_manrec
flag_adapm = 1
end if
ENDIF
END IF
END IF
end if ! thinonce
END IF ! flag_prep
END DO ! species loop
if(maninf.eq.'felling after shelterwood s.') domspec = -99
if(thr7.eq.1 .and.(maninf.eq.'felling after shelterwood s.'.or. &
maninf.eq.'shelterwood system1'.or.maninf.eq.'shelterwood system2') ) then
call input_manrec
maninf =trim(maninf)//'out'
end if
if(flag_sh_first.eq.1) then
shelteryear=time
flag_sh_first = 0
end if
if(maninf.eq.'felling after shelterwood s.') then
domspec = domspec_reg
end if
! regeneration/planting if felling was realised
if(flag_fell.eq.1.and. mgreg.ne.0) then
select case(mgreg)
case(1)
! natural regeneration
flag_reg = 1
! shelterwood management is switched off
thr7 = 0
case(4,5,6,7,8,9,10,11,12,13,14)
! artificial regeneration (planting)
flag_reg = mgreg
call planting
thinyear(actspec) = time
thin_flag2 = 0
thin_flag3 = 0
thin_flag4 = 0
flag_reg = 0
domspec = domspec_reg
end select
end if
! calculation of total dry mass of all harvested trees
sumvsab = 0.
sumvsab_m3 = 0.
svar%sumvsab = 0.
if(maninf.ne.'tending'.or. flag_brush.eq.0) then
zeig=>pt%first
do while (associated(zeig))
ns = zeig%coh%species
sumvsab = sumvsab + zeig%coh%ntreem*(zeig%coh%x_sap + zeig%coh%x_hrt)
sumvsab_m3 = sumvsab_m3 + zeig%coh%ntreem*(zeig%coh%x_sap + zeig%coh%x_hrt)/(spar(ns)%prhos*1000000)
svar(ns)%sumvsab = svar(ns)%sumvsab + zeig%coh%ntreem*(zeig%coh%x_sap + zeig%coh%x_hrt)
zeig=>zeig%next
end do
sumvsab = sumvsab * 10000./kpatchsize ! kg/ha
sumvsab_m3 = sumvsab_m3 * 10000./kpatchsize ! kg/ha
do k = 1, nspec_tree
svar(k)%sumvsab = svar(k)%sumvsab * 10000./kpatchsize ! kg/ha
end do
! cumulative harvested stem mass
cumsumvsab = cumsumvsab + sumvsab
end if
call class_man
END SUBROUTINE adap_manag
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
! management routine with fitting stem biomass on target values of stem biomass
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
SUBROUTINE target_manag
USE data_manag
USE data_stand
USE data_species
USE data_simul
implicit none
integer taxnr,k,i,j
zeig=>pt%first
do
if(.not.associated(zeig)) exit
if(zeig%coh%species.le.nspec_tree) then
stand_age = zeig%coh%x_age
taxnr = zeig%coh%species
exit
end if
zeig => zeig%next
end do
! stand manamgent at rotaiotn age
if(taxnr.le.nspec_tree) then
if(stand_age.ne.0) then
select case(thr7)
case(1) ! shelterwood manamgent
case(2) ! clear felling
if(stand_age.eq.(rot(taxnr)-15)) then
zeig=>pt%first
do
if(.not.associated(zeig)) exit
if(zeig%coh%species.eq.taxnr) zeig%coh%shelter = 1
zeig=>zeig%next
end do
return
else if (stand_age.ge.rot(taxnr)) then
call felling(taxnr,i)
flag_manreal = 1
maninf = 'felling'
meas =0
call input_manrec
select case(mgreg)
case(1)
! natural regeneration
flag_reg = 1
! shelterwood management is switched off
thr7 = 0
case(10,11,12,13)
! modification for muilti-run option BRB
if(taxnr.eq.1) then
flag_reg = 11
else if(taxnr.eq.2) then
flag_reg = 13
else if(taxnr.eq.3) then
flag_reg = 10
else if (taxnr.eq.4) then
flag_reg = 12
else
flag_reg = 14
end if
! artificial regeneration (planting)
call planting
flag_reg = 0
end select ! mgreg
end if
end select ! thr7
end if
do j= 1, thin_nr
if(time .eq.thin_year(j)) then
if(thin_stor(j).eq.1.) then
select case(mgreg)
case(1)
! natural regeneration
flag_reg = 1
! Achtung hier ändern!!!
case(8,10,11,12,13, 14, 17)
! artificial regeneration (planting)
zeig=>pt%first
do
if(.not.associated(zeig)) exit
zeig%coh%underst = 0
zeig=>zeig%next
end do
flag_reg = mgreg
call planting
flag_reg = 0
end select ! mgreg
end if ! regeneration & planting
if (flag_mg.eq.3) then
call target_thinning_OC (j)
else if(flag_mg.eq. 33) then
call target_thinning(j)
else if (flag_mg.eq.333) then
call target_thinning_bas(j)
end if
flag_manreal = 1
maninf='thinning'
call input_manrec
end if
end do
! calculation of total dry mass of all harvested trees
sumvsab = 0.
sumvsab_m3 = 0.
svar%sumvsab = 0.
zeig=>pt%first
do while (associated(zeig))
ns = zeig%coh%species
sumvsab = sumvsab + zeig%coh%ntreem*(zeig%coh%x_sap + zeig%coh%x_hrt)
sumvsab_m3 = sumvsab_m3 + zeig%coh%ntreem*(zeig%coh%x_sap + zeig%coh%x_hrt)/(spar(ns)%prhos*1000000)
svar(ns)%sumvsab = svar(ns)%sumvsab + zeig%coh%ntreem*(zeig%coh%x_sap + zeig%coh%x_hrt)
zeig=>zeig%next
end do
sumvsab = sumvsab * 10000./kpatchsize ! kg/ha
sumvsab_m3 = sumvsab_m3 * 10000./kpatchsize ! kg/ha
do k = 1, nspec_tree
svar(k)%sumvsab = svar(k)%sumvsab * 10000./kpatchsize ! kg/ha
end do! cumulated harvested stem mass
cumsumvsab = cumsumvsab + sumvsab
end if
END SUBROUTINE target_manag
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! input for target thinning
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
SUBROUTINE target_ini
! read definition of simple thinning from file
USE data_manag
USE data_simul
USE data_plant
USE data_species
integer :: manag_unit,i
character(len=150) :: filename
character ::text
logical :: ex
allocate(rot(nspec_tree))
allocate(thin_flag1(nspec_tree))
thin_flag1=-1
manag_unit=getunit()
filename = manfile(ip)
call testfile(filename,ex)
open(manag_unit,file=trim(filename))
! read head of data-file
do
read(manag_unit,*) text
if(text .ne. '!')then
backspace(manag_unit);exit
endif
enddo
read(manag_unit,*) thr7 ! management for rotation year
read(manag_unit,*) mgreg ! regeneration in rotation year
! rotation period
read (manag_unit,*) (rot(i), i =1, nspec_tree)
read (manag_unit,*) (numplant(i), i =1,nspec_tree)
read (manag_unit,*) thin_nr ! number of thinning years
allocate(thin_year(thin_nr));allocate(target_mass(thin_nr));
allocate(thin_spec(thin_nr));allocate(thin_tysp(thin_nr))
allocate(thin_stor(thin_nr))
do i=1,thin_nr
read(manag_unit,*) thin_year(i),target_mass(i), thin_spec(i), thin_tysp(i), thin_stor(i)
end do
close(manag_unit)
end SUBROUTINE target_ini
\ No newline at end of file
source_code/version_2.3_windows/mess_stat.f 0 → 100644
View file @ 82df1085
!*****************************************************************!
!* *!
!* 4C (FORESEE) Simulation Model *!
!* *!
!* *!
!* Subroutines for: *!
!* *!
!* preparation of statistical analysis *!
!* *!
!* Author: F. Suckow *!
!* *!
!* contains: *!
!* mess *!
!* prep_mw *!
!* prep_simout *!
!* kind_pos *!
!* store_sim_kind *!
!* prep_stat_out *!
!* read_simout *!
!* open_sfile *!
!* *!
!* Copyright (C) 1996-2018 *!
!* Potsdam Institute for Climate Impact Reserach (PIK) *!
!* Authors and contributors see AUTHOR file *!
!* This file is part of 4C and is licensed under BSD-2-Clause *!
!* See LICENSE file or under: *!
!* http://www.https://opensource.org/licenses/BSD-2-Clause *!
!* Contact: *!
!* https://gitlab.pik-potsdam.de/foresee/4C *!
!* *!
!*****************************************************************!
SUBROUTINE mess
use data_mess
use data_out
use data_simul
implicit none
integer i, j, k
integer :: hd = -99
real :: hv = -9999.0
real :: helpn, totm1, totm2, totm3 ! total match as average from several values
integer maxmess
logical ex
character(10) :: helpsim
character(150) :: filename
allocate (app(site_nr))
if (unit_mess .lt. 0) then
do
inquire (File = mesfile(1), exist = ex)
if(ex .eqv. .false.) then
write (*, '(A)') ' >>>foresee message: File ',trim(mesfile(1)),' not exists !'
write (*, '(A)', advance='no') ' please write full name of measurement file: '
read(*,'(A)') mesfile(1)
cycle
else
exit
endif
enddo
endif
! error.log schreiben
write(unit_err,'(A)')
write(unit_err,'(A)')
write(unit_err,'(A)') ' * * * * * Statistics * * * * *'
write(unit_err,'(A)')
fkind = 0
call prep_mw
if (tkind .eq. 1) call stat_mon
call prep_simout
if (.not. flag_mess) return
call prep_stat_out
do i = 1,site_nr
ip = i
app(i) = i
nme_av = 0.
nmae_av = 0.
nrmse_av = 0.
pme_av = 0.
prmse_av = 0.
tic_av = 0.
meff_av = 0.
rsq_av = 0.
totm1 = 0.
totm2 = 0.
imk_nme = imkind
imk_nmae = imkind
imk_nrmse= imkind
imk_rsq = imkind
call read_simout
call residuen(i)
call statistik
! Mittelwert berechnen und ausdrucken
helpn = imkind - fkind
nme_av = nme_av / (imk_nme - fkind)
nmae_av = nmae_av / (imk_nmae - fkind)
nrmse_av = nrmse_av / (imk_nrmse - fkind)
pme_av = pme_av / helpn
prmse_av = prmse_av / helpn
tic_av = tic_av / helpn
meff_av = meff_av / helpn
rsq_av = rsq_av/(imk_rsq - fkind)
! Calculation of total match without missing values
helpn = 2.
totm1 = tic_av + (1.-meff_av)
totm2 = totm1
totm3 = totm1
totm1 = totm1/helpn
if (rsq_av .ge. 0.) then
helpn = helpn + 1.
totm2 = totm2 + (1-rsq_av)
totm3 = totm2
totm2 = totm2 / helpn
endif
if (nrmse_av .lt. -9000.) then
helpn = helpn + 1.
totm3 = (totm2 + nrmse_av) / helpn
endif
write (unit_stat, '(I5,2X, A20,1X,A10,I8,1X,33E13.5)') ip, site_name(ip), 'average', hd, &
hv, hv, hv, hv, hv, hv, nme_av, hv, nmae_av, hv, hv, nrmse_av, pme_av, prmse_av, tic_av, meff_av, hv, rsq_av, &
hv, hv, hv, hv, hv, hv, hv, hv, hv, hv, hv, hv, totm1, totm2, totm3
write (unit_stat,*)
! File mit Residuen schreiben
if (flag_stat .ge. 2) then
write (helpsim,'(I4)') ip
read (helpsim,*) anh
filename = trim(dirout)//trim(site_name(ip))//'_resid'//'.res'//trim(anh)
unit_mout = getunit()
open(unit_mout,file=filename,status='replace')
write (unit_mout, '(A)') '# Residuals etc.'
write (unit_mout, '(A)') '# Number kind '
do j = 1, imkind
write (unit_mout, '(I14,3X,A10,26X)', advance='no') val(j)%imes, val(j)%mkind
enddo
write (unit_mout, '(A)') ' '
do j = 1, imkind
write (unit_mout, '(A)', advance='no') ' day year residual simulation measurement'
enddo
write (unit_mout, '(A)') ' '
maxmess = maxval(val%imes)
do k = 1, maxmess
do j = 1, imkind
if (val(j)%imes .ge. k) then
write (unit_mout, '(4X,2I5,3E13.5)', advance='no') val(j)%day(k), val(j)%year(k), val(j)%resid(k), val(j)%sim(k), val(j)%mess(k)
else
write (unit_mout, '(4X,2I5,3E13.5)', advance='no') hd, hd, hv,hv,hv
endif
enddo
write (unit_mout, '(A)') ' '
enddo
close(unit_mout)
endif
enddo
write (*,*)
write (*, '(A)') ' Statistical analysis completed'
write (*,*)
END SUBROUTINE mess
!**************************************************************
SUBROUTINE prep_mw
use data_mess
use data_simul
implicit none
INTERFACE
SUBROUTINE kind_pos(pos1, pos2, ikind, imkind, vkind, text)
! assumed shape arrays
integer :: ikind, imkind
character(150) text
character(10), dimension(ikind):: vkind
integer, dimension(:):: pos1, pos2 ! Position of variables in input file
END SUBROUTINE
END INTERFACE
integer i, j, k, ios
integer id, im, iy, itz
integer idate
character(3) ttext
character(250) text, filename
idate = 10
allocate (mtz(2,idate))
unit_cons = getunit()
open(unit_cons,file='con')
if (unit_mess .lt. 0) then
filename = mesfile(1)
unit_mess = getunit()
open(unit_mess,file=filename,iostat=ios,status='old',action='read')
endif
do
read(unit_mess,*) text
ios = scan(text, '!')
IF (ios .eq. 0) then
backspace(unit_mess)
exit
endif
enddo
! determin kind of measurement values; read 1. line
read (unit_mess, '(A)') text
ttext = adjustl(text)
if (ttext.eq.'dat' .or. ttext.eq.'Dat' .or. ttext.eq.'DAT') then
tkind = 1 ! day
else
tkind = 2 ! year
endif
call store_sim_kind(imkind, sim_kind, text)
! convert measurement values to daily counter
select case (tkind)
case (1) ! daily values
imess = 0
do
read (unit_mess, '(2(I2,1X),I4)',iostat=ios) id, im, iy
if (ios .lt. 0) exit
call daintz(id,im,iy,itz)
imess = imess + 1
if (imess .gt. idate) then
allocate (help1(2,idate))
help1 = mtz
deallocate (mtz)
idate = idate + 10
allocate (mtz(2,idate))
do j= 1,idate - 10
mtz(1,j) = help1(1,j)
mtz(2,j) = help1(2,j)
enddo
deallocate (help1)
endif
mtz(1,imess) = itz
mtz(2,imess) = iy
enddo
!read meassurement values
rewind (unit_mess)
allocate (mess1 (imess, imkind))
mess1 = -9999.0
do
read(unit_mess,*) text
IF (text .ne. '!') then
backspace(unit_mess)
exit
endif
enddo
read (unit_mess, '(A)') text
do j = 1,imess
read (unit_mess, *,iostat=ios) text, (mess1(j,k), k=1,imkind)
enddo
case (2) ! yearly values
imess = 0
if(allocated(mess1)) then
write (*,'(A)') ' Feld mess1 bereits allokiert'
STOP
endif
allocate (mess1(idate, imkind))
mess1 = -9999.0
do
imess = imess + 1
mtz(1,imess) = 0
read (unit_mess, *,iostat=ios) mtz(2,imess), (mess1(imess,k), k=1,imkind)
mtz(1,imess) = 0
if (ios .lt. 0) exit
if (imess .gt. idate-1) then
allocate (help1(2,idate))
allocate (help2(idate, imkind))
help1 = mtz
help2 = mess1
deallocate (mtz)
deallocate (mess1)
idate = idate + 10
allocate (mtz(2,idate))
allocate (mess1(idate, imkind))
mess1 = -9999.9
do j= 1,idate - 10
mtz(1,j) = 0
mtz(2,j) = help1(2,j)
do k=1,imkind
mess1(j,k) = help2(j,k)
enddo
enddo
deallocate (help1)
deallocate (help2)
endif
enddo
imess = imess - 1
end select
END SUBROUTINE prep_mw
!**************************************************************
SUBROUTINE prep_simout
use data_mess
use data_out
use data_simul
implicit none
INTERFACE
SUBROUTINE kind_pos(pos1, pos2, ikind, imkind, vkind, text)
! assumed shape arrays
integer :: ikind, imkind
character(150) text
character(10), dimension(ikind):: vkind
integer, dimension(:):: pos1, pos2 ! position of variablen in input file
END SUBROUTINE
END INTERFACE
integer i, ii, ik, j, k, year1
integer, allocatable, dimension(:):: yd, yy
character(150) :: filename
flag_mess = .FALSE.
year1 = year
! Create complete array of measurements
select case (tkind)
case (1)
anz_val = 0
allocate (yd(year1))
allocate (yy(year1))
do i=1,year1
yy(i) = time_b + i - 1
if (mod(yy(i),4) .eq. 0 .and. yy(i) .ne. 1900) then
yd(i) = 366
else
yd(i) = 365
endif
anz_val = anz_val + yd(i)
enddo
allocate (mess2(anz_val, imkind))
allocate (help1(2,anz_val))
mess2 = -9999.0
j = 1
k = 0
do while (mtz(2,j) .lt. time_b)
j = j+1
enddo
do ii = 1, year1
do i = 1, yd(ii)
k = k + 1
help1(1,k) = i
help1(2,k) = yy(ii)
if ((mtz(1,j) .eq. help1(1,k)) .and. (mtz(2,j) .eq. help1(2,k))) then
do ik = 1, imkind
mess2(k,ik) = mess1(j,ik)
flag_mess = .TRUE.
enddo ! ik
j = j+1
else
do ik = 1, imkind
mess2(k,ik) = -9999.9
enddo ! ik
endif
enddo ! i
enddo ! ii
case (2)
allocate (yy(year1))
anz_val = year1
do i=1,year1
yy(i) = time_b + i - 1
enddo
allocate (mess2(anz_val, imkind))
allocate (help1(2,anz_val))
mess2 = -9999.9
j = 1
do while (mtz(2,j) .lt. time_b)
j = j+1
enddo
do ii = 1, year1
help1(2,ii) = yy(ii)
help1(1,ii) = 0
if (mtz(2,j) .eq. help1(2,ii)) then
do ik = 1, imkind
mess2(ii,ik) = mess1(j,ik)
flag_mess = .TRUE.
enddo ! ik
j = j+1
else
do ik = 1, imkind
mess2(ii,ik) = -9999.9
enddo ! ik
endif
enddo ! ii
end select
if (.not. flag_mess) then
write (*,*)
write (*, '(A)') ' Statistical analysis:'
write (*, '(A)') ' No measurements within the simulation period'
write (*,*)
return
endif
! write file with complete set of meassurement values
if (flag_stat .eq. 3) then
filename = trim(dirout)//trim(site_name(1))//'_mess'//'.mes'
unit_mout = getunit()
open(unit_mout,file=filename,status='replace')
write (unit_mout, '(A)') '# Measurements '
write (unit_mout, '(A)') mess_info
write (unit_mout, '(A)', advance='no') '# day year'
do i=1,imkind
write (unit_mout, '(A13)', advance='no') sim_kind(i)
enddo
write (unit_mout, '(A)') ' '
do i = 1, anz_val
write (unit_mout, '(2I5)', advance='no') help1(1,i), help1(2,i)
do j = 1, imkind
write (unit_mout, '(E13.5)', advance='no') mess2(i,j)
enddo
write (unit_mout, '(A)') ' '
enddo
close(unit_mout)
endif
! Read data
allocate (sim1(anz_val, imkind))
allocate (stz(2,anz_val))
END SUBROUTINE prep_simout
!**************************************************************
SUBROUTINE kind_pos(pos1, pos2, ikind, imkind, vkind, text)
implicit none
integer imkind, & ! amount of read kinds of measurment value
ikind, & ! amount of allowed kinds of measurement value
j
character(10), dimension(ikind):: vkind
character(150) text
integer, dimension(:):: pos1, pos2 ! position of variable in input file
pos1 = 9999
imkind = 0
do j = 1,ikind
pos1(j) = index (text, trim(vkind(j)))
pos2(j) = j
if (pos1(j) .eq. 0) then
pos1(j) = 9999
else
imkind = imkind +1
endif
enddo ! j
call sort_index(ikind, pos1, pos2)
END SUBROUTINE kind_pos
!**************************************************************
SUBROUTINE store_sim_kind(imkind, vkind, text)
implicit none
integer imkind, & ! amount of read kinds of measurement values
ipos, & ! position of space character/sign
i, j
character(10), dimension(30):: vkind
character(250) text, text1, text2
character(1):: setleer = ''
character(75):: setascii
setascii = ''
do i = 48,122
j = i-47
setascii(j:j) = ACHAR(i) ! fill in with ASCII-character, no space character/signs
enddo
imkind = 0
ipos = verify(adjustl(text), setascii) ! first non-ASCII-character
text1 = ' '
text2 = adjustl(text)
text1 = text2(ipos:250) ! delete date/year
text2 = text1
ipos = scan(text2, setascii) ! first ASCII-character
text1 = text2(ipos:250) ! delete non-ASCII-characters
text2 = text1
do j = 1,30
ipos = verify(text2, setascii) ! first non_ASCII-character
vkind(j) = text2(1:ipos-1) ! save name of measurement value
imkind = imkind +1
text1 = text2(ipos:250) ! delete saved measurment value
text2 = text1
ipos = scan(text2, setascii) ! first ASCII-character
if (ipos .eq. 0) exit
text1 = text2(ipos:250)
text2 = text1
enddo ! j
END SUBROUTINE store_sim_kind
!**************************************************************
SUBROUTINE prep_stat_out
use data_mess
use data_out
use data_simul
implicit none
character(70) :: filename
character(8) actdate
character(10) acttime
filename = trim(site_name(1))//'_stat'//'.res'
call date_and_time(actdate, acttime)
unit_stat = getunit()
open(unit_stat,file=trim(dirout)//filename,status='replace')
write (unit_stat, '(A)') '# Comparison of simulated and observed values'
write (unit_stat, '(10A)') '# Date: ',actdate(7:8),'.',actdate(5:6),'.',actdate(1:4), &
' Time: ',acttime(1:2),':',acttime(3:4)
write (unit_stat, 1000)
write (unit_stat, 2000)
1000 format('# |-------- residuals ....... ', 15(' '), &
'|----------------------------- simulation -----------------------||------------------------------- observed ---------------------------|' )
2000 format( '# ipnr site_id kind number mean min max stand_dev variance var_coeff NME MAE NMAE', &
' SSE RMSE NRMSE PME PRMSE TIC MEFF cor_coeff rsquare', &
' mean min max stand_dev variance var_coeff mean min max stand_dev variance var_coeff tot_match1 tot_match2 tot_match3')
END SUBROUTINE prep_stat_out
!**************************************************************
SUBROUTINE read_simout
use data_mess
use data_out
use data_simul
use data_soil
implicit none
integer i,j, ios
character(150) :: text
character(50) :: message
character(10) :: helpsim
character(10) :: styp, skind
character :: text1
character(2) :: text2
character(3) :: text3
logical ex
integer :: year1, unithelp
real, dimension(26):: help_day
real, dimension(13):: help_sum ! size is adjusted to amount of elements in ...sum.out
real, dimension(27):: help_veg
real, dimension(28):: help_veg_spec
real, dimension(8):: help_lit
real, dimension(33):: help_soil
real, dimension(50):: tief
real, allocatable, dimension(:) :: help_temp, help_water
real htief, hnlay
sim1 = -9999.9
unitday = -99
unitcbal = -99
unitlit = -99
unittemp = -99
unitsum = -99
unitveg = -99
unitveg_pi = -99
unitveg_sp = -99
unitveg_bi = -99
unitsoil = -99
unitsoilini = -99
unitwater = -99
anz_sim = ip
year1 = year
do i=1,imkind
select case (sim_kind(i))
case ('AET')
if (tkind .eq. 1) then ! daily values
skind = 'day'
styp = 'out'
if (unitday .lt. 0) call open_sfile (skind, styp, unitday)
opos2(i) = 7
else
skind = 'soil'
styp = 'out'
if (unitsoil .lt. 0) call open_sfile (skind, styp, unitsoil)
opos2(i) = 10
endif
case ('BIOM', 'STVOL')
skind = 'veg'
styp = 'out'
if (unitveg .lt. 0) call open_sfile (skind, styp, unitveg)
opos2(i) = 14
case ('STVOL_pi')
skind = 'veg_pi'
styp = 'out'
if (unitveg_pi .lt. 0) call open_sfile (skind, styp, unitveg_pi)
opos2(i) = 14
case ('STVOL_sp')
skind = 'veg_sp'
styp = 'out'
if (unitveg_sp .lt. 0) call open_sfile (skind, styp, unitveg_sp)
opos2(i) = 14
case ('STVOL_bi')
skind = 'veg_bi'
styp = 'out'
if (unitveg_sp .lt. 0) call open_sfile (skind, styp, unitveg_bi)
opos2(i) = 14
case ('DG')
skind = 'veg'
styp = 'out'
if (unitveg .lt. 0) call open_sfile (skind, styp, unitveg)
opos2(i) = 7
case ('DG_pi')
skind = 'veg_pi'
styp = 'out'
if (unitveg_pi .lt. 0) call open_sfile (skind, styp, unitveg_pi)
opos2(i) = 7
case ('DG_sp')
skind = 'veg_sp'
styp = 'out'
if (unitveg_sp .lt. 0) call open_sfile (skind, styp, unitveg_sp)
opos2(i) = 7
case ('DG_bi')
skind = 'veg_pi'
styp = 'out'
if (unitveg_bi .lt. 0) call open_sfile (skind, styp, unitveg_bi)
opos2(i) = 7
case ('DBH')
skind = 'veg'
styp = 'out'
if (unitveg .lt. 0) call open_sfile (skind, styp, unitveg)
opos2(i) = 23
case ('DBH_pi')
skind = 'veg_pi'
styp = 'out'
if (unitveg_pi .lt. 0) call open_sfile (skind, styp, unitveg_pi)
opos2(i) = 24
case ('DBH_sp')
skind = 'veg_sp'
styp = 'out'
if (unitveg_sp .lt. 0) call open_sfile (skind, styp, unitveg_sp)
opos2(i) = 24
case ('DBH_bi')
skind = 'veg_pi'
styp = 'out'
if (unitveg_bi .lt. 0) call open_sfile (skind, styp, unitveg_bi)
opos2(i) = 24
case ('Fol')
skind = 'veg'
styp = 'out'
if (unitveg .lt. 0) call open_sfile (skind, styp, unitveg)
opos2(i) = 9
case ('Fol_pi')
skind = 'veg_pi'
styp = 'out'
if (unitveg_pi .lt. 0) call open_sfile (skind, styp, unitveg_pi)
opos2(i) = 9
case ('Fol_sp')
skind = 'veg_sp'
styp = 'out'
if (unitveg_sp .lt. 0) call open_sfile (skind, styp, unitveg_sp)
opos2(i) = 9
case ('Fol_bi')
skind = 'veg_pi'
styp = 'out'
if (unitveg_bi .lt. 0) call open_sfile (skind, styp, unitveg_bi)
opos2(i) = 9
case ('GPP')
if (tkind .eq. 1) then ! daily values
skind = 'sum'
styp = 'out'
if (unitsum .lt. 0) call open_sfile (skind, styp, unitsum)
opos2(i) = 11
else
skind = 'c_bal'
styp = 'out'
if (unitcbal .lt. 0) call open_sfile (skind, styp, unitsum)
opos2(i) = 1
endif
case ('HO')
skind = 'veg'
styp = 'out'
if (unitveg .lt. 0) call open_sfile (skind, styp, unitveg)
opos2(i) = 8
case ('HO_pi')
skind = 'veg_pi'
styp = 'out'
if (unitveg_pi .lt. 0) call open_sfile (skind, styp, unitveg_pi)
opos2(i) = 8
case ('HO_sp')
skind = 'veg_sp'
styp = 'out'
if (unitveg_sp .lt. 0) call open_sfile (skind, styp, unitveg_sp)
opos2(i) = 8
case ('HO_bi')
skind = 'veg_pi'
styp = 'out'
if (unitveg_bi .lt. 0) call open_sfile (skind, styp, unitveg_bi)
opos2(i) = 8
case ('LAI')
skind = 'veg'
styp = 'out'
if (unitveg .lt. 0) call open_sfile (skind, styp, unitveg)
opos2(i) = 4
case ('LAI_pi')
skind = 'veg_pi'
styp = 'out'
if (unitveg_pi .lt. 0) call open_sfile (skind, styp, unitveg_pi)
opos2(i) = 4
case ('LAI_sp')
skind = 'veg_sp'
styp = 'out'
if (unitveg_sp .lt. 0) call open_sfile (skind, styp, unitveg_sp)
opos2(i) = 4
case ('LAI_bi')
skind = 'veg_pi'
styp = 'out'
if (unitveg_bi .lt. 0) call open_sfile (skind, styp, unitveg_bi)
opos2(i) = 4
case ('MH')
skind = 'veg'
styp = 'out'
if (unitveg .lt. 0) call open_sfile (skind, styp, unitveg)
opos2(i) = 24
case ('MH_pi')
skind = 'veg_pi'
styp = 'out'
if (unitveg_pi .lt. 0) call open_sfile (skind, styp, unitveg_pi)
opos2(i) = 25
case ('MH_sp')
skind = 'veg_sp'
styp = 'out'
if (unitveg_sp .lt. 0) call open_sfile (skind, styp, unitveg_sp)
opos2(i) = 25
case ('MH_bi')
skind = 'veg_bi'
styp = 'out'
if (unitveg_bi .lt. 0) call open_sfile (skind, styp, unitveg_bi)
opos2(i) = 25
case ('NTREE')
skind = 'veg'
styp = 'out'
if (unitveg .lt. 0) call open_sfile (skind, styp, unitveg)
opos2(i) = 3
case ('NTREE_pi')
skind = 'veg_pi'
styp = 'out'
if (unitveg_pi .lt. 0) call open_sfile (skind, styp, unitveg_pi)
opos2(i) = 3
case ('NTREE_sp')
skind = 'veg_sp'
styp = 'out'
if (unitveg_sp .lt. 0) call open_sfile (skind, styp, unitveg_sp)
opos2(i) = 3
case ('NTREE_bi')
skind = 'veg_pi'
styp = 'out'
if (unitveg_bi .lt. 0) call open_sfile (skind, styp, unitveg_bi)
opos2(i) = 3
case ('NEE')
skind = 'sum'
styp = 'out'
if (unitsum .lt. 0) call open_sfile (skind, styp, unitsum)
opos2(i) = 6
case ('NEP')
skind = 'c_bal'
styp = 'out'
if (unitcbal .lt. 0) call open_sfile (skind, styp, unitcbal)
opos2(i) = 3
case ('Litter')
skind = 'litter'
styp = 'out'
if (unitlit .lt. 0) call open_sfile (skind, styp, unitlit)
opos2(i) = 1
case ('prec_stand')
skind = 'soil'
styp = 'out'
if (unitsoil .lt. 0) call open_sfile (skind, styp, unitsoil)
opos2(i) = 2
case ('prec_st_d')
skind = 'day'
styp = 'out'
if (unitday .lt. 0) call open_sfile (skind, styp, unitday)
opos2(i) = 4
case ('s_resp')
skind = 'day'
styp = 'out'
if (unitday .lt. 0) call open_sfile (skind, styp, unitday)
opos2(i) = 12
case ('Snow')
skind = 'day'
styp = 'out'
if (unitday .lt. 0) call open_sfile (skind, styp, unitday)
opos2(i) = 5
case ('STBIOM')
skind = 'veg'
styp = 'out'
if (unitveg .lt. 0) call open_sfile (skind, styp, unitveg)
opos2(i) = 10
case ('STBIOM_pi')
skind = 'veg_pi'
styp = 'out'
if (unitveg_pi .lt. 0) call open_sfile (skind, styp, unitveg_pi)
opos2(i) = 10
case ('STBIOM_sp')
skind = 'veg_sp'
styp = 'out'
if (unitveg_sp .lt. 0) call open_sfile (skind, styp, unitveg_sp)
opos2(i) = 10
case ('STBIOM_bi')
skind = 'veg_bi'
styp = 'out'
if (unitveg_sp .lt. 0) call open_sfile (skind, styp, unitveg_bi)
opos2(i) = 10
case ('Stem_inc')
skind = 'veg'
styp = 'out'
if (unitveg .lt. 0) call open_sfile (skind, styp, unitveg)
opos2(i) = 13
case ('Stem_inc_pi')
skind = 'veg_pi'
styp = 'out'
if (unitveg_pi .lt. 0) call open_sfile (skind, styp, unitveg_pi)
opos2(i) = 13
case ('Stem_inc_sp')
skind = 'veg_sp'
styp = 'out'
if (unitveg_sp .lt. 0) call open_sfile (skind, styp, unitveg_sp)
opos2(i) = 13
case ('Stem_inc_bi')
skind = 'veg_pi'
styp = 'out'
if (unitveg_bi .lt. 0) call open_sfile (skind, styp, unitveg_bi)
opos2(i) = 13
case ('TER')
if (tkind .eq. 1) then ! daily values
skind = 'sum'
styp = 'out'
if (unitsum .lt. 0) call open_sfile (skind, styp, unitsum)
opos2(i) = 12
else
skind = 'c_bal'
styp = 'out'
if (unitcbal .lt. 0) call open_sfile (skind, styp, unitsum)
opos2(i) = 6
endif
case ('transtree')
skind = 'day'
styp = 'out'
if (unitday .lt. 0) call open_sfile (skind, styp, unitday)
opos2(i) = 9
case ('WC_002')
skind = 'watvol'
styp = 'out'
if (unitwater .lt. 0) call open_sfile (skind, styp, unitwater)
opos2(i) = 1
case ('TS_002')
skind = 'temp'
styp = 'out'
if (unittemp .lt. 0) call open_sfile (skind, styp, unittemp)
opos2(i) = 2
case default
text2 = sim_kind(i) (1:2)
if ((text2 .eq. 'TS') .or. (text2 .eq. 'WC')) then
skind = 'soil'
styp = 'ini'
if (unitsoilini .lt. 0) then
call open_sfile (skind, styp, unitsoilini)
read (unitsoilini, *) text
read (unitsoilini, *) text
do j=1, 50
read (unitsoilini, *,iostat=ios) hnlay, tief(j)
if (hnlay .eq. 0) then
exit
else
nlay = hnlay
endif
if (ios .ne. 0) exit
enddo
endif
select case (text2)
case ('TS')
skind = 'temp'
styp = 'out'
if (unittemp .lt. 0) call open_sfile (skind, styp, unittemp)
text3 = sim_kind(i) (4:6)
write (helpsim, *) text3
read (helpsim,*) htief
! htief = 5.
do j=2,nlay
if ((tief(j)-tief(1)) .ge. htief) then
opos2(i) = j+1
exit
endif
enddo
if (opos2(i) .le.0) then
message = "no simulation values of "//text2//" for depth "
opos2(i) = nlay
write(unit_err,'(A)',advance='no') trim(message)
write(unit_err,'(F5.0,A)') htief, " cm"
else
message = "simulation values of "//text2//" for depth "
write(unit_err,'(A)',advance='no') trim(message)
write(unit_err,'(F5.0,A)') htief, " cm"
message = " selected layer: "
write(unit_err,'(A)',advance='no') trim(message)
write(unit_err,'(I3)') j
endif
case ('WC')
skind = 'watvol'
styp = 'out'
if (unitwater .lt. 0) call open_sfile (skind, styp, unitwater)
text3 = sim_kind(i) (4:6)
write (helpsim, *) text3
read (helpsim,*) htief
do j=2,nlay
if ((tief(j)-tief(1)) .ge. htief) then
opos2(i) = j
exit
endif
enddo
if (opos2(i) .le.0) then
message = "no simulation values of "//text2//" for depth "
opos2(i) = nlay
write(unit_err,'(A)',advance='no') trim(message)
write(unit_err,'(F5.0,A)') htief, " cm"
else
message = "simulation values of "//text2//" for depth "
write(unit_err,'(A)',advance='no') trim(message)
write(unit_err,'(F5.0,A)') htief, " cm"
message = " selected layer: "
write(unit_err,'(A)',advance='no') trim(message)
write(unit_err,'(I3)') j
endif
end select ! text2
else
fkind = fkind + 1
write (unit_err, *)
write (unit_err, '(A)') 'Statistics - Undefined kind of measurement '//sim_kind(i)
endif
end select
enddo ! i - imkind
! read in results file
! read day-file
if (unitday .ge. 0) then
do
read(unitday,*) text
IF (adjustl(text) .ne. '#') then
backspace(unitday)
exit
endif
enddo
do j = 1,anz_val
read (unitday, *) stz(1,j), stz(2,j), help_day
do i=1,imkind
select case (sim_kind(i))
case ('AET','Snow','prec_st_d','s_resp','transtree')
sim1(j,i) = help_day(opos2(i))
end select
enddo
enddo
endif ! unitday
! read temp-file
if (unittemp .ge. 0) then
do
read(unittemp,*) text
IF (adjustl(text) .ne. '#') then
backspace(unittemp)
exit
endif
enddo
allocate (help_temp(nlay))
do j = 1,anz_val
read (unittemp, *) stz(1,j), stz(2,j), help_temp
do i=1,imkind
if (opos2(i) .gt. 0) then
select case (sim_kind(i) (1:2))
case ('TS')
sim1(j,i) = help_temp(opos2(i))
end select
endif
enddo
enddo
deallocate (help_temp)
endif ! unittemp
! read water-file
if (unitwater .ge. 0) then
do
read(unitwater,*) text
IF (adjustl(text) .ne. '#') then
backspace(unitwater)
exit
endif
enddo
allocate (help_water(nlay))
do j = 1,anz_val
read (unitwater, *) stz(1,j), stz(2,j), help_water
do i=1,imkind
if (opos2(i) .gt. 0) then
select case (sim_kind(i) (1:2))
case ('WC')
sim1(j,i) = help_water(opos2(i))
end select
endif
enddo
enddo
deallocate (help_water)
endif ! unitwater
! read sum-file
if (unitsum .ge. 0) then
do
read(unitsum,*) text
text1 = adjustl(text)
IF (text1 .ne. '#') then
backspace(unitsum)
exit
endif
enddo
do j = 1,anz_val
read (unitsum, *) stz(1,j), stz(2,j), help_sum
do i=1,imkind
select case (sim_kind(i))
case ('NEE','GPP','TER')
sim1(j,i) = help_sum(opos2(i))
end select
enddo
enddo
endif ! unitsum
! read c_bal-file
if (unitcbal .ge. 0) then
do
read(unitcbal,*) text
text1 = adjustl(text)
IF (text1 .ne. '#') then
exit ! 1. line for standard values is skiped
endif
enddo
do j = 1,year1
read (unitcbal, *) stz(2,j), help_veg
do i=1,imkind
select case (sim_kind(i))
case ('NEP','GPP','TER')
sim1(j,i) = help_veg(opos2(i))
end select
enddo
enddo
endif ! unitcbal
! read litter-file
if (unitlit .ge. 0) then
do
read(unitlit,*) text
text1 = adjustl(text)
IF (text1 .ne. '#') then
exit
endif
enddo
do j = 1,year1
read (unitlit, *) stz(2,j), help_lit
do i=1,imkind
select case (sim_kind(i))
case ('Litter')
sim1(j,i) = help_lit(opos2(i))
end select
enddo
enddo
endif ! unitlit
! read soil-file
if (unitsoil .ge. 0) then
do
read(unitsoil,*) text
text1 = adjustl(text)
IF (text1 .ne. '#') then
exit ! 1. line of standard values is skiped
endif
enddo
do j = 1,year1
read (unitsoil, *) stz(2,j), help_soil
do i=1,imkind
select case (sim_kind(i))
case ('prec_stand')
sim1(j,i) = help_soil(opos2(i)) - help_soil(opos2(i)+1)
case ('AET')
sim1(j,i) = help_soil(opos2(i))
end select
enddo
enddo
endif ! unitsoil
! read veg-file
if (unitveg .ge. 0) then
do
read(unitveg,*) text
text1 = adjustl(text)
IF (text1 .ne. '#') then
exit
endif
enddo
do j = 1,year1
read (unitveg, *) stz(2,j), help_veg
do i=1,imkind
select case (sim_kind(i))
case ('STBIOM')
sim1(j,i) = (help_veg(opos2(i)) + help_veg(opos2(i)+2))
case ('BIOM','DG','DBH','Fol','LAI','NTREE','Stem_inc')
sim1(j,i) = help_veg(opos2(i))
case ('HO','MH')
sim1(j,i) = help_veg(opos2(i)) / 100.
end select
enddo
enddo
endif ! unitveg
! read veg_pi-file
if (unitveg_pi .ge. 0) then
do
read(unitveg_pi,*) text
text1 = adjustl(text)
IF (text1 .ne. '#') then
exit
endif
enddo
do j = 1,year1
read (unitveg_pi, *) stz(2,j), help_veg_spec
do i=1,imkind
select case (sim_kind(i))
case ('STBIOM_pi')
sim1(j,i) = (help_veg_spec(opos2(i)) + help_veg_spec(opos2(i)+2))
case ('BIOM_pi','DG_pi','DBH_pi','Fol_pi','LAI_pi','NTREE_pi','Stem_inc_pi')
sim1(j,i) = help_veg_spec(opos2(i))
case ('HO_pi','MH_pi')
sim1(j,i) = help_veg_spec(opos2(i)) / 100.
end select
enddo
enddo
endif ! unitveg_pi
! read veg_sp-file
if (unitveg_sp .ge. 0) then
do
read(unitveg_sp,*) text
text1 = adjustl(text)
IF (text1 .ne. '#') then
exit
endif
enddo
do j = 1,year1
read (unitveg_sp, *) stz(2,j), help_veg_spec
do i=1,imkind
select case (sim_kind(i))
case ('STBIOM_sp')
sim1(j,i) = (help_veg_spec(opos2(i)) + help_veg_spec(opos2(i)+2))
case ('BIOM_sp','DG_sp','DBH_sp','Fol_sp','LAI_sp','NTREE_sp','Stem_inc_sp')
sim1(j,i) = help_veg_spec(opos2(i))
case ('HO_sp','MH_sp')
sim1(j,i) = help_veg_spec(opos2(i)) / 100.
end select
enddo
enddo
endif ! unitveg_sp
! read veg_bi-file
if (unitveg_bi .ge. 0) then
do
read(unitveg_bi,*) text
text1 = adjustl(text)
IF (text1 .ne. '#') then
exit
endif
enddo
do j = 1,year1
read (unitveg_bi, *) stz(2,j), help_veg_spec
do i=1,imkind
select case (sim_kind(i))
case ('STBIOM_bi')
sim1(j,i) = (help_veg_spec(opos2(i)) + help_veg_spec(opos2(i)+2))
case ('BIOM_bi','DG_bi','DBH_bi','Fol_bi','LAI_bi','NTREE_bi','Stem_inc_bi')
sim1(j,i) = help_veg_spec(opos2(i))
case ('HO_bi','MH_bi')
sim1(j,i) = help_veg_spec(opos2(i)) / 100.
end select
enddo
enddo
endif ! unitveg_bi
END SUBROUTINE read_simout
!**************************************************************
SUBROUTINE open_sfile (okind, otyp, unitnr)
use data_mess
use data_out
use data_simul
implicit none
integer unitnr
character(150) :: simsumfile ! simulation output sum-file
character(150) :: simoutfile ! simulation output file
character(10) :: helpsim
character(10) :: otyp, okind
logical ex
WRITE(helpsim,'(I2)') app(ip)
read(helpsim,*) anh
simoutfile = trim(dirout)//trim(site_name(ip))//'_'//trim(okind)//'.'//trim(otyp)//trim(anh)
inquire (File = simoutfile, exist = ex)
if(ex .eqv. .false.) then
write (*, '(A)') ' >>>foresee message: no such file ', adjustl(simoutfile)
return
else
write (*, '(A)') ' >>>foresee message: Filetest - file exists ',trim(simoutfile)
endif
unitnr = getunit()
open(unitnr,file=simoutfile,status='old')
END SUBROUTINE open_sfile