subroutine phenofit(nphenocycl0,iphenodowhat0,phenocyclmark, &ntotpoints,phenoy,phenox,y0,a1,b1,c1,x01,a2,b2,c2,x02,amin,amax, &bmin,bmax,cmin,cmax,y0min,y0max,x01min,x01max,x02min,x02max,ndim, &beta,phenoy0,abcx,predphenoy,predphenox,sumsquare) implicit none integer nphenocycl0,iphenodowhat0(nphenocycl0),ntotpoints double precision phenocyclmark(nphenocycl0),phenoy(ntotpoints), &phenox(ntotpoints),y0,a1,b1,c1,x01,a2,b2,c2,x02,amin,amax,bmin, &bmax,cmin,cmax,y0min,y0max,x01min,x01max,x02min,x02max,phenoy0, &abcx(nphenocycl0,8),predphenoy(ntotpoints),predphenox(ntotpoints), &sumsquare !nphenocycl: the number of individual cycle units !iphenodowhat: an index specifying what mathematical function to use for each individual cycle unit !iphenodowhat= 1 - 4: double function cycle (paired sigmoid functions) ! =1: all parameters, 8 params ! =2: c1 and c2 set 1, 6 params ! =3: c1=c2=1, a1=a2, 5 params ! =4: a1=a2, 7 params !iphenodowhat= 5 - 6: single function cycle (a2, b2, c2 and x02 are not used) ! =5: a1, b1, c1, x01. 4 parameters ! =6: a1, b1, x01. 3 parameters (c1 is set to be 1) ! !ntotpoints: the total number of points in all cycle units !phenoy: the y variable !phenox: the x variable !y0,a1,b1,c1,x01,a2,b2,c2,x02,amin,amax,bmin,bmax,cmin,cmax,y0min,y0max,x01min,x01max,x02min,x02max: ! - initial guesses and their bounds !ndim: the total number of parameters estimated !phenoy0: the estimated y0 !abcx: The parameters estimated for each cycle unit. (-0.9999 indicating not used) ! abcx(i,1)=a1 ! abcx(i,2)=b1 ! abcx(i,3)=c1 ! abcx(i,4)=x01 ! abcx(i,5)=a2 ! abcx(i,6)=b2 ! abcx(i,7)=c2 ! abcx(i,8)=x02 !predphenoy: the predicted y variable for each phenox !predphenox: the predicted x variable in case orthorgonal regression is used. integer iderivative,INFO,j,ndim double precision beta(nphenocycl0*8+1),betamin(nphenocycl0*8+1), &betamax(nphenocycl0*8+1),weitphenox(ntotpoints), &phenoxmin(ntotpoints),phenoxmax(ntotpoints),weitphenoy(ntotpoints) !(((((((((((((((((((((((((((((((((((((((((((((((((((( integer nphenocycl,iphenodowhat(100) COMMON /phenocom/nphenocycl,iphenodowhat save /phenocom/ !)))))))))))))))))))))))))))))))))))))))))))))))))))) nphenocycl=nphenocycl0 do j=1,nphenocycl iphenodowhat(j)=iphenodowhat0(j) enddo call phenoparams_init(nphenocycl,iphenodowhat,phenocyclmark, &y0,a1,b1,c1,x01,a2,b2,c2,x02,amin,amax,bmin,bmax,cmin,cmax,y0min, &y0max,x01min,x01max,x02min,x02max,beta,betamin,betamax,ndim) iderivative=1 INFO=0 !INFO =0, ordinary distance regression !INFO =1, explicit orthogonal distance regression with shortest distance within iteration !INFO =2, explicit orthogonal distance regression with x positions as parameters do j=1,ntotpoints weitphenox(j)=1.0d0 phenoxmin(j)=phenox(j)-20.0d0 phenoxmax(j)=phenox(j)+20.0d0 weitphenoy(j)=1.0d0 enddo call GenericRegres(ntotpoints,1,phenoy,1,phenox,weitphenoy, &weitphenox,ndim,beta,betamin,betamax,phenoxmin,phenoxmax, &iderivative,INFO,predphenoy,predphenox,sumsquare) phenoy0=beta(1) call phenoparams_alloc(nphenocycl,iphenodowhat,beta,abcx) return end !$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ subroutine surffunc(nyvars,yvars,nxvars, & xvars,ndim,beta,dydxp,idowhat) implicit none !idowhat=0, value of the function only ! =1, derivative with respect to the independent variable x and value of the function ! =2, derivative with respect to the parameters and value of the function integer nyvars,nxvars,ndim,idowhat double precision yvars(nyvars),xvars(nxvars), & beta(ndim),dydxp(nyvars,(nxvars+ndim)) !(((((((((((((((((((((((((((((((((((((((((((((((((((( integer nphenocycl,iphenodowhat(100) COMMON /phenocom/nphenocycl,iphenodowhat save /phenocom/ !)))))))))))))))))))))))))))))))))))))))))))))))))))) integer j,NParam,i double precision y0,a1,b1,c1,x01,a2,b2,c2,x02, &abcx(1:nphenocycl,1:8),twoexpfunc,sigmoidfunc,grad(10) y0=beta(1) call phenoparams_alloc(nphenocycl,iphenodowhat,beta, &abcx(1:nphenocycl,1:8)) ! write(*,*)y0,ndim ! do j=1,nphenocycl ! write(*,330)(abcx(j,i),i=1,8) ! enddo !330 format(8(f15.6)) ! pause yvars(1)=y0 do j=1,nphenocycl a1=abcx(j,1) b1=abcx(j,2) c1=abcx(j,3) x01=abcx(j,4) if(iphenodowhat(j).le.4)then a2=abcx(j,5) b2=abcx(j,6) c2=abcx(j,7) x02=abcx(j,8) yvars(1)=yvars(1)+ &twoexpfunc(0.0d0,a1,b1,c1,x01,a2,b2,c2,x02,xvars(1)) else yvars(1)=yvars(1)+sigmoidfunc(0.0d0,a1,b1,c1,x01,xvars(1)) endif enddo if(idowhat.eq.1)then dydxp(1,1)=0.0d0 do j=1,nphenocycl a1=abcx(j,1) b1=abcx(j,2) c1=abcx(j,3) x01=abcx(j,4) if(iphenodowhat(j).le.4)then a2=abcx(j,5) b2=abcx(j,6) c2=abcx(j,7) x02=abcx(j,8) call gradtwoexp(0.0d0,a1,b1,c1,x01, &a2,b2,c2,x02,xvars(1),grad) else call gradsigmoidfunc(0.0d0,a1,b1,c1,x01,xvars(1),grad) endif dydxp(1,1)=dydxp(1,1)+grad(6) enddo endif if(idowhat.eq.2)then NParam=1 dydxp(1,1)=1.0d0 do j=1,nphenocycl a1=abcx(j,1) b1=abcx(j,2) c1=abcx(j,3) x01=abcx(j,4) if(iphenodowhat(j).le.4)then a2=abcx(j,5) b2=abcx(j,6) c2=abcx(j,7) x02=abcx(j,8) call gradtwoexp(0.0d0,a1,b1,c1,x01, &a2,b2,c2,x02,xvars(1),grad) else call gradsigmoidfunc(0.0d0,a1,b1,c1,x01,xvars(1),grad) endif ! a1<->grad(1) ! b1<->grad(2) ! c1<->grad(3) ! x01<->grad(4) ! y0<->grad(5) ! x<->grad(6) ! a2<->grad(7) ! b2<->grad(8) ! c2<->grad(9) ! x02<->grad(10) if(iphenodowhat(j).eq.1)then ! all parameters in the two exp functions dydxp(1,NParam+1)=grad(1) dydxp(1,NParam+2)=grad(2) dydxp(1,NParam+3)=grad(3) dydxp(1,NParam+4)=grad(4) dydxp(1,NParam+5)=grad(7) dydxp(1,NParam+6)=grad(8) dydxp(1,NParam+7)=grad(9) dydxp(1,NParam+8)=grad(10) NParam=NParam+8 endif if(iphenodowhat(j).eq.2)then ! c1=c2=1.0 dydxp(1,NParam+1)=grad(1) dydxp(1,NParam+2)=grad(2) dydxp(1,NParam+3)=grad(4) dydxp(1,NParam+4)=grad(7) dydxp(1,NParam+5)=grad(8) dydxp(1,NParam+6)=grad(10) NParam=NParam+6 endif if(iphenodowhat(j).eq.3)then ! c1=c2=1.0 ! a1=a2 dydxp(1,NParam+1)=grad(1)+grad(7) dydxp(1,NParam+2)=grad(2) dydxp(1,NParam+3)=grad(4) dydxp(1,NParam+4)=grad(8) dydxp(1,NParam+5)=grad(10) NParam=NParam+5 endif if(iphenodowhat(j).eq.4)then ! a1=a2 dydxp(1,NParam+1)=grad(1)+grad(7) dydxp(1,NParam+2)=grad(2) dydxp(1,NParam+3)=grad(3) dydxp(1,NParam+4)=grad(4) dydxp(1,NParam+5)=grad(8) dydxp(1,NParam+6)=grad(9) dydxp(1,NParam+7)=grad(10) NParam=NParam+7 endif if(iphenodowhat(j).eq.5)then ! single function, 4 parameters dydxp(1,NParam+1)=grad(1) dydxp(1,NParam+2)=grad(2) dydxp(1,NParam+3)=grad(3) dydxp(1,NParam+4)=grad(4) NParam=NParam+4 endif if(iphenodowhat(j).eq.6)then ! single function, 3 parameters, c=1 dydxp(1,NParam+1)=grad(1) dydxp(1,NParam+2)=grad(2) dydxp(1,NParam+3)=grad(4) NParam=NParam+3 endif enddo endif return end !$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ subroutine phenoparams_init(nphenocycl,iphenodowhat,phenocyclmark, &y0,a1,b1,c1,x01,a2,b2,c2,x02,amin,amax,bmin,bmax,cmin,cmax,y0min, &y0max,x01min,x01max,x02min,x02max,BETA,BETAmin,BETAmax,NParam) implicit none integer nphenocycl,iphenodowhat(nphenocycl),NParam,i double precision y0,a1,b1,c1,x01,a2,b2,c2,x02,amin,amax,bmin,bmax, &cmin,cmax,x01min,x01max,x02min,x02max,y0min,y0max, &BETA(nphenocycl*8+1),BETAmin(nphenocycl*8+1), &BETAmax(nphenocycl*8+1),phenocyclmark(nphenocycl) !number of parameters for each phenocycl !iphenodowhat= 1 - 4: double function cycle ! =1: all parameters, 8 params ! =2: c1 and c2 set 1, 6 params ! =3: c1=c2=1, a1=a2, 5 params ! =4: a1=a2, 7 params ! !iphenodowhat= 5 - 6: single function cycle ! =5: a, b, c, x0. 4 parameters ! =6: a, b, x0. c is set to be 1 ! ! abcx(i,1)=a1 ! abcx(i,2)=b1 ! abcx(i,3)=c1 ! abcx(i,4)=x01 ! abcx(i,5)=a2 ! abcx(i,6)=b2 ! abcx(i,7)=c2 ! abcx(i,8)=x02 NParam=1 BETA(1)=y0 BETAmin(1)=y0min BETAmax(1)=y0max do i=1,nphenocycl if(iphenodowhat(i).eq.1)then ! all parameters in the two exp functions BETA(NParam+1)=a1 BETA(NParam+2)=b1 BETA(NParam+3)=c1 BETA(NParam+4)=phenocyclmark(i)+x01 BETA(NParam+5)=a2 BETA(NParam+6)=b2 BETA(NParam+7)=c2 BETA(NParam+8)=phenocyclmark(i)+x02 BETAmin(NParam+1)=amin BETAmax(NParam+1)=amax BETAmin(NParam+2)=bmin BETAmax(NParam+2)=bmax BETAmin(NParam+3)=cmin BETAmax(NParam+3)=cmax BETAmin(NParam+4)=phenocyclmark(i)+x01min BETAmax(NParam+4)=phenocyclmark(i)+x01max BETAmin(NParam+5)=BETAmin(NParam+1) BETAmax(NParam+5)=BETAmax(NParam+1) BETAmin(NParam+6)=BETAmin(NParam+2) BETAmax(NParam+6)=BETAmax(NParam+2) BETAmin(NParam+7)=BETAmin(NParam+3) BETAmax(NParam+7)=BETAmax(NParam+3) BETAmin(NParam+8)=phenocyclmark(i)+x02min BETAmax(NParam+8)=phenocyclmark(i)+x02max NParam=NParam+8 endif if(iphenodowhat(i).eq.2)then ! c1=c2=1.0 BETA(NParam+1)=a1 BETA(NParam+2)=b1 BETA(NParam+3)=phenocyclmark(i)+x01 BETA(NParam+4)=a2 BETA(NParam+5)=b2 BETA(NParam+6)=phenocyclmark(i)+x02 BETAmin(NParam+1)=amin BETAmax(NParam+1)=amax BETAmin(NParam+2)=bmin BETAmax(NParam+2)=bmax BETAmin(NParam+3)=phenocyclmark(i)+x01min BETAmax(NParam+3)=phenocyclmark(i)+x01max BETAmin(NParam+4)=BETAmin(NParam+1) BETAmax(NParam+4)=BETAmax(NParam+1) BETAmin(NParam+5)=BETAmin(NParam+2) BETAmax(NParam+5)=BETAmax(NParam+2) BETAmin(NParam+6)=phenocyclmark(i)+x01min BETAmax(NParam+6)=phenocyclmark(i)+x02max NParam=NParam+6 endif if(iphenodowhat(i).eq.3)then ! c1=c2=1.0 ! a1=a2 BETA(NParam+1)=a1 BETA(NParam+2)=b1 BETA(NParam+3)=phenocyclmark(i)+x01 BETA(NParam+4)=b2 BETA(NParam+5)=phenocyclmark(i)+x02 BETAmin(NParam+1)=amin BETAmax(NParam+1)=amax BETAmin(NParam+2)=bmin BETAmax(NParam+2)=bmax BETAmin(NParam+3)=phenocyclmark(i)+x01min BETAmax(NParam+3)=phenocyclmark(i)+x01max BETAmin(NParam+4)=BETAmin(NParam+2) BETAmax(NParam+4)=BETAmax(NParam+2) BETAmin(NParam+5)=phenocyclmark(i)+x02min BETAmax(NParam+5)=phenocyclmark(i)+x02max NParam=NParam+5 endif if(iphenodowhat(i).eq.4)then ! a1=a2 BETA(NParam+1)=a1 BETA(NParam+2)=b1 BETA(NParam+3)=c1 BETA(NParam+4)=phenocyclmark(i)+x01 BETA(NParam+5)=b2 BETA(NParam+6)=c2 BETA(NParam+7)=phenocyclmark(i)+x02 BETAmin(NParam+1)=amin BETAmax(NParam+1)=amax BETAmin(NParam+2)=bmin BETAmax(NParam+2)=bmax BETAmin(NParam+3)=cmin BETAmax(NParam+3)=cmax BETAmin(NParam+4)=phenocyclmark(i)+x01min BETAmax(NParam+4)=phenocyclmark(i)+x01max BETAmin(NParam+5)=BETAmin(NParam+2) BETAmax(NParam+5)=BETAmax(NParam+2) BETAmin(NParam+6)=BETAmin(NParam+3) BETAmax(NParam+6)=BETAmax(NParam+3) BETAmin(NParam+7)=phenocyclmark(i)+x02min BETAmax(NParam+7)=phenocyclmark(i)+x02max NParam=NParam+7 endif if(iphenodowhat(i).eq.5)then ! single function, 4 parameters BETA(NParam+1)=a1 BETA(NParam+2)=b1 BETA(NParam+3)=c1 BETA(NParam+4)=phenocyclmark(i)+x01 BETAmin(NParam+1)=amin BETAmax(NParam+1)=amax BETAmin(NParam+2)=bmin BETAmax(NParam+2)=bmax BETAmin(NParam+3)=cmin BETAmax(NParam+3)=cmax BETAmin(NParam+4)=phenocyclmark(i)+x01min BETAmax(NParam+4)=phenocyclmark(i)+x01max NParam=NParam+4 endif if(iphenodowhat(i).eq.6)then ! single function, 3 parameters, c=1 BETA(NParam+1)=a1 BETA(NParam+2)=b1 BETA(NParam+3)=phenocyclmark(i)+x01 BETAmin(NParam+1)=amin BETAmax(NParam+1)=amax BETAmin(NParam+2)=bmin BETAmax(NParam+2)=bmax BETAmin(NParam+3)=phenocyclmark(i)+x01min BETAmax(NParam+3)=phenocyclmark(i)+x01max NParam=NParam+3 endif enddo return end !$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ subroutine phenoparams_alloc(nphenocycl,iphenodowhat,BETA,abcx) implicit none integer nphenocycl,iphenodowhat(nphenocycl) double precision BETA(nphenocycl*8+1),abcx(nphenocycl,8) integer NParam,i !number of parameters for each phenocycl !iphenodowhat= 1 - 4: double function cycle ! =1: all parameters, 8 params ! =2: c1 and c2 set 1, 6 params ! =3: c1=c2=1, a1=a2, 5 params ! =4: a1=a2, 7 params ! !iphenodowhat= 5 - 6: single function cycle ! =5: a, b, c, x0. 4 parameters ! =6: a, b, x0. c is set to be 1 ! abcx(i,1)=a1 ! abcx(i,2)=b1 ! abcx(i,3)=c1 ! abcx(i,4)=x01 ! abcx(i,5)=a2 ! abcx(i,6)=b2 ! abcx(i,7)=c2 ! abcx(i,8)=x02 NParam=1 do i=1,nphenocycl if(iphenodowhat(i).eq.1)then ! all parameters in the two exp functions abcx(i,1)=BETA(NParam+1) abcx(i,2)=BETA(NParam+2) abcx(i,3)=BETA(NParam+3) abcx(i,4)=BETA(NParam+4) abcx(i,5)=BETA(NParam+5) abcx(i,6)=BETA(NParam+6) abcx(i,7)=BETA(NParam+7) abcx(i,8)=BETA(NParam+8) NParam=NParam+8 endif if(iphenodowhat(i).eq.2)then ! c1=c2=1.0 abcx(i,1)=BETA(NParam+1) abcx(i,2)=BETA(NParam+2) abcx(i,3)=1.0d0 abcx(i,4)=BETA(NParam+3) abcx(i,5)=BETA(NParam+4) abcx(i,6)=BETA(NParam+5) abcx(i,7)=1.0d0 abcx(i,8)=BETA(NParam+6) NParam=NParam+6 endif if(iphenodowhat(i).eq.3)then ! c1=c2=1.0 ! a1=a2 abcx(i,1)=BETA(NParam+1) abcx(i,2)=BETA(NParam+2) abcx(i,3)=1.0d0 abcx(i,4)=BETA(NParam+3) abcx(i,5)=abcx(i,1) abcx(i,6)=BETA(NParam+4) abcx(i,7)=1.0d0 abcx(i,8)=BETA(NParam+5) NParam=NParam+5 endif if(iphenodowhat(i).eq.4)then ! a1=a2 abcx(i,1)=BETA(NParam+1) abcx(i,2)=BETA(NParam+2) abcx(i,3)=BETA(NParam+3) abcx(i,4)=BETA(NParam+4) abcx(i,5)=abcx(i,1) abcx(i,6)=BETA(NParam+5) abcx(i,7)=BETA(NParam+6) abcx(i,8)=BETA(NParam+7) NParam=NParam+7 endif if(iphenodowhat(i).eq.5)then ! single function, 4 parameters abcx(i,1)=BETA(NParam+1) abcx(i,2)=BETA(NParam+2) abcx(i,3)=BETA(NParam+3) abcx(i,4)=BETA(NParam+4) abcx(i,5)=0.0d0 abcx(i,6)=-0.9999d0 abcx(i,7)=0.0d0 abcx(i,8)=-0.9999d0 NParam=NParam+4 endif if(iphenodowhat(i).eq.6)then ! single function, 3 parameters abcx(i,1)=BETA(NParam+1) abcx(i,2)=BETA(NParam+2) abcx(i,3)=1.0d0 abcx(i,4)=BETA(NParam+3) abcx(i,5)=0.0d0 abcx(i,6)=-0.9999d0 abcx(i,7)=0.0d0 abcx(i,8)=-0.9999d0 NParam=NParam+3 endif enddo return end !$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$