subroutine funkmin_flujmax(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 double precision fjelect,thetaPSII !----------- 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 fjmax25=beta(1) phifactor=beta(2) thetafactor=beta(3) if(ndim.gt.3)ha_jmax=beta(4) fvalue=0.0d0 do i=1,ntotlights call jontemp(aparlights(i),templflights(i),fjelect,fjmax25, &ha_jmax,hd_jmax,sv_jmax,gascon,phifactor,thetafactor,betaPSII) if(aparlights(i).gt.0.0d0)then PhiPSIIlights_pred(i)=fjelect/(betaPSII*aparlights(i)) else call thetaphipsii(templflights(i),PhiPSIIlights_pred(i), &thetaPSII) PhiPSIIlights_pred(i)=PhiPSIIlights_pred(i)*phifactor endif fvalue=fvalue+ ! &(fjelect-betaPSII*flphips2lights(i)*aparlights(i))**2.0d0+ &(100.0d0*(PhiPSIIlights_pred(i)-flphips2lights(i)))**2.0d0 enddo return end subroutine funkmin_flujmax !$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ double precision function f1dim_flujmax(x) implicit none double precision x CU USES funkmin_flujmax 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_flujmax(ncom,xt,f1dim_flujmax) return END !&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& SUBROUTINE FCN_flujmax(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 aparlights(I)=XPLUSD(I,1) templflights(I)=XPLUSD(I,2) enddo IF (MOD(IDEVAL,10).GE.1) THEN call funkmin_flujmax(NP,BETA,fvalue) if(fvalue.gt.1.0d+20)then ISTOP=1 return endif DO 100 I = 1,N F(I,1)=PhiPSIIlights_pred(I) 100 CONTINUE END IF RETURN END !$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ double precision function flujmax_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_flujmax(ndim,beta,fvalue) flujmax_pikaia=1.0d0/(fvalue+0.00001d0) return end