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/fluorescencejmax.f
+276 -88
View File
@@ -3,11 +3,14 @@
implicit none
include '../testarea/LeafGasParams.h'
include '../testarea/LeafGasHybridFit.h'
integer i,ndim,k,j,iderivative,iwrong
integer i,ndim,k,j,iderivative,iwrong,n,icompete,i2,isitnaninf,
&nave
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
&xvar(maxobs,2),weitx(maxobs,2),weity(maxobs),
&templflights0(maxobs),aparlights0(maxobs),termmin,termmax,
&ftol_relax,term1,term2,ran2,discount,history(2000,10),upper,lower,
&f1dim_flujmax,flujmax_pikaia
parameter(ftol=1.0d-7,xtol=1.0d-7)
external funkmin_flujmax,f1dim_flujmax,FCN_flujmax,flujmax_pikaia
!beta(1)=fjmax25
@@ -65,104 +68,298 @@
call funkmin_flujmax(ndim,beta,flujmaxfval)
do i=1,ndim
beta0(i)=beta(i)
history(1,i)=beta(i)
enddo
sumsquare0=flujmaxfval
history(1,ndim+1)=flujmaxfval
!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.
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))
n=1
nave=1
ftol_relax=ftol*1000.0d0
discount=2.0d0
30 do i=1,ndim
betacp(i)=beta(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
sumsquarecp=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
if(isitnaninf(flujmaxfval).eq.1.or.flujmaxfval.gt.sumsquarecp)then
do i=1,ndim
beta(i)=betacp(i)
enddo
flujmaxfval=sumsquarecp
else
if(dabs(flujmaxfval).gt.1.0d+20)then
!in case of infinity (division by zero)
do i=1,ndim
betacp(i)=beta(i)
enddo
sumsquarecp=flujmaxfval
endif
call nongradopt(ndim,funkmin_flujmax,f1dim_flujmax,
&beta,betamin,betamax,ftol_relax,flujmaxfval)
if(isitnaninf(flujmaxfval).eq.1.or.flujmaxfval.gt.sumsquarecp)then
do i=1,ndim
beta(i)=betacp(i)
enddo
flujmaxfval=sumsquarecp
endif
if(flujmaxfval.gt.1.0d0)then
term1=flujmaxfval*ftol_relax
else
term1=ftol_relax*10.0d0
endif
if(flujmaxfval.gt.sumsquare0)then
!failure
if((flujmaxfval-sumsquare0).gt.term1)then
if(icompete.eq.1)history(1,ndim+3)=history(1,ndim+3)+1.5d0
!even though flujmaxfval 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)-flujmaxfval).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
beta(i)=beta0(i)
history(n,i)=beta(i)
enddo
flujmaxfval=sumsquare0
history(n,ndim+1)=flujmaxfval
history(n,ndim+2)=0.0d0
history(n,ndim+3)=0.0d0
!use average only when there is improvement
nave=n
else
!designed this way to avoid flujmaxfval='NAN'
!the difference is minimal even though flujmaxfval 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
k=k+1
endif
60 do i=1,ndim
beta(i)=beta0(i)
enddo
flujmaxfval=sumsquare0
else
!success
if((sumsquare0-flujmaxfval).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
k=k+1
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-flujmaxfval)/1000.0d0)
endif
k=0
n=n+1
do i=1,ndim
beta(i)=beta0(i)
history(n,i)=beta(i)
enddo
flujmaxfval=sumsquare0
history(n,ndim+1)=flujmaxfval
history(n,ndim+2)=0.0d0
history(n,ndim+3)=0.0d0
endif
do i=1,ndim
beta0(i)=beta(i)
enddo
sumsquare0=flujmaxfval
endif
j=j+1
if(j.lt.200.and.k.lt.3)then
!first explore around the very first initial guess
if(j.lt.10)then
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
icompete=1
goto 70
endif
!try average
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_flujmax(ndim,beta,flujmaxfval)
goto 30
else
if((ftol_relax-ftol).gt.ftol)then
if(k.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)=flujmaxfval
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_flujmax,f1dim_flujmax,ftol_relax)
call funkmin_flujmax(ndim,betacp,sumsquarecp)
if(isitnaninf(sumsquarecp).eq.0.and.sumsquarecp.lt.
&flujmaxfval)then
do icompete=1,ndim
beta(icompete)=betacp(icompete)
enddo
flujmaxfval=sumsquarecp
endif
enddo
do i=1,ndim
beta0(i)=beta(i)
enddo
sumsquare0=flujmaxfval
j=0
icompete=1
else
icompete=0
endif
ftol_relax=ftol
goto 30
endif
endif
j=0
100 if(j.ge.10)then
goto 110
call RepeatCompassSearch(ndim,beta,flujmaxfval,betamin,
&betamax,funkmin_flujmax,f1dim_flujmax,xtol)
call funkmin_flujmax(ndim,beta,flujmaxfval)
if(isitnaninf(flujmaxfval).eq.1.or.flujmaxfval.gt.sumsquare0)then
do i=1,ndim
betacp(i)=(beta(i)-betamin(i))/(betamax(i)-betamin(i))
beta(i)=beta0(i)
enddo
isitbounded=0
call pikaia(flujmax_pikaia,ndim,gacontrol,betacp,flujmaxfval,i)
flujmaxfval=sumsquare0
else
do i=1,ndim
beta(i)=betamin(i)+betacp(i)*(betamax(i)-betamin(i))
beta0(i)=beta(i)
enddo
isitbounded=1
call funkmin_flujmax(ndim,beta,flujmaxfval)
sumsquare0=flujmaxfval
endif
sumsquare0=flujmaxfval
do i=1,ndim
betacp(i)=(beta(i)-betamin(i))/(betamax(i)-betamin(i))
enddo
call pikaia(flujmax_pikaia,ndim,gacontrol,betacp,flujmaxfval,i)
if(i.eq.0)then
do i=1,ndim
betacp(i)=betamin(i)+betacp(i)*(betamax(i)-betamin(i))
enddo
call funkmin_flujmax(ndim,betacp,flujmaxfval)
if(isitnaninf(flujmaxfval).eq.0.and.flujmaxfval.lt.sumsquare0)
&then
do i=1,ndim
beta(i)=betacp(i)
beta0(i)=betacp(i)
enddo
sumsquare0=flujmaxfval
endif
endif
flujmaxfval=sumsquare0
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)
!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(isitnaninf(flujmaxfval).eq.1.or.flujmaxfval.gt.sumsquare0)then
do i=1,ndim
beta(i)=beta0(i)
enddo
flujmaxfval=sumsquare0
endif
j=0
100 sumsquare0=flujmaxfval
do i=1,ndim
beta0(i)=beta(i)
enddo
@@ -170,21 +367,11 @@
&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
if(isitnaninf(flujmaxfval).eq.1.or.flujmaxfval.gt.sumsquare0)then
do i=1,ndim
beta(i)=beta0(i)
enddo
flujmaxfval=sumsquare0
endif
sumsquarecp=flujmaxfval
do i=1,ndim
@@ -194,14 +381,15 @@
&betamax,funkmin_flujmax,f1dim_flujmax,xtol)
call funkmin_flujmax(ndim,betacp,sumsquarecp)
if(flujmaxfval.eq.sumsquarecp)return
if(dabs(sumsquarecp).lt.dabs(flujmaxfval))then
if(isitnaninf(sumsquarecp).eq.0.and.flujmaxfval.gt.sumsquarecp)
&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
if(j.le.2.and.(sumsquare0-flujmaxfval).gt.ftol)goto 100
!
!------------------------------------------------------
110 call funkmin_flujmax(ndim,beta,flujmaxfval)