Kolpack-Software-Consulting/piscal
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Initial commit

Browse Source
This commit is contained in:
poprhythm
2016-02-03 18:52:05 +00:00
commit d40505e161
507 changed files with 91383 additions and 0 deletions
Download Patch File Download Diff File Expand all files Collapse all files
dataassim/math/optimization/CompassSearch.f
+210
View File
@@ -0,0 +1,210 @@
subroutine RepeatCompassSearch(ndim,xbest,fbest,
& bmin,bmax,funkmin,f1dim,xtol)
implicit none
integer ndim
double precision xbest(1:ndim),fbest,
& bmin(1:ndim),bmax(1:ndim),xtol
double precision fvalpre,dmax,xpre(1:ndim),ftol,direction(ndim)
integer i,n
logical resetran2
common /ran2reset/resetran2
external funkmin,f1dim
!
ftol=xtol
n=0
resetran2=.true.
10 fvalpre=fbest
do i=1,ndim
xpre(i)=xbest(i)
enddo
call CompassSearch(ndim,xbest,fbest,
& bmin,bmax,funkmin,f1dim,xtol)
n=n+1
dmax=dabs(xbest(1)-xpre(1))
do i=2,ndim
if(dmax.lt.dabs(xbest(i)-xpre(i)))then
dmax=dabs(xbest(i)-xpre(i))
endif
enddo
if(dabs(fvalpre-fbest).gt.ftol.and.
& dmax.gt.xtol.and.n.lt.2)then
do i=1,ndim
direction(i)=xbest(i)-xpre(i)
enddo
call linmin(xbest,bmin,bmax,direction,
& ndim,f1dim,fbest)
goto 10
endif
return
end subroutine RepeatCompassSearch
subroutine CompassSearch(ndim,xbest,fbest,
& bmin,bmax,funkmin,f1dim,xtol)
implicit none
! This subroutine minimizes the function funkmin using the compass search method. The ! maximum number of function evaluations is maxiter. Once mexiter is reached, all
! function evaluations are ranked and returned.
!
!------------------------------------- Inputs -----------------------------------------------------
! maxiter: the maximum number of function evaluations allowed
! xbest: the initial guess
! fbest: the cost function value at xinitial
! bmin: the lower bounds of the parameters to be optimized
! bmax: the upper bounds of the parameters to be optimized
! ndim: the number of parameters to optimize
! funkmin: the name of the function to minimize
!------------------------------------- Outputs ---------------------------------------------------
! xobs: points where the function is evaluated. Ranked from the best to worst with the
! first point being the best point.
! fvalue: the function values at xobs
! ierr: =0 convergence criterion not reached
! =1 convergence criterion reached (minimum found)
!
integer ndim
double precision xbest(1:ndim),fbest,
& bmin(1:ndim),bmax(1:ndim),xtol,dx1,dx2
external funkmin,f1dim
!------------------------------- Locals -----------------------------------------------------------
double precision diftol,delta,
& xcompass(1:2*ndim,1:ndim),fcompass(1:2*ndim),
& xvec(1:ndim),xcent(1:ndim),fcent,dif,shrink,
& direction(ndim),dmax,fcent0,ran2_reset,ran2
integer i,j,k,iter
parameter(shrink=0.618d0)
!
diftol=xtol
delta=0.618d0
do i=1,ndim
xcent(i)=xbest(i)
enddo
fcent=fbest
iter=0
10 continue
do i=1,ndim
do j=1,ndim
xcompass(i,j)=xcent(j)
xcompass(ndim+i,j)=xcent(j)
enddo
xcompass(i,i)=xcent(i)+delta*(bmax(i)-xcent(i))
xcompass(ndim+i,i)=xcent(i)+delta*(bmin(i)-xcent(i))
enddo
do i=1,2*ndim
do j=1,ndim
xvec(j)=xcompass(i,j)
enddo
call funkmin(ndim,xvec,fcompass(i))
if(dabs(fcompass(i)).gt.1.0d+90)then
delta=delta*shrink
if(delta.lt.diftol)goto 100
goto 10
endif
enddo
do i=1,ndim
xbest(i)=xcompass(1,i)
enddo
fbest=fcompass(1)
do i=2,2*ndim
if(fcompass(i).lt.fbest)then
fbest=fcompass(i)
do j=1,ndim
xbest(j)=xcompass(i,j)
enddo
endif
enddo
fcent0=fcent
do i=1,ndim
xvec(i)=xcent(i)
enddo
do i=1,ndim
dx1=xcompass(i,i)-xcent(i)
dx2=xcent(i)-xcompass(i+ndim,i)
direction(i)=0.0d0
if(dx1.ne.0.0d0)then
direction(i)=(fcompass(i)-fcent)/dx1
endif
if(dx2.ne.0.0d0)then
direction(i)=direction(i)+
& (fcent-fcompass(i+ndim))/dx2
endif
direction(i)=-0.5d0*direction(i)
if(direction(i).eq.0.0d0)direction(i)=
& ran2_reset()-0.5d0
enddo
call linmin(xcent,bmin,bmax,direction,
& ndim,f1dim,fcent)
if(fcent.gt.fcent0)then
fcent=fcent0
do i=1,ndim
xcent(i)=xvec(i)
enddo
endif
dif=fcent-fbest
if(fbest.le.fcent)then
fcent=fbest
do i=1,ndim
xcent(i)=xbest(i)
enddo
endif
if(dif.ge.0.0d0)then
if(dif.gt.diftol)then
if(iter.lt.150)then
iter=iter+1
goto 10
else
iter=0
endif
endif
if(delta.lt.diftol)goto 100
delta=delta*shrink
goto 10
else
!no progress
if(dabs(dif).gt.diftol)then
if(delta.lt.diftol)goto 100
delta=delta*shrink
goto 10
endif
dmax=dabs(xcompass(1,1)-xcompass(ndim+1,1))
do i=2,ndim
if(dmax.lt.dabs(xcompass(i,i)-
& xcompass(ndim+i,i)))then
dmax=dabs(xcompass(i,i)-
& xcompass(ndim+i,i))
endif
enddo
if(dmax.gt.xtol)then
if(delta.lt.diftol)goto 100
delta=delta*shrink
goto 10
else
goto 100
endif
endif
100 fbest=fcent
do i=1,ndim
xbest(i)=xcent(i)
dx1=xcompass(i,i)-xcent(i)
dx2=xcent(i)-xcompass(i+ndim,i)
direction(i)=0.0d0
if(dx1.ne.0.0d0)then
direction(i)=(fcompass(i)-fcent)/dx1
endif
if(dx2.ne.0.0d0)then
direction(i)=direction(i)+
& (fcent-fcompass(i+ndim))/dx2
endif
direction(i)=-0.5d0*direction(i)
if(direction(i).eq.0.0d0)direction(i)=
& ran2_reset()-0.5d0
enddo
call linmin(xcent,bmin,bmax,direction,
& ndim,f1dim,fcent)
if(fcent.lt.fbest)then
fbest=fcent
do i=1,ndim
xbest(i)=xcent(i)
enddo
endif
return
end subroutine CompassSearch
dataassim/math/optimization/Externals_GenericRegres.f
+361
View File
@@ -0,0 +1,361 @@
subroutine funkmin_generic(ndim,beta,fvalue)
implicit none
include 'forgenericregres.h'
integer ndim
double precision beta(ndim),fvalue
!(in) ndim: the dimension of the parameter vector
!(in) beta: the parameters
!(out) fvalue: the value of the cost function at beta
!-----------------------------------------------------
integer i,j,idowhat,nparams
double precision dydxp(nyvars,(nxvars+ndim))
!
! check to see if parameters are out of bounds
if(idobounded.eq.1)then
if(betamin(1).lt.betamax(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
endif
fvalue=0.0d0
if(iregrestype.eq.1)then
!orthogonal distance regression
do i=1,nobs
call shortestdist(nyvars,nxvars,yobs(i:i,1:nyvars),
& xvars(i:i,1:nxvars),xmin(i:i,1:nxvars),
& xmax(i:i,1:nxvars),ndim,beta,iknowder,
& shorty(i:i,1:nyvars),shortx(i:i,1:nxvars))
do j=1,nyvars
fvalue=fvalue+weity(i,j)*
& (shorty(i,j)-yobs(i,j))**2
enddo
do j=1,nxvars
fvalue=fvalue+weitx(i,j)*
& (shortx(i,j)-xvars(i,j))**2
enddo
enddo
endif
if(iregrestype.eq.0)then
idowhat=0
do i=1,nobs
call surffunc(nyvars,shorty(i:i,1:nyvars),nxvars,
& xvars(i:i,1:nxvars),ndim,beta,
& dydxp(1:nyvars,1:(nxvars+ndim)),idowhat)
do j=1,nyvars
fvalue=fvalue+weity(i,j)*
& (shorty(i,j)-yobs(i,j))**2
enddo
enddo
endif
if(iregrestype.eq.2)then
nparams=ndim-nobs
idowhat=nparams
do i=1,nobs
do j=1,nxvars
idowhat=idowhat+1
shortx(i,j)=beta(idowhat)
enddo
enddo
idowhat=0
do i=1,nobs
call surffunc(nyvars,shorty(i:i,1:nyvars),nxvars,
& shortx(i:i,1:nxvars),nparams,beta,
& dydxp(1:nyvars,1:(nxvars+ndim)),idowhat)
do j=1,nyvars
fvalue=fvalue+weity(i,j)*
& (shorty(i,j)-yobs(i,j))**2
enddo
do j=1,nxvars
fvalue=fvalue+weitx(i,j)*
& (shortx(i,j)-xvars(i,j))**2
enddo
enddo
endif
if(iregrestype.eq.-1)then
!implicit orthogonal distance regression
idowhat=0
do i=1,nobs
call surffunc(nyvars,shorty(i:i,1:nyvars),nxvars,
& xvars(i:i,1:nxvars),ndim,beta,
& dydxp(1:nyvars,1:(nxvars+ndim)),idowhat)
do j=1,nyvars
fvalue=fvalue+weity(i,j)*
& shorty(i,j)**2
enddo
enddo
endif
return
end subroutine funkmin_generic
!$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
double precision function f1dim_generic(x)
implicit none
double precision x
CU USES funkmin_generic
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_generic(ncom,xt,f1dim_generic)
return
END
!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
SUBROUTINE FCN_generic(N,M,NP,NQ,
+ LDN,LDM,LDNP,
+ BETA,XPLUSD,
+ IFIXB,IFIXX,LDIFX,
+ IDEVAL,F,FJACB,FJACD,
+ ISTOP)
implicit none
include 'forgenericregres.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)
double precision ymod(NQ),dydxp(NQ,(M+NP))
integer k,idowhat
!-----------------------------------------------------
if(idobounded.eq.1)then
if(betamin(1).lt.betamax(1))then
do I=1,NP
if(BETA(I).lt.betamin(I).or.BETA(I).gt.betamax(I))then
ISTOP = 1
RETURN
endif
enddo
endif
endif
ISTOP=0
IF (MOD(IDEVAL,10).GE.1) THEN
idowhat=0
DO 100 I = 1,N
call surffunc(NQ,ymod,M,XPLUSD(I:I,1:M),
& NP,BETA,dydxp(1:NQ,1:(M+NP)),idowhat)
DO 110 L = 1,NQ
F(I,L)=ymod(L)
110 CONTINUE
100 CONTINUE
END IF
C COMPUTE DERIVATIVES WITH RESPECT TO BETA
IF (MOD(IDEVAL/10,10).GE.1) THEN
idowhat=2
DO 200 I = 1,N
call surffunc(NQ,ymod,M,XPLUSD(I:I,1:M),
& NP,BETA,dydxp(1:NQ,1:(M+NP)),idowhat)
DO 210 L = 1,NQ
do k=1,NP
FJACB(I,k,L)=dydxp(L,k)
enddo
210 CONTINUE
200 CONTINUE
ENDIF
c compute derivatives with respect to delta
IF (MOD(IDEVAL/100,10).GE.1) THEN
idowhat=1
DO 300 I = 1,N
call surffunc(NQ,ymod,M,XPLUSD(I:I,1:M),
& NP,BETA,dydxp(1:NQ,1:(M+NP)),idowhat)
DO 310 L = 1,NQ
do k=1,M
FJACD(I,k,L)=dydxp(L,k)
enddo
310 CONTINUE
300 CONTINUE
ENDIF
RETURN
END
!$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
!$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
double precision function generic_pikaia(ndim,beta01)
implicit none
include 'forgenericregres.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_generic(ndim,beta,fvalue)
generic_pikaia=1.0d0/(fvalue+0.00001d0)
return
end
!$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
!$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
subroutine distcenter(nx,x,fequ,fvalue,idowhat)
implicit none
include 'leastdistance.h'
!idowhat=1, evaluating the system of equations and calculating the sum of squares.
!idowhat=2, calculating the distance.
integer nx,idowhat
double precision x(nx),fequ(nx),fvalue
!----------------------------------------------------------
integer i,j,ider
double precision y(my),dydxp(my,(nx+nparams)),
& xcopy(nx),sum,yplush(my),yminush(my),h
parameter(h=1.0d-7)
!==============End of Variable Declaration==================
j=0
call surffunc(my,y,nx,x,nparams,params,
& dydxp(1:my,1:(nx+nparams)),j)
if(idowhat.eq.1)then
if(iknowder.eq.1)then
call surffunc(my,y,nx,x,nparams,params,
& dydxp(1:my,1:(nx+nparams)),iknowder)
endif
if(iknowder.eq.0)then
do i=1,nx
xcopy(i)=x(i)
enddo
do i=1,nx
xcopy(i)=x(i)+h
call surffunc(my,yplush,nx,xcopy,nparams,params,
& dydxp(1:my,1:(nx+nparams)),iknowder)
xcopy(i)=x(i)-h
call surffunc(my,yminush,nx,xcopy,nparams,params,
& dydxp(1:my,1:(nx+nparams)),iknowder)
do j=1,my
dydxp(j,i)=(yplush(j)-yminush(j))/(2.0d0*h)
enddo
xcopy(i)=x(i)
enddo
endif
do i=1,nx
sum=0.0d0
do j=1,my
sum=sum+(y(j)-targety(j))*dydxp(j,i)
enddo
fequ(i)=x(i)-(targetx(i)-sum)
enddo
fvalue=0.0d0
do i=1,nx
fvalue=fvalue+fequ(i)*fequ(i)
enddo
endif
if(idowhat.eq.2)then
fvalue=0.0d0
do i=1,my
fvalue=fvalue+(y(i)-targety(i))**2
enddo
do i=1,nx
fvalue=fvalue+(x(i)-targetx(i))**2
enddo
endif
return
end subroutine distcenter
!$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
subroutine distcentersys(nunknowns,x,fequ,fsqsum)
implicit none
integer nunknowns,idowhat
double precision x(nunknowns),
& fequ(nunknowns),fsqsum
parameter(idowhat=1)
call distcenter(nunknowns,x,fequ,fsqsum,idowhat)
return
end subroutine distcentersys
!-----------------------------------------------------------
subroutine fsqsum_distcenter(nunknowns,x,fsqsum)
implicit none
integer nunknowns,idowhat
double precision x(nunknowns),fsqsum,
& fequ(nunknowns)
parameter(idowhat=1)
call distcenter(nunknowns,x,fequ,fsqsum,idowhat)
return
end
!-----------------------------------------------------------
double precision function f1dimsqsum_distcenter(x)
implicit none
double precision x
INTEGER j,idowhat
!((((((((((((((((((((((((((((((((((((((((((((((((((((
integer NMAX,ncom
parameter(NMAX=1000)
double precision pcom(NMAX),xicom(NMAX)
COMMON /cpf1com/ pcom,xicom,ncom
save /cpf1com/
!))))))))))))))))))))))))))))))))))))))))))))))))))))
double precision xt(NMAX),fequ(NMAX)
parameter(idowhat=1)
do 11 j=1,ncom
xt(j)=pcom(j)+x*xicom(j)
11 continue
call distcenter(ncom,xt,fequ,
& f1dimsqsum_distcenter,idowhat)
return
END
!------------------------------------------------------------
subroutine s2_distcenter(nunknowns,x,s2)
implicit none
integer nunknowns,idowhat
double precision x(nunknowns),s2,fequ(nunknowns)
parameter(idowhat=2)
call distcenter(nunknowns,x,fequ,s2,idowhat)
return
end
!-----------------------------------------------------------
double precision function f1dims2_distcenter(x)
implicit none
double precision x
INTEGER j,idowhat
!((((((((((((((((((((((((((((((((((((((((((((((((((((
integer NMAX,ncom
parameter(NMAX=1000)
double precision pcom(NMAX),xicom(NMAX)
COMMON /cpf1com/ pcom,xicom,ncom
save /cpf1com/
!))))))))))))))))))))))))))))))))))))))))))))))))))))
double precision xt(NMAX),fequ(NMAX)
parameter(idowhat=2)
do 11 j=1,ncom
xt(j)=pcom(j)+x*xicom(j)
11 continue
call distcenter(ncom,xt,fequ,
& f1dims2_distcenter,idowhat)
return
END
!$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
dataassim/math/optimization/FCN_neural.f
+146
View File
@@ -0,0 +1,146 @@
subroutine funkmin_neural(ndim,beta,fvalue)
implicit none
include 'NeuralNetRegres.h'
integer ndim
double precision beta(ndim),fvalue
!(in) ndim: the dimension of the parameter vector
!(in) beta: the parameters
!(out) fvalue: the value of the cost function at beta
!-----------------------------------------------------
integer i,j,k,idowhat
double precision w(maxnx,maxnh),bph(maxnh),q(maxnh),
&bend,annfunc,ypred
!
! check to see if parameters are out of bounds
if(betamin(1).lt.betamax(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
idowhat=1
call coeff_beta(idowhat,nx,nh,beta,w(1:nx,1:nh),bph,q,bend)
fvalue=0.0d0
do i=1,nobs
ypred=annfunc(nx,xsamp(i:i,1:nx),nh,q,w(1:nx,1:nh),bph,bend)
fvalue=fvalue+(ysamp(i)-ypred)*(ysamp(i)-ypred)
enddo
return
end subroutine funkmin_neural
!$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
double precision function f1dim_neural(x)
implicit none
double precision x
CU USES funkmin_neural
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_neural(ncom,xt,f1dim_neural)
return
END
!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
SUBROUTINE FCN_neural(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 II,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,i,j,s,t,ierr,idowhat
include 'NeuralNetRegres.h'
double precision w(maxnx,maxnh),bph(maxnh),
& q(maxnh),bend,xnew(maxnx),annfunc,
& derBETA(NP),derw(maxnx,maxnh),derbph(maxnh),
& derq(maxnh),derbend
C CHECK FOR UNACCEPTABLE VALUES FOR THIS PROBLEM
c
do I=1,NP
if(BETA(I).lt.betamin(I).or.BETA(I).gt.betamax(I))then
ISTOP = 1
RETURN
endif
enddo
idowhat=1
call coeff_beta(idowhat,nx,nh,BETA,
& w(1:nx,1:nh),bph,q,bend)
!---------------- find the ann function values--------------------------
IF (MOD(IDEVAL,10).GE.1) THEN
DO 110 L = 1,NQ
DO 100 I = 1,N
do k=1,M
xnew(k)=XPLUSD(I,k)
enddo
F(I,L)=annfunc(nx,xnew,nh,q,w(1:nx,1:nh),bph,bend)
100 CONTINUE
110 CONTINUE
END IF
!----------------------------------------------------------------------
C COMPUTE DERIVATIVES WITH RESPECT TO BETA
IF (MOD(IDEVAL/10,10).GE.1) THEN
idowhat=2
DO 200 I = 1,N
do k=1,M
xnew(k)=XPLUSD(I,k)
enddo
call derannfunc(nx,xnew,nh,q,w(1:nx,1:nh),
& bph,bend,derq,derw(1:nx,1:nh),derbph,derbend)
call coeff_beta(idowhat,nx,nh,derBETA,
& derw(1:nx,1:nh),derbph,derq,derbend)
DO 210 L = 1,NQ
do k=1,NP
FJACB(I,k,L)=derBETA(k)
enddo
210 CONTINUE
200 CONTINUE
END IF
RETURN
END
!
!$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
dataassim/math/optimization/FilterNeuralNetRegres.f
+72
View File
@@ -0,0 +1,72 @@
subroutine FilterNeuralNetRegres(idowhat,nx0,nobs0,nh0,
&xsamp0,ysamp0,yatxsamp0,rsq,w,bph,q,bend,xnew,ypred)
implicit none
!
!=============Inputs regardless of idowhat=========================
!idowhat: =1, fit the data and estimate the coefficients. Provide the
! initial guess for the coefficients or set bend to -9999
! =2, coefficients are already available, calculate y at xnew
!nx0: the number of independent (x) variables
!nobs0: the total number of samples
!nh0: the total number of hidden nodes to use. One hidden layer is
! assumed.
!============When idowhat=1========================================
! --------Inputs--------
!xsamp0: the values of the independent (x) variables
!ysamp0: the values of the dependent (y) variable. y is one dimension.
! --------Outputs-------
!w: the slope coefficient to time the normalized x in the activation function
!bph: the intercept coefficient in the activation function
!q: the coefficient to time the value of the activation function
!bend: the residual constant in the neural network regression
!yatxsamp0: the predicted y value at xsamp0
!rsq: R squared
!============When idowhat=2=========================================
! --------Inputs--------
!w: the slope coefficient to time the normalized x in the activation function
!bph: the intercept coefficient in the activation function
!q: the coefficient to time the value of the activation function
!bend: the residual constant in the neural network regression
!xnew: the new x point who y value is to be estimated (when idowhat=2)
! --------Outputs-------
!ypred: the predicted y value at xnew
!
integer idowhat,nx0,nobs0,nh0
double precision xsamp0(nobs0,nx0),ysamp0(nobs0),
& yatxsamp0(nobs0),rsq,w(nx0,nh0),bph(nh0),q(nh0),
& bend,xnew(nx0),ypred,fn9999,dif_y(nobs0)
parameter(fn9999=-9999.0d0)
!============Locals=========================================
integer i,j,m,n,nobs,isoutlier_2sides
!
if(idowhat.eq.1)then
nobs=nobs0
10 n=0
do i=1,nobs
if(dabs(ysamp0(i)-fn9999).gt.1.0d-6)then
n=n+1
ysamp0(n)=ysamp0(i)
do j=1,nx0
xsamp0(n,j)=xsamp0(i,j)
enddo
endif
enddo
nobs=n
call NeuralNetRegres(idowhat,nx0,nobs,nh0,xsamp0(1:nobs,1:nx0),
&ysamp0,yatxsamp0,rsq,w(1:nx0,1:nh0),bph,q,bend,xnew,ypred)
do i=1,nobs
dif_y(i)=ysamp0(i)-yatxsamp0(i)
enddo
m=isoutlier_2sides(nobs,dif_y)
if(m.gt.0)then
ysamp0(m)=fn9999
goto 10
endif
return
endif
if(idowhat.eq.2)call NeuralNetRegres(idowhat,nx0,nobs0,nh0,
&xsamp0(1:nobs0,1:nx0),ysamp0,yatxsamp0,rsq,w(1:nx0,1:nh0),bph,
&q,bend,xnew,ypred)
return
end
!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
dataassim/math/optimization/FilterRegres.f
+54
View File
@@ -0,0 +1,54 @@
Subroutine FilterRegres(nobs,ny,yobs,nx,xobs,weity0,
&weitx,ndim,beta,betamin,betamax,xmin,xmax,
&iderivative,iregrestype,shorty,shortx,fatbeta)
implicit none
!Generic Regression with outlier filtering. Use the subroutine GenericRegres.
!iregrestype=0, ordinary distance regression
!iregrestype=1, orthogonal distance regression. Direct search methods
! determine the shortest distance within the iteration
!iregrestype=2, orthogonal distance regression. Direct search methods
! expand the parameter vector to include x positions.
!iregrestype=-1, implicit regression
!iderivative=0, no derivatives provided, using central finite difference
!iderivative=1, derivatives provided.
!If the weity0(i,j) is modified on exit, the corresponding point is detected
!as an outlier
integer nobs,ny,nx,iderivative,ndim,iregrestype
double precision yobs(nobs,ny),xobs(nobs,nx),weity0(nobs,ny),
&weity(nobs,ny),weitx(nobs,nx),xmin(nobs,nx),xmax(nobs,nx),
&beta(ndim),betamin(ndim),betamax(ndim),shorty(nobs,ny),
&shortx(nobs,nx),fatbeta,dif_y(nobs),tiny
parameter(tiny=1.0d-9)
!
integer i,j,k,m,isoutlier_2sides,iok,ivector(nobs)
!-----------------------------------------------------
do i=1,nobs
do j=1,ny
weity(i,j)=weity0(i,j)
enddo
enddo
10 call GenericRegres(nobs,ny,yobs(1:nobs,1:ny),nx,xobs(1:nobs,1:nx),
&weity(1:nobs,1:ny),weitx(1:nobs,1:nx),ndim,beta,betamin,betamax,
&xmin(1:nobs,1:nx),xmax(1:nobs,1:nx),iderivative,iregrestype,
&shorty(1:nobs,1:ny),shortx(1:nobs,1:nx),fatbeta)
k=0
do j=1,ny
iok=0
do i=1,nobs
if(dabs(weity(i,j)).gt.tiny)then
!do not consider points with weit = 0 for the purpose of identifying outliers
iok=iok+1
ivector(iok)=i
dif_y(iok)=weity(i,j)*(yobs(i,j)-shorty(i,j))
endif
enddo
m=isoutlier_2sides(iok,dif_y)
if(m.gt.0)then
k=k+1
weity(ivector(m),j)=0.0d0
endif
enddo
if(k.gt.0)goto 10
return
end subroutine FilterRegres
!$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
dataassim/math/optimization/GSA.f
+334
View File
@@ -0,0 +1,334 @@
program test
implicit none
integer ndim
double precision x0(10),xt(10),fvalue
ndim=2
x0(1)=-90.0d0
x0(2)=1000.0d0
call GSA(ndim,x0,xt,fvalue)
write(*,*)fvalue,xt(1),xt(2)
end
* Generalized Simulated Annealing - Code
* Program developed by Members of Lab. of Molecular Modeling
* Kleber C. Mundim (1995)
* ------------------------------------------------------
* Global optimization method using Generalized Simulated Annealing
* as for example;
* GSA Procedure + Your objective/coust function
* ______________ __________________
* | | Set of Parameters | |
* | | =================> | Routine with |
* | GSA-routine | | your objective |
* | | <================= | function |
* |______________| Objective function |__________________|
*
* ------------------------------------------------------
* First Version Jan./1994 (Kleber Mundim and Constantino Tsallis)
* Second Version Jun./1995 (Marcelo Moret)
* Third Version Sep./1995 (Thierry Lemaire and Amin Bassrei)
*
* Some Basic References and literature citation:
*
*1- Title : Geometry Optimization and Conformational Analysis Through
* Generalized Simulated Annealing
* Authors : Kleber C. Mundim and Constantino Tsallis
* Journal : Int.Journal of Quantum Chemistry, 58 (1996),373-381
*
*2- Title : Stochastic Molecular Optimization using Generalized
* Simulated Annealing
* Authors : Marcelo Moret, Pedro G. Pascutti, Paulo M. Bish
* and Kleber C. Mundim
* Journal : Journal of Computational Chemistry, 19 (1998) 647-657
*
*3- Title : Modeling Gravity Anomalies Through Generalized
* Simulated Annealing
* Authors : Kleber C. Mundim, Thierry Lemaire and Amin Bassrei
* Journal : Physica A, 252 (1998) 405-416
* ------------------------------------------------------
* Most important vectors and parameters used in the GSA routines.
* NDimension --> Number of parameters to be optimized (problem dependent).
* X_t(i) --> This vector contains the parameters.
* X_0(i) --> X_0(i) contains X_t at the time t-1.
* X_Min --> Minimal parameters obtained.
* To --> Initial Temperature.
* qV --> qV caracterize the Visiting Probability Function.
* qA --> qA Acceptance Parameter.
* qT --> qT Temperature parameter
* NStopMax --> Maximum number of GSA loops (problem dependent).
* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * |
subroutine GSA(ndim,X0,Xt,fvalue)
* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * |
* This routine start the GSA-loop
IMPLICIT DOUBLE PRECISION (A-H,O-Z)
PARAMETER (MaxDim=500)
dimension X0(ndim),Xt(ndim)
COMMON /Par1/ qV1,qV2,qA1,qT1,D,exp1,exp2,Coef,Tqt,To,ToScale
COMMON /Par2/ qA,qV,qT
COMMON /Par3/ NDimension,NStopMax,NRAN
COMMON /Xvector/ X_t(Maxdim), X_0(Maxdim), X_Min(Maxdim)
DATA One /1.0D+00/
NDimension=ndim
CALL GSAini()
DO i=1,NDimension
X_0(i)=X0(i)
X_Min(i) = X_0(i)
X_t(i) = X_0(i)
ENDDO
func_0 = func(X_0)
func_Min = func_0
func_t = func_0
OneqA1 = One/qA1
Time = 0.0D0
NCycle = 0
DO WHILE (NCycle.LE.NStopMax)
Time = Time + One
NCycle = NCycle + 1
T = Tqt/((One+Time)**qT1 - One)
IF(D.EQ.0.0D0) THEN
Tup = One
ELSE
Tup = T**(D/(qT-3.0D0))
ENDIF
CALL Gfunc(T,Tup)
func_t = func(X_t)
IF(func_t .LE. func_0) THEN
DO I=1, NDimension
X_0(I) = X_t(I)
ENDDO
func_0 = func_t
IF(func_t .LE. func_Min) THEN
func_Min = func_t
DO I=1,NDimension
X_Min(I) = X_t(I)
ENDDO
ENDIF
ELSE
DeltaE = func_t - func_0
qA1= qA - One
PqA = One/((One+qA1*DeltaE/T)**OneqA1)
Rand = RAN3(NRAN)
IF(Rand .LT. PqA) THEN
DO I=1,NDimension
X_0(I) = X_t(I)
ENDDO
func_0 = func_t
ENDIF
ENDIF
ENDDO
fvalue=func_t
do I=1,ndim
Xt(I)=X_t(I)
enddo
return
END
* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * |
SUBROUTINE Gfunc(T,Tup)
* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * |
* This routine evaluate the new set o parameters using the
* visiting probability function g(q,T).
IMPLICIT DOUBLE PRECISION (A-H,O-Z)
PARAMETER (MaxDim=500)
COMMON /Par1/ qV1,qV2,qA1,qT1,D,exp1,exp2,Coef,Tqt,To,ToScale
COMMON /Par3/ NDimension,NStopMax,NRAN
COMMON /Xvector/ X_t(Maxdim), X_0(Maxdim), X_Min(Maxdim)
DATA One /1.00000D+00/
DO I = 1,NDimension
R = RAN3(NRAN)
S = RAN3(NRAN)
DeltaX = Coef*Tup/(One+qV1*R*R/T**exp1)**exp2
IF(S.LE.0.5) DeltaX = -DeltaX
X_t(I) = X_0(I) + DeltaX
ENDDO
RETURN
END
* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * |
FUNCTION dgamma(r)
* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * |
* This routine evaluate usual Gamma function.
IMPLICIT REAL*8 (a - h, o - z)
PARAMETER (
1 p0 = 0.999999999999999990d+00, p1 = -0.422784335098466784d+00,
2 p2 = -0.233093736421782878d+00, p3 = 0.191091101387638410d+00,
3 p4 = -0.024552490005641278d+00, p5 = -0.017645244547851414d+00,
4 p6 = 0.008023273027855346d+00)
PARAMETER (
1 p7 = -0.000804329819255744d+00,p8 = -0.000360837876648255d+00,
2 p9 = 0.000145596568617526d+00,p10 = -0.000017545539395205d+00,
3 p11 = -0.000002591225267689d+00,p12 = 0.000001337767384067d+00,
4 p13 = -0.000000199542863674d+00)
n = NINT(r - 2)
w = r - (n + 2)
y = ((((((((((((p13 * w + p12)* w + p11)* w + p10)*
1 w + p9) * w + p8) * w + p7) * w + p6) * w + p5) *
2 w + p4) * w + p3) * w + p2) * w + p1) * w + p0
IF (n .gt. 0) THEN
w = r - 1
DO k = 2, n
w = w * (r - k)
END DO
ELSE
w = 1
DO k = 0, -n - 1
y = y * (r + k)
END DO
END IF
dgamma = w / y
RETURN
END
* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * |
DOUBLE PRECISION FUNCTION RAN3(IDUM)
* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * |
IMPLICIT DOUBLE PRECISION (A-H,O-Z)
* This routine return an randomic number 0<= r <= 1
C IMPLICIT REAL*4(M)
C PARAMETER (MBIG=4000000.,MSEED=1618033.,MZ=0.,FAC=2.5D-7)
PARAMETER (MBIG=1000000000,MSEED=161803398,MZ=0,FAC=1.D-9)
COMMON /RAN1A/ IFF,MJ,MK,INEXT,INEXTP,MA(55)
* DATA IFF /0/
* INEXT=0
* INEXTP=31
IF(IDUM.LT.0.OR.IFF.EQ.0)THEN
IFF=1
MJ=MSEED-IABS(IDUM)
MJ=MOD(MJ,MBIG)
MA(55)=MJ
MK=1
DO 11 I=1,54
II=MOD(21*I,55)
MA(II)=MK
MK=MJ-MK
IF(MK.LT.MZ)MK=MK+MBIG
MJ=MA(II)
11 CONTINUE
DO 13 K=1,4
DO 12 I=1,55
MA(I)=MA(I)-MA(1+MOD(I+30,55))
IF(MA(I).LT.MZ)MA(I)=MA(I)+MBIG
12 CONTINUE
13 CONTINUE
INEXT=0
INEXTP=31
IDUM=1
ENDIF
INEXT=INEXT+1
IF(INEXT.EQ.56)INEXT=1
INEXTP=INEXTP+1
IF(INEXTP.EQ.56)INEXTP=1
MJ=MA(INEXT)-MA(INEXTP)
IF(MJ.LT.MZ)MJ=MJ+MBIG
MA(INEXT)=MJ
RAN3=MJ*FAC
RETURN
END
* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * |
SUBROUTINE GSAini()
* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * |
* This routine read and initialize the GSA parameters
* The number of parameters to be optimized (NDIMENSION) is problem
* dependent.
IMPLICIT DOUBLE PRECISION (A-H,O-Z)
PARAMETER (MaxDim=500)
COMMON /Par1/ qV1,qV2,qA1,qT1,D,exp1,exp2,Coef,Tqt,To,ToScale
COMMON /Par2/ qA,qV,qT
COMMON /Par3/ NDimension,NStopMax,NRAN
DATA One /1.00000D+00/
CHARACTER tempo*8
qA=1.5d0
qT=1.5d0
qV=1.5d0
NStopMax=1000
To=1.0E-00
CALL TIME(tempo)
READ(tempo(7:8),"(I2)")NRAN
NRAN = -NRAN
D = 10.5d0
Pi = 3.14159265359D0
* Acceptance probability
qA1= qA - One
* Temperature
qT1 = qT - One
Tqt = To*(2.0D0**qT1-One)
* Visiting probability
qV1= qV - One
qV2= 2.0D0**qV1 - One
tmp= One/qV1 - 0.5D0
GamaDown = dgamma(tmp)
exp1 = 2.0D0/(3.0D0 - qV)
IF(D.EQ.0.0D0) THEN
Coef1 = One
exp2 = One/qv1 - 0.5D0
GamaUp = GamaDown
ELSE
Coef1 = (qV1/Pi)**(D*0.5D0)
exp2 = One/qV1 + 0.5D0*D - 0.5D0
GamaUp = dgamma(exp2)
ENDIF
Coef = Coef1*GamaUp/GamaDown
RETURN
END
* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * |
FUNCTION func(X)
* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * |
IMPLICIT DOUBLE PRECISION (A-H,O-Z)
PARAMETER (MaxDim=500)
* This subrotuine make link between GSA and your Objective function
* X(nDimension) is a vector that contains the parameters set.
* GSA Procedure + Your objective/coust function
* ______________ __________________
* | | Set of Parameters X(i) | |
* | | =================> | Routine with |
* | GSA-routine | | your objective |
* | | <================= | function |
* |______________| Value of the function (f) |__________________|
COMMON /Par3/ NDimension,NStopMax,NRAN
DIMENSION X(MaxDim)
* CALL here your routine with the objective function
* X(i) is parameters set and f is the value of the objective function
! CALL funct(X,f)
! func = f
func=(X(1)-2.0d0)*(X(1)-2.0d0)+(X(2)-13.8d0)*(X(2)-13.8d0)
RETURN
END
dataassim/math/optimization/GSA.in
+6
View File
@@ -0,0 +1,6 @@
Initial GSA parameters
1.5 qA Acceptance index
1.5 qT Temperature index
1.5 qV Visiting index
1000 NStopMax Max number of GSA-loops
1.0E-00 To Initial Temperature
dataassim/math/optimization/GenericRegres.f
+333
View File
@@ -0,0 +1,333 @@
Subroutine GenericRegres(npoints,ny,y,nx,x,weity0,
&weitx0,ndim0,beta_in_out,betamin0,betamax0,xmin0,xmax0,
&iderivative,iregrestype0,shorty0,shortx0,fatbeta)
implicit none
!iregrestype0=0, ordinary regression
!iregrestype0=1, orthogonal distance regression. Direct search methods
! determine the shortest distance within the iteration
!iregrestype0=2, orthogonal distance regression. Direct search methods
! expand the parameter vector to include x positions.
!iregrestype0=-1, implicit regression
!iderivative=0, no derivative provided
!iderivative=1, derivative provided
include 'forgenericregres.h'
integer npoints,ny,nx,iderivative,ndim0,iregrestype0
double precision y(npoints,ny),x(npoints,nx),weity0(npoints,ny),
&weitx0(npoints,nx),xmin0(npoints,nx),xmax0(npoints,nx),
&beta_in_out(ndim0),betamin0(ndim0),betamax0(ndim0),
&shorty0(npoints,ny),shortx0(npoints,nx),fatbeta
!
integer i,j,INFO,ndim,k
double precision xtol,beta(ndim0+nx*npoints),
&betacp(ndim0+nx*npoints),fatbetacp,beta0(ndim0+nx*npoints),
&fatbeta0,ftol,gacontrol(12),ran2,ftol_relax
parameter(xtol=1.0d-7,ftol=1.0d-7)
external funkmin_generic,FCN_generic,f1dim_generic,generic_pikaia
!-----------------------------------------------------
ndim=ndim0
nxvars=nx
nyvars=ny
if((nx*npoints+ndim0).gt.1000)iregrestype0=0
iregrestype=iregrestype0
iknowder=iderivative
nobs=npoints
do i=1,npoints
do j=1,nxvars
xvars(i,j)=x(i,j)
xmin(i,j)=xmin0(i,j)
xmax(i,j)=xmax0(i,j)
weitx0(i,j)=1.0d0
weitx(i,j)=weitx0(i,j)
enddo
do j=1,nyvars
yobs(i,j)=y(i,j)
weity(i,j)=weity0(i,j)
enddo
enddo
do i=1,ndim
betamin(i)=betamin0(i)
betamax(i)=betamax0(i)
beta(i)=beta_in_out(i)
enddo
if(iregrestype.eq.2)iregrestype=1
c gacontrol( 1) - number of individuals in a population (default
c is 100)
c gacontrol( 2) - number of generations over which solution is
c to evolve (default is 500)
c gacontrol( 3) - number of significant digits (i.e., number of
c genes) retained in chromosomal encoding (default
c is 6) (Note: This number is limited by the
c machine floating point precision. Most 32-bit
c floating point representations have only 6 full
c digits of precision. To achieve greater preci-
c sion this routine could be converted to double
c precision, but note that this would also require
c a double precision random number generator, which
c likely would not have more than 9 digits of
c precision if it used 4-byte integers internally.)
c gacontrol( 4) - crossover probability; must be <= 1.0 (default
c is 0.85). If crossover takes place, either one
c or two splicing points are used, with equal
c probabilities
c gacontrol( 5) - mutation mode; 1/2/3/4/5 (default is 2)
c 1=one-point mutation, fixed rate
c 2=one-point, adjustable rate based on fitness
c 3=one-point, adjustable rate based on distance
c 4=one-point+creep, fixed rate
c 5=one-point+creep, adjustable rate based on fitness
c 6=one-point+creep, adjustable rate based on distance
c gacontrol( 6) - initial mutation rate; should be small (default
c is 0.005) (Note: the mutation rate is the proba-
c bility that any one gene locus will mutate in
c any one generation.)
c gacontrol( 7) - minimum mutation rate; must be >= 0.0 (default
c is 0.0005)
c gacontrol( 8) - maximum mutation rate; must be <= 1.0 (default
c is 0.25)
c gacontrol( 9) - relative fitness differential; range from 0
c (none) to 1 (maximum). (default is 1.)
c gacontrol(10) - reproduction plan; 1/2/3=Full generational
c replacement/Steady-state-replace-random/Steady-
c state-replace-worst (default is 3)
c gacontrol(11) - elitism flag; 0/1=off/on (default is 0)
c (Applies only to reproduction plans 1 and 2)
c gacontrol(12) - printed output 0/1/2=None/Minimal/Verbose
c (default is 0)
idobounded=1
10 call funkmin_generic(ndim,beta,fatbeta)
do i=1,ndim
beta0(i)=beta(i)
enddo
fatbeta0=fatbeta
j=0
k=0
ftol_relax=ftol*100.0d0
30 call nongradopt(ndim,funkmin_generic,
&f1dim_generic,beta,betamin,betamax,ftol_relax,fatbeta)
call funkmin_generic(ndim,beta,fatbeta)
if((fatbeta+1.0d0).eq.fatbeta.or.fatbeta.gt.fatbeta0)then
do i=1,ndim
beta(i)=beta0(i)
enddo
fatbeta=fatbeta0
else
if((fatbeta0-fatbeta).lt.ftol_relax)then
!increment the counter for arriving at the same minimum
k=k+1
else
!reset the counter for arriving at a better minimum
k=0
endif
do i=1,ndim
beta0(i)=beta(i)
enddo
fatbeta0=fatbeta
endif
j=j+1
!try different initial guesses
if(j.lt.100.and.k.lt.5)then
if(ran2().gt.0.3d0)then
do i=1,ndim
if(ran2().gt.0.5d0)then
beta(i)=beta(i)+(ran2()**(3.0d0/dble(k+1)))*
&(betamax(i)-beta(i))
else
beta(i)=beta(i)-(ran2()**(3.0d0/dble(k+1)))*
&(beta(i)-betamin(i))
endif
enddo
else
do i=1,ndim
beta(i)=betamin(i)+ran2()*(betamax(i)-betamin(i))
enddo
endif
call funkmin_generic(ndim,beta,fatbeta)
goto 30
else
if((ftol_relax-ftol).gt.ftol)then
ftol_relax=ftol
goto 30
endif
endif
call RepeatCompassSearch(ndim,beta,fatbeta,
&betamin,betamax,funkmin_generic,f1dim_generic,xtol)
call funkmin_generic(ndim,beta,fatbeta)
k=0
if((fatbeta+1.0d0).eq.fatbeta)k=1
do i=1,ndim
if((beta(i)+1.0d0).eq.beta(i))k=1
enddo
if(k.eq.1)then
do i=1,ndim
beta(i)=betamin(i)+(betamax(i)-betamin(i))*ran2()
enddo
goto 10
endif
if(fatbeta.ge.fatbeta0)then
!if RepeatCompassSearch cannot improve, we end the search
do i=1,ndim
beta(i)=beta0(i)
enddo
fatbeta=fatbeta0
goto 110
else
if((fatbeta0-fatbeta).lt.ftol)goto 40
endif
do i=1,12
gacontrol(i)=-1.0d0
enddo
gacontrol(1)=250.0d0
gacontrol(2)=5000.0d0
gacontrol(3)=8.0d0
do i=1,ndim
beta0(i)=(beta(i)-betamin(i))/(betamax(i)-betamin(i))
enddo
idobounded=0
call pikaia(generic_pikaia,ndim,gacontrol,beta0,fatbeta0,j)
fatbeta0=1.0d+100
if(j.eq.0)then
do i=1,ndim
beta0(i)=betamin(i)+beta0(i)*(betamax(i)-betamin(i))
enddo
idobounded=1
call funkmin_generic(ndim,beta0,fatbeta0)
k=0
if((fatbeta0+1.0d0).eq.fatbeta0)k=1
do i=1,ndim
if((beta0(i)+1.0d0).eq.beta0(i))k=1
enddo
if(k.eq.1)fatbeta0=1.0d+100
endif
40 if(fatbeta0.gt.fatbeta)then
fatbeta0=fatbeta
do i=1,ndim
beta0(i)=beta(i)
enddo
endif
do i=1,ndim
beta(i)=beta0(i)
enddo
fatbeta=fatbeta0
!
INFO=iregrestype
idobounded=0
call odr_leastsquare(ndim,FCN_generic,beta,nobs,
&xvars(1:nobs,1:nxvars),nxvars,yobs(1:nobs,1:nyvars),
&nyvars,weitx(1:nobs,1:nxvars),weity(1:nobs,1:nyvars),
&iderivative,shortx(1:nobs,1:nxvars),
&shorty(1:nobs,1:nyvars),fatbeta,INFO)
idobounded=1
call funkmin_generic(ndim,beta,fatbeta)
k=0
if((fatbeta+1.0d0).eq.fatbeta)k=1
do i=1,ndim
if((beta(i)+1.0d0).eq.beta(i))k=1
enddo
if(k.eq.1)fatbeta=1.0d+100
if(dabs(fatbeta).le.dabs(fatbeta0))then
else
do i=1,ndim
beta(i)=beta0(i)
enddo
fatbeta=fatbeta0
endif
do i=1,ndim
if(beta(i).lt.betamin(i).or.beta(i).gt.betamax(i))then
do j=1,ndim
beta(j)=beta0(j)
enddo
fatbeta=fatbeta0
endif
enddo
fatbeta0=fatbeta
iregrestype=iregrestype0
if(iregrestype.eq.2)then
do i=1,npoints
do j=1,nx
ndim=ndim+1
beta(ndim)=shortx(i,j)
betamin(ndim)=xmin0(i,j)
betamax(ndim)=xmax0(i,j)
if(beta(ndim).lt.betamin(ndim).or.
&beta(ndim).gt.betamax(ndim))then
beta(ndim)=x(i,j)
endif
enddo
enddo
call funkmin_generic(ndim,beta,fatbeta)
endif
j=0
100 j=j+1
fatbeta0=fatbeta
do i=1,ndim
beta0(i)=beta(i)
enddo
call nongradopt(ndim,funkmin_generic,
&f1dim_generic,beta,betamin,betamax,ftol,fatbeta)
call funkmin_generic(ndim,beta,fatbeta)
k=0
if((fatbeta+1.0d0).eq.fatbeta)k=1
do i=1,ndim
if((beta(i)+1.0d0).eq.beta(i))k=1
enddo
if(k.eq.1)fatbeta=1.0d+100
if(dabs(fatbeta).ge.dabs(fatbeta0))then
fatbeta=fatbeta0
do i=1,ndim
beta(i)=beta0(i)
enddo
goto 110
endif
fatbetacp=fatbeta
do i=1,ndim
betacp(i)=beta(i)
enddo
call RepeatCompassSearch(ndim,betacp,fatbetacp,
&betamin,betamax,funkmin_generic,f1dim_generic,xtol)
call funkmin_generic(ndim,betacp,fatbetacp)
k=0
if((fatbetacp+1.0d0).eq.fatbetacp)k=1
do i=1,ndim
if((betacp(i)+1.0d0).eq.betacp(i))k=1
enddo
if(k.eq.1)fatbetacp=1.0d+100
if(dabs(fatbetacp).lt.dabs(fatbeta))then
fatbeta=fatbetacp
do i=1,ndim
beta(i)=betacp(i)
enddo
else
goto 110
endif
if(j.ge.2.or.fatbeta.eq.fatbeta0)goto 110
if(dabs(fatbeta0-fatbeta).gt.ftol)then
do i=1,ndim
betacp(i)=beta(i)-beta0(i)
beta0(i)=beta(i)
enddo
fatbeta0=fatbeta
call linmin(beta,betamin,betamax,betacp,ndim,
&f1dim_generic,fatbeta)
call funkmin_generic(ndim,beta,fatbeta)
if(dabs(fatbeta).lt.dabs(fatbeta0))goto 100
fatbeta=fatbeta0
do i=1,ndim
beta(i)=beta0(i)
enddo
endif
110 call funkmin_generic(ndim,beta,fatbeta)
do i=1,ndim0
beta_in_out(i)=beta(i)
enddo
do i=1,npoints
do j=1,nyvars
shorty0(i,j)=shorty(i,j)
enddo
do j=1,nxvars
shortx0(i,j)=shortx(i,j)
enddo
enddo
return
end subroutine GenericRegres
!$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
dataassim/math/optimization/Lbfgsb_2_4.f
+358
View File
@@ -0,0 +1,358 @@
c DRIVER 2
c --------------------------------------------------------------
c CUSTOMIZED DRIVER FOR L-BFGS-B (version 2.4)
c --------------------------------------------------------------
c
c L-BFGS-B is a code for solving large nonlinear optimization
c problems with simple bounds on the variables.
c
c The code can also be used for unconstrained problems and is
c as efficient for these problems as the earlier limited memory
c code L-BFGS.
c
c This driver illustrates how to control the termination of the
c run and how to design customized output.
c
c References:
c
c [1] R. H. Byrd, P. Lu, J. Nocedal and C. Zhu, ``A limited
c memory algorithm for bound constrained optimization'',
c SIAM J. Scientific Computing 16 (1995), no. 5, pp. 1190--1208.
c
c [2] C. Zhu, R.H. Byrd, P. Lu, J. Nocedal, ``L-BFGS-B: FORTRAN
c Subroutines for Large Scale Bound Constrained Optimization''
c Tech. Report, NAM-11, EECS Department, Northwestern University,
c 1994.
c
c (Postscript files of these papers are available via anonymous
c ftp to ece.nwu.edu in the directory pub/lbfgs/lbfgs_bcm.)
c
c * * *
c
c NEOS, November 1994. (Latest revision April 1997.)
c Optimization Technology Center.
c Argonne National Laboratory and Northwestern University.
c Written by
c Ciyou Zhu
c in collaboration with R.H. Byrd, P. Lu-Chen and J. Nocedal.
c
c
c **************
subroutine Lbfgsb_2_4(n,x,f,l,u,nbd,funkminfjac,
& pgtol,info)
implicit none
! info =0, best parameters on output
! info =1, output may not be best parameters
! info <0: parameter out of bounds. |info| denotes the out-of-bound parameter
! info =11: the correlation matrix is not postitive definite (the determinant is negative)
c This driver shows how to replace the default stopping test
c by other termination criteria. It also illustrates how to
c print the values of several parameters during the course of
c the iteration. The sample problem used here is the same as in
c DRIVER1 (the extended Rosenbrock function with bounds on the
c variables).
integer nmax, mmax, lenwa
parameter (nmax = 1024, mmax = 17)
parameter (lenwa = 2*mmax*nmax + 4*nmax
+ + 11*mmax*mmax + 8*mmax)
c nmax is the dimension of the largest problem to be solved.
c mmax is the maximum number of limited memory corrections.
c lenwa is the corresponding real workspace required.
c Declare the variables needed by the code.
c A description of all these variables is given at the end of
c driver1.
character*60 task, csave
logical lsave(4)
integer n, m, iprint, maxiter,info,idogradient,
+ nbd(nmax), iwa(3*nmax), isave(44)
double precision f, factr, pgtol,
+ x(nmax), l(nmax), u(nmax), g(nmax), dsave(29),
+ wa(lenwa)
parameter(maxiter=2000)
external funkminfjac
c Declare a few additional local variables.
integer i
c We suppress the default output.
iprint = -1
c We suppress both code-supplied stopping tests because the
c user is providing his own stopping criteria.
factr = 1.0d+1
! require funkminfjac to do function value and derivative calculations together
idogradient=1
c We specify the number
c m of limited memory corrections stored. (n and m should not
c exceed the limits nmax and mmax respectively.)
m = 5
c All variables have both lower and upper bounds
! do 10 i = 1, n
! nbd(i) = 2
! 10 continue
c We now define the starting point.
c We start the iteration by initializing task.
task = 'START'
info=0
c ------- The beginning of the loop ----------
111 continue
c This is the call to the L-BFGS-B code.
call setulb(n,m,x,l,u,nbd,f,g,factr,pgtol,wa,iwa,task,iprint,
+ csave,lsave,isave,dsave)
if (task(1:2) .eq. 'FG') then
c The minimization routine has returned to request the
c function f and gradient g values at the current x.
c Compute the cost function value f
! call funkmin(n,x,f)
c Compute gradient g of the cost function at x
! call fjac(n,x,f,g)
call funkminfjac(n,x,idogradient,f,g,info)
if(info.lt.0.or.info.eq.11)return
c Go back to the minimization routine.
goto 111
elseif (task(1:5) .eq. 'NEW_X') then
c
c The minimization routine has returned with a new iterate.
c At this point have the opportunity of stopping the iteration
c or observing the values of certain parameters
c
c First are two examples of stopping tests.
c Note: task(1:4) must be assigned the value 'STOP' to terminate
c the iteration and ensure that the final results are
c printed in the default format. The rest of the character
c string task may be used to store other information.
c 1) Terminate if the total number of f and g evaluations
c exceeds maxiter.
if (isave(34) .ge. maxiter)
+ task='STOP: TOTAL NO. of f AND g EVALUATIONS EXCEEDS LIMIT'
c 2) Terminate if |proj g|/(1 + |f|) < pgtol, where
c "proj g" denoted the projected gradient
if (dsave(13) .le. pgtol*(1.0d0 + dabs(f)))
+ task='STOP: THE PROJECTED GRADIENT IS SUFFICIENTLY SMALL'
c We now wish to get the following information at each
c iteration:
c
c 1) the current iteration number, isave(30),
c 2) the total number of f and g evaluations, isave(34),
c 3) the value of the objective function f,
c 4) the norm of the projected gradient, dsve(13)
c
c See the comments at the end of driver1 for a description
c of the variables isave and dsave.
c Go back to the minimization routine.
goto 111
else
c We terminate execution when task is neither FG nor NEW_X.
c We print the information contained in the string task
c if the default output is not used and the execution is
c not stopped intentionally by the user. In this case the last
! x and f may not be the best
if (task(1:4).eq.'ERROR')info=1
endif
c ---------- the end of the loop -------------
return
end subroutine Lbfgsb_2_4
c======================= The end of Lbfgsb_2_4 ============================
c --------------------------------------------------------------
c DESCRIPTION OF THE VARIABLES IN L-BFGS-B
c --------------------------------------------------------------
c
c n is an INTEGER variable that must be set by the user to the
c number of variables. It is not altered by the routine.
c
c m is an INTEGER variable that must be set by the user to the
c number of corrections used in the limited memory matrix.
c It is not altered by the routine. Values of m < 3 are
c not recommended, and large values of m can result in excessive
c computing time. The range 3 <= m <= 20 is recommended.
c
c x is a DOUBLE PRECISION array of length n. On initial entry
c it must be set by the user to the values of the initial
c estimate of the solution vector. Upon successful exit, it
c contains the values of the variables at the best point
c found (usually an approximate solution).
c
c l is a DOUBLE PRECISION array of length n that must be set by
c the user to the values of the lower bounds on the variables. If
c the i-th variable has no lower bound, l(i) need not be defined.
c
c u is a DOUBLE PRECISION array of length n that must be set by
c the user to the values of the upper bounds on the variables. If
c the i-th variable has no upper bound, u(i) need not be defined.
c
c nbd is an INTEGER array of dimension n that must be set by the
c user to the type of bounds imposed on the variables:
c nbd(i)=0 if x(i) is unbounded,
c 1 if x(i) has only a lower bound,
c 2 if x(i) has both lower and upper bounds,
c 3 if x(i) has only an upper bound.
c
c f is a DOUBLE PRECISION variable. If the routine setulb returns
c with task(1:2)= 'FG', then f must be set by the user to
c contain the value of the function at the point x.
c
c g is a DOUBLE PRECISION array of length n. If the routine setulb
c returns with taskb(1:2)= 'FG', then g must be set by the user to
c contain the components of the gradient at the point x.
c
c factr is a DOUBLE PRECISION variable that must be set by the user.
c It is a tolerance in the termination test for the algorithm.
c The iteration will stop when
c
c (f^k - f^{k+1})/max{|f^k|,|f^{k+1}|,1} <= factr*epsmch
c
c where epsmch is the machine precision which is automatically
c generated by the code. Typical values for factr on a computer
c with 15 digits of accuracy in double precision are:
c factr=1.d+12 for low accuracy;
c 1.d+7 for moderate accuracy;
c 1.d+1 for extremely high accuracy.
c The user can suppress this termination test by setting factr=0.
c
c pgtol is a double precision variable.
c On entry pgtol >= 0 is specified by the user. The iteration
c will stop when
c
c max{|proj g_i | i = 1, ..., n} <= pgtol
c
c where pg_i is the ith component of the projected gradient.
c The user can suppress this termination test by setting pgtol=0.
c
c wa is a DOUBLE PRECISION array of length
c (2mmax + 4)nmax + 11mmax^2 + 8mmax used as workspace.
c This array must not be altered by the user.
c
c iwa is an INTEGER array of length 3nmax used as
c workspace. This array must not be altered by the user.
c
c task is a CHARACTER string of length 60.
c On first entry, it must be set to 'START'.
c On a return with task(1:2)='FG', the user must evaluate the
c function f and gradient g at the returned value of x.
c On a return with task(1:5)='NEW_X', an iteration of the
c algorithm has concluded, and f and g contain f(x) and g(x)
c respectively. The user can decide whether to continue or stop
c the iteration.
c When
c task(1:4)='CONV', the termination test in L-BFGS-B has been
c satisfied;
c task(1:4)='ABNO', the routine has terminated abnormally
c without being able to satisfy the termination conditions,
c x contains the best approximation found,
c f and g contain f(x) and g(x) respectively;
c task(1:5)='ERROR', the routine has detected an error in the
c input parameters;
c On exit with task = 'CONV', 'ABNO' or 'ERROR', the variable task
c contains additional information that the user can print.
c This array should not be altered unless the user wants to
c stop the run for some reason. See driver2 or driver3
c for a detailed explanation on how to stop the run
c by assigning task(1:4)='STOP' in the driver.
c
c iprint is an INTEGER variable that must be set by the user.
c It controls the frequency and type of output generated:
c iprint<0 no output is generated;
c iprint=0 print only one line at the last iteration;
c 0<iprint<99 print also f and |proj g| every iprint iterations;
c iprint=99 print details of every iteration except n-vectors;
c iprint=100 print also the changes of active set and final x;
c iprint>100 print details of every iteration including x and g;
c When iprint > 0, the file iterate.dat will be created to
c summarize the iteration.
c
c csave is a CHARACTER working array of length 60.
c
c lsave is a LOGICAL working array of dimension 4.
c On exit with task = 'NEW_X', the following information is
c available:
c lsave(1) = .true. the initial x did not satisfy the bounds;
c lsave(2) = .true. the problem contains bounds;
c lsave(3) = .true. each variable has upper and lower bounds.
c
c isave is an INTEGER working array of dimension 44.
c On exit with task = 'NEW_X', it contains information that
c the user may want to access:
c isave(30) = the current iteration number;
c isave(34) = the total number of function and gradient
c evaluations;
c isave(36) = the number of function value or gradient
c evaluations in the current iteration;
c isave(38) = the number of free variables in the current
c iteration;
c isave(39) = the number of active constraints at the current
c iteration;
c
c See the subroutine setulb.f for a description of other
c information contained in isave.
c
c dsave is a DOUBLE PRECISION working array of dimension 29.
c On exit with task = 'NEW_X', it contains information that
c the user may want to access:
c dsave(2) = the value of f at the previous iteration;
c dsave(5) = the machine precision epsmch generated by the code;
c dsave(13) = the infinity norm of the projected gradient;
c
c See the subroutine setulb.f for a description of other
c information contained in dsave.
c
c --------------------------------------------------------------
c END OF THE DESCRIPTION OF THE VARIABLES IN L-BFGS-B
c --------------------------------------------------------------
c
c << An example of subroutine 'timer' for AIX Version 3.2 >>
c
c subroutine timer(ttime)
c double precision ttime
c integer itemp, integer mclock
c
c itemp = mclock()
c ttime = dble(itemp)*1.0d-2
c return
c end
c-----------------------------------------------------------------------
dataassim/math/optimization/MultiFit_GenericRegres.f
+411
View File
@@ -0,0 +1,411 @@
subroutine funkmin_generic(ndim,beta,fvalue)
implicit none
include 'forgenericregres.h'
integer ndim
double precision beta(ndim),fvalue
!(in) ndim: the dimension of the parameter vector
!(in) beta: the parameters
!(out) fvalue: the value of the cost function at beta
!-----------------------------------------------------
integer i,j,k,idowhat,nparams,ibreak
double precision dydxp(nyvars,(nxvars+ndim)),params(ndim)
ibreak=39
!
! check to see if parameters are out of bounds
if(betamin(1).lt.betamax(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
fvalue=0.0d0
if(iregrestype.eq.0)then
idowhat=0
do i=1,nobs
if(i.le.ibreak)then
nparams=ndim-1
do j=1,nparams
params(j)=beta(j)
enddo
else
nparams=ndim-1
do j=1,nparams
params(j)=beta(j)
enddo
params(nparams)=beta(ndim)
endif
call surffunc(nyvars,shorty(i:i,1:nyvars),nxvars,
& xvars(i:i,1:nxvars),nparams,params,
& dydxp(1:nyvars,1:(nxvars+nparams)),idowhat)
do j=1,nyvars
fvalue=fvalue+weity(i,j)*
& (shorty(i,j)-yobs(i,j))**2
enddo
enddo
endif
return
if(iregrestype.eq.1)then
!orthogonal distance regression
do i=1,nobs
call shortestdist(nyvars,nxvars,yobs(i:i,1:nyvars),
& xvars(i:i,1:nxvars),xmin(i:i,1:nxvars),
& xmax(i:i,1:nxvars),ndim,beta,iknowder,
& shorty(i:i,1:nyvars),shortx(i:i,1:nxvars))
do j=1,nyvars
fvalue=fvalue+weity(i,j)*
& (shorty(i,j)-yobs(i,j))**2
enddo
do j=1,nxvars
fvalue=fvalue+weitx(i,j)*
& (shortx(i,j)-xvars(i,j))**2
enddo
enddo
endif
if(iregrestype.eq.2)then
nparams=ndim-nobs
idowhat=nparams
do i=1,nobs
do j=1,nxvars
idowhat=idowhat+1
shortx(i,j)=beta(idowhat)
enddo
enddo
idowhat=0
do i=1,nobs
call surffunc(nyvars,shorty(i:i,1:nyvars),nxvars,
& shortx(i:i,1:nxvars),nparams,beta,
& dydxp(1:nyvars,1:(nxvars+ndim)),idowhat)
do j=1,nyvars
fvalue=fvalue+weity(i,j)*
& (shorty(i,j)-yobs(i,j))**2
enddo
do j=1,nxvars
fvalue=fvalue+weitx(i,j)*
& (shortx(i,j)-xvars(i,j))**2
enddo
enddo
endif
if(iregrestype.eq.-1)then
!implicit orthogonal distance regression
idowhat=0
do i=1,nobs
call surffunc(nyvars,shorty(i:i,1:nyvars),nxvars,
& xvars(i:i,1:nxvars),ndim,beta,
& dydxp(1:nyvars,1:(nxvars+ndim)),idowhat)
do j=1,nyvars
fvalue=fvalue+weity(i,j)*
& shorty(i,j)**2
enddo
enddo
endif
return
end subroutine funkmin_generic
!$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
double precision function f1dim_generic(x)
implicit none
double precision x
CU USES funkmin_generic
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_generic(ncom,xt,f1dim_generic)
return
END
!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
SUBROUTINE FCN_generic(N,M,NP,NQ,
+ LDN,LDM,LDNP,
+ BETA,XPLUSD,
+ IFIXB,IFIXX,LDIFX,
+ IDEVAL,F,FJACB,FJACD,
+ ISTOP)
implicit none
include 'forgenericregres.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)
double precision ymod(NQ),dydxp(NQ,(M+NP)),params(NP)
integer k,idowhat,nparams,ibreak
!-----------------------------------------------------
ibreak=39
if(betamin(1).lt.betamax(1))then
do I=1,NP
if(BETA(I).lt.betamin(I).or.BETA(I).gt.betamax(I))then
ISTOP = 1
RETURN
endif
enddo
endif
ISTOP=0
IF (MOD(IDEVAL,10).GE.1) THEN
idowhat=0
DO 100 I = 1,N
if(I.le.ibreak)then
nparams=NP-1
do k=1,nparams
params(k)=BETA(k)
enddo
else
nparams=NP-1
do k=1,nparams
params(k)=BETA(k)
enddo
params(nparams)=BETA(NP)
endif
call surffunc(NQ,ymod,M,XPLUSD(I:I,1:M),
&nparams,params,dydxp(1:NQ,1:(M+nparams)),idowhat)
DO 110 L = 1,NQ
F(I,L)=ymod(L)
110 CONTINUE
100 CONTINUE
END IF
C COMPUTE DERIVATIVES WITH RESPECT TO BETA
IF (MOD(IDEVAL/10,10).GE.1) THEN
idowhat=2
DO 200 I = 1,N
if(I.le.ibreak)then
nparams=NP-1
do k=1,nparams
params(k)=BETA(k)
enddo
else
nparams=NP-1
do k=1,nparams
params(k)=BETA(k)
enddo
params(nparams)=BETA(NP)
endif
call surffunc(NQ,ymod,M,XPLUSD(I:I,1:M),
&nparams,params,dydxp(1:NQ,1:(M+nparams)),idowhat)
DO 210 L = 1,NQ
do k=1,nparams
FJACB(I,k,L)=dydxp(L,k)
enddo
if(I.le.ibreak)then
FJACB(I,NP,L)=0.0d0
else
FJACB(I,NP,L)=dydxp(L,nparams)
FJACB(I,nparams,L)=0.0d0
endif
210 CONTINUE
200 CONTINUE
ENDIF
c compute derivatives with respect to delta
IF (MOD(IDEVAL/100,10).GE.1) THEN
idowhat=1
DO 300 I = 1,N
if(I.le.ibreak)then
nparams=NP-1
do k=1,nparams
params(k)=BETA(k)
enddo
else
nparams=NP-1
do k=1,nparams
params(k)=BETA(k)
enddo
params(nparams)=BETA(NP)
endif
call surffunc(NQ,ymod,M,XPLUSD(I:I,1:M),
&nparams,params,dydxp(1:NQ,1:(M+nparams)),idowhat)
DO 310 L = 1,NQ
do k=1,M
FJACD(I,k,L)=dydxp(L,k)
enddo
310 CONTINUE
300 CONTINUE
ENDIF
RETURN
END
!$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
subroutine distcenter(nx,x,fequ,fvalue,idowhat)
implicit none
include 'leastdistance.h'
!idowhat=1, evaluating the system of equations and calculating the sum of squares.
!idowhat=2, calculating the distance.
integer nx,idowhat
double precision x(nx),fequ(nx),fvalue
!----------------------------------------------------------
integer i,j,ider
double precision y(my),dydxp(my,(nx+nparams)),
& xcopy(nx),sum,yplush(my),yminush(my),h
parameter(h=1.0d-7)
!==============End of Variable Declaration==================
j=0
call surffunc(my,y,nx,x,nparams,params,
& dydxp(1:my,1:(nx+nparams)),j)
if(idowhat.eq.1)then
if(iknowder.eq.1)then
call surffunc(my,y,nx,x,nparams,params,
& dydxp(1:my,1:(nx+nparams)),iknowder)
endif
if(iknowder.eq.0)then
do i=1,nx
xcopy(i)=x(i)
enddo
do i=1,nx
xcopy(i)=x(i)+h
call surffunc(my,yplush,nx,xcopy,nparams,params,
& dydxp(1:my,1:(nx+nparams)),iknowder)
xcopy(i)=x(i)-h
call surffunc(my,yminush,nx,xcopy,nparams,params,
& dydxp(1:my,1:(nx+nparams)),iknowder)
do j=1,my
dydxp(j,i)=(yplush(j)-yminush(j))/(2.0d0*h)
enddo
xcopy(i)=x(i)
enddo
endif
do i=1,nx
sum=0.0d0
do j=1,my
sum=sum+(y(j)-targety(j))*dydxp(j,i)
enddo
fequ(i)=x(i)-(targetx(i)-sum)
enddo
fvalue=0.0d0
do i=1,nx
fvalue=fvalue+fequ(i)*fequ(i)
enddo
endif
if(idowhat.eq.2)then
fvalue=0.0d0
do i=1,my
fvalue=fvalue+(y(i)-targety(i))**2
enddo
do i=1,nx
fvalue=fvalue+(x(i)-targetx(i))**2
enddo
endif
return
end subroutine distcenter
!$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
subroutine distcentersys(nunknowns,x,fequ,fsqsum)
implicit none
integer nunknowns,idowhat
double precision x(nunknowns),
& fequ(nunknowns),fsqsum
parameter(idowhat=1)
call distcenter(nunknowns,x,fequ,fsqsum,idowhat)
return
end subroutine distcentersys
!-----------------------------------------------------------
subroutine fsqsum_distcenter(nunknowns,x,fsqsum)
implicit none
integer nunknowns,idowhat
double precision x(nunknowns),fsqsum,
& fequ(nunknowns)
parameter(idowhat=1)
call distcenter(nunknowns,x,fequ,fsqsum,idowhat)
return
end
!-----------------------------------------------------------
double precision function f1dimsqsum_distcenter(x)
implicit none
double precision x
INTEGER j,idowhat
!((((((((((((((((((((((((((((((((((((((((((((((((((((
integer NMAX,ncom
parameter(NMAX=1000)
double precision pcom(NMAX),xicom(NMAX)
COMMON /cpf1com/ pcom,xicom,ncom
save /cpf1com/
!))))))))))))))))))))))))))))))))))))))))))))))))))))
double precision xt(NMAX),fequ(NMAX)
parameter(idowhat=1)
do 11 j=1,ncom
xt(j)=pcom(j)+x*xicom(j)
11 continue
call distcenter(ncom,xt,fequ,
& f1dimsqsum_distcenter,idowhat)
return
END
!------------------------------------------------------------
subroutine s2_distcenter(nunknowns,x,s2)
implicit none
integer nunknowns,idowhat
double precision x(nunknowns),s2,fequ(nunknowns)
parameter(idowhat=2)
call distcenter(nunknowns,x,fequ,s2,idowhat)
return
end
!-----------------------------------------------------------
double precision function f1dims2_distcenter(x)
implicit none
double precision x
INTEGER j,idowhat
!((((((((((((((((((((((((((((((((((((((((((((((((((((
integer NMAX,ncom
parameter(NMAX=1000)
double precision pcom(NMAX),xicom(NMAX)
COMMON /cpf1com/ pcom,xicom,ncom
save /cpf1com/
!))))))))))))))))))))))))))))))))))))))))))))))))))))
double precision xt(NMAX),fequ(NMAX)
parameter(idowhat=2)
do 11 j=1,ncom
xt(j)=pcom(j)+x*xicom(j)
11 continue
call distcenter(ncom,xt,fequ,
& f1dims2_distcenter,idowhat)
return
END
!$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
dataassim/math/optimization/NeuralNetRegres.f
+179
View File
@@ -0,0 +1,179 @@
subroutine NeuralNetRegres(idowhat,nx0,nobs0,nh0,xsamp0,
&ysamp0,yatxsamp0,rsq,w,bph,q,bend,xnew,ypred)
implicit none
include 'NeuralNetRegres.h'
!
!=============Inputs regardless of idowhat=========================
!idowhat: =1, fit the data and estimate the coefficients. Provide the
! initial guess for the coefficients or set bend to -9999
! =2, coefficients are already available, calculate y at xnew
!nx0: the number of independent (x) variables
!nobs0: the total number of samples
!nh0: the total number of hidden nodes to use. One hidden layer is
! assumed.
!============When idowhat=1========================================
! --------Inputs--------
!xsamp0: the values of the independent (x) variables
!ysamp0: the values of the dependent (y) variable. y is one dimension.
! --------Outputs-------
!w: the slope coefficient to time the normalized x in the activation function
!bph: the intercept coefficient in the activation function
!q: the coefficient to time the value of the activation function
!bend: the residual constant in the neural network regression
!yatxsamp0: the predicted y value at xsamp0
!rsq: R squared
!============When idowhat=2=========================================
! --------Inputs--------
!w: the slope coefficient to time the normalized x in the activation function
!bph: the intercept coefficient in the activation function
!q: the coefficient to time the value of the activation function
!bend: the residual constant in the neural network regression
!xnew: the new x point who y value is to be estimated (when idowhat=2)
! --------Outputs-------
!ypred: the predicted y value at xnew
!
integer idowhat,nx0,nobs0,nh0
double precision xsamp0(nobs0,nx0),ysamp0(nobs0),
& yatxsamp0(nobs0),rsq,w(nx0,nh0),bph(nh0),q(nh0),
& bend,xnew(nx0),ypred
!============Locals=========================================
integer i,j,ndim,ny,INFO,iderivative,iregrestype
!iregrestype=0, ordinary distance regression
double precision xnormk(nx0),xnormb(nx0),std,fmean,
& xmin,xmax,fatbeta,fatbeta0,fatbetacp,ftol,
& beta(nx0*nh0+2*nh0+1),betacp(nx0*nh0+2*nh0+1),rms,
& agrind,ran2,annfunc,weitx(1:nobs0,1:nx0),
& weity(1:nobs0),shortx(1:nobs0,1:nx0),
& shorty(1:nobs0),yv(nobs0),fn9999,tiny
parameter(ftol=1.0d-8,iderivative=1,iregrestype=0,
&fn9999=-9999.0d0,tiny=1.0d-8)
external funkmin_neural,f1dim_neural,FCN_neural
!
if(idowhat.eq.1)then
!Regression
nx=nx0
nobs=nobs0
nh=nh0
!xnormk: the slope of the linear transformation for xsamp0
!xnormb: the intercept of the linear transformation for xsamp0
!Transform xsamp to become bounded (-1,1) so that different independent variables
!are comparable in magnitude
!xmin ~ -1
!xmax ~ +1
do i=1,nobs
ysamp(i)=ysamp0(i)
weity(i)=1.0d0
do j=1,nx
weitx(i,j)=1.0d0
enddo
enddo
do i=1,nx
call stdmaxmeanmin(nobs,xsamp0(1:nobs,i:i),
& std,fmean,xmin,xmax)
if(xmax.eq.xmin)then
xnormk(i)=1.0d0
xnormb(i)=0.0d0
else
xnormk(i)=2.0d0/(xmax-xmin)
xnormb(i)=-(xmax+xmin)/(xmax-xmin)
endif
do j=1,nobs
xsamp(j,i)=xnormk(i)*xsamp0(j,i)+xnormb(i)
enddo
enddo
ndim=2*nh+nh*nx+1
do i=1,ndim
betamin(i)=-1.0d+20
betamax(i)=1.0d+20
enddo
if(dabs(bend-fn9999).lt.tiny)then
!no initial guess. Use the general guess
do i=1,ndim
beta(i)=(ran2()-0.5d0)*2.0d0
enddo
else
!initial guess provided. transform the guessed bph and w coefficients to correspond
!to the transformed x.
do i=1,nh0
do j=1,nx0
w(j,i)=w(j,i)/xnormk(j)
enddo
enddo
do i=1,nh0
do j=1,nx0
bph(i)=bph(i)-w(j,i)*xnormb(j)
enddo
enddo
call coeff_beta(2,nx,nh,beta,w(1:nx,1:nh),bph,q,bend)
endif
do i=1,ndim
betacp(i)=beta(i)
if(beta(i).lt.betamin(i).or.beta(i).gt.betamax(i))then
! write(*,*)'Inproper initial guess in NeuralNetRegres.f'
beta(i)=ran2()
endif
betacp(i)=beta(i)
enddo
call funkmin_neural(ndim,beta,fatbeta0)
INFO=iregrestype
ny=1
fatbeta=fatbeta0
90 call odr_leastsquare(ndim,FCN_neural,beta,nobs,
&xsamp(1:nobs,1:nx),nx,ysamp(1:nobs),ny,weitx(1:nobs,1:nx),
&weity(1:nobs),iderivative,shortx(1:nobs,1:nx),shorty(1:nobs),
&fatbeta,INFO)
call funkmin_neural(ndim,beta,fatbeta)
! if((fatbeta0-fatbeta).gt.ftol)then
! fatbeta0=fatbeta
! do i=1,ndim
! betacp(i)=beta(i)
! enddo
! goto 90
! endif
if(fatbeta.gt.fatbeta0)then
j=0
do i=1,ndim
beta(i)=betacp(i)
if(beta(i).lt.betamin(i).or.beta(i).gt.betamax(i))j=1
enddo
fatbeta=fatbeta0
if(j.ne.0)then
do i=1,ndim
beta(i)=(ran2()-0.5d0)*2.0d0
enddo
call funkmin_neural(ndim,beta,fatbeta)
endif
endif
100 fatbetacp=fatbeta
call nongradopt(ndim,funkmin_neural,f1dim_neural,
&beta,betamin,betamax,ftol,fatbeta)
! call RepeatCompassSearch(ndim,beta,fatbeta,
! &betamin,betamax,funkmin_neural,f1dim_neural,ftol)
! if(dabs(fatbetacp-fatbeta).gt.ftol)goto 100
call funkmin_neural(ndim,beta,fatbeta)
call coeff_beta(idowhat,nx,nh,beta,w(1:nx,1:nh),bph,q,bend)
!transform the estimated bph and w coefficients so that the original x
!values can be used directly.
do i=1,nh0
do j=1,nx0
bph(i)=bph(i)+w(j,i)*xnormb(j)
enddo
enddo
do i=1,nh0
do j=1,nx0
w(j,i)=w(j,i)*xnormk(j)
enddo
enddo
do i=1,nobs0
yatxsamp0(i)=annfunc(nx0,xsamp0(i:i,1:nx0),nh0,q,
& w(1:nx0,1:nh0),bph,bend)
enddo
call rsq_rms(ysamp0,yatxsamp0,nobs0,rsq,rms,agrind)
endif
if(idowhat.eq.2)then
!Predict y at x with the regression coefficients already estimated
ypred=annfunc(nx0,xnew,nh0,q,w(1:nx0,1:nh0),bph,bend)
endif
return
end
!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
dataassim/math/optimization/NeuralNetRegres.h
+9
View File
@@ -0,0 +1,9 @@
integer maxnobs,maxnx,maxnh
parameter(maxnx=30,maxnh=maxnx*10,maxnobs=maxnx*1000)
integer nx,nh,nobs
common /annintegers/nx,nh,nobs
double precision ysamp(maxnobs),xsamp(maxnobs,maxnx),
& betamin(maxnx*maxnh+2*maxnh),
& betamax(maxnx*maxnh+2*maxnh)
common /anndouble/ysamp,xsamp,betamin,betamax
dataassim/math/optimization/amebsa.f
+121
View File
@@ -0,0 +1,121 @@
SUBROUTINE amebsa(p,y,mp,np,ndim,pb,yb,ftol,funk,iter,temptr)
INTEGER iter,mp,ndim,np,NMAX
double precision ftol,temptr,yb,p(mp,np),pb(np),y(mp),funk
PARAMETER (NMAX=200)
EXTERNAL funk
CU USES amotsa,funk,ran1
INTEGER i,idum,ihi,ilo,inhi,j,m,n
double precision rtol,sum,swap,tt,yhi,ylo,ynhi,ysave,yt,ytry,
&psum(NMAX),amotsa,ran1
COMMON /ambsa/ tt,idum
tt=-temptr
1 do 12 n=1,ndim
sum=0.0d0
do 11 m=1,ndim+1
sum=sum+p(m,n)
11 continue
psum(n)=sum
12 continue
2 ilo=1
inhi=1
ihi=2
ylo=y(1)+tt*dlog(ran1(idum))
ynhi=ylo
yhi=y(2)+tt*dlog(ran1(idum))
if (ylo.gt.yhi) then
ihi=1
inhi=2
ilo=2
ynhi=yhi
yhi=ylo
ylo=ynhi
endif
do 13 i=3,ndim+1
yt=y(i)+tt*dlog(ran1(idum))
if(yt.le.ylo) then
ilo=i
ylo=yt
endif
if(yt.gt.yhi) then
inhi=ihi
ynhi=yhi
ihi=i
yhi=yt
else if(yt.gt.ynhi) then
inhi=i
ynhi=yt
endif
13 continue
rtol=2.0d0*dabs(yhi-ylo)/(dabs(yhi)+dabs(ylo))
if(rtol.lt.ftol.or.iter.lt.0) then
swap=y(1)
y(1)=y(ilo)
y(ilo)=swap
do 14 n=1,ndim
swap=p(1,n)
p(1,n)=p(ilo,n)
p(ilo,n)=swap
14 continue
return
endif
iter=iter-2
ytry=amotsa(p,y,psum,mp,np,ndim,pb,yb,funk,ihi,yhi,-1.0d0)
if (ytry.le.ylo) then
ytry=amotsa(p,y,psum,mp,np,ndim,pb,yb,funk,ihi,yhi,2.0d0)
else if (ytry.ge.ynhi) then
ysave=yhi
ytry=amotsa(p,y,psum,mp,np,ndim,pb,yb,funk,ihi,yhi,0.5d0)
if (ytry.ge.ysave) then
do 16 i=1,ndim+1
if(i.ne.ilo)then
do 15 j=1,ndim
psum(j)=0.5d0*(p(i,j)+p(ilo,j))
p(i,j)=psum(j)
15 continue
y(i)=funk(psum)
endif
16 continue
iter=iter-ndim
goto 1
endif
else
iter=iter+1
endif
goto 2
END
double precision FUNCTION amotsa
&(p,y,psum,mp,np,ndim,pb,yb,funk,ihi,yhi,fac)
INTEGER ihi,mp,ndim,np,NMAX
double precision amotsa,fac,yb,yhi,p(mp,np),pb(np),psum(np),
&y(mp),funk
PARAMETER (NMAX=200)
EXTERNAL funk
CU USES funk,ran1
INTEGER idum,j
double precision fac1,fac2,tt,yflu,ytry,ptry(NMAX),ran1
COMMON /ambsa/ tt,idum
fac1=(1.-fac)/ndim
fac2=fac1-fac
do 11 j=1,ndim
ptry(j)=psum(j)*fac1-p(ihi,j)*fac2
11 continue
ytry=funk(ptry)
if (ytry.le.yb) then
do 12 j=1,ndim
pb(j)=ptry(j)
12 continue
yb=ytry
endif
yflu=ytry-tt*log(ran1(idum))
if (yflu.lt.yhi) then
y(ihi)=ytry
yhi=yflu
do 13 j=1,ndim
psum(j)=psum(j)-p(ihi,j)+ptry(j)
p(ihi,j)=ptry(j)
13 continue
endif
amotsa=yflu
return
END
dataassim/math/optimization/annactivatefunc.f
+103
View File
@@ -0,0 +1,103 @@
!$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
double precision function annfunc(nparams,params,nh,q,w,bph,bend)
implicit none
integer nparams,nh
!nh is the number of hidden nodes in one hiden layer
!params is the inputs
!w is the weighting coefficients for the inputs
double precision params(nparams),q(nh),
&w(nparams,nh),bph(nh),bend
integer i,v
double precision term,activatefunc
annfunc=bend
do i=1,nh
term=bph(i)
do v=1,nparams
term=term+w(v,i)*params(v)
enddo
annfunc=annfunc+q(i)*activatefunc(term)
enddo
end
subroutine derannfunc(nparams,params,nh,q,w,bph,
& bend,derq,derw,derbph,derbend)
implicit none
integer nparams,nh
!nh is the number of hidden nodes in one hiden layer
!params is the inputs
!w is the weighting coefficients for the inputs
double precision params(nparams),q(nh),w(nparams,nh),
&bph(nh),bend,derq(nh),derw(nparams,nh),derbph(nh),derbend
integer i,v
double precision term,activatefunc,gradactivatefunc
derbend=1.0d0
do i=1,nh
term=bph(i)
do v=1,nparams
term=term+w(v,i)*params(v)
enddo
derq(i)=activatefunc(term)
derbph(i)=q(i)*gradactivatefunc(term)
do v=1,nparams
derw(v,i)=derbph(i)*params(v)
enddo
enddo
end
double precision function activatefunc(x)
implicit none
double precision x,crit
parameter(crit=300)
! activatefunc=2.0d0*datan(x)/3.14159265d0
! return
if(x.gt.-crit)then
activatefunc=1.0d0/(1.0d0+dexp(-x))
else
activatefunc=dexp(x)/(1.0d0+dexp(x))
endif
return
end
double precision function gradactivatefunc(x)
implicit none
double precision x,crit
parameter(crit=600)
! gradactivatefunc=2.0d0/(3.14159265d0*(1.0d0+x*x))
! return
if(x.gt.-crit.and.x.lt.crit)then
gradactivatefunc=
& (1.0d0/(dexp(x/2.0d0)+dexp(-x/2.0d0)))**2
else
gradactivatefunc=0.0d0
endif
return
end
subroutine gradannfunc(nparams,params,nh,q,w,bph,
&der_params)
implicit none
integer nparams,nh
double precision params(nparams),der_params(nparams),
&q(nh),w(nparams,nh),bph(nh)
integer i,v
double precision term,dsigdterm,
& gradactivatefunc,activatefunc
do i=1,nparams
der_params(i)=0.0d0
enddo
do i=1,nh
term=bph(i)
do v=1,nparams
term=term+w(v,i)*params(v)
enddo
dsigdterm=gradactivatefunc(term)
do v=1,nparams
der_params(v)=der_params(v)+q(i)*dsigdterm*w(v,i)
enddo
enddo
return
end
dataassim/math/optimization/coeff_beta.f
+49
View File
@@ -0,0 +1,49 @@
subroutine coeff_beta(idowhat,nx,nh,BETA,w,bph,q,bend)
implicit none
!idowhat=1, allocate BETA to w, bph, q
! =2, allocate w, bph, q to BETA
!
integer k,i,nx,nh,j,idowhat
double precision w(1:nx,1:nh),bph(nh),q(nh),
& bend,BETA(nx*nh+2*nh+1)
if(idowhat.eq.1)then
k=0
do i=1,nx
do j=1,nh
k=k+1
w(i,j)=BETA(k)
enddo
enddo
do i=1,nh
k=k+1
bph(i)=BETA(k)
enddo
do i=1,nh
k=k+1
q(i)=BETA(k)
enddo
k=k+1
bend=BETA(k)
endif
!
if(idowhat.eq.2)then
k=0
do i=1,nx
do j=1,nh
k=k+1
BETA(k)=w(i,j)
enddo
enddo
do i=1,nh
k=k+1
BETA(k)=bph(i)
enddo
do i=1,nh
k=k+1
BETA(k)=q(i)
enddo
k=k+1
BETA(k)=bend
endif
return
end
dataassim/math/optimization/cpCompassSearch.f
+198
View File
@@ -0,0 +1,198 @@
subroutine cpRepeatCompassSearch(ndim,xbest,fbest,
& bmin,bmax,funkmin,f1dim,xtol)
implicit none
integer ndim
double precision xbest(1:ndim),fbest,
& bmin(1:ndim),bmax(1:ndim),xtol
double precision fvalpre,dmax,xpre(1:ndim),ftol,direction(ndim)
parameter(ftol=1.0d-7)
integer i,n
logical resetran2
common /cpran2reset/resetran2
external funkmin,f1dim
!
n=0
resetran2=.true.
10 fvalpre=fbest
do i=1,ndim
xpre(i)=xbest(i)
enddo
call cpCompassSearch(ndim,xbest,fbest,
& bmin,bmax,funkmin,f1dim,xtol)
n=n+1
dmax=dabs(xbest(1)-xpre(1))
do i=2,ndim
if(dmax.lt.dabs(xbest(i)-xpre(i)))then
dmax=dabs(xbest(i)-xpre(i))
endif
enddo
if(dabs(fvalpre-fbest).gt.ftol.and.
& dmax.gt.xtol.and.n.lt.5000)then
do i=1,ndim
direction(i)=xbest(i)-xpre(i)
enddo
call linmin(xbest,bmin,bmax,direction,
& ndim,f1dim,fbest)
goto 10
endif
return
end subroutine cpRepeatCompassSearch
subroutine cpCompassSearch(ndim,xbest,fbest,
& bmin,bmax,funkmin,f1dim,xtol)
implicit none
! This subroutine minimizes the function funkmin using the compass search method. The ! maximum number of function evaluations is maxiter. Once mexiter is reached, all
! function evaluations are ranked and returned.
!
!------------------------------------- Inputs -----------------------------------------------------
! maxiter: the maximum number of function evaluations allowed
! xbest: the initial guess
! fbest: the cost function value at xinitial
! bmin: the lower bounds of the parameters to be optimized
! bmax: the upper bounds of the parameters to be optimized
! ndim: the number of parameters to optimize
! funkmin: the name of the function to minimize
!------------------------------------- Outputs ---------------------------------------------------
! xobs: points where the function is evaluated. Ranked from the best to worst with the
! first point being the best point.
! fvalue: the function values at xobs
! ierr: =0 convergence criterion not reached
! =1 convergence criterion reached (minimum found)
!
integer ndim
double precision xbest(1:ndim),fbest,
& bmin(1:ndim),bmax(1:ndim),xtol,dx1,dx2
external funkmin,f1dim
!------------------------------- Locals -----------------------------------------------------------
double precision diftol,delta,
& xcompass(1:2*ndim,1:ndim),fcompass(1:2*ndim),
& xvec(1:ndim),xcent(1:ndim),fcent,dif,shrink,
& direction(ndim),dmax,fcent0,cpran2_reset
parameter(shrink=0.618d0,diftol=1.0d-7)
integer i,j,k
!
delta=0.618d0
do i=1,ndim
xcent(i)=xbest(i)
enddo
fcent=fbest
10 continue
do i=1,ndim
do j=1,ndim
xcompass(i,j)=xcent(j)
xcompass(ndim+i,j)=xcent(j)
enddo
xcompass(i,i)=xcent(i)+delta*(bmax(i)-xcent(i))
xcompass(ndim+i,i)=xcent(i)+delta*(bmin(i)-xcent(i))
enddo
do i=1,2*ndim
do j=1,ndim
xvec(j)=xcompass(i,j)
enddo
call funkmin(ndim,xvec,fcompass(i))
enddo
do i=1,ndim
xbest(i)=xcompass(1,i)
enddo
fbest=fcompass(1)
do i=2,2*ndim
if(fcompass(i).lt.fbest)then
fbest=fcompass(i)
do j=1,ndim
xbest(j)=xcompass(i,j)
enddo
endif
enddo
fcent0=fcent
do i=1,ndim
xvec(i)=xcent(i)
enddo
do i=1,ndim
dx1=xcompass(i,i)-xcent(i)
dx2=xcent(i)-xcompass(i+ndim,i)
direction(i)=0.0d0
if(dx1.ne.0.0d0)then
direction(i)=(fcompass(i)-fcent)/dx1
endif
if(dx2.ne.0.0d0)then
direction(i)=direction(i)+
& (fcent-fcompass(i+ndim))/dx2
endif
direction(i)=-0.5d0*direction(i)
if(direction(i).eq.0.0d0)direction(i)=
& cpran2_reset()-0.5d0
enddo
call cplinmin(xcent,bmin,bmax,direction,
& ndim,f1dim,fcent)
if(fcent.gt.fcent0)then
fcent=fcent0
do i=1,ndim
xcent(i)=xvec(i)
enddo
endif
dif=fcent-fbest
if(fbest.le.fcent)then
fcent=fbest
do i=1,ndim
xcent(i)=xbest(i)
enddo
endif
if(dif.ge.0.0d0)then
if(dif.gt.diftol)goto 10
if(delta.lt.diftol)goto 100
delta=delta*shrink
goto 10
else
!no progress
if(dabs(dif).gt.diftol)then
if(delta.lt.diftol)goto 100
delta=delta*shrink
goto 10
endif
dmax=dabs(xcompass(1,1)-xcompass(ndim+1,1))
do i=2,ndim
if(dmax.lt.dabs(xcompass(i,i)-
& xcompass(ndim+i,i)))then
dmax=dabs(xcompass(i,i)-
& xcompass(ndim+i,i))
endif
enddo
if(dmax.gt.xtol)then
if(delta.lt.diftol)goto 100
delta=delta*shrink
goto 10
else
goto 100
endif
endif
100 fbest=fcent
do i=1,ndim
xbest(i)=xcent(i)
dx1=xcompass(i,i)-xcent(i)
dx2=xcent(i)-xcompass(i+ndim,i)
direction(i)=0.0d0
if(dx1.ne.0.0d0)then
direction(i)=(fcompass(i)-fcent)/dx1
endif
if(dx2.ne.0.0d0)then
direction(i)=direction(i)+
& (fcent-fcompass(i+ndim))/dx2
endif
direction(i)=-0.5d0*direction(i)
if(direction(i).eq.0.0d0)direction(i)=
& cpran2_reset()-0.5d0
enddo
call cplinmin(xcent,bmin,bmax,direction,
& ndim,f1dim,fcent)
if(fcent.lt.fbest)then
fbest=fcent
do i=1,ndim
xbest(i)=xcent(i)
enddo
endif
return
end subroutine cpCompassSearch
dataassim/math/optimization/cpnongradopt.f
+247
View File
@@ -0,0 +1,247 @@
subroutine cpnongradopt(ndim,funkmin,f1dim,beta,
& bmin,bmax,ftol,fatbeta)
implicit none
!
! This subroutine minimizes function funkmin to estimate ndim parameters
! using non-gradient based methods
!
integer ndim
double precision beta(1:ndim),bmin(1:ndim),
& bmax(1:ndim),ftol,fatbeta
!
! ------------------ Inputs -----------------------------
! ndim: the total number of parameters to be estimated
! bmax: the maximum possible value of beta, used to determine the distance scaling factor
! bmin: the minimum possible value of beta, used to determine the distance scaling factor
! beta: initial guess, overwritten upon return
! ftol: tolerance for convergence
! fatbeta: the cost function valuate at beta, overwritten upon return
! funkmin is the name of the subroutine that computes the cost function
! f1dim: the one dimensional cost function
! ------------------ Outputs ----------------------------
! beta: The best parameters obtained
! fatbeta: the cost function value at beta
integer n,nn,mpamoeba,npamoeba,iredo,maxredo,ITMAX,
& icycle
parameter(maxredo=20,ITMAX=20000)
double precision fbest,xbest(1:ndim),
& xinidir(1:ndim,1:ndim),xbest0(1:ndim),
& pamoeba(1:ndim+1,1:ndim),famoeba(1:ndim+1)
external funkmin,f1dim
! End of declaration of variables
!---------------------------------------------------------------
icycle=0
1 iredo=0
3 do n=1,ndim
xbest(n)=beta(n)
do nn=1,ndim
xinidir(n,nn)=0.0d0
enddo
xinidir(n,n)=1.0d0
enddo
fbest=fatbeta
call cppowell(beta,xinidir(1:ndim,1:ndim),ndim,
&ndim,ftol,fatbeta,bmin,bmax,funkmin,f1dim,ITMAX)
if(fatbeta.gt.fbest)then
do n=1,ndim
beta(n)=xbest(n)
enddo
fatbeta=fbest
goto 10
endif
if((fbest-fatbeta).gt.ftol)then
if(iredo.gt.maxredo)goto 10
iredo=iredo+1
goto 3
endif
10 iredo=0
20 do n=1,ndim
xbest(n)=beta(n)
enddo
fbest=fatbeta
do nn=1,ndim
pamoeba(1,nn)=beta(nn)
enddo
famoeba(1)=fatbeta
do n=2,ndim+1
do nn=1,ndim
pamoeba(n,nn)=beta(nn)
enddo
if((bmax(n-1)-pamoeba(n,n-1))
& .gt.(pamoeba(n,n-1)-bmin(n-1)))then
pamoeba(n,n-1)=pamoeba(n,n-1)+
& (bmax(n-1)-pamoeba(n,n-1))*0.1d0
else
pamoeba(n,n-1)=pamoeba(n,n-1)-
& (pamoeba(n,n-1)-bmin(n-1))*0.1d0
endif
do nn=1,ndim
xbest0(nn)=pamoeba(n,nn)
enddo
call funkmin(ndim,xbest0,famoeba(n))
enddo
mpamoeba=ndim+1
npamoeba=ndim
call cpguamoeba(pamoeba(1:ndim+1,1:ndim),
& famoeba(1:ndim+1),mpamoeba,npamoeba,ndim,
& ftol,funkmin,ITMAX/20)
nn=1
do n=2,ndim+1
if(famoeba(n).lt.famoeba(nn))nn=n
enddo
fatbeta=famoeba(nn)
do n=1,ndim
beta(n)=pamoeba(nn,n)
if(beta(n).lt.bmin(n).or.beta(n).gt.bmax(n))then
do nn=1,ndim
beta(nn)=xbest(nn)
enddo
fatbeta=fbest
return
endif
enddo
if((fbest-fatbeta).gt.ftol)then
if(iredo.gt.maxredo)then
if(icycle.lt.maxredo)then
icycle=icycle+1
goto 1
else
return
endif
endif
iredo=iredo+1
goto 20
endif
return
end subroutine cpnongradopt
!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
SUBROUTINE cpguamoeba(p,y,mp,np,ndim,ftol,funkmin,ITMAX)
implicit none
INTEGER iter,mp,ndim,np,NMAX,ITMAX
double precision ftol,p(mp,np),y(mp),TINY
PARAMETER (TINY=1.0d-20)
external funkmin
CU USES cpguamotry,funkmin
INTEGER i,ihi,ilo,inhi,j,m,n
double precision rtol,sum,swap,ysave,ytry,psum(ndim),
& cpguamotry,degen
iter=0
1 do 12 n=1,ndim
sum=0.0d0
do 11 m=1,ndim+1
sum=sum+p(m,n)
11 continue
psum(n)=sum
12 continue
2 ilo=1
if (y(1).gt.y(2)) then
ihi=1
inhi=2
else
ihi=2
inhi=1
endif
do 13 i=1,ndim+1
if(y(i).le.y(ilo)) ilo=i
if(y(i).gt.y(ihi)) then
inhi=ihi
ihi=i
else if(y(i).gt.y(inhi)) then
if(i.ne.ihi) inhi=i
endif
13 continue
rtol=2.0d0*dabs(y(ihi)-y(ilo))/
& (dabs(y(ihi))+dabs(y(ilo))+TINY)
if (rtol.lt.ftol) then
swap=y(1)
y(1)=y(ilo)
y(ilo)=swap
do 14 n=1,ndim
swap=p(1,n)
p(1,n)=p(ilo,n)
p(ilo,n)=swap
14 continue
return
endif
! check to see if the simplex is degenerate; if so, stop
degen=0.0d0
do i=1,mp
do m=i+1,mp
do n=1,np
if(dabs(p(m,n)-p(i,n)).gt.degen)then
degen=dabs(p(m,n)-p(i,n))
endif
enddo
enddo
enddo
if(degen.lt.ftol*ftol)then
swap=y(1)
y(1)=y(ilo)
y(ilo)=swap
do n=1,ndim
swap=p(1,n)
p(1,n)=p(ilo,n)
p(ilo,n)=swap
enddo
return
endif
if(iter.ge.ITMAX)return
iter=iter+2
ytry=cpguamotry(p,y,psum,mp,np,ndim,funkmin,ihi,-1.0d0)
if (ytry.le.y(ilo))then
ytry=cpguamotry(p,y,psum,mp,np,ndim,funkmin,ihi,2.0d0)
else if (ytry.ge.y(inhi)) then
ysave=y(ihi)
ytry=cpguamotry(p,y,psum,mp,np,ndim,funkmin,ihi,0.5d0)
if (ytry.ge.ysave) then
do 16 i=1,ndim+1
if(i.ne.ilo)then
do 15 j=1,ndim
psum(j)=0.5d0*(p(i,j)+p(ilo,j))
p(i,j)=psum(j)
15 continue
call funkmin(ndim,psum,y(i))
endif
16 continue
iter=iter+ndim
goto 1
endif
else
iter=iter-1
endif
goto 2
END
C (C) Copr. 1986-92 Numerical Recipes Software v%1jw#<0(9p#3.
DOUBLE PRECISION FUNCTION cpguamotry(p,y,psum,
& mp,np,ndim,funkmin,ihi,fac)
implicit none
INTEGER ihi,mp,ndim,np
double precision fac,p(mp,np),psum(np),y(mp)
EXTERNAL funkmin
CU USES funkmin
INTEGER j
double precision fac1,fac2,ytry,ptry(ndim)
fac1=(1.0d0-fac)/dble(ndim)
fac2=fac1-fac
do 11 j=1,ndim
ptry(j)=psum(j)*fac1-p(ihi,j)*fac2
11 continue
call funkmin(ndim,ptry,ytry)
if (ytry.lt.y(ihi)) then
y(ihi)=ytry
do 12 j=1,ndim
psum(j)=psum(j)-p(ihi,j)+ptry(j)
p(ihi,j)=ptry(j)
12 continue
endif
cpguamotry=ytry
return
END
C (C) Copr. 1986-92 Numerical Recipes Software v%1jw#<0(9p#3.
c#######################################################################
dataassim/math/optimization/cpodr_leastsquare.f
+152
View File
@@ -0,0 +1,152 @@
!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
subroutine cpodr_leastsquare(nparams,FCN,params,
& npoints,xobs,yobs,iderivative,INFO)
implicit none
!if derivatives are provided, set iderivative to 1, otherwise set it to 0
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,i1,i2,i3,i4,i5,nparams,iderivative
double precision yobs(npoints),xobs(npoints),
& params(nparams)
EXTERNAL FCN
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
if(iderivative.eq.0)then
!no derivatives provided, using central finite difference
JOB=13
else
JOB=43
endif
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 = 107
LUNRPT = 108
c
N=npoints
NP=nparams
M=1
NQ=1
do I=1,NP
BETA(I)=params(I)
enddo
do I=1,N
X(I,1)=xobs(I)
Y(I,1)=yobs(I)
enddo
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(FCN,
+ 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
do I=1,NP
params(I)=BETA(I)
enddo
return
END
dataassim/math/optimization/cppowell.f
+344
View File
@@ -0,0 +1,344 @@
SUBROUTINE cppowell(p,xi,n,np,ftol,fret,pmin,pmax,
& funkmin,f1dim,ITMAX)
! fret must be given on entry
implicit none
INTEGER iter,n,np,NMAX,ITMAX
double precision fret,ftol,p(np),xi(np,np),TINY,
& pmin(np),pmax(np)
PARAMETER (NMAX=1000,TINY=1.0d-25)
CU USES funkmin,linmin
INTEGER i,ibig,j
double precision del,fp,fptt,t,pt(NMAX),
& ptt(NMAX),xit(NMAX)
external funkmin,f1dim
do 11 j=1,n
pt(j)=p(j)
11 continue
iter=0
1 iter=iter+1
fp=fret
ibig=0
del=0.0d0
do 13 i=1,n
do 12 j=1,n
xit(j)=xi(j,i)
12 continue
fptt=fret
call cplinmin(p,pmin,pmax,xit,n,f1dim,fret)
if(fptt-fret.gt.del)then
del=fptt-fret
ibig=i
endif
13 continue
if(2.0d0*(fp-fret).le.ftol*(dabs(fp)+dabs(fret))+TINY)return
if(iter.eq.ITMAX)then
! write(*,*)'powell exceeding maximum iterations'
return
endif
do 14 j=1,n
ptt(j)=2.0d0*p(j)-pt(j)
xit(j)=p(j)-pt(j)
pt(j)=p(j)
14 continue
call funkmin(n,ptt,fptt)
if(fptt.ge.fp)goto 1
t=2.0d0*(fp-2.0d0*fret+fptt)*(fp-fret-del)**2-
& del*(fp-fptt)**2
if(t.ge.0.0d0)goto 1
call cplinmin(p,pmin,pmax,xit,n,f1dim,fret)
do 15 j=1,n
xi(j,ibig)=xi(j,n)
xi(j,n)=xit(j)
15 continue
goto 1
END
C (C) Copr. 1986-92 Numerical Recipes Software v%1jw#<0(9p#3.
SUBROUTINE cplinmin(p,pmin,pmax,xi,n,f1dim,fret)
implicit none
INTEGER n
double precision fret,p(n),xi(n),TOL,pmin(n),pmax(n)
PARAMETER (TOL=1.0d-8)
CU USES brent,f1dim,mnbrak
INTEGER j,k,ierr
double precision ax,bx,fa,fb,fx,xmin,xx,cpbrent,xxmin,xxmax
!((((((((((((((((((((((((((((((((((((((((((((((((((((
integer NMAX,ncom
parameter(NMAX=1000)
double precision pcom(NMAX),xicom(NMAX)
COMMON /cpf1com/ pcom,xicom,ncom
save /cpf1com/
!))))))))))))))))))))))))))))))))))))))))))))))))))))
EXTERNAL f1dim
ncom=n
do j=1,n
pcom(j)=p(j)
xicom(j)=xi(j)
enddo
xxmax=1.0d+100
xxmin=-1.0d+100
do j=1,n
if(xicom(j).gt.1.0d-100)then
! if(xicom(j).gt.0.0d0)then
xx=(pmax(j)-pcom(j))/xicom(j)
ax=(pmin(j)-pcom(j))/xicom(j)
else
if(xicom(j).lt.(-1.0d-100))then
! if(xicom(j).lt.0.0d0)then
ax=(pmax(j)-pcom(j))/xicom(j)
xx=(pmin(j)-pcom(j))/xicom(j)
else
xx=1.0d+100
ax=-1.0d+100
endif
endif
if(xxmax.gt.xx)then
xxmax=xx
endif
if(xxmin.lt.ax)then
xxmin=ax
endif
enddo
ax=0.0d0
if(dabs(xxmax).gt.dabs(xxmin))then
xx=0.25d0*xxmax
else
xx=0.25d0*xxmin
endif
call cpmnbrak(ax,xx,bx,fa,fx,fb,
& xxmin,xxmax,ierr,f1dim)
if(ierr.eq.0)then
fret=cpbrent(ax,xx,bx,f1dim,TOL,xmin)
else
xmin=xx
fret=fx
endif
do 12 j=1,n
xi(j)=xmin*xi(j)
p(j)=p(j)+xi(j)
12 continue
return
END
C (C) Copr. 1986-92 Numerical Recipes Software v%1jw#<0(9p#3.
!
double precision function cpbrent(ax,bx,cx,f,tol,xmin)
implicit none
INTEGER ITMAX
double precision ax,bx,cx,tol,xmin,f,CGOLD,ZEPS
EXTERNAL f
PARAMETER (ITMAX=10000,CGOLD=.381966d0,ZEPS=1.0d-10)
INTEGER iter
double precision a,b,d,e,etemp,fu,fv,fw,fx,p,q,r,tol1,
& tol2,u,v,w,x,xm
a=dmin1(ax,cx)
b=dmax1(ax,cx)
v=bx
w=v
x=v
e=0.0d0
fx=f(x)
fv=fx
fw=fx
do 11 iter=1,ITMAX
xm=0.5d0*(a+b)
tol1=tol*dabs(x)+ZEPS
tol2=2.0d0*tol1
if(dabs(x-xm).le.(tol2-.5d0*(b-a))) goto 3
if(dabs(e).gt.tol1) then
r=(x-w)*(fx-fv)
q=(x-v)*(fx-fw)
p=(x-v)*q-(x-w)*r
q=2.0d0*(q-r)
if(q.gt.0.0d0) p=-p
q=dabs(q)
etemp=e
e=d
if(dabs(p).ge.dabs(.5d0*q*etemp).or.
& p.le.q*(a-x).or.p.ge.q*(b-x))goto 1
d=p/q
u=x+d
if(u-a.lt.tol2.or.b-u.lt.tol2)d=dsign(tol1,xm-x)
goto 2
endif
1 if(x.ge.xm)then
e=a-x
else
e=b-x
endif
d=CGOLD*e
2 if(dabs(d).ge.tol1) then
u=x+d
else
u=x+dsign(tol1,d)
endif
fu=f(u)
if(fu.le.fx)then
if(u.ge.x)then
a=x
else
b=x
endif
v=w
fv=fw
w=x
fw=fx
x=u
fx=fu
else
if(u.lt.x) then
a=u
else
b=u
endif
if(fu.le.fw.or.w.eq.x)then
v=w
fv=fw
w=u
fw=fu
else if(fu.le.fv.or.v.eq.x.or.v.eq.w)then
v=u
fv=fu
endif
endif
11 continue
! write(*,*) 'brent exceed maximum iterations'
3 xmin=x
cpbrent=fx
return
END
C (C) Copr. 1986-92 Numerical Recipes Software v%1jw#<0(9p#3.
! double precision function f1dim(x)
! implicit none
! double precision x
!CU USES funkmin
! INTEGER j
!((((((((((((((((((((((((((((((((((((((((((((((((((((
! integer NMAX,ncom
! parameter(NMAX=1000)
! double precision pcom(NMAX),xicom(NMAX)
! COMMON /cpf1com/ pcom,xicom,ncom
! save /cpf1com/
!))))))))))))))))))))))))))))))))))))))))))))))))))))
! double precision xt(NMAX)
! do 11 j=1,ncom
! xt(j)=pcom(j)+x*xicom(j)
!11 continue
! call funkmin(ncom,xt,f1dim)
! return
! END
!C (C) Copr. 1986-92 Numerical Recipes Software v%1jw#<0(9p#3.
SUBROUTINE cpmnbrak(ax,bx,cx,fa,fb,fc,xxmin,xxmax,
& ierr,func)
implicit none
double precision ax,bx,cx,fa,fb,fc,
& func,GOLD,GLIMIT,TINY
EXTERNAL func
PARAMETER(GOLD=1.618034d0,GLIMIT=100.0d0,TINY=1.0d-20)
double precision dum,fu,q,r,u,ulim,xxmin,xxmax
integer ierr
ierr=0
fa=func(ax)
fb=func(bx)
if(fb.gt.fa)then
dum=ax
ax=bx
bx=dum
dum=fb
fb=fa
fa=dum
endif
if(fa.eq.fb)then
cx=(bx+ax)/2.0d0
fc=func(cx)
if(fc.le.fa)return
endif
cx=bx+GOLD*(bx-ax)
if(cx.le.xxmin)then
cx=0.5d0*(dmin1(ax,bx)+xxmin)
endif
if(cx.ge.xxmax)then
cx=0.5d0*(dmax1(ax,bx)+xxmax)
endif
fc=func(cx)␍
1 if(fb.ge.fc)then
r=(bx-ax)*(fb-fc)
q=(bx-cx)*(fb-fa)
u=bx-((bx-cx)*q-(bx-ax)*r)/
& (2.0d0*dsign(dmax1(dabs(q-r),TINY),q-r))
ulim=bx+GLIMIT*(cx-bx)
if(ulim.ge.xxmax)then
ulim=xxmax-tiny
endif
if(ulim.le.xxmin)then
ulim=xxmin+tiny
endif
if((bx-u)*(u-cx).gt.0.0d0)then
fu=func(u)
if(fu.lt.fc)then
ax=bx
fa=fb
bx=u
fb=fu
return
elseif(fu.gt.fb)then
cx=u
fc=fu
return
endif
u=cx+GOLD*(cx-bx)
if(u.gt.xxmax)then
u=cx+0.5d0*(xxmax-cx)
endif
if(u.lt.xxmin)then
u=cx+0.5d0*(xxmin-cx)
endif
fu=func(u)
elseif((cx-u)*(u-ulim).gt.0.0d0)then
fu=func(u)
if(fu.lt.fc)then
bx=cx
cx=u
u=cx+GOLD*(cx-bx)
if(u.gt.xxmax)then
u=cx+0.5d0*(xxmax-cx)
endif
if(u.lt.xxmin)then
u=cx+0.5d0*(xxmin-cx)
endif
fb=fc
fc=fu
fu=func(u)
endif
else if((u-ulim)*(ulim-cx).ge.0.0d0)then
u=ulim
fu=func(u)
else
u=cx+GOLD*(cx-bx)
if(u.gt.xxmax)then
u=cx+0.5d0*(xxmax-cx)
endif
if(u.lt.xxmin)then
u=cx+0.5d0*(xxmin-cx)
endif
fu=func(u)
endif
ax=bx
bx=cx
cx=u
fa=fb
fb=fc
fc=fu
r=dmin1(dabs(ax-bx),dabs(ax-cx))
r=dmin1(r,dabs(bx-cx))
if(r.lt.tiny)then
! bracketing failed
ierr=1
return
endif
goto 1
endif
return
END
C (C) Copr. 1986-92 Numerical Recipes Software v%1jw#<0(9p#3.
dataassim/math/optimization/d_odr.f
+13439
View File
File diff suppressed because it is too large Load Diff
dataassim/math/optimization/dble_pikaia.f
+1177
View File
File diff suppressed because it is too large Load Diff
dataassim/math/optimization/distancesys.f
+119
View File
@@ -0,0 +1,119 @@
subroutine distancesys(nunknowns,scldxp,
& scldfequ,scldfsqsum,idowhat)
implicit none
!
!--------------------- Variables through arguments -------------------------
!(in) nunknowns: the number of unknowns and non-linear equations
!(in) scldxp(1:nunknowns): the scaled unknowns in the nonlinear system
!(out) scldfequ(1:nunknowns): the scaled function values evaluated at imported unknowns
!(out) scldfsqsum: half of the sum of the squared scaled function values.
integer nunknowns,idowhat
double precision scldxp(1:nunknowns),
& scldfequ(1:nunknowns),scldfsqsum
!--------------------------- Local variables-----------------------------------
integer i,j,numys
parameter
double precision xvar(nunknowns),xscalingfact(nunknowns),
& xtarget(nunknowns),yvar(numys),yscalingfact(numys),
& ytarget(numys),diffy(numys)
!^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
do i=1,nunknowns
scalingfact(i)=1.0d0
xvar(i)=scldxp(i)/xscalingfact(i)
enddo
call surface(numys,yvar,nunknowns,xvar)
do i=1,numys
diff(i)=yvar(i)-ytarget(i)
endif
if(idowhat.eq.1)then
scldfsqsum=0.0d0
do i=1,nunknowns
scldfequ(i)=scldfequ(i)*scalingfact(i)
scldfsqsum=scldfsqsum+scldfequ(i)*scldfequ(i)
enddo
scldfsqsum=0.5d0*scldfsqsum
endif
if(idowhat.eq.2)then
return
end subroutine leafsys
subroutine surface(numys,ysurface,nunknowns,xvar)
implicit none
integer numys,nunknowns
double precision ysurface(numys),xvar(nunknowns)
ysurface(1)=xvar(1)
return
end
!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
subroutine sqsum_fequ(nunknowns,xp,fequsqsum)
!This subroutine returns half of the sum of the squared equation residues
implicit none
integer nunknowns
double precision xp(nunknowns),fequsqsum,
& fequ(nunknowns)
integer idowhat
parameter(idowhat=1)
call distancesys(nunknowns,xp,fequ,fequsqsum,idowhat)
return
end
double precision function cpf1dim_fequ(x)
!this function subroutine returns half of the sum of the squared equation residues for line search
INTEGER NMAX
double precision x
PARAMETER (NMAX=1000)
INTEGER j,ncom,idowhat
parameter(idowhat=1)
double precision pcom(NMAX),xicom(NMAX),
& xt(NMAX),fequ(NMAX)
COMMON /cpf1com/ pcom,xicom,ncom
save /cpf1com/
do 11 j=1,ncom
xt(j)=pcom(j)+x*xicom(j)
11 continue
call distancesys(ncom,xt,fequ,cpf1dim_fequ,idowhat)
return
END
subroutine getequationvalues((nunknowns,xp,
& fequ,fequsqsum)
!this subroutine is for solving a nonlinear system
implicit none
integer nunknowns,idowhat
double precision xp(nunknowns),fequ(nunknowns),fequsqsum
parameter(idowhat=1)
call distancesys(nunknowns,xp,fequ,fequsqsum,idowhat)
return
end
subroutine getsqdistance(nunknowns,xp,sqdistance)
!This subroutine returns the distance between a point on a curve (surface) and another point
!that is specified in distancesys
implicit none
integer nunknowns,idowhat
double precision xp(nunknowns),sqdistance,fequ(nunknowns)
parameter(idowhat=2)
call distancesys(nunknowns,xp,fequ,sqdistance,idowhat)
return
end
double precision function cpf1dim_distance(x)
!this function subroutine returns the distance for line search
INTEGER NMAX
double precision x
PARAMETER (NMAX=1000)
INTEGER j,ncom,idowhat
parameter(idowhat=2)
double precision pcom(NMAX),xicom(NMAX),
& xt(NMAX),fequ(NMAX)
COMMON /cpf1com/ pcom,xicom,ncom
save /cpf1com/
do 11 j=1,ncom
xt(j)=pcom(j)+x*xicom(j)
11 continue
call distancesys(ncom,xt,fequ,cpf1dim_distance,idowhat)
return
END
!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
dataassim/math/optimization/dualannactivatefunc.f
+122
View File
@@ -0,0 +1,122 @@
!$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
double precision function
&annfunc(nparams,params,nh,q,w,bph,bend,c)
implicit none
integer nparams,nh
!nh is the number of hidden nodes in one hiden layer
!params is the inputs
!w is the weighting coefficients for the inputs
double precision params(nparams),q(nh),
& w(nparams,nh),bph(nh),bend,c(nh)
integer i,v
double precision term,activatefunc1,activatefunc2
annfunc=bend
do i=1,nh
term=bph(i)
do v=1,nparams
term=term+w(v,i)*params(v)
enddo
annfunc=annfunc+q(i)*activatefunc1(term)+
&c(i)*activatefunc2(term)
enddo
end
subroutine derannfunc(nparams,params,nh,q,w,bph,
& bend,c,derq,derw,derbph,derbend,derc)
implicit none
integer nparams,nh
!nh is the number of hidden nodes in one hiden layer
!params is the inputs
!w is the weighting coefficients for the inputs
double precision params(nparams),q(nh),
& w(nparams,nh),bph(nh),bend,c(nh),derq(nh),
& derw(nparams,nh),derbph(nh),derbend,derc(nh)
integer i,v
double precision term,activatefunc1,gradactivatefunc1,
&activatefunc2,gradactivatefunc2
derbend=1.0d0
do i=1,nh
term=bph(i)
do v=1,nparams
term=term+w(v,i)*params(v)
enddo
derq(i)=activatefunc1(term)
derc(i)=activatefunc2(term)
derbph(i)=q(i)*gradactivatefunc1(term)+
& c(i)*gradactivatefunc2(term)
do v=1,nparams
derw(v,i)=derbph(i)*params(v)
enddo
enddo
end
subroutine gradannfunc(nparams,params,nh,q,w,bph,
& c,der_params)
implicit none
integer nparams,nh
double precision params(nparams),der_params(nparams),
& q(nh),w(nparams,nh),bph(nh),c(nh)
integer i,v
double precision term,gradactivatefunc1,gradactivatefunc2
do i=1,nparams
der_params(i)=0.0d0
enddo
do i=1,nh
term=bph(i)
do v=1,nparams
term=term+w(v,i)*params(v)
enddo
do v=1,nparams
der_params(v)=der_params(v)+(q(i)*gradactivatefunc1(term)
&+c(i)*gradactivatefunc2(term))*w(v,i)
enddo
enddo
return
end
double precision function activatefunc1(x)
implicit none
double precision x,crit
parameter(crit=300)
if(x.gt.-crit)then
activatefunc1=1.0d0/(1.0d0+dexp(-x))
else
activatefunc1=dexp(x)/(1.0d0+dexp(x))
endif
return
end
double precision function gradactivatefunc1(x)
implicit none
double precision x,crit
parameter(crit=600)
if(x.gt.-crit.and.x.lt.crit)then
gradactivatefunc1=
& (1.0d0/(dexp(x/2.0d0)+dexp(-x/2.0d0)))**2
else
gradactivatefunc1=0.0d0
endif
return
end
double precision function activatefunc2(x)
implicit none
double precision x
! activatefunc2=2.0d0*datan(x)/3.14159265d0
! activatefunc2=1.001d0+dsin(x)
activatefunc2=x+x*x
return
end
double precision function gradactivatefunc2(x)
implicit none
double precision x,crit
parameter(crit=600)
! gradactivatefunc2=2.0d0/(3.14159265d0*(1.0d0+x*x))
! gradactivatefunc2=dcos(x)
gradactivatefunc2=1.0d0+2.0d0*x
return
end
dataassim/math/optimization/findmindistance.f
+105
View File
@@ -0,0 +1,105 @@
subroutine findmindistance(funcnleq1,fmin_funcnleq1,
& f1dim_funcnleq1,x0min,x0ori,xp,x0max,fp,
& nunknowns,iwhichsolver)
implicit none
integer nunknowns,iwhichsolver
double precision x0min(nunknowns),x0ori(nunknowns),
& xp(nunknowns),x0max(nunknowns),fp(nunknowns)
!-------- Specified values ---------------------------------------
!funcnleq1: the subroutine that calculates the functional values of the
! the nonlinear system in the following form:
! funcnleq1(nunknowns,xp,fp,fsqsum)
!fmin_funcnleq1: the subroutine that calls funcnleq1 and returns fsqsum (half
! of the sum of the squared functional values of the nonlinear system)
! fmin_funcnleq1(nunknowns,xp,fsqsum)
!f1dim_funcnleq1: a function subroutine that returns fsqsum
! f1dim_funcnleq1(xp)
! nunknowns: The number of unknowns to be solved
! x0ori(1:nunknowns): initial guess for the unknowns
! x0min(1:nunknowns): lower bound of the solution
! x0max(1:nunknowns): upper bound of the solution
! --------- Calculated values -------------------------------------
! fp(1:nunknowns): function values at the last step of iteration
! xp(1:nunknowns): final solutions
! iwhichsolver:
! =1 solved by plain fixed point method 1
! =2 solved by fixed point method 2
! =3 solved by fixed point method 3
! =4 solved by fixed point method 4
! =6 solved by broydn
! =7 Solved by multiobjective minimization.
! =-9999 Best approximation returned. Solution may not be accurate.
! --------- Local variables ---------------------------------------
double precision x0(nunknowns),TOLF,stpmax,scldstpmax,
& sum,tb,tp,xb(nunknowns),fb(nunknowns),fsqsum,
& f1dim_funcnleq1
integer i,irepeat,maxrepeats,IERR,notfound
intrinsic dble
parameter(maxrepeats=100,notfound=-9999,TOLF=1.0d-10)
external funcnleq1,fmin_funcnleq1,f1dim_funcnleq1
!-------------------------------------------------------------------
stpmax=0.0d0
sum=0.0d0
do i=1, nunknowns
x0(i)=x0ori(i)
sum=sum+x0ori(i)*x0ori(i)
stpmax=stpmax+
& (x0min(i)-x0max(i))*(x0min(i)-x0max(i))
enddo
stpmax=dsqrt(stpmax)/4.0d0
scldstpmax=stpmax/dmax1(dsqrt(sum),dble(nunknowns))
! In Numerical Recipes, scldstpmax (STPMX) is 100
scldstpmax=dmax1(100.0d0,scldstpmax)
iwhichsolver=notfound
do irepeat=1,maxrepeats
call fixedpoint(funcnleq1,x0min,x0,xp,
& x0max,fp,nunknowns,TOLF,stpmax,iwhichsolver)
tp=dabs(fp(1))
do i=1,nunknowns
if(dabs(fp(i)).gt.tp)tp=dabs(fp(i))
xb(i)=xp(i)
enddo
call broydn(x0min,xb,x0max,scldstpmax,nunknowns,
& fb,funcnleq1,TOLF,IERR)
call funcnleq1(nunknowns,xb,fb,fsqsum)
tb=dabs(fb(1))
do i=2,nunknowns
if(dabs(fb(i)).gt.tb)tb=dabs(fb(i))
enddo
if(tb.lt.tp)then
do i=1,nunknowns
xp(i)=xb(i)
fp(i)=fb(i)
enddo
if(iwhichsolver.eq.notfound.and.
& tb.lt.TOLF)then
iwhichsolver=6
endif
endif
fsqsum=0.0d0
do i=1,nunknowns
fsqsum=fsqsum+fp(i)*fp(i)
enddo
fsqsum=fsqsum*0.5d0
call nongradopt(nunknowns,fmin_funcnleq1,
& f1dim_funcnleq1,xp,x0min,x0max,TOLF,fsqsum)
call RepeatCompassSearch(nunknowns,xp,fsqsum,
& x0min,x0max,fmin_funcnleq1,f1dim_funcnleq1,TOLF)
call funcnleq1(nunknowns,xp,fp,fsqsum)
if(iwhichsolver.eq.notfound)then
tp=dabs(fp(1))
do i=2,nunknowns
if(dabs(fp(i)).gt.tp)tp=dabs(fp(i))
enddo
if(tp.lt.TOLF)iwhichsolver=7
endif
IERR=0
do i=1,nunknowns
if(dabs(xp(i)-x0(i)).gt.TOLF)IERR=1
enddo
if(IERR.eq.0)return
do i=1,nunknowns
x0(i)=xp(i)
enddo
enddo
end subroutine findmindistance
dataassim/math/optimization/forgenericregres.h
+15
View File
@@ -0,0 +1,15 @@
integer maxndim,nobs,nxvars,nyvars,maxnobs,
& maxnxvars,maxnyvars,iregrestype,iknowder,idobounded
parameter(maxnobs=50000,maxnxvars=10,maxnyvars=10,
& maxndim=1000)
common /int_com_generic/nobs,nxvars,nyvars,iregrestype,
&iknowder,idobounded
double precision xvars(maxnobs,maxnxvars),
& yobs(maxnobs,maxnyvars),weity(maxnobs,maxnyvars),
& weitx(maxnobs,maxnxvars),betamin(maxndim),
& betamax(maxndim),shorty(maxnobs,maxnyvars),
& shortx(maxnobs,maxnxvars),xmin(maxnobs,maxnxvars),
& xmax(maxnobs,maxnxvars)
common /dble_com_generic/xvars,yobs,weity,weitx,
& betamin,betamax,shorty,shortx,xmin,xmax
save /int_com_generic/,/dble_com_generic/
dataassim/math/optimization/function_generic.f
+80
View File
@@ -0,0 +1,80 @@
subroutine function_generic(ndim,beta,nxvars,
& xvars,nyvars,ymod)
integer ndim,nxvars,nyvars
double precision beta(ndim),xvars(nxvars),
& ymod(nyvars)
double precision y0,a,b,c,x0,x,term,crit
parameter(crit=300.0d0)
a=beta(1)
b=beta(2)
c=beta(3)
x0=beta(4)
y0=beta(5)
x=xvars(1)
if((-(x-x0)/b).lt.crit)then
term=dexp(-(x-x0)/b)
ymod(1)=y0+a*(1.0d0/(1.0d0+term))**c
else
term=dexp((x-x0)/b)
ymod(1)=y0+a*(term/(1.0d0+term))**c
endif
return
end
subroutine der_function_generic(np,beta,m,
& xvars,nq,der_beta)
implicit none
integer np,m,nq
double precision beta(np),xvars(m),der_beta(np,nq)
double precision y0,a,b,c,x0,x,term,crit
parameter(crit=300.0d0)
a=beta(1)
b=beta(2)
c=beta(3)
x0=beta(4)
y0=beta(5)
x=xvars(1)
der_beta(5,1)=1.0d0
if((-(x-x0)/b).lt.crit)then
term=dexp(-(x-x0)/b)
der_beta(1,1)=(1.0d0/(1.0d0+term))**c
! der_x=(a*c*term/b)*(1.0d0/(1.0d0+term))**(1.0d0+c)
der_beta(4,1)=-(a*c*term/b)*
& (1.0d0/(1.0d0+term))**(1.0d0+c)
der_beta(2,1)=-(a*c*term*(x-x0)/(b*b))*
& (1.0d0/(1.0d0+term))**(1.0d0+c)
der_beta(3,1)=-(a*dlog(1.0d0+term))*
& (1.0d0/(1.0d0+term))**c
else
term=(x-x0)/b
der_beta(1,1)=(dexp(term)/(1.0d0+dexp(term)))**c
! der_x=(a*c/b)*(dexp(term*c/(c+1.0d0))/
! & (1.0d0+dexp(term)))**(c+1.0d0)
der_beta(4,1)=-(a*c/b)*(dexp(term*c/(c+1))/
& (1.0d0+dexp(term)))**(c+1.0d0)
der_beta(2,1)=-(a*c*(x-x0)/(b*b))*(dexp(term*c/
& (c+1.0d0))/(1.0d0+dexp(term)))**(1.0d0+c)
der_beta(3,1)=-a*(dlog(1.0d0+dexp(term))-term)*
& (dexp(term)/(1.0d0+dexp(term)))**c
endif
return
end
subroutine indices_function_generic(ndim,beta,root,
& der_root,fmax)
implicit none
integer ndim
double precision beta(ndim),root,der_root,fmax
double precision a,b,c,x0,y0,term
a=beta(1)
b=beta(2)
c=beta(3)
x0=beta(4)
y0=beta(5)
term=(-a/y0)**(1.0d0/c)-1.0d0
root=x0-b*dlog(term)
term=dexp(-(root-x0)/b)
der_root=(a*c*term/b)*(1.0d0/(1.0d0+term))**(1.0d0+c)
fmax=a+y0
return
end
dataassim/math/optimization/lbfgsroutines.f
+4440
View File
File diff suppressed because it is too large Load Diff
dataassim/math/optimization/leastdistance.h
+10
View File
@@ -0,0 +1,10 @@
!------------------CommonBlock-----------------------------
integer maxmy,maxnx,maxnparams
parameter(maxmy=10,maxnx=10,maxnparams=30)
integer my,iknowder,nparams
double precision targetx(maxnx),targety(maxmy),
& params(maxnparams)
common /distcom/targetx,targety,params,
& my,iknowder,nparams
save /distcom/
!----------------------------------------------------------
dataassim/math/optimization/nongradopt.f
+412
View File
@@ -0,0 +1,412 @@
subroutine nongradopt(ndim,funkmin,f1dim,beta,
& bmin,bmax,ftol,fatbeta)
implicit none
! This subroutine minimizes function funkmin to estimate ndim parameters
! using non-gradient based methods
!
integer ndim
double precision beta(1:ndim),bmin(1:ndim),
& bmax(1:ndim),ftol,fatbeta
!
! ------------------ Inputs -----------------------------
! ndim: the total number of parameters to be estimated
! bmax: the maximum possible value of beta, used to determine the distance scaling factor
! bmin: the minimum possible value of beta, used to determine the distance scaling factor
! beta: initial guess, overwritten upon return
! ftol: tolerance for convergence
! fatbeta: the cost function valuate at beta, overwritten upon return
! funkmin is the name of the subroutine that computes the cost function
! f1dim: the one dimensional cost function
! ------------------ Outputs ----------------------------
! beta: The best parameters obtained
! fatbeta: the cost function value at beta
integer n,nn,mpamoeba,npamoeba,iredo,maxredo,ITMAX,
& icycle
parameter(maxredo=10,ITMAX=10000)
double precision fbest,xbest(1:ndim),term,
& xinidir(1:ndim,1:ndim),xbest0(1:ndim),
& pamoeba(1:ndim+1,1:ndim),famoeba(1:ndim+1)
external funkmin,f1dim
! End of declaration of variables
!---------------------------------------------------------------
icycle=0
1 iredo=0
3 do n=1,ndim
xbest(n)=beta(n)
do nn=1,ndim
xinidir(n,nn)=0.0d0
enddo
xinidir(n,n)=1.0d0
enddo
fbest=fatbeta
call powell(beta,xinidir(1:ndim,1:ndim),ndim,ndim,
& ftol,fatbeta,bmin,bmax,funkmin,f1dim,ITMAX)
if(fatbeta.gt.fbest)then
do n=1,ndim
beta(n)=xbest(n)
enddo
fatbeta=fbest
goto 10
endif
if((fbest-fatbeta).gt.ftol)then
if(iredo.gt.maxredo)goto 10
iredo=iredo+1
goto 3
endif
10 iredo=0
20 do n=1,ndim
xbest(n)=beta(n)
enddo
fbest=fatbeta
do nn=1,ndim
pamoeba(1,nn)=beta(nn)
enddo
famoeba(1)=fatbeta
do n=2,ndim+1
do nn=1,ndim
pamoeba(n,nn)=beta(nn)
enddo
if((bmax(n-1)-pamoeba(n,n-1))
& .gt.(pamoeba(n,n-1)-bmin(n-1)))then
pamoeba(n,n-1)=pamoeba(n,n-1)+
& (bmax(n-1)-pamoeba(n,n-1))*0.1d0
else
pamoeba(n,n-1)=pamoeba(n,n-1)-
& (pamoeba(n,n-1)-bmin(n-1))*0.1d0
endif
do nn=1,ndim
xbest0(nn)=pamoeba(n,nn)
enddo
call funkmin(ndim,xbest0,famoeba(n))
enddo
mpamoeba=ndim+1
npamoeba=ndim
fatbeta=1.0d+100
term=1.0d0
30 nn=ITMAX/20
call amebsa(pamoeba(1:ndim+1,1:ndim),famoeba(1:ndim+1),
&mpamoeba,npamoeba,ndim,beta,fatbeta,ftol,funkmin,nn,term)
if(fatbeta.lt.fbest)then
if((fbest-fatbeta).gt.ftol*100.0d0.and.term.gt.1.0d-2)then
term=term/3.0d0
fbest=fatbeta
goto 30
endif
do n=1,ndim
xbest(n)=beta(n)
enddo
fbest=fatbeta
else
do n=1,ndim
beta(n)=xbest(n)
enddo
fatbeta=fbest
endif
do nn=1,ndim
pamoeba(1,nn)=beta(nn)
enddo
famoeba(1)=fatbeta
do n=2,ndim+1
do nn=1,ndim
pamoeba(n,nn)=beta(nn)
enddo
if((bmax(n-1)-pamoeba(n,n-1))
& .gt.(pamoeba(n,n-1)-bmin(n-1)))then
pamoeba(n,n-1)=pamoeba(n,n-1)+
& (bmax(n-1)-pamoeba(n,n-1))*0.1d0
else
pamoeba(n,n-1)=pamoeba(n,n-1)-
& (pamoeba(n,n-1)-bmin(n-1))*0.1d0
endif
do nn=1,ndim
xbest0(nn)=pamoeba(n,nn)
enddo
call funkmin(ndim,xbest0,famoeba(n))
enddo
mpamoeba=ndim+1
npamoeba=ndim
call guamoeba(pamoeba(1:ndim+1,1:ndim),famoeba(1:ndim+1),
&mpamoeba,npamoeba,ndim,ftol,funkmin,ITMAX/20)
nn=1
do n=2,ndim+1
if(famoeba(n).lt.famoeba(nn))nn=n
enddo
fatbeta=famoeba(nn)
do n=1,ndim
beta(n)=pamoeba(nn,n)
if(beta(n).lt.bmin(n).or.beta(n).gt.bmax(n))then
do nn=1,ndim
beta(nn)=xbest(nn)
enddo
fatbeta=fbest
return
endif
enddo
if((fbest-fatbeta).gt.ftol)then
if(iredo.gt.maxredo)then
if(icycle.lt.maxredo)then
icycle=icycle+1
goto 1
else
return
endif
endif
iredo=iredo+1
goto 20
endif
return
end subroutine nongradopt
!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
SUBROUTINE guamoeba(p,y,mp,np,ndim,ftol,funkmin,ITMAX)
implicit none
INTEGER iter,mp,ndim,np,NMAX,ITMAX
double precision ftol,p(mp,np),y(mp),TINY
PARAMETER (TINY=1.0d-10)
external funkmin
CU USES guamotry,funkmin
INTEGER i,ihi,ilo,inhi,j,m,n
double precision rtol,sum,swap,ysave,ytry,psum(ndim),
& guamotry,degen
iter=0
1 do 12 n=1,ndim
sum=0.0d0
do 11 m=1,ndim+1
sum=sum+p(m,n)
11 continue
psum(n)=sum
12 continue
2 ilo=1
if (y(1).gt.y(2)) then
ihi=1
inhi=2
else
ihi=2
inhi=1
endif
do 13 i=1,ndim+1
if(y(i).le.y(ilo)) ilo=i
if(y(i).gt.y(ihi)) then
inhi=ihi
ihi=i
else if(y(i).gt.y(inhi)) then
if(i.ne.ihi) inhi=i
endif
13 continue
rtol=2.0d0*dabs(y(ihi)-y(ilo))/
& (dabs(y(ihi))+dabs(y(ilo))+TINY)
if (rtol.lt.ftol) then
swap=y(1)
y(1)=y(ilo)
y(ilo)=swap
do 14 n=1,ndim
swap=p(1,n)
p(1,n)=p(ilo,n)
p(ilo,n)=swap
14 continue
return
endif
! check to see if the simplex is degenerate; if so, stop
degen=0.0d0
do i=1,mp
do m=i+1,mp
do n=1,np
if(dabs(p(m,n)-p(i,n)).gt.degen)then
degen=dabs(p(m,n)-p(i,n))
endif
enddo
enddo
enddo
if(degen.lt.ftol*ftol)then
swap=y(1)
y(1)=y(ilo)
y(ilo)=swap
do n=1,ndim
swap=p(1,n)
p(1,n)=p(ilo,n)
p(ilo,n)=swap
enddo
return
endif
if(iter.ge.ITMAX)return
iter=iter+2
ytry=guamotry(p,y,psum,mp,np,ndim,funkmin,ihi,-1.0d0)
if (ytry.le.y(ilo))then
ytry=guamotry(p,y,psum,mp,np,ndim,funkmin,ihi,2.0d0)
else if (ytry.ge.y(inhi)) then
ysave=y(ihi)
ytry=guamotry(p,y,psum,mp,np,ndim,funkmin,ihi,0.5d0)
if (ytry.ge.ysave) then
do 16 i=1,ndim+1
if(i.ne.ilo)then
do 15 j=1,ndim
psum(j)=0.5d0*(p(i,j)+p(ilo,j))
p(i,j)=psum(j)
15 continue
call funkmin(ndim,psum,y(i))
endif
16 continue
iter=iter+ndim
goto 1
endif
else
iter=iter-1
endif
goto 2
END
C (C) Copr. 1986-92 Numerical Recipes Software v%1jw#<0(9p#3.
DOUBLE PRECISION FUNCTION guamotry(p,y,psum,
& mp,np,ndim,funkmin,ihi,fac)
implicit none
INTEGER ihi,mp,ndim,np
double precision fac,p(mp,np),psum(np),y(mp)
EXTERNAL funkmin
CU USES funkmin
INTEGER j
double precision fac1,fac2,ytry,ptry(ndim)
fac1=(1.0d0-fac)/dble(ndim)
fac2=fac1-fac
do 11 j=1,ndim
ptry(j)=psum(j)*fac1-p(ihi,j)*fac2
11 continue
call funkmin(ndim,ptry,ytry)
if (ytry.lt.y(ihi)) then
y(ihi)=ytry
do 12 j=1,ndim
psum(j)=psum(j)-p(ihi,j)+ptry(j)
p(ihi,j)=ptry(j)
12 continue
endif
guamotry=ytry
return
END
C (C) Copr. 1986-92 Numerical Recipes Software v%1jw#<0(9p#3.
c#######################################################################
SUBROUTINE amebsa(p,y,mp,np,ndim,pb,yb,ftol,funkmin,iter,temptr)
implicit none
INTEGER iter,mp,ndim,np
double precision ftol,temptr,yb,p(mp,np),pb(np),y(mp)
EXTERNAL funkmin
CU USES amotsa,funkmin,ran1
INTEGER i,idum,ihi,ilo,inhi,j,m,n
double precision rtol,sum,swap,tt,yhi,ylo,ynhi,ysave,yt,ytry,
&psum(ndim),amotsa,ran1
COMMON /ambsa/ tt,idum
tt=-temptr
1 do 12 n=1,ndim
sum=0.0d0
do 11 m=1,ndim+1
sum=sum+p(m,n)
11 continue
psum(n)=sum
12 continue
2 ilo=1
inhi=1
ihi=2
ylo=y(1)+tt*dlog(ran1(idum))
ynhi=ylo
yhi=y(2)+tt*dlog(ran1(idum))
if (ylo.gt.yhi) then
ihi=1
inhi=2
ilo=2
ynhi=yhi
yhi=ylo
ylo=ynhi
endif
do 13 i=3,ndim+1
yt=y(i)+tt*dlog(ran1(idum))
if(yt.le.ylo) then
ilo=i
ylo=yt
endif
if(yt.gt.yhi) then
inhi=ihi
ynhi=yhi
ihi=i
yhi=yt
else if(yt.gt.ynhi) then
inhi=i
ynhi=yt
endif
13 continue
rtol=2.0d0*dabs(yhi-ylo)/(dabs(yhi)+dabs(ylo))
if(rtol.lt.ftol.or.iter.lt.0) then
swap=y(1)
y(1)=y(ilo)
y(ilo)=swap
do 14 n=1,ndim
swap=p(1,n)
p(1,n)=p(ilo,n)
p(ilo,n)=swap
14 continue
return
endif
iter=iter-2
ytry=amotsa(p(1:mp,1:np),
&y,psum,mp,np,ndim,pb,yb,funkmin,ihi,yhi,-1.0d0)
if (ytry.le.ylo) then
ytry=amotsa(p(1:mp,1:np),
&y,psum,mp,np,ndim,pb,yb,funkmin,ihi,yhi,2.0d0)
else if (ytry.ge.ynhi) then
ysave=yhi
ytry=amotsa(p(1:mp,1:np),
&y,psum,mp,np,ndim,pb,yb,funkmin,ihi,yhi,0.5d0)
if (ytry.ge.ysave) then
do 16 i=1,ndim+1
if(i.ne.ilo)then
do 15 j=1,ndim
psum(j)=0.5d0*(p(i,j)+p(ilo,j))
p(i,j)=psum(j)
15 continue
call funkmin(ndim,psum,y(i))
endif
16 continue
iter=iter-ndim
goto 1
endif
else
iter=iter+1
endif
goto 2
END
double precision FUNCTION amotsa
&(p,y,psum,mp,np,ndim,pb,yb,funkmin,ihi,yhi,fac)
implicit none
INTEGER ihi,mp,ndim,np
double precision fac,yb,yhi,p(mp,np),pb(np),psum(ndim),y(mp)
EXTERNAL funkmin
CU USES funkmin,ran1
INTEGER idum,j
double precision fac1,fac2,tt,yflu,ytry,ptry(ndim),ran1
COMMON /ambsa/ tt,idum
fac1=(1.0d0-fac)/dble(ndim)
fac2=fac1-fac
do 11 j=1,ndim
ptry(j)=psum(j)*fac1-p(ihi,j)*fac2
11 continue
call funkmin(ndim,ptry,ytry)
if (ytry.le.yb) then
do 12 j=1,ndim
pb(j)=ptry(j)
12 continue
yb=ytry
endif
yflu=ytry-tt*log(ran1(idum))
if (yflu.lt.yhi) then
y(ihi)=ytry
yhi=yflu
do 13 j=1,ndim
psum(j)=psum(j)-p(ihi,j)+ptry(j)
p(ihi,j)=ptry(j)
13 continue
endif
amotsa=yflu
return
END
dataassim/math/optimization/odr_leastsquare.f
+249
View File
@@ -0,0 +1,249 @@
!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
subroutine odr_leastsquare(NP,FCN,BETA,N,X,M,Y,NQ,
&weitx,weity,iderivative,shortx,shorty,fvalue,INFO)
implicit none
!if derivatives are provided, set iderivative to 1, otherwise set it to 0.
!for ordinary least square regression, set INFO to 0.
!for explicit orthorgonal distance regression, set INFO to 1.
!the content of INFO is destroyed on return
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 ==> X EXPLANATORY VARIABLE
C ==> LWORK DIMENSION OF VECTOR WORK
C ==> LIWORK DIMENSION OF VECTOR IWORK
C <== INFO STOPPING CONDITION
C VARIABLE DECLARATIONS
INTEGER INFO,M,N,NP,NQ,iderivative,LWORK,LIWORK
double precision weity(N,NQ),weitx(N,M),shorty(N,NQ),
&shortx(N,M),fvalue,BETA(NP),X(N,M),Y(N,NQ)
EXTERNAL FCN
LWORK=18+11*NP+NP**2+M+M**2+4*N*NQ+6*N*M+2*N*NQ*NP+
&2*N*NQ*M+NQ**2+5*NQ+NQ*(NP+M)+N*1*NQ
LIWORK=20+NP+NQ*(NP+M)
call odr_interface(NP,FCN,BETA,N,X(1:N,1:M),M,Y(1:N,1:NQ),NQ,
&LWORK,LIWORK,weitx(1:N,1:M),weity(1:N,1:NQ),iderivative,
&shortx(1:N,1:M),shorty(1:N,1:NQ),fvalue,INFO)
return
end subroutine odr_leastsquare
!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
subroutine odr_interface(NP,FCN,BETA,N,X,M,Y,NQ,LWORK,
&LIWORK,weitx,weity,iderivative,shortx,shorty,fvalue,INFO)
implicit none
!if derivatives are provided, set iderivative to 1, otherwise set it to 0.
!for ordinary least square regression, set INFO to 0.
!for explicit orthorgonal distance regression, set INFO to 1.
!the content of INFO is destroyed on return
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 PARAMETER DECLARATIONS AND SPECIFICATIONS
INTEGER LDIFX,LDSCLD,LDSTPD,LDWD,LDWE,LDX,LDY,LD2WD,LD2WE,
+ LIWORK,LWORK
C VARIABLE DECLARATIONS
INTEGER I,INFO,IPRINT,J,JOB,L,LUNERR,LUNRPT,M,MAXIT,N,
+ NDIGIT,NP,NQ
INTEGER IFIXB(NP),IFIXX(N,M),IWORK(LIWORK)
DOUBLE PRECISION PARTOL,SSTOL,TAUFAC
DOUBLE PRECISION BETA(NP),SCLB(NP),SCLD(1,M),
+ STPB(NP),STPD(1,M),
+ WD(N,1,M),WE(N,1,NQ),
+ WORK(LWORK),X(N,M),Y(N,NQ)
!------------For using information in WORK----------------------------
LOGICAL
+ ISODR
INTEGER
+ DELTAI,EPSI,XPLUSI,FNI,SDI,VCVI,
+ RVARI,WSSI,WSSDEI,WSSEPI,RCONDI,ETAI,
+ OLMAVI,TAUI,ALPHAI,ACTRSI,PNORMI,RNORSI,PRERSI,
+ PARTLI,SSTOLI,TAUFCI,EPSMAI,
+ BETA0I,BETACI,BETASI,BETANI,SI,SSI,SSFI,QRAUXI,UI,
+ FSI,FJACBI,WE1I,DIFFI,
+ DELTSI,DELTNI,TI,TTI,OMEGAI,FJACDI,
+ WRK1I,WRK2I,WRK3I,WRK4I,WRK5I,WRK6I,WRK7I,
+ LWKMN
c
integer i1,i2,i3,i4,i5,iderivative
double precision weity(N,NQ),weitx(N,M),shorty(N,NQ),
&shortx(N,M),fvalue
EXTERNAL FCN
c
C SPECIFY DEFAULT VALUES FOR DODRC ARGUMENTS
LDY=N
LDX=N
LDWE=N
LD2WE=1
LDWD=N
LD2WD=1
LDIFX=N
LDSTPD=1
LDSCLD=1
WE(1,1,1) = -1.0D0
WD(1,1,1) = -1.0D0
IFIXB(1) = -1
! IFIXX(1,1) = -1
if(INFO.eq.0)then
!explicit ordinary least square fitting
ISODR=.false.
if(iderivative.eq.0)then
!no derivatives provided, using central finite difference
JOB=13
else
!don't check derivatives
JOB=43
!check derivatives
! JOB=23
endif
endif
if(INFO.eq.1)then
!explicit orthogonal distance regression
ISODR=.true.
if(iderivative.eq.0)then
!no derivatives provided, using central finite difference
JOB=10
else
!don't check derivatives
JOB=40
!check derivatives
! JOB=20
endif
endif
if(INFO.eq.-1)then
!implicit orthogonal distance regression
ISODR=.true.
if(iderivative.eq.0)then
!no derivatives provided, using central finite difference
JOB=11
else
!don't check derivatives
JOB=31
!check derivatives
! JOB=21
endif
endif
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 = 107
LUNRPT = 108
LWKMN=LWORK
c
do I=1,N
do i1=1,M
WD(I,1,i1)=weitx(I,i1)
enddo
do i1=1,NQ
WE(I,1,i1)=weity(I,i1)
enddo
enddo
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(FCN,
+ 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
CALL DWINF
+ (N,M,NP,NQ,LDWE,LD2WE,ISODR,
+ DELTAI,EPSI,XPLUSI,FNI,SDI,VCVI,
+ RVARI,WSSI,WSSDEI,WSSEPI,RCONDI,ETAI,
+ OLMAVI,TAUI,ALPHAI,ACTRSI,PNORMI,RNORSI,PRERSI,
+ PARTLI,SSTOLI,TAUFCI,EPSMAI,
+ BETA0I,BETACI,BETASI,BETANI,SI,SSI,SSFI,QRAUXI,UI,
+ FSI,FJACBI,WE1I,DIFFI,
+ DELTSI,DELTNI,TI,TTI,OMEGAI,FJACDI,
+ WRK1I,WRK2I,WRK3I,WRK4I,WRK5I,WRK6I,WRK7I,
+ LWKMN)
fvalue=0.0d0
do I=1,N
do J=1,M
shortx(I,J)=WORK(XPLUSI-1+I+(J-1)*N)
fvalue=fvalue+weitx(I,J)*WORK(DELTAI-1+I+(J-1)*N)
+ *WORK(DELTAI-1+I+(J-1)*N)
enddo
do J=1,NQ
shorty(I,J)=WORK(FNI-1+I+(J-1)*N)
fvalue=fvalue+weity(I,J)*WORK(EPSI-1+I+(J-1)*N)
+*WORK(EPSI-1+I+(J-1)*N)
enddo
enddo
return
END
dataassim/math/optimization/odrpack.f
+13600
View File
File diff suppressed because it is too large Load Diff
dataassim/math/optimization/phenofit.f
+497
View File
@@ -0,0 +1,497 @@
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
!$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
dataassim/math/optimization/pikaia.f
+1317
View File
File diff suppressed because it is too large Load Diff
dataassim/math/optimization/planarfit.f
+52
View File
@@ -0,0 +1,52 @@
subroutine planarfit(nsamp,x,y,z,a,b,d,fatbeta)
!fit a plane in the form of ax+by+cz+d=0 where c is set to 1.
!Because we set c=1, we cannot fit for vertical planes in parallel to the
!x-z or y-z planes. But perfectly flat planes in parallel to the x-y plane can be included.
!no initial guess for a, b and d are needed
implicit none
integer nsamp,i
double precision x(nsamp),y(nsamp),z(nsamp),
& a,b,d,fatbeta,p1,p2,p3,q1,q2,q3,xmean,ymean,
& zmean,x2mean,y2mean,xymean,xzmean,yzmean
!--------------------------------------------------------
xmean=0.0d0
ymean=0.0d0
zmean=0.0d0
x2mean=0.0d0
y2mean=0.0d0
xymean=0.0d0
xzmean=0.0d0
yzmean=0.0d0
do i=1,nsamp
xmean=xmean+x(i)
ymean=ymean+y(i)
zmean=zmean+z(i)
x2mean=x2mean+x(i)*x(i)
y2mean=y2mean+y(i)*y(i)
xymean=xymean+x(i)*y(i)
xzmean=xzmean+x(i)*z(i)
yzmean=yzmean+y(i)*z(i)
enddo
xmean=xmean/dble(nsamp)
ymean=ymean/dble(nsamp)
zmean=zmean/dble(nsamp)
x2mean=x2mean/dble(nsamp)
y2mean=y2mean/dble(nsamp)
xymean=xymean/dble(nsamp)
xzmean=xzmean/dble(nsamp)
yzmean=yzmean/dble(nsamp)
p1=x2mean-xmean*xmean
p2=xymean-xmean*ymean
p3=xmean*zmean-xzmean
q1=xymean-xmean*ymean
q2=y2mean-ymean*ymean
q3=ymean*zmean-yzmean
call linearsys_dim2(p1,p2,p3,q1,q2,q3,a,b)
d=-(a*xmean+b*ymean+zmean)
fatbeta=0.0d0
do i=1,nsamp
fatbeta=fatbeta+(a*x(i)+b*y(i)+z(i)+d)*
& (a*x(i)+b*y(i)+z(i)+d)
enddo
return
end
dataassim/math/optimization/powell.f
+548
View File
@@ -0,0 +1,548 @@
SUBROUTINE powell(p,xi,n,np,ftol,fret,pmin,pmax,
& funkmin,f1dim,ITMAX)
! fret must be given on entry
implicit none
INTEGER iter,n,np,NMAX,ITMAX
double precision fret,ftol,p(np),xi(np,np),TINY,
& pmin(np),pmax(np)
PARAMETER (NMAX=1000,TINY=1.0d-25)
CU USES funkmin,linmin
INTEGER i,ibig,j
double precision del,fp,fptt,t,pt(NMAX),
& ptt(NMAX),xit(NMAX)
external funkmin,f1dim
do 11 j=1,n
pt(j)=p(j)
11 continue
iter=0
1 iter=iter+1
fp=fret
ibig=0
del=0.0d0
do 13 i=1,n
do 12 j=1,n
xit(j)=xi(j,i)
12 continue
fptt=fret
call linmin(p,pmin,pmax,xit,n,f1dim,fret)
if(fptt-fret.gt.del)then
del=fptt-fret
ibig=i
endif
13 continue
if(2.0d0*(fp-fret).le.ftol*(dabs(fp)+dabs(fret))+TINY)return
if(iter.eq.ITMAX)then
! write(*,*)'powell exceeding maximum iterations'
return
endif
do 14 j=1,n
ptt(j)=2.0d0*p(j)-pt(j)
xit(j)=p(j)-pt(j)
pt(j)=p(j)
14 continue
call funkmin(n,ptt,fptt)
if(fptt.ge.fp)goto 1
t=2.0d0*(fp-2.0d0*fret+fptt)*(fp-fret-del)**2-
& del*(fp-fptt)**2
if(t.ge.0.0d0)goto 1
call linmin(p,pmin,pmax,xit,n,f1dim,fret)
if(ibig.eq.0)return
do 15 j=1,n
xi(j,ibig)=xi(j,n)
xi(j,n)=xit(j)
15 continue
goto 1
END
C (C) Copr. 1986-92 Numerical Recipes Software v%1jw#<0(9p#3.
SUBROUTINE linmin(p,pmin,pmax,xi,n,f1dim,fret)
implicit none
INTEGER n
double precision fret,p(n),xi(n),TOL,pmin(n),pmax(n)
PARAMETER (TOL=1.0d-8)
CU USES brent,f1dim,mnbrak
INTEGER j,k,ierr
double precision ax,bx,fa,fb,fx,xmin,xx,brent,xxmin,xxmax
!((((((((((((((((((((((((((((((((((((((((((((((((((((
!It is essential NMAX must be set to 1000 in f1dim!
integer NMAX,ncom
parameter(NMAX=1000)
double precision pcom(NMAX),xicom(NMAX)
COMMON /f1com/ pcom,xicom,ncom
save /f1com/
!))))))))))))))))))))))))))))))))))))))))))))))))))))
EXTERNAL f1dim
ncom=n
do j=1,n
pcom(j)=p(j)
xicom(j)=xi(j)
enddo
xxmax=1.0d+100
xxmin=-1.0d+100
do j=1,n
if(xicom(j).gt.1.0d-100)then
! if(xicom(j).gt.0.0d0)then
xx=(pmax(j)-pcom(j))/xicom(j)
ax=(pmin(j)-pcom(j))/xicom(j)
else
if(xicom(j).lt.(-1.0d-100))then
! if(xicom(j).lt.0.0d0)then
ax=(pmax(j)-pcom(j))/xicom(j)
xx=(pmin(j)-pcom(j))/xicom(j)
else
xx=1.0d+100
ax=-1.0d+100
endif
endif
if(xxmax.gt.xx)then
xxmax=xx
endif
if(xxmin.lt.ax)then
xxmin=ax
endif
enddo
ax=0.0d0
if(dabs(xxmax).gt.dabs(xxmin))then
xx=0.25d0*xxmax
else
xx=0.25d0*xxmin
endif
call mnbrak(ax,xx,bx,fa,fx,fb,xxmin,xxmax,ierr,f1dim)
if(ierr.eq.0)then
fret=brent(ax,xx,bx,f1dim,TOL,xmin)
else
xmin=xx
fret=fx
endif
do 12 j=1,n
xi(j)=xmin*xi(j)
p(j)=p(j)+xi(j)
12 continue
return
END
C (C) Copr. 1986-92 Numerical Recipes Software v%1jw#<0(9p#3.
!
!
double precision function brent(ax,bx,cx,f,tol,xmin)
INTEGER ITMAX
double precision ax,bx,cx,tol,xmin,f,CGOLD,ZEPS
EXTERNAL f
PARAMETER (ITMAX=10000,CGOLD=.381966d0,ZEPS=1.0d-10)
INTEGER iter
double precision a,b,d,e,etemp,fu,fv,fw,fx,p,q,r,tol1,
& tol2,u,v,w,x,xm
a=dmin1(ax,cx)
b=dmax1(ax,cx)
v=bx
w=v
x=v
e=0.0d0
fx=f(x)
fv=fx
fw=fx
do 11 iter=1,ITMAX
xm=0.5d0*(a+b)
tol1=tol*dabs(x)+ZEPS
tol2=2.0d0*tol1
if(dabs(x-xm).le.(tol2-.5d0*(b-a))) goto 3
if(dabs(e).gt.tol1) then
r=(x-w)*(fx-fv)
q=(x-v)*(fx-fw)
p=(x-v)*q-(x-w)*r
q=2.0d0*(q-r)
if(q.gt.0.0d0) p=-p
q=dabs(q)
etemp=e
e=d
if(dabs(p).ge.dabs(.5d0*q*etemp).or.
& p.le.q*(a-x).or.p.ge.q*(b-x))goto 1
d=p/q
u=x+d
if(u-a.lt.tol2.or.b-u.lt.tol2)d=dsign(tol1,xm-x)
goto 2
endif
1 if(x.ge.xm)then
e=a-x
else
e=b-x
endif
d=CGOLD*e
2 if(dabs(d).ge.tol1) then
u=x+d
else
u=x+dsign(tol1,d)
endif
fu=f(u)
if(fu.le.fx)then
if(u.ge.x)then
a=x
else
b=x
endif
v=w
fv=fw
w=x
fw=fx
x=u
fx=fu
else
if(u.lt.x) then
a=u
else
b=u
endif
if(fu.le.fw.or.w.eq.x)then
v=w
fv=fw
w=u
fw=fu
else if(fu.le.fv.or.v.eq.x.or.v.eq.w)then
v=u
fv=fu
endif
endif
11 continue
! write(*,*) 'brent exceed maximum iterations'
3 xmin=x
brent=fx
return
END
C (C) Copr. 1986-92 Numerical Recipes Software v%1jw#<0(9p#3.
! double precision function f1dim(x)
! implicit none
! double precision x
!CU USES funkmin
! 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(ncom,xt,f1dim)
! return
! END
!C (C) Copr. 1986-92 Numerical Recipes Software v%1jw#<0(9p#3.
SUBROUTINE mnbrak(ax,bx,cx,fa,fb,fc,xxmin,xxmax,
& ierr,func)
implicit none
double precision ax,bx,cx,fa,fb,fc,
& func,GOLD,GLIMIT,TINY
EXTERNAL func
PARAMETER(GOLD=1.618034d0,GLIMIT=100.0d0,TINY=1.0d-20)
double precision dum,fu,q,r,u,ulim,xxmin,xxmax
integer ierr
ierr=0
fa=func(ax)
fb=func(bx)
if(fb.gt.fa)then
dum=ax
ax=bx
bx=dum
dum=fb
fb=fa
fa=dum
!from ax to bx, f decreases
endif
if(fa.eq.fb)then
cx=(bx+ax)/2.0d0
fc=func(cx)
if(fc.le.fa)return
endif
cx=bx+GOLD*(bx-ax)
if(cx.le.xxmin)then
cx=0.5d0*(dmin1(ax,bx)+xxmin)
endif
if(cx.ge.xxmax)then
cx=0.5d0*(dmax1(ax,bx)+xxmax)
endif
fc=func(cx)
1 if(fb.ge.fc)then
r=(bx-ax)*(fb-fc)
q=(bx-cx)*(fb-fa)
u=bx-((bx-cx)*q-(bx-ax)*r)/
& (2.0d0*dsign(dmax1(dabs(q-r),TINY),q-r))
ulim=bx+GLIMIT*(cx-bx)
if(ulim.ge.xxmax)then
ulim=xxmax-TINY
endif
if(ulim.le.xxmin)then
ulim=xxmin+TINY
endif
if((bx-u)*(u-cx).gt.0.0d0)then
fu=func(u)
if(fu.lt.fc)then
ax=bx
fa=fb
bx=u
fb=fu
return
elseif(fu.gt.fb)then
cx=u
fc=fu
return
endif
u=cx+GOLD*(cx-bx)
if(u.gt.xxmax)then
u=cx+0.5d0*(xxmax-cx)
endif
if(u.lt.xxmin)then
u=cx+0.5d0*(xxmin-cx)
endif
fu=func(u)
elseif((cx-u)*(u-ulim).gt.0.0d0)then
fu=func(u)
if(fu.lt.fc)then
bx=cx
cx=u
u=cx+GOLD*(cx-bx)
if(u.gt.xxmax)then
u=cx+0.5d0*(xxmax-cx)
endif
if(u.lt.xxmin)then
u=cx+0.5d0*(xxmin-cx)
endif
fb=fc
fc=fu
fu=func(u)
endif
else if((u-ulim)*(ulim-cx).ge.0.0d0)then
u=ulim
fu=func(u)
else
u=cx+GOLD*(cx-bx)
if(u.gt.xxmax)then
u=cx+0.5d0*(xxmax-cx)
endif
if(u.lt.xxmin)then
u=cx+0.5d0*(xxmin-cx)
endif
fu=func(u)
endif
ax=bx
bx=cx
cx=u
fa=fb
fb=fc
fc=fu
r=dmin1(dabs(ax-bx),dabs(ax-cx))
r=dmin1(r,dabs(bx-cx))
if(r.lt.TINY)then
! bracketing failed
ierr=1
return
endif
goto 1
endif
return
END
C (C) Copr. 1986-92 Numerical Recipes Software v%1jw#<0(9p#3.
SUBROUTINE leafmnbrak(ax,bx,cx,fa,fb,fc,xxmin,xxmax,
& ierr,func)
implicit none
double precision ax,bx,cx,fa,fb,fc,
& func,GOLD,GLIMIT,TINY
EXTERNAL func
PARAMETER(GOLD=1.618034d0,GLIMIT=100.0d0,TINY=1.0d-20)
double precision dum,fu,q,r,u,ulim,xxmin,xxmax
integer ierr
ierr=0
fa=func(ax)
fb=func(bx)
if(fb.gt.fa)then
dum=ax
ax=bx
bx=dum
dum=fb
fb=fa
fa=dum
!from ax to bx, f decreases
endif
if(fa.eq.fb)then
cx=(bx+ax)/2.0d0
fc=func(cx)
if(fc.le.fa)return
endif
cx=bx+GOLD*(bx-ax)
if(cx.le.xxmin)then
cx=0.5d0*(dmin1(ax,bx)+xxmin)
endif
if(cx.ge.xxmax)then
cx=0.5d0*(dmax1(ax,bx)+xxmax)
endif
fc=func(cx)
1 if(fb.ge.fc)then
r=(bx-ax)*(fb-fc)
q=(bx-cx)*(fb-fa)
u=bx-((bx-cx)*q-(bx-ax)*r)/
& (2.0d0*dsign(dmax1(dabs(q-r),TINY),q-r))
ulim=bx+GLIMIT*(cx-bx)
if(ulim.ge.xxmax)then
ulim=xxmax-TINY
endif
if(ulim.le.xxmin)then
ulim=xxmin+TINY
endif
if((bx-u)*(u-cx).gt.0.0d0)then
fu=func(u)
if(fu.lt.fc)then
ax=bx
fa=fb
bx=u
fb=fu
return
elseif(fu.gt.fb)then
cx=u
fc=fu
return
endif
u=cx+GOLD*(cx-bx)
if(u.gt.xxmax)then
u=cx+0.5d0*(xxmax-cx)
endif
if(u.lt.xxmin)then
u=cx+0.5d0*(xxmin-cx)
endif
fu=func(u)
elseif((cx-u)*(u-ulim).gt.0.0d0)then
fu=func(u)
if(fu.lt.fc)then
bx=cx
cx=u
u=cx+GOLD*(cx-bx)
if(u.gt.xxmax)then
u=cx+0.5d0*(xxmax-cx)
endif
if(u.lt.xxmin)then
u=cx+0.5d0*(xxmin-cx)
endif
fb=fc
fc=fu
fu=func(u)
endif
else if((u-ulim)*(ulim-cx).ge.0.0d0)then
u=ulim
fu=func(u)
else
u=cx+GOLD*(cx-bx)
if(u.gt.xxmax)then
u=cx+0.5d0*(xxmax-cx)
endif
if(u.lt.xxmin)then
u=cx+0.5d0*(xxmin-cx)
endif
fu=func(u)
endif
ax=bx
bx=cx
cx=u
fa=fb
fb=fc
fc=fu
r=dmin1(dabs(ax-bx),dabs(ax-cx))
r=dmin1(r,dabs(bx-cx))
if(r.lt.TINY)then
! bracketing failed
ierr=1
return
endif
goto 1
endif
return
END
C (C) Copr. 1986-92 Numerical Recipes Software v%1jw#<0(9p#3.
double precision function leafbrent(ax,bx,cx,f,tol,xmin)
INTEGER ITMAX
double precision ax,bx,cx,tol,xmin,f,CGOLD,ZEPS
EXTERNAL f
PARAMETER (ITMAX=10000,CGOLD=.381966d0,ZEPS=1.0d-10)
INTEGER iter
double precision a,b,d,e,etemp,fu,fv,fw,fx,p,q,r,tol1,
& tol2,u,v,w,x,xm
a=dmin1(ax,cx)
b=dmax1(ax,cx)
v=bx
w=v
x=v
e=0.0d0
fx=f(x)
fv=fx
fw=fx
do 11 iter=1,ITMAX
xm=0.5d0*(a+b)
tol1=tol*dabs(x)+ZEPS
tol2=2.0d0*tol1
if(dabs(x-xm).le.(tol2-.5d0*(b-a))) goto 3
if(dabs(e).gt.tol1) then
r=(x-w)*(fx-fv)
q=(x-v)*(fx-fw)
p=(x-v)*q-(x-w)*r
q=2.0d0*(q-r)
if(q.gt.0.0d0) p=-p
q=dabs(q)
etemp=e
e=d
if(dabs(p).ge.dabs(.5d0*q*etemp).or.
& p.le.q*(a-x).or.p.ge.q*(b-x))goto 1
d=p/q
u=x+d
if(u-a.lt.tol2.or.b-u.lt.tol2)d=dsign(tol1,xm-x)
goto 2
endif
1 if(x.ge.xm)then
e=a-x
else
e=b-x
endif
d=CGOLD*e
2 if(dabs(d).ge.tol1) then
u=x+d
else
u=x+dsign(tol1,d)
endif
fu=f(u)
if(fu.le.fx)then
if(u.ge.x)then
a=x
else
b=x
endif
v=w
fv=fw
w=x
fw=fx
x=u
fx=fu
else
if(u.lt.x) then
a=u
else
b=u
endif
if(fu.le.fw.or.w.eq.x)then
v=w
fv=fw
w=u
fw=fu
else if(fu.le.fv.or.v.eq.x.or.v.eq.w)then
v=u
fv=fu
endif
endif
11 continue
! write(*,*) 'brent exceed maximum iterations'
3 xmin=x
leafbrent=fx
return
END
C (C) Copr. 1986-92 Numerical Recipes Software v%1jw#<0(9p#3.
dataassim/math/optimization/powellann.f
+403
View File
@@ -0,0 +1,403 @@
SUBROUTINE powellann(p,xi,n,np,ftol,fret,pmin,pmax,
& funkmin,f1dim,ITMAX)
! fret must be given on entry
implicit none
INTEGER iter,n,np,NMAX,ITMAX
double precision fret,ftol,p(np),xi(np,np),TINY,
& pmin(np),pmax(np)
PARAMETER (NMAX=50,TINY=1.0d-25)
CU USES funkmin,annlinmin
INTEGER i,ibig,j
double precision del,fp,fptt,t,pt(NMAX),
& ptt(NMAX),xit(NMAX)
external funkmin,f1dim
do 11 j=1,n
pt(j)=p(j)
11 continue
iter=0
1 iter=iter+1
fp=fret
ibig=0
del=0.0d0
do 13 i=1,n
do 12 j=1,n
xit(j)=xi(j,i)
12 continue
fptt=fret
call annlinmin(p,pmin,pmax,xit,n,f1dim,fret)
if(fptt-fret.gt.del)then
del=fptt-fret
ibig=i
endif
13 continue
if(2.0d0*(fp-fret).le.ftol*(dabs(fp)+dabs(fret))+TINY)return
if(iter.eq.ITMAX)then
write(*,*)'powell exceeding maximum iterations'
return
endif
do 14 j=1,n
ptt(j)=2.0d0*p(j)-pt(j)
xit(j)=p(j)-pt(j)
pt(j)=p(j)
14 continue
call funkmin(n,ptt,fptt)
if(fptt.ge.fp)goto 1
t=2.0d0*(fp-2.0d0*fret+fptt)*(fp-fret-del)**2-
& del*(fp-fptt)**2
if(t.ge.0.0d0)goto 1
call annlinmin(p,pmin,pmax,xit,n,f1dim,fret)
do 15 j=1,n
xi(j,ibig)=xi(j,n)
xi(j,n)=xit(j)
15 continue
goto 1
END
C (C) Copr. 1986-92 Numerical Recipes Software v%1jw#<0(9p#3.
SUBROUTINE annlinmin(p,pmin,pmax,xi,n,f1dim,fret)
implicit none
INTEGER n,NMAX
double precision fret,p(n),xi(n),ftol,pmin(n),pmax(n)
PARAMETER (NMAX=1000,ftol=1.0d-6)
CU USES brent,f1dim,mnbrak
INTEGER j,ncom,k,ierr
double precision ax,bx,fa,fb,fx,xmin,xx,pcom(NMAX),
& xicom(NMAX),xxmin,xxmax,term,w(2),bph(2),
& paramnormsk,paramnormsb,ynorm,q(2),bend,terma,
& termb,termc,delta,reducer,root,f1dim,postannfunc
parameter(reducer=0.25d0)
COMMON /f1com/ pcom,xicom,ncom
integer maxm1dsamp,m1dsamp
parameter(maxm1dsamp=1000)
common /intannlinmin/m1dsamp
double precision y1dsamp(maxm1dsamp),params1d(maxm1dsamp)
common /dbleannlinmin/y1dsamp,params1d
EXTERNAL f1dim
ncom=n
delta=0.5d0
do j=1,n
pcom(j)=p(j)
xicom(j)=xi(j)
enddo
xxmax=1.0d+100
xxmin=-1.0d+100
do j=1,n
if(xicom(j).gt.1.0d-100)then
! if(xicom(j).gt.0.0d0)then
xx=(pmax(j)-pcom(j))/xicom(j)
ax=(pmin(j)-pcom(j))/xicom(j)
else
if(xicom(j).lt.(-1.0d-100))then
! if(xicom(j).lt.0.0d0)then
ax=(pmax(j)-pcom(j))/xicom(j)
xx=(pmin(j)-pcom(j))/xicom(j)
else
xx=1.0d+100
ax=-1.0d+100
endif
endif
if(xxmax.gt.xx)then
xxmax=xx
endif
if(xxmin.lt.ax)then
xxmin=ax
endif
enddo
ax=0.0d0
if(dabs(xxmax).gt.dabs(xxmin))then
xx=0.25d0*xxmax
else
xx=0.25d0*xxmin
endif
m1dsamp=0
call mnbrak(ax,xx,bx,fa,fx,fb,xxmin,xxmax,ierr,f1dim)
if(ierr.ne.0)then
! bracketing failed
fret=fx
do j=1,n
xi(j)=xx*xi(j)
p(j)=p(j)+xi(j)
enddo
return
endif
if(ax.gt.xx)then
xxmax=ax
xxmin=bx
else
xxmax=bx
xxmin=ax
endif
write(*,*)m1dsamp
if(m1dsamp.lt.6)then
term=xx+(xxmax-xx)*(delta+1.0d0)/2.0d0
fret=f1dim(term)
if(fret.lt.fx)then
xxmin=xx
xx=term
fx=fret
else
xxmax=term
endif
term=xx+(xxmax-xx)*(1.0d0-delta)/2.0d0
fret=f1dim(term)
if(fret.lt.fx)then
xxmin=xx
xx=term
fx=fret
else
xxmax=term
endif
term=xx-(xx-xxmin)*(1.0d0+delta)/2.0d0
fret=f1dim(term)
if(fret.lt.fx)then
xxmax=xx
xx=term
fx=fret
else
xxmin=term
endif
term=xx-(xx-xxmin)*(1.0d0-delta)/2.0d0
fret=f1dim(term)
if(fret.lt.fx)then
xxmax=xx
xx=term
fx=fret
else
xxmin=term
endif
endif
w(1)=0.75334d0
w(2)=0.13425d0
bph(1)=0.01d0
bph(2)=-0.07d0
q(1)=1.2d0
q(2)=-2.0d0
100 call annfitting1d(m1dsamp,params1d,y1dsamp,paramnormsk,
& paramnormsb,ynorm,w,bph,q,bend)
term=q(1)*w(1)
fret=q(2)*w(2)
terma=term*w(2)*w(2)+fret*w(1)*w(1)
termb=2.0d0*(term*w(2)*bph(2)+fret*w(1)*bph(1))
termc=term*(1.0d0+bph(2)*bph(2))+
& fret*(1.0d0+bph(1)*bph(1))
if(terma.eq.0.0d0)then
if(termb.eq.0.0d0)goto 200
root=-termc/termb
goto 110
endif
fret=termb*termb-4.0d0*terma*termc
if(fret.lt.0.0d0)goto 200
term=-0.5d0*(termb+dsign(1.0d0,termb)*dsqrt(fret))
root=termc/term
root=(root-paramnormsb)/paramnormsk
if(root.lt.xxmax.and.root.gt.xxmin)then
if(dabs(root-xx).lt.ftol)goto 1000
fret=f1dim(root)
if(fret.lt.fx)then
if(root.lt.xx)then
xxmax=xx
else
xxmin=xx
endif
xx=root
fx=fret
goto 100
else
if(root.lt.xx)then
xxmin=root
else
xxmax=root
endif
endif
endif
root=term/terma
110 root=(root-paramnormsb)/paramnormsk
if(root.lt.xxmax.and.root.gt.xxmin)then
if(dabs(root-xx).lt.ftol)goto 1000
fret=f1dim(root)
if(fret.lt.fx)then
if(root.lt.xx)then
xxmax=xx
else
xxmin=xx
endif
xx=root
fx=fret
goto 100
else
if(root.lt.xx)then
xxmin=root
else
xxmax=root
endif
endif
endif
200 term=xx+delta*(xxmax-xx)
write(*,*)'ann failed'
fret=f1dim(term)
if(fret.lt.fx)then
xxmin=xx
fx=fret
xx=term
goto 100
endif
xxmax=term
term=xx-delta*(xx-xxmin)
fret=f1dim(term)
if(fret.lt.fx)then
xxmax=xx
fx=fret
xx=term
goto 100
endif
xxmin=term
delta=delta*reducer
if(delta.gt.ftol)goto 200
1000 fret=fx
do j=1,n
xi(j)=xx*xi(j)
p(j)=p(j)+xi(j)
enddo
return
END
C (C) Copr. 1986-92 Numerical Recipes Software v%1jw#<0(9p#3.
SUBROUTINE mnbrak(ax,bx,cx,fa,fb,fc,xxmin,xxmax,
& ierr,func)
implicit none
double precision ax,bx,cx,fa,fb,fc,
& func,GOLD,GLIMIT,TINY
EXTERNAL func
PARAMETER(GOLD=1.618034d0,GLIMIT=100.0d0,TINY=1.0d-20)
double precision dum,fu,q,r,u,ulim,xxmin,xxmax
integer ierr
ierr=0
fa=func(ax)
fb=func(bx)
if(fb.gt.fa)then
dum=ax
ax=bx
bx=dum
dum=fb
fb=fa
fa=dum
endif
if(fa.eq.fb)then
cx=(bx+ax)/2.0d0
fc=func(cx)
if(fc.le.fa)return
endif
cx=bx+GOLD*(bx-ax)
if(cx.le.xxmin)then
cx=0.5d0*(dmin1(ax,bx)+xxmin)
endif
if(cx.ge.xxmax)then
cx=0.5d0*(dmax1(ax,bx)+xxmax)
endif
fc=func(cx)
1 if(fb.ge.fc)then
r=(bx-ax)*(fb-fc)
q=(bx-cx)*(fb-fa)
u=bx-((bx-cx)*q-(bx-ax)*r)/
& (2.0d0*dsign(dmax1(dabs(q-r),TINY),q-r))
ulim=bx+GLIMIT*(cx-bx)
if(ulim.ge.xxmax)then
ulim=xxmax-tiny
endif
if(ulim.le.xxmin)then
ulim=xxmin+tiny
endif
if((bx-u)*(u-cx).gt.0.0d0)then
fu=func(u)
if(fu.lt.fc)then
ax=bx
fa=fb
bx=u
fb=fu
return
elseif(fu.gt.fb)then
cx=u
fc=fu
return
endif
u=cx+GOLD*(cx-bx)
if(u.gt.xxmax)then
u=cx+0.5d0*(xxmax-cx)
endif
if(u.lt.xxmin)then
u=cx+0.5d0*(xxmin-cx)
endif
fu=func(u)
elseif((cx-u)*(u-ulim).gt.0.0d0)then
fu=func(u)
if(fu.lt.fc)then
bx=cx
cx=u
u=cx+GOLD*(cx-bx)
if(u.gt.xxmax)then
u=cx+0.5d0*(xxmax-cx)
endif
if(u.lt.xxmin)then
u=cx+0.5d0*(xxmin-cx)
endif
fb=fc
fc=fu
fu=func(u)
endif
else if((u-ulim)*(ulim-cx).ge.0.0d0)then
u=ulim
fu=func(u)
else
u=cx+GOLD*(cx-bx)
if(u.gt.xxmax)then
u=cx+0.5d0*(xxmax-cx)
endif
if(u.lt.xxmin)then
u=cx+0.5d0*(xxmin-cx)
endif
fu=func(u)
endif
ax=bx
bx=cx
cx=u
fa=fb
fb=fc
fc=fu
r=dmin1(dabs(ax-bx),dabs(ax-cx))
r=dmin1(r,dabs(bx-cx))
if(r.lt.tiny)then
! bracketing failed
ierr=1
return
endif
goto 1
endif
return
END
C (C) Copr. 1986-92 Numerical Recipes Software v%1jw#<0(9p#3.
dataassim/math/optimization/randpermut_dim_samp.f
+102
View File
@@ -0,0 +1,102 @@
subroutine randpermut_dim_samp(npoints,ndim,x)
implicit none
!
! conduct random permutation
integer npoints,ndim,i,j,k,iextreme,index,ibad,ngood,
& istore(npoints)
double precision x(ndim,npoints),xtemp(npoints),
& ran2_reset,temp,bmin(ndim),bmax(ndim)
do i=1,ndim
do j=1,npoints
xtemp(j)=x(i,j)
enddo
do j=1,npoints
index=int(dble(npoints-j+1)*ran2_reset()+1.0d0)
x(i,j)=xtemp(index)
xtemp(index)=xtemp(npoints-j+1)
enddo
enddo
if(ndim.eq.1)return
if(npoints.le.3)return
! now check to see if all extreme values are togather
do i=1,ndim
bmax(i)=x(i,1)
bmin(i)=x(i,1)
enddo
do i=2,npoints
do j=1,ndim
if(bmax(j).lt.x(j,i))then
bmax(j)=x(j,i)
endif
if(bmin(j).gt.x(j,i))then
bmin(j)=x(j,i)
endif
enddo
enddo
do i=1,npoints
iextreme=0
do j=1,ndim
if(dabs(x(j,i)-bmax(j)).lt.1.0d-9.or.
& dabs(x(j,i)-bmin(j)).lt.1.0d-9)then
iextreme=iextreme+1
endif
enddo
if(iextreme.ge.(ndim/2+1))then
! more than half take extreme values, need to change
! find ones without any extremes
ngood=0
do j=1,i
ibad=0
do k=1,ndim
if(dabs(x(k,j)-bmax(k)).lt.1.0d-9.or.
& dabs(x(k,j)-bmin(k)).lt.1.0d-9)then
ibad=1
endif
enddo
if(ibad.eq.0)then
ngood=ngood+1
istore(ngood)=j
endif
enddo
do j=1+i,npoints
ibad=0
do k=1,ndim
if(dabs(x(k,j)-bmax(k)).lt.1.0d-9.or.
& dabs(x(k,j)-bmin(k)).lt.1.0d-9)then
ibad=1
endif
enddo
if(ibad.eq.0)then
ngood=ngood+1
istore(ngood)=j
endif
enddo
if(ngood.ge.1)then
index=int(dble(ngood)*ran2_reset()+1.0d0)
index=istore(index)
else
! there is no single point that does not take any extremes
index=int(dble(npoints)*ran2_reset()+1.0d0)
if(index.eq.i)then
if(i.eq.1)then
index=npoints
else
index=1
endif
endif
endif
do j=1,ndim,2
temp=x(j,i)
x(j,i)=x(j,index)
x(j,index)=temp
enddo
endif
enddo
return
end
c&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
dataassim/math/optimization/samplingscheme.f
+144
View File
@@ -0,0 +1,144 @@
subroutine samplingscheme(sampfunc,nparams,msamp,
& bestguess,guessconfid0,bmax,bmin,params,ysamp)
!
! This subroutine conducts samples from a given function using both random and
! systematic strategies. In the random strategy, sampled points randomly scatter
! around the bestguess point. The closeness to the bestguess depends on the confidence
! on the bestguess. For any given parameter, the width of the last interval is
! guessconfid0 X the width of the first interval. In the systematic strategy, two values
! for each parameter are determined with the new bestguess after
! the random sampling in the middle. The two determined values of all parameters
! are systematically combined to form new additional sampling points.
!
! After the two sampling strategies, the latest best guess is the first point in params.
implicit none
integer nparams,msamp
double precision bestguess(nparams),guessconfid0,
& bmax(nparams),bmin(nparams),params(nparams,msamp),
& ysamp(msamp),guessconfid
integer i,nright,nleft,ibest,msamptemp
double precision accum,x1,delta,j,ybest,temp
external sampfunc
guessconfid=dmax1(1.0d0,guessconfid0)
do i=1,nparams
if(bestguess(i).lt.bmin(i).or.bestguess(i).gt.
& bmax(i))then
write(*,*)'best guess out of bounds, sampling stops'
stop
endif
enddo
msamptemp=msamp-1-2*nparams
if(msamptemp.lt.0)then
write(*,*)'sampling number must be larger than',
& (1+2*nparams)
stop
endif
if(msamptemp.gt.0)then
if(msamptemp.ge.3)then
if(mod(msamptemp,2).eq.0)then
nright=msamptemp/2
nleft=msamptemp/2
else
nright=msamptemp/2+1
nleft=msamptemp/2
endif
do i=1,nparams
!first divide the right
x1=2.0d0*(bmax(i)-bestguess(i))/
& (dble(nright)*(guessconfid+1.0d0))
delta=x1*(guessconfid-1.0d0)/dble(nright-1)
accum=0.0d0
do j=1,nright
accum=accum+x1+dble(j-1)*delta
params(i,j)=accum+bestguess(i)
enddo
!
!then divide the left
x1=2.0d0*(bestguess(i)-bmin(i))/
& (dble(nleft)*(guessconfid+1.0d0))
delta=x1*(guessconfid-1.0d0)/dble(nleft-1)
accum=0.0d0
do j=1,nleft
accum=accum+x1+dble(j-1)*delta
params(i,j+nright)=bestguess(i)-accum
enddo
enddo
else
if(msamptemp.eq.1)then
do i=1,nparams
! arbitrarily take one value
params(i,1)=bestguess(i)+(bmax(i)-bestguess(i))
& *0.339354235d0
enddo
endif
if(msamptemp.eq.2)then
do i=1,nparams
! arbitrarily take two values
params(i,1)=bestguess(i)+(bmax(i)-bestguess(i))
& *0.339354235d0
params(i,2)=bestguess(i)-(bestguess(i)-bmin(i))
& *0.339354235d0
enddo
endif
endif
call randpermut_dim_samp(msamptemp,nparams,
& params(1:nparams,1:msamptemp))
endif
msamptemp=msamptemp+1
do i=1,nparams
params(i,msamptemp)=bestguess(i)
enddo
do i=1,msamptemp
call sampfunc(nparams,params(1:nparams,i:i),ysamp(i))
enddo
ibest=1
ybest=ysamp(ibest)
do i=2,msamptemp
if(ysamp(i).lt.ybest)then
ibest=i
ybest=ysamp(i)
endif
enddo
do i=1,nparams
msamptemp=msamptemp+1
params(i,msamptemp)=params(i,ibest)+
& (bmax(i)-params(i,ibest))/(1.0d0+guessconfid)
msamptemp=msamptemp+1
params(i,msamptemp)=params(i,ibest)-
& (params(i,ibest)-bmin(i))/(1.0d0+guessconfid)
do j=1,i-1
params(j,msamptemp-1)=params(j,ibest)
params(j,msamptemp)=params(j,ibest)
enddo
do j=i+1,nparams
params(j,msamptemp-1)=params(j,ibest)
params(j,msamptemp)=params(j,ibest)
enddo
enddo
do i=msamptemp-2*nparams+1,msamptemp
call sampfunc(nparams,params(1:nparams,i:i),ysamp(i))
if(ysamp(i).lt.ybest)then
ibest=i
ybest=ysamp(i)
endif
enddo
do i=1,nparams
temp=params(i,1)
params(i,1)=params(i,ibest)
params(i,ibest)=temp
enddo
temp=ysamp(1)
ysamp(1)=ysamp(ibest)
ysamp(ibest)=temp
return
end
dataassim/math/optimization/shortestdist.f
+51
View File
@@ -0,0 +1,51 @@
subroutine shortestdist(my0,nx,pointy,
& pointx,xmin,xmax,nparams0,params0,
& iknowder0,shorty,shortx)
!find the point on the surface that has the shortest distance from a given point
implicit none
include 'leastdistance.h'
integer my0,nx,nparams0,iknowder0
double precision pointy(my0),shorty(my0),pointx(nx),
& shortx(nx),xmin(nx),xmax(nx),params0(nparams0)
!------------------Locals----------------------------------
integer i,iwhichsolver,idowhat,notfound
parameter(notfound=-9999)
double precision s2,s2cp,
& f1dimsqsum_distcenter,f1dims2_distcenter,
& shortf(nx),dydxp(my0,(nx+nparams0)),xtol,ftol
parameter(xtol=1.0d-10,ftol=1.0d-10)
external distcentersys,fsqsum_distcenter,
& f1dimsqsum_distcenter,s2_distcenter,
& f1dims2_distcenter
!----------------------------------------------------------
my=my0
nparams=nparams0
iknowder=iknowder0
do i=1,nx
targetx(i)=pointx(i)
enddo
do i=1,my
targety(i)=pointy(i)
enddo
do i=1,nparams
params(i)=params0(i)
enddo
call cpnonsyssolver(distcentersys,fsqsum_distcenter,
& f1dimsqsum_distcenter,xmin,pointx,shortx,xmax,
& shortf,nx,iwhichsolver)
if(iwhichsolver.eq.notfound)then
call s2_distcenter(nx,shortx,s2)
s2cp=s2
call cpnongradopt(nx,s2_distcenter,
& f1dims2_distcenter,shortx,xmin,xmax,ftol,s2)
if(dabs(s2cp-s2).gt.ftol)then
call cpRepeatCompassSearch(nx,shortx,s2,xmin,
& xmax,s2_distcenter,f1dims2_distcenter,xtol)
endif
endif
idowhat=0
call surffunc(my,shorty,nx,shortx,nparams,
& params,dydxp(1:my,1:(nx+nparams)),idowhat)
return
end subroutine shortestdist
!$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
dataassim/math/optimization/testregres.f
+20
View File
@@ -0,0 +1,20 @@
program test
implicit none
integer npoints,i
double precision x(100),y(100),z(100),A,B,D,
& ran2,fatbeta
A=0.009d0
B=0.01d0
D=0.2d0
npoints=100
do i=1,npoints
x(i)=3000.0d0*ran2()
y(i)=20.0d0*ran2()
z(i)=-D-A*x(i)-B*y(i)
enddo
A=1.0d0
B=1.0d0
D=1.0d0
call planarfit(npoints,x,y,z,A,B,D,fatbeta)
write(*,*)A,B,D,fatbeta
end