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

New changes from l2g

Browse Source 
w
This commit is contained in:
poprhythm
2022-09-12 16:40:28 +00:00
parent 78eb7147d0
commit d713d4f61a
110 changed files with 87672 additions and 1098 deletions
Download Patch File Download Diff File Expand all files Collapse all files
leafres/testarea/UnivPhotoFit.f
+289 -116
View File
@@ -172,10 +172,12 @@
implicit none
include '../testarea/LeafGasParams.h'
include '../testarea/LeafGasHybridFit.h'
integer i,ndim,k,j,iderivative,iwrong,jnon
integer i,ndim,k,j,iderivative,iwrong,jnon,n,icompete,isame,i2,
&isitnaninf,nave
double precision beta(20),sumsquare0,beta0(20),sumsquarecp,
&betacp(20),ftol,xtol,shortx(maxobs,4),shorty(maxobs,2),ran2,
&ftol_relax
&betacp(20),ftol,xtol,shortx(maxobs,10),shorty(maxobs,5),
&ftol_relax,term1,term2,ran2,history(2000,25),discount,upper,lower,
&f1dim_UnivPhotoFit,ff_pikaia
parameter(ftol=1.0d-7,xtol=1.0d-7)
external funkmin_UnivPhotoFit,f1dim_UnivPhotoFit,
&FCN_UnivPhotoFit,ff_pikaia
@@ -193,113 +195,312 @@
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
!global search
do i=1,ndim
beta0(i)=beta(i)
history(1,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))
history(1,ndim+1)=sumsquare
!entrance counter
history(1,ndim+2)=1.0d0
!failure counter
history(1,ndim+3)=0.0d0
!Is it a competition among different initial guesses?
icompete=0
!j the total number of calls to nongradopt; k is the number of returns to the current best and reset
!to zero if a better minumum is found; n is the number of scouting points over the landscape of the cost function.
!The first initial guess provided by the user is always part of the set of scouting points.the rest consist of outcomes
!from calls to nongradopt if they are significantly different from the current best.
jnon=0
isame=0
n=1
nave=n
ftol_relax=ftol*1000.0d0
discount=2.0d0
!relax the convergence criterion for scouting
30 do i=1,ndim
betacp(i)=beta(i)
enddo
sumsquarecp=sumsquare
isitbounded=0
call pikaia(ff_pikaia,ndim,gacontrol,betacp,sumsquarecp,i)
isitbounded=1
if(i.eq.0)then
iderivative=0
if(ifitmode.lt.0)then
iwrong=0
else
iwrong=1
endif
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)
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(isitnaninf(sumsquare).eq.1.or.sumsquare.gt.sumsquarecp)then
do i=1,ndim
betacp(i)=betamin(i)+betacp(i)*(betamax(i)-betamin(i))
beta(i)=betacp(i)
enddo
call funkmin_UnivPhotoFit(ndim,betacp,sumsquarecp)
sumsquare=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
call nongradopt(ndim,funkmin_UnivPhotoFit,
&f1dim_UnivPhotoFit,beta,betamin,betamax,ftol_relax,sumsquare)
if(isitnaninf(sumsquare).eq.1.or.sumsquare.gt.sumsquarecp)then
do i=1,ndim
beta(i)=betacp(i)
enddo
sumsquare=sumsquarecp
endif
if(sumsquare.gt.1.0d0)then
term1=sumsquare*ftol_relax
else
term1=ftol_relax*10.0d0
endif
if(sumsquare.gt.sumsquare0)then
!failure
if((sumsquare-sumsquare0).gt.term1)then
if(icompete.eq.1)history(1,ndim+3)=history(1,ndim+3)+1.5d0
!even though sumsquare is much worse than sumsquare0, it is an output of optimization after all so
!include it in the set if it has not already been included in the set.
i=1
i2=1
40 if(dabs(history(i2,i)-beta(i)).gt.ftol_relax)then
if(dabs(history(i2,ndim+1)-sumsquare).lt.term1)then
history(i2,ndim+3)=history(i2,ndim+3)+1.0d0
goto 60
endif
if(i2.ge.n)goto 50
i2=i2+1
i=1
goto 40
else
if(i.ge.ndim)goto 60
i=i+1
goto 40
endif
50 n=n+1
do i=1,ndim
history(n,i)=beta(i)
enddo
history(n,ndim+1)=sumsquare
history(n,ndim+2)=0.0d0
history(n,ndim+3)=0.0d0
!use average only when there is imporvement
nave=n
else
!the difference is minimal even though sumsquare is larger than sumsquare0.
!Increment the counter for arriving at the same minimum.
if(icompete.eq.1)history(1,ndim+3)=history(1,ndim+3)+1.0d0
isame=isame+1
endif
60 do i=1,ndim
beta(i)=beta0(i)
enddo
sumsquare=sumsquare0
else
!success
if((sumsquare0-sumsquare).lt.term1)then
!negligible improvement. Increment the counter for arriving at the same minimum.
!no increment for the set of central initial guesses
if(icompete.eq.1)history(1,ndim+3)=history(1,ndim+3)+0.5d0
isame=isame+1
nave=n
else
!reset the counter for arriving at a better minimum.
!Increment the set of central initial guesses
if(dabs(discount-2.0d0).lt.ftol)then
discount=dmax1(0.001d0,(sumsquare0-sumsquare)/1000.0d0)
endif
isame=0
n=n+1
do i=1,ndim
history(n,i)=beta(i)
enddo
history(n,ndim+1)=sumsquare
history(n,ndim+2)=0.0d0
history(n,ndim+3)=0.0d0
endif
do i=1,ndim
beta0(i)=beta(i)
enddo
sumsquare0=sumsquare
endif
jnon=jnon+1
if(jnon.lt.200.and.isame.lt.3)then
!we first explore around the very first initial guess
if(jnon.lt.10)then
icompete=1
term1=0.05d0+dmin1(history(1,ndim+3)*0.1d0,0.9d0)
history(1,ndim+2)=history(1,ndim+2)+1.0d0
do i=1,ndim
lower=history(1,i)-term1*(history(1,i)-betamin(i))
upper=history(1,i)+term1*(betamax(i)-history(1,i))
beta(i)=lower+ran2()*(upper-lower)
enddo
goto 70
endif
!try average if n is incremented
if(n.gt.nave)then
term1=1.0d0/(history(1,ndim+1)+1.0d-5)
do i=2,n
term1=term1+1.0d0/(history(i,ndim+1)+1.0d-5)
enddo
do i=1,ndim
beta(i)=history(1,i)/(term1*(history(1,ndim+1)+1.0d-5))
do icompete=2,n
beta(i)=beta(i)+history(icompete,i)/
&(term1*(history(icompete,ndim+1)+1.0d-5))
enddo
enddo
nave=n
icompete=0
goto 70
endif
!try different initial guesses
if(ran2().gt.0.2d0)then
!guess around the best
icompete=1
term1=history(1,ndim+1)+
&discount*history(1,ndim+2)*history(1,ndim+3)
do i=2,n
term2=history(i,ndim+1)+
&discount*history(i,ndim+2)*history(i,ndim+3)
if(term2.le.term1)then
term1=term2
do i2=1,ndim+3
history(n+1,i2)=history(i,i2)
history(i,i2)=history(1,i2)
history(1,i2)=history(n+1,i2)
enddo
endif
enddo
term1=0.05d0+dmin1(history(1,ndim+2)*history(1,ndim+3)*
&0.015d0,0.9d0)
history(1,ndim+2)=history(1,ndim+2)+1.0d0
do i=1,ndim
lower=history(1,i)-term1*(history(1,i)-betamin(i))
upper=history(1,i)+term1*(betamax(i)-history(1,i))
beta(i)=lower+ran2()*(upper-lower)
enddo
else
!completely random guess
do i=1,ndim
beta(i)=betamin(i)+ran2()*(betamax(i)-betamin(i))
enddo
icompete=0
endif
70 call funkmin_UnivPhotoFit(ndim,beta,sumsquare)
goto 30
else
if((ftol_relax-ftol).gt.ftol)then
if(isame.le.1)then
n=n+1
do i=1,ndim+3
history(n,i)=history(1,i)
enddo
do i=1,ndim
history(1,i)=beta(i)
enddo
history(1,ndim+1)=sumsquare
history(1,ndim+2)=0.0d0
history(1,ndim+3)=0.0d0
do i=1,n
do icompete=1,ndim
betacp(icompete)=history(i,icompete)
enddo
sumsquarecp=history(i,ndim+1)
call RepeatCompassSearch(ndim,betacp,sumsquarecp,
&betamin,betamax,funkmin_UnivPhotoFit,f1dim_UnivPhotoFit,
&ftol_relax)
call funkmin_UnivPhotoFit(ndim,betacp,sumsquarecp)
if(isitnaninf(sumsquarecp).eq.0.and.sumsquarecp.lt.
&sumsquare)then
do icompete=1,ndim
beta(icompete)=betacp(icompete)
enddo
sumsquare=sumsquarecp
endif
enddo
do i=1,ndim
beta0(i)=beta(i)
enddo
sumsquare0=sumsquare
jnon=0
icompete=1
else
icompete=0
endif
ftol_relax=ftol
goto 30
endif
endif
goto 110
do i=1,ndim
beta0(i)=beta(i)
betacp(i)=(beta(i)-betamin(i))/(betamax(i)-betamin(i))
enddo
sumsquare0=sumsquare
sumsquarecp=sumsquare
call pikaia(ff_pikaia,ndim,gacontrol,betacp,sumsquarecp,i)
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)
if(isitnaninf(sumsquarecp).eq.0.and.sumsquare.gt.sumsquarecp)
&then
do i=1,ndim
beta(i)=betacp(i)
enddo
sumsquare=sumsquarecp
endif
endif
else
return
!local search
call nongradopt(ndim,funkmin_UnivPhotoFit,f1dim_UnivPhotoFit,
&beta,betamin,betamax,ftol,sumsquare)
call funkmin_UnivPhotoFit(ndim,beta,sumsquare)
endif
do i=1,ndim
beta0(i)=beta(i)
enddo
sumsquare0=sumsquare
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
@@ -322,7 +523,6 @@
&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
@@ -333,29 +533,12 @@
chlflphips2(i)=chlflphips2_ori(i)
enddo
call funkmin_UnivPhotoFit(ndim,beta,sumsquare)
if((sumsquare+1.0d0).eq.sumsquare.or.sumsquare.gt.sumsquare0)then
if(isitnaninf(sumsquare).eq.1.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
@@ -370,21 +553,11 @@
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
if(isitnaninf(sumsquare).eq.1.or.sumsquare.gt.sumsquare0)then
do i=1,ndim
beta(i)=beta0(i)
enddo
sumsquare=sumsquare0
endif
sumsquarecp=sumsquare
do i=1,ndim
@@ -394,14 +567,14 @@
&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
if(isitnaninf(sumsquarecp).eq.0.and.sumsquarecp.lt.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
if(j.le.2.and.(sumsquare0-sumsquare).gt.ftol)goto 100
!
!------------------------------------------------------
110 call funkmin_UnivPhotoFit(ndim,beta,sumsquare)