diff --git a/source_code/version2.2_windows/amod_clas.f b/source_code/version2.2_windows/amod_clas.f
new file mode 100755
index 0000000000000000000000000000000000000000..2856cfbfcc950a57ae51db6e320721a6ee127257
--- /dev/null
+++ b/source_code/version2.2_windows/amod_clas.f
@@ -0,0 +1,24 @@
+!*****************************************************************!
+!* *!
+!* 4C (FORESEE) Simulation Model *!
+!* *!
+!* *!
+!* data module data_clas for forest type classification wclas *!
+!* *!
+!* 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_clas
+
+ real, allocatable, dimension(:) :: bpart
+ real lhpar, nhpar, alhpar, alnpar
+
+end module data_clas
diff --git a/source_code/version2.2_windows/amod_clim.f b/source_code/version2.2_windows/amod_clim.f
new file mode 100755
index 0000000000000000000000000000000000000000..7b25575f6713849118124206b51842cd4484ae0d
--- /dev/null
+++ b/source_code/version2.2_windows/amod_clim.f
@@ -0,0 +1,281 @@
+!*****************************************************************!
+!* *!
+!* 4C (FORESEE) Simulation Model *!
+!* *!
+!* climate data modules *!
+!* *!
+!* containes: *!
+!* DATA_CLIMATE *!
+!* DATA_EVAPO *!
+!* DATA_INTER *!
+!* DATA_DEPO *!
+!* *!
+!* 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_climate
+
+! flag defines structure of climate data file
+ integer :: flag_climtyp = 0
+ integer :: i_exit ! day number of first missing data record
+ integer,allocatable,save,dimension(:) :: recs,yy
+ integer,allocatable,save,dimension(:,:) :: dd,mm
+ real,allocatable,save,dimension(:,:) :: tp,hm,prc,prs,rd,wd, tx, tn,vp, sdu,bw, sde
+ real,allocatable,save,dimension(:) :: tpmean
+ real :: airtemp = -99., & ! air temperature (°C)
+ airtemp_1 = -99., & ! air temperature of previous day (°C)
+ airtemp_2 = -99., & ! air temperature of two days before (°C)
+ airtemp_max = -99., & ! maximum air temperature (°C)
+ airtemp_min = -99., & ! minimum air temperature (°C)
+ hum = -99., & ! humidity (%)
+ prec = -99., & ! precipitation (mm)
+ press = -99., & ! pressure (hPa)
+ rad = -99., & ! solar radiation(J/cm2)
+ rad_max = -99., & ! maximal solar radiation(J/cm2)
+ wind = -99., & ! wind velocity (m/s)
+ par_day = -99., & ! photosynth. activ radiation (mol/m2)
+ par_av = -99., & ! average of PAR for PS/NPP model (mol/m2)
+ rnet_tot = -99., & ! total net radiation(J/cm2)
+ avg_incl , & ! average sun inclination [degrees]
+ beta , & ! average sun inclination [radians]
+ dlength = -99., & ! day length == Photoperiode (h)
+ dptemp = -99., & ! dew point temperature
+ co2 = -99. ! atmospheric CO2 content (mol/mol)
+integer :: flag_vegper = 0 ! indicates vegetation period described by temeprature > 10°C
+integer :: flag_tveg = 0
+integer :: iday_vegper = 0
+
+ ! cumulative and mean values per year
+ real :: med_air ! yearly mean air temperature
+ real :: med_air_ms ! average temperature May - September
+ real :: med_air_mj ! avarage temperature May - July
+ real :: sum_prec ! yearly precipitation sum
+ real :: sum_prec_ms ! precipitation sum May - September
+ real :: sum_prec_mj ! precipitation sum may - July
+ real :: med_air_wm ! average temperature of the warmest month
+ real :: med_air_cm ! average temperature of the coldest month
+ real :: med_rad
+ real :: med_rad1 ! annual mean of daily solar radiation of the first year of simulation
+ real :: med_wind
+ real :: gdday ! annual growing degree day
+
+ ! values per month
+ real, dimension(12) :: temp_mon ! mean monthly average air temperature (°C)
+ real, dimension(12) :: prec_mon ! mean monthly precipitation sum (mm)
+ real, dimension(12) :: rad_mon ! mean monthly average of daily radiation (J/cm2)
+ real, dimension(12) :: hum_mon ! mean monthly average daily relative humidity (%)
+ real :: aet_dec ! sum of AET of last december (mm)
+ real :: temp_dec ! mean average air temperature of last december (°C)
+ real :: prec_dec ! precipitation sum of last december (mm)
+ real :: rad_dec ! mean average of daily radiation of last december (J/cm2)
+ real :: hum_dec ! mean average of daily relative humidity of last december (%)
+
+ ! values per week
+ real, dimension(53) :: temp_week ! mean monthly average air temperature (°C)
+ real, dimension(53) :: prec_week ! mean monthly precipitation sum (mm)
+
+! for calculation of long-term monthly means
+ real, dimension(12) :: tempmean_mo ! long-term monthly means
+ real, dimension(12) :: tempmean_mo_a ! annual monthly means
+
+ integer :: days_summer = -99, & ! number of summer days (Tmax > 25°C)
+ days_hot = -99, & ! number of hot days (Tmax > 30°C)
+ days_ice = -99, & ! number of ice days (Tmax < 0°C)
+ days_dry = -99, & ! number of days without precipitation
+ days_hrain = -99, & ! number of days with heavy rain (> 10mm)
+ days_snow = -99, & ! number of days with snow (4C simulation)
+ days_rain = -99, & ! number of days with rain > 0.1 mm
+ days_rain_mj = -99, & ! number of days with rain > 0.1 mm May - July
+ days_wof = -99 ! number of days without frost Tmin > 0°C
+
+ ! total mean values
+ real :: med_air_all ! overall yearly mean air temperature
+ real :: sum_prec_all ! overall mean yearly precipitation sum
+ real :: med_rad_all ! overall mean annual radiation
+ real :: gdday_all ! overlall mean annual growing degree day
+
+ ! monthly climate indices
+ real :: ind_cout_mo ! monthly index Coutange
+ real :: ind_wiss_mo ! monthly index v. Wissmann
+ real :: ind_arid_mo ! monthly Index UNEP
+ real :: cwb_mo ! monthly climate water balance
+
+ ! annual climate indices
+ real :: ind_arid_an ! annual aridity index UNEP
+ real :: cwb_an ! annual climate water balance
+ real :: ind_lang_an ! annual climate index acc. Linsser/Lang
+ real :: ind_cout_an ! annual index Coutange
+ real :: ind_wiss_an ! annual index v. Wissmann
+ real :: ind_mart_an ! annual index Martonne
+ real :: ind_mart_vp ! annual index martonne vegetation period (May- Sept.)
+ real :: ind_emb ! annual index Emberger
+ real :: ind_weck ! annual index Weck
+ real :: ind_reich ! annual index Reichel
+ real :: con_gor ! annual continentality index Gorczynski
+ real :: con_cur ! annual continentality index Currey
+ real :: con_con ! annual continentality index Conrad
+ real :: ind_bud ! annual dryness index Budyko
+ real :: ind_shc ! annual index Seljaninov
+ real :: cwb_an_m ! mean annual climate water balance of simulation period
+
+ ! meann annual climate inidces of the simulation period
+ real :: ind_arid_an_m ! annual aridity index UNEP
+ real :: ind_lang_an_m ! annual climate index acc. Linsser/Lang
+ real :: ind_cout_an_m ! annual index Coutange
+ real :: ind_wiss_an_m ! annual index v. Wissmann
+ real :: ind_mart_an_m ! annual index Martonne
+ real :: ind_mart_vp_m ! annual index martonne vegetation perio (May- Sept.)
+ real :: ind_emb_m ! annual index Emberger
+ real :: ind_weck_m ! annual index Weck
+ real :: ind_reich_m ! annual index Reichel
+ real :: con_gor_m ! annual continentality index Gorczynski
+ real :: con_cur_m ! annual continentality index Currey
+ real :: con_con_m ! annual continentality index Conrad
+ real :: ind_bud_m ! annual dryness index Budyko
+ real :: ind_shc_m ! annual index Seljaninov
+
+ ! values for evaluation of npp module
+ real,allocatable,save,dimension(:) :: tempfield
+ real,allocatable,save,dimension(:) :: globfield
+ real,allocatable,save,dimension(:) :: dayfield
+ real, dimension(5) :: clim_waterb = 0. ! climatic water balance (fire_risk)
+
+ ! Mauna Loa CO2 time series, annual means
+ REAL :: year_CO2 = 2016
+ REAL :: Mauna_Loa_CO2(1959:2016) ! time series of annual mean CO2 measured at Mauna Loa, Hawaii
+ Real :: RCP_2p6(1765:2300)
+ Real :: RCP_6p0(1765:2150)
+
+ DATA Mauna_Loa_CO2 /0.00031598, 0.00031691, 0.00031765, 0.00031845, 0.00031899, &
+ 0.00031952, 0.00032003, 0.00032137, 0.00032218, 0.00032305, &
+ 0.00032462, 0.00032568, 0.00032632, 0.00032746, 0.00032968, &
+ 0.00033025, 0.00033115, 0.00033215, 0.0003339, 0.0003355, &
+ 0.00033685, 0.00033869, 0.00033993, 0.00034113, 0.00034278, &
+ 0.00034442, 0.0003459, 0.00034715, 0.00034893, 0.00035148, &
+ 0.00035291, 0.00035419, 0.00035559, 0.00035637, 0.00035704, &
+ 0.00035888, 0.00036088, 0.00036264, 0.00036376, 0.00036663, &
+ 0.00036831, 0.00036948, 0.00037102, 0.0003731, 0.00037564, &
+ 0.00037738, 0.00037975, 0.00038185, 0.00038372, 0.00038557, &
+ 0.00038738, 0.00038985, 0.00039163, 0.00039382, 0.00039648, &
+ 0.00039861, 0.00040083, 0.00040421/
+ DATA RCP_2p6/278.05,278.11,278.22,278.34,278.47,278.60,278.73,278.87,279.01,279.15,279.30,279.46,279.62,279.78,279.94,280.10,280.24,280.38,280.52,280.66,&
+ 280.80,280.96,281.12,281.28,281.44,281.60,281.75,281.89,282.03,282.17,282.30,282.43,282.55,282.67,282.79,282.90,283.01,283.11,283.21,283.31,283.40,283.49,&
+ 283.58,283.66,283.74,283.80,283.85,283.89,283.93,283.96,284.00,284.04,284.09,284.13,284.17,284.20,284.22,284.24,284.26,284.28,284.30,284.32,284.34,284.36,&
+ 284.38,284.40,284.39,284.28,284.13,283.98,283.83,283.68,283.53,283.43,283.40,283.40,283.43,283.50,283.60,283.73,283.90,284.08,284.23,284.40,284.58,284.73,&
+ 284.88,285.00,285.13,285.28,285.43,285.58,285.73,285.90,286.08,286.23,286.38,286.50,286.63,286.78,286.90,287.00,287.10,287.23,287.38,287.53,287.70,287.90,&
+ 288.13,288.40,288.70,289.03,289.40,289.80,290.23,290.70,291.20,291.68,292.13,292.58,292.98,293.30,293.58,293.80,294.00,294.18,294.33,294.48,294.60,294.70,&
+ 294.80,294.90,295.03,295.23,295.50,295.80,296.13,296.48,296.83,297.20,297.63,298.08,298.50,298.90,299.30,299.70,300.08,300.43,300.78,301.10,301.40,301.73,&
+ 302.08,302.40,302.70,303.03,303.40,303.78,304.13,304.53,304.98,305.40,305.83,306.30,306.78,307.23,307.70,308.18,308.60,309.00,309.40,309.75,310.00,310.18,&
+ 310.30,310.38,310.38,310.30,310.20,310.13,310.10,310.13,310.20,310.33,310.50,310.75,311.10,311.50,311.93,312.43,313.00,313.60,314.23,314.85,315.50,316.27,&
+ 317.08,317.80,318.40,318.93,319.65,320.65,321.61,322.64,323.90,324.99,325.86,327.14,328.68,329.74,330.59,331.75,333.27,334.85,336.53,338.36,339.73,340.79,&
+ 342.20,343.78,345.28,346.80,348.65,350.74,352.49,353.86,355.02,355.89,356.78,358.13,359.84,361.46,363.16,365.32,367.35,368.87,370.47,372.52,374.76,376.81,&
+ 378.81,380.83,382.78,384.80,387.00,389.29,391.56,393.84,396.12,398.40,400.68,402.97,405.25,407.53,409.80,412.07,414.33,416.52,418.60,420.60,422.52,424.35,&
+ 426.10,427.75,429.31,430.78,432.16,433.44,434.59,435.65,436.63,437.52,438.33,439.06,439.69,440.22,440.66,441.02,441.35,441.62,441.86,442.08,442.28,442.46,&
+ 442.60,442.70,442.75,442.76,442.73,442.66,442.55,442.41,442.25,442.08,441.89,441.67,441.42,441.13,440.80,440.43,440.01,439.54,439.05,438.54,438.02,437.48,&
+ 436.92,436.34,435.76,435.18,434.60,434.00,433.38,432.78,432.19,431.62,431.06,430.51,429.96,429.41,428.86,428.30,427.73,427.14,426.57,426.00,425.46,424.94,&
+ 424.43,423.93,423.43,422.93,422.43,421.92,421.40,420.90,420.41,419.95,419.50,419.06,418.62,418.17,417.71,417.25,416.77,416.28,415.80,415.32,414.87,414.42,&
+ 413.99,413.55,413.10,412.64,412.17,411.69,411.19,410.70,410.22,409.76,409.31,408.86,408.42,407.97,407.52,407.07,406.61,406.15,405.69,405.26,404.84,404.45,&
+ 404.07,403.68,403.29,402.90,402.51,402.10,401.69,401.28,400.89,400.53,400.17,399.83,399.49,399.14,398.79,398.43,398.06,397.68,397.31,396.96,396.62,396.30,&
+ 395.99,395.68,395.36,395.03,394.70,394.36,394.00,393.66,393.33,393.02,392.72,392.44,392.14,391.85,391.54,391.23,390.91,390.58,390.26,389.95,389.65,389.38,&
+ 389.11,388.83,388.55,388.27,387.97,387.67,387.35,387.05,386.75,386.48,386.21,385.96,385.70,385.44,385.16,384.88,384.59,384.29,384.00,383.72,383.45,383.20,&
+ 382.96,382.72,382.46,382.20,381.93,381.66,381.37,381.08,380.81,380.56,380.32,380.09,379.86,379.61,379.36,379.11,378.84,378.56,378.29,378.03,377.78,377.56, &
+ 377.33,377.11,376.87,376.63,376.38,376.12,375.85,375.59,375.34,375.11,374.89,374.67,374.45,374.23,373.99,373.75,373.50,373.24,372.98,372.74,372.52,372.30,&
+ 372.10,371.89,371.67,371.44,371.21,370.96,370.71,370.46,370.23,370.01,369.80,369.60,369.40,369.19,368.97,368.74,368.50,368.26,368.02,367.79,367.58,367.38,&
+ 367.18,366.98,366.78,366.57,366.35,366.11,365.87,365.64,365.42,365.21,365.02,364.83,364.64,364.44,364.23,364.02,363.79,363.55,363.32,363.11,362.91,362.72,&
+ 362.54,362.35,362.16,361.95,361.75,361.52,361.29,361.07,360.86,360.67/
+
+ DATA RCP_6p0/ 278.05,278.11,278.22,278.34,278.47,278.60,278.73,278.87,279.01,279.15,279.30,279.46,279.62,279.78,279.94,280.10,280.24,280.38,280.52,280.66,&
+ 280.80,280.96,281.12,281.28,281.44,281.60,281.75,281.89,282.03,282.17,282.30,282.43,282.55,282.67,282.79,282.90,283.01,283.11,283.21,283.31,283.40,283.49,&
+ 283.58,283.66,283.74,283.80,283.85,283.89,283.93,283.96,284.00,284.04,284.09,284.13,284.17,284.20,284.22,284.24,284.26,284.28,284.30,284.32,284.34,284.36,&
+ 284.38,284.40,284.39,284.28,284.13,283.98,283.83,283.68,283.53,283.43,283.40,283.40,283.43,283.50,283.60,283.73,283.90,284.08,284.23,284.40,284.58,284.73,&
+ 284.88,285.00,285.13,285.28,285.43,285.58,285.73,285.90,286.08,286.23,286.38,286.50,286.63,286.78,286.90,287.00,287.10,287.23,287.38,287.53,287.70,287.90,&
+ 288.13,288.40,288.70,289.03,289.40,289.80,290.23,290.70,291.20,291.68,292.13,292.58,292.98,293.30,293.58,293.80,294.00,294.18,294.33,294.48,294.60,294.70,&
+ 294.80,294.90,295.03,295.23,295.50,295.80,296.13,296.48,296.83,297.20,297.63,298.08,298.50,298.90,299.30,299.70,300.08,300.43,300.78,301.10,301.40,301.73,&
+ 302.08,302.40,302.70,303.03,303.40,303.78,304.13,304.53,304.98,305.40,305.83,306.30,306.78,307.23,307.70,308.18,308.60,309.00,309.40,309.75,310.00,310.18,&
+ 310.30,310.38,310.38,310.30,310.20,310.13,310.10,310.13,310.20,310.33,310.50,310.75,311.10,311.50,311.93,312.43,313.00,313.60,314.23,314.85,315.50,316.27,&
+ 317.08,317.80,318.40,318.93,319.65,320.65,321.61,322.64,323.90,324.99,325.86,327.14,328.68,329.74,330.59,331.75,333.27,334.85,336.53,338.36,339.73,340.79,&
+ 342.20,343.78,345.28,346.80,348.65,350.74,352.49,353.86,355.02,355.89,356.78,358.13,359.84,361.46,363.16,365.32,367.35,368.87,370.47,372.52,374.76,376.81,&
+ 378.81,380.83,382.78,384.80,386.93,389.07,391.17,393.24,395.30,397.35,399.39,401.42,403.43,405.43,407.40,409.36,411.30,413.22,415.14,417.08,419.04,421.00,&
+ 422.98,424.95,426.92,428.88,430.83,432.81,434.83,436.92,439.07,441.29,443.57,445.90,448.28,450.70,453.15,455.65,458.18,460.76,463.41,466.12,468.91,471.77,&
+ 474.69,477.67,480.70,483.78,486.92,490.10,493.34,496.64,500.02,503.48,507.02,510.63,514.31,518.03,521.80,525.62,529.49,533.40,537.38,541.44,545.59,549.82,&
+ 554.13,558.49,562.87,567.27,571.70,576.15,580.61,585.10,589.65,594.26,598.92,603.54,608.02,612.36,616.57,620.65,624.58,628.38,632.06,635.65,639.14,642.60,&
+ 646.06,649.52,652.95,656.36,659.75,663.11,666.42,669.72,673.02,676.29,679.50,682.65,685.71,688.69,691.59,694.40,697.11,699.73,702.28,704.76,707.20,709.60,&
+ 711.93,714.21,716.40,718.52,720.56,722.51,724.37,726.16,727.90,729.59,731.24,732.85,734.39,735.86,737.26,738.59,739.83,740.99,742.08,743.12,744.13,745.10,&
+ 746.02,746.88,747.68,748.40,749.05,749.62,750.09,750.51,750.87,751.20,751.49,751.74,751.92,752.00 /
+
+end module data_climate
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+module data_evapo
+ ! evapotranspiration data
+ real :: aet = 0. ! daily total actual evapotranspiration / mm
+ real :: aet_cum = 0. ! yearly total actual evapotranspiration / mm
+ real :: aet_m = 0. ! mean yearly total actual evapotranspiration / mm
+ real :: pet = 0. ! daily total potential evapotranspiration / mm
+ real :: pet_cum = 0. ! yearly total potential evapotranspiration / mm
+ real :: pet_m = 0. ! mean yearly total potential evapotranspiration / mm
+ real :: pev_s = 0. ! potential evaporation of soil / mm
+ real :: pev_sn = 0. ! potential evaporation of snow / mm
+ real :: dew_rime = 0. ! dew or rime resp. / mm
+ real :: dew_cum = 0. ! yearly total dew or rime resp. / mm
+ real :: dew_m = 0. ! mean yearly total dew or rime resp. / mm
+ real :: trans_dem = 0. ! potential transpiration / mm
+ real :: trans_tree= 0. ! actual transpiration of trees / mm
+ real :: trans_sveg= 0. ! actual transpiration of ground vegetation / mm
+ real :: tra_tr_cum= 0. ! yearly transpiration of trees / mm
+ real :: tra_sv_cum= 0. ! yearly transpiration of ground vegetation / mm
+ real :: aev_s = 0. ! actual evaporation of soil / mm
+ real :: aev_i = 0. ! actual evaporation of intercepted water / mm
+ real :: demand_mistletoe_cohort = 0. ! helping variable: transfer of mistletoe demand from evapo.f to soil.f
+
+ REAL, dimension(12) :: aet_mon ! monthly actual evapotranspiration sum / mm
+ REAL, dimension(53) :: aet_week ! weekly actual evapotranspiration sum / mm
+ REAL, dimension(12) :: pet_mon ! monthly potential evapotranspiration sum / mm
+ REAL, dimension(53) :: pet_week ! weekly potential evapotranspiration sum / mm
+
+ real :: Rnet_cum = 0. ! net radiation J/cm²
+ integer:: unit_eva
+
+end module data_evapo
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+module data_inter
+ ! interception data
+ real :: interc_can = 0. ! total daily canopy interception / mm
+ real :: int_st_can = 0. ! canopy interception storage / mm
+ real :: int_cum_can = 0. ! cumulative canopy interception / mm
+ real :: interc_m_can = 0. ! mean yearly canopy interception / mm
+ real :: prec_stand = 0. ! stand precipitation / mm
+ real :: prec_stand_red= 0. ! reduction of stand precipitation by percentage (drought experiments) / %
+ real :: interc_sveg = 0. ! total daily interception of ground vegetation / mm
+ real :: int_st_sveg = 0. ! interception storage of ground vegetation / mm
+ real :: int_cum_sveg = 0. ! cumulative interception of ground vegetation / mm
+ real :: interc_m_sveg= 0. ! mean yearly interception of ground vegetation / mm
+ real :: stem_flow = 0. ! stem flow / mm
+ logical:: lint_snow = .false. ! interception of snow = .true.
+
+end module data_inter
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+module data_depo
+ ! deposition data
+ real,allocatable,save,dimension(:,:) :: NHd, NOd ! input fields / mg N/m2
+ real :: NH_dep = 0. ! deposition of NHx-N / g N/m2
+ real :: NO_dep = 0. ! deposition of NOx-N / g N/m2
+ real :: Ndep_cum = 0. ! yearly cumulative deposition / g N/m2
+ real :: Ndep_cum_all = 0. ! overall mean yearly deposition / g N/m2
+end module data_depo
+
+
+
diff --git a/source_code/version2.2_windows/amod_effect.f b/source_code/version2.2_windows/amod_effect.f
new file mode 100755
index 0000000000000000000000000000000000000000..57d589b4ccb98d7fd6348e11be5a7359e64058cd
--- /dev/null
+++ b/source_code/version2.2_windows/amod_effect.f
@@ -0,0 +1,105 @@
+!*****************************************************************!
+!* *!
+!* 4C (FORESEE) Simulation Model *!
+!* *!
+!* environmental variables and indices *!
+!* *!
+!* containes: *!
+!* DATA_BIODIV *!
+!* DATA_FROST *!
+!* *!
+!* 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_biodiv
+! indices of fire and biodiversity
+
+! sum of hot days (Tmax>=25°C) and precipitation sum in the potential fire period
+integer :: Ndayshot
+real :: Psum_FP
+integer :: prec_flag1 = 0 ! flag is equal 1 if first time precipitation of 5 mm occurs after bud burst of birch
+integer :: prec_flag2 = 0
+
+real :: ntindex ! temperature index
+
+! fire risk
+integer :: fire_indw = -99 ! fire index west
+integer :: fd_fire_indw(1:5) = 0 ! frequency distribution of fore index west values
+integer :: fire_inde = -99 ! fire index east
+integer :: fire_indi_day = 0 ! days with forest fire indicator greater then a threshold (east)
+real :: fire_indi = 0.0 ! forest fire indicator (east)
+real :: fire_indi_max = 0.0 ! maximum forest fire indicator (east)
+real :: fire_indb = -99 ! fire index Bruschek
+real :: fire_indb_m = -99 ! mean yearly fire index Bruschek of simulation period
+real :: tsumrob ! temperature sum 'Robinie'
+real :: day_bb_rob = 0 ! day of budburst 'Robinie'
+real :: tsumbi ! temperature sum birch
+real :: day_bb_bi = 0 ! day of budburst birch
+integer :: day_nest = 0 ! days since the last prec. greater then 3 mm (Nesterov)
+real :: p_nest = 0.0 ! ignition index of Nesterov
+
+type fire_risk
+ integer :: index ! daily fire risk level
+ integer, dimension (5):: frequ ! frequency of of fire risk levels (5 classes) of a year
+ real :: mean ! mean fire risk level of a year
+ real :: mean_m ! mean yearly fire risk level of simulation period
+end type fire_risk
+
+type (fire_risk),dimension(3) :: fire ! 1 - fire index west
+ ! 2 - fire index east (M68 international)
+ ! 3 - fire index Nesterov
+
+! upper limit of climatic water balance for fire risk class (west)
+real, dimension(4,7) :: risk_class
+DATA risk_class &
+ / 5., -3., -9., -15., & ! march
+ 3., -8., -16., -27., & ! april
+ -3., -16., -25., -35., & ! may
+ -12., -24., -32., -41., & ! june
+ -12., -24., -31., -40., & ! july
+ -8., -20., -28., -37., & ! august
+ -6., -18., -26., -35./ ! september
+
+integer, dimension(38) :: daybb_rob
+integer, dimension(38) :: daybb_bi
+DATA daybb_bi/100,114,115,113,120,115,111,109,123,124,113,110,119,99,117,117,118,117,120,124,101,117,113,117,112,119,116,112, &
+ 102,92,106,109,109,110,111,112,112,101/
+
+
+DATA daybb_rob/152,165,156,151,166,148,153,153,160,163,151,161,160,163,159,161,162,158,153,163,153,153,154,159,151,152,166,154, &
+ 147,143,168,145,135,148,151,155,155,138/
+
+end module data_biodiv
+
+module data_frost
+
+integer, allocatable, save, dimension(:) :: dnlf ! number of days with late frost during vegetation period
+real, allocatable, save, dimension (:) :: tminmay_ann ! minimum temperature in may
+integer, allocatable, save, dimension(:) :: date_lf ! date of last frost after start of vegetation period per year
+integer, allocatable, save, dimension(:) :: date_lftot ! annual date of last frost event
+integer, allocatable, save, dimension(:) :: anzdlf ! number of days with frost from April until June
+integer, allocatable, save, dimension(:) :: sumtlf ! sum of temperature of days with frost from April until June
+integer :: dlfabs ! number of day of the last frost for the whole simulation period
+real :: tminmay ! minimum temperature of may of the whole simulation period
+integer, allocatable, save, dimension(:) :: dnlf_sp ! number of day with late frost during vegetation period
+integer :: dlfabs_sp ! number of day of the last frost for the whole simulation period
+real :: tminmay_sp ! minimum temperature of may of the whole simulation period
+
+real :: temp_frost = 0. ! temperature threshold of frost
+integer :: lfind ! last frost index
+real :: mlfind ! mean lfind
+integer :: maxlfind ! maximum value of 5 part inidces
+integer :: lfind_sp ! last frost index birch
+integer :: maxlfind_sp ! last frost index beech
+real :: mlfind_sp ! mean lfind
+integer :: taxnum
+end module data_frost
+
diff --git a/source_code/version2.2_windows/amod_help.f b/source_code/version2.2_windows/amod_help.f
new file mode 100755
index 0000000000000000000000000000000000000000..d97c3dacc2a20315c6de9949227ff99691a3dc22
--- /dev/null
+++ b/source_code/version2.2_windows/amod_help.f
@@ -0,0 +1,41 @@
+!*****************************************************************!
+!* *!
+!* 4C (FORESEE) Simulation Model *!
+!* *!
+!* *!
+!* data module *!
+!* data_help *!
+!* data_help_dbh *!
+!* *!
+!* Copyright (C) 1996-2018 *!
+!* Potsdam Institute for Climate Impact Reserach (PIK) *!
+!* Authors and contributors see AUTHOR file *!
+!* This file is part of 4C and is licensed under BSD-2-Clause *!
+!* See LICENSE file or under: *!
+!* http://www.https://opensource.org/licenses/BSD-2-Clause *!
+!* Contact: *!
+!* https://gitlab.pik-potsdam.de/foresee/4C *!
+!* *!
+!*****************************************************************!
+Module data_help
+
+integer :: hnspec=0 ! species number
+
+real :: mschelp ! weight of seed class
+real ::heihelp ! height of plant class
+REAL :: x_sap,x_hrt,x_fol,x_frt,x_Ahb !inital values for cohorts
+integer :: fail
+end module data_help
+
+
+module data_help_dbh
+
+! for function in calc_dbh
+
+real :: fAhb = 0., & ! cross sectional area heartwood at tree base
+ fB = 0., & ! bole height,
+ fH = 0., & ! heartwood
+ fHt = 0., & ! total tree height
+ fsprhos
+
+end module data_help_dbh
diff --git a/source_code/version2.2_windows/amod_init.f b/source_code/version2.2_windows/amod_init.f
new file mode 100755
index 0000000000000000000000000000000000000000..6411f3a0290f1bdcec2d8c578d90b9b899a97451
--- /dev/null
+++ b/source_code/version2.2_windows/amod_init.f
@@ -0,0 +1,84 @@
+!*****************************************************************!
+!* *!
+!* 4C (FORESEE) Simulation Model *!
+!* *!
+!* *!
+!* module data_init *!
+!* declaration of variables for additional information *!
+!* used during initialisation *!
+!* *!
+!* 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_init
+
+IMPLICIT NONE
+
+ INTEGER :: spec_nrDSW(120) ! species ordinal number in DSW according to BRA
+ INTEGER :: spec_nrBAY(120) ! species ordinal number in Bavaria
+ INTEGER :: spec_4C(120) ! species code number of 4C assigned to DSW species
+ CHARACTER (3) :: spec_code(120) ! specifies three letter code in DSW according to BRA
+ CHARACTER (50) :: GER_name(120) ! german name
+ CHARACTER (50) :: LAT_name(120) ! scientific, latin name
+ CHARACTER (50) :: ENG_name(120) ! english name
+ INTEGER :: spnum_for_DSW(800) ! species ordinal number (1..120) for DSW in element of vector
+ ! which corresponds to species number according to BRA
+
+ ! variables for treatment of DSW initialisation data
+ TYPE group_vec
+ INTEGER :: locid ! ID for stand
+ INTEGER :: taxid ! 4C species number
+ INTEGER :: BRAid ! DSW species code
+ INTEGER :: alter
+ INTEGER :: baumzahl
+ INTEGER :: schicht ! 10 = upper storey trees/Oberstand, 20 = retention trees/Überhälter, 40 = understorey 50 = selction/plenter forest/ plenterartig
+ REAL :: dm
+ REAL :: mhoe
+ REAL :: gf
+ REAL :: patchsize
+ REAL :: standsize
+ REAL :: volume
+ END TYPE group_vec
+ TYPE(group_vec), DIMENSION(:), ALLOCATABLE :: ngroups
+
+ ! variables for plenterwald initialisation
+ INTEGER, DIMENSION(4) :: low_age, high_age
+
+ ! Parameter for volume functions provided by Eberswalde
+ REAL, DIMENSION (10,3) :: parEBW
+ ! Parameter Pine (Kiefer) EBERSWALDE
+ DATA parEBW(10,1:3)/-9.780614,1.96047,0.89443/
+ ! Parameter Ponderosa pine taken equal to Pine (Kiefer) EBERSWALDE
+ DATA parEBW(10,1:3)/-9.780614,1.96047,0.89443/
+
+ ! Parameter for volume function adapted from SILVA
+ REAL, dimension (11,9) :: par_S
+ ! Paramter Fichte/spruce SILVA
+ DATA par_S(2,1:9)/-3.59624,1.80213,-0.288243, 1.06247, -0.128993, 0.0353434, 0.142264, -0.058259, 0.00459854/
+ ! Parameter Buche/beech SILVA
+ DATA par_S(1,1:9)/-2.7284,0.837563,-0.105843,1.62283,-0.214812,0.0289272,-0.0879719,0.0325667,-0.00446295/
+ ! Parameter Eiche/oak SILVA
+ DATA par_S(4,1:9)/-3.06118,1.45506,-0.19992,1.93898,-0.689727,0.112653,-0.165102,0.120127,-0.0202543/
+ ! Parameter Kiefer/ pine SILVA
+ DATA par_S(3,1:9)/-5.80915,3.387,-0.494392,3.67116,-1.83211,0.273999,-0.459282,0.29989,-0.0444931/
+ ! Parameter Birke/birch SILVA = Weichlaub
+ DATA par_S(5,1:9)/-5.98031,2.65905,-0.3374,3.78395,-1.47318,0.188661,-0.540955,0.296957,-0.0385165/
+ ! Parameter Pinus contorta (von Kiefer)
+ DATA par_S(6,1:9)/ -5.80915,3.387,-0.494392,3.67116,-1.83211,0.273999,-0.459282,0.29989,-0.0444931/
+ ! Parameter Pinus ponderosa (von Kiefer)
+ DATA par_S(7,1:9)/ -5.80915,3.387,-0.494392,3.67116,-1.83211,0.273999,-0.459282,0.29989,-0.0444931/
+ ! parameter Populus tremula
+ DATA par_S(8,1:9)/ -5.98031,2.65905,-0.3374,3.78395,-1.47318,0.188661,-0.54095500,0.296957,-0.03851650/
+ ! parameter Robinie( black locust)
+ DATA par_S(11,1:9)/-2.7284,0.837563,-0.105843,1.62283,-0.214812,0.0289272,-0.0879719,0.0325667,-0.00446295/
+
+
+END ! module data_init
diff --git a/source_code/version2.2_windows/amod_manag.f b/source_code/version2.2_windows/amod_manag.f
new file mode 100755
index 0000000000000000000000000000000000000000..9a927a5011e352fa36a38fc164272e0aee179c09
--- /dev/null
+++ b/source_code/version2.2_windows/amod_manag.f
@@ -0,0 +1,136 @@
+!*****************************************************************!
+!* *!
+!* 4C (FORESEE) Simulation Model *!
+!* *!
+!* *!
+!* data module management SR *!
+!* *!
+!* 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_manag
+
+real :: basarea_tot ! total basal area
+real :: tardiam_dstem=15. ! diameter target for dead stems to C_opm_stems
+
+integer :: thin_type ! type of management scenario
+integer :: thin_nr ! Number of thinnings (years with management actions)
+integer :: act_thin_year ! year field index of thinning
+integer :: target_type ! type of thinning in case of target thinning
+integer,allocatable,save,dimension(:) :: thin_year ! Field of management years
+integer,allocatable,save,dimension(:) :: thin_age ! stand age of target thinning
+integer,allocatable,save,dimension(:) :: thin_tree ! number of remaining stems after thinning
+integer,allocatable,save,dimension(:) :: thin_spec ! species number for thinning (target)
+integer,allocatable,save,dimension(:) :: thin_tysp ! type of thinning (for target thinning)
+real, allocatable,save,dimension(:) :: target_mass ! target value of stem mass
+integer,allocatable,save,dimension(:) :: thinyear ! year of last thinning
+integer, allocatable, save, dimension(:) :: thin_stor ! information of storey which hase to manage
+real,allocatable,save,dimension(:) :: np_mod ! multiplier for 'Nutzungsprozent'
+integer :: thin_dead = 0 ! 0 dead stembiomass is accumulated in litter pools
+ ! 1 dead stem biomass is removed as harvested
+integer :: domspec ! dominant species of initialised stnad for management
+integer :: domspec_reg ! dominant species of regenerated/planted stand after clear cut/shelterwood
+
+real :: stump_sum= 0
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+! thinning types
+! 1 - Niederdurchforstung (mäßig) low thinning ( moderate)
+! 2 - Niederdurchforstung (stark) low thinning (heavy)
+! 3 - Hochdurchforstung crown thinning
+! 4 - Auslesedurchforstung selective thinning
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+real :: ho1=0. ! dominant height first thinning
+real :: ho2=0. ! dominant height second thinning
+real :: ho3=0. ! dominant height third thinning
+real :: ho4=0. ! dominant height fourth thinning
+integer :: thr1=0 ! thinning regime for ho2
+integer :: thr2=0 ! thinning regime for ho3
+integer :: thr3=0 ! thinning regime for ho4
+integer :: thr4=0 ! thinning regime for ho>ho4
+integer :: thr5=0 ! 'Rückegassen'
+real :: thr6=0. ! if thr5=1 this flag control time of realization =ho1,ho2,ho3 or ho4
+integer :: thr7=0 ! management regime for rotation year
+integer :: mgreg=0 ! regeneration, natural/artificial
+integer :: thin_ob ! control of optimal basal area thinning, =1 yes, =0 no
+real :: optb= 1. ! optimal 'Bestockungsgrad'
+integer :: thinonce =0 ! special case of managemnet for only one single management activity; default=0
+integer, allocatable,save,dimension(:) :: thin_flag1 ! aux. varaibles for adaptive management
+integer, allocatable,save,dimension(:) :: thin_flag2
+integer, allocatable,save,dimension(:) :: thin_flag3
+integer, allocatable,save,dimension(:) :: thin_flag4
+real, allocatable, save, dimension(:) :: zbnr ! number of 'Zielbäume'/target trees
+
+real, allocatable, save, dimension(:) :: tend ! percentage of young tree tending/'tending of plantations'
+integer, allocatable,save,dimension(:) :: rot ! rotation
+integer, allocatable, save, dimension(:) :: regage ! age of natural/planted regeneration
+integer :: flag_direct=0 !
+integer :: thinstep=0 ! number of years between thinning if ho>ho4
+integer :: flag_brush=1 ! defaul, if 1 then all harvested stems remain in the litter and are not removed from the stand
+integer :: cutyear =0 ! year of cutting
+real :: direcfel=0. ! percentage display of 'Rückegassen' creation 'directional felling'
+real :: limit=0. ! limit für hight query (+- range)
+
+integer :: shelteryear=0 ! year of last shelterwood mang.
+integer :: stand_age =0 ! age of stand
+integer :: flag_manreal=0 ! management no/yes
+integer :: flag_shelter = 0! shelterwood management started
+integer :: flag_sh_first=0 ! aux variable for the case age(1) > regage and age(1)> rotage-20
+integer :: flag_plant_shw = 0 ! flag for planting in specieal case trhat initial age is > rot-20
+character(30) :: maninf ! description of measure
+integer :: meas ! flag of measure
+! parameter for thinning depending on age ang stand density : percent of using
+real, dimension(20,20) :: usp
+
+! multi-species management
+integer,allocatable,save,dimension(:) :: specnr, age_spec,anz_tree_spec
+
+! Austrian management
+integer,dimension(10) :: num_rel_cl ! number of relative diameter classes
+integer :: num_man ! total numbe rof management treatments
+integer, allocatable, save, dimension(:) :: yman ! years of management for each species
+integer, allocatable, save, dimension(:) :: dbh_clm ! number of relative dbh class wihich is used for thinning
+integer, allocatable, save, dimension(:) :: spec_man ! number of species for treatment
+real, allocatable, save, dimension(:) :: rem_clm ! removal of biomass
+integer, allocatable, save, dimension(:) :: act ! activity flag
+real, allocatable,save, dimension(:) :: rel_part ! mixture flag for planting
+
+! disturbance management
+integer, allocatable, save, dimension(:) :: dis_id ! number of standid with disturbance
+integer :: dis_row_nr ! the total number of disturbance events (line number of disturbance section)
+integer, dimension(1:6,1:2) :: dis_control ! array which is used to control the dirsturbance simulation (dim1=disturbance type(D,X,P,R,S), dim2=zeile man-file)
+character(1), allocatable, save, dimension(:) :: dis_type ! disturbance type D - defoliator, X - xylem clogger, P - phloem feeder
+ ! R - root pathogen or feeder, S - stem rot
+integer, allocatable, save, dimension(:) :: fortype ! forest type 1 managed forest, 2 - naturla forest
+integer, allocatable, save, dimension(:) :: dis_year ! date of disturbance
+integer, allocatable, save, dimension(:) :: dis_spec ! disturbed tree species
+integer, allocatable, save, dimension(:) :: dis_start ! start of disturbance within year
+real, allocatable, save, dimension(:) :: dis_rel ! relative value of disturbed area
+real, allocatable,save, dimension(:) :: sum_dis ! accumulated value of disturbed area (relative), for each standid
+real, allocatable, save, dimension(:) :: dis_year_id ! year of last disturbance for each standid
+integer ::dis_number
+integer :: count_dis_real =0 ! counter for realised disturbances
+
+! aspen managment
+integer :: nsprout = 3 ! number of sprouts per tree
+integer :: flag_sprout = 0 ! 0 - sprouting 1-if sprouts exist
+
+! liocourt management
+real :: dbh_max ! maximum diameter
+real :: lic_a ! parameter a of licourt function
+real :: lic_b ! parameter b of licourt function
+real :: thin_proc ! volume removal percent
+integer :: spec_lic ! species number für li management
+integer :: thin_int ! thinning interval
+integer, dimension(22,11) :: ntree_lic ! filed for calculation of licourt function for species i and diamter class j
+
+end module data_manag
diff --git a/source_code/version2.2_windows/amod_mess.f b/source_code/version2.2_windows/amod_mess.f
new file mode 100755
index 0000000000000000000000000000000000000000..667e302178c43cc1aea02bd8d7134a465ecc01c5
--- /dev/null
+++ b/source_code/version2.2_windows/amod_mess.f
@@ -0,0 +1,86 @@
+!*****************************************************************!
+!* *!
+!* 4C (FORESEE) Simulation Model *!
+!* *!
+!* *!
+!* data module for statistics with observed and simulated 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 data_mess
+
+character(150):: dirmess = 'mess/' ! directory of files with measurements
+
+integer:: anz_mesf = 1 ! amount of measurement files
+character(150),allocatable,dimension(:) :: mesfile ! name of files with measurements
+
+logical:: flag_mess ! TRUE: measurements within the simulation period / FALSE: no measurements
+
+integer:: unit_cons ! console unit
+integer:: unit_stat ! output unit for statistical analysis
+integer:: unit_mess = -99 ! unit of file with measurements
+integer:: unit_mout = -99 ! output unit of file with measurements and residuals
+integer unitday, unitsum, unitlit, unittemp, unitwater, unitsoil, unitsoilini, unitcbal, &
+ unitveg, unitveg_pi, unitveg_sp, unitveg_bi
+integer,allocatable,save,dimension(:) :: unit_mon ! array of output unit numbers for monthly values
+integer,allocatable,save,dimension(:) :: unit_mon_stat ! array of output unit numbers for statistics of monthly values
+
+integer imkind, & ! amount of read maesurement value typs
+ tkind, & ! chronological resolution of measurement values( 1 - Tage
+ ! 2 - Jahre)
+ imess, & ! amount of read measuerment values
+ anz_val, & ! amount of filled in measurement values
+ imk_nme, & ! amount of measurment numbers for mean value calculation NME
+ imk_nmae, & ! amount of measure numbers for mean value calculation NMAE
+ imk_nrmse, & ! amount of measure numbers for mean value calculation NRMSE
+ imk_rsq ! amount of measure numbers for mean value calculations RSQ
+
+real,allocatable,dimension(:,:):: mess1, mess2, sim1, help2
+integer,allocatable,dimension(:,:):: mtz ! arry for dates of measurements: day of the year, year
+integer,allocatable,dimension(:,:):: help1, stz
+integer,allocatable,dimension(:):: app
+
+real:: &
+ nme_av, & ! Average normalised mean error
+ nmae_av, & ! Average normalised mean absolut error
+ nrmse_av, & ! Average normalised root mean square error
+ pme_av, & ! Average mean precental error
+ prmse_av, & ! Average mean squared percental error
+ tic_av, & ! Average Theil's inequality coefficient
+ meff_av, & ! Average modell efficiency
+ rsq_av ! Average coefficient of determination
+
+
+type res_struct
+ character(15) :: mkind ! measurement value type
+ integer :: imes ! amount of measurement value
+ integer :: tkind ! chronological resolution of measurement values
+ integer,pointer,dimension(:):: day, year
+ real,pointer,dimension(:) :: resid
+ real,pointer,dimension(:) :: sim
+ real,pointer,dimension(:) :: mess
+end type res_struct
+
+type (res_struct),allocatable,dimension(:),target :: val
+
+integer:: ikind = 50 ! amount of allowed measurement value types
+integer:: fkind = 0 ! amount of not defined measurement value types
+
+character(10), dimension(50):: sim_kind
+
+integer, dimension(80):: mpos1, mpos2 ! position of measurement value in input file
+integer, dimension(80):: spos1, spos2 ! position of variables in simulations output
+integer, dimension(80):: opos1, opos2 ! position of variables in simulation output file
+
+end module data_mess
+
+!**************************************************************
+
diff --git a/source_code/version2.2_windows/amod_out.f b/source_code/version2.2_windows/amod_out.f
new file mode 100755
index 0000000000000000000000000000000000000000..a002f94a5a8cfa01dcc805e2df7c840858643819
--- /dev/null
+++ b/source_code/version2.2_windows/amod_out.f
@@ -0,0 +1,557 @@
+!*****************************************************************!
+!* *!
+!* 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
+
+!**************************************************************
+
diff --git a/source_code/version2.2_windows/amod_par.f b/source_code/version2.2_windows/amod_par.f
new file mode 100755
index 0000000000000000000000000000000000000000..79956536be099674262f11e9fed6925e47783d7c
--- /dev/null
+++ b/source_code/version2.2_windows/amod_par.f
@@ -0,0 +1,94 @@
+!*****************************************************************!
+!* *!
+!* 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
+
+
+! set of characters
+character(len=*), parameter :: charset = &
+ "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789.-_"
+
+end module data_par
diff --git a/source_code/version2.2_windows/amod_plant.f b/source_code/version2.2_windows/amod_plant.f
new file mode 100755
index 0000000000000000000000000000000000000000..07fdafce6aea5116f4641cb50f8296be27a3eca9
--- /dev/null
+++ b/source_code/version2.2_windows/amod_plant.f
@@ -0,0 +1,42 @@
+!*****************************************************************!
+!* *!
+!* 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
+
diff --git a/source_code/version2.2_windows/amod_simul.f b/source_code/version2.2_windows/amod_simul.f
new file mode 100755
index 0000000000000000000000000000000000000000..ccaeb954f02a04fcc5455d39e4ea55289c94abe5
--- /dev/null
+++ b/source_code/version2.2_windows/amod_simul.f
@@ -0,0 +1,258 @@
+!*****************************************************************!
+!* *!
+!* 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_forska = 0 ! 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
diff --git a/source_code/version2.2_windows/amod_site.f b/source_code/version2.2_windows/amod_site.f
new file mode 100755
index 0000000000000000000000000000000000000000..8b5885d7af997d563b875b6e99ed4bdd4abacd12
--- /dev/null
+++ b/source_code/version2.2_windows/amod_site.f
@@ -0,0 +1,43 @@
+
+!*****************************************************************!
+!* *!
+!* 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
+
diff --git a/source_code/version2.2_windows/amod_soil.f b/source_code/version2.2_windows/amod_soil.f
new file mode 100755
index 0000000000000000000000000000000000000000..40518d1d1960a92c118fddb9590b12a1b40c74bd
--- /dev/null
+++ b/source_code/version2.2_windows/amod_soil.f
@@ -0,0 +1,432 @@
+!*****************************************************************!
+!* *!
+!* 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
+! dp_rfr ! depth of root fraction / cm
+! 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 ! calculation of soil surface temperature
+ ! 0 - old version
+ ! 1 - new ersion 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, & ! Faltungskoeff.
+ 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
diff --git a/source_code/version2.2_windows/amod_spec.f b/source_code/version2.2_windows/amod_spec.f
new file mode 100755
index 0000000000000000000000000000000000000000..6382ab19367518f94c2710e590b130e98008b5e3
--- /dev/null
+++ b/source_code/version2.2_windows/amod_spec.f
@@ -0,0 +1,167 @@
+!*****************************************************************!
+!* *!
+!* 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
diff --git a/source_code/version2.2_windows/amod_stand.f b/source_code/version2.2_windows/amod_stand.f
new file mode 100755
index 0000000000000000000000000000000000000000..11d3c0308a94a66821a73052351d597ebe84ebb2
--- /dev/null
+++ b/source_code/version2.2_windows/amod_stand.f
@@ -0,0 +1,630 @@
+!*****************************************************************!
+!* *!
+!* 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 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 [-]
+
+ ! auxiliary variables
+ REAL :: bes ! avarage beset or press of cohort
+ REAL :: med_sla ! average cohort specific leaf area [m²/kg]
+! REAL,dimension(300) :: l_sla ! specific leaf area per layer [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 ! resp leaf respiration rate [kg DW/d/patch] !!! not a tree variable
+ ! resp
+ REAL :: netAss ! netAss realized net assimilation rate [kg DW/d]
+ ! netAss
+ REAL :: NPP ! NPP NPP [kg DW/yr]
+ ! NPP
+ REAL :: weekNPP ! weekNPP weekly NPP [kg DW/yr]
+ ! weekNPP
+ REAL :: NPPpool
+ REAL :: t_leaf ! t_leaf leaf area per tree [m2]
+ ! t_leaf
+ REAL :: geff ! geff growth efficiency [kg stem DM/(yr*m2)]
+ ! geff
+ REAL :: Asapw ! Asapw tree sapwood cross sectional area in bole space [cm2]
+ REAL :: crown_area ! 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 ! BG fraction of the patch covered by the
+ ! tree in each layer, may change through the layers.
+ ! BG
+ REAL,dimension(0:300) :: leafArea ! leafArea leaf area per layer [m2]
+ ! leafArea
+ REAL,dimension(0:300) :: sleafArea ! sleafArea leaf area per layer [m2], stocked
+ ! leafArea
+ REAL,dimension(0:300) :: FPAR ! 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 [-]
+ ! FPAR
+ REAL,dimension(0:300) :: antFPAR ! antFPAR fraction of totFPAR per crown layer
+ ! antFPAR
+ REAL,dimension(0:300) :: Irel ! Irel relative incident radiation
+ ! intensitiy at the top of a given layer
+ ! Irel
+ REAL :: totFPAR ! totFPAR total fraction of PAR absorbed [-],
+ ! per m² patch area!
+ ! totFPAR
+ REAL :: IrelCan ! IrelCan the relative light regime in the
+ ! middle of the cohort's canopy
+ ! IrelCan
+ INTEGER :: botLayer ! botLayer number of bottom layer of crown [-]
+ ! botLayer
+
+ INTEGER :: topLayer ! topLayer number of top layer of crown [-]
+ ! topLayer
+ REAL :: survp ! servp survival probability first 5 years of
+ ! simulation
+ ! survp
+ REAL :: rel_fol ! rel_fol relative part foliage of cohort
+ ! rel_fol
+ ! new aux. variables (model test)
+ REAL :: gfol ! gfol gross growth rate foliage
+ ! gfol
+ REAL :: gfrt ! gfrt gross growth rate fine root
+ ! gfrt
+ REAL :: gsap ! gsap gross growth rate sap wood
+ ! gsap
+ REAL :: sfol ! sfol senescence rate foliage
+ ! sfol
+ REAL :: sfrt ! sfrt senescence rate fine root
+ ! sfrt
+ REAL :: ssap ! ssap senescence rate sap wood
+ ! ssap
+ REAL :: grossass ! grossass gross assimilation rate [kg DW/yr]
+ ! grossass
+ REAL :: maintres ! maintres cumulative maintenance respiration (sap + frt) [kg DW/yr]
+ ! maintres
+ REAL :: respsap ! respsap daily respiration rate sapwood [kg DW/d]
+ ! respsap
+ REAL :: respfrt ! respfrt daily respiration rate fine root [kg DW/d]
+ ! respfrt
+ REAL :: respfol ! maintenance daily leaf respiration [kg DW/d]
+ !
+ REAL :: respbr ! respbra daily respiration rate branches, c. roots .... [kg DW/d]
+ ! respbr
+ REAL :: respaut ! daily autotrophic respiration rate of tree .... [kg DW/d]
+ !
+ REAL :: resphet ! daily hetrotrophic respiration rate of tree .... [kg DW/d]
+ !
+! new aux. variables for calculation of crown_area of new established trees
+
+ REAL :: height_ini ! height_ini initial value of height of a new established tree cohort by ingrowth [cm]
+ ! hei_ini
+ REAL :: ca_ini ! ca_ini initial value of crown area of a new established tree cohort by ingrowth [m2]
+ ! ca_ini
+! new aux. variables for mAustrian management by relatice diamter class
+
+ INTEGER :: rel_dbh_cl ! rel_dbh_cl relative DBH class
+ ! rel_dbh_cl
+ INTEGER :: underst ! underst 0 = overstorey, 1 = seedling cohort, 2 = understorey
+ ! underst
+ INTEGER :: sprout ! sprout 0 = tree is no sprout, 1 = sprout
+ ! underst
+
+ INTEGER :: fl_sap ! sapling = 0, tree = 1
+
+ ! growth-mortality coupling variables
+ REAL :: fol_inc ! fol_inc foliage increment [kg DW/yr]
+ ! fol_inc
+ REAL :: fol_inc_old ! fol_inc_old foliage increment of last year[kg DW/yr]
+ ! fol_inc_old
+ REAL :: bio_inc ! bio_inc net biomass increment [kg DW/yr]
+ ! bio_inc
+ REAL :: stem_inc ! stem_inc stem wood increment [kg DW/yr]
+ ! stem_inc
+ REAL :: frt_inc ! frt_inc fine root wood increment [kg DW/yr]
+ ! frt_inc
+ logical :: notViable ! notViable .TRUE. if non-biological tree dimensions occur
+ ! notViable
+ integer :: flag_vegend=0
+
+ ! plant-soil water coupling variables
+ REAL,dimension(0:300):: intcap ! intcap precipitation absorbed by
+ ! each layer per m² patch area [mm]
+ ! intcap
+ REAL,dimension(0:300):: prel ! prel precipitation
+ ! at the top of a given layer [mm] per m² patch area
+ ! prel
+ REAL :: interc ! interc total intercepted precipitation [mm],
+ ! per m² patch area!
+ ! interc
+ REAL :: prelCan ! prelCan the relative precipitaion regime
+ ! in the middle of the cohort's canopy
+ ! prelCan
+ REAL :: interc_st ! interc_st interception storage [mm/m2]
+ ! interc_st
+ REAL :: aev_i ! aev_i actual evaporation of intercepted water [mm]
+ ! aev_i
+ REAL :: demand ! demand daily demand for soil water of cohort [mm/day]
+ ! demand
+ REAL :: supply ! supply daily uptake of soil water by roots of cohort [mm/day]
+ ! supply
+ REAL :: watuptc ! supply yearly total uptake of soil water by roots [mm/day]
+ ! supply
+ REAL :: watleft ! watleft yearly total water left in soil layer next to last rooted soil layer [mm]
+ ! watleft
+ REAL :: gp ! gp unstressed stomatal conductance [mol/(m2*d)]
+ ! gp
+ REAL :: drIndd ! drIndd daily drought index [-]
+ ! drIndd
+ REAL :: drIndPS ! drIndPS drought index for photosynthesis calculation (cum.) [-]
+ ! drIndPS
+ REAL :: nDaysPS ! nDaysPS number of growing season days per time step of PS model [-]
+ ! nDaysPS
+ REAL :: drIndAl ! drIndAl drought index for allocation calculation (cum.) [-]
+ ! drIndAl
+ INTEGER :: nDaysGr ! nDaysGr number of growing season days per year [#]
+ ! nDaysGr
+ logical :: isGrSDay ! isGrSDay is the current day a growing season day?
+ ! isGrSDay
+
+ ! 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 ! LA leaf area in a given layer [m²]
+ ! LA
+ REAL :: cumLAI ! cumLAI cumulative leaf area index at the bottom of a given layer [m²/m²]
+ ! cumLAI
+ REAL :: radFrac ! radFrac fraction of total radiation absorbed in a given layer [-]
+ ! radFrac
+ REAL :: sumBG ! sumBG sum of all crown areas in a layer [m²]
+ ! sumBG
+ REAL :: Irel ! 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
+ ! Irel
+
+ 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
+
+
+
diff --git a/source_code/version2.2_windows/amod_tisort.f b/source_code/version2.2_windows/amod_tisort.f
new file mode 100755
index 0000000000000000000000000000000000000000..5d8419e1fe16ad8443a3b7eb7acf94ffc98f2988
--- /dev/null
+++ b/source_code/version2.2_windows/amod_tisort.f
@@ -0,0 +1,81 @@
+!*****************************************************************!
+!* *!
+!* 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
diff --git a/source_code/version2.2_windows/amod_wpm.f b/source_code/version2.2_windows/amod_wpm.f
new file mode 100755
index 0000000000000000000000000000000000000000..028ab2ef5e462ddd7b1024ebde69e025fb8db5e1
--- /dev/null
+++ b/source_code/version2.2_windows/amod_wpm.f
@@ -0,0 +1,677 @@
+!*****************************************************************!
+!* *!
+!* 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
diff --git a/source_code/version2.2_windows/aspen_manag.f b/source_code/version2.2_windows/aspen_manag.f
new file mode 100755
index 0000000000000000000000000000000000000000..733cbd977c3ac03797cd233f01c80cc76a34ff8c
--- /dev/null
+++ b/source_code/version2.2_windows/aspen_manag.f
@@ -0,0 +1,292 @@
+!*****************************************************************!
+!* *!
+!* 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
diff --git a/source_code/version2.2_windows/aust_manag.f b/source_code/version2.2_windows/aust_manag.f
new file mode 100755
index 0000000000000000000000000000000000000000..2017dac560af82d8388d56d6191999c6e9830e1a
--- /dev/null
+++ b/source_code/version2.2_windows/aust_manag.f
@@ -0,0 +1,529 @@
+!*****************************************************************!
+!* *!
+!* 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
diff --git a/source_code/version2.2_windows/calc_climdriv.f b/source_code/version2.2_windows/calc_climdriv.f
new file mode 100755
index 0000000000000000000000000000000000000000..2196cf4cc9408c5f8dacbf592bef6fb28a94de2f
--- /dev/null
+++ b/source_code/version2.2_windows/calc_climdriv.f
@@ -0,0 +1,444 @@
+!*****************************************************************!
+!* *!
+!* 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 66°33'36'' N/SL
+!
+USE data_par
+USE data_simul
+
+real d, xlatitude, del, ws, ws2
+!
+! Equator from 0,2° respectively 0°12'
+!
+IF (abs(xlatitude).lt.0.0024) then
+ photoper=12.0
+ return
+ENDIF
+!
+!pole surrounding ab 89,8° bzw 89°48'
+!
+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
+
+
+
+
+
+
diff --git a/source_code/version2.2_windows/canopy.f b/source_code/version2.2_windows/canopy.f
new file mode 100755
index 0000000000000000000000000000000000000000..0938b0b970f9c44b17865b2318a53dc5f3d19da8
--- /dev/null
+++ b/source_code/version2.2_windows/canopy.f
@@ -0,0 +1,1917 @@
+!*****************************************************************!
+!* *!
+!* 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_GEOMETRY *!
+!**********************************!
+
+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
diff --git a/source_code/version2.2_windows/crown.f b/source_code/version2.2_windows/crown.f
new file mode 100755
index 0000000000000000000000000000000000000000..7dbc460b879cd0480878c819fbe9bb226bce971c
--- /dev/null
+++ b/source_code/version2.2_windows/crown.f
@@ -0,0 +1,59 @@
+!*****************************************************************!
+!* *!
+!* 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
diff --git a/source_code/version2.2_windows/daily.f b/source_code/version2.2_windows/daily.f
new file mode 100755
index 0000000000000000000000000000000000000000..6c8ad3241d2517143fbb4522c9260edd848cdc40
--- /dev/null
+++ b/source_code/version2.2_windows/daily.f
@@ -0,0 +1,736 @@
+!*****************************************************************!
+!* *!
+!* 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)
+ if (dis_control(1,1) .eq. 1) then
+ if(all_leaves_on .eq. 1 .and. dis_start(dis_control(1,2)) .eq. iday) CALL disturbance_defoliator
+ 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) CALL disturbance_root
+ endif
+ if (dis_control(5,1) .eq. 1) then
+ if(dis_start(dis_control(5,2)) .eq. iday) CALL disturbance_stem
+ endif
+ end select
+ par_day = (1.-pfref)* GR_in_PAR * rad
+ 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
+ par_av = par
+ 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_min
+
+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
diff --git a/source_code/version2.2_windows/day_ini.f b/source_code/version2.2_windows/day_ini.f
new file mode 100755
index 0000000000000000000000000000000000000000..cb15271ce159620817b9ea4806873f8fabb10f23
--- /dev/null
+++ b/source_code/version2.2_windows/day_ini.f
@@ -0,0 +1,137 @@
+!*****************************************************************!
+!* *!
+!* 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
diff --git a/source_code/version2.2_windows/dist_manag.f b/source_code/version2.2_windows/dist_manag.f
new file mode 100755
index 0000000000000000000000000000000000000000..50d1c77193f619b47b7e66dc8cbc0da786d02a03
--- /dev/null
+++ b/source_code/version2.2_windows/dist_manag.f
@@ -0,0 +1,410 @@
+!*****************************************************************!
+!* *!
+!* 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
+implicit none
+ integer :: dis_unit,i,ios
+ character(len=150) :: filename
+ logical :: ex
+ character(3) ::text
+
+ dis_control=0
+ 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
+
+xylem_dis=1.
+dis_control=0
+zeig=>pt%first
+ do
+ if(.not.associated(zeig)) exit
+ zeig%coh%x_fol_loss=0.
+ zeig%coh%x_frt_loss=0.
+ zeig=>zeig%next
+ end do
+
+ 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_simul
+use data_stand
+use data_site
+use data_species
+use data_par
+
+implicit none
+real :: loss, remain
+character(50) :: helpout
+
+helpout='disturbance_defoliator'
+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
+zeig=>pt%first
+ do
+ if(.not.associated(zeig)) exit
+ zeig%coh%x_fol_loss=zeig%coh%x_fol*loss
+ zeig%coh%x_fol=zeig%coh%x_fol*remain
+ zeig=>zeig%next
+ end do
+
+write(*,*)helpout
+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
+character(50) :: helpout
+
+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
+
+helpout='disturbance_phloem'
+
+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
+
+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
+ zeig%coh%x_frt_loss=zeig%coh%x_frt*loss
+ zeig%coh%x_frt=zeig%coh%x_frt*remain
+ 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
+
+helpout='disturbance_stem'
+
+write(*,*)helpout
+END SUBROUTINE disturbance_stem
+
+
diff --git a/source_code/version2.2_windows/evapo.f b/source_code/version2.2_windows/evapo.f
new file mode 100755
index 0000000000000000000000000000000000000000..394c475a38717129101a01d8674d8ada0bc960af
--- /dev/null
+++ b/source_code/version2.2_windows/evapo.f
@@ -0,0 +1,472 @@
+!*****************************************************************!
+!* *!
+!* 4C (FORESEE) Simulation Model *!
+!* *!
+!* *!
+!* Subroutines for: *!
+!* Soil and Water - Programs *!
+!* *!
+!* contains: *!
+!* EVAPO calculation of potential evapotranspiration *!
+!* (vor 8.8.03 in File soil.f90) *!
+!* 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
+ par, & ! photosynth. activ radiation (J/cm2)
+ 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
+par = par_day * 100./4.6
+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
+
+!******************************************************************************
+
diff --git a/source_code/version2.2_windows/finisim.f b/source_code/version2.2_windows/finisim.f
new file mode 100755
index 0000000000000000000000000000000000000000..343de729e0dc450ae1928458d01dfd4f4fa05b7a
--- /dev/null
+++ b/source_code/version2.2_windows/finisim.f
@@ -0,0 +1,526 @@
+!*****************************************************************!
+!* *!
+!* 4C (FORESEE) Simulation Model *!
+!* *!
+!* *!
+!* Subroutines for: *!
+!* finishing simulation *!
+!* *!
+!* contains *!
+!* FINISH_SIMUL: deallocation of variables, *!
+!* closing files for each simulation *!
+!* FINISH_ALL : Finish all processes after all simulations *!
+!* DEALLOC_SOIL: deallocation of soil variables *!
+!* (also used in other routines) *!
+!* *!
+!* Copyright (C) 1996-2018 *!
+!* Potsdam Institute for Climate Impact Reserach (PIK) *!
+!* Authors and contributors see AUTHOR file *!
+!* This file is part of 4C and is licensed under BSD-2-Clause *!
+!* See LICENSE file or under: *!
+!* http://www.https://opensource.org/licenses/BSD-2-Clause *!
+!* Contact: *!
+!* https://gitlab.pik-potsdam.de/foresee/4C *!
+!* *!
+!*****************************************************************!
+
+SUBROUTINE finish_simul
+
+use data_climate
+use data_depo
+!use data_effect
+use data_evapo
+use data_init
+use data_manag
+use data_out
+use data_simul
+use data_soil
+use data_soil_cn
+use data_species
+use data_stand
+use data_site
+use data_tsort
+use data_frost
+
+implicit none
+
+integer i ,unitout
+character(150) :: filename, infile
+REAL :: rsap, cform
+CHARACTER :: source
+
+ rsap = 0.
+ cform=0.
+ source='U'
+ infile='planting'
+
+ if(time_out.gt.0) then
+
+ ! output of new tree.ini at the end of the simulation
+ unitout=getunit()
+ filename = trim(site_name(ip))//'_tree.ini'//trim(anh)
+ open(unitout,file=trim(dirout)//filename,status='replace')
+ write(unitout,'(I1,1F12.0,A32)')flag_volfunc,kpatchsize,' ! = volume function, patch size'
+ write(unitout,'(A)')'! x_fol x_frt x_sap x_hrt x_Ahb height x_hbole x_age n sp DC DBH'
+
+ zeig => pt%first
+ do while (associated(zeig))
+ write(unitout,'(5f12.5,2f10.0,i7,f7.0,i7, 2f12.5)') zeig%coh%x_fol, zeig%coh%x_frt, zeig%coh%x_sap, zeig%coh%x_hrt, &
+ zeig%coh%x_Ahb, zeig%coh%height, zeig%coh%x_hbole, zeig%coh%x_age, zeig%coh%ntreea, &
+ zeig%coh%species, zeig%coh%dcrb, zeig%coh%diam
+ zeig => zeig%next
+ end do
+ close(unitout)
+
+ ! output of new .lit-file at the end of the simulation
+ if (flag_end .eq. 0) then
+ unitout=getunit()
+ filename = trim(site_name(ip))//'.lit'//trim(anh)
+ open(unitout,file=trim(dirout)//filename,status='replace')
+ write(unitout,'(A,A)')'! litter initialisation ', site_name(ip)
+ write(unitout,'(A)')'! fraction Fagus sylvatica Picea abies Pinus sylvestris Quercus robur Betula pendula Pinus contorta Pinus ponderosa Populus tremula ground cover'
+ write(unitout,'(A12, 9F18.1)') ' C_opm_fol ', (slit(i)%C_opm_fol, i=1,nspecies)
+ write(unitout,'(A12, 9F18.1)') ' C_opm_tb ', (slit(i)%C_opm_tb, i=1,nspecies)
+ write(unitout,'(A12, 9F18.1)') ' C_opm_frt ', (slit(i)%C_opm_frt(1), i=1,nspecies)
+ write(unitout,'(A12, 9F18.1)') ' C_opm_crt ', (slit(i)%C_opm_crt(1), i=1,nspecies)
+ write(unitout,'(A12, 9F18.1)') ' C_opm_stem ', (slit(i)%C_opm_stem,i=1,nspecies)
+ close(unitout)
+ endif
+
+ end if ! time_out
+
+! deallocate cohorts
+if(flag_end.ne.1 .and. associated(pt%first)) then
+ zeig => pt%first
+ do while (associated(zeig))
+ pt%first => zeig%next
+ deallocate (zeig%coh%frtrel)
+
+
+ deallocate(zeig%coh%frtrelc)
+ deallocate (zeig%coh%rooteff)
+
+ if (flag_wred .eq. 9) deallocate (zeig%coh%rld)
+ deallocate(zeig)
+ zeig => pt%first
+ end do
+end if
+
+if(associated(pt%first)) deallocate (pt%first)
+
+if (flag_eva .gt.10) close (unit_eva)
+
+if (allocated(dayfract))deallocate(dayfract)
+
+! fields for frost index
+if(allocated(dnlf)) deallocate(dnlf)
+if(allocated(tminmay_ann))deallocate(tminmay_ann)
+if(allocated(date_lf)) deallocate(date_lf)
+if(allocated(date_lftot)) deallocate(date_lftot)
+if(allocated(dnlf_sp)) deallocate(dnlf_sp)
+if(allocated(anzdlf)) deallocate(anzdlf)
+if (allocated(sumtlf)) deallocate(sumtlf)
+
+
+if (flag_clim==1) then
+ if (allocated(recs))deallocate(recs)
+ if (allocated(dd))deallocate(dd)
+ if (allocated(mm))deallocate(mm);
+ if (allocated(yy))deallocate(yy)
+ if (allocated(tp))deallocate(tp);
+ if (allocated(hm))deallocate(hm)
+ if (allocated(prc))deallocate(prc);
+ if (allocated(prs))deallocate(prs)
+ if (allocated(rd))deallocate(rd)
+ if (allocated(wd))deallocate(wd)
+ if (allocated(tx))deallocate(tx)
+ if (allocated(tn))deallocate(tn)
+ if (allocated(vp))deallocate(vp)
+ if (allocated(sdu))deallocate(sdu)
+ if (allocated(sde))deallocate(sde)
+ if (allocated(bw))deallocate(bw)
+
+ if (allocated(tempfield))deallocate(tempfield)
+ if (allocated(globfield))deallocate(globfield)
+ if (allocated(dayfield))deallocate(dayfield)
+endif
+
+if (.not.flag_mult910) then
+ if (allocated(NHd))deallocate(NHd)
+ if (allocated(NOd))deallocate(NOd)
+endif
+
+if (allocated(diam_class))deallocate(diam_class)
+if (allocated(diam_class_t))deallocate(diam_class_t)
+if (allocated(diam_class_h))deallocate(diam_class_h)
+if (allocated(diam_class_age))deallocate(diam_class_age)
+if (allocated(diam_class_mvol))deallocate(diam_class_mvol)
+if (allocated(diam_classm))deallocate(diam_classm)
+if (allocated(diam_classm_h))deallocate(diam_classm_h)
+if (allocated(height_class))deallocate(height_class)
+
+if (allocated(ngroups))deallocate(ngroups)
+
+if (allocated(dead_wood)) then
+ do i = 1, nspec_tree
+ deallocate(dead_wood(i)%C_tb)
+ deallocate(dead_wood(i)%N_tb)
+ deallocate(dead_wood(i)%C_stem)
+ deallocate(dead_wood(i)%N_stem)
+ enddo
+ deallocate(dead_wood)
+endif
+
+svar%sumvsdead = 0.
+svar%sumvsdead_m3 = 0.
+svar%daybb = 0.
+
+if (flag_multi .eq. 1 .or. flag_multi .eq. 6 .or. flag_multi .eq. 0) then
+ if(allocated(spar)) deallocate(spar)
+ if(allocated(nrspec)) deallocate(nrspec)
+
+ ! clear subfields for stress variables of svar
+ if (flag_wurz .eq. 4 .or. flag_wurz .eq. 6) then
+ do i=1,nspecies
+ deallocate(svar(i)%tstress)
+ deallocate(svar(i)%sstr)
+ deallocate(svar(i)%BDstr)
+ deallocate(svar(i)%BDmax)
+ deallocate(svar(i)%porcrit)
+ deallocate(svar(i)%airstr)
+ deallocate(svar(i)%phstr)
+ deallocate(svar(i)%Rstress)
+ deallocate(svar(i)%Smean)
+ enddo
+ endif
+
+ if(allocated(svar)) deallocate(svar)
+endif
+
+ if(flag_multi .eq. 4 .or. flag_mult8910) then
+ do i=1,nspecies
+ svar(i)%RedN = -99.9
+ enddo
+ end if
+
+call dealloc_soil ! soil-files immer deallok.
+
+do i = 1,outy_n
+ if (outy(i)%out_flag .ne. 0) then
+ close (outy(i)%unit_nr)
+ endif
+enddo
+do i = 1,outd_n
+ if (outd(i)%out_flag .ne. 0) then
+ close (outd(i)%unit_nr)
+ endif
+enddo
+
+C_bc_tot = 0.
+N_bc_tot = 0.
+if (flag_bc .gt. 0) then
+ deallocate(C_bc)
+ deallocate(N_bc)
+ deallocate (C_bc_appl)
+ deallocate (N_bc_appl)
+ deallocate (bc_appl_lay)
+ deallocate (cnv_bc)
+ deallocate (dens_bc)
+ deallocate (cpart_bc)
+ deallocate (y_bc)
+ flag_decomp = flag_decomp + 100 ! flag_decomp zurücksetzen
+endif
+
+if (flag_cohout .ge. 1) then
+ do i = 1,outcy_n
+ if (outcy(i)%out_flag .ne. 0) then
+ close (outcy(i)%unit_nr)
+ endif
+ enddo
+endif
+
+if (flag_dayout .ge. 1) then
+ do i = 1,outcd_n
+ if (outcd(i)%out_flag .ne. 0) then
+ close (outcd(i)%unit_nr)
+ endif
+ enddo
+
+endif
+
+if(time_out .gt. 0) then
+ if (out_flag_light .ne. 0) close(unit_light)
+ if (flag_cohout .eq. 2) then
+ close(unit_prod)
+ close(unit_allo)
+ endif
+ end if
+
+if (flag_dayout .gt. 1) then
+ close(unit_wat)
+ close(unit_soicnd);close(unit_soicna)
+endif
+
+if (.not.flag_mult910) close (unit_soil)
+if (flag_sum > 0) close(unit_sum)
+if (flag_mg==1) then
+ deallocate(thin_year);deallocate(thin_tree)
+endif
+if (flag_mg==3.or. flag_mg==33) then
+ if (allocated(thin_year)) deallocate(thin_year)
+ if( allocated(target_mass)) deallocate(target_mass)
+ if (allocated(thin_tysp))deallocate(thin_tysp)
+ if (allocated(thin_spec))deallocate(thin_spec)
+ if (allocated(rot))deallocate(rot)
+ if (allocated(thin_flag1))deallocate(thin_flag1)
+ if (allocated(thinyear))deallocate(thinyear)
+ if (allocated(thin_stor))deallocate(thin_stor)
+endif
+if (flag_mg==2.and. flag_end==0) then
+ if (allocated(zbnr))deallocate(zbnr)
+ if (allocated(tend))deallocate(tend)
+ if (allocated(rot))deallocate(rot)
+ if (allocated(regage))deallocate(regage)
+ if (allocated(thin_flag1))deallocate(thin_flag1)
+ if (allocated(thin_flag2))deallocate(thin_flag2)
+ if (allocated(thin_flag3))deallocate(thin_flag3)
+ if (allocated(thin_flag4))deallocate(thin_flag4)
+ if (allocated(np_mod))deallocate(np_mod)
+ if (allocated(specnr))deallocate(specnr)
+ if (allocated(age_spec))deallocate(age_spec)
+ if (allocated(anz_tree_spec))deallocate (anz_tree_spec)
+ if (allocated(thinyear))deallocate(thinyear)
+end if
+if (flag_mg==4. .or. flag_mg == 5) then
+ if (allocated(thin_flag1)) deallocate(thin_flag1)
+end if
+if(flag_mg == 10) then
+ if (allocated(thin_flag1))deallocate(thin_flag1)
+ if (allocated(dis_id))deallocate(dis_id)
+ if (allocated(dis_type))deallocate(dis_type)
+ if (allocated(fortype))deallocate(fortype)
+ if (allocated(dis_year))deallocate(dis_year)
+ if (allocated(dis_rel))deallocate(dis_rel)
+ if (allocated(sum_dis))deallocate(sum_dis)
+ end if
+if(flag_dis == 1) then
+ if (allocated(dis_year))deallocate(dis_year)
+ if (allocated(dis_spec))deallocate(dis_spec)
+ if (allocated(dis_start))deallocate(dis_start)
+ if (allocated(dis_rel))deallocate(dis_rel)
+ if (allocated(dis_type))deallocate(dis_type)
+ end if
+
+if(flag_mg == 9) then
+ if (allocated(thin_flag1))deallocate(thin_flag1)
+ if (allocated(yman))deallocate(yman)
+ if (allocated(dbh_clm))deallocate(dbh_clm)
+ if (allocated(rem_clm))deallocate(rem_clm)
+ if (allocated(spec_man))deallocate(spec_man)
+ if (allocated(act))deallocate(act)
+ if (allocated(rel_part))deallocate(rel_part)
+end if
+if(flag_mg == 8) then
+ if (allocated(thin_flag1))deallocate(thin_flag1)
+ if (allocated(yman))deallocate(yman)
+ if (allocated(rel_part))deallocate(rel_part)
+end if
+
+if(flag_wpm.ne.0) then
+ ! free the resources
+ call deallocate_wpm
+
+IF ( associated(st%first)) then
+ ztim => st%first
+ do while (associated(ztim))
+ st%first => ztim%next
+ deallocate(ztim)
+ ztim => st%first
+ end do
+endif
+
+ IF ( associated(st%first)) deallocate(st%first)
+ if ( associated(ztim)) deallocate(ztim)
+end if
+
+! compressed output for each simulation run
+lcomp1 = .TRUE.
+end subroutine finish_simul
+
+!-----------------------------------------
+
+SUBROUTINE finish_all
+
+use data_simul
+use data_climate
+use data_depo
+use data_mess
+use data_out
+use data_site
+use data_soil
+use data_soil_cn
+use data_species
+use data_stand
+
+if (allocated(site_name))deallocate(site_name)
+if (allocated(climfile))deallocate(climfile);
+if (allocated(sitefile))deallocate(sitefile)
+if (allocated(valfile))deallocate(valfile)
+if (allocated(treefile))deallocate(treefile)
+if (allocated(wpmfile))deallocate(wpmfile)
+if (allocated(depofile))deallocate(depofile)
+if (allocated(redfile))deallocate(redfile)
+if (allocated(litfile))deallocate(litfile)
+if (allocated(standid))deallocate(standid)
+
+IF(ALLOCATED(thick)) CALL dealloc_soil
+
+if(flag_multi .eq. 1 .or. flag_multi .ge. 3) then
+ if ( allocated(sitenum))deallocate(sitenum)
+ if ( allocated(clim_id))deallocate(clim_id)
+ if ( allocated(soilid))deallocate(soilid)
+ if ( allocated(gwtable))deallocate(gwtable)
+ if ( allocated(NOdep))deallocate(NOdep)
+ if ( allocated(NHdep))deallocate(NHdep)
+endif
+
+if(allocated(diam_class)) deallocate(diam_class)
+if(allocated(diam_class_t)) deallocate(diam_class_t)
+if(allocated(diam_class_h)) deallocate(diam_class_h)
+if(allocated(diam_classm)) deallocate(diam_classm)
+if(allocated(diam_classm_h)) deallocate(diam_classm_h)
+if(allocated(height_class)) deallocate(height_class)
+
+if (allocated(NHd))deallocate(NHd)
+if (allocated(NOd))deallocate(NOd)
+
+if(allocated(recs))then
+ deallocate(recs)
+ deallocate(dd);deallocate(mm);deallocate(yy)
+ deallocate(tp);deallocate(hm);deallocate(prc);deallocate(prs)
+ deallocate(rd)
+ if (allocated(tempfield))deallocate(tempfield)
+ if (allocated(globfield))deallocate(globfield)
+ if (allocated(dayfield))deallocate(dayfield)
+endif
+
+if(time_out .ne. -2) then
+ close(unit_comp1)
+ close(unit_comp2)
+endif
+
+if (flag_stat .gt. 0) then
+ close(unit_cons)
+ close(unit_mess)
+ close(unit_stat)
+endif
+
+if (flag_multi .gt.8) close (output_unit_all)
+
+if (flag_multi .eq. 2) close(unit_ctr)
+if(flag_multi.eq.7) deallocate(fl_co2)
+
+if(flag_multi .eq. 4 .or. flag_mult8910) then
+ if (allocated(output_var))deallocate(output_var)
+ if (allocated(output_varm))deallocate(output_varm)
+ if (allocated(output_varw))deallocate(output_varw)
+ if (allocated(climszenres))deallocate(climszenres)
+ if (allocated(climszenyear))deallocate(climszenyear)
+ if (allocated(climszenmon))deallocate(climszenmon)
+ if (allocated(climszenweek))deallocate(climszenweek)
+endif
+
+if ((ip .eq. 1 .or. flag_multi .eq. 1 .or. flag_multi .eq. 6) .and. (time_out .ne. -2) ) close(unit_err)
+
+end subroutine finish_all
+
+!-----------------------------------------
+
+SUBROUTINE dealloc_soil
+
+use data_soil
+use data_soil_cn
+use data_soil_t
+use data_simul
+
+implicit none
+
+if (allocated(thick)) deallocate(thick)
+if (allocated(mid)) deallocate(mid)
+if (allocated(depth)) deallocate(depth)
+if (allocated(pv)) deallocate(pv)
+if (allocated(pv_v)) deallocate(pv_v)
+if (allocated(dens)) deallocate(dens)
+if (allocated(f_cap_v)) deallocate(f_cap_v)
+if (allocated(wilt_p_v)) deallocate(wilt_p_v)
+if (allocated(field_cap)) deallocate(field_cap)
+if (allocated(wilt_p)) deallocate(wilt_p)
+if (allocated(vol)) deallocate(vol)
+if (allocated(quarzv)) deallocate(quarzv)
+if (allocated(sandv)) deallocate(sandv)
+if (allocated(clayv)) deallocate(clayv)
+if (allocated(siltv)) deallocate(siltv)
+if (allocated(humusv)) deallocate(humusv)
+if (allocated(dmass)) deallocate(dmass)
+if (allocated(fcaph)) deallocate(fcaph)
+if (allocated(wiltph)) deallocate(wiltph)
+if (allocated(pvh)) deallocate(pvh)
+if (allocated(skelv)) deallocate(skelv)
+if (allocated(skelfact)) deallocate(skelfact)
+if (allocated(spheat)) deallocate(spheat)
+if (allocated(phv)) deallocate(phv)
+if (allocated(wlam)) deallocate(wlam)
+if (allocated(wats)) deallocate(wats)
+if (allocated(watvol)) deallocate(watvol)
+if (allocated(wat_res)) deallocate(wat_res)
+if (allocated(perc)) deallocate(perc)
+if (allocated(wupt_r)) deallocate(wupt_r)
+if (allocated(wupt_ev)) deallocate(wupt_ev)
+if (allocated(s_drought)) deallocate(s_drought)
+if (allocated(root_fr)) deallocate(root_fr)
+if (allocated(temps)) deallocate(temps)
+if (allocated(BDopt)) deallocate(BDopt)
+if (allocated(fr_loss)) deallocate(fr_loss)
+if (allocated(redis)) deallocate(redis)
+if (allocated(C_opm)) deallocate(C_opm)
+if (allocated(C_hum)) deallocate(C_hum)
+if (allocated(C_opmfrt)) deallocate(C_opmfrt)
+if (allocated(C_opmcrt)) deallocate(C_opmcrt)
+if (allocated(N_opm)) deallocate(N_opm)
+if (allocated(N_hum)) deallocate(N_hum)
+if (allocated(N_opmfrt)) deallocate(N_opmfrt)
+if (allocated(N_opmcrt)) deallocate(N_opmcrt)
+if (allocated(NH4)) deallocate(NH4)
+if (allocated(NO3)) deallocate(NO3)
+if (allocated(Nupt)) deallocate(Nupt)
+if (allocated(Nmin)) deallocate(Nmin)
+if (allocated(rmin_phv)) deallocate(rmin_phv)
+if (allocated(rnit_phv)) deallocate(rnit_phv)
+if (allocated(cnv_opm)) deallocate(cnv_opm)
+if (allocated(cnv_hum)) deallocate(cnv_hum)
+if (allocated(slit)) deallocate(slit)
+if (allocated(slit_1)) deallocate(slit_1)
+if (allocated(sh)) deallocate(sh)
+if (allocated(sv)) deallocate(sv)
+if (allocated(sb)) deallocate(sb)
+if (allocated(sbt)) deallocate(sbt)
+if (allocated(t_cond)) deallocate(t_cond)
+if (allocated(t_cb)) deallocate(t_cb)
+if (allocated(h_cap)) deallocate(h_cap)
+if (allocated(sxx)) deallocate(sxx)
+if (allocated(svv)) deallocate(svv)
+if (allocated(svva)) deallocate(svva)
+if (allocated(soh)) deallocate(soh)
+if (allocated(son)) deallocate(son)
+if (allocated(wat_root)) deallocate(wat_root)
+if (allocated(root_lay)) deallocate(root_lay)
+if (allocated(gr_depth)) deallocate(gr_depth)
+
+if (allocated(xwatupt)) deallocate (xwatupt)
+if (allocated(xNupt)) deallocate (xNupt)
+if (allocated(wat_left)) deallocate (wat_left)
+
+end subroutine dealloc_soil
+!-----------------------------------------------------------------
+
+
diff --git a/source_code/version2.2_windows/gasdev.f b/source_code/version2.2_windows/gasdev.f
new file mode 100755
index 0000000000000000000000000000000000000000..c21eb79aed4c8365dab205bed0aa9cc02237b768
--- /dev/null
+++ b/source_code/version2.2_windows/gasdev.f
@@ -0,0 +1,74 @@
+!*****************************************************************!
+!* *!
+!* 4C (FORESEE) Simulation Model *!
+!* *!
+!* *!
+!* Subroutines for: *!
+!* *!
+!* random number generator: normal distribution *!
+!* SR gasdev (from numerucal recipes) *!
+!* SR ran1 ( --"--) *!
+!* *!
+!* Copyright (C) 1996-2018 *!
+!* Potsdam Institute for Climate Impact Reserach (PIK) *!
+!* Authors and contributors see AUTHOR file *!
+!* This file is part of 4C and is licensed under BSD-2-Clause *!
+!* See LICENSE file or under: *!
+!* http://www.https://opensource.org/licenses/BSD-2-Clause *!
+!* Contact: *!
+!* https://gitlab.pik-potsdam.de/foresee/4C *!
+!* *!
+!*****************************************************************!
+
+ FUNCTION gasdev(idum)
+ INTEGER idum
+ REAL gasdev, ran1
+
+ INTEGER iset
+ REAL fac,gset,rsq,v1,v2
+ SAVE iset,gset
+ DATA iset/0/
+
+ if (iset.eq.0) then
+1 v1=2.*ran1(idum)-1.
+ v2=2.*ran1(idum)-1.
+ rsq=v1**2+v2**2
+ if(rsq.ge.1..or.rsq.eq.0.)goto 1
+ fac=sqrt(-2.*log(rsq)/rsq)
+ gset=v1*fac
+ gasdev=v2*fac
+ iset=1
+ else
+ gasdev=gset
+ iset=0
+ endif
+ return
+ END
+
+ FUNCTION ran1(idum)
+ INTEGER idum,IA,IM,IQ,IR,NTAB,NDIV
+ REAL ran1,AM,EPS,RNMX
+ PARAMETER (IA=16807,IM=2147483647,AM=1./IM,IQ=127773,IR=2836, &
+ NTAB=32,NDIV=1+(IM-1)/NTAB,EPS=1.2e-7,RNMX=1.-EPS)
+ INTEGER j,k,iv(NTAB),iy
+ SAVE iv,iy
+ DATA iv /NTAB*0/, iy /0/
+ if (idum.le.0.or.iy.eq.0) then
+ idum=max(-idum,1)
+ do 11 j=NTAB+8,1,-1
+ k=idum/IQ
+ idum=IA*(idum-k*IQ)-IR*k
+ if (idum.lt.0) idum=idum+IM
+ if (j.le.NTAB) iv(j)=idum
+11 continue
+ iy=iv(1)
+ endif
+ k=idum/IQ
+ idum=IA*(idum-k*IQ)-IR*k
+ if (idum.lt.0) idum=idum+IM
+ j=1+iy/NDIV
+ iy=iv(j)
+ iv(j)=idum
+ ran1=min(AM*iy,RNMX)
+ return
+ END
diff --git a/source_code/version2.2_windows/gen_one_coh.f b/source_code/version2.2_windows/gen_one_coh.f
new file mode 100755
index 0000000000000000000000000000000000000000..74f70bb512144e1e2852097246963f8bdd12e075
--- /dev/null
+++ b/source_code/version2.2_windows/gen_one_coh.f
@@ -0,0 +1,124 @@
+!*****************************************************************!
+!* *!
+!* 4C (FORESEE) *!
+!* *!
+!* SR gen_one_coh for: *!
+!* planting of small trees given by *.pla *!
+!* used in prep_stand *!
+!* SR is called by flag_reg=20 *!
+!* *!
+!* Copyright (C) 1996-2018 *!
+!* Potsdam Institute for Climate Impact Reserach (PIK) *!
+!* Authors and contributors see AUTHOR file *!
+!* This file is part of 4C and is licensed under BSD-2-Clause *!
+!* See LICENSE file or under: *!
+!* http://www.https://opensource.org/licenses/BSD-2-Clause *!
+!* Contact: *!
+!* https://gitlab.pik-potsdam.de/foresee/4C *!
+!* *!
+!*****************************************************************!
+
+SUBROUTINE gen_one_coh(taxid,age,pl_height,nplant)
+ USE data_stand
+ USE data_simul
+ USE data_species
+ USE data_soil
+ USE data_help
+ USE data_plant
+ USE data_manag
+ IMPLICIT NONE
+ integer :: nplant, &
+ taxid, &
+ j,nr
+ real :: age, &
+ pl_height, &
+ hhelp,x1,x2,xacc,shelp
+real :: rtflsp, sapwood
+real :: troot2
+
+TYPE(cohort) ::tree_ini
+
+external sapwood
+external rtflsp
+
+ call coh_initial (tree_ini)
+ max_coh = max_coh + 1
+ tree_ini%ident = max_coh
+ tree_ini%species = taxid
+ tree_ini%ntreea = nplant
+ tree_ini%nta = tree_ini%ntreea
+ tree_ini%x_age = age
+ tree_ini%height = pl_height
+ hhelp = tree_ini%height
+
+ IF (taxid.ne.2) tree_ini%x_sap = exp(( LOG(hhelp)-LOG(spar(taxid)%pheight1))/spar(taxid)%pheight2)/1000000.
+ IF (taxid.eq.2) THEN
+ x1 = 1.
+ x2 = 2.
+ xacc=(1.0e-10)*(x1+x2)/2
+! solve equation for calculation of sapwood from height; determine root
+ heihelp = tree_ini%height
+ shelp=rtflsp(sapwood,x1,x2,xacc)
+ tree_ini%x_sap = (10**shelp)/1000000 ! transformation mg ---> kg
+ ENDIF
+
+! leaf matter
+ tree_ini%x_fol = (spar(taxid)%seeda*(tree_ini%x_sap** spar(taxid)%seedb)) ![kg]
+
+! fine root matter rough estimate
+ tree_ini%x_frt = tree_ini%x_fol
+
+! cross sectional area of heartwood
+ tree_ini%x_crt = tree_ini%x_sap * spar(tree_ini%species)%alphac*spar(tree_ini%species)%cr_frac
+ tree_ini%x_tb = tree_ini%x_sap * spar(tree_ini%species)%alphac*(1.-spar(tree_ini%species)%cr_frac)
+ tree_ini%med_sla = spar(taxid)%psla_min + spar(taxid)%psla_a*0.5
+ tree_ini%t_leaf = tree_ini%med_sla* tree_ini%x_fol ! [m-2]
+ tree_ini%ca_ini = tree_ini%t_leaf
+
+! initialize pheno state variables
+ IF(spar(tree_ini%species)%Phmodel==1) THEN
+ tree_ini%P=0
+ tree_ini%I=1
+ ELSE
+ tree_ini%P=0
+ tree_ini%I=0
+ tree_ini%Tcrit=0
+ END IF
+
+ IF(nplant.ne.0.) then
+ IF (.not. associated(pt%first)) THEN
+ ALLOCATE (pt%first)
+ pt%first%coh = tree_ini
+ NULLIFY(pt%first%next)
+
+! root distribution
+ call root_depth (1, pt%first%coh%species, pt%first%coh%x_age, pt%first%coh%height, pt%first%coh%x_frt, pt%first%coh%x_crt, nr, troot2, pt%first%coh%x_rdpt, pt%first%coh%nroot)
+ pt%first%coh%nroot = nr
+ do j=1,nr
+ pt%first%coh%rooteff = 1. ! assumption for the first use
+ enddo
+ do j=nr+1, nlay
+ pt%first%coh%rooteff = 0. ! layers with no roots
+ enddo
+
+ ELSE
+ ALLOCATE(zeig)
+ zeig%coh = tree_ini
+ zeig%next => pt%first
+ pt%first => zeig
+
+! root distribution
+ call root_depth (1, zeig%coh%species, zeig%coh%x_age, zeig%coh%height, zeig%coh%x_frt, zeig%coh%x_crt, nr, troot2, zeig%coh%x_rdpt, zeig%coh%nroot)
+ zeig%coh%nroot = nr
+ do j=1,nr
+ zeig%coh%rooteff = 1. ! assumption for the first use
+ enddo
+ do j=nr+1, nlay
+ zeig%coh%rooteff = 0. ! layers with no roots
+ enddo
+
+ END IF
+ anz_coh=anz_coh+1
+ END IF
+
+END SUBROUTINE gen_one_coh
diff --git a/source_code/version2.2_windows/gr_seed_week.f b/source_code/version2.2_windows/gr_seed_week.f
new file mode 100755
index 0000000000000000000000000000000000000000..cfb73426b89b1ab4d55577336ea3504f055b4672
--- /dev/null
+++ b/source_code/version2.2_windows/gr_seed_week.f
@@ -0,0 +1,135 @@
+!*****************************************************************!
+!* *!
+!* 4C (FORESEE) *!
+!* *!
+!* *!
+!* growth_seed_week - Growth of seedling cohorts weekly *!
+!* Allocation with weekly NPP *!
+!* *!
+!* Copyright (C) 1996-2018 *!
+!* Potsdam Institute for Climate Impact Reserach (PIK) *!
+!* Authors and contributors see AUTHOR file *!
+!* This file is part of 4C and is licensed under BSD-2-Clause *!
+!* See LICENSE file or under: *!
+!* http://www.https://opensource.org/licenses/BSD-2-Clause *!
+!* Contact: *!
+!* https://gitlab.pik-potsdam.de/foresee/4C *!
+!* *!
+!*****************************************************************!
+
+SUBROUTINE growth_seed_week (jx)
+USE data_stand
+USE data_species
+USE data_simul
+
+IMPLICIT NONE
+ REAL :: lambdaf = 0., & ! partitioning coefficients
+ lambdas = 0., &
+ lambdar = 0., &
+ NPP = 0., & ! NPP available for allocation
+ F = 0., & ! state variables: foliage,
+ S = 0., & ! shoot biomass,
+ R = 0., & ! fine roots,
+ H = 0., & ! total tree height
+ FNew, SNew, & ! new state variables
+ RNew, &
+ sigmaf = 0., & ! current leaf activity rate
+ ar = 0.
+ REAL :: Gf, & ! growth rates
+ Gs, &
+ Gr
+ REAL :: pab,helpdr
+
+ INTEGER :: jx
+ TYPE(coh_obj), POINTER :: p
+
+ p=>pt%first
+ DO
+ IF(.not.associated(p)) exit
+ IF( p%coh%fl_sap.eq.0) then
+ ns = p%coh%species
+ F = p%coh%x_fol
+ S = p%coh%x_sap
+ R = p%coh%x_frt
+ NPP = p%coh%weekNPP ! [kg]
+ H = p%coh%height
+
+! only allocate if enough NPP is available and day < a fixed limit
+ IF (NPP>1.0E-9 .and. iday<190) THEN
+ p%coh%NPPpool = p%coh%NPPpool + NPP
+! calculate leaf activity based on net PS and leaf mass
+ sigmaf = NPP/F
+! calculate root activity based on drought index
+ helpdr= p%coh%drIndPS
+! auxiliary variables for fine roots
+ ar = 1./helpdr
+ if(helpdr.lt.0.001) ar = 1.
+! calculate coefficients for roots and foliage and shoot
+ pab = spar(ns)%seeda*spar(ns)%seedb*S**(spar(ns)%seedb-1)
+! new model without senescence within the year:
+ lambdas=1./(1.+pab+pab*ar)
+ lambdaf=(1.-lambdas)/(1.+ar)
+ lambdar=1.-lambdas-lambdaf
+
+ IF (lambdas.lt.0.) THEN
+ lambdas = 0.
+ lambdaf = 1./(ar+1.)
+ lambdar = 1.-lambdaf
+ END IF
+ IF (lambdar<0) THEN
+ lambdar=0.
+ lambdas=0.
+ lambdaf=1.
+ END IF
+ IF (lambdaf<0) THEN
+ lambdar=0.
+ lambdas=0.
+ lambdaf=1.
+ END IF
+ ELSE
+ lambdaf = 0.
+ lambdas = 0.
+ lambdar = 0.
+ END IF
+
+ Gf = lambdaf*NPP
+ Gr = lambdar*NPP
+ Gs = lambdas*NPP
+ p%coh%gfol = Gf
+ p%coh%gfrt = Gr
+ p%coh%gsap = Gs
+
+ ! update of state vector
+ FNew = F + Gf
+ SNew = S + Gs
+ RNew = R + Gr
+ p%coh%x_fol = FNew
+ p%coh%x_sap = SNew
+ p%coh%x_frt = RNew
+ p%coh%fol_inc_old = p%coh%fol_inc
+ p%coh%fol_inc = Gf
+ p%coh%stem_inc = Gs
+
+ ! update height and shoot base diameter (regression functions from Schall 1998)
+ IF(ns.ne.2) p%coh%height = spar(ns)%pheight1* (snew*1000000.) **spar(ns)%pheight2
+ IF(ns.eq.2) p%coh%height = 10**(spar(ns)%pheight1+ spar(ns)%pheight2*LOG10(snew*1000000.)+ &
+ spar(ns)%pheight3*(LOG10(snew*1000000.))**2)
+ p%coh%height_ini = p%coh%height
+
+! update foliage area, parameter med_sla
+ SELECT CASE (flag_light)
+ CASE (1:2)
+ p%coh%med_sla = spar(ns)%psla_min + spar(ns)%psla_a*(1.- vstruct(lowest_layer)%irel)
+ CASE(3,4)
+ p%coh%med_sla = spar(ns)%psla_min + spar(ns)%psla_a*(1.-irelpool(lowest_layer))!
+ END SELECT
+
+! total leaf area of a tree in this cohort [m**2]as as crown area
+ p%coh%ca_ini = p%coh%med_sla * p%coh%x_fol
+
+! weekNPP equal zero for next calculation
+ p%coh%weekNPP = 0.
+ END IF
+ p=> p%next
+ END DO
+END SUBROUTINE growth_seed_week
\ No newline at end of file
diff --git a/source_code/version2.2_windows/initia.f b/source_code/version2.2_windows/initia.f
new file mode 100755
index 0000000000000000000000000000000000000000..71ef1a6945544d325c5b5248edae9387f8223a37
--- /dev/null
+++ b/source_code/version2.2_windows/initia.f
@@ -0,0 +1,1732 @@
+!*****************************************************************!
+!* *!
+!* 4C (FORESEE) Simulation Model *!
+!* *!
+!* *!
+!* Subroutines for: *!
+!* - Initialisation of cohorts = *!
+!* reads cohort information and calculates missing values *!
+!* which are needed for stand initialisation *!
+!* initia *!
+!* treeini *!
+!* sapini *!
+!* header *!
+!* crown_base *!
+!* crown_base_eg *!
+!* fdfahc: function *!
+!* ini_gener_sap *!
+!* NEWTON: function numerical recipes *!
+!* *!
+!* Copyright (C) 1996-2018 *!
+!* Potsdam Institute for Climate Impact Reserach (PIK) *!
+!* Authors and contributors see AUTHOR file *!
+!* This file is part of 4C and is licensed under BSD-2-Clause *!
+!* See LICENSE file or under: *!
+!* http://www.https://opensource.org/licenses/BSD-2-Clause *!
+!* Contact: *!
+!* https://gitlab.pik-potsdam.de/foresee/4C *!
+!* *!
+!*****************************************************************!
+
+!***********************!
+! SUBROUTINE INITIA !
+!***********************!
+
+SUBROUTINE INITIA
+
+! begin declaration section
+
+ USE data_init
+ USE data_par
+ USE data_simul
+ USE data_species
+ USE data_stand
+ use data_help
+ IMPLICIT none
+
+ REAL :: area !area of database in m^2 (10000=1ha)
+ INTEGER :: area_factor !factor for calculation per patch (=area/kpatchsize)
+ REAL :: hlp_lai,share, ager
+ INTEGER :: taxid, & ! species number
+ age, & ! tree age
+ n, & ! number of trees
+ n_koh, & !
+ k, & ! number of tree classes
+ ng_locid ! ID stand
+ INTEGER :: inunit, parunit,outunit,tmpunit,ctrlunit,listunit !units
+ CHARACTER*85 zeile
+ CHARACTER*80 :: infile
+ CHARACTER :: source
+ INTEGER :: nlines, nlines_comp, istart, fl_num, nhelp, numstand, ihelp
+ INTEGER :: tax_of_BRA_id
+
+ INTEGER,DIMENSION(:),ALLOCATABLE :: locid_comp
+ REAL rsap, cform, dummy
+ REAL aux
+ LOGICAL :: select_lines
+ real standsz(10000)
+
+ CHARACTER*40, allocatable, dimension(:) ::helptmp
+ INTEGER :: helpz
+
+! Stand data (model initialisation)
+ INTEGER baum(10),alt(10),klimid,gwa,lbanr,wgeb,lein,zei
+ REAL mhoe(10),dm(10),gf(10),bon(10),en(10),psi(10)
+! Parameters for missing data algorithms
+ REAL p0(nspec_tree),p1(nspec_tree),p2(nspec_tree),p3(nspec_tree),p4(nspec_tree), &
+ c1(nspec_tree),c2(nspec_tree),ku_a0(nspec_tree),ku_a1(nspec_tree),ku_a2(nspec_tree),&
+ ku_b0(nspec_tree),ku_b1(nspec_tree),ku_b2(nspec_tree),ku_c0(nspec_tree),&
+ ku_c1(nspec_tree),ku_c2(nspec_tree),wei_k1(nspec_tree),wei_k2(nspec_tree)
+
+! ------------------------------------------------------------------
+! INTEGER ncl !Number of classes after classification
+ integer ncl1
+
+ REAL dg,dmin,dmax,g,gpatch,b,c,bhd,height,hbc,hg
+ REAL tot_crown_area, mixed_tot_ca, corr_la
+ INTEGER pass
+ REAL saquad, genDg, nbhd,x,gx,bhdmax,bhdmin,clwdth,Fint(0:100)
+ REAL ku_a,ku_b,ku_c,wei_f,thdmax,p1n,p4n
+ REAL, allocatable, dimension(:) :: nz
+ REAL, allocatable, dimension(:) :: zheigh,zbhd,zhbc
+ REAL xxr,xyr, &
+ kd, &
+ h_para,h_parb !parameter of the height function of level II sites
+ INTEGER idum,anzahl, data_flag,start,baumid,dir_flag,inwahl,bz,imax
+ INTEGER i,j,anzit,iz,id,icl,ios,xid,xnr,xxi,xyi, &
+ bhdcl, & !diameter classes level II
+ dclmin, & !smallest diameter class level II
+ ndcl, & !amount of diameter classes of level II
+ dcwdth, & !class wideness diameter classes of level II
+ n_dc(30) !stem figure of level II diameter class
+ LOGICAL ehkwei, wfirst, kfirst, optimi
+ LOGICAL, allocatable, dimension(:) :: smaldc, bigdc
+ CHARACTER*20 fnam2
+ CHARACTER*5 datasets
+ CHARACTER status
+ real nzsum
+! ------------------------------------------------------------------
+! ----Function----
+ REAL ran0
+ REAL crown_base
+ real crown_base_eg
+! ------------------------------------------------------------------
+ REAL T
+ DATA T/7.0/
+! ------------------------------------------------------------------
+!
+! end of declaration section
+!******************************************************************************
+
+ ncl1 = 60
+ allocate (zheigh(ncl1), zbhd(ncl1), zhbc(ncl1), nz(ncl1))
+ allocate (smaldc(ncl1), bigdc(ncl1))
+print *,' '
+print *, ' *** Choice of forest stand data set: '
+print *, ' 1 - Datenspeicher Waldfond'
+print *, ' 2 - single tree data; classification must be performed (e.g. SILVA data)'
+print *, ' 3 - Level2-data'
+print *, ' 4 - already existing class file'
+print *, ' 5 - FORGRA data'
+print *, ' 6 - Bavarian inventory data'
+WRITE(*,'(A)',advance='no') ' ***Make your choice: '
+READ *, data_flag
+print *,' '
+
+clwdth=2 !set diameter class-class width
+corr_la=1. !standard value for leaf area correction in stands of high sum of crown projection areas
+mixed_tot_ca=0. !sum of crown projection area for mixed stands
+pass = 1 !counter for number of passes through calculation loop for mixed stands
+rsap=0.3 !standard value of rsap for cases where rsap is not determined dynamically
+! get unit number and open units used in all of the above cases
+
+ctrlunit=GETUNIT()
+WRITE(*,*)site_name(ip)
+OPEN (ctrlunit,FILE=TRIM(site_name(ip))//'.initctrl',STATUS='replace')
+ WRITE(ctrlunit,*)'# number of trees in cohort = n trees'
+ WRITE(ctrlunit,*)'# age = age'
+ WRITE(ctrlunit,*)'# height = H'
+ WRITE(ctrlunit,*)'# height to the base of crown = Hbc'
+ WRITE(ctrlunit,*)'# breast height diameter = bhd'
+ WRITE(ctrlunit,*)'# sapwood fraction of trunc cross sectional area at breast height = rsap'
+ WRITE(ctrlunit,*)'# trunc diameter at tree base = D'
+ WRITE(ctrlunit,*)'# trunc diameter at crown base = Dc'
+ WRITE(ctrlunit,*)'# sapwood cross sectional area inside bole = Asap'
+ WRITE(ctrlunit,*)'# heartwood cross sectional area at crown base = Ahc'
+ WRITE(ctrlunit,*)'# heartwood cross sectional area at tree base = Ahb'
+ WRITE(ctrlunit,*)'# Vol for no heartwood in crown space = Vmin'
+ WRITE(ctrlunit,*)'# Vol prescribed according to empiracal volume function = Vpre'
+ WRITE(ctrlunit,*)'# stem vol inherent in initialisation = Veff'
+ WRITE(ctrlunit,'(A150)')'# n trees age H Hbc bhd rsap D Dc Asap Ahc Ahb Vmin Vpre Veff'
+outunit=GETUNIT()
+OPEN (outunit,FILE=TRIM(treefile(ip)),STATUS='replace')
+
+! ------------------------------------------------------------------
+! read in parameter for the missing-data-generator:
+! bhd-distribution from Nagel & Biging (1995),
+! crown starting height from Nagel (1995), uni-height curve according to Weimann (1980) bzw. Kuleschis (1981)
+ parunit=GETUNIT()
+ OPEN (parunit, FILE='input/generreg.par', STATUS='old')
+ do i=1,nspec_tree
+ READ (parunit,*) p0(i),p1(i),p2(i),p3(i),p4(i),c1(i),c2(i),ku_a0(i),ku_a1(i),ku_a2(i), &
+ ku_b0(i),ku_b1(i),ku_b2(i),ku_c0(i),ku_c1(i),ku_c2(i),wei_k1(i),wei_k2(i)
+ ENDDO
+ CLOSE(parunit)
+! ---------------------------------------------------------------------
+inunit=GETUNIT()
+
+SELECT CASE(data_flag)
+
+! ****************************************************************************
+! case(1) stand generation if data source is Datenspeicher Waldfond
+CASE(1)
+ print *, ' Forest stand data set: Datenspeicher Waldfond'
+! preliminary: here make a choice and compile
+! datasets='singl' sets the choice of the old version which uses one single
+! set (i.e. the first one in an input file) which contains
+! the complete imformation for the stand in one single line
+! datasets='multi' sets the choice of a version reading a file with line by
+! line information as in the original Datenspeicher and then
+! writes a *.ini file for many stands with individual stand
+! information separated by lines with stand identifiers
+ print*, 'choose data set (multi/singl):'
+ read(*,*) datasets
+ print*, ' file name (with directory):'
+ read(*,'(A)') infile
+ source='D'
+ standsz = 0.
+ OPEN (inunit, FILE=TRIM(infile), STATUS='old')
+! ------------------------------------------------------------------
+! generating standard value out of data from the data storage unit
+! based on estimation routine from Nagel und Biging (1995),
+! Nagel (1995) und Gerold (1990).
+! ------------------------------------------------------------------
+!
+! The following variables are read from forest inventory data:
+! Species(baum),Age(alt),Quadratic Mean Diameter(dm),Height of tree with dm(mhoe),
+! Basal area(gf),Yield Class(bon),"Ertragsniveau"(en)
+! Additional Site variables:
+! Climate station(klimid),distance of groundwater table(gwa),soil type(lbanr),
+! forest region 'Wuchsgebiet'(wgeb),last management operation(lein), number of tree layers(zei)
+! currently not used for initialisation: xid, klimid, gwa, lbanr, wgeb, lein, bon(i), en(i)
+! lbanr (check difference to declaration!),
+! check if alt and baum can be skipped as variable names and age and species directly used
+! check idendity of hg and mhoe, dg and dm, gf and g
+! ------------------------------------------------------------------
+
+! input of data from a dataset, first row
+
+ IF (datasets=='singl') THEN
+ READ (inunit,*)xid,klimid,lbanr,gwa,wgeb,lein, &
+ zei,(baum(i), alt(i),mhoe(i),dm(i),gf(i),bon(i),en(i),i=1,zei)
+ ALLOCATE(ngroups(zei))
+ DO i=1,zei
+ IF(baum(i).EQ.8) ngroups(i)%taxid=1
+ IF(baum(i).EQ.10) ngroups(i)%taxid=2
+ IF(baum(i).EQ.11) ngroups(i)%taxid=3
+ IF(baum(i).EQ.15) ngroups(i)%taxid=4
+ if(baum(i).eq.12) ngroups(i)%taxid = 10
+! Eucalyptus
+ IF(baum(i).EQ.30) ngroups(i)%taxid=12
+ IF(baum(i).EQ.31) ngroups(i)%taxid=13
+
+
+ IF (dm(i).eq.0) dm(i) = 0.5
+ IF (mhoe(i).eq.0) mhoe(i) = 1.0
+ IF (gf(i).eq.0) gf(i) = 0.25
+ ngroups(i)%locid=xid
+ ngroups(i)%alter=alt(i)
+ ngroups(i)%mhoe=mhoe(i)
+ ngroups(i)%gf=gf(i)
+ ngroups(i)%dm=dm(i)
+ ngroups(i)%patchsize=10000
+
+ ENDDO
+ CLOSE(inunit)
+ nlines=zei
+ cform=1;hlp_lai=0
+ ! Initialisastion of stand data: area = 1ha
+ area=10000
+ area_factor=int(area/kpatchsize)
+ ! read file head for description, write in ini-file
+ CALL header(outunit,infile,source,cform,rsap,flag_volfunc,kpatchsize)
+ ENDIF !block for reading of input data DSW 'singl' = specially prepared for FORSKA
+
+! read in stand dataEinlesen out of data storage for many stands
+ IF (datasets=='multi') THEN
+ select_lines=.false.
+ fl_num=0
+if(infile=='input/hyyti_ini_0616.txt') then
+
+ ALLOCATE(ngroups(10000))
+ numstand= 0
+ nlines=1
+ ngroups%taxid=0
+ ngroups%schicht=-99
+ DO
+ READ (inunit,*,END=3333)xid,klimid,lbanr,gwa,wgeb,lein, &
+ zei,(baum(i),alt(i), psi(i), mhoe(i),dm(i),gf(i),bon(i),en(i),i=1,zei)
+ numstand = numstand +1
+ ngroups(nlines)%standsize= 0
+ DO i=1,zei
+ IF(baum(i).EQ.5) ngroups(nlines)%taxid=5
+ IF(baum(i).EQ.8) ngroups(nlines)%taxid=1
+ IF(baum(i).EQ.10) ngroups(nlines)%taxid=2
+ IF(baum(i).EQ.11) ngroups(nlines)%taxid=3
+ IF(baum(i).EQ.15) ngroups(nlines)%taxid=4
+ ! the following species are preliminarily assigned
+ IF(baum(i).EQ.1) ngroups(nlines)%taxid=2 ! Abies alba
+ IF(baum(i).EQ.2) ngroups(nlines)%taxid=1 ! Acer platanoides
+ IF(baum(i).EQ.3) ngroups(nlines)%taxid=1 ! Acer pseudoplatanus
+ IF(baum(i).EQ.4) ngroups(nlines)%taxid=5 ! Alnus glutinosa
+ IF(baum(i).EQ.6) ngroups(nlines)%taxid=1 ! Carpinus betulus
+ IF(baum(i).EQ.7) ngroups(nlines)%taxid=4 ! Castanea sativa
+ IF(baum(i).EQ.9) ngroups(nlines)%taxid=4 ! Fraxinus excelsior
+ IF(baum(i).EQ.12) ngroups(nlines)%taxid=5 ! Populus tremula
+ IF(baum(i).EQ.13) ngroups(nlines)%taxid=4 ! Quercus petraea
+ IF(baum(i).EQ.14) ngroups(nlines)%taxid=4 ! Quercus pubescencs
+ IF(baum(i).EQ.16) ngroups(nlines)%taxid=1 ! Tilia cordata
+ IF(baum(i).EQ.17) ngroups(nlines)%taxid=4 ! Ulmus glabra
+ iF(baum(i).EQ.21) ngroups(nlines)%taxid=10 ! Douglasie
+ iF(baum(i).EQ.22) ngroups(nlines)%taxid=6 ! Larix
+ iF(baum(i).EQ.23) ngroups(nlines)%taxid=7 ! Pinus strobus
+ iF(baum(i).EQ.24) ngroups(nlines)%taxid=10 ! Douglasie
+
+ IF (dm(i).eq.0) dm(i) = 0.5
+ IF (mhoe(i).eq.0) mhoe(i) = 1.0
+ IF (gf(i).eq.0) gf(i) = 0.25
+ ngroups(nlines)%locid=xid
+ ngroups(nlines)%alter=alt(i)
+ ngroups(nlines)%mhoe=mhoe(i)
+ ngroups(nlines)%gf=gf(i)
+ ngroups(nlines)%dm=dm(i)
+ ngroups(nlines)%patchsize=psi(i)*10000
+ ngroups(nlines)%standsize=psi(i)*10000
+
+ nlines=nlines+1
+ standsz(numstand) = standsz(numstand) + psi(i)*10000
+ ENDDO
+ ENDDO ! read loop
+3333 CONTINUE
+ nlines=nlines-1
+ WRITE(*,*) nlines,'sets of data', numstand, 'sets of stands'
+ ELSE
+ IF(select_lines) THEN
+ READ(listunit,*)nlines_comp
+ ALLOCATE(locid_comp(nlines_comp))
+ DO i=1,nlines_comp ! reading list of sites to be initialised
+ READ(listunit,*) locid_comp(i)
+ ENDDO ! end reading list of sites to be initialised
+ ENDIF ! end of reading file with sites to be selected
+ IF(select_lines) CLOSE(listunit)
+ CALL assign_DSW
+ CALL init_plenter_param
+ READ (inunit,*)nlines
+ ALLOCATE(ngroups(nlines))
+ istart=1
+ READ(inunit,*) ngroups(1)%locid,ngroups(1)%schicht,ngroups(1)%BRAid,ngroups(1)%alter,ngroups(1)%patchsize,ngroups(1)%mhoe,ngroups(1)%dm,ngroups(1)%volume,ngroups(1)%gf
+ ngroups(1)%patchsize=ngroups(1)%patchsize*10000.
+ ngroups(1)%baumzahl=0
+ ngroups(istart)%standsize=ngroups(1)%patchsize
+ ngroups(1)%taxid=tax_of_BRA_id(ngroups(1)%BRAid)
+
+ DO i=2,nlines
+ READ(inunit,*) ngroups(i)%locid,ngroups(i)%schicht,ngroups(i)%BRAid,ngroups(i)%alter,ngroups(i)%patchsize,ngroups(i)%mhoe,ngroups(i)%dm,ngroups(i)%volume,ngroups(i)%gf
+ WRITE(*,*) 'set no', i, 'read'
+ ngroups(i)%baumzahl=0
+ ! the following line maps BRAid 770 to 779, other 'Mehlbeeren', because two
+ ! different numbering systems existed in Brandenburg in the course of time
+ IF(ngroups(i)%BRAid==770) ngroups(i)%BRAid=779
+ ngroups(i)%patchsize=ngroups(i)%patchsize*10000.
+ ngroups(i)%taxid=tax_of_BRA_id(ngroups(i)%BRAid)
+ IF(ngroups(i)%taxid==6) ngroups(i)%taxid=3
+ IF(ngroups(i)%taxid==0) THEN
+
+ ELSE
+ ENDIF
+ IF(ngroups(i)%locid==ngroups(istart)%locid) THEN
+ ngroups(istart)%standsize=ngroups(istart)%standsize+ngroups(i)%patchsize
+ ngroups(i)%standsize = ngroups(istart)%standsize
+ ELSE
+ istart=i
+ ngroups(istart)%standsize=ngroups(i)%patchsize
+ fl_num=fl_num+1
+ ENDIF
+ ENDDO ! readin loop for multi data-set
+ ENDIF ! block for direct DSW data or brb_inv-file structure
+ CLOSE(inunit)
+ ! read in file headder for description, write into ini-file
+ cform=1;hlp_lai=0
+ ! initilisation for stand data: area = stand area based on fractions of areas
+ area_factor=1
+ CALL header(outunit,infile,source,cform,rsap,flag_volfunc,-99.)
+ WRITE(*,*) 'number of data lines: ', nlines
+ write(*,*)'number of plots for calculations: ', fl_num
+ ENDIF ! block for reading input data DSW, many lines = 'multi'
+ id=1
+ tmpunit=getunit()
+ ihelp = 1
+ istart=-99
+ DO iz=1,nlines
+ IF(select_lines) THEN
+ DO i=1,nlines_comp
+ IF(locid_comp(i)==ngroups(iz)%locid) GOTO 2233
+ ENDDO ! comparison of site id to list of sites to be selected
+ CYCLE
+ ENDIF ! end of site selection
+2233 CONTINUE
+ WRITE(*,*) iz, nlines, ngroups(iz)%locid,ngroups(iz)%schicht
+ IF(datasets=='multi'.AND.(istart.NE.ngroups(iz)%locid)) THEN
+ WRITE(outunit,*) ngroups(iz)%locid,ngroups(iz)%standsize,'stand identifier, stand area'
+ ihelp = ihelp +1
+ istart=ngroups(iz)%locid
+ ENDIF
+ IF(datasets=='multi'.AND.ngroups(iz)%taxid==0.) THEN
+
+ WRITE(*,*) 'not the right species'
+ GOTO 2222
+ ENDIF
+ IF(datasets=='multi'.AND.ngroups(iz)%schicht==20) THEN
+ ! retention trees
+ age=ngroups(iz)%alter
+ taxid=ngroups(iz)%taxid
+ height=ngroups(iz)%mhoe
+ bhd=ngroups(iz)%dm
+ n_koh=ngroups(iz)%baumzahl
+ hbc=crown_base(height,c1(taxid),c2(taxid),bhd)
+ CALL treeini(outunit,ctrlunit,taxid,source,bhd,height,hbc,n_koh,cform,rsap,age,hlp_lai,corr_la)
+ GOTO 2222
+ ENDIF ! end special treatment of retention trees
+ IF(datasets=='multi'.AND.ngroups(iz)%dm==0.) THEN
+ WRITE(4444,*)'data insufficient for: ',ngroups(iz)%locid,' line: ',iz
+ GOTO 2222
+ ENDIF
+
+ IF(datasets=='multi'.AND.ngroups(iz)%mhoe<h_sapini*0.01 .or. ngroups(iz)%gf.eq.0.) THEN
+ aux = ngroups(iz)%standsize/10000.
+ height=ngroups(iz)%mhoe
+ n_koh=ngroups(iz)%baumzahl* aux
+ age=ngroups(iz)%alter
+ taxid = ngroups(iz)%taxid
+ WRITE(4444,*)'sapling init needed for: ',ng_locid,' line: ',iz
+ call ini_gener_sap(outunit, taxid,age,height,n_koh)
+ GOTO 2222
+ ENDIF
+ optimi=.false.
+ anzahl= 0;start=1
+
+ allocate(helptmp(10000000))
+ helptmp = ' '
+ ! generation of single trees out of population mean values
+ DO
+ helptmp = ' '
+ IF((start==1).or.(.not.optimi))THEN
+ T =7
+ anzahl=0
+ start=0
+ wfirst=.true.
+ kfirst=.true.
+ WRITE(*,*)ngroups(iz)%locid,ngroups(iz)%patchsize
+ age=ngroups(iz)%alter
+ dg=ngroups(iz)%dm !quadratic mean diameter
+ hg=ngroups(iz)%mhoe !corresponding height to dg
+ taxid=ngroups(iz)%taxid !species
+ g=ngroups(iz)%gf !basal area/ha
+ gpatch=g/area_factor !basal area/patch
+ IF (datasets=='multi') gpatch=g*ngroups(iz)%standsize/10000.
+ ! selection of uni-height curve: Beech, Spruce, Oak calculated according to Weimann,
+ ! other species of tree according to Kuleschis (vergl. Gerold 1990)
+ IF (taxid==3.OR.taxid==5) THEN
+ ehkwei=.false.
+ ELSE
+ ehkwei=.true.
+ ENDIF
+ IF ((dg-T).lt. 3.0) THEN
+ T=dg-4.0
+ IF (T.lt.0.3) T=0.3
+ ENDIF
+ ! Estimation of Dmax out of dg (Gerold 1990)
+ Dmax=8.2+1.8*dg-0.01*dg**2
+ IF (dg.le.2) Dmax=dg+2
+! calculation for the Weibull-distribution function
+! in case b or c are calcuted too small, p1 and p4 respectively have to be modified
+ p1n=p1(taxid)
+ IF (p1n.lt.((1.0001-p0(taxid))/Dg)) p1n=(1.0001-p0(taxid))/Dg
+ b=p0(taxid)+p1n*Dg
+ p4n=p4(taxid)
+ IF (p4n.lt.((1.0005-p2(taxid)-p3(taxid)*Dg)/Dmax)) p4n=(1.0005-p2(taxid)-p3(taxid)*Dg)/Dmax
+ c=p2(taxid)+p3(taxid)*Dg+p4n*Dmax
+
+ anzit=0
+ thdmax=5.0
+ ENDIF ! end of introductory calculation and repetitions without optimisation
+
+ genDg=0
+ nbhd=0
+ saquad=0
+ bhdmax=0
+ bhdmin=100
+ clwdth=0
+ gx=0
+ idum=1
+ x=0
+
+!----------------------------
+! generation of single trees
+ DO
+ IF (gx.gt.gpatch) exit
+ x = ran0(idum)
+ bhd=b*((T/b)**c-log(1.-x))**(1./c)
+ if ( bhd.ge. 0.5*Dg) then
+ IF (bhd.gt.bhdmax) bhdmax=bhd
+ IF (bhd.lt.bhdmin) bhdmin=bhd
+ IF ((.not. optimi) .and. (bhd.gt.(1.5*dmax))) bhd=1.5*dmax
+
+!***height calculation according to uni-height curve
+ IF (ehkwei) THEN
+! uni-height curve of Weimann (1980)
+ IF (wfirst) THEN
+ wei_f=wei_k1(taxid)+wei_k2(taxid)*hg
+ wfirst=.false.
+ ENDIF
+ IF (bhd.ge.(dg-hg/2.)) THEN
+ height=hg+wei_f*(log(hg-dg+bhd)-log(hg))
+ ELSE
+ height=(hg+wei_f*(log(hg/2.)-log(hg))-1.3)*(bhd/(dg-hg/2.))**0.5+1.3
+ ENDIF
+ ELSE
+! uni-height curve of Kuleschis (1981)
+ IF (kfirst) THEN
+ ku_a=1-(ku_a0(taxid)+ku_a1(taxid)*dg+ku_a2(taxid)*dg**2)
+ ku_b=ku_b0(taxid)+ku_b1(taxid)*dg+ku_b2(taxid)*dg**2
+ ku_c=ku_c0(taxid)+ku_c1(taxid)*dg+ku_c2(taxid)*dg**2
+ kfirst=.false.
+ ENDIF
+ height=hg*(ku_a+(ku_b/(bhd+dg/2.))*dg+(ku_c/(bhd+dg/2.)**2)*dg**2)
+ ENDIF
+ if(taxid.eq.10) then
+! height curve after Bwinpro Douglas fir
+ height = 1.3 +(hg-1.3)*exp(-(0.199651*dg+4.63277655)*((1/bhd) - (1/dg)))
+ end if
+ if(taxid.eq.12.or. taxid.eq.13) then
+! Medhurst et al. 1999
+ height = 3.665629*bhd**0.541
+ end if
+
+! solution for small stands; tree dimensions below 3 m = rubbish
+ IF (height.gt.(bhd*3.)) height=bhd*3.
+ IF (height.lt.1.35) height=1.35+bhd
+ if(taxid.eq.12.or. taxid.eq.13) then
+! Eucalyptus
+ hbc = crown_base_eg(height, bhd)
+ else
+ hbc=crown_base(height,c1(taxid),c2(taxid),bhd)
+ end if
+
+ IF ((height-hbc).lt. 0.5) hbc= height - 0.5
+ write(helptmp(nbhd+1), '(3f7.1,2i7)') bhd,height,hbc,age,taxid
+ gx=gx+1E-4*pi*(bhd/2.)**2
+ nbhd=nbhd+1
+ anzahl=anzahl+1
+ saquad=saquad+bhd**2
+ end if ! BHD test
+ ENDDO ! single tree calculation
+!---calculates the generated Dg and test deviations of Dg and Dmax of the population value.
+! if deviation greater 20% a fittinf of the parameters acording to the Weibull-distribution is done
+! the standard generation is repeated in several iterations.
+!---the optimisation can be shut off with optimi=.false.
+
+ genDg=SQRT(saquad/nbhd)
+ IF((.not. optimi) .or. (Dg .lt. 7)) exit
+ IF(ABS(genDg-Dg).gt.(Dg/10.).or.(bhdmax-Dmax).gt. (Dmax/thdmax)) THEN
+ IF (ABS(genDg-Dg).gt.(Dg/10.))THEN
+ p1n=p1n*Dg/genDg
+ IF (p1n.lt.((1.0001-p0(taxid))/Dg)) p1n=(1.0001-p0(taxid))/Dg
+ b=p0(taxid)+p1n*Dg
+ ELSE
+ p4n=p4n*Dmax/bhdmax
+ IF (p4n.lt.((1.0005-p2(taxid)-p3(taxid)*Dg)/Dmax)) &
+ p4n=(1.0005-p2(taxid)-p3(taxid)*Dg)/Dmax
+ c=p2(taxid)+p3(taxid)*Dg+p4n*Dmax
+ ENDIF
+ anzahl=anzahl-Int(nbhd)
+ anzit=anzit+1
+ IF (anzit.ge.50) THEN
+ IF (thdmax.eq.2) THEN
+ print *,'id/zei: ',id,iz,' Optimization not successful. Biased STAND.INI will be generated'
+ optimi=.false.
+ ELSE
+ anzit=0
+ thdmax=2.0
+ b=p0(taxid)+p1(taxid)*Dg
+ c=p2(taxid)+p3(taxid)*Dg+p4(taxid)*Dmax
+ ENDIF
+ ENDIF
+ ELSE
+ exit
+ ENDIF
+
+ ENDDO
+! end of generation of single trees
+
+ ! classification of single values in diameter cohorts
+ clwdth=1+AINT((bhdmax-bhdmin)/ncl1) !calculation of class widths
+ DO i=1,ncl1
+ nz(i)=0
+ zbhd(i)=0
+ zheigh(i)=0
+ zhbc(i)=0
+ ENDDO
+ DO j=1,nbhd
+ read(helptmp(j), *) bhd,height,hbc,age,taxid
+ IF(height<1.3) WRITE(4444,*)'bhd ',bhd,'height ',height,'art ',taxid
+ icl=INT(bhd/clwdth)+1
+ IF(icl.gt.ncl1) icl=ncl1
+ nz(icl)=nz(icl)+1 !addition stem numbre of diameter classes
+ zbhd(icl)=zbhd(icl)+bhd !sum of diametes of diameter calsses
+ zheigh(icl)=zheigh(icl)+height !sum of height value of classes
+ zhbc(icl)=zhbc(icl)+hbc !sum of crown starting height of classes
+
+ ENDDO
+
+ deallocate(helptmp)
+ tot_crown_area=0.
+ DO i=1,ncl1
+ IF (nz(i).ne.0) THEN
+ bhd=zbhd(i)/nz(i)
+ height=zheigh(i)/nz(i)
+ hbc=zhbc(i)/nz(i)
+ n_koh=NINT(nz(i)/area_factor)
+ tot_crown_area=tot_crown_area+n_koh*PI*(MIN(spar(taxid)%crown_a*bhd+spar(taxid)%crown_b,spar(taxid)%crown_c))**2
+ ENDIF
+ ENDDO
+
+ IF(tot_crown_area>1.1*kpatchsize) THEN
+ corr_la=kpatchsize/tot_crown_area
+ ELSE
+ corr_la=1.
+ ENDIF
+
+ DO i=1,ncl1
+ IF (nz(i).ne.0) THEN
+ bhd=zbhd(i)/nz(i)
+ height=zheigh(i)/nz(i)
+ hbc=zhbc(i)/nz(i)
+ n_koh=NINT(nz(i)/area_factor)
+ ! --- 4C-specific calculations:
+ IF(height<1.3) WRITE(4444,*)ngroups(iz)%locid,'bhd ',bhd,'height ',height,'art ',taxid
+ IF(height*100<h_sapini) THEN
+ CALL sapini(outunit,taxid, height,hbc, n_koh,age)
+ WRITE(4444,*)ngroups(iz)%locid,bhd,taxid
+ ELSE
+ CALL treeini(outunit,ctrlunit,taxid,source,bhd,height,hbc,n_koh,cform,rsap,age,hlp_lai,corr_la)
+ ENDIF
+ ENDIF
+ ENDDO !cohort loop
+2222 CONTINUE
+ if(datasets=='multi') then
+ IF (iz.ne.nlines.AND.datasets=='multi'.AND.(istart.NE.ngroups(iz+1)%locid)) WRITE(outunit,*) '-99.9'
+ end if
+2244 CONTINUE
+ ENDDO !line loop
+ CLOSE(outunit)
+ CLOSE(ctrlunit)
+ RETURN
+
+! ****************************************************************************
+! case(6) stand generation if data source is from Bavarian inventories
+CASE(6)
+ print *, ' Forest stand data set: Bavarian inventories'
+ infile='/data/safe/4C/4C_input/stand/Bayernw.dat'
+ source='B'
+ OPEN (inunit, FILE=TRIM(infile), STATUS='old')
+
+ listunit=GETUNIT()
+ OPEN (listunit, FILE='/home/lasch/4c/v0.99e1/input/koord.txt', STATUS='old')
+
+! ------------------------------------------------------------------
+! generated standard values of data from data storage based on
+! estimation routines of Nagel and Biging (1995), Nagel (1995) and
+! Gerold (1990).
+! ------------------------------------------------------------------
+!
+! The following variables are read from forest inventory data:
+! Species(baum),Age(alt),Quadratic Mean Diameter(dm),Height of tree with dm(mhoe),
+! Basal area(gf),Yield Class(bon),"Ertragsniveau"(en)
+!
+! ------------------------------------------------------------------
+
+! read in stad data of multiple stands out of records
+ select_lines=.true.
+ datasets='multi'
+ fl_num=0
+ IF(select_lines) THEN
+ READ(listunit,*)nlines_comp
+ ALLOCATE(locid_comp(nlines_comp))
+ DO i=1,nlines_comp ! reading list of sites to be initialised
+ READ(listunit,*) locid_comp(i)
+ ENDDO ! end reading list of sites to be initialised
+ ENDIF ! end of reading file with sites to be selected
+ IF(select_lines) CLOSE(listunit)
+ CALL assign_BAY
+ CALL init_plenter_param
+ READ (inunit,*)
+ READ (inunit,*)nlines
+ ALLOCATE(ngroups(nlines))
+ istart=1
+ READ(inunit,*) dummy, dummy, dummy, ngroups(1)%locid, dummy, &
+ ngroups(1)%schicht, ngroups(1)%BRAid, dummy, dummy, ngroups(1)%alter, &
+ dummy, dummy, ngroups(1)%dm, ngroups(1)%mhoe, ngroups(1)%baumzahl, &
+ ngroups(1)%gf, ngroups(1)%volume, dummy
+ ngroups(1)%taxid=tax_of_BRA_id(ngroups(1)%BRAid)
+ ngroups(1)%standsize=40000
+ IF(ngroups(1)%alter==0.OR.ngroups(1)%mhoe==0.OR.ngroups(1)%dm==0.OR.ngroups(1)%volume==0.OR.ngroups(1)%gf==0) CALL data_gap_fill_DSW(1)
+ DO i=2,nlines
+ READ(inunit,*) dummy, dummy, dummy, ngroups(i)%locid, dummy, &
+ ngroups(i)%schicht, ngroups(i)%BRAid, dummy, dummy, ngroups(i)%alter, &
+ dummy, dummy, ngroups(i)%dm, ngroups(i)%mhoe, ngroups(i)%baumzahl, &
+ ngroups(i)%gf, ngroups(i)%volume, dummy
+ WRITE(*,*) 'set no', i, 'read'
+ ngroups(i)%taxid=tax_of_BRA_id(ngroups(i)%BRAid)
+ ngroups(i)%standsize=40000
+ ! preliminary solution: larches mapped to pine
+ IF(ngroups(i)%taxid==6) ngroups(i)%taxid=3
+ IF(ngroups(i)%taxid==0) THEN
+
+ ELSE
+ IF(ngroups(i)%alter==0.OR.ngroups(i)%mhoe==0.OR.ngroups(i)%dm==0.OR.ngroups(i)%gf==0) THEN
+ WRITE(7333,*)'set ',i,'not enough data or below 1.3 m height'
+! CALL data_gap_fill_DSW(i)
+ ENDIF
+ ENDIF
+ IF(ngroups(i)%locid.NE.ngroups(istart)%locid) THEN
+ istart=i
+ fl_num=fl_num+1
+ ENDIF
+ ENDDO ! readin loop for multi data-set
+ CLOSE(inunit)
+ ! read file headder for description, write in ini-file
+ cform=1;hlp_lai=0
+ ! initialisation of stand records: area =
+ ! stand area calculated according to partial areas.
+ area_factor=1
+ CALL header(outunit,infile,source,cform,rsap,flag_volfunc,-99.)
+ id=1
+ WRITE (fnam2,'(a,i1,a)') 'schicht',id,'.tmp'
+ tmpunit=getunit()
+ istart=-99
+ DO iz=1,nlines
+
+ ng_locid = ngroups(iz)%locid
+ taxid=ngroups(iz)%taxid
+
+ IF(select_lines) THEN
+ DO i=1,nlines_comp
+ IF(locid_comp(i)==ng_locid) GOTO 2255
+ ENDDO ! comparison of site id to list of sites to be selected
+ CYCLE
+ ENDIF ! end of site selection
+2255 CONTINUE
+
+ IF(datasets=='multi'.AND.(istart.NE.ng_locid)) THEN
+
+ WRITE(outunit,*) ng_locid,ngroups(iz)%standsize,'stand identifier, stand area'
+ istart=ng_locid
+ aux = ngroups(iz)%standsize/10000.
+ ENDIF
+ IF(datasets=='multi'.AND.taxid==0.) THEN
+ ! solution for bushes must be found
+ WRITE(*,*) 'not the right species'
+ GOTO 2277
+ ENDIF
+ IF(ngroups(iz)%baumzahl<30.AND.ngroups(iz)%baumzahl>0) ngroups(iz)%schicht=5
+ IF(datasets=='multi'.AND.ngroups(iz)%schicht==5) THEN
+ ! retention trees can be directly initialized since they are not distributed onto different height cohorts
+ WRITE(4444,*) 'single type ',ngroups(iz)%schicht
+ age=ngroups(iz)%alter
+ height=ngroups(iz)%mhoe
+ bhd=ngroups(iz)%dm
+ n_koh=ngroups(iz)%baumzahl*aux
+ hbc=crown_base(height,c1(taxid),c2(taxid),bhd)
+ CALL treeini(outunit,ctrlunit,taxid,source,bhd,height,hbc,n_koh,cform,rsap,age,hlp_lai,corr_la)
+
+ GOTO 2277
+ ENDIF ! end special treatment of retention trees
+ IF(datasets=='multi'.AND.ngroups(iz)%dm==0.and.ngroups(iz)%mhoe>h_sapini*0.01) THEN
+ WRITE(4444,*)'data insufficient for: ',ng_locid,' line: ',iz
+ GOTO 2277
+ ENDIF
+ IF(datasets=='multi'.AND.ngroups(iz)%mhoe<h_sapini*0.01) THEN
+ height=ngroups(iz)%mhoe
+ n_koh=ngroups(iz)%baumzahl* aux
+ age=ngroups(iz)%alter
+ call ini_gener_sap(outunit, taxid,age,height,n_koh)
+ GOTO 2277
+ ENDIF
+
+ T=7
+ age=ngroups(iz)%alter
+ dg=ngroups(iz)%dm !quadratic mean diameter
+ hg=ngroups(iz)%mhoe !corresponding height to dg
+ g=ngroups(iz)%gf !basal area/ha
+ gpatch=g*4. !basal area/patch
+ bz=ngroups(iz)%baumzahl*4. !tree numbre/patch
+ clwdth=dg/20.
+
+ ! selection of uni-height curve: beech, spruce, oak calculation according to Weimann,
+ ! other species of trees after Kuleschis (vergl. Gerold 1990)
+ IF (taxid==3.OR.taxid==5) THEN
+ ehkwei=.false.
+ ELSE
+ ehkwei=.true.
+ ENDIF
+ ! zuweisen der PArameterwerte für Einheitshöhenkurve
+ IF (ehkwei) THEN
+ ! uni-height curve from Weimann (1980)
+ wei_f=wei_k1(taxid)+wei_k2(taxid)*hg
+ ELSE
+ ! uni-height curve from Kuleschis (1981)
+ ku_a=1-(ku_a0(taxid)+ku_a1(taxid)*dg+ku_a2(taxid)*dg**2)
+ ku_b=ku_b0(taxid)+ku_b1(taxid)*dg+ku_b2(taxid)*dg**2
+ ku_c=ku_c0(taxid)+ku_c1(taxid)*dg+ku_c2(taxid)*dg**2
+ ENDIF
+ IF ((dg-T).lt. 3.0) THEN
+ T=dg-4.0
+ IF (T.lt.0.3) T=0.3
+ ENDIF
+ ! Estimation of Dmax from dg (Gerold 1990)
+ Dmax=8.2+1.8*dg-0.01*dg**2
+ IF (dg.le.2) Dmax=dg+2
+! Calculation of parameter for Weibull-distribution
+! in case b or c is calculated too small,
+! p1 and p4 respectively have to be modified
+ p1n=p1(taxid)
+ IF (p1n.lt.((1.0001-p0(taxid))/Dg)) p1n=(1.0001-p0(taxid))/Dg
+ b=p0(taxid)+p1n*Dg
+
+ Dmin = 0.1*Dg
+ IF(Dg>70) Dmin = 2.*Dg - Dmax
+ p4n=p4(taxid)
+ IF (p4n.lt.((1.0005-p2(taxid)-p3(taxid)*Dg)/Dmax)) p4n=(1.0005-p2(taxid)-p3(taxid)*Dg)/Dmax
+ c=p2(taxid)+p3(taxid)*Dg+p4n*Dmax
+ anzit=0
+ thdmax=5.0
+
+ helpz=0
+ DO
+ imax=INT((Dmax-Dmin)/clwdth)
+ if(imax.gt.30) then
+ imax= 30
+ clwdth= (Dmax-Dmin)/30.
+ end if
+ if(helpz.gt.50) goto 2277
+ helpz= helpz + 1
+
+ Fint(0)=0.
+ gx=0.
+ bhd=Dmin+0.5*clwdth
+ DO i = 1,imax
+ Fint(i)=1-exp(-((bhd-Dmin)/b)**c)
+ gx=gx+(Fint(i)-Fint(i-1))*bhd**2
+ bhd=bhd+clwdth
+ END DO
+ gx=gx*PI/4*1e-4*bz
+ IF(ABS(gx-gpatch)>0.02*gpatch) THEN
+ IF(gx>gpatch) THEN
+ c=c*gpatch/gx
+ ELSE
+ IF(Dmin<0.8*Dg) THEN
+ Dmin=Dmin*1.05
+ ELSE
+ c=c*gx/gpatch
+ ENDIF
+ ENDIF
+ ELSE
+ EXIT
+ ENDIF
+ END DO
+ bhd=Dmin+0.5*clwdth
+ DO i = 1,imax
+ n_koh=NINT((Fint(i)-Fint(i-1))*bz)
+ !***calculate height according to uni-height curve
+ IF (ehkwei) THEN
+ ! uni-height curve from Weimann (1980)
+ IF (bhd.ge.(dg-hg/2.)) THEN
+ height=hg+wei_f*(log(hg-dg+bhd)-log(hg))
+ ELSE
+ height=(hg+wei_f*(log(hg/2.)-log(hg))-1.3)*(bhd/(dg-hg/2.))**0.5+1.3
+ ENDIF
+ ELSE
+ ! uni-height curve from Kuleschis (1981)
+ height=hg*(ku_a+(ku_b/(bhd+dg/2.))*dg+(ku_c/(bhd+dg/2.)**2)*dg**2)
+ ENDIF
+ ! solution for small stands; tree dimensions below 3 m = rubbish
+ IF (height.gt.(bhd*3.)) height=bhd*3.
+ IF (height.lt.1.35) height=1.35+bhd
+ hbc=crown_base(height,c1(taxid),c2(taxid),bhd)
+ IF ((height-hbc).lt. 0.5) hbc= height - 0.5
+ CALL treeini(outunit,ctrlunit,taxid,source,bhd,height,hbc,n_koh,cform,rsap,age,hlp_lai,corr_la)
+ if(fail.eq.1) write(4444,*) 'negative root in newton', ng_locid,iz
+ bhd=bhd+clwdth
+ END DO
+
+2277 CONTINUE
+ IF (iz.ne.nlines.AND. datasets=='multi'.AND.(istart.NE.ngroups(iz+1)%locid)) WRITE(outunit,*) '-99.9'
+2266 CONTINUE
+ ENDDO !sign loop
+ CLOSE(outunit)
+ CLOSE(ctrlunit)
+ RETURN
+
+CASE(2)
+334 CONTINUE
+ CALL assign_DSW
+ inwahl=0
+ source='S'
+ PRINT *, 'If you want to use SILVA data, type: 1'
+ PRINT *, 'If you want to use levelII data from Sachsen, type: 2'
+ PRINT *, 'If you want to use single tree data with tree class information, type: 3'
+ PRINT *, ' if you want to use data like level II single tree data and generate one tree cohorts, type: 4'
+ READ(*,*) inwahl
+ IF (inwahl<1.OR.inwahl>4) THEN
+ WRITE(*,*) 'You should use integer 1, 2,3 or 4 for the choice of data source'
+ GOTO 334
+ ENDIF
+333 CONTINUE
+ IF (inwahl==1) PRINT *, ' Forest stand data set: SILVA (classification must be performed)'
+ IF (inwahl==2) PRINT *, ' Forest stand data set: levelII Sachsen (classification must be performed)'
+ IF (inwahl==3) PRINT *, ' Forest stand data set: single tree data with tree type information (classification must be performed)'
+ IF (inwahl==4) PRINT *, ' Forest stand data set: single tree data without clissification'
+ WRITE(*,'(A)')
+ WRITE(*,'(A)')' Do you want to read the input file from '
+ WRITE(*,'(A)')' 1 - the Standard 4C stand directory on data/safe/4C/4C_input/stand'
+ WRITE(*,'(A)')' 2 - or do you want to specify another directory?'
+ WRITE(*,'(A)',advance='no') ' ***Make your choice: '
+ READ(*,*) dir_flag
+ IF(dir_flag.EQ.1) THEN
+ WRITE(*,'(A)',advance='no')' Input file: '
+ READ (*,'(A)') infile
+ ELSEIF(dir_flag.EQ.2) THEN
+ WRITE(*,'(A)',advance='no')' Input directory and file: '
+ READ (*,'(A)') infile
+ ELSE
+ WRITE(*,*) 'You should use integer 1 or 2 for the choice of the input mode. Please try again!'
+ GOTO 333
+ ENDIF
+337 CONTINUE
+ cform=1;hlp_lai=0
+ IF(dir_flag.EQ.1) OPEN (inunit,FILE='/data/safe/4C/4C_input/stand/'//trim(infile),STATUS='old')
+ IF(dir_flag.EQ.2) OPEN (inunit,FILE=trim(infile),STATUS='old')
+! initialising for stand records: area = 1ha
+ area=10000
+ IF(inwahl==2.OR.inwahl==3.OR.inwahl==4) THEN
+! class width
+ clwdth=1 !set diameter of classes width
+ READ(inunit,'(a85)')zeile
+ READ(inunit,*) area
+ READ(inunit,'(a85)')zeile
+ ENDIF
+ area_factor = 1.
+ kpatchsize = area
+
+! read in file headder for descriptions, write in ini-file
+ CALL header(outunit,infile,source,cform,rsap,flag_volfunc,kpatchsize)
+
+! classification of single values into diameter cohorts
+ IF(inwahl==1) THEN
+ READ(inunit,'(a85)')zeile
+ READ(inunit,'(a85)')zeile
+ ENDIF
+
+335 CONTINUE
+ DO i=1,ncl1
+ nz(i)=0
+ zbhd(i)=0
+ zheigh(i)=0
+ zhbc(i)=0
+ ENDDO
+
+nhelp=0
+ DO
+ IF(inwahl==1) READ(inunit,*,IOSTAT=ios)xnr,baumid,bhd,height,hbc,kd,xxr,xyr,xxi,xyi
+ IF(inwahl==2.or.inwahl.eq.4) THEN
+ READ(inunit,*,IOSTAT=ios)xnr,taxid,bhd,height,hbc,age
+ nhelp = nhelp+1
+ if(bhd.le.10) bhd=11.
+ bhd=bhd/10.
+ IF(hbc>-99.99.AND.hbc<-99.8) THEN
+ hbc=crown_base(height,c1(taxid),c2(taxid),bhd)
+ IF(height-hbc<0.5) CALL error_mess(time,"crown to shallow in tree",REAL(xnr))
+ ENDIF
+ ENDIF
+ IF(inwahl==3) THEN
+ READ(inunit,*,IOSTAT=ios)xnr,taxid,bhd,height,hbc,ager,status
+ IF(taxid>=100) taxid=tax_of_BRA_id(taxid)
+ age = INT(ager)
+ bhd=bhd/10.
+ IF(hbc>-99.99.AND.hbc<-99.8) THEN
+ hbc=crown_base(height,c1(taxid),c2(taxid),bhd)
+ IF(height-hbc<0.5) CALL error_mess(time,"crown to shallow in tree",REAL(xnr))
+ IF((height-hbc)/height<0.5) hbc=0.5*height
+ IF(bhd<=3.) hbc=0.
+ ENDIF
+ ENDIF
+ IF (ios<0) exit
+ IF (xnr==-9999) exit
+ IF (inwahl==4) exit
+ icl=INT(bhd/clwdth)+1
+ IF(inwahl.eq.4.or.(inwahl==3.AND.status.NE.'F'.AND.status.NE.'Z'.AND.status.NE.'V'.and.status.NE.'H'.and.status.NE.'U'.and. status.NE.'B'))THEN
+ ELSE
+ IF(icl.gt.ncl1) icl=ncl1
+ nz(icl)=nz(icl)+1 !sum stem numbre of diameter class
+ zbhd(icl)=zbhd(icl)+bhd !sum up the diameters of a class
+ zheigh(icl)=zheigh(icl)+height !sum up height value of a class
+ zhbc(icl)=zhbc(icl)+hbc !sum up crown startin height of a class
+ ENDIF
+ ENDDO
+ nzsum=sum(nz)
+ IF(inwahl.ne.4) THEN
+ tot_crown_area=0.
+ DO i=1,ncl1
+ IF (nz(i).ne.0) THEN
+ bhd=zbhd(i)/nz(i)
+ height=zheigh(i)/nz(i)
+ hbc=zhbc(i)/nz(i)
+ if(hbc<0.025) hbc = 0.
+ if(hbc>=0.025.and.hbc<0.05) hbc =0.05
+ n_koh=NINT(nz(i)/area_factor)
+ IF(inwahl==1) THEN
+ SELECT CASE(baumid)
+ CASE(5)
+ taxid=1
+ CASE(1)
+ taxid=2
+ CASE(3)
+ taxid=3
+ CASE default
+ taxid=99
+ END select
+ ENDIF
+ tot_crown_area=tot_crown_area+n_koh*PI*(MIN(spar(taxid)%crown_a*bhd+spar(taxid)%crown_b,spar(taxid)%crown_c))**2
+ ENDIF
+ ENDDO
+
+ IF(tot_crown_area>1.1*kpatchsize) THEN
+ corr_la=kpatchsize/tot_crown_area
+ ELSE
+ corr_la=1.
+ ENDIF
+ IF(pass==1) THEN
+ mixed_tot_ca = mixed_tot_ca + tot_crown_area
+ ELSE
+ corr_la=kpatchsize/mixed_tot_ca
+ ENDIF
+
+ DO i=1,ncl1
+ IF (nz(i).ne.0) THEN
+ bhd=zbhd(i)/nz(i)
+ height=zheigh(i)/nz(i)
+ hbc=zhbc(i)/nz(i)
+ if(hbc<0.025) hbc = 0.
+ if(hbc>=0.025.and.hbc<0.05) hbc =0.05
+ n_koh=NINT(nz(i)/area_factor)
+ IF(inwahl==1) THEN
+ SELECT CASE(baumid)
+ CASE(5)
+ taxid=1
+ CASE(1)
+ taxid=2
+ CASE(3)
+ taxid=3
+ CASE default
+ taxid=99
+ END select
+ ENDIF
+! --- 4C-specific calculation:
+ WRITE(*,*) 'call :', taxid,bhd,height,hbc,nz(i),n_koh
+ IF( height<(h_sapini/100.)) then
+ call sapini(outunit,taxid, height, hbc, n_koh,age)
+ ELSE
+ CALL treeini(outunit,ctrlunit,taxid,source,bhd,height,hbc,n_koh,cform,rsap,age,hlp_lai,corr_la)
+ ENDIF
+ ENDIF
+ ENDDO
+ else if(xnr.ne.-999) then
+ n_koh = 1
+ print*, 'xnr:', xnr
+ IF( height<(h_sapini/100.)) then
+ call sapini(outunit,taxid, height, hbc, n_koh,age)
+ ELSE
+ CALL treeini(outunit,ctrlunit,taxid,source,bhd,height,hbc,n_koh,cform,rsap,age,hlp_lai,corr_la)
+ ENDIF
+ end if
+
+ IF (xnr==-9999) GOTO 335
+ if(inwahl==4.and.xnr==-999) then
+ CLOSE(inunit)
+ CLOSE(outunit)
+ CLOSE(ctrlunit)
+ RETURN
+ end if
+ if(inwahl==4) goto 335
+ CLOSE(inunit)
+ CLOSE(outunit)
+ IF(mixed_tot_ca>1.1*kpatchsize .AND. pass == 1) THEN
+ OPEN (outunit,FILE=TRIM(treefile(ip)),STATUS='replace')
+ pass = 2
+ GOTO 337
+ ENDIF
+ CLOSE(ctrlunit)
+ RETURN
+
+CASE(3)
+444 print *, ' Forest stand data set: Level2-Daten'
+ source='L'
+ WRITE(*,'(A)')
+ WRITE(*,'(A)')' Do you want to read the input file from '
+ WRITE(*,'(A)')' 1 - the Standard 4C stand directory on data/safe/4C/4C_input/stand'
+ WRITE(*,'(A)')' 2 - or do you want to specify another directory?'
+ WRITE(*,'(A)',advance='no') ' ***Make your choice: '
+ READ(*,*) dir_flag
+ IF(dir_flag.EQ.1) THEN
+ WRITE(*,'(A)',advance='no')' Input file: '
+ READ (*,'(A)') infile
+ ELSEIF(dir_flag.EQ.2) THEN
+ WRITE(*,'(A)',advance='no')' Input directory and file: '
+ READ (*,'(A)') infile
+ ELSE
+ WRITE(*,*) 'You should use integer 1 or 2 for the choice of the input mode. Please try again!'
+ GOTO 444
+ ENDIF
+ cform=1;hlp_lai=0
+ IF(dir_flag.EQ.1) OPEN (inunit,FILE='/data/safe/4C/4C_input/stand/'//trim(infile),STATUS='old')
+ IF(dir_flag.EQ.2) OPEN (inunit,FILE=trim(infile),STATUS='old')
+!------------------------------------------------------------------
+! Read in level II data according to diamter classes
+ READ(inunit,'(a85)')zeile
+ READ(inunit,'(a85)')zeile
+ READ(inunit,'(a85)')zeile
+ READ(inunit,*)age,taxid,area, rsap, &
+ dclmin, & !smallest diameter of experimentation patches
+ ndcl, & !amount diameter class
+ dcwdth !class width
+ READ(inunit,*)h_para,h_parb, & !parameter of height function after Lockow
+ (n_dc(i),i=1,ndcl) !stem numbre per diameter class
+ close(inunit)
+ clwdth=dcwdth
+
+! ---------------------------------------------------------------------
+
+! current patch size = value specified by kpatchsize
+ area_factor=int(area/kpatchsize)
+
+! read in file headder for desciption, write into ini-file
+ CALL header(outunit,infile,source,cform,rsap,flag_volfunc,kpatchsize)
+ DO i=1,ncl1
+ nz(i)=0
+ zbhd(i)=0
+ zheigh(i)=0
+ zhbc(i)=0
+ ENDDO
+
+ bhdcl=dclmin
+ DO i=1,ndcl
+ bhd=bhdcl
+ height=h_para*(0.01*bhd)**h_parb !height function after regression from Lockow
+ hbc=crown_base(height,c1(taxid),c2(taxid),bhd)
+ IF ((height-hbc).lt. 0.5) hbc= height - 0.5
+ icl=INT(bhd/clwdth)+1
+ IF(icl.gt.ncl1) icl=ncl1
+ nz(icl)=nz(icl)+n_dc(i) !sum stem numbre of diameter class
+ zbhd(icl)=zbhd(icl)+bhd*n_dc(i) !sum up diameters of a class
+ zheigh(icl)=zheigh(icl)+height*n_dc(i) !sum up height values of a class
+ zhbc(icl)=zhbc(icl)+hbc*n_dc(i) !sum up crown starting height of a class
+ bhdcl=bhdcl+dcwdth
+ ENDDO
+
+ smaldc(1)=.false.
+ DO i=1,ncl1
+ IF (smaldc(i)) THEN
+ IF (i<ncl1) smaldc(i+1)=.true.
+ ELSE
+ IF (i<ncl1) smaldc(i+1)=.false.
+ n_koh=NINT(nz(i)/area_factor)
+ IF (n_koh>0) THEN
+ IF (i<ncl1) smaldc(i+1)=.true.
+ ENDIF
+ ENDIF
+ ENDDO
+
+ bigdc(ncl1)=.false.
+ DO i=ncl1,1,-1
+ IF (bigdc(i)) THEN
+ IF (i>1) bigdc(i-1)=.true.
+ ELSE
+ IF (i>1) bigdc(i-1)=.false.
+ n_koh=NINT(nz(i)/area_factor)
+ IF (n_koh>0) THEN
+ IF (i>1) bigdc(i-1)=.true.
+ ENDIF
+ ENDIF
+ ENDDO
+
+ DO i=1,ncl1
+ IF (nz(i).ne.0) THEN
+ n_koh=NINT(nz(i)/area_factor)
+ IF (n_koh==0) THEN !if no trees in cohorte, shift trees to next class
+ zbhd(i+1)=zbhd(i+1)+zbhd(i) !add diameter to sum of next class
+ zheigh(i+1)=zheigh(i+1)+zheigh(i) !add height to sum of next class
+ zhbc(i+1)=zhbc(i+1)+zhbc(i) !add hbc to sum of next class
+ nz(i+1)=nz(i+1)+nz(i) !add trees to next class
+ nz(i)=0 !empty class
+ ELSE
+ bhd=zbhd(i)/nz(i)
+ height=zheigh(i)/nz(i)
+ hbc=zhbc(i)/nz(i)
+! --- 4C-specific calculations:
+ CALL treeini(outunit,ctrlunit,taxid,source,bhd,height,hbc,n_koh,cform,rsap,age,hlp_lai,corr_la)
+ ENDIF
+ ENDIF
+ IF (.not.bigdc(i+1)) exit
+ ENDDO
+
+ DO j=ncl1,(i+1),-1
+ IF (nz(j).ne.0) THEN
+ n_koh=NINT(nz(j)/area_factor)
+ IF (n_koh==0) THEN !if no trees in cohorte, shift trees to next class
+ zbhd(j-1)=zbhd(j-1)+zbhd(j) !add diameter to sum of next class
+ zheigh(j-1)=zheigh(j-1)+zheigh(j) !add height to sum of next class
+ zhbc(j-1)=zhbc(j-1)+zhbc(j) !add hbc to sum of next class
+ nz(j-1)=nz(j-1)+nz(j) !add trees to next class
+ nz(j)=0 !empty class
+ ELSE
+ bhd=zbhd(j)/nz(j)
+ height=zheigh(j)/nz(j)
+ hbc=zhbc(j)/nz(j)
+! --- 4C-specific calculation:
+ CALL treeini(outunit,ctrlunit,taxid,source,bhd,height,hbc,n_koh,cform,rsap,age,hlp_lai,corr_la)
+ ENDIF
+ ENDIF
+ IF (.not. smaldc(i)) exit
+ ENDDO
+ CLOSE(outunit)
+ CLOSE(ctrlunit)
+ RETURN
+
+CASE(4)
+
+ WRITE(*,*) 'Do you want to use the standard procedure - type: S'
+ WRITE(*,*) 'or Manfred Lexers input format - type: L'
+ READ(*,*) source
+ WRITE(*,'(A)',advance='no')' Input file: '
+ READ(*,'(A)') infile
+ cform=1;hlp_lai=0
+ IF(flag_volfunc.EQ.0) THEN
+ WRITE(*,'(A)',advance='no')' Input form factor (Default in 4C = 1): '
+ READ *, cform
+ ENDIF
+ OPEN (inunit,FILE=TRIM(infile),STATUS='old')
+
+ ! read in data from input-file
+ IF (source=='S') THEN
+ READ(inunit,*)source, taxid, rsap
+ READ(inunit,*) area
+ READ(inunit,*,END=10)n,k,age
+ area_factor = 1.
+ CALL header(outunit,infile,source,cform,rsap,flag_volfunc,kpatchsize)
+
+ !read in data
+ DO i=1,k
+ READ(inunit,*,END=10)bhd,height,share,hbc
+ IF(hbc>-99.99.AND.hbc<-99.8) THEN
+ hbc=crown_base(height,c1(taxid),c2(taxid),bhd)
+ END IF
+ n_koh = NINT(share*n)
+ CALL treeini(outunit,ctrlunit,taxid,source,bhd,height,hbc,n_koh,cform,rsap,age,hlp_lai,corr_la)
+ ENDDO
+ ELSE
+ READ(inunit,*) area
+ kpatchsize= area
+ CALL header(outunit,infile,source,cform,rsap,flag_volfunc,kpatchsize)
+ !read in data
+ DO
+ READ(inunit,*,iostat=ios)bhd,taxid,height,n_koh,age
+ if(ios < 0) exit
+ IF(height.ne.0 .AND. n_koh.ne.0) then
+ IF(height<h_sapini*0.01) then
+ CALL ini_gener_sap(outunit,taxid,age,height,n_koh)
+ else
+ hbc=crown_base(height,c1(taxid),c2(taxid),bhd)
+ CALL treeini(outunit,ctrlunit,taxid,source,bhd,height,hbc,n_koh,cform,rsap,age,hlp_lai,corr_la)
+ end if
+ ENDIF
+
+ ENDDO
+ ENDIF
+10 continue
+
+PRINT*, 'Bestandesblattfläche (pro ha): ', hlp_lai*area_factor
+ CLOSE(inunit)
+ CLOSE(outunit)
+ CLOSE(ctrlunit)
+
+! FORGRA data input
+
+CASE(5)
+WRITE(*,'(A)',advance='no')' Input file: '
+ READ(*,'(A)') infile
+ cform=1;hlp_lai=0
+ IF(flag_volfunc.EQ.0) THEN
+ WRITE(*,'(A)',advance='no')' Input form factor (Default in 4C = 1): '
+ READ *, cform
+ ENDIF
+ OPEN (inunit,FILE=TRIM(infile),STATUS='old')
+
+ ! read in data from input file
+ READ(inunit,*)source, rsap
+ READ(inunit,*) area
+ READ(inunit,*,END=20)n,k
+ area_factor=int(area/kpatchsize)
+
+ CALL header(outunit,infile,source,cform,rsap,flag_volfunc,kpatchsize)
+ !read in data
+ DO i=1,k
+ READ(inunit,*,END=20)bhd,height,share,hbc,age,taxid
+ n_koh=NINT(share*n/area_factor)
+ IF(height<h_sapini) THEN
+ CALL sapini(outunit,taxid, height,hbc, n_koh,age)
+ ELSE
+ CALL treeini(outunit,ctrlunit,taxid,source,bhd,height,hbc,n_koh,cform,rsap,age,hlp_lai,corr_la)
+ ENDIF
+ ENDDO
+20 CONTINUE
+
+ CLOSE(outunit)
+ CLOSE(ctrlunit)
+
+CASE default
+
+ PRINT *,' False number'
+ RETURN
+
+END select
+WRITE(*,*) 'initialisation terminated'
+ deallocate (zheigh, zbhd, zhbc, nz)
+ deallocate (smaldc, bigdc)
+ if (allocated(locid_comp))deallocate(locid_comp)
+
+END subroutine initia
+
+!****************************!
+!* SUBROUTINE TREEINI *!
+!****************************!
+
+SUBROUTINE treeini(outunit,ctrlunit,taxid,source,bhd,height,hbc,n_koh,cform,rsap,age,hlp_lai,corr_la)
+! Species (taxid) must be handed over (Beech 1, Spruce 2, Pine 3, Oak 4)
+! Source is specifying data source
+! height and hbc are read in meter and is converted later to cm
+! n_koh numbre of trees in a cohort
+! -------------------------------------------------------------------------
+ USE data_init
+ USE data_par
+ USE data_simul
+ USE data_species
+ USE data_stand
+ USE data_help
+ IMPLICIT none
+
+! ----VARIABLEN---
+ REAL :: bhd,height,hbc,hlp_lai,hfd,vd,VS,Vg,k1,k2,k3,hm,Ahc,Veff,dbc,corr_la
+ REAL :: swheight,stembio,afol,asap,dbase, dcbase,volratio,d1,d2,h1,h2,a1,b0, x_ges
+ INTEGER :: taxid, & ! species number
+ age, & ! tree age
+ n_koh
+ INTEGER :: outunit,ctrlunit !units
+ CHARACTER*85 zeile
+ CHARACTER(75):: infile
+ CHARACTER :: source
+ REAL rsap, cform, sicrsap, lifrac, rsapfit
+ INTEGER taumax, ring
+
+! function
+ REAL newton
+
+ sicrsap=rsap
+! since the fraction of wood which is sapwood generally is not measured at the
+! plots for which the model is initialized, it needs to be approximated
+! the following rsap initialisation has been fitted to a pine run at Kienhorst
+ rsapfit=1.-1.544e-8*age**4+4.343e-6*age**3-3.359e-4*age**2-4.557e-4*age
+! estimation of rsap from average diameter increase
+! attention: age of tree when first ring has been grown at 1.3 m must be estimated
+! for the time being this is set to 5
+! If hbc < h_breast, rsap and Asap (below) have to be calculated at lower height
+ hm=height
+ height=height*100
+ hbc=hbc*100
+ lifrac=1.-spar(taxid)%pss
+ IF(age>6) THEN
+ IF(hbc<h_breast) THEN
+ taumax=age-INT(hbc/h_breast*5.)
+ ELSE
+ taumax=age-5
+ ENDIF
+ rsap=0.
+ DO ring = 0,taumax-1
+ rsap=rsap+exp(ring*log(lifrac))*(2.*(taumax-ring)-1.)
+ END DO
+ rsap=rsap/taumax**2
+ ELSE
+ rsap=1.
+ ENDIF
+ rsap=rsap*corr_la
+! --- calculate height of Sapwood-Pipes and stem-mass
+ swheight=2.*hbc/3.+height/3.
+
+if(taxid.ne.12. .and. taxid.ne.13) then
+ if(taxid.eq.10) then
+ ! after BWINpro , Bergel 1974
+ hfd = (-200.31914/(height*bhd*bhd))+(0.8734/bhd) - 0.0052*log(bhd*bhd) + 7.3594/(height*bhd) + 0.46155
+ else
+ k1=par_S(taxid,1)+par_S(taxid,2)*log(bhd)+par_S(taxid,3)*log(bhd)**2
+ k2=par_S(taxid,4)+par_S(taxid,5)*log(bhd)+par_S(taxid,6)*log(bhd)**2
+ k3=par_S(taxid,7)+par_S(taxid,8)*log(bhd)+par_S(taxid,9)*log(bhd)**2
+ hfd=exp(k1+k2*log(hm)+k3*log(hm)**2)
+ end if
+! vd volume with SILVA equations
+ vd=(hfd*pi*bhd**2)/40000
+else
+! Eucalyptus, Binkley et al 2002
+ vd = 0.00005447*bhd**1.921157*(height/100)**0.950581
+! Stape et. al 2010 Fkt. VER
+ vd = (0.027*bhd**2.221*(height/100)**0.625)/500
+! Stape et al 2010 Fkt ARA
+ vd = (0.004*bhd**1.959*(height/100)**1.512)/500
+end if
+
+! vs volume with Eberswalde equations
+ if(taxid.eq.3) vs = exp(parEBW(10,1)+parEBW(10,2)*log(bhd)+parEBW(10,3)*log(hm))
+ IF(taxid==3) vd = vs
+ IF(flag_volfunc.EQ.0) THEN
+ IF(source.ne.'S') stembio= swheight*spar(taxid)%prhos*cform*pi*(bhd/2.)**2
+ IF(source.eq.'S') THEN
+ stembio=vd*spar(taxid)%prhos*1000000
+ bhd= SQRT(stembio*4/(swheight*spar(taxid)%prhos*cform*pi))
+ ENDIF
+! --- seperation of sap wood and heartwood and sap wood cross section
+ x_Ahb= 0.
+ x_sap=rsap*stembio
+ x_hrt=(1-rsap)*stembio
+ asap=rsap*pi*(bhd/2.)**2
+ ! --- estimation of leafe matter and leave area
+ x_fol=asap*spar(taxid)%pnus
+ afol=x_fol*(spar(taxid)%psla_min+0.5*spar(taxid)%psla_a)
+ hlp_lai=hlp_lai+afol*n_koh
+ ! --- fine root matter roughly estimated
+ x_frt=x_fol
+ IF(n_koh>0) WRITE(outunit,'(5f12.5,2f10.0,3i7)')x_fol,x_frt,x_sap,x_hrt,x_Ahb,height,hbc,age,n_koh,taxid
+ ELSEIF(flag_volfunc.EQ.1) THEN
+ IF (hbc>h_breast.AND.hbc<h_breast+h_bo_br_diff) hbc=h_breast
+ IF (hbc==h_breast) dbc=bhd
+ IF (hbc<h_breast) THEN
+ dbc=bhd/height*(h_breast-hbc)+bhd ! dbc = diameter at base of the crown
+ asap=PI/4.*dbc**2.*rsap
+ ELSE
+ asap=PI/4.*bhd**2.*rsap !change Martin bhd>>dbc as written ins description and rsap weg
+ ENDIF
+
+ rsap = asap/((pi*bhd*bhd)/4)
+ x_sap=spar(taxid)%prhos*asap*swheight
+ ! first guess for start values of Ahc
+ IF (hbc<=h_breast) THEN
+ Ahc=PI/4.*dbc**2.-asap
+ x_Ahb=PI/4.*(dbc*age/taumax)**2.-asap
+ ELSE
+ Ahc=PI/4.*bhd**2.*(1.-rsap)*0.04
+ Ahc=Newton(Ahc,asap,bhd,hbc,height,Vd)
+
+ if(fail.eq.1) return
+ x_Ahb=PI/4.*((bhd-(4./PI*(asap+Ahc))**0.5*h_breast/hbc)/(1.-h_breast/hbc))**2-asap
+ ENDIF
+ ! Vg for test purposes = volume if no heartwood in crown space
+ Vg=1./3.*height*asap+2./3.*hbc*asap+1./3.*hbc*x_Ahb
+ ! --- seperation of sap wood and heartwood and splitting of sap wood cross section
+ stembio=spar(taxid)%prhos*(1./3.*height*(asap+Ahc)+1./3.*hbc*(2.*asap+x_ahb+(x_ahb*ahc)**0.5))
+ volratio=1.0
+
+ if(infile=='input/bwi2_blmwert1.prn') then
+ !Spruce
+ if(taxid.eq.2)then
+ !after Wirth et al. 2002 Tree physiology
+ b0=-2.83958
+ d1=2.55203
+ d2=-0.14991
+ h1=-0.19172
+ h2=0.25739
+ a1=-0.08278
+ volratio=(exp(b0+d1*log(bhd)+d2*(log(bhd))**2+h1*log(height/100)+h2*(log(height/100))**2+a1*log(age+0.01)))/stembio
+ endif
+ !Pine
+ if(taxid.eq.3)then
+ !after Zianis et al. 2005 Silva Fennica EFI BEFs Europe
+ volratio=exp(-2.6768+7.5939*(bhd/(bhd+13))+0.0151*height/100+0.8799*log(height/100))/stembio
+ endif
+ !for douglas fir (correction after bartelink 1996, forest ecol. manag.)
+ if(taxid.eq.10)then
+ volratio=exp(-3.229+1.901*log(bhd)+0.807*log(height/100))/stembio
+ endif
+ end if
+ x_sap=x_sap*volratio
+ x_hrt=stembio*volratio-x_sap
+ x_ges=x_hrt+x_sap
+ x_Ahb=x_Ahb*volratio
+ asap=asap*volratio
+
+ if (x_hrt/x_ges .gt. 0.5 .and. taxid .eq. 2 .and. age .gt. 100) then !query too heigh heart wood percentage
+ x_hrt=0.5*stembio*volratio
+ x_sap=0.5*stembio*volratio
+ endif
+ if (x_hrt/x_ges .gt. 0.35 .and. taxid .eq. 3 .or. taxid .eq. 10) then !query too heigh heart wood percentage
+ x_hrt=0.35*stembio*volratio
+ x_sap=0.65*stembio*volratio
+ endif
+ Veff=(1./3.*height*(asap+Ahc)+1./3.*hbc*(2.*asap+x_ahb+(x_ahb*ahc)**0.5))*0.000001
+ dbase = ((x_Ahb+asap)*4./PI)**0.5
+ dcbase = ((Ahc+asap)*4./PI)**0.5
+ WRITE(ctrlunit,'(2I5, 12F12.5)') n_koh,age,height,hbc,bhd,rsap,dbase,dcbase,asap,ahc,x_ahb,Vg/1000000,Vd,Veff
+
+ ! --- estimation leaf matter and leaf area
+
+ x_fol=asap*spar(taxid)%pnus*volratio
+ afol=x_fol*(spar(taxid)%psla_min+0.5*spar(taxid)%psla_a)
+ hlp_lai=hlp_lai+afol*n_koh
+ ! --- fine root matter rough estimate
+ x_frt=x_fol
+ IF(n_koh>0) WRITE(outunit,'(5f12.5,2f10.0,3i7, 2f12.5)')x_fol,x_frt,x_sap,x_hrt,x_Ahb,height,hbc,age,n_koh,taxid, dcbase,bhd
+ ENDIF
+END subroutine treeini
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! SUBROUTINE SAPINI !
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! initilization of seedling cohorts with given height according to relations used in growth_seed
+
+SUBROUTINE sapini(outunit,taxid, height, hbc, n_koh,iage)
+ USE data_species
+ USE data_stand
+ use data_help
+ IMPLICIT none
+ REAL :: height,hbc,hhelp
+ INTEGER :: outunit,n_koh ,taxid,iage
+ REAL :: x1,x2,xacc,shelp
+ real :: rtflsp, sapwood
+
+external sapwood
+external rtflsp
+! Shootbiomass kg from height (cm), originally x_sap [mg]
+hhelp = height * 100.
+
+IF (taxid.ne.2) x_sap = exp(( LOG(hhelp)-LOG(spar(taxid)%pheight1))/spar(taxid)%pheight2)/1000000.
+ IF (taxid.eq.2) THEN
+ x1 = 1.
+ x2 = 2.
+ xacc=(1.0e-10)*(x1+x2)/2
+! solve equation for calculation of sapwood from height; determine root
+ heihelp = hhelp
+ hnspec = taxid
+ shelp=rtflsp(sapwood,x1,x2,xacc)
+ x_sap = (10**shelp)/1000000 ! transformation mg ---> kg
+ ENDIF
+
+! leaf matter
+x_fol = (spar(taxid)%seeda*(x_sap** spar(taxid)%seedb)) ![kg]
+
+! fine root matter rough estimate
+x_frt = x_fol
+
+! cross sectional area of heartwood
+x_ahb = 0.
+x_hrt = 0.
+
+ IF(n_koh>0) WRITE(outunit,'(5f12.5,2f10.0,3i7)')x_fol,x_frt,x_sap,x_hrt,x_Ahb,hhelp,hbc,iage,n_koh,taxid
+END subroutine sapini
+
+FUNCTION ran0(idum)
+ INTEGER idum,IA,IM,IQ,IR,MASK
+ REAL ran0,AM
+ PARAMETER (IA=16807,IM=2147483647,AM=1./IM,IQ=127773,IR=2836,MASK=123459876)
+ INTEGER kran
+ idum=ieor(idum,MASK)
+ kran=idum/IQ
+ idum=IA*(idum-kran*IQ)-IR*kran
+ IF (idum.lt.0) idum=idum+IM
+ ran0=AM*idum
+ idum=ieor(idum,MASK)
+ RETURN
+END
+! (C) Copr. 1986-92 Numerical Recipes Software 0)+0143$!-.
+
+SUBROUTINE header(outunit,infile,source,cform,rsap,flag_volfunc,patchsize)
+! write file headder into ini-file
+ INTEGER :: outunit, flag_volfunc
+ REAL :: rsap, cform, patchsize
+ CHARACTER(75) :: infile
+ CHARACTER :: source
+
+ WRITE(outunit,'(I1,1F12.0,A32)')flag_volfunc,patchsize,' ! = volume function, patch size'
+ WRITE(outunit,'(A15,A1,A13,A80)') '! data source= ',source,' source file= ',infile
+ WRITE(outunit,'(A57)') '! sapwood fraction and form factor now dynamic per cohort '
+ WRITE(outunit,'(a37)')'! 4C Tree Initialization File (Stand)'
+ WRITE(outunit,'(a1)')'!'
+ WRITE(outunit,'(a51)')'! contains the following data (single tree values):'
+ WRITE(outunit,'(a1)')'!'
+ WRITE(outunit,'(a31)')'! x_fol: foliage biomass (kg)'
+ WRITE(outunit,'(a33)')'! x_frt: fine root biomass (kg)'
+ WRITE(outunit,'(a31)')'! x_sap: sapwood biomass (kg)'
+ WRITE(outunit,'(a33)')'! x_hrt: heartwood biomass (kg)'
+ WRITE(outunit,'(a65)')'! x_Ahb: cross sectional area of heartwood at stem base (cm**2)'
+ WRITE(outunit,'(a27)')'! height: tree height (cm)'
+ WRITE(outunit,'(a27)')'! x_hbole: bole height (cm)'
+ WRITE(outunit,'(a27)')'! x_age: tree age (years)'
+ WRITE(outunit,'(a26)')'! n: number of trees'
+ WRITE(outunit,'(a35)')'! sp: species (integer number)'
+ WRITE(outunit,'(a33)')'! DC: diameter at crown base'
+ WRITE(outunit,'(a37)')'! DBH: diameter at breast height'
+ WRITE(outunit,'(a1)')'!'
+ WRITE(outunit,'(a120)')'! x_fol x_frt x_sap x_hrt x_Ahb height x_hbole x_age n sp DC DBH'
+END subroutine header
+
+ FUNCTION crown_base(height,c1,c2,bhd)
+IMPLICIT NONE
+REAL crown_base
+REAL height,bhd,c1,c2
+ !--- estimate crown starting height according to Nagel (1995)
+ crown_base=height*(1.-exp(-1.*(c1+c2*height/bhd)**2))
+END function crown_base
+
+ Function crown_base_eg(height,bhd)
+ IMPLICIT NONE
+ real crown_base_eg
+ real height, bhd
+
+! after Nutto etal. 2006
+ crown_base_eg= -5.12 -0.407*bhd + 1.193*height
+ if ( crown_base_eg.lt. 0.) crown_base_eg = 0.
+END function crown_base_eg
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+SUBROUTINE fdfahc(X,F,DF,asap,bhd,hbc,height,Vd,J)
+USE data_par
+USE data_simul
+use data_help
+IMPLICIT none
+REAL X,F,DF,asap,bhd,hbc,height,Vd,C,dCdX
+INTEGER J
+ fail=0
+ IF (asap+X.LE.0) THEN
+ WRITE(*,*) 'negative root at calculation C in fdfahc, program will stop'
+ STOP
+ ENDIF
+ C=(bhd-(4./PI*(asap+X))**0.5*h_breast/hbc)/(1.-h_breast/hbc)
+ dCdX=(-h_breast)/hbc/(1.-h_breast/hbc)/(4./PI*(asap+X))**0.5*2./PI
+ IF (X*(PI/4.*C**2.-asap).LE.0) THEN
+ fail=1
+ return
+ ENDIF
+ F=1./3.*height*(asap+X)+1./3.*hbc*(asap+PI/4.*C**2.+(X*(PI/4.*C**2.-asap))**0.5)-Vd*1000000.
+ DF=1./3.*(height+hbc*PI/2.*C*dCdX+hbc*0.5/(X*(PI/4.*C**2.-asap))**0.5*(PI/4.*C**2+X*PI/2.*C*dCdX-asap))
+END subroutine fdfahc
+
+FUNCTION NEWTON(X,asap,bhd,hbc,height,Vd)
+use data_help
+IMPLICIT NONE
+REAL newton
+REAL F,DF,X,DX,asap,bhd,hbc,height,Vd
+INTEGER J,stepmax
+! Newton is to be called with a start value for X
+! a subroutine NEWFDF is to be included in the main program which
+! calculates the value of the function and its derivative at X and
+! returns them in the variables F and DF
+ PARAMETER (stepmax=5000)
+ DO 7 J=1,stepmax
+ CALL fdfAhc(X,F,DF,asap,bhd,hbc,height,Vd,J)
+ if(fail.eq.1) return
+ IF(DF.EQ.0.0) THEN
+ DX=0.01*X
+ ELSE
+ DX=F/DF
+ ENDIF
+ Newton=X
+ IF(DX.GT.X) DX=X/2.
+ X=X-DX
+ IF(ABS(DX).LT.0.0005) RETURN
+7 END DO
+END
+
+SUBROUTINE ini_gener_sap(outunit,taxid,age,pl_height, nplant)
+ USE data_stand
+ USE data_par
+ USE data_species
+ USE data_soil
+ USE data_help
+ USE data_plant
+ USE data_manag
+ IMPLICIT NONE
+ integer :: nplant, &
+ taxid, &
+ nclass, &
+ i,nr, &
+ age, &
+ outunit
+ real :: pl_height, &
+ height, &
+ hhelp, &
+ hbc, &
+ sdev, &
+ help, &
+ nstot
+real :: rtflsp, sapwood
+real :: hmin_est ! empirical estimated minimum height
+
+real, dimension(:), allocatable :: hei, &
+ nschelp
+integer,dimension(:),allocatable :: nsc
+
+external sapwood
+external rtflsp
+
+sdev = hsdev(taxid)
+if (nplant.eq.0) nplant= numplant(taxid)
+height = pl_height*100
+if(height .lt. 100) then
+ hmin_est = height - height*0.2
+else
+ hmin_est = height - height*0.1
+end if
+if(nplant.eq.1) hmin_est = height
+ nclass= nint((height+2*sdev) - hmin_est) + 1
+if(nplant.eq.1) nclass =1
+ if(nplant.lt.200) nclass=1
+ allocate(hei(nclass))
+ allocate(nschelp(nclass))
+ allocate(nsc(nclass))
+ nstot = 0
+ help = (1/(sqrt(2*pi)*sdev))
+ do i = 1, nclass
+! height per class
+ hei(i) = hmin_est + (i-1)
+ nschelp(i) = help*exp(-((hei(i)-height)**2)/(2*(sdev)**2))
+ nstot = nstot + nschelp (i)
+ end do
+
+! scaling of plant number per cohort
+ do i = 1,nclass
+ nsc(i) = nint((nschelp(i)*nplant/nstot) + 0.5)
+ end do
+ if(nplant.eq.1) nsc(1) = nplant
+ do i = 1,nclass
+ hhelp = hei(i)*0.01
+ hbc=0
+ call sapini(outunit,taxid, hhelp, hbc,nsc(i),age)
+ end do
+END SUBROUTINE ini_gener_sap
diff --git a/source_code/version2.2_windows/interc.f b/source_code/version2.2_windows/interc.f
new file mode 100755
index 0000000000000000000000000000000000000000..e04713cc0ff1a0a94637d508bb58165e8dfe888b
--- /dev/null
+++ b/source_code/version2.2_windows/interc.f
@@ -0,0 +1,810 @@
+!*****************************************************************!
+!* *!
+!* 4C (FORESEE) Simulation Model *!
+!* *!
+!* *!
+!* Subroutines for: *!
+!* Interception *!
+!* *!
+!* contains: *!
+!* INTERCEP *!
+!* INTERCEP_SVEG *!
+!* INT_LAYER *!
+!* INT_COH_LOOP1 *!
+!* INT_COH_LOOP2 *!
+!* INT_COH_LOOP3 *!
+!* *!
+!* Copyright (C) 1996-2018 *!
+!* Potsdam Institute for Climate Impact Reserach (PIK) *!
+!* Authors and contributors see AUTHOR file *!
+!* This file is part of 4C and is licensed under BSD-2-Clause *!
+!* See LICENSE file or under: *!
+!* http://www.https://opensource.org/licenses/BSD-2-Clause *!
+!* Contact: *!
+!* https://gitlab.pik-potsdam.de/foresee/4C *!
+!* *!
+!*****************************************************************!
+
+SUBROUTINE intercep
+
+! Interception of the whole stand
+! Stand variables are calculated in stand_balance
+
+use data_climate
+use data_inter
+use data_evapo
+use data_par
+use data_simul
+use data_species
+use data_soil
+use data_stand
+
+implicit none
+
+type(Coh_Obj), pointer :: p ! pointer to cohort list
+real aev_c, helplai, hxx, hsum, harea, &
+ cepmax, cepmax_can, cepmax_sveg, &
+ prec_eff, & ! effective crown precipitation
+ R_crown, &
+ interc_c, & ! interception per cohort
+ pet_c ! pet per cohort
+
+! effective crown precipitation like Anders et al., 2002, S. 95
+ prec_eff = prec * (1 + 0.13 * wind * (1-crown_area/kpatchsize))
+ aev_i = 0.
+ select case (flag_inth)
+
+ case (0) ! nach Jansson (SOIL)
+! Evaporation calculated at the start (==> interception is possible to be higher)
+! evaporation of intercepted water aev_i is limited by potential evaporation
+ aev_c = max(min(int_st_can, pet), 0.)
+ int_st_can = max(int_st_can - aev_c, 0.) ! interception storage from actual day
+
+! Canopy interception
+ if (lai_can .gt. 0.) then
+ cepmax_can = ceppot_can * lai_can ! max. int. cap. of the whole stand
+ if (airtemp .ge. temp_snow) then ! frost conditions
+ lint_snow = .false.
+ hxx = 0.
+ if (cepmax_can .ge. int_st_can) hxx = cepmax_can-int_st_can
+ interc_can = min(hxx, prec)
+ else
+ lint_snow = .true.
+ hxx = 0.
+ if (2.*cepmax_can .ge. int_st_can) hxx = 2.*cepmax_can-int_st_can
+ interc_can = min(hxx, prec)
+ endif
+ else
+ cepmax_can = ceppot_can * LAI_can ! max. int. cap. of the whole stand, only canopy
+ hxx = 0.
+ if (cepmax_can .ge. int_st_can) hxx = cepmax_can-int_st_can
+ interc_can = crown_area/kpatchsize * 0.15 * prec
+ interc_can = min(hxx, interc_can)
+ aev_c = 0.
+ endif
+ int_st_can = int_st_can + interc_can
+ ! interception of ground vegetation
+ if (flag_sveg .gt. 0) call intercep_sveg (aev_c)
+ ! interception and interc.-evaporation of cohorts
+ call interc_coh (aev_c)
+ aev_i = aev_i + aev_c
+
+!......................................
+
+ case (1) ! interception for each cohort
+ ! with distribution of precipit. over all canopy layers
+ int_st_can = 0.
+ int_st_sveg = 0.
+ interc_can = 0.
+ interc_sveg = 0.
+ aev_i = 0.
+ hsum = 0.
+
+ if (prec .gt. 0. .and. highest_layer .gt. 0) then
+ call Int_layer
+ else
+ p => pt%first
+ do while (associated(p))
+ p%coh%interc = 0.
+ p => p%next
+ enddo ! p (cohorts)
+ endif
+
+ p => pt%first
+ do while (associated(p))
+ ns = p%coh%species
+ if (all_leaves_on .eq. 0) then
+ if((anz_tree.ne.0) .and. (pet .gt. 0.)) then
+ pet_c = pet * p%coh%ntreea / anz_tree
+ else
+ pet_c = 0.
+ end if
+ else
+ if (flag_eva .eq. 2 .or. flag_eva .eq. 4) then
+ pet_c = p%coh%demand
+ else
+ if((anz_tree.ne.0) .and. (pet .gt. 0.)) then
+ pet_c = pet * p%coh%rel_fol
+ else
+ pet_c = 0.
+ end if
+ p%coh%demand = pet_c
+ endif
+ endif
+
+ interc_c = p%coh%interc
+ select case (ns) ! species
+
+ case (1,12,13) ! Fagus sylvatica
+ p%coh%interc_st = p%coh%interc_st + interc_c
+ aev_c = min(p%coh%interc_st, pet_c)
+ p%coh%interc_st = max(p%coh%interc_st - aev_c, 0.)
+ interc_can = interc_can + interc_c
+ int_st_can = int_st_can + p%coh%interc_st
+
+ case (2,10,15) ! Picea abies ... Mistletoe
+ p%coh%interc_st = p%coh%interc_st + interc_c
+ aev_c = min(p%coh%interc_st, 2.*pet_c)
+ p%coh%interc_st = max(p%coh%interc_st - aev_c, 0.)
+ interc_can = interc_can + interc_c
+ int_st_can = int_st_can + p%coh%interc_st
+
+ case (3,6,7,9) ! Pinus sylvestris
+ p%coh%interc_st = p%coh%interc_st + interc_c
+ aev_c = min(p%coh%interc_st, pet_c)
+ p%coh%interc_st = max(p%coh%interc_st - aev_c, 0.)
+ interc_can = interc_can + interc_c
+ int_st_can = int_st_can + p%coh%interc_st
+
+ case (4,5,8,11) ! Quercus robur, Betula pendula
+ p%coh%interc_st = p%coh%interc_st + interc_c
+ aev_c = min(p%coh%interc_st, 2.*pet_c)
+ p%coh%interc_st = max(p%coh%interc_st - aev_c, 0.)
+ interc_can = interc_can + interc_c
+ int_st_can = int_st_can + p%coh%interc_st
+
+ case (14) ! Ground vegetation
+ p%coh%interc_st = p%coh%interc_st + interc_c
+ aev_c = min(p%coh%interc_st, pet_c)
+ p%coh%interc_st = max(p%coh%interc_st - aev_c, 0.)
+ interc_sveg = interc_sveg + interc_c
+ int_st_sveg = int_st_sveg + p%coh%interc_st
+
+ end select
+
+ p%coh%aev_i= aev_c
+ aev_i = aev_i + aev_c
+ p => p%next
+ enddo ! p (cohorts)
+
+!......................................
+
+ case (2) ! interception for each cohort
+ ! with relativ part of precipit. accord. to foliage
+ int_st_can = 0.
+ int_st_sveg = 0.
+ interc_can = 0.
+ interc_sveg = 0.
+ aev_i = 0.
+ hsum = 0.
+ stem_flow = 0.
+
+ p => pt%first
+ do while (associated(p))
+ ns = p%coh%species
+ if (flag_eva .eq. 2 .or. flag_eva .eq. 4) then
+ pet_c = p%coh%demand
+ else
+ pet_c = pet * p%coh%rel_fol
+ endif
+
+ select case (ns) ! species
+
+ case (1) ! Fagus sylvatica
+ if ((iday .ge. p%coh%day_bb) .and. (iday .le. spar(ns)%end_bb)) then
+ helplai = p%coh%t_leaf/p%coh%crown_area
+ cepmax = spar(ns)%ceppot_spec * p%coh%rel_fol * helplai
+ if (airtemp .ge. temp_snow) then ! frost conditions
+ hxx = 0.
+ if (cepmax .ge. p%coh%interc_st) hxx = cepmax - p%coh%interc_st
+ interc_c = min(hxx, prec * p%coh%rel_fol)
+ stem_flow = stem_flow + 0.2 * (prec * p%coh%rel_fol - interc_c)
+ else
+ interc_c = 0.35 * prec * p%coh%rel_fol
+ endif
+ else
+ interc_c = 0.1 * prec * p%coh%rel_fol
+ stem_flow = stem_flow + 0.16 * prec * p%coh%rel_fol
+ endif
+ p%coh%interc_st = p%coh%interc_st + interc_c
+ aev_c = min(p%coh%interc_st, 2.*pet_c)
+ p%coh%interc_st = max(p%coh%interc_st - aev_c, 0.)
+ interc_can = interc_can + interc_c
+ int_st_can = int_st_can + p%coh%interc_st
+ stem_flow = stem_flow + 0.16 * prec * p%coh%rel_fol
+
+ case (2,10,15) ! Picea abies ... Mistletoe
+ helplai = p%coh%t_leaf/p%coh%crown_area
+ cepmax = spar(ns)%ceppot_spec * p%coh%rel_fol * helplai
+ if (airtemp .ge. temp_snow) then ! frost conditions
+ hxx = 0.
+ if (cepmax .ge. p%coh%interc_st) hxx = p%coh%interc_st
+ interc_c = min(cepmax-hxx, prec * p%coh%rel_fol)
+ else
+ interc_c = 0.35 * prec * p%coh%rel_fol
+ endif
+ p%coh%interc_st = p%coh%interc_st + interc_c
+ aev_c = min(p%coh%interc_st, 2.*pet_c)
+ p%coh%interc_st = max(p%coh%interc_st - aev_c, 0.)
+ interc_can = interc_can + interc_c
+ int_st_can = int_st_can + p%coh%interc_st
+
+ case (3,6,7,9) ! Pinus sylvestris
+ helplai = p%coh%t_leaf/p%coh%crown_area
+ cepmax = spar(ns)%ceppot_spec * p%coh%rel_fol * helplai
+ if (airtemp .ge. temp_snow) then ! frost conditions
+ hxx = 0.
+ if (cepmax .ge. p%coh%interc_st) hxx = p%coh%interc_st
+ interc_c = min(cepmax-hxx, prec * p%coh%rel_fol)
+ else
+ interc_c = 0.35 * prec * p%coh%rel_fol
+ endif
+ p%coh%interc_st = p%coh%interc_st + interc_c
+ aev_c = min(p%coh%interc_st, pet_c)
+ p%coh%interc_st = max(p%coh%interc_st - aev_c, 0.)
+ interc_can = interc_can + interc_c
+ int_st_can = int_st_can + p%coh%interc_st
+
+ case (4,5,8,11) ! Quercus robur, Betula pendula
+ if ((iday .ge. p%coh%day_bb) .and. (iday .le. spar(ns)%end_bb)) then
+ helplai = p%coh%t_leaf/p%coh%crown_area
+ cepmax = spar(ns)%ceppot_spec * p%coh%rel_fol * helplai
+ if (airtemp .ge. temp_snow) then ! frost conditions
+ hxx = 0.
+ if (cepmax .ge. p%coh%interc_st) hxx = p%coh%interc_st
+ interc_c = min(cepmax-hxx, prec * p%coh%rel_fol)
+ else
+ interc_c = 0.35 * prec * p%coh%rel_fol
+ endif
+ else
+ interc_c = 0.05 * prec * p%coh%rel_fol
+ endif
+ p%coh%interc_st = p%coh%interc_st + interc_c
+ aev_c = min(p%coh%interc_st, 2.*pet_c)
+ p%coh%interc_st = max(p%coh%interc_st - aev_c, 0.)
+ interc_can = interc_can + interc_c
+ int_st_can = int_st_can + p%coh%interc_st
+
+ case (14) ! Ground vegetation
+ if ((iday .ge. p%coh%day_bb) .and. (iday .le. spar(ns)%end_bb)) then
+ helplai = p%coh%t_leaf/p%coh%crown_area
+ cepmax = spar(ns)%ceppot_spec * p%coh%rel_fol * helplai
+ if (airtemp .ge. temp_snow) then ! frost conditions
+ hxx = 0.
+ if (cepmax .ge. p%coh%interc_st) hxx = p%coh%interc_st
+ interc_c = min(cepmax-hxx, prec * p%coh%rel_fol)
+ else
+ interc_c = 0.35 * prec * p%coh%rel_fol
+ endif
+ else
+ if (iday .eq. spar(ns)%end_bb+1) then
+ interc_c = p%coh%interc_st
+ else
+ interc_c = 0.
+ endif
+ endif
+ p%coh%interc_st = p%coh%interc_st + interc_c
+ aev_c = min(p%coh%interc_st, pet_c)
+ p%coh%interc_st = max(p%coh%interc_st - aev_c, 0.)
+ interc_sveg = interc_sveg + interc_c
+ int_st_sveg = int_st_sveg + p%coh%interc_st
+ end select
+ p%coh%aev_i= aev_c
+ aev_i = aev_i + aev_c
+ p => p%next
+ enddo ! p (cohorts)
+
+!......................................
+
+ case (3) ! interception pine like Anders et al., 2002, S. 95
+ cepmax_can = ceppot_can * lai_can ! max. int. cap. of the whole stand
+ cepmax_can = 2.9 ! effect. crown storage capacity of pine according to Anders
+ R_crown = 0.083 ! s/m aerodyn. resistance of the crown of pine (Anders)
+ if (cepmax_can .gt. prec_eff) then
+ interc_can = (crown_area/kpatchsize) * prec_eff
+ else
+ interc_can = cepmax_can + (prec_eff - cepmax_can) * wind * R_crown
+ interc_can = (crown_area/kpatchsize) * interc_can
+ endif
+ int_st_can = int_st_can + interc_can
+ aev_c = int_st_can ! imediate total evaporation
+ int_st_can = 0. ! interception storage from actual day
+
+!......................................
+
+ case (4) ! from Refr.-Bez. (reference notation) (polynom.) for Level II, Brandenburg
+ interc_can = 0.2 * prec
+ int_st_can = int_st_can + interc_can
+ ! evaporation of intercepted water aev_i is limited by potential evaporation
+ aev_c = min(int_st_can, pet)
+ int_st_can = max(int_st_can - aev_c, 0.) ! interception storage from actual day
+
+ ! Interception of ground vegetation
+ if (flag_sveg .gt. 0) call intercep_sveg (aev_c)
+
+ ! interception and interc.-evaporation of cohorts
+ call interc_coh (aev_c)
+ aev_i = aev_i + aev_c
+
+ case (5) ! 35% of precipitation (for spruce)
+ interc_can = 0.3 * prec
+ int_st_can = int_st_can + interc_can
+ ! evaporation of intercepted water aev_i is limited by potential evaporation
+ aev_c = min(int_st_can, pet)
+ int_st_can = max(int_st_can - aev_c, 0.) ! interception storage from actual day
+
+ ! interception of ground vegetation
+ if (flag_sveg .gt. 0) call intercep_sveg (aev_c)
+
+ ! interception and interc.-evaporation of cohorts
+ call interc_coh (aev_c)
+ aev_i = aev_i + aev_c
+
+ case (6) ! no interception
+ interc_can = 0.
+ aev_c = 0.
+ interc_sveg = 0.
+ end select
+
+if (flag_dayout .eq. 3) then
+ write(666,*) 'day, prec, prec_eff: ', iday, prec, prec_eff
+endif
+
+! cumul. interc.
+ int_cum_can = int_cum_can + interc_can
+ int_cum_sveg = int_cum_sveg + interc_sveg
+ if(flag_dayout.eq.3) write(1414,*) iday, aev_i
+END subroutine intercep
+
+!**************************************************************
+
+SUBROUTINE Int_layer
+
+! Interception per canopy layer
+! calculation for each cohort in subroutine int_coh_loop1 (rain)
+! and int_coh_loop3 (int_coh_loop2 old) for snow
+
+ !*** Declaration part ***!
+ USE data_climate
+ USE data_inter
+ USE data_par
+ USE data_simul
+ USE data_species
+ USE data_stand
+
+ IMPLICIT NONE
+
+ ! variables required for technical reasons
+ INTEGER :: i
+ REAL :: intlay, itest ! interception per layer
+ REAL :: help
+ TYPE(Coh_Obj), Pointer :: p ! pointer to cohort list
+
+ !*** Calculation part ***!
+ precpool = 0.
+ itest = 0.
+ intlay = 0.
+
+ ! cohort loop
+ p => pt%first
+ DO WHILE (ASSOCIATED(p))
+
+ p%coh%intcap = 0.
+ p%coh%interc = 0.
+ p%coh%prel = 0.
+
+ p => p%next
+ END DO ! cohort loop
+
+ ! above the canopy there is 100 % precipitation
+ precpool(highest_layer) = prec
+
+ if (airtemp .ge. temp_snow) then ! frost conditions
+
+ lint_snow = .false.
+ do i = highest_layer, lowest_layer, -1
+
+ intlay = 0.
+ CALL int_coh_loop1(i,intlay)
+ ! Assum.: all layers are above eachother, that means precip. is reduc. layer by layer due to interception.
+ precpool(i-1) = precpool(i) - intlay
+ itest = itest + intlay
+ enddo ! end layer loop
+
+ else
+
+ lint_snow = .true.
+ CALL int_coh_loop3(intlay)
+ endif ! airtemp
+
+ ! stand precipitation unto the ground
+ DO i = lowest_layer - 2, 0, -1
+ precpool(i)=precpool(i+1)
+ END DO
+ itest = 0.
+
+END SUBROUTINE Int_layer
+
+!**************************************************************
+
+SUBROUTINE int_coh_loop1(i,intlay)
+
+! interception for each canopy layer of each cohort
+
+ !*** Declaration part ***!
+ USE data_simul
+ USE data_soil
+ USE data_species
+ USE data_stand
+
+ IMPLICIT NONE
+
+ ! variables required for technical reasons
+ TYPE(Coh_Obj), Pointer :: p ! pointer to cohort list
+ INTEGER :: i, itop ! layer
+ REAL :: intlay ! interception per layer
+ REAL :: interc_c, & ! interception per cohort
+ cepcap ! Int.-Kapaz. fuer diese Variante reduzieren
+ REAL :: help, hxx
+
+ interc_c = 0.
+ p => pt%first
+
+ ! cohort loop in layer i
+ DO WHILE (ASSOCIATED(p))
+
+ ns=p%coh%species
+
+ IF ((iday >= p%coh%day_bb) .AND. (iday <= spar(p%coh%species)%end_bb)) then
+ IF (i <= p%coh%toplayer .AND. i >= p%coh%botlayer) THEN
+ p%coh%prel(i) = precpool(i) * p%coh%BG(i) * p%coh%nTreeA
+
+ select case (ns) ! species
+
+ case (1) ! Fagus sylvatica
+ if (p%coh%t_leaf .gt. 0.) then
+ cepcap = spar(ns)%ceppot_spec * 0.5
+ p%coh%intcap(i) = cepcap * p%coh%leafArea(i) * p%coh%rel_fol / &
+ (kpatchsize * p%coh%BG(i))
+ ! intcap is related to the projection area and has to be modified
+ ! by the same factor by that the projection area is being modified
+ ! in case sumBG > patchsize
+ p%coh%intcap(i)=p%coh%intcap(i) * MIN(kpatchsize/vStruct(i)%sumBG, 1.)
+ ! interc per patch! Since the projection area changes interc has to
+ ! be related to the patch in each layer
+ hxx = 0.
+ if (p%coh%intcap(i) .ge. p%coh%interc_st/dz) hxx = p%coh%interc_st/dz ! interc storage spead across all layers
+ interc_c = min(p%coh%prel(i), p%coh%intcap(i)-hxx)
+ else
+ interc_c = 0.1 * p%coh%prel(i)
+ endif
+
+ case (2,10,15) ! Picea abies ... mistletoe
+ cepcap = spar(ns)%ceppot_spec * 0.5
+ p%coh%intcap(i) = cepcap * p%coh%leafArea(i) * p%coh%rel_fol / &
+ (kpatchsize * p%coh%BG(i))
+ ! intcap is related to the projection area and has to be modified
+ ! by the same factor by that the projection area is being modified
+ ! in case sumBG > patchsize
+ p%coh%intcap(i)=p%coh%intcap(i) * MIN(kpatchsize/vStruct(i)%sumBG, 1.)
+ ! interc per patch! Since the projection area changes interc has to
+ ! be related to the patch in each layer
+ hxx = 0.
+ if (p%coh%intcap(i) .ge. p%coh%interc_st/dz) hxx = p%coh%interc_st/dz ! interc storage spead across all layers
+ interc_c = min(p%coh%prel(i), p%coh%intcap(i)-hxx)
+
+ case (3,6,7,9) ! Pinus sylvestris
+ cepcap = spar(ns)%ceppot_spec * 0.5
+ p%coh%intcap(i) = cepcap * p%coh%leafArea(i) * p%coh%rel_fol / &
+ (kpatchsize * p%coh%BG(i))
+ ! intcap is related to the projection area and has to be modified
+ ! by the same factor by that the projection area is being modified
+ ! in case sumBG > patchsize
+ p%coh%intcap(i)=p%coh%intcap(i) * MIN(kpatchsize/vStruct(i)%sumBG, 1.)
+ ! interc per patch! Since the projection area changes interc has to
+ ! be related to the patch in each layer
+ hxx = 0.
+ if (p%coh%intcap(i) .ge. p%coh%interc_st/dz) hxx = p%coh%interc_st/dz ! interc storage spead across all layers
+ interc_c = min(p%coh%prel(i), p%coh%intcap(i)-hxx)
+
+ case (4,5,8,11) ! Quercus robur, Betula pendula
+ if (p%coh%t_leaf .gt. 0.) then
+ cepcap = spar(ns)%ceppot_spec * 0.5
+ p%coh%intcap(i) = cepcap * p%coh%leafArea(i) * p%coh%rel_fol / &
+ (kpatchsize * p%coh%BG(i))
+ ! intcap is related to the projection area and has to be modified
+ ! by the same factor by that the projection area is being modified
+ ! in case sumBG > patchsize
+ p%coh%intcap(i)=p%coh%intcap(i) * MIN(kpatchsize/vStruct(i)%sumBG, 1.)
+ ! interc per patch! Since the projection area changes interc has to
+ ! be related to the patch in each layer
+ hxx = 0.
+ if (p%coh%intcap(i) .ge. p%coh%interc_st/dz) hxx = p%coh%interc_st/dz ! interc storage spead across all layers
+ interc_c = min(p%coh%prel(i), p%coh%intcap(i)-hxx)
+ else
+ interc_c = 0.1 * p%coh%prel(i)
+ endif
+
+ case (14) ! Ground vegetation
+ if (p%coh%t_leaf .gt. 0.) then
+ cepcap = spar(ns)%ceppot_spec * 0.5
+ p%coh%intcap(i) = cepcap * p%coh%leafArea(i) * p%coh%rel_fol / &
+ (kpatchsize * p%coh%BG(i))
+ ! intcap is related to the projection area and has to be modified
+ ! by the same factor by that the projection area is being modified
+ ! in case sumBG > patchsize
+ p%coh%intcap(i)=p%coh%intcap(i) * MIN(kpatchsize/vStruct(i)%sumBG, 1.)
+ ! interc per patch! Since the projection area changes interc has to
+ ! be related to the patch in each layer
+ hxx = 0.
+ if (p%coh%intcap(i) .ge. p%coh%interc_st/dz) hxx = p%coh%interc_st/dz ! interc storage spead across all layers
+ interc_c = min(p%coh%prel(i), p%coh%intcap(i)-hxx)
+ else
+ interc_c = 0.0
+ endif
+
+ end select
+
+ ENDIF ! i - layer
+ ELSE
+ IF (i == p%coh%toplayer) THEN
+ itop = i
+ if(cover.ne.0) p%coh%prel(itop) = precpool(i) * p%coh%nTreeA *p%coh%crown_area/crown_area
+
+ select case (ns) ! species
+
+ case (1) ! Fagus sylvatica p%coh%x_tb
+ interc_c = 0.2 * p%coh%prel(itop)
+
+ case (2,10,15) ! Picea abies ... Mistletoe
+ interc_c = 0.1 * p%coh%prel(itop)
+
+ case (3,6,7,9) ! Pinus sylvestris
+ interc_c = 0.1 * p%coh%prel(itop)
+
+ case (4,5,8,11) ! Quercus robur, Betula pendula
+ interc_c = 0.1 * p%coh%prel(itop)
+
+ case (14) ! Ground vegetation
+ interc_c = 0.
+
+ end select
+ ENDIF ! i - layer
+ END IF ! iday
+
+ if (interc_c .le. 1E-15) interc_c = 0.
+ p%coh%interc = p%coh%interc + interc_c
+ intlay = intlay + interc_c
+ interc_c = 0.
+ p => p%next
+ END DO ! cohort loop
+
+END SUBROUTINE int_coh_loop1
+
+!**************************************************************
+
+SUBROUTINE int_coh_loop2(i,intlay)
+
+! snow interception for each canopy layer of each cohort
+ !*** Declaration part ***!
+ USE data_simul
+ USE data_soil
+ USE data_species
+ USE data_stand
+ IMPLICIT NONE
+
+ ! variables required for technical reasons
+ TYPE(Coh_Obj), Pointer :: p ! pointer to cohort list
+ INTEGER :: i ! layer
+ REAL :: intlay ! interception per layer
+ REAL :: interc_c, & ! interception per cohort
+ cepcap ! Int.-Kapaz. fuer diese Variante reduzieren
+ REAL :: help, hxx
+
+ interc_c = 0.
+ p => pt%first
+
+ ! cohort loop in layer i
+ DO WHILE (ASSOCIATED(p))
+ ns=p%coh%species
+ IF (i <= p%coh%toplayer .AND. i >= p%coh%botlayer) THEN
+
+ select case (ns) ! species
+
+ case (1) ! Fagus sylvatica
+ if(cover.ne.0) p%coh%prel(i) = precpool(i) * p%coh%nTreeA *p%coh%crown_area/(kpatchsize*cover)
+ if (p%coh%t_leaf .gt. 0.) then
+ interc_c = 0.35 * p%coh%prel(i)
+ else
+ interc_c = 0.1 * p%coh%prel(i)
+ endif
+
+ case (2,10,15) ! Picea abies... Mistletoe
+ p%coh%prel(i) = precpool(i) * p%coh%BG(i) * p%coh%nTreeA
+ interc_c = 0.35 * p%coh%prel(i)
+
+ case (3,6,7,9) ! Pinus sylvestris
+ p%coh%prel(i) = precpool(i) * p%coh%BG(i) * p%coh%nTreeA
+ interc_c = 0.35 * p%coh%prel(i)
+
+ case (4,5,8,11) ! Quercus robur, Betula pendula
+ p%coh%prel(i) = precpool(i) * p%coh%nTreeA *p%coh%crown_area/kpatchsize
+ if (p%coh%t_leaf .gt. 0.) then
+ interc_c = 0.35 * p%coh%prel(i)
+ else
+ interc_c = 0.1 * p%coh%prel(i)
+ endif
+
+ case (14) ! Ground vegetation
+ if (p%coh%t_leaf .gt. 0.) then
+ p%coh%prel(i) = precpool(i) * p%coh%BG(i) * p%coh%nTreeA
+ interc_c = 0.35 * p%coh%prel(i)
+ else
+ interc_c = 0.
+ endif
+ end select
+ if (interc_c .le. 1E-15) interc_c = 0.
+ p%coh%interc = p%coh%interc + interc_c
+ END IF
+
+1313 CONTINUE
+ intlay = intlay + interc_c
+ interc_c = 0.
+ p => p%next
+ END DO ! cohort loop
+
+END SUBROUTINE int_coh_loop2
+
+!**************************************************************
+
+SUBROUTINE int_coh_loop3(intlay)
+
+! snow interception for each cohort
+ !*** Declaration part ***!
+ USE data_climate
+ USE data_simul
+ USE data_soil
+ USE data_species
+ USE data_stand
+ IMPLICIT NONE
+
+ ! variables required for technical reasons
+ TYPE(Coh_Obj), Pointer :: p ! pointer to cohort list
+ INTEGER :: itop ! toplayer
+ REAL :: intlay ! canopy interception
+ REAL :: interc_c, & ! interception per cohort
+ cepcap ! Int.-Kapaz. fuer diese Variante reduzieren
+ REAL :: help, hxx
+ real test_prel
+
+ test_prel = 0.
+ interc_c = 0.
+ p => pt%first
+
+ ! cohort loop
+ DO WHILE (ASSOCIATED(p))
+ ns=p%coh%species
+ itop = p%coh%toplayer
+ if(cover.ne.0) p%coh%prel(itop) = prec * p%coh%nTreeA *p%coh%crown_area/crown_area
+ test_prel = test_prel + p%coh%prel(itop)
+
+ select case (ns) ! species
+
+ case (1) ! Fagus sylvatica p%coh%x_tb
+ if (p%coh%t_leaf .gt. 0.) then
+ interc_c = 0.35 * p%coh%prel(itop)
+ else
+ interc_c = 0.1 * p%coh%prel(itop)
+ endif
+
+ case (2,10,15) ! Picea abies, Douglas Fir, Mistletoe (better: nspec_tree+2)
+ interc_c = 0.35 * p%coh%prel(itop)
+
+ case (3,6,7,9) ! Pinus sylvestris, P. contorta, P. ponder. P. halep.
+ interc_c = 0.6 * p%coh%prel(itop)
+
+ case (4,5,8,11) ! Quercus robur, Betula pendula, Populus, Robinia
+ if (p%coh%t_leaf .gt. 0.) then
+ interc_c = 0.35 * p%coh%prel(itop)
+ else
+ interc_c = 0.1 * p%coh%prel(itop)
+ endif
+
+ case (14) ! Ground vegetation
+ if (p%coh%t_leaf .gt. 0.) then
+ interc_c = 0.35 * p%coh%prel(itop)
+ else
+ interc_c = 0.
+ endif
+ end select
+ if (interc_c .le. 1E-15) interc_c = 0.
+ p%coh%interc = p%coh%interc + interc_c
+
+1313 CONTINUE
+ intlay = intlay + interc_c
+ interc_c = 0.
+ p => p%next
+ END DO ! cohort loop
+continue
+
+END SUBROUTINE int_coh_loop3
+
+!**************************************************************
+
+SUBROUTINE intercep_sveg (aev_c)
+
+! Interception of ground vegetation
+
+use data_climate
+use data_inter
+use data_evapo
+use data_par
+use data_species
+use data_stand
+
+implicit none
+
+real aev_c, & ! canopy interception evaporation
+ hxx, &
+ cepmax_sveg
+
+ cepmax_sveg = ceppot_sveg * lai_sveg ! max. int. cap. of the whole stand
+ if (airtemp .ge. temp_snow) then ! frost conditions
+ hxx = 0.
+ if (cepmax_sveg .ge. int_st_sveg) hxx = cepmax_sveg-int_st_sveg
+ interc_sveg = min(hxx, prec-interc_can)
+ else
+ interc_sveg = 0.35 * (prec-interc_can)
+ endif
+ int_st_sveg = int_st_sveg + interc_sveg
+ ! evaporation of intercepted water aev_i is limited by potential evaporation
+ aev_i = min(int_st_sveg, pet-aev_c)
+ int_st_sveg = max(int_st_sveg - aev_i, 0.) ! interception storage from actual day
+
+END SUBROUTINE intercep_sveg
+
+!**************************************************************
+
+SUBROUTINE interc_coh (aev_c)
+
+! Interception of ground vegetation
+
+use data_climate
+use data_inter
+use data_evapo
+use data_species
+use data_stand
+
+implicit none
+
+type(Coh_Obj), pointer :: p ! pointer to cohort list
+integer ns
+real aev_c, & ! canopy interception evaporation
+ cepmax_sveg
+ p => pt%first
+ do while (associated(p))
+ ns = p%coh%species
+ if (ns .le. nspec_tree .OR. ns .eq. nspec_tree+2) then
+ ! trees and mistletoe
+ p%coh%interc_st = int_st_can * p%coh%rel_fol
+ p%coh%aev_i= aev_c * p%coh%rel_fol
+ else
+ ! ground vegetation
+ p%coh%interc_st = int_st_sveg * p%coh%rel_fol
+ p%coh%aev_i= aev_i * p%coh%rel_fol
+ endif
+
+ p => p%next
+ enddo ! p (cohorts)
+
+END SUBROUTINE interc_coh
diff --git a/source_code/version2.2_windows/main_4c.f b/source_code/version2.2_windows/main_4c.f
new file mode 100755
index 0000000000000000000000000000000000000000..7f62f35972aa5ddd1f7136e4b793ff753996dd00
--- /dev/null
+++ b/source_code/version2.2_windows/main_4c.f
@@ -0,0 +1,29 @@
+
+!*****************************************************************!
+!* *!
+!* 4C (FORESEE) Simulation Model *!
+!* main program for 4C *!
+!* Unix/Linux Version *!
+!* *!
+!* 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 *!
+!* *!
+!*****************************************************************!
+ PROGRAM foresee
+
+ USE data_simul
+
+ actDir = ''
+
+ CALL prepare_global
+
+ CALL sim_control
+
+ END PROGRAM foresee
+
diff --git a/source_code/version2.2_windows/man_lic.f b/source_code/version2.2_windows/man_lic.f
new file mode 100755
index 0000000000000000000000000000000000000000..b663e663beece83278d92737720e953833489087
--- /dev/null
+++ b/source_code/version2.2_windows/man_lic.f
@@ -0,0 +1,219 @@
+!*****************************************************************!
+!* 4C (FORESEE) Simulation Model *!
+!* *!
+!* *!
+!* contains: *!
+!* SR man_liocourt_ini *!
+!* SR liocourt_manag *!
+!* *!
+!* Copyright (C) 1996-2018 *!
+!* Potsdam Institute for Climate Impact Reserach (PIK) *!
+!* Authors and contributors see AUTHOR file *!
+!* This file is part of 4C and is licensed under BSD-2-Clause *!
+!* See LICENSE file or under: *!
+!* http://www.https://opensource.org/licenses/BSD-2-Clause *!
+!* Contact: *!
+!* https://gitlab.pik-potsdam.de/foresee/4C *!
+!* *!
+!*****************************************************************!
+
+Subroutine man_liocourt_ini
+
+ USE data_manag
+ USE data_simul
+ USE data_plant
+ USE data_species
+
+implicit none
+
+integer :: manag_unit,i
+character(len=150) :: filename
+logical :: ex
+character :: text
+
+
+manag_unit=getunit()
+filename = manfile(ip)
+call testfile(filename,ex)
+open(manag_unit,file=trim(filename))
+
+ allocate(thin_flag1(nspec_tree))
+
+ thin_flag1=-1
+
+ ! read head of data-file
+ do
+ read(manag_unit,*) text
+ if(text .ne. '!')then
+
+ backspace(manag_unit);exit
+ endif
+ enddo
+
+read(manag_unit,*) thin_int
+read(manag_unit,*) dbh_max
+read(manag_unit,*) lic_a
+read(manag_unit,*) lic_b
+read(manag_unit,*) spec_lic
+read(manag_unit,*) thin_proc
+
+if(flag_reg.ne.0) then
+ read(manag_unit,*) m_numclass
+ do i = 1, m_numclass
+ read(manag_unit,*) m_numplant(spec_lic,i), m_specpl(spec_lic,i), m_plant_height(spec_lic,i), m_plant_hmin(spec_lic,i), m_pl_age(spec_lic,i), m_hsdev(spec_lic,i)
+ end do
+end if
+
+
+close(manag_unit)
+
+end Subroutine man_liocourt_ini
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+Subroutine liocourt_manag
+
+USE data_manag
+USE data_stand
+USE data_species
+USE data_simul
+USE data_par
+
+implicit none
+
+integer :: i, ih, nspech
+real :: diamh, help, stembiom, stembiom_us, stembiom_all, stembiom_re, target_help, target_biom
+
+
+target_biom=0.
+if(Modulo(time,thin_int).eq.0) then
+
+
+! calculation of mean diameter (correspondung to med_diam) and basal area of stand
+ zeig => pt%first
+ DO
+ IF (.NOT. ASSOCIATED(zeig)) EXIT
+
+! Modification for V Kint: no test for diameter
+ IF((zeig%coh%ntreea>0).and.zeig%coh%species.eq.spec_lic.and.zeig%coh%underst.eq.0) THEN
+ ! forester definition
+! overstorey
+ stembiom = stembiom + (zeig%coh%x_sap + zeig%coh%x_hrt)*zeig%coh%ntreea
+
+ ! Trees with DBH = 0 for population and per species
+ ELSE IF( (zeig%coh%ntreea>0).and.zeig%coh%species.eq.spec_lic.and.zeig%coh%underst.eq.1) THEN
+! seedings/regeneration
+ stembiom_re = stembiom_re + (zeig%coh%x_sap + zeig%coh%x_hrt)*zeig%coh%ntreea
+ ELSE if((zeig%coh%ntreea>0).and.zeig%coh%species.eq.spec_lic.and.zeig%coh%underst.eq.2) THEN
+! understorey
+ stembiom_us = stembiom_us + (zeig%coh%x_sap + zeig%coh%x_hrt)*zeig%coh%ntreea
+
+ ENDIF
+ zeig => zeig%next
+ ENDDO
+
+! mean diamteer for over and understorey
+stembiom_all = stembiom + stembiom_us
+target_help = stembiom_all*(thin_proc)
+ntree_lic(1,spec_lic)=int(lic_a*exp(lic_b*2.5))
+
+ Do i=1,21
+ help=(dclass_w*i + dclass_w*(i+1))/2.
+ ntree_lic(i+1,spec_lic)= int(lic_a*exp(lic_b*help))*kpatchsize/10000.
+ end do
+
+ zeig=>pt%first
+ do while (target_biom.lt. target_help)
+ if(.not.associated(zeig)) exit
+ if(zeig%coh%diam.gt. dbh_max) then
+ zeig%coh%ntreem = zeig%coh%ntreea
+ zeig%coh%ntreea = 0
+ zeig%coh%nta = 0
+ diam_class(i,spec_lic) = diam_class(i,spec_lic) - 1
+ target_biom = target_biom + zeig%coh%ntreem*(zeig%coh%x_sap + zeig%coh%x_hrt)
+ end if
+ zeig => zeig%next
+
+ end do
+
+ do i = 1, num_class
+
+ zeig=>pt%first
+ do
+ if(.not.associated(zeig)) exit
+ if(target_help.le.target_biom) exit
+
+ nspech = zeig%coh%species
+ diamh = zeig%coh%diam
+ ih= i-1
+ if(diamh.le. dbh_max .and.nspech.eq.spec_lic) then
+
+ if(diamh.gt.dclass_w*ih .and. diamh.le. dclass_w*(ih+1) .and. zeig%coh%ntreea.ne.0) then
+ if((diam_class(i,1)-zeig%coh%ntreea).ge. ntree_lic(i,1)) then
+ zeig%coh%ntreem = zeig%coh%ntreea
+ zeig%coh%ntreea = 0
+ zeig%coh%nta = 0
+ diam_class(i,spec_lic) = diam_class(i,spec_lic) - zeig%coh%ntreem
+ target_biom = target_biom + zeig%coh%ntreem*(zeig%coh%x_sap + zeig%coh%x_hrt)
+
+ else if(diam_class(i,1).gt. ntree_lic(i,1)) then
+
+ zeig%coh%ntreem= diam_class(i,spec_lic) - ntree_lic(i,spec_lic)
+ zeig%coh%ntreea = zeig%coh%ntreea - zeig%coh%ntreem
+ zeig%coh%nta = zeig%coh%nta - zeig%coh%ntreem
+ diam_class(i,spec_lic) = diam_class(i,spec_lic) - zeig%coh%ntreem
+ target_biom = target_biom + zeig%coh%ntreem*(zeig%coh%x_sap + zeig%coh%x_hrt)
+
+ end if
+
+ end if
+ end if
+ zeig => zeig%next
+ if (target_biom.ge.target_help) exit
+
+ end do ! cohort loop
+
+ end do ! loop i for diamter classes
+
+! litter pools
+ zeig=>pt%first
+
+ do
+ if(.not.associated(zeig)) exit
+ if(zeig%coh%ntreem>0.and.zeig%coh%species.eq.spec_lic) then
+! all parts of trees are input for litter excepting stems
+ zeig%coh%litC_fol = zeig%coh%litC_fol + zeig%coh%ntreem*(1.-spar(spec_lic)%psf)*zeig%coh%x_fol*cpart
+ zeig%coh%litN_fol = zeig%coh%litN_fol + zeig%coh%ntreem*((1.-spar(spec_lic)%psf)*zeig%coh%x_fol*cpart)/spar(spec_lic)%cnr_fol
+ zeig%coh%litC_frt = zeig%coh%litC_frt + zeig%coh%ntreem*zeig%coh%x_frt*cpart
+ zeig%coh%litN_frt = zeig%coh%litN_frt + zeig%coh%ntreem*zeig%coh%x_frt*cpart/spar(spec_lic)%cnr_frt
+ zeig%coh%litC_tb = zeig%coh%litC_tb + zeig%coh%ntreem*zeig%coh%x_tb*cpart
+ zeig%coh%litN_tb = zeig%coh%litN_tb + zeig%coh%ntreem*zeig%coh%x_tb*cpart/spar(spec_lic)%cnr_tbc
+ zeig%coh%litC_crt = zeig%coh%litC_crt + zeig%coh%ntreem*zeig%coh%x_crt*cpart
+ zeig%coh%litN_crt = zeig%coh%litN_crt + zeig%coh%ntreem*zeig%coh%x_crt*cpart/spar(spec_lic)%cnr_crt
+ endif
+ zeig=>zeig%next
+
+ enddo
+
+! calculation of total dry mass of all harvested trees
+ sumvsab = 0.
+ sumvsab_m3 = 0.
+ svar%sumvsab = 0.
+
+ zeig=>pt%first
+ do
+ if(.not.associated(zeig)) exit
+ nspech = zeig%coh%species
+ if(nspech.eq.spec_lic) then
+ sumvsab = sumvsab + zeig%coh%ntreem*(zeig%coh%x_sap + zeig%coh%x_hrt)
+ sumvsab_m3 = sumvsab_m3 + zeig%coh%ntreem*(zeig%coh%x_sap + zeig%coh%x_hrt)/(spar(nspech)%prhos*1000000)
+ svar(nspech)%sumvsab = svar(nspech)%sumvsab + zeig%coh%ntreem*(zeig%coh%x_sap + zeig%coh%x_hrt)
+ end if
+ zeig=>zeig%next
+ end do
+ sumvsab = sumvsab * 10000./kpatchsize ! kg/ha
+ sumvsab_m3 = sumvsab_m3 * 10000./kpatchsize ! kg/ha
+ svar(spec_lic)%sumvsab = svar(spec_lic)%sumvsab * 10000./kpatchsize ! kg/ha
+ cumsumvsab = cumsumvsab + sumvsab
+
+end if ! loop management time
+
+end Subroutine liocourt_manag
diff --git a/source_code/version2.2_windows/manag_practices.f b/source_code/version2.2_windows/manag_practices.f
new file mode 100755
index 0000000000000000000000000000000000000000..54b292c0e16cb6979d7a8233eef3db306424c6f3
--- /dev/null
+++ b/source_code/version2.2_windows/manag_practices.f
@@ -0,0 +1,1400 @@
+!*****************************************************************!
+!* *!
+!* 4C (FORESEE) Simulation Model *!
+!* *!
+!* *!
+!* contains: *!
+!* SR tending *!
+!* SR direct_fel *!
+!* SR thinning *!
+!* SR felling *!
+!* SR shelterwood_man *!
+!* SR min_dbh *!
+!* SR max_dbh *!
+!* SR max_diam *!
+!* SR min_dbh_overs *!
+!* SR min_dbh_tar *!
+!* SR target_thinning *!
+!* SR calc_usp *!
+!* SR calc_gfbg *!
+!* SR stump *!
+!* *!
+!* Copyright (C) 1996-2018 *!
+!* Potsdam Institute for Climate Impact Reserach (PIK) *!
+!* Authors and contributors see AUTHOR file *!
+!* This file is part of 4C and is licensed under BSD-2-Clause *!
+!* See LICENSE file or under: *!
+!* http://www.https://opensource.org/licenses/BSD-2-Clause *!
+!* Contact: *!
+!* https://gitlab.pik-potsdam.de/foresee/4C *!
+!* *!
+!*****************************************************************!
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! !
+! tending plantations !
+! !
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+SUBROUTINE tending(actspec, i)
+ use data_stand
+ use data_manag
+ use data_species
+ use data_par
+ use data_simul
+ implicit none
+ integer :: tendnr, & ! number of trees to be removed
+ anz, &
+ actspec
+
+ real :: pequal
+ integer :: help_tree,min_ident,h1,max_ident, h2 ,cohanz
+ integer :: taxnr, j, i, thinflag, num_coh, nhelp,anz_actspec
+ integer, dimension(0:anz_coh) ::cohl
+ allocate (height_rank(anz_coh))
+ cohanz = 0
+anz_actspec = 0
+ min_ident=1000
+ max_ident = 0
+ cohl=0.
+ anz=0
+
+! number of trees to removed from the top of the stand
+ zeig=>pt%first
+ do
+ if(.not.associated(zeig)) exit
+ cohanz = cohanz +1
+ if(zeig%coh%species.eq.actspec.and. zeig%coh%shelter.ne.1) anz_actspec = anz_actspec + zeig%coh%ntreea
+ if(zeig%coh%shelter.ne.1) then
+ if(zeig%coh%ntreea.ne.0.and. zeig%coh%species.eq.actspec) then
+ h1 = zeig%coh%ident
+ if( h1.lt. min_ident) min_ident = h1
+ h2 = zeig%coh%ident
+ if(h2.gt.max_ident) max_ident = h2
+ end if
+ end if
+ zeig=>zeig%next
+ end do
+ if(thr7.ne.2.and.anz_actspec.eq.0) then
+ deallocate(height_rank)
+ return
+ end if
+!calculation of relative proportion of stems thinned from tending only of trees which are not shelter trees
+ tendnr = anz_actspec * tend(actspec)/2
+ help_tree = tendnr
+! determination of heighest tree cohort
+! sorting by height of cohorts into the field height_rank containing cohort identifier
+ call dimsort(anz_coh, 'height',height_rank)
+
+! removing of trees
+ do j= anz_coh, 1, -1
+ zeig=>pt%first
+ do
+ if(.not.associated(zeig)) exit
+ if(zeig%coh%shelter.ne.1. .and. zeig%coh%species.eq.specnr(i)) then
+ if(zeig%coh%ident.eq.height_rank(j)) then
+ if(zeig%coh%ntreea.ge.tendnr) then
+ zeig%coh%ntreea = zeig%coh%ntreea - help_tree
+ zeig%coh%ntreet = help_tree
+ help_tree = 0.
+ else
+! number of trees to be left
+ help_tree = help_tree-zeig%coh%ntreea
+
+! number of trees removed
+ zeig%coh%ntreet = zeig%coh%ntreea
+ zeig%coh%ntreea = 0
+ end if
+ end if
+ end if
+ zeig=> zeig%next
+ end do
+
+ if(help_tree.le.0 ) exit
+ end do
+
+! second part of felling, equal distributed from all cohorts
+! equal distribution from all cohorts with trees
+ nhelp = tendnr
+ zeig=>pt%first
+ do
+ if(.not.associated(zeig)) exit
+ if(zeig%coh%species.eq.actspec) then
+ end if
+ zeig=>zeig%next
+ end do
+ do
+ j=0
+ thinflag = 0
+ call random_number(pequal)
+ num_coh = min_ident + (max_ident - min_ident) * pequal
+ zeig=>pt%first
+ do
+
+ if(.not.associated(zeig)) exit
+ if(zeig%coh%shelter.ne.1.and. zeig%coh%species.eq.actspec) then
+ j = j+1
+ if (zeig%coh%ident.eq.num_coh) then
+! check the value ntreea before
+ if(zeig%coh%ntreea.ge.1) then
+ zeig%coh%ntreea = zeig%coh%ntreea - 1
+ zeig%coh%nta = zeig%coh%ntreea
+
+ zeig%coh%ntreet = zeig%coh%ntreet + 1
+ nhelp = nhelp -1
+
+ thinflag = 1
+ else
+ exit
+ endif
+ end if
+ if(thinflag.eq.1) exit
+ end if
+ zeig => zeig%next
+ end do
+ if(nhelp.eq.0) exit
+ end do
+
+! all biomasses are added to litter pools
+
+ zeig=>pt%first
+ do
+ if(.not.associated(zeig)) exit
+ taxnr=zeig%coh%species
+ if(zeig%coh%ntreet>0.and.taxnr.eq.specnr(i))then
+! all parts of trees are input for litter
+ zeig%coh%litC_fol = zeig%coh%litC_fol + zeig%coh%ntreet*(1.-spar(taxnr)%psf)*zeig%coh%x_fol*cpart
+ zeig%coh%litN_fol = zeig%coh%litN_fol + zeig%coh%ntreet*((1.-spar(taxnr)%psf)*zeig%coh%x_fol*cpart)/spar(taxnr)%cnr_fol
+ zeig%coh%litC_frt = zeig%coh%litC_frt + zeig%coh%ntreet*zeig%coh%x_frt*cpart
+ zeig%coh%litN_frt = zeig%coh%litN_frt + zeig%coh%ntreet*zeig%coh%x_frt*cpart/spar(taxnr)%cnr_frt
+ zeig%coh%litC_tb = zeig%coh%litC_tb + zeig%coh%ntreet*zeig%coh%x_tb*cpart
+ zeig%coh%litN_tb = zeig%coh%litN_tb + zeig%coh%ntreet*zeig%coh%x_tb*cpart/spar(taxnr)%cnr_tbc
+ zeig%coh%litC_crt = zeig%coh%litC_crt + zeig%coh%ntreet*zeig%coh%x_crt*cpart
+ zeig%coh%litN_crt = zeig%coh%litN_crt + zeig%coh%ntreet*zeig%coh%x_crt*cpart/spar(taxnr)%cnr_crt
+
+ zeig%coh%litC_stem = zeig%coh%litC_stem + zeig%coh%ntreet*(zeig%coh%x_sap+zeig%coh%x_hrt)*cpart
+ zeig%coh%litN_stem = zeig%coh%litC_stem/spar(taxnr)%cnr_stem
+ zeig%coh%ntreet = 0
+ endif
+ zeig=>zeig%next
+ enddo
+ thinyear(actspec)=time
+ deallocate(height_rank)
+END SUBROUTINE tending
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! Rueckegasse directional felling
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+SUBROUTINE direct_fel(hox)
+
+ use data_manag
+ use data_stand
+ use data_simul
+ use data_par
+ use data_species
+ implicit none
+ integer :: num_felt=0, &
+ num_coh=0, &
+ i, &
+ thinflag, &
+ taxnr, &
+ nhelp
+ real :: pequal, &
+ hox
+
+ thinflag = 0
+
+ if(thr5.eq.1) then
+ if (thr6.eq.hox) then
+! felling of direcfel*anz_tree trees equal distributed from all cohorts
+
+ num_felt = direcfel*anz_tree
+ nhelp = num_felt
+ do
+ i=0
+ thinflag = 0
+ call random_number(pequal)
+ num_coh = nint(pequal * anz_coh)+1
+ zeig=>pt%first
+ do
+ if(.not.associated(zeig)) exit
+ i = i+1
+ if (i.eq.num_coh) then
+! check the value ntreea before
+ if(zeig%coh%ntreea.ge.1) then
+ zeig%coh%ntreea = zeig%coh%ntreea - 1
+ zeig%coh%ntreem = zeig%coh%ntreem + 1
+ nhelp = nhelp -1
+
+ thinflag = 1
+ else
+ exit
+ endif
+ end if
+ if(thinflag.eq.1) exit
+ zeig => zeig%next
+ end do
+ if(nhelp.eq.0) exit
+ end do
+ flag_direct=1
+ end if
+ end if
+
+
+! adding biomasses to litter pools depending on stage of stand
+ zeig=>pt%first
+
+ do
+ if(.not.associated(zeig)) exit
+ taxnr=zeig%coh%species
+
+ if(zeig%coh%ntreem>0)then
+! all parts without stems of trees are input for litter
+ zeig%coh%litC_fol = zeig%coh%litC_fol + zeig%coh%ntreem*(1.-spar(taxnr)%psf)*zeig%coh%x_fol*cpart
+ zeig%coh%litN_fol = zeig%coh%litN_fol + zeig%coh%ntreem*((1.-spar(taxnr)%psf)*zeig%coh%x_fol*cpart)/spar(taxnr)%cnr_fol
+ zeig%coh%litC_frt = zeig%coh%litC_frt + zeig%coh%ntreem*zeig%coh%x_frt*cpart
+ zeig%coh%litN_frt = zeig%coh%litN_frt + zeig%coh%ntreem*zeig%coh%x_frt*cpart/spar(taxnr)%cnr_frt
+ zeig%coh%litC_tb = zeig%coh%litC_tb + zeig%coh%ntreet*zeig%coh%x_tb*cpart
+ zeig%coh%litN_tb = zeig%coh%litN_tb + zeig%coh%ntreet*zeig%coh%x_tb*cpart/spar(taxnr)%cnr_tbc
+ zeig%coh%litC_crt = zeig%coh%litC_crt + zeig%coh%ntreet*zeig%coh%x_crt*cpart
+ zeig%coh%litN_crt = zeig%coh%litN_crt + zeig%coh%ntreet*zeig%coh%x_crt*cpart/spar(taxnr)%cnr_crt
+
+ endif
+ zeig=>zeig%next
+ enddo
+END SUBROUTINE direct_fel
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! different thinning regimes (1-4) for trees with dominant height above ho2
+! thinning regime 1 - moderate low-thinning / mässige Niederdurchforstung
+! thinning regime 2 - strong/heavy low-thinning / starke Niederdurchforstung
+! thinning regime 3 - high-thinning / Hochdurchforstung
+! thinning regime 4 - selective thinning (from upper or middle thirg of thickest trees
+!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+SUBROUTINE thinning(c1,c2,actspec, inum)
+
+use data_stand
+use data_manag
+use data_simul
+use data_species
+use data_par
+implicit none
+
+real :: dbhmin=0, &
+ wpa=0, & ! Weibull parameter
+ wpb=0, & ! -"-
+ wpc=0, & ! -"-
+ d63=0, &
+
+ pequal, &
+ tdbh=0, &
+
+ bas_help=0., &
+ dbh_h =0, &
+ db_l = 0., &
+ db_u = 0., &
+ c1, &
+ d_est=0., &
+ w_kb=0., &
+ c_usp
+
+real :: help_cra, & ! actual crown area
+ density, & ! ratio of crown area to patch size
+
+ bas_target, & ! relative value for basal area thinning
+ bas_area, &
+ help
+
+real :: hg, & ! hight of base area mean stem
+ bg, & ! degree of tillering
+ dfbg, & ! opt. base area
+ stage, & ! actual age
+ basha, &
+ stump_v, & ! volume and dry weight of stump
+ stump_dw
+
+integer :: nrmin, &
+
+ flagth, &
+ c2, &
+ taxnr, &
+ nhelp1, &
+ counth, &
+ nhelp2, &
+ zbnr_pa, &
+ callnum, &
+ actspec, inum ! number of species for thinning
+
+integer :: lowtree, agedm
+
+! auxilarity for thinning routine 4: selective thinning
+integer :: nrmax,anz,anz1,count,flagexit, flagc, num_thin,j, &
+ nhelp,idum ,numtr, third,anztree_ha,i
+integer,dimension(0:anz_coh) :: cohl
+real :: meanzb, stand,xhelp, sumdh, sumd, hh ,rel_bas
+real,external :: gasdev
+real,dimension(nspecies) :: cr_rel ! relative part of species specific crown area of total crown area
+
+! target calculation for basal area reduction
+
+ bas_target = ((time-thinyear(actspec))/5)*0.05
+ bas_area = 0.
+
+ bas_help = 0.
+ help_cra = 0.
+ cr_rel = 1.
+ callnum = 0
+ count = 0
+ cohl = -1
+ flagth = 0
+ help=0.
+ lowtree=0
+ anztree_ha = nint(anz_tree_dbh*10000./kpatchsize)
+ third = nint(anz_tree_dbh*0.333333)
+
+ sumdh = 0.; sumd = 0.
+
+! calculation of mean diameter (corresponding to med_diam) and basal area of stand
+! calculation hg ( hight of base area mean stem)
+i = inum
+ zeig => pt%first
+ DO
+ IF (.NOT. ASSOCIATED(zeig)) EXIT
+ if(zeig%coh%species.eq.actspec) then
+ stage = zeig%coh%x_age
+ help_cra = help_cra + zeig%coh%ntreea* zeig%coh%crown_area
+ IF((zeig%coh%ntreea>0).and.(zeig%coh%diam>0)) THEN
+ ! foresters defenition
+ sumd = sumd + zeig%coh%diam*zeig%coh%diam
+ sumdh = sumdh + zeig%coh%diam*zeig%coh%diam* zeig%coh%height
+ help = help + zeig%coh%ntreea*(zeig%coh%diam**2)
+ bas_area = bas_area + zeig%coh%ntreea*(zeig%coh%diam**2)*pi/4.
+ ELSE
+ ! trees with DBH = 0 for population and species
+ lowtree = lowtree + zeig%coh%ntreea
+
+ ENDIF
+ end if
+ zeig => zeig%next
+ ENDDO ! cohorts
+
+ hg = (sumdh/sumd)/100.
+
+! basal area /ha
+ basha = bas_area/kpatchsize ! cm²/patch ---> m²/ha
+
+ rel_bas = bas_area/basarea_tot
+ if(thin_ob.eq.1) then
+! calculation of optimal basal area (Brandenburg) per patchsize
+
+ call calc_gfbg(dfbg,specnr(i), stage, hg)
+! correction
+ dfbg = dfbg* kpatchsize ! m²/ha ---> cm²/patchsize
+
+ if(anz_spec.eq.1) then
+ if(dfbg.lt.0.5*bas_area) dfbg = 0.5*bas_area
+! calculation of BG (Bestockungsgrad)
+ else
+! calculation of relative part of crown area
+ cr_rel(actspec) = svar(actspec)%crown_area / crown_area
+
+ end if
+ bg = rel_bas*bas_area/dfbg
+
+! calculation of basale area target depending on target optb 'Bestockungsgrad'
+ bas_target = rel_bas*optb*dfbg
+ else
+! calculation of density dependent target for thinning
+ density = help_cra/kpatchsize
+
+ call calc_usp (actspec,age_spec(i),density,c_usp)
+
+! Modification of 'Nutzungsprozent' to avoid large number for c_usp
+ c_usp = c_usp*np_mod(actspec)
+
+ if(thinyear(actspec).eq.0) then
+ hh = c_usp*(time)/10.
+ if(hh.lt.0.7) then
+ c_usp = hh
+ else
+ c_usp = 0.5
+ end if
+ bas_target = bas_area - bas_area*c_usp
+ else
+! Modification
+ if(c_usp.gt.0.4) then
+ c_usp =c_usp * (time -thinyear(actspec))/20.
+ end if
+ bas_target = bas_area - bas_area*c_usp
+ end if
+ end if
+ select case(c2)
+
+
+ case(1:3)
+! different thinnings from below and above
+
+ select case(c2)
+ case(1)
+! moderate low-thinning
+ d_est = 1.02
+! change of w_kb to exclude small diameter classes
+ w_kb = 2.5
+ case(2)
+! high low-thinning
+ d_est = 1.03
+ w_kb = 1.5
+ case(3)
+! high-thinning
+ d_est = 1.04
+ w_kb = 1.2
+ end select
+
+! calculation of Weibull-Parameter
+ if(bas_area.gt.bas_target) then
+ call min_dbh(nrmin,dbhmin,agedm,actspec)
+ bas_help = bas_area
+ wpa = dbhmin
+ d63 = svar(actspec)%med_diam * d_est
+ wpb = (d63 - wpa)/ w_kb
+ wpc = 2
+
+! selection of trees for thinning
+ do
+ call random_number(pequal)
+ tdbh = wpa + wpb*(-log(1.-pequal))**(1./wpc)
+ callnum = callnum +1
+ flagth = 0
+ zeig => pt%first
+
+ DO
+ IF (.NOT. ASSOCIATED(zeig)) EXIT
+ if(zeig%coh%species.eq.actspec) then
+
+ if(zeig%coh%diam.gt.0.) then
+ dbh_h = zeig%coh%diam
+ db_l = dbh_h - 0.1*dbh_h
+ db_u = dbh_h + 0.1*dbh_h
+ if (tdbh.ge.db_l.and.tdbh.le.db_u.and. zeig%coh%ntreea.ne. 0) then
+ zeig%coh%ntreea = zeig%coh%ntreea -1
+ zeig%coh%nta = zeig%coh%ntreea
+ zeig%coh%ntreem = zeig%coh%ntreem +1
+ bas_help = bas_help - (zeig%coh%diam**2)*pi/4.
+ flagth = 1
+ end if
+ if(flagth.eq.1) exit
+ end if
+ end if
+ zeig=> zeig%next
+ END DO ! cohorts
+
+ if(bas_help .le. bas_target) exit
+ end do ! selection of trees
+ end if
+
+ case(4)
+
+! selective thinning
+
+! normal(or equal) distributed thinning from one third of the trees (upper or middle): n*anz_ziel or
+! depending an basal area
+! ho2: n=2; ho3,ho4: n=1.5 ho>ho4: n=1
+! determination of the third of trees with the thickest diameter (sorting of cohorts concerning diameter
+! necessary: normal distribution with 2 parameters: mean diameter of the third and standard deviation
+
+DO i=1,anz_spec
+!Calculation of number of thinning trees
+ IF ( c1.eq.ho2) THEN
+ num_thin = NINT(2* zbnr(specnr(i))*kpatchsize/10000.)
+ ELSE IF( c1.eq.ho3.or.c1.eq.ho4) THEN
+! change of num_thin because of errors during thinning
+ num_thin = NINT(zbnr(specnr(i))*kpatchsize/10000.)
+ ELSE
+ num_thin = NINT(zbnr(specnr(i))*kpatchsize/10000.)
+ END IF
+ if(anztree_ha.lt.(zbnr(specnr(i))+ zbnr(specnr(i))*0.2)) return
+
+! determine cohorts which fulfill the upper third --> selected for thinning
+ anz = 0
+ flagexit = 0
+ flagc = 0
+ if(anz_tree_dbh>1) then
+ do
+ call max_diam(nrmax,anz,cohl, specnr(i))
+ zeig=>pt%first
+ do
+ if(.not.associated(zeig)) exit
+ if(zeig%coh%diam.gt.0) then
+ if(zeig%coh%ident.eq.nrmax) then
+ count = count + zeig%coh%ntreea
+ if(count.ge. third) flagexit = 1
+ flagc = 1
+ end if
+ if (flagc.eq. 1) exit
+ end if
+ zeig=>zeig%next
+ end do
+ if(flagexit.eq.1) exit
+ flagc = 0
+ end do
+ end if
+
+ IF(c1.eq.0) THEN
+
+! determine cohorts which fulfill the middle third of thickness
+! if the number of one third is not definded by an even number of cohorts
+! the middle third starts in the last cohort of the upper third
+! some refinements are possible: the number of trees are marked in each cohort which
+! are available for thinning (may be in the last cohort of the thirg only x%)
+
+ if(count.eq.third) then
+
+ anz1 = anz+1
+ else
+ anz1 = anz
+ anz = anz-1
+ end if
+
+ count = 0
+ flagexit = 0
+ flagc = 0
+ if(anz_tree>1) THEN
+ do
+ call max_diam(nrmax,anz,cohl, specnr(i))
+ zeig=>pt%first
+ do
+ if(.not.associated(zeig)) exit
+ if(zeig%coh%ident.eq.nrmax) then
+ count = count + zeig%coh%ntreea
+ if(count.ge. third) flagexit = 1
+ flagc = 1
+ end if
+ if (flagc.eq. 1) exit
+ zeig=>zeig%next
+ end do
+ if(flagexit.eq.1) exit
+ flagc = 0
+ end do
+ end if
+
+ ENDIF
+
+! calculation on mean and standard deviation of cohorts selected for thinning
+ stand = 0.
+ if(c1.ne.0) anz1 =1
+ meanzb = 0.
+ counth = 0
+ do j = anz1,anz
+ zeig=>pt%first
+ do
+ if(.not.associated(zeig)) exit
+ nrmax = cohl(j-1)
+ if (zeig%coh%ident.eq.nrmax) then
+ meanzb = meanzb + zeig%coh%ntreea*zeig%coh%diam
+ counth = counth + zeig%coh%ntreea
+ end if
+ zeig=>zeig%next
+
+ end do
+ end do
+! mean value
+ meanzb = meanzb/count
+! standard deviation
+ do j = anz1,anz
+ zeig=>pt%first
+ do
+ if(.not.associated(zeig)) exit
+ nrmax = cohl(j-1)
+ if (zeig%coh%ident.eq.nrmax) then
+ stand = stand+ zeig%coh%ntreea*(zeig%coh%diam - meanzb)*(zeig%coh%diam - meanzb)
+ end if
+ zeig=>zeig%next
+ end do
+ end do
+ stand = sqrt(stand/count)
+
+! thinning of num_thin trees from the upper third
+! using normal distribution
+! if ho>ho4 the selection of trees from the middle third is controlled by basal area
+! a reduction of basal area by 10%
+
+ idum = -1
+ nhelp = num_thin
+ numtr = 0
+ bas_help=bas_area
+
+ do j=anz1,anz
+ zeig=>pt%first
+ DO
+ IF (.NOT. ASSOCIATED(zeig)) EXIT
+ if(zeig%coh%ident.eq.cohl(j-1)) numtr = numtr+zeig%coh%ntreea
+ zeig=>zeig%next
+ end do
+ end do
+ nhelp1 = anz_tree
+ nhelp2 = count
+ if(nhelp.gt.numtr) nhelp = numtr
+ DO
+ xhelp= meanzb+stand*gasdev(idum)
+ flagth = 0
+
+ DO j = anz1, anz
+ zeig => pt%first
+
+ DO
+ IF (.NOT. ASSOCIATED(zeig)) EXIT
+ if(zeig%coh%ident.eq.cohl(j-1)) then
+ dbh_h = zeig%coh%diam
+ db_l = dbh_h - 0.1*dbh_h
+ db_u = dbh_h + 0.1*dbh_h
+ if (xhelp.ge.db_l.and.xhelp.le.db_u.and. zeig%coh%ntreea.ne. 0) then
+ zeig%coh%ntreea = zeig%coh%ntreea -1
+ zeig%coh%nta = zeig%coh%ntreea
+ zeig%coh%ntreem = zeig%coh%ntreem +1
+ if(c1.eq.0) then
+ bas_help = bas_help - (zeig%coh%diam**2)*pi*0.25
+ nhelp1 = nhelp1 -1
+ nhelp2 = nhelp2 -1
+ else
+ nhelp= nhelp -1
+ endif
+ flagth = 1
+
+ end if
+ end if
+ if(flagth.eq.1) exit
+ zeig=> zeig%next
+ ENDDO
+ if(flagth.eq.1) exit
+ END DO
+
+! criteria of finishing thinning
+
+ zbnr_pa = nint(zbnr(specnr(i))*kpatchsize/10000.)
+ if(c1.eq.0 .and.( bas_help.le.(bas_area - bas_area*bas_target).or.nhelp1.eq.zbnr_pa) ) exit
+ if(c1.eq.0 .and.( nhelp1.eq.0 .or. nhelp2.eq.0)) exit
+ if(c1.ne.0 .and. nhelp.eq.0) exit
+
+ ENDDO
+END DO ! speices loop
+ end select
+
+! adding biomasses to litter pools depending on stage of stand
+stump_sum = 0
+ zeig=>pt%first
+
+ do
+ if(.not.associated(zeig)) exit
+ taxnr=zeig%coh%species
+
+ if(zeig%coh%ntreem>0)then
+! all parts without stems of trees are input for litter
+ zeig%coh%litC_fol = zeig%coh%litC_fol + zeig%coh%ntreem*(1.-spar(taxnr)%psf)*zeig%coh%x_fol*cpart
+ zeig%coh%litN_fol = zeig%coh%litN_fol + zeig%coh%ntreem*((1.-spar(taxnr)%psf)*zeig%coh%x_fol*cpart)/spar(taxnr)%cnr_fol
+ zeig%coh%litC_frt = zeig%coh%litC_frt + zeig%coh%ntreem*zeig%coh%x_frt*cpart
+ zeig%coh%litN_frt = zeig%coh%litN_frt + zeig%coh%ntreem*zeig%coh%x_frt*cpart/spar(taxnr)%cnr_frt
+ zeig%coh%litC_tb = zeig%coh%litC_tb + zeig%coh%ntreem*zeig%coh%x_tb*cpart
+ zeig%coh%litN_tb = zeig%coh%litN_tb + zeig%coh%ntreem*zeig%coh%x_tb*cpart/spar(taxnr)%cnr_tbc
+ zeig%coh%litC_crt = zeig%coh%litC_crt + zeig%coh%ntreem*zeig%coh%x_crt*cpart
+ zeig%coh%litN_crt = zeig%coh%litN_crt + zeig%coh%ntreem*zeig%coh%x_crt*cpart/spar(taxnr)%cnr_crt
+
+! stumps into stem litter
+ call stump( zeig%coh%x_ahb, zeig%coh%asapw,zeig%coh%dcrb,zeig%coh%x_hbole, &
+ zeig%coh%height, taxnr,stump_v, stump_dw)
+ zeig%coh%litC_stem = zeig%coh%litC_stem + zeig%coh%ntreem*stump_dw*cpart
+ zeig%coh%litN_stem = zeig%coh%litC_stem/spar(taxnr)%cnr_stem
+ stump_sum = stump_sum + zeig%coh%ntreem*stump_dw
+
+ if(maninf.eq.'brushing'.and.flag_brush.ne.0) then
+ zeig%coh%litC_stem =zeig%coh%litC_stem + zeig%coh%ntreem*(zeig%coh%x_sap+zeig%coh%x_hrt)*cpart
+ zeig%coh%litN_stem = zeig%coh%litC_stem/spar(taxnr)%cnr_stem
+ end if
+ endif
+ zeig=>zeig%next
+ enddo
+END SUBROUTINE thinning
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!
+! SR for clear cut
+!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+SUBROUTINE felling(nr,i)
+
+ use data_stand
+ use data_manag
+ use data_simul
+ use data_species
+ use data_par
+ use data_soil_cn
+
+ implicit none
+
+ integer :: taxnr, i, nr
+ real :: stump_v, stump_dw, help
+
+ zeig=>pt%first
+ do
+ if(.not.associated(zeig)) exit
+ taxnr = zeig%coh%species
+ if(taxnr.le.nspec_tree) then
+
+ if(thr7.eq.2.and. taxnr.eq.nr) then
+ zeig%coh%ntreem = zeig%coh%ntreea
+ zeig%coh%ntreea = 0
+ zeig%coh%nta = 0.
+ else if(thr7.ne.2.and. taxnr.eq.nr.and. zeig%coh%x_age.eq.age_spec(i).and. zeig%coh%shelter.eq.1) then
+ zeig%coh%ntreem = zeig%coh%ntreea
+ zeig%coh%ntreea = 0
+ zeig%coh%nta = 0.
+
+ end if
+ else
+! reduction of soil vegetation after felling
+
+ taxnr = zeig%coh%species
+ help = zeig%coh%x_fol
+ zeig%coh%x_fol = 0.005*help
+ zeig%coh%litC_fol = zeig%coh%litC_fol + 0.995*zeig%coh%ntreem*(1.-spar(taxnr)%psf)*help*cpart
+ zeig%coh%litN_fol = zeig%coh%litN_fol + 0.995*zeig%coh%ntreem*((1.-spar(taxnr)%psf)*help*cpart)/spar(taxnr)%cnr_fol
+ help = zeig%coh%x_frt
+ zeig%coh%x_frt = 0.005*help
+ zeig%coh%litC_frt = zeig%coh%litC_frt + 0.995*zeig%coh%ntreem*help*cpart
+ zeig%coh%litN_frt = zeig%coh%litN_frt + 0.995*zeig%coh%ntreem*help*cpart/spar(taxnr)%cnr_frt
+ help = zeig%coh%x_sap
+ zeig%coh%x_sap = 0.005*help
+ zeig%coh%litC_fol = zeig%coh%litC_fol + 0.995*zeig%coh%ntreem*help*cpart
+ zeig%coh%litN_fol = zeig%coh%litN_fol + 0.995*zeig%coh%ntreem*((1.-spar(taxnr)%psf)*help*cpart)/spar(taxnr)%cnr_fol
+ zeig%coh%Fmax = zeig%coh%x_fol
+ zeig%coh%t_leaf = zeig%coh%med_sla* zeig%coh%x_fol ! [m2]
+ zeig%coh%nta = zeig%coh%nTreeA
+
+ end if
+ zeig=>zeig%next
+ end do
+ zeig=>pt%first
+
+ do
+ if(.not.associated(zeig)) exit
+ taxnr=zeig%coh%species
+
+ if(zeig%coh%ntreem>0.and. taxnr.eq.nr)then
+! all parts without stems of trees are input for litter
+ zeig%coh%litC_fol = zeig%coh%litC_fol + zeig%coh%ntreem*(1.-spar(taxnr)%psf)*zeig%coh%x_fol*cpart
+ zeig%coh%litN_fol = zeig%coh%litN_fol + zeig%coh%ntreem*((1.-spar(taxnr)%psf)*zeig%coh%x_fol*cpart)/spar(taxnr)%cnr_fol
+ zeig%coh%litC_frt = zeig%coh%litC_frt + zeig%coh%ntreem*zeig%coh%x_frt*cpart
+ zeig%coh%litN_frt = zeig%coh%litN_frt + zeig%coh%ntreem*zeig%coh%x_frt*cpart/spar(taxnr)%cnr_frt
+ zeig%coh%litC_tb = zeig%coh%litC_tb + zeig%coh%ntreem*zeig%coh%x_tb*cpart
+ zeig%coh%litN_tb = zeig%coh%litN_tb + zeig%coh%ntreem*zeig%coh%x_tb*cpart/spar(taxnr)%cnr_tbc
+ zeig%coh%litC_crt = zeig%coh%litC_crt + zeig%coh%ntreem*zeig%coh%x_crt*cpart
+ zeig%coh%litN_crt = zeig%coh%litN_crt + zeig%coh%ntreem*zeig%coh%x_crt*cpart/spar(taxnr)%cnr_crt
+
+! stumps into stem litter
+ call stump( zeig%coh%x_ahb, zeig%coh%asapw,zeig%coh%dcrb,zeig%coh%x_hbole, &
+ zeig%coh%height, taxnr,stump_v, stump_dw)
+ zeig%coh%litC_stem = zeig%coh%litC_stem + zeig%coh%ntreem*stump_dw*cpart
+ zeig%coh%litN_stem = zeig%coh%litC_stem/spar(taxnr)%cnr_stem
+ stump_sum = stump_sum + zeig%coh%ntreem*stump_dw
+
+
+ endif
+ zeig=>zeig%next
+ enddo
+END SUBROUTINE felling
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!
+! subroutine for shelterwood management
+!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+SUBROUTINE shelterwood_man(nrsh,inum,domage)
+ use data_stand
+ use data_manag
+ use data_simul
+ use data_par
+ use data_species
+ implicit none
+
+ real :: bared, & ! reduction of basal area
+ bas_help, &
+ bas_area, &
+ pequal, &
+ domage, &
+ help, &
+ stump_v, &
+ stump_dw
+ integer :: taxnr, &
+
+ flagc, &
+ flagexit, &
+ num_coh, &
+ thinflag, j, &
+ count, third,&
+ counth, &
+ anz_treesh=0, &
+ anz_2th, &
+ nrsh, &
+ minident, &
+ inum, help_shnum
+
+ integer, dimension(1:anz_coh) :: coh_2th
+ allocate (dbh_rank(anz_coh))
+ minident = 100000
+ bas_area = 0.
+ anz_treesh = 0
+ help_shnum = 0
+! tending of trees, planted at first shelterwood treatment
+ help = time - shelteryear
+ IF(help.eq.15..and.flag_shelter.eq.1 .and.shelteryear.ne.0) THEN
+ call tending(nrsh,inum)
+ END IF
+
+! labelling of trees for shelterwood at first shelterwood treatment
+if (shelteryear.eq.0.or.shelteryear.eq.time) then
+ zeig=>pt%first
+
+ do
+ if(.not.associated(zeig)) exit
+ write(5432,*) zeig%coh%ntreea
+ if(zeig%coh%species.eq.nrsh.and.zeig%coh%x_age.gt.10) zeig%coh%shelter = 1.
+ zeig=> zeig%next
+ end do
+ end if
+! calculation of number of shelter trees
+ zeig=>pt%first
+ do
+ if(.not.associated(zeig)) exit
+ if(zeig%coh%shelter.eq.1.and. zeig%coh%species.eq.nrsh) anz_treesh = anz_treesh +zeig%coh%ntreea
+
+ zeig=>zeig%next
+
+ end do
+write(5432,*) time, 'anz_treesh', anz_treesh
+ count = 0
+ IF((time-shelteryear).eq.15 .or. shelteryear .eq. 0..or.shelteryear.eq.time) THEN
+ call dimsort(anz_coh, 'dbh',dbh_rank)
+ flag_manreal = 1
+ if (shelteryear.eq.0) then
+ maninf = 'shelterwood system1'
+ else
+ maninf = 'shelterwood system2'
+ end if
+ meas = 0
+ third = nint(anz_treesh*0.3333333)
+ taxnr = nrsh
+
+! calculation of basal area of shelterwood
+ zeig => pt%first
+ DO
+ IF (.NOT. ASSOCIATED(zeig)) EXIT
+
+ if(zeig%coh%shelter.eq.1.and. zeig%coh%species.eq.taxnr) then
+ IF((zeig%coh%ntreea>0).and.(zeig%coh%diam>0)) THEN
+
+ bas_area = bas_area + zeig%coh%ntreea*(zeig%coh%diam**2)*pi/4.
+ End if
+ end if
+ zeig => zeig%next
+ ENDDO
+
+! declaration of reduction coefficient of basal area
+ if(domage.eq.regage(domspec)) then
+ bared = 0.3
+ else
+ bared = 0.4
+ end if
+
+! lower two thirds sorted by diameter in coh_2th
+ counth = 0
+ flagexit = 0
+ flagc = 0
+ anz_2th = 0
+ coh_2th = -1
+ if(anz_tree>1) then
+ do j = 1,anz_coh
+ zeig => pt%first
+ do
+ if(.not.associated(zeig)) exit
+ if(zeig%coh%ident.eq.dbh_rank(j).and.zeig%coh%shelter.eq.1.and. zeig%coh%species.eq.nrsh) then
+ counth = counth + zeig%coh%ntreea
+ anz_2th = anz_2th +1
+ if(counth.ge.2*third) flagexit =1
+ coh_2th(anz_2th) = zeig%coh%ident
+ if(zeig%coh%ident.lt.minident) minident =zeig%coh%ident
+ flagc = 1
+ end if
+ if(flagc.eq.1) exit
+ zeig=>zeig%next
+ end do
+ if (flagexit.eq.1) exit
+ flagc = 0
+ end do
+ end if
+
+! thinning with equal distribution from cohorts listed in coh_2th
+ bas_help = bas_area
+
+ DO
+ flagexit = 0
+ thinflag = 0
+ call random_number(pequal)
+ num_coh = nint(pequal*anz_2th + 0.5)
+
+ zeig=> pt%first
+ do
+ if(.not.associated(zeig)) exit
+ if(zeig%coh%ident.eq.coh_2th(num_coh).and.zeig%coh%shelter.eq.1.and. zeig%coh%species.eq.nrsh) then
+ if(zeig%coh%ntreea.ge.1) then
+ zeig%coh%ntreea = zeig%coh%ntreea - 1
+ help_shnum = help_shnum +1
+ zeig%coh%nta = zeig%coh%nta -1.
+ zeig%coh%ntreem = zeig%coh%ntreem + 1
+ bas_help = bas_help - (zeig%coh%diam**2)*pi/4
+ thinflag = 1
+ end if
+ end if
+ if(thinflag.eq.1) exit
+ zeig=>zeig%next
+ end do
+ if(bas_help.le.(bas_area -bas_area*bared)) exit
+ if(help_shnum.eq. counth) exit
+ END DO
+
+! adding biomasses to litter pools depending on stage of stand
+if(anz_treesh>0) then
+ zeig=>pt%first
+
+ do
+ if(.not.associated(zeig)) exit
+ taxnr=zeig%coh%species
+
+ if(zeig%coh%ntreem>0..and. zeig%coh%species.eq.nrsh)then
+! all parts without stems of trees are input for litter
+ zeig%coh%litC_fol = zeig%coh%litC_fol + zeig%coh%ntreem*(1.-spar(taxnr)%psf)*zeig%coh%x_fol*cpart
+ zeig%coh%litN_fol = zeig%coh%litN_fol + zeig%coh%ntreem*((1.-spar(taxnr)%psf)*zeig%coh%x_fol*cpart)/spar(taxnr)%cnr_fol
+ zeig%coh%litC_frt = zeig%coh%litC_frt + zeig%coh%ntreem*zeig%coh%x_frt*cpart
+ zeig%coh%litN_frt = zeig%coh%litN_frt + zeig%coh%ntreem*zeig%coh%x_frt*cpart/spar(taxnr)%cnr_frt
+ zeig%coh%litC_tb = zeig%coh%litC_tb + zeig%coh%ntreem*zeig%coh%x_tb*cpart
+ zeig%coh%litN_tb = zeig%coh%litN_tb + zeig%coh%ntreem*zeig%coh%x_tb*cpart/spar(taxnr)%cnr_tbc
+ zeig%coh%litC_crt = zeig%coh%litC_crt + zeig%coh%ntreem*zeig%coh%x_crt*cpart
+ zeig%coh%litN_crt = zeig%coh%litN_crt + zeig%coh%ntreem*zeig%coh%x_crt*cpart/spar(taxnr)%cnr_crt
+
+! stumps into stem litter
+ call stump( zeig%coh%x_ahb, zeig%coh%asapw,zeig%coh%dcrb,zeig%coh%x_hbole, &
+ zeig%coh%height,taxnr, stump_v, stump_dw)
+ zeig%coh%litC_stem = zeig%coh%litC_stem + zeig%coh%ntreem*stump_dw*cpart
+ zeig%coh%litN_stem = zeig%coh%litC_stem/spar(taxnr)%cnr_stem
+ stump_sum = stump_sum + zeig%coh%ntreem*stump_dw
+
+! stump biomass is added to stem litter litC_stem, litN_stem
+ endif
+ zeig=>zeig%next
+ enddo
+ END IF
+ end if ! anz_treesh
+ deallocate(dbh_rank)
+END SUBROUTINE shelterwood_man
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+SUBROUTINE min_dbh(nrmin,help_h1,agedm, spnr)
+ use data_stand
+implicit none
+ integer :: nrmin,spnr, agedm, agedmh
+ integer :: nrmin_h
+ integer :: testflag
+ real :: help_h1, help_h2
+
+ testflag=0
+ agedm = -1
+ agedmh = -1
+ nrmin = -1
+ nrmin_h = -1
+ help_h2=0.
+ help_h1=1000.
+ zeig=>pt%first
+ do
+ if(.not.associated(zeig)) exit
+ if(zeig%coh%species.eq.spnr) then
+ if(zeig%coh%diam.gt.0.) then
+
+ help_h2= zeig%coh%diam
+ nrmin_h = zeig%coh%ident
+ agedmh = zeig%coh%x_age
+ if(help_h2.lt. help_h1) then
+ help_h1 = help_h2
+ nrmin = nrmin_h
+ agedm = agedmh
+ end if
+ end if
+ end if
+ zeig=>zeig%next
+
+ end do
+
+END SUBROUTINE min_dbh
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+SUBROUTINE min_dbh_tar(nrmin,help_h1,spnr,tar)
+ use data_stand
+implicit none
+ integer :: nrmin,spnr
+ integer :: nrmin_h
+ integer :: testflag
+ real :: help_h1, help_h2
+ real :: tar
+
+ testflag=0
+ nrmin = -1
+ nrmin_h = -1
+ help_h2=0.
+ help_h1=1000.
+ zeig=>pt%first
+ do
+ if(.not.associated(zeig)) exit
+ if(zeig%coh%species.eq.spnr) then
+ if(zeig%coh%diam.gt.0..and. zeig%coh%height.gt.tar) then
+
+ help_h2= zeig%coh%diam
+ nrmin_h = zeig%coh%ident
+ if(help_h2.lt. help_h1) then
+ help_h1 = help_h2
+ nrmin = nrmin_h
+ end if
+ end if
+ end if
+ zeig=>zeig%next
+
+ end do
+
+END SUBROUTINE min_dbh_tar
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+SUBROUTINE min_dbh_overs(nrmin,help_h1,spnr)
+ use data_stand
+implicit none
+ integer :: nrmin,spnr
+ integer :: nrmin_h
+ integer :: testflag
+ real :: help_h1, help_h2
+
+ testflag=0
+ nrmin = -1
+ nrmin_h = -1
+ help_h2=0.
+ help_h1=1000.
+ zeig=>pt%first
+ do
+ if(.not.associated(zeig)) exit
+ if(zeig%coh%species.eq.spnr) then
+ if(zeig%coh%diam.gt.0..and. zeig%coh%underst.eq.0) then
+
+ help_h2= zeig%coh%diam
+ nrmin_h = zeig%coh%ident
+ if(help_h2.lt. help_h1) then
+ help_h1 = help_h2
+ nrmin = nrmin_h
+ end if
+ end if
+ end if
+ zeig=>zeig%next
+
+ end do
+
+END SUBROUTINE min_dbh_overs
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+SUBROUTINE min_dbh_unders(nrmin,help_h1,spnr)
+ use data_stand
+implicit none
+ integer :: nrmin,spnr
+ integer :: nrmin_h
+ integer :: testflag
+ real :: help_h1, help_h2
+
+ testflag=0
+ nrmin = -1
+ nrmin_h = -1
+ help_h2=0.
+ help_h1=1000.
+ zeig=>pt%first
+ do
+ if(.not.associated(zeig)) exit
+ if(zeig%coh%species.eq.spnr) then
+ if(zeig%coh%diam.gt.0..and. zeig%coh%underst.eq.2) then
+
+ help_h2= zeig%coh%diam
+ nrmin_h = zeig%coh%ident
+ if(help_h2.lt. help_h1) then
+ help_h1 = help_h2
+ nrmin = nrmin_h
+ end if
+ end if
+ end if
+ zeig=>zeig%next
+
+ end do
+
+END SUBROUTINE min_dbh_unders
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+SUBROUTINE max_dbh(nrmax,help_h1,agedm,spnr)
+ use data_stand
+implicit none
+ integer :: nrmax,spnr, agedm, agedmh
+ integer :: nrmax_h
+ integer :: testflag
+ real :: help_h1, help_h2
+
+ testflag=0
+ agedm =-1
+ agedmh = -1
+ nrmax = -1
+ nrmax_h = -1
+ help_h2=0.
+ help_h1=0.
+ zeig=>pt%first
+ do
+ if(.not.associated(zeig)) exit
+ if(zeig%coh%species.eq.spnr) then
+ if(zeig%coh%diam.gt.0.) then
+
+ help_h2= zeig%coh%diam
+ nrmax_h = zeig%coh%ident
+ agedmh = zeig%coh%x_age
+ if(help_h2.gt. help_h1) then
+ help_h1 = help_h2
+ nrmax = nrmax_h
+ agedm = agedmh
+ end if
+ end if
+ end if
+ zeig=>zeig%next
+
+ end do
+
+END SUBROUTINE max_dbh
+
+!
+! calculation of cohort number with maximal diameter
+!
+
+SUBROUTINE max_diam(nrmax,anz,cohl, specnum)
+ use data_stand
+implicit none
+
+ integer :: nrmax,i
+ integer :: nrmax_h, specnum
+ integer :: anz, testflag
+ real :: help_h1, help_h2
+ integer,dimension(0:anz_coh) :: cohl
+
+ testflag=0
+ nrmax = -1
+ nrmax_h = -1
+ help_h2=0.
+ help_h1=0.
+ zeig=>pt%first
+ do
+ if(.not.associated(zeig)) exit
+ do i=0,anz-1
+ if(cohl(i).eq.zeig%coh%ident.and. zeig%coh%species.eq.specnum) then
+ testflag=1
+ endif
+ end do
+ if (testflag.eq.0) then
+ help_h2= zeig%coh%diam
+ nrmax_h = zeig%coh%ident
+ if(help_h2.gt. help_h1) then
+ help_h1 = help_h2
+ nrmax = nrmax_h
+ end if
+ end if
+
+ zeig=>zeig%next
+ testflag = 0
+ end do
+ anz = anz +1
+ cohl(anz-1) = nrmax
+END SUBROUTINE max_diam
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!
+! SR calc_usp
+! calculaiton of percent of using (NUtzungsprozent)
+!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+subroutine calc_usp (taxnr,ages,density,c_usp)
+
+use data_species
+use data_manag
+
+real ::density, c_usp
+real,dimension(20) :: spec_den=(/0.,0.8,0.9,1.,0.8,0.9,1.,1.1,0.8,0.9,1.,1.1,0.7,0.8,0.9,1.,0.7,0.8,0.9,1./)
+integer, dimension(13) :: age_den=(/15,20,25,30,35,40,45,50,60,70,80,100,120/)
+integer :: j, i,help1, taxnr,ages
+c_usp =0.
+
+ do i=1,3
+ help1=(taxnr-1)*4+i
+
+ if(density.gt.spec_den(help1).and. density.le.spec_den(help1+1)) then
+ do j= 1,12
+ if(ages.ge.age_den(j).and.ages.lt.age_den(j+1))then
+ c_usp = usp(help1,j)
+ end if
+ end do
+ end if
+ end do
+ help1=(taxnr-1)*4+4
+ if(c_usp.eq.0..and. density.gt.spec_den(help1)) then
+
+ do j= 1,12
+ if(ages.ge.age_den(j).and.ages.lt.age_den(j+1))then
+ c_usp = usp(help1,j)
+ end if
+ end do
+ else if (c_usp.eq.0..and.density .le. spec_den( help1-3)) then
+ do j= 1,12
+ if(ages.ge.age_den(j).and.ages.lt.age_den(j+1))then
+ c_usp = usp(help1-3,j)
+ end if
+ end do
+ end if
+end subroutine calc_usp
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!
+! 4C-
+! Subroutine calc_gfbg
+! calculation of optimal basal area
+! coresponding to functions from
+! A. Degenhardt: Algorithmen und Programme zur
+! waldwachstumskundlichen Auswertung von
+! Versuchs- und probeflächen
+!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+SUBROUTINE calc_gfbg(gfbg, ntax, stage, hg)
+ use data_par
+ use data_stand
+ implicit none
+real, dimension(12) :: p=(/5.3774914,4.3364045,1.7138966, &
+ 0.1791894,0.6499329,0.581721, &
+ 0.64149,1.39876,0.38106,3.48086,4.55256,1.10352/) ! parameter pinus
+real, dimension(14) :: s=(/52.021649311,17.01260031,1.817338508, &
+ 3.97091538,0.165219412,0.017015893, &
+ 17.17273582,77.00271993,180.95845108,69.85082406, &
+ 0.284339648,6.211490243,8.057235477,2.600807284/) ! parameter spruce
+real, dimension(11) :: b=(/5.1961292,5.8518918,2.048007, &
+ 0.1517038,0.8873933,0.9555725, &
+ 0.845794,29.76635,9.89798,0.2033,0.092586/) ! parameter beech
+real, dimension(16) :: o=(/10.937989911, 30.98059032,36.683338986,4.8203797, &
+ 0.217782149,0.559666286,1.253027352,2.447035652, &
+ 3.172437267,26.001075916,15.01095715,2.411330088, &
+ 0.286619845,0.126747922,0.121360347,0.05650846/)
+real, dimension(9) :: bi=(/2.304633491,5.7831992,0.057831992, &
+ 99.89719563,4983.109428, 387539.3699, &
+ 192.06078091,0.070580839, 0.624018136/) ! birch (Sandbirke)
+real, dimension(16) :: pa=(/12.114711547,13.90837359,11.746497917, 2.963065353, &
+ 0.298215006,0.325115413,0.46694307,0.043088114, &
+ 5.314568374, 9.635476988, 23.20634163,9.473964111, &
+ 0.845408671,0.187292811,0.025416101,0.050721202/)
+real :: abon, &
+ rbon, &
+ h1,h2,h3,h4,alt10, alt100, nvb, dgvb,gfbg,stage,hg
+integer :: ntax
+ alt10= 10/stage
+ alt100= stage/100
+ h1 = 0.;h2=0.;h3=0.;h4=0.
+ select case(ntax)
+ case(1) ! beech
+ h1 = b(1) + b(2)*alt100 - b(3)*alt100*alt100
+ h2 = -b(4) - b(5)*alt10 - b(6)*alt10*alt10
+ rbon = h1+h2*hg
+ abon = 36.- 4.*rbon
+ gfbg = b(7) + b(8)*alt100 -b(9)*alt100*alt100 +abon*(b(10) + b(11)*alt100)
+
+ case(2) ! spruce
+ h1 = (alog(hg)-s(4))/(-s(5)+alog(1.-exp(-s(6)*stage)))
+ abon = s(1)-s(2)*h1 +s(3)*h1*h1
+ rbon = (38.-abon)/4.
+ h2 = - s(7)-s(8)*alt100+s(9)*alt100*alt100-s(10)*alt100*alt100*alt100
+ h3 = s(11) + s(12)*alt100 -s(13)*alt100*alt100 + s(14)* alt100*alt100*alt100
+ gfbg = h2 + h3*abon
+
+ case(3) ! pine
+ h1 = p(1) + p(2)*alt100 - p(3)*alt100*alt100
+ h2 = -p(4) - p(5)*alt10 -p(6)*alt10*alt10
+ rbon = h1 + h2*hg
+ abon = 32.- 4.*rbon
+ h3 = p(7)+p(8)*alog10(stage)-p(9)*alog10(stage)*alog10(stage)
+ h4 = -p(10) + p(11)*alog10(stage) - p(12)*alog10(stage)*alog10(stage)
+ gfbg = 0.01*abon*10**h3 + 10**h4
+
+ case(4) ! oak
+ h1 = o(1) - o(2)*alt10 + o(3)*alt10*alt10 - o(4)*alt10*alt10*alt10
+ h2 =- o(5) - o(6)* alt10 + o(7)*alt10*alt10 - o(8)* alt10*alt10*alt10
+ rbon = h1 + h2*hg
+ abon = 31.3 - 3.9*rbon
+ h3 = o(9) + o(10)* alt100 -o(11)*alt100*alt100 + o(12)*alt100*alt100*alt100
+ h4 = o(13) + o(14)*alt100 - o(15)*alt10*alt100 + o(16)*alt100*alt100*alt100
+ gfbg = h3 + h4*abon
+
+ case(5) ! birch
+ rbon = 9. - 0.25*(hdom/100.)*exp(-bi(1)*(exp(-bi(2))-exp(-bi(3)*stage)))
+ abon = 36. - 4.*rbon
+ nvb = -bi(4) - bi(5)*(1./(hdom/100.)) +bi(6)*(1./(hdom/100.))*(1./(hdom/100.))
+ dgvb = bi(7)*(1. + bi(8)*nvb)**(-bi(9))
+ gfbg = pi*dgvb*dgvb*nvb/(4*10000)
+
+ case(8) ! aspen
+ h1= pa(1) - pa(2)*alt10+pa(3)*alt10*alt10-pa(4)*alt10*alt10*alt10
+ h2 = -pa(5)+pa(6)*alt10-pa(7)*alt10*alt10+pa(8)*alt10*alt10*alt10
+ rbon=h1+h2*hdom
+ abon=36.-4*rbon
+ h3 = -pa(9)+pa(10)*alt10-pa(11)*alt10*alt10+pa(12)*alt10*alt10*alt10
+ h4 = pa(13)-pa(14)*alt10 + pa(15)*alt10*alt10 -pa(16)*alt10*alt10*alt10
+ gfbg = h3 + h4*abon
+ end select
+
+END SUBROUTINE calc_gfbg
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+ SUBROUTINE stump(x1, x2, xdcrb, xhbo, xh, i, stump_v, stump_dw)
+
+ use data_tsort
+ use data_par
+ use data_species
+
+ implicit none
+
+ real :: x1, x2, xdcrb, xhbo, xh, diam_base, dbsto, v1, stump_v, stump_dw
+ integer :: i
+
+ diam_base= sqrt((x1+x2)*4/pi)
+
+ if(xhbo.ne.0) then
+ dbsto = xdcrb + (xhbo-stoh(i))*(diam_base-xdcrb)/xhbo
+
+ else if (xhbo.eq.0)then
+
+ dbsto = diam_base*(xh+stoh(i))/xh
+ end if
+
+! volume of stump
+ v1 = pi* stoh(i)*(diam_base*diam_base + diam_base*dbsto + dbsto*dbsto)/3. ! frustum
+ stump_v = v1/1000000. ! m³
+ stump_dw = v1*spar(i)%prhos ! kg DW
+
+ END SUBROUTINE stump
diff --git a/source_code/version2.2_windows/management.f b/source_code/version2.2_windows/management.f
new file mode 100755
index 0000000000000000000000000000000000000000..815f9ae3d3a9eeed30421cdc96e8f592a5cd42a2
--- /dev/null
+++ b/source_code/version2.2_windows/management.f
@@ -0,0 +1,1062 @@
+!*****************************************************************!
+!* *!
+!* 4C (FORESEE) *!
+!* *!
+!* *!
+!* Subroutines for: *!
+!* management *!
+!* contains: *!
+!* SR manag_ini *!
+!* SR manag_menu *!
+!* SR simple_ini *!
+!* SR adap_ini *!
+!* SR management *!
+!* SR simple_manag *!
+!* SR adap_manag *!
+!* SR target_manag *!
+!* SR target_ini *!
+!* *!
+!* Copyright (C) 1996-2018 *!
+!* Potsdam Institute for Climate Impact Reserach (PIK) *!
+!* Authors and contributors see AUTHOR file *!
+!* This file is part of 4C and is licensed under BSD-2-Clause *!
+!* See LICENSE file or under: *!
+!* http://www.https://opensource.org/licenses/BSD-2-Clause *!
+!* Contact: *!
+!* https://gitlab.pik-potsdam.de/foresee/4C *!
+!* *!
+!*****************************************************************!
+
+SUBROUTINE manag_ini
+use data_manag
+use data_simul
+use data_stand
+
+implicit none
+
+!call manag_menu
+select case(flag_mg)
+ case(1)
+ call simple_ini
+ case(2)
+ if(anz_spec.ne.0) call adap_ini
+ case(3, 33)
+ call target_ini
+ case(44)
+ call man_liocourt_ini
+ case(8)
+ call aspman_ini
+ case(9)
+ call aust_ini
+end select
+contains
+
+SUBROUTINE simple_ini
+! read definition of simple thinning from file
+integer :: manag_unit,i
+character(len=150) :: filename
+logical :: ex
+manag_unit=getunit()
+filename = manfile(ip)
+call testfile(filename,ex)
+open(manag_unit,file=trim(filename))
+read(manag_unit,*) thin_nr ! number of thinning years
+allocate(thin_year(thin_nr));allocate(thin_tree(thin_nr))
+do i=1,thin_nr
+read(manag_unit,*) thin_year(i),thin_tree(i)
+end do
+close(manag_unit)
+end SUBROUTINE simple_ini
+end SUBROUTINE manag_ini
+!-------------------------------------------------
+! control of management regime and call
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+SUBROUTINE management
+use data_simul
+use data_stand
+use data_species
+use data_manag
+use data_out
+implicit none
+integer diffanz
+
+if (flag_standup .eq. 0) flag_standup = 1
+
+select case(flag_mg)
+ case(1)
+ call simple_manag
+ case(2)
+ call adap_manag
+ case(3, 33)
+ call target_manag
+ case(44)
+ call liocourt_manag
+ case(8)
+ call asp_manag
+ case(9)
+ call aust_manag
+ case(10)
+ call dis_manag
+ case default
+end select
+
+contains
+
+SUBROUTINE simple_manag
+integer taxnr, cohnr
+real minheight
+! simple thinning with fitting to default stem number
+if(anz_tree>thin_tree(act_thin_year)) then
+ diffanz = anz_tree - thin_tree(act_thin_year)
+ minheight = 100000.
+do
+ !repeat while diffanz>0)
+ if(diffanz<0.1) exit
+ zeig=>pt%first
+ !search for cohort with minimal height
+ do
+ if(.not.associated(zeig)) exit
+ if(zeig%coh%ntreea>0.1 .and. zeig%coh%height<minheight)then
+ minheight=zeig%coh%height; cohnr=zeig%coh%ident
+ endif
+ zeig=>zeig%next
+ enddo
+ ! delete smallest trees
+ zeig=>pt%first
+ do
+ if(.not.associated(zeig)) exit
+ if(zeig%coh%ident==cohnr)then
+ if(diffanz <= zeig%coh%ntreea) then
+ zeig%coh%ntreea = zeig%coh%ntreea - diffanz
+ zeig%coh%ntreem = diffanz
+ diffanz=0.
+ else
+ diffanz = diffanz - zeig%coh%ntreea
+ zeig%coh%ntreem = zeig%coh%ntreea
+ zeig%coh%ntreea = 0.
+ endif
+ minheight=100000.
+ exit
+ endif
+ zeig=>zeig%next
+ enddo
+enddo
+else
+call error_mess(time,"no management possible, tree number undersized : ", REAL(anz_tree))
+endif
+! number of trees and litter pools of managed trees
+ zeig=>pt%first
+ anz_tree=0.
+ do
+ if(.not.associated(zeig)) exit
+ taxnr=zeig%coh%species
+ anz_tree=anz_tree+zeig%coh%ntreea
+ if(zeig%coh%ntreem>0 .and.zeig%coh%ntreed==0.)then
+ zeig%coh%litC_fol = zeig%coh%litC_fol + (1.-spar(taxnr)%psf)*zeig%coh%x_fol/2.
+ zeig%coh%litN_fol = zeig%coh%litN_fol + ((1.-spar(taxnr)%psf)*zeig%coh%x_fol/2.)*0.02
+ zeig%coh%litC_frt = zeig%coh%litC_frt + zeig%coh%x_frt/2.
+ zeig%coh%litN_frt = zeig%coh%litN_frt + (zeig%coh%x_frt/2.)*0.023
+ endif
+ zeig=>zeig%next
+ enddo
+
+end SUBROUTINE simple_manag
+end SUBROUTINE management
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! input of control parameters for adaptation management
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+SUBROUTINE adap_ini
+
+ use data_manag
+ use data_simul
+ use data_species
+ use data_stand
+ use data_out
+ implicit none
+ ! read definition of adapted thinning from file
+ integer :: manag_unit,i,j
+ character(len=150) :: filename
+ logical :: ex
+ character ::text
+ manag_unit=getunit()
+ filename = manfile(ip)
+
+ allocate(zbnr(nspec_tree))
+ allocate(tend(nspec_tree))
+ allocate(rot(nspec_tree))
+ allocate(thin_flag1(nspec_tree))
+ allocate(thin_flag2(nspec_tree))
+ allocate(thin_flag3(nspec_tree))
+ allocate(thin_flag4(nspec_tree))
+ allocate(regage(nspec_tree))
+ allocate(np_mod(nspec_tree))
+ allocate(thinyear(nspec_tree))
+ allocate(specnr(nspec_tree))
+ allocate(age_spec(nspec_tree))
+ allocate(anz_tree_spec(nspec_tree))
+ thinyear =0
+ thin_flag1=0
+ thin_flag2=0
+ thin_flag3=0
+ thin_flag4=0
+ flag_manreal = 0
+ flag_shelter = 0
+ shelteryear = 0
+ call testfile(filename,ex)
+ open(manag_unit,file=trim(filename))
+! read head of data-file
+ do
+ read(manag_unit,*) text
+ if(text .ne. '!')then
+ backspace(manag_unit);exit
+ endif
+ enddo
+! dominant species
+ read(manag_unit,*) domspec
+! domimant height levels
+ read(manag_unit,*) ho1,ho2,ho3,ho4
+! thinning regimes
+ read (manag_unit,*) thin_flag1(1),thr1, thr2,thr3,thr4,thr5,thr6, thr7, mgreg, domspec_reg
+ do j=2,nspec_tree
+ thin_flag1(j)= thin_flag1(1)
+ end do
+ if(thin_flag1(1) <0) then
+ close(manag_unit)
+ return
+ end if
+! limit for hight query
+ read (manag_unit,*) limit
+!test
+ limit = limit + 30.
+! number of years between thinning
+ read (manag_unit,*) thinstep
+! relative thinning for young trees
+ read (manag_unit,*) direcfel
+! control variables for thinning depending on basal area
+ read (manag_unit,*) thin_ob, optb
+! number of 'Zielb�ume' (target trees)
+ read (manag_unit,*) (zbnr(i), i =1, nspec_tree)
+! relative thinning value for tending of plantations
+ read (manag_unit,*) (tend(i), i =1, nspec_tree)
+! rotation
+ read (manag_unit,*) (rot(i), i =1, nspec_tree)
+! age of natural/planted regeneration
+ read (manag_unit,*) (regage(i), i =1, nspec_tree)
+ do j= 1,20
+ read (manag_unit,*) (usp(j,i), i=1,13)
+ end do
+ read (manag_unit,*) (np_mod(i), i = 1,nspec_tree)
+close(manag_unit)
+if (flag_reg .ne. 0) then
+ WRITE(unit_ctr,*) ' '
+ WRITE(unit_ctr,*) '***Managment parameter case flag_mg = 2 (user specified) ***'
+ WRITE(unit_ctr,'(A35,4F15.5)') 'height for management control(cm)', ho1,ho2,ho3,ho4
+ WRITE(unit_ctr,'(A35,6I15)') 'man. flags thin_flag1, thr1-thr5' , thin_flag1(1),thr1,thr2, thr3,thr4,thr5
+ WRITE(unit_ctr,'(A35,F15.5)') 'height for directional felling', thr6
+ WRITE(unit_ctr,'(A35,I15)') 'measure at rotation', thr7
+ WRITE(unit_ctr,'(A35,I15)') 'regeneration measure', mgreg
+ WRITE(unit_ctr,'(A35,F15.5)') 'lower/upper limit of height(cm)', limit
+ WRITE(unit_ctr,'(A35,I15)') 'number of years between thinning',thinstep
+ WRITE(unit_ctr,'(A35,F15.5)') 'rel. value for directional felling', direcfel
+ WRITE(unit_ctr,'(A35,2F15.5)') 'thinning depending on basal area function thin_ob (0,1), optb ', thin_ob, optb
+ WRITE(unit_ctr,'(A35,5F15.5)')'number of Zielb�ume (spec.)', (zbnr(i),i=1,nspec_tree)
+ WRITE(unit_ctr,'(A35,5F15.5)')'rel. value for tending of pl.',(tend(i), i =1,nspec_tree)
+ WRITE(unit_ctr,'(A35,5I15)')'rotation ',(rot(i), i =1,nspec_tree)
+ WRITE(unit_ctr,'(A35,5I15)')'age of nat./pl. regeneration',(regage(i), i =1,nspec_tree)
+ close(unit_ctr)
+end if
+ end SUBROUTINE adap_ini
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! routines for adaptation management
+! based on concepts from P. Mohr, P.Lasch. D. Gerold....
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+SUBROUTINE adap_manag
+ use data_stand
+ use data_manag
+ use data_simul
+ use data_par
+ use data_species
+ implicit none
+ real :: c1, &
+ helphd,helpmax, helpi, & ! hdom species specific
+ domage
+
+real :: sumdh, sumd ! for calculation of HG
+real :: bg ! stocking degree
+real :: stage
+real :: dfbg ! optimal basal area
+real :: hg ! height of DG
+ integer :: c2, &
+ taxnr, &
+ actspec, & ! number of species for thinning
+ th_help, i,j ,k, &
+ testflag, &
+ nrfel, &
+ flag_prep, &
+ flag_fell, &
+ inum, &
+ domage_sh, &
+ domspec_sh, &
+ flag_reg_act
+real,dimension(nspecies) :: bas_area_spec
+real,dimension(nspecies) :: help
+flag_reg_act = 100
+domage = 0.
+domspec_sh = 0
+help = 0.
+helpmax = 0.
+helpi =0
+bas_area_spec = 0.
+domage_sh = 0
+flag_fell = 0
+stand_age=0
+flag_prep = 0
+anz_tree_spec = 0
+anz_tree_dbh = 0
+flag_adapm = 0.
+specnr = 0.
+age_spec = 0.
+basarea_tot = 0.
+sumd = 0.
+sumdh = 0.
+! determine number of species in cohort list
+if(anz_spec.eq.0) return
+if(thin_flag1(1) <0) return
+IF(anz_spec.eq.1) then
+! stand age as maximum age of cohorts
+ zeig => pt%first
+ DO
+ IF (.NOT. ASSOCIATED(zeig)) EXIT
+ if(zeig%coh%species.le.nspec_tree) then
+ taxnr = zeig%coh%species
+
+ if(zeig%coh%x_age.gt. stand_age) stand_age = zeig%coh%x_age
+ if(zeig%coh%ntreea.ne.0.and. zeig%coh%diam.gt.0.) then
+
+ sumd = sumd + zeig%coh%diam*zeig%coh%diam
+ sumdh = sumdh + zeig%coh%diam*zeig%coh%diam*zeig%coh%height
+
+ basarea_tot = basarea_tot + zeig%coh%ntreea*(zeig%coh%diam**2)*pi/4.
+ bas_area_spec(taxnr) = bas_area_spec(taxnr) + zeig%coh%ntreea*(zeig%coh%diam**2)*pi/4.
+ end if
+ end if
+ zeig=>zeig%next
+ END DO
+
+
+ELSE if(anz_spec.gt.1) then
+! age of species i as maximum age of cohorts of this species
+
+ testflag = 0
+ i=1
+ zeig => pt%first
+ DO
+ IF (.NOT. ASSOCIATED(zeig)) EXIT
+
+ taxnr = zeig%coh%species
+ if(zeig%coh%ntreea.ne.0.and. zeig%coh%diam.gt.0.) then
+
+ basarea_tot = basarea_tot + zeig%coh%ntreea*(zeig%coh%diam**2)*pi/4.
+ bas_area_spec(taxnr) = bas_area_spec(taxnr) + zeig%coh%ntreea*(zeig%coh%diam**2)*pi/4.
+ end if
+
+ if(i.eq.1) then
+ specnr(i) = zeig%coh%species
+ if(zeig%coh%x_age.gt. age_spec(i)) age_spec(i) = zeig%coh%x_age
+ i = i+1
+
+ else
+ do j= 1,i-1
+ if(specnr(j).eq. zeig%coh%species) testflag = 1
+ end do
+ if (testflag.eq.0) then
+ specnr(i) = zeig%coh%species
+ if(zeig%coh%x_age.gt. age_spec(i)) age_spec(i) = zeig%coh%x_age
+ i = i+1
+ end if
+ testflag=0
+ end if
+ zeig=>zeig%next
+ END DO
+ DO i =1,anz_spec
+ zeig => pt%first
+ DO
+ IF (.NOT. ASSOCIATED(zeig)) EXIT
+ if(zeig%coh%species.eq.specnr(i).and.zeig%coh%x_age.gt. age_spec(i)) age_spec(i)= zeig%coh%x_age
+ zeig=>zeig%next
+ END DO
+ END DO
+! if domspec is -99 then domspec is calculated by basal area
+if( domspec.lt. 0 ) then
+ DO i = 1,nspecies
+ if (basarea_tot.ne.0) then
+ help(i) = bas_area_spec(i)/basarea_tot
+ if(help(i).gt. helpmax) then
+ helpmax = help(i)
+ helpi = i
+ end if
+ end if
+ end do
+ domspec = helpi
+end if
+
+! re-sorting of the filed specnr (at the first place of this field is the number of the dominanat species);
+! this is necessary for managemnt of mixed stands becuase this management is according to the management
+! of the dominanat species
+
+! age of domspec
+ zeig => pt%first
+ DO
+ IF (.NOT. ASSOCIATED(zeig)) EXIT
+
+ if(zeig%coh%species.eq.domspec) then
+ if(zeig%coh%x_age.gt.domage) domage = zeig%coh%x_age
+ end if
+ zeig=>zeig%next
+ END DO
+
+ if(specnr(1).ne.domspec) then
+ do k=2,anz_spec
+ if(specnr(k).eq.domspec) then
+ specnr(k)=specnr(1)
+ age_spec(k)=age_spec(1)
+ specnr(1) = domspec
+ age_spec(1)=domage
+ exit
+ end if
+ end do
+ end if ! re-sorting
+
+! species for shelterwood which is oldest
+ zeig => pt%first
+ DO
+ IF (.NOT. ASSOCIATED(zeig)) EXIT
+ if(zeig%coh%shelter.eq.1.and.zeig%coh%x_age.gt.domage.and.zeig%coh%x_age.gt.domage_sh) domage_sh = zeig%coh%x_age
+ zeig=>zeig%next
+ END DO
+ zeig => pt%first
+ DO
+ IF (.NOT. ASSOCIATED(zeig)) EXIT
+ if(zeig%coh%x_age.eq.domage_sh) domspec_sh = zeig%coh%species
+ zeig=>zeig%next
+ END DO
+
+END IF
+ if (anz_spec.eq.1) then
+ specnr(1) = taxnr
+ age_spec(1) = stand_age
+ if(domspec.lt.0) domspec = taxnr
+ end if
+
+DO i=1,anz_spec
+anz_tree_spec(i) = 0
+! caclulation of species specific number of trees
+ zeig=>pt%first
+
+ do
+ if(.not.associated(zeig)) exit
+ zeig%coh%ntreem = 0.
+ if(zeig%coh%diam.gt.0) anz_tree_dbh = anz_tree_dbh + zeig%coh%ntreea
+ if(zeig%coh%species.eq.specnr(i)) anz_tree_spec(i) = anz_tree_spec(i) + zeig%coh%ntreea
+ zeig=> zeig%next
+
+ end do
+END DO ! species loop
+
+if(domspec.lt.0) then
+ if(domage_sh.gt.domage) then
+ domage = domage_sh
+ domspec = domspec_sh
+ end if
+end if
+
+DO i=1,anz_spec
+ actspec = specnr(i)
+ zeig => pt%first
+ DO
+ IF (.NOT. ASSOCIATED(zeig)) EXIT
+ if(zeig%coh%species.le.nspec_tree) then
+ taxnr = zeig%coh%species
+
+ if(zeig%coh%ntreea.ne.0.and. zeig%coh%diam.gt.0..and.zeig%coh%species.eq.taxnr) then
+ stage = zeig%coh%x_age
+ sumd = sumd + zeig%coh%diam*zeig%coh%diam
+ sumdh = sumdh + zeig%coh%diam*zeig%coh%diam*zeig%coh%height
+
+ end if
+ end if
+ zeig=>zeig%next
+ END DO
+
+! calculation HG (height for DG)
+
+ if(sumdh.ne.0) then
+ hg = (sumdh/sumd)/100.
+ else
+ hg = 0.
+ end if
+
+ IF (specnr(i).ne.0..and. domspec.ne.0) THEN
+ select case(thr7)
+
+ case(1) ! thr7
+! shelterwood management
+
+ if(domspec.eq.actspec) then
+ if (age_spec(i).ge.regage(specnr(i)).and. age_spec(i).lt.(rot(specnr(i))-15.).and. time.ne.1) then
+ if(shelteryear.eq.0.and.flag_shelter.eq.0) flag_reg = mgreg
+ inum = i
+ if (flag_sh_first.ne.2) then
+ call shelterwood_man(specnr(inum),inum,domage)
+ end if
+ if(shelteryear.eq.0) flag_sh_first = 1
+ flag_shelter = 1
+ if(flag_sh_first.ne.2) then
+ select case(flag_reg)
+ case(1) ! mgreg
+! natural regeneration allowed
+ flag_reg = 1
+
+ case(4,5,6,7,8,9,10,11,12,13,14,15) ! mgreg
+! artificial regeneration
+
+ if(flag_reg_act.ne.0) call planting
+ flag_reg = 0
+ flag_reg_act = 0
+ end select
+ end if
+
+ flag_prep = 1
+ else if (age_spec(i).ge.rot(specnr(i)).and. time.ne.1) then
+! clear felling
+ nrfel = specnr(i)
+
+ call felling(nrfel,i)
+ flag_manreal = 1
+ flag_shelter = 0
+
+ maninf = 'felling after shelterwood s.'
+ meas = 0
+
+! set back because shelterwood m. is finished, management of regenerated stand starts
+ shelteryear = 0.
+ thin_flag1 = 0
+ thin_flag2 = 0
+ thin_flag3 = 0
+ thin_flag4 = 0
+ flag_prep = 1
+
+ if(flag_plant_shw.eq.1) then
+
+! if no first and second sherterwood management was possibele than after clear cut planting is called
+ select case(mgreg)
+ case(1) ! mgreg
+! natural regeneration allowed
+ flag_reg = 1
+
+ case(4,5,6,7,8,9,10,11,12,13,14,15) ! mgreg
+! artificial regeneration
+
+ if(flag_reg_act.ne.0) then
+ flag_reg = mgreg
+ call planting
+ end if
+ flag_reg = 0
+ flag_reg_act = 0
+ flag_plant_shw =0
+ end select
+
+ end if
+
+! if initial age is grater than age for first shleterwood treatment
+
+ else if(time.eq.1.and. age_spec(i).gt.regage(specnr(i)).and. age_spec(i).gt.(rot(specnr(i))-20) ) then
+! flags for planting if felling is realised
+ flag_plant_shw = 1
+ flag_reg_act = 1
+! in this case: to avoid sheletrwood management until rotation time
+ flag_sh_first = 2
+ shelteryear = 99
+! labelling of cohorts as sheletrwood cohorts
+ zeig=>pt%first
+ do
+ if(.not.associated(zeig)) exit
+ zeig%coh%shelter=1
+ zeig=> zeig%next
+ end do
+ exit
+
+ else if(time.eq.1.and. age_spec(i).gt.regage(specnr(i)).and. age_spec(i).le.(rot(specnr(i))-20.)) then
+! if initial age is greater than regeneration age(first shelterwood treatm.) and not too near to rotation age
+! a new rotation age is defined with delaying
+ rot(specnr(i)) = rot(specnr(i)) + (age_spec(i) - regage(specnr(i)))
+
+ if(shelteryear.eq.0.and.flag_shelter.eq.0) flag_reg = mgreg
+ inum = i
+ call shelterwood_man(specnr(inum),inum,domage)
+ if(shelteryear.eq.0) flag_sh_first = 1
+ flag_shelter = 1
+ select case(flag_reg)
+ case(1) ! mgreg
+! natural regeneration allowed
+ flag_reg = 1
+
+ case(4,5,6,7,8,9,10,11,12,13,14,15) ! mgreg
+! artificial regeneration
+
+ if(flag_reg_act.ne.0) call planting
+ flag_reg = 0
+ flag_reg_act = 0
+ end select
+
+ end if
+
+ else if(domspec.ne.actspec) then
+ if (domage.ge.regage(domspec).and.domage.lt.(rot(domspec)-15.)) then
+ if(shelteryear.eq.0) flag_reg = mgreg
+ inum=i
+ call shelterwood_man(specnr(inum),inum, domage)
+ flag_shelter = 1
+ if(shelteryear.eq.0) flag_sh_first = 1
+
+ select case(flag_reg)
+ case(1) ! mgreg
+! natural regeneration allowed
+ flag_reg = 1
+
+ case(4,5,6,7,8,9,10,11,12,13,14,15) ! mgreg
+! artificial regeneration
+
+ if(flag_reg_act.ne.0) call planting
+ flag_reg = 0
+ flag_reg_act = 0
+ end select
+ flag_prep = 1
+
+ else if(thr7.eq.1 .and. domage.eq.rot(domspec)) then
+ else if(actspec.eq.rot(actspec)) then
+
+! clear felling
+ nrfel = specnr(i)
+ call felling(nrfel,i)
+
+ flag_manreal = 1
+ flag_shelter = 0
+ maninf = 'felling after shelterwood s.'
+ meas = 0
+! set back because shelterwood m. is finished, management of regenerated stand starts
+ shelteryear = 0.
+ thin_flag1 = 0
+ thin_flag2 = 0
+ thin_flag3 = 0
+ thin_flag4 = 0
+ flag_prep = 1
+ end if
+ end if
+
+ case(2) ! thr7
+! clear felling
+ if(age_spec(i).ge.(rot(specnr(i))-15).and.age_spec(i).lt.rot(specnr(i)) ) then
+ zeig=>pt%first
+ do
+ if(.not.associated(zeig)) exit
+ if(zeig%coh%species.eq.specnr(i).and. zeig%coh%x_age.eq. age_spec(i)) zeig%coh%shelter = 1
+ zeig=>zeig%next
+ end do
+ flag_prep = 1
+ else if (age_spec(i).eq.rot(specnr(i))) then
+ nrfel = specnr(i)
+ call felling (nrfel,i)
+ flag_manreal = 1
+ flag_fell = 1
+ thinyear(actspec) = time
+ thin_flag1 = 0
+ thin_flag2 = 0
+ thin_flag3 = 0
+ thin_flag4 = 0
+
+ maninf = 'felling'
+ meas =0
+ call input_manrec
+ else if(age_spec(i).gt. rot(specnr(i)).and. time.eq.1) then
+
+ nrfel = specnr(i)
+ call felling (nrfel,i)
+ flag_manreal = 1
+ flag_fell = 1
+ thinyear(actspec) = time
+ thin_flag1 = 0
+ thin_flag2 = 0
+ thin_flag3 = 0
+ thin_flag4 = 0
+
+ maninf = 'felling'
+ meas =0
+ call input_manrec
+
+ end if
+ case default
+ end select
+
+! tending of plantations (Jungwuchspflege)
+
+! test if rotation age is not during the next 15 years
+IF (flag_prep .eq. 0. .and. flag_shelter .eq.0) then
+ helphd= svar(specnr(i))%dom_height
+if ( thinonce.eq.1) then
+ c1 = ho3
+ c2 = thr4
+ CALL thinning (c1,c2,actspec,i)
+ flag_manreal=1
+ maninf = 'thinning'
+ meas = thr1
+ thinyear(actspec)=time
+ call input_manrec
+end if
+if( thinonce.eq.0) then
+
+ IF ( (helphd.ge.(ho1-60.).and. helphd.le.(ho1+60.)).and. thin_flag1(actspec).eq.0) THEN
+ CALL tending(actspec,i)
+ flag_manreal = 1
+ maninf = 'tending'
+ meas = 0
+ call input_manrec
+ thin_flag1(actspec)=1
+ flag_adapm = 1
+
+! management at different dominant heights
+ ELSE IF( helphd.ge.(ho1-60).and.helphd.le.(ho4+limit)) then
+
+ IF((helphd.ge.(ho2-limit).and. helphd.le.(ho2+limit)).and. (thin_flag2(actspec).eq.0).or.( thin_flag2(actspec).eq.0.and. thin_flag2(domspec).eq.1))THEN
+ if(actspec.eq.domspec .or. thin_flag2(domspec).eq.1) then
+ c1= ho2
+ c2= thr1
+ thin_flag2(actspec)=1
+ maninf = 'brushing'
+
+! if beech, spruce, oak then tending else thinning based on basal area
+ if(actspec.ne.3)then
+
+! Mod. for Cornelia
+ CALL tending(actspec,i)
+ else
+ CALL thinning (c1,c2,actspec,i)
+ end if
+
+ flag_manreal=1
+
+ meas = thr1
+ thinyear(actspec)=time
+ call input_manrec
+ end if
+ ELSE IF((helphd.ge.(ho3-limit).and. helphd.le.(ho3+limit)).and. (thin_flag3(actspec).eq.0).or.( thin_flag3(actspec).eq.0.and. thin_flag3(domspec).eq.1)) THEN
+ if(actspec.eq.domspec .or. thin_flag3(domspec).eq.1) then
+ c1= ho3
+ c2= thr2
+ thin_flag3(actspec)= 1
+
+ CALL thinning (c1,c2,actspec,i)
+ flag_manreal = 1
+ maninf = 'thinning'
+ meas = thr2
+ thinyear(actspec)=time
+ call input_manrec
+ end if
+ ELSE IF( (helphd.ge.(ho4-limit).and. helphd.le.(ho4+limit)).and. (thin_flag4(actspec).eq.0).or.( thin_flag4(actspec).eq.0.and. thin_flag4(domspec).eq.1)) THEN
+ if(actspec.eq.domspec .or. thin_flag3(domspec).eq.1) then
+ c1= ho4
+ c2= thr3
+ thin_flag4(actspec)= 1
+ CALL thinning (c1,c2,actspec,i)
+ flag_manreal = 1
+ maninf = 'thinning'
+ meas = thr3
+ call input_manrec
+ thinyear(actspec) = time
+ end if
+ ENDIF
+
+! directinal felling if not done yet
+
+ flag_adapm = 1
+
+ ELSE IF(helphd.gt. (ho4+limit)) THEN
+! calculation of stocking degree
+ call calc_gfbg(dfbg, actspec, stage, hg)
+ dfbg = dfbg*kpatchsize
+ bg = bas_area_spec(actspec)*bas_area_spec(actspec)/(basarea_tot*dfbg)
+
+ th_help = time-thinyear(actspec)
+ IF(th_help.ge.thinstep.or.(bg.gt.(optb).and.time.lt.thinstep.and.thinyear(actspec).eq.0)) THEN
+ c1 = 0.
+ c2 = thr4
+ if( age_spec(i).lt.(rot(specnr(i))-15)) then
+ CALL thinning(c1,c2,actspec,i)
+ flag_manreal = 1
+ maninf = 'thinning'
+ meas = thr4
+ thinyear(actspec) = time
+ !wpm
+ call input_manrec
+
+ flag_adapm = 1
+ end if
+ ENDIF
+ END IF
+ END IF
+end if ! thinonce
+END IF ! flag_prep
+END DO ! species loop
+
+ if(maninf.eq.'felling after shelterwood s.') domspec = -99
+ if(thr7.eq.1 .and.(maninf.eq.'felling after shelterwood s.'.or. &
+ maninf.eq.'shelterwood system1'.or.maninf.eq.'shelterwood system2') ) then
+ call input_manrec
+ maninf =trim(maninf)//'out'
+ end if
+
+ if(flag_sh_first.eq.1) then
+ shelteryear=time
+ flag_sh_first = 0
+ end if
+
+ if(maninf.eq.'felling after shelterwood s.') then
+ domspec = domspec_reg
+ end if
+
+! regeneration/planting if felling was realised
+if(flag_fell.eq.1.and. mgreg.ne.0) then
+ select case(mgreg)
+ case(1)
+! natural regeneration
+ flag_reg = 1
+! shelterwood management is switched off
+ thr7 = 0
+ case(4,5,6,7,8,9,10,11,12,13,14)
+! artificial regeneration (planting)
+ flag_reg = mgreg
+ call planting
+ thinyear(actspec) = time
+ thin_flag2 = 0
+ thin_flag3 = 0
+ thin_flag4 = 0
+ flag_reg = 0
+ domspec = domspec_reg
+ end select
+end if
+
+! calculation of total dry mass of all harvested trees
+ sumvsab = 0.
+ sumvsab_m3 = 0.
+ svar%sumvsab = 0.
+
+ if(maninf.ne.'tending'.or. flag_brush.eq.0) then
+ zeig=>pt%first
+ do while (associated(zeig))
+ ns = zeig%coh%species
+ sumvsab = sumvsab + zeig%coh%ntreem*(zeig%coh%x_sap + zeig%coh%x_hrt)
+ sumvsab_m3 = sumvsab_m3 + zeig%coh%ntreem*(zeig%coh%x_sap + zeig%coh%x_hrt)/(spar(ns)%prhos*1000000)
+ svar(ns)%sumvsab = svar(ns)%sumvsab + zeig%coh%ntreem*(zeig%coh%x_sap + zeig%coh%x_hrt)
+ zeig=>zeig%next
+
+ end do
+ sumvsab = sumvsab * 10000./kpatchsize ! kg/ha
+ sumvsab_m3 = sumvsab_m3 * 10000./kpatchsize ! kg/ha
+
+ do k = 1, nspec_tree
+ svar(k)%sumvsab = svar(k)%sumvsab * 10000./kpatchsize ! kg/ha
+ end do
+! cumulative harvested stem mass
+ cumsumvsab = cumsumvsab + sumvsab
+ end if
+
+ call class_man
+END SUBROUTINE adap_manag
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!
+! management routine with fitting stem biomass on target values of stem biomass
+!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+ SUBROUTINE target_manag
+ USE data_manag
+ USE data_stand
+ USE data_species
+ USE data_simul
+ implicit none
+
+ integer taxnr,k,i
+ zeig=>pt%first
+ do
+ if(.not.associated(zeig)) exit
+ if(zeig%coh%species.le.nspec_tree) then
+ stand_age = zeig%coh%x_age
+ taxnr = zeig%coh%species
+ exit
+ end if
+ zeig => zeig%next
+ end do
+
+! stand manamgent at rotaiotn age
+if(taxnr.le.nspec_tree) then
+ if(stand_age.ne.0) then
+ select case(thr7)
+ case(1) ! shelterwood manamgent
+
+ case(2) ! clear felling
+ if(stand_age.eq.(rot(taxnr)-15)) then
+ zeig=>pt%first
+ do
+ if(.not.associated(zeig)) exit
+ if(zeig%coh%species.eq.taxnr) zeig%coh%shelter = 1
+ zeig=>zeig%next
+ end do
+ return
+ else if (stand_age.ge.rot(taxnr)) then
+
+ call felling(taxnr,i)
+ flag_manreal = 1
+ maninf = 'felling'
+ meas =0
+ call input_manrec
+ select case(mgreg)
+ case(1)
+! natural regeneration
+ flag_reg = 1
+! shelterwood management is switched off
+ thr7 = 0
+ case(10,11,12,13)
+! modification for muilti-run option BRB
+ if(taxnr.eq.1) then
+ flag_reg = 11
+ else if(taxnr.eq.2) then
+ flag_reg = 13
+ else if(taxnr.eq.3) then
+ flag_reg = 10
+ else if (taxnr.eq.4) then
+ flag_reg = 12
+ else
+ flag_reg = 14
+ end if
+
+! artificial regeneration (planting)
+ call planting
+ flag_reg = 0
+ end select ! mgreg
+ end if
+ end select ! thr7
+ end if
+
+ do i= 1, thin_nr
+ if(time .eq.thin_year(i)) then
+ if(thin_stor(i).eq.1.) then
+ select case(mgreg)
+ case(1)
+! natural regeneration
+ flag_reg = 1
+ case(10,11,12,13, 14, 17)
+
+! artificial regeneration (planting)
+ zeig=>pt%first
+ do
+ if(.not.associated(zeig)) exit
+ zeig%coh%underst = 0
+ zeig=>zeig%next
+ end do
+
+ flag_reg = mgreg
+ call planting
+ flag_reg = 0
+ end select ! mgreg
+
+ end if ! regeneration & planting
+
+ if (flag_mg.eq.3) then
+ call target_thinning_OC (i)
+ else if(flag_mg.eq. 33) then
+ call target_thinning(i)
+ end if
+ flag_manreal = 1
+ maninf='thinning'
+ call input_manrec
+ end if
+ end do
+! calculation of total dry mass of all harvested trees
+ sumvsab = 0.
+ sumvsab_m3 = 0.
+ svar%sumvsab = 0.
+
+
+ zeig=>pt%first
+do while (associated(zeig))
+ ns = zeig%coh%species
+ sumvsab = sumvsab + zeig%coh%ntreem*(zeig%coh%x_sap + zeig%coh%x_hrt)
+ sumvsab_m3 = sumvsab_m3 + zeig%coh%ntreem*(zeig%coh%x_sap + zeig%coh%x_hrt)/(spar(ns)%prhos*1000000)
+ svar(ns)%sumvsab = svar(ns)%sumvsab + zeig%coh%ntreem*(zeig%coh%x_sap + zeig%coh%x_hrt)
+ zeig=>zeig%next
+
+end do
+ sumvsab = sumvsab * 10000./kpatchsize ! kg/ha
+ sumvsab_m3 = sumvsab_m3 * 10000./kpatchsize ! kg/ha
+do k = 1, nspec_tree
+ svar(k)%sumvsab = svar(k)%sumvsab * 10000./kpatchsize ! kg/ha
+end do! cumulated harvested stem mass
+ cumsumvsab = cumsumvsab + sumvsab
+end if
+
+ END SUBROUTINE target_manag
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! input for target thinning
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+ SUBROUTINE target_ini
+
+! read definition of simple thinning from file
+ USE data_manag
+ USE data_simul
+ USE data_plant
+ USE data_species
+ integer :: manag_unit,i
+ character(len=150) :: filename
+ character ::text
+ logical :: ex
+ allocate(rot(nspec_tree))
+ allocate(thin_flag1(nspec_tree))
+
+ thin_flag1=-1
+
+manag_unit=getunit()
+filename = manfile(ip)
+call testfile(filename,ex)
+open(manag_unit,file=trim(filename))
+
+ ! read head of data-file
+ do
+ read(manag_unit,*) text
+ if(text .ne. '!')then
+
+ backspace(manag_unit);exit
+ endif
+ enddo
+
+read(manag_unit,*) thr7 ! management for rotation year
+read(manag_unit,*) mgreg ! regeneration in rotation year
+! rotation period
+read (manag_unit,*) (rot(i), i =1, nspec_tree)
+read (manag_unit,*) (numplant(i), i =1,nspec_tree)
+read (manag_unit,*) thin_nr ! number of thinning years
+allocate(thin_year(thin_nr));allocate(target_mass(thin_nr));
+allocate(thin_spec(thin_nr));allocate(thin_tysp(thin_nr))
+allocate(thin_stor(thin_nr))
+do i=1,thin_nr
+read(manag_unit,*) thin_year(i),target_mass(i), thin_spec(i), thin_tysp(i), thin_stor(i)
+end do
+close(manag_unit)
+end SUBROUTINE target_ini
\ No newline at end of file
diff --git a/source_code/version2.2_windows/mess_stat.f b/source_code/version2.2_windows/mess_stat.f
new file mode 100755
index 0000000000000000000000000000000000000000..7aa5e8413651c03533fbe706337c75722a8f5efc
--- /dev/null
+++ b/source_code/version2.2_windows/mess_stat.f
@@ -0,0 +1,1339 @@
+!*****************************************************************!
+!* *!
+!* 4C (FORESEE) Simulation Model *!
+!* *!
+!* *!
+!* Subroutines for: *!
+!* *!
+!* preparation of statistical analysis *!
+!* *!
+!* Author: F. Suckow *!
+!* *!
+!* contains: *!
+!* mess *!
+!* prep_mw *!
+!* prep_simout *!
+!* kind_pos *!
+!* store_sim_kind *!
+!* prep_stat_out *!
+!* read_simout *!
+!* open_sfile *!
+!* *!
+!* Copyright (C) 1996-2018 *!
+!* Potsdam Institute for Climate Impact Reserach (PIK) *!
+!* Authors and contributors see AUTHOR file *!
+!* This file is part of 4C and is licensed under BSD-2-Clause *!
+!* See LICENSE file or under: *!
+!* http://www.https://opensource.org/licenses/BSD-2-Clause *!
+!* Contact: *!
+!* https://gitlab.pik-potsdam.de/foresee/4C *!
+!* *!
+!*****************************************************************!
+
+SUBROUTINE mess
+
+use data_mess
+use data_out
+use data_simul
+
+implicit none
+
+integer i, j, k
+integer :: hd = -99
+real :: hv = -9999.0
+real :: helpn, totm1, totm2, totm3 ! total match as average from several values
+integer maxmess
+logical ex
+character(10) :: helpsim
+character(150) :: filename
+
+allocate (app(site_nr))
+if (unit_mess .lt. 0) then
+ do
+ inquire (File = mesfile(1), exist = ex)
+ if(ex .eqv. .false.) then
+ write (*, '(A)') ' >>>foresee message: File ',trim(mesfile(1)),' not exists !'
+ write (*, '(A)', advance='no') ' please write full name of measurement file: '
+ read(*,'(A)') mesfile(1)
+ cycle
+ else
+ exit
+ endif
+ enddo
+endif
+
+! error.log schreiben
+write(unit_err,'(A)')
+write(unit_err,'(A)')
+write(unit_err,'(A)') ' * * * * * Statistics * * * * *'
+write(unit_err,'(A)')
+
+fkind = 0
+call prep_mw
+if (tkind .eq. 1) call stat_mon
+call prep_simout
+if (.not. flag_mess) return
+call prep_stat_out
+do i = 1,site_nr
+ ip = i
+ app(i) = i
+ nme_av = 0.
+ nmae_av = 0.
+ nrmse_av = 0.
+ pme_av = 0.
+ prmse_av = 0.
+ tic_av = 0.
+ meff_av = 0.
+ rsq_av = 0.
+ totm1 = 0.
+ totm2 = 0.
+ imk_nme = imkind
+ imk_nmae = imkind
+ imk_nrmse= imkind
+ imk_rsq = imkind
+
+ call read_simout
+ call residuen(i)
+ call statistik
+
+! Mittelwert berechnen und ausdrucken
+ helpn = imkind - fkind
+ nme_av = nme_av / (imk_nme - fkind)
+ nmae_av = nmae_av / (imk_nmae - fkind)
+ nrmse_av = nrmse_av / (imk_nrmse - fkind)
+ pme_av = pme_av / helpn
+ prmse_av = prmse_av / helpn
+ tic_av = tic_av / helpn
+ meff_av = meff_av / helpn
+ rsq_av = rsq_av/(imk_rsq - fkind)
+
+! Calculation of total match without missing values
+ helpn = 2.
+ totm1 = tic_av + (1.-meff_av)
+ totm2 = totm1
+ totm3 = totm1
+ totm1 = totm1/helpn
+ if (rsq_av .ge. 0.) then
+ helpn = helpn + 1.
+ totm2 = totm2 + (1-rsq_av)
+ totm3 = totm2
+ totm2 = totm2 / helpn
+ endif
+ if (nrmse_av .lt. -9000.) then
+ helpn = helpn + 1.
+ totm3 = (totm2 + nrmse_av) / helpn
+ endif
+ write (unit_stat, '(I5,2X, A20,1X,A10,I8,1X,33E13.5)') ip, site_name(ip), 'average', hd, &
+ hv, hv, hv, hv, hv, hv, nme_av, hv, nmae_av, hv, hv, nrmse_av, pme_av, prmse_av, tic_av, meff_av, hv, rsq_av, &
+ hv, hv, hv, hv, hv, hv, hv, hv, hv, hv, hv, hv, totm1, totm2, totm3
+ write (unit_stat,*)
+
+! File mit Residuen schreiben
+ if (flag_stat .ge. 2) then
+ write (helpsim,'(I4)') ip
+ read (helpsim,*) anh
+ filename = trim(dirout)//trim(site_name(ip))//'_resid'//'.res'//trim(anh)
+ unit_mout = getunit()
+ open(unit_mout,file=filename,status='replace')
+
+ write (unit_mout, '(A)') '# Residuals etc.'
+ write (unit_mout, '(A)') '# Number kind '
+ do j = 1, imkind
+ write (unit_mout, '(I14,3X,A10,26X)', advance='no') val(j)%imes, val(j)%mkind
+ enddo
+ write (unit_mout, '(A)') ' '
+ do j = 1, imkind
+ write (unit_mout, '(A)', advance='no') ' day year residual simulation measurement'
+ enddo
+ write (unit_mout, '(A)') ' '
+
+ maxmess = maxval(val%imes)
+ do k = 1, maxmess
+ do j = 1, imkind
+ if (val(j)%imes .ge. k) then
+ write (unit_mout, '(4X,2I5,3E13.5)', advance='no') val(j)%day(k), val(j)%year(k), val(j)%resid(k), val(j)%sim(k), val(j)%mess(k)
+ else
+ write (unit_mout, '(4X,2I5,3E13.5)', advance='no') hd, hd, hv,hv,hv
+ endif
+ enddo
+ write (unit_mout, '(A)') ' '
+ enddo
+
+ close(unit_mout)
+ endif
+enddo
+
+write (*,*)
+write (*, '(A)') ' Statistical analysis completed'
+write (*,*)
+
+END SUBROUTINE mess
+
+!**************************************************************
+
+SUBROUTINE prep_mw
+
+use data_mess
+use data_simul
+
+implicit none
+
+INTERFACE
+ SUBROUTINE kind_pos(pos1, pos2, ikind, imkind, vkind, text)
+ ! assumed shape arrays
+ integer :: ikind, imkind
+ character(150) text
+ character(10), dimension(ikind):: vkind
+ integer, dimension(:):: pos1, pos2 ! Position of variables in input file
+ END SUBROUTINE
+END INTERFACE
+
+integer i, j, k, ios
+integer id, im, iy, itz
+integer idate
+character(3) ttext
+character(250) text, filename
+
+idate = 10
+allocate (mtz(2,idate))
+ unit_cons = getunit()
+ open(unit_cons,file='con')
+if (unit_mess .lt. 0) then
+ filename = mesfile(1)
+ unit_mess = getunit()
+ open(unit_mess,file=filename,iostat=ios,status='old',action='read')
+endif
+
+ do
+ read(unit_mess,*) text
+ ios = scan(text, '!')
+ IF (ios .eq. 0) then
+ backspace(unit_mess)
+ exit
+ endif
+ enddo
+
+! determin kind of measurement values; read 1. line
+ read (unit_mess, '(A)') text
+
+ ttext = adjustl(text)
+ if (ttext.eq.'dat' .or. ttext.eq.'Dat' .or. ttext.eq.'DAT') then
+ tkind = 1 ! day
+ else
+ tkind = 2 ! year
+ endif
+ call store_sim_kind(imkind, sim_kind, text)
+
+! convert measurement values to daily counter
+ select case (tkind)
+ case (1) ! daily values
+ imess = 0
+ do
+ read (unit_mess, '(2(I2,1X),I4)',iostat=ios) id, im, iy
+ if (ios .lt. 0) exit
+ call daintz(id,im,iy,itz)
+ imess = imess + 1
+ if (imess .gt. idate) then
+ allocate (help1(2,idate))
+ help1 = mtz
+ deallocate (mtz)
+ idate = idate + 10
+ allocate (mtz(2,idate))
+ do j= 1,idate - 10
+ mtz(1,j) = help1(1,j)
+ mtz(2,j) = help1(2,j)
+ enddo
+ deallocate (help1)
+ endif
+ mtz(1,imess) = itz
+ mtz(2,imess) = iy
+ enddo
+
+ !read meassurement values
+ rewind (unit_mess)
+ allocate (mess1 (imess, imkind))
+ mess1 = -9999.0
+
+ do
+ read(unit_mess,*) text
+ IF (text .ne. '!') then
+ backspace(unit_mess)
+ exit
+ endif
+ enddo
+ read (unit_mess, '(A)') text
+
+ do j = 1,imess
+ read (unit_mess, *,iostat=ios) text, (mess1(j,k), k=1,imkind)
+ enddo
+
+ case (2) ! yearly values
+ imess = 0
+ if(allocated(mess1)) then
+ write (*,'(A)') ' Feld mess1 bereits allokiert'
+ STOP
+ endif
+ allocate (mess1(idate, imkind))
+ mess1 = -9999.0
+ do
+ imess = imess + 1
+ mtz(1,imess) = 0
+ read (unit_mess, *,iostat=ios) mtz(2,imess), (mess1(imess,k), k=1,imkind)
+ mtz(1,imess) = 0
+ if (ios .lt. 0) exit
+ if (imess .gt. idate-1) then
+ allocate (help1(2,idate))
+ allocate (help2(idate, imkind))
+ help1 = mtz
+ help2 = mess1
+ deallocate (mtz)
+ deallocate (mess1)
+ idate = idate + 10
+ allocate (mtz(2,idate))
+ allocate (mess1(idate, imkind))
+ mess1 = -9999.9
+ do j= 1,idate - 10
+ mtz(1,j) = 0
+ mtz(2,j) = help1(2,j)
+ do k=1,imkind
+ mess1(j,k) = help2(j,k)
+ enddo
+ enddo
+ deallocate (help1)
+ deallocate (help2)
+ endif
+ enddo
+ imess = imess - 1
+ end select
+
+END SUBROUTINE prep_mw
+
+!**************************************************************
+
+SUBROUTINE prep_simout
+
+use data_mess
+use data_out
+use data_simul
+
+implicit none
+
+INTERFACE
+ SUBROUTINE kind_pos(pos1, pos2, ikind, imkind, vkind, text)
+ ! assumed shape arrays
+ integer :: ikind, imkind
+ character(150) text
+ character(10), dimension(ikind):: vkind
+ integer, dimension(:):: pos1, pos2 ! position of variablen in input file
+ END SUBROUTINE
+END INTERFACE
+
+integer i, ii, ik, j, k, year1
+integer, allocatable, dimension(:):: yd, yy
+character(150) :: filename
+
+flag_mess = .FALSE.
+year1 = year
+
+! Create complete array of measurements
+select case (tkind)
+case (1)
+ anz_val = 0
+ allocate (yd(year1))
+ allocate (yy(year1))
+ do i=1,year1
+ yy(i) = time_b + i - 1
+ if (mod(yy(i),4) .eq. 0 .and. yy(i) .ne. 1900) then
+ yd(i) = 366
+ else
+ yd(i) = 365
+ endif
+ anz_val = anz_val + yd(i)
+ enddo
+
+ allocate (mess2(anz_val, imkind))
+ allocate (help1(2,anz_val))
+ mess2 = -9999.0
+ j = 1
+ k = 0
+ do while (mtz(2,j) .lt. time_b)
+ j = j+1
+ enddo
+ do ii = 1, year1
+ do i = 1, yd(ii)
+ k = k + 1
+ help1(1,k) = i
+ help1(2,k) = yy(ii)
+ if ((mtz(1,j) .eq. help1(1,k)) .and. (mtz(2,j) .eq. help1(2,k))) then
+ do ik = 1, imkind
+ mess2(k,ik) = mess1(j,ik)
+ flag_mess = .TRUE.
+ enddo ! ik
+ j = j+1
+ else
+ do ik = 1, imkind
+ mess2(k,ik) = -9999.9
+ enddo ! ik
+ endif
+ enddo ! i
+ enddo ! ii
+
+case (2)
+ allocate (yy(year1))
+ anz_val = year1
+ do i=1,year1
+ yy(i) = time_b + i - 1
+ enddo
+
+ allocate (mess2(anz_val, imkind))
+ allocate (help1(2,anz_val))
+ mess2 = -9999.9
+ j = 1
+ do while (mtz(2,j) .lt. time_b)
+ j = j+1
+ enddo
+ do ii = 1, year1
+ help1(2,ii) = yy(ii)
+ help1(1,ii) = 0
+ if (mtz(2,j) .eq. help1(2,ii)) then
+ do ik = 1, imkind
+ mess2(ii,ik) = mess1(j,ik)
+ flag_mess = .TRUE.
+ enddo ! ik
+ j = j+1
+ else
+ do ik = 1, imkind
+ mess2(ii,ik) = -9999.9
+ enddo ! ik
+ endif
+ enddo ! ii
+
+end select
+
+if (.not. flag_mess) then
+ write (*,*)
+ write (*, '(A)') ' Statistical analysis:'
+ write (*, '(A)') ' No measurements within the simulation period'
+ write (*,*)
+ return
+endif
+
+! write file with complete set of meassurement values
+ if (flag_stat .eq. 3) then
+ filename = trim(dirout)//trim(site_name(1))//'_mess'//'.mes'
+ unit_mout = getunit()
+ open(unit_mout,file=filename,status='replace')
+
+ write (unit_mout, '(A)') '# Measurements '
+ write (unit_mout, '(A)') mess_info
+ write (unit_mout, '(A)', advance='no') '# day year'
+ do i=1,imkind
+ write (unit_mout, '(A13)', advance='no') sim_kind(i)
+ enddo
+ write (unit_mout, '(A)') ' '
+
+ do i = 1, anz_val
+ write (unit_mout, '(2I5)', advance='no') help1(1,i), help1(2,i)
+ do j = 1, imkind
+ write (unit_mout, '(E13.5)', advance='no') mess2(i,j)
+ enddo
+ write (unit_mout, '(A)') ' '
+ enddo
+
+ close(unit_mout)
+ endif
+
+! Read data
+allocate (sim1(anz_val, imkind))
+allocate (stz(2,anz_val))
+
+END SUBROUTINE prep_simout
+
+!**************************************************************
+
+SUBROUTINE kind_pos(pos1, pos2, ikind, imkind, vkind, text)
+
+implicit none
+
+integer imkind, & ! amount of read kinds of measurment value
+ ikind, & ! amount of allowed kinds of measurement value
+ j
+character(10), dimension(ikind):: vkind
+character(150) text
+integer, dimension(:):: pos1, pos2 ! position of variable in input file
+
+ pos1 = 9999
+ imkind = 0
+ do j = 1,ikind
+ pos1(j) = index (text, trim(vkind(j)))
+ pos2(j) = j
+ if (pos1(j) .eq. 0) then
+ pos1(j) = 9999
+ else
+ imkind = imkind +1
+ endif
+ enddo ! j
+ call sort_index(ikind, pos1, pos2)
+
+END SUBROUTINE kind_pos
+
+!**************************************************************
+
+SUBROUTINE store_sim_kind(imkind, vkind, text)
+
+implicit none
+
+integer imkind, & ! amount of read kinds of measurement values
+ ipos, & ! position of space character/sign
+ i, j
+character(10), dimension(30):: vkind
+character(250) text, text1, text2
+character(1):: setleer = ''
+character(75):: setascii
+
+ setascii = ''
+ do i = 48,122
+ j = i-47
+ setascii(j:j) = ACHAR(i) ! fill in with ASCII-character, no space character/signs
+ enddo
+ imkind = 0
+ ipos = verify(adjustl(text), setascii) ! first non-ASCII-character
+ text1 = ' '
+ text2 = adjustl(text)
+ text1 = text2(ipos:250) ! delete date/year
+ text2 = text1
+ ipos = scan(text2, setascii) ! first ASCII-character
+ text1 = text2(ipos:250) ! delete non-ASCII-characters
+ text2 = text1
+ do j = 1,30
+ ipos = verify(text2, setascii) ! first non_ASCII-character
+ vkind(j) = text2(1:ipos-1) ! save name of measurement value
+ imkind = imkind +1
+ text1 = text2(ipos:250) ! delete saved measurment value
+ text2 = text1
+ ipos = scan(text2, setascii) ! first ASCII-character
+ if (ipos .eq. 0) exit
+ text1 = text2(ipos:250)
+ text2 = text1
+ enddo ! j
+
+END SUBROUTINE store_sim_kind
+
+!**************************************************************
+
+SUBROUTINE prep_stat_out
+
+use data_mess
+use data_out
+use data_simul
+
+implicit none
+
+character(70) :: filename
+character(8) actdate
+character(10) acttime
+
+ filename = trim(site_name(1))//'_stat'//'.res'
+
+ call date_and_time(actdate, acttime)
+ unit_stat = getunit()
+ open(unit_stat,file=trim(dirout)//filename,status='replace')
+
+write (unit_stat, '(A)') '# Comparison of simulated and observed values'
+write (unit_stat, '(10A)') '# Date: ',actdate(7:8),'.',actdate(5:6),'.',actdate(1:4), &
+ ' Time: ',acttime(1:2),':',acttime(3:4)
+write (unit_stat, 1000)
+write (unit_stat, 2000)
+
+1000 format('# |-------- residuals ....... ', 15(' '), &
+ '|----------------------------- simulation -----------------------||------------------------------- observed ---------------------------|' )
+2000 format( '# ipnr site_id kind number mean min max stand_dev variance var_coeff NME MAE NMAE', &
+ ' SSE RMSE NRMSE PME PRMSE TIC MEFF cor_coeff rsquare', &
+ ' mean min max stand_dev variance var_coeff mean min max stand_dev variance var_coeff tot_match1 tot_match2 tot_match3')
+
+END SUBROUTINE prep_stat_out
+
+!**************************************************************
+
+SUBROUTINE read_simout
+
+use data_mess
+use data_out
+use data_simul
+use data_soil
+
+implicit none
+
+integer i,j, ios
+character(150) :: text
+character(50) :: message
+character(10) :: helpsim
+character(10) :: styp, skind
+character :: text1
+character(2) :: text2
+character(3) :: text3
+logical ex
+integer :: year1, unithelp
+real, dimension(26):: help_day
+real, dimension(13):: help_sum ! size is adjusted to amount of elements in ...sum.out
+real, dimension(27):: help_veg
+real, dimension(28):: help_veg_spec
+real, dimension(8):: help_lit
+real, dimension(33):: help_soil
+real, dimension(50):: tief
+real, allocatable, dimension(:) :: help_temp, help_water
+real htief, hnlay
+
+sim1 = -9999.9
+unitday = -99
+unitcbal = -99
+unitlit = -99
+unittemp = -99
+unitsum = -99
+unitveg = -99
+unitveg_pi = -99
+unitveg_sp = -99
+unitveg_bi = -99
+unitsoil = -99
+unitsoilini = -99
+unitwater = -99
+anz_sim = ip
+
+year1 = year
+
+do i=1,imkind
+ select case (sim_kind(i))
+ case ('AET')
+ if (tkind .eq. 1) then ! daily values
+ skind = 'day'
+ styp = 'out'
+ if (unitday .lt. 0) call open_sfile (skind, styp, unitday)
+ opos2(i) = 7
+ else
+ skind = 'soil'
+ styp = 'out'
+ if (unitsoil .lt. 0) call open_sfile (skind, styp, unitsoil)
+ opos2(i) = 10
+ endif
+
+ case ('BIOM', 'STVOL')
+ skind = 'veg'
+ styp = 'out'
+ if (unitveg .lt. 0) call open_sfile (skind, styp, unitveg)
+ opos2(i) = 14
+
+ case ('STVOL_pi')
+ skind = 'veg_pi'
+ styp = 'out'
+ if (unitveg_pi .lt. 0) call open_sfile (skind, styp, unitveg_pi)
+ opos2(i) = 14
+
+ case ('STVOL_sp')
+ skind = 'veg_sp'
+ styp = 'out'
+ if (unitveg_sp .lt. 0) call open_sfile (skind, styp, unitveg_sp)
+ opos2(i) = 14
+
+ case ('STVOL_bi')
+ skind = 'veg_bi'
+ styp = 'out'
+ if (unitveg_sp .lt. 0) call open_sfile (skind, styp, unitveg_bi)
+ opos2(i) = 14
+
+ case ('DG')
+ skind = 'veg'
+ styp = 'out'
+ if (unitveg .lt. 0) call open_sfile (skind, styp, unitveg)
+ opos2(i) = 7
+
+ case ('DG_pi')
+ skind = 'veg_pi'
+ styp = 'out'
+ if (unitveg_pi .lt. 0) call open_sfile (skind, styp, unitveg_pi)
+ opos2(i) = 7
+
+ case ('DG_sp')
+ skind = 'veg_sp'
+ styp = 'out'
+ if (unitveg_sp .lt. 0) call open_sfile (skind, styp, unitveg_sp)
+ opos2(i) = 7
+
+ case ('DG_bi')
+ skind = 'veg_pi'
+ styp = 'out'
+ if (unitveg_bi .lt. 0) call open_sfile (skind, styp, unitveg_bi)
+ opos2(i) = 7
+
+ case ('DBH')
+ skind = 'veg'
+ styp = 'out'
+ if (unitveg .lt. 0) call open_sfile (skind, styp, unitveg)
+ opos2(i) = 23
+
+ case ('DBH_pi')
+ skind = 'veg_pi'
+ styp = 'out'
+ if (unitveg_pi .lt. 0) call open_sfile (skind, styp, unitveg_pi)
+ opos2(i) = 24
+
+ case ('DBH_sp')
+ skind = 'veg_sp'
+ styp = 'out'
+ if (unitveg_sp .lt. 0) call open_sfile (skind, styp, unitveg_sp)
+ opos2(i) = 24
+
+ case ('DBH_bi')
+ skind = 'veg_pi'
+ styp = 'out'
+ if (unitveg_bi .lt. 0) call open_sfile (skind, styp, unitveg_bi)
+ opos2(i) = 24
+
+ case ('Fol')
+ skind = 'veg'
+ styp = 'out'
+ if (unitveg .lt. 0) call open_sfile (skind, styp, unitveg)
+ opos2(i) = 9
+
+ case ('Fol_pi')
+ skind = 'veg_pi'
+ styp = 'out'
+ if (unitveg_pi .lt. 0) call open_sfile (skind, styp, unitveg_pi)
+ opos2(i) = 9
+
+ case ('Fol_sp')
+ skind = 'veg_sp'
+ styp = 'out'
+ if (unitveg_sp .lt. 0) call open_sfile (skind, styp, unitveg_sp)
+ opos2(i) = 9
+
+ case ('Fol_bi')
+ skind = 'veg_pi'
+ styp = 'out'
+ if (unitveg_bi .lt. 0) call open_sfile (skind, styp, unitveg_bi)
+ opos2(i) = 9
+
+ case ('GPP')
+ if (tkind .eq. 1) then ! daily values
+ skind = 'sum'
+ styp = 'out'
+ if (unitsum .lt. 0) call open_sfile (skind, styp, unitsum)
+ opos2(i) = 11
+ else
+ skind = 'c_bal'
+ styp = 'out'
+ if (unitcbal .lt. 0) call open_sfile (skind, styp, unitsum)
+ opos2(i) = 1
+ endif
+
+ case ('HO')
+ skind = 'veg'
+ styp = 'out'
+ if (unitveg .lt. 0) call open_sfile (skind, styp, unitveg)
+ opos2(i) = 8
+
+ case ('HO_pi')
+ skind = 'veg_pi'
+ styp = 'out'
+ if (unitveg_pi .lt. 0) call open_sfile (skind, styp, unitveg_pi)
+ opos2(i) = 8
+
+ case ('HO_sp')
+ skind = 'veg_sp'
+ styp = 'out'
+ if (unitveg_sp .lt. 0) call open_sfile (skind, styp, unitveg_sp)
+ opos2(i) = 8
+
+ case ('HO_bi')
+ skind = 'veg_pi'
+ styp = 'out'
+ if (unitveg_bi .lt. 0) call open_sfile (skind, styp, unitveg_bi)
+ opos2(i) = 8
+
+ case ('LAI')
+ skind = 'veg'
+ styp = 'out'
+ if (unitveg .lt. 0) call open_sfile (skind, styp, unitveg)
+ opos2(i) = 4
+
+ case ('LAI_pi')
+ skind = 'veg_pi'
+ styp = 'out'
+ if (unitveg_pi .lt. 0) call open_sfile (skind, styp, unitveg_pi)
+ opos2(i) = 4
+
+ case ('LAI_sp')
+ skind = 'veg_sp'
+ styp = 'out'
+ if (unitveg_sp .lt. 0) call open_sfile (skind, styp, unitveg_sp)
+ opos2(i) = 4
+
+ case ('LAI_bi')
+ skind = 'veg_pi'
+ styp = 'out'
+ if (unitveg_bi .lt. 0) call open_sfile (skind, styp, unitveg_bi)
+ opos2(i) = 4
+
+ case ('MH')
+ skind = 'veg'
+ styp = 'out'
+ if (unitveg .lt. 0) call open_sfile (skind, styp, unitveg)
+ opos2(i) = 24
+
+ case ('MH_pi')
+ skind = 'veg_pi'
+ styp = 'out'
+ if (unitveg_pi .lt. 0) call open_sfile (skind, styp, unitveg_pi)
+ opos2(i) = 25
+
+ case ('MH_sp')
+ skind = 'veg_sp'
+ styp = 'out'
+ if (unitveg_sp .lt. 0) call open_sfile (skind, styp, unitveg_sp)
+ opos2(i) = 25
+
+ case ('MH_bi')
+ skind = 'veg_bi'
+ styp = 'out'
+ if (unitveg_bi .lt. 0) call open_sfile (skind, styp, unitveg_bi)
+ opos2(i) = 25
+
+ case ('NTREE')
+ skind = 'veg'
+ styp = 'out'
+ if (unitveg .lt. 0) call open_sfile (skind, styp, unitveg)
+ opos2(i) = 3
+
+ case ('NTREE_pi')
+ skind = 'veg_pi'
+ styp = 'out'
+ if (unitveg_pi .lt. 0) call open_sfile (skind, styp, unitveg_pi)
+ opos2(i) = 3
+
+ case ('NTREE_sp')
+ skind = 'veg_sp'
+ styp = 'out'
+ if (unitveg_sp .lt. 0) call open_sfile (skind, styp, unitveg_sp)
+ opos2(i) = 3
+
+ case ('NTREE_bi')
+ skind = 'veg_pi'
+ styp = 'out'
+ if (unitveg_bi .lt. 0) call open_sfile (skind, styp, unitveg_bi)
+ opos2(i) = 3
+
+ case ('NEE')
+ skind = 'sum'
+ styp = 'out'
+ if (unitsum .lt. 0) call open_sfile (skind, styp, unitsum)
+ opos2(i) = 6
+
+ case ('NEP')
+ skind = 'c_bal'
+ styp = 'out'
+ if (unitcbal .lt. 0) call open_sfile (skind, styp, unitcbal)
+ opos2(i) = 3
+
+ case ('Litter')
+ skind = 'litter'
+ styp = 'out'
+ if (unitlit .lt. 0) call open_sfile (skind, styp, unitlit)
+ opos2(i) = 1
+
+ case ('prec_stand')
+ skind = 'soil'
+ styp = 'out'
+ if (unitsoil .lt. 0) call open_sfile (skind, styp, unitsoil)
+ opos2(i) = 2
+
+ case ('prec_st_d')
+ skind = 'day'
+ styp = 'out'
+ if (unitday .lt. 0) call open_sfile (skind, styp, unitday)
+ opos2(i) = 4
+
+ case ('s_resp')
+ skind = 'day'
+ styp = 'out'
+ if (unitday .lt. 0) call open_sfile (skind, styp, unitday)
+ opos2(i) = 12
+
+ case ('Snow')
+ skind = 'day'
+ styp = 'out'
+ if (unitday .lt. 0) call open_sfile (skind, styp, unitday)
+ opos2(i) = 5
+
+ case ('STBIOM')
+ skind = 'veg'
+ styp = 'out'
+ if (unitveg .lt. 0) call open_sfile (skind, styp, unitveg)
+ opos2(i) = 10
+
+ case ('STBIOM_pi')
+ skind = 'veg_pi'
+ styp = 'out'
+ if (unitveg_pi .lt. 0) call open_sfile (skind, styp, unitveg_pi)
+ opos2(i) = 10
+
+ case ('STBIOM_sp')
+ skind = 'veg_sp'
+ styp = 'out'
+ if (unitveg_sp .lt. 0) call open_sfile (skind, styp, unitveg_sp)
+ opos2(i) = 10
+
+ case ('STBIOM_bi')
+ skind = 'veg_bi'
+ styp = 'out'
+ if (unitveg_sp .lt. 0) call open_sfile (skind, styp, unitveg_bi)
+ opos2(i) = 10
+
+ case ('Stem_inc')
+ skind = 'veg'
+ styp = 'out'
+ if (unitveg .lt. 0) call open_sfile (skind, styp, unitveg)
+ opos2(i) = 13
+
+ case ('Stem_inc_pi')
+ skind = 'veg_pi'
+ styp = 'out'
+ if (unitveg_pi .lt. 0) call open_sfile (skind, styp, unitveg_pi)
+ opos2(i) = 13
+
+ case ('Stem_inc_sp')
+ skind = 'veg_sp'
+ styp = 'out'
+ if (unitveg_sp .lt. 0) call open_sfile (skind, styp, unitveg_sp)
+ opos2(i) = 13
+
+ case ('Stem_inc_bi')
+ skind = 'veg_pi'
+ styp = 'out'
+ if (unitveg_bi .lt. 0) call open_sfile (skind, styp, unitveg_bi)
+ opos2(i) = 13
+
+ case ('TER')
+ if (tkind .eq. 1) then ! daily values
+ skind = 'sum'
+ styp = 'out'
+ if (unitsum .lt. 0) call open_sfile (skind, styp, unitsum)
+ opos2(i) = 12
+ else
+ skind = 'c_bal'
+ styp = 'out'
+ if (unitcbal .lt. 0) call open_sfile (skind, styp, unitsum)
+ opos2(i) = 6
+ endif
+
+ case ('transtree')
+ skind = 'day'
+ styp = 'out'
+ if (unitday .lt. 0) call open_sfile (skind, styp, unitday)
+ opos2(i) = 9
+
+ case ('WC_002')
+ skind = 'watvol'
+ styp = 'out'
+ if (unitwater .lt. 0) call open_sfile (skind, styp, unitwater)
+ opos2(i) = 1
+
+ case ('TS_002')
+ skind = 'temp'
+ styp = 'out'
+ if (unittemp .lt. 0) call open_sfile (skind, styp, unittemp)
+ opos2(i) = 2
+
+ case default
+
+ text2 = sim_kind(i) (1:2)
+ if ((text2 .eq. 'TS') .or. (text2 .eq. 'WC')) then
+ skind = 'soil'
+ styp = 'ini'
+ if (unitsoilini .lt. 0) then
+ call open_sfile (skind, styp, unitsoilini)
+ read (unitsoilini, *) text
+ read (unitsoilini, *) text
+ do j=1, 50
+ read (unitsoilini, *,iostat=ios) hnlay, tief(j)
+ if (hnlay .eq. 0) then
+ exit
+ else
+ nlay = hnlay
+ endif
+ if (ios .ne. 0) exit
+ enddo
+ endif
+
+ select case (text2)
+ case ('TS')
+ skind = 'temp'
+ styp = 'out'
+ if (unittemp .lt. 0) call open_sfile (skind, styp, unittemp)
+
+ text3 = sim_kind(i) (4:6)
+ write (helpsim, *) text3
+ read (helpsim,*) htief
+ ! htief = 5.
+ do j=2,nlay
+ if ((tief(j)-tief(1)) .ge. htief) then
+ opos2(i) = j+1
+ exit
+ endif
+ enddo
+ if (opos2(i) .le.0) then
+ message = "no simulation values of "//text2//" for depth "
+ opos2(i) = nlay
+ write(unit_err,'(A)',advance='no') trim(message)
+ write(unit_err,'(F5.0,A)') htief, " cm"
+ else
+ message = "simulation values of "//text2//" for depth "
+ write(unit_err,'(A)',advance='no') trim(message)
+ write(unit_err,'(F5.0,A)') htief, " cm"
+ message = " selected layer: "
+ write(unit_err,'(A)',advance='no') trim(message)
+ write(unit_err,'(I3)') j
+ endif
+
+ case ('WC')
+ skind = 'watvol'
+ styp = 'out'
+ if (unitwater .lt. 0) call open_sfile (skind, styp, unitwater)
+
+ text3 = sim_kind(i) (4:6)
+ write (helpsim, *) text3
+ read (helpsim,*) htief
+ do j=2,nlay
+ if ((tief(j)-tief(1)) .ge. htief) then
+ opos2(i) = j
+ exit
+ endif
+ enddo
+ if (opos2(i) .le.0) then
+ message = "no simulation values of "//text2//" for depth "
+ opos2(i) = nlay
+ write(unit_err,'(A)',advance='no') trim(message)
+ write(unit_err,'(F5.0,A)') htief, " cm"
+ else
+ message = "simulation values of "//text2//" for depth "
+ write(unit_err,'(A)',advance='no') trim(message)
+ write(unit_err,'(F5.0,A)') htief, " cm"
+ message = " selected layer: "
+ write(unit_err,'(A)',advance='no') trim(message)
+ write(unit_err,'(I3)') j
+ endif
+
+ end select ! text2
+ else
+ fkind = fkind + 1
+ write (unit_err, *)
+ write (unit_err, '(A)') 'Statistics - Undefined kind of measurement '//sim_kind(i)
+ endif
+
+ end select
+enddo ! i - imkind
+
+! read in results file
+
+! read day-file
+ if (unitday .ge. 0) then
+ do
+ read(unitday,*) text
+ IF (adjustl(text) .ne. '#') then
+ backspace(unitday)
+ exit
+ endif
+ enddo
+
+ do j = 1,anz_val
+ read (unitday, *) stz(1,j), stz(2,j), help_day
+ do i=1,imkind
+ select case (sim_kind(i))
+ case ('AET','Snow','prec_st_d','s_resp','transtree')
+ sim1(j,i) = help_day(opos2(i))
+ end select
+ enddo
+ enddo
+ endif ! unitday
+
+! read temp-file
+ if (unittemp .ge. 0) then
+ do
+ read(unittemp,*) text
+ IF (adjustl(text) .ne. '#') then
+ backspace(unittemp)
+ exit
+ endif
+ enddo
+ allocate (help_temp(nlay))
+
+ do j = 1,anz_val
+ read (unittemp, *) stz(1,j), stz(2,j), help_temp
+ do i=1,imkind
+ if (opos2(i) .gt. 0) then
+ select case (sim_kind(i) (1:2))
+ case ('TS')
+ sim1(j,i) = help_temp(opos2(i))
+ end select
+ endif
+ enddo
+ enddo
+ deallocate (help_temp)
+ endif ! unittemp
+
+! read water-file
+ if (unitwater .ge. 0) then
+ do
+ read(unitwater,*) text
+ IF (adjustl(text) .ne. '#') then
+ backspace(unitwater)
+ exit
+ endif
+ enddo
+ allocate (help_water(nlay))
+
+ do j = 1,anz_val
+ read (unitwater, *) stz(1,j), stz(2,j), help_water
+ do i=1,imkind
+ if (opos2(i) .gt. 0) then
+ select case (sim_kind(i) (1:2))
+ case ('WC')
+ sim1(j,i) = help_water(opos2(i))
+ end select
+ endif
+ enddo
+ enddo
+ deallocate (help_water)
+ endif ! unitwater
+
+! read sum-file
+ if (unitsum .ge. 0) then
+ do
+ read(unitsum,*) text
+ text1 = adjustl(text)
+ IF (text1 .ne. '#') then
+ backspace(unitsum)
+ exit
+ endif
+ enddo
+
+ do j = 1,anz_val
+ read (unitsum, *) stz(1,j), stz(2,j), help_sum
+ do i=1,imkind
+ select case (sim_kind(i))
+ case ('NEE','GPP','TER')
+ sim1(j,i) = help_sum(opos2(i))
+ end select
+ enddo
+ enddo
+ endif ! unitsum
+
+! read c_bal-file
+ if (unitcbal .ge. 0) then
+ do
+ read(unitcbal,*) text
+ text1 = adjustl(text)
+ IF (text1 .ne. '#') then
+ exit ! 1. line for standard values is skiped
+ endif
+ enddo
+ do j = 1,year1
+ read (unitcbal, *) stz(2,j), help_veg
+ do i=1,imkind
+ select case (sim_kind(i))
+ case ('NEP','GPP','TER')
+ sim1(j,i) = help_veg(opos2(i))
+
+ end select
+ enddo
+ enddo
+ endif ! unitcbal
+
+! read litter-file
+ if (unitlit .ge. 0) then
+ do
+ read(unitlit,*) text
+ text1 = adjustl(text)
+ IF (text1 .ne. '#') then
+ exit
+ endif
+ enddo
+
+ do j = 1,year1
+ read (unitlit, *) stz(2,j), help_lit
+ do i=1,imkind
+ select case (sim_kind(i))
+
+ case ('Litter')
+ sim1(j,i) = help_lit(opos2(i))
+
+ end select
+ enddo
+ enddo
+ endif ! unitlit
+
+! read soil-file
+ if (unitsoil .ge. 0) then
+ do
+ read(unitsoil,*) text
+ text1 = adjustl(text)
+ IF (text1 .ne. '#') then
+ exit ! 1. line of standard values is skiped
+ endif
+ enddo
+ do j = 1,year1
+ read (unitsoil, *) stz(2,j), help_soil
+ do i=1,imkind
+ select case (sim_kind(i))
+ case ('prec_stand')
+ sim1(j,i) = help_soil(opos2(i)) - help_soil(opos2(i)+1)
+
+ case ('AET')
+ sim1(j,i) = help_soil(opos2(i))
+ end select
+ enddo
+ enddo
+ endif ! unitsoil
+
+! read veg-file
+ if (unitveg .ge. 0) then
+ do
+ read(unitveg,*) text
+ text1 = adjustl(text)
+ IF (text1 .ne. '#') then
+ exit
+ endif
+ enddo
+ do j = 1,year1
+ read (unitveg, *) stz(2,j), help_veg
+ do i=1,imkind
+ select case (sim_kind(i))
+ case ('STBIOM')
+ sim1(j,i) = (help_veg(opos2(i)) + help_veg(opos2(i)+2))
+
+ case ('BIOM','DG','DBH','Fol','LAI','NTREE','Stem_inc')
+ sim1(j,i) = help_veg(opos2(i))
+
+ case ('HO','MH')
+ sim1(j,i) = help_veg(opos2(i)) / 100.
+
+ end select
+ enddo
+ enddo
+ endif ! unitveg
+
+! read veg_pi-file
+ if (unitveg_pi .ge. 0) then
+ do
+ read(unitveg_pi,*) text
+ text1 = adjustl(text)
+ IF (text1 .ne. '#') then
+ exit
+ endif
+ enddo
+ do j = 1,year1
+ read (unitveg_pi, *) stz(2,j), help_veg_spec
+ do i=1,imkind
+ select case (sim_kind(i))
+ case ('STBIOM_pi')
+ sim1(j,i) = (help_veg_spec(opos2(i)) + help_veg_spec(opos2(i)+2))
+
+ case ('BIOM_pi','DG_pi','DBH_pi','Fol_pi','LAI_pi','NTREE_pi','Stem_inc_pi')
+ sim1(j,i) = help_veg_spec(opos2(i))
+
+ case ('HO_pi','MH_pi')
+ sim1(j,i) = help_veg_spec(opos2(i)) / 100.
+
+ end select
+ enddo
+ enddo
+ endif ! unitveg_pi
+
+! read veg_sp-file
+ if (unitveg_sp .ge. 0) then
+ do
+ read(unitveg_sp,*) text
+ text1 = adjustl(text)
+ IF (text1 .ne. '#') then
+ exit
+ endif
+ enddo
+ do j = 1,year1
+ read (unitveg_sp, *) stz(2,j), help_veg_spec
+ do i=1,imkind
+ select case (sim_kind(i))
+ case ('STBIOM_sp')
+ sim1(j,i) = (help_veg_spec(opos2(i)) + help_veg_spec(opos2(i)+2))
+
+ case ('BIOM_sp','DG_sp','DBH_sp','Fol_sp','LAI_sp','NTREE_sp','Stem_inc_sp')
+ sim1(j,i) = help_veg_spec(opos2(i))
+
+ case ('HO_sp','MH_sp')
+ sim1(j,i) = help_veg_spec(opos2(i)) / 100.
+
+ end select
+ enddo
+ enddo
+ endif ! unitveg_sp
+
+! read veg_bi-file
+ if (unitveg_bi .ge. 0) then
+ do
+ read(unitveg_bi,*) text
+ text1 = adjustl(text)
+ IF (text1 .ne. '#') then
+ exit
+ endif
+ enddo
+ do j = 1,year1
+ read (unitveg_bi, *) stz(2,j), help_veg_spec
+ do i=1,imkind
+ select case (sim_kind(i))
+ case ('STBIOM_bi')
+ sim1(j,i) = (help_veg_spec(opos2(i)) + help_veg_spec(opos2(i)+2))
+
+ case ('BIOM_bi','DG_bi','DBH_bi','Fol_bi','LAI_bi','NTREE_bi','Stem_inc_bi')
+ sim1(j,i) = help_veg_spec(opos2(i))
+
+ case ('HO_bi','MH_bi')
+ sim1(j,i) = help_veg_spec(opos2(i)) / 100.
+
+ end select
+ enddo
+ enddo
+ endif ! unitveg_bi
+
+END SUBROUTINE read_simout
+
+
+!**************************************************************
+
+SUBROUTINE open_sfile (okind, otyp, unitnr)
+
+use data_mess
+use data_out
+use data_simul
+
+implicit none
+
+integer unitnr
+character(150) :: simsumfile ! simulation output sum-file
+character(150) :: simoutfile ! simulation output file
+character(10) :: helpsim
+character(10) :: otyp, okind
+logical ex
+
+ WRITE(helpsim,'(I2)') app(ip)
+ read(helpsim,*) anh
+ simoutfile = trim(dirout)//trim(site_name(ip))//'_'//trim(okind)//'.'//trim(otyp)//trim(anh)
+ inquire (File = simoutfile, exist = ex)
+ if(ex .eqv. .false.) then
+ write (*, '(A)') ' >>>foresee message: no such file ', adjustl(simoutfile)
+ return
+ else
+ write (*, '(A)') ' >>>foresee message: Filetest - file exists ',trim(simoutfile)
+ endif
+ unitnr = getunit()
+ open(unitnr,file=simoutfile,status='old')
+
+END SUBROUTINE open_sfile
+
+
diff --git a/source_code/version2.2_windows/npp.f b/source_code/version2.2_windows/npp.f
new file mode 100755
index 0000000000000000000000000000000000000000..37296c13f23dcc3c4380a57b360c8476aa7abbf5
--- /dev/null
+++ b/source_code/version2.2_windows/npp.f
@@ -0,0 +1,497 @@
+!*****************************************************************!
+!* *!
+!* 4C (FORESEE) *!
+!* *!
+!* *!
+!* Subroutines for: *!
+!* Calculation of daily NPP *!
+!* *!
+!* SR OPT_PS: optimum photosynthesis & conductance calculation *!
+!* SR NPP: determination of realized net primary production *!
+!* *!
+!* Copyright (C) 1996-2018 *!
+!* Potsdam Institute for Climate Impact Reserach (PIK) *!
+!* Authors and contributors see AUTHOR file *!
+!* This file is part of 4C and is licensed under BSD-2-Clause *!
+!* See LICENSE file or under: *!
+!* http://www.https://opensource.org/licenses/BSD-2-Clause *!
+!* Contact: *!
+!* https://gitlab.pik-potsdam.de/foresee/4C *!
+!* *!
+!*****************************************************************!
+
+!***********************!
+!* SUBROUTINE OPT_PS *!
+!***********************!
+
+! calculates optimum photosynthesis following Haxeltine & Prentice (1996)
+
+SUBROUTINE OPT_PS(temp, dayl, PAR, ApPa)
+
+ !*** Declaration part ***!
+
+ USE data_species
+ USE data_stand
+ USE data_simul
+ USE data_climate
+ USE data_par
+
+ IMPLICIT NONE
+
+ ! input variables
+ REAL :: temp, & ! temperature
+ dayl, & ! day length
+ PAR ! total available PAR
+
+ ! auxiliary variables
+ REAL :: ApPa, & ! atmospheric pressure [Pa], input [hPa]
+ VmOpt = 0., &
+ VmMax = 0., & ! nitrogen limited carboxylation rate
+ Jc = 0., & ! Rubisco limited rate of photosynthesis
+ Je = 0., & ! photosynthetic response under light limitation
+ assiSpe = 0., & ! specific gross photosynthesis [gC m-2 canopy projection d-1]
+ respSpe = 0., & ! specific leaf respiration [gC m-2 canopy projection d-1]
+ assDt, & ! net daytime assimilation rate
+ PHIT = 0., &
+ XHELP = 0., &
+ kco2, &
+ ko2, &
+ tau, & ! Rubisco specificity
+ piCO2, & ! leaf internal CO2 partial pressure [Pa]
+ gammas, & ! CO2 compensation point in absence of mitochondrial respiration [Pa]
+ delta, &
+ sigma, &
+ c1, &
+ c2, &
+ vmspe, &
+ redn_h, &
+ h_age
+
+ ! variables required for technical reasons
+ ! INTEGER :: nl ! loop variable for crown layers
+ integer ntr, i, j
+
+ TYPE(coh_obj), POINTER :: p
+
+
+ !*** Calculation part ***!
+
+! conversion of pressure from [kPa] to [P]
+ ApPa = ApPa * 100. ! hPa ==> Pa
+
+ ! initialization of canopy conductance
+ gp_can = 0.
+ gp_tot = 0.
+ phot_C=0.
+ ! polar night
+ if (dayl .lt. zero) then
+ p => pt%first
+ DO WHILE (ASSOCIATED(p))
+ p%coh%LUE = 0.0
+ p%coh%assi = 0.0
+ p%coh%resp = 0.0
+ p%coh%gp = 0.0
+ p%coh%Ndemc_d = 0.0
+
+ p => p%next
+ enddo
+ return
+ endif
+
+ ! Determination of photosynthesis nitrogen reduction factor RedN for species
+ select case (flag_limi)
+ case (11)
+ do j=1,anrspec
+ i = nrspec(j)
+ redn_h = svar(i)%RedN
+ if(svar(i)%Ndem .gt. 0) then
+ svar(i)%RedN = svar(i)%Nupt / svar(i)%Ndem
+ if (svar(i)%RedN .gt. 1.) svar(i)%RedN=1.
+ else
+ svar(i)%RedN = redn_h
+ endif
+ enddo
+
+ case (12)
+ do j=1,anrspec
+ i = nrspec(j)
+ redn_h = svar(i)%RedN
+ if(svar(i)%Ndem .gt. 0) then
+ if (svar(i)%Nupt .gt. svar(i)%Ndem) then
+ svar(i)%RedN = 1
+ else
+ svar(i)%RedN = exp((svar(i)%Nupt / svar(i)%Ndem) -1.)
+ endif
+ else
+ svar(i)%RedN = redn_h
+ endif
+ enddo
+
+ case (13,14)
+ do j=1,anrspec
+ i = nrspec(j)
+ redn_h = svar(i)%RedN
+ if(svar(i)%Ndem .gt. 0) then
+ xhelp = svar(i)%Nupt / svar(i)%Ndem
+ svar(i)%RedN = 2.*(xhelp+0.01) / (xhelp+1.)
+ else
+ svar(i)%RedN = redn_h
+ endif
+ if(svar(i)%Nupt .le. zero) svar(i)%RedN = redn_h
+ enddo
+
+ case (15)
+ do j=1,anrspec
+ i = nrspec(j)
+ redn_h = svar(i)%RedN
+ if(svar(i)%Ndem .gt. zero) then
+ xhelp = svar(i)%Nupt / svar(i)%Ndem
+ select case (i)
+ case (3) ! pine
+ if (xhelp .gt. 10.) then
+ svar(i)%RedN=1.
+ else
+ svar(i)%RedN = exp(xhelp -0.7) - 0.5
+ endif
+
+ case (10, 14) ! dougfir, ground vegetation
+ continue ! annual calculation in RedN_calc
+
+ case default
+ svar(i)%RedN = 2.*(xhelp+0.01) / (xhelp+1.)
+
+ end select
+ if (svar(i)%RedN .gt. 1.) svar(i)%RedN=1.
+ if (svar(i)%RedN .lt. 0.1) svar(i)%RedN=0.1
+ else
+ svar(i)%RedN = redn_h
+ endif
+ if(svar(i)%Nupt .le. zero) svar(i)%RedN = redn_h
+ if (i.eq.nspec_tree+2) then
+ svar(i)%RedN=1.
+ endif
+ enddo
+
+ case (16)
+ svar%Ndemp = -1.*svar%Ndemp
+ svar%Nuptp = -1.*svar%Nuptp
+ zeig => pt%first
+ DO WHILE (ASSOCIATED(zeig))
+
+ ns = zeig%coh%species
+ ntr = zeig%coh%ntreea
+ svar(ns)%Ndemp = svar(ns)%Ndemp + ntr * zeig%coh%Ndemc_c
+ svar(ns)%Nuptp = svar(ns)%Nuptp + ntr * zeig%coh%Nuptc_c
+
+ zeig => zeig%next
+ ENDDO
+
+ do j=1,anrspec
+ i = nrspec(j)
+ redn_h = svar(i)%RedN
+ if(svar(i)%Ndemp .gt. 0) then
+ svar(i)%RedN = svar(i)%Nuptp / svar(i)%Ndemp
+ else
+ svar(i)%RedN = redn_h
+ endif
+ enddo
+
+ end select ! flag_limi
+
+! internal partial pressure of CO2 (Eq A9)
+piCO2 = ApPa * lambda * CO2
+
+! temperature dependent damping function; orig pars: 0.2, 10.
+PHIT = 1. / ( 1.+exp(0.4*(7.-temp)) )
+
+! loop over all cohorts
+ p => pt%first
+ DO WHILE (ASSOCIATED(p))
+
+ ns = p%coh%species
+
+ ! parameter variations with temperature (Eq A14)
+
+ KCO2 = spar(ns)%kCO2_25 * spar(ns)%q10_kCO2 ** ( (temp - 25.) / 10.)
+ KO2 = spar(ns)%kO2_25 * spar(ns)%q10_kO2 ** ( (temp - 25.) / 10.)
+ tau = spar(ns)%pc_25 * spar(ns)%q10_pc ** ( (temp - 25.) / 10.)
+
+ ! CO2 compensation point in absence of mitochondrial respiration, O2 converted from kPa to Pa
+ gammas = O2*1000 / (2. * tau)
+
+ ! slope for light response under PAR limitation (Eq A7)
+ C1 = PHIT*spar(ns)%phic*Cmass*QCO2*QCO2a * (piCO2 - gammas) / (piCO2 + 2.*gammas) ! 0.35
+
+ ! slope for light response under Rubisco limitation (Eq A11)
+ C2 = (piCO2 - gammas) / ( piCO2 + KCO2 * (1. + O2 / KO2) )
+
+ ! daylength-dependent term (original: s)
+ DELTA = (24. / dayL) * spar(ns)%pb
+
+ ! optimal light use efficiency (Eq A17 and A17a)
+ SIGMA = AMAX1 (0.0001, 1. - (C2 - DELTA) / (C2 - PS * DELTA) ) ** 0.5 ! 0.25 - 0.45
+ VmSpe = (1. / spar(ns)%pb) * (C1 / C2) * ( (2.*PS - 1.) * &
+ DELTA - (2.*PS * DELTA - C2) * SIGMA)
+
+ ! maximum carboxylation potential in gC m-2 d-1 ???
+ VmOpt = p%coh%totFPAR * PAR * VmSpe
+
+! Determination of photosynthesis nitrogen reduction factor RedN
+ select case (flag_limi)
+ case (0,1)
+ p%coh%RedNc = 1.
+
+ case (2,3,10)
+ p%coh%RedNc = svar(ns)%RedN
+
+ case (4,5)
+ ! N effect on photosynthesis
+ XHELP = PN * exp ( - 0.0693 * (temp - 25.) )
+ ! calculate Vmax as function of metabolically active nitrogen per unit crown projection area first, is now in mymol m-2 s-1
+ VmMax = (p%coh%N_fol - Nc0*p%coh%x_fol) / p%coh%crown_area / XHELP
+ p%coh%RedNc = MIN (1., VmMax / VmOpt)
+
+ case (6,7)
+ if ((p%coh%Ndemc_d .gt. 1.E-6) .and. (p%coh%Nuptc_d .gt. 1.E-6)) then
+ p%coh%RedNc = p%coh%Nuptc_c / p%coh%Ndemc_c
+ else
+ p%coh%RedNc = svar(ns)%RedN
+ endif
+
+ case (8,9)
+ h_age = p%coh%x_age
+ if( h_age.lt.50.) then
+ redn_h =svar(ns)%RedN
+ else if( (h_age-time).lt.50) then
+
+ ! age dependent reduction of redN
+ redn_h = svar(ns)%RedN*(1-max(0.,(h_age-50)*0.002))
+ else
+ redn_h = svar(ns)%RedN*(1-max(0.,(time)*0.002))
+ end if
+ p%coh%RedNc = redn_h
+
+ case (11,12,13,14,15,16) ! calculation of cohort loop
+ p%coh%RedNc = svar(p%coh%species)%RedN
+
+ end select
+
+
+
+ ! limiting rates
+ Jc = C2 * VmSpe / 24.
+ Je = C1 / dayL
+
+ ! gross assimilation and leaf respiration in [g C/(day*m2)]
+ p%coh%LUE = dayL * ( Je+Jc - SQRT( (Je+Jc) * (Je+Jc) - 4.*PS*Je*Jc) ) / (2.*PS) * p%coh%RedNc
+ assiSpe = p%coh%LUE * p%coh%totFPAR * PAR
+ if(p%coh%totFPAR.lt.0) then
+ continue
+ end if
+ respSpe = spar(ns)%pb * VmOpt * p%coh%RedNc
+ phot_C = phot_C + p%coh%ntreea*assiSpe !summation for output BE
+
+ p%coh%assi = assiSpe * kPatchSize / 1000. * (1/cpart) ! conversion g C/day*m2 -> kg DW/day*patch
+ p%coh%resp = respSpe * kPatchSize / 1000. * (1/cpart) ! conversion g C/day*m2 -> kg DW/day*patch
+
+ ! optimum stomatal conductance (modified from Haxeltine & Prentice 1996) [mol/(m2*d)]
+ assDt = assiSpe - dayL/24.*respSpe
+ p%coh%gp = AMAX1( gmin, 1.56*assDt / (1.0-lambda) / CO2 / Cmass )
+
+ ! update canopy conductance
+ IF (p%coh%species.le.nspec_tree .or. p%coh%species.eq.nspec_tree+2 ) then
+ gp_can = gp_can + p%coh%gp*p%coh%nTreeA
+ else
+ gp_tot = gp_tot + p%coh%gp*p%coh%nTreeA
+ endif
+
+
+
+ p => p%next
+
+ END DO
+
+
+
+ gp_tot = gp_tot + gp_can
+
+END SUBROUTINE OPT_PS
+
+!********************!
+!* SUBROUTINE NPP *!
+!********************!
+
+! determines realized assimilation rate by taking into account water stress, and
+! calculates growth and maintenance respiration, plus overall net primary production
+
+SUBROUTINE NPP( temp, dayL, PAR, jx )
+
+ !*** Declaration part ***!
+
+ USE data_par
+ USE data_stand
+ USE data_species
+ USE data_simul
+ USE data_soil_cn
+
+ IMPLICIT NONE
+
+ ! input variables
+ REAL:: temp, &
+ dayL, &
+ PAR
+
+ ! auxiliary variables
+ REAL :: netAsspot, & ! daily potential (= no water and nutrient limitation) net assimilation rate [= dimension of p%coh%assi]
+ netAss, & ! daily net assimilation rate [= dimension of p%coh%assi]
+ maintResp, & ! daily maintenance respiration costs
+ dailypotNPP, & ! daily potential (= no water and nutrient limitation) net primary productivity per tree
+ dailyNPP, & ! daily net primary productivity per tree [gC tree-1]
+ drLimF, & ! drought factor limiting the assimilation rate
+ grass = 0, & ! gross daily assimilation rate
+ respfol, &
+ prms, &
+ prmr, &
+ NPP_mistletoe,& ! NPP of mistletoe
+ pq10, & ! q10 value for maint. respiration stem, fine root
+ help, presp
+ INTEGER :: jx ! time step length of PS/NPP model
+
+ TYPE(coh_obj), POINTER :: p
+ pq10=2.0
+
+!*** Calculation part ***!
+
+ !extraction of theor. produced NPP of mistletoe cohort
+ p => pt%first
+ do while (associated(p))
+ if (p%coh%species.eq.nspec_tree+2) then
+ NPP_mistletoe=p%coh%NPP
+ NPP_demand_mistletoe=0.3*NPP_mistletoe ! NPP that mistletoe demands from host (30% heterotroph carbon gain (Richter 1992)
+ p%coh%NPP=0.7*NPP_mistletoe ! rest of NPP stays with mistletoe (autotroph)
+ end if
+ p => p%next
+ enddo
+
+ dailypotNPP_C=0.
+ dailyNPP_C=0.
+ dailyautresp_C = 0.
+ dailygrass_C = 0.
+ dailynetass_C = 0.
+ respr_day = 0.
+ dailyrespfol_C = 0.
+ ! loop over all cohorts
+ p => pt%first
+ DO WHILE (ASSOCIATED(p))
+ ! reduction of NPP of mistletoe infected tree cohort
+ if (p%coh%mistletoe.eq.1) then
+ p%coh%NPP = p%coh%NPP-NPP_demand_mistletoe
+ endif
+ ns = p%coh%species
+ IF ( p%coh%drIndPS .lt. 0.0 ) THEN
+ continue
+ endif
+
+ ! drought index
+ IF ( p%coh%nDaysPS /= 0. ) THEN
+ p%coh%drIndPS = p%coh%drIndPS / p%coh%nDaysPS
+ ELSE
+ p%coh%drIndPS = 0. ! -> npp = 0
+ END IF
+
+ ! limiting function
+ select case(flag_limi)
+ case(0,2,4,6,8,14)
+ drLimF = 1.0
+
+ case default
+ drLimF = p%coh%drIndPS
+
+ end select
+
+ ! total net assimilation, maintenance respiration and NPP of this tree
+ if (p%coh%RedNc .gt. 1.E-6) then
+ netAsspot = (p%coh%assi - p%coh%resp) / p%coh%RedNc
+ else
+ netAsspot = 0.
+ endif
+ netAss = drLimF * (p%coh%assi - p%coh%resp)
+ grass = drLimF * p%coh%assi
+ p%coh%respfol = grass -netAss
+ respfol = p%coh%respfol
+
+ IF (flag_resp==1) THEN
+ ! calculate temperature dependant rates
+ prmr=spar(ns)%prmr*pq10**((temp-15)/10)
+ prms=spar(ns)%prms*pq10**((temp-15)/10)
+ ! leaf maintenance respiration added
+ maintResp = prms * p%coh%x_sap + prmr * p%coh%x_frt + respfol
+
+! for complete outputs of respiration components:
+ p%coh%respsap = prms * p%coh%x_sap
+ p%coh%respfrt = prmr * p%coh%x_frt
+ p%coh%respbr = prms * p%coh%x_tb
+ dailypotNPP = (1.-spar(ns)%prg) * (netAsspot - maintResp)
+ dailyNPP = (1.-spar(ns)%prg) * (netAss - maintResp)
+ help = spar(ns)%prg * (netAss - maintResp)
+
+ ELSEIF (flag_resp==2) THEN
+
+ presp=0.03
+ maintResp = (p%coh%x_sap*cpart/spar(ns)%cnr_stem + p%coh%x_crt*cpart/spar(ns)%cnr_crt + p%coh%x_tb*cpart/spar(ns)%cnr_tbc + p%coh%x_frt*cpart/spar(ns)%cnr_frt)*presp
+ maintresp=maintresp*exp(308.56*((1/56.02)-(1/(temp+46.02))))
+
+ dailypotNPP = (1.-spar(ns)%prg) * (netAsspot - maintResp)
+ dailyNPP = (1.-spar(ns)%prg) * (netAss - maintResp)
+ ELSE
+ dailypotNPP=netAsspot*(1-spar(ns)%respcoeff)
+ dailyNPP=netAss*(1-spar(ns)%respcoeff)
+ maintResp = netAss*spar(ns)%respcoeff
+ ENDIF
+ IF(p%coh%species <= nspec_tree) THEN
+ dailypotNPP_C = dailypotNPP_C + p%coh%ntreea*dailypotNPP*cpart*kg_in_g / (kPatchSize) !conversion in gC/m2
+ dailyNPP_C = dailyNPP_C + p%coh%ntreea*dailyNPP*cpart*kg_in_g / (kPatchSize) !conversion in gC/m2
+ if (flag_resp.eq.1) then
+ dailyautresp_C = dailyautresp_C + p%coh%ntreea*(maintresp+help)*cpart*kg_in_g / (kPatchSize)
+ ELSE ! flag_resp=0
+ dailyautresp_C = dailyautresp_C + p%coh%ntreea*(respfol+maintresp)*cpart*kg_in_g / (kPatchSize)
+ end if
+ dailygrass_C = dailygrass_C + p%coh%ntreea*grass*cpart*kg_in_g / (kPatchSize)
+ dailynetass_C = dailynetass_C + p%coh%ntreea*netass*cpart*kg_in_g / (kPatchSize)
+ dailyrespfol_C = dailyrespfol_C + p%coh%ntreea*respfol*cpart*kg_in_g / (kPatchSize)
+ ENDIF
+
+if (dailyNPP .gt. 10000.) then
+ continue
+end if
+ ! update annual net assimilation and NPP sum
+ p%coh%netAss = p%coh%netAss + netAss * jx
+ p%coh%grossass = p%coh%grossass + grass * jx
+ if (flag_resp.eq.1)then
+ p%coh%maintres = p%coh%maintres + (maintresp + help) * jx
+ else
+ p%coh%maintres = p%coh%maintres + (maintresp + respfol) * jx
+ end if
+ p%coh%NPP = p%coh%NPP + dailyNPP * jx
+ p%coh%weekNPP = dailyNPP * jx
+ IF (time_out .gt. 0 .and. flag_cohout .eq. 2) THEN
+ CALL OUT_ASS( p%coh%ident, PAR, p%coh%NPP, p%coh%totFPAR, p%coh%LUE, p%coh%netAss, p%coh%grossass, p%coh%nDaysPS)
+ ENDIF
+
+! remove Mistletoe from N demand calculation
+ if (p%coh%species.ne.nspec_tree+2) then
+ p%coh%Ndemc_d=dailyNPP*1000.*spar(ns)%pcnr
+ end if
+ IF((flag_limi==4 .OR. flag_limi==5) .AND. 1. > p%coh%RedNc .AND. &
+ p%coh%N_fol/p%coh%t_leaf <= 4.5 .AND. p%coh%N_pool > 0.) THEN
+ IF(p%coh%N_pool > p%coh%N_fol*(1./p%coh%RedNc - 1.)) THEN
+ p%coh%N_fol = p%coh%N_fol / p%coh%RedNc
+ p%coh%N_pool = p%coh%N_pool - p%coh%N_fol*(1./p%coh%RedNc - 1.)
+ ELSE
+ p%coh%N_fol = p%coh%N_fol + p%coh%N_pool
+ p%coh%N_pool = 0.0
+ ENDIF
+ ENDIF
+ p => p%next
+ END DO
+END SUBROUTINE NPP
diff --git a/source_code/version2.2_windows/old_out.f b/source_code/version2.2_windows/old_out.f
new file mode 100755
index 0000000000000000000000000000000000000000..13ef689847e58f0acedaf7da67fa1bb3acee486e
--- /dev/null
+++ b/source_code/version2.2_windows/old_out.f
@@ -0,0 +1,447 @@
+!*****************************************************************!
+!* *!
+!* 4C (FORESEE) Simulation Model *!
+!* *!
+!* *!
+!* Subroutines for: *!
+!* - output routines - *!
+!* Specific files written from model subroutines *!
+!* *!
+!* contains *!
+!* OLD_OUT: Initialization of output files ("private") *!
+!* OUT_ASS: file output ("private") *!
+!* OUT_ALL: output for monitoring allocation *!
+!* OUTTEST: test of output flags *!
+!* OUTTEST_YEAR: test of output flags - yearly output *!
+!* OUTTEST_DAY: test of output flags - daily output *!
+!* OUTTEST_COH: test of output flags - cohort output *!
+!* *!
+!* Copyright (C) 1996-2018 *!
+!* Potsdam Institute for Climate Impact Reserach (PIK) *!
+!* Authors and contributors see AUTHOR file *!
+!* This file is part of 4C and is licensed under BSD-2-Clause *!
+!* See LICENSE file or under: *!
+!* http://www.https://opensource.org/licenses/BSD-2-Clause *!
+!* Contact: *!
+!* https://gitlab.pik-potsdam.de/foresee/4C *!
+!* *!
+!*****************************************************************!
+
+SUBROUTINE old_out
+
+ use data_out
+ use data_simul
+
+ implicit none
+
+ INTEGER help_ip
+ CHARACTER(100) ::filename
+
+IF(site_nr==1) THEN
+ help_ip=site_nr
+ELSE
+ help_ip=ip
+END IF
+
+! open output files & write column headers
+if (time_out .gt. 0) then
+ if (out_flag_light .ne. 0) then
+ unit_light=getunit()
+ filename = trim(site_name(help_ip))//'_light.res'//trim(anh)
+ OPEN (unit_light, file=trim(dirout)//filename, status = 'UNKNOWN')
+ WRITE (unit_light, '(A)') 'year coh totFAPR LAI '
+ endif
+
+ if (flag_cohout .eq. 2) then
+ unit_prod = getunit()
+ filename = trim(site_name(help_ip))//'_prod.res'//trim(anh)
+ OPEN (unit_prod, file=trim(dirout)// filename, status = 'UNKNOWN')
+ WRITE (unit_prod, '(A)') ' year day coh PAR totFPAR LUE NPP netAss grossAss nDaysPS'
+ unit_allo = getunit()
+ filename = trim(site_name(help_ip))//'_allo.res'//trim(anh)
+ OPEN (unit_allo, file=trim(dirout)//filename, status = 'UNKNOWN')
+ WRITE (unit_allo, '(A)') ' year coh ntree NPP dbh growthrate Fnew Fmax Htnew&
+ & lambdaf lambdas lambdar lambdac x1 x2'
+ endif
+endif
+
+ IF (flag_dayout .ge. 2) THEN
+ unit_wat = getunit()
+ filename = trim(site_name(help_ip))//'_water.res'//trim(anh)
+ OPEN (unit_wat, file=trim(dirout)//filename, status = 'UNKNOWN')
+ WRITE (unit_wat, '(A)') ' Year Iday Temp Prec Interc Int_st Int_s I_st_s Snow Snow_sm PET TRA_DEM&
+ & PEV AEV_s AEV_i Percol WAtot WEtot WUtot WUtot_e&
+ & WUtot_r Tratree Trasveg EVA_dem GP_can AET cep_can cep_sv'
+
+ unit_soicnd = getunit()
+ filename = trim(site_name(help_ip))//'_Nmin.res'//trim(anh)
+ OPEN (unit_soicnd, file=trim(dirout)//filename, status = 'UNKNOWN')
+ WRITE (unit_soicnd, '(A)') ' Year Iday N_min_1 N_min_2 N_min_3 N_min_4 N_min_5 N_min_6 ... '
+
+ unit_soicna = getunit()
+ filename = trim(site_name(help_ip))//'_remin.res'//trim(anh)
+ OPEN (unit_soicna, file=trim(dirout)// filename, status = 'UNKNOWN')
+ WRITE (unit_soicna, '(A)') ' Year Iday remin_1 remin_2 remin_3 remin_4 remin_5 remin_6'
+
+ unit_soicnr = getunit()
+ filename = trim(site_name(help_ip))//'_rmin.res'//trim(anh)
+ OPEN (unit_soicnr, file=trim(dirout)// filename, status = 'UNKNOWN')
+ WRITE (unit_soicnr, '(A)') ' Year Iday rmin_t rmin_w rmin_phv'
+
+ ENDIF
+
+END SUBROUTINE old_out
+
+!**************************************************************
+
+SUBROUTINE OUT_ASS(ident,PAR,NPP,totFPAR,LUE,netass,grossass,ndaysps)
+
+ USE data_simul
+ USE data_out
+
+ IMPLICIT NONE
+
+ REAL :: temp, dayL, PAR, netAss, grossass, maintResp, NPP, totFPAR, sapresp, coarseresp, frtresp, assi, resp, LUE, ndaysps
+ integer :: ident
+
+ WRITE(unit_prod, '(3I5,6E12.4,F6.1)') time_cur,iday,ident, PAR,totFPAR,LUE,NPP,netAss,grossass, ndaysps
+
+END SUBROUTINE OUT_ASS
+
+!**************************************************************
+
+SUBROUTINE OUT_ALL( ident, ntree, NPP, DBH, grate, Fnew,Fmax_old,Htnew, lf,ls,lr,lc,x1,x2 )
+
+ !*** Declaration part ***!
+
+ USE data_out
+ USE data_simul
+ USE data_stand
+
+ IMPLICIT NONE
+
+ INTEGER :: ident
+ REAL :: ntree, NPP, DBH, lf, ls, lr, lc, x1, x2, grate,Fnew,Fmax_old,Htnew
+
+ !*** Calculation part ***!
+
+ WRITE( unit_allo, '(2I5,F8.0,12F11.4)' ) time_cur, ident, ntree, NPP, DBH,grate,Fnew,Fmax_old,Htnew, lf,ls,lr,lc,x1,x2
+
+END SUBROUTINE out_all
+
+!**************************************************************
+
+SUBROUTINE outtest
+
+use data_out
+use data_simul
+
+implicit none
+
+integer hflag, j, i
+logical testflag
+character a
+
+call outtest_year
+call outtest_day
+call outtest_coh
+call outtest_end
+
+END subroutine outtest
+
+!**************************************************************
+
+SUBROUTINE outtest_year
+
+use data_out
+use data_simul
+
+implicit none
+
+integer i, j
+logical testflag
+character a
+
+IF (time_out > 0 ) then
+ if (nyvar .eq. 1) then
+ do i = 1,outy_n
+ SELECT CASE (outy(i)%kind_name)
+
+ CASE ('litter')
+ outy(i)%out_flag = 2
+
+ CASE ('soil')
+ outy(i)%out_flag = 2
+
+ CASE DEFAULT
+ outy(i)%out_flag = 1
+ end select
+ enddo
+ else
+ outy%out_flag = 0
+ do j = 1,nyvar-1
+ testflag = .TRUE.
+ do i = 1,outy_n
+ if (trim(outy_file(j)) .eq. trim(outy(i)%kind_name)) then
+ SELECT CASE (outy(i)%kind_name)
+ CASE ('litter')
+ outy(i)%out_flag = 2
+ CASE ('soil')
+ outy(i)%out_flag = 2
+ CASE DEFAULT
+ outy(i)%out_flag = 1
+ end select
+ testflag = .FALSE.
+ exit
+ endif
+ enddo
+ if (testflag .and. trim(outy_file(j)) .ne. 'end') then
+ print *
+ print *,' >>>FORESEE message: Invalid output file name: '//trim(outy_file(j))
+ print *
+ endif
+ enddo
+ endif ! nyvar
+
+ IF (year/time_out > 500) then
+ print *,' '
+ write(*,*)' Warning: Your choice of yearly output steps will create'
+ write(*,'(I8,A)') year/time_out, ' data records per file!'
+ write(*,'(A)',advance='no')' Do you really want to use this value (y/n)? '
+ read *,a
+ IF (a .eq. 'n' .or. a .eq. 'N') then
+ write(*,'(A)',advance='no')' New value of time distance for yearly output: '
+ read *, time_out
+ ENDIF
+ ENDIF
+ELSE
+ do i = 1,outy_n
+ outy(i)%out_flag = 0
+ enddo
+ENDIF ! time_out > 0
+
+END SUBROUTINE outtest_year
+
+!**************************************************************
+
+SUBROUTINE outtest_day
+
+use data_out
+use data_simul
+
+implicit none
+
+integer i, j
+logical testflag
+character a
+
+! daily output
+IF (flag_dayout > 0 ) then
+ if (ndvar .eq. 1) then
+ do i = 1,outd_n
+ outd(i)%out_flag = 1
+ enddo
+ else
+ outd%out_flag = 0
+ do j = 1,ndvar-1
+ testflag = .TRUE.
+ do i = 1,outd_n
+ if (trim(outd_file(j)) .eq. trim(outd(i)%kind_name)) then
+ outd(i)%out_flag = 1
+ testflag = .FALSE.
+ exit
+ endif
+ enddo
+ if (testflag .and. trim(outd_file(j)) .ne. 'end') then
+ print *
+ print *,' >>>FORESEE message: Invalid output file name: '//trim(outd_file(j))
+ print *
+ endif
+ enddo
+ endif ! ndvar
+else
+ do i = 1,outd_n
+ outd(i)%out_flag = 0
+ enddo
+endif
+
+END SUBROUTINE outtest_day
+
+!**************************************************************
+
+SUBROUTINE outtest_coh
+
+use data_out
+use data_simul
+
+implicit none
+
+integer i, j
+logical testflag
+
+! cohort output
+SELECT CASE (flag_cohout)
+CASE (0)
+ ! flags of all daily cohort files
+ do i = 1,outcd_n
+ outcd(i)%out_flag = 0
+ enddo
+
+ ! flags of all yearly cohort files
+ do i = 1,outcy_n
+ outcy(i)%out_flag = 0
+ enddo
+ flag_cohoutd = 0
+ flag_cohouty = 0
+
+CASE (1,2)
+ if (ncvar .eq. 1) then
+! yearly cohort output
+ if (time_out .gt. 0) then
+ do i = 1,outcy_n
+ select case (outcy(i)%kind_name)
+ case ('dtr')
+ outcy(i)%out_flag = 2
+ case ('trman')
+ outcy(i)%out_flag = 2
+ case default
+ outcy(i)%out_flag = 1
+ end select
+ enddo
+ flag_cohouty = 1
+ else
+ outcy%out_flag = 0
+ flag_cohouty = 0
+ endif
+
+! daily cohort output
+ if (flag_dayout .gt. 0) then
+ do i = 1,outcd_n
+ select case (outcd(i)%kind_name)
+ case ('dips')
+ outcd(i)%out_flag = 2
+ case ('gsdps')
+ outcd(i)%out_flag = 2
+ case default
+ outcd(i)%out_flag = 1
+ end select
+ enddo
+ else
+ outcd%out_flag = 0
+ endif
+ else
+ outcy%out_flag = 0
+ outcd%out_flag = 0
+ flag_cohoutd = 0
+ flag_cohouty = 0
+ do j = 1,ncvar-1
+ testflag = .TRUE.
+ do i = 1,outcy_n
+ if (trim(outc_file(j)) .eq. trim(outcy(i)%kind_name)) then
+ select case (outcy(i)%kind_name)
+ case ('dtr')
+ outcy(i)%out_flag = 2
+ case ('trman')
+ outcy(i)%out_flag = 2
+ case default
+ outcy(i)%out_flag = 1
+ end select
+ testflag = .FALSE.
+ flag_cohouty = 1
+ exit
+ endif
+ enddo
+ if (testflag .and. flag_dayout .gt. 0) then
+ do i = 1,outcd_n
+ if (trim(outc_file(j)) .eq. trim(outcd(i)%kind_name)) then
+ select case (outcd(i)%kind_name)
+ case ('dips')
+ outcd(i)%out_flag = 2
+ case ('gsdps')
+ outcd(i)%out_flag = 2
+ case default
+ outcd(i)%out_flag = 1
+ end select
+ testflag = .FALSE.
+ flag_cohouty = 1
+ exit
+ endif
+ enddo
+ endif
+ if (testflag .and. trim(outd_file(j)) .ne. 'end') then
+ print *
+ print *,' >>>FORESEE message: Invalid output file name: '//trim(outd_file(j))
+ print *
+ endif
+ enddo
+ endif ! ncvar
+END SELECT
+
+if (flag_cohout .eq. 2) then
+ out_flag_light = 1
+else
+ out_flag_light = 0
+endif
+
+END SUBROUTINE outtest_coh
+
+!**************************************************************
+
+SUBROUTINE outtest_end
+
+use data_out
+use data_simul
+
+implicit none
+
+integer i, j
+if (flag_wpm == 1 .or. flag_wpm == 21 .or. flag_wpm == 11.or.flag_wpm== 5.or. flag_wpm == 4 .or. flag_wpm == 6) then
+ do i = 1,oute_n
+ select case (oute(i)%kind_name)
+ case ('wpm')
+ oute(i)%out_flag = 1
+ case ('wpm_inter')
+ oute(i)%out_flag = 1
+ end select
+ enddo
+else if (flag_wpm == 2) then
+ do i = 1,oute_n
+ select case (oute(i)%kind_name)
+ case ('sea')
+ oute(i)%out_flag = 1
+ case ('sea_npv')
+ oute(i)%out_flag = 1
+ case ('sea_ms')
+ oute(i)%out_flag = 1
+ case ('sea_st')
+ oute(i)%out_flag = 1
+
+ end select
+ enddo
+else if(flag_wpm.eq.3) then
+ do i = 1,oute_n
+ select case (oute(i)%kind_name)
+ case ('sea')
+ oute(i)%out_flag = 1
+ case ('sea_npv')
+ oute(i)%out_flag = 1
+ case ('sea_ms')
+ oute(i)%out_flag = 1
+ case ('sea_st')
+ oute(i)%out_flag = 1
+ case ('wpm')
+ oute(i)%out_flag = 1
+ case ('wpm_inter')
+ oute(i)%out_flag = 1
+
+ end select
+ enddo
+
+else
+ do i = 1,oute_n
+ oute(i)%out_flag = 0
+ enddo
+endif
+
+
+END SUBROUTINE outtest_end
diff --git a/source_code/version2.2_windows/out_var_stat.f b/source_code/version2.2_windows/out_var_stat.f
new file mode 100755
index 0000000000000000000000000000000000000000..966fad9017957b4bd85e440c2114e8270877017b
--- /dev/null
+++ b/source_code/version2.2_windows/out_var_stat.f
@@ -0,0 +1,394 @@
+!*****************************************************************!
+!* *!
+!* 4C (FORESEE) Simulation Model *!
+!* *!
+!* *!
+!* Subroutines for: *!
+!* output of variables with statistics for climate scenarios *!
+!* *!
+!* contains *!
+!* OUT_VAR_STAT compressing of output variables *!
+!* CALC_STAT calculation of statistics *!
+!* Copyright (C) 1996-2018 *!
+!* Potsdam Institute for Climate Impact Reserach (PIK) *!
+!* Authors and contributors see AUTHOR file *!
+!* This file is part of 4C and is licensed under BSD-2-Clause *!
+!* See LICENSE file or under: *!
+!* http://www.https://opensource.org/licenses/BSD-2-Clause *!
+!* Contact: *!
+!* https://gitlab.pik-potsdam.de/foresee/4C *!
+!* *!
+!*****************************************************************!
+
+SUBROUTINE out_var_stat(kind, act_real)
+
+! compressing of output variables with statistics (multi run 9, 10)
+ use data_out
+ use data_par
+ use data_simul
+ use data_site
+
+ IMPLICIT NONE
+
+ integer kind ! 1 - aggregation per realisation (average)
+ ! 2 - aggregation per climate scenario over all realisations with statistics
+ ! 3 - statistics per month over all years
+ integer act_real ! number of actual realisation
+ integer i, j, k, unit_nr, ii
+ real varerr, help
+ character(50) :: filename ! complete name of output file
+ real, dimension(nrreal) :: helparr
+ real, dimension(year):: helpmon
+ character(30) :: helpvar
+ character(20) idtext, datei
+ character(150) htext
+
+! mit Numerical Recipies
+ REAL:: adev,ave,var, &
+ curt=-99. , &
+ sdev=-99. , &
+ skew=0.
+
+! Statistische Masszahlen fuer Klimaszen.-Realisierungen
+real:: avcl, & ! Mittelwert
+ mincl, & ! Minimum
+ maxcl, & ! Maximum
+ median, & ! Median
+ stdevcl=-99. , & ! Standardabweichung
+ varicl, & ! Streuung
+ varcocl ! Variationskoeffizient
+real quant05, quant95 ! 0.05 and 0.95 quantile
+real, external :: mean, variance
+
+if (flag_trace) write (unit_trace, '(I4,I10,A,2I5)') iday, time_cur, ' out_var_stat ',kind,act_real
+
+select case (kind)
+case (1,2)
+ if (output_unit_all .le.0) then
+ filename = trim(site_name1)//'_var_all.out'
+ output_unit_all = getunit()
+ open(output_unit_all,file=trim(dirout)//filename,status='replace')
+ write (output_unit_all, '(A)') '# Output of mean annual values for each site and each realization of climate scenarios'
+ write (output_unit_all, '(A, I6)') '# Simulation period (years): ', year
+ write (output_unit_all, '(A, I6)') '# Number of climate scenarios: ', nrclim
+ write (output_unit_all, '(A, I6)') '# Number of realizations: ', nrreal
+ write (output_unit_all, *)
+ write (output_unit_all, '(A)', advance='no') '# Type_clim.scen. Site_ip Real.'
+
+ do i = 1, nvar-1
+ select case (trim(outvar(i)))
+ case ('AET_year','cwb_year','GPP_year','NEP_year','NPP_year','perc_year','PET_year','temp_year','TER_year','prec_year','resps_year')
+ continue
+
+ case ('AET_mon','cwb_mon','GPP_mon','NEP_mon','NPP_mon','perc_mon','PET_mon','temp_mon','TER_mon','prec_mon','resps_mon')
+ continue
+
+ case ('AET_week','cwb_week','GPP_week','NEP_week','NPP_week','perc_week','PET_week','temp_week','TER_week','prec_week','resps_week')
+ continue
+
+ case default
+ write (output_unit_all, '(A12)', advance='no') trim(outvar(i))
+
+ end select
+ enddo
+
+ write (output_unit_all, '(A)') ''
+ endif
+
+case (3)
+ do i = 1, nvar-1
+ if (output_unit_mon(i) .le.0) then ! for monthly values
+ filename = trim(site_name1)//'_'//trim(outvar(i))//'_stat.res'
+ output_unit_mon(i) = getunit()
+ open(output_unit_mon(i),file=trim(dirout)//filename,status='replace')
+ write (output_unit_mon(i), '(A)') '# Output of mean monthly values for '//trim(outvar(i))
+ write (output_unit_mon(i), '(A, I6)') '# Simulation period (years): ', year
+ varerr = 0
+ endif
+ enddo
+end select
+
+select case (kind)
+
+case (1) ! after each realisation
+ write (output_unit_all, '(2X, A15, 1X, A10, I5,2X)', advance = 'no') trim(typeclim(iclim)), sitenum(ip), act_real
+ do i = 1, nvar-1
+ select case (trim(outvar(i)))
+
+ case ('AET_year','cwb_year','GPP_year','NEP_year','NPP_year','perc_year','PET_year','temp_year','TER_year','prec_year','resps_year')
+ ii = output_var(i,1,0)
+ do j = 1, year
+ climszenyear(ii,ip,iclim,act_real,j) = output_var(i,1,j)
+ enddo
+
+ case ('AET_mon','cwb_mon','GPP_mon','NEP_mon','NPP_mon','perc_mon','PET_mon','temp_mon','TER_mon','prec_mon','resps_mon')
+ ii = output_var(i,1,0)
+ do k = 1,12
+ help = 0.
+ do j = 1, year
+ help = help + output_varm(ii,1,j,k)
+ enddo
+ help = help / year
+ climszenmon(ii,ip,iclim,act_real,k) = help
+ enddo
+
+ case ('AET_week','cwb_week','GPP_week','NEP_week','NPP_week','perc_week','PET_week','temp_week','TER_week','prec_week','resps_week')
+ ii = output_var(i,1,0)
+ do k = 1,52
+ help = 0.
+ do j = 1, year
+ help = help + output_varw(ii,1,j,k)
+ enddo
+ help = help / year
+ climszenweek(ii,ip,iclim,act_real,k) = help
+ enddo
+
+ case default
+ help = 0.
+ do j = 1, year
+ help = help + output_var(i,1,j)
+ enddo ! j
+ help = help / year
+ climszenres(i,ip,iclim,act_real) = help
+ write (output_unit_all, '(E12.4)', advance = 'no') help
+ end select ! outvar
+ end do ! i
+ write (output_unit_all, '(A)') ''
+
+case (2) ! am Ende der Simulation
+ do i = 1, nvar-1
+
+ if (output_unit(i) .lt. 0) then
+ helpvar = outvar(i)
+ call out_var_select(helpvar, varerr, unit_nr)
+ if (varerr .ne. 0.) then
+ output_unit(i) = unit_nr
+ write (unit_nr, '(A, I6)') '# Simulation period (years): ', year
+ write (unit_nr, '(A, I6)') '# Number of climate scenarios: ', nrclim
+ write (unit_nr, '(A, I6)') '# Number of realizations: ', nrreal
+
+ select case (trim(outvar(i)))
+ case ('AET_year','cwb_year','GPP_year','NEP_year','NPP_year','perc_year','PET_year','temp_year','TER_year','prec_year','resps_year')
+ write (unit_nr, '(A)') '# Statistics over all realizations for each year '
+ write (unit_nr, '(A)') '# Type_clim.scen. Site_ip Year Mean Minimum Maximum Variance Var.Coeff. Std.Dev. Skewness Excess 0.05-Quant. 0.95-Quant. Median'
+
+ case ('AET_mon','cwb_mon','GPP_mon','NEP_mon','NPP_mon','perc_mon','PET_mon','temp_mon','TER_mon','prec_mon','resps_mon')
+ write (unit_nr, '(A)') '# Statistics over all realizations and all years for each month '
+ write (unit_nr, '(A)') '# Type_clim.scen. Site_ip Month Mean Minimum Maximum Variance Var.Coeff. Std.Dev. Skewness Excess 0.05-Quant. 0.95-Quant. Median'
+
+ case ('AET_week','cwb_week','GPP_week','NEP_week','NPP_week','perc_week','PET_week','temp_week','TER_week','prec_week','resps_week')
+ write (unit_nr, '(A)') '# Statistics over all realizations and all years for each week '
+ write (unit_nr, '(A)') '# Type_clim.scen. Site_ip Week Mean Minimum Maximum Variance Var.Coeff. Std.Dev. Skewness Excess 0.05-Quant. 0.95-Quant. Median'
+
+ case default
+ write (unit_nr, '(A)') '# Statistics over all realizations (mean of all years) '
+ write (unit_nr, '(A)') '# Type_clim.scen. Site_ip Mean Minimum Maximum Variance Var.Coeff. Std.Dev. Skewness Excess 0.05-Quant. 0.95-Quant. Median'
+ end select
+ else
+ write (*,*)
+ write (*,*) '*** 4C-error - output of variables (out_var_file): ', trim(outvar(i)), ' not found'
+ write (*,*)
+ write (unit_err,*)
+ write (unit_err,*) '*** 4C-error - no such output variable (out_var_file): ', trim(outvar(i))
+ endif
+ endif
+
+ if (output_unit(i) .ge. 0) then
+ select case (trim(outvar(i)))
+ case ('AET_year','cwb_year','GPP_year','NEP_year','NPP_year','perc_year','PET_year','temp_year','TER_year','prec_year','resps_year')
+ ii = output_var(i,1,0)
+ do k = 1, year
+ write (output_unit(i), '(2X, A15, 1X, A10, I7)', advance = 'no') trim(typeclim(iclim)), sitenum(ip), k
+ do j = 1, nrreal
+ helparr(j) = climszenyear(ii,ip,iclim,j,k)
+ enddo
+ call calc_stat(nrreal, helparr, output_unit(i))
+ enddo
+
+ case ('AET_mon','cwb_mon','GPP_mon','NEP_mon','NPP_mon','perc_mon','PET_mon','temp_mon','TER_mon','prec_mon','resps_mon')
+ ii = output_var(i,1,0)
+ do k = 1, 12
+ write (output_unit(i), '(2X, A15, 1X, A10, I7)', advance = 'no') trim(typeclim(iclim)), sitenum(ip), k
+ do j = 1, nrreal
+ helparr(j) = climszenmon(ii,ip,iclim,j,k)
+ enddo
+ call calc_stat(nrreal, helparr, output_unit(i))
+ enddo
+
+ case ('AET_week','cwb_week','GPP_week','NEP_week','NPP_week','perc_week','PET_week','temp_week','TER_week','prec_week','resps_week')
+ ii = output_var(i,1,0)
+ do k = 1, 52
+ write (output_unit(i), '(2X, A15, 1X, A10, I7)', advance = 'no') trim(typeclim(iclim)), sitenum(ip), k
+ do j = 1, nrreal
+ helparr(j) = climszenweek(ii,ip,iclim,j,k)
+ enddo
+ call calc_stat(nrreal, helparr, output_unit(i))
+ enddo
+
+ case default
+ write (output_unit(i), '(2X, A15, 1X, A10)', advance = 'no') trim(typeclim(iclim)), sitenum(ip)
+ do j = 1, nrreal
+ helparr(j) = climszenres(i,ip,iclim,j)
+ enddo
+
+ call calc_stat(nrreal, helparr, output_unit(i))
+ end select
+ endif
+ enddo
+
+case (3) ! Monthly values
+ do i = 1, nvar-1
+ helpvar = outvar(i)
+ select case (trim(outvar(i)))
+
+ case ('AET_year','cwb_year','GPP_year','NEP_year','NPP_year','perc_year','PET_year','temp_year','TER_year','prec_year','resps_year')
+ ii = output_var(i,1,0)
+ do j = 1, year
+ climszenyear(ii,ip,iclim,act_real,j) = output_var(i,1,j)
+ enddo
+
+ case ('GPP_mon','NPP_mon','TER_mon')
+ ii = output_var(i,1,0)
+ if (ip .eq.1) then
+ write (output_unit_mon(i), '(A)') '# Statistics over all years for each month '
+ write (output_unit_mon(i), '(A)') '# g C/m² '
+ write (output_unit_mon(i), '(A)') '# ipnr site_id Month Mean Minimum Maximum Variance Var.Coeff. Std.Dev. Skewness Excess 0.05-Quant. 0.95-Quant. Median'
+ endif
+ do k = 1,12
+ help = 0.
+ do j = 1, year
+ helpmon(j) = output_varm(ii,1,j,k) * 100. ! tC/ha --> gC/m²
+ enddo
+ htext = adjustr(site_name(ip))
+ idtext = adjustl(htext (131:150)) ! only write last 20 signs
+ write (output_unit_mon(i), '(I5,2X, A20,I5)', advance = 'no') ip, idtext, k
+ call calc_stat(year, helpmon, output_unit_mon(i))
+ enddo
+
+ case ('NEE_mon')
+ ii = output_var(i,1,0)
+ if (ip .eq.1) then
+ write (output_unit_mon(i), '(A)') '# Statistics over all years for each month '
+ write (output_unit_mon(i), '(A)') '# g C/m² '
+ write (output_unit_mon(i), '(A)') '# ipnr site_id Month Mean Minimum Maximum Variance Var.Coeff. Std.Dev. Skewness Excess 0.05-Quant. 0.95-Quant. Median'
+ endif
+ do k = 1,12
+ help = 0.
+ do j = 1, year
+ helpmon(j) = output_varm(ii,1,j,k) ! gC/m²
+ enddo
+ htext = adjustr(site_name(ip))
+ idtext = adjustl(htext (131:150)) ! only write last 20 signs
+ write (output_unit_mon(i), '(I5,2X, A20,I5)', advance = 'no') ip, idtext, k
+ call calc_stat(year, helpmon, output_unit_mon(i))
+ enddo
+
+ case ('resps_mon')
+ ii = output_var(i,1,0)
+ if (ip .eq.1) then
+ write (output_unit_mon(i), '(A)') '# Statistics over all years for each month '
+ write (output_unit_mon(i), '(A)') '# g C/m² '
+ write (output_unit_mon(i), '(A)') '# ipnr site_id Month Mean Minimum Maximum Variance Var.Coeff. Std.Dev. Skewness Excess 0.05-Quant. 0.95-Quant. Median'
+ endif
+ do k = 1,12
+ help = 0.
+ do j = 1, year
+ helpmon(j) = output_varm(ii,1,j,k) * kgha_in_gm2 ! kgC/ha --> gC/m²
+ enddo
+ htext = adjustr(site_name(ip))
+ idtext = adjustl(htext (131:150)) ! only write last 20 signs
+ write (output_unit_mon(i), '(I5,2X, A20,I5)', advance = 'no') ip, idtext, k
+ call calc_stat(year, helpmon, output_unit_mon(i))
+ enddo
+
+ case ('AET_mon','cwb_mon','perc_mon','PET_mon','temp_mon','prec_mon')
+ ii = output_var(i,1,0)
+ if (ip .eq.1) then
+ write (output_unit_mon(i), '(A)') '# Statistics over all years for each month '
+ write (output_unit_mon(i), '(A)') '# '
+ write (output_unit_mon(i), '(A)') '# ipnr site_id Month Mean Minimum Maximum Variance Var.Coeff. Std.Dev. Skewness Excess 0.05-Quant. 0.95-Quant. Median'
+ endif
+ do k = 1,12
+ help = 0.
+ do j = 1, year
+ helpmon(j) = output_varm(ii,1,j,k)
+ enddo
+ htext = adjustr(site_name(ip))
+ idtext = adjustl(htext (131:150)) ! only write last 20 signs
+ write (output_unit_mon(i), '(I5,2X, A20,I5)', advance = 'no') ip, idtext, k
+ call calc_stat(year, helpmon, output_unit_mon(i))
+ enddo
+
+ case ('AET_week','cwb_week','GPP_week','NEP_week','NPP_week','perc_week','PET_week','temp_week','TER_week','prec_week','resps_week')
+ ii = output_var(i,1,0)
+ do k = 1,52
+ help = 0.
+ do j = 1, year
+ help = help + output_varw(ii,1,j,k)
+ enddo
+ help = help / year
+ climszenweek(ii,ip,iclim,act_real,k) = help
+ enddo
+
+ case default
+ help = 0.
+ do j = 1, year
+ help = help + output_var(i,1,j)
+ enddo ! j
+ help = help / year
+ climszenres(i,ip,iclim,act_real) = help
+ write (output_unit_all, '(E12.4)', advance = 'no') help
+ end select ! outvar
+ end do ! i
+ write (output_unit_all, '(A)') ''
+end select
+END SUBROUTINE out_var_stat
+
+!**************************************************************
+
+SUBROUTINE calc_stat(nreal, helparr, outunit)
+
+! calculate statistics
+ use data_out
+ use data_simul
+
+ IMPLICIT NONE
+
+integer :: outunit ! output unit
+integer :: nreal ! number of elements
+real, dimension(nreal) :: helparr ! input-array with dimension nreal
+
+! with numerical recipies
+ REAL:: adev,ave,var, &
+ curt=-99. , &
+ sdev=-99. , &
+ skew=0.
+
+! statistical measurment figures for climate scenario realisation
+real:: avcl, & ! mean
+ mincl, & ! minimum
+ maxcl, & ! maximum
+ median, & ! median
+ stdevcl=-99. , & ! standard deviation
+ varicl, & ! dispersion
+ varcocl ! coefficient of variance
+real quant05, quant95 ! 0.05 and 0.95 quantile
+real, external :: mean, variance
+
+ avcl = mean(nreal, helparr)
+ mincl = minval(helparr)
+ maxcl = maxval(helparr)
+ varicl = variance(nreal, avcl, helparr)
+ if (varicl .ge. 0.) stdevcl = sqrt(varicl)
+ if (avcl .ne. 0.) then
+ varcocl = stdevcl / avcl
+ else
+ varcocl = -9999.0
+ endif
+ call quantile(nreal, helparr, quant05, quant95, median)
+
+! with numerical recipies
+ if (nreal .gt. 1) call moment(helparr, nreal, ave,adev,sdev,var,skew,curt)
+ write (outunit, '(11E12.4)') avcl, mincl, maxcl, varicl, varcocl, sdev, skew, curt, quant05, quant95, median
+
+END SUBROUTINE calc_stat
diff --git a/source_code/version2.2_windows/output.f b/source_code/version2.2_windows/output.f
new file mode 100755
index 0000000000000000000000000000000000000000..f280e67b8746faa4f137f3c1f9c5bf5b51e23391
--- /dev/null
+++ b/source_code/version2.2_windows/output.f
@@ -0,0 +1,3400 @@
+!*****************************************************************!
+!* *!
+!* 4C (FORESEE) Simulation Model *!
+!* *!
+!* *!
+!* Subroutines for: *!
+!* - output routines - initialization and writing in files *!
+!* *!
+!* contains *!
+!* PREP_OUT initialization of output files *!
+!* PREP_OUTYEAR prepare yearly output files *!
+!* PREP_COH prepare output of cohorts *!
+!* PREP_OUT_COMP prepare compressed output *!
+!* OUTYEAR yearly output in files *!
+!* OUTDAY daily output in files *!
+!* COH_OUT_D daily cohort output *!
+!* COH_OUT_Y yearly cohort output *!
+!* OUT_COMP compressed output (multi run) *!
+!* OUT_WPM ouput for WPM after the simulation is ended *!
+!* OUT_SCEN climate scenario control file (multi run) *!
+!* ERROR_MESS print error message in error file "error.log"*!
+!* STOP_MESS print message on program abortion *!
+!* OPEN_FILE open special output file *!
+!* WR_HEADER_FILE write header of special output file *!
+!* OUTVEG output of species values (files veg_species) *!
+!* OUTSTORE store of output variables (multi run 4) *!
+!* OUT_VAR_FILE store of output variables (multi run 4) *!
+!* *!
+!* Copyright (C) 1996-2018 *!
+!* Potsdam Institute for Climate Impact Reserach (PIK) *!
+!* Authors and contributors see AUTHOR file *!
+!* This file is part of 4C and is licensed under BSD-2-Clause *!
+!* See LICENSE file or under: *!
+!* http://www.https://opensource.org/licenses/BSD-2-Clause *!
+!* Contact: *!
+!* https://gitlab.pik-potsdam.de/foresee/4C *!
+!* *!
+!*****************************************************************!
+
+SUBROUTINE prep_out
+
+! Open output files
+USE data_simul
+USE data_species
+USE data_stand
+USE data_out
+
+IMPLICIT NONE
+
+CHARACTER(50) ::filename
+INTEGER i,help_ip
+INTEGER unit_n ! output unit
+
+IF(site_nr==1) THEN
+ help_ip=site_nr
+ELSE
+ help_ip=ip
+END IF
+
+! 1. yearly output
+! open all selected files
+if (time_out .gt. 0) then
+ call prep_outyear (help_ip)
+endif
+
+call old_out !behelfs, privatoutput
+
+! 2. daily output
+! open all selected files
+if (flag_dayout .ge. 1) then
+ do i = 1,outd_n
+ if (outd(i)%out_flag .ne. 0) then
+ select CASE (outd(i)%kind_name)
+ CASE ('Cbcd')
+ if (flag_bc .gt. 0) then
+ call open_file (outd(i), help_ip)
+ call wr_header_file (outd(i))
+ endif
+
+ CASE default
+ call open_file (outd(i), help_ip)
+ call wr_header_file (outd(i))
+
+ end select
+ endif
+ END DO !i
+END IF
+
+! 3.Cohort output
+if(flag_cohout==1.or.flag_cohout==2) call prep_coh
+
+! 4. end output
+! open all selected files
+if (flag_wpm .gt. 0) then
+ do i = 1,oute_n
+ if (oute(i)%out_flag .ne. 0) then
+ select CASE (oute(i)%kind_name)
+
+ CASE default
+ call open_file (oute(i), help_ip)
+ call wr_header_file (oute(i))
+
+ end select
+ endif
+ END DO !i
+END IF
+
+! 5.summation output
+if(flag_sum>0)then
+ unit_sum=getunit()
+ filename = trim(site_name(help_ip))//'_sum.out'//trim(anh)
+ open(unit_sum,file=trim(dirout)//filename,status='replace')
+ WRITE(unit_sum,'(A)') '# Photsum = Sum of gross photosynthesis gC/m2'
+ WRITE(unit_sum,'(A)') '# NPPpotsum = Sum of potential NPP gC/m2'
+ WRITE(unit_sum,'(A)') '# NPPsum = Sum of NPP gC/m2'
+ WRITE(unit_sum,'(A)') '# respsoil = Sum of soil respiration gC/m2'
+ WRITE(unit_sum,'(A)') '# lightsum = Sum of global radiation MJ/m2'
+ WRITE(unit_sum,'(A)') '# NEE = Sum of respsoil - daily NPP gC/m2'
+ WRITE(unit_sum,'(A)') '# ALS = Sum of absorbed global radiation MJ/m2'
+ WRITE(unit_sum,'(A)') '# Psum = Sum of precipitation (mm)'
+ WRITE(unit_sum,'(A)') '# Tmean = mean temperature (°C)'
+ WRITE(unit_sum,'(A)') '# GPP = GPP gC/m2'
+ WRITE(unit_sum,'(A)') '# TER = Total ecosystem respiration gC/m2'
+ WRITE(unit_sum,'(A)') '# respaut = Autotrophe respiration gC/m2'
+
+ select CASE(flag_sum)
+ CASE(1)
+ WRITE(unit_sum,'(A11)') '# Daily sum'
+ WRITE(unit_sum,'(2A5,13A10)') '# Day','Year','Photsum','NPPpotsum','NPPsum', &
+ 'respsoil','lightsum','NEE', 'ALS', 'Psum',&
+ 'Tmean','cor_res', 'GPP','TER','respaut'
+ CASE(2)
+ WRITE(unit_sum,'(A50)') '# AET = Sum of actual evapotranspiration (mm)'
+ WRITE(unit_sum,'(A50)') '# PET = Sum of potential evapotranspiration (mm)'
+ WRITE(unit_sum,'(A50)') '# Percol. = Sum of percolation water from last layer (mm)'
+ WRITE(unit_sum,'(A12)') '# Weekly sum'
+ WRITE(unit_sum,'(2A6,17A10)') '# Week','Year','timedec','Photsum','NPPpotsum','NPPsum', &
+ 'respsoil','lightsum','NEE','ALS', 'Psum','Tmean', &
+ 'cor_res', 'AET', 'PET', 'Percol.', 'GPP','TER','respaut'
+ CASE(3)
+ WRITE(unit_sum,'(A50)') '# AET = Sum of actual evapotranspiration (mm)'
+ WRITE(unit_sum,'(A50)') '# PET = Sum of potential evapotranspiration (mm)'
+ WRITE(unit_sum,'(A50)') '# Ind_cout = monthly climate index according Coutange'
+ WRITE(unit_sum,'(A50)') '# Ind_wiss = monthly climate index according v. Wissmann'
+ WRITE(unit_sum,'(A50)') '# Ind_arid = monthly aridity index according UNEP'
+ WRITE(unit_sum,'(A50)') '# CWB = monthly climate water balance (P-PET)'
+ WRITE(unit_sum,'(A50)') '# Percol. = Sum of percolation water from last layer (mm)'
+ WRITE(unit_sum,'(A13)') '# Monthly sum'
+ WRITE(unit_sum,'(A7,A5,20A10)') '# Month','Year','timedec','Photsum','NPPpotsum','NPPsum', &
+ 'respsoil','lightsum','NEE','ALS', 'Psum', 'Tmean', 'AET', 'PET', 'Ind_cout', &
+ 'Ind_wiss', 'Ind_arid', 'CWB', 'Percol.', 'GPP','TER','respaut'
+ CASE(4)
+ WRITE(unit_sum,'(12A)') '# Yearly sum'
+ WRITE(unit_sum,'(A6,A10,11A11)') '# Year','Photsum','NPPpotsum','NPPsum', &
+ 'respsoil','lightsum','NEE','ALS', 'Psum', 'Tmean', 'GPP','TER','respaut'
+ end select
+END IF
+
+END subroutine prep_out
+
+!**************************************************************
+
+SUBROUTINE prep_outyear (help_ip)
+
+! Open yearly output files
+USE data_simul
+USE data_stand
+USE data_out
+USE data_species
+
+IMPLICIT NONE
+
+CHARACTER(10) :: helpunit
+CHARACTER(2) :: helpvar
+INTEGER i,j,help_ip,k
+INTEGER unit_n ! output unit
+
+do i = 1,outy_n
+ if (outy(i)%out_flag .ge. 1) then
+ select CASE (outy(i)%kind_name)
+
+ CASE ('AET_mon')
+ if (ip .eq. 1) then
+ nvar = nvar + 1
+ outvar(nvar) = "AET_mon"
+ endif
+ call open_file (outy(i), help_ip)
+ call wr_header_file (outy(i))
+
+ CASE ('Cbc', 'Nbc')
+ if (flag_bc .gt. 0) then
+ call open_file (outy(i), help_ip)
+ call wr_header_file (outy(i))
+ endif
+
+ CASE ('classd', 'classt') !open classification file
+ call open_file (outy(i), help_ip)
+ unit_n = outy(i)%unit_nr
+ WRITE(unit_n ,'(A)') trim(outy(i)%s_line)
+ WRITE(unit_n ,'(A)',advance='no') trim(outy(i)%header)
+ do k=1,nspecies
+ do j=1,num_class
+ WRITE(unit_n,'(A8,I2)',advance='no')'Class',j
+ END DO !j
+ end do !k
+ WRITE(unit_n,*) ' '
+
+ CASE ('classage') !open classification file
+ call open_file (outy(i), help_ip)
+ unit_n = outy(i)%unit_nr
+ WRITE(unit_n ,'(A)') trim(outy(i)%s_line)
+ WRITE(unit_n ,'(A)',advance='no') trim(outy(i)%header)
+ do k=1,nspecies
+ do j=1,num_class
+ WRITE(unit_n,'(A8,I2)',advance='no')'Class',j
+ END DO !j
+ end do !k
+ WRITE(unit_n,*) ' '
+
+ CASE ('classmvol') !open classification file
+ call open_file (outy(i), help_ip)
+ unit_n = outy(i)%unit_nr
+ WRITE(unit_n ,'(A)') trim(outy(i)%s_line)
+ WRITE(unit_n ,'(A)',advance='no') trim(outy(i)%header)
+ do k=1,nspecies
+ do j=1,num_class
+ WRITE(unit_n,'(A8,I2)',advance='no')'Class',j
+ END DO !j
+ end do !k
+ WRITE(unit_n,*) ' '
+
+ CASE ('classd_h') !open classification file
+ call open_file (outy(i), help_ip)
+ unit_n = outy(i)%unit_nr
+ WRITE(unit_n ,'(A)') trim(outy(i)%s_line)
+ WRITE(unit_n ,'(A)',advance='no') trim(outy(i)%header)
+ do k=1,nspecies
+ do j=1,num_class
+ WRITE(unit_n,'(A8,I2)',advance='no')'Class',j
+ END DO !j
+ end do
+ WRITE(unit_n,*) ' '
+
+ CASE ('classdm') !open classification file
+ call open_file (outy(i), help_ip)
+ unit_n = outy(i)%unit_nr
+ WRITE(unit_n ,'(A)') trim(outy(i)%s_line)
+ WRITE(unit_n ,'(A)',advance='no') trim(outy(i)%header)
+ do k=1,nspecies
+ do j=1,num_class
+ WRITE(unit_n,'(A8,I2)',advance='no')'Class',j
+ END DO !j
+ end do
+ WRITE(unit_n,*) ' '
+
+ CASE ('classdm_h') ! open classification file
+ call open_file (outy(i), help_ip)
+ unit_n = outy(i)%unit_nr
+ WRITE(unit_n ,'(A)') trim(outy(i)%s_line)
+ WRITE(unit_n ,'(A)',advance='no') trim(outy(i)%header)
+ do k=1,nspecies
+ do j=1,num_class
+ WRITE(unit_n,'(A8,I2)',advance='no')'Class',j
+ END DO !j
+ end do
+ WRITE(unit_n,*) ' '
+
+ CASE ('classh') !open classification file
+ call open_file (outy(i), help_ip)
+ unit_n = outy(i)%unit_nr
+ WRITE(unit_n ,'(A)') trim(outy(i)%s_line)
+ WRITE(unit_n ,'(A)',advance='no') trim(outy(i)%header)
+ do j=1,num_class
+ WRITE(unit_n,'(A8,I2)',advance='no')'Class',j
+ END DO !j
+ WRITE(unit_n,*) ' '
+
+ CASE ('GPP_mon')
+ if (ip .eq. 1) then
+ nvar = nvar + 1
+ outvar(nvar) = "GPP_mon"
+ endif
+ call open_file (outy(i), help_ip)
+ call wr_header_file (outy(i))
+
+ CASE ('NEE_mon')
+ if (ip .eq. 1) then
+ nvar = nvar + 1
+ outvar(nvar) = "NEE_mon"
+ endif
+ call open_file (outy(i), help_ip)
+ call wr_header_file (outy(i))
+
+ CASE ('NPP_mon')
+ if (ip .eq. 1) then
+ nvar = nvar + 1
+ outvar(nvar) = "NPP_mon"
+ endif
+ call open_file (outy(i), help_ip)
+ call wr_header_file (outy(i))
+
+ CASE ('spec') !open species file
+ call open_file (outy(i), help_ip)
+ unit_n = outy(i)%unit_nr
+
+ ! header
+ WRITE(unit_n ,'(A)',advance='no') trim(outy(i)%header)
+ do j=1,nspecies
+ zeig=>pt%first
+ do while (associated(zeig))
+ if(zeig%coh%species.eq.j)then
+ WRITE(helpunit,'(I2)') zeig%coh%species
+ read(helpunit,*) helpvar
+ WRITE(unit_n,'(A10)',advance='no') 'Diam_S'//helpvar
+ WRITE(unit_n,'(A10)',advance='no') 'Heig_S'//helpvar
+ WRITE(unit_n,'(2A10)',advance='no') 'Tree_S'//helpvar,'Biom_S'//helpvar
+ exit
+ END IF
+ zeig=>zeig%next
+ END DO
+ END DO
+ WRITE(unit_n,*) ' '
+
+ CASE ('TER_mon')
+ if (ip .eq. 1) then
+ nvar = nvar + 1
+ outvar(nvar) = "TER_mon"
+ endif
+ call open_file (outy(i), help_ip)
+ call wr_header_file (outy(i))
+
+ CASE default
+ call open_file (outy(i), help_ip)
+ call wr_header_file (outy(i))
+
+ end select
+ END IF
+END DO !i
+
+if (nvar .gt. 0) then
+ if (.not. allocated(output_unit_mon)) then
+ allocate(output_unit_mon(nvar))
+ if (.not. allocated(output_var)) allocate(output_var(nvar,1,0:0))
+ if (.not. allocated(output_varm)) allocate(output_varm(nvar,site_nr,year,12))
+ do i=1,nvar
+ output_var(i,1,0) = i
+ enddo
+ nvar = nvar + 1
+ endif
+endif
+
+END subroutine prep_outyear
+
+!**************************************************************
+
+SUBROUTINE prep_coh
+
+!prepare cohort output
+USE data_simul
+USE data_stand
+USE data_out
+
+IMPLICIT NONE
+
+INTEGER help_ip
+INTEGER i
+INTEGER unit_n ! output unit
+
+IF(site_nr==1) THEN
+ help_ip=site_nr
+ELSE
+ help_ip=ip
+END IF
+
+ ! output of all selected daily cohort files
+ do i = 1,outcd_n
+ if (outcd(i)%out_flag .ne. 0) then
+ unit_n = outcd(i)%unit_nr
+
+ select CASE (outcd(i)%kind_name)
+
+ CASE default
+ call open_file (outcd(i), help_ip)
+ call wr_header_file (outcd(i))
+
+ end select
+
+ END IF
+ END DO !i
+
+!prepare yearly cohort output
+! output of all selected yearly files
+do i = 1,outcy_n
+ if (outcy(i)%out_flag .ne. 0) then
+ unit_n = outcy(i)%unit_nr
+
+ select CASE (outcy(i)%kind_name)
+
+ CASE default
+ call open_file (outcy(i), help_ip)
+ call wr_header_file (outcy(i))
+
+ end select
+ END IF
+END DO !i
+END subroutine prep_coh
+
+!**************************************************************
+
+SUBROUTINE prep_out_comp
+
+! preparation: compressed output of final results for each run
+USE data_simul
+USE data_soil
+USE data_stand
+USE data_out
+
+IMPLICIT NONE
+
+character(70) filename
+
+ filename = trim(site_name(1))//'_B'//'.cmp'
+ unit_comp1 = getunit()
+ open(unit_comp1, file=trim(dirout)//filename, status='replace')
+ write (unit_comp1, '(A)') '# Compressed output of start values for each run'
+ write (unit_comp1, 1000)
+ write (unit_comp1, 2000)
+
+ filename = trim(site_name(1))//'_E'//'.cmp'
+ unit_comp2 = getunit()
+ open(unit_comp2, file=trim(dirout)//filename, status='replace')
+ write (unit_comp2, '(A)') '# Compressed output of final results for each run'
+ write (unit_comp2, '(A, I5)') '# Simulation time (years)', year
+ write (unit_comp2, 500)
+ write (unit_comp2, 1000)
+ write (unit_comp2, 2000)
+
+500 FORMAT ('# ||-------------------------------------------- final state -------------------------------------------||--- mean annual values ---||--- cumulative quantities ---||------------------- final state ',&
+ '-------------------||----------------------------------------------------------------------------- mean annual values ---------------------------------------------------------------------------------------------------------------', &
+ '-------------------------------------------------------------------------------------------------------------------------------|')
+1000 FORMAT ('# m2_m2 /ha t DW/ha t DW/ha cm cm t DW/ha t DW/ha t DW/ha t DW/ha t DW/ha t DW/ha t C/ha kg C/ha kg C/ha kg DW/ha kg DW/ha kg DW/ha t C/ha t C/ha t C/ha t C/ha',&
+ ' t C/ha t C/ha kg C/ha kg C/ha kg N/ha kg N/ha kg N/ha kg C/ha kg C/ha mm mm mm mm mm °C mm kg N/ha', 189X,' J_cm2 mm kg N/ha')
+2000 FORMAT ('# ipnr site_id LAI nTree typ Biomass Biom._sv Meddiam Domhei totfol tottb totsap tothrt totfrt totcrt mean_NPP mean_NEP mean_GPP c_Stem_inc cumVs_ab cumVs_dead C_sum C_d_stm C_tot C_hum_tot',&
+ ' C_tot_40 C_hum_40 C_accu C_litter N_litter N_min Nleach Soil_Res Tot_Resp PET AET percol interc transp temp prec N_depo drIndAl GDD cwb_an fire_inde fire_indb I_arid I_lang I_cout ', &
+ 'I_wiss I_mart I_weck I_reich I_emb CI_gor CI_cur CI_con NTindex I_Nesterov I_Budyko Rad RedN dew/rime Nupt I_frost I_frost_sp Ind_SHC' )
+
+END subroutine prep_out_comp
+
+!**************************************************************
+
+SUBROUTINE outyear (flagout)
+
+!yearly output
+ USE data_biodiv
+ USE data_climate
+ USE data_depo
+ USE data_evapo
+ USE data_inter
+ USE data_out
+ USE data_par
+ USE data_simul
+ USE data_soil
+ USE data_soil_cn
+ USE data_species
+ USE data_stand
+ USE data_manag
+ USE data_tsort
+ USE data_site
+ USE data_frost
+
+ IMPLICIT NONE
+
+ integer flagout ! control of output
+ ! 1 - output with outyear,
+ ! 2 - output after management and mortality
+ integer i,j,k,ihelp
+ integer unit_n ! output unit
+ real hconv ! conversion factor from patchsize into ha
+ ! output variables of yearly C-balance in kg C/ha
+ real y_GPP, & ! yearly gross productioin
+ y_NPP, & ! yearly net primary productioin
+ y_NEP, & ! yearly net ecosystem productioin
+ y_autresp, & ! yearly total resp of all cohorts and species
+ y_sumbio, & ! total biomass of all cohorts and all species
+ y_C_d_st, & ! C in stems of dead trees
+ y_sumvsab, & ! C in total sum of volume of removed stems by management
+ y_C_tot, & ! total soil C stock (OPM, humus and litter; whithout stems)
+ y_C_tot_es, & ! total C of ecosystem (soil, dead stems and biomass)
+ y_resps, & ! yearly soil respiration
+ y_resptot ! yearly total respiration
+ ! output variables of yearly C-balance in mol C/m2
+ real ym_GPP, & ! yearly gross productioin
+ ym_NPP, & ! yearly net primary productioin
+ ym_NEP, & ! yearly net ecosystem productioin
+ ym_autresp, & ! yearly total resp of all cohorts and species
+ ym_sumbio, & ! total biomass of all cohorts and all species
+ ym_C_d_st, & ! C in stems of dead trees
+ ym_sumvsab, & ! C in total sum of volume of removed stems by management
+ ym_C_tot, & ! total soil C stock (OPM, humus and litter; whithout stems)
+ ym_C_tot_es,& ! total C of ecosystem (soil, dead stems and biomass)
+ ym_resps, & ! yearly soil respiration
+ ym_resptot, & ! yearly total respiration
+ y_lai ! LAI of stand without soil vegetation
+ ! output variables of litter file: share in total biomasses
+ real y_fol, y_tb, y_crt, y_frt, y_stem, y_totlit, y_C_lit, y_N_lit
+ ! output variables harvested trees
+ real se_c_ha, & ! sortiment element in C kg/ha
+ se_m3_ha ! volume of sortiment element in m³/ha
+ real Cbc_ap ! output variable of biochar application
+ real help, h1, h2, h3, h4, q1, q2, q3, q4
+ real hdnlf, hdnlf_sp
+ integer hdate_lf, hdate_lftot, hanzdlf
+ real hsumtlf
+
+y_lai = 0.
+
+if ((flagout .eq. 1) .and. (.not.allocated(sout))) allocate (sout(nspecies))
+if (time.eq.0) then
+ hdnlf = 0.
+ hdnlf_sp = 0.
+ hdate_lf = 0.
+ hdate_lftot = 0.
+ hanzdlf = 0.
+ hsumtlf = 0.
+else
+ hdnlf = dnlf(time)
+ hdnlf_sp = dnlf_sp(time)
+ hdate_lf = date_lf(time)
+ hdate_lftot = date_lftot(time)
+ hanzdlf = anzdlf(time)
+ hsumtlf = sumtlf(time)
+end if
+
+! output of all selected files
+do i = 1,outy_n
+ if (outy(i)%out_flag .eq. flagout) then
+ unit_n = outy(i)%unit_nr
+
+ select CASE (outy(i)%kind_name)
+
+ CASE ('AET_mon','aet_mon')
+ q1 = aet_mon(1) + aet_mon(2) + aet_mon(3)
+ q2 = aet_mon(4) + aet_mon(5) + aet_mon(6)
+ q3 = aet_mon(7) + aet_mon(8) + aet_mon(9)
+ q4 = aet_mon(10) + aet_mon(11) + aet_mon(12)
+ if (time .gt.1) then
+ h1 = aet_dec + aet_mon(1) + aet_mon(2)
+ else
+ h1 = aet_mon(1) + aet_mon(2)
+ endif
+ h2 = aet_mon(3) + aet_mon(4) + aet_mon(5)
+ h3 = aet_mon(6) + aet_mon(7) + aet_mon(8)
+ h4 = aet_mon(9) + aet_mon(10) + aet_mon(11)
+ WRITE(unit_n,'(I6)',advance='no') time_cur
+ WRITE(unit_n,'(20F10.2)') aet_mon, q1, q2, q3, q4, h1, h2, h3, h4
+
+ CASE ('c_bal')
+ hconv = 10000./kpatchsize
+ y_NPP = sumNPP * cpart ! kg DW --> kg C
+ y_NPP = y_NPP * hconv ! kg C/patch --> kg C/ha
+ y_autresp = autresp * cpart * hconv ! kg DW pro patch --> kg C/ha
+ y_resps = resps_c * gm2_in_kgha ! g/m2 --> kg/ha
+ y_resptot = y_resps + y_autresp
+ y_GPP = y_NPP + y_autresp
+ y_NEP = y_NPP - y_resps
+ y_C_d_st = C_opm_stem * gm2_in_kgha
+ y_sumvsab = sumvsab * cpart ! kg DW /ha --> kg C
+ y_sumbio = (sumbio+sumbio_out) * cpart ! kg DW /ha --> kg C/ha
+ y_C_tot = C_tot * gm2_in_kgha * 0.001 ! g/m2 --> t/ha
+ y_C_tot_es= y_C_tot + y_C_d_st + y_sumbio
+ ym_NPP = sumNPP * cpart ! kg DW --> kg C
+ ym_NPP = ym_NPP * 1./kpatchsize ! kg C/patch --> kg C/m2
+ ym_NPP = ym_NPP * 1000. / Cmass ! kg C --> mol C
+ ym_autresp= autresp * cpart * kgha_in_gm2 * hconv / Cmass ! kg DW pro patch --> mol/m2
+ ym_resps = resps_c /Cmass ! g/m2 --> mol/m2
+ ym_resptot= ym_resps + ym_autresp
+ ym_GPP = ym_NPP + ym_autresp
+ ym_NEP = ym_NPP - ym_resps
+ ym_C_d_st = C_opm_stem /Cmass ! g/m2 --> mol/m2
+ ym_sumvsab= sumvsab * cpart * kgha_in_gm2 / Cmass ! kg DW /ha --> mol/m2
+ ym_sumbio = sumbio * cpart * kgha_in_gm2 / Cmass ! kg DW /ha --> mol/m2
+ ym_C_tot = C_tot /Cmass ! g/m2 --> mol/m2
+ ym_C_tot_es= ym_C_tot + ym_C_d_st + ym_sumbio
+
+ gppsum = gppsum * gm2_in_kgha
+
+ WRITE(unit_n,'(I6)',advance='no') time_cur
+ WRITE(unit_n,'(10F10.1,9F10.2,11F10.1,F10.1)') y_GPP, y_NPP, y_NEP, y_autresp, y_resps, y_resptot, &
+ y_C_d_st, y_sumvsab, y_sumbio, y_C_tot_es, y_C_tot, &
+ C_tot_1, C_hum_1, C_tot_40, C_hum_40, C_tot_80, C_hum_80, C_tot_100, C_hum_100, &
+ ym_GPP, ym_NPP, ym_NEP, ym_autresp, ym_resps, ym_resptot, &
+ ym_C_d_st, ym_sumvsab, ym_sumbio, ym_C_tot_es, ym_C_tot, gppsum
+
+ CASE ('Cbc')
+ if (flag_bc .gt. 0) then
+ WRITE(unit_n,'(I6)',advance='no') time_cur
+ do j=1,nlay
+ WRITE(unit_n,'(F10.3)',advance='no') C_bc(j)
+ END DO !j
+ WRITE(unit_n,'(A)') ''
+ endif
+
+ CASE ('Chum')
+ WRITE(unit_n,'(I6)',advance='no') time_cur
+ do j=1,nlay
+ WRITE(unit_n,'(F10.3)',advance='no') C_hum(j)
+ END DO !j
+ WRITE(unit_n,'(A)') ''
+
+ CASE ('Copm')
+ WRITE(unit_n,'(I6)',advance='no') time_cur
+ do j=1,nlay
+ WRITE(unit_n,'(F10.3)',advance='no') C_opm(j)
+ END DO !j
+ WRITE(unit_n,'(A)') ''
+
+ CASE ('classd')
+ WRITE(unit_n,'(I6)',advance='no') time_cur
+ do k=1,nspecies
+ do j=1,num_class
+ WRITE(unit_n,'(I10)',advance='no') diam_class(j,k)
+ END DO
+ end do
+ WRITE(unit_n,'(A)') ''
+ CASE ('classage')
+ WRITE(unit_n,'(I6)',advance='no') time_cur
+ do k=1,nspecies
+ do j=1,num_class
+ WRITE(unit_n,'(I10)',advance='no') diam_class_age(j,k)
+ END DO
+ end do
+ WRITE(unit_n,'(A)') ''
+
+ CASE ('classmvol')
+ WRITE(unit_n,'(I6)',advance='no') time_cur
+ do k=1,nspecies
+ do j=1,num_class
+ WRITE(unit_n,'(f10.3)',advance='no') diam_class_mvol(j,k)
+ END DO
+ end do
+ WRITE(unit_n,'(A)') ''
+
+ CASE ('classd_h')
+ WRITE(unit_n,'(I6)',advance='no') time_cur
+ do k=1,nspecies
+ do j=1,num_class
+ WRITE(unit_n,'(f10.3)',advance='no') diam_class_h(j,k)
+ END DO
+ end do
+ WRITE(unit_n,'(A)') ''
+
+ CASE ('classdm')
+ WRITE(unit_n,'(I6)',advance='no') time_cur
+ do k=1,nspecies
+ do j=1,num_class
+ WRITE(unit_n,'(I10)',advance='no') diam_classm(j,k)
+ END DO
+ end do
+ WRITE(unit_n,'(A)') ''
+
+ CASE ('classdm_h')
+ WRITE(unit_n,'(I6)',advance='no') time_cur
+ do k=1,nspecies
+ do j=1,num_class
+ WRITE(unit_n,'(f10.3)',advance='no') diam_classm_h(j,k)
+ END DO
+ end do
+ WRITE(unit_n,'(A)') ''
+
+ CASE ('classh')
+ WRITE(unit_n,'(I6)',advance='no') time_cur
+ do j=1,num_class
+ WRITE(unit_n,'(I10)',advance='no') height_class(j)
+ END DO
+ WRITE(unit_n,'(A)') ''
+
+ CASE ('classt')
+ WRITE(unit_n,'(I6)',advance='no') time_cur
+ do k=1,nspecies
+ do j=1,num_class
+ WRITE(unit_n,'(I10)',advance='no') diam_class_t(j,k)
+ END DO
+ end do
+ WRITE(unit_n,'(A)') ''
+
+ CASE ('clim')
+ help = co2 * 1000000.
+
+ WRITE(unit_n,'(2I5)',advance='no') time_cur
+ WRITE(unit_n,'(6F10.2, 6I10, 7F10.2, E12.4, F8.2, 6F10.2, 2F8.2, 3I8, F10.2, I8, F10.2)') med_air,sum_prec,med_rad, med_wind, help, gdday, &
+ days_summer, days_hot, days_ice, days_dry, days_hrain, days_snow, ind_arid_an, cwb_an, ind_lang_an, &
+ ind_cout_an, ind_wiss_an, ind_mart_an, ind_mart_vp, ind_emb, ind_weck, ind_reich, &
+ con_gor, con_cur, con_con, ntindex, ind_bud, hdnlf, hdnlf_sp, hdate_lf, hdate_lftot, hanzdlf, hsumtlf, iday_vegper, ind_shc
+
+ CASE ('clim_temp')
+ q1 = (temp_mon(1) + temp_mon(2) + temp_mon(3)) / 3.
+ q2 = (temp_mon(4) + temp_mon(5) + temp_mon(6)) / 3.
+ q3 = (temp_mon(7) + temp_mon(8) + temp_mon(9)) / 3.
+ q4 = (temp_mon(10) + temp_mon(11) + temp_mon(12)) / 3.
+ if (time .gt.1) then
+ h1 = (temp_dec + temp_mon(1) + temp_mon(2)) / 3.
+ else
+ h1 = (temp_mon(1) + temp_mon(2)) / 2.
+ endif
+ h2 = (temp_mon(3) + temp_mon(4) + temp_mon(5)) / 3.
+ h3 = (temp_mon(6) + temp_mon(7) + temp_mon(8)) / 3.
+ h4 = (temp_mon(9) + temp_mon(10) + temp_mon(11)) / 3.
+ WRITE(unit_n,'(I6)',advance='no') time_cur
+ WRITE(unit_n,'(20F10.2)') temp_mon, q1, q2, q3, q4, h1, h2, h3, h4
+
+ CASE ('clim_prec')
+ q1 = prec_mon(1) + prec_mon(2) + prec_mon(3)
+ q2 = prec_mon(4) + prec_mon(5) + prec_mon(6)
+ q3 = prec_mon(7) + prec_mon(8) + prec_mon(9)
+ q4 = prec_mon(10) + prec_mon(11) + prec_mon(12)
+ if (time .gt.1) then
+ h1 = prec_dec + prec_mon(1) + prec_mon(2)
+ else
+ h1 = prec_mon(1) + prec_mon(2)
+ endif
+ h2 = prec_mon(3) + prec_mon(4) + prec_mon(5)
+ h3 = prec_mon(6) + prec_mon(7) + prec_mon(8)
+ h4 = prec_mon(9) + prec_mon(10) + prec_mon(11)
+ WRITE(unit_n,'(I6)',advance='no') time_cur
+ WRITE(unit_n,'(20F10.2)') prec_mon, q1, q2, q3, q4, h1, h2, h3, h4
+
+ CASE ('clim_rad')
+ q1 = (rad_mon(1) + rad_mon(2) + rad_mon(3)) / 3.
+ q2 = (rad_mon(4) + rad_mon(5) + rad_mon(6)) / 3.
+ q3 = (rad_mon(7) + rad_mon(8) + rad_mon(9)) / 3.
+ q4 = (rad_mon(10) + rad_mon(11) + rad_mon(12)) / 3.
+ if (time .gt.1) then
+ h1 = (rad_dec + rad_mon(1) + rad_mon(2)) / 3.
+ else
+ h1 = (rad_mon(1) + rad_mon(2)) / 2.
+ endif
+ h2 = (rad_mon(3) + rad_mon(4) + rad_mon(5)) / 3.
+ h3 = (rad_mon(6) + rad_mon(7) + rad_mon(8)) / 3.
+ h4 = (rad_mon(9) + rad_mon(10) + rad_mon(11)) / 3.
+ WRITE(unit_n,'(I6)',advance='no') time_cur
+ WRITE(unit_n,'(20F10.2)') rad_mon, q1, q2, q3, q4, h1, h2, h3, h4
+
+ CASE ('clim_hum')
+ q1 = (hum_mon(1) + hum_mon(2) + hum_mon(3)) / 3.
+ q2 = (hum_mon(4) + hum_mon(5) + hum_mon(6)) / 3.
+ q3 = (hum_mon(7) + hum_mon(8) + hum_mon(9)) / 3.
+ q4 = (hum_mon(10) + hum_mon(11) + hum_mon(12)) / 3.
+ if (time .gt.1) then
+ h1 = (hum_dec + hum_mon(1) + hum_mon(2)) / 3.
+ else
+ h1 = (hum_mon(1) + hum_mon(2)) / 2.
+ endif
+ h2 = (hum_mon(3) + hum_mon(4) + hum_mon(5)) / 3.
+ h3 = (hum_mon(6) + hum_mon(7) + hum_mon(8)) / 3.
+ h4 = (hum_mon(9) + hum_mon(10) + hum_mon(11)) / 3.
+ WRITE(unit_n,'(I6)',advance='no') time_cur
+ WRITE(unit_n,'(20F10.2)') hum_mon, q1, q2, q3, q4, h1, h2, h3, h4
+
+ CASE ('indi')
+ WRITE(unit_n,'(2I5)',advance='no') time_cur
+ WRITE(unit_n,'(F10.2, 2(F8.2, 5I8), F10.1, I10, F8.2, 4I8 )') fire_indb, fire(1)%mean, fire(1)%frequ, &
+ fire(2)%mean, fire(2)%frequ, fire_indi_max, fire_indi_day, fire(3)%mean, (fire(3)%frequ(j), j=1,4)
+
+ CASE ('litter')
+ if (totfol .gt. 1E-6) then
+ y_fol = totfol_lit*100. / totfol
+ else
+ y_fol = -99.
+ endif
+ if (totfrt .gt. 1E-6) then
+ y_frt = totfrt_lit*100. / totfrt
+ else
+ y_frt = -99.
+ endif
+ if (tottb .gt. 1E-6) then
+ y_tb = tottb_lit*100. / tottb
+ else
+ y_tb = -99.
+ endif
+ if (totcrt .gt. 1E-6) then
+ y_crt = totcrt_lit*100. / totcrt
+ else
+ y_crt = -99.
+ endif
+ hconv = totsap + tothrt
+ if (hconv .gt. 1E-6) then
+ y_stem= totstem_lit*100. / hconv
+ else
+ y_stem = -99.
+ endif
+ y_totlit = totfol_lit + totfrt_lit + totcrt_lit + tottb_lit + totstem_lit
+ y_C_lit = (C_lit + C_lit_stem) * gm2_in_kgha
+ y_N_lit = (N_lit + N_lit_stem) * gm2_in_kgha
+ WRITE(unit_n,'(I6)',advance='no') time_cur
+ WRITE(unit_n,'(8E12.4,2(6E12.4),5F12.2)') totfol_lit,totfol_lit_tree,totfrt_lit,totfrt_lit_tree,totcrt_lit,tottb_lit,totstem_lit, y_totlit, &
+ C_lit_fol*gm2_in_kgha, C_lit_frt*gm2_in_kgha, C_lit_crt*gm2_in_kgha, &
+ C_lit_tb*gm2_in_kgha, C_lit_stem*gm2_in_kgha, y_C_lit, &
+ N_lit_fol*gm2_in_kgha, N_lit_frt*gm2_in_kgha, N_lit_crt*gm2_in_kgha, &
+ N_lit_tb*gm2_in_kgha, N_lit_stem*gm2_in_kgha, y_N_lit
+
+ CASE ('fcap_av')
+ WRITE(unit_n,'(I6)',advance='no') time_cur
+ do j=1,nlay
+ WRITE(unit_n,'(F10.3)',advance='no') field_cap(j) - wilt_p(j)
+ END DO !j
+ WRITE(unit_n,'(A)') ''
+
+ CASE ('fcapv_av')
+ WRITE(unit_n,'(I6)',advance='no') time_cur
+ do j=1,nlay
+ WRITE(unit_n,'(F10.3)',advance='no') f_cap_v(j) - wilt_p_v(j)
+ END DO !j
+ WRITE(unit_n,'(A)') ''
+
+ CASE ('GPP_mon')
+
+ q1 = GPP_mon(1) + GPP_mon(2) + GPP_mon(3)
+ q2 = GPP_mon(4) + GPP_mon(5) + GPP_mon(6)
+ q3 = GPP_mon(7) + GPP_mon(8) + GPP_mon(9)
+ q4 = GPP_mon(10) + GPP_mon(11) + GPP_mon(12)
+ if (time .gt.1) then
+ h1 = GPP_dec + GPP_mon(1) + GPP_mon(2)
+ else
+ h1 = GPP_mon(1) + GPP_mon(2)
+ endif
+ h2 = GPP_mon(3) + GPP_mon(4) + GPP_mon(5)
+ h3 = GPP_mon(6) + GPP_mon(7) + GPP_mon(8)
+ h4 = GPP_mon(9) + GPP_mon(10) + GPP_mon(11)
+ WRITE(unit_n,'(I6)',advance='no') time_cur
+ WRITE(unit_n,'(20F10.2)') GPP_mon, q1, q2, q3, q4, h1, h2, h3, h4
+
+ CASE ('humusv')
+ WRITE(unit_n,'(I6)',advance='no') time_cur
+ do j=1,nlay
+ WRITE(unit_n,'(F10.3)',advance='no') humusv(j)*100.
+ END DO !j
+ WRITE(unit_n,'(A)') ''
+
+ CASE ('NEE_mon')
+ q1 = NEE_mon(1) + NEE_mon(2) + NEE_mon(3)
+ q2 = NEE_mon(4) + NEE_mon(5) + NEE_mon(6)
+ q3 = NEE_mon(7) + NEE_mon(8) + NEE_mon(9)
+ q4 = NEE_mon(10) + NEE_mon(11) + NEE_mon(12)
+ if (time .gt.1) then
+ h1 = NEE_dec + NEE_mon(1) + NEE_mon(2)
+ else
+ h1 = NEE_mon(1) + NEE_mon(2)
+ endif
+ h2 = NEE_mon(3) + NEE_mon(4) + NEE_mon(5)
+ h3 = NEE_mon(6) + NEE_mon(7) + NEE_mon(8)
+ h4 = NEE_mon(9) + NEE_mon(10) + NEE_mon(11)
+ WRITE(unit_n,'(I6)',advance='no') time_cur
+ WRITE(unit_n,'(20F10.2)') NEE_mon, q1, q2, q3, q4, h1, h2, h3, h4
+
+ CASE ('NPP_mon')
+ q1 = NPP_mon(1) + NPP_mon(2) + NPP_mon(3)
+ q2 = NPP_mon(4) + NPP_mon(5) + NPP_mon(6)
+ q3 = NPP_mon(7) + NPP_mon(8) + NPP_mon(9)
+ q4 = NPP_mon(10) + NPP_mon(11) + NPP_mon(12)
+ if (time .gt.1) then
+ h1 = NPP_dec + NPP_mon(1) + NPP_mon(2)
+ else
+ h1 = NPP_mon(1) + NPP_mon(2)
+ endif
+ h2 = NPP_mon(3) + NPP_mon(4) + NPP_mon(5)
+ h3 = NPP_mon(6) + NPP_mon(7) + NPP_mon(8)
+ h4 = NPP_mon(9) + NPP_mon(10) + NPP_mon(11)
+ WRITE(unit_n,'(I6)',advance='no') time_cur
+ WRITE(unit_n,'(20F10.2)') NPP_mon, q1, q2, q3, q4, h1, h2, h3, h4
+
+ CASE ('Nbc')
+ if (flag_bc .gt. 0) then
+ WRITE(unit_n,'(I6)',advance='no') time_cur
+ do j=1,nlay
+ WRITE(unit_n,'(F10.3)',advance='no') N_bc(j)
+ END DO !j
+ WRITE(unit_n,'(A)') ''
+ endif
+
+ CASE ('Nhum')
+ WRITE(unit_n,'(I6)',advance='no') time_cur
+ do j=1,nlay
+ WRITE(unit_n,'(F10.3)',advance='no') N_hum(j)
+ END DO !j
+ WRITE(unit_n,'(A)') ''
+
+ CASE ('Nopm')
+ WRITE(unit_n,'(I6)',advance='no') time_cur
+ do j=1,nlay
+ WRITE(unit_n,'(F10.3)',advance='no') N_opm(j)
+ END DO !j
+ WRITE(unit_n,'(A)') ''
+
+ CASE ('manrec')
+ if (flag_manreal.eq.1) then
+ WRITE(unit_n,'(I6)',advance='no') time_cur-1
+ WRITE(unit_n,'(10x,A30,I6)') maninf, meas
+ end if
+
+ CASE ('mansort')
+
+ if ((flag_manreal.eq.1.or.flag_deadsort.eq.1).and.maninf.ne.'tending'.and.maninf.ne.'brushing') then
+ ztim=>st%first
+ do
+ IF (.not.ASSOCIATED(ztim)) exit
+ if(time.eq.ztim%tim%year.and. (ztim%tim%stype.eq.'ab'.or.ztim%tim%stype.eq.'tb')) then
+
+ se_m3_ha = (ztim%tim%vol/kpatchsize)*10000. ! m³/patchsize ---> m3/ha
+ se_c_ha = se_m3_ha*spar(ztim%tim%specnr)%prhos*1000000.*cpart ! m³/patchsize ---> kg C/ha
+ write(unit_n,'(3I6,1x,A5,1x,F8.3,1x,f7.3,1x,f7.3,1x,f7.3,1x,f7.3,1x,f9.4,1x,f14.3,1x,i8,x,a4)') ztim%tim%year,&
+ ztim%tim%count,ztim%tim%specnr,ztim%tim%ttype,ztim%tim%length,ztim%tim%dia,ztim%tim%diaor, ztim%tim%zapfd,&
+ ztim%tim%zapfdor,se_m3_ha, se_c_ha,int(ztim%tim%tnum), ztim%tim%stype
+ end if
+ ztim=>ztim%next
+ end do
+ flag_manreal=0
+ flag_deadsort=0
+ else if (maninf.eq.'tending'.or.maninf.eq.'brushing') then
+ flag_manreal=0
+ maninf=' '
+ end if
+
+ CASE ('root')
+ WRITE(unit_n,'(I6)',advance='no') time_cur
+ do j=1,nlay
+ WRITE(unit_n,'(F10.3)',advance='no') root_fr(j)
+ END DO !j
+ WRITE(unit_n,'(A)') ''
+
+ CASE ('fr_loss')
+ WRITE(unit_n,'(I6)',advance='no') time_cur
+ do j=1,nlay
+ WRITE(unit_n,'(F10.3)',advance='no') fr_loss(j)
+ END DO !j
+ WRITE(unit_n,'(A)') ''
+
+ CASE ('redis')
+ WRITE(unit_n,'(I6)',advance='no') time_cur
+ do j=1,nlay
+ WRITE(unit_n,'(F10.3)',advance='no') redis(j)
+ END DO !j
+ WRITE(unit_n,'(A)') ''
+
+ CASE ('sdrought')
+ WRITE(unit_n,'(I6)',advance='no') time_cur
+ WRITE(unit_n,'(20I8)') s_drought
+
+ CASE ('soil')
+ help = -99.0
+ Cbc_ap = 0.
+ if (time .gt. 0) help = rnet_cum / recs(time)
+ if (flag_bc .gt. 0) then
+ ihelp = y_bc_n - 1
+ if (y_bc_n .eq. 1) ihelp = y_bc_n
+ if (y_bc(ihelp) .eq. time) then
+ Cbc_ap = Cbc_ap + C_bc_appl(ihelp)
+ endif
+ endif
+ WRITE(unit_n,'(I6)',advance='no') time_cur
+ WRITE(unit_n,'(13F10.3,5F10.2,17F10.3,4F10.2)') med_air, sum_prec, int_cum_can, &
+ perc_cum, wupt_cum, wupt_r_c, tra_tr_cum, tra_sv_cum, wupt_e_c, aet_cum, wat_tot, gp_can_mean, &
+ N_min, N_tot, C_tot, N_an_tot, N_hum_tot, C_hum_tot, N_hum(1), C_hum(1), &
+ N_lit, C_lit, C_opm_fol, C_opm_frt, C_opm_crt, C_opm_tb, C_opm_stem, Nupt_c, &
+ Nleach_c, Ndep_cum, resps_c, pet_cum, int_cum_sveg, thick(1), dew_cum, help, N_bc_tot, C_bc_tot, Cbc_ap
+
+ CASE ('spec')
+ WRITE(unit_n,'(I6)',advance='no') time_cur
+ do j=1,nspecies
+ zeig=>pt%first
+ do while (associated(zeig))
+ if(zeig%coh%species.eq.j)then
+ WRITE(unit_n,'(2F10.2,I10,F10.2)',advance='no') svar(j)%med_diam, &
+ svar(j)%dom_height, svar(j)%sum_ntreea, svar(j)%sum_bio
+ exit
+ END IF
+ zeig=>zeig%next
+ END DO
+ END DO
+ WRITE(unit_n,*) ' '
+
+ CASE('standsort')
+ if (outy(i)%out_flag .eq. 1) then
+ outy(i)%out_flag = 2
+ else if (outy(i)%out_flag .eq. 2) then
+ ztim=>st%first
+ do
+ IF (.not.ASSOCIATED(ztim)) exit
+ if(ztim%tim%year.eq.time.and. ztim%tim%stype.eq.'vb') then
+ se_m3_ha = (ztim%tim%vol/kpatchsize)*10000. ! m³/patchsize ---> m3/ha
+ se_c_ha = se_m3_ha*spar(ztim%tim%specnr)%prhos*1000000.*cpart ! m³/patchsize ---> kg C/ha
+ write(unit_n,'(3I6,1x,A5,1x,F8.3,1x,f7.3,1x,f7.3,1x,f7.3,1x,f7.3,1x,f9.4,1x,f14.3,1x,i8)') ztim%tim%year,&
+ ztim%tim%count,ztim%tim%specnr,ztim%tim%ttype,ztim%tim%length,ztim%tim%dia,ztim%tim%diaor, ztim%tim%zapfd,&
+ ztim%tim%zapfdor,se_m3_ha, se_c_ha,int(ztim%tim%tnum)
+ end if
+ ztim=>ztim%next
+ end do
+ end if
+
+ CASE ('TER_mon')
+ q1 = TER_mon(1) + TER_mon(2) + TER_mon(3)
+ q2 = TER_mon(4) + TER_mon(5) + TER_mon(6)
+ q3 = TER_mon(7) + TER_mon(8) + TER_mon(9)
+ q4 = TER_mon(10) + TER_mon(11) + TER_mon(12)
+ if (time .gt.1) then
+ h1 = TER_dec + TER_mon(1) + TER_mon(2)
+ else
+ h1 = TER_mon(1) + TER_mon(2)
+ endif
+ h2 = TER_mon(3) + TER_mon(4) + TER_mon(5)
+ h3 = TER_mon(6) + TER_mon(7) + TER_mon(8)
+ h4 = TER_mon(9) + TER_mon(10) + TER_mon(11)
+ WRITE(unit_n,'(I6)',advance='no') time_cur
+ WRITE(unit_n,'(20F10.2)') TER_mon, q1, q2, q3, q4, h1, h2, h3, h4
+
+ CASE ('veg')
+ if (outy(i)%out_flag .eq. 1) then
+
+ vout%help_veg1(1) = anz_spec
+ vout%help_veg1(2) = anz_coh_act
+ vout%help_veg1(3) = anz_tree_ha
+
+ do k = 1, nspec_tree
+ y_lai = y_lai + svar(k)%sum_lai
+ end do
+ vout%help_veg2(1) = y_lai
+ vout%help_veg2(2) = sumbio
+ vout%help_veg2(3) = sumnpp
+ vout%help_veg2(4) = med_diam
+ vout%help_veg2(5) = hdom
+ vout%help_veg2(6) = totfol
+ vout%help_veg2(7) = totsap
+ vout%help_veg2(8) = totfrt
+ vout%help_veg2(9) = tothrt
+ vout%help_veg2(10) = totsteminc
+ vout%help_veg2(11) = totstem_m3
+ vout%help_veg3 = crown_area/kpatchsize
+ outy(i)%out_flag = 2
+ else if (outy(i)%out_flag .eq. 2) then
+ WRITE(unit_n,'(I6)',advance='no') time_cur
+ WRITE(unit_n,'(3I10)',advance='no') vout%help_veg1
+ WRITE(unit_n,'(F10.3,2E12.3,2F12.3,14E12.3, 5F12.3)') vout%help_veg2, sumvsab, sumvsdead, &
+ vout%help_veg3, drIndAl, Ndem, gp_can_mean, gp_can_min, gp_can_max, mean_diam, mean_height, basal_area, sumvsdead_m3, totsteminc_m3
+ outy(i)%out_flag = 1
+ endif
+
+ CASE ('veg_in')
+ WRITE(unit_n,'(2I5)',advance='no') time_cur
+ WRITE(unit_n,'(3I10)',advance='no') anz_spec_in, anz_coh_in, anz_tree_in
+ WRITE(unit_n,'(F10.3,E12.3,2F12.3,E12.3)') LAI_in, sumbio_in, med_diam_in, hmean_in, totfol_in
+
+ CASE ('veg_out')
+ WRITE(unit_n,'(2I5)',advance='no') time_cur
+ WRITE(unit_n,'(3I10)',advance='no') anz_spec_out, anz_coh_out, anz_tree_out
+ WRITE(unit_n,'(F10.3,E12.3,2F12.3,E12.3)') LAI_out, sumbio_out, med_diam_out, hmean_out, totfol_out
+
+ CASE ('veg_be')
+ ! beech - veg file
+ call outveg (1, outy(i)%out_flag, unit_n)
+
+ CASE ('veg_bi')
+ ! birch - veg file
+ call outveg (5, outy(i)%out_flag, unit_n)
+
+ CASE ('veg_pi')
+ ! pine - veg file
+ call outveg (3, outy(i)%out_flag, unit_n)
+
+ CASE ('veg_pc')
+ ! pinus contorta - veg file
+ if (nspec_tree .gt. 5) call outveg (6, outy(i)%out_flag, unit_n)
+
+ CASE ('veg_pp')
+ ! pinus ponderosa - veg file
+ if (nspec_tree .gt. 6) call outveg (7, outy(i)%out_flag, unit_n)
+
+ CASE ('veg_pt')
+ ! populus tremula - veg file
+ if (nspec_tree .gt. 7) call outveg (8, outy(i)%out_flag, unit_n)
+
+ CASE ('veg_oa')
+ ! oak - veg file
+ call outveg (4, outy(i)%out_flag, unit_n)
+
+ CASE ('veg_sp')
+ ! spruce - veg file
+ call outveg (2, outy(i)%out_flag, unit_n)
+
+ CASE ('veg_ph')
+ ! aleppo pine - veg file
+ if (nspec_tree .gt. 8) call outveg (9, outy(i)%out_flag, unit_n)
+
+ CASE ('veg_dg')
+ ! douglas fir - veg file
+ if (nspec_tree .gt. 9) call outveg (10, outy(i)%out_flag, unit_n)
+
+ CASE ('veg_rb')
+ ! robinia - veg file
+ if (nspec_tree .gt. 10) call outveg (11, outy(i)%out_flag, unit_n)
+
+ CASE ('veg_egl')
+ ! Eucalyptus globulus - veg file
+ if (nspec_tree .gt. 11) call outveg (12, outy(i)%out_flag, unit_n)
+
+ CASE ('veg_egr')
+ ! Ecalyptus grandis - veg file
+ if (nspec_tree .gt. 12) call outveg (13, outy(i)%out_flag, unit_n)
+
+ CASE ('veg_sveg')
+ ! ground vegetation - veg file
+ if (flag_sveg .gt. 0) call outveg (14, outy(i)%out_flag, unit_n)
+
+ CASE ('veg_mist')
+ ! Mistletoe (Viscum a.) - veg file
+ if (flag_dis .gt. 0) call outveg (15, outy(i)%out_flag, unit_n)
+
+ END SELECT
+ END IF
+END DO !i
+
+if(flag_cohout==1 .or. flag_cohout==2) call coh_out_y (flagout)
+if (flagout .eq. 2) deallocate (sout)
+
+END subroutine outyear
+
+!**************************************************************
+
+SUBROUTINE outday (flagout)
+!daily output
+
+ USE data_biodiv
+ USE data_climate
+ USE data_depo
+ USE data_inter
+ USE data_evapo
+ USE data_inter
+ USE data_simul
+ USE data_stand
+ USE data_species
+ USE data_soil
+ USE data_soil_cn
+ USE data_soil_t
+ USE data_out
+
+ IMPLICIT NONE
+
+ integer flagout ! control of output
+ ! 1 - output with
+ ! 2 - output
+ INTEGER i,j,jj,k
+ integer tt, month
+ INTEGER unit_n ! output unit
+ REAL xhelp, xhelp1
+
+! output of all selected files
+do i = 1,outd_n
+ if (outd(i)%out_flag .eq. flagout) then
+ unit_n = outd(i)%unit_nr
+
+ select CASE (outd(i)%kind_name)
+
+ CASE ('Cday')
+ j=iday
+ WRITE(unit_n,'(2I6)',advance='no') j,time_cur
+ WRITE(unit_n,'(13E12.4, F7.1)') phot_C, dailygrass_C, dailynetass_C, dailypotNPP_C, dailyNPP_C, NPP_day, GPP_day, Cout%NEE(j), &
+ TER_day, dailyautresp_C, Cout%Resp_aut(j), respsoil, dailyrespfol_C, 100.*totFPARsum
+
+ CASE ('Chumd')
+ WRITE(unit_n,'(2I6)',advance='no') iday,time_cur
+ do j=1,nlay
+ WRITE(unit_n,'(F10.3)',advance='no') C_hum(j)
+ END DO !j
+ WRITE(unit_n,'(A)') ''
+
+ CASE ('Copmd')
+ WRITE(unit_n,'(2I6)',advance='no') iday,time_cur
+ do j=1,nlay
+ WRITE(unit_n,'(F10.3)',advance='no') C_opm(j)
+ END DO !j
+ WRITE(unit_n,'(A)') ''
+
+ CASE ('COPMfract')
+ WRITE(unit_n,'(2I6)',advance='no') iday,time_cur
+ do k=1,anrspec
+ j = nrspec(k)
+ xhelp = SUM(slit(j)%C_opm_frt)
+ xhelp1 = SUM(slit(j)%C_opm_crt)
+ WRITE(unit_n,'(5F10.3)',advance='no') slit(j)%C_opm_fol, slit(j)%C_opm_tb, &
+ xhelp, xhelp1, slit(j)%C_opm_stem
+ END DO ! j
+ WRITE(unit_n,'(A)') ''
+
+ CASE ('Cbcd')
+ if (flag_bc .gt. 0) then
+ WRITE(unit_n,'(2I6)',advance='no') iday,time_cur
+ do j=1,nlay
+ WRITE(unit_n,'(F10.3)',advance='no') C_bc(j)
+ END DO !j
+ WRITE(unit_n,'(A)') ''
+ endif
+
+ CASE ('day')
+ WRITE(unit_n,'(2I6)',advance='no') iday,time_cur
+ xhelp = (NO_dep + NH_dep)*1000. ! g/m² ==> mg/m²
+ if (N_min > 100) then
+ continue
+ endif
+ WRITE(unit_n,'(21F10.3, F10.1, 3I7, I8, F8.3, 4F10.2, 4F10.3)',advance='no') airtemp,rad,prec,interc_can,snow,pet,aet, &
+ trans_dem,trans_tree,trans_sveg,gp_can,respsoil,Nleach,Nupt_d,N_min,N_an_tot, &
+ xhelp,cover,LAI, Irelpool(0), totFPARcan, fire_indi, fire(2)%index, fire(1)%index, fire(3)%index, snow_day, &
+ drIndd, bucks_root, bucks_100, prec-pet, dptemp, dew_rime, Rnet_tot, rad_max
+ WRITE(unit_n,'(A)') ''
+
+ CASE ('day_short')
+ call tzinda(tt,month,time_cur,iday)
+ WRITE(unit_n,'(2(I2,1X), I4, 2X)',advance='no') tt,month,time_cur
+ WRITE(unit_n,'(I8, F10.2)',advance='no') fire(2)%index, prec-pet
+ WRITE(unit_n,'(A)') ''
+
+ CASE ('NH4')
+ WRITE(unit_n,'(I6,I5,1X)',advance='no') iday,time_cur
+ do j=1,nlay
+ WRITE(unit_n,'(E10.3)',advance='no') NH4(j)
+ END DO !j
+ WRITE(unit_n,'(A)') ''
+
+ CASE ('NH4c')
+ WRITE(unit_n,'(2I6)',advance='no') iday,time_cur
+ do j=1,nlay
+ ! convert gN/m2 into mgN/l
+ xhelp = pNH4f * NH4(j) * 1000. / wats(j)
+ WRITE(unit_n,'(F10.4)',advance='no') xhelp
+ END DO !j
+ WRITE(unit_n,'(A)') ''
+
+ CASE ('NO3')
+ WRITE(unit_n,'(I6,I5,1X)',advance='no') iday,time_cur
+ do j=1,nlay
+ WRITE(unit_n,'(E10.3)',advance='no') NO3(j)
+ END DO !j
+ WRITE(unit_n,'(A)') ''
+
+ CASE ('NO3c')
+ WRITE(unit_n,'(2I6)',advance='no') iday,time_cur
+ do j=1,nlay
+ ! convert gN/m2 into mgN/l
+ xhelp = pNO3f * NO3(j) * 1000. / wats(j)
+ WRITE(unit_n,'(F10.4)',advance='no') xhelp
+ END DO !j
+ WRITE(unit_n,'(A)') ''
+
+ CASE ('Nhumd')
+ WRITE(unit_n,'(2I6)',advance='no') iday,time_cur
+ do j=1,nlay
+ WRITE(unit_n,'(F10.3)',advance='no') N_hum(j)
+ END DO !j
+ WRITE(unit_n,'(A)') ''
+
+ CASE ('Nopmd')
+ WRITE(unit_n,'(2I6)',advance='no') iday,time_cur
+ do j=1,nlay
+ WRITE(unit_n,'(F10.3)',advance='no') N_opm(j)
+ END DO !j
+ WRITE(unit_n,'(A)') ''
+
+ CASE ('NOPMfract')
+ WRITE(unit_n,'(2I6)',advance='no') iday,time_cur
+ do k=1,anrspec
+ j = nrspec(k)
+ WRITE(unit_n,'(5F10.3)',advance='no') slit(j)%N_opm_fol, slit(j)%N_opm_tb, &
+ slit(j)%N_opm_frt(1), slit(j)%N_opm_crt(1), slit(j)%N_opm_stem
+ END DO ! j
+ WRITE(unit_n,'(A)') ''
+
+ CASE ('Nuptd')
+ WRITE(unit_n,'(2I6)',advance='no') iday,time_cur
+ do j=1,nlay
+ WRITE(unit_n,'(E10.2)',advance='no') Nupt(j)
+ END DO !j
+ WRITE(unit_n,'(A)') ''
+
+ CASE ('Nmind')
+ WRITE(unit_n,'(2I6)',advance='no') iday,time_cur
+ do j=1,nlay
+ WRITE(unit_n,'(E10.2)',advance='no') Nmin(j)
+ END DO !j
+ WRITE(unit_n,'(A)') ''
+
+ CASE ('perc')
+ WRITE(unit_n,'(2I6)',advance='no') iday,time_cur
+ do j=1,nlay
+ WRITE(unit_n,'(F10.3)',advance='no') perc(j)
+ END DO !j
+ WRITE(unit_n,'(A)') ''
+
+ CASE ('specd')
+ WRITE(unit_n,'(2I6)',advance='no') iday,time_cur
+ k = 0
+ do jj=1,anrspec
+ j = nrspec(jj)
+ if (k .gt. 0) WRITE(unit_n,'(A12)',advance='no') ''
+ WRITE(unit_n,'(A16,I8)',advance='no') spar(j)%species_short_name, j
+ WRITE(unit_n,'(4E12.3, F10.3)',advance='no') svar(j)%Ndem, svar(j)%Nupt, svar(j)%Ndemp, svar(j)%Nuptp, svar(j)%RedN
+ WRITE(unit_n,'(A)') ''
+ k = k+1
+ END DO !j
+
+ CASE ('temp')
+ WRITE(unit_n,'(2I6,F10.3)',advance='no') iday,time_cur, temps_surf
+ do j=1,nlay
+ WRITE(unit_n,'(F10.3)',advance='no') temps(j)
+ END DO !j
+ WRITE(unit_n,'(A)') ''
+
+ CASE ('water')
+ WRITE(unit_n,'(2I6)',advance='no') iday,time_cur
+ do j=1,nlay
+ WRITE(unit_n,'(F10.3)',advance='no') wats(j)
+ END DO !j
+ WRITE(unit_n,'(A)') ''
+
+ CASE ('watvol')
+ WRITE(unit_n,'(2I6)',advance='no') iday,time_cur
+ do j=1,nlay
+ WRITE(unit_n,'(F10.3)',advance='no') watvol(j)
+ END DO !j
+ WRITE(unit_n,'(A)') ''
+
+ CASE ('wat_res')
+ WRITE(unit_n,'(2I6)',advance='no') iday,time_cur
+ do j=1,nlay
+ WRITE(unit_n,'(F10.4)',advance='no') wat_res(j)
+ END DO !j
+ WRITE(unit_n,'(A)') ''
+
+ CASE ('wupt')
+ WRITE(unit_n,'(2I6)',advance='no') iday,time_cur
+ do j=1,nlay
+ WRITE(unit_n,'(F10.3)',advance='no') wupt_r(j)
+ END DO !j
+ WRITE(unit_n,'(A)') ''
+
+ end select
+ END IF
+END DO !i
+
+if(flag_cohout .gt. 0) call coh_out_d (flagout)
+END subroutine outday
+
+!**************************************************************
+
+SUBROUTINE coh_out_d (flagout)
+! daily cohort output
+
+USE data_simul
+USE data_stand
+USE data_out
+USE data_par
+
+IMPLICIT NONE
+
+integer flagout ! control of output
+ ! 1 - output with
+ ! 2 - output
+INTEGER i,j
+INTEGER unit_n ! output unit
+logical lflag
+real help
+
+ ! output of all selected files
+ do i = 1,outcd_n
+ if (outcd(i)%out_flag .eq. flagout) then
+ unit_n = outcd(i)%unit_nr
+ WRITE(unit_n ,'(2I5)',advance='no') iday,time_cur
+
+ do j= 1,max_coh
+ zeig => pt%first
+ lflag = .FALSE.
+
+ do while (associated(zeig))
+ if (zeig%coh%ident .eq. j) then
+
+ select CASE (outcd(i)%kind_name)
+ CASE ('ass')
+ WRITE(unit_n,'(E12.3)',advance='no') zeig%coh%assi
+
+ CASE ('aevi')
+ WRITE(unit_n,'(E12.3)',advance='no') zeig%coh%aev_i
+
+ CASE ('ddi')
+ WRITE(unit_n,'(F12.3)',advance='no') zeig%coh%drindd
+
+ CASE ('dem')
+ WRITE(unit_n,'(E12.3)',advance='no') zeig%coh%demand
+
+ CASE ('dips')
+ WRITE(unit_n,'(F12.3)',advance='no') zeig%coh%drindps
+
+ CASE ('gp')
+ WRITE(unit_n,'(E12.3)',advance='no') zeig%coh%gp
+
+ CASE ('gsdps')
+ WRITE(unit_n,'(F12.0)',advance='no') zeig%coh%ndaysps
+
+ CASE ('intcap')
+ help = SUM(zeig%coh%intcap)
+ WRITE(unit_n,'(E12.3)',advance='no') help
+
+ CASE ('interc')
+ WRITE(unit_n,'(E12.3)',advance='no') zeig%coh%interc_st
+
+ CASE ('Ndemc_d')
+ WRITE(unit_n,'(E12.3)',advance='no') zeig%coh%Ndemc_d
+
+ CASE ('Nuptc_d')
+ WRITE(unit_n,'(E12.3)',advance='no') zeig%coh%Nuptc_d
+
+ CASE ('N_fol')
+ WRITE(unit_n,'(E12.3)',advance='no') zeig%coh%N_fol
+
+ CASE ('N_pool')
+ WRITE(unit_n,'(E12.3)',advance='no') zeig%coh%N_pool
+
+ CASE ('RedNc')
+ WRITE(unit_n,'(E12.3)',advance='no') zeig%coh%RedNc
+
+ CASE ('resp')
+ help = zeig%coh%resp * kg_in_g * cpart ! kg DW per tree ==> g C per tree
+ WRITE(unit_n,'(E12.3)',advance='no') help
+
+ CASE ('respaut')
+! help = zeig%coh%respaut * kg_in_g * cpart ! kg DW per tree ==> g C per tree
+ help = zeig%coh%maintres * kg_in_g * cpart
+ WRITE(unit_n,'(E12.3)',advance='no') help
+
+ CASE ('respbr')
+ help = zeig%coh%respbr * kg_in_g * cpart ! kg DW per tree ==> g C per tree
+ WRITE(unit_n,'(E12.3)',advance='no') help
+
+ CASE ('respfol')
+ help = zeig%coh%respfol * kg_in_g * cpart ! kg DW per tree ==> g C per tree
+ WRITE(unit_n,'(E12.3)',advance='no') help
+
+ CASE ('resphet')
+ help = zeig%coh%resphet * kg_in_g * cpart ! kg DW per tree ==> g C per tree
+ WRITE(unit_n,'(E12.3)',advance='no') help
+
+ CASE ('respsap')
+ help = zeig%coh%respsap * kg_in_g * cpart ! kg DW per tree ==> g C per tree
+ WRITE(unit_n,'(E12.3)',advance='no') help
+
+ CASE ('respfrt')
+ help = zeig%coh%respfrt * kg_in_g * cpart ! kg DW per tree ==> g C per tree
+ WRITE(unit_n,'(E12.3)',advance='no') help
+
+ CASE ('sup')
+ WRITE(unit_n,'(E12.3)',advance='no') zeig%coh%supply
+
+ CASE ('totfpar')
+ WRITE(unit_n,'(E12.3)',advance='no') zeig%coh%totfpar
+
+ end select
+ lflag = .TRUE.
+ exit
+ ELSE
+ zeig => zeig%next
+ END IF
+
+ END DO
+
+ if (.not. lflag) WRITE(unit_n,'(F12.3)',advance='no') -99.9
+
+ END DO !j
+
+ WRITE(unit_n,'(A)') ''
+
+ END IF ! out_flag
+ END DO !i
+END subroutine coh_out_d
+
+!**************************************************************
+
+SUBROUTINE coh_out_y (flagout)
+
+!yearly cohort output
+use data_simul
+use data_soil
+use data_stand
+use data_out
+use data_par
+
+implicit none
+
+integer flagout ! control of cohort output
+ ! 1 - output with outyear,
+ ! 2 - output after management and mortality
+integer i,j,k
+integer unit_n ! output unit
+logical lflag
+real help
+
+ ! output of all selected files
+ do i = 1,outcy_n
+ if (outcy(i)%out_flag .eq. flagout) then
+ unit_n = outcy(i)%unit_nr
+ WRITE(unit_n ,'(I5)',advance='no') time_cur
+
+ do j= 1,max_coh
+ zeig => pt%first
+ lflag = .FALSE.
+
+ do while (associated(zeig))
+ if (zeig%coh%ident .eq. j) then
+
+ select CASE (outcy(i)%kind_name)
+ CASE ('age')
+ WRITE(unit_n,'(I12)',advance='no') zeig%coh%x_age
+
+ CASE ('ahb')
+ WRITE(unit_n,'(E12.3)',advance='no') zeig%coh%x_ahb
+
+ CASE ('ahbasrel')
+ if (zeig%coh%Asapw .gt. zero) then
+ help = zeig%coh%x_ahb / zeig%coh%Asapw
+ else
+ help = 0.
+ endif
+ WRITE(unit_n,'(E12.3)',advance='no') help
+
+ CASE ('ahc')
+ WRITE(unit_n,'(E12.3)',advance='no') zeig%coh%ahc
+
+ CASE ('ahcasrel')
+ if (zeig%coh%Asapw .gt. zero) then
+ help = zeig%coh%ahc / zeig%coh%Asapw
+ else
+ help = 0.
+ endif
+ WRITE(unit_n,'(E12.3)',advance='no') help
+
+ CASE ('asapw')
+ WRITE(unit_n,'(E12.3)',advance='no') zeig%coh%Asapw
+
+ CASE ('atr')
+ WRITE(unit_n,'(I12)',advance='no') int(zeig%coh%ntreea)
+
+ CASE ('bioi')
+ WRITE(unit_n,'(E12.3)',advance='no') zeig%coh%bio_inc
+
+ CASE ('botlayer')
+ WRITE(unit_n,'(I12)',advance='no') zeig%coh%botLayer
+
+ CASE ('cpa')
+ WRITE(unit_n,'(E12.3)',advance='no') zeig%coh%crown_area*int(zeig%coh%ntreea)
+
+ CASE ('crt')
+ WRITE(unit_n,'(E12.3)',advance='no') zeig%coh%x_crt
+
+ CASE ('daybb')
+ WRITE(unit_n,'(I12)',advance='no') int(zeig%coh%day_bb)
+
+ CASE ('dcrb')
+ WRITE(unit_n,'(E12.3)',advance='no') zeig%coh%dcrb
+
+ CASE ('diac')
+ if( zeig%coh%ndaysgr.ne.0) then
+ WRITE(unit_n,'(E12.3)',advance='no') zeig%coh%drindal/zeig%coh%ndaysgr
+ else
+ WRITE(unit_n,'(E12.3)',advance='no') zeig%coh%drindal
+ end if
+
+ CASE ('diam')
+ WRITE(unit_n,'(f12.5)',advance='no') zeig%coh%diam
+
+
+ CASE ('dtr')
+ WRITE(unit_n,'(E12.3)',advance='no') zeig%coh%ntreed
+
+ CASE ('dwd')
+ help = zeig%coh%ntreed*(zeig%coh%x_sap + zeig%coh%x_hrt)
+ WRITE(unit_n,'(E12.3)',advance='no') help
+
+ CASE ('fol')
+ WRITE(unit_n,'(E12.3)',advance='no') zeig%coh%x_fol
+
+ CASE ('foli')
+ WRITE(unit_n,'(E12.3)',advance='no') zeig%coh%fol_inc
+
+ CASE ('frt')
+ WRITE(unit_n,'(E12.3)',advance='no') zeig%coh%x_frt
+
+ CASE ('frti')
+ WRITE(unit_n,'(E12.3)',advance='no') zeig%coh%frt_inc
+
+ CASE ('frtrel')
+ WRITE(unit_n,'(E12.3)',advance='no') zeig%coh%frtrel(1)
+
+ CASE ('rld')
+ if (flag_wred .eq. 9) WRITE(unit_n,'(E12.3)',advance='no') zeig%coh%rld(1)
+
+ CASE ('geff')
+ WRITE(unit_n,'(E12.3)',advance='no') zeig%coh%geff
+
+ CASE ('gfol')
+ WRITE(unit_n,'(E12.3)',advance='no') zeig%coh%gfol
+
+ CASE ('gfrt')
+ WRITE(unit_n,'(E12.3)',advance='no') zeig%coh%gfrt
+
+ CASE ('grossass')
+ WRITE(unit_n,'(E12.3)',advance='no') zeig%coh%grossass
+
+ CASE ('gsap')
+ WRITE(unit_n,'(E12.3)',advance='no') zeig%coh%gsap
+
+ CASE ('gsd')
+ WRITE(unit_n,'(I12)',advance='no') zeig%coh%ndaysgr
+
+ CASE ('hbo')
+ WRITE(unit_n,'(E12.3)',advance='no') zeig%coh%x_hbole
+
+ CASE ('hea')
+ WRITE(unit_n,'(I12)',advance='no') zeig%coh%x_health
+
+ CASE ('hei')
+ WRITE(unit_n,'(E12.3)',advance='no') zeig%coh%height
+
+ CASE ('hrt')
+ WRITE(unit_n,'(E12.3)',advance='no') zeig%coh%x_hrt
+
+ CASE ('leaf')
+ WRITE(unit_n,'(E12.3)',advance='no') zeig%coh%t_leaf
+
+ CASE ('maintres')
+ WRITE(unit_n,'(E12.3)',advance='no') zeig%coh%maintres
+
+ CASE ('nas')
+ WRITE(unit_n,'(E12.3)',advance='no') zeig%coh%netass
+
+ CASE ('npp')
+ WRITE(unit_n,'(E12.3)',advance='no') zeig%coh%npp
+
+ CASE ('Ndemc_c')
+ WRITE(unit_n,'(E12.3)',advance='no') zeig%coh%Ndemc_c
+
+ CASE ('Nuptc_c')
+ WRITE(unit_n,'(E12.3)',advance='no') zeig%coh%Nuptc_c
+
+ CASE ('Nfol')
+ WRITE(unit_n,'(E12.3)',advance='no') zeig%coh%N_fol
+
+ CASE ('Npool')
+ WRITE(unit_n,'(E12.3)',advance='no') zeig%coh%N_pool
+
+ CASE ('Nstr')
+ if(zeig%coh%Ndemc_c.ne.0) then
+ help = zeig%coh%Nuptc_c / zeig%coh%Ndemc_c
+ else
+ help = zeig%coh%Nuptc_c
+! help = 1
+ end if
+ WRITE(unit_n,'(E12.3)',advance='no') help
+
+ CASE ('rdpt')
+ WRITE(unit_n,'(E12.3)',advance='no') zeig%coh%x_rdpt
+
+ CASE ('rooteff')
+ WRITE(unit_n,'(F12.4)',advance='no') zeig%coh%rooteff(1)
+
+ CASE ('sap')
+ WRITE(unit_n,'(E12.3)',advance='no') zeig%coh%x_sap
+
+ CASE ('sfol')
+ WRITE(unit_n,'(E12.3)',advance='no') zeig%coh%sfol
+
+ CASE ('sfrt')
+ WRITE(unit_n,'(E12.3)',advance='no') zeig%coh%sfrt
+
+ CASE ('spn')
+ WRITE(unit_n,'(I12)',advance='no') zeig%coh%species
+
+ CASE ('ssap')
+ WRITE(unit_n,'(E12.3)',advance='no') zeig%coh%ssap
+
+ CASE ('stem')
+ WRITE(unit_n,'(E12.3)',advance='no') zeig%coh%stem_inc
+
+ CASE ('str')
+ WRITE(unit_n,'(I12)',advance='no') zeig%coh%x_stress
+
+ CASE ('tdb')
+ WRITE(unit_n,'(E12.3)',advance='no') zeig%coh%dbio
+
+ CASE ('trman')
+ WRITE(unit_n,'(I12)',advance='no') int(zeig%coh%ntreem)
+
+ CASE ('toplayer')
+ WRITE(unit_n,'(I12)',advance='no') zeig%coh%topLayer
+
+ CASE ('ttb')
+ WRITE(unit_n,'(E12.3)',advance='no') zeig%coh%totbio
+
+ CASE ('watleft')
+ WRITE(unit_n,'(F12.4)',advance='no') zeig%coh%watleft
+
+ CASE ('yrw')
+ WRITE(unit_n,'(F12.4)',advance='no') zeig%coh%jrb
+
+ end select
+
+ lflag = .TRUE.
+ exit
+
+ ELSE
+ zeig => zeig%next
+ END IF
+
+ END DO
+
+ if (.not. lflag) WRITE(unit_n,'(F12.3)',advance='no') -99.9
+
+ END DO !j
+
+ WRITE(unit_n,'(A)') ''
+
+ select CASE (outcy(i)%kind_name)
+ CASE ('frtrel')
+ do k=2,nroot_max
+ WRITE(unit_n ,'(I2,3X)',advance='no') k
+ do j= 1,max_coh
+ zeig => pt%first
+ lflag = .FALSE.
+ do while (associated(zeig))
+ if (zeig%coh%ident .eq. j) then
+ WRITE(unit_n,'(E12.3)',advance='no') zeig%coh%frtrel(k)
+ lflag = .TRUE.
+ exit
+ ELSE
+ zeig => zeig%next
+ END IF
+ END DO ! zeig
+ if (.not. lflag) WRITE(unit_n,'(F12.3)',advance='no') -99.9
+ END DO ! j
+ WRITE(unit_n,'(A)') ''
+ END DO ! k
+ WRITE(unit_n,'(A)') ''
+
+ CASE ('frtrelc')
+ do k=2,nroot_max
+ WRITE(unit_n ,'(I2,3X)',advance='no') k
+ do j= 1,max_coh
+ zeig => pt%first
+ lflag = .FALSE.
+ do while (associated(zeig))
+ if (zeig%coh%ident .eq. j) then
+ WRITE(unit_n,'(E12.3)',advance='no') zeig%coh%frtrelc(k)
+ lflag = .TRUE.
+ exit
+ ELSE
+ zeig => zeig%next
+ END IF
+ END DO ! zeig
+ if (.not. lflag) WRITE(unit_n,'(F12.3)',advance='no') -99.9
+ END DO ! j
+ WRITE(unit_n,'(A)') ''
+ END DO ! k
+ WRITE(unit_n,'(A)') ''
+
+ CASE ('rld')
+ if (flag_wred .eq. 9) then
+ do k=2,nroot_max
+ WRITE(unit_n ,'(I2,3X)',advance='no') k
+ do j= 1,max_coh
+ zeig => pt%first
+ lflag = .FALSE.
+ do while (associated(zeig))
+ if (zeig%coh%ident .eq. j) then
+ WRITE(unit_n,'(E12.3)',advance='no') zeig%coh%rld(k)
+ lflag = .TRUE.
+ exit
+ ELSE
+ zeig => zeig%next
+ END IF
+ END DO ! zeig
+ if (.not. lflag) WRITE(unit_n,'(F12.3)',advance='no') -99.9
+ END DO ! j
+ WRITE(unit_n,'(A)') ''
+ END DO ! k
+ endif
+ WRITE(unit_n,'(A)') ''
+
+ CASE ('rooteff')
+ do k=2,nroot_max
+ WRITE(unit_n ,'(I2,3X)',advance='no') k
+ do j= 1,max_coh
+ zeig => pt%first
+ lflag = .FALSE.
+ do while (associated(zeig))
+ if (zeig%coh%ident .eq. j) then
+ WRITE(unit_n,'(F12.4)',advance='no') zeig%coh%rooteff(k)
+ lflag = .TRUE.
+ exit
+ ELSE
+ zeig => zeig%next
+ END IF
+ END DO ! zeig
+ if (.not. lflag) WRITE(unit_n,'(F12.4)',advance='no') -99.9
+ END DO ! j
+ WRITE(unit_n,'(A)') ''
+ END DO ! k
+ WRITE(unit_n,'(A)') ''
+ end select
+
+ endif ! out_flag
+ enddo !i
+END subroutine coh_out_y
+
+!**************************************************************
+
+SUBROUTINE out_wpm (flagout)
+
+use data_out
+use data_simul
+use data_wpm
+
+implicit none
+
+ integer flagout ! control of output
+ ! 0 - no output
+ ! 1 - output at end of simulation
+ integer i,j,k
+ integer unit_n ! output unit
+
+ integer dummy
+ dummy = 0.
+
+! output of all selected files
+do j = 1,oute_n
+ if (oute(j)%out_flag .eq. flagout) then
+ unit_n = oute(j)%unit_nr
+
+ select CASE (oute(j)%kind_name)
+
+ CASE ('sea')
+ do i=1,size(years)
+ write(unit_n, '(I6, 30F10.2)') &
+ years(i), &
+ sum_costs(1,i), &
+ sum_costs(2,i), &
+ sum_costs(3,i), &
+ sum_costs(4,i), &
+ fix(2)-fix(1), &
+ sum_costs(5,i), &
+ st_costs(1,i), &
+ st_costs(2,i), &
+ st_costs(3,i), &
+ st_costs(4,i), &
+ st_costs(5,i), &
+ st_assets(1,i), &
+ st_assets(2,i), &
+ st_assets(3,i), &
+ st_assets(4,i), &
+ st_assets(5,i), &
+ ms_costs(1,i), &
+ ms_costs(2,i), &
+ ms_costs(3,i), &
+ ms_costs(4,i), &
+ ms_costs(5,i), &
+ ms_assets(1,i), &
+ ms_assets(2,i), &
+ ms_assets(3,i), &
+ ms_assets(4,i), &
+ ms_assets(5,i), &
+ fix(1), &
+ subsidy(1,i), &
+ subsidy(1,i), &
+ fix(2)
+ end do
+ case ('sea_npv')
+ do i=1,size(years)
+ write(unit_n, '(I6, 12F10.2)') &
+ years(i), &
+ npv(1,i), &
+ npv(2,i), &
+ npv(3,i), &
+ npv(4,i), &
+ npv(5,i), &
+ npv(6,i), &
+ npv(7,i), &
+ npv(8,i), &
+ npv(9,i), &
+ npv(10,i), &
+ npv(11,i), &
+ npv(12,i)
+ end do
+ CASE ('sea_ms')
+ do i=1,size(years)
+ write(unit_n, '(I6,43E10.3)') &
+ years(i), &
+ mansort_tg(1,1,i), &
+ mansort_tg(1,2,i), &
+ mansort_tg(1,3,i), &
+ mansort_tg(1,6,i), &
+ mansort_tg(1,7,i), &
+ mansort_tg(1,8,i), &
+ mansort_tg(1,9,i), &
+ mansort_tg(1,10,i), &
+ mansort_tg(2,1,i), &
+ mansort_tg(2,2,i), &
+ mansort_tg(2,4,i), &
+ mansort_tg(2,5,i), &
+ mansort_tg(2,6,i), &
+ mansort_tg(2,7,i), &
+ mansort_tg(2,8,i), &
+ mansort_tg(2,9,i), &
+ mansort_tg(2,10,i), &
+ mansort_tg(3,1,i), &
+ mansort_tg(3,2,i), &
+ mansort_tg(3,3,i), &
+ mansort_tg(3,4,i), &
+ mansort_tg(3,5,i), &
+ mansort_tg(3,6,i), &
+ mansort_tg(3,7,i), &
+ mansort_tg(3,8,i), &
+ mansort_tg(3,9,i), &
+ mansort_tg(3,10,i), &
+ mansort_tg(4,1,i), &
+ mansort_tg(4,2,i), &
+ mansort_tg(4,5,i), &
+ mansort_tg(4,6,i), &
+ mansort_tg(4,7,i), &
+ mansort_tg(4,8,i), &
+ mansort_tg(4,9,i), &
+ mansort_tg(4,10,i), &
+ mansort_tg(5,1,i), &
+ mansort_tg(5,2,i), &
+ mansort_tg(5,5,i), &
+ mansort_tg(5,6,i), &
+ mansort_tg(5,7,i), &
+ mansort_tg(5,8,i), &
+ mansort_tg(5,9,i), &
+ mansort_tg(5,10,i)
+ end do
+
+ CASE ('sea_st')
+ do i=1,size(years)
+ write(unit_n, '(I6,43E10.3)') &
+ years(i), &
+ standsort_tg(1,1,i), &
+ standsort_tg(1,2,i), &
+ standsort_tg(1,5,i), &
+ standsort_tg(1,6,i), &
+ standsort_tg(1,7,i), &
+ standsort_tg(1,8,i), &
+ standsort_tg(1,9,i), &
+ standsort_tg(1,10,i), &
+ standsort_tg(2,1,i), &
+ standsort_tg(2,2,i), &
+ standsort_tg(2,4,i), &
+ standsort_tg(2,5,i), &
+ standsort_tg(2,6,i), &
+ standsort_tg(2,7,i), &
+ standsort_tg(2,8,i), &
+ standsort_tg(2,9,i), &
+ standsort_tg(2,10,i), &
+ standsort_tg(3,1,i), &
+ standsort_tg(3,2,i), &
+ standsort_tg(3,3,i), &
+ standsort_tg(3,4,i), &
+ standsort_tg(3,5,i), &
+ standsort_tg(3,6,i), &
+ standsort_tg(3,7,i), &
+ standsort_tg(3,8,i), &
+ standsort_tg(3,9,i), &
+ standsort_tg(3,10,i), &
+ standsort_tg(4,1,i), &
+ standsort_tg(4,2,i), &
+ standsort_tg(4,5,i), &
+ standsort_tg(4,6,i), &
+ standsort_tg(4,7,i), &
+ standsort_tg(4,8,i), &
+ standsort_tg(4,9,i), &
+ standsort_tg(4,10,i), &
+ standsort_tg(5,1,i), &
+ standsort_tg(5,2,i), &
+ standsort_tg(5,5,i), &
+ standsort_tg(5,6,i), &
+ standsort_tg(5,7,i), &
+ standsort_tg(5,8,i), &
+ standsort_tg(5,9,i), &
+ standsort_tg(5,10,i)
+ end do
+
+ CASE ('wpm')
+ do i=1,size(years)
+ write(unit_n, '(I6,13E10.3, 1E11.3, 3E10.3)') &
+ years(i), &
+ sum_input(i), &
+ use_categories(1)%value(i), &
+ use_categories(2)%value(i), &
+ use_categories(3)%value(i), &
+ use_categories(4)%value(i), &
+ use_categories(5)%value(i), &
+ use_categories(6)%value(i), &
+ use_categories(7)%value(i), &
+ sum_use_cat(i), &
+ burning(i), &
+ landfill(i), &
+ atmo_year(i), &
+ atmo_cum(i), &
+ emission_har(i), &
+ sub_energy(i), &
+ sub_material(i), &
+ sub_sum(i)
+ end do
+
+ CASE ('wpm_inter')
+ do i=1,size(years)
+ write(unit_n, '(I6,27E10.3)') &
+ years(i), &
+ pl(1,1,i), &
+ pl(1,2,i), &
+ pl(1,3,i), &
+ pl(1,4,i), &
+ pl(1,5,i), &
+ pl(1,7,i), &
+ pl(2,1,i), &
+ pl(2,2,i), &
+ pl(2,3,i), &
+ pl(2,4,i), &
+ pl(2,5,i), &
+ pl(2,6,i), &
+ pl(2,7,i), &
+ pl(3,1,i), &
+ pl(3,2,i), &
+ pl(3,3,i), &
+ pl(3,4,i), &
+ pl(3,5,i), &
+ pl(3,6,i), &
+ pl(3,7,i), &
+ use_cat(1,i), &
+ use_cat(2,i), &
+ use_cat(3,i), &
+ use_cat(4,i), &
+ use_cat(5,i), &
+ use_cat(6,i), &
+ use_cat(7,i)
+ end do
+
+ end select
+ endif
+enddo
+
+end subroutine out_wpm
+
+!**************************************************************
+
+SUBROUTINE out_scen
+USE data_simul
+USE data_out
+IMPLICIT NONE
+
+WRITE (unit_ctr,*) ip,' ',deltaT,deltaPrec
+
+END subroutine out_scen
+
+!**************************************************************
+
+SUBROUTINE out_comp(unit_comp)
+
+! final result output for each run
+
+USE data_biodiv
+USE data_climate
+USE data_depo
+USE data_evapo
+USE data_inter
+USE data_manag
+USE data_out
+USE data_par
+USE data_simul
+USE data_site
+USE data_soil
+USE data_soil_cn
+USE data_species
+USE data_stand
+USE data_climate
+USE data_frost
+
+IMPLICIT NONE
+
+integer unit_comp
+integer help1, i
+real, dimension(31) :: help2
+real hconv ! conversion factor from patchsize into ha
+! output variables of final results in kg/ha
+real y_NPP, & ! mean net primary productioin
+ y_GPP, & ! mean yearly gross productioin
+ y_NEP, & ! mean yearly net ecosystem productioin
+ y_sumbio, & ! total biomass of all cohorts and all tree-species
+ y_sumbio_sv,& ! total biomass of all cohorts and all ground-vegetation-species
+ y_autresp, & ! mean yearly total autotroph resp
+ y_resps, & ! mean yearly soil respiration
+ y_resptot, & ! mean yearly total respiration
+ y_C_accu, & ! mean yearly C accumualtion
+ y_RedN, & ! mean RedN of all species
+ y_lai ! LAI of stand without soil vegetation
+real C_sum ! total C storage of the stand (biomass and soil)
+real help_gdd
+character(20) idtext, datei
+character(150) htext
+character(1) aa
+
+call wclas(waldtyp)
+hconv = 10000./kpatchsize
+y_NPP = cum_sumNPP * hconv * cpart/year ! kg DW/patch --> kg C/ha
+y_sumbio = sumbio / 1000. ! kg DW / ha --> t DW/ha
+y_sumbio_sv = sumbio_sv / 1000. ! kg DW / ha --> t DW/ha
+totfol = totfol / 1000. ! kg / ha --> t/ha
+totsap = totsap / 1000. ! kg / ha --> t/ha
+totfrt = totfrt / 1000. ! kg / ha --> t/ha
+tothrt = tothrt / 1000. ! kg / ha --> t/ha
+totcrt = totcrt / 1000. ! kg / ha --> t/ha
+tottb = tottb / 1000. ! kg / ha --> t/ha
+y_C_accu = (C_tot - C_accu) * gm2_in_kgha / year ! g C/m2 --> kg C/ha, mean
+C_lit_m = C_lit_m * gm2_in_kgha / year ! g/m2 --> kg/ha, mean
+N_lit_m = N_lit_m * gm2_in_kgha / year ! g/m2 --> kg/ha, mean
+N_min_m = N_min_m * gm2_in_kgha / year ! g/m2 --> kg/ha, mean
+Nupt_m = Nupt_m * gm2_in_kgha / year ! g/m2 --> kg/ha, mean
+Nleach_m = Nleach_m * gm2_in_kgha / year ! g/m2 --> kg/ha, mean
+y_resps = resps_c_m * gm2_in_kgha / year ! g C/m2 --> kg C/ha, mean
+y_autresp = autresp_m * cpart * hconv / year
+y_resptot = y_resps + y_autresp
+y_GPP = y_NPP + y_autresp
+y_NEP = y_NPP - y_resps ! kg C/ha
+y_NPP = y_NPP / 1000. ! kg C /ha --> t C/ha
+dew_m = dew_m / year
+AET_m = AET_m / year
+pet_m = pet_m / year
+interc_m_can = interc_m_can / year
+perc_m = perc_m / year
+wupt_r_m = wupt_r_m / year
+C_opm_stem = C_opm_stem * gm2_in_kgha / 1000. ! g C/m2 --> t C/ha
+if (.not.lcomp1) C_tot = SUM(C_opm) + SUM(C_hum) ! calculated again (litter at the end)
+C_tot = C_tot * gm2_in_kgha / 1000. ! g C/m2 --> t C/ha
+C_hum_tot = C_hum_tot * gm2_in_kgha / 1000. ! g C/m2 --> t C/ha
+med_air_all = med_air_all / year
+
+med_rad_all = med_rad_all / year
+mean_drIndAl = mean_drIndAl / year
+help_gdd = gdday_all / year
+sum_prec_all = sum_prec_all / year
+Ndep_cum_all = Ndep_cum_all * gm2_in_kgha / year ! g/m2 --> kg/ha, mean
+C_sum = C_tot + (sumbio + cumsumvsab + cumsumvsdead) * cpart / 1000. ! corrected due to C_opm_stem already in cumsumvsdead
+if(fire_indb_m.gt.0) then
+ fire_indb_m = fire_indb_m / year ! fire index Bruschek
+end if
+fire(2)%mean_m = fire(2)%mean_m / year ! fire index east (Kaese M68)
+fire(3)%mean_m = fire(3)%mean_m / year
+cwb_an_m = cwb_an_m / year
+
+ind_arid_an_m = ind_arid_an_m / year
+ind_lang_an_m = ind_lang_an_m / year
+ind_cout_an_m = ind_cout_an_m / year
+ind_wiss_an_m = ind_wiss_an_m / year
+ind_mart_an_m = ind_mart_an_m / year
+ind_weck_m = ind_weck_m / year
+ind_reich_m = ind_reich_m / year
+ind_emb_m = ind_emb_m / year
+con_gor_m = con_gor_m / year
+con_cur_m = con_cur_m / year
+con_con_m = con_con_m / year
+
+ind_bud_m = ind_bud_m / year
+ind_shc_m = ind_shc_m / year
+
+if(time.gt.1) call frost_index_total
+
+ntindex =0.
+if(time.gt.1) then
+ tempmean_mo = tempmean_mo/year
+ call t_indices(tempmean_mo)
+end if
+
+y_lai = 0.
+y_RedN = 0.
+do i = 1, nspec_tree
+ y_lai = y_lai + svar(i)%sum_lai
+end do
+if (anz_RedN .gt. 0) y_RedN = RedN_mean / anz_RedN
+
+select case (flag_multi)
+
+case (4,5,8)
+ write (datei, '(A10)') adjustl(sitenum(ip)) ! standip can occur variable times, this ensures clear indetification
+ read (datei, '(A)') idtext
+
+case default
+ htext = adjustr(site_name(ip))
+ idtext = adjustl(htext (131:150)) ! only write last 20 signs
+
+end select
+
+if(thin_dead .ne. 0) then
+ cumsumvsab = cumsumvsdead
+ cumsumvsdead = 0.
+end if
+
+if (time .le. 1) then
+ aa = 'B'
+else
+ aa = 'E'
+endif
+
+if(flag_end .eq.0) then
+ write (unit_comp, '(A, I5,1X, A20,F6.2,I7,I4,F9.2,E10.3, 8F9.2, F11.3, E11.3, 4E11.4, 3F8.2,4F10.2, F9.1, F9.3, 4F10.1, 7F7.1, 2F9.3, F9.1, 3F10.2, &
+ 7(1X,F9.2), E12.4, F8.2, 5F10.2, F8.2, 3F8.3,3X, 3f8.2)') &
+ aa, ip, idtext, y_lai, anz_tree_ha, waldtyp, y_sumbio, y_sumbio_sv, med_diam, hdom, totfol,tottb,totsap,tothrt,totfrt,totcrt, &
+ y_NPP, y_NEP, y_GPP, cumsteminc, cumsumvsab, cumsumvsdead, C_sum, C_opm_stem, C_tot, C_hum_tot,C_tot_40,C_hum_40, &
+ y_C_accu, C_lit_m, N_lit_m, N_min_m, Nleach_m, y_resps, y_resptot, pet_m, AET_m, perc_m, interc_m_can, wupt_r_m, med_air_all, &
+ sum_prec_all, Ndep_cum_all, mean_drIndAl, help_gdd, cwb_an_m, fire(2)%mean_m, fire_indb_m, ind_arid_an_m, ind_lang_an_m, ind_cout_an_m, &
+ ind_wiss_an_m, ind_mart_an_m, ind_weck_m, ind_reich_m, ind_emb_m, con_gor_m, con_cur_m, con_con_m, ntindex, fire(3)%mean_m, ind_bud_m, med_rad_all, y_RedN, dew_m, Nupt_m, mlfind, mlfind_sp, ind_shc_m
+else
+ help1 = 0
+ help2 = 0.0
+ write (unit_comp, '(A, I5,1X, A15,F6.2,I7,I4, 8F9.2, 6E11.4, 3F8.2, 3F10.2, F9.1, F9.3, 2F10.1, 6F7.1, F9.3)') &
+ aa, ip, idtext, help2(1), help1, help1, (help2(i), i=1,31)
+end if
+
+END subroutine out_comp
+
+!**************************************************************
+
+SUBROUTINE error_mess(ti,mess,val)
+
+USE data_out
+USE data_simul
+USE data_site
+
+IMPLICIT NONE
+
+INTEGER,intent(in) :: ti
+CHARACTER(LEN=*),intent(in) :: mess
+real,intent(in) :: val
+
+if (flag_multi .ne. 5) then
+ write (unit_err, *)
+ write (unit_err, '(A8,I5,1X, A20, A10,I5)') 'ip/site ', ip, stand_id, ' Year ',ti
+ write(unit_err,'(A)',advance='no') trim(mess)
+ write(unit_err,*) val
+endif
+
+END subroutine error_mess
+
+!**************************************************************
+
+SUBROUTINE stop_mess(ti,mess)
+
+USE data_out
+
+IMPLICIT NONE
+
+INTEGER,intent(in) :: ti
+CHARACTER(LEN=*),intent(in) :: mess
+
+WRITE(*,*) 'Program aborted in simulation year ',ti
+WRITE(*,*) trim(mess)
+WRITE(*,*) 'see error.log for reason'
+
+END subroutine stop_mess
+
+!**************************************************************
+
+SUBROUTINE open_file (varout, help_ip)
+
+! Open special output file
+
+USE data_simul
+USE data_out
+
+IMPLICIT NONE
+
+TYPE (out_struct) :: varout
+INTEGER help_ip
+
+CHARACTER(150) ::filename ! complete name of output file
+
+filename = trim(site_name(help_ip))//'_'//trim(varout%kind_name)//'.out'//trim(anh)
+
+varout%unit_nr = getunit()
+
+open(varout%unit_nr,file=trim(dirout)//filename,status='replace')
+
+END subroutine open_file
+
+!**************************************************************
+
+SUBROUTINE wr_header_file (varout)
+
+! Write header of special output file
+
+USE data_simul
+USE data_out
+
+IMPLICIT NONE
+
+TYPE (out_struct) :: varout
+
+INTEGER unit_n ! output unit
+
+unit_n = varout%unit_nr
+WRITE(unit_n ,'(A)') trim(varout%f_line)
+WRITE(unit_n ,'(A)') trim(varout%s_line)
+WRITE(unit_n ,'(A)') trim(varout%header)
+
+END subroutine wr_header_file
+
+!**************************************************************
+
+SUBROUTINE outveg (nsp, out_flag, unit_n)
+
+! output of species values (files veg_species)
+
+ USE data_climate
+ USE data_simul
+ USE data_species
+ USE data_stand
+ USE data_out
+
+ IMPLICIT NONE
+
+ integer:: nsp ! species number
+ integer:: out_flag ! output flag
+ integer:: unit_n ! output unit
+ real :: dumvar=0.
+
+ if (out_flag .eq. 1) then
+
+ sout(nsp)%help_veg1(1) = nsp
+ sout(nsp)%help_veg1(2) = svar(nsp)%anz_coh
+ sout(nsp)%help_veg1(3) = svar(nsp)%sum_nTreeA
+
+ sout(nsp)%help_veg2(1) = svar(nsp)%sum_lai
+ sout(nsp)%help_veg2(2) = svar(nsp)%sum_bio
+ sout(nsp)%help_veg2(3) = svar(nsp)%sumNPP
+ sout(nsp)%help_veg2(4) = svar(nsp)%med_diam
+ sout(nsp)%help_veg2(5) = svar(nsp)%dom_height
+ sout(nsp)%help_veg2(6) = svar(nsp)%fol
+ sout(nsp)%help_veg2(7) = svar(nsp)%sap
+ sout(nsp)%help_veg2(8) = svar(nsp)%frt
+ sout(nsp)%help_veg2(9) = svar(nsp)%hrt
+ sout(nsp)%help_veg2(10)= svar(nsp)%totsteminc
+ sout(nsp)%help_veg2(11)= svar(nsp)%totstem_m3
+ sout(nsp)%help_veg3 = svar(nsp)%crown_area/kpatchsize
+ sout(nsp)%help_veg4 = svar(nsp)%sumvsdead*10000/kpatchsize
+ sout(nsp)%help_veg5 = svar(nsp)%sumvsdead_m3*10000/kpatchsize
+ sout(nsp)%help_veg6 = svar(nsp)%totsteminc_m3
+
+ out_flag = 2
+ else if (out_flag .eq. 2) then
+ WRITE(unit_n,'(I6)',advance='no') time_cur
+ WRITE(unit_n,'(3I10)',advance='no') sout(nsp)%help_veg1
+ WRITE(unit_n,'(F10.3,2E12.3,2F12.3,9E12.3, 4F12.3, I6, F6.0,3F12.3, 3F12.4)') sout(nsp)%help_veg2, svar(nsp)%sumvsab, sout(nsp)%help_veg4, &
+ sout(nsp)%help_veg3, svar(nsp)%drIndAl, svar(nsp)%Ndem, svar(nsp)%Nupt, svar(nsp)%RedNm, &
+ svar(nsp)%daybb, spar(nsp)%end_bb, svar(nsp)%mean_diam, svar(nsp)%mean_height, svar(nsp)%basal_area, sout(nsp)%help_veg5,sout(nsp)%help_veg6, svar(nsp)%mean_jrb
+ out_flag = 1
+ endif
+
+END SUBROUTINE outveg
+
+!**************************************************************
+
+SUBROUTINE outstore
+
+! store of output variables (multi run 4 and 8)
+USE data_climate
+USE data_depo
+USE data_evapo
+USE data_inter
+USE data_manag
+USE data_out
+USE data_par
+USE data_simul
+USE data_soil
+USE data_soil_cn
+USE data_stand
+USE data_biodiv
+USE data_frost
+
+IMPLICIT NONE
+
+real C_sum, & ! total C storage of the stand (biomass and soil)
+ hconv, help
+integer i, j, k, ipp
+
+if (flag_trace) write (unit_trace, '(I4,I10,A)') iday, time_cur, ' outstore '
+
+ if (flag_mult910) then
+ ipp = 1
+ else
+ ipp = ip
+ endif
+
+ hconv = 10000./kpatchsize
+ do i = 1, nvar-1
+
+ select case (trim(outvar(i)))
+
+ case('above_biom')
+ output_var(i,ipp,time)=(sumbio-totfrt-totcrt)/1000.
+
+ case ('AET','aet')
+ output_var(i,ipp,time) = AET_cum
+
+ case ('AET_year','AETyear','aetyear','aet_year') ! AET
+ outvar(i) = 'AET_year'
+ output_var(i,ipp,time) = AET_cum
+
+ case ('AET_mon','AETmon','aetmon','aet_mon') ! monthly AET
+ outvar(i) = 'AET_mon'
+ k = output_var(i,1,0)
+ do j = 1, 12
+ output_varm(k,ipp,time,j) = AET_mon(j)
+ enddo
+
+ case ('AET_week','AETweek','aetweek','aet_week') ! weekly AET
+ outvar(i) = 'AET_week'
+ k = output_var(i,1,0)
+ do j = 1, 52
+ output_varw(k,ipp,time,j) = AET_week(j)
+ enddo
+
+ case ( 'anzdlf') ! number of days with forst April - June
+ output_var(i,ipp,time) = anzdlf(time)
+
+ case ( 'BA') ! basal area
+ output_var(i,ipp,time) = basal_area
+
+
+ case ('C_accu','Caccu','c_accu') ! C accumulation per year
+ if (time .eq. 1) then
+ help = C_tot - C_accu
+ else
+ help = C_tot - C_accu
+ do j = 1, time-1
+ help = help - output_var(i,ipp,j)*1000.*kgha_in_gm2
+ end do
+ endif
+ output_var(i,ipp,time) = help * gm2_in_kgha / 1000. ! g C/m2 --> t C/ha
+
+ case ('C_d_stem','c_d_stem')
+ output_var(i,ipp,time) = C_opm_stem * gm2_in_kgha / 1000.
+
+ case ('chumtot','Chumtot','C_hum_tot') ! total C in humus
+ output_var(i,ipp,time) = C_hum_tot * gm2_in_kgha / 1000. ! g C/m2 --> t C/ha
+
+ case('con_gor')
+ output_var(i,ipp,time)=con_gor
+
+ case('con_cur')
+ output_var(i,ipp,time)=con_cur
+
+ case('con_con')
+ output_var(i,ipp,time)=con_con
+
+ case ('ctot','Ctot','C_tot') ! total soil C
+ output_var(i,ipp,time) = C_tot * gm2_in_kgha / 1000. ! g C/m2 --> t C/ha
+
+ case ('csum','Csum','C_sum') ! total C in ecosystem
+ output_var(i,ipp,time) = C_tot*gm2_in_kgha/1000. + (sumbio + cumsumvsab + cumsumvsdead) * cpart / 1000. ! t/ha
+
+ case('cwb') ! climatic water balance
+ output_var(i,ipp,time)=cwb_an
+
+ case ('cwbyear','cwb_year') ! climatic water balance
+ outvar(i) = 'cwb_year'
+ output_var(i,ipp,time)=cwb_an
+
+ case ('cwbmon','cwb_mon') ! monthly climatic water balance
+ outvar(i) = 'cwb_mon'
+ k = output_var(i,1,0)
+ do j = 1, 12
+ output_varm(k,ipp,time,j) = prec_mon(j) - pet_mon(j)
+ enddo
+
+ case ('cwbweek','cwb_week') ! weekly climatic water balance
+ outvar(i) = 'cwb_week'
+ k = output_var(i,1,0)
+ do j = 1, 52
+ output_varw(k,ipp,time,j) = prec_week(j) - pet_week(j)
+ enddo
+
+ case ( 'date_lf') ! number of the day with the last late frost
+ output_var(i,ipp,time) = date_lf(time)
+
+ case ( 'date_lft') ! number of the day with the last late frost
+ output_var(i,ipp,time) = date_lftot(time)
+
+ case('daybb_be')
+ output_var(i,ipp,time)= svar(1)%daybb
+
+ case('daybb_oa')
+ output_var(i,ipp,time)= svar(4)%daybb
+
+ case('daybb_bi')
+ output_var(i,ipp,time)= svar(5)%daybb
+
+ case ('dbh')
+ output_var(i,ipp,time) = mean_diam
+
+ case ('dens') ! stem density
+ output_var(i,ipp,time) = anz_tree_ha
+
+ case ('dnlf') ! number of frost days after start of vegetation period
+ output_var(i,ipp,time) = dnlf(time)
+
+ case ('dnlf_sp') ! number of frost days after bud burst
+ output_var(i,ipp,time) = dnlf_sp(time)
+
+ case ('drindal', 'drIndAl', 'drIndal', 'DrIndAl') ! drought index for allocation calculation (cum.) for the whole stand [-], weighted by NPP
+ output_var(i,ipp,time) = drIndAl
+
+ case ('fire_indb')
+ output_var(i,ipp,time) = fire_indb
+
+ case ('fire_ind1')
+ output_var(i,ipp,time) = fire(1)%mean
+
+ case ('fire_ind2')
+ output_var(i,ipp,time) = fire(2)%mean
+
+ case ('fire_ind3')
+ output_var(i,ipp,time) = fire(3)%mean
+
+ case ('fire_ind1_c1')
+ output_var(i,ipp,time) = fire(1)%frequ(1)
+
+ case ('fire_ind1_c2')
+ output_var(i,ipp,time) = fire(1)%frequ(2)
+
+ case ('fire_ind1_c3')
+ output_var(i,ipp,time) = fire(1)%frequ(3)
+
+ case ('fire_ind1_c4')
+ output_var(i,ipp,time) = fire(1)%frequ(4)
+
+ case ('fire_ind1_c5')
+ output_var(i,ipp,time) = fire(1)%frequ(5)
+
+ case ('fire_ind2_c1')
+ output_var(i,ipp,time) = fire(2)%frequ(1)
+
+ case ('fire_ind2_c2')
+ output_var(i,ipp,time) = fire(2)%frequ(2)
+
+ case ('fire_ind2_c3')
+ output_var(i,ipp,time) = fire(2)%frequ(3)
+
+ case ('fire_ind2_c4')
+ output_var(i,ipp,time) = fire(2)%frequ(4)
+
+ case ('fire_ind2_c5')
+ output_var(i,ipp,time) = fire(2)%frequ(5)
+
+ case ('fire_ind3_c1')
+ output_var(i,ipp,time) = fire(3)%frequ(1)
+
+ case ('fire_ind3_c2')
+ output_var(i,ipp,time) = fire(3)%frequ(2)
+
+ case ('fire_ind3_c3')
+ output_var(i,ipp,time) = fire(3)%frequ(3)
+
+ case ('fire_ind3_c4')
+ output_var(i,ipp,time) = fire(3)%frequ(4)
+
+ case ('fire_ind3_c5')
+ output_var(i,ipp,time) = fire(3)%frequ(5)
+
+ case('fortyp') ! forest type classified
+ call wclas(waldtyp)
+ output_var(i,ipp,time) = waldtyp
+
+ case ('gpp','GPP') ! yearly GPP
+ output_var(i,ipp,time) = sumGPP * hconv/100. ! g C/patch --> t C/ha
+
+ case ('GPP_year','GPPyear','gppyear','gpp_year') ! GPP for each year
+ outvar(i) = 'GPP_year'
+ output_var(i,ipp,time) = sumGPP * hconv/100. ! g C/patch --> t C/ha
+
+ case ('GPP_mon','GPPmon','gppmon','gpp_mon') ! monthly GPP
+ outvar(i) = 'GPP_mon'
+ k = output_var(i,1,0)
+ do j = 1, 12
+ output_varm(k,ipp,time,j) = GPP_mon(j) * hconv/100. ! g C/patch --> t C/ha
+ enddo
+
+ case ('GPP_week','GPPweek','gppweek','gpp_week') ! weekly GPP
+ outvar(i) = 'GPP_week'
+ k = output_var(i,1,0)
+ do j = 1, 52
+ output_varw(k,ipp,time,j) = GPP_week(j) * hconv/100. ! g C/patch --> t C/ha
+ enddo
+
+ case ('height')
+ output_var(i,ipp,time) = hdom
+
+ case ('iday_vp') ! yearly canopy interception
+ output_var(i,ipp,time) = iday_vegper
+
+ case('ind_arid')
+ output_var(i,ipp,time)=ind_arid_an
+
+ case('ind_cout')
+ output_var(i,ipp,time)=ind_cout_an
+
+ case('ind_emb')
+ output_var(i,ipp,time)=ind_emb
+
+ case('ind_lang')
+ output_var(i,ipp,time)=ind_lang_an
+
+ case('ind_mart')
+ output_var(i,ipp,time)=ind_mart_an
+
+ case('ind_reich')
+ output_var(i,ipp,time)=ind_reich
+
+ case('ind_weck')
+ output_var(i,ipp,time)=ind_weck
+
+ case('ind_wiss')
+ output_var(i,ipp,time)=ind_wiss_an
+
+ case ('int','interc') ! yearly canopy interception
+ output_var(i,ipp,time) = int_cum_can
+
+ case ('lai','LAI')
+ output_var(i,ipp,time) = LAImax
+
+ case ('NEE_mon','NEEmon','neemon','nee_mon') ! monthly NEP
+ outvar(i) = 'NEE_mon'
+ k = output_var(i,1,0)
+ do j = 1, 12
+ output_varm(k,ipp,time,j) = NEE_mon(j) ! g C/m²
+ enddo
+
+ case ('NEP', 'nep')
+ outvar(i) = 'NEP'
+ output_var(i,ipp,time) = sumNPP * hconv * cpart/1000. - resps_c * gm2_in_kgha/1000. ! kg DW/patch --> t C/ha
+
+ case ('NEP_year','NEPyear','nepyear','nep_year') ! NEP of each year
+ outvar(i) = 'NEP_year'
+ output_var(i,ipp,time) = sumNPP * hconv * cpart/1000. - resps_c * gm2_in_kgha/1000. ! kg DW/patch --> t C/ha
+
+ case ('NEP_mon','NEPmon','nepmon','nep_mon') ! monthly NEP
+ outvar(i) = 'NEP_mon'
+ k = output_var(i,1,0)
+ do j = 1, 12
+ output_varm(k,ipp,time,j) = NPP_mon(j) * hconv/100. - resps_mon(j) * gm2_in_kgha/1000. ! kg C/patch --> t C/ha
+ enddo
+
+ case ('NEP_week','NEPweek','nepweek','nep_week') ! weekly NPP
+ outvar(i) = 'NEP_week'
+ k = output_var(i,1,0)
+ do j = 1, 52
+ output_varw(k,ipp,time,j) = NPP_week(j) * hconv/100. - resps_week(j) * gm2_in_kgha/1000. ! g C/patch --> t C/ha
+ enddo
+
+ case ('ndep','Ndep','N_dep') ! yearly N deposition
+ output_var(i,ipp,time) = Ndep_cum ! g N/m2
+
+ case('nleach', 'Nleach', 'N_leach') ! Annual N leaching kg N/ha
+ output_var(i,ipp,time) = N_min * gm2_in_kgha ! g/m2 --> kg/ha, mean
+
+ case ('nmin','Nmin','N_min') ! yearly N mineralization
+ output_var(i,ipp,time) = N_min * gm2_in_kgha ! g/m2 --> kg/ha, mean
+
+ case ('npp','NPP') ! NPP
+ output_var(i,ipp,time) = sumNPP * hconv * cpart/1000. ! kg DW/patch --> t C/ha
+
+ case ('NPP_year','NPPyear','nppyear','npp_year') ! NPP of each year
+ outvar(i) = 'NPP_year'
+ output_var(i,ipp,time) = sumNPP * hconv * cpart/1000. ! kg DW/patch --> t C/ha
+
+ case ('NPP_mon','NPPmon','nppmon','npp_mon') ! monthly NPP
+ outvar(i) = 'NPP_mon'
+ k = output_var(i,1,0)
+ do j = 1, 12
+ output_varm(k,ipp,time,j) = NPP_mon(j) * hconv/100. ! g C/patch --> t C/ha
+ enddo
+
+ case ('NPP_week','NPPweek','nppweek','npp_week') ! weekly NPP
+ outvar(i) = 'NPP_week'
+ k = output_var(i,1,0)
+ do j = 1, 52
+ output_varw(k,ipp,time,j) = NPP_week(j) * hconv/100. ! g C/patch --> t C/ha
+ enddo
+
+ case ('NTI', 'nti','NTindex','ntindex') ! Nonnen-Temperatur-Index
+ output_var(i,ipp,time) = ntindex
+
+ case ('perc') ! yearly percolation
+ output_var(i,ipp,time) = perc_cum
+
+ case ('perc_year') ! yearly percolation
+ outvar(i) = 'perc_year'
+ output_var(i,ipp,time) = perc_cum
+
+ case ('perc_mon', 'percmon') ! monthly percolation
+ outvar(i) = 'perc_mon'
+ k = output_var(i,1,0)
+ do j = 1, 12
+ output_varm(k,ipp,time,j) = perc_mon(j)
+ enddo
+
+ case ('perc_week', 'percweek') ! weekly percolation
+ outvar(i) = 'perc_week'
+ k = output_var(i,1,0)
+ do j = 1, 52
+ output_varw(k,ipp,time,j) = perc_week(j)
+ enddo
+
+ case ('PET','pet') ! potential evapotranspiration sum
+ output_var(i,ipp,time) = PET_cum
+
+ case ('PET_year','PETyear','pet_year','petyear') ! potential evapotranspiration sum of each year
+ outvar(i) = 'PET_year'
+ output_var(i,ipp,time) = PET_cum
+
+ case ('PET_mon','PETmon','pet_mon','petmon') ! monthly potential evapotranspiration sum
+ outvar(i) = 'PET_mon'
+ k = output_var(i,1,0)
+ do j = 1, 12
+ output_varm(k,ipp,time,j) = PET_mon(j)
+ enddo
+
+ case ('PET_week','PETweek','pet_week','petweek') ! weekly potential evapotranspiration sum
+ outvar(i) = 'PET_week'
+ k = output_var(i,1,0)
+ do j = 1, 52
+ output_varw(k,ipp,time,j) = PET_week(j)
+ enddo
+
+ case ('prec') ! yearly precipitation
+ output_var(i,ipp,time) = sum_prec
+
+ case ('prec_year', 'precyear') ! precipitation sum of each year
+ outvar(i) = 'prec_year'
+ output_var(i,ipp,time) = sum_prec
+
+ case ('prec_mon', 'precmon') ! monthly precipitation sum
+ outvar(i) = 'prec_mon'
+ k = output_var(i,1,0)
+ do j = 1, 12
+ output_varm(k,ipp,time,j) = prec_mon(j)
+ enddo
+
+ case ('prec_week', 'precweek') ! weekly precipitation sum
+ outvar(i) = 'prec_week'
+ k = output_var(i,1,0)
+ do j = 1, 52
+ output_varw(k,ipp,time,j) = prec_week(j)
+ enddo
+
+ case ('resps','respsoil') ! yearly soil respiration
+ outvar(i) = 'resps'
+ output_var(i,ipp,time) = resps_c * gm2_in_kgha ! g C/m2 --> kg C/ha, mean
+
+ case ('resps_year', 'respsyear') ! soil respiration of each year
+ outvar(i) = 'resps_year'
+ output_var(i,ipp,time) = resps_c * gm2_in_kgha ! g C/m2 --> kg C/ha, mean
+
+ case ('resps_mon', 'respsmon') ! monthly soil respiration
+ outvar(i) = 'resps_mon'
+ k = output_var(i,1,0)
+ do j = 1, 12
+ output_varm(k,ipp,time,j) = resps_mon(j) * gm2_in_kgha ! g C/m2 --> kg C/ha
+ enddo
+
+ case ('resps_week', 'respsweek') ! weekly soil respiration
+ outvar(i) = 'resps_week'
+ k = output_var(i,1,0)
+ do j = 1, 52
+ output_varw(k,ipp,time,j) = resps_week(j) * gm2_in_kgha ! g C/m2 --> kg C/ha
+ enddo
+
+ case('steminc')
+ output_var(i,ipp,time)= totsteminc/1000.
+
+ case ('sumbio') ! Biomass
+ output_var(i,ipp,time) = sumbio / 1000. ! kg DW / ha --> t DW/ha
+
+ case ('sumtlf') ! temperature sum of days with frost April - June
+ output_var(i,ipp,time) = sumtlf(time)
+
+ case ('temp') ! airtemp
+ output_var(i,ipp,time) = med_air
+
+ case ('temp_year', 'tempyear') ! mean yearly air temperature
+ outvar(i) = 'temp_year'
+ output_var(i,ipp,time) = med_air
+
+ case ('temp_mon', 'tempmon') ! mean monthly air temperature
+ outvar(i) = 'temp_mon'
+ k = output_var(i,1,0)
+ do j = 1, 12
+ output_varm(k,ipp,time,j) = temp_mon(j) ! Mittelung erfolgt schon in daily (/ monrec(j))
+ enddo
+
+ case ('temp_week', 'tempweek') ! mean weekly air temperature
+ outvar(i) = 'temp_week'
+ k = output_var(i,1,0)
+ do j = 1, 52
+ output_varw(k,ipp,time,j) = temp_week(j) / 7.
+ enddo
+
+ case ('TER','ter') ! yearly TER
+ outvar(i) = 'TER'
+ output_var(i,ipp,time) = sumTER * hconv/100. ! g C/patch --> t C/ha
+
+ case ('TER_year','TERyear','teryear','ter_year') ! yearly TER
+ outvar(i) = 'TER_year'
+ output_var(i,ipp,time) = sumTER * hconv/100. ! g C/patch --> t C/ha
+
+ case ('TER_mon','TERmon','termon','ter_mon') ! monthly TER
+ outvar(i) = 'TER_mon'
+ k = output_var(i,1,0)
+ do j = 1, 12
+ output_varm(k,ipp,time,j) = TER_mon(j) * hconv/100. ! g C/patch --> t C/ha
+ enddo
+
+ case ('TER_week','TERweek','terweek','ter_week') ! weekly TER
+ outvar(i) = 'TER_week'
+ k = output_var(i,1,0)
+ do j = 1, 52
+ output_varw(k,ipp,time,j) = TER_week(j) * hconv/100. ! g C/patch --> t C/ha
+ enddo
+
+ case('totstem')
+ output_var(i,ipp,time)= totstem_m3
+
+ case('vsab')
+ output_var(i,ipp,time)= sumvsab_m3
+
+ case('vsdead')
+ output_var(i,ipp,time)= sumvsdead_m3
+
+ end select
+ enddo
+END SUBROUTINE outstore
+
+!**************************************************************
+
+SUBROUTINE out_var_file
+
+! writing of output variables (multi run 4 and 8)
+ use data_biodiv
+ use data_out
+ use data_simul
+ use data_site
+
+ IMPLICIT NONE
+
+ integer i, ii, j, k, unit_nr
+ real varerr
+ character(50) :: filename ! complete name of output file
+ character(15) idtext, datei
+ real, dimension(12) :: helpf
+ real, dimension(52) :: helpw
+ character(30) :: helpvar
+
+if (flag_trace) write (unit_trace, '(I4,I10,A)') iday, time_cur, ' out_var_file '
+
+ do i = 1, nvar-1
+
+ helpvar = outvar(i)
+ call out_var_select(helpvar, varerr, unit_nr)
+
+ if (varerr .ne. 0.) then
+ select case (trim(outvar(i)))
+ case ('AET_week','cwb_week','GPP_week','NEP_week','NPP_week','perc_week','PET_week','temp_week','TER_week','prec_week','resps_week')
+ write (unit_nr, '(A)') '# Site Week1 Week2 Week3 Week4 Week5 Week6 Week7 Week8 Week9 &
+ Week10 Week11 Week12 Week13 Week14 Week15 Week16 Week17 Week18 Week19 &
+ Week20 Week21 Week22 Week23 Week24 Week25 Week26 Week27 Week28 Week29 &
+ Week30 Week31 Week32 Week33 Week34 Week35 Week13 Week37 Week38 Week39 &
+ Week40 Week41 Week42 Week43 Week44 Week45 Week46 Week47 Week48 Week49 &
+ Week50 Week51 Week52'
+ do ip = 1, site_nr
+ write (datei, '(A10)') adjustl(sitenum(ip))
+ read (datei, '(A)') idtext
+ write (unit_nr, '(A15)', advance = 'no') idtext
+ ii = output_var(i,1,0)
+ helpw = 0.
+ do k = 1, 52
+ do j = 1, year
+ helpw(k) = helpw(k) + output_varw(ii,ip,j,k)
+ enddo
+ helpw(k) = helpw(k) / year
+ enddo
+ write (unit_nr, '(52(E12.4))', advance = 'no') helpw
+ write (unit_nr, '(A)') ''
+ enddo
+
+ case ('AET_mon','cwb_mon','GPP_mon','NEP_mon','NPP_mon','perc_mon','PET_mon','temp_mon','TER_mon','prec_mon','resps_mon')
+ write (unit_nr, '(A)') '# Site Mean1 Mean2 Mean3 Mean 4&
+ Mean5 Mean6 Mean7 Mean8 Mean9 Mean10 Mean11 Mean12'
+ do ip = 1, site_nr
+ write (datei, '(A10)') adjustl(sitenum(ip))
+ read (datei, '(A)') idtext
+ write (unit_nr, '(A15)', advance = 'no') idtext
+ ii = output_var(i,1,0)
+ helpf = 0.
+ do k = 1, 12
+ do j = 1, year
+ helpf(k) = helpf(k) + output_varm(ii,ip,j,k)
+ enddo
+ helpf(k) = helpf(k) / year
+ enddo
+ write (unit_nr, '(12(E12.4))', advance = 'no') helpf
+ write (unit_nr, '(A)') ''
+ enddo
+
+ case default
+ write (unit_nr, '(A)') '# Site Year 1 Year 2 Year 3 Year 4 Year 5 ...'
+ do ip = 1, site_nr
+ write (datei, '(A10)') adjustl(sitenum(ip))
+ read (datei, '(A)') idtext
+ write (unit_nr, '(A15)', advance = 'no') idtext
+ do j = 1, year
+ write (unit_nr, '(E12.4)', advance = 'no') output_var(i,ip,j)
+ enddo
+ write (unit_nr, '(A)') ''
+ enddo
+ end select
+ else
+ write (*,*)
+ write (*,*) '*** 4C-error - output of variables (out_var_file): ', trim(outvar(i)), ' not found'
+ write (*,*)
+ write (unit_err,*)
+ write (unit_err,*) '*** 4C-error - no such output variable (out_var_file): ', trim(outvar(i))
+ endif
+ close(unit_nr)
+ enddo
+END SUBROUTINE out_var_file
+
+!**************************************************************
+
+SUBROUTINE out_var_select(varout, varerr, unit_nr)
+
+! selection of output variables and open files (multi run 4, 8, 9)
+ use data_biodiv
+ use data_out
+ use data_simul
+ use data_site
+
+ IMPLICIT NONE
+
+ integer unit_nr
+ real varerr
+ character(50) :: filename ! complete name of output file
+ character(30) :: varout
+ character(15) idtext, datei
+
+if (flag_trace) write (unit_trace, '(I4,I10,A,F6.0,I4)') iday, time_cur, ' out_var_select '//varout, varerr, unit_nr
+
+ filename = trim(site_name1)//'_'//trim(varout)//'.out'
+ unit_nr = getunit()
+ open(unit_nr,file=trim(dirout)//filename,status='replace')
+ write (unit_nr, '(A)') '# Output of '//varout
+ varerr = 0.
+
+ select case (trim(varout))
+
+ case('anzdlf')
+ write(unit_nr, '(A)') '# number of days with frost April - June'
+ varerr = 1
+
+ case ('AET','aet')
+ write (unit_nr, '(A)') '# Yearly actual evapotranspiration sum / mm'
+ varerr = 1.
+
+ case ('AET_year')
+ write (unit_nr, '(A)') '# Annual actual evapotranspiration sum / mm'
+ varerr = 1.
+
+ case ('AET_mon','aet_mon','AETmon','aetmon')
+ write (unit_nr, '(A)') '# Monthly actual evapotranspiration sum / mm'
+ varerr = 1.
+
+ case ('AET_week','aet_week','AETweek','aetweek')
+ write (unit_nr, '(A)') '# Weekly actual evapotranspiration sum / mm'
+ varerr = 1.
+
+ case('above_biom')
+ write(unit_nr,'(A)') '# Total aboveground biomass / t DW/ha'
+ varerr = 1.
+
+ case('BA')
+ write(unit_nr,'(A)') '# Basal arera m²'
+ varerr = 1.
+
+ case ('C_accu','Caccu','c_accu') ! C accumulation per year
+ write (unit_nr, '(A)') '# Soil carbon accumulation per year / t C/ha'
+ varerr = 1.
+
+ case ('C_d_stem','c_d_stem') ! C accumulation per year
+ write (unit_nr, '(A)') '# carbon in dead trees / t C/ha'
+ varerr = 1.
+
+ case ('C_hum_tot','C_humtot','chumtot','Chumtot') ! total soil C
+ write (unit_nr, '(A)') '# Total carbon in humus / t C/ha'
+ varerr = 1.
+
+ case ('C_sum','csum','Csum') ! total C in ecosystem
+ write (unit_nr, '(A)') '# Total carbon in ecosystem / t C/ha'
+ varerr = 1.
+
+ case ('C_tot','ctot','Ctot') ! total soil C
+ write (unit_nr, '(A)') '# Total carbon in soil / t C/ha'
+ varerr = 1.
+
+ case('con_gor')
+ write(unit_nr,'(A)') '# Continentality index Gorczynski'
+ varerr = 1.
+
+ case('con_cur')
+ write(unit_nr,'(A)') '# Continentality index Currey'
+ varerr = 1.
+
+ case('con_con')
+ write(unit_nr,'(A)') '# Continentality index Conrad'
+ varerr = 1.
+
+ case('cwb_year','cwb')
+ write(unit_nr,'(A)') '# Annual climate water balance'
+ varerr = 1.
+
+ case('cwb_mon')
+ write(unit_nr,'(A)') '# Monthly climate water balance'
+ varerr = 1.
+
+ case('cwb_week')
+ write(unit_nr,'(A)') '# Weekly climate water balance'
+ varerr = 1.
+
+ case('date_lf')
+ write(unit_nr, '(A)') '# number of day of last late frost after start of vegetation period'
+ varerr = 1
+
+ case('date_lft')
+ write(unit_nr, '(A)') '# number of day of last late frost'
+ varerr = 1
+
+ case('daybb_be')
+ write(unit_nr,'(A)') '# Day of bud burst beech'
+ varerr = 1.
+
+ case('daybb_bi')
+ write(unit_nr,'(A)') '# Day of bud burst betula'
+ varerr = 1.
+
+ case('daybb_oa')
+ write(unit_nr,'(A)') '# Day of bud burst oak'
+ varerr = 1.
+
+ case ('dbh') ! mean DBH
+ write (unit_nr, '(A)') '# DBH / cm'
+ varerr = 1.
+
+ case ('dens') ! stem density /ha
+ write (unit_nr, '(A)') '# Stem density per ha'
+ varerr = 1.
+
+ case('dnlf')
+ write(unit_nr, '(A)') '# number of frost days since start of vegetation period'
+ varerr = 1.
+
+ case('dnlf_sp')
+ write(unit_nr, '(A)') '# number of frost days since start of bud burst'
+ varerr = 1.
+
+ case ('drindal','drIndAl','drIndal','DrIndAl') ! drought index for allocation calculation (cum.) for the whole stand [-], weighted by NPP
+ write (unit_nr, '(A)') '# Drought index for allocation calculation'
+ varerr = 1.
+
+ case ('fire_indb')
+ write (unit_nr, '(A)') '# Fire index Bruschek'
+ varerr = 1.
+
+ case ('fire_ind1')
+ write (unit_nr, '(A)') '# Fire index west'
+ varerr = 1.
+
+ case ('fire_ind2')
+ write (unit_nr, '(A)') '# Fire index east'
+ varerr = 1.
+
+ case ('fire_ind3')
+ write (unit_nr, '(A)') '# Fire index Nesterov'
+ varerr = 1.
+
+ case ('fire_ind1_c1')
+ write (unit_nr, '(A)') '# Fire index west class 1'
+ varerr = 1.
+
+ case ('fire_ind1_c2')
+ write (unit_nr, '(A)') '# Fire index west class 2'
+ varerr = 1.
+
+ case ('fire_ind1_c3')
+ write (unit_nr, '(A)') '# Fire index west class 3'
+ varerr = 1.
+
+ case ('fire_ind1_c4')
+ write (unit_nr, '(A)') '# Fire index west class 4'
+ varerr = 1.
+
+ case ('fire_ind1_c5')
+ write (unit_nr, '(A)') '# Fire index west class 5'
+ varerr = 1.
+
+ case ('fire_ind2_c1')
+ write (unit_nr, '(A)') '# Fire index east class 1'
+ varerr = 1.
+
+ case ('fire_ind2_c2')
+ write (unit_nr, '(A)') '# Fire index east class 2'
+ varerr = 1.
+
+ case ('fire_ind2_c3')
+ write (unit_nr, '(A)') '# Fire index east class 3'
+ varerr = 1.
+
+ case ('fire_ind2_c4')
+ write (unit_nr, '(A)') '# Fire index east class 4'
+ varerr = 1.
+
+ case ('fire_ind2_c5')
+ write (unit_nr, '(A)') '# Fire index east class 5'
+ varerr = 1.
+
+ case ('fire_ind3_c1')
+ write (unit_nr, '(A)') '# Fire index Nesterov class 1'
+ varerr = 1.
+
+ case ('fire_ind3_c2')
+ write (unit_nr, '(A)') '# Fire index Nesterov class 2'
+ varerr = 1.
+
+ case ('fire_ind3_c3')
+ write (unit_nr, '(A)') '# Fire index Nesterov class 3'
+ varerr = 1.
+
+ case ('fire_ind3_c4')
+ write (unit_nr, '(A)') '# Fire index Nesterov class 4'
+ varerr = 1.
+
+ case ('fire_ind3_c5')
+ write (unit_nr, '(A)') '# Fire index Nesterov class 5'
+ varerr = 1.
+
+ case ('fortyp')
+ write (unit_nr, '(A)') '# Forest classification'
+ varerr = 1.
+
+ case ('GPP') ! GPP
+ write (unit_nr, '(A)') '# Yearly gross primary production / t C/ha'
+ varerr = 1.
+
+ case ('GPP_year') ! GPP
+ write (unit_nr, '(A)') '# Annual gross primary production / t C/ha'
+ varerr = 1.
+
+ case ('GPP_mon') ! monthly GPP
+ write (unit_nr, '(A)') '# Monthly gross primary production / t C/ha'
+ varerr = 1.
+
+ case ('GPP_week') ! weekly GPP
+ write (unit_nr, '(A)') '# Weekly gross primary production / t C/ha'
+ varerr = 1.
+
+ case ('height') ! height, in this case dominant height
+ write (unit_nr, '(A)') '# Height / cm'
+ varerr = 1.
+
+ case ('iday_vp')
+ write (unit_nr, '(A)') '# start day of vegetation period'
+ varerr = 1.
+
+ case('ind_arid')
+ write(unit_nr,'(A)') '# Aridity index (UNEP)'
+ varerr = 1.
+
+ case('ind_lang')
+ write(unit_nr,'(A)') '# Climate index Lang'
+ varerr = 1.
+
+ case('ind_cout')
+ write(unit_nr,'(A)') '# Climate index Coutange'
+ varerr = 1.
+
+ case('ind_emb')
+ write(unit_nr,'(A)') '# Climate index Emberger'
+ varerr = 1.
+
+ case('ind_mart')
+ write(unit_nr,'(A)') '# Climate index Martonne'
+ varerr = 1.
+
+ case('ind_reich')
+ write(unit_nr,'(A)') '# Climate index Reichel'
+ varerr = 1.
+
+ case('ind_weck')
+ write(unit_nr,'(A)') '# Climate index Weck'
+ varerr = 1.
+
+ case('ind_wiss')
+ write(unit_nr,'(A)') '# Climate index v. Wissmann'
+ varerr = 1.
+
+ case ('int','interc') ! yearly canopy interception
+ write (unit_nr, '(A)') '# Yearly canopy interception / mm'
+ varerr = 1.
+
+ case ('lai','LAI') ! yearly canopy interception
+ write (unit_nr, '(A)') '# Maximum LAI '
+ varerr = 1.
+
+ case ('N_dep','ndep','Ndep') ! yearly N deposition
+ write (unit_nr, '(A)') '# Yearly N deposition / g N/m2'
+ varerr = 1.
+
+ case('N_leach', 'nleach', 'Nleach')
+ write(unit_nr,'(A)') '# Annual N leaching kg N/ha'
+ varerr = 1.
+
+ case ('N_min','nmin','Nmin') ! yearly N mineralization
+ write (unit_nr, '(A)') '# Yearly N mineralization / kg N/ha'
+ varerr = 1.
+
+ case ('nep','NEP') ! NEP
+ write (unit_nr, '(A)') '# Yearly net ecosystem production / t C/ha'
+ varerr = 1.
+
+ case ('NEP_year') ! NEP
+ write (unit_nr, '(A)') '# Annual net ecosystem production / t C/ha'
+ varerr = 1.
+
+ case ('NEP_mon') ! monthly NEP
+ write (unit_nr, '(A)') '# Monthly net ecosystem production / t C/ha'
+ varerr = 1.
+
+ case ('NEP_week') ! weekly NEP
+ write (unit_nr, '(A)') '# Weekly net ecosystem production / t C/ha'
+ varerr = 1.
+
+ case ('NPP','npp') ! NPP
+ write (unit_nr, '(A)') '# Yearly net primary production / t C/ha'
+ varerr = 1.
+
+ case ('NPP_year') ! NPP of each year
+ write (unit_nr, '(A)') '# Annual net primary production / t C/ha'
+ varerr = 1.
+
+ case ('NPP_mon') ! monthly NPP
+ write (unit_nr, '(A)') '# Monthly net primary production / t C/ha'
+ varerr = 1.
+
+ case ('NPP_week') ! weekly NPP
+ write (unit_nr, '(A)') '# Weekly net primary production / t C/ha'
+ varerr = 1.
+
+ case ('NTI', 'nti','NTindex','ntindex') ! Nonnen-Temperatur-Index
+ write (unit_nr, '(A)') '# Nun temperature index'
+ varerr = 1.
+
+ case ('perc') ! yearly percolation
+ write (unit_nr, '(A)') '# Yearly percolation / mm'
+ varerr = 1.
+
+ case ('perc_year') ! yearly percolation
+ write (unit_nr, '(A)') '# Annual percolation / mm'
+ varerr = 1.
+
+ case ('perc_mon', 'percmon') ! monthly percolation
+ write (unit_nr, '(A)') '# Monthly percolation / mm'
+ varerr = 1.
+
+ case ('perc_week', 'percweek') ! weekly percolation
+ write (unit_nr, '(A)') '# Weekly percolation / mm'
+ varerr = 1.
+
+ case ('PET','pet') ! PET
+ write (unit_nr, '(A)') '# Yearly potential evapotranspiration / mm'
+ varerr = 1.
+
+ case ('PET_year') ! PET
+ write (unit_nr, '(A)') '# Annual potential evapotranspiration / mm'
+ varerr = 1.
+
+ case ('PET_mon') ! PET
+ write (unit_nr, '(A)') '# Monthly potential evapotranspiration / mm'
+ varerr = 1.
+
+ case ('PET_week') ! PET
+ write (unit_nr, '(A)') '# Weekly potential evapotranspiration / mm'
+ varerr = 1.
+
+ case ('prec') ! yearly precipitation
+ write (unit_nr, '(A)') '# Yearly precipitation sum / mm'
+ varerr = 1.
+
+ case ('prec_year') ! yearly precipitation
+ write (unit_nr, '(A)') '# Annual precipitation sum / mm'
+ varerr = 1.
+
+ case ('prec_mon', 'precmon') ! monthly precipitation sum
+ write (unit_nr, '(A)') '# Monthly precipitation sum / mm'
+ varerr = 1.
+
+ case ('prec_week', 'precweek') ! weekly precipitation sum
+ write (unit_nr, '(A)') '# Weekly precipitation sum / mm'
+ varerr = 1.
+
+ case ('resps', 'respsoil') ! yearly soil respiration
+ write (unit_nr, '(A)') '# Yearly soil respiration / kg C/ha'
+ varerr = 1.
+
+ case ('resps_year') ! yearly soil respiration
+ write (unit_nr, '(A)') '# Annual soil respiration / kg C/ha'
+ varerr = 1.
+
+ case ('resps_mon', 'respsmon') ! monthly soil respiration
+ write (unit_nr, '(A)') '# Monthly soil respiration / kg C/ha'
+ varerr = 1.
+
+ case ('resps_week', 'respsweek') ! Weekly soil respiration
+ write (unit_nr, '(A)') '# Weekly soil respiration / kg C/ha'
+ varerr = 1.
+
+ case('steminc')
+ write(unit_nr,'(A)') '# Total annual stem increment t/ha'
+ varerr = 1.
+
+ case ('sumbio') ! Biomass
+ write (unit_nr, '(A)') '# Total Biomass / t DW/ha'
+ varerr = 1.
+
+ case('sumtlf')
+ write(unit_nr, '(A)') '# temperature sum of minimum temperature < 0 April - June'
+ varerr = 1
+
+ case ('temp') ! airtemp
+ write (unit_nr, '(A)') '# Mean yearly air temperature / °C'
+ varerr = 1.
+
+ case ('temp_year') ! airtemp
+ write (unit_nr, '(A)') '# Mean annual air temperature / °C'
+ varerr = 1.
+
+ case ('temp_mon', 'tempmon') ! mean monthly air temperature
+ write (unit_nr, '(A)') '# Mean monthly air temperature / °C'
+ varerr = 1.
+
+ case ('temp_week', 'tempweek') ! mean weekly air temperature
+ write (unit_nr, '(A)') '# Mean weekly air temperature / °C'
+ varerr = 1.
+
+ case ('TER') ! TER
+ write (unit_nr, '(A)') '# Yearly total ecosystem respiration / t C/ha'
+ varerr = 1.
+
+ case ('TER_year') ! TER
+ write (unit_nr, '(A)') '# Annual total ecosystem respiration / t C/ha'
+ varerr = 1.
+
+ case ('TER_mon') ! monthly TER
+ write (unit_nr, '(A)') '# Monthly total ecosystem respiration / t C/ha'
+ varerr = 1.
+
+ case ('TER_week') ! weekly TER
+ write (unit_nr, '(A)') '# Weekly total ecosystem respiration / t C/ha'
+ varerr = 1.
+
+ case('totstem')
+ write(unit_nr,'(A)') '# Total annual stem volume m³/ha'
+ varerr = 1.
+
+ case('vsdead')
+ write(unit_nr,'(A)') '# Total annual dead stem volume m³/ha (not in the litter pool)'
+ varerr = 1.
+
+ case('vsab')
+ write(unit_nr,'(A)') '# Total annual harvested stem volume m³/ha'
+ varerr = 1.
+ end select
+END SUBROUTINE out_var_select
+
+!**************************************************************
diff --git a/source_code/version2.2_windows/partitio.f b/source_code/version2.2_windows/partitio.f
new file mode 100755
index 0000000000000000000000000000000000000000..0c7497ceca015b6333371e2580af3fb3fe02d312
--- /dev/null
+++ b/source_code/version2.2_windows/partitio.f
@@ -0,0 +1,765 @@
+!*****************************************************************!
+!* *!
+!* 4C (FORESEE) Simulation Model *!
+!* *!
+!* *!
+!* Subroutines for: *!
+!* - Calculation of annual allocation of NPP (SR PARTITION) *!
+!* - Calculation of annual allocation of NPP of soil *!
+!* vegetation (PARTITION_SV *!
+!* - Calculation of diameter at breast height (SR CALC_DBH) *!
+!* *!
+!* Copyright (C) 1996-2018 *!
+!* Potsdam Institute for Climate Impact Reserach (PIK) *!
+!* Authors and contributors see AUTHOR file *!
+!* This file is part of 4C and is licensed under BSD-2-Clause *!
+!* See LICENSE file or under: *!
+!* http://www.https://opensource.org/licenses/BSD-2-Clause *!
+!* Contact: *!
+!* https://gitlab.pik-potsdam.de/foresee/4C *!
+!* *!
+!*****************************************************************!
+
+!****************************!
+!* SUBROUTINE PARTITION *!
+!****************************!
+
+SUBROUTINE PARTITION( p )
+
+ !*** Declaration part ***!
+ USE data_out
+ USE data_par
+ USE data_stand
+ USE data_species
+ USE data_simul
+
+ IMPLICIT NONE
+
+ REAL :: lambdaf = 0., & ! partitioning functions
+ lambdas = 0., &
+ lambdar = 0., &
+ lambdac = 0., &
+ lambdaSum = 0.,& ! sum of the above three lambdas
+ NPP = 0., & ! annual NPP
+ F = 0., & ! state variables: foliage,
+ S = 0., & ! sapwood,
+ H = 0., & ! heartwood
+ R = 0., & ! fine roots,
+ B = 0., & ! bole height,
+ Ahb = 0., & ! cross sectional area heartwood at tree base
+ hs = 0., & ! sapwood height
+ Ht = 0., & ! total tree height
+ Asw = 0., & ! cross sectional area of sapwood in bole
+ DBH = 0., & ! tree diameter at breast height (DBH)
+ FNew, SNew, & ! new states
+ RNew, BNew, &
+ HtNew, &
+ HNew, Ahbnew, &
+ sigmaf = 0., & ! current leaf activity rate
+ sigman = 0., & ! current root activity rate
+ ar = 0., & ! aux vars for partitioning functions
+ as = 0., &
+ ac = 0., &
+ betar = 0., &
+ betas = 0., &
+ aux = 0., &
+ Fmax, & ! determines whether height growth or not
+ rsap, & ! auxiliary variable for height growth determination
+ growthrate ! height growthrate depends on relative light regime in the middle of the canopy
+ REAL :: Sf, & ! senescence rates
+ Ss, &
+ Sr, &
+ Gf, & ! growth rates
+ Gs, &
+ Gr
+ real :: DBH_help
+ REAL :: leaf_N_conc, & ! last years N concentration in leaves gN kgDM
+ tbc_root_Ndemand, & ! N demand for ghrowth of fine roots, branches and coarse roots g tree-1
+ Nredfak ! reduction factor for N allocation to fine roots, branches and coarse roots
+
+ TYPE(Coh_Obj) :: p ! pointer to cohort list
+
+ REAL :: term1, &
+ a1, a2, a3, & ! coefficients of quadratic equation
+ x1 = 0., &
+ x2 = 0. ! solutions of quadratic equation
+
+ real :: Fmax_old
+
+ ! if this cohort is mistletoe infected, reduce NPP by mistletoe-specific demand
+ ! demand is defined in PARTITION_MI. as mistletoe is always 1st cohort, the demand of mistletoe is calculated before the reduction here
+ if (p%coh%mistletoe.eq.1) then
+ p%coh%NPP = p%coh%NPP-(NPP_demand_mistletoe/p%coh%ntreea)
+ endif
+ ns = p%coh%species
+ F = p%coh%x_fol
+ Fmax = p%coh%Fmax
+ S = p%coh%x_sap
+ R = p%coh%x_frt
+ H = p%coh%x_hrt
+ B = p%coh%x_hbole
+ NPP = p%coh%NPP
+ Ht = p%coh%height
+ Ahb = p%coh%x_Ahb
+ Sf = p%coh%sfol
+ Ss = p%coh%ssap
+ Sr = p%coh%sfrt
+ hs = p%coh%x_hsap
+ Asw = p%coh%Asapw
+ Fmax_old = Fmax
+
+ DBH_help = p%coh%diam
+
+ if (flag_end.eq.1) then
+ p%coh%notViable = .TRUE.
+ flag_end = 0
+ end if
+
+if(p%coh%notViable.neqv..TRUE.) then
+ select case (flag_folhei)
+ case (1,4)
+ spar(ns)%pha = spar(ns)%pha_v1 * spar(ns)%pha_v3 * &
+ (F)**(-1-spar(ns)%pha_v3)/(spar(ns)%pha_v2+(F)**(-spar(ns)%pha_v3))**2.
+
+ case (2)
+
+ rsap=Asw/(Asw+Ahb)
+ spar(ns)%pha = 2.*spar(ns)%crown_a/(pi**0.5*(rsap*spar(ns)%pnus)**1.5*F**0.5)
+
+ case (3)
+ ! this version only for tests and pine trees
+ spar(ns)%pha = (3500*(10.+F**0.9)-(0.9*3500.*F**0.9))/(10.+F**0.9)**2
+
+ end select ! flag_folhei
+
+ ! only allocate if enough NPP is available
+ IF (NPP>1.0E-9) THEN
+
+ select case (flag_folhei)
+ case (0)
+ growthrate=spar(ns)%pha*spar(ns)%pha_coeff1 + spar(ns)%pha*spar(ns)%pha_coeff2*(1./p%coh%IrelCan-1.)
+
+ case (1,3)
+ growthrate=spar(ns)%pha + spar(ns)%pha*(1./MAX(p%coh%IrelCan,0.25)-1.)
+
+ case (2)
+ growthrate=spar(ns)%pha + spar(ns)%pha*(1.-p%coh%IrelCan)*5.
+
+ case (4)
+ growthrate=spar(ns)%pha *0.5/MAX(p%coh%IrelCan,0.25)
+
+ end select ! flag_folhei
+
+ sigmaf = NPP/F
+
+ ! calculate root activity based on drought index
+ ! test of a relationship which modifies fine root leaf ratio with shade tolerance:
+
+ IF (flag_sign.eq.1 .or. flag_sign.eq.11) THEN
+ term1 = spar(ns)%sigman * 10. * (((5.-spar(ns)%stol)*1.-p%coh%crown_area) / (5.-spar(ns)%stol)*1.)
+ sigman = amax1(term1,spar(ns)%sigman) * p%coh%drIndAl/p%coh%nDaysGr
+ ELSE
+ sigman = spar(ns)%sigman * p%coh%drIndAl / p%coh%nDaysGr
+ END IF
+
+ if (flag_sign .eq. 0 .or. flag_sign .eq. 1) then
+ ! auxiliary variables for fine roots
+ ar = spar(ns)%pcnr * sigmaf / sigman
+ betar = (Sr - R + ar*(F-Sf)) / NPP
+
+ ! auxiliary variables for sapwood
+ as = spar(ns)%prhos / spar(ns)%pnus
+ aux = 2.*(B+p%coh%deltaB) + Ht
+ betas = ( (as/3.)*(aux - growthrate*Sf) * (F-Sf) + Ss - S ) / NPP
+
+ ! solve quadratic equation for lambdaf
+ term1 = (1.+spar(ns)%alphac)
+ a1 = term1 * as/3. * growthrate * NPP
+ a2 = 1.0 + ar + term1 * as/3. * (aux + growthrate*(F-2.*Sf))
+ a3 = term1*betas + betar - 1.
+
+ x1 = (-a2 + SQRT( a2*a2 - 4.*a1*a3) ) / (2.*a1)
+ x2 = (-a2 - SQRT( a2*a2 - 4.*a1*a3) ) / (2.*a1)
+ lambdaf = x1
+
+ if (lambdaf .le. 0. .or. lambdaf .gt. 1.) then
+ lambdaf = 0.5
+ lambdar = 0.5
+ lambdas = 0.
+ lambdac = 0.
+ else
+
+ ! calculate coefficients for sapwood and roots
+ lambdar = ar * lambdaf + betar;
+ lambdas = as/3. * (aux + growthrate*(F+lambdaf*NPP-2.*Sf)) * lambdaf + betas
+ lambdac = spar(ns)%alphac * lambdas
+
+ ! check consistency of calculation, i.e. no negative values
+ IF(lambdas < 0. .or. lambdas .gt. 1.) THEN
+ lambdas = 0.
+ lambdac = 0.
+ lambdaf = (1.-betar)/(ar+1)
+ lambdar = 1.-lambdaf
+
+ if (lambdaf .le. 0. .or. lambdaf .gt. 1.) then
+ lambdaf = 0.5
+ lambdar = 0.5
+
+ else if (lambdar<0) then
+ lambdar=0.
+ lambdaf=1.
+ end if
+
+ ELSE
+ ! reduced allocation schemes for lamdaf<0. or lamdar<0. still to be added
+ lambdaf = AMAX1( lambdaf, 0. )
+ lambdar = AMAX1( lambdar, 0. )
+
+ ! warrant that lambdaSum = 1 if balance can not be achieved this time step
+ lambdaSum = lambdaf + (1.+spar(ns)%alphac)*lambdas + lambdar
+ lambdaf = lambdaf / lambdaSum
+ lambdas = lambdas / lambdaSum
+ lambdar = lambdar / lambdaSum
+ lambdac = lambdac / lambdaSum
+ lambdaSum = lambdaf + (1.+spar(ns)%alphac)*lambdas + lambdar ! for debugging only
+
+ END IF
+ end if ! lambdaf .le. 0.
+
+ else ! flag_sign = 10, 11
+ ! auxiliary variables for fine roots
+ ar = spar(ns)%pcnr * sigmaf / sigman
+ betar = (Sr - ar*Sf) / NPP
+
+ ! auxiliary variables for sapwood
+ as = spar(ns)%prhos / spar(ns)%pnus
+ betas = (Ss - 2.*as*hs*Sf ) / NPP
+
+ ! auxiliary variables for coarse roots, twigs and branches
+ ac = spar(ns)%alphac
+
+ ! linear equation system in lamda(i)
+ term1 = 1. + ar + 2.*as*hs*(1+ac)
+ lambdaf = 1. - (1.+ac)*betas - betar
+ lambdaf = lambdaf / term1
+ lambdar = ar * lambdaf + betar
+ lambdas = 2.*as*hs * lambdaf + betas
+ lambdac = ac * lambdas
+
+ if (lambdaf .le. 0. .or. lambdaf .gt. 1.) then
+ lambdaf = 0.5
+ lambdar = 0.5
+ lambdas = 0.
+ lambdac = ac * lambdas
+ else
+
+ ! calculate coefficients for sapwood and roots
+ lambdar = ar * lambdaf + betar;
+ lambdas = 2.*as*hs * lambdaf + betas
+ lambdac = ac * lambdas
+
+ ! check consistency of calculation, i.e. no negative values
+ IF(lambdas < 0. .or. lambdas .gt. 1.) THEN
+ lambdas = 0.
+ lambdac = 0.
+ lambdaf = (1.-betar)/(ar+1)
+ lambdar = 1.-lambdaf
+
+ if (lambdaf .le. 0. .or. lambdaf .gt. 1.) then
+ lambdaf = 0.5
+ lambdar = 0.5
+
+ else if (lambdar<0) then
+ lambdar=0.
+ lambdaf=1.
+ end if
+
+ ELSE
+ ! reduced allocation schemes for lamdaf<0. or lamdar<0. still to be added
+ lambdaf = AMAX1( lambdaf, 0. )
+ lambdar = AMAX1( lambdar, 0. )
+
+ ! warrant that lambdaSum = 1 if balance can not be achieved this time step
+ lambdaSum = lambdaf + (1.+spar(ns)%alphac)*lambdas + lambdar
+ lambdaf = lambdaf / lambdaSum
+ lambdas = lambdas / lambdaSum
+ lambdar = lambdar / lambdaSum
+ lambdac = lambdac / lambdaSum
+ lambdaSum = lambdaf + (1.+spar(ns)%alphac)*lambdas + lambdar ! for debugging only
+
+ END IF
+ end if ! lambdaf .le. 0.
+
+ endif ! flag_sign
+ ELSE
+
+ lambdaf = 0.
+ lambdas = 0.
+ lambdar = 0.
+
+ END IF ! IF NPP < 1.0E-09
+
+ ! gross growth rates of compartments
+ Gf = lambdaf * NPP
+ Gr = lambdar * NPP
+ Gs = lambdas * NPP
+ p%coh%gfol = Gf
+ p%coh%gfrt = Gr
+ p%coh%gsap = Gs
+ p%coh%x_crt = p%coh%x_crt + Gs*spar(ns)%alphac*spar(ns)%cr_frac
+ p%coh%x_tb = p%coh%x_tb + Gs*spar(ns)%alphac*(1.-spar(ns)%cr_frac)
+
+ ! update of state vector
+ FNew = F + Gf - Sf
+ SNew = S + Gs - Ss
+ RNew = R + Gr - Sr
+ Hnew = H + Ss
+ AhbNew= Ahb + Asw*spar(ns)%pss
+
+ ! check whether height growth or not
+
+ IF (lambdas == 0.OR.FNew<Fmax) THEN ! treat special case where there is no height growth
+ HtNew = Ht
+ ELSE
+ ! height growth depending on the relative light regime in the middle of the canopy
+ HtNew = Ht + growthrate * (FNew-Fmax)
+ Fmax=FNew
+ ENDIF
+ BNew = B+p%coh%deltaB
+
+ ! copy back to original variables
+ p%coh%Fmax = Fmax
+ p%coh%x_fol = FNew
+ p%coh%x_sap = SNew
+ p%coh%x_frt = RNew
+ p%coh%x_hrt = HNew
+ p%coh%height = HtNew
+ p%coh%x_hbole= BNew
+ p%coh%x_Ahb = AhbNew
+
+ CALL CALC_DBH(BNew,Htnew,Snew,Hnew,Ahbnew,p%coh%Ahc,p%coh%ident,DBH,p%coh%dcrb,hs,Asw)
+ if (flag_end.eq.1) then
+ DBH = p%coh%diam
+ p%coh%notViable = .TRUE.
+ flag_end = 0
+ end if
+
+ ! Monitoring of current values
+ if (time_out .gt. 0 .and. flag_cohout .eq. 2) then
+ CALL OUT_ALL( p%coh%ident, p%coh%ntreea, NPP, DBH, growthrate,Fnew,Fmax_old,Htnew, lambdaf,lambdas,lambdar,lambdac,x1,x2)
+ endif
+
+ p%coh%x_hsap = hs
+ p%coh%diam = DBH ! This is the new value
+ p%coh%Asapw = Asw
+
+ p%coh%jrb = (DBH-DBH_help)*10/2
+
+ if(((DBH-DBH_help)*10/2).lt.0.) p%coh%jrb = 0.
+
+ ! variables required by mortality submodel
+ p%coh%fol_inc = Gf - Sf
+ p%coh%bio_inc = NPP - Sf - (1.+spar(ns)%alphac)*Ss - Sr
+ p%coh%stem_inc = Gs ! deltaH + deltaS = Ss + Gs - Ss
+ p%coh%frt_inc = Gr - Sr ! fine root increment
+ p%coh%totBio = p%coh%x_fol + (1.+spar(ns)%alphac)*(p%coh%x_sap + p%coh%x_hrt) + p%coh%x_frt
+ p%coh%notViable = (FNew <= 0.) .OR. (SNew <= 0.) .OR. &
+ (RNew <= 0.) .OR. (Htnew <= Bnew)
+
+! Nitrogen dynamics:
+ leaf_N_conc = p%coh%N_fol/F
+
+! Simple model: all (sap)wood grows with CN-ratios of branches, twigs and coarse roots.
+! When sapwood senesces N is reallocated and the new heart wood is at the level of stem CN-ratios.
+! Branches, twigs and coarse roots do not senesce
+
+! first step nitrogen related processes: N in litter, N-recallocation
+ p%coh%N_pool = p%coh%N_pool + Sf/F*p%coh%N_fol*spar(ns)%reallo_fol &
+ + Sr*cpart/spar(ns)%cnr_frt*1000.* spar(ns)%reallo_frt &
+ + Ss*cpart *1000. * (1/spar(ns)%cnr_tbc - 1/spar(ns)%cnr_stem)
+ p%coh%N_fol = p%coh%N_fol*(1-Sf/F)
+
+ p%coh%litC_fol = p%coh%litC_fol + p%coh%ntreea * Sf * cpart
+ p%coh%litC_frt = p%coh%litC_frt + p%coh%ntreea * Sr * cpart
+
+ ! Species specific N content and reallocation factor (see species.par)
+ ! Caution: tbc mortallity is not a litter compartment; it is assigned as heartwood
+ p%coh%litN_fol = p%coh%litN_fol + p%coh%ntreea * Sf * cpart * (1.-spar(ns)%reallo_fol) / spar(ns)%cnr_fol
+ p%coh%litN_frt = p%coh%litN_frt + p%coh%ntreea * Sr * cpart * (1.-spar(ns)%reallo_frt) / spar(ns)%cnr_frt
+
+ ! second step: allocation of N to new growth
+ ! before bud-break allocation to leaves is 50% of the N content of last years foliage
+ tbc_root_Ndemand = Gs*cpart *kg_in_g / spar(ns)%cnr_tbc + Gr* cpart/spar(ns)%cnr_frt*kg_in_g
+ IF(tbc_root_Ndemand + Gf*p%coh%med_sla*0.5 > p%coh%N_pool) THEN
+ if (tbc_root_Ndemand .gt. 1E-8) then
+ Nredfak = AMAX1((p%coh%N_pool-Gf*p%coh%med_sla*0.5) / tbc_root_Ndemand,0.) ! Division by zero possible
+ else
+ Nredfak = 0.
+ endif
+ tbc_root_Ndemand = tbc_root_Ndemand*Nredfak
+ ENDIF
+ p%coh%N_pool = p%coh%N_pool - tbc_root_Ndemand
+ IF(p%coh%N_pool < Gf*0.5*leaf_N_conc) THEN
+ p%coh%N_fol = p%coh%N_fol + p%coh%N_pool
+ p%coh%N_pool = 0.
+ ELSE
+ p%coh%N_fol = p%coh%N_fol + Gf*0.5*leaf_N_conc
+ p%coh%N_pool = p%coh%N_pool - Gf*0.5*leaf_N_conc
+ ENDIF
+end if
+
+END SUBROUTINE PARTITION
+
+!*******************************!
+!* SUBROUTINE PARTITION_SV *!
+!*******************************!
+
+SUBROUTINE PARTITION_SV( p )
+
+ !*** Declaration part ***!
+ USE data_par
+ USE data_stand
+ USE data_species
+ USE data_simul
+
+ IMPLICIT NONE
+
+ REAL :: lambdaf = 0., & ! partitioning functions
+ lambdas = 0., &
+ lambdar = 0., &
+ NPP = 0., & ! annual NPP
+ F = 0., & ! state variables: foliage,
+ S = 0., & ! sapwood,
+ R = 0., & ! fine roots,
+ Ht = 0., & ! total tree height
+ FNew, SNew, & ! new states
+ RNew, &
+ sigmaf = 0., & ! current leaf activity rate
+ sigman = 0. ! current root activity rate
+ REAL :: Sf, & ! senescence rates
+ Ss, &
+ Sr, &
+ Gf, & ! growth rates
+ Gs, &
+ Gr
+
+ REAL :: FRsum
+
+ REAL :: tbc_root_Ndemand, & ! N demand for ghrowth of fine roots, branches and coarse roots g tree-1
+ Nredfak ! reduction factor for N allocation to fine roots, branches and coarse roots
+
+ REAL, EXTERNAL :: f_lf, df_lf, ddf_lf
+
+ INTEGER :: flag_SV_allo, &
+ rnum
+
+ TYPE(Coh_Obj) :: p ! pointer to cohort list
+
+ ns = p%coh%species
+ F = p%coh%x_fol
+ S = p%coh%x_sap
+ R = p%coh%x_frt
+ NPP = p%coh%NPP
+ Ht = p%coh%height
+ Sf = p%coh%sfol
+ Ss = p%coh%ssap
+ Sr = p%coh%sfrt
+
+ ! choice of allocation model. 0 = constant allocation factors, 1 = allometric model
+ flag_SV_allo = 1
+
+ ! only allocate if enough NPP is available
+ IF (NPP>1.0E-9) THEN
+
+ ! calculate leaf activity based on net PS and leaf mass
+ sigmaf = NPP/F
+
+ ! calculate root activity based on drought index
+! test of a relationship which modifies fine root leaf ratio with shade tolerance
+ IF (flag_sign.eq.1) THEN
+ sigman = amax1(spar(ns)%sigman*10*(((5.-spar(ns)%stol)*1.-p%coh%crown_area)/(5.-spar(ns)%stol)*1.),spar(ns)%sigman) * p%coh%drIndAl / p%coh%nDaysGr
+ ELSE
+ sigman = spar(ns)%sigman * p%coh%drIndAl / p%coh%nDaysGr
+ END IF
+ M_avail=(NPP+F-Sf+R-Sr+S-Ss)/kpatchsize
+
+ IF(flag_SV_allo==0) THEN
+ ! the parameters pdiam in the species.par file are used for allocation fractions
+ lambdaf=spar(ns)%pdiam1
+ lambdar=spar(ns)%pdiam2
+ lambdas=spar(ns)%pdiam3
+ ELSE
+ FRsum=(F+R)/kpatchsize
+ CALL newt (FRsum, f_lf, df_lf, ddf_lf, 1.e-6, 100, rnum)
+ IF(FRsum>M_avail .and. .not.flag_mult8910) CALL error_mess(time,'no solution found for allocation for groundvegetation cohort, rnum: ',real(rnum))
+ IF(rnum==-1) THEN
+ if (.not.flag_mult8910) CALL error_mess(time,'no solution found for allocation for groundvegetation cohort: ',real(p%coh%ident))
+ lambdaf=0.4
+ lambdar=0.4
+ lambdas=0.2
+ ELSE
+ lambdaf=(FRsum)/M_avail/2.
+ lambdar=(FRsum)/M_avail/2.
+ lambdas=1.-lambdaf-lambdar
+ ENDIF
+ ENDIF
+
+ END IF ! IF NPP < 1.0E-09
+
+ ! gross growth rates of compartments
+
+ Gf = lambdaf * M_avail*kpatchsize -F +Sf
+ Gr = lambdar * M_avail*kpatchsize -R +Sr
+ Gs = lambdas * M_avail*kpatchsize -S +Ss
+
+! preliminary solution for permanent seeding
+ IF(lambdaf * M_avail < 1.e-4) THEN
+ Gf = Gf + 1.e-4*kpatchsize
+ ENDIF
+
+ p%coh%gfol = Gf
+ p%coh%gfrt = Gr
+ p%coh%gsap = Gs
+
+ ! update of state vector
+ FNew = F + Gf - Sf
+ SNew = S + Gs - Ss
+ RNew = R + Gr - Sr
+ p%coh%x_fol = FNew
+ p%coh%x_sap = SNew
+ p%coh%x_frt = RNew
+
+ ! determine litter production from plant turnover rates
+ ! first step nitrogen related processes: N in litter, N-recallocation
+ p%coh%N_pool = p%coh%N_pool + Sf/F*p%coh%N_fol*spar(ns)%reallo_fol &
+ + Sr*cpart/spar(ns)%cnr_frt*1000.* spar(ns)%reallo_frt &
+ + Ss*cpart *1000. * (1/spar(ns)%cnr_tbc - 1/spar(ns)%cnr_stem)
+ p%coh%N_fol = p%coh%N_fol*(1-Sf/F)
+
+ ! Summation, due to the filling of the pool at other points as well
+ p%coh%litC_fol = p%coh%litC_fol + p%coh%ntreea * Sf * cpart
+ p%coh%litC_frt = p%coh%litC_frt + p%coh%ntreea * Sr * cpart
+
+ ! New version with species specific N content and reallocation factor (see species.par)
+ ! changed to 1-reallo
+ p%coh%litN_fol = p%coh%litN_fol + p%coh%ntreea * Sf * cpart * (1.-spar(ns)%reallo_fol) / spar(ns)%cnr_fol
+ p%coh%litN_frt = p%coh%litN_frt + p%coh%ntreea * Sr * cpart * (1.-spar(ns)%reallo_frt) / spar(ns)%cnr_frt
+
+ ! second step: allocation of N to new growth
+ ! before bud-break allocation to leaves is 50% of the N content of last years foliage
+ tbc_root_Ndemand = Gs*cpart *kg_in_g / spar(ns)%cnr_tbc + Gr* cpart/spar(ns)%cnr_frt*kg_in_g
+ IF(tbc_root_Ndemand + Gf*p%coh%med_sla*0.5 > p%coh%N_pool) THEN
+ if (tbc_root_Ndemand .gt. 1E-8) then
+ Nredfak = AMAX1((p%coh%N_pool-Gf*p%coh%med_sla*0.5) / tbc_root_Ndemand,0.) ! Div. by zero possible !
+ else
+ Nredfak = 0.
+ endif
+ tbc_root_Ndemand = tbc_root_Ndemand*Nredfak
+ ENDIF
+ p%coh%N_pool = p%coh%N_pool - tbc_root_Ndemand
+
+ END SUBROUTINE PARTITION_SV
+
+!*******************************!
+!* SUBROUTINE PARTITION_MI *!
+!*******************************!
+
+SUBROUTINE PARTITION_MI( p )
+ !*** Declaration part ***!
+ USE data_par
+ USE data_stand
+ USE data_simul
+ IMPLICIT NONE
+ TYPE(Coh_Obj) :: p ! pointer to cohort list
+ !no partitioning, foliage mass keeps constant
+ p%coh%x_fol = p%coh%x_fol ! !FNew
+ p%coh%x_sap = 0.!SNew
+ p%coh%x_frt = 0.!RNew
+END SUBROUTINE PARTITION_MI
+
+!***************************!
+! FUNCTION f_lf *!
+!***************************!
+
+REAL FUNCTION f_lf(x)
+ USE data_stand
+ USE data_plant
+ REAL :: x
+ f_lf = ksi*x**kappa + x - M_avail
+END ! FUNCTION f_lf
+
+!***************************!
+! FUNCTION df_lf *!
+!***************************!
+
+REAL FUNCTION df_lf(x)
+ USE data_stand
+ USE data_plant
+ REAL :: x
+ df_lf = ksi*kappa*x**(kappa-1.) + 1.
+END ! FUNCTION df_lf
+
+!***************************!
+! FUNCTION ddf_lf *!
+!***************************!
+
+REAL FUNCTION ddf_lf(x)
+ USE data_stand
+ USE data_plant
+ REAL :: x
+ ddf_lf = ksi*kappa*(kappa-1.)*x**(kappa-2.)
+END ! FUNCTION ddf_lf
+
+!***************************!
+! SUBROUTINE CALC_DBH *!
+!***************************!
+SUBROUTINE CALC_DBH(B, Ht, S, H, Ahb, Ahc, ident, dbh, dc, hs, Asw)
+
+ !*** Declaration part ***!
+
+USE data_par
+USE data_species
+USE data_simul
+
+IMPLICIT NONE
+
+INTEGER :: ident
+
+REAL :: Dc ! diameter at crown base
+REAL :: B, & ! bole height,
+ Ht, & ! total tree height
+ S, & ! sapwood
+ H, & ! heartwood
+ hs, & ! sapwood height
+ D, & ! stem diameter at forest floor
+ DBH, & ! tree diameter at breast height
+ Ahb, & ! cross sectional area heartwood at tree base
+ Ahc, & ! cross sectional area of heartwood at crown base
+ Asw, & ! cross sectional area of sapwood in bole
+ discr, func, help, hp1, hp2,hp3, hp4
+REAL :: fp, fq, & ! coefficients of quadratic equation
+ w1, w2, & ! solutions of quadratic equation
+ precision ! criterion for acceptance of solution
+real :: sprhos ! sapwood density [kg/cm3]
+
+ !*** Calculation part ***!
+
+ precision = 1.e-5
+ sprhos = spar(ns)%prhos
+! calculate Diameters
+ hs = (2*B +Ht)/3.
+ Asw = S/(spar(ns)%prhos*hs)
+
+! if Bole height >= height trees are dead and calculations not required
+ IF(B .lt. Ht) THEN
+ select case (flag_volfunc)
+ case (0)
+ D = SQRT( (S+H)*4. / (sprhos*hs*pi) )
+ IF (Ht<h_breast) THEN
+ DBH = 0.0
+ ELSEIF (Ht>h_breast.and.B<h_breast) then
+ DBH=D-(D/(Ht-B))*(h_breast-B)
+ ELSE
+ DBH=D
+ ENDIF
+
+ case (1)
+ D = SQRT((Ahb+Asw)*4./pi)
+ ! if Bole height = 0 then there is no need to calulate Diameter at crown base and Dc = D
+ IF(B.EQ.0.) THEN
+ Dc = D
+ ELSE
+ fp = -2. * (B/Ht) * (3.*H/(sprhos*B)-Ahb)-Ahb*(B/Ht)**2.
+ fp = -2. * B/Ht * (3.*H/(sprhos*B)-Ahb)-Ahb*(B/Ht)**2.
+ fq = ((3.*H/(sprhos) - Ahb*B) / Ht)**2.
+ discr = fp**2./4.-fq
+ if (abs(discr) .lt. zero) then
+ discr = zero ! avoid small values
+ endif
+ ! No solution
+ if(discr.lt.0) then
+ if (.not.flag_mult8910) then
+ CALL error_mess(time,'discriminant < 0 in calc_dbh for cohort: ',real(ident))
+ CALL stop_mess(time,'discriminant < 0 in calc_dbh ')
+ CALL error_mess(time,'stop in calc_dbh for stand No: ',real(ip))
+ CALL error_mess(time,'heart wood mass H: ',H)
+ CALL error_mess(time,'bole height b: ',b)
+ CALL error_mess(time,'height Ht: ',Ht)
+ CALL error_mess(time,'ave. sapwood height hs: ',hs)
+ CALL error_mess(time,'sapwood area Asw: ',Asw)
+ CALL error_mess(time,'heartwood area at stem base Ahb: ',Ahb)
+ endif
+ flag_end = 1
+ return
+ end if
+
+ discr = SQRT(discr)
+ w1 = -fp/2. + discr
+ w2 = -fp/2. - discr
+1313 hp1 = SQRT(w1*Ahb)
+ hp2 = (Ahb+SQRT(w1*Ahb))*B
+ hp3 = (w1*Ht + (Ahb+SQRT(w1*Ahb))*B)
+ help = (sprhos/3.) * (w1*Ht + (Ahb+SQRT(w1*Ahb))*B)
+ func = (sprhos/3.) * (w1*Ht + (Ahb+SQRT(w1*Ahb))*B) - H
+ hp4= H* precision
+ IF(abs(func) <= H * precision) THEN
+ Ahc = w1
+ if (.not.flag_mult8910) then
+ CALL error_mess(time,' positive root is a solution in calc_dbh for cohort: ',real(ident))
+ CALL error_mess(time,'stop in calc_dbh for stand No: ',real(ip))
+ CALL error_mess(time,'function: ',func)
+ endif
+ flag_end = 1
+ return
+ ELSE
+ func = (sprhos/3.) * (w2*Ht + (Ahb+SQRT(w2*Ahb))*B) - H
+ IF(abs(func) <= H * precision) THEN
+ Ahc = w2
+ ELSE
+ IF(precision.LT.1e-2) THEN
+ precision = precision*10.
+ GOTO 1313
+ if (.not.flag_mult8910) then
+ CALL error_mess(time,'no valid solution found in calc_dbh for heartwood geometry for cohort: ',real(ident))
+ CALL error_mess(time,': heart wood mass, H = ',H)
+ CALL error_mess(time,': precision requirement = ',precision)
+ CALL error_mess(time,'iteration in stand No: ',real(ip))
+ endif
+ ELSE
+ if (.not.flag_mult8910) then
+ CALL error_mess(time,'no valid solution found in calc_dbh for heartwood geometry for cohort: ',real(ident))
+ CALL stop_mess(time,'no valid solution found in calc_dbh for heartwood geometry')
+ CALL error_mess(time,'species No: ',real(ns))
+ CALL error_mess(time,'stop in calc_dbh for stand No: ',real(ip))
+ CALL error_mess(time,'precision requirement H*precision ',H*precision)
+ CALL error_mess(time,'heart wood mass H: ',H)
+ CALL error_mess(time,'bole height b: ',b)
+ CALL error_mess(time,'height Ht: ',Ht)
+ CALL error_mess(time,'ave. sapwood height hs: ',hs)
+ CALL error_mess(time,'sapwood area Asw: ',Asw)
+ CALL error_mess(time,'heartwood area at stem base Ahb: ',Ahb)
+ endif
+ flag_end = 1
+ return
+ ENDIF
+ ENDIF
+ ENDIF
+ Dc = SQRT((Ahc+Asw)*4./pi)
+ END IF
+ if (Ht<=h_breast) then
+ DBH = 0.0
+ else if (Ht>h_breast.and.B<h_breast) then
+ DBH=Dc*(Ht-h_breast)/(Ht-B)
+ else
+ DBH=D-(D-Dc)*h_breast/B
+ end if
+ end select
+ ELSE
+ if (.not.flag_mult8910) then
+ CALL error_mess(time,'no calculation of heartwood geometry for cohort (Bole height >= height trees are dead): ',real(ident))
+ CALL error_mess(time,'bole height: ',b)
+ CALL error_mess(time,'height: ',Ht)
+ endif
+ END IF ! if B > Ht
+
+END SUBROUTINE CALC_DBH
diff --git a/source_code/version2.2_windows/pheno.f b/source_code/version2.2_windows/pheno.f
new file mode 100755
index 0000000000000000000000000000000000000000..ea6ec9e2a96778334445e82c8704e5a14bfebf01
--- /dev/null
+++ b/source_code/version2.2_windows/pheno.f
@@ -0,0 +1,422 @@
+!*****************************************************************!
+!* *!
+!* 4C Simulation Model *!
+!* *!
+!* *!
+!* Subroutines for: *!
+!* Simulation of processes at subannual resolution *!
+!* *!
+!* Contains subroutines: *!
+!* *!
+!* - pheno_ini *!
+!* - pheno_begin *!
+!* - pheno_count *!
+!* - pheno_shed *!
+!* *!
+!* functions: *!
+!* triangle *!
+!* *!
+!* Copyright (C) 1996-2018 *!
+!* Potsdam Institute for Climate Impact Reserach (PIK) *!
+!* Authors and contributors see AUTHOR file *!
+!* This file is part of 4C and is licensed under BSD-2-Clause *!
+!* See LICENSE file or under: *!
+!* http://www.https://opensource.org/licenses/BSD-2-Clause *!
+!* Contact: *!
+!* https://gitlab.pik-potsdam.de/foresee/4C *!
+!* *!
+!*****************************************************************!
+
+SUBROUTINE pheno_ini
+
+ USE data_climate
+ USE data_simul
+ USE data_site
+ USE data_species
+ USE data_stand
+
+ IMPLICIT NONE
+
+ integer i, j
+ integer leapyear
+ real atemp, hh, htemp
+ real triangle
+ real, external :: daylength
+
+ leaves_on = .false.
+ all_leaves_on = 0
+ phen_flag=1 ! CANOPY is calculated once at the beginning of each year
+
+! Initialising of all species is done at the beginning, since if species information wouldnt be initialised
+ IF(time==1) THEN
+ do i=1,nspec_tree
+ ns = i
+ IF(spar(ns)%Phmodel==1) THEN
+ svar(ns)%Pro = 0.
+ svar(ns)%Inh = 1.
+ ELSE
+ svar(ns)%Pro = 0.
+ svar(ns)%Inh = 0.
+ svar(ns)%Tcrit = 0.
+ END IF
+
+! initialize pheno state variables with climate from the actual year
+ do j = spar(ns)%end_bb+1, 365
+
+ atemp = tp(j, 1)
+ hh = DAYLENGTH(j,lat)
+ SELECT CASE(ns)
+ CASE(1,8)
+ !Fagus
+ ! Promotor-Inhibitor model 11
+ svar(ns)%Pro = svar(ns)%Pro + spar(ns)%PPa* &
+ triangle(spar(ns)%PPtmin,spar(ns)%PPtopt,spar(ns)%PPtmax,atemp)* &
+ (1-svar(ns)%Inh)*hh/24 - &
+ spar(ns)%PPb*svar(ns)%Pro*(24-hh)/24
+
+ svar(ns)%Inh = svar(ns)%Inh - spar(ns)%PIa* &
+ triangle(spar(ns)%PItmin,spar(ns)%PItopt,spar(ns)%PItmax,atemp)* &
+ svar(ns)%Inh*hh/24
+
+ CASE(4)
+ ! Quercus
+ ! Promotor-Inhibitor model 12
+ htemp = triangle(spar(ns)%PPtmin,spar(ns)%PPtopt,spar(ns)%PPtmax,atemp)
+ svar(ns)%Pro = svar(ns)%Pro + spar(ns)%PPa * htemp * &
+ (1-svar(ns)%Inh) * hh/24
+
+ htemp = triangle(spar(ns)%PItmin,spar(ns)%PItopt,spar(ns)%PItmax,atemp)
+ svar(ns)%Inh = svar(ns)%Inh - spar(ns)%PIa * htemp * &
+ svar(ns)%Inh * hh/24 + spar(ns)%PPb*(24-hh)/24
+
+ CASE(5, 11)
+ ! Betula, Robinia
+ IF(spar(ns)%Phmodel==1) THEN
+ ! Promotor-Inhibitor model 2
+ svar(ns)%Pro = svar(ns)%Pro + spar(ns)%PPa* &
+ triangle(spar(ns)%PPtmin,spar(ns)%PPtopt,spar(ns)%PPtmax,atemp)* &
+ (1-svar(ns)%Inh) - spar(ns)%PPb*svar(ns)%Pro*(24-hh)/24
+ svar(ns)%Inh = svar(ns)%Inh - spar(ns)%PIa* &
+ triangle(spar(ns)%PItmin,spar(ns)%PItopt,spar(ns)%PItmax,atemp)*svar(ns)%Inh
+
+ END IF
+
+ END SELECT
+ enddo ! j
+ Enddo ! nspec_tree
+ END IF
+
+! latest day of bud burst 30. of June (DOY 181+leapyear(time_cur))
+ do i=1, anrspec
+ ns = nrspec(i)
+ if(ns.le.nspec_tree) then
+ IF(spar(ns)%phmodel==4) THEN
+ svar(ns)%daybb = svar(ns)%ext_daybb
+ ELSE
+ svar(ns)%daybb = 181 + leapyear(time_cur)
+ ENDIF
+ end if
+ END DO ! anrspec
+
+end SUBROUTINE pheno_ini
+
+!*******************************************************************
+
+SUBROUTINE pheno_begin
+! calculation of day_bb, latest day of bud burst 30. june (DOY 181)
+ USE data_simul
+ USE data_species
+ USE data_stand
+ USE data_climate
+ USE data_site
+ IMPLICIT NONE
+
+ REAL triangle
+ INTEGER leapyear
+ real hh, htemp
+ integer i
+
+ hh = dlength
+ do i=1, anrspec
+ ns = nrspec(i)
+
+if (iday .ge.364) then
+continue
+endif
+
+ if(ns.le.nspec_tree .OR. ns.eq.nspec_tree+2) then !either tree or mistletoe
+ ! Pheno model
+ select Case (spar(ns)%Phmodel)
+ Case(0) ! no model
+ !Picea, Pinus, Mistletoe
+
+ IF(iday.EQ.1) THEN
+ svar(ns)%daybb = iday
+ phen_flag = 1
+ leaves_on = .TRUE.
+ ENDIF
+
+ Case(1)
+ ! Phenology starts after leaf coloring/shedding and ends not later than 30. June
+ IF (iday > spar(ns)%end_bb+1 .OR. iday <= svar(ns)%daybb) THEN
+
+ SELECT CASE(ns)
+ CASE(1,8)
+ !Fagus
+ ! Promotor-Inhibitor model 11
+
+ htemp = triangle(spar(ns)%PPtmin,spar(ns)%PPtopt,spar(ns)%PPtmax,airtemp)
+ svar(ns)%Pro = svar(ns)%Pro + spar(ns)%PPa * htemp * &
+ (1-svar(ns)%Inh) * dlength/24 - &
+ spar(ns)%PPb*svar(ns)%Pro * (24-dlength)/24
+ svar(ns)%Inh = svar(ns)%Inh - spar(ns)%PIa*&
+ triangle(spar(ns)%PItmin,spar(ns)%PItopt,spar(ns)%PItmax,airtemp)*&
+ svar(ns)%Inh*dlength/24
+
+ IF (svar(ns)%Pro >= 1) THEN
+ svar(ns)%daybb=iday
+ phen_flag = 1
+ leaves_on=.TRUE.
+ ELSE IF (svar(ns)%Pro < 1 .AND. iday==svar(ns)%daybb) THEN
+ phen_flag = 1
+ leaves_on=.TRUE.
+ END IF
+ CASE(4)
+ ! Quercus
+ ! Promotor-Inhibitor model 12
+
+ all_leaves_on=0
+
+ if (svar(ns)%Inh .gt. 1.) then
+ continue
+ svar(ns)%Inh = 1.
+ endif
+ if (svar(ns)%Pro .lt. 0.) then
+ continue
+ svar(ns)%Pro = 0.
+ endif
+ htemp = triangle(spar(ns)%PPtmin,spar(ns)%PPtopt,spar(ns)%PPtmax,airtemp)
+ svar(ns)%Pro = svar(ns)%Pro + spar(ns)%PPa * htemp * &
+ (1-svar(ns)%Inh) * dlength/24
+ htemp = triangle(spar(ns)%PItmin,spar(ns)%PItopt,spar(ns)%PItmax,airtemp)
+ svar(ns)%Inh = svar(ns)%Inh - spar(ns)%PIa * htemp * &
+ svar(ns)%Inh * dlength/24 + spar(ns)%PPb*(24-dlength)/24
+
+ IF (svar(ns)%Pro >= 1) THEN
+ svar(ns)%daybb=iday
+ phen_flag = 1
+ leaves_on=.TRUE.
+ ELSE IF (svar(ns)%Pro < 1 .AND. iday==svar(ns)%daybb) THEN
+ phen_flag = 1
+ leaves_on=.TRUE.
+ END IF
+
+ CASE(5, 11)
+ ! Betula, Robinia
+
+ all_leaves_on=0
+
+ IF(spar(ns)%Phmodel==1) THEN
+ ! Promotor-Inhibitor model 2
+
+ svar(ns)%Pro = svar(ns)%Pro + spar(ns)%PPa* &
+ triangle(spar(ns)%PPtmin,spar(ns)%PPtopt,spar(ns)%PPtmax,airtemp)* &
+ (1-svar(ns)%Inh) - spar(ns)%PPb*svar(ns)%Pro*(24-dlength)/24
+ svar(ns)%Inh = svar(ns)%Inh - spar(ns)%PIa* &
+ triangle(spar(ns)%PItmin,spar(ns)%PItopt,spar(ns)%PItmax,airtemp)*svar(ns)%Inh
+
+ IF (svar(ns)%Pro >= 1) THEN
+ svar(ns)%daybb=iday
+ phen_flag = 1
+ leaves_on=.TRUE.
+ ELSE IF (svar(ns)%Pro < 1 .AND. iday==svar(ns)%daybb) THEN
+ phen_flag = 1
+ leaves_on=.TRUE.
+ END IF
+ END IF
+
+ END SELECT
+ Endif
+
+ Case(2)
+ ! Cannel-Smith model
+
+ IF(iday >= 305 + leapyear(time_cur) .OR. iday <= svar(ns)%daybb) THEN
+ IF(airtemp < spar(ns)%CSTbC) THEN
+ svar(ns)%Inh = svar(ns)%Inh + 1
+ svar(ns)%Tcrit = spar(ns)%CSa + spar(ns)%CSb*LOG(svar(ns)%Inh)
+ END IF
+
+ IF(airtemp > spar(ns)%CSTbT .AND. iday >= 32 .AND. iday <= svar(ns)%daybb) THEN
+ svar(ns)%Pro = svar(ns)%Pro + airtemp - spar(ns)%CSTbT;
+ END IF
+
+ IF(svar(ns)%Pro > svar(ns)%Tcrit) THEN
+ svar(ns)%daybb=iday
+ phen_flag = 1
+ leaves_on=.TRUE.
+ ELSE IF (svar(ns)%Pro < svar(ns)%Tcrit .AND. iday==svar(ns)%daybb) THEN
+ phen_flag = 1
+ leaves_on=.TRUE.
+ END IF
+ END IF
+
+ Case(3)
+ ! Temperature sum model
+
+ SELECT CASE(ns)
+ CASE(11)
+ ! Robinia
+ IF(iday >= spar(ns)%Lstart .AND. iday <= svar(ns)%daybb) THEN
+ IF(airtemp > spar(ns)%LTbT) THEN
+ svar(ns)%Pro = svar(ns)%Pro + airtemp
+ END IF
+
+ IF(svar(ns)%Pro > spar(ns)%LTcrit) THEN
+ svar(ns)%daybb=iday
+ phen_flag = 1
+ leaves_on=.TRUE.
+ ELSE IF (svar(ns)%Pro < spar(ns)%LTcrit .AND. iday==svar(ns)%daybb) THEN
+ phen_flag = 1
+ leaves_on=.TRUE.
+ END IF
+ END IF
+
+ CASE default
+ IF(iday >= spar(ns)%Lstart .AND. iday <= svar(ns)%daybb) THEN
+ IF(airtemp > spar(ns)%LTbT) THEN
+ svar(ns)%Pro = svar(ns)%Pro + airtemp - spar(ns)%LTbT
+ END IF
+
+ IF(svar(ns)%Pro > spar(ns)%LTcrit) THEN
+ svar(ns)%daybb=iday
+ phen_flag = 1
+ leaves_on=.TRUE.
+ ELSE IF (svar(ns)%Pro < spar(ns)%LTcrit .AND. iday==svar(ns)%daybb) THEN
+ phen_flag = 1
+ leaves_on=.TRUE.
+ END IF
+ END IF
+ END SELECT
+
+ Case(4)
+ ! externally prescribed day of budburst
+ IF(iday==svar(ns)%daybb) THEN
+ phen_flag = 1
+ leaves_on=.TRUE.
+
+ END IF
+
+ Case default
+
+ IF(iday.EQ.1) THEN
+ svar(ns)%daybb=iday
+ phen_flag=1
+ leaves_on=.TRUE.
+ ENDIF
+ end select
+
+ else if(iday==svar(ns)%daybb) then
+ phen_flag = 1
+ leaves_on=.TRUE.
+ end if
+
+ END DO
+
+ zeig=>pt%first
+ do while (associated(zeig))
+ ns = zeig%coh%species
+ zeig%coh%day_bb = svar(ns)%daybb
+ zeig=>zeig%next
+ enddo
+
+END SUBROUTINE pheno_begin
+
+!*******************************************************************
+
+SUBROUTINE pheno_count
+USE data_simul
+USE data_species
+USE data_stand
+IMPLICIT NONE
+
+zeig=>pt%first
+DO
+ if(.not. associated(zeig)) exit
+ ! vegetation period per PS-time step and per season
+ IF((iday >= zeig%coh%day_bb) .AND. (iday <= spar(zeig%coh%species)%end_bb)) THEN
+ zeig%coh%nDaysPS = zeig%coh%nDaysPS + 1. ! set to 0 in npp
+ zeig%coh%nDaysGr = zeig%coh%nDaysGr + 1. ! set to 0 year_ini
+ END IF
+
+ zeig=>zeig%next
+
+END DO
+
+END SUBROUTINE pheno_count
+
+!*******************************************************************
+
+SUBROUTINE pheno_shed
+
+ USE data_simul
+ USE data_species
+ USE data_stand
+
+ IMPLICIT NONE
+
+ integer i
+
+ leaves_on=.FALSE.
+ all_leaves_on=1
+ DO i=1, anrspec
+ ns = nrspec(i)
+
+ IF(iday == spar(ns)%end_bb +1) THEN
+ phen_flag=1
+ all_leaves_on=0
+
+ ! reset pheno state variable
+ IF(spar(ns)%Phmodel==1) THEN
+ svar(ns)%Pro = 0.
+ svar(ns)%Inh = 1.
+ ELSE
+ svar(ns)%Pro = 0.
+ svar(ns)%Inh = 0.
+ svar(ns)%Tcrit = 0.
+ END IF
+ ELSE IF((iday < svar(ns)%daybb) .OR. (iday > spar(ns)%end_bb)) THEN
+ all_leaves_on=0
+ ELSE IF((iday >= svar(ns)%daybb) .AND. (iday <= spar(ns)%end_bb)) THEN
+ leaves_on=.TRUE.
+ END IF
+ END DO
+END SUBROUTINE pheno_shed
+
+!*******************************************************************
+
+FUNCTION triangle(min,opt,max,x)
+
+ REAL :: min,opt,max,x,triangle
+
+ IF( min <= x .AND. x <= opt) THEN
+ triangle = (x - min)/(opt - min)
+ ELSE IF( opt < x .AND. x <= max) THEN
+ triangle = (max - x)/(max - opt)
+ ELSE
+ triangle = 0
+ END IF
+
+END FUNCTION triangle
+
+FUNCTION leapyear(year)
+ INTEGER :: year,leapyear
+
+ IF( MOD(year,400)==0 .OR. ( MOD(year,100)/=0 .AND. MOD(year,4)==0 )) THEN
+ leapyear = 1
+ ELSE
+ leapyear = 0
+ END IF
+
+END FUNCTION leapyear
+
diff --git a/source_code/version2.2_windows/planting.f b/source_code/version2.2_windows/planting.f
new file mode 100755
index 0000000000000000000000000000000000000000..3a846b79b3ab59a184a82516dc478d88ce6268c2
--- /dev/null
+++ b/source_code/version2.2_windows/planting.f
@@ -0,0 +1,554 @@
+!*****************************************************************!
+!* *!
+!* 4C (FORESEE) *!
+!* *!
+!* *!
+!* Subroutines for planting *!
+!* *!
+!* contains: *!
+!* SR planting *!
+!* function sapwood *!
+!* SR gener_coh *!
+!* *!
+!* comment: planting is controlled by the flag flag_reg, *!
+!* soe standardized planting ensembles are definded *!
+!* *!
+!* 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 planting
+ USE data_stand
+ USE data_simul
+ USE data_species
+ USE data_soil
+ USE data_help
+ USE data_plant
+ USE data_manag
+ use data_wpm
+
+ IMPLICIT NONE
+ integer :: nplant, &
+ taxid, &
+ i,j,nr, &
+ taxnum, &
+ outunit, ctrlunit
+ real :: age, &
+ pl_height, &
+ sdev, &
+ plhmin, &
+ rsap, &
+ hbc, &
+ bhd, &
+ cform, &
+ hlp_lai, &
+ rednpl_sh
+
+real :: rtflsp, sapwood, height, plots
+integer, dimension(nspec_tree) :: infhelp
+character(80) :: infile
+character :: text
+ CHARACTER :: source
+integer :: inunit,ios
+integer :: parunit
+integer :: nkoh, nplanth, numb
+
+REAL p0(nspec_tree),p1(nspec_tree),p2(nspec_tree),p3(nspec_tree),p4(nspec_tree), &
+ c1(nspec_tree),c2(nspec_tree),ku_a0(nspec_tree),ku_a1(nspec_tree),ku_a2(nspec_tree),&
+ ku_b0(nspec_tree),ku_b1(nspec_tree),ku_b2(nspec_tree),ku_c0(nspec_tree),&
+ ku_c1(nspec_tree),ku_c2(nspec_tree),wei_k1(nspec_tree),wei_k2(nspec_tree)
+real :: crown_base, crown_base_eg
+TYPE(cohort) ::tree_ini
+
+real corr_la
+real :: troot2
+
+real, dimension(20) :: hhei
+
+external sapwood
+external rtflsp
+ do i =1,nspec_tree
+ infhelp(i) = infspec(i)
+ end do
+
+ parunit=GETUNIT()
+ OPEN (parunit, FILE='input/generreg.par', STATUS='old')
+ DO i=1,nspec_tree
+ READ (parunit,*) p0(i),p1(i),p2(i),p3(i),p4(i),c1(i),c2(i),ku_a0(i),ku_a1(i),ku_a2(i), &
+ ku_b0(i),ku_b1(i),ku_b2(i),ku_c0(i),ku_c1(i),ku_c2(i),wei_k1(i),wei_k2(i)
+ ENDDO
+ CLOSE(parunit)
+
+
+!*********************** sea **************************************
+ plant_year = time
+ flag_plant = flag_reg
+!******************************************************************
+
+ rednpl_sh = 1.
+! modification uf number of planted trees in the case of shelterwood management
+ if(flag_shelter.eq.1) rednpl_sh = 0.7
+
+ taxid = 0
+ if( flag_reg .ge.10) quspec = 1
+
+ if(flag_reg.ge.10.and.flag_reg.lt. 30) then
+
+ ! planting of mono-species stands
+
+ select case(flag_reg)
+
+ case(10)
+ ! planting pine
+ taxnum = 3
+ case(11)
+ ! planting beech
+ taxnum = 1
+ case(12)
+ ! planting oak
+ taxnum =4
+ case(13)
+ ! planting spruce
+ taxnum = 2
+ case(14)
+ ! planting birch
+ taxnum = 5
+ case(15)
+ ! planting aspen
+ taxnum = 8
+ case(16)
+ ! planting aleppo pine
+ taxnum = 9
+ case(17)
+ ! planting douglas fir
+ taxnum =10
+ case(18)
+ ! planting black locust
+ taxnum =11
+
+ case(20)
+! reading planting data from file and generating tree cohorts
+
+ inunit=getunit()
+ write(*,'(a)') ' *** Planting of small trees ***'
+ write(*,'(A)',advance='no')' Input directory and file for planting: '
+ read (*,'(A)') infile
+ open (inunit,FILE=trim(infile),STATUS='old')
+! read head of data-file
+ outunit=getunit()
+ open(outunit, FILE=TRIM(treefile(ip)),STATUS='replace')
+ ctrlunit = getunit() +1
+ OPEN (ctrlunit,FILE=TRIM(site_name(ip))//'.initctrl',STATUS='replace')
+ plots=10000.
+ do
+ read(inunit,*) text
+ if(text .ne. '!')then
+ backspace(inunit);exit
+ endif
+ enddo
+! modification AB 19.9.11
+ CALL header(outunit,infile,source,cform,rsap,flag_volfunc,kpatchsize)
+
+ do
+ READ(inunit,*,IOSTAT=ios)numb, nplant ,taxid,pl_height, age, bhd, hbc
+ if(ios<0) exit
+ height = pl_height
+! Modification (Alexander Borys), generating of nkoh cohorts from given data, 19.9.11
+ nkoh =10
+ do i = 1, nkoh
+ hhei(i) = height*(0.8 + (i-1)*0.025)
+ end do
+ write(outunit,*) numb, plots
+
+ do i = 1, nkoh
+ pl_height = hhei(i)*100.
+ height = hhei(i)
+ if(taxid.eq.12.or. taxid.eq.13) then
+! Eucalyptus
+ hbc = crown_base_eg(height, bhd)
+ else
+ hbc=crown_base(height,c1(taxid),c2(taxid),bhd)
+ end if
+ nplanth = int(nplant/nkoh)
+ rsap = 0.5
+ source = 'd'
+ cform=1;hlp_lai=0
+ corr_la = 1.
+ call treeini(outunit,ctrlunit,taxid,source,bhd,height,hbc,nplanth,cform,rsap,int(age),hlp_lai,corr_la)
+ max_coh = max_coh + 1
+ ! initialise tree_ini with zero
+ call coh_initial (tree_ini)
+
+ tree_ini%ident = max_coh
+ tree_ini%species = taxid
+ tree_ini%ntreea = nplant
+ tree_ini%ntreed = 0.
+ tree_ini%nta = tree_ini%ntreea
+ tree_ini%x_age = age
+ tree_ini%x_hbole = hbc
+ tree_ini%resp = 0.
+ tree_ini%height = pl_height
+ tree_ini%x_sap = x_sap
+ tree_ini%x_fol = x_fol
+ tree_ini%x_frt = x_frt
+ tree_ini%x_hrt = x_hrt
+ tree_ini%x_ahb = x_ahb
+ tree_ini%x_crt = (tree_ini%x_sap + tree_ini%x_hrt) * spar(taxid)%alphac*spar(taxid)%cr_frac
+ tree_ini%x_tb = (tree_ini%x_sap + tree_ini%x_hrt) * spar(taxid)%alphac*(1.-spar(taxid)%cr_frac)
+
+! Borys
+ tree_ini%diam = bhd
+ tree_ini%med_sla = spar(taxid)%psla_min + spar(taxid)%psla_a*0.5
+ tree_ini%t_leaf = tree_ini%med_sla* tree_ini%x_fol ! [m-2]
+ tree_ini%ca_ini = tree_ini%t_leaf
+ tree_ini%crown_area = tree_ini%ca_ini
+! initialize pheno state variables
+ IF(spar(tree_ini%species)%Phmodel==1) THEN
+ tree_ini%P=0
+ tree_ini%I=1
+ ELSE
+ tree_ini%P=0
+ tree_ini%I=0
+ tree_ini%Tcrit=0
+ END IF
+
+ IF(nplant.ne.0.) then
+ IF (.not. associated(pt%first)) THEN
+ ALLOCATE (pt%first)
+ pt%first%coh = tree_ini
+ NULLIFY(pt%first%next)
+
+! root distribution
+ call root_depth (1, pt%first%coh%species, pt%first%coh%x_age, pt%first%coh%height, pt%first%coh%x_frt, pt%first%coh%x_crt, nr, troot2, pt%first%coh%x_rdpt, pt%first%coh%nroot)
+ pt%first%coh%nroot = nr
+ do j=1,nr
+ pt%first%coh%rooteff = 1. ! assumption for the first use
+ enddo
+ do j=nr+1, nlay
+ pt%first%coh%rooteff = 0. ! layers with no roots
+ enddo
+
+ ELSE
+ ALLOCATE(zeig)
+ zeig%coh = tree_ini
+ zeig%next => pt%first
+ pt%first => zeig
+
+! root distribution
+ call root_depth (1, zeig%coh%species, zeig%coh%x_age, zeig%coh%height, zeig%coh%x_frt, zeig%coh%x_crt, nr, troot2, zeig%coh%x_rdpt, zeig%coh%nroot)
+ zeig%coh%nroot = nr
+ do j=1,nr
+ zeig%coh%rooteff = 1. ! assumption for the first use
+ enddo
+ do j=nr+1, nlay
+ zeig%coh%rooteff = 0. ! layers with no roots
+ enddo
+
+ END IF ! associated
+ anz_coh=anz_coh+1
+ END IF ! nplant
+
+ end do ! nkoh
+ end do
+ close(inunit)
+ close (outunit)
+ close (ctrlunit)
+ return
+
+ end select
+
+! liocourt management with regeneration if flag_mg = 44
+if(flag_mg.eq.44) then
+
+ do i= 1, M_numclass
+ taxid = m_specpl(spec_lic,i)
+ age = m_pl_age(spec_lic,i)
+ pl_height = m_plant_height(spec_lic,i)
+ plhmin = m_plant_hmin(spec_lic,i)
+ nplant = m_numplant(spec_lic,i) * kpatchsize/10000
+ sdev = m_hsdev(spec_lic,i)
+ call gener_coh(taxid, age, pl_height, plhmin, nplant,sdev)
+ end do
+else
+ taxid = taxnum
+ age = pl_age(taxnum)
+ pl_height = plant_height(taxnum)
+ plhmin = plant_hmin(taxnum)
+
+! number of seedling from data_plant
+ nplant = rednpl_sh*nint(numplant(taxnum)*kpatchsize/10000)
+! number of seedlings from seedrate
+ if(flag_reg.eq.15.or.flag_reg.eq.16.or.flag_reg.eq.18) nplant = spar(taxnum)%seedrate*kpatchsize
+ sdev = hsdev(taxnum)
+ call gener_coh(taxid, age, pl_height, plhmin, nplant,sdev)
+end if
+
+ else
+ ! planting of mixed stands
+ ! mixture given by ara<meters in data_plant
+ if(flag_reg.eq.9) then
+ do i = 1,nspec_tree
+ if (infspec(i).eq.1 .and. infhelp(i).eq.1) then
+ taxid = i
+ age = pl_age(taxid)
+ pl_height = plant_height(taxid)
+ plhmin = plant_hmin(taxid)
+ nplant = rednpl_sh*nint(npl_mix(taxid)*kpatchsize/10000)
+ sdev = hsdev(taxid)
+ call gener_coh(taxid, age, pl_height, plhmin, nplant,sdev)
+ infhelp(i) = 0
+ end if
+ end do ! i
+ else if(flag_reg.lt.9.or.flag_reg.gt.30) then
+ infspec = 0
+ npl_mix = 0
+
+ select case (flag_reg)
+! planting of well definded mixtures of pine and oak
+ case(8)
+ infspec(3)=1
+ infspec(4)=1
+ npl_mix(3) = 9000.
+ npl_mix(4) = 1000.
+ case(7)
+ infspec(3)=1
+ infspec(4)=1
+ npl_mix(3) = 7000.
+ npl_mix(4) = 3000.
+ case(6)
+ infspec(3)=1
+ infspec(4)=1
+ npl_mix(3) = 5000.
+ npl_mix(4) = 5000.
+ case(5)
+ infspec(3)=1
+ infspec(4)=1
+ npl_mix(3) = 3000.
+ npl_mix(4) = 7000.
+ case(4)
+ infspec(3)=1
+ infspec(4)=1
+ npl_mix(3) = 2000.
+ npl_mix(4) = 8000.
+ case(33)
+ infspec(2) = 1
+ infspec(3) = 1
+ npl_mix(2) = 5000.
+ npl_mix(3) = 5000.
+ end select
+ do i =1,nspec_tree
+ infhelp(i) = infspec(i)
+ end do
+ do i = 1,nspec_tree
+ if (infspec(i).eq.1 .and. infhelp(i).eq.1) then
+
+ taxid = i
+ age = pl_age(taxid)
+ pl_height = plant_height(taxid)
+ plhmin = plant_hmin(taxid)
+ nplant = rednpl_sh*nint(npl_mix(taxid)*kpatchsize/10000)
+ sdev = hsdev(taxid)
+ call gener_coh(taxid, age, pl_height, plhmin, nplant,sdev)
+ infhelp(i) = 0
+ end if
+ end do ! i
+ end if
+ end if
+
+END SUBROUTINE planting
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! gener_coh
+! SR for planting seedling cohorts
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+SUBROUTINE gener_coh(taxid,age,pl_height,plhmin, nplant,sdev)
+
+ USE data_simul
+ USE data_stand
+ USE data_par
+ USE data_species
+ USE data_soil
+ USE data_help
+ USE data_plant
+ USE data_manag
+
+ IMPLICIT NONE
+ integer :: nplant, &
+ taxid, &
+ nclass, &
+ i,j,nr
+ real :: age, &
+ pl_height, &
+ sdev, &
+ plhmin, &
+ plhmax, &
+ plhinc, &
+ help, &
+ nstot, &
+ hhelp,x1,x2,xacc,shelp
+real :: rtflsp, sapwood
+real :: troot2
+
+real, dimension(:), save, allocatable :: hei, &
+ nschelp
+
+integer,dimension(:),allocatable :: nsc
+TYPE(cohort) ::tree_ini
+
+external sapwood
+external rtflsp
+
+flag_standup = 2 ! call stand_balance and root_distribution later
+
+! number of classes
+ nclass = nint(plhmin + (pl_height-plhmin))
+! Liocourt management
+ if(flag_reg.eq.17) nclass = 20
+ if(flag_reg.eq.11 .and. flag_mg.eq.44) nclass = 1
+ if(flag_reg.eq.18) nclass =20
+ if (flag_reg.eq.15) nclass = 20
+ allocate(hei(nclass))
+ allocate(nschelp(nclass))
+ allocate(nsc(nclass))
+
+ plhmax = pl_height + (pl_height-plhmin)
+ plhinc = (plhmax-plhmin)/nclass
+ nstot = 0
+ help = (1/(sqrt(2*pi)*sdev))
+ do i = 1, nclass
+ if ( nclass.eq.1) then
+ hei(i) = pl_height
+ else
+! height per class
+ hei(i) = plhmin + (i-1)
+ nschelp(i) = help*exp(-((hei(i)-pl_height)**2)/(2*(sdev)**2))
+ nstot = nstot + nschelp (i)
+ end if
+ end do
+ do i = 1,nclass
+ if(nclass.eq.1) then
+ nsc(i) = nplant *kpatchsize/10000
+ else
+ nsc(i) = nint((nschelp(i)*nplant/nstot) + 0.5)
+ end if
+ end do
+
+ do i = 1,nclass
+
+ max_coh = max_coh + 1
+! initialise tree_ini with zero
+ call coh_initial (tree_ini)
+
+ tree_ini%ident = max_coh
+ tree_ini%species = taxid
+ tree_ini%ntreea = nsc(i)
+ tree_ini%nta = tree_ini%ntreea
+ tree_ini%x_age = age
+ tree_ini%height = hei(i)
+
+ hhelp = tree_ini%height
+
+ IF (taxid.ne.2) tree_ini%x_sap = exp(( LOG(hhelp)-LOG(spar(taxid)%pheight1))/spar(taxid)%pheight2)/1000000.
+ IF (taxid.eq.2) THEN
+ x1 = 1.
+ x2 = 2.
+ xacc=(1.0e-10)*(x1+x2)/2
+ heihelp = tree_ini%height
+ hnspec = taxid
+ shelp=rtflsp(sapwood,x1,x2,xacc)
+ tree_ini%x_sap = (10**shelp)/1000000 ! transformation mg ---> kg
+ ENDIF
+
+! Leaf mass
+ tree_ini%x_fol = (spar(taxid)%seeda*(tree_ini%x_sap** spar(taxid)%seedb)) ![kg]
+ tree_ini%Fmax = tree_ini%x_fol
+! Fine root mass rough estimate
+ tree_ini%x_frt = tree_ini%x_fol
+! cross sectional area of heartwood
+ tree_ini%x_crt = (tree_ini%x_sap + tree_ini%x_hrt) * spar(taxid)%alphac*spar(taxid)%cr_frac
+ tree_ini%x_tb = (tree_ini%x_sap + tree_ini%x_hrt) * spar(taxid)%alphac*(1.-spar(taxid)%cr_frac)
+
+ tree_ini%med_sla = spar(taxid)%psla_min + spar(taxid)%psla_a*0.5
+ tree_ini%t_leaf = tree_ini%med_sla* tree_ini%x_fol ! [m-2]
+ tree_ini%ca_ini = tree_ini%t_leaf
+ tree_ini%crown_area = tree_ini%ca_ini
+! 1 für Vincent kint, 2 oakchain
+ tree_ini%underst = 2
+! initialize pheno state variables
+ IF(spar(tree_ini%species)%Phmodel==1) THEN
+ tree_ini%P=0
+ tree_ini%I=1
+ ELSE
+ tree_ini%P=0
+ tree_ini%I=0
+ tree_ini%Tcrit=0
+ END IF
+
+ IF(nsc(i).ne.0.) then
+ IF (.not. associated(pt%first)) THEN
+ ALLOCATE (pt%first)
+ pt%first%coh = tree_ini
+ NULLIFY(pt%first%next)
+ call root_depth (1, pt%first%coh%species, pt%first%coh%x_age, pt%first%coh%height, pt%first%coh%x_frt, pt%first%coh%x_crt, nr, troot2, pt%first%coh%x_rdpt, pt%first%coh%nroot)
+ pt%first%coh%nroot = nr
+ do j=1,nr
+ pt%first%coh%rooteff(j) = 1. ! assumption for the first use
+ enddo
+ do j=nr+1, nlay
+ pt%first%coh%rooteff(j) = 0. ! layers with no roots
+ enddo
+
+ ELSE
+ ALLOCATE(zeig)
+ zeig%coh = tree_ini
+ zeig%next => pt%first
+ pt%first => zeig
+ call root_depth (1, zeig%coh%species, zeig%coh%x_age, zeig%coh%height, zeig%coh%x_frt, zeig%coh%x_crt, nr, troot2, zeig%coh%x_rdpt, zeig%coh%nroot)
+ zeig%coh%nroot = nr
+ do j=1,nr
+ zeig%coh%rooteff(j) = 1. ! assumption for the first use
+ enddo
+ do j=nr+1, nlay
+ zeig%coh%rooteff(j) = 0. ! layers with no roots
+ enddo
+
+ END IF
+ anz_coh=anz_coh+1
+ END IF
+
+end do
+
+ deallocate(hei)
+ deallocate(nschelp)
+ deallocate(nsc)
+
+END SUBROUTINE gener_coh
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! weight
+! seed mass function
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+function sapwood (x)
+
+use data_help
+use data_species
+
+real :: x
+real :: p1,p2,p3
+
+p1 = spar(hnspec)%pheight1
+p2 = spar(hnspec)%pheight2
+p3 = spar(hnspec)%pheight3
+
+sapwood = p3*(x**2) + p2*x +p1-alog10(heihelp)
+
+end function sapwood
diff --git a/source_code/version2.2_windows/prand.f b/source_code/version2.2_windows/prand.f
new file mode 100755
index 0000000000000000000000000000000000000000..7d198aed14140ccd9143fedc5668c108f8e6c897
--- /dev/null
+++ b/source_code/version2.2_windows/prand.f
@@ -0,0 +1,43 @@
+!*****************************************************************!
+!* *!
+!* 4C (FORESEE) *!
+!* *!
+!* *!
+!* returns a random number N drawn from a Poisson distribution *!
+!* with expected value U. I is a seed for *!
+!* the random number generator *!
+!* *!
+!* 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 PRAND(U,N)
+
+ REAL UTOP
+ PARAMETER(UTOP=188.)
+ INTEGER N
+ REAL P,R,Q,U
+
+! function declarations
+
+ REAL RAND
+
+ IF(U.GT.UTOP)STOP 'Failure in PRAND: expected value too high'
+ P=EXP(-U)
+ Q=P
+ R=RAND()
+ N=0
+100 IF(Q.GE.R)RETURN
+ N=N+1
+ P=P*U/N
+ Q=Q+P
+ GOTO 100
+
+END subroutine prand
diff --git a/source_code/version2.2_windows/prepglob.f b/source_code/version2.2_windows/prepglob.f
new file mode 100755
index 0000000000000000000000000000000000000000..0dcfb2eb73a0ceee5dbd1bdb7b8d0e52030847d9
--- /dev/null
+++ b/source_code/version2.2_windows/prepglob.f
@@ -0,0 +1,109 @@
+!*****************************************************************!
+!* *!
+!* 4C (FORESEE) Simulation Model *!
+!* *!
+!* *!
+!* Subroutines for: *!
+!* *!
+!* Contains the following subroutines: *!
+!* *!
+!* PREPARE_GLOBAL: general preparation of simulation *!
+!* contains internal subroutines: *!
+!* TOPMENU: main menu *!
+!* EDITSIM: edit simulation file names *!
+!* *!
+!* 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 prepare_global
+
+use data_simul
+use data_out
+use data_species
+use data_stand
+use data_site
+use data_tsort
+use data_climate
+
+implicit none
+
+character anf
+logical ex
+
+! main menu
+
+DO
+ call topmenu
+
+ if (anf == '2') then
+
+ call editsim
+ call testfile(simfile,ex)
+ if(ex .eqv. .false.) cycle
+ call readsim
+ if (flag_mult910) print *,' Check the data from file:'
+
+ ELSE if (anf == '1' .or. anf == ' ') then
+
+ call testfile(simfile,ex)
+ if(ex .eqv. .false.) cycle
+ call readsim
+ if (flag_mult910) print *,' Check the data from file:'
+
+ end if
+
+ if (ex .eqv. .true.) exit
+
+end DO
+
+call outtest
+
+contains
+
+!---------------------------------------------------------------
+
+SUBROUTINE topmenu
+
+print *,' ****************************************************'
+print *,' **************** Welcome to 4C *******************'
+print *,' ****************************************************'
+print *,' '
+print *,' 1 <Enter>.. Start with default simulation control: ',trim(simfile)
+print *,' '
+print *,' 2...........Edit simulation control file name'
+print *,' '
+print *,' ****************************************************'
+write(*,'(A)',advance='no') ' Make your choice: '
+read(*,'(A)') anf
+
+END subroutine topmenu
+
+!-----------------------------------------------------------------------------
+
+SUBROUTINE editsim
+
+ open(1000,file='user')
+
+ write(1000,'(A,A,A)',advance='no') ' Simulation control file (default= ',trim(simfile),'): '
+ read (*,'(A)') simfile
+ if (simfile == ' ') then
+ simfile = 'test0.sim'
+ end if
+
+end subroutine editsim
+
+!-----------------------------------------------------------------------------
+
+END subroutine prepare_global
+
+!**************************************************************
+
+
diff --git a/source_code/version2.2_windows/prepsite.f b/source_code/version2.2_windows/prepsite.f
new file mode 100755
index 0000000000000000000000000000000000000000..2aa34d4a036cb32f36784aa538a1d14ab70530bd
--- /dev/null
+++ b/source_code/version2.2_windows/prepsite.f
@@ -0,0 +1,2277 @@
+!*****************************************************************!
+!* *!
+!* 4C (FORESEE) *!
+!* *!
+!* *!
+!* Subroutines: *!
+!* PREPARE_SITE and PREPARE_CLIMATE *!
+!* *!
+!* Contains subroutines: *!
+!* *!
+!* PREPARE_SITE: *!
+!* preparation of site specific simulation parameters *!
+!* *!
+!* contains internal subroutines: *!
+!* SITEMENU: choice of inputs *!
+!* EDITFILE: edit filenames *!
+!* READSOIL: input of soil parameter *!
+!* READCN: input of C-N-parameter *!
+!* READVALUE: input of start values for *!
+!* soil water and C-N-modeling *!
+!* ALLOC_SOIL: allocate soil variables *!
+!* STAND_BAL_INI: allocate and init stand variables *!
+!* CONTROL_FILE: saving all parameters *!
+!* and start conditions for each site *!
+!* *!
+!* READDEPO: reading deposition data *!
+!* READREDN: reading values of redN *!
+!* READLIT: reading initialisation data of litter fractions *!
+!* *!
+!* PREPARE_CLIMATE: reading of site specific climate input data *!
+!* from file *!
+!* contains internal subroutines: *!
+!* READ_DWD *!
+!* READ_CLI *!
+!* CLIMFILL *!
+!* *!
+!* STORE_PARA: multi run - restore of changed parameter *!
+!* *!
+!* 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 prepare_site
+
+! input of site specific data
+
+ use data_climate
+ use data_inter
+ use data_manag
+ use data_mess
+ use data_out
+ use data_par
+ use data_simul
+ use data_site
+ use data_soil
+ use data_soil_cn
+ use data_species
+ use data_stand
+ use data_tsort
+ use data_frost
+
+
+implicit none
+integer i,ios,help, help_ip
+character a
+character :: text
+character(10) :: helpsim, text2
+logical:: ex=.TRUE.
+real parerr
+real, external :: avg_sun_incl
+character(100) :: helpx
+
+if (flag_trace) write (unit_trace, '(I4,I10,A)') iday, time_cur, ' prepare_site'
+
+WRITE(helpsim,'(I4)') anz_sim
+read(helpsim,*) anh
+
+
+IF(site_nr==1) THEN
+ help_ip=site_nr
+ELSE
+ help_ip=ip
+END IF
+
+! Initialization of climate data
+IF (flag_clim==1 .or. ip==1 .or. flag_multi .eq.5) THEN
+ call prepare_climate
+END IF
+
+if (flag_end .gt. 0) return
+ios=0; help=0
+do
+ if (ip==1 .and. flag_mult9) then
+ if (flag_trace) write (unit_trace, '(I4,I10,A,I3,A5,L5)') iday, time_cur, ' prepare_site ip=',ip,' ex=',ex
+ call readspec
+ call readsoil ! reading soil parameter
+ IF (flag_end .gt.0) return
+ if (flag_soilin .eq. 0) call readvalue ! Initialization of simulation start values for soil layers
+
+ ! biochar
+ if (flag_bc .gt. 0) call bc_appl
+
+ ! Deposition data
+ call readdepo
+
+ ! Input redN
+ if (flag_multi .ne. 4 .or. flag_multi .ne. 8 ) call readredN
+
+ flag_mult9 = .FALSE.
+ else
+ if (flag_trace) write (unit_trace, '(I4,I10,A,I3,A5,L5)') iday, time_cur, ' prepare_site ip=',ip,' ex=',ex
+
+ ! Deposition data
+ call readdepo
+
+ select case (flag_multi)
+ case (1,6)
+ call readspec
+ if (flag_soilin .eq. 0) call readvalue ! Initialization of simulation start values for soil layers
+ call readredN ! Input redN
+ call readsoil ! reading soil parameter
+
+ do
+ jpar = jpar + 1
+ if (vpar(jpar) .gt. -90.0) then
+ helpx = simpar(jpar)
+ call store_para(vpar(jpar), helpx, parerr)
+ IF (parerr .ne. 1.) then
+ CALL error_mess(time,'parameter variation: '//trim(simpar(jpar))//' not found',vpar(jpar))
+ write (*,*) '*** parameter variation: ', trim(simpar(jpar)), ' not found, see error log'
+ endif
+ else
+ exit
+ endif
+ enddo
+
+ ! biochar
+ if (flag_bc .gt. 0 .or. flag_decomp .gt. 100) call bc_appl
+
+ case (2,4)
+
+
+ call readsoil ! reading soil parameter
+ if (flag_soilin .eq. 0) call readvalue ! Initialization of simulation start values for soil layers
+
+ case (5)
+ call readspec
+ call readsoil
+ if (flag_soilin .eq. 0) call readvalue ! Initialization of simulation start values for soil layers
+ call readredN ! Input redN
+
+ case (7)
+ call assign_co2par
+ call readsoil ! reading soil parameter
+ if (flag_soilin .eq. 0) call readvalue ! Initialization of simulation start values for soil layers
+ call readredN ! Input redN
+
+ case (8, 9, 10)
+
+ call readsoil ! reading soil parameter
+ call readredN ! Input redN or test resp.
+ end select
+ endif
+exit
+enddo
+
+! Setting flag_inth and prec_stad_red from flag_int
+if (flag_int .lt. 1000) then
+ flag_inth = flag_int
+else
+ ! Conversion character ==> number and vice versa
+ write (helpsim,'(I4)') flag_int
+ text2 = helpsim(2:2)
+ read (text2,*) flag_inth
+ text2 = helpsim(3:4)
+ read (text2,*) prec_stand_red
+endif
+
+if (.not.flag_mult8910) then
+ unit_soil = getunit()
+ open (unit_soil,file=trim(dirout)//trim(site_name(help_ip))//'_soil.ini'//anh,status='replace')
+ WRITE (unit_soil,'(2A)') '! Soil initialisation, site name: ',site_name(help_ip)
+endif
+
+call stand_bal_ini !allocation of stand summation variables
+
+! Initialization of CO2
+call assign_co2par
+! Initialisation litter compartments
+call readlit
+! Initialization of soil model with profile data
+call soil_ini ! Aufruf ohne s_cn_ini
+! Initialization disturbances
+IF (flag_dis .eq. 1) CALL dist_ini
+! Initialization of stand
+call prepare_stand
+IF (flag_end .gt.0) return
+! calculation of latitude in radians
+xlat = lat/90.*pi*0.5
+! calculation of average sun inclination
+avg_incl = AVG_SUN_INCL(lat) ! degrees
+beta=avg_incl*PI/180 ! radians
+! read externally prescribed bud burst days
+CALL readbudb
+! Initialization management
+IF(flag_mg.ne.0.and. flag_mg.ne.5) call manag_ini
+IF(flag_mg.eq. 5) then
+ thin_dead = 1
+ allocate(thin_flag1(nspec_tree))
+ thin_flag1 = 0
+end if
+! Initialization of output file per site
+call prep_out
+call stand_balance
+call CROWN_PROJ
+call standup
+call root_ini ! initialisation of root distribution
+call s_cn_ini
+
+! Initialization of soil temperature model with stand data
+call s_t_ini
+
+! control file for saving simulation environment
+! output of first Litter-Input at start
+if(flag_mult8910 .and. (anz_sim .gt. 1)) then
+ continue
+else
+ IF ((ip .eq. 1 .or. flag_multi .eq. 1 .or. flag_multi .eq. 6) .and. (time_out .ne. -2) ) call control_file
+endif
+
+! hand over of the litter-initialising
+call litter
+if ((flag_decomp .eq. 20) .or. (flag_decomp .eq. 21)) then
+ call testfile(valfile(ip),ex)
+ if (ex .eqv. .true.) then
+ ios = 0
+ unit_litter = getunit()
+ open(unit_litter,file=valfile(ip),status='old',action='read')
+ if (flag_multi .ne. 9) print *,' *** Open file of litter input data ',valfile(ip),'...'
+ do
+ read(unit_litter,*) text
+ IF(text .ne. '!')then
+ backspace(unit_litter);exit
+ endif
+ enddo
+ endif
+endif
+call cn_inp
+
+! read flux data
+if (flag_eva .gt.10) call evapo_ini
+ ! yearly output
+ IF (time_out .gt. 0) THEN
+ IF (mod(time,time_out) .eq. 0) CALL outyear (1)
+ IF (mod(time,time_out) .eq. 0) CALL outyear (2)
+ ENDIF
+
+ contains
+
+!-------------------------------------------------------------------------------
+
+subroutine readsoil ! Input of soil parameter
+
+use data_soil_t
+use data_site
+
+implicit none
+
+integer :: inunit, helpnl, helpnr
+real helpgrw, hlong, hlat
+character :: text
+character(30) :: hor, boart, helpid
+
+if (flag_trace) write (unit_trace, '(I4,I10,A)') iday, time_cur, ' readsoil'
+
+! Setting of flag_surf from flag_cond
+select case (flag_cond)
+
+case (0,1,2,3)
+ flag_surf = 0
+
+case (10,11,12,13)
+ flag_surf = 1
+
+case (20,21,22,23)
+ flag_surf = 2
+
+case (30,31,32,33)
+ flag_surf = 3
+end select
+
+! Setting of flag_bc from flag_decomp
+if (flag_decomp .ge. 100) then
+ flag_decomp = flag_decomp - 100
+ flag_bc = 1
+else
+ flag_bc = 0
+endif
+
+call testfile(sitefile(ip),ex)
+IF (ex .eqv. .true.) then
+ inunit = getunit()
+ ios=0
+ open(inunit,file=sitefile(ip),iostat=ios,status='old',action='read')
+ if (.not.flag_mult8910) then
+ print *,'***** Reading soil parameter from file ',sitefile(ip),'...'
+ write (unit_err, *) 'Soil parameter from file ',trim(sitefile(ip))
+ endif
+
+ do
+ read(inunit,*) text
+ IF(text .ne. '!')then
+ backspace(inunit)
+ exit
+ endif
+ enddo
+
+ if (flag_multi .eq. 8.or. flag_multi.eq.5.or. flag_mult910) then
+ read(inunit,*) text
+ IF((text .eq. 'N') .or. (text .eq. 'n'))then
+ flag_soilin = 3
+ else
+ flag_soilin = 2
+ backspace(inunit)
+ endif
+ else
+ read(inunit,*) text
+ IF((text .eq. 'N') .or. (text .eq. 'n'))then
+ flag_soilin = 1
+ else
+ flag_soilin = 0
+ backspace(inunit)
+ endif
+ soilid(ip) = valfile(ip)
+ endif
+ if ((text .eq. 'S') .or. (text .eq. 's'))then
+ flag_soilin = 4
+ read(inunit,*) text
+ endif
+ if (.not.flag_mult8910) then
+ write (unit_err, *) 'Soil identity number ', trim(soilid(ip))
+ write (unit_err, *) 'Climate ID ', trim(clim_id(ip))
+ endif
+
+ if (flag_soilin .eq. 1 .or. flag_soilin .ge. 3) then
+ flag_hum = 1
+ endif
+
+ if (flag_cond .ge. 40) then
+ flag_hum = 0
+ endif
+
+ select case (flag_soilin)
+
+ case (0,1) ! single files f. j. site
+
+ read (inunit,*,iostat=ios) long
+ read (inunit,*,iostat=ios) lat
+ read (inunit,*,iostat=ios) nlay
+ read (inunit,*,iostat=ios) nroot_max
+ read (inunit,*,iostat=ios) helpgrw
+
+ if (helpgrw .gt. 1) then
+ grwlev = helpgrw
+ else
+ fakt = helpgrw
+ grwlev = 1000.
+ endif
+
+ read (inunit,*,iostat=ios) w_ev_d
+ read(inunit,*,iostat=ios) k_hum ! mineralization constants of humus
+ read(inunit,*,iostat=ios) k_hum_r
+ read(inunit,*,iostat=ios) k_nit ! nitrification constant
+
+ IF(help==0) call alloc_soil
+ read (inunit,*,iostat=ios) text
+ select case (flag_soilin)
+ case (0) ! old input structure
+ do i = 1, nlay
+ read (inunit,*,iostat=ios) text
+ read (inunit,*,iostat=ios) thick(i),pv_v(i),dens(i),f_cap_v(i), &
+ wilt_p_v(i),spheat(i),phv(i),wlam(i)
+ end do
+ skelv = 0.
+
+ case(1) ! new input structure
+ do i = 1, nlay
+ read (inunit,*,iostat=ios) helpnr, thick(i),pv_v(i),f_cap_v(i),wilt_p_v(i), &
+ dens(i),spheat(i),phv(i),wlam(i),skelv(i), sandv(i),clayv(i),humusv(i),&
+ C_hum(i), N_hum(i),NH4(i),NO3(i)
+ if (flag_wurz .eq. 4 .or. flag_wurz .eq. 6) then
+ if (phv(i) .le. 0.01) phv(i)=6.0 ! if flag_wurz 4 or 6 is used for calculation a pH-value is assumed
+ endif
+ end do
+ end select ! flag_soilin (0,1)
+
+ if (.not.flag_mult8910) print *, ' '
+ IF (ios .ne.0) then
+ print *,' >>>FORESEE message: Error during reading soil data!'
+ WRITE(*,'(A)',advance='no') ' Stop program (y/n)? '
+ read *, a
+ IF ( a .eq. 'y' .or. a .eq. 'Y') then
+ print *, ' STOP program!'
+ stop
+ endif
+ IF (help==1) call dealloc_soil
+ print *,' Check your input choice!!!'
+ endif ! ios
+
+ case (2) ! all sites are read from one file; old structure
+
+ ios = 0
+ do while (ios .eq. 0)
+ read (inunit,*,iostat=ios) helpid, helpnl, helpnr
+ if (trim(soilid(ip)) .ne. trim(helpid)) then
+ do i = 1, helpnl
+ read (inunit,*,iostat=ios) helpid
+ enddo
+ else
+ nlay = helpnl
+ nroot_max = helpnr
+ if (help==0) call alloc_soil
+ do i = 1, nlay
+ read (inunit,*,iostat=ios) helpnl, hor, boart, depth(i), thick(i),pv_v(i),dens(i), &
+ f_cap_v(i), wilt_p_v(i), spheat(i),phv(i),wlam(i), &
+ C_hum(i), N_hum(i), NH4(i), NO3(i), temps(i)
+ enddo
+ lat = latitude(ip)
+ grwlev = gwtable(ip)
+ exit
+ endif
+ enddo
+
+ IF (ios .lt. 0) then
+ if (.not.flag_mult8910) print *,' >>>FORESEE message: soil_id ', soilid(ip), ' not found'
+ if (.not.flag_mult8910) print *,' Check your input choice!!!'
+ if (help==1) call dealloc_soil
+ CALL error_mess(time,"soil identificator not found "//adjustl(soilid(ip))//" ip No. ",real(help_ip))
+ flag_end = 5
+ return
+ ENDIF ! ios
+
+ skelv = 0.
+
+ case (3) ! all sites are read from one file; new structure
+
+ ios = 0
+ do while (ios .eq. 0)
+ read (inunit,*,iostat=ios) helpid, helpnl, helpnr
+ if (trim(soilid(ip)) .ne. trim(helpid)) then
+ do i = 1, helpnl
+ read (inunit,*,iostat=ios) helpid
+ enddo
+ else
+ nlay = helpnl
+ nroot_max = helpnr
+ if (help==0) call alloc_soil
+ do i = 1, nlay
+ read (inunit,*,iostat=ios) helpnr, hor, boart, depth(i), thick(i),pv_v(i),f_cap_v(i), &
+ wilt_p_v(i),dens(i),spheat(i),phv(i),wlam(i),skelv(i), sandv(i), &
+ clayv(i),humusv(i),C_hum(i), N_hum(i),NH4(i),NO3(i)
+ if (flag_wurz .eq. 4 .or. flag_wurz .eq. 6) then
+ if (phv(i) .le. 0.01) phv(i)=6.0 ! if flag_wurz 4 or 6 is used for calculation a pH-value is assumed
+ endif
+ end do
+ lat = latitude(ip)
+ grwlev = gwtable(ip)
+ exit
+ endif
+ enddo
+ IF (ios .lt. 0) then
+ if (.not.flag_mult8910) print *,' >>>FORESEE message: soil_id ', soilid(ip), ' not found'
+ if (.not.flag_mult8910) print *,' Check your input choice!!!'
+ if (help==1) call dealloc_soil
+ CALL error_mess(time,"soil identificator not found"//adjustl(soilid(ip))//"ip No.",real(help_ip))
+ flag_end = 5
+ return
+ ENDIF ! ios
+
+ case (4) ! one file several sites
+
+ if (.not.flag_mult8910) print *,' Reading soil model parameter from soil type file... ', soilid(ip)
+
+ ios = 0
+ do while (ios .eq. 0)
+ read (inunit,*,iostat=ios) helpid
+ if (trim(soilid(ip)) .ne. trim(helpid)) then
+ read (inunit,*,iostat=ios) text
+ read (inunit,*,iostat=ios) text
+ read (inunit,*,iostat=ios) helpnl
+ do i = 1, helpnl+6
+ read (inunit,*,iostat=ios) boart
+ enddo
+ read (inunit,*,iostat=ios) boart
+ else
+ read (inunit,*,iostat=ios) hlong
+ read (inunit,*,iostat=ios) hlat
+ read (inunit,*,iostat=ios) nlay
+ read (inunit,*,iostat=ios) nroot_max
+ read (inunit,*,iostat=ios) helpgrw
+ if (flag_multi .eq. 8.or. flag_multi.eq.5.or. flag_mult910) then
+ if (abs(latitude(ip)) .gt. 90.) lat = latitude(ip)
+ grwlev = gwtable(ip)
+ else
+ if (helpgrw .gt. 1) then
+ grwlev = helpgrw
+ else
+ fakt = helpgrw
+ grwlev = 1000.
+ endif
+ long = hlong
+ lat = hlat
+ endif
+ read (inunit,*,iostat=ios) w_ev_d
+ read(inunit,*,iostat=ios) k_hum ! mineralization constants of humus
+ read(inunit,*,iostat=ios) k_hum_r
+ read(inunit,*,iostat=ios) k_nit ! nitrification constant
+
+ IF(help==0) call alloc_soil
+
+ read (inunit,*,iostat=ios) text
+ do i = 1, nlay
+ read (inunit,*,iostat=ios) helpnr, thick(i),pv_v(i),f_cap_v(i),wilt_p_v(i), &
+ dens(i),spheat(i),phv(i),wlam(i),skelv(i), sandv(i),clayv(i),humusv(i),&
+ C_hum(i), N_hum(i),NH4(i),NO3(i)
+ if (flag_wurz .eq. 4 .or. flag_wurz .eq. 6) then
+ if (phv(i) .le. 0.01) phv(i)=6.0 ! if flag_wurz 4 or 6 is used for calculation a pH-value is assumed
+ endif
+ end do
+ IF (ios .ne.0) then
+ if (.not.flag_mult8910) print *,' >>>FORESEE message: Error during reading soil data!'
+ WRITE(*,'(A)',advance='no') ' Stop program (y/n)? '
+ read *, a
+ IF ( a .eq. 'y' .or. a .eq. 'Y') then
+ print *, ' STOP program!'
+ stop
+ endif
+ IF (help==1) call dealloc_soil
+ if (.not.flag_mult8910) print *,' Check your input choice!!!'
+ endif ! ios
+ exit
+ endif
+ enddo
+
+ if (.not.flag_mult8910) print *, ' '
+ IF (ios .lt. 0) then
+ if (.not.flag_mult8910) then
+ print *,' >>>FORESEE message: soil_id ', soilid(ip), ' not found'
+ print *,' Check your input choice!!!'
+ endif
+ if (help==1) call dealloc_soil
+ CALL error_mess(time,"soil identificator not found"//adjustl(soilid(ip))//"ip No.",real(help_ip))
+ flag_end = 5
+ return
+ ENDIF ! ios
+
+ end select ! flag_soilin
+ close(inunit)
+endif ! ex
+
+if (nroot_max .lt. 0) then
+ do i=1, nlay
+ if (C_hum(i) .gt. zero) nroot_max = i
+ enddo
+endif
+if (.not.flag_mult8910) then
+ write (unit_err, *) 'Latitude ',lat
+ write (unit_err,*)
+endif
+
+end subroutine readsoil
+
+!-------------------------------------------------------------------------
+
+subroutine readvalue ! Input of cn-parameters and start values for soil model
+
+integer :: inunit
+character :: text
+
+if (flag_trace) write (unit_trace, '(I4,I10,A)') iday, time_cur, ' readvalue'
+
+call testfile(valfile(ip),ex)
+IF (ex .eqv. .true.) then
+ ios = 0
+ inunit = getunit()
+ open(inunit,file=valfile(ip),status='old',action='read')
+ if (.not.flag_mult8910) print *,' *** Reading initial soil values from file ',valfile(ip),'...'
+ do
+ read(inunit,*) text
+ IF(text .ne. '!')then
+ backspace(inunit);exit
+ endif
+ enddo
+ ! Soil temperature
+ read(inunit,*,iostat=ios) text
+ read(inunit,*,iostat=ios) (temps(i),i=1,nlay)
+ ! C-content of humus
+ read(inunit,*,iostat=ios) text
+ read(inunit,*,iostat=ios) (C_hum(i),i=1,nlay)
+ ! N-content of humus
+ read(inunit,*,iostat=ios) text
+ read(inunit,*,iostat=ios) (N_hum(i),i=1,nlay)
+ ! NH4-content
+ read(inunit,*,iostat=ios) text
+ read(inunit,*,iostat=ios) (NH4(i),i=1,nlay)
+ ! NO3-content
+ read(inunit,*,iostat=ios) text
+ read(inunit,*,iostat=ios) (NO3(i),i=1,nlay)
+endif
+
+IF (ios .ne. 0) then
+print *,' >>>FORESEE message: Error during reading start values!'
+WRITE(*,'(A)',advance='no') ' Stop program (y/n)? '
+read *, a
+ IF ( a .eq. 'y' .or. a .eq. 'Y') then
+ print *, ' STOP program!'
+ stop
+ ELSE
+ call dealloc_soil
+ print *,' Check your input choice!!!'
+ end if
+endif
+close(inunit)
+
+end subroutine readvalue
+
+!--------------------------------------------------------------------------
+
+subroutine alloc_soil
+use data_soil_t
+use data_soil
+
+if (flag_trace) write (unit_trace, '(I4,I10,A)') iday, time_cur, ' alloc_soil'
+
+help=0
+allocate(thick(nlay))
+allocate(mid(nlay))
+allocate(depth(nlay))
+allocate(pv(nlay))
+allocate(pv_v(nlay))
+allocate(dens(nlay))
+allocate(f_cap_v(nlay))
+allocate(field_cap(nlay))
+allocate(wilt_p(nlay))
+allocate(wilt_p_v(nlay))
+allocate(vol(nlay))
+allocate(quarzv(nlay))
+allocate(sandv(nlay))
+allocate(BDopt(nlay))
+allocate(clayv(nlay))
+allocate(siltv(nlay))
+allocate(humusv(nlay))
+allocate(fcaph(nlay))
+allocate(wiltph(nlay))
+allocate(pvh(nlay))
+allocate(dmass(nlay))
+allocate(skelv(nlay))
+allocate(skelfact(nlay))
+allocate(spheat(nlay))
+allocate(phv(nlay))
+allocate(wlam(nlay))
+allocate(wats(nlay))
+allocate(watvol(nlay))
+allocate(wat_res(nlay))
+wat_res = 0.
+
+allocate(perc(nlay))
+allocate(wupt_r(nlay))
+allocate(wupt_ev(nlay))
+allocate(s_drought(nlay))
+allocate(root_fr(nlay))
+!allocate(dp_rfr(nlay))
+allocate(temps(nlay))
+allocate (C_opm(nlay))
+allocate (C_hum(nlay))
+allocate (C_opmfrt(nlay))
+allocate (C_opmcrt(nlay))
+allocate (N_opm(nlay))
+allocate (N_hum(nlay))
+allocate (N_opmfrt(nlay))
+allocate (N_opmcrt(nlay))
+allocate (NH4(nlay))
+allocate (NO3(nlay))
+allocate (Nupt(nlay))
+allocate (Nmin(nlay))
+allocate (rmin_phv(nlay))
+allocate (rnit_phv(nlay))
+allocate (cnv_opm(nlay))
+allocate (cnv_hum(nlay))
+allocate(slit(nspecies))
+allocate(slit_1(nspecies))
+
+if (flag_bc .gt. 0) then
+ allocate (C_bc(nlay))
+ allocate (N_bc(nlay))
+ C_bc = 0.
+ N_bc = 0.
+endif
+
+do i=1,nspecies
+slit(i)%C_opm_frt = 0.
+slit(i)%N_opm_frt = 0.
+slit(i)%C_opm_crt = 0.
+slit(i)%N_opm_crt = 0.
+slit(i)%C_opm_tb = 0.
+slit(i)%N_opm_tb = 0.
+slit(i)%C_opm_stem = 0.
+slit(i)%N_opm_stem = 0.
+enddo
+
+nlay2 = nlay+2
+mfirst = 1
+
+allocate (sh(mfirst:nlay2))
+allocate (sv(mfirst:nlay2))
+allocate (sb(mfirst:nlay2))
+allocate (sbt(mfirst:nlay2))
+allocate (t_cb(mfirst:nlay2))
+allocate (t_cond(mfirst:nlay2))
+allocate (h_cap(mfirst:nlay2))
+allocate (sxx(mfirst:nlay2))
+allocate (svv(mfirst:nlay2))
+allocate (svva(mfirst:nlay2))
+allocate (soh(mfirst:nlay2))
+allocate (son(mfirst:nlay2+1))
+help=1
+C_opm = 0
+allocate(fr_loss(nlay))
+allocate(redis(nlay))
+
+end subroutine alloc_soil
+
+!------------------------------------------------------------------
+subroutine stand_bal_ini
+
+use data_stand
+
+implicit none
+
+integer i
+
+allocate(diam_class(num_class, nspecies)); diam_class=0
+allocate(diam_class_t(num_class, nspecies)); diam_class_t=0
+allocate(diam_class_h(num_class,nspecies)); diam_class_h=0
+allocate(diam_class_age(num_class,nspecies)); diam_class_age=0
+allocate(diam_class_mvol(num_class,nspecies)); diam_class_mvol=0
+allocate(diam_classm(num_class,nspecies)); diam_classm=0
+allocate(diam_classm_h(num_class,nspecies)); diam_classm_h=0
+allocate(height_class(num_class)); height_class =0
+
+! array of potential litter (dead stems and twigs/branches for the next years
+allocate(dead_wood(nspec_tree))
+do i = 1,nspec_tree
+ allocate(dead_wood(i)%C_tb(lit_year))
+ allocate(dead_wood(i)%N_tb(lit_year))
+ allocate(dead_wood(i)%C_stem(lit_year))
+ allocate(dead_wood(i)%N_stem(lit_year))
+ dead_wood(i)%C_tb = 0.
+ dead_wood(i)%N_tb = 0.
+ dead_wood(i)%C_stem = 0.
+ dead_wood(i)%N_stem = 0.
+enddo
+
+end subroutine stand_bal_ini
+
+!--------------------------------------------------------------
+
+subroutine control_file ! saving simulation parameter and start conditions for each site
+real buckdepth
+character(8) actdate
+character(10) acttime
+character(150) site_help
+integer help_ip, j
+TYPE(Coh_Obj), Pointer :: help_coh ! pointer to cohort list
+
+IF(site_nr==1) THEN
+ help_ip=site_nr
+ELSE
+ help_ip=ip
+END IF
+
+! Write soil initialisation file
+if (flag_mult8910) then
+ site_help = site_name1
+else
+ site_help = site_name(help_ip)
+endif
+
+if (.not.flag_mult8910 .or. (flag_mult8910 .and. anh .eq. "1") .or. (flag_mult8910 .and. time_out .gt. 0.)) then
+ if (.not.flag_mult8910) then
+ WRITE (unit_soil,'(26A)') 'Layer',' Depth(cm)',' F-cap(mm)',' F-cap(Vol%)',' Wiltp(mm)', &
+ ' Wiltp(Vol%)',' Pore vol.',' Skel.(Vol%)',' Density',' Spheat',' pH',' Wlam', &
+ ' Water(mm)',' Water(Vol%)',' Soil-temp.',' C_opm g/m2', &
+ ' C_hum g/m2',' N_opm g/m2',' N_hum g/m2',' NH4 g/m2',' NO3 g/m2',' humus part',' d_mass g/m2', ' Clay',' Silt',' Sand'
+ do i = 1,nlay
+ WRITE (unit_soil,'(I5,2F10.2,3F12.2,F10.2,F12.2,4F8.2,F10.2,F12.2, 5F11.2,2F9.4,2E12.4, 3F6.1)') i,depth(i),field_cap(i),f_cap_v(i),wilt_p(i), &
+ wilt_p_v(i),pv_v(i), skelv(i)*100., dens(i),spheat(i),phv(i),wlam(i), &
+ wats(i),watvol(i),temps(i),c_opm(i),c_hum(i),n_opm(i), n_hum(i),nh4(i),no3(i),humusv(i),dmass(i), clayv(i)*100., siltv(i)*100., sandv(i)*100.
+
+ end do
+ endif
+
+ ! Write control file
+ call date_and_time(actdate, acttime)
+ unit_ctr = getunit()
+ open(unit_ctr,file=trim(dirout)//trim(site_help)//'.ctr'//anh,status='replace')
+ WRITE(unit_ctr,'(2A)') '*** Site name: ',site_name(help_ip)
+ WRITE(unit_ctr,'(2A)') ' Appendix ' ,anh
+ WRITE(unit_ctr,'(A,F7.2)') ' Longitude: ', long
+ WRITE(unit_ctr,'(A,F7.2)') ' Latitude: ', lat
+ WRITE(unit_ctr,*) ' '
+ WRITE(unit_ctr,'(10A)') ' ---- Version: v2.2 ---- '
+ WRITE(unit_ctr,'(10A)') ' Date: ',actdate(7:8),'.',actdate(5:6),'.',actdate(1:4), &
+ ' Time: ',acttime(1:2),':',acttime(3:4)
+ WRITE(unit_ctr,'(A,A)') ' Simulation control file: ',trim(simfile)
+ WRITE(unit_ctr,*) ' '
+ WRITE(unit_ctr,'(A)') '*** Data files:'
+ IF(flag_clim==1)then
+ WRITE(unit_ctr,'(A,A)') ' Climfile: ',trim(climfile(ip))
+ ELSE
+ WRITE(unit_ctr,'(A,A)') ' Climfile: ',trim(climfile(1))
+ endif
+ WRITE(unit_ctr,'(A,A)') ' Sitefile: ',trim(sitefile(help_ip))
+ WRITE(unit_ctr,'(A,A)') ' Start value file: ',trim(valfile(help_ip))
+
+ ! Initialization of stand
+ IF( flag_multi==3 .OR. (site_nr>1 .AND. flag_stand>0) ) THEN
+ WRITE(unit_ctr,'(A,A)') ' Stand initialization: ',trim(treefile(ip))
+ ELSE IF( ip==1 .AND. flag_stand>0) THEN
+ WRITE(unit_ctr,'(A,A)') ' Stand initialization: ',trim(treefile(ip))
+ ELSE IF (flag_stand==0) THEN
+ WRITE(unit_ctr,'(A,A)') ' Stand initialization: none'
+ endif
+ IF (lmulti) WRITE(unit_ctr,'(A,A)') ' Stand identificator: ', adjustl(standid(ip))
+ WRITE(unit_ctr,*) ' '
+ IF(flag_mg.ne.0 .and. flag_mg.ne.5) then
+ WRITE(unit_ctr,'(A,A)') ' Management control file: ',trim(manfile(ip))
+ ELSE
+ WRITE(unit_ctr,'(A)') ' Management: none'
+ endif
+ WRITE(unit_ctr,'(A,A)') ' Deposition file: ',trim(depofile(ip))
+ WRITE(unit_ctr,'(A,A)') ' N reduction file: ',trim(redfile(ip))
+ WRITE(unit_ctr,'(A,A)') ' Litter initialisation file: ',trim(litfile(ip))
+ if (flag_stat .gt. 0) WRITE(unit_ctr,'(A,A)') ' File with measurements: ',trim(mesfile(1))
+ WRITE(unit_ctr,*) ' '
+ WRITE(unit_ctr,'(A)') '*** Soil description '
+ WRITE(unit_ctr,'(A,I3)') ' Number of soil layers: ',nlay
+ WRITE(unit_ctr,'(A,I3)') ' Number of rooting layers: ',nroot_max
+ WRITE(unit_ctr,'(A,I3)') ' Ground water from layer: ',nlgrw
+ WRITE(unit_ctr,'(A,F5.1)') ' Evaporation depth (cm): ',w_ev_d
+ call bucket(bucks_100, bucks_root, buckdepth)
+ buckdepth = buckdepth/100
+ WRITE(unit_ctr,'(A,F5.2,A,F7.2)') ' Bucket size (mm), ', buckdepth,' m depth: ',bucks_100
+ WRITE(unit_ctr,'(A,F7.2)') ' Bucket size (mm) of rooting zone: ',bucks_root
+ WRITE(unit_ctr,*) ' '
+ WRITE(unit_ctr,'(A)') '*** Soil water conditions'
+ WRITE(unit_ctr,'(12A)') 'Layer ','Depth(cm) ','F-cap(mm) ','F-cap(Vol%) ','Wiltp(mm) ', &
+ 'Wiltp(Vol%) ','Pore vol. ','Density ','Spheat ','pH-value ',' Wlam',' skel. '
+ do i = 1,nlay
+ WRITE(unit_ctr,'(I5,12F10.2)') i,depth(i),field_cap(i),f_cap_v(i),wilt_p(i), &
+ wilt_p_v(i),pv_v(i),dens(i),spheat(i),phv(i),wlam(i),skelv(i)
+ end do
+ WRITE(unit_ctr,*) ' '
+ WRITE(unit_ctr,'(A)') '*** Soil initial values'
+ WRITE(unit_ctr,'(9A)') 'Layer ','Water-cont. ','Soil-temp. ','C_opm ', &
+ 'C_hum ','N_opm ','N_hum ','NH4-cont. ','NO3-cont '
+ do i=1,nlay
+ WRITE(unit_ctr,'(I5, 2F10.2, 6F10.4)') i,wats(i),temps(i),c_opm(i),c_hum(i),n_opm(i), &
+ n_hum(i),nh4(i),no3(i)
+ end do
+ WRITE(unit_ctr,*) ' '
+ WRITE(unit_ctr,'(A)') ' N_tot C_tot N_antot N_humtot C_humtot C_opm_fol C_opm_tb C_opm_frt C_opm_crt C_opm_stem '
+ WRITE(unit_ctr,'(10F12.4)') N_tot, C_tot, N_an_tot, N_hum_tot, C_hum_tot, C_opm_fol, C_opm_tb, C_opm_frt, C_opm_crt, C_opm_stem
+ WRITE(unit_ctr,*) ' '
+ WRITE(unit_ctr,'(A)',advance='no') 'Mineralization constant of humus - humus layer (k_hum): '
+ WRITE(unit_ctr,'(F10.5)') k_hum
+ WRITE(unit_ctr,'(A)',advance='no') 'Mineralization constant of humus - mineral soil (k_hum_r): '
+ WRITE(unit_ctr,'(F10.5)') k_hum_r
+ WRITE(unit_ctr,'(A)',advance='no') 'Nitrification constant (k_nit): '
+ WRITE(unit_ctr,'(F10.5)') k_nit
+ WRITE(unit_ctr,*) ' '
+ if (flag_bc .gt.0) then
+ WRITE(unit_ctr,'(A)') '*** Biochar application '
+ WRITE(unit_ctr,'(A)') ' year C-content(%) C/N-ratio depth mass(kg/ha dry mass)'
+ do j = 1, n_appl_bc
+ WRITE(unit_ctr,'(I7,F14.1, F11.1, I7, F18.1)') &
+ y_bc(j), cpart_bc(j), cnv_bc(j), bc_appl_lay(j), C_bc_appl(j)
+ enddo
+ WRITE(unit_ctr,'(F10.5)')
+ endif
+ WRITE(unit_ctr,*) ' '
+ WRITE(unit_ctr,'(A)') '*** Stand initialisation'
+ WRITE(unit_ctr,'(A)')' Coh x_fol x_frt x_sap x_hrt x_Ahb height x_hbole x_age n sp DC DBH'
+ help_coh => pt%first
+ DO WHILE (ASSOCIATED(help_coh))
+ WRITE(unit_ctr,'(I5,5f12.5,2f10.0,i7,f7.0,i7, 2f12.5)') help_coh%coh%ident, help_coh%coh%x_fol, help_coh%coh%x_frt, help_coh%coh%x_sap, help_coh%coh%x_hrt, &
+ help_coh%coh%x_Ahb, help_coh%coh%height, help_coh%coh%x_hbole, help_coh%coh%x_age, &
+ help_coh%coh%nTreeA,help_coh%coh%species, help_coh%coh%dcrb, help_coh%coh%diam
+ help_coh => help_coh%next
+ END DO
+ WRITE(unit_ctr,*) ' '
+ WRITE(unit_ctr,'(A)') '*** Simulation control'
+ WRITE(unit_ctr,'(A66,I4)') 'Run option: ',flag_multi
+ WRITE(unit_ctr,'(A66,I4)') 'Start year: ',time_b
+ WRITE(unit_ctr,'(A66,I4)') 'Number of simulation years - year: ', year
+ WRITE(unit_ctr,'(A60,F12.1)') 'Patch size [m²] - kpatchsize: ',kpatchsize
+ WRITE(unit_ctr,'(A60,F12.1)') 'Thickness of leaf layers - dz: ',dz
+ WRITE(unit_ctr,'(A66,I4)') 'Time step for photosynthesis calculations (days) - ns_pro: ',ns_pro
+ WRITE(unit_ctr,'(A66,I4)') 'Mortality (0-OFF,1-ON stress, 2- ON stress+intr) - flag_mort: ',flag_mort
+ WRITE(unit_ctr,'(A66,I4)') 'Regeneration (0-OFF,1-ON, 2-weekly growth of seedl.) - flag_reg: ',flag_reg
+ WRITE(unit_ctr,'(A66,I4)') 'use FORSKA for regeneration (0-OFF,1-ON) - flag_forska: ',flag_forska
+ WRITE(unit_ctr,'(A66,I4)') 'Stand initialization (0-no,1-from *.ini,2-generate) - flag_stand: ',flag_stand
+ WRITE(unit_ctr,'(A66,I4)') 'Ground vegetation initialization (0-no,1-generate) - flag_sveg: ',flag_sveg
+ WRITE(unit_ctr,'(A66,I4)') 'Stand management (0-no,1-yes, 2 - seed once) - flag_mg: ',flag_mg
+ WRITE(unit_ctr,'(A66,I4)') 'Disturbance (0-OFF, 1-ON ) - flag_dis: ',flag_dis
+ WRITE(unit_ctr,'(A66,I4)') 'Light absoption algorithm (1,2,3,4) - : ',flag_light
+ WRITE(unit_ctr,'(A66,I4)') 'Foliage-height relationship (0,1) - flag_folhei: ',flag_folhei
+ WRITE(unit_ctr,'(A66,I4)') 'Volume function trunc (0,1) - flag_volfunc: ',flag_volfunc
+ WRITE(unit_ctr,'(A66,I4)') 'Respiration model (0-0.5*NPP,1-organ specific) - flag_resp: ',flag_resp
+ WRITE(unit_ctr,'(A66,I4)') 'Limitation (0-NO,1-water, 2-N, 3-water+N) - flag_limi: ',flag_limi
+ WRITE(unit_ctr,'(A66,I4)') 'Flag for decomposition model - flag_decomp: ',flag_decomp
+ WRITE(unit_ctr,'(A66,I4)') 'Root spec. activity (0-const,1-varying) - flag_sign: ',flag_sign
+ WRITE(unit_ctr,'(A66,I4)') 'Water uptake function soil (1,2,3,4) - flag_wred: ',flag_wred
+ WRITE(unit_ctr,'(A66,I4)') 'Root distribution - flag_wurz: ',flag_wurz
+ WRITE(unit_ctr,'(A66,I4)') 'Heat conductance - flag_cond: ',flag_cond
+ WRITE(unit_ctr,'(A66,I4)') 'Interception - flag_int: ',flag_int
+ WRITE(unit_ctr,'(A66,I4)') 'Evapotranspiration - flag_eva: ',flag_eva
+ WRITE(unit_ctr,'(A66,I4)') 'CO2 (0-constant,1-historic increase,2-step change)- flag_co2: ',flag_co2
+ WRITE(unit_ctr,'(A66,I4)') 'Sort flag - flag_sort: ',flag_sort
+ WRITE(unit_ctr,'(A66,I4)') 'wpm flag - flag_wpm: ',flag_wpm
+ WRITE(unit_ctr,'(A66,I4)') 'Analysis of measurements - flag_stat: ',flag_stat
+ WRITE(unit_ctr,*) ' '
+ WRITE(unit_ctr,'(A66,A)') 'Species parameter file: ',trim(specfile(help_ip))
+ WRITE(unit_ctr,*) ' '
+ WRITE(unit_ctr,'(A)') '*** Species parameter description'
+ WRITE(unit_ctr,'(A51,I4)') ' Species number: ', nspecies
+ WRITE(unit_ctr,'(A51,I4)') ' Number of tree species: ', nspec_tree
+ WRITE(unit_ctr,*) ' ********** '
+ WRITE(unit_ctr,'(A25,A9,2X,A30)') 'Short Name', ' Spec-Nr', 'Latin Name '
+ WRITE(unit_ctr,*) ' '
+ do i=1,nspecies
+ WRITE(unit_ctr,'(A25,I9,2X,A30)') trim(spar(i)%species_short_name), i, spar(i)%species_name
+ enddo
+ WRITE(unit_ctr,*) ' ********** '
+ WRITE(unit_ctr,'(A51,15A16)') ' Species name: ', (trim(spar(i)%species_short_name),i=1,nspecies)
+ WRITE(unit_ctr,1010) ' Maximal age - max_age: ', (spar(i)%max_age,i=1,nspecies)
+ WRITE(unit_ctr,1010) ' Stress rec. time - yrec: ', (spar(i)%yrec,i=1,nspecies)
+ WRITE(unit_ctr,1010) ' Shade tolerance - stol: ', (spar(i)%stol,i=1,nspecies)
+ WRITE(unit_ctr,1000) ' Extinction coeff - pfext: ', (spar(i)%pfext,i=1,nspecies)
+ WRITE(unit_ctr,1000) ' Root activity rate - sigman: ', (spar(i)%sigman,i=1,nspecies)
+ WRITE(unit_ctr,1000) ' Respiration coeff - respcoeff: ', (spar(i)%respcoeff,i=1,nspecies)
+ WRITE(unit_ctr,1000) ' Growth resp. par. - prg: ', (spar(i)%prg,i=1,nspecies)
+ WRITE(unit_ctr,1000) ' Maint.resp.par./sapwood - prms: ', (spar(i)%prms,i=1,nspecies)
+ WRITE(unit_ctr,1000) ' Maint.resp.par./fineroot - prmr: ', (spar(i)%prmr,i=1,nspecies)
+ WRITE(unit_ctr,1000) ' Senesc.par. foliage - psf: ', (spar(i)%psf,i=1,nspecies)
+ WRITE(unit_ctr,1000) ' Senesc.par. sapwood - pss: ', (spar(i)%pss,i=1,nspecies)
+ WRITE(unit_ctr,1000) ' Senesc.par. fineroot - psr: ', (spar(i)%psr,i=1,nspecies)
+ WRITE(unit_ctr,1000) ' N/C ratio of biomass - pcnr: ', (spar(i)%pcnr,i=1,nspecies)
+ WRITE(unit_ctr,1000) ' N concentration of foliage - ncon_fol: ', (spar(i)%ncon_fol,i=1,nspecies)
+ WRITE(unit_ctr,1000) ' N concentration of fine roots - ncon_frt: ', (spar(i)%ncon_frt,i=1,nspecies)
+ WRITE(unit_ctr,1000) ' N concentration of coarse roots - ncon_crt: ', (spar(i)%ncon_crt,i=1,nspecies)
+ WRITE(unit_ctr,1000) ' N concentration of twigs and branches - ncon_tbc: ', (spar(i)%ncon_tbc,i=1,nspecies)
+ WRITE(unit_ctr,1000) ' N concentration of stemwood - ncon_stem: ', (spar(i)%ncon_stem,i=1,nspecies)
+ WRITE(unit_ctr,1000) ' Reallocation parameter of foliage - reallo_fol: ', (spar(i)%reallo_fol,i=1,nspecies)
+ WRITE(unit_ctr,1000) ' Reallocation parameter of fine root - reallo_frt: ', (spar(i)%reallo_frt,i=1,nspecies)
+ WRITE(unit_ctr,1000) ' Ratio of coarse wood - alphac: ', (spar(i)%alphac,i=1,nspecies)
+ WRITE(unit_ctr,1000) ' Coarse root fraction of coarse wood - cr_frac: ', (spar(i)%cr_frac,i=1,nspecies)
+ WRITE(unit_ctr,1000) ' Sapwood density - prhos: ', (spar(i)%prhos,i=1,nspecies)
+ WRITE(unit_ctr,1000) ' Proport.const.(pipe mod.) - pnus: ', (spar(i)%pnus,i=1,nspecies)
+ IF(flag_folhei==0) THEN
+ WRITE(unit_ctr,1000) ' Height growth parameter - pha: ', (spar(i)%pha,i=1,nspecies)
+ ELSEIF(flag_folhei==1) THEN
+ WRITE(unit_ctr,1000) ' Height growth par. 1 - pha_v1: ', (spar(i)%pha_v1,i=1,nspecies)
+ WRITE(unit_ctr,1000) ' Height growth par. 2 - pha_v2: ', (spar(i)%pha_v2,i=1,nspecies)
+ WRITE(unit_ctr,1000) ' Height growth par. 3 - pha_v3: ', (spar(i)%pha_v3,i=1,nspecies)
+ ELSE
+ WRITE(unit_ctr,'(A51,I3)') ' non valid flag value - flag_folhei : ',flag_folhei
+ ENDIF
+ WRITE(unit_ctr,1000) ' Height growth parameter coeff 1 - pha_coeff1: ', (spar(i)%pha_coeff1,i=1,nspecies)
+ WRITE(unit_ctr,1000) ' Height growth parameter coeff 2 - pha_coeff2: ', (spar(i)%pha_coeff2,i=1,nspecies)
+ WRITE(unit_ctr,1000) ' Crown radius - DBH ratio parameter a - crown_a: ', (spar(i)%crown_a,i=1,nspecies)
+ WRITE(unit_ctr,1000) ' Crown radius - DBH ratio parameter b - crown_b: ', (spar(i)%crown_b,i=1,nspecies)
+ WRITE(unit_ctr,1000) ' Crown radius - DBH ratio parameter c - crown_c: ', (spar(i)%crown_c,i=1,nspecies)
+ WRITE(unit_ctr,1000) ' Minimum specific leaf area - psla_min: ', (spar(i)%psla_min,i=1,nspecies)
+ WRITE(unit_ctr,1000) ' Light dep. specific leaf area - psla_a: ', (spar(i)%psla_a,i=1,nspecies)
+ WRITE(unit_ctr,1000) ' Efficiency parameter - phic: ', (spar(i)%phic,i=1,nspecies)
+ WRITE(unit_ctr,1000) ' N content - pnc: ', (spar(i)%pnc,i=1,nspecies)
+ WRITE(unit_ctr,1000) ' kco2_25: ', (spar(i)%kCO2_25,i=1,nspecies)
+ WRITE(unit_ctr,1000) ' ko2_25: ', (spar(i)%kO2_25,i=1,nspecies)
+ WRITE(unit_ctr,1000) ' CO2/O2 specif. value - pc_25: ', (spar(i)%pc_25,i=1,nspecies)
+ WRITE(unit_ctr,1000) ' Q10_kco2: ', (spar(i)%q10_kCO2,i=1,nspecies)
+ WRITE(unit_ctr,1000) ' Q10_ko2: ', (spar(i)%q10_kO2,i=1,nspecies)
+ WRITE(unit_ctr,1000) ' Q10_pc: ', (spar(i)%q10_pc,i=1,nspecies)
+ WRITE(unit_ctr,1000) ' Rd to Vm ratio - pb: ', (spar(i)%pb,i=1,nspecies)
+
+ WRITE(unit_ctr,1000) ' PIM: Inhibitor min temp. - PItmin: ', (spar(i)%PItmin,i=1,nspecies)
+ WRITE(unit_ctr,1000) ' PIM: Inhibitor opt temp. - PItopt: ', (spar(i)%PItopt,i=1,nspecies)
+ WRITE(unit_ctr,1000) ' PIM: Inhibitor max temp. - PItmax: ', (spar(i)%PItmax,i=1,nspecies)
+ WRITE(unit_ctr,1000) ' PIM: Inhibitor scaling factor - PIa: ', (spar(i)%PIa,i=1,nspecies)
+ WRITE(unit_ctr,1000) ' PIM: Promotor min temp. - PPtmin: ', (spar(i)%PPtmin,i=1,nspecies)
+ WRITE(unit_ctr,1000) ' PIM: Promotor opt temp. - PPtopt: ', (spar(i)%PPtopt,i=1,nspecies)
+ WRITE(unit_ctr,1000) ' PIM: Promotor max temp. - PPtmax: ', (spar(i)%PPtmax,i=1,nspecies)
+ WRITE(unit_ctr,1000) ' PIM: Promotor scaling factor - PPa: ', (spar(i)%PPa,i=1,nspecies)
+ WRITE(unit_ctr,1000) ' PIM: Promotor scaling factor - PPb: ', (spar(i)%PPb,i=1,nspecies)
+ WRITE(unit_ctr,1000) ' CSM: chilling base temp. - CSTbC: ', (spar(i)%CSTbC,i=1,nspecies)
+ WRITE(unit_ctr,1000) ' CSM: base temp. - CSTbT: ', (spar(i)%CSTbT,i=1,nspecies)
+ WRITE(unit_ctr,1000) ' CSM: scaling factor - CSa: ', (spar(i)%CSa,i=1,nspecies)
+ WRITE(unit_ctr,1000) ' CSM: scaling factor - CSb: ', (spar(i)%CSb,i=1,nspecies)
+ WRITE(unit_ctr,1000) ' TSM: base temp. - LTbT: ', (spar(i)%LTbT,i=1,nspecies)
+ WRITE(unit_ctr,1000) ' TSM: critical temperature sum - LTcrit: ', (spar(i)%LTcrit,i=1,nspecies)
+ WRITE(unit_ctr,1010) ' TSM: start day after 1.11. - Lstart: ', (spar(i)%Lstart,i=1,nspecies)
+ WRITE(unit_ctr,1000) ' usefd pheno model - Phmodel: ', (spar(i)%Phmodel,i=1,nspecies)
+ WRITE(unit_ctr,1000) ' End day for phenology - end_bb: ', (spar(i)%end_bb,i=1,nspecies)
+ WRITE(unit_ctr,1000) ' Fpar_mod - fpar_mod: ', (spar(i)%fpar_mod,i=1,nspecies)
+ WRITE(unit_ctr,1000) ' Intercep.cap. - ceppot_spec: ', (spar(i)%ceppot_spec,i=1,nspecies)
+ WRITE(unit_ctr,1000) ' photosynthesis response to N-limitation - Nresp: ', (spar(i)%Nresp,i=1,nspecies)
+ WRITE(unit_ctr,1000) ' Regeneration flag - regflag: ', (spar(i)%regflag,i=1,nspecies)
+ WRITE(unit_ctr,1000) ' Seedrate: ', (spar(i)%seedrate,i=1,nspecies)
+ WRITE(unit_ctr,1000) ' Seedmass: ', (spar(i)%seedmass,i=1,nspecies)
+ WRITE(unit_ctr,1000) ' Standard dev. of seedrate - seedsd: ', (spar(i)%seedsd,i=1,nspecies)
+ WRITE(unit_ctr,1000) ' all. parameter - seeda: ', (spar(i)%seeda,i=1,nspecies)
+ WRITE(unit_ctr,1000) ' all. parameter - seedb: ', (spar(i)%seedb,i=1,nspecies)
+ WRITE(unit_ctr,1000) ' all. parameter - pheight1: ', (spar(i)%pheight1,i=1,nspecies)
+ WRITE(unit_ctr,1000) ' all. parameter - pheight2: ', (spar(i)%pheight2,i=1,nspecies)
+ WRITE(unit_ctr,1000) ' all. parameter - pheight3: ', (spar(i)%pheight3,i=1,nspecies)
+ WRITE(unit_ctr,1000) ' all. parameter - pdiam1: ', (spar(i)%pdiam1,i=1,nspecies)
+ WRITE(unit_ctr,1000) ' all. parameter - pdiam2: ', (spar(i)%pdiam2,i=1,nspecies)
+ WRITE(unit_ctr,1000) ' all. parameter - pdiam3: ', (spar(i)%pdiam3,i=1,nspecies)
+ WRITE(unit_ctr,1000) ' decomp. parameter foliage - k_opm_fol: ', (spar(i)%k_opm_fol,i=1,nspecies)
+ WRITE(unit_ctr,1000) ' synth. parameter foliage - k_syn_fol: ', (spar(i)%k_syn_fol,i=1,nspecies)
+ WRITE(unit_ctr,1000) ' decomp. parameter fine roots - k_opm_frt: ', (spar(i)%k_opm_frt,i=1,nspecies)
+ WRITE(unit_ctr,1000) ' synth. parameter fine roots - k_syn_frt: ', (spar(i)%k_syn_frt,i=1,nspecies)
+ WRITE(unit_ctr,1000) ' decomp. parameter coarse roots - k_opm_crt: ', (spar(i)%k_opm_crt,i=1,nspecies)
+ WRITE(unit_ctr,1000) ' synth. parameter coarse roots - k_syn_crt: ', (spar(i)%k_syn_crt,i=1,nspecies)
+ WRITE(unit_ctr,1000) ' decomp. parameter twigs/branches - k_opm_tb: ', (spar(i)%k_opm_tb,i=1,nspecies)
+ WRITE(unit_ctr,1000) ' synth. parameter twigs/branches - k_syn_tb: ', (spar(i)%k_syn_tb,i=1,nspecies)
+ WRITE(unit_ctr,1000) ' decomp. parameter stem - k_opm_stem: ', (spar(i)%k_opm_stem,i=1,nspecies)
+ WRITE(unit_ctr,1000) ' synth. parameter dtem - k_syn_stem: ', (spar(i)%k_syn_stem,i=1,nspecies)
+
+ WRITE(unit_ctr,1000)
+ WRITE(unit_ctr,1000) ' spec_rl: ', (spar(i)%spec_rl,i=1,nspecies)
+ WRITE(unit_ctr,1000) ' tbase: ', (spar(i)%tbase,i=1,nspecies)
+ WRITE(unit_ctr,1000) ' topt: ', (spar(i)%topt,i=1,nspecies)
+ WRITE(unit_ctr,1000) ' bdmax_coef: ', (spar(i)%bdmax_coef,i=1,nspecies)
+ WRITE(unit_ctr,1000) ' porcrit_coef: ', (spar(i)%porcrit_coef,i=1,nspecies)
+ WRITE(unit_ctr,1000) ' ph_opt_max: ', (spar(i)%ph_opt_max,i=1,nspecies)
+ WRITE(unit_ctr,1000) ' ph_opt_min: ', (spar(i)%ph_opt_min,i=1,nspecies)
+ WRITE(unit_ctr,1000) ' ph_max: ', (spar(i)%ph_max,i=1,nspecies)
+ WRITE(unit_ctr,1000) ' ph_min : ', (spar(i)%ph_min ,i=1,nspecies)
+ WRITE(unit_ctr,1000) ' v_growth: ', (spar(i)%v_growth,i=1,nspecies)
+
+ WRITE(unit_ctr,1000)
+ WRITE(unit_ctr,1000) ' C/N ratio of foliage - cnr_fol: ', (spar(i)%cnr_fol,i=1,nspecies)
+ WRITE(unit_ctr,1000) ' C/N ratio of fine roots - cnr_frt: ', (spar(i)%cnr_frt,i=1,nspecies)
+ WRITE(unit_ctr,1000) ' C/N ratio of coarse roots - cnr_crt: ', (spar(i)%cnr_crt,i=1,nspecies)
+ WRITE(unit_ctr,1000) ' C/N ratio of twigs and branches - cnr_tbc: ', (spar(i)%cnr_tbc,i=1,nspecies)
+ WRITE(unit_ctr,1000) ' C/N ratio of stemwood - cnr_stem: ', (spar(i)%cnr_stem,i=1,nspecies)
+
+ WRITE(unit_ctr,1000)
+ WRITE(unit_ctr,1000) ' Reduction factor - RedN: ', (svar(i)%RedN, i=1,nspecies)
+
+ WRITE(unit_ctr,*) ' '
+ WRITE(unit_ctr,'(A)') '****** Model parameter ******'
+ WRITE(unit_ctr,1020) 'Optimum ratio of ci to ca [-] - Lambda: ',lambda
+ WRITE(unit_ctr,1020) 'Molar mass of carbon [g/mol] - Cmass: ',Cmass
+ WRITE(unit_ctr,1020) 'Minimum conductance [mol/(m2*d)] - gmin: ',gmin
+ WRITE(unit_ctr,1020) 'Shape of PS response curve - ps: ',ps
+ WRITE(unit_ctr,1020) 'Slope of N function at 20 °C [g(N) (mymol s-1)-1] - pn: ',pn
+ WRITE(unit_ctr,1020) 'Minimum N content [g/g] - nc0: ',nc0
+ WRITE(unit_ctr,1020) 'C3 quantum efficiency - qco2: ',qco2
+ WRITE(unit_ctr,1020) 'Scaling parameter - qco2a: ',qco2a
+ WRITE(unit_ctr,1020) 'Partial pressure of oxygen (kPa) - o2: ',o2
+ WRITE(unit_ctr,1020) 'Atmospheric CO2 content (mol/mol) - co2: ',co2_st
+ WRITE(unit_ctr,1020) 'Albedo of the canopy - pfref: ',pfref
+ WRITE(unit_ctr,1020) 'Part of C in biomass [-] - cpart: ',cpart
+ WRITE(unit_ctr,1020) 'Ratio of molecular weights of water and air - rmolw: ',rmolw
+ WRITE(unit_ctr,1020) 'Universal gas constant [J/mol/K] = [Pa/m3/K] - R_gas: ',R_gas
+ WRITE(unit_ctr,1020) 'von Karman''s constant [-] - c_karman: ',c_karman
+ WRITE(unit_ctr,1020) 'Specific heat of air at const. pressure [J/g/K] - c_air: ',c_air
+ WRITE(unit_ctr,1020) 'Psychrometer constant [hPa/K] - psycro: ',psycro
+ WRITE(unit_ctr,1020) 'Breast height for inventory measurements [cm] - h_breast: ',h_breast
+ WRITE(unit_ctr,1020) 'Height for sapling allometry - h_sapini: ',h_sapini
+ WRITE(unit_ctr,1020) 'Min. diff. b. height of crown base and breast height- h_bo_br_diff: ',h_bo_br_diff
+ WRITE(unit_ctr,1020) 'Parameter variable for calculation of CO2 scenario - p1_co2: ',p1_co2
+ WRITE(unit_ctr,1020) 'Parameter variable for calculation of CO2 scenario - p2_co2: ',p2_co2
+ WRITE(unit_ctr,1020) 'Parameter variable for calculation of CO2 scenario - p3_co2: ',p3_co2
+ WRITE(unit_ctr,1020) 'Parameter variable for calculation of CO2 scenario - p4_co2: ',p4_co2
+ WRITE(unit_ctr,1020) 'Parameter variable for calculation of CO2 scenario - p5_co2: ',p5_co2
+ WRITE(unit_ctr,1020) 'Parameter variable for calculation of historical CO2 scenario - p1_co2h: ',p1_co2h
+ WRITE(unit_ctr,1020) 'Parameter variable for calculation of historical CO2 scenario - p2_co2h: ',p2_co2h
+ WRITE(unit_ctr,1020) 'Parameter variable for calculation of historical CO2 scenario - p3_co2h: ',p3_co2h
+ WRITE(unit_ctr,1020) 'Parameter variable for calculation of historical CO2 scenario - p4_co2h: ',p4_co2h
+ WRITE(unit_ctr,1020) 'Threshold of air temperature for snow accumulation [°C] - temp_snow: ',temp_snow
+ WRITE(unit_ctr,1020) 'Parameter for calculation of transpiration demand - alfm: ',alfm
+ WRITE(unit_ctr,1020) 'Parameter for calculation of transpiration demand [mol/(m2*d)] - gpmax: ',gpmax
+ WRITE(unit_ctr,1020) 'Parameter for growing degree day calculation - thr_gdd: ',thr_gdd
+
+ IF (flag_multi==2) THEN
+ WRITE(unit_ctr,*) ' '
+ WRITE(unit_ctr,*) 'runs with climate scenarios produced by adding summands to every daily temperature'
+ WRITE(unit_ctr,*) 'and modifying every single precipitation value by a multiplicand'
+ WRITE(unit_ctr,*) 'run ident deltaT delta P factor'
+ ENDIF
+
+ ! mangament parameter adaptation management
+
+ IF (flag_mg.eq.2. .and. flag_reg .eq. 0) then
+ WRITE(unit_ctr,*) ' '
+ WRITE(unit_ctr,*) '***Managment parameter case flag_mg = 2 (user specified) ***'
+ WRITE(unit_ctr,'(A35,4F15.5)') 'height for management control(cm)', ho1,ho2,ho3,ho4
+ WRITE(unit_ctr,'(A35,5I15)') 'management flags thr1-thr5' , thr1,thr2, thr3,thr4,thr5
+ WRITE(unit_ctr,'(A35,F15.5)') 'height for directional felling', thr6
+ WRITE(unit_ctr,'(A35,I15)') 'measure at rotation', thr7
+ WRITE(unit_ctr,'(A35,I15)') 'regeneration measure', mgreg
+ WRITE(unit_ctr,'(A35,F15.5)') 'lower/upper limit of height(cm)', limit
+ WRITE(unit_ctr,'(A35,I15)') 'number of years between thinning',thinstep
+ WRITE(unit_ctr,'(A35,F15.5)') 'rel. value for directional felling', direcfel
+ WRITE(unit_ctr,'(A35,5F15.5)')'number of Zielbaeume(spec.)', (zbnr(i),i=1,nspec_tree)
+ WRITE(unit_ctr,'(A35,5F15.5)')'rel. value for tending of pl.',(tend(i), i =1,nspec_tree)
+ WRITE(unit_ctr,'(A35,5I15)')'rotation ',(rot(i), i =1,nspec_tree)
+ WRITE(unit_ctr,'(A35,5I15)')'age of nat./pl. regeneration',(regage(i), i =1,nspec_tree)
+ end IF
+
+ IF (flag_multi .ne. 2.and. flag_mg.ne.2 .and. flag_reg .eq.0) close(unit_ctr)
+endif ! flag_mult8910
+
+1000 FORMAT (A51,15 F16.5)
+1010 FORMAT (A51,15 I16)
+1020 FORMAT(A70,F15.5)
+
+end subroutine control_file
+
+end subroutine prepare_site
+
+!******************************************************************************
+
+SUBROUTINE readbudb
+
+use data_simul
+use data_species
+use data_stand
+
+implicit none
+
+ DO ns=1,nspecies
+ IF(spar(ns)%phmodel==4) THEN
+ WRITE(*,*) 'Please type the day of budburst for 4C species number ',ns,':'
+ READ(*,*) svar(ns)%ext_daybb
+ ENDIF
+ ENDDO
+
+END subroutine readbudb
+
+!******************************************************************************
+
+SUBROUTINE readdepo
+
+use data_climate
+use data_depo
+use data_out
+use data_simul
+use data_site
+
+implicit none
+
+character text
+integer hx, unit_dep, i,j,ios, ii
+!integer realrec
+integer id,im,iy,itz1, itz2, hyear1, hyear2, hyear3, hy
+logical ex
+real hNO, hNH
+
+if (flag_trace) write (unit_trace, '(I4,I10,A)') iday, time_cur, ' readdepo'
+
+! for areal usage standard/constant deposition is set as concentration:
+if (flag_multi .eq. 8 .or. flag_mult910) then
+ flag_depo = 2
+ if (.not.allocated(NOd)) then
+ allocate (NOd (1:366,1:year))
+ NOd = NOdep(ip) ! concentration mg/l
+ endif
+ if (.not.allocated(NHd)) then
+ allocate (NHd (1:366,1:year))
+ NHd = NHdep(ip) ! concentration mg/l
+ endif
+ return
+endif
+
+if (.not.allocated(NOd)) allocate (NOd (1:366,1:year))
+if (.not.allocated(NHd)) allocate (NHd (1:366, 1:year))
+NOd = 0.
+NHd = 0.
+
+if (.not.flag_mult8910) print *
+inquire (File = depofile(ip), exist = ex) ! test whether file exists
+ IF(ex .eqv. .false.) then
+ if (.not.flag_mult8910) then
+ hx = 0
+ print *,' >>>FORESEE message: Cannot find deposition data - all data set to zero!'
+ CALL error_mess(hx,'Cannot find deposition data - all data set to ',REAL(hx))
+ endif
+ else
+ if (.not.flag_mult8910) print *, ' >>>FORESEE message: Now reading DEPOSITION data from file, please wait...'
+! now read data from file
+ unit_dep = getunit()
+ OPEN (unit_dep,FILE=depofile(ip),IOSTAT=ios,STATUS='OLD',ACTION='READ')
+
+ flag_depo = 1
+ read(unit_dep,*) text
+ select case (text)
+ case ('C', 'c') ! concentrations mg/l
+ flag_depo = 2
+ read(unit_dep,*) text
+
+ case ('Y', 'y') ! Yearly constant deposition mg/m2
+ flag_depo = 3
+ read(unit_dep,*) text
+
+ case ('A', 'a') ! Annual sum of deposition g/m2
+ flag_depo = 4
+ read(unit_dep,*) text
+
+ end select
+
+ do
+ IF (text .ne. '!') then
+ backspace(unit_dep)
+ exit
+ endif
+ read(unit_dep,*) text
+ enddo
+
+! assignment of dates
+! fill in missing values with current values until current date
+! fill in missing values at the end
+ hyear1 = 0
+ hyear2 = 0
+ hyear3 = 1
+ itz1 = 1
+ itz2 = 1
+ select case (flag_depo)
+ case(4)
+ do while ((ios .eq. 0) .and. (hyear1 .lt. year))
+ read(unit_dep,*,iostat=ios) iy, hNO, hNH
+ if (ios .eq.0) then
+ if (iy .gt. time_b+year) then
+ hyear1 = year
+ else
+ hyear1 = iy - time_b + 1
+ endif
+ if ((hyear1 .le. year) .and. (hyear1 .gt. 0)) then ! save from simulation start year onwards
+ do i = 1,366
+ NOd(i,hyear1) = hNO * 1000./366. ! report of year [g/m2] in daily values [mg/m2]
+ NHd(i,hyear1) = hNH * 1000./366.
+ enddo
+ hy = hyear1-1
+ do while ((hy .gt. hyear2) .and. (hy .gt. 0))
+ do i = 366, 1, -1
+ NOd(i,hy) = hNO * 1000./366.
+ NHd(i,hy) = hNH * 1000./366.
+ enddo
+ hy = hy - 1
+ enddo
+ hyear2 = hyear1
+ endif ! 0 < hyear1 < year
+ else ! ios .ne. 0
+ if (hyear1 .le. 0) then
+ hyear1 = 1
+ hyear2 = 1
+ endif
+ continue
+ endif ! ios = 0
+ enddo
+
+ case default
+ do while ((ios .eq. 0) .and. (hyear1 .lt. year))
+ read(unit_dep,*,iostat=ios) id,im,iy, hNO, hNH
+ if (ios .eq.0) then
+ call daintz(id,im,iy,itz1)
+ if (iy .gt. time_b+year) then
+ hyear1 = year
+ else
+ hyear1 = iy - time_b + 1
+ endif
+ if ((hyear1 .le. year) .and. (hyear1 .gt. 0)) then ! save from simulation start year onwards
+ NOd(itz1,hyear1) = hNO
+ NHd(itz1,hyear1) = hNH
+
+ select case (flag_depo)
+ case(1,2)
+ if (hyear1 .eq. hyear3) then
+ if (itz1 .gt. 1) then
+ do i = itz1-1, itz2, -1
+ NOd(i,hyear1) = hNO
+ NHd(i,hyear1) = hNH
+ enddo
+ endif
+ else
+ if (itz2 .lt. recs(hyear3)) then
+ do i = itz2+1, recs(hyear3)
+ NOd(i,hyear3) = hNO
+ NHd(i,hyear3) = hNH
+ enddo
+ endif
+ itz2 = 1
+ if (itz1 .gt. 1) then
+ do i = itz1-1, itz2, -1
+ NOd(i,hyear1) = hNO
+ NHd(i,hyear1) = hNH
+ enddo
+ endif
+ hy = hyear1-1
+ do while ((hy .gt. hyear3) .and. (hy .gt. 0))
+ do i = 366, 1, -1
+ NOd(i,hy) = hNO
+ NHd(i,hy) = hNH
+ enddo
+ hy = hy - 1
+ enddo
+ endif ! hyear1 .eq. hyear3
+ hyear3 = hyear1
+ itz2 = itz1
+ hyear2 = hyear3
+
+ case(3) ! fill in of constant year values
+ do i = 1,366
+ NOd(i,hyear1) = hNO
+ NHd(i,hyear1) = hNH
+ enddo
+ hy = hyear1-1
+ do while ((hy .gt. hyear2) .and. (hy .gt. 0))
+ do i = 366, 1, -1
+ NOd(i,hy) = hNO
+ NHd(i,hy) = hNH
+ enddo
+ hy = hy - 1
+ enddo
+ hyear2 = hyear1
+ itz2 = 366
+ end select ! flag_depo 1-3
+
+ endif ! 0 < hyear1 < year
+ else ! ios .ne. 0
+ if (hyear1 .le. 0) then
+ hyear1 = 1
+ hyear2 = 1
+ endif
+ continue
+ endif ! ios = 0
+ enddo
+ end select ! flag_depo
+
+! fill in of the missing data at the end
+ select case (flag_depo)
+ case (3)
+ if (hyear1 .lt. year) then
+ hy = hyear1+1
+ do while (hy .le. year)
+ do i = 366, 1, -1
+ NOd(i,hy) = hNO
+ NHd(i,hy) = hNH
+ enddo
+ hy = hy + 1
+ enddo
+ else ! if date is outside the simulation period, it will be completly filled in
+ do j = 1, year
+ do i = 1, 366
+ NOd(i,j) = hNO
+ NHd(i,j) = hNH
+ enddo
+ enddo
+ endif
+
+ case default
+ if (hyear2 .le. year) then
+ if (itz2 .lt. recs(hyear2)) then
+ if (.not.flag_mult8910) then
+ hx = iy
+ CALL error_mess(hx,' Not enough data records in deposition file, iostat = ',REAL(ios))
+ WRITE (unit_err,*) ' >>>FORESEE message: Fill next values with same data '
+ WRITE (unit_err,'(A,2I4,A,2I4)')' from internal simulation time', itz2, hyear2, ' to', recs(hyear2), year
+ endif
+ do j = hyear2, year
+ ii = 1
+ if (j .eq. hyear2) ii = itz2
+ do i = ii, 366
+ NOd(i,j) = hNO
+ NHd(i,j) = hNH
+ enddo
+ enddo
+ else
+ hy = hyear2+1
+ do while (hy .le. year)
+ do i = 366, 1, -1
+ NOd(i,hy) = hNO
+ NHd(i,hy) = hNH
+ enddo
+ hy = hy + 1
+ enddo
+ endif
+ else ! if date is outside the simulation period, it will be completly filled in
+ do j = 1, year
+ do i = 1, 366
+ NOd(i,j) = hNO
+ NHd(i,j) = hNH
+ enddo
+ enddo
+ endif
+ end select
+ close (unit_dep)
+ endif
+
+ write (*,*)
+
+END subroutine readdepo
+
+
+!******************************************************************************
+
+SUBROUTINE readredN
+
+use data_out
+use data_species
+use data_stand
+use data_simul
+
+implicit none
+
+character text
+integer hx, unit_red, i,ios
+logical ex
+
+if (.not.flag_mult8910) print *
+if (flag_multi .lt. 8) then
+ inquire (File = "./input/.", exist = ex) ! test whether file exists
+ inquire (File = redfile(ip), exist = ex) ! test whether file exists
+ IF(ex .eqv. .false.) then
+ print *,' >>>FORESEE message: Cannot find data of RedN - internal calculation'
+ hx = 0
+ CALL error_mess(hx,'Cannot find data of RedN - internal calculation ',REAL(hx))
+ else
+ print *, ' >>>FORESEE message: Now reading RedN data from file, please wait...'
+ unit_red = getunit()
+ OPEN (unit_red,FILE=redfile(ip),IOSTAT=ios,STATUS='OLD',ACTION='READ')
+
+ DO
+ READ(unit_red,*) text
+ IF (text .ne. '!') THEN
+ backspace(unit_red)
+ EXIT
+ ENDIF
+ ENDDO
+
+ read (unit_red,*,iostat=ios) (svar(i)%RedN, i=1,nspecies)
+ close (unit_red)
+ endif ! ex
+else
+ do i = 1, nspecies
+ svar(i)%RedN = RedN_list(i, ip)
+ enddo
+endif ! flag_multi
+
+IF(flag_limi==0 .OR. flag_limi==1) THEN
+ DO i=1,nspecies
+ svar(i)%RedN = 1.
+ ENDDO
+ENDIF
+
+do i = 1,nspecies
+ if (svar(i)%RedN .lt. 0) then ! no values; internal calculation
+ if (flag_multi .lt. 8) then
+ print *,' >>>FORESEE message: Cannot find data of RedN - internal calculation for', spar(i)%species_short_name
+ write (unit_err, '(A,I3,1X,A)') 'Cannot find data of RedN - internal calculation for species ',i, spar(i)%species_short_name
+ endif
+ flag_redn = .TRUE.
+ endif
+enddo
+
+ if (.not.flag_mult8910) write (*,*)
+
+END subroutine readredN
+
+!******************************************************************************
+
+SUBROUTINE readlit
+
+!use data_climate
+use data_out
+use data_soil_cn
+use data_species
+use data_stand
+use data_simul
+
+implicit none
+
+character text
+integer unit_lit, i,ios
+integer nspec_lit
+logical ex
+real help, hx
+real, dimension(22) :: helpin
+
+flag_lit = 0
+if (flag_mult8910) then
+ inquire (File = litfile(1), exist = ex) ! test whether file exists
+else
+ print *
+ inquire (File = litfile(ip), exist = ex) ! test whether file exists
+endif
+ IF(ex .eqv. .false.) then
+ if (.not.flag_mult8910) then
+ print *,' >>>FORESEE message: Cannot find data of litter initialisation - internal calculation'
+ hx = 0.
+ write (unit_err,*)
+ write (unit_err,*) 'Cannot find data of litter initialisation - internal calculation '
+ endif
+ else
+ if (.not.flag_mult8910) print *, ' >>>FORESEE message: Now reading litter initialisation data from file, please wait...'
+! now read data from file
+ unit_lit = getunit()
+ OPEN (unit_lit,FILE=litfile(ip),IOSTAT=ios,STATUS='OLD',ACTION='READ')
+
+ do
+ read(unit_lit,*) text
+ IF (text .ne. '!') then
+ backspace(unit_lit)
+ exit
+ endif
+ enddo
+
+ helpin = 0.
+ slit%C_opm_fol = 0.
+ read (unit_lit,*) nspec_lit
+ read (unit_lit,*,iostat=ios) text, (slit(i)%C_opm_fol, i=1,nspec_lit)
+ read (unit_lit,*,iostat=ios) text, (slit(i)%C_opm_tb , i=1,nspec_lit)
+ read (unit_lit,*,iostat=ios) text, (slit(i)%C_opm_frt(1), i=1,nspec_lit)
+ read (unit_lit,*,iostat=ios) text, (slit(i)%C_opm_crt(1), i=1,nspec_lit)
+ read (unit_lit,*,iostat=ios) text, (slit(i)%C_opm_stem,i=1,nspec_lit)
+ flag_lit = 1
+
+ help = 0.
+ hx = 1.
+ do i=1,nspecies
+ if (slit(i)%C_opm_fol .gt. 0) then
+ totfol_lit = totfol_lit + slit(i)%C_opm_fol
+ totfrt_lit = totfrt_lit + slit(i)%C_opm_frt(1)
+ tottb_lit = tottb_lit + slit(i)%C_opm_tb
+ totcrt_lit = totcrt_lit + slit(i)%C_opm_crt(1)
+ totstem_lit = totstem_lit + slit(i)%C_opm_stem
+ else
+ hx = -1.
+ endif
+ enddo
+ help = totfol_lit
+
+ if ((help .gt. 0.) .or. (hx .gt. 0) .and. .not.flag_mult8910) then
+ CALL error_mess(0,'Using data of litter initialisation from file '//trim(litfile(ip)), hx)
+ else
+ ! no values; internal calculation of litter initialisation
+ if (.not.flag_mult8910) then
+ print *,' >>>FORESEE message: No data of litter initialisation - internal calculation'
+ hx = 0.
+ CALL error_mess(0,'No data of litter initialisation - internal calculation ', hx)
+ endif
+ flag_lit = 0
+ endif
+ close (unit_lit)
+ endif ! ex
+
+ if (.not.flag_mult8910) write (*,*)
+
+END subroutine readlit
+
+!******************************************************************************
+
+subroutine prepare_climate
+! read climate file
+
+use data_climate
+use data_out
+use data_simul
+use data_stand
+
+implicit none
+
+type clifile ! new data type for all climate parameters
+ integer :: day,mon,ye
+ real :: m1, m2, m3, m4, m5, m6, m7, m8, m9, m10, m11
+end type clifile
+type (clifile), allocatable,dimension(:,:) :: climall !variable for data type climfile
+character(1) c
+character :: text
+integer :: i,j,ios, unit_cli
+integer :: realrec = 0
+integer :: repflag = 0
+logical :: ex
+
+if (.not.flag_mult8910) then
+ print *, ' '
+ print *, ' Input of climate data: '
+endif
+
+call testfile(climfile(ip),ex) !input filename, test whether file exists
+ IF(ex .eqv. .false.) then
+ print *,' >>>FORESEE message: Cannot find climate data - program STOP!'
+ stop
+ endif
+ if (.not.flag_mult8910) print *, ' >>>FORESEE message: Now reading CLIMATE data from file, please wait...'
+!now read data from file
+unit_cli = getunit()
+OPEN (unit_cli,FILE=climfile(ip),IOSTAT=ios,STATUS='OLD',ACTION='READ')
+allocate (recs (1:year))
+allocate (dd (1:366,1:year));allocate (mm (1:366, 1:year))
+allocate (yy (1:year));allocate (tp (-2:366,1:year))
+allocate (hm (0:366,1:year));allocate (prc (0:366,1:year))
+allocate (prs (0:366,1:year));allocate (rd (0:366,1:year))
+allocate (tn (0:366,1:year))
+allocate (tx (0:366,1:year))
+allocate (vp (0:366,1:year))
+allocate (sdu (0:366,1:year))
+allocate (wd (0:366,1:year))
+allocate (sde (0:366,1:year))
+allocate (bw (0:366,1:year))
+
+dd = -99.9
+mm = -99.9
+yy = -99.9
+tn = -99.9
+tx = -99.9
+wd = -99.9 ! wind initialisation
+
+IF (index(climfile(ip),'.cli') .ne. 0) then
+ flag_climtyp = 1
+ do
+ read(unit_cli,*) text
+ IF (text .ne. '!') then
+ IF (text .eq. 'N') then
+ flag_climtyp = 2
+ else IF(text.eq.'T') then
+ flag_climtyp = 3
+ else
+ backspace(unit_cli)
+ exit
+ endif
+ endif
+ enddo
+else if (index(climfile(ip),'.txt') .ne. 0) then
+ flag_climtyp = 4
+else
+ flag_climtyp = 5
+end IF
+call read_cli
+close(unit_cli)
+if (flag_end .gt. 0) return
+
+
+IF (realrec < year .and. repflag == 0) then
+ year = realrec
+else
+ IF (repflag == 1) then
+ call climfill
+ end IF
+end IF
+med_rad1 = 0.
+do j = 1, year-1
+ tp(0,j+1) = tp(recs(j),j)
+ tp(-1,j+1)= tp(recs(j)-1,j)
+ tp(-2,j+1)= tp(recs(j)-2,j)
+ hm(0,j+1) = hm(recs(j),j);prc(0,j+1) = prc(recs(j),j);prs(0,j+1) = prs(recs(j),j)
+ rd(0,j+1) = rd(recs(j),j)
+ wd(0,j+1) = wd(recs(j),j)
+ bw(0,j+1) = bw(recs(j),j)
+ vp(0,j+1) = vp(recs(j),j)
+ sdu(0,j+1) = sdu(recs(j),j)
+ sde(0,j+1) = sde(recs(j),j)
+ tx(0,j+1) = tx(recs(j),j)
+ tn(0,j+1) = tn(recs(j),j)
+
+ if( yy(j) .eq.time_b) then
+ do i=1, recs(j)
+
+ med_rad1 = med_rad1 + rd(i, j)
+ end do
+ med_rad1 = med_rad1/recs(1)
+
+ end if
+end do
+tp(-2,1) = tp(1,1); tp(-1,1) = tp(1,1); tp(0,1) = tp(1,1)
+hm(0,1) = hm(1,1);prc(0,1) = prc(1,1);prs(0,1) = prs(1,1)
+rd(0,1) = rd(1,1)
+wd(0,1)=wd(1,1)
+vp(0,1) = vp(1,1)
+bw(0,1) = bw(1,1)
+tn(0,1) = tn(1,1)
+tx(0,1) = tx(1,1)
+sdu(0,1) =sdu(1,1)
+sde(0,1) = sde(1,1)
+
+contains
+
+!--------------------------------------------------------------
+
+subroutine read_dwd
+
+character(3) text
+integer help, help1, help2, help3
+allocate (climall (0:366,1:year))
+
+j=1
+c = 'n'
+do
+ IF (j > year) then
+ realrec = year
+ exit
+ end IF
+ if (.not.flag_mult8910) print *, 'Year ',j
+ read(unit_cli,*) text
+ if(text.ne.'ta ') then
+ backspace(unit_cli)
+ end if
+
+ do i = 1, 366
+ read (unit_cli,*,IOSTAT=ios) climall(i,j)
+
+ help2 = climall(i,j)%day
+ help3 = climall(i,j)%mon
+ help = climall(i,j)%ye
+ help1 = climall(i-1,j)%ye
+ if (help.eq.2099 .and.help1.eq.2100.and. i.eq.366) then
+ end if
+ end do
+ IF (climall(365,j)%ye == climall(366,j)%ye) then
+ recs(j) = 366
+ else
+ backspace unit_cli
+ climall(366,j)%day = 0
+ climall(366,j)%mon = 0
+ climall(366,j)%ye = 0
+ recs(j) = 365
+ help = help-1
+ end IF
+ IF (j < year .and. ios < 0 .and. c .eq. 'n') then
+ realrec = j
+ if (.not.flag_mult8910) then
+ print *, ' >>>FORESEE message: Not enough climate data records in file!'
+ call error_mess(0,'read_cli: Not enough data records in climate file; number of complete years: ',real(realrec))
+ write(unit_err,'(A,I5)')' read_cli: Fill next values with same from first year, day: ',i_exit
+ write(unit_err,'(A,I5)')' read_cli: Fill next values with same data up to years: ',year
+ repflag = 1
+ exit
+ endif
+ else if(j.eq.year.and.ios < 0) then
+ realrec = year
+ exit
+ end IF
+
+ j=j+1
+ if(help.lt.time_b) j = j-1
+
+end do
+
+do j = 1, realrec
+ yy(j) = climall(1,j)%ye
+ do i = 1, recs(j)
+ dd(i,j) = climall(i,j)%day
+ mm(i,j) = climall(i,j)%mon
+ tx(i,j) = climall(i,j)%m1
+ tp(i,j) = climall(i,j)%m2
+ tn(i,j) = climall(i,j)%m3
+
+ prc(i,j) = climall(i,j)%m4
+ hm(i,j) = climall(i,j)%m5
+ prs(i,j) = climall(i,j)%m6
+ vp(i,j) = climall(i,j)%m7
+ sdu(i,j) = climall(i,j)%m8
+ bw(i,j) = climall(i,j)%m9
+ rd(i,j) = climall(i,j)%m10
+
+ wd(i,j) = climall(i,j)%m11
+ end do
+end do
+
+close(9)
+deallocate (climall)
+end subroutine read_dwd
+
+!--------------------------------------------------------------
+
+subroutine read_cli
+
+implicit none
+
+integer :: testtext, hp
+character(11) :: text2
+character(4) :: text
+
+testtext=0
+c = 'n'
+j = 1
+hp = 0
+read(unit_cli,'(A)') text2
+hp = index(text2,'.')
+backspace(unit_cli)
+
+do
+ IF(j > year) exit
+
+ select case(flag_climtyp)
+ case (1)
+ do i=1,366
+ if (hp .gt. 0) then
+ read(unit_cli,*,iostat=ios) text2,tp(i,j),hm(i,j),prc(i,j),prs(i,j),rd(i,j)
+ text = text2(1:2)
+ write (text,'(A)') text2(1:2)
+ read (text,*) dd(i,j)
+ write (text,'(A)') text2(4:5)
+ read (text,*) mm(i,j)
+ write (text,'(A)') text2(7:10)
+ read (text,*) yy(j)
+ else
+ read(unit_cli,*,iostat=ios) dd(i,j),mm(i,j),yy(j),tp(i,j),hm(i,j),prc(i,j),prs(i,j),rd(i,j)
+ endif ! hp
+ i_exit = i
+ if ((dd(i,j) .eq. 31) .and. (mm(i,j) .eq. 12)) then
+ recs(j) = i
+ write (*,*) 'Year ',j, yy(j)
+ realrec = j
+ if (j .eq. year) ios = -10
+ exit
+ endif
+ if (ios .ne. 0) exit
+ end do
+
+ case (2)
+ do i=1,366
+ read(unit_cli,*) dd(i,j),mm(i,j),yy(j),&
+ tp(i,j),hm(i,j),prc(i,j),prs(i,j),rd(i,j),wd(i,j)
+ i_exit = i
+ if ((dd(i,j) .eq. 31) .and. (mm(i,j) .eq. 12)) then
+ recs(j) = i
+ write (*,*) 'Year ',j, yy(j)
+ realrec = j
+ if (j .eq. year) ios = -10
+ exit
+ endif
+ if (ios .ne. 0) exit
+ end do
+
+ case (3)
+ do i=1,366
+ if (hp .gt. 0) then
+ read(unit_cli,*,iostat=ios) text2, &
+ tp(i,j),hm(i,j),prc(i,j),prs(i,j),rd(i,j),wd(i,j), tx(i,j),tn(i,j)
+ text = text2(1:2)
+ write (text,'(A)') text2(1:2)
+ read (text,*) dd(i,j)
+ write (text,'(A)') text2(4:5)
+ read (text,*) mm(i,j)
+ write (text,'(A)') text2(7:10)
+ read (text,*) yy(j)
+ else
+ read(unit_cli,*,iostat=ios) dd(i,j),mm(i,j),yy(j),&
+ tp(i,j),hm(i,j),prc(i,j),prs(i,j),rd(i,j),wd(i,j), tx(i,j),tn(i,j)
+ endif
+ i_exit = i
+ if ((dd(i,j) .eq. 31) .and. (mm(i,j) .eq. 12)) then
+ recs(j) = i
+ write (*,*) 'Year ',j, yy(j)
+ realrec = j
+ if (j .eq. year) ios = -10
+ exit
+ endif
+ if (ios .ne. 0) exit
+ end do
+
+ case (4) ! suffix 'txt'
+ if (j .eq. 1 .and. testtext.eq.0) then
+ read(unit_cli,*) text
+ testtext = 1
+ end if
+ do i=1,366
+ read(unit_cli,*,iostat=ios) dd(i,j),mm(i,j),yy(j),&
+ tx(i,j),tp(i,j),tn(i,j),prc(i,j),hm(i,j),prs(i,j),rd(i,j),wd(i,j)
+ i_exit = i
+ if ((dd(i,j) .eq. 31) .and. (mm(i,j) .eq. 12)) then
+ recs(j) = i
+ write (*,*) 'Year ',j, yy(j)
+ realrec = j
+ if (j .eq. year) ios = -10
+ exit
+ endif
+ if (ios .ne. 0) exit
+ end do
+
+ case (5 )
+ call read_dwd
+ exit
+
+ end select
+
+ IF (realrec .lt. year .and. ios .ne. 0 .and. c .eq. 'n') then
+ if (dd(i_exit,j) .gt. 0) i_exit = i_exit+1
+ if (i_exit .ge. 365) i_exit = 1
+ repflag = 1
+ if (.not.flag_mult8910) then
+ print *, ' >>>FORESEE message: Not enough data records in file'
+ print *, ' IOSTAT = ', ios
+
+ WRITE (*,'(A,I5)') ' >>>FORESEE message: Fill next values with same data from day number', i_exit
+ CALL error_mess(0,'read_cli: Not enough data records in meteorology file; number of complete years: ',real(realrec))
+ write(unit_err,'(A,I5)')' read_cli: Fill next values with same from first year, day: ',i_exit
+ write(unit_err,'(A,I5)')' read_cli: Fill next values with same data up to years: ',year
+ exit
+ endif
+
+ end if
+ if (ios .ne. 0) exit
+ if (yy(j) .ge. time_b) then
+ if ((j .eq. 1) .and. (yy(j) .gt. time_b)) then
+ CALL error_mess(0,'read_cli: No climate data in meteorology file for year ',real(time_b))
+ flag_end = 6
+ return
+ endif
+ j = j+1
+ endif
+end do
+
+end subroutine read_cli
+
+!--------------------------------------------------------------
+
+subroutine climfill
+
+integer istart
+
+istart = i_exit
+if(istart.eq.0) istart =istart +1
+do j=realrec+1,year
+ print *,'Year ',j
+ yy(j)=yy(j-realrec)
+ recs(j)=recs(j-realrec)
+ do i=istart,366
+ dd(i,j) = dd(i,j-realrec)
+ mm(i,j) = mm(i,j-realrec)
+ tp(i,j) = tp(i,j-realrec)
+ hm(i,j) = hm(i,j-realrec)
+ prc(i,j) = prc(i,j-realrec)
+ prs(i,j) = prs(i,j-realrec)
+ rd(i,j) = rd(i,j-realrec)
+ wd(i,j) = wd(i,j-realrec)
+ tx(i,j) = tx(i,j-realrec)
+ tn(i,j) = tn(i,j-realrec)
+ end do
+end do
+
+end subroutine climfill
+
+END subroutine prepare_climate
+
+!**************************************************************
+
+SUBROUTINE store_para(hpara, simpara, parerr)
+
+use data_simul
+use data_out
+use data_par
+use data_species
+use data_soil_cn
+use data_stand
+use data_tsort
+implicit none
+
+integer inum
+real hpara, parerr
+character(100):: simpara, hchar1
+integer, external :: array_num
+
+if (flag_trace) write (unit_trace, '(I4,I10,A)') iday, time_cur, ' store_para'
+
+parerr = 0.
+if (trim(simpara) .eq. 'year') then
+ year=hpara
+ parerr = 1.
+ return
+endif
+if (trim(simpara) .eq. 'time_b') then
+ time_b=hpara
+ parerr = 1.
+ return
+endif
+if (trim(simpara) .eq. 'kpatchsize') then
+ kpatchsize=hpara
+ parerr = 1.
+ return
+endif
+if (trim(simpara) .eq. 'dz') then
+ dz=hpara
+ parerr = 1.
+ return
+endif
+if (trim(simpara) .eq. 'ns_pro') then
+ ns_pro=hpara
+ parerr = 1.
+ return
+endif
+if (trim(simpara) .eq. 'flag_mort') then
+ flag_mort=hpara
+ parerr = 1.
+ return
+endif
+if (trim(simpara) .eq. 'flag_reg') then
+ flag_reg=hpara
+ parerr = 1.
+ return
+endif
+if (trim(simpara) .eq. 'flag_stand') then
+ flag_stand=hpara
+ parerr = 1.
+ return
+endif
+if (trim(simpara) .eq. 'flag_sveg') then
+ flag_sveg=hpara
+ parerr = 1.
+ return
+endif
+if (trim(simpara) .eq. 'flag_mg') then
+ flag_mg=hpara
+ parerr = 1.
+ return
+endif
+if (trim(simpara) .eq. 'flag_dis') then
+ flag_dis=hpara
+ parerr = 1.
+ return
+endif
+if (trim(simpara) .eq. 'flag_light') then
+ flag_light=hpara
+ parerr = 1.
+ return
+endif
+if (trim(simpara) .eq. 'flag_folhei') then
+ flag_folhei=hpara
+ parerr = 1.
+ return
+endif
+if (trim(simpara) .eq. 'flag_volfunc') then
+ flag_volfunc=hpara
+ parerr = 1.
+ return
+endif
+if (trim(simpara) .eq. 'flag_resp') then
+ flag_resp=hpara
+ parerr = 1.
+ return
+endif
+if (trim(simpara) .eq. 'flag_limi') then
+ flag_limi=hpara
+ parerr = 1.
+ return
+endif
+if (trim(simpara) .eq. 'flag_sign') then
+ flag_sign=hpara
+ parerr = 1.
+ return
+endif
+if (trim(simpara) .eq. 'flag_decomp') then
+ flag_decomp=hpara
+ parerr = 1.
+ return
+endif
+if (trim(simpara) .eq. 'flag_wred') then
+ flag_wred=hpara
+ parerr = 1.
+ return
+endif
+if (trim(simpara) .eq. 'flag_wurz') then
+ flag_wurz=hpara
+ parerr = 1.
+ return
+endif
+if (trim(simpara) .eq. 'flag_cond') then
+ flag_cond=hpara
+ parerr = 1.
+ return
+endif
+if (trim(simpara) .eq. 'flag_int') then
+ flag_int=hpara
+ parerr = 1.
+ return
+endif
+if (trim(simpara) .eq. 'flag_eva') then
+ flag_eva=hpara
+ parerr = 1.
+ return
+endif
+if ((trim(simpara) .eq. 'flag_co2') .or.(trim(simpara) .eq. 'flag_CO2')) then
+ flag_co2=hpara
+ parerr = 1.
+ return
+endif
+if (adjustl(trim(simpara)) .eq. 'flag_sort') then
+ flag_sort = hpara
+ parerr = 1.
+ return
+endif
+if (adjustl(trim(simpara)) .eq. 'flag_wpm') then
+ flag_wpm = hpara
+ parerr = 1.
+ return
+endif
+if (trim(simpara) .eq. 'time_out') then
+ time_out=hpara
+ parerr = 1.
+ return
+endif
+if (trim(simpara) .eq. 'flag_dayout') then
+ flag_dayout=hpara
+ parerr = 1.
+ return
+endif
+if (trim(simpara) .eq. 'flag_cohout') then
+ flag_cohout=hpara
+ parerr = 1.
+ return
+endif
+if (trim(simpara) .eq. 'flag_sum') then
+ flag_sum=hpara
+ parerr = 1.
+ return
+endif
+
+if (trim(simpara) .eq. 'k_hum') then
+ k_hum=hpara
+ parerr = 1.
+ return
+endif
+
+if (trim(simpara) .eq. 'k_hum_r') then
+ k_hum_r=hpara
+ parerr = 1.
+ return
+endif
+
+if (trim(simpara) .eq. 'k_nit') then
+ k_nit=hpara
+ parerr = 1.
+ return
+endif
+if (adjustl(trim(simpara)) .eq. 'alfm') then
+ alfm = hpara
+ parerr = 1.
+ return
+endif
+if (adjustl(trim(simpara)) .eq. 'gpmax') then
+ gpmax = hpara
+ parerr = 1.
+ return
+endif
+if (adjustl(trim(simpara)) .eq. 'alfm') then
+ alfm = hpara
+ parerr = 1.
+ return
+endif
+
+! Species parameter
+hchar1 = adjustl(simpara)
+inum = array_num(hchar1)
+if (hchar1(1:9) .eq. 'k_opm_fol') then
+ if (inum .gt. 0 .and. inum .le. nspecies) then
+ spar(inum)%k_opm_fol = hpara
+ parerr = 1.
+ return
+ endif
+endif
+if (hchar1(1:9) .eq. 'k_opm_frt') then
+ inum = array_num(hchar1)
+ if (inum .gt. 0 .and. inum .le. nspecies) then
+ spar(inum)%k_opm_frt = hpara
+ parerr = 1.
+ return
+ endif
+endif
+if (hchar1(1:9) .eq. 'k_syn_fol') then
+ inum = array_num(hchar1)
+ if (inum .gt. 0 .and. inum .le. nspecies) then
+ spar(inum)%k_syn_fol = hpara
+ parerr = 1.
+ return
+ endif
+endif
+if (hchar1(1:9) .eq. 'k_syn_frt') then
+ if (inum .gt. 0 .and. inum .le. nspecies) then
+ spar(inum)%k_syn_frt = hpara
+ parerr = 1.
+ return
+ endif
+endif
+if (hchar1(1:3) .eq. 'psf') then
+ inum = array_num(hchar1)
+ if (inum .gt. 0 .and. inum .le. nspecies) then
+ spar(inum)%psf = hpara
+ parerr = 1.
+ return
+ endif
+endif
+if (hchar1(1:7) .eq. 'Phmodel') then
+ inum = array_num(hchar1)
+ if (inum .gt. 0 .and. inum .le. nspecies) then
+ spar(inum)%Phmodel = hpara
+ parerr = 1.
+ return
+ endif
+endif
+if ((hchar1(1:4) .eq. 'pnus') .or. (hchar1(1:4) .eq. 'Pnus')) then
+ inum = array_num(hchar1)
+ if (inum .gt. 0 .and. inum .le. nspecies) then
+ spar(inum)%pnus = hpara
+ parerr = 1.
+ return
+ endif
+endif
+if ((hchar1(1:4) .eq. 'RedN') .or. (hchar1(1:4) .eq. 'redn')) then
+ inum = array_num(hchar1)
+ if (inum .gt. 0 .and. inum .le. nspecies) then
+ svar(inum)%RedN = hpara
+ parerr = 1.
+ return
+ endif
+endif
+if (hchar1(1:4) .eq. 'prms') then
+ inum = array_num(hchar1)
+ if (inum .gt. 0 .and. inum .le. nspecies) then
+ spar(inum)%prms = hpara
+ parerr = 1.
+ return
+ endif
+endif
+if (hchar1(1:4) .eq. 'prmr') then
+ inum = array_num(hchar1)
+ if (inum .gt. 0 .and. inum .le. nspecies) then
+ spar(inum)%prmr = hpara
+ parerr = 1.
+ return
+ endif
+endif
+
+END subroutine store_para
+
+!**************************************************************
+
+integer FUNCTION array_num(string)
+
+! reads the field numbre out of an array and hands it back as integer
+
+implicit none
+
+integer ipos1, ipos2, inum
+character (100) string
+character (10) help, hchar
+
+ ipos1 = scan(string, '(' )
+ ipos2 = scan(string, ')' )
+ ipos1 = ipos1+1
+ ipos2 = ipos2-1
+ hchar = string(ipos1:ipos2)
+ write(help,'(A3)') hchar
+ read(help,*) inum
+ array_num = inum
+
+end function array_num
diff --git a/source_code/version2.2_windows/prepstand.f b/source_code/version2.2_windows/prepstand.f
new file mode 100755
index 0000000000000000000000000000000000000000..1d5124dd8f88829983de8aac84910ea04400c4b3
--- /dev/null
+++ b/source_code/version2.2_windows/prepstand.f
@@ -0,0 +1,725 @@
+!*****************************************************************!
+!* *!
+!* 4C (FORESEE) Simulation Model *!
+!* *!
+!* *!
+!* Stand initialisation *!
+!* *!
+!* CONTAINS SUBROUTINES : *!
+!* PREPARE_STAND *!
+!* internal subroutines: *!
+!* SLA_INI *!
+!* *!
+!* CALC_INT *!
+!* CALC_WEIBLA *!
+!* READ_STAND (treeunit) *!
+!* COH_INITIAL (coh) *!
+!* CREATE_MISTLETOE *!
+!* CREATE_SOILVEG *!
+!* *!
+!* CONTAiNS FUNCTIONS : *!
+!* SURVAGE *!
+!* *!
+!* 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 prepare_stand
+
+ USE data_simul
+ USE data_site
+ USE data_stand
+ USE data_species
+ use data_climate
+ use data_par
+ USE data_manag
+
+ IMPLICIT NONE
+
+ CHARACTER :: a
+ CHARACTER(30) :: text
+ CHARACTER(50) :: test_stand_id
+ INTEGER :: ios,treeunit
+ LOGICAL :: exs, lstin
+ INTEGER :: help_ip, test_vf
+ REAL :: test_patchsize, xx
+
+
+ REAL help_height_top ! auxiliary var. for setting mistletoe height at uppermost crown layer
+ INTEGER which_cohort
+ INTEGER nr_infect_trees
+ INTEGER nr_mist_per_tree
+ INTEGER i
+ TYPE(Coh_Obj), Pointer :: p ! pointer to cohort list
+
+ IF(site_nr==1) THEN
+ help_ip=site_nr
+ ELSE
+ help_ip=ip
+ END IF
+
+ pt = neu()
+ anz_coh=0
+ max_coh=0
+ ios = -1
+ nr_mist_per_tree=0
+
+ IF(flag_stand>0) then
+
+ exs = .false.
+ stand_id = standid(help_ip)
+ ! reading stand information from treefile
+ inquire (File = treefile(help_ip), exist = exs)
+ IF((exs .eqv. .false.) .or. (flag_stand==2)) then
+ IF(exs .eqv. .false.) write(*,*) ' Stand initialization file not exists!'
+ IF(flag_stand==2) write(*,*)' Stand initialization with new file'
+ write(*,'(A)',advance='no') ' Creating new file (y/n): '
+ READ *, a
+ IF(a.eq.'y'.or. a.eq.'Y') CALL initia
+
+ ! planting of small trees
+ if(flag_reg.eq.20) then
+ call planting
+ flag_reg=100
+ end if
+ flag_stand=1
+ exs=.true.
+ ENDIF
+ ! read values from treefile
+ IF (exs.eqv. .true.) then
+ treeunit=getunit()
+ OPEN(treeunit,file=treefile(help_ip),action='read', pad='YES')
+ READ(treeunit,'(I1,F12.0)',iostat=ios) test_vf, test_patchsize
+ if(flag_multi.ne.4 .or. (flag_multi.eq.4.and.ip.eq.1) .or. (flag_multi.eq.8.and.ip.eq.1)) then
+ IF(test_vf.NE.flag_volfunc) THEN
+ if (.not.flag_mult8910) then
+ CALL error_mess(time,"volume function in sim-file and the one used for initialisation do not match",REAL(flag_volfunc))
+ CALL error_mess(time,"volume function (flag_volfunc) is set to",REAL(test_vf))
+ endif
+ flag_volfunc = test_vf
+ end if
+
+ ENDIF
+ IF(test_patchsize .GT. 0.) THEN
+ lmulti = .FALSE.
+ IF(test_patchsize.NE.kpatchsize) THEN
+ if (.not.flag_mult8910) then
+ CALL error_mess(time,"patch size in sim-file and the one used for initialisation do not match",kpatchsize)
+ CALL error_mess(time,"value in ini-file",test_patchsize)
+ CALL error_mess(time,"value in sim-file",kpatchsize)
+ endif
+ kpatchsize = test_patchsize
+ ENDIF
+ ELSE
+ lmulti = .TRUE.
+ ENDIF
+ do
+ READ(treeunit,'(A)',iostat=ios) a
+ IF (a .ne. '!') exit
+ end do
+ backspace treeunit
+ ! generation of mistletoe cohort; mistletoe cohort need to be generated BEFORE tree cohorts as otherwise the light model becomes messy
+ if (flag_dis.eq.1) then
+ do i= 1, dis_row_nr
+ if (dis_type(i) .eq. 'M') then
+ if (flag_mistle.eq.0) then !set #of mist. only once
+ print *,"!! Note, implementation of mistletoe is restricted to trees of Pinus sylvestris"
+ nr_mist_per_tree = dis_rel(i)
+ flag_mistle=1 ! flag indicating mistletoes
+ call create_mistletoe ! initialisation of Mistletoe
+ endif
+ anz_coh = max_coh
+ endif
+ enddo
+ endif
+
+ lstin = .TRUE.
+ if(flag_multi.eq.4 .or. flag_multi.eq.8) stand_id = standid(help_ip)
+ do while (lstin)
+ IF (lmulti) THEN
+ read(treeunit,*,iostat=ios) test_stand_id, test_patchsize,text
+ IF (ios .lt. 0) then
+ if (.not.flag_mult8910) then
+ CALL error_mess(time,"stand identificator not found"//adjustl(stand_id)//"ip No.",real(help_ip))
+ write (*,*) '*** PREPSTAND: program aborted'
+ write (*,*) ' stand identificator',stand_id,' not found'
+ write (*,'(A, 2x,A)') ' in initialisation file',treefile(help_ip)
+ endif
+ flag_end = 2
+ return
+ ENDIF
+ IF (test_stand_id .ne. stand_id) THEN
+ read (treeunit,*) xx
+ do while (xx .gt. -90.0)
+ read (treeunit,*) xx
+ enddo ! xx
+ ELSE
+ lstin = .FALSE.
+ kpatchsize = test_patchsize
+ call read_stand (treeunit)
+ END IF ! stand_id
+ ELSE
+ lstin = .FALSE.
+ call read_stand (treeunit)
+ END IF ! lmulti
+ end do ! lstin
+ CLOSE(treeunit)
+ anz_coh = max_coh
+ coh_ident_max = anz_coh
+
+ END IF
+END IF
+
+!if treefile not exists and not created:
+IF(ios .ne. 0 .or. exs .eqv. .false.)THEN
+ if (.not.flag_mult8910) PRINT *,' >>> No Stand Initialization possible '
+ flag_stand=0
+END IF
+
+! Setting of height and number of mistletoe
+if (flag_mistle.ne.0) then
+ help_height_top=1.
+ p=>pt%first
+ DO WHILE (ASSOCIATED(p))
+ if (p%coh%species.eq.3 .AND. p%coh%height.gt.help_height_top) then !only on Pinus
+ help_height_top=p%coh%height
+ which_cohort=p%coh%ident
+ nr_infect_trees=p%coh%nTreeA
+ end if
+ p=>p%next
+ end do
+
+ p=>pt%first
+ DO WHILE (ASSOCIATED(p))
+ if (p%coh%species.eq.nspec_tree+2) then
+ p%coh%height = help_height_top !upper crown
+ p%coh%x_hbole = p%coh%height-50. !lower crown
+ p%coh%nTreeA = nr_infect_trees*nr_mist_per_tree !number of mistletoes
+ end if
+ if (p%coh%ident.eq.which_cohort) then !mark uppermost tree cohort with flag mistletoe
+ p%coh%mistletoe=1
+ end if
+ p=>p%next
+ end do
+end if ! end set height/number of mistletoe
+
+! Soil Vegetation
+if (flag_sveg .gt. 0) then
+ call create_soilveg ! initialisation of ground vegetation
+ anz_coh = max_coh
+endif
+
+IF(flag_stand>0) CALL sla_ini
+IF(flag_stand>0) CALL stand_bal_spec
+CALL calc_int
+CALL calc_weibla
+if(flag_mg.ne.33) call overstorey
+
+contains
+
+SUBROUTINE sla_ini
+
+ USE data_stand
+ USE data_species
+
+ IMPLICIT NONE
+ TYPE(Coh_Obj), Pointer :: p ! pointer to cohort list
+
+ p => pt%first
+
+ DO WHILE (ASSOCIATED(p))
+ ns=p%coh%species
+ p%coh%med_sla=spar(ns)%psla_min+spar(ns)%psla_a*0.5
+ p%coh%t_leaf = p%coh%med_sla * p%coh%x_fol
+ p =>p%next
+ END DO
+end subroutine sla_ini
+
+end subroutine prepare_stand
+
+!*************************************************************************
+
+subroutine calc_int ! calculation of intrinsic mortality rate
+
+use data_species
+implicit none
+INTEGER j
+
+do j=1,nspecies
+spar(j)%intr = -log(0.01)/spar(j)%max_age
+end do
+end subroutine calc_int
+
+!*************************************************************************
+
+subroutine calc_weibla
+! calculation of parameter lamda for Weibull-distribution of sress mortality
+
+use data_species
+implicit none
+INTEGER j
+REAL survage
+
+do j=1,nspecies
+spar(j)%weibla = -log(0.01)/(survage(j)**weibal)
+end do
+
+end subroutine calc_weibla
+
+!*************************************************************************
+
+REAL function survage(ispec)
+! calculation of survival time per species depending on shade tolerance class stol
+
+use data_species
+implicit none
+INTEGER :: ispec
+
+IF(spar(ispec)%stol.eq.1) survage=20.
+IF (spar(ispec)%stol.eq.2) survage=40.
+IF (spar(ispec)%stol.eq.3) survage=60.
+IF (spar(ispec)%stol.eq.4) survage=80.
+IF (spar(ispec)%stol.eq.5) survage=100.
+end function
+
+!*************************************************************************
+
+SUBROUTINE read_stand (treeunit)
+
+! Read of stand initialisation
+
+ USE data_par
+ USE data_simul
+ USE data_species
+ USE data_stand
+
+ IMPLICIT NONE
+
+ TYPE(cohort) :: coh_ini
+ REAL :: hdquo ! auxiliary variable for stress initilization
+ INTEGER :: ios,treeunit
+
+ do
+ call coh_initial (coh_ini)
+ READ(treeunit,'(5f12.5,2f10.0,i7, f10.0,i7, f9.5, f12.5)',iostat=ios) coh_ini%x_fol, coh_ini%x_frt, coh_ini%x_sap, coh_ini%x_hrt, &
+ coh_ini%x_Ahb, coh_ini%height, coh_ini%x_hbole, coh_ini%x_age, &
+ coh_ini%nTreeA,coh_ini%species, coh_ini%dcrb, coh_ini%diam
+ IF(ios<0 .or. coh_ini%x_fol .lt. -90.0) exit
+
+ coh_ini%nTreeD = 0.
+ coh_ini%x_crt = (coh_ini%x_sap + coh_ini%x_hrt) * spar(coh_ini%species)%alphac*spar(coh_ini%species)%cr_frac
+ coh_ini%x_tb = (coh_ini%x_sap + coh_ini%x_hrt) * spar(coh_ini%species)%alphac*(1.-spar(coh_ini%species)%cr_frac)
+ coh_ini%ident = max_coh + 1
+ coh_ini%Fmax = coh_ini%x_fol
+ coh_ini%x_health = 0
+ coh_ini%x_hsap = 0.
+ ns = coh_ini%species
+ coh_ini%N_fol=coh_ini%x_fol*spar(coh_ini%species)%ncon_fol ! kg * mg/g --> g
+ if (coh_ini%dcrb.eq.0..and.coh_ini%diam.eq.0..and.coh_ini%height.gt.h_sapini) then
+ CALL CALC_DBH(coh_ini%x_hbole,coh_ini%height,coh_ini%x_sap,coh_ini%x_hrt,coh_ini%x_Ahb,coh_ini%Ahc,coh_ini%ident,coh_ini%diam,coh_ini%dcrb,coh_ini%x_hsap,coh_ini%asapw)
+ else
+ coh_ini%x_hsap = (2*coh_ini%x_hbole + coh_ini%height)/3.
+ coh_ini%Asapw = coh_ini%x_sap/(spar(coh_ini%species)%prhos*coh_ini%x_hsap)
+ end if
+
+ ! Stress calculation
+ IF (coh_ini%diam.ne. 0.) THEN
+ hdquo = coh_ini%height/ (coh_ini%diam*100)
+ IF (hdquo.gt. 1. .and. (coh_ini%x_age .gt. 10..and. coh_ini%x_age .lt.50) ) THEN
+ coh_ini%x_stress = coh_ini%x_age/2
+ ELSE IF ( hdquo.gt. 1. .and. coh_ini%x_age .gt.50) THEN
+ coh_ini%x_stress = coh_ini%x_age*3./7.
+ ELSE
+ coh_ini%x_stress = 0.
+ END IF
+ ELSE
+ coh_ini%x_stress = 0.
+ END IF ! coh_ini
+
+ coh_ini%x_stress = 0.
+ coh_ini%nta = coh_ini%nTreeA
+
+ IF (.not. associated(pt%first)) THEN
+ max_coh = 0
+ allocate(pt%first)
+ pt%first%coh = coh_ini
+ nullify(pt%first%next)
+ ELSE
+ allocate(zeig)
+ zeig%coh = coh_ini
+ zeig%next => pt%first
+ pt%first => zeig
+ END IF
+ max_coh = max_coh + 1
+ enddo
+
+END SUBROUTINE read_stand
+
+!*************************************************************************
+
+SUBROUTINE coh_initial (coh_ini)
+
+ USE data_simul
+ USE data_soil
+ USE data_stand
+ USE data_species
+
+ IMPLICIT NONE
+
+ TYPE(cohort) :: coh_ini
+
+ coh_ini%nTreeA = 0.
+ coh_ini%nTreeD = 0.
+ coh_ini%nTreeM = 0.
+ coh_ini%nTreet = 0.
+ coh_ini%nta = 0.
+ coh_ini%mistletoe = 0
+
+ coh_ini%x_age = 0.
+ coh_ini%x_fol = 0.
+ coh_ini%x_sap = 0.
+ coh_ini%x_frt = 0.
+ coh_ini%x_hrt = 0.
+ coh_ini%x_crt = 0.
+ coh_ini%x_tb = 0.
+ coh_ini%x_hsap = 0.
+ coh_ini%x_hbole= 0.
+ coh_ini%x_Ahb = 0.
+
+ coh_ini%x_stress = 0
+ coh_ini%x_health = 0
+
+ coh_ini%bes = 0.
+ coh_ini%med_sla = 0.
+ coh_ini%Fmax = 0
+ coh_ini%totBio = 0.
+ coh_ini%Dbio = 0.
+ coh_ini%height = 0.
+ coh_ini%deltaB = 0.
+ coh_ini%dcrb = 0.
+ coh_ini%diam = 0.
+ coh_ini%assi = 0.
+ coh_ini%LUE = 0.
+ coh_ini%resp = 0.
+ coh_ini%netAss = 0.
+ coh_ini%NPP = 0.
+ coh_ini%weekNPP = 0.
+ coh_ini%NPPpool = 0.
+ coh_ini%t_Leaf = 0.
+ coh_ini%geff = 0.
+ coh_ini%Asapw = 0.
+ coh_ini%crown_area = 0.
+
+ coh_ini%BG = 0.
+ coh_ini%leafArea = 0.
+ coh_ini%sleafArea = 0.
+ coh_ini%FPAR = 0.
+ coh_ini%antFPAR = 0.
+ coh_ini%Irel = 0.
+
+ coh_ini%totFPAR = 0
+ coh_ini%IrelCan = 0
+ coh_ini%botLayer = 0
+ coh_ini%topLayer = 0
+ coh_ini%survp = 0.
+ coh_ini%rel_fol = 0.
+ coh_ini%gfol = 0.
+ coh_ini%gfrt = 0.
+ coh_ini%gsap = 0.
+ coh_ini%sfol = 0.
+ coh_ini%sfrt = 0.
+ coh_ini%ssap = 0.
+ coh_ini%grossass = 0.
+ coh_ini%maintres = 0.
+ coh_ini%respsap = 0.
+ coh_ini%respfrt = 0.
+ coh_ini%respbr = 0.
+
+ coh_ini%height_ini = 0.
+ coh_ini%ca_ini = 0.
+
+ coh_ini%rel_dbh_cl = 0
+ coh_ini%underst = 0
+
+ coh_ini%fol_inc = 0.
+ coh_ini%fol_inc_old = 0.
+ coh_ini%bio_inc = 0.
+ coh_ini%stem_inc = 0.
+ coh_ini%frt_inc = 0.
+ coh_ini%notViable = .FALSE.
+
+ coh_ini%intcap = 0.
+ coh_ini%prel = 0.
+ coh_ini%interc = 0.
+ coh_ini%prelCan = 0.
+ coh_ini%interc_st= 0.
+ coh_ini%aev_i = 0.
+ coh_ini%demand = 0.
+ coh_ini%supply = 0.
+ coh_ini%watuptc = 0.
+ coh_ini%gp = 0.
+ coh_ini%drIndd = 0.
+ coh_ini%drIndPS = 0.
+ coh_ini%drIndAl = 0.
+ coh_ini%nDaysGr = 0
+ coh_ini%isGrSDay = .false.
+
+ coh_ini%litC_fol = 0.
+ coh_ini%litC_fold = 0.
+ coh_ini%litN_fol = 0.
+ coh_ini%litN_fold = 0.
+ coh_ini%litC_frt = 0.
+ coh_ini%litC_frtd = 0.
+ coh_ini%litN_frt = 0.
+ coh_ini%litN_frtd = 0.
+ coh_ini%litC_stem = 0.
+ coh_ini%litN_stem = 0.
+ coh_ini%litC_tb = 0.
+ coh_ini%litC_crt = 0.
+ coh_ini%litC_tbcd = 0.
+ coh_ini%litN_tb = 0.
+ coh_ini%litN_crt = 0.
+ coh_ini%litN_tbcd = 0.
+ coh_ini%Nuptc_c = 0.
+ coh_ini%Nuptc_d = 0.
+ coh_ini%Ndemc_d = 0.
+ coh_ini%RedNc = 1.
+ coh_ini%N_pool = 0.
+ coh_ini%N_fol = 0.
+ coh_ini%wat_mg = 0. ! soley forflag_wred=9
+
+ coh_ini%nroot = 0
+ coh_ini%shelter = 0
+ coh_ini%day_bb = 0
+
+ if (coh_ini%species .ne. nspec_tree+2) then ! no root allocation for mistletoe
+ allocate (coh_ini%frtrel(nlay))
+ allocate (coh_ini%frtrelc(nlay))
+ if (flag_wred .eq. 9) then
+ allocate (coh_ini%rld(nlay))
+ coh_ini%rld = 0.
+ endif
+ allocate (coh_ini%rooteff(nlay))
+ coh_ini%frtrel = 0.
+ coh_ini%rooteff = 0.
+ end if ! end exclude mistletoe
+END SUBROUTINE coh_initial
+!*************************************************************************
+SUBROUTINE create_mistletoe
+ USE data_plant
+ USE data_simul
+ USE data_species
+ USE data_stand
+ USE data_climate
+ USE data_soil
+ USE data_species
+ USE data_par
+ IMPLICIT NONE
+ TYPE(cohort) :: coh_ini
+ real :: help_height_top, help_height_bot
+ REAL, EXTERNAL :: fi_lf, dfi_lf, ddfi_lf
+
+ ! initialising of cohort of mistletoe
+ call coh_initial (coh_ini)
+ ! set mistletoe here to 20 m height, will be changed after, when cohorts of trees will be initialised
+ help_height_top=2000
+ help_height_bot=help_height_top-50
+ ! following values are from sample calcul. of 10 year old V.austr. from Pfiz 2010
+ coh_ini%ident = max_coh + 1
+ coh_ini%species = nspec_tree+2 ! Species = species after all tree species and ground veg.
+ coh_ini%nTreeA = 1 ! #of mistletoes, to be read-in in management file
+ coh_ini%nTreeD = 0 ! dead trees
+ coh_ini%nta = coh_ini%nTreeA ! alive trees internal calc.
+ coh_ini%x_age = 10
+ coh_ini%x_fol = mistletoe_x_fol ! fol biomass per tree [kg DW/tree], 1 Viscum (10years) see Pfiz 2010
+ coh_ini%x_sap = 0. ! set near-zero for partitioning
+ coh_ini%x_frt = 0. ! set near-zero for partitioning
+ coh_ini%height = help_height_top ! highest_layer ! highest_layer of all cohorts
+ coh_ini%x_hbole = help_height_bot !
+ coh_ini%med_sla = 0. ! average cohort specific leaf area [m2/kg] is being calculated internal
+ coh_ini%Fmax = 0 ! anual change of leaf biomass, for now: now change
+ coh_ini%crown_area = 0.0189 ! max. projected crown area (m2) per individuum, calculated from Pfiz 2010
+ coh_ini%t_leaf = coh_ini%med_sla* coh_ini%x_fol !leaf area per tree [m2] !
+ coh_ini%day_bb = 1 ! evergreen
+! no partitioning of NPP into stem/leaf etc.
+! no root allocation
+ allocate(zeig)
+ zeig%coh = coh_ini
+ zeig%next => pt%first
+ pt%first => zeig
+ max_coh = max_coh + 1
+END SUBROUTINE create_mistletoe
+
+ !*************************************************************************
+
+SUBROUTINE create_soilveg
+
+! Read of stand initialisation
+
+ USE data_plant
+ USE data_simul
+ USE data_species
+ USE data_stand
+ USE data_climate
+ USE data_soil
+
+ IMPLICIT NONE
+
+ TYPE(cohort) :: coh_ini
+
+ real :: lai_help, irel_help, FRsum
+ integer :: age_stand, nr, j
+ integer :: flag_SV_allo, rnum
+ real :: troot2
+
+ REAL, EXTERNAL :: fi_lf, dfi_lf, ddfi_lf
+
+ age_stand = 0
+ lai_help = 0.
+ irel_help = 0.
+ call wclas(waldtyp)
+
+ zeig=>pt%first
+
+ DO WHILE (ASSOCIATED(zeig))
+ ns = zeig%coh%species
+ lai_help = lai_help + zeig%coh%ntreea*zeig%coh%x_fol* spar(ns)%psla_min
+ age_stand = MAX(zeig%coh%x_age,age_stand)
+ zeig=>zeig%next
+ end do
+
+ IF((flag_stand==0 .or. age_stand .le. 5) .AND. flag_sveg ==2) THEN
+ NPP_est = 10.
+ ELSE if(age_stand.le.5) then
+ if(ns.eq.4) then
+ NPP_est = 5
+ else
+ NPP_est = 10.
+ end if
+ ELSE if(flag_reg.ne.0) then
+ NPP_est = 10
+ ELSE
+ lai_help = lai_help/kpatchsize
+ irel_help = exp(-0.5*lai_help)
+ if( svar(nspec_tree+1)%RedN .lt.0.) then
+ NPP_est = irel_help * med_rad1 * 365./100. *0.5
+ else
+ NPP_est = irel_help * med_rad1 * 365./100. *0.5 * svar(nspec_tree+1)%RedN
+ end if
+ ENDIF
+
+ call coh_initial (coh_ini)
+
+ coh_ini%species = nspec_tree+1 ! numbre of species determined automatically
+ ns = coh_ini%species
+ flag_SV_allo=1
+ IF(flag_SV_allo==0) THEN
+ ! the parameters pdiam in the species.par file are used for allocation fractions
+ coh_ini%x_sap = spar(ns)%pdiam3 * NPP_est/1000.*kpatchsize
+ coh_ini%x_fol = spar(ns)%pdiam1 * NPP_est/1000.*kpatchsize
+ coh_ini%x_frt = spar(ns)%pdiam2 * NPP_est/1000.*kpatchsize
+ ELSE
+ FRsum=0.8*NPP_est/1000. ! start value as fraction of NPP in kg DM m-2
+ CALL newt (FRsum, fi_lf, dfi_lf, ddfi_lf, 0.001, 100, rnum)
+ IF(rnum==-1) THEN
+ if (.not.flag_mult8910) CALL error_mess(time,'no solution found for allocation for groundvegetation cohort: ',real(ns))
+ coh_ini%x_sap = spar(ns)%pdiam3 * NPP_est/1000.*kpatchsize
+ coh_ini%x_fol = spar(ns)%pdiam1 * NPP_est/1000.*kpatchsize
+ coh_ini%x_frt = spar(ns)%pdiam2 * NPP_est/1000.*kpatchsize
+ ELSE
+ coh_ini%x_sap = (ksi*FRsum**kappa)*kpatchsize
+ coh_ini%x_fol = (FRsum/2.)*kpatchsize
+ coh_ini%x_frt = (FRsum/2.)*kpatchsize
+ ENDIF
+ ENDIF
+
+ coh_ini%height = 60.
+ coh_ini%x_age = 1
+ coh_ini%nTreeA = 1
+ coh_ini%ident = max_coh + 1
+ coh_ini%Fmax = coh_ini%x_fol
+ coh_ini%med_sla = spar(coh_ini%species)%psla_min + spar(coh_ini%species)%psla_a*irel_help
+ coh_ini%t_leaf = coh_ini%med_sla* coh_ini%x_fol ! [m2]
+
+ coh_ini%nta = coh_ini%nTreeA
+ coh_ini%ca_ini = kpatchsize
+ coh_ini%day_bb = 100 ! assumption budding on 8.April
+
+! root allocation
+ IF (.not. associated(pt%first)) THEN
+ max_coh = 0
+ allocate(pt%first)
+ pt%first%coh = coh_ini
+ nullify(pt%first%next)
+ call root_depth (1, pt%first%coh%species, pt%first%coh%x_age, pt%first%coh%height, pt%first%coh%x_frt, pt%first%coh%x_crt, nr, troot2, pt%first%coh%x_rdpt, pt%first%coh%nroot)
+ pt%first%coh%nroot = nr
+ do j=1,nr
+ pt%first%coh%rooteff = 1. ! assumption for the first use
+ enddo
+ do j=nr+1, nlay
+ pt%first%coh%rooteff = 0. ! layers with no roots
+ enddo
+
+ ELSE
+ allocate(zeig)
+ zeig%coh = coh_ini
+ zeig%next => pt%first
+ pt%first => zeig
+ call root_depth (1, zeig%coh%species, zeig%coh%x_age, zeig%coh%height, zeig%coh%x_frt, zeig%coh%x_crt, nr, troot2, zeig%coh%x_rdpt, zeig%coh%nroot)
+ zeig%coh%nroot = nr
+ do j=1,nr
+ zeig%coh%rooteff = 1. ! assumption for the first use
+ enddo
+ do j=nr+1, nlay
+ zeig%coh%rooteff = 0. ! layers with no roots
+ enddo
+
+ END IF
+ max_coh = max_coh + 1
+
+END SUBROUTINE create_soilveg
+
+!*************************************************************************
+
+!***************************!
+! FUNCTION fi_lf *!
+!***************************!
+
+REAL FUNCTION fi_lf(x)
+ USE data_stand
+ USE data_plant
+ USE data_species
+ REAL :: x
+ fi_lf = spar(nspec_tree+1)%pss*ksi*x**kappa + (spar(nspec_tree+1)%psf+spar(nspec_tree+1)%psr)/2.*x - NPP_est/1000.
+END ! FUNCTION fi_lf
+
+!***************************!
+! FUNCTION dfi_lf *!
+!***************************!
+
+REAL FUNCTION dfi_lf(x)
+ USE data_stand
+ USE data_plant
+ USE data_species
+ REAL :: x
+ dfi_lf = spar(nspec_tree+1)%pss*ksi*kappa*x**(kappa-1.) + (spar(nspec_tree+1)%psf+spar(nspec_tree+1)%psr)/2.
+END ! FUNCTION dfi_lf
+
+!***************************!
+! FUNCTION ddfi_lf *!
+!***************************!
+
+REAL FUNCTION ddfi_lf(x)
+ USE data_stand
+ USE data_plant
+ USE data_species
+ REAL :: x
+ ddfi_lf = spar(nspec_tree+1)%pss*ksi*kappa*(kappa-1.)*x**(kappa-2.)
+END ! FUNCTION ddfi_lf
diff --git a/source_code/version2.2_windows/rand.f b/source_code/version2.2_windows/rand.f
new file mode 100755
index 0000000000000000000000000000000000000000..00f01a31e4fa7b83b432168ffe14e878f25208e4
--- /dev/null
+++ b/source_code/version2.2_windows/rand.f
@@ -0,0 +1,41 @@
+!*****************************************************************!
+!* *!
+!* 4C (FORSEE) Simulation Model *!
+!* *!
+!* *!
+!* Function: *!
+!* Algorithm as described in APPL. STATIST. 31:2 (1982) *!
+!* The function returns a pseudo-random number uniformly *!
+!* distributed between 0 and 1. *!
+!* *!
+!* 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 RAND()
+
+ INTEGER IE,IM,IG
+
+! IE, IM and IG should be set to integer values between
+! 1 and 30000 before the first entry.
+
+ COMMON /RANDOM/ IE,IM,IG
+ IE=171*MOD(IE,177)-2* (IE/177)
+ IM=172*MOD(IM,176)-35*(IM/176)
+ IG=170*MOD(IG,178)-63*(IG/178)
+
+ IF (IE.LT.0)IE=IE+30269
+ IF (IM.LT.0)IM=IM+30307
+ IF (IG.LT.0)IG=IG+30323
+
+ RAND = AMOD(FLOAT(IE) /30269.0+FLOAT(IM)/30307.0+ FLOAT(IG) /30323.0,1.0)
+
+ RETURN
+
+END function rand
diff --git a/source_code/version2.2_windows/read_spec.f b/source_code/version2.2_windows/read_spec.f
new file mode 100755
index 0000000000000000000000000000000000000000..abf96cd3bc1170215783411b555eb5f4af2345f6
--- /dev/null
+++ b/source_code/version2.2_windows/read_spec.f
@@ -0,0 +1,252 @@
+!*****************************************************************!
+!* *!
+!* 4C (FORESEE) Simulation Model *!
+!* *!
+!* *!
+!* Subroutines for: *!
+!* readspec: Read species parameters from file *!
+!* *!
+!* 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 readspec
+
+! input of species data from file
+
+use data_par
+use data_simul
+use data_species
+use data_stand
+use data_soil_cn
+use data_soil
+implicit none
+integer i,ios,nowunit
+character text
+logical ex
+
+nowunit=getunit()
+ if (.not.flag_mult8910) then
+ print *,' '
+ print *,' >>>foresee message: now reading species parameter file...'
+ endif
+
+do
+ call testfile(specfile(ip),ex)
+ if (.not.flag_mult8910) print *,' '
+ if(ex .eqv. .false.) cycle
+ exit
+end do
+
+open(nowunit, FILE=trim(specfile(ip)), ACTION="READ")
+do
+ read(nowunit,'(A)') text
+ if (text .ne. '!') then
+ exit
+ end if
+end do
+backspace nowunit
+
+ read(nowunit,*) text, nspecies
+ read(nowunit,*) text, nspec_tree
+
+ if(.not.allocated(spar)) allocate(spar(nspecies))
+ if(.not.allocated(svar)) allocate(svar(nspecies))
+ if(.not.allocated(nrspec)) allocate(nrspec(nspecies))
+ nrspec = 0
+
+! read intermediate lines
+ do
+ read(nowunit,'(A)') text
+ if (text .ne. '!') then
+ exit
+ end if
+ end do
+ backspace nowunit
+
+ do i=1,nspecies
+ read(nowunit,*) text,spar(i)%species_name
+ if (text .ne. '!') then
+ svar(i)%daybb = 0
+ svar(i)%ext_daybb = 0
+ svar(i)%sum_nTreeA = 0
+ svar(i)%anz_coh = 0
+ svar(i)%RedN = -99.0
+ svar(i)%RedNm = 0.0
+ svar(i)%med_diam = 0.0
+ svar(i)%dom_height = 0.0
+ svar(i)%drIndAl = 0.0
+ svar(i)%sumNPP = 0.0
+ svar(i)%sum_bio = 0.0
+ svar(i)%sum_lai = 0.0
+ svar(i)%act_sum_lai= 0.0
+ svar(i)%fol = 0.0
+ svar(i)%hrt = 0.0
+ svar(i)%sap = 0.0
+ svar(i)%frt = 0.0
+ svar(i)%totsteminc = 0.0
+ svar(i)%totstem_m3 = 0.0
+ svar(i)%sumvsab = 0.0
+ svar(i)%sumvsdead = 0.0
+ svar(i)%sumvsdead_m3 = 0.
+ svar(i)%crown_area = 0.0
+ svar(i)%Ndem = 0.0
+ svar(i)%basal_area = 0.0
+ svar(i)%sumvsab = 0.0
+ else
+ write (*,*) '! *** not enough species in ', specfile(ip), (i-1),' of ', nspecies
+ call errorfile (specfile(ip), 0, nowunit)
+ call error_mess(time, 'not enough species in '//specfile(ip), real(i-1))
+ exit
+ endif
+ enddo
+
+! read intermediate lines
+ read(nowunit,'(A)') text
+ if (text .ne. '!') then
+ do
+ read(nowunit,'(A)') text
+ if (text .eq. '!') then
+ do
+ read(nowunit,'(A)') text
+ if (text .ne. '!') then
+ exit
+ end if
+ end do
+ exit
+ end if
+ end do
+ else
+ do
+ read(nowunit,'(A)') text
+ if (text .ne. '!') then
+ exit
+ end if
+ end do
+ endif
+ backspace nowunit
+
+ read(nowunit,*) text,(spar(i)%species_short_name,i=1,nspecies) ! read abbreviated names
+ read(nowunit,*) text,(spar(i)%max_age,i=1,nspecies)
+ read(nowunit,*) text,(spar(i)%yrec,i=1,nspecies)
+ read(nowunit,*) text,(spar(i)%stol,i=1,nspecies)
+ read(nowunit,*) text,(spar(i)%pfext, i=1,nspecies)
+ read(nowunit,*) text,(spar(i)%sigman,i=1,nspecies)
+ read(nowunit,*) text,(spar(i)%respcoeff,i=1,nspecies)
+ read(nowunit,*) text,(spar(i)%prg,i=1,nspecies)
+ read(nowunit,*) text,(spar(i)%prms,i=1,nspecies)
+ read(nowunit,*) text,(spar(i)%prmr,i=1,nspecies)
+ read(nowunit,*) text,(spar(i)%psf,i=1,nspecies)
+ read(nowunit,*) text,(spar(i)%pss,i=1,nspecies)
+ read(nowunit,*) text,(spar(i)%psr,i=1,nspecies)
+ read(nowunit,*) text,(spar(i)%pcnr,i=1,nspecies)
+ read(nowunit,*) text,(spar(i)%ncon_fol,i=1,nspecies)
+ read(nowunit,*) text,(spar(i)%ncon_frt,i=1,nspecies)
+ read(nowunit,*) text,(spar(i)%ncon_crt,i=1,nspecies)
+ read(nowunit,*) text,(spar(i)%ncon_tbc,i=1,nspecies)
+ read(nowunit,*) text,(spar(i)%ncon_stem,i=1,nspecies)
+ read(nowunit,*) text,(spar(i)%reallo_fol,i=1,nspecies)
+ read(nowunit,*) text,(spar(i)%reallo_frt,i=1,nspecies)
+ read(nowunit,*) text,(spar(i)%alphac,i=1,nspecies)
+ read(nowunit,*) text,(spar(i)%cr_frac,i=1,nspecies)
+ read(nowunit,*) text,(spar(i)%prhos,i=1,nspecies)
+ read(nowunit,*) text,(spar(i)%pnus,i=1,nspecies)
+ read(nowunit,*) text,(spar(i)%pha,i=1,nspecies)
+ read(nowunit,*) text,(spar(i)%pha_coeff1,i=1,nspecies)
+ read(nowunit,*) text,(spar(i)%pha_coeff2,i=1,nspecies)
+ read(nowunit,*) text,(spar(i)%pha_v1,i=1,nspecies)
+ read(nowunit,*) text,(spar(i)%pha_v2,i=1,nspecies)
+ read(nowunit,*) text,(spar(i)%pha_v3,i=1,nspecies)
+ read(nowunit,*) text,(spar(i)%crown_a,i=1,nspecies)
+ read(nowunit,*) text,(spar(i)%crown_b,i=1,nspecies)
+ read(nowunit,*) text,(spar(i)%crown_c,i=1,nspecies)
+ read(nowunit,*) text,(spar(i)%psla_min,i=1,nspecies)
+ read(nowunit,*) text,(spar(i)%psla_a,i=1,nspecies)
+ read(nowunit,*) text,(spar(i)%phic,i=1,nspecies)
+ read(nowunit,*) text,(spar(i)%pnc,i=1,nspecies)
+ read(nowunit,*) text,(spar(i)%kCO2_25,i=1,nspecies)
+ read(nowunit,*) text,(spar(i)%kO2_25,i=1,nspecies)
+ read(nowunit,*) text,(spar(i)%pc_25,i=1,nspecies)
+ read(nowunit,*) text,(spar(i)%q10_kCO2,i=1,nspecies)
+ read(nowunit,*) text,(spar(i)%q10_kO2,i=1,nspecies)
+ read(nowunit,*) text,(spar(i)%q10_pc,i=1,nspecies)
+ read(nowunit,*) text,(spar(i)%pb,i=1,nspecies)
+ read(nowunit,*) text,(spar(i)%PItmin,i=1,nspecies)
+ read(nowunit,*) text,(spar(i)%PItopt,i=1,nspecies)
+ read(nowunit,*) text,(spar(i)%PItmax,i=1,nspecies)
+ read(nowunit,*) text,(spar(i)%PIa,i=1,nspecies)
+ read(nowunit,*) text,(spar(i)%PPtmin,i=1,nspecies)
+ read(nowunit,*) text,(spar(i)%PPtopt,i=1,nspecies)
+ read(nowunit,*) text,(spar(i)%PPtmax,i=1,nspecies)
+ read(nowunit,*) text,(spar(i)%PPa,i=1,nspecies)
+ read(nowunit,*) text,(spar(i)%PPb,i=1,nspecies)
+ read(nowunit,*) text,(spar(i)%CSTbC,i=1,nspecies)
+ read(nowunit,*) text,(spar(i)%CSTbT,i=1,nspecies)
+ read(nowunit,*) text,(spar(i)%CSa,i=1,nspecies)
+ read(nowunit,*) text,(spar(i)%CSb,i=1,nspecies)
+ read(nowunit,*) text,(spar(i)%LTbT,i=1,nspecies)
+ read(nowunit,*) text,(spar(i)%LTcrit,i=1,nspecies)
+ read(nowunit,*) text,(spar(i)%Lstart,i=1,nspecies)
+ read(nowunit,*) text,(spar(i)%Phmodel,i=1,nspecies)
+ read(nowunit,*) text,(spar(i)%end_bb,i=1,nspecies)
+ read(nowunit,*) text,(spar(i)%fpar_mod,i=1,nspecies)
+ read(nowunit,*) text,(spar(i)%ceppot_spec,i=1,nspecies)
+ read(nowunit,*) text,(spar(i)%Nresp,i=1,nspecies)
+ read(nowunit,*) text,(spar(i)%regflag, i=1,nspecies)
+ read(nowunit,*) text,(spar(i)%seedrate, i=1,nspecies)
+ read(nowunit,*) text,(spar(i)%seedmass, i=1,nspecies)
+ read(nowunit,*) text,(spar(i)%seedsd, i=1,nspecies)
+ read(nowunit,*) text,(spar(i)%seeda, i=1,nspecies)
+ read(nowunit,*) text,(spar(i)%seedb, i=1,nspecies)
+ read(nowunit,*) text,(spar(i)%pheight1, i=1,nspecies)
+ read(nowunit,*) text,(spar(i)%pheight2, i=1,nspecies)
+ read(nowunit,*) text,(spar(i)%pheight3, i=1,nspecies)
+ read(nowunit,*) text,(spar(i)%pdiam1, i=1,nspecies)
+ read(nowunit,*) text,(spar(i)%pdiam2, i=1,nspecies)
+ read(nowunit,*) text,(spar(i)%pdiam3, i=1,nspecies)
+ read(nowunit,*) text,(spar(i)%k_opm_fol , i=1,nspecies)
+ read(nowunit,*) text,(spar(i)%k_syn_fol , i=1,nspecies)
+ read(nowunit,*) text,(spar(i)%k_opm_frt , i=1,nspecies)
+ read(nowunit,*) text,(spar(i)%k_syn_frt , i=1,nspecies)
+ read(nowunit,*) text,(spar(i)%k_opm_crt , i=1,nspecies)
+ read(nowunit,*) text,(spar(i)%k_syn_crt , i=1,nspecies)
+ read(nowunit,*) text,(spar(i)%k_opm_tb , i=1,nspecies)
+ read(nowunit,*) text,(spar(i)%k_syn_tb , i=1,nspecies)
+ read(nowunit,*) text,(spar(i)%k_opm_stem, i=1,nspecies)
+ read(nowunit,*) text,(spar(i)%k_syn_stem, i=1,nspecies)
+ read(nowunit,*) text,(spar(i)%spec_rl, i=1,nspecies)
+ read(nowunit,*) text,(spar(i)%tbase, i=1,nspecies)
+ read(nowunit,*) text,(spar(i)%topt, i=1,nspecies)
+ read(nowunit,*) text,(spar(i)%bdmax_coef, i=1,nspecies)
+ read(nowunit,*) text,(spar(i)%porcrit_coef, i=1,nspecies)
+ read(nowunit,*) text,(spar(i)%ph_opt_max, i=1,nspecies)
+ read(nowunit,*) text,(spar(i)%ph_opt_min, i=1,nspecies)
+ read(nowunit,*) text,(spar(i)%ph_max, i=1,nspecies)
+ read(nowunit,*) text,(spar(i)%ph_min, i=1,nspecies)
+ read(nowunit,*) text,(spar(i)%v_growth, i=1,nspecies)
+
+ios = 0
+call errorfile (specfile(ip), ios, nowunit)
+
+do i=1,nspecies
+ spar(i)%cnr_fol = cpart / (spar(i)%ncon_fol / 1000.)
+ spar(i)%cnr_frt = cpart / (spar(i)%ncon_frt / 1000.)
+ spar(i)%cnr_crt = cpart / (spar(i)%ncon_crt / 1000.)
+ spar(i)%cnr_tbc = cpart / (spar(i)%ncon_tbc / 1000.)
+ spar(i)%cnr_stem = cpart / (spar(i)%ncon_stem / 1000.)
+enddo
+
+close(nowunit)
+
+end subroutine readspec
+!------------------------------------------------------------------------
+
+
+
diff --git a/source_code/version2.2_windows/readsim.f b/source_code/version2.2_windows/readsim.f
new file mode 100755
index 0000000000000000000000000000000000000000..acadc706d0309897fa2c485ce9376bf98d027cbc
--- /dev/null
+++ b/source_code/version2.2_windows/readsim.f
@@ -0,0 +1,877 @@
+!*****************************************************************!
+!* *!
+!* 4C (FORESEE) Simulation Model *!
+!* *!
+!* Subroutines for: *!
+!* - READSIM: Read simulation options from file *!
+!* - ALLOFILE: Allocate simulation files *!
+!* - READCON *!
+!* *!
+!* 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 readsim
+
+! read simulation options from file
+
+use data_mess
+use data_out
+use data_par
+use data_simul
+use data_species
+use data_stand
+use data_site
+use data_tsort
+use data_climate
+
+implicit none
+
+logical ex
+integer i, ios, ios1, nowunit, nowunit1, k, anzclim, j, l, helpi, helpw, helpy, ihelp, ilen
+character:: a, ttext
+character (150) tspec, tname, tclim, tval, tsite, tman, ttree, tdepo, tred, tlit, tsoilid, &
+ pathdir1, pathdir2,pathdir3, pathdir4, pathdir5, pathdir6, pathdir7, &
+ climszen, siteall, climall,site_name_all
+character(50), dimension(:), allocatable:: site_name_ad
+character(50), dimension(:), allocatable:: climfile_ad
+character(50), dimension(:), allocatable:: sitefile_ad
+character(50), dimension(:), allocatable:: manfile_ad
+character(50), dimension(:), allocatable:: treefile_ad
+character(50), dimension(:), allocatable:: wpmfile_ad
+character(50), dimension(:), allocatable:: depofile_ad
+character(50), dimension(:), allocatable:: redfile_ad
+character(50), dimension(:), allocatable:: litfile_ad
+character(150):: text
+character(50) :: istand
+character(10) :: helpsim, text4
+
+real, dimension(:), allocatable:: clim_long, clim_lat, clim_height ! coordinates and height of climate stations
+character(10), dimension(:), allocatable:: climnum
+character(50), dimension(:), allocatable:: clim_nam
+
+ nowunit = getunit()
+ ios = 0
+ nvar = 0
+
+ call testfile(simfile,ex)
+ if(ex .eqv. .false.) return
+ open(nowunit,file=simfile,iostat=ios,status='old',action='read')
+
+ read(nowunit,*,iostat=ios) flag_multi
+
+ if(flag_multi .ge. 1) then
+ read(nowunit,*,iostat=ios) site_nr
+
+ if(flag_multi .eq. 9 .or. flag_multi .eq. 10) then
+ flag_mult910 = .True.
+ else
+ flag_mult910 = .False.
+ endif
+
+ if((flag_mult910 .or. flag_multi .eq. 8) .and. (site_nr .gt.1)) then
+ flag_mult8910 = .True.
+ else
+ flag_mult8910 = .False.
+ endif
+
+ repeat_number = site_nr
+ allocate(sitenum(site_nr))
+ allocate(clim_id(site_nr))
+ allocate(soilid(site_nr))
+ allocate(gwtable(site_nr))
+ allocate(NOdep(site_nr))
+ allocate(NHdep(site_nr))
+ clim_id = "xxx"
+ NOdep = 0.
+ NHdep = 0.
+ endif
+
+ select case (flag_multi)
+ case (1, 4)
+ flag_clim = 1
+ case (7, 8, 9, 10)
+ flag_clim = 1
+ flag_trace = .FALSE.
+ case default
+ flag_clim = 0
+ end select
+
+ read(nowunit,*,iostat=ios) ! skip comment line 'simulation specifications'
+ read(nowunit,*,iostat=ios) year
+ read(nowunit,*,iostat=ios) time_b
+ read(nowunit,*,iostat=ios) kpatchsize
+ read(nowunit,*,iostat=ios) dz
+ read(nowunit,*,iostat=ios) ns_pro
+ read(nowunit,*,iostat=ios) ! skip comment line 'choice of model options'
+ read(nowunit,*,iostat=ios) flag_mort
+ read(nowunit,*,iostat=ios) flag_reg
+ read(nowunit,*,iostat=ios) flag_forska
+ read(nowunit,*,iostat=ios) flag_stand
+ read(nowunit,*,iostat=ios) flag_sveg
+ read(nowunit,*,iostat=ios) flag_mg
+ read(nowunit,*,iostat=ios) flag_dis
+ read(nowunit,*,iostat=ios) flag_light
+ read(nowunit,*,iostat=ios) flag_folhei
+ read(nowunit,*,iostat=ios) flag_volfunc
+ read(nowunit,*,iostat=ios) flag_resp
+ read(nowunit,*,iostat=ios) flag_limi
+ read(nowunit,*,iostat=ios) flag_decomp
+ read(nowunit,*,iostat=ios) flag_sign
+ read(nowunit,*,iostat=ios) flag_wred
+ read(nowunit,*,iostat=ios) flag_wurz
+ read(nowunit,*,iostat=ios) flag_cond
+ read(nowunit,*,iostat=ios) flag_int
+ read(nowunit,*,iostat=ios) flag_eva
+ read(nowunit,*,iostat=ios) flag_co2
+ read(nowunit,*,iostat=ios) flag_sort
+ read(nowunit,*,iostat=ios) flag_wpm
+ read(nowunit,*,iostat=ios) flag_stat
+ read(nowunit,*,iostat=ios) ! skip comment line 'output specifications'
+ read(nowunit,*,iostat=ios) time_out
+
+
+! define name of yearly output variables
+ nyvar = 1
+ read(nowunit,*,iostat=ios) outy_file(nyvar)
+ do while (trim(outy_file(nyvar)) .ne. 'end')
+ nyvar = nyvar + 1
+ read(nowunit,*) outy_file(nyvar)
+ enddo
+
+ read(nowunit,*,iostat=ios) flag_dayout
+! define name of daily output variables
+ ndvar = 1
+ read(nowunit,*) outd_file(ndvar)
+ do while (trim(outd_file(ndvar)) .ne. 'end')
+ ndvar = ndvar + 1
+ read(nowunit,*) outd_file(ndvar)
+ enddo
+
+ read(nowunit,*,iostat=ios) flag_cohout
+! define name of cohort output variables
+ ncvar = 1
+ read(nowunit,*) outc_file(ncvar)
+ do while (trim(outc_file(ncvar)) .ne. 'end')
+ ncvar = ncvar + 1
+ read(nowunit,*) outc_file(ncvar)
+ enddo
+
+ read(nowunit,*,iostat=ios) flag_sum
+ read(nowunit,*,iostat=ios) ! skip comment line 'input'
+
+ if (.not.flag_mult910) call allofile
+
+ SELECT CASE(flag_multi)
+ CASE (0,1,2,3,6)
+ jpar = 0
+ DO i=1,site_nr
+ if(i .gt. 1)then
+ read(nowunit,*,iostat=ios) ! skip comment line 'run number'
+ do
+ jpar = jpar + 1
+ read(nowunit,*) vpar(jpar), simpar(jpar)
+ if (vpar(jpar) .lt. -90.0) exit
+ enddo
+ endif
+
+ read(nowunit,'(A)',iostat=ios) specfile(i)
+ read(nowunit,'(A)') site_name(i)
+ read(nowunit,'(A)') climfile(i)
+ read(nowunit,'(A)') sitefile(i)
+ read(nowunit,'(A)') valfile(i)
+ read(nowunit,'(A)') treefile(i)
+ read(nowunit,'(A)') standid(i)
+ read(nowunit,'(A)') manfile(i)
+ read(nowunit,'(A)') depofile(i)
+ read(nowunit,'(A)') redfile(i)
+ read(nowunit,'(A)',iostat=ios) litfile(i)
+
+ ! fill clim_id
+ clim_id(i) = climfile(i)
+ ios1=-1
+ ! measurements
+ if(flag_multi.ne.2) then
+ if (ios .eq. 0) read(nowunit,'(A)',iostat=ios1) text
+ if (ios1 .eq. 0) then
+ if (flag_stat .gt. 0 .and. i .eq. 1) then
+ allocate (mesfile(anz_mesf))
+ mesfile(1) = text
+ ttext = adjustl(text)
+ if (ttext .eq. '!' .or. ttext .eq. '*') then
+ backspace (nowunit)
+ else
+ if (.not.flag_mult8910) write (*, '(A, I3,A,A)')' >>>foresee message: site_nr ',i,'; filename of measurements: ', trim(mesfile(1))
+ endif
+ else
+ ttext = adjustl(text)
+ if (ttext .eq. '!' .or. ttext .eq. '*') backspace (nowunit)
+ endif
+ endif
+ end if
+ if (.not.flag_mult8910) print *, ' >>>foresee message: site_nr ',i,'; input of filenames completed'
+ end DO
+
+ CASE (4, 5, 8)
+ allocate(latitude(site_nr))
+ allocate(RedN_list(15, site_nr))
+ RedN_list = -99.9
+ read(nowunit,'(A)',iostat=ios) specfile(1)
+ read(nowunit,'(A)') site_name(1)
+ read(nowunit,'(A)') treefile(1)
+ read(nowunit,'(A)') manfile(1)
+ read(nowunit,'(A)') siteall ! control xxx.con
+ read(nowunit,'(A)') climall ! climate stations with coordination
+ read(nowunit,'(A)') pathdir1 ! path for climate scenarios
+ read(nowunit,'(A)') pathdir2 ! path for soil file xxx.sop or name of total soil file (flag_multi=8)
+ read(nowunit,'(A)') climszen ! labeling climate scenarios
+ if (flag_multi .eq. 8.or.flag_multi.eq.5) read(nowunit,*) text ! BRB / BAWUE / DEU
+ if (.not.flag_mult8910) print *, ' >>>foresee message: Input of filenames completed'
+
+ site_name1 = site_name(1)
+! define name of output variables
+ nvar = 1
+ read(nowunit,*) outvar(nvar)
+ do while (trim(outvar(nvar)) .ne. 'end')
+ nvar = nvar + 1
+ read(nowunit,*) outvar(nvar)
+ enddo
+ if (nvar .gt. 1) allocate(output_var(nvar,site_nr,0:year))
+
+ helpw = 0
+ helpi = 0
+ do i = 1, nvar-1
+ select case (trim(outvar(i)))
+
+ case ('AET_mon','AETmon','aetmon','aet_mon','cwb_mon','cwbmon','PET_mon','PETmon','petmon','pet_mon', &
+ 'GPP_mon','GPPmon','gppmon','gpp_mon','NEP_mon','NEPmon','nepmon','nep_mon','NPP_mon','NPPmon','nppmon','npp_mon', &
+ 'perc_mon','percmon','temp_mon','tempmon','prec_mon','precmon', 'resps_mon','respsmon','TER_mon','TERmon','ter_mon','termon')
+ flag_cum = 1
+ helpi = helpi + 1
+ output_var(i,1,0) = 1.*helpi ! field numbre of monthly value
+
+ case ('AET_week','AETweek','aetweek','aet_week','cwb_week','cwbweek','PET_week','PETweek','petweek','pet_week', &
+ 'GPP_week','GPPweek','gppweek','gpp_week','NEP_week','NEPweek','nepweek','nep_week','NPP_week','NPPweek','nppweek','npp_week', &
+ 'perc_week','percweek','temp_week','tempweek','prec_week','precweek', 'resps_week','respsweek', 'TER_week','TERweek','ter_week','terweek')
+ flag_cum = 1
+ helpw = helpw + 1
+ output_var(i,1,0) = 1.*helpw ! field numbre of weekly values
+
+ end select ! outvar
+
+ enddo
+ if (helpi .gt. 0) then
+ allocate(output_varm(helpi,site_nr,year,12))
+ endif
+ if (helpw .gt. 0) then
+ allocate(output_varw(helpw,site_nr,year,52))
+ endif
+
+ call errorfile(simfile, ios, nowunit)
+
+! reading file with description of climate stations used
+ allocate(climnum(3000))
+ allocate(clim_long(3000))
+ allocate(clim_lat(3000))
+ allocate(clim_height(3000))
+ allocate(clim_nam(3000))
+
+ call testfile(climall,ex)
+ if (ex .eqv. .false.) return
+ nowunit1 = getunit()
+ ios1 = 0
+ open(nowunit1,file=climall,iostat=ios,status='old',action='read')
+ k=1
+ do
+ READ(nowunit1,'(A)',iostat=ios1) a
+ IF (a .ne. '!') exit
+
+ end do
+ backspace nowunit1
+
+ do
+ read(nowunit1,*,iostat=ios1) climnum(k), clim_long(k),clim_lat(k), &
+ clim_height(k)
+ if(ios1 .lt. 0) exit
+ k = k+1
+ end do
+ anzclim = k-1
+ ios1 = 0
+
+ call errorfile(climall, ios1, nowunit1)
+
+! reading control file with site-id, climate-id, soil-id, gwtabe-id
+ call testfile(siteall,ex)
+ if (ex .eqv. .false.) return
+ nowunit1 = getunit()
+ open(nowunit1,file=siteall,iostat=ios1,status='old',action='read')
+ do
+ READ(nowunit1,'(A)',iostat=ios1) a
+ IF (a .ne. '!') exit
+
+ end do
+ backspace nowunit1
+! if (flag_multi .eq. 8) read(nowunit1,*) text ! BRB / BAWUE / DEU
+
+ select case (trim(text))
+ case ('BRB')
+ flag_climnam = 1
+ case ('BAWUE')
+ flag_climnam = 2
+ case ('DEU')
+ flag_climnam = 3
+ case ('REMO')
+ flag_climnam = 4
+ case('WETTREG')
+ flag_climnam =5
+ end select
+
+ do i=1,site_nr
+ select case (flag_multi)
+ case (4)
+ read(nowunit1,*,iostat=ios1) sitenum(i), clim_id(i), soilid(i), gwtable(i)
+ flag_climnam = 1
+
+ sitefile(i) =trim(pathdir2)//'wbuek'//trim(soilid(i))//'.sop'
+ valfile(i) =trim(pathdir2)//'wbuek'//trim(soilid(i))//'.soi'
+ standid(i) = sitenum(i)
+
+ case (5,8)
+ call readcon(i, nowunit1)
+ soilid(i) = adjustl(soilid(i))
+ ihelp = len(trim(soilid(i)))
+ sitefile(i) = trim(pathdir2)
+ if( flag_climnam.eq.3) then
+ climfile(i) = trim(pathdir1)//trim(clim_id(i))//trim(climszen)//'.dat'
+ end if
+ if(flag_climnam.eq.4) then
+ climfile(i) = trim(pathdir1)//'gp_'//trim(clim_id(i))//'_'//trim(climszen)//'.txt'
+ end if
+
+ if(flag_climnam.eq.5) then
+ climfile(i) = trim(pathdir1)//trim(clim_id(i))//'_'//trim(climszen)//'.dat'
+ end if
+ end select
+
+
+ do j = 1,anzclim
+ if(clim_id(i).eq.climnum(j)) then
+ select case (flag_climnam)
+
+ case (1) ! ÖWK
+ if(flag_climtyp .eq. 5) then
+ climfile(i) = trim(pathdir1)//trim(clim_nam(j))//trim(climszen)//'.dat'
+ else
+ climfile(i) = trim(pathdir1)//trim(clim_nam(j))//trim(climszen)//'.cli'
+ end if
+
+ case (2) ! Klara
+ climfile(i) = trim(pathdir1)//trim(climnum(j))//trim(climszen)//'.dat'
+ end select
+ latitude(i) = clim_lat(j)
+ exit
+ end if
+ if (j .eq. anzclim) then
+ write (unit_err,*) '*** 4C-error - searching in file:', trim(climall)
+ write (unit_err,*) ' no climate station found for climate id: ', clim_id(i)
+ write (unit_err,*)
+ endif
+ end do
+
+! fill in sitefile
+ site_name(i) = site_name(1)
+ specfile(i) = specfile(1)
+ treefile(i) = treefile(1)
+ manfile(i) = manfile(1)
+ depofile(i) = 'dummy.dep'
+ redfile = 'dummy.red'
+ litfile = 'dummy.lit'
+ enddo
+
+ if ((.not.flag_mult8910) .and. (ios1 .lt. 0)) print *, 'no information for site number ', i
+ call errorfile(siteall, ios1, nowunit1)
+
+ deallocate(climnum)
+ deallocate(clim_long)
+ deallocate(clim_lat)
+ deallocate(clim_height)
+ deallocate(clim_nam)
+
+ close(nowunit1)
+
+! variation of flag_multi= 5, especially for SILVISTRAT
+ CASE (7)
+
+ allocate(site_name_ad(site_nr))
+ allocate(climfile_ad(site_nr))
+ allocate(sitefile_ad(site_nr))
+ allocate(manfile_ad(site_nr))
+ allocate(treefile_ad(site_nr))
+ allocate(depofile_ad(site_nr))
+ allocate(redfile_ad(site_nr))
+ allocate(litfile_ad(site_nr))
+
+ allocate(fl_co2(site_nr))
+
+ read(nowunit,'(A)',iostat=ios) specfile(1)
+ read(nowunit,'(A)') site_name_all
+ read(nowunit,'(A)') siteall
+ read(nowunit,'(A)') pathdir1 ! path climate file
+ read(nowunit,'(A)') pathdir2 ! path soil file
+ read(nowunit,'(A)') pathdir3 ! path treeini file
+ read(nowunit,'(A)') pathdir4 ! path management file
+ read(nowunit,'(A)') pathdir5 ! path deposition file
+ read(nowunit,'(A)') pathdir6 ! path RedN file
+ read(nowunit,'(A)') pathdir7 ! path litter file
+
+ call errorfile(simfile, ios, nowunit)
+
+! reading control file with site-id,name, climate scenario, soil-id, man-file, treeini-file, dep-file
+
+ call testfile(siteall,ex)
+ if (ex .eqv. .false.) return
+
+ nowunit1 = getunit()
+
+ open(nowunit1,file=siteall,iostat=ios1,status='old',action='read')
+ do
+ READ(nowunit1,'(A)',iostat=ios1) a
+ IF (a .ne. '!') exit
+
+ end do
+ backspace nowunit1
+
+ do i=1,site_nr
+ read(nowunit1,*,iostat=ios1) sitenum(i),site_name_ad(i), climfile_ad(i),sitefile_ad(i),treefile_ad(i), &
+ manfile_ad(i),depofile_ad(i),redfile_ad(i),litfile_ad(i), fl_co2(i)
+ specfile(i) = specfile(1)
+ standid(i) = sitenum(i)
+ site_name(i)= trim(site_name_all)//trim(site_name_ad(i))
+ climfile(i) = trim(pathdir1)//trim(climfile_ad(i))
+ sitefile(i) = trim(pathdir2)//trim(sitefile_ad(i))
+ treefile(i) = trim(pathdir3)//trim(treefile_ad(i))
+ manfile(i) = trim(pathdir4)//trim(manfile_ad(i))
+ depofile(i) = trim(pathdir5)//trim(depofile_ad(i))
+ redfile(i) = trim(pathdir6)//trim(redfile_ad(i))
+ litfile(i) = trim(pathdir7)//trim(litfile_ad(i))
+
+ enddo
+ call errorfile(siteall, ios1, nowunit1)
+
+ deallocate(site_name_ad)
+ deallocate(climfile_ad)
+ deallocate(sitefile_ad)
+ deallocate(manfile_ad)
+ deallocate(treefile_ad)
+ deallocate(depofile_ad)
+ deallocate(redfile_ad)
+ deallocate(litfile_ad)
+ if (allocated(wpmfile_ad)) deallocate(wpmfile_ad)
+
+ close(nowunit1)
+
+ CASE (9, 10)
+
+ ! read once only per climate station
+ allocate(sitefile(site_nr))
+ allocate(climfile(site_nr))
+ allocate(treefile(site_nr))
+ allocate(manfile(site_nr))
+ allocate(standid(site_nr))
+ allocate(latitude(site_nr))
+ allocate(site_name(site_nr))
+ allocate(RedN_list(15, site_nr))
+ RedN_list = -99.9
+
+ ! read once only
+ allocate(specfile(1))
+ allocate(depofile(1))
+ allocate(redfile(1))
+ allocate(litfile(1))
+ allocate(valfile(1))
+
+ read(nowunit,'(A)',iostat=ios) specfile(1)
+ read(nowunit,'(A)') site_name(1)
+ read(nowunit,'(A)') treefile(1)
+ read(nowunit,'(A)') manfile(1)
+ read(nowunit,'(A)') siteall ! control file xxx.con
+ read(nowunit,'(A)') climall ! climate station with coordiantes
+ read(nowunit,'(A)') pathdir1 ! path of climate scenarios
+ read(nowunit,'(A)') pathdir2 ! path of soil file xxx.sop or name of total soil file (flag_multi=8)
+ read(nowunit,'(A)') climszen ! labeling climate scenarios
+ read(nowunit,'(A)') text ! degree of climate scenarios
+ read(nowunit,*) nrreal ! amount of realisations/implementations
+
+ if (.not.flag_mult8910) print *, ' >>>foresee message: Input of filenames completed'
+
+ depofile(1) = 'dummy.dep'
+ redfile(1) = 'dummy.red'
+ litfile(1) = 'dummy.lit'
+ site_name = site_name(1)
+ site_name1 = site_name(1)
+
+ ilen = len(trim(text))
+ text = adjustl(text)
+ nrclim = 0
+ do while (ilen .gt. 0)
+ nrclim = nrclim + 1
+ ihelp = scan(text, ' ')
+ typeclim(nrclim) = adjustl(text(1:ihelp-1))
+ text = adjustl(text(ihelp:))
+ ilen = len(trim(text))
+ enddo
+
+ ! processing of nrreal realisations/implementations of climate scenarios
+ site_anz = nrreal * nrclim * site_nr
+ allocate(climszenfile(site_nr, nrclim, nrreal))
+
+! define name of output variables
+ nvar = 1
+ read(nowunit,*) outvar(nvar)
+ do while (trim(outvar(nvar)) .ne. 'end')
+ nvar = nvar + 1
+ read(nowunit,*) outvar(nvar)
+ enddo
+
+ if (nvar .gt. 1) then
+ allocate(output_var(nvar-1,1,0:year))
+ allocate(output_unit(nvar-1))
+ allocate(climszenres(nvar-1,site_nr,nrclim,nrreal))
+ output_unit = -99
+ output_unit_all = -99
+
+ helpy = 0
+ helpi = 0
+ helpw = 0
+ do i = 1, nvar-1
+
+ select case (trim(outvar(i)))
+
+ case ('AET_year','AETyear','aetyear','aet_year','cwb_year','cwbyear','PET_year','PETyear','petyear','pet_year', &
+ 'GPP_year','GPPyear','gppyear','gpp_year','NEP_year','NEPyear','nepyear','nep_year','NPP_year','NPPyear','nppyear','npp_year', &
+ 'perc_year','percyear','temp_year','tempyear','prec_year','precyear', 'resps_year','respsyear','TER_year','TERyear','ter_year','teryear')
+ flag_cum = 1
+ helpy = helpy + 1
+ output_var(i,1,0) = 1.*helpy ! field numbre of yearly values
+
+ case ('AET_mon','AETmon','aetmon','aet_mon','cwb_mon','cwbmon','PET_mon','PETmon','petmon','pet_mon', &
+ 'GPP_mon','GPPmon','gppmon','gpp_mon','NEP_mon','NEPmon','nepmon','nep_mon','NPP_mon','NPPmon','nppmon','npp_mon', &
+ 'perc_mon','percmon','temp_mon','tempmon','prec_mon','precmon', 'resps_mon','respsmon','TER_mon','TERmon','ter_mon','termon')
+ flag_cum = 1
+ helpi = helpi + 1
+ output_var(i,1,0) = 1.*helpi ! field numbre of monthly values
+
+ case ('AET_week','AETweek','aetweek','aet_week','cwb_week','cwbweek','PET_week','PETweek','petweek','pet_week', &
+ 'GPP_week','GPPweek','gppweek','gpp_week','NEP_week','NEPweek','nepweek','nep_week','NPP_week','NPPweek','nppweek','npp_week', &
+ 'perc_week','percweek','temp_week','tempweek','prec_week','precweek', 'resps_week','respsweek', 'TER_week','TERweek','ter_week','terweek')
+ flag_cum = 1
+ helpw = helpw + 1
+ output_var(i,1,0) = 1.*helpw ! field numbre of weekly values
+
+ end select ! outvar
+
+ enddo
+ if (helpy .gt. 0) then
+ allocate(climszenyear(helpy,site_nr,nrclim,nrreal,year))
+ endif
+ if (helpi .gt. 0) then
+ allocate(climszenmon(helpi,site_nr,nrclim,nrreal,12))
+ allocate(output_varm(helpi,1,year,12))
+ endif
+ if (helpw .gt. 0) then
+ allocate(climszenweek(helpw,site_nr,nrclim,nrreal,52))
+ allocate(output_varw(helpw,1,year,52))
+ endif
+ endif ! nvar
+
+ call errorfile(simfile, ios, nowunit)
+
+! reading file with description of climate stations used
+ allocate(climnum(3000))
+ allocate(clim_long(3000))
+ allocate(clim_lat(3000))
+ allocate(clim_height(3000))
+ allocate(clim_nam(3000))
+
+ call testfile(climall,ex)
+ if (ex .eqv. .false.) return
+ nowunit1 = getunit()
+ ios1 = 0
+ open(nowunit1,file=climall,iostat=ios,status='old',action='read')
+ k=1
+ do
+ READ(nowunit1,'(A)',iostat=ios1) a
+ IF (a .ne. '!') exit
+
+ end do
+ backspace nowunit1
+
+ do
+ read(nowunit1,*,iostat=ios1) climnum(k), clim_long(k),clim_lat(k), clim_height(k)
+ if(ios1 .lt. 0) exit
+ k = k+1
+ end do
+ anzclim = k-1
+ ios1 = 0
+
+ call errorfile(climall, ios1, nowunit1)
+
+! reading control file with site-id, climate-id, soil-id, gwtabe-id
+
+ call testfile(siteall,ex)
+ if (ex .eqv. .false.) return
+ nowunit1 = getunit()
+ open(nowunit1,file=siteall,iostat=ios1,status='old',action='read')
+ do
+ READ(nowunit1,'(A)',iostat=ios1) a
+ IF (a .ne. '!') exit
+ end do
+ backspace nowunit1
+
+ do i=1,site_nr
+ call readcon(i, nowunit1)
+
+ sitefile(i) = trim(pathdir2)
+ if(i.gt.1) treefile(i)= treefile(1)
+ if(i.gt.1) manfile(i) = manfile(1)
+ k = 1
+ do while (clim_id(i).ne.climnum(k))
+ k = k + 1
+ if (k .gt. anzclim) then
+ write (unit_err,*)
+ write (unit_err,*) ' >>>foresee message: Climate ID ', trim(clim_id(i)), ' not in file ',trim(climall)
+ write (unit_err,*) ' Site number ',sitenum(i)
+ write (*,*)
+ write (*,*) ' >>>foresee message: Climate ID ', trim(clim_id(i)), ' not in file ',trim(climall)
+ write (*,*) ' Site number ',sitenum(i)
+ print *,' Program will stop!'
+ flag_end = 4
+ return
+ endif
+ enddo
+ latitude(i) = clim_lat(k)
+ do l = 1, nrclim
+ do j = 1, nrreal
+ write (helpsim,'(I5)') j
+ read (helpsim,*) text4
+ select case (flag_multi)
+ case (9)
+ climszenfile(i,l,j) = trim(pathdir1)//trim(typeclim(l))//'/real_'//trim(text4)//'/'//trim(clim_id(i))//trim(climszen)//'.dat'
+ case (10)
+ if (j .lt. 10) then
+ text4 = '00'//text4
+ else if (j .lt. 100) then
+ text4 = '0'//text4
+ endif
+ climszenfile(i,l,j) = trim(pathdir1)//'/q'//trim(text4)//'/'//trim(clim_id(i))//trim(climszen)//'.dat'
+ end select
+ enddo !j
+ end do !l
+ enddo
+
+ if ((.not.flag_mult8910) .and. (ios1 .lt. 0)) print *, 'no information for site number ', i
+ call errorfile(siteall, ios1, nowunit1)
+
+ deallocate(climnum)
+ deallocate(clim_long)
+ deallocate(clim_lat)
+ deallocate(clim_height)
+ deallocate(clim_nam)
+
+ close(nowunit1)
+
+ END SELECT
+
+ jpar = 0 ! reset jpar for restore
+
+ if(flag_multi .eq. 2)then
+ read (nowunit,*) step_sum_T,n_T_downsteps,n_T_upsteps
+ read (nowunit,*) step_fac_P,n_P_downsteps,n_P_upsteps
+
+ site_nr = (1+n_T_downsteps+n_T_upsteps) * (1+n_P_downsteps+n_P_upsteps)
+ repeat_number = site_nr
+
+ tspec = specfile(1)
+ tname = site_name(1)
+ tclim = climfile(1)
+ tsite = sitefile(1)
+ tval = valfile(1)
+ ttree = treefile(1)
+ tman = manfile(1)
+ tdepo = depofile(1)
+ tred = redfile(1)
+ tlit = litfile(1)
+ istand = standid(1)
+ tsoilid = soilid(1)
+
+ deallocate (specfile)
+ deallocate (site_name)
+ deallocate (climfile)
+ deallocate (clim_id)
+ deallocate (sitefile)
+ deallocate (valfile)
+ deallocate (treefile)
+ deallocate (manfile)
+ deallocate (depofile)
+ deallocate (redfile)
+ deallocate (litfile)
+ deallocate (wpmfile)
+ deallocate (standid)
+ deallocate (soilid)
+ allocate (specfile(site_nr))
+ allocate (site_name(site_nr))
+ allocate (climfile(site_nr))
+ allocate (clim_id(site_nr))
+ allocate (sitefile(site_nr))
+ allocate (valfile(site_nr))
+ allocate (treefile(site_nr))
+ allocate (manfile(site_nr))
+ allocate (depofile(site_nr))
+ allocate (standid(site_nr))
+ allocate (soilid(site_nr))
+ allocate (redfile(site_nr))
+ allocate (litfile(site_nr))
+ allocate (wpmfile(site_nr))
+
+ specfile = tspec
+ site_name = tname
+ climfile = tclim
+ sitefile = tsite
+ valfile = tval
+ treefile = ttree
+ manfile = tman
+ depofile = tdepo
+ redfile = tred
+ litfile = tlit
+ standid = istand
+ soilid = tsoilid
+
+ call errorfile(simfile, ios, nowunit)
+
+ endif ! flag_multi = 2
+close(nowunit)
+
+END subroutine readsim
+
+!**************************************************************
+
+SUBROUTINE allofile
+
+use data_simul
+
+implicit none
+
+ allocate(site_name(site_nr))
+ allocate(climfile(repeat_number))
+ allocate(sitefile(site_nr))
+ allocate(valfile(site_nr))
+ allocate(treefile(repeat_number))
+ allocate(standid(repeat_number))
+ allocate(manfile(repeat_number))
+ allocate(depofile(repeat_number))
+ allocate(redfile(repeat_number))
+ allocate(litfile(repeat_number))
+ allocate(wpmfile(repeat_number))
+ allocate(specfile(repeat_number))
+
+end subroutine allofile
+
+!**************************************************************
+
+SUBROUTINE readcon (ii, unitnum)
+
+use data_depo
+use data_out
+use data_par
+use data_simul
+use data_site
+
+implicit none
+
+integer ii, ihelp, unitnum, ios1, ilen, helpi
+character(150):: text
+character(10):: helpsim, text4
+
+ read(unitnum,'(A)',iostat=ios1) text
+ ! text disassemble
+ ! sitenum
+ ilen = len(trim(text))
+ text = adjustl(text)
+ ihelp = verify(text, charset)
+ text4 = adjustl(text(1:ihelp-1))
+ sitenum(ii) = text4
+ text = adjustl(text(ihelp+1:))
+ ilen = len(trim(text))
+ ihelp = scan(text, charset)
+ text = text(ihelp:)
+ ihelp = verify(text, charset)
+ clim_id(ii) = adjustl(text(1:ihelp-1))
+ text = adjustl(text(ihelp+1:))
+ ilen = len(trim(text))
+ ihelp = scan(text, charset)
+ text = text(ihelp:)
+ ihelp = verify(text, charset)
+ soilid(ii) = adjustl(text(1:ihelp-1))
+ ! gwtable
+ text = adjustl(text(ihelp+1:))
+ ilen = len(trim(text))
+ ihelp = scan(text, charset)
+ text = text(ihelp:)
+ ihelp = verify(text, charset)
+ text4 = adjustl(text(1:ihelp-1))
+ write (helpsim,'(A)') text4
+ read (helpsim,*) gwtable(ii)
+ ! standid
+ text = adjustl(text(ihelp+1:))
+ ilen = len(trim(text))
+ ihelp = scan(text, charset)
+ text = text(ihelp:)
+ ihelp = verify(text, charset)
+ text4 = adjustl(text(1:ihelp-1))
+ standid(ii) = text4
+ ! deposition
+ text = adjustl(text(ihelp+1:))
+ ilen = len(trim(text))
+ if (ilen .gt. 0) then
+ text = adjustl(text)
+ ihelp = verify(text, charset)
+ text4 = adjustl(text(1:ihelp-1))
+ write (helpsim,'(A)') text4
+ read (helpsim,*) NOdep(ii) ! hand over in readdepo as concentration
+ text = adjustl(text(ihelp+1:))
+ ilen = len(trim(text))
+ ihelp = scan(text, charset)
+ text = text(ihelp:)
+ ihelp = verify(text, charset)
+ text4 = adjustl(text(1:ihelp-1))
+ write (helpsim,'(A)') text4
+ read (helpsim,*) NHdep(ii) ! hand over in readdepo as concentration
+ ! RedN
+ text = adjustl(text(ihelp+1:))
+ ilen = len(trim(text))
+ do while (ilen .gt. 0)
+ ihelp = verify(text, charset)
+ text4 = adjustl(text(1:ihelp-1))
+ write (helpsim,'(A)') text4
+ read (helpsim,*) helpi
+ text = adjustl(text(ihelp+1:))
+ ihelp = verify(text, charset)
+ text4 = adjustl(text(1:ihelp-1))
+ write (helpsim,'(A)') text4
+ read (helpsim,*) RedN_list(helpi, ii)
+ text = adjustl(text(ihelp+1:))
+ ilen = len(trim(text))
+ enddo
+ else
+ NOdep(ii) = 0.
+ NHdep(ii) = 0.
+ endif
+
+End SUBROUTINE readcon
diff --git a/source_code/version2.2_windows/root.f b/source_code/version2.2_windows/root.f
new file mode 100755
index 0000000000000000000000000000000000000000..d56998bbdf97be2023c6b1c3c5c70e0765e7190c
--- /dev/null
+++ b/source_code/version2.2_windows/root.f
@@ -0,0 +1,886 @@
+!*****************************************************************!
+!* *!
+!* 4C (FORESEE) Simulation Model *!
+!* *!
+!* *!
+!* Subroutines for: *!
+!* Root distribution *!
+!* *!
+!* - ROOT_DISTR *!
+!* - ROOT_EFF *!
+!* - ROOT_DEPTH *!
+!* - ROOT_INI *!
+!* - DEALLOC_ROOT *!
+!* - ROOTC_NEW (nicht benutzt wegen Problemen bei Verkettung) *!
+!* - CR_DEPTH *!
+!* *!
+!* 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 root_distr
+
+! Calculation of root distribution for each cohorte
+
+use data_simul
+use data_soil
+use data_stand
+use data_par
+use data_species
+
+implicit none
+
+integer specn ! species type (number)
+integer i, j, nj, k, jlay
+integer nr ! aux. var. for nroot (rooting depth)
+integer rkind ! kind of calculation of root depth
+real frtrel_1, frtrel_j ! rel fine root fraction of previous layer
+real frtrel_s ! Sum of fine root fractions
+real radius ! radius of cylyndric space created by roots of the root length density
+
+real beta ! base of power
+real help
+real alpha, b ! Parameters for Arora function
+real troot2 ! theoretical root biomass of population (coarse and fine roots) only for Arora funktion spereated according to cohorts [kg/m²]
+real :: part_coef=0.0 ! Verteilungskoeffizient um Verhältnis zwischen fr_loss und redis zu bestimmen
+real, dimension (1:nlay) :: fr_loss1, valspace, frtrelcoh !auxiliary vectors
+
+rkind = rdepth_kind
+
+if ((anz_tree + anz_sveg) .eq. 0) return
+select case (flag_wurz)
+
+case (0)
+ root_fr = 0.
+ zeig => pt%first
+ do while (associated(zeig))
+
+ call root_depth (rkind, zeig%coh%species, zeig%coh%x_age, zeig%coh%height, zeig%coh%x_frt, zeig%coh%x_crt, nr, troot2, zeig%coh%x_rdpt, zeig%coh%nroot)
+ zeig%coh%nroot = nr
+ zeig%coh%frtrel = thick/depth(nr)
+ specn = zeig%coh%species
+
+ do j = 1, nr
+ root_fr(j) = root_fr(j) + zeig%coh%frtrel(j) * zeig%coh%ntreeA
+ enddo
+ do j = nr+1, nlay
+ zeig%coh%frtrel(j) = 0.
+ enddo
+ zeig%coh%rooteff = 0. ! zero after use
+ zeig => zeig%next
+ enddo
+
+case (1) ! Funktion
+ root_fr = 0.
+ zeig => pt%first
+ do while (associated(zeig))
+ call root_depth (rkind, zeig%coh%species, zeig%coh%x_age, zeig%coh%height, zeig%coh%x_frt, zeig%coh%x_crt, nr, troot2, zeig%coh%x_rdpt, zeig%coh%nroot) !Änderung MG: Übergabe von Grob und Feinwurzelmasse an root_depth
+ zeig%coh%nroot = nr
+ specn = zeig%coh%species
+ if (specn .eq. 2 .or. specn .eq. 3) then
+ beta = 0.976
+ else
+ beta = 0.966
+ endif
+ frtrel_1 = 1.
+ zeig%coh%frtrel = 0.
+ do j=1,nr
+ frtrel_j = beta ** depth(j)
+ zeig%coh%frtrel(j) = frtrel_1 - frtrel_j
+ frtrel_1 = frtrel_j
+ enddo
+ frtrel_s = SUM(zeig%coh%frtrel)
+ frtrel_s = 1./frtrel_s
+ do j=1,nr
+ ! scaling of root distribution
+ zeig%coh%frtrel(j) = zeig%coh%frtrel(j) * frtrel_s
+ root_fr(j) = root_fr(j) + zeig%coh%frtrel(j) * zeig%coh%ntreeA
+ enddo
+
+ zeig%coh%rooteff = 0. ! zero after use
+ zeig => zeig%next
+ enddo
+
+case (2) ! read/use default distribution; not changed
+
+ root_fr = 0.
+ zeig => pt%first
+ do while (associated(zeig))
+ if (zeig%coh%frtrel(1) .gt. 0.) then
+ do j = 1,nroot_max
+ root_fr(j) = root_fr(j) + zeig%coh%frtrel(j) * zeig%coh%ntreeA
+ enddo
+ else
+ root_fr = 0.
+ call root_depth (1, zeig%coh%species, zeig%coh%x_age, zeig%coh%height, zeig%coh%x_frt, zeig%coh%x_crt, nr, troot2, zeig%coh%x_rdpt, zeig%coh%nroot)
+ zeig%coh%nroot = nr
+ specn = zeig%coh%species
+ if (specn .eq. 2 .or. specn .eq. 3) then
+ beta = 0.98
+ else
+ beta = 0.967
+ endif
+
+ frtrel_1 = 1.
+ zeig%coh%frtrel = 0.
+ do j=1,nr
+ frtrel_j = beta ** depth(j)
+ zeig%coh%frtrel(j) = frtrel_1 - frtrel_j
+ frtrel_1 = frtrel_j
+ enddo
+ frtrel_s = SUM(zeig%coh%frtrel)
+ frtrel_s = 1./frtrel_s
+ do j=1,nr
+ zeig%coh%frtrel(j) = zeig%coh%frtrel(j) * frtrel_s
+ root_fr(j) = root_fr(j) + zeig%coh%frtrel(j) * zeig%coh%ntreeA
+ enddo
+
+ endif
+
+ zeig%coh%rooteff = 0. ! zero after use
+ zeig => zeig%next
+ enddo
+
+case (3)
+root_fr = 0.
+rkind=5
+
+zeig => pt%first
+ do while (associated(zeig))
+ call root_depth (rkind, zeig%coh%species, zeig%coh%x_age, zeig%coh%height, zeig%coh%x_frt, zeig%coh%x_crt, nr, troot2, zeig%coh%x_rdpt, zeig%coh%nroot) !Änderung MG: Übergabe von Grob und Feinwurzelmasse an root_depth
+ zeig%coh%nroot = nr
+ specn = zeig%coh%species
+ alpha=0.7
+ if (specn .eq. 2 .or. specn .eq. 3 .or. specn .eq. 6 .or. specn .eq. 7) then
+ b = 7.95
+ else
+ b = 10.91
+ endif
+
+ frtrel_1 = 1.
+ zeig%coh%frtrel = 0.
+ do j=1,nr
+! root distribution (Arora et al., 2003)
+ frtrel_j = exp((-b/troot2**alpha)*(depth(j)/100))
+ zeig%coh%frtrel(j) = frtrel_1 - frtrel_j
+ frtrel_1 = frtrel_j
+ enddo
+ frtrel_s = SUM(zeig%coh%frtrel)
+ frtrel_s = 1./frtrel_s
+ do j=1,nr
+ ! scaling of root distribution
+ zeig%coh%frtrel(j) = zeig%coh%frtrel(j) * frtrel_s
+ root_fr(j) = root_fr(j) + zeig%coh%frtrel(j) * zeig%coh%ntreeA
+ enddo
+
+ zeig%coh%rooteff = 0. ! zero after use
+ zeig => zeig%next
+ enddo
+
+case(4) ! TRAP-model Rasse et al. (2001)
+root_fr = 0.
+rkind = 6
+fr_loss1= 0
+k = 0
+
+zeig => pt%first
+ do while (associated(zeig))
+ k=k+1
+ zeig%coh%x_rdpt=gr_depth(k)
+ specn = zeig%coh%species
+ if (specn .eq. 12) then
+ continue
+ endif
+ call root_depth (rkind, specn, zeig%coh%x_age, zeig%coh%height, zeig%coh%x_frt, zeig%coh%x_crt, nr, troot2, zeig%coh%x_rdpt, zeig%coh%nroot)
+ zeig%coh%nroot = nr
+
+ frtrel_1 = 1.
+ zeig%coh%frtrel = 0.
+ do j=1,nr
+ if (j .eq. 1) then
+ zeig%coh%frtrel(j) = (zeig%coh%x_rdpt**3-(zeig%coh%x_rdpt-depth(j))**3)/zeig%coh%x_rdpt**3
+ elseif (j .eq. nr) then
+ zeig%coh%frtrel(j)= frtrel_1
+ else
+ zeig%coh%frtrel(j) = ((zeig%coh%x_rdpt-depth(j-1))**3-((zeig%coh%x_rdpt-depth(j))**3))/zeig%coh%x_rdpt**3
+ endif
+ frtrel_1 = frtrel_1-zeig%coh%frtrel(j)
+ enddo
+ frtrel_s = SUM(zeig%coh%frtrel)
+ frtrel_s = 1./frtrel_s
+ zeig%coh%frtrel = zeig%coh%frtrel * frtrel_s
+
+ fr_loss1 = zeig%coh%frtrel
+ fr_loss = zeig%coh%frtrel*svar(specn)%Smean(1:nlay)
+ fr_loss = part_coef*(fr_loss1-fr_loss)
+ redis = zeig%coh%frtrel*svar(specn)%Smean(1:nlay)
+ redis = part_coef*(fr_loss1-redis)
+
+ do j=1,nr
+ ! scaling of root distribution
+ if (sum(svar(specn)%Smean(1:nr)) .lt. 0.0001) then
+ zeig%coh%frtrel(j) = 0.
+ else
+ zeig%coh%frtrel(j) = zeig%coh%frtrel(j)*svar(specn)%Smean(j)+(sum(redis)*svar(specn)%Smean(j)/sum(svar(specn)%Smean(1:nr)))
+ endif
+ enddo
+
+ frtrel_s = SUM(zeig%coh%frtrel)
+ if (frtrel_s .lt. 1.E-6) then
+ do j=1,nr
+ zeig%coh%frtrel(j) = 0
+ enddo
+ else
+ frtrel_s = 1./frtrel_s
+ do j=1,nr
+ ! scaling of root distribution
+ zeig%coh%frtrel(j) = zeig%coh%frtrel(j) * frtrel_s
+ root_fr(j) = root_fr(j) + zeig%coh%frtrel(j) * zeig%coh%ntreeA
+ enddo
+ endif
+
+ zeig%coh%rooteff = 0.
+ zeig => zeig%next
+ enddo
+
+case(5)
+root_fr = 0.
+rkind=5
+ zeig => pt%first
+ do while (associated(zeig))
+
+
+ call root_depth (rkind, zeig%coh%species, zeig%coh%x_age, zeig%coh%height, zeig%coh%x_frt, zeig%coh%x_crt, nr, troot2, zeig%coh%x_rdpt, zeig%coh%nroot) !Änderung MG: Übergabe von Grob und Feinwurzelmasse an root_depth
+ zeig%coh%nroot = nr
+ specn = zeig%coh%species
+ if (specn .eq. 2 .or. specn .eq. 3) then
+ beta = 0.98
+ else
+ beta = 0.967
+ endif
+
+
+ frtrel_1 = 1.
+ zeig%coh%frtrel = 0.
+ do j=1,nr
+! root distribution (Jackson et al., 1996): beta ** depth
+ frtrel_j = beta ** depth(j)
+ zeig%coh%frtrel(j) = frtrel_1 - frtrel_j
+ frtrel_1 = frtrel_j
+ enddo
+ frtrel_s = SUM(zeig%coh%frtrel)
+ frtrel_s = 1./frtrel_s
+ do j=1,nr
+ ! scaling of root distribution
+ zeig%coh%frtrel(j) = zeig%coh%frtrel(j) * frtrel_s
+ root_fr(j) = root_fr(j) + zeig%coh%frtrel(j) * zeig%coh%ntreeA
+ enddo
+
+ zeig%coh%rooteff = 0. ! zero after use
+ zeig => zeig%next
+ enddo
+
+case(6)
+
+root_fr = 0.
+rkind=7
+ zeig => pt%first
+ k=1
+ do while (associated(zeig))
+
+ zeig%coh%x_rdpt=gr_depth(k)
+ call root_depth (rkind, zeig%coh%species, zeig%coh%x_age, zeig%coh%height, zeig%coh%x_frt, zeig%coh%x_crt, nr, troot2, zeig%coh%x_rdpt,zeig%coh%nroot) !Änderung MG: Übergabe von Grob und Feinwurzelmasse an root_depth
+
+ if (time .le. 1) then
+ root_lay(k)=nr
+ else
+ root_lay(k)=root_lay(k)+nr
+ endif
+
+ if (root_lay(k) .gt. nroot_max) root_lay(k) = nroot_max
+
+ zeig%coh%nroot=root_lay(k)
+ nr=root_lay(k)
+
+ specn = zeig%coh%species
+ if (specn .eq. 2 .or. specn .eq. 3) then
+ beta = 0.98
+ else
+ beta = 0.967
+ endif
+
+
+ frtrel_1 = 1.
+ zeig%coh%frtrel = 0.
+ do j=1,nr
+! root distribution (Jackson et al., 1996): beta ** depth
+ frtrel_j = beta ** depth(j)
+ zeig%coh%frtrel(j) = frtrel_1 - frtrel_j
+ frtrel_1 = frtrel_j
+ enddo
+ frtrel_s = SUM(zeig%coh%frtrel)
+ frtrel_s = 1./frtrel_s
+ do j=1,nr
+ ! scaling of root distribution
+ zeig%coh%frtrel(j) = zeig%coh%frtrel(j) * frtrel_s
+ root_fr(j) = root_fr(j) + zeig%coh%frtrel(j) * zeig%coh%ntreeA
+ enddo
+
+ zeig%coh%rooteff = 0. ! zero after use
+ k=k+1
+ zeig => zeig%next
+ enddo
+
+case (7) ! Funktion nach Jackson (1996) mit fester Tiefe
+ root_fr = 0.
+ nr = nroot_max
+ zeig => pt%first
+ do while (associated(zeig))
+
+ zeig%coh%nroot = nroot_max
+ specn = zeig%coh%species
+ if (specn .eq. 2 .or. specn .eq. 3) then
+ beta = 0.98
+ else
+ beta = 0.967
+ endif
+
+ frtrel_1 = 1.
+ zeig%coh%frtrel = 0.
+ do j=1,nr
+! root distribution (Jackson et al., 1996): beta ** depth
+ frtrel_j = beta ** depth(j)
+ zeig%coh%frtrel(j) = frtrel_1 - frtrel_j
+ frtrel_1 = frtrel_j
+ enddo
+ frtrel_s = SUM(zeig%coh%frtrel)
+ frtrel_s = 1./frtrel_s
+ do j=1,nr
+ ! scaling of root distribution
+ zeig%coh%frtrel(j) = zeig%coh%frtrel(j) * frtrel_s
+ root_fr(j) = root_fr(j) + zeig%coh%frtrel(j) * zeig%coh%ntreeA
+ enddo
+
+ zeig%coh%rooteff = 0. ! zero after use
+
+ zeig => zeig%next
+ enddo
+
+end select
+
+root_fr = root_fr / (anz_tree + anz_sveg) ! normieren
+zeig => pt%first
+do while (associated(zeig))
+ help = zeig%coh%x_frt * zeig%coh%ntreea
+ do jlay = 1, nroot_max
+ if (root_fr(jlay) .gt. zero) then
+ zeig%coh%frtrelc(jlay) = zeig%coh%frtrel(jlay) * help / (root_fr(jlay) * totfrt_p) ! mass of root part of total cohort in a layer
+ else
+ zeig%coh%frtrelc(jlay) = 0.
+ endif
+ enddo
+ zeig => zeig%next
+enddo
+
+if (flag_wred .eq. 9) then
+
+ !Calculation of root length density
+ zeig => pt%first
+ do while (associated(zeig))
+ if (specn .le. nspec_tree) then
+ radius = (zeig%coh%diam/6.)*100. ! formula bhd [cm]/6 yield radius in [m] so *100 (aus Wagner 2005)
+ valspace = pi * radius**2 * thick
+ else
+ valspace = kpatchsize * 100*100 * thick
+ endif !circular cylinder
+
+ frtrelcoh = zeig%coh%frtrel * zeig%coh%x_frt * zeig%coh%ntreea
+
+ if (zeig%coh%ntreea .gt. 0 .AND. minval(valspace(1:nr)) .gt. 0.) then
+ zeig%coh%rld = (frtrelcoh*1000*spar(specn)%spec_rl*100)/(valspace* zeig%coh%ntreea) !in cm root length /cm3 volume
+ else
+ zeig%coh%rld = -99
+ endif
+
+ zeig => zeig%next
+ enddo
+endif
+
+if (allocated(wat_root)) wat_root=0.
+
+END subroutine root_distr
+
+!**************************************************************
+
+SUBROUTINE root_eff
+
+! Calculation of root efficiency in dependence of water and N uptake
+use data_soil
+use data_soil_cn
+use data_stand
+
+implicit none
+
+integer i,j
+integer nr ! layer number of root depth
+real hroot ! root depth
+real fdc ! discounting function describing transport resistance
+real gw, gN ! accounting functions of water resp. N uptake
+real glimit ! limitation constant for use of rooting layer
+
+glimit = 0. ! min. assumption
+
+ i = 1
+ zeig => pt%first
+ do while (associated(zeig))
+ nr = zeig%coh%nroot
+ do j = 1,nr
+ fdc = 50./depth(j)
+ if (zeig%coh%supply .gt. 1e-06) then
+ gw = xwatupt(i,j)/zeig%coh%supply
+ gw = gw / thick(j)
+ else
+ gw = 0.
+ endif
+
+ gw = xwatupt(i,j)
+ zeig%coh%rooteff(j) = zeig%coh%rooteff(j) + gw
+ enddo
+ zeig%coh%watuptc = zeig%coh%watuptc + zeig%coh%supply
+ i = i + 1
+ zeig => zeig%next
+ enddo
+
+END subroutine root_eff
+
+!**************************************************************
+
+SUBROUTINE root_depth(rkind, specn, agec, heightc, froot, croot, nr, troot2, crdepth, nrooth)
+
+use data_simul
+use data_soil
+use data_soil_cn
+use data_stand
+
+implicit none
+
+! input:
+integer rkind ! kind of calculation of root depth
+integer specn ! species number
+integer agec ! tree age
+integer nrooth ! for case(7)
+
+real heightc, froot, croot ! tree height of cohort, fine and coarse root mass[kg]/ tree
+real troot, troot1,troot2, troot_stand ! total root mass 1./tree 2./ha according to cohorts 3. /m² according to cohorts Kohorten 4./ha of 4C
+real :: wat_demand ! query whether one cohort was unable to cover water demand with the from root penetrated soil layer
+real rootingdepth, crdepth ! rooting depth nach Arora function in [m]
+real alpha, b ! parameter for Arorafunction
+! output:
+integer nr ! last root layer
+
+integer i,j
+real hc, wtiefe
+real, dimension(4,3):: rdepth ! effective rooting depth depending on tree age and soil texture
+! data from Raissi et al. (2001)
+data rdepth /85, 130, 175, 95, 140, 185, 135, 180, 225, 90, 110, 135/
+
+select case (rkind)
+
+case (1)
+ ! nroot depending on tree height and soil profile depth
+ nr = 1
+ do j=1,nlay
+ if (heightc .ge. depth(j)) nr = j
+ enddo
+ if (nr .gt. nroot_max) nr = nroot_max
+ crdepth = depth(nr)
+
+case (2)
+ ! fixed nroot for all adult cohorts
+ if (agec .lt. 10) then
+ nr = 1
+ wtiefe=depth(nroot_max)/(1+exp(1.5-0.55*real(agec))) ! logicla function to determin root depth [cm] until age 10
+ do j=1,nlay
+ if (wtiefe .ge. depth(j)) nr = j
+ enddo
+ if (nr .gt. nroot_max) nr = nroot_max
+ else
+ nr = nroot_max
+ endif
+ crdepth = depth(nr)
+
+case (3)
+ ! nroot depending on root efficiency
+ nr = nlay
+ crdepth = depth(nr)
+
+case (4)
+ ! nroot depending on soil texture and age
+ if (agec .lt. 15) then
+ i = 1
+ else if (agec .gt. 45) then
+ i = 3
+ else
+ i = 2
+ endif
+
+ nr = 1
+ if (heightc .gt. rdepth(s_typen,i)) then
+ hc = rdepth(s_typen,i)
+ else
+ hc = heightc
+ endif
+ do j=1,nlay
+ if (hc .ge. depth(j)) nr = j
+ enddo
+ if (nr .gt. nroot_max) nr = nroot_max
+
+case (5)
+ alpha=0.7
+ if (specn .eq. 2 .or. specn .eq. 3 .or. specn .eq. 6 .or. specn .eq. 7) then
+ b = 7.95
+ else
+ b = 10.91
+ endif
+
+ troot=froot+croot
+ troot1=troot*anz_tree_ha ! total root biomass per ha if population of a cohort is soley comprised of trees
+ troot_stand=totfrt+totcrt ! total root biomass per ha calculated by 4C
+ troot2=troot1/10000 ! conversion to m²
+ rootingdepth=(3*troot2**alpha)/b !Arora function
+ nr = 1
+ do j=1,nlay
+ if (rootingdepth*100 .ge. depth(j)) nr = j
+ enddo
+ if (nr .gt. nroot_max) nr = nroot_max
+ crdepth = depth(nr)
+
+case (6) !Calculation in soil.f in cr_depth
+
+ if (crdepth .eq.0) then
+ ! nroot depending on soil texture and age
+ if (agec .lt. 15) then
+ i = 1
+ else if (agec .gt. 45) then
+ i = 3
+ else
+ i = 2
+ endif
+
+ nr = 1
+ if (heightc .gt. rdepth(s_typen,i)) then
+ crdepth = rdepth(s_typen,i)
+ else
+ crdepth = heightc
+ endif
+
+ endif
+
+ do j=1,nlay
+ if (depth(j) .le. crdepth) nr=j
+ enddo
+ if (nr .gt. nroot_max) nr = nroot_max
+
+case (7) !further growth only if next layer bears water
+ wat_demand=maxval(wat_root)
+ if (time .le. 1) then
+ crdepth=30.0
+ do j=1,nlay
+ if (depth(j) .le. 30.) nr=j
+ enddo
+ else
+ if (wat_demand .gt. 0) then
+ nr=1
+ else
+ nr=0
+ endif
+ endif
+
+ if (nr .gt. nroot_max) nr = nroot_max
+ crdepth = depth(nr)
+end select
+
+if (crdepth < 0.) then
+continue
+endif
+
+END subroutine root_depth
+
+!**************************************************************
+
+SUBROUTINE root_ini
+
+! Allocation and initialisation of root distribution
+
+use data_simul
+use data_soil
+use data_species
+use data_stand
+
+implicit none
+
+integer i, j, nj, rkind, hspec, ios
+integer unit_root
+integer nr ! aux. var. for nroot (rooting depth)
+real frtrel_j, frtrel_1 ! rel fine root fraction of previous layer
+real frtrel_s ! Sum of fine root fractions
+real hfrt, help, troot2
+real, allocatable, dimension(:,:):: hd,hr
+integer, allocatable, dimension(:):: nlspec
+character text
+character (150) file_root
+
+logical :: pruefer=.false.
+
+root_fr = 0.
+ if (wlam(3) .gt. 0.4) then
+ s_typen = 1 ! sand
+ else if (wlam(3) .le. 0.15) then
+ s_typen = 4 ! clay
+ else if (wlam(3) .gt. 0.25) then
+ s_typen = 3 ! silt
+ else
+ s_typen = 2 ! loam
+ endif
+
+ if (nroot_max .lt. 0) then
+ nroot_max = 1
+ rkind = 4
+ else
+ rkind = 2
+ endif
+ rdepth_kind = rkind
+
+select case (flag_wurz)
+
+case (0,1,5)
+ if (anz_tree .gt. 0 .or. (anz_tree.eq.0 .and. flag_sveg .eq.1)) call root_distr
+
+case (3,4,6)
+ !intercept the case that the ground vegetatuin is already initialised but no trees have been initialised so cohorts are not finalised
+ if (anz_tree.eq.0 .and. flag_sveg .eq.1) then
+ if (.not. allocated(wat_root)) then
+ allocate(wat_root(anz_coh))
+ wat_root=0.
+ allocate(root_lay(anz_coh))
+ root_lay=0
+ allocate(gr_depth(anz_coh))
+ gr_depth=0.
+ Pruefer=.true.
+ endif
+ else
+ if (Pruefer .OR. (.not. allocated(wat_root))) then
+ if (Pruefer) deallocate(wat_root)
+ allocate(wat_root(anz_coh))
+ wat_root=0.
+ if (Pruefer) deallocate(root_lay)
+ allocate(root_lay(anz_coh))
+ root_lay=0
+ if (Pruefer) deallocate(gr_depth)
+ allocate(gr_depth(anz_coh))
+ gr_depth=0.
+ Pruefer=.false.
+ endif
+ endif
+ if (anz_tree .gt. 0 .or. (anz_tree.eq.0 .and. flag_sveg .eq.1)) call root_distr
+
+case (2)
+! read root distribution once in the beginning alone
+ write (*,*)
+ write (*,'(A)', advance='no') 'Define root distribution, name of input file: '
+ read (*,'(A)') file_root
+ unit_root = getunit()
+ open (unit_root, file=trim(file_root), status='unknown')
+ allocate (hd(0:40, 1:nspecies))
+ allocate (hr(0:40, 1:nspecies))
+ allocate (nlspec(nspecies))
+
+ do
+ read (unit_root,'(A)') text
+ if (text .ne. '!') then
+ backspace(unit_root);exit
+ endif
+ enddo
+
+ ios = 0
+ hd = 0.
+ hr = 0.
+ nlspec = 0
+ do while (ios .ge. 0)
+ j = 1
+ read (unit_root, *, iostat=ios) hspec
+ if (ios .lt. 0) exit
+ read (unit_root, *, iostat=ios) hd(1,hspec), hr(1,hspec)
+ do while (hd(j,hspec) .ge. 0.)
+ nlspec(hspec) = j
+ j = j+1
+ read (unit_root, *, iostat=ios) hd(j,hspec), hr(j,hspec)
+ enddo
+ if (hd(j,hspec) .lt. depth(nlay)) hd(j,hspec) = depth(nlay)
+ enddo
+ close (unit_root)
+
+ zeig => pt%first
+ do while (associated(zeig))
+
+ ns = zeig%coh%species
+ zeig%coh%frtrel = 0.
+
+ ! rel. root distribution of cohorts to species allocated
+ if (nlspec(ns) .gt. 0) then
+
+ frtrel_j = 0.
+ hfrt = 0.
+ j= 1
+ do while (hd(j,ns) .lt. depth(1))
+ hfrt = hfrt + hr(j,ns)
+ j = j+1
+ enddo
+ frtrel_j = hr(j,ns) / (hd(j,ns)-hd(j-1,ns))
+ hfrt = hfrt + frtrel_j * (depth(1)-hd(j-1,ns))
+ zeig%coh%frtrel(1) = hfrt
+ nj = j
+
+ do i=2,nlay
+ hfrt = 0.
+ do j = nj,nlspec(ns)+1
+ if (hd(j,ns) .lt. depth(i)) then
+ frtrel_j = hr(j,ns) / (hd(j,ns)-hd(j-1,ns))
+ hfrt = hfrt + frtrel_j * (hd(j,ns)-depth(i-1))
+ else
+ if (depth(i-1) .gt. hd(j-1,ns)) then
+ help = depth(i)-depth(i-1)
+ else
+ help = depth(i)-hd(j-1,ns)
+ endif
+ frtrel_j = hr(j,ns) / (hd(j,ns)-hd(j-1,ns))
+ hfrt = hfrt + frtrel_j * help
+ nj = j
+ exit
+ endif
+ enddo
+
+ zeig%coh%frtrel(i) = hfrt
+ enddo
+ else
+
+ continue
+ endif
+
+ frtrel_s = SUM(zeig%coh%frtrel)
+ zeig%coh%rooteff = 0.
+ zeig => zeig%next
+ enddo
+ rdepth_kind = 2
+end select
+
+END subroutine root_ini
+
+!**************************************************************
+
+SUBROUTINE dealloc_root
+
+use data_simul
+use data_stand
+
+if (flag_wurz .eq. 1) then
+ zeig => pt%first
+ do while (associated(zeig))
+
+ deallocate (zeig%coh%frtrel)
+ deallocate (zeig%coh%rooteff)
+
+ zeig => zeig%next
+ enddo
+endif
+
+END subroutine dealloc_root
+
+!**************************************************************
+
+SUBROUTINE rootc_new (zeig1)
+
+! root initialisation of a new cohort
+
+use data_stand
+use data_soil
+
+implicit none
+
+type(coh_obj), pointer :: zeig1 ! pointer variable for cohorts
+real troot2
+integer j, nr
+
+ allocate (zeig1%coh%frtrel(nlay))
+ allocate (zeig1%coh%rooteff(nlay))
+ zeig1%coh%frtrel = 0. ! initialisation
+ call root_depth (1, zeig1%coh%species, zeig1%coh%x_age, zeig1%coh%height, zeig1%coh%x_frt, zeig1%coh%x_crt, nr, troot2, zeig%coh%x_rdpt, zeig%coh%nroot)
+ zeig1%coh%nroot = nr
+ do j=1,nr
+ zeig1%coh%rooteff = 1. ! assumption for the first use
+ enddo
+ do j=nr+1, nlay
+ zeig1%coh%rooteff = 0. ! layers with no roots
+ enddo
+
+END subroutine rootc_new
+
+!**************************************************************
+
+SUBROUTINE cr_depth
+
+! Calculation of the rooting depth after Rasse et al. 2001
+
+use data_soil
+use data_stand
+use data_simul
+use data_climate
+use data_species
+
+implicit none
+real :: vcr ! growth rate rootdepth [cm]
+integer :: j,k
+
+vcr=0.
+
+select case (flag_wurz)
+
+case(4,6)
+zeig => pt%first
+ k=1
+ do while (associated(zeig))
+ do j=1,nlay
+ if (zeig%coh%x_rdpt .lt. depth(j)) then
+ if (zeig%coh%x_age .le. 100) then
+ if (j .eq. 1) then
+ vcr=spar(zeig%coh%species)%v_growth*((100-real(zeig%coh%x_age))/100)*svar(zeig%coh%species)%Rstress(j)
+ zeig%coh%x_rdpt=zeig%coh%x_rdpt+(vcr/recs(time))
+ gr_depth(k)=zeig%coh%x_rdpt
+ exit
+ else
+ vcr=spar(zeig%coh%species)%v_growth*((100-real(zeig%coh%x_age))/100)*svar(zeig%coh%species)%Rstress(j)
+ zeig%coh%x_rdpt=zeig%coh%x_rdpt+(vcr/recs(time))
+ gr_depth(k)=zeig%coh%x_rdpt
+ exit
+ endif
+ endif
+ endif
+ enddo
+
+ if (zeig%coh%x_rdpt .gt. depth(nroot_max)) zeig%coh%x_rdpt = depth(nroot_max)
+ k=k+1
+ zeig => zeig%next
+ enddo
+end select
+
+END subroutine cr_depth
+
+!*******************************************************************************
+
diff --git a/source_code/version2.2_windows/seed_multi.f b/source_code/version2.2_windows/seed_multi.f
new file mode 100755
index 0000000000000000000000000000000000000000..1c355566093a747ba656792d37e575af7c521690
--- /dev/null
+++ b/source_code/version2.2_windows/seed_multi.f
@@ -0,0 +1,252 @@
+!*****************************************************************!
+!* *!
+!* 4C (FORESEE) Simulation Model *!
+!* *!
+!* *!
+!* SR SEED_multi *!
+!* *!
+!* including SR/Function *!
+!* function rtflsp (regula falsi solving equation) *!
+!* function weight *!
+!* function weight1 *!
+!* *!
+!* generation of a variety of seedling cohorts for *!
+!* one seed number according to seedmass distribution *!
+!* (for given mean value and standard deviation) *!
+!* *!
+!* 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 seed_multi(nseed,nsp)
+
+USE data_species
+use data_stand
+use data_help
+use data_par
+use data_soil
+use data_simul
+
+IMPLICIT NONE
+integer :: nseed, nseedha, nsclass , k, j, nr
+integer,dimension(:),allocatable :: nsc
+
+real, dimension(:), allocatable :: msc, &
+ shooth, &
+ nschelp
+integer :: nsp
+REAL :: shoot
+REAL :: ms, msclass, x1,x2,xacc,shelp, nshelp,ntot,help
+REAL :: troot2
+
+real :: standdev
+real :: rtflsp, weight
+
+TYPE(cohort) ::tree_ini
+
+external weight
+external rtflsp
+
+if(nseed.eq.0) return
+ standdev = spar(nsp)%seedsd*1000.
+ hnspec = nsp
+ ms = spar(nsp)%seedmass *1000. ! g ---> mg
+ nseedha = nseed
+ nshelp = nseedha/10000.
+
+! calculation of seed class number
+ if(flag_reg.eq.3) then
+ nsclass = int(100.*nshelp**0.6)
+ else if(flag_reg.eq.30) then
+ nsclass = int(10.*nshelp**0.6)+1
+ end if
+allocate(nsc(nsclass))
+allocate(nschelp(nsclass))
+allocate(msc(nsclass))
+allocate(shooth(nsclass))
+
+! seed weight and number of seeds per class
+ msclass = 6.*standdev/nsclass
+ ntot = 0
+ help = (1/(sqrt(2*pi)*standdev))
+ do k=1, nsclass
+
+ msc(k) = (ms - 3.*standdev) + msclass*(k-1)
+ nschelp(k) = help*exp(-((msc(k)-ms)**2)/(2*(standdev)**2))
+ ntot = ntot + nschelp(k)
+
+ end do
+
+ do k= 1,nsclass
+
+ nsc(k) = nint((nschelp(k)*nseedha/ntot) + 0.5)
+
+ end do
+! calculation of shoot weight per seed class and initilization
+
+ do k = 1,nsclass
+
+ mschelp = msc(k)/1000000. ! mg ---> kg
+ x1 = 0.
+ x2 = 0.1
+ xacc=(1.0e-10)*(x1+x2)/2
+
+! solve mass equation; determine root
+ shelp=rtflsp(weight,x1,x2,xacc)
+ shooth(k)= shelp
+ max_coh = max_coh + 1
+
+ call coh_initial (tree_ini)
+
+ tree_ini%ident = max_coh
+ tree_ini%species = nsp
+ tree_ini%ntreea = nsc(k)
+ tree_ini%nta = nsc(k)
+ shoot = shooth(k)
+ tree_ini%x_sap = shoot ! [kg]
+ shoot = shoot * 1000. ! [g]
+ tree_ini%x_fol= (spar(nsp)%seeda*(tree_ini%x_sap** spar(nsp)%seedb)) ![kg]
+ tree_ini%x_frt = tree_ini%x_fol ! [kg]
+! Leder
+ tree_ini%x_hrt = 0.
+ 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
+ tree_ini%crown_area = tree_ini%ca_ini
+ tree_ini%underst = 1
+
+! tranformation of shoot biomass kg --> mg
+
+ if(nsp.ne.2)tree_ini%height = spar(nsp)%pheight1*(shoot*1000.)**spar(nsp)%pheight2 ! [cm] berechnet aus shoot biomass (mg)
+! Leder
+
+ if(nsp.eq.2) tree_ini%height = 10**(spar(nsp)%pheight1+ spar(nsp)%pheight2*LOG10(shoot*1000.)+ &
+ spar(nsp)%pheight3*(LOG10(shoot*1000.))**2)
+ IF(nsc(k).ne.0.) then
+ IF (.not. associated(pt%first)) THEN
+ ALLOCATE (pt%first)
+ pt%first%coh = tree_ini
+ NULLIFY(pt%first%next)
+! root distribution
+ call root_depth (1, pt%first%coh%species, pt%first%coh%x_age, pt%first%coh%height, pt%first%coh%x_frt, pt%first%coh%x_crt, nr, troot2, pt%first%coh%x_rdpt, pt%first%coh%nroot)
+ pt%first%coh%nroot = nr
+ do j=1,nr
+ pt%first%coh%rooteff = 1. ! assumption for the first use
+ enddo
+ do j=nr+1, nlay
+ pt%first%coh%rooteff = 0. ! layers with no roots
+ enddo
+ ELSE
+
+ ALLOCATE(zeig)
+ zeig%coh = tree_ini
+ zeig%next => pt%first
+ pt%first => zeig
+
+ call root_depth (1, zeig%coh%species, zeig%coh%x_age, zeig%coh%height, zeig%coh%x_frt, zeig%coh%x_crt, nr, troot2, zeig%coh%x_rdpt, zeig%coh%nroot)
+ zeig%coh%nroot = nr
+ do j=1,nr
+ zeig%coh%rooteff = 1. ! assumption for the first use
+ enddo
+ do j=nr+1, nlay
+ zeig%coh%rooteff = 0. ! layers with no roots
+ enddo
+
+ END IF
+ anz_coh=anz_coh+1
+ END IF
+ end do
+
+deallocate(nsc)
+deallocate(nschelp)
+deallocate(msc)
+deallocate(shooth)
+
+END SUBROUTINE seed_multi
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! weight: seed mass function
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+function weight (x)
+
+use data_help
+use data_species
+
+implicit none
+
+real :: x
+real :: p1,p2, weight
+
+p1 = spar(hnspec)%seeda
+p2 = spar(hnspec)%seedb
+
+weight = p1*2*(x**p2) + x - 0.7*mschelp
+
+end function weight
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! weight1: coarse root mass function
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+function weight1 (x)
+
+use data_help
+use data_species
+
+real :: x
+real :: p1,p2
+
+p1 = spar(hnspec)%seeda
+p2 = spar(hnspec)%seedb
+
+weight1 = p1*(x**p2) + x - mschelp
+
+end function weight1
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! rtflsp: regula falsi solving euation
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+
+FUNCTION rtflsp(func,x1,x2,xacc)
+ INTEGER MAXIT
+ REAL rtflsp,x1,x2,xacc,func
+ EXTERNAL func
+ PARAMETER (MAXIT=30)
+ INTEGER j
+ REAL del,dx,f,fh,fl,swap,xh,xl
+ fl=func(x1)
+ fh=func(x2)
+ if(fl.lt.0.)then
+ xl=x1
+ xh=x2
+ else
+ xl=x2
+ xh=x1
+ swap=fl
+ fl=fh
+ fh=swap
+ endif
+ dx=xh-xl
+ do j=1,MAXIT
+ rtflsp=xl+dx*fl/(fl-fh)
+ f=func(rtflsp)
+
+ if(f.lt.0.) then
+ del=xl-rtflsp
+ xl=rtflsp
+ fl=f
+ else
+ del=xh-rtflsp
+ xh=rtflsp
+ fh=f
+ endif
+ dx=xh-xl
+ if(abs(del).lt.xacc.or.f.eq.0.)return
+ end do
+END function rtflsp
\ No newline at end of file
diff --git a/source_code/version2.2_windows/sim_ini.f b/source_code/version2.2_windows/sim_ini.f
new file mode 100755
index 0000000000000000000000000000000000000000..26395162202a05f6d731576485902a14596c9a75
--- /dev/null
+++ b/source_code/version2.2_windows/sim_ini.f
@@ -0,0 +1,272 @@
+!*****************************************************************!
+!* *!
+!* 4C (FORESEE) Simulation Model *!
+!* *!
+!* *!
+!* Subroutines for: *!
+!* - Simulation initialisation (SIM_INI) *!
+!* *!
+!* Copyright (C) 1996-2018 *!
+!* Potsdam Institute for Climate Impact Reserach (PIK) *!
+!* Authors and contributors see AUTHOR file *!
+!* This file is part of 4C and is licensed under BSD-2-Clause *!
+!* See LICENSE file or under: *!
+!* http://www.https://opensource.org/licenses/BSD-2-Clause *!
+!* Contact: *!
+!* https://gitlab.pik-potsdam.de/foresee/4C *!
+!* *!
+!*****************************************************************!
+
+SUBROUTINE sim_ini
+
+use data_biodiv
+use data_climate
+use data_depo
+use data_evapo
+use data_inter
+use data_manag
+use data_simul
+use data_site
+use data_stand
+use data_soil
+use data_soil_cn
+use data_species
+use data_par
+use data_frost
+
+implicit none
+
+type(Coh_Obj), pointer :: p ! pointer to cohort list
+
+anz_sim = anz_sim + 1
+time = 0
+time_cur = time_b - 1 ! before Sim.-Start in year_ini time_cur=time_cur+1
+iday = 0
+
+act_thin_year = 1
+flag_cum = 0
+flag_lit = 0
+flag_sens = 0
+flag_redn = .FALSE.
+
+lai=0.
+gp_can = 0.
+sumbio = 0.
+totfrt = 0.
+sumNPP = 0.
+nppsum = 0.
+gppsum = 0.
+cum_sumNPP= 0.
+NEE_mon = 0.
+NPP_mon = 0.
+autresp = 0.
+autresp_m = 0.
+anrspec = 0
+anz_coh = 0
+anz_spec = 0
+anz_tree = 0
+med_diam = 0.
+hdom = 0.
+mean_drIndAl = 0.
+
+med_air = 0.
+med_rad = 0.
+med_air_cm = 0.
+med_air_wm = 0.
+med_air_ms = 0.
+med_air_mj = 0.
+med_wind = 0.
+temp_mon = 0.
+prec_mon = 0.
+sum_prec = 0.
+sum_prec_ms= 0.;
+sum_prec_mj= 0.
+gdday = 0.
+days_summer = 0
+days_hot = 0
+days_ice = 0
+days_dry = 0
+days_hrain = 0
+days_rain = 0
+days_rain_mj= 0
+days_snow = 0
+days_wof = 0
+gdday_all = 0.
+med_air_all = 0.
+sum_prec_all = 0.
+med_rad_all = 0.
+int_cum_can = 0.
+int_cum_sveg = 0.
+interc_m_can = 0.
+interc_m_sveg= 0.
+perc_cum = 0.
+perc_mon = 0.
+wupt_cum = 0.
+wupt_r_c = 0.
+wupt_e_c = 0.
+tra_tr_cum = 0.
+tra_sv_cum = 0.
+dew_m = 0.
+aet_cum = 0.
+pet_cum = 0.
+pet_m = 0.
+AET_m = 0.
+wupt_r_m = 0.
+perc_m = 0.
+wat_tot = 0.
+gp_can_mean = 0.
+gp_can_max = 0.
+snow = 0.
+snow_day = 0
+totFPARcan = 0.
+Rnet_cum = 0.
+
+! fire index
+fire(1)%mean_m = 0
+fire(2)%mean_m = 0
+fire(3)%mean_m = 0
+fire_indb_m = 0
+
+ind_arid_an = 0.
+ind_lang_an = 0.
+ind_cout_an = 0.
+ind_wiss_an = 0.
+ind_mart_an = 0.
+ind_mart_vp = 0.
+ind_emb = 0.
+ind_weck = 0.
+ind_reich = 0.
+con_gor = 0.
+con_cur = 0.
+con_con = 0.
+cwb_an = 0.
+cwb_an_m = 0.
+ind_bud = 0.
+ind_shc = 0.
+
+ind_arid_an_m = 0.
+ind_lang_an_m = 0.
+ind_cout_an_m = 0.
+ind_wiss_an_m = 0.
+ind_mart_an_m = 0.
+ind_mart_vp_m = 0.
+ind_emb_m = 0.
+ind_weck_m = 0.
+ind_reich_m = 0.
+con_gor_m = 0.
+con_cur_m = 0.
+con_con_m = 0.
+ind_bud_m = 0.
+ind_shc_m = 0.
+ntindex = 0.
+
+tempmean_mo = 0
+
+aet_dec = 0.
+temp_dec = 0.
+prec_dec = 0.
+rad_dec = 0.
+hum_dec = 0.
+
+! frost index
+if(flag_climtyp .ge. 3) then
+ ! calculation for airtemp_min > -90.
+ tminmay=0
+ lfind=0
+ dlfabs=0.
+ tminmay_sp=0
+ dlfabs_sp=0.
+ flag_tveg=0
+else
+ tminmay=-99
+ lfind=-99
+ dlfabs=-99.
+ tminmay_sp=-99
+ dlfabs_sp=-99.
+ flag_tveg=-99
+endif
+
+
+!! initialisation of root distribution
+RedN_mean = 0.
+anz_RedN = 0
+N_min = 0.
+N_min_m = 0.
+resps_c = 0.
+resps_c_m = 0.
+resps_mon = 0.
+N_tot = 0.
+N_an_tot = 0.
+N_hum_tot = 0.
+C_tot = 0.
+C_hum_tot = 0.
+N_lit = 0.
+C_lit = 0.
+Nupt_c = 0.
+Nupt_m = 0.
+C_accu = 0.
+Nleach_c = 0.
+Nleach_m = 0.
+N_lit_m = 0.
+C_lit_m = 0.
+totfol_lit = 0.
+totfol_lit_tree = 0.
+totfrt_lit = 0.
+totfrt_lit_tree = 0.
+tottb_lit = 0.
+totcrt_lit = 0.
+totstem_lit = 0.
+C_opm_fol = 0.
+C_opm_frt = 0.
+C_opm_crt = 0.
+C_opm_tb = 0.
+C_opm_stem = 0.
+N_opm_stem = 0.
+N_opm_fol = 0.
+N_opm_frt = 0.
+N_opm_crt = 0.
+N_opm_tb = 0.
+Ndep_cum = 0.
+Ndep_cum_all= 0.
+if (flag_multi .ne. 8) then
+ if ((flag_multi .ne. 2) .or. (ip .le. 1)) then
+ NOdep(ip) = 0.
+ NHdep(ip) = 0.
+ endif
+endif
+
+flag_bc = 0
+totsteminc = 0.
+cumsteminc = 0.
+cumsumvsdead = 0.
+cumsumvsab = 0.
+sumvsdead = 0.
+sumvsab = 0.
+
+p => pt%first
+do while (associated(p))
+ p%coh%N_pool = 0.
+
+ p => p%next
+enddo ! p (cohorts)
+
+allocate(dayfract(ns_pro))
+
+! fields for frost index
+allocate(dnlf(year))
+allocate(tminmay_ann(year))
+allocate(date_lf(year))
+allocate(date_lftot(year))
+allocate(dnlf_sp(year))
+allocate (anzdlf(year))
+allocate (sumtlf(year))
+
+dnlf_sp=0
+dnlf = 0
+tminmay_ann = 0.
+date_lf = 0
+date_lftot = 0
+anzdlf = 0.
+sumtlf = 0.
+
+end subroutine sim_ini
\ No newline at end of file
diff --git a/source_code/version2.2_windows/simul.f b/source_code/version2.2_windows/simul.f
new file mode 100755
index 0000000000000000000000000000000000000000..101f9a37eb18ab3f17d999b43690d9fa263bcf86
--- /dev/null
+++ b/source_code/version2.2_windows/simul.f
@@ -0,0 +1,400 @@
+!*****************************************************************!
+!* *!
+!* 4C (FORESEE) Simulation Model *!
+!* *!
+!* *!
+!* Subroutines for: *!
+!* - Simulation control: SIM_CONTROL *!
+!* SIMULATION_4C *!
+!* *!
+!* Copyright (C) 1996-2018 *!
+!* Potsdam Institute for Climate Impact Reserach (PIK) *!
+!* Authors and contributors see AUTHOR file *!
+!* This file is part of 4C and is licensed under BSD-2-Clause *!
+!* See LICENSE file or under: *!
+!* http://www.https://opensource.org/licenses/BSD-2-Clause *!
+!* Contact: *!
+!* https://gitlab.pik-potsdam.de/foresee/4C *!
+!* *!
+!*****************************************************************!
+
+SUBROUTINE sim_control
+
+use data_climate
+use data_simul
+use data_site
+use data_out
+
+implicit none
+
+integer run_nr, ipp, irl, icl, i
+character a
+character(8) actdate
+character(10) acttime, helpsim, text1, text2
+real time1, time2, time3
+logical lhelp
+
+unit_err=getunit()
+if(flag_multi.eq.5) dirout = './'
+open(unit_err,file=trim(dirout)//trim(site_name(1))//'_error.log',status='replace', position='append')
+unit_trace=getunit()
+open(unit_trace,file=trim(dirout)//trim(site_name(1))//'_trace.log',status='replace', position='append')
+write (unit_trace, *) ' Trace of calls - subroutines of 4C '
+write (unit_trace, *)
+write (unit_trace, *) 'iday time_cur subroutine '
+write (unit_trace, '(I4,I10,A)') iday, time_cur, ' sim_control'
+
+! check daily output
+if (year > 5 .and. flag_dayout .ge. 1) then
+
+ lhelp = .true.
+ do i = 1,outd_n
+ if (outd(i)%out_flag .eq. flag_dayout) then
+
+ select CASE (outd(i)%kind_name)
+
+ CASE ('day_short')
+ lhelp = .false.
+ end select
+ endif
+ enddo
+
+ if (lhelp) then
+ write(*,*) ' Warning: Your choice of daily output is ON with a simulation time of'
+ write(*,'(I6,A,I8,A)') year,' years. This option will create ',365*year,' data records per file!'
+ write(*,'(A)',advance='no') ' Do you really want do use daily output (y/n)? '
+ read *,a
+ IF (a .eq. 'n' .or. a .eq. 'N') then
+ flag_dayout = 0
+ ENDIF
+ endif ! lhelp
+ENDIF
+
+! open file ycomp (yearly compressed output (multi run))
+IF (time_out .ne. -2) call prep_out_comp
+
+!call epsilon
+ IF(flag_multi.eq.1) THEN
+ run_nr = site_nr
+ ELSE IF (flag_multi.eq.5) THEN
+ run_nr = 1
+ ELSE
+ run_nr = repeat_number
+ ENDIF
+
+call date_and_time(actdate, acttime)
+write (unit_err, *)
+time3 = 0.
+
+ if (.not.flag_mult910) then
+ nrreal = 1
+ nrclim = 1
+ endif
+
+ do icl = 1, nrclim ! climate scenarios
+ iclim = icl
+ DO ipp = 1, run_nr ! sites
+ ip = ipp
+ if (flag_trace) write (unit_trace, '(I4,I10,A,I3)') iday, time_cur, ' sim_control ip=',ip
+ do irl = 1, nrreal ! realization f climate scenarios
+ if (flag_mult910) then
+ climfile(ip) = climszenfile(ip, icl, irl)
+ site_name (ip) = trim(site_name1)//'_'//trim(sitenum(ip))
+ write (helpsim,'(I10)') icl
+ read (helpsim,*) text1
+ write (helpsim,'(I10)') irl
+ read (helpsim,*) text2
+ site_name (ip) = trim(site_name (ip))//'_'//trim(text1)//'_'//trim(text2)
+ write (unit_err, *)
+ write (unit_err, '(A,3I5,2X, A50)')'* ip, cli-scenario, real., site: ', ip, icl, irl, site_name(ip)
+ write (unit_err, '(A,A)') 'Climate file: ', trim(climfile(ip))
+ else
+ write (unit_err, *)
+ write (unit_err, '(A10,I5,2X, A50)') ' ip/site ', ip, trim(site_name(ip))
+ site_name1 = trim(site_name(ip))
+ endif
+ call CPU_time (time1)
+ if(ip.ne.0) then
+ CALL sim_ini
+ CALL prepare_site
+ if (flag_multi.eq.5) then
+! call m4c_simenv_in
+ unit_comp2 = 6 ! standard output
+ end if
+
+ if(flag_end.gt.0) then
+ select case (flag_end)
+ case (1)
+ print*,ip, ' stop in prepare_stand (see error.log)'
+ case (2)
+ print*, ip, 'stop in prepare_stand, stand ', &
+ 'identificator not found in prepare_stand'
+ case (3)
+ print*,ip, 'stop in canopy'
+ case (4)
+ print*,ip, 'stop in readsim, climate ID not found'
+ case (5)
+ print*,ip, ' stop in readsoil, soil ID not found ', adjustl(soilid(ip))
+ case (6)
+ write(*,'(A,I5)') ' >>>foresee message: stop in read_cli - no climate data for year ',time_b
+ call finish_simul
+ stop
+ case default
+ print*,ip, 'flag_end = ', flag_end
+ end select
+
+ call finish_simul
+ flag_end = 0
+ else
+ IF(flag_multi==2) CALL fixclimscen
+ if (.not.flag_mult910) then
+ write (*,*)
+ write (*,*) '>>> Start FORESEE-Simulation site ', ipp
+ write (*,*)
+ endif
+
+ CALL simulation_4c
+ CALL finish_simul
+ endif
+ if (flag_mult910) then
+ call out_var_stat(1, irl)
+ else
+ if ((flag_multi .ne. 8) .and. (nvar .gt. 1)) call out_var_stat(3, 1)
+ endif
+ endif ! flag_end
+ call CPU_time (time2)
+ if (.not.flag_mult910) then
+ print *, ' run time for simulation ',ip, time2-time1, ' sec'
+ endif
+ write (unit_err, *) ' run time for simulation ',ip, time2-time1, ' sec'
+ time3 = time3 + (time2-time1)
+ enddo ! irl
+ if (flag_mult910) call out_var_stat(2, -99)
+ write (unit_err, *)
+ write (unit_err, *)
+ write (unit_err, *) '* * * * * New ip/site * * * * *'
+ ENDDO ! ip until site_nr (page number)
+ write (unit_err, *)
+ write (unit_err, *) '************ New climate scenario **********'
+ enddo ! icl
+
+ if (nvar .gt. 1) then
+ select case (flag_multi)
+ case (5, 9, 10)
+ continue
+ case (1)
+ continue
+ case default
+ call out_var_file
+ end select
+ endif
+
+! comparison with measurements
+ if (flag_stat .gt. 0) CALL mess
+
+ call CPU_time (time1)
+ time3 = time3 + (time1-time2)
+ write (unit_err, *)
+ write (unit_err, *) ' total run time ', time3, ' sec'
+ CALL finish_all
+ PRINT *,'All simulations finished!'
+
+END SUBROUTINE sim_control
+
+!**************************************************************
+
+SUBROUTINE simulation_4C
+
+ !*** Declaration part ***!
+
+ USE data_simul
+ USE data_species ! species specific parameters
+ USE data_site ! site specific data
+ USE data_climate ! climate data
+ USE data_soil
+ USE data_soil_cn
+ USE data_stand ! state variables of stand, cohort and cohort element
+ USE data_out
+ USE data_manag
+ USE data_plant
+ USE data_par
+ IMPLICIT NONE
+
+if (flag_trace) write (unit_trace, '(I4,I10,A)') iday, time_cur, ' simulation_4C'
+
+! allocation of environmental variable fields
+ if(flag_wpm.ne.4 .and. flag_wpm.ne.5.and.flag_wpm.ne.6) then
+ ! time loop
+ DO time = 1, year
+ iday = 1
+ ! Update population variable for new year if population is changed through interventions
+ if (flag_standup .gt. 0 .or. flag_dis==1) then
+ call stand_balance
+ call standup
+ flag_standup = 0
+ endif
+
+ CALL year_ini
+ ! Calculate RedN from soil C/N
+ ! read or create Redn for areal application
+
+ IF (time.EQ.1 .and. flag_redn) CALL RedN_ini
+ IF (flag_dis .eq. 1) CALL dis_manag
+
+ ! simulation of processes with subannual resolution (fluxes and soil)
+ CALL stand_daily
+ if(flag_end.ge.1) exit ! exit do loop time
+
+ ! compressed output of start values
+ IF (lcomp1) THEN
+ CALL out_comp(unit_comp1)
+ lcomp1 = .FALSE.
+ ENDIF
+
+ ! cohort litter production
+ CALL senescence
+
+ ! calculation of stand variables over all patches
+ CALL stand_balance
+
+ ! calculation of soil variables for yearly output
+ CALL s_year
+
+ ! calculation of fire variables for yearly output
+ CALL fire_year
+
+ ! calculation of indices for yearly output
+ CALL t_indices(temp_mon)
+
+ ! summation output
+ IF(flag_sum.eq.4) THEN
+ write(unit_sum,'(I5,9F11.3)') time_cur,photsum,npppotsum,nppsum,resosum,lightsum,nee,abslightsum,precsum, tempmean
+ photsum=0.;npppotsum=0.;nppsum=0.;resosum=0.;lightsum=0.;nee=0.;abslightsum=0.;precsum=0.
+ ENDIF
+
+ totsteminc = 0.
+ totsteminc_m3 = 0.
+ ! cohort loop for change in crown dimensions, allocation and tree dimension calculations
+ zeig=>pt%first
+ DO
+ IF (.not.ASSOCIATED(zeig)) exit
+
+ IF (zeig%coh%height.ge.thr_height .and. zeig%coh%species.le.nspec_tree) then
+
+ ! determine crown movement
+ CALL CROWN( zeig )
+
+ ! allocate NPP to the various tree compartments
+ CALL PARTITION( zeig )
+ if(flag_end.ge.1) exit ! do loop
+ ENDIF
+ IF (zeig%coh%species.EQ.nspec_tree+1) then ! Ground vegetation
+ ! allocate NPP to the various ground vegetation compartments
+ CALL PARTITION_SV( zeig )
+ ENDIF
+ IF (zeig%coh%species.eq.nspec_tree+2) then ! Mistletoe
+ CALL PARTITION_MI( zeig )
+ if(flag_end.ge.1) exit ! do loop
+ ENDIF
+ zeig=>zeig%next
+ END DO
+ if(flag_end.ge.1) exit ! exit do loop time
+
+ ! calculation of annual mortality
+ IF(flag_mort.ge.1) CALL stand_mort
+
+! annual growth of trees below thr_height, which are initialized by planting (not seeded!)
+! at the beginning of the simulation or during management (shelter-wood)
+ if(flag_reg.ne.2.and.flag_sprout.eq.0) CALL growth_seed
+ CALL mort_seed
+ if(flag_sprout.eq.1) flag_sprout=0
+ IF(flag_mg==1) then
+ if(thin_year(act_thin_year)==time_cur) then
+ CALL management
+ act_thin_year = act_thin_year+1
+ end if
+ ELSE IF((flag_mg.ge.2 .or. flag_mg.eq.3 .or. flag_mg.eq.33.or. flag_mg.eq.9 .or. flag_mg.eq.10).and.anz_spec.ne.0) THEN
+
+ CALL management
+ if(flag_wpm.ne.0) CALL timsort
+ ENDIF
+
+! no assortment if wpm is not called
+ if(flag_mg.eq.0.and.anz_spec.ne.0) then
+ if(flag_wpm.ne.0) call timsort
+ end if
+ CALL litter
+
+! input of dead biomass into soil compartments
+ CALL cn_inp
+
+ ! if(flag_multi.eq.5) call m4c_simenv_out
+! annual establishment for all species
+ IF (flag_reg.eq.1.or.flag_reg.eq.2.or.flag_reg.eq.3.or.flag_reg.eq.30) CALL stand_regen
+
+! cumsteminc = cumsteminc + totsteminc
+! planting of seedlings/saplings at the beginning of simulation
+ if(flag_reg.ge.9..and. flag_reg.lt.100. .and. time.eq.1) call planting
+ if(flag_reg.ge.9..and. flag_reg.lt.100. .and. flag_mg .eq.44) call planting
+
+! Update stand variables if stand changed
+ if (flag_standup.gt.0 .or. anz_spec.eq.0) then
+ call stand_balance
+! if (flag_standup .gt. 1) call root_distr ! wird generell in year_ini berechnet
+ endif
+ cumsteminc = cumsteminc + totsteminc
+
+
+
+ ! yearly output
+ IF (time_out .gt. 0) THEN
+ IF (mod(time,time_out) .eq. 0) then
+ CALL outyear (1)
+ CALL outyear (2)
+ endif
+ ENDIF
+
+ ! store of output variables (multi run 4, 8, 9)
+ IF (nvar .gt. 1) CALL outstore
+
+ ! RedN calculation
+ if ((flag_limi .eq. 10) .or. (flag_limi .eq. 15)) call RedN_calc
+
+! CALL list_cohort
+ CALL del_cohort
+
+ if (.not.flag_mult910) PRINT *, ' * Year ', time, time_cur,' finished... '
+
+ END DO ! time
+ ! calculation of stand variables over all patches at the end!
+ CALL stand_balance
+
+ !***** wpm ******
+ ! check if management
+ if(flag_mg == 0) then
+ flag_wpm = 0
+ endif
+
+ if (flag_wpm == 1 .or. flag_wpm == 21 .or. flag_wpm == 11) call wpm
+ if (flag_wpm == 2) call sea
+ if (flag_wpm == 3) then
+ call wpm
+ call sea
+ end if
+ !*** * * * * * * * ****
+else
+ call wpm
+end if
+ if (flag_wpm .gt. 0) call out_wpm(1)
+
+ CALL out_comp(unit_comp2)
+
+ if(flag_end.eq.1) print*,ip, 'stop in partitio'
+ if(flag_end.eq.3) print*,ip, 'stop in calc_la in canopy: toplayer = 125 m'
+ flag_end = 0
+ if (.not.flag_mult910) PRINT *, ' * Simulation ',ip,' finished.'
+
+END SUBROUTINE simulation_4C
+
+
+!**************************************************************
diff --git a/source_code/version2.2_windows/soil.f b/source_code/version2.2_windows/soil.f
new file mode 100755
index 0000000000000000000000000000000000000000..370b01efc41514a39039802eac3476478012ff84
--- /dev/null
+++ b/source_code/version2.2_windows/soil.f
@@ -0,0 +1,1502 @@
+!*****************************************************************!
+!* *!
+!* 4C (FORESEE) Simulation Model *!
+!* *!
+!* *!
+!* Subroutines for: *!
+!* Soil and Water - Programs *!
+!* *!
+!* contains: *!
+!* SOIL *!
+!* SOIL_INI *!
+!* SOIL_WAT *!
+!* UPT_WAT *!
+!* FRED1 - ...11 *!
+!* TAKE_WAT *!
+!* BUCKET *!
+!* SNOWPACK *!
+!* HUM_ADD *!
+!* BC_APPL: application of biochar *!
+!* *!
+!* 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 soil
+
+! Soil processes (frame)
+
+use data_climate
+use data_depo
+use data_out
+use data_simul
+use data_soil
+use data_soil_cn
+
+implicit none
+
+call evapo
+call intercep
+call soil_wat
+call soil_temp
+
+if (flag_wurz .eq. 4 .or. flag_wurz .eq. 6) then
+ call soil_stress !calculate ground stress factors
+ call cr_depth !define root depth
+endif
+call soil_cn
+call root_eff
+
+END subroutine soil
+
+!**************************************************************
+
+SUBROUTINE soil_ini
+
+! Initialisation of soil data and parameters
+
+use data_inter
+use data_evapo
+use data_out
+use data_par
+use data_simul
+use data_soil
+use data_soil_cn
+use data_species
+use data_stand
+
+implicit none
+
+integer i,j,k
+real d_0, t_0
+! Table of quarz and clay content (mass%) versus wlam
+real, dimension(17) :: xwlam = (/1.5, 1.15, 0.9, 0.67, 0.6, 0.5, 0.38, 0.37, 0.3, 0.29, 0.27, 0.26, 0.25, 0.24, 0.23, 0.22, 0.15/), &
+ yquarz = (/93.0,85.0,80.0, 82.0,76.0, 64.0, 65.0, 51.0,60.0, 30.0, 14.0, 10.0, 12.0, 20.0, 30.0, 43.0, 23.0/), &
+ yclay = (/3.0, 3.0, 3.0, 12.0, 6.0, 6.0, 10.0, 4.0,21.0, 12.0, 10.0, 37.0, 15.0, 40.0, 30.0, 35.0, 55.0/)
+real value
+real, dimension(nlay):: humush(nlay)
+real, dimension(nlay):: xfcap, xwiltp, xpv ! output of addition for water capacities
+
+! estimation of soil layer values
+d_0 = 0.
+do j = 1, nlay
+ t_0 = thick(j)
+ mid(j) = d_0 + 0.5*t_0
+ d_0 = d_0 + t_0
+ depth(j) = d_0
+enddo
+
+perc = 0.
+wupt_r = 0.
+wupt_ev = 0.
+thick_1 = thick(1)
+
+select case (flag_soilin)
+case (0,2)
+ do i=1,nlay
+ if (i .gt. 1) then
+ call tab_int(xwlam, yquarz, 17, wlam(i), value)
+ sandv(i) = value / 100. ! Mass% of mineral fraction
+ call tab_int(xwlam, yclay, 17, wlam(i), value)
+ clayv(i) = value / 100.
+ siltv(i) = 1. - clayv(i) - sandv(i)
+ else
+ sandv(1) = 0.0
+ clayv(1) = 0.0
+ siltv(1) = 0.0
+ endif
+ enddo
+
+case (1,3,4)
+ clayv = clayv / 100.
+ sandv = sandv / 100.
+ siltv = 1. - clayv - sandv
+ if ((sandv(1) .le. zero) .and. (clayv(1) .le. zero)) siltv(1) = 0.
+ skelv = skelv / 100.
+ humusv = humusv / 100.
+end select
+
+! Settings for subroutine take_wat
+skelfact = 1.
+pv = skelfact * pv_v * thick * 0.1 ! mm
+wilt_p = skelfact * wilt_p_v * thick * 0.1 ! mm
+field_cap = skelfact * f_cap_v * thick * 0.1 ! mm
+wats = field_cap ! mm
+watvol = f_cap_v ! vol%
+
+n_ev_d = nlay
+nlgrw = nlay+1
+do i=1,nlay
+ if (w_ev_d .gt. depth(i)) n_ev_d = i
+ if (grwlev .gt. depth(i)) nlgrw = i+1
+ vol(i) = thick(i) * 10000.
+enddo
+
+! dry mass of first layer
+dmass = vol * dens
+rmass1 = dmass(1) - (C_hum(1) + C_opm(1)) / cpart ! corection term of first layer
+
+humush = humusv
+if (2.*C_hum(1) .lt. humusv(1)*dmass(1)) then
+ humusv(1) = C_hum(1) / (dmass(1) * cpart)
+endif
+do i=2, nlay
+ humusv(i) = C_hum(i) / (dmass(i) * cpart)
+enddo
+
+if (flag_bc .gt. 0) y_bc_n = 1 ! actual number of biochar application
+
+! calculation of additions for water capacities
+call hum_add(xfcap, xwiltp, xpv)
+
+fcaph = f_cap_v - xfcap
+wiltph = wilt_p_v - xwiltp
+pvh = pv_v - xpv
+
+! ground water
+do i = nlgrw, nlay
+ wats(i) = pv(i)
+enddo
+
+interc_can = 0.
+int_st_can = 0.
+interc_sveg = 0.
+int_st_sveg = 0.
+aev_i = 0.
+
+
+
+
+wat_tot = SUM(wats)
+END subroutine soil_ini
+
+!**************************************************************
+
+SUBROUTINE soil_wat
+use data_out
+! soil water balance
+
+use data_climate
+use data_evapo
+use data_inter
+use data_out
+use data_par
+use data_simul
+use data_soil
+use data_species
+use data_stand
+
+implicit none
+
+real :: eva_dem ! evaporation demand of soil
+real :: p_inf = 0. ! infiltrated water
+real :: pev ! local: soil evaporation
+real :: watot, wetot ! total water content at start and end
+real :: wutot ! total water uptake from the soil
+real :: wutot_ev ! total water uptake by soil evaporation
+real :: wutot_r ! total water uptake by roots
+real, allocatable, dimension(:) :: upt ! local array for uptake
+real, external :: wat_new
+
+real enr, wa, we, percolnl, snow_sm, buckdepth
+integer j
+
+allocate (upt(nlay))
+wupt_ev = 0.
+aev_s = 0.
+prec_stand = MAX(0., prec - interc_can - interc_sveg) ! stand precipitation
+
+if (flag_int .gt. 1000) then
+ prec_stand = prec_stand * prec_stand_red / 100.
+endif
+
+call snowpack(snow_sm, p_inf, pev)
+
+if (anz_coh .le. 0) pev = pet
+eva_dem = MAX(0., p_inf) - pev ! evaporation demand of soil
+
+! if all stand precipitation is evaporated and there is still a demand
+! there is an uptake from soil layers (up to an certain depth)
+if (eva_dem .lt. 0.) then
+ if (snow .le. 0) call take_wat(eva_dem, cover)
+ aev_s = aev_s + p_inf + SUM(wupt_ev)
+else
+ aev_s = aev_s + pev
+endif ! eva_dem
+
+aet = aev_s + aev_i
+p_inf = MAX(eva_dem, 0.)
+upt = wupt_ev
+watot = SUM(wats) ! total initial water content
+
+do j = 1, nlgrw-1
+
+ enr = p_inf - upt(j)
+ wa = wats(j) - field_cap(j)
+ we = wat_new(wa, enr, j)
+ p_inf = enr + wa - we
+
+ perc(j) = MAX(p_inf, 0.)
+ wats(j) = MAX(we+field_cap(j), wilt_p(j))
+
+enddo
+
+do j = nlgrw, nlay
+
+ enr = p_inf - upt(j)
+ wa = wats(j) - field_cap(j)
+ we = pv(j) - field_cap(j) ! ground water level is constant!
+ p_inf = enr + wa - we
+ perc(j) = MAX(p_inf, 0.)
+ wats(j) = MAX(we+field_cap(j), wilt_p(j))
+
+enddo
+
+if (flag_wred .le. 10) then
+ call upt_wat
+else
+ call upt_wat1
+endif
+
+! root uptake balanced imediate after calculation
+upt = upt + wupt_r
+wats = wats - wupt_r
+
+watvol = 10.*wats/(thick * skelfact) ! estimation for complete layer in Vol% without skeleton (only soil substrate)
+
+! total water quantities
+wetot = SUM(wats) ! total final water content
+wutot_ev = SUM(wupt_ev) ! total water uptake by soil evaporation
+wutot_r = SUM(wupt_r) ! total water uptake by roots
+wutot = wutot_ev + wutot_r ! total water uptake
+aet = aet + wutot_r ! daily total aet
+
+percolnl = perc(nlay)
+
+trans_tree = 0.
+trans_sveg = 0.
+ zeig => pt%first
+ do while (associated(zeig))
+ if (zeig%coh%species .le. nspec_tree) then
+ trans_tree = trans_tree + zeig%coh%supply
+ else
+ trans_sveg = trans_sveg + zeig%coh%supply
+ endif
+ zeig => zeig%next
+ enddo ! zeig (cohorts)
+
+! cumulative water quantities
+perc_cum = perc_cum + perc(nlay)
+wupt_r_c = wupt_r_c + wutot_r
+wupt_e_c = wupt_e_c + wutot_ev
+wupt_cum = wupt_cum + wutot
+aet_cum = aet_cum + aet
+dew_cum = dew_cum + dew_rime
+tra_tr_cum = tra_tr_cum + trans_tree
+tra_sv_cum = tra_sv_cum + trans_sveg
+
+call bucket(bucks_100, bucks_root, buckdepth)
+
+! number of drought days per layer
+where ((wats-0.2) .le. wilt_p) s_drought = s_drought+1
+
+ if (flag_dayout .ge. 2) then
+ write (unit_wat, '(2I5, 7F7.2, 24F8.2)') time_cur, iday, airtemp, prec, interc_can, int_st_can, &
+ interc_sveg, int_st_sveg, snow, snow_sm, pet, trans_dem, &
+ pev, aev_s, aev_i, perc(nlay), watot, wetot, wutot, wutot_ev, wutot_r,&
+ trans_tree,trans_sveg, eva_dem, gp_can, aet, ceppot_can, ceppot_sveg
+endif
+deallocate (upt)
+
+END subroutine soil_wat
+
+!**************************************************************
+SUBROUTINE upt_wat
+
+! Water uptake by roots
+
+use data_simul
+use data_evapo
+use data_soil
+use data_stand
+use data_par
+use data_species
+use data_climate
+
+implicit none
+
+real, dimension(1:anz_coh) :: tr_dem ! auxiliary arrays for cohorts
+real wat_ava, hdem, frtrel, frtrel_1, hupt, hupt_c, totfrt_2, hv, demand_mistletoe_canopy
+real wat_at ! total available water per layer
+real wat_ar ! total available water per layer with uptake resistance
+real hred ! resistance coefficient
+real, external :: fred1, fred2, fred3, fred4, fred5, fred6, fred7, fred11
+integer i, ianz, j, nroot3
+
+
+! Calculation of Water Demand
+ianz = anz_coh
+
+tr_dem = 0
+hdem = 0
+hv = pet-aev_i-pev_s
+if (hv .lt. 0.) hv = 0.
+
+select case (flag_eva)
+case (0,1,3)
+ if((pet .gt. 0.) .and. (hv .gt. 0.)) then
+ trans_dem = hv * alfm * (1. - exp(-gp_tot/gpmax)) ! pet (potential evapotranspiration) is reduced by intereption evaporation and potential ground evaporation
+ else
+ trans_dem = 0.0
+ endif
+ if (gp_tot .gt. zero) then
+ hdem = trans_dem / gp_tot
+ else
+ hdem= 0.
+ endif
+case (8)
+ ! potential transpiration demand of each cohort
+ if ((gp_tot .gt. zero) .and. (hv .gt. 0.)) then
+ hdem = (pet-aev_i-aev_s) / gp_tot
+ else
+ hdem= 0.
+ endif
+
+case (2,4)
+ trans_dem = 0.
+
+case (6,16,36)
+ ! Eucalyptus
+ hv = pet
+
+ if((pet .gt. 0.) .and. (hv .gt. 0.)) then
+ trans_dem = hv * alfm * (1. - exp(-gp_tot/gpmax))
+ else
+ trans_dem = 0.
+ endif
+
+ ! preparation: potential transpiration demand of each cohort
+ if (gp_tot .gt. zero) then
+ hdem = trans_dem / gp_tot
+ else
+ hdem= 0.
+ endif
+
+case (7,17,37)
+ trans_dem = hv
+
+ ! potential transpiration demand of each cohort
+ if (gp_tot .gt. zero) then
+ hdem = trans_dem / gp_tot
+ else
+ hdem= 0.
+ endif
+
+end select
+
+hdem = max(0., hdem)
+
+! Distribution of total Demand into Demands of Cohorts
+
+!extraction of demand of mistletoe cohort (for case flag eva = 1,3,6,7...)
+zeig => pt%first
+ do while (associated(zeig))
+ if (zeig%coh%species.eq.nspec_tree+2) then
+ demand_mistletoe_canopy=zeig%coh%gp * zeig%coh%ntreea * hdem
+ end if
+ zeig => zeig%next
+ enddo
+zeig => pt%first
+i = 1
+do while (associated(zeig))
+
+ select case (flag_eva)
+ case (0, 1, 3, 6, 7, 16, 17, 36, 37)
+
+ !uppermost tree cohort (with flag mistletoe) gets additinal demand of mistletoe
+ if (zeig%coh%mistletoe.eq.1) then
+ zeig%coh%demand = zeig%coh%gp * zeig%coh%ntreea * hdem + demand_mistletoe_canopy
+ elseif (zeig%coh%species.eq.nspec_tree+2) then ! set demand of mistletoe to zero as it will be fullfilled by the tree
+ zeig%coh%demand=0. ! set to zero because demand has been added to the infested tree cohort
+ else
+ zeig%coh%demand = zeig%coh%gp * zeig%coh%ntreea * hdem ! all other cohorts get their demand
+ end if
+
+ case (2,4)
+ !uppermost tree cohort (with flag mistletoe) gets additinal demand, that of mistletoe
+ if (zeig%coh%mistletoe.eq.1) then
+ zeig%coh%demand = (max(0., zeig%coh%demand - zeig%coh%aev_i) + demand_mistletoe_cohort)
+ endif
+ if (zeig%coh%species.eq.nspec_tree+2) then ! set demand of mistletoe to zero as it will be fullfilled by the tree
+ zeig%coh%demand=0.
+ endif
+ if (zeig%coh%mistletoe.ne.1 .AND. zeig%coh%species.ne.nspec_tree+2) then
+ zeig%coh%demand = max(0., zeig%coh%demand - zeig%coh%aev_i)
+ end if
+ trans_dem = trans_dem + zeig%coh%demand
+ end select
+
+ tr_dem(i) = zeig%coh%demand ! demand of transpiration per cohort
+ i = i + 1
+ zeig => zeig%next
+enddo ! zeig (cohorts)
+
+! Calculation of Water Supply
+frtrel_1 = 1.
+
+select case (flag_wurz)
+case (0)
+ if (nroot_max .gt. 5) then
+ nroot3 = 5
+ else
+ nroot3 = nroot_max
+ endif
+case default
+ nroot3=nroot_max
+end select
+
+
+
+
+! layers with seedlings
+do j = 1,nroot3
+ ! determination of resisctance coefficient
+
+ select case (flag_wred)
+ case(1)
+ hred = fred1(j)
+ case(2)
+ hred = fred2(j)
+ case(3)
+ hred = fred3(j)
+ case(4)
+ hred = fred4(j)
+ case(5)
+ hred = 1.
+ case(6)
+ hred = 0.5
+ case(7)
+ hred = 0.25
+ case(8)
+ hred = fred6(j)
+ case(10)
+ hred = fred7(j)
+ case(11)
+ hred = fred11(j)
+ end select
+
+ wat_res(j) = hred
+
+ if (temps(j) .gt. -0.3) then
+ wat_at = max(wats(j) - wilt_p(j), 0.) ! total available water per layer
+ wat_ar = hred * wat_at ! total available water per layer with uptake resistance
+ hupt = 0.
+ else
+ wat_ar = 0. ! frost
+ wat_at = 0.
+ hupt = 0.
+ endif
+
+
+
+! Distribution of Water Supply into the Cohorts
+! Distribution of Fine Roots
+
+ zeig => pt%first
+ i = 1 ! cohort index
+ do while (associated(zeig))
+ if (zeig%coh%species .ne. nspec_tree+2) then ! not for mistletoe
+ frtrel = zeig%coh%frtrelc(j)
+
+ wat_ava = frtrel * wat_ar ! available water per tree cohort and layer
+
+
+ if (wat_ava .ge. tr_dem(i)) then
+ hupt_c = tr_dem(i)
+ tr_dem(i) = 0.
+ else
+ hupt_c = wat_ava
+ tr_dem(i) = tr_dem(i) - wat_ava
+ endif
+ xwatupt(i,j) = hupt_c ! water uptake per cohorte and layer
+ zeig%coh%supply = zeig%coh%supply + hupt_c
+ if (zeig%coh%supply .lt.0.) then
+ continue
+ endif
+ hupt = hupt + hupt_c
+
+
+ i = i + 1
+ end if ! exclusion of mistletoe
+ zeig => zeig%next
+ enddo ! zeig (cohorts)
+
+ wupt_r(j) = hupt
+
+enddo ! j
+
+! layers without seedlings
+
+if (totfrt_p.gt.(seedlfrt+zero)) then
+ totfrt_2 = 1./(totfrt_p-seedlfrt)
+
+ do j = nroot3+1, nroot_max
+ ! determination of resisctance coefficient
+ select case (flag_wred)
+ case(1)
+ hred = fred1(j)
+ case(2)
+ hred = fred2(j)
+ case(3)
+ hred = fred3(j)
+ case(4)
+ hred = fred4(j)
+ case(5)
+ hred = 1.
+ case(6)
+ hred = 0.5
+ case(7)
+ hred = 0.25
+ end select
+
+ wat_res(j) = hred
+
+ if (temps(j) .gt. -0.3) then
+ wat_at = max(wats(j) - wilt_p(j), 0.) ! total available water per layer
+ wat_ar = hred * wat_at ! total available water per layer with uptake resistance
+ hupt = 0.
+ else
+ wat_ar = 0.
+ endif
+
+ zeig => pt%first
+ i = 1 ! cohort index
+ do while (associated(zeig))
+ frtrel = zeig%coh%frtrelc(j)
+ wat_ava = frtrel * wat_ar ! available water per tree cohort and layer
+ if (wat_ava .ge. tr_dem(i)) then
+ hupt_c = tr_dem(i)
+ tr_dem(i) = 0.
+ else
+ hupt_c = wat_ava
+ tr_dem(i) = tr_dem(i) - wat_ava
+ endif
+ xwatupt(i,j) = hupt_c
+ zeig%coh%supply = zeig%coh%supply + hupt_c
+ hupt = hupt + hupt_c
+ i = i + 1
+ zeig => zeig%next
+ enddo ! zeig (cohorts)
+
+ wupt_r(j) = hupt
+enddo ! j
+endif
+END subroutine upt_wat
+
+!**************************************************************
+
+SUBROUTINE upt_wat1
+
+! Water uptake by roots
+! 2. Version
+
+use data_simul
+use data_evapo
+use data_soil
+use data_stand
+use data_par
+
+implicit none
+
+real, dimension(1:anz_coh) :: tr_dem,frt_rel ! help arrays for cohorts
+real wat_ava, hdem, frtrel, frtrel_1, hupt, hupt_c, totfrt_2
+real wat_at ! total available water per layer
+real wat_ar ! total available water per layer with uptake resistance
+real hred ! resistance coefficient
+real, external :: fred1, fred2, fred3, fred4, fred5, fred6, fred7, fred11
+
+integer i, ianz, j, nroot3
+
+ianz = anz_coh
+tr_dem=0
+trans_dem = (pet-aev_i) * alfm * (1. - exp(-gp_can/gpmax)) ! pet NOT reduced by ground evaporation
+if (trans_dem .lt. 0.) trans_dem = 0.
+
+! potential transpiration demand of each cohort
+if (gp_can .gt. zero) then
+ hdem = trans_dem / gp_can
+else
+ hdem= 0.
+endif
+
+! Estimation of transpiration demand of tree cohorts and total fine root mass
+! in layers with and without seedlings
+zeig => pt%first
+i = 1
+do while (associated(zeig))
+ select case (flag_eva)
+ case (0, 1, 3)
+ zeig%coh%demand = zeig%coh%gp * zeig%coh%ntreea * hdem
+ case (2)
+ zeig%coh%demand = zeig%coh%demand - zeig%coh%aev_i
+ end select
+ tr_dem(i) = zeig%coh%demand
+ i = i + 1
+ zeig => zeig%next
+enddo ! zeig (cohorts)
+
+! uptake controlled by share of roots
+frtrel_1 = 1.
+
+! layers with seedlings
+do j = 1,nroot_max
+ ! determination of resisctance coefficient
+ select case (flag_wred)
+ case(1)
+ hred = fred1(j)
+ case(2)
+ hred = fred2(j)
+ case(3)
+ hred = fred3(j)
+ case(4)
+ hred = fred4(j)
+ case(5)
+ hred = 1.
+ case(6)
+ hred = 0.5
+ case(7)
+ hred = 0.25
+ case(8) ! BKL, ArcEGMO
+ hred = fred6(j)
+ case(10)
+ hred = fred7(j)
+ end select
+
+ wat_at = max(wats(j) - wilt_p(j), 0.) ! total available water per layer
+ wat_ar = hred * wat_at ! total available water per layer with uptake resistance
+ hupt = 0.
+
+ zeig => pt%first
+ i = 1 ! cohort index
+ do while (associated(zeig))
+
+ frtrel = zeig%coh%frtrel(j) * zeig%coh%x_frt * zeig%coh%ntreea * totfrt_1
+ wat_ava = frtrel * wat_ar ! available water per tree cohort and layer
+ if (wat_ava .ge. tr_dem(i)) then
+ hupt_c = tr_dem(i)
+ tr_dem(i) = 0.
+ else
+ hupt_c = wat_ava
+ tr_dem(i) = tr_dem(i) - wat_ava
+ endif
+ xwatupt(i,j) = hupt_c
+ zeig%coh%supply = zeig%coh%supply + hupt_c
+ hupt = hupt + hupt_c
+ i = i + 1
+ zeig => zeig%next
+ enddo ! zeig (cohorts)
+
+ wupt_r(j) = hupt
+enddo ! j
+END subroutine upt_wat1
+
+!**************************************************************
+
+real FUNCTION fred1(j)
+
+! Function for calculating uptake resistance
+! from CHEN (1993)
+! empirical relation between soil water content and resistance
+! fred1=1 if (field_cap - 10%*field_cap) <= wats <= (field_cap + 10%*field_cap)
+
+use data_par
+use data_soil
+
+implicit none
+real hf, f09, f11, wc, diff
+integer j
+
+f09 = 0.9 * field_cap(j)
+f11 = 1.1 * field_cap(j)
+wc = wats(j)
+
+if (wc .lt. wilt_p(j)) then
+ hf = 0.
+else if (wc .lt. f09) then
+ diff = f09-wilt_p(j)
+ if (diff .lt. zero) diff = 0.001
+ hf = 1. - (f09-wc) / diff
+else if (wc .gt. f11) then
+ diff = pv(j)-f11
+ if (diff .lt. zero) diff = 0.001
+ hf = 0.3 + 0.7 * (pv(j)-wc) / diff
+ if (hf .lt. zero) hf = 0.001
+else
+ hf = 1.
+endif
+fred1 = hf
+END function fred1
+
+!**************************************************************
+
+real FUNCTION fred2(j)
+
+! Function for calculating uptake resistance
+! from Aber and Federer (f=0.04 fuer Wasser in cm)
+! only 40% of total available water are plant available per day
+
+implicit none
+
+integer j
+
+fred2 = 0.05
+
+END function fred2
+
+!**************************************************************
+
+real FUNCTION fred3(j)
+
+! Function for calculating uptake resistance
+! from CHEN (1993)
+! modified to a profile defined in fred
+! fred3 may be described by a function (old version):
+! fred3 = 0.0004*j*j - 0.0107*j + 0.0735
+! this case: set from a root profile, defined by input of root_fr
+
+use data_par
+use data_soil
+
+implicit none
+real hf, f09, f11, wc, diff
+! hf is a reduction factor in dependence on water content
+real fred(15)
+
+integer j
+
+! uptake reduction depending on water content
+f09 = 0.9 * field_cap(j)
+f11 = 1.1 * field_cap(j)
+wc = wats(j)
+
+if (wc .lt. wilt_p(j)) then
+ hf = 0.
+else if (wc .lt. f09) then
+ diff = f09-wilt_p(j)
+ if (diff .lt. zero) diff = 0.001
+ hf = 1. - (f09-wc) / diff
+else if (wc .gt. f11) then
+ diff = pv(j)-f11
+ if (diff .lt. zero) diff = 0.001
+ hf = 0.3 + 0.7 * (pv(j)-wc) / diff
+ if (hf .lt. zero) hf = 0.001
+else
+ hf = 1.
+endif
+
+fred3 = root_fr(j) * hf
+
+END function fred3
+
+!**************************************************************
+
+real FUNCTION fred4(j)
+
+! Function for calculating uptake resistance
+! modified to a profile defined in fred
+! profile at Beerenbusch
+
+use data_soil
+
+implicit none
+real fred(15)
+
+integer j
+
+fred = (/ 0.0, 0.03, 0.03, 0.02, 0.02, 0.02, 0.02, 0.01, 0.01, 0.01, &
+ 0.01, 0.01, 0.01, 0.01, 0.01 /) ! fred fuer Beerenbusch
+
+fred4 = fred(j)
+
+END function fred4
+
+!**************************************************************
+
+real FUNCTION fred6(j)
+
+! Function for calculating uptake resistance
+! from Kloecking (2006) simular to fred1
+! empirical relation between soil water content and resistance
+! fred6=1 if field_cap <= wats <= (field_cap + 10%*field_cap)
+
+use data_soil
+
+implicit none
+real hf, f09, f11, wc
+integer j
+
+f09 = field_cap(j)
+f11 = 1.1 * field_cap(j)
+wc = wats(j)
+
+if (wc .le. wilt_p(j)) then
+ hf = 0.
+else if (wc .lt. f09) then
+ hf = 0.1 + (0.9 *(wc-wilt_p(j)) / (f09-wilt_p(j)))
+else if (wc .gt. f11) then
+ hf = 0.3 + 0.7 * (pv(j)-wc) / (pv(j)-f11)
+ if (hf .lt. 0.) hf = 0.001
+else
+ hf = 1.
+endif
+
+fred6 = hf
+
+END function fred6
+
+!**************************************************************
+
+real FUNCTION fred7(j)
+
+! Function for calculating uptake resistance
+! from CHEN (1993)
+! empirical relation between soil water content and resistance
+! fred1=1 if (field_cap - 10%*field_cap) <= wats <= (field_cap + 10%*field_cap)
+
+use data_par
+use data_soil
+
+implicit none
+real hf, f09, f11, wc, diff
+integer j
+
+f09 = 0.9 * field_cap(j)
+f11 = 1.1 * field_cap(j)
+wc = wats(j)
+
+if (wc .lt. wilt_p(j)) then
+ hf = 0.
+else if (wc .lt. f09) then
+ diff = f09-wilt_p(j)
+ if (diff .lt. zero) diff = 0.001
+ hf = exp(-5.*(f09-wc) / diff)
+else if (wc .gt. f11) then
+ diff = pv(j)-f11
+ if (diff .lt. zero) diff = 0.001
+ hf = 0.3 + 0.7 * (pv(j)-wc) / diff
+ if (hf .lt. zero) hf = 0.001
+else
+ hf = 1.
+endif
+
+fred7 = hf
+
+END function fred7
+
+!**************************************************************
+
+real FUNCTION fred11(j)
+
+! Function for calculating uptake resistance, especially adapted for Mistletoe disturbance
+! function after van Wijk, 2000
+
+use data_par
+use data_soil
+implicit none
+real hf, S, f11, wc, diff
+integer j
+f11 = 1.1 * field_cap(j)
+wc = wats(j)
+if (wc .lt. wilt_p(j)) then
+ hf = 0.
+else if (wc .lt. field_cap(j)) then
+ S=(field_cap(j)-wc)/(field_cap(j)-wilt_p(j))
+ hf = exp(-30*S) !30 = strong reduction in water avail.
+else if (wc .gt. f11) then
+ diff = pv(j)-f11
+ if (diff .lt. zero) diff = 0.001
+ hf = 0.3 + 0.7 * (pv(j)-wc) / diff
+ if (hf .lt. zero) hf = 0.001
+else
+ hf = 1.
+endif
+fred11 = hf
+END function fred11
+
+!**************************************************************
+
+
+
+
+
+
+
+
+ SUBROUTINE take_wat(eva_dem, psi)
+
+! Estimation of water taking out for uncovered soil
+use data_soil
+use data_simul
+
+implicit none
+
+!input:
+real :: eva_dem ! evaporation demand
+real :: psi ! covering
+
+integer i, ii, j, ntag ! max. layer of taking out
+real, allocatable, dimension(:) :: gj
+real, external :: b_r, funcov
+real diff, gj_j, depth_j, depth_n, rij, rmax, rr, rs, sr
+
+allocate (gj(nlay))
+
+do i=1,nlay
+ wupt_ev(i)=0.0
+ gj(i)=0.0
+enddo
+
+ntag = 0
+rmax = 0.0
+depth_n = depth(n_ev_d)
+
+do i=1,n_ev_d
+ rij = 0.0
+ rr = depth_n/depth(i)
+ sr = 0.0
+ rs = 0.0
+
+ do j=1,i
+! depth for uncovered take out
+ depth_j = depth(j)
+ gj(j) = FUNCOV(w_ev_d, rs*rr, rr*depth_j)
+ rs = depth_j
+ sr = sr + gj(j)
+ enddo ! i
+
+ if (sr.gt.1.E-7) then
+ sr = 1.0/sr
+
+ do j=1,i
+! water take out
+! (psi = 1.-psi) no soil evaporation in case of total covering
+! and maximal evaporation for uncovered soil
+ gj_j = -B_R(wats(j), field_cap(j), wilt_p(j)) &
+ * eva_dem * (1.-psi) * gj(j) * sr
+ gj_j = max(gj_j,0.0)
+ gj(j)= gj_j
+ rij = rij + gj_j
+ enddo ! i
+
+ if (rij .gt. rmax) then
+ rmax = rij
+ ntag = i
+
+ do ii=1,ntag
+ wupt_ev(ii) = gj(ii)
+ enddo
+
+ endif ! rij
+ endif ! sr
+enddo ! n_ev_d
+
+! balance
+do i=1,nlay
+ diff = wats(i) - wilt_p(i)
+ if (wupt_ev(i) .gt. diff) then
+ wupt_ev(i) = diff
+ endif
+enddo ! nlay
+
+deallocate (gj)
+
+END subroutine take_wat
+
+!*******************************************************************************
+
+real FUNCTION B_R(water, f_cap, wilting)
+
+! Reduction function for water taking out (uncovered soil)
+
+implicit none
+
+!input:
+real :: water ! water storage
+real :: f_cap ! field capacity
+real :: wilting ! wilting point
+
+b_r = 1.0
+
+if (water .lt. f_cap) B_R = max((water-wilting)/(f_cap-wilting), 0.0)
+
+END function B_R
+
+!******************************************************************************
+
+real FUNCTION funcov(wt_d, a, bb)
+
+! take out density function for uncovered soil
+
+implicit none
+
+!input:
+real :: wt_d ! depth of water taking out by evaporation (cm)
+real :: a, bb ! relative upper and lower depth of actual layer
+real fk, wt_5, b
+
+ fk = .455218234
+ wt_5 = 0.05 * wt_d
+ b = min(bb,wt_d)
+ funcov = (- b + a + 1.05*wt_d*log((b+wt_5)/(a+wt_5)))*fk/wt_d
+
+END function funcov
+
+!******************************************************************************
+
+real FUNCTION wat_new(wat_us, wat_in, ilayer)
+! FUNCTION WIEN(WIA,NIST,ALAM,DTI,TT,DICK)
+
+! Estimation of additional water after infiltration and percolation
+
+use data_par
+use data_soil
+
+implicit none
+
+! input:
+real :: wat_us ! water content in relation to field capacity
+real :: wat_in ! water infiltration into actual layer
+integer :: ilayer ! number of actual layer
+real dti !time step
+real awi, b1, b2, la, hsqr, exphelp
+
+dti = 1.
+fakt = 0.4
+
+if (fakt .ge. 0.0) then ! percolation?
+ la = 100.0 * fakt * dti * wlam(ilayer)/thick(ilayer)**2
+ if (wat_us .le. zero) then ! water near zero?
+ if (wat_in .le. zero) then ! infiltrated water near zero?
+ wat_new = wat_us + wat_in
+ else
+ if (wat_us+wat_in .gt. zero) then
+ exphelp = sqrt(la*wat_in) * (1 + wat_us/wat_in)*1
+ if (exphelp .le.10.) then ! avoid underflow
+ b1 = -exp(-2. * exphelp)
+ else
+ b1 = 0.
+ endif
+ wat_new = sqrt(wat_in/la) * (1+b1)/(1-b1)
+ else
+ wat_new = wat_us + wat_in
+ endif
+ endif ! wat_in
+
+ else
+ if (wat_in .lt. 0.) then
+ awi = abs(wat_in)
+ b1 = atan(wat_us/sqrt(awi/la)) / sqrt(la * awi)
+ if (b1 .gt. 1) then
+ b2 = sqrt (awi * la)
+ b1 = sin(b2) / cos(b2)
+ b2 = sqrt(awi / la)
+ wat_new = b2 * (wat_us - b2*b1) / (b2 + wat_us*b1)
+ else
+ wat_new = wat_in * (1-b1)
+ endif ! b1
+ else
+ if (wat_in .gt. 0.) then
+ b1 = sqrt(wat_in / la)
+ hsqr = sqrt(la*wat_in)
+ if (hsqr .lt. 10.) then
+ b2 = (wat_us - b1) * exp(-2.* hsqr) / (wat_us + b1)
+ if (b2 .ge. 1.0) then
+ b2 = 0.99999
+ endif
+ else
+ b2 = 0.
+ endif
+ wat_new = b1 * (1.+b2) / (1.-b2)
+ else
+ wat_new = wat_us / (1. + la*wat_us)
+ endif
+ endif ! wat_in
+ endif ! wat_us
+else
+ wat_new = wat_us
+endif ! fakt
+
+END function wat_new
+
+!******************************************************************************
+
+SUBROUTINE bucket(bucksize1, bucksize2, buckdepth)
+
+! calculation of bucket size (1m; without humus layer)
+
+use data_soil
+
+implicit none
+
+real bucksize1, & ! bucket size of 1 m depth (nFK)
+ bucksize2, & ! bucket size of rooting zone
+ buckdepth, diff
+integer j
+
+bucksize1 = 0.
+bucksize2 = 0.
+buckdepth = 0.
+do j=2,nlay
+ if ((depth(j)-depth(1)) .lt. 100.) then
+ bucksize1 = bucksize1 + wats(j) - wilt_p(j)
+ buckdepth = depth(j) - depth(1)
+ else
+ diff = 100. - buckdepth
+ bucksize1 = bucksize1 + (wats(j) - wilt_p(j))*diff/thick(j)
+ buckdepth = 100.
+ exit
+ endif
+enddo
+
+do j=2,nroot_max
+ bucksize2 = bucksize2 + wats(j) - wilt_p(j)
+enddo
+
+END subroutine bucket
+
+!******************************************************************************
+
+SUBROUTINE snowpack(snow_sm, p_inf, pev)
+
+! properties of snow
+! calculation of soil surface temperature under snow pack
+
+use data_climate
+use data_evapo
+use data_inter
+use data_par
+use data_simul
+use data_soil
+use data_soil_t
+
+implicit none
+
+real p_inf ! infiltrated water
+real snow_sm
+real pev
+real airtemp_sm ! melting temperature
+real snow_old ! old snow pack
+real tc_snow ! thermal conductivity of snow J/cm/s/K
+real thick_snow ! thickness of snow
+real dens_snow ! density of snow
+real:: dens_sn_new = 0.1 ! density of fresh snow
+real fakta
+
+snow_old = snow
+
+!substract evaporation of snowcover from snow in both cases
+if (airtemp .lt. temp_snow) then ! frost conditions
+ snow = snow + prec_stand ! precipitation as snow
+ snow_sm = 0.0 ! no snow melting
+ p_inf = 0.0 ! no infiltrated precipitation
+ pev = max((pev_s - aev_i), 0.) ! interc. evapor. reduces soil evapor.
+
+else
+
+ airtemp_sm = max(airtemp, 0.)
+ snow_sm = airtemp*(0.45+0.2*airtemp) ! snow melting
+ snow_sm = MIN(snow_sm, snow)
+ snow = snow - snow_sm
+ p_inf = prec_stand + snow_sm ! infiltrated precipitation
+ pev = max((pev_s - aev_i), 0.) ! interc. evapor. reduces soil evapor.
+
+end if ! airtemp
+
+if (snow .ge. zero) then
+ snow_day = snow_day + 1
+ days_snow = days_snow + 1
+ if (pev .le. zero) then
+ pev = 0.
+ else
+ ! snow sublimation
+ aev_s = max(min(snow, pev), 0.)
+ snow = snow - aev_s
+ pev = pev - aev_s
+ endif
+
+ ! soil surface temperature under snow pack
+ ! snow hight = 0.2598 * water equivalent + 8.6851; adjustment from measurement values (see Bodentemperatur.xls)
+
+ if (snow .ge. 0.05) then
+
+ dens_snow = dens_sn_new + snow_day*0.025
+ dens_snow = MIN(dens_snow, 1.)
+ dens_snow = 0.5*(dens_sn_new*prec_stand + dens_snow*snow_old)/snow
+ dens_snow = MIN(dens_snow, 1.)
+ tc_snow = 0.7938*EXP(3.808*dens_snow)*0.001 ! thermal conductivity of snow J/cm/s/K
+ thick_snow = snow / dens_snow
+ fakta = tc_snow * 86400. * (thick(1)/2.) / (t_cond(1) * thick_snow) ! s --> day
+ temps_surf = (0.5*temps(1) + fakta*airtemp) / (1. + fakta) ! CoupModel (Jansson, 2001)
+ endif
+else
+ snow_day = 0
+endif
+END subroutine snowpack
+
+!******************************************************************************
+
+SUBROUTINE soil_stress
+
+! Calculation of the stress factors
+
+use data_soil
+use data_species
+use data_stand
+use data_par
+
+implicit none
+integer :: i, k
+
+real :: m_1, m_2, n_1, n_2
+real :: wratio, wafpo
+real, dimension (1:4) :: allstress, xvar, yvar
+
+!temperature stress
+do i=1,nlay
+ do k=1,nspecies
+ if (temps(i) .ge. spar(k)%tbase) then
+ svar(k)%tstress(i) = sin((pi/2)*(temps(i)-spar(k)%tbase)/(spar(k)%topt-spar(k)%tbase))
+ else
+ svar(k)%tstress(i) = 0.
+ endif
+
+ !soil strength
+ wratio=0.
+ if (dens(i) .le. BDopt(i)) then
+ svar(k)%BDstr(i) = 1
+ svar(k)%BDstr(i) = 1
+ elseif (dens(i) .ge. svar(k)%BDmax(i)) then
+ svar(k)%BDstr(i) = 0
+ else
+ svar(k)%BDstr(i) = (svar(k)%BDmax(i)-dens(i))/(svar(k)%BDmax(i)-BDopt(i))
+ endif
+
+ if (watvol(i) .lt. wilt_p_v(i)) then
+ wratio = 0.
+ elseif (watvol(i) .gt. f_cap_v(i)) then
+ wratio = 1.
+ else
+ wratio = (watvol(i)-wilt_p_v(i))/(f_cap_v(i)-wilt_p_v(i))
+ endif
+
+ svar(k)%sstr(i)=svar(k)%BDstr(i)*sin(1.57*wratio)
+
+ !aeration
+ wafpo=watvol(i)/pv_v(i)
+ if (wafpo .ge. svar(k)%porcrit(i)) then
+ svar(k)%airstr(i) = (1.-wafpo)/(1.-svar(k)%porcrit(i))
+ else
+ svar(k)%airstr(i) = 1.
+ endif
+
+ if (svar(k)%airstr(i) .lt. 0.) svar(k)%airstr(i) = 0.
+
+ !soil acidity
+ xvar=(/spar(k)%ph_min, spar(k)%ph_opt_min, spar(k)%ph_opt_max, spar(k)%ph_max/)
+ yvar=(/0,1,1,0/)
+ m_1=(yvar(1)-yvar(2))/(xvar(1)-xvar(2))
+ n_1=yvar(2)-m_1*xvar(2)
+ m_2=(yvar(3)-yvar(4))/(xvar(3)-xvar(4))
+ n_2=yvar(4)-m_2*xvar(4)
+
+ if (phv(i) .gt. spar(k)%ph_opt_max .and. phv(i) .le. spar(k)%ph_max ) then
+ svar(k)%phstr(i)=m_2*phv(i)+n_2
+ elseif (phv(i) .lt. spar(k)%ph_opt_min .and. phv(i) .ge. spar(k)%ph_min ) then
+ svar(k)%phstr(i)=m_1*phv(i)+n_1
+ elseif (phv(i) .gt. spar(k)%ph_max .or. phv(i) .lt. spar(k)%ph_min) then
+ svar(k)%phstr(i)=0.
+ else
+ svar(k)%phstr(i)=1.
+ endif
+
+ ! total stress (Rstress) is taken as the largest of the four
+
+ allstress(1)=svar(k)%tstress(i)
+ allstress(2)=svar(k)%sstr(i)
+ allstress(3)=svar(k)%airstr(i)
+ allstress(4)=svar(k)%phstr(i)
+
+ svar(k)%Rstress(i)= minval(allstress)
+ svar(k)%Smean(i)=svar(k)%Rstress(i)+svar(k)%Smean(i)
+
+ enddo
+enddo
+
+END subroutine soil_stress
+
+!*******************************************************************************
+
+SUBROUTINE hum_add(xfcap, xwiltp, xpv)
+! Soil parameter according to [Kuntze et al., Bodenkunde, 1994], S. 172
+
+use data_simul
+use data_soil
+use data_soil_cn
+
+implicit none
+integer :: i, k
+real :: fcapi, clayvi, siltvi, humvi, humvi2, wiltpi, pvi, nfki, hcbc
+real, dimension(nlay):: xfcap, xwiltp, xpv ! output of addition mm/dm
+
+ xfcap(1) = 0.0
+ xwiltp(1) = 0.0
+ xpv(1) = 0.0
+
+do i = 1, nlay
+ fcapi = 0.
+ wiltpi = 0.
+ pvi = 0.
+ clayvi = clayv(i)
+ humvi = humusv(i)*100.
+ humvi2 = humusv(i)*humusv(i)
+ if (humvi .lt. 15.) then
+ if (clayvi .le. 0.05) then
+ wiltpi = 0.0609 * humvi2 + 0.33 * humvi
+ pvi = 0.0436 * humvi2 + 0.631 * humvi
+ nfki = -0.0009 * humvi2 + 1.171 * humvi
+ fcapi = nfki + wiltpi
+
+ else if (clayvi .le. 0.12) then
+ wiltpi = 0.0357 * humvi2 + 0.0762 * humvi
+ pvi = 0.0441 * humvi2 + 0.5455 * humvi
+ nfki = 0.0252 * humvi2 + 0.7462 * humvi
+ fcapi = nfki + wiltpi
+
+ else if (clayvi .le. 0.17) then
+ wiltpi = 0.0374 * humvi2 - 0.1777 * humvi
+ pvi = 0.0552 * humvi2 + 0.2936 * humvi
+ nfki = 0.0324 * humvi2 + 0.6243 * humvi
+ fcapi = nfki + wiltpi
+
+ else if (clayvi .le. 0.35) then
+ wiltpi = 0.0179 * humvi2 - 0.0385 * humvi
+ pvi = 0.0681 * humvi2 + 0.0768 * humvi
+ nfki = 0.0373 * humvi2 + 0.3617 * humvi
+ fcapi = nfki + wiltpi
+
+ else if (clayvi .le. 0.65) then
+ wiltpi = 0.0039 * humvi2 + 0.0254 * humvi
+ pvi = 0.0613 * humvi2 + 0.0947 * humvi
+ nfki = 0.0338 * humvi2 + 0.0904 * humvi
+ fcapi = nfki + wiltpi
+
+ else
+ wiltpi = 0.0
+ pvi = 0.0613 * humvi2 + 0.0947 * humvi
+ nfki = 0.0104 * humvi2 + 0.2853 * humvi
+ fcapi = nfki + wiltpi
+
+ endif
+ else ! humvi > 15
+ ! organic soils
+ continue
+ endif ! humvi
+
+ xfcap(i) = fcapi
+ xwiltp(i) = wiltpi
+ xpv(i) = pvi
+enddo
+
+if (flag_bc .gt. 0) then
+ do i = 1, nlay
+ if (C_bc(i) .gt. 0.) then
+ fcapi = f_cap_v(i)
+ clayvi = clayv(i)
+ siltvi = siltv(i)
+ humvi = humusv(i)*100.
+ hcbc = C_bc(i)*100.*100. / (cpart_bc(y_bc_n) * dmass(i))
+ if ((clayvi .le. 0.17) .and. (siltvi .le. 0.5)) then ! sand
+ fcapi = 0.0619 * hcbc
+ wiltpi = 0.0375 * hcbc
+ nfki = 7.0
+ elseif ((clayvi .le. 0.45) .and. (siltvi .gt. 0.17)) then ! loam
+ fcapi = 0.015 * hcbc
+ wiltpi = 0.0157 * hcbc
+ nfki = 10.
+ else ! clay
+ fcapi = -0.0109 * hcbc
+ wiltpi = -0.0318 * hcbc
+ nfki = 16.
+ endif
+ xfcap(i) = xfcap(i) + fcapi
+ xwiltp(i) = xwiltp(i) + wiltpi
+ endif
+
+ enddo
+endif
+
+END subroutine hum_add
+
+!*******************************************************************************
+
+SUBROUTINE bc_appl
+
+! application of biochar
+
+use data_out
+use data_simul
+use data_soil
+use data_soil_cn
+
+implicit none
+
+character :: text
+integer :: ios, inunit, j
+logical :: ex
+real :: hcbc
+
+ call testfile(valfile(ip),ex)
+ IF (ex .eqv. .true.) then
+ inunit = getunit()
+ ios=0
+ open(inunit,file=valfile(ip),iostat=ios,status='old',action='read')
+ if (.not.flag_mult8910) then
+ print *,'***** Reading application values of biochar from file ',valfile(ip),'...'
+ write (unit_err, *) 'Application values of biochar from file ',trim(valfile(ip))
+ endif
+
+ do
+ read(inunit,*) text
+ IF(text .ne. '!')then
+ backspace(inunit)
+ exit
+ endif
+ enddo
+
+ read (inunit,*,iostat=ios) n_appl_bc
+ allocate (C_bc_appl(n_appl_bc))
+ allocate (N_bc_appl(n_appl_bc))
+ allocate (bc_appl_lay(n_appl_bc))
+ allocate (cnv_bc(n_appl_bc))
+ allocate (dens_bc(n_appl_bc))
+ allocate (cpart_bc(n_appl_bc))
+ allocate (y_bc(0 : n_appl_bc + 1))
+ y_bc = 0
+ C_bc_appl = 0.
+ N_bc_appl = 0.
+ do j = 1, n_appl_bc
+ read (inunit,*,iostat=ios) y_bc(j), cpart_bc(j), cnv_bc(j), dens_bc(j)
+ read (inunit,*,iostat=ios) bc_appl_lay(j), C_bc_appl(j)
+ enddo
+ endif ! ex
+
+END subroutine bc_appl
+
+!*******************************************************************************
diff --git a/source_code/version2.2_windows/soil_cn.f b/source_code/version2.2_windows/soil_cn.f
new file mode 100755
index 0000000000000000000000000000000000000000..af3c05ee7d9f3ce6898171c9f367d0d035212814
--- /dev/null
+++ b/source_code/version2.2_windows/soil_cn.f
@@ -0,0 +1,945 @@
+!*****************************************************************!
+!* *!
+!* 4C (FORESEE) Simulation Model *!
+!* *!
+!* *!
+!* Subroutines for: *!
+!* SOIL_C/N - Programs *!
+!* *!
+!* Author: F. Suckow *!
+!* *!
+!* contains: *!
+!* SOIL_CN *!
+!* F_CNV(Cpool, Npool) *!
+!* RMIN_T(temp) *!
+!* RNIT_T(temp) *!
+!* RMIN_W(water, xpv) *!
+!* RNIT_W(water, xpv) *!
+!* RMIN_P(phv) *!
+!* RNIT_P(phv) *!
+!* HUMLAY *!
+!* DECOMP1(Copm, Nopm, cnv, kopm, ksyn, hdiff) *!
+!* DECOMP2(Copm, Nopm, cnv, kopm, ksyn, hdiff) *!
+!* MINLAY(jlay) *!
+!* N_LEACH(jlay, NH4l, NO3l) *!
+!* S_RESP(Copm_1, Chum_1) *!
+!* *!
+!* 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 soil_cn
+
+! Soil C-N budget
+
+use data_climate
+use data_out
+use data_simul
+use data_soil
+use data_soil_cn
+use data_stand
+
+implicit none
+
+integer j, hnlay, ntr
+real Copm_1, Chum_1 ! previous C-content of soil profile
+real Nopm_1, Nhum_1 ! previous N-content of soil profile
+real Cbc_1, Nbc_1 ! previous C- and N-content of biochar
+real Nmin1, N_min_h
+type(Coh_Obj), pointer :: p ! pointer to cohort list
+
+! save previous state of soil C-content
+Copm_1 = SUM(C_opm) + C_opm_stem
+Chum_1 = SUM(C_hum)
+Nopm_1 = SUM(N_opm) + N_opm_stem
+Nhum_1 = SUM(N_hum)
+N_min_h= N_min
+if (flag_bc .gt. 0) then
+ Cbc_1 = SUM(C_bc)
+ Nbc_1 = SUM(N_bc)
+else
+ Cbc_1 = 0.
+ Nbc_1 = 0.
+endif
+
+call humlay ! humus layer
+
+! loop over mineral layers
+do j=2,nlay
+ call minlay(j)
+enddo ! loop over j (nlay)
+
+! soil respiration
+call s_resp(Copm_1, Chum_1, Cbc_1)
+
+! daily values
+Nleach = NH4_in + NO3_in
+Nupt_d = SUM(Nupt)
+N_an_tot = SUM(NH4) + SUM(NO3)
+Nmin1 = Nopm_1 + Nhum_1 - SUM(N_opm) - SUM(N_hum)
+if (flag_bc .gt. 0) then
+ Nmin1 = Nmin1 + Nbc_1 - SUM(N_bc)
+endif
+
+! yearly cumul. quantities
+Nleach_c = Nleach_c + Nleach
+Nupt_c = Nupt_c + Nupt_d
+resps_c = resps_c + respsoil
+
+p => pt%first
+do while (associated(p))
+ ns = p%coh%species
+ ns = p%coh%species
+ ntr = p%coh%ntreea
+ svar(ns)%Ndem = svar(ns)%Ndem + ntr * p%coh%Ndemc_d
+ svar(ns)%Nupt = svar(ns)%Nupt + ntr * p%coh%Nuptc_d
+
+ p%coh%Nuptc_c = p%coh%Nuptc_c + p%coh%Nuptc_d
+ p%coh%Ndemc_c = p%coh%Ndemc_c + p%coh%Ndemc_d
+ p%coh%N_pool = p%coh%N_pool + p%coh%Nuptc_d
+
+ p => p%next
+enddo ! p (cohorts)
+
+if (flag_dayout .ge. 2) then
+ if (nlay .gt. 6) then
+ hnlay = 6
+
+ else
+ hnlay = nlay
+ endif
+
+ N_min_h = N_min - N_min_h
+ write (unit_soicna, '(A)') ''
+ write (unit_soicnd, '(A)') ''
+endif
+
+1000 FORMAT (2I5, 6F10.3, 6F10.1)
+1100 FORMAT (2I5, 12F10.3)
+1200 FORMAT (2I5, 4F10.3, 4F10.1, F10.2)
+
+END subroutine soil_cn
+
+!**************************************************************
+
+real FUNCTION f_cnv(Cpool, Npool)
+
+! C/N-ratio of a pool
+! implicit none
+
+real Cpool, Npool
+
+ if (Npool .lt. 1e-6) then
+ f_cnv = 0.
+ else
+ f_cnv = Cpool / Npool
+ endif
+
+END function f_cnv
+
+!**************************************************************
+
+real FUNCTION rmin_t(temp, rkind)
+
+! reduction of mineralization depending on soil temperature
+use data_simul
+implicit none
+
+integer rkind
+real temp, toptm, Q10
+
+select case (rkind)
+
+case(1)
+ toptm = 35.
+ Q10 = 2.9
+ rmin_t = exp(log(Q10) * ((temp-toptm)/10.)) ! Stanford
+
+case(2)
+ toptm = 35.
+ Q10 = 2.9
+ rmin_t = Q10**((temp-toptm)*0.1) ! van't Hoff
+
+case(4)
+ rmin_t = 1.
+
+case default
+ toptm = 35.
+ Q10 = 2.9
+ rmin_t = exp(log(Q10) * ((temp-toptm)/10.)) ! Stanford
+
+end select
+
+END function rmin_t
+
+!**************************************************************
+
+real FUNCTION rnit_t(temp, rkind)
+
+! reduction of nitrification depending on soil temperature
+
+implicit none
+
+integer rkind
+real temp, toptn, Q10
+
+select case (rkind)
+
+case(1) ! Stanford
+ toptn = 30.
+ Q10 = 2.8
+ rnit_t = exp(log(Q10) * ((temp-toptn)/10.))
+
+case(2) ! van't Hoff
+ toptn = 30.
+ Q10 = 2.8
+ rnit_t = Q10**((temp-toptn)*0.1) ! van't Hoff
+
+case(3) ! SWAT-approach; Nitrif. only above 5°C
+ if (temp .gt. 5.) then
+ rnit_t = 0.041 *(temp-5.)
+ else
+ rnit_t = 0.
+ endif
+
+case(4)
+ rnit_t = 1.
+
+case default
+ toptn = 30.
+ Q10 = 2.8
+ rnit_t = exp(log(Q10) * ((temp-toptn)/10.)) ! Stanford
+
+end select
+
+
+END function rnit_t
+
+!**************************************************************
+
+real FUNCTION rmin_w(water, xpv)
+
+! reduction of mineralization depending on soil water content
+! xpv - pore volume
+
+ rmin_w = 4.0 * water * (1.0-water/xpv) / xpv
+if (rmin_w .lt. 0.) rmin_w = 0.
+
+END function rmin_w
+
+!**************************************************************
+
+real FUNCTION rnit_w(water, xpv, xfk, xwp, rkind)
+
+! reduction of nitrification depending on soil water content
+! xpv - pore volume
+
+implicit none
+
+integer rkind
+real water, xpv, xfk, xwp, nfk, avwat
+
+select case (rkind)
+
+case(1) ! Franco
+ if (water .lt. 0.9*xpv) then
+ rnit_w = 4.0 * water * (1.0-water/xpv) / xpv
+ else
+ rnit_w = 1.
+ endif
+ if (rnit_w .lt. 0.) rnit_w = 0.
+
+case(2) ! SWAT-Ansatz
+ nfk = xfk - xwp
+ avwat = water - xwp
+ if (avwat .lt. 0.25*nfk) then
+ rnit_w = avwat / 0.25 * nfk
+ else
+ rnit_w = 1.
+ endif
+
+case default
+ if (water .lt. 0.9*xpv) then
+ rnit_w = 4.0 * water * (1.0-water/xpv) / xpv
+ else
+ rnit_w = 1.
+ endif
+ if (rnit_w .lt. 0.) rnit_w = 0.
+
+end select
+
+END function rnit_w
+
+!**************************************************************
+
+
+real FUNCTION rmin_p(phv)
+
+! reduction of mineralization depending on pH-value
+real, dimension(4) :: a = (/2.5, 4.0, 5.0, 8.0/), &
+ b = (/0.5, 0.8, 1.0, 1.0/)
+
+call tab_int(a,b,4,phv,value)
+rmin_p = value
+
+END function rmin_p
+
+!**************************************************************
+
+
+real FUNCTION rnit_p(phv)
+
+! reduction of nitrification depending on pH-value
+real, dimension(4) :: a = (/2.5, 4.0, 6.0, 8.0/), &
+ b = (/0.1, 0.3, 1.0, 1.0/)
+
+call tab_int(a,b,4,phv,value)
+rnit_p = value
+
+END function rnit_p
+
+!**************************************************************
+
+SUBROUTINE humlay
+
+! C-N budget of the humus layer
+! (including litter layer)
+use data_climate
+use data_depo
+use data_inter
+use data_out
+use data_simul
+use data_soil
+use data_soil_cn
+use help_soil_cn
+use data_species
+
+implicit none
+
+integer, parameter:: double_prec = kind(0.0D0)
+integer i
+real (kind = double_prec):: N_hum_1, NH4_1, NO3_1 ! previous state of C- and N-pools
+real (kind = double_prec):: N_hum_2, NH4_2, NO3_2 ! actual state of C- and N-pools
+real (kind = double_prec):: hnh4, hno3, bilanz, hnhum, hncopm, nh4diff, nhdiff, hdiff, s_hdiff
+real (kind = double_prec):: renit ! reduction function of nitrif.
+real (kind = double_prec):: redtermc, redtermn ! red. terms of C-/ N-pools
+real Copm, Nopm, hcnv, hcnv_bc, kopm, redopm, Nminl, Nmin1, redbc
+logical ldecomp
+real, external :: rmin_t, rmin_w, rnit_t, rnit_w, f_cnv
+type (species_litter) :: sliti
+
+if (flag_dayout .ge. 2) then
+ write (unit_soicnr, '(2I5,3E12.3)') time_cur, iday, rmin_t(temps(1), kmint), rmin_w(wats(1), pv(1)), rmin_phv(1)
+endif
+
+! reduction factors of mineralization and nitrification
+remin = rmin_t(temps(1), kmint) * rmin_w(wats(1), pv(1)) * rmin_phv(1)
+renit = rnit_t(temps(1), knitt) * rnit_w(wats(1), pv(1), field_cap(1), wilt_p(1), knitw) * rnit_phv(1)
+
+! add deposition
+if (flag_depo .eq. 2) then
+ NH_dep = NH_dep * prec_stand ! conversion g/l in g/m2
+ NO_dep = NO_dep * prec_stand
+endif
+NH4(1) = NH4(1) + NH_dep
+NO3(1) = NO3(1) + NO_dep
+
+Ndep_cum = Ndep_cum + NO_dep + NH_dep
+
+! store state of previous step
+N_hum_1 = N_hum(1)
+NH4_1 = NH4(1)
+NO3_1 = NO3(1)
+
+khr = k_hum * remin
+hexph = exp(-khr)
+knr = k_nit * renit
+if (abs(knr-khr) .le. 1E-6) knr = knr + 1E-6
+hexpn = exp(-knr)
+
+! reduction of C- and N-humus-pool by mineralization,
+redtermc = C_hum(1) * hexph ! part of equation II
+redtermn = N_hum_1 * hexph ! -"-
+
+! NH4-pool
+if (NH4_1 .gt. 1E-6) then
+ term1 = NH4_1 * hexpn ! part of equ. III
+else
+ term1 = NH4_1
+endif
+term3 = N_hum_1 * khr * (hexph-hexpn) / (knr-khr)
+
+if (cnv_hum(1) .lt. 1e-8) cnv_hum(1) = 20.
+cnvh = 1./cnv_hum(1)
+redopm = 1.
+redbc = 1.
+slit_1 = slit
+ldecomp = .TRUE.
+do while (ldecomp)
+
+ ! Decomposition of dead biomass
+ Copm = 0.
+ Nopm = 0.
+ C_opm_stem = 0.
+ N_opm_stem = 0.
+
+ reptermc = 0.
+ reptermn = 0.
+ term2 = 0.
+ term4 = 0.
+
+ s_hdiff = 0.
+ ! Decomposition of dead biomass fractions
+ do i=1,nspecies
+ sliti = slit_1(i)
+ hdiff = 0.
+
+ if (sliti%C_opm_fol .gt. 1e-8) then
+ kopm = redopm * spar(i)%k_opm_fol
+ if (kopm .ge. 1e-8) then
+ sliti%cnv_opm_fol = f_cnv(sliti%C_opm_fol, sliti%N_opm_fol)
+ call decomp1(sliti%C_opm_fol, sliti%N_opm_fol, sliti%cnv_opm_fol, &
+ kopm, spar(i)%k_syn_fol, hdiff)
+ s_hdiff = s_hdiff + hdiff
+ endif
+ endif
+
+ if (sliti%C_opm_frt(1) .gt. 1e-8) then
+ kopm = redopm * spar(i)%k_opm_frt
+ if (kopm .ge. 1e-8) then
+ sliti%cnv_opm_frt = f_cnv(sliti%C_opm_frt(1), sliti%N_opm_frt(1))
+ call decomp1(sliti%C_opm_frt(1), sliti%N_opm_frt(1), sliti%cnv_opm_frt, &
+ kopm, spar(i)%k_syn_frt, hdiff)
+ s_hdiff = s_hdiff + hdiff
+ endif
+ endif
+
+ if (sliti%C_opm_tb .gt. 1e-8) then
+ kopm = redopm * spar(i)%k_opm_tb
+ if (kopm .ge. 1e-8) then
+ sliti%cnv_opm_tb = f_cnv(sliti%C_opm_tb, sliti%N_opm_tb)
+ call decomp1(sliti%C_opm_tb, sliti%N_opm_tb, sliti%cnv_opm_tb, &
+ kopm, spar(i)%k_syn_tb, hdiff)
+ s_hdiff = s_hdiff + hdiff
+ endif
+ endif
+
+ select case (flag_decomp)
+ case (0, 10, 20, 30, 40)
+ if (sliti%C_opm_crt(1) .gt. 1e-8) then
+ kopm = redopm * spar(i)%k_opm_crt
+ if (kopm .ge. 1e-8) then
+ sliti%cnv_opm_crt = f_cnv(sliti%C_opm_crt(1), sliti%N_opm_crt(1))
+ call decomp1(sliti%C_opm_crt(1), sliti%N_opm_crt(1), sliti%cnv_opm_crt, &
+ kopm, spar(i)%k_syn_crt, hdiff)
+ s_hdiff = s_hdiff + hdiff
+ endif
+ endif
+
+ if (sliti%C_opm_stem .gt. 1e-8) then
+ kopm = redopm * spar(i)%k_opm_stem
+ if (kopm .ge. 1e-8) then
+ sliti%cnv_opm_stem = f_cnv(sliti%C_opm_stem, sliti%N_opm_stem)
+ call decomp1(sliti%C_opm_stem, sliti%N_opm_stem, sliti%cnv_opm_stem, &
+ kopm, spar(i)%k_syn_stem, hdiff)
+ s_hdiff = s_hdiff + hdiff
+ endif
+ endif
+
+ case (1, 11, 21, 31, 41)
+ if (sliti%C_opm_crt(1) .gt. 1e-8) then
+ kopm = redopm * spar(i)%k_opm_crt
+ if (kopm .ge. 1e-8) then
+ sliti%cnv_opm_crt = f_cnv(sliti%C_opm_crt(1), sliti%N_opm_crt(1))
+ call decomp2(sliti%C_opm_crt(1), sliti%N_opm_crt(1), sliti%cnv_opm_crt, &
+ kopm, spar(i)%k_syn_crt, hdiff)
+ s_hdiff = s_hdiff + hdiff
+ endif
+ endif
+
+ if (sliti%C_opm_stem .gt. 1e-8) then
+ kopm = redopm * spar(i)%k_opm_stem
+ if (kopm .ge. 1e-8) then
+ sliti%cnv_opm_stem = f_cnv(sliti%C_opm_stem, sliti%N_opm_stem)
+ call decomp2(sliti%C_opm_stem, sliti%N_opm_stem, sliti%cnv_opm_stem, &
+ kopm, spar(i)%k_syn_stem, hdiff)
+ s_hdiff = s_hdiff + hdiff
+ endif
+ endif
+
+ end select
+
+ ! pools of dead biomass without stems
+ Copm = Copm + sliti%C_opm_fol + sliti%C_opm_frt(1) + sliti%C_opm_crt(1) + sliti%C_opm_tb
+ Nopm = Nopm + sliti%N_opm_fol + sliti%N_opm_frt(1) + sliti%N_opm_crt(1) + sliti%N_opm_tb
+
+ ! dead stems
+ C_opm_stem = C_opm_stem + sliti%C_opm_stem
+ N_opm_stem = N_opm_stem + sliti%N_opm_stem
+
+ slit(i) = sliti
+
+ enddo
+
+! Decomposition of biochar
+ if (flag_bc .gt. 0) then
+ if (C_bc(1) .gt. 1e-8) then
+ kbc = redbc * k_bc
+ if (kbc .ge. 1e-8) then
+ hcnv_bc = f_cnv(C_bc(1), N_bc(1))
+ call decomp1(C_bc(1), N_bc(1), hcnv_bc, kbc, k_syn_bc, hdiff)
+ s_hdiff = s_hdiff + hdiff
+ endif
+ endif
+ endif
+
+
+ ldecomp = .FALSE.
+
+ C_opm(1) = Copm
+ N_opm(1) = Nopm
+
+! C- and N-humus-pool: reduction by mineralization, supply by turnover of organic primary matter
+ C_hum(1) = redtermc + reptermc
+ N_hum_2 = redtermn + reptermn
+ N_hum(1) = N_hum_2
+
+! ammonium pool
+ hnh4 = term1 + term2 + term3 + khr/(knr-khr) * term4
+ NH4(1) = hnh4
+ nhdiff = N_hum_1 - N_hum_2
+ nh4diff = NH4_1 - NH4(1)
+ Nminl = hnh4 - NH4_1 - NO3(1) ! daily net min.
+
+! nitrat pool from balance
+ hno3 = NO3_1 + s_hdiff + nhdiff + nh4diff
+ NO3(1) = hno3
+
+ if (hnh4 .lt. 0.0 .or. hno3 .lt. 0.0) then
+ redopm = 0.9 * redopm
+ if (redopm .ge. 1E-8) then
+ ldecomp = .TRUE.
+ else
+ if (NH4(1) .lt. 1E-10) NH4(1) = 0.
+ if (NO3(1) .lt. 1E-10) NO3(1) = 0.
+ endif
+ endif
+
+ Nminl = Nminl + NO3(1) ! daily net min. per layer
+enddo ! ldecomp
+
+Nmin(1) = Nminl
+N_min = N_min + Nminl ! cumul. yearly net min.
+
+call n_leach(1) ! without balance
+
+! new balance after leaching
+NH4(1) = NH4(1) - NH4_in
+NO3(1) = NO3(1) - NO3_in
+
+call n_upt(1) ! with balance
+
+if (flag_dayout .ge. 2) then
+ write (unit_soicna, '(2I5,E12.3)', advance='no') time_cur, iday, remin
+ write (unit_soicnd, '(2I5,E12.3)', advance='no') time_cur, iday, Nminl
+endif
+
+END subroutine humlay
+
+!**************************************************************
+
+SUBROUTINE decomp1(Copm, Nopm, cnv, kopm, ksyn, hdiff)
+
+! Decomposition of dead biomass fractions per species
+
+use help_soil_cn
+
+implicit none
+
+integer, parameter:: double_prec = kind(0.0D0)
+real Copm, Nopm ! C- and N-pool of primary organic matter fraction
+real kopm, ksyn ! mineralisation and synthesis coeff. of opm-fraction
+real kor ! reduced mineralisation coeff. of opm-fraction
+real N_opm_1, C_opm_1 ! previous state of C- and N-pools
+real hexpo ! exponential part
+real cnv ! C/N-ratio of opm-fraction
+real exterm
+real (kind = double_prec):: hdiff
+real gamma
+
+ ! store state of previous step
+ C_opm_1 = Copm
+ N_opm_1 = Nopm
+
+ kor = kopm * remin ! reduction of miner. coeff.
+ ! avoid denominators near zero
+ if (abs(kor-khr) .lt. 1E-6) kor = kor + 1E-6
+ if (abs(kor-knr) .lt. 1E-6) kor = kor + 1E-6
+ hexpo = exp(-kor)
+ Copm = C_opm_1 * hexpo ! equations II
+ Nopm = N_opm_1 * hexpo ! -"-
+
+ ! reproduction of C- and N-humus-pool by turnover of organic primary matter
+ exterm = hexph - hexpo
+ gamma = cnv * cnvh
+
+ if (abs(kor-khr) .gt. 1E-6) then
+ reptermc = reptermc + C_opm_1 * ksyn * kor * exterm / (kor-khr) ! part of equ. II
+ reptermn = reptermn + N_opm_1 * gamma*ksyn * kor * exterm / (kor-khr) ! part of equ. II
+ endif
+
+ ! change of ammonium pool
+ if (abs(kor-knr) .gt. 1E-6) then
+ term2 = term2 + (1.-gamma*ksyn)*kor * N_opm_1 * (hexpn - hexpo) / (kor - knr) ! part of equ. III
+ endif
+ if ((abs(kor-khr) .gt. 1E-6) .and. (abs(kor-knr) .gt. 1E-6)) then
+ term4 = term4 + gamma*ksyn*kor * N_opm_1 & ! part of equ. III
+ * ((kor-khr) * hexpn + (knr-kor) * hexph + (khr-knr) * hexpo) &
+ / ((khr - kor) * (kor - knr))
+ endif
+
+ hdiff = N_opm_1 - Nopm ! N-change rate in organic primary matter
+
+END subroutine decomp1
+
+!**************************************************************
+
+SUBROUTINE decomp2(Copm, Nopm, cnv, kopm, ksyn, hdiffn)
+
+! Decomposition of dead stem biomass per species
+
+use help_soil_cn
+
+implicit none
+
+integer, parameter:: double_prec = kind(0.0D0)
+real Copm, Nopm ! C- and N-pool of primary organic matter fraction
+real kopm, ksyn ! mineralisation and synthesis coeff. of opm-fraction
+real kor ! reduced mineralisation coeff. of opm-fraction
+real N_opm_1, C_opm_1 ! previous state of C- and N-pools
+real hexpo ! exponential part
+real cnv ! C/N-ratio of opm-fraction
+real (kind = double_prec):: hdiffn, hdiffc
+
+ ! store state of previous step
+ C_opm_1 = Copm
+ N_opm_1 = Nopm
+
+ kor = kopm * remin ! reduction of miner. coeff.
+! avoid denominators near zero
+ if (abs(kor) .lt. 1E-6) kor = kor + 1E-6
+ hexpo = exp(-kor)
+ Copm = C_opm_1 * hexpo ! equations II
+ Nopm = N_opm_1 * hexpo ! -"-
+
+ ! reproduction of C- and N-humus-pool by turnover of organic primary matter
+ hdiffn = N_opm_1 - Nopm ! N-change rate in organic primary matter
+ hdiffc = hdiffn / cnvh
+ reptermn = reptermn + hdiffn
+ reptermc = reptermc + hdiffc
+
+END subroutine decomp2
+
+!**************************************************************
+
+SUBROUTINE minlay(jlay)
+
+! C-N budget of a mineral layer
+
+use data_climate
+use data_out
+use data_simul
+use data_soil
+use data_soil_cn
+use help_soil_cn
+use data_species
+
+implicit none
+
+! input:
+integer jlay ! number of actual layer
+
+!------------------------------------------------------------
+
+integer, parameter:: double_prec = kind(0.0D0)
+integer i
+real (kind = double_prec):: N_hum_1, NH4_1, NO3_1 ! previous state of C- and N-pools
+real (kind = double_prec):: hnh4, hno3, bilanz, hnhum, hncopm, nh4diff, nhdiff, hdiff, s_hdiff
+real (kind = double_prec):: renit ! reduction function of nitrif.
+real (kind = double_prec):: redtermc, redtermn ! red. terms of C-/ N-pools
+real Copm, Nopm, hcnv, hcnv_bc, kopm, redopm, Nminl, Nmin1, redbc
+real, dimension(nspecies):: Copm_frt_1, Nopm_frt_1, Copm_crt_1, Nopm_crt_1
+logical ldecomp
+real, external :: rmin_t, rmin_w, rnit_t, rnit_w, f_cnv
+
+! reduction factors of mineralization and nitrification
+remin = rmin_t(temps(jlay), kmint) * rmin_w(wats(jlay), pv(jlay)) * rmin_phv(jlay)
+renit = rnit_t(temps(jlay), knitt) * rnit_phv(jlay) * &
+ rnit_w(wats(jlay), pv(jlay), field_cap(jlay), wilt_p(jlay), knitw)
+
+if (flag_dayout .eq. 3) then
+ write (1122, *) 'minlay ', iday, jlay
+endif
+
+! add N transport from above layer
+NH4(jlay) = NH4(jlay) + NH4_in
+NO3(jlay) = NO3(jlay) + NO3_in
+
+! store state of previous step
+N_hum_1 = N_hum(jlay)
+NH4_1 = NH4(jlay)
+NO3_1 = NO3(jlay)
+Nopm_frt_1 = slit%N_opm_frt(jlay)
+Copm_frt_1 = slit%C_opm_frt(jlay)
+Nopm_crt_1 = slit%N_opm_crt(jlay)
+Copm_crt_1 = slit%C_opm_crt(jlay)
+redopm = 1.
+redbc = 1.
+
+khr = k_hum_r * remin
+hexph = exp(-khr)
+knr = k_nit * renit
+if (abs(knr-khr) .le. 1E-6) knr = knr + 1E-6
+hexpn = exp(-knr)
+
+! reduction of C- and N-humus-pool by mineralization,
+redtermc = C_hum(jlay) * hexph ! part of equation II
+redtermn = N_hum_1 * hexph ! -"-
+
+! NH4-pool
+term1 = NH4_1 * hexpn ! part of equ. III
+term3 = N_hum_1 * khr * (hexph-hexpn) / (knr-khr)
+
+if (cnv_hum(jlay) .lt. 1e-8) then
+ if (cnv_hum(jlay-1) .ge. 1e-8) then
+ cnv_hum(jlay) = cnv_hum(jlay-1)
+ else
+ cnv_hum(jlay) = 20.
+ endif
+endif
+cnvh = 1./cnv_hum(jlay)
+
+ldecomp = .TRUE.
+do while (ldecomp)
+ ! Decomposition of dead biomass
+ reptermc = 0.
+ reptermn = 0.
+ term2 = 0.
+ term4 = 0.
+ s_hdiff = 0.
+ do i=1,nspecies
+ Nopm = Nopm_frt_1(i)
+ kopm = redopm * spar(i)%k_opm_frt
+ if (Nopm .ge. 1e-8 .and. kopm .ge. 1e-8) then
+ Copm = Copm_frt_1(i)
+ hcnv = f_cnv(Copm, Nopm)
+ if ((time .eq.1) .and. (jlay .gt. 155)) then
+ endif
+ call decomp1(Copm, Nopm, hcnv, kopm, spar(i)%k_syn_frt, hdiff)
+
+ slit(i)%C_opm_frt(jlay) = Copm
+ slit(i)%N_opm_frt(jlay) = Nopm
+ cnv_opm(jlay) = hcnv
+ else
+ hdiff = 0.
+ endif ! Nopm
+ s_hdiff = s_hdiff + hdiff
+
+ Nopm = Nopm_crt_1(i)
+ kopm = redopm * spar(i)%k_opm_crt
+ if (Nopm .ge. 1e-8 .and. kopm .ge. 1e-8) then
+ Copm = Copm_crt_1(i)
+ hcnv = f_cnv(Copm, Nopm)
+ if ((time .eq.1) .and. (jlay .gt. 155)) then
+ endif
+ select case (flag_decomp)
+ case (0, 10, 20, 30, 40)
+ call decomp1(Copm, Nopm, hcnv, kopm, spar(i)%k_syn_crt, hdiff)
+
+ case (1, 11, 21, 31, 41)
+ call decomp2(Copm, Nopm, hcnv, kopm, spar(i)%k_syn_crt, hdiff)
+ end select
+ slit(i)%C_opm_crt(jlay) = Copm
+ slit(i)%N_opm_crt(jlay) = Nopm
+ cnv_opm(jlay) = hcnv
+ else
+ hdiff = 0.
+ endif ! Nopm
+ s_hdiff = s_hdiff + hdiff
+
+ enddo ! nspecies
+
+ ! Decomposition of biochar
+ if (flag_bc .gt. 0) then
+ if (C_bc(jlay) .gt. 1e-8) then
+ kbc = redbc * k_bc
+ if (kbc .ge. 1e-8) then
+ hcnv_bc = f_cnv(C_bc(jlay), N_bc(jlay))
+ call decomp1(C_bc(jlay), N_bc(jlay), hcnv_bc, kbc, k_syn_bc, hdiff)
+ s_hdiff = s_hdiff + hdiff
+ endif
+ endif
+ endif
+
+ ldecomp = .FALSE.
+
+ C_opm(jlay) = SUM(slit%C_opm_frt(jlay)) + SUM(slit%C_opm_crt(jlay))
+ N_opm(jlay) = SUM(slit%N_opm_frt(jlay)) + SUM(slit%N_opm_crt(jlay))
+
+ ! C- and N-humus-pool: reduction by mineralization,
+ ! supply by turnover of organic primary matter
+ C_hum(jlay) = redtermc + reptermc
+ hnhum = redtermn + reptermn
+ N_hum(jlay) = hnhum
+
+ ! ammonium pool
+ hnh4 = term1 + term2 + term3 + khr/(knr-khr) * term4
+ NH4(jlay) = hnh4
+ nhdiff = N_hum_1 - N_hum(jlay)
+ nh4diff = NH4_1 - NH4(jlay)
+ bilanz = NO3(jlay) + s_hdiff &
+ + nhdiff + nh4diff
+ Nminl = NH4(jlay) - NH4_1 - NO3(jlay) ! daily net min.
+
+ ! nitrate pool from balance
+ hno3 = NO3_1 + s_hdiff + nhdiff + nh4diff
+ NO3(jlay) = hno3
+
+ if (hnh4 .lt. 0.0 .or. hno3 .lt. 0.0) then
+ redopm = 0.9 * redopm
+ if (redopm .ge. 1E-8) then
+ ldecomp = .TRUE.
+ else
+ if (NH4(jlay) .lt. 1E-10) NH4(jlay) = 0.
+ if (NO3(jlay) .lt. 1E-10) NO3(jlay) = 0.
+ endif
+ endif
+
+ Nminl = Nminl + NO3(jlay) ! daily net min. per layer
+ bilanz = bilanz - NO3(jlay)
+enddo ! ldecomp
+
+Nmin(jlay) = Nminl
+N_min = N_min + Nminl ! cumul. yearly net min.
+
+call n_leach(jlay) ! without balance
+
+! new balance after leaching
+NH4(jlay) = NH4(jlay) - NH4_in
+NO3(jlay) = NO3(jlay) - NO3_in
+
+call n_upt(jlay) ! with balance
+
+if (flag_dayout .ge. 2) then
+ write (unit_soicna, '(E12.3)', advance='no') remin
+ write (unit_soicnd, '(E12.3)', advance='no') Nminl
+endif
+
+END subroutine minlay
+
+!**************************************************************
+
+SUBROUTINE n_leach(jlay)
+
+! N leaching and new balance
+! Addition of deposition to the anorganic pools
+
+use data_climate
+use data_simul
+use data_soil
+use data_soil_cn
+use help_soil_cn
+use data_species
+
+implicit none
+
+! input:
+integer jlay ! number of actual layer
+
+!-----------------------------------------------------------
+
+real NH4f, NO3f ! free available NH4-, NO3-N
+real perc_w ! relative part of percolated water
+
+! NH4 and NO3 partly fixed
+
+if (NH4(jlay) .lt. 1E-25) then
+continue
+endif
+
+NH4f = NH4(jlay) * pNH4f
+NO3f = NO3(jlay) * pNO3f
+
+! relative part of percolated water
+perc_w = perc(jlay) / (wats(jlay) + perc(jlay) + wupt_r(jlay) + wupt_ev(jlay))
+
+! N transport
+NH4_in = NH4f * perc_w
+NO3_in = NO3f * perc_w
+
+END subroutine n_leach
+
+!**************************************************************
+
+
+SUBROUTINE s_resp(Copm_1, Chum_1, Cbc_1)
+
+! Estimation of soil respiration
+
+use data_climate
+use data_simul
+use data_soil
+use data_soil_cn
+use help_soil_cn
+use data_species
+
+implicit none
+
+! input:
+real Copm_1, Chum_1, Cbc_1 ! previous C-content of soil profile
+real Sum_C_opm, Sum_C_hum, Sum_C_bc
+
+!-----------------------------------------------------------
+
+Sum_C_opm = SUM(C_opm) + C_opm_stem
+Sum_C_hum = SUM(C_hum)
+respsoil = Copm_1 + Chum_1 - Sum_C_opm - Sum_C_hum
+if (flag_bc .gt. 0) then
+ Sum_C_bc = SUM(C_bc)
+ respsoil = respsoil + Cbc_1 - Sum_C_bc
+endif
+
+END subroutine s_resp
+
+!**************************************************************
+
+SUBROUTINE s
+
+!
+
+use data_climate
+use data_simul
+use data_soil
+use data_soil_cn
+use help_soil_cn
+use data_species
+
+implicit none
+
+
+END subroutine s
+
+!**************************************************************
+
+
+
+
+
+
diff --git a/source_code/version2.2_windows/soil_cn_link.f b/source_code/version2.2_windows/soil_cn_link.f
new file mode 100755
index 0000000000000000000000000000000000000000..b8ed84868ed68b0b850ceccba4e074c3f1bd4b26
--- /dev/null
+++ b/source_code/version2.2_windows/soil_cn_link.f
@@ -0,0 +1,655 @@
+!*****************************************************************!
+!* *!
+!* 4C (FORESEE) Simulation Model *!
+!* *!
+!* *!
+!* Subroutines for: *!
+!* linking SOIL_C/N - Programs with forest module *!
+!* *!
+!* Author: F. Suckow *!
+!* *!
+!* contains: *!
+!* S_CN_INI *!
+!* S_CN_GENER *!
+!* CN_INP *!
+!* N_UPT(jlay) *!
+!* READ_LITTER_INPUT *!
+!* *!
+!* 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 s_cn_ini
+
+! Initialisation of soil data and parameters for C/N-module
+
+use data_simul
+use data_soil
+use data_soil_cn
+use data_species
+use data_stand
+
+implicit none
+
+integer i, j
+type (species_litter) :: sliti
+real, external :: f_cnv, rmin_p, rnit_p
+real :: xx, xcnv
+
+! turnover biochar
+k_bc = 0.00005
+k_syn_bc =0.03
+
+do j = 1, nlay
+ if (C_hum(j) .lt.0.) then
+ if (.not.flag_mult8910) call error_mess(time, 'missing value of C_hum set to 0.0 in layer ', real(j))
+ C_hum(j) = 0.0
+ endif
+ if (N_hum(j) .lt.0.) then
+ if (.not.flag_mult8910) call error_mess(time, 'missing value of N_hum set to 0.0 in layer ', real(j))
+ N_hum(j) = 0.0
+ endif
+enddo
+
+!!! zum Test ohne Primaersubstanz !!!
+C_opm = 0.
+N_opm = 0.
+
+!!! zum Test ohne Primaersubstanz !!!
+call s_cn_gener
+
+! Convert concentration (mg/l) into contents (g/m2) per layer
+NH4 = NH4 * 0.001 *wats
+NO3 = NO3 * 0.001 *wats
+
+
+if (flag_lit .eq. 0) then
+ ! to even out balance for generated values ==> new values for C_ / N_hum
+ do j = 1, nlay
+ xx = C_hum(j)
+ if (N_hum(j) .gt. 1E-6) then
+ xcnv = f_cnv(C_hum(j), N_hum(j))
+ if (xx .gt. C_opm(j)) then
+ C_hum(j) = xx - C_opm(j)
+ N_hum(j) = C_hum(j) / xcnv
+ endif
+ endif
+ enddo
+endif
+
+! reduction of mineralization and nitrification depending on pH
+do j=1,nlay
+ if (phv(j) .lt. 0) then
+ rmin_phv(j) = 1
+ rnit_phv(j) = 1
+ else
+ rmin_phv(j) = rmin_p(phv(j))
+ rnit_phv(j) = rnit_p(phv(j))
+ endif
+ cnv_opm(j) = f_cnv(C_opm(j), N_opm(j))
+ cnv_hum(j) = f_cnv(C_hum(j), N_hum(j))
+enddo
+
+call s_year ! calculate a year's values for start year as well
+wats(1) = field_cap(1) ! ensuring consistency, in case novel calculation was done in s_year
+
+! yearly cumulative quantities
+N_min = 0.
+N_lit = 0.
+C_lit = 0.
+C_accu = C_tot
+Nleach_c = 0.
+Nupt_c = 0.
+Nupt_d = 0.
+resps_c = 0.
+
+END subroutine s_cn_ini
+
+!**************************************************************
+
+SUBROUTINE s_cn_gener
+
+! Initialisation of soil data and parameters for C/N-module
+
+use data_par
+use data_simul
+use data_soil
+use data_soil_cn
+use data_species
+use data_stand
+
+implicit none
+
+integer i, j
+real dbm_c ! C content of dead biomass
+real dbm_frt ! C content of dead fine root biomass
+real dbm_part ! part of dead biomass of previous years
+real e_part ! part of dead biomass of one year
+real t_day
+real hconvd ! conversion factor kg/patchsize ==> g/m2
+real hconvda ! conversion in C content and from tree to cohort
+real, external :: f_cnv
+type (species_litter) :: sliti
+
+C_opm = 0.
+N_opm = 0.
+
+do i = 1, nspecies
+ if (i .eq. nspec_tree+2) then
+ continue
+ endif
+ sliti = slit(i)
+ sliti%species_name = spar(i)%species_name
+
+ if (flag_lit .eq. 0) then
+ sliti%C_opm_fol = 0.
+ sliti%C_opm_tb = 0.
+ sliti%C_opm_stem = 0.
+ sliti%C_opm_frt = 0.
+ sliti%C_opm_crt = 0.
+ endif
+
+ sliti%N_opm_fol = 0.
+ sliti%N_opm_tb = 0.
+ sliti%N_opm_stem = 0.
+ sliti%N_opm_frt = 0.
+ sliti%N_opm_crt = 0.
+
+ slit(i) = sliti
+
+enddo
+
+hconvd = 1000. / kpatchsize
+
+if (flag_lit .eq. 0) then
+ zeig => pt%first
+ do
+ if (.not. associated(zeig)) exit
+
+ i = zeig%coh%species
+ if (i .ne. nspec_tree+2) then ! no litter initialisation for Mistletoe
+ sliti = slit(i)
+ hconvda = cpart * zeig%coh%ntreea
+ ! consider decomposition rate, i.e. biomass of previous years
+ j = 1
+ t_day = 365.
+ dbm_part = 0.
+ do
+ ! consider dependency on temp. and water
+ e_part = exp (-spar(i)%k_opm_fol * 0.2 * j * t_day)
+ dbm_part = dbm_part + e_part
+ if (e_part .gt. 0.001) then
+ j = j+1
+ else
+ exit
+ endif
+ enddo
+ select case (flag_dis)
+ case (1)
+ zeig%coh%litC_fol = (spar(i)%psf * zeig%coh%x_fol+zeig%coh%x_fol_loss) * hconvda ! conversion in g/m2 first into subr. litter
+ case (0)
+ zeig%coh%litC_fol = spar(i)%psf * zeig%coh%x_fol * hconvda ! conversion in g/m2 first into subr. litter
+ end select
+
+ zeig%coh%litN_fol = zeig%coh%litC_fol * (1.-spar(i)%reallo_fol) / spar(i)%cnr_fol
+ dbm_c = dbm_part * zeig%coh%litC_fol * hconvd
+ sliti%C_opm_fol = sliti%C_opm_fol + dbm_c
+
+ !dead fine root biomass of humus layer
+ ! consider decomposition rate, i.e. biomass of previous years
+ j = 1
+ t_day = 365.
+ dbm_part = 0.
+ do
+ ! consider dependency on temp. and water
+ e_part = exp (-spar(i)%k_opm_frt * 0.2 * j * t_day)
+ dbm_part = dbm_part + e_part
+ if (e_part .gt. 0.001) then
+ j = j+1
+ else
+ exit
+ endif
+ enddo
+
+ ! change see foliage
+ select case (flag_dis)
+ case (1)
+ zeig%coh%litC_frt = (spar(i)%psr * zeig%coh%x_frt+zeig%coh%x_frt_loss) * hconvda ! conversion in g/m2 first into subr. litter
+ case (0)
+ zeig%coh%litC_frt = spar(i)%psr * zeig%coh%x_frt * hconvda ! conversion in g/m2 first into subr. litter
+ end select
+
+ zeig%coh%litN_frt = zeig%coh%litC_frt * (1.-spar(i)%reallo_frt) / spar(i)%cnr_frt
+ dbm_c = dbm_part * zeig%coh%litC_frt * hconvd * (1.-spar(i)%reallo_frt) / spar(i)%cnr_frt
+ dbm_frt = dbm_c * zeig%coh%frtrel(1)
+ sliti%C_opm_frt(1) = sliti%C_opm_frt(1) + dbm_frt
+ sliti%N_opm_frt(1) = sliti%N_opm_frt(1) + dbm_frt
+
+ ! Total fine root biomass must be distributed over all soil layers
+ do j = 2, nlay
+ dbm_frt = dbm_c * zeig%coh%frtrel(j)
+ sliti%C_opm_frt(j) = sliti%C_opm_frt(j) + dbm_frt
+ sliti%N_opm_frt(j) = sliti%N_opm_frt(j) + dbm_frt
+ enddo
+
+ slit(i) = sliti
+ endif ! (i .ne. nspec_tree+2)
+
+ zeig => zeig%next
+ enddo
+endif
+
+
+do i = 1, (nspec_tree+1) !exclusion of mistletoe
+ sliti = slit(i)
+
+ if (flag_lit .gt. 0) then
+ dbm_frt = sliti%C_opm_frt(1)
+ dbm_c = sliti%C_opm_crt(1)
+ do j = 1, nlay
+ sliti%C_opm_frt(j) = dbm_frt * root_fr(j)
+ sliti%N_opm_frt(j) = sliti%C_opm_frt(j) * (1.-spar(i)%reallo_frt) / spar(i)%cnr_frt
+ sliti%C_opm_crt(j) = dbm_c * root_fr(j)
+ enddo
+ endif
+
+ sliti%N_opm_fol = sliti%C_opm_fol * (1.-spar(i)%reallo_fol) / spar(i)%cnr_fol
+
+ ! pools of dead biomass without stems
+ C_opm(1) = C_opm(1) + sliti%C_opm_fol + sliti%C_opm_tb + sliti%C_opm_frt(1) + sliti%C_opm_crt(1)
+ N_opm(1) = N_opm(1) + sliti%N_opm_fol + sliti%N_opm_tb + sliti%N_opm_frt(1) + sliti%N_opm_crt(1)
+ slit(i) = sliti
+
+enddo
+
+do j=2,nlay
+ C_opm(j) = SUM(slit%C_opm_frt(j)) ! + SUM(slit%C_opm_crt(j))
+ N_opm(j) = SUM(slit%N_opm_frt(j)) ! + SUM(slit%N_opm_crt(j))
+ if (C_opm(j) < 0.) then
+ continue
+ endif
+enddo
+
+! Total OPM of all species
+
+END subroutine s_cn_gener
+
+!**************************************************************
+
+SUBROUTINE cn_inp
+
+! Input of dead biomass (all fractions) into soil C- and N-pools
+! call from simulation_4C
+
+use data_simul
+use data_par
+use data_soil
+use data_soil_cn
+use data_species
+use data_stand
+
+implicit none
+
+integer i, j
+real hconvd, hf, hc, hfc, hfn, hfrtc, hfrtn, hfc1, Copm, Nopm, Clitf, Nlitf
+type (species_litter) :: sliti
+real, external :: f_cnv
+
+Clitf = 0.
+Nlitf = 0.
+N_lit = 0.
+C_lit = 0.
+C_lit_fol = 0.
+N_lit_fol = 0.
+C_lit_frt = 0.
+N_lit_frt = 0.
+C_lit_crt = 0.
+N_lit_crt = 0.
+C_lit_tb = 0.
+N_lit_tb = 0.
+C_lit_stem = 0.
+N_lit_stem = 0.
+
+select case (flag_decomp)
+case (20,21)
+ if (time .gt. 0) call read_litter_input
+
+case(30,31)
+ continue
+
+case default
+ ! Input of litter into primary organic matter pools
+ ! litter: x kg/tree to g/m2 (n*x*1000g/(kPatchSize m2))
+ ! values are aggregated already as cohort
+ hconvd = 1000. / kpatchsize
+ zeig => pt%first
+ do while (associated(zeig))
+ ns = zeig%coh%species
+ sliti = slit(ns)
+
+ sliti%C_opm_fol = sliti%C_opm_fol + zeig%coh%litC_fol * hconvd
+ sliti%N_opm_fol = sliti%N_opm_fol + zeig%coh%litN_fol * hconvd
+
+ sliti%C_opm_stem = sliti%C_opm_stem + zeig%coh%litC_stem * hconvd
+ sliti%N_opm_stem = sliti%N_opm_stem + zeig%coh%litN_stem * hconvd
+
+ sliti%C_opm_tb = sliti%C_opm_tb + zeig%coh%litC_tb * hconvd
+ sliti%N_opm_tb = sliti%N_opm_tb + zeig%coh%litN_tb * hconvd
+
+ hfc = zeig%coh%litC_frt * hconvd
+ hfn = zeig%coh%litN_frt * hconvd
+ hfrtc = hconvd * zeig%coh%litC_crt
+ hfrtn = hconvd * zeig%coh%litN_crt
+
+ do i = 1,nroot_max
+ hfc1 = zeig%coh%frtrel(i)
+ sliti%C_opm_frt(i) = sliti%C_opm_frt(i) + hfc * hfc1
+ sliti%N_opm_frt(i) = sliti%N_opm_frt(i) + hfn * hfc1
+ sliti%C_opm_crt(i) = sliti%C_opm_crt(i) + hfrtc * hfc1
+ sliti%N_opm_crt(i) = sliti%N_opm_crt(i) + hfrtn * hfc1
+ enddo ! i (nroot_max)
+
+ C_lit_frt = C_lit_frt + zeig%coh%litC_frt
+ N_lit_frt = N_lit_frt + zeig%coh%litN_frt
+ C_lit_crt = C_lit_crt + zeig%coh%litC_crt
+ N_lit_crt = N_lit_crt + zeig%coh%litN_crt
+ C_lit_fol = C_lit_fol + zeig%coh%litC_fol
+ N_lit_fol = N_lit_fol + zeig%coh%litN_fol
+ C_lit_tb = C_lit_tb + zeig%coh%litC_tb
+ N_lit_tb = N_lit_tb + zeig%coh%litN_tb
+ C_lit_stem = C_lit_stem + zeig%coh%litC_stem
+ N_lit_stem = N_lit_stem + zeig%coh%litN_stem
+
+ slit(ns) = sliti
+ zeig => zeig%next
+ enddo ! show (cohorts)
+
+ do i = 1,nspec_tree
+ ! input of delayed litter fall from dead stems
+ slit(i)%C_opm_tb = slit(i)%C_opm_tb + dead_wood(i)%C_tb(1)
+ slit(i)%N_opm_tb = slit(i)%N_opm_tb + dead_wood(i)%N_tb(1)
+ slit(i)%C_opm_stem = slit(i)%C_opm_stem + dead_wood(i)%C_stem(1)
+ slit(i)%N_opm_stem = slit(i)%N_opm_stem + dead_wood(i)%N_stem(1)
+ C_lit_tb = C_lit_tb + dead_wood(i)%C_tb(1)
+ N_lit_tb = N_lit_tb + dead_wood(i)%N_tb(1)
+ C_lit_stem = C_lit_stem + dead_wood(i)%C_stem(1)
+ N_lit_stem = N_lit_stem + dead_wood(i)%N_stem(1)
+ enddo ! i (nspec_tree)
+
+ ! conversion g/m2/patch --> g/m2
+ C_lit_fol = C_lit_fol * hconvd
+ N_lit_fol = N_lit_fol * hconvd
+ C_lit_frt = C_lit_frt * hconvd
+ N_lit_frt = N_lit_frt * hconvd
+ C_lit_crt = C_lit_crt * hconvd
+ N_lit_crt = N_lit_crt * hconvd
+ C_lit_tb = C_lit_tb * hconvd
+ N_lit_tb = N_lit_tb * hconvd
+ C_lit_stem= C_lit_stem * hconvd
+ N_lit_stem= N_lit_stem * hconvd
+end select ! flag_decomp
+
+do j=1,nlay
+ cnv_opm(j) = f_cnv(C_opm(j), N_opm(j))
+ cnv_hum(j) = f_cnv(C_hum(j), N_hum(j))
+enddo
+
+ Clitf = C_lit_frt + C_lit_crt
+ Nlitf = N_lit_frt + N_lit_crt
+ C_lit = C_lit_fol + C_lit_tb + Clitf
+ N_lit = N_lit_fol + N_lit_tb + Nlitf
+ C_lit_m = C_lit + C_lit_m
+ N_lit_m = N_lit + N_lit_m
+
+ C_opm = 0.
+ N_opm = 0.
+ C_opm_stem = 0.
+ do i = 1,nspecies
+ C_opm(1) = C_opm(1) + slit(i)%C_opm_frt(1) + slit(i)%C_opm_crt(1) &
+ + slit(i)%C_opm_fol + slit(i)%C_opm_tb
+ N_opm(1) = N_opm(1) + slit(i)%N_opm_frt(1) + slit(i)%N_opm_crt(1) &
+ + slit(i)%N_opm_fol + slit(i)%N_opm_tb
+ C_opm_stem = C_opm_stem + slit(i)%C_opm_stem
+ do j = 2,nlay
+ C_opm(j) = C_opm(j) + slit(i)%C_opm_frt(j) + slit(i)%C_opm_crt(j)
+ N_opm(j) = N_opm(j) + slit(i)%N_opm_frt(j) + slit(i)%N_opm_crt(j)
+ enddo
+ enddo
+
+END subroutine cn_inp
+
+!**************************************************************
+
+SUBROUTINE read_litter_input
+
+! Reading of litter input data
+
+use data_soil_cn
+use data_simul
+
+integer lyear, lspec, ios
+real helpC, helpN
+logical :: lin = .TRUE.
+type (species_litter) :: sliti
+
+ if (lin) read(unit_litter,*,iostat=ios) lyear, lspec, helpC, helpN
+ if (ios .lt. 0) lin = .FALSE.
+
+ do while (lyear .lt. time_cur)
+ if (lin) read(unit_litter,*,iostat=ios) lyear, lspec, helpC, helpN
+ if (ios .lt. 0) then
+ lin = .FALSE.
+ exit
+ endif
+ enddo
+
+ do while (lyear .eq. time_cur)
+ sliti = slit(lspec)
+ sliti%C_opm_fol = sliti%C_opm_fol + helpC
+ sliti%N_opm_fol = sliti%N_opm_fol + helpN
+ C_lit_fol = C_lit_fol + helpC
+ N_lit_fol = N_lit_fol + helpN
+
+ slit(lspec) = sliti
+ if (lin) read(unit_litter,*,iostat=ios) lyear, lspec, helpC, helpN
+ if (ios .lt. 0) then
+ lin = .FALSE.
+ exit
+ endif
+ enddo
+
+ if (lin) backspace (unit_litter)
+
+END subroutine read_litter_input
+
+!**************************************************************
+
+SUBROUTINE n_upt(jlay)
+
+! N uptake by roots
+
+use data_climate
+use data_par
+use data_simul
+use data_soil
+use data_soil_cn
+use help_soil_cn
+use data_species
+use data_stand
+
+implicit none
+
+! input:
+integer jlay ! number of actual layer
+integer i, ntr
+
+!-----------------------------------------------------------
+
+real NH4f, NO3f ! free available NH4-, NO3-N
+real NH4u, NO3u, Nutot ! uptake of NH4-N, NO3-N, Nan_tot
+real NH4jl, NO3jl ! NH4-, NO3-N
+real watlay ! total water content of layer before uptake and perc.
+real upt_w ! relative part of uptake water
+real :: etau = 0.036 ! parameter from A. Friend (1997)
+real :: fft ! temperature function of uptake from Thornley (1991)
+real :: ft0 = 0. , &
+ ftmax = 30. , &
+ ftref = 20. ! parameter (°C) of temperature function from Thornley (1991)
+real help, hNupt, hNupt1, Nutot1, h1, h2, N_ava, frtrel, hfrtrel, hxw
+real, dimension(1:anz_coh) :: N_dem ! auxilary array for cohorts
+real, external :: fred1
+
+! no roots -> no N-uptake
+if (root_fr(jlay) .lt. 1E-10) then
+ Nupt(jlay) = 0.
+ return
+endif
+
+! all NH4 and NO3 plant available
+NH4jl = NH4(jlay)
+NO3jl = NO3(jlay)
+NH4f = NH4jl
+NO3f = NO3jl
+
+! relative part of uptake water
+watlay = wats(jlay) + wupt_r(jlay)
+upt_w = wupt_r(jlay) / watlay
+! uptake of total available N
+upt_w = 1.
+
+fft = (temps(jlay)-ft0)*(2.*ftmax-ft0-temps(jlay))/((ftref-ft0)*(2.*ftmax-ft0-ftref))
+if (fft .lt. 0.) then
+ fft = 0.
+else
+ if (fft .gt. 1) fft = 1.
+endif
+
+NH4u = NH4f * fred1(jlay)
+NO3u = NO3f * fft * fred1(jlay)
+Nutot = (NH4u + NO3u)
+Nutot1 = 0. ! actual N uptake per layer
+
+! Uptake per cohort and m2
+
+select case (flag_decomp)
+ case (0, 1, 10, 11, 20, 21, 30, 31)
+ if (wupt_r(jlay) .lt. 1E-10) then
+ Nupt(jlay) = 0.
+ return
+ else
+ ! new balance
+ NH4jl = NH4(jlay) - NH4u
+ NO3jl = NO3(jlay) - NO3u
+ if (Nutot .ge. zero) then
+ i = 1
+ hxw = 0.
+ zeig => pt%first
+ do while (associated(zeig))
+ if (zeig%coh%species.ne.nspec_tree+2) then !exclude mistletoe
+ ntr = zeig%coh%ntreea
+ hNupt = Nutot * xwatupt(i,jlay) / wupt_r(jlay)
+ Nutot1 = Nutot1 + hNupt
+ N_ava = hNupt * kpatchsize
+ N_ava = N_ava /ntr ! g per tree
+
+ zeig%coh%Nuptc_d = zeig%coh%Nuptc_d + N_ava ! in g per tree
+
+ N_ava = N_ava * ntr ! Balance in g/m2
+
+ i = i+1
+ endif !exclusion of mistletoe
+ zeig => zeig%next
+ enddo
+ Nutot1 = Nutot
+ else
+ Nutot1 = 0.
+ do i = 1, anz_coh
+ xNupt(i,jlay) = 0.
+ enddo
+ endif
+ endif
+
+ case (40, 41)
+ ! Ansatz A. Friend (1997, Gl. 13)
+ if (Nutot .ge. 1.e-6) then
+ i = 1
+ hxw = 0.
+ zeig => pt%first
+ do while (associated(zeig))
+ if (zeig%coh%species.ne.nspec_tree+2) then !exclude mistletoe
+ ntr = zeig%coh%ntreea
+ frtrel = zeig%coh%frtrelc(jlay) ! root percentage of the entire cohort
+ hNupt = frtrel * Nutot ! available nitrogen per tree cohort and layer g
+ hxw = hxw + frtrel
+ h2 = Nutot * kpatchsize
+ h1 = h2 * frtrel
+ N_ava = h1/ntr
+ hNupt1 = N_ava
+ h1 = zeig%coh%Ndemc_c - zeig%coh%Nuptc_c
+ h2 = zeig%coh%Ndemc_d - zeig%coh%Nuptc_d
+ help = h1 + h2 ! limited by actual and resudual cohort N-demand in g/m2
+ ! limited by actual and residual cohort N-demand in g per tree
+ if (help .gt. N_ava) then
+
+ zeig%coh%Nuptc_d = zeig%coh%Nuptc_d + N_ava ! in g per tree
+
+ else
+ if (help .gt. 0.) then
+ zeig%coh%Nuptc_d = zeig%coh%Nuptc_d + help ! in g/m2 per Coh.
+ N_ava = help
+ else
+ N_ava = 0.
+ endif
+ endif
+ N_ava = N_ava * ntr ! balance in g/m2
+
+ h1 = N_ava
+ if (NH4jl .lt. h1+zero) then
+ h1 = h1 - NH4jl
+ NH4jl = zero
+ if (NO3jl .lt. h1+zero) then
+ h1 = h1 - NO3jl
+ NO3jl = zero
+ else
+ NO3jl = NO3jl - h1
+ endif
+ else
+ NH4jl = NH4jl - h1
+ h1 = 0.
+ endif
+ if ((NH4jl .lt. 0.) .or. (NO3jl .lt. 0.)) then
+ continue
+ endif
+ Nutot1 = Nutot1 + N_ava
+ xNupt(i,jlay) = N_ava
+
+ i = i+1
+ endif !exclusion of mistletoe
+ zeig => zeig%next
+
+ enddo
+ Nutot1 = Nutot1/kpatchsize
+
+ else
+ Nutot1 = 0.
+ do i = 1, anz_coh
+ xNupt(i,jlay) = 0.
+ enddo
+ endif
+
+ end select
+
+NH4(jlay) = NH4jl
+NO3(jlay) = NO3jl
+Nupt(jlay) = Nutot1 ! N uptake per layer
+
+END subroutine n_upt
+
+!**************************************************************
diff --git a/source_code/version2.2_windows/soil_tem.f b/source_code/version2.2_windows/soil_tem.f
new file mode 100755
index 0000000000000000000000000000000000000000..757a3074b5627ce84d9ba379135ebe3281b534de
--- /dev/null
+++ b/source_code/version2.2_windows/soil_tem.f
@@ -0,0 +1,643 @@
+!*****************************************************************!
+!* *!
+!* 4C (FORESEE) Simulation Model *!
+!* *!
+!* *!
+!* Subroutines for: *!
+!* SOIL-Temperature - Programs *!
+!* *!
+!* Author: F. Suckow *!
+!* *!
+!* contains: *!
+!* SOIL_TEMP main program for soil temperature *!
+!* S_T_INI initialisation of soil temperature model *!
+!* S_T_STRT initialisation of geometry parameter for the *!
+!* numerical solution of the heat conduction equation *!
+!* SURF_T calculation of the soil surface temperature *!
+!* COND calculation of conductivity 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 *!
+!* *!
+!*****************************************************************!
+
+SUBROUTINE soil_temp
+
+! soil temperature model
+
+use data_simul
+use data_climate
+use data_soil
+use data_soil_t
+use data_out
+
+implicit none
+
+integer i
+
+! Surface temperature
+call surf_t
+
+ if (flag_dayout .eq. 3) then
+ write (3334,*)
+ write (3334,*) iday
+ endif
+
+! Calculation of thermal conductivity and capacity
+do i=1,nlay
+ call cond(i,wats(i),dens(i),thick(i),pv_v(i),sandv(i),clayv(i),siltv(i),skelv(i),vol(i),spheat(i),t_cond(i),h_cap(i))
+enddo ! i (nlay)
+call cond(nlay, wats(nlay),dens(nlay),sh(nlay1),pv_v(nlay),sandv(nlay),clayv(nlay),siltv(nlay),skelv(nlay),vol(nlay),spheat(nlay),t_cond(nlay1),h_cap(nlay1))
+call cond(nlay, wats(nlay),dens(nlay),sh(nlay2),pv_v(nlay),sandv(nlay),clayv(nlay),siltv(nlay),skelv(nlay),vol(nlay),spheat(nlay),t_cond(nlay2),h_cap(nlay2))
+
+! Calculation of thermal diffusivity
+t_cb(1) = t_cond(1)
+do i=2,nlay2
+ t_cb(i) = (sh(i-1)*t_cond(i-1) + sh(i)*t_cond(i))/(sh(i)+sh(i-1))
+enddo
+
+ if (flag_dayout .eq. 4) then
+ do i=1,nlay
+ write (3336,'(3I4, 5E11.4)') time,iday,i,watvol(i),dens(i),spheat(i),t_cond(i),h_cap(i)
+ enddo
+ write (3336, *)
+ endif
+
+! Numerical solution of the heat conduction equation
+call num_t
+
+lfirst = .FALSE.
+! Restore of temperature
+do i=1,nlay
+ if (abs(sbt(i)) .lt. 1e-6) sbt(i)=0.
+ temps(i) = sbt(i)
+enddo
+
+! soil heat flux at soil surface
+hflux_surf = 2. * t_cond(1) * (temps_surf - temps(1)) / thick(1)
+
+1010 FORMAT (2I5, 20F8.1)
+END subroutine soil_temp
+
+!******************************************************************************
+
+SUBROUTINE s_t_ini
+
+! Initialisation of soil temperature model
+
+use data_simul
+use data_soil
+use data_soil_t
+
+implicit none
+
+integer i
+real, external:: kw
+real tc_cont ! thermal conductivity of continuum
+
+! Preparation of subroutine cond
+! Parameter initialisation
+water%tc = 0.005945 ! thermal conductivity of water at 20°C J/cm/s/K
+quarz%tc = 0.0879228 ! thermal conductivity of quarz at 20°C
+humus%tc = 0.00251 ! thermal conductivity of humus
+clay%tc = 0.0251208 ! thermal conductivity of clay minerals
+silt%tc = 0.02931 ! thermal conductivity of silt
+air%tc = 0.00026 ! thermal conductivity of air
+ice%tc = 0.021771 ! thermal conductivity of ice
+stone%tc = 0.041868 ! thermal conductivity of stone
+water%hc = 4.1868 ! heat capacity of water J/cm3/K
+quarz%hc = 2.01 ! heat capacity of quarz
+humus%hc = 2.512 ! heat capacity of humus
+clay%hc = 2.01 ! heat capacity of clay minerals
+silt%hc = 2.01 ! heat capacity of silt
+air%hc = 0.0012 ! heat capacity of air
+ice%hc = 1.884 ! heat capacity of ice
+stone%hc = 1.8 ! heat capacity of stone
+
+! shape factors
+quarz%ga = 0.144 ! de Vries, S. 224
+clay%ga = 0.144
+silt%ga = 0.144
+stone%ga = 0.144
+humus%ga = 0.333
+air%ga = 0.333
+ice%ga = 0.125
+
+! weighting factors for dry soil (continuous medium air)
+tc_cont = air%tc
+water%kwa = kw(water, tc_cont)
+quarz%kwa = kw(quarz, tc_cont)
+clay%kwa = kw(clay, tc_cont)
+silt%kwa = kw(silt, tc_cont)
+humus%kwa = kw(humus, tc_cont)
+ice%kwa = kw(ice, tc_cont)
+stone%kwa = kw(stone, tc_cont)
+air%kwa = 1
+
+! weighting factors for wet soil (continuous medium water)
+tc_cont = water%tc
+water%kww = 1
+quarz%kww = kw(quarz, tc_cont)
+clay%kww = kw(clay, tc_cont)
+silt%kww = kw(silt, tc_cont)
+humus%kww = kw(humus, tc_cont)
+ice%kww = kw(ice, tc_cont)
+stone%kww = kw(stone, tc_cont)
+air%kww = kw(air, tc_cont)
+
+if (flag_dayout .eq. 3) then
+ write (3335, '(A)') 'wet soil'
+ write (3335,'(6E11.4)') water%kww, air%kww, humus%kww, quarz%kww, clay%kww,ice%kww
+ write (3335, '(A)') 'dry soil'
+ write (3335,'(6E11.4)') water%kwa, air%kwa, humus%kwa, quarz%kwa, clay%kwa,ice%kwa
+endif
+
+! Calculation of thermal diffusivity
+do i=1,nlay
+ call cond(i,wats(i),dens(i),thick(i),pv_v(i),sandv(i),clayv(i),siltv(i),skelv(i),vol(i),spheat(i),t_cond(i),h_cap(i))
+enddo
+call s_t_prof
+
+call s_t_strt
+
+! Calculation of thermal diffusivity (additional layers)
+call cond(nlay, wats(nlay),dens(nlay),sh(nlay1),pv_v(nlay),sandv(nlay),clayv(nlay),siltv(nlay),skelv(nlay),vol(nlay),spheat(nlay),t_cond(nlay1),h_cap(nlay1))
+call cond(nlay, wats(nlay),dens(nlay),sh(nlay2),pv_v(nlay),sandv(nlay),clayv(nlay),siltv(nlay),skelv(nlay),vol(nlay),spheat(nlay),t_cond(nlay2),h_cap(nlay2))
+
+t_cb(1) = t_cond(1)
+do i=2,nlay2
+ t_cb(i) = (sh(i-1)*t_cond(i-1) + sh(i)*t_cond(i))/(sh(i)+sh(i-1))
+enddo
+
+END subroutine s_t_ini
+
+!******************************************************************************
+
+SUBROUTINE s_t_strt
+
+! Initialisation of geometry parameter for the
+! numerical solution of the heat conduction equation
+
+use data_soil
+use data_soil_t
+
+implicit none
+
+integer i
+real h_0, h_1
+real :: ntau = 1. ! potential time step
+
+lfirst = .TRUE.
+
+nlay1 = nlay+1
+nlay2 = nlay+2
+
+ sh(1) = thick(1)
+ sb(1) = 2. / sh(1)
+
+sv(mfirst) = sh(mfirst)
+sbt(mfirst) = temps_surf
+
+do i=mfirst+1,nlay
+ sbt(i) = temps(i)
+ sh(i) = thick(i)
+enddo
+
+sbt(nlay1) = temps(nlay)
+sbt(nlay2) = temps(nlay)
+sh(nlay1) = 2. * thick(nlay)
+sh(nlay2) = 100.
+
+h_0 = sh(1)
+do i= mfirst+1, nlay2
+ h_1 = sh(i)
+ sb(i) = 2. / (h_1 + h_0)
+ sv(i) = h_1 * ntau
+ h_0 = h_1
+enddo
+END subroutine s_t_strt
+
+!******************************************************************************
+
+SUBROUTINE surf_t
+
+! Calculation of soil surface temperature
+use data_climate
+use data_simul
+use data_soil
+use data_soil_t
+use data_stand
+
+implicit none
+
+real day
+real cof ! daily correction cefficient
+real dampcof ! stand damping coefficient
+real helplai ! thermal conductivity of organic layer (global vereinbaren und vom Vortag merken!!!)
+integer unit_tmp, helptyp
+character(80) text
+
+! read surface temperature; Oberflaechentemperatur einlesen
+if (flag_surf .eq. 2) then
+ if (lfirst) then
+ write (*,'(A)', advance='no') 'Reading of soil surface temperature, please type file name:'
+ read (*,'(A)') text
+ unit_tmp = getunit()
+ open (unit_tmp, file=trim(text), status='unknown')
+ read (unit_tmp,'(A)') text
+ read (unit_tmp, *) day, temps_surf
+ return
+ else
+ read (unit_tmp, *) day, temps_surf
+ return
+ endif
+endif
+
+! snow
+if (snow .lt. 0.05) then ! calculation of temps_surf in subroutine snowpack
+
+ dampcof = 1.0
+
+ if (waldtyp .ge. 110 .and. (waldtyp .ne. 125)) then
+ helptyp = 110
+ else
+ helptyp = waldtyp
+ endif
+ select case (helptyp)
+
+ case (10,20,25,30,31,35,37,38,70,71,75,76,125) ! Spruce; Fichte
+ if (iday .lt. 90 .or. (iday .gt. 320)) then
+ dampcof=0.8
+ else if (iday .lt. 115) then
+ dampcof=1.0
+ else if (iday .gt. 240) then
+ dampcof=1.0
+ else
+ dampcof=0.7
+ endif
+
+ case (40,50,51,52,54,55,56,60,61,62,64,65,66,90,100) ! Pine; Kiefer
+ if (iday .lt. 90 .or. (iday .gt. 320)) then
+ dampcof=1.5
+ else if (iday .lt. 115) then
+ dampcof=1.2
+ else if (iday .gt. 285) then
+ dampcof=1.3
+ else
+ dampcof=0.8
+ endif
+
+ case (110) ! Beech and other decidous trees; Buche und andere Laubhoelzer
+ if (LAI .gt. 1.) then
+ if (iday .gt. 50) then
+ if (iday .lt. 100 .or. (iday .gt. 300 .and. iday .lt. 345)) then
+ dampcof=1.2
+ else if (iday .gt. 130 .and. iday .le. 300) then ! for beech; fuer Buche
+ dampcof=0.8 ! for beech; fuer Buche
+ endif
+ endif
+ else
+ dampcof=1.2 ! for beech; fuer Buche
+ endif
+
+ end select
+
+! Daempfung berechnen nach Paul et al. (2004)
+ day = iday
+ cof = abs(-0.00003*day*day + 0.0118*day - 0.0703)
+ if (flag_surf .eq. 0) then
+ temps_surf = (c0*airtemp + c1*airtemp_1 + c2*airtemp_2) * cof * dampcof
+ temps(1) = temps_surf
+ else
+ if (flag_surf .eq. 3) then
+ cof = 1
+ dampcof = 1.0
+ endif
+ temps_surf = (c0*airtemp + c1*airtemp_1 + c2*airtemp_2) * cof * dampcof
+ endif
+
+endif ! snow
+
+
+ if (flag_dayout .eq. 3) then
+ write (1222,'(A,I5,F10.4,3F8.2)') 'day, cof, dampcof', iday, cof, dampcof, temps_surf, airtemp
+ endif
+
+END subroutine surf_t
+
+!******************************************************************************
+
+SUBROUTINE cond(ilay,watsi,densi,thicki,pvi,sandi,clayi,silti,skelvi,voli,spheati,tcondi,hcapi)
+
+! Calculation of thermal conductivity and capacity
+! de Vries-approach
+
+use data_par
+use data_soil
+use data_soil_cn
+use data_soil_t
+use data_simul
+
+implicit none
+
+! input
+integer ilay ! number of layer
+real watsi ! water content mm
+real densi ! soil density
+real thicki ! layer thickness
+real spheati ! specific heat capacity
+real dmi ! dry mass g/m2
+real pvi ! pore volume
+real quarzi ! quarz fraction in soild soil
+real sandi ! sand fraction in soild soil
+real clayi ! clay fraction in soild soil
+real silti ! silt fraction in soild soil
+real skelvi ! skeleton fraction in soil
+real tc_cont ! thermal conductivity of continuum
+real wcvol ! water content (vol%)
+
+! output
+real tcondi, tcond0, tcond1, tcond2, tcond3 ! thermal conductivity
+real hcapi, hcap0, hcap1, hcap2, hcap3 ! thermal capacity
+
+real numera, denom ! numerator, denominator of calculation of thermal conductivity
+real hum_dens, densi1, pvi1, hvf, hvf1
+real aa, bb, cc, dd, vfm, vfs, massfr ! Campbell-Ansatz
+real wkw,akw,hkw,qkw,ckw,skw,ikw,tkw, skel, voli, restvol
+
+! density g/cm3
+hum_dens = 1.3 !Density of humus (compressed, without air)
+quarzi = sandi
+ ! dry mass
+ dmi = voli * densi
+ voli = thicki * 10000.
+ hvf = (C_opm(ilay) + C_hum(ilay)) / cpart ! Masse (g)
+
+ ! volume fractions
+ skel = 1. - skelvi
+ pvi1 = skel * pvi/100.
+ water%vf = skel * watsi/(10.*thicki)
+ air%vf = pvi1 - water%vf
+ if (air%vf .lt. 0.) then
+ continue
+ endif
+ hvf = hvf / hum_dens ! volume; Volumen
+ restvol = voli - (skelvi + pvi1)*voli - hvf
+ humus%vf = hvf / voli
+ quarz%vf = quarzi*restvol / voli
+ clay%vf = clayi*restvol / voli
+ silt%vf = silti*restvol / voli
+ stone%vf = skelvi
+ ice%vf = 0.
+
+ if (flag_dayout .ge. 3) then
+ write (3334,'(3I4,F8.3,8F10.4)') time,iday,ilay,pvi1, water%vf, air%vf,humus%vf,quarz%vf,clay%vf,silt%vf,stone%vf,ice%vf
+ if (ilay .eq. nlay) write (3334, *)
+ endif
+
+select CASE (flag_cond)
+
+CASE (1, 11, 21, 31, 41) ! Neusypina
+ if (densi .lt. 0.6) then
+ densi1 = 0.6
+ else
+ densi1 = densi
+ endif
+ wcvol = watsi/(10.*thicki)
+ tcondi = ((3.*densi1-1.7)*0.001)/(1.+(11.5-5.*densi1) &
+ *EXP((-50.)*(wcvol/densi1)**1.5))*86400.
+ tcondi = tcondi * 4.1868 ! convertation cal/(cm s K) in J/(cm s K)
+
+ ! heat capacity J/(cm3 K)
+ hcapi = densi1*spheati + wcvol*4.1868
+ hcap1 = hcapi
+ tcond1 = tcondi
+
+CASE (0, 10, 20, 30, 40) ! de Vries
+
+ ! Determination of continuous medium
+
+ if (watsi .gt. 0.95 * pv(ilay)) then
+ ! wet soil
+ wkw = water%kww
+ akw = air%kww
+ hkw = humus%kww
+ qkw = quarz%kww
+ ckw = clay%kww
+ skw = silt%kww
+ tkw = stone%kww
+ ikw = ice%kww
+ else
+ ! dry soil
+ wkw = water%kwa
+ akw = air%kwa
+ hkw = humus%kwa
+ qkw = quarz%kwa
+ ckw = clay%kwa
+ skw = silt%kwa
+ tkw = stone%kwa
+ ikw = ice%kwa
+ endif
+
+ numera = wkw * water%vf * water%tc + qkw * quarz%vf * quarz%tc + ckw * clay%vf * clay%tc + &
+ skw * silt%vf * silt%tc + hkw * humus%vf * humus%tc + akw * air%vf * air%tc + &
+ tkw * stone%vf * stone%tc + ikw * ice%vf * ice%tc
+ denom = wkw * water%vf + qkw * quarz%vf + ckw * clay%vf + skw * silt%vf + &
+ hkw * humus%vf + akw * air%vf + tkw * stone%vf + ikw * ice%vf
+
+ tcond0 = numera/denom * 86400. ! s --> day
+
+ CASE(2, 12, 22, 32, 42) ! sum like resistor; wie Widerstaende addieren
+ tcond2 = water%vf / water%tc + quarz%vf / quarz%tc + clay%vf / clay%tc + &
+ silt%vf / silt%tc + humus%vf / humus%tc + air%vf / air%tc + stone%vf / stone%tc + ice%vf / ice%tc
+
+ tcond2 = 86400. / tcond2
+
+CASE(3, 13, 23, 33, 43) ! Campbell
+ vfm = clay%vf + silt%vf + stone%vf
+ vfs = vfm + quarz%vf + humus%vf
+ if (watsi .gt. 0.95 * pv(ilay)) then
+ ! wet soil
+ aa = 0.57 + 1.73*quarz%vf + 0.93*vfm
+ aa = aa / (1. - 0.74*quarz%vf - 0.49*vfm) - 2.8*vfs*(1.-vfs)
+ bb = 2.8 * vfs * water%vf
+ tcond3 = (aa + bb * water%vf) ! W/m/K
+ else if (watsi .le. wilt_p(ilay)) then
+ ! dry soil
+ tcond3 = 0.03 + 0.7 * vfs * vfs ! W/m/K
+ else
+ massfr = 2.65 * (vfm + quarz%vf) + 1.3 * humus%vf
+ massfr = 2.65 * clay%vf / massfr
+ aa = 0.57 + 1.73*quarz%vf + 0.93*vfm
+ aa = aa / (1. - 0.74*quarz%vf - 0.49*vfm) - 2.8*vfs*(1.-vfs)
+ bb = 2.8 * vfs * water%vf
+ cc = 1. + 2.6 * sqrt(clay%vf)
+ dd = 0.03 + 0.7 * vfs * vfs
+ tcond3 = aa + bb*water%vf - (aa-dd) * exp(-(cc*water%vf)**4) ! W/m/K
+ endif
+ tcond3 = tcond3 / 100. ! W/m/K ==> J/(cm s K)
+ tcond3 = tcond3 * 86400. ! s --> day
+end select
+
+ ! heat capacity J/(cm3 K)
+ hcap0 = water%vf * water%hc + quarz%vf * quarz%hc + clay%vf * clay%hc + silt%vf * silt%hc + &
+ humus%vf * humus%hc + air%vf * air%hc + stone%vf * stone%hc + ice%vf * ice%hc
+
+ if (flag_dayout .eq. 4) then
+ write (3337,'(3I4, 6E11.4)') time,iday,ilay,tcond0,tcond1,tcond2,tcond3,hcap0,hcap1
+ if (ilay .eq. nlay) write (3337, *)
+ endif
+
+select CASE (flag_cond)
+
+CASE (0, 10, 20, 30, 40) ! de Vries
+ hcapi = hcap0
+ tcondi = tcond0
+
+CASE (1, 11, 21, 31, 41) ! Neusypina
+ hcapi = hcap1
+ tcondi = tcond1
+
+CASE (2, 12, 22, 32, 42) ! sum like resitors; Widerstände addieren
+ if ((tcond2 .gt. 8000.) .or. (tcond2 .le. 0.)) then
+ continue
+ endif
+ hcapi = hcap0
+ tcondi = tcond2
+
+CASE (3, 13, 23, 33, 43) ! Campbell
+ hcapi = hcap0
+ tcondi = tcond3
+end select
+
+END subroutine cond
+
+!**************************************************************
+real FUNCTION kw(part, tc_cont)
+
+! Function for calculating weighting factor k
+! in calculating thermal conductivity
+
+use data_soil_t
+implicit none
+
+type (therm_par):: part ! soil fraction (particles)
+real tc_cont ! thermal conductivity of continuum
+real term, ga
+
+ term = part%tc / tc_cont -1.
+ ga = part%ga
+ kw = (2./(1.+ term*ga) + 1./(1.+ term*(1.-2.*ga)))/3.
+
+end FUNCTION
+
+!******************************************************************************
+
+SUBROUTINE num_t
+
+! Numerical solution of the heat conduction equation
+
+use data_soil
+use data_soil_t
+use data_simul
+
+implicit none
+
+integer i
+logical lcase ! logical control of Cholesky procedure
+real hflux ! heat flux at surface (right side)
+
+lcase = .TRUE.
+
+! Determination of the volume matrix
+svv = sv * h_cap
+if (lfirst) svva = svv
+
+! Determination (side diagonal; Nebendiagonale) !
+do i=1,nlay2
+ son(i) = -sb(i) * t_cb(i)
+enddo
+son(nlay2+1) = 0.0
+
+! Determination (main diagonal; Hauptdiagonale) !
+do i=1,nlay2
+ soh(i) = svv(i) - son(i) - son(i+1)
+enddo
+
+hflux = temps_surf * sb(1) * t_cb(1) ! Set heat flux at surface at right side
+
+if (.not.lfirst) then
+ ! Calculation of the right side
+ do i=1,nlay2
+ sxx(i) = (svva(i) + (svv(i)-svva(i))/sh(i)) * sbt(i)
+ enddo
+ sxx(1) = sxx(1) + hflux
+
+ ! Iteration (Cholesky procedure)
+ call chl3 (nlay2, son, soh, sxx, lcase)
+
+ ! Results of iteration on temperature help array
+ sbt = sxx
+endif ! lfirst
+
+! Restore of geometry matrix
+svva = svv
+END subroutine num_t
+
+!******************************************************************************
+
+SUBROUTINE chl3 (n, a, b, x, lcase)
+
+! Solution of EX = Z (E - tridiagonal, symmetric matrix)
+! with Cholesky procedure (E = LDL')
+
+implicit none
+
+! input
+integer n ! rang of matrix
+logical lcase ! logical control of Cholesky procedure
+ ! .TRUE. for start of iteration
+real, dimension(n) :: a, & ! Nebendiagonale
+ b ! main diagonal
+
+! output
+real, dimension(n) :: x ! solution vector
+
+! local variables
+integer i, j, j1
+real, dimension(n) :: d, ul
+
+! Calculation of the left upper triangle matrix L
+! and of the diagonal matrix D at start of iteration
+if (lcase) then
+ d(1) = b(1)
+ do i=2,n
+ ul(i) = a(i) / d(i-1)
+ d(i) = b(i) - ul(i)*a(i)
+ enddo
+ lcase = .FALSE.
+endif
+
+! Solution of LY = Z
+do i=2,n
+ x(i) = x(i) - ul(i)*x(i-1)
+enddo
+
+! Solution of L'X = D(-1)Y
+x(n) = x(n) / d(n)
+do i=1,n-1
+ j = n-i
+ j1 = j+1
+ x(j) = x(j)/d(j) - ul(j1)*x(j1)
+enddo
+
+END subroutine chl3
+
+!******************************************************************************
+
diff --git a/source_code/version2.2_windows/soil_tem_ini.f b/source_code/version2.2_windows/soil_tem_ini.f
new file mode 100755
index 0000000000000000000000000000000000000000..1dbce6107f86fbff904b7e1c3411c7429e3a1663
--- /dev/null
+++ b/source_code/version2.2_windows/soil_tem_ini.f
@@ -0,0 +1,137 @@
+!*****************************************************************!
+!* 4C (FORSEE) Simulation Model *!
+!* *!
+!* *!
+!* contains: *!
+!* s_t_prof generates initial soil temp. profile *!
+!* BTFOUR TRICOF use to develope soil-surface-temp. *!
+!* *!
+!* 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 s_t_prof
+
+! Generation of initial soil temperature profile
+
+use data_par
+use data_soil
+use data_soil_t
+use data_simul
+
+implicit none
+
+integer i, ia, ie, k
+real ath, dth, rfr, sn, uhf, u, vk, vh, fourterm
+real tcsu, hcsu
+
+ ia = 1
+ ie = 365
+ TQ = 10.
+
+ CALL BTFOUR
+ tcsu = 0.
+ hcsu = 0.
+ rfr = 2. * pi / 365. ! radial frequency; Radialfrequenz
+ UHF=2.*pi/(IE-IA+1)
+ u = uhf * it
+
+! calculation of temperature profile commonly from day 1 (it=1) set in data_soil;
+! Temperaturprofil berechnen, standardmaessig it=1 (1. Tag) in data_soil gesetzt
+ do i = 1, nlay
+ tcsu = tcsu + t_cond(i)*thick(i)
+ hcsu = hcsu + h_cap(i)*thick(i)
+ ath = tcsu / hcsu ! for a weighted mean both values are divided by the depth (i), thus they cancel each other; fuer gewichtetes Mittel beide Werte durch depth(i) teilen ==> weggekuerzt
+ DTH=SQRT(2*ATH/RFR)
+ VH=mid(I)/DTH
+ fourterm = 0.
+ do k = 1, nk
+ VK=VH*SQRT(K+0.)
+ SN=FTA(K)*EXP(-VK)*SIN(U*K+FTO(K)-VK)
+ fourterm = fourterm + SN
+ enddo
+ temps(i) = TQ + fourterm
+ if (flag_dayout .eq. 3) write (2244, *) i, temps(i), mid(i), ath, dth, fourterm
+ enddo
+
+END subroutine s_t_prof
+
+!******************************************************************************
+
+SUBROUTINE BTFOUR
+
+! using TRICOF for a Fourier series development for ground surface temperature;
+! Fourierreihenentwicklung fuer Boden-Oberflaechen-Temperatur unter Nutzung von TRICOF
+
+use data_climate
+use data_par
+use data_soil
+use data_soil_t
+use data_simul
+
+implicit none
+
+integer i, n, nt, nts, nf, nend, naf, no, ne, lf
+real a0
+real, dimension(184):: FA,FB
+
+! set amount of auxiliary points NF for transformation;
+! Anzahl der Stuetzstellen NF fuer Transformation festlegen
+
+ nend = 365
+ naf = 1
+
+ NT=NEND-NAF+1
+ NTS=1
+ NF=(NT+NTS-1)/NTS
+ N=(NF-1)/2
+ IF((2*N-NF+1) .LT. 0) THEN
+ NF=NF-1
+ NT=(NF*NTS)-NTS+1
+ NEND=NAF+NT-1
+ ENDIF
+ NE=1+(NF/2)
+ NO=NE-2
+ NK=NO
+
+! calculation of auxiliary points; Stuetzstellen berechnen
+
+ LF=NAF
+ DO I=1,NF
+ airtemp = tp(lf,1)
+ airtemp_1 = tp(lf-1,1)
+ airtemp_2 = tp(lf-2,1)
+ rad = rd(lf,1)
+ iday = lf
+ call surf_t
+ if (lf .eq. 1) temps(1) = temps_surf
+ Four_sp(i) = temps_surf
+ LF=LF+NTS
+ ENDDO
+
+! Fourier transformation; FOURIERTRANSFORMATION
+ CALL TRICOF(Four_sp,NF,FA,NE,FB,NO,1)
+ A0 = FA(1) / 2.
+ TQ = A0
+
+! coefficient to transform solution; Koeffizienten fuer Loesung transformieren
+ DO I=1,NK
+ FTA(I) = SQRT(FA(I+1)*FA(I+1) + FB(I)*FB(I))
+ FTA(I) = FTA(I) * SIGN(1.,FB(I))
+ if(FB(I).eq. 0.) then
+ FTO(I) = pi/2.
+ else
+ FTO(I) = ATAN(FA(I+1)/FB(I))
+ end if
+ FTO(I) = FTO(I) - (NEND+NAF)*PI*I/(NEND-NAF)
+ ENDDO
+
+END SUBROUTINE BTFOUR
+
+!******************************************************************************
diff --git a/source_code/version2.2_windows/sorting.f b/source_code/version2.2_windows/sorting.f
new file mode 100755
index 0000000000000000000000000000000000000000..920a1b23c8b74fda8a8223f97d535539476aba15
--- /dev/null
+++ b/source_code/version2.2_windows/sorting.f
@@ -0,0 +1,163 @@
+!*****************************************************************!
+!* *!
+!* 4C (FORESEE) Simulation Model *!
+!* *!
+!* Subroutines for: *!
+!* - dimsort: sorting of cohorts according to a *!
+!* charcteristic variable *!
+!* - sort2: subroutine from Numerical recipes *!
+!* *!
+!* Copyright (C) 1996-2018 *!
+!* Potsdam Institute for Climate Impact Reserach (PIK) *!
+!* Authors and contributors see AUTHOR file *!
+!* This file is part of 4C and is licensed under BSD-2-Clause *!
+!* See LICENSE file or under: *!
+!* http://www.https://opensource.org/licenses/BSD-2-Clause *!
+!* Contact: *!
+!* https://gitlab.pik-potsdam.de/foresee/4C *!
+!* *!
+!*****************************************************************!
+
+SUBROUTINE dimsort(n,var,ranktable)
+
+ USE data_species
+ USE data_stand ! state variables of stand, cohort and cohort element
+ IMPLICIT NONE
+ INTEGER :: isort,n
+ INTEGER :: ranktable(n)
+ CHARACTER(3) :: var
+ REAL :: sortarray(n)
+
+ ranktable=0
+ sortarray=0
+ isort=1
+ zeig=>pt%first
+ DO
+ IF (.not.ASSOCIATED(zeig)) exit
+ IF (zeig%coh%species .le. nspec_tree) THEN ! for trees only
+ ranktable(isort) = zeig%coh%ident
+ IF(var=='hei') sortarray(isort) = zeig%coh%height
+ IF(var=='dbh') sortarray(isort) = zeig%coh%diam
+ isort=isort+1
+ ENDIF
+ zeig=>zeig%next
+ END DO
+ CALL sort2(n,sortarray,ranktable)
+END SUBROUTINE dimsort
+
+!******************************************************************************
+
+ SUBROUTINE sort2(n,arr,brr)
+! sorts array arr(1:n) into an ascending order and
+! makes the corresponding rearrangement of the array brr(1:n)
+
+ INTEGER n,M,NSTACK
+
+ REAL arr(n)
+ INTEGER brr(n)
+
+ PARAMETER (M=7,NSTACK=50)
+
+ INTEGER i,ir,j,jstack,k,l,istack(NSTACK)
+
+ REAL a,b,temp
+ jstack=0
+ l=1
+ ir=n
+1 if(ir-l.lt.M)then
+ do 12 j=l+1,ir
+ a=arr(j)
+ b=brr(j)
+ do 11 i=j-1,1,-1
+ if(arr(i).le.a)goto 2
+ arr(i+1)=arr(i)
+ brr(i+1)=brr(i)
+11 continue
+ i=0
+2 arr(i+1)=a
+ brr(i+1)=b
+12 continue
+ if(jstack.eq.0)return
+ ir=istack(jstack)
+ l=istack(jstack-1)
+ jstack=jstack-2
+ else
+ k=(l+ir)/2
+ temp=arr(k)
+ arr(k)=arr(l+1)
+ arr(l+1)=temp
+ temp=brr(k)
+ brr(k)=brr(l+1)
+ brr(l+1)=temp
+ if(arr(l+1).gt.arr(ir))then
+ temp=arr(l+1)
+ arr(l+1)=arr(ir)
+ arr(ir)=temp
+ temp=brr(l+1)
+ brr(l+1)=brr(ir)
+ brr(ir)=temp
+ endif
+ if(arr(l).gt.arr(ir))then
+ temp=arr(l)
+ arr(l)=arr(ir)
+ arr(ir)=temp
+ temp=brr(l)
+ brr(l)=brr(ir)
+ brr(ir)=temp
+ endif
+
+ if(arr(l+1).gt.arr(l))then
+ temp=arr(l+1)
+ arr(l+1)=arr(l)
+ arr(l)=temp
+ temp=brr(l+1)
+ brr(l+1)=brr(l)
+ brr(l)=temp
+ endif
+
+ i=l+1
+ j=ir
+ a=arr(l)
+ b=brr(l)
+3 continue
+
+ i=i+1
+ if(arr(i).lt.a)goto 3
+4 continue
+
+ j=j-1
+ if(arr(j).gt.a)goto 4
+ if(j.lt.i)goto 5
+ temp=arr(i)
+ arr(i)=arr(j)
+ arr(j)=temp
+ temp=brr(i)
+ brr(i)=brr(j)
+ brr(j)=temp
+ goto 3
+
+5 arr(l)=arr(j)
+ arr(j)=a
+ brr(l)=brr(j)
+ brr(j)=b
+ jstack=jstack+2
+ if(jstack.gt.NSTACK)pause 'NSTACK too small in sort2'
+ if(ir-i+1.ge.j-l)then
+ istack(jstack)=ir
+ istack(jstack-1)=i
+ ir=j-1
+ else
+
+ istack(jstack)=j-1
+ istack(jstack-1)=l
+ l=i
+ endif
+
+ endif
+
+ goto 1
+
+ END Subroutine
+
+! (C) Copr. 1986-92 Numerical Recipes Software "!D#+.
+
diff --git a/source_code/version2.2_windows/sr_forska.f b/source_code/version2.2_windows/sr_forska.f
new file mode 100755
index 0000000000000000000000000000000000000000..c7525a4e1001f53ec32ca11901ab0c826baea156
--- /dev/null
+++ b/source_code/version2.2_windows/sr_forska.f
@@ -0,0 +1,393 @@
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!
+! Subroutines used only with flag flag_forska
+!
+! cetbl_4c
+! CGTSPE_4c
+! CLIMEF_4c
+! gsdr_cal
+! tmp_mean
+! therm
+!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+
+SUBROUTINE CETBL_4c
+
+use data_effect
+use data_taxa
+use data_simul
+use data_stand
+
+! function declarations
+
+ REAL RAND
+
+! local variables
+real :: PMX
+INTEGER :: I,J,K
+integer,dimension(17) :: nsap= 0
+real,dimension(17) :: amdest = 0., &
+ amdest1 = 0.
+
+if (flag_light.eq.1.or.flag_light.eq.2) then
+ PMX= Vstruct(lowest_layer)%Irel
+else if (flag_light.eq.3.OR.flag_light.EQ.4) then
+ PMX = Bgpool(lowest_layer+1)
+end if
+
+! amend the EST for climate according to the climate multipliers
+
+do i=1,17
+
+ AMDEST(I)=EST(I)*GDDMX(I)*DRMX(I)*TCMX(I)*TWMX(I)*PMX &
+ *XTFTMX(I)*TWARMX(I)
+ AMDEST1(I)=EST(I)*AMIN1(GDDMX(I),DRMX(I),TCMX(I),TWMX(I), &
+ PMX,XTFTMX(I),TWARMX(I))
+
+ IF(GSC(I).EQ.0.0)GOTO 301
+301 CONTINUE
+ end do
+
+ RETURN
+
+END subroutine cetbl_4c
+
+
+SUBROUTINE CGTSPE_4c
+
+! input of species data for regeneration
+
+! reads species parameters
+ use data_simul
+ use data_taxa
+
+! local variables
+INTEGER:: I,J,K,nowunit,ntax
+
+! reads number of taxa (NTAX)
+ nowunit=getunit()
+ open(unit=nowunit,file= '/data/safe/4C/4C_input/par/param_4c.dat', status='old')
+ READ(nowunit,*) NTAX
+
+! reads for each taxon:
+
+! NAM(I): name (8 characters)
+! HMX(I): max height (m)
+! HDS(I): initial slope of diameter vs height (m/cm)
+! hgro(I): maximum height growth per year (m)
+! ALP(I): half-saturation point (umol/m**2/s)
+! LCP(I): compensation point (umol/m**2/s)
+! GSC(I): growth constant (cm**2/m/yr)
+! EST(I): sapling establishment rate (/ha/yr)
+! TDI(I): threshold relative growth efficiency for increased mortality
+! UMN(I): intrinsic mortality rate (/yr)
+! UMX(I): suppressed mortality rate (/yr)
+! SPR(I): number of sprouts per tree (0.0 or greater)
+! SMN(I): minimum diameter for sprouting (cm)
+! LAC(I): initial leaf area/D2 ratio (m**2/cm**2)
+! LAF(I): sapwood turnover rate (/yr)
+! BCF(I): stemwood biomass conversion factor (kg/cm**2/m)
+! R(I): volumetric sapwood maintenance cost (/yr)
+! Q10(I): rate of increase of respiration
+! TMIN(I): minimum temperature for assimilation
+! TMAX(I): maximum temperature for assimilation
+! CCP(I): species compensation point
+! DRI(I): maximum tolerated drought-index
+!MINGDD(I): minimum growing degree-days
+! MINTC(I): minimum temperature of coldest month (degrees C)
+! MAXTC(I): maximum temperature of coldest month (degrees C)
+! MINTW(I): minimum temperature of warmest month (degrees C)
+! DORE(I): deciduous or evergreen 0=deciduous,1=evergreen
+! ntc(I): nitrogen tolerance class (1,2,3,4,5)
+! e1(I): Parameter smin of haadee height growth function
+! e2(I): Second Parameter of haadee height growth function
+! geff(I): growth efficiency factor of shaded trees
+
+ DO I=1,ntax
+ READ(nowunit,1) NAM(I)
+ READ(nowunit,*) HMX(I),HDS(I),hgro(I),ALP(I),LCP(I),GSC(I), &
+
+ EST(I),TDI(I),UMN(I),UMX(I),SPR(I),SMN(I),LAC(I),LAF(I),BCF(I), &
+
+ R(I),Q10(I),TMIN(I),TMAX(I),CCP(I),DRI(I),MINGDD(I),MINTC(I), &
+
+ MAXTC(I),MINTW(I),DORE(I),ntc(I)
+
+ IF(SPR(I).EQ.0)SMN(I)=0.0
+
+
+ DRI(I)=DRI(I)+0.3
+
+
+
+ end do
+
+ RETURN
+
+! format statements
+
+1 FORMAT(A8)
+
+END subroutine cgtspe_4c
+
+
+SUBROUTINE CLIMEF_4c
+
+use data_taxa
+use data_effect
+use data_simul
+
+
+! computes the growth multipliers.
+! checks to see if GDD, temp coldest month below minimum for species
+! if so multipliers = 0 else equals 1.
+! computes drought effect multipliers as per ICP
+! sets max.temp of coldest month multiplier to 0 or 1 for ESTBL routine
+! checks if warmest month exceeds species limit
+! averages light intensity (INS) over time step.
+
+
+! local parameters
+
+ INTEGER :: I,J,K
+ REAL ::TOTGDD= 0, &
+ TGSDRT=0., &
+ TM4DRT=0.
+
+ real,dimension(17) :: tottft=0.
+
+! gives growth multiplier for each species to be applied in subroutine
+! TVXT or ETBL - growing degree days, growing/-4 drought index, temps.
+
+ TOTGDD=GDD(time)
+ TGSDRT=GSDRI(time)
+ TM4DRT=M4DRI(time)
+
+! totals and then averages species specific multipliers etc. over timestep
+! that is sapres, mutmx, tftmx
+
+ do i=1,17
+
+ xtftmx(i) = tftmx(i,time)
+
+ end do
+
+! set multipliers to 1 before checking on environment
+ do i=1,17
+
+ GDDMX(I)=1.0
+ TWARMX(I)=1.0
+ TCMX(I)=1.0
+ TWMX(I)=1.0
+ TWARMX(I)=1.0
+
+! check to see is a deciduous species
+
+ IF(DORE(I).EQ.0)THEN
+ DRMX(I)=1-((TGSDRT/DRI(I))**2)
+ IF(DRMX(I).LT.0.0)DRMX(I)=0.0
+
+ ELSE
+
+! must be an evergreen
+
+ DRMX(I)=1-((TM4DRT/DRI(I))**2)
+ IF(DRMX(I).LT.0.0)DRMX(I)=0.0
+
+ ENDIF
+
+! check if environment exceeds species limits - step functions
+! if so set multiplier to zero
+
+ IF(TOTGDD.LT.MINGDD(I))GDDMX(I)=0.0
+ IF(TCOLD.LT.MINTC(I))TCMX(I)=0.0
+ IF(TCOLD.GT.MAXTC(I))TWMX(I)=0.0
+ IF(TWARM.LT.MINTW(I))TWARMX(I)=0.0
+
+! write out to screen and forcli.out multipliers for each species
+! keep these commented as they use a lot of paper <--M.B was ist damit gemeint? ist das relevant für den nutzer.
+
+ end do
+ do i=1,17
+ end do
+
+
+end subroutine climef_4c
+
+ SUBROUTINE gsdr_cal
+! calculation of gsdri and m4dri for FORSKA regeneration
+
+use data_climate
+use data_effect
+use data_simul
+use data_evapo
+
+if(tp(iday,time).ge.-4.) then
+ foudpt = foudpt + pet
+ foudae = foudae + aet
+end if
+
+if(tp(iday,time).ge.4.) then
+ tgsdpt = tgsdpt + pet
+ tgsdae = tgsdae + aet
+
+end if
+
+if(iday.eq. recs(time)) then
+
+ gsdri(time) = (tgsdpt-tgsdae)/tgsdpt
+ m4dri(time) = (foudpt-foudae)/foudpt
+end if
+
+END SUBROUTINE gsdr_cal
+
+SUBROUTINE tmp_mean
+! calculation of environmental variables twarm, tcold and long-term monthly
+! mean of temperature
+
+USE data_effect
+USE data_climate
+USE data_simul
+
+real,dimension(12) :: tmph = 0.
+integer :: i,l,m,dayc
+allocate( tpmean(12))
+allocate (gdd(year))
+allocate (tftmx(17,year))
+monrec=(/31,28,31,30,31,30,31,31,30,31,30,31/)
+tpmean = 0
+
+if (recs(time).eq.366) then
+ monrec(2)=29
+else
+ monrec(2)=28
+endif
+
+
+do k = 1, year
+! call calculation of env. variables
+
+ call therm(k)
+
+ dayc = 1
+ do l= 1,12
+ tmph(l) = 0.
+ do m=1,monrec(l)
+ tmph(l) = tmph(l) + tp( dayc,k)
+ dayc = dayc + 1
+ end do
+ tmph(l) = tmph(l)/monrec(l)
+ tpmean(l) = tpmean(l) + tmph(l)
+ end do
+
+end do
+
+do l=1,12
+
+ tpmean(l) = tpmean(l)/year
+
+end do
+
+! work out which is temperature of coldest month
+! and warmest month for year
+
+ tcold = 50.0
+ twarm = -50.0
+
+do k=1,12
+ if(tpmean(k).lt.tcold) tcold = tpmean(k)
+ if(tpmean(k).gt.twarm) twarm = tpmean(k)
+end do
+
+END SUBROUTINE tmp_mean
+
+SUBROUTINE therm(ktime)
+
+! therm - calculation of environmental variables (annual and species specific)
+! gdd - growing degress day
+! tftmx - thermal multiplier - species specific
+
+use data_climate
+use data_simul
+use data_effect
+use data_taxa
+implicit none
+
+
+
+! local variables
+
+integer :: j,k,m4day,gdday1,ktime
+real,dimension(17) :: tft,tresft
+ gdd(ktime) = 0.
+ m4day=0
+ gdday1=0
+ do j=1,17
+
+ tft(j)=0.0
+ tresft(j)=0.0
+ end do
+
+! calculate ft values for each day of the year
+! for each species upto number of taxa
+ do k=1,17
+
+ do j=1,recs(ktime)
+
+! add up mutmx multiplier
+
+ tresft(k) = tresft(k)+(q10(k)**((tp(j,ktime) - tref)*0.1))
+
+ if(k.eq.1) then
+ if (tp(j,ktime).ge.tref) gdd(ktime) = gdd(ktime) + (tp(j,ktime)-tref)
+ end if
+! first check to see if deciduous or not
+
+ if(dore(k).eq.0)then
+
+! totalling daily deciduous multipliers for growing season only
+
+ if(tp(j,ktime).ge.5.0) then
+
+ tft(k) = tft(k)+(4*(tp(j,ktime)-tmin(k))*(tmax(k)-tp(j,ktime))/(tmin(k)-tmax(k))**2)
+
+
+ endif
+ else
+
+! must be evergreen so produce daily values
+! do not allow below zero
+! checks for temperature greater than -4 oC for evergreen species
+
+ if(tp(j,ktime).ge.-4.0)then
+
+ tft(k)=tft(k)+(4*((tp(j,ktime)-tmin(k))*(tmax(k)-tp(j,ktime))) &
+ /(tmin(k)-tmax(k))**2)
+
+ endif
+
+ endif
+ if(tft(k).lt.0.0)tft(k)=0.0
+ end do
+
+ end do
+ do j=1,recs(ktime)
+ if(tp(j,ktime).ge.5.0) then
+ gdday1=gdday1+1
+ end if
+ if(tp(j,ktime).ge.-4.0) then
+ m4day=m4day+1
+ end if
+ end do
+
+ do k=1,17
+
+ if(dore(k).eq.0) then
+ tftmx(k,ktime) = tft(k)/gdday1
+ else
+ tftmx(k,ktime) = tft(k)/m4day
+ end if
+ end do
+
+END SUBROUTINE therm
diff --git a/source_code/version2.2_windows/stand_bal.f b/source_code/version2.2_windows/stand_bal.f
new file mode 100755
index 0000000000000000000000000000000000000000..18b7a42e363ec3e14d8fce298aa210aec64dd7bb
--- /dev/null
+++ b/source_code/version2.2_windows/stand_bal.f
@@ -0,0 +1,1259 @@
+!*****************************************************************!
+!* *!
+!* 4C (FORESEE) Simulation Model *!
+!* *!
+!* Subroutines for: *!
+!* - STAND_BALANCE: Recalculation of stand variables *!
+!* contains: *!
+!* UPDATE_AGE *!
+!* - STAND_BAL_SPEC *!
+!* - CLASS *!
+!* - CLASST *!
+!* - CLASS_MAN *!
+!* - CALC_HEIDOM *!
+!* - MAX_HEIGHT(nrmax,anz,cohl) *!
+!* - STANDUP: Update of cover and ceppot *!
+!* - LITTER: Summation variables of litter fractions *!
+!* - calc_ind_rep: calculation of representation index *!
+!* - overstorey *!
+!* *!
+!* 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_balance
+use data_species
+use data_stand
+use data_climate
+use data_simul
+use data_manag
+use data_out
+use data_par
+
+implicit none
+
+integer i, ntr, nd, hanz
+integer, dimension(nspecies) :: helpin, helpout
+real conv ! conversion factor
+
+if (flag_trace) write (unit_trace, '(I4,I10,A)') iday, time, ' stand_balance'
+
+if(time>0. .and. flag_standup.ne.2) call update_age
+
+! calculation of total dead biomass per cohort and total biomass of allcohorts
+! calc. of ceppot
+anz_sveg = 0
+anz_tree = 0.
+anz_tree_in = 0.
+anz_tree_out = 0.
+anz_spec_in = 0.
+anz_spec_out = 0.
+anz_coh_in = 0.
+anz_coh_out = 0.
+anz_coh_act = 0.
+lai_in = 0.
+lai_out = 0.
+totfol_in = 0.
+totfol_out = 0.
+med_diam_in = 0.
+med_diam_out = 0.
+hmean_in = 0.
+hmean_out = 0.
+mean_height = 0.
+sumbio = 0.
+sumbio_in = 0.
+sumbio_out = 0.
+sumNPP = 0.
+drIndAl = 0.
+Ndem = 0.
+helpin = 0
+helpout = 0
+basal_area = 0.
+totstem_m3 = 0.
+totsteminc_m3 = 0.
+totsteminc = 0
+autresp = 0.
+totfol = 0.
+totsap = 0.
+totfrt = 0.
+totfrt_p = 0.
+totcrt = 0.
+tottb = 0.
+tothrt = 0.
+sumbio_sv = 0.
+
+zeig=>pt%first
+do
+ if(.not.associated(zeig)) exit
+
+ ns = zeig%coh%species
+ ntr = zeig%coh%ntreeA
+ svar(ns)%daybb = zeig%coh%day_bb
+ if(ns.le.nspec_tree) then
+ if(zeig%coh%ident .le. coh_ident_max) then
+ anz_coh_act = anz_coh_act + 1
+ anz_tree = anz_tree + ntr
+ zeig%coh%totBio = zeig%coh%x_fol + zeig%coh%x_sap + zeig%coh%x_hrt + zeig%coh%x_tb + zeig%coh%x_frt +zeig%coh%x_crt
+ zeig%coh%Dbio = zeig%coh%nTreeD * zeig%coh%totBio
+ sumbio = sumbio + ntr * zeig%coh%totBio
+ sumNPP = sumNPP + ntr * zeig%coh%NPP
+ Ndem = Ndem + ntr * zeig%coh%Ndemc_c
+ autresp = autresp + ntr * zeig%coh%maintres
+ totfol = totfol + ntr * zeig%coh%x_fol
+ totsap = totsap + ntr * zeig%coh%x_sap
+ totfrt = totfrt + ntr * zeig%coh%x_frt
+ totcrt = totcrt + ntr * zeig%coh%x_crt
+ tottb = tottb + ntr * zeig%coh%x_tb
+ tothrt = tothrt + ntr * zeig%coh%x_hrt
+ if (zeig%coh%height.le.thr_height) then
+ seedlfrt = seedlfrt + zeig%coh%x_frt * ntr
+ endif
+ totstem_m3 = totstem_m3 + (ntr*zeig%coh%x_sap + ntr*zeig%coh%x_hrt) &
+ /(spar(ns)%prhos*1000000) ! conversion kg/patch ---m³/ha
+
+ nd = zeig%coh%nDaysGr
+ if (nd .gt. 0) drIndAl = drIndAl + ntr * zeig%coh%drIndAl * zeig%coh%NPP / nd
+
+ endif
+
+ if(zeig%coh%ident > coh_ident_max) then
+ anz_tree_in = anz_tree_in + ntr
+ sumbio_in = sumbio_in + ntr * zeig%coh%totBio
+ anz_coh_in = anz_coh_in + 1
+ helpin(ns) = ns
+ lai_in = lai_in + ntr * zeig%coh%t_leaf/kpatchsize
+ totfol_in = totfol_in + ntr * zeig%coh%x_fol
+ med_diam_in = med_diam_in + ntr * (zeig%coh%diam**2)
+ hmean_in = hmean_in + ntr * zeig%coh%height
+ totfrt = totfrt + ntr * zeig%coh%x_frt
+ endif
+
+ if((zeig%coh%nTreeD > 0.1) .or. (zeig%coh%nTreeM > 0.1) .or. (zeig%coh%nTreet > 0.1)) then
+ hanz = zeig%coh%nTreeD + zeig%coh%nTreeM + zeig%coh%nTreet
+ anz_tree_out = anz_tree_out + hanz
+ sumbio_out = sumbio_out + hanz * zeig%coh%totBio
+ sumNPP = sumNPP + hanz * zeig%coh%NPP ! eliminated (died or harvested) trees produce during the year as well;
+ autresp = autresp + hanz * zeig%coh%maintres
+ anz_coh_out = anz_coh_out + 1
+ helpout(ns) = ns
+ lai_out = lai_out + hanz * zeig%coh%t_leaf/kpatchsize
+ totfol_out = totfol_out + hanz * zeig%coh%x_fol
+ med_diam_out = med_diam_out + hanz * (zeig%coh%diam**2)
+ hmean_out = hmean_out + hanz * zeig%coh%height
+ endif
+
+ else
+ ntr = zeig%coh%ntreeA
+ anz_sveg = anz_sveg +1
+ zeig%coh%totBio = zeig%coh%x_fol + (1.+spar(ns)%alphac)*(zeig%coh%x_sap + zeig%coh%x_hrt) + zeig%coh%x_frt
+ sumbio_sv = sumbio_sv + ntr * zeig%coh%totBio
+ totfrt_p = totfrt_p + ntr * zeig%coh%x_frt
+ end if !only trees
+ zeig=>zeig%next
+end do
+
+ if (flag_cumNPP .eq. 1) then
+
+ cum_sumNPP = cum_sumNPP + sumNPP
+
+ flag_cumNPP = 0
+
+ endif
+
+
+ if (sumNPP .gt. 1E-06) drIndAl = drIndAl / sumNPP
+
+! conversion kg/patch ---> kg/ha; N/patch ---> N/ha
+ conv = 10000./kpatchsize
+
+ totfrt_p = totfrt_p + totfrt ! Rootmass f. patch (trees and soil veg.) save before conversion; Wurzelmenge vor Umrechnung sichern
+ if (totfrt_p .gt. zero) then
+ totfrt_1 = 1./totfrt_p ! reciprocal for later calculationshKehrwert f. spaetere Berechnungen
+ else
+ totfrt_1 = 0.
+ endif
+ totfrt = totfrt * conv
+ totfol = totfol * conv
+ totfol_in = totfol_in * conv
+ totfol_out = totfol_out * conv
+ tottb = tottb * conv
+ totsap = totsap * conv
+ tothrt = tothrt * conv
+ totcrt = totcrt * conv
+ sumbio = sumbio * conv
+ sumbio_in = sumbio_in * conv
+ sumbio_out = sumbio_out * conv
+ sumbio_sv = sumbio_sv * conv
+ Ndem = Ndem / kpatchsize ! g per tree --> g/m2
+ totstem_m3 = totstem_m3* conv ! m3/ha
+ anz_tree_ha = anz_tree * conv
+ anz_tree_in = anz_tree_in * conv
+ anz_tree_out = anz_tree_out * conv
+
+ do i=1, nspec_tree+1 ! for all but mistletoe
+ if (helpin(i) > 0) anz_spec_in = anz_spec_in + 1
+ if (helpout(i) > 0) anz_spec_out = anz_spec_out + 1
+ enddo
+
+ if(anz_tree_in > 0.) then
+ med_diam_in = sqrt(med_diam_in/anz_tree_in)
+ hmean_in = hmean_in / anz_tree_in
+ endif
+ if(anz_tree_out > 0.) then
+ med_diam_out = sqrt(med_diam_out/anz_tree_out)
+ hmean_out = hmean_out / anz_tree_out
+ endif
+
+! call species values
+call classt
+
+call stand_bal_spec
+
+call calc_ind_rep
+!call classification of stand diameter and height
+
+call class
+
+! moving of understorey tree cohorts to overstorey tree cohorts
+
+
+if(flag_mg.ne.33) call overstorey
+contains
+
+!**************************************************************
+
+subroutine update_age
+
+if(flag_standup.ne. 2) then
+zeig=>pt%first
+do
+if(.not.associated(zeig)) exit
+zeig%coh%x_age=zeig%coh%x_age + 1
+zeig=>zeig%next
+end do
+end if
+end subroutine update_age
+
+end subroutine stand_balance
+
+!**************************************************************
+
+subroutine stand_bal_spec
+
+use data_climate
+use data_out
+use data_simul
+use data_site
+use data_stand
+use data_species
+use data_par
+use data_manag
+
+implicit none
+
+integer :: i, j, k, ntr, nd, lowtree, hntr, spec_new
+real,dimension(nspec_tree):: vgldom1, vgldom2, vgldom_spec1, vgldom_spec2
+integer,dimension(nspec_tree):: anzdom1, anzdom2, anzdom_spec1, anzdom_spec2, &
+ helpdiam
+integer,dimension(nspecies):: helpanz
+integer helpntr
+integer help_nr_inf_trees
+logical lhelp
+INTEGER leapyear
+real atemp, hh, help_height_top
+real triangle
+real, external :: daylength
+
+if (flag_trace) write (unit_trace, '(I4,I10,A)') iday, time, ' stand_bal_spec'
+
+! Initialisation
+vgldom1 = 0.
+vgldom2 = 0.
+anzdom1 = 0
+anzdom2 = 0
+med_diam = 0.
+mean_diam = 0.
+mean_height = 0.
+hdom = 0. ! dominante height (highest or two highest cohorst); Hoehe (hoehste oder die beiden hoechsten Kohorten)
+
+anz_spec = 0 ! currently existing species
+lowtree = 0 ! amount of trees with DBH=0 for the whole population; Anzahl Baeume mit DBH = 0 fuer gesamten Bestand
+hntr = 0
+helpanz = 0 ! auxiliary variable to count species; Hilfsvariable um Spezies zu zaehlen
+helpdiam = 0 ! amount of trees with DBH=0 per species; Anzahl Baeume mit DBH = 0 pro Spezies
+vgldom_spec1 = 0.
+vgldom_spec2 = 0.
+anzdom_spec1 = 0
+anzdom_spec2 = 0
+
+svar%med_diam = 0.
+svar%mean_diam = 0.
+svar%mean_jrb = 0.
+svar%mean_height= 0.
+svar%basal_area = 0.
+svar%sumNPP = 0.
+svar%Ndem = 0.
+svar%Nupt = 0.
+svar%sum_ntreea = 0.
+svar%sum_ntreed = 0.
+svar%sum_bio = 0.
+svar%sum_lai = 0.
+svar%anz_coh = 0.
+svar%drIndAl = 0.
+svar%totsteminc = 0.
+svar%totsteminc_m3 = 0.
+svar%fol = 0.
+svar%sap = 0.
+svar%hrt = 0.
+svar%frt = 0.
+
+
+ !update height of mistletoe to height of mistletoe-infected cohort
+ if (flag_mistle.ne.0) then
+ zeig => pt%first
+ DO WHILE (ASSOCIATED(zeig))
+ if (zeig%coh%mistletoe.eq.1) then
+ help_height_top=zeig%coh%height
+ end if
+ zeig => zeig%next
+ ENDDO
+ zeig => pt%first
+ DO WHILE (ASSOCIATED(zeig))
+ if (zeig%coh%species.eq.nspec_tree+2) then
+ zeig%coh%height = help_height_top !upper crown
+ zeig%coh%x_hbole = zeig%coh%height-50. !lower crown
+ end if
+ zeig => zeig%next
+ ENDDO
+ end if ! end update of height of Mistletoe
+
+ ! update of #of mistletoe upon dist_manag
+ if (flag_mistle.ne.0) then
+ zeig => pt%first
+ DO WHILE (ASSOCIATED(zeig))
+ if (zeig%coh%mistletoe.eq.1) then
+ help_nr_inf_trees=zeig%coh%nTreeA
+ end if
+ zeig => zeig%next
+ ENDDO
+
+ zeig => pt%first
+ DO WHILE (ASSOCIATED(zeig))
+ if (zeig%coh%species.eq.nspec_tree+2) then
+ zeig%coh%nTreeA= help_nr_inf_trees*AMAX1(1.,dis_rel(time))
+ zeig%coh%nta=zeig%coh%nTreeA
+ end if
+ zeig => zeig%next
+ ENDDO
+ end if ! end update #of mistletoe
+
+ zeig => pt%first
+ DO WHILE (ASSOCIATED(zeig))
+
+ ns = zeig%coh%species
+ helpanz(ns) = helpanz(ns) + 1 ! all species incl. ground vegetation;
+
+ IF(zeig%coh%ident .le. coh_ident_max) THEN
+ ntr = zeig%coh%ntreea
+
+ IF(ns .le. nspec_tree) THEN
+!
+ IF((ns .le. nspec_tree) .and. (ntr > 0.) .and. (zeig%coh%diam > 0.)) THEN
+ svar(ns)%med_diam = svar(ns)%med_diam + ntr * (zeig%coh%diam**2)
+ med_diam = med_diam + ntr * (zeig%coh%diam**2)
+ mean_diam = mean_diam + ntr*zeig%coh%diam
+ svar(ns)%mean_diam = svar(ns)%mean_diam + ntr*zeig%coh%diam
+ svar(ns)%mean_height = svar(ns)%mean_height + ntr*zeig%coh%height
+ svar(ns)%mean_jrb = svar(ns)%mean_jrb + ntr*zeig%coh%jrb
+ mean_height = mean_height + ntr*zeig%coh%height
+ hntr = hntr + ntr
+
+ ELSE
+ ! Trees with DBH=0 for population and per species; Baeume mit DBH =0 fuer Bestand und pro Spezies
+ lowtree = lowtree + ntr
+ helpdiam(ns) = helpdiam(ns) + ntr
+ ENDIF ! ns
+ IF(zeig%coh%height > vgldom1(ns)) THEN
+ vgldom2(ns) = vgldom1(ns)
+ anzdom2(ns) = anzdom1(ns)
+ vgldom1(ns) = zeig%coh%height
+ anzdom1(ns) = ntr
+ ELSE
+ if(zeig%coh%height > vgldom2(ns))then
+ vgldom2(ns) = zeig%coh%height
+ anzdom2(ns) = ntr
+ endif
+ ENDIF ! vgldom1
+ IF(zeig%coh%height > vgldom_spec1(ns)) THEN
+ vgldom_spec2(ns) = vgldom_spec1(ns)
+ anzdom_spec2(ns) = anzdom_spec1(ns)
+ vgldom_spec1(ns) = zeig%coh%height
+ anzdom_spec1(ns) = ntr
+ ELSE
+ if(zeig%coh%height > vgldom_spec2(ns))then
+ vgldom_spec2(ns) = zeig%coh%height
+ anzdom_spec2(ns) = ntr
+ endif
+ ENDIF ! vgldom_spec2
+ ELSE
+ svar(ns)%dom_height = zeig%coh%height
+ ENDIF ! end loop across trees
+
+ svar(ns)%sumNPP = svar(ns)%sumNPP + ntr * zeig%coh%NPP
+ svar(ns)%sum_ntreea = svar(ns)%sum_ntreea + ntr
+ svar(ns)%sum_ntreed = svar(ns)%sum_ntreed + zeig%coh%nTreeD + zeig%coh%nTreeM ! died or harvested trees of current year; ausgeschiedene Bäume des akt. Jahres
+ svar(ns)%Ndem = svar(ns)%Ndem + ntr * zeig%coh%Ndemc_c
+ svar(ns)%Nupt = svar(ns)%Nupt + ntr * zeig%coh%Nuptc_c
+ svar(ns)%sum_bio = svar(ns)%sum_bio + ntr * zeig%coh%totBio
+ svar(ns)%sum_lai = svar(ns)%sum_lai + ntr * zeig%coh%t_leaf/kpatchsize
+ svar(ns)%anz_coh = svar(ns)%anz_coh + 1
+ svar(ns)%totsteminc = svar(ns)%totsteminc + ntr * zeig%coh%stem_inc
+ if (zeig%coh%species.ne.nspec_tree+2) then !no stem increment for mistletoe
+ svar(ns)%totsteminc_m3 = svar(ns)%totsteminc_m3 + ntr * zeig%coh%stem_inc /(spar(ns)%prhos*1000000)
+ endif
+ svar(ns)%fol = svar(ns)%fol + ntr * zeig%coh%x_fol
+ svar(ns)%sap = svar(ns)%sap + ntr * zeig%coh%x_sap
+ svar(ns)%hrt = svar(ns)%hrt + ntr * zeig%coh%x_hrt
+ svar(ns)%frt = svar(ns)%frt + ntr * zeig%coh%x_frt
+ nd = zeig%coh%nDaysGr
+ if (nd .gt. 0) svar(ns)%drIndAl = svar(ns)%drIndAl + ntr * zeig%coh%drIndAl * zeig%coh%NPP / nd
+
+ ENDIF ! coh%ident
+
+ zeig%coh%ntreed = 0.
+ zeig%coh%ntreem = 0.
+ zeig => zeig%next
+ ENDDO ! cohort loop
+
+ ! neue Spezies feststellen und belegen
+ if (time .gt. 1) then
+ do i=1,nspecies
+ if (helpanz(i) > 0) then
+ spec_new = 0
+ lhelp = .True.
+ do j=1,anrspec
+ if (nrspec(j) .eq. i) lhelp = .False.
+ enddo
+ if (lhelp) then
+ spec_new = i
+ if(spec_new.le.nspec_tree) then
+ IF(spar(spec_new)%Phmodel==1) THEN
+ svar(spec_new)%Pro = 0.
+ svar(spec_new)%Inh = 1.
+ ELSE
+ svar(spec_new)%Pro = 0.
+ svar(spec_new)%Inh = 0.
+ svar(spec_new)%Tcrit = 0.
+ END IF
+
+ ! initialize pheno state variables with climate from the actual year
+ do j = spar(ns)%end_bb+1, 365
+
+ atemp = tp(j, time)
+ hh = DAYLENGTH(j,lat)
+ SELECT CASE(ns)
+ CASE(1,8)
+ !Fagus
+ ! Promotor-Inhibitor model 11
+ svar(ns)%Pro = svar(ns)%Pro + spar(ns)%PPa* &
+ triangle(spar(ns)%PPtmin,spar(ns)%PPtopt,spar(ns)%PPtmax,atemp)* &
+ (1-svar(ns)%Inh)*hh/24 - &
+ spar(ns)%PPb*svar(ns)%Pro*(24-hh)/24
+
+ svar(ns)%Inh = svar(ns)%Inh - spar(ns)%PIa*&
+ triangle(spar(ns)%PItmin,spar(ns)%PItopt,spar(ns)%PItmax,atemp)* &
+ svar(ns)%Inh*hh/24
+
+ CASE(4)
+ ! Quercus
+ ! Promotor-Inhibitor model 12
+ svar(ns)%Pro = svar(ns)%Pro + spar(ns)%PPa* &
+ triangle(spar(ns)%PPtmin,spar(ns)%PPtopt,spar(ns)%PPtmax,atemp)* &
+ (1-svar(ns)%Inh)*hh/24
+
+ svar(ns)%Inh = svar(ns)%Inh - spar(ns)%PIa* &
+ triangle(spar(ns)%PItmin,spar(ns)%PItopt,spar(ns)%PItmax,atemp)* &
+ svar(ns)%Inh*hh/24 + spar(ns)%PPb*(24-hh)/24
+
+ CASE(5, 11)
+ ! Betula, Robinia
+ IF(spar(ns)%Phmodel==1) THEN
+ ! Promotor-Inhibitor model 2
+
+ svar(ns)%Pro = svar(ns)%Pro + spar(ns)%PPa* &
+ triangle(spar(ns)%PPtmin,spar(ns)%PPtopt,spar(ns)%PPtmax,atemp)* &
+ (1-svar(ns)%Inh) - spar(ns)%PPb*svar(ns)%Pro*(24-hh)/24
+
+ svar(ns)%Inh = svar(ns)%Inh - spar(ns)%PIa* &
+ triangle(spar(ns)%PItmin,spar(ns)%PItopt,spar(ns)%PItmax,atemp)*svar(ns)%Inh
+
+ END IF
+
+ END SELECT
+ Enddo
+
+
+
+
+
+ IF(spar(spec_new)%phmodel==4) THEN
+ svar(spec_new)%daybb = svar(spec_new)%ext_daybb
+ ELSE
+ svar(spec_new)%daybb = 181 + leapyear(time_cur)
+ ENDIF
+
+ endif
+ endif
+ endif
+ enddo
+ endif ! time
+
+ k = 0
+do i=1,nspecies
+
+ if (helpanz(i) > 0) then
+ k = k + 1
+ anrspec = k
+ nrspec(k) = i
+ endif
+
+ ntr = svar(i)%sum_ntreea
+
+ if (svar(i)%sumNPP .gt. 1E-06) svar(i)%drIndAl = svar(i)%drIndAl / svar(i)%sumNPP
+
+ if (i .le. nspec_tree) then
+ IF(helpanz(i) > 0) THEN
+ anz_spec = anz_spec + 1
+ IF(helpdiam(i) < ntr) THEN
+ svar(i)%med_diam = SQRT(svar(i)%med_diam / (ntr - helpdiam(i)))
+
+ ENDIF
+
+ svar(i)%Ndem = svar(i)%Ndem / kpatchsize ! g per tree --> g/m2
+ svar(i)%Nupt = svar(i)%Nupt / kpatchsize ! g per tree --> g/m2
+
+ if (ntr .ne. 0) then
+ svar(i)%mean_height = svar(i)%mean_height / ntr
+ svar(i)%mean_diam = svar(i)%mean_diam / ntr
+ svar(i)%mean_jrb = svar(i)%mean_jrb / ntr
+
+ svar(i)%basal_area = pi*ntr*(svar(i)%med_diam*svar(i)%med_diam/40000)*10000/kpatchsize
+ else
+ svar(i)%sum_ntreea = 0.
+ endif
+
+ call calc_heidom_spec(i)
+ ENDIF
+
+ end if ! nspec_tree
+
+! conversion kg/patch ---> kg/ha; N/patch ---> N/ha
+ helpntr = svar(i)%sum_nTreeA* 10000./kpatchsize
+ if(helpntr.eq.0 .and. svar(i)%sum_nTreeA.eq.1) then
+ svar(i)%sum_nTreeA = 1
+ else
+ svar(i)%sum_nTreeA = helpntr
+
+ end if
+ svar(i)%sum_bio = svar(i)%sum_bio * 10000./kpatchsize
+ svar(i)%fol = svar(i)%fol * 10000./kpatchsize
+ svar(i)%sap = svar(i)%sap* 10000./kpatchsize
+ svar(i)%hrt= svar(i)%hrt* 10000./kpatchsize
+ svar(i)%frt= svar(i)%frt* 10000./kpatchsize
+ svar(i)%totstem_m3= ( svar(i)%sap + svar(i)%hrt)/ (spar(i)%prhos*1000000) ! m3/ha
+ svar(i)%totsteminc = svar(i)%totsteminc * 10000./kpatchsize ! kg/ha
+ svar(i)%totsteminc_m3 = svar(i)%totsteminc_m3 * 10000./kpatchsize ! kg/ha
+ totsteminc_m3 = totsteminc_m3 + svar(i)%totsteminc_m3
+ totsteminc = totsteminc + svar(i)%totsteminc
+
+ end do
+
+! new calculation of dominant height
+call calc_heidom
+
+
+if(anz_tree>0)then
+ if(lowtree<anz_tree) then
+ med_diam = sqrt(med_diam /(anz_tree-lowtree))
+ mean_diam = mean_diam /(anz_tree-lowtree)
+ mean_height = mean_height /(anz_tree-lowtree)
+ basal_area = pi*(anz_tree-lowtree)*(med_diam*med_diam/40000)*10000/kpatchsize
+ endif
+else
+ if (hntr .ne. 0) then
+ med_diam = sqrt(med_diam /hntr)
+ mean_diam = mean_diam / hntr
+ mean_height = mean_height / hntr
+ else
+ med_diam = 0.
+ mean_diam = 0.
+ mean_height = 0.
+ endif
+endif
+
+end subroutine stand_bal_spec
+
+!**************************************************************
+
+subroutine class
+use data_stand
+use data_simul
+use data_species
+use data_par
+implicit none
+integer i,k
+
+
+diam_class=0;height_class=0
+diam_class_age=0.
+diam_class_h = 0.
+zeig=>pt%first
+
+do
+ if(.not.associated(zeig)) exit
+ k = zeig%coh%species
+ if (k.ne.nspec_tree+2) then !exclusion of mistletoe
+ if(zeig%coh%diam<=dclass_w) then
+ diam_class(1,k)=diam_class(1,k)+zeig%coh%ntreea
+ diam_class_h(1,k) = diam_class_h(1,k) + zeig%coh%ntreea*zeig%coh%height
+ diam_class_age(1,k) = diam_class_age(1,k)+zeig%coh%x_age*zeig%coh%ntreea
+ end if
+ do i=2,num_class
+ if(zeig%coh%diam.le.(dclass_w + dclass_w*(i-1)) .and. zeig%coh%diam>(dclass_w + dclass_w*(i-2))) then
+ diam_class(i,k)=diam_class(i,k) + zeig%coh%ntreea
+ diam_class_h(i,k) = diam_class_h(i,k) + zeig%coh%ntreea*zeig%coh%height
+ diam_class_age(i,k) = diam_class_age(i,k)+zeig%coh%x_age*zeig%coh%ntreea
+
+ else if(zeig%coh%diam.gt. (dclass_w + dclass_w*(num_class-2))) then
+ diam_class(num_class,k)=diam_class(num_class,k) + zeig%coh%ntreea
+ diam_class_h(num_class,k) = diam_class_h(num_class,k) + zeig%coh%ntreea*zeig%coh%height
+ diam_class_age(num_class,k) = diam_class_age(num_class,k) + zeig%coh%x_age+zeig%coh%ntreea
+ exit
+ end if
+ enddo
+
+ if(zeig%coh%height<=100) height_class(1) = height_class(1)+zeig%coh%ntreea
+ if(zeig%coh%height>100.and.zeig%coh%height<500) height_class(2) = height_class(2)+zeig%coh%ntreea
+ do i=3,num_class-2
+ if(zeig%coh%height>(i+2)*100.and.zeig%coh%height<=(i+3)*100) height_class(i) = height_class(i)+zeig%coh%ntreea
+ enddo
+ if(zeig%coh%height>5000.and.zeig%coh%height<5500) height_class(num_class-1) = height_class(num_class-1)+zeig%coh%ntreea
+ if(zeig%coh%height>5500) height_class(num_class) = height_class(num_class)+zeig%coh%ntreea
+
+ endif!exclusion of mistletoe
+ zeig=>zeig%next
+
+enddo
+
+do i=1,num_class
+ do k=1,nspec_tree
+ if(diam_class(i,k).ne.0) diam_class_h(i,k) = (diam_class_h(i,k)/diam_class(i,k))*10000./kpatchsize
+ if(diam_class_age(i,k).ne.0.and.diam_class(i,k).ne.0 ) diam_class_age(i,k) =diam_class_age(i,k)/diam_class(i,k)
+ diam_class(i,k) = diam_class(i,k)*10000./kpatchsize
+ end do
+end do
+end subroutine class
+
+!**************************************************************
+
+subroutine classt
+use data_stand
+use data_simul
+use data_species
+implicit none
+integer i,k
+
+diam_class_t=0;height_class=0
+diam_class_h = 0.
+zeig=>pt%first
+do
+ if(.not.associated(zeig)) exit
+ k = zeig%coh%species
+ if (k.ne.nspec_tree+2) then ! exclusion mistletoe
+ if(zeig%coh%diam<=dclass_w) then
+ diam_class_t(1,k)=diam_class_t(1,k)+zeig%coh%ntreed
+ end if
+ do i=2,num_class
+ if(zeig%coh%diam.le.(dclass_w + dclass_w*(i-1)) .and. zeig%coh%diam>(dclass_w + dclass_w*(i-2))) then
+ diam_class_t(i,k)=diam_class_t(i,k) + zeig%coh%ntreed
+
+ else if(zeig%coh%diam.gt. (dclass_w + dclass_w*(num_class-2))) then
+ diam_class_t(num_class,k)=diam_class_t(num_class,k) + zeig%coh%ntreed
+ exit
+ end if
+ enddo
+
+ endif !exclusion of mistletoe
+ zeig=>zeig%next
+
+enddo
+
+do i=1,num_class
+ do k=1,nspec_tree
+ diam_class_t(i,k)=diam_class_t(i,k)*10000./kpatchsize
+ end do
+end do
+end subroutine classt
+
+!**************************************************************
+
+
+subroutine class_man
+use data_stand
+use data_simul
+use data_species
+use data_manag
+implicit none
+integer i , k
+real anz
+diam_classm=0
+diam_classm_h=0.
+diam_class_mvol = 0.
+
+ zeig=>pt%first
+ do
+ if(.not.associated(zeig)) exit
+ if(zeig%coh%ntreem.ne.0.or.(zeig%coh%ntreed.gt.0 .and. zeig%coh%diam.gt.tardiam_dstem)) then
+ if(zeig%coh%diam.le.tardiam_dstem) then
+ anz = zeig%coh%ntreem
+ else
+ anz = zeig%coh%ntreem + zeig%coh%ntreed
+ end if
+ k = zeig%coh%species
+
+ if(zeig%coh%diam<=dclass_w) then
+ diam_classm(1,k)=diam_classm(1,k)+anz
+ diam_classm_h(1,k) = diam_classm_h(1,k) + anz*zeig%coh%height
+ diam_class_mvol(1,k) = diam_class_mvol(1,k) +anz*(zeig%coh%x_sap + zeig%coh%x_hrt)
+ end if
+
+ if(zeig%coh%diam<=dclass_w*2.and.zeig%coh%diam.gt.dclass_w) then
+ diam_classm(2,k)=diam_classm(2,k)+anz
+ diam_classm_h(2,k) = diam_classm_h(2,k) + anz*zeig%coh%height
+ diam_class_mvol(2,k) = diam_class_mvol(2,k) + anz*(zeig%coh%x_sap + zeig%coh%x_hrt)
+ end if
+
+ do i=3,num_class
+ if(zeig%coh%diam.le.(dclass_w*2 + dclass_w*(i-2)) .and. zeig%coh%diam>(dclass_w*2 + dclass_w*(i-3))) then
+ diam_classm(i,k) = diam_classm(i,k) + anz
+ diam_classm_h(i,k) = diam_classm_h(i,k) + anz*zeig%coh%height
+ diam_class_mvol(i,k) = diam_class_mvol(i,k) + anz*(zeig%coh%x_sap + zeig%coh%x_hrt)
+
+
+ else if(zeig%coh%diam.gt. (dclass_w*2 + dclass_w*(num_class-3))) then
+ diam_classm(num_class,k)=diam_classm(num_class,k) + anz
+ diam_classm_h(num_class,k) = diam_classm_h(num_class,k) + anz*zeig%coh%height
+ diam_class_mvol(num_class,k) = diam_class_mvol(num_class,k) + anz*(zeig%coh%x_sap + zeig%coh%x_hrt)
+
+ end if
+ enddo
+ end if
+ zeig=>zeig%next
+ enddo
+
+do i=1,num_class
+ do k=1,nspecies
+
+ if(diam_classm(i,k).ne.0) diam_classm_h(i,k) = diam_classm_h(i,k)/diam_classm(i,k)
+ if(diam_class_mvol(i,k).ne.0.) then
+ diam_class_mvol(i,k) = diam_class_mvol(i,k)/(spar(k)%prhos*1000000)*10000/kpatchsize
+ end if
+ diam_classm(i,k) = diam_classm(i,k)*10000./kpatchsize
+ end do
+end do
+end subroutine class_man
+
+!**************************************************************
+
+subroutine calc_heidom
+
+ use data_out
+ use data_simul
+ use data_stand
+
+ implicit none
+
+ real :: mh
+
+ integer :: nhelp, &
+ nh1,nh2, &
+ testflag=0, &
+ j
+
+ allocate (height_rank(anz_coh))
+
+ nh1=0
+ nh2=0
+ mh = 0
+ testflag = 0
+ nhelp = nint(kpatchsize/100)
+ if(anz_tree.le.nhelp) nhelp = anz_tree
+
+! sorting by height of cohorts
+ call dimsort(anz_coh, 'height',height_rank)
+
+ if(anz_tree>1) then
+ do j=anz_coh, 1,-1
+ call dimsort(anz_coh, 'height',height_rank)
+
+ zeig=>pt%first
+ do
+ if(.not.associated(zeig)) exit
+ if(zeig%coh%ident.eq.height_rank(j)) then
+ nh2 = nh1
+ nh1 = nh1 + zeig%coh%ntreea
+ if(nh1.le. nhelp) then
+ mh = mh + zeig%coh%ntreea*zeig%coh%height
+ else
+ mh = mh + zeig%coh%height*( nhelp - nh2)
+ testflag=1
+ exit
+ end if
+ endif
+ zeig=>zeig%next
+ if(testflag.eq.1) exit
+ end do
+ if(testflag.eq.1) exit
+ if(nh1.eq.nhelp) exit
+ end do
+ if (nhelp.lt. nh1) then
+ hdom = mh/nhelp
+ else
+ hdom = mh/nh1
+ end if
+ end if
+ deallocate(height_rank)
+end subroutine calc_heidom
+
+!**************************************************************
+
+ subroutine calc_heidom_spec(ispec)
+
+!*****************************************************
+! species specific dominant height calculation
+!*****************************************************
+
+ use data_out
+ use data_simul
+ use data_stand
+
+ implicit none
+
+ real :: mh
+
+ integer :: nhelp, &
+ nh1,nh2, &
+ testflag=0, &
+ j, &
+ ispec
+
+ allocate (height_rank(anz_coh))
+ hdom = 0
+ nh1=0
+ nh2=0
+ mh = 0
+ testflag = 0
+! calculation of number of trees used for H100 ( 100/ ha = nhelp/ kpachtsize)
+ nhelp = nint(kpatchsize/100)
+ if(anz_tree.le.nhelp) nhelp = anz_tree
+
+! sorting by height of cohorts
+ call dimsort(anz_coh, 'height',height_rank)
+
+ if(anz_tree>1) then
+ do j=anz_coh, 1,-1
+ call dimsort(anz_coh, 'height',height_rank)
+
+ zeig=>pt%first
+ do
+ if(.not.associated(zeig)) exit
+ if(zeig%coh%ident.eq.height_rank(j).and. zeig%coh%species.eq.ispec) then
+ nh2 = nh1
+ nh1 = nh1 + zeig%coh%ntreea
+ if(nh1.le. nhelp) then
+ mh = mh + zeig%coh%ntreea*zeig%coh%height
+ else
+ mh = mh + zeig%coh%height*( nhelp - nh2)
+ testflag=1
+ exit
+ end if
+ endif
+ zeig=>zeig%next
+ if(testflag.eq.1) exit
+ end do
+ if(testflag.eq.1) exit
+ if(nh1.eq.nhelp) exit
+ end do
+ if (nhelp.lt. nh1.and. nhelp.ne.0) then
+ hdom = mh/nhelp
+ else if(nh1.ne.0) then
+ hdom = mh/nh1
+ end if
+ else if(anz_tree.eq.1) then
+ zeig=>pt%first
+ do
+ if(.not.associated(zeig)) exit
+ if(zeig%coh%species.eq.ispec) hdom=zeig%coh%height
+ zeig=>zeig%next
+ end do
+ end if
+ deallocate(height_rank)
+ svar(ispec)%dom_height = hdom
+
+end subroutine calc_heidom_spec
+
+!**************************************************************
+
+subroutine max_height(nrmax,anz,cohl)
+
+ use data_out
+ use data_simul
+ use data_stand
+
+ implicit none
+
+ integer :: nrmax
+ integer :: nrmax_h
+ integer :: anz, testflag,i
+ real :: help_h1, help_h2
+ integer,dimension(0:anz_coh) :: cohl
+
+ testflag=0
+ nrmax = -1
+ nrmax_h = -1
+ help_h2=0.
+ help_h1=0.
+ zeig=>pt%first
+ do
+ if(.not.associated(zeig)) exit
+ do i=0,anz-1
+ if(cohl(i).eq.zeig%coh%ident) then
+ testflag=1
+ endif
+ end do
+ if (testflag.eq.0) then
+ help_h2= zeig%coh%height
+ nrmax_h = zeig%coh%ident
+ if(help_h2.gt. help_h1) then
+ help_h1 = help_h2
+ nrmax = nrmax_h
+ end if
+
+ end if
+
+ zeig=>zeig%next
+ testflag = 0
+ end do
+ anz = anz +1
+ cohl(anz-1) = nrmax
+
+end subroutine max_height
+
+!**************************************************************
+
+SUBROUTINE standup
+
+! update of stand variables (LAI, cover, waldtyp)
+
+USE data_par
+USE data_stand
+USE data_soil
+USE data_species
+use data_out
+use data_simul
+
+implicit none
+
+integer i
+REAL :: sumfol_can = 0.
+REAL :: sumfol_sveg= 0.
+REAL :: ntr, cover3
+
+! estimating degree of covering
+
+ if (flag_trace) write (unit_trace, '(I4,I10,A)') iday, time, ' standup'
+
+cover3 = 0.
+sumfol_can = 0.
+sumfol_sveg= 0.
+crown_area = 0.
+
+do i = 1, anrspec
+ svar(nrspec(i))%crown_area = 0.
+enddo
+
+zeig=>pt%first
+do
+ IF(.not.associated(zeig)) exit
+ if (zeig%coh%crown_area .ge. 0) then
+ ntr = zeig%coh%nTreeA
+ ns = zeig%coh%species
+ cover3 = cover3 + ntr * zeig%coh%crown_area
+ if (ns .le. nspec_tree) then
+ sumfol_can = sumfol_can + ntr * zeig%coh%x_fol
+ crown_area = crown_area + ntr * zeig%coh%crown_area
+ else
+ sumfol_sveg = sumfol_sveg + ntr * zeig%coh%x_fol
+ endif
+ svar(ns)%crown_area = svar(ns)%crown_area + ntr * zeig%coh%crown_area
+ endif
+ zeig=>zeig%next
+end do
+
+cover3 = cover3 / kpatchsize
+
+anz_tree = 0
+zeig=>pt%first
+do
+ IF(.not.associated(zeig)) exit
+ ns=zeig%coh%species
+ if (ns .le. nspec_tree) then
+ zeig%coh%rel_fol = zeig%coh%ntreea * zeig%coh%x_fol/sumfol_can
+ ceppot_can = ceppot_can + zeig%coh%rel_fol * spar(ns)%ceppot_spec
+ anz_tree = anz_tree + zeig%coh%ntreea
+ else if (ns.eq.nspec_tree+1) then
+ zeig%coh%rel_fol = zeig%coh%ntreea * zeig%coh%x_fol/sumfol_sveg
+ ceppot_sveg = ceppot_sveg + zeig%coh%rel_fol * spar(ns)%ceppot_spec
+ endif
+ zeig=>zeig%next
+end do
+
+!Berechnung LAI und ceppot
+ceppot_can = 0.
+ceppot_sveg = 0.
+LAI_can = 0.
+LAI_sveg = 0.
+
+ DO i=1,anrspec
+ ns = nrspec(i)
+ IF (ns .le. nspec_tree) THEN
+ LAI_can = LAI_can + svar(ns)%act_sum_lai
+ ELSE
+ LAI_sveg = LAI_sveg + svar(ns)%act_sum_lai
+ ENDIF
+ ENDDO
+
+ DO i=1,anrspec
+ ns = nrspec(i)
+ IF (ns .le. nspec_tree) THEN
+ IF(LAI_can .gt. 0.) THEN
+ ceppot_can = ceppot_can + svar(ns)%act_sum_lai/LAI_can * spar(ns)%ceppot_spec
+ ELSE
+ ceppot_can = 0.
+ ENDIF
+ ELSE
+ IF(LAI_sveg .gt. 0.) THEN
+ ceppot_sveg = ceppot_sveg + svar(ns)%act_sum_lai/LAI_sveg * spar(ns)%ceppot_spec
+ ELSE
+ ceppot_sveg= 0.
+ ENDIF
+ END IF
+ ENDDO
+
+if (LAI .gt. 1.) then
+ cover = cover3
+else if (LAI .le. zero) then
+ cover = 0.1 * cover3
+else
+ cover = LAI * cover3 ! to combine with leave surface; an Blattflaeche koppeln
+endif
+call wclas(waldtyp) ! forest type
+
+END SUBROUTINE standup
+
+!******************************************************************************
+
+SUBROUTINE senescence
+
+! update of senescence rates
+
+USE data_stand
+USE data_species
+USE data_simul
+IMPLICIT NONE
+
+ ! senescence rates
+ zeig=>pt%first
+ DO
+ IF(.not.associated(zeig)) exit
+ if (zeig%coh%species.ne.nspec_tree+2) then ! exclude mistletoe from senescence
+ zeig%coh%sfol = spar(zeig%coh%species)%psf * zeig%coh%x_fol
+ zeig%coh%sfrt = spar(zeig%coh%species)%psr * zeig%coh%x_frt
+ IF (zeig%coh%height.ge.thr_height .and.zeig%coh%species.LE. nspec_tree) THEN
+ zeig%coh%ssap = spar(zeig%coh%species)%pss * zeig%coh%x_sap
+ ELSE
+ zeig%coh%ssap = 0
+ if(zeig%coh%species.GT.nspec_tree) zeig%coh%ssap = spar(zeig%coh%species)%pss*zeig%coh%x_sap
+ ENDIF
+ end if !exclusion of mistletoe
+ zeig=>zeig%next
+ END DO
+
+END SUBROUTINE senescence
+
+!**************************************************************
+
+SUBROUTINE litter
+
+! Calculation of summation variables of litter fractions
+
+use data_par
+use data_out
+use data_simul
+use data_soil
+use data_soil_cn
+use data_species
+use data_stand
+
+implicit none
+
+real hconvd
+integer taxnr, i
+
+if (flag_trace) write (unit_trace, '(I4,I10,A)') iday, time_cur, ' litter'
+
+zeig => pt%first
+do while (associated(zeig))
+ taxnr = zeig%coh%species
+ if(taxnr.le.nspec_tree) then
+ totfol_lit_tree = totfol_lit_tree + zeig%coh%litC_fol
+ totfrt_lit_tree = totfrt_lit_tree + zeig%coh%litC_frt
+ end if
+ totfol_lit = totfol_lit + zeig%coh%litC_fol
+ totfrt_lit = totfrt_lit + zeig%coh%litC_frt
+ tottb_lit = tottb_lit + zeig%coh%litC_tb
+ totcrt_lit = totcrt_lit + zeig%coh%litC_crt
+ totstem_lit = totstem_lit + zeig%coh%litC_stem
+
+ zeig => zeig%next
+enddo ! zeig (cohorts)
+
+! litter biomass: x kg C/tree to kg/ha (n*x*1000g/(kPatchSize m2)/cpart==> kg/ha)
+ hconvd = (1000*gm2_in_kgha) / (kpatchsize * cpart) !
+ totfrt_lit = totfrt_lit * hconvd
+ totfol_lit = totfol_lit * hconvd
+ tottb_lit = tottb_lit * hconvd
+ totcrt_lit = totcrt_lit * hconvd
+ totstem_lit = totstem_lit * hconvd
+ totfol_lit_tree = totfol_lit_tree * hconvd
+ totfrt_lit_tree = totfrt_lit_tree * hconvd
+
+do i = 1,nspec_tree
+ tottb_lit = tottb_lit + dead_wood(i)%C_tb(1)*gm2_in_kgha
+ totstem_lit = totstem_lit + dead_wood(i)%C_stem(1)*gm2_in_kgha
+enddo
+
+END subroutine litter
+
+!**************************************************************
+
+SUBROUTINE calc_ind_rep
+
+USE data_stand
+USE data_species
+USE data_simul
+implicit none
+
+ integer :: i
+ real :: hi
+ real, dimension(nspecies) :: rindex_spec
+ rindex1 = 0.
+ rindex2 = 0.
+
+ if(anz_spec.ne.0) then
+ hi = 1/real(anz_spec)
+ rindex_spec = 0.
+ do i = 1, nspecies
+
+ if(sumbio.ne.0) then
+ rindex_spec(i) = svar(i)%sum_bio/sumbio
+ end if
+
+ end do
+ rindex1 = 0.
+ rindex2 = 1.
+ do i = 1, nspecies
+ if(rindex_spec(i).ne.0) then
+ rindex1 = rindex1 + abs(hi -rindex_spec(i))
+ rindex2 = rindex2 * abs(hi -rindex_spec(i))
+ end if
+ end do
+
+
+ if(hi.ne.1) then
+ rindex1 = 1. - rindex1/(2*(1.-hi))
+ else
+ rindex1 = 0.
+ end if
+
+ rindex2 = rindex2**anz_spec
+ end if
+
+ END subroutine calc_ind_rep
+
+!**************************************************************
+
+SUBROUTINE overstorey
+
+ use data_out
+ USE data_stand
+ USE data_species
+ USE data_simul
+ implicit none
+
+ real,dimension(nspec_tree) :: mindbh, maxdbh, dminage, dmaxage
+ integer :: i, nrmin, taxnr, agedmin, agedmax
+ real :: dbhmin, dbhmax
+ integer :: anzoverst, nrmax
+
+ anzoverst = 0
+ mindbh=0.
+ do i =1,nspec_tree
+
+ call min_dbh(nrmin,dbhmin,agedmin, i)
+
+ mindbh(i) = dbhmin
+ dminage(i) = agedmin
+
+ call max_dbh(nrmax, dbhmax, agedmax, i)
+
+ maxdbh(i) = dbhmax
+ dmaxage(i) = agedmax
+ end do
+
+if (time.eq.0) then
+ zeig=>pt%first
+ do
+ IF(.not.associated(zeig)) exit
+ taxnr = zeig%coh%species
+
+ if(taxnr .le.nspec_tree) then
+ if(zeig%coh%x_age.lt. (dminage(taxnr) +20) .and. dminage(taxnr).lt. dmaxage(taxnr)) then
+ zeig%coh%underst =2
+ end if
+ end if
+
+ zeig=>zeig%next
+
+ end do
+
+else
+ zeig=>pt%first
+ do
+ IF(.not.associated(zeig)) exit
+ taxnr = zeig%coh%species
+
+ if(zeig%coh%height.gt. 130..and. zeig%coh%underst.eq.4) then
+ zeig%coh%underst = 2
+ end if
+ zeig=>zeig%next
+ end do
+
+end if ! time
+END SUBROUTINE overstorey
diff --git a/source_code/version2.2_windows/stand_mort.f b/source_code/version2.2_windows/stand_mort.f
new file mode 100755
index 0000000000000000000000000000000000000000..9a09954acdf3035adb40006960b27b9f4d9e4ff0
--- /dev/null
+++ b/source_code/version2.2_windows/stand_mort.f
@@ -0,0 +1,307 @@
+!*****************************************************************!
+!* *!
+!* 4C (FORESEE) Simulation Model *!
+!* *!
+!* *!
+!* Subroutines for: *!
+!* - stand_mort *!
+!* - int_mort intrinsic mortality rate *!
+!* - stress_mort stress mortality rate *!
+!* - int_mort_weib *!
+!* *!
+!* - Calculation of dead trees per cohort and species *!
+!* deterministic approach *!
+!* - relative mortality rate is determined by intr. mortality *!
+!* and stress mortality *!
+!* - stress mortality is calculated depending on *!
+!* npp, ystress, yhealth *!
+!* - intrinsic probability is optionally calculated on *!
+!* age of cohort *!
+!* - for each tree of the cohort mortality is decided *!
+!* by means of the Mortality probability and *!
+!* a uniformly distributed variable *!
+!* *!
+!* 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 *!
+!* *!
+!*****************************************************************!
+
+! input variables:
+! pro cohort NPP
+! state variables:
+! pro cohort nTreeA nTreeD
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+SUBROUTINE stand_mort
+USE data_stand
+USE data_species
+USE data_simul
+USE data_manag
+use data_out
+use data_par
+IMPLICIT NONE
+
+!local variables
+
+INTEGER :: flag_hgrowth
+INTEGER :: taxnr
+REAL :: intmort
+REAL :: strmort
+REAL :: totmort
+REAL :: totmort_m
+REAL :: besmort
+REAL :: ntdead
+REAL :: ntdead_m
+REAL :: nhelp
+REAL :: survpfunct
+INTEGER :: hage
+REAL :: besp1,besp2 ! parameters for besetting mortality
+real :: help1, help2
+real :: intmorth
+
+if (flag_trace) write (unit_trace, '(I4,I10,A)') iday, time_cur, ' stand_mort'
+
+if (flag_standup .eq. 0) flag_standup = 1 ! call stand_balance later
+
+ntdead=0.
+nhelp=0.
+ntdead_m=0
+
+
+flag_hgrowth=0
+sumvsdead = 0.
+sumvsdead_m3 = 0.
+besmort = 0
+strmort = 0.
+totmort = 0.
+svar%sumvsdead = 0
+svar%sumvsdead_m3 = 0.
+
+
+
+zeig=>pt%first
+DO
+IF(.not.associated(zeig)) exit
+IF (zeig%coh%height.ge.thr_height.and. zeig%coh%species.le.nspec_tree) then
+ taxnr=zeig%coh%species
+ IF(time.eq.1) then
+ zeig%coh%nta=zeig%coh%nTreeA
+ ELSE
+ IF (flag_mg.eq.1) then
+
+ IF (thin_year(act_thin_year-1).eq.(time-1)) zeig%coh%nta=zeig%coh%nTreeA
+ ELSE IF (flag_mg.eq.2) then
+ if(flag_adapm .eq. 1) zeig%coh%nta=zeig%coh%nTreeA
+ ENDIF
+ ENDIF
+
+ IF(zeig%coh%notViable) then
+ print*,time, zeig%coh%notViable
+ zeig%coh%nTreeD = zeig%coh%ntreeA
+ zeig%coh%nta = 0.
+ zeig%coh%ntreeA = 0
+ goto 1000
+ ENDIF
+! calculation of stress and health indicator based on foliage biomass increment
+
+ hage = zeig%coh%x_age
+ IF (flag_hgrowth==0) THEN
+ IF(zeig%coh%fol_inc.le.0.0) then
+ zeig%coh%x_stress = zeig%coh%x_stress + 1
+ zeig%coh%x_health= 0
+ ELSE
+ zeig%coh%x_health = zeig%coh%x_health + 1
+ IF(zeig%coh%x_stress.eq.1.and. zeig%coh%x_health.gt.0) zeig%coh%nta = zeig%coh%ntreeA
+ IF(zeig%coh%x_stress .gt.0) zeig%coh%x_stress = zeig%coh%x_stress - 1
+ ENDIF
+ ENDIF
+ IF (flag_hgrowth==1) THEN
+ IF(zeig%coh%bio_inc.le.0.0) then
+ zeig%coh%x_stress = zeig%coh%x_stress + 1
+ zeig%coh%x_health= 0
+
+ ELSE
+ zeig%coh%x_health = zeig%coh%x_health + 1
+ IF(zeig%coh%x_stress.eq.1.and. zeig%coh%x_health.gt.0) zeig%coh%nta = zeig%coh%ntreeA
+ IF(zeig%coh%x_stress .gt.0) zeig%coh%x_stress = MAX(zeig%coh%x_stress - 3,0)
+ ENDIF
+ ENDIF
+
+! calculation of relative mortality rates
+! intrinsic mortality
+! constant
+ call int_mort(taxnr,intmorth)
+! age-depending using Weibull function
+ call int_mort_weib(taxnr,intmort,hage)
+! stress mortality
+ IF(zeig%coh%x_stress.gt.0) then
+ IF(flag_hgrowth==0) strmort = weibal*spar(taxnr)%weibla*zeig%coh%x_stress**(weibal-1)
+ IF(flag_hgrowth==1) strmort = weibal*spar(taxnr)%weibla*(zeig%coh%x_stress/3.)**(weibal-1)
+ ELSE
+ strmort = 0.
+ ENDIF
+
+!mortality depending on gross growth rate foliage
+ IF(strmort==0.0 .AND. flag_hgrowth==2) THEN
+ IF(zeig%coh%sfol/zeig%coh%gfol.GT.0.9) THEN
+ strmort=((zeig%coh%sfol/zeig%coh%gfol-0.9)*10.)**2
+ ELSE
+ ENDIF
+ ENDIF
+ if(strmort==0. .and. flag_hgrowth==3) then
+ help1 = 10**((log10(4.5)-log10((zeig%coh%x_sap + zeig%coh%x_hrt))*zeig%coh%ntreea)/1.5)
+ help2 = help1/zeig%coh%ntreea
+ end if
+
+! mortality caused by besetting for oak
+ besp1= 0.018
+ besp2= 0.0216
+
+ if(zeig%coh%species.eq.4) then
+ if( zeig%coh%bes.le. 1.2) then
+ besmort = 0.
+ else
+ besmort = besp1*zeig%coh%bes- besp2
+ end if
+ else if (zeig%coh%species.eq.1.) then
+ if(zeig%coh%bes.le. 1.2) then
+ besmort = 0.
+ else
+ besmort = 0.04*zeig%coh%bes- 0.04
+ end if
+ end if
+
+!total mortality rate depending on flag_mort
+ IF(flag_mort.eq.1) THEN
+ totmort = strmort
+ ELSE IF(zeig%coh%x_age.le.30) then
+ totmort=intmort+(1-intmort)*strmort
+ if(taxnr.eq.8) totmort = strmort
+ ELSE
+ totmort=intmort+(1-intmort)*strmort
+ ENDIF
+
+
+! if species type oak then combination of stress mortality and besetting mortality
+ if(zeig%coh%species.eq.4.or.zeig%coh%species.eq.1) then
+ totmort = besmort + (1-besmort)* strmort
+ end if
+ survpfunct = exp(- spar(taxnr)%weibla * zeig%coh%x_stress**weibal)
+
+ ntdead = totmort*zeig%coh%nTreeA
+ IF(totmort.GT.1) CALL error_mess(time,"totmort greater 1: ",totmort)
+! calculation of real stem number
+ zeig%coh%nta = zeig%coh%nta - ntdead
+! calculation of integer stem number
+ zeig%coh%nTreeD = zeig%coh%nTreeA-NINT(zeig%coh%nta)
+ zeig%coh%nTreeA = NINT(zeig%coh%nta)
+ IF(zeig%coh%nTreeA.lt.1.) zeig%coh%nTreeA=0.
+
+ if (zeig%coh%mistletoe.eq.1) then ! in case Mist.infect. tree dies, number of mistletoes dies, too
+ totmort_m = zeig%coh%nTreeD/(zeig%coh%nTreeD+zeig%coh%nTreeA) ! share of trees removed of total trees. used for the share of mistletoe that dies
+ ntdead_m = 1. !flag
+ end if
+! calculation of the litter pool of a died tree of a cohort
+1000 IF (zeig%coh%ntreeD.ne.0) then
+ zeig%coh%litC_fol = zeig%coh%litC_fol + zeig%coh%ntreeD*(1.-spar(taxnr)%psf)*zeig%coh%x_fol*cpart
+ zeig%coh%litN_fol = zeig%coh%litN_fol + zeig%coh%ntreeD*((1.-spar(taxnr)%psf)*zeig%coh%x_fol*cpart)/spar(taxnr)%cnr_fol
+ zeig%coh%litC_frt = zeig%coh%litC_frt + zeig%coh%ntreeD*zeig%coh%x_frt*cpart
+ zeig%coh%litN_frt = zeig%coh%litN_frt + zeig%coh%ntreeD*zeig%coh%x_frt*cpart/spar(taxnr)%cnr_frt
+ zeig%coh%litC_tb = zeig%coh%litC_tb + zeig%coh%ntreeD*zeig%coh%x_tb*cpart
+ zeig%coh%litN_tb = zeig%coh%litN_tb + zeig%coh%ntreeD*zeig%coh%x_tb*cpart/spar(taxnr)%cnr_tbc
+ zeig%coh%litC_crt = zeig%coh%litC_crt + zeig%coh%ntreeD*zeig%coh%x_crt*cpart
+ zeig%coh%litN_crt = zeig%coh%litN_crt + zeig%coh%ntreeD*zeig%coh%x_crt*cpart/spar(taxnr)%cnr_crt
+
+ if(flag_mg.ne.0) then
+ if(thin_dead.eq.0.and.thin_flag1(1).lt.0.) then
+ zeig%coh%litC_stem =zeig%coh%litC_stem + zeig%coh%ntreeD*(zeig%coh%x_sap+zeig%coh%x_hrt)*cpart
+ zeig%coh%litN_stem =zeig%coh%litC_stem/spar(taxnr)%cnr_stem
+ sumvsdead = sumvsdead + zeig%coh%ntreeD*(zeig%coh%x_sap + zeig%coh%x_hrt)
+ svar(taxnr)%sumvsdead= svar(taxnr)%sumvsdead + zeig%coh%ntreeD*(zeig%coh%x_sap + zeig%coh%x_hrt)
+ svar(taxnr)%sumvsdead_m3 = svar(taxnr)%sumvsdead_m3 + zeig%coh%ntreeD*(zeig%coh%x_sap + zeig%coh%x_hrt)/(spar(taxnr)%prhos*1000000)
+ sumvsdead_m3 = sumvsdead_m3 + zeig%coh%ntreeD*(zeig%coh%x_sap + zeig%coh%x_hrt) /(spar(taxnr)%prhos*1000000)
+ end if
+ else if(zeig%coh%diam.le.tardiam_dstem.or. flag_mg.eq.0) then
+ zeig%coh%litC_stem =zeig%coh%litC_stem + zeig%coh%ntreeD*(zeig%coh%x_sap+zeig%coh%x_hrt)*cpart
+ zeig%coh%litN_stem =zeig%coh%litC_stem/spar(taxnr)%cnr_stem
+ sumvsdead = sumvsdead + zeig%coh%ntreeD*(zeig%coh%x_sap + zeig%coh%x_hrt)
+ svar(taxnr)%sumvsdead= svar(taxnr)%sumvsdead + zeig%coh%ntreeD*(zeig%coh%x_sap + zeig%coh%x_hrt)
+ sumvsdead_m3 = sumvsdead_m3 + zeig%coh%ntreeD*(zeig%coh%x_sap + zeig%coh%x_hrt) /(spar(taxnr)%prhos*1000000)
+ svar(taxnr)%sumvsdead_m3 = svar(taxnr)%sumvsdead_m3 + zeig%coh%ntreeD*(zeig%coh%x_sap + zeig%coh%x_hrt)/(spar(taxnr)%prhos*1000000)
+ else if(zeig%coh%diam.gt.tardiam_dstem.and.flag_mg.ne.0.or.flag_mg.eq.5) then
+ sumvsdead = sumvsdead + zeig%coh%ntreeD*(zeig%coh%x_sap + zeig%coh%x_hrt)
+ svar(taxnr)%sumvsdead= svar(taxnr)%sumvsdead + zeig%coh%ntreeD*(zeig%coh%x_sap + zeig%coh%x_hrt)
+ sumvsdead_m3 = sumvsdead_m3 + zeig%coh%ntreeD*(zeig%coh%x_sap + zeig%coh%x_hrt) /(spar(taxnr)%prhos*1000000)
+ svar(taxnr)%sumvsdead_m3 = svar(taxnr)%sumvsdead_m3 + zeig%coh%ntreeD*(zeig%coh%x_sap + zeig%coh%x_hrt)/(spar(taxnr)%prhos*1000000)
+ else if(thin_dead.eq.1.and.zeig%coh%diam.le.tardiam_dstem) then
+ zeig%coh%litC_stem =zeig%coh%litC_stem + zeig%coh%ntreeD*(zeig%coh%x_sap+zeig%coh%x_hrt)*cpart
+ zeig%coh%litN_stem =zeig%coh%litC_stem/spar(taxnr)%cnr_stem
+ end if
+
+ ENDIF
+
+ENDIF
+ zeig=>zeig%next
+ENDDO
+! if tree cohort with mistletoe changed, change number of mistletoes too
+if (ntdead_m.eq.1.) then
+ zeig => pt%first
+ do while (associated(zeig))
+ if (zeig%coh%species.eq.nspec_tree+2) then
+ zeig%coh%nta=zeig%coh%nTreeA
+ ntdead_m = totmort_m*zeig%coh%nTreeA
+ zeig%coh%nta = zeig%coh%nta - ntdead_m
+ zeig%coh%nTreeD = zeig%coh%nTreeA-NINT(zeig%coh%nta)
+ zeig%coh%nTreeA = NINT(zeig%coh%nta)
+ IF(zeig%coh%nTreeA.lt.1.) then
+ zeig%coh%nTreeA=0.
+ flag_mistle=0 !set flag mistletoe back to zero
+ ENDIF
+ endif
+ zeig=>zeig%next
+ enddo ! zeig (cohorts)
+end if
+ntdead_m=0.
+
+! recalculation sumvsdead
+ sumvsdead = sumvsdead * 10000./kpatchsize ! kg/patch ---> ! kg/ha
+ sumvsdead_m3 = sumvsdead_m3 * 10000./kpatchsize ! kg/patch ---> ! kg/ha
+ cumsumvsdead = cumsumvsdead + sumvsdead
+
+END SUBROUTINE stand_mort
+
+
+SUBROUTINE int_mort(taxnr,intmort)
+USE data_species
+IMPLICIT NONE
+REAL :: intmort
+INTEGER :: taxnr
+
+intmort=1.-exp(-spar(taxnr)%intr)
+
+END SUBROUTINE int_mort
+
+
+SUBROUTINE int_mort_weib(taxnr,intmort,hage)
+USE data_species
+USE data_stand
+USE data_simul
+
+IMPLICIT NONE
+REAL :: intmort, weibla_int
+INTEGER :: taxnr
+INTEGER :: hage
+
+! Weibull functions depending on age
+weibla_int = -log(0.01)/(spar(taxnr)%max_age**weibal_int)
+intmort = weibal_int*weibla_int*(hage)**(weibal_int-1.)
+
+
+
+END SUBROUTINE int_mort_weib
diff --git a/source_code/version2.2_windows/stand_regen.f b/source_code/version2.2_windows/stand_regen.f
new file mode 100755
index 0000000000000000000000000000000000000000..c3873656225b6a6a9e6b3df5b0bb2ea484421645
--- /dev/null
+++ b/source_code/version2.2_windows/stand_regen.f
@@ -0,0 +1,675 @@
+!*****************************************************************!
+!* *!
+!* 4C (FORESEE) Simulation Model *!
+!* *!
+!* *!
+!* subroutine for regeneration *!
+!* including the SR: *!
+!* - gener_seed *!
+!* - seed_ini *!
+!* - simseed *!
+!* - growth_seed *!
+!* - mort_seed *!
+!* *!
+!* 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_regen
+
+ USE data_simul
+ USE data_stand
+
+ IMPLICIT NONE
+
+ flag_standup = 2
+
+ CALL mort_seed
+
+ CALL gener_seed
+
+END SUBROUTINE stand_regen
+
+
+SUBROUTINE gener_seed
+
+USE data_stand
+USE data_species
+USE data_simul
+use data_out
+USE data_plant
+USE data_soil
+
+IMPLICIT NONE
+real :: seedla ! leaf area of all seedling cohorts
+real :: laiseed ! lai ----"------
+integer :: nseed ! number of generated seeds
+real :: redseed
+integer :: i
+integer, dimension(5) :: agemin, seedpot
+real, dimension(5,3) :: latg
+real :: help,help1, help2
+real :: pequal
+integer :: hlayer
+integer :: flag_reg_help
+TYPE(coh_obj), POINTER :: p
+DATA latg /1.,0.3,0.1,1.,0.1,1.,0.9,0.5,1.,0.5,1.,1.,0.9,1.,0.9/
+
+if (flag_trace) write (unit_trace, '(I4,I10,A)') iday, time_cur, ' gener_seed'
+
+flag_reg_help = 0
+agemin = 0
+seedpot = 0
+seedla = 0.
+help1 = 0.
+! calculation of leafarea of all seedling cohorts
+
+SELECT CASE (flag_reg)
+! according to FORGRA (Vincent Kint)
+ CASE (30)
+ call random_number(pequal)
+
+ DO i= 1, nspecies
+ nseed = 0
+ p =>pt%first
+ DO WHILE (ASSOCIATED(p))
+ if(p%coh%species.eq.i) then
+ if (i.eq.1) then
+ agemin(i) = 50 + (30* pequal)
+ call random_number(pequal)
+ seedpot(i) = 810*pequal
+ else if(i.eq.3) then
+ agemin(i) = 15 + (45* pequal)
+ call random_number(pequal)
+ seedpot(i) = 1000*pequal
+ else if(i.eq.4) then
+ agemin(i) = 15 +(35* pequal)
+ call random_number(pequal)
+ seedpot(i) = 1125*pequal
+ else if(i.eq.5) then
+ agemin(i) = 10 +(10* pequal)
+ call random_number(pequal)
+ seedpot(i) = 8750*pequal
+ end if
+ if(p%coh%x_age.ge. agemin(i).and.p%coh%diam.gt.0.) then
+ nseed = nseed + seedpot(i)*(p%coh%ntreem + p%coh%ntreea)
+ end if
+ end if
+ p => p%next
+ END DO ! cohort
+
+ help2 = irelpool_ll
+ if(help2.lt.0) help2 =0
+ if(help2.eq. 0.) then
+ redseed = 0.
+ else if( help2.gt.0. .and. help2.le.latg(i,1)) then
+ redseed = help2*latg(i,1)/0.4
+ else if ( help2.gt.latg(i,1).and. help2.le.latg(i,2)) then
+ redseed = help2*latg(i,2)/0.6
+ else if ( help2.gt.latg(i,2).and. help2.le.latg(i,3)) then
+ redseed = help2*latg(i,3)/0.8
+ else if(help2.gt.latg(i,3)) then
+ redseed = help2* latg(i,3)
+ end if
+
+ nseed = nseed * redseed
+
+
+! for birch 1 year old saplings are used
+ if (i.eq.5) then
+ numplant(i) = nseed
+ flag_reg = 14
+ if(nseed.ne.0) call planting
+ flag_reg= 0
+ else
+ call seed_multi(nseed,i)
+ end if
+
+ END DO ! species
+
+ CASE(1,2,3)
+
+p =>pt%first
+ DO WHILE (ASSOCIATED(p))
+ if(p%coh%height.lt.thr_height) then
+
+ seedla = seedla + p%coh%t_leaf*p%coh%ntreea
+ help1 = help1 + p%coh%x_fol*p%coh%ntreea
+ end if
+ p => p%next
+
+ END DO
+
+! calculation LAI of lowest_layer
+ laiseed=seedla/kpatchsize
+
+DO i=1,nspecies
+
+
+ IF (spar(i)%regflag.eq.1) THEN
+ CALL simseed(i,nseed)
+ IF(laiseed.lt.1) THEN
+! reduction of seedling number nseed depending on light module and free space in the lowest_layer
+ SELECT CASE (flag_light)
+
+ CASE(1)
+ IF(flag_reg.ne.3) THEN
+ CALL seed_ini(nseed,i)
+ ELSE
+ CALL seed_multi(nseed,i)
+ END IF
+ CASE (2)
+
+
+ if (anz_coh.eq. 0) then
+ if(time.eq.1) then
+ hlayer = 0
+ else
+ hlayer = 1
+ end if
+ else
+ hlayer = lowest_layer -1
+ end if
+
+ help = vstruct(hlayer)%Irel
+ if (help.lt.0.05) help = 0
+ IF(help.eq.0) THEN
+ nseed = 0
+ ELSE
+ nseed = nseed*help
+ IF(flag_reg.ne.3) THEN
+ CALL seed_ini(nseed,i)
+ ELSE
+ CALL seed_multi(nseed,i)
+ END IF
+ END IF
+
+ CASE(3)
+ redseed= bgpool_ll
+ nseed = nseed*redseed
+ IF(flag_reg.ne.3) THEN
+ CALL seed_ini(nseed,i)
+ ELSE
+ CALL seed_multi(nseed,i)
+ END IF
+
+ CASE(4)
+ if(i.gt.5) then
+
+ redseed= irelpool_ll
+ else
+ ! according to FORGRA, not for all species (i=1,5)
+ help2 = irelpool_ll
+ if(help2.lt. 0.01) then
+ redseed = 0.
+
+ else if( help2.gt.0.01 .and. help2.le.latg(i,1)) then
+
+ redseed = help2*latg(i,1)/0.4
+ else if ( help2.gt.latg(i,1).and. help2.le.latg(i,2)) then
+ redseed = help2*latg(i,2)/0.6
+ else if ( help2.gt.latg(i,2).and. help2.le.latg(i,3)) then
+ redseed = help2*latg(i,3)/0.8
+ else if(help2.gt.latg(i,3)) then
+ redseed = help2* latg(i,3)
+
+ end if
+ end if
+ nseed = redseed * nseed
+
+ IF(flag_reg.ne.3) THEN
+ CALL seed_ini(nseed,i)
+ ELSE
+ if (i.eq.5) then
+ numplant(i) = nseed
+ flag_reg_help = flag_reg
+ flag_reg = 14
+ if(nseed.ne.0) call planting
+ flag_reg = flag_reg_help
+ else
+ CALL seed_multi(nseed,i)
+ end if
+ END IF
+ END SELECT
+ ELSE
+ nseed = 0.
+ END IF
+ ELSE
+ nseed=0.
+ END IF
+
+END DO
+
+END SELECT ! flag_reg
+
+
+END subroutine gener_seed
+
+SUBROUTINE simseed(specnum,nseed)
+USE data_species
+use data_simul
+use data_stand
+IMPLICIT NONE
+REAL :: pequal
+INTEGER :: nseed,specnum
+REAL :: seedmax
+
+! calculation of max. seedrate of patch from max. seedrate per m2
+ seedmax=spar(specnum)%seedrate*kpatchsize
+
+ CALL random_number(pequal)
+ CALL random_number(pequal)
+ nseed=-seedmax*alog(1.-pequal)
+ IF (flag_mg ==4 .and. time.eq.1) THEN
+ nseed = NINT(spar(specnum)%seedrate*kpatchsize)
+ ELSE IF(flag_mg ==4.and. time.gt.1)THEN
+ nseed = 0
+
+ END IF
+ end
+
+
+
+SUBROUTINE seed_ini(nseed,nsp)
+
+USE data_species
+use data_stand
+use data_help
+use data_out
+use data_simul
+use data_soil
+
+IMPLICIT NONE
+integer :: nseed, nr, j
+integer :: nsp
+REAL :: shoot
+REAL :: x1,x2,xacc,root
+REAL :: rtflsp
+REAL :: troot2
+TYPE(cohort) ::tree_ini
+
+
+external weight
+external rtflsp
+
+if (flag_trace) write (unit_trace, '(I4,I10,A)') iday, time_cur, ' seed_ini'
+
+IF(nseed.eq.0) RETURN
+
+
+hnspec = nsp
+max_coh = max_coh + 1
+
+! nullify of all elements
+
+ call coh_initial (tree_ini)
+
+tree_ini%ident = max_coh
+tree_ini%species = nsp
+tree_ini%ntreea = nseed
+tree_ini%nta = nseed
+ tree_ini%x_age = 1
+
+mschelp = spar(nsp)%seedmass/1000. ! g ---> kg
+x1 = 0.
+x2 = 0.1
+xacc = (1.0e-10) * (x1+x2)/2
+root = rtflsp(weight,x1,x2,xacc)
+tree_ini%x_sap = root
+shoot = root*1000. ! [kg]
+tree_ini%x_fol= (spar(nsp)%seeda*(tree_ini%x_sap** spar(nsp)%seedb)) ![kg]
+tree_ini%x_frt = tree_ini%x_fol ! [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
+
+ ! initialize pheno state variables
+ IF(spar(tree_ini%species)%Phmodel==1) THEN
+ tree_ini%P=0
+ tree_ini%I=1
+ ELSE
+ tree_ini%P=0
+ tree_ini%I=0
+ tree_ini%Tcrit=0
+ END IF
+
+! 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); berechnet aus shoot biomass (mg)
+if(nsp.eq.2) tree_ini%height = 10**(spar(nsp)%pheight1+ spar(nsp)%pheight2*LOG10(shoot*1000.)+ &
+ spar(nsp)%pheight3*(LOG10(shoot*1000.))**2)
+
+ IF(nseed.ne.0.) then
+ IF (.not. associated(pt%first)) THEN
+ ALLOCATE (pt%first)
+ pt%first%coh = tree_ini
+ NULLIFY(pt%first%next)
+
+! root distribution
+ call root_depth (1, pt%first%coh%species, pt%first%coh%x_age, pt%first%coh%height, pt%first%coh%x_frt, pt%first%coh%x_crt, nr, troot2, pt%first%coh%x_rdpt, pt%first%coh%nroot)
+ pt%first%coh%nroot = nr
+ do j=1,nr
+ pt%first%coh%rooteff = 1. ! assumption for the first use
+ enddo
+ do j=nr+1, nlay
+ pt%first%coh%rooteff = 0. ! layers with no roots
+ enddo
+
+ ELSE
+ ALLOCATE(zeig)
+ zeig%coh = tree_ini
+ zeig%next => pt%first
+ pt%first => zeig
+
+! root distribution
+ call root_depth (1, zeig%coh%species, zeig%coh%x_age, zeig%coh%height, zeig%coh%x_frt, zeig%coh%x_crt, nr, troot2, zeig%coh%x_rdpt, zeig%coh%nroot)
+ zeig%coh%nroot = nr
+ do j=1,nr
+ zeig%coh%rooteff = 1. ! assumption for the first use
+ enddo
+ do j=nr+1, nlay
+ zeig%coh%rooteff = 0. ! layers with no roots
+ enddo
+
+ END IF
+ anz_coh=anz_coh+1
+ END IF
+
+END SUBROUTINE seed_ini
+
+
+
+SUBROUTINE growth_seed
+
+USE data_stand
+USE data_species
+USE data_simul
+USE data_par
+use data_out
+
+IMPLICIT NONE
+ REAL :: lambdaf = 0., & ! partitioning functions
+ lambdas = 0., &
+ lambdar = 0., &
+ NPP = 0., & ! annual NPP
+ F = 0., & ! state variables: foliage,
+ S = 0., & ! shoot biomass,
+
+ R = 0., & ! fine roots,
+
+ H = 0., & ! total tree height
+
+ FNew, SNew, & ! new states
+ RNew, &
+ sigmaf = 0., & ! current leaf activity rate
+ sigman = 0., & ! current root activity rate
+ betar = 0., &
+ ar = 0
+ REAL :: Sf, & ! senescence rates
+ Sr, &
+ Gf, & ! growth rates
+ Gs, &
+ Gr
+ real :: pab,helpdr,helpsum
+ TYPE(coh_obj), POINTER :: p
+
+if (flag_trace) write (unit_trace, '(I4,I10,A)') iday, time_cur, ' growth_seed'
+
+ flag_standup = 2 ! call stand_balance and root_distribution later
+
+ p=>pt%first
+ DO
+ if(.not.associated(p)) exit
+ if( p%coh%height.lt.thr_height.and. p%coh%species.le.nspec_tree) then
+ ns = p%coh%species
+
+ F = p%coh%x_fol
+ S = p%coh%x_sap
+ R = p%coh%x_frt
+
+ NPP = p%coh%NPP
+ IF (flag_reg .eq. 2) NPP = p%coh%NPPpool ! [kg]
+ H = p%coh%height
+
+ Sf = p%coh%sfol
+ Sr = p%coh%sfrt
+
+! only allocate if enough NPP is available
+
+1 IF (NPP>1.0E-9.or. NPP.ge.(Sf+Sr).and.(sr+Sf)>1.0E-9) THEN
+
+! calculate leaf activity based on net PS and leaf mass
+ sigmaf = NPP/F
+
+! calculate root activity based on drought index
+ helpdr= p%coh%drIndAl / p%coh%nDaysGr
+ IF (flag_sign.eq.1) THEN
+ sigman = amax1(spar(ns)%sigman*10*(((5.-spar(ns)%stol)*1.-p%coh%crown_area)/(5.-spar(ns)%stol)*1.),spar(ns)%sigman) * p%coh%drIndAl / p%coh%nDaysGr
+ ELSE
+ sigman = spar(ns)%sigman * p%coh%drIndAl / p%coh%nDaysGr
+ END IF
+ ! auxiliary variables for fine roots
+ if(helpdr.lt.0.001) ar = 0.
+
+ ar = spar(ns)%pcnr * sigmaf / sigman
+ betar = (Sr - R + ar*(F-Sf)) / NPP
+
+! calculate coefficients for roots and foliage and shoot
+
+ select case (ns)
+ case (1)
+ pab = 0.487
+ case(2)
+ pab = 0.826
+ case(3)
+ pab=1.9
+ case(4)
+ pab=1.002
+! Pinus contorta
+ case(6)
+! Gholz
+ pab = 0.236
+! Populus tremula
+ case(8)
+ pab = 0.3233
+ case(9)
+! Pinus halepensis
+ pab = 1.42335
+ case(10)
+! pseudotsuga menziesii
+ pab = 0.8515
+ case(11)
+! Robinia
+ pab = 0.8594
+ end select
+
+ lambdaf = (pab*(1-betar)+ (Sf/NPP))/(1 + pab*(1. + ar))
+ lambdar = ar * lambdaf + betar
+ lambdas = 1.- lambdaf - lambdar
+
+! consistency
+ ELSE
+
+ lambdaf = 0.
+ lambdas = 0.
+ lambdar = 0.
+
+ END IF
+ if ( lambdas.lt.0.) then
+ lambdas = 0.
+ lambdaf = (1.-betar)/(ar+1)
+ lambdar = 1.-lambdaf
+ if( lambdar.lt.0) then
+ lambdar=0
+ lambdaf=1
+ end if
+ if(lambdaf.lt.0) then
+ lambdaf =1
+ lambdar = 0.
+ end if
+ endif
+helpsum = lambdaf + lambdar+ lambdas
+ Gf = lambdaf*NPP
+ Gr = lambdar*NPP
+ Gs = lambdas*NPP
+ p%coh%gfol = Gf
+ p%coh%gfrt = Gr
+ p%coh%gsap = Gs
+
+ ! update of state vector
+ FNew = F + Gf - Sf
+ SNew = S + Gs
+ RNew = R + Gr - Sr
+
+ p%coh%x_fol = FNew
+ p%coh%x_sap = SNew
+ p%coh%x_frt = RNew
+ p%coh%fol_inc_old = p%coh%fol_inc
+ p%coh%fol_inc = Gf - Sf
+ p%coh%stem_inc = Gs
+
+! update height and shoot base diameter (regression functions from Schall 1998)
+
+ IF(ns.ne.2) p%coh%height = spar(ns)%pheight1* (snew*1000000.) **spar(ns)%pheight2
+ IF(ns.eq.2) p%coh%height = 10**(spar(ns)%pheight1+ spar(ns)%pheight2*LOG10(snew*1000000.)+ &
+ spar(ns)%pheight3*(LOG10(snew*1000000.))**2)
+ p%coh%height_ini = p%coh%height
+
+! update foliage area, parameter med_sla
+
+ SELECT CASE (flag_light)
+ CASE (1:2)
+ p%coh%med_sla = spar(ns)%psla_min + spar(ns)%psla_a*(1.- vstruct(lowest_layer)%irel)
+ CASE(3,4)
+ p%coh%med_sla = spar(ns)%psla_min + spar(ns)%psla_a*(1.-irelpool(lowest_layer))
+ END SELECT
+
+! total leaf area of a tree in this cohort [m**2]
+ p%coh%ca_ini = p%coh%med_sla * p%coh%x_fol
+
+ ! update age -now not necessary this is done in stand_bal
+ p%coh%notViable = (FNew <= 0.) .OR. (SNew <= 0.) .OR. &
+ (RNew <= 0.)
+ p%coh%litC_fol = p%coh%litC_fol + p%coh%ntreea * Sf * cpart
+ p%coh%litC_frt = p%coh%litC_frt + p%coh%ntreea * Sr * cpart
+
+ ! with species specific N content and reallocation factor (see species.par)
+ p%coh%litN_fol = p%coh%litN_fol + p%coh%ntreea * Sf * cpart * spar(ns)%reallo_fol / spar(ns)%cnr_fol
+ p%coh%litN_frt = p%coh%litN_frt + p%coh%ntreea * Sr * cpart * spar(ns)%reallo_frt / spar(ns)%cnr_frt
+
+ end if ! seedling cohort test
+
+ p=> p%next
+
+ END DO
+
+END SUBROUTINE growth_seed
+
+
+SUBROUTINE mort_seed
+
+USE data_species
+USE data_simul
+use data_stand
+use data_par
+use data_out
+
+IMPLICIT NONE
+
+integer :: taxnr
+integer :: hage
+real :: intmort
+real :: strmort
+real :: totmort
+real :: ntdead
+real :: ntahelp
+TYPE(coh_obj), POINTER :: p
+
+if (flag_trace) write (unit_trace, '(I4,I10,A)') iday, time_cur, ' mort_seed'
+
+p=>pt%first
+DO
+ IF(.not.associated(p)) EXIT
+ IF(p%coh%height.lt.thr_height) THEN
+ IF(p%coh%notViable) then
+ PRINT*,time, p%coh%notViable
+ p%coh%ntreed = p%coh%ntreea
+ p%coh%ntreea = 0
+
+ ENDIF
+ END IF
+ p => p%next
+
+END DO
+
+p => pt%first
+
+DO
+
+ IF(.not.associated(p)) EXIT
+ IF(p%coh%height.lt.thr_height .and. p%coh%species.le.nspec_tree) THEN
+ taxnr = p%coh%species
+ if(p%coh%ntreea .eq.0) goto 1000
+
+ hage = p%coh%x_age
+ IF( p%coh%fol_inc.le.0.) THEN
+ p%coh%x_stress = p%coh%x_stress +1
+ p%coh%x_health = 0
+
+ ELSE
+ p%coh%x_health = p%coh%x_health +1
+ IF(p%coh%x_stress .gt. 0.) p%coh%x_stress = p%coh%x_stress -1
+
+ ENDIF
+! intrinsic mortality
+ CALL int_mort_weib(taxnr, intmort, hage)
+
+! stress mortality
+ IF(p%coh%x_stress.gt.0) THEN
+ strmort = weibal*spar(taxnr)%weibla*p%coh%x_stress**(weibal-1)
+ ELSE
+ strmort = 0.
+ ENDIF
+
+ totmort=intmort+(1-intmort)*strmort
+
+! calculation of real number of dying stems
+ ntdead = totmort*p%coh%ntreeA
+! update of real stem number nta and number of dead stems
+ p%coh%nta = p%coh%nta -ntdead
+ p%coh%nTreeD = p%coh%nTreeA-NINT(p%coh%nta)
+! help variable for comparison
+ ntahelp = p%coh%nTreeA
+! update of integer stem number
+ p%coh%nTreeA = NINT(p%coh%nta)
+! update of integer stem number
+ if(p%coh%nta.lt.1.) p%coh%nTreeA=0.
+! update of real stem number if integer stem number was changed
+ if (ntahelp .ne. p%coh%nTreeA ) p%coh%nta = p%coh%nTreeA
+1000 if (p%coh%ntreeD.ne.0) then
+ p%coh%litC_fol = p%coh%litC_fol + p%coh%ntreeD*(1.-spar(taxnr)%psf)*p%coh%x_fol*cpart
+ p%coh%litN_fol = p%coh%litN_fol + p%coh%ntreeD*((1.-spar(taxnr)%psf)*p%coh%x_fol*cpart)/spar(taxnr)%cnr_fol
+ p%coh%litC_frt = p%coh%litC_frt + p%coh%ntreeD*p%coh%x_frt*cpart
+ p%coh%litN_frt = p%coh%litN_frt + p%coh%ntreeD*p%coh%x_frt*cpart/spar(taxnr)%cnr_frt
+ p%coh%litC_tb = p%coh%litC_tb + p%coh%ntreeD*p%coh%x_tb*cpart
+ p%coh%litN_tb = p%coh%litN_tb + p%coh%ntreeD*p%coh%x_tb*cpart/spar(taxnr)%cnr_tbc
+ p%coh%litC_crt = p%coh%litC_crt + p%coh%ntreeD*p%coh%x_crt*cpart
+ p%coh%litN_crt = p%coh%litN_crt + p%coh%ntreeD*p%coh%x_crt*cpart/spar(taxnr)%cnr_tbc
+
+ p%coh%litC_stem = p%coh%litC_stem + p%coh%ntreeD*(p%coh%x_sap)*cpart
+ p%coh%litN_stem = p%coh%litC_stem/spar(taxnr)%cnr_stem
+ endif
+
+ END IF
+ p => p%next
+
+ENDDO
+
+END SUBROUTINE mort_seed
diff --git a/source_code/version2.2_windows/statistik.f b/source_code/version2.2_windows/statistik.f
new file mode 100755
index 0000000000000000000000000000000000000000..ae1726e164bd5a23f42888d284f3ee007eee1e37
--- /dev/null
+++ b/source_code/version2.2_windows/statistik.f
@@ -0,0 +1,484 @@
+!*****************************************************************!
+!* *!
+!* 4C (FORESEE) Simulation Model *!
+!* *!
+!* *!
+!* Subroutines for: *!
+!* *!
+!* statistical analysis of model quality *!
+!* *!
+!* Author: F. Suckow *!
+!* *!
+!* contains: *!
+!* residuen *!
+!* statistik *!
+!* mean (n, arr) *!
+!* variance (n, meanv, arr) *!
+!* correl (n, meanv1, arr1, meanv2, arr2) *!
+!* sumsq (n, arr) *!
+!* stat_mon *!
+!* *!
+!* 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 residuen (ip)
+
+use data_mess
+
+implicit none
+
+integer i,j, ires, ip
+
+! calculate and save residues, with date, simulation as well as measurement value
+! Residuen berechnen, mit Datum, Sim.- und Messwert speichern
+
+ if (ip .eq. 1) then
+ allocate (val(imkind))
+ do i=1,imkind
+ ires = 0
+ val(i)%tkind = tkind
+ allocate (val(i)%day(1:anz_val))
+ allocate (val(i)%year(1:anz_val))
+ allocate (val(i)%resid(1:anz_val))
+ allocate (val(i)%sim(1:anz_val))
+ allocate (val(i)%mess(1:anz_val))
+ val(i)%day = -99
+ val(i)%year = -99
+ val(i)%resid = -9999.0
+ val(i)%mkind = sim_kind(i)
+ do j = 1,anz_val
+ if (mess2(j,i) .gt. -9000.0 .and. sim1(j,i) .gt. -9000.0) then
+ ires = ires + 1
+ val(i)%day(ires) = stz(1,j)
+ val(i)%year(ires) = stz(2,j)
+ val(i)%resid(ires)= sim1(j,i) - mess2(j,i)
+ val(i)%sim(ires) = sim1(j,i)
+ val(i)%mess(ires) = mess2(j,i)
+ else
+ endif
+ enddo
+ val(i)%imes = ires
+ enddo
+ else
+ do i=1,imkind
+ ires = 0
+ val(i)%resid = -9999.9
+ val(i)%sim = -9999.9
+ do j = 1,anz_val
+ if (mess2(j,i) .gt. -9000.0 .and. sim1(j,i) .gt. -9000.0) then
+ ires = ires + 1
+ val(i)%resid(ires)= sim1(j,i) - mess2(j,i)
+ val(i)%sim(ires) = sim1(j,i)
+ else
+ endif
+ enddo
+ enddo
+
+ endif
+
+END SUBROUTINE residuen
+
+!**************************************************************
+
+SUBROUTINE statistik
+
+use data_mess
+use data_simul
+
+implicit none
+
+integer imt ! aktueller Messwert-Typ
+real, external :: mean, variance, correl, sumsq
+
+integer i, n, nhelp
+real help, h1, h2
+real, allocatable, dimension(:):: arr, arrs, arrm, harr
+real:: avs, & ! mean value simulation; Mittelwert Simulation
+ mins, & ! Minimum Simulation
+ maxs, & ! Maximum Simulation
+ stdevs, & ! standard deviation simulation; Standardabweichung Simulation
+ varis, & ! scattering of simulation; Streuung Simulation
+ varcos, & ! coefficient of variation for simulation; Variationskoeffizient Simulation
+ avm, & ! mean value measurements; Mittelwert Messwerte
+ minm, & ! minimum value measurements; Minimum Messwerte
+ maxm, & ! maximum value measurements; Maximum Messwerte
+ stdevm, & ! standard deviation measurements; Standardabweichung Messwerte
+ varim, & ! scattering of measurements; Streuung Messwerte
+ varcom, & ! coefficient of variation of measurements; Variationskoeffizient Messwerte
+ corrco, & ! coefficient of correlation; Korrelationskoeffizient
+ rsq, & ! coefficient of determination; Bestimmtheitsmass
+ avr, & ! mean error residues; Mittlerer Fehler Residuen
+ minr, & ! minimum residues; Minimum Residuen
+ maxr, & ! maximum residues; Maximum Residuen
+ stdevr, & ! standard deviation residues; Standardabweichung Residuen
+ varir, & ! scattering of residues; Streuung Residuen
+ varcor, & ! coefficient of variation residues; Variationskoeffizient Residuen
+ nme, & ! normalised mean error; Normalisierter mittlerer Fehler
+ mae, & ! mean absolute error of residues; Mittlerer absoluter Fehler Residuen
+ nmae, & ! normalised mean absolute error; Normalisierter mittlerer absoluter Fehler
+ sse , & ! sum of squared errors; Fehlerquadratsumme
+ rmse, & ! Root mean square error
+ nrmse, & ! Normalised root mean square error
+ pme, & ! mean procental error; Mittlerer prozentualer Fehler
+ prmse, & ! mean squared procentual error; Mittlerer quadratischer prozentualer Fehler
+ tic, & ! Theilsch imbalance coefficient; Theilscher Ungleichheitskoeffizient
+ meff ! Model efficiency (Medlyn et al. 2005)
+
+do imt = 1, imkind
+ n = val(imt)%imes
+ if (n .gt. 0) then
+ allocate (arr(n))
+ allocate (arrs(n))
+ allocate (arrm(n))
+ allocate (harr(n))
+
+ ! simulation
+ arrs = val(imt)%sim(1:n)
+ avs = mean(n, arrs)
+ mins = minval(arrs)
+ maxs = maxval(arrs)
+ varis = variance(n, avs, arrs)
+ if (varis .ge. 0.) then
+ stdevs = sqrt(varis)
+ else
+ stdevs = 0.
+ endif
+ if (avs .ne. 0.) then
+ varcos = stdevs / avs
+ else
+ varcos = -9999.0
+ endif
+
+ ! observed
+ arrm = val(imt)%mess(1:n)
+ avm = mean(n, arrm)
+ minm = minval(arrm)
+ maxm = maxval(arrm)
+ varim = variance(n, avm, arrm)
+ if (varim .ge. 0.) then
+ stdevm = sqrt(varim)
+ else
+ stdevm = 0.
+ endif
+
+
+ ! residuals
+ arr = val(imt)%resid(1:n)
+
+ avr = mean(n, arr)
+ minr = minval(arr)
+ maxr = maxval(arr)
+ varir = variance(n, avr, arr)
+ if (varir .ge. 0.) then
+ stdevr = sqrt(varir)
+ else
+ stdevr = 0.
+ endif
+ if (avr .ne. 0.) then
+ varcor = stdevr / avr
+ else
+ varcor = -9999.0
+ endif
+
+
+ corrco = correl(n, avs, arrs, avm, arrm)
+ if (corrco .ge. -1.) then
+ rsq = corrco * corrco
+ rsq_av = rsq_av + rsq
+ else
+ imk_rsq = imk_rsq - 1
+ rsq = -9999.0
+ endif
+
+ if (avs .ne. 0.) then
+ nme = (avm - avs) / avs
+ nme_av = nme_av + nme
+ else
+ imk_nme = imk_nme - 1
+ nme = -9999.0
+ endif
+ mae = mean(n, abs(arr))
+ sse = sumsq(n, arr)
+ rmse = sqrt(sse / n)
+ if (avm .ne. 0.) then
+ varcom = stdevm / avm
+ nrmse = rmse / abs(avm)
+ nrmse_av = nrmse_av + nrmse
+ nmae = mae / abs(avm)
+ nmae_av = nmae_av + nmae
+ else
+ imk_nrmse = imk_nrmse - 1
+ imk_nmae = imk_nmae - 1
+ varcom = -9999.0
+ nrmse = -9999.0
+ nmae = -9999.0
+ endif
+
+ nhelp = n
+ do i = 1, n
+ if (arrm(i) .ne. 0.) then
+ harr(i) = abs(arr(i)/arrm(i))
+ else
+ nhelp = nhelp -1
+ harr(i) = 0
+ endif
+ enddo
+ pme = mean(nhelp, harr)
+ prmse = sumsq(nhelp, harr)
+ prmse = sqrt(prmse / nhelp)
+ tic = sse / (sumsq(n, arrs) + sumsq(n, arrm))
+
+ h1=sumsq(n, arr)
+ harr = arrm-avm
+ h2=sumsq(n, harr)
+
+ if (h2.ne.0) then
+ meff = 1. - (h1 / h2)
+ else
+ meff=1
+ end if
+
+! Mittelwert
+ pme_av = pme_av + pme
+ prmse_av = prmse_av + prmse
+ tic_av = tic_av + tic
+ meff_av = meff_av + meff
+
+ deallocate (arr)
+ deallocate (arrm)
+ deallocate (arrs)
+ deallocate (harr)
+
+ write (unit_stat, '(I5,2X, A20,1X,A10,I8,1X,30E13.5)') ip, site_name(ip), val(imt)%mkind, val(imt)%imes, &
+ avr, minr, maxr, stdevr, varir, varcor, nme, mae, nmae, sse, rmse, nrmse, pme, prmse, tic,meff, corrco, rsq, &
+ avs, mins, maxs, stdevs, varis, varcos, avm, minm, maxm, stdevm, varim, varcom
+ endif
+enddo
+
+END SUBROUTINE statistik
+
+!**************************************************************
+
+REAL FUNCTION mean (n, arr)
+
+integer n, i
+real, dimension(n):: arr
+real help
+
+help = 0.
+do i = 1,n
+ help = help + arr(i)
+enddo
+mean = help / n
+
+END FUNCTION mean
+
+!**************************************************************
+
+REAL FUNCTION variance (n, meanv, arr)
+
+integer n, i
+real, dimension(n):: arr
+real meanv, help, xx
+
+help = 0.
+if (n .gt. 1) then
+ do i = 1,n
+ xx = arr(i) - meanv
+ help = help + xx * xx
+ enddo
+ variance = help / (n -1)
+else
+ variance = -9999.0
+endif
+
+END FUNCTION variance
+
+!**************************************************************
+
+REAL FUNCTION correl (n, meanv1, arr1, meanv2, arr2)
+
+integer n, i
+real, dimension(n):: arr1, arr2
+real meanv1, meanv2, help1, help2, help3, xx1, xx2
+
+help1 = 0.
+help2 = 0.
+help3 = 0.
+do i = 1,n
+ xx1 = arr1(i) - meanv1
+ xx2 = arr2(i) - meanv2
+ help1 = help1 + xx1 * xx2
+ help2 = help2 + xx1 * xx1
+ help3 = help3 + xx2 * xx2
+enddo
+if ((help2 .gt. 1.E-06) .and. (help3 .gt. 1.E-06)) then
+ correl = help1 / sqrt(help2*help3)
+else
+ correl = -9999.0
+endif
+
+END FUNCTION correl
+
+!**************************************************************
+
+REAL FUNCTION sumsq (n, arr)
+
+integer n, i
+real, dimension(n):: arr
+real help
+
+help = 0.
+do i = 1,n
+ help = help + arr(i) * arr(i)
+enddo
+sumsq = help
+
+END FUNCTION sumsq
+
+!**************************************************************
+
+Subroutine stat_mon
+
+! Statistics of monthly values, derived from daily observed values
+
+use data_mess
+use data_out
+use data_simul
+
+implicit none
+
+integer i, j, k, l
+integer dd, mm, yy, doy, yanz, arranz
+integer :: outunit ! output unit
+character(250) text, filename
+character(20) idtext, datei, vunit, obskind
+character(150) htext
+real, allocatable, dimension(:):: helparr ! help array with montly values of one month for all years
+real, allocatable, dimension(:,:):: help_mon ! array with monthly values for each year, year
+real, allocatable, dimension(:,:):: help_day ! array with mean daily values per month for each year, year
+integer, allocatable, dimension(:,:):: help_num ! array with number of measurement values for each year, year
+
+yanz = mtz(2,imess) - mtz(2,1) + 1
+if (.not. allocated(unit_mon)) then
+ allocate(unit_mon(imkind))
+ allocate(unit_mon_stat(imkind))
+ allocate(helparr(yanz))
+endif
+if (.not. allocated(help_mon)) then
+ allocate(help_mon(12,yanz))
+ allocate(help_day(12,yanz))
+ allocate(help_num(12,yanz))
+endif
+do k = 1, imkind
+ help_mon = 0.0
+ help_num = 0
+ obskind = sim_kind(k)
+ filename = trim(dirout)//trim(site_name(ip))//'_'//trim(obskind)//'_mon_obs'//'.out'
+ unit_mon(k) = getunit()
+ open(unit_mon(k),file=filename,status='replace')
+
+! Calculate mmonthly sums
+ do j = 1, imess
+ doy = mtz(1,j)
+ yy = mtz(2,j)
+ call TZINDA(dd,mm,yy,doy)
+ yy = mtz(2,j) - mtz(2,1) + 1
+ if (mess1(j,k) .Gt. -9990.) then
+ if (sim_kind(k) .eq. 'AET') then
+ if (mess1(j,k) .lt. 0.) then
+ mess_info = '# negative AET set to zero'
+ mess1(j,k) = 0. ! avoid negative AET
+ endif
+ endif
+ help_mon(mm,yy) = help_mon(mm,yy) + mess1(j,k)
+ help_num(mm,yy) = help_num(mm,yy) + 1
+ endif
+ enddo ! j
+ do j = 1, yanz
+ do i = 1,12
+ if (help_num(i,j) .gt. 0) then
+ help_day(i,j) = help_mon(i,j) / help_num(i,j)
+ else
+ help_mon(i,j) = -9999.
+ help_day(i,j) = -9999.
+ endif
+ enddo
+ enddo
+
+! Output of monthly sums
+ select case (trim(obskind))
+ case ('AET')
+ vunit = 'mm'
+ case ('GPP', 'NPP', 'TER')
+ vunit = 'g C/m²'
+ case ('Snow')
+ return
+ case default
+ vunit = ' '
+ end select
+ write (unit_mon(k), '(A)') '# Monthly sum, daily mean of month and number of values per month of observed '//trim(obskind)
+ write (unit_mon(k), '(A)') '# '//trim(vunit)
+ write (unit_mon(k), '(A)', advance='no') '# Year'
+ do i = 1,12
+ write (unit_mon(k), '(A8,I2)', advance='no') trim(obskind)//'_',i
+ enddo
+ write (unit_mon(k), '(A)')
+ l = 0
+ do j = mtz(2,1), mtz(2,imess)
+ l = l + 1
+ write (unit_mon(k), '(A,I6,12F10.2)') 'sum ', j, (help_mon(i,l), i=1,12)
+ write (unit_mon(k), '(A,I6,12F10.2)') 'daily mean ', j, (help_day(i,l), i=1,12)
+ write (unit_mon(k), '(A,I6,12I10)') 'number ', j, (help_num(i,l), i=1,12)
+ enddo
+
+! Statistics
+ filename = trim(dirout)//trim(site_name(ip))//'_'//trim(obskind)//'_mon_obs_stat'//'.res'
+ outunit = getunit()
+ open(outunit,file=filename,status='replace')
+ write (outunit, '(A)') '# Statistics over all years for each monthly sum and daily mean per month of '//trim(obskind)
+ write (outunit, '(A)') '# '//trim(vunit)
+ write (outunit, '(A, I6)') '# Simulation period (years): ', year
+ write (outunit, '(A)') '# site_id Month number Mean Minimum Maximum Variance Var.Coeff. Std.Dev. Skewness Excess 0.05-Quant. 0.95-Quant. Median'
+ write (outunit, '(A)') 'monthly sum'
+ do i = 1,12
+ arranz = 0
+ do j = 1,yanz
+ if (help_mon(i,j) .gt. -9990.) then
+ arranz = arranz + 1
+ helparr(arranz) = help_mon(i,j)
+ endif
+ enddo ! j
+ htext = adjustr(site_name(ip))
+ idtext = adjustl(htext (131:150)) ! nur letzte 20 Zeichen schreiben
+ write (outunit, '(A20,I5,I8)', advance = 'no') idtext, i, arranz
+ call calc_stat(arranz, helparr, outunit)
+ enddo ! i
+ write (outunit, '(A)') ' '
+ write (outunit, '(A)') 'daily mean per month'
+ do i = 1,12
+ arranz = 0
+ do j = 1,yanz
+ if (help_day(i,j) .gt. -9990.) then
+ arranz = arranz + 1
+ helparr(arranz) = help_day(i,j)
+ endif
+ enddo ! j
+ htext = adjustr(site_name(ip))
+ idtext = adjustl(htext (131:150)) ! nur letzte 20 Zeichen schreiben
+ write (outunit, '(A20,I5,I8)', advance = 'no') idtext, i, arranz
+ call calc_stat(arranz, helparr, outunit)
+ enddo ! i
+enddo ! k
+
+continue
+
+End Subroutine stat_mon
\ No newline at end of file
diff --git a/source_code/version2.2_windows/target_thin.f b/source_code/version2.2_windows/target_thin.f
new file mode 100755
index 0000000000000000000000000000000000000000..fd9b3b9778ec60b48c1e7fd43bf1dd737875fb1b
--- /dev/null
+++ b/source_code/version2.2_windows/target_thin.f
@@ -0,0 +1,578 @@
+!*****************************************************************!
+!* *!
+!* 4C (FORESEE) Simulation Model *!
+!* *!
+!* *!
+!* Subroutine *!
+!* target thinning - *!
+!* thinning routine with given values of biomass per *!
+!* thinning year as target values *!
+!* targetm i given in kg DW/ha *!
+!* *!
+!* 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 target_thinning(i)
+
+use data_stand
+use data_manag
+use data_simul
+use data_species
+use data_par
+
+implicit none
+
+real :: targetm ! target value of stem biomass
+real :: dbhmin=0, &
+ dbhmin_us = 0, &
+ wpa=0, & ! Weibull parameter
+ wpa_us , &
+ wpb=0, & ! -"-
+ wpb_us, &
+ wpc=0, & ! -"-
+ d63=0, &
+ d63_us, &
+ help=0, &
+ pequal, &
+ tdbh=0, &
+ bas_area=0, &
+ bas_help=0., &
+ rtarget_help=0, &
+ target_help1=0,&
+ dbh_h =0, &
+ db_l = 0., &
+ db_u = 0., &
+ d_est=0., &
+ w_kb=0., &
+ stembiom, &
+ stembiom_us = 0. , &
+ stembiom_re = 0. , &
+ stembiom_all = 0. , &
+ diff, &
+ mdiam, &
+ mdiam_us
+
+
+integer :: nrmin, &
+ lowtree, &
+ undertree, &
+ flagth, &
+ taxnr, &
+ counth, &
+ min_id, &
+ max_id, &
+ ih1,ih2,ncoh, &
+ coun1
+! auxilary for thinning routine 4: selective thinning
+integer :: count,i, &
+ idum , third, ipot, isel, ih
+integer,dimension(0:anz_coh) :: cohl
+integer, dimension(anz_coh) :: id_pot
+real :: h1, h2
+real,external :: gasdev
+real:: ran0
+! reacalculation of target to kg DW/patch
+ h1 = 0.
+ h2 = 0.
+ count = 0
+ cohl = -1
+ flagth = 0
+ coun1 = 0
+ help=0.
+ lowtree=0
+ undertree = 0
+ anz_tree_dbh = 0
+ bas_area = 0.
+! stem biomass of overstorey
+ stembiom = 0.
+! stem biomass of understorey
+ stembiom_us = 0.
+ stembiom_all = 0.
+
+ if (time.eq.73.and. ip .eq.87) then
+
+ stembiom = 0
+ end if
+
+taxnr = thin_spec(i)
+mdiam = 0.
+mdiam_us = 0.
+! calculation of mean diameter (correspondung to med_diam) and basal area of stand
+ zeig => pt%first
+ DO
+ IF (.NOT. ASSOCIATED(zeig)) EXIT
+
+! Modification for V Kint: no test for diameter
+ IF((zeig%coh%ntreea>0).and.zeig%coh%species.eq.taxnr.and.zeig%coh%underst.eq.0) THEN
+! overstorey
+ stembiom = stembiom + (zeig%coh%x_sap + zeig%coh%x_hrt)*zeig%coh%ntreea
+ help = help + zeig%coh%ntreea*(zeig%coh%diam**2)
+ bas_area = bas_area + zeig%coh%ntreea*(zeig%coh%diam**2)*pi/4
+ if( zeig%coh%diam>0) then
+ anz_tree_dbh = anz_tree_dbh + zeig%coh%ntreea
+ mdiam = mdiam + zeig%coh%ntreea * (zeig%coh%diam**2)
+ end if
+
+ ! Trees with DBH=0 for population and per species; Baeume mit DBH =0 fuer Bestand und pro Spezie
+ ELSE IF( (zeig%coh%ntreea>0).and.zeig%coh%species.eq.taxnr.and.zeig%coh%underst.eq.1) THEN
+! seedings/regeneration
+ stembiom_re = stembiom_re + (zeig%coh%x_sap + zeig%coh%x_hrt)*zeig%coh%ntreea
+ lowtree = lowtree + zeig%coh%ntreea
+ ELSE if((zeig%coh%ntreea>0).and.zeig%coh%species.eq.taxnr.and.zeig%coh%underst.eq.2) THEN
+! understorey
+ stembiom_us = stembiom_us + (zeig%coh%x_sap + zeig%coh%x_hrt)*zeig%coh%ntreea
+ mdiam_us = mdiam_us + zeig%coh%ntreea * (zeig%coh%diam**2)
+ undertree = undertree + zeig%coh%ntreea
+
+ ENDIF
+ zeig => zeig%next
+ ENDDO
+
+! mean diamteer for over and understorey
+stembiom_all = stembiom + stembiom_us
+if(anz_tree_dbh.ne.0) mdiam = sqrt(mdiam/real(anz_tree_dbh))
+if(undertree.ne.0) mdiam_us = sqrt(mdiam_us/undertree)
+
+third = nint(anz_tree_dbh*0.333333)
+anz_tree_ha = nint(anz_tree_dbh*10000./kpatchsize)
+
+ IF(anz_tree>0)THEN
+ if(lowtree<anz_tree) help = sqrt(help/(anz_tree-lowtree))
+ ENDIF
+
+! setting of aux. variable target_help
+ rtarget_help = stembiom_all
+! tending
+ if(thin_tysp(i).eq.4.or.(stembiom_re.ne.0. .and. stembiom_all.eq.0)) then
+ rtarget_help = stembiom_re
+ end if
+! Umrechnung in Biomasse pro patch in kg
+ targetm = target_mass(i)*1000*kpatchsize/10000.
+
+! target value of biomass
+ if(thin_tysp(i).eq.4 .or.(stembiom_re.ne.0. .and. stembiom_all.eq.0) ) then
+! tending
+ targetm = stembiom_re - targetm*stembiom_re
+ else
+ end if
+
+ if( targetm.eq.1) targetm = 0.
+ ! targetm (kg DW/patch)
+ ! cuttting
+ if (targetm.eq.0.)then
+ zeig => pt%first
+ DO
+ IF (.NOT. ASSOCIATED(zeig)) EXIT
+ if(zeig%coh%species.eq.taxnr.and. zeig%coh%underst.eq.thin_stor(i)) then
+ zeig%coh%ntreem = zeig%coh%ntreea
+ zeig%coh%ntreea = 0
+ zeig%coh%nta = 0
+ end if
+ zeig=> zeig%next
+ END DO
+!tending of regeneration
+
+ else if(thin_tysp(i).eq.4) then
+
+ min_id = 1000
+ max_id = 0.
+ zeig=>pt%first
+ do
+ if(.not.associated(zeig)) exit
+ if(zeig%coh%species.eq.taxnr.and. zeig%coh%underst.eq.1) then
+ ih1 = zeig%coh%ident
+ if(ih1.lt.min_id) min_id = ih1
+ ih2 = zeig%coh%ident
+ if (ih2.gt.max_id) max_id = ih2
+ end if
+ zeig=> zeig%next
+ end do
+ target_help1 = 0.
+ do
+ call random_number(pequal)
+ ncoh = min_id +(max_id-min_id)*pequal
+ zeig=>pt%first
+ do
+ if(.not.associated(zeig)) exit
+ if(zeig%coh%species.eq.taxnr.and. zeig%coh%underst.eq.1.and. zeig%coh%ident.eq.ncoh ) then
+ zeig%coh%ntreea = zeig%coh%ntreea - 1
+ zeig%coh%nta = zeig%coh%nta-1
+ zeig%coh%ntreem = zeig%coh%ntreem +1
+ rtarget_help = rtarget_help - (zeig%coh%x_sap+zeig%coh%x_hrt)
+ exit
+ end if
+ zeig=>zeig%next
+ end do
+
+ diff = targetm - rtarget_help
+ if(diff.lt.0.01) exit
+ end do
+
+
+ else IF ( targetm .ne. 0.) then
+
+ if(target_mass(i).lt.1.) then
+
+ targetm = target_mass(i) * rtarget_help
+
+ end if
+
+! different thinnings from below and above
+ select case(thin_tysp(i))
+ case(1)
+! moderate lower thinning;
+ d_est = 1.02
+ w_kb = 1.8
+ case(2)
+! intensive lower thinning;
+ d_est = 1.03
+ w_kb = 1.5
+ case(3)
+! high thinning;
+ d_est = 1.04
+ w_kb = 1.2
+ end select
+
+
+
+! calculation of Weibull-Parameter
+ call min_dbh_overs(nrmin,dbhmin,taxnr)
+ call min_dbh_unders(nrmin,dbhmin_us, taxnr)
+
+ bas_help = bas_area
+ wpa = dbhmin
+ wpa_us = dbhmin_us
+
+ d63 = mdiam*d_est
+ d63_us = mdiam_us * d_est
+
+ wpb = (d63 - wpa)/ w_kb
+ wpb_us = (d63_us-wpa_us)/w_kb
+
+
+ wpc = 2
+
+ if (thin_tysp(i).eq. 3) then
+! starting with overstorey!, continuing with the understorey
+
+ if(targetm.lt.(stembiom_all-stembiom)) then
+! total removing of overstorey
+ zeig => pt%first
+ DO
+ IF (.NOT. ASSOCIATED(zeig)) EXIT
+ if(zeig%coh%species.eq.taxnr.and. zeig%coh%underst.eq.0) then
+ zeig%coh%ntreem = zeig%coh%ntreea
+ zeig%coh%ntreea = 0
+ zeig%coh%nta = 0
+ end if
+ zeig=> zeig%next
+ END DO
+! defining the remaining part of stem biomass which has to be remove
+ rtarget_help = stembiom_us
+
+! understorey
+!selection of trees for thinning
+ if(mdiam_us.ne.0) then
+! start understorey thinning
+ do
+ call random_number(pequal)
+ tdbh = wpa_us + wpb_us*(-log(1.-pequal))**(1./wpc)
+! list of potential thinned tree chorts
+ counth = 0
+ id_pot = 0
+ ipot = 1
+
+ zeig => pt%first
+ DO
+ IF (.NOT. ASSOCIATED(zeig)) EXIT
+
+ if(zeig%coh%ntreea.gt.0.and.zeig%coh%species.eq.taxnr.and.zeig%coh%underst.eq.2) then
+ dbh_h = zeig%coh%diam
+ db_l = dbh_h - 0.1*dbh_h
+ db_u = dbh_h + 0.1*dbh_h
+ counth = counth +1
+ if (tdbh.ge.db_l.and.tdbh.le.db_u.and. zeig%coh%ntreea.ne. 0) then
+ id_pot(ipot) = zeig%coh%ident
+ ipot = ipot + 1
+ end if
+ if(counth.gt.10000) exit
+ end if
+
+ zeig=> zeig%next
+ END DO ! list of potential thinned tees cohorts
+
+! selecting one equal distributed tree from the list of cohorts
+
+ if ((ipot-1).ge.1) then
+ if((ipot-1).eq.1) then
+
+ isel = 1
+ else
+ pequal = ran0(idum)
+ isel = int(pequal*(ipot-1)) +1
+ end if
+ ih = id_pot(isel)
+
+ zeig => pt%first
+ DO
+ IF (.NOT. ASSOCIATED(zeig)) EXIT
+
+ if(zeig%coh%ident.eq. ih.and.zeig%coh%ntreea.ne. 0 ) then
+ zeig%coh%ntreea = zeig%coh%ntreea -1
+ zeig%coh%nta = zeig%coh%nta -1
+ zeig%coh%ntreem = zeig%coh%ntreem +1
+ rtarget_help = rtarget_help - (zeig%coh%x_sap+zeig%coh%x_hrt)
+ count = count +1
+ exit
+ end if
+ zeig =>zeig%next
+
+ END DO ! thinning of one tree
+ end if
+
+ diff = rtarget_help - targetm
+
+ if(diff.le.0.1) exit
+ if(count.gt.100000) exit
+ end do ! understorey thinning
+ end if ! mediam_us.ne.0
+
+ else ! targetm.lt.(stembiom_all-stembiom)
+
+
+!selection of trees for thinning
+ do
+ call random_number(pequal)
+ tdbh = wpa + wpb*(-log(1.-pequal))**(1./wpc)
+ flagth = 0
+! list of potential thinned tree chorts
+ counth = 0
+ id_pot = 0
+ ipot = 1
+
+ zeig => pt%first
+ DO
+ IF (.NOT. ASSOCIATED(zeig)) EXIT
+ if(zeig%coh%ntreea.gt.0.and.zeig%coh%species.eq.taxnr.and. zeig%coh%underst.eq.0) then
+ dbh_h = zeig%coh%diam
+ db_l = dbh_h - 0.2*dbh_h
+ db_u = dbh_h + 0.2*dbh_h
+ counth = counth +1
+ if (tdbh.ge.db_l.and.tdbh.le.db_u.and. zeig%coh%ntreea.ne. 0) then
+ id_pot(ipot) = zeig%coh%ident
+ ipot = ipot + 1
+ end if
+ if(counth.gt. 100000) exit
+ end if
+
+ zeig=> zeig%next
+ END DO ! list of potential cohorts
+
+! selecting one equal distributed tree from the list of cohorts
+
+ if ((ipot-1).ge.1) then
+ if((ipot-1).eq.1) then
+
+ isel = 1
+ else
+ call random_number(pequal)
+ pequal = ran0(idum)
+ isel = int(pequal*(ipot-1)) +1
+! write(1234,*) time, ipot, pequal, isel
+! if(isel.eq.0) isel =1
+ end if
+ ih = id_pot(isel)
+ zeig => pt%first
+ DO
+ IF (.NOT. ASSOCIATED(zeig)) EXIT
+
+ if(zeig%coh%ident.eq. ih.and.zeig%coh%ntreea.ne. 0 ) then
+ zeig%coh%ntreea = zeig%coh%ntreea -1
+ zeig%coh%nta = zeig%coh%nta -1
+ zeig%coh%ntreem = zeig%coh%ntreem +1
+ coun1 = coun1 + 1
+ rtarget_help = rtarget_help - (zeig%coh%x_sap+zeig%coh%x_hrt)
+ exit
+ end if
+ zeig =>zeig%next
+
+ END DO ! thinning of one tree
+ end if
+ diff = rtarget_help - targetm
+ if(diff.le.0.1) exit
+ if(coun1.gt.100000) exit
+ end do ! total thinning
+ end if !targetm.lt.(stembiom_all-stembiom)
+ end if ! thintype 3
+
+ if(thin_tysp(i).eq.1.or.thin_tysp(i).eq.2) then
+ if(targetm.lt.(stembiom_all-stembiom_us)) then
+! total removing of understorey
+ zeig => pt%first
+ DO
+ IF (.NOT. ASSOCIATED(zeig)) EXIT
+ if(zeig%coh%species.eq.taxnr.and. zeig%coh%underst.eq.2) then
+ zeig%coh%ntreem = zeig%coh%ntreea
+ zeig%coh%ntreea = 0
+ zeig%coh%nta = 0
+ end if
+ zeig=> zeig%next
+ END DO
+
+! definging the remaining part of stem biomass which has to remove
+ rtarget_help = stembiom
+ if(mdiam.ne.0) then
+! additional thinning from the overstorey
+ counth = 0
+ do
+ call random_number(pequal)
+ tdbh = wpa + wpb*(-log(1.-pequal))**(1./wpc)
+ flagth = 0
+! list of potential thinned tree chorts
+ id_pot = 0
+ ipot = 1
+
+ zeig => pt%first
+ DO
+ IF (.NOT. ASSOCIATED(zeig)) EXIT
+ if(zeig%coh%ntreea.gt.0.and.zeig%coh%species.eq.taxnr.and. zeig%coh%underst.eq.0) then
+ dbh_h = zeig%coh%diam
+ db_l = dbh_h - 0.3*dbh_h
+ db_u = dbh_h + 0.3*dbh_h
+ counth = counth +1
+ if (tdbh.ge.db_l.and.tdbh.le.db_u.and. zeig%coh%ntreea.ne. 0) then
+ id_pot(ipot) = zeig%coh%ident
+ ipot = ipot + 1
+ end if
+ if(counth.gt. 100000) exit
+ end if
+
+ zeig=> zeig%next
+ END DO ! list of potential cohorts
+
+! selecting one equal distributed tree from the list of cohorts
+ if ((ipot-1).ge.1) then
+ if((ipot-1).eq.1) then
+ isel = 1
+ else
+ pequal = ran0(idum)
+ isel = int(pequal*(ipot-1)) +1
+ end if
+ ih = id_pot(isel)
+ zeig => pt%first
+ DO
+ IF (.NOT. ASSOCIATED(zeig)) EXIT
+
+ if(zeig%coh%ident.eq. ih.and.zeig%coh%ntreea.ne. 0 ) then
+ zeig%coh%ntreea = zeig%coh%ntreea -1
+ zeig%coh%nta = zeig%coh%nta -1
+ zeig%coh%ntreem = zeig%coh%ntreem +1
+ coun1 = coun1 + 1
+ rtarget_help = rtarget_help - (zeig%coh%x_sap+zeig%coh%x_hrt)
+ exit
+ end if
+ zeig =>zeig%next
+ END DO ! thinning of one tree
+ end if
+ diff = rtarget_help - targetm
+ if(diff.le.0.1) exit
+ if(counth.gt.100000) exit
+ end do ! overstorey thinning
+ end if ! mdiam.ne.0
+else ! targtem.lt.(stembiom_all-stembiom_us)
+
+! first thinning from the understorey
+!selection of trees for thinning
+ if(mdiam_us.ne.0) then
+ do
+ call random_number(pequal)
+ tdbh = wpa_us + wpb_us*(-log(1.-pequal))**(1./wpc)
+! list of potential thinned tree chorts
+ counth = 0
+ id_pot = 0
+ ipot = 1
+
+ zeig => pt%first
+ DO
+ IF (.NOT. ASSOCIATED(zeig)) EXIT
+ if(zeig%coh%ntreea.gt.0.and.zeig%coh%species.eq.taxnr.and.zeig%coh%underst.eq.1) then
+ dbh_h = zeig%coh%diam
+ db_l = dbh_h - 0.1*dbh_h
+ db_u = dbh_h + 0.1*dbh_h
+ counth = counth +1
+ if (tdbh.ge.db_l.and.tdbh.le.db_u.and. zeig%coh%ntreea.ne. 0) then
+ id_pot(ipot) = zeig%coh%ident
+ ipot = ipot + 1
+ end if
+ if(counth .gt. 100000) exit
+ end if
+
+ zeig=> zeig%next
+ END DO ! list of potential cohorts
+
+! selecting one equal distributed tree from the list of cohorts
+ if ((ipot-1).ge.1) then
+ if((ipot-1).eq.1) then
+ isel = 1
+ else
+ pequal = ran0(idum)
+ isel = int(pequal*(ipot-1)) +1
+ end if
+ ih = id_pot(isel)
+ zeig => pt%first
+ DO
+ IF (.NOT. ASSOCIATED(zeig)) EXIT
+ if(zeig%coh%ident.eq. ih.and.zeig%coh%ntreea.ne. 0 ) then
+ zeig%coh%ntreea = zeig%coh%ntreea -1
+ zeig%coh%nta = zeig%coh%nta -1
+ zeig%coh%ntreem = zeig%coh%ntreem +1
+ coun1 = coun1 + 1
+ rtarget_help = rtarget_help - (zeig%coh%x_sap+zeig%coh%x_hrt)
+ exit
+ end if
+ zeig =>zeig%next
+ END DO ! thinning of one tree
+ end if
+
+ diff = rtarget_help - targetm
+
+ if(diff.le.0.1 .or. (stembiom_all-stembiom_us).eq.rtarget_help) exit
+ if(coun1.gt.100000) exit
+ end do ! understorey thinning
+ end if ! mdiam_us
+ end if
+ end if !! thin_tysp.eq.1 or. thin-tysp.eq.2
+
+ END IF ! all thinnings and tending
+
+
+ zeig=>pt%first
+ do
+ if(.not.associated(zeig)) exit
+
+
+ if(zeig%coh%ntreem>0.and.zeig%coh%species.eq.taxnr) then
+! all parts without stems of trees are input for litter
+ h1 = zeig%coh%ntreem*zeig%coh%x_fol
+ h2 = h2 + h1
+
+ 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
+ endif
+ zeig=>zeig%next
+ enddo
+END SUBROUTINE target_thinning
diff --git a/source_code/version2.2_windows/target_thinstemnum.f b/source_code/version2.2_windows/target_thinstemnum.f
new file mode 100755
index 0000000000000000000000000000000000000000..517e4bf82d74bf101d2db994ad4ded1f8a616440
--- /dev/null
+++ b/source_code/version2.2_windows/target_thinstemnum.f
@@ -0,0 +1,383 @@
+!*****************************************************************!
+!* *!
+!* 4C (FORESEE) Simulation Model *!
+!* *!
+!* *!
+!* Subroutine *!
+!* target thinning - *!
+!* thinning routine with given values of biomass per *!
+!* thinning year as target values *!
+!* rtargetm i given in kg DW/ha *!
+!* *!
+!* 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 target_thinning_OC(i)
+
+use data_stand
+use data_manag
+use data_simul
+use data_species
+use data_par
+
+implicit none
+
+real :: rtargetm=0. ! target value of stem biomass
+integer :: target_help = 0.
+
+real :: dbhmin=0, &
+ dbhmin_us = 0, &
+ wpa=0, & ! Weibull parameter
+ wpb=0, & ! -"-
+ wpc=0, & ! -"-
+ d63=0, &
+ help=0, &
+ pequal, &
+ tdbh=0, &
+ bas_area=0, &
+ bas_help=0., &
+ target_help1=0,&
+ dbh_h =0, &
+ db_l = 0., &
+ db_u = 0., &
+ d_est=0., &
+ w_kb=0., &
+ stembiom, &
+ stembiom_us, &
+ stembiom_re, &
+ stembiom_all, &
+ diff, &
+ mdiam, &
+ mdiam_us
+
+
+integer :: nrmin, &
+ lowtree, &
+ undertree, &
+ flagth, &
+ taxnr, &
+ counth, &
+ min_id, &
+ max_id, &
+ ih1,ih2,ncoh, &
+ coun1
+! auxilarity for thinning routine 4: selective thinning
+integer :: count, i, &
+ idum,third, ipot, isel, ih
+integer,dimension(0:anz_coh) :: cohl
+integer, dimension(anz_coh) :: id_pot
+
+real :: h1, h2 , tar_h
+real,external :: gasdev
+real:: ran0
+
+
+! reacalculation of target to kg DW/patch
+ h1 = 0.
+ h2 = 0.
+ count = 0
+ cohl = -1
+ flagth = 0
+ coun1 = 0
+ help=0.
+ lowtree=0
+ undertree = 0
+ anz_tree_dbh = 0
+ bas_area = 0.
+! stem biomass of overstorey
+ stembiom = 0.
+! stem biomass of understorey
+ stembiom_us = 0.
+ stembiom_all = 0.
+ tar_h = 300.
+
+ if (time.eq.73.and. ip .eq.87) then
+
+ stembiom = 0
+ end if
+
+taxnr = thin_spec(i)
+mdiam = 0.
+mdiam_us = 0.
+! calculation of mean diameter (correspondung to med_diam) and basal area of stand
+ zeig => pt%first
+ DO
+ IF (.NOT. ASSOCIATED(zeig)) EXIT
+
+! Modification for V Kint: no test for diameter
+ IF((zeig%coh%ntreea>0).and.zeig%coh%species.eq.taxnr.and.zeig%coh%underst.eq.0) THEN
+! overstorey
+ stembiom = stembiom + (zeig%coh%x_sap + zeig%coh%x_hrt)*zeig%coh%ntreea
+ help = help + zeig%coh%ntreea*(zeig%coh%diam**2)
+ bas_area = bas_area + zeig%coh%ntreea*(zeig%coh%diam**2)*pi/4
+ if( zeig%coh%diam>0) then
+ anz_tree_dbh = anz_tree_dbh + zeig%coh%ntreea
+ mdiam = mdiam + zeig%coh%ntreea * (zeig%coh%diam**2)
+ end if
+
+ ! Trees with DBH=0 for populations and per species; Baeume mit DBH =0 fuer Bestand und pro Spezie
+ ELSE IF( (zeig%coh%ntreea>0).and.zeig%coh%species.eq.taxnr.and.zeig%coh%underst.eq.1) THEN
+! seedings/regeneration
+ stembiom_re = stembiom_re + (zeig%coh%x_sap + zeig%coh%x_hrt)*zeig%coh%ntreea
+ lowtree = lowtree + zeig%coh%ntreea
+ ELSE if((zeig%coh%ntreea>0).and.zeig%coh%species.eq.taxnr.and.zeig%coh%underst.eq.2) THEN
+! understorey
+ stembiom_us = stembiom_us + (zeig%coh%x_sap + zeig%coh%x_hrt)*zeig%coh%ntreea
+ mdiam_us = mdiam_us + zeig%coh%ntreea * (zeig%coh%diam**2)
+ undertree = undertree + zeig%coh%ntreea
+
+ ENDIF
+ zeig => zeig%next
+ ENDDO
+
+! mean diameter for over and understorey
+stembiom_all = stembiom + stembiom_us
+if(anz_tree_dbh.ne.0) mdiam = sqrt(mdiam/real(anz_tree_dbh))
+if(undertree.ne.0) mdiam_us = sqrt(mdiam_us/undertree)
+
+third = nint(anz_tree_dbh*0.333333)
+anz_tree_ha = nint(anz_tree_dbh*10000./kpatchsize)
+anz_tree = anz_tree_dbh + undertree
+
+ IF(anz_tree>0)THEN
+ if(lowtree<anz_tree) help = sqrt(help/(anz_tree-lowtree))
+
+ ENDIF
+
+if(thin_stor(i).eq.0) then
+ target_help = anz_tree_dbh
+else
+ target_help = undertree
+end if
+
+! tending
+ if(thin_tysp(i).eq.4) target_help = stembiom_re
+
+ if(target_mass(i).gt.1) then
+ rtargetm = target_mass(i)*kpatchsize/10000.
+ else
+ rtargetm = target_mass(i)
+ end if
+
+! target value of biomass
+ if(thin_tysp(i).eq.4) then
+ rtargetm = stembiom_re - rtargetm*stembiom_re
+ else
+ end if
+
+ ! cuttting
+ if (rtargetm.eq.0.)then
+ zeig => pt%first
+ DO
+ IF (.NOT. ASSOCIATED(zeig)) EXIT
+ if(zeig%coh%species.eq.taxnr.and. zeig%coh%underst.eq.thin_stor(i)) then
+ zeig%coh%ntreem = zeig%coh%ntreea
+ zeig%coh%ntreea = 0
+ zeig%coh%nta = 0
+ end if
+ zeig=> zeig%next
+ END DO
+
+!tending of regeneration
+
+else if(thin_tysp(i).eq.4) then
+
+ min_id = 1000
+ max_id = 0.
+ zeig=>pt%first
+ do
+ if(.not.associated(zeig)) exit
+ if(zeig%coh%species.eq.taxnr.and. zeig%coh%underst.eq.1) then
+ ih1 = zeig%coh%ident
+ if(ih1.lt.min_id) min_id = ih1
+ ih2 = zeig%coh%ident
+ if (ih2.gt.max_id) max_id = ih2
+ end if
+ zeig=> zeig%next
+ end do
+ target_help1 = 0.
+ do
+ call random_number(pequal)
+ ncoh = min_id +(max_id-min_id)*pequal
+ zeig=>pt%first
+ do
+ if(.not.associated(zeig)) exit
+ if(zeig%coh%species.eq.taxnr.and. zeig%coh%underst.eq.1.and. zeig%coh%ident.eq.ncoh ) then
+ zeig%coh%ntreea = zeig%coh%ntreea - 1
+ zeig%coh%nta = zeig%coh%nta-1
+ zeig%coh%ntreem = zeig%coh%ntreem +1
+ target_help = target_help - zeig%coh%ntreea
+ exit
+ end if
+ zeig=>zeig%next
+ end do
+
+ diff = rtargetm -target_help
+ if(diff.lt.0.01) exit
+ end do
+
+! different thinnings from below and above
+else IF ( rtargetm .ne. 0.) then
+
+ if(target_mass(i).lt.1.) then
+ rtargetm = target_mass(i) * target_help
+! No management if rtargetm=1
+ else if (rtargetm.eq.1) then
+ return
+endif
+
+ select case(thin_tysp(i))
+ case(1)
+! medium lower thinning
+ d_est = 1.02
+ w_kb = 2.5
+ case(2)
+! strong lower thinning
+ d_est = 1.03
+ w_kb = 1.5
+ case(3)
+! High thinning
+ d_est = 1.04
+ w_kb = 1.2
+ end select
+
+
+
+! calculation of Weibull-Parameter
+ call min_dbh_overs(nrmin,dbhmin,taxnr)
+ call min_dbh_unders(nrmin,dbhmin_us, taxnr)
+
+ bas_help = bas_area
+if (thin_stor(i).eq.0) then
+ wpa = dbhmin
+else
+ wpa = dbhmin_us
+
+end if
+if (thin_stor(i).eq.0) then
+ d63 = mdiam*d_est
+else
+ d63 = mdiam_us * d_est
+end if
+
+ wpb = (d63 - wpa)/ w_kb
+ wpc = 2
+ wpc = 0.8
+
+ if ((thin_tysp(i).ne.4) .and. rtargetm.lt.target_help) then
+
+!selection of trees for thinning
+ do
+ call random_number(pequal)
+
+ tdbh = wpa + wpb*(-log(1.-pequal))**(1./wpc)
+ flagth = 0
+! list of potential thinned tree chorts
+ counth = 0
+ id_pot = 0
+ ipot = 1
+ zeig => pt%first
+
+ DO
+ IF (.NOT. ASSOCIATED(zeig)) EXIT
+
+ if(zeig%coh%notviable.eqv. .TRUE.) then
+ if(flag_mort.eq.0) then
+ id_pot(ipot)=zeig%coh%ident
+ ipot=ipot + 1
+ endif
+ else if(zeig%coh%ntreea.gt.0.and.zeig%coh%species.eq.taxnr.and. zeig%coh%underst.eq.thin_stor(i)) then
+ dbh_h = zeig%coh%diam
+ db_l = dbh_h - 0.1*dbh_h
+ db_u = dbh_h + 0.1*dbh_h
+ counth = counth +1
+ if (tdbh.ge.db_l.and.tdbh.le.db_u.and. zeig%coh%ntreea.ne. 0) then
+ id_pot(ipot) = zeig%coh%ident
+ ipot = ipot + 1
+ end if
+ if(counth.gt. 100000) exit
+ end if
+
+ zeig=> zeig%next
+ END DO ! list of potential thinned tree cohorts
+
+! selecting one equal distributed tree from the list of cohorts
+
+ if ((ipot-1).ge.1) then
+ if((ipot-1).eq.1) then
+
+ isel = 1
+ else
+ call random_number(pequal)
+ pequal = ran0(idum)
+ isel = int(pequal*(ipot-1)) +1
+ end if
+ ih = id_pot(isel)
+ zeig => pt%first
+ DO
+ IF (.NOT. ASSOCIATED(zeig)) EXIT
+
+ if(zeig%coh%ident.eq. ih.and.zeig%coh%ntreea.ne. 0 ) then
+ if(zeig%coh%notviable.eqv..TRUE.) then
+ if(flag_mort.eq.0) then
+ zeig%coh%ntreem = zeig%coh%ntreea
+ zeig%coh%ntreea=0
+ zeig%coh%nta=0
+ coun1=coun1+1
+ target_help = target_help - zeig%coh%ntreem
+ endif
+ else
+ zeig%coh%ntreea = zeig%coh%ntreea -1
+ zeig%coh%nta = zeig%coh%nta -1
+ zeig%coh%ntreem = zeig%coh%ntreem +1
+ coun1 = coun1 + 1
+ target_help = target_help - 1
+ exit
+ end if
+ end if
+ zeig =>zeig%next
+
+ END DO ! thinning of one tree
+ end if
+
+ diff = target_help - rtargetm
+ if(diff.le.0.1) exit
+ if(coun1.gt.100000) exit
+ end do ! total thinning
+
+ end if ! thintype 1,2,3
+
+ END IF ! all thinnings and tending
+
+! adding biomasses to litter pools depending on stage of stand
+ zeig=>pt%first
+
+ do
+ if(.not.associated(zeig)) exit
+ if(zeig%coh%ntreem>0.and.zeig%coh%species.eq.taxnr) then
+! all parts without stems of trees are input for litter
+ h1 = zeig%coh%ntreem*zeig%coh%x_fol
+ h2 = h2 + h1
+
+ 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
+ endif
+ zeig=>zeig%next
+
+ enddo
+call class_man
+END SUBROUTINE target_thinning_OC
diff --git a/source_code/version2.2_windows/timsort.f b/source_code/version2.2_windows/timsort.f
new file mode 100755
index 0000000000000000000000000000000000000000..fa9654ad1ca2ce4e2e3e7b21a65dd69a61b0f51e
--- /dev/null
+++ b/source_code/version2.2_windows/timsort.f
@@ -0,0 +1,1033 @@
+!*****************************************************************!
+!* *!
+!* 4C (FORESEE) Simulation Model *!
+!* *!
+!* *!
+!* SUBROUTINE *!
+!* timsort - for sorting of harvested timber to *!
+!* different timber qualities *!
+!* definition: *!
+!* ste - stems *!
+!* sg1/sg2 - stem segments *!
+!* in1/in2 - industrial wood *!
+!* fue - fuelwood *!
+!* Subroutine: *!
+!* out_tim - generating field sort *!
+!* out_timlist *!
+!* fuction rabf *!
+!* *!
+!* 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 timsort
+
+use data_stand
+use data_species
+use data_tsort
+use data_simul
+use data_par
+use data_manag
+
+!***************** wpm ************************
+use data_wpm
+use data_stand
+use data_species
+!***************** wpm ************************
+
+implicit none
+
+integer i
+real h,dbh,db, dcrb, hbo, llazmin, lx,lxz,lldmin ,llasdmin,liszmin,help,lisdmin,llzmin
+real h1,h2,dcrb_org,db_org,suml, h_org, sumbio_help,sumvol, h3
+real (KIND = dg) :: calcvol
+character(4) K
+character(2) standt
+integer count,count_old,taxid
+real, external :: rabf
+real :: diam_base=0. ! diameter at basis
+llazmin=0.;lx=0.;lldmin=0.;llasdmin=0.; liszmin=0.;lisdmin=0.;llzmin=0.
+count = 1
+sumbio_help = 0
+DO i=1,nspec_tree
+
+ zeig => pt%first
+ DO
+ IF (.NOT. ASSOCIATED(zeig)) EXIT
+! Douglasie --- > Kiefer
+ taxid = zeig%coh%species
+ IF(taxid .EQ. 10) taxid = 3
+ IF(taxid .EQ. i) THEN
+
+ calcvol = 0.
+ sumvol = 0.
+ h = zeig%coh%height -stoh(i) ! stump correction
+ hbo = zeig%coh%x_hbole
+ dbh = zeig%coh%diam
+ dcrb = zeig%coh%dcrb
+ dcrb_org = dcrb
+ suml = stoh(i) ! hight of stump; stockhöhe
+ h_org = zeig%coh%height
+
+! calculation of stump biomass for harvesting
+
+
+! selection of small trees with out dbh
+! IF (dbh.eq.0.) THEN
+!litter
+
+
+ diam_base= sqrt((zeig%coh%x_ahb+zeig%coh%asapw)*4/pi)
+
+
+ if(hbo.ne.0) then
+ db = dcrb + (hbo-stoh(i))*(diam_base-dcrb)/hbo
+ else if (hbo.eq.0)then
+ db = diam_base*h/(h + stoh(i))
+ end if
+
+
+
+ db_org = db
+
+ if( hbo.eq.0) then
+ llzmin=0
+ lx=0
+ end if
+! stems
+
+ help = rabf(i,lzmin(i))
+ if(db.ge.(lzmin(i) + rabf(i,lzmin(i)))) then
+
+! calculation of lenght at diameter = lzmin
+! llzmin > h can occur
+ if ( dcrb .gt. lzmin(i)+rabf(i,lzmin(i))) then
+ llzmin = h-(h-hbo)*(lzmin(i)+rabf(i,lzmin(i)))/dcrb
+ else if (dcrb.le.lzmin(i)+rabf(i,lzmin(i))) then
+ llzmin = hbo -hbo*(lzmin(i)+rabf(i,lzmin(i))-dcrb)/(db-dcrb)
+ end if
+
+! calculation of diameter at llzmin/2
+ if (llzmin/2.lt. hbo) then
+
+ lx = dcrb + (db-dcrb)*(hbo-llzmin/2)/hbo
+ else
+ lx = dcrb*(h- llzmin/2)/(h-hbo)
+ end if
+
+! begin of sorting stem lumbre
+if( flag_sort.eq.0) then
+ if( llzmin.ge. lmin(i).and. lx.ge. ldmin(i)+rabf(i,ldmin(i))) then
+ k = 'ste'
+ if(zeig%coh%ntreem.ne.0.) then
+ standt='ab'
+ call out_tim(count,i,k,llzmin + zug ,lx,lzmin(i), zeig%coh%ntreem,&
+ standt,h,hbo,db,dcrb,calcvol)
+ end if
+ if(zeig%coh%ntreea.ne.0.) then
+ standt='vb'
+ call out_tim(count,i,k,llzmin + zug ,lx,lzmin(i), zeig%coh%ntreea,&
+ standt,h,hbo,db,dcrb,calcvol)
+ end if
+ if(zeig%coh%ntreed.ne.0..and.flag_mg.ne.0.and.zeig%coh%diam.gt.tardiam_dstem) then
+ if(thin_flag1(1).ge.0) then
+ standt='tb'
+ flag_deadsort = 1
+ call out_tim(count,i,k,llzmin + zug ,lx,lzmin(i), zeig%coh%ntreed,&
+ standt,h,hbo,db,dcrb,calcvol)
+ end if
+ end if
+ suml = suml +llzmin+zug
+ sumvol = sumvol + calcvol
+ calcvol = 0.
+ count = count + 1
+ h = h-llzmin-zug
+ if(h.lt.0.) h = 0.
+ db = lzmin(i)
+ else
+! Höhe Hx berechnen, wo lx = ldmin(i)+rabf(i,ldmin(i)) , dann testen, ob 2*Hx >= lmin ist,
+!wenn ja, abspeichern in sto
+ if (dcrb .gt.(ldmin(i)+rabf(i,ldmin(i)))) then
+ lldmin= h-(h-hbo)*(ldmin(i)+rabf(i,ldmin(i)))/dcrb
+ else if (dcrb.le.(ldmin(i)+rabf(i,ldmin(i)))) then
+ lldmin = hbo - hbo*(ldmin(i)+rabf(i,ldmin(i))-dcrb)/(db_org-dcrb)
+ end if
+! calculation of diameter at 2*lldmin and test against lzmin
+!(Durchmesser an der Spitze des Stammstückes
+ if (2*lldmin.lt. hbo) then
+
+ lx = dcrb + (db_org-dcrb)*(hbo-lldmin*2)/hbo
+ else
+ lx = dcrb*(h- lldmin*2)/(h-hbo)
+ end if
+
+ if (2*lldmin .ge. lmin(i) .and. lx.ge.lzmin(i)+rabf(i,lx)) then
+!second test Stammholz!
+ k = 'ste'
+ if(zeig%coh%ntreem.ne.0.) then
+ standt='ab'
+ call out_tim(count,i,k,2*lldmin + zug,ldmin(i),lx, zeig%coh%ntreem,&
+ standt,h,hbo,db,dcrb_org,calcvol)
+ end if
+ if(zeig%coh%ntreea.ne.0.) then
+ standt='vb'
+ call out_tim(count,i,k,2*lldmin + zug,ldmin(i),lx, zeig%coh%ntreea,&
+ standt,h,hbo,db,dcrb_org,calcvol)
+ end if
+ if(zeig%coh%ntreed.ne.0..and.flag_mg.ne.0.and.zeig%coh%diam.gt.tardiam_dstem) then
+ if(thin_flag1(1).ge.0) then
+ standt='tb'
+ flag_deadsort = 1
+ call out_tim(count,i,k,2*lldmin + zug,ldmin(i),lx, zeig%coh%ntreed,&
+ standt,h,hbo,db,dcrb_org,calcvol)
+ end if
+ end if
+
+ suml = suml + 2*lldmin + zug
+ sumvol=sumvol + calcvol
+ calcvol = 0.
+ count = count + 1
+ h = h - 2*lldmin-zug
+ if(h.lt.0.) h = 0.
+ db = lx
+ end if
+ end if
+ end if ! db.gt. lzmin(i)
+ end if ! flag_sortst
+! ende test Stammholz
+
+! begin test auf Stammstücke
+
+! calculation of length at diamter lazmin(i)
+ Do while((h.ge.lasfixl1(i).or.h.ge.lasfixl2(i)).and. hbo.ne.0.)
+ count_old = count
+ IF(db .ge.laszmin(i)+rabf(i,laszmin(i)).and. db.gt.lasdmin(i)+ rabf(i,lasdmin(i))) THEN
+ if (dcrb .eq.0.) then
+ llazmin = (h_org-suml) -(h_org-stoh(i))*(laszmin(i)+rabf(i,laszmin(i)))/db
+ else if ( dcrb .gt. laszmin(i)+rabf(i,laszmin(i))) then
+ llazmin =(h_org-suml)- (h_org-hbo)*(laszmin(i)+rabf(i,laszmin(i)))/dcrb
+ else if (dcrb.le.laszmin(i)+rabf(i,laszmin(i))) then
+ llazmin = (hbo-suml) -hbo*(laszmin(i)+rabf(i,laszmin(i))-dcrb)/(db_org-dcrb)
+ end if
+
+ if(llazmin.ge.lasfixl1(i)) then
+ if(flag_sort.eq.2) then
+ llazmin = lasfixl2(i)
+ else
+ llazmin = lasfixl1(i)
+ end if
+ else if(llazmin.ge.lasfixl2(i)) then
+ llazmin = lasfixl2(i)
+ end if
+
+! calculation of diameter lx at llazmin/2
+
+ if (dcrb .eq.0.) then
+ lx = db*(h_org-(suml+llazmin/2))/(h_org-stoh(i))
+ else if ((suml+llazmin/2).lt. hbo) then
+
+ lx = dcrb + (db_org-dcrb)*(hbo-(suml+llazmin/2))/hbo
+ else
+ lx = dcrb*(h_org-(suml+ llazmin/2))/(h_org-hbo)
+ end if
+! calculation of diameter at llazmin
+ if (dcrb .eq.0.) then
+ lxz = db*(h_org-(suml+llazmin))/(h_org-stoh(i))
+ else if ((suml+llazmin).lt. hbo) then
+
+ lxz = dcrb + (db_org-dcrb)*(hbo-(suml+llazmin))/hbo
+ else
+ lxz = dcrb*(h_org-(suml+ llazmin))/(h_org-hbo)
+ end if
+! test
+ help = lasdmin(i)+rabf(i,lasdmin(i))
+
+! if flag_sort = 2 only lasfixl2 is used
+ h3 = lasdmin(i)+rabf(i,lasdmin(i))
+
+ if (llazmin.ge. lasfixl1(i).and. lx.ge. lasdmin(i)+rabf(i,lasdmin(i)).and. flag_sort.ne.2) then
+ k = 'sg1'
+ if(zeig%coh%ntreem.ne.0.) then
+ standt = 'ab'
+ call out_tim(count,i,k,llazmin+zug,lx,lxz, zeig%coh%ntreem,&
+ standt,h,hbo,db,dcrb_org,calcvol)
+ end if
+ if(zeig%coh%ntreea.ne.0.) then
+ standt = 'vb'
+ call out_tim(count,i,k,llazmin+zug,lx,lxz, zeig%coh%ntreea,&
+ standt,h,hbo,db,dcrb_org,calcvol)
+ end if
+ if(zeig%coh%ntreed.ne.0..and.flag_mg.ne.0.and.zeig%coh%diam.gt.tardiam_dstem) then
+ if(thin_flag1(1).ge.0) then
+ flag_deadsort = 1
+ standt = 'tb'
+ call out_tim(count,i,k,llazmin+zug,lx,lxz, zeig%coh%ntreed,&
+ standt,h,hbo,db,dcrb_org,calcvol)
+ end if
+ end if
+
+ suml = suml + llazmin+zug
+ sumvol = sumvol +calcvol
+ calcvol =0.
+ count = count + 1
+ h = h - llazmin-zug
+ if(h.lt.0.) h = 0.
+ db = lxz
+
+! test
+! if flag_sort = 3 only lasfixl1 is unsed
+ else if (llazmin.ge.lasfixl2(i).and.llazmin.lt.lasfixl1(i).and. lx.ge. lasdmin(i)+rabf(i,lasdmin(i)).and. flag_sort.ne.3) then
+ k = 'sg2'
+ if(zeig%coh%ntreem.ne.0.) then
+ standt = 'ab'
+ call out_tim(count,i,k,llazmin + zug,lx, lxz,zeig%coh%ntreem,standt,h,hbo,db,dcrb_org,calcvol)
+ end if
+ if(zeig%coh%ntreea.ne.0.) then
+ standt = 'vb'
+ call out_tim(count,i,k,llazmin + zug,lx, lxz,zeig%coh%ntreea,standt,h,hbo,db,dcrb_org,calcvol)
+ end if
+ if(zeig%coh%ntreed.ne.0..and.flag_mg.ne.0.and.zeig%coh%diam.gt.tardiam_dstem) then
+ if(thin_flag1(1).ge.0) then
+ flag_deadsort = 1
+ standt = 'tb'
+ call out_tim(count,i,k,llazmin + zug,lx, lxz,zeig%coh%ntreed,standt,h,hbo,db,dcrb_org,calcvol)
+ end if
+ end if
+
+ suml = suml + llazmin+zug
+ sumvol = sumvol + calcvol
+ calcvol = 0.
+ count = count + 1
+ h = h - llazmin-zug
+ if(h.lt.0.) h = 0.
+ db = lxz
+
+
+ else
+ if (dcrb.eq.0) then
+ llasdmin = (h_org-suml)- (h_org-stoh(i))*(lasdmin(i)+rabf(i,lasdmin(i)))/db
+ else if (dcrb .gt. lasdmin(i)+rabf(i,lasdmin(i))) then
+ llasdmin = (h_org-suml)-(h_org-hbo)*(lasdmin(i)+rabf(i,lasdmin(i)))/dcrb
+ else if (dcrb.le.lasdmin(i)+rabf(i,lasdmin(i))) then
+ llasdmin = (hbo-suml)-hbo*(lasdmin(i)+rabf(i,lasdmin(i))-dcrb)/(db_org-dcrb)
+ end if
+ if(2*llasdmin.ge.lasfixl1(i)) then
+ llasdmin = lasfixl1(i)/2.
+ else if(2*llasdmin.ge.lasfixl2(i)) then
+ llasdmin = lasfixl2(i)/2.
+ end if
+
+!calculation lx diameter at 2*llasdmin
+ if (dcrb .eq.0.) then
+ lx = db*(h_org-suml-llasdmin*2)/(h_org-stoh(i))
+ else if ((suml+2*llasdmin).lt. hbo) then
+
+ lx = dcrb + (db_org-dcrb)*(hbo-(suml+2*llasdmin))/hbo
+ else
+ lx = dcrb*(h_org- suml-2*llasdmin)/(h_org-hbo)
+ end if
+
+! if flag_sort = 2 only lasfixl2 is used
+ if(2*llasdmin.ge.lasfixl1(i).and.lx.ge.laszmin(i)+rabf(i,laszmin(i)).and. flag_sort.ne.2) then
+ k = 'sg1'
+ if(zeig%coh%ntreem.ne.0.) then
+ standt = 'ab'
+ call out_tim(count,i,k,2*llasdmin + zug,lasdmin(i),lx, zeig%coh%ntreem, standt,h,hbo,db,dcrb_org,calcvol)
+ end if
+ if(zeig%coh%ntreea.ne.0.) then
+ standt = 'vb'
+ call out_tim(count,i,k,2*llasdmin + zug,lasdmin(i),lx, zeig%coh%ntreea, standt,h,hbo,db,dcrb_org,calcvol)
+ end if
+ if(zeig%coh%ntreed.ne.0..and.flag_mg.ne.0.and.zeig%coh%diam.gt.tardiam_dstem) then
+ if(thin_flag1(1).ge.0) then
+ flag_deadsort = 1
+ standt = 'tb'
+ call out_tim(count,i,k,2*llasdmin + zug,lasdmin(i),lx, zeig%coh%ntreed, standt,h,hbo,db,dcrb_org,calcvol)
+ end if
+ end if
+
+ count = count + 1
+ suml = suml + 2*llasdmin + zug
+ sumvol = sumvol + calcvol
+ calcvol = 0.
+ h = h - 2*llasdmin-zug
+ if(h.lt.0.) h = 0.
+ db = lx
+
+
+! if flag_sort = 3 only lasfixl1 is unsed
+ else if (2*llasdmin.ge.lasfixl2(i).and.2*llasdmin.lt.lasfixl2(i) .and.lx.ge.laszmin(i)+rabf(i,laszmin(i)).and.flag_sort.ne.3) then
+ k = 'sg2'
+ if(zeig%coh%ntreem.ne.0.) then
+ standt = 'ab'
+ call out_tim(count,i,k,2*llasdmin + zug,lasdmin(i),lx, zeig%coh%ntreem, standt,h,hbo,db,dcrb_org,calcvol)
+ end if
+ if(zeig%coh%ntreea.ne.0.) then
+ standt = 'vb'
+ call out_tim(count,i,k,2*llasdmin + zug,lasdmin(i),lx, zeig%coh%ntreea, standt,h,hbo,db,dcrb_org,calcvol)
+ end if
+ if(zeig%coh%ntreed.ne.0..and.flag_mg.ne.0.and.zeig%coh%diam.gt.tardiam_dstem) then
+ if(thin_flag1(1).ge.0) then
+ flag_deadsort = 1
+ standt = 'tb'
+ call out_tim(count,i,k,2*llasdmin + zug,lasdmin(i),lx, zeig%coh%ntreed, standt,h,hbo,db,dcrb_org,calcvol)
+ end if
+ end if
+
+ count = count + 1
+ suml = suml + 2*llasdmin + zug
+ sumvol = sumvol + calcvol
+ calcvol = 0.
+ h = h - 2*llasdmin-zug
+ if(h.lt.0.) h = 0.
+ db = lx
+ end if
+ end if
+
+ END IF ! db.gt. laszmin(i)
+ if(count.eq.count_old) exit
+ END DO
+! end test
+
+! assortment LAS1a for pine
+Do while((h.ge.lasfixl1(i).or.h.ge.lasfixl2(i)).and.i.eq.3)
+ count_old = count
+ IF(db .ge.las1zmin(i)+rabf(i,las1zmin(i)).and. db.gt.las1dmin(i)+ rabf(i,las1dmin(i))) THEN
+ if (dcrb .eq.0.) then
+ llazmin = (h_org-suml) -(h_org-stoh(i))*(las1zmin(i)+rabf(i,las1zmin(i)))/db
+ else if ( dcrb .gt. las1zmin(i)+rabf(i,las1zmin(i))) then
+ llazmin =(h_org-suml)- (h_org-hbo)*(las1zmin(i)+rabf(i,las1zmin(i)))/dcrb
+ else if (dcrb.le.las1zmin(i)+rabf(i,las1zmin(i))) then
+ llazmin = (hbo-suml) -hbo*(las1zmin(i)+rabf(i,las1zmin(i))-dcrb)/(db_org-dcrb)
+ end if
+
+ if(llazmin.ge.lasfixl1(i)) then
+ if(flag_sort.eq.2) then
+ llazmin = lasfixl2(i)
+ else
+ llazmin = lasfixl1(i)
+ end if
+ else if(llazmin.ge.lasfixl2(i)) then
+ llazmin = lasfixl2(i)
+ end if
+
+! calculation of diameter lx at llazmin/2
+ if (dcrb .eq.0.) then
+ lx = db*(h_org-(suml+llazmin/2))/(h_org-stoh(i))
+ else if ((suml+llazmin/2).lt. hbo) then
+
+ lx = dcrb + (db_org-dcrb)*(hbo-(suml+llazmin/2))/hbo
+ else
+ lx = dcrb*(h_org-(suml+ llazmin/2))/(h_org-hbo)
+ end if
+
+! calculation of diameter at llazmin
+ if (dcrb .eq.0.) then
+ lxz = db*(h_org-(suml+llazmin))/(h_org-stoh(i))
+ else if ((suml+llazmin).lt. hbo) then
+
+ lxz = dcrb + (db_org-dcrb)*(hbo-(suml+llazmin))/hbo
+ else
+ lxz = dcrb*(h_org-(suml+ llazmin))/(h_org-hbo)
+ end if
+
+
+! if flag_sort = 2 only lasfixl2 is used
+ help = las1dmin(i)+rabf(i,las1dmin(i))
+ if (llazmin.ge. lasfixl1(i).and. lx.ge. las1dmin(i)+rabf(i,las1dmin(i)).and.flag_sort.ne.2) then
+ k = 'sg1'
+
+ if(zeig%coh%ntreem.ne.0.) then
+ standt = 'ab'
+ call out_tim(count,i,k,llazmin+zug,lx,lxz, zeig%coh%ntreem,&
+ standt,h,hbo,db,dcrb_org,calcvol)
+ end if
+ if(zeig%coh%ntreea.ne.0.) then
+ standt = 'vb'
+ call out_tim(count,i,k,llazmin+zug,lx,lxz, zeig%coh%ntreea,&
+ standt,h,hbo,db,dcrb_org,calcvol)
+ end if
+ if(zeig%coh%ntreed.ne.0..and.flag_mg.ne.0.and.zeig%coh%diam.gt.tardiam_dstem) then
+ if(thin_flag1(1).ge.0) then
+ flag_deadsort = 1
+ standt = 'tb'
+ call out_tim(count,i,k,llazmin+zug,lx,lxz,zeig%coh%ntreed, standt,h,hbo,db,dcrb_org,calcvol)
+ end if
+ end if
+
+ suml = suml + llazmin+zug
+ sumvol = sumvol +calcvol
+ calcvol =0.
+ count = count + 1
+ h = h - llazmin-zug
+ if(h.lt.0.) h = 0.
+ db = lxz
+
+
+! if flag_sort = 3 only lasfixl1 is used
+ else if (llazmin.ge.lasfixl2(i).and.llazmin.lt.lasfixl1(i).and. lx.ge. las1dmin(i)+rabf(i,las1dmin(i)).and.flag_sort.ne.3) then
+ k = 'sg2'
+
+ if(zeig%coh%ntreem.ne.0.) then
+ standt = 'ab'
+ call out_tim(count,i,k,llazmin + zug,lx, lxz,zeig%coh%ntreem,standt,h,hbo,db,dcrb_org,calcvol)
+ end if
+ if(zeig%coh%ntreea.ne.0.) then
+ standt = 'vb'
+ call out_tim(count,i,k,llazmin + zug,lx, lxz,zeig%coh%ntreea,standt,h,hbo,db,dcrb_org,calcvol)
+ end if
+ if(zeig%coh%ntreed.ne.0..and.flag_mg.ne.0.and.zeig%coh%diam.gt.tardiam_dstem) then
+ if(thin_flag1(1).ge.0) then
+ flag_deadsort = 1
+ standt = 'tb'
+ call out_tim(count,i,k,llazmin+zug,lx,lxz,zeig%coh%ntreed, standt,h,hbo,db,dcrb_org,calcvol)
+ end if
+ end if
+
+ suml = suml + llazmin+zug
+ sumvol = sumvol + calcvol
+ calcvol = 0.
+ count = count + 1
+ h = h - llazmin-zug
+ if(h.lt.0.) h = 0.
+ db = lxz
+
+
+ else
+ if (dcrb.eq.0) then
+ llasdmin = (h_org-suml)- (h_org-stoh(i))*(las1dmin(i)+rabf(i,las1dmin(i)))/db
+ else if (dcrb .gt. las1dmin(i)+rabf(i,las1dmin(i))) then
+ llasdmin = (h_org-suml)-(h_org-hbo)*(las1dmin(i)+rabf(i,las1dmin(i)))/dcrb
+ else if (dcrb.le.las1dmin(i)+rabf(i,las1dmin(i))) then
+ llasdmin = (hbo-suml)-hbo*(las1dmin(i)+rabf(i,las1dmin(i))-dcrb)/(db_org-dcrb)
+ end if
+ if(2*llasdmin.ge.lasfixl1(i)) then
+ llasdmin = lasfixl1(i)/2.
+ else if(2*llasdmin.ge.lasfixl2(i)) then
+ llasdmin = lasfixl2(i)/2.
+ end if
+
+!calculation lx diameter at 2*llasdmin
+ if (dcrb .eq.0.) then
+ lx = db*(h_org-suml-llasdmin*2)/(h_org-stoh(i))
+ else if ((suml+2*llasdmin).lt. hbo) then
+
+ lx = dcrb + (db_org-dcrb)*(hbo-(suml+2*llasdmin))/hbo
+ else
+ lx = dcrb*(h_org- suml-2*llasdmin)/(h_org-hbo)
+ end if
+
+
+ ! if flag_sort = 2 only lasfixl2 is used
+ if(2*llasdmin.ge.lasfixl1(i).and.lx.ge.las1zmin(i)+rabf(i,las1zmin(i)).and.flag_sort.ne.2) then
+ k = 'sg1'
+
+ if(zeig%coh%ntreem.ne.0.) then
+ standt = 'ab'
+ call out_tim(count,i,k,2*llasdmin + zug,las1dmin(i),lx, zeig%coh%ntreem, standt,h,hbo,db,dcrb_org,calcvol)
+ end if
+ if(zeig%coh%ntreea.ne.0.) then
+ standt = 'vb'
+ call out_tim(count,i,k,2*llasdmin + zug,las1dmin(i),lx, zeig%coh%ntreea, standt,h,hbo,db,dcrb_org,calcvol)
+ end if
+ if(zeig%coh%ntreed.ne.0..and.flag_mg.ne.0.and.zeig%coh%diam.gt.tardiam_dstem) then
+ if(thin_flag1(1).ge.0) then
+ flag_deadsort = 1
+ standt = 'tb'
+ call out_tim(count,i,k,2*llasdmin + zug,las1dmin(i),lx,zeig%coh%ntreed, standt,h,hbo,db,dcrb_org,calcvol)
+ end if
+ end if
+
+ count = count + 1
+ suml = suml + 2*llasdmin + zug
+ sumvol = sumvol + calcvol
+ calcvol = 0.
+ h = h - 2*llasdmin-zug
+ if(h.lt.0.) h = 0.
+ db = lx
+
+
+! if flag_sort = 3 only lasfixl1 is used
+ else if (2*llasdmin.ge.lasfixl2(i).and.2*llasdmin.lt.lasfixl2(i) .and.lx.ge.las1zmin(i)+rabf(i,las1zmin(i)).and.flag_sort.ne.3) then
+ k = 'sg2'
+
+ if(zeig%coh%ntreem.ne.0.) then
+ standt = 'ab'
+ call out_tim(count,i,k,2*llasdmin + zug,las1dmin(i),lx, zeig%coh%ntreem, standt,h,hbo,db,dcrb_org,calcvol)
+ end if
+ if(zeig%coh%ntreea.ne.0.) then
+ standt = 'vb'
+ call out_tim(count,i,k,2*llasdmin + zug,las1dmin(i),lx, zeig%coh%ntreea, standt,h,hbo,db,dcrb_org,calcvol)
+ end if
+ if(zeig%coh%ntreed.ne.0..and.flag_mg.ne.0.and.zeig%coh%diam.gt.tardiam_dstem) then
+ if(thin_flag1(1).ge.0) then
+ flag_deadsort = 1
+ standt = 'tb'
+ call out_tim(count,i,k,2*llasdmin + zug,las1dmin(i),lx,zeig%coh%ntreed, standt,h,hbo,db,dcrb_org,calcvol)
+ end if
+ end if
+ count = count + 1
+ suml = suml + 2*llasdmin + zug
+ sumvol = sumvol + calcvol
+ calcvol = 0.
+ h = h - 2*llasdmin-zug
+ if(h.lt.0.) h = 0.
+ db = lx
+ end if
+ end if
+ END IF ! db.gt. laszmin(i)
+ if(count.eq.count_old) exit
+ END DO
+! end test LAS1a for pine
+
+! begin test industrial wood
+ Do while((h.ge.isfixl1(i).or.h.ge.isfixl2(i)).and.hbo.ne.0)
+ count_old = count
+ IF(db.gt.iszmin(i)+rabf(i,iszmin(i)).and.db.gt. isdmin(i)+rabf(i,isdmin(i))) THEN
+ help = iszmin(i)+rabf(i,iszmin(i))
+
+! calculation of length at diameter iszmin(i)
+ if (dcrb .eq.0.) then
+ liszmin = h_org -suml -(h_org-stoh(i))*(iszmin(i)+rabf(i,iszmin(i)))/db
+ else if ( dcrb .gt. iszmin(i)+rabf(i,iszmin(i))) then
+ liszmin = (h_org-suml)- (h_org-hbo)*(iszmin(i)+rabf(i,iszmin(i)))/dcrb
+ else if (dcrb.le.(i)+rabf(i,iszmin(i))) then
+ liszmin = (hbo-suml) -hbo*(iszmin(i)+rabf(i,iszmin(i))-dcrb)/(db_org-dcrb)
+ end if
+ if(liszmin.ge.isfixl1(i)) then
+ liszmin = isfixl1(i)
+ else if (liszmin.ge.isfixl2(i)) then
+ liszmin = isfixl2(i)
+ end if
+
+ ! calculation of diameter lx at liszmin/2
+ if (dcrb .eq.0.) then
+ lx = db*(h_org-suml-liszmin/2)/(h_org-stoh(i))
+ else if ((suml+liszmin/2).lt. hbo) then
+
+ lx = dcrb + (db_org-dcrb)*(hbo-(suml+liszmin/2))/hbo
+ else
+ lx = dcrb*(h_org-suml- liszmin/2)/(h_org-hbo)
+ end if
+
+! calculation of diameter at liszmin
+ if (dcrb .eq.0.) then
+ lxz = db*(h_org-suml-liszmin)/(h_org-stoh(i))
+ else if ((suml+liszmin).lt. hbo) then
+
+ lxz = dcrb + (db_org-dcrb)*(hbo-(suml+liszmin))/hbo
+ else
+ lxz = dcrb*(h_org-(suml+ liszmin))/(h_org-hbo)
+ end if
+
+
+! test industrial wood Fix length 1
+ if (liszmin.ge. isfixl1(i).and. lx.ge. isdmin(i)+rabf(i,isdmin(i))) then
+ k = 'in1'
+ if(zeig%coh%ntreem.ne.0.) then
+ standt = 'ab'
+ call out_tim(count,i,k,liszmin + zug,lx, lxz,zeig%coh%ntreem, standt,h,hbo,db,dcrb_org,calcvol)
+ end if
+ if(zeig%coh%ntreea.ne.0.) then
+ standt = 'vb'
+ call out_tim(count,i,k,liszmin + zug,lx, lxz,zeig%coh%ntreea, standt,h,hbo,db,dcrb_org,calcvol)
+ end if
+ if(zeig%coh%ntreed.ne.0..and.flag_mg.ne.0.and.zeig%coh%diam.gt.tardiam_dstem) then
+ if(thin_flag1(1).ge.0) then
+ flag_deadsort = 1
+ standt = 'tb'
+ call out_tim(count,i,k,liszmin + zug,lx, lxz,zeig%coh%ntreed, standt,h,hbo,db,dcrb_org,calcvol)
+ end if
+ end if
+
+ suml = suml + liszmin + zug
+ sumvol = sumvol + calcvol
+ calcvol = 0.
+ count = count + 1
+ h = h - liszmin-zug
+ if(h.lt.0.) h = 0.
+ db = lxz
+
+ ! test industrial wood fix length 2
+ else if (liszmin.ge.isfixl2(i).and.liszmin.lt.isfixl1(i).and. lx.ge. isdmin(i)+rabf(i,isdmin(i))) then
+ k = 'in2'
+ if(zeig%coh%ntreem.ne.0.) then
+ standt = 'ab'
+ call out_tim(count,i,k,liszmin + zug,lx, lxz,zeig%coh%ntreem, standt,h,hbo,db,dcrb_org,calcvol)
+ end if
+ if(zeig%coh%ntreea.ne.0.) then
+ standt = 'vb'
+ call out_tim(count,i,k,liszmin + zug,lx, lxz,zeig%coh%ntreea, standt,h,hbo,db,dcrb_org,calcvol)
+ end if
+ if(zeig%coh%ntreed.ne.0..and.flag_mg.ne.0.and.zeig%coh%diam.gt.tardiam_dstem) then
+ if(thin_flag1(1).ge.0) then
+ flag_deadsort = 1
+ standt = 'tb'
+ call out_tim(count,i,k,liszmin + zug,lx, lxz,zeig%coh%ntreed, standt,h,hbo,db,dcrb_org,calcvol)
+ end if
+ end if
+
+ suml = suml + liszmin + zug
+ sumvol = sumvol + calcvol
+ calcvol =0.
+ count = count + 1
+ h = h - liszmin-zug
+ if(h.lt.0.) h = 0.
+ db = lxz
+
+
+ else
+
+ if (dcrb.eq.0) then
+ h1 = isdmin(i)
+ h2 = rabf(i,isdmin(i))
+ llasdmin = h_org - suml-(h_org-stoh(i))*(isdmin(i)+rabf(i,isdmin(i)))/db
+ else if (dcrb .gt. isdmin(i)+rabf(i,isdmin(i))) then
+ llasdmin = (h_org-suml)-(h_org-hbo)*(isdmin(i)+rabf(i,isdmin(i)))/dcrb
+ else if (dcrb.le.isdmin(i)+rabf(i,isdmin(i))) then
+ llasdmin = hbo-suml -hbo*(isdmin(i)+rabf(i,isdmin(i))-dcrb)/(db_org-dcrb)
+ end if
+
+ if(2*llasdmin.ge.isfixl1(i)) then
+ llasdmin = isfixl1(i)/2.
+ else if (2*llasdmin.ge.isfixl2(i)) then
+ llasdmin = isfixl2(i)/2.
+ end if
+
+!calculation lx diameter at 2*lisdmin
+ if (dcrb .eq.0.) then
+ lx = db*(h_org -suml -llasdmin*2)/(h_org -stoh(i))
+ else if (2*llasdmin.lt. hbo) then
+ lx = dcrb + (db_org-dcrb)*(hbo-suml-llasdmin)/hbo
+ else
+ lx = dcrb*(h_org- llasdmin)/(h_org-hbo)
+ end if
+
+! test isfixl1
+ if(2*lisdmin.ge.isfixl1(i).and.lx.ge.iszmin(i)+rabf(i,iszmin(i))) then
+ k = 'in1'
+ if(zeig%coh%ntreem.ne.0.) then
+ standt = 'ab'
+ call out_tim(count,i,k,2*lisdmin+zug,lx, isdmin(i), zeig%coh%ntreem, standt,h,hbo,db,dcrb_org,calcvol)
+ end if
+ if(zeig%coh%ntreea.ne.0.) then
+ standt = 'vb'
+ call out_tim(count,i,k,2*lisdmin+zug,lx, isdmin(i), zeig%coh%ntreea, standt,h,hbo,db,dcrb_org,calcvol)
+ end if
+ if(zeig%coh%ntreed.ne.0..and.flag_mg.ne.0.and.zeig%coh%diam.gt.tardiam_dstem) then
+ if(thin_flag1(1).ge.0) then
+ flag_deadsort = 1
+ standt = 'tb'
+ call out_tim(count,i,k,2*lisdmin+zug,lx, isdmin(i), zeig%coh%ntreed, standt,h,hbo,db,dcrb_org,calcvol)
+ end if
+ end if
+
+ suml = suml + 2*lisdmin+zug
+ sumvol = sumvol + calcvol
+ calcvol = 0.
+ count = count + 1
+ h = h - 2*lisdmin-zug
+ if(h.lt.0.) h = 0.
+ db = lx
+
+! test isfixl2
+ else if (2*lisdmin.ge.isfixl2(i).and.2*lisdmin.lt.isfixl2(i) .and.lx.ge.iszmin(i)+rabf(i,iszmin(i))) then
+ k = 'in2'
+ if(zeig%coh%ntreem.ne.0.) then
+ standt = 'ab'
+ call out_tim(count,i,k,2*lisdmin+zug,lx, isdmin(i),zeig%coh%ntreem, standt,h,hbo,db,dcrb_org,calcvol)
+ end if
+ if(zeig%coh%ntreea.ne.0.) then
+ standt = 'vb'
+ call out_tim(count,i,k,2*lisdmin+zug,lx, isdmin(i),zeig%coh%ntreea, standt,h,hbo,db,dcrb_org,calcvol)
+ end if
+ if(zeig%coh%ntreed.ne.0..and.flag_mg.ne.0.and.zeig%coh%diam.gt.tardiam_dstem) then
+ if(thin_flag1(1).ge.0) then
+ flag_deadsort = 1
+ standt = 'tb'
+ call out_tim(count,i,k,2*lisdmin+zug,lx, isdmin(i),zeig%coh%ntreed, standt,h,hbo,db,dcrb_org,calcvol)
+ end if
+ end if
+
+ suml = suml + 2*lisdmin+zug
+ sumvol = sumvol + calcvol
+ calcvol = 0.
+ count = count + 1
+ h = h - 2*lisdmin-zug
+ if(h.lt.0.) h = 0.
+ db = lx
+ end if
+ end if
+ END IF ! db .ge. iszmin
+ if(count.eq.count_old) exit
+ END DO
+
+! ende test industrial wood
+
+! begin fuelwood
+ if (h.ne.0.and. db .ne.0) then
+ k = 'fue'
+ lx=0.
+ if(zeig%coh%ntreem.ne.0.) then
+ standt = 'ab'
+ if (suml.eq.stoh(i)) then
+
+ ! calculation of fuel wood in the case of total use of stem for fuel wood
+ calcvol = (zeig%coh%x_sap + zeig%coh%x_hrt)/spar(i)%prhos/1000000. ! kg DW/tree ---> m³/tree
+ else
+! ! calculation of fuelwood volume from all stem segments and total volume of stem, error because stump is not considered
+ calcvol = (zeig%coh%x_sap + zeig%coh%x_hrt)/spar(i)%prhos/1000000. - sumvol ! m³/tree
+ end if
+ call out_tim(count,i,k,h,db, lx, zeig%coh%ntreem, standt,h_org,hbo,db,dcrb_org,calcvol)
+ end if
+ if(zeig%coh%ntreea.ne.0.) then
+ if(suml.eq.stoh(i)) then
+ ! calculation of fuel wood in the case of total use of stem for fuel wood
+ calcvol = (zeig%coh%x_sap + zeig%coh%x_hrt)/spar(i)%prhos/1000000. ! kg DW/tree ---> m³/tree
+ help = zeig%coh%x_sap + zeig%coh%x_hrt
+ else
+ ! calculation of fuelwood volume from all stem segments and total volume of stem, error because stump is not considered
+ calcvol = (zeig%coh%x_sap + zeig%coh%x_hrt)/spar(i)%prhos/1000000. - sumvol ! m³/tree
+ end if
+ standt = 'vb'
+ call out_tim(count,i,k,h,db, lx, zeig%coh%ntreea, standt,h_org,hbo,db,dcrb_org,calcvol)
+ end if
+ if(zeig%coh%ntreed.ne.0..and.flag_mg.ne.0.and.zeig%coh%diam.gt.tardiam_dstem) then
+ if(thin_flag1(1).ge.0) then
+ if(suml.eq.stoh(i)) then
+ ! calculation of fuel wood in the case of total use of stem for fuel wood
+ calcvol = (zeig%coh%x_sap + zeig%coh%x_hrt)/spar(i)%prhos/1000000. ! kg DW/tree ---> m³/tree
+ help = zeig%coh%x_sap + zeig%coh%x_hrt
+ else
+ ! calculation of fuelwood volume from all stem segments and total volume of stem, error because stump is not considered
+ calcvol = (zeig%coh%x_sap + zeig%coh%x_hrt)/spar(i)%prhos/1000000. - sumvol ! m³/tree
+ end if
+ flag_deadsort = 1
+ standt = 'tb'
+ call out_tim(count,i,k,h,db, lx, zeig%coh%ntreed, standt,h_org,hbo,db,dcrb_org,calcvol)
+ end if
+ end if
+ count = count + 1
+ end if
+ end if
+ zeig => zeig%next
+ end do
+ end do
+
+
+
+end subroutine timsort
+
+subroutine out_tim(cou,nr,k, len, d,zapf, anz,standt,h,hbo,db,dcrb,calcvol)
+use data_tsort
+use data_simul
+use data_par
+
+!***************** wpm ************************
+use data_wpm
+use data_stand
+use data_species
+use data_manag
+!***************** wpm ************************
+type(mansort_type) :: mansort_ini
+
+integer nr,cou
+
+real len, d, anz,zapf, volume, v1,v2,r,r1,rc,vhelp
+real (KIND = dg) :: calcvol
+character(4) k
+character(2) standt
+type(timber) ::tim_ini
+
+ tim_ini%year = time
+ tim_ini%count= cou
+ tim_ini%ttype = k
+ tim_ini%specnr = nr
+ tim_ini%length = len
+ tim_ini%dia = d
+ tim_ini%diaor = d -rabf(nr,d)
+if(tim_ini%diaor.lt.0) tim_ini%diaor=0
+!calculaiton of volume for stem segment, depending on the charcteristics (cone, 2 cones, or frustum of a cone)
+! cone: vol=1./3.(pi*h*r²)
+! frustum: vol = pi*h(r1²+r1*r2+r2²)/3
+ r = db*0.5
+ r1 = zapf*0.5
+ rc = dcrb*0.5
+ if(k.eq. 'ste') then
+ if((len + 10.).lt.hbo) then
+ volume =( pi*len*(r*r + r*r1 + r1*r1)/3.)/1000000. ! frustum
+ else
+ v1 = pi*(hbo-stoh(nr))*(r*r +r*rc + rc*rc)/3.
+ v2 = pi*(len-stoh(nr)-hbo)*(rc*rc+ rc*r1 + r1*r1)/3.
+ volume = (v1+v2)/1000000.
+ end if
+ else if (k.eq.'fue'.and.hbo.ne.0)then
+ if( db.gt.dcrb) then
+ if(len.lt.(h-hbo)) then
+ volume = ( pi * len* r*r/3 )/1000000.
+ else
+ v1 = pi* (len-h+hbo)*(r*r + r*rc + rc*rc)/3. ! frustum
+ vhelp = pi*hbo*(r*r + r*rc + rc*rc)/3.
+ v2 = pi* (h-hbo)* rc*rc/3. ! cone
+
+ volume = (v1+v2)/1000000.
+ end if
+ else
+ volume = (pi*len*r*r/3.)/1000000.
+ end if
+ else if (k.eq.'fue'.and.hbo.eq.0)then
+
+ volume = (pi*len*r*r/3.)/1000000.
+ else
+! stem timber or industrial timber
+
+ if(hbo .eq.0.) then
+ volume = (pi*len*r*r/3.)/1000000.
+ else
+ volume = ( pi*len*(r*r +r*r1 + r1*r1)/3.)/1000000.
+ end if
+ end if
+if( volume.lt.0) then
+ volume = volume
+end if
+
+ if(calcvol.eq.0.) then
+ tim_ini%vol = volume
+ calcvol = volume
+ else
+ tim_ini%vol = volume
+ end if
+ tim_ini%zapfd = zapf
+ tim_ini%zapfdor = zapf - rabf(nr,zapf)
+ if ( tim_ini%zapfdor.lt.0) tim_ini%zapfdor=0.
+ tim_ini%tnum = anz
+ tim_ini%stype = standt
+ tim_ini%hei_tree = h
+ tim_ini%hbo_tree = hbo
+ tim_ini%dcrb = dcrb
+
+ IF (.not. associated(st%first)) THEN
+ ALLOCATE (st%first)
+ st%first%tim = tim_ini
+ NULLIFY(st%first%next)
+ anz_list = 1
+ ELSE
+ ALLOCATE(ztim)
+ ztim%tim = tim_ini
+ ztim%next => st%first
+ st%first => ztim
+ anz_list = anz_list +1
+ END IF
+
+!***************** wpm ************************
+ ! information needed for wpm
+if ( flag_wpm > 0 .and. (tim_ini%stype .eq. 'ab'.or.tim_ini%stype .eq. 'tb')) then
+ if (flag_manreal.eq.1.and.maninf.ne.'tending'.and.maninf.ne.'brushing') then
+ mansort_ini%year = tim_ini%year
+ mansort_ini%count = tim_ini%count
+ mansort_ini%spec = tim_ini%specnr
+ mansort_ini%typus = tim_ini%ttype
+ mansort_ini%diam = tim_ini%dia
+ mansort_ini%diam_wob = tim_ini%diaor
+ mansort_ini%volume = (tim_ini%vol/kpatchsize)*10000. ! m³/patchsize ---> m3/ha
+ mansort_ini%dw = (tim_ini%vol/kpatchsize)*10000*spar(tim_ini%specnr)%prhos*1000000.*cpart ! m³/patchsize ---> kg C/ha
+ mansort_ini%number = tim_ini%tnum
+
+ if (.not. associated(first_mansort)) then
+ allocate (first_mansort)
+ first_mansort%mansort = mansort_ini
+ nullify(first_mansort%next)
+ else
+ ! build new mansort object
+ allocate(act_mansort)
+ act_mansort%mansort = mansort_ini
+ ! chain into the list
+ act_mansort%next => first_mansort
+ ! set the first pointer to the new object
+ first_mansort => act_mansort
+ end if
+ end if
+end if
+
+ ! information needed for sea or wpm+sea
+if ( (flag_wpm == 2 .or. flag_wpm == 3) .and. tim_ini%stype .eq. 'vb') then
+ mansort_ini%year = tim_ini%year
+ mansort_ini%count = tim_ini%count
+ mansort_ini%spec = tim_ini%specnr
+ mansort_ini%typus = tim_ini%ttype
+ mansort_ini%diam = tim_ini%dia
+ mansort_ini%diam_wob = tim_ini%diaor
+ mansort_ini%volume = (tim_ini%vol/kpatchsize)*10000. ! m³/patchsize ---> m3/ha
+ mansort_ini%dw = (tim_ini%vol/kpatchsize)*10000*spar(tim_ini%specnr)%prhos*1000000.*cpart ! m³/patchsize ---> kg C/ha
+ mansort_ini%number = tim_ini%tnum
+
+ if (.not. associated(first_standsort)) then
+ allocate (first_standsort)
+ first_standsort%mansort = mansort_ini
+ nullify(first_standsort%next)
+ else
+ ! build new mansort object
+ allocate(act_standsort)
+ act_standsort%mansort = mansort_ini
+ ! chain into the list
+ act_standsort%next => first_standsort
+ ! set the first pointer to the new object
+ first_standsort => act_standsort
+ end if
+end if
+
+!***************** wpm ************************
+
+
+end subroutine out_tim
+
+subroutine out_timlist
+use data_tsort
+use data_simul
+integer timunit
+
+timunit = getunit()
+
+open (timunit,file = 'timlist.dat', status='unknown')
+
+write( timunit,*) ' year ','count ',' spec','type ',' length',' diameter', 'diam wo bark', 'top diam. ',' top d. wo bark','Volume(m³)',' number '
+ ztim=>st%first
+ do
+ IF (.not.ASSOCIATED(ztim)) exit
+ write(timunit,'(3I6,1x,A5,1x,F8.3,1x,f7.3,1x,f7.3,1x,f7.3,1x,f7.3,1x,f7.3,1x,f10.2)') ztim%tim%year, ztim%tim%count, &
+ ztim%tim%specnr,ztim%tim%ttype,ztim%tim%length,ztim%tim%dia,ztim%tim%diaor,ztim%tim%zapfd,ztim%tim%zapfdor, ztim%tim%vol,ztim%tim%tnum
+ ztim=>ztim%next
+ end do
+close(timunit)
+
+end subroutine out_timlist
+
+real function rabf(spec, db)
+! calculation of rabz i.A.
+use data_tsort
+use data_species
+integer iz, spec
+
+do iz = 1,nspec_tree
+
+ if(iz.eq.spec) then
+ if(db.lt.rabth(spec,1)) then
+ rabf = rabz(spec,1)
+ else if (db.ge.rabth(spec,1).and. db.lt.rabth(spec,2)) then
+ rabf = rabz(spec,2)
+ else
+ rabf = rabz(spec,3)
+ end if
+
+ end if
+
+end do
+
+end function rabf
\ No newline at end of file
diff --git a/source_code/version2.2_windows/tool.f b/source_code/version2.2_windows/tool.f
new file mode 100755
index 0000000000000000000000000000000000000000..a54b2b745e91cc67de8faf319ffb42cfa8722161
--- /dev/null
+++ b/source_code/version2.2_windows/tool.f
@@ -0,0 +1,844 @@
+!*****************************************************************!
+!* *!
+!* 4C (FORESEE) Simulation Model *!
+!* *!
+!* Subroutines for standard tasks *!
+!* *!
+!* contains: *!
+!* SOLV_QUADR solving quadratic equation, real*4 *!
+!* DSOLV_QUADR solving quadratic equation, real*8 *!
+!* NEWT Newton method *!
+!* TRICOF Harmonic Analysis *!
+!* SORT_INDEX Sorts two arrays *!
+!* SORT sort an array by quicksort method *!
+!* MOMENT Descriptive statistics of a data set *!
+!* *!
+!* 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 solv_quadr (meth, p, q, x1, x2, res1, res2, rnum)
+
+! Solution of quadratic equation in normal form
+! x*x + p*x + q = 0
+
+IMPLICIT NONE
+
+! Input
+integer meth ! solver method
+real p, q ! parameter of the quadratic equation
+
+! Output
+real x1, x2 ! solutions; initial value of Newton method
+real res1, res2 ! residua
+integer rnum ! return code
+
+real discr
+
+! Variables of Newton method
+real df ! quotient of quadratic function and its first derivative
+real :: precision = 1E-5
+integer:: maxloop, iloop
+
+! Variables of solver program ZPORC of ISML Library
+
+!external ZPLRC
+
+discr = (p*p/4.)-q
+if (discr .lt. 0.) then
+ rnum = -1 ! no real solution
+ return
+else
+ select case (meth)
+ case (1)
+ ! standard solution
+ discr = SQRT(discr)
+ x1 = -p/2. + discr
+ x2 = -p/2. - discr
+ rnum = 0
+
+ case (2)
+ ! Vieta's formulae (root theorem)
+ discr = SQRT(discr)
+ x2 = -p/2. - discr
+ x1 = q / x2
+ rnum = 0
+
+ case (3)
+ ! Newton method
+ ! initial value x2
+ maxloop = 100
+ iloop = 1
+ df = (x2*x2 + p*x2 + q) / (2.* x2 + p)
+ do while (abs(df) .gt. precision .and. iloop .le. maxloop)
+ x2 = x2 - df
+ df = (x2*x2 + p*x2 + q) / (2.* x2 + p)
+ iloop = iloop + 1
+ enddo
+ if (iloop .lt. maxloop) then
+ rnum = 0
+ else
+ rnum = 1
+ endif
+
+ end select
+endif ! discr
+
+ res1 = x1*x1 + p*x1 + q
+ res2 = x2*x2 + p*x2 + q
+
+END SUBROUTINE solv_quadr
+
+!**************************************************************
+
+SUBROUTINE dsolv_quadr (meth, p, q, x1, x2, res1, res2, rnum)
+
+! Solution of quadratic equation in normal form
+! x*x + p*x + q = 0
+! with double precision
+
+IMPLICIT NONE
+
+! Input
+integer meth ! solver method
+real (kind (0.0D0)) :: p, q ! parameter of the quadratic equation
+
+! Output
+real (kind (0.0D0)) :: x1, x2 ! solutions
+real (kind (0.0D0)) :: res1, res2 ! residua
+integer rnum ! return code
+
+real (kind (0.0D0)) :: discr
+
+! Variables of Newton method
+real (kind (0.0D0)) :: df ! quotient of quadratic function and its first derivative
+real (kind (0.0D0)) :: precision = 1E-5
+integer:: maxloop, iloop
+
+! Variables for solver program ZPORC of ISML Library
+real (kind (0.0D0)) :: coeff(3)
+real (kind (0.0D0)) :: zero(2)
+
+discr = (p*p/4.)-q
+if (discr .lt. 0.) then
+ rnum = -1 ! no real solution
+ return
+else
+ select case (meth)
+ case (1)
+ ! standard solution
+ discr = DSQRT(discr)
+ x1 = -p/2. + discr
+ x2 = -p/2. - discr
+ rnum = 0
+
+ case (2)
+ ! Vieta's formulae (root theorem)
+ discr = DSQRT(discr)
+ x2 = -p/2. - discr
+ x1 = q / x2
+ rnum = 0
+
+ case (3)
+ ! Newton method
+ ! initial value x2
+ maxloop = 100
+ iloop = 1
+ df = (x2*x2 + p*x2 + q) / (2.* x2 + p)
+ do while (abs(df) .gt. precision .and. iloop .le. maxloop)
+ x2 = x2 - df
+ df = (x2*x2 + p*x2 + q) / (2.* x2 + p)
+ iloop = iloop + 1
+ enddo
+ if (iloop .lt. maxloop) then
+ rnum = 0
+ else
+ rnum = 1
+ endif
+ end select
+endif ! discr
+
+ res1 = x1*x1 + p*x1 + q
+ res2 = x2*x2 + p*x2 + q
+
+END SUBROUTINE dsolv_quadr
+
+!**************************************************************
+
+SUBROUTINE newt (x, f, df, ddf, prec, maxit, rnum)
+
+! Newton method
+
+implicit none
+integer :: maxit ! maximum number of iteration
+real :: x ! initial value and result
+real :: prec ! precision
+real :: dx ! quotient of function and its first derivative
+real :: hf, hdf, hddf
+integer :: rnum ! options: 0 - change of sign allowed,
+ ! 1 - no change of sign
+ ! return code
+integer :: i
+real, external :: f, df, ddf ! function and its first derivative
+
+
+hf = f(x)
+hdf = df(x)
+hddf = ddf(x)
+dx = hddf * hf
+
+if (abs(dx) .lt. abs(hdf*hdf)) then ! Test of convergence
+
+ ! Iteration
+ i = 1
+ if (abs(dx) .gt. 0.) then
+ dx = hf / hdf
+ endif
+ do while (abs(hf) .gt. prec .and. i .le. maxit)
+ if (dx .gt. x .and. rnum .gt. 0) dx = x/2.
+ x = x - dx
+ hdf = df(x)
+ if (abs(hdf) .gt. 0.) then
+ hf = f(x)
+ dx = hf/hdf
+ endif
+ i = i + 1
+ enddo
+ if (i .lt. maxit) then
+ rnum = 0
+ else
+ rnum = 1 ! not enough iteration steps
+ endif
+
+else
+ rnum = -1 ! no convergence
+endif
+
+END SUBROUTINE newt
+
+!**************************************************************
+
+ SUBROUTINE TRICOF(F,NF,A,NE,B,NO,IOP)
+
+! PURPOSE = TO COMPUTE THE COEFFICIENTS IN A TRIGONOMETRIC EXPANSION
+! FOR A FUNCTION GIVEN IN EQUIDISTANT POINTS
+
+! PARAMETERS
+
+! F = AN ARRAY USED FOR STORING THE FUNCTION VALUES F(X)
+! NF = THE NUMBER OF FUNCTION VALUES IN THE ARRAY F.NF MUST
+! HAVE THE STRUCTURE , NF = 2*N+1 , THE GENERAL CASE
+! NF = N+1 , THE EVEN CASE
+! NF = N-1 , THE ODD CASE
+! A = AN ARRAY USED FOR RETURNING THE COEFFICIENTS OF THE COS-
+! INE TERMS
+! NE = THE NUMBER OF COEFFICIENTS IN THE ARRAY A , NE = N+1
+! B = AN ARRAY USED FOR RETURNING THE COEFFICIENTS OF THE SINE
+! TERMS
+! NO = THE NUMBER OF COEFFICIENTS IN THE ARRAY B , NO = N-1
+! IOP = OPTION NUMBER , IOP = 1 , THE GENERAL CASE
+! IOP = 2 , THE EVEN CASE
+! IOP = 3 , THE ODD CASE
+
+ DIMENSION F(NF) , A(NE) , B(NO)
+
+ REAL KSI0 , KSI1 , KSIK
+
+ DATA ZERO , FOURTH , HALF , ONE , TWO , PI / 0. , .25 , .5 , 1. , 2. , 3.14159265358979 /
+
+! COMPUTE THE NUMBER N (SEE EXPLANATION OF PARAMETERS)
+
+ 1000 N=0
+ IF (IOP.EQ.1) N=(NF-1)/2
+ IF (IOP.EQ.2) N=NF-1
+ IF (IOP.EQ.3) N=NF+1
+ IF (N.EQ.0) STOP
+
+! STOP IF IOP DOES NOT HAVE A CORRECT VALUE
+
+ IF (IOP.GT.1) GO TO 1030
+ IF ((2*N-NF+1).NE.0) STOP
+
+! STOP IF NF DOES NOT HAVE THE CORRECT STRUCTURE IN THE GENERAL CASE
+
+! SPLIT THE FUNCTION F(X) IN AN EVEN AND ODD PART
+
+ M=N+1
+ DO 1020 J=1,N
+ COF1=HALF*(F(M+J)+F(M-J))
+ COF2=HALF*(F(M+J)-F(M-J))
+ F(M+J)=COF2
+ F(M-J)=COF1
+ 1020 CONTINUE
+
+! REWRITE N IN POWERS OF 2 I.E. N=NBASE*2**NEXP
+
+ 1030 NBASE=N
+ NEXP =0
+ 1040 NINT =NBASE/2
+ IF ((NBASE-2*NINT).NE.0) GO TO 1050
+ NBASE=NINT
+ NEXP =NEXP+1
+ GO TO 1040
+
+! DO SOME INITIAL CALCULATIONS
+
+ 1050 REALN=NBASE
+ ARG =HALF*PI/REALN
+ KSI0 =COS(ARG)
+ ETA0 =SIN(ARG)
+
+! START CALCULATION OF COEFFICIENTS
+
+ IF (IOP.EQ.3) GO TO 1160
+
+! ********** EVEN COEFFICIENT CALCULATION **********
+
+! COMPUTE THE BASIC COEFFICIENTS A(K) , K=1(1)(NBASE+1)
+
+! START CALCULATION OF A(1)
+
+ NN =NBASE-1
+ NPOINT=1
+ NINCRE=2**NEXP
+ NLOCAL=NINCRE+1
+ BASEIN=ONE/REALN
+ A(1) =HALF*(F(1)+F(N+1))
+ IF (NN.EQ.0) GO TO 1065
+ DO 1060 J=1,NN
+ A(1) =A(1)+F(NLOCAL)
+ NLOCAL=NLOCAL+NINCRE
+ 1060 CONTINUE
+ 1065 A(1) =TWO*BASEIN*A(1)
+
+! START CALCULATION OF A(K) , K=2(1)(NBASE+1)
+
+ KSI1=KSI0
+ KSIK=KSI1
+ ETA1=ETA0
+ ETAK=ETA1
+ CONST=HALF*F(N+1)
+ DO 1090 K=1,NBASE
+ COF1=TWO*(TWO*KSIK**2-ONE)
+ A2 =ZERO
+ A1 =A2
+ A0 =CONST
+ NLOCAL=N+1-NINCRE
+ DO 1070 J=1,NBASE
+ A2=A1
+ A1=A0
+ A0=F(NLOCAL)+COF1*A1-A2
+ NLOCAL=NLOCAL-NINCRE
+ 1070 CONTINUE
+
+ 1080 A(K+1)=BASEIN*(A0-A2)
+ COF1 =KSIK
+ COF2 =ETAK
+ KSIK =KSI1*COF1-ETA1*COF2
+ ETAK =ETA1*COF1+KSI1*COF2
+ 1090 CONTINUE
+
+
+! CALCULATION OF THE BASIC EVEN COEFFICIENTS FINISHED
+
+ IF (NEXP.EQ.0) GO TO 1145
+
+! CONTINUE CALCULATION OF EVEN COEFFICIENTS
+
+ NUMCOF=NBASE
+ DO 1140 NSTEP=1,NEXP
+ NINCRE=2**(NEXP-NSTEP)
+ NPOINT=NINCRE+1
+ NINCRE=2*NINCRE
+ NLOCAL=NPOINT
+ NUMBER=2*NUMCOF+1
+
+! COMPUTE CONSTANT TERM IN MID-POINT APPROXIMATION I.E. K=1
+
+ SUM=ZERO
+ DO 1100 J=1,NUMCOF
+ SUM=SUM+F(NLOCAL)
+ NLOCAL=NLOCAL+NINCRE
+ 1100 CONTINUE
+
+ SUM =TWO*BASEIN*SUM
+ COF1=A(1)
+ A(1)=HALF*(COF1+SUM)
+ A(NUMBER)=HALF*(COF1-SUM)
+
+ IF (NUMCOF.EQ.1) GO TO 1135
+
+
+! COMPUTE MID-POINT APPROXIMATION FOR K=2(1)NUMCOF
+
+ 1105 NN =NUMCOF-1
+ KSIK=KSI1
+ ETAK=ETA1
+ DO 1130 K=1,NN
+ COF1=TWO*(TWO*KSIK**2-ONE)
+ A2=ZERO
+ A1=A2
+ NLOCAL=N+2-NPOINT
+ A0=F(NLOCAL)
+ DO 1110 J=1,NN
+ A2=A1
+ A1=A0
+ NLOCAL=NLOCAL-NINCRE
+ A0=F(NLOCAL)+COF1*A1-A2
+ 1110 CONTINUE
+
+ 1120 SUM=TWO*BASEIN*(A0-A1)*KSIK
+ COF1=A(K+1)
+ A(K+1)=HALF*(COF1+SUM)
+ A(NUMBER-K)=HALF*(COF1-SUM)
+
+ COF1=KSIK
+ COF2=ETAK
+ KSIK=KSI1*COF1-ETA1*COF2
+ ETAK=ETA1*COF1+KSI1*COF2
+
+ 1130 CONTINUE
+ 1135 A(NUMCOF+1)=HALF*A(NUMCOF+1)
+
+! CALCULATIONS OF MID-POINT APPROXIMATIONS FINISHED
+
+! DO CHANGES RELATED TO HALVING OF THE INTERVAL
+
+ ARG =HALF*ARG
+ COF1=ETA1
+ ETA1=SIN(ARG)
+ KSI1=HALF*COF1/ETA1
+ BASEIN=HALF*BASEIN
+ NUMCOF=2*NUMCOF
+
+ 1140 CONTINUE
+ 1145 IF (NEXP.EQ.0) NUMBER=NBASE+1
+ A(NUMBER)=HALF*A(NUMBER)
+
+! CALULATION OF EVEN COEFFICIENTS FINISHED
+
+ 1150 IF (IOP.EQ.2) RETURN
+
+! RETURN TO CALLING PROGRAM IF F(X) WAS AN EVEN FUNCTION
+! IF IOP=1 CHANGE SIGN OF EACH SECOND COEFFICIENTS
+
+ NINT=(N+1)/2
+ IF (NINT.EQ.0) GO TO 1166
+ DO 1164 K=1,NINT
+ A(2*K)=-A(2*K)
+ 1164 CONTINUE
+
+
+! ********** ODD COEFFICIENT CALCULATION **********
+
+! COMPUTE THE BASIC COEFFICIENTS B(K) , K=1(1)NBASE
+
+ 1166 ARG=HALF*PI/REALN
+ 1160 IF (IOP.EQ.1) NMAX=2*N+1
+ IF (IOP.EQ.3) NMAX=N
+ NINCRE=2**NEXP
+ NPOINT=NMAX-NINCRE
+ NLOCAL=NPOINT
+ BASEIN=ONE/REALN
+ B(1)=ZERO
+ IF (NBASE.EQ.1) GO TO 1200
+ KSI1=TWO*KSI0**2-ONE
+ KSIK=KSI1
+ ETA1=TWO*KSI0*ETA0
+ ETAK=ETA1
+ NN =NBASE-1
+ NNN=NN-1
+ DO 1190 K=1,NN
+ COF1=TWO*KSIK
+ A2 =ZERO
+ A1 =A2
+ A0 =F(NPOINT)
+ NLOCAL=NPOINT-NINCRE
+ IF (NNN.EQ.0) GO TO 1180
+ DO 1170 J=1,NNN
+ A2=A1
+ A1=A0
+ A0=F(NLOCAL)+COF1*A1-A2
+ NLOCAL=NLOCAL-NINCRE
+ 1170 CONTINUE
+
+ 1180 B(K)=TWO*BASEIN*A0*ETAK
+ COF1=KSIK
+ COF2=ETAK
+ KSIK=KSI1*COF1-ETA1*COF2
+ ETAK=ETA1*COF1+KSI1*COF2
+ 1190 CONTINUE
+
+! CALCULATION OF THE BASIC ODD COEFFICIENTS FINISHED
+
+ 1200 IF (NEXP.EQ.0) GO TO 1260
+
+! CONTINUE CALCULATION OF ODD COEFFICIENTS
+
+ KSI1=KSI0
+ ETA1=ETA0
+
+ NUMCOF=NBASE
+ DO 1250 NSTEP=1,NEXP
+ KSIK=KSI1
+ ETAK=ETA1
+ NINCRE=2**(NEXP-NSTEP)
+ NPOINT=NMAX-NINCRE
+ NINCRE=2*NINCRE
+ NUMBER=2*NUMCOF
+ B(NUMCOF)=ZERO
+
+! COMPUTE MID-POINT APPROXIMATIONS FOR K=1(1)NUMCOF
+
+ NN =NUMCOF-1
+ DO 1240 K=1,NUMCOF
+ COF1=TWO*(TWO*KSIK**2-ONE)
+ A2 =ZERO
+ A1 =A2
+ NLOCAL=NPOINT
+ A0 =F(NLOCAL)
+ IF (NN.EQ.0) GO TO 1220
+ DO 1210 J=1,NN
+ A2=A1
+ A1=A0
+ NLOCAL=NLOCAL-NINCRE
+ A0=F(NLOCAL)+COF1*A1-A2
+ 1210 CONTINUE
+
+ 1220 SUM=TWO*BASEIN*(A0+A1)*ETAK
+ COF1=B(K)
+ B(K)=HALF*(COF1+SUM)
+ IF (K.EQ.NUMCOF) GO TO 1230
+ B(NUMBER-K)=-HALF*(COF1-SUM)
+
+ 1230 COF1=KSIK
+ COF2=ETAK
+ KSIK=KSI1*COF1-ETA1*COF2
+ ETAK=ETA1*COF1+KSI1*COF2
+
+ 1240 CONTINUE
+
+! CALCULATION OF MID-POINT APPROXIMATION FINISHED
+
+! DO CHANGES RELATED TO HALVING OF INTERVAL
+
+ ARG =HALF*ARG
+ COF1=ETA1
+ ETA1=SIN(ARG)
+ KSI1=HALF*COF1/ETA1
+ BASEIN=HALF*BASEIN
+ NUMCOF=2*NUMCOF
+
+ 1250 CONTINUE
+
+! CALCULATION OF ODD COEFFICIENTS FINISHED
+
+ 1260 IF (IOP.EQ.3) RETURN
+
+! IF IOP=1 RECOMPUTE FUNCTION VALUES
+
+ DO 1270 J=1,N
+ COF2=F(M+J)
+ COF1=F(M-J)
+ F(M+J)=COF1+COF2
+ F(M-J)=COF1-COF2
+ 1270 CONTINUE
+
+ RETURN
+
+ END SUBROUTINE TRICOF
+
+!**************************************************************
+
+ SUBROUTINE sort_index(n,arr,brr)
+
+! variation of sort2 for integer array
+! sorts array arr(1:n) into an ascending order and
+! makes the corresponding rearrangement of the array brr(1:n)
+
+ INTEGER n,M,NSTACK
+
+ Integer arr(n)
+ INTEGER brr(n)
+
+ PARAMETER (M=7,NSTACK=50)
+
+ INTEGER i,ir,j,jstack,k,l,istack(NSTACK)
+
+ REAL a,b,temp
+
+ jstack=0
+ l=1
+ ir=n
+
+1 if(ir-l.lt.M)then
+
+ do 12 j=l+1,ir
+ a=arr(j)
+ b=brr(j)
+
+ do 11 i=j-1,1,-1
+ if(arr(i).le.a)goto 2
+ arr(i+1)=arr(i)
+ brr(i+1)=brr(i)
+
+11 continue
+
+ i=0
+2 arr(i+1)=a
+ brr(i+1)=b
+
+12 continue
+
+ if(jstack.eq.0)return
+ ir=istack(jstack)
+ l=istack(jstack-1)
+ jstack=jstack-2
+ else
+ k=(l+ir)/2
+ temp=arr(k)
+ arr(k)=arr(l+1)
+ arr(l+1)=temp
+ temp=brr(k)
+ brr(k)=brr(l+1)
+ brr(l+1)=temp
+ if(arr(l+1).gt.arr(ir))then
+ temp=arr(l+1)
+ arr(l+1)=arr(ir)
+ arr(ir)=temp
+ temp=brr(l+1)
+ brr(l+1)=brr(ir)
+ brr(ir)=temp
+ endif
+
+ if(arr(l).gt.arr(ir))then
+ temp=arr(l)
+ arr(l)=arr(ir)
+ arr(ir)=temp
+ temp=brr(l)
+ brr(l)=brr(ir)
+ brr(ir)=temp
+ endif
+
+ if(arr(l+1).gt.arr(l))then
+ temp=arr(l+1)
+ arr(l+1)=arr(l)
+ arr(l)=temp
+ temp=brr(l+1)
+ brr(l+1)=brr(l)
+ brr(l)=temp
+ endif
+
+ i=l+1
+ j=ir
+ a=arr(l)
+ b=brr(l)
+
+3 continue
+
+ i=i+1
+ if(arr(i).lt.a)goto 3
+
+4 continue
+
+ j=j-1
+ if(arr(j).gt.a)goto 4
+ if(j.lt.i)goto 5
+ temp=arr(i)
+ arr(i)=arr(j)
+ arr(j)=temp
+ temp=brr(i)
+ brr(i)=brr(j)
+ brr(j)=temp
+
+ goto 3
+
+5 arr(l)=arr(j)
+ arr(j)=a
+ brr(l)=brr(j)
+ brr(j)=b
+ jstack=jstack+2
+
+ if(jstack.gt.NSTACK)pause 'NSTACK too small in sort2'
+ if(ir-i+1.ge.j-l)then
+ istack(jstack)=ir
+ istack(jstack-1)=i
+ ir=j-1
+ else
+ istack(jstack)=j-1
+ istack(jstack-1)=l
+ l=i
+ endif
+ endif
+
+ goto 1
+
+ END
+
+! (C) Copr. 1986-92 Numerical Recipes Software "!D#+.
+
+!**************************************************************
+
+ SUBROUTINE sort(n,arr)
+
+ ! sort a n-dimensional array arr(1:n) by quicksort method
+
+ INTEGER n,M,NSTACK
+ REAL arr(n)
+ PARAMETER (M=7,NSTACK=50)
+ INTEGER i,ir,j,jstack,k,l,istack(NSTACK)
+ REAL a,temp
+ jstack=0
+ l=1
+ ir=n
+1 if(ir-l.lt.M)then
+ do 12 j=l+1,ir
+ a=arr(j)
+ do 11 i=j-1,1,-1
+ if(arr(i).le.a)goto 2
+ arr(i+1)=arr(i)
+11 continue
+ i=0
+2 arr(i+1)=a
+12 continue
+ if(jstack.eq.0)return
+ ir=istack(jstack)
+ l=istack(jstack-1)
+ jstack=jstack-2
+ else
+ k=(l+ir)/2
+ temp=arr(k)
+ arr(k)=arr(l+1)
+ arr(l+1)=temp
+ if(arr(l+1).gt.arr(ir))then
+ temp=arr(l+1)
+ arr(l+1)=arr(ir)
+ arr(ir)=temp
+ endif
+ if(arr(l).gt.arr(ir))then
+ temp=arr(l)
+ arr(l)=arr(ir)
+ arr(ir)=temp
+ endif
+ if(arr(l+1).gt.arr(l))then
+ temp=arr(l+1)
+ arr(l+1)=arr(l)
+ arr(l)=temp
+ endif
+ i=l+1
+ j=ir
+ a=arr(l)
+3 continue
+ i=i+1
+ if(arr(i).lt.a)goto 3
+4 continue
+ j=j-1
+ if(arr(j).gt.a)goto 4
+ if(j.lt.i)goto 5
+ temp=arr(i)
+ arr(i)=arr(j)
+ arr(j)=temp
+ goto 3
+5 arr(l)=arr(j)
+ arr(j)=a
+ jstack=jstack+2
+ if(jstack.gt.NSTACK)pause 'NSTACK too small in sort'
+ if(ir-i+1.ge.j-l)then
+ istack(jstack)=ir
+ istack(jstack-1)=i
+ ir=j-1
+ else
+ istack(jstack)=j-1
+ istack(jstack-1)=l
+ l=i
+ endif
+ endif
+ goto 1
+ END
+! C (C) Copr. 1986-92 Numerical Recipes Software )$!.
+
+!**************************************************************
+
+ SUBROUTINE moment(array,n,ave,adev,sdev,var,skew,curt)
+
+! Calculates statistics of array (n-dimensional array of data)
+! n - number of observations
+! adev - average deviation
+! ave - average
+! curt - curtosis
+! sdev - standard deviation
+! skew - skewness
+! var - variance
+
+ INTEGER n
+ REAL adev,ave,curt,sdev,skew,var,array(n)
+ INTEGER j
+ REAL p,s,ep
+ if(n.le.1)pause 'n must be at least 2 in moment'
+ s=0.
+ do 11 j=1,n
+ s=s+array(j)
+11 continue
+ ave=s/n
+ adev=0.
+ var=0.
+ skew=0.
+ curt=0.
+ ep=0.
+ do 12 j=1,n
+ s=array(j)-ave
+ ep=ep+s
+ adev=adev+abs(s)
+ p=s*s
+ var=var+p
+ p=p*s
+ skew=skew+p
+ p=p*s
+ curt=curt+p
+12 continue
+ adev=adev/n
+ var=(var-ep**2/n)/(n-1)
+ sdev=sqrt(var)
+ if(var.ne.0.)then
+ skew=skew/(n*sdev**3)
+ curt=curt/(n*var**2)-3.
+ else
+ skew = -99.
+ curt = -99.
+ endif
+ return
+ END
+! (C) Copr. 1986-92 Numerical Recipes Software )$!.
+
+ FUNCTION rtbis(func,x1,x2,xacc)
+ INTEGER JMAX
+ REAL rtbis,x1,x2,xacc,func
+ EXTERNAL func
+ PARAMETER (JMAX=40)
+ INTEGER j
+ REAL dx,f,fmid,xmid
+ fmid=func(x2)
+ f=func(x1)
+ if(f.lt.0.)then
+ rtbis=x1
+ dx=x2-x1
+ else
+ rtbis=x2
+ dx=x1-x2
+ endif
+ do j=1,JMAX
+ dx=dx*.5
+ xmid=rtbis+dx
+ fmid=func(xmid)
+ if(fmid.le.0.)rtbis=xmid
+ if(abs(dx).lt.xacc .or. fmid.eq.0.) return
+
+ end do
+ END function
\ No newline at end of file
diff --git a/source_code/version2.2_windows/tool1.f b/source_code/version2.2_windows/tool1.f
new file mode 100755
index 0000000000000000000000000000000000000000..92875a4cb84102249532149eb4a9f7e7642e2165
--- /dev/null
+++ b/source_code/version2.2_windows/tool1.f
@@ -0,0 +1,197 @@
+!*****************************************************************!
+!* *!
+!* 4C (FORESEE) Simulation Model *!
+!* *!
+!* *!
+!* Subroutines for standard tasks *!
+!* *!
+!* contains: *!
+!* DAINTZ Date to day of the year *!
+!* TZINDA Day of the year to date *!
+!* TAB_INT Table function *!
+!* CHARACTER_IN_INTEGER Conversion of character in integer *!
+!* INTEGER_IN_CHARACTER Conversion of integer in character *!
+!* QUANTILE calculates the 0.05 and 0.95 quantile *!
+!* QUANT_CALC calculates a quantile of a sorted array *!
+!* *!
+!* 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 DAINTZ(IT,IM,IJ,TZ)
+
+! Umrechnen von Datum in Tageszaehler
+
+ implicit none
+
+ INTEGER IT, IM, IJ, TZ
+ INTEGER I, ME
+ REAL, DIMENSION(12):: MNL
+! COMMON /MONTH/ MMM(12),JAHR,JS,IC
+ DATA MNL /31,28,31,30,31,30,31,31,30,31,30,31/
+
+ TZ=IT
+ IF (IM.EQ.1) RETURN
+ ME=IM-1
+
+ if (mod(IJ,4).EQ.0) MNL(2)=29
+ if ((IJ .eq. 1900) .or. (IJ .eq. 1800) .or. (IJ .eq. 1700)) MNL(2)=28
+ DO I=1,ME
+ TZ=TZ+MNL(I)
+ enddo
+ MNL(2)=28
+
+ END SUBROUTINE DAINTZ
+
+!***********************************************************************
+
+ SUBROUTINE TZINDA(T,M,J,TZ)
+
+! Umrechnen von Tageszaehler in Datum
+
+ implicit none
+
+ INTEGER MNL(12)
+ INTEGER T, M, J, TZ
+ DATA MNL /31,28,31,30,31,30,31,31,30,31,30,31/
+
+ if (mod(J,4).EQ.0) MNL(2)=29
+ if ((J .eq. 1900) .or. (J .eq. 1800) .or. (J .eq. 1700)) MNL(2)=28
+ T=TZ
+ M=1
+ do while (T .gt. MNL(M))
+ T=T-MNL(M)
+ M=M+1
+ if (M .gt. 12) return
+ enddo
+ MNL(2)=28
+
+ END SUBROUTINE TZINDA
+
+!***********************************************************************
+
+SUBROUTINE tab_int(x,y,idim,arg,val)
+
+! Read a table function with ordered pairs x,y (sortet)
+! linear interpolation between
+
+implicit none
+
+! input
+integer idim ! dimension of array x, y
+real, dimension(idim) :: x, y ! table values
+real arg ! argument of function
+! output
+real val ! result
+integer i
+
+if (arg .le. x(1)) then
+ val = y(1)
+else if (arg .ge. x(idim)) then
+ val = y(idim)
+else
+ i = 2
+ do while ((i .lt. idim) .and. (arg .gt. x(i)))
+ i = i+1
+ enddo
+ if (arg .eq. x(i)) then
+ val = y(i)
+ else
+ val = y(i) + (y(i)-y(i-1)) * (arg-x(i)) / (x(i)-x(i-1))
+ endif
+endif
+
+END subroutine tab_int
+
+!***********************************************************************
+
+SUBROUTINE character_in_integer(string, vint)
+
+! Conversion of character variable in integer variable
+
+implicit none
+
+integer vint
+character (100) string
+character (10) help
+
+ write(help,'(A)') string
+ read(help,*) vint
+
+END subroutine character_in_integer
+
+!**************************************************************
+
+SUBROUTINE integer_in_character(vint, string)
+
+! Conversion of integer variable in character variable
+
+implicit none
+
+integer vint
+character (10) string
+character (10) help
+
+
+ write(help,'(I10)') vint
+ read(help,*) string
+
+END subroutine integer_in_character
+
+!**************************************************************
+
+ SUBROUTINE quantile(idim, arr, quant05, quant95, median)
+
+ ! sorts and calculates the 0.05 and 0.95 quantile of an array with dimension idim
+
+ implicit none
+
+ ! input
+integer idim ! dimension of array arr
+real, dimension(idim) :: arr ! array
+! output
+real quant05, quant95, median ! 0.05 and 0.95 quantile
+
+call sort(idim,arr)
+
+call quant_calc(idim, arr, 0.05, quant05) ! 0.05 quantile
+call quant_calc(idim, arr, 0.95, quant95) ! 0.95 quantile
+call quant_calc(idim, arr, 0.5, median) ! 0.95 quantile
+
+END SUBROUTINE quantile
+
+!**************************************************************
+
+ SUBROUTINE quant_calc(idim, arr, pord, quant)
+
+ ! calculates a quantile of a sorted array with dimension idim
+
+ implicit none
+
+integer idim ! dimension of array arr
+real, dimension(idim) :: arr ! array
+real quant ! quantile
+real pord, help ! order
+integer ihelp
+
+help = idim * pord
+ihelp = int(help)
+if (ihelp*1.0 .lt. help) then
+ quant = arr(ihelp+1)
+else
+ quant = (arr(ihelp+1) + arr(ihelp)) / 2.
+endif
+
+END SUBROUTINE quant_calc
+
+!**************************************************************
+
+
diff --git a/source_code/version2.2_windows/utils_init.f b/source_code/version2.2_windows/utils_init.f
new file mode 100755
index 0000000000000000000000000000000000000000..af2e046e0c2639226bd8b4a2c2a279fbbbcf3875
--- /dev/null
+++ b/source_code/version2.2_windows/utils_init.f
@@ -0,0 +1,852 @@
+!*****************************************************************!
+!* *!
+!* 4C (FORESEE) Simulation Model *!
+!* *!
+!* *!
+!* SUBROUTINES *!
+!* - assign_DSW *!
+!* - assign_Bay *!
+!* - parthe_param *!
+!* - data_gap_fill_DSW *!
+!* - init_plenter_param *!
+!* - fdfk *!
+!* FUNCTIONS *!
+!* - tax_of_BRA_id *!
+!* - wachsfunc *!
+!* - inv_wachsfunc *!
+!* - agefunc *!
+!* - newton_plenter *!
+!* - n0ofvol *!
+!* *!
+!* 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 assign_DSW
+! Table of species numbers and names used in Datenspeicher Waldfonds (DSW)
+! data structure of species data DSW
+! this table is based on the Brandenburg version of the BRA (Betriebsregelungsanweisung)
+! in other states (Länder) the numbering can be different. Therefore the table must be checked against
+! their definitions, when new data sources are to be used
+USE data_init
+IMPLICIT NONE
+INTEGER :: i,imax
+! <400 conifers
+! >100 <200 pines and larches
+i=1
+spec_nrDSW(i)=111; spec_code(i)='GKI'; GER_name(i)='Gemeine Kiefer'; LAT_name(i)='Pinus sylvertris L.'
+spec_4c(i)=3
+i=i+1
+spec_nrDSW(i)=112; spec_code(i)='WKI'; GER_name(i)='Weymouthkiefer'; LAT_name(i)='Pinus strobus L.'
+spec_4c(i)=7
+i=i+1
+spec_nrDSW(i)=113; spec_code(i)='SKI'; GER_name(i)='Schwarzkiefer'; LAT_name(i)='Pinus nigra ARN.'
+spec_4c(i)=3
+i=i+1
+spec_nrDSW(i)=114; spec_code(i)='MKI'; GER_name(i)='Murraykiefer'; LAT_name(i)='Pinus contorta DOUGL. Ex LOUD.'
+spec_4c(i)=6
+i=i+1
+spec_nrDSW(i)=115; spec_code(i)='RKI'; GER_name(i)='Rumelische Kiefer'; LAT_name(i)='Pinus peuce GRISEB.'
+spec_4c(i)=3
+i=i+1
+spec_nrDSW(i)=116; spec_code(i)='BKI'; GER_name(i)='Bergkiefer'; LAT_name(i)='Pinus mugo TURRA'
+spec_4c(i)=6
+i=i+1
+spec_nrDSW(i)=117; spec_code(i)='ZKI'; GER_name(i)='Zirbelkiefer'; LAT_name(i)='Pinus cembra L.'
+spec_4c(i)=6
+i=i
+spec_nrDSW(i)=118; spec_code(i)='PKI'; GER_name(i)='Gelbkiefer'; LAT_name(i)='Pinus ponderosa DOUGL. Ex LAWS.'
+spec_4c(i)=7
+i=i+1
+spec_nrDSW(i)=119; spec_code(i)='KIS'; GER_name(i)='Sonst. Kiefern'
+spec_4c(i)=3
+i=i+1
+spec_nrDSW(i)=171; spec_code(i)='ELA'; GER_name(i)='Europ. Lärche'; LAT_name(i)='Larix decidua MILL.'
+spec_4c(i)=6
+i=i+1
+spec_nrDSW(i)=172; spec_code(i)='JLA'; GER_name(i)='Japan. Lärche'; LAT_name(i)='Larix kaempferi (LAMB.) CARR.'
+spec_4c(i)=6
+i=i+1
+spec_nrDSW(i)=173; spec_code(i)='HLA'; GER_name(i)='Hybridlärche'; LAT_name(i)='Larix x eurolepis HENRY'
+spec_4c(i)=6
+i=i+1
+spec_nrDSW(i)=179; spec_code(i)='LAS'; GER_name(i)='Sonst. Lärchen'
+spec_4c(i)=6
+! >2oo <300 spruces
+i=i+1
+spec_nrDSW(i)=211; spec_code(i)='GFI'; GER_name(i)='Gemeine Fichte'; LAT_name(i)='Picea abies (L.) KARST.'
+spec_4c(i)=2
+i=i+1
+spec_nrDSW(i)=212; spec_code(i)='SFI'; GER_name(i)='Sitkafichte'; LAT_name(i)='Picea sitchensis (BONG.) CARR.'
+spec_4c(i)=2
+i=i+1
+spec_nrDSW(i)=213; spec_code(i)='WFI'; GER_name(i)='Weißfichte'; LAT_name(i)='Picea glauca (MOENCH) VOSS'
+spec_4c(i)=2
+i=i+1
+spec_nrDSW(i)=214; spec_code(i)='OFI'; GER_name(i)='Omorikafichte'; LAT_name(i)='Picea omorika (PANC.) PURK.'
+spec_4c(i)=2
+i=i+1
+spec_nrDSW(i)=215; spec_code(i)='BFI'; GER_name(i)='Stechfichte, Blaufichte'; LAT_name(i)='Picea pungens ENGELM. + P.p. Glauca'
+spec_4c(i)=2
+i=i+1
+spec_nrDSW(i)=216; spec_code(i)='EFI'; GER_name(i)='Engelmannfichte'; LAT_name(i)='Picea engelmannii ENGELM.'
+spec_4c(i)=2
+i=i+1
+spec_nrDSW(i)=217; spec_code(i)='MFI'; GER_name(i)='Schwarzfichte'; LAT_name(i)='Picea mariana (MILL.) B. S. P.'
+spec_4c(i)=2
+i=i+1
+spec_nrDSW(i)=218; spec_code(i)='RFI'; GER_name(i)='Rotfichte'; LAT_name(i)='Picea rubens SARG.'
+spec_4c(i)=2
+i=i+1
+spec_nrDSW(i)=219; spec_code(i)='FIS'; GER_name(i)='Sonst. Fichten'
+spec_4c(i)=2
+! >300 <400 firs, douglas fir, thuja, hemlock fir
+i=i+1
+spec_nrDSW(i)=311; spec_code(i)='WTA'; GER_name(i)='Weißtanne'; LAT_name(i)='Abies alba MILL.'
+spec_4c(i)=2
+i=i+1
+spec_nrDSW(i)=312; spec_code(i)='KTA'; GER_name(i)='Küstentanne'; LAT_name(i)='Abies grandis (D. DON) LINDL.'
+spec_4c(i)=2
+i=i+1
+spec_nrDSW(i)=313; spec_code(i)='CTA'; GER_name(i)='Coleradotanne'; LAT_name(i)='Abies concolor (GORD. et GLEND.) LINDL.'
+spec_4c(i)=2
+i=i+1
+spec_nrDSW(i)=314; spec_code(i)='NTA'; GER_name(i)='Nordmanntanne'; LAT_name(i)='Abies nordmanniana (STEV.) SPACH.'
+spec_4c(i)=2
+i=i+1
+spec_nrDSW(i)=315; spec_code(i)='ETA'; GER_name(i)='Amerikanische Edeltanne'; LAT_name(i)='Abies procera REHD.'
+spec_4c(i)=2
+i=i+1
+spec_nrDSW(i)=316; spec_code(i)='HTA'; GER_name(i)='Nikkotanne'; LAT_name(i)='Abies homolepis SIEB. et ZUCC.'
+spec_4c(i)=2
+i=i+1
+spec_nrDSW(i)=317; spec_code(i)='VTA'; GER_name(i)='Veitchtanne'; LAT_name(i)='Abies veitchii LINDL.'
+spec_4c(i)=2
+i=i+1
+spec_nrDSW(i)=319; spec_code(i)='TAS'; GER_name(i)='Sonst. Tannen'
+spec_4c(i)=2
+i=i+1
+spec_nrDSW(i)=321; spec_code(i)='GDG'; GER_name(i)='Grüne Douglasie'; LAT_name(i)='Pseudotsuga menziesii (MIRBEL) FRANCO var. menziesii'
+spec_4c(i)=10
+i=i+1
+spec_nrDSW(i)=322; spec_code(i)='BDG'; GER_name(i)='Blaue Douglasie'; LAT_name(i)='Pseudotsuga menziesii var. glauca (BEISSN.) FRANCO'
+spec_4c(i)=10
+i=i+1
+spec_nrDSW(i)=323; spec_code(i)='CDG'; GER_name(i)='Graue Douglasie'; LAT_name(i)='Pseudotsuga menziesii var. caesia (SCHWERIN) FRANCO'
+spec_4c(i)=10
+i=i+1
+spec_nrDSW(i)=329; spec_code(i)='DGS'; GER_name(i)='Sonst. Douglasien'
+spec_4c(i)=10
+i=i+1
+spec_nrDSW(i)=331; spec_code(i)='RLB'; GER_name(i)='Riesenlebensbaum'; LAT_name(i)='Thuja plicata DONN ex D. DON'
+spec_4c(i)=2
+i=i+1
+spec_nrDSW(i)=332; spec_code(i)='MLB'; GER_name(i)='Morgenländischer Lebensbaum'; LAT_name(i)='Thuja orientalis L.'
+spec_4c(i)=2
+i=i+1
+spec_nrDSW(i)=333; spec_code(i)='ALB'; GER_name(i)='Abendländischer Lebensbaum'; LAT_name(i)='Thuja occidentalis L.'
+spec_4c(i)=2
+i=i+1
+spec_nrDSW(i)=339; spec_code(i)='LBS'; GER_name(i)='Sonst. Lebensb.'
+spec_4c(i)=2
+i=i+1
+spec_nrDSW(i)=341; spec_code(i)='LLZ'; GER_name(i)='Lawson-Scheinzypresse'; LAT_name(i)='Chamaecyparis lawsoniana (A. MURR.) PARL.'
+spec_4c(i)=2
+i=i+1
+spec_nrDSW(i)=349; spec_code(i)='LZS'; GER_name(i)='Sonstige Scheinzypressen'
+spec_4c(i)=2
+i=i+1
+spec_nrDSW(i)=351; spec_code(i)='KHT'; GER_name(i)='Kanadische Hemlockstanne'; LAT_name(i)='Tsuga canadensis (L.) CARR.'
+spec_4c(i)=2
+i=i+1
+spec_nrDSW(i)=352; spec_code(i)='WHT'; GER_name(i)='Westamerikanische Hemlockstanne'; LAT_name(i)='Tsuga heterophylla (RAF.) SARG.'
+spec_4c(i)=2
+i=i+1
+spec_nrDSW(i)=359; spec_code(i)='HTS'; GER_name(i)='Hemlockstannen'
+spec_4c(i)=2
+i=i+1
+spec_nrDSW(i)=361; spec_code(i)='EIB'; GER_name(i)='(Beeren-) Eibe'; LAT_name(i)='Taxus baccata L.'
+spec_4c(i)=2
+i=i+1
+spec_nrDSW(i)=371; spec_code(i)='GWA'; GER_name(i)='Gemeiner Wachholder'; LAT_name(i)='Juniperus communis L.'
+spec_4c(i)=0
+i=i+1
+spec_nrDSW(i)=379; spec_code(i)='WAS'; GER_name(i)='Sonstige Wacholder'; LAT_name(i)='Juniperus spec.'
+spec_4c(i)=0
+i=i+1
+spec_nrDSW(i)=381; spec_code(i)='MA '; GER_name(i)='Mammutbäume'; LAT_name(i)='Metasequoia spec., Sequia spec.'
+spec_4c(i)=10
+i=i+1
+spec_nrDSW(i)=399; spec_code(i)='NDS'; GER_name(i)='Sonstige Nadelbaumarten'
+spec_4c(i)=2
+! >400 broad leaved trees
+! >400 <500 oaks
+i=i+1
+spec_nrDSW(i)=410; spec_code(i)='EI '; GER_name(i)='Eichen-Bastarde (SEI-/TEI-Bastarde)'
+spec_4c(i)=4
+i=i+1
+spec_nrDSW(i)=411; spec_code(i)='SEI'; GER_name(i)='Stieleiche'; LAT_name(i)='Quercus robur L.'
+spec_4c(i)=4
+i=i+1
+spec_nrDSW(i)=412; spec_code(i)='TEI'; GER_name(i)='Traubeneiche'; LAT_name(i)='Quercus petraea (MAT.) LIEBL.'
+spec_4c(i)=4
+i=i+1
+spec_nrDSW(i)=413; spec_code(i)='ZEI'; GER_name(i)='Zerreiche Quercus cerris L.'
+spec_4c(i)=4
+i=i+1
+spec_nrDSW(i)=414; spec_code(i)='PEI'; GER_name(i)='Sumpfeiche'; LAT_name(i)='Quercus palustris MUENCHH.'
+spec_4c(i)=4
+i=i+1
+spec_nrDSW(i)=415; spec_code(i)='REI'; GER_name(i)='Roteiche'; LAT_name(i)='Quercus rubra L.'
+spec_4c(i)=4
+i=i+1
+spec_nrDSW(i)=419; spec_code(i)='EIS'; GER_name(i)='Sonst. Eichen'
+spec_4c(i)=4
+! >500 <600 Buchen, beeches
+i=i+1
+spec_nrDSW(i)=511; spec_code(i)='RBU'; GER_name(i)='Rotbuche'; LAT_name(i)='Fagus sylvatica L.'
+spec_4c(i)=1
+i=i+1
+spec_nrDSW(i)=519; spec_code(i)='BUS'; GER_name(i)='Sonst. Buchen'
+spec_4c(i)=1
+i=i+1
+! >600 <700 Hard wood specieces, except oaks and beeches
+spec_nrDSW(i)=611; spec_code(i)='HBU'; GER_name(i)='Hainbuche'; LAT_name(i)='Carpinus betulus L.'
+spec_4c(i)=1
+i=i+1
+spec_nrDSW(i)=621; spec_code(i)='GES'; GER_name(i)='Gemeine Esche'; LAT_name(i)='Fraxinus excelsior L.'
+spec_4c(i)=4
+i=i+1
+spec_nrDSW(i)=622; spec_code(i)='WES'; GER_name(i)='Weißesche'; LAT_name(i)='Fraxinus americana L.'
+spec_4c(i)=4
+i=i+1
+spec_nrDSW(i)=629; spec_code(i)='ESS'; GER_name(i)='Sonstige Eschen'
+spec_4c(i)=4
+i=i+1
+spec_nrDSW(i)=631; spec_code(i)='BAH'; GER_name(i)='Bergahorn'; LAT_name(i)='Acer pseudoplatanus L.'
+spec_4c(i)=1
+i=i+1
+spec_nrDSW(i)=632; spec_code(i)='SAH'; GER_name(i)='Spitzahorn'; LAT_name(i)='Acer platanoides L.'
+spec_4c(i)=1
+i=i+1
+spec_nrDSW(i)=633; spec_code(i)='FAH'; GER_name(i)='Feldahorn'; LAT_name(i)='Acer campestre L.'
+spec_4c(i)=1
+i=i+1
+spec_nrDSW(i)=634; spec_code(i)='IAH'; GER_name(i)='Silberahorn'; LAT_name(i)='Acer saccharinum L.'
+spec_4c(i)=1
+i=i+1
+spec_nrDSW(i)=635; spec_code(i)='EAH'; GER_name(i)='Eschenblättriger Ahorn'; LAT_name(i)='Acer negundo L.'
+spec_4c(i)=1
+i=i+1
+spec_nrDSW(i)=639; spec_code(i)='AHS'; GER_name(i)='Sonst. Ahornarten'
+spec_4c(i)=1
+i=i+1
+spec_nrDSW(i)=641; spec_code(i)='BRU'; GER_name(i)='Bergrüster,Bergulme'; LAT_name(i)='Ulmus glabra HUDS.'
+spec_4c(i)=4
+i=i+1
+spec_nrDSW(i)=642; spec_code(i)='WRU'; GER_name(i)='Weißrüster, Flatterulme'; LAT_name(i)='Ulmus laevis PALL.'
+spec_4c(i)=4
+i=i+1
+spec_nrDSW(i)=643; spec_code(i)='FRU'; GER_name(i)='Feldrüster, Feldulme'; LAT_name(i)=''; LAT_name(i)='Ulmus minor MILL.'
+spec_4c(i)=4
+i=i+1
+spec_nrDSW(i)=644; spec_code(i)='HRU'; GER_name(i)='Hölländische Rüster, Bastardulme'; LAT_name(i)='Ulmus x hollandica MILL.'
+spec_4c(i)=4
+i=i+1
+spec_nrDSW(i)=649; spec_code(i)='RUS'; GER_name(i)='(UL) Sonstige Rüstern, (Heimische) Rüstern - Ulmen'
+spec_4c(i)=4
+i=i+1
+spec_nrDSW(i)=651; spec_code(i)='RO '; GER_name(i)='Gem. Robinie'; LAT_name(i)='Robinia pseudoacacia L.'
+spec_4c(i)=11
+i=i+1
+spec_nrDSW(i)=654; spec_code(i)='GLE'; GER_name(i)='Amerikanische Gleditschie'; LAT_name(i)='Gleditsia triacanthos L.'
+spec_4c(i)=4
+i=i+1
+spec_nrDSW(i)=661; spec_code(i)='EK '; GER_name(i)='Edelkastanie'; LAT_name(i)='Castanea sativa MILL.'
+spec_4c(i)=4
+i=i+1
+spec_nrDSW(i)=662; spec_code(i)='NB '; GER_name(i)='Nußbaumarten'; LAT_name(i)='Juglans spec.'
+spec_4c(i)=4
+i=i+1
+spec_nrDSW(i)=665; spec_code(i)='HI '; GER_name(i)='Hickory-Arten'; LAT_name(i)='Carya spec.'
+spec_4c(i)=4
+i=i+1
+spec_nrDSW(i)=667; spec_code(i)='EHA'; GER_name(i)='Europäische Hasel'; LAT_name(i)='Corylus avellana L.'
+spec_4c(i)=0
+i=i+1
+spec_nrDSW(i)=668; spec_code(i)='BHA'; GER_name(i)='Baumhasel'; LAT_name(i)='Corylus colurna L.'
+spec_4c(i)=0
+i=i+1
+spec_nrDSW(i)=671; spec_code(i)='VKB'; GER_name(i)='Vogelkirsche (-baum)'; LAT_name(i)='Cerasus avium (L.) MOENCH ssp. Avium (Prunus avium L.)'
+spec_4c(i)=4
+i=i+1
+spec_nrDSW(i)=672; spec_code(i)='GTK'; GER_name(i)='Gewöhnliche Traubenkirsche'; LAT_name(i)='Padus avium MILL. (Prunus padus L.)'
+spec_4c(i)=0
+i=i+1
+spec_nrDSW(i)=673; spec_code(i)='STK'; GER_name(i)='Spätbl. Traubenk.'; LAT_name(i)='Padus serotina (EHRH.) BORKH. (Prunus serotina EHRH.)'
+spec_4c(i)=0
+i=i+1
+spec_nrDSW(i)=675; spec_code(i)='AB '; GER_name(i)='Wildapfel (-baum)'; LAT_name(i)='Malus sylvestris MILL.'
+spec_4c(i)=0
+i=i+1
+spec_nrDSW(i)=676; spec_code(i)='BB '; GER_name(i)='Wildbirne (-baum)'; LAT_name(i)='Pyrus spec.'
+spec_4c(i)=0
+i=i+1
+spec_nrDSW(i)=679; spec_code(i)='KBS'; GER_name(i)='Sonstige Obstbäume'; LAT_name(i)='Prunus spec.'
+spec_4c(i)=0
+i=i+1
+spec_nrDSW(i)=681; spec_code(i)='PLT'; GER_name(i)='Platanen'; LAT_name(i)='Platanus spec.'
+spec_4c(i)=1
+i=i+1
+spec_nrDSW(i)=699; spec_code(i)='HLS'; GER_name(i)='Sonst. Hartlaubbaumarten'
+spec_4c(i)=4
+! >700 <800 soft (deciduous) wood species
+i=i+1
+spec_nrDSW(i)=711; spec_code(i)='GBI'; GER_name(i)='Gemeine Birke, Sandbirke'; LAT_name(i)='Betula pendula ROTH.'
+spec_4c(i)=5
+i=i+1
+spec_nrDSW(i)=712; spec_code(i)='MBI'; GER_name(i)='Moorbirke'; LAT_name(i)='Betula pubescens EHRH.'
+spec_4c(i)=5
+i=i+1
+spec_nrDSW(i)=719; spec_code(i)='BIS'; GER_name(i)='Sonst. Birken'
+spec_4c(i)=5
+i=i+1
+spec_nrDSW(i)=721; spec_code(i)='RER'; GER_name(i)='Roterle, Schwarzerle'; LAT_name(i)='Alnus glutinosa (L.) GAERTN.'
+spec_4c(i)=5
+i=i+1
+spec_nrDSW(i)=722; spec_code(i)='WER'; GER_name(i)='Weißerle, Grauerle'; LAT_name(i)='Alnus incana (L.) MOENCH'
+spec_4c(i)=5
+i=i+1
+spec_nrDSW(i)=723; spec_code(i)='GER'; GER_name(i)='Grünerle'; LAT_name(i)='Alnus viridis (CHAIX) DC.'
+spec_4c(i)=5
+i=i+1
+spec_nrDSW(i)=731; spec_code(i)='WLI'; GER_name(i)='Winterlinde'; LAT_name(i)='Tilia cordata MILL.'
+spec_4c(i)=1
+i=i+1
+spec_nrDSW(i)=732; spec_code(i)='SLI'; GER_name(i)='Sommerlinde'; LAT_name(i)='Tilia platyphyllos SCOP.'
+spec_4c(i)=1
+i=i+1
+spec_nrDSW(i)=739; spec_code(i)='LIS'; GER_name(i)='Sonstige Linden'
+spec_4c(i)=1
+i=i+1
+spec_nrDSW(i)=741; spec_code(i)='SPA'; GER_name(i)='Europäische Schwarzpappel'; LAT_name(i)='Populus nigra L.'
+spec_4c(i)=8
+i=i+1
+spec_nrDSW(i)=742; spec_code(i)='HPA'; GER_name(i)='Schwarzpappel-Hybriden'; LAT_name(i)='Populus canadensis MOENCH.'
+spec_4c(i)=8
+i=i+1
+spec_nrDSW(i)=743; spec_code(i)='TPA'; GER_name(i)='Trichocarpa-Pappel'; LAT_name(i)='Populus trichocarpa TORR. et A. GRAY ex HOOK'
+spec_4c(i)=8
+i=i+1
+spec_nrDSW(i)=744; spec_code(i)='BPA'; GER_name(i)='Balsampappel-Hybriden'; LAT_name(i)='Populus trichocarpa x maximoviczii HENRY (Androscoggin)'
+spec_4c(i)=8
+i=i+1
+spec_nrDSW(i)=745; spec_code(i)='GPA'; GER_name(i)='Graupappel + Hybriden'; LAT_name(i)='Populus x canescens SMITH + P. can. X grandidentata MICHX.'
+spec_4c(i)=8
+i=i+1
+spec_nrDSW(i)=746; spec_code(i)='WPA'; GER_name(i)='Silberpappel (Weißpappel)'; LAT_name(i)='Populus Populus alba L.'
+spec_4c(i)=8
+i=i+1
+spec_nrDSW(i)=747; spec_code(i)='AS '; GER_name(i)='Aspe'; LAT_name(i)='Populus tremula L.'
+spec_4c(i)=8
+i=i+1
+spec_nrDSW(i)=748; spec_code(i)='HAS'; GER_name(i)='Aspen-Hybriden'; LAT_name(i)='Populus tremula l. x Populus tremuloides'
+spec_4c(i)=8
+i=i+1
+spec_nrDSW(i)=749; spec_code(i)='PAS'; GER_name(i)='Sonst. Pappeln (z.B. Balsam-Schwarzpappel-Hybriden)'
+spec_4c(i)=8
+i=i+1
+spec_nrDSW(i)=751; spec_code(i)='WWE'; GER_name(i)='Weißweide (Silberweide)'; LAT_name(i)='Salix alba L.'
+spec_4c(i)=5
+i=i+1
+spec_nrDSW(i)=752; spec_code(i)='BWE'; GER_name(i)='Bruchweide (Knackweide)'; LAT_name(i)='Salix fragilis L.'
+spec_4c(i)=5
+i=i+1
+spec_nrDSW(i)=753; spec_code(i)='FWE'; GER_name(i)='Fahlweide (Baumweiden-Hybriden)'; LAT_name(i)='Salix x rubens SCHRANK (= Salix alba x fragilis)'
+spec_4c(i)=5
+i=i+1
+spec_nrDSW(i)=754; spec_code(i)='SWE'; GER_name(i)='Salweide'; LAT_name(i)='Salix caprea L.'
+spec_4c(i)=5
+i=i+1
+spec_nrDSW(i)=759; spec_code(i)='WEB'; GER_name(i)='Baumweiden'
+spec_4c(i)=5
+i=i+1
+spec_nrDSW(i)=761; spec_code(i)='RK '; GER_name(i)='Roßkastanie'; LAT_name(i)='Aesculus hippocastanum L.'
+spec_4c(i)=1
+i=i+1
+spec_nrDSW(i)=771; spec_code(i)='EB '; GER_name(i)='Gemeine Eberesche'; LAT_name(i)='Sorbus aucuparia L.'
+spec_4c(i)=4
+i=i+1
+spec_nrDSW(i)=772; spec_code(i)='EEB'; GER_name(i)='Edel-Eberesche'; LAT_name(i)='Sorbus a. var. Edulis DIECK'
+spec_4c(i)=4
+i=i+1
+spec_nrDSW(i)=773; spec_code(i)='ME '; GER_name(i)='Echte Mehlbeere'; LAT_name(i)='Sorbus aria CRANTZ'
+spec_4c(i)=4
+i=i+1
+spec_nrDSW(i)=774; spec_code(i)='EL '; GER_name(i)='Elsbeere'; LAT_name(i)='Sorbus torminalis CRANTZ'
+spec_4c(i)=4
+i=i+1
+spec_nrDSW(i)=775; spec_code(i)='SG '; GER_name(i)='Speierling'; LAT_name(i)='Sorbus domestica L.'
+spec_4c(i)=4
+i=i+1
+spec_nrDSW(i)=779; spec_code(i)='MES'; GER_name(i)='Sonst. Mehlbeeren'; LAT_name(i)='Sorbus spec.'
+spec_4c(i)=4
+i=i+1
+spec_nrDSW(i)=781; spec_code(i)='GO '; GER_name(i)='Gemeiner Götterbaum'; LAT_name(i)='Ailanthus altissima (MILL.) SWINGLE'
+spec_4c(i)=0
+i=i+1
+spec_nrDSW(i)=786; spec_code(i)='MB '; GER_name(i)='Maulbeeren'; LAT_name(i)='Morus spec.'
+spec_4c(i)=0
+i=i+1
+spec_nrDSW(i)=799; spec_code(i)='WLS'; GER_name(i)='Sonstige Weichlaubbaumarten'
+spec_4c(i)=5
+imax=i
+spnum_for_DSW=0
+DO i=1,imax
+ spnum_for_DSW(spec_nrDSW(i))=i
+ENDDO
+END ! subroutine assign_DSW
+
+! Baumartenkodierung fuer Bayern 2003
+!
+! BA-ID BA_Gruppe BA_Typ Kurzname Name Ertragstafel-ID X1 X2
+! 10 1 1 Fi Fichte 10 1 0.81
+! 11 1 1 OFi Omorikafichte 10 1 0.81
+! 12 1 1 SFi Sitkafichte 10 1 0.81
+! 20 2 1 Kie Kiefer 20 1 0.79
+! 21 2 1 Stro Strobe 10 1 0.79
+! 22 2 1 SKie Schwarzkiefer 20 1 0.79
+! 23 2 1 Spir Spirke 20 1 0.79
+! 24 2 1 Zir Zirbe 20 1 0.79
+! 25 2 1 Lat Latsche
+! 30 3 1 Ta Tanne 30 6 0.81
+! 35 3 1 Eib Eibe 30 6 0.81
+! 40 4 1 ELae Lärche (europ.) 40 7 0.72
+! 41 4 1 JLae Jap.Lärche 41 7 0.72
+! 50 5 1 Dgl Douglasie 50 8 0.79
+! 60 6 2 Bu Buche 60 1 0.846
+! 61 8 2 HBu Hainbuche 60 1 0.81
+! 62 9 2 WLi Winterlinde 60 1 0.81
+! 63 9 2 Es Esche 63 12 0.81
+! 64 9 2 BAh Bergahorn 63 12 0.81
+! 65 8 2 SAh Spitzahorn 63 12 0.81
+! 66 8 2 FAh Feldahorn 75 13 0.81
+! 67 8 2 Rob Robinie 60 1 0.81
+! 68 9 2 Kir Kirsche 60 1 0.81
+! 69 9 2 Wob Wildobst 60 1 0.81
+! 70 7 2 Ei Eiche 70 9 0.79
+! 71 9 2 REi Roteiche 71 10 0.79
+! 72 9 2 Ul Ulme 70 9 0.81
+! 73 9 2 Elsb Elsbeere 70 9 0.81
+! 74 8 2 Mebe Mehlbeere 70 9 0.81
+! 75 8 2 SBi Sandbirke 75 13 0.81
+! 76 8 2 Vobe Vogelbeere 75 13 0.81
+! 77 9 2 Kast Edelkastanie 60 1 0.81
+! 78 9 2 Nuss Nußarten 60 1 0.81
+! 79 9 2 Spei Speierling 70 9 0.81
+! 80 8 2 SLbh Sonst.Laubholz 75 13 0.81
+! 81 8 2 WErl Weißerle 75 13 0.81
+! 82 8 2 As Aspe 75 13 0.81
+! 83 8 2 Pa Pappel 83 14 0.81
+! 84 8 2 Wei Weide 75 13 0.81
+! 85 8 2 GErl Grünerle 75 13 0.81
+! 86 8 2 SErl Schwarzerle 86 11 0.81
+! 87 9 2 ELbh Edellaubholz 63 12 0.81
+! 88 9 2 SLi Sommerlinde 60 1 0.81
+! 89 8 2 MBi Moorbirke 60 1 0.81
+! 90 1 1 SNdh Sonst.Nadelholz 10 1 0.81
+
+
+SUBROUTINE assign_BAY
+! Table of species numbers and names used in Bavaria (Bayern)
+USE data_init
+IMPLICIT NONE
+INTEGER :: i,imax
+
+! <60 conifers and 90 = other conifers
+! >=10 <20 spruces
+i=1
+spec_nrBAY(i)=10; spec_code(i)='FI'; GER_name(i)='Fichte'; LAT_name(i)='Picea abies (L.) KARST.'; spec_4c(i)=2
+i=i+1
+spec_nrBAY(i)=11; spec_code(i)='OFI'; GER_name(i)='Omorikafichte'; LAT_name(i)='Picea omorika (PANC.) PURK.'; spec_4c(i)=2
+i=i+1
+spec_nrBAY(i)=12; spec_code(i)='SFI'; GER_name(i)='Sitkafichte'; LAT_name(i)='Picea sitchensis (BONG.) CARR.'; spec_4c(i)=2
+! >= 20 <30 Scots pine
+i=i+1
+spec_nrBAY(i)=20; spec_code(i)='KIE'; GER_name(i)='Kiefer'; LAT_name(i)='Pinus sylvertris L.'; spec_4c(i)=3
+i=i+1
+spec_nrBAY(i)=21; spec_code(i)='STR'; GER_name(i)='Strobe'; LAT_name(i)='Pinus strobus L.'; spec_4c(i)=3
+! Weymouth pine (Pinus strobus) is assumably classed as spruce in Bavaria, so it is adopted here
+i=i+1
+spec_nrBAY(i)=22; spec_code(i)='SKI'; GER_name(i)='Schwarzkiefer'; LAT_name(i)='Pinus nigra ARN.'; spec_4c(i)=3
+i=i+1
+spec_nrBAY(i)=23; spec_code(i)='SPI'; GER_name(i)='Spirke'; LAT_name(i)='Pinus uncinata RAMOND'; spec_4c(i)=3
+i=i+1
+! Spirke/local mountain pine no distinction between mountain pine mugo pine
+spec_nrBAY(i)=24; spec_code(i)='ZKI'; GER_name(i)='Zirbelkiefer'; LAT_name(i)='Pinus cembra L.'; spec_4c(i)=3
+i=i+1
+spec_nrBAY(i)=25; spec_code(i)='BKI'; GER_name(i)='Latsche'; LAT_name(i)='Pinus mugo TURRA'; spec_4c(i)=3
+! arolla pine
+! >= 30 <40 firs
+i=i+1
+spec_nrBAY(i)=30; spec_code(i)='TA'; GER_name(i)='Tanne'; LAT_name(i)='Abies alba MILL.'; spec_4c(i)=2
+i=i+1
+spec_nrBAY(i)=35; spec_code(i)='EIB'; GER_name(i)='Eibe'; LAT_name(i)='Taxus baccata L.'; spec_4c(i)=2
+! >= 40 <50 larches
+i=i+1
+spec_nrBAY(i)=40; spec_code(i)='ELA'; GER_name(i)='Europ. Lärche'; LAT_name(i)='Larix decidua MILL.'; spec_4c(i)=6
+i=i+1
+spec_nrBAY(i)=41; spec_code(i)='JLA'; GER_name(i)='Japan. Lärche'; LAT_name(i)='Larix kaempferi (LAMB.) CARR.'; spec_4c(i)=6
+! >=50 <60 douglas firs
+i=i+1
+spec_nrBAY(i)=50; spec_code(i)='DGL'; GER_name(i)='Douglasie'; LAT_name(i)='Pseudotsuga menziesii (MIRBEL) FRANCO var. menziesii'; spec_4c(i)=2
+i=i+1
+! >= 60 < deciduous tree species
+spec_nrBAY(i)=60; spec_code(i)='BU'; GER_name(i)='Buche'; LAT_name(i)='Fagus sylvatica'; spec_4c(i)=1
+i=i+1
+spec_nrBAY(i)=61; spec_code(i)='HBU'; GER_name(i)='Hainbuche'; LAT_name(i)='Carpinus betulus L.'; spec_4c(i)=1
+i=i+1
+spec_nrBAY(i)=62; spec_code(i)='WLi'; GER_name(i)='Winterlinde'; LAT_name(i)='Tilia cordata'; spec_4c(i)=1
+i=i+1
+spec_nrBAY(i)=63; spec_code(i)='Es'; GER_name(i)='Esche'; LAT_name(i)='Fraxinus excelsior'; spec_4c(i)=4
+i=i+1
+spec_nrBAY(i)=64; spec_code(i)='BAh'; GER_name(i)='Bergahorn'; LAT_name(i)='Acer pseudoplatanus'; spec_4c(i)=1
+i=i+1
+spec_nrBAY(i)=65; spec_code(i)='SAh'; GER_name(i)='Spitzahorn'; LAT_name(i)='Acer platanoides'; spec_4c(i)=1
+i=i+1
+spec_nrBAY(i)=66; spec_code(i)='FAh'; GER_name(i)='Feldahorn'; LAT_name(i)='Acer campestre'; spec_4c(i)=1
+i=i+1
+spec_nrBAY(i)=67; spec_code(i)='Rob'; GER_name(i)='Robinie'; LAT_name(i)='Robinia pseudoacacia L.'; spec_4c(i)=4
+i=i+1
+spec_nrBAY(i)=68; spec_code(i)='Kir'; GER_name(i)='Kirsche'; LAT_name(i)='??? L.'; spec_4c(i)=0
+i=i+1
+spec_nrBAY(i)=69; spec_code(i)='Wob'; GER_name(i)='Wildobst'; LAT_name(i)='???'; spec_4c(i)=0
+i=i+1
+spec_nrBAY(i)=70; spec_code(i)='Ei'; GER_name(i)='Eiche'; LAT_name(i)='Quercus sp.'; spec_4c(i)=4
+i=i+1
+spec_nrBAY(i)=71; spec_code(i)='REi'; GER_name(i)='Roteiche'; LAT_name(i)='Quercus rubra L.'; spec_4c(i)=4
+i=i+1
+spec_nrBAY(i)=72; spec_code(i)='Ul'; GER_name(i)='Ulme'; LAT_name(i)='Ulmus sp.'; spec_4c(i)=4
+i=i+1
+spec_nrBAY(i)=73; spec_code(i)='Elsb'; GER_name(i)='Elsbeere'; LAT_name(i)='Sorbus torminalis CRANTZ'; spec_4c(i)=1
+i=i+1
+spec_nrBAY(i)=74; spec_code(i)='Mebe'; GER_name(i)='Mehlbeere'; LAT_name(i)='Sorbus aria CRANTZ'; spec_4c(i)=0
+i=i+1
+spec_nrBAY(i)=75; spec_code(i)='SBi'; GER_name(i)='Sandbirke'; LAT_name(i)='Betula pendula ROTH'; spec_4c(i)=5
+i=i+1
+spec_nrBAY(i)=76; spec_code(i)='Vobe'; GER_name(i)='Vogelbeere'; LAT_name(i)='Sorbus aucuparia L.'; spec_4c(i)=1
+i=i+1
+spec_nrBAY(i)=77; spec_code(i)='Kast'; GER_name(i)='Edelkastanie'; LAT_name(i)='Castanea sativa MILL.'; spec_4c(i)=4
+i=i+1
+spec_nrBAY(i)=78; spec_code(i)='Nuss'; GER_name(i)='Nußarten'; LAT_name(i)='Juglans spec.'; spec_4c(i)=4
+i=i+1
+spec_nrBAY(i)=79; spec_code(i)='Spei'; GER_name(i)='Speierling'; LAT_name(i)='Sorbus domestica L.'; spec_4c(i)=1
+i=i+1
+spec_nrBAY(i)=80; spec_code(i)='SLbh'; GER_name(i)='Sonst. Laubholz'; LAT_name(i)=''; spec_4c(i)=1
+i=i+1
+spec_nrBAY(i)=81; spec_code(i)='WErl'; GER_name(i)='Weißerle'; LAT_name(i)='Alnus incana (L.) MOENCH'; spec_4c(i)=5
+i=i+1
+spec_nrBAY(i)=82; spec_code(i)='As'; GER_name(i)='Aspe'; LAT_name(i)='Populus tremula L.'; spec_4c(i)=5
+i=i+1
+spec_nrBAY(i)=83; spec_code(i)='Pa'; GER_name(i)='Pappel'; LAT_name(i)='Populus spec.'; spec_4c(i)=5
+i=i+1
+spec_nrBAY(i)=84; spec_code(i)='Wei'; GER_name(i)='Weide'; LAT_name(i)='Salix spec.'; spec_4c(i)=5
+i=i+1
+spec_nrBAY(i)=85; spec_code(i)='GErl'; GER_name(i)='Grünerle'; LAT_name(i)='Alnus viridis (CHAIX) DC.'; spec_4c(i)=0
+i=i+1
+spec_nrBAY(i)=86; spec_code(i)='SErl'; GER_name(i)='Schwarzerle'; LAT_name(i)='Alnus glutinosa (L.) GAERTN.'; spec_4c(i)=5
+i=i+1
+spec_nrBAY(i)=87; spec_code(i)='ELbh'; GER_name(i)='Edellaubholz'; LAT_name(i)=''; spec_4c(i)=1
+i=i+1
+spec_nrBAY(i)=88; spec_code(i)='SLi'; GER_name(i)='Sommerlinde'; LAT_name(i)='Tilia platyphyllos SCOP.'; spec_4c(i)=1
+i=i+1
+spec_nrBAY(i)=89; spec_code(i)='SLi'; GER_name(i)='Moorbirke'; LAT_name(i)='Betula pubescens EHRH.'; spec_4c(i)=5
+i=i+1
+spec_nrBAY(i)=90; spec_code(i)='SNdh'; GER_name(i)='Sonst. Nadelholz'; LAT_name(i)=''; spec_4c(i)=2
+i=i+1
+
+imax = i-1
+spnum_for_DSW=0
+DO i=1,imax
+ spnum_for_DSW(spec_nrBay(i))=i
+ENDDO
+END ! subroutine assign_BAY
+
+
+FUNCTION tax_of_BRA_id(BRAid)
+USE data_init
+IMPLICIT NONE
+INTEGER BRAid, tax_of_BRA_id
+ tax_of_BRA_id=spec_4c(spnum_for_DSW(BRAid))
+END
+
+SUBROUTINE parthe_param(species,schichtin,hymax_Parthe,hb_Parthe,hT_Parthe,dymax_Parthe,db_Parthe,dT_Parthe,uh_Parthe,um_Parthe,un_Parthe,uxu_Parthe)
+USE data_init
+IMPLICIT NONE
+INTEGER spezies,schicht,species,schichtin
+REAL hymax_Parthe,hb_Parthe,hT_Parthe,dymax_Parthe,db_Parthe,dT_Parthe,uh_Parthe,um_Parthe,un_Parthe,uxu_Parthe
+! assignment of parameter values for data gap filling on height and diameter
+spezies=species
+schicht=schichtin
+IF(schicht==50) schicht=10
+IF(schicht==20) GOTO 2222
+1111 CONTINUE
+IF(spezies==111) THEN ! Pinus sylvestris
+ hymax_Parthe=23.74697; hb_Parthe=0.003; hT_Parthe=21.94225
+ dymax_Parthe=34.83703; db_Parthe=0.00146; dT_Parthe=34.72167
+ELSEIF (spezies==211) THEN ! Picea abies
+ hymax_Parthe=25.93201; hb_Parthe=0.00186; hT_Parthe=26.76250
+ dymax_Parthe=42.86844; db_Parthe=0.00029; dT_Parthe=15.53258
+ELSEIF (spezies==171) THEN ! Larix decidua
+ hymax_Parthe=25.65709; hb_Parthe=0.00295; hT_Parthe=18.05441
+ dymax_Parthe=50.63337; db_Parthe=0.00027; dT_Parthe=9.03576
+ELSEIF (spezies==711) THEN ! Betula pendula
+ hymax_Parthe=24.63548; hb_Parthe=0.00298; hT_Parthe=18.02402
+ dymax_Parthe=36.45272; db_Parthe=0.00112; dT_Parthe=36.2542
+ELSEIF (spezies==411.AND.schicht==10) THEN ! Quercus robur
+ hymax_Parthe=22.22929; hb_Parthe=0.00224; hT_Parthe=24.73157
+ dymax_Parthe=87.64567; db_Parthe=0.00012; dT_Parthe=89.0633
+ELSEIF (spezies==411.AND.schicht==40) THEN ! Quercus robur
+ hymax_Parthe=14.34897; hb_Parthe=0.00970; hT_Parthe=20.76731
+ dymax_Parthe=12.78134; db_Parthe=0.02083; dT_Parthe=25.9982
+ELSEIF (spezies==412) THEN ! Quercus petraea
+ hymax_Parthe=22.39128; hb_Parthe=0.003; hT_Parthe=25.4039
+ dymax_Parthe=54.13989; db_Parthe=0.00037; dT_Parthe=62.1369
+ELSEIF (spezies==511.AND.schicht==10) THEN ! Fagus sylvatica
+ hymax_Parthe=28.6865; hb_Parthe=0.00172; hT_Parthe=28.46973
+ dymax_Parthe=68.5734; db_Parthe=0.00032; dT_Parthe=73.12856
+ELSEIF (spezies==511.AND.schicht==40) THEN ! Fagus sylvatica
+ hymax_Parthe=31.28959; hb_Parthe=0.00162; hT_Parthe=39.51603
+ dymax_Parthe=21.01226; db_Parthe=0.00363; dT_Parthe=32.94303
+ELSEIF (spezies==631) THEN ! Acer pseudoplatanus
+ hymax_Parthe=28.36913; hb_Parthe=0.00123; hT_Parthe=12.72464
+ dymax_Parthe=63.8451; db_Parthe=0.00016; dT_Parthe=19.84293
+ELSEIF (spezies==621) THEN ! Fraxinus excelsior
+ hymax_Parthe=28.69626; hb_Parthe=0.00138; hT_Parthe=15.23287
+ dymax_Parthe=76.37174; db_Parthe=0.0001; dT_Parthe=16.90759
+ELSEIF (spezies==611.AND.schicht==10) THEN ! Carpinus betulus
+ hymax_Parthe=24.60247; hb_Parthe=0.00132; hT_Parthe=11.40522
+ dymax_Parthe=45.57378; db_Parthe=0.00047; dT_Parthe=55.59576
+ELSEIF (spezies==611.AND.schicht==40) THEN ! Carpinus betulus
+ hymax_Parthe=19.04968; hb_Parthe=0.00174; hT_Parthe=5.76216
+ dymax_Parthe=38.45864; db_Parthe=0.00042; dT_Parthe=46.93101
+ELSEIF (spezies==731.AND.schicht==10) THEN ! Tilia cordata
+ hymax_Parthe=27.69013; hb_Parthe=0.00156; hT_Parthe=23.76142
+ dymax_Parthe=50.06284; db_Parthe=0.00044; dT_Parthe=53.24075
+ELSEIF (spezies==731.AND.schicht==40) THEN ! Tilia cordata
+ hymax_Parthe=17.46179; hb_Parthe=0.00371; hT_Parthe=19.00039
+ dymax_Parthe=13.19608; db_Parthe=0.00586; dT_Parthe=16.4324
+ELSE
+ ! if no parameters provided for the species then the parameters for the
+ ! assigned 4c species will be used
+ IF(spec_4c(spnum_for_DSW(spezies))==1)spezies=511
+ IF(spec_4c(spnum_for_DSW(spezies))==2)spezies=211
+ IF(spec_4c(spnum_for_DSW(spezies))==3)spezies=111
+ IF(spec_4c(spnum_for_DSW(spezies))==4)spezies=411
+ IF(spec_4c(spnum_for_DSW(spezies))==5)spezies=711
+ IF(spec_4c(spnum_for_DSW(spezies))==6)spezies=171
+ GOTO 1111
+ENDIF
+! assignment of parameter values for missing data generation on
+spezies=species
+2222 CONTINUE
+IF(spezies==111) THEN ! Pinus sylvestris
+ uh_Parthe=24; um_Parthe=3.462; un_Parthe=110; uxu_Parthe=30
+ELSEIF (spezies==211) THEN ! Picea abies; Larix parameters used
+ uh_Parthe=25; um_Parthe=0.417; un_Parthe=90; uxu_Parthe=30
+ELSEIF (spezies==171) THEN ! Larix decidua
+ uh_Parthe=25; um_Parthe=0.417; un_Parthe=90; uxu_Parthe=30
+ELSEIF (spezies==711) THEN ! Betula pendula; Larix parameters used
+ uh_Parthe=25; um_Parthe=0.417; un_Parthe=90; uxu_Parthe=30
+ELSEIF (spezies==411) THEN ! Quercus robur
+ uh_Parthe=24; um_Parthe=1.63; un_Parthe=145; uxu_Parthe=40
+ELSEIF (spezies==412) THEN ! Quercus petraea
+ uh_Parthe=23; um_Parthe=0.395; un_Parthe=150; uxu_Parthe=40
+ELSEIF (spezies==511) THEN ! Fagus sylvatica
+ uh_Parthe=28; um_Parthe=1.17; un_Parthe=125; uxu_Parthe=45
+ELSEIF (spezies==621) THEN ! Fraxinus excelsior; Fagus parameters used
+ uh_Parthe=28; um_Parthe=1.17; un_Parthe=125; uxu_Parthe=45
+ELSEIF (spezies==731) THEN ! Tilia cordata; Fagus parameters used
+ uh_Parthe=28; um_Parthe=1.17; un_Parthe=125; uxu_Parthe=45
+ELSEIF (spezies==611) THEN ! Carpinus betulus; Fagus parameters used except height
+ uh_Parthe=23; um_Parthe=1.17; un_Parthe=125; uxu_Parthe=45
+ELSE
+ ! if no parameters provided for the species then the parameters for the
+ ! assigned 4c species will be used
+ IF(spec_4c(spnum_for_DSW(spezies))==1)spezies=511
+ IF(spec_4c(spnum_for_DSW(spezies))==2)spezies=211
+ IF(spec_4c(spnum_for_DSW(spezies))==3)spezies=111
+ IF(spec_4c(spnum_for_DSW(spezies))==4)spezies=411
+ IF(spec_4c(spnum_for_DSW(spezies))==5)spezies=711
+ IF(spec_4c(spnum_for_DSW(spezies))==6)spezies=171
+ GOTO 2222
+ENDIF
+END ! subroutine parthe_param
+
+FUNCTION wachsfunc(x,ymax,b,T)
+! data gap filling parameters for height and diameter as a function of age
+IMPLICIT NONE
+INTEGER x
+REAL ymax,b,T,wachsfunc
+ wachsfunc=ymax*(1.-(1./(1.+(EXP(b*ymax))**(x-T)-(EXP(b*ymax))**(-T))))
+END ! function wachsfunc
+
+FUNCTION inv_wachsfunc(x,ymax,b,T)
+! inverse function of wachsfunc for retrieval of age corresponding to a given diameter
+IMPLICIT NONE
+REAL x,ymax,b,T
+INTEGER inv_wachsfunc
+ inv_wachsfunc=NINT(LOG(1./(1.-x/ymax)-1.+(EXP(b*ymax))**(-T))/(b*ymax)+T)
+END ! function inv_wachsfunc
+
+FUNCTION agefunc(x,m,xu,n)
+! data gap filling parameters for age as a function of diameter for seed trees
+IMPLICIT NONE
+REAL x,m,xu,n,agefunc
+ agefunc=m*(x-xu)+n
+END ! function agefunc
+
+SUBROUTINE init_plenter_param
+! determines and sets ages at which dbh of 2 cm is reached and harvest age in plenter wald respectively
+USE data_init
+IMPLICIT NONE
+INTEGER inv_wachsfunc
+REAL hymax_Parthe,hb_Parthe,hT_Parthe,dymax_Parthe,db_Parthe,dT_Parthe,uh_Parthe,um_Parthe,un_Parthe,uxu_Parthe
+ high_age(1)=180 ! average estimated harvest age in plenter wald for Fagus sylvatica
+ high_age(2)=140 ! average estimated harvest age in plenter wald for Picea abies
+ high_age(3)=170 ! average estimated harvest age in plenter wald for Pinus silvestris
+ high_age(4)=190 ! average estimated harvest age in plenter wald for Quercus sp.
+ CALL parthe_param(511,10,hymax_Parthe,hb_Parthe,hT_Parthe,dymax_Parthe,db_Parthe,dT_Parthe,uh_Parthe,um_Parthe,un_Parthe,uxu_Parthe)
+ low_age(1)=inv_wachsfunc(2.,dymax_Parthe,db_Parthe,dT_Parthe)
+ CALL parthe_param(211,10,hymax_Parthe,hb_Parthe,hT_Parthe,dymax_Parthe,db_Parthe,dT_Parthe,uh_Parthe,um_Parthe,un_Parthe,uxu_Parthe)
+ low_age(2)=inv_wachsfunc(2.,dymax_Parthe,db_Parthe,dT_Parthe)
+ CALL parthe_param(111,10,hymax_Parthe,hb_Parthe,hT_Parthe,dymax_Parthe,db_Parthe,dT_Parthe,uh_Parthe,um_Parthe,un_Parthe,uxu_Parthe)
+ low_age(3)=inv_wachsfunc(2.,dymax_Parthe,db_Parthe,dT_Parthe)
+ CALL parthe_param(411,10,hymax_Parthe,hb_Parthe,hT_Parthe,dymax_Parthe,db_Parthe,dT_Parthe,uh_Parthe,um_Parthe,un_Parthe,uxu_Parthe)
+ low_age(4)=inv_wachsfunc(2.,dymax_Parthe,db_Parthe,dT_Parthe)
+ END ! subroutine init_plenter_param
+
+SUBROUTINE data_gap_fill_DSW(i)
+! fills gaps in input data
+USE data_init
+USE data_par
+USE data_simul
+USE data_species
+IMPLICIT NONE
+INTEGER i,n0ofvol,inv_wachsfunc
+REAL formfactor,wachsfunc,agefunc,k_age,newton_plenter
+REAL hymax_Parthe,hb_Parthe,hT_Parthe,dymax_Parthe,db_Parthe,dT_Parthe,uh_Parthe,um_Parthe,un_Parthe,uxu_Parthe
+LOGICAL init_plent
+ IF(ngroups(i)%taxid==2.OR.ngroups(i)%taxid==3) THEN
+ formfactor=0.45
+ ELSE
+ formfactor=0.5
+ ENDIF
+ CALL parthe_param(ngroups(i)%BRAid,ngroups(i)%schicht,hymax_Parthe,hb_Parthe,hT_Parthe,dymax_Parthe,db_Parthe,dT_Parthe,uh_Parthe,um_Parthe,un_Parthe,uxu_Parthe)
+ IF(ngroups(i)%schicht==20) THEN
+ ! gap filling for Überhälter (seed or shelter trees)
+ ngroups(i)%mhoe=uh_Parthe
+ ngroups(i)%alter=agefunc(ngroups(i)%dm,um_Parthe,uxu_Parthe,un_Parthe)
+ ngroups(i)%baumzahl=NINT(ngroups(i)%volume/(PI/4.*ngroups(i)%dm**2*ngroups(i)%mhoe*formfactor))
+ IF(ngroups(i)%baumzahl==0.AND.ngroups(i)%volume/(PI/4.*ngroups(i)%dm**2*ngroups(i)%mhoe*formfactor)>=0.) ngroups(i)%baumzahl=1
+ ELSEIF(ngroups(i)%schicht==10.OR.ngroups(i)%schicht==40) THEN
+ ! gap filling for Oberstand and Unterstand (upper and lower canopy strata)
+ ! with missing diameter and/or height information
+ IF(ngroups(i)%alter==0.) CALL error_mess(ngroups(i)%locid,'no age information for stand: ',REAL(ngroups(i)%locid))
+ IF(ngroups(i)%alter==0.) WRITE(8999,*) i,ngroups(i)%locid,ngroups(i)%BRAid,ngroups(i)%alter
+ IF(ngroups(i)%patchsize==0.) CALL error_mess(ngroups(i)%locid,'no area information for stand: ',ngroups(i)%patchsize)
+ IF(ngroups(i)%mhoe==0.) ngroups(i)%mhoe=wachsfunc(ngroups(i)%alter,hymax_Parthe,hb_Parthe,hT_Parthe)
+ IF(ngroups(i)%dm==0.) ngroups(i)%dm=wachsfunc(ngroups(i)%alter,dymax_Parthe,db_Parthe,dT_Parthe)
+ IF(ngroups(i)%gf==0.AND.ngroups(i)%volume==0.AND.ngroups(i)%baumzahl==0.) ngroups(i)%gf=PI/4.*(ngroups(i)%dm/100.)**2*10000./(PI*(spar(ngroups(i)%taxid)%crown_a*ngroups(i)%dm+spar(ngroups(i)%taxid)%crown_b)**2)
+ ELSEIF(ngroups(i)%schicht==50) THEN
+ ! gap filling for plenterwald
+ ! this routine is built on the use of the so called plenterwaldkurve (plenterwaldcurve)
+ ! i.e. exponential decrease in number of trees in age classes
+ init_plent=.false.
+ IF(init_plent) THEN
+
+ k_age=newton_plenter(0.15,low_age(ngroups(i)%taxid),high_age(ngroups(i)%taxid),dymax_Parthe,db_Parthe,dT_Parthe,ngroups(i)%dm)
+ ngroups(i)%baumzahl=n0ofvol(k_age,low_age(ngroups(i)%taxid),high_age(ngroups(i)%taxid),dymax_Parthe,db_Parthe,dT_Parthe,hymax_Parthe,hb_Parthe,hT_Parthe,ngroups(i)%volume,formfactor)
+ WRITE(8989,*) i,k_age,ngroups(i)%baumzahl,ngroups(i)%patchsize,ngroups(i)%baumzahl/ngroups(i)%patchsize,ngroups(i)%dm
+ ELSE
+ ngroups(i)%alter=inv_wachsfunc(ngroups(i)%dm,dymax_Parthe,db_Parthe,dT_Parthe)
+ ngroups(i)%mhoe=wachsfunc(ngroups(i)%alter,hymax_Parthe,hb_Parthe,hT_Parthe)
+ ngroups(i)%baumzahl=ngroups(i)%volume/(PI/4.*(ngroups(i)%dm/100.)**2*ngroups(i)%mhoe*formfactor)
+ ngroups(i)%gf=PI/4.*(ngroups(i)%dm/100.)**2*ngroups(i)%baumzahl*10000./ngroups(i)%patchsize
+ WRITE(8999,*) i,ngroups(i)%baumzahl,ngroups(i)%patchsize,ngroups(i)%gf,ngroups(i)%dm
+ ENDIF
+ ELSE
+ CALL error_mess(ngroups(i)%locid,'unknown schicht_id occured: ',real(ngroups(i)%schicht))
+ END IF ! end of distinction according to layer (schicht)
+END ! subroutine data_gap_fill_DSW
+
+FUNCTION newton_plenter(X,low_age,high_age,dmax,b,T,dg)
+IMPLICIT NONE
+REAL newton_plenter
+REAL F,DF,X,DX,dmax,b,T,dg
+INTEGER J,stepmax,low_age,high_age
+! Newton-plenter is to be called with a start value for X
+! which is k_age here
+! a subroutine NEWFDF is to be included in the main program which
+! calculates the value of the function and its derivative at X and
+! returns them in the variables F and DF
+ PARAMETER (stepmax=50)
+ DO 7 J=1,stepmax
+ CALL fdfk(X,low_age,high_age,dmax,b,T,dg,F,DF)
+ IF (J==stepmax) WRITE(8989,*) F, DF, X
+! IF(J==15) STOP
+ IF(DF.EQ.0.0) THEN
+ DX=0.01*X
+ ELSE
+ DX=F/DF
+ ENDIF
+ newton_plenter=X
+ IF(DX.GT.X) DX=X/2.
+ X=X-DX
+ IF(ABS(DX).LT.0.0005) RETURN
+7 END DO
+END
+
+SUBROUTINE fdfk(k_age,low_age,high_age,dmax,b,T,dg,F,DF)
+! calculates function value and derivative for newton_plenter
+USE data_par
+USE data_simul
+IMPLICIT NONE
+INTEGER :: low_age,high_age,age
+REAL :: term(1:4),sum(1:4),F,DF,k_age,dg,dmax,b,T,wachsfunc
+ sum=0.
+ DO age=low_age,high_age
+ term(1)=exp(-k_age*age)
+ term(2)=PI/4.*wachsfunc(age,dmax,b,T)**2*term(1)
+ term(3)=-term(2)*age
+ term(4)=-term(1)*age
+ sum(1)=sum(1)+term(2)
+ sum(2)=sum(2)+term(1)
+ sum(3)=sum(3)+term(3)
+ sum(4)=sum(4)+term(4)
+ END DO
+ F=(sum(1)/sum(2)*4/PI)**0.5-dg
+ DF=((1./PI)**0.5*(sum(3)*sum(2)-sum(4)*sum(1)))/(sum(2)**2.*(sum(1)/sum(2))**0.5)
+END ! subroutine fdfk
+
+FUNCTION n0ofvol(k_age,low_age,high_age,dmax,db,dT,hmax,hb,hT,vol,formfactor)
+! calcualtes number of trees at dbh = 2cm for the plenter wald curve
+! called by data_gap_fill_DSW if schicht=20 and init_plent=true; schicht is the word for layer
+USE data_par
+USE data_simul
+IMPLICIT NONE
+INTEGER :: low_age,high_age,age,n0ofvol
+REAL :: sum,k_age,dmax,db,dT,hmax,hb,hT,vol,wachsfunc,formfactor
+ sum=0.
+ DO age=low_age,high_age
+ sum=PI/4.*wachsfunc(age,dmax,db,dT)**2*exp(-k_age*age)*wachsfunc(age,hmax,hb,hT)
+ END DO
+ n0ofvol=NINT(vol/(sum/10000.*pi/4.*formfactor))
+END ! function n0ofvol
diff --git a/source_code/version2.2_windows/utils_par.f b/source_code/version2.2_windows/utils_par.f
new file mode 100755
index 0000000000000000000000000000000000000000..38d25b25f4e5e48b2a3de9e32aa36b6ff2b53068
--- /dev/null
+++ b/source_code/version2.2_windows/utils_par.f
@@ -0,0 +1,288 @@
+!*****************************************************************!
+!* *!
+!* 4C (FORESEE) Simulation Model *!
+!* *!
+!* *!
+!* SUBROUTINES *!
+!* - assign_CO2par *!
+!* FUNCTIONS *!
+!* - CO2_annual *!
+!* - CO2_hist *!
+!* *!
+!* 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 assign_CO2par
+! Tables of parameters for calculation of CO2 scenarios
+
+USE data_climate
+USE data_par
+USE data_simul
+
+IMPLICIT NONE
+DOUBLE PRECISION co2_annual
+
+if (flag_co2 .ge. 250) then
+ co2 = flag_co2/1000000.
+
+else if (flag_co2 .eq. 0) then
+ co2 = co2_st
+
+else
+ ! historical CO2 increase, function fitted by Kohlmaier et al.
+ p1_co2h = 0.000295
+ p2_co2h = 0.027
+ p3_co2h = 1860
+ p4_co2h = 0.00616
+
+ select case (flag_co2)
+ case (101, 201)
+ p1_co2 = 0.000295
+ p2_co2 = 0.027
+ p3_co2 = 1860
+ p4_co2 = 0.00616
+
+ case (102, 202)
+ !IF (flag_co2==102.OR.flag_co2==202) THEN
+ ! scenario function used for LTEEF II and SILVISTRAT
+ p1_co2 = 0.000350
+ p2_co2 = 0.0063
+ p3_co2 = 1990
+
+ case (103, 203)
+ ! Mauna Loa
+ continue
+
+ case(110, 210)
+ !ELSEIF (flag_co2==110.OR.flag_co2==210) THEN
+ ! IPCC IS92a after Bern CC model, reference
+ p0_co2 = -513178.349650788
+ p1_co2 = 774.68578088642
+ p2_co2 = -0.39065850816
+ p3_co2 = 0.00006585082
+
+ case(111,211)
+ !ELSEIF (flag_co2==111.OR.flag_co2==211) THEN
+ ! IPCC A1FI after Bern CC model, reference
+ p0_co2 = 1818104.0398310008
+ p1_co2 = -2584.5240137942828
+ p2_co2 = 1.2208975180122
+ p3_co2 = -0.0001915345027
+
+ case(112, 212)
+ !ELSEIF (flag_co2==112.OR.flag_co2==212) THEN
+ ! IPCC A2 after Bern CC model, reference
+ p0_co2 = -1045454.7878788
+ p1_co2 = 1587.54094794094
+ p2_co2 = -0.804265734265715
+ p3_co2 = 0.00013597513597513
+
+ case(113, 213)
+ !ELSEIF (flag_co2==113.OR.flag_co2==213) THEN
+ ! IPCC B1 after Bern CC model, reference
+ p0_co2 = 1596094.36363588
+ p1_co2 = -2362.17634032563
+ p2_co2 = 1.16444055944021
+ p3_co2 = -0.000191142191142135
+
+ case(114, 214)
+ !ELSEIF (flag_co2==114.OR.flag_co2==214) THEN
+ ! IPCC B2 after Bern CC model, reference
+ p0_co2 = 152455.527149544
+ p1_co2 = - 213.773160908033
+ p2_co2 = 0.0988590820945227
+ p3_co2 = -0.000014997257644339
+
+ case(115, 215)
+ !ELSEIF (flag_co2==115.OR.flag_co2==215) THEN
+ ! IPCC A1B after Bern CC model, reference
+ p0_co2 = 1955425.02331
+ p1_co2 = - 2858.095994844593
+ p2_co2 = 1.39094405594
+ p3_co2 = -0.00022533023
+
+ case(116, 216)
+ !ELSEIF (flag_co2==116.OR. flag_co2 == 216) THEN
+ ! IPCC A1p after Bern CC model, reference
+ p0_co2 = 1872081.750583
+ p1_co2 = -2742.46196581203
+ p2_co2 = 1.33764568765
+ p3_co2 = -0.00021717172
+
+ case(117, 217)
+ ! RCP8.5, FINAL RELEASE, 26 Nov. 2009
+ ! DOCUMENTATION: M. Meinshausen, S. Smith et al., 2011: "The RCP GHG concentrations and their extension from 1765 to 2500",
+ ! Climatic Change, 109(1-2), S. 213-241.
+
+ p0_co2 = 179973.892732277
+ p1_co2 = -180.746725115325
+ p2_co2 = 0.0454730127294021
+ p3_co2 = 0.
+
+ case(118, 218)
+ ! RCP2.6, FINAL RELEASE, 26 Nov. 2009
+ ! DOCUMENTATION: M. Meinshausen, S. Smith et al., 2011: "The RCP GHG concentrations and their extension from 1765 to 2500",
+ ! Climatic Change, 109(1-2), S. 213-241.
+
+ p0_co2 = 166355.928340573
+ p1_co2 = -285.793245173113
+ p2_co2 = 0.16016037734385
+ p3_co2 = -0.00002937992775
+
+ case(119, 219)
+ ! RCP4.5, FINAL RELEASE, 26 Nov. 2009
+ ! DOCUMENTATION: M. Meinshausen, S. Smith et al., 2011: "The RCP GHG concentrations and their extension from 1765 to 2500",
+ ! Climatic Change, 109(1-2), S. 213-241.
+
+ p0_co2 = 173604.151969275
+ p1_co2 = -286.531541491431
+ p2_co2 = 0.15501922547777
+ p3_co2 = -0.00002753265703
+
+ case(120, 220)
+ ! RCP6.0, FINAL RELEASE, 26 Nov. 2009
+ ! DOCUMENTATION: M. Meinshausen, S. Smith et al., 2011: "The RCP GHG concentrations and their extension from 1765 to 2500",
+ ! Climatic Change, 109(1-2), S. 213-241.
+
+ p0_co2 = 70777.
+ p1_co2 = -71.604
+ p2_co2 = 0.0182
+ p3_co2 = 0.0
+
+
+ end select
+
+ co2 = co2_annual(time_cur)
+end if
+
+END
+
+!*****************************************************************************
+
+DOUBLE PRECISION FUNCTION CO2_annual(int_time)
+! calculates annual atmospheric CO2 mixing ratio for scenarios
+
+USE data_climate
+USE data_par
+USE data_simul
+
+IMPLICIT NONE
+
+Integer int_time
+REAL x_time
+DOUBLE PRECISION CO2_hist
+
+! variable x_time foreseen for choice of year of step change
+! help variable
+x_time = real(int_time)
+
+! first set of functions for continuous scenarios, flag_co2 values < 200
+IF(flag_co2<200) THEN
+ select case (flag_co2)
+ case(101)
+! IF (flag_co2==101) THEN
+! historical increase (Kohlmaier)
+ CO2_annual=(p4_co2*(exp(p2_co2*(x_time-p3_co2))-1.)+1.)*p1_co2
+
+ case(102)
+! ELSE IF (flag_co2==102) THEN
+! LTEEF, SILVISTRAT Scenarios
+ CO2_annual=p1_co2*exp(p2_co2*((x_time-1)-p3_co2))
+
+ case(103)
+! ELSE IF (flag_co2==103) THEN
+! Mauna Loa
+ CO2_annual = CO2_hist(x_time)
+
+ case(111, 112, 113, 114, 115, 116, 117, 118,119,120)
+! ELSE IF (flag_co2==111.OR.flag_co2==114.OR.flag_co2==112.OR.flag_co2==113.OR.flag_co2==115) THEN
+! Sceanrio A1F1, B1, B2, A2
+ IF(x_time > year_CO2) THEN
+ CO2_annual = p0_co2 + p1_co2*x_time + p2_co2*x_time*x_time + p3_co2*x_time*x_time*x_time
+ CO2_annual = CO2_annual/1000000.
+ ELSE
+ CO2_annual = CO2_hist(x_time)
+ ENDIF
+
+ case(131)
+
+ CO2_annual = RCP_2p6(x_time)/1000000.
+ case(132)
+ if((time .gt. 0) .and. (x_time.le.2150)) then
+ CO2_annual = RCP_6p0(x_time)/1000000.
+ else
+ CO2_annual = RCP_6p0(2150)/1000000.
+ end if
+ case (133)
+ if((time .gt. 0) .and. (x_time .le. 2005)) then
+ CO2_annual = RCP_2p6(x_time)/1000000.
+ else
+ CO2_annual= 378.81/1000000.
+ end if
+
+ end select ! flag_co2
+ELSE
+! second set of functions for step change scenarios, flag_co2 values > 200
+! step change in the middle of the simulation period
+! in the first (second) half the CO2 partial pressure of the start (end) year is used
+ IF (flag_co2==201) THEN
+ IF(time < year/2) THEN
+ CO2_annual=(p4_co2*(exp(p2_co2*(time_b-p3_co2))-1.)+1.)*p1_co2
+ ELSE
+ CO2_annual=(p4_co2*(exp(p2_co2*(year+time_b-p3_co2))-1.)+1.)*p1_co2
+ ENDIF
+ ELSE IF (flag_co2==202) THEN
+ IF(time < year/2) THEN
+ CO2_annual=p1_co2*exp(p2_co2*((time_b-1)-p3_co2))
+ ELSE
+ CO2_annual=p1_co2*exp(p2_co2*((year+time_b-1)-p3_co2))
+ ENDIF
+! Hyytiälä 1995 - 2009
+ ELSE IF (flag_co2 == 199) THEN
+ if(x_time .gt.1994 .and. x_time .lt.2010) then
+ CO2_annual = (1.8607 * (x_time-1) -3353)/ 1000000.
+ else
+ CO2_annual = (1.8607 * 2009 -3353)/ 1000000.
+ end if
+ ENDIF
+
+ENDIF
+
+END function ! CO2_annual
+
+!*****************************************************************************
+
+DOUBLE PRECISION FUNCTION CO2_hist(x_time1)
+! calculates annual atmospheric CO2 mixing ratio for historical times
+
+USE data_climate
+USE data_out
+USE data_par
+USE data_simul
+
+IMPLICIT NONE
+
+REAL x_time1
+integer i_time1
+
+! Mauna Loa
+ IF(x_time1 > year_CO2 .or. x_time1 < 1959) then
+ write (unit_err,*)'Mauna Loa can only be used for 1959 through ', year_CO2
+ write (unit_err,*)'calendar year: ',x_time1,' is outside this range'
+ write (unit_err,*)'Application of historical increase'
+ CO2_hist=(p4_co2h*(exp(p2_co2h*(x_time1-p3_co2h))-1.)+1.)*p1_co2h
+ ELSE
+ i_time1 = int(x_time1)
+ CO2_hist=Mauna_Loa_CO2(i_time1)
+ ENDIF
+
+END function ! CO2_hist
+
diff --git a/source_code/version2.2_windows/wclas.f b/source_code/version2.2_windows/wclas.f
new file mode 100755
index 0000000000000000000000000000000000000000..caceb4730731758afe4acc92aebd82b917bbcb43
--- /dev/null
+++ b/source_code/version2.2_windows/wclas.f
@@ -0,0 +1,531 @@
+!*****************************************************************!
+!* *!
+!* 4C (FORESEE) Simulation Model *!
+!* *!
+!* *!
+!* Subroutine *!
+!* - wclas: classification of forest type according to the *!
+!* present species share (M.Lindner, 8.8.96) *!
+!* - clas_grob *!
+!* - indexx *!
+!* *!
+!* 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 wclas(btyp)
+
+ use data_stand
+ use data_species
+ use data_clas
+
+! ------------------------------------------------------------------
+! ----VARIABLEN---
+ INTEGER btyp, ns, ntr, i
+ real sumbio1
+ allocate(bpart(nspec_tree))
+! ------------------------------------------------------------------
+! Berechnung der Baumartenanteile (bpart) als Anteil an der
+! Gesamtbiomasse
+! ------------------------------------------------------------------
+ if(sumbio.eq.0) then
+
+ zeig=>pt%first
+ do
+ if(.not.associated(zeig)) exit
+
+ ns = zeig%coh%species
+ if(ns.le.nspec_tree) then
+ ntr = zeig%coh%ntreeA
+ zeig%coh%totBio = zeig%coh%x_fol + (1.+spar(ns)%alphac)*(zeig%coh%x_sap + zeig%coh%x_hrt) + zeig%coh%x_frt
+ sumbio = sumbio + ntr * zeig%coh%totBio
+ svar(ns)%sum_bio = svar(ns)%sum_bio + ntr*zeig%coh%totBio
+ end if
+ zeig=>zeig%next
+
+
+ end do
+ end if
+
+ sumbio1 = sumbio*kpatchsize/10000.
+
+
+ if (sumbio1.lt.1) sumbio1=sumbio1+0.0001
+
+ do i=1,nspec_tree
+ if( sumbio.ne.0) then
+ bpart(i)=svar(i)%sum_bio/sumbio
+ end if
+ end do
+!-----------------------------------------------------------------
+! Wald vorhanden? Freiflaeche (btyp300) unter 5m3 Biomasse
+!-----------------------------------------------------------------
+ btyp=0
+ if (sumbio1.le.5) then
+ btyp=300
+ goto 201
+ end if
+! ------------------------------------------------------------------
+! Klassifikation in Bestandestypen (Beschreibung in waldtyp.txt).
+! ------------------------------------------------------------------
+ nhpar =0
+ lhpar=0
+ alhpar=0
+ alnpar=0
+!-----------------------------------------------------------------
+! Baumartengruppen definieren:
+! Eichenanteile (Q. petrea und Q. robur) werden zusammengefasst
+! Aln=Laubholz mit niedriger Lebensdauer (Pioniere:Asp,Birk,Erl)
+! Alh=Laubholz mit hoher Lebensdauer (Edellh:Ah,Es,Hbu,Lind,Ulm)
+! Lh=Laubholz
+! Nh=Nadelholz
+!-----------------------------------------------------------------
+
+ alnpar = bpart(5)
+
+ alhpar = bpart(4)
+
+ lhpar = alnpar + alhpar + bpart(1)
+
+ nhpar = bpart(2) + bpart(3) + bpart(10)
+
+! ------------------------------------------------------------------
+! Unterprogramm zur Klassifikation (!lasgrob) bzw. (!lasfein)
+! ------------------------------------------------------------------
+ CALL clasgrob(btyp)
+
+ 201 CONTINUE
+
+ deallocate(bpart)
+
+ END subroutine wclas
+
+ subroutine clasgrob(btyp)
+! ------------------------------------------------------------------
+! Unterprogramm zur Klassifizierung von Simulationsergebnissen
+! 3. Version; Index nach Baumartenanteilen inclusive Grundwasser-
+! response. 29 Klassen (M.Lindner, 8.8.96)
+! ------------------------------------------------------------------
+!
+ use data_clas
+ use data_species
+
+! ----VARIABLEN---
+ REAL aa
+ INTEGER i, btyp, indx(18), top1,top2, maxspe
+ real bparth(18)
+
+! ----Konstanten----
+ REAL T1, T2, T3, T4
+ PARAMETER (T4=.9, T3=.5, T2=.3, T1=.2)
+
+!-----------------------------------------------------------------
+! Index nach aufsteigend sortierten Baumartenanteilen erzeugen
+!-----------------------------------------------------------------
+
+ do i =1, 18
+ bparth(i) = 0.
+ end do
+ bparth(8) = bpart(1)
+ bparth(10) = bpart(2)
+ bparth(11) = bpart(3)
+ bparth(13) = bpart(4)
+ bparth(5) = bpart(5)
+! eingefügt für Douglasie
+ bparth(6) = bpart(10)
+ maxspe = 18
+ call indexx(maxspe,bparth,indx)
+
+ top1=indx(maxspe)
+ top2=indx(maxspe-1)
+
+!-------Hauptbaumart > 90%---------------------------------------------
+ if (bparth(indx(maxspe)).ge.T4) then
+ if (top1.eq.1) then
+ btyp=70
+ else if (top1.eq.8) then
+
+ btyp=110
+ else if (top1.eq.10) then
+ btyp=10
+ else if (top1.eq.11) then
+ btyp=40
+ else if (top1.eq.13) then
+ btyp=140
+ else if (alnpar.ge.T4) then
+ btyp=180
+ else if (alhpar.ge.T4) then
+ if (top1.eq.16) then
+ btyp=190
+ else
+ btyp=191
+ endif
+ else if (nhpar.ge.T4) then
+ btyp=90
+ endif
+
+!-------Hauptbaumart 50-90%--------------------------------------------
+ else if (bparth(indx(maxspe)).ge.T3) then
+ if (top1.eq.1) then
+ btyp=70
+ else if (top1.eq.8) then
+ aa=lhpar - bparth(8)
+ if (top2.eq.1) then
+ btyp=125
+ else if (top2.eq.10) then
+ btyp=125
+ else if (top2.eq.11) then
+ btyp=125
+ else if (top2.eq.13) then
+ btyp=122
+ else if (aa.gt.nhpar) then
+ if (alhpar.gt.alnpar) then
+ btyp=120
+ else
+ btyp=120
+ endif
+ else
+ btyp=125
+ endif
+ else if (top1.eq.10) then
+ aa=(nhpar-bparth(10))
+ if (top2.eq.1) then
+ btyp=25
+ else if (top2.eq.8) then
+ btyp=20
+ else if (top2.eq.11) then
+ btyp=25
+ else if (top2.eq.13) then
+ btyp=20
+ else if (aa.gt.lhpar) then
+ btyp=25
+ else
+ btyp=20
+ endif
+ else if (top1.eq.11) then
+ aa=(nhpar-bparth(11))
+ if (top2.eq.1) then
+ btyp=55
+ else if (top2.eq.8) then
+ btyp=50
+ else if (top2.eq.10) then
+ btyp=55
+ else if (top2.eq.13) then
+ btyp=52
+ else if (aa.gt.lhpar) then
+ btyp=55
+ else
+ btyp=50
+ endif
+ else if (top1.eq.13) then
+ aa=(lhpar-bparth(13))
+ if (top2.eq.8) then
+ btyp=151
+ else if (top2.eq.11) then
+ btyp=157
+ else if (aa.gt.nhpar) then
+ if (alhpar.gt.alnpar) then
+ btyp=154
+ else
+ btyp=150
+ endif
+ else
+ btyp=155
+ endif
+ else if (alnpar.gt.T3) then
+ btyp=180
+ else if (alhpar.gt.T3) then
+ if (top1.eq.16) then
+ btyp=190
+ else
+ btyp=191
+ endif
+ else if (nhpar.ge.T3) then
+ btyp=90
+ endif
+
+!-------Hauptbaumart 30-50%--------------------------------------------
+ else if (bparth(indx(maxspe)).ge.T2) then
+ if (top1.eq.1) then
+ if (top2.eq.8) then
+ btyp=75
+ else if (top2.eq.10) then
+ btyp=75
+ else
+ btyp=75
+ endif
+ else if (top1.eq.8) then
+ aa=(lhpar-bparth(8))
+ if (top2.eq.1) then
+ btyp=125
+ else if (top2.eq.10) then
+ btyp=125
+ else if (top2.eq.11) then
+ btyp=125
+ else if (top2.eq.13) then
+ btyp=122
+ else if (aa.gt.nhpar) then
+ if (alhpar.gt.alnpar) then
+ btyp=120
+ else
+ btyp=120
+ endif
+ else
+ btyp=125
+ endif
+ else if (top1.eq.10) then
+ aa=(nhpar-bparth(10))
+ if (top2.eq.1) then
+ btyp=25
+ else if (top2.eq.8) then
+ btyp=20
+ else if (top2.eq.11) then
+ btyp=25
+ else if (top2.eq.13) then
+ btyp=20
+ else if (aa.gt.lhpar) then
+ btyp=25
+ else
+ btyp=20
+ endif
+ else if (top1.eq.11) then
+ aa=(nhpar-bparth(11))
+ if (top2.eq.8) then
+ btyp=50
+ else if (top2.eq.10) then
+ btyp=55
+ else if (top2.eq.13) then
+ btyp=52
+ else if (aa.gt.lhpar) then
+ btyp=55
+ else
+ btyp=50
+ endif
+ else if (top1.eq.13) then
+ aa=(lhpar-bparth(13))
+ if (top2.eq.8) then
+ btyp=151
+ else if (top2.eq.11) then
+ btyp=157
+ else if (aa.gt.nhpar) then
+ if (alhpar.gt.alnpar) then
+ btyp=154
+ else
+ btyp=150
+ endif
+ else
+ btyp=155
+ endif
+ else if (nhpar.gt.lhpar) then
+ btyp=100
+ else if (alnpar.gt.alhpar) then
+ if (top2.eq.11) then
+ btyp=185
+ else if (top2.eq.13) then
+ btyp=185
+ else
+ btyp=185
+ endif
+ else if (alhpar.ge.T2) then
+ if (top2.eq.8) then
+ btyp=195
+ else if (top2.eq.13) then
+ btyp=154
+ else if (top1.eq.16) then
+ btyp=195
+ else
+ btyp=191
+ endif
+ else
+ btyp=250
+ endif
+
+!-------Hauptbaumart 20-30%--------------------------------------------
+ else if (bparth(indx(maxspe)).ge.T1) then
+ if (top1.eq.1) then
+ if (top2.eq.8) then
+ btyp=75
+ else if (top2.eq.10) then
+ btyp=75
+ else
+ btyp=75
+ endif
+ else if (top1.eq.8) then
+ aa=(lhpar-bparth(8))
+ if (top2.eq.1) then
+ btyp=125
+ else if (top2.eq.10) then
+ btyp=125
+ else if (top2.eq.11) then
+ btyp=125
+ else if (top2.eq.13) then
+ btyp=122
+ else if (aa.gt.nhpar) then
+ if (alhpar.gt.alnpar) then
+ btyp=120
+ else
+ btyp=120
+ endif
+ else
+ btyp=125
+ endif
+ else if (top1.eq.10) then
+ aa=(nhpar-bparth(10))
+ if (top2.eq.1) then
+ btyp=25
+ else if (top2.eq.8) then
+ btyp=20
+ else if (top2.eq.11) then
+ btyp=25
+ else if (top2.eq.13) then
+ btyp=20
+ else if (aa.gt.lhpar) then
+ btyp=25
+ else
+ btyp=20
+ endif
+ else if (top1.eq.11) then
+ aa=(nhpar-bparth(11))
+ if (top2.eq.8) then
+ btyp=50
+ else if (top2.eq.10) then
+ btyp=55
+ else if (top2.eq.13) then
+ btyp=52
+ else if (aa.gt.lhpar) then
+ btyp=55
+ else
+ btyp=50
+ endif
+ else if (top1.eq.13) then
+ aa=(lhpar-bparth(13))
+ if (top2.eq.8) then
+ btyp=151
+ else if (top2.eq.11) then
+ btyp=157
+ else if (aa.gt.nhpar) then
+ if (alhpar.gt.alnpar) then
+ btyp=154
+ else
+ btyp=150
+ endif
+ else
+ btyp=155
+ endif
+ else if (alnpar.gt.alhpar) then
+ btyp=185
+ else if (alhpar.gt.T2) then
+ if (top2.eq.13) then
+ btyp=154
+ else if (top1.eq.16) then
+ btyp=195
+ else
+ btyp=191
+ endif
+ else if (lhpar.le.T2) then
+ btyp=100
+ else if (nhpar.le.T2) then
+ btyp=200
+ else
+ btyp=250
+ endif
+
+!------------Hauptbaumart unter 20%-------------------------
+ else
+ if (lhpar.le.T2) then
+ btyp=100
+ else if (nhpar.le.T2) then
+ btyp=200
+ else
+ btyp=250
+ endif
+ endif
+ END subroutine clasgrob
+
+ SUBROUTINE indexx(n,arr,indx)
+ INTEGER n,indx(n),M,NSTACK
+ REAL arr(n)
+ PARAMETER (M=7,NSTACK=50)
+ INTEGER i,indxt,ir,itemp,j,jstack,k,l,istack(NSTACK)
+ REAL a
+ do 11 j=1,n
+ indx(j)=j
+11 continue
+ jstack=0
+ l=1
+ ir=n
+1 if(ir-l.lt.M)then
+ do 13 j=l+1,ir
+ indxt=indx(j)
+ a=arr(indxt)
+ do 12 i=j-1,1,-1
+ if(arr(indx(i)).le.a)goto 2
+ indx(i+1)=indx(i)
+12 continue
+ i=0
+2 indx(i+1)=indxt
+13 continue
+ if(jstack.eq.0)return
+ ir=istack(jstack)
+ l=istack(jstack-1)
+ jstack=jstack-2
+ else
+ k=(l+ir)/2
+ itemp=indx(k)
+ indx(k)=indx(l+1)
+ indx(l+1)=itemp
+ if(arr(indx(l+1)).gt.arr(indx(ir)))then
+ itemp=indx(l+1)
+ indx(l+1)=indx(ir)
+ indx(ir)=itemp
+ endif
+ if(arr(indx(l)).gt.arr(indx(ir)))then
+ itemp=indx(l)
+ indx(l)=indx(ir)
+ indx(ir)=itemp
+ endif
+ if(arr(indx(l+1)).gt.arr(indx(l)))then
+ itemp=indx(l+1)
+ indx(l+1)=indx(l)
+ indx(l)=itemp
+ endif
+ i=l+1
+ j=ir
+ indxt=indx(l)
+ a=arr(indxt)
+3 continue
+ i=i+1
+ if(arr(indx(i)).lt.a)goto 3
+4 continue
+ j=j-1
+ if(arr(indx(j)).gt.a)goto 4
+ if(j.lt.i)goto 5
+ itemp=indx(i)
+ indx(i)=indx(j)
+ indx(j)=itemp
+ goto 3
+5 indx(l)=indx(j)
+ indx(j)=indxt
+ jstack=jstack+2
+ if(jstack.gt.NSTACK)pause 'NSTACK too small in indexx'
+ if(ir-i+1.ge.j-l)then
+ istack(jstack)=ir
+ istack(jstack-1)=i
+ ir=j-1
+ else
+ istack(jstack)=j-1
+ istack(jstack-1)=l
+ l=i
+ endif
+ endif
+ goto 1
+ END
+! (C) Copr. 1986-92 Numerical Recipes Software 0)+0143$!-.
diff --git a/source_code/version2.2_windows/wpm.f b/source_code/version2.2_windows/wpm.f
new file mode 100755
index 0000000000000000000000000000000000000000..52544216f929babf2cdd888d679769346c2314fd
--- /dev/null
+++ b/source_code/version2.2_windows/wpm.f
@@ -0,0 +1,284 @@
+!*****************************************************************!
+!* *!
+!* 4C (FORESEE) Simulation Model *!
+!* *!
+!* *!
+!* Post Processing for 4C (FORESEE) *!
+!* Subroutines: *!
+!* - wpm: control subroutine for wpm *!
+!* - calculate_output: wood production model *!
+!* *!
+!* 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 wpm()
+
+use data_simul
+use data_wpm
+
+implicit none
+
+
+character(150) mansortFile, manrecFile, spinupFile, file
+
+
+ ! begin program
+ call setFlags
+
+ ! input
+ if(flag_wpm.eq.5.or. flag_wpm.eq.4 .or.flag_wpm.eq.6) then
+ wob = .FALSE.
+ mansortfile = 'input/wpm_mansort.ini'
+ manrecfile = 'input/wpm_manrec.ini'
+ call read_mansort(mansortFile, manrecFile)
+ end if
+ if(flag_wpm.eq.4) output_spinup = .TRUE.
+ if(flag_wpm.eq.6) then
+
+ spinup_on = .TRUE.
+ spinupFile = 'input/spinup.wpm'
+
+
+ end if
+
+ call allocate_in_output
+ call ini_input
+
+ ! simulation
+ if ( associated(first_mansort) ) then
+ ! wood processing
+ call calculate_product_lines
+ if (debug) then
+ file = trim(dirout) // 'calculate_prod_lines.wpm'
+ call write_product_lines(file)
+ end if
+ end if
+
+ call calculate_wood_processing
+
+ if (debug) then
+ file = trim(dirout) // 'calculate_wood_proc.wpm'
+ call write_product_lines(file)
+ end if
+
+ ! use categories
+ call calculate_use_categories
+ if (debug) then
+ file = trim(dirout) // 'calculate_use_cat.wpm'
+ call write_wpm_output()
+ end if
+
+ ! ouput for every year
+ if ( spinup_on ) call read_spinup(spinupFile)
+ call calculate_output
+
+! call write_wpm_output()
+
+ if (output_spinup) then
+ file = trim(dirout) // 'spinup.wpm'
+ call write_spinup(file)
+ end if
+
+ end subroutine wpm
+
+
+
+!***********************************************************
+! simulation: lifespan - recycling, burning, atmosphere, landfill
+
+subroutine calculate_output
+
+use data_wpm
+
+implicit none
+
+integer i, j, k, l
+real rec_value, burn_value, land_value, rest, sum_rest, sum_out
+real func, func1, func2
+real, dimension(nr_use_cat) :: a, b, c, d
+real, dimension(nr_use_cat) :: val
+integer age
+! stores the pieces of wood, dimensions: 2, max_age of every use category
+! %pieces(1,:) stores values for the actual year
+! %pieces(2,:) stores new calculated values after calculating the recycling part for the actual year
+type store_wood
+ real, pointer, dimension(:,:) :: pieces
+ real :: rec_value
+end type store_wood
+! list of store_wood arrays of dimension of number of use category
+type(store_wood), allocatable, dimension(:) :: wood_pieces
+
+ allocate(wood_pieces(nr_use_cat))
+
+ ! simulation: recycling, burning, atmosphere, landfill
+ ! allocate wood_pieces for use categories, get the parameters
+ do j=1,nr_use_cat
+
+ allocate(wood_pieces(j)%pieces(2,max_age(j)))
+
+ wood_pieces(j)%pieces(:,:) = 0.
+
+ a(j) = use_categories(j)%lifespan_function%a
+ b(j) = use_categories(j)%lifespan_function%b
+ c(j) = use_categories(j)%lifespan_function%c
+ d(j) = use_categories(j)%lifespan_function%d
+
+ end do
+
+ sub_material = 0.
+
+ do i=1,size(years)
+
+ ! set used values to 0
+ burn_value = 0.
+ land_value = 0.
+ val = 0.
+
+ do j = 1, nr_use_cat
+ wood_pieces(j)%rec_value = 0.
+ end do
+
+ ! for each use category
+ do j=1, nr_use_cat
+ ! put the calculated values from the last year
+ ! fill the wood_pieces with values from the categories
+ if ( spinup_on .and. i == 1 ) then
+ wood_pieces(j)%pieces(2,:) = use_categories(j)%spinup(:)
+ end if
+
+ wood_pieces(j)%pieces(1,:) = 0.
+ wood_pieces(j)%pieces(1,:) = wood_pieces(j)%pieces(2,:)
+
+ ! spinup output
+ if (output_spinup .and. i == size(years)) then
+ use_categories(j)%spinup(:) = wood_pieces(j)%pieces(1,:)
+ end if
+
+
+
+ wood_pieces(j)%pieces(1,1) = wood_pieces(j)%pieces(1,1) + use_categories(j)%value(i)
+ use_categories(j)%value(i) = 0.
+
+ ! set used values to 0
+ wood_pieces(j)%pieces(2,:) = 0.
+ rec_value = 0.
+ func = 0.
+ rest = 0.
+ sum_rest = 0.
+
+
+ ! for all wood pieces: sum up recycling, burning, output
+ do k=1,max_age(j)-1
+ ! lifespan function: percentual quotient of the REMAINING wood
+ age = k-1
+ if ( age > 1) then
+ func1 = d(j) - a(j) / ( 1 + ( b(j) * EXP( -c(j) * age ) ) )
+ func2 = d(j) - a(j) / ( 1 + ( b(j) * EXP( -c(j) * (age-1) ) ) )
+ func = func1 / func2
+ else
+ func = d(j) - a(j) / ( 1 + ( b(j) * EXP( -c(j) * age ) ) )
+ func = func / 100
+ endif
+ rest = wood_pieces(j)%pieces(1,k) * (func)
+
+ ! sum up the remaining pieces
+ sum_rest = sum_rest + rest
+
+ ! calculated wood pieces into wood_pieces(j)%pieces(1,k) or (if too old) into the recycling
+ wood_pieces(j)%pieces(2,k+1) = rest
+
+ end do
+
+ ! all the wood per year:
+ ! sum_rest + (rec_value + land_value + burn_value)
+ sum_out = sum(wood_pieces(j)%pieces(1,:)) - sum_rest
+ rec_value = sum_out * use_categories(j)%rec_par(1)
+ land_value = land_value + sum_out * use_categories(j)%rec_par(2)
+ burn_value = burn_value + sum_out * use_categories(j)%rec_par(3)
+
+ ! use recycling parameters to calculate this year use_categories values from rec_value
+ if ( i <= size(years) ) then
+ do l=1,nr_use_cat
+ wood_pieces(l)%rec_value = wood_pieces(l)%rec_value + rec_value * use_categories(j)%rec_use_par(l)
+ val(l) = val(l) + rec_value * use_categories(j)%rec_use_par(l)
+ end do
+ end if
+
+ ! calculate material substitution for use categorie 1 and 2 from recycling
+ ! sub_material(i) = sub_material(i) + val(1) + val(2)
+ if (j.eq.1 ) then
+ sub_material(i) = sub_material(i) + (wood_pieces(j)%pieces(1,1) + rec_value) * sub_par(3)
+ elseif (j.eq.2) then
+ sub_material(i) = sub_material(i) + ((wood_pieces(j)%pieces(1,1) + rec_value) * sub_par(3))
+ endif
+
+ ! store the output for the year and use category
+ val(j) = val(j) + sum_rest
+
+
+ end do
+
+ ! fill the final values to the use_categories
+ do j=1, nr_use_cat
+ use_categories(j)%value(i) = val(j)
+ wood_pieces(j)%pieces(2,2) = wood_pieces(j)%pieces(2,2) + wood_pieces(j)%rec_value
+
+ ! store the last wood_pieces as spinup value
+ if (output_spinup .and. i == size(years)) then
+ use_categories(j)%spinup(1) = use_categories(j)%spinup(1) + wood_pieces(j)%rec_value
+ end if
+
+ end do
+
+ ! sum up the use categories
+ sum_use_cat(i) = sum(val)
+
+ burning(i) = burning(i) + burn_value
+
+ ! calculate energy substitution
+ sub_energy(i) = burning(i) * sub_par(2)
+
+ ! calculate sum of harvest emission, energy and material substitution
+ sub_sum(i) = emission_har(i) + sub_energy(i) + sub_material(i)
+
+
+ ! fill the landfill spinup value into the first year
+ if ( spinup_on .and. i == 1) landfill(i) = landfill(i) + landfill_spinup
+
+ ! landfill values
+ if ( i > 1 ) then
+ landfill(i) = landfill(i-1)*0.995 + land_value
+ endif
+
+ end do
+
+ ! store landfill spinup value
+ landfill_spinup = landfill( size(years) )
+
+ ! write atmosphere: summation of burning values per year
+ do i=1, size(years)
+ if (i == 1) then
+ atmo_cum(i) = atmo_cum(i) + burning(i)
+ atmo_year(i) = atmo_year(i) + burning(i)
+ else
+ atmo_cum(i) = atmo_cum(i) + atmo_cum(i-1) + landfill(i-1)*0.005 + burning(i)
+ atmo_year(i) = atmo_year(i) + landfill(i-1)*0.005 + burning(i)
+ end if
+ end do
+
+
+ ! deallocate wood_pieces
+ do j=1,nr_use_cat
+ deallocate(wood_pieces(j)%pieces)
+ end do
+ deallocate(wood_pieces)
+
+end subroutine calculate_output
diff --git a/source_code/version2.2_windows/wpm_input.f b/source_code/version2.2_windows/wpm_input.f
new file mode 100755
index 0000000000000000000000000000000000000000..26e45dca3fa69daf80713ea6b946513be213dc04
--- /dev/null
+++ b/source_code/version2.2_windows/wpm_input.f
@@ -0,0 +1,233 @@
+!*****************************************************************!
+!* *!
+!* 4C (FORESEE) Simulation Model *!
+!* *!
+!* *!
+!* Post Processing: read the mansort files *!
+!* *!
+!* Subroutines for: *!
+!* - input_manrec: call from management, fills values into *!
+!* manrec structure *!
+!* - read_spinup: reads the spinup file *!
+!* - read_input: read the mansort and manrec files *!
+!* *!
+!* 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 input_manrec
+
+use data_simul
+use data_manag
+use data_wpm
+
+implicit none
+
+
+type(manrec_type) :: manrec_ini
+
+
+
+
+if ( flag_wpm > 0 ) then
+
+ manrec_ini%year = time
+ manrec_ini%management = maninf
+ manrec_ini%measure = meas
+
+ if (.not. associated(first_manrec)) then
+ allocate (first_manrec)
+ first_manrec%manrec = manrec_ini
+ nullify(first_manrec%next)
+ nr_management_years = 1
+ else
+ ! build new manrec object
+ allocate(act_manrec)
+ act_manrec%manrec = manrec_ini
+ ! chain into the list
+ act_manrec%next => first_manrec
+ ! set the first pointer to the new object
+ first_manrec => act_manrec
+ nr_management_years = nr_management_years + 1
+ end if
+
+end if
+
+end subroutine input_manrec
+
+
+
+
+
+subroutine read_mansort(mansortFile, manrecFile)
+
+
+use data_wpm
+use data_tsort
+
+implicit none
+
+character(70) mansortFile, manrecFile
+integer i, k
+integer ios, un
+real buffer
+type(mansort_type) mansort_ini
+type(manrec_type) manrec_ini
+
+ ! set the external unit
+ un = 100
+ ios = 0
+
+ ! read manrec file
+ ! leave header
+ open (un, file = manrecFile, iostat = ios, status = 'OLD', action = 'read')
+ do i=1,3
+ read (un, *)
+ enddo
+
+ ! read lines
+ do
+ read (un,'(I16,A28,I8)',iostat=ios) &
+ manrec_ini%year, manrec_ini%management, &
+ manrec_ini%measure
+
+ ! set the manrec list pointer
+ if (ios == 0) then
+ if (.not. associated(first_manrec)) then
+ allocate (first_manrec)
+ first_manrec%manrec = manrec_ini
+ nullify(first_manrec%next)
+ nr_management_years = 1
+ else
+ ! build the manrec object
+ allocate(act_manrec)
+ act_manrec%manrec = manrec_ini
+ ! chain into the list
+ act_manrec%next => first_manrec
+ ! set the actual pointer to the new object
+ first_manrec => act_manrec
+
+ nr_management_years = nr_management_years + 1
+ end if
+ end if
+
+ if (ios > 0) then
+ stop
+ else if (ios < 0) then
+ exit
+ endif
+ k=k+1
+ end do
+
+ close(un, status="keep")
+
+ ! read mansort file
+ ! leave header
+ open (un, file = mansortFile, iostat = ios, status = 'OLD', action = 'read')
+ do i=1,3
+ read (un,*)
+ end do
+
+ ! read lines
+ do
+ read (un,'(I9,I8,I3, A3, F10.3, 4(F8.3), F10.4, F15.3, I9)',iostat=ios)&
+ mansort_ini%year, mansort_ini%count, mansort_ini%spec, &
+ mansort_ini%typus, &
+ buffer, &
+ mansort_ini%diam, mansort_ini%diam_wob, buffer, buffer, &
+ mansort_ini%volume, &
+ mansort_ini%dw, &
+ mansort_ini%number
+
+ ! set the mansort list pointer
+ if (ios == 0) then
+ if (.not. associated(first_mansort)) then
+ allocate (first_mansort)
+ first_mansort%mansort = mansort_ini
+ nullify(first_mansort%next)
+ anz_list = 1
+ else
+ ! build new mansort object
+ allocate(act_mansort)
+ act_mansort%mansort = mansort_ini
+ ! chain into the list
+ act_mansort%next => first_mansort
+ ! set the first pointer to the new object
+ first_mansort => act_mansort
+ anz_list = anz_list +1
+ end if
+ end if
+
+ if (ios.gt.0) then
+ stop
+ elseif (ios.lt.0) then
+ exit
+ endif
+ k=k+1
+ enddo
+
+ close(un, status="keep")
+
+
+ end subroutine read_mansort
+
+!*****************************************************************************
+
+subroutine read_spinup(spinupFile)
+
+use data_wpm
+
+character(70) spinupFile
+integer i, j, unit, ios
+integer max
+real, dimension(nr_use_cat + 1) :: spinny
+real dummy
+
+ unit = 20
+
+ ! Headers to output files
+ open(unit, FILE=spinupFile, STATUS='OLD', action='read')
+ do i=1,3
+ read (unit, *)
+ enddo
+
+ ! how many years?
+ max = max_age(1)
+ do j = 1,nr_use_cat
+ if ( max < max_age(j) ) max = max_age(j)
+ end do
+
+ do i=1,max
+ read(unit, '(I9,8(F15.3) )',iostat=ios) &
+ dummy, &
+ spinny(1), &
+ spinny(2), &
+ spinny(3), &
+ spinny(4), &
+ spinny(5), &
+ spinny(6), &
+ spinny(7), &
+ spinny(8)
+
+ if ( ios == 0 ) then
+ do j = 1,nr_use_cat
+ if ( i <= max_age(j) ) then
+ use_categories(j)%spinup(i) = spinny(j)
+ end if
+ end do
+ if (i == 1) then
+ landfill_spinup = spinny(8)
+ end if
+ end if
+ end do
+
+ close(unit, status="keep")
+
+end subroutine read_spinup
diff --git a/source_code/version2.2_windows/wpm_sea.f b/source_code/version2.2_windows/wpm_sea.f
new file mode 100755
index 0000000000000000000000000000000000000000..f8d835ce8f0d6dfd28690a9f08709218b14dbd59
--- /dev/null
+++ b/source_code/version2.2_windows/wpm_sea.f
@@ -0,0 +1,660 @@
+!*****************************************************************!
+!* *!
+!* SEA for 4C (FORESEE) Simulation Model *!
+!* *!
+!* *!
+!* Subroutines: *!
+!* *!
+!* sea: control subroutine for sea *!
+!* *!
+!* sort_mansort: first sorting of mansort *!
+!* sort_standsort: first sorting of standsort *!
+!* sort_industrial *!
+!* calculate_harvest_costs *!
+!* calculate_assets *!
+!* calculate_costs *!
+!* calculate_npv *!
+!* read_sea_prices *!
+!* *!
+!* 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 sea
+
+use data_simul
+use data_wpm
+
+implicit none
+
+
+character(150) pricesFile
+
+
+ ! begin program
+ call setFlags
+
+ call allocate_in_output
+
+ call ini_input_sea
+
+
+ ! read prices
+ pricesFile = trim(dirin)//'sea_prices.wpm'
+ ! call fullPath(pricesFile, dirin)
+ call read_sea_prices(pricesFile)
+
+ ! simulation
+ if ( associated(first_mansort) ) then
+ ! first sorting
+ call sort_mansort
+ end if
+
+ if ( associated(first_standsort) ) then
+ call sort_standsort
+ end if
+
+ ! sort 0.4 to the industrial wood
+ call sort_industrial
+
+ ! harvest costs calculation
+ call calculate_harvest_costs
+
+ ! timber selling assets calculation
+ call calculate_assets
+
+ ! calculate rest costs
+ call calculate_costs
+
+ ! calculate npv
+ call calculate_npv
+
+
+
+end subroutine sea
+
+
+!***************************************************************
+! calculate timber grades from the mansort and standsort input
+! input: data_wpm
+! output: data_wpm
+!***************************************************************
+
+subroutine sort_mansort
+
+use data_wpm
+use data_simul
+
+implicit none
+
+integer i, index
+real volume, pi, diam
+character(4) act_typus
+integer act_spec, act_year, set_year
+
+
+ pi = 3.1415926536 ! PI
+
+ i = nr_years
+
+ ! set the first year, set an ima
+ act_year = first_mansort%mansort%year
+ set_year = first_manrec%manrec%year
+
+ ! set the run pointer to the begin of the list
+ act_mansort => first_mansort
+ act_manrec => first_manrec
+
+ ! check if actuelles management is not brushing or tending
+ if (trim(act_manrec%manrec%management) .eq. 'brushing') then
+ if( associated(act_manrec%next) ) then
+ act_manrec => act_manrec%next
+ endif
+ endif
+
+ if (trim(act_manrec%manrec%management) .eq. 'tending') then
+ if( associated(act_manrec%next) ) then
+ act_manrec => act_manrec%next
+ endif
+ endif
+
+
+
+ ! check if last management year was some years ealier
+ do while (set_year < act_mansort%mansort%year)
+ act_mansort => act_mansort%next
+ end do
+
+ act_year = act_mansort%mansort%year
+ set_year = act_manrec%manrec%year
+
+
+ if( associated(act_manrec%next) ) then
+ act_manrec => act_manrec%next
+ end if
+
+ do while (associated(act_mansort))
+
+ if ( act_year <= act_manrec%manrec%year .and. &
+ act_manrec%manrec%year /= set_year ) then
+ ! check the management in actual year
+ if (trim(act_manrec%manrec%management) .eq. 'brushing') then
+ if( associated(act_manrec%next) ) then
+ act_manrec => act_manrec%next
+ endif
+ endif
+
+ if (trim(act_manrec%manrec%management) .eq. 'tending') then
+ if( associated(act_manrec%next) ) then
+ act_manrec => act_manrec%next
+ endif
+ endif
+
+ if (trim(act_manrec%manrec%management) .ne. 'tending' .and. &
+ trim(act_manrec%manrec%management) .ne. 'brushing' ) then
+ ! set next value for actual manrec year
+ set_year = act_manrec%manrec%year
+ endif
+
+ if( associated(act_manrec%next) ) then
+ act_manrec => act_manrec%next
+ end if
+ endif
+
+ ! set species index
+ act_spec = act_mansort%mansort%spec
+ act_typus = act_mansort%mansort%typus
+
+ ! calculate carbon for the actual line in mansort
+ volume = act_mansort%mansort%volume * act_mansort%mansort%number
+
+
+ select case (trim(act_typus))
+ case ('ste1', 'ste2')
+ diam = act_mansort%mansort%diam_wob
+ if (diam >=25 .and. diam < 30) index = 8
+ if (diam >=30 .and. diam < 35) index = 9
+ if (diam >=35) index = 10
+
+ case ('sg1', 'sg2')
+ diam = act_mansort%mansort%diam_wob
+ if (diam < 15) index = 3
+ if (diam >=15 .and. diam < 20) index = 4
+ if (diam >=20 .and. diam < 25) index = 5
+ if (diam >=25 .and. diam < 30) index = 6
+ if (diam >=30) index = 7
+
+ case ('in1', 'in2')
+ index = 2
+ case ('fue')
+ index = 1
+
+ end select
+
+ mansort_tg(act_spec, index, set_year) = mansort_tg(act_spec, index, set_year) + volume
+
+ ! after using the mansort list item, go to the next
+ act_mansort => act_mansort%next
+
+ if (associated(act_mansort)) then
+ act_year = act_mansort%mansort%year
+ end if
+ end do
+
+
+end subroutine sort_mansort
+
+!***************************************************************
+
+subroutine sort_industrial
+
+use data_wpm
+use data_simul
+
+implicit none
+
+integer i, j
+real ind
+
+ ! sort value*ind into the industrial wood
+ ind = 0.4
+
+ do i = 1, nr_spec
+ do j = 1, nr_timb_grades
+ select case (j>2)
+ case (.TRUE.)
+ mansort_tg(i, 2, :) = mansort_tg(i, j, :) * ind + mansort_tg(i, 2, :)
+ mansort_tg(i, j, :) = mansort_tg(i, j, :) * (1 - ind)
+ standsort_tg(i, 2, :) = standsort_tg(i, j, :) * ind + standsort_tg(i, 2, :)
+ standsort_tg(i, j, :) = standsort_tg(i, j, :) * (1 - ind)
+ end select
+ end do
+ end do
+
+
+end subroutine sort_industrial
+
+!****************************************************************
+subroutine sort_standsort
+
+use data_wpm
+
+implicit none
+
+integer j, index
+real volume, pi, diam
+character(4) act_typus
+integer act_spec, act_year
+
+
+ pi = 3.1415926536 ! PI
+
+ j = 1
+ ! set the first year
+ act_year = first_standsort%mansort%year
+ ! set the run pointer to the begin of the list
+ act_standsort => first_standsort
+
+ ! check if last management year was some years ealier
+ do while (act_year < act_standsort%mansort%year)
+ act_standsort => act_standsort%next
+ end do
+
+ do while (associated(act_standsort))
+
+ ! check the management year
+ if ( act_year <= act_standsort%mansort%year )then
+ ! set next value for actual standsort year
+ j = j+1
+ endif
+
+ ! set species index
+ act_spec = act_standsort%mansort%spec
+
+ act_typus = act_standsort%mansort%typus
+ ! calculate carbon for the actual line in standsort
+ volume = act_standsort%mansort%volume * act_standsort%mansort%number
+
+
+ select case (trim(act_typus))
+
+ case ('ste1', 'ste2')
+ diam = act_standsort%mansort%diam_wob
+ if (diam >=25 .and. diam < 30) index = 8
+ if (diam >=30 .and. diam < 35) index = 9
+ if (diam >=35) index = 10
+
+
+ case ('sg1', 'sg2')
+ diam = act_standsort%mansort%diam_wob
+ if (diam < 15) index = 3
+ if (diam >=15 .and. diam < 20) index = 4
+ if (diam >=20 .and. diam < 25) index = 5
+ if (diam >=25 .and. diam < 30) index = 6
+ if (diam >=30) index = 7
+
+ case ('in1', 'in2')
+ index = 2
+
+ case ('fue')
+ index = 1
+
+ end select
+
+
+ standsort_tg(act_spec, index, act_standsort%mansort%year) = standsort_tg(act_spec, index, act_standsort%mansort%year) + volume
+
+
+ ! after using the standsort list item, go to the next
+ act_standsort => act_standsort%next
+
+ if (associated(act_standsort)) then
+ act_year = act_standsort%mansort%year
+ end if
+
+ end do
+
+
+end subroutine sort_standsort
+
+
+!*****************************************************************************
+subroutine calculate_harvest_costs()
+
+use data_wpm
+use data_simul
+
+implicit none
+
+integer i, j
+
+! calcultation of costs only implemented for monoculture stands
+! differentiation between coniferous and deciduous trees
+do i = 1, nr_spec
+ if (nr_spec.eq.2 .or. nr_spec.eq.3) then
+ do j = 1, nr_timb_grades
+ ms_costs(i,:) = hsystem(2) * mansort_tg(i,j,:) * chainsaw_prices(i,j) + &
+ hsystem(1) * mansort_tg(i,j,:) * harvester_prices(i,j) + &
+ ms_costs(i,:)
+ st_costs(i,:) = hsystem(2) * standsort_tg(i,j,:) * chainsaw_prices(i,j) + &
+ hsystem(1) * standsort_tg(i,j,:) * harvester_prices(i,j) + &
+ st_costs(i,:)
+ end do
+ else
+ do j = 1, nr_timb_grades
+ ms_costs(i,:) = mansort_tg(i,j,:) * chainsaw_prices(i,j) + ms_costs(i,:)
+ st_costs(i,:) = standsort_tg(i,j,:) * chainsaw_prices(i,j) + st_costs(i,:)
+ end do
+ endif
+end do
+
+end subroutine calculate_harvest_costs
+
+
+
+!*****************************************************************************
+subroutine calculate_assets()
+
+use data_wpm
+use data_simul
+
+implicit none
+
+integer i, j
+
+ do i = 1, nr_spec
+ do j = 1, nr_timb_grades
+ ms_assets(i,:) = mansort_tg(i,j,:) * net_prices(i,j) + &
+ ms_assets(i,:)
+ st_assets(i,:) = standsort_tg(i,j,:) * net_prices(i,j) + &
+ st_assets(i,:)
+ end do
+ end do
+
+end subroutine calculate_assets
+
+
+
+!*****************************************************************************
+subroutine calculate_costs()
+
+use data_wpm
+use data_simul
+use data_plant
+
+implicit none
+
+character(30) manag
+integer i, act_year, spec
+
+
+ ! sum of standsort
+ do i = 1, nr_spec
+ sum_costs(2,:) = st_assets(i,:) - st_costs(i,:) + sum_costs(2,:)
+ end do
+
+ ! sum of mansort
+ do i = 1, nr_spec
+ sum_costs(3,:) = ms_assets(i,:) - ms_costs(i,:) + sum_costs(3,:)
+ end do
+
+ ! silvicultural costs like tending etc.
+ act_manrec => first_manrec
+ do while (associated(act_manrec))
+ act_year = act_manrec%manrec%year
+ manag = trim(act_manrec%manrec%management)
+
+ ! sum up silvicultural costs and subsidies
+ select case (trim(manag))
+
+ case ('tending')
+ ! tending costs and subsidies
+ sum_costs(4, act_year) = - tending_prices(1) + sum_costs(4, act_year)
+ subsidy(2, act_year) = tending_prices(2) + subsidy(2, act_year)
+
+ case ('brushing')
+ ! brushing costs and subsidies
+ sum_costs(4, act_year) = - brushing(1) + sum_costs(4, act_year)
+ subsidy(2, act_year) = brushing(2) + subsidy(2, act_year)
+
+ case ('felling')
+ ! forest maintenance costs and subsidies
+ sum_costs(4,act_year) = - ext_for(2,1) + sum_costs(4,act_year)
+ sum_costs(5,act_year) = ext_for(2,2) + sum_costs(5,act_year)
+
+ case ('shelterwood system1')
+ ! forest maintenance costs and subsidies
+ sum_costs(4,act_year) = - ext_for(1,1) + sum_costs(4,act_year)
+ sum_costs(4,act_year) = ext_for(1,2) + sum_costs(4,act_year)
+ sum_costs(4,act_year) = - ext_for(2,1) + sum_costs(4,act_year)
+ sum_costs(4,act_year) = ext_for(2,2) + sum_costs(4,act_year)
+
+ case ('shelterwood system2')
+ ! brushing, forest maintenance, timber selling costs and subsidies
+ sum_costs(4,act_year) = - ext_for(1,1) + sum_costs(4,act_year)
+ sum_costs(4,act_year) = ext_for(1,2) + sum_costs(4,act_year)
+ sum_costs(4,act_year) = - ext_for(2,1) + sum_costs(4,act_year)
+ sum_costs(4,act_year) = ext_for(2,2) + sum_costs(4,act_year)
+ sum_costs(4, act_year) = - brushing(1) + sum_costs(4, act_year)
+ subsidy(2, act_year) = brushing(2) + subsidy(2, act_year)
+
+ case ('felling after shelterwood s.')
+ sum_costs(4,act_year) = - ext_for(2,1) + sum_costs(4,act_year)
+ sum_costs(4,act_year) = ext_for(2,2) + sum_costs(4,act_year)
+
+ case ('thinning')
+ ! forest maintenance, timber selling
+ sum_costs(4,act_year) = - ext_for(1,1) + sum_costs(4,act_year)
+ sum_costs(4,act_year) = ext_for(1,2) + sum_costs(4,act_year)
+ sum_costs(4,act_year) = - ext_for(2,1) + sum_costs(4,act_year)
+ sum_costs(4,act_year) = ext_for(2,2) + sum_costs(4,act_year)
+
+
+ end select
+ act_manrec => act_manrec%next
+ end do
+
+ ! planting
+ if (plant_year /= 0) then
+ select case (flag_plant)
+ case(8,7,6,5,4,33)
+ sum_costs(4,plant_year) = - sum(planting_prices * (npl_mix / 1000)) + sum_costs(4,plant_year)
+ subsidy(2,plant_year) = sum(planting_sub(1,plant_year)*npl_mix/npl_mix) + subsidy(2,plant_year)
+
+ ! pine, beech, oak, spruce, birch
+ case (10)
+ spec = 3
+ case (11)
+ spec = 1
+ case (12)
+ spec = 4
+ case (13)
+ spec = 2
+ case (14)
+ spec = 5
+ end select
+ sum_costs(4,plant_year) = - planting_prices(spec) * numplant(spec)/1000 + sum_costs(4,plant_year)
+ subsidy(2,plant_year) = planting_sub(1,spec) + subsidy(2,plant_year)
+
+ ! fence
+ sum_costs(4,plant_year) = - fence(1,spec) + sum_costs(4,plant_year)
+ sum_costs(5,plant_year) = fence(2,spec) + sum_costs(5,plant_year)
+ end if
+
+
+ ! sum up subsidies
+ sum_costs(5,:) = subsidy(1,:) + subsidy(2,:) + fix(2) + sum_costs(5,:)
+
+ ! sum up all except standsort
+ sum_costs(1,:) = sum_costs(3,:) + sum_costs(4,:) - fix(1) + sum_costs(5,:)
+
+end subroutine calculate_costs
+
+
+!*****************************************************************************
+subroutine calculate_npv()
+
+use data_wpm
+use data_simul
+use data_plant
+
+implicit none
+
+real, dimension(4, nr_years) :: rate
+integer i, j
+
+ rate(:,:) = 0.
+ do i = 1, nr_years
+ do j = 1, 4
+ rate(j, i) = (1+int_rate(j))**i
+ npv(j,i) = (sum_costs(2,i) + sum_costs(3,i)) / rate(j, i)
+ npv(j+4,i) = sum(sum_costs(1,1:i)/rate(j,1:i))
+ npv(j+8,i) = npv(j+4,i) - npv(1,1) + npv(j,i)
+ end do
+ end do
+
+end subroutine calculate_npv
+
+
+!*****************************************************************************
+subroutine read_sea_prices(pricesFile)
+
+use data_wpm
+use data_simul
+
+implicit none
+
+character(70) pricesFile
+integer i, unit, ios
+
+ unit = getunit()
+
+ open(unit, FILE=pricesFile, STATUS='OLD', action='read')
+
+ ! Headers
+ do i=1,5
+ read (unit, *)
+ enddo
+
+ read(unit, '(F6.2)',iostat=ios) fix(1)
+ read (unit, *)
+ read(unit, *)
+ read(unit, '(5(F6.2))',iostat=ios) &
+ planting_prices(1), &
+ planting_prices(2), &
+ planting_prices(3), &
+ planting_prices(4), &
+ planting_prices(5)
+ read(unit, *)
+ read(unit, '(5(F6.2))',iostat=ios) &
+ fence(1,1), &
+ fence(1,2), &
+ fence(1,3), &
+ fence(1,4), &
+ fence(1,5)
+ read(unit, *)
+ read(unit, '(F6.2)',iostat=ios) brushing(1)
+ read(unit, *)
+ read(unit, '(F6.2)',iostat=ios) tending_prices(1)
+
+ read(unit, *)
+ read(unit, *)
+ read(unit, '(2(F6.2))',iostat=ios) &
+ hsystem(1), &
+ hsystem(2)
+
+ read(unit, *)
+ read(unit, '(F6.2)',iostat=ios) dec_per
+
+ do i=1,4
+ read (unit, *)
+ enddo
+ do i=1, nr_timb_grades
+ read(unit, '(5(F6.2) )',iostat=ios) &
+ chainsaw_prices(1, i), &
+ chainsaw_prices(2, i), &
+ chainsaw_prices(3, i), &
+ chainsaw_prices(4, i), &
+ chainsaw_prices(5, i)
+ end do
+
+ read(unit, *)
+ read(unit, *)
+ do i=1, nr_timb_grades
+ read(unit, *) &
+ harvester_prices(1, i), &
+ harvester_prices(2, i), &
+ harvester_prices(3, i), &
+ harvester_prices(4, i), &
+ harvester_prices(5, i)
+ end do
+
+ read(unit, *)
+ read(unit, *)
+ do i=1, nr_timb_grades
+ read(unit, '(5(F6.2) )',iostat=ios) &
+ net_prices(1, i), &
+ net_prices(2, i), &
+ net_prices(3, i), &
+ net_prices(4, i), &
+ net_prices(5, i)
+ end do
+
+ read(unit, *)
+ read(unit, *)
+ read(unit, '(F6.2)',iostat=ios) ext_for(1,1)
+ read(unit, *)
+ read(unit, '(F6.2)',iostat=ios) ext_for(1,2)
+
+ read(unit, *)
+ read(unit, *)
+ read(unit, *)
+ read(unit, '(F6.2)',iostat=ios) fix(2)
+ read (unit, *)
+ read(unit, *)
+ read(unit, '(5(F6.2))',iostat=ios) &
+ planting_sub(1,1), &
+ planting_sub(1,2), &
+ planting_sub(1,3), &
+ planting_sub(1,4), &
+ planting_sub(1,5)
+ read(unit, *)
+ read(unit, '(5(F6.2))',iostat=ios) &
+ planting_sub(2,1), &
+ planting_sub(2,2), &
+ planting_sub(2,3), &
+ planting_sub(2,4), &
+ planting_sub(2,5)
+ read(unit, *)
+ read(unit, '(5(F6.2))',iostat=ios) &
+ fence(1,1), &
+ fence(1,2), &
+ fence(1,3), &
+ fence(1,4), &
+ fence(1,5)
+ read(unit, *)
+ read(unit, '(F6.2)',iostat=ios) brushing(2)
+ read(unit, *)
+ read(unit, '(F6.2)',iostat=ios) tending_prices(2)
+
+ read(unit, *)
+ read(unit, '(F6.2)',iostat=ios) ext_for(2,2)
+ read(unit, *)
+ read(unit, '(F6.2)',iostat=ios) ext_for(2,2)
+
+ read(unit, *)
+ read(unit, *) &
+ int_rate(2), &
+ int_rate(3), &
+ int_rate(4)
+
+ close(unit, status="keep")
+
+end subroutine read_sea_prices
diff --git a/source_code/version2.2_windows/wpm_wood_proc.f b/source_code/version2.2_windows/wpm_wood_proc.f
new file mode 100755
index 0000000000000000000000000000000000000000..3aa07d8a5e2682dc050af9b09e55f85ef919ac20
--- /dev/null
+++ b/source_code/version2.2_windows/wpm_wood_proc.f
@@ -0,0 +1,251 @@
+!*****************************************************************!
+!* *!
+!* Post Processing for 4C (FORESEE) *!
+!* *!
+!* *!
+!* Subroutines: *!
+!* *!
+!* - calculate_product_lines: calculate product lines from the *!
+!* mansort input *!
+!* *!
+!* - calculate_wood_processing: calculates wood processing *!
+!* product lines after processing *!
+!* *!
+!* - calculate_use_categories: prepare use_categories module *!
+!* for use in the simulation *!
+!* *!
+!* 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 *!
+!* *!
+!*****************************************************************!
+
+!***************************************************************
+! calculate producl lines from the mansort input
+! input: data_mansort
+! output: wood_processing
+!***************************************************************
+
+subroutine calculate_product_lines
+
+use data_wpm
+
+implicit none
+
+integer i, j, index
+real volume, volume_wob, pi, summe
+character(4) act_typus
+integer act_spec, act_year, set_year
+
+
+ pi = 3.1415926536 ! PI
+
+ j = 0 ! nr_management_years
+ i = nr_years
+ wpm_manag_years = 0
+
+ ! set the first year, set an ima
+ act_year = first_mansort%mansort%year
+ set_year = first_mansort%mansort%year + 1
+
+ ! set the run pointer to the begin of the list
+ act_mansort => first_mansort
+ act_manrec => first_manrec
+
+ ! check if last management year was some years ealier
+ do while (act_year < act_mansort%mansort%year)
+ act_mansort => act_mansort%next
+ end do
+
+ do while (associated(act_mansort))
+
+ ! check the management year
+ if ( act_year <= act_manrec%manrec%year .and. &
+ act_manrec%manrec%year /= set_year ) then
+ ! check the management in actual year
+ if (trim(act_manrec%manrec%management) .ne. 'tending' .and. &
+ trim(act_manrec%manrec%management) .ne. 'brushing' ) then
+ ! set next value for actual manrec year
+ j = j+1
+ wpm_manag_years = wpm_manag_years + 1
+ management_years(j) = act_manrec%manrec%year
+ set_year = act_manrec%manrec%year
+ endif
+ if( associated(act_manrec%next) ) then
+ act_manrec => act_manrec%next
+ end if
+ endif
+
+ act_spec = act_mansort%mansort%spec
+ act_typus = act_mansort%mansort%typus
+ ! calculate carbon for the actual line in mansort
+ volume = act_mansort%mansort%dw * act_mansort%mansort%number
+
+ if (wob) then
+ ! without bark
+ volume_wob = volume * &
+ (act_mansort%mansort%diam_wob * act_mansort%mansort%diam_wob) / &
+ (act_mansort%mansort%diam * act_mansort%mansort%diam)
+ else
+ ! with bark
+ volume_wob = volume
+ end if
+
+ ! logs (L)
+ if ( trim(act_typus) == 'ste1' .or. trim(act_typus) == 'ste2') then
+ ! logs (L) softwood
+ if( act_spec == 2 .or. act_spec == 3) then
+ index = 1
+ ! logs (L) hardwood
+ elseif ( act_spec == 1 .or. act_spec == 4 .or. act_spec == 5) then
+ index = 2
+ end if
+
+ ! partial logs (LAS)
+ elseif( trim(act_typus) == 'sg1' .or. trim(act_typus) == 'sg2') then
+ ! partial logs (LAS) softwood
+ if( act_spec == 2 .or. act_spec == 3) then
+ index = 3
+ ! partial logs (LAS) hardwood
+ elseif ( act_spec == 1 .or. act_spec == 4 .or. act_spec == 5) then
+ index = 4
+ end if
+
+ ! industrial wood
+ elseif ( trim(act_typus) == 'in1' .or. trim(act_typus) == 'in2') then
+ index = 5
+
+ ! fuelwood
+ elseif ( trim(act_typus) == 'fue' ) then
+ index = 7
+
+ end if
+
+
+ if (j == 0) then
+ product_lines(index)%value(1) = product_lines(index)%value(1) + volume_wob
+ product_lines(7)%value(1) = product_lines(7)%value(1) + (volume - volume_wob)
+ else
+ product_lines(index)%value(j) = product_lines(index)%value(j) + volume_wob
+ product_lines(7)%value(j) = product_lines(7)%value(j) + (volume - volume_wob)
+ end if
+
+ ! after using the mansort list item, go to the next
+ act_mansort => act_mansort%next
+
+ if (associated(act_mansort)) then
+ act_year = act_mansort%mansort%year
+ end if
+
+ end do
+
+ ! sum up input
+ do i=1, wpm_manag_years
+ summe = 0.
+ do j = 1, nr_pr_ln
+ summe = summe + product_lines(j)%value(i)
+ end do
+ sum_input(management_years(i)) = summe
+
+ ! calculate emission from harvesting process
+ emission_har (management_years(i)) = summe * sub_par(1)
+ write (9999,*) emission_har(management_years(i)), management_years(i)
+ end do
+end subroutine calculate_product_lines
+
+
+
+
+!***************************************************************
+! calculate wood processing
+! input: wood_processing
+! output: wood_processing
+!***************************************************************
+
+subroutine calculate_wood_processing
+
+
+use data_wpm
+
+implicit none
+
+integer i,j,k
+integer, dimension(2) :: s
+real, dimension(nr_pr_ln) :: ext
+
+ ext = 0
+ ! for each parameter set
+ s = shape(product_lines(1)%proc_par)
+ do k=1, s(1)
+ ! for each year of manrec
+ do i=1,size(management_years)
+ ! all lines read
+ if (management_years(i) == 0) then
+ exit
+ end if
+
+ ! percentual distribution of wood types after processing
+ do j=1,nr_pr_ln
+ ext = ext + product_lines(j)%proc_par(k,:)*product_lines(j)%value(i)
+ end do
+
+ ! save the result in product_lines
+ do j=1,nr_pr_ln
+ product_lines(j)%value(i) = ext(j)
+ ! save the initial values for the intermediate output
+ pl(k,j,management_years(i)) = ext(j)
+ end do
+
+ ext(:) = 0.
+
+ end do
+ end do
+
+end subroutine calculate_wood_processing
+
+
+
+
+
+!**********************************************************************
+! prepare use_categories module for use in the simulation
+subroutine calculate_use_categories
+
+
+use data_wpm
+
+implicit none
+
+integer i, j, l, k
+real val
+
+ j = 1
+ i = size(years)
+ do while(i > 0 .and. j .le. size(management_years))
+
+ if ( years(i) == management_years(j)) then
+ val = 0
+ ! for every use category, for every product line
+ do k=1,nr_use_cat
+ do l=1,nr_pr_ln
+ val = val + product_lines(l)%value(j)*product_lines(l)%use_par(k)
+ end do
+ use_categories(k)%value(i) = val
+ use_cat(k,i) = val
+ val = 0
+ end do
+
+ ! set rest pools
+ burning(i) = product_lines(7)%value(j)
+ landfill(i) = 0.
+ j = j + 1
+ end if
+ i = i - 1
+ end do
+
+end subroutine calculate_use_categories
diff --git a/source_code/version2.2_windows/wpm_write_output.f b/source_code/version2.2_windows/wpm_write_output.f
new file mode 100755
index 0000000000000000000000000000000000000000..c05a7a46fdb245c30b7d3e6763b676e17b9267b4
--- /dev/null
+++ b/source_code/version2.2_windows/wpm_write_output.f
@@ -0,0 +1,158 @@
+!*****************************************************************!
+!* *!
+!* 4C (FORESEE) Simulation Model *!
+!* *!
+!* *!
+!* Post Processing: output files WPM *!
+!* *!
+!* Subroutines for: *!
+!* - write_wpm_output *!
+!* - write_product_lines *!
+!* - write_spinup *!
+!* *!
+!* 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 write_wpm_output()
+
+use data_simul
+
+use data_wpm
+
+character(150) outputFile
+integer i, unit, ios
+
+ unit = getunit()
+
+ ! Headers to output files
+ outputFile = trim(dirout) // 'wpm_output.out' // trim(anh)
+
+ open(unit, FILE=trim(outputFile), STATUS='unknown')
+ ! Headers to output files
+ ! prodyht.dat
+ open(unit, FILE=trim(outputFile), STATUS='unknown')
+ write(unit,'(A50)') '# Carbon in different products, Gg C'
+ write(unit,'(A50)') '# use categories'
+ write(unit,'(11(A20))') ' ','build','other','struct','furni','pack','long','short','','land '
+ write(unit,'(11(A20))') 'year',' mat.','build','support','mat','mat','paper','paper','burn','fill','atmo'
+
+ ! how many years?
+ ! write
+ do i=1,size(years)
+ write(unit, '(I9,10(F20.3) )',iostat=ios) &
+ years(i), &
+ use_categories(1)%value(i), &
+ use_categories(2)%value(i), &
+ use_categories(3)%value(i), &
+ use_categories(4)%value(i), &
+ use_categories(5)%value(i), &
+ use_categories(6)%value(i), &
+ use_categories(7)%value(i), &
+ burning(i), &
+ landfill(i), &
+ atmo_cum(i)
+ end do
+
+end subroutine write_wpm_output
+
+!***************************************************************************
+subroutine write_product_lines(outputFile)
+
+use data_simul
+
+use data_wpm
+
+character(150) outputFile
+integer i, unit, ios
+
+ unit = getunit()
+
+ ! Headers to output files
+ ! prodyht.dat
+ open(unit, FILE=trim(outputFile), STATUS='unknown')
+ write(unit,'(A50)') '# Carbon in different products, Gg C'
+ write(unit,'(A50)') '# product lines'
+ write(unit,'(7(A15))') 'year',' 1','2','3','5','6','7'
+
+ ! how many years?
+ ! write
+ do i=1,size(management_years)
+ write(unit, '(I9,7(F15.3) )',iostat=ios) &
+ management_years(i), &
+ product_lines(1)%value(i), &
+ product_lines(2)%value(i), &
+ product_lines(3)%value(i), &
+ product_lines(4)%value(i), &
+ product_lines(5)%value(i), &
+ product_lines(6)%value(i), &
+ product_lines(7)%value(i)
+ end do
+
+end subroutine write_product_lines
+
+!*****************************************************************************
+subroutine write_spinup(outputFile)
+
+use data_simul
+
+use data_wpm
+
+character(150) outputFile
+integer i, j, unit, ios
+integer max
+real, dimension(nr_use_cat + 1) :: spinny
+
+
+ unit = getunit()
+
+ ! Headers to output files
+ ! prodyht.dat
+ open(unit, FILE=trim(outputFile), STATUS='unknown')
+ write(unit,'(A50)') '# Carbon in different products, Gg C'
+ write(unit,'(A30)') '# use categories'
+ write(unit,'(9(A15))') 'year','1','2','3','4','5','6','7','landfill'
+
+ ! how many years?
+ ! write
+ max = max_age(1)
+ do j = 1,nr_use_cat
+ if ( max < max_age(j) ) max = max_age(j)
+ end do
+
+ ! write for max age every value, fill not existing values with 0
+ do i=1,max
+ spinny(8) = 0.
+ do j = 1,nr_use_cat
+ if ( i <= max_age(j) ) then
+ spinny(j) = use_categories(j)%spinup(i)
+ else
+ spinny(j) = 0.
+ end if
+ end do
+ if (i == 1) then
+ spinny(8) = landfill_spinup
+ end if
+ write(unit, '(I9,8(F15.3) )',iostat=ios) &
+ i, &
+ spinny(1), &
+ spinny(2), &
+ spinny(3), &
+ spinny(4), &
+ spinny(5), &
+ spinny(6), &
+ spinny(7), &
+ spinny(8)
+
+ end do
+
+end subroutine write_spinup
+
+
diff --git a/source_code/version2.2_windows/year_ini.f b/source_code/version2.2_windows/year_ini.f
new file mode 100755
index 0000000000000000000000000000000000000000..25a9b363568d452a6de8ddf0b929bf248f8ffeb8
--- /dev/null
+++ b/source_code/version2.2_windows/year_ini.f
@@ -0,0 +1,1122 @@
+!*****************************************************************!
+!* *!
+!* 4C (FORESEE) Simulation Model *!
+!* *!
+!* *!
+!* Subroutines for: *!
+!* Initialization and calculation *!
+!* per year *!
+!* *!
+!* - YEAR_INI: Initialization (yearly) *!
+!* - REDN_INI: Calculation of RedN *!
+!* - REDN_CALC: Calculation of RedN *!
+!* - SAVE_COHORT: Save intialisation of cohorts (optional) *!
+!* - RESTORE_COHORT: Restore intialisation of cohorts (optional) *!
+!* - S_YEAR: Calculation of yearly values *!
+!* - FIRE_YEAR: Calculation of yearly fire indices *!
+!* - T_INDICES: Calculation of the nun temperature 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 *!
+!* *!
+!*****************************************************************!
+
+SUBROUTINE year_ini
+
+!initialization of several variables for yearly calculation and output
+
+use data_biodiv
+use data_climate
+use data_depo
+use data_evapo
+use data_inter
+use data_par
+use data_out
+use data_simul
+use data_soil
+use data_soil_cn
+use data_species
+use data_stand
+use data_manag
+
+implicit none
+
+integer i, j, k, helpnl
+real help, hCbc
+real thickh, thicki, thicki1, &
+ pvi , &
+ fcapi , &
+ wilti , &
+ sandi , &
+ clayi , &
+ silti , &
+ humi , &
+ nfki , &
+ densi , &
+ skeli , &
+ pHi , wati, watsi, wlami, &
+ Copmi , Chumi, &
+ Nopmi, Nhumi, NH4i, NO3i, &
+ voli, vol_bc
+real, dimension (nlay) :: xfcap, xwiltp, xpv
+
+DOUBLE PRECISION :: co2_annual
+
+time_cur = time_cur+1
+call pheno_ini
+
+flag_vegper = 0
+flag_tveg = 0
+iday_vegper = 0
+
+med_air = 0.
+sum_prec = 0.
+med_rad = 0.
+sum_prec_ms = 0.
+sum_prec_mj = 0.
+med_air_ms = 0.
+med_air_mj = 0.
+gdday = 0.
+days_summer = 0
+days_hot = 0
+days_ice = 0
+days_dry = 0
+days_hrain = 0
+days_rain = 0
+days_rain_mj= 0
+days_snow = 0
+days_wof = 0
+int_cum_can = 0.
+int_cum_sveg= 0.
+perc_cum = 0.
+aet_cum = 0.
+aet_mon = 0.
+aet_week = 0.
+pet_cum = 0.
+pet_mon = 0.
+pet_week = 0.
+Rnet_cum = 0.
+perc_mon = 0.
+perc_week = 0.
+dew_cum = 0.
+tra_tr_cum = 0.
+tra_sv_cum = 0.
+wupt_r_c = 0.
+wupt_e_c = 0.
+wupt_cum = 0.
+s_drought = 0
+N_min = 0.
+Nleach_c = 0.
+Nupt = 0.
+Nupt_c = 0.
+Ndep_cum = 0.
+resps_c = 0.
+resps_mon = 0.
+resps_week = 0.
+totfol_lit = 0.
+totfol_lit_tree = 0.
+totfrt_lit = 0.
+totfrt_lit_tree = 0.
+tottb_lit = 0.
+totcrt_lit = 0.
+totstem_lit = 0.
+C_opm_fol = 0.
+C_opm_frt = 0.
+C_opm_crt = 0.
+C_opm_tb = 0.
+N_opm_fol = 0.
+N_opm_frt = 0.
+N_opm_crt = 0.
+N_opm_tb = 0.
+C_opmfrt = 0.
+C_opmcrt = 0.
+N_opmfrt = 0.
+N_opmcrt = 0.
+
+diam_class_mvol = 0.
+diam_classm = 0.
+
+!Addition of biochar
+if (flag_bc .gt. 0) then
+ C_bc_tot = 0.
+ N_bc_tot = 0.
+ if (y_bc(y_bc_n) .eq. time) then
+ vol_bc = C_bc_appl(y_bc_n) * kgha_in_gm2 / dens_bc(y_bc_n) ! cm³
+ help = (cpart_bc(y_bc_n)*0.01) * C_bc_appl(y_bc_n) * kgha_in_gm2
+ C_bc_appl(y_bc_n) = help
+ help = help / cnv_bc(y_bc_n)
+ N_bc_appl(y_bc_n) = help
+ if (bc_appl_lay(y_bc_n) .gt. 0) then
+ ! Ploughing until the layer of helpnr (meaning all layers are mixed to this depth)
+ helpnl = bc_appl_lay(y_bc_n)
+ thicki = 0.
+ voli = 0.
+ pvi = 0.
+ fcapi = 0.
+ wilti = 0.
+ sandi = 0.
+ clayi = 0.
+ densi = 0.
+ skeli = 0.
+ pHi = 0.
+ wati = 0.
+ watsi = 0.
+ wlami = 0.
+ Copmi = 0.
+ Nopmi = 0.
+ Chumi = 0.
+ Nhumi = 0.
+ NH4i = 0.
+ NO3i = 0.
+ do i=1, helpnl
+ thicki = thicki + thick(i)
+ enddo
+ ! all layers are proportionally combined
+ do i=1, helpnl
+ thickh = thick(i) / thicki
+ sandi = sandi + thickh * sandv(i)
+ clayi = clayi + thickh * clayv(i)
+ pvi = pvi + thickh * pv_v(i)
+ skeli = skeli + thickh * skelv(i)
+ densi = densi + thickh * dens(i)
+ fcapi = fcapi + thickh * f_cap_v(i)
+ wilti = wilti + thickh * wilt_p_v(i)
+ wlami = wlami + thickh * wlam(i)
+ wati = wati + thickh * watvol(i)
+ watsi = watsi + wats(i)
+ Copmi = Copmi + C_opm(i)
+ Nopmi = Nopmi + N_opm(i)
+ Chumi = Chumi + C_hum(i)
+ Nhumi = Nhumi + N_hum(i)
+ NH4i = NH4i + NH4(i)
+ NO3i = NO3i + NO3(i)
+ enddo
+ ! new soil parameter calculation including biochar
+ voli = thicki * 10000. ! cm³
+ help = voli + vol_bc
+ densi = (voli * densi + vol_bc * dens_bc(y_bc_n)) / help ! weighted mean or bulk density
+ voli = help
+ thickh = voli / 10000.
+
+ if (thickh .gt. depth(helpnl)) then
+ ! new soil profil calculated
+ thicki1 = thickh - depth(helpnl)
+ thick(1) = thicki1
+ depth(1) = thicki1
+ mid(1) = 0.5 * thicki1
+ do i = 2, nlay ! intercepted in last layer
+ depth(i) = depth(i-1) + thick(i)
+ mid(i) = mid(i) + thick(i)
+ enddo
+ else
+ thicki1 = thick(1)
+ endif
+
+ do i = 1, helpnl
+ thickh = thick(i)/depth(helpnl)
+ vol(i) = thick(i) * 10000.
+ sandv(i) = sandi
+ clayv(i) = clayi
+ siltv(i) = 1. - sandi - clayi
+ pv_v(i) = pvi
+ dens(i) = densi
+ skelv(i) = skeli
+ f_cap_v(i) = fcapi
+ wilt_p_v(i) = wilti
+ wlam(i) = wlami
+ watvol(i) = wati
+ wats(i) = watsi * thickh
+ C_opm(i) = Copmi * thickh
+ N_opm(i) = Nopmi * thickh
+ C_hum(i) = Chumi * thickh
+ N_hum(i) = Nhumi * thickh
+ NH4(i) = NH4i * thickh
+ NO3(i) = NO3i * thickh
+ dmass(i) = vol(i) * dens(i)
+ humusv(i) = C_hum(i) / (dmass(i) * cpart)
+ C_bc(i) = C_bc_appl(y_bc_n) * thickh
+ N_bc(i) = N_bc_appl(y_bc_n) * thickh
+ enddo
+
+ skelfact = 1.
+ pv = skelfact * pv_v * thick * 0.1 ! mm
+ wilt_p = skelfact * wilt_p_v * thick * 0.1 ! mm
+ field_cap = skelfact * f_cap_v * thick * 0.1 ! mm
+ thick_1 = thick(1)
+ rmass1 = dmass(1) - (C_hum(1) + C_opm(1)) / cpart ! adjustment amount of first layer
+
+ ! calculation of surcharge of biochar
+ do i = 1, nlay
+ if (C_bc(i) .gt. 0.) then
+ fcapi = f_cap_v(i)
+ clayi = clayv(i)
+ silti = siltv(i)
+ humi = humusv(i)*100.
+ hcbc = C_bc(i)*100.*100. / (cpart_bc(y_bc_n) * dmass(i))
+ if ((clayi .le. 0.17) .and. (silti .le. 0.5)) then ! sand
+ fcapi = 0.0619 * hcbc
+ wilti = 0.0375 * hcbc
+ nfki = 7.0
+ elseif ((clayi .le. 0.45) .and. (silti .gt. 0.17)) then ! loam
+ fcapi = 0.015 * hcbc
+ wilti = 0.0157 * hcbc
+ nfki = 10.
+ else ! clay
+ fcapi = -0.0109 * hcbc
+ wilti = -0.0318 * hcbc
+ nfki = 16.
+ endif
+ xfcap(i) = xfcap(i) + fcapi
+ xwiltp(i) = xwiltp(i) + wilti
+
+ endif
+
+ enddo
+
+ else
+ C_bc(1) = C_bc(1) + C_bc_appl(y_bc_n)
+ N_bc(1) = N_bc(1) + N_bc_appl(y_bc_n)
+ endif
+
+ ! write into soil.ini
+ WRITE (unit_soil,*)
+ WRITE (unit_soil,'(A,I3,A,I4)') 'Adding of biochar up to layer',helpnl,' at the begin of year:', time
+ WRITE (unit_soil,'(26A)') 'Layer',' Depth(cm)',' F-cap(mm)',' F-cap(Vol%)',' Wiltp(mm)', &
+ ' Wiltp(Vol%)',' Pore vol.',' Skel.(Vol%)',' Density',' Spheat',' pH',' Wlam', &
+ ' Water(mm)',' Water(Vol%)',' Soil-temp.',' C_opm g/m2', &
+ ' C_hum g/m2',' N_opm g/m2',' N_hum g/m2',' NH4 g/m2',' NO3 g/m2',' humus part',' d_mass g/m2', ' Clay',' Silt',' Sand'
+ do i = 1,nlay
+ WRITE (unit_soil,'(I5,2F10.2,3F12.2,F10.2,F12.2,4F8.2,F10.2,F12.2, 5F11.2,2F9.4,2E12.4, 3F6.1)') i,depth(i),field_cap(i),f_cap_v(i),wilt_p(i), &
+ wilt_p_v(i),pv_v(i), skelv(i)*100., dens(i),spheat(i),phv(i),wlam(i), &
+ wats(i),watvol(i),temps(i),c_opm(i),c_hum(i),n_opm(i), n_hum(i),nh4(i),no3(i),humusv(i),dmass(i), clayv(i)*100., siltv(i)*100., sandv(i)*100.
+ end do
+
+ if (y_bc_n .lt. n_appl_bc) y_bc_n = y_bc_n + 1
+ endif
+endif ! flag_bc Addition of biochar
+
+sumGPP = 0.
+sumTER = 0.
+GPP_mon = 0.
+GPP_week = 0.
+NEE_mon = 0.
+NPP_mon = 0.
+NPP_week = 0.
+TER_mon = 0.
+TER_week = 0.
+
+! save of last december value for calculation of seasons
+aet_dec = aet_mon(12)
+temp_dec = temp_mon(12)
+prec_dec = prec_mon(12)
+rad_dec = rad_mon(12)
+hum_dec = hum_mon(12)
+GPP_dec = GPP_mon(12)
+NEE_dec = NEE_mon(12)
+NPP_dec = NPP_mon(12)
+TER_dec = TER_mon(12)
+
+temp_mon = 0.
+temp_week = 0.
+prec_mon = 0.
+prec_week = 0.
+tempmean_mo_a = 0.
+
+rad_mon = 0.
+hum_mon = 0.
+
+flag_cumNPP = 1
+
+ if (flag_wurz .eq. 4 .or. flag_wurz .eq. 6) then
+ do k=1,nspecies
+ svar(k)%Smean(1:nlay)=0.
+ enddo
+ endif
+
+sumvsdead = 0.
+sumvsab = 0.
+sumvsab_m3 = 0.
+
+do i = 1,nspec_tree
+ do j = 1, lit_year-1
+ ! shift of delayed litter
+ dead_wood(i)%C_tb(j) = dead_wood(i)%C_tb(j+1)
+ dead_wood(i)%N_tb(j) = dead_wood(i)%N_tb(j+1)
+ dead_wood(i)%C_stem(j) = dead_wood(i)%C_stem(j+1)
+ dead_wood(i)%C_stem(j) = dead_wood(i)%C_stem(j+1)
+ enddo ! j (lit_year)
+ dead_wood(i)%C_tb(lit_year) = 0.
+ dead_wood(i)%N_tb(lit_year) = 0.
+ dead_wood(i)%C_stem(lit_year) = 0.
+ dead_wood(i)%C_stem(lit_year) = 0.
+enddo ! i (nspec_tree)
+
+monrec=(/31,28,31,30,31,30,31,31,30,31,30,31/)
+
+if (recs(time).eq.366) monrec(2)=29
+
+photsum =0.
+npppotsum =0.
+nppsum =0.
+resosum =0.
+lightsum =0.
+nee =0.
+precsum =0.
+gppsum =0.
+tersum =0.
+resautsum =0.
+tempmean =0.
+tempmeanh = 0.
+med_air_cm = 0.
+med_air_wm = 0.
+laimax =0.
+drIndAl =0.
+gp_can_mean =0.
+gp_can_min =0.
+gp_can_max =0.
+aet_sum = 0.
+pet_sum = 0.
+
+ind_arid_an = 0.
+ind_lang_an = 0.
+ind_cout_an = 0.
+ind_wiss_an = 0.
+ind_mart_an = 0.
+ind_mart_vp = 0.
+ind_emb =0.
+ind_weck=0.
+ind_reich =0.
+con_gor = 0.
+con_cur = 0.
+con_con = 0.
+cwb_an = 0.
+ind_bud = 0.
+ntindex = 0.
+
+! species variables
+svar%sumvsab = 0.
+svar%sumvsdead = 0.
+svar%drIndAl = 0.
+svar%RedNm = 0.
+svar%Ndem = 0.
+svar%Nupt = 0.
+svar%Ndemp = 0.
+svar%Nuptp = 0.
+
+! fire index
+Ndayshot = 0
+Psum_FP = 0.
+fire(1)%frequ = 0
+fire(2)%frequ = 0
+fire(3)%frequ = 0
+fire_indi = 0.
+fire_indi_max = 0.
+fire_indi_day = 0
+fd_fire_indw = 0
+day_nest = 0
+p_nest = 0.0
+
+! species variable
+
+spar%flag_endbb = 0.
+
+if (flag_multi .eq. 6) then
+ if (flag_sens .eq. 0) then
+ ! save cohorts for the first time
+ call save_cohort
+ flag_sens = 1
+ else
+ call restore_cohort
+ endif
+endif
+
+
+! initialize this year's summation variables of all cohorts to zero
+ flag_tree = .TRUE.
+ coh_ident_max = 0
+ zeig => pt%first
+ DO WHILE (ASSOCIATED(zeig))
+
+ ! assimilation and NPP variables
+ zeig%coh%NPP = 0.
+ zeig%coh%NPPpool = 0.
+ zeig%coh%netAss = 0.
+ zeig%coh%grossass = 0.
+ zeig%coh%maintres = 0.
+ zeig%coh%t_leaf = 0.
+ ! litter production variables
+ zeig%coh%litC_fol = 0.; zeig%coh%litN_fol = 0.
+ zeig%coh%litC_frt = 0.; zeig%coh%litN_frt = 0.
+ zeig%coh%litC_stem = 0.; zeig%coh%litN_stem = 0.
+ zeig%coh%litC_tb = 0.; zeig%coh%litN_tb = 0.
+ zeig%coh%litC_crt = 0.; zeig%coh%litN_crt = 0.
+
+ zeig%coh%litC_fold = 0.; zeig%coh%litN_fold = 0.
+ zeig%coh%litC_frtd = 0.; zeig%coh%litN_frtd = 0.
+ zeig%coh%litC_tbcd = 0.; zeig%coh%litN_tbcd = 0.
+ zeig%coh%Nuptc_c = 0.
+ zeig%coh%Ndemc_c = 0.
+ zeig%coh%watuptc = 0.
+
+ ! annual drought index variables
+ zeig%coh%drIndAl = 0.; zeig%coh%nDaysGr = 0.
+ zeig%coh%fl_sap = 1
+
+ if ((zeig%coh%height .lt. thr_height .and. zeig%coh%species .le. nspec_tree) &
+ .and. (flag_reg .eq. 15 .or. flag_reg .eq. 2 .or. flag_reg .eq. 18)) then
+ zeig%coh%fl_sap = 0
+
+ end if
+ coh_ident_max = max(coh_ident_max, zeig%coh%ident)
+
+! number of tended trees
+ zeig%coh%ntreet = 0
+ zeig => zeig%next
+ END DO
+
+ zeig => pt%first
+ DO WHILE (ASSOCIATED(zeig))
+
+ if (zeig%coh%fl_sap.eq.0) then
+ flag_tree = .FALSE.
+ flag_sprout=1
+ exit
+ end if
+ zeig => zeig%next
+ END DO
+
+
+! Assisting field allocation; Hilfsfelder allok.
+if (anz_coh > 0) then
+ allocate (xwatupt(anz_coh, nlay))
+ xwatupt = 0.
+ allocate (xNupt(anz_coh, nlay))
+ xNupt = 0.
+ if (flag_wurz .eq. 6) then
+ allocate (wat_left(anz_coh))
+ wat_left=0.
+ endif
+endif
+
+! As cohort variable defined and initialised (not annual allocation); Als Kohorten-Var. vereinbart und dort initialisiert (nicht jaehrl. allok.!)
+! wat_mg is the watter absorption per cohort at flag_wred=9; wat_mg ist wasseraufnahme pro cohorte bei flag_wred=9
+
+if (anz_tree .gt. 0) call root_distr
+
+! calculation of additions for water capacities
+ call hum_add(xfcap, xwiltp, xpv)
+
+ f_cap_v = fcaph + xfcap ! vol%
+ wilt_p_v = wiltph + xwiltp ! vol%
+ pv_v = pvh + xpv ! vol%
+
+ pv = skelfact * pv_v * thick * 0.1 ! mm
+ wilt_p = skelfact * wilt_p_v * thick * 0.1 ! mm
+ field_cap = skelfact * f_cap_v * thick * 0.1 ! mm
+
+do i=1,nlay
+ if ((f_cap_v(i) < 0.) .or. (wilt_p_v(i) < 0.) .or. (pv_v(i) < 0.) .or. (pv(i) < 0.) .or. (wilt_p(i) < 0.) &
+ .or.(field_cap(i) < 0.) .or. (xfcap(i) < 0.) .or. (xwiltp(i) < 0.)) then
+ continue
+ endif
+enddo
+
+! output of new soil profile after recalculation of fcap etc.
+if (flag_bc_add .gt. 0) then
+ WRITE (unit_soil,'(26A)') 'Layer',' Depth(cm)',' F-cap(mm)',' F-cap(Vol%)',' Wiltp(mm)', &
+ ' Wiltp(Vol%)',' Pore vol.',' Skel.(Vol%)',' Density',' Spheat',' pH',' Wlam', &
+ ' Water(mm)',' Water(Vol%)',' Soil-temp.',' C_opm g/m2', &
+ ' C_hum g/m2',' N_opm g/m2',' N_hum g/m2',' NH4 g/m2',' NO3 g/m2',' humus part',' d_mass g/m2', ' Clay',' Silt',' Sand'
+ do i = 1,nlay
+ WRITE (unit_soil,'(I5,2F10.2,3F12.2,F10.2,F12.2,4F8.2,F10.2,F12.2, 5F11.2,2F9.4,2E12.4, 3F6.1)') i,depth(i),field_cap(i),f_cap_v(i),wilt_p(i), &
+ wilt_p_v(i),pv_v(i), skelv(i)*100., dens(i),spheat(i),phv(i),wlam(i), &
+ wats(i),watvol(i),temps(i),c_opm(i),c_hum(i),n_opm(i), n_hum(i),nh4(i),no3(i),humusv(i),dmass(i), clayv(i)*100., siltv(i)*100., sandv(i)*100.
+ end do
+ flag_bc_add = 0
+endif
+
+! assigne CO2; CO2 belegen
+ IF(flag_co2 > 0 .and. flag_co2 < 250) then
+ co2 = co2_annual(time_cur)
+ end if
+
+end subroutine year_ini
+
+!**************************************************************
+
+SUBROUTINE RedN_ini
+use data_soil_cn
+use data_simul
+use data_stand
+use data_species
+implicit none
+INTEGER i
+REAL cnv_tot
+
+
+ cnv_tot=C_hum_tot/N_hum_tot
+
+ do i=1,nspecies
+
+ if (svar(i)%RedN .lt. 0.) then
+ IF(cnv_tot.GT.13.2) THEN
+ svar(i)%RedN = (1.-(120.-480./(cnv_tot-9.2))*spar(i)%Nresp) !**0.7
+ IF(svar(i)%RedN.LT.0) svar(i)%RedN = 0.
+ ELSE
+ svar(i)%RedN = 1.
+ ENDIF
+ endif
+ IF(flag_limi==0.OR.flag_limi==1) svar(i)%RedN = 1.
+
+ END DO
+
+end subroutine RedN_ini
+
+!**************************************************************
+
+SUBROUTINE RedN_calc
+
+use data_par
+use data_soil_cn
+use data_simul
+use data_stand
+use data_species
+
+implicit none
+
+integer i,j
+real, dimension(20) :: reda, redb
+
+do i = 1, 20
+ reda(i) = 0.019
+ redb(i) = 10. ! min. N-availability necessary for growth in kg/ha; minimale N-Verfuegbarkeit kg/ha, die zum Wachsen benoetigt wird
+enddo
+
+! after/nach Kopp & Schwanecke (1994)
+ do j=1,anrspec
+ i = nrspec(j)
+
+ if ((flag_limi .eq. 15) .and. (i .ne. 10)) exit ! only use flag_limi=14 for Douglas fir; für flag_limi=14 nur für Douglasie rechnen
+ if(svar(i)%Ndem .gt. 0) then
+ call RedN_Ndem(i)
+ else
+ if(svar(i)%RedN .le. 0.) svar(i)%RedN = 1.
+ endif
+
+ END DO
+
+end subroutine RedN_calc
+
+!******************************************************************************
+
+subroutine RedN_Ndem(ispec)
+
+!Adaptation for Ndem and Nupt; Adaption fuer Ndem und Nupt
+
+use data_par
+use data_soil_cn
+use data_simul
+use data_stand
+use data_species
+
+implicit none
+
+integer ispec ! species number
+real reda, redb, hn
+
+! If total demand is satisfied almost no limitation; Wenn gesamter Bedarf befriedigt wird, nahezu keine Limitierung (RedN=0.99)
+! Koefficient reda calculated in dependency of Ndem; Koeff. reda wird in Abh. von Ndem berechnet
+
+ reda = log(0.01) / ( - gm2_in_kgha*svar(ispec)%Ndem)
+ redb = 0.5
+
+if (svar(ispec)%Nupt .lt. 1.)then
+ if (svar(ispec)%Ndem .lt. 1) then
+ hn = gm2_in_kgha * svar(ispec)%Nupt
+ else
+ hn = gm2_in_kgha * N_min
+ endif
+else
+ hn = gm2_in_kgha * svar(ispec)%Nupt
+endif
+
+select case (ispec)
+case (3)
+ reda = 0.5 * reda
+ redb = 0.3
+
+case (10)
+ reda = 2. * reda
+
+end select
+
+svar(ispec)%RedN = 1.- exp(-reda * hn - redb)
+if (svar(ispec)%RedN .le. 0.) then
+ continue
+ svar(ispec)%RedN = 0.1
+endif
+end subroutine RedN_Ndem
+
+
+!******************************************************************************
+
+subroutine RedN_Ndem1(ispec, mini_N)
+
+!Adaptation for Ndem and Nupt after Bugmann/Lindner; Adaption fuer Ndem und Nupt nach Bugmann/Lindner
+
+use data_par
+use data_soil_cn
+use data_simul
+use data_stand
+use data_species
+
+implicit none
+
+integer ispec ! species number
+real mini_N, reda
+
+mini_N = 0. ! Assumption: no growth if no N is absorbed, which means RedN=0.001; Ann.: kein Wachstum, wenn kein N aufgenommen wird, d.h. RedN = 0.001
+! If total demand is satisfied almost no limitation; Wenn gesamter Bedarf befriedigt wird, nahezu keine Limitierung (RedN=0.99)
+! Koefficient reda calculated in dependency of Ndem; Koeff. reda wird in Abh. von Ndem berechnet
+
+if((gm2_in_kgha*svar(ispec)%Ndem).gt. mini_N) then
+ reda = log(0.01) / (mini_N - gm2_in_kgha*svar(ispec)%Ndem) ! Assumption/Ann.: RedN=0.99 bei Optimum
+else
+ reda = log(0.01) / (mini_N - 200) ! Assumption/Ann.: bei 200 kg N/ha RedN=0.99, d.h. optimal
+endif
+
+svar(ispec)%RedN = 1.- exp(-reda * (gm2_in_kgha*svar(ispec)%Nupt - mini_N))
+if (svar(ispec)%RedN .le. 0.) then
+ continue
+ svar(ispec)%RedN = 0.001
+endif
+ write (12345, '(F10.3)', advance='no') svar(ispec)%RedN
+end subroutine RedN_Ndem1
+
+!******************************************************************************
+
+subroutine save_cohort
+
+use data_soil
+use data_stand
+
+implicit none
+
+type(coh_obj), pointer :: p
+
+integer i
+
+anz_coh_save = anz_coh
+allocate (coh_save(anz_coh))
+zeig => pt%first
+i = 1
+
+do while (associated(zeig))
+ coh_save(i) = zeig%coh
+ i = i+1
+ zeig => zeig%next
+end do
+
+end subroutine save_cohort
+
+!******************************************************************************
+
+subroutine restore_cohort
+
+use data_soil
+use data_stand
+
+implicit none
+
+integer i
+
+ zeig => pt%first
+ do while (associated(zeig))
+ pt%first => zeig%next
+ deallocate(zeig)
+ zeig => pt%first
+ end do
+
+ allocate(pt%first)
+ pt%first%coh = coh_save(anz_coh_save)
+ nullify(pt%first%next)
+
+ do i = anz_coh_save-1,1, -1
+ allocate(zeig)
+ zeig%coh = coh_save(i)
+ zeig%next => pt%first
+ pt%first => zeig
+ end do
+
+end subroutine restore_cohort
+
+!******************************************************************************
+
+SUBROUTINE s_year
+
+! yearly quantities
+
+use data_climate
+use data_depo
+use data_evapo
+use data_inter
+use data_out
+use data_par
+use data_simul
+use data_site
+use data_soil
+use data_soil_cn
+use data_species
+use data_stand
+
+implicit none
+
+integer i,j
+real help, helpd, h1, h2, h3
+real temp_ampl ! temperature amplitude between warmest and coldest month
+logical l40, l80
+real, dimension (nlay) :: xfcap, xwiltp, xpv
+
+if (time .gt. 0) then
+ ! climate quantites
+
+ med_rad = med_rad/recs(time)
+ med_wind = med_wind / recs(time)
+ med_air = med_air/recs(time)
+ med_air_all = med_air_all + med_air
+ sum_prec_all = sum_prec_all + sum_prec
+
+ med_rad_all = med_rad_all + med_rad
+
+ med_air_ms = med_air_ms/153
+ med_air_mj = med_air_mj/92
+
+ ! stress index
+ mean_drIndAl = mean_drIndAl + drIndAl
+
+ ! stomatal conductance of the canopy
+ gp_can_mean = gp_can_mean / recs(time)
+
+! climate indices
+ if(pet_cum.ne.0.) then
+ ind_arid_an = sum_prec/pet_cum
+ else
+ ind_arid_an =0.
+ end if
+ cwb_an = sum_prec-pet_cum
+ cwb_an_m = cwb_an_m + cwb_an
+ if(med_air.ne. 0) then
+ ind_lang_an = sum_prec/med_air
+ else
+ ind_lang_an = 0
+ end if
+ temp_ampl = med_air_wm - med_air_cm
+
+ ind_cout_an = ind_cout_an/12
+ ind_wiss_an = ind_wiss_an/12
+ ind_mart_vp = sum_prec_ms/(med_air_ms+10)
+ if(med_air.lt. -9.9) then
+ ind_mart_an = 100
+ else
+ ind_mart_an = sum_prec/(med_air+10)
+ end if
+ ind_weck = sum_prec_mj*days_rain_mj*(days_wof-60)/((med_air_mj+10)*92)/100
+ h2 = sum_prec *days_rain
+ h3 = 180*(med_air +10)
+ ind_reich = h2/h3
+ help = med_air_wm*med_air_wm - med_air_cm*med_air_cm
+ if(help.ne.0) ind_emb = sum_prec*100/help
+! Budyko
+ ind_bud = rnet_cum*10/recs(time) ! Radiation/Strahlung in kJ/m²
+ if(sum_prec.ne.0) then
+ ind_bud = ind_bud/(sum_prec*2.51)
+ end if
+
+
+! continental indices
+ h1 = (lat)/90*pi*0.5
+ if (lat.ne.0) then
+ if(temp_ampl.gt.0) con_gor = 1.7*temp_ampl/sin(h1) -20.4
+ con_cur = temp_ampl/(1. + lat/3)
+ h1 = (lat+10)/90*pi*0.5
+ if(temp_ampl .gt. 0.) con_con = 1.7*temp_ampl/sin(h1) - 14
+ end if
+
+ ind_arid_an_m = ind_arid_an_m + ind_arid_an
+ ind_lang_an_m = ind_lang_an_m + ind_lang_an
+ ind_cout_an_m = ind_cout_an_m + ind_cout_an
+ ind_wiss_an_m = ind_wiss_an_m + ind_wiss_an
+ ind_mart_vp_m = ind_mart_vp_m + ind_mart_vp
+ ind_mart_an_m = ind_mart_an_m + ind_mart_an
+ ind_weck_m = ind_weck_m + ind_weck
+ ind_reich_m = ind_reich_m + ind_reich
+ ind_emb_m = ind_emb_m + ind_emb
+ con_gor_m = con_gor_m +con_gor
+ con_cur_m = con_cur_m + con_cur
+ con_con_m = con_con_m + con_con
+ ind_bud_m = ind_bud_m + ind_bud
+ ind_shc_m = ind_shc_m + ind_shc
+endif
+
+! water quantites
+wat_tot = SUM(wats)
+perc_m = perc_m + perc_cum
+wupt_r_m = wupt_r_m + wupt_r_c
+interc_m_can = interc_m_can + int_cum_can
+interc_m_sveg= interc_m_sveg + int_cum_sveg
+aet_m = aet_m + aet_cum
+pet_m = pet_m + pet_cum
+dew_m = dew_m + dew_cum
+
+! C/N quantites
+N_min_m = N_min_m + N_min
+Nupt_m = Nupt_m + Nupt_c
+Nleach_m = Nleach_m + Nleach_c
+resps_c_m = resps_c_m + resps_c
+autresp_m = autresp_m + autresp
+Ndep_cum_all = Ndep_cum_all + Ndep_cum
+
+! C content up to 40, 80 and 100cm depth
+l40 = .true.
+l80 = .true.
+C_hum_1 = C_hum(1)
+C_tot_1 = C_hum(1) + C_opm(1)
+C_hum_40 = C_hum_1
+C_tot_40 = C_tot_1
+C_hum_80 = C_hum_40
+C_tot_80 = C_tot_40
+C_hum_100 = C_hum_40
+C_tot_100 = C_tot_40
+do i = 2, nlay
+ if ((depth(i)-depth(1)) .le. 40.) then
+ C_hum_40 = C_hum_40 + C_hum(i)
+ C_tot_40 = C_tot_40 + C_hum(i) + C_opm(i)
+ C_hum_80 = C_hum_40
+ C_tot_80 = C_tot_40
+ C_hum_100 = C_hum_40
+ C_tot_100 = C_tot_40
+ else
+ if (l40) then
+ helpd = (40. - (depth(i-1)-depth(1))) / thick(i)
+ C_hum_40 = C_hum_40 + C_hum(i)*helpd
+ C_tot_40 = C_tot_40 + (C_hum(i) + C_opm(i))*helpd
+ l40 = .false.
+ endif
+ if ((depth(i)-depth(1)) .le. 80.) then
+ C_hum_80 = C_hum_80 + C_hum(i)
+ C_tot_80 = C_tot_80 + C_hum(i) + C_opm(i)
+ C_hum_100 = C_hum_80
+ C_tot_100 = C_tot_80
+ else
+ if (l80) then
+ helpd = (80. - (depth(i-1)-depth(1))) / thick(i)
+ C_hum_80 = C_hum_80 + C_hum(i)*helpd
+ C_tot_80 = C_tot_80 + (C_hum(i) + C_opm(i))*helpd
+ l80 = .false.
+ endif
+ if ((depth(i)-depth(1)) .le. 100.) then
+ C_hum_100 = C_hum_100 + C_hum(i)
+ C_tot_100 = C_tot_100 + C_hum(i) + C_opm(i)
+ else
+ helpd = (100. - (depth(i-1)-depth(1))) / thick(i)
+ C_hum_100 = C_hum_100 + C_hum(i)*helpd
+ C_tot_100 = C_tot_100 + (C_hum(i) + C_opm(i))*helpd
+ exit
+ endif
+ endif
+ endif
+enddo
+C_hum_1 = C_hum_1 * gm2_in_kgha * 0.001 ! g/m2 --> t/ha
+C_tot_1 = C_tot_1 * gm2_in_kgha * 0.001 ! g/m2 --> t/ha
+C_hum_40 = C_hum_40 * gm2_in_kgha * 0.001 ! g/m2 --> t/ha
+C_tot_40 = C_tot_40 * gm2_in_kgha * 0.001 ! g/m2 --> t/ha
+C_hum_80 = C_hum_80 * gm2_in_kgha * 0.001 ! g/m2 --> t/ha
+C_tot_80 = C_tot_80 * gm2_in_kgha * 0.001 ! g/m2 --> t/ha
+C_hum_100 = C_hum_100 * gm2_in_kgha * 0.001 ! g/m2 --> t/ha
+C_tot_100 = C_tot_100 * gm2_in_kgha * 0.001 ! g/m2 --> t/ha
+
+! total anorganic N
+N_an_tot = SUM(NH4) + SUM(NO3)
+
+! N and C content of total humus
+N_hum_tot = SUM(N_hum)
+C_hum_tot = SUM(C_hum)
+
+! N- and C-content befor litter fall
+N_tot = SUM(N_opm) + N_hum_tot + N_an_tot
+C_tot = SUM(C_opm) + C_hum_tot
+
+! N- and C-content of total biochar
+if (flag_bc .gt. 0) then
+ C_bc_tot = SUM(C_bc)
+ N_bc_tot = SUM(N_bc)
+endif
+
+! Uptake per tree (conv. from cohort and m2)
+ zeig => pt%first
+ do while (associated(zeig))
+ if (zeig%coh%watuptc .ge. 1E-8) then
+ do j = 1,nlay
+ zeig%coh%rooteff(j) = zeig%coh%rooteff(j) / (zeig%coh%watuptc * thick(j))
+ enddo
+ endif
+ zeig => zeig%next
+
+ enddo
+
+! Total foliage and fine root OPM
+C_opm_stem = 0.
+do i=1,anrspec
+ j = nrspec(i)
+ C_opm_fol = C_opm_fol + slit(j)%C_opm_fol
+ C_opm_frt = C_opm_frt + SUM(slit(j)%C_opm_frt)
+ C_opm_crt = C_opm_crt + SUM(slit(j)%C_opm_crt)
+ C_opm_tb = C_opm_tb + slit(j)%C_opm_tb
+ C_opm_stem = C_opm_stem + slit(j)%C_opm_stem
+
+ select case (flag_limi)
+ case (4,5,6,7,8,9)
+ if(svar(j)%sum_nTreeA .ne. 0 .or. svar(j)%sum_nTreeD .ne. 0) then
+ if(j.le.nspec_tree) then
+ svar(j)%RedNm = svar(j)%RedNm / (((svar(j)%sum_nTreeA+svar(j)%sum_nTreeD)*kpatchsize/10000.) * (spar(j)%end_bb-svar(j)%daybb))
+ else
+ svar(j)%RedNm = svar(j)%RedNm / (spar(j)%end_bb-svar(j)%daybb)
+ end if
+ else
+ svar(j)%RedN = 0.
+ end if
+
+ case default
+ if (time .gt. 0) svar(j)%RedNm = svar(j)%RedNm / recs(time)
+
+ end select
+
+ if (time .gt. 0) then
+ if (svar(j)%RedN .gt. 0. .and. j .le. nspec_tree) then
+ RedN_mean = RedN_mean + svar(j)%RedNm
+ anz_RedN = anz_RedN + 1
+ endif
+ endif
+
+enddo
+
+if (flag_hum .eq. 1) then
+ ! Calculation of the new depth of cover layer; Berechnung der neuen Dicke fuer die Auflage
+ help = (C_opm(1) + C_hum(1)) / cpart ! Masse (g
+ thick(1) = (rmass1 + help) / (dens(1)*10000.)
+ if (thick(1) .lt. 0.) then
+ continue
+ endif
+ help = thick(1)-thick_1
+ if (ABS(help) .ge. 1.)then ! when first layer grows soil profile is shifted lower; bei Wachsen der 1.Schicht Profil nach unten verschieben
+ helpd = depth(1) + help
+ depth(1) = depth(1) + help
+ mid(1) = 0.5 * depth(1)
+ do i=2, nlay-1 ! intercepted in last layer; wird in letzter Schicht aufgefangen
+ depth(i) = depth(i) + help
+ mid(i) = mid(i) + help
+ enddo
+ if (time .gt.0 .and. .not.flag_mult8910) then
+ ! write/schreibe in soil.ini
+ WRITE (unit_soil,*)
+ WRITE (unit_soil,'(A,I4)') 'Increase of first layer in year: ', time
+ WRITE (unit_soil,'(26A)') 'Layer',' Depth(cm)',' F-cap(mm)',' F-cap(Vol%)',' Wiltp(mm)', &
+ ' Wiltp(Vol%)',' Pore vol.',' Skel.(Vol%)',' Density',' Spheat',' pH',' Wlam', &
+ ' Water(mm)',' Water(Vol%)',' Soil-temp.',' C_opm g/m2', &
+ ' C_hum g/m2',' N_opm g/m2',' N_hum g/m2',' NH4 g/m2',' NO3 g/m2',' humus part',' d_mass g/m2', ' Clay',' Silt',' Sand'
+ do i = 1,nlay
+ WRITE (unit_soil,'(I5,2F10.2,3F12.2,F10.2,F12.2,4F8.2,F10.2,F12.2, 5F11.2,2F9.4,2E12.4, 3F6.1)') i,depth(i),field_cap(i),f_cap_v(i),wilt_p(i), &
+ wilt_p_v(i),pv_v(i), skelv(i)*100., dens(i),spheat(i),phv(i),wlam(i), &
+ wats(i),watvol(i),temps(i),c_opm(i),c_hum(i),n_opm(i), n_hum(i),nh4(i),no3(i),humusv(i),dmass(i), clayv(i)*100., siltv(i)*100., sandv(i)*100.
+ end do
+ endif
+ thick_1 = thick(1)
+ endif
+
+ if (2.*C_hum(1) .lt. humusv(1)*dmass(1)) then
+ humusv(1) = C_hum(1) / (dmass(1) * cpart)
+ endif
+ do i=2, nlay
+ humusv(i) = C_hum(i) / (dmass(i) * cpart)
+ enddo
+
+endif
+
+! Assisting fields deallok (due to probable changes in cohort amount)/Hifsfelder deallok (wegen evtl. geaenderter Koh.-Anzahl)
+if (allocated(xwatupt)) deallocate (xwatupt)
+if (allocated(xNupt)) deallocate (xNupt)
+if (allocated(wat_left)) deallocate (wat_left)
+
+END subroutine s_year
+
+!***************************************************************
+
+SUBROUTINE fire_year
+
+!calculation of mean fire risk index of a year
+
+USE data_biodiv
+use data_climate
+
+implicit none
+
+integer i,j
+real hsum1, hsum2
+
+do i = 1,3
+ hsum1 = 0.
+ hsum2 = SUM(fire(i)%frequ)
+ do j = 1,5
+ hsum1 = hsum1 + fire(i)%frequ(j) * j
+ enddo
+ if (hsum2 .ne. 0) then
+ fire(i)%mean = hsum1 / hsum2
+ else
+ fire(i)%mean = -99.0
+ endif
+ fire(i)%mean_m = fire(i)%mean_m + fire(i)%mean
+enddo
+
+! fire index Bruschek
+if(flag_climtyp .ge. 3) then
+ if(Psum_FP.ne.0.) fire_indb = Ndayshot/Psum_FP
+ fire_indb_m = fire_indb_m + fire_indb
+else
+ fire_indb = -99.0
+ fire_indb_m = -99.0
+endif
+
+END subroutine fire_year
+
+!***************************************************************
+
+SUBROUTINE t_indices (htempm)
+
+use data_biodiv
+use data_simul
+
+implicit none
+
+real, dimension(12):: htempm
+ntindex = 0.
+
+! Nonnen-Temperatur-Index after/nach Zwölfer (1935)
+if(time.gt.0) then
+ htempm = htempm / monrec
+ ntindex = (htempm(4)-4.9) * 30. + (htempm(5)-4.9) * 3. + (htempm(5)-3.2) * 17. + (htempm(5)-5.7) * 8. &
+ + (htempm(5)-7.2) * 3. + (htempm(6)-7.2) * 6. + (htempm(6)-7.6) * 10. + (htempm(6)-7.8) * 14. &
+ + (htempm(7)-6.0) * 18. + (htempm(7)-8.4) * 13. + (htempm(8)-8.4) * 2. + (htempm(8)-6.8) * 29. &
+ + (htempm(9)-6.8) * 30.
+
+ ntindex = ntindex/1240
+endif
+
+END subroutine t_indices
+
+!***************************************************************