New changes from l2g

w

leafres/testarea/funkmin_C4Fit.f

@@ -0,0 +1,128 @@
+      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
+!$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$