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 13684 additions and 0 deletions
source_code/version_2.3_windows/finisim.f 0 → 100644
View file @ 82df1085
!*****************************************************************!
!* *!
!* 4C (FORESEE) Simulation Model *!
!* *!
!* *!
!* Subroutines for: *!
!* finishing simulation *!
!* *!
!* contains *!
!* FINISH_SIMUL: deallocation of variables, *!
!* closing files for each simulation *!
!* FINISH_ALL : Finish all processes after all simulations *!
!* DEALLOC_SOIL: deallocation of soil variables *!
!* (also used in other routines) *!
!* *!
!* Copyright (C) 1996-2018 *!
!* Potsdam Institute for Climate Impact Reserach (PIK) *!
!* Authors and contributors see AUTHOR file *!
!* This file is part of 4C and is licensed under BSD-2-Clause *!
!* See LICENSE file or under: *!
!* http://www.https://opensource.org/licenses/BSD-2-Clause *!
!* Contact: *!
!* https://gitlab.pik-potsdam.de/foresee/4C *!
!* *!
!*****************************************************************!
SUBROUTINE finish_simul
use data_climate
use data_depo
!use data_effect
use data_evapo
use data_init
use data_manag
use data_out
use data_simul
use data_soil
use data_soil_cn
use data_species
use data_stand
use data_site
use data_tsort
use data_frost
! test lambda_ts
use data_par
implicit none
integer i ,unitout
character(150) :: filename, infile
REAL :: rsap, cform
CHARACTER :: source
rsap = 0.
cform=0.
source='U'
infile='planting'
if(time_out.gt.0) then
if (flag_dis .eq. 2) then
! output of new tree.ini at the end of the simulation
! hier neue version rausschreiben zum einlesen in 4C mit NSC Speicher
! x_nsc_tb x_nsc_crt x_nsc_sap als kg C per tree
unitout=getunit()
! filename = trim(site_name(site_nr))//'_tree.ini'//trim(anh)
filename = trim(site_name(ip))//'_tree.ini'//trim(anh)
open(unitout,file=trim(dirout)//filename,status='replace')
write(unitout,'(A1,2X,I1,1F12.0,A55)')'C', flag_volfunc, kpatchsize,' ! = ini version flag_dis, volume function, patch size'
write(unitout,'(A)')'! x_fol x_frt x_sap x_hrt x_Ahb height x_hbole x_age n sp DC DBH &
& x_nsc_tb x_nsc_crt x_nsc_sap'
zeig => pt%first
do while (associated(zeig))
write(unitout,'(5f12.5,2f10.0,i7,f7.0,i7, 5f12.5)') zeig%coh%x_fol, zeig%coh%x_frt, zeig%coh%x_sap, zeig%coh%x_hrt, &
zeig%coh%x_Ahb, zeig%coh%height, zeig%coh%x_hbole, zeig%coh%x_age, zeig%coh%ntreea, &
zeig%coh%species, zeig%coh%dcrb, zeig%coh%diam, zeig%coh%x_nsc_tb, zeig%coh%x_nsc_crt, zeig%coh%x_nsc_sap
zeig => zeig%next
end do
close(unitout)
else
! output of new tree.ini at the end of the simulation
unitout=getunit()
filename = trim(site_name(ip))//'_tree.ini'//trim(anh)
open(unitout,file=trim(dirout)//filename,status='replace')
write(unitout,'(I1,1F12.0,A32)')flag_volfunc,kpatchsize,' ! = volume function, patch size'
write(unitout,'(A)')'! x_fol x_frt x_sap x_hrt x_Ahb height x_hbole x_age n sp DC DBH'
zeig => pt%first
do while (associated(zeig))
write(unitout,'(5f12.5,2f10.0,i7,f7.0,i7, 2f12.5)') zeig%coh%x_fol, zeig%coh%x_frt, zeig%coh%x_sap, zeig%coh%x_hrt, &
zeig%coh%x_Ahb, zeig%coh%height, zeig%coh%x_hbole, zeig%coh%x_age, zeig%coh%ntreea, &
zeig%coh%species, zeig%coh%dcrb, zeig%coh%diam
zeig => zeig%next
end do
close(unitout)
endif
! output of new .lit-file at the end of the simulation
if (flag_end .eq. 0) then
unitout=getunit()
filename = trim(site_name(ip))//'.lit'//trim(anh)
open(unitout,file=trim(dirout)//filename,status='replace')
write(unitout,'(A,A)')'! litter initialisation ', site_name(ip)
write(unitout,'(A)')'! fraction Fagus sylvatica Picea abies Pinus sylvestris Quercus robur Betula pendula Pinus contorta Pinus ponderosa Populus tremula ground cover'
write(unitout,'(A12, 9F18.1)') ' C_opm_fol ', (slit(i)%C_opm_fol, i=1,nspecies)
write(unitout,'(A12, 9F18.1)') ' C_opm_tb ', (slit(i)%C_opm_tb, i=1,nspecies)
write(unitout,'(A12, 9F18.1)') ' C_opm_frt ', (slit(i)%C_opm_frt(1), i=1,nspecies)
write(unitout,'(A12, 9F18.1)') ' C_opm_crt ', (slit(i)%C_opm_crt(1), i=1,nspecies)
write(unitout,'(A12, 9F18.1)') ' C_opm_stem ', (slit(i)%C_opm_stem,i=1,nspecies)
close(unitout)
endif
end if ! time_out
! deallocate cohorts
if(flag_end.ne.1 .and. associated(pt%first)) then
zeig => pt%first
do while (associated(zeig))
pt%first => zeig%next
deallocate (zeig%coh%frtrel)
deallocate(zeig%coh%frtrelc)
deallocate (zeig%coh%rooteff)
if (flag_wred .eq. 9) deallocate (zeig%coh%rld)
deallocate(zeig)
zeig => pt%first
end do
end if
if(associated(pt%first)) deallocate (pt%first)
if (flag_eva .gt.10) close (unit_eva)
if (allocated(dayfract))deallocate(dayfract)
! fields for frost index
if(allocated(dnlf)) deallocate(dnlf)
if(allocated(tminmay_ann))deallocate(tminmay_ann)
if(allocated(date_lf)) deallocate(date_lf)
if(allocated(date_lftot)) deallocate(date_lftot)
if(allocated(dnlf_sp)) deallocate(dnlf_sp)
if(allocated(anzdlf)) deallocate(anzdlf)
if (allocated(sumtlf)) deallocate(sumtlf)
if (flag_clim==1) then
if (allocated(recs))deallocate(recs)
if (allocated(dd))deallocate(dd)
if (allocated(mm))deallocate(mm);
if (allocated(yy))deallocate(yy)
if (allocated(tp))deallocate(tp);
if (allocated(hm))deallocate(hm)
if (allocated(prc))deallocate(prc);
if (allocated(prs))deallocate(prs)
if (allocated(rd))deallocate(rd)
if (allocated(wd))deallocate(wd)
if (allocated(tx))deallocate(tx)
if (allocated(tn))deallocate(tn)
if (allocated(vp))deallocate(vp)
if (allocated(sdu))deallocate(sdu)
if (allocated(sde))deallocate(sde)
if (allocated(bw))deallocate(bw)
if (allocated(tempfield))deallocate(tempfield)
if (allocated(globfield))deallocate(globfield)
if (allocated(dayfield))deallocate(dayfield)
endif
if (.not.flag_mult910) then
if (allocated(NHd))deallocate(NHd)
if (allocated(NOd))deallocate(NOd)
endif
if (allocated(diam_class))deallocate(diam_class)
if (allocated(diam_class_t))deallocate(diam_class_t)
if (allocated(diam_class_h))deallocate(diam_class_h)
if (allocated(diam_class_age))deallocate(diam_class_age)
if (allocated(diam_class_mvol))deallocate(diam_class_mvol)
if (allocated(diam_classm))deallocate(diam_classm)
if (allocated(diam_classm_h))deallocate(diam_classm_h)
if (allocated(height_class))deallocate(height_class)
if (allocated(ngroups))deallocate(ngroups)
if (allocated(dead_wood)) then
do i = 1, nspec_tree
deallocate(dead_wood(i)%C_tb)
deallocate(dead_wood(i)%N_tb)
deallocate(dead_wood(i)%C_stem)
deallocate(dead_wood(i)%N_stem)
enddo
deallocate(dead_wood)
endif
svar%sumvsdead = 0.
svar%sumvsdead_m3 = 0.
svar%daybb = 0.
if (flag_multi .eq. 1 .or. flag_multi .eq. 6 .or. flag_multi .eq. 0) then
if(allocated(spar)) deallocate(spar)
if(allocated(nrspec)) deallocate(nrspec)
! clear subfields for stress variables of svar
if (flag_wurz .eq. 4 .or. flag_wurz .eq. 6) then
do i=1,nspecies
deallocate(svar(i)%tstress)
deallocate(svar(i)%sstr)
deallocate(svar(i)%BDstr)
deallocate(svar(i)%BDmax)
deallocate(svar(i)%porcrit)
deallocate(svar(i)%airstr)
deallocate(svar(i)%phstr)
deallocate(svar(i)%Rstress)
deallocate(svar(i)%Smean)
enddo
endif
if(allocated(svar)) deallocate(svar)
endif
if(flag_multi .eq. 4 .or. flag_mult8910) then
do i=1,nspecies
svar(i)%RedN = -99.9
enddo
end if
call dealloc_soil ! soil-files immer deallok.
do i = 1,outy_n
if (outy(i)%out_flag .ne. 0) then
close (outy(i)%unit_nr)
endif
enddo
do i = 1,outd_n
if (outd(i)%out_flag .ne. 0) then
close (outd(i)%unit_nr)
endif
enddo
C_bc_tot = 0.
N_bc_tot = 0.
if (flag_bc .gt. 0) then
deallocate(C_bc)
deallocate(N_bc)
deallocate (C_bc_appl)
deallocate (N_bc_appl)
deallocate (bc_appl_lay)
deallocate (cnv_bc)
deallocate (dens_bc)
deallocate (cpart_bc)
deallocate (y_bc)
flag_decomp = flag_decomp + 100 ! flag_decomp zurcksetzen
endif
if (flag_cohout .ge. 1) then
do i = 1,outcy_n
if (outcy(i)%out_flag .ne. 0) then
close (outcy(i)%unit_nr)
endif
enddo
endif
if (flag_dayout .ge. 1) then
do i = 1,outcd_n
if (outcd(i)%out_flag .ne. 0) then
close (outcd(i)%unit_nr)
endif
enddo
endif
if(time_out .gt. 0) then
if (out_flag_light .ne. 0) close(unit_light)
if (flag_cohout .eq. 2) then
close(unit_prod)
close(unit_allo)
endif
end if
if (flag_dayout .gt. 1) then
close(unit_wat)
close(unit_soicnd);close(unit_soicna)
endif
if (.not.flag_mult910) close (unit_soil)
if (flag_sum > 0) close(unit_sum)
if (flag_mg==1) then
deallocate(thin_year);deallocate(thin_tree)
endif
if (flag_mg==3.or. flag_mg==33) then
if (allocated(thin_year)) deallocate(thin_year)
if( allocated(target_mass)) deallocate(target_mass)
if (allocated(thin_tysp))deallocate(thin_tysp)
if (allocated(thin_spec))deallocate(thin_spec)
if (allocated(rot))deallocate(rot)
if (allocated(thin_flag1))deallocate(thin_flag1)
if (allocated(thinyear))deallocate(thinyear)
if (allocated(thin_stor))deallocate(thin_stor)
endif
if (flag_mg==2.and. flag_end==0) then
if (allocated(zbnr))deallocate(zbnr)
if (allocated(tend))deallocate(tend)
if (allocated(rot))deallocate(rot)
if (allocated(regage))deallocate(regage)
if (allocated(thin_flag1))deallocate(thin_flag1)
if (allocated(thin_flag2))deallocate(thin_flag2)
if (allocated(thin_flag3))deallocate(thin_flag3)
if (allocated(thin_flag4))deallocate(thin_flag4)
if (allocated(np_mod))deallocate(np_mod)
if (allocated(specnr))deallocate(specnr)
if (allocated(age_spec))deallocate(age_spec)
if (allocated(anz_tree_spec))deallocate (anz_tree_spec)
if (allocated(thinyear))deallocate(thinyear)
end if
if (flag_mg==4. .or. flag_mg == 5) then
if (allocated(thin_flag1)) deallocate(thin_flag1)
end if
if(flag_mg == 10) then
if (allocated(thin_flag1))deallocate(thin_flag1)
if (allocated(dis_id))deallocate(dis_id)
if (allocated(dis_type))deallocate(dis_type)
if (allocated(fortype))deallocate(fortype)
if (allocated(dis_year))deallocate(dis_year)
if (allocated(dis_rel))deallocate(dis_rel)
if (allocated(sum_dis))deallocate(sum_dis)
end if
if(flag_dis == 1 .or. flag_dis == 2) then
if (allocated(dis_year))deallocate(dis_year)
if (allocated(dis_spec))deallocate(dis_spec)
if (allocated(dis_start))deallocate(dis_start)
if (allocated(dis_rel))deallocate(dis_rel)
if (allocated(dis_type))deallocate(dis_type)
end if
if(flag_mg == 9) then
if (allocated(thin_flag1))deallocate(thin_flag1)
if (allocated(yman))deallocate(yman)
if (allocated(dbh_clm))deallocate(dbh_clm)
if (allocated(rem_clm))deallocate(rem_clm)
if (allocated(spec_man))deallocate(spec_man)
if (allocated(act))deallocate(act)
if (allocated(rel_part))deallocate(rel_part)
end if
if(flag_mg == 8) then
if (allocated(thin_flag1))deallocate(thin_flag1)
if (allocated(yman))deallocate(yman)
if (allocated(rel_part))deallocate(rel_part)
end if
if(flag_wpm.ne.0) then
! free the resources
call deallocate_wpm
IF ( associated(st%first)) then
ztim => st%first
do while (associated(ztim))
st%first => ztim%next
deallocate(ztim)
ztim => st%first
end do
endif
IF ( associated(st%first)) deallocate(st%first)
if ( associated(ztim)) deallocate(ztim)
end if
! test lambda_ts
if (flag_lambda.eq.1) then
deallocate (lambda_ts)
end if
! compressed output for each simulation run
lcomp1 = .TRUE.
end subroutine finish_simul
!-----------------------------------------
SUBROUTINE finish_all
use data_simul
use data_climate
use data_depo
use data_mess
use data_out
use data_site
use data_soil
use data_soil_cn
use data_species
use data_stand
if (allocated(site_name))deallocate(site_name)
if (allocated(climfile))deallocate(climfile);
if (allocated(sitefile))deallocate(sitefile)
if (allocated(valfile))deallocate(valfile)
if (allocated(treefile))deallocate(treefile)
if (allocated(wpmfile))deallocate(wpmfile)
if (allocated(depofile))deallocate(depofile)
if (allocated(redfile))deallocate(redfile)
if (allocated(litfile))deallocate(litfile)
if (allocated(standid))deallocate(standid)
IF(ALLOCATED(thick)) CALL dealloc_soil
if(flag_multi .eq. 1 .or. flag_multi .ge. 3) then
if ( allocated(sitenum))deallocate(sitenum)
if ( allocated(clim_id))deallocate(clim_id)
if ( allocated(soilid))deallocate(soilid)
if ( allocated(gwtable))deallocate(gwtable)
if ( allocated(NOdep))deallocate(NOdep)
if ( allocated(NHdep))deallocate(NHdep)
endif
if(allocated(diam_class)) deallocate(diam_class)
if(allocated(diam_class_t)) deallocate(diam_class_t)
if(allocated(diam_class_h)) deallocate(diam_class_h)
if(allocated(diam_classm)) deallocate(diam_classm)
if(allocated(diam_classm_h)) deallocate(diam_classm_h)
if(allocated(height_class)) deallocate(height_class)
if (allocated(NHd))deallocate(NHd)
if (allocated(NOd))deallocate(NOd)
if(allocated(recs))then
deallocate(recs)
deallocate(dd);deallocate(mm);deallocate(yy)
deallocate(tp);deallocate(hm);deallocate(prc);deallocate(prs)
deallocate(rd)
if (allocated(tempfield))deallocate(tempfield)
if (allocated(globfield))deallocate(globfield)
if (allocated(dayfield))deallocate(dayfield)
endif
if(time_out .ne. -2) then
close(unit_comp1)
close(unit_comp2)
endif
if (flag_stat .gt. 0) then
close(unit_cons)
close(unit_mess)
close(unit_stat)
endif
if (flag_multi .gt.8) close (output_unit_all)
if (flag_multi .eq. 2) close(unit_ctr)
if(flag_multi.eq.7) deallocate(fl_co2)
if(flag_multi .eq. 4 .or. flag_mult8910) then
if (allocated(output_var))deallocate(output_var)
if (allocated(output_varm))deallocate(output_varm)
if (allocated(output_varw))deallocate(output_varw)
if (allocated(climszenres))deallocate(climszenres)
if (allocated(climszenyear))deallocate(climszenyear)
if (allocated(climszenmon))deallocate(climszenmon)
if (allocated(climszenweek))deallocate(climszenweek)
endif
if ((ip .eq. 1 .or. flag_multi .eq. 1 .or. flag_multi .eq. 6) .and. (time_out .ne. -2) ) close(unit_err)
end subroutine finish_all
!-----------------------------------------
SUBROUTINE dealloc_soil
use data_soil
use data_soil_cn
use data_soil_t
use data_simul
implicit none
if (allocated(thick)) deallocate(thick)
if (allocated(mid)) deallocate(mid)
if (allocated(depth)) deallocate(depth)
if (allocated(pv)) deallocate(pv)
if (allocated(pv_v)) deallocate(pv_v)
if (allocated(dens)) deallocate(dens)
if (allocated(f_cap_v)) deallocate(f_cap_v)
if (allocated(wilt_p_v)) deallocate(wilt_p_v)
if (allocated(field_cap)) deallocate(field_cap)
if (allocated(wilt_p)) deallocate(wilt_p)
if (allocated(vol)) deallocate(vol)
if (allocated(quarzv)) deallocate(quarzv)
if (allocated(sandv)) deallocate(sandv)
if (allocated(clayv)) deallocate(clayv)
if (allocated(siltv)) deallocate(siltv)
if (allocated(humusv)) deallocate(humusv)
if (allocated(dmass)) deallocate(dmass)
if (allocated(fcaph)) deallocate(fcaph)
if (allocated(wiltph)) deallocate(wiltph)
if (allocated(pvh)) deallocate(pvh)
if (allocated(skelv)) deallocate(skelv)
if (allocated(skelfact)) deallocate(skelfact)
if (allocated(spheat)) deallocate(spheat)
if (allocated(phv)) deallocate(phv)
if (allocated(wlam)) deallocate(wlam)
if (allocated(wats)) deallocate(wats)
if (allocated(watvol)) deallocate(watvol)
if (allocated(wat_res)) deallocate(wat_res)
if (allocated(perc)) deallocate(perc)
if (allocated(wupt_r)) deallocate(wupt_r)
if (allocated(wupt_ev)) deallocate(wupt_ev)
if (allocated(s_drought)) deallocate(s_drought)
if (allocated(root_fr)) deallocate(root_fr)
if (allocated(temps)) deallocate(temps)
if (allocated(BDopt)) deallocate(BDopt)
if (allocated(fr_loss)) deallocate(fr_loss)
if (allocated(redis)) deallocate(redis)
if (allocated(C_opm)) deallocate(C_opm)
if (allocated(C_hum)) deallocate(C_hum)
if (allocated(C_opmfrt)) deallocate(C_opmfrt)
if (allocated(C_opmcrt)) deallocate(C_opmcrt)
if (allocated(N_opm)) deallocate(N_opm)
if (allocated(N_hum)) deallocate(N_hum)
if (allocated(N_opmfrt)) deallocate(N_opmfrt)
if (allocated(N_opmcrt)) deallocate(N_opmcrt)
if (allocated(NH4)) deallocate(NH4)
if (allocated(NO3)) deallocate(NO3)
if (allocated(Nupt)) deallocate(Nupt)
if (allocated(Nmin)) deallocate(Nmin)
if (allocated(rmin_phv)) deallocate(rmin_phv)
if (allocated(rnit_phv)) deallocate(rnit_phv)
if (allocated(cnv_opm)) deallocate(cnv_opm)
if (allocated(cnv_hum)) deallocate(cnv_hum)
if (allocated(slit)) deallocate(slit)
if (allocated(slit_1)) deallocate(slit_1)
if (allocated(sh)) deallocate(sh)
if (allocated(sv)) deallocate(sv)
if (allocated(sb)) deallocate(sb)
if (allocated(sbt)) deallocate(sbt)
if (allocated(t_cond)) deallocate(t_cond)
if (allocated(t_cb)) deallocate(t_cb)
if (allocated(h_cap)) deallocate(h_cap)
if (allocated(sxx)) deallocate(sxx)
if (allocated(svv)) deallocate(svv)
if (allocated(svva)) deallocate(svva)
if (allocated(soh)) deallocate(soh)
if (allocated(son)) deallocate(son)
if (allocated(wat_root)) deallocate(wat_root)
if (allocated(root_lay)) deallocate(root_lay)
if (allocated(gr_depth)) deallocate(gr_depth)
if (allocated(xwatupt)) deallocate (xwatupt)
if (allocated(xNupt)) deallocate (xNupt)
if (allocated(wat_left)) deallocate (wat_left)
end subroutine dealloc_soil
!-----------------------------------------------------------------
source_code/version_2.3_windows/gasdev.f 0 → 100644
View file @ 82df1085
!*****************************************************************!
!* *!
!* 4C (FORESEE) Simulation Model *!
!* *!
!* *!
!* Subroutines for: *!
!* *!
!* random number generator: normal distribution *!
!* SR gasdev (from numerucal recipes) *!
!* SR ran1 ( --"--) *!
!* *!
!* Copyright (C) 1996-2018 *!
!* Potsdam Institute for Climate Impact Reserach (PIK) *!
!* Authors and contributors see AUTHOR file *!
!* This file is part of 4C and is licensed under BSD-2-Clause *!
!* See LICENSE file or under: *!
!* http://www.https://opensource.org/licenses/BSD-2-Clause *!
!* Contact: *!
!* https://gitlab.pik-potsdam.de/foresee/4C *!
!* *!
!*****************************************************************!
FUNCTION gasdev(idum)
INTEGER idum
REAL gasdev, ran1
INTEGER iset
REAL fac,gset,rsq,v1,v2
SAVE iset,gset
DATA iset/0/
if (iset.eq.0) then
1 v1=2.*ran1(idum)-1.
v2=2.*ran1(idum)-1.
rsq=v1**2+v2**2
if(rsq.ge.1..or.rsq.eq.0.)goto 1
fac=sqrt(-2.*log(rsq)/rsq)
gset=v1*fac
gasdev=v2*fac
iset=1
else
gasdev=gset
iset=0
endif
return
END
FUNCTION ran1(idum)
INTEGER idum,IA,IM,IQ,IR,NTAB,NDIV
REAL ran1,AM,EPS,RNMX
PARAMETER (IA=16807,IM=2147483647,AM=1./IM,IQ=127773,IR=2836, &
NTAB=32,NDIV=1+(IM-1)/NTAB,EPS=1.2e-7,RNMX=1.-EPS)
INTEGER j,k,iv(NTAB),iy
SAVE iv,iy
DATA iv /NTAB*0/, iy /0/
if (idum.le.0.or.iy.eq.0) then
idum=max(-idum,1)
do 11 j=NTAB+8,1,-1
k=idum/IQ
idum=IA*(idum-k*IQ)-IR*k
if (idum.lt.0) idum=idum+IM
if (j.le.NTAB) iv(j)=idum
11 continue
iy=iv(1)
endif
k=idum/IQ
idum=IA*(idum-k*IQ)-IR*k
if (idum.lt.0) idum=idum+IM
j=1+iy/NDIV
iy=iv(j)
iv(j)=idum
ran1=min(AM*iy,RNMX)
return
END
source_code/version_2.3_windows/gen_one_coh.f 0 → 100644
View file @ 82df1085
!*****************************************************************!
!* *!
!* 4C (FORESEE) *!
!* *!
!* SR gen_one_coh for: *!
!* planting of small trees given by *.pla *!
!* used in prep_stand *!
!* SR is called by flag_reg=20 *!
!* *!
!* Copyright (C) 1996-2018 *!
!* Potsdam Institute for Climate Impact Reserach (PIK) *!
!* Authors and contributors see AUTHOR file *!
!* This file is part of 4C and is licensed under BSD-2-Clause *!
!* See LICENSE file or under: *!
!* http://www.https://opensource.org/licenses/BSD-2-Clause *!
!* Contact: *!
!* https://gitlab.pik-potsdam.de/foresee/4C *!
!* *!
!*****************************************************************!
SUBROUTINE gen_one_coh(taxid,age,pl_height,nplant)
USE data_stand
USE data_simul
USE data_species
USE data_soil
USE data_help
USE data_plant
USE data_manag
IMPLICIT NONE
integer :: nplant, &
taxid, &
j,nr
real :: age, &
pl_height, &
hhelp,x1,x2,xacc,shelp
real :: rtflsp, sapwood
real :: troot2
TYPE(cohort) ::tree_ini
external sapwood
external rtflsp
call coh_initial (tree_ini)
max_coh = max_coh + 1
tree_ini%ident = max_coh
tree_ini%species = taxid
tree_ini%ntreea = nplant
tree_ini%nta = tree_ini%ntreea
tree_ini%x_age = age
tree_ini%height = pl_height
hhelp = tree_ini%height
IF (taxid.ne.2) tree_ini%x_sap = exp(( LOG(hhelp)-LOG(spar(taxid)%pheight1))/spar(taxid)%pheight2)/1000000.
IF (taxid.eq.2) THEN
x1 = 1.
x2 = 2.
xacc=(1.0e-10)*(x1+x2)/2
! solve equation for calculation of sapwood from height; determine root
heihelp = tree_ini%height
shelp=rtflsp(sapwood,x1,x2,xacc)
tree_ini%x_sap = (10**shelp)/1000000 ! transformation mg ---> kg
ENDIF
! leaf matter
tree_ini%x_fol = (spar(taxid)%seeda*(tree_ini%x_sap** spar(taxid)%seedb)) ![kg]
! fine root matter rough estimate
tree_ini%x_frt = tree_ini%x_fol
! cross sectional area of heartwood
tree_ini%x_crt = tree_ini%x_sap * spar(tree_ini%species)%alphac*spar(tree_ini%species)%cr_frac
tree_ini%x_tb = tree_ini%x_sap * spar(tree_ini%species)%alphac*(1.-spar(tree_ini%species)%cr_frac)
tree_ini%med_sla = spar(taxid)%psla_min + spar(taxid)%psla_a*0.5
tree_ini%t_leaf = tree_ini%med_sla* tree_ini%x_fol ! [m-2]
tree_ini%ca_ini = tree_ini%t_leaf
! initialize pheno state variables
IF(spar(tree_ini%species)%Phmodel==1) THEN
tree_ini%P=0
tree_ini%I=1
ELSE
tree_ini%P=0
tree_ini%I=0
tree_ini%Tcrit=0
END IF
IF(nplant.ne.0.) then
IF (.not. associated(pt%first)) THEN
ALLOCATE (pt%first)
pt%first%coh = tree_ini
NULLIFY(pt%first%next)
! root distribution
call root_depth (1, pt%first%coh%species, pt%first%coh%x_age, pt%first%coh%height, pt%first%coh%x_frt, pt%first%coh%x_crt, nr, troot2, pt%first%coh%x_rdpt, pt%first%coh%nroot)
pt%first%coh%nroot = nr
do j=1,nr
pt%first%coh%rooteff = 1. ! assumption for the first use
enddo
do j=nr+1, nlay
pt%first%coh%rooteff = 0. ! layers with no roots
enddo
ELSE
ALLOCATE(zeig)
zeig%coh = tree_ini
zeig%next => pt%first
pt%first => zeig
! root distribution
call root_depth (1, zeig%coh%species, zeig%coh%x_age, zeig%coh%height, zeig%coh%x_frt, zeig%coh%x_crt, nr, troot2, zeig%coh%x_rdpt, zeig%coh%nroot)
zeig%coh%nroot = nr
do j=1,nr
zeig%coh%rooteff = 1. ! assumption for the first use
enddo
do j=nr+1, nlay
zeig%coh%rooteff = 0. ! layers with no roots
enddo
END IF
anz_coh=anz_coh+1
END IF
END SUBROUTINE gen_one_coh
source_code/version_2.3_windows/getopenfilename.f90 0 → 100644
View file @ 82df1085
!*****************************************************************!
!* *!
!* 4C (FORESEE) Simulation Model *!
!* *!
!* *!
!* Subroutines for: *!
!* - windows shell - *!
!* *!
!* contains: *!
!* FileOpen *!
!* *!
!* Copyright (C) 1996-2018 *!
!* Potsdam Institute for Climate Impact Reserach (PIK) *!
!* Authors and contributors see AUTHOR file *!
!* This file is part of 4C and is licensed under BSD-2-Clause *!
!* See LICENSE file or under: *!
!* http://www.https://opensource.org/licenses/BSD-2-Clause *!
!* Contact: *!
!* https://gitlab.pik-potsdam.de/XXXXXXXXXXXXXXXXXXXXX *!
!* *!
!*****************************************************************!
Subroutine FileOpen (file_spec, filter_spec)
! Following example of calling the Win32 API routine GetOpenFileName
use comdlg32
!use dflib ! In case QuickWin is used
implicit none
! Declare structure used to pass and receive attributes
!
type(T_OPENFILENAME) ofn
! Declare filter specification. This is a concatenation of
! pairs of null-terminated strings. The first string in each pair
! is the file type name, the second is a semicolon-separated list
! of file types for the given name. The list ends with a trailing
! null-terminated empty string.
!
character*(*) :: filter_spec
! Declare string variable to return the file specification.
! Initialize with an initial filespec, if any - null string
! otherwise
character*512 :: file_spec
integer status,ilen
ofn%lStructSize = SIZEOF(ofn)
ofn%hwndOwner = NULL ! For non-console applications,
! set this to the Hwnd of the
! Owner window. For QuickWin
! and Standard Graphics projects,
! use GETHWNDQQ(QWIN$FRAMEWINDOW)
!
ofn%hInstance = NULL ! For Win32 applications, you
! can set this to the appropriate
! hInstance
!
ofn%lpstrFilter = loc(filter_spec)
ofn%lpstrCustomFilter = NULL
ofn%nMaxCustFilter = 0
ofn%nFilterIndex = 1 ! Specifies initial filter value
ofn%lpstrFile = loc(file_spec)
ofn%nMaxFile = sizeof(file_spec)
ofn%nMaxFileTitle = 0
ofn%lpstrInitialDir = NULL ! Use Windows default directory
ofn%lpstrTitle = loc(""C)
ofn%Flags = OFN_PATHMUSTEXIST
ofn%lpstrDefExt = loc("txt"C)
ofn%lpfnHook = NULL
ofn%lpTemplateName = NULL
! Call GetOpenFileName and check status
do
status = GetOpenFileName(ofn)
if (status .eq. 0) then
write(*,'(A)',advance='no') ' No file name specified'
write(*,'(A)',advance='no') ' Program aborted'
PAUSE
STOP
else
! Get length of file_spec by looking for trailing NUL
ilen = INDEX(file_spec,CHAR(0))
exit
end if
enddo
end Subroutine fileopen
source_code/version_2.3_windows/gr_seed_week.f 0 → 100644
View file @ 82df1085
!*****************************************************************!
!* *!
!* 4C (FORESEE) *!
!* *!
!* *!
!* growth_seed_week - Growth of seedling cohorts weekly *!
!* Allocation with weekly NPP *!
!* *!
!* Copyright (C) 1996-2018 *!
!* Potsdam Institute for Climate Impact Reserach (PIK) *!
!* Authors and contributors see AUTHOR file *!
!* This file is part of 4C and is licensed under BSD-2-Clause *!
!* See LICENSE file or under: *!
!* http://www.https://opensource.org/licenses/BSD-2-Clause *!
!* Contact: *!
!* https://gitlab.pik-potsdam.de/foresee/4C *!
!* *!
!*****************************************************************!
SUBROUTINE growth_seed_week (jx)
USE data_stand
USE data_species
USE data_simul
IMPLICIT NONE
REAL :: lambdaf = 0., & ! partitioning coefficients
lambdas = 0., &
lambdar = 0., &
NPP = 0., & ! NPP available for allocation
F = 0., & ! state variables: foliage,
S = 0., & ! shoot biomass,
R = 0., & ! fine roots,
H = 0., & ! total tree height
FNew, SNew, & ! new state variables
RNew, &
sigmaf = 0., & ! current leaf activity rate
ar = 0.
REAL :: Gf, & ! growth rates
Gs, &
Gr
REAL :: pab,helpdr
INTEGER :: jx
TYPE(coh_obj), POINTER :: p
p=>pt%first
DO
IF(.not.associated(p)) exit
IF( p%coh%fl_sap.eq.0) then
ns = p%coh%species
F = p%coh%x_fol
S = p%coh%x_sap
R = p%coh%x_frt
NPP = p%coh%weekNPP ! [kg]
H = p%coh%height
! only allocate if enough NPP is available and day < a fixed limit
IF (NPP>1.0E-9 .and. iday<190) THEN
p%coh%NPPpool = p%coh%NPPpool + NPP
! calculate leaf activity based on net PS and leaf mass
sigmaf = NPP/F
! calculate root activity based on drought index
helpdr= p%coh%drIndPS
! auxiliary variables for fine roots
ar = 1./helpdr
if(helpdr.lt.0.001) ar = 1.
! calculate coefficients for roots and foliage and shoot
pab = spar(ns)%seeda*spar(ns)%seedb*S**(spar(ns)%seedb-1)
! new model without senescence within the year:
lambdas=1./(1.+pab+pab*ar)
lambdaf=(1.-lambdas)/(1.+ar)
lambdar=1.-lambdas-lambdaf
IF (lambdas.lt.0.) THEN
lambdas = 0.
lambdaf = 1./(ar+1.)
lambdar = 1.-lambdaf
END IF
IF (lambdar<0) THEN
lambdar=0.
lambdas=0.
lambdaf=1.
END IF
IF (lambdaf<0) THEN
lambdar=0.
lambdas=0.
lambdaf=1.
END IF
ELSE
lambdaf = 0.
lambdas = 0.
lambdar = 0.
END IF
Gf = lambdaf*NPP
Gr = lambdar*NPP
Gs = lambdas*NPP
p%coh%gfol = Gf
p%coh%gfrt = Gr
p%coh%gsap = Gs
! update of state vector
FNew = F + Gf
SNew = S + Gs
RNew = R + Gr
p%coh%x_fol = FNew
p%coh%x_sap = SNew
p%coh%x_frt = RNew
p%coh%fol_inc_old = p%coh%fol_inc
p%coh%fol_inc = Gf
p%coh%stem_inc = Gs
! update height and shoot base diameter (regression functions from Schall 1998)
IF(ns.ne.2) p%coh%height = spar(ns)%pheight1* (snew*1000000.) **spar(ns)%pheight2
IF(ns.eq.2) p%coh%height = 10**(spar(ns)%pheight1+ spar(ns)%pheight2*LOG10(snew*1000000.)+ &
spar(ns)%pheight3*(LOG10(snew*1000000.))**2)
p%coh%height_ini = p%coh%height
! update foliage area, parameter med_sla
SELECT CASE (flag_light)
CASE (1:2)
p%coh%med_sla = spar(ns)%psla_min + spar(ns)%psla_a*(1.- vstruct(lowest_layer)%irel)
CASE(3,4)
p%coh%med_sla = spar(ns)%psla_min + spar(ns)%psla_a*(1.-irelpool(lowest_layer))!
END SELECT
! total leaf area of a tree in this cohort [m**2]as as crown area
p%coh%ca_ini = p%coh%med_sla * p%coh%x_fol
! weekNPP equal zero for next calculation
p%coh%weekNPP = 0.
END IF
p=> p%next
END DO
END SUBROUTINE growth_seed_week
\ No newline at end of file
source_code/version_2.3_windows/initia.f 0 → 100644
View file @ 82df1085
!*****************************************************************!
!* *!
!* 4C (FORESEE) Simulation Model *!
!* *!
!* *!
!* Subroutines for: *!
!* - Initialisation of cohorts = *!
!* reads cohort information and calculates missing values *!
!* which are needed for stand initialisation *!
!* initia *!
!* treeini *!
!* sapini *!
!* header *!
!* crown_base *!
!* crown_base_eg *!
!* fdfahc: function *!
!* ini_gener_sap *!
!* NEWTON: function numerical recipes *!
!* *!
!* Copyright (C) 1996-2018 *!
!* Potsdam Institute for Climate Impact Reserach (PIK) *!
!* Authors and contributors see AUTHOR file *!
!* This file is part of 4C and is licensed under BSD-2-Clause *!
!* See LICENSE file or under: *!
!* http://www.https://opensource.org/licenses/BSD-2-Clause *!
!* Contact: *!
!* https://gitlab.pik-potsdam.de/foresee/4C *!
!* *!
!*****************************************************************!
!***********************!
! SUBROUTINE INITIA !
!***********************!
SUBROUTINE INITIA
! begin declaration section
USE data_init
USE data_par
USE data_simul
USE data_species
USE data_stand
use data_help
IMPLICIT none
REAL :: area !area of database in m^2 (10000=1ha)
INTEGER :: area_factor !factor for calculation per patch (=area/kpatchsize)
REAL :: hlp_lai,share, ager
INTEGER :: taxid, & ! species number
age, & ! tree age
n, & ! number of trees
n_koh, & !
k, & ! number of tree classes
ng_locid ! ID stand
INTEGER :: inunit, parunit,outunit,tmpunit,ctrlunit,listunit !units
CHARACTER*85 zeile
CHARACTER*80 :: infile
CHARACTER :: source
INTEGER :: nlines, nlines_comp, istart, fl_num, nhelp, numstand, ihelp
INTEGER :: tax_of_BRA_id
INTEGER,DIMENSION(:),ALLOCATABLE :: locid_comp
REAL rsap, cform, dummy
REAL aux
LOGICAL :: select_lines
real standsz(10000)
CHARACTER*40, allocatable, dimension(:) ::helptmp
INTEGER :: helpz
! Stand data (model initialisation)
INTEGER baum(10),alt(10),klimid,gwa,lbanr,wgeb,lein,zei
REAL mhoe(10),dm(10),gf(10),bon(10),en(10),psi(10)
! Parameters for missing data algorithms
REAL p0(nspec_tree),p1(nspec_tree),p2(nspec_tree),p3(nspec_tree),p4(nspec_tree), &
c1(nspec_tree),c2(nspec_tree),ku_a0(nspec_tree),ku_a1(nspec_tree),ku_a2(nspec_tree),&
ku_b0(nspec_tree),ku_b1(nspec_tree),ku_b2(nspec_tree),ku_c0(nspec_tree),&
ku_c1(nspec_tree),ku_c2(nspec_tree),wei_k1(nspec_tree),wei_k2(nspec_tree)
! ------------------------------------------------------------------
! INTEGER ncl !Number of classes after classification
integer ncl1
REAL dg,dmin,dmax,g,gpatch,b,c,bhd,height,hbc,hg
REAL tot_crown_area, mixed_tot_ca, corr_la
INTEGER pass
REAL saquad, genDg, nbhd,x,gx,bhdmax,bhdmin,clwdth,Fint(0:100)
REAL ku_a,ku_b,ku_c,wei_f,thdmax,p1n,p4n
REAL, allocatable, dimension(:) :: nz
REAL, allocatable, dimension(:) :: zheigh,zbhd,zhbc
REAL xxr,xyr, &
kd, &
h_para,h_parb !parameter of the height function of level II sites
INTEGER idum,anzahl, data_flag,start,baumid,dir_flag,inwahl,bz,imax
INTEGER i,j,anzit,iz,id,icl,ios,xid,xnr,xxi,xyi, &
bhdcl, & !diameter classes level II
dclmin, & !smallest diameter class level II
ndcl, & !amount of diameter classes of level II
dcwdth, & !class wideness diameter classes of level II
n_dc(30) !stem figure of level II diameter class
LOGICAL ehkwei, wfirst, kfirst, optimi
LOGICAL, allocatable, dimension(:) :: smaldc, bigdc
CHARACTER*20 fnam2
CHARACTER*5 datasets
CHARACTER status
real nzsum
! ------------------------------------------------------------------
! ----Function----
REAL ran0
REAL crown_base
real crown_base_eg
! ------------------------------------------------------------------
REAL T
DATA T/7.0/
! ------------------------------------------------------------------
!
! end of declaration section
!******************************************************************************
!ncl1 = 60
ncl1=40
allocate (zheigh(ncl1), zbhd(ncl1), zhbc(ncl1), nz(ncl1))
allocate (smaldc(ncl1), bigdc(ncl1))
print *,' '
print *, ' *** Choice of forest stand data set: '
print *, ' 1 - Datenspeicher Waldfond'
print *, ' 2 - single tree data; classification must be performed (e.g. SILVA data)'
print *, ' 3 - Level2-data'
print *, ' 4 - already existing class file'
print *, ' 5 - FORGRA data'
print *, ' 6 - Bavarian inventory data'
WRITE(*,'(A)',advance='no') ' ***Make your choice: '
READ *, data_flag
print *,' '
clwdth=15 !set diameter class-class width
corr_la=1. !standard value for leaf area correction in stands of high sum of crown projection areas
mixed_tot_ca=0. !sum of crown projection area for mixed stands
pass = 1 !counter for number of passes through calculation loop for mixed stands
rsap=0.3 !standard value of rsap for cases where rsap is not determined dynamically
! get unit number and open units used in all of the above cases
ctrlunit=GETUNIT()
WRITE(*,*)site_name(ip)
OPEN (ctrlunit,FILE=TRIM(site_name(ip))//'.initctrl',STATUS='replace')
WRITE(ctrlunit,*)'# number of trees in cohort = n trees'
WRITE(ctrlunit,*)'# age = age'
WRITE(ctrlunit,*)'# height = H'
WRITE(ctrlunit,*)'# height to the base of crown = Hbc'
WRITE(ctrlunit,*)'# breast height diameter = bhd'
WRITE(ctrlunit,*)'# sapwood fraction of trunc cross sectional area at breast height = rsap'
WRITE(ctrlunit,*)'# trunc diameter at tree base = D'
WRITE(ctrlunit,*)'# trunc diameter at crown base = Dc'
WRITE(ctrlunit,*)'# sapwood cross sectional area inside bole = Asap'
WRITE(ctrlunit,*)'# heartwood cross sectional area at crown base = Ahc'
WRITE(ctrlunit,*)'# heartwood cross sectional area at tree base = Ahb'
WRITE(ctrlunit,*)'# Vol for no heartwood in crown space = Vmin'
WRITE(ctrlunit,*)'# Vol prescribed according to empiracal volume function = Vpre'
WRITE(ctrlunit,*)'# stem vol inherent in initialisation = Veff'
WRITE(ctrlunit,'(A150)')'# n trees age H Hbc bhd rsap D Dc Asap Ahc Ahb Vmin Vpre Veff'
outunit=GETUNIT()
OPEN (outunit,FILE=TRIM(treefile(ip)),STATUS='replace')
! ------------------------------------------------------------------
! read in parameter for the missing-data-generator:
! bhd-distribution from Nagel & Biging (1995),
! crown starting height from Nagel (1995), uni-height curve according to Weimann (1980) bzw. Kuleschis (1981)
parunit=GETUNIT()
OPEN (parunit, FILE='input/generreg.par', STATUS='old')
do i=1,nspec_tree
READ (parunit,*) p0(i),p1(i),p2(i),p3(i),p4(i),c1(i),c2(i),ku_a0(i),ku_a1(i),ku_a2(i), &
ku_b0(i),ku_b1(i),ku_b2(i),ku_c0(i),ku_c1(i),ku_c2(i),wei_k1(i),wei_k2(i)
ENDDO
CLOSE(parunit)
! ---------------------------------------------------------------------
inunit=GETUNIT()
SELECT CASE(data_flag)
! ****************************************************************************
! case(1) stand generation if data source is Datenspeicher Waldfond
CASE(1)
print *, ' Forest stand data set: Datenspeicher Waldfond'
! preliminary: here make a choice and compile
! datasets='singl' sets the choice of the old version which uses one single
! set (i.e. the first one in an input file) which contains
! the complete imformation for the stand in one single line
! datasets='multi' sets the choice of a version reading a file with line by
! line information as in the original Datenspeicher and then
! writes a *.ini file for many stands with individual stand
! information separated by lines with stand identifiers
print*, 'choose data set (multi/singl):'
read(*,*) datasets
print*, ' file name (with directory):'
read(*,'(A)') infile
source='D'
standsz = 0.
OPEN (inunit, FILE=TRIM(infile), STATUS='old')
! ------------------------------------------------------------------
! generating standard value out of data from the data storage unit
! based on estimation routine from Nagel und Biging (1995),
! Nagel (1995) und Gerold (1990).
! ------------------------------------------------------------------
!
! The following variables are read from forest inventory data:
! Species(baum),Age(alt),Quadratic Mean Diameter(dm),Height of tree with dm(mhoe),
! Basal area(gf),Yield Class(bon),"Ertragsniveau"(en)
! Additional Site variables:
! Climate station(klimid),distance of groundwater table(gwa),soil type(lbanr),
! forest region 'Wuchsgebiet'(wgeb),last management operation(lein), number of tree layers(zei)
! currently not used for initialisation: xid, klimid, gwa, lbanr, wgeb, lein, bon(i), en(i)
! lbanr (check difference to declaration!),
! check if alt and baum can be skipped as variable names and age and species directly used
! check idendity of hg and mhoe, dg and dm, gf and g
! ------------------------------------------------------------------
! input of data from a dataset, first row
IF (datasets=='singl') THEN
READ (inunit,*)xid,klimid,lbanr,gwa,wgeb,lein, &
zei,(baum(i), alt(i),mhoe(i),dm(i),gf(i),bon(i),en(i),i=1,zei)
ALLOCATE(ngroups(zei))
DO i=1,zei
IF(baum(i).EQ.8) ngroups(i)%taxid=1
IF(baum(i).EQ.10) ngroups(i)%taxid=2
IF(baum(i).EQ.11) ngroups(i)%taxid=3
IF(baum(i).EQ.15) ngroups(i)%taxid=4
if(baum(i).eq.12) ngroups(i)%taxid = 10
! Eucalyptus
IF(baum(i).EQ.30) ngroups(i)%taxid=12
IF(baum(i).EQ.31) ngroups(i)%taxid=13
IF (dm(i).eq.0) dm(i) = 0.5
IF (mhoe(i).eq.0) mhoe(i) = 1.0
IF (gf(i).eq.0) gf(i) = 0.25
ngroups(i)%locid=xid
ngroups(i)%alter=alt(i)
ngroups(i)%mhoe=mhoe(i)
ngroups(i)%gf=gf(i)
ngroups(i)%dm=dm(i)
ngroups(i)%patchsize=10000
ENDDO
CLOSE(inunit)
nlines=zei
cform=1;hlp_lai=0
! Initialisastion of stand data: area = 1ha
area=10000
area_factor=int(area/kpatchsize)
! read file head for description, write in ini-file
CALL header(outunit,infile,source,cform,rsap,flag_volfunc,kpatchsize)
ENDIF !block for reading of input data DSW 'singl' = specially prepared for FORSKA
! read in stand dataEinlesen out of data storage for many stands
IF (datasets=='multi') THEN
select_lines=.false.
fl_num=0
ALLOCATE(ngroups(10000))
numstand= 0
nlines=1
ngroups%taxid=0
ngroups%schicht=-99
DO
READ (inunit,*,END=3333)xid,klimid,lbanr,gwa,wgeb,lein, &
zei,(baum(i),alt(i), psi(i), mhoe(i),dm(i),gf(i),bon(i),en(i),i=1,zei)
numstand = numstand +1
ngroups(nlines)%standsize= 0
DO i=1,zei
IF(baum(i).EQ.5) ngroups(nlines)%taxid=5
IF(baum(i).EQ.8) ngroups(nlines)%taxid=1
IF(baum(i).EQ.10) ngroups(nlines)%taxid=2
IF(baum(i).EQ.11) ngroups(nlines)%taxid=3
IF(baum(i).EQ.15) ngroups(nlines)%taxid=4
! the following species are preliminarily assigned
IF(baum(i).EQ.1) ngroups(nlines)%taxid=2 ! Abies alba
IF(baum(i).EQ.2) ngroups(nlines)%taxid=1 ! Acer platanoides
IF(baum(i).EQ.3) ngroups(nlines)%taxid=1 ! Acer pseudoplatanus
IF(baum(i).EQ.4) ngroups(nlines)%taxid=5 ! Alnus glutinosa
IF(baum(i).EQ.6) ngroups(nlines)%taxid=1 ! Carpinus betulus
IF(baum(i).EQ.7) ngroups(nlines)%taxid=4 ! Castanea sativa
IF(baum(i).EQ.9) ngroups(nlines)%taxid=4 ! Fraxinus excelsior
IF(baum(i).EQ.12) ngroups(nlines)%taxid=5 ! Populus tremula
IF(baum(i).EQ.13) ngroups(nlines)%taxid=4 ! Quercus petraea
IF(baum(i).EQ.14) ngroups(nlines)%taxid=4 ! Quercus pubescencs
IF(baum(i).EQ.16) ngroups(nlines)%taxid=1 ! Tilia cordata
IF(baum(i).EQ.17) ngroups(nlines)%taxid=4 ! Ulmus glabra
iF(baum(i).EQ.21) ngroups(nlines)%taxid=10 ! Douglasie
iF(baum(i).EQ.22) ngroups(nlines)%taxid=6 ! Larix
iF(baum(i).EQ.23) ngroups(nlines)%taxid=7 ! Pinus strobus
iF(baum(i).EQ.24) ngroups(nlines)%taxid=10 ! Douglasie
IF (dm(i).eq.0) dm(i) = 0.5
IF (mhoe(i).eq.0) mhoe(i) = 1.0
IF (gf(i).eq.0) gf(i) = 0.25
ngroups(nlines)%locid=xid
ngroups(nlines)%alter=alt(i)
ngroups(nlines)%mhoe=mhoe(i)
ngroups(nlines)%gf=gf(i)
ngroups(nlines)%dm=dm(i)
ngroups(nlines)%patchsize=psi(i)*10000
ngroups(nlines)%standsize=psi(i)*10000
nlines=nlines+1
standsz(numstand) = standsz(numstand) + psi(i)*10000
ENDDO
ENDDO ! read loop
3333 CONTINUE
nlines=nlines-1
WRITE(*,*) nlines,'sets of data', numstand, 'sets of stands'
CLOSE(inunit)
! read in file headder for description, write into ini-file
cform=1;hlp_lai=0
! initilisation for stand data: area = stand area based on fractions of areas
area_factor=1
CALL header(outunit,infile,source,cform,rsap,flag_volfunc,-99.)
WRITE(*,*) 'number of data lines: ', nlines
write(*,*)'number of plots for calculations: ', fl_num
ENDIF ! block for reading input data DSW, many lines = 'multi'
id=1
tmpunit=getunit()
ihelp = 1
istart=-99
DO iz=1,nlines
IF(select_lines) THEN
DO i=1,nlines_comp
IF(locid_comp(i)==ngroups(iz)%locid) GOTO 2233
ENDDO ! comparison of site id to list of sites to be selected
CYCLE
ENDIF ! end of site selection
2233 CONTINUE
WRITE(*,*) iz, nlines, ngroups(iz)%locid,ngroups(iz)%schicht
IF(datasets=='multi'.AND.(istart.NE.ngroups(iz)%locid)) THEN
WRITE(outunit,*) ngroups(iz)%locid,ngroups(iz)%standsize,'stand identifier, stand area'
ihelp = ihelp +1
istart=ngroups(iz)%locid
ENDIF
IF(datasets=='multi'.AND.ngroups(iz)%taxid==0.) THEN
WRITE(*,*) 'not the right species'
GOTO 2222
ENDIF
IF(datasets=='multi'.AND.ngroups(iz)%schicht==20) THEN
! retention trees
age=ngroups(iz)%alter
taxid=ngroups(iz)%taxid
height=ngroups(iz)%mhoe
bhd=ngroups(iz)%dm
n_koh=ngroups(iz)%baumzahl
hbc=crown_base(height,c1(taxid),c2(taxid),bhd)
CALL treeini(outunit,ctrlunit,taxid,source,bhd,height,hbc,n_koh,cform,rsap,age,hlp_lai,corr_la)
GOTO 2222
ENDIF ! end special treatment of retention trees
IF(datasets=='multi'.AND.ngroups(iz)%dm==0.) THEN
WRITE(4444,*)'data insufficient for: ',ngroups(iz)%locid,' line: ',iz
GOTO 2222
ENDIF
IF(datasets=='multi'.AND.ngroups(iz)%mhoe<h_sapini*0.01 .or. ngroups(iz)%gf.eq.0.) THEN
aux = ngroups(iz)%standsize/10000.
height=ngroups(iz)%mhoe
n_koh=ngroups(iz)%baumzahl* aux
age=ngroups(iz)%alter
taxid = ngroups(iz)%taxid
WRITE(4444,*)'sapling init needed for: ',ng_locid,' line: ',iz
call ini_gener_sap(outunit, taxid,age,height,n_koh)
GOTO 2222
ENDIF
optimi=.false.
anzahl= 0;start=1
allocate(helptmp(10000000))
helptmp = ' '
! generation of single trees out of population mean values
DO
helptmp = ' '
IF((start==1).or.(.not.optimi))THEN
T =7
anzahl=0
start=0
wfirst=.true.
kfirst=.true.
WRITE(*,*)ngroups(iz)%locid,ngroups(iz)%patchsize
age=ngroups(iz)%alter
dg=ngroups(iz)%dm !quadratic mean diameter
hg=ngroups(iz)%mhoe !corresponding height to dg
taxid=ngroups(iz)%taxid !species
g=ngroups(iz)%gf !basal area/ha
gpatch=g/area_factor !basal area/patch
IF (datasets=='multi') gpatch=g*ngroups(iz)%standsize/10000.
! selection of uni-height curve: Beech, Spruce, Oak calculated according to Weimann,
! other species of tree according to Kuleschis (vergl. Gerold 1990)
IF (taxid==3.OR.taxid==5) THEN
ehkwei=.false.
ELSE
ehkwei=.true.
ENDIF
IF ((dg-T).lt. 3.0) THEN
T=dg-4.0
IF (T.lt.0.3) T=0.3
ENDIF
! Estimation of Dmax out of dg (Gerold 1990)
Dmax=8.2+1.8*dg-0.01*dg**2
IF (dg.le.2) Dmax=dg+2
! calculation for the Weibull-distribution function
! in case b or c are calcuted too small, p1 and p4 respectively have to be modified
p1n=p1(taxid)
IF (p1n.lt.((1.0001-p0(taxid))/Dg)) p1n=(1.0001-p0(taxid))/Dg
b=p0(taxid)+p1n*Dg
p4n=p4(taxid)
IF (p4n.lt.((1.0005-p2(taxid)-p3(taxid)*Dg)/Dmax)) p4n=(1.0005-p2(taxid)-p3(taxid)*Dg)/Dmax
c=p2(taxid)+p3(taxid)*Dg+p4n*Dmax
anzit=0
thdmax=5.0
ENDIF ! end of introductory calculation and repetitions without optimisation
genDg=0
nbhd=0
saquad=0
bhdmax=0
bhdmin=100
clwdth=0
gx=0
idum=1
x=0
!----------------------------
! generation of single trees
DO
IF (gx.gt.gpatch) exit
x = ran0(idum)
bhd=b*((T/b)**c-log(1.-x))**(1./c)
if ( bhd.ge. 0.5*Dg) then
IF (bhd.gt.bhdmax) bhdmax=bhd
IF (bhd.lt.bhdmin) bhdmin=bhd
IF ((.not. optimi) .and. (bhd.gt.(1.5*dmax))) bhd=1.5*dmax
!***height calculation according to uni-height curve
IF (ehkwei) THEN
! uni-height curve of Weimann (1980)
IF (wfirst) THEN
wei_f=wei_k1(taxid)+wei_k2(taxid)*hg
wfirst=.false.
ENDIF
IF (bhd.ge.(dg-hg/2.)) THEN
height=hg+wei_f*(log(hg-dg+bhd)-log(hg))
ELSE
height=(hg+wei_f*(log(hg/2.)-log(hg))-1.3)*(bhd/(dg-hg/2.))**0.5+1.3
ENDIF
ELSE
! uni-height curve of Kuleschis (1981)
IF (kfirst) THEN
ku_a=1-(ku_a0(taxid)+ku_a1(taxid)*dg+ku_a2(taxid)*dg**2)
ku_b=ku_b0(taxid)+ku_b1(taxid)*dg+ku_b2(taxid)*dg**2
ku_c=ku_c0(taxid)+ku_c1(taxid)*dg+ku_c2(taxid)*dg**2
kfirst=.false.
ENDIF
height=hg*(ku_a+(ku_b/(bhd+dg/2.))*dg+(ku_c/(bhd+dg/2.)**2)*dg**2)
ENDIF
if(taxid.eq.10) then
! height curve after Bwinpro Douglas fir
height = 1.3 +(hg-1.3)*exp(-(0.199651*dg+4.63277655)*((1/bhd) - (1/dg)))
end if
if(taxid.eq.12.or. taxid.eq.13) then
! Medhurst et al. 1999
height = 3.665629*bhd**0.541
end if
! solution for small stands; tree dimensions below 3 m = rubbish
IF (height.gt.(bhd*3.)) height=bhd*3.
IF (height.lt.1.35) height=1.35+bhd
if(taxid.eq.12.or. taxid.eq.13) then
! Eucalyptus
hbc = crown_base_eg(height, bhd)
else
hbc=crown_base(height,c1(taxid),c2(taxid),bhd)
end if
IF ((height-hbc).lt. 0.5) hbc= height - 0.5
write(helptmp(nbhd+1), '(3f7.1,2i7)') bhd,height,hbc,age,taxid
gx=gx+1E-4*pi*(bhd/2.)**2
nbhd=nbhd+1
anzahl=anzahl+1
saquad=saquad+bhd**2
end if ! BHD test
ENDDO ! single tree calculation
!---calculates the generated Dg and test deviations of Dg and Dmax of the population value.
! if deviation greater 20% a fittinf of the parameters acording to the Weibull-distribution is done
! the standard generation is repeated in several iterations.
!---the optimisation can be shut off with optimi=.false.
genDg=SQRT(saquad/nbhd)
IF((.not. optimi) .or. (Dg .lt. 7)) exit
IF(ABS(genDg-Dg).gt.(Dg/10.).or.(bhdmax-Dmax).gt. (Dmax/thdmax)) THEN
IF (ABS(genDg-Dg).gt.(Dg/10.))THEN
p1n=p1n*Dg/genDg
IF (p1n.lt.((1.0001-p0(taxid))/Dg)) p1n=(1.0001-p0(taxid))/Dg
b=p0(taxid)+p1n*Dg
ELSE
p4n=p4n*Dmax/bhdmax
IF (p4n.lt.((1.0005-p2(taxid)-p3(taxid)*Dg)/Dmax)) &
p4n=(1.0005-p2(taxid)-p3(taxid)*Dg)/Dmax
c=p2(taxid)+p3(taxid)*Dg+p4n*Dmax
ENDIF
anzahl=anzahl-Int(nbhd)
anzit=anzit+1
IF (anzit.ge.50) THEN
IF (thdmax.eq.2) THEN
print *,'id/zei: ',id,iz,' Optimization not successful. Biased STAND.INI will be generated'
optimi=.false.
ELSE
anzit=0
thdmax=2.0
b=p0(taxid)+p1(taxid)*Dg
c=p2(taxid)+p3(taxid)*Dg+p4(taxid)*Dmax
ENDIF
ENDIF
ELSE
exit
ENDIF
ENDDO
! end of generation of single trees
! classification of single values in diameter cohorts
clwdth=1+AINT((bhdmax-bhdmin)/ncl1) !calculation of class widths
! write(4444,*) 'clwdth', clwdth, bhdmax, bhdmin, ncl1
DO i=1,ncl1
nz(i)=0
zbhd(i)=0
zheigh(i)=0
zhbc(i)=0
ENDDO
DO j=1,nbhd
read(helptmp(j), *) bhd,height,hbc,age,taxid
IF(height<1.3) WRITE(4444,*)'bhd ',bhd,'height ',height,'art ',taxid
icl=INT(bhd/clwdth)+1
IF(icl.gt.ncl1) icl=ncl1
nz(icl)=nz(icl)+1 !addition stem numbre of diameter classes
zbhd(icl)=zbhd(icl)+bhd !sum of diametes of diameter calsses
zheigh(icl)=zheigh(icl)+height !sum of height value of classes
zhbc(icl)=zhbc(icl)+hbc !sum of crown starting height of classes
ENDDO
deallocate(helptmp)
tot_crown_area=0.
DO i=1,ncl1
IF (nz(i).ne.0) THEN
bhd=zbhd(i)/nz(i)
height=zheigh(i)/nz(i)
hbc=zhbc(i)/nz(i)
n_koh=NINT(nz(i)/area_factor)
tot_crown_area=tot_crown_area+n_koh*PI*(MIN(spar(taxid)%crown_a*bhd+spar(taxid)%crown_b,spar(taxid)%crown_c))**2
ENDIF
ENDDO
IF(tot_crown_area>1.1*kpatchsize) THEN
corr_la=kpatchsize/tot_crown_area
ELSE
corr_la=1.
ENDIF
DO i=1,ncl1
IF (nz(i).ne.0) THEN
bhd=zbhd(i)/nz(i)
height=zheigh(i)/nz(i)
hbc=zhbc(i)/nz(i)
n_koh=NINT(nz(i)/area_factor)
! --- 4C-specific calculations:
IF(height<1.3) WRITE(4444,*)ngroups(iz)%locid,'bhd ',bhd,'height ',height,'art ',taxid
IF(height*100<h_sapini) THEN
CALL sapini(outunit,taxid, height,hbc, n_koh,age)
WRITE(4444,*)ngroups(iz)%locid,bhd,taxid
ELSE
CALL treeini(outunit,ctrlunit,taxid,source,bhd,height,hbc,n_koh,cform,rsap,age,hlp_lai,corr_la)
ENDIF
ENDIF
ENDDO !cohort loop
2222 CONTINUE
if(datasets=='multi') then
IF (iz.ne.nlines.AND.datasets=='multi'.AND.(istart.NE.ngroups(iz+1)%locid)) WRITE(outunit,*) '-99.9'
end if
2244 CONTINUE
ENDDO !line loop
CLOSE(outunit)
CLOSE(ctrlunit)
RETURN
! ****************************************************************************
! case(6) stand generation if data source is from Bavarian inventories
CASE(6)
print *, ' Forest stand data set: Bavarian inventories'
infile='/data/safe/4C/4C_input/stand/Bayernw.dat'
source='B'
OPEN (inunit, FILE=TRIM(infile), STATUS='old')
listunit=GETUNIT()
OPEN (listunit, FILE='/home/lasch/4c/v0.99e1/input/koord.txt', STATUS='old')
! ------------------------------------------------------------------
! generated standard values of data from data storage based on
! estimation routines of Nagel and Biging (1995), Nagel (1995) and
! Gerold (1990).
! ------------------------------------------------------------------
!
! The following variables are read from forest inventory data:
! Species(baum),Age(alt),Quadratic Mean Diameter(dm),Height of tree with dm(mhoe),
! Basal area(gf),Yield Class(bon),"Ertragsniveau"(en)
!
! ------------------------------------------------------------------
! read in stad data of multiple stands out of records
select_lines=.true.
datasets='multi'
fl_num=0
IF(select_lines) THEN
READ(listunit,*)nlines_comp
ALLOCATE(locid_comp(nlines_comp))
DO i=1,nlines_comp ! reading list of sites to be initialised
READ(listunit,*) locid_comp(i)
ENDDO ! end reading list of sites to be initialised
ENDIF ! end of reading file with sites to be selected
IF(select_lines) CLOSE(listunit)
CALL assign_BAY
CALL init_plenter_param
READ (inunit,*)
READ (inunit,*)nlines
ALLOCATE(ngroups(nlines))
istart=1
READ(inunit,*) dummy, dummy, dummy, ngroups(1)%locid, dummy, &
ngroups(1)%schicht, ngroups(1)%BRAid, dummy, dummy, ngroups(1)%alter, &
dummy, dummy, ngroups(1)%dm, ngroups(1)%mhoe, ngroups(1)%baumzahl, &
ngroups(1)%gf, ngroups(1)%volume, dummy
ngroups(1)%taxid=tax_of_BRA_id(ngroups(1)%BRAid)
ngroups(1)%standsize=40000
IF(ngroups(1)%alter==0.OR.ngroups(1)%mhoe==0.OR.ngroups(1)%dm==0.OR.ngroups(1)%volume==0.OR.ngroups(1)%gf==0) CALL data_gap_fill_DSW(1)
DO i=2,nlines
READ(inunit,*) dummy, dummy, dummy, ngroups(i)%locid, dummy, &
ngroups(i)%schicht, ngroups(i)%BRAid, dummy, dummy, ngroups(i)%alter, &
dummy, dummy, ngroups(i)%dm, ngroups(i)%mhoe, ngroups(i)%baumzahl, &
ngroups(i)%gf, ngroups(i)%volume, dummy
WRITE(*,*) 'set no', i, 'read'
ngroups(i)%taxid=tax_of_BRA_id(ngroups(i)%BRAid)
ngroups(i)%standsize=40000
! preliminary solution: larches mapped to pine
IF(ngroups(i)%taxid==6) ngroups(i)%taxid=3
IF(ngroups(i)%taxid==0) THEN
ELSE
IF(ngroups(i)%alter==0.OR.ngroups(i)%mhoe==0.OR.ngroups(i)%dm==0.OR.ngroups(i)%gf==0) THEN
WRITE(7333,*)'set ',i,'not enough data or below 1.3 m height'
! CALL data_gap_fill_DSW(i)
ENDIF
ENDIF
IF(ngroups(i)%locid.NE.ngroups(istart)%locid) THEN
istart=i
fl_num=fl_num+1
ENDIF
ENDDO ! readin loop for multi data-set
CLOSE(inunit)
! read file headder for description, write in ini-file
cform=1;hlp_lai=0
! initialisation of stand records: area =
! stand area calculated according to partial areas.
area_factor=1
CALL header(outunit,infile,source,cform,rsap,flag_volfunc,-99.)
id=1
WRITE (fnam2,'(a,i1,a)') 'schicht',id,'.tmp'
tmpunit=getunit()
istart=-99
DO iz=1,nlines
ng_locid = ngroups(iz)%locid
taxid=ngroups(iz)%taxid
IF(select_lines) THEN
DO i=1,nlines_comp
IF(locid_comp(i)==ng_locid) GOTO 2255
ENDDO ! comparison of site id to list of sites to be selected
CYCLE
ENDIF ! end of site selection
2255 CONTINUE
IF(datasets=='multi'.AND.(istart.NE.ng_locid)) THEN
WRITE(outunit,*) ng_locid,ngroups(iz)%standsize,'stand identifier, stand area'
istart=ng_locid
aux = ngroups(iz)%standsize/10000.
ENDIF
IF(datasets=='multi'.AND.taxid==0.) THEN
! solution for bushes must be found
WRITE(*,*) 'not the right species'
GOTO 2277
ENDIF
IF(ngroups(iz)%baumzahl<30.AND.ngroups(iz)%baumzahl>0) ngroups(iz)%schicht=5
IF(datasets=='multi'.AND.ngroups(iz)%schicht==5) THEN
! retention trees can be directly initialized since they are not distributed onto different height cohorts
WRITE(4444,*) 'single type ',ngroups(iz)%schicht
age=ngroups(iz)%alter
height=ngroups(iz)%mhoe
bhd=ngroups(iz)%dm
n_koh=ngroups(iz)%baumzahl*aux
hbc=crown_base(height,c1(taxid),c2(taxid),bhd)
CALL treeini(outunit,ctrlunit,taxid,source,bhd,height,hbc,n_koh,cform,rsap,age,hlp_lai,corr_la)
GOTO 2277
ENDIF ! end special treatment of retention trees
IF(datasets=='multi'.AND.ngroups(iz)%dm==0.and.ngroups(iz)%mhoe>h_sapini*0.01) THEN
WRITE(4444,*)'data insufficient for: ',ng_locid,' line: ',iz
GOTO 2277
ENDIF
IF(datasets=='multi'.AND.ngroups(iz)%mhoe<h_sapini*0.01) THEN
height=ngroups(iz)%mhoe
n_koh=ngroups(iz)%baumzahl* aux
age=ngroups(iz)%alter
call ini_gener_sap(outunit, taxid,age,height,n_koh)
GOTO 2277
ENDIF
T=7
age=ngroups(iz)%alter
dg=ngroups(iz)%dm !quadratic mean diameter
hg=ngroups(iz)%mhoe !corresponding height to dg
g=ngroups(iz)%gf !basal area/ha
gpatch=g*4. !basal area/patch
bz=ngroups(iz)%baumzahl*4. !tree numbre/patch
! clwdth=dg/20.
clwdth=dg/5
! selection of uni-height curve: beech, spruce, oak calculation according to Weimann,
! other species of trees after Kuleschis (vergl. Gerold 1990)
IF (taxid==3.OR.taxid==5) THEN
ehkwei=.false.
ELSE
ehkwei=.true.
ENDIF
! zuweisen der PArameterwerte fr Einheitshhenkurve
IF (ehkwei) THEN
! uni-height curve from Weimann (1980)
wei_f=wei_k1(taxid)+wei_k2(taxid)*hg
ELSE
! uni-height curve from Kuleschis (1981)
ku_a=1-(ku_a0(taxid)+ku_a1(taxid)*dg+ku_a2(taxid)*dg**2)
ku_b=ku_b0(taxid)+ku_b1(taxid)*dg+ku_b2(taxid)*dg**2
ku_c=ku_c0(taxid)+ku_c1(taxid)*dg+ku_c2(taxid)*dg**2
ENDIF
IF ((dg-T).lt. 3.0) THEN
T=dg-4.0
IF (T.lt.0.3) T=0.3
ENDIF
! Estimation of Dmax from dg (Gerold 1990)
Dmax=8.2+1.8*dg-0.01*dg**2
IF (dg.le.2) Dmax=dg+2
! Calculation of parameter for Weibull-distribution
! in case b or c is calculated too small,
! p1 and p4 respectively have to be modified
p1n=p1(taxid)
IF (p1n.lt.((1.0001-p0(taxid))/Dg)) p1n=(1.0001-p0(taxid))/Dg
b=p0(taxid)+p1n*Dg
Dmin = 0.1*Dg
IF(Dg>70) Dmin = 2.*Dg - Dmax
p4n=p4(taxid)
IF (p4n.lt.((1.0005-p2(taxid)-p3(taxid)*Dg)/Dmax)) p4n=(1.0005-p2(taxid)-p3(taxid)*Dg)/Dmax
c=p2(taxid)+p3(taxid)*Dg+p4n*Dmax
anzit=0
thdmax=5.0
helpz=0
DO
imax=INT((Dmax-Dmin)/clwdth)
if(imax.gt.30) then
imax= 30
clwdth= (Dmax-Dmin)/30.
end if
if(helpz.gt.50) goto 2277
helpz= helpz + 1
Fint(0)=0.
gx=0.
bhd=Dmin+0.5*clwdth
DO i = 1,imax
Fint(i)=1-exp(-((bhd-Dmin)/b)**c)
gx=gx+(Fint(i)-Fint(i-1))*bhd**2
bhd=bhd+clwdth
END DO
gx=gx*PI/4*1e-4*bz
IF(ABS(gx-gpatch)>0.02*gpatch) THEN
IF(gx>gpatch) THEN
c=c*gpatch/gx
ELSE
IF(Dmin<0.8*Dg) THEN
Dmin=Dmin*1.05
ELSE
c=c*gx/gpatch
ENDIF
ENDIF
ELSE
EXIT
ENDIF
END DO
bhd=Dmin+0.5*clwdth
DO i = 1,imax
n_koh=NINT((Fint(i)-Fint(i-1))*bz)
!***calculate height according to uni-height curve
IF (ehkwei) THEN
! uni-height curve from Weimann (1980)
IF (bhd.ge.(dg-hg/2.)) THEN
height=hg+wei_f*(log(hg-dg+bhd)-log(hg))
ELSE
height=(hg+wei_f*(log(hg/2.)-log(hg))-1.3)*(bhd/(dg-hg/2.))**0.5+1.3
ENDIF
ELSE
! uni-height curve from Kuleschis (1981)
height=hg*(ku_a+(ku_b/(bhd+dg/2.))*dg+(ku_c/(bhd+dg/2.)**2)*dg**2)
ENDIF
! solution for small stands; tree dimensions below 3 m = rubbish
IF (height.gt.(bhd*3.)) height=bhd*3.
IF (height.lt.1.35) height=1.35+bhd
hbc=crown_base(height,c1(taxid),c2(taxid),bhd)
IF ((height-hbc).lt. 0.5) hbc= height - 0.5
CALL treeini(outunit,ctrlunit,taxid,source,bhd,height,hbc,n_koh,cform,rsap,age,hlp_lai,corr_la)
if(fail.eq.1) write(4444,*) 'negative root in newton', ng_locid,iz
bhd=bhd+clwdth
END DO
2277 CONTINUE
IF (iz.ne.nlines.AND. datasets=='multi'.AND.(istart.NE.ngroups(iz+1)%locid)) WRITE(outunit,*) '-99.9'
2266 CONTINUE
ENDDO !sign loop
CLOSE(outunit)
CLOSE(ctrlunit)
RETURN
CASE(2)
334 CONTINUE
CALL assign_DSW
inwahl=0
source='S'
PRINT *, 'If you want to use SILVA data, type: 1'
PRINT *, 'If you want to use levelII data from Sachsen, type: 2'
PRINT *, 'If you want to use single tree data with tree class information, type: 3'
PRINT *, ' if you want to use data like level II single tree data and generate one tree cohorts, type: 4'
READ(*,*) inwahl
IF (inwahl<1.OR.inwahl>4) THEN
WRITE(*,*) 'You should use integer 1, 2,3 or 4 for the choice of data source'
GOTO 334
ENDIF
333 CONTINUE
IF (inwahl==1) PRINT *, ' Forest stand data set: SILVA (classification must be performed)'
IF (inwahl==2) PRINT *, ' Forest stand data set: levelII Sachsen (classification must be performed)'
IF (inwahl==3) PRINT *, ' Forest stand data set: single tree data with tree type information (classification must be performed)'
IF (inwahl==4) PRINT *, ' Forest stand data set: single tree data without clissification'
WRITE(*,'(A)')
WRITE(*,'(A)')' Do you want to read the input file from '
WRITE(*,'(A)')' 1 - the Standard 4C stand directory on data/safe/4C/4C_input/stand'
WRITE(*,'(A)')' 2 - or do you want to specify another directory?'
WRITE(*,'(A)',advance='no') ' ***Make your choice: '
READ(*,*) dir_flag
IF(dir_flag.EQ.1) THEN
WRITE(*,'(A)',advance='no')' Input file: '
READ (*,'(A)') infile
ELSEIF(dir_flag.EQ.2) THEN
WRITE(*,'(A)',advance='no')' Input directory and file: '
READ (*,'(A)') infile
ELSE
WRITE(*,*) 'You should use integer 1 or 2 for the choice of the input mode. Please try again!'
GOTO 333
ENDIF
337 CONTINUE
cform=1;hlp_lai=0
IF(dir_flag.EQ.1) OPEN (inunit,FILE='/data/safe/4C/4C_input/stand/'//trim(infile),STATUS='old')
IF(dir_flag.EQ.2) OPEN (inunit,FILE=trim(infile),STATUS='old')
! initialising for stand records: area = 1ha
area=10000
IF(inwahl==2.OR.inwahl==3.OR.inwahl==4) THEN
! class width
clwdth=1 !set diameter of classes width
READ(inunit,'(a85)')zeile
READ(inunit,*) area
READ(inunit,'(a85)')zeile
ENDIF
area_factor = 1.
kpatchsize = area
! read in file headder for descriptions, write in ini-file
CALL header(outunit,infile,source,cform,rsap,flag_volfunc,kpatchsize)
! classification of single values into diameter cohorts
IF(inwahl==1) THEN
READ(inunit,'(a85)')zeile
READ(inunit,'(a85)')zeile
ENDIF
335 CONTINUE
DO i=1,ncl1
nz(i)=0
zbhd(i)=0
zheigh(i)=0
zhbc(i)=0
ENDDO
nhelp=0
DO
IF(inwahl==1) READ(inunit,*,IOSTAT=ios)xnr,baumid,bhd,height,hbc,kd,xxr,xyr,xxi,xyi
IF(inwahl==2.or.inwahl.eq.4) THEN
READ(inunit,*,IOSTAT=ios)xnr,taxid,bhd,height,hbc,age
nhelp = nhelp+1
if(bhd.le.10) bhd=11.
bhd=bhd/10.
IF(hbc>-99.99.AND.hbc<-99.8) THEN
hbc=crown_base(height,c1(taxid),c2(taxid),bhd)
IF(height-hbc<0.5) CALL error_mess(time,"crown to shallow in tree",REAL(xnr))
ENDIF
ENDIF
IF(inwahl==3) THEN
READ(inunit,*,IOSTAT=ios)xnr,taxid,bhd,height,hbc,ager,status
IF(taxid>=100) taxid=tax_of_BRA_id(taxid)
age = INT(ager)
bhd=bhd/10.
IF(hbc>-99.99.AND.hbc<-99.8) THEN
hbc=crown_base(height,c1(taxid),c2(taxid),bhd)
IF(height-hbc<0.5) CALL error_mess(time,"crown to shallow in tree",REAL(xnr))
IF((height-hbc)/height<0.5) hbc=0.5*height
IF(bhd<=3.) hbc=0.
ENDIF
ENDIF
IF (ios<0) exit
IF (xnr==-9999) exit
IF (inwahl==4) exit
icl=INT(bhd/clwdth)+1
IF(inwahl.eq.4.or.(inwahl==3.AND.status.NE.'F'.AND.status.NE.'Z'.AND.status.NE.'V'.and.status.NE.'H'.and.status.NE.'U'.and. status.NE.'B'))THEN
ELSE
IF(icl.gt.ncl1) icl=ncl1
nz(icl)=nz(icl)+1 !sum stem numbre of diameter class
zbhd(icl)=zbhd(icl)+bhd !sum up the diameters of a class
zheigh(icl)=zheigh(icl)+height !sum up height value of a class
zhbc(icl)=zhbc(icl)+hbc !sum up crown startin height of a class
ENDIF
ENDDO
nzsum=sum(nz)
IF(inwahl.ne.4) THEN
tot_crown_area=0.
DO i=1,ncl1
IF (nz(i).ne.0) THEN
bhd=zbhd(i)/nz(i)
height=zheigh(i)/nz(i)
hbc=zhbc(i)/nz(i)
if(hbc<0.025) hbc = 0.
if(hbc>=0.025.and.hbc<0.05) hbc =0.05
n_koh=NINT(nz(i)/area_factor)
IF(inwahl==1) THEN
SELECT CASE(baumid)
CASE(5)
taxid=1
CASE(1)
taxid=2
CASE(3)
taxid=3
CASE default
taxid=99
END select
ENDIF
tot_crown_area=tot_crown_area+n_koh*PI*(MIN(spar(taxid)%crown_a*bhd+spar(taxid)%crown_b,spar(taxid)%crown_c))**2
ENDIF
ENDDO
IF(tot_crown_area>1.1*kpatchsize) THEN
corr_la=kpatchsize/tot_crown_area
ELSE
corr_la=1.
ENDIF
IF(pass==1) THEN
mixed_tot_ca = mixed_tot_ca + tot_crown_area
ELSE
corr_la=kpatchsize/mixed_tot_ca
ENDIF
DO i=1,ncl1
IF (nz(i).ne.0) THEN
bhd=zbhd(i)/nz(i)
height=zheigh(i)/nz(i)
hbc=zhbc(i)/nz(i)
if(hbc<0.025) hbc = 0.
if(hbc>=0.025.and.hbc<0.05) hbc =0.05
n_koh=NINT(nz(i)/area_factor)
IF(inwahl==1) THEN
SELECT CASE(baumid)
CASE(5)
taxid=1
CASE(1)
taxid=2
CASE(3)
taxid=3
CASE default
taxid=99
END select
ENDIF
! --- 4C-specific calculation:
WRITE(*,*) 'call :', taxid,bhd,height,hbc,nz(i),n_koh
IF( height<(h_sapini/100.)) then
call sapini(outunit,taxid, height, hbc, n_koh,age)
ELSE
CALL treeini(outunit,ctrlunit,taxid,source,bhd,height,hbc,n_koh,cform,rsap,age,hlp_lai,corr_la)
ENDIF
ENDIF
ENDDO
else if(xnr.ne.-999) then
n_koh = 1
print*, 'xnr:', xnr
IF( height<(h_sapini/100.)) then
call sapini(outunit,taxid, height, hbc, n_koh,age)
ELSE
CALL treeini(outunit,ctrlunit,taxid,source,bhd,height,hbc,n_koh,cform,rsap,age,hlp_lai,corr_la)
ENDIF
end if
IF (xnr==-9999) GOTO 335
if(inwahl==4.and.xnr==-999) then
CLOSE(inunit)
CLOSE(outunit)
CLOSE(ctrlunit)
RETURN
end if
if(inwahl==4) goto 335
CLOSE(inunit)
CLOSE(outunit)
IF(mixed_tot_ca>1.1*kpatchsize .AND. pass == 1) THEN
OPEN (outunit,FILE=TRIM(treefile(ip)),STATUS='replace')
pass = 2
GOTO 337
ENDIF
CLOSE(ctrlunit)
RETURN
CASE(3)
444 print *, ' Forest stand data set: Level2-Daten'
source='L'
WRITE(*,'(A)')
WRITE(*,'(A)')' Do you want to read the input file from '
WRITE(*,'(A)')' 1 - the Standard 4C stand directory on data/safe/4C/4C_input/stand'
WRITE(*,'(A)')' 2 - or do you want to specify another directory?'
WRITE(*,'(A)',advance='no') ' ***Make your choice: '
READ(*,*) dir_flag
IF(dir_flag.EQ.1) THEN
WRITE(*,'(A)',advance='no')' Input file: '
READ (*,'(A)') infile
ELSEIF(dir_flag.EQ.2) THEN
WRITE(*,'(A)',advance='no')' Input directory and file: '
READ (*,'(A)') infile
ELSE
WRITE(*,*) 'You should use integer 1 or 2 for the choice of the input mode. Please try again!'
GOTO 444
ENDIF
cform=1;hlp_lai=0
IF(dir_flag.EQ.1) OPEN (inunit,FILE='/data/safe/4C/4C_input/stand/'//trim(infile),STATUS='old')
IF(dir_flag.EQ.2) OPEN (inunit,FILE=trim(infile),STATUS='old')
!------------------------------------------------------------------
! Read in level II data according to diamter classes
READ(inunit,'(a85)')zeile
READ(inunit,'(a85)')zeile
READ(inunit,'(a85)')zeile
READ(inunit,*)age,taxid,area, rsap, &
dclmin, & !smallest diameter of experimentation patches
ndcl, & !amount diameter class
dcwdth !class width
READ(inunit,*)h_para,h_parb, & !parameter of height function after Lockow
(n_dc(i),i=1,ndcl) !stem numbre per diameter class
close(inunit)
clwdth=dcwdth
! ---------------------------------------------------------------------
! current patch size = value specified by kpatchsize
area_factor=int(area/kpatchsize)
! read in file headder for desciption, write into ini-file
CALL header(outunit,infile,source,cform,rsap,flag_volfunc,kpatchsize)
DO i=1,ncl1
nz(i)=0
zbhd(i)=0
zheigh(i)=0
zhbc(i)=0
ENDDO
bhdcl=dclmin
DO i=1,ndcl
bhd=bhdcl
height=h_para*(0.01*bhd)**h_parb !height function after regression from Lockow
hbc=crown_base(height,c1(taxid),c2(taxid),bhd)
IF ((height-hbc).lt. 0.5) hbc= height - 0.5
icl=INT(bhd/clwdth)+1
IF(icl.gt.ncl1) icl=ncl1
nz(icl)=nz(icl)+n_dc(i) !sum stem numbre of diameter class
zbhd(icl)=zbhd(icl)+bhd*n_dc(i) !sum up diameters of a class
zheigh(icl)=zheigh(icl)+height*n_dc(i) !sum up height values of a class
zhbc(icl)=zhbc(icl)+hbc*n_dc(i) !sum up crown starting height of a class
bhdcl=bhdcl+dcwdth
ENDDO
smaldc(1)=.false.
DO i=1,ncl1
IF (smaldc(i)) THEN
IF (i<ncl1) smaldc(i+1)=.true.
ELSE
IF (i<ncl1) smaldc(i+1)=.false.
n_koh=NINT(nz(i)/area_factor)
IF (n_koh>0) THEN
IF (i<ncl1) smaldc(i+1)=.true.
ENDIF
ENDIF
ENDDO
bigdc(ncl1)=.false.
DO i=ncl1,1,-1
IF (bigdc(i)) THEN
IF (i>1) bigdc(i-1)=.true.
ELSE
IF (i>1) bigdc(i-1)=.false.
n_koh=NINT(nz(i)/area_factor)
IF (n_koh>0) THEN
IF (i>1) bigdc(i-1)=.true.
ENDIF
ENDIF
ENDDO
DO i=1,ncl1
IF (nz(i).ne.0) THEN
n_koh=NINT(nz(i)/area_factor)
IF (n_koh==0) THEN !if no trees in cohorte, shift trees to next class
zbhd(i+1)=zbhd(i+1)+zbhd(i) !add diameter to sum of next class
zheigh(i+1)=zheigh(i+1)+zheigh(i) !add height to sum of next class
zhbc(i+1)=zhbc(i+1)+zhbc(i) !add hbc to sum of next class
nz(i+1)=nz(i+1)+nz(i) !add trees to next class
nz(i)=0 !empty class
ELSE
bhd=zbhd(i)/nz(i)
height=zheigh(i)/nz(i)
hbc=zhbc(i)/nz(i)
! --- 4C-specific calculations:
CALL treeini(outunit,ctrlunit,taxid,source,bhd,height,hbc,n_koh,cform,rsap,age,hlp_lai,corr_la)
ENDIF
ENDIF
IF (.not.bigdc(i+1)) exit
ENDDO
DO j=ncl1,(i+1),-1
IF (nz(j).ne.0) THEN
n_koh=NINT(nz(j)/area_factor)
IF (n_koh==0) THEN !if no trees in cohorte, shift trees to next class
zbhd(j-1)=zbhd(j-1)+zbhd(j) !add diameter to sum of next class
zheigh(j-1)=zheigh(j-1)+zheigh(j) !add height to sum of next class
zhbc(j-1)=zhbc(j-1)+zhbc(j) !add hbc to sum of next class
nz(j-1)=nz(j-1)+nz(j) !add trees to next class
nz(j)=0 !empty class
ELSE
bhd=zbhd(j)/nz(j)
height=zheigh(j)/nz(j)
hbc=zhbc(j)/nz(j)
! --- 4C-specific calculation:
CALL treeini(outunit,ctrlunit,taxid,source,bhd,height,hbc,n_koh,cform,rsap,age,hlp_lai,corr_la)
ENDIF
ENDIF
IF (.not. smaldc(i)) exit
ENDDO
CLOSE(outunit)
CLOSE(ctrlunit)
RETURN
CASE(4)
WRITE(*,*) 'Do you want to use the standard procedure - type: S'
WRITE(*,*) 'or Manfred Lexers input format - type: L'
READ(*,*) source
WRITE(*,'(A)',advance='no')' Input file: '
READ(*,'(A)') infile
cform=1;hlp_lai=0
IF(flag_volfunc.EQ.0) THEN
WRITE(*,'(A)',advance='no')' Input form factor (Default in 4C = 1): '
READ *, cform
ENDIF
OPEN (inunit,FILE=TRIM(infile),STATUS='old')
! read in data from input-file
IF (source=='S') THEN
READ(inunit,*)source, taxid, rsap
READ(inunit,*) area
READ(inunit,*,END=10)n,k,age
area_factor = 1.
CALL header(outunit,infile,source,cform,rsap,flag_volfunc,kpatchsize)
!read in data
DO i=1,k
READ(inunit,*,END=10)bhd,height,share,hbc
IF(hbc>-99.99.AND.hbc<-99.8) THEN
hbc=crown_base(height,c1(taxid),c2(taxid),bhd)
END IF
n_koh = NINT(share*n)
CALL treeini(outunit,ctrlunit,taxid,source,bhd,height,hbc,n_koh,cform,rsap,age,hlp_lai,corr_la)
ENDDO
ELSE
READ(inunit,*) area
kpatchsize= area
CALL header(outunit,infile,source,cform,rsap,flag_volfunc,kpatchsize)
!read in data
DO
READ(inunit,*,iostat=ios)bhd,taxid,height,n_koh,age
if(ios < 0) exit
IF(height.ne.0 .AND. n_koh.ne.0) then
IF(height<h_sapini*0.01) then
CALL ini_gener_sap(outunit,taxid,age,height,n_koh)
else
hbc=crown_base(height,c1(taxid),c2(taxid),bhd)
CALL treeini(outunit,ctrlunit,taxid,source,bhd,height,hbc,n_koh,cform,rsap,age,hlp_lai,corr_la)
end if
ENDIF
ENDDO
ENDIF
10 continue
PRINT*, 'Bestandesblattflche (pro ha): ', hlp_lai*area_factor
CLOSE(inunit)
CLOSE(outunit)
CLOSE(ctrlunit)
! FORGRA data input
CASE(5)
WRITE(*,'(A)',advance='no')' Input file: '
READ(*,'(A)') infile
cform=1;hlp_lai=0
IF(flag_volfunc.EQ.0) THEN
WRITE(*,'(A)',advance='no')' Input form factor (Default in 4C = 1): '
READ *, cform
ENDIF
OPEN (inunit,FILE=TRIM(infile),STATUS='old')
! read in data from input file
READ(inunit,*)source, rsap
READ(inunit,*) area
READ(inunit,*,END=20)n,k
area_factor=int(area/kpatchsize)
CALL header(outunit,infile,source,cform,rsap,flag_volfunc,kpatchsize)
!read in data
DO i=1,k
READ(inunit,*,END=20)bhd,height,share,hbc,age,taxid
n_koh=NINT(share*n/area_factor)
IF(height<h_sapini) THEN
CALL sapini(outunit,taxid, height,hbc, n_koh,age)
ELSE
CALL treeini(outunit,ctrlunit,taxid,source,bhd,height,hbc,n_koh,cform,rsap,age,hlp_lai,corr_la)
ENDIF
ENDDO
20 CONTINUE
CLOSE(outunit)
CLOSE(ctrlunit)
CASE default
PRINT *,' False number'
RETURN
END select
WRITE(*,*) 'initialisation terminated'
deallocate (zheigh, zbhd, zhbc, nz)
deallocate (smaldc, bigdc)
if (allocated(locid_comp))deallocate(locid_comp)
END subroutine initia
!****************************!
!* SUBROUTINE TREEINI *!
!****************************!
SUBROUTINE treeini(outunit,ctrlunit,taxid,source,bhd,height,hbc,n_koh,cform,rsap,age,hlp_lai,corr_la)
! Species (taxid) must be handed over (Beech 1, Spruce 2, Pine 3, Oak 4)
! Source is specifying data source
! height and hbc are read in meter and is converted later to cm
! n_koh numbre of trees in a cohort
! -------------------------------------------------------------------------
USE data_init
USE data_par
USE data_simul
USE data_species
USE data_stand
USE data_help
IMPLICIT none
! ----VARIABLEN---
REAL :: bhd,height,hbc,hlp_lai,hfd,vd,VS,Vg,k1,k2,k3,hm,Ahc,Veff,dbc,corr_la
REAL :: swheight,stembio,afol,asap,dbase, dcbase,volratio,d1,d2,h1,h2,a1,b0, x_ges
INTEGER :: taxid, & ! species number
age, & ! tree age
n_koh
INTEGER :: outunit,ctrlunit !units
CHARACTER*85 zeile
CHARACTER(75):: infile
CHARACTER :: source
REAL rsap, cform, sicrsap, lifrac, rsapfit
INTEGER taumax, ring
! function
REAL newton
sicrsap=rsap
! since the fraction of wood which is sapwood generally is not measured at the
! plots for which the model is initialized, it needs to be approximated
! the following rsap initialisation has been fitted to a pine run at Kienhorst
rsapfit=1.-1.544e-8*age**4+4.343e-6*age**3-3.359e-4*age**2-4.557e-4*age
! estimation of rsap from average diameter increase
! attention: age of tree when first ring has been grown at 1.3 m must be estimated
! for the time being this is set to 5
! If hbc < h_breast, rsap and Asap (below) have to be calculated at lower height
hm=height
height=height*100
hbc=hbc*100
lifrac=1.-spar(taxid)%pss
IF(age>6) THEN
IF(hbc<h_breast) THEN
taumax=age-INT(hbc/h_breast*5.)
ELSE
taumax=age-5
ENDIF
rsap=0.
DO ring = 0,taumax-1
rsap=rsap+exp(ring*log(lifrac))*(2.*(taumax-ring)-1.)
END DO
rsap=rsap/taumax**2
ELSE
rsap=1.
ENDIF
rsap=rsap*corr_la
! --- calculate height of Sapwood-Pipes and stem-mass
swheight=2.*hbc/3.+height/3.
if(taxid.ne.12. .and. taxid.ne.13) then
if(taxid.eq.10) then
! after BWINpro , Bergel 1974
hfd = (-200.31914/(height*bhd*bhd))+(0.8734/bhd) - 0.0052*log(bhd*bhd) + 7.3594/(height*bhd) + 0.46155
else
k1=par_S(taxid,1)+par_S(taxid,2)*log(bhd)+par_S(taxid,3)*log(bhd)**2
k2=par_S(taxid,4)+par_S(taxid,5)*log(bhd)+par_S(taxid,6)*log(bhd)**2
k3=par_S(taxid,7)+par_S(taxid,8)*log(bhd)+par_S(taxid,9)*log(bhd)**2
hfd=exp(k1+k2*log(hm)+k3*log(hm)**2)
end if
! vd volume with SILVA equations
vd=(hfd*pi*bhd**2)/40000
else
! Eucalyptus, Binkley et al 2002
vd = 0.00005447*bhd**1.921157*(height/100)**0.950581
! Stape et. al 2010 Fkt. VER
vd = (0.027*bhd**2.221*(height/100)**0.625)/500
! Stape et al 2010 Fkt ARA
vd = (0.004*bhd**1.959*(height/100)**1.512)/500
end if
! vs volume with Eberswalde equations
if(taxid.eq.3) vs = exp(parEBW(10,1)+parEBW(10,2)*log(bhd)+parEBW(10,3)*log(hm))
IF(taxid==3) vd = vs
IF(flag_volfunc.EQ.0) THEN
IF(source.ne.'S') stembio= swheight*spar(taxid)%prhos*cform*pi*(bhd/2.)**2
IF(source.eq.'S') THEN
stembio=vd*spar(taxid)%prhos*1000000
bhd= SQRT(stembio*4/(swheight*spar(taxid)%prhos*cform*pi))
ENDIF
! --- seperation of sap wood and heartwood and sap wood cross section
x_Ahb= 0.
x_sap=rsap*stembio
x_hrt=(1-rsap)*stembio
asap=rsap*pi*(bhd/2.)**2
! --- estimation of leafe matter and leave area
x_fol=asap*spar(taxid)%pnus
afol=x_fol*(spar(taxid)%psla_min+0.5*spar(taxid)%psla_a)
hlp_lai=hlp_lai+afol*n_koh
! --- fine root matter roughly estimated
x_frt=x_fol
IF(n_koh>0) WRITE(outunit,'(5f12.5,2f10.0,3i7)')x_fol,x_frt,x_sap,x_hrt,x_Ahb,height,hbc,age,n_koh,taxid
ELSEIF(flag_volfunc.EQ.1) THEN
IF (hbc>h_breast.AND.hbc<h_breast+h_bo_br_diff) hbc=h_breast
IF (hbc==h_breast) dbc=bhd
IF (hbc<h_breast) THEN
dbc=bhd/height*(h_breast-hbc)+bhd ! dbc = diameter at base of the crown
asap=PI/4.*dbc**2.*rsap
ELSE
asap=PI/4.*bhd**2.*rsap !change Martin bhd>>dbc as written ins description and rsap weg
ENDIF
rsap = asap/((pi*bhd*bhd)/4)
x_sap=spar(taxid)%prhos*asap*swheight
! first guess for start values of Ahc
IF (hbc<=h_breast) THEN
Ahc=PI/4.*dbc**2.-asap
x_Ahb=PI/4.*(dbc*age/taumax)**2.-asap
ELSE
Ahc=PI/4.*bhd**2.*(1.-rsap)*0.04
Ahc=Newton(Ahc,asap,bhd,hbc,height,Vd)
if(fail.eq.1) return
x_Ahb=PI/4.*((bhd-(4./PI*(asap+Ahc))**0.5*h_breast/hbc)/(1.-h_breast/hbc))**2-asap
ENDIF
! Vg for test purposes = volume if no heartwood in crown space
Vg=1./3.*height*asap+2./3.*hbc*asap+1./3.*hbc*x_Ahb
! --- seperation of sap wood and heartwood and splitting of sap wood cross section
stembio=spar(taxid)%prhos*(1./3.*height*(asap+Ahc)+1./3.*hbc*(2.*asap+x_ahb+(x_ahb*ahc)**0.5))
volratio=1.0
if(infile=='input/bwi2_blmwert1.prn') then
!Spruce
if(taxid.eq.2)then
!after Wirth et al. 2002 Tree physiology
b0=-2.83958
d1=2.55203
d2=-0.14991
h1=-0.19172
h2=0.25739
a1=-0.08278
volratio=(exp(b0+d1*log(bhd)+d2*(log(bhd))**2+h1*log(height/100)+h2*(log(height/100))**2+a1*log(age+0.01)))/stembio
endif
!Pine
if(taxid.eq.3)then
!after Zianis et al. 2005 Silva Fennica EFI BEFs Europe
volratio=exp(-2.6768+7.5939*(bhd/(bhd+13))+0.0151*height/100+0.8799*log(height/100))/stembio
endif
!for douglas fir (correction after bartelink 1996, forest ecol. manag.)
if(taxid.eq.10)then
volratio=exp(-3.229+1.901*log(bhd)+0.807*log(height/100))/stembio
endif
end if
x_sap=x_sap*volratio
x_hrt=stembio*volratio-x_sap
x_ges=x_hrt+x_sap
x_Ahb=x_Ahb*volratio
asap=asap*volratio
if (x_hrt/x_ges .gt. 0.5 .and. taxid .eq. 2 .and. age .gt. 100) then !query too heigh heart wood percentage
x_hrt=0.5*stembio*volratio
x_sap=0.5*stembio*volratio
endif
if (x_hrt/x_ges .gt. 0.35 .and. taxid .eq. 3 .or. taxid .eq. 10) then !query too heigh heart wood percentage
x_hrt=0.35*stembio*volratio
x_sap=0.65*stembio*volratio
endif
Veff=(1./3.*height*(asap+Ahc)+1./3.*hbc*(2.*asap+x_ahb+(x_ahb*ahc)**0.5))*0.000001
dbase = ((x_Ahb+asap)*4./PI)**0.5
dcbase = ((Ahc+asap)*4./PI)**0.5
WRITE(ctrlunit,'(2I5, 12F12.5)') n_koh,age,height,hbc,bhd,rsap,dbase,dcbase,asap,ahc,x_ahb,Vg/1000000,Vd,Veff
! --- estimation leaf matter and leaf area
x_fol=asap*spar(taxid)%pnus*volratio
afol=x_fol*(spar(taxid)%psla_min+0.5*spar(taxid)%psla_a)
hlp_lai=hlp_lai+afol*n_koh
! --- fine root matter rough estimate
x_frt=x_fol
IF(n_koh>0) WRITE(outunit,'(5f12.5,2f10.0,3i7, 2f12.5)')x_fol,x_frt,x_sap,x_hrt,x_Ahb,height,hbc,age,n_koh,taxid, dcbase,bhd
ENDIF
END subroutine treeini
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! SUBROUTINE SAPINI !
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! initilization of seedling cohorts with given height according to relations used in growth_seed
SUBROUTINE sapini(outunit,taxid, height, hbc, n_koh,iage)
USE data_species
USE data_stand
use data_help
IMPLICIT none
REAL :: height,hbc,hhelp
INTEGER :: outunit,n_koh ,taxid,iage
REAL :: x1,x2,xacc,shelp
real :: rtflsp, sapwood
external sapwood
external rtflsp
! Shootbiomass kg from height (cm), originally x_sap [mg]
hhelp = height * 100.
IF (taxid.ne.2) x_sap = exp(( LOG(hhelp)-LOG(spar(taxid)%pheight1))/spar(taxid)%pheight2)/1000000.
IF (taxid.eq.2) THEN
x1 = 1.
x2 = 2.
xacc=(1.0e-10)*(x1+x2)/2
! solve equation for calculation of sapwood from height; determine root
heihelp = hhelp
hnspec = taxid
shelp=rtflsp(sapwood,x1,x2,xacc)
x_sap = (10**shelp)/1000000 ! transformation mg ---> kg
ENDIF
! leaf matter
x_fol = (spar(taxid)%seeda*(x_sap** spar(taxid)%seedb)) ![kg]
! fine root matter rough estimate
x_frt = x_fol
! cross sectional area of heartwood
x_ahb = 0.
x_hrt = 0.
IF(n_koh>0) WRITE(outunit,'(5f12.5,2f10.0,3i7)')x_fol,x_frt,x_sap,x_hrt,x_Ahb,hhelp,hbc,iage,n_koh,taxid
END subroutine sapini
FUNCTION ran0(idum)
INTEGER idum,IA,IM,IQ,IR,MASK
REAL ran0,AM
PARAMETER (IA=16807,IM=2147483647,AM=1./IM,IQ=127773,IR=2836,MASK=123459876)
INTEGER kran
idum=ieor(idum,MASK)
kran=idum/IQ
idum=IA*(idum-kran*IQ)-IR*kran
IF (idum.lt.0) idum=idum+IM
ran0=AM*idum
idum=ieor(idum,MASK)
RETURN
END
! (C) Copr. 1986-92 Numerical Recipes Software 0)+0143$!-.
SUBROUTINE header(outunit,infile,source,cform,rsap,flag_volfunc,patchsize)
! write file headder into ini-file
INTEGER :: outunit, flag_volfunc
REAL :: rsap, cform, patchsize
CHARACTER(75) :: infile
CHARACTER :: source
WRITE(outunit,'(I1,1F12.0,A32)')flag_volfunc,patchsize,' ! = volume function, patch size'
WRITE(outunit,'(A15,A1,A13,A80)') '! data source= ',source,' source file= ',infile
WRITE(outunit,'(A57)') '! sapwood fraction and form factor now dynamic per cohort '
WRITE(outunit,'(a37)')'! 4C Tree Initialization File (Stand)'
WRITE(outunit,'(a1)')'!'
WRITE(outunit,'(a51)')'! contains the following data (single tree values):'
WRITE(outunit,'(a1)')'!'
WRITE(outunit,'(a31)')'! x_fol: foliage biomass (kg)'
WRITE(outunit,'(a33)')'! x_frt: fine root biomass (kg)'
WRITE(outunit,'(a31)')'! x_sap: sapwood biomass (kg)'
WRITE(outunit,'(a33)')'! x_hrt: heartwood biomass (kg)'
WRITE(outunit,'(a65)')'! x_Ahb: cross sectional area of heartwood at stem base (cm**2)'
WRITE(outunit,'(a27)')'! height: tree height (cm)'
WRITE(outunit,'(a27)')'! x_hbole: bole height (cm)'
WRITE(outunit,'(a27)')'! x_age: tree age (years)'
WRITE(outunit,'(a26)')'! n: number of trees'
WRITE(outunit,'(a35)')'! sp: species (integer number)'
WRITE(outunit,'(a33)')'! DC: diameter at crown base'
WRITE(outunit,'(a37)')'! DBH: diameter at breast height'
WRITE(outunit,'(a1)')'!'
WRITE(outunit,'(a120)')'! x_fol x_frt x_sap x_hrt x_Ahb height x_hbole x_age n sp DC DBH'
END subroutine header
FUNCTION crown_base(height,c1,c2,bhd)
IMPLICIT NONE
REAL crown_base
REAL height,bhd,c1,c2
!--- estimate crown starting height according to Nagel (1995)
crown_base=height*(1.-exp(-1.*(c1+c2*height/bhd)**2))
END function crown_base
Function crown_base_eg(height,bhd)
IMPLICIT NONE
real crown_base_eg
real height, bhd
! after Nutto etal. 2006
crown_base_eg= -5.12 -0.407*bhd + 1.193*height
if ( crown_base_eg.lt. 0.) crown_base_eg = 0.
END function crown_base_eg
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
SUBROUTINE fdfahc(X,F,DF,asap,bhd,hbc,height,Vd,J)
USE data_par
USE data_simul
use data_help
IMPLICIT none
REAL X,F,DF,asap,bhd,hbc,height,Vd,C,dCdX
INTEGER J
fail=0
IF (asap+X.LE.0) THEN
WRITE(*,*) 'negative root at calculation C in fdfahc, program will stop'
STOP
ENDIF
C=(bhd-(4./PI*(asap+X))**0.5*h_breast/hbc)/(1.-h_breast/hbc)
dCdX=(-h_breast)/hbc/(1.-h_breast/hbc)/(4./PI*(asap+X))**0.5*2./PI
IF (X*(PI/4.*C**2.-asap).LE.0) THEN
fail=1
return
ENDIF
F=1./3.*height*(asap+X)+1./3.*hbc*(asap+PI/4.*C**2.+(X*(PI/4.*C**2.-asap))**0.5)-Vd*1000000.
DF=1./3.*(height+hbc*PI/2.*C*dCdX+hbc*0.5/(X*(PI/4.*C**2.-asap))**0.5*(PI/4.*C**2+X*PI/2.*C*dCdX-asap))
END subroutine fdfahc
FUNCTION NEWTON(X,asap,bhd,hbc,height,Vd)
use data_help
IMPLICIT NONE
REAL newton
REAL F,DF,X,DX,asap,bhd,hbc,height,Vd
INTEGER J,stepmax
! Newton is to be called with a start value for X
! a subroutine NEWFDF is to be included in the main program which
! calculates the value of the function and its derivative at X and
! returns them in the variables F and DF
PARAMETER (stepmax=5000)
DO 7 J=1,stepmax
CALL fdfAhc(X,F,DF,asap,bhd,hbc,height,Vd,J)
if(fail.eq.1) return
IF(DF.EQ.0.0) THEN
DX=0.01*X
ELSE
DX=F/DF
ENDIF
Newton=X
IF(DX.GT.X) DX=X/2.
X=X-DX
IF(ABS(DX).LT.0.0005) RETURN
7 END DO
END
SUBROUTINE ini_gener_sap(outunit,taxid,age,pl_height, nplant)
USE data_stand
USE data_par
USE data_species
USE data_soil
USE data_help
USE data_plant
USE data_manag
IMPLICIT NONE
integer :: nplant, &
taxid, &
nclass, &
i,nr, &
age, &
outunit
real :: pl_height, &
height, &
hhelp, &
hbc, &
sdev, &
help, &
nstot
real :: rtflsp, sapwood
real :: hmin_est ! empirical estimated minimum height
real, dimension(:), allocatable :: hei, &
nschelp
integer,dimension(:),allocatable :: nsc
external sapwood
external rtflsp
sdev = hsdev(taxid)
if (nplant.eq.0) nplant= numplant(taxid)
height = pl_height*100
if(height .lt. 100) then
hmin_est = height - height*0.2
else
hmin_est = height - height*0.1
end if
if(nplant.eq.1) hmin_est = height
nclass= nint((height+2*sdev) - hmin_est) + 1
if(nplant.eq.1) nclass =1
if(nplant.lt.200) nclass=1
allocate(hei(nclass))
allocate(nschelp(nclass))
allocate(nsc(nclass))
nstot = 0
help = (1/(sqrt(2*pi)*sdev))
do i = 1, nclass
! height per class
hei(i) = hmin_est + (i-1)
nschelp(i) = help*exp(-((hei(i)-height)**2)/(2*(sdev)**2))
nstot = nstot + nschelp (i)
end do
! scaling of plant number per cohort
do i = 1,nclass
nsc(i) = nint((nschelp(i)*nplant/nstot) + 0.5)
end do
if(nplant.eq.1) nsc(1) = nplant
do i = 1,nclass
hhelp = hei(i)*0.01
hbc=0
call sapini(outunit,taxid, hhelp, hbc,nsc(i),age)
end do
END SUBROUTINE ini_gener_sap
source_code/version_2.3_windows/interc.f 0 → 100644
View file @ 82df1085
!*****************************************************************!
!* *!
!* 4C (FORESEE) Simulation Model *!
!* *!
!* *!
!* Subroutines for: *!
!* Interception *!
!* *!
!* contains: *!
!* INTERCEP *!
!* INTERCEP_SVEG *!
!* INT_LAYER *!
!* INT_COH_LOOP1 *!
!* INT_COH_LOOP2 *!
!* INT_COH_LOOP3 *!
!* *!
!* Copyright (C) 1996-2018 *!
!* Potsdam Institute for Climate Impact Reserach (PIK) *!
!* Authors and contributors see AUTHOR file *!
!* This file is part of 4C and is licensed under BSD-2-Clause *!
!* See LICENSE file or under: *!
!* http://www.https://opensource.org/licenses/BSD-2-Clause *!
!* Contact: *!
!* https://gitlab.pik-potsdam.de/foresee/4C *!
!* *!
!*****************************************************************!
SUBROUTINE intercep
! Interception of the whole stand
! Stand variables are calculated in stand_balance
use data_climate
use data_inter
use data_evapo
use data_par
use data_simul
use data_species
use data_soil
use data_stand
implicit none
type(Coh_Obj), pointer :: p ! pointer to cohort list
real aev_c, helplai, hxx, hsum, harea, &
cepmax, cepmax_can, cepmax_sveg, &
prec_eff, & ! effective crown precipitation
R_crown, &
interc_c, & ! interception per cohort
pet_c ! pet per cohort
! effective crown precipitation like Anders et al., 2002, S. 95
prec_eff = prec * (1 + 0.13 * wind * (1-crown_area/kpatchsize))
aev_i = 0.
select case (flag_inth)
case (0) ! nach Jansson (SOIL)
! Evaporation calculated at the start (==> interception is possible to be higher)
! evaporation of intercepted water aev_i is limited by potential evaporation
aev_c = max(min(int_st_can, pet), 0.)
int_st_can = max(int_st_can - aev_c, 0.) ! interception storage from actual day
! Canopy interception
if (lai_can .gt. 0.) then
cepmax_can = ceppot_can * lai_can ! max. int. cap. of the whole stand
if (airtemp .ge. temp_snow) then ! frost conditions
lint_snow = .false.
hxx = 0.
if (cepmax_can .ge. int_st_can) hxx = cepmax_can-int_st_can
interc_can = min(hxx, prec)
else
lint_snow = .true.
hxx = 0.
if (2.*cepmax_can .ge. int_st_can) hxx = 2.*cepmax_can-int_st_can
interc_can = min(hxx, prec)
endif
else
cepmax_can = ceppot_can * LAI_can ! max. int. cap. of the whole stand, only canopy
hxx = 0.
if (cepmax_can .ge. int_st_can) hxx = cepmax_can-int_st_can
interc_can = crown_area/kpatchsize * 0.15 * prec
interc_can = min(hxx, interc_can)
aev_c = 0.
endif
int_st_can = int_st_can + interc_can
! interception of ground vegetation
if (flag_sveg .gt. 0) call intercep_sveg (aev_c)
! interception and interc.-evaporation of cohorts
call interc_coh (aev_c)
aev_i = aev_i + aev_c
!......................................
case (1) ! interception for each cohort
! with distribution of precipit. over all canopy layers
int_st_can = 0.
int_st_sveg = 0.
interc_can = 0.
interc_sveg = 0.
aev_i = 0.
hsum = 0.
if (prec .gt. 0. .and. highest_layer .gt. 0) then
call Int_layer
else
p => pt%first
do while (associated(p))
p%coh%interc = 0.
p => p%next
enddo ! p (cohorts)
endif
p => pt%first
do while (associated(p))
ns = p%coh%species
if (all_leaves_on .eq. 0) then
if((anz_tree.ne.0) .and. (pet .gt. 0.)) then
pet_c = pet * p%coh%ntreea / anz_tree
else
pet_c = 0.
end if
else
if (flag_eva .eq. 2 .or. flag_eva .eq. 4) then
pet_c = p%coh%demand
else
if((anz_tree.ne.0) .and. (pet .gt. 0.)) then
pet_c = pet * p%coh%rel_fol
else
pet_c = 0.
end if
p%coh%demand = pet_c
endif
endif
interc_c = p%coh%interc
select case (ns) ! species
case (1,12,13) ! Fagus sylvatica
p%coh%interc_st = p%coh%interc_st + interc_c
aev_c = min(p%coh%interc_st, pet_c)
p%coh%interc_st = max(p%coh%interc_st - aev_c, 0.)
interc_can = interc_can + interc_c
int_st_can = int_st_can + p%coh%interc_st
case (2,10,15) ! Picea abies ... Mistletoe
p%coh%interc_st = p%coh%interc_st + interc_c
aev_c = min(p%coh%interc_st, 2.*pet_c)
p%coh%interc_st = max(p%coh%interc_st - aev_c, 0.)
interc_can = interc_can + interc_c
int_st_can = int_st_can + p%coh%interc_st
case (3,6,7,9) ! Pinus sylvestris
p%coh%interc_st = p%coh%interc_st + interc_c
aev_c = min(p%coh%interc_st, pet_c)
p%coh%interc_st = max(p%coh%interc_st - aev_c, 0.)
interc_can = interc_can + interc_c
int_st_can = int_st_can + p%coh%interc_st
case (4,5,8,11) ! Quercus robur, Betula pendula
p%coh%interc_st = p%coh%interc_st + interc_c
aev_c = min(p%coh%interc_st, 2.*pet_c)
p%coh%interc_st = max(p%coh%interc_st - aev_c, 0.)
interc_can = interc_can + interc_c
int_st_can = int_st_can + p%coh%interc_st
case (14) ! Ground vegetation
p%coh%interc_st = p%coh%interc_st + interc_c
aev_c = min(p%coh%interc_st, pet_c)
p%coh%interc_st = max(p%coh%interc_st - aev_c, 0.)
interc_sveg = interc_sveg + interc_c
int_st_sveg = int_st_sveg + p%coh%interc_st
end select
p%coh%aev_i= aev_c
aev_i = aev_i + aev_c
p => p%next
enddo ! p (cohorts)
!......................................
case (2) ! interception for each cohort
! with relativ part of precipit. accord. to foliage
int_st_can = 0.
int_st_sveg = 0.
interc_can = 0.
interc_sveg = 0.
aev_i = 0.
hsum = 0.
stem_flow = 0.
p => pt%first
do while (associated(p))
ns = p%coh%species
if (flag_eva .eq. 2 .or. flag_eva .eq. 4) then
pet_c = p%coh%demand
else
pet_c = pet * p%coh%rel_fol
endif
select case (ns) ! species
case (1) ! Fagus sylvatica
if ((iday .ge. p%coh%day_bb) .and. (iday .le. spar(ns)%end_bb)) then
helplai = p%coh%t_leaf/p%coh%crown_area
cepmax = spar(ns)%ceppot_spec * p%coh%rel_fol * helplai
if (airtemp .ge. temp_snow) then ! frost conditions
hxx = 0.
if (cepmax .ge. p%coh%interc_st) hxx = cepmax - p%coh%interc_st
interc_c = min(hxx, prec * p%coh%rel_fol)
stem_flow = stem_flow + 0.2 * (prec * p%coh%rel_fol - interc_c)
else
interc_c = 0.35 * prec * p%coh%rel_fol
endif
else
interc_c = 0.1 * prec * p%coh%rel_fol
stem_flow = stem_flow + 0.16 * prec * p%coh%rel_fol
endif
p%coh%interc_st = p%coh%interc_st + interc_c
aev_c = min(p%coh%interc_st, 2.*pet_c)
p%coh%interc_st = max(p%coh%interc_st - aev_c, 0.)
interc_can = interc_can + interc_c
int_st_can = int_st_can + p%coh%interc_st
stem_flow = stem_flow + 0.16 * prec * p%coh%rel_fol
case (2,10,15) ! Picea abies ... Mistletoe
helplai = p%coh%t_leaf/p%coh%crown_area
cepmax = spar(ns)%ceppot_spec * p%coh%rel_fol * helplai
if (airtemp .ge. temp_snow) then ! frost conditions
hxx = 0.
if (cepmax .ge. p%coh%interc_st) hxx = p%coh%interc_st
interc_c = min(cepmax-hxx, prec * p%coh%rel_fol)
else
interc_c = 0.35 * prec * p%coh%rel_fol
endif
p%coh%interc_st = p%coh%interc_st + interc_c
aev_c = min(p%coh%interc_st, 2.*pet_c)
p%coh%interc_st = max(p%coh%interc_st - aev_c, 0.)
interc_can = interc_can + interc_c
int_st_can = int_st_can + p%coh%interc_st
case (3,6,7,9) ! Pinus sylvestris
helplai = p%coh%t_leaf/p%coh%crown_area
cepmax = spar(ns)%ceppot_spec * p%coh%rel_fol * helplai
if (airtemp .ge. temp_snow) then ! frost conditions
hxx = 0.
if (cepmax .ge. p%coh%interc_st) hxx = p%coh%interc_st
interc_c = min(cepmax-hxx, prec * p%coh%rel_fol)
else
interc_c = 0.35 * prec * p%coh%rel_fol
endif
p%coh%interc_st = p%coh%interc_st + interc_c
aev_c = min(p%coh%interc_st, pet_c)
p%coh%interc_st = max(p%coh%interc_st - aev_c, 0.)
interc_can = interc_can + interc_c
int_st_can = int_st_can + p%coh%interc_st
case (4,5,8,11) ! Quercus robur, Betula pendula
if ((iday .ge. p%coh%day_bb) .and. (iday .le. spar(ns)%end_bb)) then
helplai = p%coh%t_leaf/p%coh%crown_area
cepmax = spar(ns)%ceppot_spec * p%coh%rel_fol * helplai
if (airtemp .ge. temp_snow) then ! frost conditions
hxx = 0.
if (cepmax .ge. p%coh%interc_st) hxx = p%coh%interc_st
interc_c = min(cepmax-hxx, prec * p%coh%rel_fol)
else
interc_c = 0.35 * prec * p%coh%rel_fol
endif
else
interc_c = 0.05 * prec * p%coh%rel_fol
endif
p%coh%interc_st = p%coh%interc_st + interc_c
aev_c = min(p%coh%interc_st, 2.*pet_c)
p%coh%interc_st = max(p%coh%interc_st - aev_c, 0.)
interc_can = interc_can + interc_c
int_st_can = int_st_can + p%coh%interc_st
case (14) ! Ground vegetation
if ((iday .ge. p%coh%day_bb) .and. (iday .le. spar(ns)%end_bb)) then
helplai = p%coh%t_leaf/p%coh%crown_area
cepmax = spar(ns)%ceppot_spec * p%coh%rel_fol * helplai
if (airtemp .ge. temp_snow) then ! frost conditions
hxx = 0.
if (cepmax .ge. p%coh%interc_st) hxx = p%coh%interc_st
interc_c = min(cepmax-hxx, prec * p%coh%rel_fol)
else
interc_c = 0.35 * prec * p%coh%rel_fol
endif
else
if (iday .eq. spar(ns)%end_bb+1) then
interc_c = p%coh%interc_st
else
interc_c = 0.
endif
endif
p%coh%interc_st = p%coh%interc_st + interc_c
aev_c = min(p%coh%interc_st, pet_c)
p%coh%interc_st = max(p%coh%interc_st - aev_c, 0.)
interc_sveg = interc_sveg + interc_c
int_st_sveg = int_st_sveg + p%coh%interc_st
end select
p%coh%aev_i= aev_c
aev_i = aev_i + aev_c
p => p%next
enddo ! p (cohorts)
!......................................
case (3) ! interception pine like Anders et al., 2002, S. 95
cepmax_can = ceppot_can * lai_can ! max. int. cap. of the whole stand
cepmax_can = 2.9 ! effect. crown storage capacity of pine according to Anders
R_crown = 0.083 ! s/m aerodyn. resistance of the crown of pine (Anders)
if (cepmax_can .gt. prec_eff) then
interc_can = (crown_area/kpatchsize) * prec_eff
else
interc_can = cepmax_can + (prec_eff - cepmax_can) * wind * R_crown
interc_can = (crown_area/kpatchsize) * interc_can
endif
int_st_can = int_st_can + interc_can
aev_c = int_st_can ! imediate total evaporation
int_st_can = 0. ! interception storage from actual day
!......................................
case (4) ! from Refr.-Bez. (reference notation) (polynom.) for Level II, Brandenburg
interc_can = 0.2 * prec
int_st_can = int_st_can + interc_can
! evaporation of intercepted water aev_i is limited by potential evaporation
aev_c = min(int_st_can, pet)
int_st_can = max(int_st_can - aev_c, 0.) ! interception storage from actual day
! Interception of ground vegetation
if (flag_sveg .gt. 0) call intercep_sveg (aev_c)
! interception and interc.-evaporation of cohorts
call interc_coh (aev_c)
aev_i = aev_i + aev_c
case (5) ! 35% of precipitation (for spruce)
interc_can = 0.3 * prec
int_st_can = int_st_can + interc_can
! evaporation of intercepted water aev_i is limited by potential evaporation
aev_c = min(int_st_can, pet)
int_st_can = max(int_st_can - aev_c, 0.) ! interception storage from actual day
! interception of ground vegetation
if (flag_sveg .gt. 0) call intercep_sveg (aev_c)
! interception and interc.-evaporation of cohorts
call interc_coh (aev_c)
aev_i = aev_i + aev_c
case (6) ! no interception
interc_can = 0.
aev_c = 0.
interc_sveg = 0.
end select
if (flag_dayout .eq. 3) then
write(666,*) 'day, prec, prec_eff: ', iday, prec, prec_eff
endif
! cumul. interc.
int_cum_can = int_cum_can + interc_can
int_cum_sveg = int_cum_sveg + interc_sveg
if(flag_dayout.eq.3) write(1414,*) iday, aev_i
END subroutine intercep
!**************************************************************
SUBROUTINE Int_layer
! Interception per canopy layer
! calculation for each cohort in subroutine int_coh_loop1 (rain)
! and int_coh_loop3 (int_coh_loop2 old) for snow
!*** Declaration part ***!
USE data_climate
USE data_inter
USE data_par
USE data_simul
USE data_species
USE data_stand
IMPLICIT NONE
! variables required for technical reasons
INTEGER :: i
REAL :: intlay, itest ! interception per layer
REAL :: help
TYPE(Coh_Obj), Pointer :: p ! pointer to cohort list
!*** Calculation part ***!
precpool = 0.
itest = 0.
intlay = 0.
! cohort loop
p => pt%first
DO WHILE (ASSOCIATED(p))
p%coh%intcap = 0.
p%coh%interc = 0.
p%coh%prel = 0.
p => p%next
END DO ! cohort loop
! above the canopy there is 100 % precipitation
precpool(highest_layer) = prec
if (airtemp .ge. temp_snow) then ! frost conditions
lint_snow = .false.
do i = highest_layer, lowest_layer, -1
intlay = 0.
CALL int_coh_loop1(i,intlay)
! Assum.: all layers are above eachother, that means precip. is reduc. layer by layer due to interception.
precpool(i-1) = precpool(i) - intlay
itest = itest + intlay
enddo ! end layer loop
else
lint_snow = .true.
CALL int_coh_loop3(intlay)
endif ! airtemp
! stand precipitation unto the ground
DO i = lowest_layer - 2, 0, -1
precpool(i)=precpool(i+1)
END DO
itest = 0.
END SUBROUTINE Int_layer
!**************************************************************
SUBROUTINE int_coh_loop1(i,intlay)
! interception for each canopy layer of each cohort
!*** Declaration part ***!
USE data_simul
USE data_soil
USE data_species
USE data_stand
IMPLICIT NONE
! variables required for technical reasons
TYPE(Coh_Obj), Pointer :: p ! pointer to cohort list
INTEGER :: i, itop ! layer
REAL :: intlay ! interception per layer
REAL :: interc_c, & ! interception per cohort
cepcap ! Int.-Kapaz. fuer diese Variante reduzieren
REAL :: help, hxx
interc_c = 0.
p => pt%first
! cohort loop in layer i
DO WHILE (ASSOCIATED(p))
ns=p%coh%species
IF ((iday >= p%coh%day_bb) .AND. (iday <= spar(p%coh%species)%end_bb)) then
IF (i <= p%coh%toplayer .AND. i >= p%coh%botlayer) THEN
p%coh%prel(i) = precpool(i) * p%coh%BG(i) * p%coh%nTreeA
select case (ns) ! species
case (1) ! Fagus sylvatica
if (p%coh%t_leaf .gt. 0.) then
cepcap = spar(ns)%ceppot_spec * 0.5
p%coh%intcap(i) = cepcap * p%coh%leafArea(i) * p%coh%rel_fol / &
(kpatchsize * p%coh%BG(i))
! intcap is related to the projection area and has to be modified
! by the same factor by that the projection area is being modified
! in case sumBG > patchsize
p%coh%intcap(i)=p%coh%intcap(i) * MIN(kpatchsize/vStruct(i)%sumBG, 1.)
! interc per patch! Since the projection area changes interc has to
! be related to the patch in each layer
hxx = 0.
if (p%coh%intcap(i) .ge. p%coh%interc_st/dz) hxx = p%coh%interc_st/dz ! interc storage spead across all layers
interc_c = min(p%coh%prel(i), p%coh%intcap(i)-hxx)
else
interc_c = 0.1 * p%coh%prel(i)
endif
case (2,10,15) ! Picea abies ... mistletoe
cepcap = spar(ns)%ceppot_spec * 0.5
p%coh%intcap(i) = cepcap * p%coh%leafArea(i) * p%coh%rel_fol / &
(kpatchsize * p%coh%BG(i))
! intcap is related to the projection area and has to be modified
! by the same factor by that the projection area is being modified
! in case sumBG > patchsize
p%coh%intcap(i)=p%coh%intcap(i) * MIN(kpatchsize/vStruct(i)%sumBG, 1.)
! interc per patch! Since the projection area changes interc has to
! be related to the patch in each layer
hxx = 0.
if (p%coh%intcap(i) .ge. p%coh%interc_st/dz) hxx = p%coh%interc_st/dz ! interc storage spead across all layers
interc_c = min(p%coh%prel(i), p%coh%intcap(i)-hxx)
case (3,6,7,9) ! Pinus sylvestris
cepcap = spar(ns)%ceppot_spec * 0.5
p%coh%intcap(i) = cepcap * p%coh%leafArea(i) * p%coh%rel_fol / &
(kpatchsize * p%coh%BG(i))
! intcap is related to the projection area and has to be modified
! by the same factor by that the projection area is being modified
! in case sumBG > patchsize
p%coh%intcap(i)=p%coh%intcap(i) * MIN(kpatchsize/vStruct(i)%sumBG, 1.)
! interc per patch! Since the projection area changes interc has to
! be related to the patch in each layer
hxx = 0.
if (p%coh%intcap(i) .ge. p%coh%interc_st/dz) hxx = p%coh%interc_st/dz ! interc storage spead across all layers
interc_c = min(p%coh%prel(i), p%coh%intcap(i)-hxx)
case (4,5,8,11) ! Quercus robur, Betula pendula
if (p%coh%t_leaf .gt. 0.) then
cepcap = spar(ns)%ceppot_spec * 0.5
p%coh%intcap(i) = cepcap * p%coh%leafArea(i) * p%coh%rel_fol / &
(kpatchsize * p%coh%BG(i))
! intcap is related to the projection area and has to be modified
! by the same factor by that the projection area is being modified
! in case sumBG > patchsize
p%coh%intcap(i)=p%coh%intcap(i) * MIN(kpatchsize/vStruct(i)%sumBG, 1.)
! interc per patch! Since the projection area changes interc has to
! be related to the patch in each layer
hxx = 0.
if (p%coh%intcap(i) .ge. p%coh%interc_st/dz) hxx = p%coh%interc_st/dz ! interc storage spead across all layers
interc_c = min(p%coh%prel(i), p%coh%intcap(i)-hxx)
else
interc_c = 0.1 * p%coh%prel(i)
endif
case (14) ! Ground vegetation
if (p%coh%t_leaf .gt. 0.) then
cepcap = spar(ns)%ceppot_spec * 0.5
p%coh%intcap(i) = cepcap * p%coh%leafArea(i) * p%coh%rel_fol / &
(kpatchsize * p%coh%BG(i))
! intcap is related to the projection area and has to be modified
! by the same factor by that the projection area is being modified
! in case sumBG > patchsize
p%coh%intcap(i)=p%coh%intcap(i) * MIN(kpatchsize/vStruct(i)%sumBG, 1.)
! interc per patch! Since the projection area changes interc has to
! be related to the patch in each layer
hxx = 0.
if (p%coh%intcap(i) .ge. p%coh%interc_st/dz) hxx = p%coh%interc_st/dz ! interc storage spead across all layers
interc_c = min(p%coh%prel(i), p%coh%intcap(i)-hxx)
else
interc_c = 0.0
endif
end select
ENDIF ! i - layer
ELSE
IF (i == p%coh%toplayer) THEN
itop = i
if(cover.ne.0) p%coh%prel(itop) = precpool(i) * p%coh%nTreeA *p%coh%crown_area/crown_area
select case (ns) ! species
case (1) ! Fagus sylvatica p%coh%x_tb
interc_c = 0.2 * p%coh%prel(itop)
case (2,10,15) ! Picea abies ... Mistletoe
interc_c = 0.1 * p%coh%prel(itop)
case (3,6,7,9) ! Pinus sylvestris
interc_c = 0.1 * p%coh%prel(itop)
case (4,5,8,11) ! Quercus robur, Betula pendula
interc_c = 0.1 * p%coh%prel(itop)
case (14) ! Ground vegetation
interc_c = 0.
end select
ENDIF ! i - layer
END IF ! iday
if (interc_c .le. 1E-15) interc_c = 0.
p%coh%interc = p%coh%interc + interc_c
intlay = intlay + interc_c
interc_c = 0.
p => p%next
END DO ! cohort loop
END SUBROUTINE int_coh_loop1
!**************************************************************
SUBROUTINE int_coh_loop2(i,intlay)
! snow interception for each canopy layer of each cohort
!*** Declaration part ***!
USE data_simul
USE data_soil
USE data_species
USE data_stand
IMPLICIT NONE
! variables required for technical reasons
TYPE(Coh_Obj), Pointer :: p ! pointer to cohort list
INTEGER :: i ! layer
REAL :: intlay ! interception per layer
REAL :: interc_c, & ! interception per cohort
cepcap ! Int.-Kapaz. fuer diese Variante reduzieren
REAL :: help, hxx
interc_c = 0.
p => pt%first
! cohort loop in layer i
DO WHILE (ASSOCIATED(p))
ns=p%coh%species
IF (i <= p%coh%toplayer .AND. i >= p%coh%botlayer) THEN
select case (ns) ! species
case (1) ! Fagus sylvatica
if(cover.ne.0) p%coh%prel(i) = precpool(i) * p%coh%nTreeA *p%coh%crown_area/(kpatchsize*cover)
if (p%coh%t_leaf .gt. 0.) then
interc_c = 0.35 * p%coh%prel(i)
else
interc_c = 0.1 * p%coh%prel(i)
endif
case (2,10,15) ! Picea abies... Mistletoe
p%coh%prel(i) = precpool(i) * p%coh%BG(i) * p%coh%nTreeA
interc_c = 0.35 * p%coh%prel(i)
case (3,6,7,9) ! Pinus sylvestris
p%coh%prel(i) = precpool(i) * p%coh%BG(i) * p%coh%nTreeA
interc_c = 0.35 * p%coh%prel(i)
case (4,5,8,11) ! Quercus robur, Betula pendula
p%coh%prel(i) = precpool(i) * p%coh%nTreeA *p%coh%crown_area/kpatchsize
if (p%coh%t_leaf .gt. 0.) then
interc_c = 0.35 * p%coh%prel(i)
else
interc_c = 0.1 * p%coh%prel(i)
endif
case (14) ! Ground vegetation
if (p%coh%t_leaf .gt. 0.) then
p%coh%prel(i) = precpool(i) * p%coh%BG(i) * p%coh%nTreeA
interc_c = 0.35 * p%coh%prel(i)
else
interc_c = 0.
endif
end select
if (interc_c .le. 1E-15) interc_c = 0.
p%coh%interc = p%coh%interc + interc_c
END IF
1313 CONTINUE
intlay = intlay + interc_c
interc_c = 0.
p => p%next
END DO ! cohort loop
END SUBROUTINE int_coh_loop2
!**************************************************************
SUBROUTINE int_coh_loop3(intlay)
! snow interception for each cohort
!*** Declaration part ***!
USE data_climate
USE data_simul
USE data_soil
USE data_species
USE data_stand
IMPLICIT NONE
! variables required for technical reasons
TYPE(Coh_Obj), Pointer :: p ! pointer to cohort list
INTEGER :: itop ! toplayer
REAL :: intlay ! canopy interception
REAL :: interc_c, & ! interception per cohort
cepcap ! Int.-Kapaz. fuer diese Variante reduzieren
REAL :: help, hxx
real test_prel
test_prel = 0.
interc_c = 0.
p => pt%first
! cohort loop
DO WHILE (ASSOCIATED(p))
ns=p%coh%species
itop = p%coh%toplayer
if(cover.ne.0) p%coh%prel(itop) = prec * p%coh%nTreeA *p%coh%crown_area/crown_area
test_prel = test_prel + p%coh%prel(itop)
select case (ns) ! species
case (1) ! Fagus sylvatica p%coh%x_tb
if (p%coh%t_leaf .gt. 0.) then
interc_c = 0.35 * p%coh%prel(itop)
else
interc_c = 0.1 * p%coh%prel(itop)
endif
case (2,10,15) ! Picea abies, Douglas Fir, Mistletoe (better: nspec_tree+2)
interc_c = 0.35 * p%coh%prel(itop)
case (3,6,7,9) ! Pinus sylvestris, P. contorta, P. ponder. P. halep.
interc_c = 0.6 * p%coh%prel(itop)
case (4,5,8,11) ! Quercus robur, Betula pendula, Populus, Robinia
if (p%coh%t_leaf .gt. 0.) then
interc_c = 0.35 * p%coh%prel(itop)
else
interc_c = 0.1 * p%coh%prel(itop)
endif
case (14) ! Ground vegetation
if (p%coh%t_leaf .gt. 0.) then
interc_c = 0.35 * p%coh%prel(itop)
else
interc_c = 0.
endif
end select
if (interc_c .le. 1E-15) interc_c = 0.
p%coh%interc = p%coh%interc + interc_c
1313 CONTINUE
intlay = intlay + interc_c
interc_c = 0.
p => p%next
END DO ! cohort loop
continue
END SUBROUTINE int_coh_loop3
!**************************************************************
SUBROUTINE intercep_sveg (aev_c)
! Interception of ground vegetation
use data_climate
use data_inter
use data_evapo
use data_par
use data_species
use data_stand
implicit none
real aev_c, & ! canopy interception evaporation
hxx, &
cepmax_sveg
cepmax_sveg = ceppot_sveg * lai_sveg ! max. int. cap. of the whole stand
if (airtemp .ge. temp_snow) then ! frost conditions
hxx = 0.
if (cepmax_sveg .ge. int_st_sveg) hxx = cepmax_sveg-int_st_sveg
interc_sveg = min(hxx, prec-interc_can)
else
interc_sveg = 0.35 * (prec-interc_can)
endif
int_st_sveg = int_st_sveg + interc_sveg
! evaporation of intercepted water aev_i is limited by potential evaporation
aev_i = min(int_st_sveg, pet-aev_c)
int_st_sveg = max(int_st_sveg - aev_i, 0.) ! interception storage from actual day
END SUBROUTINE intercep_sveg
!**************************************************************
SUBROUTINE interc_coh (aev_c)
! Interception of ground vegetation
use data_climate
use data_inter
use data_evapo
use data_species
use data_stand
implicit none
type(Coh_Obj), pointer :: p ! pointer to cohort list
integer ns
real aev_c, & ! canopy interception evaporation
cepmax_sveg
p => pt%first
do while (associated(p))
ns = p%coh%species
if (ns .le. nspec_tree .OR. ns .eq. nspec_tree+2) then
! trees and mistletoe
p%coh%interc_st = int_st_can * p%coh%rel_fol
p%coh%aev_i= aev_c * p%coh%rel_fol
else
! ground vegetation
p%coh%interc_st = int_st_sveg * p%coh%rel_fol
p%coh%aev_i= aev_i * p%coh%rel_fol
endif
p => p%next
enddo ! p (cohorts)
END SUBROUTINE interc_coh
source_code/version_2.3_windows/main_4c.f 0 → 100644
View file @ 82df1085
PROGRAM foresee
! main program for 4C
! Unix Version
! 14.10.04 Su aktuelles Directory (actDir) hier bestimmen
! 16.08.04 Su Schleife ueber run_nr in UP sim_control (File simul.f)
! 24.03.03 pl Aufruf finish_simul fr flag_end>0
! 02.12.02 MF Aufruf SimEnv
! 30.07.02 MF Aufruf SIMENV
! 29.05.02 Su ip-Schleife fuer SIMENV (flag_multi=5) ueberspringen
! call simenv mit Uebergabe von ip
! 26.04.02 Su call out_var_file
! 21.11.01 Su flag_end=2 testen
! 14.05.01 FB call fixclimscen added
! 18.12.97 BE new structure/name
! 11.12.97 BE include same changes for multi_runs
! 27.8.97 BE insert SIM_INI
! 26.8.97 BE insert DO-LOOP for whole program, until choice=end program
! 20.3.97 BE Erweiterung/Umstrukturierung Protokollfile
! USE data_out
USE data_simul
! USE data_stand
! USE data_species
! IMPLICIT NONE
! INTEGER run_nr, ipp
actDir = ''
CALL prepare_global
CALL sim_control
END PROGRAM foresee
source_code/version_2.3_windows/main_4c_cons_win.f90 0 → 100644
View file @ 82df1085
!*****************************************************************!
!* *!
!* 4C (FORESEE) Simulation Model *!
!* *!
!* *!
!* Subroutines for: *!
!* - windows shell - *!
!* *!
!* contains: *!
!* main program for 4C *!
!* *!
!* Copyright (C) 1996-2018 *!
!* Potsdam Institute for Climate Impact Reserach (PIK) *!
!* Authors and contributors see AUTHOR file *!
!* This file is part of 4C and is licensed under BSD-2-Clause *!
!* See LICENSE file or under: *!
!* http://www.https://opensource.org/licenses/BSD-2-Clause *!
!* Contact: *!
!* https://gitlab.pik-potsdam.de/XXXXXXXXXXXXXXXXXXXXX *!
!* *!
!*****************************************************************!
PROGRAM foresee
USE data_simul
real time1, time2
call CPU_time (time1)
call Act_Dir(actDir)
CALL topmenu_win
call CPU_time (time2)
print *, ' 4C total run time ', time2-time1, ' sec'
END PROGRAM foresee
source_code/version_2.3_windows/man_lic.f 0 → 100644
View file @ 82df1085
!*****************************************************************!
!* 4C (FORESEE) Simulation Model *!
!* *!
!* *!
!* contains: *!
!* SR man_liocourt_ini *!
!* SR liocourt_manag *!
!* *!
!* Copyright (C) 1996-2018 *!
!* Potsdam Institute for Climate Impact Reserach (PIK) *!
!* Authors and contributors see AUTHOR file *!
!* This file is part of 4C and is licensed under BSD-2-Clause *!
!* See LICENSE file or under: *!
!* http://www.https://opensource.org/licenses/BSD-2-Clause *!
!* Contact: *!
!* https://gitlab.pik-potsdam.de/foresee/4C *!
!* *!
!*****************************************************************!
Subroutine man_liocourt_ini
USE data_manag
USE data_simul
USE data_plant
USE data_species
implicit none
integer :: manag_unit,i
character(len=150) :: filename
logical :: ex
character :: text
manag_unit=getunit()
filename = manfile(ip)
call testfile(filename,ex)
open(manag_unit,file=trim(filename))
allocate(thin_flag1(nspec_tree))
thin_flag1=-1
! read head of data-file
do
read(manag_unit,*) text
if(text .ne. '!')then
backspace(manag_unit);exit
endif
enddo
read(manag_unit,*) thin_int
read(manag_unit,*) dbh_max
read(manag_unit,*) lic_a
read(manag_unit,*) lic_b
read(manag_unit,*) spec_lic
read(manag_unit,*) thin_proc
if(flag_reg.ne.0) then
read(manag_unit,*) m_numclass
do i = 1, m_numclass
read(manag_unit,*) m_numplant(spec_lic,i), m_specpl(spec_lic,i), m_plant_height(spec_lic,i), m_plant_hmin(spec_lic,i), m_pl_age(spec_lic,i), m_hsdev(spec_lic,i)
end do
end if
close(manag_unit)
end Subroutine man_liocourt_ini
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
Subroutine liocourt_manag
USE data_manag
USE data_stand
USE data_species
USE data_simul
USE data_par
implicit none
integer :: i, ih, nspech
real :: diamh, help, stembiom, stembiom_us, stembiom_all, stembiom_re, target_help, target_biom
target_biom=0.
if(Modulo(time,thin_int).eq.0) then
! calculation of mean diameter (correspondung to med_diam) and basal area of stand
zeig => pt%first
DO
IF (.NOT. ASSOCIATED(zeig)) EXIT
! Modification for V Kint: no test for diameter
IF((zeig%coh%ntreea>0).and.zeig%coh%species.eq.spec_lic.and.zeig%coh%underst.eq.0) THEN
! forester definition
! overstorey
stembiom = stembiom + (zeig%coh%x_sap + zeig%coh%x_hrt)*zeig%coh%ntreea
! Trees with DBH = 0 for population and per species
ELSE IF( (zeig%coh%ntreea>0).and.zeig%coh%species.eq.spec_lic.and.zeig%coh%underst.eq.1) THEN
! seedings/regeneration
stembiom_re = stembiom_re + (zeig%coh%x_sap + zeig%coh%x_hrt)*zeig%coh%ntreea
ELSE if((zeig%coh%ntreea>0).and.zeig%coh%species.eq.spec_lic.and.zeig%coh%underst.eq.2) THEN
! understorey
stembiom_us = stembiom_us + (zeig%coh%x_sap + zeig%coh%x_hrt)*zeig%coh%ntreea
ENDIF
zeig => zeig%next
ENDDO
! mean diamteer for over and understorey
stembiom_all = stembiom + stembiom_us
target_help = stembiom_all*(thin_proc)
ntree_lic(1,spec_lic)=int(lic_a*exp(lic_b*2.5))
Do i=1,21
help=(dclass_w*i + dclass_w*(i+1))/2.
ntree_lic(i+1,spec_lic)= int(lic_a*exp(lic_b*help))*kpatchsize/10000.
end do
zeig=>pt%first
do while (target_biom.lt. target_help)
if(.not.associated(zeig)) exit
if(zeig%coh%diam.gt. dbh_max) then
zeig%coh%ntreem = zeig%coh%ntreea
zeig%coh%ntreea = 0
zeig%coh%nta = 0
diam_class(i,spec_lic) = diam_class(i,spec_lic) - 1
target_biom = target_biom + zeig%coh%ntreem*(zeig%coh%x_sap + zeig%coh%x_hrt)
end if
zeig => zeig%next
end do
do i = 1, num_class
zeig=>pt%first
do
if(.not.associated(zeig)) exit
if(target_help.le.target_biom) exit
nspech = zeig%coh%species
diamh = zeig%coh%diam
ih= i-1
if(diamh.le. dbh_max .and.nspech.eq.spec_lic) then
if(diamh.gt.dclass_w*ih .and. diamh.le. dclass_w*(ih+1) .and. zeig%coh%ntreea.ne.0) then
if((diam_class(i,1)-zeig%coh%ntreea).ge. ntree_lic(i,1)) then
zeig%coh%ntreem = zeig%coh%ntreea
zeig%coh%ntreea = 0
zeig%coh%nta = 0
diam_class(i,spec_lic) = diam_class(i,spec_lic) - zeig%coh%ntreem
target_biom = target_biom + zeig%coh%ntreem*(zeig%coh%x_sap + zeig%coh%x_hrt)
else if(diam_class(i,1).gt. ntree_lic(i,1)) then
zeig%coh%ntreem= diam_class(i,spec_lic) - ntree_lic(i,spec_lic)
zeig%coh%ntreea = zeig%coh%ntreea - zeig%coh%ntreem
zeig%coh%nta = zeig%coh%nta - zeig%coh%ntreem
diam_class(i,spec_lic) = diam_class(i,spec_lic) - zeig%coh%ntreem
target_biom = target_biom + zeig%coh%ntreem*(zeig%coh%x_sap + zeig%coh%x_hrt)
end if
end if
end if
zeig => zeig%next
if (target_biom.ge.target_help) exit
end do ! cohort loop
end do ! loop i for diamter classes
! litter pools
zeig=>pt%first
do
if(.not.associated(zeig)) exit
if(zeig%coh%ntreem>0.and.zeig%coh%species.eq.spec_lic) then
! all parts of trees are input for litter excepting stems
zeig%coh%litC_fol = zeig%coh%litC_fol + zeig%coh%ntreem*(1.-spar(spec_lic)%psf)*zeig%coh%x_fol*cpart
zeig%coh%litN_fol = zeig%coh%litN_fol + zeig%coh%ntreem*((1.-spar(spec_lic)%psf)*zeig%coh%x_fol*cpart)/spar(spec_lic)%cnr_fol
zeig%coh%litC_frt = zeig%coh%litC_frt + zeig%coh%ntreem*zeig%coh%x_frt*cpart
zeig%coh%litN_frt = zeig%coh%litN_frt + zeig%coh%ntreem*zeig%coh%x_frt*cpart/spar(spec_lic)%cnr_frt
zeig%coh%litC_tb = zeig%coh%litC_tb + zeig%coh%ntreem*zeig%coh%x_tb*cpart
zeig%coh%litN_tb = zeig%coh%litN_tb + zeig%coh%ntreem*zeig%coh%x_tb*cpart/spar(spec_lic)%cnr_tbc
zeig%coh%litC_crt = zeig%coh%litC_crt + zeig%coh%ntreem*zeig%coh%x_crt*cpart
zeig%coh%litN_crt = zeig%coh%litN_crt + zeig%coh%ntreem*zeig%coh%x_crt*cpart/spar(spec_lic)%cnr_crt
endif
zeig=>zeig%next
enddo
! calculation of total dry mass of all harvested trees
sumvsab = 0.
sumvsab_m3 = 0.
svar%sumvsab = 0.
zeig=>pt%first
do
if(.not.associated(zeig)) exit
nspech = zeig%coh%species
if(nspech.eq.spec_lic) then
sumvsab = sumvsab + zeig%coh%ntreem*(zeig%coh%x_sap + zeig%coh%x_hrt)
sumvsab_m3 = sumvsab_m3 + zeig%coh%ntreem*(zeig%coh%x_sap + zeig%coh%x_hrt)/(spar(nspech)%prhos*1000000)
svar(nspech)%sumvsab = svar(nspech)%sumvsab + zeig%coh%ntreem*(zeig%coh%x_sap + zeig%coh%x_hrt)
end if
zeig=>zeig%next
end do
sumvsab = sumvsab * 10000./kpatchsize ! kg/ha
sumvsab_m3 = sumvsab_m3 * 10000./kpatchsize ! kg/ha
svar(spec_lic)%sumvsab = svar(spec_lic)%sumvsab * 10000./kpatchsize ! kg/ha
cumsumvsab = cumsumvsab + sumvsab
end if ! loop management time
end Subroutine liocourt_manag
source_code/version_2.3_windows/manag_practices.f 0 → 100644
View file @ 82df1085
!*****************************************************************!
!* *!
!* 4C (FORESEE) Simulation Model *!
!* *!
!* *!
!* contains: *!
!* SR tending *!
!* SR direct_fel *!
!* SR thinning *!
!* SR felling *!
!* SR shelterwood_man *!
!* SR min_dbh *!
!* SR max_dbh *!
!* SR max_diam *!
!* SR min_dbh_overs *!
!* SR min_dbh_tar *!
!* SR target_thinning *!
!* SR calc_usp *!
!* SR calc_gfbg *!
!* SR stump *!
!* *!
!* Copyright (C) 1996-2018 *!
!* Potsdam Institute for Climate Impact Reserach (PIK) *!
!* Authors and contributors see AUTHOR file *!
!* This file is part of 4C and is licensed under BSD-2-Clause *!
!* See LICENSE file or under: *!
!* http://www.https://opensource.org/licenses/BSD-2-Clause *!
!* Contact: *!
!* https://gitlab.pik-potsdam.de/foresee/4C *!
!* *!
!*****************************************************************!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! !
! tending plantations !
! !
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
SUBROUTINE tending(actspec, i)
use data_stand
use data_manag
use data_species
use data_par
use data_simul
implicit none
integer :: tendnr, & ! number of trees to be removed
anz, &
actspec
real :: pequal
integer :: help_tree,min_ident,h1,max_ident, h2 ,cohanz
integer :: taxnr, j, i, thinflag, num_coh, nhelp,anz_actspec
integer, dimension(0:anz_coh) ::cohl
allocate (height_rank(anz_coh))
cohanz = 0
anz_actspec = 0
min_ident=1000
max_ident = 0
cohl=0.
anz=0
! number of trees to removed from the top of the stand
zeig=>pt%first
do
if(.not.associated(zeig)) exit
cohanz = cohanz +1
if(zeig%coh%species.eq.actspec.and. zeig%coh%shelter.ne.1) anz_actspec = anz_actspec + zeig%coh%ntreea
if(zeig%coh%shelter.ne.1) then
if(zeig%coh%ntreea.ne.0.and. zeig%coh%species.eq.actspec) then
h1 = zeig%coh%ident
if( h1.lt. min_ident) min_ident = h1
h2 = zeig%coh%ident
if(h2.gt.max_ident) max_ident = h2
end if
end if
zeig=>zeig%next
end do
if(thr7.ne.2.and.anz_actspec.eq.0) then
deallocate(height_rank)
return
end if
!calculation of relative proportion of stems thinned from tending only of trees which are not shelter trees
tendnr = anz_actspec * tend(actspec)/2
help_tree = tendnr
! determination of heighest tree cohort
! sorting by height of cohorts into the field height_rank containing cohort identifier
call dimsort(anz_coh, 'height',height_rank)
! removing of trees
do j= anz_coh, 1, -1
zeig=>pt%first
do
if(.not.associated(zeig)) exit
if(zeig%coh%shelter.ne.1. .and. zeig%coh%species.eq.specnr(i)) then
if(zeig%coh%ident.eq.height_rank(j)) then
if(zeig%coh%ntreea.ge.tendnr) then
zeig%coh%ntreea = zeig%coh%ntreea - help_tree
zeig%coh%ntreet = help_tree
help_tree = 0.
else
! number of trees to be left
help_tree = help_tree-zeig%coh%ntreea
! number of trees removed
zeig%coh%ntreet = zeig%coh%ntreea
zeig%coh%ntreea = 0
end if
end if
end if
zeig=> zeig%next
end do
if(help_tree.le.0 ) exit
end do
! second part of felling, equal distributed from all cohorts
! equal distribution from all cohorts with trees
nhelp = tendnr
zeig=>pt%first
do
if(.not.associated(zeig)) exit
if(zeig%coh%species.eq.actspec) then
end if
zeig=>zeig%next
end do
do
j=0
thinflag = 0
call random_number(pequal)
num_coh = min_ident + (max_ident - min_ident) * pequal
zeig=>pt%first
do
if(.not.associated(zeig)) exit
if(zeig%coh%shelter.ne.1.and. zeig%coh%species.eq.actspec) then
j = j+1
if (zeig%coh%ident.eq.num_coh) then
! check the value ntreea before
if(zeig%coh%ntreea.ge.1) then
zeig%coh%ntreea = zeig%coh%ntreea - 1
zeig%coh%nta = zeig%coh%ntreea
zeig%coh%ntreet = zeig%coh%ntreet + 1
nhelp = nhelp -1
thinflag = 1
else
exit
endif
end if
if(thinflag.eq.1) exit
end if
zeig => zeig%next
end do
if(nhelp.eq.0) exit
end do
! all biomasses are added to litter pools
zeig=>pt%first
do
if(.not.associated(zeig)) exit
taxnr=zeig%coh%species
if(zeig%coh%ntreet>0.and.taxnr.eq.specnr(i))then
! all parts of trees are input for litter
zeig%coh%litC_fol = zeig%coh%litC_fol + zeig%coh%ntreet*(1.-spar(taxnr)%psf)*zeig%coh%x_fol*cpart
zeig%coh%litN_fol = zeig%coh%litN_fol + zeig%coh%ntreet*((1.-spar(taxnr)%psf)*zeig%coh%x_fol*cpart)/spar(taxnr)%cnr_fol
zeig%coh%litC_frt = zeig%coh%litC_frt + zeig%coh%ntreet*zeig%coh%x_frt*cpart
zeig%coh%litN_frt = zeig%coh%litN_frt + zeig%coh%ntreet*zeig%coh%x_frt*cpart/spar(taxnr)%cnr_frt
zeig%coh%litC_tb = zeig%coh%litC_tb + zeig%coh%ntreet*zeig%coh%x_tb*cpart
zeig%coh%litN_tb = zeig%coh%litN_tb + zeig%coh%ntreet*zeig%coh%x_tb*cpart/spar(taxnr)%cnr_tbc
zeig%coh%litC_crt = zeig%coh%litC_crt + zeig%coh%ntreet*zeig%coh%x_crt*cpart
zeig%coh%litN_crt = zeig%coh%litN_crt + zeig%coh%ntreet*zeig%coh%x_crt*cpart/spar(taxnr)%cnr_crt
zeig%coh%litC_stem = zeig%coh%litC_stem + zeig%coh%ntreet*(zeig%coh%x_sap+zeig%coh%x_hrt)*cpart
zeig%coh%litN_stem = zeig%coh%litC_stem/spar(taxnr)%cnr_stem
zeig%coh%ntreet = 0
endif
zeig=>zeig%next
enddo
thinyear(actspec)=time
deallocate(height_rank)
END SUBROUTINE tending
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Rueckegasse directional felling
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
SUBROUTINE direct_fel(hox)
use data_manag
use data_stand
use data_simul
use data_par
use data_species
implicit none
integer :: num_felt=0, &
num_coh=0, &
i, &
thinflag, &
taxnr, &
nhelp
real :: pequal, &
hox
thinflag = 0
if(thr5.eq.1) then
if (thr6.eq.hox) then
! felling of direcfel*anz_tree trees equal distributed from all cohorts
num_felt = direcfel*anz_tree
nhelp = num_felt
do
i=0
thinflag = 0
call random_number(pequal)
num_coh = nint(pequal * anz_coh)+1
zeig=>pt%first
do
if(.not.associated(zeig)) exit
i = i+1
if (i.eq.num_coh) then
! check the value ntreea before
if(zeig%coh%ntreea.ge.1) then
zeig%coh%ntreea = zeig%coh%ntreea - 1
zeig%coh%ntreem = zeig%coh%ntreem + 1
nhelp = nhelp -1
thinflag = 1
else
exit
endif
end if
if(thinflag.eq.1) exit
zeig => zeig%next
end do
if(nhelp.eq.0) exit
end do
flag_direct=1
end if
end if
! adding biomasses to litter pools depending on stage of stand
zeig=>pt%first
do
if(.not.associated(zeig)) exit
taxnr=zeig%coh%species
if(zeig%coh%ntreem>0)then
! all parts without stems of trees are input for litter
zeig%coh%litC_fol = zeig%coh%litC_fol + zeig%coh%ntreem*(1.-spar(taxnr)%psf)*zeig%coh%x_fol*cpart
zeig%coh%litN_fol = zeig%coh%litN_fol + zeig%coh%ntreem*((1.-spar(taxnr)%psf)*zeig%coh%x_fol*cpart)/spar(taxnr)%cnr_fol
zeig%coh%litC_frt = zeig%coh%litC_frt + zeig%coh%ntreem*zeig%coh%x_frt*cpart
zeig%coh%litN_frt = zeig%coh%litN_frt + zeig%coh%ntreem*zeig%coh%x_frt*cpart/spar(taxnr)%cnr_frt
zeig%coh%litC_tb = zeig%coh%litC_tb + zeig%coh%ntreet*zeig%coh%x_tb*cpart
zeig%coh%litN_tb = zeig%coh%litN_tb + zeig%coh%ntreet*zeig%coh%x_tb*cpart/spar(taxnr)%cnr_tbc
zeig%coh%litC_crt = zeig%coh%litC_crt + zeig%coh%ntreet*zeig%coh%x_crt*cpart
zeig%coh%litN_crt = zeig%coh%litN_crt + zeig%coh%ntreet*zeig%coh%x_crt*cpart/spar(taxnr)%cnr_crt
endif
zeig=>zeig%next
enddo
END SUBROUTINE direct_fel
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! different thinning regimes (1-4) for trees with dominant height above ho2
! thinning regime 1 - moderate low-thinning / mssige Niederdurchforstung
! thinning regime 2 - strong/heavy low-thinning / starke Niederdurchforstung
! thinning regime 3 - high-thinning / Hochdurchforstung
! thinning regime 4 - selective thinning (from upper or middle thirg of thickest trees
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
SUBROUTINE thinning(c1,c2,actspec, inum)
use data_stand
use data_manag
use data_simul
use data_species
use data_par
implicit none
real :: dbhmin=0, &
wpa=0, & ! Weibull parameter
wpb=0, & ! -"-
wpc=0, & ! -"-
d63=0, &
pequal, &
tdbh=0, &
bas_help=0., &
dbh_h =0, &
db_l = 0., &
db_u = 0., &
c1, &
d_est=0., &
w_kb=0., &
c_usp
real :: help_cra, & ! actual crown area
density, & ! ratio of crown area to patch size
bas_target, & ! relative value for basal area thinning
bas_area, &
help
real :: hg, & ! hight of base area mean stem
bg, & ! degree of tillering
dfbg, & ! opt. base area
stage, & ! actual age
basha, &
stump_v, & ! volume and dry weight of stump
stump_dw
integer :: nrmin, &
flagth, &
c2, &
taxnr, &
nhelp1, &
counth, &
nhelp2, &
zbnr_pa, &
callnum, &
actspec, inum ! number of species for thinning
integer :: lowtree, agedm
! auxilarity for thinning routine 4: selective thinning
integer :: nrmax,anz,anz1,count,flagexit, flagc, num_thin,j, &
nhelp,idum ,numtr, third,anztree_ha,i
integer,dimension(0:anz_coh) :: cohl
real :: meanzb, stand,xhelp, sumdh, sumd, hh ,rel_bas
real,external :: gasdev
real,dimension(nspecies) :: cr_rel ! relative part of species specific crown area of total crown area
! target calculation for basal area reduction
bas_target = ((time-thinyear(actspec))/5)*0.05
bas_area = 0.
bas_help = 0.
help_cra = 0.
cr_rel = 1.
callnum = 0
count = 0
cohl = -1
flagth = 0
help=0.
lowtree=0
anztree_ha = nint(anz_tree_dbh*10000./kpatchsize)
third = nint(anz_tree_dbh*0.333333)
sumdh = 0.; sumd = 0.
! calculation of mean diameter (corresponding to med_diam) and basal area of stand
! calculation hg ( hight of base area mean stem)
i = inum
zeig => pt%first
DO
IF (.NOT. ASSOCIATED(zeig)) EXIT
if(zeig%coh%species.eq.actspec) then
stage = zeig%coh%x_age
help_cra = help_cra + zeig%coh%ntreea* zeig%coh%crown_area
IF((zeig%coh%ntreea>0).and.(zeig%coh%diam>0)) THEN
! foresters defenition
sumd = sumd + zeig%coh%diam*zeig%coh%diam
sumdh = sumdh + zeig%coh%diam*zeig%coh%diam* zeig%coh%height
help = help + zeig%coh%ntreea*(zeig%coh%diam**2)
bas_area = bas_area + zeig%coh%ntreea*(zeig%coh%diam**2)*pi/4.
ELSE
! trees with DBH = 0 for population and species
lowtree = lowtree + zeig%coh%ntreea
ENDIF
end if
zeig => zeig%next
ENDDO ! cohorts
hg = (sumdh/sumd)/100.
! basal area /ha
basha = bas_area/kpatchsize ! cm/patch ---> m/ha
rel_bas = bas_area/basarea_tot
if(thin_ob.eq.1) then
! calculation of optimal basal area (Brandenburg) per patchsize
call calc_gfbg(dfbg,specnr(i), stage, hg)
! correction
dfbg = dfbg* kpatchsize ! m/ha ---> cm/patchsize
if(anz_spec.eq.1) then
if(dfbg.lt.0.5*bas_area) dfbg = 0.5*bas_area
! calculation of BG (Bestockungsgrad)
else
! calculation of relative part of crown area
cr_rel(actspec) = svar(actspec)%crown_area / crown_area
end if
bg = rel_bas*bas_area/dfbg
! calculation of basale area target depending on target optb 'Bestockungsgrad'
bas_target = rel_bas*optb*dfbg
else
! calculation of density dependent target for thinning
density = help_cra/kpatchsize
call calc_usp (actspec,age_spec(i),density,c_usp)
! Modification of 'Nutzungsprozent' to avoid large number for c_usp
c_usp = c_usp*np_mod(actspec)
if(thinyear(actspec).eq.0) then
hh = c_usp*(time)/10.
if(hh.lt.0.7) then
c_usp = hh
else
c_usp = 0.5
end if
bas_target = bas_area - bas_area*c_usp
else
! Modification
if(c_usp.gt.0.4) then
c_usp =c_usp * (time -thinyear(actspec))/20.
end if
bas_target = bas_area - bas_area*c_usp
end if
end if
select case(c2)
case(1:3)
! different thinnings from below and above
select case(c2)
case(1)
! moderate low-thinning
d_est = 1.02
! change of w_kb to exclude small diameter classes
w_kb = 2.5
case(2)
! high low-thinning
d_est = 1.03
w_kb = 1.5
case(3)
! high-thinning
d_est = 1.04
w_kb = 1.2
end select
! calculation of Weibull-Parameter
if(bas_area.gt.bas_target) then
call min_dbh(nrmin,dbhmin,agedm,actspec)
bas_help = bas_area
wpa = dbhmin
d63 = svar(actspec)%med_diam * d_est
wpb = (d63 - wpa)/ w_kb
wpc = 2
! selection of trees for thinning
do
call random_number(pequal)
tdbh = wpa + wpb*(-log(1.-pequal))**(1./wpc)
callnum = callnum +1
flagth = 0
zeig => pt%first
DO
IF (.NOT. ASSOCIATED(zeig)) EXIT
if(zeig%coh%species.eq.actspec) then
if(zeig%coh%diam.gt.0.) then
dbh_h = zeig%coh%diam
db_l = dbh_h - 0.1*dbh_h
db_u = dbh_h + 0.1*dbh_h
if (tdbh.ge.db_l.and.tdbh.le.db_u.and. zeig%coh%ntreea.ne. 0) then
zeig%coh%ntreea = zeig%coh%ntreea -1
zeig%coh%nta = zeig%coh%ntreea
zeig%coh%ntreem = zeig%coh%ntreem +1
bas_help = bas_help - (zeig%coh%diam**2)*pi/4.
flagth = 1
end if
if(flagth.eq.1) exit
end if
end if
zeig=> zeig%next
END DO ! cohorts
if(bas_help .le. bas_target) exit
end do ! selection of trees
end if
case(4)
! selective thinning
! normal(or equal) distributed thinning from one third of the trees (upper or middle): n*anz_ziel or
! depending an basal area
! ho2: n=2; ho3,ho4: n=1.5 ho>ho4: n=1
! determination of the third of trees with the thickest diameter (sorting of cohorts concerning diameter
! necessary: normal distribution with 2 parameters: mean diameter of the third and standard deviation
DO i=1,anz_spec
!Calculation of number of thinning trees
IF ( c1.eq.ho2) THEN
num_thin = NINT(2* zbnr(specnr(i))*kpatchsize/10000.)
ELSE IF( c1.eq.ho3.or.c1.eq.ho4) THEN
! change of num_thin because of errors during thinning
num_thin = NINT(zbnr(specnr(i))*kpatchsize/10000.)
ELSE
num_thin = NINT(zbnr(specnr(i))*kpatchsize/10000.)
END IF
if(anztree_ha.lt.(zbnr(specnr(i))+ zbnr(specnr(i))*0.2)) return
! determine cohorts which fulfill the upper third --> selected for thinning
anz = 0
flagexit = 0
flagc = 0
if(anz_tree_dbh>1) then
do
call max_diam(nrmax,anz,cohl, specnr(i))
zeig=>pt%first
do
if(.not.associated(zeig)) exit
if(zeig%coh%diam.gt.0) then
if(zeig%coh%ident.eq.nrmax) then
count = count + zeig%coh%ntreea
if(count.ge. third) flagexit = 1
flagc = 1
end if
if (flagc.eq. 1) exit
end if
zeig=>zeig%next
end do
if(flagexit.eq.1) exit
flagc = 0
end do
end if
IF(c1.eq.0) THEN
! determine cohorts which fulfill the middle third of thickness
! if the number of one third is not definded by an even number of cohorts
! the middle third starts in the last cohort of the upper third
! some refinements are possible: the number of trees are marked in each cohort which
! are available for thinning (may be in the last cohort of the thirg only x%)
if(count.eq.third) then
anz1 = anz+1
else
anz1 = anz
anz = anz-1
end if
count = 0
flagexit = 0
flagc = 0
if(anz_tree>1) THEN
do
call max_diam(nrmax,anz,cohl, specnr(i))
zeig=>pt%first
do
if(.not.associated(zeig)) exit
if(zeig%coh%ident.eq.nrmax) then
count = count + zeig%coh%ntreea
if(count.ge. third) flagexit = 1
flagc = 1
end if
if (flagc.eq. 1) exit
zeig=>zeig%next
end do
if(flagexit.eq.1) exit
flagc = 0
end do
end if
ENDIF
! calculation on mean and standard deviation of cohorts selected for thinning
stand = 0.
if(c1.ne.0) anz1 =1
meanzb = 0.
counth = 0
do j = anz1,anz
zeig=>pt%first
do
if(.not.associated(zeig)) exit
nrmax = cohl(j-1)
if (zeig%coh%ident.eq.nrmax) then
meanzb = meanzb + zeig%coh%ntreea*zeig%coh%diam
counth = counth + zeig%coh%ntreea
end if
zeig=>zeig%next
end do
end do
! mean value
meanzb = meanzb/count
! standard deviation
do j = anz1,anz
zeig=>pt%first
do
if(.not.associated(zeig)) exit
nrmax = cohl(j-1)
if (zeig%coh%ident.eq.nrmax) then
stand = stand+ zeig%coh%ntreea*(zeig%coh%diam - meanzb)*(zeig%coh%diam - meanzb)
end if
zeig=>zeig%next
end do
end do
stand = sqrt(stand/count)
! thinning of num_thin trees from the upper third
! using normal distribution
! if ho>ho4 the selection of trees from the middle third is controlled by basal area
! a reduction of basal area by 10%
idum = -1
nhelp = num_thin
numtr = 0
bas_help=bas_area
do j=anz1,anz
zeig=>pt%first
DO
IF (.NOT. ASSOCIATED(zeig)) EXIT
if(zeig%coh%ident.eq.cohl(j-1)) numtr = numtr+zeig%coh%ntreea
zeig=>zeig%next
end do
end do
nhelp1 = anz_tree
nhelp2 = count
if(nhelp.gt.numtr) nhelp = numtr
DO
xhelp= meanzb+stand*gasdev(idum)
flagth = 0
DO j = anz1, anz
zeig => pt%first
DO
IF (.NOT. ASSOCIATED(zeig)) EXIT
if(zeig%coh%ident.eq.cohl(j-1)) then
dbh_h = zeig%coh%diam
db_l = dbh_h - 0.1*dbh_h
db_u = dbh_h + 0.1*dbh_h
if (xhelp.ge.db_l.and.xhelp.le.db_u.and. zeig%coh%ntreea.ne. 0) then
zeig%coh%ntreea = zeig%coh%ntreea -1
zeig%coh%nta = zeig%coh%ntreea
zeig%coh%ntreem = zeig%coh%ntreem +1
if(c1.eq.0) then
bas_help = bas_help - (zeig%coh%diam**2)*pi*0.25
nhelp1 = nhelp1 -1
nhelp2 = nhelp2 -1
else
nhelp= nhelp -1
endif
flagth = 1
end if
end if
if(flagth.eq.1) exit
zeig=> zeig%next
ENDDO
if(flagth.eq.1) exit
END DO
! criteria of finishing thinning
zbnr_pa = nint(zbnr(specnr(i))*kpatchsize/10000.)
if(c1.eq.0 .and.( bas_help.le.(bas_area - bas_area*bas_target).or.nhelp1.eq.zbnr_pa) ) exit
if(c1.eq.0 .and.( nhelp1.eq.0 .or. nhelp2.eq.0)) exit
if(c1.ne.0 .and. nhelp.eq.0) exit
ENDDO
END DO ! speices loop
end select
! adding biomasses to litter pools depending on stage of stand
stump_sum = 0
zeig=>pt%first
do
if(.not.associated(zeig)) exit
taxnr=zeig%coh%species
if(zeig%coh%ntreem>0)then
! all parts without stems of trees are input for litter
zeig%coh%litC_fol = zeig%coh%litC_fol + zeig%coh%ntreem*(1.-spar(taxnr)%psf)*zeig%coh%x_fol*cpart
zeig%coh%litN_fol = zeig%coh%litN_fol + zeig%coh%ntreem*((1.-spar(taxnr)%psf)*zeig%coh%x_fol*cpart)/spar(taxnr)%cnr_fol
zeig%coh%litC_frt = zeig%coh%litC_frt + zeig%coh%ntreem*zeig%coh%x_frt*cpart
zeig%coh%litN_frt = zeig%coh%litN_frt + zeig%coh%ntreem*zeig%coh%x_frt*cpart/spar(taxnr)%cnr_frt
zeig%coh%litC_tb = zeig%coh%litC_tb + zeig%coh%ntreem*zeig%coh%x_tb*cpart
zeig%coh%litN_tb = zeig%coh%litN_tb + zeig%coh%ntreem*zeig%coh%x_tb*cpart/spar(taxnr)%cnr_tbc
zeig%coh%litC_crt = zeig%coh%litC_crt + zeig%coh%ntreem*zeig%coh%x_crt*cpart
zeig%coh%litN_crt = zeig%coh%litN_crt + zeig%coh%ntreem*zeig%coh%x_crt*cpart/spar(taxnr)%cnr_crt
! stumps into stem litter
call stump( zeig%coh%x_ahb, zeig%coh%asapw,zeig%coh%dcrb,zeig%coh%x_hbole, &
zeig%coh%height, taxnr,stump_v, stump_dw)
zeig%coh%litC_stem = zeig%coh%litC_stem + zeig%coh%ntreem*stump_dw*cpart
zeig%coh%litN_stem = zeig%coh%litC_stem/spar(taxnr)%cnr_stem
stump_sum = stump_sum + zeig%coh%ntreem*stump_dw
if(maninf.eq.'brushing'.and.flag_brush.ne.0) then
zeig%coh%litC_stem =zeig%coh%litC_stem + zeig%coh%ntreem*(zeig%coh%x_sap+zeig%coh%x_hrt)*cpart
zeig%coh%litN_stem = zeig%coh%litC_stem/spar(taxnr)%cnr_stem
end if
endif
zeig=>zeig%next
enddo
END SUBROUTINE thinning
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
! SR for clear cut
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
SUBROUTINE felling(nr,i)
use data_stand
use data_manag
use data_simul
use data_species
use data_par
use data_soil_cn
implicit none
integer :: taxnr, i, nr
real :: stump_v, stump_dw, help
zeig=>pt%first
do
if(.not.associated(zeig)) exit
taxnr = zeig%coh%species
if(taxnr.le.nspec_tree) then
if(thr7.eq.2.and. taxnr.eq.nr) then
zeig%coh%ntreem = zeig%coh%ntreea
zeig%coh%ntreea = 0
zeig%coh%nta = 0.
else if(thr7.ne.2.and. taxnr.eq.nr.and. zeig%coh%x_age.eq.age_spec(i).and. zeig%coh%shelter.eq.1) then
zeig%coh%ntreem = zeig%coh%ntreea
zeig%coh%ntreea = 0
zeig%coh%nta = 0.
end if
else
! reduction of soil vegetation after felling
taxnr = zeig%coh%species
help = zeig%coh%x_fol
zeig%coh%x_fol = 0.005*help
zeig%coh%litC_fol = zeig%coh%litC_fol + 0.995*zeig%coh%ntreem*(1.-spar(taxnr)%psf)*help*cpart
zeig%coh%litN_fol = zeig%coh%litN_fol + 0.995*zeig%coh%ntreem*((1.-spar(taxnr)%psf)*help*cpart)/spar(taxnr)%cnr_fol
help = zeig%coh%x_frt
zeig%coh%x_frt = 0.005*help
zeig%coh%litC_frt = zeig%coh%litC_frt + 0.995*zeig%coh%ntreem*help*cpart
zeig%coh%litN_frt = zeig%coh%litN_frt + 0.995*zeig%coh%ntreem*help*cpart/spar(taxnr)%cnr_frt
help = zeig%coh%x_sap
zeig%coh%x_sap = 0.005*help
zeig%coh%litC_fol = zeig%coh%litC_fol + 0.995*zeig%coh%ntreem*help*cpart
zeig%coh%litN_fol = zeig%coh%litN_fol + 0.995*zeig%coh%ntreem*((1.-spar(taxnr)%psf)*help*cpart)/spar(taxnr)%cnr_fol
zeig%coh%Fmax = zeig%coh%x_fol
zeig%coh%t_leaf = zeig%coh%med_sla* zeig%coh%x_fol ! [m2]
zeig%coh%nta = zeig%coh%nTreeA
end if
zeig=>zeig%next
end do
zeig=>pt%first
do
if(.not.associated(zeig)) exit
taxnr=zeig%coh%species
if(zeig%coh%ntreem>0.and. taxnr.eq.nr)then
! all parts without stems of trees are input for litter
zeig%coh%litC_fol = zeig%coh%litC_fol + zeig%coh%ntreem*(1.-spar(taxnr)%psf)*zeig%coh%x_fol*cpart
zeig%coh%litN_fol = zeig%coh%litN_fol + zeig%coh%ntreem*((1.-spar(taxnr)%psf)*zeig%coh%x_fol*cpart)/spar(taxnr)%cnr_fol
zeig%coh%litC_frt = zeig%coh%litC_frt + zeig%coh%ntreem*zeig%coh%x_frt*cpart
zeig%coh%litN_frt = zeig%coh%litN_frt + zeig%coh%ntreem*zeig%coh%x_frt*cpart/spar(taxnr)%cnr_frt
zeig%coh%litC_tb = zeig%coh%litC_tb + zeig%coh%ntreem*zeig%coh%x_tb*cpart
zeig%coh%litN_tb = zeig%coh%litN_tb + zeig%coh%ntreem*zeig%coh%x_tb*cpart/spar(taxnr)%cnr_tbc
zeig%coh%litC_crt = zeig%coh%litC_crt + zeig%coh%ntreem*zeig%coh%x_crt*cpart
zeig%coh%litN_crt = zeig%coh%litN_crt + zeig%coh%ntreem*zeig%coh%x_crt*cpart/spar(taxnr)%cnr_crt
! stumps into stem litter
call stump( zeig%coh%x_ahb, zeig%coh%asapw,zeig%coh%dcrb,zeig%coh%x_hbole, &
zeig%coh%height, taxnr,stump_v, stump_dw)
zeig%coh%litC_stem = zeig%coh%litC_stem + zeig%coh%ntreem*stump_dw*cpart
zeig%coh%litN_stem = zeig%coh%litC_stem/spar(taxnr)%cnr_stem
stump_sum = stump_sum + zeig%coh%ntreem*stump_dw
endif
zeig=>zeig%next
enddo
END SUBROUTINE felling
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
! subroutine for shelterwood management
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
SUBROUTINE shelterwood_man(nrsh,inum,domage)
use data_stand
use data_manag
use data_simul
use data_par
use data_species
implicit none
real :: bared, & ! reduction of basal area
bas_help, &
bas_area, &
pequal, &
domage, &
help, &
stump_v, &
stump_dw
integer :: taxnr, &
flagc, &
flagexit, &
num_coh, &
thinflag, j, &
count, third,&
counth, &
anz_treesh=0, &
anz_2th, &
nrsh, &
minident, &
inum, help_shnum
integer, dimension(1:anz_coh) :: coh_2th
allocate (dbh_rank(anz_coh))
minident = 100000
bas_area = 0.
anz_treesh = 0
help_shnum = 0
! tending of trees, planted at first shelterwood treatment
help = time - shelteryear
IF(help.eq.15..and.flag_shelter.eq.1 .and.shelteryear.ne.0) THEN
call tending(nrsh,inum)
END IF
! labelling of trees for shelterwood at first shelterwood treatment
if (shelteryear.eq.0.or.shelteryear.eq.time) then
zeig=>pt%first
do
if(.not.associated(zeig)) exit
write(5432,*) zeig%coh%ntreea
if(zeig%coh%species.eq.nrsh.and.zeig%coh%x_age.gt.10) zeig%coh%shelter = 1.
zeig=> zeig%next
end do
end if
! calculation of number of shelter trees
zeig=>pt%first
do
if(.not.associated(zeig)) exit
if(zeig%coh%shelter.eq.1.and. zeig%coh%species.eq.nrsh) anz_treesh = anz_treesh +zeig%coh%ntreea
zeig=>zeig%next
end do
write(5432,*) time, 'anz_treesh', anz_treesh
count = 0
IF((time-shelteryear).eq.15 .or. shelteryear .eq. 0..or.shelteryear.eq.time) THEN
call dimsort(anz_coh, 'dbh',dbh_rank)
flag_manreal = 1
if (shelteryear.eq.0) then
maninf = 'shelterwood system1'
else
maninf = 'shelterwood system2'
end if
meas = 0
third = nint(anz_treesh*0.3333333)
taxnr = nrsh
! calculation of basal area of shelterwood
zeig => pt%first
DO
IF (.NOT. ASSOCIATED(zeig)) EXIT
if(zeig%coh%shelter.eq.1.and. zeig%coh%species.eq.taxnr) then
IF((zeig%coh%ntreea>0).and.(zeig%coh%diam>0)) THEN
bas_area = bas_area + zeig%coh%ntreea*(zeig%coh%diam**2)*pi/4.
End if
end if
zeig => zeig%next
ENDDO
! declaration of reduction coefficient of basal area
if(domage.eq.regage(domspec)) then
bared = 0.3
else
bared = 0.4
end if
! lower two thirds sorted by diameter in coh_2th
counth = 0
flagexit = 0
flagc = 0
anz_2th = 0
coh_2th = -1
if(anz_tree>1) then
do j = 1,anz_coh
zeig => pt%first
do
if(.not.associated(zeig)) exit
if(zeig%coh%ident.eq.dbh_rank(j).and.zeig%coh%shelter.eq.1.and. zeig%coh%species.eq.nrsh) then
counth = counth + zeig%coh%ntreea
anz_2th = anz_2th +1
if(counth.ge.2*third) flagexit =1
coh_2th(anz_2th) = zeig%coh%ident
if(zeig%coh%ident.lt.minident) minident =zeig%coh%ident
flagc = 1
end if
if(flagc.eq.1) exit
zeig=>zeig%next
end do
if (flagexit.eq.1) exit
flagc = 0
end do
end if
! thinning with equal distribution from cohorts listed in coh_2th
bas_help = bas_area
DO
flagexit = 0
thinflag = 0
call random_number(pequal)
num_coh = nint(pequal*anz_2th + 0.5)
zeig=> pt%first
do
if(.not.associated(zeig)) exit
if(zeig%coh%ident.eq.coh_2th(num_coh).and.zeig%coh%shelter.eq.1.and. zeig%coh%species.eq.nrsh) then
if(zeig%coh%ntreea.ge.1) then
zeig%coh%ntreea = zeig%coh%ntreea - 1
help_shnum = help_shnum +1
zeig%coh%nta = zeig%coh%nta -1.
zeig%coh%ntreem = zeig%coh%ntreem + 1
bas_help = bas_help - (zeig%coh%diam**2)*pi/4
thinflag = 1
end if
end if
if(thinflag.eq.1) exit
zeig=>zeig%next
end do
if(bas_help.le.(bas_area -bas_area*bared)) exit
if(help_shnum.eq. counth) exit
END DO
! adding biomasses to litter pools depending on stage of stand
if(anz_treesh>0) then
zeig=>pt%first
do
if(.not.associated(zeig)) exit
taxnr=zeig%coh%species
if(zeig%coh%ntreem>0..and. zeig%coh%species.eq.nrsh)then
! all parts without stems of trees are input for litter
zeig%coh%litC_fol = zeig%coh%litC_fol + zeig%coh%ntreem*(1.-spar(taxnr)%psf)*zeig%coh%x_fol*cpart
zeig%coh%litN_fol = zeig%coh%litN_fol + zeig%coh%ntreem*((1.-spar(taxnr)%psf)*zeig%coh%x_fol*cpart)/spar(taxnr)%cnr_fol
zeig%coh%litC_frt = zeig%coh%litC_frt + zeig%coh%ntreem*zeig%coh%x_frt*cpart
zeig%coh%litN_frt = zeig%coh%litN_frt + zeig%coh%ntreem*zeig%coh%x_frt*cpart/spar(taxnr)%cnr_frt
zeig%coh%litC_tb = zeig%coh%litC_tb + zeig%coh%ntreem*zeig%coh%x_tb*cpart
zeig%coh%litN_tb = zeig%coh%litN_tb + zeig%coh%ntreem*zeig%coh%x_tb*cpart/spar(taxnr)%cnr_tbc
zeig%coh%litC_crt = zeig%coh%litC_crt + zeig%coh%ntreem*zeig%coh%x_crt*cpart
zeig%coh%litN_crt = zeig%coh%litN_crt + zeig%coh%ntreem*zeig%coh%x_crt*cpart/spar(taxnr)%cnr_crt
! stumps into stem litter
call stump( zeig%coh%x_ahb, zeig%coh%asapw,zeig%coh%dcrb,zeig%coh%x_hbole, &
zeig%coh%height,taxnr, stump_v, stump_dw)
zeig%coh%litC_stem = zeig%coh%litC_stem + zeig%coh%ntreem*stump_dw*cpart
zeig%coh%litN_stem = zeig%coh%litC_stem/spar(taxnr)%cnr_stem
stump_sum = stump_sum + zeig%coh%ntreem*stump_dw
! stump biomass is added to stem litter litC_stem, litN_stem
endif
zeig=>zeig%next
enddo
END IF
end if ! anz_treesh
deallocate(dbh_rank)
END SUBROUTINE shelterwood_man
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
SUBROUTINE min_dbh(nrmin,help_h1,agedm, spnr)
use data_stand
implicit none
integer :: nrmin,spnr, agedm, agedmh
integer :: nrmin_h
integer :: testflag
real :: help_h1, help_h2
testflag=0
agedm = -1
agedmh = -1
nrmin = -1
nrmin_h = -1
help_h2=0.
help_h1=1000.
zeig=>pt%first
do
if(.not.associated(zeig)) exit
if(zeig%coh%species.eq.spnr) then
if(zeig%coh%diam.gt.0.) then
help_h2= zeig%coh%diam
nrmin_h = zeig%coh%ident
agedmh = zeig%coh%x_age
if(help_h2.lt. help_h1) then
help_h1 = help_h2
nrmin = nrmin_h
agedm = agedmh
end if
end if
end if
zeig=>zeig%next
end do
END SUBROUTINE min_dbh
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
SUBROUTINE min_dbh_tar(nrmin,help_h1,spnr,tar)
use data_stand
implicit none
integer :: nrmin,spnr
integer :: nrmin_h
integer :: testflag
real :: help_h1, help_h2
real :: tar
testflag=0
nrmin = -1
nrmin_h = -1
help_h2=0.
help_h1=1000.
zeig=>pt%first
do
if(.not.associated(zeig)) exit
if(zeig%coh%species.eq.spnr) then
if(zeig%coh%diam.gt.0..and. zeig%coh%height.gt.tar) then
help_h2= zeig%coh%diam
nrmin_h = zeig%coh%ident
if(help_h2.lt. help_h1) then
help_h1 = help_h2
nrmin = nrmin_h
end if
end if
end if
zeig=>zeig%next
end do
END SUBROUTINE min_dbh_tar
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
SUBROUTINE min_dbh_overs(nrmin,help_h1,spnr)
use data_stand
implicit none
integer :: nrmin,spnr
integer :: nrmin_h
integer :: testflag
real :: help_h1, help_h2
testflag=0
nrmin = -1
nrmin_h = -1
help_h2=0.
help_h1=1000.
zeig=>pt%first
do
if(.not.associated(zeig)) exit
if(zeig%coh%species.eq.spnr) then
if(zeig%coh%diam.gt.0..and. zeig%coh%underst.eq.0) then
help_h2= zeig%coh%diam
nrmin_h = zeig%coh%ident
if(help_h2.lt. help_h1) then
help_h1 = help_h2
nrmin = nrmin_h
end if
end if
end if
zeig=>zeig%next
end do
END SUBROUTINE min_dbh_overs
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
SUBROUTINE min_dbh_unders(nrmin,help_h1,spnr)
use data_stand
implicit none
integer :: nrmin,spnr
integer :: nrmin_h
integer :: testflag
real :: help_h1, help_h2
testflag=0
nrmin = -1
nrmin_h = -1
help_h2=0.
help_h1=1000.
zeig=>pt%first
do
if(.not.associated(zeig)) exit
if(zeig%coh%species.eq.spnr) then
if(zeig%coh%diam.gt.0..and. zeig%coh%underst.eq.2) then
help_h2= zeig%coh%diam
nrmin_h = zeig%coh%ident
if(help_h2.lt. help_h1) then
help_h1 = help_h2
nrmin = nrmin_h
end if
end if
end if
zeig=>zeig%next
end do
END SUBROUTINE min_dbh_unders
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
SUBROUTINE max_dbh(nrmax,help_h1,agedm,spnr)
use data_stand
implicit none
integer :: nrmax,spnr, agedm, agedmh
integer :: nrmax_h
integer :: testflag
real :: help_h1, help_h2
testflag=0
agedm =-1
agedmh = -1
nrmax = -1
nrmax_h = -1
help_h2=0.
help_h1=0.
zeig=>pt%first
do
if(.not.associated(zeig)) exit
if(zeig%coh%species.eq.spnr) then
if(zeig%coh%diam.gt.0.) then
help_h2= zeig%coh%diam
nrmax_h = zeig%coh%ident
agedmh = zeig%coh%x_age
if(help_h2.gt. help_h1) then
help_h1 = help_h2
nrmax = nrmax_h
agedm = agedmh
end if
end if
end if
zeig=>zeig%next
end do
END SUBROUTINE max_dbh
!
! calculation of cohort number with maximal diameter
!
SUBROUTINE max_diam(nrmax,anz,cohl, specnum)
use data_stand
implicit none
integer :: nrmax,i
integer :: nrmax_h, specnum
integer :: anz, testflag
real :: help_h1, help_h2
integer,dimension(0:anz_coh) :: cohl
testflag=0
nrmax = -1
nrmax_h = -1
help_h2=0.
help_h1=0.
zeig=>pt%first
do
if(.not.associated(zeig)) exit
do i=0,anz-1
if(cohl(i).eq.zeig%coh%ident.and. zeig%coh%species.eq.specnum) then
testflag=1
endif
end do
if (testflag.eq.0) then
help_h2= zeig%coh%diam
nrmax_h = zeig%coh%ident
if(help_h2.gt. help_h1) then
help_h1 = help_h2
nrmax = nrmax_h
end if
end if
zeig=>zeig%next
testflag = 0
end do
anz = anz +1
cohl(anz-1) = nrmax
END SUBROUTINE max_diam
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
! SR calc_usp
! calculaiton of percent of using (NUtzungsprozent)
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
subroutine calc_usp (taxnr,ages,density,c_usp)
use data_species
use data_manag
real ::density, c_usp
real,dimension(20) :: spec_den=(/0.,0.8,0.9,1.,0.8,0.9,1.,1.1,0.8,0.9,1.,1.1,0.7,0.8,0.9,1.,0.7,0.8,0.9,1./)
integer, dimension(13) :: age_den=(/15,20,25,30,35,40,45,50,60,70,80,100,120/)
integer :: j, i,help1, taxnr,ages
c_usp =0.
do i=1,3
help1=(taxnr-1)*4+i
if(density.gt.spec_den(help1).and. density.le.spec_den(help1+1)) then
do j= 1,12
if(ages.ge.age_den(j).and.ages.lt.age_den(j+1))then
c_usp = usp(help1,j)
end if
end do
end if
end do
help1=(taxnr-1)*4+4
if(c_usp.eq.0..and. density.gt.spec_den(help1)) then
do j= 1,12
if(ages.ge.age_den(j).and.ages.lt.age_den(j+1))then
c_usp = usp(help1,j)
end if
end do
else if (c_usp.eq.0..and.density .le. spec_den( help1-3)) then
do j= 1,12
if(ages.ge.age_den(j).and.ages.lt.age_den(j+1))then
c_usp = usp(help1-3,j)
end if
end do
end if
end subroutine calc_usp
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
! 4C-
! Subroutine calc_gfbg
! calculation of optimal basal area
! coresponding to functions from
! A. Degenhardt: Algorithmen und Programme zur
! waldwachstumskundlichen Auswertung von
! Versuchs- und probeflchen
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
SUBROUTINE calc_gfbg(gfbg, ntax, stage, hg)
use data_par
use data_stand
implicit none
real, dimension(12) :: p=(/5.3774914,4.3364045,1.7138966, &
0.1791894,0.6499329,0.581721, &
0.64149,1.39876,0.38106,3.48086,4.55256,1.10352/) ! parameter pinus
real, dimension(14) :: s=(/52.021649311,17.01260031,1.817338508, &
3.97091538,0.165219412,0.017015893, &
17.17273582,77.00271993,180.95845108,69.85082406, &
0.284339648,6.211490243,8.057235477,2.600807284/) ! parameter spruce
real, dimension(11) :: b=(/5.1961292,5.8518918,2.048007, &
0.1517038,0.8873933,0.9555725, &
0.845794,29.76635,9.89798,0.2033,0.092586/) ! parameter beech
real, dimension(16) :: o=(/10.937989911, 30.98059032,36.683338986,4.8203797, &
0.217782149,0.559666286,1.253027352,2.447035652, &
3.172437267,26.001075916,15.01095715,2.411330088, &
0.286619845,0.126747922,0.121360347,0.05650846/)
real, dimension(9) :: bi=(/2.304633491,5.7831992,0.057831992, &
99.89719563,4983.109428, 387539.3699, &
192.06078091,0.070580839, 0.624018136/) ! birch (Sandbirke)
real, dimension(16) :: pa=(/12.114711547,13.90837359,11.746497917, 2.963065353, &
0.298215006,0.325115413,0.46694307,0.043088114, &
5.314568374, 9.635476988, 23.20634163,9.473964111, &
0.845408671,0.187292811,0.025416101,0.050721202/)
real :: abon, &
rbon, &
h1,h2,h3,h4,alt10, alt100, nvb, dgvb,gfbg,stage,hg
integer :: ntax
alt10= 10/stage
alt100= stage/100
h1 = 0.;h2=0.;h3=0.;h4=0.
select case(ntax)
case(1) ! beech
h1 = b(1) + b(2)*alt100 - b(3)*alt100*alt100
h2 = -b(4) - b(5)*alt10 - b(6)*alt10*alt10
rbon = h1+h2*hg
abon = 36.- 4.*rbon
gfbg = b(7) + b(8)*alt100 -b(9)*alt100*alt100 +abon*(b(10) + b(11)*alt100)
case(2) ! spruce
h1 = (alog(hg)-s(4))/(-s(5)+alog(1.-exp(-s(6)*stage)))
abon = s(1)-s(2)*h1 +s(3)*h1*h1
rbon = (38.-abon)/4.
h2 = - s(7)-s(8)*alt100+s(9)*alt100*alt100-s(10)*alt100*alt100*alt100
h3 = s(11) + s(12)*alt100 -s(13)*alt100*alt100 + s(14)* alt100*alt100*alt100
gfbg = h2 + h3*abon
case(3) ! pine
h1 = p(1) + p(2)*alt100 - p(3)*alt100*alt100
h2 = -p(4) - p(5)*alt10 -p(6)*alt10*alt10
rbon = h1 + h2*hg
abon = 32.- 4.*rbon
h3 = p(7)+p(8)*alog10(stage)-p(9)*alog10(stage)*alog10(stage)
h4 = -p(10) + p(11)*alog10(stage) - p(12)*alog10(stage)*alog10(stage)
gfbg = 0.01*abon*10**h3 + 10**h4
case(4) ! oak
h1 = o(1) - o(2)*alt10 + o(3)*alt10*alt10 - o(4)*alt10*alt10*alt10
h2 =- o(5) - o(6)* alt10 + o(7)*alt10*alt10 - o(8)* alt10*alt10*alt10
rbon = h1 + h2*hg
abon = 31.3 - 3.9*rbon
h3 = o(9) + o(10)* alt100 -o(11)*alt100*alt100 + o(12)*alt100*alt100*alt100
h4 = o(13) + o(14)*alt100 - o(15)*alt10*alt100 + o(16)*alt100*alt100*alt100
gfbg = h3 + h4*abon
case(5) ! birch
rbon = 9. - 0.25*(hdom/100.)*exp(-bi(1)*(exp(-bi(2))-exp(-bi(3)*stage)))
abon = 36. - 4.*rbon
nvb = -bi(4) - bi(5)*(1./(hdom/100.)) +bi(6)*(1./(hdom/100.))*(1./(hdom/100.))
dgvb = bi(7)*(1. + bi(8)*nvb)**(-bi(9))
gfbg = pi*dgvb*dgvb*nvb/(4*10000)
case(8) ! aspen
h1= pa(1) - pa(2)*alt10+pa(3)*alt10*alt10-pa(4)*alt10*alt10*alt10
h2 = -pa(5)+pa(6)*alt10-pa(7)*alt10*alt10+pa(8)*alt10*alt10*alt10
rbon=h1+h2*hdom
abon=36.-4*rbon
h3 = -pa(9)+pa(10)*alt10-pa(11)*alt10*alt10+pa(12)*alt10*alt10*alt10
h4 = pa(13)-pa(14)*alt10 + pa(15)*alt10*alt10 -pa(16)*alt10*alt10*alt10
gfbg = h3 + h4*abon
end select
END SUBROUTINE calc_gfbg
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
SUBROUTINE stump(x1, x2, xdcrb, xhbo, xh, i, stump_v, stump_dw)
use data_tsort
use data_par
use data_species
implicit none
real :: x1, x2, xdcrb, xhbo, xh, diam_base, dbsto, v1, stump_v, stump_dw
integer :: i
diam_base= sqrt((x1+x2)*4/pi)
if(xhbo.ne.0) then
dbsto = xdcrb + (xhbo-stoh(i))*(diam_base-xdcrb)/xhbo
else if (xhbo.eq.0)then
dbsto = diam_base*(xh+stoh(i))/xh
end if
! volume of stump
v1 = pi* stoh(i)*(diam_base*diam_base + diam_base*dbsto + dbsto*dbsto)/3. ! frustum
stump_v = v1/1000000. ! m
stump_dw = v1*spar(i)%prhos ! kg DW
END SUBROUTINE stump
source_code/version_2.3_windows/management.f 0 → 100644
View file @ 82df1085
!*****************************************************************!
!* *!
!* 4C (FORESEE) *!
!* *!
!* *!
!* Subroutines for: *!
!* management *!
!* contains: *!
!* SR manag_ini *!
!* SR manag_menu *!
!* SR simple_ini *!
!* SR adap_ini *!
!* SR management *!
!* SR simple_manag *!
!* SR adap_manag *!
!* SR target_manag *!
!* SR target_ini *!
!* *!
!* Copyright (C) 1996-2018 *!
!* Potsdam Institute for Climate Impact Reserach (PIK) *!
!* Authors and contributors see AUTHOR file *!
!* This file is part of 4C and is licensed under BSD-2-Clause *!
!* See LICENSE file or under: *!
!* http://www.https://opensource.org/licenses/BSD-2-Clause *!
!* Contact: *!
!* https://gitlab.pik-potsdam.de/foresee/4C *!
!* *!
!*****************************************************************!
SUBROUTINE manag_ini
use data_manag
use data_simul
use data_stand
implicit none
!call manag_menu
select case(flag_mg)
case(1)
call simple_ini
case(2)
if(anz_spec.ne.0) call adap_ini
case(3, 33, 333)
call target_ini
case(44)
call man_liocourt_ini
case(8)
call aspman_ini
case(9)
call aust_ini
end select
contains
SUBROUTINE simple_ini
! read definition of simple thinning from file
integer :: manag_unit,i
character(len=150) :: filename
logical :: ex
manag_unit=getunit()
filename = manfile(ip)
call testfile(filename,ex)
open(manag_unit,file=trim(filename))
read(manag_unit,*) thin_nr ! number of thinning years
allocate(thin_year(thin_nr));allocate(thin_tree(thin_nr))
do i=1,thin_nr
read(manag_unit,*) thin_year(i),thin_tree(i)
end do
close(manag_unit)
end SUBROUTINE simple_ini
end SUBROUTINE manag_ini
!-------------------------------------------------
! control of management regime and call
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
SUBROUTINE management
use data_simul
use data_stand
use data_species
use data_manag
use data_out
implicit none
integer diffanz
if (flag_standup .eq. 0) flag_standup = 1
select case(flag_mg)
case(1)
call simple_manag
case(2)
call adap_manag
case(3, 33, 333)
call target_manag
case(44)
call liocourt_manag
case(8)
call asp_manag
case(9)
call aust_manag
case(10)
call dis_manag
case default
end select
contains
SUBROUTINE simple_manag
integer taxnr, cohnr
real minheight
! simple thinning with fitting to default stem number
if(anz_tree>thin_tree(act_thin_year)) then
diffanz = anz_tree - thin_tree(act_thin_year)
minheight = 100000.
do
!repeat while diffanz>0)
if(diffanz<0.1) exit
zeig=>pt%first
!search for cohort with minimal height
do
if(.not.associated(zeig)) exit
if(zeig%coh%ntreea>0.1 .and. zeig%coh%height<minheight)then
minheight=zeig%coh%height; cohnr=zeig%coh%ident
endif
zeig=>zeig%next
enddo
! delete smallest trees
zeig=>pt%first
do
if(.not.associated(zeig)) exit
if(zeig%coh%ident==cohnr)then
if(diffanz <= zeig%coh%ntreea) then
zeig%coh%ntreea = zeig%coh%ntreea - diffanz
zeig%coh%ntreem = diffanz
diffanz=0.
else
diffanz = diffanz - zeig%coh%ntreea
zeig%coh%ntreem = zeig%coh%ntreea
zeig%coh%ntreea = 0.
endif
minheight=100000.
exit
endif
zeig=>zeig%next
enddo
enddo
else
call error_mess(time,"no management possible, tree number undersized : ", REAL(anz_tree))
endif
! number of trees and litter pools of managed trees
zeig=>pt%first
anz_tree=0.
do
if(.not.associated(zeig)) exit
taxnr=zeig%coh%species
anz_tree=anz_tree+zeig%coh%ntreea
if(zeig%coh%ntreem>0 .and.zeig%coh%ntreed==0.)then
zeig%coh%litC_fol = zeig%coh%litC_fol + (1.-spar(taxnr)%psf)*zeig%coh%x_fol/2.
zeig%coh%litN_fol = zeig%coh%litN_fol + ((1.-spar(taxnr)%psf)*zeig%coh%x_fol/2.)*0.02
zeig%coh%litC_frt = zeig%coh%litC_frt + zeig%coh%x_frt/2.
zeig%coh%litN_frt = zeig%coh%litN_frt + (zeig%coh%x_frt/2.)*0.023
endif
zeig=>zeig%next
enddo
end SUBROUTINE simple_manag
end SUBROUTINE management
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! input of control parameters for adaptation management
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
SUBROUTINE adap_ini
use data_manag
use data_simul
use data_species
use data_stand
use data_out
implicit none
! read definition of adapted thinning from file
integer :: manag_unit,i,j
character(len=150) :: filename
logical :: ex
character ::text
manag_unit=getunit()
filename = manfile(ip)
allocate(zbnr(nspec_tree))
allocate(tend(nspec_tree))
allocate(rot(nspec_tree))
allocate(thin_flag1(nspec_tree))
allocate(thin_flag2(nspec_tree))
allocate(thin_flag3(nspec_tree))
allocate(thin_flag4(nspec_tree))
allocate(regage(nspec_tree))
allocate(np_mod(nspec_tree))
allocate(thinyear(nspec_tree))
allocate(specnr(nspec_tree))
allocate(age_spec(nspec_tree))
allocate(anz_tree_spec(nspec_tree))
thinyear =0
thin_flag1=0
thin_flag2=0
thin_flag3=0
thin_flag4=0
flag_manreal = 0
flag_shelter = 0
shelteryear = 0
call testfile(filename,ex)
open(manag_unit,file=trim(filename))
! read head of data-file
do
read(manag_unit,*) text
if(text .ne. '!')then
backspace(manag_unit);exit
endif
enddo
! dominant species
read(manag_unit,*) domspec
! domimant height levels
read(manag_unit,*) ho1,ho2,ho3,ho4
! thinning regimes
read (manag_unit,*) thin_flag1(1),thr1, thr2,thr3,thr4,thr5,thr6, thr7, mgreg, domspec_reg
do j=2,nspec_tree
thin_flag1(j)= thin_flag1(1)
end do
if(thin_flag1(1) <0) then
close(manag_unit)
return
end if
! limit for hight query
read (manag_unit,*) limit
!test
limit = limit + 30.
! number of years between thinning
read (manag_unit,*) thinstep
! relative thinning for young trees
read (manag_unit,*) direcfel
! control variables for thinning depending on basal area
read (manag_unit,*) thin_ob, optb
! number of 'Zielb�ume' (target trees)
read (manag_unit,*) (zbnr(i), i =1, nspec_tree)
! relative thinning value for tending of plantations
read (manag_unit,*) (tend(i), i =1, nspec_tree)
! rotation
read (manag_unit,*) (rot(i), i =1, nspec_tree)
! age of natural/planted regeneration
read (manag_unit,*) (regage(i), i =1, nspec_tree)
do j= 1,20
read (manag_unit,*) (usp(j,i), i=1,13)
end do
read (manag_unit,*) (np_mod(i), i = 1,nspec_tree)
close(manag_unit)
if (flag_reg .ne. 0) then
WRITE(unit_ctr,*) ' '
WRITE(unit_ctr,*) '***Managment parameter case flag_mg = 2 (user specified) ***'
WRITE(unit_ctr,'(A35,4F15.5)') 'height for management control(cm)', ho1,ho2,ho3,ho4
WRITE(unit_ctr,'(A35,6I15)') 'man. flags thin_flag1, thr1-thr5' , thin_flag1(1),thr1,thr2, thr3,thr4,thr5
WRITE(unit_ctr,'(A35,F15.5)') 'height for directional felling', thr6
WRITE(unit_ctr,'(A35,I15)') 'measure at rotation', thr7
WRITE(unit_ctr,'(A35,I15)') 'regeneration measure', mgreg
WRITE(unit_ctr,'(A35,F15.5)') 'lower/upper limit of height(cm)', limit
WRITE(unit_ctr,'(A35,I15)') 'number of years between thinning',thinstep
WRITE(unit_ctr,'(A35,F15.5)') 'rel. value for directional felling', direcfel
WRITE(unit_ctr,'(A35,2F15.5)') 'thinning depending on basal area function thin_ob (0,1), optb ', thin_ob, optb
WRITE(unit_ctr,'(A35,5F15.5)')'number of Zielb�ume (spec.)', (zbnr(i),i=1,nspec_tree)
WRITE(unit_ctr,'(A35,5F15.5)')'rel. value for tending of pl.',(tend(i), i =1,nspec_tree)
WRITE(unit_ctr,'(A35,5I15)')'rotation ',(rot(i), i =1,nspec_tree)
WRITE(unit_ctr,'(A35,5I15)')'age of nat./pl. regeneration',(regage(i), i =1,nspec_tree)
close(unit_ctr)
end if
end SUBROUTINE adap_ini
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! routines for adaptation management
! based on concepts from P. Mohr, P.Lasch. D. Gerold....
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
SUBROUTINE adap_manag
use data_stand
use data_manag
use data_simul
use data_par
use data_species
implicit none
real :: c1, &
helphd,helpmax, helpi, & ! hdom species specific
domage
real :: sumdh, sumd ! for calculation of HG
real :: bg ! stocking degree
real :: stage
real :: dfbg ! optimal basal area
real :: hg ! height of DG
integer :: c2, &
taxnr, &
actspec, & ! number of species for thinning
th_help, i,j ,k, &
testflag, &
nrfel, &
flag_prep, &
flag_fell, &
inum, &
domage_sh, &
domspec_sh, &
flag_reg_act
real,dimension(nspecies) :: bas_area_spec
real,dimension(nspecies) :: help
flag_reg_act = 100
domage = 0.
domspec_sh = 0
help = 0.
helpmax = 0.
helpi =0
bas_area_spec = 0.
domage_sh = 0
flag_fell = 0
stand_age=0
flag_prep = 0
anz_tree_spec = 0
anz_tree_dbh = 0
flag_adapm = 0.
specnr = 0.
age_spec = 0.
basarea_tot = 0.
sumd = 0.
sumdh = 0.
! determine number of species in cohort list
if(anz_spec.eq.0) return
if(thin_flag1(1) <0) return
IF(anz_spec.eq.1) then
! stand age as maximum age of cohorts
zeig => pt%first
DO
IF (.NOT. ASSOCIATED(zeig)) EXIT
if(zeig%coh%species.le.nspec_tree) then
taxnr = zeig%coh%species
if(zeig%coh%x_age.gt. stand_age) stand_age = zeig%coh%x_age
if(zeig%coh%ntreea.ne.0.and. zeig%coh%diam.gt.0.) then
sumd = sumd + zeig%coh%diam*zeig%coh%diam
sumdh = sumdh + zeig%coh%diam*zeig%coh%diam*zeig%coh%height
basarea_tot = basarea_tot + zeig%coh%ntreea*(zeig%coh%diam**2)*pi/4.
bas_area_spec(taxnr) = bas_area_spec(taxnr) + zeig%coh%ntreea*(zeig%coh%diam**2)*pi/4.
end if
end if
zeig=>zeig%next
END DO
ELSE if(anz_spec.gt.1) then
! age of species i as maximum age of cohorts of this species
testflag = 0
i=1
zeig => pt%first
DO
IF (.NOT. ASSOCIATED(zeig)) EXIT
taxnr = zeig%coh%species
if(zeig%coh%ntreea.ne.0.and. zeig%coh%diam.gt.0.) then
basarea_tot = basarea_tot + zeig%coh%ntreea*(zeig%coh%diam**2)*pi/4.
bas_area_spec(taxnr) = bas_area_spec(taxnr) + zeig%coh%ntreea*(zeig%coh%diam**2)*pi/4.
end if
if(i.eq.1) then
specnr(i) = zeig%coh%species
if(zeig%coh%x_age.gt. age_spec(i)) age_spec(i) = zeig%coh%x_age
i = i+1
else
do j= 1,i-1
if(specnr(j).eq. zeig%coh%species) testflag = 1
end do
if (testflag.eq.0) then
specnr(i) = zeig%coh%species
if(zeig%coh%x_age.gt. age_spec(i)) age_spec(i) = zeig%coh%x_age
i = i+1
end if
testflag=0
end if
zeig=>zeig%next
END DO
DO i =1,anz_spec
zeig => pt%first
DO
IF (.NOT. ASSOCIATED(zeig)) EXIT
if(zeig%coh%species.eq.specnr(i).and.zeig%coh%x_age.gt. age_spec(i)) age_spec(i)= zeig%coh%x_age
zeig=>zeig%next
END DO
END DO
! if domspec is -99 then domspec is calculated by basal area
if( domspec.lt. 0 ) then
DO i = 1,nspecies
if (basarea_tot.ne.0) then
help(i) = bas_area_spec(i)/basarea_tot
if(help(i).gt. helpmax) then
helpmax = help(i)
helpi = i
end if
end if
end do
domspec = helpi
end if
! re-sorting of the filed specnr (at the first place of this field is the number of the dominanat species);
! this is necessary for managemnt of mixed stands becuase this management is according to the management
! of the dominanat species
! age of domspec
zeig => pt%first
DO
IF (.NOT. ASSOCIATED(zeig)) EXIT
if(zeig%coh%species.eq.domspec) then
if(zeig%coh%x_age.gt.domage) domage = zeig%coh%x_age
end if
zeig=>zeig%next
END DO
if(specnr(1).ne.domspec) then
do k=2,anz_spec
if(specnr(k).eq.domspec) then
specnr(k)=specnr(1)
age_spec(k)=age_spec(1)
specnr(1) = domspec
age_spec(1)=domage
exit
end if
end do
end if ! re-sorting
! species for shelterwood which is oldest
zeig => pt%first
DO
IF (.NOT. ASSOCIATED(zeig)) EXIT
if(zeig%coh%shelter.eq.1.and.zeig%coh%x_age.gt.domage.and.zeig%coh%x_age.gt.domage_sh) domage_sh = zeig%coh%x_age
zeig=>zeig%next
END DO
zeig => pt%first
DO
IF (.NOT. ASSOCIATED(zeig)) EXIT
if(zeig%coh%x_age.eq.domage_sh) domspec_sh = zeig%coh%species
zeig=>zeig%next
END DO
END IF
if (anz_spec.eq.1) then
specnr(1) = taxnr
age_spec(1) = stand_age
if(domspec.lt.0) domspec = taxnr
end if
DO i=1,anz_spec
anz_tree_spec(i) = 0
! caclulation of species specific number of trees
zeig=>pt%first
do
if(.not.associated(zeig)) exit
zeig%coh%ntreem = 0.
if(zeig%coh%diam.gt.0) anz_tree_dbh = anz_tree_dbh + zeig%coh%ntreea
if(zeig%coh%species.eq.specnr(i)) anz_tree_spec(i) = anz_tree_spec(i) + zeig%coh%ntreea
zeig=> zeig%next
end do
END DO ! species loop
if(domspec.lt.0) then
if(domage_sh.gt.domage) then
domage = domage_sh
domspec = domspec_sh
end if
end if
DO i=1,anz_spec
actspec = specnr(i)
zeig => pt%first
DO
IF (.NOT. ASSOCIATED(zeig)) EXIT
if(zeig%coh%species.le.nspec_tree) then
taxnr = zeig%coh%species
if(zeig%coh%ntreea.ne.0.and. zeig%coh%diam.gt.0..and.zeig%coh%species.eq.taxnr) then
stage = zeig%coh%x_age
sumd = sumd + zeig%coh%diam*zeig%coh%diam
sumdh = sumdh + zeig%coh%diam*zeig%coh%diam*zeig%coh%height
end if
end if
zeig=>zeig%next
END DO
! calculation HG (height for DG)
if(sumdh.ne.0) then
hg = (sumdh/sumd)/100.
else
hg = 0.
end if
IF (specnr(i).ne.0..and. domspec.ne.0) THEN
select case(thr7)
case(1) ! thr7
! shelterwood management
if(domspec.eq.actspec) then
if (age_spec(i).ge.regage(specnr(i)).and. age_spec(i).lt.(rot(specnr(i))-15.).and. time.ne.1) then
if(shelteryear.eq.0.and.flag_shelter.eq.0) flag_reg = mgreg
inum = i
if (flag_sh_first.ne.2) then
call shelterwood_man(specnr(inum),inum,domage)
end if
if(shelteryear.eq.0) flag_sh_first = 1
flag_shelter = 1
if(flag_sh_first.ne.2) then
select case(flag_reg)
case(1) ! mgreg
! natural regeneration allowed
flag_reg = 1
case(4,5,6,7,8,9,10,11,12,13,14,15) ! mgreg
! artificial regeneration
if(flag_reg_act.ne.0) call planting
flag_reg = 0
flag_reg_act = 0
end select
end if
flag_prep = 1
else if (age_spec(i).ge.rot(specnr(i)).and. time.ne.1) then
! clear felling
nrfel = specnr(i)
call felling(nrfel,i)
flag_manreal = 1
flag_shelter = 0
maninf = 'felling after shelterwood s.'
meas = 0
! set back because shelterwood m. is finished, management of regenerated stand starts
shelteryear = 0.
thin_flag1 = 0
thin_flag2 = 0
thin_flag3 = 0
thin_flag4 = 0
flag_prep = 1
if(flag_plant_shw.eq.1) then
! if no first and second sherterwood management was possibele than after clear cut planting is called
select case(mgreg)
case(1) ! mgreg
! natural regeneration allowed
flag_reg = 1
case(4,5,6,7,8,9,10,11,12,13,14,15) ! mgreg
! artificial regeneration
if(flag_reg_act.ne.0) then
flag_reg = mgreg
call planting
end if
flag_reg = 0
flag_reg_act = 0
flag_plant_shw =0
end select
end if
! if initial age is grater than age for first shleterwood treatment
else if(time.eq.1.and. age_spec(i).gt.regage(specnr(i)).and. age_spec(i).gt.(rot(specnr(i))-20) ) then
! flags for planting if felling is realised
flag_plant_shw = 1
flag_reg_act = 1
! in this case: to avoid sheletrwood management until rotation time
flag_sh_first = 2
shelteryear = 99
! labelling of cohorts as sheletrwood cohorts
zeig=>pt%first
do
if(.not.associated(zeig)) exit
zeig%coh%shelter=1
zeig=> zeig%next
end do
exit
else if(time.eq.1.and. age_spec(i).gt.regage(specnr(i)).and. age_spec(i).le.(rot(specnr(i))-20.)) then
! if initial age is greater than regeneration age(first shelterwood treatm.) and not too near to rotation age
! a new rotation age is defined with delaying
rot(specnr(i)) = rot(specnr(i)) + (age_spec(i) - regage(specnr(i)))
if(shelteryear.eq.0.and.flag_shelter.eq.0) flag_reg = mgreg
inum = i
call shelterwood_man(specnr(inum),inum,domage)
if(shelteryear.eq.0) flag_sh_first = 1
flag_shelter = 1
select case(flag_reg)
case(1) ! mgreg
! natural regeneration allowed
flag_reg = 1
case(4,5,6,7,8,9,10,11,12,13,14,15) ! mgreg
! artificial regeneration
if(flag_reg_act.ne.0) call planting
flag_reg = 0
flag_reg_act = 0
end select
end if
else if(domspec.ne.actspec) then
if (domage.ge.regage(domspec).and.domage.lt.(rot(domspec)-15.)) then
if(shelteryear.eq.0) flag_reg = mgreg
inum=i
call shelterwood_man(specnr(inum),inum, domage)
flag_shelter = 1
if(shelteryear.eq.0) flag_sh_first = 1
select case(flag_reg)
case(1) ! mgreg
! natural regeneration allowed
flag_reg = 1
case(4,5,6,7,8,9,10,11,12,13,14,15) ! mgreg
! artificial regeneration
if(flag_reg_act.ne.0) call planting
flag_reg = 0
flag_reg_act = 0
end select
flag_prep = 1
else if(thr7.eq.1 .and. domage.eq.rot(domspec)) then
else if(actspec.eq.rot(actspec)) then
! clear felling
nrfel = specnr(i)
call felling(nrfel,i)
flag_manreal = 1
flag_shelter = 0
maninf = 'felling after shelterwood s.'
meas = 0
! set back because shelterwood m. is finished, management of regenerated stand starts
shelteryear = 0.
thin_flag1 = 0
thin_flag2 = 0
thin_flag3 = 0
thin_flag4 = 0
flag_prep = 1
end if
end if
case(2) ! thr7
! clear felling
if(age_spec(i).ge.(rot(specnr(i))-15).and.age_spec(i).lt.rot(specnr(i)) ) then
zeig=>pt%first
do
if(.not.associated(zeig)) exit
if(zeig%coh%species.eq.specnr(i).and. zeig%coh%x_age.eq. age_spec(i)) zeig%coh%shelter = 1
zeig=>zeig%next
end do
flag_prep = 1
else if (age_spec(i).eq.rot(specnr(i))) then
nrfel = specnr(i)
call felling (nrfel,i)
flag_manreal = 1
flag_fell = 1
thinyear(actspec) = time
thin_flag1 = 0
thin_flag2 = 0
thin_flag3 = 0
thin_flag4 = 0
maninf = 'felling'
meas =0
call input_manrec
else if(age_spec(i).gt. rot(specnr(i)).and. time.eq.1) then
nrfel = specnr(i)
call felling (nrfel,i)
flag_manreal = 1
flag_fell = 1
thinyear(actspec) = time
thin_flag1 = 0
thin_flag2 = 0
thin_flag3 = 0
thin_flag4 = 0
maninf = 'felling'
meas =0
call input_manrec
end if
case default
end select
! tending of plantations (Jungwuchspflege)
! test if rotation age is not during the next 15 years
IF (flag_prep .eq. 0. .and. flag_shelter .eq.0) then
helphd= svar(specnr(i))%dom_height
if ( thinonce.eq.1) then
c1 = ho3
c2 = thr4
CALL thinning (c1,c2,actspec,i)
flag_manreal=1
maninf = 'thinning'
meas = thr1
thinyear(actspec)=time
call input_manrec
end if
if( thinonce.eq.0) then
IF ( (helphd.ge.(ho1-60.).and. helphd.le.(ho1+60.)).and. thin_flag1(actspec).eq.0) THEN
CALL tending(actspec,i)
flag_manreal = 1
maninf = 'tending'
meas = 0
call input_manrec
thin_flag1(actspec)=1
flag_adapm = 1
! management at different dominant heights
ELSE IF( helphd.ge.(ho1-60).and.helphd.le.(ho4+limit)) then
IF((helphd.ge.(ho2-limit).and. helphd.le.(ho2+limit)).and. (thin_flag2(actspec).eq.0).or.( thin_flag2(actspec).eq.0.and. thin_flag2(domspec).eq.1))THEN
if(actspec.eq.domspec .or. thin_flag2(domspec).eq.1) then
c1= ho2
c2= thr1
thin_flag2(actspec)=1
maninf = 'brushing'
! if beech, spruce, oak then tending else thinning based on basal area
if(actspec.ne.3)then
! Mod. for Cornelia
CALL tending(actspec,i)
else
CALL thinning (c1,c2,actspec,i)
end if
flag_manreal=1
meas = thr1
thinyear(actspec)=time
call input_manrec
end if
ELSE IF((helphd.ge.(ho3-limit).and. helphd.le.(ho3+limit)).and. (thin_flag3(actspec).eq.0).or.( thin_flag3(actspec).eq.0.and. thin_flag3(domspec).eq.1)) THEN
if(actspec.eq.domspec .or. thin_flag3(domspec).eq.1) then
c1= ho3
c2= thr2
thin_flag3(actspec)= 1
CALL thinning (c1,c2,actspec,i)
flag_manreal = 1
maninf = 'thinning'
meas = thr2
thinyear(actspec)=time
call input_manrec
end if
ELSE IF( (helphd.ge.(ho4-limit).and. helphd.le.(ho4+limit)).and. (thin_flag4(actspec).eq.0).or.( thin_flag4(actspec).eq.0.and. thin_flag4(domspec).eq.1)) THEN
if(actspec.eq.domspec .or. thin_flag3(domspec).eq.1) then
c1= ho4
c2= thr3
thin_flag4(actspec)= 1
CALL thinning (c1,c2,actspec,i)
flag_manreal = 1
maninf = 'thinning'
meas = thr3
call input_manrec
thinyear(actspec) = time
end if
ENDIF
! directinal felling if not done yet
flag_adapm = 1
ELSE IF(helphd.gt. (ho4+limit)) THEN
! calculation of stocking degree
call calc_gfbg(dfbg, actspec, stage, hg)
dfbg = dfbg*kpatchsize
bg = bas_area_spec(actspec)*bas_area_spec(actspec)/(basarea_tot*dfbg)
th_help = time-thinyear(actspec)
IF(th_help.ge.thinstep.or.(bg.gt.(optb).and.time.lt.thinstep.and.thinyear(actspec).eq.0)) THEN
c1 = 0.
c2 = thr4
if( age_spec(i).lt.(rot(specnr(i))-15)) then
CALL thinning(c1,c2,actspec,i)
flag_manreal = 1
maninf = 'thinning'
meas = thr4
thinyear(actspec) = time
!wpm
call input_manrec
flag_adapm = 1
end if
ENDIF
END IF
END IF
end if ! thinonce
END IF ! flag_prep
END DO ! species loop
if(maninf.eq.'felling after shelterwood s.') domspec = -99
if(thr7.eq.1 .and.(maninf.eq.'felling after shelterwood s.'.or. &
maninf.eq.'shelterwood system1'.or.maninf.eq.'shelterwood system2') ) then
call input_manrec
maninf =trim(maninf)//'out'
end if
if(flag_sh_first.eq.1) then
shelteryear=time
flag_sh_first = 0
end if
if(maninf.eq.'felling after shelterwood s.') then
domspec = domspec_reg
end if
! regeneration/planting if felling was realised
if(flag_fell.eq.1.and. mgreg.ne.0) then
select case(mgreg)
case(1)
! natural regeneration
flag_reg = 1
! shelterwood management is switched off
thr7 = 0
case(4,5,6,7,8,9,10,11,12,13,14)
! artificial regeneration (planting)
flag_reg = mgreg
call planting
thinyear(actspec) = time
thin_flag2 = 0
thin_flag3 = 0
thin_flag4 = 0
flag_reg = 0
domspec = domspec_reg
end select
end if
! calculation of total dry mass of all harvested trees
sumvsab = 0.
sumvsab_m3 = 0.
svar%sumvsab = 0.
if(maninf.ne.'tending'.or. flag_brush.eq.0) then
zeig=>pt%first
do while (associated(zeig))
ns = zeig%coh%species
sumvsab = sumvsab + zeig%coh%ntreem*(zeig%coh%x_sap + zeig%coh%x_hrt)
sumvsab_m3 = sumvsab_m3 + zeig%coh%ntreem*(zeig%coh%x_sap + zeig%coh%x_hrt)/(spar(ns)%prhos*1000000)
svar(ns)%sumvsab = svar(ns)%sumvsab + zeig%coh%ntreem*(zeig%coh%x_sap + zeig%coh%x_hrt)
zeig=>zeig%next
end do
sumvsab = sumvsab * 10000./kpatchsize ! kg/ha
sumvsab_m3 = sumvsab_m3 * 10000./kpatchsize ! kg/ha
do k = 1, nspec_tree
svar(k)%sumvsab = svar(k)%sumvsab * 10000./kpatchsize ! kg/ha
end do
! cumulative harvested stem mass
cumsumvsab = cumsumvsab + sumvsab
end if
call class_man
END SUBROUTINE adap_manag
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
! management routine with fitting stem biomass on target values of stem biomass
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
SUBROUTINE target_manag
USE data_manag
USE data_stand
USE data_species
USE data_simul
implicit none
integer taxnr,k,i,j
zeig=>pt%first
do
if(.not.associated(zeig)) exit
if(zeig%coh%species.le.nspec_tree) then
stand_age = zeig%coh%x_age
taxnr = zeig%coh%species
exit
end if
zeig => zeig%next
end do
! stand manamgent at rotaiotn age
if(taxnr.le.nspec_tree) then
if(stand_age.ne.0) then
select case(thr7)
case(1) ! shelterwood manamgent
case(2) ! clear felling
if(stand_age.eq.(rot(taxnr)-15)) then
zeig=>pt%first
do
if(.not.associated(zeig)) exit
if(zeig%coh%species.eq.taxnr) zeig%coh%shelter = 1
zeig=>zeig%next
end do
return
else if (stand_age.ge.rot(taxnr)) then
call felling(taxnr,i)
flag_manreal = 1
maninf = 'felling'
meas =0
call input_manrec
select case(mgreg)
case(1)
! natural regeneration
flag_reg = 1
! shelterwood management is switched off
thr7 = 0
case(10,11,12,13)
! modification for muilti-run option BRB
if(taxnr.eq.1) then
flag_reg = 11
else if(taxnr.eq.2) then
flag_reg = 13
else if(taxnr.eq.3) then
flag_reg = 10
else if (taxnr.eq.4) then
flag_reg = 12
else
flag_reg = 14
end if
! artificial regeneration (planting)
call planting
flag_reg = 0
end select ! mgreg
end if
end select ! thr7
end if
do j= 1, thin_nr
if(time .eq.thin_year(j)) then
if(thin_stor(j).eq.1.) then
select case(mgreg)
case(1)
! natural regeneration
flag_reg = 1
! Achtung hier ändern!!!
case(8,10,11,12,13, 14, 17)
! artificial regeneration (planting)
zeig=>pt%first
do
if(.not.associated(zeig)) exit
zeig%coh%underst = 0
zeig=>zeig%next
end do
flag_reg = mgreg
call planting
flag_reg = 0
end select ! mgreg
end if ! regeneration & planting
if (flag_mg.eq.3) then
call target_thinning_OC (j)
else if(flag_mg.eq. 33) then
call target_thinning(j)
else if (flag_mg.eq.333) then
call target_thinning_bas(j)
end if
flag_manreal = 1
maninf='thinning'
call input_manrec
end if
end do
! calculation of total dry mass of all harvested trees
sumvsab = 0.
sumvsab_m3 = 0.
svar%sumvsab = 0.
zeig=>pt%first
do while (associated(zeig))
ns = zeig%coh%species
sumvsab = sumvsab + zeig%coh%ntreem*(zeig%coh%x_sap + zeig%coh%x_hrt)
sumvsab_m3 = sumvsab_m3 + zeig%coh%ntreem*(zeig%coh%x_sap + zeig%coh%x_hrt)/(spar(ns)%prhos*1000000)
svar(ns)%sumvsab = svar(ns)%sumvsab + zeig%coh%ntreem*(zeig%coh%x_sap + zeig%coh%x_hrt)
zeig=>zeig%next
end do
sumvsab = sumvsab * 10000./kpatchsize ! kg/ha
sumvsab_m3 = sumvsab_m3 * 10000./kpatchsize ! kg/ha
do k = 1, nspec_tree
svar(k)%sumvsab = svar(k)%sumvsab * 10000./kpatchsize ! kg/ha
end do! cumulated harvested stem mass
cumsumvsab = cumsumvsab + sumvsab
end if
END SUBROUTINE target_manag
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! input for target thinning
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
SUBROUTINE target_ini
! read definition of simple thinning from file
USE data_manag
USE data_simul
USE data_plant
USE data_species
integer :: manag_unit,i
character(len=150) :: filename
character ::text
logical :: ex
allocate(rot(nspec_tree))
allocate(thin_flag1(nspec_tree))
thin_flag1=-1
manag_unit=getunit()
filename = manfile(ip)
call testfile(filename,ex)
open(manag_unit,file=trim(filename))
! read head of data-file
do
read(manag_unit,*) text
if(text .ne. '!')then
backspace(manag_unit);exit
endif
enddo
read(manag_unit,*) thr7 ! management for rotation year
read(manag_unit,*) mgreg ! regeneration in rotation year
! rotation period
read (manag_unit,*) (rot(i), i =1, nspec_tree)
read (manag_unit,*) (numplant(i), i =1,nspec_tree)
read (manag_unit,*) thin_nr ! number of thinning years
allocate(thin_year(thin_nr));allocate(target_mass(thin_nr));
allocate(thin_spec(thin_nr));allocate(thin_tysp(thin_nr))
allocate(thin_stor(thin_nr))
do i=1,thin_nr
read(manag_unit,*) thin_year(i),target_mass(i), thin_spec(i), thin_tysp(i), thin_stor(i)
end do
close(manag_unit)
end SUBROUTINE target_ini
\ No newline at end of file
source_code/version_2.3_windows/mess_stat.f 0 → 100644
View file @ 82df1085
!*****************************************************************!
!* *!
!* 4C (FORESEE) Simulation Model *!
!* *!
!* *!
!* Subroutines for: *!
!* *!
!* preparation of statistical analysis *!
!* *!
!* Author: F. Suckow *!
!* *!
!* contains: *!
!* mess *!
!* prep_mw *!
!* prep_simout *!
!* kind_pos *!
!* store_sim_kind *!
!* prep_stat_out *!
!* read_simout *!
!* open_sfile *!
!* *!
!* Copyright (C) 1996-2018 *!
!* Potsdam Institute for Climate Impact Reserach (PIK) *!
!* Authors and contributors see AUTHOR file *!
!* This file is part of 4C and is licensed under BSD-2-Clause *!
!* See LICENSE file or under: *!
!* http://www.https://opensource.org/licenses/BSD-2-Clause *!
!* Contact: *!
!* https://gitlab.pik-potsdam.de/foresee/4C *!
!* *!
!*****************************************************************!
SUBROUTINE mess
use data_mess
use data_out
use data_simul
implicit none
integer i, j, k
integer :: hd = -99
real :: hv = -9999.0
real :: helpn, totm1, totm2, totm3 ! total match as average from several values
integer maxmess
logical ex
character(10) :: helpsim
character(150) :: filename
allocate (app(site_nr))
if (unit_mess .lt. 0) then
do
inquire (File = mesfile(1), exist = ex)
if(ex .eqv. .false.) then
write (*, '(A)') ' >>>foresee message: File ',trim(mesfile(1)),' not exists !'
write (*, '(A)', advance='no') ' please write full name of measurement file: '
read(*,'(A)') mesfile(1)
cycle
else
exit
endif
enddo
endif
! error.log schreiben
write(unit_err,'(A)')
write(unit_err,'(A)')
write(unit_err,'(A)') ' * * * * * Statistics * * * * *'
write(unit_err,'(A)')
fkind = 0
call prep_mw
if (tkind .eq. 1) call stat_mon
call prep_simout
if (.not. flag_mess) return
call prep_stat_out
do i = 1,site_nr
ip = i
app(i) = i
nme_av = 0.
nmae_av = 0.
nrmse_av = 0.
pme_av = 0.
prmse_av = 0.
tic_av = 0.
meff_av = 0.
rsq_av = 0.
totm1 = 0.
totm2 = 0.
imk_nme = imkind
imk_nmae = imkind
imk_nrmse= imkind
imk_rsq = imkind
call read_simout
call residuen(i)
call statistik
! Mittelwert berechnen und ausdrucken
helpn = imkind - fkind
nme_av = nme_av / (imk_nme - fkind)
nmae_av = nmae_av / (imk_nmae - fkind)
nrmse_av = nrmse_av / (imk_nrmse - fkind)
pme_av = pme_av / helpn
prmse_av = prmse_av / helpn
tic_av = tic_av / helpn
meff_av = meff_av / helpn
rsq_av = rsq_av/(imk_rsq - fkind)
! Calculation of total match without missing values
helpn = 2.
totm1 = tic_av + (1.-meff_av)
totm2 = totm1
totm3 = totm1
totm1 = totm1/helpn
if (rsq_av .ge. 0.) then
helpn = helpn + 1.
totm2 = totm2 + (1-rsq_av)
totm3 = totm2
totm2 = totm2 / helpn
endif
if (nrmse_av .lt. -9000.) then
helpn = helpn + 1.
totm3 = (totm2 + nrmse_av) / helpn
endif
write (unit_stat, '(I5,2X, A20,1X,A10,I8,1X,33E13.5)') ip, site_name(ip), 'average', hd, &
hv, hv, hv, hv, hv, hv, nme_av, hv, nmae_av, hv, hv, nrmse_av, pme_av, prmse_av, tic_av, meff_av, hv, rsq_av, &
hv, hv, hv, hv, hv, hv, hv, hv, hv, hv, hv, hv, totm1, totm2, totm3
write (unit_stat,*)
! File mit Residuen schreiben
if (flag_stat .ge. 2) then
write (helpsim,'(I4)') ip
read (helpsim,*) anh
filename = trim(dirout)//trim(site_name(ip))//'_resid'//'.res'//trim(anh)
unit_mout = getunit()
open(unit_mout,file=filename,status='replace')
write (unit_mout, '(A)') '# Residuals etc.'
write (unit_mout, '(A)') '# Number kind '
do j = 1, imkind
write (unit_mout, '(I14,3X,A10,26X)', advance='no') val(j)%imes, val(j)%mkind
enddo
write (unit_mout, '(A)') ' '
do j = 1, imkind
write (unit_mout, '(A)', advance='no') ' day year residual simulation measurement'
enddo
write (unit_mout, '(A)') ' '
maxmess = maxval(val%imes)
do k = 1, maxmess
do j = 1, imkind
if (val(j)%imes .ge. k) then
write (unit_mout, '(4X,2I5,3E13.5)', advance='no') val(j)%day(k), val(j)%year(k), val(j)%resid(k), val(j)%sim(k), val(j)%mess(k)
else
write (unit_mout, '(4X,2I5,3E13.5)', advance='no') hd, hd, hv,hv,hv
endif
enddo
write (unit_mout, '(A)') ' '
enddo
close(unit_mout)
endif
enddo
write (*,*)
write (*, '(A)') ' Statistical analysis completed'
write (*,*)
END SUBROUTINE mess
!**************************************************************
SUBROUTINE prep_mw
use data_mess
use data_simul
implicit none
INTERFACE
SUBROUTINE kind_pos(pos1, pos2, ikind, imkind, vkind, text)
! assumed shape arrays
integer :: ikind, imkind
character(150) text
character(10), dimension(ikind):: vkind
integer, dimension(:):: pos1, pos2 ! Position of variables in input file
END SUBROUTINE
END INTERFACE
integer i, j, k, ios
integer id, im, iy, itz
integer idate
character(3) ttext
character(250) text, filename
idate = 10
allocate (mtz(2,idate))
unit_cons = getunit()
open(unit_cons,file='con')
if (unit_mess .lt. 0) then
filename = mesfile(1)
unit_mess = getunit()
open(unit_mess,file=filename,iostat=ios,status='old',action='read')
endif
do
read(unit_mess,*) text
ios = scan(text, '!')
IF (ios .eq. 0) then
backspace(unit_mess)
exit
endif
enddo
! determin kind of measurement values; read 1. line
read (unit_mess, '(A)') text
ttext = adjustl(text)
if (ttext.eq.'dat' .or. ttext.eq.'Dat' .or. ttext.eq.'DAT') then
tkind = 1 ! day
else
tkind = 2 ! year
endif
call store_sim_kind(imkind, sim_kind, text)
! convert measurement values to daily counter
select case (tkind)
case (1) ! daily values
imess = 0
do
read (unit_mess, '(2(I2,1X),I4)',iostat=ios) id, im, iy
if (ios .lt. 0) exit
call daintz(id,im,iy,itz)
imess = imess + 1
if (imess .gt. idate) then
allocate (help1(2,idate))
help1 = mtz
deallocate (mtz)
idate = idate + 10
allocate (mtz(2,idate))
do j= 1,idate - 10
mtz(1,j) = help1(1,j)
mtz(2,j) = help1(2,j)
enddo
deallocate (help1)
endif
mtz(1,imess) = itz
mtz(2,imess) = iy
enddo
!read meassurement values
rewind (unit_mess)
allocate (mess1 (imess, imkind))
mess1 = -9999.0
do
read(unit_mess,*) text
IF (text .ne. '!') then
backspace(unit_mess)
exit
endif
enddo
read (unit_mess, '(A)') text
do j = 1,imess
read (unit_mess, *,iostat=ios) text, (mess1(j,k), k=1,imkind)
enddo
case (2) ! yearly values
imess = 0
if(allocated(mess1)) then
write (*,'(A)') ' Feld mess1 bereits allokiert'
STOP
endif
allocate (mess1(idate, imkind))
mess1 = -9999.0
do
imess = imess + 1
mtz(1,imess) = 0
read (unit_mess, *,iostat=ios) mtz(2,imess), (mess1(imess,k), k=1,imkind)
mtz(1,imess) = 0
if (ios .lt. 0) exit
if (imess .gt. idate-1) then
allocate (help1(2,idate))
allocate (help2(idate, imkind))
help1 = mtz
help2 = mess1
deallocate (mtz)
deallocate (mess1)
idate = idate + 10
allocate (mtz(2,idate))
allocate (mess1(idate, imkind))
mess1 = -9999.9
do j= 1,idate - 10
mtz(1,j) = 0
mtz(2,j) = help1(2,j)
do k=1,imkind
mess1(j,k) = help2(j,k)
enddo
enddo
deallocate (help1)
deallocate (help2)
endif
enddo
imess = imess - 1
end select
END SUBROUTINE prep_mw
!**************************************************************
SUBROUTINE prep_simout
use data_mess
use data_out
use data_simul
implicit none
INTERFACE
SUBROUTINE kind_pos(pos1, pos2, ikind, imkind, vkind, text)
! assumed shape arrays
integer :: ikind, imkind
character(150) text
character(10), dimension(ikind):: vkind
integer, dimension(:):: pos1, pos2 ! position of variablen in input file
END SUBROUTINE
END INTERFACE
integer i, ii, ik, j, k, year1
integer, allocatable, dimension(:):: yd, yy
character(150) :: filename
flag_mess = .FALSE.
year1 = year
! Create complete array of measurements
select case (tkind)
case (1)
anz_val = 0
allocate (yd(year1))
allocate (yy(year1))
do i=1,year1
yy(i) = time_b + i - 1
if (mod(yy(i),4) .eq. 0 .and. yy(i) .ne. 1900) then
yd(i) = 366
else
yd(i) = 365
endif
anz_val = anz_val + yd(i)
enddo
allocate (mess2(anz_val, imkind))
allocate (help1(2,anz_val))
mess2 = -9999.0
j = 1
k = 0
do while (mtz(2,j) .lt. time_b)
j = j+1
enddo
do ii = 1, year1
do i = 1, yd(ii)
k = k + 1
help1(1,k) = i
help1(2,k) = yy(ii)
if ((mtz(1,j) .eq. help1(1,k)) .and. (mtz(2,j) .eq. help1(2,k))) then
do ik = 1, imkind
mess2(k,ik) = mess1(j,ik)
flag_mess = .TRUE.
enddo ! ik
j = j+1
else
do ik = 1, imkind
mess2(k,ik) = -9999.9
enddo ! ik
endif
enddo ! i
enddo ! ii
case (2)
allocate (yy(year1))
anz_val = year1
do i=1,year1
yy(i) = time_b + i - 1
enddo
allocate (mess2(anz_val, imkind))
allocate (help1(2,anz_val))
mess2 = -9999.9
j = 1
do while (mtz(2,j) .lt. time_b)
j = j+1
enddo
do ii = 1, year1
help1(2,ii) = yy(ii)
help1(1,ii) = 0
if (mtz(2,j) .eq. help1(2,ii)) then
do ik = 1, imkind
mess2(ii,ik) = mess1(j,ik)
flag_mess = .TRUE.
enddo ! ik
j = j+1
else
do ik = 1, imkind
mess2(ii,ik) = -9999.9
enddo ! ik
endif
enddo ! ii
end select
if (.not. flag_mess) then
write (*,*)
write (*, '(A)') ' Statistical analysis:'
write (*, '(A)') ' No measurements within the simulation period'
write (*,*)
return
endif
! write file with complete set of meassurement values
if (flag_stat .eq. 3) then
filename = trim(dirout)//trim(site_name(1))//'_mess'//'.mes'
unit_mout = getunit()
open(unit_mout,file=filename,status='replace')
write (unit_mout, '(A)') '# Measurements '
write (unit_mout, '(A)') mess_info
write (unit_mout, '(A)', advance='no') '# day year'
do i=1,imkind
write (unit_mout, '(A13)', advance='no') sim_kind(i)
enddo
write (unit_mout, '(A)') ' '
do i = 1, anz_val
write (unit_mout, '(2I5)', advance='no') help1(1,i), help1(2,i)
do j = 1, imkind
write (unit_mout, '(E13.5)', advance='no') mess2(i,j)
enddo
write (unit_mout, '(A)') ' '
enddo
close(unit_mout)
endif
! Read data
allocate (sim1(anz_val, imkind))
allocate (stz(2,anz_val))
END SUBROUTINE prep_simout
!**************************************************************
SUBROUTINE kind_pos(pos1, pos2, ikind, imkind, vkind, text)
implicit none
integer imkind, & ! amount of read kinds of measurment value
ikind, & ! amount of allowed kinds of measurement value
j
character(10), dimension(ikind):: vkind
character(150) text
integer, dimension(:):: pos1, pos2 ! position of variable in input file
pos1 = 9999
imkind = 0
do j = 1,ikind
pos1(j) = index (text, trim(vkind(j)))
pos2(j) = j
if (pos1(j) .eq. 0) then
pos1(j) = 9999
else
imkind = imkind +1
endif
enddo ! j
call sort_index(ikind, pos1, pos2)
END SUBROUTINE kind_pos
!**************************************************************
SUBROUTINE store_sim_kind(imkind, vkind, text)
implicit none
integer imkind, & ! amount of read kinds of measurement values
ipos, & ! position of space character/sign
i, j
character(10), dimension(30):: vkind
character(250) text, text1, text2
character(1):: setleer = ''
character(75):: setascii
setascii = ''
do i = 48,122
j = i-47
setascii(j:j) = ACHAR(i) ! fill in with ASCII-character, no space character/signs
enddo
imkind = 0
ipos = verify(adjustl(text), setascii) ! first non-ASCII-character
text1 = ' '
text2 = adjustl(text)
text1 = text2(ipos:250) ! delete date/year
text2 = text1
ipos = scan(text2, setascii) ! first ASCII-character
text1 = text2(ipos:250) ! delete non-ASCII-characters
text2 = text1
do j = 1,30
ipos = verify(text2, setascii) ! first non_ASCII-character
vkind(j) = text2(1:ipos-1) ! save name of measurement value
imkind = imkind +1
text1 = text2(ipos:250) ! delete saved measurment value
text2 = text1
ipos = scan(text2, setascii) ! first ASCII-character
if (ipos .eq. 0) exit
text1 = text2(ipos:250)
text2 = text1
enddo ! j
END SUBROUTINE store_sim_kind
!**************************************************************
SUBROUTINE prep_stat_out
use data_mess
use data_out
use data_simul
implicit none
character(70) :: filename
character(8) actdate
character(10) acttime
filename = trim(site_name(1))//'_stat'//'.res'
call date_and_time(actdate, acttime)
unit_stat = getunit()
open(unit_stat,file=trim(dirout)//filename,status='replace')
write (unit_stat, '(A)') '# Comparison of simulated and observed values'
write (unit_stat, '(10A)') '# Date: ',actdate(7:8),'.',actdate(5:6),'.',actdate(1:4), &
' Time: ',acttime(1:2),':',acttime(3:4)
write (unit_stat, 1000)
write (unit_stat, 2000)
1000 format('# |-------- residuals ....... ', 15(' '), &
'|----------------------------- simulation -----------------------||------------------------------- observed ---------------------------|' )
2000 format( '# ipnr site_id kind number mean min max stand_dev variance var_coeff NME MAE NMAE', &
' SSE RMSE NRMSE PME PRMSE TIC MEFF cor_coeff rsquare', &
' mean min max stand_dev variance var_coeff mean min max stand_dev variance var_coeff tot_match1 tot_match2 tot_match3')
END SUBROUTINE prep_stat_out
!**************************************************************
SUBROUTINE read_simout
use data_mess
use data_out
use data_simul
use data_soil
implicit none
integer i,j, ios
character(150) :: text
character(50) :: message
character(10) :: helpsim
character(10) :: styp, skind
character :: text1
character(2) :: text2
character(3) :: text3
logical ex
integer :: year1, unithelp
real, dimension(26):: help_day
real, dimension(13):: help_sum ! size is adjusted to amount of elements in ...sum.out
real, dimension(27):: help_veg
real, dimension(28):: help_veg_spec
real, dimension(8):: help_lit
real, dimension(33):: help_soil
real, dimension(50):: tief
real, allocatable, dimension(:) :: help_temp, help_water
real htief, hnlay
sim1 = -9999.9
unitday = -99
unitcbal = -99
unitlit = -99
unittemp = -99
unitsum = -99
unitveg = -99
unitveg_pi = -99
unitveg_sp = -99
unitveg_bi = -99
unitsoil = -99
unitsoilini = -99
unitwater = -99
anz_sim = ip
year1 = year
do i=1,imkind
select case (sim_kind(i))
case ('AET')
if (tkind .eq. 1) then ! daily values
skind = 'day'
styp = 'out'
if (unitday .lt. 0) call open_sfile (skind, styp, unitday)
opos2(i) = 7
else
skind = 'soil'
styp = 'out'
if (unitsoil .lt. 0) call open_sfile (skind, styp, unitsoil)
opos2(i) = 10
endif
case ('BIOM', 'STVOL')
skind = 'veg'
styp = 'out'
if (unitveg .lt. 0) call open_sfile (skind, styp, unitveg)
opos2(i) = 14
case ('STVOL_pi')
skind = 'veg_pi'
styp = 'out'
if (unitveg_pi .lt. 0) call open_sfile (skind, styp, unitveg_pi)
opos2(i) = 14
case ('STVOL_sp')
skind = 'veg_sp'
styp = 'out'
if (unitveg_sp .lt. 0) call open_sfile (skind, styp, unitveg_sp)
opos2(i) = 14
case ('STVOL_bi')
skind = 'veg_bi'
styp = 'out'
if (unitveg_sp .lt. 0) call open_sfile (skind, styp, unitveg_bi)
opos2(i) = 14
case ('DG')
skind = 'veg'
styp = 'out'
if (unitveg .lt. 0) call open_sfile (skind, styp, unitveg)
opos2(i) = 7
case ('DG_pi')
skind = 'veg_pi'
styp = 'out'
if (unitveg_pi .lt. 0) call open_sfile (skind, styp, unitveg_pi)
opos2(i) = 7
case ('DG_sp')
skind = 'veg_sp'
styp = 'out'
if (unitveg_sp .lt. 0) call open_sfile (skind, styp, unitveg_sp)
opos2(i) = 7
case ('DG_bi')
skind = 'veg_pi'
styp = 'out'
if (unitveg_bi .lt. 0) call open_sfile (skind, styp, unitveg_bi)
opos2(i) = 7
case ('DBH')
skind = 'veg'
styp = 'out'
if (unitveg .lt. 0) call open_sfile (skind, styp, unitveg)
opos2(i) = 23
case ('DBH_pi')
skind = 'veg_pi'
styp = 'out'
if (unitveg_pi .lt. 0) call open_sfile (skind, styp, unitveg_pi)
opos2(i) = 24
case ('DBH_sp')
skind = 'veg_sp'
styp = 'out'
if (unitveg_sp .lt. 0) call open_sfile (skind, styp, unitveg_sp)
opos2(i) = 24
case ('DBH_bi')
skind = 'veg_pi'
styp = 'out'
if (unitveg_bi .lt. 0) call open_sfile (skind, styp, unitveg_bi)
opos2(i) = 24
case ('Fol')
skind = 'veg'
styp = 'out'
if (unitveg .lt. 0) call open_sfile (skind, styp, unitveg)
opos2(i) = 9
case ('Fol_pi')
skind = 'veg_pi'
styp = 'out'
if (unitveg_pi .lt. 0) call open_sfile (skind, styp, unitveg_pi)
opos2(i) = 9
case ('Fol_sp')
skind = 'veg_sp'
styp = 'out'
if (unitveg_sp .lt. 0) call open_sfile (skind, styp, unitveg_sp)
opos2(i) = 9
case ('Fol_bi')
skind = 'veg_pi'
styp = 'out'
if (unitveg_bi .lt. 0) call open_sfile (skind, styp, unitveg_bi)
opos2(i) = 9
case ('GPP')
if (tkind .eq. 1) then ! daily values
skind = 'sum'
styp = 'out'
if (unitsum .lt. 0) call open_sfile (skind, styp, unitsum)
opos2(i) = 11
else
skind = 'c_bal'
styp = 'out'
if (unitcbal .lt. 0) call open_sfile (skind, styp, unitsum)
opos2(i) = 1
endif
case ('HO')
skind = 'veg'
styp = 'out'
if (unitveg .lt. 0) call open_sfile (skind, styp, unitveg)
opos2(i) = 8
case ('HO_pi')
skind = 'veg_pi'
styp = 'out'
if (unitveg_pi .lt. 0) call open_sfile (skind, styp, unitveg_pi)
opos2(i) = 8
case ('HO_sp')
skind = 'veg_sp'
styp = 'out'
if (unitveg_sp .lt. 0) call open_sfile (skind, styp, unitveg_sp)
opos2(i) = 8
case ('HO_bi')
skind = 'veg_pi'
styp = 'out'
if (unitveg_bi .lt. 0) call open_sfile (skind, styp, unitveg_bi)
opos2(i) = 8
case ('LAI')
skind = 'veg'
styp = 'out'
if (unitveg .lt. 0) call open_sfile (skind, styp, unitveg)
opos2(i) = 4
case ('LAI_pi')
skind = 'veg_pi'
styp = 'out'
if (unitveg_pi .lt. 0) call open_sfile (skind, styp, unitveg_pi)
opos2(i) = 4
case ('LAI_sp')
skind = 'veg_sp'
styp = 'out'
if (unitveg_sp .lt. 0) call open_sfile (skind, styp, unitveg_sp)
opos2(i) = 4
case ('LAI_bi')
skind = 'veg_pi'
styp = 'out'
if (unitveg_bi .lt. 0) call open_sfile (skind, styp, unitveg_bi)
opos2(i) = 4
case ('MH')
skind = 'veg'
styp = 'out'
if (unitveg .lt. 0) call open_sfile (skind, styp, unitveg)
opos2(i) = 24
case ('MH_pi')
skind = 'veg_pi'
styp = 'out'
if (unitveg_pi .lt. 0) call open_sfile (skind, styp, unitveg_pi)
opos2(i) = 25
case ('MH_sp')
skind = 'veg_sp'
styp = 'out'
if (unitveg_sp .lt. 0) call open_sfile (skind, styp, unitveg_sp)
opos2(i) = 25
case ('MH_bi')
skind = 'veg_bi'
styp = 'out'
if (unitveg_bi .lt. 0) call open_sfile (skind, styp, unitveg_bi)
opos2(i) = 25
case ('NTREE')
skind = 'veg'
styp = 'out'
if (unitveg .lt. 0) call open_sfile (skind, styp, unitveg)
opos2(i) = 3
case ('NTREE_pi')
skind = 'veg_pi'
styp = 'out'
if (unitveg_pi .lt. 0) call open_sfile (skind, styp, unitveg_pi)
opos2(i) = 3
case ('NTREE_sp')
skind = 'veg_sp'
styp = 'out'
if (unitveg_sp .lt. 0) call open_sfile (skind, styp, unitveg_sp)
opos2(i) = 3
case ('NTREE_bi')
skind = 'veg_pi'
styp = 'out'
if (unitveg_bi .lt. 0) call open_sfile (skind, styp, unitveg_bi)
opos2(i) = 3
case ('NEE')
skind = 'sum'
styp = 'out'
if (unitsum .lt. 0) call open_sfile (skind, styp, unitsum)
opos2(i) = 6
case ('NEP')
skind = 'c_bal'
styp = 'out'
if (unitcbal .lt. 0) call open_sfile (skind, styp, unitcbal)
opos2(i) = 3
case ('Litter')
skind = 'litter'
styp = 'out'
if (unitlit .lt. 0) call open_sfile (skind, styp, unitlit)
opos2(i) = 1
case ('prec_stand')
skind = 'soil'
styp = 'out'
if (unitsoil .lt. 0) call open_sfile (skind, styp, unitsoil)
opos2(i) = 2
case ('prec_st_d')
skind = 'day'
styp = 'out'
if (unitday .lt. 0) call open_sfile (skind, styp, unitday)
opos2(i) = 4
case ('s_resp')
skind = 'day'
styp = 'out'
if (unitday .lt. 0) call open_sfile (skind, styp, unitday)
opos2(i) = 12
case ('Snow')
skind = 'day'
styp = 'out'
if (unitday .lt. 0) call open_sfile (skind, styp, unitday)
opos2(i) = 5
case ('STBIOM')
skind = 'veg'
styp = 'out'
if (unitveg .lt. 0) call open_sfile (skind, styp, unitveg)
opos2(i) = 10
case ('STBIOM_pi')
skind = 'veg_pi'
styp = 'out'
if (unitveg_pi .lt. 0) call open_sfile (skind, styp, unitveg_pi)
opos2(i) = 10
case ('STBIOM_sp')
skind = 'veg_sp'
styp = 'out'
if (unitveg_sp .lt. 0) call open_sfile (skind, styp, unitveg_sp)
opos2(i) = 10
case ('STBIOM_bi')
skind = 'veg_bi'
styp = 'out'
if (unitveg_sp .lt. 0) call open_sfile (skind, styp, unitveg_bi)
opos2(i) = 10
case ('Stem_inc')
skind = 'veg'
styp = 'out'
if (unitveg .lt. 0) call open_sfile (skind, styp, unitveg)
opos2(i) = 13
case ('Stem_inc_pi')
skind = 'veg_pi'
styp = 'out'
if (unitveg_pi .lt. 0) call open_sfile (skind, styp, unitveg_pi)
opos2(i) = 13
case ('Stem_inc_sp')
skind = 'veg_sp'
styp = 'out'
if (unitveg_sp .lt. 0) call open_sfile (skind, styp, unitveg_sp)
opos2(i) = 13
case ('Stem_inc_bi')
skind = 'veg_pi'
styp = 'out'
if (unitveg_bi .lt. 0) call open_sfile (skind, styp, unitveg_bi)
opos2(i) = 13
case ('TER')
if (tkind .eq. 1) then ! daily values
skind = 'sum'
styp = 'out'
if (unitsum .lt. 0) call open_sfile (skind, styp, unitsum)
opos2(i) = 12
else
skind = 'c_bal'
styp = 'out'
if (unitcbal .lt. 0) call open_sfile (skind, styp, unitsum)
opos2(i) = 6
endif
case ('transtree')
skind = 'day'
styp = 'out'
if (unitday .lt. 0) call open_sfile (skind, styp, unitday)
opos2(i) = 9
case ('WC_002')
skind = 'watvol'
styp = 'out'
if (unitwater .lt. 0) call open_sfile (skind, styp, unitwater)
opos2(i) = 1
case ('TS_002')
skind = 'temp'
styp = 'out'
if (unittemp .lt. 0) call open_sfile (skind, styp, unittemp)
opos2(i) = 2
case default
text2 = sim_kind(i) (1:2)
if ((text2 .eq. 'TS') .or. (text2 .eq. 'WC')) then
skind = 'soil'
styp = 'ini'
if (unitsoilini .lt. 0) then
call open_sfile (skind, styp, unitsoilini)
read (unitsoilini, *) text
read (unitsoilini, *) text
do j=1, 50
read (unitsoilini, *,iostat=ios) hnlay, tief(j)
if (hnlay .eq. 0) then
exit
else
nlay = hnlay
endif
if (ios .ne. 0) exit
enddo
endif
select case (text2)
case ('TS')
skind = 'temp'
styp = 'out'
if (unittemp .lt. 0) call open_sfile (skind, styp, unittemp)
text3 = sim_kind(i) (4:6)
write (helpsim, *) text3
read (helpsim,*) htief
! htief = 5.
do j=2,nlay
if ((tief(j)-tief(1)) .ge. htief) then
opos2(i) = j+1
exit
endif
enddo
if (opos2(i) .le.0) then
message = "no simulation values of "//text2//" for depth "
opos2(i) = nlay
write(unit_err,'(A)',advance='no') trim(message)
write(unit_err,'(F5.0,A)') htief, " cm"
else
message = "simulation values of "//text2//" for depth "
write(unit_err,'(A)',advance='no') trim(message)
write(unit_err,'(F5.0,A)') htief, " cm"
message = " selected layer: "
write(unit_err,'(A)',advance='no') trim(message)
write(unit_err,'(I3)') j
endif
case ('WC')
skind = 'watvol'
styp = 'out'
if (unitwater .lt. 0) call open_sfile (skind, styp, unitwater)
text3 = sim_kind(i) (4:6)
write (helpsim, *) text3
read (helpsim,*) htief
do j=2,nlay
if ((tief(j)-tief(1)) .ge. htief) then
opos2(i) = j
exit
endif
enddo
if (opos2(i) .le.0) then
message = "no simulation values of "//text2//" for depth "
opos2(i) = nlay
write(unit_err,'(A)',advance='no') trim(message)
write(unit_err,'(F5.0,A)') htief, " cm"
else
message = "simulation values of "//text2//" for depth "
write(unit_err,'(A)',advance='no') trim(message)
write(unit_err,'(F5.0,A)') htief, " cm"
message = " selected layer: "
write(unit_err,'(A)',advance='no') trim(message)
write(unit_err,'(I3)') j
endif
end select ! text2
else
fkind = fkind + 1
write (unit_err, *)
write (unit_err, '(A)') 'Statistics - Undefined kind of measurement '//sim_kind(i)
endif
end select
enddo ! i - imkind
! read in results file
! read day-file
if (unitday .ge. 0) then
do
read(unitday,*) text
IF (adjustl(text) .ne. '#') then
backspace(unitday)
exit
endif
enddo
do j = 1,anz_val
read (unitday, *) stz(1,j), stz(2,j), help_day
do i=1,imkind
select case (sim_kind(i))
case ('AET','Snow','prec_st_d','s_resp','transtree')
sim1(j,i) = help_day(opos2(i))
end select
enddo
enddo
endif ! unitday
! read temp-file
if (unittemp .ge. 0) then
do
read(unittemp,*) text
IF (adjustl(text) .ne. '#') then
backspace(unittemp)
exit
endif
enddo
allocate (help_temp(nlay))
do j = 1,anz_val
read (unittemp, *) stz(1,j), stz(2,j), help_temp
do i=1,imkind
if (opos2(i) .gt. 0) then
select case (sim_kind(i) (1:2))
case ('TS')
sim1(j,i) = help_temp(opos2(i))
end select
endif
enddo
enddo
deallocate (help_temp)
endif ! unittemp
! read water-file
if (unitwater .ge. 0) then
do
read(unitwater,*) text
IF (adjustl(text) .ne. '#') then
backspace(unitwater)
exit
endif
enddo
allocate (help_water(nlay))
do j = 1,anz_val
read (unitwater, *) stz(1,j), stz(2,j), help_water
do i=1,imkind
if (opos2(i) .gt. 0) then
select case (sim_kind(i) (1:2))
case ('WC')
sim1(j,i) = help_water(opos2(i))
end select
endif
enddo
enddo
deallocate (help_water)
endif ! unitwater
! read sum-file
if (unitsum .ge. 0) then
do
read(unitsum,*) text
text1 = adjustl(text)
IF (text1 .ne. '#') then
backspace(unitsum)
exit
endif
enddo
do j = 1,anz_val
read (unitsum, *) stz(1,j), stz(2,j), help_sum
do i=1,imkind
select case (sim_kind(i))
case ('NEE','GPP','TER')
sim1(j,i) = help_sum(opos2(i))
end select
enddo
enddo
endif ! unitsum
! read c_bal-file
if (unitcbal .ge. 0) then
do
read(unitcbal,*) text
text1 = adjustl(text)
IF (text1 .ne. '#') then
exit ! 1. line for standard values is skiped
endif
enddo
do j = 1,year1
read (unitcbal, *) stz(2,j), help_veg
do i=1,imkind
select case (sim_kind(i))
case ('NEP','GPP','TER')
sim1(j,i) = help_veg(opos2(i))
end select
enddo
enddo
endif ! unitcbal
! read litter-file
if (unitlit .ge. 0) then
do
read(unitlit,*) text
text1 = adjustl(text)
IF (text1 .ne. '#') then
exit
endif
enddo
do j = 1,year1
read (unitlit, *) stz(2,j), help_lit
do i=1,imkind
select case (sim_kind(i))
case ('Litter')
sim1(j,i) = help_lit(opos2(i))
end select
enddo
enddo
endif ! unitlit
! read soil-file
if (unitsoil .ge. 0) then
do
read(unitsoil,*) text
text1 = adjustl(text)
IF (text1 .ne. '#') then
exit ! 1. line of standard values is skiped
endif
enddo
do j = 1,year1
read (unitsoil, *) stz(2,j), help_soil
do i=1,imkind
select case (sim_kind(i))
case ('prec_stand')
sim1(j,i) = help_soil(opos2(i)) - help_soil(opos2(i)+1)
case ('AET')
sim1(j,i) = help_soil(opos2(i))
end select
enddo
enddo
endif ! unitsoil
! read veg-file
if (unitveg .ge. 0) then
do
read(unitveg,*) text
text1 = adjustl(text)
IF (text1 .ne. '#') then
exit
endif
enddo
do j = 1,year1
read (unitveg, *) stz(2,j), help_veg
do i=1,imkind
select case (sim_kind(i))
case ('STBIOM')
sim1(j,i) = (help_veg(opos2(i)) + help_veg(opos2(i)+2))
case ('BIOM','DG','DBH','Fol','LAI','NTREE','Stem_inc')
sim1(j,i) = help_veg(opos2(i))
case ('HO','MH')
sim1(j,i) = help_veg(opos2(i)) / 100.
end select
enddo
enddo
endif ! unitveg
! read veg_pi-file
if (unitveg_pi .ge. 0) then
do
read(unitveg_pi,*) text
text1 = adjustl(text)
IF (text1 .ne. '#') then
exit
endif
enddo
do j = 1,year1
read (unitveg_pi, *) stz(2,j), help_veg_spec
do i=1,imkind
select case (sim_kind(i))
case ('STBIOM_pi')
sim1(j,i) = (help_veg_spec(opos2(i)) + help_veg_spec(opos2(i)+2))
case ('BIOM_pi','DG_pi','DBH_pi','Fol_pi','LAI_pi','NTREE_pi','Stem_inc_pi')
sim1(j,i) = help_veg_spec(opos2(i))
case ('HO_pi','MH_pi')
sim1(j,i) = help_veg_spec(opos2(i)) / 100.
end select
enddo
enddo
endif ! unitveg_pi
! read veg_sp-file
if (unitveg_sp .ge. 0) then
do
read(unitveg_sp,*) text
text1 = adjustl(text)
IF (text1 .ne. '#') then
exit
endif
enddo
do j = 1,year1
read (unitveg_sp, *) stz(2,j), help_veg_spec
do i=1,imkind
select case (sim_kind(i))
case ('STBIOM_sp')
sim1(j,i) = (help_veg_spec(opos2(i)) + help_veg_spec(opos2(i)+2))
case ('BIOM_sp','DG_sp','DBH_sp','Fol_sp','LAI_sp','NTREE_sp','Stem_inc_sp')
sim1(j,i) = help_veg_spec(opos2(i))
case ('HO_sp','MH_sp')
sim1(j,i) = help_veg_spec(opos2(i)) / 100.
end select
enddo
enddo
endif ! unitveg_sp
! read veg_bi-file
if (unitveg_bi .ge. 0) then
do
read(unitveg_bi,*) text
text1 = adjustl(text)
IF (text1 .ne. '#') then
exit
endif
enddo
do j = 1,year1
read (unitveg_bi, *) stz(2,j), help_veg_spec
do i=1,imkind
select case (sim_kind(i))
case ('STBIOM_bi')
sim1(j,i) = (help_veg_spec(opos2(i)) + help_veg_spec(opos2(i)+2))
case ('BIOM_bi','DG_bi','DBH_bi','Fol_bi','LAI_bi','NTREE_bi','Stem_inc_bi')
sim1(j,i) = help_veg_spec(opos2(i))
case ('HO_bi','MH_bi')
sim1(j,i) = help_veg_spec(opos2(i)) / 100.
end select
enddo
enddo
endif ! unitveg_bi
END SUBROUTINE read_simout
!**************************************************************
SUBROUTINE open_sfile (okind, otyp, unitnr)
use data_mess
use data_out
use data_simul
implicit none
integer unitnr
character(150) :: simsumfile ! simulation output sum-file
character(150) :: simoutfile ! simulation output file
character(10) :: helpsim
character(10) :: otyp, okind
logical ex
WRITE(helpsim,'(I2)') app(ip)
read(helpsim,*) anh
simoutfile = trim(dirout)//trim(site_name(ip))//'_'//trim(okind)//'.'//trim(otyp)//trim(anh)
inquire (File = simoutfile, exist = ex)
if(ex .eqv. .false.) then
write (*, '(A)') ' >>>foresee message: no such file ', adjustl(simoutfile)
return
else
write (*, '(A)') ' >>>foresee message: Filetest - file exists ',trim(simoutfile)
endif
unitnr = getunit()
open(unitnr,file=simoutfile,status='old')
END SUBROUTINE open_sfile
source_code/version_2.3_windows/npp.f 0 → 100644
View file @ 82df1085
!*****************************************************************!
!* *!
!* 4C (FORESEE) *!
!* *!
!* *!
!* Subroutines for: *!
!* Calculation of daily NPP *!
!* *!
!* SR OPT_PS: optimum photosynthesis & conductance calculation *!
!* SR NPP: determination of realized net primary production *!
!* *!
!* 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 OPT_PS *!
!***********************!
! calculates optimum photosynthesis following Haxeltine & Prentice (1996)
SUBROUTINE OPT_PS(temp, dayl, PAR, ApPa)
!*** Declaration part ***!
USE data_species
USE data_stand
USE data_simul
USE data_climate
USE data_par
IMPLICIT NONE
! input variables
REAL :: temp, & ! temperature
dayl, & ! day length
PAR ! total available PAR
! auxiliary variables
REAL :: ApPa, & ! atmospheric pressure [Pa], input [hPa]
VmOpt = 0., &
VmMax = 0., & ! nitrogen limited carboxylation rate
Jc = 0., & ! Rubisco limited rate of photosynthesis
Je = 0., & ! photosynthetic response under light limitation
assiSpe = 0., & ! specific gross photosynthesis [gC m-2 canopy projection d-1]
respSpe = 0., & ! specific leaf respiration [gC m-2 canopy projection d-1]
assDt, & ! net daytime assimilation rate
PHIT = 0., &
XHELP = 0., &
kco2, &
ko2, &
tau, & ! Rubisco specificity
piCO2, & ! leaf internal CO2 partial pressure [Pa]
gammas, & ! CO2 compensation point in absence of mitochondrial respiration [Pa]
delta, &
sigma, &
c1, &
c2, &
vmspe, &
redn_h, &
h_age
! variables required for technical reasons
! INTEGER :: nl ! loop variable for crown layers
integer ntr, i, j
TYPE(coh_obj), POINTER :: p
!*** Calculation part ***!
! conversion of pressure from [kPa] to [P]
ApPa = ApPa * 100. ! hPa ==> Pa
! initialization of canopy conductance
gp_can = 0.
gp_tot = 0.
phot_C=0.
! polar night
if (dayl .lt. zero) then
p => pt%first
DO WHILE (ASSOCIATED(p))
p%coh%LUE = 0.0
p%coh%assi = 0.0
p%coh%resp = 0.0
p%coh%gp = 0.0
p%coh%Ndemc_d = 0.0
p => p%next
enddo
return
endif
! Determination of photosynthesis nitrogen reduction factor RedN for species
select case (flag_limi)
case (11)
do j=1,anrspec
i = nrspec(j)
redn_h = svar(i)%RedN
if(svar(i)%Ndem .gt. 0) then
svar(i)%RedN = svar(i)%Nupt / svar(i)%Ndem
if (svar(i)%RedN .gt. 1.) svar(i)%RedN=1.
else
svar(i)%RedN = redn_h
endif
enddo
case (12)
do j=1,anrspec
i = nrspec(j)
redn_h = svar(i)%RedN
if(svar(i)%Ndem .gt. 0) then
if (svar(i)%Nupt .gt. svar(i)%Ndem) then
svar(i)%RedN = 1
else
svar(i)%RedN = exp((svar(i)%Nupt / svar(i)%Ndem) -1.)
endif
else
svar(i)%RedN = redn_h
endif
enddo
case (13,14)
do j=1,anrspec
i = nrspec(j)
redn_h = svar(i)%RedN
if(svar(i)%Ndem .gt. 0) then
xhelp = svar(i)%Nupt / svar(i)%Ndem
svar(i)%RedN = 2.*(xhelp+0.01) / (xhelp+1.)
else
svar(i)%RedN = redn_h
endif
if(svar(i)%Nupt .le. zero) svar(i)%RedN = redn_h
enddo
case (15)
do j=1,anrspec
i = nrspec(j)
redn_h = svar(i)%RedN
if(svar(i)%Ndem .gt. zero) then
xhelp = svar(i)%Nupt / svar(i)%Ndem
select case (i)
case (3) ! pine
if (xhelp .gt. 10.) then
svar(i)%RedN=1.
else
svar(i)%RedN = exp(xhelp -0.7) - 0.5
endif
case (10, 14) ! dougfir, ground vegetation
continue ! annual calculation in RedN_calc
case default
svar(i)%RedN = 2.*(xhelp+0.01) / (xhelp+1.)
end select
if (svar(i)%RedN .gt. 1.) svar(i)%RedN=1.
if (svar(i)%RedN .lt. 0.1) svar(i)%RedN=0.1
else
svar(i)%RedN = redn_h
endif
if(svar(i)%Nupt .le. zero) svar(i)%RedN = redn_h
if (i.eq.nspec_tree+2) then
svar(i)%RedN=1.
endif
enddo
case (16)
svar%Ndemp = -1.*svar%Ndemp
svar%Nuptp = -1.*svar%Nuptp
zeig => pt%first
DO WHILE (ASSOCIATED(zeig))
ns = zeig%coh%species
ntr = zeig%coh%ntreea
svar(ns)%Ndemp = svar(ns)%Ndemp + ntr * zeig%coh%Ndemc_c
svar(ns)%Nuptp = svar(ns)%Nuptp + ntr * zeig%coh%Nuptc_c
zeig => zeig%next
ENDDO
do j=1,anrspec
i = nrspec(j)
redn_h = svar(i)%RedN
if(svar(i)%Ndemp .gt. 0) then
svar(i)%RedN = svar(i)%Nuptp / svar(i)%Ndemp
else
svar(i)%RedN = redn_h
endif
enddo
end select ! flag_limi
! internal partial pressure of CO2 (Eq A9)
piCO2 = ApPa * lambda * CO2
! temperature dependent damping function; orig pars: 0.2, 10.
PHIT = 1. / ( 1.+exp(0.4*(7.-temp)) )
! loop over all cohorts
p => pt%first
DO WHILE (ASSOCIATED(p))
ns = p%coh%species
! parameter variations with temperature (Eq A14)
KCO2 = spar(ns)%kCO2_25 * spar(ns)%q10_kCO2 ** ( (temp - 25.) / 10.)
KO2 = spar(ns)%kO2_25 * spar(ns)%q10_kO2 ** ( (temp - 25.) / 10.)
tau = spar(ns)%pc_25 * spar(ns)%q10_pc ** ( (temp - 25.) / 10.)
! CO2 compensation point in absence of mitochondrial respiration, O2 converted from kPa to Pa
gammas = O2*1000 / (2. * tau)
! slope for light response under PAR limitation (Eq A7)
C1 = PHIT*spar(ns)%phic*Cmass*QCO2*QCO2a * (piCO2 - gammas) / (piCO2 + 2.*gammas) ! 0.35
! slope for light response under Rubisco limitation (Eq A11)
C2 = (piCO2 - gammas) / ( piCO2 + KCO2 * (1. + O2 / KO2) )
! daylength-dependent term (original: s)
DELTA = (24. / dayL) * spar(ns)%pb
! optimal light use efficiency (Eq A17 and A17a)
SIGMA = AMAX1 (0.0001, 1. - (C2 - DELTA) / (C2 - PS * DELTA) ) ** 0.5 ! 0.25 - 0.45
VmSpe = (1. / spar(ns)%pb) * (C1 / C2) * ( (2.*PS - 1.) * &
DELTA - (2.*PS * DELTA - C2) * SIGMA)
! maximum carboxylation potential in gC m-2 d-1 ???
VmOpt = p%coh%totFPAR * PAR * VmSpe
! Determination of photosynthesis nitrogen reduction factor RedN
select case (flag_limi)
case (0,1)
p%coh%RedNc = 1.
case (2,3,10)
p%coh%RedNc = svar(ns)%RedN
case (4,5)
! N effect on photosynthesis
XHELP = PN * exp ( - 0.0693 * (temp - 25.) )
! calculate Vmax as function of metabolically active nitrogen per unit crown projection area first, is now in mymol m-2 s-1
VmMax = (p%coh%N_fol - Nc0*p%coh%x_fol) / p%coh%crown_area / XHELP
p%coh%RedNc = MIN (1., VmMax / VmOpt)
case (6,7)
if ((p%coh%Ndemc_d .gt. 1.E-6) .and. (p%coh%Nuptc_d .gt. 1.E-6)) then
p%coh%RedNc = p%coh%Nuptc_c / p%coh%Ndemc_c
else
p%coh%RedNc = svar(ns)%RedN
endif
case (8,9)
h_age = p%coh%x_age
if( h_age.lt.50.) then
redn_h =svar(ns)%RedN
else if( (h_age-time).lt.50) then
! age dependent reduction of redN
redn_h = svar(ns)%RedN*(1-max(0.,(h_age-50)*0.002))
else
redn_h = svar(ns)%RedN*(1-max(0.,(time)*0.002))
end if
p%coh%RedNc = redn_h
case (11,12,13,14,15,16) ! calculation of cohort loop
p%coh%RedNc = svar(p%coh%species)%RedN
end select
! limiting rates
Jc = C2 * VmSpe / 24.
Je = C1 / dayL
! gross assimilation and leaf respiration in [g C/(day*m2)]
p%coh%LUE = dayL * ( Je+Jc - SQRT( (Je+Jc) * (Je+Jc) - 4.*PS*Je*Jc) ) / (2.*PS) * p%coh%RedNc
assiSpe = p%coh%LUE * p%coh%totFPAR * PAR
if(p%coh%totFPAR.lt.0) then
continue
end if
respSpe = spar(ns)%pb * VmOpt * p%coh%RedNc
phot_C = phot_C + p%coh%ntreea*assiSpe !summation for output BE
p%coh%assi = assiSpe * kPatchSize / 1000. * (1/cpart) ! conversion g C/day*m2 -> kg DW/day*patch
p%coh%resp = respSpe * kPatchSize / 1000. * (1/cpart) ! conversion g C/day*m2 -> kg DW/day*patch
! optimum stomatal conductance (modified from Haxeltine & Prentice 1996) [mol/(m2*d)]
assDt = assiSpe - dayL/24.*respSpe
p%coh%gp = AMAX1( gmin, 1.56*assDt / (1.0-lambda) / CO2 / Cmass )
! update canopy conductance
IF (p%coh%species.le.nspec_tree .or. p%coh%species.eq.nspec_tree+2 ) then
gp_can = gp_can + p%coh%gp*p%coh%nTreeA
else
gp_tot = gp_tot + p%coh%gp*p%coh%nTreeA
endif
p => p%next
END DO
gp_tot = gp_tot + gp_can
END SUBROUTINE OPT_PS
!********************!
!* SUBROUTINE NPP *!
!********************!
! determines realized assimilation rate by taking into account water stress, and
! calculates growth and maintenance respiration, plus overall net primary production
SUBROUTINE NPP( temp, dayL, PAR, jx )
!*** Declaration part ***!
USE data_par
USE data_stand
USE data_species
USE data_simul
USE data_soil_cn
IMPLICIT NONE
! input variables
REAL:: temp, &
dayL, &
PAR
! auxiliary variables
REAL :: netAsspot, & ! daily potential (= no water and nutrient limitation) net assimilation rate [= dimension of p%coh%assi]
netAss, & ! daily net assimilation rate [= dimension of p%coh%assi]
maintResp, & ! daily maintenance respiration costs
dailypotNPP, & ! daily potential (= no water and nutrient limitation) net primary productivity per tree
dailyNPP, & ! daily net primary productivity per tree [gC tree-1]
drLimF, & ! drought factor limiting the assimilation rate
grass = 0, & ! gross daily assimilation rate
respfol, &
prms, &
prmr, &
NPP_mistletoe,& ! NPP of mistletoe
pq10, & ! q10 value for maint. respiration stem, fine root
help, presp
INTEGER :: jx ! time step length of PS/NPP model
TYPE(coh_obj), POINTER :: p
pq10=2.0
!*** Calculation part ***!
!extraction of theor. produced NPP of mistletoe cohort
p => pt%first
do while (associated(p))
if (p%coh%species.eq.nspec_tree+2) then
NPP_mistletoe=p%coh%NPP
NPP_demand_mistletoe=0.3*NPP_mistletoe ! NPP that mistletoe demands from host (30% heterotroph carbon gain (Richter 1992)
p%coh%NPP=0.7*NPP_mistletoe ! rest of NPP stays with mistletoe (autotroph)
end if
p => p%next
enddo
dailypotNPP_C=0.
dailyNPP_C=0.
dailyautresp_C = 0.
dailygrass_C = 0.
dailynetass_C = 0.
respr_day = 0.
dailyrespfol_C = 0.
! loop over all cohorts
p => pt%first
DO WHILE (ASSOCIATED(p))
! reduction of NPP of mistletoe infected tree cohort
if (p%coh%mistletoe.eq.1) then
p%coh%NPP = p%coh%NPP-NPP_demand_mistletoe
endif
ns = p%coh%species
IF ( p%coh%drIndPS .lt. 0.0 ) THEN
continue
endif
! drought index
IF ( p%coh%nDaysPS /= 0. ) THEN
p%coh%drIndPS = p%coh%drIndPS / p%coh%nDaysPS
ELSE
p%coh%drIndPS = 0. ! -> npp = 0
END IF
! limiting function
select case(flag_limi)
case(0,2,4,6,8,14)
drLimF = 1.0
case default
drLimF = p%coh%drIndPS
end select
! total net assimilation, maintenance respiration and NPP of this tree
if (p%coh%RedNc .gt. 1.E-6) then
netAsspot = (p%coh%assi - p%coh%resp) / p%coh%RedNc
else
netAsspot = 0.
endif
netAss = drLimF * (p%coh%assi - p%coh%resp)
grass = drLimF * p%coh%assi
p%coh%respfol = grass -netAss
respfol = p%coh%respfol
IF (flag_resp==1) THEN
! calculate temperature dependant rates
prmr=spar(ns)%prmr*pq10**((temp-15)/10)
prms=spar(ns)%prms*pq10**((temp-15)/10)
! leaf maintenance respiration added
maintResp = prms * p%coh%x_sap + prmr * p%coh%x_frt + respfol
! for complete outputs of respiration components:
p%coh%respsap = prms * p%coh%x_sap
p%coh%respfrt = prmr * p%coh%x_frt
p%coh%respbr = prms * p%coh%x_tb
dailypotNPP = (1.-spar(ns)%prg) * (netAsspot - maintResp)
dailyNPP = (1.-spar(ns)%prg) * (netAss - maintResp)
help = spar(ns)%prg * (netAss - maintResp)
ELSEIF (flag_resp==2) THEN
presp=0.03
maintResp = (p%coh%x_sap*cpart/spar(ns)%cnr_stem + p%coh%x_crt*cpart/spar(ns)%cnr_crt + p%coh%x_tb*cpart/spar(ns)%cnr_tbc + p%coh%x_frt*cpart/spar(ns)%cnr_frt)*presp
maintresp=maintresp*exp(308.56*((1/56.02)-(1/(temp+46.02))))
dailypotNPP = (1.-spar(ns)%prg) * (netAsspot - maintResp)
dailyNPP = (1.-spar(ns)%prg) * (netAss - maintResp)
ELSE
dailypotNPP=netAsspot*(1-spar(ns)%respcoeff)
dailyNPP=netAss*(1-spar(ns)%respcoeff)
maintResp = netAss*spar(ns)%respcoeff
ENDIF
IF(p%coh%species <= nspec_tree) THEN
dailypotNPP_C = dailypotNPP_C + p%coh%ntreea*dailypotNPP*cpart*kg_in_g / (kPatchSize) !conversion in gC/m2
dailyNPP_C = dailyNPP_C + p%coh%ntreea*dailyNPP*cpart*kg_in_g / (kPatchSize) !conversion in gC/m2
if (flag_resp.eq.1) then
dailyautresp_C = dailyautresp_C + p%coh%ntreea*(maintresp+help)*cpart*kg_in_g / (kPatchSize)
ELSE ! flag_resp=0
dailyautresp_C = dailyautresp_C + p%coh%ntreea*(respfol+maintresp)*cpart*kg_in_g / (kPatchSize)
end if
dailygrass_C = dailygrass_C + p%coh%ntreea*grass*cpart*kg_in_g / (kPatchSize)
dailynetass_C = dailynetass_C + p%coh%ntreea*netass*cpart*kg_in_g / (kPatchSize)
dailyrespfol_C = dailyrespfol_C + p%coh%ntreea*respfol*cpart*kg_in_g / (kPatchSize)
ENDIF
if (dailyNPP .gt. 10000.) then
continue
end if
! update annual net assimilation and NPP sum
p%coh%netAss = p%coh%netAss + netAss * jx
p%coh%grossass = p%coh%grossass + grass * jx
if (flag_resp.eq.1)then
p%coh%maintres = p%coh%maintres + (maintresp + help) * jx
else
p%coh%maintres = p%coh%maintres + (maintresp + respfol) * jx
end if
select case (flag_dis) !phloem disturbance
case (1,2)
dailyNPP = dailyNPP * phlo_feed
case (0)
dailyNPP = dailyNPP
end select
p%coh%NPP = p%coh%NPP + dailyNPP * jx
p%coh%weekNPP = dailyNPP * jx
IF (time_out .gt. 0 .and. flag_cohout .eq. 2) THEN
CALL OUT_ASS( p%coh%ident, PAR, p%coh%NPP, p%coh%totFPAR, p%coh%LUE, p%coh%netAss, p%coh%grossass, p%coh%nDaysPS)
ENDIF
! remove Mistletoe from N demand calculation
if (p%coh%species.ne.nspec_tree+2) then
p%coh%Ndemc_d=dailyNPP*1000.*spar(ns)%pcnr
end if
IF((flag_limi==4 .OR. flag_limi==5) .AND. 1. > p%coh%RedNc .AND. &
p%coh%N_fol/p%coh%t_leaf <= 4.5 .AND. p%coh%N_pool > 0.) THEN
IF(p%coh%N_pool > p%coh%N_fol*(1./p%coh%RedNc - 1.)) THEN
p%coh%N_fol = p%coh%N_fol / p%coh%RedNc
p%coh%N_pool = p%coh%N_pool - p%coh%N_fol*(1./p%coh%RedNc - 1.)
ELSE
p%coh%N_fol = p%coh%N_fol + p%coh%N_pool
p%coh%N_pool = 0.0
ENDIF
ENDIF
p => p%next
END DO
END SUBROUTINE NPP
source_code/version_2.3_windows/old_out.f 0 → 100644
View file @ 82df1085
!*****************************************************************!
!* *!
!* 4C (FORESEE) Simulation Model *!
!* *!
!* *!
!* Subroutines for: *!
!* - output routines - *!
!* Specific files written from model subroutines *!
!* *!
!* contains *!
!* OLD_OUT: Initialization of output files ("private") *!
!* OUT_ASS: file output ("private") *!
!* OUT_ALL: output for monitoring allocation *!
!* OUTTEST: test of output flags *!
!* OUTTEST_YEAR: test of output flags - yearly output *!
!* OUTTEST_DAY: test of output flags - daily output *!
!* OUTTEST_COH: test of output flags - cohort output *!
!* *!
!* 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 old_out
use data_out
use data_simul
implicit none
INTEGER help_ip
CHARACTER(100) ::filename
IF(site_nr==1) THEN
help_ip=site_nr
ELSE
help_ip=ip
END IF
! open output files & write column headers
if (time_out .gt. 0) then
if (out_flag_light .ne. 0) then
unit_light=getunit()
filename = trim(site_name(help_ip))//'_light.res'//trim(anh)
OPEN (unit_light, file=trim(dirout)//filename, status = 'UNKNOWN')
WRITE (unit_light, '(A)') 'year coh totFAPR LAI '
endif
if (flag_cohout .eq. 2) then
unit_prod = getunit()
filename = trim(site_name(help_ip))//'_prod.res'//trim(anh)
OPEN (unit_prod, file=trim(dirout)// filename, status = 'UNKNOWN')
WRITE (unit_prod, '(A)') ' year day coh PAR totFPAR LUE NPP netAss grossAss nDaysPS'
unit_allo = getunit()
filename = trim(site_name(help_ip))//'_allo.res'//trim(anh)
OPEN (unit_allo, file=trim(dirout)//filename, status = 'UNKNOWN')
WRITE (unit_allo, '(A)') ' year coh ntree NPP dbh growthrate Fnew Fmax Htnew&
& lambdaf lambdas lambdar lambdac x1 x2&
& xnsc_sap_max xnsc_tb_max xnsc_crt_max xnsc_sap xnsc_tb xnsc_crt'
endif
endif
IF (flag_dayout .ge. 2) THEN
unit_wat = getunit()
filename = trim(site_name(help_ip))//'_water.res'//trim(anh)
OPEN (unit_wat, file=trim(dirout)//filename, status = 'UNKNOWN')
WRITE (unit_wat, '(A)') ' Year Iday Temp Prec Interc Int_st Int_s I_st_s Snow Snow_sm PET TRA_DEM&
& PEV AEV_s AEV_i Percol WAtot WEtot WUtot WUtot_e&
& WUtot_r Tratree Trasveg EVA_dem GP_can AET cep_can cep_sv'
unit_soicnd = getunit()
filename = trim(site_name(help_ip))//'_Nmin.res'//trim(anh)
OPEN (unit_soicnd, file=trim(dirout)//filename, status = 'UNKNOWN')
WRITE (unit_soicnd, '(A)') ' Year Iday N_min_1 N_min_2 N_min_3 N_min_4 N_min_5 N_min_6 ... '
unit_soicna = getunit()
filename = trim(site_name(help_ip))//'_remin.res'//trim(anh)
OPEN (unit_soicna, file=trim(dirout)// filename, status = 'UNKNOWN')
WRITE (unit_soicna, '(A)') ' Year Iday remin_1 remin_2 remin_3 remin_4 remin_5 remin_6'
unit_soicnr = getunit()
filename = trim(site_name(help_ip))//'_rmin.res'//trim(anh)
OPEN (unit_soicnr, file=trim(dirout)// filename, status = 'UNKNOWN')
WRITE (unit_soicnr, '(A)') ' Year Iday rmin_t rmin_w rmin_phv'
ENDIF
END SUBROUTINE old_out
!**************************************************************
SUBROUTINE OUT_ASS(ident,PAR,NPP,totFPAR,LUE,netass,grossass,ndaysps)
USE data_simul
USE data_out
IMPLICIT NONE
REAL :: temp, dayL, PAR, netAss, grossass, maintResp, NPP, totFPAR, sapresp, coarseresp, frtresp, assi, resp, LUE, ndaysps
integer :: ident
WRITE(unit_prod, '(3I5,6E12.4,F6.1)') time_cur,iday,ident, PAR,totFPAR,LUE,NPP,netAss,grossass, ndaysps
END SUBROUTINE OUT_ASS
!**************************************************************
SUBROUTINE OUT_ALL( ident, ntree, NPP, DBH, grate, Fnew,Fmax_old,Htnew, lf,ls,lr,lc,x1,x2,xnsc_sap_max, xnsc_tb_max, xnsc_crt_max, xnsc_sap, xnsc_tb, xnsc_crt)
!*** Declaration part ***!
USE data_out
USE data_simul
USE data_stand
IMPLICIT NONE
INTEGER :: ident
REAL :: ntree, NPP, DBH, lf, ls, lr, lc, x1, x2, grate,Fnew,Fmax_old,Htnew,xnsc_sap_max, xnsc_tb_max, xnsc_crt_max, xnsc_sap, xnsc_tb, xnsc_crt
!*** Calculation part ***!
WRITE( unit_allo, '(2I5,F8.0,18F11.4)' ) time_cur, ident, ntree, NPP, DBH,grate,Fnew,Fmax_old,Htnew, lf,ls,lr,lc,x1,x2,xnsc_sap_max, xnsc_tb_max, xnsc_crt_max, xnsc_sap, xnsc_tb, xnsc_crt
END SUBROUTINE out_all
!**************************************************************
SUBROUTINE outtest
use data_out
use data_simul
implicit none
integer hflag, j, i
logical testflag
character a
call outtest_year
call outtest_day
call outtest_coh
call outtest_end
END subroutine outtest
!**************************************************************
SUBROUTINE outtest_year
use data_out
use data_simul
implicit none
integer i, j
logical testflag
character a
IF (time_out > 0 ) then
if (nyvar .eq. 1) then
do i = 1,outy_n
SELECT CASE (outy(i)%kind_name)
CASE ('litter')
outy(i)%out_flag = 2
CASE ('soil')
outy(i)%out_flag = 2
CASE DEFAULT
outy(i)%out_flag = 1
end select
enddo
else
outy%out_flag = 0
do j = 1,nyvar-1
testflag = .TRUE.
do i = 1,outy_n
if (trim(outy_file(j)) .eq. trim(outy(i)%kind_name)) then
SELECT CASE (outy(i)%kind_name)
CASE ('litter')
outy(i)%out_flag = 2
CASE ('soil')
outy(i)%out_flag = 2
CASE DEFAULT
outy(i)%out_flag = 1
end select
testflag = .FALSE.
exit
endif
enddo
if (testflag .and. trim(outy_file(j)) .ne. 'end') then
print *
print *,' >>>FORESEE message: Invalid output file name: '//trim(outy_file(j))
print *
endif
enddo
endif ! nyvar
IF (year/time_out > 500) then
print *,' '
write(*,*)' Warning: Your choice of yearly output steps will create'
write(*,'(I8,A)') year/time_out, ' data records per file!'
write(*,'(A)',advance='no')' Do you really want to use this value (y/n)? '
read *,a
IF (a .eq. 'n' .or. a .eq. 'N') then
write(*,'(A)',advance='no')' New value of time distance for yearly output: '
read *, time_out
ENDIF
ENDIF
ELSE
do i = 1,outy_n
outy(i)%out_flag = 0
enddo
ENDIF ! time_out > 0
END SUBROUTINE outtest_year
!**************************************************************
SUBROUTINE outtest_day
use data_out
use data_simul
implicit none
integer i, j
logical testflag
character a
! daily output
IF (flag_dayout > 0 ) then
if (ndvar .eq. 1) then
do i = 1,outd_n
outd(i)%out_flag = 1
enddo
else
outd%out_flag = 0
do j = 1,ndvar-1
testflag = .TRUE.
do i = 1,outd_n
if (trim(outd_file(j)) .eq. trim(outd(i)%kind_name)) then
outd(i)%out_flag = 1
testflag = .FALSE.
exit
endif
enddo
if (testflag .and. trim(outd_file(j)) .ne. 'end') then
print *
print *,' >>>FORESEE message: Invalid output file name: '//trim(outd_file(j))
print *
endif
enddo
endif ! ndvar
else
do i = 1,outd_n
outd(i)%out_flag = 0
enddo
endif
END SUBROUTINE outtest_day
!**************************************************************
SUBROUTINE outtest_coh
use data_out
use data_simul
implicit none
integer i, j
logical testflag
! cohort output
SELECT CASE (flag_cohout)
CASE (0)
! flags of all daily cohort files
do i = 1,outcd_n
outcd(i)%out_flag = 0
enddo
! flags of all yearly cohort files
do i = 1,outcy_n
outcy(i)%out_flag = 0
enddo
flag_cohoutd = 0
flag_cohouty = 0
CASE (1,2)
if (ncvar .eq. 1) then
! yearly cohort output
if (time_out .gt. 0) then
do i = 1,outcy_n
select case (outcy(i)%kind_name)
case ('dtr')
outcy(i)%out_flag = 2
case ('trman')
outcy(i)%out_flag = 2
case default
outcy(i)%out_flag = 1
end select
enddo
flag_cohouty = 1
else
outcy%out_flag = 0
flag_cohouty = 0
endif
! daily cohort output
if (flag_dayout .gt. 0) then
do i = 1,outcd_n
select case (outcd(i)%kind_name)
case ('dips')
outcd(i)%out_flag = 2
case ('gsdps')
outcd(i)%out_flag = 2
case default
outcd(i)%out_flag = 1
end select
enddo
else
outcd%out_flag = 0
endif
else
outcy%out_flag = 0
outcd%out_flag = 0
flag_cohoutd = 0
flag_cohouty = 0
do j = 1,ncvar-1
testflag = .TRUE.
do i = 1,outcy_n
if (trim(outc_file(j)) .eq. trim(outcy(i)%kind_name)) then
select case (outcy(i)%kind_name)
case ('dtr')
outcy(i)%out_flag = 2
case ('trman')
outcy(i)%out_flag = 2
case default
outcy(i)%out_flag = 1
end select
testflag = .FALSE.
flag_cohouty = 1
exit
endif
enddo
if (testflag .and. flag_dayout .gt. 0) then
do i = 1,outcd_n
if (trim(outc_file(j)) .eq. trim(outcd(i)%kind_name)) then
select case (outcd(i)%kind_name)
case ('dips')
outcd(i)%out_flag = 2
case ('gsdps')
outcd(i)%out_flag = 2
case default
outcd(i)%out_flag = 1
end select
testflag = .FALSE.
flag_cohouty = 1
exit
endif
enddo
endif
if (testflag .and. trim(outd_file(j)) .ne. 'end') then
print *
print *,' >>>FORESEE message: Invalid output file name: '//trim(outd_file(j))
print *
endif
enddo
endif ! ncvar
END SELECT
if (flag_cohout .eq. 2) then
out_flag_light = 1
else
out_flag_light = 0
endif
END SUBROUTINE outtest_coh
!**************************************************************
SUBROUTINE outtest_end
use data_out
use data_simul
implicit none
integer i, j
if (flag_wpm == 1 .or. flag_wpm == 21 .or. flag_wpm == 11.or.flag_wpm== 5.or. flag_wpm == 4 .or. flag_wpm == 6) then
do i = 1,oute_n
select case (oute(i)%kind_name)
case ('wpm')
oute(i)%out_flag = 1
case ('wpm_inter')
oute(i)%out_flag = 1
end select
enddo
else if (flag_wpm == 2) then
do i = 1,oute_n
select case (oute(i)%kind_name)
case ('sea')
oute(i)%out_flag = 1
case ('sea_npv')
oute(i)%out_flag = 1
case ('sea_ms')
oute(i)%out_flag = 1
case ('sea_st')
oute(i)%out_flag = 1
end select
enddo
else if(flag_wpm.eq.3) then
do i = 1,oute_n
select case (oute(i)%kind_name)
case ('sea')
oute(i)%out_flag = 1
case ('sea_npv')
oute(i)%out_flag = 1
case ('sea_ms')
oute(i)%out_flag = 1
case ('sea_st')
oute(i)%out_flag = 1
case ('wpm')
oute(i)%out_flag = 1
case ('wpm_inter')
oute(i)%out_flag = 1
end select
enddo
else
do i = 1,oute_n
oute(i)%out_flag = 0
enddo
endif
END SUBROUTINE outtest_end
source_code/version_2.3_windows/out_var_stat.f 0 → 100644
View file @ 82df1085
!*****************************************************************!
!* *!
!* 4C (FORESEE) Simulation Model *!
!* *!
!* *!
!* Subroutines for: *!
!* output of variables with statistics for climate scenarios *!
!* *!
!* contains *!
!* OUT_VAR_STAT compressing of output variables *!
!* CALC_STAT calculation of statistics *!
!* 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 out_var_stat(kind, act_real)
! compressing of output variables with statistics (multi run 9, 10)
use data_out
use data_par
use data_simul
use data_site
IMPLICIT NONE
integer kind ! 1 - aggregation per realisation (average)
! 2 - aggregation per climate scenario over all realisations with statistics
! 3 - statistics per month over all years
integer act_real ! number of actual realisation
integer i, j, k, unit_nr, ii
real varerr, help
character(50) :: filename ! complete name of output file
real, dimension(nrreal) :: helparr
real, dimension(year):: helpmon
character(30) :: helpvar
character(20) idtext, datei
character(150) htext
! mit Numerical Recipies
REAL:: adev,ave,var, &
curt=-99. , &
sdev=-99. , &
skew=0.
! Statistische Masszahlen fuer Klimaszen.-Realisierungen
real:: avcl, & ! Mittelwert
mincl, & ! Minimum
maxcl, & ! Maximum
median, & ! Median
stdevcl=-99. , & ! Standardabweichung
varicl, & ! Streuung
varcocl ! Variationskoeffizient
real quant05, quant95 ! 0.05 and 0.95 quantile
real, external :: mean, variance
if (flag_trace) write (unit_trace, '(I4,I10,A,2I5)') iday, time_cur, ' out_var_stat ',kind,act_real
select case (kind)
case (1,2)
if (output_unit_all .le.0) then
filename = trim(site_name1)//'_var_all.out'
output_unit_all = getunit()
open(output_unit_all,file=trim(dirout)//filename,status='replace')
write (output_unit_all, '(A)') '# Output of mean annual values for each site and each realization of climate scenarios'
write (output_unit_all, '(A, I6)') '# Simulation period (years): ', year
write (output_unit_all, '(A, I6)') '# Number of climate scenarios: ', nrclim
write (output_unit_all, '(A, I6)') '# Number of realizations: ', nrreal
write (output_unit_all, *)
write (output_unit_all, '(A)', advance='no') '# Type_clim.scen. Site_ip Real.'
do i = 1, nvar-1
select case (trim(outvar(i)))
case ('AET_year','cwb_year','GPP_year','NEP_year','NPP_year','perc_year','PET_year','temp_year','TER_year','prec_year','resps_year')
continue
case ('AET_mon','cwb_mon','GPP_mon','NEP_mon','NPP_mon','perc_mon','PET_mon','temp_mon','TER_mon','prec_mon','resps_mon')
continue
case ('AET_week','cwb_week','GPP_week','NEP_week','NPP_week','perc_week','PET_week','temp_week','TER_week','prec_week','resps_week')
continue
case default
write (output_unit_all, '(A12)', advance='no') trim(outvar(i))
end select
enddo
write (output_unit_all, '(A)') ''
endif
case (3)
do i = 1, nvar-1
if (output_unit_mon(i) .le.0) then ! for monthly values
filename = trim(site_name1)//'_'//trim(outvar(i))//'_stat.res'
output_unit_mon(i) = getunit()
open(output_unit_mon(i),file=trim(dirout)//filename,status='replace')
write (output_unit_mon(i), '(A)') '# Output of mean monthly values for '//trim(outvar(i))
write (output_unit_mon(i), '(A, I6)') '# Simulation period (years): ', year
varerr = 0
endif
enddo
end select
select case (kind)
case (1) ! after each realisation
write (output_unit_all, '(2X, A15, 1X, A10, I5,2X)', advance = 'no') trim(typeclim(iclim)), sitenum(ip), act_real
do i = 1, nvar-1
select case (trim(outvar(i)))
case ('AET_year','cwb_year','GPP_year','NEP_year','NPP_year','perc_year','PET_year','temp_year','TER_year','prec_year','resps_year')
ii = output_var(i,1,0)
do j = 1, year
climszenyear(ii,ip,iclim,act_real,j) = output_var(i,1,j)
enddo
case ('AET_mon','cwb_mon','GPP_mon','NEP_mon','NPP_mon','perc_mon','PET_mon','temp_mon','TER_mon','prec_mon','resps_mon')
ii = output_var(i,1,0)
do k = 1,12
help = 0.
do j = 1, year
help = help + output_varm(ii,1,j,k)
enddo
help = help / year
climszenmon(ii,ip,iclim,act_real,k) = help
enddo
case ('AET_week','cwb_week','GPP_week','NEP_week','NPP_week','perc_week','PET_week','temp_week','TER_week','prec_week','resps_week')
ii = output_var(i,1,0)
do k = 1,52
help = 0.
do j = 1, year
help = help + output_varw(ii,1,j,k)
enddo
help = help / year
climszenweek(ii,ip,iclim,act_real,k) = help
enddo
case default
help = 0.
do j = 1, year
help = help + output_var(i,1,j)
enddo ! j
help = help / year
climszenres(i,ip,iclim,act_real) = help
write (output_unit_all, '(E12.4)', advance = 'no') help
end select ! outvar
end do ! i
write (output_unit_all, '(A)') ''
case (2) ! am Ende der Simulation
do i = 1, nvar-1
if (output_unit(i) .lt. 0) then
helpvar = outvar(i)
call out_var_select(helpvar, varerr, unit_nr)
if (varerr .ne. 0.) then
output_unit(i) = unit_nr
write (unit_nr, '(A, I6)') '# Simulation period (years): ', year
write (unit_nr, '(A, I6)') '# Number of climate scenarios: ', nrclim
write (unit_nr, '(A, I6)') '# Number of realizations: ', nrreal
select case (trim(outvar(i)))
case ('AET_year','cwb_year','GPP_year','NEP_year','NPP_year','perc_year','PET_year','temp_year','TER_year','prec_year','resps_year')
write (unit_nr, '(A)') '# Statistics over all realizations for each year '
write (unit_nr, '(A)') '# Type_clim.scen. Site_ip Year Mean Minimum Maximum Variance Var.Coeff. Std.Dev. Skewness Excess 0.05-Quant. 0.95-Quant. Median'
case ('AET_mon','cwb_mon','GPP_mon','NEP_mon','NPP_mon','perc_mon','PET_mon','temp_mon','TER_mon','prec_mon','resps_mon')
write (unit_nr, '(A)') '# Statistics over all realizations and all years for each month '
write (unit_nr, '(A)') '# Type_clim.scen. Site_ip Month Mean Minimum Maximum Variance Var.Coeff. Std.Dev. Skewness Excess 0.05-Quant. 0.95-Quant. Median'
case ('AET_week','cwb_week','GPP_week','NEP_week','NPP_week','perc_week','PET_week','temp_week','TER_week','prec_week','resps_week')
write (unit_nr, '(A)') '# Statistics over all realizations and all years for each week '
write (unit_nr, '(A)') '# Type_clim.scen. Site_ip Week Mean Minimum Maximum Variance Var.Coeff. Std.Dev. Skewness Excess 0.05-Quant. 0.95-Quant. Median'
case default
write (unit_nr, '(A)') '# Statistics over all realizations (mean of all years) '
write (unit_nr, '(A)') '# Type_clim.scen. Site_ip Mean Minimum Maximum Variance Var.Coeff. Std.Dev. Skewness Excess 0.05-Quant. 0.95-Quant. Median'
end select
else
write (*,*)
write (*,*) '*** 4C-error - output of variables (out_var_file): ', trim(outvar(i)), ' not found'
write (*,*)
write (unit_err,*)
write (unit_err,*) '*** 4C-error - no such output variable (out_var_file): ', trim(outvar(i))
endif
endif
if (output_unit(i) .ge. 0) then
select case (trim(outvar(i)))
case ('AET_year','cwb_year','GPP_year','NEP_year','NPP_year','perc_year','PET_year','temp_year','TER_year','prec_year','resps_year')
ii = output_var(i,1,0)
do k = 1, year
write (output_unit(i), '(2X, A15, 1X, A10, I7)', advance = 'no') trim(typeclim(iclim)), sitenum(ip), k
do j = 1, nrreal
helparr(j) = climszenyear(ii,ip,iclim,j,k)
enddo
call calc_stat(nrreal, helparr, output_unit(i))
enddo
case ('AET_mon','cwb_mon','GPP_mon','NEP_mon','NPP_mon','perc_mon','PET_mon','temp_mon','TER_mon','prec_mon','resps_mon')
ii = output_var(i,1,0)
do k = 1, 12
write (output_unit(i), '(2X, A15, 1X, A10, I7)', advance = 'no') trim(typeclim(iclim)), sitenum(ip), k
do j = 1, nrreal
helparr(j) = climszenmon(ii,ip,iclim,j,k)
enddo
call calc_stat(nrreal, helparr, output_unit(i))
enddo
case ('AET_week','cwb_week','GPP_week','NEP_week','NPP_week','perc_week','PET_week','temp_week','TER_week','prec_week','resps_week')
ii = output_var(i,1,0)
do k = 1, 52
write (output_unit(i), '(2X, A15, 1X, A10, I7)', advance = 'no') trim(typeclim(iclim)), sitenum(ip), k
do j = 1, nrreal
helparr(j) = climszenweek(ii,ip,iclim,j,k)
enddo
call calc_stat(nrreal, helparr, output_unit(i))
enddo
case default
write (output_unit(i), '(2X, A15, 1X, A10)', advance = 'no') trim(typeclim(iclim)), sitenum(ip)
do j = 1, nrreal
helparr(j) = climszenres(i,ip,iclim,j)
enddo
call calc_stat(nrreal, helparr, output_unit(i))
end select
endif
enddo
case (3) ! Monthly values
do i = 1, nvar-1
helpvar = outvar(i)
select case (trim(outvar(i)))
case ('AET_year','cwb_year','GPP_year','NEP_year','NPP_year','perc_year','PET_year','temp_year','TER_year','prec_year','resps_year')
ii = output_var(i,1,0)
do j = 1, year
climszenyear(ii,ip,iclim,act_real,j) = output_var(i,1,j)
enddo
case ('GPP_mon','NPP_mon','TER_mon')
ii = output_var(i,1,0)
if (ip .eq.1) then
write (output_unit_mon(i), '(A)') '# Statistics over all years for each month '
write (output_unit_mon(i), '(A)') '# g C/m '
write (output_unit_mon(i), '(A)') '# ipnr site_id Month Mean Minimum Maximum Variance Var.Coeff. Std.Dev. Skewness Excess 0.05-Quant. 0.95-Quant. Median'
endif
do k = 1,12
help = 0.
do j = 1, year
helpmon(j) = output_varm(ii,1,j,k) * 100. ! tC/ha --> gC/m
enddo
htext = adjustr(site_name(ip))
idtext = adjustl(htext (131:150)) ! only write last 20 signs
write (output_unit_mon(i), '(I5,2X, A20,I5)', advance = 'no') ip, idtext, k
call calc_stat(year, helpmon, output_unit_mon(i))
enddo
case ('NEE_mon')
ii = output_var(i,1,0)
if (ip .eq.1) then
write (output_unit_mon(i), '(A)') '# Statistics over all years for each month '
write (output_unit_mon(i), '(A)') '# g C/m '
write (output_unit_mon(i), '(A)') '# ipnr site_id Month Mean Minimum Maximum Variance Var.Coeff. Std.Dev. Skewness Excess 0.05-Quant. 0.95-Quant. Median'
endif
do k = 1,12
help = 0.
do j = 1, year
helpmon(j) = output_varm(ii,1,j,k) ! gC/m
enddo
htext = adjustr(site_name(ip))
idtext = adjustl(htext (131:150)) ! only write last 20 signs
write (output_unit_mon(i), '(I5,2X, A20,I5)', advance = 'no') ip, idtext, k
call calc_stat(year, helpmon, output_unit_mon(i))
enddo
case ('resps_mon')
ii = output_var(i,1,0)
if (ip .eq.1) then
write (output_unit_mon(i), '(A)') '# Statistics over all years for each month '
write (output_unit_mon(i), '(A)') '# g C/m '
write (output_unit_mon(i), '(A)') '# ipnr site_id Month Mean Minimum Maximum Variance Var.Coeff. Std.Dev. Skewness Excess 0.05-Quant. 0.95-Quant. Median'
endif
do k = 1,12
help = 0.
do j = 1, year
helpmon(j) = output_varm(ii,1,j,k) * kgha_in_gm2 ! kgC/ha --> gC/m
enddo
htext = adjustr(site_name(ip))
idtext = adjustl(htext (131:150)) ! only write last 20 signs
write (output_unit_mon(i), '(I5,2X, A20,I5)', advance = 'no') ip, idtext, k
call calc_stat(year, helpmon, output_unit_mon(i))
enddo
case ('AET_mon','cwb_mon','perc_mon','PET_mon','temp_mon','prec_mon')
ii = output_var(i,1,0)
if (ip .eq.1) then
write (output_unit_mon(i), '(A)') '# Statistics over all years for each month '
write (output_unit_mon(i), '(A)') '# '
write (output_unit_mon(i), '(A)') '# ipnr site_id Month Mean Minimum Maximum Variance Var.Coeff. Std.Dev. Skewness Excess 0.05-Quant. 0.95-Quant. Median'
endif
do k = 1,12
help = 0.
do j = 1, year
helpmon(j) = output_varm(ii,1,j,k)
enddo
htext = adjustr(site_name(ip))
idtext = adjustl(htext (131:150)) ! only write last 20 signs
write (output_unit_mon(i), '(I5,2X, A20,I5)', advance = 'no') ip, idtext, k
call calc_stat(year, helpmon, output_unit_mon(i))
enddo
case ('AET_week','cwb_week','GPP_week','NEP_week','NPP_week','perc_week','PET_week','temp_week','TER_week','prec_week','resps_week')
ii = output_var(i,1,0)
do k = 1,52
help = 0.
do j = 1, year
help = help + output_varw(ii,1,j,k)
enddo
help = help / year
climszenweek(ii,ip,iclim,act_real,k) = help
enddo
case default
help = 0.
do j = 1, year
help = help + output_var(i,1,j)
enddo ! j
help = help / year
climszenres(i,ip,iclim,act_real) = help
write (output_unit_all, '(E12.4)', advance = 'no') help
end select ! outvar
end do ! i
write (output_unit_all, '(A)') ''
end select
END SUBROUTINE out_var_stat
!**************************************************************
SUBROUTINE calc_stat(nreal, helparr, outunit)
! calculate statistics
use data_out
use data_simul
IMPLICIT NONE
integer :: outunit ! output unit
integer :: nreal ! number of elements
real, dimension(nreal) :: helparr ! input-array with dimension nreal
! with numerical recipies
REAL:: adev,ave,var, &
curt=-99. , &
sdev=-99. , &
skew=0.
! statistical measurment figures for climate scenario realisation
real:: avcl, & ! mean
mincl, & ! minimum
maxcl, & ! maximum
median, & ! median
stdevcl=-99. , & ! standard deviation
varicl, & ! dispersion
varcocl ! coefficient of variance
real quant05, quant95 ! 0.05 and 0.95 quantile
real, external :: mean, variance
avcl = mean(nreal, helparr)
mincl = minval(helparr)
maxcl = maxval(helparr)
varicl = variance(nreal, avcl, helparr)
if (varicl .ge. 0.) stdevcl = sqrt(varicl)
if (avcl .ne. 0.) then
varcocl = stdevcl / avcl
else
varcocl = -9999.0
endif
call quantile(nreal, helparr, quant05, quant95, median)
! with numerical recipies
if (nreal .gt. 1) call moment(helparr, nreal, ave,adev,sdev,var,skew,curt)
write (outunit, '(11E12.4)') avcl, mincl, maxcl, varicl, varcocl, sdev, skew, curt, quant05, quant95, median
END SUBROUTINE calc_stat
source_code/version_2.3_windows/output.f 0 → 100644
View file @ 82df1085
!*****************************************************************!
!* *!
!* 4C (FORESEE) Simulation Model *!
!* *!
!* *!
!* Subroutines for: *!
!* - output routines - initialization and writing in files *!
!* *!
!* contains *!
!* PREP_OUT initialization of output files *!
!* PREP_OUTYEAR prepare yearly output files *!
!* PREP_COH prepare output of cohorts *!
!* PREP_OUT_COMP prepare compressed output *!
!* OUTYEAR yearly output in files *!
!* OUTDAY daily output in files *!
!* COH_OUT_D daily cohort output *!
!* COH_OUT_Y yearly cohort output *!
!* OUT_COMP compressed output (multi run) *!
!* OUT_WPM ouput for WPM after the simulation is ended *!
!* OUT_SCEN climate scenario control file (multi run) *!
!* ERROR_MESS print error message in error file "error.log"*!
!* STOP_MESS print message on program abortion *!
!* OPEN_FILE open special output file *!
!* WR_HEADER_FILE write header of special output file *!
!* OUTVEG output of species values (files veg_species) *!
!* OUTSTORE store of output variables (multi run 4) *!
!* OUT_VAR_FILE store of output variables (multi run 4) *!
!* *!
!* 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 prep_out
! Open output files
USE data_simul
USE data_species
USE data_stand
USE data_out
IMPLICIT NONE
CHARACTER(50) ::filename
INTEGER i,help_ip
INTEGER unit_n ! output unit
IF(site_nr==1) THEN
help_ip=site_nr
ELSE
help_ip=ip
END IF
! 1. yearly output
! open all selected files
if (time_out .gt. 0) then
call prep_outyear (help_ip)
endif
call old_out !behelfs, privatoutput
! 2. daily output
! open all selected files
if (flag_dayout .ge. 1) then
do i = 1,outd_n
if (outd(i)%out_flag .ne. 0) then
select CASE (outd(i)%kind_name)
CASE ('Cbcd')
if (flag_bc .gt. 0) then
call open_file (outd(i), help_ip)
call wr_header_file (outd(i))
endif
CASE default
call open_file (outd(i), help_ip)
call wr_header_file (outd(i))
end select
endif
END DO !i
END IF
! 3.Cohort output
if(flag_cohout==1.or.flag_cohout==2) call prep_coh
! 4. end output
! open all selected files
if (flag_wpm .gt. 0) then
do i = 1,oute_n
if (oute(i)%out_flag .ne. 0) then
select CASE (oute(i)%kind_name)
CASE default
call open_file (oute(i), help_ip)
call wr_header_file (oute(i))
end select
endif
END DO !i
END IF
! 5.summation output
if(flag_sum>0)then
unit_sum=getunit()
filename = trim(site_name(help_ip))//'_sum.out'//trim(anh)
open(unit_sum,file=trim(dirout)//filename,status='replace')
WRITE(unit_sum,'(A)') '# Photsum = Sum of gross photosynthesis gC/m2'
WRITE(unit_sum,'(A)') '# NPPpotsum = Sum of potential NPP gC/m2'
WRITE(unit_sum,'(A)') '# NPPsum = Sum of NPP gC/m2'
WRITE(unit_sum,'(A)') '# respsoil = Sum of soil respiration gC/m2'
WRITE(unit_sum,'(A)') '# lightsum = Sum of global radiation MJ/m2'
WRITE(unit_sum,'(A)') '# NEE = Sum of respsoil - daily NPP gC/m2'
WRITE(unit_sum,'(A)') '# ALS = Sum of absorbed global radiation MJ/m2'
WRITE(unit_sum,'(A)') '# Psum = Sum of precipitation (mm)'
WRITE(unit_sum,'(A)') '# Tmean = mean temperature (C)'
WRITE(unit_sum,'(A)') '# GPP = GPP gC/m2'
WRITE(unit_sum,'(A)') '# TER = Total ecosystem respiration gC/m2'
WRITE(unit_sum,'(A)') '# respaut = Autotrophe respiration gC/m2'
select CASE(flag_sum)
CASE(1)
WRITE(unit_sum,'(A11)') '# Daily sum'
WRITE(unit_sum,'(2A5,13A10)') '# Day','Year','Photsum','NPPpotsum','NPPsum', &
'respsoil','lightsum','NEE', 'ALS', 'Psum',&
'Tmean','cor_res', 'GPP','TER','respaut'
CASE(2)
WRITE(unit_sum,'(A50)') '# AET = Sum of actual evapotranspiration (mm)'
WRITE(unit_sum,'(A50)') '# PET = Sum of potential evapotranspiration (mm)'
WRITE(unit_sum,'(A50)') '# Percol. = Sum of percolation water from last layer (mm)'
WRITE(unit_sum,'(A12)') '# Weekly sum'
WRITE(unit_sum,'(2A6,17A10)') '# Week','Year','timedec','Photsum','NPPpotsum','NPPsum', &
'respsoil','lightsum','NEE','ALS', 'Psum','Tmean', &
'cor_res', 'AET', 'PET', 'Percol.', 'GPP','TER','respaut'
CASE(3)
WRITE(unit_sum,'(A50)') '# AET = Sum of actual evapotranspiration (mm)'
WRITE(unit_sum,'(A50)') '# PET = Sum of potential evapotranspiration (mm)'
WRITE(unit_sum,'(A50)') '# Ind_cout = monthly climate index according Coutange'
WRITE(unit_sum,'(A50)') '# Ind_wiss = monthly climate index according v. Wissmann'
WRITE(unit_sum,'(A50)') '# Ind_arid = monthly aridity index according UNEP'
WRITE(unit_sum,'(A50)') '# CWB = monthly climate water balance (P-PET)'
WRITE(unit_sum,'(A50)') '# Percol. = Sum of percolation water from last layer (mm)'
WRITE(unit_sum,'(A13)') '# Monthly sum'
WRITE(unit_sum,'(A7,A5,20A10)') '# Month','Year','timedec','Photsum','NPPpotsum','NPPsum', &
'respsoil','lightsum','NEE','ALS', 'Psum', 'Tmean', 'AET', 'PET', 'Ind_cout', &
'Ind_wiss', 'Ind_arid', 'CWB', 'Percol.', 'GPP','TER','respaut'
CASE(4)
WRITE(unit_sum,'(12A)') '# Yearly sum'
WRITE(unit_sum,'(A6,A10,11A11)') '# Year','Photsum','NPPpotsum','NPPsum', &
'respsoil','lightsum','NEE','ALS', 'Psum', 'Tmean', 'GPP','TER','respaut'
end select
END IF
END subroutine prep_out
!**************************************************************
SUBROUTINE prep_outyear (help_ip)
! Open yearly output files
USE data_simul
USE data_stand
USE data_out
USE data_species
IMPLICIT NONE
CHARACTER(10) :: helpunit
CHARACTER(2) :: helpvar
INTEGER i,j,help_ip,k
INTEGER unit_n ! output unit
do i = 1,outy_n
if (outy(i)%out_flag .ge. 1) then
select CASE (outy(i)%kind_name)
CASE ('AET_mon')
if (ip .eq. 1) then
nvar = nvar + 1
outvar(nvar) = "AET_mon"
endif
call open_file (outy(i), help_ip)
call wr_header_file (outy(i))
CASE ('Cbc', 'Nbc')
if (flag_bc .gt. 0) then
call open_file (outy(i), help_ip)
call wr_header_file (outy(i))
endif
CASE ('classd', 'classt') !open classification file
call open_file (outy(i), help_ip)
unit_n = outy(i)%unit_nr
WRITE(unit_n ,'(A)') trim(outy(i)%s_line)
WRITE(unit_n ,'(A)',advance='no') trim(outy(i)%header)
do k=1,nspecies
do j=1,num_class
WRITE(unit_n,'(A8,I2)',advance='no')'Class',j
END DO !j
end do !k
WRITE(unit_n,*) ' '
CASE ('classage') !open classification file
call open_file (outy(i), help_ip)
unit_n = outy(i)%unit_nr
WRITE(unit_n ,'(A)') trim(outy(i)%s_line)
WRITE(unit_n ,'(A)',advance='no') trim(outy(i)%header)
do k=1,nspecies
do j=1,num_class
WRITE(unit_n,'(A8,I2)',advance='no')'Class',j
END DO !j
end do !k
WRITE(unit_n,*) ' '
CASE ('classmvol') !open classification file
call open_file (outy(i), help_ip)
unit_n = outy(i)%unit_nr
WRITE(unit_n ,'(A)') trim(outy(i)%s_line)
WRITE(unit_n ,'(A)',advance='no') trim(outy(i)%header)
do k=1,nspecies
do j=1,num_class
WRITE(unit_n,'(A8,I2)',advance='no')'Class',j
END DO !j
end do !k
WRITE(unit_n,*) ' '
CASE ('classd_h') !open classification file
call open_file (outy(i), help_ip)
unit_n = outy(i)%unit_nr
WRITE(unit_n ,'(A)') trim(outy(i)%s_line)
WRITE(unit_n ,'(A)',advance='no') trim(outy(i)%header)
do k=1,nspecies
do j=1,num_class
WRITE(unit_n,'(A8,I2)',advance='no')'Class',j
END DO !j
end do
WRITE(unit_n,*) ' '
CASE ('classdm') !open classification file
call open_file (outy(i), help_ip)
unit_n = outy(i)%unit_nr
WRITE(unit_n ,'(A)') trim(outy(i)%s_line)
WRITE(unit_n ,'(A)',advance='no') trim(outy(i)%header)
do k=1,nspecies
do j=1,num_class
WRITE(unit_n,'(A8,I2)',advance='no')'Class',j
END DO !j
end do
WRITE(unit_n,*) ' '
CASE ('classdm_h') ! open classification file
call open_file (outy(i), help_ip)
unit_n = outy(i)%unit_nr
WRITE(unit_n ,'(A)') trim(outy(i)%s_line)
WRITE(unit_n ,'(A)',advance='no') trim(outy(i)%header)
do k=1,nspecies
do j=1,num_class
WRITE(unit_n,'(A8,I2)',advance='no')'Class',j
END DO !j
end do
WRITE(unit_n,*) ' '
CASE ('classh') !open classification file
call open_file (outy(i), help_ip)
unit_n = outy(i)%unit_nr
WRITE(unit_n ,'(A)') trim(outy(i)%s_line)
WRITE(unit_n ,'(A)',advance='no') trim(outy(i)%header)
do j=1,num_class
WRITE(unit_n,'(A8,I2)',advance='no')'Class',j
END DO !j
WRITE(unit_n,*) ' '
CASE ('GPP_mon')
if (ip .eq. 1) then
nvar = nvar + 1
outvar(nvar) = "GPP_mon"
endif
call open_file (outy(i), help_ip)
call wr_header_file (outy(i))
CASE ('NEE_mon')
if (ip .eq. 1) then
nvar = nvar + 1
outvar(nvar) = "NEE_mon"
endif
call open_file (outy(i), help_ip)
call wr_header_file (outy(i))
CASE ('NPP_mon')
if (ip .eq. 1) then
nvar = nvar + 1
outvar(nvar) = "NPP_mon"
endif
call open_file (outy(i), help_ip)
call wr_header_file (outy(i))
CASE ('spec') !open species file
call open_file (outy(i), help_ip)
unit_n = outy(i)%unit_nr
! header
WRITE(unit_n ,'(A)',advance='no') trim(outy(i)%header)
do j=1,nspecies
zeig=>pt%first
do while (associated(zeig))
if(zeig%coh%species.eq.j)then
WRITE(helpunit,'(I2)') zeig%coh%species
read(helpunit,*) helpvar
WRITE(unit_n,'(A10)',advance='no') 'Diam_S'//helpvar
WRITE(unit_n,'(A10)',advance='no') 'Heig_S'//helpvar
WRITE(unit_n,'(2A10)',advance='no') 'Tree_S'//helpvar,'Biom_S'//helpvar
exit
END IF
zeig=>zeig%next
END DO
END DO
WRITE(unit_n,*) ' '
CASE ('TER_mon')
if (ip .eq. 1) then
nvar = nvar + 1
outvar(nvar) = "TER_mon"
endif
call open_file (outy(i), help_ip)
call wr_header_file (outy(i))
CASE default
call open_file (outy(i), help_ip)
call wr_header_file (outy(i))
end select
END IF
END DO !i
if (nvar .gt. 0) then
if (.not. allocated(output_unit_mon)) then
allocate(output_unit_mon(nvar))
if (.not. allocated(output_var)) allocate(output_var(nvar,1,0:0))
if (.not. allocated(output_varm)) allocate(output_varm(nvar,site_nr,year,12))
do i=1,nvar
output_var(i,1,0) = i
enddo
nvar = nvar + 1
endif
endif
END subroutine prep_outyear
!**************************************************************
SUBROUTINE prep_coh
!prepare cohort output
USE data_simul
USE data_stand
USE data_out
IMPLICIT NONE
INTEGER help_ip
INTEGER i
INTEGER unit_n ! output unit
IF(site_nr==1) THEN
help_ip=site_nr
ELSE
help_ip=ip
END IF
! output of all selected daily cohort files
do i = 1,outcd_n
if (outcd(i)%out_flag .ne. 0) then
unit_n = outcd(i)%unit_nr
select CASE (outcd(i)%kind_name)
CASE default
call open_file (outcd(i), help_ip)
call wr_header_file (outcd(i))
end select
END IF
END DO !i
!prepare yearly cohort output
! output of all selected yearly files
do i = 1,outcy_n
if (outcy(i)%out_flag .ne. 0) then
unit_n = outcy(i)%unit_nr
select CASE (outcy(i)%kind_name)
CASE default
call open_file (outcy(i), help_ip)
call wr_header_file (outcy(i))
end select
END IF
END DO !i
END subroutine prep_coh
!**************************************************************
SUBROUTINE prep_out_comp
! preparation: compressed output of final results for each run
USE data_simul
USE data_soil
USE data_stand
USE data_out
IMPLICIT NONE
character(70) filename
filename = trim(site_name(1))//'_B'//'.cmp'
unit_comp1 = getunit()
open(unit_comp1, file=trim(dirout)//filename, status='replace')
write (unit_comp1, '(A)') '# Compressed output of start values for each run'
write (unit_comp1, 1000)
write (unit_comp1, 2000)
filename = trim(site_name(1))//'_E'//'.cmp'
unit_comp2 = getunit()
open(unit_comp2, file=trim(dirout)//filename, status='replace')
write (unit_comp2, '(A)') '# Compressed output of final results for each run'
write (unit_comp2, '(A, I5)') '# Simulation time (years)', year
write (unit_comp2, 500)
write (unit_comp2, 1000)
write (unit_comp2, 2000)
500 FORMAT ('# ||-------------------------------------------- final state -------------------------------------------||--- mean annual values ---||--- cumulative quantities ---||------------------- final state ',&
'-------------------||----------------------------------------------------------------------------- mean annual values ---------------------------------------------------------------------------------------------------------------', &
'-------------------------------------------------------------------------------------------------------------------------------|')
1000 FORMAT ('# m2_m2 /ha t DW/ha t DW/ha cm cm t DW/ha t DW/ha t DW/ha t DW/ha t DW/ha t DW/ha t C/ha kg C/ha kg C/ha kg DW/ha kg DW/ha kg DW/ha t C/ha t C/ha t C/ha t C/ha',&
' t C/ha t C/ha kg C/ha kg C/ha kg N/ha kg N/ha kg N/ha kg C/ha kg C/ha mm mm mm mm mm C mm kg N/ha', 189X,' J_cm2 mm kg N/ha')
2000 FORMAT ('# ipnr site_id LAI nTree typ Biomass Biom._sv Meddiam Domhei totfol tottb totsap tothrt totfrt totcrt mean_NPP mean_NEP mean_GPP c_Stem_inc cumVs_ab cumVs_dead C_sum C_d_stm C_tot C_hum_tot',&
' C_tot_40 C_hum_40 C_accu C_litter N_litter N_min Nleach Soil_Res Tot_Resp PET AET percol interc transp temp prec N_depo drIndAl GDD cwb_an fire_inde fire_indb I_arid I_lang I_cout ', &
'I_wiss I_mart I_weck I_reich I_emb CI_gor CI_cur CI_con NTindex I_Nesterov I_Budyko Rad RedN dew/rime Nupt I_frost I_frost_sp Ind_SHC' )
END subroutine prep_out_comp
!**************************************************************
SUBROUTINE outyear (flagout)
!yearly output
USE data_biodiv
USE data_climate
USE data_depo
USE data_evapo
USE data_inter
USE data_out
USE data_par
USE data_simul
USE data_soil
USE data_soil_cn
USE data_species
USE data_stand
USE data_manag
USE data_tsort
USE data_site
USE data_frost
IMPLICIT NONE
integer flagout ! control of output
! 1 - output with outyear,
! 2 - output after management and mortality
integer i,j,k,ihelp
integer unit_n ! output unit
real hconv ! conversion factor from patchsize into ha
! output variables of yearly C-balance in kg C/ha
real y_GPP, & ! yearly gross productioin
y_NPP, & ! yearly net primary productioin
y_NEP, & ! yearly net ecosystem productioin
y_autresp, & ! yearly total resp of all cohorts and species
y_sumbio, & ! total biomass of all cohorts and all species
y_C_d_st, & ! C in stems of dead trees
y_sumvsab, & ! C in total sum of volume of removed stems by management
y_C_tot, & ! total soil C stock (OPM, humus and litter; whithout stems)
y_C_tot_es, & ! total C of ecosystem (soil, dead stems and biomass)
y_resps, & ! yearly soil respiration
y_resptot ! yearly total respiration
! output variables of yearly C-balance in mol C/m2
real ym_GPP, & ! yearly gross productioin
ym_NPP, & ! yearly net primary productioin
ym_NEP, & ! yearly net ecosystem productioin
ym_autresp, & ! yearly total resp of all cohorts and species
ym_sumbio, & ! total biomass of all cohorts and all species
ym_C_d_st, & ! C in stems of dead trees
ym_sumvsab, & ! C in total sum of volume of removed stems by management
ym_C_tot, & ! total soil C stock (OPM, humus and litter; whithout stems)
ym_C_tot_es,& ! total C of ecosystem (soil, dead stems and biomass)
ym_resps, & ! yearly soil respiration
ym_resptot, & ! yearly total respiration
y_lai ! LAI of stand without soil vegetation
! output variables of litter file: share in total biomasses
real y_fol, y_tb, y_crt, y_frt, y_stem, y_totlit, y_C_lit, y_N_lit
! output variables harvested trees
real se_c_ha, & ! sortiment element in C kg/ha
se_m3_ha ! volume of sortiment element in m/ha
real Cbc_ap ! output variable of biochar application
real help, h1, h2, h3, h4, q1, q2, q3, q4
real hdnlf, hdnlf_sp, xhelp, xhelp1
integer hdate_lf, hdate_lftot, hanzdlf
real hsumtlf
y_lai = 0.
if ((flagout .eq. 1) .and. (.not.allocated(sout))) allocate (sout(nspecies))
if (time.eq.0) then
hdnlf = 0.
hdnlf_sp = 0.
hdate_lf = 0.
hdate_lftot = 0.
hanzdlf = 0.
hsumtlf = 0.
else
hdnlf = dnlf(time)
hdnlf_sp = dnlf_sp(time)
hdate_lf = date_lf(time)
hdate_lftot = date_lftot(time)
hanzdlf = anzdlf(time)
hsumtlf = sumtlf(time)
end if
! output of all selected files
do i = 1,outy_n
if (outy(i)%out_flag .eq. flagout) then
unit_n = outy(i)%unit_nr
select CASE (outy(i)%kind_name)
CASE ('AET_mon','aet_mon')
q1 = aet_mon(1) + aet_mon(2) + aet_mon(3)
q2 = aet_mon(4) + aet_mon(5) + aet_mon(6)
q3 = aet_mon(7) + aet_mon(8) + aet_mon(9)
q4 = aet_mon(10) + aet_mon(11) + aet_mon(12)
if (time .gt.1) then
h1 = aet_dec + aet_mon(1) + aet_mon(2)
else
h1 = aet_mon(1) + aet_mon(2)
endif
h2 = aet_mon(3) + aet_mon(4) + aet_mon(5)
h3 = aet_mon(6) + aet_mon(7) + aet_mon(8)
h4 = aet_mon(9) + aet_mon(10) + aet_mon(11)
WRITE(unit_n,'(I6)',advance='no') time_cur
WRITE(unit_n,'(20F10.2)') aet_mon, q1, q2, q3, q4, h1, h2, h3, h4
CASE ('c_bal')
hconv = 10000./kpatchsize
y_NPP = sumNPP * cpart ! kg DW --> kg C
y_NPP = y_NPP * hconv ! kg C/patch --> kg C/ha
y_autresp = autresp * cpart * hconv ! kg DW pro patch --> kg C/ha
y_resps = resps_c * gm2_in_kgha ! g/m2 --> kg/ha
y_resptot = y_resps + y_autresp
y_GPP = y_NPP + y_autresp
y_NEP = y_NPP - y_resps
y_C_d_st = C_opm_stem * gm2_in_kgha
y_sumvsab = sumvsab * cpart ! kg DW /ha --> kg C
y_sumbio = (sumbio+sumbio_out) * cpart ! kg DW /ha --> kg C/ha
y_C_tot = C_tot * gm2_in_kgha * 0.001 ! g/m2 --> t/ha
y_C_tot_es= y_C_tot + y_C_d_st + y_sumbio
ym_NPP = sumNPP * cpart ! kg DW --> kg C
ym_NPP = ym_NPP * 1./kpatchsize ! kg C/patch --> kg C/m2
ym_NPP = ym_NPP * 1000. / Cmass ! kg C --> mol C
ym_autresp= autresp * cpart * kgha_in_gm2 * hconv / Cmass ! kg DW pro patch --> mol/m2
ym_resps = resps_c /Cmass ! g/m2 --> mol/m2
ym_resptot= ym_resps + ym_autresp
ym_GPP = ym_NPP + ym_autresp
ym_NEP = ym_NPP - ym_resps
ym_C_d_st = C_opm_stem /Cmass ! g/m2 --> mol/m2
ym_sumvsab= sumvsab * cpart * kgha_in_gm2 / Cmass ! kg DW /ha --> mol/m2
ym_sumbio = sumbio * cpart * kgha_in_gm2 / Cmass ! kg DW /ha --> mol/m2
ym_C_tot = C_tot /Cmass ! g/m2 --> mol/m2
ym_C_tot_es= ym_C_tot + ym_C_d_st + ym_sumbio
gppsum = gppsum * gm2_in_kgha
WRITE(unit_n,'(I6)',advance='no') time_cur
WRITE(unit_n,'(10F10.1,9F10.2,11F10.1,F10.1)') y_GPP, y_NPP, y_NEP, y_autresp, y_resps, y_resptot, &
y_C_d_st, y_sumvsab, y_sumbio, y_C_tot_es, y_C_tot, &
C_tot_1, C_hum_1, C_tot_40, C_hum_40, C_tot_80, C_hum_80, C_tot_100, C_hum_100, &
ym_GPP, ym_NPP, ym_NEP, ym_autresp, ym_resps, ym_resptot, &
ym_C_d_st, ym_sumvsab, ym_sumbio, ym_C_tot_es, ym_C_tot, gppsum
CASE ('Cbc')
if (flag_bc .gt. 0) then
WRITE(unit_n,'(I6)',advance='no') time_cur
do j=1,nlay
WRITE(unit_n,'(F10.3)',advance='no') C_bc(j)
END DO !j
WRITE(unit_n,'(A)') ''
endif
CASE ('Chum')
WRITE(unit_n,'(I6)',advance='no') time_cur
do j=1,nlay
WRITE(unit_n,'(F10.3)',advance='no') C_hum(j)
END DO !j
WRITE(unit_n,'(A)') ''
CASE ('Copm')
WRITE(unit_n,'(I6)',advance='no') time_cur
do j=1,nlay
WRITE(unit_n,'(F10.3)',advance='no') C_opm(j)
END DO !j
WRITE(unit_n,'(A)') ''
CASE ('Copmfract')
WRITE(unit_n,'(I6)',advance='no') time_cur
do k=1,anrspec
j = nrspec(k)
xhelp = SUM(slit(j)%C_opm_frt)
xhelp1 = SUM(slit(j)%C_opm_crt)
WRITE(unit_n,'(I8,5F10.3)',advance='no') j, slit(j)%C_opm_fol, slit(j)%C_opm_tb, &
xhelp, xhelp1, slit(j)%C_opm_stem
END DO ! j
WRITE(unit_n,'(A)') ''
CASE ('classd')
WRITE(unit_n,'(I6)',advance='no') time_cur
do k=1,nspecies
do j=1,num_class
WRITE(unit_n,'(I10)',advance='no') diam_class(j,k)
END DO
end do
WRITE(unit_n,'(A)') ''
CASE ('classage')
WRITE(unit_n,'(I6)',advance='no') time_cur
do k=1,nspecies
do j=1,num_class
WRITE(unit_n,'(I10)',advance='no') diam_class_age(j,k)
END DO
end do
WRITE(unit_n,'(A)') ''
CASE ('classmvol')
WRITE(unit_n,'(I6)',advance='no') time_cur
do k=1,nspecies
do j=1,num_class
WRITE(unit_n,'(f10.3)',advance='no') diam_class_mvol(j,k)
END DO
end do
WRITE(unit_n,'(A)') ''
CASE ('classd_h')
WRITE(unit_n,'(I6)',advance='no') time_cur
do k=1,nspecies
do j=1,num_class
WRITE(unit_n,'(f10.3)',advance='no') diam_class_h(j,k)
END DO
end do
WRITE(unit_n,'(A)') ''
CASE ('classdm')
WRITE(unit_n,'(I6)',advance='no') time_cur
do k=1,nspecies
do j=1,num_class
WRITE(unit_n,'(I10)',advance='no') diam_classm(j,k)
END DO
end do
WRITE(unit_n,'(A)') ''
CASE ('classdm_h')
WRITE(unit_n,'(I6)',advance='no') time_cur
do k=1,nspecies
do j=1,num_class
WRITE(unit_n,'(f10.3)',advance='no') diam_classm_h(j,k)
END DO
end do
WRITE(unit_n,'(A)') ''
CASE ('classh')
WRITE(unit_n,'(I6)',advance='no') time_cur
do j=1,num_class
WRITE(unit_n,'(I10)',advance='no') height_class(j)
END DO
WRITE(unit_n,'(A)') ''
CASE ('classt')
WRITE(unit_n,'(I6)',advance='no') time_cur
do k=1,nspecies
do j=1,num_class
WRITE(unit_n,'(I10)',advance='no') diam_class_t(j,k)
END DO
end do
WRITE(unit_n,'(A)') ''
CASE ('clim')
help = co2 * 1000000.
WRITE(unit_n,'(2I5)',advance='no') time_cur
WRITE(unit_n,'(6F10.2, 6I10, 7F10.2, E12.4, F8.2, 6F10.2, 2F8.2, 3I8, F10.2, I8, F10.2)') med_air,sum_prec,med_rad, med_wind, help, gdday, &
days_summer, days_hot, days_ice, days_dry, days_hrain, days_snow, ind_arid_an, cwb_an, ind_lang_an, &
ind_cout_an, ind_wiss_an, ind_mart_an, ind_mart_vp, ind_emb, ind_weck, ind_reich, &
con_gor, con_cur, con_con, ntindex, ind_bud, hdnlf, hdnlf_sp, hdate_lf, hdate_lftot, hanzdlf, hsumtlf, iday_vegper, ind_shc
CASE ('clim_temp')
q1 = (temp_mon(1) + temp_mon(2) + temp_mon(3)) / 3.
q2 = (temp_mon(4) + temp_mon(5) + temp_mon(6)) / 3.
q3 = (temp_mon(7) + temp_mon(8) + temp_mon(9)) / 3.
q4 = (temp_mon(10) + temp_mon(11) + temp_mon(12)) / 3.
if (time .gt.1) then
h1 = (temp_dec + temp_mon(1) + temp_mon(2)) / 3.
else
h1 = (temp_mon(1) + temp_mon(2)) / 2.
endif
h2 = (temp_mon(3) + temp_mon(4) + temp_mon(5)) / 3.
h3 = (temp_mon(6) + temp_mon(7) + temp_mon(8)) / 3.
h4 = (temp_mon(9) + temp_mon(10) + temp_mon(11)) / 3.
WRITE(unit_n,'(I6)',advance='no') time_cur
WRITE(unit_n,'(20F10.2)') temp_mon, q1, q2, q3, q4, h1, h2, h3, h4
CASE ('clim_prec')
q1 = prec_mon(1) + prec_mon(2) + prec_mon(3)
q2 = prec_mon(4) + prec_mon(5) + prec_mon(6)
q3 = prec_mon(7) + prec_mon(8) + prec_mon(9)
q4 = prec_mon(10) + prec_mon(11) + prec_mon(12)
if (time .gt.1) then
h1 = prec_dec + prec_mon(1) + prec_mon(2)
else
h1 = prec_mon(1) + prec_mon(2)
endif
h2 = prec_mon(3) + prec_mon(4) + prec_mon(5)
h3 = prec_mon(6) + prec_mon(7) + prec_mon(8)
h4 = prec_mon(9) + prec_mon(10) + prec_mon(11)
WRITE(unit_n,'(I6)',advance='no') time_cur
WRITE(unit_n,'(20F10.2)') prec_mon, q1, q2, q3, q4, h1, h2, h3, h4
CASE ('clim_rad')
q1 = (rad_mon(1) + rad_mon(2) + rad_mon(3)) / 3.
q2 = (rad_mon(4) + rad_mon(5) + rad_mon(6)) / 3.
q3 = (rad_mon(7) + rad_mon(8) + rad_mon(9)) / 3.
q4 = (rad_mon(10) + rad_mon(11) + rad_mon(12)) / 3.
if (time .gt.1) then
h1 = (rad_dec + rad_mon(1) + rad_mon(2)) / 3.
else
h1 = (rad_mon(1) + rad_mon(2)) / 2.
endif
h2 = (rad_mon(3) + rad_mon(4) + rad_mon(5)) / 3.
h3 = (rad_mon(6) + rad_mon(7) + rad_mon(8)) / 3.
h4 = (rad_mon(9) + rad_mon(10) + rad_mon(11)) / 3.
WRITE(unit_n,'(I6)',advance='no') time_cur
WRITE(unit_n,'(20F10.2)') rad_mon, q1, q2, q3, q4, h1, h2, h3, h4
CASE ('clim_hum')
q1 = (hum_mon(1) + hum_mon(2) + hum_mon(3)) / 3.
q2 = (hum_mon(4) + hum_mon(5) + hum_mon(6)) / 3.
q3 = (hum_mon(7) + hum_mon(8) + hum_mon(9)) / 3.
q4 = (hum_mon(10) + hum_mon(11) + hum_mon(12)) / 3.
if (time .gt.1) then
h1 = (hum_dec + hum_mon(1) + hum_mon(2)) / 3.
else
h1 = (hum_mon(1) + hum_mon(2)) / 2.
endif
h2 = (hum_mon(3) + hum_mon(4) + hum_mon(5)) / 3.
h3 = (hum_mon(6) + hum_mon(7) + hum_mon(8)) / 3.
h4 = (hum_mon(9) + hum_mon(10) + hum_mon(11)) / 3.
WRITE(unit_n,'(I6)',advance='no') time_cur
WRITE(unit_n,'(20F10.2)') hum_mon, q1, q2, q3, q4, h1, h2, h3, h4
CASE ('indi')
WRITE(unit_n,'(2I5)',advance='no') time_cur
WRITE(unit_n,'(F10.2, 2(F8.2, 5I8), F10.1, I10, F8.2, 4I8 )') fire_indb, fire(1)%mean, fire(1)%frequ, &
fire(2)%mean, fire(2)%frequ, fire_indi_max, fire_indi_day, fire(3)%mean, (fire(3)%frequ(j), j=1,4)
CASE ('litter')
if (totfol .gt. 1E-6) then
y_fol = totfol_lit*100. / totfol
else
y_fol = -99.
endif
if (totfrt .gt. 1E-6) then
y_frt = totfrt_lit*100. / totfrt
else
y_frt = -99.
endif
if (tottb .gt. 1E-6) then
y_tb = tottb_lit*100. / tottb
else
y_tb = -99.
endif
if (totcrt .gt. 1E-6) then
y_crt = totcrt_lit*100. / totcrt
else
y_crt = -99.
endif
hconv = totsap + tothrt
if (hconv .gt. 1E-6) then
y_stem= totstem_lit*100. / hconv
else
y_stem = -99.
endif
y_totlit = totfol_lit + totfrt_lit + totcrt_lit + tottb_lit + totstem_lit
y_C_lit = (C_lit + C_lit_stem) * gm2_in_kgha
y_N_lit = (N_lit + N_lit_stem) * gm2_in_kgha
WRITE(unit_n,'(I6)',advance='no') time_cur
WRITE(unit_n,'(8E12.4,2(6E12.4),5F12.2)') totfol_lit,totfol_lit_tree,totfrt_lit,totfrt_lit_tree,totcrt_lit,tottb_lit,totstem_lit, y_totlit, &
C_lit_fol*gm2_in_kgha, C_lit_frt*gm2_in_kgha, C_lit_crt*gm2_in_kgha, &
C_lit_tb*gm2_in_kgha, C_lit_stem*gm2_in_kgha, y_C_lit, &
N_lit_fol*gm2_in_kgha, N_lit_frt*gm2_in_kgha, N_lit_crt*gm2_in_kgha, &
N_lit_tb*gm2_in_kgha, N_lit_stem*gm2_in_kgha, y_N_lit
CASE ('fcap_av')
WRITE(unit_n,'(I6)',advance='no') time_cur
do j=1,nlay
WRITE(unit_n,'(F10.3)',advance='no') field_cap(j) - wilt_p(j)
END DO !j
WRITE(unit_n,'(A)') ''
CASE ('fcapv_av')
WRITE(unit_n,'(I6)',advance='no') time_cur
do j=1,nlay
WRITE(unit_n,'(F10.3)',advance='no') f_cap_v(j) - wilt_p_v(j)
END DO !j
WRITE(unit_n,'(A)') ''
CASE ('GPP_mon')
q1 = GPP_mon(1) + GPP_mon(2) + GPP_mon(3)
q2 = GPP_mon(4) + GPP_mon(5) + GPP_mon(6)
q3 = GPP_mon(7) + GPP_mon(8) + GPP_mon(9)
q4 = GPP_mon(10) + GPP_mon(11) + GPP_mon(12)
if (time .gt.1) then
h1 = GPP_dec + GPP_mon(1) + GPP_mon(2)
else
h1 = GPP_mon(1) + GPP_mon(2)
endif
h2 = GPP_mon(3) + GPP_mon(4) + GPP_mon(5)
h3 = GPP_mon(6) + GPP_mon(7) + GPP_mon(8)
h4 = GPP_mon(9) + GPP_mon(10) + GPP_mon(11)
WRITE(unit_n,'(I6)',advance='no') time_cur
WRITE(unit_n,'(20F10.2)') GPP_mon, q1, q2, q3, q4, h1, h2, h3, h4
CASE ('humusv')
WRITE(unit_n,'(I6)',advance='no') time_cur
do j=1,nlay
WRITE(unit_n,'(F10.3)',advance='no') humusv(j)*100.
END DO !j
WRITE(unit_n,'(A)') ''
CASE ('NEE_mon')
q1 = NEE_mon(1) + NEE_mon(2) + NEE_mon(3)
q2 = NEE_mon(4) + NEE_mon(5) + NEE_mon(6)
q3 = NEE_mon(7) + NEE_mon(8) + NEE_mon(9)
q4 = NEE_mon(10) + NEE_mon(11) + NEE_mon(12)
if (time .gt.1) then
h1 = NEE_dec + NEE_mon(1) + NEE_mon(2)
else
h1 = NEE_mon(1) + NEE_mon(2)
endif
h2 = NEE_mon(3) + NEE_mon(4) + NEE_mon(5)
h3 = NEE_mon(6) + NEE_mon(7) + NEE_mon(8)
h4 = NEE_mon(9) + NEE_mon(10) + NEE_mon(11)
WRITE(unit_n,'(I6)',advance='no') time_cur
WRITE(unit_n,'(20F10.2)') NEE_mon, q1, q2, q3, q4, h1, h2, h3, h4
CASE ('NPP_mon')
q1 = NPP_mon(1) + NPP_mon(2) + NPP_mon(3)
q2 = NPP_mon(4) + NPP_mon(5) + NPP_mon(6)
q3 = NPP_mon(7) + NPP_mon(8) + NPP_mon(9)
q4 = NPP_mon(10) + NPP_mon(11) + NPP_mon(12)
if (time .gt.1) then
h1 = NPP_dec + NPP_mon(1) + NPP_mon(2)
else
h1 = NPP_mon(1) + NPP_mon(2)
endif
h2 = NPP_mon(3) + NPP_mon(4) + NPP_mon(5)
h3 = NPP_mon(6) + NPP_mon(7) + NPP_mon(8)
h4 = NPP_mon(9) + NPP_mon(10) + NPP_mon(11)
WRITE(unit_n,'(I6)',advance='no') time_cur
WRITE(unit_n,'(20F10.2)') NPP_mon, q1, q2, q3, q4, h1, h2, h3, h4
CASE ('Nbc')
if (flag_bc .gt. 0) then
WRITE(unit_n,'(I6)',advance='no') time_cur
do j=1,nlay
WRITE(unit_n,'(F10.3)',advance='no') N_bc(j)
END DO !j
WRITE(unit_n,'(A)') ''
endif
CASE ('Nhum')
WRITE(unit_n,'(I6)',advance='no') time_cur
do j=1,nlay
WRITE(unit_n,'(F10.3)',advance='no') N_hum(j)
END DO !j
WRITE(unit_n,'(A)') ''
CASE ('Nopm')
WRITE(unit_n,'(I6)',advance='no') time_cur
do j=1,nlay
WRITE(unit_n,'(F10.3)',advance='no') N_opm(j)
END DO !j
WRITE(unit_n,'(A)') ''
CASE ('manrec')
if (flag_manreal.eq.1) then
WRITE(unit_n,'(I6)',advance='no') time_cur-1
WRITE(unit_n,'(10x,A30,I6)') maninf, meas
end if
CASE ('mansort')
if ((flag_manreal.eq.1.or.flag_deadsort.eq.1).and.maninf.ne.'tending'.and.maninf.ne.'brushing') then
ztim=>st%first
do
IF (.not.ASSOCIATED(ztim)) exit
if(time.eq.ztim%tim%year.and. (ztim%tim%stype.eq.'ab'.or.ztim%tim%stype.eq.'tb')) then
se_m3_ha = (ztim%tim%vol/kpatchsize)*10000. ! m/patchsize ---> m3/ha
se_c_ha = se_m3_ha*spar(ztim%tim%specnr)%prhos*1000000.*cpart ! m/patchsize ---> kg C/ha
write(unit_n,'(3I6,1x,A5,1x,F8.3,1x,f7.3,1x,f7.3,1x,f7.3,1x,f7.3,1x,f9.4,1x,f14.3,1x,i8,x,a4)') ztim%tim%year,&
ztim%tim%count,ztim%tim%specnr,ztim%tim%ttype,ztim%tim%length,ztim%tim%dia,ztim%tim%diaor, ztim%tim%zapfd,&
ztim%tim%zapfdor,se_m3_ha, se_c_ha,int(ztim%tim%tnum), ztim%tim%stype
end if
ztim=>ztim%next
end do
flag_manreal=0
flag_deadsort=0
else if (maninf.eq.'tending'.or.maninf.eq.'brushing') then
flag_manreal=0
maninf=' '
end if
CASE ('root')
WRITE(unit_n,'(I6)',advance='no') time_cur
do j=1,nlay
WRITE(unit_n,'(F10.3)',advance='no') root_fr(j)
END DO !j
WRITE(unit_n,'(A)') ''
CASE ('fr_loss')
WRITE(unit_n,'(I6)',advance='no') time_cur
do j=1,nlay
WRITE(unit_n,'(F10.3)',advance='no') fr_loss(j)
END DO !j
WRITE(unit_n,'(A)') ''
CASE ('redis')
WRITE(unit_n,'(I6)',advance='no') time_cur
do j=1,nlay
WRITE(unit_n,'(F10.3)',advance='no') redis(j)
END DO !j
WRITE(unit_n,'(A)') ''
CASE ('sdrought')
WRITE(unit_n,'(I6)',advance='no') time_cur
WRITE(unit_n,'(20I8)') s_drought
CASE ('soil')
help = -99.0
Cbc_ap = 0.
if (time .gt. 0) help = rnet_cum / recs(time)
if (flag_bc .gt. 0) then
ihelp = y_bc_n - 1
if (y_bc_n .eq. 1) ihelp = y_bc_n
if (y_bc(ihelp) .eq. time) then
Cbc_ap = Cbc_ap + C_bc_appl(ihelp)
endif
endif
WRITE(unit_n,'(I6)',advance='no') time_cur
WRITE(unit_n,'(13F10.3,5F10.2,17F10.3,4F10.2)') med_air, sum_prec, int_cum_can, &
perc_cum, wupt_cum, wupt_r_c, tra_tr_cum, tra_sv_cum, wupt_e_c, aet_cum, wat_tot, gp_can_mean, &
N_min, N_tot, C_tot, N_an_tot, N_hum_tot, C_hum_tot, N_hum(1), C_hum(1), &
N_lit, C_lit, C_opm_fol, C_opm_frt, C_opm_crt, C_opm_tb, C_opm_stem, Nupt_c, &
Nleach_c, Ndep_cum, resps_c, pet_cum, int_cum_sveg, thick(1), dew_cum, help, N_bc_tot, C_bc_tot, Cbc_ap
CASE ('spec')
WRITE(unit_n,'(I6)',advance='no') time_cur
do j=1,nspecies
zeig=>pt%first
do while (associated(zeig))
if(zeig%coh%species.eq.j)then
WRITE(unit_n,'(2F10.2,I10,F10.2)',advance='no') svar(j)%med_diam, &
svar(j)%dom_height, svar(j)%sum_ntreea, svar(j)%sum_bio
exit
END IF
zeig=>zeig%next
END DO
END DO
WRITE(unit_n,*) ' '
CASE('standsort')
if (outy(i)%out_flag .eq. 1) then
outy(i)%out_flag = 2
else if (outy(i)%out_flag .eq. 2) then
ztim=>st%first
do
IF (.not.ASSOCIATED(ztim)) exit
if(ztim%tim%year.eq.time.and. ztim%tim%stype.eq.'vb') then
se_m3_ha = (ztim%tim%vol/kpatchsize)*10000. ! m/patchsize ---> m3/ha
se_c_ha = se_m3_ha*spar(ztim%tim%specnr)%prhos*1000000.*cpart ! m/patchsize ---> kg C/ha
write(unit_n,'(3I6,1x,A5,1x,F8.3,1x,f7.3,1x,f7.3,1x,f7.3,1x,f7.3,1x,f9.4,1x,f14.3,1x,i8)') ztim%tim%year,&
ztim%tim%count,ztim%tim%specnr,ztim%tim%ttype,ztim%tim%length,ztim%tim%dia,ztim%tim%diaor, ztim%tim%zapfd,&
ztim%tim%zapfdor,se_m3_ha, se_c_ha,int(ztim%tim%tnum)
end if
ztim=>ztim%next
end do
end if
CASE ('TER_mon')
q1 = TER_mon(1) + TER_mon(2) + TER_mon(3)
q2 = TER_mon(4) + TER_mon(5) + TER_mon(6)
q3 = TER_mon(7) + TER_mon(8) + TER_mon(9)
q4 = TER_mon(10) + TER_mon(11) + TER_mon(12)
if (time .gt.1) then
h1 = TER_dec + TER_mon(1) + TER_mon(2)
else
h1 = TER_mon(1) + TER_mon(2)
endif
h2 = TER_mon(3) + TER_mon(4) + TER_mon(5)
h3 = TER_mon(6) + TER_mon(7) + TER_mon(8)
h4 = TER_mon(9) + TER_mon(10) + TER_mon(11)
WRITE(unit_n,'(I6)',advance='no') time_cur
WRITE(unit_n,'(20F10.2)') TER_mon, q1, q2, q3, q4, h1, h2, h3, h4
CASE ('veg')
if (outy(i)%out_flag .eq. 1) then
vout%help_veg1(1) = anz_spec
vout%help_veg1(2) = anz_coh_act
vout%help_veg1(3) = anz_tree_ha
do k = 1, nspec_tree
y_lai = y_lai + svar(k)%sum_lai
end do
vout%help_veg2(1) = y_lai
vout%help_veg2(2) = sumbio
vout%help_veg2(3) = sumnpp
vout%help_veg2(4) = med_diam
vout%help_veg2(5) = hdom
vout%help_veg2(6) = totfol
vout%help_veg2(7) = totsap
vout%help_veg2(8) = totfrt
vout%help_veg2(9) = tothrt
vout%help_veg2(10) = totsteminc
vout%help_veg2(11) = totstem_m3
vout%help_veg3 = crown_area/kpatchsize
outy(i)%out_flag = 2
else if (outy(i)%out_flag .eq. 2) then
WRITE(unit_n,'(I6)',advance='no') time_cur
WRITE(unit_n,'(3I10)',advance='no') vout%help_veg1
WRITE(unit_n,'(F10.3,2E12.3,2F12.3,14E12.3, 5F12.3)') vout%help_veg2, sumvsab, sumvsdead, &
vout%help_veg3, drIndAl, Ndem, gp_can_mean, gp_can_min, gp_can_max, mean_diam, mean_height, basal_area, sumvsdead_m3, totsteminc_m3
outy(i)%out_flag = 1
endif
CASE ('veg_in')
WRITE(unit_n,'(2I5)',advance='no') time_cur
WRITE(unit_n,'(3I10)',advance='no') anz_spec_in, anz_coh_in, anz_tree_in
WRITE(unit_n,'(F10.3,E12.3,2F12.3,E12.3)') LAI_in, sumbio_in, med_diam_in, hmean_in, totfol_in
CASE ('veg_out')
WRITE(unit_n,'(2I5)',advance='no') time_cur
WRITE(unit_n,'(3I10)',advance='no') anz_spec_out, anz_coh_out, anz_tree_out
WRITE(unit_n,'(F10.3,E12.3,2F12.3,E12.3)') LAI_out, sumbio_out, med_diam_out, hmean_out, totfol_out
CASE ('veg_be')
! beech - veg file
call outveg (1, outy(i)%out_flag, unit_n)
CASE ('veg_bi')
! birch - veg file
call outveg (5, outy(i)%out_flag, unit_n)
CASE ('veg_pi')
! pine - veg file
call outveg (3, outy(i)%out_flag, unit_n)
CASE ('veg_pc')
! pinus contorta - veg file
if (nspec_tree .gt. 5) call outveg (6, outy(i)%out_flag, unit_n)
CASE ('veg_pp')
! pinus ponderosa - veg file
if (nspec_tree .gt. 6) call outveg (7, outy(i)%out_flag, unit_n)
CASE ('veg_pt')
! populus tremula - veg file
if (nspec_tree .gt. 7) call outveg (8, outy(i)%out_flag, unit_n)
CASE ('veg_oa')
! oak - veg file
call outveg (4, outy(i)%out_flag, unit_n)
CASE ('veg_sp')
! spruce - veg file
call outveg (2, outy(i)%out_flag, unit_n)
CASE ('veg_ph')
! aleppo pine - veg file
if (nspec_tree .gt. 8) call outveg (9, outy(i)%out_flag, unit_n)
CASE ('veg_dg')
! douglas fir - veg file
if (nspec_tree .gt. 9) call outveg (10, outy(i)%out_flag, unit_n)
CASE ('veg_rb')
! robinia - veg file
if (nspec_tree .gt. 10) call outveg (11, outy(i)%out_flag, unit_n)
CASE ('veg_egl')
! Eucalyptus globulus - veg file
if (nspec_tree .gt. 11) call outveg (12, outy(i)%out_flag, unit_n)
CASE ('veg_egr')
! Ecalyptus grandis - veg file
if (nspec_tree .gt. 12) call outveg (13, outy(i)%out_flag, unit_n)
CASE ('veg_sveg')
! ground vegetation - veg file
if (flag_sveg .gt. 0) call outveg (14, outy(i)%out_flag, unit_n)
CASE ('veg_mist')
! Mistletoe (Viscum a.) - veg file
if (flag_dis .gt. 0) call outveg (15, outy(i)%out_flag, unit_n)
END SELECT
END IF
END DO !i
if(flag_cohout==1 .or. flag_cohout==2) call coh_out_y (flagout)
if (flagout .eq. 2) deallocate (sout)
END subroutine outyear
!**************************************************************
SUBROUTINE outday (flagout)
!daily output
USE data_biodiv
USE data_climate
USE data_depo
USE data_inter
USE data_evapo
USE data_inter
USE data_simul
USE data_stand
USE data_species
USE data_soil
USE data_soil_cn
USE data_soil_t
USE data_out
IMPLICIT NONE
integer flagout ! control of output
! 1 - output with
! 2 - output
INTEGER i,j,jj,k
integer tt, month
INTEGER unit_n ! output unit
REAL xhelp, xhelp1
! output of all selected files
do i = 1,outd_n
if (outd(i)%out_flag .eq. flagout) then
unit_n = outd(i)%unit_nr
select CASE (outd(i)%kind_name)
CASE ('Cday')
j=iday
WRITE(unit_n,'(2I6)',advance='no') j,time_cur
WRITE(unit_n,'(13E12.4, F7.1)') phot_C, dailygrass_C, dailynetass_C, dailypotNPP_C, dailyNPP_C, NPP_day, GPP_day, Cout%NEE(j), &
TER_day, dailyautresp_C, Cout%Resp_aut(j), respsoil, dailyrespfol_C, 100.*totFPARsum
CASE ('Chumd')
WRITE(unit_n,'(2I6)',advance='no') iday,time_cur
do j=1,nlay
WRITE(unit_n,'(F10.3)',advance='no') C_hum(j)
END DO !j
WRITE(unit_n,'(A)') ''
CASE ('Copmd')
WRITE(unit_n,'(2I6)',advance='no') iday,time_cur
do j=1,nlay
WRITE(unit_n,'(F10.3)',advance='no') C_opm(j)
END DO !j
WRITE(unit_n,'(A)') ''
CASE ('Copmfractd')
WRITE(unit_n,'(2I6)',advance='no') iday,time_cur
do k=1,anrspec
j = nrspec(k)
xhelp = SUM(slit(j)%C_opm_frt)
xhelp1 = SUM(slit(j)%C_opm_crt)
WRITE(unit_n,'(I8,5F10.3)',advance='no') j, slit(j)%C_opm_fol, slit(j)%C_opm_tb, &
xhelp, xhelp1, slit(j)%C_opm_stem
END DO ! j
WRITE(unit_n,'(A)') ''
CASE ('Cbcd')
if (flag_bc .gt. 0) then
WRITE(unit_n,'(2I6)',advance='no') iday,time_cur
do j=1,nlay
WRITE(unit_n,'(F10.3)',advance='no') C_bc(j)
END DO !j
WRITE(unit_n,'(A)') ''
endif
CASE ('day')
WRITE(unit_n,'(2I6)',advance='no') iday,time_cur
xhelp = (NO_dep + NH_dep)*1000. ! g/m ==> mg/m
if (N_min > 100) then
continue
endif
WRITE(unit_n,'(21F10.3, F10.1, 3I7, I8, F8.3, 4F10.2, 4F10.3)',advance='no') airtemp,rad,prec,interc_can,snow,pet,aet, &
trans_dem,trans_tree,trans_sveg,gp_can,respsoil,Nleach,Nupt_d,N_min,N_an_tot, &
xhelp,cover,LAI, Irelpool(0), totFPARcan, fire_indi, fire(2)%index, fire(1)%index, fire(3)%index, snow_day, &
drIndd, bucks_root, bucks_100, prec-pet, dptemp, dew_rime, Rnet_tot, rad_max
WRITE(unit_n,'(A)') ''
CASE ('day_short')
call tzinda(tt,month,time_cur,iday)
WRITE(unit_n,'(2(I2,1X), I4, 2X)',advance='no') tt,month,time_cur
WRITE(unit_n,'(I8, F10.2)',advance='no') fire(2)%index, prec-pet
WRITE(unit_n,'(A)') ''
CASE ('NH4')
WRITE(unit_n,'(I6,I5,1X)',advance='no') iday,time_cur
do j=1,nlay
WRITE(unit_n,'(E10.3)',advance='no') NH4(j)
END DO !j
WRITE(unit_n,'(A)') ''
CASE ('NH4c')
WRITE(unit_n,'(2I6)',advance='no') iday,time_cur
do j=1,nlay
! convert gN/m2 into mgN/l
xhelp = pNH4f * NH4(j) * 1000. / wats(j)
WRITE(unit_n,'(F10.4)',advance='no') xhelp
END DO !j
WRITE(unit_n,'(A)') ''
CASE ('NO3')
WRITE(unit_n,'(I6,I5,1X)',advance='no') iday,time_cur
do j=1,nlay
WRITE(unit_n,'(E10.3)',advance='no') NO3(j)
END DO !j
WRITE(unit_n,'(A)') ''
CASE ('NO3c')
WRITE(unit_n,'(2I6)',advance='no') iday,time_cur
do j=1,nlay
! convert gN/m2 into mgN/l
xhelp = pNO3f * NO3(j) * 1000. / wats(j)
WRITE(unit_n,'(F10.4)',advance='no') xhelp
END DO !j
WRITE(unit_n,'(A)') ''
CASE ('Nhumd')
WRITE(unit_n,'(2I6)',advance='no') iday,time_cur
do j=1,nlay
WRITE(unit_n,'(F10.3)',advance='no') N_hum(j)
END DO !j
WRITE(unit_n,'(A)') ''
CASE ('Nopmd')
WRITE(unit_n,'(2I6)',advance='no') iday,time_cur
do j=1,nlay
WRITE(unit_n,'(F10.3)',advance='no') N_opm(j)
END DO !j
WRITE(unit_n,'(A)') ''
CASE ('NOPMfract')
WRITE(unit_n,'(2I6)',advance='no') iday,time_cur
do k=1,anrspec
j = nrspec(k)
WRITE(unit_n,'(5F10.3)',advance='no') slit(j)%N_opm_fol, slit(j)%N_opm_tb, &
slit(j)%N_opm_frt(1), slit(j)%N_opm_crt(1), slit(j)%N_opm_stem
END DO ! j
WRITE(unit_n,'(A)') ''
CASE ('Nuptd')
WRITE(unit_n,'(2I6)',advance='no') iday,time_cur
do j=1,nlay
WRITE(unit_n,'(E10.2)',advance='no') Nupt(j)
END DO !j
WRITE(unit_n,'(A)') ''
CASE ('Nmind')
WRITE(unit_n,'(2I6)',advance='no') iday,time_cur
do j=1,nlay
WRITE(unit_n,'(E10.2)',advance='no') Nmin(j)
END DO !j
WRITE(unit_n,'(A)') ''
CASE ('perc')
WRITE(unit_n,'(2I6)',advance='no') iday,time_cur
do j=1,nlay
WRITE(unit_n,'(F10.3)',advance='no') perc(j)
END DO !j
WRITE(unit_n,'(A)') ''
CASE ('specd')
WRITE(unit_n,'(2I6)',advance='no') iday,time_cur
k = 0
do jj=1,anrspec
j = nrspec(jj)
if (k .gt. 0) WRITE(unit_n,'(A12)',advance='no') ''
WRITE(unit_n,'(A16,I8)',advance='no') spar(j)%species_short_name, j
WRITE(unit_n,'(4E12.3, F10.3)',advance='no') svar(j)%Ndem, svar(j)%Nupt, svar(j)%Ndemp, svar(j)%Nuptp, svar(j)%RedN
WRITE(unit_n,'(A)') ''
k = k+1
END DO !j
CASE ('temp')
WRITE(unit_n,'(2I6,F10.3)',advance='no') iday,time_cur, temps_surf
do j=1,nlay
WRITE(unit_n,'(F10.3)',advance='no') temps(j)
END DO !j
WRITE(unit_n,'(A)') ''
CASE ('water')
WRITE(unit_n,'(2I6)',advance='no') iday,time_cur
do j=1,nlay
WRITE(unit_n,'(F10.3)',advance='no') wats(j)
END DO !j
WRITE(unit_n,'(A)') ''
CASE ('watvol')
WRITE(unit_n,'(2I6)',advance='no') iday,time_cur
do j=1,nlay
WRITE(unit_n,'(F10.3)',advance='no') watvol(j)
END DO !j
WRITE(unit_n,'(A)') ''
CASE ('wat_res')
WRITE(unit_n,'(2I6)',advance='no') iday,time_cur
do j=1,nlay
WRITE(unit_n,'(F10.4)',advance='no') wat_res(j)
END DO !j
WRITE(unit_n,'(A)') ''
CASE ('wupt')
WRITE(unit_n,'(2I6)',advance='no') iday,time_cur
do j=1,nlay
WRITE(unit_n,'(F10.3)',advance='no') wupt_r(j)
END DO !j
WRITE(unit_n,'(A)') ''
end select
END IF
END DO !i
if(flag_cohout .gt. 0) call coh_out_d (flagout)
END subroutine outday
!**************************************************************
SUBROUTINE coh_out_d (flagout)
! daily cohort output
USE data_simul
USE data_stand
USE data_out
USE data_par
IMPLICIT NONE
integer flagout ! control of output
! 1 - output with
! 2 - output
INTEGER i,j
INTEGER unit_n ! output unit
logical lflag
real help
! output of all selected files
do i = 1,outcd_n
if (outcd(i)%out_flag .eq. flagout) then
unit_n = outcd(i)%unit_nr
WRITE(unit_n ,'(2I5)',advance='no') iday,time_cur
do j= 1,max_coh
zeig => pt%first
lflag = .FALSE.
do while (associated(zeig))
if (zeig%coh%ident .eq. j) then
select CASE (outcd(i)%kind_name)
CASE ('ass')
WRITE(unit_n,'(E12.3)',advance='no') zeig%coh%assi
CASE ('aevi')
WRITE(unit_n,'(E12.3)',advance='no') zeig%coh%aev_i
CASE ('ddi')
WRITE(unit_n,'(F12.3)',advance='no') zeig%coh%drindd
CASE ('dem')
WRITE(unit_n,'(E12.3)',advance='no') zeig%coh%demand
CASE ('dips')
WRITE(unit_n,'(F12.3)',advance='no') zeig%coh%drindps
CASE ('gp')
WRITE(unit_n,'(E12.3)',advance='no') zeig%coh%gp
CASE ('gsdps')
WRITE(unit_n,'(F12.0)',advance='no') zeig%coh%ndaysps
CASE ('intcap')
help = SUM(zeig%coh%intcap)
WRITE(unit_n,'(E12.3)',advance='no') help
CASE ('interc')
WRITE(unit_n,'(E12.3)',advance='no') zeig%coh%interc_st
CASE ('Ndemc_d')
WRITE(unit_n,'(E12.3)',advance='no') zeig%coh%Ndemc_d
CASE ('Nuptc_d')
WRITE(unit_n,'(E12.3)',advance='no') zeig%coh%Nuptc_d
CASE ('N_fol')
WRITE(unit_n,'(E12.3)',advance='no') zeig%coh%N_fol
CASE ('N_pool')
WRITE(unit_n,'(E12.3)',advance='no') zeig%coh%N_pool
CASE ('RedNc')
WRITE(unit_n,'(E12.3)',advance='no') zeig%coh%RedNc
CASE ('resp')
help = zeig%coh%resp * kg_in_g * cpart ! kg DW per tree ==> g C per tree
WRITE(unit_n,'(E12.3)',advance='no') help
CASE ('respaut')
! help = zeig%coh%respaut * kg_in_g * cpart ! kg DW per tree ==> g C per tree
help = zeig%coh%maintres * kg_in_g * cpart
WRITE(unit_n,'(E12.3)',advance='no') help
CASE ('respbr')
help = zeig%coh%respbr * kg_in_g * cpart ! kg DW per tree ==> g C per tree
WRITE(unit_n,'(E12.3)',advance='no') help
CASE ('respfol')
help = zeig%coh%respfol * kg_in_g * cpart ! kg DW per tree ==> g C per tree
WRITE(unit_n,'(E12.3)',advance='no') help
CASE ('resphet')
help = zeig%coh%resphet * kg_in_g * cpart ! kg DW per tree ==> g C per tree
WRITE(unit_n,'(E12.3)',advance='no') help
CASE ('respsap')
help = zeig%coh%respsap * kg_in_g * cpart ! kg DW per tree ==> g C per tree
WRITE(unit_n,'(E12.3)',advance='no') help
CASE ('respfrt')
help = zeig%coh%respfrt * kg_in_g * cpart ! kg DW per tree ==> g C per tree
WRITE(unit_n,'(E12.3)',advance='no') help
CASE ('sup')
WRITE(unit_n,'(E12.3)',advance='no') zeig%coh%supply
CASE ('totfpar')
WRITE(unit_n,'(E12.3)',advance='no') zeig%coh%totfpar
end select
lflag = .TRUE.
exit
ELSE
zeig => zeig%next
END IF
END DO
if (.not. lflag) WRITE(unit_n,'(F12.3)',advance='no') -99.9
END DO !j
WRITE(unit_n,'(A)') ''
END IF ! out_flag
END DO !i
END subroutine coh_out_d
!**************************************************************
SUBROUTINE coh_out_y (flagout)
!yearly cohort output
use data_simul
use data_soil
use data_stand
use data_out
use data_par
implicit none
integer flagout ! control of cohort output
! 1 - output with outyear,
! 2 - output after management and mortality
integer i,j,k
integer unit_n ! output unit
logical lflag
real help
! output of all selected files
do i = 1,outcy_n
if (outcy(i)%out_flag .eq. flagout) then
unit_n = outcy(i)%unit_nr
WRITE(unit_n ,'(I5)',advance='no') time_cur
do j= 1,max_coh
zeig => pt%first
lflag = .FALSE.
do while (associated(zeig))
if (zeig%coh%ident .eq. j) then
select CASE (outcy(i)%kind_name)
CASE ('age')
WRITE(unit_n,'(I12)',advance='no') zeig%coh%x_age
CASE ('ahb')
WRITE(unit_n,'(E12.3)',advance='no') zeig%coh%x_ahb
CASE ('ahbasrel')
if (zeig%coh%Asapw .gt. zero) then
help = zeig%coh%x_ahb / zeig%coh%Asapw
else
help = 0.
endif
WRITE(unit_n,'(E12.3)',advance='no') help
CASE ('ahc')
WRITE(unit_n,'(E12.3)',advance='no') zeig%coh%ahc
CASE ('ahcasrel')
if (zeig%coh%Asapw .gt. zero) then
help = zeig%coh%ahc / zeig%coh%Asapw
else
help = 0.
endif
WRITE(unit_n,'(E12.3)',advance='no') help
CASE ('asapw')
WRITE(unit_n,'(E12.3)',advance='no') zeig%coh%Asapw
CASE ('atr')
WRITE(unit_n,'(I12)',advance='no') int(zeig%coh%ntreea)
CASE ('bioi')
WRITE(unit_n,'(E12.3)',advance='no') zeig%coh%bio_inc
CASE ('botlayer')
WRITE(unit_n,'(I12)',advance='no') zeig%coh%botLayer
CASE ('cpa')
WRITE(unit_n,'(E12.3)',advance='no') zeig%coh%crown_area*int(zeig%coh%ntreea)
CASE ('crt')
WRITE(unit_n,'(E12.3)',advance='no') zeig%coh%x_crt
CASE ('daybb')
WRITE(unit_n,'(I12)',advance='no') int(zeig%coh%day_bb)
CASE ('dcrb')
WRITE(unit_n,'(E12.3)',advance='no') zeig%coh%dcrb
CASE ('diac')
if( zeig%coh%ndaysgr.ne.0) then
WRITE(unit_n,'(E12.3)',advance='no') zeig%coh%drindal/zeig%coh%ndaysgr
else
WRITE(unit_n,'(E12.3)',advance='no') zeig%coh%drindal
end if
CASE ('diam')
WRITE(unit_n,'(f12.5)',advance='no') zeig%coh%diam
CASE ('dtr')
WRITE(unit_n,'(E12.3)',advance='no') zeig%coh%ntreed
CASE ('dwd')
help = zeig%coh%ntreed*(zeig%coh%x_sap + zeig%coh%x_hrt)
WRITE(unit_n,'(E12.3)',advance='no') help
CASE ('fol')
WRITE(unit_n,'(E12.3)',advance='no') zeig%coh%x_fol
CASE ('foli')
WRITE(unit_n,'(E12.3)',advance='no') zeig%coh%fol_inc
CASE ('frt')
WRITE(unit_n,'(E12.3)',advance='no') zeig%coh%x_frt
CASE ('frti')
WRITE(unit_n,'(E12.3)',advance='no') zeig%coh%frt_inc
CASE ('frtrel')
WRITE(unit_n,'(E12.3)',advance='no') zeig%coh%frtrel(1)
CASE ('geff')
WRITE(unit_n,'(E12.3)',advance='no') zeig%coh%geff
CASE ('gfol')
WRITE(unit_n,'(E12.3)',advance='no') zeig%coh%gfol
CASE ('gfrt')
WRITE(unit_n,'(E12.3)',advance='no') zeig%coh%gfrt
CASE ('grossass')
WRITE(unit_n,'(E12.3)',advance='no') zeig%coh%grossass
CASE ('gsap')
WRITE(unit_n,'(E12.3)',advance='no') zeig%coh%gsap
CASE ('gsd')
WRITE(unit_n,'(I12)',advance='no') zeig%coh%ndaysgr
CASE ('hbo')
WRITE(unit_n,'(E12.3)',advance='no') zeig%coh%x_hbole
CASE ('hea')
WRITE(unit_n,'(I12)',advance='no') zeig%coh%x_health
CASE ('hei')
WRITE(unit_n,'(E12.3)',advance='no') zeig%coh%height
CASE ('hrt')
WRITE(unit_n,'(E12.3)',advance='no') zeig%coh%x_hrt
CASE ('leaf')
WRITE(unit_n,'(E12.3)',advance='no') zeig%coh%t_leaf
CASE ('maintres')
WRITE(unit_n,'(E12.3)',advance='no') zeig%coh%maintres
CASE ('nas')
WRITE(unit_n,'(E12.3)',advance='no') zeig%coh%netass
CASE ('npp')
WRITE(unit_n,'(E12.3)',advance='no') zeig%coh%npp
CASE ('Ndemc_c')
WRITE(unit_n,'(E12.3)',advance='no') zeig%coh%Ndemc_c
CASE ('Nuptc_c')
WRITE(unit_n,'(E12.3)',advance='no') zeig%coh%Nuptc_c
CASE ('Nfol')
WRITE(unit_n,'(E12.3)',advance='no') zeig%coh%N_fol
CASE ('Npool')
WRITE(unit_n,'(E12.3)',advance='no') zeig%coh%N_pool
CASE ('Nstr')
if(zeig%coh%Ndemc_c.ne.0) then
help = zeig%coh%Nuptc_c / zeig%coh%Ndemc_c
else
help = zeig%coh%Nuptc_c
! help = 1
end if
WRITE(unit_n,'(E12.3)',advance='no') help
CASE ('rdpt')
WRITE(unit_n,'(E12.3)',advance='no') zeig%coh%x_rdpt
CASE ('rooteff')
WRITE(unit_n,'(F12.4)',advance='no') zeig%coh%rooteff(1)
CASE ('sap')
WRITE(unit_n,'(E12.3)',advance='no') zeig%coh%x_sap
CASE ('sfol')
WRITE(unit_n,'(E12.3)',advance='no') zeig%coh%sfol
CASE ('sfrt')
WRITE(unit_n,'(E12.3)',advance='no') zeig%coh%sfrt
CASE ('spn')
WRITE(unit_n,'(I12)',advance='no') zeig%coh%species
CASE ('ssap')
WRITE(unit_n,'(E12.3)',advance='no') zeig%coh%ssap
CASE ('stem')
WRITE(unit_n,'(E12.3)',advance='no') zeig%coh%stem_inc
CASE ('str')
WRITE(unit_n,'(I12)',advance='no') zeig%coh%x_stress
CASE ('tdb')
WRITE(unit_n,'(E12.3)',advance='no') zeig%coh%dbio
CASE ('trman')
WRITE(unit_n,'(I12)',advance='no') int(zeig%coh%ntreem)
CASE ('toplayer')
WRITE(unit_n,'(I12)',advance='no') zeig%coh%topLayer
CASE ('ttb')
WRITE(unit_n,'(E12.3)',advance='no') zeig%coh%totbio
CASE ('watleft')
WRITE(unit_n,'(F12.4)',advance='no') zeig%coh%watleft
CASE ('yrw')
WRITE(unit_n,'(F12.4)',advance='no') zeig%coh%jrb
end select
lflag = .TRUE.
exit
ELSE
zeig => zeig%next
END IF
END DO
if (.not. lflag) WRITE(unit_n,'(F12.3)',advance='no') -99.9
END DO !j
WRITE(unit_n,'(A)') ''
select CASE (outcy(i)%kind_name)
CASE ('frtrel')
do k=2,nroot_max
WRITE(unit_n ,'(I2,3X)',advance='no') k
do j= 1,max_coh
zeig => pt%first
lflag = .FALSE.
do while (associated(zeig))
if (zeig%coh%ident .eq. j) then
WRITE(unit_n,'(E12.3)',advance='no') zeig%coh%frtrel(k)
lflag = .TRUE.
exit
ELSE
zeig => zeig%next
END IF
END DO ! zeig
if (.not. lflag) WRITE(unit_n,'(F12.3)',advance='no') -99.9
END DO ! j
WRITE(unit_n,'(A)') ''
END DO ! k
WRITE(unit_n,'(A)') ''
CASE ('frtrelc')
do k=2,nroot_max
WRITE(unit_n ,'(I2,3X)',advance='no') k
do j= 1,max_coh
zeig => pt%first
lflag = .FALSE.
do while (associated(zeig))
if (zeig%coh%ident .eq. j) then
WRITE(unit_n,'(E12.3)',advance='no') zeig%coh%frtrelc(k)
lflag = .TRUE.
exit
ELSE
zeig => zeig%next
END IF
END DO ! zeig
if (.not. lflag) WRITE(unit_n,'(F12.3)',advance='no') -99.9
END DO ! j
WRITE(unit_n,'(A)') ''
END DO ! k
WRITE(unit_n,'(A)') ''
CASE ('rld')
if (flag_wred .eq. 9) then
do k=2,nroot_max
WRITE(unit_n ,'(I2,3X)',advance='no') k
do j= 1,max_coh
zeig => pt%first
lflag = .FALSE.
do while (associated(zeig))
if (zeig%coh%ident .eq. j) then
WRITE(unit_n,'(E12.3)',advance='no') zeig%coh%rld(k)
lflag = .TRUE.
exit
ELSE
zeig => zeig%next
END IF
END DO ! zeig
if (.not. lflag) WRITE(unit_n,'(F12.3)',advance='no') -99.9
END DO ! j
WRITE(unit_n,'(A)') ''
END DO ! k
endif
WRITE(unit_n,'(A)') ''
end select
endif ! out_flag
enddo !i
END subroutine coh_out_y
!**************************************************************
SUBROUTINE out_wpm (flagout)
use data_out
use data_simul
use data_wpm
implicit none
integer flagout ! control of output
! 0 - no output
! 1 - output at end of simulation
integer i,j,k
integer unit_n ! output unit
integer dummy
dummy = 0.
! output of all selected files
do j = 1,oute_n
if (oute(j)%out_flag .eq. flagout) then
unit_n = oute(j)%unit_nr
select CASE (oute(j)%kind_name)
CASE ('sea')
do i=1,size(years)
write(unit_n, '(I6, 30F10.2)') &
years(i), &
sum_costs(1,i), &
sum_costs(2,i), &
sum_costs(3,i), &
sum_costs(4,i), &
fix(2)-fix(1), &
sum_costs(5,i), &
st_costs(1,i), &
st_costs(2,i), &
st_costs(3,i), &
st_costs(4,i), &
st_costs(5,i), &
st_assets(1,i), &
st_assets(2,i), &
st_assets(3,i), &
st_assets(4,i), &
st_assets(5,i), &
ms_costs(1,i), &
ms_costs(2,i), &
ms_costs(3,i), &
ms_costs(4,i), &
ms_costs(5,i), &
ms_assets(1,i), &
ms_assets(2,i), &
ms_assets(3,i), &
ms_assets(4,i), &
ms_assets(5,i), &
fix(1), &
subsidy(1,i), &
subsidy(1,i), &
fix(2)
end do
case ('sea_npv')
do i=1,size(years)
write(unit_n, '(I6, 12F10.2)') &
years(i), &
npv(1,i), &
npv(2,i), &
npv(3,i), &
npv(4,i), &
npv(5,i), &
npv(6,i), &
npv(7,i), &
npv(8,i), &
npv(9,i), &
npv(10,i), &
npv(11,i), &
npv(12,i)
end do
CASE ('sea_ms')
do i=1,size(years)
write(unit_n, '(I6,43E10.3)') &
years(i), &
mansort_tg(1,1,i), &
mansort_tg(1,2,i), &
mansort_tg(1,3,i), &
mansort_tg(1,6,i), &
mansort_tg(1,7,i), &
mansort_tg(1,8,i), &
mansort_tg(1,9,i), &
mansort_tg(1,10,i), &
mansort_tg(2,1,i), &
mansort_tg(2,2,i), &
mansort_tg(2,4,i), &
mansort_tg(2,5,i), &
mansort_tg(2,6,i), &
mansort_tg(2,7,i), &
mansort_tg(2,8,i), &
mansort_tg(2,9,i), &
mansort_tg(2,10,i), &
mansort_tg(3,1,i), &
mansort_tg(3,2,i), &
mansort_tg(3,3,i), &
mansort_tg(3,4,i), &
mansort_tg(3,5,i), &
mansort_tg(3,6,i), &
mansort_tg(3,7,i), &
mansort_tg(3,8,i), &
mansort_tg(3,9,i), &
mansort_tg(3,10,i), &
mansort_tg(4,1,i), &
mansort_tg(4,2,i), &
mansort_tg(4,5,i), &
mansort_tg(4,6,i), &
mansort_tg(4,7,i), &
mansort_tg(4,8,i), &
mansort_tg(4,9,i), &
mansort_tg(4,10,i), &
mansort_tg(5,1,i), &
mansort_tg(5,2,i), &
mansort_tg(5,5,i), &
mansort_tg(5,6,i), &
mansort_tg(5,7,i), &
mansort_tg(5,8,i), &
mansort_tg(5,9,i), &
mansort_tg(5,10,i)
end do
CASE ('sea_st')
do i=1,size(years)
write(unit_n, '(I6,43E10.3)') &
years(i), &
standsort_tg(1,1,i), &
standsort_tg(1,2,i), &
standsort_tg(1,5,i), &
standsort_tg(1,6,i), &
standsort_tg(1,7,i), &
standsort_tg(1,8,i), &
standsort_tg(1,9,i), &
standsort_tg(1,10,i), &
standsort_tg(2,1,i), &
standsort_tg(2,2,i), &
standsort_tg(2,4,i), &
standsort_tg(2,5,i), &
standsort_tg(2,6,i), &
standsort_tg(2,7,i), &
standsort_tg(2,8,i), &
standsort_tg(2,9,i), &
standsort_tg(2,10,i), &
standsort_tg(3,1,i), &
standsort_tg(3,2,i), &
standsort_tg(3,3,i), &
standsort_tg(3,4,i), &
standsort_tg(3,5,i), &
standsort_tg(3,6,i), &
standsort_tg(3,7,i), &
standsort_tg(3,8,i), &
standsort_tg(3,9,i), &
standsort_tg(3,10,i), &
standsort_tg(4,1,i), &
standsort_tg(4,2,i), &
standsort_tg(4,5,i), &
standsort_tg(4,6,i), &
standsort_tg(4,7,i), &
standsort_tg(4,8,i), &
standsort_tg(4,9,i), &
standsort_tg(4,10,i), &
standsort_tg(5,1,i), &
standsort_tg(5,2,i), &
standsort_tg(5,5,i), &
standsort_tg(5,6,i), &
standsort_tg(5,7,i), &
standsort_tg(5,8,i), &
standsort_tg(5,9,i), &
standsort_tg(5,10,i)
end do
CASE ('wpm')
do i=1,size(years)
write(unit_n, '(I6,13E10.3, 1E11.3, 3E10.3)') &
years(i), &
sum_input(i), &
use_categories(1)%value(i), &
use_categories(2)%value(i), &
use_categories(3)%value(i), &
use_categories(4)%value(i), &
use_categories(5)%value(i), &
use_categories(6)%value(i), &
use_categories(7)%value(i), &
sum_use_cat(i), &
burning(i), &
landfill(i), &
atmo_year(i), &
atmo_cum(i), &
emission_har(i), &
sub_energy(i), &
sub_material(i), &
sub_sum(i)
end do
CASE ('wpm_inter')
do i=1,size(years)
write(unit_n, '(I6,27E10.3)') &
years(i), &
pl(1,1,i), &
pl(1,2,i), &
pl(1,3,i), &
pl(1,4,i), &
pl(1,5,i), &
pl(1,7,i), &
pl(2,1,i), &
pl(2,2,i), &
pl(2,3,i), &
pl(2,4,i), &
pl(2,5,i), &
pl(2,6,i), &
pl(2,7,i), &
pl(3,1,i), &
pl(3,2,i), &
pl(3,3,i), &
pl(3,4,i), &
pl(3,5,i), &
pl(3,6,i), &
pl(3,7,i), &
use_cat(1,i), &
use_cat(2,i), &
use_cat(3,i), &
use_cat(4,i), &
use_cat(5,i), &
use_cat(6,i), &
use_cat(7,i)
end do
end select
endif
enddo
end subroutine out_wpm
!**************************************************************
SUBROUTINE out_scen
USE data_simul
USE data_out
IMPLICIT NONE
WRITE (unit_ctr,*) ip,' ',deltaT,deltaPrec
END subroutine out_scen
!**************************************************************
SUBROUTINE out_comp(unit_comp)
! final result output for each run
USE data_biodiv
USE data_climate
USE data_depo
USE data_evapo
USE data_inter
USE data_manag
USE data_out
USE data_par
USE data_simul
USE data_site
USE data_soil
USE data_soil_cn
USE data_species
USE data_stand
USE data_climate
USE data_frost
IMPLICIT NONE
integer unit_comp
integer help1, i
real, dimension(31) :: help2
real hconv ! conversion factor from patchsize into ha
! output variables of final results in kg/ha
real y_NPP, & ! mean net primary productioin
y_GPP, & ! mean yearly gross productioin
y_NEP, & ! mean yearly net ecosystem productioin
y_sumbio, & ! total biomass of all cohorts and all tree-species
y_sumbio_sv,& ! total biomass of all cohorts and all ground-vegetation-species
y_autresp, & ! mean yearly total autotroph resp
y_resps, & ! mean yearly soil respiration
y_resptot, & ! mean yearly total respiration
y_C_accu, & ! mean yearly C accumualtion
y_RedN, & ! mean RedN of all species
y_lai ! LAI of stand without soil vegetation
real C_sum ! total C storage of the stand (biomass and soil)
real help_gdd
character(20) idtext, datei
character(150) htext
character(1) aa
call wclas(waldtyp)
hconv = 10000./kpatchsize
y_NPP = cum_sumNPP * hconv * cpart/year ! kg DW/patch --> kg C/ha
y_sumbio = sumbio / 1000. ! kg DW / ha --> t DW/ha
y_sumbio_sv = sumbio_sv / 1000. ! kg DW / ha --> t DW/ha
totfol = totfol / 1000. ! kg / ha --> t/ha
totsap = totsap / 1000. ! kg / ha --> t/ha
totfrt = totfrt / 1000. ! kg / ha --> t/ha
tothrt = tothrt / 1000. ! kg / ha --> t/ha
totcrt = totcrt / 1000. ! kg / ha --> t/ha
tottb = tottb / 1000. ! kg / ha --> t/ha
y_C_accu = (C_tot - C_accu) * gm2_in_kgha / year ! g C/m2 --> kg C/ha, mean
C_lit_m = C_lit_m * gm2_in_kgha / year ! g/m2 --> kg/ha, mean
N_lit_m = N_lit_m * gm2_in_kgha / year ! g/m2 --> kg/ha, mean
N_min_m = N_min_m * gm2_in_kgha / year ! g/m2 --> kg/ha, mean
Nupt_m = Nupt_m * gm2_in_kgha / year ! g/m2 --> kg/ha, mean
Nleach_m = Nleach_m * gm2_in_kgha / year ! g/m2 --> kg/ha, mean
y_resps = resps_c_m * gm2_in_kgha / year ! g C/m2 --> kg C/ha, mean
y_autresp = autresp_m * cpart * hconv / year
y_resptot = y_resps + y_autresp
y_GPP = y_NPP + y_autresp
y_NEP = y_NPP - y_resps ! kg C/ha
y_NPP = y_NPP / 1000. ! kg C /ha --> t C/ha
dew_m = dew_m / year
AET_m = AET_m / year
pet_m = pet_m / year
interc_m_can = interc_m_can / year
perc_m = perc_m / year
wupt_r_m = wupt_r_m / year
C_opm_stem = C_opm_stem * gm2_in_kgha / 1000. ! g C/m2 --> t C/ha
if (.not.lcomp1) C_tot = SUM(C_opm) + SUM(C_hum) ! calculated again (litter at the end)
C_tot = C_tot * gm2_in_kgha / 1000. ! g C/m2 --> t C/ha
C_hum_tot = C_hum_tot * gm2_in_kgha / 1000. ! g C/m2 --> t C/ha
med_air_all = med_air_all / year
med_rad_all = med_rad_all / year
mean_drIndAl = mean_drIndAl / year
help_gdd = gdday_all / year
sum_prec_all = sum_prec_all / year
Ndep_cum_all = Ndep_cum_all * gm2_in_kgha / year ! g/m2 --> kg/ha, mean
C_sum = C_tot + (sumbio + cumsumvsab + cumsumvsdead) * cpart / 1000. ! corrected due to C_opm_stem already in cumsumvsdead
if(fire_indb_m.gt.0) then
fire_indb_m = fire_indb_m / year ! fire index Bruschek
end if
fire(2)%mean_m = fire(2)%mean_m / year ! fire index east (Kaese M68)
fire(3)%mean_m = fire(3)%mean_m / year
cwb_an_m = cwb_an_m / year
ind_arid_an_m = ind_arid_an_m / year
ind_lang_an_m = ind_lang_an_m / year
ind_cout_an_m = ind_cout_an_m / year
ind_wiss_an_m = ind_wiss_an_m / year
ind_mart_an_m = ind_mart_an_m / year
ind_weck_m = ind_weck_m / year
ind_reich_m = ind_reich_m / year
ind_emb_m = ind_emb_m / year
con_gor_m = con_gor_m / year
con_cur_m = con_cur_m / year
con_con_m = con_con_m / year
ind_bud_m = ind_bud_m / year
ind_shc_m = ind_shc_m / year
if(time.gt.1) call frost_index_total
ntindex =0.
if(time.gt.1) then
tempmean_mo = tempmean_mo/year
call t_indices(tempmean_mo)
end if
y_lai = 0.
y_RedN = 0.
do i = 1, nspec_tree
y_lai = y_lai + svar(i)%sum_lai
end do
if (anz_RedN .gt. 0) y_RedN = RedN_mean / anz_RedN
select case (flag_multi)
case (4,5,8)
write (datei, '(A10)') adjustl(sitenum(ip)) ! standip can occur variable times, this ensures clear indetification
read (datei, '(A)') idtext
case default
htext = adjustr(site_name(ip))
idtext = adjustl(htext (131:150)) ! only write last 20 signs
end select
if(thin_dead .ne. 0) then
cumsumvsab = cumsumvsdead
cumsumvsdead = 0.
end if
if (time .le. 1) then
aa = 'B'
else
aa = 'E'
endif
if(flag_end .eq.0) then
write (unit_comp, '(A, I5,1X, A20,F6.2,I7,I4,F9.2,E10.3, 8F9.2, F11.3, E11.3, 4E11.4, 3F8.2,4F10.2, F9.1, F9.3, 4F10.1, 7F7.1, 2F9.3, F9.1, 3F10.2, &
7(1X,F9.2), E12.4, F8.2, 5F10.2, F8.2, 3F8.3,3X, 3f8.2)') &
aa, ip, idtext, y_lai, anz_tree_ha, waldtyp, y_sumbio, y_sumbio_sv, med_diam, hdom, totfol,tottb,totsap,tothrt,totfrt,totcrt, &
y_NPP, y_NEP, y_GPP, cumsteminc, cumsumvsab, cumsumvsdead, C_sum, C_opm_stem, C_tot, C_hum_tot,C_tot_40,C_hum_40, &
y_C_accu, C_lit_m, N_lit_m, N_min_m, Nleach_m, y_resps, y_resptot, pet_m, AET_m, perc_m, interc_m_can, wupt_r_m, med_air_all, &
sum_prec_all, Ndep_cum_all, mean_drIndAl, help_gdd, cwb_an_m, fire(2)%mean_m, fire_indb_m, ind_arid_an_m, ind_lang_an_m, ind_cout_an_m, &
ind_wiss_an_m, ind_mart_an_m, ind_weck_m, ind_reich_m, ind_emb_m, con_gor_m, con_cur_m, con_con_m, ntindex, fire(3)%mean_m, ind_bud_m, med_rad_all, y_RedN, dew_m, Nupt_m, mlfind, mlfind_sp, ind_shc_m
else
help1 = 0
help2 = 0.0
write (unit_comp, '(A, I5,1X, A15,F6.2,I7,I4, 8F9.2, 6E11.4, 3F8.2, 3F10.2, F9.1, F9.3, 2F10.1, 6F7.1, F9.3)') &
aa, ip, idtext, help2(1), help1, help1, (help2(i), i=1,31)
end if
END subroutine out_comp
!**************************************************************
SUBROUTINE error_mess(ti,mess,val)
USE data_out
USE data_simul
USE data_site
IMPLICIT NONE
INTEGER,intent(in) :: ti
CHARACTER(LEN=*),intent(in) :: mess
real,intent(in) :: val
if (flag_multi .ne. 5) then
write (unit_err, *)
write (unit_err, '(A8,I5,1X, A20, A10,I5)') 'ip/site ', ip, stand_id, ' Year ',ti
write(unit_err,'(A)',advance='no') trim(mess)
write(unit_err,*) val
endif
END subroutine error_mess
!**************************************************************
SUBROUTINE stop_mess(ti,mess)
USE data_out
IMPLICIT NONE
INTEGER,intent(in) :: ti
CHARACTER(LEN=*),intent(in) :: mess
WRITE(*,*) 'Program aborted in simulation year ',ti
WRITE(*,*) trim(mess)
WRITE(*,*) 'see error.log for reason'
END subroutine stop_mess
!**************************************************************
SUBROUTINE open_file (varout, help_ip)
! Open special output file
USE data_simul
USE data_out
IMPLICIT NONE
TYPE (out_struct) :: varout
INTEGER help_ip
CHARACTER(150) ::filename ! complete name of output file
filename = trim(site_name(help_ip))//'_'//trim(varout%kind_name)//'.out'//trim(anh)
varout%unit_nr = getunit()
open(varout%unit_nr,file=trim(dirout)//filename,status='replace')
END subroutine open_file
!**************************************************************
SUBROUTINE wr_header_file (varout)
! Write header of special output file
USE data_simul
USE data_out
IMPLICIT NONE
TYPE (out_struct) :: varout
INTEGER unit_n ! output unit
unit_n = varout%unit_nr
WRITE(unit_n ,'(A)') trim(varout%f_line)
WRITE(unit_n ,'(A)') trim(varout%s_line)
WRITE(unit_n ,'(A)') trim(varout%header)
END subroutine wr_header_file
!**************************************************************
SUBROUTINE outveg (nsp, out_flag, unit_n)
! output of species values (files veg_species)
USE data_climate
USE data_simul
USE data_species
USE data_stand
USE data_out
IMPLICIT NONE
integer:: nsp ! species number
integer:: out_flag ! output flag
integer:: unit_n ! output unit
real :: dumvar=0.
if (out_flag .eq. 1) then
sout(nsp)%help_veg1(1) = nsp
sout(nsp)%help_veg1(2) = svar(nsp)%anz_coh
sout(nsp)%help_veg1(3) = svar(nsp)%sum_nTreeA
sout(nsp)%help_veg2(1) = svar(nsp)%sum_lai
sout(nsp)%help_veg2(2) = svar(nsp)%sum_bio
sout(nsp)%help_veg2(3) = svar(nsp)%sumNPP
sout(nsp)%help_veg2(4) = svar(nsp)%med_diam
sout(nsp)%help_veg2(5) = svar(nsp)%dom_height
sout(nsp)%help_veg2(6) = svar(nsp)%fol
sout(nsp)%help_veg2(7) = svar(nsp)%sap
sout(nsp)%help_veg2(8) = svar(nsp)%frt
sout(nsp)%help_veg2(9) = svar(nsp)%hrt
sout(nsp)%help_veg2(10)= svar(nsp)%totsteminc
sout(nsp)%help_veg2(11)= svar(nsp)%totstem_m3
sout(nsp)%help_veg3 = svar(nsp)%crown_area/kpatchsize
sout(nsp)%help_veg4 = svar(nsp)%sumvsdead*10000/kpatchsize
sout(nsp)%help_veg5 = svar(nsp)%sumvsdead_m3*10000/kpatchsize
sout(nsp)%help_veg6 = svar(nsp)%totsteminc_m3
out_flag = 2
else if (out_flag .eq. 2) then
WRITE(unit_n,'(I6)',advance='no') time_cur
WRITE(unit_n,'(3I10)',advance='no') sout(nsp)%help_veg1
WRITE(unit_n,'(F10.3,2E12.3,2F12.3,9E12.3, 4F12.3, I6, F6.0,3F12.3, 3F12.4)') sout(nsp)%help_veg2, svar(nsp)%sumvsab, sout(nsp)%help_veg4, &
sout(nsp)%help_veg3, svar(nsp)%drIndAl, svar(nsp)%Ndem, svar(nsp)%Nupt, svar(nsp)%RedNm, &
svar(nsp)%daybb, spar(nsp)%end_bb, svar(nsp)%mean_diam, svar(nsp)%mean_height, svar(nsp)%basal_area, sout(nsp)%help_veg5,sout(nsp)%help_veg6, svar(nsp)%mean_jrb
out_flag = 1
endif
END SUBROUTINE outveg
!**************************************************************
SUBROUTINE outstore
! store of output variables (multi run 4 and 8)
USE data_climate
USE data_depo
USE data_evapo
USE data_inter
USE data_manag
USE data_out
USE data_par
USE data_simul
USE data_soil
USE data_soil_cn
USE data_stand
USE data_biodiv
USE data_frost
IMPLICIT NONE
real C_sum, & ! total C storage of the stand (biomass and soil)
hconv, help
integer i, j, k, ipp
if (flag_trace) write (unit_trace, '(I4,I10,A)') iday, time_cur, ' outstore '
if (flag_mult910) then
ipp = 1
else
ipp = ip
endif
hconv = 10000./kpatchsize
do i = 1, nvar-1
select case (trim(outvar(i)))
case('above_biom')
output_var(i,ipp,time)=(sumbio-totfrt-totcrt)/1000.
case ('AET','aet')
output_var(i,ipp,time) = AET_cum
case ('AET_year','AETyear','aetyear','aet_year') ! AET
outvar(i) = 'AET_year'
output_var(i,ipp,time) = AET_cum
case ('AET_mon','AETmon','aetmon','aet_mon') ! monthly AET
outvar(i) = 'AET_mon'
k = output_var(i,1,0)
do j = 1, 12
output_varm(k,ipp,time,j) = AET_mon(j)
enddo
case ('AET_week','AETweek','aetweek','aet_week') ! weekly AET
outvar(i) = 'AET_week'
k = output_var(i,1,0)
do j = 1, 52
output_varw(k,ipp,time,j) = AET_week(j)
enddo
case ( 'anzdlf') ! number of days with forst April - June
output_var(i,ipp,time) = anzdlf(time)
case ( 'BA') ! basal area
output_var(i,ipp,time) = basal_area
case ('C_accu','Caccu','c_accu') ! C accumulation per year
if (time .eq. 1) then
help = C_tot - C_accu
else
help = C_tot - C_accu
do j = 1, time-1
help = help - output_var(i,ipp,j)*1000.*kgha_in_gm2
end do
endif
output_var(i,ipp,time) = help * gm2_in_kgha / 1000. ! g C/m2 --> t C/ha
case ('C_d_stem','c_d_stem')
output_var(i,ipp,time) = C_opm_stem * gm2_in_kgha / 1000.
case ('chumtot','Chumtot','C_hum_tot') ! total C in humus
output_var(i,ipp,time) = C_hum_tot * gm2_in_kgha / 1000. ! g C/m2 --> t C/ha
case('con_gor')
output_var(i,ipp,time)=con_gor
case('con_cur')
output_var(i,ipp,time)=con_cur
case('con_con')
output_var(i,ipp,time)=con_con
case ('ctot','Ctot','C_tot') ! total soil C
output_var(i,ipp,time) = C_tot * gm2_in_kgha / 1000. ! g C/m2 --> t C/ha
case ('csum','Csum','C_sum') ! total C in ecosystem
output_var(i,ipp,time) = C_tot*gm2_in_kgha/1000. + (sumbio + cumsumvsab + cumsumvsdead) * cpart / 1000. ! t/ha
case('cwb') ! climatic water balance
output_var(i,ipp,time)=cwb_an
case ('cwbyear','cwb_year') ! climatic water balance
outvar(i) = 'cwb_year'
output_var(i,ipp,time)=cwb_an
case ('cwbmon','cwb_mon') ! monthly climatic water balance
outvar(i) = 'cwb_mon'
k = output_var(i,1,0)
do j = 1, 12
output_varm(k,ipp,time,j) = prec_mon(j) - pet_mon(j)
enddo
case ('cwbweek','cwb_week') ! weekly climatic water balance
outvar(i) = 'cwb_week'
k = output_var(i,1,0)
do j = 1, 52
output_varw(k,ipp,time,j) = prec_week(j) - pet_week(j)
enddo
case ( 'date_lf') ! number of the day with the last late frost
output_var(i,ipp,time) = date_lf(time)
case ( 'date_lft') ! number of the day with the last late frost
output_var(i,ipp,time) = date_lftot(time)
case('daybb_be')
output_var(i,ipp,time)= svar(1)%daybb
case('daybb_oa')
output_var(i,ipp,time)= svar(4)%daybb
case('daybb_bi')
output_var(i,ipp,time)= svar(5)%daybb
case ('dbh')
output_var(i,ipp,time) = mean_diam
case ('dens') ! stem density
output_var(i,ipp,time) = anz_tree_ha
case ('dnlf') ! number of frost days after start of vegetation period
output_var(i,ipp,time) = dnlf(time)
case ('dnlf_sp') ! number of frost days after bud burst
output_var(i,ipp,time) = dnlf_sp(time)
case ('drindal', 'drIndAl', 'drIndal', 'DrIndAl') ! drought index for allocation calculation (cum.) for the whole stand [-], weighted by NPP
output_var(i,ipp,time) = drIndAl
case ('fire_indb')
output_var(i,ipp,time) = fire_indb
case ('fire_ind1')
output_var(i,ipp,time) = fire(1)%mean
case ('fire_ind2')
output_var(i,ipp,time) = fire(2)%mean
case ('fire_ind3')
output_var(i,ipp,time) = fire(3)%mean
case ('fire_ind1_c1')
output_var(i,ipp,time) = fire(1)%frequ(1)
case ('fire_ind1_c2')
output_var(i,ipp,time) = fire(1)%frequ(2)
case ('fire_ind1_c3')
output_var(i,ipp,time) = fire(1)%frequ(3)
case ('fire_ind1_c4')
output_var(i,ipp,time) = fire(1)%frequ(4)
case ('fire_ind1_c5')
output_var(i,ipp,time) = fire(1)%frequ(5)
case ('fire_ind2_c1')
output_var(i,ipp,time) = fire(2)%frequ(1)
case ('fire_ind2_c2')
output_var(i,ipp,time) = fire(2)%frequ(2)
case ('fire_ind2_c3')
output_var(i,ipp,time) = fire(2)%frequ(3)
case ('fire_ind2_c4')
output_var(i,ipp,time) = fire(2)%frequ(4)
case ('fire_ind2_c5')
output_var(i,ipp,time) = fire(2)%frequ(5)
case ('fire_ind3_c1')
output_var(i,ipp,time) = fire(3)%frequ(1)
case ('fire_ind3_c2')
output_var(i,ipp,time) = fire(3)%frequ(2)
case ('fire_ind3_c3')
output_var(i,ipp,time) = fire(3)%frequ(3)
case ('fire_ind3_c4')
output_var(i,ipp,time) = fire(3)%frequ(4)
case ('fire_ind3_c5')
output_var(i,ipp,time) = fire(3)%frequ(5)
case('fortyp') ! forest type classified
call wclas(waldtyp)
output_var(i,ipp,time) = waldtyp
case ('gpp','GPP') ! yearly GPP
output_var(i,ipp,time) = sumGPP * hconv/100. ! g C/patch --> t C/ha
case ('GPP_year','GPPyear','gppyear','gpp_year') ! GPP for each year
outvar(i) = 'GPP_year'
output_var(i,ipp,time) = sumGPP * hconv/100. ! g C/patch --> t C/ha
case ('GPP_mon','GPPmon','gppmon','gpp_mon') ! monthly GPP
outvar(i) = 'GPP_mon'
k = output_var(i,1,0)
do j = 1, 12
output_varm(k,ipp,time,j) = GPP_mon(j) * hconv/100. ! g C/patch --> t C/ha
enddo
case ('GPP_week','GPPweek','gppweek','gpp_week') ! weekly GPP
outvar(i) = 'GPP_week'
k = output_var(i,1,0)
do j = 1, 52
output_varw(k,ipp,time,j) = GPP_week(j) * hconv/100. ! g C/patch --> t C/ha
enddo
case ('height')
output_var(i,ipp,time) = hdom
case ('iday_vp') ! yearly canopy interception
output_var(i,ipp,time) = iday_vegper
case('ind_arid')
output_var(i,ipp,time)=ind_arid_an
case('ind_cout')
output_var(i,ipp,time)=ind_cout_an
case('ind_emb')
output_var(i,ipp,time)=ind_emb
case('ind_lang')
output_var(i,ipp,time)=ind_lang_an
case('ind_mart')
output_var(i,ipp,time)=ind_mart_an
case('ind_reich')
output_var(i,ipp,time)=ind_reich
case('ind_weck')
output_var(i,ipp,time)=ind_weck
case('ind_wiss')
output_var(i,ipp,time)=ind_wiss_an
case ('int','interc') ! yearly canopy interception
output_var(i,ipp,time) = int_cum_can
case ('lai','LAI')
output_var(i,ipp,time) = LAImax
case ('NEE_mon','NEEmon','neemon','nee_mon') ! monthly NEP
outvar(i) = 'NEE_mon'
k = output_var(i,1,0)
do j = 1, 12
output_varm(k,ipp,time,j) = NEE_mon(j) ! g C/m
enddo
case ('NEP', 'nep')
outvar(i) = 'NEP'
output_var(i,ipp,time) = sumNPP * hconv * cpart/1000. - resps_c * gm2_in_kgha/1000. ! kg DW/patch --> t C/ha
case ('NEP_year','NEPyear','nepyear','nep_year') ! NEP of each year
outvar(i) = 'NEP_year'
output_var(i,ipp,time) = sumNPP * hconv * cpart/1000. - resps_c * gm2_in_kgha/1000. ! kg DW/patch --> t C/ha
case ('NEP_mon','NEPmon','nepmon','nep_mon') ! monthly NEP
outvar(i) = 'NEP_mon'
k = output_var(i,1,0)
do j = 1, 12
output_varm(k,ipp,time,j) = NPP_mon(j) * hconv/100. - resps_mon(j) * gm2_in_kgha/1000. ! kg C/patch --> t C/ha
enddo
case ('NEP_week','NEPweek','nepweek','nep_week') ! weekly NPP
outvar(i) = 'NEP_week'
k = output_var(i,1,0)
do j = 1, 52
output_varw(k,ipp,time,j) = NPP_week(j) * hconv/100. - resps_week(j) * gm2_in_kgha/1000. ! g C/patch --> t C/ha
enddo
case ('ndep','Ndep','N_dep') ! yearly N deposition
output_var(i,ipp,time) = Ndep_cum ! g N/m2
case('nleach', 'Nleach', 'N_leach') ! Annual N leaching kg N/ha
output_var(i,ipp,time) = N_min * gm2_in_kgha ! g/m2 --> kg/ha, mean
case ('nmin','Nmin','N_min') ! yearly N mineralization
output_var(i,ipp,time) = N_min * gm2_in_kgha ! g/m2 --> kg/ha, mean
case ('npp','NPP') ! NPP
output_var(i,ipp,time) = sumNPP * hconv * cpart/1000. ! kg DW/patch --> t C/ha
case ('NPP_year','NPPyear','nppyear','npp_year') ! NPP of each year
outvar(i) = 'NPP_year'
output_var(i,ipp,time) = sumNPP * hconv * cpart/1000. ! kg DW/patch --> t C/ha
case ('NPP_mon','NPPmon','nppmon','npp_mon') ! monthly NPP
outvar(i) = 'NPP_mon'
k = output_var(i,1,0)
do j = 1, 12
output_varm(k,ipp,time,j) = NPP_mon(j) * hconv/100. ! g C/patch --> t C/ha
enddo
case ('NPP_week','NPPweek','nppweek','npp_week') ! weekly NPP
outvar(i) = 'NPP_week'
k = output_var(i,1,0)
do j = 1, 52
output_varw(k,ipp,time,j) = NPP_week(j) * hconv/100. ! g C/patch --> t C/ha
enddo
case ('NTI', 'nti','NTindex','ntindex') ! Nonnen-Temperatur-Index
output_var(i,ipp,time) = ntindex
case ('perc') ! yearly percolation
output_var(i,ipp,time) = perc_cum
case ('perc_year') ! yearly percolation
outvar(i) = 'perc_year'
output_var(i,ipp,time) = perc_cum
case ('perc_mon', 'percmon') ! monthly percolation
outvar(i) = 'perc_mon'
k = output_var(i,1,0)
do j = 1, 12
output_varm(k,ipp,time,j) = perc_mon(j)
enddo
case ('perc_week', 'percweek') ! weekly percolation
outvar(i) = 'perc_week'
k = output_var(i,1,0)
do j = 1, 52
output_varw(k,ipp,time,j) = perc_week(j)
enddo
case ('PET','pet') ! potential evapotranspiration sum
output_var(i,ipp,time) = PET_cum
case ('PET_year','PETyear','pet_year','petyear') ! potential evapotranspiration sum of each year
outvar(i) = 'PET_year'
output_var(i,ipp,time) = PET_cum
case ('PET_mon','PETmon','pet_mon','petmon') ! monthly potential evapotranspiration sum
outvar(i) = 'PET_mon'
k = output_var(i,1,0)
do j = 1, 12
output_varm(k,ipp,time,j) = PET_mon(j)
enddo
case ('PET_week','PETweek','pet_week','petweek') ! weekly potential evapotranspiration sum
outvar(i) = 'PET_week'
k = output_var(i,1,0)
do j = 1, 52
output_varw(k,ipp,time,j) = PET_week(j)
enddo
case ('prec') ! yearly precipitation
output_var(i,ipp,time) = sum_prec
case ('prec_year', 'precyear') ! precipitation sum of each year
outvar(i) = 'prec_year'
output_var(i,ipp,time) = sum_prec
case ('prec_mon', 'precmon') ! monthly precipitation sum
outvar(i) = 'prec_mon'
k = output_var(i,1,0)
do j = 1, 12
output_varm(k,ipp,time,j) = prec_mon(j)
enddo
case ('prec_week', 'precweek') ! weekly precipitation sum
outvar(i) = 'prec_week'
k = output_var(i,1,0)
do j = 1, 52
output_varw(k,ipp,time,j) = prec_week(j)
enddo
case ('resps','respsoil') ! yearly soil respiration
outvar(i) = 'resps'
output_var(i,ipp,time) = resps_c * gm2_in_kgha ! g C/m2 --> kg C/ha, mean
case ('resps_year', 'respsyear') ! soil respiration of each year
outvar(i) = 'resps_year'
output_var(i,ipp,time) = resps_c * gm2_in_kgha ! g C/m2 --> kg C/ha, mean
case ('resps_mon', 'respsmon') ! monthly soil respiration
outvar(i) = 'resps_mon'
k = output_var(i,1,0)
do j = 1, 12
output_varm(k,ipp,time,j) = resps_mon(j) * gm2_in_kgha ! g C/m2 --> kg C/ha
enddo
case ('resps_week', 'respsweek') ! weekly soil respiration
outvar(i) = 'resps_week'
k = output_var(i,1,0)
do j = 1, 52
output_varw(k,ipp,time,j) = resps_week(j) * gm2_in_kgha ! g C/m2 --> kg C/ha
enddo
case('steminc')
output_var(i,ipp,time)= totsteminc/1000.
case ('sumbio') ! Biomass
output_var(i,ipp,time) = sumbio / 1000. ! kg DW / ha --> t DW/ha
case ('sumtlf') ! temperature sum of days with frost April - June
output_var(i,ipp,time) = sumtlf(time)
case ('temp') ! airtemp
output_var(i,ipp,time) = med_air
case ('temp_year', 'tempyear') ! mean yearly air temperature
outvar(i) = 'temp_year'
output_var(i,ipp,time) = med_air
case ('temp_mon', 'tempmon') ! mean monthly air temperature
outvar(i) = 'temp_mon'
k = output_var(i,1,0)
do j = 1, 12
output_varm(k,ipp,time,j) = temp_mon(j) ! Mittelung erfolgt schon in daily (/ monrec(j))
enddo
case ('temp_week', 'tempweek') ! mean weekly air temperature
outvar(i) = 'temp_week'
k = output_var(i,1,0)
do j = 1, 52
output_varw(k,ipp,time,j) = temp_week(j) / 7.
enddo
case ('TER','ter') ! yearly TER
outvar(i) = 'TER'
output_var(i,ipp,time) = sumTER * hconv/100. ! g C/patch --> t C/ha
case ('TER_year','TERyear','teryear','ter_year') ! yearly TER
outvar(i) = 'TER_year'
output_var(i,ipp,time) = sumTER * hconv/100. ! g C/patch --> t C/ha
case ('TER_mon','TERmon','termon','ter_mon') ! monthly TER
outvar(i) = 'TER_mon'
k = output_var(i,1,0)
do j = 1, 12
output_varm(k,ipp,time,j) = TER_mon(j) * hconv/100. ! g C/patch --> t C/ha
enddo
case ('TER_week','TERweek','terweek','ter_week') ! weekly TER
outvar(i) = 'TER_week'
k = output_var(i,1,0)
do j = 1, 52
output_varw(k,ipp,time,j) = TER_week(j) * hconv/100. ! g C/patch --> t C/ha
enddo
case('totstem')
output_var(i,ipp,time)= totstem_m3
case('vsab')
output_var(i,ipp,time)= sumvsab_m3
case('vsdead')
output_var(i,ipp,time)= sumvsdead_m3
end select
enddo
END SUBROUTINE outstore
!**************************************************************
SUBROUTINE out_var_file
! writing of output variables (multi run 4 and 8)
use data_biodiv
use data_out
use data_simul
use data_site
IMPLICIT NONE
integer i, ii, j, k, unit_nr
real varerr
character(50) :: filename ! complete name of output file
character(15) idtext, datei
real, dimension(12) :: helpf
real, dimension(52) :: helpw
character(30) :: helpvar
if (flag_trace) write (unit_trace, '(I4,I10,A)') iday, time_cur, ' out_var_file '
do i = 1, nvar-1
helpvar = outvar(i)
call out_var_select(helpvar, varerr, unit_nr)
if (varerr .ne. 0.) then
select case (trim(outvar(i)))
case ('AET_week','cwb_week','GPP_week','NEP_week','NPP_week','perc_week','PET_week','temp_week','TER_week','prec_week','resps_week')
write (unit_nr, '(A)') '# Site Week1 Week2 Week3 Week4 Week5 Week6 Week7 Week8 Week9 &
Week10 Week11 Week12 Week13 Week14 Week15 Week16 Week17 Week18 Week19 &
Week20 Week21 Week22 Week23 Week24 Week25 Week26 Week27 Week28 Week29 &
Week30 Week31 Week32 Week33 Week34 Week35 Week13 Week37 Week38 Week39 &
Week40 Week41 Week42 Week43 Week44 Week45 Week46 Week47 Week48 Week49 &
Week50 Week51 Week52'
do ip = 1, site_nr
write (datei, '(A10)') adjustl(sitenum(ip))
read (datei, '(A)') idtext
write (unit_nr, '(A15)', advance = 'no') idtext
ii = output_var(i,1,0)
helpw = 0.
do k = 1, 52
do j = 1, year
helpw(k) = helpw(k) + output_varw(ii,ip,j,k)
enddo
helpw(k) = helpw(k) / year
enddo
write (unit_nr, '(52(E12.4))', advance = 'no') helpw
write (unit_nr, '(A)') ''
enddo
case ('AET_mon','cwb_mon','GPP_mon','NEP_mon','NPP_mon','perc_mon','PET_mon','temp_mon','TER_mon','prec_mon','resps_mon')
write (unit_nr, '(A)') '# Site Mean1 Mean2 Mean3 Mean 4&
Mean5 Mean6 Mean7 Mean8 Mean9 Mean10 Mean11 Mean12'
do ip = 1, site_nr
write (datei, '(A10)') adjustl(sitenum(ip))
read (datei, '(A)') idtext
write (unit_nr, '(A15)', advance = 'no') idtext
ii = output_var(i,1,0)
helpf = 0.
do k = 1, 12
do j = 1, year
helpf(k) = helpf(k) + output_varm(ii,ip,j,k)
enddo
helpf(k) = helpf(k) / year
enddo
write (unit_nr, '(12(E12.4))', advance = 'no') helpf
write (unit_nr, '(A)') ''
enddo
case default
write (unit_nr, '(A)') '# Site Year 1 Year 2 Year 3 Year 4 Year 5 ...'
do ip = 1, site_nr
write (datei, '(A10)') adjustl(sitenum(ip))
read (datei, '(A)') idtext
write (unit_nr, '(A15)', advance = 'no') idtext
do j = 1, year
write (unit_nr, '(E12.4)', advance = 'no') output_var(i,ip,j)
enddo
write (unit_nr, '(A)') ''
enddo
end select
else
write (*,*)
write (*,*) '*** 4C-error - output of variables (out_var_file): ', trim(outvar(i)), ' not found'
write (*,*)
write (unit_err,*)
write (unit_err,*) '*** 4C-error - no such output variable (out_var_file): ', trim(outvar(i))
endif
close(unit_nr)
enddo
END SUBROUTINE out_var_file
!**************************************************************
SUBROUTINE out_var_select(varout, varerr, unit_nr)
! selection of output variables and open files (multi run 4, 8, 9)
use data_biodiv
use data_out
use data_simul
use data_site
IMPLICIT NONE
integer unit_nr
real varerr
character(50) :: filename ! complete name of output file
character(30) :: varout
character(15) idtext, datei
if (flag_trace) write (unit_trace, '(I4,I10,A,F6.0,I4)') iday, time_cur, ' out_var_select '//varout, varerr, unit_nr
filename = trim(site_name1)//'_'//trim(varout)//'.out'
unit_nr = getunit()
open(unit_nr,file=trim(dirout)//filename,status='replace')
write (unit_nr, '(A)') '# Output of '//varout
varerr = 0.
select case (trim(varout))
case('anzdlf')
write(unit_nr, '(A)') '# number of days with frost April - June'
varerr = 1
case ('AET','aet')
write (unit_nr, '(A)') '# Yearly actual evapotranspiration sum / mm'
varerr = 1.
case ('AET_year')
write (unit_nr, '(A)') '# Annual actual evapotranspiration sum / mm'
varerr = 1.
case ('AET_mon','aet_mon','AETmon','aetmon')
write (unit_nr, '(A)') '# Monthly actual evapotranspiration sum / mm'
varerr = 1.
case ('AET_week','aet_week','AETweek','aetweek')
write (unit_nr, '(A)') '# Weekly actual evapotranspiration sum / mm'
varerr = 1.
case('above_biom')
write(unit_nr,'(A)') '# Total aboveground biomass / t DW/ha'
varerr = 1.
case('BA')
write(unit_nr,'(A)') '# Basal arera m'
varerr = 1.
case ('C_accu','Caccu','c_accu') ! C accumulation per year
write (unit_nr, '(A)') '# Soil carbon accumulation per year / t C/ha'
varerr = 1.
case ('C_d_stem','c_d_stem') ! C accumulation per year
write (unit_nr, '(A)') '# carbon in dead trees / t C/ha'
varerr = 1.
case ('C_hum_tot','C_humtot','chumtot','Chumtot') ! total soil C
write (unit_nr, '(A)') '# Total carbon in humus / t C/ha'
varerr = 1.
case ('C_sum','csum','Csum') ! total C in ecosystem
write (unit_nr, '(A)') '# Total carbon in ecosystem / t C/ha'
varerr = 1.
case ('C_tot','ctot','Ctot') ! total soil C
write (unit_nr, '(A)') '# Total carbon in soil / t C/ha'
varerr = 1.
case('con_gor')
write(unit_nr,'(A)') '# Continentality index Gorczynski'
varerr = 1.
case('con_cur')
write(unit_nr,'(A)') '# Continentality index Currey'
varerr = 1.
case('con_con')
write(unit_nr,'(A)') '# Continentality index Conrad'
varerr = 1.
case('cwb_year','cwb')
write(unit_nr,'(A)') '# Annual climate water balance'
varerr = 1.
case('cwb_mon')
write(unit_nr,'(A)') '# Monthly climate water balance'
varerr = 1.
case('cwb_week')
write(unit_nr,'(A)') '# Weekly climate water balance'
varerr = 1.
case('date_lf')
write(unit_nr, '(A)') '# number of day of last late frost after start of vegetation period'
varerr = 1
case('date_lft')
write(unit_nr, '(A)') '# number of day of last late frost'
varerr = 1
case('daybb_be')
write(unit_nr,'(A)') '# Day of bud burst beech'
varerr = 1.
case('daybb_bi')
write(unit_nr,'(A)') '# Day of bud burst betula'
varerr = 1.
case('daybb_oa')
write(unit_nr,'(A)') '# Day of bud burst oak'
varerr = 1.
case ('dbh') ! mean DBH
write (unit_nr, '(A)') '# DBH / cm'
varerr = 1.
case ('dens') ! stem density /ha
write (unit_nr, '(A)') '# Stem density per ha'
varerr = 1.
case('dnlf')
write(unit_nr, '(A)') '# number of frost days since start of vegetation period'
varerr = 1.
case('dnlf_sp')
write(unit_nr, '(A)') '# number of frost days since start of bud burst'
varerr = 1.
case ('drindal','drIndAl','drIndal','DrIndAl') ! drought index for allocation calculation (cum.) for the whole stand [-], weighted by NPP
write (unit_nr, '(A)') '# Drought index for allocation calculation'
varerr = 1.
case ('fire_indb')
write (unit_nr, '(A)') '# Fire index Bruschek'
varerr = 1.
case ('fire_ind1')
write (unit_nr, '(A)') '# Fire index west'
varerr = 1.
case ('fire_ind2')
write (unit_nr, '(A)') '# Fire index east'
varerr = 1.
case ('fire_ind3')
write (unit_nr, '(A)') '# Fire index Nesterov'
varerr = 1.
case ('fire_ind1_c1')
write (unit_nr, '(A)') '# Fire index west class 1'
varerr = 1.
case ('fire_ind1_c2')
write (unit_nr, '(A)') '# Fire index west class 2'
varerr = 1.
case ('fire_ind1_c3')
write (unit_nr, '(A)') '# Fire index west class 3'
varerr = 1.
case ('fire_ind1_c4')
write (unit_nr, '(A)') '# Fire index west class 4'
varerr = 1.
case ('fire_ind1_c5')
write (unit_nr, '(A)') '# Fire index west class 5'
varerr = 1.
case ('fire_ind2_c1')
write (unit_nr, '(A)') '# Fire index east class 1'
varerr = 1.
case ('fire_ind2_c2')
write (unit_nr, '(A)') '# Fire index east class 2'
varerr = 1.
case ('fire_ind2_c3')
write (unit_nr, '(A)') '# Fire index east class 3'
varerr = 1.
case ('fire_ind2_c4')
write (unit_nr, '(A)') '# Fire index east class 4'
varerr = 1.
case ('fire_ind2_c5')
write (unit_nr, '(A)') '# Fire index east class 5'
varerr = 1.
case ('fire_ind3_c1')
write (unit_nr, '(A)') '# Fire index Nesterov class 1'
varerr = 1.
case ('fire_ind3_c2')
write (unit_nr, '(A)') '# Fire index Nesterov class 2'
varerr = 1.
case ('fire_ind3_c3')
write (unit_nr, '(A)') '# Fire index Nesterov class 3'
varerr = 1.
case ('fire_ind3_c4')
write (unit_nr, '(A)') '# Fire index Nesterov class 4'
varerr = 1.
case ('fire_ind3_c5')
write (unit_nr, '(A)') '# Fire index Nesterov class 5'
varerr = 1.
case ('fortyp')
write (unit_nr, '(A)') '# Forest classification'
varerr = 1.
case ('GPP') ! GPP
write (unit_nr, '(A)') '# Yearly gross primary production / t C/ha'
varerr = 1.
case ('GPP_year') ! GPP
write (unit_nr, '(A)') '# Annual gross primary production / t C/ha'
varerr = 1.
case ('GPP_mon') ! monthly GPP
write (unit_nr, '(A)') '# Monthly gross primary production / t C/ha'
varerr = 1.
case ('GPP_week') ! weekly GPP
write (unit_nr, '(A)') '# Weekly gross primary production / t C/ha'
varerr = 1.
case ('height') ! height, in this case dominant height
write (unit_nr, '(A)') '# Height / cm'
varerr = 1.
case ('iday_vp')
write (unit_nr, '(A)') '# start day of vegetation period'
varerr = 1.
case('ind_arid')
write(unit_nr,'(A)') '# Aridity index (UNEP)'
varerr = 1.
case('ind_lang')
write(unit_nr,'(A)') '# Climate index Lang'
varerr = 1.
case('ind_cout')
write(unit_nr,'(A)') '# Climate index Coutange'
varerr = 1.
case('ind_emb')
write(unit_nr,'(A)') '# Climate index Emberger'
varerr = 1.
case('ind_mart')
write(unit_nr,'(A)') '# Climate index Martonne'
varerr = 1.
case('ind_reich')
write(unit_nr,'(A)') '# Climate index Reichel'
varerr = 1.
case('ind_weck')
write(unit_nr,'(A)') '# Climate index Weck'
varerr = 1.
case('ind_wiss')
write(unit_nr,'(A)') '# Climate index v. Wissmann'
varerr = 1.
case ('int','interc') ! yearly canopy interception
write (unit_nr, '(A)') '# Yearly canopy interception / mm'
varerr = 1.
case ('lai','LAI') ! yearly canopy interception
write (unit_nr, '(A)') '# Maximum LAI '
varerr = 1.
case ('N_dep','ndep','Ndep') ! yearly N deposition
write (unit_nr, '(A)') '# Yearly N deposition / g N/m2'
varerr = 1.
case('N_leach', 'nleach', 'Nleach')
write(unit_nr,'(A)') '# Annual N leaching kg N/ha'
varerr = 1.
case ('N_min','nmin','Nmin') ! yearly N mineralization
write (unit_nr, '(A)') '# Yearly N mineralization / kg N/ha'
varerr = 1.
case ('nep','NEP') ! NEP
write (unit_nr, '(A)') '# Yearly net ecosystem production / t C/ha'
varerr = 1.
case ('NEP_year') ! NEP
write (unit_nr, '(A)') '# Annual net ecosystem production / t C/ha'
varerr = 1.
case ('NEP_mon') ! monthly NEP
write (unit_nr, '(A)') '# Monthly net ecosystem production / t C/ha'
varerr = 1.
case ('NEP_week') ! weekly NEP
write (unit_nr, '(A)') '# Weekly net ecosystem production / t C/ha'
varerr = 1.
case ('NPP','npp') ! NPP
write (unit_nr, '(A)') '# Yearly net primary production / t C/ha'
varerr = 1.
case ('NPP_year') ! NPP of each year
write (unit_nr, '(A)') '# Annual net primary production / t C/ha'
varerr = 1.
case ('NPP_mon') ! monthly NPP
write (unit_nr, '(A)') '# Monthly net primary production / t C/ha'
varerr = 1.
case ('NPP_week') ! weekly NPP
write (unit_nr, '(A)') '# Weekly net primary production / t C/ha'
varerr = 1.
case ('NTI', 'nti','NTindex','ntindex') ! Nonnen-Temperatur-Index
write (unit_nr, '(A)') '# Nun temperature index'
varerr = 1.
case ('perc') ! yearly percolation
write (unit_nr, '(A)') '# Yearly percolation / mm'
varerr = 1.
case ('perc_year') ! yearly percolation
write (unit_nr, '(A)') '# Annual percolation / mm'
varerr = 1.
case ('perc_mon', 'percmon') ! monthly percolation
write (unit_nr, '(A)') '# Monthly percolation / mm'
varerr = 1.
case ('perc_week', 'percweek') ! weekly percolation
write (unit_nr, '(A)') '# Weekly percolation / mm'
varerr = 1.
case ('PET','pet') ! PET
write (unit_nr, '(A)') '# Yearly potential evapotranspiration / mm'
varerr = 1.
case ('PET_year') ! PET
write (unit_nr, '(A)') '# Annual potential evapotranspiration / mm'
varerr = 1.
case ('PET_mon') ! PET
write (unit_nr, '(A)') '# Monthly potential evapotranspiration / mm'
varerr = 1.
case ('PET_week') ! PET
write (unit_nr, '(A)') '# Weekly potential evapotranspiration / mm'
varerr = 1.
case ('prec') ! yearly precipitation
write (unit_nr, '(A)') '# Yearly precipitation sum / mm'
varerr = 1.
case ('prec_year') ! yearly precipitation
write (unit_nr, '(A)') '# Annual precipitation sum / mm'
varerr = 1.
case ('prec_mon', 'precmon') ! monthly precipitation sum
write (unit_nr, '(A)') '# Monthly precipitation sum / mm'
varerr = 1.
case ('prec_week', 'precweek') ! weekly precipitation sum
write (unit_nr, '(A)') '# Weekly precipitation sum / mm'
varerr = 1.
case ('resps', 'respsoil') ! yearly soil respiration
write (unit_nr, '(A)') '# Yearly soil respiration / kg C/ha'
varerr = 1.
case ('resps_year') ! yearly soil respiration
write (unit_nr, '(A)') '# Annual soil respiration / kg C/ha'
varerr = 1.
case ('resps_mon', 'respsmon') ! monthly soil respiration
write (unit_nr, '(A)') '# Monthly soil respiration / kg C/ha'
varerr = 1.
case ('resps_week', 'respsweek') ! Weekly soil respiration
write (unit_nr, '(A)') '# Weekly soil respiration / kg C/ha'
varerr = 1.
case('steminc')
write(unit_nr,'(A)') '# Total annual stem increment t/ha'
varerr = 1.
case ('sumbio') ! Biomass
write (unit_nr, '(A)') '# Total Biomass / t DW/ha'
varerr = 1.
case('sumtlf')
write(unit_nr, '(A)') '# temperature sum of minimum temperature < 0 April - June'
varerr = 1
case ('temp') ! airtemp
write (unit_nr, '(A)') '# Mean yearly air temperature / C'
varerr = 1.
case ('temp_year') ! airtemp
write (unit_nr, '(A)') '# Mean annual air temperature / C'
varerr = 1.
case ('temp_mon', 'tempmon') ! mean monthly air temperature
write (unit_nr, '(A)') '# Mean monthly air temperature / C'
varerr = 1.
case ('temp_week', 'tempweek') ! mean weekly air temperature
write (unit_nr, '(A)') '# Mean weekly air temperature / C'
varerr = 1.
case ('TER') ! TER
write (unit_nr, '(A)') '# Yearly total ecosystem respiration / t C/ha'
varerr = 1.
case ('TER_year') ! TER
write (unit_nr, '(A)') '# Annual total ecosystem respiration / t C/ha'
varerr = 1.
case ('TER_mon') ! monthly TER
write (unit_nr, '(A)') '# Monthly total ecosystem respiration / t C/ha'
varerr = 1.
case ('TER_week') ! weekly TER
write (unit_nr, '(A)') '# Weekly total ecosystem respiration / t C/ha'
varerr = 1.
case('totstem')
write(unit_nr,'(A)') '# Total annual stem volume m/ha'
varerr = 1.
case('vsdead')
write(unit_nr,'(A)') '# Total annual dead stem volume m/ha (not in the litter pool)'
varerr = 1.
case('vsab')
write(unit_nr,'(A)') '# Total annual harvested stem volume m/ha'
varerr = 1.
end select
END SUBROUTINE out_var_select
!**************************************************************
source_code/version_2.3_windows/partitio.f 0 → 100644
View file @ 82df1085
!*****************************************************************!
!* *!
!* 4C (FORESEE) Simulation Model *!
!* *!
!* *!
!* Subroutines for: *!
!* - Calculation of annual allocation of NPP (SR PARTITION) *!
!* - Calculation of annual allocation of NPP of soil *!
!* vegetation (PARTITION_SV *!
!* - Calculation of diameter at breast height (SR CALC_DBH) *!
!* *!
!* 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 PARTITION *!
!****************************!
SUBROUTINE PARTITION( p )
!*** Declaration part ***!
USE data_out
USE data_par
USE data_stand
USE data_species
USE data_simul
USE data_manag
IMPLICIT NONE
REAL :: lambdaf = 0., & ! partitioning functions
lambdas = 0., &
lambdar = 0., &
lambdac = 0., &
lambdaSum = 0.,& ! sum of the above three lambdas
NPP = 0., & ! annual NPP
F = 0., & ! state variables: foliage,
S = 0., & ! sapwood,
H = 0., & ! heartwood
R = 0., & ! fine roots,
B = 0., & ! bole height,
Ahb = 0., & ! cross sectional area heartwood at tree base
hs = 0., & ! sapwood height
Ht = 0., & ! total tree height
Asw = 0., & ! cross sectional area of sapwood in bole
DBH = 0., & ! tree diameter at breast height (DBH)
FNew, SNew, & ! new states
RNew, BNew, &
HtNew, &
HNew, Ahbnew, &
sigmaf = 0., & ! current leaf activity rate
sigman = 0., & ! current root activity rate
ar = 0., & ! aux vars for partitioning functions
as = 0., &
ac = 0., &
betar = 0., &
betas = 0., &
aux = 0., &
Fmax, & ! determines whether height growth or not
rsap, & ! auxiliary variable for height growth determination
growthrate ! height growthrate depends on relative light regime in the middle of the canopy
REAL :: Sf, & ! senescence rates
Ss, &
Sr, &
Gf, & ! growth rates
Gs, &
Gr
real :: DBH_help
REAL :: leaf_N_conc, & ! last years N concentration in leaves gN kgDM
tbc_root_Ndemand, & ! N demand for ghrowth of fine roots, branches and coarse roots g tree-1
Nredfak, & ! reduction factor for N allocation to fine roots, branches and coarse roots
nsc_get, nsc_plus, nsc_max, & !nsc_get estimated NSC demand [kg DW/tree], nsc_plus realized NSC supply from storage for NPP [kg DW/tree], nsc_max [kg DW/tree] maximum=80%
nsc_sap_refill,nsc_tb_refill, & !calculated amount for refilling of the NSC-Pools [kg C/tree], subtracted from the NPP
nsc_crt_refill,nsc_all_refill, & !
bioscost_sap, bioscost_tb, & ! Biosynthesis cost [kg C/tree]
bioscost_crt, bioscost_all, max_for_refill
logical :: treegroup_decid, looptrue ! decidous or coniferous for flag_dis=1
integer, dimension(5) :: decidous = (/1, 4, 5, 8, 11/) ! species numbers for decidous trees for flag_dis=1
integer :: i, nrow_dis
TYPE(Coh_Obj) :: p ! pointer to cohort list
REAL :: term1, &
a1, a2, a3, & ! coefficients of quadratic equation
x1 = 0., &
x2 = 0. ! solutions of quadratic equation
real :: Fmax_old
! if this cohort is mistletoe infected, reduce NPP by mistletoe-specific demand
! demand is defined in PARTITION_MI. as mistletoe is always 1st cohort, the demand of mistletoe is calculated before the reduction here
if (p%coh%mistletoe.eq.1) then
p%coh%NPP = p%coh%NPP-(NPP_demand_mistletoe/p%coh%ntreea)
endif
ns = p%coh%species
F = p%coh%x_fol
Fmax = p%coh%Fmax
S = p%coh%x_sap
R = p%coh%x_frt
H = p%coh%x_hrt
B = p%coh%x_hbole
NPP = p%coh%NPP
Ht = p%coh%height
Ahb = p%coh%x_Ahb
Sf = p%coh%sfol
Ss = p%coh%ssap
Sr = p%coh%sfrt
hs = p%coh%x_hsap
Asw = p%coh%Asapw
Fmax_old = Fmax
DBH_help = p%coh%diam
if (flag_end.eq.1) then
p%coh%notViable = .TRUE.
flag_end = 0
end if
if(p%coh%notViable.neqv..TRUE.) then
select case (flag_folhei)
case (1,4)
spar(ns)%pha = spar(ns)%pha_v1 * spar(ns)%pha_v3 * &
(F)**(-1-spar(ns)%pha_v3)/(spar(ns)%pha_v2+(F)**(-spar(ns)%pha_v3))**2.
case (2)
rsap=Asw/(Asw+Ahb)
spar(ns)%pha = 2.*spar(ns)%crown_a/(pi**0.5*(rsap*spar(ns)%pnus)**1.5*F**0.5)
case (3)
! this version only for tests and pine trees
spar(ns)%pha = (3500*(10.+F**0.9)-(0.9*3500.*F**0.9))/(10.+F**0.9)**2
end select ! flag_folhei
! only allocate if enough NPP is available
IF (NPP>1.0E-9) THEN
select case (flag_folhei)
case (0)
growthrate=spar(ns)%pha*spar(ns)%pha_coeff1 + spar(ns)%pha*spar(ns)%pha_coeff2*(1./p%coh%IrelCan-1.)
case (1,3)
growthrate=spar(ns)%pha + spar(ns)%pha*(1./MAX(p%coh%IrelCan,0.25)-1.)
case (2)
growthrate=spar(ns)%pha + spar(ns)%pha*(1.-p%coh%IrelCan)*5.
case (4)
growthrate=spar(ns)%pha *0.5/MAX(p%coh%IrelCan,0.25)
end select ! flag_folhei
sigmaf = NPP/F
! calculate root activity based on drought index
! test of a relationship which modifies fine root leaf ratio with shade tolerance:
IF (flag_sign.eq.1 .or. flag_sign.eq.11) THEN
term1 = spar(ns)%sigman * 10. * (((5.-spar(ns)%stol)*1.-p%coh%crown_area) / (5.-spar(ns)%stol)*1.)
sigman = amax1(term1,spar(ns)%sigman) * p%coh%drIndAl/p%coh%nDaysGr
ELSE
sigman = spar(ns)%sigman * p%coh%drIndAl / p%coh%nDaysGr
END IF
if (flag_sign .eq. 0 .or. flag_sign .eq. 1) then
! auxiliary variables for fine roots
ar = spar(ns)%pcnr * sigmaf / sigman
betar = (Sr - R + ar*(F-Sf)) / NPP
! auxiliary variables for sapwood
as = spar(ns)%prhos / spar(ns)%pnus
aux = 2.*(B+p%coh%deltaB) + Ht
betas = ( (as/3.)*(aux - growthrate*Sf) * (F-Sf) + Ss - S ) / NPP
! solve quadratic equation for lambdaf
term1 = (1.+spar(ns)%alphac)
a1 = term1 * as/3. * growthrate * NPP
a2 = 1.0 + ar + term1 * as/3. * (aux + growthrate*(F-2.*Sf))
a3 = term1*betas + betar - 1.
x1 = (-a2 + SQRT( a2*a2 - 4.*a1*a3) ) / (2.*a1)
x2 = (-a2 - SQRT( a2*a2 - 4.*a1*a3) ) / (2.*a1)
lambdaf = x1
if (lambdaf .le. 0. .or. lambdaf .gt. 1.) then
lambdaf = 0.5
lambdar = 0.5
lambdas = 0.
lambdac = 0.
else
! calculate coefficients for sapwood and roots
lambdar = ar * lambdaf + betar;
lambdas = as/3. * (aux + growthrate*(F+lambdaf*NPP-2.*Sf)) * lambdaf + betas
lambdac = spar(ns)%alphac * lambdas
! check consistency of calculation, i.e. no negative values
IF(lambdas < 0. .or. lambdas .gt. 1.) THEN
lambdas = 0.
lambdac = 0.
lambdaf = (1.-betar)/(ar+1)
lambdar = 1.-lambdaf
if (lambdaf .le. 0. .or. lambdaf .gt. 1.) then
lambdaf = 0.5
lambdar = 0.5
else if (lambdar<0) then
lambdar=0.
lambdaf=1.
end if
ELSE
! reduced allocation schemes for lamdaf<0. or lamdar<0. still to be added
lambdaf = AMAX1( lambdaf, 0. )
lambdar = AMAX1( lambdar, 0. )
! warrant that lambdaSum = 1 if balance can not be achieved this time step
lambdaSum = lambdaf + (1.+spar(ns)%alphac)*lambdas + lambdar
lambdaf = lambdaf / lambdaSum
lambdas = lambdas / lambdaSum
lambdar = lambdar / lambdaSum
lambdac = lambdac / lambdaSum
lambdaSum = lambdaf + (1.+spar(ns)%alphac)*lambdas + lambdar ! for debugging only
END IF
end if ! lambdaf .le. 0.
else ! flag_sign = 10, 11
! auxiliary variables for fine roots
ar = spar(ns)%pcnr * sigmaf / sigman
betar = (Sr - ar*Sf) / NPP
! auxiliary variables for sapwood
as = spar(ns)%prhos / spar(ns)%pnus
betas = (Ss - 2.*as*hs*Sf ) / NPP
! auxiliary variables for coarse roots, twigs and branches
ac = spar(ns)%alphac
! linear equation system in lamda(i)
term1 = 1. + ar + 2.*as*hs*(1+ac)
lambdaf = 1. - (1.+ac)*betas - betar
lambdaf = lambdaf / term1
lambdar = ar * lambdaf + betar
lambdas = 2.*as*hs * lambdaf + betas
lambdac = ac * lambdas
if (lambdaf .le. 0. .or. lambdaf .gt. 1.) then
lambdaf = 0.5
lambdar = 0.5
lambdas = 0.
lambdac = ac * lambdas
else
! calculate coefficients for sapwood and roots
lambdar = ar * lambdaf + betar;
lambdas = 2.*as*hs * lambdaf + betas
lambdac = ac * lambdas
! check consistency of calculation, i.e. no negative values
IF(lambdas < 0. .or. lambdas .gt. 1.) THEN
lambdas = 0.
lambdac = 0.
lambdaf = (1.-betar)/(ar+1)
lambdar = 1.-lambdaf
if (lambdaf .le. 0. .or. lambdaf .gt. 1.) then
lambdaf = 0.5
lambdar = 0.5
else if (lambdar<0) then
lambdar=0.
lambdaf=1.
end if
ELSE
! reduced allocation schemes for lamdaf<0. or lamdar<0. still to be added
lambdaf = AMAX1( lambdaf, 0. )
lambdar = AMAX1( lambdar, 0. )
! warrant that lambdaSum = 1 if balance can not be achieved this time step
lambdaSum = lambdaf + (1.+spar(ns)%alphac)*lambdas + lambdar
lambdaf = lambdaf / lambdaSum
lambdas = lambdas / lambdaSum
lambdar = lambdar / lambdaSum
lambdac = lambdac / lambdaSum
lambdaSum = lambdaf + (1.+spar(ns)%alphac)*lambdas + lambdar ! for debugging only
END IF
end if ! lambdaf .le. 0.
endif ! flag_sign
ELSE
lambdaf = 0.
lambdas = 0.
lambdar = 0.
END IF ! IF NPP < 1.0E-09
! gross growth rates of compartments
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
select case(flag_dis)
case (1)
looptrue = .False.
if (size(dis_year) .gt. 0) then
nrow_dis = size(dis_year)
do i=1,nrow_dis
if (time .eq. dis_year(i)) looptrue = .True.
enddo
endif
case(2)
looptrue = .False.
if (size(dis_year) .gt. 0) then
nrow_dis = size(dis_year)
do i=1,nrow_dis
if (time .eq. dis_year(i)) looptrue = .True.
enddo
endif
nsc_sap_refill = 0.
nsc_tb_refill = 0.
nsc_crt_refill = 0.
bioscost_sap = 0.
bioscost_tb = 0.
bioscost_crt = 0.
bioscost_all = 0.
if (NPP .gt. 0.001) then !is not working if NPP<=0
!first calculate the amount of carbon which is used to refill nsc storage
! 0.128 cost of biosynthese (F. Stuart Chapin et al. 2011. &
! Principles of terrestrial ecosystem ecology (page 159, table 6.1), Eglin et al. 2008. &
! Biochemical composition is not the main factor influencing variability in carbon isotope composition of tree rings)
nsc_sap_refill = AMAX1(0.00001,p%coh%x_nsc_sap_max - p%coh%x_nsc_sap)
nsc_tb_refill = AMAX1(0.00001,p%coh%x_nsc_tb_max - p%coh%x_nsc_tb)
nsc_crt_refill = AMAX1(0.00001,p%coh%x_nsc_crt_max - p%coh%x_nsc_crt)
bioscost_sap = 0.128*nsc_sap_refill
bioscost_tb = 0.128*nsc_tb_refill
bioscost_crt = 0.128*nsc_crt_refill
nsc_all_refill = nsc_sap_refill + nsc_tb_refill + nsc_crt_refill
bioscost_all = bioscost_sap + bioscost_tb + bioscost_crt
max_for_refill = 0.5*cpart*NPP
if (nsc_all_refill .gt. 0.1) then
if (nsc_all_refill .gt. max_for_refill) then ! the half can be used for refilling,
nsc_sap_refill = AMIN1(nsc_sap_refill, max_for_refill)
max_for_refill = max_for_refill - nsc_sap_refill
if (max_for_refill .gt. 0.0001) then
nsc_tb_refill = AMIN1(nsc_tb_refill, max_for_refill)
max_for_refill = max_for_refill - nsc_tb_refill
endif
if (max_for_refill .gt. 0.0001) then
nsc_crt_refill = AMIN1(nsc_crt_refill, max_for_refill)
max_for_refill = max_for_refill - nsc_crt_refill
endif
bioscost_sap = 0.128*nsc_sap_refill
bioscost_tb = 0.128*nsc_tb_refill
bioscost_crt = 0.128*nsc_crt_refill
nsc_all_refill = nsc_sap_refill + nsc_tb_refill + nsc_crt_refill
bioscost_all = bioscost_sap + bioscost_tb + bioscost_crt
endif !nsc_all_refill .gt. max_for_refill
p%coh%biocost_all = bioscost_all * 2. !*2 is conversion from kg C to kg DW
NPP = AMIN1(NPP - nsc_all_refill*2. - bioscost_all*2., NPP) !*2 is conversion from kg C to kg DW
if (NPP .lt. 0.001) NPP=0.001
p%coh%x_nsc_sap = AMIN1(p%coh%x_nsc_sap + nsc_sap_refill, p%coh%x_nsc_sap_max)
p%coh%x_nsc_tb = AMIN1(p%coh%x_nsc_tb + nsc_tb_refill, p%coh%x_nsc_tb_max)
p%coh%x_nsc_crt = AMIN1(p%coh%x_nsc_crt + nsc_crt_refill, p%coh%x_nsc_crt_max)
endif !nsc_all_refill>0
write(8612,150) time, p%coh%ident, p%coh%ntreea, p%coh%NPP, NPP, p%coh%x_nsc_sap, p%coh%x_nsc_tb, p%coh%x_nsc_crt, nsc_sap_refill, nsc_tb_refill, nsc_crt_refill, bioscost_all
150 FORMAT (I4,2X,I4,2X,F5.1,2X,9(F12.4,2X))
!second if disturbance took place this year --> NSC is used and added to NPP
if(looptrue .eq. .True.) then ! hier abaendern fuer die zeit der verminderten NPP
!first determine the amount to take from nsc-pool
nsc_get = 0.
nsc_plus = 0.
if (dis_control(1,1) .eq. 1) nsc_get = p%coh%x_fol_loss + nsc_get
if (dis_control(4,1) .eq. 1) nsc_get = p%coh%x_frt_loss + nsc_get
if (dis_control(2,1) .eq. 1) nsc_get = p%coh%NPP * p%coh%drindAl + nsc_get
!if (dis_control(3,1) .eq. 1) nsc_get = p%coh%x_phloem_loss + nsc_get
nsc_max = (p%coh%x_nsc_sap + p%coh%x_nsc_tb + p%coh%x_nsc_crt)*2. !*2 Umrechnung von kg C/tree zu kg DW/tree
nsc_plus = AMIN1(nsc_get,nsc_max)
NPP = NPP + nsc_plus
!third update of nsc storage in the three compartements
p%coh%x_nsc_sap = AMAX1(p%coh%x_nsc_sap - nsc_plus*cpart/3.0, 0.00001) !cpart Umrechnung von kg DW/tree zu kg C/tree
p%coh%x_nsc_tb = AMAX1(p%coh%x_nsc_tb - nsc_plus*cpart/3.0, 0.00001)
p%coh%x_nsc_crt = AMAX1(p%coh%x_nsc_crt - nsc_plus*cpart/3.0, 0.00001)
endif ! end NSC surplus if disturbance year
p%coh%NPP = NPP !update NPP value
write(8613,160) time, p%coh%ident, p%coh%ntreea, NPP, nsc_max, nsc_get, nsc_plus, p%coh%x_nsc_sap, p%coh%x_nsc_tb, p%coh%x_nsc_crt
160 FORMAT (I4,2X,I4,2X,F5.1,2X,7(F12.4,2X))
else
write(*,*)' Attention:: NPP<=0 --> NSC-POOL not working!!!'
endif ! NPP>0
end select
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
Gf = lambdaf * NPP
Gr = lambdar * NPP
Gs = lambdas * NPP
p%coh%gfol = Gf
p%coh%gfrt = Gr
p%coh%gsap = Gs
p%coh%x_crt = p%coh%x_crt + Gs*spar(ns)%alphac*spar(ns)%cr_frac
p%coh%x_tb = p%coh%x_tb + Gs*spar(ns)%alphac*(1.-spar(ns)%cr_frac)
! update of state vector
select case (flag_dis)
! case (1,2)
! if (looptrue .eq. .True.) then
! FNew = F + Gf !im Schadjahr Seneszenz nicht nochmal abziehen
! SNew = S + Gs - Ss
! RNew = R + Gr !im Schadjahr Seneszenz nicht nochmal abziehen
! Hnew = H + Ss
! AhbNew= Ahb + Asw*spar(ns)%pss
! else
! FNew = F + Gf - Sf
! SNew = S + Gs - Ss
! RNew = R + Gr - Sr
! Hnew = H + Ss
! AhbNew= Ahb + Asw*spar(ns)%pss
! endif
case (0,1,2)
FNew = F + Gf - Sf
SNew = S + Gs - Ss
RNew = R + Gr - Sr
Hnew = H + Ss
AhbNew= Ahb + Asw*spar(ns)%pss
end select
! geffhelp = Gs/Fnew
! check whether height growth or not
IF (lambdas == 0.OR.FNew<Fmax) THEN ! treat special case where there is no height growth
HtNew = Ht
ELSE
! height growth depending on the relative light regime in the middle of the canopy
HtNew = Ht + growthrate * (FNew-Fmax)
Fmax=FNew
ENDIF
BNew = B+p%coh%deltaB
! copy back to original variables
p%coh%Fmax = Fmax
p%coh%x_fol = FNew
p%coh%x_sap = SNew
p%coh%x_frt = RNew
p%coh%x_hrt = HNew
p%coh%height = HtNew
p%coh%x_hbole= BNew
p%coh%x_Ahb = AhbNew
!Update of the maximum NSC storage capacity
select case(flag_dis)
case(2)
treegroup_decid = .False.
do i = 1, 5
if (decidous(i) .eq. p%coh%species) then
treegroup_decid = .True.
exit
endif
end do
If (treegroup_decid .eq. .True.) then
p%coh%x_nsc_sap_max = p%coh%x_sap * decid_sap_allo * cpart
p%coh%x_nsc_tb_max = p%coh%x_tb * decid_tb_allo * cpart
p%coh%x_nsc_crt_max = p%coh%x_crt * decid_crt_allo * cpart
p%coh%x_nsc_sap = AMIN1(p%coh%x_nsc_sap,p%coh%x_nsc_sap_max) ! has to change because of carbon inconsistency carbon loss due to sap shrinking is not accounted
p%coh%x_nsc_tb = AMIN1(p%coh%x_nsc_tb,p%coh%x_nsc_tb_max)
p%coh%x_nsc_crt = AMIN1(p%coh%x_nsc_crt,p%coh%x_nsc_crt_max)
endif
If (treegroup_decid .eq. .False.) then
p%coh%x_nsc_sap_max = p%coh%x_sap * conif_sap_allo * cpart
p%coh%x_nsc_tb_max = p%coh%x_tb * conif_tb_allo * cpart
p%coh%x_nsc_crt_max = p%coh%x_crt * conif_crt_allo * cpart
p%coh%x_nsc_sap = AMIN1(p%coh%x_nsc_sap,p%coh%x_nsc_sap_max)
p%coh%x_nsc_tb = AMIN1(p%coh%x_nsc_tb,p%coh%x_nsc_tb_max)
p%coh%x_nsc_crt = AMIN1(p%coh%x_nsc_crt,p%coh%x_nsc_crt_max)
endif
write(8614,170) time, p%coh%ident, p%coh%ntreea, p%coh%x_nsc_sap_max, p%coh%x_nsc_tb_max, p%coh%x_nsc_crt_max
170 FORMAT (I4,2X,I4,2X,F5.1,2X,3(F12.4,2X))
end select
CALL CALC_DBH(BNew,Htnew,Snew,Hnew,Ahbnew,p%coh%Ahc,p%coh%ident,DBH,p%coh%dcrb,hs,Asw)
if (flag_end.eq.1) then
DBH = p%coh%diam
p%coh%notViable = .TRUE.
flag_end = 0
end if
! Monitoring of current values
if (time_out .gt. 0 .and. flag_cohout .eq. 2) then
CALL OUT_ALL( p%coh%ident, p%coh%ntreea, NPP, DBH, growthrate,Fnew,Fmax_old,Htnew, lambdaf,lambdas,lambdar,lambdac,x1,x2,p%coh%x_nsc_sap_max, p%coh%x_nsc_tb_max, p%coh%x_nsc_crt_max, p%coh%x_nsc_sap, p%coh%x_nsc_tb, p%coh%x_nsc_crt)
endif
p%coh%x_hsap = hs
p%coh%diam = DBH ! This is the new value
p%coh%Asapw = Asw
p%coh%jrb = (DBH-DBH_help)*10/2
if(((DBH-DBH_help)*10/2).lt.0.) p%coh%jrb = 0.
! variables required by mortality submodel
p%coh%fol_inc = Gf - Sf
p%coh%bio_inc = NPP - Sf - (1.+spar(ns)%alphac)*Ss - Sr
p%coh%stem_inc = Gs ! deltaH + deltaS = Ss + Gs - Ss
p%coh%frt_inc = Gr - Sr ! fine root increment
p%coh%totBio = p%coh%x_fol + (1.+spar(ns)%alphac)*(p%coh%x_sap + p%coh%x_hrt) + p%coh%x_frt
p%coh%notViable = (FNew <= 0.) .OR. (SNew <= 0.) .OR. &
(RNew <= 0.) .OR. (Htnew <= Bnew)
! Nitrogen dynamics:
leaf_N_conc = p%coh%N_fol/F
! Simple model: all (sap)wood grows with CN-ratios of branches, twigs and coarse roots.
! When sapwood senesces N is reallocated and the new heart wood is at the level of stem CN-ratios.
! Branches, twigs and coarse roots do not senesce
! first step nitrogen related processes: N in litter, N-recallocation
p%coh%N_pool = p%coh%N_pool + Sf/F*p%coh%N_fol*spar(ns)%reallo_fol &
+ Sr*cpart/spar(ns)%cnr_frt*1000.* spar(ns)%reallo_frt &
+ Ss*cpart *1000. * (1/spar(ns)%cnr_tbc - 1/spar(ns)%cnr_stem)
p%coh%N_fol = p%coh%N_fol*(1-Sf/F)
! New version: cpart = C:biomass = 0.5 (amod.par)
! Summation, da Pool auch an anderen Stellen gefuellt wird
select case (flag_dis)
case (1,2)
p%coh%litC_fol = p%coh%litC_fol + p%coh%ntreea * Sf * cpart + p%coh%x_fol_loss * p%coh%ntreea * cpart
p%coh%litC_frt = p%coh%litC_frt + p%coh%ntreea * Sr * cpart + p%coh%x_frt_loss * p%coh%ntreea * cpart
case (0)
p%coh%litC_fol = p%coh%litC_fol + p%coh%ntreea * Sf * cpart
p%coh%litC_frt = p%coh%litC_frt + p%coh%ntreea * Sr * cpart
end select
! Sterblichkeit von sapwood fuert zu heartwood und nicht zur Litterproduktion
! p%coh%litC_tbc = p%coh%litC_tbc + p%coh%ntreea * spar(ns)%alphac*Ss * cpart
! Species specific N content and reallocation factor (see species.par)
! Caution: tbc mortallity is not a litter compartment; it is assigned as heartwood
p%coh%litN_fol = p%coh%litN_fol + p%coh%ntreea * Sf * cpart * (1.-spar(ns)%reallo_fol) / spar(ns)%cnr_fol
p%coh%litN_frt = p%coh%litN_frt + p%coh%ntreea * Sr * cpart * (1.-spar(ns)%reallo_frt) / spar(ns)%cnr_frt
! second step: allocation of N to new growth
! before bud-break allocation to leaves is 50% of the N content of last years foliage
tbc_root_Ndemand = Gs*cpart *kg_in_g / spar(ns)%cnr_tbc + Gr* cpart/spar(ns)%cnr_frt*kg_in_g
IF(tbc_root_Ndemand + Gf*p%coh%med_sla*0.5 > p%coh%N_pool) THEN
if (tbc_root_Ndemand .gt. 1E-8) then
Nredfak = AMAX1((p%coh%N_pool-Gf*p%coh%med_sla*0.5) / tbc_root_Ndemand,0.) ! Division by zero possible
else
Nredfak = 0.
endif
tbc_root_Ndemand = tbc_root_Ndemand*Nredfak
ENDIF
p%coh%N_pool = p%coh%N_pool - tbc_root_Ndemand
IF(p%coh%N_pool < Gf*0.5*leaf_N_conc) THEN
p%coh%N_fol = p%coh%N_fol + p%coh%N_pool
p%coh%N_pool = 0.
ELSE
p%coh%N_fol = p%coh%N_fol + Gf*0.5*leaf_N_conc
p%coh%N_pool = p%coh%N_pool - Gf*0.5*leaf_N_conc
ENDIF
end if
END SUBROUTINE PARTITION
!*******************************!
!* SUBROUTINE PARTITION_SV *!
!*******************************!
SUBROUTINE PARTITION_SV( p )
!*** Declaration part ***!
USE data_par
USE data_stand
USE data_species
USE data_simul
IMPLICIT NONE
REAL :: lambdaf = 0., & ! partitioning functions
lambdas = 0., &
lambdar = 0., &
NPP = 0., & ! annual NPP
F = 0., & ! state variables: foliage,
S = 0., & ! sapwood,
R = 0., & ! fine roots,
Ht = 0., & ! total tree height
FNew, SNew, & ! new states
RNew, &
sigmaf = 0., & ! current leaf activity rate
sigman = 0. ! current root activity rate
REAL :: Sf, & ! senescence rates
Ss, &
Sr, &
Gf, & ! growth rates
Gs, &
Gr
REAL :: FRsum
REAL :: tbc_root_Ndemand, & ! N demand for ghrowth of fine roots, branches and coarse roots g tree-1
Nredfak ! reduction factor for N allocation to fine roots, branches and coarse roots
REAL, EXTERNAL :: f_lf, df_lf, ddf_lf
INTEGER :: flag_SV_allo, &
rnum
TYPE(Coh_Obj) :: p ! pointer to cohort list
ns = p%coh%species
F = p%coh%x_fol
S = p%coh%x_sap
R = p%coh%x_frt
NPP = p%coh%NPP
Ht = p%coh%height
Sf = p%coh%sfol
Ss = p%coh%ssap
Sr = p%coh%sfrt
! choice of allocation model. 0 = constant allocation factors, 1 = allometric model
flag_SV_allo = 1
! only allocate if enough NPP is available
IF (NPP>1.0E-9) THEN
! calculate leaf activity based on net PS and leaf mass
sigmaf = NPP/F
! calculate root activity based on drought index
! test of a relationship which modifies fine root leaf ratio with shade tolerance
IF (flag_sign.eq.1) THEN
sigman = amax1(spar(ns)%sigman*10*(((5.-spar(ns)%stol)*1.-p%coh%crown_area)/(5.-spar(ns)%stol)*1.),spar(ns)%sigman) * p%coh%drIndAl / p%coh%nDaysGr
ELSE
sigman = spar(ns)%sigman * p%coh%drIndAl / p%coh%nDaysGr
END IF
M_avail=(NPP+F-Sf+R-Sr+S-Ss)/kpatchsize
IF(flag_SV_allo==0) THEN
! the parameters pdiam in the species.par file are used for allocation fractions
lambdaf=spar(ns)%pdiam1
lambdar=spar(ns)%pdiam2
lambdas=spar(ns)%pdiam3
ELSE
FRsum=(F+R)/kpatchsize
CALL newt (FRsum, f_lf, df_lf, ddf_lf, 1.e-6, 100, rnum)
IF(FRsum>M_avail .and. .not.flag_mult8910) CALL error_mess(time,'no solution found for allocation for groundvegetation cohort, rnum: ',real(rnum))
IF(rnum==-1) THEN
if (.not.flag_mult8910) CALL error_mess(time,'no solution found for allocation for groundvegetation cohort: ',real(p%coh%ident))
lambdaf=0.4
lambdar=0.4
lambdas=0.2
ELSE
lambdaf=(FRsum)/M_avail/2.
lambdar=(FRsum)/M_avail/2.
lambdas=1.-lambdaf-lambdar
ENDIF
ENDIF
END IF ! IF NPP < 1.0E-09
! gross growth rates of compartments
Gf = lambdaf * M_avail*kpatchsize -F +Sf
Gr = lambdar * M_avail*kpatchsize -R +Sr
Gs = lambdas * M_avail*kpatchsize -S +Ss
! preliminary solution for permanent seeding
IF(lambdaf * M_avail < 1.e-4) THEN
Gf = Gf + 1.e-4*kpatchsize
ENDIF
p%coh%gfol = Gf
p%coh%gfrt = Gr
p%coh%gsap = Gs
! update of state vector
FNew = F + Gf - Sf
SNew = S + Gs - Ss
RNew = R + Gr - Sr
p%coh%x_fol = FNew
p%coh%x_sap = SNew
p%coh%x_frt = RNew
! determine litter production from plant turnover rates
! first step nitrogen related processes: N in litter, N-recallocation
p%coh%N_pool = p%coh%N_pool + Sf/F*p%coh%N_fol*spar(ns)%reallo_fol &
+ Sr*cpart/spar(ns)%cnr_frt*1000.* spar(ns)%reallo_frt &
+ Ss*cpart *1000. * (1/spar(ns)%cnr_tbc - 1/spar(ns)%cnr_stem)
p%coh%N_fol = p%coh%N_fol*(1-Sf/F)
! Summation, due to the filling of the pool at other points as well
p%coh%litC_fol = p%coh%litC_fol + p%coh%ntreea * Sf * cpart
p%coh%litC_frt = p%coh%litC_frt + p%coh%ntreea * Sr * cpart
! New version with species specific N content and reallocation factor (see species.par)
! changed to 1-reallo
p%coh%litN_fol = p%coh%litN_fol + p%coh%ntreea * Sf * cpart * (1.-spar(ns)%reallo_fol) / spar(ns)%cnr_fol
p%coh%litN_frt = p%coh%litN_frt + p%coh%ntreea * Sr * cpart * (1.-spar(ns)%reallo_frt) / spar(ns)%cnr_frt
! second step: allocation of N to new growth
! before bud-break allocation to leaves is 50% of the N content of last years foliage
tbc_root_Ndemand = Gs*cpart *kg_in_g / spar(ns)%cnr_tbc + Gr* cpart/spar(ns)%cnr_frt*kg_in_g
IF(tbc_root_Ndemand + Gf*p%coh%med_sla*0.5 > p%coh%N_pool) THEN
if (tbc_root_Ndemand .gt. 1E-8) then
Nredfak = AMAX1((p%coh%N_pool-Gf*p%coh%med_sla*0.5) / tbc_root_Ndemand,0.) ! Div. by zero possible !
else
Nredfak = 0.
endif
tbc_root_Ndemand = tbc_root_Ndemand*Nredfak
ENDIF
p%coh%N_pool = p%coh%N_pool - tbc_root_Ndemand
END SUBROUTINE PARTITION_SV
!*******************************!
!* SUBROUTINE PARTITION_MI *!
!*******************************!
SUBROUTINE PARTITION_MI( p )
!*** Declaration part ***!
USE data_par
USE data_stand
USE data_simul
IMPLICIT NONE
TYPE(Coh_Obj) :: p ! pointer to cohort list
!no partitioning, foliage mass keeps constant
p%coh%x_fol = p%coh%x_fol ! !FNew
p%coh%x_sap = 0.!SNew
p%coh%x_frt = 0.!RNew
END SUBROUTINE PARTITION_MI
!***************************!
! FUNCTION f_lf *!
!***************************!
REAL FUNCTION f_lf(x)
USE data_stand
USE data_plant
REAL :: x
f_lf = ksi*x**kappa + x - M_avail
END ! FUNCTION f_lf
!***************************!
! FUNCTION df_lf *!
!***************************!
REAL FUNCTION df_lf(x)
USE data_stand
USE data_plant
REAL :: x
df_lf = ksi*kappa*x**(kappa-1.) + 1.
END ! FUNCTION df_lf
!***************************!
! FUNCTION ddf_lf *!
!***************************!
REAL FUNCTION ddf_lf(x)
USE data_stand
USE data_plant
REAL :: x
ddf_lf = ksi*kappa*(kappa-1.)*x**(kappa-2.)
END ! FUNCTION ddf_lf
!***************************!
! SUBROUTINE CALC_DBH *!
!***************************!
SUBROUTINE CALC_DBH(B, Ht, S, H, Ahb, Ahc, ident, dbh, dc, hs, Asw)
!*** Declaration part ***!
USE data_par
USE data_species
USE data_simul
IMPLICIT NONE
INTEGER :: ident
REAL :: Dc ! diameter at crown base
REAL :: B, & ! bole height,
Ht, & ! total tree height
S, & ! sapwood
H, & ! heartwood
hs, & ! sapwood height
D, & ! stem diameter at forest floor
DBH, & ! tree diameter at breast height
Ahb, & ! cross sectional area heartwood at tree base
Ahc, & ! cross sectional area of heartwood at crown base
Asw, & ! cross sectional area of sapwood in bole
discr, func, help, hp1, hp2,hp3, hp4
REAL :: fp, fq, & ! coefficients of quadratic equation
w1, w2, & ! solutions of quadratic equation
precision ! criterion for acceptance of solution
real :: sprhos ! sapwood density [kg/cm3]
!*** Calculation part ***!
precision = 1.e-5
sprhos = spar(ns)%prhos
! calculate Diameters
hs = (2*B +Ht)/3.
Asw = S/(spar(ns)%prhos*hs)
! if Bole height >= height trees are dead and calculations not required
IF(B .lt. Ht) THEN
select case (flag_volfunc)
case (0)
D = SQRT( (S+H)*4. / (sprhos*hs*pi) )
IF (Ht<h_breast) THEN
DBH = 0.0
ELSEIF (Ht>h_breast.and.B<h_breast) then
DBH=D-(D/(Ht-B))*(h_breast-B)
ELSE
DBH=D
ENDIF
case (1)
D = SQRT((Ahb+Asw)*4./pi)
! if Bole height = 0 then there is no need to calulate Diameter at crown base and Dc = D
IF(B.EQ.0.) THEN
Dc = D
ELSE
fp = -2. * (B/Ht) * (3.*H/(sprhos*B)-Ahb)-Ahb*(B/Ht)**2.
fp = -2. * B/Ht * (3.*H/(sprhos*B)-Ahb)-Ahb*(B/Ht)**2.
fq = ((3.*H/(sprhos) - Ahb*B) / Ht)**2.
discr = fp**2./4.-fq
if (abs(discr) .lt. zero) then
discr = zero ! avoid small values
endif
! No solution
if(discr.lt.0) then
if (.not.flag_mult8910) then
CALL error_mess(time,'discriminant < 0 in calc_dbh for cohort: ',real(ident))
CALL stop_mess(time,'discriminant < 0 in calc_dbh ')
CALL error_mess(time,'stop in calc_dbh for stand No: ',real(ip))
CALL error_mess(time,'heart wood mass H: ',H)
CALL error_mess(time,'bole height b: ',b)
CALL error_mess(time,'height Ht: ',Ht)
CALL error_mess(time,'ave. sapwood height hs: ',hs)
CALL error_mess(time,'sapwood area Asw: ',Asw)
CALL error_mess(time,'heartwood area at stem base Ahb: ',Ahb)
endif
flag_end = 1
return
end if
discr = SQRT(discr)
w1 = -fp/2. + discr
w2 = -fp/2. - discr
1313 hp1 = SQRT(w1*Ahb)
hp2 = (Ahb+SQRT(w1*Ahb))*B
hp3 = (w1*Ht + (Ahb+SQRT(w1*Ahb))*B)
help = (sprhos/3.) * (w1*Ht + (Ahb+SQRT(w1*Ahb))*B)
func = (sprhos/3.) * (w1*Ht + (Ahb+SQRT(w1*Ahb))*B) - H
hp4= H* precision
IF(abs(func) <= H * precision) THEN
Ahc = w1
if (.not.flag_mult8910) then
CALL error_mess(time,' positive root is a solution in calc_dbh for cohort: ',real(ident))
CALL error_mess(time,'stop in calc_dbh for stand No: ',real(ip))
CALL error_mess(time,'function: ',func)
endif
flag_end = 1
return
ELSE
func = (sprhos/3.) * (w2*Ht + (Ahb+SQRT(w2*Ahb))*B) - H
IF(abs(func) <= H * precision) THEN
Ahc = w2
ELSE
IF(precision.LT.1e-2) THEN
precision = precision*10.
GOTO 1313
if (.not.flag_mult8910) then
CALL error_mess(time,'no valid solution found in calc_dbh for heartwood geometry for cohort: ',real(ident))
CALL error_mess(time,': heart wood mass, H = ',H)
CALL error_mess(time,': precision requirement = ',precision)
CALL error_mess(time,'iteration in stand No: ',real(ip))
endif
ELSE
if (.not.flag_mult8910) then
CALL error_mess(time,'no valid solution found in calc_dbh for heartwood geometry for cohort: ',real(ident))
CALL stop_mess(time,'no valid solution found in calc_dbh for heartwood geometry')
CALL error_mess(time,'species No: ',real(ns))
CALL error_mess(time,'stop in calc_dbh for stand No: ',real(ip))
CALL error_mess(time,'precision requirement H*precision ',H*precision)
CALL error_mess(time,'heart wood mass H: ',H)
CALL error_mess(time,'bole height b: ',b)
CALL error_mess(time,'height Ht: ',Ht)
CALL error_mess(time,'ave. sapwood height hs: ',hs)
CALL error_mess(time,'sapwood area Asw: ',Asw)
CALL error_mess(time,'heartwood area at stem base Ahb: ',Ahb)
endif
flag_end = 1
return
ENDIF
ENDIF
ENDIF
Dc = SQRT((Ahc+Asw)*4./pi)
END IF
if (Ht<=h_breast) then
DBH = 0.0
else if (Ht>h_breast.and.B<h_breast) then
DBH=Dc*(Ht-h_breast)/(Ht-B)
else
DBH=D-(D-Dc)*h_breast/B
end if
end select
ELSE
if (.not.flag_mult8910) then
CALL error_mess(time,'no calculation of heartwood geometry for cohort (Bole height >= height trees are dead): ',real(ident))
CALL error_mess(time,'bole height: ',b)
CALL error_mess(time,'height: ',Ht)
endif
END IF ! if B > Ht
END SUBROUTINE CALC_DBH
source_code/version_2.3_windows/pheno.f 0 → 100644
View file @ 82df1085
!*****************************************************************!
!* *!
!* 4C Simulation Model *!
!* *!
!* *!
!* Subroutines for: *!
!* Simulation of processes at subannual resolution *!
!* *!
!* Contains subroutines: *!
!* *!
!* - pheno_ini *!
!* - pheno_begin *!
!* - pheno_count *!
!* - pheno_shed *!
!* *!
!* functions: *!
!* triangle *!
!* *!
!* 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 pheno_ini
USE data_climate
USE data_simul
USE data_site
USE data_species
USE data_stand
IMPLICIT NONE
integer i, j
integer leapyear
real atemp, hh, htemp
real triangle
real, external :: daylength
leaves_on = .false.
all_leaves_on = 0
phen_flag=1 ! CANOPY is calculated once at the beginning of each year
! Initialising of all species is done at the beginning, since if species information wouldnt be initialised
IF(time==1) THEN
do i=1,nspec_tree
ns = i
IF(spar(ns)%Phmodel==1) THEN
svar(ns)%Pro = 0.
svar(ns)%Inh = 1.
ELSE
svar(ns)%Pro = 0.
svar(ns)%Inh = 0.
svar(ns)%Tcrit = 0.
END IF
! initialize pheno state variables with climate from the actual year
do j = spar(ns)%end_bb+1, 365
atemp = tp(j, 1)
hh = DAYLENGTH(j,lat)
SELECT CASE(ns)
CASE(1,8)
!Fagus
! Promotor-Inhibitor model 11
svar(ns)%Pro = svar(ns)%Pro + spar(ns)%PPa* &
triangle(spar(ns)%PPtmin,spar(ns)%PPtopt,spar(ns)%PPtmax,atemp)* &
(1-svar(ns)%Inh)*hh/24 - &
spar(ns)%PPb*svar(ns)%Pro*(24-hh)/24
svar(ns)%Inh = svar(ns)%Inh - spar(ns)%PIa* &
triangle(spar(ns)%PItmin,spar(ns)%PItopt,spar(ns)%PItmax,atemp)* &
svar(ns)%Inh*hh/24
CASE(4)
! Quercus
! Promotor-Inhibitor model 12
htemp = triangle(spar(ns)%PPtmin,spar(ns)%PPtopt,spar(ns)%PPtmax,atemp)
svar(ns)%Pro = svar(ns)%Pro + spar(ns)%PPa * htemp * &
(1-svar(ns)%Inh) * hh/24
htemp = triangle(spar(ns)%PItmin,spar(ns)%PItopt,spar(ns)%PItmax,atemp)
svar(ns)%Inh = svar(ns)%Inh - spar(ns)%PIa * htemp * &
svar(ns)%Inh * hh/24 + spar(ns)%PPb*(24-hh)/24
CASE(5, 11)
! Betula, Robinia
IF(spar(ns)%Phmodel==1) THEN
! Promotor-Inhibitor model 2
svar(ns)%Pro = svar(ns)%Pro + spar(ns)%PPa* &
triangle(spar(ns)%PPtmin,spar(ns)%PPtopt,spar(ns)%PPtmax,atemp)* &
(1-svar(ns)%Inh) - spar(ns)%PPb*svar(ns)%Pro*(24-hh)/24
svar(ns)%Inh = svar(ns)%Inh - spar(ns)%PIa* &
triangle(spar(ns)%PItmin,spar(ns)%PItopt,spar(ns)%PItmax,atemp)*svar(ns)%Inh
END IF
END SELECT
enddo ! j
Enddo ! nspec_tree
END IF
! latest day of bud burst 30. of June (DOY 181+leapyear(time_cur))
do i=1, anrspec
ns = nrspec(i)
if(ns.le.nspec_tree) then
IF(spar(ns)%phmodel==4) THEN
svar(ns)%daybb = svar(ns)%ext_daybb
ELSE
svar(ns)%daybb = 181 + leapyear(time_cur)
ENDIF
end if
END DO ! anrspec
end SUBROUTINE pheno_ini
!*******************************************************************
SUBROUTINE pheno_begin
! calculation of day_bb, latest day of bud burst 30. june (DOY 181)
USE data_simul
USE data_species
USE data_stand
USE data_climate
USE data_site
IMPLICIT NONE
REAL triangle
INTEGER leapyear
real hh, htemp
integer i
hh = dlength
do i=1, anrspec
ns = nrspec(i)
if (iday .ge.364) then
continue
endif
if(ns.le.nspec_tree .OR. ns.eq.nspec_tree+2) then !either tree or mistletoe
! Pheno model
select Case (spar(ns)%Phmodel)
Case(0) ! no model
!Picea, Pinus, Mistletoe
IF(iday.EQ.1) THEN
svar(ns)%daybb = iday
phen_flag = 1
leaves_on = .TRUE.
ENDIF
Case(1)
! Phenology starts after leaf coloring/shedding and ends not later than 30. June
IF (iday > spar(ns)%end_bb+1 .OR. iday <= svar(ns)%daybb) THEN
SELECT CASE(ns)
CASE(1,8)
!Fagus
! Promotor-Inhibitor model 11
htemp = triangle(spar(ns)%PPtmin,spar(ns)%PPtopt,spar(ns)%PPtmax,airtemp)
svar(ns)%Pro = svar(ns)%Pro + spar(ns)%PPa * htemp * &
(1-svar(ns)%Inh) * dlength/24 - &
spar(ns)%PPb*svar(ns)%Pro * (24-dlength)/24
svar(ns)%Inh = svar(ns)%Inh - spar(ns)%PIa*&
triangle(spar(ns)%PItmin,spar(ns)%PItopt,spar(ns)%PItmax,airtemp)*&
svar(ns)%Inh*dlength/24
IF (svar(ns)%Pro >= 1) THEN
svar(ns)%daybb=iday
phen_flag = 1
leaves_on=.TRUE.
ELSE IF (svar(ns)%Pro < 1 .AND. iday==svar(ns)%daybb) THEN
phen_flag = 1
leaves_on=.TRUE.
END IF
CASE(4)
! Quercus
! Promotor-Inhibitor model 12
all_leaves_on=0
if (svar(ns)%Inh .gt. 1.) then
continue
svar(ns)%Inh = 1.
endif
if (svar(ns)%Pro .lt. 0.) then
continue
svar(ns)%Pro = 0.
endif
htemp = triangle(spar(ns)%PPtmin,spar(ns)%PPtopt,spar(ns)%PPtmax,airtemp)
svar(ns)%Pro = svar(ns)%Pro + spar(ns)%PPa * htemp * &
(1-svar(ns)%Inh) * dlength/24
htemp = triangle(spar(ns)%PItmin,spar(ns)%PItopt,spar(ns)%PItmax,airtemp)
svar(ns)%Inh = svar(ns)%Inh - spar(ns)%PIa * htemp * &
svar(ns)%Inh * dlength/24 + spar(ns)%PPb*(24-dlength)/24
IF (svar(ns)%Pro >= 1) THEN
svar(ns)%daybb=iday
phen_flag = 1
leaves_on=.TRUE.
ELSE IF (svar(ns)%Pro < 1 .AND. iday==svar(ns)%daybb) THEN
phen_flag = 1
leaves_on=.TRUE.
END IF
CASE(5, 11)
! Betula, Robinia
all_leaves_on=0
IF(spar(ns)%Phmodel==1) THEN
! Promotor-Inhibitor model 2
svar(ns)%Pro = svar(ns)%Pro + spar(ns)%PPa* &
triangle(spar(ns)%PPtmin,spar(ns)%PPtopt,spar(ns)%PPtmax,airtemp)* &
(1-svar(ns)%Inh) - spar(ns)%PPb*svar(ns)%Pro*(24-dlength)/24
svar(ns)%Inh = svar(ns)%Inh - spar(ns)%PIa* &
triangle(spar(ns)%PItmin,spar(ns)%PItopt,spar(ns)%PItmax,airtemp)*svar(ns)%Inh
IF (svar(ns)%Pro >= 1) THEN
svar(ns)%daybb=iday
phen_flag = 1
leaves_on=.TRUE.
ELSE IF (svar(ns)%Pro < 1 .AND. iday==svar(ns)%daybb) THEN
phen_flag = 1
leaves_on=.TRUE.
END IF
END IF
END SELECT
Endif
Case(2)
! Cannel-Smith model
IF(iday >= 305 + leapyear(time_cur) .OR. iday <= svar(ns)%daybb) THEN
IF(airtemp < spar(ns)%CSTbC) THEN
svar(ns)%Inh = svar(ns)%Inh + 1
svar(ns)%Tcrit = spar(ns)%CSa + spar(ns)%CSb*LOG(svar(ns)%Inh)
END IF
IF(airtemp > spar(ns)%CSTbT .AND. iday >= 32 .AND. iday <= svar(ns)%daybb) THEN
svar(ns)%Pro = svar(ns)%Pro + airtemp - spar(ns)%CSTbT;
END IF
IF(svar(ns)%Pro > svar(ns)%Tcrit) THEN
svar(ns)%daybb=iday
phen_flag = 1
leaves_on=.TRUE.
ELSE IF (svar(ns)%Pro < svar(ns)%Tcrit .AND. iday==svar(ns)%daybb) THEN
phen_flag = 1
leaves_on=.TRUE.
END IF
END IF
Case(3)
! Temperature sum model
SELECT CASE(ns)
CASE(11)
! Robinia
IF(iday >= spar(ns)%Lstart .AND. iday <= svar(ns)%daybb) THEN
IF(airtemp > spar(ns)%LTbT) THEN
svar(ns)%Pro = svar(ns)%Pro + airtemp
END IF
IF(svar(ns)%Pro > spar(ns)%LTcrit) THEN
svar(ns)%daybb=iday
phen_flag = 1
leaves_on=.TRUE.
ELSE IF (svar(ns)%Pro < spar(ns)%LTcrit .AND. iday==svar(ns)%daybb) THEN
phen_flag = 1
leaves_on=.TRUE.
END IF
END IF
CASE default
IF(iday >= spar(ns)%Lstart .AND. iday <= svar(ns)%daybb) THEN
IF(airtemp > spar(ns)%LTbT) THEN
svar(ns)%Pro = svar(ns)%Pro + airtemp - spar(ns)%LTbT
END IF
IF(svar(ns)%Pro > spar(ns)%LTcrit) THEN
svar(ns)%daybb=iday
phen_flag = 1
leaves_on=.TRUE.
ELSE IF (svar(ns)%Pro < spar(ns)%LTcrit .AND. iday==svar(ns)%daybb) THEN
phen_flag = 1
leaves_on=.TRUE.
END IF
END IF
END SELECT
Case(4)
! externally prescribed day of budburst
IF(iday==svar(ns)%daybb) THEN
phen_flag = 1
leaves_on=.TRUE.
END IF
Case default
IF(iday.EQ.1) THEN
svar(ns)%daybb=iday
phen_flag=1
leaves_on=.TRUE.
ENDIF
end select
else if(iday==svar(ns)%daybb) then
phen_flag = 1
leaves_on=.TRUE.
end if
END DO
zeig=>pt%first
do while (associated(zeig))
ns = zeig%coh%species
zeig%coh%day_bb = svar(ns)%daybb
zeig=>zeig%next
enddo
END SUBROUTINE pheno_begin
!*******************************************************************
SUBROUTINE pheno_count
USE data_simul
USE data_species
USE data_stand
IMPLICIT NONE
zeig=>pt%first
DO
if(.not. associated(zeig)) exit
! vegetation period per PS-time step and per season
IF((iday >= zeig%coh%day_bb) .AND. (iday <= spar(zeig%coh%species)%end_bb)) THEN
zeig%coh%nDaysPS = zeig%coh%nDaysPS + 1. ! set to 0 in npp
zeig%coh%nDaysGr = zeig%coh%nDaysGr + 1. ! set to 0 year_ini
END IF
zeig=>zeig%next
END DO
END SUBROUTINE pheno_count
!*******************************************************************
SUBROUTINE pheno_shed
USE data_simul
USE data_species
USE data_stand
IMPLICIT NONE
integer i
leaves_on=.FALSE.
all_leaves_on=1
DO i=1, anrspec
ns = nrspec(i)
IF(iday == spar(ns)%end_bb +1) THEN
phen_flag=1
all_leaves_on=0
! reset pheno state variable
IF(spar(ns)%Phmodel==1) THEN
svar(ns)%Pro = 0.
svar(ns)%Inh = 1.
ELSE
svar(ns)%Pro = 0.
svar(ns)%Inh = 0.
svar(ns)%Tcrit = 0.
END IF
ELSE IF((iday < svar(ns)%daybb) .OR. (iday > spar(ns)%end_bb)) THEN
all_leaves_on=0
ELSE IF((iday >= svar(ns)%daybb) .AND. (iday <= spar(ns)%end_bb)) THEN
leaves_on=.TRUE.
END IF
END DO
END SUBROUTINE pheno_shed
!*******************************************************************
FUNCTION triangle(min,opt,max,x)
REAL :: min,opt,max,x,triangle
IF( min <= x .AND. x <= opt) THEN
triangle = (x - min)/(opt - min)
ELSE IF( opt < x .AND. x <= max) THEN
triangle = (max - x)/(max - opt)
ELSE
triangle = 0
END IF
END FUNCTION triangle
FUNCTION leapyear(year)
INTEGER :: year,leapyear
IF( MOD(year,400)==0 .OR. ( MOD(year,100)/=0 .AND. MOD(year,4)==0 )) THEN
leapyear = 1
ELSE
leapyear = 0
END IF
END FUNCTION leapyear
source_code/version_2.3_windows/pik400x.bmp 0 → 100644
View file @ 82df1085
source_code/version_2.3_windows/pik400x.bmp

75.1 KiB