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 8910 additions and 0 deletions
source_code/version_2.3_windows/aspen_manag.f 0 → 100644
View file @ 82df1085
!*****************************************************************!
!* *!
!* 4C (FORESEE) *!
!* *!
!* *!
!* Subroutines for: *!
!* Aspen management *!
!* contains: *!
!* SR aspman_ini *!
!* SR asp_manag *!
!* SR asp_sprout *!
!* SR asp_pruning *!
!* *!
!* 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 aspman_ini
use data_manag
use data_species
use data_simul
use data_stand
use data_par
implicit none
integer :: manag_unit,i, ios
character(len=150) :: filename
logical :: ex
character ::text
manag_unit=getunit()
filename = manfile(ip)
allocate(thin_flag1(nspec_tree))
thin_flag1 = -1
allocate(yman(100))
allocate(rel_part(100))
yman = 0
rel_part = 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
i = 1
do
read(manag_unit,*,iostat=ios) yman(i), rel_part(i)
if(ios < 0) exit
i = i+1
end do
num_man = i-1
close(manag_unit)
end subroutine aspman_ini
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
subroutine asp_manag
use data_manag
use data_simul
implicit none
integer :: i
do i=1,num_man
if(yman(i).eq.time) then
call asp_pruning
if(i.ne.num_man) then
call asp_sprout
flag_sprout = 1
end if
end if
end do
end subroutine asp_manag
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
subroutine asp_sprout
use data_manag
use data_species
use data_simul
use data_stand
use data_par
use data_help
use data_soil
use data_tsort
implicit none
integer :: taxnr, i, j, nsp, acoh
REAL :: shoot
real :: faktor
REAL :: x1,x2,xacc,h_root, root
REAL :: rtflsp, stump_dw, stump_v, rtbis
TYPE(cohort) ::tree_ini
real, dimension(:), save, allocatable :: treea, crt, frt, stumpw
integer, dimension(:), save, allocatable :: spectyp, cohid
! distribution of coarse root matter of coppice shoots
real, dimension(6) :: fac_rob=(/0.0666, 0.1332, 0.1998, 0.2664,0.334, 0./)
external weight1
external rtflsp
external rtbis
allocate ( treea(anz_coh), crt(anz_coh), frt(anz_coh), spectyp(anz_coh), cohid(anz_coh), stumpw(anz_coh))
if(flag_reg.eq.18) then
nsprout = 5
end if
i = 1
zeig=>pt%first
do
if(.not.associated(zeig)) exit
if(zeig%coh%ntreem.ne.0.and. zeig%coh%ntreea.eq.0.and. zeig%coh%x_crt.ne.0) then
treea(i) = zeig%coh%ntreem
taxnr = zeig%coh%species
crt(i) = zeig%coh%x_crt
frt(i) = zeig%coh%x_frt
spectyp(i) = zeig%coh%species
cohid(i) = zeig%coh%ident
call stump( zeig%coh%x_ahb, zeig%coh%asapw,zeig%coh%dcrb,zeig%coh%x_hbole, &
zeig%coh%height, taxnr,stump_v, stump_dw)
stumpw(i) = stump_dw
i = i+1
end if
zeig=>zeig%next
end do
acoh = i-1
do i =1, acoh
if(flag_reg.eq.15) then
faktor = 0.25
else
faktor = fac_rob(1)
end if
do j = 1, nsprout
tree_ini%species = spectyp(i)
nsp = spectyp(i)
hnspec = nsp
h_root = faktor * (crt(i)*0.3 + stumpw(i)* 0.5)
max_coh= max_coh +1
call coh_initial (tree_ini)
tree_ini%ident = max_coh
tree_ini%x_age = 1
tree_ini%ntreea = treea(i)
tree_ini%nta = treea(i)
mschelp = h_root
x1 = 0.
x2 = 0.1
xacc = (1.0e-10) * (x1+x2)/2
root = rtbis(weight1,x1,x2,xacc)
tree_ini%x_sap = root
shoot = root*1000. ! [g]
tree_ini%x_fol= (spar(nsp)%seeda*(tree_ini%x_sap** spar(nsp)%seedb)) ![kg] ! [kg]
tree_ini%x_frt = faktor * frt(i) ! [kg]
tree_ini%med_sla = spar(nsp)%psla_min + spar(nsp)%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
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
zeig=>pt%first
do
if(.not.associated(zeig)) exit
if(zeig%coh%ident.eq. cohid(i)) then
tree_ini%rooteff = zeig%coh%rooteff
exit
end if
zeig=>zeig%next
end do
! tranformation of shoot biomass kg --> mg
if(nsp.ne.2)tree_ini%height = spar(nsp)%pheight1*(shoot*1000.)**spar(nsp)%pheight2 ! [cm] calculated from shoot biomass (mg)
if(tree_ini%height.eq.0.) then
nsp = nsp
end if
! bole height from stump
tree_ini%x_hbole = stoh(nsp)
IF(tree_ini%ntreea.ne.0.) then
IF (.not. associated(pt%first)) THEN
ALLOCATE (pt%first)
pt%first%coh = tree_ini
NULLIFY(pt%first%next)
ELSE
ALLOCATE(zeig)
zeig%coh = tree_ini
zeig%next => pt%first
pt%first => zeig
END IF
anz_coh=anz_coh+1
END IF
if(flag_reg.eq.15) then
faktor = faktor + 0.0833333
else
faktor = fac_rob(j+1)
end if
end do ! j, nsprouts
end do ! i
deallocate ( treea, crt, frt, spectyp,cohid, stumpw)
end subroutine asp_sprout
subroutine asp_pruning
use data_manag
use data_species
use data_simul
use data_stand
use data_par
implicit none
integer :: taxnr, j
zeig=>pt%first
do
if(.not.associated(zeig)) exit
zeig%coh%ntreem = zeig%coh%ntreea
zeig%coh%ntreea = 0
zeig%coh%nta = 0.
zeig=>zeig%next
end do
! calculation of total dry mass of all harvested trees (stem + twigs and branches)
sumNPP = 0
sumvsab = 0.
sumvsab_m3 = 0.
svar%sumvsab = 0.
zeig=>pt%first
do
if(.not.associated(zeig)) exit
ns = zeig%coh%species
sumvsab = sumvsab + zeig%coh%ntreem*(zeig%coh%x_sap + zeig%coh%x_hrt + zeig%coh%x_tb)
sumvsab_m3 = sumvsab_m3 + zeig%coh%ntreem*(zeig%coh%x_sap + zeig%coh%x_hrt+zeig%coh%x_tb)/(spar(ns)%prhos*1000000)
svar(ns)%sumvsab = svar(ns)%sumvsab + zeig%coh%ntreem*(zeig%coh%x_sap + zeig%coh%x_hrt + zeig%coh%x_tb)
sumnpp = sumnpp + zeig%coh%ntreem*zeig%coh%npp
zeig=>zeig%next
end do
sumvsab_m3 = sumvsab_m3 * 10000./kpatchsize ! kg/ha
sumvsab = sumvsab * 10000./kpatchsize ! kg/ha
do j = 1, nspec_tree
svar(j)%sumvsab = svar(j)%sumvsab * 10000./kpatchsize
end do
! cumulative harvested stem mass
cumsumvsab = cumsumvsab + sumvsab
! litter pools
! 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
endif
zeig=>zeig%next
enddo
end subroutine asp_pruning
source_code/version_2.3_windows/aust_manag.f 0 → 100644
View file @ 82df1085
!*****************************************************************!
!* *!
!* 4C (FORESEE) *!
!* *!
!* *!
!* Subroutines for: *!
!* Austrian management *!
!* contains: *!
!* SR aust_ini *!
!* SR aust_manag *!
!* SR plant_aust *!
!* SR calc_rel_class *!
!* *!
!* 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 aust_ini
use data_manag
use data_species
use data_simul
use data_stand
implicit none
integer :: manag_unit,i, ih1,ih2,ios,ih4, flp , flag_help
character(len=150) :: filename
logical :: ex
character ::text
real :: hp, ih3
manag_unit=getunit()
filename = manfile(ip)
allocate(thin_flag1(nspec_tree))
flag_help = 0
thin_flag1=-1
thin_dead = 1
allocate(yman(1000))
allocate(dbh_clm(1000))
allocate(rem_clm(1000))
allocate(spec_man(1000))
allocate(act(1000))
allocate(rel_part(1000))
yman = 0
dbh_clm = 0
rem_clm = 0.
spec_man = 0
act = 0
rel_part = 0
flp = 0
call testfile(filename,ex)
open(manag_unit,file=trim(filename))
! read head of data-file
do
read(manag_unit,*) text
if(text .ne. 's')then
backspace(manag_unit);exit
endif
enddo
i=1
do
read(manag_unit,*,iostat=ios) ih1,ih2, ih3, hp,ih4
if(ios<0) exit
yman(i) = ih1 ! year of treatment
if(ih2.eq.1) then
! Fichte/ Spruce
spec_man(i) = 2
else if(ih2.eq.2) then
! Kiefer/ Pine
spec_man(i) = 3
else if(ih2.eq.3) then
! Eiche/ oak
spec_man(i) = 4
else if(ih2.eq.4) then
spec_man(i) = 1
end if
! species number
act(i) = ih4
if(ih1.ne.-999 ) then
if(flp.eq.0) then
dbh_clm(i) = int(ih3) ! dbh-cluss number for treatment
rem_clm(i) = hp ! removal of biomass
i = i+1
else
act(i) = ih4
rel_part(i) = ih3
rem_clm(i) = 0
i = i+1
end if
else
if(i.eq.1) thin_dead = 0
flp = 1
backspace(manag_unit)
end if
end do
num_man = i-1
close(manag_unit)
END SUBROUTINE aust_ini
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
SUBROUTINE aust_manag
use data_manag
use data_stand
use data_simul
use data_species
use data_par
implicit none
integer :: i,j,hcl, ha, taxnr,k,l, help_fl,helpz, helps
real, dimension(5) :: rel_biom, harv_biom
real, dimension(5) :: num_ccl, contr
real,dimension(5) :: help_rem_clm
integer,dimension(5) :: help_rel_dbh, hrd
real :: stump_dw, stump_v, hrb
ha =0
rel_biom = 0.
num_ccl =0
harv_biom = 0.
help_rel_dbh = 0
help_rem_clm = 0.
hrd = 0
helpz = 0
helps = 0
call calc_rel_class
! calculation of stem biomass of relative dbh-class
zeig=>pt%first
do
if(.not.associated(zeig)) exit
if(zeig%coh%diam.ne.0) then
hcl = zeig%coh%rel_dbh_cl
if(hcl.ne.0) then
num_ccl(hcl)= num_ccl(hcl) +1
rel_biom(hcl)= rel_biom(hcl) + (zeig%coh%x_sap + zeig%coh%x_hrt)*zeig%coh%ntreea
end if
end if
zeig=>zeig%next
end do
do l=1,nspecies
help_rel_dbh = 0
help_rem_clm = 0.
helpz = 0
helps = 0
! calculation of stem biomass of relative dbh-class
zeig=>pt%first
do
if(.not.associated(zeig)) exit
if(zeig%coh%diam.ne.0.and.zeig%coh%species.eq.l) then
hcl = zeig%coh%rel_dbh_cl
if(hcl.ne.0) then
num_ccl(hcl)= num_ccl(hcl) +1
rel_biom(hcl)= rel_biom(hcl) + (zeig%coh%x_sap + zeig%coh%x_hrt)*zeig%coh%ntreea
end if
end if
zeig=>zeig%next
end do
hrd=0
do i=1,num_man
if(yman(i).eq.time) then
if(act(i) .eq.1.and.spec_man(i).eq.l) then
zeig=>pt%first
do
if(.not.associated(zeig)) exit
if(zeig%coh%diam.ne.0) then
if(zeig%coh%species.eq.l) then
hrd(zeig%coh%rel_dbh_cl)= 1
end if
end if
zeig=>zeig%next
end do
help_rel_dbh(dbh_clm(i)) = 1
help_rem_clm(dbh_clm(i)) = rem_clm(i)
end if ! act(i)
end if !yman(i)
end do ! num_man
do j=1,5
if(help_rel_dbh(j).eq.1.and.hrd(j).eq.0) then
if(j.eq.1.) then
do k=2,5
if(hrd(k).ne.0) then
help_rem_clm(k) = help_rem_clm(k) + help_rem_clm(j)
help_rel_dbh(k)=1
exit
end if
end do
else if (j.eq.5.) then
do k= 4,1,-1
if(hrd(k).eq.1) then
help_rem_clm(k) = help_rem_clm(k) + help_rem_clm(j)
help_rel_dbh(k) = 1
exit
endif
end do
else
do k=j,5
if(hrd(k).eq.1) then
help_rem_clm(k) = help_rem_clm(k) + help_rem_clm(j)*0.5
help_rel_dbh(k) = 1
exit
end if
end do
do k=j,1,-1
if(hrd(k).eq.1) then
help_rem_clm(k) = help_rem_clm(k) + help_rem_clm(j)*0.5
help_rel_dbh(k) = 1
exit
end if
end do
end if
help_rel_dbh(j) = 0
help_rem_clm(j) = 0.
end if
end do
! thinning
help_fl = 0
do i=1,num_man
if(yman(i).eq.time.and.help_fl.eq.0) then
do k=1,5
helps = helps + help_rel_dbh(k)
end do
help_fl=1
zeig=>pt%first
do
if(.not.associated(zeig)) exit
if(zeig%coh%diam.ne.0.and.zeig%coh%species.eq.l) then
do k=1,5
if(zeig%coh%rel_dbh_cl.eq.k.and.help_rel_dbh(k).eq.1) then
if(help_rem_clm(k).gt.1.) help_rem_clm(k) = 1.
if( help_rem_clm(k) .eq. 1.)then
if(zeig%coh%underst.eq.0.and.zeig%coh%x_age.gt. 20) ha=int(help_rem_clm(k)* zeig%coh%ntreea+0.5)
helpz = helpz +1
else
ha=int(help_rem_clm(k)* zeig%coh%ntreea+0.5)
end if
if(ha.lt.1) ha = 1
if(help_rem_clm(k) .ne.1) then
harv_biom(k) = harv_biom(k) + ha* (zeig%coh%x_sap + zeig%coh%x_hrt)
hrb = help_rem_clm(k)* rel_biom(k)
if(harv_biom(k).eq.rel_biom(k)) then
ha = ha -1
end if
end if
zeig%coh%ntreea = zeig%coh%ntreea - ha
zeig%coh%nta = zeig%coh%ntreea
zeig%coh%ntreem = zeig%coh%ntreem + ha
end if
end do ! k loop
end if
zeig=>zeig%next
end do ! zeig loop
end if
end do ! num_man
if(helps.gt.0.and.helpz.ge.helps) then
zeig=>pt%first
do
if(.not.associated(zeig)) exit
if(zeig%coh%species.eq.l.and.zeig%coh%underst.eq.1) then
zeig%coh%underst = 0
end if
zeig => zeig%next
end do
end if
write(9898,*) time, 'totbio', rel_biom
write(9898,*) time, 'harvbio', harv_biom
do i=1,5
if(rel_biom(i).ne.0.) then
contr(i) = harv_biom(i)/rel_biom(i)
else
contr(i) = 0.
end if
end do
write(9898,*) time,l, contr
rel_biom = 0.
harv_biom = 0.
end do ! nspecies
! planting
do i=1,num_man
if(yman(i).eq.time.and.act(i).ne.1) then
call plant_aust(i)
end if ! act
end do
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
endif
zeig=>zeig%next
enddo
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
! cumulative harvested stem mass
cumsumvsab = cumsumvsab + sumvsab
if(thin_dead.ne.0) then
call class_man
end if
END SUBROUTINE aust_manag
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
SUBROUTINE plant_aust(mp)
use data_manag
use data_plant
use data_species
use data_stand
implicit none
integer :: fl_plant, i, nplant,taxid,mp
real :: age, &
pl_height, &
sdev, &
plhmin
infspec = 0
npl_mix = 0
fl_plant = act(mp)
select case(fl_plant)
case(2)
infspec(2) = 1
npl_mix(2) = 2500
case(3)
infspec(2) = 1
npl_mix(2) = 10000
case(4)
infspec(3) = 1
npl_mix(3) = 5000
case(5)
infspec(3) = 1
npl_mix(3) = 2000
case(6)
infspec(1) = 1
npl_mix(1) = 500
case(7)
infspec(1) = 1
npl_mix(1) = 5000
case(8)
infspec(4) = 1
npl_mix(4) = 5000
case(9)
infspec(1) = 1
npl_mix(1) = 1000
infspec(4) = 1
npl_mix(4) = 3500
case(10)
infspec(3) = 1
npl_mix(3) = 2500
infspec(4) = 1
npl_mix(4) = 2500
case(11)
infspec(3) = 1
npl_mix(3) = 2500
infspec(1) = 1
npl_mix(1) = 2500
case(12)
infspec(3) = 1
npl_mix(3) = 7000
case(13)
infspec(4) = 1
npl_mix(4) = 2500
end select
do i = 1,nspec_tree
if (infspec(i).eq.1) then
taxid = i
! data for Austria
age = pl_age(taxid)
pl_height = plant_height(taxid)
plhmin = plant_hmin(taxid)
nplant = rel_part(mp)*nint(npl_mix(taxid)*kpatchsize/10000)
sdev = hsdev(taxid)
call gener_coh(taxid, age, pl_height, plhmin, nplant,sdev)
end if
end do ! i
END SUBROUTINE plant_aust
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
SUBROUTINE calc_rel_class
use data_manag
use data_stand
use data_species
implicit none
integer :: nrmax, i, j, k, adm
real,dimension(10) :: maxdbh, mindbh,class_wd
integer :: nrmin
real :: help, help_h1
class_wd =0.
maxdbh = 0.
mindbh = 0.
do j= 1,nspecies
call max_dbh(nrmax,help,adm, j)
call min_dbh(nrmin,help_h1,adm, j)
zeig=>pt%first
do
if(.not.associated(zeig)) exit
if(zeig%coh%ident.eq.nrmax.and.zeig%coh%species.eq.j) then
maxdbh(j) = help
else if(zeig%coh%ident.eq.nrmin.and.zeig%coh%species.eq.j) then
mindbh(j) = help_h1
end if
zeig=>zeig%next
end do
end do
do j=1,nspecies
class_wd(j) = (maxdbh(j)-mindbh(j))/5
k = 5
zeig=>pt%first
do
if(.not.associated(zeig)) exit
if(zeig%coh%species.eq.j.and. zeig%coh%diam.gt.0) then
do i=1,k
if(zeig%coh%diam.ge.(mindbh(j)+class_wd(j)*(i-1)).and.zeig%coh%diam.lt.(mindbh(j)+class_wd(j)*i)) then
zeig%coh%rel_dbh_cl = i
exit
else if (zeig%coh%diam.eq.maxdbh(j)) then
zeig%coh%rel_dbh_cl = 5
end if
end do
end if
zeig=>zeig%next
end do
end do
END SUBROUTINE calc_rel_class
source_code/version_2.3_windows/calc_climdriv.f 0 → 100644
View file @ 82df1085
!*****************************************************************!
!* *!
!* 4C (FORESEE) Simulation Model *!
!* *!
!* *!
!* SR photoper *!
!* *!
!* contains follow global units: *!
!* photoper function for calculation of photoperiod *!
!* daylength calculation of day length *!
!* avg_sun_incl Calculates average sun declination for *!
! the season at the given latitude in degrees *!
!* fixclimscen subroutine for calculation of delta T and P *!
!* glob_rad Estimation of global radiation from sunshine *!
!* frost_index_total subroutine for calculation of frost index *!
!* *!
!* 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 *!
!* *!
!*****************************************************************!
REAL FUNCTION PHOTOPER(d,xlatitude)
! by Thomas Kartschall 8.7.92
!
! PhotoPeriod -Potential daily Sun Shine Period [h]
! d -Ordinal Number of Julian Date [Real!4]
! latitude -Latitude by Radiant [Real!4]
! Northern L>0; Southern L<0
!
! Polarkreis bei je 66.55 bzw 6633'36'' N/SL
!
USE data_par
USE data_simul
real d, xlatitude, del, ws, ws2
!
! Equator from 0,2 respectively 012'
!
IF (abs(xlatitude).lt.0.0024) then
photoper=12.0
return
ENDIF
!
!pole surrounding ab 89,8 bzw 8948'
!
IF (xlatitude.ge. 1.567305668)xlatitude= 1.567305668
IF (xlatitude.le.-1.567305668) xlatitude=-1.567305668
g=2*pi*(d-1.0)/365.25
del=0.006918-0.399912*cos(g)
del=del+0.070257*sin(g)-0.006758*cos(g+g)
del=del+0.000907*sin(g+g)-0.002697*cos(g+g+g)
del=del+0.00148*sin(g+g+g)
ws=sin(xlatitude)*sin(del)
ws2=cos(xlatitude)*cos(del)
!
!polar night duration per day no longer than 24h
!
IF (ws/ws2.ge.1.0) ws=ws2
IF (ws/ws2.le.-1.0) ws=-ws2
ws=acos(ws/ws2)
ws=12.*(1.-ws/pi)
!day length is dopple the time between HighNoon and SunRise
PHOTOPER=2.*(ws)
RETURN
END FUNCTION photoper
!*******************************************************************
FUNCTION DAYLENGTH(doy,hlat)
USE data_par
IMPLICIT NONE
REAL :: hlat
REAL :: daylength
INTEGER :: doy
REAL :: decl,arg
decl = -23.45*(PI/180)*COS(2.*PI/365.*(doy+10))
! latitude is converted to rad
arg = -TAN(hlat*PI/180.)*TAN(decl);
IF( arg < -1. ) THEN
daylength = 24.
ELSE IF ( arg > 1. ) THEN
daylength = 0.
ELSE
daylength = (24./PI)*ACOS(arg)
ENDIF
END FUNCTION DAYLENGTH
!*******************************************************************
FUNCTION AVG_SUN_INCL(hlat)
!Calculates average sun declination for the season
! at the given latitude in degrees
use data_par
implicit none
REAL :: avg_sun_incl
REAL :: hlat, h1, h2, h3
REAL :: decl, sumbeta, dl, sumdl
INTEGER :: i, j
REAL, EXTERNAL :: daylength
sumdl = 0
sumbeta = 0
h1 = sin(PI*hlat/180)
h2 = cos(PI*hlat/180)
DO i=120,280,+1
decl = -23.45*(PI/180)*COS(2.*PI/365.*(i+10))
dl = DAYLENGTH(i,hlat)
! sun declination at noon
h3 = h1*sin(decl)+h2*cos(decl)
if(h3.gt.1.) h3 = 1
avg_sun_incl = 180/PI*asin(h3);
sumbeta = sumbeta + avg_sun_incl*dl;
sumdl = sumdl + dl;
END DO
avg_sun_incl = sumbeta/sumdl
END FUNCTION AVG_SUN_INCL
!*******************************************************************
SUBROUTINE fixclimscen
! fixclimscen calculates deltaT and deltaPrec for climate change scenarios with
! fixed offsets in temperature and precipitation
USE data_simul
IMPLICIT NONE
INTEGER :: dimTsteps, dimPsteps
! calculations
dimTsteps = 1 + n_T_downsteps + n_T_upsteps
dimPsteps = 1 + n_P_downsteps + n_P_upsteps
deltaT = ((ip-1)/dimPsteps-n_T_downsteps)*step_sum_T
deltaPrec = 1.+((ip-1)-((ip-1)/dimPsteps)*dimPsteps-n_P_downsteps)*step_fac_P
CALL out_scen
END SUBROUTINE fixclimscen
!****************************************************************************
SUBROUTINE glob_rad(sd, iday, xlat, rad)
! Estimation of global radiation from sunshine duration
! (calculation after Angstrom)
implicit none
! input:
integer :: iday ! actual day
real :: sd ! sunshine duration (h)
real :: xlat ! latitude
! output:
real :: rad ! global radiation (J/cm2)
! internal variables
real :: rad_ex , & ! extraterrestrical radiation (J/cm2)
dayl , & ! daylength
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)
! after P. Hupfer: "Klimasystem der Erde", 1991
! change of units from degree to radians
pi = 3.141592654
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(xlat*radi)*sin(dec)
cosld = cos(xlat*radi)*cos(dec)
tanld = amax1(-1., amin1(1., sinld/cosld))
! daylength
dayl = 12.*(1.+2.*asin(tanld)/pi)
! 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 (sd.ge.0.) then
rad = (0.231+0.539*sd/dayl)*rad_ex
else
write (*, '(A, I3, A)') ' RAD is out of range at day ', iday , &
' , RAD will be = 1000 J/cm2!'
end if
END SUBROUTINE glob_rad
!****************************************************************************
subroutine frost_index_total
use data_frost
use data_simul
use data_stand
implicit none
integer :: zaehl=0
integer :: i
integer :: zaehl1 =0
integer :: t,m,j
real :: mean_dnlf
real :: mean_tminmay
integer :: mean_date_lf
integer :: mean_date_lftot
real :: mean_dnlf_sp
real :: mean_tminmay_sp
integer :: mean_date_lf_sp
real :: mean_anzdlf
real :: mean_sumtlf
integer :: ind1, ind2, ind3, ind4, ind5
integer :: ind1_sp
zaehl=0
mean_tminmay = 0.
mean_date_lf = 0
mean_date_lftot = 0
mean_dnlf = 0
mean_dnlf_sp = 0
mean_anzdlf = 0
mean_sumtlf = 0
do i =1,year
if(tminmay_ann(i).ne.0) then
zaehl = zaehl +1
mean_tminmay= mean_tminmay+tminmay_ann(i)
end if
end do
if(zaehl.ne.0) then
mean_tminmay = mean_tminmay/zaehl
else
mean_tminmay = 0.
end if
do i=1,year
mean_anzdlf = mean_anzdlf + anzdlf(i)
mean_sumtlf = mean_sumtlf + sumtlf(i)
end do
mean_anzdlf = mean_anzdlf/year
mean_sumtlf = mean_sumtlf/year
zaehl=0
do i =1,year
if(date_lftot(i).ne.0) then
zaehl = zaehl +1
mean_date_lftot = mean_date_lftot + date_lftot(i)
end if
end do
if(zaehl.ne.0) then
mean_date_lftot = mean_date_lftot/zaehl
else
mean_date_lftot = 0.
end if
mean_dnlf = 0.
zaehl=0
do i =1,year
if(dnlf(i).ne.0) then
mean_dnlf = mean_dnlf + dnlf(i)
zaehl = zaehl +1
end if
end do
if(zaehl.ne.0) then
mean_dnlf = mean_dnlf/zaehl
else
mean_dnlf = 0
endif
zaehl=0
do i =1,year
if(date_lf(i).ne.0) then
mean_date_lf = mean_date_lf + date_lf(i)
zaehl = zaehl +1
end if
enddo
if(zaehl.ne.0) then
mean_date_lf = mean_date_lf/zaehl
else
mean_date_lf = 0
end if
zaehl1=0
do i =1,year
if(dnlf_sp(i).ne.0) then
zaehl1 = zaehl1 +1
mean_dnlf_sp = mean_dnlf_sp + dnlf_sp(i)
end if
enddo
if (zaehl1.ne.0) then
mean_dnlf_sp = mean_dnlf_sp/zaehl1
else
mean_dnlf_sp = 0
endif
if (mean_dnlf.le.2.5 .and. mean_tminmay.ge. -1.5 .and.tminmay.ge.-5.0 .and. mean_date_lf.lt.130 .and. dlfabs .lt. 156) lfind=1
if (mean_dnlf.ge.2.6 .and. mean_dnlf .le.3.5 .and. mean_tminmay.ge. -2.0 .and. mean_tminmay.lt.-1.5 .and. tminmay .ge.-6. .and. mean_date_lf .lt.135 .and. dlfabs .lt.161) lfind=2
if (mean_dnlf.gt.3.5 .and. mean_dnlf .le.4.5 .and. mean_tminmay.ge. -2.5 .and. mean_tminmay.lt.-2.0 .and. tminmay .ge.-6. .and. mean_date_lf .ge.135 .and. mean_date_lf .le. 140 .and. dlfabs .ge.162 .and. dlfabs.le.166) lfind=3
if (mean_dnlf.gt.4.5 .and. mean_dnlf .le.5.0 .and. mean_tminmay.ge. -3.0 .and. mean_tminmay.lt.-2.5 .and. tminmay .ge.-7. .and. mean_date_lf .ge.141 .and. mean_date_lf .le. 145 .and. dlfabs .ge.167 .and. dlfabs.le.171) lfind=4
if (mean_dnlf.gt.5.10 .and. mean_dnlf .le.5.5 .and. mean_tminmay.ge. -3.5 .and. mean_tminmay.lt.-3.0 .and. tminmay .ge.-8. .and. mean_date_lf .ge.141 .and. mean_date_lf .le. 145 .and. dlfabs .ge.172 .and. dlfabs.le.176) lfind=5
if (mean_dnlf.gt.5.5 .and. mean_tminmay.lt.-3.5 .and. tminmay .le.-8. .and. mean_date_lf .gt.145 .and. dlfabs .gt.176) lfind=6
! index of number of late frost days since beginning of vegetation period
if (mean_dnlf.le.2.5) then
ind1 = 1
else if(mean_dnlf.le.3.5) then
ind1 = 2
else if (mean_dnlf.le.4.5) then
ind1 = 3
else if (mean_dnlf.le.5.0) then
ind1 = 4
else if (mean_dnlf.le.5.5) then
ind1 = 5
else
ind1 = 6
endif
! index of number of late frost days since beginning of bud burst
if (mean_dnlf_sp .le. 2.5) then
ind1_sp= 1
else if(mean_dnlf_sp.le.3.5) then
ind1_sp = 2
else if (mean_dnlf_sp.le.4.5) then
ind1_sp = 3
else if (mean_dnlf.le.5.0) then
ind1_sp = 4
else if (mean_dnlf_sp.le.5.5) then
ind1_sp = 5
else
ind1_sp = 6
endif
! index of mean minimum may temperature
if(mean_tminmay.ge. -1.5) then
ind2 = 1
else if (mean_tminmay.ge. -2.0) then
ind2 = 2
else if (mean_tminmay.ge. -2.5) then
ind2 = 3
else if (mean_tminmay.ge. -3.0) then
ind2 = 4
else if (mean_tminmay.ge. -3.5) then
ind2 = 5
else
ind2 =6
endif
! index of absolute minimum may temperature
if(tminmay.ge.-5.0) then
ind3 = 1
else if(tminmay.ge.-6.0 .and. ind2 .le.2) then
ind3 = 2
else if (tminmay.ge.-6.0 .and. ind2 .le.3) then
ind3 =3
else if (tminmay.ge.-7.0) then
ind3 = 4
else if (tminmay.ge.-8.0) then
ind3 = 5
else
ind3 = 6
end if
! index of mean date(number of the year) of late frost
if (mean_date_lf.lt.130) then
ind4 = 1
else if (mean_date_lf.lt.135) then
ind4 = 2
else if (mean_date_lf.le.140 ) then
ind4 = 3
else if (mean_date_lf.le.145 .and. ind2.le.4) then
ind4 = 4
else if(mean_date_lf.le.145 .and. ind2.le.5) then
ind4 = 5
else
ind4 = 6
endif
! absolute last late frost (numbedr of the year)
if (dlfabs .lt. 156) then
ind5 = 1
else if (dlfabs .lt. 161) then
ind5 = 2
else if (dlfabs .le. 162) then
ind5 =3
else if (dlfabs .le. 171) then
ind5 = 4
else if (dlfabs .le. 176) then
ind5 = 5
else
ind5 =6
endif
mlfind = real((ind1 + ind2 + ind3 + ind4 + ind5)/5)
mlfind_sp = (ind1_sp + ind2 + ind3 + ind4 + ind5)/5
if(waldtyp.eq. 10 .or. waldtyp .eq. 40 .or. waldtyp .eq.90) mlfind_sp = 0
end subroutine frost_index_total
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