Kolpack-Software-Consulting/piscal
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Initial commit

Browse Source
This commit is contained in:
James Kolpack
2016-02-03 18:52:05 +00:00
commit d40505e161
507 changed files with 91383 additions and 0 deletions
Download Patch File Download Diff File Expand all files Collapse all files
leafres/testarea/ALightCombinatorial.f
+318
View File
@@ -0,0 +1,318 @@
subroutine ALightCombinatorial()
implicit none
include '../testarea/LeafGasHybridFit.h'
integer i,ilastrubp1,ilastrubis1,ilastrubp2,ilastrubis2,
&ilastrubp3,ilastrubis3,ilastrubp4,ilastrubis4,
&ilastrubp5,ilastrubis5,ilastrubp6,ilastrubis6,
&ilastrubp7,ilastrubis7,ilastrubp8,ilastrubis8,
&ilastrubp9,ilastrubis9,ilastrubp10,ilastrubis10,
&ilastrubp11,ilastrubis11,ilastrubp12,ilastrubis12,
&ilastrubp13,ilastrubis13,ilastrubp14,ilastrubis14,
&ilastrubp15,ilastrubis15,k1,k2,k3,k4,k5,k6,k7,k8,k9,k10,
&k11,k12,k13,k14,k15
!common block variables: numALightcurves,nALightPoints(numALightcurves),
!ALightiphotolimit(nALightPoints,numALightcurves),ialightmin(numALightcurves),
!ialightmax(numALightcurves),ialightrubpmin(numALightcurves),ialightrubpmax(numALightcurves),
!ialightorder(numALightcurves)
if(numALightcurves.eq.0)then
!no conventional A/Light curves. go to free-style measurements directly and then return
call FreeCombinatorial()
return
endif
!(before 17/09/2014 remarks.) Assume rubp, rubisco and tpu limitations in the order of (rubp, rubisco, tpu)
!but any limitation can be missing in any light response curves. The nALightPoints data in each light
!response curve must be ordered from low to high PAR. When ordered in such, the three limitation states
!should occur in the order of (rubp, rubisco, tpu)
!
!17/09/2014 Wenting found (RuBP, TPU, Rubisco) is more likely for A/Light curves if Ci decreases with
!increased light. Thus the following changes are made:
!we generally assume the points of an A/Light curve are lined up in a sequence of (RuBP, TPU and Rubisco),
!which is indicated by ialightorder=0. However, if Ci increases steadily from nstartalight to the end, we
!assume a sequence of (RuBP, Rubisco and TPU),which is indicated by ialightorder=2.
do ilastrubp1=ialightrubpmin(1),ialightrubpmax(1)
do i=1,ilastrubp1
ALightiphotolimit(i,1)=2
enddo
k1=max0(ilastrubp1,ialightmin(1))
do 1 ilastrubis1=k1,ialightmax(1)
do i=ilastrubp1+1,ilastrubis1
ALightiphotolimit(i,1)=3-ialightorder(1)
enddo
do i=ilastrubis1+1,nALightPoints(1)
ALightiphotolimit(i,1)=1+ialightorder(1)
enddo
if(numALightcurves.eq.1)then
call FreeCombinatorial()
goto 1
endif
do ilastrubp2=ialightrubpmin(2),ialightrubpmax(2)
do i=1,ilastrubp2
ALightiphotolimit(i,2)=2
enddo
k2=max0(ilastrubp2,ialightmin(2))
do 2 ilastrubis2=k2,ialightmax(2)
do i=ilastrubp2+1,ilastrubis2
ALightiphotolimit(i,2)=3-ialightorder(2)
enddo
do i=ilastrubis2+1,nALightPoints(2)
ALightiphotolimit(i,2)=1+ialightorder(2)
enddo
if(numALightcurves.eq.2)then
call FreeCombinatorial()
goto 2
endif
do ilastrubp3=ialightrubpmin(3),ialightrubpmax(3)
do i=1,ilastrubp3
ALightiphotolimit(i,3)=2
enddo
k3=max0(ilastrubp3,ialightmin(3))
do 3 ilastrubis3=k3,ialightmax(3)
do i=ilastrubp3+1,ilastrubis3
ALightiphotolimit(i,3)=3-ialightorder(3)
enddo
do i=ilastrubis3+1,nALightPoints(3)
ALightiphotolimit(i,3)=1+ialightorder(3)
enddo
if(numALightcurves.eq.3)then
call FreeCombinatorial()
goto 3
endif
do ilastrubp4=ialightrubpmin(4),ialightrubpmax(4)
do i=1,ilastrubp4
ALightiphotolimit(i,4)=2
enddo
k4=max0(ilastrubp4,ialightmin(4))
do 4 ilastrubis4=k4,ialightmax(4)
do i=ilastrubp4+1,ilastrubis4
ALightiphotolimit(i,4)=3-ialightorder(4)
enddo
do i=ilastrubis4+1,nALightPoints(4)
ALightiphotolimit(i,4)=1+ialightorder(4)
enddo
if(numALightcurves.eq.4)then
call FreeCombinatorial()
goto 4
endif
do ilastrubp5=ialightrubpmin(5),ialightrubpmax(5)
do i=1,ilastrubp5
ALightiphotolimit(i,5)=2
enddo
k5=max0(ilastrubp5,ialightmin(5))
do 5 ilastrubis5=k5,ialightmax(5)
do i=ilastrubp5+1,ilastrubis5
ALightiphotolimit(i,5)=3-ialightorder(5)
enddo
do i=ilastrubis5+1,nALightPoints(5)
ALightiphotolimit(i,5)=1+ialightorder(5)
enddo
if(numALightcurves.eq.5)then
call FreeCombinatorial()
goto 5
endif
do ilastrubp6=ialightrubpmin(6),ialightrubpmax(6)
do i=1,ilastrubp6
ALightiphotolimit(i,6)=2
enddo
k6=max0(ilastrubp6,ialightmin(6))
do 6 ilastrubis6=k6,ialightmax(6)
do i=ilastrubp6+1,ilastrubis6
ALightiphotolimit(i,6)=3-ialightorder(6)
enddo
do i=ilastrubis6+1,nALightPoints(6)
ALightiphotolimit(i,6)=1+ialightorder(6)
enddo
if(numALightcurves.eq.6)then
call FreeCombinatorial()
goto 6
endif
do ilastrubp7=ialightrubpmin(7),ialightrubpmax(7)
do i=1,ilastrubp7
ALightiphotolimit(i,7)=2
enddo
k7=max0(ilastrubp7,ialightmin(7))
do 7 ilastrubis7=k7,ialightmax(7)
do i=ilastrubp7+1,ilastrubis7
ALightiphotolimit(i,7)=3-ialightorder(7)
enddo
do i=ilastrubis7+1,nALightPoints(7)
ALightiphotolimit(i,7)=1+ialightorder(7)
enddo
if(numALightcurves.eq.7)then
call FreeCombinatorial()
goto 7
endif
do ilastrubp8=ialightrubpmin(8),ialightrubpmax(8)
do i=1,ilastrubp8
ALightiphotolimit(i,8)=2
enddo
k8=max0(ilastrubp8,ialightmin(8))
do 8 ilastrubis8=k8,ialightmax(8)
do i=ilastrubp8+1,ilastrubis8
ALightiphotolimit(i,8)=3-ialightorder(8)
enddo
do i=ilastrubis8+1,nALightPoints(8)
ALightiphotolimit(i,8)=1+ialightorder(8)
enddo
if(numALightcurves.eq.8)then
call FreeCombinatorial()
goto 8
endif
do ilastrubp9=ialightrubpmin(9),ialightrubpmax(9)
do i=1,ilastrubp9
ALightiphotolimit(i,9)=2
enddo
k9=max0(ilastrubp9,ialightmin(9))
do 9 ilastrubis9=k9,ialightmax(9)
do i=ilastrubp9+1,ilastrubis9
ALightiphotolimit(i,9)=3-ialightorder(9)
enddo
do i=ilastrubis9+1,nALightPoints(9)
ALightiphotolimit(i,9)=1+ialightorder(9)
enddo
if(numALightcurves.eq.9)then
call FreeCombinatorial()
goto 9
endif
do ilastrubp10=ialightrubpmin(10),ialightrubpmax(10)
do i=1,ilastrubp10
ALightiphotolimit(i,10)=2
enddo
k10=max0(ilastrubp10,ialightmin(10))
do 10 ilastrubis10=k10,ialightmax(10)
do i=ilastrubp10+1,ilastrubis10
ALightiphotolimit(i,10)=3-ialightorder(10)
enddo
do i=ilastrubis10+1,nALightPoints(10)
ALightiphotolimit(i,10)=1+ialightorder(10)
enddo
if(numALightcurves.eq.10)then
call FreeCombinatorial()
goto 10
endif
do ilastrubp11=ialightrubpmin(11),ialightrubpmax(11)
do i=1,ilastrubp11
ALightiphotolimit(i,11)=2
enddo
k11=max0(ilastrubp11,ialightmin(11))
do 11 ilastrubis11=k11,ialightmax(11)
do i=ilastrubp11+1,ilastrubis11
ALightiphotolimit(i,11)=3-ialightorder(11)
enddo
do i=ilastrubis11+1,nALightPoints(11)
ALightiphotolimit(i,11)=1+ialightorder(11)
enddo
if(numALightcurves.eq.11)then
call FreeCombinatorial()
goto 11
endif
do ilastrubp12=ialightrubpmin(12),ialightrubpmax(12)
do i=1,ilastrubp12
ALightiphotolimit(i,12)=2
enddo
k12=max0(ilastrubp12,ialightmin(12))
do 12 ilastrubis12=k12,ialightmax(12)
do i=ilastrubp12+1,ilastrubis12
ALightiphotolimit(i,12)=3-ialightorder(12)
enddo
do i=ilastrubis12+1,nALightPoints(12)
ALightiphotolimit(i,12)=1+ialightorder(12)
enddo
if(numALightcurves.eq.12)then
call FreeCombinatorial()
goto 12
endif
do ilastrubp13=ialightrubpmin(13),ialightrubpmax(13)
do i=1,ilastrubp13
ALightiphotolimit(i,13)=2
enddo
k13=max0(ilastrubp13,ialightmin(13))
do 13 ilastrubis13=k13,ialightmax(13)
do i=ilastrubp13+1,ilastrubis13
ALightiphotolimit(i,13)=3-ialightorder(13)
enddo
do i=ilastrubis13+1,nALightPoints(13)
ALightiphotolimit(i,13)=1+ialightorder(13)
enddo
if(numALightcurves.eq.13)then
call FreeCombinatorial()
goto 13
endif
do ilastrubp14=ialightrubpmin(14),ialightrubpmax(14)
do i=1,ilastrubp14
ALightiphotolimit(i,14)=2
enddo
k14=max0(ilastrubp14,ialightmin(14))
do 14 ilastrubis14=k14,ialightmax(14)
do i=ilastrubp14+1,ilastrubis14
ALightiphotolimit(i,14)=3-ialightorder(14)
enddo
do i=ilastrubis14+1,nALightPoints(14)
ALightiphotolimit(i,14)=1+ialightorder(14)
enddo
if(numALightcurves.eq.14)then
call FreeCombinatorial()
goto 14
endif
do ilastrubp15=ialightrubpmin(15),ialightrubpmax(15)
do i=1,ilastrubp15
ALightiphotolimit(i,15)=2
enddo
k15=max0(ilastrubp15,ialightmin(15))
do 15 ilastrubis15=k15,ialightmax(15)
do i=ilastrubp15+1,ilastrubis15
ALightiphotolimit(i,15)=3-ialightorder(15)
enddo
do i=ilastrubis15+1,nALightPoints(15)
ALightiphotolimit(i,15)=1+ialightorder(15)
enddo
if(numALightcurves.eq.15)then
call FreeCombinatorial()
goto 15
endif
15 continue
enddo
14 continue
enddo
13 continue
enddo
12 continue
enddo
11 continue
enddo
10 continue
enddo
9 continue
enddo
8 continue
enddo
7 continue
enddo
6 continue
enddo
5 continue
enddo
4 continue
enddo
3 continue
enddo
2 continue
enddo
1 continue
enddo
return
end subroutine ALightCombinatorial
leafres/testarea/Anet_Final.f
+1087
View File
File diff suppressed because it is too large Load Diff
leafres/testarea/FreeCombinatorial.f
+385
View File
@@ -0,0 +1,385 @@
subroutine FreeCombinatorial()
include '../testarea/LeafGasHybridFit.h'
integer
&i01,i02,i03,i04,i05,i06,i07,i08,i09,i10,
&i11,i12,i13,i14,i15,i16,i17,i18,i19,i20,
&i21,i22,i23,i24,i25,i26,i27,i28,i29,i30,
&i31,i32,i33,i34,i35,i36,i37,i38,i39,i40,
&i41,i42,i43,i44,i45,i46,i47,i48,i49,i50,
&maxfreeruns
double precision ran2,r
if(nFreePoints.eq.0)then
call UnivPhotoFit()
return
endif
if(nFreePoints.gt.5)then
maxfreeruns=100
do i01=1,maxfreeruns
do i02=1,nFreePoints
r=ran2()
if(r.lt.0.35d0)then
Freeiphotolimit(i02)=1
else
if(r.gt.0.65d0)then
Freeiphotolimit(i02)=2
else
Freeiphotolimit(i02)=3
endif
endif
enddo
call UnivPhotoFit()
enddo
return
endif
do 1 i01=1,3
Freeiphotolimit(1)=i01
if(nFreePoints.eq.1)then
call UnivPhotoFit()
goto 1
endif
do 2 i02=1,3
Freeiphotolimit(2)=i02
if(nFreePoints.eq.2)then
call UnivPhotoFit()
goto 2
endif
do 3 i03=1,3
Freeiphotolimit(3)=i03
if(nFreePoints.eq.3)then
call UnivPhotoFit()
goto 3
endif
do 4 i04=1,3
Freeiphotolimit(4)=i04
if(nFreePoints.eq.4)then
call UnivPhotoFit()
goto 4
endif
do 5 i05=1,3
Freeiphotolimit(5)=i05
if(nFreePoints.eq.5)then
call UnivPhotoFit()
goto 5
endif
do 6 i06=1,3
Freeiphotolimit(6)=i06
if(nFreePoints.eq.6)then
call UnivPhotoFit()
goto 6
endif
do 7 i07=1,3
Freeiphotolimit(7)=i07
if(nFreePoints.eq.7)then
call UnivPhotoFit()
goto 7
endif
do 8 i08=1,3
Freeiphotolimit(8)=i08
if(nFreePoints.eq.8)then
call UnivPhotoFit()
goto 8
endif
do 9 i09=1,3
Freeiphotolimit(9)=i09
if(nFreePoints.eq.9)then
call UnivPhotoFit()
goto 9
endif
do 10 i10=1,3
Freeiphotolimit(10)=i10
if(nFreePoints.eq.10)then
call UnivPhotoFit()
goto 10
endif
do 11 i11=1,3
Freeiphotolimit(11)=i11
if(nFreePoints.eq.11)then
call UnivPhotoFit()
goto 11
endif
do 12 i12=1,3
Freeiphotolimit(12)=i12
if(nFreePoints.eq.12)then
call UnivPhotoFit()
goto 12
endif
do 13 i13=1,3
Freeiphotolimit(13)=i13
if(nFreePoints.eq.13)then
call UnivPhotoFit()
goto 13
endif
do 14 i14=1,3
Freeiphotolimit(14)=i14
if(nFreePoints.eq.14)then
call UnivPhotoFit()
goto 14
endif
do 15 i15=1,3
Freeiphotolimit(15)=i15
if(nFreePoints.eq.15)then
call UnivPhotoFit()
goto 15
endif
do 16 i16=1,3
Freeiphotolimit(16)=i16
if(nFreePoints.eq.16)then
call UnivPhotoFit()
goto 16
endif
do 17 i17=1,3
Freeiphotolimit(17)=i17
if(nFreePoints.eq.17)then
call UnivPhotoFit()
goto 17
endif
do 18 i18=1,3
Freeiphotolimit(18)=i18
if(nFreePoints.eq.18)then
call UnivPhotoFit()
goto 18
endif
do 19 i19=1,3
Freeiphotolimit(19)=i19
if(nFreePoints.eq.19)then
call UnivPhotoFit()
goto 19
endif
do 20 i20=1,3
Freeiphotolimit(20)=i20
if(nFreePoints.eq.20)then
call UnivPhotoFit()
goto 20
endif
do 21 i21=1,3
Freeiphotolimit(21)=i21
if(nFreePoints.eq.21)then
call UnivPhotoFit()
goto 21
endif
do 22 i22=1,3
Freeiphotolimit(22)=i22
if(nFreePoints.eq.22)then
call UnivPhotoFit()
goto 22
endif
do 23 i23=1,3
Freeiphotolimit(23)=i23
if(nFreePoints.eq.23)then
call UnivPhotoFit()
goto 23
endif
do 24 i24=1,3
Freeiphotolimit(24)=i24
if(nFreePoints.eq.24)then
call UnivPhotoFit()
goto 24
endif
do 25 i25=1,3
Freeiphotolimit(25)=i25
if(nFreePoints.eq.25)then
call UnivPhotoFit()
goto 25
endif
do 26 i26=1,3
Freeiphotolimit(26)=i26
if(nFreePoints.eq.26)then
call UnivPhotoFit()
goto 26
endif
do 27 i27=1,3
Freeiphotolimit(27)=i27
if(nFreePoints.eq.27)then
call UnivPhotoFit()
goto 27
endif
do 28 i28=1,3
Freeiphotolimit(28)=i28
if(nFreePoints.eq.28)then
call UnivPhotoFit()
goto 28
endif
do 29 i29=1,3
Freeiphotolimit(29)=i29
if(nFreePoints.eq.29)then
call UnivPhotoFit()
goto 29
endif
do 30 i30=1,3
Freeiphotolimit(30)=i30
if(nFreePoints.eq.30)then
call UnivPhotoFit()
goto 30
endif
do 31 i31=1,3
Freeiphotolimit(31)=i31
if(nFreePoints.eq.31)then
call UnivPhotoFit()
goto 31
endif
do 32 i32=1,3
Freeiphotolimit(32)=i32
if(nFreePoints.eq.32)then
call UnivPhotoFit()
goto 32
endif
do 33 i33=1,3
Freeiphotolimit(33)=i33
if(nFreePoints.eq.33)then
call UnivPhotoFit()
goto 33
endif
do 34 i34=1,3
Freeiphotolimit(34)=i34
if(nFreePoints.eq.34)then
call UnivPhotoFit()
goto 34
endif
do 35 i35=1,3
Freeiphotolimit(35)=i35
if(nFreePoints.eq.35)then
call UnivPhotoFit()
goto 35
endif
do 36 i36=1,3
Freeiphotolimit(36)=i36
if(nFreePoints.eq.36)then
call UnivPhotoFit()
goto 36
endif
do 37 i37=1,3
Freeiphotolimit(37)=i37
if(nFreePoints.eq.37)then
call UnivPhotoFit()
goto 37
endif
do 38 i38=1,3
Freeiphotolimit(38)=i38
if(nFreePoints.eq.38)then
call UnivPhotoFit()
goto 38
endif
do 39 i39=1,3
Freeiphotolimit(39)=i39
if(nFreePoints.eq.39)then
call UnivPhotoFit()
goto 39
endif
do 40 i40=1,3
Freeiphotolimit(40)=i40
if(nFreePoints.eq.40)then
call UnivPhotoFit()
goto 40
endif
do 41 i41=1,3
Freeiphotolimit(41)=i41
if(nFreePoints.eq.41)then
call UnivPhotoFit()
goto 41
endif
do 42 i42=1,3
Freeiphotolimit(42)=i42
if(nFreePoints.eq.42)then
call UnivPhotoFit()
goto 42
endif
do 43 i43=1,3
Freeiphotolimit(43)=i43
if(nFreePoints.eq.43)then
call UnivPhotoFit()
goto 43
endif
do 44 i44=1,3
Freeiphotolimit(44)=i44
if(nFreePoints.eq.44)then
call UnivPhotoFit()
goto 44
endif
do 45 i45=1,3
Freeiphotolimit(45)=i45
if(nFreePoints.eq.45)then
call UnivPhotoFit()
goto 45
endif
do 46 i46=1,3
Freeiphotolimit(46)=i46
if(nFreePoints.eq.46)then
call UnivPhotoFit()
goto 46
endif
do 47 i47=1,3
Freeiphotolimit(47)=i47
if(nFreePoints.eq.47)then
call UnivPhotoFit()
goto 47
endif
do 48 i48=1,3
Freeiphotolimit(48)=i48
if(nFreePoints.eq.48)then
call UnivPhotoFit()
goto 48
endif
do 49 i49=1,3
Freeiphotolimit(49)=i49
if(nFreePoints.eq.49)then
call UnivPhotoFit()
goto 49
endif
do 50 i50=1,3
Freeiphotolimit(50)=i50
if(nFreePoints.eq.50)then
call UnivPhotoFit()
goto 50
endif
50 continue
49 continue
48 continue
47 continue
46 continue
45 continue
44 continue
43 continue
42 continue
41 continue
40 continue
39 continue
38 continue
37 continue
36 continue
35 continue
34 continue
33 continue
32 continue
31 continue
30 continue
29 continue
28 continue
27 continue
26 continue
25 continue
24 continue
23 continue
22 continue
21 continue
20 continue
19 continue
18 continue
17 continue
16 continue
15 continue
14 continue
13 continue
12 continue
11 continue
10 continue
9 continue
8 continue
7 continue
6 continue
5 continue
4 continue
3 continue
2 continue
1 continue
return
end subroutine FreeCombinatorial
leafres/testarea/HybridCombinatorial.f
+732
View File
@@ -0,0 +1,732 @@
!We consider four types of leaf gas exchange measurements. These four types must be clearly indicated in the input:
!1. Points whose limitation states are known from other means (e.g. chlorophyll fluorescence): these points will be called fixed points and
! their limitation states will not be changed by the parameter estimation program.
!2. Points from conventional CO2 response measurements (A/Ci curves) that are done without fluorescence. Limitation states are not known but follow
! the order of Rubisco, RuBP and TPU along the CO2i axis as suggested in Gu et al. (2010) PCE paper. We call these points ACi points.
! The ACi points must be already ordered from low to high CO2i.
!3. Points from conventional light response measurements (A/PAR curves) that are done without fluorescence. Limitation states are not known but follow
! the order of RuBP, Rubisco and TPU along the PAR axis. We call these points ALight points. The ALight points must be already ordered from low to high PAR.
!4. Points whose limitation states follow no order. We call these points free points. They are obtained with no control of environmental conditions.
subroutine HybridCombinatorial()
implicit none
include '../testarea/LeafGasParams.h'
include '../testarea/LeafGasHybridFit.h'
integer i,j,k,m,mm,n,iacirubismin(numACicurves),
&iacirubismax(numACicurves),iacitpumin(numACicurves),
&iacitpumax(numACicurves),ialightrubismin(numALightcurves),
&ialighttpumin(numALightcurves),ilastrubis1,ilastrubp1,
&ilastrubis2,ilastrubp2,ilastrubis3,ilastrubp3,ilastrubis4,
&ilastrubp4,ilastrubis5,ilastrubp5,ilastrubis6,ilastrubp6,
&ilastrubis7,ilastrubp7,ilastrubis8,ilastrubp8,
&ilastrubis9,ilastrubp9,ilastrubis10,ilastrubp10,
&ilastrubis11,ilastrubp11,ilastrubis12,ilastrubp12,
&ilastrubis13,ilastrubp13,ilastrubis14,ilastrubp14,
&ilastrubis15,ilastrubp15,k1,k2,k3,k4,k5,k6,k7,k8,
&k9,k10,k11,k12,k13,k14,k15,ilasttpu1,ilasttpu2,
&ilasttpu3,ilasttpu4,ilasttpu5,ilasttpu6,ilasttpu7,
&ilasttpu8,ilasttpu9,ilasttpu10,ilasttpu11,ilasttpu12,
&ilasttpu13,ilasttpu14,ilasttpu15
double precision rdlight,atp,resistwp,resistch,stargamma,
&realizedfjelect,term
!
!common block variables:idokco,idoalpha,minimumrubis,minimumfj,minimumvt,nACiPoints,ACiiphotolimit(nACiPoints)
minimumfj=2
if(idokc.eq.0.and.idoko.eq.0)then
minimumrubis=2
else
if(idokc.eq.0.or.idoko.eq.0)then
minimumrubis=3
else
minimumrubis=4
endif
endif
if((nFixedPoints+numACicurves+nFreePoints).eq.0)minimumrubis=2
if(idoalpha.eq.0)then
minimumvt=2
else
minimumvt=3
endif
i=0
do k1=1,numACicurves
do k2=nendaci(k1)+1,nACiPoints(k1)
i=i+1
enddo
enddo
if(i.gt.0)minimumvt=i
!
ntotunivparams=19
univparamsmin(1)=resistwp25min
univparamsmax(1)=resistwp25max
univparamsmin(2)=resistch25min
univparamsmax(2)=resistch25max
univparamsmin(3)=rdlight25min
univparamsmax(3)=rdlight25max
univparamsmin(4)=stargamma25min
univparamsmax(4)=stargamma25max
univparamsmin(5)=vcmax25min
univparamsmax(5)=vcmax25max
univparamsmin(6)=fkc25min
univparamsmax(6)=fkc25max
univparamsmin(7)=fko25min
univparamsmax(7)=fko25max
univparamsmin(8)=fjmax25min
univparamsmax(8)=fjmax25max
univparamsmin(9)=tpu25min
univparamsmax(9)=tpu25max
univparamsmin(10)=alpha25min
univparamsmax(10)=alpha25max
univparamsmin(11)=phifactormin
univparamsmax(11)=phifactormax
univparamsmin(12)=thetafactormin
univparamsmax(12)=thetafactormax
univparamsmin(13)=betaPSIImin
univparamsmax(13)=betaPSIImax
univparamsmin(14)=ha_darkrespmin
univparamsmax(14)=ha_darkrespmax
univparamsmin(15)=ha_stargammamin
univparamsmax(15)=ha_stargammamax
univparamsmin(16)=ha_vcmaxmin
univparamsmax(16)=ha_vcmaxmax
univparamsmin(17)=ha_jmaxmin
univparamsmax(17)=ha_jmaxmax
univparamsmin(18)=ha_tpumin
univparamsmax(18)=ha_tpumax
univparamsmin(19)=ha_gmesomin
univparamsmax(19)=ha_gmesomax
bestilimittype=-9999
do ilastrubis1=1,7
subbestsumsquare(ilastrubis1)=1.0d+100
subbestunivparams(1,ilastrubis1)=resistwp25_ori
subbestunivparams(2,ilastrubis1)=resistch25_ori
subbestunivparams(3,ilastrubis1)=rdlight25_ori
subbestunivparams(4,ilastrubis1)=stargamma25_ori
subbestunivparams(5,ilastrubis1)=vcmax25_ori
subbestunivparams(6,ilastrubis1)=fkc25_ori
subbestunivparams(7,ilastrubis1)=fko25_ori
subbestunivparams(8,ilastrubis1)=fjmax25_ori
subbestunivparams(9,ilastrubis1)=tpu25_ori
subbestunivparams(10,ilastrubis1)=alpha25_ori
subbestunivparams(11,ilastrubis1)=phifactor_ori
subbestunivparams(12,ilastrubis1)=thetafactor_ori
subbestunivparams(13,ilastrubis1)=betaPSII_ori
subbestunivparams(14,ilastrubis1)=ha_darkresp_ori
subbestunivparams(15,ilastrubis1)=ha_stargamma_ori
subbestunivparams(16,ilastrubis1)=ha_vcmax_ori
subbestunivparams(17,ilastrubis1)=ha_jmax_ori
subbestunivparams(18,ilastrubis1)=ha_tpu_ori
subbestunivparams(19,ilastrubis1)=ha_gmeso_ori
do i=1,ntotsamples
subbestiphotolimit(i,ilastrubis1)=-9999
enddo
enddo
do i=1,ntotsamples
forcings(i,1)=pco2i_ori(i)
forcings(i,2)=aPPFDlf_ori(i)
forcings(i,3)=templeaf_ori(i)
forcings(i,4)=po2i_ori(i)
responses(i,1)=anet_obs(i)
weitforcings(i,1)=1.0d0
weitforcings(i,2)=1.0d0
weitforcings(i,3)=1.0d0
weitforcings(i,4)=1.0d0
weitresponses(i,1)=1.0d0
if(ntotphips2.ge.1)then
if(chlflphips2_ori(i).gt.0.0d0)then
!for least square regression
responses(i,2)=chlflphips2_ori(i)
!a factor of 100 makes PhiPSII comparable to Anet in magnitude
weitresponses(i,2)=100.0d0
else
responses(i,2)=chlflphips2_ori(i)
weitresponses(i,2)=0.0d0
endif
endif
if(Prioriknowlimit.eq.-1)then
!fluorescence fit only. chlflphips2 becomes a forcing variable
forcings(i,5)=chlflphips2_ori(i)
weitforcings(i,5)=1.0d0
if(chlflphips2_ori(i).le.0.0d0)then
weitforcings(i,5)=0.0d0
weitresponses(i,1)=0.0d0
endif
endif
enddo
do i=1,12
gacontrol(i)=-1.0d0
enddo
gacontrol(1)=500.0d0
gacontrol(2)=10000.0d0
gacontrol(3)=8.0d0
!Priorilimittype: indicator for the choice of overall mixtures of limitation types
! = 1, Rubisco+RuBP+TPU
! = 2, Rubisco+RuBP
! = 3, Rubisco+TPU
! = 4, RuBP+TPU
! = 5, Rubisco Only
! = 6, RuBP Only
! = 7, TPU Only
!Prioriknowlimit: indicator for how the limitation type of each point is set before the fitting
! = 0, the limitation type of each individual point has not been pre-set when mixed
! limitation states are present in the dataset. When Priorilimittype = 5, 6, 7,
! all points are limited by one type.
! = 1, the limit type of each individual point has been pre-set. Don't allow the fitting
! algorithm to change the limitation type of each point during the first fit. But
! check the admissibility after the first fit. If the admissibility is violated,
! treat the osicilation points as colimited; if there is no osicilation, use the penalty
! approach to refit.
! = 2, the limit type of each individual point has been pre-set. Allow the fitting
! algorithm to change the limitation type of each point during the fit. Penalize any fit
! that results in any point to have a limitation type different from the pre-set type.
! =-1, only do a fluorescence fit
!$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
if(Prioriknowlimit.eq.-1)then
!fluorescence only fit
Priorilimittype=6
Currentilimittype=Priorilimittype
Currentiknowlimit=Prioriknowlimit
!we pass UnivPhotoFit and call DoUnivPhotoFit directly
call DoUnivPhotoFit()
if(numALightcurves.gt.0.and.idorch.eq.1)then
!we only need to call fluorescencemax once.
call fluorescencejmax()
endif
return
endif
!$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
k1=0
do i=1,numACicurves
if(nendaci(i).lt.nACiPoints(i))k1=1
!TPU limitation must be present
enddo
k2=0
do i=1,numALightcurves
if(nstartalight(i).gt.1)k2=1
!RuBP points must be present
enddo
Prioriknowlimit=0
bestsumsquare=1.0d+100
do Priorilimittype=1,7
if(k1.eq.1)then
if(Priorilimittype.eq.2.or.Priorilimittype.eq.5
&.or.Priorilimittype.eq.6)goto 2001
endif
if(k2.eq.1)then
if(Priorilimittype.eq.3.or.Priorilimittype.eq.5
&.or.Priorilimittype.eq.7)goto 2001
endif
if(Priorilimittype.gt.4)then
gacontrol(1)=100.0d0
gacontrol(2)=1000.0d0
endif
call UnivPhotoFit()
if(subbestsumsquare(Priorilimittype).le.bestsumsquare)then
bestilimittype=Priorilimittype
bestsumsquare=subbestsumsquare(Priorilimittype)
do i=1,ntotunivparams
bestunivparams(i)=subbestunivparams(i,Priorilimittype)
enddo
do i=1,ntotsamples
bestiphotolimit(i)=subbestiphotolimit(i,Priorilimittype)
enddo
endif
2001 continue
enddo
! goto 1000
gacontrol(1)=200.0d0
gacontrol(2)=2000.0d0
!-------------------------------------------------------------------
k=nFixedPoints
do i=1,numACicurves
!Find the position (iacirubismin) of the last point of the first continuous rubisco section.
! However, if the curve does not start with rubisco points, iacirubismin=0
!Find the position (iacirubismax) of the last rubisco point of the whole curve
! If the curve does not contain any rubusco points, iacirubismax=0
!Find the position (iacitpumin) of the first tpu point of the whole curve
iacirubismin(i)=0
iacirubismax(i)=0
iacitpumin(i)=nACiPoints(i)+1
n=0
m=0
do j=1,nACiPoints(i)
k=k+1
if(bestiphotolimit(k).eq.1)then
if(n.eq.0)iacirubismin(i)=j
iacirubismax(i)=j
else
n=1
if(bestiphotolimit(k).eq.3.and.m.eq.0)then
iacitpumin(i)=j
m=1
endif
endif
enddo
if(iacirubismin(i).eq.0)then
iacirubismax(i)=nendaci(i)
else
iacirubismin(i)=max0(0,iacirubismin(i)-2)
iacirubismax(i)=min0(nendaci(i),iacirubismax(i)+2)
endif
iacitpumax(i)=iacitpumin(i)
iacitpumin(i)=max0(nstartaci(i),iacitpumin(i)-2)
iacitpumin(i)=min0(nendaci(i)-2,iacitpumin(i))
iacitpumin(i)=max0(0,iacitpumin(i))
iacitpumax(i)=min0(nendaci(i),nACiPoints(i),iacitpumax(i)+2)
enddo
do i=1,numALightcurves
!Find the position (iacirubismin) of the last point of the first continuous rubisco section.
! However, if the curve does not start with rubisco points, iacirubismin=0
!Find the position (iacirubismax) of the last rubisco point of the whole curve
! If the curve does not contain any rubusco points, iacirubismax=0
!Find the position (iacitpumin) of the first tpu point of the whole curve
ialightrubpmin(i)=0
ialightrubpmax(i)=0
ialighttpumin(i)=nALightPoints(i)+1
ialightrubismin(i)=nALightPoints(i)+1
n=0
m=0
mm=0
do j=1,nALightPoints(i)
k=k+1
if(bestiphotolimit(k).eq.2)then
if(n.eq.0)ialightrubpmin(i)=j
ialightrubpmax(i)=j
else
n=1
if(bestiphotolimit(k).eq.3.and.m.eq.0)then
ialighttpumin(i)=j
m=1
endif
if(bestiphotolimit(k).eq.1.and.mm.eq.0)then
ialightrubismin(i)=j
mm=1
endif
endif
enddo
ialightrubpmin(i)=max0(0,ialightrubpmin(i)-2,nstartalight(i))
ialightrubpmax(i)=min0(nendalight(i),ialightrubpmax(i)+2)
ialightrubpmax(i)=max0(ialightrubpmax(i),ialightrubpmin(i)+2)
!we generally assume the points of an A/Light curve are lined up in a sequence of (RuBP, TPU and Rubisco),
!which is indicated by ialightorder=0. However, if Ci increases steadily from nstartalight to the end, we
!assume a sequence of (RuBP, Rubisco and TPU),which is indicated by ialightorder=2.
ialightmin(i)=nALightPoints(i)
ialightmax(i)=nALightPoints(i)
if(ialighttpumin(i).lt.ialightrubismin(i))then
!(RuBP,TPU,Rubisco)
ialightorder(i)=0
if(ialightrubismin(i).le.nALightPoints(i))then
ialightmin(i)=max0(ialightrubismin(i)-2,nstartalight(i))
ialightmax(i)=ialightrubismin(i)+2
endif
else
if(ialighttpumin(i).gt.ialightrubismin(i))then
!(RuBP,Rubisco,TPU)
ialightorder(i)=2
if(ialighttpumin(i).le.nALightPoints(i))then
ialightmin(i)=max0(ialighttpumin(i)-2,nstartalight(i))
ialightmax(i)=ialighttpumin(i)+2
endif
endif
endif
ialightmax(i)=max0(ialightrubpmax(i)+1,ialightmax(i))
ialightmax(i)=min0(nALightPoints(i),ialightmax(i))
if(ialightmax(i).lt.ialightmin(i))ialightmin(i)=ialightmax(i)
enddo
!-------------------------------------------------------------------
bestilimittype=-9999
Prioriknowlimit=1
Priorilimittype=-9999
!
c gacontrol( 1) - number of individuals in a population (default
c is 100)
c gacontrol( 2) - number of generations over which solution is
c to evolve (default is 500)
c gacontrol( 3) - number of significant digits (i.e., number of
c genes) retained in chromosomal encoding (default
c is 6) (Note: This number is limited by the
c machine floating point precision. Most 32-bit
c floating point representations have only 6 full
c digits of precision. To achieve greater preci-
c sion this routine could be converted to double
c precision, but note that this would also require
c a double precision random number generator, which
c likely would not have more than 9 digits of
c precision if it used 4-byte integers internally.)
c gacontrol( 4) - crossover probability; must be <= 1.0 (default
c is 0.85). If crossover takes place, either one
c or two splicing points are used, with equal
c probabilities
c gacontrol( 5) - mutation mode; 1/2/3/4/5 (default is 2)
c 1=one-point mutation, fixed rate
c 2=one-point, adjustable rate based on fitness
c 3=one-point, adjustable rate based on distance
c 4=one-point+creep, fixed rate
c 5=one-point+creep, adjustable rate based on fitness
c 6=one-point+creep, adjustable rate based on distance
c gacontrol( 6) - initial mutation rate; should be small (default
c is 0.005) (Note: the mutation rate is the proba-
c bility that any one gene locus will mutate in
c any one generation.)
c gacontrol( 7) - minimum mutation rate; must be >= 0.0 (default
c is 0.0005)
c gacontrol( 8) - maximum mutation rate; must be <= 1.0 (default
c is 0.25)
c gacontrol( 9) - relative fitness differential; range from 0
c (none) to 1 (maximum). (default is 1.)
c gacontrol(10) - reproduction plan; 1/2/3=Full generational
c replacement/Steady-state-replace-random/Steady-
c state-replace-worst (default is 3)
c gacontrol(11) - elitism flag; 0/1=off/on (default is 0)
c (Applies only to reproduction plans 1 and 2)
c gacontrol(12) - printed output 0/1/2=None/Minimal/Verbose
c (default is 0)
c
if(numACicurves.eq.0)then
!no conventional A/Ci curves. go to light response curves directly.
call ALightCombinatorial()
goto 1000
endif
!Assume rubisco, rubp and tpu limitations in the order of (rubisco, rubp, tpu) but any limitation can be missing in any ACi curves.
!The nACiPoints points of each ACi curve must have been already ordered from low to high Ci within each individual ACi curve.
do ilastrubis1=iacirubismin(1),iacirubismax(1)
do i=1,ilastrubis1
ACiiphotolimit(i,1)=1
enddo
k1=max0(ilastrubis1,iacitpumin(1))
do 1 ilasttpu1=k1,iacitpumax(1)
do i=ilasttpu1+1,nACiPoints(1)
ACiiphotolimit(i,1)=3
enddo
do i=ilastrubis1+1,ilasttpu1
ACiiphotolimit(i,1)=2
enddo
if(numACicurves.eq.1)then
call ALightCombinatorial()
goto 1
endif
do ilastrubis2=iacirubismin(2),iacirubismax(2)
do i=1,ilastrubis2
ACiiphotolimit(i,2)=1
enddo
k2=max0(ilastrubis2,iacitpumin(2))
do 2 ilasttpu2=k2,iacitpumax(2)
do i=ilasttpu2+1,nACiPoints(2)
ACiiphotolimit(i,2)=3
enddo
do i=ilastrubis2+1,ilasttpu2
ACiiphotolimit(i,2)=2
enddo
if(numACicurves.eq.2)then
call ALightCombinatorial()
goto 2
endif
do ilastrubis3=iacirubismin(3),iacirubismax(3)
do i=1,ilastrubis3
ACiiphotolimit(i,3)=1
enddo
k3=max0(ilastrubis3,iacitpumin(3))
do 3 ilasttpu3=k3,iacitpumax(3)
do i=ilasttpu3+1,nACiPoints(3)
ACiiphotolimit(i,3)=3
enddo
do i=ilastrubis3+1,ilasttpu3
ACiiphotolimit(i,3)=2
enddo
if(numACicurves.eq.3)then
call ALightCombinatorial()
goto 3
endif
do ilastrubis4=iacirubismin(4),iacirubismax(4)
do i=1,ilastrubis4
ACiiphotolimit(i,4)=1
enddo
k4=max0(iacitpumin(4),ilastrubis4)
do 4 ilasttpu4=k4,iacitpumax(4)
do i=ilasttpu4+1,nACiPoints(4)
ACiiphotolimit(i,4)=3
enddo
do i=ilastrubis4+1,ilasttpu4
ACiiphotolimit(i,4)=2
enddo
if(numACicurves.eq.4)then
call ALightCombinatorial()
goto 4
endif
do ilastrubis5=iacirubismin(5),iacirubismax(5)
do i=1,ilastrubis5
ACiiphotolimit(i,5)=1
enddo
k5=max0(iacitpumin(5),ilastrubis5)
do 5 ilasttpu5=k5,iacitpumax(5)
do i=ilasttpu5+1,nACiPoints(5)
ACiiphotolimit(i,5)=3
enddo
do i=ilastrubis5+1,ilasttpu5
ACiiphotolimit(i,5)=2
enddo
if(numACicurves.eq.5)then
call ALightCombinatorial()
goto 5
endif
do ilastrubis6=iacirubismin(6),iacirubismax(6)
do i=1,ilastrubis6
ACiiphotolimit(i,6)=1
enddo
k6=max0(iacitpumin(6),ilastrubis6)
do 6 ilasttpu6=k6,iacitpumax(6)
do i=ilasttpu6+1,nACiPoints(6)
ACiiphotolimit(i,6)=3
enddo
do i=ilastrubis6+1,ilasttpu6
ACiiphotolimit(i,6)=2
enddo
if(numACicurves.eq.6)then
call ALightCombinatorial()
goto 6
endif
do ilastrubis7=iacirubismin(7),iacirubismax(7)
do i=1,ilastrubis7
ACiiphotolimit(i,7)=1
enddo
k7=max0(iacitpumin(7),ilastrubis7)
do 7 ilasttpu7=k7,iacitpumax(7)
do i=ilasttpu7+1,nACiPoints(7)
ACiiphotolimit(i,7)=3
enddo
do i=ilastrubis7+1,ilasttpu7
ACiiphotolimit(i,7)=2
enddo
if(numACicurves.eq.7)then
call ALightCombinatorial()
goto 7
endif
do ilastrubis8=iacirubismin(8),iacirubismax(8)
do i=1,ilastrubis8
ACiiphotolimit(i,8)=1
enddo
k8=max0(iacitpumin(8),ilastrubis8)
do 8 ilasttpu8=k8,iacitpumax(8)
do i=ilasttpu8+1,nACiPoints(8)
ACiiphotolimit(i,8)=3
enddo
do i=ilastrubis8+1,ilasttpu8
ACiiphotolimit(i,8)=2
enddo
if(numACicurves.eq.8)then
call ALightCombinatorial()
goto 8
endif
do ilastrubis9=iacirubismin(9),iacirubismax(9)
do i=1,ilastrubis9
ACiiphotolimit(i,9)=1
enddo
k9=max0(iacitpumin(9),ilastrubis9)
do 9 ilasttpu9=k9,iacitpumax(9)
do i=ilasttpu9+1,nACiPoints(9)
ACiiphotolimit(i,9)=3
enddo
do i=ilastrubis9+1,ilasttpu9
ACiiphotolimit(i,9)=2
enddo
if(numACicurves.eq.9)then
call ALightCombinatorial()
goto 9
endif
do ilastrubis10=iacirubismin(10),iacirubismax(10)
do i=1,ilastrubis10
ACiiphotolimit(i,10)=1
enddo
k10=max0(iacitpumin(10),ilastrubis10)
do 10 ilasttpu10=k10,iacitpumax(10)
do i=ilasttpu10+1,nACiPoints(10)
ACiiphotolimit(i,10)=3
enddo
do i=ilastrubis10+1,ilasttpu10
ACiiphotolimit(i,10)=2
enddo
if(numACicurves.eq.10)then
call ALightCombinatorial()
goto 10
endif
do ilastrubis11=iacirubismin(11),iacirubismax(11)
do i=1,ilastrubis11
ACiiphotolimit(i,11)=1
enddo
k11=max0(iacitpumin(11),ilastrubis11)
do 11 ilasttpu11=k11,iacitpumax(11)
do i=ilasttpu11+1,nACiPoints(11)
ACiiphotolimit(i,11)=3
enddo
do i=ilastrubis11+1,ilasttpu11
ACiiphotolimit(i,11)=2
enddo
if(numACicurves.eq.11)then
call ALightCombinatorial()
goto 11
endif
do ilastrubis12=iacirubismin(12),iacirubismax(12)
do i=1,ilastrubis12
ACiiphotolimit(i,12)=1
enddo
k12=max0(iacitpumin(12),ilastrubis12)
do 12 ilasttpu12=k12,iacitpumax(12)
do i=ilasttpu12+1,nACiPoints(12)
ACiiphotolimit(i,12)=3
enddo
do i=ilastrubis12+1,ilasttpu12
ACiiphotolimit(i,12)=2
enddo
if(numACicurves.eq.12)then
call ALightCombinatorial()
goto 12
endif
do ilastrubis13=iacirubismin(13),iacirubismax(13)
do i=1,ilastrubis13
ACiiphotolimit(i,13)=1
enddo
k13=max0(iacitpumin(13),ilastrubis13)
do 13 ilasttpu13=k13,iacitpumax(13)
do i=ilasttpu13+1,nACiPoints(13)
ACiiphotolimit(i,13)=3
enddo
do i=ilastrubis13+1,ilasttpu13
ACiiphotolimit(i,13)=2
enddo
if(numACicurves.eq.13)then
call ALightCombinatorial()
goto 13
endif
do ilastrubis14=iacirubismin(14),iacirubismax(14)
do i=1,ilastrubis14
ACiiphotolimit(i,14)=1
enddo
k14=max0(iacitpumin(14),ilastrubis14)
do 14 ilasttpu14=k14,iacitpumax(14)
do i=ilasttpu14+1,nACiPoints(14)
ACiiphotolimit(i,14)=3
enddo
do i=ilastrubis14+1,ilasttpu14
ACiiphotolimit(i,14)=2
enddo
if(numACicurves.eq.14)then
call ALightCombinatorial()
goto 14
endif
do ilastrubis15=iacirubismin(15),iacirubismax(15)
do i=1,ilastrubis15
ACiiphotolimit(i,15)=1
enddo
k15=max0(iacitpumin(15),ilastrubis15)
do 15 ilasttpu15=k15,iacitpumax(15)
do i=ilasttpu15+1,nACiPoints(15)
ACiiphotolimit(i,15)=3
enddo
do i=ilastrubis15+1,ilasttpu15
ACiiphotolimit(i,15)=2
enddo
if(numACicurves.eq.15)then
call ALightCombinatorial()
goto 15
endif
15 continue
enddo
14 continue
enddo
13 continue
enddo
12 continue
enddo
11 continue
enddo
10 continue
enddo
9 continue
enddo
8 continue
enddo
7 continue
enddo
6 continue
enddo
5 continue
enddo
4 continue
enddo
3 continue
enddo
2 continue
enddo
1 continue
enddo
bestsumsquare=1.0d+100
do Priorilimittype=1,7
if(subbestsumsquare(Priorilimittype).le.bestsumsquare)then
bestilimittype=Priorilimittype
bestsumsquare=subbestsumsquare(Priorilimittype)
do i=1,ntotunivparams
bestunivparams(i)=subbestunivparams(i,Priorilimittype)
enddo
do i=1,ntotsamples
bestiphotolimit(i)=subbestiphotolimit(i,Priorilimittype)
enddo
endif
enddo
1000 do i=1,ntotunivparams
univparams(i)=bestunivparams(i)
enddo
call UnivParamsAlloc(2)
call ilimittypestats(ntotsamples,bestiphotolimit,
&bestilimittype,bestnumrubis,bestnumrubp,bestnumtpu)
if(bestnumrubis.eq.0)then
vcmax25=-9999
if(idokc.eq.1)fkc25=-9999.0d0
if(idoko.eq.1)fko25=-9999.0d0
endif
if(bestnumrubp.eq.0)fjmax25=-9999
if(bestnumtpu.eq.0)then
tpu25=-9999
if(idoalpha.eq.1)alpha25=-9999
endif
do i=1,ntotsamples
ilastrubp1=bestiphotolimit(i)+4
call leafunivphotosyn(Prioriknowlimit,ilastrubp1,ifitmode,
&aPPFDlf(i),templeaf(i),pco2i(i),po2i(i),chlflphips2(i),
&anet_obs(i),weitresponses(i:i,1:1),weitresponses(i:i,1:1),
&weitresponses(i:i,2:2),weitresponses(i:i,1:1),
&pco2i_pred(i),anet_pred(i),Postiphotolimit(i),pco2c(i),
&PhiPSII_pred(i),anet_pred_flu(i),pco2i_pred_flu(i),
&pco2c_anet_flu(i),pco2c_pco2i_flu(i),term)
if(chlflphips2(i).lt.0.0d0)then
anet_pred_flu(i)=-9999.0d0
pco2i_pred_flu(i)=-9999.0d0
pco2c_anet_flu(i)=-9999.0d0
pco2c_pco2i_flu(i)=-9999.0d0
else
if(iabs(ifitmode).eq.1)then
pco2i_pred_flu(i)=-9999.0d0
pco2c_pco2i_flu(i)=-9999.0d0
endif
if(iabs(ifitmode).eq.2)then
anet_pred_flu(i)=-9999.0d0
pco2c_anet_flu(i)=-9999.0d0
endif
endif
enddo
return
end subroutine HybridCombinatorial
leafres/testarea/LeafGasFit_Stom.f
+627
View File
@@ -0,0 +1,627 @@
subroutine LeafGasFit_Stom(unitparamsout,unitwuecicacomp,
&unitstomcomp,curveno,curvename,npoints0,aPPFDlf0,templeaf0,
&tempair0,co2i_pa,co2a_pa,pres_air0,yAnet0,gswmeas0,vpdl0,trmmol0,
&abspt_lf_par,co2c_pa,co2recycleratio,stargamma25,ha_stargamma,
!
& siteID,Latitude,Longitude,Elevation,yearsampled,
& sampledoy,GrowingSeasonStart,GrowingSeasonEnd,
& standage,CanopyHeight,LeafAreaIndex,species,
& avetimeresolution,avetimesampled,SampleHeight,
& Needleage,specificLAI,nitrogencontent,carboncontent,
& phoscontent,woodporosity,sapwooddensity,leafratio)
implicit none
!
!----------Inputs-------------------------------------------
integer npoints0,unitparamsout,unitwuecicacomp,unitstomcomp,
&curveno
double precision aPPFDlf0(npoints0),templeaf0(npoints0),
&tempair0(npoints0),co2i_pa(npoints0),co2a_pa(npoints0),
&pres_air0(npoints0),yAnet0(npoints0),gswmeas0(npoints0),
&vpdl0(npoints0),trmmol0(npoints0),abspt_lf_par,
&co2c_pa(4,npoints0),co2recycleratio0(6,npoints0),
&stargamma25(6),ha_stargamma
character*100 curvename
character siteID*(*),species*(*),woodporosity*(*)
double precision Latitude,Longitude,Elevation,yearsampled,
&sampledoy,GrowingSeasonStart,GrowingSeasonEnd,standage,
&CanopyHeight,LeafAreaIndex,avetimeresolution,avetimesampled,
&SampleHeight,Needleage,specificLAI,nitrogencontent,
&carboncontent,phoscontent,sapwooddensity,leafratio
!----------Internal variables-------------------------------
integer npoints_stom,i,j,k,numparams,INFO,istommodel,malfit,
&imodel,iwrong,idostom,idocica,idowue,npoints
double precision co2threshold,co2current,vpdl_ref,gascon,
&templeaf_stom(npoints0),gswmeas_stom(npoints0),
&pres_air_stom(npoints0),xpco2i_stom(npoints0),
&yAnet_stom(npoints0),trmmol_stom(npoints0),stargamma(npoints0),
&pco2s(npoints0),rehulfsurf(npoints0),pvapordef_s(npoints0),
&combined1(npoints0),combined2(npoints0),wue(npoints0),
&wuemod(npoints0),wue_intrin(npoints0),wue_intrinmod(npoints0),
&cicameas(npoints0),cicamod(npoints0),gswmodcp(npoints0),
&gswmod1(npoints0),gswmod2(npoints0),gswmod(4,npoints0),
&sig(npoints0),ballintersurf,ballslopesurf,ballrsqsurf,
&ballinterinside,ballslopeinside,
&ballrsqinside,ballinter,ballslope,ballrsqgsw,esat,raysurfinter,
&raysurfslope,raysurfd0,raysurfrsqgsw,belindainter,belindaslope,
&belindad0,belindarsqgsw,dewarinter,dewarslope,deward0,dewarrsqgsw,
&wueref,der_wueref,rsqwue,alfit(10),der_alfit(10),wueref_intrin,
&der_wueref_intrin,rsqwue_intrin,blfit(10),der_blfit(10),cicaref,
&der_cicaref,rsqcica,avetleaf,avetair,avevpdl,avepari,term,
&ballrmsgsw,ballagrindgsw,raysurfrmsgsw,raysurfagrindgsw,
&belindarmsgsw,belindaagrindgsw,dewarrmsgsw,dewaragrindgsw,rmswue,
&agrindwue,rmswue_intrin,agrindwue_intrin,stomintercept,stomslope,
&rayDzero,rsqgsw,rmsgsw,agrindgsw,rmscica,agrindcica,cicafit(10),
&der_cicafit(10),bmin(10),bmax(10),rsqccci(4),rmsccci(4),
&agrindccci(4),cccifit(4,10),der_cccifit(4,10),ccciref(4),
&der_ccciref(4),co2iref,cccimeas(4,npoints0),cccimod(4,npoints0),
&avepres_air,rsqrecyc(6),rmsrecyc(6),agrindrecyc(6),recycfit(6,10),
&der_recycfit(6,10),recycref(6),der_recycref(6),
&recycmod(6,npoints0),aPPFDlf(npoints0),templeaf(npoints0),
&tempair(npoints0),co2i_ppm(npoints0),co2a_ppm(npoints0),
&pres_air(npoints0),yAnet(npoints0),gswmeas(npoints0),
&vpdl(npoints0),trmmol(npoints0),co2c_ppm(4,npoints0),
&co2recycleratio(6,npoints0)
parameter(gascon=8.314472d0,co2threshold=0.0d0,co2current=400.0d0,
&vpdl_ref=1600.0d0)
!if ambient co2 is too low, the ball-berry stomatal conductance model does not apply so we need to
!set up a threshold here
!this ambient CO2 threshold (250ppm) is taken from Gutschick and Simmonneau (2002)
!WUE are standardized for VPD at 50% relative humidity at 25 oC.
external lfitbasisfuncs
!-------------------------------------------------------------------------------------------
idostom=1
idowue=1
idocica=1
npoints=0
do j=1,npoints0
if(gswmeas0(j).gt.0.0d0.and.co2i_pa(j).gt.0.0d0.and.
&trmmol0(j).gt.0.0d0)then
npoints=npoints+1
aPPFDlf(npoints)=aPPFDlf0(j)
templeaf(npoints)=templeaf0(j)
tempair(npoints)=tempair0(j)
yAnet(npoints)=yAnet0(j)
co2i_ppm(npoints)=co2i_pa(j)*1.0d+6/pres_air0(j)
if(co2a_pa(j).gt.0.0d0)then
co2a_ppm(npoints)=co2a_pa(j)*1.0d+6/pres_air0(j)
else
co2a_ppm(npoints)=-9999.0d0
idocica=0
endif
pres_air(npoints)=pres_air0(j)
gswmeas(npoints)=gswmeas0(j)
trmmol(npoints)=trmmol0(j)
vpdl(npoints)=vpdl0(j)
do k=1,4
if(dabs(co2c_pa(k,j)+9999.0d0).gt.1.0d-5)then
co2c_ppm(k,npoints)=co2c_pa(k,j)*1.0d+6/pres_air0(j)
else
co2c_ppm(k,npoints)=-9999.0d0
endif
enddo
do k=1,6
co2recycleratio(k,npoints)=co2recycleratio0(k,j)
enddo
endif
enddo
if(npoints.le.3)return
avevpdl=0.0d0
avetleaf=0.0d0
avetair=0.0d0
avepari=0.0d0
avepres_air=0.0d0
do j=1,npoints
avevpdl=avevpdl+vpdl(j)
avetleaf=avetleaf+templeaf(j)
avetair=avetair+tempair(j)
avepari=avepari+aPPFDlf(j)/abspt_lf_par
avepres_air=avepres_air+pres_air(j)
enddo
avevpdl=avevpdl/dble(npoints)
avetleaf=avetleaf/dble(npoints)-273.15d0
avetair=avetair/dble(npoints)-273.15d0
avepari=avepari/dble(npoints)
avepres_air=avepres_air/dble(npoints)
if(avepres_air.lt.0.0d0)avepres_air=98000.0d0
!$$$$$$$$$$$$ Fitting stomatal conductance models $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
!Now fit the stomatal conductance models
npoints_stom=-9999
if(idostom.eq.1)then
npoints_stom=0
do j=1,npoints
if(co2a_ppm(j).gt.co2threshold.and.yAnet(j).gt.0.0d0)then
npoints_stom=npoints_stom+1
templeaf_stom(npoints_stom)=templeaf(j)
pres_air_stom(npoints_stom)=pres_air(j)
xpco2i_stom(npoints_stom)=co2i_ppm(j)
yAnet_stom(npoints_stom)=yAnet(j)
trmmol_stom(npoints_stom)=trmmol(j)
gswmeas_stom(npoints_stom)=gswmeas(j)
endif
enddo
if(npoints_stom.le.3)then
idostom=0
endif
endif
if(idostom.eq.1)then
do j=1,npoints_stom
call co2compens(templeaf_stom(j),stargamma25(5),ha_stargamma,
& gascon,stargamma(j))
!stargamma is in Pa, so convert it to ppm
term=esat(templeaf_stom(j),pres_air_stom(j))
stargamma(j)=1.0d+6*stargamma(j)/pres_air_stom(j)
pco2s(j)=xpco2i_stom(j)+1.6d0*yAnet_stom(j)/gswmeas_stom(j)
!mole fraction
pvapordef_s(j)=term/pres_air_stom(j)-
& 0.001d0*trmmol_stom(j)/gswmeas_stom(j)
!partial pressure
pvapordef_s(j)=pres_air_stom(j)*pvapordef_s(j)
!partial pressure deficit
pvapordef_s(j)=term-pvapordef_s(j)
pvapordef_s(j)=dmax1(0.0d0,pvapordef_s(j))
pvapordef_s(j)=dmin1(term,pvapordef_s(j))
rehulfsurf(j)=1.0d0-pvapordef_s(j)/term
combined1(j)=yAnet_stom(j)*rehulfsurf(j)/pco2s(j)
combined2(j)=yAnet_stom(j)*rehulfsurf(j)/xpco2i_stom(j)
enddo
malfit=2
do j=1,npoints_stom
sig(j)=1.0d0
enddo
call lfit(combined1,gswmeas_stom,sig,npoints_stom,alfit,
& malfit,malfit,lfitbasisfuncs,INFO)
do j=1,npoints_stom
gswmod1(j)=alfit(1)+alfit(2)*combined1(j)
enddo
call rsq_rms(gswmeas_stom,gswmod1,npoints_stom,rsqgsw,
& rmsgsw,agrindgsw)
ballintersurf=alfit(1)
ballslopesurf=alfit(2)
ballrsqsurf=rsqgsw
malfit=2
do j=1,npoints_stom
sig(j)=1.0d0
enddo
call lfit(combined2,gswmeas_stom,sig,npoints_stom,alfit,
& malfit,malfit,lfitbasisfuncs,INFO)
do j=1,npoints_stom
gswmod2(j)=alfit(1)+alfit(2)*combined2(j)
enddo
call rsq_rms(gswmeas_stom,gswmod2,npoints_stom,rsqgsw,
& rmsgsw,agrindgsw)
ballinterinside=alfit(1)
ballslopeinside=alfit(2)
ballrsqinside=rsqgsw
do istommodel=1,4
stomintercept=0.0001d0
stomslope=10.0d0
rayDzero=2000.0d0
if(istommodel.le.3)then
call StomRegression(npoints_stom,istommodel,pco2s,
& rehulfsurf,stargamma,yAnet_stom,gswmeas_stom,
& stomintercept,stomslope,pvapordef_s,rayDzero)
call stomoptimization(npoints_stom,istommodel,pco2s,
& rehulfsurf,stargamma,yAnet_stom,gswmeas_stom,
& stomintercept,stomslope,pvapordef_s,rayDzero)
do j=1,npoints_stom
call StomatalConductance(pco2s(j),rehulfsurf(j),
&stargamma(j),pvapordef_s(j),rayDzero,yAnet_stom(j),istommodel,
&stomintercept,stomslope,term)
gswmod(istommodel,j)=term
gswmodcp(j)=term
enddo
endif
if(istommodel.eq.4)then
!We experiment using internal CO2 to fit the dewar model
call StomRegression(npoints_stom,istommodel,xpco2i_stom,
& rehulfsurf,stargamma,yAnet_stom,gswmeas_stom,
& stomintercept,stomslope,pvapordef_s,rayDzero)
call stomoptimization(npoints_stom,istommodel,xpco2i_stom,
& rehulfsurf,stargamma,yAnet_stom,gswmeas_stom,
& stomintercept,stomslope,pvapordef_s,rayDzero)
do j=1,npoints_stom
call StomatalConductance(xpco2i_stom(j),
& rehulfsurf(j),stargamma(j),pvapordef_s(j),rayDzero,
& yAnet_stom(j),istommodel,
& stomintercept,stomslope,term)
gswmod(istommodel,j)=term
gswmodcp(j)=term
enddo
endif
call rsq_rms(gswmeas_stom,gswmodcp,
& npoints_stom,rsqgsw,rmsgsw,agrindgsw)
if(istommodel.eq.1)then
ballinter=stomintercept
ballslope=stomslope
ballrsqgsw=rsqgsw
ballrmsgsw=rmsgsw
ballagrindgsw=agrindgsw
endif
if(istommodel.eq.2)then
raysurfinter=stomintercept
raysurfslope=stomslope
raysurfd0=rayDzero
raysurfrsqgsw=rsqgsw
raysurfrmsgsw=rmsgsw
raysurfagrindgsw=agrindgsw
endif
if(istommodel.eq.3)then
belindainter=stomintercept
belindaslope=stomslope
belindad0=-9999.0d0
belindarsqgsw=rsqgsw
belindarmsgsw=rmsgsw
belindaagrindgsw=agrindgsw
endif
if(istommodel.eq.4)then
dewarinter=stomintercept
dewarslope=stomslope
deward0=rayDzero
dewarrsqgsw=rsqgsw
dewarrmsgsw=rmsgsw
dewaragrindgsw=agrindgsw
endif
enddo
do j=1,npoints_stom
write(unitstomcomp,370)curveno,trim(curvename),
& gswmeas_stom(j),gswmod1(j),gswmod2(j),gswmod(1,j),
& gswmod(2,j),gswmod(3,j),gswmod(4,j),xpco2i_stom(j),
& pco2s(j),rehulfsurf(j),stargamma(j),pvapordef_s(j),
& pres_air_stom(j),yAnet_stom(j)
enddo
else
ballintersurf=-9999.0d0
ballslopesurf=-9999.0d0
ballrsqsurf=-9999.0d0
ballinterinside=-9999.0d0
ballslopeinside=-9999.0d0
ballrsqinside=-9999.0d0
ballinter=-9999.0d0
ballslope=-9999.0d0
ballrsqgsw=-9999.0d0
ballrmsgsw=-9999.0d0
ballagrindgsw=-9999.0d0
raysurfinter=-9999.0d0
raysurfslope=-9999.0d0
raysurfd0=-9999.0d0
raysurfrsqgsw=-9999.0d0
raysurfrmsgsw=-9999.0d0
raysurfagrindgsw=-9999.0d0
belindainter=-9999.0d0
belindaslope=-9999.0d0
belindad0=-9999.0d0
belindarsqgsw=-9999.0d0
belindarmsgsw=-9999.0d0
belindaagrindgsw=-9999.0d0
dewarinter=-9999.0d0
dewarslope=-9999.0d0
deward0=-9999.0d0
dewarrsqgsw=-9999.0d0
dewarrmsgsw=-9999.0d0
dewaragrindgsw=-9999.0d0
endif
!$$$$$$$$$$$$ End of Stomatal Conductance Fit $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
!Now analyze the relationship of water use efficiency with ambient CO2
if(idowue.eq.1)then
do j=1,npoints
wue(j)=yAnet(j)/trmmol(j)
sig(j)=1.0d0
enddo
! malfit=3
! do j=1,npoints
! sig(j)=1.0d0
! enddo
! call lfit(co2a_ppm,wue,sig,npoints,alfit,malfit,malfit,
! & lfitbasisfuncs,INFO)
! do j=1,npoints
! wuemod(j)=alfit(1)+alfit(2)*co2a_ppm(j)+alfit(3)*
! & co2a_ppm(j)*co2a_ppm(j)/1000.0d0
! enddo
! call rsq_rms(wue,wuemod,npoints,rsqwue,rmswue,agrindwue)
! wueref=alfit(1)+alfit(2)*co2current+alfit(3)*
! & co2current*co2current/1000.0d0
! der_wueref=alfit(2)+2.0d0*alfit(3)*co2current/1000.0d0
alfit(1)=1.0d0
alfit(2)=0.1d0
alfit(3)=-20.0d0
alfit(4)=0.1d0
alfit(5)=100.0d0
bmin(1)=-1.0d+3
bmax(1)=1.0d+4
bmin(2)=-1.0d+4
bmax(2)=1.0d+5
bmin(3)=-1.0d+5
bmax(3)=1.0d+5
bmin(4)=-1.0d+5
bmax(4)=1.0d+5
bmin(5)=-1.0d+5
bmax(5)=1.0d+5
imodel=1
numparams=5
call cica_Regression5(npoints,wue,co2a_ppm,alfit,numparams,
&imodel,bmin,bmax)
call cicaoptimization5(npoints,wue,co2a_ppm,alfit,numparams,
&imodel,bmin,bmax)
do j=1,npoints
call cica_ca5(imodel,numparams,alfit,co2a_ppm(j),wuemod(j),
&der_wueref,der_alfit)
enddo
call cica_ca5(imodel,numparams,alfit,co2current,wueref,
&der_wueref,der_alfit)
call rsq_rms(wue,wuemod,npoints,rsqwue,rmswue,agrindwue)
!------------------------------------------------------------------------------
do j=1,npoints
wue_intrin(j)=yAnet(j)/gswmeas(j)
enddo
! call lfit(co2a_ppm,wue_intrin,sig,npoints,blfit,malfit,
! & malfit,lfitbasisfuncs,INFO)
! do j=1,npoints
! wue_intrinmod(j)=blfit(1)+blfit(2)*co2a_ppm(j)+
! & blfit(3)*co2a_ppm(j)*co2a_ppm(j)/1000.0d0
! enddo
! call rsq_rms(wue_intrin,wue_intrinmod,npoints,rsqwue_intrin,
! & rmswue,agrindwue)
! wueref_intrin=blfit(1)+blfit(2)*co2current+blfit(3)*
! & co2current*co2current/1000.0d0
! der_wueref_intrin=blfit(2)+2.0d0*blfit(3)*co2current/1000.0d0
blfit(1)=1.0d0
blfit(2)=0.10
blfit(3)=-20.0d0
blfit(4)=0.1d0
blfit(5)=100.0d0
bmin(1)=-1.0d+5
bmax(1)=1.0d+5
bmin(2)=-1.0d+5
bmax(2)=1.0d+5
bmin(3)=-1.0d+5
bmax(3)=1.0d+5
bmin(4)=-1.0d+5
bmax(4)=1.0d+5
bmin(5)=-1.0d+5
bmax(5)=1.0d+5
numparams=5
imodel=1
call cica_Regression5(npoints,wue_intrin,co2a_ppm,
&blfit,numparams,imodel,bmin,bmax)
call cicaoptimization5(npoints,wue_intrin,co2a_ppm,
&blfit,numparams,imodel,bmin,bmax)
do j=1,npoints
call cica_ca5(imodel,numparams,blfit,co2a_ppm(j),
&wue_intrinmod(j),der_wueref_intrin,der_blfit)
enddo
call cica_ca5(imodel,numparams,blfit,co2current,
&wueref_intrin,der_wueref_intrin,der_blfit)
call rsq_rms(wue_intrin,wue_intrinmod,npoints,rsqwue_intrin,
&rmswue,agrindwue)
else
rsqwue=-9999.0d0
rmswue=-9999.0d0
agrindwue=-9999.d0
wueref=-9999.0d0
der_wueref=-9999.0d0
avevpdl=-9999.0d0
avetleaf=-9999.0d0
avetair=-9999.0d0
do j=1,npoints
wue(j)=-9999.0d0
wuemod(j)=-9999.0d0
wue_intrin(j)=-9999.0d0
wue_intrinmod(j)=-9999.0d0
enddo
rsqwue_intrin=-9999.0d0
wueref_intrin=-9999.0d0
der_wueref_intrin=-9999.0d0
do j=1,numparams
alfit(j)=-9999.0d0
blfit(j)=-9999.0d0
enddo
endif
!----------------------------------------------------------------------------
!Now analyze the relationship of Ci/Ca ratio with ambient CO2 and Cc/Ci with Ci
100 term=co2a_ppm(1)
do j=2,npoints
if(co2a_ppm(j).gt.term)then
term=co2a_ppm(j)
endif
enddo
bmin(1)=-1.0d+2
bmax(1)=1.0d+2
bmin(2)=-300.0d0/term
bmax(2)=1.0d+6
if(idocica.eq.1)then
do j=1,npoints
cicameas(j)=co2i_ppm(j)/co2a_ppm(j)
enddo
!Ci/Ca=a*exp(-b*Ca)+c+d*ln(co2a)+e*(ln(co2))**2
cicafit(1)=1.5874d0
cicafit(2)=2.0343d0
cicafit(3)=0.8779d0
cicafit(4)=0.1d0
cicafit(5)=0.01d0
bmin(3)=-1.0d+2
bmax(3)=1.0d+2
bmin(4)=-1.0d+2
bmax(4)=1.0d+2
bmin(5)=-1.0d+2
bmax(5)=1.0d+2
numparams=5
imodel=3
call cica_Regression5(npoints,cicameas,co2a_ppm,
&cicafit,numparams,imodel,bmin,bmax)
call cicaoptimization5(npoints,cicameas,co2a_ppm,
&cicafit,numparams,imodel,bmin,bmax)
do j=1,npoints
call cica_ca5(imodel,numparams,cicafit,co2a_ppm(j),
&cicamod(j),der_cicaref,der_cicafit)
enddo
call cica_ca5(imodel,numparams,cicafit,co2current,
&cicaref,der_cicaref,der_cicafit)
call rsq_rms(cicameas,cicamod,npoints,rsqcica,rmscica,
& agrindcica)
else
do j=1,npoints
cicamod(j)=-9999.0d0
enddo
rsqcica=-9999.0d0
rmscica=-9999.0d0
agrindcica=-9999.0d0
cicaref=-9999.0d0
der_cicaref=-9999.0d0
do j=1,numparams
cicafit(j)=-9999.0d0
der_cicafit(j)=-9999.0d0
enddo
endif
!--------------------------------------------------------------------------
!below we fit Cc/Ci
110 do i=1,4
do j=1,npoints
cccimeas(i,j)=co2c_ppm(i,j)/co2i_ppm(j)
enddo
if(co2c_ppm(i,1).ge.0.0d0)then
cccifit(i,1)=2.5874d0
cccifit(i,2)=2.0343d0
cccifit(i,3)=0.8779d0
cccifit(i,4)=0.1d0
cccifit(i,5)=0.01d0
cccifit(i,6)=0.001d0
bmin(3)=-1.0d+2
bmax(3)=1.0d+2
bmin(4)=-1.0d+2
bmax(4)=1.0d+2
bmin(5)=-1.0d+2
bmax(5)=1.0d+2
bmin(6)=-1.0d+2
bmax(6)=1.0d+2
numparams=6
imodel=3
call cica_Regression5(npoints,cccimeas(i:i,1:npoints),
&co2i_ppm,cccifit(i:i,1:numparams),numparams,imodel,bmin,bmax)
call cicaoptimization5(npoints,cccimeas(i:i,1:npoints),
&co2i_ppm,cccifit(i:i,1:numparams),numparams,imodel,bmin,bmax)
do j=1,npoints
call cica_ca5(imodel,numparams,cccifit(i:i,1:numparams),
&co2i_ppm(j),cccimod(i,j),der_ccciref(i),der_cccifit)
enddo
if(dabs(cicaref+9999.0d0).gt.1.0d-5)then
co2iref=cicaref*co2current
else
co2iref=0.75d0*co2current
endif
call cica_ca5(imodel,numparams,cccifit(i:i,1:numparams),
&co2iref,ccciref(i),der_ccciref(i),der_cccifit)
call rsq_rms(cccimeas(i:i,1:npoints),cccimod(i:i,1:npoints),
&npoints,rsqccci(i),rmsccci(i),agrindccci(i))
else
do j=1,npoints
cccimod(i,j)=-9999.0d0
enddo
rsqccci(i)=-9999.0d0
rmsccci(i)=-9999.0d0
agrindccci(i)=-9999.0d0
ccciref(i)=-9999.0d0
der_ccciref(i)=-9999.0d0
do j=1,numparams
cccifit(i,j)=-9999.0d0
enddo
endif
enddo
!-----------------------------------------------------------------------
!now we fit CO2 recycling ratio
do i=1,6
if(co2recycleratio(i,1).ge.0.0d0)then
recycfit(i,1)=2.5874d0
recycfit(i,2)=2.0343d0
recycfit(i,3)=0.8779d0
recycfit(i,4)=0.1d0
recycfit(i,5)=0.01d0
recycfit(i,6)=0.001d0
bmin(3)=-1.0d+2
bmax(3)=1.0d+2
bmin(4)=-1.0d+2
bmax(4)=1.0d+2
bmin(5)=-1.0d+2
bmax(5)=1.0d+2
bmin(6)=-1.0d+2
bmax(6)=1.0d+2
numparams=5
imodel=3
call cica_Regression5(npoints,co2recycleratio(i:i,1:npoints),
&co2i_ppm,recycfit(i:i,1:numparams),numparams,imodel,bmin,bmax)
call cicaoptimization5(npoints,co2recycleratio(i:i,1:npoints),
&co2i_ppm,recycfit(i:i,1:numparams),numparams,imodel,bmin,bmax)
do j=1,npoints
call cica_ca5(imodel,numparams,recycfit(i:i,1:numparams),
&co2i_ppm(j),recycmod(i,j),der_recycref(i),der_recycfit)
enddo
if(dabs(cicaref+9999.0d0).gt.1.0d-5)then
co2iref=cicaref*co2current
else
co2iref=0.75d0*co2current
endif
call cica_ca5(imodel,numparams,recycfit(i:i,1:numparams),
&co2iref,recycref(i),der_recycref(i),der_recycfit)
call rsq_rms(co2recycleratio(i:i,1:npoints),
&recycmod(i:i,1:npoints),npoints,rsqrecyc(i),rmsrecyc(i),
&agrindrecyc(i))
else
do j=1,npoints
recycmod(i,j)=-9999.0d0
enddo
rsqrecyc(i)=-9999.0d0
rmsrecyc(i)=-9999.0d0
agrindrecyc(i)=-9999.0d0
recycref(i)=-9999.0d0
der_recycref(i)=-9999.0d0
do j=1,numparams
recycfit(i,j)=-9999.0d0
enddo
endif
enddo
!-----------------------------------------------------------------------
do j=1,npoints
write(unitwuecicacomp,380)curveno,trim(curvename),co2a_ppm(j),
&vpdl(j),wue(j),wuemod(j),cicameas(j),cicamod(j),wue_intrin(j),
&wue_intrinmod(j),((cccimeas(k,j),cccimod(k,j)),k=1,4),
&((co2recycleratio(k,j),recycmod(k,j)),k=1,6)
enddo
write(unitparamsout,390)curveno,trim(curvename),npoints_stom,
&co2threshold,co2current,vpdl_ref,ballintersurf,ballslopesurf,
&ballrsqsurf,ballinterinside,ballslopeinside,ballrsqinside,
&ballinter,ballslope,ballrsqgsw,raysurfinter,raysurfslope,
&raysurfd0,raysurfrsqgsw,belindainter,belindaslope,
&belindad0,belindarsqgsw,dewarinter,dewarslope,deward0,
&dewarrsqgsw,wueref,der_wueref,rsqwue,(alfit(i),i=1,5),
&wueref_intrin,der_wueref_intrin,rsqwue_intrin,(blfit(i),i=1,5),
&cicaref,der_cicaref,rsqcica,(cicafit(i),i=1,5),
&avetleaf,avetair,avevpdl,avepari,((ccciref(i),der_ccciref(i),
&rsqccci(i),(cccifit(i,j),j=1,6)),i=1,4),
&((recycref(i),der_recycref(i),
&rsqrecyc(i),(recycfit(i,j),j=1,5)),i=1,6),
!
&trim(siteID),Latitude,Longitude,Elevation,yearsampled,
&sampledoy,GrowingSeasonStart,GrowingSeasonEnd,
&standage,CanopyHeight,LeafAreaIndex,trim(species),
&avetimeresolution,avetimesampled,SampleHeight,
&Needleage,specificLAI,nitrogencontent,carboncontent,
&phoscontent,trim(woodporosity),sapwooddensity,leafratio
370 format(i0,',',a,',',13(f0.8,','),f0.8)
380 format(i0,',',a,',',27(f0.8,','),f0.8)
390 format(i0,',',a,',',i0,',',136(f0.8,','),a,',',10(f0.8,','),
&a,',',8(f0.8,','),a,',',f0.8,',',f0.8)
return
end subroutine LeafGasFit_Stom
leafres/testarea/LeafGasHybridFit.h
+239
View File
@@ -0,0 +1,239 @@
! This file contains common blocks used in the optimization runs.
!
! ------ Optimization variables common Blocks ---------------------
! maxobs: the maximum number of observations
! maxpsnparam: the maximum number of parameters to be optimized
! aPPFDlf: PAR absorbed by leaf (umol m-2 s-1)
! templeaf: leaf temperature (K)
! xpco2i: Intercellular CO2 partial pressure (Pa)
! po2i: Intercellular oxygen partial pressure (Pa)
! obs_psn: net photosynthetic rate (umol m-2 s-1)
! psnparamx: parameters in the leaf photosynthetic model
! nobs: integer, the actual number of observations
! IFIXBcp: the index for the parameters in psnparams that are being
! optimized (0= not optimized; 1= optimized)
! ilimittype: indicator for the choice of limitation types
! = 1, Rubisco+RuBP+TPU'
! = 2, Rubisco+RuBP
! = 3, Rubisco+TPU
! = 4, RuBP+TPU
! = 5, Rubisco Only
! = 6, RuBP Only
! = 7, TPU Only
! betamin: the lower bound of the parameters to be optimized
! betamax: the upper bound of the parameters to be optimized
!resistwp: =rwp, resistance to CO2 via cell walls and plasmalemma (Pa s m2 umol-1). If less than zero, set to zero.
!resistch: =rch, resistance to CO2 via chloroplast envelope and stroma (Pa s m2 umol-1). If less than zero, set to zero.
!idorwp, =0 zero rwp
! =1 fit for rwp
! =2 keep input rwp and don't optimize it
!idorch, =0 zero rch
! =1 fit for rch
! =2 keep input rch and don't optimize it
! ntotparams: the total number of optimized and unoptimized parameters
! isitgridsearch=0, in optimization mode (cij+cic is the transition RuBp-TPU CO2i threshold)
! =1, in grid search mode (cij is the transition RuBp-TPU CO2i threshold)
integer maxobs,maxcurves
parameter (maxobs=200,maxcurves=15)
double precision anet_obs(maxobs),pco2i(maxobs),templeaf(maxobs),
&aPPFDlf(maxobs),pres_air(maxobs),po2i(maxobs),chlflphips2(maxobs),
&pco2ambient(maxobs),trmmol(maxobs),gswmeas(maxobs),vpdl(maxobs),
&tempair(maxobs),eambient(maxobs),resiststomco2(maxobs),sumsquare,
&pco2i_ori(maxobs),templeaf_ori(maxobs),aPPFDlf_ori(maxobs),
&pres_air_ori(maxobs),po2i_ori(maxobs),chlflphips2_ori(maxobs),
&pco2ambient_ori(maxobs),trmmol_ori(maxobs),gswmeas_ori(maxobs),
&vpdl_ori(maxobs),tempair_ori(maxobs),eambient_ori(maxobs),
&fo_pam(maxobs),fm_pam(maxobs),fs_pam(maxobs),
&pam_measlight(maxobs),yield_ps2(maxobs),yield_npq(maxobs),
&qlake(maxobs),qpuddle(maxobs),kps2_norm(maxobs),knpq_norm(maxobs),
&resiststomco2_ori(maxobs),pco2i_pred(maxobs),anet_pred(maxobs),
&PhiPSII_pred(maxobs),pco2c(maxobs),bestsumsquare,
&subbestsumsquare(7),forcings(maxobs,10),weitforcings(maxobs,10),
&responses(maxobs,5),weitresponses(maxobs,5),
&pco2i_pred_flu(maxobs),anet_pred_flu(maxobs),
&pco2c_pco2i_flu(maxobs),pco2c_anet_flu(maxobs),
&PhiPSIIlights_pred(maxobs),templflights(maxobs),
&aparlights(maxobs),flphips2lights(maxobs),flujmaxfval,
&Fixedanet_obs(maxobs/4),Fixedpco2i(maxobs/4),
&Fixedtempleaf(maxobs/4),FixedaPPFDlf(maxobs/4),
&Fixedpres_air(maxobs/4),Fixedpo2i(maxobs/4),
&Fixedchlflphips2(maxobs/4),Fixedpco2ambient(maxobs/4),
&Fixedtrmmol(maxobs/4),Fixedgswmeas(maxobs/4),
&Fixedvpdl(maxobs/4),Fixedtempair(maxobs/4),
&Fixedeambient(maxobs/4),Fixedfo_pam(maxobs/4),
&Fixedfm_pam(maxobs/4),Fixedfs_pam(maxobs/4),
&Fixedpam_measlight(maxobs/4),Fixedyield_ps2(maxobs/4),
&Fixedyield_npq(maxobs/4),Fixedqlake(maxobs/4),
&Fixedqpuddle(maxobs/4),Fixedkps2_norm(maxobs/4),
&Fixedknpq_norm(maxobs/4),Fixedresiststomco2(maxobs/4),
&ACianet_obs0(maxobs/4,maxcurves),ACipco2i0(maxobs/4,maxcurves),
&ACitempleaf0(maxobs/4,maxcurves),ACiaPPFDlf0(maxobs/4,maxcurves),
&ACipres_air0(maxobs/4,maxcurves),ACipo2i0(maxobs/4,maxcurves),
&ACichlflphips20(maxobs/4,maxcurves),
&ACipco2ambient0(maxobs/4,maxcurves),
&ACitrmmol0(maxobs/4,maxcurves),ACigswmeas0(maxobs/4,maxcurves),
&ACivpdl0(maxobs/4,maxcurves),ACitempair0(maxobs/4,maxcurves),
&ACieambient0(maxobs/4,maxcurves),ACifo_pam0(maxobs/4,maxcurves),
&ACifm_pam0(maxobs/4,maxcurves),ACifs_pam0(maxobs/4,maxcurves),
&ACipam_measlight0(maxobs/4,maxcurves),
&ACiyield_ps20(maxobs/4,maxcurves),
&ACiyield_npq0(maxobs/4,maxcurves),ACiqlake0(maxobs/4,maxcurves),
&ACiqpuddle0(maxobs/4,maxcurves),ACikps2_norm0(maxobs/4,maxcurves),
&ACiknpq_norm0(maxobs/4,maxcurves),
&ACiresiststomco20(maxobs/4,maxcurves),
&ACianet_obs(maxobs/4,maxcurves),ACipco2i(maxobs/4,maxcurves),
&ACitempleaf(maxobs/4,maxcurves),ACiaPPFDlf(maxobs/4,maxcurves),
&ACipres_air(maxobs/4,maxcurves),ACipo2i(maxobs/4,maxcurves),
&ACichlflphips2(maxobs/4,maxcurves),
&ACipco2ambient(maxobs/4,maxcurves),
&ACitrmmol(maxobs/4,maxcurves),ACigswmeas(maxobs/4,maxcurves),
&ACivpdl(maxobs/4,maxcurves),ACitempair(maxobs/4,maxcurves),
&ACieambient(maxobs/4,maxcurves),ACifo_pam(maxobs/4,maxcurves),
&ACifm_pam(maxobs/4,maxcurves),ACifs_pam(maxobs/4,maxcurves),
&ACipam_measlight(maxobs/4,maxcurves),
&ACiyield_ps2(maxobs/4,maxcurves),
&ACiyield_npq(maxobs/4,maxcurves),ACiqlake(maxobs/4,maxcurves),
&ACiqpuddle(maxobs/4,maxcurves),ACikps2_norm(maxobs/4,maxcurves),
&ACiknpq_norm(maxobs/4,maxcurves),
&ACiresiststomco2(maxobs/4,maxcurves),
&ALightanet_obs0(maxobs/4,maxcurves),
&ALightpco2i0(maxobs/4,maxcurves),
&ALighttempleaf0(maxobs/4,maxcurves),
&ALightaPPFDlf0(maxobs/4,maxcurves),
&ALightpres_air0(maxobs/4,maxcurves),
&ALightpo2i0(maxobs/4,maxcurves),
&ALightchlflphips20(maxobs/4,maxcurves),
&ALightpco2ambient0(maxobs/4,maxcurves),
&ALighttrmmol0(maxobs/4,maxcurves),
&ALightgswmeas0(maxobs/4,maxcurves),
&ALightvpdl0(maxobs/4,maxcurves),
&ALighttempair0(maxobs/4,maxcurves),
&ALighteambient0(maxobs/4,maxcurves),
&ALightfo_pam0(maxobs/4,maxcurves),
&ALightfm_pam0(maxobs/4,maxcurves),
&ALightfs_pam0(maxobs/4,maxcurves),
&ALightpam_measlight0(maxobs/4,maxcurves),
&ALightyield_ps20(maxobs/4,maxcurves),
&ALightyield_npq0(maxobs/4,maxcurves),
&ALightqlake0(maxobs/4,maxcurves),
&ALightqpuddle0(maxobs/4,maxcurves),
&ALightkps2_norm0(maxobs/4,maxcurves),
&ALightknpq_norm0(maxobs/4,maxcurves),
&ALightresiststomco20(maxobs/4,maxcurves),
&ALightanet_obs(maxobs/4,maxcurves),
&ALightpco2i(maxobs/4,maxcurves),
&ALighttempleaf(maxobs/4,maxcurves),
&ALightaPPFDlf(maxobs/4,maxcurves),
&ALightpres_air(maxobs/4,maxcurves),
&ALightpo2i(maxobs/4,maxcurves),
&ALightchlflphips2(maxobs/4,maxcurves),
&ALightpco2ambient(maxobs/4,maxcurves),
&ALighttrmmol(maxobs/4,maxcurves),
&ALightgswmeas(maxobs/4,maxcurves),
&ALightvpdl(maxobs/4,maxcurves),
&ALighttempair(maxobs/4,maxcurves),
&ALighteambient(maxobs/4,maxcurves),
&ALightfo_pam(maxobs/4,maxcurves),
&ALightfm_pam(maxobs/4,maxcurves),
&ALightfs_pam(maxobs/4,maxcurves),
&ALightpam_measlight(maxobs/4,maxcurves),
&ALightyield_ps2(maxobs/4,maxcurves),
&ALightyield_npq(maxobs/4,maxcurves),
&ALightqlake(maxobs/4,maxcurves),
&ALightqpuddle(maxobs/4,maxcurves),
&ALightkps2_norm(maxobs/4,maxcurves),
&ALightknpq_norm(maxobs/4,maxcurves),
&ALightresiststomco2(maxobs/4,maxcurves),
&Freeanet_obs(maxobs/4),Freepco2i(maxobs/4),
&Freetempleaf(maxobs/4),FreeaPPFDlf(maxobs/4),
&Freepres_air(maxobs/4),Freepo2i(maxobs/4),
&Freechlflphips2(maxobs/4),Freepco2ambient(maxobs/4),
&Freetrmmol(maxobs/4),Freegswmeas(maxobs/4),
&Freevpdl(maxobs/4),Freetempair(maxobs/4),
&Freeeambient(maxobs/4),Freefo_pam(maxobs/4),
&Freefm_pam(maxobs/4),Freefs_pam(maxobs/4),
&Freepam_measlight(maxobs/4),Freeyield_ps2(maxobs/4),
&Freeyield_npq(maxobs/4),Freeqlake(maxobs/4),
&Freeqpuddle(maxobs/4),Freekps2_norm(maxobs/4),
&Freeknpq_norm(maxobs/4),Freeresiststomco2(maxobs/4)
integer ifitmode,ntotsamples,ntotphips2,nFixedPoints,numACicurves,
&nACiPoints(maxcurves),numALightcurves,nALightPoints(maxcurves),
&nFreePoints,Fixediphotolimit(maxobs),
&ACiiphotolimit(maxobs/4,maxcurves),
&ALightiphotolimit(maxobs/4,maxcurves),Freeiphotolimit(maxobs/4),
&Prioriphotolimit(maxobs),Priorilimittype,Prioriknowlimit,
&Currentiphotolimit(maxobs),Currentilimittype,Currentiknowlimit,
&Postiphotolimit(maxobs),bestiphotolimit(maxobs),bestilimittype,
&subbestiphotolimit(maxobs,7),nendaci(maxcurves),
&nstartaci(maxcurves),nendalight(maxcurves),
&nstartalight(maxcurves),ialightorder(maxcurves),ntotlights,
&ialightrubpmin(maxcurves),ialightrubpmax(maxcurves),
&ialightmin(maxcurves),ialightmax(maxcurves)
common /dbleleafgasobservations/anet_obs,pco2i,templeaf,
&aPPFDlf,pres_air,po2i,chlflphips2,pco2ambient,trmmol,gswmeas,
&vpdl,tempair,eambient,resiststomco2,sumsquare,pco2i_ori,
&templeaf_ori,aPPFDlf_ori,pres_air_ori,po2i_ori,chlflphips2_ori,
&pco2ambient_ori,trmmol_ori,gswmeas_ori,vpdl_ori,tempair_ori,
&eambient_ori,fo_pam,fm_pam,fs_pam,pam_measlight,yield_ps2,
&yield_npq,qlake,qpuddle,kps2_norm,knpq_norm,
&resiststomco2_ori,pco2i_pred,anet_pred,PhiPSII_pred,
&pco2c,bestsumsquare,subbestsumsquare,forcings,weitforcings,
&responses,weitresponses,pco2i_pred_flu,anet_pred_flu,
&pco2c_pco2i_flu,pco2c_anet_flu,PhiPSIIlights_pred,templflights,
&aparlights,flphips2lights,flujmaxfval,
&Fixedanet_obs,Fixedpco2i,Fixedtempleaf,FixedaPPFDlf,Fixedpres_air,
&Fixedpo2i,Fixedchlflphips2,Fixedpco2ambient,Fixedtrmmol,
&Fixedgswmeas,Fixedvpdl,Fixedtempair,Fixedeambient,Fixedfo_pam,
&Fixedfm_pam,Fixedfs_pam,Fixedpam_measlight,Fixedyield_ps2,
&Fixedyield_npq,Fixedqlake,Fixedqpuddle,Fixedkps2_norm,
&Fixedknpq_norm,Fixedresiststomco2,
&ACianet_obs0,ACipco2i0,ACitempleaf0,ACiaPPFDlf0,ACipres_air0,
&ACipo2i0,ACichlflphips20,ACipco2ambient0,ACitrmmol0,ACigswmeas0,
&ACivpdl0,ACitempair0,ACieambient0,ACifo_pam0,ACifm_pam0,
&ACifs_pam0,ACipam_measlight0,ACiyield_ps20,ACiyield_npq0,
&ACiqlake0,ACiqpuddle0,ACikps2_norm0,ACiknpq_norm0,
&ACiresiststomco20,ACianet_obs,
&ACipco2i,ACitempleaf,ACiaPPFDlf,ACipres_air,ACipo2i,
&ACichlflphips2,ACipco2ambient,ACitrmmol,ACigswmeas,ACivpdl,
&ACitempair,ACieambient,ACifo_pam,ACifm_pam,ACifs_pam,
&ACipam_measlight,ACiyield_ps2,ACiyield_npq,ACiqlake,ACiqpuddle,
&ACikps2_norm,ACiknpq_norm,ACiresiststomco2,ALightanet_obs0,
&ALightpco2i0,ALighttempleaf0,ALightaPPFDlf0,ALightpres_air0,
&ALightpo2i0,ALightchlflphips20,ALightpco2ambient0,ALighttrmmol0,
&ALightgswmeas0,ALightvpdl0,ALighttempair0,ALighteambient0,
&ALightfo_pam0,ALightfm_pam0,ALightfs_pam0,ALightpam_measlight0,
&ALightyield_ps20,ALightyield_npq0,ALightqlake0,ALightqpuddle0,
&ALightkps2_norm0,ALightknpq_norm0,
&ALightresiststomco20,ALightanet_obs,ALightpco2i,ALighttempleaf,
&ALightaPPFDlf,ALightpres_air,ALightpo2i,ALightchlflphips2,
&ALightpco2ambient,ALighttrmmol,ALightgswmeas,ALightvpdl,
&ALighttempair,ALighteambient,ALightfo_pam,ALightfm_pam,
&ALightfs_pam,ALightpam_measlight,ALightyield_ps2,
&ALightyield_npq,ALightqlake,ALightqpuddle,ALightkps2_norm,
&ALightknpq_norm,ALightresiststomco2,Freeanet_obs,
&Freetempleaf,FreeaPPFDlf,Freepres_air,Freepo2i,Freechlflphips2,
&Freepco2ambient,Freetrmmol,Freegswmeas,Freevpdl,Freetempair,
&Freeeambient,Freefo_pam,Freefm_pam,Freefs_pam,Freepam_measlight,
&Freeyield_ps2,Freeyield_npq,Freeqlake,Freeqpuddle,Freekps2_norm,
&Freeknpq_norm,Freeresiststomco2
common /intleafgasobservations/ifitmode,ntotsamples,ntotphips2,
&nFixedPoints,numACicurves,nACiPoints,numALightcurves,
&nALightPoints,nFreePoints,
&Fixediphotolimit,ACiiphotolimit,ALightiphotolimit,Freeiphotolimit,
&Prioriphotolimit,Priorilimittype,Prioriknowlimit,
&Currentiphotolimit,Currentilimittype,Currentiknowlimit,
&Postiphotolimit,bestiphotolimit,bestilimittype,subbestiphotolimit,
&nendaci,nstartaci,nendalight,nstartalight,ialightorder,ntotlights,
&ialightrubpmin,ialightrubpmax,ialightmin,ialightmax
save /dbleleafgasobservations/,/intleafgasobservations/
!-------- End of list of common block variables ------------------
leafres/testarea/LeafGasPISCAL_mpi.f
+364
View File
@@ -0,0 +1,364 @@
!Photosynthetic, Internal and Stomatal Conductance Analyses of Leaves (PISCAL)
!
!Created by: Lianhong Gu
! Environmental Sciences Dvision
! Oak Ridge National Laboratory
! Oak Ridge, TN 37831
! lianhong-gu@ornl.gov
!with support from Department of Energy Office of Science, Biological
!and Environmental Research Program
!
!PISCAL first created 10 July 2008
!Paralle PISCAL 20 Feb 2013
!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()
program main
implicit none
include 'mpif.h'
integer dataunit,spareunit,ierr(2),runvalues(8),ipos1,ipos2,
&ntotfiles,noutputfiles,i,j,k,rank_mpi,numproc_mpi,numproc,
&ierror_mpi,nshare,nmod,npartfiles,istartno,iendno,indexunit(20),
&numchar,needheader(20),rootprocess
character rundate*8,runtime*10,runzone*5,longchar*5000,achar*5,
&longchar1*5000
character*100 datapath,outpath,storein,storeout,ACidata(8000)
character*50 AllACiFiles,outputfile(20)
! Set input / output directory
parameter(
& datapath=
! &'/home/l2g/ngeetropics/gamboa/curves/',
! &'/home/l2g/ngeetropics/metropolitano/curves/',
! &'/home/l2g/ngeetropics/fortsherman/curves/',
! & '/home/l2g/ngeetropics/kelsey/curves/',
! & '/home/l2g/leafres/hybriddata/Berner/',
& '/home/l2g/SingleLeafModel/ACiSimulation/hybrid/',
! &'/home/l2g/leafweb/data/dweston/Sphagnum_leafweb_Oct2015/',
! & '/home/l2g/SingleLeafModel/ACiSimulation/wenting/',
! &'/home/l2g/leafres/hybriddata/dwestonpoplus/data_Pn_tree_1_195_v2/
! &',
! &'/home/l2g/leafres/hybriddata/dwestonpoplus/data3/',
! &'/home/l2g/leafres/hybriddata/cernusak/2014data/',
! & '/home/l2g/dataassim/leaf/data/moflux/2008/inputs/',
! & '/home/l2g/leafres/hybriddata/sphagnum/2014data1/',
!for moflux data, 2004-2008 requires correction of Ci. Other years do not
! & '/home/l2g/dataassim/leaf/data/LawData/inputs/',
! & '/home/l2g/dataassim/leaf/data/dweston/inputs/',
! & '/home/l2g/dataassim/leaf/data/johnbaker/inputs/',
! & '/home/l2g/dataassim/leaf/data/martins/inputs/',
! & '/home/l2g/dataassim/leaf/data/benzi/inputs/',
! & '/home/l2g/dataassim/leaf/data/loos/inputs/',
! & '/home/l2g/dataassim/leaf/data/ellsworth/inputs/',
! & '/home/l2g/dataassim/leaf/data/fromleafweb/inputs/',
! & '/home/l2g/SingleLeafModel/ACiSimulation/testkco/',
! & '/home/l2g/SingleLeafModel/ACiSimulation/rwprch/',
! & '/home/l2g/dataassim/leaf/data/panama/sept2012/inputs/',
! &'/home/l2g/dataassim/leaf/data/williams/inputs/',
! & '/home/l2g/dataassim/leaf/test/',
! & '/home/l2g/SingleLeafModel/ACiSimulation/Martins/',
! & '/home/l2g/SingleLeafModel/ACiSimulation/collantes/',
! & '/home/l2g/dataassim/leaf/data/dweston/inputs/',
! & '/home/l2g/GEMSiS/curves/',
& outpath=
! &'/home/l2g/ngeetropics/gamboa/results/',
! &'/home/l2g/ngeetropics/metropolitano/results/',
! &'/home/l2g/ngeetropics/fortsherman/',
! &'/home/l2g/ngeetropics/kelsey/results/',
! & '/home/l2g/leafres/hybriddata/Berner/',
& '/home/l2g/SingleLeafModel/ACiSimulation/hybrid/',
! &'/home/l2g/leafweb/data/dweston/Sphagnum_leafweb_Oct2015/',
! &'/home/l2g/leafres/hybriddata/cernusak/2014data/',
! & '/home/l2g/SingleLeafModel/ACiSimulation/wenting/',
! &'/home/l2g/leafres/hybriddata/dwestonpoplus/data3/',
! &'/home/l2g/leafres/hybriddata/dwestonpoplus/data_Pn_tree_1_195_v2/
! &',
! & '/home/l2g/dataassim/leaf/data/moflux/2008/outputs/',
! & '/home/l2g/dataassim/leaf/data/moflux/2012/outputs/',
! & '/home/l2g/dataassim/leaf/data/LawData/outputs/',
! & '/home/l2g/dataassim/leaf/data/dweston/outputs/',
! & '/home/l2g/dataassim/leaf/data/johnbaker/outputs/',
! & '/home/l2g/dataassim/leaf/data/martins/outputs/',
! & '/home/l2g/dataassim/leaf/data/benzi/outputs/',
! & '/home/l2g/dataassim/leaf/data/loos/outputs/',
! & '/home/l2g/dataassim/leaf/data/ellsworth/outputs/',
! &'/home/l2g/leafres/hybriddata/sphagnum/2014results1/',
! &'/home/l2g/junk/',
! & '/home/l2g/SingleLeafModel/ACiSimulation/testkco/',
! & '/home/l2g/SingleLeafModel/ACiSimulation/rwprch/results/',
! & '/home/l2g/dataassim/leaf/data/panama/sept2012/outputs/',
! &'/home/l2g/dataassim/leaf/data/panama/sept2012/outputs/rwprch/',
! & '/home/l2g/mpitest/',
! &'/home/l2g/dataassim/leaf/data/williams/outputs/',
! & '/home/l2g/dataassim/leaf/data/fromleafweb/outputs/withpad/',
! & '/home/l2g/dataassim/leaf/test/',
! & '/home/l2g/SingleLeafModel/ACiSimulation/collantes/',
! & '/home/l2g/SingleLeafModel/ACiSimulation/Martins/',
! & '/home/l2g/dataassim/leaf/data/dweston/outputs/',
! & '/home/l2g/GEMSiS/results/',
! &storein='/home/l2g/leafweb/users/curves/',
! &storeout='/home/l2g/leafweb/users/results/',
&storein='/home/l2g/clm/results/',
&storeout='/home/l2g/clm/results/',
! &storein='/home/l2g/junk/',
! &storeout='/home/l2g/junk/',
! &storein='/home/l2g/dataassim/leaf/data/ellsworth/outputs/',
! &storeout='/home/l2g/dataassim/leaf/data/ellsworth/outputs/',
& AllACiFiles='AllLeafGasFiles')
!---------------End of variable declaration----------------
rootprocess=0
dataunit=1
spareunit=3
! if(rank_mpi.ne.rootprocess)goto 25
!read A/Ci curve names stored in AllACiFiles
open(unit=2,file=trim(datapath)//trim(AllACiFiles))
ntotfiles=1
10 read(2,fmt=300,end=20)longchar
i=len(longchar)
j=0
15 j=j+1
if(longchar(j:j).ne.''.or.longchar(j:j).ne.' ')then
ipos1=j
else
if(j.ge.i)goto 10
goto 15
endif
j=i+1
16 j=j-1
if(longchar(j:j).ne.''.or.longchar(j:j).ne.' ')then
ipos2=j
else
if(j.le.1)goto 10
goto 16
endif
ACidata(ntotfiles)=longchar(ipos1:ipos2)
ntotfiles=ntotfiles+1
goto 10
20 ntotfiles=ntotfiles-1
close(2)
outputfile(1)='leafgasparameters.csv'
outputfile(2)='leafgascomparison.csv'
outputfile(3)='stomwuecicaparameters.csv'
outputfile(4)='stomcomparison.csv'
outputfile(5)='wuecicacomparison.csv'
outputfile(6)='fluorescencefit.csv'
outputfile(7)='fluoresparameters.csv'
outputfile(8)='aciempfitparameters.csv'
outputfile(9)='alightempfitparameters.csv'
outputfile(10)='warningmessage'
outputfile(11)='errormessage'
noutputfiles=11
!10 to 20 are used for file units for output files
do i=1,noutputfiles
indexunit(i)=i+9
enddo
call MPI_INIT(ierror_mpi)
call MPI_COMM_RANK(MPI_COMM_WORLD,rank_mpi,ierror_mpi)
call MPI_COMM_SIZE(MPI_COMM_WORLD,numproc,ierror_mpi)
!25 continue
! call MPI_BCAST(ACidata,ntotfiles,MPI_CHARACTER,rootprocess,
! &MPI_COMM_WORLD,ierror_mpi)
! call MPI_BCAST(ntotfiles,1,MPI_INTEGER,rootprocess,
! &MPI_COMM_WORLD,ierror_mpi)
! call MPI_BCAST(outputfile,noutputfiles,MPI_CHARACTER,rootprocess,
! &MPI_COMM_WORLD,ierror_mpi)
! call MPI_BCAST(indexunit,noutputfiles,MPI_INTEGER,rootprocess,
! &MPI_COMM_WORLD,ierror_mpi)
! call MPI_BCAST(noutputfiles,1,MPI_INTEGER,rootprocess,
! &MPI_COMM_WORLD,ierror_mpi)
!make sure the number of processors actually needed not to exceed the number of curves
numproc_mpi=min0(ntotfiles,numproc)
!only processors with ranks 0,1,.......numproc_mpi-1 actually do work and the rest
!go idle
if(rank_mpi.ge.numproc_mpi)goto 45
nshare=ntotfiles/numproc_mpi
nmod=ntotfiles-nshare*numproc_mpi
if((rank_mpi+1).le.nmod)then
npartfiles=nshare+1
istartno=rank_mpi*npartfiles+1
iendno=(rank_mpi+1)*npartfiles
else
npartfiles=nshare
istartno=nmod*(nshare+1)+(rank_mpi+1-nmod-1)*nshare+1
iendno=istartno+nshare-1
endif
numchar=1
30 if(rank_mpi.lt.(10**numchar))goto 40
numchar=numchar+1
goto 30
40 call NumberToChar(rank_mpi,numchar,achar)
do i=1,noutputfiles-1
open(unit=indexunit(i),
&file=trim(outpath)//trim(outputfile(i))//trim(achar))
enddo
call ToLeafGasOptimization(npartfiles,ACidata(istartno:iendno),
&dataunit,spareunit,datapath,indexunit,ierr)
do i=1,noutputfiles-1
close(indexunit(i))
enddo
if(ierr(1).ne.0)then
i=indexunit(noutputfiles)
open(unit=i,
&file=trim(outpath)//trim(outputfile(noutputfiles))//trim(achar))
write(i,*)'Input data error in ',ACidata(ierr(2)+istartno-1)
write(i,*)
&'Please resubmit the data after correcting the following error:'
if(ierr(1).eq.1)then
write(i,*)'Photosynthesis (umol/m2/s) out of range'
endif
if(ierr(1).eq.2)then
write(i,*)'Intercellular CO2(ppm) out of range'
endif
if(ierr(1).eq.3)then
write(i,*)'Leaf temperature (oC) out of range'
endif
if(ierr(1).eq.4)then
write(i,*)'Chamber PAR (umol/m2/s) out of range'
endif
if(ierr(1).eq.5)then
write(i,*)'Atmospheric pressure (Pa) out of range'
endif
if(ierr(1).eq.13)then
write(i,*)'Check line 13 for data entry error'
endif
if(ierr(1).eq.14)then
write(i,*)'Specified chloroplastic CO2 compensation point',
&'(Pa) out of range'
endif
if(ierr(1).eq.15)then
write(i,*)'Specified Michaelis-Menten constant for the',
&'carboxylase (Kc) out of range'
endif
if(ierr(1).eq.16)then
write(i,*)'Specified Michaelis-Menten constant for the',
&'oxygenase (Ko) out of range'
endif
if(ierr(1).eq.17)then
write(i,*)'Specified fraction of nonreturned glycolate',
&'carbon(alpha) out of range 0~1'
endif
if(ierr(1).eq.18)then
write(i,*)'Specified dark respiration rate Rd out of range >0'
endif
if(ierr(1).eq.19)then
write(i,*)'Specified mesophyll) resistance rch or rwp out of',
&'of range >0'
endif
if(ierr(1).eq.34)then
write(i,*)'Check Column 33 or 34. Mixing area- and mass-based
&measurements is not allowed'
endif
if(ierr(1).eq.36)then
write(i,*)'Check line 16 for data entry error'
endif
if(ierr(1).eq.39)then
write(i,*)
&'Check the main body of data for data entry error, starting from
&line 19'
endif
if(ierr(1).eq.40)then
write(i,*)
&'Data file format cannot be recognized'
endif
close(i)
endif
!make sure everyone is done before wrapping up.
45 call MPI_BARRIER(MPI_COMM_WORLD,ierror_mpi)
if(rank_mpi.eq.rootprocess)then
do j=1,noutputfiles
open(unit=indexunit(j),file=
&trim(outpath)//trim(outputfile(j)))
needheader(j)=0
enddo
!needheader=0: the two headerlines as well as data have not been written yet
!needheader=1: the two headerlines but no data have been written
!needheader=2: the two headerlines and data have been written
do i=1,numproc_mpi
rank_mpi=i-1
numchar=1
50 if(rank_mpi.lt.(10**numchar))goto 60
numchar=numchar+1
goto 50
60 call NumberToChar(rank_mpi,numchar,achar)
do j=1,noutputfiles-2
k=0
open(unit=2,file=
&trim(outpath)//trim(outputfile(j))//trim(achar))
if(needheader(j).eq.1.or.needheader(j).eq.2)then
read(2,*,end=70)
read(2,*,end=70)
else
read(2,fmt=300,end=70)longchar
read(2,fmt=300,end=70)longchar1
write(indexunit(j),310)trim(longchar)
write(indexunit(j),310)trim(longchar1)
needheader(j)=1
endif
65 read(2,fmt=300,end=70)longchar
write(indexunit(j),310)trim(longchar)
needheader(j)=2
k=1
goto 65
70 close(2,status='delete')
enddo
do j=noutputfiles-1,noutputfiles
open(unit=2,file=
&trim(outpath)//trim(outputfile(j))//trim(achar))
75 read(2,fmt=300,end=80)longchar
write(indexunit(j),310)trim(longchar)
needheader(j)=2
goto 75
80 close(2,status='delete')
enddo
enddo
do j=1,noutputfiles
if(needheader(j).eq.2)then
!keep files that contain data
close(indexunit(j))
else
!delete files that contain no data
close(indexunit(j),status='delete')
endif
enddo
!----------------------------------------------------------
!intercept the data
goto 450
399 call date_and_time(rundate,runtime,runzone,runvalues)
do i=1,ntotfiles
open(unit=1,file=trim(datapath)//trim(ACidata(i)))
open(unit=2,file=
&trim(storein)//rundate//runtime(1:6)//trim(ACidata(i)))
400 read(1,fmt=300,end=410)longchar
write(2,310)trim(longchar)
goto 400
410 close(1)
close(2)
enddo
do i=1,6
k=0
open(unit=1,file=trim(outpath)//trim(outputfile(i)))
open(unit=2,file=
&trim(storeout)//rundate//runtime(1:6)//trim(outputfile(i)))
420 read(1,fmt=300,end=430)longchar
write(2,310)trim(longchar)
k=1
goto 420
430 if(k.eq.1)then
close(1)
close(2)
else
close(1,status='delete')
close(2,status='delete')
endif
enddo
endif
450 call MPI_FINALIZE(ierror_mpi)
!----------------------------------------------------------
300 format(a5000)
310 format(a)
end
!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
leafres/testarea/LeafGasPISCAL_single.f
+297
View File
@@ -0,0 +1,297 @@
!Photosynthetic, Internal and Stomatal Conductance Analyses of Leaves (PISCAL)
!
!Created by: Lianhong Gu
! Environmental Sciences Dvision
! Oak Ridge National Laboratory
! Oak Ridge, TN 37831
! lianhong-gu@ornl.gov
!with support from Department of Energy Office of Science, Biological
!and Environmental Research Program
!
!PISCAL first created 10 July 2008
!Paralle PISCAL 20 Feb 2013
!Updated 24 Jan 1014
!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()
program main
implicit none
integer dataunit,spareunit,ierr(2),runvalues(8),ipos1,ipos2,
&ntotfiles,noutputfiles,i,j,k,indexunit(20)
character rundate*8,runtime*10,runzone*5,longchar*5000
character*100 datapath,outpath,storein,storeout,
&ACidata(8000)
character*50 AllACiFiles,outputfile(20)
! Set input / output directory
parameter(datapath=
! &'/home/l2g/ngeetropics/gamboa/curves/',
! &'/home/l2g/ngeetropics/metropolitano/curves/',
! &'/home/l2g/ngeetropics/fortsherman/curves/',
! &'/home/l2g/ngeetropics/kelsey/curves/',
& '/home/l2g/SingleLeafModel/ACiSimulation/hybrid/',
! &'/home/l2g/leafres/hybriddata/dwestonpoplus/data3/',
! &'/home/l2g/leafres/hybriddata/cernusak/2014data/',
! &'/home/l2g/leafres/hybriddata/hanjimei/',
! &'/home/l2g/junk/',
! & '/home/l2g/leafres/hybriddata/Berner/',
! & '/home/l2g/leafres/hybriddata/huidafeng/',
! &'/home/l2g/leafres/hybriddata/dwestonpoplus/data_Pn_tree_1_195_v2/
! &'/home/l2g/SingleLeafModel/ACiSimulation/hybrid/',
! & '/home/l2g/dataassim/leaf/data/moflux/2008/inputs/',
! & '/home/l2g/leafres/hybriddata/sphagnum/2014data1/',
! & '/home/l2g/dataassim/leaf/data/moflux/2010/inputs/',
!for moflux data, 2004-2008 requires correction of Ci. Other years do not
! & '/home/l2g/dataassim/leaf/data/LawData/inputs/',
! & '/home/l2g/dataassim/leaf/data/dweston/inputs/',
! & '/home/l2g/dataassim/leaf/data/johnbaker/inputs/',
! & '/home/l2g/dataassim/leaf/data/martins/inputs/',
! & '/home/l2g/dataassim/leaf/data/benzi/inputs/',
! & '/home/l2g/dataassim/leaf/data/loos/inputs/',
! & '/home/l2g/dataassim/leaf/data/ellsworth/inputs/',
! & '/home/l2g/dataassim/leaf/data/fromleafweb/inputs/',
! & '/home/l2g/SingleLeafModel/ACiSimulation/testkco/',
! & '/home/l2g/SingleLeafModel/ACiSimulation/rwprch/',
! & '/home/l2g/dataassim/leaf/data/panama/sept2012/inputs/',
! &'/home/l2g/dataassim/leaf/data/williams/inputs/',
! & '/home/l2g/dataassim/leaf/test/',
! & '/home/l2g/SingleLeafModel/ACiSimulation/Martins/',
! & '/home/l2g/SingleLeafModel/ACiSimulation/collantes/',
! & '/home/l2g/dataassim/leaf/data/dweston/inputs/',
! & '/home/l2g/GEMSiS/curves/',
& outpath=
! &'/home/l2g/ngeetropics/gamboa/results/',
! &'/home/l2g/ngeetropics/metropolitano/results/',
! &'/home/l2g/ngeetropics/fortsherman/results/',
! &'/home/l2g/ngeetropics/kelsey/results/',
! &'/home/l2g/leafres/hybriddata/dwestonpoplus/data3/',
! & '/home/l2g/SingleLeafModel/ACiSimulation/wenting/',
! &'/home/l2g/leafres/testdata/',
! &'/home/l2g/leafres/hybriddata/hanjimei/',
!
! & '/home/l2g/leafres/hybriddata/Berner/',
& '/home/l2g/SingleLeafModel/ACiSimulation/hybrid/',
! & '/home/l2g/leafres/hybriddata/huidafeng/',
! &'/home/l2g/leafres/hybriddata/dwestonpoplus/data_Pn_tree_1_195_v2/
! &',
! & '/home/l2g/dataassim/leaf/data/moflux/2008/outputs/',
! & '/home/l2g/dataassim/leaf/data/moflux/2012/outputs/',
! & '/home/l2g/dataassim/leaf/data/LawData/outputs/',
! & '/home/l2g/dataassim/leaf/data/dweston/outputs/',
! & '/home/l2g/dataassim/leaf/data/johnbaker/outputs/',
! & '/home/l2g/dataassim/leaf/data/martins/outputs/',
! & '/home/l2g/dataassim/leaf/data/benzi/outputs/',
! & '/home/l2g/dataassim/leaf/data/loos/outputs/',
! & '/home/l2g/dataassim/leaf/data/ellsworth/outputs/',
! &'/home/l2g/leafres/hybriddata/sphagnum/2014results1/',
! &'/home/l2g/junk/',
! & '/home/l2g/SingleLeafModel/ACiSimulation/testkco/',
! & '/home/l2g/SingleLeafModel/ACiSimulation/rwprch/results/',
! & '/home/l2g/dataassim/leaf/data/panama/sept2012/outputs/',
! &'/home/l2g/dataassim/leaf/data/panama/sept2012/outputs/rwprch/',
! & '/home/l2g/mpitest/',
! &'/home/l2g/dataassim/leaf/data/williams/outputs/',
! & '/home/l2g/dataassim/leaf/data/fromleafweb/outputs/withpad/',
! & '/home/l2g/dataassim/leaf/test/',
! & '/home/l2g/SingleLeafModel/ACiSimulation/collantes/',
! & '/home/l2g/SingleLeafModel/ACiSimulation/Martins/',
! & '/home/l2g/dataassim/leaf/data/dweston/outputs/',
! & '/home/l2g/GEMSiS/results/',
! &storein='/home/l2g/leafweb/users/curves/',
! &storeout='/home/l2g/leafweb/users/results/',
&storein='/home/l2g/leafres/testdata/',
&storeout='/home/l2g/leafres/testdata/',
! &storein='/home/l2g/junk/',
! &storeout='/home/l2g/junk/',
! &storein='/home/l2g/dataassim/leaf/data/ellsworth/outputs/',
! &storeout='/home/l2g/dataassim/leaf/data/ellsworth/outputs/',
& AllACiFiles='AllLeafGasFiles')
!---------------End of variable declaration----------------
ierr(1)=-1
ierr(2)=-1
outputfile(1)='leafgasparameters.csv'
outputfile(2)='leafgascomparison.csv'
outputfile(3)='stomwuecicaparameters.csv'
outputfile(4)='stomcomparison.csv'
outputfile(5)='wuecicacomparison.csv'
outputfile(6)='fluorescencefit.csv'
outputfile(7)='fluoresparameters.csv'
outputfile(8)='aciempfitparameters.csv'
outputfile(9)='alightempfitparameters.csv'
outputfile(10)='warningmessage'
outputfile(11)='errormessage'
noutputfiles=11
do i=1,noutputfiles
indexunit(i)=i+9
enddo
do i=1,noutputfiles-1
open(unit=indexunit(i),file=trim(outpath)//trim(outputfile(i)))
enddo
!read A/Ci curve names stored in AllACiFiles
dataunit=1
spareunit=3
open(unit=dataunit,status='scratch')
open(unit=spareunit,file=trim(datapath)//trim(AllACiFiles))
read(spareunit,fmt=300,err=40,end=40)longchar
rewind(spareunit)
2 read(spareunit,fmt=300,err=40,end=5)longchar
3 k=index(longchar,char(13))
if(k.gt.0)then
!DOS text format, convert it to unix format
longchar(k:k+len(char(10))-1)=char(10)
goto 3
endif
write(dataunit,310)trim(longchar)
goto 2
5 close(spareunit)
rewind(dataunit)
ntotfiles=1
10 read(dataunit,fmt=300,end=20)longchar
i=len(longchar)
j=0
15 j=j+1
if(ichar(longchar(j:j)).ge.33.and.ichar(longchar(j:j)).le.127)then
ipos1=j
else
if(j.ge.i)goto 10
goto 15
endif
j=i+1
16 j=j-1
if(ichar(longchar(j:j)).ge.33.and.ichar(longchar(j:j)).le.127)then
ipos2=j
else
if(j.le.1)goto 10
goto 16
endif
ACidata(ntotfiles)=longchar(ipos1:ipos2)
ntotfiles=ntotfiles+1
goto 10
20 ntotfiles=ntotfiles-1
close(dataunit)
call ToLeafGasOptimization(ntotfiles,ACidata,dataunit,spareunit,
&datapath,indexunit,ierr)
40 do i=1,noutputfiles-1
close(indexunit(i))
enddo
if(ierr(1).ne.0)then
i=indexunit(noutputfiles)
open(unit=i,file=trim(outpath)//trim(outputfile(noutputfiles)))
if(ierr(1).eq.-1)then
close(spareunit)
write(i,*)
&'No data files to analyze or incorrect file name format'
else
write(i,*)'Input data error in ',trim(ACidata(ierr(2)))
write(i,*)
&'Please resubmit the data after correcting the following error:'
endif
if(ierr(1).eq.1)then
write(i,*)'Photosynthesis (umol/m2/s) out of range'
endif
if(ierr(1).eq.2)then
write(i,*)'Intercellular CO2(ppm) out of range'
endif
if(ierr(1).eq.3)then
write(i,*)'Leaf temperature (oC) out of range'
endif
if(ierr(1).eq.4)then
write(i,*)'Chamber PAR (umol/m2/s) out of range'
endif
if(ierr(1).eq.5)then
write(i,*)'Atmospheric pressure (Pa) out of range'
endif
if(ierr(1).eq.13)then
write(i,*)'Check line 13 for data entry error'
endif
if(ierr(1).eq.14)then
write(i,*)'Specified chloroplastic CO2 compensation point',
&'(Pa) out of range'
endif
if(ierr(1).eq.15)then
write(i,*)'Specified Michaelis-Menten constant for the',
&'carboxylase (Kc) out of range'
endif
if(ierr(1).eq.16)then
write(i,*)'Specified Michaelis-Menten constant for the',
&'oxygenase (Ko) out of range'
endif
if(ierr(1).eq.17)then
write(i,*)'Specified fraction of nonreturned glycolate',
&'carbon(alpha) out of range 0~1'
endif
if(ierr(1).eq.18)then
write(i,*)'Specified dark respiration rate Rd out of range >0'
endif
if(ierr(1).eq.19)then
write(i,*)'Specified internal (mesophyll) conductance gi out',
&'of range >0'
endif
if(ierr(1).eq.34)then
write(i,*)'Check Column 33 or 34. Mixing area- and mass-based
&measurements is not allowed'
endif
if(ierr(1).eq.36)then
write(i,*)'Check line 16 for data entry error'
endif
if(ierr(1).eq.39)then
write(i,*)
&'Check the main body of data for data entry error, starting from
&line 19'
endif
if(ierr(1).eq.40)then
write(i,*)
&'Data file format cannot be recognized'
endif
close(i)
endif
do j=1,noutputfiles
open(unit=2,file=trim(outpath)//trim(outputfile(j)))
read(2,*,end=70)
if(j.le.(noutputfiles-2))then
read(2,*,end=70)
read(2,*,end=70)
endif
close(2)
goto 80
70 close(2,status='delete')
80 enddo
!----------------------------------------------------------
!intercept the data
goto 450
399 call date_and_time(rundate,runtime,runzone,runvalues)
do i=1,ntotfiles
open(unit=1,file=trim(datapath)//trim(ACidata(i)))
open(unit=2,file=
&trim(storein)//rundate//runtime(1:6)//trim(ACidata(i)))
400 read(1,fmt=300,end=410)longchar
write(2,310)trim(longchar)
goto 400
410 close(1)
close(2)
enddo
do i=1,6
k=0
open(unit=1,file=trim(outpath)//trim(outputfile(i)))
open(unit=2,file=
&trim(storeout)//rundate//runtime(1:6)//trim(outputfile(i)))
420 read(1,fmt=300,end=430)longchar
write(2,310)trim(longchar)
k=1
goto 420
430 if(k.eq.1)then
close(1)
close(2)
else
close(1,status='delete')
close(2,status='delete')
endif
enddo
450 continue
!----------------------------------------------------------
300 format(a5000)
310 format(a)
end
!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
leafres/testarea/LeafGasParams.h
+96
View File
@@ -0,0 +1,96 @@
! This file contains common blocks used in the optimization runs.
!
! ------ Optimization variables common Blocks ---------------------
! maxobs: the maximum number of observations
! maxpsnparam: the maximum number of parameters to be optimized
! aPPFDlf: PAR absorbed by leaf (umol m-2 s-1)
! templeaf: leaf temperature (K)
! xpco2i: Intercellular CO2 partial pressure (Pa)
! po2i: Intercellular oxygen partial pressure (Pa)
! obs_psn: net photosynthetic rate (umol m-2 s-1)
! psnparamx: parameters in the leaf photosynthetic model
! nobs: integer, the actual number of observations
! IFIXBcp: the index for the parameters in psnparams that are being
! optimized (0= not optimized; 1= optimized)
! ilimittype: indicator for the choice of limitation types
! = 1, Rubisco+RuBP+TPU'
! = 2, Rubisco+RuBP
! = 3, Rubisco+TPU
! = 4, RuBP+TPU
! = 5, Rubisco Only
! = 6, RuBP Only
! = 7, TPU Only
! betamin: the lower bound of the parameters to be optimized
! betamax: the upper bound of the parameters to be optimized
!resistwp: =rwp, resistance to CO2 via cell walls and plasmalemma (Pa s m2 umol-1). If less than zero, set to zero.
!resistch: =rch, resistance to CO2 via chloroplast envelope and stroma (Pa s m2 umol-1). If less than zero, set to zero.
!idorwp, =0 zero rwp
! =1 fit for rwp
! =2 keep input rwp and don't optimize it
!idorch, =0 zero rch
! =1 fit for rch
! =2 keep input rch and don't optimize it
! ntotparams: the total number of optimized and unoptimized parameters
! isitgridsearch=0, in optimization mode (cij+cic is the transition RuBp-TPU CO2i threshold)
! =1, in grid search mode (cij is the transition RuBp-TPU CO2i threshold)
integer maxpsnparam
parameter (maxpsnparam=50)
double precision univparams(maxpsnparam),
&univparamsmin(maxpsnparam),univparamsmax(maxpsnparam),
&betamin(maxpsnparam),betamax(maxpsnparam),resistwp25,resistch25,
&rdlight25,stargamma25,vcmax25,fkc25,fko25,fjmax25,tpu25,alpha25,
&bestunivparams(maxpsnparam),resistwp25_ori,resistch25_ori,
&rdlight25_ori,stargamma25_ori,vcmax25_ori,fkc25_ori,fko25_ori,
&fjmax25_ori,tpu25_ori,alpha25_ori,gascon,ha_vcmax,hd_vcmax,
&sv_vcmax,ha_jmax,hd_jmax,sv_jmax,ha_tpu,hd_tpu,sv_tpu,
&ha_gmeso,hd_gmeso,sv_gmeso,ha_darkresp,ha_stargamma,ha_kc,ha_ko,
&abspt_lf_par,resistwp25min,resistch25min,rdlight25min,
&stargamma25min,vcmax25min,fkc25min,fko25min,fjmax25min,tpu25min,
&alpha25min,resistwp25max,resistch25max,rdlight25max,
&stargamma25max,vcmax25max,fkc25max,fko25max,fjmax25max,tpu25max,
&alpha25max,gacontrol(maxpsnparam),
&subbestunivparams(maxpsnparam,7),phifactor,phifactormin,
&phifactormax,thetafactor,thetafactormin,thetafactormax,
&phifactor_ori,thetafactor_ori,betaPSII,betaPSIImin,betaPSIImax,
&betaPSII_ori,ha_darkrespmin,ha_darkrespmax,ha_darkresp_ori,
&ha_stargammamin,ha_stargammamax,ha_stargamma_ori,ha_vcmaxmin,
&ha_vcmaxmax,ha_vcmax_ori,ha_jmaxmin,ha_jmaxmax,ha_jmax_ori,
&ha_tpumin,ha_tpumax,ha_tpu_ori,ha_gmesomin,ha_gmesomax,
&ha_gmeso_ori
integer minimumrubis,minimumfj,minimumvt,idorwp,idorch,idord,
&idostargamma,idoalpha,idokc,idoko,ifixunivparams(maxpsnparam),
&ntotunivparams,bestnumrubis,bestnumrubp,bestnumtpu,isitbounded,
&idophifactor,idothetafactor,idobetaPSII,idoha_darkresp,
&idoha_stargamma,idoha_vcmax,idoha_jmax,idoha_tpu,idoha_gmeso
common /dbleleafparams/univparams,univparamsmin,univparamsmax,
&betamin,betamax,resistwp25,resistch25,rdlight25,stargamma25,
&vcmax25,fkc25,fko25,fjmax25,tpu25,alpha25,bestunivparams,
&resistwp25_ori,resistch25_ori,rdlight25_ori,stargamma25_ori,
&vcmax25_ori,fkc25_ori,fko25_ori,fjmax25_ori,tpu25_ori,alpha25_ori,
&gascon,ha_vcmax,hd_vcmax,sv_vcmax,ha_jmax,hd_jmax,sv_jmax,ha_tpu,
&hd_tpu,sv_tpu,ha_gmeso,hd_gmeso,sv_gmeso,ha_darkresp,ha_stargamma,
&ha_kc,ha_ko,abspt_lf_par,resistwp25min,resistch25min,rdlight25min,
&stargamma25min,vcmax25min,fkc25min,fko25min,fjmax25min,tpu25min,
&alpha25min,resistwp25max,resistch25max,rdlight25max,
&stargamma25max,vcmax25max,fkc25max,fko25max,fjmax25max,tpu25max,
&alpha25max,gacontrol,subbestunivparams,phifactor,phifactormin,
&phifactormax,thetafactor,thetafactormin,thetafactormax,
&phifactor_ori,thetafactor_ori,betaPSII,betaPSIImin,betaPSIImax,
&betaPSII_ori,ha_darkrespmin,ha_darkrespmax,ha_darkresp_ori,
&ha_stargammamin,ha_stargammamax,ha_stargamma_ori,ha_vcmaxmin,
&ha_vcmaxmax,ha_vcmax_ori,ha_jmaxmin,ha_jmaxmax,ha_jmax_ori,
&ha_tpumin,ha_tpumax,ha_tpu_ori,ha_gmesomin,ha_gmesomax,
&ha_gmeso_ori
common /intleafparams/minimumrubis,minimumfj,minimumvt,idorwp,
&idorch,idord,idostargamma,idoalpha,idokc,idoko,ifixunivparams,
&ntotunivparams,bestnumrubis,bestnumrubp,bestnumtpu,isitbounded,
&idophifactor,idothetafactor,idobetaPSII,idoha_darkresp,
&idoha_stargamma,idoha_vcmax,idoha_jmax,idoha_tpu,idoha_gmeso
save /dbleleafparams/,/intleafparams/
!-------- End of list of common block variables ------------------
leafres/testarea/LeafGasPrintToFiles.f
+884
View File
@@ -0,0 +1,884 @@
subroutine LeafGasPrintToFiles(isitmassbased,indexunit)
implicit none
integer isitmassbased,indexunit(20),paramunit,compareunit,
&stomwuecicaoutunit,stomcompunit,wuecicacompunit,fluorescenceunit,
&fluoresparamunit,aciempfitunit,alightempfitunit
character *25,
& sitevars(50),unitsitevars(50),
& paramsvar(0:50),unitparamsvar(0:50),
& stomwuecica(200),unitstomwuecica(200),
& univcomvars(50),unitunivcomvars(50),
& univsumvars(50),unitunivsumvars(50),
& ACichars(50),unitACichars(50),
& ALightchars(50),unitALightchars(50),
&cterm1,cterm2
integer i
!$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
paramunit=indexunit(1)
compareunit=indexunit(2)
stomwuecicaoutunit=indexunit(3)
stomcompunit=indexunit(4)
wuecicacompunit=indexunit(5)
fluorescenceunit=indexunit(6)
fluoresparamunit=indexunit(7)
aciempfitunit=indexunit(8)
alightempfitunit=indexunit(9)
!Fit for Amax_ACi and Asat_ALight
ACichars(1)='CurveID'
ACichars(2)='ACicurveNo'
ACichars(3)='CiatZeroAnet'
ACichars(4)='der_atCi'
ACichars(5)='Amax_ACi'
ACichars(6)='ACiIntercept'
ACichars(7)='der_atInterceptCi'
ACichars(8)='der_atACiend'
ACichars(9)='PhiPSIImax_ACi'
ACichars(10)='PhiPSIICiIntercept'
ACichars(11)='der_atInterceptCi'
ACichars(12)='der_atPhiPSIIendCi'
ACichars(13)='ACiMaxCurvature'
ACichars(14)='CO2i_ACiMaxcurva'
ACichars(15)='PhiPSIIMaxCurvatCi'
ACichars(16)='CO2i_PhiPSIIMaxCur'
ACichars(17)='CaatZeroAnet'
ACichars(18)='der_atCa'
ACichars(19)='Amax_ACa'
ACichars(20)='ACaIntercept'
ACichars(21)='der_atInterceptCa'
ACichars(22)='der_ACaat400ppm'
ACichars(23)='anet_ACaat400ppm'
ACichars(24)='PhiPSIImax_ACa'
ACichars(25)='PhiPSIICaIntercept'
ACichars(26)='der_atInterceptCa'
ACichars(27)='der_atPhiPSIIendCa'
ACichars(28)='ACaMaxCurvature'
ACichars(29)='CO2a_ACaMaxcurva'
ACichars(30)='PhiPSIIMaxCurvatCa'
ACichars(31)='CO2a_PhiPSIIMaxCur'
ACichars(32)='AveLeafTemp'
ACichars(33)='AvePAR'
ACichars(34)='AvepO2i'
unitACichars(1)='NA'
unitACichars(2)='NA'
unitACichars(3)='Pa'
unitACichars(4)='umolm-2s-1Pa-1'
unitACichars(5)='umolm-2s-1'
unitACichars(6)='umolm-2s-1'
unitACichars(7)='umolm-2s-1Pa-1'
unitACichars(8)='umolm-2s-1Pa-1'
unitACichars(9)='NA'
unitACichars(10)='NA'
unitACichars(11)='Pa-1'
unitACichars(12)='Pa-1'
unitACichars(13)='X1000'
unitACichars(14)='Pa'
unitACichars(15)='X1000'
unitACichars(16)='Pa'
unitACichars(17)='Pa'
unitACichars(18)='umolm-2s-1Pa-1'
unitACichars(19)='umolm-2s-1'
unitACichars(20)='umolm-2s-1'
unitACichars(21)='umolm-2s-1Pa-1'
unitACichars(22)='umolm-2s-1Pa-1'
unitACichars(23)='umolm-2s-1'
unitACichars(24)='NA'
unitACichars(25)='NA'
unitACichars(26)='Pa-1'
unitACichars(27)='Pa-1'
unitACichars(28)='X1000'
unitACichars(29)='Pa'
unitACichars(30)='X1000'
unitACichars(31)='Pa'
unitACichars(32)='oC'
unitACichars(33)='umolm-2s-1'
unitACichars(34)='Pa'
if(isitmassbased.eq.1)then
unitACichars(4)='umolkg-1s-1Pa-1'
unitACichars(5)='umolkg-1s-1'
unitACichars(6)='umolkg-1s-1'
unitACichars(7)='umolkg-1s-1Pa-1'
unitACichars(8)='umolkg-1s-1Pa-1'
unitACichars(18)='umolkg-1s-1Pa-1'
unitACichars(19)='umolkg-1s-1'
unitACichars(20)='umolkg-1s-1'
unitACichars(21)='umolkg-1s-1Pa-1'
unitACichars(22)='umolkg-1s-1Pa-1'
unitACichars(23)='umolkg-1s-1'
unitACichars(33)='umolkg-1s-1'
endif
ALightchars(1)='CurveID'
ALightchars(2)='ALightcurveNo'
ALightchars(3)='PARatZeroAnet'
ALightchars(4)='der_atPAR'
ALightchars(5)='Asat_ALight'
ALightchars(6)='ALightIntercept'
ALightchars(7)='der_atIntercept'
ALightchars(8)='der_atPARend'
ALightchars(9)='PhiPSIILightIntercept'
ALightchars(10)='der_atIntercept'
ALightchars(11)='ExcessLightFactor'
ALightchars(12)='der_atPAR1000'
ALightchars(13)='ALightMaxCurvature'
ALightchars(14)='PAR_MaxCurvature'
ALightchars(15)='PhiPSIIALightMaxCur'
ALightchars(16)='PAR_PhiPSIIMaxCurva'
ALightchars(17)='AveLeafTemp'
ALightchars(18)='AvepCO2ambient'
ALightchars(19)='AvepO2i'
unitALightchars(1)='NA'
unitALightchars(2)='NA'
unitALightchars(3)='umolm-2s-1'
unitALightchars(4)='umol/umol'
unitALightchars(5)='umolm-2s-1'
unitALightchars(6)='umolm-2s-1'
unitALightchars(7)='umol/umol'
unitALightchars(8)='umol/umol'
unitALightchars(9)='NA'
unitALightchars(10)='umol-1m2s'
unitALightchars(11)='NA'
unitALightchars(12)='umol-1m2s'
unitALightchars(13)='X1000'
unitALightchars(14)='umolm-2s-1'
unitALightchars(15)='X1000'
unitALightchars(16)='umolm-2s-1'
unitALightchars(17)='oC'
unitALightchars(18)='Pa'
unitALightchars(19)='Pa'
if(isitmassbased.eq.1)then
unitALightchars(3)='umolkg-1s-1'
unitALightchars(5)='umolkg-1s-1'
unitALightchars(6)='umolkg-1s-1'
unitALightchars(10)='umol-1kgs'
unitALightchars(12)='umol-1kgs'
unitALightchars(14)='umolkg-1s-1'
unitALightchars(16)='umolkg-1s-1'
endif
univcomvars(1)='CurveID'
univcomvars(2)='FitRwp|Rch|ha?'
univcomvars(3)='Fitha_Vcmax|Jmax|Tpu?'
univcomvars(4)='FitGamma*|ha?'
univcomvars(5)='FitKc|ha?'
univcomvars(6)='FitKo|ha?'
univcomvars(7)='FitRd|ha?'
univcomvars(8)='FitAlpha?'
univcomvars(9)='FitbetaPSII?'
univcomvars(10)='CO2i_obs'
univcomvars(11)='CO2i_Pred'
univcomvars(12)='CO2c'
univcomvars(13)='Anet_Obs'
univcomvars(14)='Anet_Pred'
univcomvars(15)='LimitState'
univcomvars(16)='RecycRate'
univcomvars(17)='CO2S'
univcomvars(18)='Pres_O2'
univcomvars(19)='Pres_H2O'
univcomvars(20)='Pres_Air'
univcomvars(21)='VPDL'
univcomvars(22)='PARi'
univcomvars(23)='LeafTemp'
univcomvars(24)='ChamberAirTemp'
univcomvars(25)='Trmmol'
univcomvars(26)='StomatalCond_H2O'
univcomvars(27)='ChlFlPHIPSII_Obs'
univcomvars(28)='ChlFlPHIPSII_Pred'
univcomvars(29)='CO2i_Pred_ChlFl'
univcomvars(30)='Anet_Pred_ChlFl'
univcomvars(31)='CO2c_CO2i_ChlFl'
univcomvars(32)='CO2c_Anet_ChlFl'
univcomvars(33)='fo_pam'
univcomvars(34)='fm_pam'
univcomvars(35)='fs_pam'
univcomvars(36)='pam_measlight'
univcomvars(37)='yield_ps2'
univcomvars(38)='yield_npq'
univcomvars(39)='qlake'
univcomvars(40)='qpuddle'
univcomvars(41)='kps2_norm'
univcomvars(42)='knpq_norm'
unitunivcomvars(1)='NA'
unitunivcomvars(2)='1=No2=Yes'
unitunivcomvars(3)='1=No2=Yes'
unitunivcomvars(4)='1=No2=Yes'
unitunivcomvars(5)='1=No2=Yes'
unitunivcomvars(6)='1=No2=Yes'
unitunivcomvars(7)='1=No2=Yes'
unitunivcomvars(8)='1=No2=Yes'
unitunivcomvars(9)='1=No2=Yes'
unitunivcomvars(10)='Pa'
unitunivcomvars(11)='Pa'
unitunivcomvars(12)='Pa'
unitunivcomvars(13)='umolm-2s-1'
unitunivcomvars(14)='umolm-2s-1'
unitunivcomvars(15)='Rubis1RUBP2TPU3'
unitunivcomvars(16)='%'
unitunivcomvars(17)='Pa'
unitunivcomvars(18)='KPa'
unitunivcomvars(19)='KPa'
unitunivcomvars(20)='KPa'
unitunivcomvars(21)='KPa'
unitunivcomvars(22)='umolm-2s-1'
unitunivcomvars(23)='oC'
unitunivcomvars(24)='oC'
unitunivcomvars(25)='mmolm-2s-1'
unitunivcomvars(26)='molm-2s-1'
unitunivcomvars(27)='NA'
unitunivcomvars(28)='NA'
unitunivcomvars(29)='Pa'
unitunivcomvars(30)='umolm-2s-1'
unitunivcomvars(31)='Pa'
unitunivcomvars(32)='Pa'
unitunivcomvars(33)='ArbitUnit'
unitunivcomvars(34)='ArbitUnit'
unitunivcomvars(35)='ArbitUnit'
unitunivcomvars(36)='umolm-2s-1'
unitunivcomvars(37)='0-1'
unitunivcomvars(38)='0-1'
unitunivcomvars(39)='0-1'
unitunivcomvars(40)='0-1'
unitunivcomvars(41)='kps2/(kf+kd)'
unitunivcomvars(42)='knpq/(kf+fd)'
if(isitmassbased.eq.1)then
unitunivcomvars(13)='umolkg-1s-1'
unitunivcomvars(14)='umolkg-1s-1'
unitunivcomvars(22)='umolkg-1s-1'
unitunivcomvars(25)='mmolkg-1s-1'
unitunivcomvars(26)='molkg-1s-1'
unitunivcomvars(30)='molkg-1s-1'
unitunivcomvars(36)='umolkg-1s-1'
endif
write(compareunit,'(1000A)')(trim(univcomvars(i)),',',
&i=1,31),trim(univcomvars(32))
write(compareunit,'(1000A)')(trim(unitunivcomvars(i)),
&',',i=1,31),trim(unitunivcomvars(32))
paramsvar(0)='LimitState'
paramsvar(1)='Vcmax25'
paramsvar(2)='Jmax25'
paramsvar(3)='Rdlight25'
paramsvar(4)='Resistwp25'
paramsvar(5)='Resistch25'
paramsvar(6)='tpu25'
paramsvar(7)='gamma*25'
paramsvar(8)='fkc25'
paramsvar(9)='fko25'
paramsvar(10)='alpha'
paramsvar(11)='ha_vcmax'
paramsvar(12)='hd_vcmax'
paramsvar(13)='sv_vcmax'
paramsvar(14)='ha_jmax'
paramsvar(15)='hd_jmax'
paramsvar(16)='sv_jmax'
paramsvar(17)='ha_tpu'
paramsvar(18)='hd_tpu'
paramsvar(19)='sv_tpu'
paramsvar(20)='ha_gmeso'
paramsvar(21)='hd_gmeso'
paramsvar(22)='sv_gmeso'
paramsvar(23)='ha_darkresp'
paramsvar(24)='ha_stargamma'
paramsvar(25)='ha_kc'
paramsvar(26)='ha_ko'
paramsvar(27)='phifactor'
paramsvar(28)='thetafactor'
paramsvar(29)='betaPSII'
paramsvar(30)='numrubisco'
paramsvar(31)='numrubp'
paramsvar(32)='numtpu'
paramsvar(33)='NumSamplePoints'
paramsvar(34)='SumSquare'
paramsvar(35)='Rdlight'
paramsvar(36)='Resistwp'
paramsvar(37)='Resistch'
paramsvar(38)='gamma*'
paramsvar(39)='co2iRubismax25'
paramsvar(40)='co2iRuBpmax25'
paramsvar(41)='anetRubismax25'
paramsvar(42)='anetRuBpmax25'
unitparamsvar(0)='Occurrence'
unitparamsvar(1)='umolm-2s-1'
unitparamsvar(2)='umolm-2s-1'
unitparamsvar(3)='umolm-2s-1'
unitparamsvar(4)='Pasm2umol-1'
unitparamsvar(5)='Pasm2umol-1'
unitparamsvar(6)='umolm-2s-1'
unitparamsvar(7)='Pa'
unitparamsvar(8)='Pa'
unitparamsvar(9)='Pa'
unitparamsvar(10)='0_1'
unitparamsvar(11)='kJmol-1'
unitparamsvar(12)='kJmol-1'
unitparamsvar(13)='KJmol-1K-1'
unitparamsvar(14)='kJmol-1'
unitparamsvar(15)='kJmol-1'
unitparamsvar(16)='KJmol-1K-1'
unitparamsvar(17)='kJmol-1'
unitparamsvar(18)='kJmol-1'
unitparamsvar(19)='KJmol-1K-1'
unitparamsvar(20)='kJmol-1'
unitparamsvar(21)='kJmol-1'
unitparamsvar(22)='KJmol-1K-1'
unitparamsvar(23)='kJmol-1'
unitparamsvar(24)='kJmol-1'
unitparamsvar(25)='kJmol-1'
unitparamsvar(26)='kJmol-1'
unitparamsvar(27)='NA'
unitparamsvar(28)='NA'
unitparamsvar(29)='NA'
unitparamsvar(30)='rubispoints'
unitparamsvar(31)='rubppoints'
unitparamsvar(32)='tpupoints'
unitparamsvar(33)='<=rubis+rubp+tpu'
unitparamsvar(34)='NA'
unitparamsvar(35)='umolm-2s-1'
unitparamsvar(36)='Pasm2umol-1'
unitparamsvar(37)='Pasm2umol-1'
unitparamsvar(38)='Pa'
unitparamsvar(39)='Pa'
unitparamsvar(40)='Pa'
unitparamsvar(41)='umolm-2s-1'
unitparamsvar(42)='umolm-2s-1'
if(isitmassbased.eq.1)then
unitparamsvar(1)='umolkg-1s-1'
unitparamsvar(2)='umolkg-1s-1'
unitparamsvar(3)='umolkg-1s-1'
unitparamsvar(4)='Paskgumol-1'
unitparamsvar(5)='Paskgumol-1'
unitparamsvar(6)='umolkg-1s-1'
unitparamsvar(35)='umolkg-1s-1'
unitparamsvar(36)='Paskgumol-1'
unitparamsvar(37)='Paskgumol-1'
unitparamsvar(41)='umolkg-1s-1'
unitparamsvar(42)='umolkg-1s-1'
endif
sitevars(1)='siteID'
sitevars(2)='Latitude'
sitevars(3)='Longitude'
sitevars(4)='Elevation'
sitevars(5)='yearsampled'
sitevars(6)='sampledoy'
sitevars(7)='GrowingSeasonStart'
sitevars(8)='GrowingSeasonEnd'
sitevars(9)='standage'
sitevars(10)='CanopyHeight'
sitevars(11)='LeafAreaIndex'
sitevars(12)='species'
sitevars(13)='avetimeresolution'
sitevars(14)='avetimesampled'
sitevars(15)='SampleHeight'
sitevars(16)='Needleage'
sitevars(17)='specificLAI'
sitevars(18)='nitrogencontent'
sitevars(19)='carboncontent'
sitevars(20)='phosphoruscontent'
sitevars(21)='woodporosity'
sitevars(22)='sapwooddensity'
sitevars(23)='leafratio'
unitsitevars(1)='NA'
unitsitevars(2)='DegNorthPositive'
unitsitevars(3)='DegEastPositive'
unitsitevars(4)='m'
unitsitevars(5)='Year'
unitsitevars(6)='DayofYear'
unitsitevars(7)='DayofYear'
unitsitevars(8)='DayofYear'
unitsitevars(9)='years'
unitsitevars(10)='m'
unitsitevars(11)='m2m-2'
unitsitevars(12)='species'
unitsitevars(13)='minutes'
unitsitevars(14)='HourFraction'
unitsitevars(15)='m'
unitsitevars(16)='days'
unitsitevars(17)='cm2g-1'
unitsitevars(18)='%'
unitsitevars(19)='%'
unitsitevars(20)='%'
unitsitevars(21)='ring/diffuse'
unitsitevars(22)='g/cm3'
unitsitevars(23)='Unitless'
write(paramunit,'(2000A)')(trim(univcomvars(i)),',',i=1,9),
&(trim(paramsvar(i)),',',i=0,34),(trim(paramsvar(i)),',',i=39,42),
&(trim(sitevars(i)),',',i=1,22),trim(sitevars(23))
write(paramunit,'(2000A)')(trim(unitunivcomvars(i)),',',i=1,9),
&(trim(unitparamsvar(i)),',',i=0,34),
&(trim(unitparamsvar(i)),',',i=39,42),
&(trim(unitsitevars(i)),',',i=1,22),trim(unitsitevars(23))
write(fluorescenceunit,'(1000A)')trim(univcomvars(1)),',',
&(trim(univcomvars(i)),',',i=10,14),
&(trim(univcomvars(i)),',',i=17,27),
&(trim(paramsvar(i)),',',i=3,5),trim(paramsvar(7)),',',
&trim(paramsvar(29)),',',trim(paramsvar(34)),',',
&trim(paramsvar(23)),',',(trim(paramsvar(i)),',',i=36,37),
&trim(paramsvar(24)),',',(trim(univcomvars(i)),',',i=33,41),
&trim(univcomvars(42))
write(fluorescenceunit,'(1000A)')trim(unitunivcomvars(1)),',',
&(trim(unitunivcomvars(i)),',',i=10,14),
&(trim(unitunivcomvars(i)),',',i=17,27),
&(trim(unitparamsvar(i)),',',i=3,5),trim(unitparamsvar(7)),',',
&trim(unitparamsvar(29)),',',trim(unitparamsvar(34)),',',
&trim(unitparamsvar(23)),',',(trim(unitparamsvar(i)),',',i=36,37),
&trim(unitparamsvar(24)),',',(trim(unitunivcomvars(i)),',',
&i=33,41),trim(unitunivcomvars(42))
cterm1='Flu.Anet.SumSqure'
cterm2='Flu.Electron.SumS'
write(fluoresparamunit,'(1000A)')trim(univcomvars(1)),',',
&trim(paramsvar(2)),',',trim(paramsvar(3)),',',
&trim(paramsvar(3)),'/0rch,',trim(paramsvar(4)),',',
&trim(paramsvar(4)),'/0rch,',trim(paramsvar(5)),',',
&trim(paramsvar(7)),',',trim(paramsvar(7)),'/0rch,',
&(trim(paramsvar(i)),',',i=27,29),trim(paramsvar(29)),'/0rch,',
&'fo_dark,fm_dark,resp_dark,temp_dark,',trim(cterm1),',',
&trim(cterm2)
write(fluoresparamunit,'(1000A)')trim(unitunivcomvars(1)),',',
&trim(unitparamsvar(2)),',',trim(unitparamsvar(3)),',',
&trim(unitparamsvar(3)),',',trim(unitparamsvar(4)),',',
&trim(unitparamsvar(4)),',',trim(unitparamsvar(5)),',',
&trim(unitparamsvar(7)),',',trim(unitparamsvar(7)),',',
&(trim(unitparamsvar(i)),',',i=27,29),trim(unitparamsvar(29)),',',
&'ArbitUnit,ArbitUnit,',trim(unitparamsvar(3)),',oC,',
&trim(cterm1),',',trim(cterm2)
write(aciempfitunit,'(2000A)')(trim(ACichars(i)),',',i=1,34),
&(trim(sitevars(i)),',',i=1,22),trim(sitevars(23))
write(aciempfitunit,'(2000A)')(trim(unitACichars(i)),',',i=1,34),
&(trim(unitsitevars(i)),',',i=1,22),trim(unitsitevars(23))
write(alightempfitunit,'(2000A)')
&(trim(ALightchars(i)),',',i=1,19),
&(trim(sitevars(i)),',',i=1,22),trim(sitevars(23))
write(alightempfitunit,'(2000A)')
&(trim(unitALightchars(i)),',',i=1,19),
&(trim(unitsitevars(i)),',',i=1,22),trim(unitsitevars(23))
!------------------------------------------------
!$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
!Stomatal conductance, water use efficiency and ci/ca
stomwuecica(1)='curveno'
stomwuecica(2)='curvename'
stomwuecica(3)='gswmeas_stom'
stomwuecica(4)='gswCO2sLin'
stomwuecica(5)='gswCO2iLin'
stomwuecica(6)='gswCO2iBall'
stomwuecica(7)='gswCO2sRay'
stomwuecica(8)='gswCO2iRay'
stomwuecica(9)='gswDewar'
stomwuecica(10)='CO2i'
stomwuecica(11)='CO2s'
stomwuecica(12)='RH'
stomwuecica(13)='gammas'
stomwuecica(14)='vpd_surf'
stomwuecica(15)='Pres_air'
stomwuecica(16)='Anet_Meas'
unitstomwuecica(1)='NA'
unitstomwuecica(2)='NA'
unitstomwuecica(3)='molm-2s-1'
unitstomwuecica(4)='molm-2s-1'
unitstomwuecica(5)='molm-2s-1'
unitstomwuecica(6)='molm-2s-1'
unitstomwuecica(7)='molm-2s-1'
unitstomwuecica(8)='molm-2s-1'
unitstomwuecica(9)='molm-2s-1'
unitstomwuecica(10)='ppm'
unitstomwuecica(11)='ppm'
unitstomwuecica(12)='0-1'
unitstomwuecica(13)='ppm'
unitstomwuecica(14)='Pa'
unitstomwuecica(15)='Pa'
unitstomwuecica(16)='umolm-2s-1'
if(isitmassbased.eq.1)then
unitstomwuecica(3)='molkg-1s-1'
unitstomwuecica(4)='molkg-1s-1'
unitstomwuecica(5)='molkg-1s-1'
unitstomwuecica(6)='molkg-1s-1'
unitstomwuecica(7)='molkg-1s-1'
unitstomwuecica(8)='molkg-1s-1'
unitstomwuecica(9)='molkg-1s-1'
unitstomwuecica(16)='umolkg-1s-1'
endif
write(stomcompunit,'(100A)')((trim(stomwuecica(i)),','),
&i=1,15),trim(stomwuecica(16))
write(stomcompunit,'(100A)')((trim(unitstomwuecica(i)),','),
&i=1,15),trim(unitstomwuecica(16))
!------------------------------------------------------------
stomwuecica(1)='curveno'
stomwuecica(2)='curvename'
stomwuecica(3)='co2ambient'
stomwuecica(4)='vpdl'
stomwuecica(5)='WUEmeasured'
stomwuecica(6)='WUEmodeled'
stomwuecica(7)='cicameasured'
stomwuecica(8)='cicamodeled'
stomwuecica(9)='IntrinsicWUE'
stomwuecica(10)='IntWUEModel'
stomwuecica(11)='cccimeasured1'
stomwuecica(12)='cccimodeled1'
stomwuecica(13)='cccimeasured2'
stomwuecica(14)='cccimodeled2'
stomwuecica(15)='cccimeasured3'
stomwuecica(16)='cccimodeled3'
stomwuecica(17)='cccimeasured4'
stomwuecica(18)='cccimodeled4'
stomwuecica(19)='recycmeasured1'
stomwuecica(20)='recycmodeled1'
stomwuecica(21)='recycmeasured2'
stomwuecica(22)='recycmodeled2'
stomwuecica(23)='recycmeasured3'
stomwuecica(24)='recycmodeled3'
stomwuecica(25)='recycmeasured4'
stomwuecica(26)='recycmodeled4'
stomwuecica(27)='recycmeasured5'
stomwuecica(28)='recycmodeled5'
stomwuecica(29)='recycmeasured6'
stomwuecica(30)='recycmodeled6'
unitstomwuecica(1)='NA'
unitstomwuecica(2)='NA'
unitstomwuecica(3)='ppm'
unitstomwuecica(4)='Pa'
unitstomwuecica(5)='umolmmol-1'
unitstomwuecica(6)='umolmmol-1'
unitstomwuecica(7)='NA'
unitstomwuecica(8)='NA'
unitstomwuecica(9)='umolmol-1'
unitstomwuecica(10)='umolmol-1'
unitstomwuecica(11)='NA'
unitstomwuecica(12)='NA'
unitstomwuecica(13)='NA'
unitstomwuecica(14)='NA'
unitstomwuecica(15)='NA'
unitstomwuecica(16)='NA'
unitstomwuecica(17)='NA'
unitstomwuecica(18)='NA'
unitstomwuecica(19)='NA'
unitstomwuecica(20)='NA'
unitstomwuecica(21)='NA'
unitstomwuecica(22)='NA'
unitstomwuecica(23)='NA'
unitstomwuecica(24)='NA'
unitstomwuecica(25)='NA'
unitstomwuecica(26)='NA'
unitstomwuecica(27)='NA'
unitstomwuecica(28)='NA'
unitstomwuecica(29)='NA'
unitstomwuecica(30)='NA'
write(wuecicacompunit,'(200A)')((trim(stomwuecica(i)),','),
&i=1,29),trim(stomwuecica(30))
write(wuecicacompunit,'(200A)')((trim(unitstomwuecica(i)),','),
&i=1,29),trim(stomwuecica(30))
stomwuecica(1)='curveno'
stomwuecica(2)='curvename'
stomwuecica(3)='TotPoints'
stomwuecica(4)='gswCO2ithresl'
stomwuecica(5)='CO2AmbCurrent'
stomwuecica(6)='vpdl_ref'
stomwuecica(7)='Ballg0CO2sLin'
stomwuecica(8)='BallmCO2sLin'
stomwuecica(9)='BallrsqsLin'
stomwuecica(10)='Ballg0CO2iLin'
stomwuecica(11)='BallmCO2iLin'
stomwuecica(12)='BallrsqiLin'
stomwuecica(13)='Ballg0CO2s'
stomwuecica(14)='BallmCO2s'
stomwuecica(15)='Ballrsqs'
stomwuecica(16)='Rayg0CO2s'
stomwuecica(17)='RaymCO2s'
stomwuecica(18)='Rayd0CO2s'
stomwuecica(19)='RayrsqCO2s'
stomwuecica(20)='Belindag0CO2s'
stomwuecica(21)='Belindag1CO2s'
stomwuecica(22)='Belindad0CO2s'
stomwuecica(23)='BelindarsqCO2s'
stomwuecica(24)='Dewarg0CO2i'
stomwuecica(25)='DewarmCO2i'
stomwuecica(26)='Deward0CO2i'
stomwuecica(27)='DewarrsqCO2i'
stomwuecica(28)='WUEref'
stomwuecica(29)='der_WUEref'
stomwuecica(30)='rsqwue'
stomwuecica(31)='wuefit1'
stomwuecica(32)='wuefit2'
stomwuecica(33)='wuefit3'
stomwuecica(34)='wuefit4'
stomwuecica(35)='wuefit5'
stomwuecica(36)='IntrWUEref'
stomwuecica(37)='Intrder_WUEref'
stomwuecica(38)='Intrrsqwue'
stomwuecica(39)='Intrwuefit1'
stomwuecica(40)='Intrwuefit2'
stomwuecica(41)='Intrwuefit3'
stomwuecica(42)='Intrwuefit4'
stomwuecica(43)='Intrwuefit5'
stomwuecica(44)='CiCa-1Ref'
stomwuecica(45)='der_CiCa-1Ref'
stomwuecica(46)='rsqCiCa-1'
stomwuecica(47)='CiCa-1Fit1'
stomwuecica(48)='CiCa-1Fit2'
stomwuecica(49)='CiCa-1Fit3'
stomwuecica(50)='CiCa-1Fit4'
stomwuecica(51)='CiCa-1Fit5'
stomwuecica(52)='MeanLfTemp'
stomwuecica(53)='MeanAirTemp'
stomwuecica(54)='MeanVPDL'
stomwuecica(55)='MeanPARi'
stomwuecica(56)='CcCi-1Ref'
stomwuecica(57)='der_CcCi-1Ref'
stomwuecica(58)='rsqCcCi-1'
stomwuecica(59)='CcCi-1Fit1'
stomwuecica(60)='CcCi-1Fit2'
stomwuecica(61)='CcCi-1Fit3'
stomwuecica(62)='CcCi-1Fit4'
stomwuecica(63)='CcCi-1Fit5'
stomwuecica(64)='CcCi-1Fit6'
stomwuecica(65)='CcCi-2Ref'
stomwuecica(66)='der_CcCi-2Ref'
stomwuecica(67)='rsqCcCi-2'
stomwuecica(68)='CcCi-2Fit1'
stomwuecica(69)='CcCi-2Fit2'
stomwuecica(70)='CcCi-2Fit3'
stomwuecica(71)='CcCi-2Fit4'
stomwuecica(72)='CcCi-2Fit5'
stomwuecica(73)='CcCi-2Fit6'
stomwuecica(74)='CcCi-3Ref'
stomwuecica(75)='der_CcCi-3Ref'
stomwuecica(76)='rsqCcCi-3'
stomwuecica(77)='CcCi-3Fit1'
stomwuecica(78)='CcCi-3Fit2'
stomwuecica(79)='CcCi-3Fit3'
stomwuecica(80)='CcCi-3Fit4'
stomwuecica(81)='CcCi-3Fit5'
stomwuecica(82)='CcCi-3Fit6'
stomwuecica(83)='CcCi-4Ref'
stomwuecica(84)='der_CcCi-4Ref'
stomwuecica(85)='rsqCcCi-4'
stomwuecica(86)='CcCi-4Fit1'
stomwuecica(87)='CcCi-4Fit2'
stomwuecica(88)='CcCi-4Fit3'
stomwuecica(89)='CcCi-4Fit4'
stomwuecica(90)='CcCi-4Fit5'
stomwuecica(91)='CcCi-4Fit6'
stomwuecica(92)='Recyc-1Ref'
stomwuecica(93)='der_Recyc-1Ref'
stomwuecica(94)='rsqRecyc-1'
stomwuecica(95)='Recyc-1Fit1'
stomwuecica(96)='Recyc-1Fit2'
stomwuecica(97)='Recyc-1Fit3'
stomwuecica(98)='Recyc-1Fit4'
stomwuecica(99)='Recyc-1Fit5'
stomwuecica(100)='Recyc-2Ref'
stomwuecica(101)='der_Recyc-2Ref'
stomwuecica(102)='rsqRecyc-2'
stomwuecica(103)='Recyc-2Fit1'
stomwuecica(104)='Recyc-2Fit2'
stomwuecica(105)='Recyc-2Fit3'
stomwuecica(106)='Recyc-2Fit4'
stomwuecica(107)='Recyc-2Fit5'
stomwuecica(108)='Recyc-3Ref'
stomwuecica(109)='der_Recyc-3Ref'
stomwuecica(110)='rsqRecyc-3'
stomwuecica(111)='Recyc-3Fit1'
stomwuecica(112)='Recyc-3Fit2'
stomwuecica(113)='Recyc-3Fit3'
stomwuecica(114)='Recyc-3Fit4'
stomwuecica(115)='Recyc-3Fit5'
stomwuecica(116)='Recyc-4Ref'
stomwuecica(117)='der_Recyc-4Ref'
stomwuecica(118)='rsqRecyc-4'
stomwuecica(119)='Recyc-4Fit1'
stomwuecica(120)='Recyc-4Fit2'
stomwuecica(121)='Recyc-4Fit3'
stomwuecica(122)='Recyc-4Fit4'
stomwuecica(123)='Recyc-4Fit5'
stomwuecica(124)='Recyc-5Ref'
stomwuecica(125)='der_Recyc-5Ref'
stomwuecica(126)='rsqRecyc-5'
stomwuecica(127)='Recyc-5Fit1'
stomwuecica(128)='Recyc-5Fit2'
stomwuecica(129)='Recyc-5Fit3'
stomwuecica(130)='Recyc-5Fit4'
stomwuecica(131)='Recyc-5Fit5'
stomwuecica(132)='Recyc-6Ref'
stomwuecica(133)='der_Recyc-6Ref'
stomwuecica(134)='rsqRecyc-6'
stomwuecica(135)='Recyc-6Fit1'
stomwuecica(136)='Recyc-6Fit2'
stomwuecica(137)='Recyc-6Fit3'
stomwuecica(138)='Recyc-6Fit4'
stomwuecica(139)='Recyc-6Fit5'
unitstomwuecica(1)='NA'
unitstomwuecica(2)='NA'
unitstomwuecica(3)='NA'
unitstomwuecica(4)='ppm'
unitstomwuecica(5)='ppm'
unitstomwuecica(6)='PA'
unitstomwuecica(7)='molm-2s-1'
unitstomwuecica(8)='NA'
unitstomwuecica(9)='NA'
unitstomwuecica(10)='molm-2s-1'
unitstomwuecica(11)='NA'
unitstomwuecica(12)='NA'
unitstomwuecica(13)='molm-2s-1'
unitstomwuecica(14)='NA'
unitstomwuecica(15)='NA'
unitstomwuecica(16)='molm-2s-1'
unitstomwuecica(17)='NA'
unitstomwuecica(18)='Pa'
unitstomwuecica(19)='NA'
unitstomwuecica(20)='molm-2s-1'
unitstomwuecica(21)='(kPa)^0.5'
unitstomwuecica(22)='Pa'
unitstomwuecica(23)='NA'
unitstomwuecica(24)='molm-2s-1'
unitstomwuecica(25)='NA'
unitstomwuecica(26)='Pa'
unitstomwuecica(27)='NA'
unitstomwuecica(28)='umolmmol-1'
unitstomwuecica(29)='umolmmol-1ppm-1'
unitstomwuecica(30)='NA'
unitstomwuecica(31)='NA'
unitstomwuecica(32)='NA'
unitstomwuecica(33)='NA'
unitstomwuecica(34)='NA'
unitstomwuecica(35)='NA'
unitstomwuecica(36)='umolmol-1ppm-1'
unitstomwuecica(37)='umolmol-1ppm-1'
unitstomwuecica(38)='NA'
unitstomwuecica(39)='NA'
unitstomwuecica(40)='NA'
unitstomwuecica(41)='NA'
unitstomwuecica(42)='NA'
unitstomwuecica(43)='NA'
unitstomwuecica(44)='NA'
unitstomwuecica(45)='ppm-1'
unitstomwuecica(46)='NA'
unitstomwuecica(47)='NA'
unitstomwuecica(48)='NA'
unitstomwuecica(49)='NA'
unitstomwuecica(50)='NA'
unitstomwuecica(51)='NA'
unitstomwuecica(52)='oC'
unitstomwuecica(53)='oC'
unitstomwuecica(54)='Pa'
unitstomwuecica(55)='umolm-2s-1'
unitstomwuecica(56)='NA'
unitstomwuecica(57)='ppm-1'
unitstomwuecica(58)='NA'
unitstomwuecica(59)='NA'
unitstomwuecica(60)='NA'
unitstomwuecica(61)='NA'
unitstomwuecica(62)='NA'
unitstomwuecica(63)='NA'
unitstomwuecica(64)='NA'
unitstomwuecica(65)='NA'
unitstomwuecica(66)='ppm-1'
unitstomwuecica(67)='NA'
unitstomwuecica(68)='NA'
unitstomwuecica(69)='NA'
unitstomwuecica(70)='NA'
unitstomwuecica(71)='NA'
unitstomwuecica(72)='NA'
unitstomwuecica(73)='NA'
unitstomwuecica(74)='NA'
unitstomwuecica(75)='ppm-1'
unitstomwuecica(76)='NA'
unitstomwuecica(77)='NA'
unitstomwuecica(78)='NA'
unitstomwuecica(79)='NA'
unitstomwuecica(80)='NA'
unitstomwuecica(81)='NA'
unitstomwuecica(82)='NA'
unitstomwuecica(83)='NA'
unitstomwuecica(84)='ppm-1'
unitstomwuecica(85)='NA'
unitstomwuecica(86)='NA'
unitstomwuecica(87)='NA'
unitstomwuecica(88)='NA'
unitstomwuecica(89)='NA'
unitstomwuecica(90)='NA'
unitstomwuecica(91)='NA'
unitstomwuecica(92)='NA'
unitstomwuecica(93)='NA'
unitstomwuecica(94)='NA'
unitstomwuecica(95)='NA'
unitstomwuecica(96)='NA'
unitstomwuecica(97)='NA'
unitstomwuecica(98)='NA'
unitstomwuecica(99)='NA'
unitstomwuecica(100)='NA'
unitstomwuecica(101)='NA'
unitstomwuecica(102)='NA'
unitstomwuecica(103)='NA'
unitstomwuecica(104)='NA'
unitstomwuecica(105)='NA'
unitstomwuecica(106)='NA'
unitstomwuecica(107)='NA'
unitstomwuecica(108)='NA'
unitstomwuecica(109)='NA'
unitstomwuecica(110)='NA'
unitstomwuecica(111)='NA'
unitstomwuecica(112)='NA'
unitstomwuecica(113)='NA'
unitstomwuecica(114)='NA'
unitstomwuecica(115)='NA'
unitstomwuecica(116)='NA'
unitstomwuecica(117)='NA'
unitstomwuecica(118)='NA'
unitstomwuecica(119)='NA'
unitstomwuecica(120)='NA'
unitstomwuecica(121)='NA'
unitstomwuecica(122)='NA'
unitstomwuecica(123)='NA'
unitstomwuecica(124)='NA'
unitstomwuecica(125)='NA'
unitstomwuecica(126)='NA'
unitstomwuecica(127)='NA'
unitstomwuecica(128)='NA'
unitstomwuecica(129)='NA'
unitstomwuecica(130)='NA'
unitstomwuecica(131)='NA'
unitstomwuecica(132)='NA'
unitstomwuecica(133)='NA'
unitstomwuecica(134)='NA'
unitstomwuecica(135)='NA'
unitstomwuecica(136)='NA'
unitstomwuecica(137)='NA'
unitstomwuecica(138)='NA'
unitstomwuecica(139)='NA'
if(isitmassbased.eq.1)then
unitstomwuecica(7)='molkg-1s-1'
unitstomwuecica(10)='molkg-1s-1'
unitstomwuecica(13)='molkg-1s-1'
unitstomwuecica(16)='molkg-1s-1'
unitstomwuecica(20)='molkg-1s-1'
unitstomwuecica(24)='molkg-1s-1'
unitstomwuecica(55)='umolkg-1s-1'
endif
write(stomwuecicaoutunit,'(2000A)')((trim(stomwuecica(i)),','),
&i=1,139),((trim(sitevars(i)),','),i=1,22),trim(sitevars(23))
write(stomwuecicaoutunit,'(2000A)')((trim(unitstomwuecica(i)),
&','),i=1,139),((trim(unitsitevars(i)),','),i=1,22),
&trim(unitsitevars(23))
return
end
leafres/testarea/SetUpLeafGasFit.f
+1796
View File
File diff suppressed because it is too large Load Diff
leafres/testarea/StomatalConductance.f
+118
View File
@@ -0,0 +1,118 @@
subroutine StomatalConductance(pco2s,rehulfsurf,gammas,
& pvapordef_s,rayDzero,assim_net,istommodel,
& stomintercept,stomslope,gswmod)
implicit none
!=====================Inputs===================================
! pvapordef_s: water vapor partial pressure deficit at the leaf surface [Pa]
! istommodel: which stomatal conductance model to use
! 1 = Ball - Berry Model
! 2 = Ray Leuning model using leaf surface CO2 concentration
! 3 = Belinda E. Medlyn model
! 4 = Dewar model
! stomintercept: Interception in the Ball - Berry model or the Leuning version [mol H2O m-2 s-1]
! stomslope: Slope in the Ball - Berry model or the leuning version [--]
! rayDzero: D0 in the Ray Leuning modified Ball - Berry Model [Pa]
!
! assim_net: net rate of CO2 uptake per unit leaf area
! calculated from the biochemical model[umol m-2 s-1]
! gammas: CO2 compensation point (ppm)
! pco2s: CO2 concentration at the leaf surface or internal CO2 (ppm)
! rehulfsurf: relative humidity at the leaf surface [0-1]
integer istommodel
double precision pco2s,rehulfsurf,gammas,
& pvapordef_s,rayDzero,stomintercept,
& stomslope,assim_net
!=====================Outputs=================================
! gswmod: stomatal conductance for water vapor calculated
! from stomatal conductance model [mol m-2 s-1]
double precision gswmod
if(istommodel.eq.1)then
! Ball - Berry model
gswmod=stomintercept+stomslope*assim_net*
& rehulfsurf/pco2s
gswmod=dmax1(gswmod,stomintercept)
endif
if(istommodel.eq.2)then
! Ray Leuning model using leaf surface CO2 or internal CO2
gswmod=stomintercept+stomslope*assim_net/
& ((pco2s-gammas)*(1.0d0+pvapordef_s/rayDzero))
gswmod=dmax1(gswmod,stomintercept)
endif
if(istommodel.eq.3)then
!Belinda Medlyn model
gswmod=stomintercept+(1.0d0+stomslope/dsqrt(1.0d-3*pvapordef_s))
&*assim_net/pco2s
gswmod=dmax1(gswmod,stomintercept)
endif
if(istommodel.eq.4)then
! Dewar model
gswmod=(stomintercept+stomslope*assim_net)/
& (pco2s*(1.0d0+pvapordef_s/rayDzero))
gswmod=dmax1(gswmod,stomintercept)
endif
return
end subroutine StomatalConductance
subroutine Der_StomatalConductance(pco2s,rehulfsurf,
& gammas,pvapordef_s,rayDzero,assim_net,istommodel,
& stomintercept,stomslope,derivb,derivslope,derivd0)
implicit none
!=====================Inputs===================================
! pvapordef_s: water vapor partial pressure deficit at the leaf surface [Pa]
! istommodel: which stomatal conductance model to use
! 1 = Ball - Berry Model
! 2 = Ray Leuning model using leaf surface CO2 concentration
! 3 = Belinda Medlyn model
! 4 = Dewar model
! stomintercept: Interception in the Ball - Berry model or the Leuning version [mol H2O m-2 s-1]
! stomslope: Slope in the Ball - Berry model or the leuning version [--]
! rayDzero: D0 in the Ray Leuning modified Ball - Berry Model [Pa]
!
! assim_net: net rate of CO2 uptake per unit leaf area
! calculated from the biochemical model[umol m-2 s-1]
! gammas: CO2 compensation point (ppm)
! pco2s: CO2 concentration at the leaf surface or internal CO2 (ppm)
! rehulfsurf: relative humidity at the leaf surface [0-1]
integer istommodel
double precision pco2s,rehulfsurf,gammas,
& pvapordef_s,rayDzero,stomintercept,
& stomslope,assim_net
!=====================Outputs=================================
! gswmod: stomatal conductance for water vapor calculated
! from stomatal conductance model [mol m-2 s-1]
double precision derivb,derivslope,derivd0
derivb=1.0d0
if(istommodel.eq.1)then
! Ball - Berry model
derivslope=assim_net*rehulfsurf/pco2s
endif
if(istommodel.eq.2)then
! Ray Leuning model using leaf surface CO2
derivslope=assim_net/
& ((pco2s-gammas)*(1.0d0+pvapordef_s/rayDzero))
derivd0=(stomslope*assim_net/(pco2s-gammas))*
& pvapordef_s/((rayDzero+pvapordef_s)**2.0d0)
endif
if(istommodel.eq.3)then
! Belinda E. Medlyn model
derivslope=assim_net/(pco2s*dsqrt(1.0d-3*pvapordef_s))
endif
if(istommodel.eq.4)then
! Ray Leuning model using leaf surface partial pressure
derivb=1.0d0/(pco2s*(1.0d0+pvapordef_s/rayDzero))
derivslope=assim_net/
& (pco2s*(1.0d0+pvapordef_s/rayDzero))
derivd0=((stomintercept+stomslope*assim_net)/pco2s)*
& pvapordef_s/((rayDzero+pvapordef_s)**2.0d0)
endif
return
end subroutine Der_StomatalConductance
leafres/testarea/ToLeafGasOptimization.f
+577
View File
@@ -0,0 +1,577 @@
subroutine ToLeafGasOptimization(ntotfiles,ACidata,dataunit,
&spareunit,datapath,indexunit,ierr)
implicit none
!--------------All inputs except for ierr. Outputs are written to files----------------
integer ntotfiles,dataunit,spareunit,ierr(2),indexunit(20)
!ierr(1)=0, ok, >1 input data out of range
!ierr(2) specifies in which input file, the data is out of range
character*100 datapath,ACidata(ntotfiles)
!-------------------------------------------------------------------------------
integer ntotpoints,npoints(ntotfiles),i,j,k,n,curveno(ntotfiles),
&iobs,maxobs,nmax,iwarning,warningunit,isitmassbased(ntotfiles),
&iprintheader(ntotfiles),ivector(1000),startline
parameter(maxobs=2000,nmax=100)
character*100 sample(ntotfiles)
character*50 chartime,siteID(ntotfiles),species(ntotfiles),ftime,
&longchar1*50000,longchar*5000,charvars(500),
&woodporosity(ntotfiles)
double precision esat,Latitude(ntotfiles),Longitude(ntotfiles),
&Elevation(ntotfiles),yearsampled(ntotfiles),sampledoy(ntotfiles),
&GrowingSeasonStart(ntotfiles),GrowingSeasonEnd(ntotfiles),
&standage(ntotfiles),CanopyHeight(ntotfiles),
&LeafAreaIndex(ntotfiles),MeanTimeBtwnSteadyReadings(ntotfiles),
&SampleHeight(ntotfiles),Needleage(ntotfiles),
&specificLAI(ntotfiles),nitrogencontent(ntotfiles),
&carboncontent(ntotfiles),avetimeresolution(ntotfiles),
&avetimesampled(ntotfiles),phoscontent(ntotfiles),
&sapwooddensity(ntotfiles),leafratio(ntotfiles),
&stom_COND_mol,CO2i_ppm,transp_mmol,vpdl_KPa,BLCond,Tair_oC,
&Tleaf_oC,CO2chamber_ppm,H2OS_mmol,RH_S100,PARi_umol,Press_KPa,
&oxygeni_KPa,PNcor_umol,uncorphoto,chamberarea,stmrad,tblk,co2r,
&h2or,rh_r,flow,paro,csmch,hsmch,stablef,listatus,phips2,
&ambientvaporpres,pari(ntotfiles,maxobs),
&templeaf(ntotfiles,maxobs),pres_air(ntotfiles,maxobs),
&yAnet(ntotfiles,maxobs),po2i(ntotfiles,maxobs),
&trmmol(ntotfiles,maxobs),gswmeas(ntotfiles,maxobs),
&vpdl(ntotfiles,maxobs),tempair(ntotfiles,maxobs),
&eambient(ntotfiles,maxobs),xpco2i_ppm(ntotfiles,maxobs),
&xpco2i(ntotfiles,maxobs),co2a_ppm(ntotfiles,maxobs),
&pco2ambient(ntotfiles,maxobs),sampletime(ntotfiles,maxobs),
&chlflphips2(ntotfiles,maxobs),CurveTypeID(ntotfiles,maxobs),
&fo_pam(ntotfiles,maxobs),fm_pam(ntotfiles,maxobs),
&fs_pam(ntotfiles,maxobs),pam_measlight(ntotfiles,maxobs),
&vectorhorse(maxobs),stargamma25_usr(ntotfiles),
&fkc25_usr(ntotfiles),fko25_usr(ntotfiles),tissuearea,tissuemass,
&rdlight25_usr(ntotfiles),alpha25_usr(ntotfiles),datumlimit,
&resistwp25_usr(ntotfiles),resistch25_usr(ntotfiles),gtc,gtw,
&term,term1,H2OLeaf_mmol,fo_fluoresce,fm_fluoresce,fs_fluoresce,
&f_measlight,stdpar,fmeanpar,xminpar,xmaxpar,
&stdco2,fmeanco2,xminco2,xmaxco2
!
warningunit=indexunit(10)
ierr(1)=0
! open(unit=121,file='sphagnumdata.csv')
! write(121,'(200A)')'name,','hhmmss,','no,','time,','datumlimit,',
! &'stom_COND_mol,','CO2chamber_ppm,','CO2i_ppm,','PARi_umol,',
! &'Tleaf_oC,','Tair_oC,','transp_mmol,','PNcor_umol,','H2OS_mmol,',
! &'RH_S100'
!We read all files at once
do 10 i=1,ntotfiles
isitmassbased(i)=0
iwarning=0
ierr(2)=i
npoints(i)=0
sample(i)=trim(ACidata(i))
!fill any blank spaces in sample(i) with '_'
1 j=index(trim(sample(i)),' ')
if(j.gt.0)then
sample(i)(j:j)='_'
goto 1
endif
curveno(i)=i
!
!========================================================================================================================
!In early 2015, the following section of code is added to allow flexibity for the starting rows to be used for metadata.
!There is no need for a strict number of rows for metadata because the main data section is now determined automatically.
!Locate the rows for the actual data
open(unit=dataunit,file=
&trim(datapath)//trim(ACidata(i))//'middle')
open(unit=spareunit,file=trim(datapath)//trim(ACidata(i)))
read(spareunit,fmt=300,err=40,end=40)longchar1
rewind(spareunit)
2 read(spareunit,fmt=300,err=40,end=5)longchar1
3 k=index(longchar1,char(13))
if(k.gt.0)then
!DOS text format, convert it to unix format
longchar1(k:k+len(char(10))-1)=char(10)
goto 3
endif
write(dataunit,340)trim(longchar1)
goto 2
5 close(spareunit)
rewind(dataunit)
open(unit=spareunit,file=
&trim(datapath)//trim(ACidata(i))//'clean')
7 read(dataunit,fmt=310,err=40,end=9)longchar
if(longchar.eq.''.or.longchar.eq.' ')goto 7
call charlineparser(longchar,nmax,charvars,n)
if(n.eq.0)goto 7
write(spareunit,340)trim(longchar)
goto 7
9 rewind(spareunit)
close(dataunit,status='delete')
j=0
500 read(spareunit,fmt=310,err=40,end=600)longchar
call charlineparser(longchar,nmax,charvars,n)
j=j+1
ivector(j)=n
goto 500
600 if(j.lt.12)then
close(spareunit,status='delete')
goto 630
else
rewind(spareunit)
endif
startline=0
610 startline=startline+1
if(startline.gt.j-11)goto 40
n=0
if(ivector(startline).ne.ivector(startline+1))n=1
if(ivector(startline).ne.ivector(startline+2))n=1
if(ivector(startline+2).lt.15.or.ivector(startline+2).gt.25)n=1
if(ivector(startline+3).ne.ivector(startline+4))n=1
if(ivector(startline+3).ne.ivector(startline+5))n=1
if(ivector(startline+5).lt.5.or.ivector(startline+5).gt.10)n=1
if(ivector(startline+6).ne.ivector(startline+7))n=1
if(ivector(startline+6).ne.ivector(startline+8))n=1
if(ivector(startline+8).ne.ivector(startline+9))n=1
if(ivector(startline+8).ne.ivector(startline+10))n=1
if(ivector(startline+8).ne.ivector(startline+11))n=1
if(ivector(startline+8).lt.25)n=1
if(n.eq.1)goto 610
!startline is the line 'Elevation,SampleYear,SampleDayOfYear.....'
!In general
!Line 1-10 describe the general information about the data
!Line 11-12 are the header lines for line 13
!Line 13 gives the site information and the data about the leaf sampled
!Line 14-15 are the header lines for lines 16
!Line 16 user-supplied parameter values
!Line 17-18 are the header lines for lines 19 and higer
!Line 19 and higher: actual gas exchange data
do j=1,startline+1
read(spareunit,*)
enddo
!=========================================================================================================================
read(spareunit,fmt=310,err=13)longchar
call charlineparser(longchar,nmax,charvars,n)
do j=n+1,nmax
charvars(j)='-9999'
enddo
siteID(i)=trim(charvars(1))
species(i)=trim(charvars(12))
woodporosity(i)=trim(charvars(20))
n=len(trim(charvars(2)))
call extCharToFloatNum(n,charvars(2),Latitude(i),j)
n=len(trim(charvars(3)))
call extCharToFloatNum(n,charvars(3),Longitude(i),j)
n=len(trim(charvars(4)))
call extCharToFloatNum(n,charvars(4),Elevation(i),j)
n=len(trim(charvars(5)))
call extCharToFloatNum(n,charvars(5),yearsampled(i),j)
n=len(trim(charvars(6)))
call extCharToFloatNum(n,charvars(6),sampledoy(i),j)
n=len(trim(charvars(7)))
call extCharToFloatNum(n,charvars(7),GrowingSeasonStart(i),j)
n=len(trim(charvars(8)))
call extCharToFloatNum(n,charvars(8),GrowingSeasonEnd(i),j)
n=len(trim(charvars(9)))
call extCharToFloatNum(n,charvars(9),standage(i),j)
n=len(trim(charvars(10)))
call extCharToFloatNum(n,charvars(10),CanopyHeight(i),j)
n=len(trim(charvars(11)))
call extCharToFloatNum(n,charvars(11),LeafAreaIndex(i),j)
n=len(trim(charvars(13)))
call extCharToFloatNum(n,charvars(13),
&MeanTimeBtwnSteadyReadings(i),j)
n=len(trim(charvars(14)))
call extCharToFloatNum(n,charvars(14),SampleHeight(i),j)
n=len(trim(charvars(15)))
call extCharToFloatNum(n,charvars(15),Needleage(i),j)
n=len(trim(charvars(16)))
call extCharToFloatNum(n,charvars(16),specificLAI(i),j)
n=len(trim(charvars(17)))
call extCharToFloatNum(n,charvars(17),nitrogencontent(i),j)
n=len(trim(charvars(18)))
call extCharToFloatNum(n,charvars(18),carboncontent(i),j)
n=len(trim(charvars(19)))
call extCharToFloatNum(n,charvars(19),phoscontent(i),j)
n=len(trim(charvars(21)))
call extCharToFloatNum(n,charvars(21),sapwooddensity(i),j)
n=len(trim(charvars(22)))
call extCharToFloatNum(n,charvars(22),leafratio(i),j)
do j=1,2
read(spareunit,*)
enddo
read(spareunit,fmt=310,err=36)longchar
call charlineparser(longchar,nmax,charvars,n)
do j=n+1,nmax
charvars(j)='-9999'
enddo
n=len(trim(charvars(1)))
call extCharToFloatNum(n,charvars(1),stargamma25_usr(i),j)
n=len(trim(charvars(2)))
call extCharToFloatNum(n,charvars(2),fkc25_usr(i),j)
n=len(trim(charvars(3)))
call extCharToFloatNum(n,charvars(3),fko25_usr(i),j)
n=len(trim(charvars(4)))
call extCharToFloatNum(n,charvars(4),alpha25_usr(i),j)
n=len(trim(charvars(5)))
call extCharToFloatNum(n,charvars(5),rdlight25_usr(i),j)
n=len(trim(charvars(6)))
call extCharToFloatNum(n,charvars(6),resistwp25_usr(i),j)
n=len(trim(charvars(7)))
call extCharToFloatNum(n,charvars(7),resistch25_usr(i),j)
if(stargamma25_usr(i).lt.0.0d0.or.
&stargamma25_usr(i).gt.500.0d0)stargamma25_usr(i)=-9999.0d0
if(fkc25_usr(i).lt.0.0d0.or.fkc25_usr(i).gt.5000.0d0)
&fkc25_usr(i)=-9999.0d0
if(fko25_usr(i).lt.0.0d0.or.fko25_usr(i).gt.90000.0d0)
&fko25_usr(i)=-9999.0d0
if(alpha25_usr(i).lt.0.0d0.or.alpha25_usr(i).gt.1.0d0)
&alpha25_usr(i)=-9999.0d0
if(rdlight25_usr(i).lt.0.0d0.or.rdlight25_usr(i).gt.100.0d0)
&rdlight25_usr(i)=-9999.0d0
if(resistwp25_usr(i).lt.0.0d0.or.resistwp25_usr(i).gt.10000.0d0)
&resistwp25_usr(i)=-9999.0d0
if(resistwp25_usr(i).lt.0.0d0.or.resistwp25_usr(i).gt.10000.0d0)
&resistch25_usr(i)=-9999.0d0
do j=1,2
read(spareunit,*)
enddo
20 read(spareunit,fmt=310,err=39,end=100)longchar
call charlineparser(longchar,nmax,charvars,n)
if(n.le.25)goto 20
do j=n+1,nmax
charvars(j)='-9999'
enddo
chartime=trim(charvars(2))
ftime=trim(charvars(3))
n=len(trim(charvars(1)))
call extCharToFloatNum(n,charvars(1),term,j)
iObs=idnint(term)
n=len(trim(charvars(4)))
call extCharToFloatNum(n,charvars(4),uncorphoto,j)
n=len(trim(charvars(5)))
call extCharToFloatNum(n,charvars(5),PNcor_umol,j)
if(dabs(PNcor_umol+9999.0d0).lt.1.0d-4)PNcor_umol=uncorphoto
n=len(trim(charvars(6)))
call extCharToFloatNum(n,charvars(6),stom_COND_mol,j)
n=len(trim(charvars(7)))
call extCharToFloatNum(n,charvars(7),CO2i_ppm,j)
n=len(trim(charvars(8)))
call extCharToFloatNum(n,charvars(8),transp_mmol,j)
n=len(trim(charvars(9)))
call extCharToFloatNum(n,charvars(9),vpdl_KPa,j)
n=len(trim(charvars(10)))
call extCharToFloatNum(n,charvars(10),chamberarea,j)
n=len(trim(charvars(11)))
call extCharToFloatNum(n,charvars(11),stmrad,j)
n=len(trim(charvars(12)))
call extCharToFloatNum(n,charvars(12),BLCond,j)
n=len(trim(charvars(13)))
call extCharToFloatNum(n,charvars(13),Tair_oC,j)
n=len(trim(charvars(14)))
call extCharToFloatNum(n,charvars(14),Tleaf_oC,j)
n=len(trim(charvars(15)))
call extCharToFloatNum(n,charvars(15),tblk,j)
n=len(trim(charvars(16)))
call extCharToFloatNum(n,charvars(16),co2r,j)
n=len(trim(charvars(17)))
call extCharToFloatNum(n,charvars(17),CO2chamber_ppm,j)
n=len(trim(charvars(18)))
call extCharToFloatNum(n,charvars(18),h2or,j)
n=len(trim(charvars(19)))
call extCharToFloatNum(n,charvars(19),H2OS_mmol,j)
n=len(trim(charvars(20)))
call extCharToFloatNum(n,charvars(20),rh_r,j)
n=len(trim(charvars(21)))
call extCharToFloatNum(n,charvars(21),RH_S100,j)
n=len(trim(charvars(22)))
call extCharToFloatNum(n,charvars(22),flow,j)
n=len(trim(charvars(23)))
call extCharToFloatNum(n,charvars(23),PARi_umol,j)
n=len(trim(charvars(24)))
call extCharToFloatNum(n,charvars(24),paro,j)
n=len(trim(charvars(25)))
call extCharToFloatNum(n,charvars(25),Press_KPa,j)
n=len(trim(charvars(26)))
call extCharToFloatNum(n,charvars(26),csmch,j)
n=len(trim(charvars(27)))
call extCharToFloatNum(n,charvars(27),hsmch,j)
n=len(trim(charvars(28)))
call extCharToFloatNum(n,charvars(28),stablef,j)
n=len(trim(charvars(29)))
call extCharToFloatNum(n,charvars(29),listatus,j)
n=len(trim(charvars(30)))
call extCharToFloatNum(n,charvars(30),phips2,j)
n=len(trim(charvars(31)))
call extCharToFloatNum(n,charvars(31),oxygeni_KPa,j)
n=len(trim(charvars(32)))
call extCharToFloatNum(n,charvars(32),datumlimit,j)
n=len(trim(charvars(33)))
call extCharToFloatNum(n,charvars(33),tissuearea,j)
n=len(trim(charvars(34)))
call extCharToFloatNum(n,charvars(34),tissuemass,j)
!
n=len(trim(charvars(35)))
call extCharToFloatNum(n,charvars(35),fo_fluoresce,j)
n=len(trim(charvars(36)))
call extCharToFloatNum(n,charvars(36),fm_fluoresce,j)
n=len(trim(charvars(37)))
call extCharToFloatNum(n,charvars(37),fs_fluoresce,j)
n=len(trim(charvars(38)))
call extCharToFloatNum(n,charvars(38),f_measlight,j)
if(tissuearea.gt.0.0d0.and.tissuemass.gt.0.0d0)then
!We assume the user requires mass-based calculations. We convert net photosynthesis,
!transpiration, conductance and PAR from area basis to mass basis. All fitted parameters
!are mass-based. However, mixing area- and mass- based calculations is not allowed.
if(npoints(i).gt.0.and.isitmassbased(i).eq.0)goto 34
isitmassbased(i)=1
!Convert PAR from umol/m2/s to umol/kg/s. tissuearea is in cm2 and tissuemass in in g
PARi_umol=PARi_umol*tissuearea/(tissuemass*10.0d0)
term=(H2OS_mmol-h2or)/(1000.0d0-H2OS_mmol)
transp_mmol=(flow/tissuemass)*term
term=co2r-CO2chamber_ppm*(1000.0d0-h2or)/(1000.0d0-H2OS_mmol)
PNcor_umol=(1.0d-3*flow/tissuemass)*term
H2OLeaf_mmol=esat(Tleaf_oC+273.15d0,Press_KPa*1000.0d0)/
&Press_KPa
!gtw is the conductance for water vapor between the water film and free air
gtw=transp_mmol*1.0d-3*(1.0d+3-(H2OLeaf_mmol+H2OS_mmol)/2.0d0)
&/(H2OLeaf_mmol-H2OS_mmol)
!we assume no stomatal conductance. We use the ratio of diffusivities of CO2 and water vapor in air (1.6),
!rather than the ratio of diffusivities of CO2 and water vapor in the boundary layer (1.37) as the latter applies
!to Pohlhausen analysis of mass transfer from a plate in laminar parallel flows which is probably not true
!for Sphagnum tissues.
gtc=gtw/1.6d0
!we set treat gtw as if it is stomatal conductance.
stom_COND_mol=gtw
CO2i_ppm=((gtc-1.0d-3*transp_mmol/2.0d0)*CO2chamber_ppm-
&PNcor_umol)/(gtc-1.0d-3*transp_mmol/2.0d0)
else
if(isitmassbased(i).ne.0)goto 34
endif
if(isitmassbased(i).eq.0)then
term=-100.0d0
term1=200.0d0
else
term=-9998.0d0
term1=1.0d+10
endif
if(PNcor_umol.lt.term.or.PNcor_umol.gt.term1)then
ierr(1)=1
if(fm_fluoresce.le.0.0d0)return
else
if(transp_mmol.gt.0.0d0.and.stom_COND_mol.gt.0.0d0
&.and.BLCond.gt.0.0d0)then
!use the corrected PN to calculate the Ci
!we assume BLCond already takes into account the stomatal ratio.
!for Missouri MOFLUX data, only 2004-2008 data need this correction
gtc=1.0d0/(1.6d0/stom_COND_mol+1.37d0/BLCond)
term=((gtc-transp_mmol*0.001d0/2.0d0)*CO2chamber_ppm
&-PNcor_umol)/(gtc+transp_mmol*0.001d0/2.0d0)
if(dabs(term-CO2i_ppm).gt.5.0d0)then
if(iwarning.eq.0)then
write(warningunit,*)'In file ',trim(sample(i))
write(warningunit,*)'Provided CO2i values do not agree with other
&input variables. Make sure input data are ok'
write(warningunit,*)'Original CO2i',',','Calculated CO2i'
iwarning=1
endif
write(warningunit,*)CO2i_ppm,',',term
endif
! CO2i_ppm=term
endif
endif
if(CO2i_ppm.le.0.0d0.or.CO2i_ppm.gt.10000.0d0)then
! ierr(1)=2
! return
if(fm_fluoresce.le.0.0d0)goto 20
endif
if(Tleaf_oC.lt.-50.0d0.or.Tleaf_oC.gt.100.0d0)then
ierr(1)=3
if(fm_fluoresce.le.0.0d0)return
endif
if(isitmassbased(i).eq.0)then
term1=1.0d+5
else
term1=1.0d+10
endif
if(PARi_umol.lt.-10.01d0.or.PARi_umol.gt.term1)then
ierr(1)=4
return
else
PARi_umol=dmax1(0.0d0,PARi_umol)
endif
if(Press_KPa.lt.50.0d0.or.Press_KPa.gt.150.0d0)then
Press_KPa=98.9d0
! ierr(1)=5
! return
endif
if(Tair_oC.lt.-50.0d0.or.Tair_oC.gt.100.0d0)then
Tair_oC=Tleaf_oC
endif
if(vpdl_KPa.lt.0.0d0.or.vpdl_KPa.gt.1000.0d0)then
if(H2OS_mmol.gt.0.0d0)then
term=H2OS_mmol*0.001d0/(1.0d0+H2OS_mmol*0.001d0)
term=term*Press_KPa
vpdl_KPa=esat((Tleaf_oC+273.15d0),(Press_KPa*1000.0d0))
vpdl_KPa=vpdl_KPa*0.001d0-term
else
if(RH_S100.ge.0.0d0.and.RH_S100.le.100.0d0)then
term=0.01d0*RH_S100*
& esat((Tair_oC+273.15d0),(Press_KPa*1000.0d0))
vpdl_KPa=0.001d0*(
& esat((Tleaf_oC+273.15d0),(Press_KPa*1000.0d0))-term)
else
vpdl_KPa=1.6d0
endif
endif
endif
if(H2OS_mmol.lt.0.0d0)then
if(RH_S100.lt.0.0d0.or.RH_S100.gt.100.0d0)then
ambientvaporpres=esat((Tair_oC+273.15d0),
& (Press_KPa*1000.0d0))-vpdl_KPa*1000.0d0
ambientvaporpres=dmax1(0.0d0,ambientvaporpres)
else
ambientvaporpres=0.01d0*RH_S100*esat((Tair_oC+273.15d0),
& (Press_KPa*1000.0d0))
endif
else
ambientvaporpres=H2OS_mmol*0.001d0/(1.0d0+H2OS_mmol*0.001d0)
ambientvaporpres=ambientvaporpres*Press_KPa*1000.0d0
endif
npoints(i)=npoints(i)+1
pari(i,npoints(i))=PARi_umol
if(Tleaf_oC.gt.-50.0d0.and.Tleaf_oC.lt.100.0d0)then
templeaf(i,npoints(i))=Tleaf_oC+273.15d0
else
templeaf(i,npoints(i))=-9999.0d0
endif
pres_air(i,npoints(i))=Press_KPa*1000.0d0
yAnet(i,npoints(i))=PNcor_umol
if(oxygeni_KPa.le.0.0d0.or.oxygeni_KPa.ge.Press_KPa)then
po2i(i,npoints(i))=0.2095d0*pres_air(i,npoints(i))
else
po2i(i,npoints(i))=oxygeni_KPa*1000.0d0
endif
trmmol(i,npoints(i))=transp_mmol
gswmeas(i,npoints(i))=stom_COND_mol
vpdl(i,npoints(i))=vpdl_KPa*1000.0d0
if(Tair_oC.gt.-50.0d0.and.Tair_oC.lt.100.0d0)then
tempair(i,npoints(i))=Tair_oC+273.15d0
else
tempair(i,npoints(i))=-9999.0d0
endif
eambient(i,npoints(i))=ambientvaporpres
chlflphips2(i,npoints(i))=phips2
fo_pam(i,npoints(i))=fo_fluoresce
fm_pam(i,npoints(i))=fm_fluoresce
fs_pam(i,npoints(i))=fs_fluoresce
pam_measlight(i,npoints(i))=f_measlight
!the unit of CO2 is in umol/mol. We use both umol/mol and Pa. Li-Cor 6400
!measures CO2 on a moist air basis.
xpco2i_ppm(i,npoints(i))=CO2i_ppm
xpco2i(i,npoints(i))=CO2i_ppm*
& pres_air(i,npoints(i))*1.0d-6
if(CO2chamber_ppm.gt.0.0d0)then
co2a_ppm(i,npoints(i))=CO2chamber_ppm
pco2ambient(i,npoints(i))=CO2chamber_ppm*
& pres_air(i,npoints(i))*1.0d-6
else
pco2ambient(i,npoints(i))=-9999.0d0
co2a_ppm(i,npoints(i))=-9999.0d0
endif
CurveTypeID(i,npoints(i))=datumlimit
call CharToNumeric(chartime,term)
sampletime(i,npoints(i))=term
goto 20
100 close(spareunit,status='delete')
do j=1,npoints(i)
vectorhorse(j)=sampletime(i,j)
call time_resolution(npoints(i),vectorhorse,
& avetimeresolution(i),avetimesampled(i))
enddo
630 continue
10 enddo
iprintheader(1)=1
do i=2,ntotfiles
if(isitmassbased(i).eq.isitmassbased(i-1))then
iprintheader(i)=0
else
iprintheader(i)=1
endif
enddo
k=1
do i=1,ntotfiles
if(k.eq.1.or.iprintheader(i).eq.1)then
call LeafGasPrintToFiles(isitmassbased(i:i),indexunit)
k=0
endif
if(npoints(i).lt.3)goto 1112
!-----------------------------------------------------
!detect A/Ci or light response curves with many points but no curve types are given
if(npoints(i).ge.7)then
j=0
do n=1,npoints(i)
if(CurveTypeID(i,n).gt.0)j=1
enddo
if(j.eq.0)then
call stdmaxmeanmin(npoints(i),pari(i:i,1:npoints(i)),
&stdpar,fmeanpar,xminpar,xmaxpar)
stdpar=100.0d0*(xmaxpar-xminpar)/fmeanpar
call stdmaxmeanmin(npoints(i),pco2ambient(i:i,1:npoints(i)),
&stdco2,fmeanco2,xminco2,xmaxco2)
stdco2=100.0d0*(xmaxco2-xminco2)/fmeanco2
if(stdpar.lt.5.0d0.and.stdco2.gt.5.0d0)then
!ACi curve
do n=1,npoints(i)
CurveTypeID(i,n)=11
enddo
else
if(stdpar.gt.5.0d0.and.stdco2.lt.5.0d0)then
!light response curve
do n=1,npoints(i)
CurveTypeID(i,n)=31
enddo
endif
endif
endif
endif
!------------------------------------------------------
call SetUpLeafGasFit(curveno(i:i),sample(i:i),npoints(i:i),
&CurveTypeID(i:i,1:npoints(i)),yAnet(i:i,1:npoints(i)),
&xpco2i(i:i,1:npoints(i)),templeaf(i:i,1:npoints(i)),
&pari(i:i,1:npoints(i)),pres_air(i:i,1:npoints(i)),
&po2i(i:i,1:npoints(i)),chlflphips2(i:i,1:npoints(i)),
&pco2ambient(i:i,1:npoints(i)),trmmol(i:i,1:npoints(i)),
&gswmeas(i:i,1:npoints(i)),vpdl(i:i,1:npoints(i)),
&tempair(i:i,1:npoints(i)),eambient(i:i,1:npoints(i)),
&fo_pam(i:i,1:npoints(i)),fm_pam(i:i,1:npoints(i)),
&fs_pam(i:i,1:npoints(i)),pam_measlight(i:i,1:npoints(i)),
&stargamma25_usr(i:i),fkc25_usr(i:i),fko25_usr(i:i),
&rdlight25_usr(i:i),alpha25_usr(i:i),resistwp25_usr(i:i),
&resistch25_usr(i:i),isitmassbased(i:i),indexunit,
&siteID(i:i),Latitude(i:i),Longitude(i:i),Elevation(i:i),
&yearsampled(i:i),sampledoy(i:i),GrowingSeasonStart(i:i),
&GrowingSeasonEnd(i:i),standage(i:i),CanopyHeight(i:i),
&LeafAreaIndex(i:i),species(i:i),avetimeresolution(i:i),
&avetimesampled(i:i),SampleHeight(i:i),Needleage(i:i),
&specificLAI(i:i),nitrogencontent(i:i),carboncontent(i:i),
&phoscontent(i:i),woodporosity(i:i),sapwooddensity(i:i),
&leafratio(i:i))
1112 continue
enddo
return
13 ierr(1)=13
return
34 ierr(1)=34
return
36 ierr(1)=36
return
39 ierr(1)=39
return
40 ierr(1)=40
return
300 format(a50000)
310 format(a5000)
340 format(a)
end subroutine ToLeafGasOptimization
!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
leafres/testarea/UnivParamsAlloc.f
+87
View File
@@ -0,0 +1,87 @@
subroutine UnivParamsAlloc(iswitch)
implicit none
include '../testarea/LeafGasParams.h'
include '../testarea/LeafGasHybridFit.h'
integer iswitch,i
!ilimittype=1: Rubisco,RuBp and TPU limitations
!ilimittype=2: Rubisco and RuBp limitations only
!ilimittype=3: Rubisco and TPU limitations only
!ilimittype=4: RuBp and TPU limitations only
!ilimittype=5: Rubisco limitation only
!ilimittype=6: RuBp limitation only
!ilimittype=7: TPU limitation only
!iswitch=1: initilize the array of univparams
!iswitch=2: allcoate the array of univparams to corresponding parameters
if(iswitch.eq.2)then
resistwp25=univparams(1)
resistch25=univparams(2)
rdlight25=univparams(3)
stargamma25=univparams(4)
vcmax25=univparams(5)
fkc25=univparams(6)
fko25=univparams(7)
fjmax25=univparams(8)
tpu25=univparams(9)
alpha25=univparams(10)
phifactor=univparams(11)
thetafactor=univparams(12)
betaPSII=univparams(13)
ha_darkresp=univparams(14)
ha_stargamma=univparams(15)
ha_vcmax=univparams(16)
ha_jmax=univparams(17)
ha_tpu=univparams(18)
ha_gmeso=univparams(19)
return
else
do i=1,ntotunivparams
!Initialize ifixunivparams to keep all parameters unchanged
ifixunivparams(i)=0
enddo
!
if(Currentiknowlimit.eq.-1)then
!Fluorescence only fit
if(idorwp.eq.1)ifixunivparams(1)=1
if(idorch.eq.1)ifixunivparams(2)=1
if(idord.eq.1)ifixunivparams(3)=1
if(idostargamma.eq.1)ifixunivparams(4)=1
if(idobetaPSII.eq.1)ifixunivparams(13)=1
if(idoha_darkresp.eq.1)ifixunivparams(14)=1
if(idoha_stargamma.eq.1)ifixunivparams(15)=1
if(idoha_gmeso.eq.1)ifixunivparams(19)=1
return
endif
!
if(idorwp.eq.1)ifixunivparams(1)=1
if(idorch.eq.1)ifixunivparams(2)=1
if(idord.eq.1)ifixunivparams(3)=1
if(idostargamma.eq.1)ifixunivparams(4)=1
if(Currentilimittype.le.3.or.Currentilimittype.eq.5)then
!Rubisco limit involved
ifixunivparams(5)=1
if(idokc.eq.1)ifixunivparams(6)=1
if(idoko.eq.1)ifixunivparams(7)=1
if(idoha_vcmax)ifixunivparams(16)=1
endif
if(Currentilimittype.le.2.or.Currentilimittype.eq.4.or.
&Currentilimittype.eq.6)then
!RuBp limit involved
ifixunivparams(8)=1
if(idoha_jmax.eq.1)ifixunivparams(17)=1
if(idophifactor.eq.1)ifixunivparams(11)=1
if(idothetafactor.eq.1)ifixunivparams(12)=1
if(idobetaPSII.eq.1)ifixunivparams(13)=1
endif
if(Currentilimittype.eq.1.or.Currentilimittype.eq.3.or.
&Currentilimittype.eq.4.or.Currentilimittype.eq.7)then
!tpu limit involved
ifixunivparams(9)=1
if(idoalpha.eq.1)ifixunivparams(10)=1
if(idoha_tpu.eq.1)ifixunivparams(18)=1
endif
if(idoha_darkresp.eq.1)ifixunivparams(14)=1
if(idoha_stargamma.eq.1)ifixunivparams(15)=1
if(idoha_gmeso.eq.1)ifixunivparams(19)=1
return
endif
end subroutine UnivParamsAlloc
leafres/testarea/UnivPhotoFit.f
+409
View File
@@ -0,0 +1,409 @@
subroutine UnivPhotoFit()
implicit none
include '../testarea/LeafGasParams.h'
include '../testarea/LeafGasHybridFit.h'
integer i,j,k,Priornumrubis,Priornumrubp,Priornumtpu,
&Currentnumrubis,Currentnumrubp,Currentnumtpu,Postnumrubis,
&Postnumrubp,Postnumtpu,Postilimittype
double precision term,term1,term2,term3,term4,term5,term6,
&term7,term8,term9
!
if(Prioriknowlimit.eq.1.or.Prioriknowlimit.eq.2)then
ntotsamples=0
do i=1,nFixedPoints
ntotsamples=ntotsamples+1
Prioriphotolimit(ntotsamples)=Fixediphotolimit(i)
enddo
do j=1,numACicurves
do i=1,nACiPoints(j)
ntotsamples=ntotsamples+1
Prioriphotolimit(ntotsamples)=ACiiphotolimit(i,j)
enddo
enddo
do j=1,numALightcurves
do i=1,nALightPoints(j)
ntotsamples=ntotsamples+1
Prioriphotolimit(ntotsamples)=ALightiphotolimit(i,j)
enddo
enddo
do i=1,nFreePoints
ntotsamples=ntotsamples+1
Prioriphotolimit(ntotsamples)=Freeiphotolimit(i)
enddo
call ilimittypestats(ntotsamples,Prioriphotolimit,
&Priorilimittype,Priornumrubis,Priornumrubp,Priornumtpu)
if(bestilimittype.gt.0.and.Priorilimittype.ne.bestilimittype)
&return
!if bestilimittype is specified, we assume the fitting is constained to the limit type specified by bestilimittype
if(Priorilimittype.ge.3)return
!5, 6, 7 are done with Prioriknowlimit=0. We don't consider cases with only rubp and tpu limitations but no rubisco limitations
if(Priornumrubis.gt.0.and.Priornumrubis.lt.minimumrubis)return
if(Priornumrubp.gt.0.and.Priornumrubp.lt.minimumfj)return
if(Priornumtpu.gt.0.and.Priornumtpu.lt.minimumvt)return
do i=1,ntotsamples
Currentiphotolimit(i)=Prioriphotolimit(i)
enddo
endif
Currentilimittype=Priorilimittype
Currentiknowlimit=Prioriknowlimit
!
!-------------Test Area---------------------------------------------
! Currentilimittype=1
! Currentiknowlimit=1
! do i=1,ntotsamples
! if(i.le.6)then
! Currentiphotolimit(i)=1
! else
! if(i.ge.16.and.i.le.26)then
! Currentiphotolimit(i)=2
! else
! Currentiphotolimit(i)=3
! endif
! endif
! enddo
!-------------------------------------------------------------------
call DoUnivPhotoFit()
if(Prioriknowlimit.ne.1.or.Priorilimittype.ge.5)goto 1000
!---------------------------------------------------------
!Enforce the admissibility rule.
!first get the post-fit limit type of each point. (pco2i,anet_obs) should be replaced
!by (pco2i_pred, anet_pred)
do i=1,ntotsamples
call leafunivphotosyn(Currentiknowlimit,Currentilimittype,
&0,aPPFDlf(i),templeaf(i),pco2i_pred(i),po2i(i),chlflphips2(i),
&term,weitresponses(i:i,1:1),weitresponses(i:i,1:1),
&weitresponses(i:i,2:2),weitresponses(i:i,1:1),term1,term2,
&Postiphotolimit(i),term3,term4,term5,term6,term7,term8,term9)
enddo
j=0
do i=1,ntotsamples
if(Postiphotolimit(i).ne.Currentiphotolimit(i))j=j+1
enddo
!if j = 0, the fitting is admissible so go to the wrapup
if(j.eq.0)goto 1000
call ilimittypestats(ntotsamples,Postiphotolimit,
&Postilimittype,Postnumrubis,Postnumrubp,Postnumtpu)
!if minimum number of points is not satisfied, go to penality fit directly.
if(Postnumrubis.gt.0.and.Postnumrubis.lt.minimumrubis)goto 500
if(Postnumrubp.gt.0.and.Postnumrubp.lt.minimumfj)goto 500
if(Postnumtpu.gt.0.and.Postnumtpu.lt.minimumvt)goto 500
!check to see if the fit oscillates.
Currentilimittype=Postilimittype
do i=1,ntotsamples
Currentiphotolimit(i)=Postiphotolimit(i)
enddo
call DoUnivPhotoFit()
do i=1,ntotsamples
call leafunivphotosyn(Currentiknowlimit,Currentilimittype,
&0,aPPFDlf(i),templeaf(i),pco2i_pred(i),po2i(i),chlflphips2(i),
&term,weitresponses(i:i,1:1),weitresponses(i:i,1:1),
&weitresponses(i:i,2:2),weitresponses(i:i,1:1),term1,term2,
&Postiphotolimit(i),term3,term4,term5,term6,term7,term8,term9)
enddo
j=0
do i=1,ntotsamples
if(Postiphotolimit(i).ne.Prioriphotolimit(i))j=j+1
enddo
if(j.eq.0)then
!Osicillation. Treat osicillating points as co-limited
k=ntotsamples
do i=1,ntotsamples
if(Currentiphotolimit(i).ne.Prioriphotolimit(i))then
k=k+1
Currentiphotolimit(k)=Currentiphotolimit(i)
aPPFDlf(k)=aPPFDlf(i)
templeaf(k)=templeaf(i)
po2i(k)=po2i(i)
pco2i(k)=pco2i(i)
anet_obs(k)=anet_obs(i)
chlflphips2(k)=chlflphips2(i)
Currentiphotolimit(i)=Prioriphotolimit(i)
endif
enddo
call ilimittypestats(k,Currentiphotolimit,
&Currentilimittype,Currentnumrubis,Currentnumrubp,Currentnumtpu)
i=ntotsamples
ntotsamples=k
call DoUnivPhotoFit()
sumsquare=sumsquare*dble(i)/dble(k)
ntotsamples=i
goto 1000
else
!no osicillation
Currentilimittype=Priorilimittype
do i=1,ntotsamples
Currentiphotolimit(i)=Prioriphotolimit(i)
enddo
endif
!-------------Penalty function fit-------------------------------------------
500 Currentiknowlimit=2
call DoUnivPhotoFit()
!-------------Wrap up--------------------------------------------------------
1000 if(Prioriknowlimit.eq.0.and.Priorilimittype.le.4)then
call ilimittypestats(ntotsamples,Postiphotolimit,
&Postilimittype,Postnumrubis,Postnumrubp,Postnumtpu)
if(Postnumrubis.gt.0.and.Postnumrubis.lt.minimumrubis-1)
&sumsquare=1.0d+10
if(Postnumrubp.gt.0.and.Postnumrubp.lt.minimumfj-1)
&sumsquare=1.0d+10
if(Postnumtpu.gt.0.and.Postnumtpu.lt.minimumvt-1)
&sumsquare=1.0d+10
endif
term=1.0d0+(subbestsumsquare(Priorilimittype)-sumsquare)
if(term.gt.1.0d0)then
subbestsumsquare(Priorilimittype)=sumsquare
do i=1,ntotunivparams
subbestunivparams(i,Priorilimittype)=univparams(i)
enddo
do i=1,ntotsamples
if(Prioriknowlimit.eq.0)then
subbestiphotolimit(i,Priorilimittype)=Postiphotolimit(i)
else
subbestiphotolimit(i,Priorilimittype)=Prioriphotolimit(i)
endif
enddo
endif
return
end subroutine UnivPhotoFit
!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
subroutine DoUnivPhotoFit()
implicit none
include '../testarea/LeafGasParams.h'
include '../testarea/LeafGasHybridFit.h'
integer i,ndim,k,j,iderivative,iwrong,jnon
double precision beta(20),sumsquare0,beta0(20),sumsquarecp,
&betacp(20),ftol,xtol,shortx(maxobs,4),shorty(maxobs,2),ran2,
&ftol_relax
parameter(ftol=1.0d-7,xtol=1.0d-7)
external funkmin_UnivPhotoFit,f1dim_UnivPhotoFit,
&FCN_UnivPhotoFit,ff_pikaia
!find out which parameters to optimize
call UnivParamsAlloc(1)
ndim=0
do i=1,ntotunivparams
univparams(i)=subbestunivparams(i,Currentilimittype)
if(ifixunivparams(i).eq.1)then
ndim=ndim+1
beta(ndim)=univparams(i)
betamin(ndim)=univparamsmin(i)
betamax(ndim)=univparamsmax(i)
endif
enddo
isitbounded=1
call funkmin_UnivPhotoFit(ndim,beta,sumsquare)
do i=1,ndim
beta0(i)=beta(i)
enddo
sumsquare0=sumsquare
ftol_relax=ftol
k=0
if(subbestsumsquare(Currentilimittype).gt.1.0d+9)then
jnon=0
ftol_relax=ftol*100.0d0
endif
30 call nongradopt(ndim,funkmin_UnivPhotoFit,f1dim_UnivPhotoFit,
&beta,betamin,betamax,ftol_relax,sumsquare)
call funkmin_UnivPhotoFit(ndim,beta,sumsquare)
if((sumsquare+1.0d0).eq.sumsquare.or.sumsquare.gt.sumsquare0)then
do i=1,ndim
beta(i)=beta0(i)
enddo
sumsquare=sumsquare0
else
if((sumsquare0-sumsquare).gt.ftol_relax)then
!reset the counter for arriving at a better minimum
k=0
else
!if the same minimum is found, increment the counter
k=k+1
endif
do i=1,ndim
beta0(i)=beta(i)
enddo
sumsquare0=sumsquare
endif
if(subbestsumsquare(Currentilimittype).gt.1.0d+9)then
jnon=jnon+1
!for the first run, try different initial guesses
if(jnon.lt.100.and.k.lt.5)then
if(ran2().gt.0.7d0)then
do i=1,ndim
beta(i)=betamin(i)+ran2()*(betamax(i)-betamin(i))
enddo
else
do i=1,ndim
if(ran2().gt.0.5d0)then
beta(i)=beta(i)+(ran2()**(3.0d0/dble(k+1)))*
&(betamax(i)-beta(i))
else
beta(i)=beta(i)-(ran2()**(3.0d0/dble(k+1)))*
&(beta(i)-betamin(i))
endif
enddo
endif
call funkmin_UnivPhotoFit(ndim,beta,sumsquare)
goto 30
else
if((ftol_relax-ftol).gt.ftol)then
ftol_relax=ftol
goto 30
endif
endif
call RepeatCompassSearch(ndim,beta,sumsquare,betamin,
&betamax,funkmin_UnivPhotoFit,f1dim_UnivPhotoFit,xtol)
call funkmin_UnivPhotoFit(ndim,beta,sumsquare)
if((sumsquare+1.0d0).eq.sumsquare.or.sumsquare.gt.sumsquare0)
&then
do i=1,ndim
beta(i)=beta0(i)
enddo
sumsquare=sumsquare0
endif
do i=1,ndim
betacp(i)=(beta(i)-betamin(i))/(betamax(i)-betamin(i))
enddo
sumsquarecp=sumsquare
isitbounded=0
call pikaia(ff_pikaia,ndim,gacontrol,betacp,sumsquarecp,i)
isitbounded=1
if(i.eq.0)then
do i=1,ndim
betacp(i)=betamin(i)+betacp(i)*(betamax(i)-betamin(i))
enddo
call funkmin_UnivPhotoFit(ndim,betacp,sumsquarecp)
else
do i=1,ndim
betacp(i)=beta(i)
enddo
sumsquarecp=sumsquare
endif
if((sumsquarecp+1.0d0).ne.sumsquarecp.and.
&sumsquare.gt.sumsquarecp)then
do i=1,ndim
beta(i)=betacp(i)
enddo
sumsquare=sumsquarecp
endif
do i=1,ndim
beta0(i)=beta(i)
enddo
sumsquare0=sumsquare
else
return
endif
iderivative=0
if(ifitmode.lt.0)then
iwrong=0
else
iwrong=1
endif
isitbounded=1
k=ifitmode
ifitmode=-1
!ifitmode: =-2, ordinary fitting with pco2i calculated as a function of anet
!ifitmode: =-1, ordinary fitting with anet calculated as a function of pco2i
!ifitmode: =1, orthogonal fitting with anet calculated as a function of pco2i
!ifitmode: =2, orthogonal fitting with pco2i calculated as a function of anet
!for odr_leastsquare, only the predicted value of the response variable is needed, i.e., the cost function value is not needed.
!also, only anet as a function of CO2i is considered (not the other way around) because odr_leastsquare cannot handle the situation
!co2i as a function of anet for tpu limitation when alpha=0
i=1
if(ntotphips2.ge.1)i=2
j=4
if(Currentiknowlimit.eq.-1)then
!fluorescence only fit. chlflphisi2 becomes a forcing variable
i=1
j=5
endif
call odr_leastsquare(ndim,FCN_UnivPhotoFit,beta,ntotsamples,
&forcings(1:ntotsamples,1:j),j,responses(1:ntotsamples,1:i),i,
&weitforcings(1:ntotsamples,1:j),weitresponses(1:ntotsamples,1:i),
&iderivative,shortx(1:ntotsamples,1:j),shorty(1:ntotsamples,1:i),
&sumsquare,iwrong)
isitbounded=1
ifitmode=k
!after odr_leastsquare, forcing variables are destroyed. restore to the origninals
do i=1,ntotsamples
pco2i(i)=pco2i_ori(i)
aPPFDlf(i)=aPPFDlf_ori(i)
templeaf(i)=templeaf_ori(i)
po2i(i)=po2i_ori(i)
chlflphips2(i)=chlflphips2_ori(i)
enddo
call funkmin_UnivPhotoFit(ndim,beta,sumsquare)
if((sumsquare+1.0d0).eq.sumsquare.or.sumsquare.gt.sumsquare0)then
do i=1,ndim
beta(i)=beta0(i)
enddo
sumsquare=sumsquare0
endif
k=0
do i=1,ndim
if(beta(i).lt.betamin(i))k=1
if(beta(i).gt.betamax(i))k=1
enddo
if(k.eq.1)then
do i=1,ndim
betacp(i)=(beta(i)-betamin(i))/(betamax(i)-betamin(i))
enddo
isitbounded=0
call pikaia(ff_pikaia,ndim,gacontrol,betacp,sumsquare,i)
do i=1,ndim
beta(i)=betamin(i)+betacp(i)*(betamax(i)-betamin(i))
enddo
isitbounded=1
call funkmin_UnivPhotoFit(ndim,beta,sumsquare)
endif
j=0
100 jnon=0
105 sumsquare0=sumsquare
do i=1,ndim
beta0(i)=beta(i)
enddo
call nongradopt(ndim,funkmin_UnivPhotoFit,f1dim_UnivPhotoFit,
&beta,betamin,betamax,ftol,sumsquare)
call funkmin_UnivPhotoFit(ndim,beta,sumsquare)
if(jnon.le.2.and.(sumsquare0-sumsquare).gt.ftol)then
jnon=jnon+1
goto 105
endif
if(sumsquare.eq.sumsquare0)goto 110
if(dabs(sumsquare).le.dabs(sumsquare0))then
else
if(dabs(sumsquare).gt.1.0d+20)then
!in case of infinity (division by zero)
do i=1,ndim
beta(i)=beta0(i)
enddo
sumsquare=sumsquare0
else
!designed this way to avoid sumsquare='NAN'
do i=1,ndim
beta(i)=beta0(i)
enddo
sumsquare=sumsquare0
endif
endif
sumsquarecp=sumsquare
do i=1,ndim
betacp(i)=beta(i)
enddo
call RepeatCompassSearch(ndim,betacp,sumsquarecp,betamin,
&betamax,funkmin_UnivPhotoFit,f1dim_UnivPhotoFit,xtol)
call funkmin_UnivPhotoFit(ndim,betacp,sumsquarecp)
if(sumsquare.eq.sumsquarecp)goto 110
if(dabs(sumsquarecp).lt.dabs(sumsquare))then
do i=1,ndim
beta(i)=betacp(i)
enddo
sumsquare=sumsquarecp
endif
j=j+1
if(j.le.2.and.dabs(sumsquare-sumsquare0).gt.ftol)goto 100
!
!------------------------------------------------------
110 call funkmin_UnivPhotoFit(ndim,beta,sumsquare)
return
END subroutine DoUnivPhotoFit
leafres/testarea/cica.h
+7
View File
@@ -0,0 +1,7 @@
double precision bmin(10),bmax(10),cicameas(1000),
& pco2ambient(1000)
common /cicadble/bmin,bmax,cicameas,
& pco2ambient
integer nobs,imodel
common /cicaint/nobs,imodel
leafres/testarea/cica5.f
+138
View File
@@ -0,0 +1,138 @@
!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
subroutine cicaoptimization5(npoints,cicameas0,
&pco2ambient0,beta,ndim,imodel0,bmin0,bmax0)
implicit none
include '../testarea/cica.h'
c
integer npoints
double precision pco2ambient0(npoints),cicameas0(npoints),
& acica,bcica,ccica,dcica,ecica
integer i,ndim,imodel0
double precision beta(ndim),fatbeta,ftol,bmin0(ndim),
& bmax0(ndim)
parameter(ftol=1.0d-7)
external funkmin_cica,f1dim_cica
nobs = npoints
imodel=imodel0
do i=1,npoints
pco2ambient(i)=pco2ambient0(i)
cicameas(i)=cicameas0(i)
enddo
do i=1,ndim
bmin(i)=bmin0(i)
bmax(i)=bmax0(i)
enddo
!
! Initialize the cost function evaluation counter in the subroutine funkmin.
! The counter counts and memorizes points where the cost function is evaluated.
call funkmin_cica(ndim,beta,fatbeta)
call nongradopt(ndim,funkmin_cica,f1dim_cica,beta,
& bmin,bmax,ftol,fatbeta)
if(imodel.eq.3)then
call RepeatCompassSearch(ndim,beta,fatbeta,bmin,
&bmax,funkmin_cica,f1dim_cica,ftol)
else
call nongradopt(ndim,funkmin_cica,f1dim_cica,beta,
&bmin,bmax,ftol,fatbeta)
endif
return
END
c
!$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
subroutine cica_ca5(imodel,ndim,beta,ambco2_in_Pa,cica,der_cica,
&der_beta)
implicit none
integer imodel,ndim
! calculate Ci/Ca ratio for a given ambient CO2 partial pressure in Pa.
!
!Ci/Ca=a*exp(-b*Ca)+c/(1+exp(-(Ca-d)/e))
!
double precision a,b,c,d,e,f,ambco2_in_Pa,cica,der_cica,
&term1,term2,term0,crit,grad(10),twoexpfunc,beta(ndim),
&der_beta(ndim)
parameter(crit=300.0d0)
a=beta(1)
b=beta(2)
c=beta(3)
d=beta(4)
e=beta(5)
f=beta(ndim)
if(ndim.le.5)f=0.0d0
if(imodel.eq.1)then
! cica=twoexpfunc(y0,a1,b1,c1,x01,
! & a2,b2,c2,x02,x)
cica=twoexpfunc(e,a,b,1.d0,0.0d0,
& c,d,1.0d0,0.0d0,ambco2_in_Pa)
! call gradtwoexp(y0,a1,b1,c1,x01,
! & a2,b2,c2,x02,x,grad)
call gradtwoexp(e,a,b,1.d0,0.0d0,
& c,d,1.0d0,0.0d0,ambco2_in_Pa,grad)
! a1<->grad(1)<->a
! b1<->grad(2)<->b
! c1<->grad(3)
! x01<->grad(4)
! y0<->grad(5)<->e
! x<->grad(6)
! a2<->grad(7)
! b2<->grad(8)
! c2<->grad(9)
! x02<->grad(10)
der_cica=grad(6)
der_beta(5)=grad(5)
der_beta(1)=grad(1)
der_beta(2)=grad(2)
der_beta(3)=grad(7)
der_beta(4)=grad(8)
return
endif
if(imodel.eq.2)then
term0=-(ambco2_in_Pa-d)/e
term1=dexp(-b*ambco2_in_Pa)
if(term0.lt.crit)then
term2=dexp(term0)
cica=a*term1+c/(1.0d0+term2)
der_cica=-a*b*term1+(c*term2)/(e*(1.0d0+term2)**2)
der_beta(1)=term1
der_beta(2)=-a*ambco2_in_Pa*term1
der_beta(3)=1.0d0/(1.0d0+term2)
der_beta(4)=-c*term2/(e*(1.0d0+term2)**2)
der_beta(5)=c*term2*(-ambco2_in_Pa+d)/((e*(1.0d0+term2))**2)
else
term2=dexp(-term0)
cica=a*term1+c*term2/(1.0d0+term2)
der_cica=-a*b*term1+(c*term2)/(e*(1.0d0+term2)**2)
der_beta(1)=term1
der_beta(2)=-a*ambco2_in_Pa*term1
der_beta(3)=term2/(1.0d0+term2)
der_beta(4)=-c*term2/(e*(1.0d0+term2)**2)
der_beta(5)=c*term2*(-ambco2_in_Pa+d)/((e*(1.0d0+term2))**2)
endif
if(ndim.eq.6)then
cica=cica+beta(ndim)
der_beta(ndim)=1.0d0
endif
endif
if(imodel.eq.3)then
term1=dexp(-b*ambco2_in_Pa)
cica=a*term1+c+d*dlog(ambco2_in_Pa)+e*dlog(ambco2_in_Pa)*
&dlog(ambco2_in_Pa)+f*dlog(ambco2_in_Pa)*dlog(ambco2_in_Pa)*
&dlog(ambco2_in_Pa)
der_cica=-a*b*term1+d/ambco2_in_Pa+2.0d0*e*dlog(ambco2_in_Pa)/
&ambco2_in_Pa+3.0d0*f*dlog(ambco2_in_Pa)*dlog(ambco2_in_Pa)/
&ambco2_in_Pa
der_beta(1)=term1
der_beta(2)=-a*ambco2_in_Pa*term1
der_beta(3)=1.0d0
der_beta(4)=dlog(ambco2_in_Pa)
der_beta(5)=dlog(ambco2_in_Pa)*dlog(ambco2_in_Pa)
if(ndim.eq.6)der_beta(ndim)=dlog(ambco2_in_Pa)*
&dlog(ambco2_in_Pa)*dlog(ambco2_in_Pa)
endif
return
end
leafres/testarea/cica_Regression5.f
+230
View File
@@ -0,0 +1,230 @@
!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
!
subroutine cica_Regression5(N,cicameas0,pco2ambient0,BETA,NP,
&imodel0,bmin0,bmax0)
implicit none
include '../testarea/cica.h'
c
C ODRPACK ARGUMENT DEFINITIONS
C ==> FCN NAME OF THE USER SUPPLIED FUNCTION SUBROUTINE
C ==> N NUMBER OF OBSERVATIONS
C ==> M COLUMNS OF DATA IN THE EXPLANATORY VARIABLE
C ==> NP NUMBER OF PARAMETERS
C ==> NQ NUMBER OF RESPONSES PER OBSERVATION
C <==> BETA FUNCTION PARAMETERS
C ==> Y RESPONSE VARIABLE
C ==> LDY LEADING DIMENSION OF ARRAY Y
C ==> X EXPLANATORY VARIABLE
C ==> LDX LEADING DIMENSION OF ARRAY X
C ==> WE "EPSILON" WEIGHTS
C ==> LDWE LEADING DIMENSION OF ARRAY WE
C ==> LD2WE SECOND DIMENSION OF ARRAY WE
C ==> WD "DELTA" WEIGHTS
C ==> LDWD LEADING DIMENSION OF ARRAY WD
C ==> LD2WD SECOND DIMENSION OF ARRAY WD
C ==> IFIXB INDICATORS FOR "FIXING" PARAMETERS (BETA)
C ==> IFIXX INDICATORS FOR "FIXING" EXPLANATORY VARIABLE (X)
C ==> LDIFX LEADING DIMENSION OF ARRAY IFIXX
C ==> JOB TASK TO BE PERFORMED
C ==> NDIGIT GOOD DIGITS IN SUBROUTINE FUNCTION RESULTS
C ==> TAUFAC TRUST REGION INITIALIZATION FACTOR
C ==> SSTOL SUM OF SQUARES CONVERGENCE CRITERION
C ==> PARTOL PARAMETER CONVERGENCE CRITERION
C ==> MAXIT MAXIMUM NUMBER OF ITERATIONS
C ==> IPRINT PRINT CONTROL
C ==> LUNERR LOGICAL UNIT FOR ERROR REPORTS
C ==> LUNRPT LOGICAL UNIT FOR COMPUTATION REPORTS
C ==> STPB STEP SIZES FOR FINITE DIFFERENCE DERIVATIVES WRT BETA
C ==> STPD STEP SIZES FOR FINITE DIFFERENCE DERIVATIVES WRT DELTA
C ==> LDSTPD LEADING DIMENSION OF ARRAY STPD
C ==> SCLB SCALE VALUES FOR PARAMETERS BETA
C ==> SCLD SCALE VALUES FOR ERRORS DELTA IN EXPLANATORY VARIABLE
C ==> LDSCLD LEADING DIMENSION OF ARRAY SCLD
C <==> WORK DOUBLE PRECISION WORK VECTOR
C ==> LWORK DIMENSION OF VECTOR WORK
C <== IWORK INTEGER WORK VECTOR
C ==> LIWORK DIMENSION OF VECTOR IWORK
C <== INFO STOPPING CONDITION
C PARAMETERS SPECIFYING MAXIMUM PROBLEM SIZES HANDLED BY THIS DRIVER
C MAXN MAXIMUM NUMBER OF OBSERVATIONS
C MAXM MAXIMUM NUMBER OF COLUMNS IN EXPLANATORY VARIABLE
C MAXNP MAXIMUM NUMBER OF FUNCTION PARAMETERS
C MAXNQ MAXIMUM NUMBER OF RESPONSES PER OBSERVATION
C PARAMETER DECLARATIONS AND SPECIFICATIONS
INTEGER LDIFX,LDSCLD,LDSTPD,LDWD,LDWE,LDX,LDY,LD2WD,LD2WE,
+ LIWORK,LWORK,MAXM,MAXN,MAXNP,MAXNQ
PARAMETER (MAXM=25,MAXN=10000,MAXNP=30,MAXNQ=1,
+ LDY=MAXN,LDX=MAXN,
+ LDWE=1,LD2WE=1,LDWD=1,LD2WD=1,
+ LDIFX=MAXN,LDSTPD=1,LDSCLD=1,
+ LWORK=18 + 11*MAXNP + MAXNP**2 + MAXM + MAXM**2 +
+ 4*MAXN*MAXNQ + 6*MAXN*MAXM + 2*MAXN*MAXNQ*MAXNP +
+ 2*MAXN*MAXNQ*MAXM + MAXNQ**2 +
+ 5*MAXNQ + MAXNQ*(MAXNP+MAXM) + LDWE*LD2WE*MAXNQ,
+ LIWORK=20+MAXNP+MAXNQ*(MAXNP+MAXM))
C VARIABLE DECLARATIONS
INTEGER I,INFO,IPRINT,J,JOB,L,LUNERR,LUNRPT,M,MAXIT,N,
+ NDIGIT,NP,NQ
INTEGER IFIXB(MAXNP),IFIXX(LDIFX,MAXM),IWORK(LIWORK)
DOUBLE PRECISION PARTOL,SSTOL,TAUFAC
DOUBLE PRECISION BETA(MAXNP),SCLB(MAXNP),SCLD(LDSCLD,MAXM),
+ STPB(MAXNP),STPD(LDSTPD,MAXM),
+ WD(LDWD,LD2WD,MAXM),WE(LDWE,LD2WE,MAXNQ),
+ WORK(LWORK),X(LDX,MAXM),Y(LDY,MAXNQ)
c
integer i1,i2,i3,i4,i5,imodel0
double precision cicameas0(N),pco2ambient0(N),
&bmin0(NP),bmax0(NP)
EXTERNAL CICAFCN5
c
C SPECIFY DEFAULT VALUES FOR DODRC ARGUMENTS
WE(1,1,1) = -1.0D0
WD(1,1,1) = -1.0D0
IFIXB(1) = -1
! IFIXX(1,1) = -1
! JOB = 00023
JOB=23
NDIGIT = -1
TAUFAC = -1.0D0
SSTOL = -1.0D0
PARTOL = -1.0D0
MAXIT = -1
! IPRINT = -1
IPRINT=0
LUNERR = -1
LUNRPT = -1
STPB(1) = -1.0D0
STPD(1,1) = -1.0D0
SCLB(1) = -1.0D0
SCLD(1,1) = -1.0D0
MAXIT = 200000
C SET UP ODRPACK REPORT FILES
LUNERR = 9
LUNRPT = 9
c
imodel=imodel0
nobs=N
do I=1,NP
bmin(I)=bmin0(I)
bmax(I)=bmax0(I)
enddo
do I=1,N
pco2ambient(I)=pco2ambient0(I)
cicameas(I)=cicameas0(I)
X(I,1)=pco2ambient(I)
Y(I,1)=cicameas(I)
enddo
M=1
NQ=1
C READ PROBLEM DATA, AND SET NONDEFAULT VALUE FOR ARGUMENT IFIXX
DO 10 I=1,N
DO 15 J=1, M
IFIXX(I,J) = 1
15 CONTINUE
10 CONTINUE
60 CALL DODRC(CICAFCN5,
+ N,M,NP,NQ,
+ BETA,
+ Y,LDY,X,LDX,
+ WE,LDWE,LD2WE,WD,LDWD,LD2WD,
+ IFIXB,IFIXX,LDIFX,
+ JOB,NDIGIT,TAUFAC,
+ SSTOL,PARTOL,MAXIT,
+ IPRINT,LUNERR,LUNRPT,
+ STPB,STPD,LDSTPD,
+ SCLB,SCLD,LDSCLD,
+ WORK,LWORK,IWORK,LIWORK,
+ INFO)
i1=mod(INFO,10)
i2=(mod(INFO,100)-i1)/10
i3=(mod(INFO,1000)-mod(INFO,100))/100
i4=(mod(INFO,10000)-mod(INFO,1000))/1000
i5=(INFO-mod(INFO,10000))/10000
return
END
SUBROUTINE CICAFCN5(N,M,NP,NQ,
+ LDN,LDM,LDNP,
+ BETA,XPLUSD,
+ IFIXB,IFIXX,LDIFX,
+ IDEVAL,F,FJACB,FJACD,
+ ISTOP)
implicit none
include '../src/cica.h'
C SUBROUTINE ARGUMENTS
C ==> N NUMBER OF OBSERVATIONS
C ==> M NUMBER OF COLUMNS IN EXPLANATORY VARIABLE
C ==> NP NUMBER OF PARAMETERS
C ==> NQ NUMBER OF RESPONSES PER OBSERVATION
C ==> LDN LEADING DIMENSION DECLARATOR EQUAL OR EXCEEDING N
C ==> LDM LEADING DIMENSION DECLARATOR EQUAL OR EXCEEDING M
C ==> LDNP LEADING DIMENSION DECLARATOR EQUAL OR EXCEEDING NP
C ==> BETA CURRENT VALUES OF PARAMETERS
C ==> XPLUSD CURRENT VALUE OF EXPLANATORY VARIABLE, I.E., X + DELTA
C ==> IFIXB INDICATORS FOR "FIXING" PARAMETERS (BETA)
C ==> IFIXX INDICATORS FOR "FIXING" EXPLANATORY VARIABLE (X)
C ==> LDIFX LEADING DIMENSION OF ARRAY IFIXX
C ==> IDEVAL INDICATOR FOR SELECTING COMPUTATION TO BE PERFORMED
C <== F PREDICTED FUNCTION VALUES
C <== FJACB JACOBIAN WITH RESPECT TO BETA
C <== FJACD JACOBIAN WITH RESPECT TO ERRORS DELTA
C <== ISTOP STOPPING CONDITION, WHERE
C 0 MEANS CURRENT BETA AND X+DELTA WERE
C ACCEPTABLE AND VALUES WERE COMPUTED SUCCESSFULLY
C 1 MEANS CURRENT BETA AND X+DELTA ARE
C NOT ACCEPTABLE; ODRPACK SHOULD SELECT VALUES
C CLOSER TO MOST RECENTLY USED VALUES IF POSSIBLE
C -1 MEANS CURRENT BETA AND X+DELTA ARE
C NOT ACCEPTABLE; ODRPACK SHOULD STOP
C INPUT ARGUMENTS, NOT TO BE CHANGED BY THIS ROUTINE:
INTEGER I,IDEVAL,ISTOP,L,LDIFX,LDM,LDN,LDNP,M,N,NP,NQ
DOUBLE PRECISION BETA(NP),XPLUSD(LDN,M)
INTEGER IFIXB(NP),IFIXX(LDIFX,M),k
C OUTPUT ARGUMENTS:
DOUBLE PRECISION F(LDN,NQ),FJACB(LDN,LDNP,NQ),FJACD(LDN,LDM,NQ)
double precision pco2a,cica,der_cica,der_BETA(NP)
C CHECK FOR UNACCEPTABLE VALUES FOR THIS PROBLEM
c
do I=1,NP
if(BETA(I).lt.bmin(I).or.BETA(I).gt.bmax(I))then
ISTOP = 1
RETURN
endif
enddo
!
IF (MOD(IDEVAL,10).GE.1) THEN
DO 110 L = 1,NQ
DO 100 I = 1,N
pco2a=XPLUSD(I,1)
call cica_ca5(imodel,NP,BETA,pco2a,cica,der_cica,der_BETA)
F(I,L)=cica
100 CONTINUE
110 CONTINUE
END IF
C COMPUTE DERIVATIVES WITH RESPECT TO BETA
IF (MOD(IDEVAL/10,10).GE.1) THEN
DO 210 L = 1,NQ
DO 200 I = 1,N
pco2a=XPLUSD(I,1)
call cica_ca5(imodel,NP,BETA,pco2a,cica,der_cica,der_BETA)
do k=1,NP
FJACB(I,k,L)=der_BETA(k)
enddo
200 CONTINUE
210 CONTINUE
END IF
RETURN
END
!
!$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
leafres/testarea/commonparameters.f
+205
View File
@@ -0,0 +1,205 @@
!This subroutine initializes the parameters to be optimized as well as those to be used and not changed
!
subroutine commonparameters(stargamma25,fkc25,fko25,alpha25,
&ha_vcmax,hd_vcmax,sv_vcmax,ha_jmax,hd_jmax,sv_jmax,ha_tpu,
&hd_tpu,sv_tpu,ha_gmeso,hd_gmeso,sv_gmeso,ha_darkresp,ha_stargamma,
&ha_kc,ha_ko,abspt_lf_par,gascon,phifactor,thetafactor,betaPSII)
implicit none
!-------Secondary parameters in A/Ci curve analysis----------------------
! stargamma25: the chloroplastic CO2 compensation point at 25oC
! fkc25: the Michaelis constant for CO2 at 25oC when gmeso is not include [Pa]
! fko25: the Michaelis constant for O2 at 25oC when gmeso is not include [Pa]
! alpha25: The fraction of glycolate carbon not returned to the chloroplat [0-1]
double precision stargamma25,fkc25,fko25,alpha25
!-------Parameters that define temperature responses---------------------
! ha_vcmax: The activation energy (Ha) in Vcmax temperature response function [kJmol-1]
! hd_vcmax: The deactivation energy (Hd) in Vcmax temperature response function [kJmol-1]
! sv_vcmax: The entropy term (Sv) in Vcmax temperature response function [kJmol-1K-1]
! ha_jmax: The activation energy (Ha) in jmax temperature response function [kJmol-1]
! hd_jmax: The deactivation energy (Hd) in jmax temperature response function [kJmol-1]
! sv_jmax: The entropy term (Sv) in jmax temperature response function [kJmol-1K-1]
! ha_tpu: The activation energy (Ha) in tpu temperature response function [kJmol-1]
! hd_tpu: The deactivation energy (Hd) in tpu temperature response function [kJmol-1]
! sv_tpu: The entropy term (Sv) in tpu temperature response function [kJmol-1K-1]
! ha_gmeso: The activation energy (Ha) in gmeso temperature response function [kJmol-1]
! hd_gmeso: The deactivation energy (Hd) in gmeso temperature response function [kJmol-1]
! sv_gmeso: The entropy term (Sv) in gmeso temperature response function [kJmol-1K-1]
!
! ha_darkresp: parameter in the temperature response function of dark respiration [kJmol-1]
! ha_stargamma: parameter in the temperature response function of the co2 compensation point [kJmol-1]
! ha_kc: a CO2 Michaelis temp coefficient [kJmol-1]
! ha_ko: a O2 Michaelis temp coefficient [kJmol-1]
! gascon: Universal gas constant J K-1 mol-1
! phifactor: modifies Bernacchi phiPSIImax
! thetafactor: modifies Bernacchi thetaPSII
! betaPSII: the fraction of absorbed light that reaches photosystem II (0.5)
double precision ha_vcmax,hd_vcmax,sv_vcmax,ha_jmax,
&hd_jmax,sv_jmax,ha_tpu,hd_tpu,sv_tpu,ha_gmeso,hd_gmeso,sv_gmeso,
&ha_darkresp,ha_stargamma,ha_kc,ha_ko,phifactor,thetafactor,
&betaPSII
!--------------Other parameters-------------------------------------------
! abspt_lf_par: leaf absorptance in PAR
double precision abspt_lf_par,gascon
gascon=8.314472d0
!
!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
!Parameters below this line will be used as inputs if not optimized from curve fitting
!but as initial values if optimized. So they are not arbitrary values and should not be
!changed unless there is a good reason.
!
!-------Secondary parameters---------------------------
!Considered universal but uncertain, also depend on whether mesophyll conductance is involked
!The subscript 1 is for fitting without mesophyll conductance; 2 is for fitting with mesophyll conductance
!Bernacchi et al. (2003) values
! stargamma25=4.3d0
! stargamma25=4.3d0
! fkc25=41.0d0
! fkc25=41.0d0
! fko25=27710.0d0
! fko25=27710.0d0
!
!S. von Caemmerer (2000) values
! stargamma25=3.7d0
! stargamma25=3.86d0
! fkc25=40.4d0
! fkc25=26.0d0
! fko25=24800.0d0
! fko25=17900.0d0
!Values used in Sharkey et al. (2007)
stargamma25=3.743d0
fkc25=27.238d0
fko25=16582.0d0
!Jordan and Ogren (1984) values
! stargamma25=4.5146d0
! stargamma25=4.5146d0
! fkc25=27.422d0
! fkc25=27.422d0
! fko25=41829.0d0
! fko25=41829.0d0
alpha25=0.0d0
!most models have alpha=0
!-----------------------------------------------------
!Parameters in the generic Vcmax temperature response function.
!Leuning, Harley and Bernacchi can all be expressed in the same generic form
!Bernacchi et al. (2003) function
! ha_vcmax=65.33d0
! hd_vcmax=0.0d0
! sv_vcmax=0.0d0
!S. von Caemmerer (2000) values
! ha_vcmax=58.52d0
! hd_vcmax=0.0d0
! sv_vcmax=0.0d0
!Leuning (2002) function
! ha_vcmax=73.637d0
! hd_vcmax=149.252d0
! sv_vcmax=0.486d0
!Harley et al. (1992) function
! ha_vcmax=116.3d0
! hd_vcmax=202.9d0
! sv_vcmax=0.65d0
!Values used in Sharkey et al. (2007)
ha_vcmax=65.33d0
hd_vcmax=0.0d0
sv_vcmax=0.0d0
!
!-------------------------------------------------------
!Parameters in Jmax temperature response functions. All in unit of kJmol-1
!Leuning, Harley and Bernacchi can all be expressed in the same generic form
!Bernacchi et al. (2003) function
! ha_jmax=43.54d0
! hd_jmax=0.0d0
! sv_jmax=0.0d0
!S. von Caemmerer (2000) values
! ha_jmax=37.0d0
! hd_jmax=0.0d0
! sv_jmax=0.0d0
!Leuning function
! ha_jmax=50.3d0
! hd_jmax=152.044d0
! sv_jmax=0.495d0
!Harley functions
! ha_jmax=79.5d0
! hd_jmax=201.0d0
! sv_jmax=0.65d0
!values used in Sharkey et al. (2007)
ha_jmax=43.54d0
hd_jmax=0.0d0
sv_jmax=0.0d0
!June et al. function. The June et al function cannot be expressed in the generic form. Need to go to the
!Jmax temperature response function subroutine to change the form if this function is used
! ha_jmax=30.0d0+273.15d0
! hd_jmax=11.6d0
! sv_jmax=0.18d0
!---------------------------------------------------------
!Parameters in TPU temperature response function in kJmol-1
!Harley function
ha_tpu=53.1d0
hd_tpu=201.8d0
sv_tpu=0.65d0
!Parameters in gmeso temperature response function
!Values from the functions in Bernacchi, et al. (2002), Plant Physiology, 130, 1992-1998.
ha_gmeso=49.6d0
hd_gmeso=437.4d0
sv_gmeso=1.4d0
!Values from the function in Scafaro et al. (2011), PCE 34: 1999-2008
! ha_gmeso=(45.22d0+29.17d0+48.26d0)/3.0d0
! hd_gmeso=-9999.0d0
! sv_gmeso=-9999.0d0
!---------------------------------------------------------
!Parameters in the temperature response function for leaf mitochondrial (dark) respiration (kJmol-1)
!Parameters in the temp function for the choloraplastic CO2 compensation point (kJmol-1)
!Parameters in the temp function of Kc
!Parameters in the temp function of Ko
!Bernacchi et al. (2003) parameters
! ha_darkresp=46.39d0
! ha_stargamma=37.83d0
! ha_kc=79.43d0
! ha_ko=36.38d0
!S. von Caemmerer (2000) values
! ha_darkresp=66.4d0
! ha_stargamma=23.4d0
! ha_kc=59.36d0
! ha_ko=35.94d0
!Jordan and Ogren (1984) parameters
! ha_darkresp=66.4d0
! ha_stargamma=29.213d0
! ha_kc=70.372d0
! ha_ko=14.351d0
!Values used in Sharkey et al. (2007)
ha_darkresp=46.39d0
ha_stargamma=24.46d0
ha_kc=80.99d0
ha_ko=23.72d0
!----------------------------------------------------------
!Leaf absorptance parameter in PAR
abspt_lf_par=0.85d0
!
!!3/29/2014. Bernacchi method cannot fit A/PAR curves well. phifactor and thetafactor are
!estimated and used to modify his method when A/PAR curves are present.
! phifactor: modifies Bernacchi phiPSIImax
! thetafactor: modifies Bernacchi thetaPSII
phifactor=1.0d0
thetafactor=1.0d0
betaPSII=0.5d0
return
end
leafres/testarea/fluorescencejmax.f
+209
View File
@@ -0,0 +1,209 @@
!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
subroutine fluorescencejmax()
implicit none
include '../testarea/LeafGasParams.h'
include '../testarea/LeafGasHybridFit.h'
integer i,ndim,k,j,iderivative,iwrong
double precision beta(4),sumsquare0,beta0(4),sumsquarecp,
&betacp(4),ftol,xtol,shortx(maxobs,2),shorty(maxobs),
&xvar(maxobs,2),weitx(maxobs,2),weity(maxobs),ran2,
&templflights0(maxobs),aparlights0(maxobs),termmin,termmax
parameter(ftol=1.0d-7,xtol=1.0d-7)
external funkmin_flujmax,f1dim_flujmax,FCN_flujmax,flujmax_pikaia
!beta(1)=fjmax25
beta(1)=univparams(8)
betamin(1)=univparamsmin(8)
betamax(1)=univparamsmax(8)
!beta(2)=phifactor
beta(2)=univparams(11)
betamin(2)=univparamsmin(11)
betamax(2)=univparamsmax(11)
!beta(3)=thetafactor
beta(3)=univparams(12)
betamin(3)=univparamsmin(12)
betamax(3)=univparamsmax(12)
ndim=3
ntotlights=0
termmax=-1.0d+9
termmin=1.0d+9
do i=1,numALightcurves
do j=1,nALightPoints(i)
if(ALightchlflphips2(j,i).gt.0.0d0.and.
&j.le.nstartalight(i))then
!Only points before nstartalight are used because these points are apparently limited by RuBP regeneration and therefore
!the electron transport equation applies.
ntotlights=ntotlights+1
templflights(ntotlights)=ALighttempleaf(j,i)
if(templflights(ntotlights).lt.termmin)
&termmin=templflights(ntotlights)
if(templflights(ntotlights).gt.termmax)
&termmax=templflights(ntotlights)
aparlights(ntotlights)=ALightaPPFDlf(j,i)
flphips2lights(ntotlights)=ALightchlflphips2(j,i)
xvar(ntotlights,1)=aparlights(ntotlights)
xvar(ntotlights,2)=templflights(ntotlights)
weitx(ntotlights,1)=1.0d0
weitx(ntotlights,2)=1.0d0
weity(ntotlights)=1.0d0
templflights0(ntotlights)=templflights(ntotlights)
aparlights0(ntotlights)=aparlights(ntotlights)
endif
enddo
enddo
if((termmax-termmin).gt.2.0d0)then
ndim=4
!beta(4)=ha_jmax
beta(4)=univparams(17)
betamin(4)=univparamsmin(17)
betamax(4)=univparamsmax(17)
endif
if(ntotlights.lt.ndim)then
ntotlights=0
return
endif
isitbounded=1
call funkmin_flujmax(ndim,beta,flujmaxfval)
do i=1,ndim
beta0(i)=beta(i)
enddo
sumsquare0=flujmaxfval
j=0
k=0
30 call nongradopt(ndim,funkmin_flujmax,
&f1dim_flujmax,beta,betamin,betamax,ftol,flujmaxfval)
call funkmin_flujmax(ndim,beta,flujmaxfval)
if((flujmaxfval+1.0d0).eq.flujmaxfval)then
do i=1,ndim
beta(i)=beta0(i)
enddo
flujmaxfval=sumsquare0
else
if(dabs(flujmaxfval-sumsquare0).lt.ftol)k=k+1
if(flujmaxfval.gt.sumsquare0)then
do i=1,ndim
beta(i)=beta0(i)
enddo
flujmaxfval=sumsquare0
else
if((sumsquare0-flujmaxfval).gt.ftol)k=0
!reset the counter of revisiting a minimum if a new minimum is found
endif
endif
j=j+1
!try different initial guesses
if(j.lt.200.and.k.lt.50)then
do i=1,ndim
beta0(i)=beta(i)
beta(i)=betamin(i)+ran2()*(betamax(i)-betamin(i))
enddo
sumsquare0=flujmaxfval
call funkmin_flujmax(ndim,beta,flujmaxfval)
goto 30
endif
call RepeatCompassSearch(ndim,beta,flujmaxfval,betamin,
&betamax,funkmin_flujmax,f1dim_flujmax,xtol)
do i=1,ndim
betacp(i)=(beta(i)-betamin(i))/(betamax(i)-betamin(i))
enddo
isitbounded=0
call pikaia(flujmax_pikaia,ndim,gacontrol,betacp,flujmaxfval,i)
do i=1,ndim
beta(i)=betamin(i)+betacp(i)*(betamax(i)-betamin(i))
enddo
isitbounded=1
call funkmin_flujmax(ndim,beta,flujmaxfval)
call RepeatCompassSearch(ndim,beta,flujmaxfval,betamin,
&betamax,funkmin_flujmax,f1dim_flujmax,xtol)
isitbounded=1
call funkmin_flujmax(ndim,beta,flujmaxfval)
do i=1,ndim
beta0(i)=beta(i)
enddo
sumsquare0=flujmaxfval
iderivative=0
iwrong=0
call odr_leastsquare(ndim,FCN_flujmax,beta,ntotlights,
&xvar(1:ntotlights,1:2),2,flphips2lights,1,weitx(1:ntotlights,1:2),
&weity,iderivative,shortx(1:ntotlights,1:2),shorty(1:ntotlights),
&flujmaxfval,iwrong)
isitbounded=1
!after odr_leastsquare, forcing variables are destroyed. restore to the origninals
do i=1,ntotlights
templflights(i)=templflights0(i)
aparlights(i)=aparlights0(i)
enddo
call funkmin_flujmax(ndim,beta,flujmaxfval)
if(dabs(flujmaxfval).le.dabs(sumsquare0))then
else
if(dabs(flujmaxfval).gt.1.0d+20)then
!in case of infinity (division by zero)
do i=1,ndim
beta(i)=beta0(i)
enddo
flujmaxfval=sumsquare0
else
!designed this way to avoid flujmaxfval='NAN'
do i=1,ndim
beta(i)=beta0(i)
enddo
flujmaxfval=sumsquare0
endif
endif
j=0
100 if(j.ge.10)then
do i=1,ndim
betacp(i)=(beta(i)-betamin(i))/(betamax(i)-betamin(i))
enddo
isitbounded=0
call pikaia(flujmax_pikaia,ndim,gacontrol,betacp,flujmaxfval,i)
do i=1,ndim
beta(i)=betamin(i)+betacp(i)*(betamax(i)-betamin(i))
enddo
isitbounded=1
call funkmin_flujmax(ndim,beta,flujmaxfval)
endif
sumsquare0=flujmaxfval
do i=1,ndim
beta0(i)=beta(i)
enddo
call nongradopt(ndim,funkmin_flujmax,f1dim_flujmax,
&beta,betamin,betamax,ftol,flujmaxfval)
call funkmin_flujmax(ndim,beta,flujmaxfval)
if(flujmaxfval.eq.sumsquare0)return
if(dabs(flujmaxfval).le.dabs(sumsquare0))then
else
if(dabs(flujmaxfval).gt.1.0d+20)then
!in case of infinity (division by zero)
do i=1,ndim
beta(i)=beta0(i)
enddo
flujmaxfval=sumsquare0
else
!designed this way to avoid flujmaxfval='NAN'
do i=1,ndim
beta(i)=beta0(i)
enddo
flujmaxfval=sumsquare0
endif
endif
sumsquarecp=flujmaxfval
do i=1,ndim
betacp(i)=beta(i)
enddo
call RepeatCompassSearch(ndim,betacp,sumsquarecp,betamin,
&betamax,funkmin_flujmax,f1dim_flujmax,xtol)
call funkmin_flujmax(ndim,betacp,sumsquarecp)
if(flujmaxfval.eq.sumsquarecp)return
if(dabs(sumsquarecp).lt.dabs(flujmaxfval))then
do i=1,ndim
beta(i)=betacp(i)
enddo
flujmaxfval=sumsquarecp
endif
j=j+1
if(j.le.2.and.dabs(flujmaxfval-sumsquare0).gt.ftol)goto 100
!
!------------------------------------------------------
110 call funkmin_flujmax(ndim,beta,flujmaxfval)
return
END subroutine fluorescencejmax
leafres/testarea/funkmin_UnivPhotoFit.f
+177
View File
@@ -0,0 +1,177 @@
subroutine funkmin_UnivPhotoFit(ndim,beta,fvalue)
implicit none
include '../testarea/LeafGasParams.h'
include '../testarea/LeafGasHybridFit.h'
integer ndim
double precision beta(1:ndim),fvalue
!(in) ndim: the dimension of the parameter vector
!(in) beta: the parameters
!(out) fvalue: the value of the cost function at beta
!
!---------Local variables--------------------------------------------------
integer i,n,ilimit0,nummismatch
double precision pointfvalue
!----------- End of variables declaration ---------------------------------
!check to see if parameters are out of bounds.
if(isitbounded.eq.1)then
do i=1,ndim
if(beta(i).lt.betamin(i).or.beta(i).gt.betamax(i))then
! parameter out of bound
fvalue=1.0d+100
return
endif
enddo
endif
n=0
do i=1,ntotunivparams
!replace the values in univparams with those optimized
if(ifixunivparams(i).eq.1)then
n=n+1
univparams(i)=beta(n)
endif
enddo
call UnivParamsAlloc(2)
ilimit0=Currentilimittype
fvalue=0.0d0
nummismatch=0
do i=1,ntotsamples
if(Currentilimittype.le.4.and.Currentiknowlimit.eq.1)
&ilimit0=Currentiphotolimit(i)+4
call leafunivphotosyn(Currentiknowlimit,ilimit0,ifitmode,
&aPPFDlf(i),templeaf(i),pco2i(i),po2i(i),chlflphips2(i),
&anet_obs(i),weitresponses(i:i,1:1),weitresponses(i:i,1:1),
&weitresponses(i:i,2:2),weitresponses(i:i,1:1),
&pco2i_pred(i),anet_pred(i),Postiphotolimit(i),pco2c(i),
&PhiPSII_pred(i),anet_pred_flu(i),pco2i_pred_flu(i),
&pco2c_anet_flu(i),pco2c_pco2i_flu(i),pointfvalue)
if(pco2c(i).lt.0.0d0.and.Currentiknowlimit.ne.-1)then
fvalue=1.0d+101
return
endif
fvalue=fvalue+pointfvalue
if(Currentiknowlimit.eq.2.and.Currentiphotolimit(i).ne.
&Postiphotolimit(i))nummismatch=nummismatch+1
enddo
if(nummismatch.ne.0)then
!penalize inadmissible fit
fvalue=fvalue*(dble(nummismatch)*1000.0d0)**2+
&dble(nummismatch)*1000.0d0
endif
return
end subroutine funkmin_UnivPhotoFit
!$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
double precision function f1dim_UnivPhotoFit(x)
implicit none
double precision x
CU USES funkmin_UnivPhotoFit
INTEGER j
!((((((((((((((((((((((((((((((((((((((((((((((((((((
integer NMAX,ncom
parameter(NMAX=1000)
double precision pcom(NMAX),xicom(NMAX)
COMMON /f1com/ pcom,xicom,ncom
save /f1com/
!))))))))))))))))))))))))))))))))))))))))))))))))))))
double precision xt(NMAX)
do 11 j=1,ncom
xt(j)=pcom(j)+x*xicom(j)
11 continue
call funkmin_UnivPhotoFit(ncom,xt,f1dim_UnivPhotoFit)
return
END
!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
SUBROUTINE FCN_UnivPhotoFit(N,M,NP,NQ,
+ LDN,LDM,LDNP,
+ BETA,XPLUSD,
+ IFIXB,IFIXX,LDIFX,
+ IDEVAL,F,FJACB,FJACD,
+ ISTOP)
implicit none
include '../testarea/LeafGasParams.h'
include '../testarea/LeafGasHybridFit.h'
C SUBROUTINE ARGUMENTS
C ==> N NUMBER OF OBSERVATIONS
C ==> M NUMBER OF COLUMNS IN EXPLANATORY VARIABLE
C ==> NP NUMBER OF PARAMETERS
C ==> NQ NUMBER OF RESPONSES PER OBSERVATION
C ==> LDN LEADING DIMENSION DECLARATOR EQUAL OR EXCEEDING N
C ==> LDM LEADING DIMENSION DECLARATOR EQUAL OR EXCEEDING M
C ==> LDNP LEADING DIMENSION DECLARATOR EQUAL OR EXCEEDING NP
C ==> BETA CURRENT VALUES OF PARAMETERS
C ==> XPLUSD CURRENT VALUE OF EXPLANATORY VARIABLE, I.E., X + DELTA
C ==> IFIXB INDICATORS FOR "FIXING" PARAMETERS (BETA)
C ==> IFIXX INDICATORS FOR "FIXING" EXPLANATORY VARIABLE (X)
C ==> LDIFX LEADING DIMENSION OF ARRAY IFIXX
C ==> IDEVAL INDICATOR FOR SELECTING COMPUTATION TO BE PERFORMED
C <== F PREDICTED FUNCTION VALUES
C <== FJACB JACOBIAN WITH RESPECT TO BETA
C <== FJACD JACOBIAN WITH RESPECT TO ERRORS DELTA
C <== ISTOP STOPPING CONDITION, WHERE
C 0 MEANS CURRENT BETA AND X+DELTA WERE
C ACCEPTABLE AND VALUES WERE COMPUTED SUCCESSFULLY
C 1 MEANS CURRENT BETA AND X+DELTA ARE
C NOT ACCEPTABLE; ODRPACK SHOULD SELECT VALUES
C CLOSER TO MOST RECENTLY USED VALUES IF POSSIBLE
C -1 MEANS CURRENT BETA AND X+DELTA ARE
C NOT ACCEPTABLE; ODRPACK SHOULD STOP
C INPUT ARGUMENTS, NOT TO BE CHANGED BY THIS ROUTINE:
INTEGER I,IDEVAL,ISTOP,L,LDIFX,LDM,LDN,LDNP,M,N,NP,NQ
DOUBLE PRECISION BETA(NP),XPLUSD(LDN,M)
INTEGER IFIXB(NP),IFIXX(LDIFX,M)
C OUTPUT ARGUMENTS:
DOUBLE PRECISION F(LDN,NQ),FJACB(LDN,LDNP,NQ),FJACD(LDN,LDM,NQ)
integer k
double precision fvalue
c
ISTOP=0
do I=1,NP
if(BETA(I).lt.betamin(I).or.
&BETA(I).gt.betamax(I))then
ISTOP=1
return
endif
enddo
do I=1,N
pco2i(I)=XPLUSD(I,1)
aPPFDlf(I)=XPLUSD(I,2)
templeaf(I)=XPLUSD(I,3)
po2i(I)=XPLUSD(I,4)
if(Currentiknowlimit.eq.-1)chlflphips2(I)=XPLUSD(I,M)
enddo
IF (MOD(IDEVAL,10).GE.1) THEN
call funkmin_UnivPhotoFit(NP,BETA,fvalue)
if(fvalue.gt.1.0d+20)then
ISTOP=1
return
endif
DO 100 I = 1,N
if(Currentiknowlimit.eq.-1)then
F(I,1)=anet_pred_flu(I)
else
F(I,1)=anet_pred(I)
endif
100 CONTINUE
if(NQ.eq.2)then
DO 110 I = 1,N
F(I,NQ)=PhiPSII_pred(I)
110 CONTINUE
endif
END IF
RETURN
END
!$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
double precision function ff_pikaia(ndim,beta01)
implicit none
include '../testarea/LeafGasParams.h'
integer ndim,i
double precision beta01(ndim),beta(ndim),fvalue
do i=1,ndim
! beta01(i)=(beta(i)-betamin(i))/(betamax(i)-betamin(i))
beta(i)=betamin(i)+beta01(i)*(betamax(i)-betamin(i))
enddo
call funkmin_UnivPhotoFit(ndim,beta,fvalue)
ff_pikaia=1.0d0/(fvalue+0.00001d0)
return
end
leafres/testarea/funkmin_cica5.f
+50
View File
@@ -0,0 +1,50 @@
subroutine funkmin_cica(ndim,beta,fvalue)
implicit none
include '../testarea/cica.h'
integer ndim
double precision beta(1:ndim),fvalue
!(in) ndim: the dimension of the parameter vector
!(in) beta: the parameters
!(out) fvalue: the value of the cost function at beta
!
integer i
double precision cica,der_cica,term,der_beta(ndim)
!----------- End of variables declaration ---------------------------------
!
! check to see if parameters are out of bounds
do i=1,ndim
if(beta(i).lt.bmin(i).or.beta(i).gt.bmax(i))then
! parameter out of bound
fvalue=1.0d+100
return
endif
enddo
fvalue=0.0d0
do i=1,nobs
term=pco2ambient(i)
call cica_ca5(imodel,ndim,beta,term,cica,der_cica,der_beta)
fvalue=fvalue+(cicameas(i)-cica)**2
enddo
return
end subroutine funkmin_cica
!$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
double precision function f1dim_cica(x)
INTEGER NMAX
double precision x
PARAMETER (NMAX=1000)
CU USES funkmin_stom
INTEGER j,ncom
double precision pcom(NMAX),xicom(NMAX),xt(NMAX)
COMMON /f1com/ pcom,xicom,ncom
do 11 j=1,ncom
xt(j)=pcom(j)+x*xicom(j)
11 continue
call funkmin_cica(ncom,xt,f1dim_cica)
return
END
leafres/testarea/funkmin_flujmax.f
+149
View File
@@ -0,0 +1,149 @@
subroutine funkmin_flujmax(ndim,beta,fvalue)
implicit none
include '../testarea/LeafGasParams.h'
include '../testarea/LeafGasHybridFit.h'
integer ndim
double precision beta(1:ndim),fvalue
!(in) ndim: the dimension of the parameter vector
!(in) beta: the parameters
!(out) fvalue: the value of the cost function at beta
!
!---------Local variables--------------------------------------------------
integer i
double precision fjelect,thetaPSII
!----------- End of variables declaration ---------------------------------
!check to see if parameters are out of bounds.
if(isitbounded.eq.1)then
do i=1,ndim
if(beta(i).lt.betamin(i).or.beta(i).gt.betamax(i))then
! parameter out of bound
fvalue=1.0d+100
return
endif
enddo
endif
fjmax25=beta(1)
phifactor=beta(2)
thetafactor=beta(3)
if(ndim.gt.3)ha_jmax=beta(4)
fvalue=0.0d0
do i=1,ntotlights
call jontemp(aparlights(i),templflights(i),fjelect,fjmax25,
&ha_jmax,hd_jmax,sv_jmax,gascon,phifactor,thetafactor,betaPSII)
if(aparlights(i).gt.0.0d0)then
PhiPSIIlights_pred(i)=fjelect/(betaPSII*aparlights(i))
else
call thetaphipsii(templflights(i),PhiPSIIlights_pred(i),
&thetaPSII)
PhiPSIIlights_pred(i)=PhiPSIIlights_pred(i)*phifactor
endif
fvalue=fvalue+
! &(fjelect-betaPSII*flphips2lights(i)*aparlights(i))**2.0d0+
&(100.0d0*(PhiPSIIlights_pred(i)-flphips2lights(i)))**2.0d0
enddo
return
end subroutine funkmin_flujmax
!$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
double precision function f1dim_flujmax(x)
implicit none
double precision x
CU USES funkmin_flujmax
INTEGER j
!((((((((((((((((((((((((((((((((((((((((((((((((((((
integer NMAX,ncom
parameter(NMAX=1000)
double precision pcom(NMAX),xicom(NMAX)
COMMON /f1com/ pcom,xicom,ncom
save /f1com/
!))))))))))))))))))))))))))))))))))))))))))))))))))))
double precision xt(NMAX)
do 11 j=1,ncom
xt(j)=pcom(j)+x*xicom(j)
11 continue
call funkmin_flujmax(ncom,xt,f1dim_flujmax)
return
END
!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
SUBROUTINE FCN_flujmax(N,M,NP,NQ,
+ LDN,LDM,LDNP,
+ BETA,XPLUSD,
+ IFIXB,IFIXX,LDIFX,
+ IDEVAL,F,FJACB,FJACD,
+ ISTOP)
implicit none
include '../testarea/LeafGasParams.h'
include '../testarea/LeafGasHybridFit.h'
C SUBROUTINE ARGUMENTS
C ==> N NUMBER OF OBSERVATIONS
C ==> M NUMBER OF COLUMNS IN EXPLANATORY VARIABLE
C ==> NP NUMBER OF PARAMETERS
C ==> NQ NUMBER OF RESPONSES PER OBSERVATION
C ==> LDN LEADING DIMENSION DECLARATOR EQUAL OR EXCEEDING N
C ==> LDM LEADING DIMENSION DECLARATOR EQUAL OR EXCEEDING M
C ==> LDNP LEADING DIMENSION DECLARATOR EQUAL OR EXCEEDING NP
C ==> BETA CURRENT VALUES OF PARAMETERS
C ==> XPLUSD CURRENT VALUE OF EXPLANATORY VARIABLE, I.E., X + DELTA
C ==> IFIXB INDICATORS FOR "FIXING" PARAMETERS (BETA)
C ==> IFIXX INDICATORS FOR "FIXING" EXPLANATORY VARIABLE (X)
C ==> LDIFX LEADING DIMENSION OF ARRAY IFIXX
C ==> IDEVAL INDICATOR FOR SELECTING COMPUTATION TO BE PERFORMED
C <== F PREDICTED FUNCTION VALUES
C <== FJACB JACOBIAN WITH RESPECT TO BETA
C <== FJACD JACOBIAN WITH RESPECT TO ERRORS DELTA
C <== ISTOP STOPPING CONDITION, WHERE
C 0 MEANS CURRENT BETA AND X+DELTA WERE
C ACCEPTABLE AND VALUES WERE COMPUTED SUCCESSFULLY
C 1 MEANS CURRENT BETA AND X+DELTA ARE
C NOT ACCEPTABLE; ODRPACK SHOULD SELECT VALUES
C CLOSER TO MOST RECENTLY USED VALUES IF POSSIBLE
C -1 MEANS CURRENT BETA AND X+DELTA ARE
C NOT ACCEPTABLE; ODRPACK SHOULD STOP
C INPUT ARGUMENTS, NOT TO BE CHANGED BY THIS ROUTINE:
INTEGER I,IDEVAL,ISTOP,L,LDIFX,LDM,LDN,LDNP,M,N,NP,NQ
DOUBLE PRECISION BETA(NP),XPLUSD(LDN,M)
INTEGER IFIXB(NP),IFIXX(LDIFX,M)
C OUTPUT ARGUMENTS:
DOUBLE PRECISION F(LDN,NQ),FJACB(LDN,LDNP,NQ),FJACD(LDN,LDM,NQ)
integer k
double precision fvalue
c
ISTOP=0
! do I=1,NP
! if(BETA(I).lt.betamin(I).or.
! &BETA(I).gt.betamax(I))then
! ISTOP=1
! return
! endif
! enddo
do I=1,N
aparlights(I)=XPLUSD(I,1)
templflights(I)=XPLUSD(I,2)
enddo
IF (MOD(IDEVAL,10).GE.1) THEN
call funkmin_flujmax(NP,BETA,fvalue)
if(fvalue.gt.1.0d+20)then
ISTOP=1
return
endif
DO 100 I = 1,N
F(I,1)=PhiPSIIlights_pred(I)
100 CONTINUE
END IF
RETURN
END
!$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
double precision function flujmax_pikaia(ndim,beta01)
implicit none
include '../testarea/LeafGasParams.h'
integer ndim,i
double precision beta01(ndim),beta(ndim),fvalue
do i=1,ndim
! beta01(i)=(beta(i)-betamin(i))/(betamax(i)-betamin(i))
beta(i)=betamin(i)+beta01(i)*(betamax(i)-betamin(i))
enddo
call funkmin_flujmax(ndim,beta,fvalue)
flujmax_pikaia=1.0d0/(fvalue+0.00001d0)
return
end
leafres/testarea/funkmin_stom.f
+51
View File
@@ -0,0 +1,51 @@
subroutine funkmin_stom(ndim,beta,fvalue)
implicit none
include '../testarea/stomoptim.h'
integer ndim
double precision beta(ndim+1),fvalue
!(in) ndim: the dimension of the parameter vector
!(in) beta: the parameters
!(out) fvalue: the value of the cost function at beta
!
integer i,j
double precision stomintercept,stomslope,gswmod,rayDzero
!----------- End of variables declaration ---------------------------------
!
! check to see if parameters are out of bounds
do i=1,ndim
if(beta(i).lt.bmin(i).or.beta(i).gt.bmax(i))then
! parameter out of bound
fvalue=1.0d+100
return
endif
enddo
stomintercept=beta(1)
stomslope=beta(2)
if(istommodel.eq.2.or.istommodel.eq.4)rayDzero=beta(3)
fvalue=0.0d0
do j=1,nobs
call StomatalConductance(pco2s(j),rehulfsurf(j),
& gammas(j),pvapordef_s(j),rayDzero,assim_net(j),
& istommodel,stomintercept,stomslope,gswmod)
fvalue=fvalue+(gswmeas(j)-gswmod)**2.0d0
enddo
return
end subroutine funkmin_stom
!$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
double precision function f1dim_stom(x)
INTEGER NMAX
double precision x
PARAMETER (NMAX=1000)
CU USES funkmin_stom
INTEGER j,ncom
double precision pcom(NMAX),xicom(NMAX),xt(NMAX)
COMMON /f1com/ pcom,xicom,ncom
do 11 j=1,ncom
xt(j)=pcom(j)+x*xicom(j)
11 continue
call funkmin_stom(ncom,xt,f1dim_stom)
return
END
leafres/testarea/ilimittypestats.f
+45
View File
@@ -0,0 +1,45 @@
subroutine ilimittypestats(ntotpoints,iphotolimit,ilimittype,
&numrubis,numrubp,numtpu)
implicit none
integer ntotpoints,iphotolimit(ntotpoints),ilimittype,
&numrubis,numrubp,numtpu,i
numrubis=0
numrubp=0
numtpu=0
do i=1,ntotpoints
if(iphotolimit(i).eq.1)numrubis=numrubis+1
if(iphotolimit(i).eq.2)numrubp=numrubp+1
if(iphotolimit(i).eq.3)numtpu=numtpu+1
enddo
if(numrubis.eq.0.and.numrubp.eq.0.and.numtpu.eq.0)then
ilimittype=0
return
endif
if(numrubis.eq.0)then
if(numrubp.eq.0)then
ilimittype=7
else
if(numtpu.eq.0)then
ilimittype=6
else
ilimittype=4
endif
endif
else
if(numrubp.eq.0)then
if(numtpu.eq.0)then
ilimittype=5
else
ilimittype=3
endif
else
if(numtpu.eq.0)then
ilimittype=2
else
ilimittype=1
endif
endif
endif
return
end
leafres/testarea/leafanetmodel.f
+1041
View File
File diff suppressed because it is too large Load Diff
leafres/testarea/leafunivphotosyn.f
+258
View File
@@ -0,0 +1,258 @@
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
subroutine leafunivphotosyn(Currentiknowlimit0,ilimittype0,
&ifitmode0,aPPFDlf,templeaf,pco2i_obs0,po2i,chlflphips20,anet_obs0,
&weitpco2i0,weitanet0,weitphips20,weitfjelect0,pco2i_pred0,
&anet_pred0,iphotolimit0,pco2c0,PhiPSII_pred,anet_pred_flu0,
&pco2i_pred_flu0,pco2c_anet_flu0,pco2c_pco2i_flu0,fvalue)
implicit none
include '../testarea/LeafGasParams.h'
include '../testarea/pco2ianetfunc.h'
!------------ Inputs -------------------
!ilimittype=1: Rubisco,RuBp and TPU limitations
! =2: Rubisco and RuBp limitations only
! =3: Rubisco and TPU limitations only
! =4: RuBp and TPU limitations only
! =5: Rubisco limitation only
! =6: RuBp limitation only
! =7: TPU limitation only
!aPPFDlf: absorbed photosynthetic photon flux density by leaf (umol m-2 s-1)
!templeaf: leaf temperature [K]
!pco2i_obs: measured intercellular CO2 partial pressure (Pa).
!po2i: intercellular O2 partial pressure (Pa, often taking the ambient value).
!chlflphips2: photochemical efficiency of photosynthesis (NA), if provided
!anet_obs: meausred net rate of CO2 uptake per unit leaf area [umol m-2 s-1]
!ifitmode: =-2, ordinary fitting with pco2i calculated as a function of anet
!ifitmode: =-1, ordinary fitting with anet calculated as a function of pco2i
!ifitmode: =1, orthogonal fitting with anet calculated as a function of pco2i
!ifitmode: =2, orthogonal fitting with pco2i calculated as a function of anet
!------------ Outputs -------------------
!anet_pred: net rate of CO2 uptake per unit leaf area calculated from pco2i_obs and photosynthetic parameters [umol m-2 s-1]
!iphotolimit_anet: the limitation state of the photosynthesis determined with anet as the response variable and pco2i as one independent variable
!pco2c_anet: chloroplastic CO2 partial pressure calculated with anet as a response
!fjelect_anet: the realized electron transport rate <= jrubp (=when RuBP regeneration limits photosynthesis) determined with anet as the response
! variable and pco2i as one independent variable.
!anet_pred_flu: if chlflphips2 is provided, net rate of CO2 uptake per unit leaf area calculated from photochemical efficiency. anet is a response. [umol m-2 s-1],
!pco2c_anet_flu: chloroplastic CO2 partial pressure calculated from fluorescence data with anet as a response (Pa)
!
!pco2i_pred: intercellular CO2 partial pressure calculated from anet_obs and photosynthetic parameters [Pa]
!iphotolimit_pco2i: the limitation state of the photosynthesis determined with pco2i as the response variable and anet as one independent variable
!pco2c_pco2i: chloroplastic CO2 partial pressure calculated with pco2i as a response
!fjelect_pco2i: the realized electron transport rate <= jrubp (=when RuBP regeneration limits photosynthesis) determined with pco2i as the response
! variable and anet as one independent variable.
!pco2i_pred_flu: if chlflphips2 is provided, intercellular CO2 partial pressure calculated from photochemical efficiency. pco2i is a response. [Pa]
!pco2c_pco2i_flu: chloroplastic CO2 partial pressure calculated from fluorescence data with pco2i as a response (Pa)
!Note: when alpha25 = 0, pco2i cannot be solved from anet because anet is independent of pco2i and pco2c. so when TPU is limitting, we always treat
! anet as a response and pco2i as an independent.
integer Currentiknowlimit0,ilimittype0,ifitmode0,iphotolimit0
double precision aPPFDlf,templeaf,pco2i_obs0,po2i,chlflphips20,
&anet_obs0,weitpco2i0,weitanet0,weitphips20,weitfjelect0,
&pco2i_pred0,anet_pred0,pco2c0,PhiPSII_pred,anet_pred_flu0,
&pco2i_pred_flu0,pco2c_anet_flu0,pco2c_pco2i_flu0,fvalue
!------------ Local variables -----------
integer ierr,n
double precision fkc,fko,ax,bx,cx,fa,fb,fc,lowerbound,upperbound,
&pco2ianetfunc,term,x_pred,deltafract,step,TOL,leafbrent,dum,
&thetaPSII
parameter(TOL=1.0d-7,deltafract=0.2d0)
Currentiknowlimit=Currentiknowlimit0
ilimittype=ilimittype0
ifitmode=ifitmode0
pco2i_obs=pco2i_obs0
chlflphips2=chlflphips20
anet_obs=anet_obs0
weitpco2i=weitpco2i0
weitanet=weitanet0
weitphips2=weitphips20
weitfjelect=weitfjelect0
alpha=alpha25
if(Currentiknowlimit.ne.-1)then
call vcmaxontemp(templeaf,vcmax25,gascon,ha_vcmax,hd_vcmax,
&sv_vcmax,vcmax)
call jontemp(aPPFDlf,templeaf,fjelect,fjmax25,ha_jmax,
&hd_jmax,sv_jmax,gascon,phifactor,thetafactor,betaPSII)
call tpuontemp(templeaf,gascon,tpu25,ha_tpu,hd_tpu,sv_tpu,tpu)
if(chlflphips2.gt.0.0d0)then
chlflfjelect=betaPSII*chlflphips2*aPPFDlf
if(aPPFDlf.lt.0.0d0)then
call thetaphipsii(templeaf,PhiPSIImax,thetaPSII)
PhiPSIImax=PhiPSIImax*phifactor
endif
endif
else
if(chlflphips2.gt.0.0d0)then
fjelect=betaPSII*chlflphips2*aPPFDlf
else
fvalue=0.0d0
return
endif
endif
call gmesoontemp(templeaf,1.0d0,gascon,ha_gmeso,hd_gmeso,
&sv_gmeso,term)
resistwp=resistwp25/term
resistch=resistch25/term
call resp_mitocho(templeaf,rdlight25,ha_darkresp,gascon,rdlight)
call co2compens(templeaf,stargamma25,ha_stargamma,gascon,
&stargamma)
call MichaelisCO2(templeaf,fkc25,ha_kc,gascon,fkc)
call MichaelisO2(templeaf,fko25,ha_ko,gascon,fko)
fkco=fkc*(1.0d0+po2i/fko)
if(ifitmode.eq.-1)then
ifitmode=1
fvalue=pco2ianetfunc(pco2i_obs)
goto 100
endif
if(ifitmode.eq.-2)then
ifitmode=2
fvalue=pco2ianetfunc(anet_obs)
goto 100
endif
if(ifitmode.eq.1)then
term=pco2i_obs
upperbound=term*(1.0d0+deltafract)
lowerbound=term*(1.0d0-deltafract)
ax=term*(1.0d0-deltafract/5.0d0)
bx=term
endif
if(ifitmode.eq.2)then
term=dmax1(2.0d0,dabs(anet_obs))
upperbound=anet_obs+term*deltafract
lowerbound=anet_obs-term*deltafract
ax=anet_obs-term*deltafract/5.0d0
bx=anet_obs
endif
n=0
10 call leafmnbrak(ax,bx,cx,fa,fb,fc,lowerbound,upperbound,
&ierr,pco2ianetfunc)
if(ierr.ne.0)then
if(n.le.50)then
if(fb.gt.fa)then
dum=ax
ax=bx
bx=dum
dum=fa
fa=fb
fb=dum
!from ax to bx, f decreases
endif
if(fc.gt.fb)then
if(fc.lt.fa)then
dum=bx
bx=cx
cx=dum
dum=fc
fc=fb
fb=dum
else
dum=ax
ax=cx
cx=dum
dum=fc
fc=fa
fa=dum
endif
endif
!from ax to bx to cx, f decreases
if(dabs(cx-bx).lt.dabs(cx-ax))then
if(ax.gt.cx)then
lowerbound=lowerbound-term*deltafract
else
upperbound=upperbound+term*deltafract
endif
ax=lowerbound+(upperbound-lowerbound)*0.5d0
bx=lowerbound+(upperbound-lowerbound)*0.51d0
n=n+1
goto 10
else
if(ifitmode.eq.1)x_pred=pco2i_obs
if(ifitmode.eq.2)x_pred=anet_obs
endif
else
if(ifitmode.eq.1)x_pred=pco2i_obs
if(ifitmode.eq.2)x_pred=anet_obs
endif
endif
fvalue=leafbrent(ax,bx,cx,pco2ianetfunc,TOL,x_pred)
fvalue=pco2ianetfunc(x_pred)
100 pco2i_pred0=pco2i_pred
anet_pred0=anet_pred
if(aPPFDlf.gt.0.0d0)then
PhiPSII_pred=realizedfjelect/(betaPSII*aPPFDlf)
else
PhiPSII_pred=PhiPSIImax
endif
iphotolimit0=iphotolimit
pco2c0=pco2c
anet_pred_flu0=anet_pred_flu
pco2i_pred_flu0=pco2i_pred_flu
pco2c_anet_flu0=pco2c_anet_flu
pco2c_pco2i_flu0=pco2c_pco2i_flu
return
end
double precision function pco2ianetfunc(x)
implicit none
include '../testarea/pco2ianetfunc.h'
!local variables
integer iph
double precision x,term,term1,term2,term3,pco2c_wp,anet_wp
if(ifitmode.eq.1)then
!anet as a function of pco2i
pco2i_pred=x
call Anet_Final(vcmax,fjelect,tpu,resistwp,resistch,stargamma,
&fkco,pco2i_pred,alpha,rdlight,ilimittype,iphotolimit,anet_pred,
&pco2c,realizedfjelect)
pco2ianetfunc=(weitpco2i*(pco2i_obs-pco2i_pred))**2+
&(weitanet*(anet_obs-anet_pred))**2
endif
if(ifitmode.eq.2)then
!pco2i as a function of anet
anet_pred=x
call CO2i_Final(vcmax,fjelect,tpu,resistwp,resistch,stargamma,
&fkco,pco2i_pred,alpha,rdlight,ilimittype,iphotolimit,
&anet_pred,pco2c,realizedfjelect,pco2i_obs,pco2c_wp,anet_wp)
if(iphotolimit.eq.3.and.alpha.le.0.0d0)then
!anet is independent of pco2i. assume no error in pco2i. ensure the optimized x = 3*tpu-rd. Vc for tpu
!is computed from the forward mode, i.e. the same as in ifitmode=1
pco2i_pred=pco2i_obs
anet_pred=anet_wp
pco2c=pco2c_wp
pco2ianetfunc=(weitanet**2)*
&((anet_obs-anet_pred)**2+(x-anet_pred)**2)
else
pco2ianetfunc=(weitpco2i*(pco2i_obs-pco2i_pred))**2+
&(weitanet*(anet_obs-anet_pred))**2
endif
endif
if(Currentiknowlimit.ne.-1.and.chlflphips2.gt.0.0d0)then
!use either option 1 or option 2 or option 3
!option 1
if(chlflfjelect.gt.0.0d0)then
pco2ianetfunc=pco2ianetfunc+(weitphips2*
&chlflphips2*(1.0d0-realizedfjelect/chlflfjelect))**2
else
pco2ianetfunc=pco2ianetfunc+
&(weitphips2*(chlflphips2-PhiPSIImax))**2
endif
!option 2
pco2ianetfunc=pco2ianetfunc+
&(weitfjelect*(chlflfjelect-realizedfjelect))**2
!option 3
if(ifitmode.eq.1)then
call Anet_Final(vcmax,chlflfjelect,tpu,resistwp,resistch,
&stargamma,fkco,pco2i_pred,alpha,rdlight,6,iph,anet_pred_flu,
&pco2c_anet_flu,term)
pco2ianetfunc=pco2ianetfunc+
&(weitanet*(anet_pred-anet_pred_flu))**2
endif
if(ifitmode.eq.2)then
call CO2i_Final(vcmax,chlflfjelect,tpu,resistwp,resistch,
&stargamma,fkco,pco2i_pred_flu,alpha,rdlight,6,iph,anet_pred,
&pco2c_pco2i_flu,term,term1,term2,term3)
pco2ianetfunc=pco2ianetfunc+
&(weitpco2i*(pco2i_pred-pco2i_pred_flu))**2
endif
endif
return
end
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
leafres/testarea/pam_parameters.f
+189
View File
@@ -0,0 +1,189 @@
subroutine pam_parameters(nsamples,fo,fm,fs,measlight,anet,
&actiniclight,tempK,yield_ps2,yield_npq,qlake,qpuddle,kps2_norm,
&knpq_norm,fo_dark,fm_dark,resp_dark,tempK_dark)
implicit none
!Calculate fluorescence parameters
!The dark-adapted measurements must be put in the beginning of the data section and the
!corresponding par must be set to zero. If the dark-adapted measurements are sampled
!multiple times, these multiple samples must be put immediately one after the other.
integer nsamples
double precision fo(nsamples),fm(nsamples),fs(nsamples),
&measlight(nsamples),anet(nsamples),actiniclight(nsamples),
&tempK(nsamples),yield_ps2(nsamples),yield_npq(nsamples),
&qlake(nsamples),qpuddle(nsamples),kps2_norm(nsamples),
&knpq_norm(nsamples),fo_dark,fm_dark,resp_dark,tempK_dark
!
!==============Inputs==========================================
!nsamples: The total number of samples
!fo: The fluorescence yield in the dark (zero PARi). It is measured on either
! a dark-adapted leaf or a previously illuminated leaf with the actinic light
! turned off and a far-red light applied to energize PSI to drain electrons from
! PSII and reoxidize QA. In other words, here fo can be either fo or fo'(to be indicated by PAR value)
!fm: The fluorescence yield with the all PSII reaction centers closed (all QAs fully
! reduced) by a saturating pulse of light. It is either fm or fm' (to be indicated by PAR value)
!fs: The steady-state fluorescence yield of an illuminated leaf.
!measlight The measuring light (umol photons m-2s-1), not used as of 3/19/2015
!anet: The net photosynthetical rate (umol/m2/s)
!actiniclight: The total incident actinic photosynthetically active radiation (umol photons /m2/s)
!tempK: The temperature of each measurement (K)
!
!==============Outputs=========================================
!yield_ps2: The photochemical yield of PSII
!yield_npq: The yield of regulated nonphotochemical quenching
!qlake: The fraction of open PSII reaction centers based on the lake model
!qpuddle: The fraction of open PSII reaction centers based on the puddle model
!kps2_norm: The rate constant of photochemical quenching, normalized by the sum of fluorescence rate constant kf and
! intrinsic thermal dissipation rate constant kd. That is, kps2_norm = kp/(kf+kd)
!knpq_norm: The rate constant of regulated nonphotochemical quenching, normalized by the sum of fluorescence rate constant kf and
! intrinsic thermal dissipation rate constant kd. That is, knpq_norm = knqp/(kf+kd).
! knpq_norm is simply the NPQ parameter commonly used in the literature.
!fo_dark: The dark-adapted fo
!fm_dark: The dark-adapted fm
!resp_dark: The dark respiration rate (umol/m2/s)
!tempK_dark: The temperature of the dark measurement (K)
!
!We don't calculate qn because it has no clear physical / biological meaning)
!
!
integer i,j,k,n
double precision fs_dark,threshold
!
do i=1,nsamples
if(measlight(i).gt.0.0d0)then
if(fo(i).gt.0.0d0)fo(i)=fo(i)/dabs(measlight(i))
if(fm(i).gt.0.0d0)fm(i)=fm(i)/dabs(measlight(i))
if(fs(i).gt.0.0d0)fs(i)=fs(i)/dabs(measlight(i))
endif
enddo
!Find the dark-adapted fo and fm
!We assume the following:
!- The first measurement that has a zero actiniclight is a dark-adapted measurement.
!- Any measurements that immediately follow the first dark-adapated measurement and have zero actiniclight are
!- repeated samples of dark-adated measurements.
threshold=0.001d0
i=1
10 if(dabs(actiniclight(i)).lt.threshold)then
j=i
goto 20
endif
if(i.lt.nsamples)then
i=i+1
goto 10
endif
!no dark-adapted measurements
fo_dark=-9999.0d0
fm_dark=-9999.0d0
fs_dark=-9999.0d0
resp_dark=-9999.0d0
tempK_dark=-9999.0d0
goto 40
20 j=j+1
if(j.gt.nsamples)goto 30
if(dabs(actiniclight(j)).gt.threshold)goto 30
if(j.lt.nsamples)goto 20
j=j+1
30 j=j-1
!
fo_dark=0.0d0
n=0
do k=i,j
if(fo(k).gt.0.0d0)then
n=n+1
fo_dark=fo_dark+fo(k)
endif
enddo
if(n.eq.0)then
fo_dark=-9999.0d0
else
fo_dark=fo_dark/dble(n)
endif
!
fm_dark=0.0d0
n=0
do k=i,j
if(fm(k).gt.0.0d0)then
n=n+1
fm_dark=fm_dark+fm(k)
endif
enddo
if(n.eq.0)then
fm_dark=-9999.0d0
else
fm_dark=fm_dark/dble(n)
endif
!
fs_dark=0.0d0
n=0
do k=i,j
if(fs(k).gt.0.0d0)then
n=n+1
fs_dark=fs_dark+fs(k)
endif
enddo
if(n.eq.0)then
fs_dark=-9999.0d0
else
fs_dark=fs_dark/dble(n)
endif
!
resp_dark=0.0d0
n=0
do k=i,j
if(anet(k).lt.0.0d0.and.dabs(anet(k)+9999.0d0).gt.0.01d0)then
n=n+1
resp_dark=resp_dark+anet(k)
endif
enddo
if(n.eq.0)then
resp_dark=-9999.0d0
else
resp_dark=dabs(resp_dark/dble(n))
endif
!
tempK_dark=0.0d0
n=0
do k=i,j
if(tempK(k).gt.0.0d0)then
n=n+1
tempK_dark=tempK_dark+tempK(k)
endif
enddo
if(n.eq.0)then
tempK_dark=-9999.0d0
else
tempK_dark=tempK_dark/dble(n)
endif
!
!for dark-adapted measurements, fo_dark and fs_dark are the same
if(fo_dark.lt.0.0d0)fo_dark=fs_dark
!
40 do i=1,nsamples
if(fo(i).lt.0.0d0.and.fo_dark.gt.0.0d0)then
!We use Oxborough and Baker (1997) Photosynthesis Research 54: 135-142 in case when Fo' in the light
!is not measured.
if(fm_dark.gt.0.0d0.and.fm(i).gt.0.0d0)fo(i)=
&fo_dark/(1.0d0-fo_dark/fm_dark+fo_dark/fm(i))
endif
!
yield_ps2(i)=-9999.0d0
yield_npq(i)=-9999.0d0
qpuddle(i)=-9999.0d0
qlake(i)=-9999.0d0
if(fm(i).gt.0.0d0.and.fs(i).gt.0.0d0)then
yield_ps2(i)=(fm(i)-fs(i))/fm(i)
if(fm_dark.gt.0.0d0)yield_npq(i)=fs(i)/fm(i)-fs(i)/fm_dark
if(fo(i).gt.0.0d0)then
qpuddle(i)=(fm(i)-fs(i))/(fm(i)-fo(i))
qlake(i)=qpuddle(i)*fo(i)/fs(i)
endif
endif
knpq_norm(i)=-9999.0d0
kps2_norm(i)=-9999.0d0
if(fm_dark.gt.0.0d0.and.fm(i).gt.0.0d0)then
knpq_norm(i)=fm_dark/fm(i)-1.0d0
if(fs(i).gt.0.0d0)
&kps2_norm(i)=fm_dark*(1.0d0/fs(i)-1.0d0/fm(i))
endif
enddo
return
end subroutine pam_parameters
leafres/testarea/pco2ianetfunc.h
+14
View File
@@ -0,0 +1,14 @@
integer ifitmode,Currentiknowlimit,ilimittype,iphotolimit
double precision vcmax,fjelect,tpu,resistwp,resistch,stargamma,
&fkco,alpha,rdlight,pco2i_obs,anet_obs,chlflphips2,chlflfjelect,
&pco2i_pred,anet_pred,pco2c,realizedfjelect,weitanet,weitpco2i,
&weitphips2,weitfjelect,pco2i_pred_flu,anet_pred_flu,
&pco2c_anet_flu,pco2c_pco2i_flu,PhiPSIImax
common/int_pco2ianetfunc/ifitmode,Currentiknowlimit,ilimittype,
&iphotolimit
common/dble_pco2ianetfunc/vcmax,fjelect,tpu,resistwp,resistch,
&stargamma,fkco,alpha,rdlight,pco2i_obs,anet_obs,chlflphips2,
&chlflfjelect,pco2i_pred,anet_pred,pco2c,realizedfjelect,weitanet,
&weitpco2i,weitphips2,weitfjelect,pco2i_pred_flu,anet_pred_flu,
&pco2c_anet_flu,pco2c_pco2i_flu,PhiPSIImax
leafres/testarea/retired/ALightCombinatorial.f
+299
View File
@@ -0,0 +1,299 @@
subroutine ALightCombinatorial()
implicit none
include '../testarea/LeafGasHybridFit.h'
integer i,ilastrubp1,ilastrubis1,ilastrubp2,ilastrubis2,
&ilastrubp3,ilastrubis3,ilastrubp4,ilastrubis4,
&ilastrubp5,ilastrubis5,ilastrubp6,ilastrubis6,
&ilastrubp7,ilastrubis7,ilastrubp8,ilastrubis8,
&ilastrubp9,ilastrubis9,ilastrubp10,ilastrubis10,
&ilastrubp11,ilastrubis11,ilastrubp12,ilastrubis12,
&ilastrubp13,ilastrubis13,ilastrubp14,ilastrubis14,
&ilastrubp15,ilastrubis15
!common block variables: numALightcurves,nALightPoints(numALightcurves),
!ALightiphotolimit(nALightPoints,numALightcurves)
if(numALightcurves.eq.0)then
!no conventional A/Light curves. go to free-style measurements directly and then return
call FreeCombinatorial()
return
endif
!(before 17/09/2014 remarks.) Assume rubp, rubisco and tpu limitations in the order of (rubp, rubisco, tpu) but any limitation can be missing in any light response curves
!the nALightPoints data in each light response curve must be ordered from low to high PAR. When ordered in such, the three limitation states
!should occur in the order of (rubp, rubisco, tpu)
!
!17/09/2014 Wenting found (RuBP, TPU, Rubisco) is more likely for A/Light curves if Ci decreases with increased light. Thus the following
!changes are made:
!we generally assume the points of an A/Light curve are lined up in a sequence of (RuBP, TPU and Rubisco), which is indicated by
!ialightorder=0. However, if Ci increases steadily from nstartalight to the end, we assume a sequence of (RuBP, Rubisco and TPU),
!which is indicated by ialightorder=2.
do ilastrubp1=nstartalight(1),nendalight(1)
do i=1,ilastrubp1
ALightiphotolimit(i,1)=2
enddo
do 1 ilastrubis1=ilastrubp1,nALightPoints(1)
do i=ilastrubp1+1,ilastrubis1
ALightiphotolimit(i,1)=3-ialightorder(1)
enddo
do i=ilastrubis1+1,nALightPoints(1)
ALightiphotolimit(i,1)=1+ialightorder(1)
enddo
if(numALightcurves.eq.1)then
call FreeCombinatorial()
goto 1
endif
do ilastrubp2=nstartalight(2),nendalight(2)
do i=1,ilastrubp2
ALightiphotolimit(i,2)=2
enddo
do 2 ilastrubis2=ilastrubp2,nALightPoints(2)
do i=ilastrubp2+1,ilastrubis2
ALightiphotolimit(i,2)=3-ialightorder(2)
enddo
do i=ilastrubis2+1,nALightPoints(2)
ALightiphotolimit(i,2)=1+ialightorder(2)
enddo
if(numALightcurves.eq.2)then
call FreeCombinatorial()
goto 2
endif
do ilastrubp3=nstartalight(3),nendalight(3)
do i=1,ilastrubp3
ALightiphotolimit(i,3)=2
enddo
do 3 ilastrubis3=ilastrubp3,nALightPoints(3)
do i=ilastrubp3+1,ilastrubis3
ALightiphotolimit(i,3)=3-ialightorder(3)
enddo
do i=ilastrubis3+1,nALightPoints(3)
ALightiphotolimit(i,3)=1+ialightorder(3)
enddo
if(numALightcurves.eq.3)then
call FreeCombinatorial()
goto 3
endif
do ilastrubp4=nstartalight(4),nendalight(4)
do i=1,ilastrubp4
ALightiphotolimit(i,4)=2
enddo
do 4 ilastrubis4=ilastrubp4,nALightPoints(4)
do i=ilastrubp4+1,ilastrubis4
ALightiphotolimit(i,4)=3-ialightorder(4)
enddo
do i=ilastrubis4+1,nALightPoints(4)
ALightiphotolimit(i,4)=1+ialightorder(4)
enddo
if(numALightcurves.eq.4)then
call FreeCombinatorial()
goto 4
endif
do ilastrubp5=nstartalight(5),nendalight(5)
do i=1,ilastrubp5
ALightiphotolimit(i,5)=2
enddo
do 5 ilastrubis5=ilastrubp5,nALightPoints(5)
do i=ilastrubp5+1,ilastrubis5
ALightiphotolimit(i,5)=3-ialightorder(5)
enddo
do i=ilastrubis5+1,nALightPoints(5)
ALightiphotolimit(i,5)=1+ialightorder(5)
enddo
if(numALightcurves.eq.5)then
call FreeCombinatorial()
goto 5
endif
do ilastrubp6=nstartalight(6),nendalight(6)
do i=1,ilastrubp6
ALightiphotolimit(i,6)=2
enddo
do 6 ilastrubis6=ilastrubp6,nALightPoints(6)
do i=ilastrubp6+1,ilastrubis6
ALightiphotolimit(i,6)=3-ialightorder(6)
enddo
do i=ilastrubis6+1,nALightPoints(6)
ALightiphotolimit(i,6)=1+ialightorder(6)
enddo
if(numALightcurves.eq.6)then
call FreeCombinatorial()
goto 6
endif
do ilastrubp7=nstartalight(7),nendalight(7)
do i=1,ilastrubp7
ALightiphotolimit(i,7)=2
enddo
do 7 ilastrubis7=ilastrubp7,nALightPoints(7)
do i=ilastrubp7+1,ilastrubis7
ALightiphotolimit(i,7)=3-ialightorder(7)
enddo
do i=ilastrubis7+1,nALightPoints(7)
ALightiphotolimit(i,7)=1+ialightorder(7)
enddo
if(numALightcurves.eq.7)then
call FreeCombinatorial()
goto 7
endif
do ilastrubp8=nstartalight(8),nendalight(8)
do i=1,ilastrubp8
ALightiphotolimit(i,8)=2
enddo
do 8 ilastrubis8=ilastrubp8,nALightPoints(8)
do i=ilastrubp8+1,ilastrubis8
ALightiphotolimit(i,8)=3-ialightorder(8)
enddo
do i=ilastrubis8+1,nALightPoints(8)
ALightiphotolimit(i,8)=1+ialightorder(8)
enddo
if(numALightcurves.eq.8)then
call FreeCombinatorial()
goto 8
endif
do ilastrubp9=nstartalight(9),nendalight(9)
do i=1,ilastrubp9
ALightiphotolimit(i,9)=2
enddo
do 9 ilastrubis9=ilastrubp9,nALightPoints(9)
do i=ilastrubp9+1,ilastrubis9
ALightiphotolimit(i,9)=3-ialightorder(9)
enddo
do i=ilastrubis9+1,nALightPoints(9)
ALightiphotolimit(i,9)=1+ialightorder(9)
enddo
if(numALightcurves.eq.9)then
call FreeCombinatorial()
goto 9
endif
do ilastrubp10=nstartalight(10),nendalight(10)
do i=1,ilastrubp10
ALightiphotolimit(i,10)=2
enddo
do 10 ilastrubis10=ilastrubp10,nALightPoints(10)
do i=ilastrubp10+1,ilastrubis10
ALightiphotolimit(i,10)=3-ialightorder(10)
enddo
do i=ilastrubis10+1,nALightPoints(10)
ALightiphotolimit(i,10)=1+ialightorder(10)
enddo
if(numALightcurves.eq.10)then
call FreeCombinatorial()
goto 10
endif
do ilastrubp11=nstartalight(11),nendalight(11)
do i=1,ilastrubp11
ALightiphotolimit(i,11)=2
enddo
do 11 ilastrubis11=ilastrubp11,nALightPoints(11)
do i=ilastrubp11+1,ilastrubis11
ALightiphotolimit(i,11)=3-ialightorder(11)
enddo
do i=ilastrubis11+1,nALightPoints(11)
ALightiphotolimit(i,11)=1+ialightorder(11)
enddo
if(numALightcurves.eq.11)then
call FreeCombinatorial()
goto 11
endif
do ilastrubp12=nstartalight(12),nendalight(12)
do i=1,ilastrubp12
ALightiphotolimit(i,12)=2
enddo
do 12 ilastrubis12=ilastrubp12,nALightPoints(12)
do i=ilastrubp12+1,ilastrubis12
ALightiphotolimit(i,12)=3-ialightorder(12)
enddo
do i=ilastrubis12+1,nALightPoints(12)
ALightiphotolimit(i,12)=1+ialightorder(12)
enddo
if(numALightcurves.eq.12)then
call FreeCombinatorial()
goto 12
endif
do ilastrubp13=nstartalight(13),nendalight(13)
do i=1,ilastrubp13
ALightiphotolimit(i,13)=2
enddo
do 13 ilastrubis13=ilastrubp13,nALightPoints(13)
do i=ilastrubp13+1,ilastrubis13
ALightiphotolimit(i,13)=3-ialightorder(13)
enddo
do i=ilastrubis13+1,nALightPoints(13)
ALightiphotolimit(i,13)=1+ialightorder(13)
enddo
if(numALightcurves.eq.13)then
call FreeCombinatorial()
goto 13
endif
do ilastrubp14=nstartalight(14),nendalight(14)
do i=1,ilastrubp14
ALightiphotolimit(i,14)=2
enddo
do 14 ilastrubis14=ilastrubp14,nALightPoints(14)
do i=ilastrubp14+1,ilastrubis14
ALightiphotolimit(i,14)=3-ialightorder(14)
enddo
do i=ilastrubis14+1,nALightPoints(14)
ALightiphotolimit(i,14)=1+ialightorder(14)
enddo
if(numALightcurves.eq.14)then
call FreeCombinatorial()
goto 14
endif
do ilastrubp15=nstartalight(15),nendalight(15)
do i=1,ilastrubp15
ALightiphotolimit(i,15)=2
enddo
do 15 ilastrubis15=ilastrubp15,nALightPoints(15)
do i=ilastrubp15+1,ilastrubis15
ALightiphotolimit(i,15)=3-ialightorder(15)
enddo
do i=ilastrubis15+1,nALightPoints(15)
ALightiphotolimit(i,15)=1+ialightorder(15)
enddo
if(numALightcurves.eq.15)then
call FreeCombinatorial()
goto 15
endif
15 continue
enddo
14 continue
enddo
13 continue
enddo
12 continue
enddo
11 continue
enddo
10 continue
enddo
9 continue
enddo
8 continue
enddo
7 continue
enddo
6 continue
enddo
5 continue
enddo
4 continue
enddo
3 continue
enddo
2 continue
enddo
1 continue
enddo
return
end subroutine ALightCombinatorial
leafres/testarea/retired/FreeCombinatorial.f
+364
View File
@@ -0,0 +1,364 @@
subroutine FreeCombinatorial()
include '../testarea/LeafGasHybridFit.h'
integer
&i01,i02,i03,i04,i05,i06,i07,i08,i09,i10,
&i11,i12,i13,i14,i15,i16,i17,i18,i19,i20,
&i21,i22,i23,i24,i25,i26,i27,i28,i29,i30,
&i31,i32,i33,i34,i35,i36,i37,i38,i39,i40,
&i41,i42,i43,i44,i45,i46,i47,i48,i49,i50
if(nFreePoints.eq.0)then
call UnivPhotoFit()
return
endif
do 1 i01=1,3
Freeiphotolimit(1)=i01
if(nFreePoints.eq.1)then
call UnivPhotoFit()
goto 1
endif
do 2 i02=1,3
Freeiphotolimit(2)=i02
if(nFreePoints.eq.2)then
call UnivPhotoFit()
goto 2
endif
do 3 i03=1,3
Freeiphotolimit(3)=i03
if(nFreePoints.eq.3)then
call UnivPhotoFit()
goto 3
endif
do 4 i04=1,3
Freeiphotolimit(4)=i04
if(nFreePoints.eq.4)then
call UnivPhotoFit()
goto 4
endif
do 5 i05=1,3
Freeiphotolimit(5)=i05
if(nFreePoints.eq.5)then
call UnivPhotoFit()
goto 5
endif
do 6 i06=1,3
Freeiphotolimit(6)=i06
if(nFreePoints.eq.6)then
call UnivPhotoFit()
goto 6
endif
do 7 i07=1,3
Freeiphotolimit(7)=i07
if(nFreePoints.eq.7)then
call UnivPhotoFit()
goto 7
endif
do 8 i08=1,3
Freeiphotolimit(8)=i08
if(nFreePoints.eq.8)then
call UnivPhotoFit()
goto 8
endif
do 9 i09=1,3
Freeiphotolimit(9)=i09
if(nFreePoints.eq.9)then
call UnivPhotoFit()
goto 9
endif
do 10 i10=1,3
Freeiphotolimit(10)=i10
if(nFreePoints.eq.10)then
call UnivPhotoFit()
goto 10
endif
do 11 i11=1,3
Freeiphotolimit(11)=i11
if(nFreePoints.eq.11)then
call UnivPhotoFit()
goto 11
endif
do 12 i12=1,3
Freeiphotolimit(12)=i12
if(nFreePoints.eq.12)then
call UnivPhotoFit()
goto 12
endif
do 13 i13=1,3
Freeiphotolimit(13)=i13
if(nFreePoints.eq.13)then
call UnivPhotoFit()
goto 13
endif
do 14 i14=1,3
Freeiphotolimit(14)=i14
if(nFreePoints.eq.14)then
call UnivPhotoFit()
goto 14
endif
do 15 i15=1,3
Freeiphotolimit(15)=i15
if(nFreePoints.eq.15)then
call UnivPhotoFit()
goto 15
endif
do 16 i16=1,3
Freeiphotolimit(16)=i16
if(nFreePoints.eq.16)then
call UnivPhotoFit()
goto 16
endif
do 17 i17=1,3
Freeiphotolimit(17)=i17
if(nFreePoints.eq.17)then
call UnivPhotoFit()
goto 17
endif
do 18 i18=1,3
Freeiphotolimit(18)=i18
if(nFreePoints.eq.18)then
call UnivPhotoFit()
goto 18
endif
do 19 i19=1,3
Freeiphotolimit(19)=i19
if(nFreePoints.eq.19)then
call UnivPhotoFit()
goto 19
endif
do 20 i20=1,3
Freeiphotolimit(20)=i20
if(nFreePoints.eq.20)then
call UnivPhotoFit()
goto 20
endif
do 21 i21=1,3
Freeiphotolimit(21)=i21
if(nFreePoints.eq.21)then
call UnivPhotoFit()
goto 21
endif
do 22 i22=1,3
Freeiphotolimit(22)=i22
if(nFreePoints.eq.22)then
call UnivPhotoFit()
goto 22
endif
do 23 i23=1,3
Freeiphotolimit(23)=i23
if(nFreePoints.eq.23)then
call UnivPhotoFit()
goto 23
endif
do 24 i24=1,3
Freeiphotolimit(24)=i24
if(nFreePoints.eq.24)then
call UnivPhotoFit()
goto 24
endif
do 25 i25=1,3
Freeiphotolimit(25)=i25
if(nFreePoints.eq.25)then
call UnivPhotoFit()
goto 25
endif
do 26 i26=1,3
Freeiphotolimit(26)=i26
if(nFreePoints.eq.26)then
call UnivPhotoFit()
goto 26
endif
do 27 i27=1,3
Freeiphotolimit(27)=i27
if(nFreePoints.eq.27)then
call UnivPhotoFit()
goto 27
endif
do 28 i28=1,3
Freeiphotolimit(28)=i28
if(nFreePoints.eq.28)then
call UnivPhotoFit()
goto 28
endif
do 29 i29=1,3
Freeiphotolimit(29)=i29
if(nFreePoints.eq.29)then
call UnivPhotoFit()
goto 29
endif
do 30 i30=1,3
Freeiphotolimit(30)=i30
if(nFreePoints.eq.30)then
call UnivPhotoFit()
goto 30
endif
do 31 i31=1,3
Freeiphotolimit(31)=i31
if(nFreePoints.eq.31)then
call UnivPhotoFit()
goto 31
endif
do 32 i32=1,3
Freeiphotolimit(32)=i32
if(nFreePoints.eq.32)then
call UnivPhotoFit()
goto 32
endif
do 33 i33=1,3
Freeiphotolimit(33)=i33
if(nFreePoints.eq.33)then
call UnivPhotoFit()
goto 33
endif
do 34 i34=1,3
Freeiphotolimit(34)=i34
if(nFreePoints.eq.34)then
call UnivPhotoFit()
goto 34
endif
do 35 i35=1,3
Freeiphotolimit(35)=i35
if(nFreePoints.eq.35)then
call UnivPhotoFit()
goto 35
endif
do 36 i36=1,3
Freeiphotolimit(36)=i36
if(nFreePoints.eq.36)then
call UnivPhotoFit()
goto 36
endif
do 37 i37=1,3
Freeiphotolimit(37)=i37
if(nFreePoints.eq.37)then
call UnivPhotoFit()
goto 37
endif
do 38 i38=1,3
Freeiphotolimit(38)=i38
if(nFreePoints.eq.38)then
call UnivPhotoFit()
goto 38
endif
do 39 i39=1,3
Freeiphotolimit(39)=i39
if(nFreePoints.eq.39)then
call UnivPhotoFit()
goto 39
endif
do 40 i40=1,3
Freeiphotolimit(40)=i40
if(nFreePoints.eq.40)then
call UnivPhotoFit()
goto 40
endif
do 41 i41=1,3
Freeiphotolimit(41)=i41
if(nFreePoints.eq.41)then
call UnivPhotoFit()
goto 41
endif
do 42 i42=1,3
Freeiphotolimit(42)=i42
if(nFreePoints.eq.42)then
call UnivPhotoFit()
goto 42
endif
do 43 i43=1,3
Freeiphotolimit(43)=i43
if(nFreePoints.eq.43)then
call UnivPhotoFit()
goto 43
endif
do 44 i44=1,3
Freeiphotolimit(44)=i44
if(nFreePoints.eq.44)then
call UnivPhotoFit()
goto 44
endif
do 45 i45=1,3
Freeiphotolimit(45)=i45
if(nFreePoints.eq.45)then
call UnivPhotoFit()
goto 45
endif
do 46 i46=1,3
Freeiphotolimit(46)=i46
if(nFreePoints.eq.46)then
call UnivPhotoFit()
goto 46
endif
do 47 i47=1,3
Freeiphotolimit(47)=i47
if(nFreePoints.eq.47)then
call UnivPhotoFit()
goto 47
endif
do 48 i48=1,3
Freeiphotolimit(48)=i48
if(nFreePoints.eq.48)then
call UnivPhotoFit()
goto 48
endif
do 49 i49=1,3
Freeiphotolimit(49)=i49
if(nFreePoints.eq.49)then
call UnivPhotoFit()
goto 49
endif
do 50 i50=1,3
Freeiphotolimit(50)=i50
if(nFreePoints.eq.50)then
call UnivPhotoFit()
goto 50
endif
50 continue
49 continue
48 continue
47 continue
46 continue
45 continue
44 continue
43 continue
42 continue
41 continue
40 continue
39 continue
38 continue
37 continue
36 continue
35 continue
34 continue
33 continue
32 continue
31 continue
30 continue
29 continue
28 continue
27 continue
26 continue
25 continue
24 continue
23 continue
22 continue
21 continue
20 continue
19 continue
18 continue
17 continue
16 continue
15 continue
14 continue
13 continue
12 continue
11 continue
10 continue
9 continue
8 continue
7 continue
6 continue
5 continue
4 continue
3 continue
2 continue
1 continue
return
end subroutine FreeCombinatorial
leafres/testarea/retired/HybridCombinatorial.f
+587
View File
@@ -0,0 +1,587 @@
!We consider four types of leaf gas exchange measurements. These four types must be clearly indicated in the input:
!1. Points whose limitation states are known from other means (e.g. chlorophyll fluorescence): these points will be called fixed points and
! their limitation states will not be changed by the parameter estimation program.
!2. Points from conventional CO2 response measurements (A/Ci curves) that are done without fluorescence. Limitation states are not known but follow
! the order of Rubisco, RuBP and TPU along the CO2i axis as suggested in Gu et al. (2010) PCE paper. We call these points ACi points.
! The ACi points must be already ordered from low to high CO2i.
!3. Points from conventional light response measurements (A/PAR curves) that are done without fluorescence. Limitation states are not known but follow
! the order of RuBP, Rubisco and TPU along the PAR axis. We call these points ALight points. The ALight points must be already ordered from low to high PAR.
!4. Points whose limitation states follow no order. We call these points free points. They are obtained with no control of environmental conditions.
subroutine HybridCombinatorial()
implicit none
include '../testarea/LeafGasParams.h'
include '../testarea/LeafGasHybridFit.h'
integer i,ilastrubis1,ilastrubp1,ilastrubis2,ilastrubp2,
&ilastrubis3,ilastrubp3,ilastrubis4,ilastrubp4,
&ilastrubis5,ilastrubp5,ilastrubis6,ilastrubp6,
&ilastrubis7,ilastrubp7,ilastrubis8,ilastrubp8,
&ilastrubis9,ilastrubp9,ilastrubis10,ilastrubp10,
&ilastrubis11,ilastrubp11,ilastrubis12,ilastrubp12,
&ilastrubis13,ilastrubp13,ilastrubis14,ilastrubp14,
&ilastrubis15,ilastrubp15,k1,k2,k3,k4,k5,k6,k7,k8,
&k9,k10,k11,k12,k13,k14,k15,ilasttpu1,ilasttpu2,
&ilasttpu3,ilasttpu4,ilasttpu5,ilasttpu6,ilasttpu7,
&ilasttpu8,ilasttpu9,ilasttpu10,ilasttpu11,ilasttpu12,
&ilasttpu13,ilasttpu14,ilasttpu15
double precision rdlight,atp,resistwp,resistch,stargamma,
&realizedfjelect,term
!
!common block variables:idokco,idoalpha,minimumrubis,minimumfj,minimumvt,nACiPoints,ACiiphotolimit(nACiPoints)
minimumfj=3
if(idokc.eq.0.and.idoko.eq.0)then
minimumrubis=3
else
if(idokc.eq.0.or.idoko.eq.0)then
minimumrubis=4
else
minimumrubis=5
endif
endif
if((nFixedPoints+numACicurves+nFreePoints).eq.0)minimumrubis=2
if(idoalpha.eq.0)then
minimumvt=2
else
minimumvt=3
endif
i=0
do k1=1,numACicurves
do k2=nendaci(k1)+1,nACiPoints(k1)
i=i+1
enddo
enddo
if(i.gt.0)minimumvt=i
!
ntotunivparams=13
univparamsmin(1)=resistwp25min
univparamsmax(1)=resistwp25max
univparamsmin(2)=resistch25min
univparamsmax(2)=resistch25max
univparamsmin(3)=rdlight25min
univparamsmax(3)=rdlight25max
univparamsmin(4)=stargamma25min
univparamsmax(4)=stargamma25max
univparamsmin(5)=vcmax25min
univparamsmax(5)=vcmax25max
univparamsmin(6)=fkc25min
univparamsmax(6)=fkc25max
univparamsmin(7)=fko25min
univparamsmax(7)=fko25max
univparamsmin(8)=fjmax25min
univparamsmax(8)=fjmax25max
univparamsmin(9)=tpu25min
univparamsmax(9)=tpu25max
univparamsmin(10)=alpha25min
univparamsmax(10)=alpha25max
univparamsmin(11)=phifactormin
univparamsmax(11)=phifactormax
univparamsmin(12)=thetafactormin
univparamsmax(12)=thetafactormax
univparamsmin(13)=betaPSIImin
univparamsmax(13)=betaPSIImax
bestilimittype=-9999
do ilastrubis1=1,7
subbestsumsquare(ilastrubis1)=1.0d+100
subbestunivparams(1,ilastrubis1)=resistwp25_ori
subbestunivparams(2,ilastrubis1)=resistch25_ori
subbestunivparams(3,ilastrubis1)=rdlight25_ori
subbestunivparams(4,ilastrubis1)=stargamma25_ori
subbestunivparams(5,ilastrubis1)=vcmax25_ori
subbestunivparams(6,ilastrubis1)=fkc25_ori
subbestunivparams(7,ilastrubis1)=fko25_ori
subbestunivparams(8,ilastrubis1)=fjmax25_ori
subbestunivparams(9,ilastrubis1)=tpu25_ori
subbestunivparams(10,ilastrubis1)=alpha25_ori
subbestunivparams(11,ilastrubis1)=phifactor_ori
subbestunivparams(12,ilastrubis1)=thetafactor_ori
subbestunivparams(13,ilastrubis1)=betaPSII_ori
do i=1,ntotsamples
subbestiphotolimit(i,ilastrubis1)=-9999
enddo
enddo
do i=1,ntotsamples
forcings(i,1)=pco2i_ori(i)
forcings(i,2)=aPPFDlf_ori(i)
forcings(i,3)=templeaf_ori(i)
forcings(i,4)=po2i_ori(i)
responses(i,1)=anet_obs(i)
weitforcings(i,1)=1.0d0
weitforcings(i,2)=1.0d0
weitforcings(i,3)=1.0d0
weitforcings(i,4)=1.0d0
weitresponses(i,1)=1.0d0
if(ntotphips2.ge.1)then
if(chlflphips2_ori(i).gt.0.0d0)then
!for least square regression
responses(i,2)=chlflphips2_ori(i)
!a factor of 50 makes PhiPSII comparable to Anet in magnitude
weitresponses(i,2)=50.0d0
else
responses(i,2)=chlflphips2_ori(i)
weitresponses(i,2)=0.0d0
endif
endif
if(Prioriknowlimit.eq.-1)then
!fluorescence fit only. chlflphips2 becomes a response variable
forcings(i,5)=chlflphips2_ori(i)
weitforcings(i,5)=1.0d0
if(chlflphips2_ori(i).le.0.0d0)then
weitforcings(i,5)=0.0d0
weitresponses(i,1)=0.0d0
endif
endif
enddo
do i=1,12
gacontrol(i)=-1.0d0
enddo
gacontrol(1)=250.0d0
gacontrol(2)=5000.0d0
gacontrol(3)=8.0d0
!Priorilimittype: indicator for the choice of overall mixtures of limitation types
! = 1, Rubisco+RuBP+TPU
! = 2, Rubisco+RuBP
! = 3, Rubisco+TPU
! = 4, RuBP+TPU
! = 5, Rubisco Only
! = 6, RuBP Only
! = 7, TPU Only
!Prioriknowlimit: indicator for how the limitation type of each point is set before the fitting
! = 0, the limitation type of each individual point has not been pre-set when mixed
! limitation states are present in the dataset. When Priorilimittype = 5, 6, 7,
! all points are limited by one type.
! = 1, the limit type of each individual point has been pre-set. Don't allow the fitting
! algorithm to change the limitation type of each point during the first fit. But
! check the admissibility after the first fit. If the admissibility is violated,
! treat the osicilation points as colimited; if there is no osicilation, use the penalty
! approach to refit.
! = 2, the limit type of each individual point has been pre-set. Allow the fitting
! algorithm to change the limitation type of each point during the fit. Penalize any fit
! that results in any point to have a limitation type different from the pre-set type.
! =-1, only do a fluorescence fit
!$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
if(Prioriknowlimit.eq.-1)then
!fluorescence only fit
Priorilimittype=6
Currentilimittype=Priorilimittype
Currentiknowlimit=Prioriknowlimit
!we pass UnivPhotoFit and call DoUnivPhotoFit directly
call DoUnivPhotoFit()
if(numALightcurves.gt.0.and.idorch.eq.1)then
call fluorescencejmax()
endif
return
endif
!$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
Prioriknowlimit=0
bestsumsquare=1.0d+100
do Priorilimittype=1,7
call UnivPhotoFit()
if(subbestsumsquare(Priorilimittype).le.bestsumsquare)then
bestilimittype=Priorilimittype
bestsumsquare=subbestsumsquare(Priorilimittype)
do i=1,ntotunivparams
bestunivparams(i)=subbestunivparams(i,Priorilimittype)
enddo
do i=1,ntotsamples
bestiphotolimit(i)=subbestiphotolimit(i,Priorilimittype)
enddo
endif
enddo
! goto 1000
bestilimittype=-9999
Prioriknowlimit=1
Priorilimittype=-9999
!
c gacontrol( 1) - number of individuals in a population (default
c is 100)
c gacontrol( 2) - number of generations over which solution is
c to evolve (default is 500)
c gacontrol( 3) - number of significant digits (i.e., number of
c genes) retained in chromosomal encoding (default
c is 6) (Note: This number is limited by the
c machine floating point precision. Most 32-bit
c floating point representations have only 6 full
c digits of precision. To achieve greater preci-
c sion this routine could be converted to double
c precision, but note that this would also require
c a double precision random number generator, which
c likely would not have more than 9 digits of
c precision if it used 4-byte integers internally.)
c gacontrol( 4) - crossover probability; must be <= 1.0 (default
c is 0.85). If crossover takes place, either one
c or two splicing points are used, with equal
c probabilities
c gacontrol( 5) - mutation mode; 1/2/3/4/5 (default is 2)
c 1=one-point mutation, fixed rate
c 2=one-point, adjustable rate based on fitness
c 3=one-point, adjustable rate based on distance
c 4=one-point+creep, fixed rate
c 5=one-point+creep, adjustable rate based on fitness
c 6=one-point+creep, adjustable rate based on distance
c gacontrol( 6) - initial mutation rate; should be small (default
c is 0.005) (Note: the mutation rate is the proba-
c bility that any one gene locus will mutate in
c any one generation.)
c gacontrol( 7) - minimum mutation rate; must be >= 0.0 (default
c is 0.0005)
c gacontrol( 8) - maximum mutation rate; must be <= 1.0 (default
c is 0.25)
c gacontrol( 9) - relative fitness differential; range from 0
c (none) to 1 (maximum). (default is 1.)
c gacontrol(10) - reproduction plan; 1/2/3=Full generational
c replacement/Steady-state-replace-random/Steady-
c state-replace-worst (default is 3)
c gacontrol(11) - elitism flag; 0/1=off/on (default is 0)
c (Applies only to reproduction plans 1 and 2)
c gacontrol(12) - printed output 0/1/2=None/Minimal/Verbose
c (default is 0)
c
if(numACicurves.eq.0)then
!no conventional A/Ci curves. go to light response curves directly.
call ALightCombinatorial()
goto 1000
endif
!Assume rubisco, rubp and tpu limitations in the order of (rubisco, rubp, tpu) but any limitation can be missing in any ACi curves.
!The nACiPoints points of each ACi curve must have been already ordered from low to high Ci within each individual ACi curve.
do ilastrubis1=0,nendaci(1)
do i=1,ilastrubis1
ACiiphotolimit(i,1)=1
enddo
k1=max0(nstartaci(1)-1,ilastrubis1)
do 1 ilasttpu1=k1,nendaci(1)
do i=ilasttpu1+1,nACiPoints(1)
ACiiphotolimit(i,1)=3
enddo
do i=ilastrubis1+1,ilasttpu1
ACiiphotolimit(i,1)=2
enddo
if(numACicurves.eq.1)then
call ALightCombinatorial()
goto 1
endif
do ilastrubis2=0,nendaci(2)
do i=1,ilastrubis2
ACiiphotolimit(i,2)=1
enddo
k2=max0(nstartaci(2)-1,ilastrubis2)
do 2 ilasttpu2=k2,nendaci(2)
do i=ilasttpu2+1,nACiPoints(2)
ACiiphotolimit(i,2)=3
enddo
do i=ilastrubis2+1,ilasttpu2
ACiiphotolimit(i,2)=2
enddo
if(numACicurves.eq.2)then
call ALightCombinatorial()
goto 2
endif
do ilastrubis3=0,nendaci(3)
do i=1,ilastrubis3
ACiiphotolimit(i,3)=1
enddo
k3=max0(nstartaci(3)-1,ilastrubis3)
do 3 ilasttpu3=k3,nendaci(3)
do i=ilasttpu3+1,nACiPoints(3)
ACiiphotolimit(i,3)=3
enddo
do i=ilastrubis3+1,ilasttpu3
ACiiphotolimit(i,3)=2
enddo
if(numACicurves.eq.3)then
call ALightCombinatorial()
goto 3
endif
do ilastrubis4=0,nendaci(4)
do i=1,ilastrubis4
ACiiphotolimit(i,4)=1
enddo
k4=max0(nstartaci(4)-1,ilastrubis4)
do 4 ilasttpu4=k4,nendaci(4)
do i=ilasttpu4+1,nACiPoints(4)
ACiiphotolimit(i,4)=3
enddo
do i=ilastrubis4+1,ilasttpu4
ACiiphotolimit(i,4)=2
enddo
if(numACicurves.eq.4)then
call ALightCombinatorial()
goto 4
endif
do ilastrubis5=0,nendaci(5)
do i=1,ilastrubis5
ACiiphotolimit(i,5)=1
enddo
k5=max0(nstartaci(5)-1,ilastrubis5)
do 5 ilasttpu5=k5,nendaci(5)
do i=ilasttpu5+1,nACiPoints(5)
ACiiphotolimit(i,5)=3
enddo
do i=ilastrubis5+1,ilasttpu5
ACiiphotolimit(i,5)=2
enddo
if(numACicurves.eq.5)then
call ALightCombinatorial()
goto 5
endif
do ilastrubis6=0,nendaci(6)
do i=1,ilastrubis6
ACiiphotolimit(i,6)=1
enddo
k6=max0(nstartaci(6)-1,ilastrubis6)
do 6 ilasttpu6=k6,nendaci(6)
do i=ilasttpu6+1,nACiPoints(6)
ACiiphotolimit(i,6)=3
enddo
do i=ilastrubis6+1,ilasttpu6
ACiiphotolimit(i,6)=2
enddo
if(numACicurves.eq.6)then
call ALightCombinatorial()
goto 6
endif
do ilastrubis7=0,nendaci(7)
do i=1,ilastrubis7
ACiiphotolimit(i,7)=1
enddo
k7=max0(nstartaci(7)-1,ilastrubis7)
do 7 ilasttpu7=k7,nendaci(7)
do i=ilasttpu7+1,nACiPoints(7)
ACiiphotolimit(i,7)=3
enddo
do i=ilastrubis7+1,ilasttpu7
ACiiphotolimit(i,7)=2
enddo
if(numACicurves.eq.7)then
call ALightCombinatorial()
goto 7
endif
do ilastrubis8=0,nendaci(8)
do i=1,ilastrubis8
ACiiphotolimit(i,8)=1
enddo
k8=max0(nstartaci(8)-1,ilastrubis8)
do 8 ilasttpu8=k8,nendaci(8)
do i=ilasttpu8+1,nACiPoints(8)
ACiiphotolimit(i,8)=3
enddo
do i=ilastrubis8+1,ilasttpu8
ACiiphotolimit(i,8)=2
enddo
if(numACicurves.eq.8)then
call ALightCombinatorial()
goto 8
endif
do ilastrubis9=0,nendaci(9)
do i=1,ilastrubis9
ACiiphotolimit(i,9)=1
enddo
k9=max0(nstartaci(9)-1,ilastrubis9)
do 9 ilasttpu9=k9,nendaci(9)
do i=ilasttpu9+1,nACiPoints(9)
ACiiphotolimit(i,9)=3
enddo
do i=ilastrubis9+1,ilasttpu9
ACiiphotolimit(i,9)=2
enddo
if(numACicurves.eq.9)then
call ALightCombinatorial()
goto 9
endif
do ilastrubis10=0,nendaci(10)
do i=1,ilastrubis10
ACiiphotolimit(i,10)=1
enddo
k10=max0(nstartaci(10)-1,ilastrubis10)
do 10 ilasttpu10=k10,nendaci(10)
do i=ilasttpu10+1,nACiPoints(10)
ACiiphotolimit(i,10)=3
enddo
do i=ilastrubis10+1,ilasttpu10
ACiiphotolimit(i,10)=2
enddo
if(numACicurves.eq.10)then
call ALightCombinatorial()
goto 10
endif
do ilastrubis11=0,nendaci(11)
do i=1,ilastrubis11
ACiiphotolimit(i,11)=1
enddo
k11=max0(nstartaci(11)-1,ilastrubis11)
do 11 ilasttpu11=k11,nendaci(11)
do i=ilasttpu11+1,nACiPoints(11)
ACiiphotolimit(i,11)=3
enddo
do i=ilastrubis11+1,ilasttpu11
ACiiphotolimit(i,11)=2
enddo
if(numACicurves.eq.11)then
call ALightCombinatorial()
goto 11
endif
do ilastrubis12=0,nendaci(12)
do i=1,ilastrubis12
ACiiphotolimit(i,12)=1
enddo
k12=max0(nstartaci(12)-1,ilastrubis12)
do 12 ilasttpu12=k12,nendaci(12)
do i=ilasttpu12+1,nACiPoints(12)
ACiiphotolimit(i,12)=3
enddo
do i=ilastrubis12+1,ilasttpu12
ACiiphotolimit(i,12)=2
enddo
if(numACicurves.eq.12)then
call ALightCombinatorial()
goto 12
endif
do ilastrubis13=0,nendaci(13)
do i=1,ilastrubis13
ACiiphotolimit(i,13)=1
enddo
k13=max0(nstartaci(13)-1,ilastrubis13)
do 13 ilasttpu13=k13,nendaci(13)
do i=ilasttpu13+1,nACiPoints(13)
ACiiphotolimit(i,13)=3
enddo
do i=ilastrubis13+1,ilasttpu13
ACiiphotolimit(i,13)=2
enddo
if(numACicurves.eq.13)then
call ALightCombinatorial()
goto 13
endif
do ilastrubis14=0,nendaci(14)
do i=1,ilastrubis14
ACiiphotolimit(i,14)=1
enddo
k14=max0(nstartaci(14)-1,ilastrubis14)
do 14 ilasttpu14=k14,nendaci(14)
do i=ilasttpu14+1,nACiPoints(14)
ACiiphotolimit(i,14)=3
enddo
do i=ilastrubis14+1,ilasttpu14
ACiiphotolimit(i,14)=2
enddo
if(numACicurves.eq.14)then
call ALightCombinatorial()
goto 14
endif
do ilastrubis15=0,nendaci(15)
do i=1,ilastrubis15
ACiiphotolimit(i,15)=1
enddo
k15=max0(nstartaci(15)-1,ilastrubis15)
do 15 ilasttpu15=k15,nendaci(15)
do i=ilasttpu15+1,nACiPoints(15)
ACiiphotolimit(i,15)=3
enddo
do i=ilastrubis15+1,ilasttpu15
ACiiphotolimit(i,15)=2
enddo
if(numACicurves.eq.15)then
call ALightCombinatorial()
goto 15
endif
15 continue
enddo
14 continue
enddo
13 continue
enddo
12 continue
enddo
11 continue
enddo
10 continue
enddo
9 continue
enddo
8 continue
enddo
7 continue
enddo
6 continue
enddo
5 continue
enddo
4 continue
enddo
3 continue
enddo
2 continue
enddo
1 continue
enddo
bestsumsquare=1.0d+100
do Priorilimittype=1,7
if(subbestsumsquare(Priorilimittype).le.bestsumsquare)then
bestilimittype=Priorilimittype
bestsumsquare=subbestsumsquare(Priorilimittype)
do i=1,ntotunivparams
bestunivparams(i)=subbestunivparams(i,Priorilimittype)
enddo
do i=1,ntotsamples
bestiphotolimit(i)=subbestiphotolimit(i,Priorilimittype)
enddo
endif
enddo
1000 do i=1,ntotunivparams
univparams(i)=bestunivparams(i)
enddo
call UnivParamsAlloc(2)
call ilimittypestats(ntotsamples,bestiphotolimit,
&bestilimittype,bestnumrubis,bestnumrubp,bestnumtpu)
if(bestnumrubis.eq.0)then
vcmax25=-9999
if(idokc.eq.1)fkc25=-9999.0d0
if(idoko.eq.1)fko25=-9999.0d0
endif
if(bestnumrubp.eq.0)fjmax25=-9999
if(bestnumtpu.eq.0)then
tpu25=-9999
if(idoalpha.eq.1)alpha25=-9999
endif
do i=1,ntotsamples
ilastrubp1=bestiphotolimit(i)+4
call leafunivphotosyn(Prioriknowlimit,ilastrubp1,ifitmode,
&aPPFDlf(i),templeaf(i),pco2i(i),po2i(i),chlflphips2(i),
&anet_obs(i),weitresponses(i:i,1:1),weitresponses(i:i,1:1),
&weitresponses(i:i,2:2),weitresponses(i:i,1:1),
&pco2i_pred(i),anet_pred(i),Postiphotolimit(i),pco2c(i),
&PhiPSII_pred(i),anet_pred_flu(i),pco2i_pred_flu(i),
&pco2c_anet_flu(i),pco2c_pco2i_flu(i),term)
if(chlflphips2(i).lt.0.0d0)then
anet_pred_flu(i)=-9999.0d0
pco2i_pred_flu(i)=-9999.0d0
pco2c_anet_flu(i)=-9999.0d0
pco2c_pco2i_flu(i)=-9999.0d0
else
if(iabs(ifitmode).eq.1)then
pco2i_pred_flu(i)=-9999.0d0
pco2c_pco2i_flu(i)=-9999.0d0
endif
if(iabs(ifitmode).eq.2)then
anet_pred_flu(i)=-9999.0d0
pco2c_anet_flu(i)=-9999.0d0
endif
endif
enddo
return
end subroutine HybridCombinatorial
leafres/testarea/sim_ALightCombinatorial.f
+257
View File
@@ -0,0 +1,257 @@
subroutine sim_ALightCombinatorial()
implicit none
include '../testarea/LeafGasHybridFit.h'
integer i,ilastrubp1,ilastrubis1,ilastrubp2,ilastrubis2,
&ilastrubp3,ilastrubis3,ilastrubp4,ilastrubis4,
&ilastrubp5,ilastrubis5,ilastrubp6,ilastrubis6,
&ilastrubp7,ilastrubis7,ilastrubp8,ilastrubis8,
&ilastrubp9,ilastrubis9,ilastrubp10,ilastrubis10,
&ilastrubp11,ilastrubis11,ilastrubp12,ilastrubis12,
&ilastrubp13,ilastrubis13,ilastrubp14,ilastrubis14,
&ilastrubp15,ilastrubis15
!common block variables: numALightcurves,nALightPoints(numALightcurves),
!ALightiphotolimit(nALightPoints,numALightcurves)
if(numALightcurves.eq.0)then
!no conventional A/Light curves. go to free-style measurements directly and then return
call FreeCombinatorial()
return
endif
!(before 17/09/2014 remarks.) Assume rubp, rubisco and tpu limitations in the order of (rubp, rubisco, tpu) but any limitation can be missing in any light response curves
!the nALightPoints data in each light response curve must be ordered from low to high PAR. When ordered in such, the three limitation states
!should occur in the order of (rubp, rubisco, tpu)
!
!17/09/2014 Wenting found (RuBP, TPU, Rubisco) is more likely for A/Light curves if Ci decreases with increased light. Thus the following
!changes are made:
!we generally assume the points of an A/Light curve are lined up in a sequence of (RuBP, TPU and Rubisco), which is indicated by
!ialightorder=0. However, if Ci increases steadily from nstartalight to the end, we assume a sequence of (RuBP, Rubisco and TPU),
!which is indicated by ialightorder=2.
!
!Assume a light response curve is either rubp and rubisco or rubp and tpu
do ilastrubp1=nstartalight(1),nendalight(1)
do i=1,ilastrubp1
ALightiphotolimit(i,1)=2
enddo
do 1 ilastrubis1=1,2
do i=ilastrubp1+1,nALightPoints(1)
ALightiphotolimit(i,1)=2*ilastrubis1-1
enddo
if(numALightcurves.eq.1)then
call FreeCombinatorial()
goto 1
endif
do ilastrubp2=nstartalight(2),nendalight(2)
do i=1,ilastrubp2
ALightiphotolimit(i,2)=2
enddo
do 2 ilastrubis2=1,2
do i=ilastrubp2+1,nALightPoints(2)
ALightiphotolimit(i,2)=2*ilastrubis2-1
enddo
if(numALightcurves.eq.2)then
call FreeCombinatorial()
goto 2
endif
do ilastrubp3=nstartalight(3),nendalight(3)
do i=1,ilastrubp3
ALightiphotolimit(i,3)=2
enddo
do 3 ilastrubis3=1,2
do i=ilastrubp3+1,nALightPoints(3)
ALightiphotolimit(i,3)=2*ilastrubis3-1
enddo
if(numALightcurves.eq.3)then
call FreeCombinatorial()
goto 3
endif
do ilastrubp4=nstartalight(4),nendalight(4)
do i=1,ilastrubp4
ALightiphotolimit(i,4)=2
enddo
do 4 ilastrubis4=1,2
do i=ilastrubp4+1,nALightPoints(4)
ALightiphotolimit(i,4)=2*ilastrubis4-1
enddo
if(numALightcurves.eq.4)then
call FreeCombinatorial()
goto 4
endif
do ilastrubp5=nstartalight(5),nendalight(5)
do i=1,ilastrubp5
ALightiphotolimit(i,5)=2
enddo
do 5 ilastrubis5=1,2
do i=ilastrubp5+1,nALightPoints(5)
ALightiphotolimit(i,5)=2*ilastrubis5-1
enddo
if(numALightcurves.eq.5)then
call FreeCombinatorial()
goto 5
endif
do ilastrubp6=nstartalight(6),nendalight(6)
do i=1,ilastrubp6
ALightiphotolimit(i,6)=2
enddo
do 6 ilastrubis6=1,2
do i=ilastrubp6+1,nALightPoints(6)
ALightiphotolimit(i,6)=2*ilastrubis6-1
enddo
if(numALightcurves.eq.6)then
call FreeCombinatorial()
goto 6
endif
do ilastrubp7=nstartalight(7),nendalight(7)
do i=1,ilastrubp7
ALightiphotolimit(i,7)=2
enddo
do 7 ilastrubis7=1,2
do i=ilastrubp7+1,nALightPoints(7)
ALightiphotolimit(i,7)=2*ilastrubis7-1
enddo
if(numALightcurves.eq.7)then
call FreeCombinatorial()
goto 7
endif
do ilastrubp8=nstartalight(8),nendalight(8)
do i=1,ilastrubp8
ALightiphotolimit(i,8)=2
enddo
do 8 ilastrubis8=1,2
do i=ilastrubp8+1,nALightPoints(8)
ALightiphotolimit(i,8)=2*ilastrubis8-1
enddo
if(numALightcurves.eq.8)then
call FreeCombinatorial()
goto 8
endif
do ilastrubp9=nstartalight(9),nendalight(9)
do i=1,ilastrubp9
ALightiphotolimit(i,9)=2
enddo
do 9 ilastrubis9=1,2
do i=ilastrubp9+1,nALightPoints(9)
ALightiphotolimit(i,9)=2*ilastrubis9-1
enddo
if(numALightcurves.eq.9)then
call FreeCombinatorial()
goto 9
endif
do ilastrubp10=nstartalight(10),nendalight(10)
do i=1,ilastrubp10
ALightiphotolimit(i,10)=2
enddo
do 10 ilastrubis10=1,2
do i=ilastrubp10+1,nALightPoints(10)
ALightiphotolimit(i,10)=2*ilastrubis10-1
enddo
if(numALightcurves.eq.10)then
call FreeCombinatorial()
goto 10
endif
do ilastrubp11=nstartalight(11),nendalight(11)
do i=1,ilastrubp11
ALightiphotolimit(i,11)=2
enddo
do 11 ilastrubis11=1,2
do i=ilastrubp11+1,nALightPoints(11)
ALightiphotolimit(i,11)=2*ilastrubis11-1
enddo
if(numALightcurves.eq.11)then
call FreeCombinatorial()
goto 11
endif
do ilastrubp12=nstartalight(12),nendalight(12)
do i=1,ilastrubp12
ALightiphotolimit(i,12)=2
enddo
do 12 ilastrubis12=1,2
do i=ilastrubp12+1,nALightPoints(12)
ALightiphotolimit(i,12)=2*ilastrubis12-1
enddo
if(numALightcurves.eq.12)then
call FreeCombinatorial()
goto 12
endif
do ilastrubp13=nstartalight(13),nendalight(13)
do i=1,ilastrubp13
ALightiphotolimit(i,13)=2
enddo
do 13 ilastrubis13=1,2
do i=ilastrubp13+1,nALightPoints(13)
ALightiphotolimit(i,13)=2*ilastrubis13-1
enddo
if(numALightcurves.eq.13)then
call FreeCombinatorial()
goto 13
endif
do ilastrubp14=nstartalight(14),nendalight(14)
do i=1,ilastrubp14
ALightiphotolimit(i,14)=2
enddo
do 14 ilastrubis14=1,2
do i=ilastrubp14+1,nALightPoints(14)
ALightiphotolimit(i,14)=2*ilastrubis14-1
enddo
if(numALightcurves.eq.14)then
call FreeCombinatorial()
goto 14
endif
do ilastrubp15=nstartalight(15),nendalight(15)
do i=1,ilastrubp15
ALightiphotolimit(i,15)=2
enddo
do 15 ilastrubis15=1,2
do i=ilastrubp15+1,nALightPoints(15)
ALightiphotolimit(i,15)=2*ilastrubis15-1
enddo
if(numALightcurves.eq.15)then
call FreeCombinatorial()
goto 15
endif
15 continue
enddo
14 continue
enddo
13 continue
enddo
12 continue
enddo
11 continue
enddo
10 continue
enddo
9 continue
enddo
8 continue
enddo
7 continue
enddo
6 continue
enddo
5 continue
enddo
4 continue
enddo
3 continue
enddo
2 continue
enddo
1 continue
enddo
return
end subroutine sim_ALightCombinatorial
leafres/testarea/stom_regression.f
+331
View File
@@ -0,0 +1,331 @@
!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
!
subroutine StomRegression(npoints,istommodel,pco2s,
& rehulfsurf,gammas,assim_net,gswmeas,
& stomintercept,stomslope,pvapordef_s,rayDzero)
implicit none
c
C ODRPACK ARGUMENT DEFINITIONS
C ==> FCN NAME OF THE USER SUPPLIED FUNCTION SUBROUTINE
C ==> N NUMBER OF OBSERVATIONS
C ==> M COLUMNS OF DATA IN THE EXPLANATORY VARIABLE
C ==> NP NUMBER OF PARAMETERS
C ==> NQ NUMBER OF RESPONSES PER OBSERVATION
C <==> BETA FUNCTION PARAMETERS
C ==> Y RESPONSE VARIABLE
C ==> LDY LEADING DIMENSION OF ARRAY Y
C ==> X EXPLANATORY VARIABLE
C ==> LDX LEADING DIMENSION OF ARRAY X
C ==> WE "EPSILON" WEIGHTS
C ==> LDWE LEADING DIMENSION OF ARRAY WE
C ==> LD2WE SECOND DIMENSION OF ARRAY WE
C ==> WD "DELTA" WEIGHTS
C ==> LDWD LEADING DIMENSION OF ARRAY WD
C ==> LD2WD SECOND DIMENSION OF ARRAY WD
C ==> IFIXB INDICATORS FOR "FIXING" PARAMETERS (BETA)
C ==> IFIXX INDICATORS FOR "FIXING" EXPLANATORY VARIABLE (X)
C ==> LDIFX LEADING DIMENSION OF ARRAY IFIXX
C ==> JOB TASK TO BE PERFORMED
C ==> NDIGIT GOOD DIGITS IN SUBROUTINE FUNCTION RESULTS
C ==> TAUFAC TRUST REGION INITIALIZATION FACTOR
C ==> SSTOL SUM OF SQUARES CONVERGENCE CRITERION
C ==> PARTOL PARAMETER CONVERGENCE CRITERION
C ==> MAXIT MAXIMUM NUMBER OF ITERATIONS
C ==> IPRINT PRINT CONTROL
C ==> LUNERR LOGICAL UNIT FOR ERROR REPORTS
C ==> LUNRPT LOGICAL UNIT FOR COMPUTATION REPORTS
C ==> STPB STEP SIZES FOR FINITE DIFFERENCE DERIVATIVES WRT BETA
C ==> STPD STEP SIZES FOR FINITE DIFFERENCE DERIVATIVES WRT DELTA
C ==> LDSTPD LEADING DIMENSION OF ARRAY STPD
C ==> SCLB SCALE VALUES FOR PARAMETERS BETA
C ==> SCLD SCALE VALUES FOR ERRORS DELTA IN EXPLANATORY VARIABLE
C ==> LDSCLD LEADING DIMENSION OF ARRAY SCLD
C <==> WORK DOUBLE PRECISION WORK VECTOR
C ==> LWORK DIMENSION OF VECTOR WORK
C <== IWORK INTEGER WORK VECTOR
C ==> LIWORK DIMENSION OF VECTOR IWORK
C <== INFO STOPPING CONDITION
C PARAMETERS SPECIFYING MAXIMUM PROBLEM SIZES HANDLED BY THIS DRIVER
C MAXN MAXIMUM NUMBER OF OBSERVATIONS
C MAXM MAXIMUM NUMBER OF COLUMNS IN EXPLANATORY VARIABLE
C MAXNP MAXIMUM NUMBER OF FUNCTION PARAMETERS
C MAXNQ MAXIMUM NUMBER OF RESPONSES PER OBSERVATION
C PARAMETER DECLARATIONS AND SPECIFICATIONS
INTEGER LDIFX,LDSCLD,LDSTPD,LDWD,LDWE,LDX,LDY,LD2WD,LD2WE,
+ LIWORK,LWORK,MAXM,MAXN,MAXNP,MAXNQ
PARAMETER (MAXM=25,MAXN=10000,MAXNP=30,MAXNQ=1,
+ LDY=MAXN,LDX=MAXN,
+ LDWE=1,LD2WE=1,LDWD=1,LD2WD=1,
+ LDIFX=MAXN,LDSTPD=1,LDSCLD=1,
+ LWORK=18 + 11*MAXNP + MAXNP**2 + MAXM + MAXM**2 +
+ 4*MAXN*MAXNQ + 6*MAXN*MAXM + 2*MAXN*MAXNQ*MAXNP +
+ 2*MAXN*MAXNQ*MAXM + MAXNQ**2 +
+ 5*MAXNQ + MAXNQ*(MAXNP+MAXM) + LDWE*LD2WE*MAXNQ,
+ LIWORK=20+MAXNP+MAXNQ*(MAXNP+MAXM))
C VARIABLE DECLARATIONS
INTEGER I,INFO,IPRINT,J,JOB,L,LUNERR,LUNRPT,M,MAXIT,N,
+ NDIGIT,NP,NQ
INTEGER IFIXB(MAXNP),IFIXX(LDIFX,MAXM),IWORK(LIWORK)
DOUBLE PRECISION PARTOL,SSTOL,TAUFAC
DOUBLE PRECISION BETA(MAXNP),SCLB(MAXNP),SCLD(LDSCLD,MAXM),
+ STPB(MAXNP),STPD(LDSTPD,MAXM),
+ WD(LDWD,LD2WD,MAXM),WE(LDWE,LD2WE,MAXNQ),
+ WORK(LWORK),X(LDX,MAXM),Y(LDY,MAXNQ)
c
integer npoints,istommodel,istommodel0,i1,i2,i3,i4,i5
double precision pco2s(npoints),gswmeas(npoints),
& rehulfsurf(npoints),gammas(npoints),
& assim_net(npoints),pvapordef_s(npoints),stomintercept,
& stomslope,rayDzero
common /stommodelindicator/istommodel0
EXTERNAL STOMFCN
c
C SPECIFY DEFAULT VALUES FOR DODRC ARGUMENTS
WE(1,1,1) = -1.0D0
WD(1,1,1) = -1.0D0
IFIXB(1) = -1
! IFIXX(1,1) = -1
! JOB = 00023
JOB=23
NDIGIT = -1
TAUFAC = -1.0D0
SSTOL = -1.0D0
PARTOL = -1.0D0
MAXIT = -1
! IPRINT = -1
IPRINT=0
LUNERR = -1
LUNRPT = -1
STPB(1) = -1.0D0
STPD(1,1) = -1.0D0
SCLB(1) = -1.0D0
SCLD(1,1) = -1.0D0
MAXIT = 200000
C SET UP ODRPACK REPORT FILES
LUNERR = 9
LUNRPT = 9
c
N=npoints
istommodel0=istommodel
BETA(1)=stomintercept
BETA(2)=stomslope
do I=1,N
X(I,1)=assim_net(I)
Y(I,1)=gswmeas(I)
enddo
if(istommodel0.eq.1)then
! Ball-Berry
NP=2
M=3
do I=1,N
X(I,2)=pco2s(I)
X(I,3)=rehulfsurf(I)
enddo
endif
if(istommodel0.eq.2)then
! Leuning with leaf surface co2
NP=3
BETA(3)=rayDzero
M=4
do I=1,N
X(I,2)=pco2s(I)
X(I,3)=gammas(I)
X(I,4)=pvapordef_s(I)
enddo
endif
if(istommodel0.eq.3)then
! Belinda Medlyn model
NP=2
M=3
do I=1,N
X(I,2)=pco2s(I)
X(I,3)=pvapordef_s(I)
enddo
endif
if(istommodel0.eq.4)then
! Dewar model
NP=3
BETA(3)=rayDzero
M=3
do I=1,N
X(I,2)=pco2s(I)
X(I,3)=pvapordef_s(I)
enddo
endif
NQ=1
C READ PROBLEM DATA, AND SET NONDEFAULT VALUE FOR ARGUMENT IFIXX
DO 10 I=1,N
DO 15 J=1, M
IFIXX(I,J) = 1
15 CONTINUE
10 CONTINUE
60 CALL DODRC(STOMFCN,
+ N,M,NP,NQ,
+ BETA,
+ Y,LDY,X,LDX,
+ WE,LDWE,LD2WE,WD,LDWD,LD2WD,
+ IFIXB,IFIXX,LDIFX,
+ JOB,NDIGIT,TAUFAC,
+ SSTOL,PARTOL,MAXIT,
+ IPRINT,LUNERR,LUNRPT,
+ STPB,STPD,LDSTPD,
+ SCLB,SCLD,LDSCLD,
+ WORK,LWORK,IWORK,LIWORK,
+ INFO)
i1=mod(INFO,10)
i2=(mod(INFO,100)-i1)/10
i3=(mod(INFO,1000)-mod(INFO,100))/100
i4=(mod(INFO,10000)-mod(INFO,1000))/1000
i5=(INFO-mod(INFO,10000))/10000
stomintercept=BETA(1)
stomslope=BETA(2)
if(istommodel0.eq.2.or.istommodel0.eq.4)RayDzero=BETA(3)
return
END
c
SUBROUTINE STOMFCN(N,M,NP,NQ,
+ LDN,LDM,LDNP,
+ BETA,XPLUSD,
+ IFIXB,IFIXX,LDIFX,
+ IDEVAL,F,FJACB,FJACD,
+ ISTOP)
implicit none
C SUBROUTINE ARGUMENTS
C ==> N NUMBER OF OBSERVATIONS
C ==> M NUMBER OF COLUMNS IN EXPLANATORY VARIABLE
C ==> NP NUMBER OF PARAMETERS
C ==> NQ NUMBER OF RESPONSES PER OBSERVATION
C ==> LDN LEADING DIMENSION DECLARATOR EQUAL OR EXCEEDING N
C ==> LDM LEADING DIMENSION DECLARATOR EQUAL OR EXCEEDING M
C ==> LDNP LEADING DIMENSION DECLARATOR EQUAL OR EXCEEDING NP
C ==> BETA CURRENT VALUES OF PARAMETERS
C ==> XPLUSD CURRENT VALUE OF EXPLANATORY VARIABLE, I.E., X + DELTA
C ==> IFIXB INDICATORS FOR "FIXING" PARAMETERS (BETA)
C ==> IFIXX INDICATORS FOR "FIXING" EXPLANATORY VARIABLE (X)
C ==> LDIFX LEADING DIMENSION OF ARRAY IFIXX
C ==> IDEVAL INDICATOR FOR SELECTING COMPUTATION TO BE PERFORMED
C <== F PREDICTED FUNCTION VALUES
C <== FJACB JACOBIAN WITH RESPECT TO BETA
C <== FJACD JACOBIAN WITH RESPECT TO ERRORS DELTA
C <== ISTOP STOPPING CONDITION, WHERE
C 0 MEANS CURRENT BETA AND X+DELTA WERE
C ACCEPTABLE AND VALUES WERE COMPUTED SUCCESSFULLY
C 1 MEANS CURRENT BETA AND X+DELTA ARE
C NOT ACCEPTABLE; ODRPACK SHOULD SELECT VALUES
C CLOSER TO MOST RECENTLY USED VALUES IF POSSIBLE
C -1 MEANS CURRENT BETA AND X+DELTA ARE
C NOT ACCEPTABLE; ODRPACK SHOULD STOP
C INPUT ARGUMENTS, NOT TO BE CHANGED BY THIS ROUTINE:
INTEGER I,IDEVAL,ISTOP,L,LDIFX,LDM,LDN,LDNP,M,N,NP,NQ
DOUBLE PRECISION BETA(NP+1),XPLUSD(LDN,M)
INTEGER IFIXB(NP+1),IFIXX(LDIFX,M)
C OUTPUT ARGUMENTS:
DOUBLE PRECISION F(LDN,NQ),FJACB(LDN,LDNP,NQ),FJACD(LDN,LDM,NQ)
integer istommodel0
common /stommodelindicator/istommodel0
double precision pco2s,rehulfsurf,gammas,
& pvapordef_s,rayDzero,assim_net,stomintercept,
& stomslope,gswmod,derivb,derivslope,derivd0
C CHECK FOR UNACCEPTABLE VALUES FOR THIS PROBLEM
c
do I=1,NP
if(BETA(I).lt.0.0d0)then
ISTOP = 1
RETURN
endif
enddo
!
IF (MOD(IDEVAL,10).GE.1) THEN
DO 110 L = 1,NQ
DO 100 I = 1,N
stomintercept=BETA(1)
stomslope=BETA(2)
assim_net=XPLUSD(I,1)
if(istommodel0.eq.1)then
! Ball-Berry
pco2s=XPLUSD(I,2)
rehulfsurf=XPLUSD(I,3)
endif
if(istommodel0.eq.2)then
! Leuning with leaf surface co2
RayDzero=BETA(3)
pco2s=XPLUSD(I,2)
gammas=XPLUSD(I,3)
pvapordef_s=XPLUSD(I,4)
endif
if(istommodel0.eq.3)then
! Belinda Medlyn with leaf surface co2
pco2s=XPLUSD(I,2)
pvapordef_s=XPLUSD(I,3)
endif
if(istommodel0.eq.4)then
! dewar with leaf surface co2
RayDzero=BETA(3)
pco2s=XPLUSD(I,2)
pvapordef_s=XPLUSD(I,3)
endif
call StomatalConductance(pco2s,rehulfsurf,gammas,
& pvapordef_s,rayDzero,assim_net,istommodel0,
& stomintercept,stomslope,gswmod)
F(I,L)=gswmod
100 CONTINUE
110 CONTINUE
END IF
C COMPUTE DERIVATIVES WITH RESPECT TO BETA
IF (MOD(IDEVAL/10,10).GE.1) THEN
DO 210 L = 1,NQ
DO 200 I = 1,N
stomintercept=BETA(1)
stomslope=BETA(2)
assim_net=XPLUSD(I,1)
if(istommodel0.eq.1)then
! Ball-Berry
pco2s=XPLUSD(I,2)
rehulfsurf=XPLUSD(I,3)
endif
if(istommodel0.eq.2)then
! Leuning with leaf surface co2
RayDzero=BETA(3)
pco2s=XPLUSD(I,2)
gammas=XPLUSD(I,3)
pvapordef_s=XPLUSD(I,4)
endif
if(istommodel0.eq.3)then
! Belinda Medlyn model
pco2s=XPLUSD(I,2)
pvapordef_s=XPLUSD(I,3)
endif
if(istommodel0.eq.4)then
! Dewar model
RayDzero=BETA(3)
pco2s=XPLUSD(I,2)
pvapordef_s=XPLUSD(I,3)
endif
call Der_StomatalConductance(pco2s,rehulfsurf,gammas,
& pvapordef_s,rayDzero,assim_net,istommodel0,
& stomintercept,stomslope,derivb,derivslope,derivd0)
FJACB(I,1,L)=derivb
FJACB(I,2,L)=derivslope
if(istommodel0.eq.2.or.istommodel0.eq.4)FJACB(I,3,L)=derivd0
200 CONTINUE
210 CONTINUE
END IF
RETURN
END
!$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
leafres/testarea/stomlfitbasis.f
+12
View File
@@ -0,0 +1,12 @@
subroutine lfitbasisfuncs(x,afunc,ma)
implicit none
integer ma
double precision x,afunc(ma)
afunc(1)=1.0d0
afunc(2)=x
if(ma.gt.2)then
afunc(3)=x*x/1000.0d0
endif
return
end
leafres/testarea/stomoptim.h
+16
View File
@@ -0,0 +1,16 @@
! used for the stomatal optimization block
integer maxdimobs
parameter(maxdimobs=200)
double precision xpco2i(maxdimobs),pco2s(maxdimobs),
& rehulfsurf(maxdimobs),gammas(maxdimobs),pres_air(maxdimobs),
& assim_net(maxdimobs),gswmeas(maxdimobs),pvapordef_s(maxdimobs),
& bmin(10),bmax(10)
common /stomvariables/xpco2i,pco2s,rehulfsurf,gammas,
& pres_air,assim_net,gswmeas,pvapordef_s,bmin,bmax
integer istommodel,nobs
common /stomindices/istommodel,nobs
!-------- End of list of common block variables ------------------
leafres/testarea/stomoptimization.f
+69
View File
@@ -0,0 +1,69 @@
!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
subroutine stomoptimization(npoints,ioption,pco2s0,rehulfsurf0,
&gammas0,yAnet0,gswmeas0,stomintercept,stomslope,pvapordef_s0,
&rayDzero)
implicit none
include '../testarea/stomoptim.h'
c
integer npoints,ioption
double precision pco2s0(npoints),rehulfsurf0(npoints),
&gammas0(npoints),yAnet0(npoints),gswmeas0(npoints),
&pvapordef_s0(npoints),stomintercept,stomslope,rayDzero
integer i,ndim
double precision beta(10),fatbeta,ftol
parameter(ftol=1.0d-7)
external funkmin_stom,f1dim_stom
istommodel=ioption
nobs = npoints
do i=1,npoints
pco2s(i)=pco2s0(i)
rehulfsurf(i)=rehulfsurf0(i)
gammas(i)=gammas0(i)
assim_net(i)=yAnet0(i)
gswmeas(i)=gswmeas0(i)
pvapordef_s(i)=pvapordef_s0(i)
enddo
ndim=2
beta(1)=stomintercept
bmin(1)=0.0d0
bmax(1)=1.0d+7
if(stomintercept.lt.bmin(1).or.stomintercept.gt.bmax(1))
&beta(1)=0.001d0
beta(2)=stomslope
bmin(2)=0.0d0
bmax(2)=1.0d+8
if(stomslope.lt.bmin(2).or.stomslope.gt.bmax(2))
&beta(2)=10.0d0
if(istommodel.eq.1.or.istommodel.eq.3)then
ndim=2
endif
if(istommodel.eq.2.or.istommodel.eq.4)then
ndim=3
beta(3)=rayDzero
bmin(3)=0.00001d0
bmax(3)=1.0d+8
if(rayDzero.lt.bmin(3).or.rayDzero.gt.bmax(3))
&beta(3)=2000.0d0
endif
!
! Initialize the cost function evaluation counter in the subroutine funkmin.
! The counter counts and memorizes points where the cost function is evaluated.
call funkmin_stom(ndim,beta,fatbeta)
call nongradopt(ndim,funkmin_stom,f1dim_stom,beta,
& bmin,bmax,ftol,fatbeta)
call RepeatCompassSearch(ndim,beta,fatbeta,bmin,
& bmax,funkmin_stom,f1dim_stom,ftol)
! Replace these parameters with their optimized values
stomintercept=beta(1)
stomslope=beta(2)
if(istommodel.eq.2.or.istommodel.eq.4)rayDzero=beta(3)
return
END subroutine stomoptimization
c
!$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
leafres/testarea/surffunc.f
+227
View File
@@ -0,0 +1,227 @@
subroutine surffunc(nyvars,yvars,nxvars,
& xvars,ndim,beta,dydxp,idowhat)
implicit none
!idowhat=0, value of the function only
!idowhat=1, derivative with respect to the independent variable x
!idowhat=2, derivative with respect to the parameters
integer nyvars,nxvars,ndim,idowhat
double precision yvars(nyvars),xvars(nxvars),
&beta(5),dydxp(nyvars,(nxvars+5))
!-------------------------------------------------------
double precision y0,a,b,c,x0,x,term,crit
parameter(crit=300.0d0)
a=beta(1)
b=beta(2)
c=beta(3)
x=xvars(1)
if(ndim.eq.3)then
term=dexp(-b*x)
if(idowhat.eq.0)yvars(1)=c+a*(1.0d0-term)
if(idowhat.eq.1)then
dydxp(1,1)=a*b*term
endif
if(idowhat.eq.2)then
dydxp(1,1)=1.0d0-term
dydxp(1,2)=a*x*term
dydxp(1,3)=1.0d0
endif
return
endif
if(ndim.eq.4)then
x0=beta(4)
if(idowhat.eq.0)yvars(1)=a*(1.0d0-b*x)*(x-x0)/(1.0d0+c*x)
if(idowhat.eq.1)then
dydxp(1,1)=a*(1.0d0-2.0d0*b*x-b*c*x*x+(b+c)*x0)/
&((1.0d0+c*x)*(1.0d0+c*x))
endif
if(idowhat.eq.2)then
dydxp(1,1)=(1.0d0-b*x)*(x-x0)/(1.0d0+c*x)
dydxp(1,2)=a*(1.0d0-x)*(x-x0)/(1.0d0+c*x)
dydxp(1,3)=-a*(1.0d0-b*x)*(x-x0)*x/((1.0d0+c*x)*(1.0d0+c*x))
dydxp(1,4)=-a*(1.0d0-b*x)/(1.0d0+c*x)
endif
return
endif
! if(ndim.eq.3)then
! yvars(1)=(1.0d0+a*x)/(b+c*x)
! if(idowhat.eq.0)return
! if(idowhat.eq.1)then
! dydxp(1,1)=(a-yvars(1)*c)/(b+c*x)
! return
! endif
! if(idowhat.eq.2)then
! dydxp(1,1)=x/(b+c*x)
! dydxp(1,2)=-yvars(1)/(b+c*x)
! dydxp(1,3)=-yvars(1)*dydxp(1,1)
! return
! endif
! endif
!A/Ci or A/PAR curves
x0=beta(4)
y0=beta(5)
if(idowhat.eq.0)then
if((-(x-x0)/b).lt.crit)then
term=dexp(-(x-x0)/b)
yvars(1)=y0+a*(1.0d0/(1.0d0+term))**c
else
term=dexp((x-x0)/b)
yvars(1)=y0+a*(term/(1.0d0+term))**c
endif
endif
if(idowhat.eq.1)then
if((-(x-x0)/b).lt.crit)then
term=dexp(-(x-x0)/b)
dydxp(1,1)=(a*c*term/b)*
& (1.0d0/(1.0d0+term))**(1.0d0+c)
else
term=(x-x0)/b
dydxp(1,1)=(a*c/b)*(dexp(term*c/(c+1.0d0))/
& (1.0d0+dexp(term)))**(c+1.0d0)
endif
endif
if(idowhat.eq.2)then
dydxp(1,5)=1.0d0
if((-(x-x0)/b).lt.crit)then
term=dexp(-(x-x0)/b)
dydxp(1,1)=(1.0d0/(1.0d0+term))**c
dydxp(1,4)=-(a*c*term/b)*
& (1.0d0/(1.0d0+term))**(1.0d0+c)
dydxp(1,2)=-(a*c*term*(x-x0)/(b*b))*
& (1.0d0/(1.0d0+term))**(1.0d0+c)
dydxp(1,3)=-(a*dlog(1.0d0+term))*
& (1.0d0/(1.0d0+term))**c
else
term=(x-x0)/b
dydxp(1,1)=(dexp(term)/(1.0d0+dexp(term)))**c
dydxp(1,4)=-(a*c/b)*(dexp(term*c/(c+1))/
& (1.0d0+dexp(term)))**(c+1.0d0)
dydxp(1,2)=-(a*c*(x-x0)/(b*b))*(dexp(term*c/
& (c+1.0d0))/(1.0d0+dexp(term)))**(1.0d0+c)
dydxp(1,3)=-a*(dlog(1.0d0+dexp(term))-term)*
& (dexp(term)/(1.0d0+dexp(term)))**c
endif
endif
return
end
!==========================================================
subroutine properties_surffunc(ndim,beta,root,der_root,fmax,
&yinter,der_yinter,agivenx,der_agivenx,funcval_agivenx,
&xmin,xmax,curvatmax,xcurvatmax)
implicit none
integer ndim
double precision beta(5),root,der_root,fmax,yinter,der_yinter,
&agivenx,der_agivenx,funcval_agivenx,xmin,xmax,curvatmax,xcurvatmax
double precision a,b,c,x0,y0,term,term1,term2,term3,step,
&deratx,der2atx
a=beta(1)
b=beta(2)
c=beta(3)
if(ndim.eq.3)then
!y=c+a(1-exp(-bx))
root=-dlog(1.0d0+c/a)/b
der_root=a*b*dexp(-b*root)
fmax=c+a
yinter=c
der_yinter=a*b
funcval_agivenx=c+a*(1.0d0-dexp(-b*agivenx))
der_agivenx=a*b*dexp(-b*agivenx)
xcurvatmax=dlog(2*a*a*b*b)/(2.0d0*b)
! curvatmax=-a*b*b*dexp(-b*xcurvatmax)/
! &((1.0d0+a*a*b*b*dexp(-2.0d0*b*xcurvatmax))**1.5d0)
curvatmax=-b*0.3849d0
curvatmax=dabs(curvatmax)*1000.0d0
return
endif
if(ndim.eq.4)then
!y=a*(1-bx)*(x-x0)/(1+c*x)
!we ignore the other root
!dydxp(1,1)=a*(1.0d0-2.0d0*b*x-b*c*x*x+(b+c)*x0)/((1.0d0+c*x)*(1.0d0+c*x))
x0=beta(4)
root=x0
der_root=a*(1.0d0-2.0d0*b*root-b*c*root*root+(b+c)*x0)/
&((1.0d0+c*root)*(1.0d0+c*root))
term=(dsqrt((b+c)*(1.0d0+c*x0)/b)-1.0d0)/c
fmax=a*(1.0d0-b*term)*(term-x0)/(1.0d0+c*term)
yinter=-a*x0
der_yinter=a*(1.0d0+(b+c)*x0)
funcval_agivenx=a*(1.0d0-b*agivenx)*(agivenx-x0)/
&(1.0d0+c*agivenx)
der_agivenx=
&a*(1.0d0-2.0d0*b*agivenx-b*c*agivenx*agivenx+(b+c)*x0)/
&((1.0d0+c*agivenx)*(1.0d0+c*agivenx))
xcurvatmax=-9999.0d0
curvatmax=-9999.0d0
return
endif
! if(ndim.eq.3)then
!y=(1+a*x)/(b+c*x)
! root=-1.0d0/a
! der_root=a/(b-c/a)
! fmax=a/c
! yinter=1.0d0/b
! der_yinter=(a*b-c)/(b*b)
! return
! endif
x0=beta(4)
y0=beta(5)
if((-a/y0).gt.0.0d0)then
term=(-a/y0)**(1.0d0/c)-1.0d0
root=x0-b*dlog(term)
term=dexp(-(root-x0)/b)
der_root=(a*c*term/b)*(1.0d0/(1.0d0+term))**(1.0d0+c)
else
root=-9999.0d0
der_root=-9999.0d0
endif
fmax=a+y0
call surffunc(1,yinter,1,0.0d0,ndim,beta,term,0)
call surffunc(1,term,1,0.0d0,ndim,beta,der_yinter,1)
call surffunc(1,term,1,agivenx,ndim,beta,der_agivenx,1)
call surffunc(1,funcval_agivenx,1,agivenx,ndim,beta,term,0)
curvatmax=-9999.0d0
xcurvatmax=-9999.0d0
step=(xmax-xmin)/1000.0d0
do term=xmin,xmax,step
call surffunc(1,term1,1,term,ndim,beta,deratx,1)
term2=dexp(-(term-x0)/b)
der2atx=-deratx/b+
&(1.0d0+c)*deratx*deratx*((1.0d0+term2)**c)/(a*c)
term3=dabs(der2atx/((1.0d0+deratx*deratx)**1.5d0))
if(term3.gt.curvatmax)then
curvatmax=term3
xcurvatmax=term
endif
enddo
if(dabs(xcurvatmax-xmin).le.step.or.
&dabs(xcurvatmax-xmax).le.step)then
curvatmax=-9999.0d0
xcurvatmax=-9999.0d0
else
curvatmax=dabs(curvatmax)*1000.0d0
endif
return
end
!==========================================================
subroutine indices_surffunc(ndim,beta,root,
& der_root,fmax)
implicit none
integer ndim
double precision beta(ndim),root,der_root,fmax
double precision a,b,c,x0,y0,term
a=beta(1)
b=beta(2)
c=beta(3)
x0=beta(4)
y0=beta(5)
term=(-a/y0)**(1.0d0/c)-1.0d0
root=x0-b*dlog(term)
term=dexp(-(root-x0)/b)
der_root=(a*c*term/b)*(1.0d0/(1.0d0+term))**(1.0d0+c)
fmax=a+y0
return
end
leafres/testarea/time_resolution.f
+51
View File
@@ -0,0 +1,51 @@
subroutine time_resolution(npoints,sampletime,
& avetimeresolution,avetimesampled)
implicit none
integer npoints
double precision sampletime(npoints),
& avetimeresolution,avetimesampled
! sampletime: hour fraction
! avetimeresolution: minutes
! avetimesampled: hour fraction
integer i,j,nactual
double precision term,copy(npoints),temp,sum
nactual=0
do i=1,npoints
if(sampletime(i).gt.-9000.0d0)then
nactual=nactual+1
copy(nactual)=sampletime(i)
endif
enddo
if(nactual.eq.0)then
avetimeresolution=-9999.0d0
avetimesampled=-9999.0d0
return
endif
do i=1,nactual
do j=i,nactual
if(copy(j).lt.copy(i))then
temp=copy(i)
copy(i)=copy(j)
copy(j)=temp
endif
enddo
enddo
sum=copy(1)
avetimeresolution=0.0d0
do i=2,nactual
sum=sum+copy(i)
avetimeresolution=avetimeresolution+copy(i)-copy(i-1)
enddo
avetimesampled=sum/dble(nactual)
if(nactual.eq.1)then
avetimeresolution=-9999.0d0
else
avetimeresolution=60.0d0*
& avetimeresolution/dble(nactual-1)
endif
return
end
leafres/testarea/try.f
+6
View File
@@ -0,0 +1,6 @@
program try
integer i,k(5)
do 1 k(2)=1,3
1 continue
end
leafres/testrun/Makefile
+38
View File
@@ -0,0 +1,38 @@
# This is the makefile for piscal
# name of executable
ALL = mpipiscal
# compiler options
FF = mpif90
#FOPTS = -g -C
FOPTS = -g
#Base directory
BASEDIR = /home/piscaladmin
VPATH =$(BASEDIR)/leafres/testarea:\
$(BASEDIR)/dataassim/math/optimization:\
$(BASEDIR)/dataassim/math/othersupmath:\
$(BASEDIR)/dataassim/math/algebra:\
$(BASEDIR)/dataassim/math/specialfuncs:\
$(BASEDIR)/dataassim/math/nonlinsystems/
# Define objects
OBJS = LeafGasPISCAL_single.o adsor.o clustering.o cppowell.o GenericRegres.o lfit.o stomoptimization.o ALightCombinatorial.o commonparameters.o\
dble_pikaia.o HybridCombinatorial.o powell.o stom_regression.o Anet_Final.o CompassSearch.o extCharToFloatNum.o ilimittypestats.o\
SetUpLeafGasFit.o bookkeeping.o cpbookkeeping.o Externals_GenericRegres.o ispartnum.o shortestdist.o supmath.o\
broydn.o cpbroydn.o fixedpoint.o leafanetmodel.o nongradopt.o sigmoid.o surffunc.o charlineparser.o cpCompassSearch.o FreeCombinatorial.o\
LeafGasFit_Stom.o nonsyssolver.o time_resolution.o CharToNumeric.o cpfixedpoint.o funkmin_cica5.o NumberToChar.o\
stdmaxmeanmin.o ToLeafGasOptimization.o cica5.o cpnongradopt.o funkmin_stom.o LeafGasPrintToFiles.o odr_leastsquare.o StomatalConductance.o\
UnivParamsAlloc.o cica_Regression5.o cpnonsyssolver.o funkmin_UnivPhotoFit.o leafunivphotosyn.o odrpack.o stomlfitbasis.o UnivPhotoFit.o\
fluorescencejmax.o funkmin_flujmax.o pam_parameters.o
$(ALL): $(OBJS)
$(FF) $(FOPTS) $(OBJS) -o $@
.f.o:
$(FF) -c $(FOPTS) $<
depend:
/usr/bin/X11/makedepend -- $(CFLAGS) -- $(SRCS)