Initial commit
This commit is contained in:
@@ -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
|
||||
Reference in New Issue
Block a user