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 8531 additions and 0 deletions
source_code/version_2.3_windows/amod_out.f 0 → 100644
View file @ 82df1085
!*****************************************************************!
!* *!
!* 4C (FORESEE) Simulation Model *!
!* *!
!* *!
!* data module for various output files (Header ,...) *!
!* *!
!* 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 *!
!* *!
!*****************************************************************!
module data_out
! definition of output form each output type (kind_name) with 4 DATA statements
! character strings with more than 1 row must be separated only by &
! Attention! Blanks are normally significant, but problematic:
! at the beginning of the row only one blank is significant
!
! Recipe for new output files:
! add 1 to the dimension field "(type (out_struct),dimension(x+1),target :: out??)"
! a n d to the number of files "out??_n"+1
! add the specifier of output file to DATA kind_name
! add the comments on first and second line to the respective DATA statements
! add the column header to DATA header (pay attention to the above remarks regarding blanks!)
! add the write statements to the case construct with the kind_name (in output.f)
! depending on the output structure special open statements might have to be added
! in OLD_OUT in output.f
! data structure of skalar and field output
type out_struct
character (10) :: kind_name ! specifies the kind and the name of the output file
integer :: unit_nr ! output unit, set in output.f
integer :: out_flag ! output flag
character (200) :: f_line ! first comment line
character (500) :: s_line ! second comment line
character (900) :: header ! header of output columns
end type out_struct
! daily output of scalars and fields
type (out_struct),dimension(24),target :: outd ! daily output files
integer :: outd_n = 24 ! number of all declared daily output files
DATA outd%kind_name /'Cday','Chumd','Copmd','Copmfractd','Cbcd', 'day', 'day_short','NH4','NH4c','NO3','NO3c','Nhumd','Nopmd', &
'NOPMfract', 'Nuptd', 'Nmind', 'perc', 'specd', 'temp', 'wat_potent', 'wat_res', 'water', 'watvol', 'wupt'/
DATA outd%f_line /'# Daily C balance', & ! Cday
'# C content of humus (hum) per layer', & ! Chumd
'# C content of organic primary matter (OPM) per layer', & ! Copmd
'# C content of organic primary matter (OPM) fractions', & ! Copmfractd
'# C content of biochar per layer', & ! Cbcd
'# Daily output', & ! day
'# Short daily output', & ! day_short
'# NH4 content per layer', & ! NH4
'# NH4 concentration per layer', & ! NH4c
'# NO3 content per layer', & ! NO3
'# NO3 concentration per layer', & ! NO3c
'# N content of humus (hum) per layer', & ! Nhumd
'# N content of organic primary matter (OPM) per layer', & ! Nopmd
'# N content of organic primary matter (OPM) fractions', & ! NOPMfract
'# Daily nitrogen uptake by roots per layer Nupt', & ! Nuptd
'# Daily nitrogen mineralisation per layer Nmin', & ! Nmind
'# Daily percolation of water per layer perc', & ! perc
'# Daily species variables svar', & ! specd
'# Daily soil temperature per layer temps', & ! temp
'# Daily soil water potential per layer wat_potential',& ! wat_potent
'# Daily water uptake resistance per layer wat_res', & ! wat_res
'# Daily soil water content per layer wats', & ! water
'# Daily soil water content per layer watvol', & ! watvol
'# Daily water uptake by roots per layer wupt_r'/ ! wupt
DATA outd%s_line / &
'# gC/m2 gC/m2 gC/m2 gC/m2 gC/m2 gC/m2 gC/m2 gC/m2 gC/m2 gC/m2&
& gC/m2 gC/m2 gC/m2 %' , & ! Cday
'# gC_m2', & ! Chumd
'# gC_m2', & ! Copmd
'# gC/m2',& ! Copmfractd
'# gC_m2', & ! Cbcd
'# Grad C J/cm2 mm mm mm mm mm mm mm mm&
& mol/m2 gC/m2 gN/m2 gN/m2 gN/m2 gN/m2 mgN/m2 &
& mm mm C&
J/cm2 J/cm2', & ! day
'# - mm', & ! day_short
'# gN/m2', & ! NH4
'# mgN/l', & ! NH4c
'# gN/m2', & ! NO3
'# mgN/l', & ! NO3c
'# gN/m2', & ! Nhumd
'# gN/m2', & ! Nopmd
'# gN/m2 |------------- Fagus sylvatica ----------------|--------------- Picea abies -----------------|&
&------------ Pinus sylvestris ----------------|--------------- Quercus robur ----------------|&
&------------- Betula pendula -----------------|-------------- Pinus contorta ---------------|&
&------------- Pinus ponderosa -----------------|-------------- Populus tremula ---------------|&
&------------- Bodenvegetation ----------------|', & ! NOPMfract
'# gN/m2', & ! Nuptd
'# gN/m2', & ! Nmind
'# mm/day', & ! perc
'# ', & ! specd
'# C', & ! temp
'# hPa', & ! wat_potent
'# ', & ! wat_res
'# mm', & ! water
'# vol%', & ! watvol
'# mm/day'/ ! wupt
DATA outd%header / &
'# Day Year gross_Phot gross_Ass net_Ass pot_NPP NPP NPP_day GPP_day NEE &
& TER_day autresp Resp_aut Resp_het Resp_fol FaPar',& ! Cday
'# Day Year Chum_1 Chum_2 Chum_3 Chum_4 Chum_5 Chum_6 ....',& ! Chumd
'# Day Year Copm_1 Copm_2 Copm_3 Copm_4 Copm_5 Copm_6 ....',& ! Copmd
'# Day Year species C_opm_fol C_opm_tb C_opm_frt C_opm_crt C_opm_stm species C_opm_fol C_opm_tb C_opm_frt C_opm_crt C_opm_stm &
& ....',& ! Copmfractd
'# Day Year Cbc_1 Cbc_2 Cbc_3 Cbc_4 Cbc_5 Cbc_6 ....',& ! Cbcd
'# Day Year Temp Rad Prec Intercep Snow PET AET Transdem Transtree Transsveg&
& GP_can Resp_het Nleach_d Nupt_d Nmin_d_c N_antot N_Depo Cover&
& LAI s_Light toFPARcan fire_indi fire_e fire_w fire_n snowday drIndd&
& buckroot buck100 cl_WatBal dewp.temp dew/rime Rnet_tot Rad_max',& ! day
'# Date fire_e cl_WatBal',& ! day_short
'# Day Year NH4_1 NH4_2 NH4_3 NH4_4 NH4_5 NH4_6 ....',& ! NH4
'# Day Year NH4_1 NH4_2 NH4_3 NH4_4 NH4_5 NH4_6 ....',& ! NH4c
'# Day Year NO3_1 NO3_2 NO3_3 NO3_4 NO3_5 NO3_6 ....',& ! NO3
'# Day Year NO3_1 NO3_2 NO3_3 NO3_4 NO3_5 NO3_6 ....',& ! NO3c
'# Day Year Nhum_1 Nhum_2 Nhum_3 Nhum_4 Nhum_5 Nhum_6 ....',& ! Nhumd
'# Day Year Nopm_1 Nopm_2 Nopm_3 Nopm_4 Nopm_5 Nopm_6 ....',& ! Nopmd
'# Day Year N_opm_fol N_opm_tb N_opm_frt N_opm_crt N_opm_stm N_opm_fol N_opm_tb N_opm_frt N_opm_crt N_opm_stm &
& N_opm_fol N_opm_tb N_opm_frt N_opm_crt N_opm_stm N_opm_fol N_opm_tb N_opm_frt N_opm_crt N_opm_stm &
& N_opm_fol N_opm_tb N_opm_frt N_opm_crt N_opm_stm N_opm_fol N_opm_tb N_opm_frt N_opm_crt N_opm_stm &
& N_opm_fol N_opm_tb N_opm_frt N_opm_crt N_opm_stm ',& ! NOPMfract
'# Day Year Nupt_1 Nupt_2 Nupt_3 Nupt_4 Nupt_5 Nupt_6 ....',& ! Nuptd
'# Day Year Nmin_1 Nmin_2 Nmin_3 Nmin_4 Nmin_5 Nmin_6 ....',& ! Nmind
'# Day Year Percol_1 Percol_2 Percol_3 Percol_4 Percol_5 Percol_6 ....',& ! perc
'# Day Year species_name number Ndem Nupt Ndemp Nuptp RedN ',& ! specd
'# Day Year Temp_surf Temps_1 Temps_2 Temps_3 Temps_4 Temps_5 Temps_6 ....',& ! temp
'# Day Year Pot_1 Pot_2 Pot_3 Pot_4 Pot_5 Pot_6 ....',& ! wat_potent
'# Day Year Wat_res_1 Wat_res_2 Wat_res_3 Wat_res_4 Wat_res_5 Wat_res_6 ....',& ! wat_res
'# Day Year Wats_1 Wats_2 Wats_3 Wats_4 Wats_5 Wats_6 ....',& ! water
'# Day Year Wats_1 Wats_2 Wats_3 Wats_4 Wats_5 Wats_6 ....',& ! watvol
'# Day Year Wupt_r_1 Wupt_r_2 Wupt_r_3 Wupt_r_4 Wupt_r_5 Wupt_r_6 ....'/ ! wupt
! ----------------------------------------------------- !
! yearly output of scalars and fields
type (out_struct),dimension(58),target :: outy ! yearly output files
integer :: outy_n = 58 ! number of all declared yearly output files
DATA outy%kind_name /'AET_mon','c_bal','Cbc','Chum','Copm','Copmfract','classd','classage','classmvol','classd_h','classdm', 'classdm_h',&
'classh', 'classt', 'clim', 'clim_temp', 'clim_prec', 'clim_rad', 'clim_hum', &
'fcap_av','fcapv_av', 'fr_loss','GPP_mon', 'humusv', 'indi', &
'litter','Nbc','Nhum','Nopm','NEE_mon','NPP_mon','manrec', 'mansort', 'redis', 'root', 'sdrought',&
'soil', 'spec', 'standsort','TER_mon','veg', 'veg_in', 'veg_out', &
'veg_be','veg_bi','veg_pi', 'veg_pc', 'veg_pp', 'veg_pt', &
'veg_oa','veg_sp','veg_ph', 'veg_dg', 'veg_rb', 'veg_egl', 'veg_egr','veg_sveg','veg_mist'/
DATA outy%f_line /'# Monthly sum of actual evapotranspiration (AET)', & ! AET_mon
'# Yearly C-Balance, C-stocks and -fluxes; C_sumvsab is part of C_biomass', & ! c_bal
'# C content of biochar (C_bc) per layer', & ! Cbc
'# C content of humus (hum) per layer', & ! Chum
'# C content of organic primary matter (OPM) per layer', & ! Copm
'# C content of organic primary matter (OPM) fractions', & ! Copmfract
'#', & ! classd
'#', & ! classage
'#', & ! classmvol
'#', & ! classd_h
'#', & ! classdm
'#', & ! classdm_h
'#', & ! classh
'#', & ! classt
'# Climate data', & ! clim
'# Air temperature: monthly climate data', & ! clim_temp
'# Precipitation: monthly climate data', & ! clim_prec
'# Radiation: monthly climate data', & ! clim_rad
'# Relative humidity: monthly climate data', & ! clim_hum
'# Available field capacity per layer', & ! fcap_av
'# Available field capacity per layer', & ! fcapv_av
'# Percentage fine root C-loss per soil layer', & ! fr_loss
'# Monthly GPP of all cohorts and species', & ! GPP_mon
'# Content of humus per layer', & ! humusv
'# Indices of fire and biodiversity', & ! indi
'# Yearly litter fractions', & ! litter
'# N content of biochar (N_bc) per layer', & ! Nbc
'# N content of humus (hum) per layer', & ! Nhum
'# N content of organic primary matter (OPM) per layer', & ! Nopm
'# Monthly NEE of all cohorts and species', & ! NEE_mon
'# Monthly NPP of all cohorts and species', & ! NPP_mon
'# Management record', & ! manrec
'# Management sortiment',& ! mansort
'# Redistribution of root C (redis)', & ! redis
'# Root distribution (root_fr)', & ! root
'# Data from soil model', & ! sdrought
'# Data from soil model', & ! soil
'# Species number and name', & ! spec
'# sortiment of whole stand (without harvested trees)',& ! standsort
'# Monthly TER of all cohorts and species', & ! TER_mon
'# Values for the whole stand (per ha); see files veg_in, veg_out in addition', & ! veg
'# New trees (by planting or regeneration), values for the whole stand (per ha)', & ! veg_in
'# Removed trees (by mortality or management) with number of cohorts from which trees are removed (per ha)', & ! veg_out
'# Values for the whole stand (per ha) for beech', & ! veg_be
'# Values for the whole stand (per ha) for birch', & ! veg_bi
'# Values for the whole stand (per ha) for pinus sylvestris', & ! veg_pi
'# Values for the whole stand (per ha) for pinus contorta', & ! veg_pc
'# Values for the whole stand (per ha) for pinus ponderosa', & ! veg_pp
'# Values for the whole stand (per ha) for populus tremula', & ! veg_pt
'# Values for the whole stand (per ha) for oak', & ! veg_oa
'# Values for the whole stand (per ha) for spruce', & ! veg_sp
'# Values for the whole stand (per ha) for pinus halepensis', & ! veg_ph
'# Values for the whole stand (per ha) for douglas fir', & ! veg_dg
'# Values for the whole stand (per ha) for black locust', & ! veg_rb
'# Values for the whole stand (per ha) for E.globulus', & ! veg_egl
'# Values for the whole stand (per ha) for E.grandis', & ! veg_egr
'# Values for the whole stand (per ha) for ground vegetation', & ! veg_sveg
'# Values for the whole stand (per ha) for mistletoe (Visc. a.)'/! veg_mist
DATA outy%s_line / &
'# mm', & ! AET_mon
'# kg/ha kg/ha kg/ha kg/ha kg/ha kg/ha kg/ha kg/ha&
& kg/ha kg/ha t/ha t/ha t/ha t/ha t/ha t/ha t/ha t/ha t/ha&
& mol/m2 mol/m2 mol/m2 mol/m2 mol/m2 mol/m2 mol/m2 mol/m2&
& mol/m2 mol/m2 mol/m2 kg/ha', & ! c_bal
'# gC/m2', & ! Cbc
'# gC/m2', & ! Chum
'# gC/m2', & ! Copm
'# gC/m2', & ! Copmfract
'# diam_class: Number of trees (per ha) in diameter classes, step 5 cm', & ! classd
'# diam_class: Mean age of trees (per ha) in diamter classes, step 5 cm', & ! classage
'# diam_class: Mean volume (m/ha) of harvested trees in diamter classes, step 5 cm', & ! classmvol
'# diam_class: Mean height of trees in diameter classes, step 5 cm', & ! classd_h
'# diam_class: Number of harvested trees (per ha) in diameter classes, step 5 cm', & ! classdm
'# diam_class: Mean height of trees in diameter classes, step 5 cm', & ! classdm_h
'# height_class: Number of trees in height classes, bis 1,5,6,7,...,50,55,>55m', & ! classh
'# diam_class: Number of dead trees (per ha) in diameter classes, step 5 cm', & ! classt
'# C mm J/cm2 m/s ppm C', & ! clim
'# C ... ', & ! clim_temp
'# mm ... ', & ! clim_prec
'# J/cm2 ... ', & ! clim_rad
'# % ... ', & ! clim_hum
'# mm', & ! fcap_av
'# %', & ! fcapv_av
'# yearly mean fine root C-loss', & ! fr_loss
'# gC/m2', & ! GPP_mon
'# %', & ! humusv
'# fire index |------------ fire index west ------------|&
&|----------------------- fire index east -----------------------|&
&|------- fire index Nesterov -------|', & ! indi
'# |-------------------------------- Dry mass kg DW/ha_yr ---------------------------------|&
& |----------------- Carbon content kg C/ha_yr -------------------|&
& |----------------- Nitrogen content kg N/ha_yr -----------------|', & ! litter
!& % % % % ', & ! litter
'# gN/m2', & ! Nbc
'# gN/m2', & ! Nhum
'# gN/m2', & ! Nopm
'# gC/m2', & ! NEE_mon
'# gC/m2', & ! NPP_mon
' ', & ! manrec
' cm cm cm cm cm m/ha kg C/ha ', & ! mansort
'# relative share of redistributed C per layer (whole stand) ', & ! redis
'# relative share of root mass per layer (whole stand) ', & ! root
'# s_drought: Number of days with water content near wilting point (drought days) per layer', & ! sdrought
'# Grad_C mm mm mm mm mm mm mm mm mm mm mol_m2 gN_m2&
& gN_m2 gC_m2 gN_m2 gN_m2 gC_m2 gN_m2 gC_m2 gN_m2 gC_m2 gC_m2 gC_m2 gC_m2 gC_m2 gC_m2&
& gN_m2 gN_m2 gN_m2 gC_m2 mm mm cm mm J/cm2 gN_m2 gC_m2 gC_m2',& ! soil
'#', & ! spec
' cm cm cm cm cm m/ha kg C/ha ', & ! standsort
'# gC/m2', & ! TER_mon
'# /ha m2_m2 kg_DW/ha kg_DW_yr/ha cm cm&
& kg_DW/ha kg_DW/ha kg_DW/ha kg_DW/ha kg_DW/ha m3/ha kg_DW/ha kg_DW/ha m2_m2&
& gN/m2 mol/m2 mol/m2 mol/m2 cm cm m m/ha m/ha', & ! veg
2*'# /ha m2_m2 kg_DW/ha cm cm&
& kg_DW/ha kg_DW/ha kg_DW/ha kg_DW/ha kg_DW/ha m3/ha kg_DW/ha kg_DW/ha m2_m2&
& gN/m2 mol/m2 mol/m2 mol/m2', & ! veg_in, veg_out
15*'# /ha m2_m2 kg_DW/ha kg_DW_yr/ha cm &
&cm kg_DW/ha kg_DW/ha kg_DW/ha kg_DW/ha kg_DW/ha m3/ha kg_DW/ha kg_DW/ha m2_m2&
& gN/m2 gN/m2 - - cm cm m m/ha m/ha mm'/ ! veg_be, bi, pi, oa, sp, sveg
DATA outy%header / &
'# Year AET_1 AET_2 AET_3 AET_4 AET_5 AET_6 AET_7 AET_8 AET_9 AET_10&
& AET_11 AET_12 AET_Quar1 AET_Quar2 AET_Quar3 AET_Quar4 AET_DJF AET_MAM AET_JJA AET_SON', & ! AET_mon
'# Year GPP NPP NEP Aut_Resp Het_Resp Tot_Resp C_dead_st C_sumvsab C_biomass&
& C_tot_ES C_soil C_tot_1 C_hum_1 C_tot_40 C_hum_40 C_tot_80 C_hum_80 C_tot_100 C_hum_100&
& GPP NPP NEP Aut_Resp Het_Resp Tot_Resp C_dead_st&
& C_sumvsab C_biomass C_tot_ES C_soil gppsum', & ! c_bal
'# Year Cbc_1 Cbc_2 Cbc_3 Cbc_4 Cbc_5 Cbc_6 ....',& ! Cbc
'# Year Chum_1 Chum_2 Chum_3 Chum_4 Chum_5 Chum_6 ....',& ! Chum
'# Year Copm_1 Copm_2 Copm_3 Copm_4 Copm_5 Copm_6 ....',& ! Copm
'# Year species C_opm_fol C_opm_tb C_opm_frt C_opm_crt C_opm_stm species C_opm_fol C_opm_tb C_opm_frt C_opm_crt C_opm_stm &
& ....',& ! Copmfract
'# Year', & ! classd
'# Year', & ! classage
'# Year', & ! classmvol
'# Year', & ! classd_h
'# Year', & ! classdm
'# Year', & ! classdm_h
'# Year', & ! classh
'# Year', & ! classt
'# Year Temp Prec Radiation Wind CO2 GDD summerdays hotdays icedays &
& drydays hraindays snowdays Ind_arid CWB Ind_Lang Ind_Cout Ind_Wissm Ind_Mart Ind_Mart_VP &
&Ind_Emb Ind_Weck Ind_Reich Ind_Gor I_Currey I_Conrad NTIndex Ind_Budyko F_day F_day_sp l_frost l_frosttot anzfd sumtfd iday_vp Ind_SHC', & ! clim
'# Year Temp_1 Temp_2 Temp_3 Temp_4 Temp_5 Temp_6 Temp_7 Temp_8 Temp_9 Temp_10&
& Temp_11 Temp_12 T_Quart1 T_Quart2 T_Quart3 T_Quart4 T_DJF T_MAM T_JJA T_SON', & ! clim_temp
'# Year Prec_1 Prec_2 Prec_3 Prec_4 Prec_5 Prec_6 Prec_7 Prec_8 Prec_9 Prec_10&
& Prec_11 Prec_12 P_Quart1 P_Quart2 P_Quart3 P_Quart4 P_DJF P_MAM P_JJA P_SON', & ! clim_prec
'# Year Rad_1 Rad_2 Rad_3 Rad_4 Rad_5 Rad_6 Rad_7 Rad_8 Rad_9 Rad_10&
& Rad_11 Rad_12 R_Quart1 R_Quart2 R_Quart3 R_Quart4 R_DJF R_MAM R_JJA R_SON', & ! clim_rad
'# Year Hum_1 Hum_2 Hum_3 Hum_4 Hum_5 Hum_6 Hum_7 Hum_8 Hum_9 Hum_10&
& Hum_11 Hum_12 H_Quart1 H_Quart2 H_Quart3 H_Quart4 H_DJF H_MAM H_JJA H_SON', & ! clim_hum
'# Year fcap_av_1 fcap_av_2 fcap_av_3 fcap_av_4 fcap_av_5 fcap_av_6 ....',& ! fcap_av
'# Year fcapvav_1 fcapvav_2 fcapvav_3 fcapvav_4 fcapvav_5 fcapvav_6 ....',& ! fcapv_av
'# Year lay_1 lay_2 lay_3 lay_4 lay_5 lay_6 ....',& ! fr_loss
'# Year GPP_1 GPP_2 GPP_3 GPP_4 GPP_5 GPP_6 GPP_7 GPP_8 GPP_9 GPP_10&
& GPP_11 GPP_12 GPP_Quar1 GPP_Quar2 GPP_Quar3 GPP_Quar4 GPP_DJF GPP_MAM GPP_JJA GPP_SON', & ! GPP_mon
'# Year humus_1 humus_2 humus_3 humus_4 humus_5 humus_6 ....',& ! humusv
'# Bruschek Mean class1 class2 class3 class4 class5&
& Mean class1 class2 class3 class4 class5 Ind_max Ind_day Mean class1 class2 class3 class4', & ! indi
'# Year fol_litter fol_lit_tr frt_litter frt_lit_tr crt_litter tb_litter stem_litter tot_litter&
& fol_litter frt_litter crt_litter tb_litter stem_litter tot_litter&
& fol_litter frt_litter crt_litter tb_litter stem_litter tot_litter', & ! litter
!'# Year fol_litter frt_litter crt_litter tb_litter stem_litter fol_litter frt_litter&
!& crt_litter tb_litter stem_litter', & ! litter
'# Year Nbc_1 Nbc_2 Nbc_3 Nbc_4 Nbc_5 Nbc_6 ....',& ! Nbc
'# Year Nhum_1 Nhum_2 Nhum_3 Nhum_4 Nhum_5 Nhum_6 ....',& ! Nhum
'# Year Nopm_1 Nopm_2 Nopm_3 Nopm_4 Nopm_5 Nopm_6 ....',& ! Nopm
'# Year NEE_1 NEE_2 NEE_3 NEE_4 NEE_5 NEE_6 NEE_7 NEE_8 NEE_9 NEE_10&
& NEE_11 NEE_12 NEE_Quar1 NEE_Quar2 NEE_Quar3 NEE_Quar4 NEE_DJF NEE_MAM NEE_JJA NEE_SON', & ! NEE_mon
'# Year NPP_1 NPP_2 NPP_3 NPP_4 NPP_5 NPP_6 NPP_7 NPP_8 NPP_9 NPP_10&
& NPP_11 NPP_12 NPP_Quar1 NPP_Quar2 NPP_Quar3 NPP_Quar4 NPP_DJF NPP_MAM NPP_JJA NPP_SON', & ! NPP_mon
'# Year management measure ', & ! manrec
'# year count spec type len diam diam wob top_d t_d wob Volume DW number type', & ! mansort
'# Year lay_1 lay_2 lay_3 lay_4 lay_5 lay_6 ....',& ! redis
'# Year root_1 root_2 root_3 root_4 root_5 root_6 ....',& ! root
'# Year layer1 layer2 layer3 layer4 ........', & ! sdrought
'# Year Temp Prec Interc Percol Wupt Wuptroot Transtree Transsveg Wuptsoil AET Wats_tot&
& GP_can N_min N_tot C_tot N_antot N_humtot C_humtot N_hum(1) C_hum(1) N_litter&
& C_litter C_opm_fol C_opm_frt C_opm_crt C_opm_tbc C_opm_stm Nupt Nleach N_depo Soil_Resp&
& PET interc_sv thick1 dew/rime Rnet_tot N_bc_tot C_bc_tot C_bc_app', & ! soil
'# Year', & ! spec
' year count spec type len diam diam wob top_d t_d wob Volume DW number ', & ! standsort
'# Year TER_1 TER_2 TER_3 TER_4 TER_5 TER_6 TER_7 TER_8 TER_9 TER_10&
& TER_11 TER_12 TER_Quar1 TER_Quar2 TER_Quar3 TER_Quar4 TER_DJF TER_MAM TER_JJA TER_SON', & ! TER_mon
'# Year num_Spec Coh Tree LAI Biomass NPPsum Meddiam&
& Domhei Fol_Bio Sap_Bio Frt_Bio Hrt_Bio Stem_inc Stemvol rem_stems&
& dead_stems cover drIndAl Ndem gp_can_mean gp_can_min gp_can_max mean_diam mean_height basal_area dead_stems_m3 stem_inc_m3', & ! veg
2* '# Year num_Spec Coh Tree LAI Biomass Meddiam&
& mean_hei Fol_Bio Sap_Bio Frt_Bio Hrt_Bio Stem_inc Stemvol rem_stems&
& dead_stems cover drIndAl Ndem gp_can_mean gp_can_min gp_can_max', & ! veg_in, veg_out
15*'# Year Spec_id Coh Tree LAI Biomass NPPsum Meddiam&
& Domhei Fol_Bio Sap_Bio Frt_Bio Hrt_Bio Stem_inc Stemvol rem_stems&
& dead_stems cover drIndAl Ndem Nupt Red_N daybb endbb mean_diam mean_height basal_area dead_stems_m3 stem_inc_m3 YRW'/ ! veg_be, bi, pi, oa, sp,lp, sveg, mist
! ----------------------------------------------------- !
! daily output of cohorts
type (out_struct),dimension(23),target :: outcd
integer :: outcd_n = 23 ! number of all declared cohort output files
DATA outcd%kind_name /'ass', 'aevi', 'ddi', 'dem', 'dips', 'gp', 'gsdps', 'intcap', 'interc', &
'Ndemc_d', 'Nuptc_d', 'N_fol', 'N_pool', 'RedNc', 'resp', 'respaut', &
'respbr', 'respfol', 'resphet', 'respsap', 'respfrt', 'sup', 'totfpar'/
DATA outcd%s_line /23*'# Cohort output'/ ! ass, ddi, dem, gp, gsdps, res,
! resbr, ressap, resfrt, sup
DATA outcd%f_line / &
'# Optimum gross assimilation rate (kg DW/d) assi', & ! ass
'# Daily evaporation of intercepted water (mm/day) aev_i', & ! aevi
'# Daily drought index drindd', & ! ddi
'# Demand for soil water of the cohort (mm/day) demand', & ! dem
'# Drought index for Photosyntheses calculation (cum) drindps', & ! dips
'# Unstressed stomatal conductance (mol/m2*d) gp', & ! gp
'# Number of growing season days per time step of photosynthesis ndaysps', & ! gsdps
'# Interception capacity (mm) sum of intcap(layer)', & ! intcap
'# Interception storage (mm) interc_st', & ! interc
'# Daily N demand per tree (g)', & ! Ndemc_d
'# Daily N uptake per tree (g)', & ! Nuptc_d
'# Daily N content of foliage per tree (g)', & ! N_fol
'# Daily N_pool per tree (g)', & ! N_pool
'# Daily photosynthesis nitrogen reduction factor [-]', & ! RedNc
'# Leaf respiration rate (g C/d) resp', & ! resp
'# Daily autotrophic respiration rate (g C/d) respaut', & ! respaut
'# Daily respiration rate of branches (g C/d) respbr', & ! respbr
'# Daily respiration rate of leaves (g C/d) respfol', & ! respfol
'# Daily heterotrophic respiration rate (g C/d) resphet', & ! resphet
'# Daily respiration rate of sapwood (g C/d) respsap', & ! respsap
'# Daily respiration rate of frt (g C/d) respfrt', & ! respfrt
'# Supply of soil water to roots of the cohort (mm/day) supply', & ! sup
'# Total fraction of PAR absorbed per m patch area (-) totFPAR'/ ! totfpar
DATA outcd%header / &
23*'# Day Year Coh1 Coh2 Coh3 Coh4 ...'/ ! ass, ddi, dem, gp, gsdps, res,
! resbr, ressap, resfrt, sup
! ----------------------------------------------------- !
! yearly output of cohorts
type (out_struct),dimension(58),target :: outcy
integer :: outcy_n = 58 ! number of all declared cohort output files
DATA outcy%kind_name /'age', 'ahb', 'ahbasrel', 'ahc', 'ahcasrel', 'asapw', 'atr', 'bioi', 'botlayer','cpa', 'crt', 'daybb', 'dcrb', 'diac', 'diam', &
'dtr', 'dwd','fol', 'foli', 'frt', 'frti', 'frtrel', 'frtrelc', 'geff', 'gfol', 'gfrt', 'grossass', 'gsap', &
'gsd', 'hbo', 'hea', 'hei', 'hrt', 'leaf', 'maintres', 'nas', 'npp', 'rdpt', 'rld', 'sap', &
'sfol', 'sfrt', 'spn', 'ssap', 'stem', 'str', 'tdb','toplayer', 'trman', 'ttb','Ndemc_c','Nuptc_c', &
'Nfol', 'Npool', 'Nstr','rooteff', 'watleft', 'yrw'/
DATA outcy%s_line /58*'# Cohort output'/ ! age, ahb, ahc, atr, asapw, bioi, botLayer, cpa, crt, daybb, dcrb, diac, diam,
! dtr, dwd, fol, foli, frt, frti, frtrel, geff, gfol, gfrt,
! grossass, gsap, gsd, hbo, hea, hrt, hei,
! leaf, maintres, nas, npp, rdpt, rld, sap, sfol, sfrt, spn,
! ssap, stem, str, tdb, topLayer, trman,ttb, Ndemc,Nuptc, rooteff,watleft
DATA outcy%f_line / &
'# Tree age (year)', & ! age
'# Cross sectional area of heartwood at stem base [cm**2] x_Ahb', & ! ahb
'# Relation of heartwood to sapwood at stem base', & ! ahbasrel
'# Cross sectional area of heartwood at crown base [cm**2] Ahc', & ! ahc
'# Relation of heartwood to sapwood at crown base', & ! ahcasrel
'# Cross sectional area of sapwood in bole space [cm**2] Asapw', & ! asapw
'# Number of alive trees per cohort', & ! atr
'# Net biomass increment (kg DM/year)', & ! bioi
'# Number of bottom layer of crown [-]', & ! botLayer
'# Cohort crown projection area (m2)', & ! cpa
'# coarse root biomass (kg DM/tree)', & ! crt
'# Day of leaf bud burst', & ! daybb
'# Diameter of stem at crown base (cm)',& ! dcrb
'# Drought index for allocation calculation (cum)', & ! diac
'# Diameter at breast height (cm)', & ! diam
'# Number of dead trees per cohort', & ! dtr
'# Stem biomass of dead trees per cohort', & ! dwd
'# Foliage biomass (kg DM/tree)', & ! fol
'# Foliage increment (kg DM/year/tree)', & ! foli
'# Fine root biomass (kg DM/tree)', & ! frt
'# Net fine root increment (kg DM/year/tree)', & ! frti
'# Relative fine root fraction of tree per soil layer (root profile)', & ! frtrel
'# Relative fine root fraction of cohort of total layer fine root mass per soil layer', & ! frtrel
'# Growth efficiency kg/m2', & ! geff
'# Gross growth rate foliage (kg DM/year/tree)', & ! gfol
'# Gross growth rate fine root (kg DM/year/tree)', & ! gfrt
'# Gross assimilation rate (kg DM/year/tree)', & ! grossass
'# Gross growth rate sapwood (kg DM/year/tree)', & ! gsap
'# Number of growing season days per year ndaysgr',& ! gsd
'# Bole height (cm)', & ! hbo
'# Number of years without stress', & ! hea
'# Total tree height (cm)', & ! hei
'# Heartwood biomass (kg DM/tree)', & ! hrt
'# Leaf area per tree (m2)', & ! leaf
'# Maintenance respiration (kg DM/year/tree)', & ! maintres
'# Net foliage assimilation rate (kg DM/year/tree)', & ! nas
'# NPP (kg DM/year/tree)', & ! npp
'# Rooting depth calculated with TRAP model[cm]', & ! rdpt
'# estimated root length density [cm]', & ! rld
'# Sapwood biomass (kg DM)', & ! sap
'# Senescence rate foliage (kg DM/year/tree)', & ! sfol
'# Senescence rate fine roots (kg DM/year/tree)', & ! sfrt
'# Species number of the cohort', & ! spn
'# Senescence rate sapwood (kg DM/year/tree)', & ! ssap
'# Stemwood biomass increment (kg DM/year/tree)', & ! stem
'# Number of stress years', & ! str
'# Total cohort dead biomass (kg DM/year/cohort)', & ! tdb
'# Number of top layer of crown [-]', & ! topLayer
'# Number of trees harvested by managment', & ! trman
'# Total tree biomass (kg DM/tree)', & ! ttb
'# N demand per tree and year (g)', & ! Ndemc_c
'# N uptake per tree and year (g)', & ! Nuptc_c
'# N content of foliage per tree and year (g)', & ! Nfol
'# N pool per tree and year (g)', & ! Npool
'# Ratio of N uptake to demand per tree and year', & ! Nstr
'# Root uptake efficiency factor', & ! rooteff
'# Water left in next layer', & ! watleft
'# Year ring width [mm]' / ! yrw
DATA outcy%header / &
58*'# Year Coh1 Coh2 Coh3 Coh4 ...'/ !age, ahb, ahc, atr, bioi, cpa, crt, daybb, dcrb, diac, diam,
! dtr, dwd, fol, foli, frt, frti, frtrel, geff, gfol, gfrt,
! gsap, gsd, hbo, hea, hrt, hei,
! leaf, maintres, nas, npp, rdpt, rld, sap, sfol, sfrt, spn,
! stem, str, tdb,trman, ttb, Ndemc,Nuptc, rooteff,watleft, yrw
! output at simulation end
type (out_struct),dimension(6),target :: oute
integer :: oute_n = 6 ! number of all declared end output files
DATA oute%kind_name /'sea', 'sea_ms', 'sea_npv', 'sea_st','wpm', 'wpm_inter'/
DATA oute%f_line / &
'# SEA: Costs and assets of standing stock, harvested timber, silvicultural costs, fix costs, and subsidies in euro/ha', &
'# SEA: Timber grading for harvested wood, m3/ha', &
'# SEA: liquidation value, npv, npv+ in euro/ha', &
'# SEA: Timber grading for standing stock, m3/ha', &
'# Wood product model output', &
'# Wood product model intermediate steps'/ !
DATA oute%s_line / &
'# shotcuts: sum: summe, st: standing stock, ms: harvested wood, fc: fix costs, sv: silvicultural costs, co: costs, as: assets, sub: subsidies, sp: spruce, be: beech, pi: pine, oa: oak, bi: birch, ' , &
'# Timber grades 1-7: 1-fue, 2-in, 3-LAS1a, 4-LAS1b, 5-LAS2a, 6-LAS2b, 7-LAS3a, 8-L2b, 9-L3a, 10-L3b ' , &
'# a: without discounting, b-d: interest rate (see "sea_prices.wpm" file) ' , &
'# Timber grades 1-7: 1-fue, 2-in, 3-LAS1a, 4-LAS1b, 5-LAS2a, 6-LAS2b, 7-LAS3a, 8-L2b, 9-L3a, 10-L3b ' , &
'# Carbon in different products, kg C/ha ' , &
'# Carbon in different products, kg C/ha tg: timber grades, il: industrial lines, pl: product lines'/
DATA oute%header / &
'# Year sum_all sum_st sum_ms sum_sv sum_fc sum_sub be_st_co sp_st_co pi_st_co oa_st_co bi_st_co |be_st_as sp_st_as pi_st_as oa_st_as bi_st_as |be_ms_co sp_ms_co pi_ms_co oa_ms_co bi_ms_co |be_ms_as sp_ms_as pi_ms_as oa_ms_as bi_ms_as fix_costs sub_har sub_sv_co sub_fix ', &! sea
'# Year be_tg1 be_tg2 be_tg5 be_tg6 be_tg7 be_tg8 be_tg9 be_tg10 &
&sp_tg1 sp_tg2 sp_tg4 sp_tg5 sp_tg6 sp_tg7 sp_tg8 sp_tg9 sp_tg10 &
&pi_tg1 pi_tg2 pi_tg3 pi_tg4 pi_tg5 pi_tg6 pi_tg7 pi_tg8 pi_tg9 pi_tg10 &
&oa_tg1 oa_tg2 oa_tg5 oa_tg6 oa_tg7 oa_tg8 oa_tg9 oa_tg10 &
&bi_tg1 bi_tg2 bi_tg5 bi_tg6 bi_tg7 bi_tg8 bi_tg9 bi_tg10', &! sea_ms
'# Year LVa LVb LVc LVd NPVa NPVb NPVc NPVd NPV+a NPV+b NPV+c NPV+d ', &! sea_npv
'# Year be_tg1 be_tg2 be_tg5 be_tg6 be_tg7 be_tg8 be_tg9 be_tg10 &
&sp_tg1 sp_tg2 sp_tg4 sp_tg5 sp_tg6 sp_tg7 sp_tg8 sp_tg9 sp_tg10 &
&pi_tg1 pi_tg2 pi_tg3 pi_tg4 pi_tg5 pi_tg6 pi_tg7 pi_tg8 pi_tg9 pi_tg10 &
&oa_tg1 oa_tg2 oa_tg5 oa_tg6 oa_tg7 oa_tg8 oa_tg9 oa_tg10 &
&bi_tg1 bi_tg2 bi_tg5 bi_tg6 bi_tg7 bi_tg8 bi_tg9 bi_tg10', &! sea_st
'# Year sum_input u1 u2 u3 u4 u5 u6 u7 sum_u1-7 burn&
& landfill atmo atmo_cum emission sub_energ sub_mat sub_sum', & ! wpm
'# Year tg1 tg2 tg3 tg4 tg5 tg6 il1 il2 il3 il4 il5 il6 il7 pl1 pl2 pl3 pl4 pl5 pl6 pl7 u1 u2 u3 u4 u5 u6 u7 '/ ! wpm_inter
! special output forms
INTEGER :: out_flag_light ! output flag light-file
INTEGER :: unit_err ! unit for error log file
INTEGER :: unit_trace ! unit for trace log file
INTEGER :: unit_sum ! unit for summation output (fluxes) file
INTEGER :: unit_comp1, unit_comp2 ! ncompressed output
INTEGER :: unit_light, unit_wat
INTEGER :: unit_ctr, unit_prod, unit_allo, unit_soil
INTEGER :: unit_soicnd, unit_soicna, unit_soicnr
! store output variables of veg-file
type out_veg
integer,dimension(3):: help_veg1
real,dimension(11):: help_veg2
real help_veg3
real :: help_veg4
real :: help_veg5
real :: help_veg6
end type out_veg
type (out_veg),allocatable,dimension(:),target :: sout
type (out_veg) :: vout
type out_C
real, dimension(366):: NEE ! net ecosystem exchange
real, dimension(366):: Resp_aut ! autotrophic respiration
end type out_C
type (out_C) :: Cout
character(100) :: mess_info = '# ' ! output of measurements: information line
end module data_out
!**************************************************************
source_code/version_2.3_windows/amod_out.fold 0 → 100644
View file @ 82df1085
!*****************************************************************!
!* *!
!* 4C (FORESEE) Simulation Model *!
!* *!
!* *!
!* data module for various output files (Header ,...) *!
!* *!
!* 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 *!
!* *!
!*****************************************************************!
module data_out
! definition of output form each output type (kind_name) with 4 DATA statements
! character strings with more than 1 row must be separated only by &
! Attention! Blanks are normally significant, but problematic:
! at the beginning of the row only one blank is significant
!
! Recipe for new output files:
! add 1 to the dimension field "(type (out_struct),dimension(x+1),target :: out??)"
! a n d to the number of files "out??_n"+1
! add the specifier of output file to DATA kind_name
! add the comments on first and second line to the respective DATA statements
! add the column header to DATA header (pay attention to the above remarks regarding blanks!)
! add the write statements to the case construct with the kind_name (in output.f)
! depending on the output structure special open statements might have to be added
! in OLD_OUT in output.f
! data structure of skalar and field output
type out_struct
character (10) :: kind_name ! specifies the kind and the name of the output file
integer :: unit_nr ! output unit, set in output.f
integer :: out_flag ! output flag
character (200) :: f_line ! first comment line
character (500) :: s_line ! second comment line
character (900) :: header ! header of output columns
end type out_struct
! daily output of scalars and fields
type (out_struct),dimension(24),target :: outd ! daily output files
integer :: outd_n = 24 ! number of all declared daily output files
DATA outd%kind_name /'Cday','Chumd','Copmd','COPMfract','Cbcd', 'day', 'day_short','NH4','NH4c','NO3','NO3c','Nhumd','Nopmd', &
'NOPMfract', 'Nuptd', 'Nmind', 'perc', 'specd', 'temp', 'wat_potent', 'wat_res', 'water', 'watvol', 'wupt'/
DATA outd%f_line /'# Daily C balance', & ! Cday
'# C content of humus (hum) per layer', & ! Chumd
'# C content of organic primary matter (OPM) per layer', & ! Copmd
'# C content of organic primary matter (OPM) fractions', & ! COPMfract
'# C content of biochar per layer', & ! Cbcd
'# Daily output', & ! day
'# Short daily output', & ! day_short
'# NH4 content per layer', & ! NH4
'# NH4 concentration per layer', & ! NH4c
'# NO3 content per layer', & ! NO3
'# NO3 concentration per layer', & ! NO3c
'# N content of humus (hum) per layer', & ! Nhumd
'# N content of organic primary matter (OPM) per layer', & ! Nopmd
'# N content of organic primary matter (OPM) fractions', & ! NOPMfract
'# Daily nitrogen uptake by roots per layer Nupt', & ! Nuptd
'# Daily nitrogen mineralisation per layer Nmin', & ! Nmind
'# Daily percolation of water per layer perc', & ! perc
'# Daily species variables svar', & ! specd
'# Daily soil temperature per layer temps', & ! temp
'# Daily soil water potential per layer wat_potential',& ! wat_potent
'# Daily water uptake resistance per layer wat_res', & ! wat_res
'# Daily soil water content per layer wats', & ! water
'# Daily soil water content per layer watvol', & ! watvol
'# Daily water uptake by roots per layer wupt_r'/ ! wupt
DATA outd%s_line / &
'# gC/m2 gC/m2 gC/m2 gC/m2 gC/m2 gC/m2 gC/m2 gC/m2 gC/m2 gC/m2&
& gC/m2 gC/m2 gC/m2 %' , & ! Cday
'# gC_m2', & ! Chumd
'# gC_m2', & ! Copmd
'# gC/m2 |------------- Fagus sylvatica ----------------|--------------- Picea abies -----------------|&
&------------ Pinus sylvestris ----------------|--------------- Quercus robur ----------------|&
&------------- Betula pendula -----------------|-------------- Pinus contorta ---------------|&
&------------- Bodenvegetation ----------------|', & ! COPMfract
'# gC_m2', & ! Cbcd
'# Grad C J/cm2 mm mm mm mm mm mm mm mm&
& mol/m2 gC/m2 gN/m2 gN/m2 gN/m2 gN/m2 mgN/m2 &
& mm mm C&
J/cm2 J/cm2', & ! day
'# - mm', & ! day_short
'# gN/m2', & ! NH4
'# mgN/l', & ! NH4c
'# gN/m2', & ! NO3
'# mgN/l', & ! NO3c
'# gN/m2', & ! Nhumd
'# gN/m2', & ! Nopmd
'# gN/m2 |------------- Fagus sylvatica ----------------|--------------- Picea abies -----------------|&
&------------ Pinus sylvestris ----------------|--------------- Quercus robur ----------------|&
&------------- Betula pendula -----------------|-------------- Pinus contorta ---------------|&
&------------- Pinus ponderosa -----------------|-------------- Populus tremula ---------------|&
&------------- Bodenvegetation ----------------|', & ! NOPMfract
'# gN/m2', & ! Nuptd
'# gN/m2', & ! Nmind
'# mm/day', & ! perc
'# ', & ! specd
'# C', & ! temp
'# hPa', & ! wat_potent
'# ', & ! wat_res
'# mm', & ! water
'# vol%', & ! watvol
'# mm/day'/ ! wupt
DATA outd%header / &
'# Day Year gross_Phot gross_Ass net_Ass pot_NPP NPP NPP_day GPP_day NEE &
& TER_day autresp Resp_aut Resp_het Resp_fol FaPar',& ! Cday
'# Day Year Chum_1 Chum_2 Chum_3 Chum_4 Chum_5 Chum_6 ....',& ! Chumd
'# Day Year Copm_1 Copm_2 Copm_3 Copm_4 Copm_5 Copm_6 ....',& ! Copmd
'# Day Year C_opm_fol C_opm_tb C_opm_frt C_opm_crt C_opm_stm C_opm_fol C_opm_tb C_opm_frt C_opm_crt C_opm_stm &
& C_opm_fol C_opm_tb C_opm_frt C_opm_crt C_opm_stm C_opm_fol C_opm_tb C_opm_frt C_opm_crt C_opm_stm &
& C_opm_fol C_opm_tb C_opm_frt C_opm_crt C_opm_stm C_opm_fol C_opm_tb C_opm_frt C_opm_crt C_opm_stm &
& C_opm_fol C_opm_tb C_opm_frt C_opm_crt C_opm_stm ',& ! COPMfract
'# Day Year Cbc_1 Cbc_2 Cbc_3 Cbc_4 Cbc_5 Cbc_6 ....',& ! Cbcd
'# Day Year Temp Rad Prec Intercep Snow PET AET Transdem Transtree Transsveg&
& GP_can Resp_het Nleach_d Nupt_d Nmin_d_c N_antot N_Depo Cover&
& LAI s_Light toFPARcan fire_indi fire_e fire_w fire_n snowday drIndd&
& buckroot buck100 cl_WatBal dewp.temp dew/rime Rnet_tot Rad_max',& ! day
'# Date fire_e cl_WatBal',& ! day_short
'# Day Year NH4_1 NH4_2 NH4_3 NH4_4 NH4_5 NH4_6 ....',& ! NH4
'# Day Year NH4_1 NH4_2 NH4_3 NH4_4 NH4_5 NH4_6 ....',& ! NH4c
'# Day Year NO3_1 NO3_2 NO3_3 NO3_4 NO3_5 NO3_6 ....',& ! NO3
'# Day Year NO3_1 NO3_2 NO3_3 NO3_4 NO3_5 NO3_6 ....',& ! NO3c
'# Day Year Nhum_1 Nhum_2 Nhum_3 Nhum_4 Nhum_5 Nhum_6 ....',& ! Nhumd
'# Day Year Nopm_1 Nopm_2 Nopm_3 Nopm_4 Nopm_5 Nopm_6 ....',& ! Nopmd
'# Day Year N_opm_fol N_opm_tb N_opm_frt N_opm_crt N_opm_stm N_opm_fol N_opm_tb N_opm_frt N_opm_crt N_opm_stm &
& N_opm_fol N_opm_tb N_opm_frt N_opm_crt N_opm_stm N_opm_fol N_opm_tb N_opm_frt N_opm_crt N_opm_stm &
& N_opm_fol N_opm_tb N_opm_frt N_opm_crt N_opm_stm N_opm_fol N_opm_tb N_opm_frt N_opm_crt N_opm_stm &
& N_opm_fol N_opm_tb N_opm_frt N_opm_crt N_opm_stm ',& ! NOPMfract
'# Day Year Nupt_1 Nupt_2 Nupt_3 Nupt_4 Nupt_5 Nupt_6 ....',& ! Nuptd
'# Day Year Nmin_1 Nmin_2 Nmin_3 Nmin_4 Nmin_5 Nmin_6 ....',& ! Nmind
'# Day Year Percol_1 Percol_2 Percol_3 Percol_4 Percol_5 Percol_6 ....',& ! perc
'# Day Year species_name number Ndem Nupt Ndemp Nuptp RedN ',& ! specd
'# Day Year Temp_surf Temps_1 Temps_2 Temps_3 Temps_4 Temps_5 Temps_6 ....',& ! temp
'# Day Year Pot_1 Pot_2 Pot_3 Pot_4 Pot_5 Pot_6 ....',& ! wat_potent
'# Day Year Wat_res_1 Wat_res_2 Wat_res_3 Wat_res_4 Wat_res_5 Wat_res_6 ....',& ! wat_res
'# Day Year Wats_1 Wats_2 Wats_3 Wats_4 Wats_5 Wats_6 ....',& ! water
'# Day Year Wats_1 Wats_2 Wats_3 Wats_4 Wats_5 Wats_6 ....',& ! watvol
'# Day Year Wupt_r_1 Wupt_r_2 Wupt_r_3 Wupt_r_4 Wupt_r_5 Wupt_r_6 ....'/ ! wupt
! ----------------------------------------------------- !
! yearly output of scalars and fields
type (out_struct),dimension(57),target :: outy ! yearly output files
integer :: outy_n = 57 ! number of all declared yearly output files
DATA outy%kind_name /'AET_mon','c_bal','Cbc','Chum','Copm','classd','classage','classmvol','classd_h','classdm', 'classdm_h',&
'classh', 'classt', 'clim', 'clim_temp', 'clim_prec', 'clim_rad', 'clim_hum', &
'fcap_av','fcapv_av', 'fr_loss','GPP_mon', 'humusv', 'indi', &
'litter','Nbc','Nhum','Nopm','NEE_mon','NPP_mon','manrec', 'mansort', 'redis', 'root', 'sdrought',&
'soil', 'spec', 'standsort','TER_mon','veg', 'veg_in', 'veg_out', &
'veg_be','veg_bi','veg_pi', 'veg_pc', 'veg_pp', 'veg_pt', &
'veg_oa','veg_sp','veg_ph', 'veg_dg', 'veg_rb', 'veg_egl', 'veg_egr','veg_sveg','veg_mist'/
DATA outy%f_line /'# Monthly sum of actual evapotranspiration (AET)', & ! AET_mon
'# Yearly C-Balance, C-stocks and -fluxes; C_sumvsab is part of C_biomass', & ! c_bal
'# C content of biochar (C_bc) per layer', & ! Cbc
'# C content of humus (hum) per layer', & ! Chum
'# C content of organic primary matter (OPM) per layer', & ! Copm
'#', & ! classd
'#', & ! classage
'#', & ! classmvol
'#', & ! classd_h
'#', & ! classdm
'#', & ! classdm_h
'#', & ! classh
'#', & ! classt
'# Climate data', & ! clim
'# Air temperature: monthly climate data', & ! clim_temp
'# Precipitation: monthly climate data', & ! clim_prec
'# Radiation: monthly climate data', & ! clim_rad
'# Relative humidity: monthly climate data', & ! clim_hum
'# Available field capacity per layer', & ! fcap_av
'# Available field capacity per layer', & ! fcapv_av
'# Percentage fine root C-loss per soil layer', & ! fr_loss
'# Monthly GPP of all cohorts and species', & ! GPP_mon
'# Content of humus per layer', & ! humusv
'# Indices of fire and biodiversity', & ! indi
'# Yearly litter fractions', & ! litter
'# N content of biochar (N_bc) per layer', & ! Nbc
'# N content of humus (hum) per layer', & ! Nhum
'# N content of organic primary matter (OPM) per layer', & ! Nopm
'# Monthly NEE of all cohorts and species', & ! NEE_mon
'# Monthly NPP of all cohorts and species', & ! NPP_mon
'# Management record', & ! manrec
'# Management sortiment',& ! mansort
'# Redistribution of root C (redis)', & ! redis
'# Root distribution (root_fr)', & ! root
'# Data from soil model', & ! sdrought
'# Data from soil model', & ! soil
'# Species number and name', & ! spec
'# sortiment of whole stand (without harvested trees)',& ! standsort
'# Monthly TER of all cohorts and species', & ! TER_mon
'# Values for the whole stand (per ha); see files veg_in, veg_out in addition', & ! veg
'# New trees (by planting or regeneration), values for the whole stand (per ha)', & ! veg_in
'# Removed trees (by mortality or management) with number of cohorts from which trees are removed (per ha)', & ! veg_out
'# Values for the whole stand (per ha) for beech', & ! veg_be
'# Values for the whole stand (per ha) for birch', & ! veg_bi
'# Values for the whole stand (per ha) for pinus sylvestris', & ! veg_pi
'# Values for the whole stand (per ha) for pinus contorta', & ! veg_pc
'# Values for the whole stand (per ha) for pinus ponderosa', & ! veg_pp
'# Values for the whole stand (per ha) for populus tremula', & ! veg_pt
'# Values for the whole stand (per ha) for oak', & ! veg_oa
'# Values for the whole stand (per ha) for spruce', & ! veg_sp
'# Values for the whole stand (per ha) for pinus halepensis', & ! veg_ph
'# Values for the whole stand (per ha) for douglas fir', & ! veg_dg
'# Values for the whole stand (per ha) for black locust', & ! veg_rb
'# Values for the whole stand (per ha) for E.globulus', & ! veg_egl
'# Values for the whole stand (per ha) for E.grandis', & ! veg_egr
'# Values for the whole stand (per ha) for ground vegetation', & ! veg_sveg
'# Values for the whole stand (per ha) for mistletoe (Visc. a.)'/! veg_mist
DATA outy%s_line / &
'# mm', & ! AET_mon
'# kg/ha kg/ha kg/ha kg/ha kg/ha kg/ha kg/ha kg/ha&
& kg/ha kg/ha t/ha t/ha t/ha t/ha t/ha t/ha t/ha t/ha t/ha&
& mol/m2 mol/m2 mol/m2 mol/m2 mol/m2 mol/m2 mol/m2 mol/m2&
& mol/m2 mol/m2 mol/m2 kg/ha', & ! c_bal
'# gC/m2', & ! Cbc
'# gC/m2', & ! Chum
'# gC/m2', & ! Copm
'# diam_class: Number of trees (per ha) in diameter classes, step 5 cm', & ! classd
'# diam_class: Mean age of trees (per ha) in diamter classes, step 5 cm', & ! classage
'# diam_class: Mean volume (m/ha) of harvested trees in diamter classes, step 5 cm', & ! classmvol
'# diam_class: Mean height of trees in diameter classes, step 5 cm', & ! classd_h
'# diam_class: Number of harvested trees (per ha) in diameter classes, step 5 cm', & ! classdm
'# diam_class: Mean height of trees in diameter classes, step 5 cm', & ! classdm_h
'# height_class: Number of trees in height classes, bis 1,5,6,7,...,50,55,>55m', & ! classh
'# diam_class: Number of dead trees (per ha) in diameter classes, step 5 cm', & ! classt
'# C mm J/cm2 m/s ppm C', & ! clim
'# C ... ', & ! clim_temp
'# mm ... ', & ! clim_prec
'# J/cm2 ... ', & ! clim_rad
'# % ... ', & ! clim_hum
'# mm', & ! fcap_av
'# %', & ! fcapv_av
'# yearly mean fine root C-loss', & ! fr_loss
'# gC/m2', & ! GPP_mon
'# %', & ! humusv
'# fire index |------------ fire index west ------------|&
&|----------------------- fire index east -----------------------|&
&|------- fire index Nesterov -------|', & ! indi
'# |-------------------------------- Dry mass kg DW/ha_yr ---------------------------------|&
& |----------------- Carbon content kg C/ha_yr -------------------|&
& |----------------- Nitrogen content kg N/ha_yr -----------------|', & ! litter
!& % % % % ', & ! litter
'# gN/m2', & ! Nbc
'# gN/m2', & ! Nhum
'# gN/m2', & ! Nopm
'# gC/m2', & ! NEE_mon
'# gC/m2', & ! NPP_mon
' ', & ! manrec
' cm cm cm cm cm m/ha kg C/ha ', & ! mansort
'# relative share of redistributed C per layer (whole stand) ', & ! redis
'# relative share of root mass per layer (whole stand) ', & ! root
'# s_drought: Number of days with water content near wilting point (drought days) per layer', & ! sdrought
'# Grad_C mm mm mm mm mm mm mm mm mm mm mol_m2 gN_m2&
& gN_m2 gC_m2 gN_m2 gN_m2 gC_m2 gN_m2 gC_m2 gN_m2 gC_m2 gC_m2 gC_m2 gC_m2 gC_m2 gC_m2&
& gN_m2 gN_m2 gN_m2 gC_m2 mm mm cm mm J/cm2 gN_m2 gC_m2 gC_m2',& ! soil
'#', & ! spec
' cm cm cm cm cm m/ha kg C/ha ', & ! standsort
'# gC/m2', & ! TER_mon
'# /ha m2_m2 kg_DW/ha kg_DW_yr/ha cm cm&
& kg_DW/ha kg_DW/ha kg_DW/ha kg_DW/ha kg_DW/ha m3/ha kg_DW/ha kg_DW/ha m2_m2&
& gN/m2 mol/m2 mol/m2 mol/m2 cm cm m m/ha m/ha', & ! veg
2*'# /ha m2_m2 kg_DW/ha cm cm&
& kg_DW/ha kg_DW/ha kg_DW/ha kg_DW/ha kg_DW/ha m3/ha kg_DW/ha kg_DW/ha m2_m2&
& gN/m2 mol/m2 mol/m2 mol/m2', & ! veg_in, veg_out
15*'# /ha m2_m2 kg_DW/ha kg_DW_yr/ha cm &
&cm kg_DW/ha kg_DW/ha kg_DW/ha kg_DW/ha kg_DW/ha m3/ha kg_DW/ha kg_DW/ha m2_m2&
& gN/m2 gN/m2 - - cm cm m m/ha m/ha mm'/ ! veg_be, bi, pi, oa, sp, sveg
DATA outy%header / &
'# Year AET_1 AET_2 AET_3 AET_4 AET_5 AET_6 AET_7 AET_8 AET_9 AET_10&
& AET_11 AET_12 AET_Quar1 AET_Quar2 AET_Quar3 AET_Quar4 AET_DJF AET_MAM AET_JJA AET_SON', & ! AET_mon
'# Year GPP NPP NEP Aut_Resp Het_Resp Tot_Resp C_dead_st C_sumvsab C_biomass&
& C_tot_ES C_soil C_tot_1 C_hum_1 C_tot_40 C_hum_40 C_tot_80 C_hum_80 C_tot_100 C_hum_100&
& GPP NPP NEP Aut_Resp Het_Resp Tot_Resp C_dead_st&
& C_sumvsab C_biomass C_tot_ES C_soil gppsum', & ! c_bal
'# Year Cbc_1 Cbc_2 Cbc_3 Cbc_4 Cbc_5 Cbc_6 ....',& ! Cbc
'# Year Chum_1 Chum_2 Chum_3 Chum_4 Chum_5 Chum_6 ....',& ! Chum
'# Year Copm_1 Copm_2 Copm_3 Copm_4 Copm_5 Copm_6 ....',& ! Copm
'# Year', & ! classd
'# Year', & ! classage
'# Year', & ! classmvol
'# Year', & ! classd_h
'# Year', & ! classdm
'# Year', & ! classdm_h
'# Year', & ! classh
'# Year', & ! classt
'# Year Temp Prec Radiation Wind CO2 GDD summerdays hotdays icedays &
& drydays hraindays snowdays Ind_arid CWB Ind_Lang Ind_Cout Ind_Wissm Ind_Mart Ind_Mart_VP &
&Ind_Emb Ind_Weck Ind_Reich Ind_Gor I_Currey I_Conrad NTIndex Ind_Budyko F_day F_day_sp l_frost l_frosttot anzfd sumtfd iday_vp Ind_SHC', & ! clim
'# Year Temp_1 Temp_2 Temp_3 Temp_4 Temp_5 Temp_6 Temp_7 Temp_8 Temp_9 Temp_10&
& Temp_11 Temp_12 T_Quart1 T_Quart2 T_Quart3 T_Quart4 T_DJF T_MAM T_JJA T_SON', & ! clim_temp
'# Year Prec_1 Prec_2 Prec_3 Prec_4 Prec_5 Prec_6 Prec_7 Prec_8 Prec_9 Prec_10&
& Prec_11 Prec_12 P_Quart1 P_Quart2 P_Quart3 P_Quart4 P_DJF P_MAM P_JJA P_SON', & ! clim_prec
'# Year Rad_1 Rad_2 Rad_3 Rad_4 Rad_5 Rad_6 Rad_7 Rad_8 Rad_9 Rad_10&
& Rad_11 Rad_12 R_Quart1 R_Quart2 R_Quart3 R_Quart4 R_DJF R_MAM R_JJA R_SON', & ! clim_rad
'# Year Hum_1 Hum_2 Hum_3 Hum_4 Hum_5 Hum_6 Hum_7 Hum_8 Hum_9 Hum_10&
& Hum_11 Hum_12 H_Quart1 H_Quart2 H_Quart3 H_Quart4 H_DJF H_MAM H_JJA H_SON', & ! clim_hum
'# Year fcap_av_1 fcap_av_2 fcap_av_3 fcap_av_4 fcap_av_5 fcap_av_6 ....',& ! fcap_av
'# Year fcapvav_1 fcapvav_2 fcapvav_3 fcapvav_4 fcapvav_5 fcapvav_6 ....',& ! fcapv_av
'# Year lay_1 lay_2 lay_3 lay_4 lay_5 lay_6 ....',& ! fr_loss
'# Year GPP_1 GPP_2 GPP_3 GPP_4 GPP_5 GPP_6 GPP_7 GPP_8 GPP_9 GPP_10&
& GPP_11 GPP_12 GPP_Quar1 GPP_Quar2 GPP_Quar3 GPP_Quar4 GPP_DJF GPP_MAM GPP_JJA GPP_SON', & ! GPP_mon
'# Year humus_1 humus_2 humus_3 humus_4 humus_5 humus_6 ....',& ! humusv
'# Bruschek Mean class1 class2 class3 class4 class5&
& Mean class1 class2 class3 class4 class5 Ind_max Ind_day Mean class1 class2 class3 class4', & ! indi
'# Year fol_litter fol_lit_tr frt_litter frt_lit_tr crt_litter tb_litter stem_litter tot_litter&
& fol_litter frt_litter crt_litter tb_litter stem_litter tot_litter&
& fol_litter frt_litter crt_litter tb_litter stem_litter tot_litter', & ! litter
!'# Year fol_litter frt_litter crt_litter tb_litter stem_litter fol_litter frt_litter&
!& crt_litter tb_litter stem_litter', & ! litter
'# Year Nbc_1 Nbc_2 Nbc_3 Nbc_4 Nbc_5 Nbc_6 ....',& ! Nbc
'# Year Nhum_1 Nhum_2 Nhum_3 Nhum_4 Nhum_5 Nhum_6 ....',& ! Nhum
'# Year Nopm_1 Nopm_2 Nopm_3 Nopm_4 Nopm_5 Nopm_6 ....',& ! Nopm
'# Year NEE_1 NEE_2 NEE_3 NEE_4 NEE_5 NEE_6 NEE_7 NEE_8 NEE_9 NEE_10&
& NEE_11 NEE_12 NEE_Quar1 NEE_Quar2 NEE_Quar3 NEE_Quar4 NEE_DJF NEE_MAM NEE_JJA NEE_SON', & ! NEE_mon
'# Year NPP_1 NPP_2 NPP_3 NPP_4 NPP_5 NPP_6 NPP_7 NPP_8 NPP_9 NPP_10&
& NPP_11 NPP_12 NPP_Quar1 NPP_Quar2 NPP_Quar3 NPP_Quar4 NPP_DJF NPP_MAM NPP_JJA NPP_SON', & ! NPP_mon
'# Year management measure ', & ! manrec
'# year count spec type len diam diam wob top_d t_d wob Volume DW number type', & ! mansort
'# Year lay_1 lay_2 lay_3 lay_4 lay_5 lay_6 ....',& ! redis
'# Year root_1 root_2 root_3 root_4 root_5 root_6 ....',& ! root
'# Year layer1 layer2 layer3 layer4 ........', & ! sdrought
'# Year Temp Prec Interc Percol Wupt Wuptroot Transtree Transsveg Wuptsoil AET Wats_tot&
& GP_can N_min N_tot C_tot N_antot N_humtot C_humtot N_hum(1) C_hum(1) N_litter&
& C_litter C_opm_fol C_opm_frt C_opm_crt C_opm_tbc C_opm_stm Nupt Nleach N_depo Soil_Resp&
& PET interc_sv thick1 dew/rime Rnet_tot N_bc_tot C_bc_tot C_bc_app', & ! soil
'# Year', & ! spec
' year count spec type len diam diam wob top_d t_d wob Volume DW number ', & ! standsort
'# Year TER_1 TER_2 TER_3 TER_4 TER_5 TER_6 TER_7 TER_8 TER_9 TER_10&
& TER_11 TER_12 TER_Quar1 TER_Quar2 TER_Quar3 TER_Quar4 TER_DJF TER_MAM TER_JJA TER_SON', & ! TER_mon
'# Year num_Spec Coh Tree LAI Biomass NPPsum Meddiam&
& Domhei Fol_Bio Sap_Bio Frt_Bio Hrt_Bio Stem_inc Stemvol rem_stems&
& dead_stems cover drIndAl Ndem gp_can_mean gp_can_min gp_can_max mean_diam mean_height basal_area dead_stems_m3 stem_inc_m3', & ! veg
2* '# Year num_Spec Coh Tree LAI Biomass Meddiam&
& mean_hei Fol_Bio Sap_Bio Frt_Bio Hrt_Bio Stem_inc Stemvol rem_stems&
& dead_stems cover drIndAl Ndem gp_can_mean gp_can_min gp_can_max', & ! veg_in, veg_out
15*'# Year Spec_id Coh Tree LAI Biomass NPPsum Meddiam&
& Domhei Fol_Bio Sap_Bio Frt_Bio Hrt_Bio Stem_inc Stemvol rem_stems&
& dead_stems cover drIndAl Ndem Nupt Red_N daybb endbb mean_diam mean_height basal_area dead_stems_m3 stem_inc_m3 YRW'/ ! veg_be, bi, pi, oa, sp,lp, sveg, mist
! ----------------------------------------------------- !
! daily output of cohorts
type (out_struct),dimension(23),target :: outcd
integer :: outcd_n = 23 ! number of all declared cohort output files
DATA outcd%kind_name /'ass', 'aevi', 'ddi', 'dem', 'dips', 'gp', 'gsdps', 'intcap', 'interc', &
'Ndemc_d', 'Nuptc_d', 'N_fol', 'N_pool', 'RedNc', 'resp', 'respaut', &
'respbr', 'respfol', 'resphet', 'respsap', 'respfrt', 'sup', 'totfpar'/
DATA outcd%s_line /23*'# Cohort output'/ ! ass, ddi, dem, gp, gsdps, res,
! resbr, ressap, resfrt, sup
DATA outcd%f_line / &
'# Optimum gross assimilation rate (kg DW/d) assi', & ! ass
'# Daily evaporation of intercepted water (mm/day) aev_i', & ! aevi
'# Daily drought index drindd', & ! ddi
'# Demand for soil water of the cohort (mm/day) demand', & ! dem
'# Drought index for Photosyntheses calculation (cum) drindps', & ! dips
'# Unstressed stomatal conductance (mol/m2*d) gp', & ! gp
'# Number of growing season days per time step of photosynthesis ndaysps', & ! gsdps
'# Interception capacity (mm) sum of intcap(layer)', & ! intcap
'# Interception storage (mm) interc_st', & ! interc
'# Daily N demand per tree (g)', & ! Ndemc_d
'# Daily N uptake per tree (g)', & ! Nuptc_d
'# Daily N content of foliage per tree (g)', & ! N_fol
'# Daily N_pool per tree (g)', & ! N_pool
'# Daily photosynthesis nitrogen reduction factor [-]', & ! RedNc
'# Leaf respiration rate (g C/d) resp', & ! resp
'# Daily autotrophic respiration rate (g C/d) respaut', & ! respaut
'# Daily respiration rate of branches (g C/d) respbr', & ! respbr
'# Daily respiration rate of leaves (g C/d) respfol', & ! respfol
'# Daily heterotrophic respiration rate (g C/d) resphet', & ! resphet
'# Daily respiration rate of sapwood (g C/d) respsap', & ! respsap
'# Daily respiration rate of frt (g C/d) respfrt', & ! respfrt
'# Supply of soil water to roots of the cohort (mm/day) supply', & ! sup
'# Total fraction of PAR absorbed per m patch area (-) totFPAR'/ ! totfpar
DATA outcd%header / &
23*'# Day Year Coh1 Coh2 Coh3 Coh4 ...'/ ! ass, ddi, dem, gp, gsdps, res,
! resbr, ressap, resfrt, sup
! ----------------------------------------------------- !
! yearly output of cohorts
type (out_struct),dimension(58),target :: outcy
integer :: outcy_n = 58 ! number of all declared cohort output files
DATA outcy%kind_name /'age', 'ahb', 'ahbasrel', 'ahc', 'ahcasrel', 'asapw', 'atr', 'bioi', 'botlayer','cpa', 'crt', 'daybb', 'dcrb', 'diac', 'diam', &
'dtr', 'dwd','fol', 'foli', 'frt', 'frti', 'frtrel', 'frtrelc', 'geff', 'gfol', 'gfrt', 'grossass', 'gsap', &
'gsd', 'hbo', 'hea', 'hei', 'hrt', 'leaf', 'maintres', 'nas', 'npp', 'rdpt', 'rld', 'sap', &
'sfol', 'sfrt', 'spn', 'ssap', 'stem', 'str', 'tdb','toplayer', 'trman', 'ttb','Ndemc_c','Nuptc_c', &
'Nfol', 'Npool', 'Nstr','rooteff', 'watleft', 'yrw'/
DATA outcy%s_line /58*'# Cohort output'/ ! age, ahb, ahc, atr, asapw, bioi, botLayer, cpa, crt, daybb, dcrb, diac, diam,
! dtr, dwd, fol, foli, frt, frti, frtrel, geff, gfol, gfrt,
! grossass, gsap, gsd, hbo, hea, hrt, hei,
! leaf, maintres, nas, npp, rdpt, rld, sap, sfol, sfrt, spn,
! ssap, stem, str, tdb, topLayer, trman,ttb, Ndemc,Nuptc, rooteff,watleft
DATA outcy%f_line / &
'# Tree age (year)', & ! age
'# Cross sectional area of heartwood at stem base [cm**2] x_Ahb', & ! ahb
'# Relation of heartwood to sapwood at stem base', & ! ahbasrel
'# Cross sectional area of heartwood at crown base [cm**2] Ahc', & ! ahc
'# Relation of heartwood to sapwood at crown base', & ! ahcasrel
'# Cross sectional area of sapwood in bole space [cm**2] Asapw', & ! asapw
'# Number of alive trees per cohort', & ! atr
'# Net biomass increment (kg DM/year)', & ! bioi
'# Number of bottom layer of crown [-]', & ! botLayer
'# Cohort crown projection area (m2)', & ! cpa
'# coarse root biomass (kg DM/tree)', & ! crt
'# Day of leaf bud burst', & ! daybb
'# Diameter of stem at crown base (cm)',& ! dcrb
'# Drought index for allocation calculation (cum)', & ! diac
'# Diameter at breast height (cm)', & ! diam
'# Number of dead trees per cohort', & ! dtr
'# Stem biomass of dead trees per cohort', & ! dwd
'# Foliage biomass (kg DM/tree)', & ! fol
'# Foliage increment (kg DM/year/tree)', & ! foli
'# Fine root biomass (kg DM/tree)', & ! frt
'# Net fine root increment (kg DM/year/tree)', & ! frti
'# Relative fine root fraction of tree per soil layer (root profile)', & ! frtrel
'# Relative fine root fraction of cohort of total layer fine root mass per soil layer', & ! frtrel
'# Growth efficiency kg/m2', & ! geff
'# Gross growth rate foliage (kg DM/year/tree)', & ! gfol
'# Gross growth rate fine root (kg DM/year/tree)', & ! gfrt
'# Gross assimilation rate (kg DM/year/tree)', & ! grossass
'# Gross growth rate sapwood (kg DM/year/tree)', & ! gsap
'# Number of growing season days per year ndaysgr',& ! gsd
'# Bole height (cm)', & ! hbo
'# Number of years without stress', & ! hea
'# Total tree height (cm)', & ! hei
'# Heartwood biomass (kg DM/tree)', & ! hrt
'# Leaf area per tree (m2)', & ! leaf
'# Maintenance respiration (kg DM/year/tree)', & ! maintres
'# Net foliage assimilation rate (kg DM/year/tree)', & ! nas
'# NPP (kg DM/year/tree)', & ! npp
'# Rooting depth calculated with TRAP model[cm]', & ! rdpt
'# estimated root length density [cm]', & ! rld
'# Sapwood biomass (kg DM)', & ! sap
'# Senescence rate foliage (kg DM/year/tree)', & ! sfol
'# Senescence rate fine roots (kg DM/year/tree)', & ! sfrt
'# Species number of the cohort', & ! spn
'# Senescence rate sapwood (kg DM/year/tree)', & ! ssap
'# Stemwood biomass increment (kg DM/year/tree)', & ! stem
'# Number of stress years', & ! str
'# Total cohort dead biomass (kg DM/year/cohort)', & ! tdb
'# Number of top layer of crown [-]', & ! topLayer
'# Number of trees harvested by managment', & ! trman
'# Total tree biomass (kg DM/tree)', & ! ttb
'# N demand per tree and year (g)', & ! Ndemc_c
'# N uptake per tree and year (g)', & ! Nuptc_c
'# N content of foliage per tree and year (g)', & ! Nfol
'# N pool per tree and year (g)', & ! Npool
'# Ratio of N uptake to demand per tree and year', & ! Nstr
'# Root uptake efficiency factor', & ! rooteff
'# Water left in next layer', & ! watleft
'# Year ring width [mm]' / ! yrw
DATA outcy%header / &
58*'# Year Coh1 Coh2 Coh3 Coh4 ...'/ !age, ahb, ahc, atr, bioi, cpa, crt, daybb, dcrb, diac, diam,
! dtr, dwd, fol, foli, frt, frti, frtrel, geff, gfol, gfrt,
! gsap, gsd, hbo, hea, hrt, hei,
! leaf, maintres, nas, npp, rdpt, rld, sap, sfol, sfrt, spn,
! stem, str, tdb,trman, ttb, Ndemc,Nuptc, rooteff,watleft, yrw
! output at simulation end
type (out_struct),dimension(6),target :: oute
integer :: oute_n = 6 ! number of all declared end output files
DATA oute%kind_name /'sea', 'sea_ms', 'sea_npv', 'sea_st','wpm', 'wpm_inter'/
DATA oute%f_line / &
'# SEA: Costs and assets of standing stock, harvested timber, silvicultural costs, fix costs, and subsidies in euro/ha', &
'# SEA: Timber grading for harvested wood, m3/ha', &
'# SEA: liquidation value, npv, npv+ in euro/ha', &
'# SEA: Timber grading for standing stock, m3/ha', &
'# Wood product model output', &
'# Wood product model intermediate steps'/ !
DATA oute%s_line / &
'# shotcuts: sum: summe, st: standing stock, ms: harvested wood, fc: fix costs, sv: silvicultural costs, co: costs, as: assets, sub: subsidies, sp: spruce, be: beech, pi: pine, oa: oak, bi: birch, ' , &
'# Timber grades 1-7: 1-fue, 2-in, 3-LAS1a, 4-LAS1b, 5-LAS2a, 6-LAS2b, 7-LAS3a, 8-L2b, 9-L3a, 10-L3b ' , &
'# a: without discounting, b-d: interest rate (see "sea_prices.wpm" file) ' , &
'# Timber grades 1-7: 1-fue, 2-in, 3-LAS1a, 4-LAS1b, 5-LAS2a, 6-LAS2b, 7-LAS3a, 8-L2b, 9-L3a, 10-L3b ' , &
'# Carbon in different products, kg C/ha ' , &
'# Carbon in different products, kg C/ha tg: timber grades, il: industrial lines, pl: product lines'/
DATA oute%header / &
'# Year sum_all sum_st sum_ms sum_sv sum_fc sum_sub be_st_co sp_st_co pi_st_co oa_st_co bi_st_co |be_st_as sp_st_as pi_st_as oa_st_as bi_st_as |be_ms_co sp_ms_co pi_ms_co oa_ms_co bi_ms_co |be_ms_as sp_ms_as pi_ms_as oa_ms_as bi_ms_as fix_costs sub_har sub_sv_co sub_fix ', &! sea
'# Year be_tg1 be_tg2 be_tg5 be_tg6 be_tg7 be_tg8 be_tg9 be_tg10 &
&sp_tg1 sp_tg2 sp_tg4 sp_tg5 sp_tg6 sp_tg7 sp_tg8 sp_tg9 sp_tg10 &
&pi_tg1 pi_tg2 pi_tg3 pi_tg4 pi_tg5 pi_tg6 pi_tg7 pi_tg8 pi_tg9 pi_tg10 &
&oa_tg1 oa_tg2 oa_tg5 oa_tg6 oa_tg7 oa_tg8 oa_tg9 oa_tg10 &
&bi_tg1 bi_tg2 bi_tg5 bi_tg6 bi_tg7 bi_tg8 bi_tg9 bi_tg10', &! sea_ms
'# Year LVa LVb LVc LVd NPVa NPVb NPVc NPVd NPV+a NPV+b NPV+c NPV+d ', &! sea_npv
'# Year be_tg1 be_tg2 be_tg5 be_tg6 be_tg7 be_tg8 be_tg9 be_tg10 &
&sp_tg1 sp_tg2 sp_tg4 sp_tg5 sp_tg6 sp_tg7 sp_tg8 sp_tg9 sp_tg10 &
&pi_tg1 pi_tg2 pi_tg3 pi_tg4 pi_tg5 pi_tg6 pi_tg7 pi_tg8 pi_tg9 pi_tg10 &
&oa_tg1 oa_tg2 oa_tg5 oa_tg6 oa_tg7 oa_tg8 oa_tg9 oa_tg10 &
&bi_tg1 bi_tg2 bi_tg5 bi_tg6 bi_tg7 bi_tg8 bi_tg9 bi_tg10', &! sea_st
'# Year sum_input u1 u2 u3 u4 u5 u6 u7 sum_u1-7 burn&
& landfill atmo atmo_cum emission sub_energ sub_mat sub_sum', & ! wpm
'# Year tg1 tg2 tg3 tg4 tg5 tg6 il1 il2 il3 il4 il5 il6 il7 pl1 pl2 pl3 pl4 pl5 pl6 pl7 u1 u2 u3 u4 u5 u6 u7 '/ ! wpm_inter
! special output forms
INTEGER :: out_flag_light ! output flag light-file
INTEGER :: unit_err ! unit for error log file
INTEGER :: unit_trace ! unit for trace log file
INTEGER :: unit_sum ! unit for summation output (fluxes) file
INTEGER :: unit_comp1, unit_comp2 ! ncompressed output
INTEGER :: unit_light, unit_wat
INTEGER :: unit_ctr, unit_prod, unit_allo, unit_soil
INTEGER :: unit_soicnd, unit_soicna, unit_soicnr
! store output variables of veg-file
type out_veg
integer,dimension(3):: help_veg1
real,dimension(11):: help_veg2
real help_veg3
real :: help_veg4
real :: help_veg5
real :: help_veg6
end type out_veg
type (out_veg),allocatable,dimension(:),target :: sout
type (out_veg) :: vout
type out_C
real, dimension(366):: NEE ! net ecosystem exchange
real, dimension(366):: Resp_aut ! autotrophic respiration
end type out_C
type (out_C) :: Cout
character(100) :: mess_info = '# ' ! output of measurements: information line
end module data_out
!**************************************************************
source_code/version_2.3_windows/amod_par.f 0 → 100644
View file @ 82df1085
!*****************************************************************!
!* *!
!* 4C (FORESEE) Simulation Model *!
!* *!
!* *!
!*data module for a variety of parameters (non-species dependent)*!
!* *!
!* 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 *!
!* *!
!*****************************************************************!
module data_par
! from npp.f:
real :: pi = 3.1415926536 ! PI
real :: zero = 1.E-6 ! numerical zero
REAL :: lambda = 0.7 , & ! optimum ratio of ci to ca [-]
Cmass = 12.0 , & ! molar mass of carbon [g/mol]
gmin = 0.0 , & ! minimum conductance [mol/(m2*d)]
ps = 0.7 , & ! shape of PS response curve
pn = 0.025 , & ! slope of N function (eqn 27) at 20 �C [g(N) (mymol s-1)-1]
nc0 = 0.00715 , & ! minimum N content [g/g] (eqn 27)
qco2 = 0.08 , & ! C3 quantum efficiency (eqn 16)
qco2a = 1.0 , & ! scaling parameter (eqn A7)
o2 = 20.9 , & ! partial pressure of oxygen (kPa)
co2_st= 0.00035, & ! atmospheric CO2 content (mol/mol)
pfref = 0.2 , & ! albedo of the canopy
cpart = 0.5 , & ! part of C in biomass [-]
rmolw = 0.622 , & ! ratio of molecular weights of water and air
R_gas = 8.314 , & ! universal gas constant [J/mol/K] = [Pa/m3/K]
c_karman = 0.41 , & ! von Karman's constant [-]
c_air = 1.005 , & ! specific heat of air at const. pressure [J/g/K]
psycro =0.000662 , & ! psychrometer constant [hPa/K]
h_breast =137 , & ! breast height for inventory measurements [cm]
h_sapini = 200 , & ! height below which tree is initialised with sapling allometry
h_bo_br_diff = 50, & ! minimal difference between height of crown base and breast height
Q10_T = 2. ! used for calculation of dayfract from air temperature
DOUBLE PRECISION :: p0_co2 , & ! parameter variable for calculation of CO2 scenarios
p1_co2 , & ! parameter variable for calculation of CO2 scenarios
p2_co2 , & ! parameter variable for calculation of CO2 scenarios
p3_co2 , & ! parameter variable for calculation of CO2 scenarios
p4_co2 , & ! parameter variable for calculation of CO2 scenarios
p1_co2h , & ! parameter variable for calculation of historical CO2 scenarios
p2_co2h , & ! parameter variable for calculation of historical CO2 scenarios
p3_co2h , & ! parameter variable for calculation of historical CO2 scenarios
p4_co2h , & ! parameter variable for calculation of historical CO2 scenarios
p5_co2 ! parameter variable for calculation of CO2 scenarios
! Transformation coefficients
REAL :: gm2_in_kgha = 10. ! transf. coeff. from g/m2 in kg/ha
REAL :: kgha_in_gm2 = 0.1 ! transf. coeff. from kg/ha in g/m2
REAL :: gm2_in_tha = 0.01 ! transf. coeff. from g/m2 in t/ha
REAL :: tha_in_gm2 = 100. ! transf. coeff. from t/ha in g/m2
REAL :: kg_in_g = 1000. ! transf. coeff. from kg in g
REAL :: GR_in_PAR = 0.5*4.6/100. ! from global rad. in J/cm2 to PAR in mol/m2
! explanation of conversion factor:
! 0.5: PAR is 50% of incident radiation
! 4.6: 1 J = 4.6e-6 mol (Larcher 1995);
! 100: conversion J/cm2 -> MJ/m2
! soil parameter
real :: dens_om = 1.4 ! specific density of organic matter g/cm3
! parameter for snow
real :: temp_snow = 0.2 ! threshold of air temperature for snow accumulation
! parameter for calculation of potential evapotranspiration rate
real :: alpha_PT = 1.26 ! Priestley-Taylor coefficient
! parameter for calculation of transpiration demand
real :: alfm = 1.4
real :: gpmax = 14000. ! mol/(m2*d)
! parameter for growing degree day calculation
real :: thr_gdd = 5.
! van Genuchten parameter for flag_wred=9
real :: l_gnu = 0.5
! fol biomass per mistletoe [kg DW/tree], 1 Viscum (10years) see Pfiz 2010
real :: mistletoe_x_fol = 0.0158
! parameter for allocation to NSC-Pool
real :: decid_sap_allo = 0.042 !fraction of sapwood DW allocated to NSC-Pool for decidous tree species
real :: decid_tb_allo = 0.125 !fraction of twigs and branch DW allocated to NSC-Pool for decidous tree species
real :: decid_crt_allo = 0.125 !fraction of coarse root DW allocated to NSC-Pool for decidous tree species
real :: conif_sap_allo = 0.018 !fraction of sapwood allocated to NSC-Pool for coniferous tree species
real :: conif_tb_allo = 0.065 !fraction of twigs and branch allocated to NSC-Pool for coniferous tree species
real :: conif_crt_allo = 0.065 !fraction of coarse root DW allocated to NSC-Pool for coniferous tree species
! set of characters
character(len=*), parameter :: charset = &
"abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789.-_"
! test
real, allocatable, dimension(:,:) ::lambda_ts
end module data_par
source_code/version_2.3_windows/amod_plant.f 0 → 100644
View file @ 82df1085
!*****************************************************************!
!* *!
!* 4C (FORESEE) Simulation Model *!
!* *!
!* *!
!* data module for planting of seedlings/saplings *!
!* ! arrays have to be adapted to the species number ! *!
!* *!
!* 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 *!
!* *!
!*****************************************************************!
module data_plant
integer :: quspec= 2 ! number of planted species
integer, dimension(13) :: infspec=(/1,0,1,0,0,0,0,0,0,0,0,0,0/) ! sign of planted species = 0/1
integer, dimension(13) :: npl_mix =(/3000,0,6000,4500,0,0,0,0,0,0, 0, 0, 0/) ! number of plants in mixed stands
integer, dimension(13) :: numplant=(/178,6000,8000,9000,10000,0,8000,1666, 1140, 2000, 5000, 0, 0/) ! number of plants per ha
integer, dimension(13) :: specpl=(/1,2,3,4,5,6,7,8, 9, 10, 11, 12, 13/) ! number of species
real, dimension(13) :: plant_height=(/130.,37.5,17.5,40.,8.7,0.,17.5,40.,17.5, 30.0, 30.0, 0., 0./) ! mean height of plants
real, dimension(13) :: plant_hmin=(/70.,25.,10.,30.,3.,0.,10.,30., 10., 20., 10., 0.,0./) ! minimum height of plants
real, dimension(13) :: hsdev=(/3.33,4.1,7.5,3.33,5.9,0.0,7.5,3.33, 7.5,4.1, 7.5, 0.,0. /) ! standard deviation od height
real, dimension(13) :: pl_age=(/10.,4.,2.,2.,1.,0.,2.,1.,2.,2., 2., 0.,0./) ! age of plants
real :: kappa = 1.2 !1.2
real :: ksi = 2.99 !1.5
integer, dimension(11,10) :: m_numplant
integer, dimension(11,10) :: m_specpl
real, dimension(11,10) :: m_plant_height
real, dimension(11,10) :: m_plant_hmin
real, dimension(11,10) :: m_pl_age
real, dimension(11,10) :: m_hsdev
integer :: m_numclass
end module data_plant
source_code/version_2.3_windows/amod_simul.f 0 → 100644
View file @ 82df1085
!*****************************************************************!
!* *!
!* 4C (FORESEE) Simulation Model *!
!* *!
!* *!
!* module data_simul *!
!* *!
!* contains follow global subroutines: *!
!* GETUNIT() function for unit number handling *!
!* TESTFILE(infile,ex) subroutine for testing, if a file exists *!
!* ERRORFILE(infile,ios,unitnum) subroutine for messages *!
!* during file reading *!
!* *!
!* FUNCTION GETUNIT *!
!* *!
!* 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 *!
!* *!
!*****************************************************************!
module data_simul
integer :: anz_sim = 0 ! actual number of simulations
character(4) :: anh ! output file extension
integer :: time_b = 1951 ! start simulation year
integer :: time_cur ! current simulation year
integer :: clim_dt = 1 ! kind of climate resolution (daily/monthly) for weathergen.
integer :: repeat_number = 1 ! max. number of repeats
integer :: site_nr = 1 ! number of sites
integer :: year = 40 ! number of simulation years
integer :: ns_pro = 7 ! time step (days) for production module
integer :: ns_day ! loop variable for time step
integer :: ns ! loop variable for species
integer :: iday =1 ! actual day of simulation
integer :: ip ! loop variable for site_nr
integer :: time ! yearly loop variable in simulation_4c(from 1 to year)
integer :: monat
integer :: woche
integer :: flag_adapm = 0 ! flag for adaptive managemen:0/1(carried out last time step)
integer :: flag_bc = 0 ! flag for application of biochar (0 - no application)
integer :: flag_bc_add = 0 ! flag for output to file ...soil.ini for changes of soil parameters
! after addition of biochar (0 - no output)
integer :: flag_clim = 0 ! climate data for each site?(yes/no)
integer :: flag_climnam= 0 ! kind of generation of climate scenario names (flag_multi=8)
integer :: flag_co2 = 0 ! choice of amospheric CO2 scenario
integer :: flag_cohout = 1 ! flag for cohort output
integer :: flag_cohoutd= 1 ! flag for cohort output daily
integer :: flag_cohouty= 1 ! flag for cohort output yearly
integer :: flag_cond = 0 ! choice of heat conductance function
integer :: flag_cum = 0 ! internal flag of cumulativ calculations for output
integer :: flag_dayout = 0 ! flag of daily output
integer :: flag_decomp = 0 ! decomposition model
integer :: flag_depo = 0 ! deposition (set after reading file) 1 - mg/m2, 2 - mg/l
integer :: flag_dis = 0 ! choice of disturbance modus (1=on)
integer :: flag_hum = 0 ! internal flag for recalculation of field capcity etc. depending on humus
integer :: flag_end = 0 ! stop in partitio
integer :: flag_eva = 0 ! choice of evapotranspiration function
integer :: flag_folhei = 1 ! choice of foliage-height relationship
integer :: flag_lambda = 0 ! variable lambda time series/ FORSKA environmental factors and regeneration on/off(0)
integer :: flag_int = 0 ! choice of interception function
integer :: flag_inth = 0 ! internal flag for choice of interception function
integer :: flag_light = 3 ! flag for light absorption algorithm
integer :: flag_limi = 3 ! choice of limitations taken into account
integer :: flag_lit = 0 ! input of litter initialisation (internal control) (0 - no)
integer :: flag_mg = 0 ! choice of management (yes/no)
integer :: flag_mistle = 0 ! internal flag (1 = disturbance by mistletoe)
integer :: flag_mort = 1 ! mortality on/off
integer :: flag_multi = 0 ! Multiple run choice
integer :: flag_reg = 0 ! regeneration on/off
integer :: flag_resp = 0 ! choice of respiration modelling
integer :: flag_seedgr = 0 ! flag for weekly seedling growth
integer :: flag_sign = 0 ! choice of mode of calculation for sigman
integer :: flag_sens = 0 ! flag for sensitivity analysis (no input, derived from flag_multi)
integer :: flag_soilin = 0 ! internal flag for soil input version
integer :: flag_stand = 1 ! choice of initialization
integer :: flag_standup= 0 ! stand structure changed (1 - removal of trees, 2 - neww trees)
integer :: flag_stat = 0 ! flag for comparison with measurements
integer :: flag_sum = 0 ! flag for summation output
integer :: flag_sveg = 0 ! flag for soilvegetation (0 = no, 1 = intialis.)
integer :: flag_volfunc= 1 ! choice of volume function for trunc
integer :: flag_wred = 1 ! choice of soil water uptake function
integer :: flag_wurz = 0 ! choice of root distribution function
integer :: flag_wpm = 0 ! wpm flag
integer :: time_out = 1 ! time step of yearly output; compressed output if < 0
integer :: flag_cumNPP = 0 ! time step of summation of yearly NPP for mean yearly NPP in compressed output
logical :: flag_tree = .TRUE. ! internal flag : .TRUE. - all cohorts are trees
logical :: flag_redn =.FALSE. ! internal flag : .TRUE. - Redn<0 for at least one species
logical :: flag_mult9 = .TRUE. ! internal flag : .TRUE. - first run with flag_multi=9
logical :: flag_mult910 = .TRUE. ! internal flag : .TRUE. - runs with flag_multi=9 or flag_multi=10
logical :: flag_mult8910 = .TRUE. ! internal flag : .TRUE. - runs with flag_multi=8 or flag_multi=9 or flag_multi=10
logical :: flag_trace = .TRUE. ! internal flag : .TRUE. - output of trace.log
logical :: lmulti = .FALSE. ! stand initialisation file with several stands
logical :: lcomp1 = .TRUE. ! compressed output with start values
logical :: leaves_on = .false. ! detection of periods with lai > 0
integer :: all_leaves_on = 0 ! detection of periods with maximal lai
real :: thr_height = 50. ! threshold of height for ingrowth
integer :: n_T_downsteps = 0 ! number of steps to decrease temperature in multi-run 2
integer :: n_T_upsteps = 0 ! number of steps to increase temperature in multi-run 2
integer :: n_P_downsteps = 0 ! number of steps to decrease precipitation in multi-run 2
integer :: n_P_upsteps = 0 ! number of steps to increase precipitation in multi-run 2
real :: step_sum_T = 0. ! additive step for temperature change in multi-run 2
real :: step_fac_P = 0. ! factorial step for precipitation change in multi-run 2
real :: deltaT = 0. ! additive change of temperature
real :: deltaPrec = 1. ! factorial change of precipitation
integer :: jpar ! number (array size) of changed parameter (multi run)
real, dimension(200) :: vpar = -99.0 ! store of parameter changes (multi run)
character(30), dimension(50) :: outy_file ! name of yearly output files
integer :: nyvar ! number of yearly output files
character(30), dimension(50) :: outd_file ! name of daily output files
integer :: ndvar ! number of daily output files
character(30), dimension(50) :: outc_file ! name of cohort output files
integer :: ncvar ! number of cohort output files
integer :: ncdvar ! number of daily cohort output files
character(100), dimension(200) :: simpar ! name of changed parameter (multi run)
character(30), dimension(50) :: outvar ! name of output variables (multi run 4, 8, 9, 10)
integer :: nvar ! number of output variables (multi run 4, 8, 9, 10)
integer :: output_unit_all ! output unit number of all selected yearly variables (multi run 9, 10)
integer :: output_unit_all_m ! output unit number of all selected monthly variables (multi run 9, 10)
integer :: output_unit_all_w ! output unit number of all selected weekly variables (multi run 9, 10)
real,allocatable,save,dimension(:,:,:) :: output_var ! value array of output variables (multi run 4, 8, 9, 10)
! (number of output variable, site ip, year)
real,allocatable,save,dimension(:,:,:,:):: output_varm ! value array of monthly output variables (multi run 4, 8, 9, 10)
! (number of output variable, site ip, year, month)
real,allocatable,save,dimension(:,:,:,:):: output_varw ! value array of weekly output variables (multi run 4, 8, 9, 10)
! (number of output variable, site ip, year, week)
integer,allocatable,save,dimension(:) :: output_unit ! array of output unit numbers (multi run 9, 10)
integer,allocatable,save,dimension(:) :: output_unit_mon ! array of output unit numbers for monthly values
character(10), dimension(10) :: typeclim ! array of type of climate scenarios (multi run 9)
real,allocatable,save,dimension(:,:,:,:) :: climszenres ! data file with results from climate scenarios (flag_multi=9, 10)
! (number of output variable, site ip, climate scenario type, realization)
real,allocatable,save,dimension(:,:,:,:,:):: climszenyear ! data file with yearly results from climate scenarios (flag_multi=9, 10)
! (number of output variable, site ip, climate scenario type, realization, year)
real,allocatable,save,dimension(:,:,:,:,:):: climszenmon ! data file with monthly results from climate scenarios (flag_multi=9, 10)
! (number of output variable, site ip, climate scenario type, realization, month)
real,allocatable,save,dimension(:,:,:,:,:):: climszenweek ! data file with weekly results from climate scenarios (flag_multi=9, 10)
! (number of output variable, site ip, climate scenario type, realization, week)
character(150),allocatable,save,dimension(:) :: site_name ! names of simulation sites
character(150) :: site_name1 ! name of first simulation site (multi run 9)
integer :: allunit = 10 ! variable for function getunit
character(150):: actdir ! actual directory
character(150):: dirout = 'output/' ! directory of output files
character(150):: dirin = 'input/' ! directory of input files
character(150) :: simfile = 'test0.sim' ! default simulation parameter file
character(300),allocatable,save,dimension(:) :: climfile ! climate data file
character(300),allocatable,save,dimension(:,:,:) :: climszenfile ! data file from climate scenarios (flag_multi=9)
character(150),allocatable,save,dimension(:) :: sitefile ! site specific parameter file
character(150),allocatable,save,dimension(:) :: valfile ! soil start value file
character(150),allocatable,save,dimension(:) :: treefile ! tree initialization file
character(150),allocatable,save,dimension(:) :: manfile ! management file
character(150),allocatable,save,dimension(:) :: wpmfile ! wpm spinup file
character(150),allocatable,save,dimension(:) :: specfile ! species parameter file
character(150),allocatable,save,dimension(:) :: depofile ! deposition file
character(150),allocatable,save,dimension(:) :: redfile ! file of redN for each species
character(150),allocatable,save,dimension(:) :: litfile ! file of litter initialisation for each fraction and species
integer,allocatable,save,dimension(:) :: fl_co2 ! flag_co2 for flag_multi = 7
character(50),allocatable,save,dimension(:) :: standid ! stand identifier
character(50), allocatable, dimension(:) :: standid_list ! List of stand identifier in input file
real, allocatable, dimension(:,:) :: redN_list ! List of of RedN per species in con-file with flag_multi=8,9
integer :: anz_standid
logical :: lstandid
integer :: nrreal ! number of realizations of climate scenarios (flag_multi=9)
integer :: nrclim ! number of types of climate scenarios (flag_multi=9)
integer :: iclim ! actual number of climate scenario type (flag_multi=9)
integer :: site_anz ! number of all simulation runs for flag_multi=9
integer,dimension(12) :: monrec ! Anzahl Tage im Monat
integer :: dclass_w = 5 ! class width for diameter classification
!----------------------------------------------------------------------
contains
integer function getunit()
logical logo
inquire(allunit, opened=logo)
if(logo) allunit = allunit+1
if(allunit==5.or.allunit==6) allunit=7
getunit = allunit
end function getunit
!----------------------------------------------------------------------
subroutine testfile (infile,ex)
! test whether the file exists
character a
character(len=*),intent(inout) ::infile
logical, intent(out):: ex
ex = .false.
do
inquire (File = infile, exist = ex)
if (ex .eqv. .false.) then
print *, ' >>>foresee message: File ',trim(infile),' not exists !'
write (*,'(A)') ' (0)STOP program'
write(*,'(A)') ' (1) Repeat filename input (def)'
write(*,'(A)',advance='no') ' (2) Return to input choice: '
read (*,'(A)') a
select case(a)
case('0')
stop
case(' ','1')
write(*,'(A)',ADVANCE='NO') ' New filename: ';read (*,'(A75)')infile
case('2')
ex = .false.; exit
end select
else
if (flag_multi .ne. 9) print *, ' >>>foresee message: Filetest - file ',trim(infile),' exists! '
exit
end if
end do
end subroutine testfile
!----------------------------------------------------------------------
subroutine errorfile (infile, ios, unitnum)
! error message during file reading
integer ios, unitnum
logical ex
character(150) infile
character a
if (ios .ne. 0) then
print *,' >>>foresee message: error during file ',trim(infile),' reading!'
ex = .false.
write(*,'(A)',advance='no')' STOP program (y/n)? '
read *, a
if (a .eq. 'y' .or. a .eq. 'Y') then
print *,' Program will stop!'
stop
end if
else
if (flag_multi .ne. 9) print *,' >>>foresee message: reading file ',trim(infile),' completed'
endif
close (unitnum)
if (flag_multi .ne. 9) print *,' '
end subroutine errorfile
end module data_simul
source_code/version_2.3_windows/amod_site.f 0 → 100644
View file @ 82df1085
!*****************************************************************!
!* *!
!* 4C (FORESEE) Simulation Model *!
!* *!
!* *!
!* data module for site data *!
!* *!
!* 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 *!
!* *!
!*****************************************************************! *!
MODULE data_site
INTEGER :: patch_id ! Patch identifier
character(50) :: stand_id ! Stand identifier
REAL :: xlat ! latitude in radians
REAL :: lat = 52.24 ! Default Potsdam coordinates
REAL :: long = 13.04
REAL, DIMENSION(:), ALLOCATABLE :: latitude ! array of latitudes for multi run 8
REAL, ALLOCATABLE, DIMENSION(:) :: NHdep ! yearly deposition
REAL, ALLOCATABLE, DIMENSION(:) :: NOdep ! yearly deposition
INTEGER, ALLOCATABLE, DIMENSION(:) :: gwtable ! groundwater level class
! 1: 0 - 0.5 m
! 2: 0.5 - 1.0 m
! 3: 1.0 - 1.5 m
! 4: 1.5 - 2.0 m
! 5: > 2.0 m
character(50),ALLOCATABLE, DIMENSION(:) :: sitenum
! KLara
character(50),ALLOCATABLE, DIMENSION(:) :: clim_id
! WK
CHARACTER(13),ALLOCATABLE, DIMENSION(:) :: soilid
END module data_site
source_code/version_2.3_windows/amod_soil.f 0 → 100644
View file @ 82df1085
!*****************************************************************!
!* *!
!* 4C (FORESEE) Simulation Model *!
!* *!
!* *!
!* data modules of soil submodels *!
!* *!
!* containes: *!
!* DATA_SOIL *!
!* DATA_SOIL_CN *!
!* HELP_SOIL_CN *!
!* DATA_SOIL_T *!
!* DATA_SOIL_PARAM *!
!* *!
!* 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 *!
!* *!
!*****************************************************************!
module data_soil
! Variables and parameters of soil model
integer :: soil_id = -1 ! soil type identification
integer :: nlay = -1 ! number of soil layers
integer :: nroot_max = 1 ! number of rooting layers
integer :: s_typen = -1 ! soil type number: 1 - sand, 2 - loam,
! 3 - silt, 4 - clay
integer :: nlgrw ! number of layer with ground water
real :: grwlev ! groundwater level
real :: rmass1 ! rest of dry mass , 1. layer
! arrays with dimension nlay
real, allocatable, save, dimension(:) :: &
! Description of soil layers
thick, & ! thickness of the layer cm
mid, & ! middle of the layer cm
depth, & ! depth of the layer cm
! soil parameter
pv, & ! pore volume mm
pv_v, & ! pore volume vol%
dens, & ! soil density g/cm3
field_cap ,& ! field capacity mm
wilt_p ,& ! wilting point mm
f_cap_v ,& ! field capacity vol-%
wilt_p_v ,& ! wilting point vol%
spheat, & ! specific heat capacity J/(g K)
phv, & ! pH-value
quarzv, & ! content of quarz (Vol%)
sandv, & ! content of sand (Vol%, input: Mass%)
clayv, & ! content of clay (Vol%, input: Mass%)
siltv, & ! content of silt (Vol%, input: Mass%)
humusv, & ! content of humus (Vol%, input: Mass%)
skelv, & ! content of skeleton Vol%
skelfact, & ! skeleton factor for water calculation
vol, & ! volume of layer (cm3)
dmass, & ! dry mass of layer (g/m2)
! model parameter
wlam, & ! Lambda parameter for percolation
! soil state variables
wats, & ! water content mm
wats_1, & ! water content of previous day mm
watvol, & ! water content in vol%
wat_res, & ! water uptake resistance
perc, & ! percolation water mm
wupt_r, & ! water uptake by roots mm
wupt_ev, & ! water taking by evaporation mm
temps, & ! soil temperature ¡C
! soil help variables
fcaph, & ! field capacity without humus vol%
wiltph, & ! wilting point without humus vol%
pvh, & ! pore volume without humus vol%
! soil stress variables
BDopt, & ! optimum bulk density for root growth
fr_loss, & ! yearly fine root loss [%]
redis ! yearly part of redistribution [%]
integer, allocatable, save, dimension(:) :: &
s_drought ! number of drought days per layer
! other scalar state variables and parameter
integer :: snow_day = 0 ! days with continious snow cover day
real :: snow = 0. ! water equivalent of snow mm
real :: snow_m = 0. ! water from melting of snow mm
real :: cover = -99. ! percent of covering
real :: grwsup ! groundwater supply per day
real :: bucks_root ! bucket size (mm) of rooting zone
real :: bucks_100 ! bucket size (mm) of 1 m depth
real :: thick_1 ! thickness of first layer (old value)
! disturbance variable if xylem disturbance influence water uptake
real :: xylem_dis ! percentage of root water uptake reduction by xylem disturbance (flag_dis=1)
! yearly cumulative quantities
real :: perc_cum = 0. ! cumulative percolation water from last layer
real :: perc_sum = 0. ! sum of percolation water from last layer for weeks or months
real :: wupt_r_c = 0. ! cumulative water uptake by roots
real :: wupt_e_c = 0. ! cumulative soil evaporation
real :: wupt_cum = 0. ! cumulative whole water uptake
real :: wat_tot = 0. ! total water content of the soil profile
real :: grwsup_cum=0. ! groundwater supply per year
real, dimension(12) :: perc_mon ! monthly percolation water from last layer
real, dimension(53) :: perc_week ! wekkly percolation water from last layer
! mean quantities (per year)
real :: perc_m = 0. ! mean yearly percolation water from last layer
real :: wupt_r_m = 0. ! mean yearly water uptake by roots
! parameter
real :: fakt = 0.4 ! percolation factor
real :: w_ev_d = 7. ! depth of water taking out by evaporation (cm)
integer :: n_ev_d = 1 ! corresponding number of layer for w_ev_d
real, allocatable, save, dimension(:,:) :: xwatupt ! temp. aux. field of water uptake per cohort and layer
! arrays of given root distribution (defined input)
real, allocatable, save, dimension(:) :: root_fr ! root fraction per soil layer
! yearly fine root loss after Rasse et al. 2001
integer :: rdepth_kind ! kind of calculation of root depth
real, allocatable, dimension(:) :: wat_left ! auxiliary variable for coh%watleft to determin annual sum of available water in soil layer boardering on root zone
real, allocatable, dimension(:) :: wat_root ! auxiliary variable for coh%watleft to determin annual sum of availabel water in soil layer boardering on root zone
integer, allocatable, dimension(:) :: root_lay ! auxiliary variable for coh%nroot to determin root zone layer
real, allocatable, dimension(:) :: gr_depth ! auxiliary variable for coh%x_rdpt to determin annual sum of root growth
end module data_soil
!------------------------------------------------------------------------
module data_soil_cn
! Variables and parameters of soil_cn-model
integer :: nspeclit = 5 ! number of species-litter for decomposition and min.
integer :: kmint = 1 ! kind of reduction function of min. for temp.
integer :: knitt = 1 ! kind of reduction function of nit. for temp.
integer :: kminw = 1 ! kind of reduction function of min. for water
integer :: knitw = 1 ! kind of reduction function of nit. for water
! arrays with dimension nlay
real, allocatable, save, dimension(:) :: &
! C and N pools per layer
C_opm, & ! whole C-content of dead biomass per layer without stems / g/m2
C_hum, & ! C-content of humus per layer / g/m2
N_opm, & ! whole N-content of dead biomass per layer without stems / g/m2
N_hum, & ! N-content of humus per layer / g/m2
C_opmfrt, & ! C-content of dead fine roots per layer / g/m2
N_opmfrt, & ! N-content of dead fine roots per layer / g/m2
C_opmcrt, & ! C-content of dead coarse roots per layer / g/m2
N_opmcrt, & ! N-content of dead coarse roots per layer / g/m2
C_bc, & ! C-content of biochar per layer / g/m2
N_bc, & ! N-content of biochar per layer / g/m2
NH4, & ! NH4-content of the soil layer / g/m2
NO3, & ! NO3-content of the soil layer / g/m2
Nupt, & ! N uptake from the soil layer / g/m2
Nmin, & ! N mineralisation per day and soil layer / g/m2
! model parameter
rmin_phv, & ! reduction of mineralization depending on pH-value
rnit_phv, & ! reduction of nitrification depending on pH-value
cnv_opm, & ! C/N-ratio of dead biomass
cnv_hum, & ! C/N-ratio of humus
cnv_bc, & ! C/N-ratio of biochar
cpart_bc, & ! part of C in biochar
dens_bc ! density of biochar
real, allocatable, save, dimension(:) :: &
C_bc_appl,& ! C-content of biochar application per layer / g/m2
N_bc_appl ! C/N-ratio of biochar application per layer / g/m2
integer, allocatable, save, dimension(:) :: &
y_bc, & ! year of application of biochar
bc_appl_lay ! layer of biochar application
real :: Nleach ! N leaching from last layer per day / g/m2
real :: Nupt_d ! total daily N uptake / g/m2
real :: NH4_in, NO3_in ! input of NH4 and NO3 into the actual layer as
! deposition or transport / g/m2
real :: respsoil ! daily heterotrophic respiration / gC/m2
! Model parameter
real :: k_nit =0.0025 ! nitrification constant / per day
real :: pNH4f =0.1 ! part of free available NH4-N
real :: pNO3f =1.0 ! part of free available NO3-N
real :: k_hum_r=0.0003 ! mineralization constant of humus in mineral soil / per day
real :: k_hum =0.0002 ! mineralization constant of humus in humus layer / per day
real :: k_bc =0.00001 ! mineralization constant of biochar / per day
real :: k_syn_bc =0.003 ! synthesis coefficient of biochar / per day
integer :: y_bc_n ! actual array number of list of biochar application
integer :: n_appl_bc ! number of biochar applications
type species_litter
character (len=20) :: species_name
! soil C- and N-pools of primary organic matter per species and fraction
real :: C_opm_fol ! C-content of foliage litter pool / g/m2
real :: N_opm_fol ! N-content of foliage litter pool / g/m2
real :: C_opm_tb ! C-content of twigs and branches litter pool / g/m2
real :: N_opm_tb ! N-content of twigs and branches litter pool / g/m2
real :: C_opm_stem ! C-content of stemwood litter pool / g/m2
real :: N_opm_stem ! N-content of stemwood litter pool / g/m2
real,dimension(50):: C_opm_frt ! C-content of fine root litter pool / g/m2
real,dimension(50):: N_opm_frt ! N-content of fine root litter pool / g/m2
real,dimension(50):: C_opm_crt ! C-content of coarse root litter pool / g/m2
real,dimension(50):: N_opm_crt ! N-content of coarse root litter pool / g/m2
! C/N-ratios of organic primary matter fractions
real :: cnv_opm_fol ! C/N-ratio of foliage litter pool
real :: cnv_opm_tb ! C/N-ratio of twigs, branches litter pool
real :: cnv_opm_stem ! C/N-ratio of stemwood litter pool
real :: cnv_opm_frt ! C/N-ratio of fine root litter pool
real :: cnv_opm_crt ! C/N-ratio of coarse root litter pool
end type species_litter
type (species_litter),allocatable,dimension(:),target :: slit, slit_1
! yearly and cumulative quantities
real :: N_min = 0. ! cumulative netto mineralisation per year
real :: N_min_m = 0. ! mean cumulative netto mineralisation of all years
real :: N_tot = 0. ! total N content of the soil profil at the end of the year
real :: C_tot = 0. ! total C content of the soil profil at the end of the year
real :: N_lit = 0. ! N content of total litter per year
real :: C_lit = 0. ! C content of total litter per year
real :: N_lit_m = 0. ! mean cumulative N content of total litter of all years
real :: C_lit_m = 0. ! mean cumulative C content of total litter of all years
real :: N_lit_fol = 0. ! N content of foliage litter per year
real :: C_lit_fol = 0. ! C content of foliage litter per year
real :: N_lit_frt = 0. ! N content of fine root litter per year
real :: C_lit_frt = 0. ! C content of fine root litter per year
real :: N_lit_crt = 0. ! N content of coarse root litter per year
real :: C_lit_crt = 0. ! C content of coarse root litter per year
real :: N_lit_tb = 0. ! N content of litter from twigs and branches per year
real :: C_lit_tb = 0. ! C content of litter from twigs and branches per year
real :: N_lit_stem = 0. ! N content of new dead stems per year
real :: C_lit_stem = 0. ! C content of new dead stems per year
real :: N_hum_tot = 0. ! N content of total humus
real :: C_hum_tot = 0. ! C content of total humus
real :: N_an_tot = 0. ! total anorganic N
real :: Nupt_c = 0. ! total N uptake per year / g N/m2
real :: Nupt_m = 0. ! mean total N uptake per year
real :: Nleach_c = 0. ! cumul. N leaching from last layer per year
real :: Nleach_m = 0. ! mean cumulative N leaching from last layer of all years
real :: resps_c = 0. ! yearly soil respiration / gC/m2
real :: resps_c_m = 0. ! mean yearly soil respiration / gC/m2
real :: C_opm_fol ! C-content of total foliage litter pool / g/m2
real :: N_opm_fol ! N-content of total foliage litter pool / g/m2
real :: C_opm_stem ! C-content of total stemwood litter pool / g/m2
real :: N_opm_stem ! N-content of total stemwood litter pool / g/m2
real :: C_opm_tb ! C-content of total twigs, branches root litter pool / g/m2
real :: N_opm_tb ! N-content ofv twigs, branches litter pool / g/m2
real :: C_opm_frt ! C-content of total fine root litter pool / g/m2
real :: N_opm_frt ! N-content of total fine root litter pool / g/m2
real :: C_opm_crt ! C-content of total coarse root litter pool / g/m2
real :: N_opm_crt ! N-content of total coarse root litter pool / g/m2
real :: C_accu = 0. ! C accumulation (new C_tot - old C_tot) / t C/ha
! (mean of all years at the end of simulation)
real :: C_hum_1 ! C content in humus of the litter layer / t C/ha
real :: C_tot_1 ! total C content of the litter layer / t C/ha
real :: C_hum_40 ! C content in humus of the soil profil up to 40cm depth / t C/ha
real :: C_tot_40 ! total C content of the soil profil up to 40cm depth / t C/ha
real :: C_hum_80 ! C content in humus of the soil profil up to 80cm depth / t C/ha
real :: C_tot_80 ! total C content of the soil profil up to 80cm depth / t C/ha
real :: C_hum_100 ! C content in humus of the soil profil up to 100cm depth / t C/ha
real :: C_tot_100 ! total C content of the soil profil up to 100cm depth / t C/ha
real :: C_bc_tot ! total C content of biochar / g C/m2
real :: N_bc_tot ! total N content of biochar / g N/m2
real, dimension(12) :: resps_mon ! mean monthly soil respiration / gC/m2
real, dimension(53) :: resps_week ! mean weekly soil respiration / gC/m2
real, allocatable, save, dimension(:,:) :: xNupt ! temp. aux. field of N uptake per cohort and layer
integer unit_litter
end module data_soil_cn
!------------------------------------------------------------------------
module help_soil_cn
! internal variables for decomposition calculation
real khr, knr, ks, kbc ! reduced humif., nitr. and syth. coeff.
real remin ! reduction function of mineralisation
real reptermc, reptermn ! reprod. terms of C-/ N-pools
real term1, term2, term3, term4 ! parts of equ. III
real hexph, hexpn ! exponential parts
real cnvh ! reciprocal C/N-ratio of humus
end module help_soil_cn
!------------------------------------------------------------------------
module data_soil_t
! Variables and parameters for soil temperature calculation
integer :: flag_surf = 0 ! calculation of soil surface temperature
! 0 - surface temperature equals temperature of first layer
! 1 - with explicit surface temperature
real temps_surf ! soil surface temperature
real hflux_surf ! soil heat flux at soil surface
! model parameters
real :: C0 = 0.76, & ! coefficients for calculation of surface temperature
C1 = 0.05, &
C2 = 0.3
! arrays with dimension nlay2
real, allocatable, save, dimension(:) :: &
t_cond, & ! thermal conductivity J/(cm s K)
t_cb , & ! weighted mean of thermal conductivity (term of values b)
h_cap, & ! heat capacity J/(cm3 K)
t_diff ! thermal diffusivity cm2/s
! internal variables for calculation of thermal conductivity
type therm_par ! parameter of soil fractions (particles)
real:: vf ! volume fraction
real:: hc ! heat capacity J/(cm3 K)
real:: tc ! thermal conductivity J/(cm s K)
real:: kwa ! weighting factor k for continous medium air
real:: kww ! weighting factor k for continous medium water
real:: ga ! shape factor of particles
end type therm_par
type (therm_par):: water
type (therm_par):: quarz
type (therm_par):: clay
type (therm_par):: silt
type (therm_par):: humus
type (therm_par):: air
type (therm_par):: ice
type (therm_par):: stone
! internal variables for the numerical solution
integer :: nlay1, nlay2 ! number of 2 additional layers
! diagonals of the matrix
! arrays with dimension nlay2
real, allocatable, save, dimension(:) :: &
sb, & ! term of values b (reciprocal mean of thickness)
sv, & ! thickness times time step
sh, & ! thickness
sbt, & ! aux. array of soil temperature
sxx, & ! right side and result (soil temperature)
svv, & ! thickness times heat capacity
svva,& ! svv from previous time step
soh ! Hauptdiagonale
! array with dimension nlay2+1
real, allocatable, save, dimension(:) :: son ! Nebendiagonale
integer mfirst ! first elemet number of matrix
logical lfirst ! .true for the first time
! variables for Fourier analysis
integer :: NK ! Anzahl der Fourier-Koeffizienten
real, dimension(200) :: FTA, FTO ! Fourier-Koeffizienten
real, dimension(366) :: Four_sp ! Stuetzstellen
real :: TQ ! mittlere Temp.
integer :: it = 1 ! Starttag fuer Temp.-Profil
end module data_soil_t
!------------------------------------------------------------------------
module data_soil_param
! soil type parameters
real, dimension(13):: grwdist ! distance groundwater level to root depth
type soiltype
character(10) :: stype ! soil type
real :: lambda ! percolation coefficient lambda
real, dimension(13):: rate ! supply of groundwater to root
end type soiltype
type(soiltype), dimension(40):: soil ! parameter setting in subroutine soil_ini_param
DATA grwdist / 20, 30, 40, 50, 60, 70, 80, 90, 100, 120, 140, 170, 200/
DATA soil%stype / 'Ss','gS','mS','fS','Su2','St2','Sl2','Su3','St3','Sl3','Su4','Slu','Sl4','Ls2', &
'Ls4','Lt2','Ts3','Ts4','Lts','Lt3','Tu3','Tu4','Tt','Tu2','Ts2','Tl','Lu', &
'Ut4','Us','Uls','Ut2','Ul2','Ut3','Ul3','Uu','Hum','Hh','Hu','Hn','' /
DATA soil%lambda / 1.50, 1.50, 1.50, 1.15, 0.90, 0.67, 0.60, 0.50, 0.30, 0.38, 0.37, 0.27, 0.30, &
0.30, 0.24, 0.23, 0.23, 0.22, 0.22, 0.22, 0.24, 0.26, 0.30, 0.15, 0.15, 0.15, &
0.15, 0.27, 0.25, 0.29, 0.29, 0.27, 0.27, 0.25, 0.25, 0.27, -99., -99., -99., -99. /
DATA soil(1)%rate / 5.2, 5.0, 1.5, 0.5, 0.2, 0.1, 0, 0, 0, 0, 0, 0, 0.0 /
DATA soil(2)%rate / 5.2, 5.0, 1.5, 0.5, 0.2, 0.1, 0, 0, 0, 0, 0, 0, 0.0 /
DATA soil(3)%rate / 5.8, 5.5, 5.3, 3, 1.2, 0.5, 0.2, 0.1, 0, 0, 0, 0, 0 /
DATA soil(4)%rate / 5.8, 5.5, 5.3, 5.1, 3, 1.5, 0.7, 0.3, 0.15, 0.1, 0, 0, 0 /
DATA soil(5)%rate / 5.8, 5.5, 5.3, 5.1, 4.5, 2.5, 1.5, 0.7, 0.4, 0.1, 0.08, 0, 0 /
DATA soil(6)%rate / 5.8, 5.5, 5.3, 5.1, 4.5, 2.5, 1.5, 0.7, 0.4, 0.1, 0.08, 0, 0 /
DATA soil(7)%rate / 5.8, 5.5, 5.3, 5.1, 4.5, 2.5, 1.5, 0.7, 0.4, 0.1, 0.08, 0, 0 /
! 6 > 5.0;> 5.0;> 5.0;> 5.0;4.5;2.5;1.5;0.7;0.4;0.1;< 0.1;0;0;;;;;;;;;;;;;;;;;;;;;;;;;;;;
! 7 > 5.0;> 5.0;> 5.0;> 5.0;4.5;2.5;1.5;0.7;0.4;0.1;< 0.1;0;0;;;;;;;;;;;;;;;;;;;;;;;;;;;;
! 8 > 5.0;> 5.0;> 5.0;> 5.0;5;3.5;2;1.5;0.8;0.3;0.1;< 0.1;0;;;;;;;;;;;;;;;;;;;;;;;;;;;;
! 9 > 5.0;> 5.0;> 5.0;> 5.0;3;2;1;0.7;0.4;0.15;< 0.1;0;0
! 10 > 5.0;> 5.0;> 5.0;> 5.0;5;3.5;2;1.5;0.8;0.3;0.1;< 0.1;0
! 11 > 5.0;> 5.0;> 5.0;> 5.0;> 5.0;> 5.0;5;3;2;1;0.5;0.15;0
! 12 > 5.0;> 5.0;> 5.0;> 5.0;> 5.0;> 5.0;5;3;2;1;0.5;0.15;0
! 13 > 5.0;> 5.0;> 5.0;> 5.0;3;2;1;0.7;0.4;0.15;< 0.1;0;0
! 14
! 15 > 5.0;> 5.0;> 5.0;3.5;2;1.3;0.8;0.5;0.3;0.15;< 0.1;0;0
! 16 > 5.0;> 5.0;> 5.0;3.5;2;1.3;0.8;0.5;0.3;0.15;< 0.1;0;0
! 17 > 5.0;> 5.0;> 5.0;3.5;2;1.3;0.8;0.5;0.3;0.15;< 0.1;0;0
! 18 > 5.0;> 5.0;4;2;1;0.7;0.5;0.3;0.2;0.1;< 0.1;0;0
! 19
! 20
! 21 > 5.0;> 5.0;2.5;1.2;0.7;0.5;0.3;0.2;0.15;< 0.1;0;0;0
! 22 > 5.0;> 5.0;2.5;1.2;0.7;0.5;0.3;0.2;0.15;< 0.1;0;0;0
! 23 > 5.0;> 5.0;4;2;1;0.7;0.5;0.3;0.2;0.1;< 0.1;0;0
! 24 > 5.0;> 5.0;> 5.0;> 5.0;4.5;3.5;2.5;2;1.5;0.8;0.4;0.2;< 0.1
! 25 4;2;1.1;0.7;0.5;0.4;0.35;0.3;0.22;0.17;0.14;0.1;< 0.1
! 26 4;2;1.1;0.7;0.5;0.4;0.35;0.3;0.22;0.17;0.14;0.1;< 0.1
! 27
! 28 4;2;1.1;0.7;0.5;0.4;0.35;0.3;0.22;0.17;0.14;0.1;< 0.1
! 29 > 5.0;> 5.0;> 5.0;> 5.0;4.5;3.5;2.5;2;1.5;0.8;0.4;0.2;< 0.1
! 30 > 5.0;> 5.0;> 5.0;> 5.0;4.5;3.5;2.5;2;1.5;0.8;0.4;0.2;< 0.1
! 31 > 5.0;> 5.0;> 5.0;> 5.0;> 5.0;> 5.0;> 5.0;5;3.5;2;1;0.5;0.15
! 32 > 5.0;> 5.0;> 5.0;> 5.0;> 5.0;> 5.0;4.5;3;2.5;1.5;0.7;0.3;0.1
! 33 > 5.0;> 5.0;> 5.0;> 5.0;> 5.0;> 5.0;4.5;3;2.5;1.5;0.7;0.3;0.1
! 34
! 35 > 5.0;> 5.0;> 5.0;> 5.0;> 5.0;> 5.0;4.5;3;2.5;1.5;0.7;0.3;0.1
! 36
! 37 > 5.0;> 5.0;> 5.0;> 5.0;> 5.0;> 5.0;> 5.0;5;3.5;2;1;0.5;0.15
end module data_soil_param
source_code/version_2.3_windows/amod_spec.f 0 → 100644
View file @ 82df1085
!*****************************************************************!
!* *!
!* 4C Simulation Model: Module data_species *!
!* *!
!* *!
!* module for species parameters *!
!* *!
!* 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 *!
!* *!
!*****************************************************************!
MODULE data_species
! general parameters
INTEGER :: nspecies ! number of all species (incl. ground vegetation)
INTEGER :: nspec_tree ! number of tree species
INTEGER :: spec_help = 1 ! aux var for species number
REAL :: weibal = 1.5 ! mortality parameter (NOT species-specific)
REAL :: weibal_int = 0.1 ! mortality parameter of intrinsic mortality
REAL :: NPP_demand_mistletoe !helping var. to substract demand of mistletoe from pine cohort
! species-specific parameters
TYPE species_par
CHARACTER (len=30) :: species_name
CHARACTER (len=15) :: species_short_name
! mortality parameters
INTEGER :: max_age ! maximum tree age [yr]
INTEGER :: yrec ! stress recovery time [yr]
INTEGER :: stol ! shade tolerance class [1=intol, 5=tol]
REAL :: intr ! intrinsic mortality rate [?]
REAL :: weibla ! lambda parameter of Weibull distribution [?]
! photosynthesis parameters
REAL :: psla_min ! minimum specific one-sided leaf area [m2/kg DW]
REAL :: psla_a ! light dep. specific one-sided leaf area [m2/kg DW]
REAL :: phic ! efficiency parameter, different for everg/decid [-]
REAL :: pnc ! leaf N content [mg/g]
REAL :: kco2_25 ! Michaelis constant for CO2 (base 25 °C) [Pa]
REAL :: ko2_25 ! inhibition constant of O2 (base 25 °C) [kPa]
REAL :: pc_25 ! CO2/O2 specificity ratio (base 25 °C) [-]
REAL :: q10_kco2 ! Q10 coefficients (acclimated to 25 °C) [-]
REAL :: q10_ko2 ! [-]
REAL :: q10_pc ! [-]
REAL :: pb ! Rd to Vm ratio [-]
REAL :: Nresp ! slope of photosynthesis response to Nitrogen [yr/kg/ha]
! NPP parameters
REAL :: respcoeff ! respiration coefficient
REAL :: prg ! growth respiration [/day]
REAL :: prms ! maintenance resp. (base 15 °C): sapwood, [/day]
REAL :: prmr ! fine roots [/day]
REAL :: q10_prms ! Q10 coefficients (acclimated to 15 °C) [-]
REAL :: q10_prmr ! [-]
! allocation parameters
REAL :: pfext ! extinction coefficient
REAL :: sigman ! root activity rate (N uptake) [/yr]
REAL :: psf ! senescence rates: foliage, [/yr]
REAL :: pss ! sapwood, [/yr]
REAL :: psr ! fine roots [/yr]
REAL :: pcnr ! N/C ratio of biomass [kg N/kg C]
REAL :: cnr_fol ! C/N ratio of foliage [kg C/kg N]
REAL :: cnr_frt ! C/N ratio of fine roots [kg C/kg N]
REAL :: cnr_crt ! C/N ratio of coarse roots [kg C/kg N]
REAL :: cnr_tbc ! C/N ratio of twigs and branches [kg C/kg N]
REAL :: cnr_stem ! C/N ratio of stemwood [kg C/kg N]
REAL :: ncon_fol ! N concentration of foliage [mg/g]
REAL :: ncon_frt ! N concentration of fine roots [mg/g]
REAL :: ncon_crt ! N concentration of coarse roots [mg/g]
REAL :: ncon_tbc ! N concentration of twigs and branches [mg/g]
REAL :: ncon_stem ! N concentration of stemwood [mg/g]
REAL :: reallo_fol ! reallocation parameter of foliage
REAL :: reallo_frt ! reallocation parameter of fine root
REAL :: prhos ! sapwood density [kg/cm3]
REAL :: pnus ! foliage to sapwood area relationship [kg/cm2]
REAL :: alphac ! (twigs, branches & coarse roots) to sapwood ratio [-]
REAL :: cr_frac ! fraction of tbc (twigs, branches, roots) that is coarse roots [-]
REAL :: pha ! height growth rate [cm/kg]
REAL :: pha_coeff1 ! " coefficient 1
REAL :: pha_coeff2 ! " coefficient 2
REAL :: pha_v1 ! parameter for non-linear height-foliage relationship
REAL :: pha_v2 ! "
REAL :: pha_v3 ! "
REAL :: crown_a ! parameter to calculate crown radius from DHB [m/cm]
REAL :: crown_b ! parameter to calculate crown radius from DHB [m]
REAL :: crown_c ! parameter to calculate crown radius from DHB [m]
! decomposition parameters per fraction
REAL :: k_opm_fol ! mineralization constant of foliage litter / per day
REAL :: k_syn_fol ! synthesis coefficient of foliage litter / fraction
REAL :: k_opm_tb ! mineralization constant of twigs and branches litter / per day
REAL :: k_syn_tb ! synthesis coefficient of twigs and branches litter / fraction
REAL :: k_opm_stem ! mineralization constant of stemwood / per day
REAL :: k_syn_stem ! synthesis coefficient of stemwood / fraction
REAL :: k_opm_frt ! mineralization constant of fine root / per day
REAL :: k_syn_frt ! synthesis coefficient of fine root / fraction
REAL :: k_opm_crt ! mineralization constant of coarse root / per day
REAL :: k_syn_crt ! synthesis coefficient of coarse root / fraction
! phenology parameters
! PIM: Promotor-Inhibitor model
! CSM: Cannel and Smoth model
! TSM: linear temperature sum model
REAL :: PItmin ! PIM: Inhibitor min temp. [°C]
REAL :: PItopt ! PIM: Inhibitor opt temp. [°C]
REAL :: PItmax ! PIM: Inhibitor max temp. [°C]
REAL :: PIa ! PIM: Inhibitor scaling factor [-]
REAL :: PPtmin ! PIM: Promotor min temp. [°C]
REAL :: PPtopt ! PIM: Promotor opt temp. [°C]
REAL :: PPtmax ! PIM: Promotor max temp. [°C]
REAL :: PPa ! PIM: Promotor scaling factor [-]
REAL :: PPb ! PIM: Promotor scaling factor [-]
REAL :: CSTbC ! CSM: chilling base temp. [°C]
REAL :: CSTbT ! CSM: base temp. [°C]
REAL :: CSa ! CSM: scaling factor [-]
REAL :: CSb ! CSM: scaling factor [-]
REAL :: LTbT ! TSM: base temp. [°C]
REAL :: LTcrit ! TSM: critical temperature sum [°C]
integer :: Lstart ! TSM: start day after 1.11.
integer :: Phmodel ! used pheno model 0: no model, 1: PIM, 2: CSM, 3: TSM
REAL :: end_bb ! last day for vegetation period
integer :: flag_endbb = 0
! Canopy parameters
REAL :: ceppot_spec ! species parameter for pot. intercept. [mm/m2 leaf area]
REAL :: fpar_mod ! Parameter in canopy_geom (Petra) temp?
! regeneration parameter
REAL :: regflag ! flag for regenration control
REAL :: seedrate ! maximum seed rate per m2
REAL :: seedmass ! mass of single seed [g DW], mean value
REAL :: seedsd ! standard deviation of seed mass
REAL :: seeda ! parameter of shoot biomass - foliage mass emp. relation
REAL :: seedb ! ------------"-------------
REAL :: pheight1 ! parameter of shoot biomass - height emp. relation
REAL :: pheight2 ! ---------"--------------
REAL :: pheight3 ! ---------"--------------
REAL :: pdiam1 ! parameter of shoot biomass -diameter emp. relation
REAL :: pdiam2 ! -------------"-----------
REAL :: pdiam3 ! -------------"-----------
! parameter for root growth model
REAL :: spec_rl ! specific root length [m/g DW]
REAL :: tbase ! minimum temperature for root growth [°C]
REAL :: topt ! optimum temperature for root growth [°C]
REAL :: bdmax_coef ! for equation of maximum bulk density for root growth []
REAL :: porcrit_coef ! for equation critical pore space for aeration []
REAL :: ph_opt_max ! maximum pH-value for optimal root growth
REAL :: ph_opt_min ! minimum pH-value for optimal root growth
REAL :: ph_max ! maximum pH-value for root growth
REAL :: ph_min ! minimum pH-value for root growth
REAL :: v_growth ! maximum velocity of coarse root growth [cm/day]
END type species_par
TYPE (species_par),allocatable,save,dimension(:),target :: spar
END MODULE data_species
source_code/version_2.3_windows/amod_stand.f 0 → 100644
View file @ 82df1085
!*****************************************************************!
!* *!
!* ForeSee Simulation Model *!
!* *!
!* *!
!* Declaration of species and cohort variables *!
!* data_stand *!
!* Subroutines: *!
!* del_cohort *!
!* test_cohort *!
!* list_cohort *!
!* *!
!* 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 *!
!* *!
!*****************************************************************!
MODULE data_stand
INTEGER :: anz_coh = 0 ! current amount of cohortes
INTEGER :: max_coh = 0 ! max. amount of cohortes
REAL :: kpatchsize = 200 ! patch size [m^2]
REAL :: dz = 50 ! thickness of a crown layer [cm]
INTEGER :: waldtyp ! forest type
! variables for the whole stand
INTEGER,allocatable,save,dimension(:):: nrspec ! actual kind numbers of species
REAL,dimension(0:300) :: Irelpool ! relative light intensitiy of the crown space which is not
! occupied by trees (pool). This is the light intensitiy
! at the top of each layer. Irelpool(0)=light unto ground
REAL,dimension(1:301) :: BGpool ! fraction of patch covered by 'free crown space' for
! the next layer respectivley.
REAL,dimension(0:300) :: precpool ! relative precipitation intensitiy of the crown space which is not
! occupied by trees (pool). This is the precipitation intensitiy
! at the top of each layer
REAL :: Irelpool_ll ! relative light intensitiy at the lowest layer
REAL :: bgpool_ll ! fraction of patch covered by 'free crown space'
REAL :: totFPARsum ! fraction of absorbed light for the whole patch
REAL :: totFPARcan ! fraction of absorbed light for the whole canopy
REAL :: LAI ! leaf area index of the patch [m^2/m^2]
REAL :: LAI_can ! leaf area index of the canopy [m^2/m^2]
REAL :: LAI_sveg ! leaf area index of the ground vegetation [m^2/m^2]
REAL :: LAImax ! leaf area index of the patch in period when all trees carry leaves [m^2/m^2]
REAL :: LAI_in ! leaf area index of new trees [m^2/m^2]
REAL :: LAI_out ! leaf area index of removed trees [m^2/m^2]
REAL :: crown_area ! projected crown area [m**2] for the whole canopy,
REAL :: gp_tot ! unstressed stomatal conductance of the total vegetation (canopy + ground vegetation) [mol/(m2*d)]
REAL :: gp_can ! unstressed stomatal conductance of the canopy [mol/(m2*d)]
REAL :: gp_can_mean ! yearly mean of unstressed stomatal conductance of the canopy [mol/(m2*d)]
REAL :: gp_can_min ! yearly minimum of unstressed stomatal conductance of the canopy [mol/(m2*d)]
REAL :: gp_can_max ! yearly maximum of unstressed stomatal conductance of the canopy [mol/(m2*d)]
REAL :: drIndd ! daily drought index for the whole stand [-], weighted by ntree
REAL :: drIndAl ! drought index for allocation calculation (cum.) for the whole stand [-],
! weighted by NPP
REAL :: mean_drIndAl ! mean drought index for allocation calculation (cum.) for the whole stand [-],
REAL :: RedN_mean ! mean RedN of all species
INTEGER :: anz_RedN ! number of RedN for calculation of RedN_mean
REAL :: sumbio ! biomass of all cohorts and all tree-species [kg DW/ha]
REAL :: sumbio_sv ! biomass of all cohorts and all ground-vegetation-species [kg DW/ha]
REAL :: sumbio_in ! biomass of new trees [kg DW/ha]
REAL :: sumbio_out ! biomass of removed trees [kg DW/ha]
REAL :: cumsteminc ! total cumulated sum of all stem increments [kg/ha]
REAL :: cumsumvsab ! cumulated total sum of volume of removed stems by management [kg/ha]
REAL :: cumsumvsdead ! cumulated total sum of volume of dead stems [kg/ha]
REAL :: sumvsab ! total sum of volume of removed stems by management [kg/ha]
REAL :: sumvsab_m3 ! total sum of volume of removed stems by management [m³/ha]
REAL :: sumvsdead ! total sum of volume of dead stems [kg/ha]
REAL :: sumvsdead_m3 ! total sum of volume of dead stems [m³/ha]
REAL :: totfol ! total biomass of foliage [kg DW/ha]
REAL :: totfol_in ! total biomass of foliage of new trees [kg DW/ha]
REAL :: totfol_out ! total biomass of foliage of removed trees [kg DW/ha]
REAL :: totsap ! total biomass of sapwood [kg DW/ha]
REAL :: totfrt ! total fine root biomass of all cohorts and all species [kg DW/ha]
REAL :: totfrt_p ! total fine root biomass of all cohorts and all species per patch [kg DW/patchsize]
REAL :: totfrt_1 ! reciprocal of total fine root biomass of all cohorts and all species per patch [kg DW/patchsize]
REAL :: tottb ! total twigs, branches biomass of all cohorts and all species [kg DW/ha]
REAL :: totcrt ! total coarse root biomass of all cohorts and all species [kg DW/ha]
REAL :: seedlfrt ! total fine root biomass of all cohorts with height < thr_height [kg DW]
REAL :: tothrt ! total biomass of heartwood [kg DW/ha]
REAL :: sumNPP ! total NPP of all cohorts and species
REAL :: cum_sumNPP ! cumulative total NPP of all cohorts and species
REAL :: sumGPP ! total GPP of all cohorts and species [g C/m2 --> t C/ha]
REAL :: totfol_lit ! total foliage litter [kg DW / ha / year]
REAL :: totfol_lit_tree ! total foliage litter of trees [kg DW / ha / year]
REAL :: totfrt_lit ! total fine root litter [kg DW / ha / year]
REAL :: totfrt_lit_tree ! total fine root litter of trees [kg DW / ha / year]
REAL :: tottb_lit ! total litter of twigs, and branches [kg DW / ha / year]
REAL :: totcrt_lit ! total litter of coarse roots [kg DW / ha / year]
REAL :: totstem_lit ! total dead biomass of stems [kg DW / ha / year]
REAL :: totsteminc ! total stem increment of patch [kg DW/ha]
REAL :: totsteminc_m3 ! total stem increment of patch in m3
REAL :: totstem_m3 ! total stem volume [m3/ha]
REAL :: Ndem ! total N demand of the stand per year [g/m2]
REAL :: autresp ! total autotroph resp of all cohorts and species
REAL :: autresp_m ! mean total autotroph resp of all cohorts and species (mean over all years)
REAL :: sumTER ! total ecosystem respiration of all cohorts and species [g C/m2 --> t C/ha]
INTEGER :: coh_ident_max ! actual maximum ident number of cohorts
INTEGER :: anz_coh_in ! number of new cohorts
INTEGER :: anz_coh_out ! number of removed cohorts
INTEGER :: anz_coh_act ! number of cohorts of the actual year
INTEGER :: anz_spec ! number of current existing tree species
INTEGER :: anrspec ! number of all current existing species
INTEGER :: anz_spec_in ! number of new tree species
INTEGER :: anz_spec_out ! number of removed tree species
INTEGER :: anz_tree_dbh ! number of trees with dbh
INTEGER :: anz_tree ! total number of trees /patch
INTEGER :: anz_tree_ha ! total number of trees /ha
INTEGER :: anz_tree_in ! number of new trees /ha
INTEGER :: anz_tree_out ! number of removed trees /ha
INTEGER :: anz_sveg ! total number of soil vegetation cohorts
REAL :: med_diam ! medium diameter of stand (Dg)
REAL :: med_diam_in ! medium diameter of new trees (Dg)
REAL :: med_diam_out ! medium diameter of removed trees (Dg)
REAL :: hdom ! medium height of 2 dominant trees
REAL :: hmean_in ! mean height of all new trees
REAL :: hmean_out ! mean height of all removed trees
REAL :: mean_height ! mean height of stand [cm]
REAL :: mean_diam ! mean diameter of stand [cm]
REAL :: basal_area ! basal area [m²]
INTEGER :: highest_layer ! highest foliage layer of the stand
INTEGER :: lowest_layer ! lowest foliage layer of the stand.
! lowest_layer=0: bare ground
INTEGER :: lm3layer ! light model 4: layer from that on light model 3 is used
REAL :: GRASS_day
REAL :: NETASS_day
REAL :: GPP_day ! daily GPP of all cohorts and species after scaling by temperature
REAL, dimension(12) :: GPP_mon ! monthly GPP of all cohorts and species
REAL, dimension(53) :: GPP_week ! weekly GPP of all cohorts and species
REAL :: GPP_dec ! sum of GPP of all cohorts and species of last december
REAL, dimension(12) :: NEE_mon ! monthly NEE of all cohorts and species
REAL :: NEE_dec ! sum of NEE of all cohorts and species of last december
REAL :: NPP_day ! daily NPP of all cohorts and species after scaling by temperature
REAL, dimension(12) :: NPP_mon ! monthly NPP of all cohorts and species
REAL, dimension(53) :: NPP_week ! weekly NPP of all cohorts and species
REAL :: NPP_dec ! sum of NPP of all cohorts and species of last december
REAL :: TER_day ! daily TER of all cohorts and species after scaling by temperature
REAL, dimension(12) :: TER_mon ! monthly total ecosystem respiration of all cohorts and species
REAL, dimension(53) :: TER_week ! weekly total ecosystem respiration of all cohorts and species
REAL :: TER_dec ! sum of TER of all cohorts and species of last december
REAL :: respr_day ! daily root respiration of all cohorts and species after scaling by temperature
REAL, dimension(12) :: respr_mon ! monthly total root respiration of all cohorts and species (fine and coarse roots)
REAL, dimension(53) :: respr_week ! weekly total root respiration of all cohorts and species
REAL,allocatable, save, dimension(:) :: dayfract ! daily fraction of fluxes (depending on temperature)
REAL :: dailyNPP_C, & ! daily net production [gC/m2]
dailypotNPP_C, & ! daily potential (= no water and nutrient limitation) net primary production [gC/m2]
dailyautresp_C, & ! daily autotrophic respiration [gC/m2]
dailygrass_C, & ! daily gross assimilation [gC/m2]
dailynetass_C, & ! daily net assimilation [gC/m2]
dailyrespfol_C, & ! daily maintenance leaf respiration [gC/m2]
phot_C, & ! daily gross photosynthesis [gC/m2]
precsum
REAL :: ceppot_can ! pot. intercept. whole canopy
REAL :: ceppot_sveg ! pot. intercept. whole ground vegetation
INTEGER :: phen_flag=0 ! phenology flag, =1 if canopy changes due to
! phenological events
REAL :: basal_area_tot ! basal area of the whole stand [cm²]
! variables used in sum-output
REAL :: photsum,nppsum, &
npppotsum,resosum, &
lightsum, &
abslightsum,nee, &
gppsum, &
tersum, & ! total ecosystem respiration
resautsum, & ! autotrophe respiratiom
aet_sum, pet_sum, &
tempmean, tempmeanh !summation variable for output *_sum
! variables for representation index calculation
REAL :: rindex1, &
rindex2
! variable for ground-vegetation
REAL :: M_avail ! mass available for allocation to organs in soil veg. initialisation [kg DM m-2]
REAL :: NPP_est ! NPP estimated for soil veg. initialisation [g DM m-2]
! Variables for disturbances
REAL :: phlo_feed ! Percentage loss of carbon due to phloem feeders
REAL :: stem_rot ! Percentage loss of stems due to stem rot
! variables for classification of trees
INTEGER :: num_class=29 ! number of diameter and height classes
INTEGER,allocatable, save, dimension(:,:) :: diam_class, diam_classm, diam_class_t, diam_class_age
REAL ,allocatable, save, dimension(:,:) :: diam_class_h, diam_classm_h, diam_class_mvol
INTEGER,allocatable, save, dimension(:) :: height_class
! ! variables per species
INTEGER,allocatable,save,dimension(:) :: height_rank ! number of trees per species
INTEGER,allocatable,save,dimension(:) :: dbh_rank ! number of trees per species
type species_var
! variables per species
INTEGER :: daybb ! day of bud burst per species [julian day of year]
INTEGER :: ext_daybb ! externally prescribed day of bud burst per species [julian day of year]
INTEGER :: sum_nTreeA ! number of trees per species [per ha]
INTEGER :: sum_nTreeD ! number of all dead trees per species [per ha]
INTEGER :: anz_coh ! number of cohorts per species
REAL :: RedN ! photosynthesis nitrogen reduction factor [-]
REAL :: RedNm ! mean annual photosynthesis nitrogen reduction factor [-]
REAL :: med_diam ! medium diameter per species (squared average) [cm]
REAL :: mean_diam ! average diameter per species [cm]
REAL :: mean_jrb ! average year ring width [mm]
REAL :: dom_height ! dominant height per species [cm]
REAL :: mean_height ! average height per species [cm]
REAL :: basal_area ! basal area per species [m²]
REAL :: drIndAl ! drought index for allocation calculation (cum.) per species [-]
! weighted by NPP
REAL :: sumNPP ! total NPP of all cohorts per species
REAL :: sum_bio ! total biomass per species [kg DW/ha]
REAL :: sum_lai ! maximum annual LAI per species
REAL :: act_sum_lai ! LAI per species
REAL :: fol ! total foliage mass per species [kg DW/ha]
REAL :: hrt ! total heartwood mass per species [kg DW/ha]
REAL :: sap ! totalsapwood mass per species [kg DW/ha]
REAL :: frt ! total fine root mass per species [kg DW/ha]
REAL :: totsteminc ! total stem increment per species [kg DW/ha]
REAL :: totsteminc_m3 ! total stem increment per species [m3/ha]
REAL :: totstem_m3 ! total stem volume per species [m³/ha]
REAL :: sumvsab ! total sum of volume of harvested stem mass of species [kg/ha]
REAL :: sumvsdead ! total sum of volume of dead stems [kg/ha]
REAL :: sumvsdead_m3 ! total sum of volume of dead stems [m3/ha]
REAL :: crown_area ! species specific crown area
REAL :: Ndem ! total N demand per species and year [g/m2]
REAL :: Nupt ! total N uptake per species and year [g/m2]
REAL :: Ndemp ! total N demand per species and potosynthesis period [g/m2]
REAL :: Nuptp ! total N uptake per species and potosynthesis period [g/m2]
! Phenology parameters
REAL :: Pro ! Depending on phenomodel: Promotor or Temperature sum
REAL :: Inh ! Depending on phenomodel: Inhibitor or chill days
REAL :: Tcrit ! Critical temperature sum for Cannel-Smith model [°C]
REAL,pointer,dimension(:) :: BDmax ! species specific maximum bulk density for root growth in soil layers
REAL,pointer,dimension(:) :: tstress ! species specific temperature stress for root growth in soil layers
REAL,pointer,dimension(:) :: sstr ! species specific soil strength stress for root growth in soil layers
REAL,pointer,dimension(:) :: BDstr ! species specific bulk density stress for root growth in soil layers
REAL,pointer,dimension(:) :: porcrit ! species specific critical pore space for root growth in soil layers
REAL,pointer,dimension(:) :: airstr ! species specific aeration stress for root growth in soil layers
REAL,pointer,dimension(:) :: phstr ! species specific pH stress for root growth in soil layers
REAL,pointer,dimension(:) :: Rstress ! species specific total daily stress for root growth in soil layers
REAL,pointer,dimension(:) :: Smean ! species specific total yearly stress for root growth in soil layers
end type species_var
type(species_var),allocatable,dimension(:),target :: svar
type cohort
INTEGER :: ident ! identification of cohort
INTEGER :: species ! number of species parameter set in spar (type)
! state variables for population dynamics
REAL :: nTreeA ! number of alive trees (output) integer [-]
REAL :: nTreeD ! number of dead trees integer [-]
REAL :: nTreeM ! number of trees harvested by Management
REAL :: nTreet ! number of trees tended by Management
REAL :: nta ! number of alive trees (internal) REAL [-]
INTEGER :: mistletoe ! cohort has / has no mistletoe infection
! all variables are values of single trees !!!
! tree state variables; DW = dry weight (i.e., dry biomass)
INTEGER :: x_age ! tree age [yr]
REAL :: x_fol ! foliage biomass [kg DW / tree]
REAL :: x_fol_loss ! loss of foliage biomass [kg DW / tree] by disturbance (flag_dis=1)
REAL :: x_sap ! sapwood biomass [kg DW / tree]
REAL :: x_frt ! fine root biomass [kg DW / tree]
REAL :: x_frt_loss ! loss of fine root biomass [kg DW / tree] by disturbance (flag_dis=1)
REAL :: x_hrt ! heartwood biomass [kg DW / tree]
REAL :: x_rdpt ! rooting depth [cm]
REAL :: x_crt ! coarse root biomass [kg DW / tree]
REAL :: x_tb ! twigs and branches biomass [kg DW / tree]
REAL :: x_hsap ! sapwood height [cm]
REAL :: x_hbole ! bole height [cm]
REAL :: x_Ahb ! cross sectional area of heart wood at stem base [cm**2]
INTEGER :: x_stress ! number of stress years [-]
INTEGER :: x_health ! number of years without stress [-]
REAL :: x_nsc_sap ! sapwood nsc-pool [kg C / tree]
REAL :: x_nsc_tb ! twigs and branch nsc-pool [kg C / tree]
REAL :: x_nsc_crt ! coarse root nsc-pool [kg C / tree]
REAL :: x_nsc_sap_max !maximum amount sapwood nsc-pool [kg C / tree]
REAL :: x_nsc_tb_max !maximum amount twigs and branch nsc-pool [kg C / tree]
REAL :: x_nsc_crt_max !maximum amount coarse root nsc-pool [kg C / tree]
REAL :: biocost_all !biosynthesis costs for refilling process [kg DW / tree]
! auxiliary variables
REAL :: bes ! avarage beset or press of cohort
REAL :: med_sla ! average cohort specific leaf area [m²/kg]
REAL :: Fmax ! maximum foliage biomass [kg DW]
REAL :: totBio ! total tree biomass [kg DW]
REAL :: Dbio ! total dead biomass per cohort [kg DW]
REAL :: height ! total tree height [cm]
REAL :: deltaB ! change in bole height [cm]
REAL :: Ahc ! cross sectional area of heart wood at crown base [cm**2]
REAL :: dcrb ! trunc diameter at crown base [cm]
REAL :: diam ! diameter at breast height [cm]
real :: jrb ! year ring width [mm]
REAL :: assi ! optimum gross assimilation rate [kg DW/d/patch] !!! not a tree variable
REAL :: LUE ! light use efficiency [gC/micromole]
REAL :: resp ! leaf respiration rate [kg DW/d/patch] !!! not a tree variable
REAL :: netAss ! realized net assimilation rate [kg DW/d]
REAL :: NPP ! NPP [kg DW/yr]
REAL :: weekNPP ! weekly NPP [kg DW/yr]
REAL :: NPPpool
REAL :: t_leaf ! leaf area per tree [m2]
REAL :: geff ! growth efficiency [kg stem DM/(yr*m2)]
REAL :: Asapw ! tree sapwood cross sectional area in bole space [cm2]
REAL :: crown_area ! projected crown area [m**2],
! is the same in each layer; maximal proj. crown area,
! when enough space available crown_area
REAL,dimension(301) :: BG ! fraction of the patch covered by the
! tree in each layer, may change through the layers.
REAL,dimension(0:300) :: leafArea ! leaf area per layer [m2]
REAL,dimension(0:300) :: sleafArea ! leaf area per layer [m2], stocked
REAL,dimension(0:300) :: FPAR ! light version 1-3 : fraction of PAR
! absorbed by each layer per crown coverage area [-]
! light version 4 : fraction of PAR absorbed until(!)
! each layer per patch [-]
REAL,dimension(0:300) :: antFPAR ! fraction of totFPAR per crown layer
REAL,dimension(0:300) :: Irel ! relative incident radiation
! intensitiy at the top of a given layer
REAL :: totFPAR ! total fraction of PAR absorbed [-],
! per m² patch area!
REAL :: IrelCan ! the relative light regime in the
! middle of the cohort's canopy
INTEGER :: botLayer ! number of bottom layer of crown [-]
INTEGER :: topLayer ! number of top layer of crown [-]
REAL :: survp ! survival probability first 5 years of simulation
REAL :: rel_fol ! relative part foliage of cohort
REAL :: gfol ! gross growth rate foliage
REAL :: gfrt ! gross growth rate fine root
REAL :: gsap ! gross growth rate sap wood
REAL :: sfol ! senescence rate foliage
REAL :: sfrt ! senescence rate fine root
REAL :: ssap ! senescence rate sap wood
REAL :: grossass ! gross assimilation rate [kg DW/yr]
REAL :: maintres ! cumulative maintenance respiration (sap + frt) [kg DW/yr]
REAL :: respsap ! daily respiration rate sapwood [kg DW/d]
REAL :: respfrt ! daily respiration rate fine root [kg DW/d]
REAL :: respfol ! maintenance daily leaf respiration [kg DW/d]
REAL :: respbr ! daily respiration rate branches, c. roots .... [kg DW/d]
REAL :: respaut ! daily autotrophic respiration rate of tree .... [kg DW/d]
REAL :: resphet ! daily hetrotrophic respiration rate of tree .... [kg DW/d]
!
! aux. variables for calculation of crown_area of new established trees
REAL :: height_ini ! initial value of height of a new established tree cohort by ingrowth [cm]
REAL :: ca_ini ! initial value of crown area of a new established tree cohort by ingrowth [m2]
! new aux. variables for mAustrian management by relative diamter class
INTEGER :: rel_dbh_cl ! relative DBH class
INTEGER :: underst ! 0 = overstorey, 1 = seedling cohort, 2 = understorey
INTEGER :: sprout ! 0 = tree is no sprout, 1 = sprout
INTEGER :: fl_sap ! sapling = 0, tree = 1
! growth-mortality coupling variables
REAL :: fol_inc ! foliage increment [kg DW/yr]
REAL :: fol_inc_old ! foliage increment of last year[kg DW/yr]
REAL :: bio_inc ! net biomass increment [kg DW/yr]
REAL :: stem_inc ! stem wood increment [kg DW/yr]
REAL :: frt_inc ! fine root wood increment [kg DW/yr]
logical :: notViable ! .TRUE. if non-biological tree dimensions occur
integer :: flag_vegend=0
! plant-soil water coupling variables
REAL,dimension(0:300):: intcap ! precipitation absorbed by
! each layer per m² patch area [mm]
REAL,dimension(0:300):: prel ! precipitation
! at the top of a given layer [mm] per m² patch area
REAL :: interc ! total intercepted precipitation [mm],
! per m² patch area!
REAL :: prelCan ! the relative precipitaion regime
! in the middle of the cohort's canopy
REAL :: interc_st ! interception storage [mm/m2]
REAL :: aev_i ! actual evaporation of intercepted water [mm]
REAL :: demand ! daily demand for soil water of cohort [mm/day]
REAL :: supply ! daily uptake of soil water by roots of cohort [mm/day]
REAL :: watuptc ! yearly total uptake of soil water by roots [mm/day]
REAL :: watleft ! yearly total water left in soil layer next to last rooted soil layer [mm]
REAL :: gp ! unstressed stomatal conductance [mol/(m2*d)]
REAL :: drIndd ! daily drought index [-]
REAL :: drIndPS ! drought index for photosynthesis calculation (cum.) [-]
REAL :: nDaysPS ! number of growing season days per time step of PS model [-]
REAL :: drIndAl ! drought index for allocation calculation (cum.) [-]
INTEGER :: nDaysGr ! number of growing season days per year [#]
logical :: isGrSDay ! is the current day a growing season day?
! plant-soil C/N coupling variables in kg per cohort
REAL :: litC_fol ! foliage litter C pool [kg/cohort]
REAL :: litC_fold ! foliage litter C pool [kg/cohort] of dead trees
REAL :: litN_fol ! foliage litter N pool [kg/cohort]
REAL :: litN_fold ! foliage litter N pool [kg/cohort] of dead trees
REAL :: litC_frt ! fine root litter C pool [kg/cohort]
REAL :: litC_frtd ! fine root litter C pool [kg/cohort] of dead trees
REAL :: litN_frt ! fine root litter N pool [kg/cohort]
REAL :: litN_frtd ! fine root litter N pool [kg/cohort] of dead trees
REAL :: litC_stem ! stemwood litter C pool [kg/cohort]
REAL :: litN_stem ! stemwood litter N pool [kg/cohort]
REAL :: litC_tb ! twig, and branch litter C pool [kg/cohort]
REAL :: litC_crt ! coarse root litter C pool [kg/cohort]
REAL :: litC_tbcd ! twigs, branches, and coarse root litter C pool [kg/cohort] of dead trees
REAL :: litN_tb ! twig, and branch litter N pool [kg/cohort]
REAL :: litN_crt ! coarse root litter N pool [kg/cohort]
REAL :: litN_tbcd ! twigs, branches, and coarse root litter N pool [kg/cohort] of dead trees
REAL :: Nuptc_c ! N uptake per tree and year [g/yr]
REAL :: Ndemc_c ! N demand per tree and year [g/yr]
REAL :: Nuptc_d ! daily N uptake per tree [g/d]
REAL :: Ndemc_d ! daily N demand per tree [g/d]
REAL :: RedNc ! tree specific RedN (photosynthesis nitrogen reduction factor) [-]
REAL :: N_pool ! N pool per tree [g]
REAL :: N_fol ! N content of foliage per tree [g]
REAL :: wat_mg ! cohort water uptake (flag_wred=9)
! root distribution
REAL,pointer,dimension(:) :: frtrel ! relative part of fine root mass of tree per soil layer
REAL,pointer,dimension(:) :: frtrelc ! relative part of fine root mass of cohort of total layer fine root mass per soil layer
REAL,pointer,dimension(:) :: rld ! root length [cm per cm3]
REAL,pointer,dimension(:) :: rooteff ! root uptake efficiency per soil layer
INTEGER :: nroot ! nroot soil layer with max. root depth
! pseudo parameter (used as an index for field spar with species-specific parameters)
INTEGER :: shelter ! Überhaelter
! Phenology parameters
INTEGER :: day_bb ! day_bb day of bud burst [julian day of year]
! day_bb
REAL :: P ! Depending on phenomodel: Promotor or Temperature sum
REAL :: I ! Depending on phenomodel: Inhibitor or chill days
REAL :: Tcrit ! Critical temperature sum for Cannel-Smith model [°C]
end type cohort
type coh_obj
type(cohort) :: coh ! cohort data structure
type(coh_obj), pointer :: next ! pointer to next cohort
end type coh_obj
type coh_list
type(coh_obj), pointer :: first ! List of cohorts
end type coh_list
type(coh_list) :: pt ! variable for whole stand, all cohorts
type(cohort), pointer, dimension(:) :: coh_save ! pointer to variables for saving intialisation of all cohorts
type(coh_obj), pointer :: zeig ! pointer variable for manipulating cohorts
INTEGER :: anz_coh_save
type vert_struct
REAL :: LA ! leaf area in a given layer [m²]
REAL :: cumLAI ! cumulative leaf area index at the bottom of a given layer [m²/m²]
REAL :: radFrac ! fraction of total radiation absorbed in a given layer [-]
REAL :: sumBG ! sum of all crown areas in a layer [m²]
REAL :: Irel ! light version 1,2 : relative incident radiation at the top of a given layer [-]
! light version 3,4 : average relative incident radiation at the bottom of a given layer [-]. For test reasons only
end type vert_struct
type(vert_struct),dimension(0:300) :: vStruct ! field with vertical patch structure
! variables for litter retention
type dead_litter
INTEGER :: specnr ! species number
! arrays of dead stem and twigs/branches
REAL,pointer,dimension(:) :: C_tb
REAL,pointer,dimension(:) :: N_tb
REAL,pointer,dimension(:) :: C_stem
REAL,pointer,dimension(:) :: N_stem
end type dead_litter
INTEGER :: lit_year = 5 ! number of years of retention
type(dead_litter),allocatable,dimension(:),target :: dead_wood ! delay over 5 years []
!----------------------------------------------------------------------------------------
contains
function neu() result (stand_neu) ! Create a new pointer list = new stand without any cohort
implicit none
type(coh_list) :: stand_neu
nullify(stand_neu%first)
end function neu
!----------------------------------------------------------------------------------------
subroutine del_cohort
use data_species
use data_simul
implicit none
type(coh_obj), pointer :: nachlauf
zeig => pt%first
do while (associated(zeig))
if (zeig%coh%nTreeA < 0.1.or. (zeig%coh%species.gt.nspec_tree.and.zeig%coh%x_fol.le. 1.E-6)) then
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
anz_coh=anz_coh-1
else
nachlauf => zeig
zeig => zeig%next
exit
end if
end do
do while (associated(zeig))
if (zeig%coh%nTreeA < 0.1.or. (zeig%coh%species.gt.nspec_tree.and.zeig%coh%x_fol.le. 1.E-6)) then
nachlauf%next => 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 => nachlauf%next
anz_coh=anz_coh-1
else
nachlauf => zeig
zeig => zeig%next
end if
end do
end subroutine del_cohort
!----------------------------------------------------------------------------------------
subroutine list_cohort ! Output of cohort list
implicit none
INTEGER :: i
zeig => pt%first
i = 0
do while (associated(zeig))
i = i + 1
zeig => zeig%next
end do
end subroutine list_cohort
!----------------------------------------------------------------------------------------
subroutine test_cohort(ts)
implicit none
INTEGER, intent(out):: ts
zeig => pt%first
if (.not. associated(zeig)) then
print *,' No existing cohort!'
ts = 1
else
ts = 0
end if
end subroutine test_cohort
end module data_stand
source_code/version_2.3_windows/amod_tisort.f 0 → 100644
View file @ 82df1085
!*****************************************************************!
!* *!
!* Post Processing for 4C (FORESEE) *!
!* *!
!* *!
!* Modules and Subroutines: *!
!* *!
!* data_tsort: module to store timber assortments *!
!* *!
!* 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 *!
!* *!
!*************************************************************** *!
module data_tsort
! species specific parameter for sorting of harvested timber
! fagus, picea, pinus, quercus, betula
real, dimension(11) :: stoh=(/10.,10.,10.,10.,10.,10.,10.,10.,10.,10.,10./)
real, dimension(5) :: lmin=(/400.,400.,400.,400.,400./)
real, dimension(5) :: ldmin=(/30.,30., 30., 30.,35./)
real, dimension(5) :: lzmin=(/20.,14.,14.,20.,20./)
real, dimension(5) :: lasfixl1=(/400.,400.,400.,400.,400./)
real, dimension(5) :: lasfixl2= (/300.,300.,300.,300.,300./)
real, dimension(5) :: lasdmin= (/20.,15.,15.,20.,20./)
real, dimension(5) :: las1zmin= (/0.,0.,11.,0.,0./)
real, dimension(5) :: las1dmin= (/0.,0.,11.,0.,0./)
real, dimension(5) :: laszmin= (/11.,11.,11.,11.,11./)
real, dimension(5) :: isfixl1= (/200.,200.,200.,200.,200./)
real, dimension(5) :: isfixl2= (/100.,100.,100.,100.,100./)
real, dimension(5) :: isdmin= (/10.,10.,10.,10.,10./)
real, dimension(5) :: iszmin= (/7.,7.,7.,7.,7./)
real rabth(5,2)
real,dimension(5,3) :: rabz
real :: zug =10 ! addition [cm]
real, allocatable,save, dimension(:,:,:,:) :: sort ! per year and species for different cohorts:
integer, parameter :: dg=kind(0.0D0) ! identifier, lenght, diamter, volume, number of pieces
integer :: anz_list
integer :: flag_sort= 1 ! 0: with stem timber; 1: without stem timber, 2:only LAS 3m + Ind +Fuel
! 3: only LAS 4m * Ind + Fuel
integer :: flag_deadsort =0
type timber
integer :: year
integer :: count
character(4):: ttype
character(2):: stype ! stand type (vb or ab)
integer :: specnr
real :: zapfd ! diameter at the top
real :: zapfdor ! without bark
real :: length
real :: dia ! diameter at thre middle
real :: diaor ! without bark
real(kind =dg) :: vol
real :: tnum
real ::hei_tree
real :: hbo_tree
real :: diab ! diameter at base
real :: dcrb
end type timber
type tim_obj
type(timber) :: tim ! cohort data structure
type(tim_obj), pointer :: next ! pointer to next cohort
end type tim_obj
type tim_list
type(tim_obj), pointer :: first ! List of cohorts
end type tim_list
type(tim_list) :: st ! variable for whole stand, all cohorts
type(tim_obj), pointer :: ztim ! pointer variable for manipulating cohorts
DATA rabth /35.,25.,20.,40.,40.,0.,40.,30.,60.,0./
DATA rabz /1.,1.,1.,3.,2.,2.,2.,2.,5.,4.,2.,3.,4.,6.,4./
end module data_tsort
source_code/version_2.3_windows/amod_wpm.f 0 → 100644
View file @ 82df1085
!*****************************************************************!
!* *!
!* Post Processing for 4C (FORESEE) *!
!* *!
!* *!
!* Modules and Subroutines: *!
!* *!
!* data_mansort: module to store the mansort, manrec input *!
!* wood_processing: module to store wood processing infos *!
!* wpm_output: module to store simulation output *!
!* lifespan_par: module to store lifespan parameters *!
!* ini_input: initialize the values of the modules *!
!* allocate_in_output: allocates module values *!
!* deallocate_in_output: deallocates module values *!
!* *!
!* 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 *!
!* *!
!*****************************************************************!
! module contains informations from mansort file: "removals"
! module contains information for "roundwood" and "after processing" steps
! module contains lifespan function parameters
! module contains wmp output
module data_wpm
!***************************************************************
! module contains informations from mansort file: "removals"
! cm cm cm cm cm m³/ha kg C/ha
!# year count spec type len diam diam wob top_d t_d wob Volume DW number
type mansort_type
integer :: year, count, spec, number
character(4) :: typus
real :: diam, volume, dw, diam_wob
end type mansort_type
type manrec_type
integer :: year, measure
character(28) :: management
end type manrec_type
type mansort_obj
type(mansort_type) :: mansort
type(mansort_obj), pointer :: next
end type mansort_obj
type manrec_obj
type(manrec_type) :: manrec
type(manrec_obj), pointer :: next
end type manrec_obj
! pointer to the the mansort, manrec lists, sea list
type(mansort_obj), pointer :: first_mansort
type(manrec_obj) , pointer :: first_manrec
type(mansort_obj), pointer :: first_standsort
! pointer variable for manipulating mansort, manrec lists, sea list
type(mansort_obj), pointer :: act_mansort
type(manrec_obj) , pointer :: act_manrec
type(mansort_obj), pointer :: act_standsort
! years from the manrec file with needed management
integer, allocatable, save, dimension(:) :: management_years
integer :: nr_pr_ln
! number of simulation years, management (manrec) years and wpm relevant management years
integer :: nr_years
integer :: nr_management_years
integer :: wpm_manag_years
! sea: number of timber grades, number of tree species
integer :: nr_timb_grades
integer :: nr_spec
!***************************************************************
! module contains information for "roundwood" and "after processing" steps
!***************************************************************
! value: carbon per simulation year
! proc_par: parameters for the processing
! use_par: parameters for the "use categories" distribution
type wood_type
real, pointer, dimension(:) :: value
real, dimension(3,7) :: proc_par
real, dimension(7) :: use_par
end type wood_type
! for each simulation year
! product lines: sawntimber_sw, sawntimber_hw (softwood, hardwood),
! plywood, particle_board, chem_pulpwood, mech_pulpwood, fuelwood
type(wood_type), allocatable, save, dimension(:) :: product_lines
! save the results by the procentual sorting of product lines
! three sortings, product lines, years
real, allocatable, save, dimension(:,:,:) :: pl
! with or without wob
logical :: wob
!***************************************************************
! module contains lifespan function parameters
!***************************************************************
type lifespan_type
real hl
real a, b, c, d
end type lifespan_type
type(lifespan_type) :: short_lifespan
type(lifespan_type) :: medium_short_lifespan
type(lifespan_type) :: medium_long_lifespan
type(lifespan_type) :: long_lifespan
!***************************************************************
! module contains wmp output
!***************************************************************
integer, allocatable, save, dimension(:) :: years
integer :: nr_use_cat
integer, allocatable, dimension(:) :: max_age
! use_categories: building_materials, other_building_materials, structural_support,
! furnishing, packing_materials, long_life_paper, short_life_paper
! per simulation year
! rec_par: recycling, landfill, burning parameter of use
type use_categories_type
type(lifespan_type) :: lifespan_function
real, pointer, dimension(:) :: value
real, dimension(3) :: rec_par
real, dimension(7) :: rec_use_par
! spin up values
real, pointer, dimension(:) :: spinup
end type use_categories_type
! spin up value
real :: landfill_spinup
! spinup_on
logical :: spinup_on
! debug and spinup output
logical :: debug
logical :: output_spinup
! list of use_cateories, sum of use categories per year, use_cat at the beginning
type(use_categories_type), allocatable, save, dimension(:) :: use_categories
real, allocatable, save, dimension(:) :: sum_use_cat
real, allocatable, save, dimension(:) :: sum_input
real, allocatable, save, dimension(:,:) :: use_cat
real, allocatable, save, dimension(:) :: burning
real, allocatable, save, dimension(:) :: landfill
! atmosphere per year, atmosphere cummulative
real, allocatable, save, dimension(:) :: atmo_year
real, allocatable, save, dimension(:) :: atmo_cum
!******************** substitution ********************
real, allocatable, save, dimension(:) :: emission_har, sub_energy, sub_material, sub_sum
real, dimension (3) :: sub_par
!********************** sea ****************************
! sea timber grades:
! _tg(tree species, timber grade, year)
real, allocatable, save, dimension(:,:,:) :: mansort_tg
real, allocatable, save, dimension(:,:,:) :: standsort_tg
! prices (spec, timber grades)
real, allocatable, save, dimension(:,:) :: chainsaw_prices
real, allocatable, save, dimension(:,:) :: harvester_prices
real, allocatable, save, dimension(:) :: planting_prices
real, allocatable, save, dimension(:,:) :: planting_sub
real, allocatable, save, dimension(:,:) :: fence
real, dimension(2) :: fix
real, dimension(2) :: brushing
real, dimension(2) :: tending_prices
real, dimension(2,2) :: ext_for
real, dimension(4) :: int_rate
real, allocatable, save, dimension(:,:) :: sum_costs
real, allocatable, save, dimension(:,:) :: subsidy
real, allocatable, save, dimension(:,:) :: npv
real, allocatable, save, dimension(:,:) :: net_prices
! percentual of chainsaw to harvester methods
real, dimension(2) :: hsystem = (/0.8, 0.2/)
! percentual of decidious wood in a forest
real :: dec_per
! planting year
integer :: plant_year = 0
integer :: flag_plant = 0
! costs, assets (spec, year)
real, allocatable, save, dimension(:,:) :: ms_costs
real, allocatable, save, dimension(:,:) :: ms_assets
real, allocatable, save, dimension(:,:) :: st_costs
real, allocatable, save, dimension(:,:) :: st_assets
end ! module data_wpm
!***************************************************************
!************* functions ***************************************
!***************************************************************
! initializes the inputfiles and fills the parameters
subroutine ini_input
use data_simul
use data_wpm
implicit none
integer i
!******************* ini wpm and sea **************************
do i =1,nr_years
years(i) = i
enddo
management_years(:) = 0
!******************* ini wpm **************************
! parameters for the round wood => product lines
do i=1,nr_pr_ln
product_lines(i)%value(:) = 0.
end do
! distribution of round wood to product lines
! redistribution of timber grades:
! wiener model
! product_lines(1)%proc_par(1,:) = (/0.6, 0., 0., 0., 0.4, 0., 0./)
! product_lines(2)%proc_par(1,:) = (/0., 0.6, 0., 0., 0.4, 0., 0./)
! product_lines(3)%proc_par(1,:) = (/0., 0., 0.6, 0., 0.4, 0., 0./)
! product_lines(4)%proc_par(1,:) = (/0., 0., 0., 0.6, 0.4, 0., 0./)
! product_lines(5)%proc_par(1,:) = (/0., 0., 0., 0., 1., 0., 0./)
! product_lines(6)%proc_par(1,:) = (/0., 0., 0., 0., 0., 1., 0./)
! product_lines(7)%proc_par(1,:) = (/0., 0., 0., 0., 0., 0., 1./)
! distribution of timber: industrial lines to product lines
! product_lines(1)%proc_par(2,:) = (/0.6, 0., 0.12, 0., 0.14, 0., 0.12/)
! product_lines(2)%proc_par(2,:) = (/0.6, 0., 0.12, 0., 0.14, 0., 0.12/)
! product_lines(3)%proc_par(2,:) = (/0., 0., 0.61, 0., 0.16, 0., 0.23/)
! product_lines(4)%proc_par(2,:) = (/0., 0., 0.61, 0., 0.16, 0., 0.23/)
! product_lines(5)%proc_par(2,:) = (/0., 0., 0., 0., 0.70, 0., 0.30/)
! product_lines(6)%proc_par(2,:) = (/0., 0., 0., 0., 0.71, 0., 0.30/)
! product_lines(7)%proc_par(2,:) = (/0., 0., 0., 0., 0., 0., 1.00/)
! 40% of 1st,2nd,3rd,4th timber grades must go to the 5th timber grade (industrial wood)
product_lines(1)%proc_par(1,:) = (/0.6, 0., 0., 0., 0.4, 0., 0./)
product_lines(2)%proc_par(1,:) = (/0., 0.6, 0., 0., 0.4, 0., 0./)
product_lines(3)%proc_par(1,:) = (/0., 0., 0.6, 0., 0.4, 0., 0./)
product_lines(4)%proc_par(1,:) = (/0., 0., 0., 0.6, 0.4, 0., 0./)
product_lines(5)%proc_par(1,:) = (/0., 0., 0., 0., 1., 0., 0./)
product_lines(6)%proc_par(1,:) = (/0., 0., 0., 0., 0., 1., 0./)
product_lines(7)%proc_par(1,:) = (/0., 0., 0., 0., 0., 0., 1./)
! distribution of timber grades to industrial lines - Brandenburg
product_lines(1)%proc_par(2,:) = (/0.97, 0., 0.03, 0., 0., 0., 0./)
product_lines(2)%proc_par(2,:) = (/0., 0.83, 0.17, 0., 0. , 0., 0./)
product_lines(3)%proc_par(2,:) = (/0.86, 0., 0.01, 0., 0.13, 0., 0./)
product_lines(4)%proc_par(2,:) = (/0., 0.53, 0.10, 0., 0.37, 0., 0./)
product_lines(5)%proc_par(2,:) = (/0., 0., 0., 0.66, 0.34, 0., 0./)
product_lines(6)%proc_par(2,:) = (/0., 0., 0., 0., 0., 0., 0./)
product_lines(7)%proc_par(2,:) = (/0., 0., 0., 0., 0., 0., 1./)
!distribution of timber into industrial lines - Germany
! product_lines(1)%proc_par(2,:) = (/0.97, 0., 0.03, 0., 0., 0., 0./)
! product_lines(2)%proc_par(2,:) = (/0., 0.83, 0.17, 0., 0. , 0., 0./)
! product_lines(3)%proc_par(2,:) = (/0.86, 0., 0.01, 0., 0.07, 0.06, 0./)
! product_lines(4)%proc_par(2,:) = (/0., 0.53, 0.10, 0., 0.20, 0.17, 0./)
! product_lines(5)%proc_par(2,:) = (/0., 0., 0., 0.66, 0.18, 0.16, 0./)
! product_lines(6)%proc_par(2,:) = (/0., 0., 0., 0., 0., 0., 0./)
! product_lines(7)%proc_par(2,:) = (/0., 0., 0., 0., 0., 0., 1./)
! distribution of timber: industrial lines to product lines
select case (flag_wpm)
! central europe
case (1:10)
product_lines(1)%proc_par(3,:) = (/0.610, 0., 0., 0.152, 0.141, 0., 0.097/)
product_lines(2)%proc_par(3,:) = (/0., 0.670, 0., 0.152, 0.119, 0., 0.082/)
product_lines(3)%proc_par(3,:) = (/0., 0., 0.530, 0.095, 0., 0., 0.375/)
product_lines(4)%proc_par(3,:) = (/0., 0., 0., 0.690, 0.080, 0., 0.230/)
product_lines(5)%proc_par(3,:) = (/0., 0., 0., 0., 0.472, 0., 0.528/)
product_lines(6)%proc_par(3,:) = (/0., 0., 0., 0., 0., 0.928, 0.072/)
product_lines(7)%proc_par(3,:) = (/0., 0., 0., 0., 0., 0., 1.000/)
! nothern europe
case (11:20)
product_lines(1)%proc_par(3,:) = (/0.435, 0., 0., 0.270, 0.435, 0., 0.130/)
product_lines(2)%proc_par(3,:) = (/0., 0.435, 0., 0.270, 0.435, 0., 0.130/)
product_lines(3)%proc_par(3,:) = (/0., 0., 0.384, 0., 0.339, 0., 0.277/)
product_lines(4)%proc_par(3,:) = (/0., 0., 0., 0.690, 0.080, 0., 0.230/)
product_lines(5)%proc_par(3,:) = (/0., 0., 0., 0., 0.472, 0., 0.528/)
product_lines(6)%proc_par(3,:) = (/0., 0., 0., 0., 0., 0.928, 0.072/)
product_lines(7)%proc_par(3,:) = (/0., 0., 0., 0., 0., 0., 1.000/)
! southern europe
case (21:30)
product_lines(1)%proc_par(3,:) = (/0.610, 0., 0.152, 0., 0.141, 0., 0.097/)
product_lines(2)%proc_par(3,:) = (/0., 0.670, 0.129, 0., 0.119, 0., 0.082/)
product_lines(3)%proc_par(3,:) = (/0., 0., 0.530, 0., 0., 0., 0.375/)
product_lines(4)%proc_par(3,:) = (/0., 0., 0., 0.095, 0.080, 0., 0.230/)
product_lines(5)%proc_par(3,:) = (/0., 0., 0., 0.690, 0.472, 0., 0.528/)
product_lines(6)%proc_par(3,:) = (/0., 0., 0., 0., 0., 0.928, 0.072/)
product_lines(7)%proc_par(3,:) = (/0., 0., 0., 0., 0., 0., 1.000/)
case (31:40)
!central europe
product_lines(1)%proc_par(3,:) = (/0.610, 0., 0., 0.152, 0.141, 0., 0.097/)
product_lines(2)%proc_par(3,:) = (/0., 0.670, 0., 0.152, 0.119, 0., 0.082/)
product_lines(3)%proc_par(3,:) = (/0., 0., 0.530, 0.095, 0., 0., 0.375/)
product_lines(4)%proc_par(3,:) = (/0., 0., 0., 0.690, 0.080, 0., 0.230/)
product_lines(5)%proc_par(3,:) = (/0., 0., 0., 0., 0.472, 0., 0.528/)
product_lines(6)%proc_par(3,:) = (/0., 0., 0., 0., 0., 0.928, 0.072/)
product_lines(7)%proc_par(3,:) = (/0., 0., 0., 0., 0., 0., 1.000/)
!distribution of timber into industrial lines - Germany
! product_lines(1)%proc_par(2,:) = (/0.97, 0., 0.03, 0., 0., 0., 0./)
! product_lines(2)%proc_par(2,:) = (/0., 0.83, 0.17, 0., 0. , 0., 0./)
! product_lines(3)%proc_par(2,:) = (/0.86, 0., 0.01, 0., 0.07, 0.06, 0./)
! product_lines(4)%proc_par(2,:) = (/0., 0.53, 0.10, 0., 0.20, 0.17, 0./)
! product_lines(5)%proc_par(2,:) = (/0., 0., 0., 0.66, 0.18, 0.16, 0./)
! product_lines(6)%proc_par(2,:) = (/0., 0., 0., 0., 0., 0., 0./)
! product_lines(7)%proc_par(2,:) = (/0., 0., 0., 0., 0., 0., 1./)
end select
!**************************************************************************************************************
! parameters for the product lines => "use categories"
product_lines(1)%use_par = (/0.35, 0.30, 0.10, 0.15, 0.10, 0., 0./)
product_lines(2)%use_par = (/0.35, 0.30, 0.10, 0.15, 0.10, 0., 0./)
product_lines(3)%use_par = (/0.05, 0.05, 0.30, 0.30, 0.30, 0., 0./)
product_lines(4)%use_par = (/0.20, 0.30, 0.10, 0.20, 0.20, 0., 0./)
product_lines(5)%use_par = (/0., 0., 0., 0., 0.33, 0.33, 0.34/)
product_lines(6)%use_par = (/0., 0., 0., 0., 0.34, 0.33, 0.33/)
product_lines(7)%use_par = (/0., 0., 0., 0., 0., 0., 0./)
!******************* ini lifespan **************************
short_lifespan%hl = 1.
short_lifespan%a = 120.
short_lifespan%b = 5.
short_lifespan%c = 3.
short_lifespan%d = 120.
medium_short_lifespan%hl = 4.
medium_short_lifespan%a = 120.
medium_short_lifespan%b = 5.
medium_short_lifespan%c = 0.5
medium_short_lifespan%d = 120.
medium_long_lifespan%hl = 16.
medium_long_lifespan%a = 120.
medium_long_lifespan%b = 5.
medium_long_lifespan%c = 0.12
medium_long_lifespan%d = 120.
long_lifespan%hl = 50.
long_lifespan%a = 120.
long_lifespan%b = 5.
long_lifespan%c = 0.04
long_lifespan%d = 120.
!************** ini use categories **************************
do i=1,nr_use_cat
use_categories(i)%value(:) = 0.
end do
use_categories(1)%lifespan_function = long_lifespan
use_categories(2)%lifespan_function = medium_long_lifespan
use_categories(3)%lifespan_function = short_lifespan
use_categories(4)%lifespan_function = medium_long_lifespan
use_categories(5)%lifespan_function = short_lifespan
use_categories(6)%lifespan_function = medium_short_lifespan
use_categories(7)%lifespan_function = short_lifespan
! recycling, landfill, burning
use_categories(1)%rec_par = (/0.30, 0.35, 0.35/)
use_categories(2)%rec_par = (/0.25, 0.50, 0.25/)
use_categories(3)%rec_par = (/0.15, 0.45, 0.40/)
use_categories(4)%rec_par = (/0.25, 0.50, 0.25/)
use_categories(5)%rec_par = (/0.72, 0.14, 0.14/)
use_categories(6)%rec_par = (/0.72, 0.14, 0.14/)
use_categories(7)%rec_par = (/0.72, 0.14, 0.14/)
! recycling parameters
! test parameters like in the wien model
! use_categories(1)%rec_use_par = (/1.00, 0., 0., 0., 0., 0., 0./)
! use_categories(2)%rec_use_par = (/0., 1.00, 0., 0., 0., 0., 0./)
! use_categories(3)%rec_use_par = (/0., 0., 1.00, 0., 0., 0., 0./)
! use_categories(4)%rec_use_par = (/0., 0., 0., 1.00, 0., 0., 0./)
! use_categories(5)%rec_use_par = (/0., 0., 0., 0., 1.00, 0., 0./)
! use_categories(6)%rec_use_par = (/0., 0., 0., 0., 0., 1.00, 0./)
! use_categories(7)%rec_use_par = (/0., 0., 0., 0., 0., 0., 1.00/)
! real parameters
use_categories(1)%rec_use_par = (/0.33, 0.34, 0.33, 0., 0., 0., 0./)
use_categories(2)%rec_use_par = (/0., 0.50, 0.50, 0., 0., 0., 0./)
use_categories(3)%rec_use_par = (/0., 0., 1.00, 0., 0., 0., 0./)
use_categories(4)%rec_use_par = (/0., 0., 0.5, 0.5, 0., 0., 0./)
use_categories(5)%rec_use_par = (/0., 0., 0., 0., 0.5, 0., 0.5/)
use_categories(6)%rec_use_par = (/0., 0., 0., 0., 0.5, 0., 0.5/)
use_categories(7)%rec_use_par = (/0., 0., 0., 0., 0.5, 0., 0.5/)
! test parameters
! use_categories(1)%rec_use_par = (/1.00, 0., 0., 0., 0., 0., 0./)
! use_categories(2)%rec_use_par = (/0., 1.00, 0., 0., 0., 0., 0./)
! use_categories(3)%rec_use_par = (/0., 0., 1.00, 0., 0., 0., 0./)
! use_categories(4)%rec_use_par = (/0., 0., 0., 1.00, 0., 0., 0./)
! use_categories(5)%rec_use_par = (/0., 0., 0., 0., 0.5, 0.5, 0./)
! use_categories(6)%rec_use_par = (/0., 0., 0., 0., 0., 1.00, 0./)
! use_categories(7)%rec_use_par = (/0., 0., 0., 0., 0., 0., 1.00/)
! wood_pieces containes the wood_pieces of different age
do i=1, nr_use_cat
max_age(i) = use_categories(i)%lifespan_function%hl * 3
end do
! allocation of spinup values
do i=1, nr_use_cat
allocate(use_categories(i)%spinup(max_age(i)))
end do
do i=1, nr_use_cat
use_categories(i)%spinup(:) = 0.
end do
burning(:) = 0.
atmo_cum(:) = 0.
atmo_year(:) = 0.
landfill(:) = 0.
sum_use_cat(:) = 0.
sum_input(:) = 0.
pl(:,:,:) = 0.
use_cat(:,:) = 0.
!******************* ini substitution **************************
emission_har = 0.
sub_energy = 0.
sub_material = 0.
sub_sum = 0.
sub_par (1) = -0.013 ! Emission from harvest
sub_par (2) = 0.601
sub_par (3) = 0.2651
end subroutine
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
subroutine ini_input_sea
use data_simul
use data_wpm
implicit none
!************************ ini sea ***********************
mansort_tg(:,:,:) = 0.
standsort_tg(:,:,:) = 0.
chainsaw_prices(:,:) = 0.
harvester_prices(:,:) = 0.
fence(:,:) = 0.
planting_prices(:) = 0.
planting_sub(:,:) = 0.
net_prices(:,:) = 0.
ms_costs(:,:) = 0.
st_costs(:,:) = 0.
ms_assets(:,:) = 0.
st_assets(:,:) = 0.
sum_costs(:,:) = 0.
subsidy(:,:) = 0.
npv(:,:) = 0.
brushing(:) = 0.
fix(:) = 0.
tending_prices(:) = 0.
dec_per = 0.
end subroutine
!********************** FLAGS **********************************
! set flags for the run
subroutine setFlags
use data_wpm
implicit none
! calculate product lines with or without bark
! wob = .FALSE.
wob = .TRUE.
! spin up flag: true - read and add the spin up values
spinup_on = .FALSE.
! spinup_on = .TRUE.
! debug and spinup outputs
debug = .FALSE.
! debug = .TRUE.
output_spinup = .FALSE.
! output_spinup = .TRUE.
end subroutine
!***************************************************************
subroutine allocate_in_output
use data_simul
use data_wpm
implicit none
! integer mansort_lines, nr_years, nr_management_years
integer i
! set some informations for wpm / sea
nr_years = year
! allocate output
if(flag_wpm.eq.5 .or.flag_wpm.eq.4 .or. flag_wpm.eq.6) then
nr_years = nr_management_years
end if
if (.not. allocated(years)) allocate(years(nr_years))
if (.not. allocated(management_years)) allocate(management_years(nr_management_years))
! only wpm
if (flag_wpm == 1 .or. flag_wpm == 3 .or. flag_wpm == 21 .or. flag_wpm == 11.or. flag_wpm == 5 .or. flag_wpm == 4 .or. flag_wpm == 6) then
nr_pr_ln = 7
nr_use_cat = 7
! allocate wood processing
if (.not. allocated(product_lines)) then
allocate(product_lines(nr_pr_ln))
do i=1,nr_pr_ln
allocate(product_lines(i)%value(nr_management_years))
end do
end if
! allocate pl: save results of the product lines sorting
if (.not. allocated(pl))allocate(pl(3, nr_pr_ln, nr_years))
! 6 use categories per simulation year
if (.not. allocated(use_categories)) then
allocate(use_categories(nr_use_cat))
do i=1,nr_use_cat
allocate(use_categories(i)%value(nr_years))
end do
end if
if (.not. allocated(max_age))allocate(max_age(nr_use_cat))
if (.not. allocated(burning))allocate(burning(nr_years))
if (.not. allocated(landfill))allocate(landfill(nr_years))
if (.not. allocated(atmo_cum))allocate(atmo_cum(nr_years))
if (.not. allocated(atmo_year))allocate(atmo_year(nr_years))
if (.not. allocated(sum_use_cat))allocate(sum_use_cat(nr_years))
if (.not. allocated(sum_input))allocate(sum_input(nr_years))
if (.not. allocated(use_cat))allocate(use_cat(nr_use_cat, nr_years))
! Substitution
if (.not. allocated(emission_har))allocate(emission_har(nr_years))
if (.not. allocated(sub_energy))allocate(sub_energy(nr_years))
if (.not. allocated(sub_material))allocate(sub_material(nr_years))
if (.not. allocated(sub_sum))allocate(sub_sum(nr_years))
end if
! only sea
if (flag_wpm == 2 .or. flag_wpm == 3.or.flag_wpm.eq.5 .or. flag_wpm.eq.6) then
nr_spec = 5
nr_timb_grades = 10
if (.not. allocated(mansort_tg)) allocate(mansort_tg(nr_spec, nr_timb_grades, nr_years))
if (.not. allocated(standsort_tg)) allocate(standsort_tg(nr_spec, nr_timb_grades, nr_years))
if (.not. allocated(chainsaw_prices)) allocate(chainsaw_prices(nr_spec, nr_timb_grades))
if (.not. allocated(harvester_prices)) allocate(harvester_prices(nr_spec, nr_timb_grades))
if (.not. allocated(planting_prices)) allocate(planting_prices(nr_spec))
if (.not. allocated(fence)) allocate(fence(2,nr_spec))
if (.not. allocated(planting_sub)) allocate(planting_sub(2,nr_spec))
if (.not. allocated(net_prices)) allocate(net_prices(nr_spec, nr_timb_grades))
if (.not. allocated(ms_costs)) allocate(ms_costs(nr_spec, nr_years))
if (.not. allocated(st_costs)) allocate(st_costs(nr_spec, nr_years))
if (.not. allocated(sum_costs)) allocate(sum_costs(5, nr_years))
if (.not. allocated(subsidy)) allocate(subsidy(2, nr_years))
if (.not. allocated(npv)) allocate(npv(12, nr_years))
if (.not. allocated(ms_assets)) allocate(ms_assets(nr_spec, nr_years))
if (.not. allocated(st_assets)) allocate(st_assets(nr_spec, nr_years))
end if
end subroutine
!***************************************************************
subroutine deallocate_wpm
use data_wpm
use data_simul
implicit none
integer i
! deallocate mansort and manrec lists
if ( associated(first_manrec)) then
act_manrec => first_manrec
do while ( associated(act_manrec))
first_manrec => act_manrec%next
deallocate(act_manrec)
act_manrec => first_manrec
end do
endif
if ( associated(first_mansort)) then
act_mansort => first_mansort
do while ( associated(act_mansort))
first_mansort => act_mansort%next
deallocate(act_mansort)
act_mansort => first_mansort
end do
endif
! deallocate wood processing
if (allocated(management_years)) deallocate(management_years)
do i=1,nr_pr_ln
if (associated(product_lines(i)%value)) deallocate(product_lines(i)%value)
end do
if (allocated(product_lines)) deallocate(product_lines)
if (allocated(pl)) deallocate(pl)
! deallocate output
if (allocated(years)) deallocate(years)
do i=1,nr_use_cat
if (associated(use_categories(i)%value)) deallocate(use_categories(i)%value)
if (associated(use_categories(i)%spinup)) deallocate(use_categories(i)%spinup)
end do
if (allocated(use_categories)) deallocate(use_categories)
if (allocated(max_age)) deallocate(max_age)
if (allocated(burning)) deallocate(burning)
if (allocated(landfill)) deallocate(landfill)
if (allocated(atmo_cum)) deallocate(atmo_cum)
if (allocated(atmo_year)) deallocate(atmo_year)
if (allocated(sum_use_cat)) deallocate(sum_use_cat)
if (allocated(sum_input)) deallocate(sum_input)
if (allocated(use_cat)) deallocate(use_cat)
! Sustitution
if (allocated(emission_har)) deallocate(emission_har)
if (allocated(sub_energy)) deallocate(sub_energy)
if (allocated(sub_material)) deallocate(sub_material)
if (allocated(sub_sum)) deallocate(sub_sum)
!sea
if (flag_wpm == 2 .or. flag_wpm == 3) then
if ( associated(first_standsort)) then
act_standsort => first_standsort
do while ( associated(act_standsort))
first_standsort => act_standsort%next
deallocate(act_standsort)
act_standsort => first_standsort
end do
endif
if (allocated(mansort_tg)) deallocate(mansort_tg)
if (allocated(standsort_tg)) deallocate(standsort_tg)
if (allocated(chainsaw_prices)) deallocate(chainsaw_prices)
if (allocated(harvester_prices)) deallocate(harvester_prices)
if (allocated(planting_prices)) deallocate(planting_prices)
if (allocated(fence)) deallocate(fence)
if (allocated(planting_sub)) deallocate(planting_sub)
if (allocated(net_prices)) deallocate(net_prices)
if (allocated(ms_costs)) deallocate(ms_costs)
if (allocated(st_costs)) deallocate(st_costs)
if (allocated(ms_assets)) deallocate(ms_assets)
if (allocated(st_assets)) deallocate(st_assets)
if (allocated(sum_costs)) deallocate(sum_costs)
if (allocated(subsidy)) deallocate(subsidy)
if (allocated(npv)) deallocate(npv)
end if
end subroutine
source_code/version_2.3_windows/aspen_manag.f 0 → 100644
View file @ 82df1085
!*****************************************************************!
!* *!
!* 4C (FORESEE) *!
!* *!
!* *!
!* Subroutines for: *!
!* Aspen management *!
!* contains: *!
!* SR aspman_ini *!
!* SR asp_manag *!
!* SR asp_sprout *!
!* SR asp_pruning *!
!* *!
!* Copyright (C) 1996-2018 *!
!* Potsdam Institute for Climate Impact Reserach (PIK) *!
!* Authors and contributors see AUTHOR file *!
!* This file is part of 4C and is licensed under BSD-2-Clause *!
!* See LICENSE file or under: *!
!* http://www.https://opensource.org/licenses/BSD-2-Clause *!
!* Contact: *!
!* https://gitlab.pik-potsdam.de/foresee/4C *!
!* *!
!*****************************************************************!
subroutine aspman_ini
use data_manag
use data_species
use data_simul
use data_stand
use data_par
implicit none
integer :: manag_unit,i, ios
character(len=150) :: filename
logical :: ex
character ::text
manag_unit=getunit()
filename = manfile(ip)
allocate(thin_flag1(nspec_tree))
thin_flag1 = -1
allocate(yman(100))
allocate(rel_part(100))
yman = 0
rel_part = 0
call testfile(filename,ex)
open(manag_unit,file=trim(filename))
! read head of data-file
do
read(manag_unit,*) text
if(text .ne. '#')then
backspace(manag_unit);exit
endif
enddo
i = 1
do
read(manag_unit,*,iostat=ios) yman(i), rel_part(i)
if(ios < 0) exit
i = i+1
end do
num_man = i-1
close(manag_unit)
end subroutine aspman_ini
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
subroutine asp_manag
use data_manag
use data_simul
implicit none
integer :: i
do i=1,num_man
if(yman(i).eq.time) then
call asp_pruning
if(i.ne.num_man) then
call asp_sprout
flag_sprout = 1
end if
end if
end do
end subroutine asp_manag
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
subroutine asp_sprout
use data_manag
use data_species
use data_simul
use data_stand
use data_par
use data_help
use data_soil
use data_tsort
implicit none
integer :: taxnr, i, j, nsp, acoh
REAL :: shoot
real :: faktor
REAL :: x1,x2,xacc,h_root, root
REAL :: rtflsp, stump_dw, stump_v, rtbis
TYPE(cohort) ::tree_ini
real, dimension(:), save, allocatable :: treea, crt, frt, stumpw
integer, dimension(:), save, allocatable :: spectyp, cohid
! distribution of coarse root matter of coppice shoots
real, dimension(6) :: fac_rob=(/0.0666, 0.1332, 0.1998, 0.2664,0.334, 0./)
external weight1
external rtflsp
external rtbis
allocate ( treea(anz_coh), crt(anz_coh), frt(anz_coh), spectyp(anz_coh), cohid(anz_coh), stumpw(anz_coh))
if(flag_reg.eq.18) then
nsprout = 5
end if
i = 1
zeig=>pt%first
do
if(.not.associated(zeig)) exit
if(zeig%coh%ntreem.ne.0.and. zeig%coh%ntreea.eq.0.and. zeig%coh%x_crt.ne.0) then
treea(i) = zeig%coh%ntreem
taxnr = zeig%coh%species
crt(i) = zeig%coh%x_crt
frt(i) = zeig%coh%x_frt
spectyp(i) = zeig%coh%species
cohid(i) = zeig%coh%ident
call stump( zeig%coh%x_ahb, zeig%coh%asapw,zeig%coh%dcrb,zeig%coh%x_hbole, &
zeig%coh%height, taxnr,stump_v, stump_dw)
stumpw(i) = stump_dw
i = i+1
end if
zeig=>zeig%next
end do
acoh = i-1
do i =1, acoh
if(flag_reg.eq.15) then
faktor = 0.25
else
faktor = fac_rob(1)
end if
do j = 1, nsprout
tree_ini%species = spectyp(i)
nsp = spectyp(i)
hnspec = nsp
h_root = faktor * (crt(i)*0.3 + stumpw(i)* 0.5)
max_coh= max_coh +1
call coh_initial (tree_ini)
tree_ini%ident = max_coh
tree_ini%x_age = 1
tree_ini%ntreea = treea(i)
tree_ini%nta = treea(i)
mschelp = h_root
x1 = 0.
x2 = 0.1
xacc = (1.0e-10) * (x1+x2)/2
root = rtbis(weight1,x1,x2,xacc)
tree_ini%x_sap = root
shoot = root*1000. ! [g]
tree_ini%x_fol= (spar(nsp)%seeda*(tree_ini%x_sap** spar(nsp)%seedb)) ![kg] ! [kg]
tree_ini%x_frt = faktor * frt(i) ! [kg]
tree_ini%med_sla = spar(nsp)%psla_min + spar(nsp)%psla_a*0.5
tree_ini%t_leaf = tree_ini%med_sla* tree_ini%x_fol ! [m-2]
tree_ini%ca_ini = tree_ini%t_leaf
IF(spar(tree_ini%species)%Phmodel==1) THEN
tree_ini%P=0
tree_ini%I=1
ELSE
tree_ini%P=0
tree_ini%I=0
tree_ini%Tcrit=0
END IF
zeig=>pt%first
do
if(.not.associated(zeig)) exit
if(zeig%coh%ident.eq. cohid(i)) then
tree_ini%rooteff = zeig%coh%rooteff
exit
end if
zeig=>zeig%next
end do
! tranformation of shoot biomass kg --> mg
if(nsp.ne.2)tree_ini%height = spar(nsp)%pheight1*(shoot*1000.)**spar(nsp)%pheight2 ! [cm] calculated from shoot biomass (mg)
if(tree_ini%height.eq.0.) then
nsp = nsp
end if
! bole height from stump
tree_ini%x_hbole = stoh(nsp)
IF(tree_ini%ntreea.ne.0.) then
IF (.not. associated(pt%first)) THEN
ALLOCATE (pt%first)
pt%first%coh = tree_ini
NULLIFY(pt%first%next)
ELSE
ALLOCATE(zeig)
zeig%coh = tree_ini
zeig%next => pt%first
pt%first => zeig
END IF
anz_coh=anz_coh+1
END IF
if(flag_reg.eq.15) then
faktor = faktor + 0.0833333
else
faktor = fac_rob(j+1)
end if
end do ! j, nsprouts
end do ! i
deallocate ( treea, crt, frt, spectyp,cohid, stumpw)
end subroutine asp_sprout
subroutine asp_pruning
use data_manag
use data_species
use data_simul
use data_stand
use data_par
implicit none
integer :: taxnr, j
zeig=>pt%first
do
if(.not.associated(zeig)) exit
zeig%coh%ntreem = zeig%coh%ntreea
zeig%coh%ntreea = 0
zeig%coh%nta = 0.
zeig=>zeig%next
end do
! calculation of total dry mass of all harvested trees (stem + twigs and branches)
sumNPP = 0
sumvsab = 0.
sumvsab_m3 = 0.
svar%sumvsab = 0.
zeig=>pt%first
do
if(.not.associated(zeig)) exit
ns = zeig%coh%species
sumvsab = sumvsab + zeig%coh%ntreem*(zeig%coh%x_sap + zeig%coh%x_hrt + zeig%coh%x_tb)
sumvsab_m3 = sumvsab_m3 + zeig%coh%ntreem*(zeig%coh%x_sap + zeig%coh%x_hrt+zeig%coh%x_tb)/(spar(ns)%prhos*1000000)
svar(ns)%sumvsab = svar(ns)%sumvsab + zeig%coh%ntreem*(zeig%coh%x_sap + zeig%coh%x_hrt + zeig%coh%x_tb)
sumnpp = sumnpp + zeig%coh%ntreem*zeig%coh%npp
zeig=>zeig%next
end do
sumvsab_m3 = sumvsab_m3 * 10000./kpatchsize ! kg/ha
sumvsab = sumvsab * 10000./kpatchsize ! kg/ha
do j = 1, nspec_tree
svar(j)%sumvsab = svar(j)%sumvsab * 10000./kpatchsize
end do
! cumulative harvested stem mass
cumsumvsab = cumsumvsab + sumvsab
! litter pools
! adding biomasses to litter pools depending on stage of stand
zeig=>pt%first
do
if(.not.associated(zeig)) exit
taxnr=zeig%coh%species
if(zeig%coh%ntreem>0)then
! all parts without stems of trees are input for litter
zeig%coh%litC_fol = zeig%coh%litC_fol + zeig%coh%ntreem*(1.-spar(taxnr)%psf)*zeig%coh%x_fol*cpart
zeig%coh%litN_fol = zeig%coh%litN_fol + zeig%coh%ntreem*((1.-spar(taxnr)%psf)*zeig%coh%x_fol*cpart)/spar(taxnr)%cnr_fol
endif
zeig=>zeig%next
enddo
end subroutine asp_pruning
source_code/version_2.3_windows/aust_manag.f 0 → 100644
View file @ 82df1085
!*****************************************************************!
!* *!
!* 4C (FORESEE) *!
!* *!
!* *!
!* Subroutines for: *!
!* Austrian management *!
!* contains: *!
!* SR aust_ini *!
!* SR aust_manag *!
!* SR plant_aust *!
!* SR calc_rel_class *!
!* *!
!* Copyright (C) 1996-2018 *!
!* Potsdam Institute for Climate Impact Reserach (PIK) *!
!* Authors and contributors see AUTHOR file *!
!* This file is part of 4C and is licensed under BSD-2-Clause *!
!* See LICENSE file or under: *!
!* http://www.https://opensource.org/licenses/BSD-2-Clause *!
!* Contact: *!
!* https://gitlab.pik-potsdam.de/foresee/4C *!
!* *!
!*****************************************************************!
SUBROUTINE aust_ini
use data_manag
use data_species
use data_simul
use data_stand
implicit none
integer :: manag_unit,i, ih1,ih2,ios,ih4, flp , flag_help
character(len=150) :: filename
logical :: ex
character ::text
real :: hp, ih3
manag_unit=getunit()
filename = manfile(ip)
allocate(thin_flag1(nspec_tree))
flag_help = 0
thin_flag1=-1
thin_dead = 1
allocate(yman(1000))
allocate(dbh_clm(1000))
allocate(rem_clm(1000))
allocate(spec_man(1000))
allocate(act(1000))
allocate(rel_part(1000))
yman = 0
dbh_clm = 0
rem_clm = 0.
spec_man = 0
act = 0
rel_part = 0
flp = 0
call testfile(filename,ex)
open(manag_unit,file=trim(filename))
! read head of data-file
do
read(manag_unit,*) text
if(text .ne. 's')then
backspace(manag_unit);exit
endif
enddo
i=1
do
read(manag_unit,*,iostat=ios) ih1,ih2, ih3, hp,ih4
if(ios<0) exit
yman(i) = ih1 ! year of treatment
if(ih2.eq.1) then
! Fichte/ Spruce
spec_man(i) = 2
else if(ih2.eq.2) then
! Kiefer/ Pine
spec_man(i) = 3
else if(ih2.eq.3) then
! Eiche/ oak
spec_man(i) = 4
else if(ih2.eq.4) then
spec_man(i) = 1
end if
! species number
act(i) = ih4
if(ih1.ne.-999 ) then
if(flp.eq.0) then
dbh_clm(i) = int(ih3) ! dbh-cluss number for treatment
rem_clm(i) = hp ! removal of biomass
i = i+1
else
act(i) = ih4
rel_part(i) = ih3
rem_clm(i) = 0
i = i+1
end if
else
if(i.eq.1) thin_dead = 0
flp = 1
backspace(manag_unit)
end if
end do
num_man = i-1
close(manag_unit)
END SUBROUTINE aust_ini
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
SUBROUTINE aust_manag
use data_manag
use data_stand
use data_simul
use data_species
use data_par
implicit none
integer :: i,j,hcl, ha, taxnr,k,l, help_fl,helpz, helps
real, dimension(5) :: rel_biom, harv_biom
real, dimension(5) :: num_ccl, contr
real,dimension(5) :: help_rem_clm
integer,dimension(5) :: help_rel_dbh, hrd
real :: stump_dw, stump_v, hrb
ha =0
rel_biom = 0.
num_ccl =0
harv_biom = 0.
help_rel_dbh = 0
help_rem_clm = 0.
hrd = 0
helpz = 0
helps = 0
call calc_rel_class
! calculation of stem biomass of relative dbh-class
zeig=>pt%first
do
if(.not.associated(zeig)) exit
if(zeig%coh%diam.ne.0) then
hcl = zeig%coh%rel_dbh_cl
if(hcl.ne.0) then
num_ccl(hcl)= num_ccl(hcl) +1
rel_biom(hcl)= rel_biom(hcl) + (zeig%coh%x_sap + zeig%coh%x_hrt)*zeig%coh%ntreea
end if
end if
zeig=>zeig%next
end do
do l=1,nspecies
help_rel_dbh = 0
help_rem_clm = 0.
helpz = 0
helps = 0
! calculation of stem biomass of relative dbh-class
zeig=>pt%first
do
if(.not.associated(zeig)) exit
if(zeig%coh%diam.ne.0.and.zeig%coh%species.eq.l) then
hcl = zeig%coh%rel_dbh_cl
if(hcl.ne.0) then
num_ccl(hcl)= num_ccl(hcl) +1
rel_biom(hcl)= rel_biom(hcl) + (zeig%coh%x_sap + zeig%coh%x_hrt)*zeig%coh%ntreea
end if
end if
zeig=>zeig%next
end do
hrd=0
do i=1,num_man
if(yman(i).eq.time) then
if(act(i) .eq.1.and.spec_man(i).eq.l) then
zeig=>pt%first
do
if(.not.associated(zeig)) exit
if(zeig%coh%diam.ne.0) then
if(zeig%coh%species.eq.l) then
hrd(zeig%coh%rel_dbh_cl)= 1
end if
end if
zeig=>zeig%next
end do
help_rel_dbh(dbh_clm(i)) = 1
help_rem_clm(dbh_clm(i)) = rem_clm(i)
end if ! act(i)
end if !yman(i)
end do ! num_man
do j=1,5
if(help_rel_dbh(j).eq.1.and.hrd(j).eq.0) then
if(j.eq.1.) then
do k=2,5
if(hrd(k).ne.0) then
help_rem_clm(k) = help_rem_clm(k) + help_rem_clm(j)
help_rel_dbh(k)=1
exit
end if
end do
else if (j.eq.5.) then
do k= 4,1,-1
if(hrd(k).eq.1) then
help_rem_clm(k) = help_rem_clm(k) + help_rem_clm(j)
help_rel_dbh(k) = 1
exit
endif
end do
else
do k=j,5
if(hrd(k).eq.1) then
help_rem_clm(k) = help_rem_clm(k) + help_rem_clm(j)*0.5
help_rel_dbh(k) = 1
exit
end if
end do
do k=j,1,-1
if(hrd(k).eq.1) then
help_rem_clm(k) = help_rem_clm(k) + help_rem_clm(j)*0.5
help_rel_dbh(k) = 1
exit
end if
end do
end if
help_rel_dbh(j) = 0
help_rem_clm(j) = 0.
end if
end do
! thinning
help_fl = 0
do i=1,num_man
if(yman(i).eq.time.and.help_fl.eq.0) then
do k=1,5
helps = helps + help_rel_dbh(k)
end do
help_fl=1
zeig=>pt%first
do
if(.not.associated(zeig)) exit
if(zeig%coh%diam.ne.0.and.zeig%coh%species.eq.l) then
do k=1,5
if(zeig%coh%rel_dbh_cl.eq.k.and.help_rel_dbh(k).eq.1) then
if(help_rem_clm(k).gt.1.) help_rem_clm(k) = 1.
if( help_rem_clm(k) .eq. 1.)then
if(zeig%coh%underst.eq.0.and.zeig%coh%x_age.gt. 20) ha=int(help_rem_clm(k)* zeig%coh%ntreea+0.5)
helpz = helpz +1
else
ha=int(help_rem_clm(k)* zeig%coh%ntreea+0.5)
end if
if(ha.lt.1) ha = 1
if(help_rem_clm(k) .ne.1) then
harv_biom(k) = harv_biom(k) + ha* (zeig%coh%x_sap + zeig%coh%x_hrt)
hrb = help_rem_clm(k)* rel_biom(k)
if(harv_biom(k).eq.rel_biom(k)) then
ha = ha -1
end if
end if
zeig%coh%ntreea = zeig%coh%ntreea - ha
zeig%coh%nta = zeig%coh%ntreea
zeig%coh%ntreem = zeig%coh%ntreem + ha
end if
end do ! k loop
end if
zeig=>zeig%next
end do ! zeig loop
end if
end do ! num_man
if(helps.gt.0.and.helpz.ge.helps) then
zeig=>pt%first
do
if(.not.associated(zeig)) exit
if(zeig%coh%species.eq.l.and.zeig%coh%underst.eq.1) then
zeig%coh%underst = 0
end if
zeig => zeig%next
end do
end if
write(9898,*) time, 'totbio', rel_biom
write(9898,*) time, 'harvbio', harv_biom
do i=1,5
if(rel_biom(i).ne.0.) then
contr(i) = harv_biom(i)/rel_biom(i)
else
contr(i) = 0.
end if
end do
write(9898,*) time,l, contr
rel_biom = 0.
harv_biom = 0.
end do ! nspecies
! planting
do i=1,num_man
if(yman(i).eq.time.and.act(i).ne.1) then
call plant_aust(i)
end if ! act
end do
stump_sum = 0
zeig=>pt%first
do
if(.not.associated(zeig)) exit
taxnr=zeig%coh%species
if(zeig%coh%ntreem>0)then
! all parts without stems of trees are input for litter
zeig%coh%litC_fol = zeig%coh%litC_fol + zeig%coh%ntreem*(1.-spar(taxnr)%psf)*zeig%coh%x_fol*cpart
zeig%coh%litN_fol = zeig%coh%litN_fol + zeig%coh%ntreem*((1.-spar(taxnr)%psf)*zeig%coh%x_fol*cpart)/spar(taxnr)%cnr_fol
zeig%coh%litC_frt = zeig%coh%litC_frt + zeig%coh%ntreem*zeig%coh%x_frt*cpart
zeig%coh%litN_frt = zeig%coh%litN_frt + zeig%coh%ntreem*zeig%coh%x_frt*cpart/spar(taxnr)%cnr_frt
zeig%coh%litC_tb = zeig%coh%litC_tb + zeig%coh%ntreem*zeig%coh%x_tb*cpart
zeig%coh%litN_tb = zeig%coh%litN_tb + zeig%coh%ntreem*zeig%coh%x_tb*cpart/spar(taxnr)%cnr_tbc
zeig%coh%litC_crt = zeig%coh%litC_crt + zeig%coh%ntreem*zeig%coh%x_crt*cpart
zeig%coh%litN_crt = zeig%coh%litN_crt + zeig%coh%ntreem*zeig%coh%x_crt*cpart/spar(taxnr)%cnr_crt
! stumps into stem litter
call stump( zeig%coh%x_ahb, zeig%coh%asapw,zeig%coh%dcrb,zeig%coh%x_hbole, &
zeig%coh%height, taxnr,stump_v, stump_dw)
zeig%coh%litC_stem = zeig%coh%litC_stem + zeig%coh%ntreem*stump_dw*cpart
zeig%coh%litN_stem = zeig%coh%litC_stem/spar(taxnr)%cnr_stem
stump_sum = stump_sum + zeig%coh%ntreem*stump_dw
endif
zeig=>zeig%next
enddo
sumvsab = 0.
sumvsab_m3 = 0.
svar%sumvsab = 0.
zeig=>pt%first
do while (associated(zeig))
ns = zeig%coh%species
sumvsab = sumvsab + zeig%coh%ntreem*(zeig%coh%x_sap + zeig%coh%x_hrt)
sumvsab_m3 = sumvsab_m3 + zeig%coh%ntreem*(zeig%coh%x_sap + zeig%coh%x_hrt)/(spar(ns)%prhos*1000000)
svar(ns)%sumvsab = svar(ns)%sumvsab + zeig%coh%ntreem*(zeig%coh%x_sap + zeig%coh%x_hrt)
zeig=>zeig%next
end do
sumvsab = sumvsab * 10000./kpatchsize ! kg/ha
sumvsab_m3 = sumvsab_m3 * 10000./kpatchsize ! kg/ha
do k = 1, nspec_tree
svar(k)%sumvsab = svar(k)%sumvsab * 10000./kpatchsize ! kg/ha
end do
! cumulative harvested stem mass
cumsumvsab = cumsumvsab + sumvsab
if(thin_dead.ne.0) then
call class_man
end if
END SUBROUTINE aust_manag
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
SUBROUTINE plant_aust(mp)
use data_manag
use data_plant
use data_species
use data_stand
implicit none
integer :: fl_plant, i, nplant,taxid,mp
real :: age, &
pl_height, &
sdev, &
plhmin
infspec = 0
npl_mix = 0
fl_plant = act(mp)
select case(fl_plant)
case(2)
infspec(2) = 1
npl_mix(2) = 2500
case(3)
infspec(2) = 1
npl_mix(2) = 10000
case(4)
infspec(3) = 1
npl_mix(3) = 5000
case(5)
infspec(3) = 1
npl_mix(3) = 2000
case(6)
infspec(1) = 1
npl_mix(1) = 500
case(7)
infspec(1) = 1
npl_mix(1) = 5000
case(8)
infspec(4) = 1
npl_mix(4) = 5000
case(9)
infspec(1) = 1
npl_mix(1) = 1000
infspec(4) = 1
npl_mix(4) = 3500
case(10)
infspec(3) = 1
npl_mix(3) = 2500
infspec(4) = 1
npl_mix(4) = 2500
case(11)
infspec(3) = 1
npl_mix(3) = 2500
infspec(1) = 1
npl_mix(1) = 2500
case(12)
infspec(3) = 1
npl_mix(3) = 7000
case(13)
infspec(4) = 1
npl_mix(4) = 2500
end select
do i = 1,nspec_tree
if (infspec(i).eq.1) then
taxid = i
! data for Austria
age = pl_age(taxid)
pl_height = plant_height(taxid)
plhmin = plant_hmin(taxid)
nplant = rel_part(mp)*nint(npl_mix(taxid)*kpatchsize/10000)
sdev = hsdev(taxid)
call gener_coh(taxid, age, pl_height, plhmin, nplant,sdev)
end if
end do ! i
END SUBROUTINE plant_aust
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
SUBROUTINE calc_rel_class
use data_manag
use data_stand
use data_species
implicit none
integer :: nrmax, i, j, k, adm
real,dimension(10) :: maxdbh, mindbh,class_wd
integer :: nrmin
real :: help, help_h1
class_wd =0.
maxdbh = 0.
mindbh = 0.
do j= 1,nspecies
call max_dbh(nrmax,help,adm, j)
call min_dbh(nrmin,help_h1,adm, j)
zeig=>pt%first
do
if(.not.associated(zeig)) exit
if(zeig%coh%ident.eq.nrmax.and.zeig%coh%species.eq.j) then
maxdbh(j) = help
else if(zeig%coh%ident.eq.nrmin.and.zeig%coh%species.eq.j) then
mindbh(j) = help_h1
end if
zeig=>zeig%next
end do
end do
do j=1,nspecies
class_wd(j) = (maxdbh(j)-mindbh(j))/5
k = 5
zeig=>pt%first
do
if(.not.associated(zeig)) exit
if(zeig%coh%species.eq.j.and. zeig%coh%diam.gt.0) then
do i=1,k
if(zeig%coh%diam.ge.(mindbh(j)+class_wd(j)*(i-1)).and.zeig%coh%diam.lt.(mindbh(j)+class_wd(j)*i)) then
zeig%coh%rel_dbh_cl = i
exit
else if (zeig%coh%diam.eq.maxdbh(j)) then
zeig%coh%rel_dbh_cl = 5
end if
end do
end if
zeig=>zeig%next
end do
end do
END SUBROUTINE calc_rel_class
source_code/version_2.3_windows/calc_climdriv.f 0 → 100644
View file @ 82df1085
!*****************************************************************!
!* *!
!* 4C (FORESEE) Simulation Model *!
!* *!
!* *!
!* SR photoper *!
!* *!
!* contains follow global units: *!
!* photoper function for calculation of photoperiod *!
!* daylength calculation of day length *!
!* avg_sun_incl Calculates average sun declination for *!
! the season at the given latitude in degrees *!
!* fixclimscen subroutine for calculation of delta T and P *!
!* glob_rad Estimation of global radiation from sunshine *!
!* frost_index_total subroutine for calculation of frost index *!
!* *!
!* Copyright (C) 1996-2018 *!
!* Potsdam Institute for Climate Impact Reserach (PIK) *!
!* Authors and contributors see AUTHOR file *!
!* This file is part of 4C and is licensed under BSD-2-Clause *!
!* See LICENSE file or under: *!
!* http://www.https://opensource.org/licenses/BSD-2-Clause *!
!* Contact: *!
!* https://gitlab.pik-potsdam.de/foresee/4C *!
!* *!
!*****************************************************************!
REAL FUNCTION PHOTOPER(d,xlatitude)
! by Thomas Kartschall 8.7.92
!
! PhotoPeriod -Potential daily Sun Shine Period [h]
! d -Ordinal Number of Julian Date [Real!4]
! latitude -Latitude by Radiant [Real!4]
! Northern L>0; Southern L<0
!
! Polarkreis bei je 66.55 bzw 6633'36'' N/SL
!
USE data_par
USE data_simul
real d, xlatitude, del, ws, ws2
!
! Equator from 0,2 respectively 012'
!
IF (abs(xlatitude).lt.0.0024) then
photoper=12.0
return
ENDIF
!
!pole surrounding ab 89,8 bzw 8948'
!
IF (xlatitude.ge. 1.567305668)xlatitude= 1.567305668
IF (xlatitude.le.-1.567305668) xlatitude=-1.567305668
g=2*pi*(d-1.0)/365.25
del=0.006918-0.399912*cos(g)
del=del+0.070257*sin(g)-0.006758*cos(g+g)
del=del+0.000907*sin(g+g)-0.002697*cos(g+g+g)
del=del+0.00148*sin(g+g+g)
ws=sin(xlatitude)*sin(del)
ws2=cos(xlatitude)*cos(del)
!
!polar night duration per day no longer than 24h
!
IF (ws/ws2.ge.1.0) ws=ws2
IF (ws/ws2.le.-1.0) ws=-ws2
ws=acos(ws/ws2)
ws=12.*(1.-ws/pi)
!day length is dopple the time between HighNoon and SunRise
PHOTOPER=2.*(ws)
RETURN
END FUNCTION photoper
!*******************************************************************
FUNCTION DAYLENGTH(doy,hlat)
USE data_par
IMPLICIT NONE
REAL :: hlat
REAL :: daylength
INTEGER :: doy
REAL :: decl,arg
decl = -23.45*(PI/180)*COS(2.*PI/365.*(doy+10))
! latitude is converted to rad
arg = -TAN(hlat*PI/180.)*TAN(decl);
IF( arg < -1. ) THEN
daylength = 24.
ELSE IF ( arg > 1. ) THEN
daylength = 0.
ELSE
daylength = (24./PI)*ACOS(arg)
ENDIF
END FUNCTION DAYLENGTH
!*******************************************************************
FUNCTION AVG_SUN_INCL(hlat)
!Calculates average sun declination for the season
! at the given latitude in degrees
use data_par
implicit none
REAL :: avg_sun_incl
REAL :: hlat, h1, h2, h3
REAL :: decl, sumbeta, dl, sumdl
INTEGER :: i, j
REAL, EXTERNAL :: daylength
sumdl = 0
sumbeta = 0
h1 = sin(PI*hlat/180)
h2 = cos(PI*hlat/180)
DO i=120,280,+1
decl = -23.45*(PI/180)*COS(2.*PI/365.*(i+10))
dl = DAYLENGTH(i,hlat)
! sun declination at noon
h3 = h1*sin(decl)+h2*cos(decl)
if(h3.gt.1.) h3 = 1
avg_sun_incl = 180/PI*asin(h3);
sumbeta = sumbeta + avg_sun_incl*dl;
sumdl = sumdl + dl;
END DO
avg_sun_incl = sumbeta/sumdl
END FUNCTION AVG_SUN_INCL
!*******************************************************************
SUBROUTINE fixclimscen
! fixclimscen calculates deltaT and deltaPrec for climate change scenarios with
! fixed offsets in temperature and precipitation
USE data_simul
IMPLICIT NONE
INTEGER :: dimTsteps, dimPsteps
! calculations
dimTsteps = 1 + n_T_downsteps + n_T_upsteps
dimPsteps = 1 + n_P_downsteps + n_P_upsteps
deltaT = ((ip-1)/dimPsteps-n_T_downsteps)*step_sum_T
deltaPrec = 1.+((ip-1)-((ip-1)/dimPsteps)*dimPsteps-n_P_downsteps)*step_fac_P
CALL out_scen
END SUBROUTINE fixclimscen
!****************************************************************************
SUBROUTINE glob_rad(sd, iday, xlat, rad)
! Estimation of global radiation from sunshine duration
! (calculation after Angstrom)
implicit none
! input:
integer :: iday ! actual day
real :: sd ! sunshine duration (h)
real :: xlat ! latitude
! output:
real :: rad ! global radiation (J/cm2)
! internal variables
real :: rad_ex , & ! extraterrestrical radiation (J/cm2)
dayl , & ! daylength
dec , & ! declination of sun angle
sinld, cosld, tanld, dsinb, dsinbe, &
sc, radi, seas
real :: pi = 3.141592654
real :: solc = 1367. ! solar constant (J/(m2*s)
! after P. Hupfer: "Klimasystem der Erde", 1991
! change of units from degree to radians
pi = 3.141592654
radi = pi/180.
! term of seasonality (10 days in front of calendar)
seas = (iday+10.)/365.
! declination of sun angle
! (Spitters et al. 1986, equations transformed for use or radians)
dec = -asin(sin(23.45*radi)*cos(2.*pi*seas))
! some intermediate values
sinld = sin(xlat*radi)*sin(dec)
cosld = cos(xlat*radi)*cos(dec)
tanld = amax1(-1., amin1(1., sinld/cosld))
! daylength
dayl = 12.*(1.+2.*asin(tanld)/pi)
! integral of sun elevation
dsinb = 3600.*(dayl*sinld+24.*cosld*sqrt(1.-tanld*tanld)/pi)
! corrected integral of sun elevation
dsinbe = 3600.*(dayl*(sinld+0.4*(sinld*sinld+cosld*cosld*0.5)) &
+12.*cosld*(2.+3.*0.4*sinld)*sqrt(1.-tanld*tanld)/pi)
! intensity of radiation outside the atmosphere
sc = solc/(1.-0.016729*cos((360./365.)*(iday-4.)*radi))**2.
rad_ex = sc*(1.+0.033*cos(2.*pi*iday/365.))*dsinbe
! unit conversion in MJ/m2: rad_ex = rad_ex/1000000.
! unit conversion in J/cm2
rad_ex = rad_ex * 0.0001
if (sd.ge.0.) then
rad = (0.231+0.539*sd/dayl)*rad_ex
else
write (*, '(A, I3, A)') ' RAD is out of range at day ', iday , &
' , RAD will be = 1000 J/cm2!'
end if
END SUBROUTINE glob_rad
!****************************************************************************
subroutine frost_index_total
use data_frost
use data_simul
use data_stand
implicit none
integer :: zaehl=0
integer :: i
integer :: zaehl1 =0
integer :: t,m,j
real :: mean_dnlf
real :: mean_tminmay
integer :: mean_date_lf
integer :: mean_date_lftot
real :: mean_dnlf_sp
real :: mean_tminmay_sp
integer :: mean_date_lf_sp
real :: mean_anzdlf
real :: mean_sumtlf
integer :: ind1, ind2, ind3, ind4, ind5
integer :: ind1_sp
zaehl=0
mean_tminmay = 0.
mean_date_lf = 0
mean_date_lftot = 0
mean_dnlf = 0
mean_dnlf_sp = 0
mean_anzdlf = 0
mean_sumtlf = 0
do i =1,year
if(tminmay_ann(i).ne.0) then
zaehl = zaehl +1
mean_tminmay= mean_tminmay+tminmay_ann(i)
end if
end do
if(zaehl.ne.0) then
mean_tminmay = mean_tminmay/zaehl
else
mean_tminmay = 0.
end if
do i=1,year
mean_anzdlf = mean_anzdlf + anzdlf(i)
mean_sumtlf = mean_sumtlf + sumtlf(i)
end do
mean_anzdlf = mean_anzdlf/year
mean_sumtlf = mean_sumtlf/year
zaehl=0
do i =1,year
if(date_lftot(i).ne.0) then
zaehl = zaehl +1
mean_date_lftot = mean_date_lftot + date_lftot(i)
end if
end do
if(zaehl.ne.0) then
mean_date_lftot = mean_date_lftot/zaehl
else
mean_date_lftot = 0.
end if
mean_dnlf = 0.
zaehl=0
do i =1,year
if(dnlf(i).ne.0) then
mean_dnlf = mean_dnlf + dnlf(i)
zaehl = zaehl +1
end if
end do
if(zaehl.ne.0) then
mean_dnlf = mean_dnlf/zaehl
else
mean_dnlf = 0
endif
zaehl=0
do i =1,year
if(date_lf(i).ne.0) then
mean_date_lf = mean_date_lf + date_lf(i)
zaehl = zaehl +1
end if
enddo
if(zaehl.ne.0) then
mean_date_lf = mean_date_lf/zaehl
else
mean_date_lf = 0
end if
zaehl1=0
do i =1,year
if(dnlf_sp(i).ne.0) then
zaehl1 = zaehl1 +1
mean_dnlf_sp = mean_dnlf_sp + dnlf_sp(i)
end if
enddo
if (zaehl1.ne.0) then
mean_dnlf_sp = mean_dnlf_sp/zaehl1
else
mean_dnlf_sp = 0
endif
if (mean_dnlf.le.2.5 .and. mean_tminmay.ge. -1.5 .and.tminmay.ge.-5.0 .and. mean_date_lf.lt.130 .and. dlfabs .lt. 156) lfind=1
if (mean_dnlf.ge.2.6 .and. mean_dnlf .le.3.5 .and. mean_tminmay.ge. -2.0 .and. mean_tminmay.lt.-1.5 .and. tminmay .ge.-6. .and. mean_date_lf .lt.135 .and. dlfabs .lt.161) lfind=2
if (mean_dnlf.gt.3.5 .and. mean_dnlf .le.4.5 .and. mean_tminmay.ge. -2.5 .and. mean_tminmay.lt.-2.0 .and. tminmay .ge.-6. .and. mean_date_lf .ge.135 .and. mean_date_lf .le. 140 .and. dlfabs .ge.162 .and. dlfabs.le.166) lfind=3
if (mean_dnlf.gt.4.5 .and. mean_dnlf .le.5.0 .and. mean_tminmay.ge. -3.0 .and. mean_tminmay.lt.-2.5 .and. tminmay .ge.-7. .and. mean_date_lf .ge.141 .and. mean_date_lf .le. 145 .and. dlfabs .ge.167 .and. dlfabs.le.171) lfind=4
if (mean_dnlf.gt.5.10 .and. mean_dnlf .le.5.5 .and. mean_tminmay.ge. -3.5 .and. mean_tminmay.lt.-3.0 .and. tminmay .ge.-8. .and. mean_date_lf .ge.141 .and. mean_date_lf .le. 145 .and. dlfabs .ge.172 .and. dlfabs.le.176) lfind=5
if (mean_dnlf.gt.5.5 .and. mean_tminmay.lt.-3.5 .and. tminmay .le.-8. .and. mean_date_lf .gt.145 .and. dlfabs .gt.176) lfind=6
! index of number of late frost days since beginning of vegetation period
if (mean_dnlf.le.2.5) then
ind1 = 1
else if(mean_dnlf.le.3.5) then
ind1 = 2
else if (mean_dnlf.le.4.5) then
ind1 = 3
else if (mean_dnlf.le.5.0) then
ind1 = 4
else if (mean_dnlf.le.5.5) then
ind1 = 5
else
ind1 = 6
endif
! index of number of late frost days since beginning of bud burst
if (mean_dnlf_sp .le. 2.5) then
ind1_sp= 1
else if(mean_dnlf_sp.le.3.5) then
ind1_sp = 2
else if (mean_dnlf_sp.le.4.5) then
ind1_sp = 3
else if (mean_dnlf.le.5.0) then
ind1_sp = 4
else if (mean_dnlf_sp.le.5.5) then
ind1_sp = 5
else
ind1_sp = 6
endif
! index of mean minimum may temperature
if(mean_tminmay.ge. -1.5) then
ind2 = 1
else if (mean_tminmay.ge. -2.0) then
ind2 = 2
else if (mean_tminmay.ge. -2.5) then
ind2 = 3
else if (mean_tminmay.ge. -3.0) then
ind2 = 4
else if (mean_tminmay.ge. -3.5) then
ind2 = 5
else
ind2 =6
endif
! index of absolute minimum may temperature
if(tminmay.ge.-5.0) then
ind3 = 1
else if(tminmay.ge.-6.0 .and. ind2 .le.2) then
ind3 = 2
else if (tminmay.ge.-6.0 .and. ind2 .le.3) then
ind3 =3
else if (tminmay.ge.-7.0) then
ind3 = 4
else if (tminmay.ge.-8.0) then
ind3 = 5
else
ind3 = 6
end if
! index of mean date(number of the year) of late frost
if (mean_date_lf.lt.130) then
ind4 = 1
else if (mean_date_lf.lt.135) then
ind4 = 2
else if (mean_date_lf.le.140 ) then
ind4 = 3
else if (mean_date_lf.le.145 .and. ind2.le.4) then
ind4 = 4
else if(mean_date_lf.le.145 .and. ind2.le.5) then
ind4 = 5
else
ind4 = 6
endif
! absolute last late frost (numbedr of the year)
if (dlfabs .lt. 156) then
ind5 = 1
else if (dlfabs .lt. 161) then
ind5 = 2
else if (dlfabs .le. 162) then
ind5 =3
else if (dlfabs .le. 171) then
ind5 = 4
else if (dlfabs .le. 176) then
ind5 = 5
else
ind5 =6
endif
mlfind = real((ind1 + ind2 + ind3 + ind4 + ind5)/5)
mlfind_sp = (ind1_sp + ind2 + ind3 + ind4 + ind5)/5
if(waldtyp.eq. 10 .or. waldtyp .eq. 40 .or. waldtyp .eq.90) mlfind_sp = 0
end subroutine frost_index_total
source_code/version_2.3_windows/canopy.f 0 → 100644
View file @ 82df1085
!*****************************************************************!
!* *!
!* 4C (FORESEE) Simulation Model *!
!* *!
!* *!
!* Subroutine canopy for: *!
!* Calculation of canopy geometry & light absorption *!
!* with *!
!* CALC_LA *!
!* LIGHT_GROWTH *!
!* COV_AREA *!
!* Light_1 *!
!* Light_2 *!
!* Light_3 *!
!* Light_4 *!
!* L_3_COH_LOOP *!
!* L_4_COH_LOOP *!
!* LIGHT_OUT_2 *!
!* CROWN_PROJ *!
!* *!
!* Copyright (C) 1996-2018 *!
!* Potsdam Institute for Climate Impact Reserach (PIK) *!
!* Authors and contributors see AUTHOR file *!
!* This file is part of 4C and is licensed under BSD-2-Clause *!
!* See LICENSE file or under: *!
!* http://www.https://opensource.org/licenses/BSD-2-Clause *!
!* Contact: *!
!* https://gitlab.pik-potsdam.de/foresee/4C *!
!* *!
!*****************************************************************!
!**********************************!
!* SUBROUTINE CANOPY *!
!**********************************!
SUBROUTINE CANOPY
!*** Declaration part ***!
USE data_out
USE data_species
USE data_simul
USE data_stand
IMPLICIT NONE
integer i
! If no Cohorts on the patch, initialize properly
IF( anz_coh == 0 ) THEN
lowest_layer=0
highest_layer=0
vStruct%cumLAI= 0.
vStruct%Irel = 0.
vStruct%sumBG = 0.
Irelpool = 0.
BGpool = 0.
LAI = 0.
! full light on the ground (layer = 0)
! Lightroutine 1,2
vStruct(highest_layer)%Irel=1
! Lightroutine 3,4
Irelpool(highest_layer)=1
! the whole patch is availabe for recruitment
BGpool(highest_layer+1)=1
BGpool(highest_layer+2)=1
all_leaves_on=0
! Calculation of leaf area, lowest and highest layer, etc.
! for all cohorts in all respective layers
CALL CALC_LA ! leaf area etc. always calculate
RETURN
END IF
! Calculation of leaf area, lowest and highest layer, etc.
! for all cohorts in all respective layers
CALL CALC_LA
IF(flag_end.EQ.3) RETURN
IF( flag_light == 1 )THEN
CALL LIGHT_1
ELSE IF ( flag_light == 2 ) THEN
CALL LIGHT_2
ELSE IF ( flag_light == 3 ) THEN
CALL LIGHT_3
ELSE IF ( flag_light == 4 ) THEN
CALL LIGHT_4
END IF
DO i=1,anrspec
ns = nrspec(i)
IF(svar(ns)%act_sum_lai > svar(ns)%sum_lai) svar(ns)%sum_lai = svar(ns)%act_sum_lai
ENDDO
! Determine relative light in the middle of each cohort canopy, the sla
! and the totFPAR per square meter patch and the total FPAR on the patch
CALL LIGHT_GROWTH
! print relevant light parameters for the canopy for each layer and cohort
if (time_out.gt.0 .and. out_flag_light.ne.0) CALL LIGHT_OUT_2
!------------------------------------------------
!------------------- SUBROUTINES ----------------
!------------------------------------------------
CONTAINS
SUBROUTINE CALC_LA
! Calculation of leaf area, lowest and highest layer, etc.
! for all cohorts in all respective layers
!*** Declaration part ***!
USE data_species
USE data_simul
USE data_stand
IMPLICIT NONE
! variables required for technical reasons
INTEGER :: nl, i
TYPE(Coh_Obj), Pointer :: p ! pointer to cohort list
! auxiliary variable
REAL :: x ! leaf area per crown unit [m**2/cm]
vStruct%LA = 0.
! structure of the canopy is determined once at the start of the year
! initialisation
IF(iday==1) THEN
lowest_layer=250
highest_layer=0
END IF
do i = 1, anrspec
svar(nrspec(i))%act_sum_lai = 0.
enddo
p => pt%first
DO WHILE (ASSOCIATED(p))
ns = p%coh%species
! cohort loop for determination of lowest and highest canopy layer of the tree crown
! structure of the canopy must only be determined once at the start of the year
IF(iday==1) THEN
! determine bottom of the crown in terms of number of layers
p%coh%botLayer = INT( p%coh%x_hbole / dz ) + 1
! determine top of the crown in terms of number of layers
IF (MODULO(p%coh%height,dz)==0.) THEN
p%coh%topLayer = INT( p%coh%height / dz )
ELSE
p%coh%topLayer = INT( p%coh%height / dz ) + 1
END IF
! remember the highest layer
IF(p%coh%topLayer > highest_layer .AND. p%coh%toplayer < 250) THEN
highest_layer=p%coh%topLayer
ELSE IF(p%coh%toplayer >= 250) THEN
if (.not.flag_mult8910) then
CALL stop_mess(time,'FATAL EXCEPTION RAISED IN CANOPY CALC_LA')
CALL error_mess(time,'maximal tree height of 125 m reached by cohort No.',REAL(p%coh%ident))
endif
flag_end=3
RETURN
END IF
!remember the lowest layer of the stand
IF(p%coh%botLayer < lowest_layer) THEN
lowest_layer=p%coh%botLayer
END IF
END IF
p%coh%leafarea = 0.
! total leaf area of a tree in this cohort [m**2]
IF((iday >= p%coh%day_bb) .AND. (iday <= spar(ns)%end_bb)) THEN
p%coh%t_leaf = p%coh%med_sla * p%coh%x_fol
! amount of leaf area per tree in layers
IF (p%coh%topLayer-p%coh%botLayer.GE.1) THEN
! now calculate leaf area per crown unit of this tree [m**2/cm]
x = p%coh%t_leaf / ( p%coh%height - p%coh%x_hbole )
p%coh%leafArea( p%coh%botLayer ) = ( dz - MODULO( p%coh%x_hbole, dz ) ) * x
IF (MODULO(p%coh%height,dz)==0.) THEN
p%coh%leafArea( p%coh%topLayer ) = dz * x
ELSE
p%coh%leafArea( p%coh%topLayer ) = MODULO( p%coh%height, dz ) * x
END IF
DO nl = p%coh%botLayer+1, p%coh%topLayer-1
p%coh%leafArea(nl) = x * dz
END DO
ELSE
p%coh%leafArea(p%coh%botLayer) = p%coh%t_leaf
END IF
! Update vertical patch leaf area profile of the canopy
DO nl = p%coh%botLayer, p%coh%topLayer
vStruct(nl)%LA = vStruct(nl)%LA + p%coh%leafArea(nl) * p%coh%nTreeA
END DO
ELSE
p%coh%leafArea=0.
ENDIF
IF(iday<=spar(ns)%end_bb) svar(ns)%act_sum_lai = svar(ns)%act_sum_lai + p%coh%ntreea*p%coh%t_leaf/kpatchsize
p => p%next
END DO
END SUBROUTINE CALC_LA
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
SUBROUTINE LIGHT_GROWTH
! Determine relative light in the middle of each cohort canopy, the sla,
! the total FPAR on the patch
!*** Declaration part ***!
USE data_species
USE data_simul
USE data_stand
IMPLICIT NONE
integer help
TYPE(Coh_Obj), Pointer :: p ! pointer to cohort list
totFPARsum=0 ! sum of all totFPAR's
totFPARcan=0 ! sum of all totFPAR's for the canopy
p => pt%first
DO WHILE (ASSOCIATED(p))
ns=p%coh%species
! the new average specific leaf area per cohort depends
! on the light regime in the middle of the canopy
! this is the SLA which is used for the leaf area distr. in the next year
! the new average specific leaf area per cohort depends on the
! mean light regime in the middle in the canopy
! IrelCan modifies the growthfunction
IF(all_leaves_on==1) THEN
select case (flag_light)
case (1,2)
p%coh%med_sla = spar(ns)%psla_min+spar(ns)%psla_a*&
(1-(vStruct(p%coh%toplayer)%Irel+vStruct(p%coh%botlayer)%Irel)/2.)
p%coh%IrelCan = vStruct(p%coh%toplayer)%Irel
case default
p%coh%med_sla = spar(ns)%psla_min+spar(ns)%psla_a*&
(1-(p%coh%Irel(p%coh%topLayer)+p%coh%Irel(p%coh%botLayer))/2.)
select case (ns)
case (10) ! Douglas fir
help = p%coh%botLayer+2*(p%coh%toplayer - p%coh%botLayer) / 3
p%coh%IrelCan = p%coh%Irel(help)
case default
help = vStruct(p%coh%toplayer)%SumBG
if (help .gt. 0.) then
p%coh%IrelCan = p%coh%Irel(p%coh%toplayer)*MIN(kpatchsize/help, 1.)
else
p%coh%IrelCan = p%coh%Irel(p%coh%toplayer)
endif
end select ! ns
end select ! flag_light
END IF
totFPARsum = totFPARsum + p%coh%totFPAR*p%coh%nTreeA
IF (p%coh%species .le. nspec_tree .or. p%coh%species.eq.nspec_tree+2) totFPARcan = totFPARcan + p%coh%totFPAR*p%coh%nTreeA
p => p%next
END DO
END SUBROUTINE LIGHT_GROWTH
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
SUBROUTINE COV_AREA
! calculate coverage-area as fraction of the patchsize per tree and layer
!*** Declaration part ***!
USE data_climate
USE data_par
USE data_stand
USE data_site
IMPLICIT NONE
! variables required for technical reasons
INTEGER :: i
! Variables to test restriction in light model 4
REAL :: y ! potential shadow cast of the cohort [m]
REAL :: w ! effective shadow cast of the cohort [m]
REAL :: l ! side length of a coort layer [m]
REAL :: reqarea ! area of the patch required for the shadow cast for all cohorts per layer
INTEGER :: layer_flag ! remember the highest layer where first LM4 restriction occurs
TYPE(Coh_Obj), Pointer :: p ! pointer to cohort list
y = dz/100/TAN(beta)
lm3layer=0
layer_flag=0
DO i = highest_layer, lowest_layer, -1
reqarea=0.
p => pt%first
DO WHILE (ASSOCIATED(p))
p%coh%BG(i) = 0.
! only those trees that have leaves
IF((iday >= p%coh%day_bb) .AND. (iday <= spar(p%coh%species)%end_bb) .AND. &
i <= p%coh%topLayer .AND. i >= p%coh%botLayer) THEN
IF (vStruct(i)%sumBG > kpatchsize) THEN
p%coh%BG(i)=p%coh%crown_area/vStruct(i)%sumBG
ELSE
p%coh%BG(i)=p%coh%crown_area/kpatchsize
END IF
l = SQRT(p%coh%BG(i)*kpatchsize)
reqarea = reqarea + l*y*p%coh%nTreeA
END IF
p => p%next
END DO ! cohorts
IF( kpatchsize > vStruct(i)%sumBG .AND. reqarea /= 0) THEN
w = y*(kpatchsize-vStruct(i)%sumBG)/reqarea
ELSE
w = 0
END IF
p => pt%first
DO WHILE (ASSOCIATED(p) .AND. layer_flag.EQ.0)
! only those trees that have leaves
IF((iday >= p%coh%day_bb) .AND. (iday <= spar(p%coh%species)%end_bb) .AND. &
i <= p%coh%topLayer .AND. i >= p%coh%botLayer) THEN
l = SQRT(p%coh%BG(i)*kpatchsize)
! layer from that on light model 3 is used instead of light model 4
! because of LM4 restrictions
IF( y-w > w+l ) THEN
layer_flag=1
lm3layer = i
EXIT ! do loop
END IF
END IF
p => p%next
END DO
END DO ! layers
END SUBROUTINE COV_AREA
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
SUBROUTINE LIGHT_1
!*** Declaration part ***!
USE data_species
USE data_simul
USE data_stand
IMPLICIT NONE
! variables required for technical reasons
INTEGER :: i, nl
TYPE(Coh_Obj), Pointer :: p ! pointer to cohort list
! auxiliary variables
REAL :: radSum ! sum of absorbed radiation (help variable)
REAL :: pfext=0.6 ! extinction coefficient. Only for one specie.
!*** Calculation part ***!
! Intialization radiation summator
radSum = 0.
vStruct%cumLAI = 0.
vStruct%Irel = 0.
! Calculate cumulative leaf area index and absorbed radiation per layer
! using Lambert-Beer
vStruct(highest_layer)%Irel=1
DO i = highest_layer, lowest_layer, -1
vStruct(i)%cumLAI = vStruct(i)%LA/kPatchsize + vStruct(i+1)%cumLAI
vStruct( i )%radFrac = 1. - Exp(-pfext * vStruct(i)%cumLAI) - radSum
radSum = radSum + vStruct(i)%radFrac
vStruct(i-1)%Irel=vStruct(i)%Irel-vStruct(i)%radFrac
END DO
! Light intensitiy unto the ground
DO i = lowest_layer - 2, 0, -1
vStruct(i)%Irel=vStruct(i+1)%Irel
END DO
! total LAI is simply the value of cumLAI at the forest floor
LAI = vStruct(lowest_layer)%cumLAI
IF(lai>laimax) laimax=lai
! Determine layer-specific & total fraction of PAR absorbed by this tree
p => pt%first
DO WHILE (ASSOCIATED(p))
p%coh%totFPAR = 0.
p%coh%FPAR = 0.
DO nl = p%coh%botLayer, p%coh%topLayer
p%coh%FPAR(nl) = p%coh%leafArea(nl) / vStruct(nl)%LA * vStruct(nl)%radFrac
p%coh%totFPAR = p%coh%totFPAR + p%coh%FPAR(nl)
END DO
p => p%next
END DO
IF(all_leaves_on==1) THEN
p => pt%first
DO WHILE (ASSOCIATED(p))
DO i = highest_layer, lowest_layer, -1
p%coh%antFPAR(i)=p%coh%FPAR(i)/p%coh%totFPAR
p%coh%sleafarea(i)=p%coh%leafarea(i)
END DO ! end layer loop
p => p%next
END DO ! cohort loop
ENDIF
END SUBROUTINE LIGHT_1
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
SUBROUTINE LIGHT_2
!*** Declaration part ***!
USE data_species
USE data_simul
USE data_stand
IMPLICIT NONE
! variables required for technical reasons
INTEGER :: i
real :: help
TYPE(Coh_Obj), Pointer :: p ! pointer to cohort list
!*** Calculation part ***!
vStruct%cumLAI = 0.
vStruct%Irel = 0.
! cohort loop
p => pt%first
DO WHILE (ASSOCIATED(p))
p%coh%FPAR = 0.
p%coh%totFPAR = 0.
p => p%next
END DO ! cohort loop
! Now calculate crown projection per tree and layer and
! the coverage sum over all layers
CALL CROWN_PROJ
! now calculate coverage-area as fraction of the patchsize per tree and layer
CALL COV_AREA
vStruct(highest_layer)%Irel=1
DO i = highest_layer, lowest_layer, -1
p => pt%first
help=0.
vStruct(i)%cumLAI = vStruct(i)%LA/kpatchsize + vStruct(i+1)%cumLAI
DO WHILE (ASSOCIATED(p))
ns=p%coh%species
IF (p%coh%BG(i).ne.0.) THEN
! faction of absorbed light rel. to the light at the top of this layer
! the reference area is the whole patch (weighted by BG(i))!
p%coh%FPAR(i)=(1-exp(-spar(ns)%pfext*p%coh%leafArea(i)/&
kpatchsize/p%coh%BG(i)))*p%coh%BG(i)
! sum up the total absorbed fraction of this cohort,
! the total fraction of absorbed light in this layer
! is the fraction absorbed* fraction of light*BG
! the reference area is the whole patch!
p%coh%totFPAR=p%coh%totFPAR+vStruct(i)%Irel*p%coh%FPAR(i)*&
(1+(0.5-vStruct(i)%Irel)*spar(ns)%fpar_mod/0.5)
! at first sum all the absorbed light fractions over the cohorts
help=help+p%coh%FPAR(i)*p%coh%nTreeA
ELSE
p%coh%FPAR(i)=0.
END IF
p => p%next
END DO
! then calculate the fraction of light which is available for the next layer
vStruct(i-1)%Irel=vStruct(i)%Irel*(1-help)
END DO
! Light intensitiy unto the ground
DO i = lowest_layer - 2, 0, -1
vStruct(i)%Irel=vStruct(i+1)%Irel
END DO
IF(all_leaves_on==1) THEN
p => pt%first
DO WHILE (ASSOCIATED(p))
DO i = highest_layer, lowest_layer, -1
p%coh%antFPAR(i)=vStruct(i)%Irel*p%coh%FPAR(i)*(1+(0.5-vStruct(i)%Irel)*spar(ns)%fpar_mod/0.5)/p%coh%totFPAR
p%coh%sleafarea(i)=p%coh%leafarea(i)
END DO ! end layer loop
p => p%next
END DO ! cohort loop
ENDIF
! total LAI is simply the value of cumLAI at the forest floor
LAI = vStruct(lowest_layer)%cumLAI
IF(lai>laimax) laimax=lai
END SUBROUTINE LIGHT_2
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
SUBROUTINE L_3_COH_LOOP(i,j)
!*** Declaration part ***!
USE data_species
USE data_simul
USE data_stand
IMPLICIT NONE
! variables required for technical reasons
TYPE(Coh_Obj), Pointer :: p ! pointer to cohort list
INTEGER :: i, j ! i= Schicht, j= Variante
REAL :: help
p => pt%first
! cohort loop in layer i
DO WHILE (ASSOCIATED(p))
ns=p%coh%species
IF((iday < p%coh%day_bb) .OR. (iday > spar(ns)%end_bb)) GOTO 1313
IF (i<=p%coh%toplayer.AND.i>=p%coh%botlayer) THEN
p%coh%FPAR(i)=1-exp(-spar(ns)%pfext*p%coh%leafArea(i)/&
kpatchsize/p%coh%BG(i))
! FPAR is related to the projection area and has to be modified
! by the same factor by that the projection area is being modified
! in case sumBG > patchsize
p%coh%FPAR(i)=p%coh%FPAR(i)*MIN(kpatchsize/vStruct(i)%sumBG,1.)
! test wether the cohort is new, was there before or will not be
! represented in the next layer
IF (i == p%coh%toplayer) THEN
p%coh%Irel(i)=Irelpool(i)
! totFPAR per patch! Since the projection area changes totFPAR has to
! be related to the patch in each layer
p%coh%totFPAR=p%coh%totFPAR+p%coh%Irel(i)*p%coh%FPAR(i)*p%coh%BG(i)
! light available for this cohort in the next layer
p%coh%Irel(i-1)=p%coh%Irel(i)*(1-p%coh%FPAR(i))
ELSE IF (i == p%coh%botlayer) THEN
IF( j == 2 ) THEN
help=p%coh%BG(i)-p%coh%BG(i+1)
p%coh%Irel(i)=(1/(p%coh%BG(i)))*&
(p%coh%Irel(i)*p%coh%BG(i+1)+Irelpool(i)*help)
END IF
! totFPAR per patch! Since the projection area changes totFPAR has to
! be related to the patch in each layer
p%coh%totFPAR=p%coh%totFPAR+p%coh%Irel(i)*p%coh%FPAR(i)*p%coh%BG(i)
! light available for this cohort in the next layer
p%coh%Irel(i-1)=p%coh%Irel(i)*(1-p%coh%FPAR(i))
! The light which leaves the cohort is fed into the pool
! the light intensitiy is weighted by the overall BG of this cohort
Irelpool(i-1)=(1/(p%coh%BG(i)*p%coh%nTreeA+BGpool(i)))*&
(p%coh%BG(i)*p%coh%nTreeA*p%coh%Irel(i-1)+BGpool(i)*Irelpool(i-1))
! BG of the pool available for the next layer increases
BGpool(i)=BGpool(i)+p%coh%BG(i)*p%coh%nTreeA
ELSE
IF( j == 2 ) THEN
help=p%coh%BG(i)-p%coh%BG(i+1)
p%coh%Irel(i)=(1/(p%coh%BG(i)))*&
(p%coh%Irel(i)*p%coh%BG(i+1)+Irelpool(i)*help)
END IF
! totFPAR per patch! Since the projection area changes totFPAR has to
! be related to the patch in each layer
p%coh%totFPAR=p%coh%totFPAR+p%coh%Irel(i)*p%coh%FPAR(i)*p%coh%BG(i)
! light available for this cohort in the next layer
p%coh%Irel(i-1)=p%coh%Irel(i)*(1-p%coh%FPAR(i))
END IF
END IF ! Layer test
1313 CONTINUE
p => p%next
END DO ! cohort loop
END SUBROUTINE L_3_COH_LOOP
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
SUBROUTINE LIGHT_3
!*** Declaration part ***!
USE data_species
USE data_simul
USE data_stand
IMPLICIT NONE
! variables required for technical reasons
INTEGER :: i
REAL :: help
TYPE(Coh_Obj), Pointer :: p ! pointer to cohort list
!*** Calculation part ***!
vStruct%cumLAI = 0.
Irelpool = 0.
BGpool = 0.
vStruct%Irel = 0. ! test variable for the light balance in layers
vStruct%radFrac = 0. ! test variable for the light balance in layers
! cohort loop
p => pt%first
DO WHILE (ASSOCIATED(p))
p%coh%FPAR = 0.
p%coh%totFPAR = 0.
p%coh%Irel = 0.
p => p%next
END DO ! cohort loop
! Now calculate crown projection per tree and layer and
! the coverage sum over all layers
CALL CROWN_PROJ
! now calculate coverage-area as fraction of the patchsize per tree and layer
CALL COV_AREA
! -----------------------------------------------------------
! now calculate per tree and layer the effective LAI
! this gives the absorbed light per tree and layer
! this gives the total fraction absorbes light per tree
! further each tree and each layer has an individual light regime. The area
! which is not covered by trees is treated as a pool
!
! reference area for the total fracation absorbed is the patch area
! above the canopy there is 100 % rel. light
Irelpool(highest_layer)=1.
! the size of the pool is defined as the fraction of the patch
! which can potentially be used by new cohorts in the next layer.
! Therefore is is the patch-fraction which is free anyway plus the
! fraction coverd by cohorts that will not be present in the next layer
! this means, the light intensity Irelpool(i) is available on the
! area BGpool(i+1)
BGpool(highest_layer+1)=1.
DO i = highest_layer, lowest_layer, -1
vStruct(i)%cumLAI = vStruct(i)%LA/kpatchsize + vStruct(i+1)%cumLAI
! two cases:
! first case: sumBG increases in this layer or remains the same
IF (vStruct(i+1)%sumBG<=vStruct(i)%sumBG) THEN
! three subcases:
! first subcase of 'sumBG increases': sumBG stays below patchsize
! ( no BG modification) or does not change
IF ((vStruct(i+1)%sumBG.LT.kpatchsize.AND.vStruct(i)%sumBG.LE.kpatchsize).OR.&
vStruct(i+1)%sumBG == vStruct(i)%sumBG) THEN
! At the beginning the light intensity of the pool remains the same
! but it will be updated when cohorts drop out
Irelpool(i-1)=Irelpool(i)
! until there are cohorts dropping out
BGpool(i)=MAX((kpatchsize-vStruct(i)%sumBG)/kpatchsize,0.)
CALL L_3_COH_LOOP(i,1)
! second and third subcase of 'sumBG increases or remains the same'
! the BG's of the cohorts change because sumBG exceeds patchsize.
! second subcase: sumBG was < patchsize before
! third subcase: sumBG was > patchsize before
ELSE
! BG and light intensitiy of the pool for the next(!) layer
! is 0 as long as there are no cohorts dropping out
Irelpool(i-1)=0.
BGpool(i)=0.
p => pt%first
! cohort loop 1
DO WHILE (ASSOCIATED(p))
! calculate the new fraction covered by the pool
! which is the old pool plus the fractions which are lost
! by the old cohorts due to new BG's
! this also changes the light intensity of the pool
! This pool will all be used by the new cohorts
! consider only cohorts that have been there before (i<toplayer)
IF (i<p%coh%toplayer.AND.i>=p%coh%botlayer .AND.&
iday >= p%coh%day_bb .AND. iday <= spar(p%coh%species)%end_bb) THEN
help=BGpool(i+1)+(p%coh%BG(i+1)-p%coh%BG(i))*p%coh%nTreeA
Irelpool(i)=(1/help)*(Irelpool(i)*BGpool(i+1)+p%coh%Irel(i)*&
(p%coh%BG(i+1)-p%coh%BG(i))*p%coh%nTreeA)
BGpool(i+1)=help
END IF ! layer test
p => p%next
END DO ! cohort loop1
CALL L_3_COH_LOOP(i,1)
END IF ! subcases of 'sumBG increases
! second case: sumBG decreases
ELSE
! two subcases
! first subcase of 'sumBG decrease': sumBG < patchsize before and after
! i.e. BG's do not change
! i.e. all projection area requirements can be fulfilled in the next layer
IF (vStruct(i+1)%sumBG.LT.kpatchsize) THEN
! At the beginning the light intensity of the pool remains the same
! but it will be updated when cohorts drop out
Irelpool(i-1)=Irelpool(i)
! until there are cohorts dropping out
BGpool(i)=(kpatchsize-vStruct(i)%sumBG)/kpatchsize
CALL L_3_COH_LOOP(i,1)
! second subcase of 'sumBG decrease': sumBG remains > patchsize or
! sumBG was > patchsize, i.e. BG's do change
ELSE
! BG of the pool for the next layer as long as there are
! no cohorts dropping out
BGpool(i)=MAX((kpatchsize-vStruct(i)%sumBG)/kpatchsize,0.)
Irelpool(i-1)=Irelpool(i)
CALL L_3_COH_LOOP(i,2)
END IF ! subcases
END IF ! three main cases
END DO ! end layer loop
! -----------------------------------------------------------
IF(all_leaves_on==1) THEN
p => pt%first
DO WHILE (ASSOCIATED(p))
DO i = highest_layer, lowest_layer, -1
p%coh%antFPAR(i)=p%coh%Irel(i)*p%coh%FPAR(i)*p%coh%BG(i)/p%coh%totFPAR
p%coh%sleafarea(i)=p%coh%leafarea(i)
END DO ! end layer loop
p => p%next
END DO ! cohort loop
ENDIF
! total LAI is simply the value of cumLAI at the lowest layer
LAI = vStruct(lowest_layer)%cumLAI
IF(lai>laimax) laimax=lai
! light intensitiy and free patch space unto the ground
DO i = lowest_layer - 2, 0, -1
Irelpool(i)=Irelpool(i+1)
BGpool(i+1)=BGpool(i+2)
END DO
END SUBROUTINE LIGHT_3
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
SUBROUTINE L_4_COH_LOOP(i,j,beta,y)
!*** Declaration part ***!
USE data_species
USE data_simul
USE data_stand
IMPLICIT NONE
! variables required for technical reasons
TYPE(Coh_Obj), Pointer :: p ! pointer to cohort list
INTEGER :: i, j ! i= layer, j= type
REAL :: y ! potential shadow cast of a cohort layer [m]
REAL :: l ! side length of a cohort layer [m]
REAL :: w ! effective shadow cast of a cohort layer [m]
REAL :: helplai ! LAI per layer and cohort
REAL :: help
REAL :: beta ! sun inclination
REAL :: dropoutpool ! relative area covered by cohort dropping out
REAL :: f1,f2,f3,f4,f5,f6,f7,f8 ! average fraction of absorbed radiation in different
! regions of the tree layer according to the 4C description paper
REAL :: k ! extintion coefficient
REAL :: reqarea ! area of the patch required for the shadow cast for all cohorts per layer
reqarea=0.
! cohort loop
p => pt%first
DO WHILE (ASSOCIATED(p))
IF (i<=p%coh%toplayer.AND.i>=p%coh%botlayer) THEN
l = SQRT(p%coh%BG(i)*kpatchsize)
reqarea = reqarea + l*y*p%coh%nTreeA
END IF
p => p%next
END DO ! cohort loop
! the size of the pool is defined as the fraction of
! the patch which is not covered by cohorts. This is the
! area covered by the sum of the 'shadows' of the cohorts,
! i.e. y's or rather w's + the area of cohorts dropping out in the next layer +
! the are that exeeds the maximal required area by the shadow-cast.
! This is updated in each layer
! w is the width of the shadow-cast of the cohorts that is maximal y.
! This maximal y also defines the maximal required area for all shadows
! 'reqarea' = required area
! When the maximal y cannot be satisfied, then this area is reduced by the
! relative share of the available space not covered by cohorts to the
! maximal required area for shadow cast
IF( kpatchsize > vStruct(i)%sumBG ) THEN
if (reqarea .gt. 1E-08) then
w = y*(kpatchsize-vStruct(i)%sumBG)/reqarea
else
w = y*kpatchsize
endif
ELSE
w = 0
END IF
BGpool(i)=0.
dropoutpool=0
p => pt%first
! cohort loop in layer i
DO WHILE (ASSOCIATED(p))
ns=p%coh%species
IF((iday < p%coh%day_bb) .OR. (iday > spar(ns)%end_bb)) GOTO 1313
k = spar(ns)%pfext
IF (i<=p%coh%toplayer.AND.i>=p%coh%botlayer) THEN
l = SQRT(p%coh%BG(i)*kpatchsize)
if( p%coh%BG(i).ne.0) then
helplai=p%coh%leafArea(i)/kpatchsize/p%coh%BG(i)
if (helplai .le. 0.) then
continue
endif
else
helplai = 0.
end if
IF (i == p%coh%toplayer) THEN
p%coh%Irel(i)=Irelpool(i)
ELSE IF( j == 2 .AND. i /= p%coh%toplayer ) THEN
help=p%coh%BG(i)-p%coh%BG(i+1)
p%coh%Irel(i)=(1/(p%coh%BG(i)))*&
(p%coh%Irel(i)*p%coh%BG(i+1)+Irelpool(i)*help)
END IF
! two main cases:
! first case : all light from the side comes from the pool
! second case : light from the side comes partially from the cohort itself
IF( w >= y ) THEN
! subcases : 1.: light from the side of the layer
! does only leave at the bottom of the layer
! 2: light from the side does also leave on the other side
! totFPAR per patch! Since the projection area changes totFPAR has to
! be related to the patch in each layer
IF( y <= l ) THEN
f1 = 1-exp(-k*helplai/SIN(beta))
if (helplai .lt. 1.E-6) then
f2 = 0.
else
f2 = 1-SIN(beta)/(k*helplai)*f1
if (f2 .lt. 0.) then
continue
f2 = 0.
endif
endif
p%coh%totFPAR=p%coh%totFPAR+(1/kpatchsize)*&
((l-y)*l*p%coh%Irel(i)*f1+& ! max. LAI
! exits layer at the side
y*l*f2*p%coh%Irel(i)+&
! from the side to the next layer
y*l*f2*Irelpool(i))
p%coh%FPAR(i)=p%coh%totFPAR
! average light leaving the bottom of the cohort
p%coh%Irel(i-1)=(1/l)*&
! max. LAI
((l-y)*p%coh%Irel(i)*(1-f1)+&
! from the side to the next layer
y*(1-f2)*Irelpool(i))
! Light in the pool.
IF(i /= p%coh%botlayer) THEN
Irelpool(i-1)=1/(BGpool(i)*kpatchsize+y*l*p%coh%nTreeA)*&
! amount present in the pool
(BGpool(i)*kpatchsize*Irelpool(i-1)+&
! exits layer at the side
y*l*p%coh%nTreeA*(1-f2)*p%coh%Irel(i))
BGpool(i)=BGpool(i)+y*l*p%coh%nTreeA/kpatchsize
ELSE
Irelpool(i-1)=1/(BGpool(i)*kpatchsize+(y+l)*l*p%coh%nTreeA)*&
! amount present in the pool
(BGpool(i)*kpatchsize*Irelpool(i-1)+&
! exits layer at the side
y*l*p%coh%nTreeA*(1-f2)*p%coh%Irel(i)+&
! from layer onto next layer
l*l*p%coh%nTreeA*p%coh%Irel(i-1))
! BG of the pool available for the next layer increases
BGpool(i)=BGpool(i)+p%coh%nTreeA*(y*l/kpatchsize+p%coh%BG(i))
dropoutpool=dropoutpool+p%coh%nTreeA*p%coh%BG(i)
END IF
! y > l
ELSE
f3 = 1-exp(-k*helplai*l/(SIN(beta)*y))
f4 = 1-SIN(beta)*y/(l*k*helplai)*f3
p%coh%totFPAR=p%coh%totFPAR+(1/kpatchsize)*&
((y-l)*l*f3*Irelpool(i)+& ! red. max. LAI
! exits layer at the side
l*l*f4*p%coh%Irel(i)+&
! from the side to next layer
l*l*f4*Irelpool(i))
p%coh%FPAR(i)=p%coh%totFPAR
! average light leaving the cohort
p%coh%Irel(i-1)=(1-f4)*Irelpool(i)
! Light in the pool. Even when the area of the pool is
! equal to zero, there is virtual light in the pool
! which is used as light coming from the side
! the area weighted mean over all y is calculated
IF(i /= p%coh%botlayer) THEN
Irelpool(i-1)=1/(BGpool(i)*kpatchsize+y*l*p%coh%nTreeA)*&
! amount present in pool
(BGpool(i)*kpatchsize*Irelpool(i-1)+&
! red. max. LAI
(y-l)*l*p%coh%nTreeA*(1-f3)*Irelpool(i)+&
! exits layer at side
l*l*p%coh%nTreeA*(1-f4)*p%coh%Irel(i))
BGpool(i)=BGpool(i)+y*l*p%coh%nTreeA/kpatchsize
ELSE
Irelpool(i-1)=1/(BGpool(i)*kpatchsize+(l+y)*l*p%coh%nTreeA)*&
! amount present in the pool
(BGpool(i)*kpatchsize*Irelpool(i-1)+&
! red. max. LAI
(y-l)*l*p%coh%nTreeA*(1-f3)*Irelpool(i)+&
! exits layer at side
l*l*p%coh%nTreeA*(1-f4)*p%coh%Irel(i)+&
! from layer to next layer
l*l*p%coh%nTreeA*p%coh%Irel(i-1))
! BG of the pool available for the next layer increases
BGpool(i)=BGpool(i)+p%coh%nTreeA*(y*l/kpatchsize+p%coh%BG(i))
dropoutpool=dropoutpool+p%coh%nTreeA*p%coh%BG(i)
END IF ! bottom layer or not
END IF ! light entering sideways also leaving sideways or not
! second main case : light from the side comes partially from the
! cohort itself
ELSE
! Exit, when average light from the side needs itself as input
! should not happen because this is taken care for in COV_AREA
IF( y-w > w+l ) THEN
if (.not.flag_mult8910) then
CALL stop_mess(time,'FATAL EXCEPTION RAISED IN CANOPY LIGHT ROUTINE 4')
CALL error_mess(time,'Light leaving the side of cohort needs itself as input. Cohort No.',REAL(p%coh%ident))
CALL error_mess(time,'Try decreasing layer height dz or increasing average sun inclination.',0.)
endif
STOP
END IF
! subcases : 1.: light from the side of the layer
! does only leave at the bottom of the layer
! 2: light from the side does also leave on the other side but light from the top
! still goes into the pool
! 3. light from the side does also leave on the other side and light from the top
! is all used as input again
! totFPAR per patch! because the projection area changes totFPAR has to
! be related to the patch in each layer
IF( y <= l ) THEN
IF( w /= 0 ) THEN
! max LAI
f1 = 1-exp(-k*helplai/SIN(beta))
! edge piece
f5 = 1+SIN(beta)*y/((y-w)*k*helplai)*(exp(-k*helplai*(y-w)/(SIN(beta)*y))-1)
! red. LAI
f6 = 1+SIN(beta)*y/(w*k*helplai)*(1-f1-exp(-k*helplai*(y-w)/(SIN(beta)*y)))
ELSE
! max LAI
f1 = 1-exp(-k*helplai/SIN(beta))
f5 = 1+SIN(beta)*y/((y-w)*k*helplai)*(exp(-k*helplai*(y-w)/(SIN(beta)*y))-1)
f6 = 0
END IF
p%coh%totFPAR=p%coh%totFPAR+(1/kpatchsize)*&
! enters from above into the pool
(w*l*f6*p%coh%Irel(i)+&
! from above on own side
(y-w)*l*f5*p%coh%Irel(i)+&
! max. LAI
(l-y)*l*f1*p%coh%Irel(i)+&
! from pool to next layer
w*l*f6*Irelpool(i)+&
! from the side to the next layer
(y-w)*l*(1-f5)*f5*p%coh%Irel(i))
p%coh%FPAR(i)=p%coh%totFPAR
! average light leaving the bottom of the cohort
p%coh%Irel(i-1)=(1/l)*&
! max. LAI
((l-y)*(1-f1)*p%coh%Irel(i)+&
! from pool to next layer
w*(1-f6)*Irelpool(i)+&
! from the sides to the next layer
(y-w)*(1-f5)*(1-f5)*p%coh%Irel(i))
! Light in the pool.
IF(i /= p%coh%botlayer .AND. w/=0) THEN
Irelpool(i-1)=1/(BGpool(i)*kpatchsize+w*l*p%coh%nTreeA)*&
! present in the pool
(BGpool(i)*kpatchsize*Irelpool(i-1)+&
! exits layer at the side
w*l*p%coh%nTreeA*(1-f6)*p%coh%Irel(i))
BGpool(i)=BGpool(i)+w*l*p%coh%nTreeA/kpatchsize
ELSE IF(i == p%coh%botlayer) THEN
Irelpool(i-1)=1/(BGpool(i)*kpatchsize+(w+l)*l*p%coh%nTreeA)*&
! present in pool
(BGpool(i)*kpatchsize*Irelpool(i-1)+&
! exits layer to the side
w*l*p%coh%nTreeA*(1-f6)*p%coh%Irel(i)+&
! from layer to next layer
l*l*p%coh%nTreeA*p%coh%Irel(i-1))
! BG of the pool available for the next layer increases
BGpool(i)=BGpool(i)+p%coh%nTreeA*(w*l/kpatchsize+p%coh%BG(i))
dropoutpool=dropoutpool+p%coh%nTreeA*p%coh%BG(i)
END IF
! light from the top still goes into the pool.
! The case w=0 is no longer permissible
ELSE IF(y > l .AND. w >= y-l) THEN
IF( w /= y-l ) THEN
f3 = 1-exp(-k*helplai*l/(SIN(beta)*y))
f5 = 1+SIN(beta)*y/((y-w)*k*helplai)*(exp(-k*helplai*(y-w)/(SIN(beta)*y))-1)
f7 = 1+SIN(beta)*y/((l-y+w)*k*helplai)*(exp(-k*helplai*l/(SIN(beta)*y))-&
exp(-k*helplai*(y-w)/(SIN(beta)*y)))
ELSE
f3 = 1-exp(-k*helplai*l/(SIN(beta)*y))
f5 = 1+SIN(beta)*y/((y-w)*k*helplai)*(exp(-k*helplai*(y-w)/(SIN(beta)*y))-1)
f7 = 0
END IF
p%coh%totFPAR=p%coh%totFPAR+(1/kpatchsize)*&
! enters pool from above
((l-y+w)*l*f7*p%coh%Irel(i)+&
! from above into own side
(y-w)*l*f5*p%coh%Irel(i)+&
! red. max. LAI
(y-l)*l*f3*Irelpool(i)+&
! from the side into the next layer
(l-y+w)*l*f7*Irelpool(i)+&
! from the side into the next layer
(y-w)*l*f5*(1-f5)*p%coh%Irel(i))
p%coh%FPAR(i)=p%coh%totFPAR
! average light leaving the cohort
p%coh%Irel(i-1)=(1/l)*((l-y+w)*((1-f7)*Irelpool(i)+&
(y-w)*(1-f5)*(1-f5)*p%coh%Irel(i)))
! Light in the pool.
IF(i /= p%coh%botlayer) THEN
Irelpool(i-1)=1/(BGpool(i)*kpatchsize+w*l*p%coh%nTreeA)*&
! present in the pool
(BGpool(i)*kpatchsize*Irelpool(i-1)+&
! exits from top to the side
(l-y+w)*l*p%coh%nTreeA*(1-f7)*p%coh%Irel(i)+&
! from the side into the pool
(y-l)*l*p%coh%nTreeA*(1-f3)*Irelpool(i))
BGpool(i)=BGpool(i)+w*l*p%coh%nTreeA/kpatchsize
ELSE IF (i == p%coh%botlayer) THEN
Irelpool(i-1)=1/(BGpool(i)*kpatchsize+(l+w)*l*p%coh%nTreeA)*&
! present in the pool
(BGpool(i)*kpatchsize*Irelpool(i-1)+&
! exits from the sides
(l-y+w)*l*p%coh%nTreeA*(1-f7)*p%coh%Irel(i)+&
! enters from the sied into the pool
(y-l)*l*p%coh%nTreeA*(1-f3)*Irelpool(i)+&
! from layer to next layer
l*l*p%coh%nTreeA*p%coh%Irel(i-1))
! BG of the pool available for the next layer increases
BGpool(i)=BGpool(i)+p%coh%nTreeA*(w*l/kpatchsize+p%coh%BG(i))
dropoutpool=dropoutpool+p%coh%nTreeA*p%coh%BG(i)
END IF ! bottom layer or not
! light from the top still goes into the pool
ELSE IF(y > l .AND. w < y-l) THEN
f3 = 1-exp(-k*helplai*l/(SIN(beta)*y))
f4 = 1-SIN(beta)*y/(l*k*helplai)*f3
f8 = 1/(y-w)*(l*f4+(y-w-l)*f3)
p%coh%totFPAR=p%coh%totFPAR+(1/kpatchsize)*&
! from above to own side
(l*l*f4*p%coh%Irel(i)+&
! from side to the own side and into the pool
y*l*f3*Irelpool(i)+&
! from the side to the next layer and into the pool
l*f8*(1-f8)*(l*p%coh%Irel(i)+(y-w-l)*Irelpool(i)))
p%coh%FPAR(i)=p%coh%totFPAR
! average light leaving the cohort
p%coh%Irel(i-1)=(1-f4)*(1-f8)*(l*p%coh%Irel(i)+(y-w-l)*Irelpool(i))
! Light in the pool.
IF(i /= p%coh%botlayer) THEN
Irelpool(i-1)=1/(BGpool(i)*kpatchsize+w*l*p%coh%nTreeA)*&
! present in the pool
(BGpool(i)*kpatchsize*Irelpool(i-1)+&
! from the side into the pool
(2*w-y+l)*l*p%coh%nTreeA*(1-f3)*Irelpool(i)+&
(y-w-l)*l*p%coh%nTreeA*(1-f3)*(1-f8)*&
(l*p%coh%Irel(i)+(y-w-l)*Irelpool(i)))
BGpool(i)=BGpool(i)+w*l*p%coh%nTreeA/kpatchsize
ELSE IF (i == p%coh%botlayer) THEN
Irelpool(i-1)=1/(BGpool(i)*kpatchsize+(l+w)*l*p%coh%nTreeA)*&
! present in the pool
(BGpool(i)*kpatchsize*Irelpool(i-1)+&
! from the side into the pool
(2*w-y+l)*l*p%coh%nTreeA*(1-f3)*Irelpool(i)+&
(y-w-l)*l*p%coh%nTreeA*(1-f3)*(1-f8)*&
(l*p%coh%Irel(i)+(y-w-l)*Irelpool(i))+&
! from layer to next layer
l*l*p%coh%nTreeA*(1-f4)*(1-f8)*&
(l*p%coh%Irel(i)+(y-w-l)*Irelpool(i)))
! BG of the pool available for the next layer increases
BGpool(i)=BGpool(i)+p%coh%nTreeA*(w*l/kpatchsize+p%coh%BG(i))
dropoutpool=dropoutpool+p%coh%nTreeA*p%coh%BG(i)
END IF ! bottom layer or not
END IF ! light entering sideways also leaving sideways or not
END IF ! two main cases
END IF
1313 CONTINUE
if (p%coh%FPAR(i) .lt. 0. .or. p%coh%totFPAR .lt. 0.) then
continue
p%coh%FPAR(i) = 0. ! intercept negative radiation
p%coh%totFPAR = 0.
endif
p => p%next
END DO ! cohort loop
! Treelayers are distributed on the patch such that their y's
! cover the free space as good as possible
IF( w > y ) THEN
Irelpool(i-1)=1/(kpatchsize*(1+dropoutpool)-vStruct(i)%sumBG)*&
(BGpool(i)*kpatchsize*Irelpool(i-1)+&
(kpatchsize-vStruct(i)%sumBG-(BGpool(i)-dropoutpool)*kpatchsize)*Irelpool(i))
BGpool(i)=(kpatchsize-vStruct(i)%sumBG)/kpatchsize + dropoutpool
END IF
END SUBROUTINE L_4_COH_LOOP
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
SUBROUTINE LIGHT_4
!*** Declaration part ***!
USE data_climate
USE data_par
USE data_species
USE data_stand
use data_site
IMPLICIT NONE
! variables required for technical reasons
INTEGER :: i
REAL :: help
REAL :: y ! potential shadow cast of the stand [m]
TYPE(Coh_Obj), Pointer :: p ! pointer to cohort list
!*** Calculation part ***!
vStruct%cumLAI = 0.
Irelpool = 0.
BGpool = 0.
vStruct%Irel = 0. ! test variable for the balance in layers
vStruct%radFrac = 0. ! test variable for the balance in layers
y = dz/100/TAN(beta)
! cohort loop
p => pt%first
DO WHILE (ASSOCIATED(p))
p%coh%FPAR = 0.
p%coh%totFPAR = 0.
p%coh%Irel = 0.
p => p%next
END DO ! cohort loop
if (time .eq. 8 .and. iday .eq. 134) then
continue
endif
! Now calculate crown projection per tree and layer and
! the coverage sum over all layers
CALL CROWN_PROJ
! now calculate coverage-area as fraction of the patchsize per tree and layer
CALL COV_AREA
! -----------------------------------------------------------
! now calculate per tree and layer the effective LAI
! this gives the absorbed light per tree and layer
! this gives the total fraction absorbes light per tree
! further each tree and each layer has an individual light regime. The area
! which is not covered by trees is treated as a pool
! whose light is available for all new cohorts.
! reference area for the total fraction absorbed is the patch area.
! GBpool is exactly defined in subroutine L_4_COH_LOOP
BGpool(highest_layer+1)=1.
! above the canopy there is 100 % rel. light
Irelpool(highest_layer)=1.
DO i = highest_layer, lowest_layer, -1
vStruct(i)%cumLAI = vStruct(i)%LA/kpatchsize + vStruct(i+1)%cumLAI
! two cases:
! first case: sumBG increases in this layer or remains the same
IF (vStruct(i+1)%sumBG<=vStruct(i)%sumBG) THEN
! three subcases:
! first subcase of 'sumBG increases': sumBG stays below patchsize
! ( no BG modification) or does not change
IF ((vStruct(i+1)%sumBG.LT.kpatchsize.AND.vStruct(i)%sumBG.LE.kpatchsize).OR.&
vStruct(i+1)%sumBG == vStruct(i)%sumBG) THEN
!until light model 4 restriction apply
IF ( i <= lm3layer ) THEN
! At the beginning the light intensity of the pool remains the same
! but it will be updated when cohorts drop out
Irelpool(i-1)=Irelpool(i)
! until there are cohorts dropping out
BGpool(i)=MAX((kpatchsize-vStruct(i)%sumBG)/kpatchsize,0.)
CALL L_3_COH_LOOP(i,1)
! FPAR in light model 3 defined differently has
! to be redefined here to cause no conflict in crown.f
p => pt%first
DO WHILE (ASSOCIATED(p))
p%coh%FPAR(i)=p%coh%totFPAR
p => p%next
END DO ! cohort loop1
ELSE
CALL L_4_COH_LOOP(i,1,beta,y)
END IF
! second and third subcase of 'sumBG increases or remains the same'
! the BG's of the cohorts change because sumBG exceeds patchsize.
! second subcase: sumBG was < patchsize before
! third subcase: sumBG was > patchsize before
ELSE
p => pt%first
! cohort loop 1
DO WHILE (ASSOCIATED(p))
! calculate the new fraction covered by the pool
! which is the old pool plus the fractions which are lost
! by the old cohorts due to new BG's
! this also changes the light intensity of the pool
! consider only cohorts that have been there before (i<toplayer)
! consider only cohorts that have leafed out already, otherwise
! it may happen that help=0
IF (i<p%coh%toplayer.AND.i>=p%coh%botlayer .AND.&
iday >= p%coh%day_bb .AND. iday <= spar(p%coh%species)%end_bb) THEN
help=BGpool(i+1)+(p%coh%BG(i+1)-p%coh%BG(i))*p%coh%nTreeA
if( help.ne.0) then
Irelpool(i)=(1/help)*(Irelpool(i)*BGpool(i+1)+p%coh%Irel(i)*&
(p%coh%BG(i+1)-p%coh%BG(i))*p%coh%nTreeA)
BGpool(i+1)=help
end if
END IF ! layer test
p => p%next
END DO ! cohort loop1
!until light model 4 restriction apply
IF ( i <= lm3layer ) THEN
CALL L_3_COH_LOOP(i,1)
! FPAR in light model 3 defined differently has
! to be redefined here to cause no conflict in crown.f
p => pt%first
DO WHILE (ASSOCIATED(p))
p%coh%FPAR(i)=p%coh%totFPAR
p => p%next
END DO ! cohort loop1
ELSE
CALL L_4_COH_LOOP(i,1,beta,y)
END IF
END IF ! subcases of 'sumBG increases
! second case: sumBG decreases
ELSE
! two subcases
! first subcase of 'sumBG decrease': sumBG < patchsize before and after
! i.e. BG's do not change
! i.e. all projection area requirements can be fulfilled in the next layer
IF (vStruct(i+1)%sumBG.LT.kpatchsize) THEN
!until light model 4 restriction apply
IF ( i <= lm3layer ) THEN
! At the beginning the light intensity of the pool remains the same
! but it will be updated when cohorts drop out
Irelpool(i-1)=Irelpool(i)
! until there are cohorts dropping out
BGpool(i)=(kpatchsize-vStruct(i)%sumBG)/kpatchsize
CALL L_3_COH_LOOP(i,1)
! FPAR in light model 3 defined differently has
! to be redefined here to cause no conflict in crown.f
p => pt%first
DO WHILE (ASSOCIATED(p))
p%coh%FPAR(i)=p%coh%totFPAR
p => p%next
END DO ! cohort loop1
ELSE
CALL L_4_COH_LOOP(i,1,beta,y)
END IF
! second subcase of 'sumBG decrease': sumBG remains > patchsize or
! sumBG was > patchsize, i.e. BG's do increase
ELSE
!until light model 4 restriction apply
IF ( i <= lm3layer ) THEN
! BG of the pool for the next layer as long as there are
! no cohorts dropping out
BGpool(i)=MAX((kpatchsize-vStruct(i)%sumBG)/kpatchsize,0.)
Irelpool(i-1)=Irelpool(i)
CALL L_3_COH_LOOP(i,2)
! FPAR in light model 3 defined differently has
! to be redefined here to cause no conflict in crown.f
p => pt%first
DO WHILE (ASSOCIATED(p))
p%coh%FPAR(i)=p%coh%totFPAR
p => p%next
END DO ! cohort loop1
ELSE
CALL L_4_COH_LOOP(i,2,beta,y)
END IF
END IF ! subcases
END IF ! three main cases
END DO ! end layer loop
! -----------------------------------------------------------
IF(all_leaves_on==1) THEN
p => pt%first
DO WHILE (ASSOCIATED(p))
p%coh%bes = 0.
DO i = highest_layer, lowest_layer, -1
if(p%coh%totFPAR.ne.0) p%coh%antFPAR(i)=(p%coh%FPAR(i)-p%coh%FPAR(i+1))/p%coh%totFPAR
p%coh%sleafarea(i)=p%coh%leafarea(i)
! besetting here weighted with relative leaf area in layer, could also be done with nimber of layers
IF((vstruct(i)%sumBG > kpatchsize) .and. (p%coh%t_leaf .gt. zero)) p%coh%bes = p%coh%bes + p%coh%leafarea(i)/p%coh%t_leaf*(vstruct(i)%sumBG/kpatchsize)
END DO ! end layer loop
p => p%next
END DO ! cohort loop
ENDIF
! total LAI is simply the value of cumLAI at the lowest canopy layer
LAI = vStruct(lowest_layer)%cumLAI
IF(lai>laimax) laimax=lai
! light intensitiy and free patch space unto the ground
DO i = lowest_layer - 2, 0, -1
Irelpool(i)=Irelpool(i+1)
BGpool(i+1)=BGpool(i+2)
END DO
END SUBROUTINE LIGHT_4
END SUBROUTINE CANOPY
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! writes essential light paramerter into light.res1
! seperated to cohorts and layers
SUBROUTINE LIGHT_OUT_2
use data_simul
USE data_out
USE data_stand
USE data_species
INTEGER:: i=0,j=0
TYPE(Coh_Obj), Pointer :: p ! pointer to cohort list
! Header
write(unit_light,'(2A5,5A9)') 'YEAR ','layer ',' Coh1 ', &
' Coh2 ',' Coh3 ',' Coh4 ','...'
p => pt%first
WRITE(unit_light,'(i3,A)',ADVANCE='NO') time,' '
! the crown cover area for cohorts
DO WHILE (ASSOCIATED(p))
WRITE(unit_light,'(F8.2)',ADVANCE='NO') p%coh%crown_area
p => p%next
END DO
WRITE(unit_light,'(A)') ' '
WRITE(unit_light,'(A)') '-----------------------------------------------------------------------'
SELECT CASE (flag_light)
CASE(3,4)
DO i = highest_layer, lowest_layer, -1
IF(i.EQ.lm3layer) WRITE(unit_light,'(A)',ADVANCE='NO') 'ab hier LM3!'
WRITE(unit_light,'(A,i3)',ADVANCE='NO') 'IREL ',i
! relativ light intensity that hits layers and cohorts
p => pt%first
DO j=1, anz_coh
IF (p%coh%Irel(i) == 0.) THEN
WRITE(unit_light,'(F8.2)',ADVANCE='NO') -99.99
ELSE
WRITE(unit_light,'(F8.4)',ADVANCE='NO') p%coh%Irel(i)
END IF
p => p%next
END DO
WRITE(unit_light,'(A)') ' '
WRITE(unit_light,'(A,A7)',ADVANCE='NO') 'BG',' '
! cover degree per cohort and layer
p => pt%first
DO j=1, anz_coh
IF (p%coh%BG(i) == 0.) THEN
WRITE(unit_light,'(F8.2)',ADVANCE='NO') -99.99
ELSE
WRITE(unit_light,'(F8.4)',ADVANCE='NO') p%coh%BG(i)
END IF
p => p%next
END DO
WRITE(unit_light,'(A)') ' '
WRITE(unit_light,'(A,A5)',ADVANCE='NO') 'FPAR',' '
! the fraction absorbed by corhort and layer
p => pt%first
DO j=1, anz_coh
IF (p%coh%FPAR(i) == 0.) THEN
WRITE(unit_light,'(F8.2)',ADVANCE='NO') -99.99
ELSE
WRITE(unit_light,'(F8.4)',ADVANCE='NO') p%coh%FPAR(i)
END IF
p => p%next
END DO
WRITE(unit_light,'(A)') ' '
WRITE(unit_light,'(A,F8.4)') 'BGpool in dieser schicht :', BGpool(i)
WRITE(unit_light,'(A,F8.4)') 'relative Ueberdeckung in dieser Schicht :', vStruct(i)%sumBG/kpatchsize
WRITE(unit_light,'(A,F8.4)') 'Summer der Ueberdeckungen :', BGpool(i)+vStruct(i)%sumBG/kpatchsize
WRITE(unit_light,'(A)') ' '
WRITE(unit_light,'(A,F8.4)') 'Rel. Licht unter dieser schicht :', VStruct(i)%Irel
WRITE(unit_light,'(A,F8.4)') 'totFparsum bis zu dieser schicht :', VStruct(i)%radFrac
WRITE(unit_light,'(A,F8.4)') ' Lichtbilanz : ', vStruct(i)%Irel+VStruct(i)%radFrac
WRITE(unit_light,'(A)') ' '
WRITE(unit_light,'(A)') '-----------------------------------------------------------------------'
END DO ! layers loop
CASE(2)
DO i = highest_layer, lowest_layer, -1
WRITE(unit_light,'(A,i3)',ADVANCE='NO') 'Irel ',i
! relative light intensity that hits the layer and cohorts
DO j=1, anz_coh
WRITE(unit_light,'(F8.4)',ADVANCE='NO') vStruct(i)%Irel
END DO
WRITE(unit_light,'(A)') ' '
! cover degree per cohort and layers
p => pt%first
WRITE(unit_light,'(A,A7)',ADVANCE='NO') 'BG',' '
DO j=1, anz_coh
IF (p%coh%BG(i) == 0.) THEN
WRITE(unit_light,'(F8.2)',ADVANCE='NO') -99.99
ELSE
WRITE(unit_light,'(F8.4)',ADVANCE='NO') p%coh%BG(i)
END IF
p => p%next
END DO
WRITE(unit_light,'(A)') ' '
WRITE(unit_light,'(A,A5)',ADVANCE='NO') 'FPAR',' '
! fraction absorbed by cohort and layer
p => pt%first
DO j=1, anz_coh
IF (p%coh%FPAR(i) == 0.) THEN
WRITE(unit_light,'(F8.2)',ADVANCE='NO') -99.99
ELSE
WRITE(unit_light,'(F8.4)',ADVANCE='NO') p%coh%FPAR(i)
END IF
p => p%next
END DO
WRITE(unit_light,'(A)') ' '
WRITE(unit_light,'(A)') '-----------------------------------------------------------------------'
END DO
CASE(1)
DO i = highest_layer, lowest_layer, -1
WRITE(unit_light,'(A,i3)',ADVANCE='NO') 'IREL ',i
! relative light inensity that hits layers and cohorts
DO j=1, anz_coh
WRITE(unit_light,'(F8.4)',ADVANCE='NO') vStruct(i)%Irel
END DO
WRITE(unit_light,'(A)') ' '
WRITE(unit_light,'(A,A5)',ADVANCE='NO') 'FPAR',' '
! fraction absirbed by cohort and layer
p => pt%first
DO j=1, anz_coh
IF (p%coh%FPAR(i) == 0.) THEN
WRITE(unit_light,'(F8.2)',ADVANCE='NO') -99.99
ELSE
WRITE(unit_light,'(F8.4)',ADVANCE='NO') p%coh%FPAR(i)
END IF
p => p%next
END DO
WRITE(unit_light,'(A)') ' '
WRITE(unit_light,'(A)') '-----------------------------------------------------------------------'
END DO
END SELECT
WRITE(unit_light,'(A,A2)',ADVANCE='NO') 'totFPAR',' '
p => pt%first
DO j=1, anz_coh
WRITE(unit_light,'(F8.5)',ADVANCE='NO') p%coh%totFPAR
p => p%next
END DO
WRITE(unit_light,'(A)') ' '
WRITE(unit_light,'(A,F8.4)') 'Summe totFPAR : ',totFPARsum
SELECT CASE(flag_light)
CASE(3,4)
WRITE(unit_light,'(A,F8.4)') 'Irel(lowest-1) : ', Irelpool(lowest_layer-1)
WRITE(unit_light,'(A,F8.4)') ' Lichtbilanz : ', Irelpool(lowest_layer-1)+totFPARsum
CASE(1,2)
WRITE(unit_light,'(A,F8.4)') 'Irel(lowest-1) : ', vStruct(lowest_layer-1)%Irel
WRITE(unit_light,'(A,F8.4)') ' Lichtbilanz : ', vStruct(lowest_layer-1)%Irel+totFPARsum
END SELECT
WRITE(unit_light,'(A)') ' '
WRITE(unit_light,'(A)') ' '
WRITE(unit_light,'(A)') ' '
WRITE(unit_light,'(A)') ' '
WRITE(unit_light,'(A)') '------------------------------------------------------------------------------------'
WRITE(unit_light,'(A)') ' '
WRITE(unit_light,'(A)') ' '
END SUBROUTINE LIGHT_OUT_2
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
SUBROUTINE CROWN_PROJ
! Now calculate crown projection per tree and layer and
! the coverage sum over all layers
!*** Declaration part ***!
USE data_par
USE data_species
USE data_simul
USE data_stand
IMPLICIT NONE
! variables required for technical reasons
INTEGER :: i
real :: help, help1
TYPE(Coh_Obj), Pointer :: p ! pointer to cohort list
vStruct%sumBG=0.
p => pt%first
DO WHILE (ASSOCIATED(p))
ns=p%coh%species
! SMALL TREES OR GROUND VEGETATION
IF (p%coh%height.lt.thr_height .or. ns .eq. nspec_tree+1) THEN
p%coh%crown_area = p%coh%t_leaf ! small trees or ground vegetation
ELSEIF (p%coh%species.eq.nspec_tree+2) then ! Case mistletoe
p%coh%crown_area=pi*(real(p%coh%nTreeA)*0.000475)**(0.6666) ! 1 big ball: volume = sum of mistletoe standard balls (10 years, pfiz 2000)
! V=4/3*Pi*r^3 , r= (3*V/4*PI)^1/3, (set V=n*4/3*Pi*512, with r=0.08 standard ball), r=(n*5.12*10-4)^1/3,A=pi*(n*5.12*10-4)^2/3
ELSE
! Formel nach Biber 1996 S. 121, Kronenradius [dm]= a*DBH [cm]+b
help1 = MIN(spar(ns)%crown_c,spar(ns)%crown_a*(p%coh%diam)+spar(ns)%crown_b)
help=PI*(help1)**2
! adaptation of seedling crown projected area
IF(p%coh%ca_ini.GT.help) THEN
p%coh%crown_area=p%coh%ca_ini
ELSE IF (p%coh%ca_ini.LT.help.AND.p%coh%diam == 0) THEN
if(p%coh%height_ini.eq.137. .or. p%coh%height.eq.p%coh%height_ini) then
p%coh%crown_area=p%coh%ca_ini
else
p%coh%crown_area=(p%coh%height-p%coh%height_ini)/(137.-p%coh%height_ini)*&
(PI*(spar(ns)%crown_b)**2-p%coh%ca_ini)+p%coh%ca_ini
end if
ELSE
p%coh%crown_area=help
END IF
END IF
if(p%coh%crown_area.lt.0) then
p%coh%crown_area = p%coh%ca_ini
end if
DO i=p%coh%topLayer,p%coh%botLayer,-1
vStruct(i)%sumBG=vStruct(i)%sumBG+p%coh%crown_area*p%coh%nTreeA
END DO
p => p%next
END DO
END SUBROUTINE CROWN_PROJ
source_code/version_2.3_windows/crown.f 0 → 100644
View file @ 82df1085
!*****************************************************************!
!* *!
!* FORESEE Simulation Model *!
!* *!
!* *!
!* Subroutine for: *!
!* Calculation of rise of bole height *!
!* *!
!* Copyright (C) 1996-2018 *!
!* Potsdam Institute for Climate Impact Reserach (PIK) *!
!* Authors and contributors see AUTHOR file *!
!* This file is part of 4C and is licensed under BSD-2-Clause *!
!* See LICENSE file or under: *!
!* http://www.https://opensource.org/licenses/BSD-2-Clause *!
!* Contact: *!
!* https://gitlab.pik-potsdam.de/foresee/4C *!
!* *!
!*****************************************************************!
SUBROUTINE CROWN (p)
!*** Declaration part ***!
USE data_stand
USE data_species
USE data_simul
IMPLICIT NONE
REAL :: relnpp, & ! layer specific amount of npp per cohort
reldm ! layer specific dry matter to be replaced
INTEGER :: nl ! variable for crown layers
INTEGER :: i
TYPE(Coh_Obj) :: p ! pointer to cohort list
!*** Calculation part ***!
! evaluate assimilation balance vs. foliage turnover rate for the crown layers
ns = p%coh%species
DO i = p%coh%topLayer, p%coh%botLayer, -1
nl = i
relnpp = p%coh%antFPAR(i) * p%coh%netAss
reldm = 1.5*spar(ns)%psf * p%coh%sleafArea(i) / p%coh%med_sla
IF ( relnpp < reldm) THEN
nl = nl + 1
EXIT
ENDIF
END DO
p%coh%deltaB = (nl - p%coh%botLayer) * dz
IF(p%coh%deltaB.GT.0.05*(p%coh%height-p%coh%x_hbole)) p%coh%deltaB=0.05*(p%coh%height-p%coh%x_hbole)
END SUBROUTINE CROWN
source_code/version_2.3_windows/daily.f 0 → 100644
View file @ 82df1085
!*****************************************************************!
!* *!
!* 4C Simulation Model *!
!* *!
!* *!
!* Subroutines for: *!
!* Simulation of processes at subannual resolution *!
!* *!
!* *!
!* Contains subroutines: *!
!* *!
!* STAND_DAILY *!
!* SET_PS *!
!* DROUGHT : Calculation of drought stress indices *!
!* FIRE_RISK *!
!* calc_frost_index : calculation of indices for frost damage *!
!* calc_endbb : calculation of end of the vegetation period *!
!* *!
!* Copyright (C) 1996-2018 *!
!* Potsdam Institute for Climate Impact Reserach (PIK) *!
!* Authors and contributors see AUTHOR file *!
!* This file is part of 4C and is licensed under BSD-2-Clause *!
!* See LICENSE file or under: *!
!* http://www.https://opensource.org/licenses/BSD-2-Clause *!
!* Contact: *!
!* https://gitlab.pik-potsdam.de/foresee/4C *!
!* *!
!*****************************************************************!
SUBROUTINE stand_daily
!*** Declaration part ***!
USE data_stand
USE data_simul
USE data_species
USE data_climate
USE data_site
USE data_soil_cn
USE data_out
USE data_par
USE data_evapo
USE data_soil
use data_manag
IMPLICIT NONE
REAL :: aveT, & ! average of temperature for PS/NPP models
avDL, & ! average of daylength for PS/NPP model
avRD, & ! average of radiation
avPR, & ! average of pressure (hPa)
PAR ! average of PAR for PS/NPP model [mol quanta d-1]
REAL :: hdfr, hdt, hprs
INTEGER :: i, jd, k, d, week, monthday, ns_pro_help
real :: p_help, t_help
REAL :: photoper
p_help=0.
t_help=0.
irelpool_ll=0.
bgpool_ll=0.
!*** Calculation part ***!
week = 0
monthday = 0
monat = 1
woche = 1
! daily loop
DO jd = 1, recs(time)
iday = jd
monthday=monthday+1
! input of daily climate data
CALL day_ini
if(anz_coh .gt. 0) then ! if no cohort, then no phaenology necessary
IF(all_leaves_on==0) CALL pheno_begin
CALL pheno_count
IF(leaves_on) CALL pheno_shed
endif
IF(phen_flag==1 .OR. (.not.flag_tree .and. leaves_on)) THEN
! Calculate this year's crown geometry for each cohort, followed by
! leaf area and light profiles across the canopy
CALL CANOPY
if (anz_coh.eq.0) then
irelpool_ll = 1.
end if
if(all_leaves_on.eq.1) then
irelpool_ll = irelpool(0)
bgpool_ll = bgpool(2)
end if
IF(flag_end.EQ.3) RETURN
! update of stand variables (LAI, cover)
CALL standup
phen_flag=0;
END IF
!call distubance after start day
select case(flag_dis)
case(1,2)
if (dis_control(1,1) .eq. 1) then
if(all_leaves_on .eq. 1 .and. dis_start(dis_control(1,2)) .eq. iday) then
CALL disturbance_defoliator
CALL CANOPY
CALL stand_balance
CALL standup
endif
endif
if (dis_control(2,1) .eq. 1) then
if(all_leaves_on .eq. 1 .and. dis_start(dis_control(2,2)) .eq. iday) CALL disturbance_xylem
endif
if (dis_control(3,1) .eq. 1) then
if(dis_start(dis_control(3,2)) .eq. iday) CALL disturbance_phloem
endif
if (dis_control(4,1) .eq. 1) then
if(dis_start(dis_control(4,2)) .eq. iday) then
CALL disturbance_root
CALL stand_balance
CALL standup
endif
endif
if (dis_control(5,1) .eq. 1) then
if(dis_start(dis_control(5,2)) .eq. iday) CALL disturbance_stem
endif
end select
ns_pro_help = ns_pro
! set ns_pro_help to length of last photosynthesis period at end of year
IF(iday >int(recs(time)/ns_pro)*ns_pro .and. (MOD( iday, ns_pro )==1)) THEN
ns_pro_help = recs(time) - int(recs(time)/ns_pro)*ns_pro
END IF
! optimum photosynthesis submodel
IF (ns_pro==1.OR.(MOD( iday, ns_pro )==1) .or. iday.eq.1) THEN
! assign averaged input variables for PS model
aveT = 0.
avDL = 0.
avRD = 0.
avPR = 0.
hdfr = 0.
ns_day = 1
DO k = 1, ns_pro_help ! this calculates 365 or 366, but is not included as a wwek value
! ==> last week of the year is recieving this amount
d = iday-1+k
hdt = Q10_T**((tp(d,time) - 15.) / 10.)
hdfr = hdfr + hdt
dayfract(k) = hdt
aveT = aveT + tp(d,time) + deltaT
avRD = avRD + rd(d,time)
hprs = prs(d,time)
if (hprs .lt. 800.) then
hprs = 1013
endif
avPR = avPR + hprs
avDL = avDL + photoper( FLOAT(d), xLat )
END DO
aveT = aveT / ns_pro_help
avDL = avDL / ns_pro_help
avRD = avRD / ns_pro_help
avPR = avPR / ns_pro_help
! PAR that is coming in stand reflection is substracted
PAR = (1.-pfref)* GR_in_PAR * avRD
if (iday .gt. 364) then
dayfract = 1. ! at the last days of the year no temperature depending daily fraction of flux
else
dayfract = ns_pro * dayfract / hdfr ! temperature depending daily fraction of flux, calc. from sum of ns_pro days
endif
CALL OPT_PS( aveT, avDL, PAR, avPR )
ENDIF
! aggregation of stomatal conductance of the canopy
gp_can_mean = gp_can_mean + gp_can
gp_can_min = min(gp_can_min, gp_can)
gp_can_max = max(gp_can_max, gp_can)
! soil submodel
CALL SOIL
CALL drought
! NPP submodel
IF (ns_pro==1.OR.(MOD( (iday-1), ns_pro )==0) .or. iday .eq. recs(time) .or. iday.eq.1) THEN
CALL NPP( aveT, avDL, PAR, ns_pro_help )
IF(.not.flag_tree .and. leaves_on.and.flag_sprout.eq.1) CALL growth_seed_week (ns_pro_help)
! daily output every ns_pro days of dips- and gsdps-files
IF (flag_dayout .ge. 1) CALL coh_out_d(2)
ENDIF
CALL calc_fire_risk
! calculation of the start of vegetation period
if(flag_vegper.eq.0) then
if(airtemp.le.5. .and. flag_tveg .ne.0) then
flag_tveg=0
else if(airtemp.gt.5. .and. flag_tveg.eq.0) then
flag_tveg =1
else if(airtemp.gt.5. .and. flag_tveg.eq.1) then
flag_tveg =2
else if(airtemp.gt.5. .and. flag_tveg.eq.2) then
flag_tveg =3
else if(airtemp.gt.5. .and. flag_tveg.eq.3)then
flag_tveg =4
else if(airtemp.gt.5. .and. flag_tveg.eq.4) then
flag_tveg =5
end if
if(flag_tveg .eq.5) then
flag_vegper=1
iday_vegper = iday
end if
endif
! call of SR for calculation of various indices for the frost index
if(airtemp_min .gt. -90.) call calc_frost_index
! Calculation of maximal radiation (for information only)
call glob_rad(dlength, iday, lat, rad_max)
Cout%NEE(iday) = respsoil - dailyNPP_C ! g C/m²
Cout%Resp_aut(iday) = dailyautresp_C * dayfract(ns_day)
NPP_day = dailyNPP_C * dayfract(ns_day)
GPP_day = (dailyNPP_C + dailyautresp_C) * dayfract(ns_day)
TER_day = dailyautresp_C * dayfract(ns_day) + respsoil
IF (flag_dayout .ge. 1) CALL outday(1)
IF (ns_pro==1.OR.(MOD( iday, ns_pro )==0) .or. iday .eq. recs(time) ) CALL SET_PS
! Wochen- und Monatswerte berechnen
aet_mon(monat) = aet_mon(monat) + aet
aet_week(woche) = aet_week(woche) + aet
pet_mon(monat) = pet_mon(monat) + pet
pet_week(woche) = pet_week(woche) + pet
temp_mon(monat) = temp_mon(monat) + airtemp
temp_week(woche) = temp_week(woche) + airtemp
prec_mon(monat) = prec_mon(monat) + prec
prec_week(woche) = prec_week(woche) + prec
rad_mon(monat) = rad_mon(monat) + rad
hum_mon(monat) = hum_mon(monat) + hum
perc_mon(monat) = perc_mon(monat) + perc(nlay)
perc_week(woche) = perc_week(woche) + perc(nlay)
resps_mon(monat) = resps_mon(monat) + respsoil
resps_week(woche)= resps_week(woche) + respsoil
GPP_mon(monat) = GPP_mon(monat) + dailyNPP_C + dailyautresp_C
GPP_week(woche) = GPP_week(woche) + dailyNPP_C + dailyautresp_C
NEE_mon(monat) = NEE_mon(monat) + Cout%NEE(iday) ! g C/m²
NPP_mon(monat) = NPP_mon(monat) + dailyNPP_C
NPP_week(woche) = NPP_week(woche) + dailyNPP_C
TER_mon(monat) = TER_mon(monat) + dailyautresp_C + respsoil
TER_week(woche) = TER_week(woche) + dailyautresp_C + respsoil
tempmean_mo(monat) = tempmean_mo(monat) + airtemp ! long-term monthly means
! summation output with variabel time steps
photsum = photsum + phot_C
npppotsum = npppotsum + dailypotNPP_C
nppsum = nppsum + dailyNPP_C
resosum = resosum + respsoil
nee = nee + respsoil - dailyNPP_C
gppsum = gppsum + GPP_day
sumGPP = sumGPP + dailyNPP_C + dailyautresp_C
sumTER = sumTER + dailyautresp_C + respsoil
resautsum = resautsum + dailyautresp_C
precsum = precsum + prec
tempmean = tempmean + airtemp
tempmeanh = tempmeanh +airtemp
aet_sum = aet_sum + aet
pet_sum = pet_sum + pet
perc_sum = perc_sum + perc(nlay)
if(monthday==monrec(monat)) then
tempmeanh = tempmeanh/monrec(monat)
if(monat.eq.1) med_air_cm = tempmeanh
if(tempmeanh.lt.med_air_cm) med_air_cm = tempmeanh
if(tempmeanh.gt.med_air_wm) med_air_wm = tempmeanh
tempmeanh = 0.
temp_mon(monat) = temp_mon(monat) / monrec(monat)
rad_mon(monat) = rad_mon(monat) / monrec(monat)
hum_mon(monat) = hum_mon(monat) / monrec(monat)
if(temp_mon(monat).lt.med_air_cm) med_air_cm = temp_mon(monat)
if(temp_mon(monat).gt.med_air_wm) med_air_wm = temp_mon(monat)
end if
if(airtemp.ge.10.) then
t_help= t_help + airtemp
p_help= p_help + prec
end if
ns_day = ns_day + 1
! daily output
IF(flag_sum .eq. 1) THEN
write(unit_sum,'(2I5,13F10.3)') iday,time_cur,photsum,npppotsum,nppsum,resosum, &
lightsum,nee,abslightsum,precsum,tp(iday,time), &
exp(0.069*(tp(iday,time)-15.)), sumGPP, sumTER, resautsum
photsum=0.;npppotsum=0.;nppsum=0.;resosum=0.;lightsum=0.;nee=0.;abslightsum=0.; precsum=0.
sumGPP = 0.
sumTER = 0.
resautsum = 0.
ENDIF
! output with time step of photosynthesis
IF(flag_sum .eq. 2 .and. mod(iday,ns_pro)==0) THEN
week = week + 1
write(unit_sum,'(2I6,17F10.3)') week,time_cur,time_cur+(week-0.5)/52.,photsum,npppotsum,nppsum,resosum, &
lightsum,nee,abslightsum,precsum,aveT,exp(0.069*(aveT-15.)), &
aet_sum, pet_sum, perc_sum, sumGPP, sumTER, resautsum
photsum=0.;npppotsum=0.;nppsum=0.;resosum=0.;lightsum=0.;nee=0.;abslightsum=0.; precsum=0.
aet_sum = 0.; pet_sum = 0.
perc_sum = 0.
sumGPP = 0.
sumTER = 0.
resautsum = 0.
ENDIF
if(mod(iday,7) .eq. 0) then
woche = woche + 1
endif
if(monthday .eq. monrec(monat)) then
IF(flag_sum .eq. 3 ) THEN
tempmean = tempmean/monrec(monat)
if( temp_mon(monat) .le. 0.) then
ind_cout_mo = 12.* prec_mon(monat)
ind_cout_mo = 12*precsum
else
ind_cout_mo = 12.* prec_mon(monat) /(temp_mon(monat) + 10.)
ind_cout_mo = 12*precsum/(tempmean+10)
end if
if(temp_mon(monat) .le. 0.) then
ind_wiss_mo = 12.* prec_mon(monat)
ind_wiss_mo = 12*precsum
else
ind_wiss_mo = 12.* prec_mon(monat) /(temp_mon(monat) + 7.)
ind_wiss_mo = 12*precsum/(tempmean+7)
end if
if(ind_arid_mo.ne.0.) then
ind_arid_mo = prec_mon(monat)/pet_sum
else
ind_arid_mo=0.
end if
cwb_mo = prec_mon(monat) - pet_sum
ind_cout_an = ind_cout_an + ind_cout_mo
ind_wiss_an = ind_wiss_an + ind_wiss_mo
write(unit_sum,'(I7,I5,20F10.3)') monat,time_cur,time_cur+(monat-0.5)/12.,photsum,npppotsum,nppsum,resosum, &
lightsum,nee,abslightsum, precsum, tempmean, aet_sum, pet_sum, ind_cout_mo, ind_wiss_mo, &
ind_arid_mo, cwb_mo, perc_sum, sumGPP, sumTER, resautsum
photsum=0.;npppotsum=0.;nppsum=0.;resosum=0.;lightsum=0.;nee=0.;abslightsum=0.; precsum=0.; tempmean = 0.
aet_sum = 0.; pet_sum = 0.; ind_cout_mo = 0.; ind_wiss_mo=0.; ind_arid_mo=0.; cwb_mo = 0.
perc_sum = 0.
sumGPP = 0.
sumTER = 0.
resautsum = 0.
ENDIF ! flag_sum
monat = monat+1
monthday = 0
endif ! monthday
END DO ! iday daily loop
!calculate the mean stress factor for root growth
if (flag_wurz .eq. 4 .or. flag_wurz .eq. 6) then
do i=1,nlay
do k=1,nspecies
svar(k)%Smean(i)=svar(k)%Smean(i)/recs(time)
enddo
enddo
endif
ind_shc = p_help/(t_help/10)
END SUBROUTINE stand_daily
!***************************************************************
SUBROUTINE SET_PS
USE data_stand
TYPE(coh_obj), POINTER :: p
p => pt%first
DO WHILE (ASSOCIATED(p))
! reset drought index & day counter to zero for next time step
p%coh%drIndPS = 0.
p%coh%nDaysPS = 0.
p => p%next
END DO
END SUBROUTINE SET_PS
!**************************************************************
SUBROUTINE drought
! Calculation of drought stress indices
! Sum up of RedN
USE data_simul
USE data_stand
USE data_par
USE data_species
implicit none
integer i, ii
real, dimension(1:nspecies):: rhelp
rhelp = 0.
! drought index of trees
zeig => pt%first
do while (associated(zeig))
ns = zeig%coh%species
! calculation of daily drought index
if (zeig%coh%demand .gt. 10E-6) then
if (ns.eq.nspec_tree+2) then ! set drought index to 1 for mistletoe (no drought)
zeig%coh%drIndD = 1
else
zeig%coh%drIndD = zeig%coh%supply / zeig%coh%demand
endif
else
zeig%coh%drIndD = 1.
endif
select case (flag_limi)
case (4, 5, 6, 7, 8, 9)
rhelp(ns) = rhelp(ns) + zeig%coh%ntreeA * zeig%coh%RedNc ! mean annual RedN
end select
IF ((iday .ge. zeig%coh%day_bb) .AND. (iday .le. spar(zeig%coh%species)%end_bb)) THEN
zeig%coh%drIndPS = zeig%coh%drIndPS + zeig%coh%drIndD
zeig%coh%drIndAl = zeig%coh%drIndAl + zeig%coh%drIndD
drIndD = drIndD + zeig%coh%ntreeA * zeig%coh%drIndD
ENDIF
zeig => zeig%next
enddo ! zeig (cohorts)
if (flag_limi .ge. 4 .and. flag_limi .le. 9) then
do i=1,anrspec
ii = nrspec(i)
svar(ii)%RedN = rhelp(ii) * 10000. / (svar(ii)%sum_nTreeA * kpatchsize) ! durch Anz. Tree pro patchsize teilen
enddo
endif
do i=1,anrspec
ii = nrspec(i)
svar(ii)%RedNm = svar(ii)%RedNm + svar(ii)%RedN
enddo
if(anz_tree.ne.0) then
drIndD = drIndD / anz_tree
endif
END subroutine drought
!***************************************************************
SUBROUTINE calc_fire_risk
!calculation of fire risk index
USE data_biodiv
USE data_climate
USE data_simul
USE data_soil
USE data_species
USE data_stand
implicit none
integer i, ii, nshelp
real hsum, hday, Tcrit_bi, cdays
real svp_13, vp_13, vpd_13, relhum_13
real k_prec ! constant depending on precipitation
real k_phen
real hh
if (iday.eq.1) then
prec_flag1 = 0
prec_flag2 = 0
tsumrob = 0.
day_bb_rob = 0
tsumbi = 0.
day_bb_bi = -999.
cdays = 0.
Tcrit_bi = 0.
end if
! calculation of day_bb for 'Robinie'
if(day_bb_rob.lt.1) then
if(airtemp.gt.9.3) tsumrob = tsumrob + airtemp
if(tsumrob.gt.537.) then
day_bb_rob = iday
end if
end if
! calculation of day_bb for birch
nshelp = 5
! Temperature sum model Schaber 2002
if(day_bb_bi.lt.-99) then
if(airtemp > spar(nshelp)%LTbT.and. iday.gt.47) then
tsumbi = tsumbi + airtemp - spar(nshelp)%LTbT
end if
if(tsumbi > spar(nshelp)%LTcrit) then
day_bb_bi = iday
end if
end if
! if birch is simulated
zeig=>pt%first
DO
IF (.not.ASSOCIATED(zeig)) exit
if(zeig%coh%species.eq.5) day_bb_bi = zeig%coh%day_bb
zeig=>zeig%next
END DO
! fire index west
if (iday .ge. 60 .and. iday .lt. 270) then
hday = iday/30.
ii = int(hday) - 1 ! month index
hsum = SUM(clim_waterb)
i = 1
do i=1,4
if (hsum .gt. risk_class(i,ii)) then
fire_indw = i
fire(1)%index = i
exit
endif
fire_indw = 5
fire(1)%index = 5
enddo
fd_fire_indw(fire_indw)=fd_fire_indw(fire_indw)+1
fire(1)%frequ(fire(1)%index) = fire(1)%frequ(fire(1)%index) + 1
else
fire(1)%index = 0
endif
if(airtemp_max .gt. -90.) then
! fire index east
if (iday .ge. 46 .and. iday .lt. 275) then
svp_13 = 6.1078 * exp(17.62 * airtemp_max / (243.12+airtemp_max)) ! saturated vapour pressure at 13.00
! estimation actual vapour pressure derived from mean air humidity
vp_13 = svp_13*hum/100
vpd_13 = svp_13 - vp_13 ! vapour pressure deficit at 13.00
relhum_13 = 100. * vp_13 / svp_13
if ((prec .ge. 1.0 .and. prec .lt. 5.0) .or. (snow_day .eq. 1)) then
k_prec = 0.5
else if ((prec .ge. 5.0 .and. prec .lt. 10.0) .or. (snow_day .eq. 2)) then
k_prec = 0.25
else if ((prec .ge. 10.0) .or. (snow_day .gt. 2)) then
k_prec = 0.0
else
k_prec = 1.0
endif
if (iday .lt. day_bb_bi .or. day_bb_bi.eq.-999) then
k_phen = 3.
else if (prec.lt. 5 .and. iday .le. 227 .and. day_bb_rob.ne.0 .and. prec_flag1.eq.0) then
k_phen = 2.
else if (prec.ge. 5 .and. day_bb_rob.ne.0 .and. iday .gt. day_bb_rob .and. iday .lt. 227 .or. (prec_flag1.eq.1.and.iday.le.227)) then
k_phen = 1.
prec_flag1 = 1
else if( day_bb_rob.eq.0) then
k_phen = 2
else if (iday.ge. 227.and. prec.ge. 5) then
k_phen = 0.5
prec_flag2 = 1
else if(prec_flag2 .eq.1 .or. iday .gt. 243) then
k_phen = 0.5
else
k_phen = 1. ! no modification of forest fire index
endif
hh = (airtemp_max + 10)*vpd_13
fire_indi = k_prec * fire_indi + k_phen*(airtemp_max + 10)*vpd_13
if (fire_indi .gt. 4000) fire_indi_day = fire_indi_day + 1
fire_indi_max = max(fire_indi, fire_indi_max)
! fire hazard level east
if (fire_indi .le. 500.) then
fire(2)%index = 1 ! no alarm level
else if (fire_indi .le. 2000.) then
fire(2)%index = 2 ! alarm level 1
else if (fire_indi .le. 4000.) then
fire(2)%index = 3 ! alarm level 2
else if (fire_indi .le. 7000.) then
fire(2)%index = 4 ! alarm level 3
else
fire(2)%index = 5 ! alarm level 4
endif
fire(2)%frequ(fire(2)%index) = fire(2)%frequ(fire(2)%index) + 1
else
fire_indi = 0.
fire(2)%index = 0
endif
! fire index Bruschek
if (iday > 90 .AND. iday < 275) then
if(airtemp_max .ge. 25.) Ndayshot = Ndayshot + 1
Psum_FP = Psum_FP + prec
endif
! fire index Nesterov
! only calulated for vegetation and snow free period
if (iday .ge. 60 .and. iday .lt. 275 .and. snow .lt. 0.01 .and. airtemp_max .gt. 0.) then
if (prec .lt. 3.) then
day_nest = day_nest + 1
p_nest = p_nest + (airtemp_max - dptemp) * airtemp_max
else
day_nest = 0
p_nest = 0.
endif
if (p_nest .le. 300.) then
fire(3)%index = 1 ! minimal
else if (p_nest .le. 1000.) then
fire(3)%index = 2 ! moderate
else if (p_nest .le. 4000.) then
fire(3)%index = 3 ! high
else
fire(3)%index = 4 ! extreme
endif
fire(3)%frequ(fire(3)%index) = fire(3)%frequ(fire(3)%index) + 1
else
p_nest = 0.
fire(3)%index = 0
endif
else
fire(2)%index = -99.0
fire(3)%index = -99.0
endif ! airtemp_max
END subroutine calc_fire_risk
!*******************************************************************************
subroutine calc_frost_index
USE data_frost
USE data_climate
USE data_simul
USE data_stand
implicit none
integer :: day_bb, j, t, m, ii
! absolute and annual last frost day during spring/ summer
if(airtemp_min .lt. temp_frost .and. iday .lt. 200 ) then
if(iday.gt.dlfabs ) dlfabs = iday
if(iday.gt.date_lftot(time)) date_lftot(time)=iday
end if
! annual number of frost days after start of the vegetation period and annual last frost day
if(flag_vegper.eq.1. .and. iday.lt.200) then
if(airtemp_min .lt. temp_frost) then
dnlf(time) = dnlf(time) +1
! calculation of last frost day after beginning of vegetation period due to 5°C threshold for the case of needle trees
if( waldtyp.eq.10 .or. waldtyp.eq.40.or.waldtyp.eq.90 .and. iday.gt. date_lf(time)) date_lf(time)= iday
end if
end if
! calculation of the number of the actual month
j= time_cur
ii = iday
call tzinda(t,m,j,ii)
iday = ii
if(m.eq.4 .or. m.eq.5 .or. m.eq.6) then
if(airtemp_min .lt.0) then
anzdlf(time)=anzdlf(time)+1
sumtlf(time) = sumtlf(time) + airtemp_min
end if
endif
! annual minimum temperature may for year time
if(airtemp_min.lt.tminmay_ann(time).and. m.eq.5) tminmay_ann(time) = airtemp_min
! absolute minimum temperature May
if( airtemp_min .lt. tminmay .and. m.eq.5) tminmay = airtemp_min
! assuming mono species stand !!!
zeig=>pt%first
DO
IF (.not.ASSOCIATED(zeig)) exit
taxnum= zeig%coh%species
day_bb = zeig%coh%day_bb
exit
zeig=>zeig%next
END DO
! caculation not for conifer stands (pine, spruce, douglas fir)
if(waldtyp .ne. 10 .and. waldtyp .ne. 40 .and. waldtyp .ne.90)then
if(all_leaves_on.eq.1) then
if (iday.ge.day_bb .and. iday.lt.200) then
! calculation of number of frost day during vegetation period (bud burst) for year time
if(airtemp_min .lt. temp_frost ) then
dnlf_sp(time) = dnlf_sp(time) +1
! calculagtion of last frost day after beginning of vegetation period by bud burst
if(iday .gt. date_lf(time)) date_lf(time)= iday
end if
end if
end if ! all_leaves_on
end if ! waldtyp
END subroutine calc_frost_index
!*******************************************************************************
Subroutine calc_endbb
use data_climate
use data_stand
use data_species
use data_simul
implicit none
integer :: tax,fl
if(iday.gt.180) then
zeig => pt%first
do while (associated(zeig))
tax = zeig%coh%species
fl = zeig%coh%flag_vegend
if(spar(tax)%end_bb.ne.366) then
if(spar(ns)%flag_endbb.eq.0) then
if(airtemp.ge.5. .and. fl .ne.0) then
fl=0
else if(airtemp.lt.5. .and. fl.eq.0) then
fl =1
else if(airtemp.lt.5. .and. fl.eq.1) then
fl =2
else if(airtemp.lt.5. .and. fl.eq.2) then
fl =3
else if(airtemp.lt.5. .and. fl.eq.3)then
fl =4
else if(airtemp.lt.5. .and. fl.eq.4) then
fl =5
end if
zeig%coh%flag_vegend = fl
if(fl .eq.5) then
spar(tax)%flag_endbb=1
spar(tax)%end_bb = iday
write(666,*) time, iday
end if
end if
zeig => zeig%next
end if
end do
end if
end subroutine calc_endbb
source_code/version_2.3_windows/day_ini.f 0 → 100644
View file @ 82df1085
!*****************************************************************!
!* *!
!* 4C (FORESEE) Simulation Model *!
!* *!
!* *!
!* Subroutine DAY_INI for: *!
!* *!
!* allocation of daily weather variables *!
!* *!
!* Copyright (C) 1996-2018 *!
!* Potsdam Institute for Climate Impact Reserach (PIK) *!
!* Authors and contributors see AUTHOR file *!
!* This file is part of 4C and is licensed under BSD-2-Clause *!
!* See LICENSE file or under: *!
!* http://www.https://opensource.org/licenses/BSD-2-Clause *!
!* Contact: *!
!* https://gitlab.pik-potsdam.de/foresee/4C *!
!* *!
!*****************************************************************!
SUBROUTINE day_ini
USE data_biodiv
USE data_climate
USE data_depo
USE data_evapo
USE data_simul
USE data_site
USE data_stand
USE data_par
implicit none
type(Coh_Obj), pointer :: p ! pointer to cohort list
real, external :: photoper
real, external :: daylength
integer i, j
j = time
i = iday
airtemp = tp(i,j)+deltaT
airtemp_1 = tp(i-1,j)+deltaT
airtemp_2 = tp(i-2,j)+deltaT
airtemp_max = tx(i,j)
airtemp_min = tn(i,j)
prec = prc(i,j)*deltaPrec
hum = hm(i,j)
if (hum .le. 0.) then
hum = 1.
else if (hum .gt. 100.) then
hum = 100.
endif
if (press .gt. 0.) then
press = prs(i,j)
else
press = 1013.
endif
rad = rd(i,j)
wind = wd(i,j)
if (wind .lt. 0.) wind = 0.5
dlength = photoper(i+0.,xlat)
med_air = med_air + airtemp
sum_prec = sum_prec + prec
if(recs(time).eq.365) then
if(i.gt.120 .and. i.lt.274) then
med_air_ms = med_air_ms + airtemp
sum_prec_ms = sum_prec_ms + prec
end if
if(i.gt.120 .and. i .lt. 213) then
med_air_mj = med_air_mj + airtemp
sum_prec_mj = sum_prec_mj + prec
end if
else
if(i.gt.121 .and. i.lt.275) then
med_air_ms = med_air_ms + airtemp
sum_prec_ms = sum_prec_ms + prec
if(i.gt.121 .and. i .lt.214) then
med_air_mj = med_air_mj + airtemp
sum_prec_mj = sum_prec_mj + prec
end if
end if
end if
med_rad = med_rad + rad
med_wind = med_wind + wind
if (airtemp.gt. thr_gdd) then
gdday = gdday + airtemp
gdday_all = gdday_all + airtemp
end if
if (airtemp_max .ge. 25.) then
days_summer = days_summer + 1
if (airtemp_max .ge. 30.) then
days_hot = days_hot + 1
endif
endif
if( airtemp_min .gt. 0) days_wof = days_wof +1
if ((airtemp_max .lt. 0.) .and. (airtemp_max .gt. -90.)) then
days_ice = days_ice + 1
endif
if (prec .lt. 1.E-06) then
days_dry = days_dry + 1
else if (prec .gt. 10.) then
days_hrain = days_hrain + 1
else if (prec .gt. 0.1) then
days_rain = days_rain +1
if(recs(time).eq.365) then
if(i.gt.120 .and. i .lt. 213) days_rain_mj = days_rain_mj +1
else
if(i.gt.121 .and. i .lt.214) days_rain_mj = days_rain_mj +1
end if
endif
drIndd = 0.
lightsum = lightsum + rad/100 ! sum global radiation in mJ/m2
abslightsum = abslightsum + rad/100*totFPARsum ! sum absorbed global radiation in mJ/m2
! set standardised deposition data for areal application of deposition:
NO_dep = NOd(i,j)*0.001 ! mg N/m2 ==> g N/m2
NH_dep = NHd(i,j)*0.001 ! mg N/m2 ==> g N/m2
pev_sn = 0.
dew_rime = 0.
fire_indw = -99
fire_inde = -99
! water and N uptake
p => pt%first
do while (associated(p))
p%coh%supply = 0.
p%coh%Nuptc_d = 0.
p => p%next
enddo ! p (cohorts)
END SUBROUTINE day_ini
source_code/version_2.3_windows/dist_manag.f 0 → 100644
View file @ 82df1085
!*****************************************************************!
!* *!
!* 4C (FORESEE) *!
!* *!
!* *!
!* Subroutines for: *!
!* disturbance management *!
!* contains: *!
!* SR dist_ini *!
!* SR dist_manag *!
!* SR beetle_nat *!
!* SR beetle_man *!
!* SR disturbance_defoliator *!
!* SR disturbance_xylem *!
!* SR disturbance_phloem *!
!* SR disturbance_root *!
!* SR disturbance_stem *!
!* *!
!* Copyright (C) 1996-2018 *!
!* Potsdam Institute for Climate Impact Reserach (PIK) *!
!* Authors and contributors see AUTHOR file *!
!* This file is part of 4C and is licensed under BSD-2-Clause *!
!* See LICENSE file or under: *!
!* http://www.https://opensource.org/licenses/BSD-2-Clause *!
!* Contact: *!
!* https://gitlab.pik-potsdam.de/foresee/4C *!
!* *!
!*****************************************************************!
SUBROUTINE dist_ini
use data_manag
use data_simul
use data_species
use data_stand
use data_soil
implicit none
integer :: dis_unit,i,ios
character(len=150) :: filename
logical :: ex
character(3) ::text
dis_control=0
xylem_dis=1.0
phlo_feed=1.0
stem_rot=0.0
zeig=>pt%first
do
if(.not.associated(zeig)) exit
zeig%coh%x_fol_loss=0.
zeig%coh%x_frt_loss=0.
zeig%coh%biocost_all=0.
zeig=>zeig%next
end do
dis_unit=getunit()
filename = manfile(ip)
call testfile(filename,ex)
open(dis_unit,file=trim(filename))
do
read(dis_unit,*) text
if(text .eq. 'end')then
exit
endif
enddo
! read the total number of disturbance events (first line after 'end') and after this the annual events
read (dis_unit,*) dis_row_nr ! number of disturbance lines
allocate(dis_year(dis_row_nr));allocate(dis_type(dis_row_nr));
allocate(dis_spec(dis_row_nr));allocate(dis_start(dis_row_nr))
allocate(dis_rel(dis_row_nr))
do i=1,dis_row_nr
read(dis_unit,*,iostat=ios) dis_year(i),dis_type(i), dis_spec(i), dis_start(i), dis_rel(i)
if(ios<0) exit
end do
close(dis_unit)
END SUBROUTINE dist_ini
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
SUBROUTINE dis_manag
use data_manag
use data_simul
use data_stand
use data_site
use data_species
use data_soil
implicit none
integer :: i
do i= 1, dis_row_nr
if(time .eq. dis_year(i)) then
if(dis_type(i) .eq. 'D') then
dis_control(1,1) = 1
dis_control(1,2) = i
endif
if(dis_type(i) .eq. 'X') then
dis_control(2,1) = 1
dis_control(2,2) = i
endif
if(dis_type(i) .eq. 'P') then
dis_control(3,1) = 1
dis_control(3,2) = i
endif
if(dis_type(i) .eq. 'R') then
dis_control(4,1) = 1
dis_control(4,2) = i
endif
if(dis_type(i) .eq. 'S') then
dis_control(5,1) = 1
dis_control(5,2) = i
endif
if(dis_type(i) .eq. 'M') then
dis_control(6,1) = 1
dis_control(6,2) = i
endif
endif
enddo
END SUBROUTINE dis_manag
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! bark beetle infestation in unmanaged stands
SUBROUTINE beetle_nat(dis_rel_ip, rel_cra)
use data_manag
use data_simul
use data_species
use data_stand
use data_par
implicit none
real :: dis_cra, tot_cra, rel_cra, dis_rel_ip, tar_cra, tar_ba, dis_ba, tot_ba
real :: help, helpN, help1, help1N, hconvd
integer :: i, j, taxnr
dis_cra = 0
tot_cra = 0
dis_ba = 0
tot_ba = 0
help = 0
zeig=>pt%first
do
if(.not.associated(zeig)) exit
tot_cra = tot_cra + zeig%coh%crown_area*zeig%coh%ntreea
tot_ba = tot_ba + zeig%coh%ntreea*pi*zeig%coh%diam*zeig%coh%diam/4
if(zeig%coh%species.eq.2.and. zeig%coh%x_age.gt.50.and.zeig%coh%ntreea.ne.0) then
dis_cra = dis_cra + zeig%coh%crown_area*zeig%coh%ntreea
dis_ba = dis_ba + zeig%coh%ntreea*pi*zeig%coh%diam*zeig%coh%diam/4
end if
zeig=>zeig%next
end do
rel_cra = (tot_cra/dis_cra)* dis_rel_ip/100.
tar_cra = dis_cra * dis_rel_ip/100
tar_ba = dis_ba * dis_rel_ip/100
do while (help.lt.(tar_ba-0.01).and.help.lt.(dis_ba-0.01))
zeig=>pt%first
do
if(.not.associated(zeig)) exit
if(zeig%coh%species.eq.2.and. zeig%coh%x_age.gt.50.and. zeig%coh%ntreea.ne.0) then
zeig%coh%ntreea = zeig%coh%ntreea -1
zeig%coh%nta = zeig%coh%ntreea
zeig%coh%ntreem = zeig%coh%ntreem +1
help = help + pi*zeig%coh%diam*zeig%coh%diam/4
end if
if(help.ge.(dis_ba-0.01)) exit
if(help.ge.(tar_ba-0.01)) exit
zeig=>zeig%next
end do
end do
zeig=>pt%first
do
if(.not.associated(zeig)) exit
taxnr = zeig%coh%species
IF (taxnr.eq.2.and. zeig%coh%x_age.gt.50.and.zeig%coh%ntreem.ne.0) then
zeig%coh%litC_fol = zeig%coh%litC_fol + zeig%coh%ntreem*(1.-spar(taxnr)%psf)*zeig%coh%x_fol*cpart
zeig%coh%litN_fol = zeig%coh%litN_fol + zeig%coh%ntreem*((1.-spar(taxnr)%psf)*zeig%coh%x_fol*cpart)/spar(taxnr)%cnr_fol
zeig%coh%litC_frt = zeig%coh%litC_frt + zeig%coh%ntreem*zeig%coh%x_frt*cpart
zeig%coh%litN_frt = zeig%coh%litN_frt + zeig%coh%ntreem*zeig%coh%x_frt*cpart/spar(taxnr)%cnr_frt
zeig%coh%litC_crt = zeig%coh%litC_crt + zeig%coh%ntreem*zeig%coh%x_crt*cpart
zeig%coh%litN_crt = zeig%coh%litN_crt + zeig%coh%ntreem*zeig%coh%x_crt*cpart/spar(taxnr)%cnr_crt
hconvd = 1000. / kpatchsize
do i = 1,nspec_tree
! delayed litter fall from dead stems and twigs/branches
help = zeig%coh%ntreem*zeig%coh%x_tb*cpart*hconvd
helpN = zeig%coh%ntreem*zeig%coh%x_tb*cpart/spar(taxnr)%cnr_tbc*hconvd
help1 = zeig%coh%ntreem*(zeig%coh%x_sap+zeig%coh%x_hrt)*cpart*hconvd
help1N = zeig%coh%litC_stem/spar(taxnr)%cnr_stem*hconvd
do j = 1, lit_year
dead_wood(taxnr)%C_tb(j) = dead_wood(taxnr)%C_tb(j) + help/lit_year
dead_wood(taxnr)%N_tb(j) = dead_wood(taxnr)%N_tb(j) + helpN/lit_year
dead_wood(taxnr)%C_stem(j) = dead_wood(taxnr)%C_stem(j) + help1/lit_year
dead_wood(taxnr)%N_stem(j) = dead_wood(taxnr)%N_stem(j) + help1N/lit_year
enddo ! j (lit_year)
enddo ! i (nspec_tree)
end if
zeig=>zeig%next
end do
END SUBROUTINE beetle_nat
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! management of stands with bark beetle infestation
SUBROUTINE beetle_man(dis_rel_ip, rel_cra)
use data_manag
use data_simul
use data_species
use data_stand
use data_par
implicit none
real :: dis_cra, tot_cra, rel_cra, dis_rel_ip, tot_ba, dis_ba, tar_ba
real :: help
integer :: taxnr
dis_cra = 0
tot_cra = 0
help = 0
dis_ba = 0
tot_ba = 0
zeig=>pt%first
do
if(.not.associated(zeig)) exit
tot_cra = tot_cra + zeig%coh%crown_area*zeig%coh%ntreea
tot_ba = tot_ba + zeig%coh%ntreea*pi*zeig%coh%diam*zeig%coh%diam/4
if(zeig%coh%species.eq.2.and. zeig%coh%x_age.gt.50) then
dis_cra = dis_cra + zeig%coh%crown_area*zeig%coh%ntreea
dis_ba = dis_ba + zeig%coh%ntreea*pi*zeig%coh%diam*zeig%coh%diam/4
end if
zeig=>zeig%next
end do
rel_cra = (tot_cra/dis_cra)* dis_rel_ip/100.
tar_ba = dis_ba * dis_rel_ip/100.
do while (help.lt.tar_ba.and.help.ne.dis_ba)
zeig=>pt%first
do
if(.not.associated(zeig)) exit
if(zeig%coh%species.eq.2.and. zeig%coh%x_age.gt.50.and.zeig%coh%ntreea.ne.0) then
zeig%coh%ntreea = zeig%coh%ntreea -1
zeig%coh%nta = zeig%coh%ntreea
zeig%coh%ntreem = zeig%coh%ntreem +1
help = help + zeig%coh%crown_area
help = help + pi*zeig%coh%diam*zeig%coh%diam/4
if(help.eq.dis_ba) exit
if(help.gt. tar_ba) exit
end if
zeig=>zeig%next
end do
end do
zeig=>pt%first
do
if(.not.associated(zeig)) exit
taxnr = zeig%coh%species
IF (taxnr.eq.2.and. zeig%coh%x_age.gt.50.and.zeig%coh%ntreem.ne.0) then
! stems, twigs and branches are completely removed
zeig%coh%litC_fol = zeig%coh%litC_fol + zeig%coh%ntreem*(1.-spar(taxnr)%psf)*zeig%coh%x_fol*cpart
zeig%coh%litN_fol = zeig%coh%litN_fol + zeig%coh%ntreem*((1.-spar(taxnr)%psf)*zeig%coh%x_fol*cpart)/spar(taxnr)%cnr_fol
zeig%coh%litC_frt = zeig%coh%litC_frt + zeig%coh%ntreem*zeig%coh%x_frt*cpart
zeig%coh%litN_frt = zeig%coh%litN_frt + zeig%coh%ntreem*zeig%coh%x_frt*cpart/spar(taxnr)%cnr_frt
zeig%coh%litC_crt = zeig%coh%litC_crt + zeig%coh%ntreem*zeig%coh%x_crt*cpart
zeig%coh%litN_crt = zeig%coh%litN_crt + zeig%coh%ntreem*zeig%coh%x_crt*cpart/spar(taxnr)%cnr_crt
end if
zeig=>zeig%next
end do
END SUBROUTINE beetle_man
!##########################!
!! DEFOLIATOR DISTURBANCES !!
!##########################!
SUBROUTINE disturbance_defoliator
use data_manag
use data_soil_cn
use data_simul
use data_stand
use data_site
use data_species
use data_par
implicit none
real :: loss, remain, humusnew, humusneuin
character(50) :: helpout
helpout='disturbance_defoliator'
if (flag_standup .eq. 0) flag_standup = 1 ! call stand_balance later
humusnew=0.
remain=1.0
loss=dis_rel(dis_control(1,2))
if (loss .lt. 0.0) loss=0.0
if (loss .gt. 1.0) loss=1.0
remain=1.0-loss
if (remain .lt. 0.0) remain=0.0
if (remain .gt. 1.0) remain=1.0
if (loss .gt. 0.01) then
zeig=>pt%first
do
if(.not.associated(zeig)) exit
if (zeig%coh%species .le. nspec_tree) then
zeig%coh%x_fol_loss=zeig%coh%x_fol*loss
zeig%coh%x_fol=zeig%coh%x_fol*remain
endif
zeig=>zeig%next
end do
write(*,*)helpout
endif ! loss>0.01
END SUBROUTINE disturbance_defoliator
!#####################!
!! XYLEM DITURBANCES !!
!#####################!
SUBROUTINE disturbance_xylem
use data_manag
use data_simul
use data_stand
use data_site
use data_species
use data_par
use data_soil
implicit none
real :: loss, remain
character(50) :: helpout
if (flag_standup .eq. 0) flag_standup = 1 ! call stand_balance later
helpout='disturbance_xylem'
xylem_dis=1.0-dis_rel(dis_control(2,2))
if (xylem_dis .lt. 0.0) xylem_dis=0.0
if (xylem_dis .gt. 1.0) xylem_dis=1.0
write(*,*)helpout
END SUBROUTINE disturbance_xylem
!######################!
!! PHLOEM DITURBANCES !!
!######################!
SUBROUTINE disturbance_phloem
use data_manag
use data_simul
use data_stand
use data_site
use data_species
use data_par
implicit none
character(50) :: helpout
if (flag_standup .eq. 0) flag_standup = 1 ! call stand_balance later
helpout='disturbance_phloem'
phlo_feed=1.0-dis_rel(dis_control(3,2))
if (phlo_feed .lt. 0.0) phlo_feed=0.0
if (phlo_feed .gt. 1.0) phlo_feed=1.0
write(*,*)helpout
END SUBROUTINE disturbance_phloem
!####################!
!! ROOT DITURBANCES !!
!####################!
SUBROUTINE disturbance_root
use data_manag
use data_simul
use data_stand
use data_site
use data_species
use data_par
implicit none
real :: loss, remain
character(50) :: helpout
if (flag_standup .eq. 0) flag_standup = 1 ! call stand_balance later
remain=1.0
loss=dis_rel(dis_control(4,2))
if (loss .lt. 0.0) loss=0.0
if (loss .gt. 1.0) loss=1.0
remain=1.0-loss
if (remain .lt. 0.0) remain=0.0
if (remain .gt. 1.0) remain=1.0
helpout='disturbance_root'
zeig=>pt%first
do
if(.not.associated(zeig)) exit
if (zeig%coh%species .le. nspec_tree) then
zeig%coh%x_frt_loss=zeig%coh%x_frt*loss
zeig%coh%x_frt=zeig%coh%x_frt*remain
endif
zeig=>zeig%next
end do
write(*,*)helpout
END SUBROUTINE disturbance_root
!####################!
!! STEM DITURBANCES !!
!####################!
SUBROUTINE disturbance_stem
use data_manag
use data_simul
use data_stand
use data_site
use data_species
use data_par
implicit none
character(50) :: helpout
if (flag_standup .eq. 0) flag_standup = 1 ! call stand_balance later
helpout='disturbance_stem'
stem_rot=dis_rel(dis_control(5,2))
if (stem_rot .lt. 0.0) stem_rot=0.0
if (stem_rot .gt. 1.0) stem_rot=1.0
write(*,*)helpout
END SUBROUTINE disturbance_stem
!####################!
!! MISTLETOE INFECTION !!
!####################!
! mistletoe cohort is produced in prepstand.f
source_code/version_2.3_windows/evapo.f 0 → 100644
View file @ 82df1085
!*****************************************************************!
!* *!
!* 4C (FORESEE) Simulation Model *!
!* *!
!* *!
!* Subroutines for: *!
!* Soil and Water - Programs *!
!* *!
!* contains: *!
!* EVAPO calculation of potential evapotranspiration *!
!* EVAPO_INI initialisation of potential evapotranspiration *!
!* turc_ivanov *!
!* sunshine *!
!* *!
!* Copyright (C) 1996-2018 *!
!* Potsdam Institute for Climate Impact Reserach (PIK) *!
!* Authors and contributors see AUTHOR file *!
!* This file is part of 4C and is licensed under BSD-2-Clause *!
!* See LICENSE file or under: *!
!* http://www.https://opensource.org/licenses/BSD-2-Clause *!
!* Contact: *!
!* https://gitlab.pik-potsdam.de/foresee/4C *!
!* *!
!*****************************************************************!
SUBROUTINE evapo
! Potential evapotranspiration PET
use data_climate
use data_evapo
use data_inter
use data_par
use data_simul
use data_site
use data_stand
use data_soil
use data_species
implicit none
integer i
real atemp25, cf, hxx, redcof
real pet0, & ! PET Turc/Ivanov
pet1, & ! PET Priestley-Taylor
pet2, & ! PET Priestley-Taylor for each cohort
pet3, & ! PET Penman/Monteith
pet4, & ! PET Penman/Monteith for each cohort
pet5, & ! PET Haude
pev0_s, & ! soil evaporation from Turc/Ivanov
pev1_s, & ! soil evaporation from Priestley-Taylor
pev2_s, & ! soil evaporation from Priestley-Taylor for each cohort
h_klim, & ! height of reference station
gamma, & ! scheinbare Psychrometer-Konstante
svp, & ! saturated vapour pressure
vpd, & ! vapour pressure deficit
vpress, & ! vapour pressure
delta, & ! slope of vapour pressure curve against temperature
dens_air, & ! density of dry air (kg/m3) (like MONTEITH (1973))
alpha, & ! Priestley-Taylor coefficient
Rnet, & ! net radiation W/m2 of whole canopy
Rnet_s, & ! absorbed global radiation W/m2 of soil
Rnet_alb, & ! net radiation from radiation balance with intermediate calculation in J/m2
Rnet_alb1,& ! net radiation from radiation balance without reflected radiation in J/cm2
Rnet_tem, & ! net radiation from temperature and airpressure
Rnet_fed, & ! net radiation according to Federer (1968) and Feddes (1971)
Rrefl, & ! reflected long wave radiation
Srel, & ! relative sunshine duration
albedo, &
sigma, & ! Boltzmannsche constant
lamb, & ! latent heat of vaporization of water (W / (m2 mm) day value)
rc, & ! empir. plant base resistance (s/m)
v_conc, & ! concentration water vapour
hf, hln, hz, z0, tutrf, &
atmp_1
real Rnet1, Rnet2_sum, Rnet3, Rnet4_sum
real Rnet_mw, & ! net radiation (J/cm2) measured value
G_flux ! soil heat flux (J/cm2) measured value
character (10) text
real transd0, transd1, hx
! for PET according to Haude
real svp_13, vp_13, vpd_13, relhum_13, dptemph, hh
real dpta, dptb, dptc ! coefficients for calculation of dew point temperature
real, dimension(12) :: ft_haude=(/0.22,0.22,0.22,0.29,0.29,0.28,0.26,0.25,0.23,0.22,0.22,0.22/)
! read flux data
if (flag_eva .gt.10) read (unit_eva,*) text, Rnet_mw, G_flux
alpha = alpha_PT
atmp_1 = 1./(airtemp + 273.3)
svp = 6.1078 * exp(17.2694 * airtemp * atmp_1) ! saturated vapour pressure (MURRAY, 1967)
vpress = 0.01 * hum * svp
vpd = svp*(1. - hum*0.01) ! vapour pressure deficit
! dew point temperature (DVWK 1996, P. 83)
if(airtemp .lt. 0.) then
dpta = 272.2
dptb = 24.27
else
dpta = 243.12
dptb = 19.43
endif
dptc = 1.81
dptemp = dpta * (log(vpress)-dptc) / (dptb-log(vpress))
! relative Sonnenscheindauer
call sunshine(Srel, iday, lat, dlength, rad)
!! net radiation from radiation balance ( Rijtema, 1965)
! albedo = 0.35 ! adjustment to Rnet for spruce (Tharandt), beech (Hesse), pine (Loobos)
! albedo = 0.1 ! for pine from Lit.
!net radiation according to Federer (1968) and Feddes (1971)
Rnet_fed = 0.649 * (rad/8.64) - 23 ! rad: J/cm2 ==> W/m2
Rnet_fed = 8.64 * Rnet_fed ! W/m2 ==> J/cm2
Rnet_tot = Rnet_fed
Rnet = (Rnet_tot/8.64) ! J/cm2 ==> W/m2
if (((snow .gt. 0.) .or. lint_snow) .and. (airtemp .lt. 0.)) then
! snow or frost evaporation (DVWK S.73, 1996; Rachner, 1987)
albedo = 0.85
pev_sn = 0.41 * vpd - 0.22
if (pev_sn .lt. 0.) then
dew_rime = -pev_sn
pev_s = 0.1
else
pev_s = pev_sn
endif
if (Rnet_fed .lt. 0.) then
sigma = 5.67 * 10.**(-8) ! W / m2
Rrefl = sigma * (airtemp+273)**4 * (0.56 - 0.079*Sqrt(vpress))*(0.1 + 0.9*Srel) ! J/m2
Rnet_alb = (rad*10000.0 * (1.-albedo) - Rrefl) ! J/m2
Rnet_alb = Rnet_alb * 0.0001
Rnet_tot = Rnet_alb ! J/cm2
Rnet = (Rnet_tot/8.64) ! J/cm2 ==> W/m2
endif
pet = 0.
zeig => pt%first
do while (associated(zeig))
zeig%coh%demand = 0.
zeig => zeig%next
enddo ! zeig (cohorts)
else
if (Rnet_fed .lt. 0.) then
albedo = 0.2
sigma = 5.67 * 10.**(-8) ! W / m2
Rrefl = sigma * (airtemp+273)**4 * (0.56 - 0.079*Sqrt(vpress))*(0.1 + 0.9*Srel) ! J/m2
Rnet_alb = (rad*10000.0 * (1.-albedo) - Rrefl) ! J/m2
Rnet_alb = Rnet_alb * 0.0001
Rnet_tot = Rnet_alb ! J/cm2
Rnet = (Rnet_tot/8.64) ! J/cm2 ==> W/m2
endif
select case (flag_eva)
case (0,6,7)
call turc_ivanov
case (1,2,3,4,16,17,36,37)
! preparation Priestley/Taylor and Penman/Monteith calculation
gamma = psycro * press
delta = 239. * 17.4 * svp * atmp_1*atmp_1 ! slope of vapour pressure curve
lamb = (2.498 - 0.00242*airtemp) * 1E06 ! W s /(m2 mm) == J/mm / m2
lamb = lamb/86400. ! W / (m2 mm) Tageswert
if (anz_coh .le. 0) then
pet = alpha * Rnet * delta/((delta+gamma)*lamb) ! potential evapotranspiration of canopy
pev_s = 0.
else
if (all_leaves_on .eq. 0) then
pet = alpha * Rnet * delta/((delta+gamma)*lamb) ! potential evapotranspiration of canopy
! potential transpiration demand of each cohort
if (gp_can .gt. 1.E-6) then
hx = pet / gp_can
else
hx = 0.
endif
zeig => pt%first
do while (associated(zeig))
zeig%coh%demand = zeig%coh%gp * zeig%coh%ntreea * hx
if (zeig%coh%species.eq.nspec_tree+2) then !save demand of mistletoe calculated cohort-specific for later use in upt_wat (soil.f)
demand_mistletoe_cohort=zeig%coh%gp * zeig%coh%ntreea * hx
end if
zeig => zeig%next
enddo ! zeig (cohorts)
! soil evaporation
redcof = 0.4
Rnet_s = (Rnet_tot/8.64) * redcof ! J/cm2 ==> W/m2
else
Rnet = (Rnet_tot/8.64) * totFPARsum ! J/cm2 ==> W/m2
Rnet_s = (Rnet_tot/8.64) * (1.-totFPARsum) ! J/cm2 ==> W/m2
select case (flag_eva)
case (1) ! Priestley / Taylor
pet = alpha * Rnet * delta/((delta+gamma)*lamb) ! potential evapotranspiration of canopy
case (2) ! Priestley / Taylor for each cohort
pet2 = 0.
Rnet2_sum = 0
zeig => pt%first
do while (associated(zeig))
if (zeig%coh%gp .gt. 0.) then
Rnet = (Rnet_tot/8.64) * zeig%coh%totFPAR * zeig%coh%nTreeA ! J/cm2 ==> W/m2
Rnet2_sum = Rnet2_sum + Rnet
zeig%coh%demand = alpha * Rnet * delta/((delta+gamma)*lamb) ! potential evapotranspiration of cohort
if (zeig%coh%species.eq.nspec_tree+2) then !save demand of mistletoe calculated cohort-specific for later use in upt_wat (soil.f)
demand_mistletoe_cohort=alpha * Rnet * delta/((delta+gamma)*lamb)
end if
else
zeig%coh%demand = 0.
endif
pet2 = pet2 + zeig%coh%demand
zeig => zeig%next
enddo ! zeig (cohorts)
pet = pet2
case(3,36,37) ! Penman/Monteith
h_klim = 200. ! Hoehe Messstation (cm)
dens_air = 1.2917 - 0.00434*airtemp ! density of dry air (kg/m3) (like MONTEITH (1973))
dens_air = dens_air*0.001 ! kg/m3 --> g/cm3
hf = dens_air * c_karman*c_karman * wind
if (hdom .ge. 0.5) then
hz = hdom
else
hz = 0.5
endif
z0 = 10.**(0.997*alog10(hz)-0.883)
hln = alog(h_klim/z0)
tutrf = hf*rmolw / (hln*hln*press)
! canopy conductance verwenden:
v_conc = (press*100.) / (R_gas * (273.15 + airtemp)) ! pressure in hPa --> Pa
if (gp_can .gt. 1E-8) then
rc = gp_can / (8980.0 * v_conc) ! gp_can mol/m2*d --> m/s
rc = 1. / rc
Rnet = (Rnet_tot/8.64) * totFPARsum ! J/cm2/d ==> W/m2
Rnet3 = Rnet
pet3 = (delta*Rnet + vpd*hf*c_air/(hln*hln)) / &
((delta+gamma*(1+rc*tutrf))*lamb)
pet = pet3
else
call turc_ivanov
endif ! gp_can
case(4) ! Penman/Monteith for each cohort
pet4 = 0.
Rnet4_sum = 0
h_klim = 200. ! hight of measurement station (cm)
dens_air = 1.2917 - 0.00434*airtemp ! density of dry air (kg/m3) (like MONTEITH (1973))
dens_air = dens_air*0.001 ! kg/m3 --> g/cm3
hf = dens_air * c_karman*c_karman * wind
v_conc = (press*100.) / (R_gas * (273.15 + airtemp)) ! pressure hPa --> Pa
zeig => pt%first
do while (associated(zeig))
if (zeig%coh%gp .gt. 0.) then
if (zeig%coh%height .ge. 0.5) then
hz = zeig%coh%height
else
hz = 0.5
endif
z0 = 10.**(0.997*alog10(hz)-0.883)
hln = alog(h_klim/z0)
if( hln.ne.0) then
tutrf = hf*rmolw / (hln*hln*press)
! canopy conductance verwenden:
rc = zeig%coh%gp / (8980.0 * v_conc) ! gp_can mol/m2*d --> m/s
rc = 1. / rc
Rnet = (Rnet_tot/8.64) * zeig%coh%totFPAR * zeig%coh%nTreeA ! J/cm2 ==> W/m2
Rnet4_sum = Rnet4_sum + Rnet ! zum Test
zeig%coh%demand = (delta*Rnet + vpd*hf*c_air/(hln*hln)) / & ! potential evapotranspiration of cohort
((delta+gamma*(1+rc*tutrf))*lamb)
!save demand of mistletoe calculated cohort-specific for later use in upt_wat (soil.f)
if (zeig%coh%species.eq.nspec_tree+2) then
if (zeig%coh%demand.lt.0) zeig%coh%demand=0 ! avoid further calculations with neg. demands
demand_mistletoe_cohort=zeig%coh%demand
endif
endif
else
zeig%coh%demand = 0.
endif ! ...coh%gp
pet4 = pet4 + zeig%coh%demand
zeig => zeig%next
enddo ! zeig (cohorts)
pet = pet4
end select ! flag_eva (inner cycle)
endif ! all_leaves_on
! soil evaporation
pev_s = alpha * Rnet_s * delta/((delta+gamma)*lamb) ! potential soil evaporation
endif ! anz_coh
case (5) ! PET Haude
if(airtemp_min .gt. -90.) then
dptemph = airtemp_min - 4. ! dew point temperature
vp_13 = 6.1078 * exp(17.62 * dptemph / (243.12+dptemp)) ! estimated actual vapour pressure at 13.00 (DVWK)
svp_13 = 6.1078 * exp(17.62 * airtemp_max / (243.12+airtemp_max)) ! saturated vapour pressure at 13.00 (DVWK)
vpd_13 = svp_13 - vp_13 ! vapour pressure deficit at 13.00
relhum_13 = 100. * vp_13 / svp_13
hh = ft_haude(monat)
pet5 = hh* vpd_13
! without limit, because otherwise class5 wont be reached (maxwert = -35!)
! limit according to DVWK annotation (Merkblatt) is 7 mm
pev_s = pet5 * exp(-0.6*LAI) ! nach Belmans, Dekker & Bouma, 1982
pet = pet5 - pev_s
else
print *, ' >>>foresee message: Program aborted'
print *, ' >>> Minimum air temperature required but not available'
Stop
endif
end select ! flag_eva (aeusserer Zyklus)
endif ! snow
! Gesamt-PET als Summe PET-Bestand und Boden-Evaporation
pet = pet + pev_s
hx = alfm * (1. - exp(-gp_can/gpmax))
! climatic water balance of the last five days
do i= 1,4
clim_waterb(i) = clim_waterb(i+1)
enddo
clim_waterb(5) = prec - pet
pet_cum = pet_cum + pet
Rnet_cum = rnet_cum + rnet_tot
END subroutine evapo
!******************************************************************************
SUBROUTINE turc_ivanov
use data_climate
use data_evapo
use data_stand
implicit none
real atemp25, cf, hxx, pet0
! calculation after DYCK/PESCHKE, 1995, S.200
if (airtemp .gt. 5.) then
if (hum .lt. 50.) then
cf = 1. + (50. - hum) / 70.
else
cf = 1.
endif ! hum
pet0 = 0.0031 * cf * (rad+209.) * airtemp/(airtemp+15.) ! from TURC
else
atemp25 = (airtemp + 25.)
pet0 = 3.6 * 10.**(-5) * (100 - hum) * atemp25 * atemp25 ! from IVANOV (daily)
endif ! airtemp
pev_s = pet0 * exp(-0.6*LAI) ! Belmans, Dekker & Bouma, 1982
pet = pet0 - pev_s
END subroutine turc_ivanov
!******************************************************************************
SUBROUTINE sunshine (sdrel, iday, xxlat, dayl, rad)
! Estimation of sunshine duration from global radiation
! (calculation after Angstrom)
!use data_site
implicit none
! input:
integer :: iday ! actual day
real :: dayl ! daylength
real :: rad ! global radiation (J/cm2)
real :: xxlat ! latitude
! output:
real :: sdrel !, sdrel1 ! sunshine duration (h)
! internal variables
real :: rad_ex , & ! extraterrestrical radiation (MJ/m2)
dec , & ! declination of sun angle
sinld, cosld, tanld, dsinb, dsinbe, &
sc, radi, seas
real :: pi = 3.141592654
real :: solc = 1367. ! solar constant (J/(m2*s)
! according to P. Hupfer: "Klimasystem der Erde", 1991
if (rad .lt. 1.E-6) then
sdrel=0
return
end if
! change of units from degree to radians
radi = pi/180.
! term of seasonality (10 days in front of calendar)
seas = (iday+10.)/365.
! declination of sun angle
! (Spitters et al. 1986, equations transformed for use or radians)
dec = -asin(sin(23.45*radi)*cos(2.*pi*seas))
! some intermediate values
sinld = sin(xxlat*radi)*sin(dec)
cosld = cos(xxlat*radi)*cos(dec)
tanld = amax1(-1., amin1(1., sinld/cosld))
! integral of sun elevation
dsinb = 3600.*(dayl*sinld+24.*cosld*sqrt(1.-tanld*tanld)/pi)
! corrected integral of sun elevation
dsinbe = 3600.*(dayl*(sinld+0.4*(sinld*sinld+cosld*cosld*0.5)) &
+12.*cosld*(2.+3.*0.4*sinld)*sqrt(1.-tanld*tanld)/pi)
! intensity of radiation outside the atmosphere
sc = solc/(1.-0.016729*cos((360./365.)*(iday-4.)*radi))**2.
rad_ex = sc*(1.+0.033*cos(2.*pi*iday/365.))*dsinbe
! unit conversion in MJ/m2: rad_ex = rad_ex/1000000.
! unit conversion in J/cm2
rad_ex = rad_ex * 0.0001
if(rad_ex.eq.0) then
sdrel=0.
return
end if
sdrel = (rad - rad_ex*0.19) / (0.55*rad_ex) ! DVWK
if (sdrel .lt. 0.) sdrel = 0.
END SUBROUTINE sunshine
!****************************************************************************
SUBROUTINE evapo_ini
! Initialisierung Potential evapotranspiration PET
use data_evapo
use data_simul
implicit none
character text
character (150) file_eva
write (*,*)
write (*,'(A)', advance='no') 'Read flux data for evaporation, name of input file: '
read (*,'(A)') file_eva
unit_eva = getunit()
open (unit_eva, file=trim(file_eva), status='unknown')
read (unit_eva,'(A)') text
END subroutine evapo_ini
!******************************************************************************