129 lines
4.6 KiB
FortranFixed
129 lines
4.6 KiB
FortranFixed
subroutine funkmin_C4Fit(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
|
|
!----------- 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
|
|
vcmax25=beta(1)
|
|
c4aparslope=beta(2)
|
|
c4kp25=beta(3)
|
|
if(idord.eq.1)rdlight25=beta(ndim)
|
|
fvalue=0.0d0
|
|
do i=1,ntotsamples
|
|
call c4leafanetmodel(1,aPPFDlf(i),templeaf(i),pco2i(i),
|
|
&pres_air(i),vcmax25,c4aparslope,c4kp25,rdlight25,anet_pred(i),
|
|
&Postiphotolimit(i))
|
|
fvalue=fvalue+(anet_obs(i)-anet_pred(i))**2.0d0
|
|
enddo
|
|
return
|
|
end subroutine funkmin_C4Fit
|
|
!$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
|
|
double precision function f1dim_C4Fit(x)
|
|
implicit none
|
|
double precision x
|
|
CU USES funkmin_C4Fit
|
|
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_C4Fit(ncom,xt,f1dim_C4Fit)
|
|
return
|
|
END
|
|
!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
|
|
SUBROUTINE FCN_C4Fit(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)
|
|
pres_air(I)=XPLUSD(I,4)
|
|
enddo
|
|
IF (MOD(IDEVAL,10).GE.1) THEN
|
|
call funkmin_C4Fit(NP,BETA,fvalue)
|
|
if(fvalue.gt.1.0d+20)then
|
|
ISTOP=1
|
|
return
|
|
endif
|
|
DO 100 I = 1,N
|
|
F(I,1)=anet_pred(I)
|
|
100 CONTINUE
|
|
END IF
|
|
RETURN
|
|
END
|
|
!$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
|