!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& 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