!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& ! subroutine StomRegression(npoints,istommodel,pco2s, & rehulfsurf,gammas,assim_net,gswmeas, & stomintercept,stomslope,pvapordef_s,rayDzero) implicit none c C ODRPACK ARGUMENT DEFINITIONS C ==> FCN NAME OF THE USER SUPPLIED FUNCTION SUBROUTINE C ==> N NUMBER OF OBSERVATIONS C ==> M COLUMNS OF DATA IN THE EXPLANATORY VARIABLE C ==> NP NUMBER OF PARAMETERS C ==> NQ NUMBER OF RESPONSES PER OBSERVATION C <==> BETA FUNCTION PARAMETERS C ==> Y RESPONSE VARIABLE C ==> LDY LEADING DIMENSION OF ARRAY Y C ==> X EXPLANATORY VARIABLE C ==> LDX LEADING DIMENSION OF ARRAY X C ==> WE "EPSILON" WEIGHTS C ==> LDWE LEADING DIMENSION OF ARRAY WE C ==> LD2WE SECOND DIMENSION OF ARRAY WE C ==> WD "DELTA" WEIGHTS C ==> LDWD LEADING DIMENSION OF ARRAY WD C ==> LD2WD SECOND DIMENSION OF ARRAY WD C ==> IFIXB INDICATORS FOR "FIXING" PARAMETERS (BETA) C ==> IFIXX INDICATORS FOR "FIXING" EXPLANATORY VARIABLE (X) C ==> LDIFX LEADING DIMENSION OF ARRAY IFIXX C ==> JOB TASK TO BE PERFORMED C ==> NDIGIT GOOD DIGITS IN SUBROUTINE FUNCTION RESULTS C ==> TAUFAC TRUST REGION INITIALIZATION FACTOR C ==> SSTOL SUM OF SQUARES CONVERGENCE CRITERION C ==> PARTOL PARAMETER CONVERGENCE CRITERION C ==> MAXIT MAXIMUM NUMBER OF ITERATIONS C ==> IPRINT PRINT CONTROL C ==> LUNERR LOGICAL UNIT FOR ERROR REPORTS C ==> LUNRPT LOGICAL UNIT FOR COMPUTATION REPORTS C ==> STPB STEP SIZES FOR FINITE DIFFERENCE DERIVATIVES WRT BETA C ==> STPD STEP SIZES FOR FINITE DIFFERENCE DERIVATIVES WRT DELTA C ==> LDSTPD LEADING DIMENSION OF ARRAY STPD C ==> SCLB SCALE VALUES FOR PARAMETERS BETA C ==> SCLD SCALE VALUES FOR ERRORS DELTA IN EXPLANATORY VARIABLE C ==> LDSCLD LEADING DIMENSION OF ARRAY SCLD C <==> WORK DOUBLE PRECISION WORK VECTOR C ==> LWORK DIMENSION OF VECTOR WORK C <== IWORK INTEGER WORK VECTOR C ==> LIWORK DIMENSION OF VECTOR IWORK C <== INFO STOPPING CONDITION C PARAMETERS SPECIFYING MAXIMUM PROBLEM SIZES HANDLED BY THIS DRIVER C MAXN MAXIMUM NUMBER OF OBSERVATIONS C MAXM MAXIMUM NUMBER OF COLUMNS IN EXPLANATORY VARIABLE C MAXNP MAXIMUM NUMBER OF FUNCTION PARAMETERS C MAXNQ MAXIMUM NUMBER OF RESPONSES PER OBSERVATION C PARAMETER DECLARATIONS AND SPECIFICATIONS INTEGER LDIFX,LDSCLD,LDSTPD,LDWD,LDWE,LDX,LDY,LD2WD,LD2WE, + LIWORK,LWORK,MAXM,MAXN,MAXNP,MAXNQ PARAMETER (MAXM=25,MAXN=10000,MAXNP=30,MAXNQ=1, + LDY=MAXN,LDX=MAXN, + LDWE=1,LD2WE=1,LDWD=1,LD2WD=1, + LDIFX=MAXN,LDSTPD=1,LDSCLD=1, + LWORK=18 + 11*MAXNP + MAXNP**2 + MAXM + MAXM**2 + + 4*MAXN*MAXNQ + 6*MAXN*MAXM + 2*MAXN*MAXNQ*MAXNP + + 2*MAXN*MAXNQ*MAXM + MAXNQ**2 + + 5*MAXNQ + MAXNQ*(MAXNP+MAXM) + LDWE*LD2WE*MAXNQ, + LIWORK=20+MAXNP+MAXNQ*(MAXNP+MAXM)) C VARIABLE DECLARATIONS INTEGER I,INFO,IPRINT,J,JOB,L,LUNERR,LUNRPT,M,MAXIT,N, + NDIGIT,NP,NQ INTEGER IFIXB(MAXNP),IFIXX(LDIFX,MAXM),IWORK(LIWORK) DOUBLE PRECISION PARTOL,SSTOL,TAUFAC DOUBLE PRECISION BETA(MAXNP),SCLB(MAXNP),SCLD(LDSCLD,MAXM), + STPB(MAXNP),STPD(LDSTPD,MAXM), + WD(LDWD,LD2WD,MAXM),WE(LDWE,LD2WE,MAXNQ), + WORK(LWORK),X(LDX,MAXM),Y(LDY,MAXNQ) c integer npoints,istommodel,istommodel0,i1,i2,i3,i4,i5 double precision pco2s(npoints),gswmeas(npoints), & rehulfsurf(npoints),gammas(npoints), & assim_net(npoints),pvapordef_s(npoints),stomintercept, & stomslope,rayDzero common /stommodelindicator/istommodel0 EXTERNAL STOMFCN c C SPECIFY DEFAULT VALUES FOR DODRC ARGUMENTS WE(1,1,1) = -1.0D0 WD(1,1,1) = -1.0D0 IFIXB(1) = -1 ! IFIXX(1,1) = -1 ! JOB = 00023 JOB=23 NDIGIT = -1 TAUFAC = -1.0D0 SSTOL = -1.0D0 PARTOL = -1.0D0 MAXIT = -1 ! IPRINT = -1 IPRINT=0 LUNERR = -1 LUNRPT = -1 STPB(1) = -1.0D0 STPD(1,1) = -1.0D0 SCLB(1) = -1.0D0 SCLD(1,1) = -1.0D0 MAXIT = 200000 C SET UP ODRPACK REPORT FILES LUNERR = 9 LUNRPT = 9 c N=npoints istommodel0=istommodel BETA(1)=stomintercept BETA(2)=stomslope do I=1,N X(I,1)=assim_net(I) Y(I,1)=gswmeas(I) enddo if(istommodel0.eq.1)then ! Ball-Berry NP=2 M=3 do I=1,N X(I,2)=pco2s(I) X(I,3)=rehulfsurf(I) enddo endif if(istommodel0.eq.2)then ! Leuning with leaf surface co2 NP=3 BETA(3)=rayDzero M=4 do I=1,N X(I,2)=pco2s(I) X(I,3)=gammas(I) X(I,4)=pvapordef_s(I) enddo endif if(istommodel0.eq.3)then ! Belinda Medlyn model NP=2 M=3 do I=1,N X(I,2)=pco2s(I) X(I,3)=pvapordef_s(I) enddo endif if(istommodel0.eq.4)then ! Dewar model NP=3 BETA(3)=rayDzero M=3 do I=1,N X(I,2)=pco2s(I) X(I,3)=pvapordef_s(I) enddo endif NQ=1 C READ PROBLEM DATA, AND SET NONDEFAULT VALUE FOR ARGUMENT IFIXX DO 10 I=1,N DO 15 J=1, M IFIXX(I,J) = 1 15 CONTINUE 10 CONTINUE 60 CALL DODRC(STOMFCN, + N,M,NP,NQ, + BETA, + Y,LDY,X,LDX, + WE,LDWE,LD2WE,WD,LDWD,LD2WD, + IFIXB,IFIXX,LDIFX, + JOB,NDIGIT,TAUFAC, + SSTOL,PARTOL,MAXIT, + IPRINT,LUNERR,LUNRPT, + STPB,STPD,LDSTPD, + SCLB,SCLD,LDSCLD, + WORK,LWORK,IWORK,LIWORK, + INFO) i1=mod(INFO,10) i2=(mod(INFO,100)-i1)/10 i3=(mod(INFO,1000)-mod(INFO,100))/100 i4=(mod(INFO,10000)-mod(INFO,1000))/1000 i5=(INFO-mod(INFO,10000))/10000 stomintercept=BETA(1) stomslope=BETA(2) if(istommodel0.eq.2.or.istommodel0.eq.4)RayDzero=BETA(3) return END c SUBROUTINE STOMFCN(N,M,NP,NQ, + LDN,LDM,LDNP, + BETA,XPLUSD, + IFIXB,IFIXX,LDIFX, + IDEVAL,F,FJACB,FJACD, + ISTOP) implicit none 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+1),XPLUSD(LDN,M) INTEGER IFIXB(NP+1),IFIXX(LDIFX,M) C OUTPUT ARGUMENTS: DOUBLE PRECISION F(LDN,NQ),FJACB(LDN,LDNP,NQ),FJACD(LDN,LDM,NQ) integer istommodel0 common /stommodelindicator/istommodel0 double precision pco2s,rehulfsurf,gammas, & pvapordef_s,rayDzero,assim_net,stomintercept, & stomslope,gswmod,derivb,derivslope,derivd0 C CHECK FOR UNACCEPTABLE VALUES FOR THIS PROBLEM c do I=1,NP if(BETA(I).lt.0.0d0)then ISTOP = 1 RETURN endif enddo ! IF (MOD(IDEVAL,10).GE.1) THEN DO 110 L = 1,NQ DO 100 I = 1,N stomintercept=BETA(1) stomslope=BETA(2) assim_net=XPLUSD(I,1) if(istommodel0.eq.1)then ! Ball-Berry pco2s=XPLUSD(I,2) rehulfsurf=XPLUSD(I,3) endif if(istommodel0.eq.2)then ! Leuning with leaf surface co2 RayDzero=BETA(3) pco2s=XPLUSD(I,2) gammas=XPLUSD(I,3) pvapordef_s=XPLUSD(I,4) endif if(istommodel0.eq.3)then ! Belinda Medlyn with leaf surface co2 pco2s=XPLUSD(I,2) pvapordef_s=XPLUSD(I,3) endif if(istommodel0.eq.4)then ! dewar with leaf surface co2 RayDzero=BETA(3) pco2s=XPLUSD(I,2) pvapordef_s=XPLUSD(I,3) endif call StomatalConductance(pco2s,rehulfsurf,gammas, & pvapordef_s,rayDzero,assim_net,istommodel0, & stomintercept,stomslope,gswmod) F(I,L)=gswmod 100 CONTINUE 110 CONTINUE END IF C COMPUTE DERIVATIVES WITH RESPECT TO BETA IF (MOD(IDEVAL/10,10).GE.1) THEN DO 210 L = 1,NQ DO 200 I = 1,N stomintercept=BETA(1) stomslope=BETA(2) assim_net=XPLUSD(I,1) if(istommodel0.eq.1)then ! Ball-Berry pco2s=XPLUSD(I,2) rehulfsurf=XPLUSD(I,3) endif if(istommodel0.eq.2)then ! Leuning with leaf surface co2 RayDzero=BETA(3) pco2s=XPLUSD(I,2) gammas=XPLUSD(I,3) pvapordef_s=XPLUSD(I,4) endif if(istommodel0.eq.3)then ! Belinda Medlyn model pco2s=XPLUSD(I,2) pvapordef_s=XPLUSD(I,3) endif if(istommodel0.eq.4)then ! Dewar model RayDzero=BETA(3) pco2s=XPLUSD(I,2) pvapordef_s=XPLUSD(I,3) endif call Der_StomatalConductance(pco2s,rehulfsurf,gammas, & pvapordef_s,rayDzero,assim_net,istommodel0, & stomintercept,stomslope,derivb,derivslope,derivd0) FJACB(I,1,L)=derivb FJACB(I,2,L)=derivslope if(istommodel0.eq.2.or.istommodel0.eq.4)FJACB(I,3,L)=derivd0 200 CONTINUE 210 CONTINUE END IF RETURN END !$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$